File Coverage

blib/lib/Anarres/Mud/Driver/Compiler/Check.pm

Criterion	Covered	Total	%
statement	51	543	9.3
branch	1	246	0.4
condition	1	12	8.3
subroutine	16	74	21.6
pod	0	17	0.0
total	69	892	7.7

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
				)),

		(map { $_ => 'CODE' } qw(
			LogOr LogAnd
			LogOrEq LogAndEq
				)),

	IntEq		=> [ T_INTEGER, T_INTEGER,				T_BOOL ],
	IntNe		=> [ T_INTEGER, T_INTEGER,				T_BOOL ],
	IntGe		=> [ T_INTEGER, T_INTEGER,				T_BOOL ],
	IntLe		=> [ T_INTEGER, T_INTEGER,				T_BOOL ],
	IntGt		=> [ T_INTEGER, T_INTEGER,				T_BOOL ],
	IntLt		=> [ T_INTEGER, T_INTEGER,				T_BOOL ],

	IntAdd		=> [ T_INTEGER, T_INTEGER,				T_INTEGER ],
	IntSub		=> [ T_INTEGER, T_INTEGER,				T_INTEGER ],
	IntMul		=> [ T_INTEGER, T_INTEGER,				T_INTEGER ],
	IntDiv		=> [ T_INTEGER, T_INTEGER,				T_INTEGER ],
	IntMod		=> [ T_INTEGER, T_INTEGER,				T_INTEGER ],

	IntAnd		=> [ T_INTEGER, T_INTEGER,				T_INTEGER ],
	IntOr		=> [ T_INTEGER, T_INTEGER,				T_INTEGER ],
	IntXor		=> [ T_INTEGER, T_INTEGER,				T_INTEGER ],

	IntLsh		=> [ T_INTEGER, T_INTEGER,				T_INTEGER ],
	IntRsh		=> [ T_INTEGER, T_INTEGER,				T_INTEGER ],

	IntAddEq	=> [ LV(T_INTEGER), T_INTEGER,			T_INTEGER ],
	IntSubEq	=> [ LV(T_INTEGER), T_INTEGER,			T_INTEGER ],
	IntMulEq	=> [ LV(T_INTEGER), T_INTEGER,			T_INTEGER ],
	IntDivEq	=> [ LV(T_INTEGER), T_INTEGER,			T_INTEGER ],
	IntModEq	=> [ LV(T_INTEGER), T_INTEGER,			T_INTEGER ],

	IntAndEq	=> [ LV(T_INTEGER), T_INTEGER,			T_INTEGER ],
	IntOrEq		=> [ LV(T_INTEGER), T_INTEGER,			T_INTEGER ],
	IntXorEq	=> [ LV(T_INTEGER), T_INTEGER,			T_INTEGER ],

	IntLshEq	=> [ LV(T_INTEGER), T_INTEGER,			T_INTEGER ],
	IntRshEq	=> [ LV(T_INTEGER), T_INTEGER,			T_INTEGER ],


	StrEq		=> [ T_STRING, T_STRING,				T_BOOL ],
	StrNe		=> [ T_STRING, T_STRING,				T_BOOL ],
	StrGe		=> [ T_STRING, T_STRING,				T_BOOL ],
	StrLe		=> [ T_STRING, T_STRING,				T_BOOL ],
	StrGt		=> [ T_STRING, T_STRING,				T_BOOL ],
	StrLt		=> [ T_STRING, T_STRING,				T_BOOL ],

	StrAdd		=> [ T_STRING, T_STRING,				T_STRING ],
	StrMul		=> [ T_STRING, T_STRING,				T_STRING ],

	StrAddEq	=> [ LV(T_STRING), T_INTEGER,			T_INTEGER ],
	StrMulEq	=> [ LV(T_STRING), T_INTEGER,			T_INTEGER ],

	ArrEq		=> [ T_UNKNOWN->array, T_UNKNOWN->array,T_BOOL ],
	ArrNe		=> [ T_UNKNOWN->array, T_UNKNOWN->array,T_BOOL ],
		# ArrAdd and ArrSub are the target of the Add and Sub choices.
		(map { $_ => 'NOCHECK' } qw(
			ArrAdd ArrSub
			ArrOr ArrAnd
				)),

	MapEq		=> [ T_UNKNOWN->mapping, T_UNKNOWN->mapping, T_BOOL ],
	MapNe		=> [ T_UNKNOWN->mapping, T_UNKNOWN->mapping, T_BOOL ],
		# These are choice targets.
		(map { $_ => 'NOCHECK' } qw(
			MapAdd MapSub
				)),

	ObjEq		=> [ T_OBJECT, T_OBJECT,				T_BOOL ],
	ObjNe		=> [ T_OBJECT, T_OBJECT,				T_BOOL ],

		# These actually have custom choose routines.
		(map { $_ => 'CHOOSE' } qw(
			Index Range
				)),

	StrIndex	=> [ T_STRING, T_INTEGER, undef,		T_INTEGER ],
	StrRange	=> [ T_STRING, T_INTEGER, T_INTEGER, undef, undef,
														T_INTEGER ],
		# These are choice targets with nonstatic types
		(map { $_ => 'NOCHECK' } qw(
			ArrIndex ArrRange
			MapIndex
				)),
		# These have nonstatic types
		(map { $_ => 'CODE' } qw(
			Member New
				)),

	Catch		=> [ T_UNKNOWN,							T_STRING ],

	Assign		=> 'CODE',		# Output type is input type

	ExpCond		=> 'CODE',		# Output type is unification of input

	Block		=> 'CODE',		# Iterate over statements

	StmtExp		=> [ T_UNKNOWN,							T_VOID ],
	StmtRlimits => [ T_INTEGER, T_INTEGER, 'BLOCK',		T_VOID ],
	StmtTry		=> 'CODE',
	StmtCatch	=> [ 'BLOCK',							T_VOID ],

		# XXX These have to set up break and continue targets.
	StmtDo		=> [ T_BOOL, 'BLOCK',					T_VOID ],
	StmtWhile	=> [ T_BOOL, 'BLOCK',					T_VOID ],
	StmtFor		=> [ T_VOID, T_BOOL, T_VOID, 'BLOCK',	T_VOID ],
		(map { $_ => 'CODE' } qw(
			StmtForeach StmtForeachArr StmtForeachMap
				)),

		# StmtBreak also needs code to get the label.
		# Most of the flow control statements probably need code.
	StmtSwitch	=> 'CODE',		# Open a new switch context
	StmtCase	=> 'CODE',		# Generate a label
	StmtDefault	=> 'CODE',		# Sort out the labels
	StmtIf		=> 'CODE',		# Handle the 'else' clause!
	StmtBreak	=> 'CODE',		# Get the break target
	StmtContinue=> 'CODE',		# Get the continue target
	StmtReturn	=> 'CODE',		# Output type must match function

	Sscanf		=> 'CODE',		# Urgh!
);

	# This looks like a fast way of generating the choice table for
	# promotable operators, but does depend a little on the naming
	# of opcodes! If there are any special cases, they need to be put
	# into %OPCHOICES as literals. I'm going to get lynched for this.
{
	%OPCHOICES = ();
	no strict qw(refs);
	my $package = __PACKAGE__;
	$package =~ s/[^:]+$/Node/;
	foreach my $op (keys %OPTYPES) {
		next unless $OPTYPES{$op} eq 'CHOOSE';
		foreach my $tp (qw(Int Str Obj Arr Map)) {
			push(@{ $OPCHOICES{$op} }, "$tp$op") if $OPTYPES{"$tp$op"};
		}
	}
}
# We can't do this because we then don't pass the new opcode type
# in the case that we're calling the superclass method! Furthermore,
# the subclass method we actually try to call won't exist.
#			my $sub = \&{ "$package\::$tp$op::convert" }
#					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);
	}
	continue {
		$i++;
	}

	return @errors if @errors;

	# Hack the node gratuitously. Should I use 2+$#tvals?
	splice(@$self, 2, $#$self, @tvals);
	$self->settype($rettype);

	# We might also have a package change.
	my $package = ref($self);
	$package =~ s/::[^:]*$/::$opcode/;
	bless $self, $package;

	return ();
}

