102 lines
2.3 KiB
Perl
Executable File
102 lines
2.3 KiB
Perl
Executable File
#!/usr/bin/perl
|
|
#
|
|
|
|
package S2::NodeSet;
|
|
|
|
use strict;
|
|
use S2::Node;
|
|
use S2::NodeExpr;
|
|
use vars qw($VERSION @ISA);
|
|
|
|
$VERSION = '1.0';
|
|
@ISA = qw(S2::Node);
|
|
|
|
sub new {
|
|
my ($class) = @_;
|
|
my $node = new S2::Node;
|
|
bless $node, $class;
|
|
}
|
|
|
|
sub canStart {
|
|
my ($class, $toker) = @_;
|
|
return $toker->peek() == $S2::TokenKeyword::SET;
|
|
}
|
|
|
|
sub parse {
|
|
my ($class, $toker) = @_;
|
|
|
|
my $nkey; # NodeText
|
|
my $ns = new S2::NodeSet;
|
|
|
|
$ns->setStart($ns->requireToken($toker, $S2::TokenKeyword::SET));
|
|
|
|
$nkey = parse S2::NodeText $toker;
|
|
$ns->addNode($nkey);
|
|
$ns->{'key'} = $nkey->getText();
|
|
|
|
$ns->requireToken($toker, $S2::TokenPunct::ASSIGN);
|
|
|
|
$ns->{'value'} = parse S2::NodeExpr $toker;
|
|
$ns->addNode($ns->{'value'});
|
|
|
|
$ns->requireToken($toker, $S2::TokenPunct::SCOLON);
|
|
return $ns;
|
|
}
|
|
|
|
|
|
sub asS2 {
|
|
my ($this, $o) = @_;
|
|
$o->tabwrite("set ");
|
|
$o->write(S2::Backend->quoteString($this->{'key'}));
|
|
$o->write(" = ");
|
|
$this->{'value'}->asS2($o);
|
|
$o->writeln(";");
|
|
}
|
|
|
|
sub check {
|
|
my ($this, $l, $ck) = @_;
|
|
|
|
my $ltype = $ck->propertyType($this->{'key'});
|
|
$ck->setInFunction(0);
|
|
|
|
unless ($ltype) {
|
|
S2::error($this, "Can't set non-existent property '$this->{'key'}'");
|
|
}
|
|
|
|
my $rtype = $this->{'value'}->getType($ck, $ltype);
|
|
|
|
unless ($ltype->equals($rtype)) {
|
|
my $lname = $ltype->toString;
|
|
my $rname = $rtype->toString;
|
|
S2::error($this, "Property value is of wrong type. Expecting $lname but got $rname.");
|
|
}
|
|
|
|
if ($ck->propertyBuiltin($this->{'key'})) {
|
|
S2::error($this, "Can't set built-in properties");
|
|
}
|
|
|
|
# simple case... assigning a primitive
|
|
if ($ltype->isPrimitive()) {
|
|
# TODO: check that value.isLiteral()
|
|
# TODO: check value's type matches
|
|
return;
|
|
}
|
|
|
|
my $base = new S2::Type $ltype->baseType();
|
|
if ($base->isPrimitive()) {
|
|
return;
|
|
} elsif (! defined $ck->getClass($ltype->baseType())) {
|
|
S2::error($this, "Can't set property of unknown type");
|
|
}
|
|
}
|
|
|
|
sub asPerl {
|
|
my ($this, $bp, $o) = @_;
|
|
$o->tabwrite("register_set(" .
|
|
$bp->getLayerIDString() . "," .
|
|
$bp->quoteString($this->{'key'}) . ",");
|
|
$this->{'value'}->asPerl($bp, $o);
|
|
$o->writeln(");");
|
|
return;
|
|
}
|