view release on metacpan or  search on metacpan

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

# A lot of superclass methods. These are found in ::Check via @ISA.

sub lvaluep { undef; }
sub constp { undef; }

sub assert {	# This sucks somewhat
	my ($self, $type) = @_;
	if (!$self->type->equals(T_UNKNOWN)) {	# DEBUGGING
		confess "Asserting something of known type.";
	}
	print "Asserting " . $self->opcode . " into " . ${$type} . "\n";
	return new Anarres::Mud::Driver::Compiler::Node::IntAssert($self)
					if $type->equals(T_INTEGER);
	return new Anarres::Mud::Driver::Compiler::Node::StrAssert($self)
					if $type->equals(T_STRING);
	return new Anarres::Mud::Driver::Compiler::Node::ArrAssert($self)
					if $type->is_array;
	return new Anarres::Mud::Driver::Compiler::Node::MapAssert($self)
					if $type->is_mapping;
	return new Anarres::Mud::Driver::Compiler::Node::ClsAssert($self)
					if $type->equals(T_CLOSURE);
	return new Anarres::Mud::Driver::Compiler::Node::ObjAssert($self)
					if $type->equals(T_OBJECT);
	confess "Cannot assert node into type " . $$type . "!\n";
	return undef;
}

sub promote_to_block {
	my ($self, $stmt) = @_;

	return $stmt if ref($stmt) =~ /::Block$/;
	confess "Can only promote statements into blocks, not " .
			$stmt->opcode
					unless ref($stmt) =~ /::Stmt[^:]+$/;

	# It's a statement. This code is partially duplicated below.
	return new Anarres::Mud::Driver::Compiler::Node::Block(
					[],	# locals
					[ $stmt ]);
}

sub idx_promote_to_block {
	my ($self, $index) = @_;
	my $stmt = $self->value($index);
	my $block = $self->promote_to_block($stmt);
	$self->setvalue($index, $block);
	return $block;
}

# There is a special case of this in Integer.
sub promote {
	my ($self, $newtype) = @_;
	my $type = $self->type;
	# XXX Checking for T_UNKNOWN is wrong here. I need to check
	# whether the old type is 'weaker' than the new type.
	confess "XXX No type in " . $self->dump unless $type;
	return $self if $type->equals($newtype);
	$self->debug_tc(DBG_TC_PROMOTE, "Promoting ([" . $type->dump . "] ".
					$self->opcode . ") into " . $newtype->dump);

	# Anything can become 'unknown' - this allows weakening
	return $self if $type->compatible($newtype);

	# This should really be done by 'compatible'?
	return $self if $newtype->equals(T_BOOL);

	# The Assert nodes are broken for some reason?
	# return $self->assert($newtype) if $type->equals(T_UNKNOWN);
	return $self if $type->equals(T_UNKNOWN);	# Should assert

	return $self
		if $type->equals(T_INTEGER) && $newtype->equals(T_STRING);
	# return $type->promote($self, $newtype);
	return undef;
}

# This might return an undef in the error list in the case that an
# error occurred which has already been reported.
sub convert {
	my ($self, $program, @rest) = @_;

	my $opcode = $self->opcode;

	$self->debug_tc(DBG_TC_CONVERT, "Convert " . $self->opcode .
					" to " . $opcode);

	unless (ref $OPTYPES{$opcode}) {
		confess "XXX OPTYPES for $opcode is $OPTYPES{$opcode}"
				if $OPTYPES{$opcode};
		confess "XXX No OPTYPES for $opcode!";
	}

	my @values = $self->values;
	my @template = @{ $OPTYPES{$opcode} };
	my $rettype = pop(@template);

	unless (@values == @template) {
		# XXX This is for self-debugging.
		print STDERR "I have " . scalar(@values) . " values\n";
		print STDERR "I have " . scalar(@template) . " template\n";
		die "Child count mismatch in $opcode";
	}

	# We push undef into @errors to indicate that an error occurred
	# but should have been reported already at a lower level.

	my $i = 0;
	my @tvals = ();
	my @errors = ();
	foreach my $type (@template) {
		my $val = $values[$i];
		my ($tval, @assertions);

		# XXX I should promote unknown to anything, not
		# assert directly in convert.

		if (ref($type) eq 'ARRAY') {
			@assertions = @$type;
			$type = shift @assertions;
		}