sub choose {
	my ($self, $program, @rest) = @_;

	$self->tc_start;

	my $opcode = $self->opcode;

	# If everything follows the pattern, or at least a large
	# amount of it does, then it would be worth iterating over
	# Int, Str, Arr, Map here instead of having OPCHOICES at all.
	# That might smell a bit more like black magic though.
	# Alternatively, I could embed the choices into the OPTYPES
	# table, but that might involve more magic stash hacking
	# to optimise.
	my @failures;
	foreach (@{ $OPCHOICES{$opcode} }) {
		$self->setopcode($_);
		my @errors = $self->convert($program, @rest);
		return $self->tc_end unless @errors;
		push(@failures, \@errors);
	}
	$self->setopcode($opcode);	# Might as well restore.

	# Make @errors contain only the error messages from the attempted
	# conversions which produced the fewest errors.
	my @counts;
	foreach (@failures) {
		push(@{ $counts[@$_] }, $_);
	}
	my $minimum = first { defined $_ } @counts;
	my @errors = map { @$_ } @$minimum;

	$program->error("Cannot convert $opcode into any available choice: "
					. Dumper(\@errors));

	return $self->tc_fail;
}

# Actually, this is kind of like an optimised 'choose'
sub convert_or_fail {
	my ($self, $program, @rest) = @_;
	$self->tc_start;
	my $opcode = $self->opcode;
	my @errors = $self->convert($program, @rest);
	return $self->tc_end unless @errors;
	# Remove errors which should have been reported already
	@errors = grep { defined $_ } @errors;
	$program->error("Failed to typecheck $opcode:\n\t" .
			join("\n\t", @errors))
					if @errors;
	return $self->tc_fail(T_FAILED);
}

