Anarres-Mud-Driver
view release on metacpan or search on metacpan
lib/Driver/Compiler/Check.pm view on Meta::CPAN
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
lib/Driver/Compiler/Check.pm view on Meta::CPAN
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.
lib/Driver/Compiler/Check.pm view on Meta::CPAN
}
}
{
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);
lib/Driver/Compiler/Check.pm view on Meta::CPAN
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);
( run in 0.881 second using v1.01-cache-2.11-cpan-5c0b1e786e0 )