view release on metacpan or  search on metacpan

lib/Driver/Compiler/Check.pm  view on Meta::CPAN

sub check_children {
	my ($self, $vals, @rest) = @_;

	my $ok = 1;

	foreach (@$vals) {
		next unless $_;		# We have some 'undef' statements.
		$_->check(@rest)
						or $ok = undef;
	}

	return $ok;
}

# A utility function called from various packages at boot time.
# It replaces code similar to the following in various packages.
#	my $package = __PACKAGE__;
#	$package =~ s/[^:]+$/Index/;
#	no strict qw(refs);
#	*lvaluep = \&{ "$package\::lvaluep" };

sub steal {
	my ($self, $victim, $subname) = @_;
	my $target = ref($self) || $self;
	my $source = $target;
	$source =~ s/[^:]+$/$victim/;
	no strict qw(refs);
	my $sub = \&{ "$source\::$subname" }
					or confess "No such sub $subname in $source";
	*{ "$target\::$subname" } = $sub;
}

# Now the node-specific packages.

{
	package Anarres::Mud::Driver::Compiler::Node::Nil;
	sub check { $_[0]->settype(T_NIL); $_[0]->setflag(F_CONST); 1; }
}

{
	package Anarres::Mud::Driver::Compiler::Node::String;
	sub check {$_[0]->settype(T_STRING); $_[0]->setflag(F_CONST); 1;}
}

{
	package Anarres::Mud::Driver::Compiler::Node::Integer;
	# This doesn't start/end since it can't fail.
	sub check {$_[0]->settype(T_INTEGER); $_[0]->setflag(F_CONST); 1;}
	sub promote {
		my ($self, $newtype, @rest) = @_;

		# Yes, a special case.
		if ($self->value(0) == 0) {	# A valid nil
			unless ($newtype->equals(T_INTEGER)) {
				my $nil = new Anarres::Mud::Driver::Compiler::Node::Nil;
				$nil->check;
				return $nil;
			}
		}

		return $self->SUPER::promote($newtype, @rest);
	}
}

{
	package Anarres::Mud::Driver::Compiler::Node::Array;
	sub check {
		my ($self, $program, @rest) = @_;

		$self->tc_start;

		my @values = $self->values;
		$self->check_children(\@values, $program, @rest)
						or return $self->tc_fail(T_ARRAY);

		my $flag = F_CONST;
		my $type = T_NIL;
		foreach (@values) {
			# Search the types to find a good type.
			$type = $_->type->unify($type);
			$flag &= $_->flags;
		}

		$self->settype($type->array);
		$self->setflag($flag) if $flag;

		return $self->tc_end;
	}
}

{
	package Anarres::Mud::Driver::Compiler::Node::Mapping;
	sub check {
		my ($self, $program, @rest) = @_;

		$self->tc_start;

		my @values = $self->values;
		$self->check_children(\@values, $program, @rest)
						or return $self->tc_fail(T_MAPPING);

		my $ret = 1;

		my $flag = F_CONST;
		my $type = T_NIL;
		my $idx = 0;
		foreach (@values) {
			# Search the types to find a good type.
			if ($idx & 1) {
				$type = $_->type->unify($type);
			}
			else {
				my $key = $_->promote(T_STRING);
				if ($key) {
					$self->setvalue($idx, $key);
				}
				else {
					$program->error("Map keys must be strings, not " .
									$_->dump);
					$ret = undef;
				}