# This doesn't call tc_start/tc_end because it modifies the stash
# in the class it's called in to point to another function. The
# superclass versions of those new functions must themselves call
# tc_start/tc_end.
sub check {
	my ($self, $program, @rest) = @_;

	if ($self->type) {
#		carp "Have already typechecked " . $self->opcode .
#						" " . (0+$self);
		return 1;
	}

	my $opcode = $self->opcode;
	my $subname = ref($self) . '::check';

	# We have to use can() here because some classes
	# have custom choose/convert overrides.

	if (ref($OPTYPES{$opcode}) eq 'ARRAY') {
		no strict qw(refs);
		*{ $subname } = $self->can('convert_or_fail');
		return $self->convert_or_fail($program, @rest);
	}
	elsif ($OPTYPES{$opcode} eq 'CHOOSE') {
		no strict qw(refs);
		*{ $subname } = $self->can('choose');
		return $self->choose($program, @rest);
	}
	elsif ($OPTYPES{$opcode} eq 'NOCHECK') {
		die "Cannot check NOCHECK opcode $opcode";
	}
	elsif ($OPTYPES{$opcode} eq 'CODE') {
		die "Cannot auto-check CODE opcode $opcode";
	}
	else {
		die "What is $OPTYPES{$opcode}?";
	}

	die "How did I get to the end of the superclass check() method?";
}

# This routine shouldn't be reporting. A failure should be reporting
# itself, with the parent from the typecheck stack.
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;
				}
			}

			$flag &= $_->flags;
			$idx++;
		}

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

		return $ret ? $self->tc_end : $self->tc_fail;
	}
}

{
	package Anarres::Mud::Driver::Compiler::Node::Closure;
	# XXX Write this.
	sub check {
		my ($self, $program, @rest) = @_;
		$self->tc_start;
		$self->setvalue(1, $program->closure($self));
		$self->settype(T_CLOSURE);
		return $self->tc_end;
	}
}

{
	package Anarres::Mud::Driver::Compiler::Node::Variable;
	sub lvaluep { 1; }
	# Look up type
	sub check {
		my ($self, $program, @rest) = @_;
		my $name = $self->value(0);
		$self->tc_start($name);
		my ($var, $class);
		confess "XXX No program" unless $program;
		if ($var = $program->local($name)) {
			$class = 'Anarres::Mud::Driver::Compiler::Node::VarLocal';
		}
		elsif ($var = $program->global($name)) {
			$class = 'Anarres::Mud::Driver::Compiler::Node::VarGlobal';
		}
		# elsif ($var = $program->static($name)) {
		#	$class ='Anarres::Mud::Driver::Compiler::Node::VarStatic';
		# }
		else {
			$program->error("Variable $name not found");
			# XXX Should we fake something up? We end up
			# dying later if we leave a Variable in the tree.
			return $self->tc_fail;
		}
		bless $self, $class;
		$self->settype($var->type);
		return $self->tc_end;
	}
	# XXX As an rvalue? Delegate to a basic type infer method.
	# XXX If it's an rvalue then it must be initialised. Also for ++, --
}

