view release on metacpan or  search on metacpan

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

package Anarres::Mud::Driver::Compiler::Check;

use strict;
use vars qw(@ISA @EXPORT_OK @STACK $DEBUG
		%OPTYPETABLE %OPTYPES %OPCHOICES);
use Carp qw(:DEFAULT cluck);
use Data::Dumper;
use List::Util qw(first);
use Anarres::Mud::Driver::Compiler::Type qw(:all);
use Anarres::Mud::Driver::Compiler::Node qw(:all);

# This has turned into a rather long, complex and involved Perl file.

# Error messages starting with [D] are duplicating work done elsewhere
# and are candidates for removal.

push(@Anarres::Mud::Driver::Compiler::Node::ISA, __PACKAGE__);

sub DBG_TC_NAME		() { 1 }
sub DBG_TC_PROMOTE	() { 2 }
sub DBG_TC_CONVERT	() { 4 }

$DEBUG = 0;;
$DEBUG |= DBG_TC_NAME		if 0;
$DEBUG |= DBG_TC_PROMOTE	if 0;
$DEBUG |= DBG_TC_CONVERT	if 0;

@STACK = ();

sub debug_tc {
	my ($self, $class, @args) = @_;
	return undef unless $DEBUG & $class;
	my $msg = join(": ", @args);
	print STDERR "DebugTC: $msg\n";
}

# Called at the beginning of any typecheck call
sub tc_start {
	my ($self, @args) = @_;
	push(@STACK, $self);
	$self->debug_tc(DBG_TC_NAME, "Checking " . $self->opcode, @args);
}

# Called at the end of any typecheck call, possibly by tc_fail().
sub tc_end {
	my ($self, $type, @args) = @_;
	$self->settype($type) if $type;
	$self->debug_tc(DBG_TC_NAME, "Finished " . $self->opcode, @args);
	pop(@STACK);
	return 1;	# Make it return a success.
}

	# This is a utility method. Calling it is mandatory
	# in the case of failure.
sub tc_fail {
	my ($self, $type, @args) = @_;
	$type = T_FAILED unless $type;
	$self->tc_end($type, @args);
	return undef;	# Make it return a failure.
}




sub LV ($) { return [ $_[0], F_LVALUE ] }

# Opcodes which are choice targets and provide a custom convert
# are marked up as 'NOCHECK'.

%OPTYPES = (
	StmtNull	=> [									T_VOID ],
	ExpComma	=> 'CODE',

		(map { $_ => 'NOCHECK' } qw(
			IntAssert StrAssert ArrAssert MapAssert ClsAssert ObjAssert
			ToString
				)),

	# It's faster to give these two custom code as well.
	# Nil			=> [								T_NIL ],
	# String		=> [								T_STRING ],
		(map { $_ => 'CODE' } qw(
			Nil String Integer Array Mapping Closure Variable Parameter
			Funcall CallOther
				)),
		(map { $_ => 'NOCHECK' } qw(
			VarStatic VarGlobal VarLocal
				)),

	Unot		=> [ T_UNKNOWN,							T_BOOL ],
	Tilde		=> [ T_INTEGER,							T_INTEGER ],
	Plus		=> [ T_INTEGER,							T_INTEGER ],
	Minus		=> [ T_INTEGER,							T_INTEGER ],

	Postinc		=> [ LV(T_INTEGER),						T_INTEGER ],
	Postdec		=> [ LV(T_INTEGER),						T_INTEGER ],
	Preinc		=> [ LV(T_INTEGER),						T_INTEGER ],
	Predec		=> [ LV(T_INTEGER),						T_INTEGER ],
		(map { $_ => 'CHOOSE' } qw(
			Eq Ne Lt Gt Le Ge

			Add Sub Mul Div Mod
			Or And Xor
			Lsh Rsh

			AddEq SubEq DivEq MulEq ModEq
			AndEq OrEq XorEq
			LshEq RshEq

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

#					or die "No 'convert' in package $package\::$tp$op";


# 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;
		}

		if (!defined $type) {
			$tval = $val;
		}
		elsif ($type eq 'BLOCK') {
			$tval = $self->promote_to_block($val);
			$tval->check($program, @rest)
							or push(@errors, undef);
		}
		else {
			if (!$val->check($program, @rest)) {
				push(@errors, undef);
			}
			elsif (!($tval = $val->promote($type))) {
				push(@errors, "Cannot promote " . $val->opcode .
								" from " . $val->type->name .
								" to " . $type->name .
								" for argument $i of " . $self->opcode);
			}
		}

		# return undef unless $tval;

		# XXX Perform assertions.
		foreach (@assertions) {
			if ($_ == F_LVALUE) {
				unless ($tval->lvaluep) {
					push(@errors, $val->opcode . " is not an lvalue in "
									. $self->opcode);
				}
			}
			else {
				die "Unknown assertion $_!";
			}
		}

		push(@tvals, $tval);
	}