102 lines
2.3 KiB
Perl
102 lines
2.3 KiB
Perl
|
#!/usr/bin/perl
|
||
|
|
#
|
||
|
|
|
||
|
|
package S2::NodeAssignExpr;
|
||
|
|
|
||
|
|
use strict;
|
||
|
|
use S2::Node;
|
||
|
|
use S2::NodeCondExpr;
|
||
|
|
use vars qw($VERSION @ISA);
|
||
|
|
|
||
|
|
$VERSION = '1.0';
|
||
|
|
@ISA = qw(S2::Node);
|
||
|
|
|
||
|
|
sub new {
|
||
|
|
my ($class, $n) = @_;
|
||
|
|
my $node = new S2::Node;
|
||
|
|
bless $node, $class;
|
||
|
|
}
|
||
|
|
|
||
|
|
sub canStart {
|
||
|
|
my ($class, $toker) = @_;
|
||
|
|
S2::NodeCondExpr->canStart($toker);
|
||
|
|
}
|
||
|
|
|
||
|
|
sub parse {
|
||
|
|
my ($class, $toker) = @_;
|
||
|
|
my $n = new S2::NodeAssignExpr;
|
||
|
|
|
||
|
|
$n->{'lhs'} = parse S2::NodeCondExpr $toker;
|
||
|
|
$n->addNode($n->{'lhs'});
|
||
|
|
|
||
|
|
if ($toker->peek() == $S2::TokenPunct::ASSIGN) {
|
||
|
|
$n->{'op'} = $toker->peek();
|
||
|
|
$n->eatToken($toker);
|
||
|
|
} else {
|
||
|
|
return $n->{'lhs'};
|
||
|
|
}
|
||
|
|
|
||
|
|
$n->{'rhs'} = parse S2::NodeAssignExpr $toker;
|
||
|
|
$n->addNode($n->{'rhs'});
|
||
|
|
|
||
|
|
return $n;
|
||
|
|
}
|
||
|
|
|
||
|
|
sub getType {
|
||
|
|
my ($this, $ck, $wanted) = @_;
|
||
|
|
|
||
|
|
my $lt = $this->{'lhs'}->getType($ck, $wanted);
|
||
|
|
my $rt = $this->{'rhs'}->getType($ck, $lt);
|
||
|
|
|
||
|
|
if ($lt->isReadOnly()) {
|
||
|
|
S2::error($this, "Left-hand side of assignment is a read-only value.");
|
||
|
|
}
|
||
|
|
|
||
|
|
if (! $this->{'lhs'}->isa('S2::NodeTerm') ||
|
||
|
|
! $this->{'lhs'}->isLValue()) {
|
||
|
|
S2::error($this, "Left-hand side of assignment must be an lvalue.");
|
||
|
|
}
|
||
|
|
|
||
|
|
if ($this->{'lhs'}->isBuiltinProperty($ck)) {
|
||
|
|
S2::error($this, "Can't assign to built-in properties.");
|
||
|
|
}
|
||
|
|
|
||
|
|
return $lt if $ck->typeIsa($rt, $lt);
|
||
|
|
|
||
|
|
# types don't match, but maybe class for left hand side has
|
||
|
|
# a constructor which takes a string.
|
||
|
|
if ($rt->equals($S2::Type::STRING) && $ck->isStringCtor($lt)) {
|
||
|
|
$rt = $this->{'rhs'}->getType($ck, $lt); # FIXME: can remove this line?
|
||
|
|
return $lt if $lt->equals($rt);
|
||
|
|
}
|
||
|
|
|
||
|
|
S2::error($this, "Can't assign type " . $rt->toString . " to " . $lt->toString);
|
||
|
|
}
|
||
|
|
|
||
|
|
sub asS2 {
|
||
|
|
my ($this, $o) = @_;
|
||
|
|
$this->{'lhs'}->asS2($o);
|
||
|
|
if ($this->{'op'}) {
|
||
|
|
$o->write(" = ");
|
||
|
|
$this->{'rhs'}->asS2($o);
|
||
|
|
}
|
||
|
|
}
|
||
|
|
|
||
|
|
sub asPerl {
|
||
|
|
my ($this, $bp, $o) = @_;
|
||
|
|
die "INTERNAL ERROR: no op?" unless $this->{'op'};
|
||
|
|
|
||
|
|
$this->{'lhs'}->asPerl($bp, $o);
|
||
|
|
|
||
|
|
my $need_notags = $bp->untrusted() &&
|
||
|
|
$this->{'lhs'}->isProperty() &&
|
||
|
|
$this->{'lhs'}->getType()->equals($S2::Type::STRING);
|
||
|
|
|
||
|
|
$o->write(" = ");
|
||
|
|
$o->write("S2::notags(") if $need_notags;
|
||
|
|
$this->{'rhs'}->asPerl($bp, $o);
|
||
|
|
$o->write(")") if $need_notags;
|
||
|
|
|
||
|
|
}
|
||
|
|
|