{
	package Anarres::Mud::Driver::Compiler::Node::VarStatic;
	sub lvaluep { 1; }
}

{
	package Anarres::Mud::Driver::Compiler::Node::VarGlobal;
	sub lvaluep { 1; }
}

{
	package Anarres::Mud::Driver::Compiler::Node::VarLocal;
	sub lvaluep { 1; }
}

{
	package Anarres::Mud::Driver::Compiler::Node::Parameter;
	sub lvaluep { 1; }
	# XXX We could look this up at the current point ...
	sub check { $_[0]->settype(T_UNKNOWN); return 1; }	# XXX Do this!
}

{
	package Anarres::Mud::Driver::Compiler::Node::Funcall;
	# Look up return type, number of args
	sub check {
		my ($self, $program, @rest) = @_;

		# Changing the format of this node will require modifications
		# to StmtIf optimisation.
		my @values = $self->values;
		my $method = shift @values;

		$self->tc_start('"' . $method->proto . '"');

		my @failed = ();
		my $ctr = 0;
		foreach (@values) {
			$_->check($program, @rest) or push(@failed, $ctr);
			$ctr++;
		}
		if (@failed) {
			$program->error("Failed to typecheck arguments @failed to "
							. $method->name);
			# XXX Wrong! Use the method's type. This should be some
			# sensible default in the case of overloads. If we don't
			# have overloads then we can evaluate the method's type
			# already. We don't need to check the child nodes yet.
			return $self->tc_fail(T_UNKNOWN);
		}

		unshift(@values, $method);
		# XXX Revisit typecheck_call fairly soon. It must report errors.
		my $type = $method->typecheck_call($program, \@values);
		return $self->tc_fail unless $type;
		$self->settype($type);
		return $self->tc_end;
	}
}

{
	package Anarres::Mud::Driver::Compiler::Node::CallOther;
	# XXX Look up return type?
	sub check {
		my ($self, $program, @rest) = @_;
		my ($exp, $name, @values) = $self->values;
		$self->tc_start;
		unshift(@values, $exp);
		$self->check_children(\@values, $program, @rest)
						or return $self->tc_fail;
		# XXX What if the lhs is type string?
		$self->settype(T_UNKNOWN);
		return $self->tc_end;
	}
}

{
	package Anarres::Mud::Driver::Compiler::Node::Index;
	sub lvaluep {	# XXX This should live in StrIndex or ArrIndex
		return 1 if $_[0]->flags & F_LVALUE;
		if ($_[0]->value(0)->lvaluep) {
			$_[0]->setflag(F_LVALUE);
			return 1;
		}
		return undef;
	}
}

{
	package Anarres::Mud::Driver::Compiler::Node::StrIndex;
	__PACKAGE__->steal("Index", "lvaluep");
}

{
	package Anarres::Mud::Driver::Compiler::Node::ArrIndex;
	__PACKAGE__->steal("Index", "lvaluep");

	# This isn't a 'sub check' because it's the target of a choice,
	# and therefore it can't issue errors because it's called
	# speculatively by the chooser.
	sub convert {
		my ($self, $program, @rest) = @_;
		my ($val, $idx) = $self->values;
		my @errors = ();

		$val->check($program, @rest)
			or push(@errors, "Failed to check value " . $val->opcode);
		$idx->check($program, @rest)
			or push(@errors, "Failed to check index " . $idx->opcode);
		$val->type->is_array
			or push(@errors, "Cannot perform array index on " .
							$val->type->name);
		$idx->type->equals(T_INTEGER)
			or push(@errors, "Cannot index on array with " .
							$idx->type->name);
		return @errors if @errors;
		$self->settype($val->type->dereference);
		bless $self, __PACKAGE__;
		return ();
	}
}

