/usr/local/CPAN/Anarres-Mud-Driver/Anarres/Mud/Driver/Compiler/Check.pm
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;