{
	package Anarres::Mud::Driver::Compiler::Node::MapIndex;
	__PACKAGE__->steal("Index", "lvaluep");

	sub convert {
		my ($self, $program, @rest) = @_;
		my ($val, $idx, $endp) = $self->values;
		my @errors = ();

		$val->check($program, @rest)
			or push(@errors, "Failed to check value " . $val->opcode);
		$idx->check($program, @rest)
			or push(@errors, "Failed to check index " . $idx->opcode);
		$val->type->is_mapping
			or push(@errors, "Cannot perform mapping dereference on " .
							$val->type->name);
		# XXX Make this use promotion properly.
		$idx->type->equals(T_STRING)
			||
		$idx->type->equals(T_INTEGER)
			or push(@errors, "Cannot index on mapping with " .
							$idx->type->name);
		return @errors if @errors;
		$endp
			and $program->error("Cannot index from end of mapping");
		$self->settype($val->type->dereference);
		bless $self, __PACKAGE__;
		return ();
	}
}

{
	package Anarres::Mud::Driver::Compiler::Node::Member;
	sub lvaluep {
		if ($_[0]->value(0)->lvaluep) {
			$_[0]->setflag(F_LVALUE);
			return 1;
		}
		return undef;
	}

	sub check {
		my ($self, $program, @rest) = @_;
		$self->tc_start;
		my ($value, $field) = $self->values;
		$value->check($program, @rest)
						or return $self->tc_fail;
		my $type = $value->type;
		if (!($type->is_class)) {
			$program->error("Cannot get member $field of type " .
							$type->name);
			# print STDERR "Failed fragment is " . $value->dump, "\n";
			return $self->tc_fail;
		}
		elsif (0) {	# XXX Does the field exist?
			$program->error("No field called $field in class " .
							$type->class);
			return $self->tc_fail;
		}
		my $ftype = $program->class_field_type($type->class, $field);
		$self->settype($ftype);	# Might be T_FAILED
		return $self->tc_end;
	}
}

{
	package Anarres::Mud::Driver::Compiler::Node::New;
	sub check {
		my ($self, $program, $flags, @rest) = @_;
		my $cname = $self->value(0);
		$self->tc_start("class $cname");
		my $type = $program->class_type($cname);
		$self->settype($type);	# Might be T_FAILED
		return $self->tc_end;
	}
}

# 1. Promote things to blocks.
# 2. Check children
# 3. Check that things are lvalues.
# 4. Check that things are appropriate types.
# 5. Rebless the current node.
# 6. Set the type of the current node.
# 7. Return a success or failure.

{
	package Anarres::Mud::Driver::Compiler::Node::Sscanf;
	# This should be $_[1], @{$_[2]}
	sub check {
		my ($self, $program, $flags, @rest) = @_;
		my @values = $self->values;
		$self->tc_start;
		$self->check_children(\@values, $program, @rest)
						or return $self->tc_fail(T_INTEGER);

		my $exp = shift @values;
		my $fmt = shift @values;

		my $sexp = $exp->promote(T_STRING);
		unless ($sexp) {
			$program->error("Input for sscanf must be string, not " .
							${ $exp->type });
			return $self->tc_fail(T_INTEGER);
		}
		$self->setvalue(0, $sexp);

		my $sfmt = $fmt->promote(T_STRING);
		unless ($sfmt) {
			$program->error("Format for sscanf must be string, not " .
							$fmt->type->dump);
			return $self->tc_fail(T_INTEGER);
		}
		$self->setvalue(1, $sfmt);

		$self->settype(T_INTEGER);
		return $self->tc_end;
	}
}

{
	package Anarres::Mud::Driver::Compiler::Node::Assign;
	sub check {
		my ($self, $program, @rest) = @_;
		my ($lval, $exp) = $self->values;

		$self->tc_start;

		$self->check_children([ $lval, $exp ], $program, @rest)
						or return $self->tc_fail($exp->type);
		unless ($lval->lvaluep) {
			$program->error("lvalue to assign is not an lvalue");
			return $self->tc_fail($exp->type);
		}

		# XXX Use "compatible"
		my $rval = $exp->promote($lval->type);
		unless ($rval) {
			my $dump = $lval->dump;
			$dump =~ s/\s+/ /g;
			$program->error("Cannot assign type " .
							$exp->type->name . " to lvalue " .
							$dump ." of type ". $lval->type->name);
			# Assign always takes the type of the lvalue.
			return $self->tc_fail($lval->type);
		}

		# Perhaps this ought to be the more specific of the two types.

		$self->setvalue(1, $rval);
		$self->settype($rval->type);	# More accurate than lval->type

		return $self->tc_end;
	}
}

{
	package Anarres::Mud::Driver::Compiler::Node::LogAnd;
	sub check {
		my ($self, $program, @rest) = @_;
		my ($lval, $rval) = $self->values;
		$self->tc_start;
		my $ret = 1;
		$lval->check($program, @rest) or $ret = undef;
		$rval->check($program, @rest) or $ret = undef;
		return $self->tc_fail unless $ret;
		$self->settype($lval->type->unify($rval->type));
		return $self->tc_end;
	}
}

{
	package Anarres::Mud::Driver::Compiler::Node::LogOr;
	__PACKAGE__->steal("LogAnd", "check");
}

{
	package Anarres::Mud::Driver::Compiler::Node::LogAndEq;
	sub check {
		my ($self, $program, @rest) = @_;
		my ($lval, $rval) = $self->values;
		$self->tc_start;
		my $ret = 1;
		$lval->check($program, @rest) or $ret = undef;
		$rval->check($program, @rest) or $ret = undef;
		return $self->tc_fail unless $ret;
		unless ($lval->lvaluep) {
			$program->error("Lvalue to logical assignment is not an lvalue.");
			return $self->tc_fail;
		}
		$self->settype($lval->type->unify($rval->type));
		return $self->tc_end;
	}
}

{
	package Anarres::Mud::Driver::Compiler::Node::LogOrEq;
	__PACKAGE__->steal("LogAndEq", "check");
}

{
	package Anarres::Mud::Driver::Compiler::Node::ArrAdd;
	sub convert {
		my ($self, @rest) = @_;
		my ($left, $right) = $self->values;
		my @errors = ();
		$self->check_children([ $left, $right ], @rest)
						or return $self->tc_fail(T_ARRAY);
		# This should use compatible() or can_promote() or something.
		$left->type->is_array
			or push(@errors, "LHS of array add is not an array");
		$right->type->is_array
			or push(@errors, "RHS of array add is not an array");
		return @errors if @errors;
		$self->settype($right->type->unify($right->type));
		return ();
	}
}

{
	package Anarres::Mud::Driver::Compiler::Node::ArrSub;
	sub convert {
		my ($self, @rest) = @_;
		my ($left, $right) = $self->values;
		my @errors = ();
		$self->check_children([ $left, $right ], @rest)
						or return $self->tc_fail(T_ARRAY);
		# This should use compatible() or can_promote() or something.
		$left->type->is_array
			or push(@errors, "LHS of array add is not an array");
		$right->type->is_array
			or push(@errors, "RHS of array add is not an array");
		return @errors if @errors;
		$self->settype($left->type);
		return ();
	}
}

{
	package Anarres::Mud::Driver::Compiler::Node::ArrOr;
	__PACKAGE__->steal("ArrAdd", "check");
}

{
	package Anarres::Mud::Driver::Compiler::Node::ArrAnd;
	__PACKAGE__->steal("ArrSub", "check");
}

{
	package Anarres::Mud::Driver::Compiler::Node::MapAdd;
	sub convert {
		my ($self, @rest) = @_;
		my ($left, $right) = $self->values;
		my @errors = ();
		$self->check_children([ $left, $right ], @rest)
						or return ("Failed to check children");
		# This should use compatible() or can_promote() or something.
		$left->type->is_mapping
			or push(@errors, "LHS of mapping add is not an mapping");
		$right->type->is_mapping
			or push(@errors, "RHS of mapping add is not an mapping");
		return @errors if @errors;
		$self->settype($right->type->unify($right->type));
		return ();
	}
}

{
	package Anarres::Mud::Driver::Compiler::Node::ExpComma;
	sub check {
		my ($self, @rest) = @_;
		my ($left, $right) = $self->values;
		$self->tc_start;
		$self->check_children([ $left, $right ], @rest)
						or return $self->tc_fail($right->type);
		$self->settype($right->type);
		return $self->tc_end;
	}
}

{
	package Anarres::Mud::Driver::Compiler::Node::ExpCond;
	sub check {
		my ($self, @rest) = @_;
		my ($cond, $left, $right) = $self->values;
		$self->tc_start;
		$self->check_children([ $cond, $left, $right ], @rest)
						or return $self->tc_fail;
		# XXX Check that cond is a boolean.
		$self->settype($right->type->unify($left->type));
		return $self->tc_end;
	}
}

{
	package Anarres::Mud::Driver::Compiler::Node::Block;
	# The funny thing about blocks is that no type information goes
	# into or out of them. If a subnode fails to check, it will
	# always fail to check. Therefore, if the block fails, there
	# is never any point in rechecking it. Since the fact of the
	# failure is already recorded, there is no point returning it
	# recursively from here. So we always call $self->tc_end.
	# XXX This is a caveat and should be noted in case we try to
	# do a fuller unification algorithm which infers types on
	# variables or closures. For this reason, we temporarily let
	# it fail.
	sub check {
		my ($self, $program, @rest) = @_;
		my $ret = 1;

		$self->tc_start;

		$program->save_locals;
		foreach (@{ $self->value(0) }) {	# Local variables
			$program->local($_->name, $_);
		}
		foreach (@{ $self->value(1) }) {	# Statements
			$_->check($program, @rest)
					or $ret = undef;
		}
		$program->restore_locals;

		$self->settype(T_VOID);
		return $ret ? $self->tc_end : $self->tc_fail(T_VOID);
	}
}

{
	package Anarres::Mud::Driver::Compiler::Node::StmtForeach;
	# This method does a lot of the common stuff for the two
	# 'subclasses'. I could alternatively use a 'choose' here...
	sub check {
		my ($self, $program, @rest) = @_;
		my $ret;
		$self->tc_start;

		# Actually, I can rebless before I check the children!
		if ($self->value(1)) {	# Second lvalue
			bless $self, ref($self) . "Map";
		}
		else {
			bless $self, ref($self) . "Arr";
		}
		$self->settype(T_VOID);

		$self->idx_promote_to_block(3);
		my @values = $self->values;
		$self->check_children(\@values, $program, @rest)
						or return undef;

		return $self->check($program, @rest);
	}
}

{
	package Anarres::Mud::Driver::Compiler::Node::StmtForeachArr;
	sub check {
		my ($self, $program, @rest) = @_;
		my ($lv0, undef, $rv) = $self->values;

		unless ($lv0->lvaluep) {
			$program->error("foreach key lvalue must be an lvalue");
			return $self->tc_fail(T_VOID);
		}

		# Check that $rv->type->deref->compatible($lv0->type)

		return $self->tc_end;
	}
}

{
	package Anarres::Mud::Driver::Compiler::Node::StmtForeachMap;
	sub check {
		my ($self, $program, @rest) = @_;
		my ($lv0, $lv1, $rv) = $self->values;

		unless ($lv0->lvaluep) {
			$program->error("foreach key lvalue must be an lvalue");
			return $self->tc_fail(T_VOID);
		}
		unless ($lv0->type->equals(T_STRING)) {
			$program->error("foreach key lvalue must be type string");
			return $self->tc_fail(T_VOID);
		}

		# Check that $rv->type->deref->compatible($lv1->type)

		return $self->tc_end;
	}
}

{
	package Anarres::Mud::Driver::Compiler::Node::StmtSwitch;
	sub check {
		my ($self, $program, @rest) = @_;
		my ($exp, $block) = $self->values;
		my $ret = 1;
		$self->tc_start;
		$exp->check($program, @rest)
						or $ret = undef;
		my $tgt_break = $program->switch_start($exp->type);
		$self->setvalue(2, $tgt_break);		# end of switch
		$block->check($program, @rest)
						or $ret = undef;
		my $data = $program->switch_end;
		$self->setvalue(3, $data->[0]);	# labels
		$self->setvalue(4, $data->[1]);	# default
		$self->settype(T_VOID);
		return $ret ? $self->tc_end : $self->tc_fail(T_VOID);
	}
}

{
	package Anarres::Mud::Driver::Compiler::Node::StmtCase;
	sub check {
		my ($self, $program, @rest) = @_;
		my $case = $self->value(0);
		$self->tc_start;
		$case->check($program, @rest)
						or return $self->tc_fail(T_VOID);
		unless ($case->constp) {
			$program->error("'case' value is not constant");
			return $self->tc_fail(T_VOID);
		}
		$self->setvalue(2, $program->label($case));
		$self->settype(T_VOID);
		return $self->tc_end;
	}
}

{
	package Anarres::Mud::Driver::Compiler::Node::StmtDefault;
	sub check {
		my ($self, $program, @rest) = @_;
		$self->tc_start;
		$self->setvalue(0, $program->default);
		$self->settype(T_VOID);
		return $self->tc_end;
	}
}

{
	package Anarres::Mud::Driver::Compiler::Node::StmtBreak;
	sub check {
		my ($self, $program, @rest) = @_;
		$self->tc_start;
		$self->setvalue(0, $program->getbreaktarget);
		$self->settype(T_VOID);
		return $self->tc_end;
	}
}

{
	package Anarres::Mud::Driver::Compiler::Node::StmtContinue;
	sub check {
		my ($self, $program, @rest) = @_;
		$self->tc_start;
		# XXX Do this.
		# $self->setvalue(0, $program->getbreaktarget);
		$self->settype(T_VOID);
		return $self->tc_end;
	}
}

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

		$self->idx_promote_to_block(1);
		# Allow the 'elsif' perlism.
		if ($self->value(2) and (ref($self->value(2)) !~ /::StmtIf$/)) {
			# Would it be better to do this in the code generator?
			$self->idx_promote_to_block(2);
		}

		my ($cond, $if, $else) = $self->values;
		my $ret = 1;

		$cond->check($program, @rest)
						or $ret = undef;

#		# Now we inspect $cond and set hints. However, this is wrong
#		# in the 'else' block!
#		if (ref($cond) =~ /::Funcall$/) {
#			my $method = $cond->value(0);
#			my $name = $method->name;
#			# intp, stringp, boolp, objectp, classp, arrayp, mapp
#			if ($name =~ /(?:int|string|bool|object|class|array|map)p/){
#				print "Hinting conditional: Call to $name\n";
#			}
#		}

		$if->check($program, @rest)
						or $ret = undef;

		if ($else) {
			# Reverse the hint

			$else->check($program, @rest)
							or $ret = undef;
		}

		$_[0]->settype(T_VOID);
		return $ret ? $self->tc_end : $self->tc_fail(T_VOID);
	}
}

{
	package Anarres::Mud::Driver::Compiler::Node::StmtReturn;
	sub check {
		my ($self, $program, @rest) = @_;
		$self->tc_start;
		my $val = $self->value(0);
		if ($val) {
			$val->check($program, @rest)
							or return $self->tc_fail(T_VOID);
		}
		# XXX Check that the returned type is compatible with the
		# function type.
		$self->settype(T_VOID);
		return $self->tc_end;
	}
}

{
	package Anarres::Mud::Driver::Compiler::Node::StmtTry;
	sub check {
		my ($self, $program, @rest) = @_;
		$self->tc_start;
		my @values = $self->values;
		my $ret = 1;
		$self->check_children(\@values, $program, @rest)
						or return $self->tc_fail(T_VOID);
		unless ($values[1]->lvaluep) {
			$program->error("'catch' lvalue must be an lvalue");
			return $self->tc_fail(T_VOID);
		}
		$self->settype(T_VOID);
		return $ret ? $self->tc_end : $self->tc_fail(T_VOID);
	}
}

# print STDERR Dumper(\%OPCHOICES);

if (1) {
	use strict;

	my $package = __PACKAGE__;
	$package =~ s/::Check$/::Node/;
	no strict qw(refs);
	my @missing;
	my @nochoice;
	my @nocode;
	my @spurious;
	my @oldcheck;
	foreach (@NODETYPES) {
		push(@oldcheck, $_) if defined &{"$package\::$_\::OLD_check"};
		my $tpt = $OPTYPES{$_};
		if ($tpt ne 'CODE') {
			push(@spurious, $_) if defined &{"$package\::$_\::check"};
		}
		next if ref($tpt) eq 'ARRAY';
		next if $tpt eq 'NOCHECK';
		if ($tpt eq 'CODE') {
			push(@nocode, $_) unless defined &{"$package\::$_\::check"};
			next;
		}
		if ($tpt eq 'CHOOSE') {
			push(@nochoice, $_) unless $OPCHOICES{$_};
			next;
		}
		push(@missing, $_);
	}
	print "OLD code for check in @oldcheck\n" if @oldcheck;
	print "Spurious code for check in @spurious\n" if @spurious;
	print "No code for check in @nocode\n" if @nocode;
	print "No choices for check in @nochoice\n" if @nochoice;
	print "No check in @missing\n" if @missing;
}

1;