init
This commit is contained in:
75
wcmtools/s2/S2/BackendHTML.pm
Executable file
75
wcmtools/s2/S2/BackendHTML.pm
Executable file
@@ -0,0 +1,75 @@
|
||||
#!/usr/bin/perl
|
||||
#
|
||||
|
||||
package S2::BackendHTML;
|
||||
|
||||
use strict;
|
||||
|
||||
use vars qw($CommentColor $IdentColor $KeywordColor
|
||||
$StringColor $PunctColor $BracketColor $TypeColor
|
||||
$VarColor $IntegerColor);
|
||||
|
||||
$CommentColor = "#008000";
|
||||
$IdentColor = "#000000";
|
||||
$KeywordColor = "#0000FF";
|
||||
$StringColor = "#008080";
|
||||
$PunctColor = "#000000";
|
||||
$BracketColor = "#800080";
|
||||
$TypeColor = "#000080";
|
||||
$VarColor = "#000000";
|
||||
$IntegerColor = "#000000";
|
||||
|
||||
sub new {
|
||||
my ($class, $l) = @_;
|
||||
my $this = {
|
||||
'layer' => $l,
|
||||
};
|
||||
bless $this, $class;
|
||||
}
|
||||
|
||||
sub output {
|
||||
my ($this, $o) = @_;
|
||||
|
||||
$o->write("<html><head><title>Layer Source</title>\n");
|
||||
$o->write("<meta http-equiv=\"Content-Type\" content=\"text/html; charset=utf-8\">\n");
|
||||
$o->write("<style type=\"text/css\">\n");
|
||||
$o->write("body { background: #ffffff none; color: #000000; }\n");
|
||||
$o->write(".c { background: #ffffff none; color: " . $CommentColor . "; }\n");
|
||||
$o->write(".i { background: #ffffff none; color: " . $IdentColor . "; }\n");
|
||||
$o->write(".k { background: #ffffff none; color: " . $KeywordColor . "; }\n");
|
||||
$o->write(".s { background: #ffffff none; color: " . $StringColor . "; }\n");
|
||||
$o->write(".p { background: #ffffff none; color: " . $PunctColor . "; }\n");
|
||||
$o->write(".b { background: #ffffff none; color: " . $BracketColor . "; }\n");
|
||||
$o->write(".t { background: #ffffff none; color: " . $TypeColor . "; }\n");
|
||||
$o->write(".v { background: #ffffff none; color: " . $VarColor . "; }\n");
|
||||
$o->write(".n { background: #ffffff none; color: " . $IntegerColor . "; }\n");
|
||||
$o->write("</style></head>\n<body>\n<pre>");
|
||||
my $nodes = $this->{'layer'}->getNodes();
|
||||
foreach my $n (@$nodes) {
|
||||
my $dbg = "Doing node: " . ref($n);
|
||||
if (ref $n eq "S2::NodeFunction") {
|
||||
$dbg .= " (" . $n->getName() . ")";
|
||||
if ($n->getName() eq "print_body") {
|
||||
#use Data::Dumper;
|
||||
#$dbg .= Dumper($n->{'tokenlist'});
|
||||
}
|
||||
}
|
||||
#Apache->request->log_error($dbg);
|
||||
#print $dbg;
|
||||
|
||||
$n->asHTML($o);
|
||||
}
|
||||
$o->write("</pre></body></html>"); $o->newline();
|
||||
}
|
||||
|
||||
sub quoteHTML {
|
||||
shift if ref $_[0];
|
||||
my $s = shift;
|
||||
$s =~ s/&/&/g;
|
||||
$s =~ s/</</g;
|
||||
$s =~ s/>/>/g;
|
||||
$s;
|
||||
}
|
||||
|
||||
|
||||
1;
|
||||
62
wcmtools/s2/S2/BackendPerl.pm
Executable file
62
wcmtools/s2/S2/BackendPerl.pm
Executable file
@@ -0,0 +1,62 @@
|
||||
#!/usr/bin/perl
|
||||
#
|
||||
|
||||
package S2::BackendPerl;
|
||||
|
||||
use strict;
|
||||
use S2::Indenter;
|
||||
|
||||
sub new {
|
||||
my ($class, $l, $layerID, $untrusted) = @_;
|
||||
my $this = {
|
||||
'layer' => $l,
|
||||
'layerID' => $layerID,
|
||||
'untrusted' => $untrusted,
|
||||
'package' => '',
|
||||
};
|
||||
bless $this, $class;
|
||||
}
|
||||
|
||||
sub getBuiltinPackage { shift->{'package'}; }
|
||||
sub setBuiltinPackage { my $t = shift; $t->{'package'} = shift; }
|
||||
|
||||
sub getLayerID { shift->{'layerID'}; }
|
||||
sub getLayerIDString { shift->{'layerID'}; }
|
||||
|
||||
sub untrusted { shift->{'untrusted'}; }
|
||||
|
||||
sub output {
|
||||
my ($this, $o) = @_;
|
||||
my $io = new S2::Indenter $o, 4;
|
||||
|
||||
$io->writeln("#!/usr/bin/perl");
|
||||
$io->writeln("# auto-generated Perl code from input S2 code");
|
||||
$io->writeln("package S2;");
|
||||
$io->writeln("use strict;");
|
||||
$io->writeln("use constant VTABLE => 0;");
|
||||
$io->writeln("use constant STATIC => 1;");
|
||||
$io->writeln("use constant PROPS => 2;");
|
||||
$io->writeln("register_layer($this->{'layerID'});");
|
||||
my $nodes = $this->{'layer'}->getNodes();
|
||||
foreach my $n (@$nodes) {
|
||||
$n->asPerl($this, $io);
|
||||
}
|
||||
$io->writeln("1;");
|
||||
$io->writeln("# end.");
|
||||
}
|
||||
|
||||
sub quoteString {
|
||||
shift if ref $_[0];
|
||||
my $s = shift;
|
||||
return "\"" . quoteStringInner($s) . "\"";
|
||||
}
|
||||
|
||||
sub quoteStringInner {
|
||||
my $s = shift;
|
||||
$s =~ s/([\\\$\"\@])/\\$1/g;
|
||||
$s =~ s/\n/\\n/g;
|
||||
return $s;
|
||||
}
|
||||
|
||||
|
||||
1;
|
||||
367
wcmtools/s2/S2/Checker.pm
Executable file
367
wcmtools/s2/S2/Checker.pm
Executable file
@@ -0,0 +1,367 @@
|
||||
#!/usr/bin/perl
|
||||
#
|
||||
|
||||
package S2::Checker;
|
||||
|
||||
use strict;
|
||||
use vars qw($VERSION);
|
||||
|
||||
# version should be incremented whenever any internals change.
|
||||
# the external mechanisms which serialize checker objects should
|
||||
# then include in their hash/db/etc the version, so any change
|
||||
# in version invalidates checker caches and forces a full re-compile
|
||||
$VERSION = '1.0';
|
||||
|
||||
# // combined (all layers)
|
||||
# private Hashtable classes; // class name -> NodeClass
|
||||
# private Hashtable props; // property name -> Type
|
||||
# private Hashtable funcs; // FuncID -> return type
|
||||
# private Hashtable funcAttr; // FuncID -> attr string -> Boolean (has attr)
|
||||
# private LinkedList localblocks; // NodeStmtBlock scopes .. last is deepest (closest)
|
||||
# private Type returnType;
|
||||
# private String funcClass; // current function class
|
||||
# private Hashtable derclass; // classname -> LinkedList<classname>
|
||||
# private boolean inFunction; // checking in a function now?
|
||||
|
||||
# // per-layer
|
||||
# private Hashtable funcDist; // FuncID -> [ distance, NodeFunction ]
|
||||
# private Hashtable funcIDs; // NodeFunction -> Set<FuncID>
|
||||
# private boolean hitFunction; // true once a function has been declared/defined
|
||||
|
||||
# // per function
|
||||
# private int funcNum = 0;
|
||||
# private Hashtable funcNums; // FuncID -> Integer(funcnum)
|
||||
# private LinkedList funcNames; // Strings
|
||||
|
||||
sub new
|
||||
{
|
||||
my $class = shift;
|
||||
my $this = {
|
||||
'classes' => {},
|
||||
'props' => {},
|
||||
'funcs' => {},
|
||||
'funcAttr' => {},
|
||||
'derclass' => {}, # classname -> arrayref<classname>
|
||||
'localblocks' => [],
|
||||
};
|
||||
bless $this, $class;
|
||||
}
|
||||
|
||||
sub cleanForFreeze {
|
||||
my $this = shift;
|
||||
delete $this->{'funcDist'};
|
||||
delete $this->{'funcIDs'};
|
||||
delete $this->{'hitFunction'};
|
||||
delete $this->{'funcNum'};
|
||||
delete $this->{'funcNums'};
|
||||
delete $this->{'funcNames'};
|
||||
$this->{'localBlocks'} = [];
|
||||
delete $this->{'returnType'};
|
||||
delete $this->{'funcClass'};
|
||||
delete $this->{'inFunction'};
|
||||
foreach my $nc (values %{$this->{'classes'}}) {
|
||||
$nc->cleanForFreeze();
|
||||
}
|
||||
}
|
||||
|
||||
sub addClass {
|
||||
my ($this, $name, $nc) = @_;
|
||||
$this->{'classes'}->{$name} = $nc;
|
||||
|
||||
# make sure that the list of classes that derive from
|
||||
# this one exists.
|
||||
$this->{'derclass'}->{$name} ||= [];
|
||||
|
||||
# and if this class derives from another, add ourselves
|
||||
# to that list
|
||||
my $parent = $nc->getParentName();
|
||||
if ($parent) {
|
||||
my $l = $this->{'derclass'}->{$parent};
|
||||
die "Internal error: can't append to empty list" unless $l;
|
||||
push @$l, $name;
|
||||
}
|
||||
}
|
||||
|
||||
sub getClass {
|
||||
my ($this, $name) = @_;
|
||||
return undef unless $name;
|
||||
return $this->{'classes'}->{$name};
|
||||
}
|
||||
|
||||
sub getParentClassName {
|
||||
my ($this, $name) = @_;
|
||||
my $nc = $this->getClass($name);
|
||||
return undef unless $nc;
|
||||
return $nc->getParentName();
|
||||
}
|
||||
|
||||
sub isValidType {
|
||||
my ($this, $t) = @_;
|
||||
return 0 unless $t;
|
||||
return 1 if $t->isPrimitive();
|
||||
return defined $this->getClass($t->baseType());
|
||||
}
|
||||
|
||||
# property functions
|
||||
sub addProperty {
|
||||
my ($this, $name, $t, $builtin) = @_;
|
||||
$this->{'props'}->{$name} = $t;
|
||||
$this->{'prop_builtin'}->{$name} = 1 if $builtin;
|
||||
}
|
||||
|
||||
sub propertyType {
|
||||
my ($this, $name) = @_;
|
||||
return $this->{'props'}->{$name};
|
||||
}
|
||||
|
||||
sub propertyBuiltin {
|
||||
my ($this, $name) = @_;
|
||||
return $this->{'prop_builtin'}->{$name};
|
||||
}
|
||||
|
||||
# return type functions (undef means no return type)
|
||||
sub setReturnType {
|
||||
my ($this, $t) = @_;
|
||||
$this->{'returnType'} = $t;
|
||||
}
|
||||
|
||||
sub getReturnType {
|
||||
shift->{'returnType'};
|
||||
}
|
||||
|
||||
# funtion functions
|
||||
sub addFunction {
|
||||
my ($this, $funcid, $t, $attrs) = @_;
|
||||
my $existing = $this->functionType($funcid);
|
||||
if ($existing && ! $existing->equals($t)) {
|
||||
S2::error(undef, "Can't override function '$funcid' with new return type.");
|
||||
}
|
||||
$this->{'funcs'}->{$funcid} = $t;
|
||||
|
||||
# enable all attributes specified
|
||||
if (defined $attrs) {
|
||||
die "Internal error. \$attrs is defined, but not a hashref."
|
||||
if ref $attrs ne "HASH";
|
||||
foreach my $k (keys %$attrs) {
|
||||
$this->{'funcAttr'}->{$funcid}->{$k} = 1;
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
sub functionType {
|
||||
my ($this, $funcid) = @_;
|
||||
$this->{'funcs'}->{$funcid};
|
||||
}
|
||||
|
||||
sub checkFuncAttr {
|
||||
my ($this, $funcid, $attr) = @_;
|
||||
$this->{'funcAttr'}->{$funcid}->{$attr};
|
||||
}
|
||||
|
||||
sub isFuncBuiltin {
|
||||
my ($this, $funcid) = @_;
|
||||
return $this->checkFuncAttr($funcid, "builtin");
|
||||
}
|
||||
|
||||
# returns true if there's a string -> t class constructor
|
||||
sub isStringCtor {
|
||||
my ($this, $t) = @_;
|
||||
return 0 unless $t && $t->isSimple();
|
||||
my $cname = $t->baseType();
|
||||
my $ctorid = "${cname}::${cname}(string)";
|
||||
my $rt = $this->functionType($ctorid);
|
||||
return $rt && $rt->isSimple() && $rt->baseType() eq $cname &&
|
||||
$this->isFuncBuiltin($ctorid);
|
||||
}
|
||||
|
||||
# setting/getting the current function class we're in
|
||||
sub setCurrentFunctionClass { my $this = shift; $this->{'funcClass'} = shift; }
|
||||
sub getCurrentFunctionClass { shift->{'funcClass'}; }
|
||||
|
||||
# setting/getting whether in a function now
|
||||
sub setInFunction { my $this = shift; $this->{'inFunction'} = shift; }
|
||||
sub getInFunction { shift->{'inFunction'}; }
|
||||
|
||||
# variable lookup
|
||||
sub pushLocalBlock {
|
||||
my ($this, $nb) = @_; # nb = NodeStmtBlock
|
||||
push @{$this->{'localblocks'}}, $nb;
|
||||
}
|
||||
sub popLocalBlock {
|
||||
my ($this) = @_;
|
||||
pop @{$this->{'localblocks'}};
|
||||
}
|
||||
|
||||
sub getLocalScope {
|
||||
my $this = shift;
|
||||
return undef unless @{$this->{'localblocks'}};
|
||||
return $this->{'localblocks'}->[-1];
|
||||
}
|
||||
|
||||
sub localType {
|
||||
my ($this, $local) = @_;
|
||||
return undef unless @{$this->{'localblocks'}};
|
||||
foreach my $nb (reverse @{$this->{'localblocks'}}) {
|
||||
my $t = $nb->getLocalVar($local);
|
||||
return $t if $t;
|
||||
}
|
||||
return undef;
|
||||
}
|
||||
|
||||
sub memberType {
|
||||
my ($this, $clas, $member) = @_;
|
||||
my $nc = $this->getClass($clas);
|
||||
return undef unless $nc;
|
||||
return $nc->getMemberType($member);
|
||||
}
|
||||
|
||||
sub setHitFunction { my $this = shift; $this->{'hitFunction'} = shift; }
|
||||
sub getHitFunction { shift->{'hitFunction'}; }
|
||||
|
||||
sub hasDerClasses {
|
||||
my ($this, $clas) = @_;
|
||||
return scalar @{$this->{'derclass'}->{$clas}};
|
||||
}
|
||||
|
||||
sub getDerClasses {
|
||||
my ($this, $clas) = @_;
|
||||
return $this->{'derclass'}->{$clas};
|
||||
}
|
||||
|
||||
sub setFuncDistance {
|
||||
my ($this, $funcID, $df) = @_; # df = hashref with 'dist' and 'nf' key
|
||||
|
||||
my $existing = $this->{'funcDist'}->{$funcID};
|
||||
|
||||
if (! defined $existing || $df->{'dist'} < $existing->{'dist'}) {
|
||||
$this->{'funcDist'}->{$funcID} = $df;
|
||||
|
||||
# keep the funcIDs hashes -> FuncID set up-to-date
|
||||
# removing the existing funcID from the old set first
|
||||
if ($existing) {
|
||||
delete $this->{'funcIDs'}->{$existing->{'nf'}}->{$funcID};
|
||||
}
|
||||
|
||||
# add to new set
|
||||
$this->{'funcIDs'}->{$df->{'nf'}}->{$funcID} = 1;
|
||||
}
|
||||
}
|
||||
|
||||
sub getFuncIDs {
|
||||
my ($this, $nf) = @_;
|
||||
return [ sort keys %{$this->{'funcIDs'}->{$nf}} ];
|
||||
}
|
||||
|
||||
# per function
|
||||
sub resetFunctionNums {
|
||||
my $this = shift;
|
||||
$this->{'funcNum'} = 0;
|
||||
$this->{'funcNums'} = {};
|
||||
$this->{'funcNames'} = [];
|
||||
}
|
||||
|
||||
sub functionNum {
|
||||
my ($this, $funcID) = @_;
|
||||
my $num = $this->{'funcNums'}->{$funcID};
|
||||
unless (defined $num) {
|
||||
$num = ++$this->{'funcNum'};
|
||||
$this->{'funcNums'}->{$funcID} = $num;
|
||||
push @{$this->{'funcNames'}}, $funcID;
|
||||
}
|
||||
return $num;
|
||||
}
|
||||
|
||||
sub getFuncNums { shift->{'funcNums'}; }
|
||||
sub getFuncNames { shift->{'funcNames'}; }
|
||||
|
||||
# check if type 't' is a subclass of 'w'
|
||||
sub typeIsa {
|
||||
my ($this, $t, $w) = @_;
|
||||
return 0 unless S2::Type->sameMods($t, $w);
|
||||
|
||||
my $is = $t->baseType();
|
||||
my $parent = $w->baseType();
|
||||
while ($is) {
|
||||
return 1 if $is eq $parent;
|
||||
my $nc = $this->getClass($is);
|
||||
$is = $nc ? $nc->getParentName() : undef;
|
||||
}
|
||||
return 0;
|
||||
}
|
||||
|
||||
# check to see if a class or parents has a "toString()" or "as_string()" method.
|
||||
# returns the method name found.
|
||||
sub classHasToString {
|
||||
my ($this, $clas) = @_;
|
||||
foreach my $methname (qw(toString as_string)) {
|
||||
my $et = $this->functionType("${clas}::$methname()");
|
||||
return $methname if $et && $et->equals($S2::Type::STRING);
|
||||
}
|
||||
return undef;
|
||||
}
|
||||
|
||||
# check to see if a class or parents has an "as_string" string member
|
||||
sub classHasAsString {
|
||||
my ($this, $clas) = @_;
|
||||
my $et = $this->memberType($clas, "as_string");
|
||||
return $et && $et->equals($S2::Type::STRING);
|
||||
}
|
||||
|
||||
# ---------------
|
||||
|
||||
sub checkLayer {
|
||||
my ($this, $lay) = @_; # lay = Layer
|
||||
|
||||
# initialize layer-specific data structures
|
||||
$this->{'funcDist'} = {}; # funcID -> "derItem" hashref ('dist' scalar and 'nf' NodeFormal)
|
||||
$this->{'funcIDs'} = {};
|
||||
$this->{'hitFunction'} = 0;
|
||||
|
||||
# check to see that they declared the layer type, and that
|
||||
# it isn't bogus.
|
||||
{
|
||||
# what the S2 source says the layer is
|
||||
my $dtype = $lay->getDeclaredType();
|
||||
S2::error(undef, "Layer type not declared") unless $dtype;
|
||||
|
||||
# what type s2compile thinks it is
|
||||
my $type = $lay->getType();
|
||||
|
||||
S2::error(undef, "Layer is declared $dtype but expecting a $type layer")
|
||||
unless $type eq $dtype;
|
||||
|
||||
# now that we've validated their type is okay
|
||||
$lay->setType($dtype);
|
||||
}
|
||||
|
||||
my $nodes = $lay->getNodes();
|
||||
foreach my $n (@$nodes) {
|
||||
$n->check($lay, $this);
|
||||
}
|
||||
|
||||
if ($lay->getType() eq "core") {
|
||||
my $mv = $lay->getLayerInfo("majorversion");
|
||||
unless (defined $mv) {
|
||||
S2::error(undef, "Core layers must declare 'majorversion' layerinfo.");
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
sub functionID {
|
||||
my ($clas, $func, $o) = @_;
|
||||
my $sb;
|
||||
$sb .= "${clas}::" if $clas;
|
||||
$sb .= "$func(";
|
||||
if (! defined $o) {
|
||||
# do nothing
|
||||
} elsif (ref $o && $o->isa('S2::NodeFormals')) {
|
||||
$sb .= $o->typeList();
|
||||
} else {
|
||||
$sb .= $o;
|
||||
}
|
||||
$sb .= ")";
|
||||
return $sb;
|
||||
}
|
||||
|
||||
|
||||
1;
|
||||
48
wcmtools/s2/S2/Compiler.pm
Executable file
48
wcmtools/s2/S2/Compiler.pm
Executable file
@@ -0,0 +1,48 @@
|
||||
#!/usr/bin/perl
|
||||
#
|
||||
|
||||
package S2::Compiler;
|
||||
|
||||
use strict;
|
||||
use S2::Tokenizer;
|
||||
use S2::Checker;
|
||||
use S2::Layer;
|
||||
use S2::Util;
|
||||
use S2::BackendPerl;
|
||||
use S2::BackendHTML;
|
||||
use S2::OutputScalar;
|
||||
|
||||
sub new # (fh) class method
|
||||
{
|
||||
my ($class, $opts) = @_;
|
||||
$opts->{'checker'} ||= new S2::Checker;
|
||||
bless $opts, $class;
|
||||
}
|
||||
|
||||
sub compile_source {
|
||||
my ($this, $opts) = @_;
|
||||
$S2::CUR_COMPILER = $this;
|
||||
my $ref = ref $opts->{'source'} ? $opts->{'source'} : \$opts->{'source'};
|
||||
my $toker = S2::Tokenizer->new($ref);
|
||||
my $s2l = S2::Layer->new($toker, $opts->{'type'});
|
||||
my $o = new S2::OutputScalar($opts->{'output'});
|
||||
my $be;
|
||||
$opts->{'format'} ||= "perl";
|
||||
if ($opts->{'format'} eq "html") {
|
||||
$be = new S2::BackendHTML($s2l);
|
||||
} elsif ($opts->{'format'} eq "perl") {
|
||||
$this->{'checker'}->checkLayer($s2l);
|
||||
$be = new S2::BackendPerl($s2l, $opts->{'layerid'}, $opts->{'untrusted'});
|
||||
if ($opts->{'builtinPackage'}) {
|
||||
$be->setBuiltinPackage($opts->{'builtinPackage'});
|
||||
}
|
||||
} else {
|
||||
S2::error("Unknown output type in S2::Compiler");
|
||||
}
|
||||
$be->output($o);
|
||||
undef $S2::CUR_COMPILER;
|
||||
return 1;
|
||||
}
|
||||
|
||||
|
||||
1;
|
||||
37
wcmtools/s2/S2/FilePos.pm
Executable file
37
wcmtools/s2/S2/FilePos.pm
Executable file
@@ -0,0 +1,37 @@
|
||||
#!/usr/bin/perl
|
||||
#
|
||||
|
||||
package S2::FilePos;
|
||||
|
||||
use strict;
|
||||
|
||||
sub new
|
||||
{
|
||||
my ($class, $l, $c) = @_;
|
||||
my $this = [ $l, $c ];
|
||||
bless $this, $class;
|
||||
return $this;
|
||||
}
|
||||
|
||||
sub line { shift->[0]; }
|
||||
sub col { shift->[1]; }
|
||||
|
||||
sub clone
|
||||
{
|
||||
my $this = shift;
|
||||
return new S2::FilePos(@$this);
|
||||
}
|
||||
|
||||
sub locationString
|
||||
{
|
||||
my $this = shift;
|
||||
return "line $this->[0], column $this->[1]";
|
||||
}
|
||||
|
||||
sub toString
|
||||
{
|
||||
my $this = shift;
|
||||
return $this->locationString();
|
||||
}
|
||||
|
||||
1;
|
||||
43
wcmtools/s2/S2/Indenter.pm
Executable file
43
wcmtools/s2/S2/Indenter.pm
Executable file
@@ -0,0 +1,43 @@
|
||||
#!/usr/bin/perl
|
||||
#
|
||||
|
||||
package S2::Indenter;
|
||||
|
||||
use strict;
|
||||
|
||||
sub new {
|
||||
my ($class, $o, $tabsize) = @_;
|
||||
my $this = {
|
||||
'o' => $o,
|
||||
'tabsize' => $tabsize,
|
||||
'depth' => 0,
|
||||
};
|
||||
bless $this, $class;
|
||||
}
|
||||
|
||||
sub write {
|
||||
my ($this, $s) = @_;
|
||||
$this->{'o'}->write($s);
|
||||
}
|
||||
|
||||
sub writeln {
|
||||
my ($this, $s) = @_;
|
||||
$this->{'o'}->writeln($s);
|
||||
}
|
||||
|
||||
sub tabwrite {
|
||||
my ($this, $s) = @_;
|
||||
$this->{'o'}->write(" "x($this->{'tabsize'}*$this->{'depth'}) . $s);
|
||||
}
|
||||
|
||||
sub tabwriteln {
|
||||
my ($this, $s) = @_;
|
||||
$this->{'o'}->writeln(" "x($this->{'tabsize'}*$this->{'depth'}) . $s);
|
||||
}
|
||||
|
||||
sub newline { shift->{'o'}->newline(); }
|
||||
|
||||
sub tabIn { shift->{'depth'}++; }
|
||||
sub tabOut { shift->{'depth'}--; }
|
||||
|
||||
1;
|
||||
115
wcmtools/s2/S2/Layer.pm
Executable file
115
wcmtools/s2/S2/Layer.pm
Executable file
@@ -0,0 +1,115 @@
|
||||
#!/usr/bin/perl
|
||||
#
|
||||
|
||||
package S2::Layer;
|
||||
|
||||
use S2::NodeUnnecessary;
|
||||
use S2::NodeLayerInfo;
|
||||
use S2::NodeProperty;
|
||||
use S2::NodePropGroup;
|
||||
use S2::NodeSet;
|
||||
use S2::NodeFunction;
|
||||
use S2::NodeClass;
|
||||
|
||||
sub new
|
||||
{
|
||||
my ($class, $toker, $type) = @_;
|
||||
my $this = {
|
||||
'type' => $type,
|
||||
'declaredType' => undef,
|
||||
'nodes' => [],
|
||||
'layerinfo' => {},
|
||||
};
|
||||
|
||||
my $nodes = $this->{'nodes'};
|
||||
|
||||
while (my $t = $toker->peek()) {
|
||||
|
||||
if (S2::NodeUnnecessary->canStart($toker)) {
|
||||
push @$nodes, S2::NodeUnnecessary->parse($toker);
|
||||
next;
|
||||
}
|
||||
|
||||
if (S2::NodeLayerInfo->canStart($toker)) {
|
||||
my $nli = S2::NodeLayerInfo->parse($toker);
|
||||
push @$nodes, $nli;
|
||||
if ($nli->getKey() eq "type") {
|
||||
$this->{'declaredType'} = $nli->getValue();
|
||||
}
|
||||
next;
|
||||
}
|
||||
|
||||
if (S2::NodeProperty->canStart($toker)) {
|
||||
push @$nodes, S2::NodeProperty->parse($toker);
|
||||
next;
|
||||
}
|
||||
|
||||
if (S2::NodePropGroup->canStart($toker)) {
|
||||
push @$nodes, S2::NodePropGroup->parse($toker);
|
||||
next;
|
||||
}
|
||||
|
||||
if (S2::NodeSet->canStart($toker)) {
|
||||
push @$nodes, S2::NodeSet->parse($toker);
|
||||
next;
|
||||
}
|
||||
|
||||
if (S2::NodeFunction->canStart($toker)) {
|
||||
push @$nodes, S2::NodeFunction->parse($toker);
|
||||
next;
|
||||
}
|
||||
|
||||
if (S2::NodeClass->canStart($toker)) {
|
||||
push @$nodes, S2::NodeClass->parse($toker);
|
||||
next;
|
||||
}
|
||||
|
||||
S2::error($t, "Unknown token encountered while parsing layer: " .
|
||||
$t->toString());
|
||||
}
|
||||
|
||||
bless $this, $class;
|
||||
}
|
||||
|
||||
sub setLayerInfo {
|
||||
my ($this, $key, $val) = @_;
|
||||
$this->{'layerinfo'}->{$key} = $val;
|
||||
}
|
||||
|
||||
sub getLayerInfo {
|
||||
my ($this, $key) = @_;
|
||||
$this->{'layerinfo'}->{$key};
|
||||
}
|
||||
|
||||
sub getLayerInfoKeys {
|
||||
my ($this) = @_;
|
||||
return [ keys %{$this->{'layerinfo'}} ];
|
||||
}
|
||||
|
||||
sub getType {
|
||||
shift->{'type'};
|
||||
}
|
||||
|
||||
sub getDeclaredType {
|
||||
shift->{'declaredType'};
|
||||
}
|
||||
|
||||
sub setType {
|
||||
shift->{'type'} = shift;
|
||||
}
|
||||
|
||||
sub toString {
|
||||
shift->{'type'};
|
||||
}
|
||||
|
||||
sub getNodes {
|
||||
return shift->{'nodes'};
|
||||
}
|
||||
|
||||
sub isCoreOrLayout {
|
||||
my $this = shift;
|
||||
return $this->{'type'} eq "core" ||
|
||||
$this->{'type'} eq "layout";
|
||||
}
|
||||
|
||||
1;
|
||||
224
wcmtools/s2/S2/Node.pm
Executable file
224
wcmtools/s2/S2/Node.pm
Executable file
@@ -0,0 +1,224 @@
|
||||
#!/usr/bin/perl
|
||||
#
|
||||
|
||||
package S2::Node;
|
||||
|
||||
use strict;
|
||||
|
||||
sub new {
|
||||
my ($class) = @_;
|
||||
my $node = {
|
||||
'startPos' => undef,
|
||||
'tokenlist' => [],
|
||||
};
|
||||
bless $node, $class;
|
||||
}
|
||||
|
||||
sub cleanForFreeze {
|
||||
my $this = shift;
|
||||
delete $this->{'tokenlist'};
|
||||
delete $this->{'_cache_type'};
|
||||
}
|
||||
|
||||
sub setStart {
|
||||
my ($this, $arg) = @_;
|
||||
|
||||
if ($arg->isa('S2::Token') || $arg->isa('S2::Node')) {
|
||||
$this->{'startPos'} =
|
||||
$arg->getFilePos()->clone();
|
||||
} elsif ($arg->isa('S2::FilePos')) {
|
||||
$this->{'startPos'} =
|
||||
$arg->clone();
|
||||
} else {
|
||||
die "Unexpected argument.\n";
|
||||
}
|
||||
}
|
||||
|
||||
sub check {
|
||||
my ($this, $l, $ck) = @_;
|
||||
die "FIXME: check not implemented for $this\n";
|
||||
}
|
||||
|
||||
sub asHTML {
|
||||
my ($this, $o) = @_;
|
||||
foreach my $el (@{$this->{'tokenlist'}}) {
|
||||
# $el is an S2::Token or S2::Node
|
||||
$el->asHTML($o);
|
||||
}
|
||||
}
|
||||
|
||||
sub asS2 {
|
||||
my ($this, $o) = @_;
|
||||
$o->tabwriteln("###$this:::asS2###");
|
||||
}
|
||||
|
||||
sub asPerl {
|
||||
my ($this, $bp, $o) = @_;
|
||||
$o->tabwriteln("###${this}::asPerl###");
|
||||
}
|
||||
|
||||
sub asPerl_bool {
|
||||
my ($this, $bp, $o) = @_;
|
||||
my $ck = $S2::CUR_COMPILER->{'checker'};
|
||||
my $s2type = $this->getType($ck);
|
||||
|
||||
# already boolean
|
||||
if ($s2type->equals($S2::Type::BOOL) || $s2type->equals($S2::Type::INT)) {
|
||||
$this->asPerl($bp, $o);
|
||||
return;
|
||||
}
|
||||
|
||||
# S2 semantics and perl semantics differ ("0" is true in S2)
|
||||
if ($s2type->equals($S2::Type::STRING)) {
|
||||
$o->write("((");
|
||||
$this->asPerl($bp, $o);
|
||||
$o->write(") ne '')");
|
||||
return;
|
||||
}
|
||||
|
||||
# is the object defined?
|
||||
if ($s2type->isSimple()) {
|
||||
$o->write("S2::check_defined(");
|
||||
$this->asPerl($bp, $o);
|
||||
$o->write(")");
|
||||
return;
|
||||
}
|
||||
|
||||
# does the array have elements?
|
||||
if ($s2type->isArrayOf() || $s2type->isHashOf()) {
|
||||
$o->write("S2::check_elements(");
|
||||
$this->asPerl($bp, $o);
|
||||
$o->write(")");
|
||||
return;
|
||||
}
|
||||
|
||||
S2::error($this, "Unhandled internal case for NodeTerm::asPerl_bool()");
|
||||
}
|
||||
|
||||
sub setTokenList {
|
||||
my ($this, $newlist) = @_;
|
||||
$this->{'tokenlist'} = $newlist;
|
||||
}
|
||||
|
||||
sub getTokenList {
|
||||
my ($this) = @_;
|
||||
$this->{'tokenlist'};
|
||||
}
|
||||
|
||||
sub addNode {
|
||||
my ($this, $subnode) = @_;
|
||||
push @{$this->{'tokenlist'}}, $subnode;
|
||||
}
|
||||
|
||||
sub addToken {
|
||||
my ($this, $t) = @_;
|
||||
push @{$this->{'tokenlist'}}, $t;
|
||||
}
|
||||
|
||||
sub eatToken {
|
||||
my ($this, $toker, $ignoreSpace) = @_;
|
||||
$ignoreSpace = 1 unless defined $ignoreSpace;
|
||||
my $t = $toker->getToken();
|
||||
$this->addToken($t);
|
||||
if ($ignoreSpace) {
|
||||
$this->skipWhite($toker);
|
||||
}
|
||||
return $t;
|
||||
}
|
||||
|
||||
sub requireToken {
|
||||
my ($this, $toker, $t, $ignoreSpace) = @_;
|
||||
$ignoreSpace = 1 unless defined $ignoreSpace;
|
||||
if ($ignoreSpace) { $this->skipWhite($toker); }
|
||||
|
||||
my $next = $toker->getToken();
|
||||
S2::error($next, "Unexpected end of file found") unless $next;
|
||||
|
||||
unless ($next == $t) {
|
||||
S2::error(undef, "internal error") unless $t;
|
||||
S2::error($next, "Unexpected token found. ".
|
||||
"Expecting: " . $t->toString() . "\nGot: " . $next->toString());
|
||||
}
|
||||
$this->addToken($next);
|
||||
if ($ignoreSpace) { $this->skipWhite($toker); }
|
||||
return $next;
|
||||
}
|
||||
|
||||
sub getStringLiteral {
|
||||
my ($this, $toker, $ignoreSpace) = @_;
|
||||
$ignoreSpace = 1 unless defined $ignoreSpace;
|
||||
if ($ignoreSpace) { $this->skipWhite($toker); }
|
||||
|
||||
my $t = $toker->getToken();
|
||||
S2::error($t, "Expected string literal")
|
||||
unless $t && $t->isa("S2::TokenStringLiteral");
|
||||
|
||||
$this->addToken($t);
|
||||
return $t;
|
||||
}
|
||||
|
||||
sub getIdent {
|
||||
my ($this, $toker, $addToList, $ignoreSpace) = @_;
|
||||
$addToList = 1 unless defined $addToList;
|
||||
$ignoreSpace = 1 unless defined $ignoreSpace;
|
||||
|
||||
my $id = $toker->peek();
|
||||
unless ($id->isa("S2::TokenIdent")) {
|
||||
S2::error($id, "Expected identifier.");
|
||||
}
|
||||
if ($addToList) {
|
||||
$this->eatToken($toker, $ignoreSpace);
|
||||
}
|
||||
return $id;
|
||||
}
|
||||
|
||||
sub skipWhite {
|
||||
my ($this, $toker) = @_;
|
||||
while (my $next = $toker->peek()) {
|
||||
return if $next->isNecessary();
|
||||
$this->addToken($toker->getToken());
|
||||
}
|
||||
}
|
||||
|
||||
sub getFilePos {
|
||||
my ($this) = @_;
|
||||
|
||||
# most nodes should set their position
|
||||
return $this->{'startPos'} if $this->{'startPos'};
|
||||
|
||||
# if the node didn't record its position, try to figure it out
|
||||
# from where the first token is at
|
||||
my $el = $this->{'tokenlist'}->[0];
|
||||
return $el->getFilePos() if $el;
|
||||
return undef;
|
||||
}
|
||||
|
||||
sub getType {
|
||||
my ($this, $ck, $wanted) = @_;
|
||||
die "FIXME: getType(ck) not implemented in $this\n";
|
||||
}
|
||||
|
||||
# kinda a crappy part to put this, perhaps. but all expr
|
||||
# nodes don't inherit from NodeExpr. maybe they should?
|
||||
sub isLValue {
|
||||
my ($this) = @_;
|
||||
# hack: only NodeTerms inside NodeExprs can be true
|
||||
if ($this->isa('S2::NodeExpr')) {
|
||||
my $n = $this->getExpr();
|
||||
if ($n->isa('S2::NodeTerm')) {
|
||||
return $n->isLValue();
|
||||
}
|
||||
}
|
||||
return 0;
|
||||
}
|
||||
|
||||
sub makeAsString {
|
||||
my ($this, $ck) = @_;
|
||||
return 0;
|
||||
}
|
||||
|
||||
sub isProperty {
|
||||
0;
|
||||
}
|
||||
|
||||
1;
|
||||
63
wcmtools/s2/S2/NodeArguments.pm
Executable file
63
wcmtools/s2/S2/NodeArguments.pm
Executable file
@@ -0,0 +1,63 @@
|
||||
#!/usr/bin/perl
|
||||
#
|
||||
|
||||
package S2::NodeArguments;
|
||||
|
||||
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;
|
||||
$node->{'args'} = [];
|
||||
bless $node, $class;
|
||||
}
|
||||
|
||||
sub parse {
|
||||
my ($class, $toker) = @_;
|
||||
my $n = new S2::NodeArguments;
|
||||
|
||||
$n->setStart($n->requireToken($toker, $S2::TokenPunct::LPAREN));
|
||||
while (1) {
|
||||
my $tp = $toker->peek();
|
||||
if ($tp == $S2::TokenPunct::RPAREN) {
|
||||
$n->eatToken($toker);
|
||||
return $n;
|
||||
}
|
||||
|
||||
my $expr = parse S2::NodeExpr $toker;
|
||||
push @{$n->{'args'}}, $expr;
|
||||
$n->addNode($expr);
|
||||
if ($toker->peek() == $S2::TokenPunct::COMMA) {
|
||||
$n->eatToken($toker);
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
sub asS2 {
|
||||
my ($this, $o) = @_;
|
||||
die "not ported";
|
||||
}
|
||||
|
||||
sub asPerl {
|
||||
my ($this, $bp, $o, $doCurlies) = @_;
|
||||
$doCurlies = 1 unless defined $doCurlies;
|
||||
$o->write("(") if $doCurlies;
|
||||
my $didFirst = 0;
|
||||
foreach my $n (@{$this->{'args'}}) {
|
||||
$o->write(", ") if $didFirst++;
|
||||
$n->asPerl($bp, $o);
|
||||
}
|
||||
$o->write(")") if $doCurlies;
|
||||
}
|
||||
|
||||
sub typeList {
|
||||
my ($this, $ck) = @_;
|
||||
return join(',', map { $_->getType($ck)->toString() }
|
||||
@{$this->{'args'}});
|
||||
}
|
||||
173
wcmtools/s2/S2/NodeArrayLiteral.pm
Executable file
173
wcmtools/s2/S2/NodeArrayLiteral.pm
Executable file
@@ -0,0 +1,173 @@
|
||||
#!/usr/bin/perl
|
||||
#
|
||||
|
||||
package S2::NodeArrayLiteral;
|
||||
|
||||
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;
|
||||
$node->{'keys'} = [];
|
||||
$node->{'vals'} = [];
|
||||
bless $node, $class;
|
||||
}
|
||||
|
||||
sub canStart {
|
||||
my ($class, $toker) = @_;
|
||||
return $toker->peek() == $S2::TokenPunct::LBRACK ||
|
||||
$toker->peek() == $S2::TokenPunct::LBRACE;
|
||||
}
|
||||
|
||||
# [ <NodeExpr>? (, <NodeExpr>)* ,? ]
|
||||
# { (<NodeExpr> => <NodeExpr> ,)* }
|
||||
|
||||
sub parse {
|
||||
my ($this, $toker) = @_;
|
||||
|
||||
my $nal = new S2::NodeArrayLiteral;
|
||||
|
||||
my $t = $toker->peek();
|
||||
if ($t == $S2::TokenPunct::LBRACK) {
|
||||
$nal->{'isArray'} = 1;
|
||||
$nal->setStart($nal->requireToken($toker, $S2::TokenPunct::LBRACK));
|
||||
} else {
|
||||
$nal->{'isHash'} = 1;
|
||||
$nal->setStart($nal->requireToken($toker, $S2::TokenPunct::LBRACE));
|
||||
}
|
||||
|
||||
my $need_comma = 0;
|
||||
while (1) {
|
||||
$t = $toker->peek();
|
||||
|
||||
# find the ends
|
||||
if ($nal->{'isArray'} && $t == $S2::TokenPunct::RBRACK) {
|
||||
$nal->requireToken($toker, $S2::TokenPunct::RBRACK);
|
||||
return $nal;
|
||||
}
|
||||
if ($nal->{'isHash'} && $t == $S2::TokenPunct::RBRACE) {
|
||||
$nal->requireToken($toker, $S2::TokenPunct::RBRACE);
|
||||
return $nal;
|
||||
}
|
||||
|
||||
S2::error($t, "Expecting comma") if $need_comma;
|
||||
|
||||
if ($nal->{'isArray'}) {
|
||||
my $ne = S2::NodeExpr->parse($toker);
|
||||
push @{$nal->{'vals'}}, $ne;
|
||||
$nal->addNode($ne);
|
||||
} elsif ($nal->{'isHash'}) {
|
||||
my $ne = S2::NodeExpr->parse($toker);
|
||||
push @{$nal->{'keys'}}, $ne;
|
||||
$nal->addNode($ne);
|
||||
|
||||
$nal->requireToken($toker, $S2::TokenPunct::HASSOC);
|
||||
|
||||
$ne = S2::NodeExpr->parse($toker);
|
||||
push @{$nal->{'vals'}}, $ne;
|
||||
$nal->addNode($ne);
|
||||
}
|
||||
|
||||
$need_comma = 1;
|
||||
if ($toker->peek() == $S2::TokenPunct::COMMA) {
|
||||
$nal->requireToken($toker, $S2::TokenPunct::COMMA);
|
||||
$need_comma = 0;
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
}
|
||||
|
||||
sub getType {
|
||||
my ($this, $ck, $wanted) = @_;
|
||||
|
||||
# in case of empty array [] or hash {}, the type is what they wanted,
|
||||
# if they wanted something, otherwise void[] or void{}
|
||||
my $t;
|
||||
my $vals = scalar @{$this->{'vals'}};
|
||||
unless ($vals) {
|
||||
return $wanted if $wanted;
|
||||
$t = new S2::Type("void");
|
||||
$t->makeArrayOf() if $this->{'isArray'};
|
||||
$t->makeHashOf() if $this->{'isHash'};
|
||||
return $t;
|
||||
}
|
||||
|
||||
$t = $this->{'vals'}->[0]->getType($ck)->clone();
|
||||
for (my $i=1; $i<$vals; $i++) {
|
||||
my $next = $this->{'vals'}->[$i]->getType($ck);
|
||||
next if $t->equals($next);
|
||||
S2::error($this, "Hash/array literal with inconsistent types: ".
|
||||
"starts with ". $t->toString .", but then has ".
|
||||
$next->toString);
|
||||
}
|
||||
|
||||
if ($this->{'isHash'}) {
|
||||
for (my $i=0; $i<$vals; $i++) {
|
||||
my $t = $this->{'keys'}->[$i]->getType($ck);
|
||||
next if $t->equals($S2::Type::STRING) ||
|
||||
$t->equals($S2::Type::INT);
|
||||
S2::error($this, "Hash keys must be strings or ints.");
|
||||
}
|
||||
}
|
||||
|
||||
$t->makeArrayOf() if $this->{'isArray'};
|
||||
$t->makeHashOf() if $this->{'isHash'};
|
||||
return $t;
|
||||
}
|
||||
|
||||
sub asS2 {
|
||||
my ($this, $o) = @_;
|
||||
die "Not ported.";
|
||||
}
|
||||
|
||||
sub asPerl {
|
||||
my ($this, $bp, $o) = @_;
|
||||
|
||||
$o->writeln($this->{'isArray'} ? "[" : "{");
|
||||
$o->tabIn();
|
||||
|
||||
my $size = scalar @{$this->{'vals'}};
|
||||
for (my $i=0; $i<$size; $i++) {
|
||||
$o->tabwrite("");
|
||||
if ($this->{'isHash'}) {
|
||||
$this->{'keys'}->[$i]->asPerl($bp, $o);
|
||||
$o->write(" => ");
|
||||
}
|
||||
$this->{'vals'}->[$i]->asPerl($bp, $o);
|
||||
$o->writeln(",");
|
||||
}
|
||||
$o->tabOut();
|
||||
$o->tabwrite($this->{'isArray'} ? "]" : "}");
|
||||
}
|
||||
|
||||
__END__
|
||||
|
||||
public void asS2 (Indenter o)
|
||||
{
|
||||
o.writeln(isArray ? "[" : "{");
|
||||
o.tabIn();
|
||||
ListIterator liv = vals.listIterator();
|
||||
ListIterator lik = keys.listIterator();
|
||||
Node n;
|
||||
while (liv.hasNext()) {
|
||||
o.tabwrite("");
|
||||
if (isHash) {
|
||||
n = (Node) lik.next();
|
||||
n.asS2(o);
|
||||
o.write(" => ");
|
||||
}
|
||||
n = (Node) liv.next();
|
||||
n.asS2(o);
|
||||
o.writeln(",");
|
||||
}
|
||||
o.tabOut();
|
||||
o.tabwrite(isArray ? "]" : "}");
|
||||
}
|
||||
|
||||
101
wcmtools/s2/S2/NodeAssignExpr.pm
Executable file
101
wcmtools/s2/S2/NodeAssignExpr.pm
Executable file
@@ -0,0 +1,101 @@
|
||||
#!/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;
|
||||
|
||||
}
|
||||
|
||||
269
wcmtools/s2/S2/NodeClass.pm
Executable file
269
wcmtools/s2/S2/NodeClass.pm
Executable file
@@ -0,0 +1,269 @@
|
||||
#!/usr/bin/perl
|
||||
#
|
||||
|
||||
package S2::NodeClass;
|
||||
|
||||
use strict;
|
||||
use S2::Node;
|
||||
use S2::NodeClassVarDecl;
|
||||
use vars qw($VERSION @ISA);
|
||||
|
||||
$VERSION = '1.0';
|
||||
@ISA = qw(S2::Node);
|
||||
|
||||
sub new {
|
||||
my ($class) = @_;
|
||||
my $node = new S2::Node;
|
||||
$node->{'vars'} = [];
|
||||
$node->{'functions'} = [];
|
||||
$node->{'varType'} = {};
|
||||
$node->{'funcType'} = {};
|
||||
bless $node, $class;
|
||||
}
|
||||
|
||||
sub cleanForFreeze {
|
||||
my $this = shift;
|
||||
delete $this->{'tokenlist'};
|
||||
delete $this->{'docstring'};
|
||||
foreach (@{$this->{'functions'}}) { $_->cleanForFreeze(); }
|
||||
foreach (@{$this->{'vars'}}) { $_->cleanForFreeze(); }
|
||||
}
|
||||
|
||||
sub canStart {
|
||||
my ($class, $toker) = @_;
|
||||
return $toker->peek() == $S2::TokenKeyword::CLASS;
|
||||
}
|
||||
|
||||
sub parse {
|
||||
my ($class, $toker, $isDecl) = @_;
|
||||
my $n = new S2::NodeClass;
|
||||
|
||||
# get the function keyword
|
||||
$n->setStart($n->requireToken($toker, $S2::TokenKeyword::CLASS));
|
||||
|
||||
$n->{'name'} = $n->getIdent($toker);
|
||||
|
||||
if ($toker->peek() == $S2::TokenKeyword::EXTENDS) {
|
||||
$n->eatToken($toker);
|
||||
$n->{'parentName'} = $n->getIdent($toker);
|
||||
}
|
||||
|
||||
# docstring
|
||||
if ($toker->peek()->isa('S2::TokenStringLiteral')) {
|
||||
my $t = $n->eatToken($toker);
|
||||
$n->{'docstring'} = $t->getString();
|
||||
}
|
||||
|
||||
$n->requireToken($toker, $S2::TokenPunct::LBRACE);
|
||||
|
||||
my $t;
|
||||
while (($t = $toker->peek()) && $t->isa('S2::TokenKeyword')) {
|
||||
if ($t == $S2::TokenKeyword::VAR) {
|
||||
my $ncvd = parse S2::NodeClassVarDecl $toker;
|
||||
push @{$n->{'vars'}}, $ncvd;
|
||||
$n->addNode($ncvd);
|
||||
} elsif ($t == $S2::TokenKeyword::FUNCTION) {
|
||||
my $nm = parse S2::NodeFunction $toker, 1;
|
||||
push @{$n->{'functions'}}, $nm;
|
||||
$n->addNode($nm);
|
||||
}
|
||||
}
|
||||
$n->requireToken($toker, $S2::TokenPunct::RBRACE);
|
||||
return $n;
|
||||
}
|
||||
|
||||
sub getName { shift->{'name'}->getIdent(); }
|
||||
|
||||
sub getParentName {
|
||||
my $this = shift;
|
||||
return undef unless $this->{'parentName'};
|
||||
return $this->{'parentName'}->getIdent();
|
||||
}
|
||||
|
||||
sub getFunctionType {
|
||||
my ($this, $funcID) = @_;
|
||||
my $t = $this->{'funcType'}->{$funcID};
|
||||
return $t if $t;
|
||||
return undef unless $this->{'parentClass'};
|
||||
return $this->{'parentClass'}->getFunctionType($funcID);
|
||||
}
|
||||
|
||||
sub getFunctionDeclClass {
|
||||
my ($this, $funcID) = @_;
|
||||
my $t = $this->{'funcType'}->{$funcID};
|
||||
return $this if $t;
|
||||
return undef unless $this->{'parentClass'};
|
||||
return $this->{'parentClass'}->getFunctionDeclClass($funcID);
|
||||
}
|
||||
|
||||
sub getMemberType {
|
||||
my ($this, $mem) = @_;
|
||||
my $t = $this->{'varType'}->{$mem};
|
||||
return $t if $t;
|
||||
return undef unless $this->{'parentClass'};
|
||||
return $this->{'parentClass'}->getMemberType($mem);
|
||||
}
|
||||
|
||||
sub getMemberDeclClass {
|
||||
my ($this, $mem) = @_;
|
||||
my $t = $this->{'varType'}->{$mem};
|
||||
return $this if $t;
|
||||
return undef unless $this->{'parentClass'};
|
||||
return $this->{'parentClass'}->getMemberDeclClass($mem);
|
||||
}
|
||||
|
||||
sub getDerClasses {
|
||||
my ($this, $l, $depth) = @_;
|
||||
$depth ||= 0; $l ||= [];
|
||||
my $myname = $this->getName();
|
||||
push @$l, { 'nc' => $this, 'dist' => $depth};
|
||||
foreach my $cname (@{$this->{'ck'}->getDerClasses($myname)}) {
|
||||
my $c = $this->{'ck'}->getClass($cname);
|
||||
$c->getDerClasses($l, $depth+1);
|
||||
}
|
||||
return $l;
|
||||
}
|
||||
|
||||
sub check {
|
||||
my ($this, $l, $ck) = @_;
|
||||
|
||||
# keep a reference to the checker for later
|
||||
$this->{'ck'} = $ck;
|
||||
|
||||
# can't declare classes inside of a layer if functions
|
||||
# have already been declared or defined.
|
||||
if ($ck->getHitFunction()) {
|
||||
S2::error($this, "Can't declare a class inside a layer ".
|
||||
"file after functions have been defined");
|
||||
}
|
||||
|
||||
# if this is an extended class, make sure parent class exists
|
||||
$this->{'parentClass'} = undef;
|
||||
my $pname = $this->getParentName();
|
||||
if (defined $pname) {
|
||||
$this->{'parentClass'} = $ck->getClass($pname);
|
||||
unless ($this->{'parentClass'}) {
|
||||
S2::error($this, "Can't extend non-existent class '$pname'");
|
||||
}
|
||||
}
|
||||
|
||||
# make sure the class isn't already defined.
|
||||
my $cname = $this->{'name'}->getIdent();
|
||||
S2::error($this, "Can't redeclare class '$cname'") if $ck->getClass($cname);
|
||||
|
||||
# register all var and function declarations in hash & check for both
|
||||
# duplicates and masking of parent class's declarations
|
||||
|
||||
# register self. this needs to be done before checking member
|
||||
# variables so we can have members of our own type.
|
||||
$ck->addClass($cname, $this);
|
||||
|
||||
# member vars
|
||||
foreach my $nnt (@{$this->{'vars'}}) {
|
||||
my $readonly = $nnt->isReadOnly();
|
||||
my $vn = $nnt->getName();
|
||||
my $vt = $nnt->getType();
|
||||
my $et = $this->getMemberType($vn);
|
||||
if ($et) {
|
||||
my $oc = $this->getMemberDeclClass($vn);
|
||||
S2::error($nnt, "Can't declare the variable '$vn' ".
|
||||
"as '" . $vt->toString . "' in class '$cname' because it's ".
|
||||
"already defined in class '". $oc->getName() ."' as ".
|
||||
"type '". $et->toString ."'.");
|
||||
}
|
||||
|
||||
# check to see if type exists
|
||||
unless ($ck->isValidType($vt)) {
|
||||
S2::error($nnt, "Can't declare member variable '$vn' ".
|
||||
"as unknown type '". $vt->toString ."' in class '$cname'");
|
||||
}
|
||||
|
||||
$vt->setReadOnly($readonly);
|
||||
$this->{'varType'}->{$vn} = $vt; # register member variable
|
||||
}
|
||||
|
||||
# all parent class functions need to be inherited:
|
||||
$this->registerFunctions($ck, $cname);
|
||||
}
|
||||
|
||||
sub registerFunctions {
|
||||
my ($this, $ck, $clas) = @_;
|
||||
|
||||
# register parent's functions first.
|
||||
if ($this->{'parentClass'}) {
|
||||
$this->{'parentClass'}->registerFunctions($ck, $clas);
|
||||
}
|
||||
|
||||
# now do our own
|
||||
foreach my $nf (@{$this->{'functions'}}) {
|
||||
my $rettype = $nf->getReturnType();
|
||||
$nf->registerFunction($ck, $clas);
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
sub asS2 {
|
||||
my ($this, $o) = @_;
|
||||
die "not done";
|
||||
}
|
||||
|
||||
sub asPerl {
|
||||
my ($this, $bp, $o) = @_;
|
||||
|
||||
$o->tabwriteln("register_class(" . $bp->getLayerIDString() .
|
||||
", " . $bp->quoteString($this->getName()) . ", {");
|
||||
$o->tabIn();
|
||||
if ($this->{'parentName'}) {
|
||||
$o->tabwriteln("'parent' => " . $bp->quoteString($this->getParentName()) . ",");
|
||||
}
|
||||
if ($this->{'docstring'}) {
|
||||
$o->tabwriteln("'docstring' => " . $bp->quoteString($this->{'docstring'}) . ",");
|
||||
}
|
||||
|
||||
# vars
|
||||
$o->tabwriteln("'vars' => {");
|
||||
$o->tabIn();
|
||||
foreach my $nnt (@{$this->{'vars'}}) {
|
||||
my $vn = $nnt->getName();
|
||||
my $vt = $nnt->getType();
|
||||
my $et = $this->getMemberType($vn);
|
||||
$o->tabwrite($bp->quoteString($vn) . " => { 'type' => " . $bp->quoteString($vt->toString()));
|
||||
if ($vt->isReadOnly()) {
|
||||
$o->write(", 'readonly' => 1");
|
||||
}
|
||||
if ($nnt->getDocString()) {
|
||||
$o->write(", 'docstring' => " . $bp->quoteString($nnt->getDocString()));
|
||||
}
|
||||
$o->writeln(" },");
|
||||
}
|
||||
$o->tabOut();
|
||||
$o->tabwriteln("},");
|
||||
|
||||
# methods
|
||||
$o->tabwriteln("'funcs' => {");
|
||||
$o->tabIn();
|
||||
foreach my $nf (@{$this->{'functions'}}) {
|
||||
my $name = $nf->getName();
|
||||
my $nfo = $nf->getFormals();
|
||||
my $rt = $nf->getReturnType();
|
||||
$o->tabwrite($bp->quoteString($name . ($nfo ? $nfo->toString() : "()"))
|
||||
. " => { 'returntype' => "
|
||||
. $bp->quoteString($rt->toString()));
|
||||
if ($nf->getDocString()) {
|
||||
$o->write(", 'docstring' => " . $bp->quoteString($nf->getDocString()));
|
||||
}
|
||||
if (my $attrs = $nf->attrsJoined) {
|
||||
$o->write(", 'attrs' => " . $bp->quoteString($attrs));
|
||||
}
|
||||
$o->writeln(" },");
|
||||
}
|
||||
$o->tabOut();
|
||||
$o->tabwriteln("},");
|
||||
|
||||
$o->tabOut();
|
||||
$o->tabwriteln("});");
|
||||
}
|
||||
|
||||
__END__
|
||||
|
||||
|
||||
75
wcmtools/s2/S2/NodeClassVarDecl.pm
Executable file
75
wcmtools/s2/S2/NodeClassVarDecl.pm
Executable file
@@ -0,0 +1,75 @@
|
||||
#!/usr/bin/perl
|
||||
#
|
||||
|
||||
package S2::NodeClassVarDecl;
|
||||
|
||||
use strict;
|
||||
use S2::Node;
|
||||
use S2::NodeType;
|
||||
use vars qw($VERSION @ISA);
|
||||
|
||||
$VERSION = '1.0';
|
||||
@ISA = qw(S2::Node);
|
||||
|
||||
sub new {
|
||||
my ($class, $name, $type) = @_;
|
||||
my $node = new S2::Node;
|
||||
$node->{'name'} = $name;
|
||||
$node->{'type'} = $type;
|
||||
bless $node, $class;
|
||||
}
|
||||
|
||||
sub cleanForFreeze {
|
||||
my $this = shift;
|
||||
delete $this->{'tokenlist'};
|
||||
delete $this->{'docstring'};
|
||||
$this->{'typenode'}->cleanForFreeze;
|
||||
}
|
||||
|
||||
sub getType { shift->{'type'}; }
|
||||
sub getName { shift->{'name'}; }
|
||||
sub getDocString { shift->{'docstring'}; }
|
||||
sub isReadOnly { shift->{'readonly'}; }
|
||||
|
||||
sub parse {
|
||||
my ($class, $toker) = @_;
|
||||
|
||||
my $n = new S2::NodeClassVarDecl;
|
||||
|
||||
# get the function keyword
|
||||
$n->setStart($n->requireToken($toker, $S2::TokenKeyword::VAR));
|
||||
|
||||
if ($toker->peek() == $S2::TokenKeyword::READONLY) {
|
||||
$n->{'readonly'} = 1;
|
||||
$n->eatToken($toker);
|
||||
}
|
||||
|
||||
$n->{'typenode'} = parse S2::NodeType $toker;
|
||||
$n->{'type'} = $n->{'typenode'}->getType();
|
||||
$n->addNode($n->{'typenode'});
|
||||
|
||||
$n->{'name'} = $n->getIdent($toker)->getIdent();
|
||||
|
||||
# docstring
|
||||
if ($toker->peek()->isa('S2::TokenStringLiteral')) {
|
||||
my $t = $n->eatToken($toker);
|
||||
$n->{'docstring'} = $t->getString();
|
||||
}
|
||||
|
||||
$n->requireToken($toker, $S2::TokenPunct::SCOLON);
|
||||
return $n;
|
||||
}
|
||||
|
||||
sub asS2 {
|
||||
my ($this, $o) = @_;
|
||||
die "not done";
|
||||
}
|
||||
|
||||
sub asString {
|
||||
my $this = shift;
|
||||
return join(' ', $this->{'type'}->toString, $this->{'name'});
|
||||
}
|
||||
|
||||
__END__
|
||||
|
||||
|
||||
82
wcmtools/s2/S2/NodeCondExpr.pm
Executable file
82
wcmtools/s2/S2/NodeCondExpr.pm
Executable file
@@ -0,0 +1,82 @@
|
||||
#!/usr/bin/perl
|
||||
#
|
||||
|
||||
package S2::NodeCondExpr;
|
||||
|
||||
use strict;
|
||||
use S2::Node;
|
||||
use S2::NodeRange;
|
||||
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::NodeRange->canStart($toker);
|
||||
}
|
||||
|
||||
sub parse {
|
||||
my ($class, $toker) = @_;
|
||||
my $n = new S2::NodeCondExpr;
|
||||
|
||||
$n->{'test_expr'} = parse S2::NodeRange $toker;
|
||||
$n->addNode($n->{'test_expr'});
|
||||
|
||||
return $n->{'test_expr'} unless
|
||||
$toker->peek() == $S2::TokenPunct::QMARK;
|
||||
|
||||
$n->eatToken($toker);
|
||||
|
||||
$n->{'true_expr'} = parse S2::NodeRange $toker;
|
||||
$n->addNode($n->{'true_expr'});
|
||||
$n->requireToken($toker, $S2::TokenPunct::COLON);
|
||||
|
||||
$n->{'false_expr'} = parse S2::NodeRange $toker;
|
||||
$n->addNode($n->{'false_expr'});
|
||||
|
||||
return $n;
|
||||
}
|
||||
|
||||
sub getType {
|
||||
my ($this, $ck) = @_;
|
||||
|
||||
my $ctype = $this->{'test_expr'}->getType($ck);
|
||||
unless ($ctype->isBoolable()) {
|
||||
S2::error($this, "Conditional expression not of type boolean.");
|
||||
}
|
||||
|
||||
my $lt = $this->{'true_expr'}->getType($ck);
|
||||
my $rt = $this->{'false_expr'}->getType($ck);
|
||||
unless ($lt->equals($rt)) {
|
||||
S2::error($this, "Types don't match in conditional expression.");
|
||||
}
|
||||
return $lt;
|
||||
}
|
||||
|
||||
sub asS2 {
|
||||
my ($this, $o) = @_;
|
||||
$this->{'test_expr'}->asS2($o);
|
||||
$o->write(" ? ");
|
||||
$this->{'true_expr'}->asS2($o);
|
||||
$o->write(" : ");
|
||||
$this->{'false_expr'}->asS2($o);
|
||||
}
|
||||
|
||||
sub asPerl {
|
||||
my ($this, $bp, $o) = @_;
|
||||
$o->write("(");
|
||||
$this->{'test_expr'}->asPerl_bool($bp, $o);
|
||||
$o->write(" ? ");
|
||||
$this->{'true_expr'}->asPerl($bp, $o);
|
||||
$o->write(" : ");
|
||||
$this->{'false_expr'}->asPerl($bp, $o);
|
||||
$o->write(")");
|
||||
}
|
||||
|
||||
64
wcmtools/s2/S2/NodeDeleteStmt.pm
Executable file
64
wcmtools/s2/S2/NodeDeleteStmt.pm
Executable file
@@ -0,0 +1,64 @@
|
||||
#!/usr/bin/perl
|
||||
#
|
||||
|
||||
package S2::NodeDeleteStmt;
|
||||
|
||||
use strict;
|
||||
use S2::Node;
|
||||
use S2::NodeVarRef;
|
||||
use vars qw($VERSION @ISA);
|
||||
|
||||
$VERSION = '1.0';
|
||||
@ISA = qw(S2::Node);
|
||||
|
||||
sub new {
|
||||
my ($class) = @_;
|
||||
my $n = new S2::Node;
|
||||
bless $n, $class;
|
||||
}
|
||||
|
||||
sub canStart {
|
||||
my ($class, $toker) = @_;
|
||||
return $toker->peek() == $S2::TokenKeyword::DELETE;
|
||||
}
|
||||
|
||||
sub parse {
|
||||
my ($class, $toker) = @_;
|
||||
|
||||
my $n = new S2::NodeDeleteStmt;
|
||||
my $t = $toker->peek();
|
||||
|
||||
$n->setStart($n->requireToken($toker, $S2::TokenKeyword::DELETE));
|
||||
$n->addNode($n->{'var'} = S2::NodeVarRef->parse($toker));
|
||||
$n->requireToken($toker, $S2::TokenPunct::SCOLON);
|
||||
|
||||
return $n;
|
||||
}
|
||||
|
||||
sub check {
|
||||
my ($this, $l, $ck) = @_;
|
||||
|
||||
# type check the innards, but we don't care what type
|
||||
# actually is.
|
||||
$this->{'var'}->getType($ck);
|
||||
|
||||
# but it must be a hash reference
|
||||
unless ($this->{'var'}->isHashElement()) {
|
||||
S2::error($this, "Delete statement argument is not a hash");
|
||||
}
|
||||
}
|
||||
|
||||
sub asS2 {
|
||||
my ($this, $o) = @_;
|
||||
$o->tabwrite("delete ");
|
||||
$this->{'var'}->asS2($o);
|
||||
$o->writeln(";");
|
||||
}
|
||||
|
||||
sub asPerl {
|
||||
my ($this, $bp, $o) = @_;
|
||||
$o->tabwrite("delete ");
|
||||
$this->{'var'}->asPerl($bp, $o);
|
||||
$o->writeln(";");
|
||||
}
|
||||
|
||||
89
wcmtools/s2/S2/NodeEqExpr.pm
Executable file
89
wcmtools/s2/S2/NodeEqExpr.pm
Executable file
@@ -0,0 +1,89 @@
|
||||
#!/usr/bin/perl
|
||||
#
|
||||
|
||||
package S2::NodeEqExpr;
|
||||
|
||||
use strict;
|
||||
use S2::Node;
|
||||
use S2::NodeRelExpr;
|
||||
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::NodeRelExpr->canStart($toker);
|
||||
}
|
||||
|
||||
sub parse {
|
||||
my ($class, $toker) = @_;
|
||||
my $n = new S2::NodeEqExpr;
|
||||
|
||||
$n->{'lhs'} = parse S2::NodeRelExpr $toker;
|
||||
$n->addNode($n->{'lhs'});
|
||||
|
||||
return $n->{'lhs'} unless
|
||||
$toker->peek() == $S2::TokenPunct::EQ ||
|
||||
$toker->peek() == $S2::TokenPunct::NE;
|
||||
|
||||
$n->{'op'} = $toker->peek();
|
||||
$n->eatToken($toker);
|
||||
|
||||
$n->{'rhs'} = parse S2::NodeRelExpr $toker;
|
||||
$n->addNode($n->{'rhs'});
|
||||
$n->skipWhite($toker);
|
||||
|
||||
return $n;
|
||||
}
|
||||
|
||||
sub getType {
|
||||
my ($this, $ck) = @_;
|
||||
|
||||
my $lt = $this->{'lhs'}->getType($ck);
|
||||
my $rt = $this->{'rhs'}->getType($ck);
|
||||
|
||||
if (! $lt->equals($rt)) {
|
||||
S2::error($this, "The types of the left and right hand side of " .
|
||||
"equality test expression don't match.");
|
||||
}
|
||||
|
||||
$this->{'myType'} = $lt;
|
||||
|
||||
return $S2::Type::BOOL if $lt->isPrimitive();
|
||||
|
||||
S2::error($this, "Only bool, string, and int types can be tested for equality.");
|
||||
}
|
||||
|
||||
sub asS2 {
|
||||
my ($this, $o) = @_;
|
||||
$this->{'lhs'}->asS2($o);
|
||||
$o->write(" " . $this->{'op'}->getPunct() . " ");
|
||||
$this->{'rhs'}->asS2($o);
|
||||
}
|
||||
|
||||
sub asPerl {
|
||||
my ($this, $bp, $o) = @_;
|
||||
$this->{'lhs'}->asPerl($bp, $o);
|
||||
if ($this->{'op'} == $S2::TokenPunct::EQ) {
|
||||
if ($this->{'myType'}->equals($S2::Type::STRING)) {
|
||||
$o->write(" eq ");
|
||||
} else {
|
||||
$o->write(" == ");
|
||||
}
|
||||
} else {
|
||||
if ($this->{'myType'}->equals($S2::Type::STRING)) {
|
||||
$o->write(" ne ");
|
||||
} else {
|
||||
$o->write(" != ");
|
||||
}
|
||||
}
|
||||
$this->{'rhs'}->asPerl($bp, $o);
|
||||
}
|
||||
|
||||
56
wcmtools/s2/S2/NodeExpr.pm
Executable file
56
wcmtools/s2/S2/NodeExpr.pm
Executable file
@@ -0,0 +1,56 @@
|
||||
#!/usr/bin/perl
|
||||
#
|
||||
|
||||
package S2::NodeExpr;
|
||||
|
||||
use strict;
|
||||
use S2::Node;
|
||||
use S2::NodeAssignExpr;
|
||||
use vars qw($VERSION @ISA);
|
||||
|
||||
$VERSION = '1.0';
|
||||
@ISA = qw(S2::Node);
|
||||
|
||||
sub new {
|
||||
my ($class, $n) = @_;
|
||||
my $node = new S2::Node;
|
||||
$node->{'expr'} = $n;
|
||||
bless $node, $class;
|
||||
}
|
||||
|
||||
sub canStart {
|
||||
my ($class, $toker) = @_;
|
||||
S2::NodeAssignExpr->canStart($toker);
|
||||
}
|
||||
|
||||
sub parse {
|
||||
my ($class, $toker) = @_;
|
||||
my $n = new S2::NodeExpr;
|
||||
$n->{'expr'} = parse S2::NodeAssignExpr $toker;
|
||||
$n->addNode($n->{'expr'});
|
||||
return $n;
|
||||
}
|
||||
|
||||
sub asS2 {
|
||||
my ($this, $o) = @_;
|
||||
$this->{'expr'}->asS2($o);
|
||||
}
|
||||
|
||||
sub asPerl {
|
||||
my ($this, $bp, $o) = @_;
|
||||
$this->{'expr'}->asPerl($bp, $o);
|
||||
}
|
||||
|
||||
sub getType {
|
||||
my ($this, $ck, $wanted) = @_;
|
||||
$this->{'expr'}->getType($ck, $wanted);
|
||||
}
|
||||
|
||||
sub makeAsString {
|
||||
my ($this, $ck) = @_;
|
||||
$this->{'expr'}->makeAsString($ck);
|
||||
}
|
||||
|
||||
sub getExpr {
|
||||
shift->{'expr'};
|
||||
}
|
||||
52
wcmtools/s2/S2/NodeExprStmt.pm
Executable file
52
wcmtools/s2/S2/NodeExprStmt.pm
Executable file
@@ -0,0 +1,52 @@
|
||||
#!/usr/bin/perl
|
||||
#
|
||||
|
||||
package S2::NodeExprStmt;
|
||||
|
||||
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 ($this, $toker) = @_;
|
||||
return S2::NodeExpr->canStart($toker);
|
||||
}
|
||||
|
||||
sub parse {
|
||||
my ($class, $toker) = @_;
|
||||
my $n = new S2::NodeExprStmt;
|
||||
$n->addNode($n->{'expr'} = S2::NodeExpr->parse($toker));
|
||||
$n->requireToken($toker, $S2::TokenPunct::SCOLON);
|
||||
return $n;
|
||||
}
|
||||
|
||||
sub check {
|
||||
my ($this, $l, $ck) = @_;
|
||||
$this->{'expr'}->getType($ck);
|
||||
}
|
||||
|
||||
sub asS2 {
|
||||
my ($this, $o) = @_;
|
||||
$o->tabwrite("");
|
||||
$this->{'expr'}->asS2($o);
|
||||
$o->writeln(";");
|
||||
}
|
||||
|
||||
sub asPerl {
|
||||
my ($this, $bp, $o) = @_;
|
||||
$o->tabwrite("");
|
||||
$this->{'expr'}->asPerl($bp, $o);
|
||||
$o->writeln(";");
|
||||
}
|
||||
|
||||
|
||||
134
wcmtools/s2/S2/NodeForeachStmt.pm
Executable file
134
wcmtools/s2/S2/NodeForeachStmt.pm
Executable file
@@ -0,0 +1,134 @@
|
||||
#!/usr/bin/perl
|
||||
#
|
||||
|
||||
package S2::NodeForeachStmt;
|
||||
|
||||
use strict;
|
||||
use S2::Node;
|
||||
use S2::NodeVarDecl;
|
||||
use S2::NodeVarRef;
|
||||
use S2::NodeExpr;
|
||||
use S2::NodeStmtBlock;
|
||||
use vars qw($VERSION @ISA);
|
||||
|
||||
$VERSION = '1.0';
|
||||
@ISA = qw(S2::Node);
|
||||
|
||||
sub new {
|
||||
my ($class) = @_;
|
||||
my $n = new S2::Node;
|
||||
bless $n, $class;
|
||||
}
|
||||
|
||||
sub canStart {
|
||||
my ($class, $toker) = @_;
|
||||
return $toker->peek() == $S2::TokenKeyword::FOREACH
|
||||
}
|
||||
|
||||
sub parse {
|
||||
my ($class, $toker) = @_;
|
||||
|
||||
my $n = new S2::NodeForeachStmt;
|
||||
$n->setStart($n->requireToken($toker, $S2::TokenKeyword::FOREACH));
|
||||
|
||||
if (S2::NodeVarDecl->canStart($toker)) {
|
||||
$n->addNode($n->{'vardecl'} = S2::NodeVarDecl->parse($toker));
|
||||
} else {
|
||||
$n->addNode($n->{'varref'} = S2::NodeVarRef->parse($toker));
|
||||
}
|
||||
|
||||
# expression in parenthesis representing an array to iterate over:
|
||||
$n->requireToken($toker, $S2::TokenPunct::LPAREN);
|
||||
$n->addNode($n->{'listexpr'} = S2::NodeExpr->parse($toker));
|
||||
$n->requireToken($toker, $S2::TokenPunct::RPAREN);
|
||||
|
||||
# and what to do on each element
|
||||
$n->addNode($n->{'stmts'} = S2::NodeStmtBlock->parse($toker));
|
||||
|
||||
return $n;
|
||||
}
|
||||
|
||||
sub check {
|
||||
my ($this, $l, $ck) = @_;
|
||||
|
||||
my $ltype = $this->{'listexpr'}->getType($ck);
|
||||
|
||||
if ($ltype->isHashOf()) {
|
||||
$this->{'isHash'} = 1;
|
||||
} elsif ($ltype->equals($S2::Type::STRING)) {
|
||||
$this->{'isString'} = 1;
|
||||
} elsif (! $ltype->isArrayOf()) {
|
||||
S2::error($this, "Must use an array, hash, or string in a foreach");
|
||||
}
|
||||
|
||||
my $itype;
|
||||
if ($this->{'vardecl'}) {
|
||||
$this->{'vardecl'}->populateScope($this->{'stmts'});
|
||||
$itype = $this->{'vardecl'}->getType();
|
||||
}
|
||||
$itype = $this->{'varref'}->getType($ck) if $this->{'varref'};
|
||||
|
||||
if ($this->{'isHash'}) {
|
||||
unless ($itype->equals($S2::Type::STRING) ||
|
||||
$itype->equals($S2::Type::INT)) {
|
||||
S2::error($this, "Foreach iteration variable must be a ".
|
||||
"string or int when interating over the keys ".
|
||||
"in a hash");
|
||||
}
|
||||
} elsif ($this->{'isString'}) {
|
||||
unless ($itype->equals($S2::Type::STRING)) {
|
||||
S2::error($this, "Foreach iteration variable must be a ".
|
||||
"string when interating over the characters ".
|
||||
"in a string");
|
||||
}
|
||||
} else {
|
||||
# iter type must be the same as the list type minus
|
||||
# the final array ref
|
||||
|
||||
# figure out the desired type
|
||||
my $dtype = $ltype->clone();
|
||||
$dtype->removeMod();
|
||||
|
||||
unless ($dtype->equals($itype)) {
|
||||
S2::error("Foreach iteration variable is of type ".
|
||||
$itype->toString . ", not the expected type of ".
|
||||
$dtype->toString);
|
||||
}
|
||||
}
|
||||
|
||||
$ck->pushLocalBlock($this->{'stmts'});
|
||||
$this->{'stmts'}->check($l, $ck);
|
||||
$ck->popLocalBlock();
|
||||
}
|
||||
|
||||
sub asS2 {
|
||||
my ($this, $o) = @_;
|
||||
die "unported";
|
||||
}
|
||||
|
||||
sub asPerl {
|
||||
my ($this, $bp, $o) = @_;
|
||||
|
||||
$o->tabwrite("foreach ");
|
||||
$this->{'vardecl'}->asPerl($bp, $o) if $this->{'vardecl'};
|
||||
$this->{'varref'}->asPerl($bp, $o) if $this->{'varref'};
|
||||
if ($this->{'isHash'}) {
|
||||
$o->write(" (keys %{");
|
||||
} elsif ($this->{'isString'}) {
|
||||
$o->write(" (S2::get_characters(");
|
||||
} else {
|
||||
$o->write(" (\@{");
|
||||
}
|
||||
|
||||
$this->{'listexpr'}->asPerl($bp, $o);
|
||||
|
||||
if ($this->{'isString'}) {
|
||||
$o->write(")) ");
|
||||
} else {
|
||||
$o->write("}) ");
|
||||
}
|
||||
|
||||
$this->{'stmts'}->asPerl($bp, $o);
|
||||
$o->newline();
|
||||
}
|
||||
|
||||
135
wcmtools/s2/S2/NodeFormals.pm
Executable file
135
wcmtools/s2/S2/NodeFormals.pm
Executable file
@@ -0,0 +1,135 @@
|
||||
#!/usr/bin/perl
|
||||
#
|
||||
|
||||
package S2::NodeFormals;
|
||||
|
||||
use strict;
|
||||
use S2::Node;
|
||||
use vars qw($VERSION @ISA);
|
||||
|
||||
$VERSION = '1.0';
|
||||
@ISA = qw(S2::Node);
|
||||
|
||||
sub new {
|
||||
my ($class, $formals) = @_;
|
||||
my $node = new S2::Node;
|
||||
$node->{'listFormals'} = $formals || [];
|
||||
bless $node, $class;
|
||||
}
|
||||
|
||||
sub cleanForFreeze {
|
||||
my $this = shift;
|
||||
delete $this->{'tokenlist'};
|
||||
foreach (@{$this->{'listFormals'}}) { $_->cleanForFreeze; }
|
||||
}
|
||||
|
||||
sub parse {
|
||||
my ($class, $toker, $isDecl) = @_;
|
||||
my $n = new S2::NodeFormals;
|
||||
my $count = 0;
|
||||
|
||||
$n->requireToken($toker, $S2::TokenPunct::LPAREN);
|
||||
while ($toker->peek() != $S2::TokenPunct::RPAREN) {
|
||||
$n->requireToken($toker, $S2::TokenPunct::COMMA) if $count;
|
||||
$n->skipWhite($toker);
|
||||
|
||||
my $nf = parse S2::NodeNamedType $toker;
|
||||
push @{$n->{'listFormals'}}, $nf;
|
||||
$n->addNode($nf);
|
||||
|
||||
$n->skipWhite($toker);
|
||||
$count++;
|
||||
}
|
||||
$n->requireToken($toker, $S2::TokenPunct::RPAREN);
|
||||
return $n;
|
||||
}
|
||||
|
||||
sub check {
|
||||
my ($this, $l, $ck) = @_;
|
||||
my %seen;
|
||||
foreach my $nt (@{$this->{'listFormals'}}) {
|
||||
my $name = $nt->getName();
|
||||
S2::error($nt, "Duplicate argument named $name") if $seen{$name}++;
|
||||
my $t = $nt->getType();
|
||||
unless ($ck->isValidType($t)) {
|
||||
S2::error($nt, "Unknown type " . $t->toString);
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
sub asS2 {
|
||||
my ($this, $o) = @_;
|
||||
return unless @{$this->{'listFormals'}};
|
||||
$o->write($this->toString());
|
||||
}
|
||||
|
||||
sub toString {
|
||||
my ($this) = @_;
|
||||
return "(" . join(", ", map { $_->toString }
|
||||
@{$this->{'listFormals'}}) . ")";
|
||||
}
|
||||
|
||||
sub getFormals { shift->{'listFormals'}; }
|
||||
|
||||
# static
|
||||
sub variations {
|
||||
my ($nf, $ck) = @_; # NodeFormals, Checker
|
||||
my $l = [];
|
||||
if ($nf) {
|
||||
$nf->getVariations($ck, $l, [], 0);
|
||||
} else {
|
||||
push @$l, new S2::NodeFormals;
|
||||
}
|
||||
return $l;
|
||||
}
|
||||
|
||||
sub getVariations {
|
||||
my ($this, $ck, $vars, $temp, $col) = @_;
|
||||
my $size = @{$this->{'listFormals'}};
|
||||
|
||||
if ($col == $size) {
|
||||
push @$vars, new S2::NodeFormals($temp);
|
||||
return;
|
||||
}
|
||||
|
||||
my $nt = $this->{'listFormals'}->[$col]; # NodeNamedType
|
||||
my $t = $nt->getType();
|
||||
|
||||
foreach my $st (@{$t->subTypes($ck)}) {
|
||||
my $newtemp = [ @$temp ]; # hacky clone (not cloning member objects)
|
||||
push @$newtemp, new S2::NodeNamedType($nt->getName(), $st);
|
||||
$this->getVariations($ck, $vars, $newtemp, $col+1);
|
||||
}
|
||||
}
|
||||
|
||||
sub typeList {
|
||||
my $this = shift;
|
||||
return join(',', map { $_->getType()->toString }
|
||||
@{$this->{'listFormals'}});
|
||||
|
||||
# debugging implementation:
|
||||
#my @list;
|
||||
#foreach my $nnt (@{$this->{'listFormals'}}) { # NodeNamedType
|
||||
# my $t = $nnt->getType();
|
||||
# if (ref $t ne "S2::Type") {
|
||||
# print STDERR "Is: $t\n";
|
||||
# S2::error()
|
||||
# }
|
||||
# push @list, $t->toString;
|
||||
#}
|
||||
#return join(',', @list);
|
||||
}
|
||||
|
||||
|
||||
# adds all these variables to the stmtblock's symbol table
|
||||
sub populateScope {
|
||||
my ($this, $nb) = @_; # NodeStmtBlock
|
||||
foreach my $nt (@{$this->{'listFormals'}}) {
|
||||
$nb->addLocalVar($nt->getName(), $nt->getType());
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
393
wcmtools/s2/S2/NodeFunction.pm
Executable file
393
wcmtools/s2/S2/NodeFunction.pm
Executable file
@@ -0,0 +1,393 @@
|
||||
#!/usr/bin/perl
|
||||
#
|
||||
|
||||
package S2::NodeFunction;
|
||||
|
||||
use strict;
|
||||
use S2::Node;
|
||||
use S2::NodeFormals;
|
||||
use S2::NodeStmtBlock;
|
||||
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 cleanForFreeze {
|
||||
my $this = shift;
|
||||
delete $this->{'tokenlist'};
|
||||
delete $this->{'docstring'};
|
||||
$this->{'formals'}->cleanForFreeze() if $this->{'formals'};
|
||||
$this->{'rettype'}->cleanForFreeze() if $this->{'rettype'};
|
||||
}
|
||||
|
||||
sub getDocString { shift->{'docstring'}; }
|
||||
|
||||
sub canStart {
|
||||
my ($class, $toker) = @_;
|
||||
return $toker->peek() == $S2::TokenKeyword::FUNCTION;
|
||||
}
|
||||
|
||||
sub parse {
|
||||
my ($class, $toker, $isDecl) = @_;
|
||||
my $n = new S2::NodeFunction;
|
||||
|
||||
# get the function keyword
|
||||
$n->setStart($n->requireToken($toker, $S2::TokenKeyword::FUNCTION));
|
||||
|
||||
# is the builtin keyword on?
|
||||
# this is the old way, but still supported. the new way
|
||||
# is function attributes in brackets.
|
||||
if ($toker->peek() == $S2::TokenKeyword::BUILTIN) {
|
||||
$n->{'attr'}->{'builtin'} = 1;
|
||||
$n->eatToken($toker);
|
||||
}
|
||||
|
||||
# the class name or function name (if no class)
|
||||
$n->{'name'} = $n->getIdent($toker);
|
||||
|
||||
# check for a double colon
|
||||
if ($toker->peek() == $S2::TokenPunct::DCOLON) {
|
||||
# so last ident was the class name
|
||||
$n->{'classname'} = $n->{'name'};
|
||||
$n->eatToken($toker);
|
||||
$n->{'name'} = $n->getIdent($toker);
|
||||
}
|
||||
|
||||
# Argument list is optional.
|
||||
if ($toker->peek() == $S2::TokenPunct::LPAREN) {
|
||||
$n->addNode($n->{'formals'} = S2::NodeFormals->parse($toker));
|
||||
}
|
||||
|
||||
# Attribute list is optional
|
||||
if ($toker->peek() == $S2::TokenPunct::LBRACK) {
|
||||
$n->eatToken($toker);
|
||||
while ($toker->peek() && $toker->peek() != $S2::TokenPunct::RBRACK) {
|
||||
my $t = $n->eatToken($toker);
|
||||
next if $t == $S2::TokenPunct::COMMA;
|
||||
S2::error($t, "Expecting an identifer for an attribute")
|
||||
unless $t->isa("S2::TokenIdent");
|
||||
my $attr = $t->getIdent();
|
||||
unless ($attr eq "builtin" || # implemented by system, not in S2
|
||||
$attr eq "fixed" || # can't be overridden in derived or same layers
|
||||
$attr eq "notags") { # return from untrusted layers pass through S2::notags()
|
||||
S2::error($t, "Unknown function attribute '$attr'");
|
||||
}
|
||||
$n->{'attr'}->{$attr} = 1;
|
||||
}
|
||||
$n->requireToken($toker, $S2::TokenPunct::RBRACK);
|
||||
}
|
||||
|
||||
# return type is optional too.
|
||||
if ($toker->peek() == $S2::TokenPunct::COLON) {
|
||||
$n->requireToken($toker, $S2::TokenPunct::COLON);
|
||||
$n->addNode($n->{'rettype'} = S2::NodeType->parse($toker));
|
||||
}
|
||||
|
||||
# docstring
|
||||
if ($toker->peek()->isa('S2::TokenStringLiteral')) {
|
||||
$n->{'docstring'} = $n->eatToken($toker)->getString();
|
||||
}
|
||||
|
||||
# if inside a class declaration, only a declaration now.
|
||||
if ($isDecl || $n->{'attr'}->{'builtin'}) {
|
||||
$n->requireToken($toker, $S2::TokenPunct::SCOLON);
|
||||
return $n;
|
||||
}
|
||||
|
||||
# otherwise, keep parsing the function definition.
|
||||
$n->{'stmts'} = parse S2::NodeStmtBlock $toker;
|
||||
$n->addNode($n->{'stmts'});
|
||||
|
||||
return $n;
|
||||
}
|
||||
|
||||
sub getFormals { shift->{'formals'}; }
|
||||
sub getName { shift->{'name'}->getIdent(); }
|
||||
sub getReturnType {
|
||||
my $this = shift;
|
||||
return $this->{'rettype'} ? $this->{'rettype'}->getType() : $S2::Type::VOID;
|
||||
}
|
||||
|
||||
sub check {
|
||||
my ($this, $l, $ck) = @_;
|
||||
|
||||
# keep a reference to the checker for later
|
||||
$this->{'ck'} = $ck;
|
||||
|
||||
# reset the functionID -> local funcNum mappings
|
||||
$ck->resetFunctionNums();
|
||||
|
||||
# tell the checker we've seen a function now so it knows
|
||||
# later to complain if it then sees a new class declaration.
|
||||
# (builtin functions are okay)
|
||||
$ck->setHitFunction(1) unless $this->{'attr'}->{'builtin'};
|
||||
|
||||
my $funcName = $this->{'name'}->getIdent();
|
||||
my $cname = $this->className();
|
||||
my $funcID = S2::Checker::functionID($cname, $funcName, $this->{'formals'});
|
||||
my $t = $this->getReturnType();
|
||||
|
||||
$ck->setInFunction($funcID);
|
||||
|
||||
if ($cname && $cname eq $funcName) {
|
||||
$this->{'isCtor'} = 1;
|
||||
}
|
||||
|
||||
if ($ck->isFuncBuiltin($funcID)) {
|
||||
S2::error($this, "Can't override built-in functions");
|
||||
}
|
||||
|
||||
if ($ck->checkFuncAttr($funcID, "fixed") && $l->getType() ne "core") {
|
||||
S2::error($this, "Can't override functions with the 'fixed' attribute.");
|
||||
}
|
||||
|
||||
if ($this->{'attr'}->{'builtin'} && $l->getType() ne "core") {
|
||||
S2::error($this, "Only core layers can declare builtin functions");
|
||||
}
|
||||
|
||||
# if this function is global, no declaration is done, but if
|
||||
# this is class-scoped, we must check the class exists and
|
||||
# that it declares this function.
|
||||
if ($cname) {
|
||||
my $nc = $ck->getClass($cname);
|
||||
unless ($nc) {
|
||||
S2::error($this, "Can't declare function $funcID for ".
|
||||
"non-existent class '$cname'");
|
||||
}
|
||||
|
||||
my $et = $ck->functionType($funcID);
|
||||
unless ($et || ($l->getType() eq "layout" &&
|
||||
$funcName =~ /^lay_/)) {
|
||||
S2::error($this, "Can't define undeclared object function $funcID");
|
||||
}
|
||||
|
||||
# find & register all the derivative names by which this function
|
||||
# could be called.
|
||||
my $dercs = $nc->getDerClasses();
|
||||
my $fvs = S2::NodeFormals::variations($this->{'formals'}, $ck);
|
||||
foreach my $dc (@$dercs) { # DerItem
|
||||
my $c = $dc->{'nc'}; # NodeClass
|
||||
foreach my $fv (@$fvs) {
|
||||
my $derFuncID = S2::Checker::functionID($c->getName(), $this->getName(), $fv);
|
||||
$ck->setFuncDistance($derFuncID, { 'nf' => $this, 'dist' => $dc->{'dist'} });
|
||||
$ck->addFunction($derFuncID, $t, $this->{'attr'});
|
||||
}
|
||||
}
|
||||
} else {
|
||||
# non-class function. register all variations of the formals.
|
||||
my $fvs = S2::NodeFormals::variations($this->{'formals'}, $ck);
|
||||
foreach my $fv (@$fvs) {
|
||||
my $derFuncID = S2::Checker::functionID($cname,
|
||||
$this->getName(),
|
||||
$fv);
|
||||
$ck->setFuncDistance($derFuncID, { 'nf' => $this, 'dist' => 0 });
|
||||
|
||||
unless ($l->isCoreOrLayout() || $ck->functionType($derFuncID)) {
|
||||
# only core and layout layers can define new functions
|
||||
S2::error($this, "Only core and layout layers can define new functions.");
|
||||
}
|
||||
|
||||
$ck->addFunction($derFuncID, $t, $this->{'attr'});
|
||||
}
|
||||
}
|
||||
|
||||
# check the formals
|
||||
$this->{'formals'}->check($l, $ck) if $this->{'formals'};
|
||||
|
||||
|
||||
# check the statement block
|
||||
if ($this->{'stmts'}) {
|
||||
# prepare stmts to be checked
|
||||
$this->{'stmts'}->setReturnType($t);
|
||||
|
||||
# make sure $this is accessible in a class method
|
||||
# FIXME: not in static functions, once we have static functions
|
||||
if ($cname) {
|
||||
$this->{'stmts'}->addLocalVar("this", new S2::Type($cname));
|
||||
} else {
|
||||
$this->{'stmts'}->addLocalVar("this", $S2::Type::VOID); # prevent its use
|
||||
}
|
||||
|
||||
# make sure $this is accessible in a class method
|
||||
# that has a parent.
|
||||
my $pname = $ck->getParentClassName($cname); # String
|
||||
if (defined $pname) {
|
||||
$this->{'stmts'}->addLocalVar("super", new S2::Type($pname));
|
||||
} else {
|
||||
$this->{'stmts'}->addLocalVar("super", $S2::Type::VOID); # prevent its use
|
||||
}
|
||||
|
||||
$this->{'formals'}->populateScope($this->{'stmts'}) if $this->{'formals'};
|
||||
|
||||
$ck->setCurrentFunctionClass($cname); # for $.member lookups
|
||||
$ck->pushLocalBlock($this->{'stmts'});
|
||||
$this->{'stmts'}->check($l, $ck);
|
||||
$ck->popLocalBlock();
|
||||
}
|
||||
|
||||
# remember the funcID -> local funcNum mappings for the backend
|
||||
$this->{'funcNames'} = $ck->getFuncNames();
|
||||
$ck->setInFunction(0);
|
||||
}
|
||||
|
||||
sub asS2 {
|
||||
my ($this, $o) = @_;
|
||||
die "not done";
|
||||
}
|
||||
|
||||
sub attrsJoined {
|
||||
my $this = shift;
|
||||
return join(',', keys %{$this->{'attr'} || {}});
|
||||
}
|
||||
|
||||
sub asPerl {
|
||||
my ($this, $bp, $o) = @_;
|
||||
unless ($this->{'classname'}) {
|
||||
$o->tabwrite("register_global_function(" .
|
||||
$bp->getLayerIDString() . "," .
|
||||
$bp->quoteString($this->{'name'}->getIdent() . ($this->{'formals'} ? $this->{'formals'}->toString() : "()")) . "," .
|
||||
$bp->quoteString($this->getReturnType()->toString()));
|
||||
$o->write(", " . $bp->quoteString($this->{'docstring'}));
|
||||
$o->write(", " . $bp->quoteString($this->attrsJoined));
|
||||
|
||||
$o->writeln(");");
|
||||
}
|
||||
|
||||
return if $this->{'attr'}->{'builtin'};
|
||||
|
||||
$o->tabwrite("register_function(" . $bp->getLayerIDString() .
|
||||
", [");
|
||||
|
||||
# declare all the names by which this function would be called:
|
||||
# its base name, then all derivative classes which aren't already
|
||||
# used.
|
||||
foreach my $funcID (@{$this->{'ck'}->getFuncIDs($this)}) {
|
||||
$o->write($bp->quoteString($funcID) . ", ");
|
||||
}
|
||||
|
||||
$o->writeln("], sub {");
|
||||
$o->tabIn();
|
||||
|
||||
# the first time register_function is run, it'll find the
|
||||
# funcNames for this session and save those in a list and then
|
||||
# return the sub which is a closure and will have fast access
|
||||
# to that num -> num hash. (benchmarking showed two
|
||||
# hashlookups on ints was faster than one on strings)
|
||||
|
||||
if (scalar(@{$this->{'funcNames'}})) {
|
||||
$o->tabwriteln("my \@_l2g_func = ( undef, ");
|
||||
$o->tabIn();
|
||||
foreach my $id (@{$this->{'funcNames'}}) {
|
||||
$o->tabwriteln("get_func_num(" .
|
||||
$bp->quoteString($id) . "),");
|
||||
}
|
||||
$o->tabOut();
|
||||
$o->tabwriteln(");");
|
||||
}
|
||||
|
||||
# now, return the closure
|
||||
$o->tabwriteln("return sub {");
|
||||
$o->tabIn();
|
||||
|
||||
# setup function argument/ locals
|
||||
$o->tabwrite("my (\$_ctx");
|
||||
if ($this->{'classname'} && ! $this->{'isCtor'}) {
|
||||
$o->write(", \$this");
|
||||
}
|
||||
|
||||
if ($this->{'formals'}) {
|
||||
my $nts = $this->{'formals'}->getFormals();
|
||||
foreach my $nt (@$nts) {
|
||||
$o->write(", \$" . $nt->getName());
|
||||
}
|
||||
}
|
||||
|
||||
$o->writeln(") = \@_;");
|
||||
# end function locals
|
||||
|
||||
$this->{'stmts'}->asPerl($bp, $o, 0);
|
||||
$o->tabOut();
|
||||
$o->tabwriteln("};");
|
||||
|
||||
# end the outer sub
|
||||
$o->tabOut();
|
||||
$o->tabwriteln("});");
|
||||
}
|
||||
|
||||
sub toString {
|
||||
my $this = shift;
|
||||
return $this->className() . "...";
|
||||
}
|
||||
|
||||
sub isBuiltin { shift->{'builtin'}; }
|
||||
|
||||
# private
|
||||
sub className {
|
||||
my $this = shift;
|
||||
return undef unless $this->{'classname'};
|
||||
return $this->{'classname'}->getIdent();
|
||||
|
||||
}
|
||||
|
||||
# private
|
||||
sub totalName {
|
||||
my $this = shift;
|
||||
my $sb;
|
||||
my $clas = $this->className();
|
||||
$sb .= "${clas}::" if $clas;
|
||||
$sb .= $this->{'name'}->getIdent();
|
||||
return $sb;
|
||||
}
|
||||
|
||||
# called by NodeClass
|
||||
sub registerFunction {
|
||||
my ($this, $ck, $cname) = @_;
|
||||
|
||||
my $fname = $this->getName();
|
||||
my $funcID = S2::Checker::functionID($cname, $fname,
|
||||
$this->{'formals'});
|
||||
my $et = $ck->functionType($funcID);
|
||||
my $rt = $this->getReturnType();
|
||||
|
||||
# check that function is either currently undefined or
|
||||
# defined with the same type, otherwise complain
|
||||
if ($et && ! $et->equals($rt)) {
|
||||
S2::error($this, "Can't redefine function '$fname' with return ".
|
||||
"type of '" . $rt->toString . "' masking ".
|
||||
"earlier definition of type '". $et->toString ."'.");
|
||||
}
|
||||
|
||||
$ck->addFunction($funcID, $rt, $this->{'attr'}); # Register
|
||||
}
|
||||
|
||||
__END__
|
||||
|
||||
|
||||
public void asS2 (Indenter o)
|
||||
{
|
||||
o.tabwrite("function " + totalName());
|
||||
if (formals != null) {
|
||||
o.write(" ");
|
||||
formals.asS2(o);
|
||||
}
|
||||
if (rettype != null) {
|
||||
o.write(" : ");
|
||||
rettype.asS2(o);
|
||||
}
|
||||
if (stmts != null) {
|
||||
o.write(" ");
|
||||
stmts.asS2(o);
|
||||
o.newline();
|
||||
} else {
|
||||
o.writeln(";");
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
|
||||
144
wcmtools/s2/S2/NodeIfStmt.pm
Executable file
144
wcmtools/s2/S2/NodeIfStmt.pm
Executable file
@@ -0,0 +1,144 @@
|
||||
#!/usr/bin/perl
|
||||
#
|
||||
|
||||
package S2::NodeIfStmt;
|
||||
|
||||
use strict;
|
||||
use S2::Node;
|
||||
use vars qw($VERSION @ISA);
|
||||
|
||||
$VERSION = '1.0';
|
||||
@ISA = qw(S2::Node);
|
||||
|
||||
sub new {
|
||||
my ($class) = @_;
|
||||
my $n = new S2::Node;
|
||||
bless $n, $class;
|
||||
}
|
||||
|
||||
sub canStart {
|
||||
my ($class, $toker) = @_;
|
||||
return $toker->peek() == $S2::TokenKeyword::IF;
|
||||
}
|
||||
|
||||
sub parse {
|
||||
my ($class, $toker) = @_;
|
||||
|
||||
my $n = new S2::NodeIfStmt;
|
||||
$n->{'elseifblocks'} = [];
|
||||
$n->{'elseifexprs'} = [];
|
||||
|
||||
$n->setStart($n->requireToken($toker, $S2::TokenKeyword::IF));
|
||||
$n->requireToken($toker, $S2::TokenPunct::LPAREN);
|
||||
$n->addNode($n->{'expr'} = S2::NodeExpr->parse($toker));
|
||||
$n->requireToken($toker, $S2::TokenPunct::RPAREN);
|
||||
$n->addNode($n->{'thenblock'} = S2::NodeStmtBlock->parse($toker));
|
||||
|
||||
while ($toker->peek() == $S2::TokenKeyword::ELSEIF) {
|
||||
$n->eatToken($toker);
|
||||
$n->requireToken($toker, $S2::TokenPunct::LPAREN);
|
||||
my $expr = S2::NodeExpr->parse($toker);
|
||||
$n->addNode($expr);
|
||||
$n->requireToken($toker, $S2::TokenPunct::RPAREN);
|
||||
push @{$n->{'elseifexprs'}}, $expr;
|
||||
|
||||
my $nie = S2::NodeStmtBlock->parse($toker);
|
||||
$n->addNode($nie);
|
||||
push @{$n->{'elseifblocks'}}, $nie;
|
||||
}
|
||||
|
||||
if ($toker->peek() == $S2::TokenKeyword::ELSE) {
|
||||
$n->eatToken($toker);
|
||||
$n->addNode($n->{'elseblock'} =
|
||||
S2::NodeStmtBlock->parse($toker));
|
||||
}
|
||||
|
||||
return $n;
|
||||
}
|
||||
|
||||
# returns true if and only if the 'then' stmtblock ends in a
|
||||
# return statement, the 'else' stmtblock is non-null and ends
|
||||
# in a return statement, and any elseif stmtblocks end in a return
|
||||
# statement.
|
||||
sub willReturn {
|
||||
my ($this) = @_;
|
||||
return 0 unless $this->{'elseblock'};
|
||||
return 0 unless $this->{'thenblock'}->willReturn();
|
||||
return 0 unless $this->{'elseblock'}->willReturn();
|
||||
foreach (@{$this->{'elseifblocks'}}) {
|
||||
return 0 unless $_->willReturn();
|
||||
}
|
||||
return 1;
|
||||
}
|
||||
|
||||
sub check {
|
||||
my ($this, $l, $ck) = @_;
|
||||
|
||||
my $expr = $this->{'expr'};
|
||||
|
||||
my $t = $expr->getType($ck);
|
||||
S2::error($this, "Non-boolean if test") unless $t->isBoolable();
|
||||
|
||||
my $check_assign = sub {
|
||||
my $ex = shift;
|
||||
my $innerexpr = $ex->getExpr;
|
||||
if ($innerexpr->isa("S2::NodeAssignExpr")) {
|
||||
S2::error($ex, "Assignments not allowed bare in conditionals. Did you mean to use == instead? If not, wrap assignment in parens.");
|
||||
}
|
||||
};
|
||||
$check_assign->($expr);
|
||||
|
||||
$ck->pushLocalBlock($this->{'thenblock'});
|
||||
$this->{'thenblock'}->check($l, $ck);
|
||||
$ck->popLocalBlock();
|
||||
|
||||
foreach my $ne (@{$this->{'elseifexprs'}}) {
|
||||
$t = $ne->getType($ck);
|
||||
S2::error($ne, "Non-boolean if test") unless $t->isBoolable();
|
||||
$check_assign->($ne);
|
||||
}
|
||||
|
||||
foreach my $sb (@{$this->{'elseifblocks'}}) {
|
||||
$ck->pushLocalBlock($sb);
|
||||
$sb->check($l, $ck);
|
||||
$ck->popLocalBlock();
|
||||
}
|
||||
|
||||
if ($this->{'elseblock'}) {
|
||||
$ck->pushLocalBlock($this->{'elseblock'});
|
||||
$this->{'elseblock'}->check($l, $ck);
|
||||
$ck->popLocalBlock();
|
||||
}
|
||||
}
|
||||
|
||||
sub asS2 {
|
||||
my ($this, $o) = @_;
|
||||
die "Unported";
|
||||
}
|
||||
|
||||
sub asPerl {
|
||||
my ($this, $bp, $o) = @_;
|
||||
|
||||
# if
|
||||
$o->tabwrite("if (");
|
||||
$this->{'expr'}->asPerl_bool($bp, $o);
|
||||
$o->write(") ");
|
||||
$this->{'thenblock'}->asPerl($bp, $o);
|
||||
|
||||
# else-if
|
||||
my $i = 0;
|
||||
foreach my $expr (@{$this->{'elseifexprs'}}) {
|
||||
my $block = $this->{'elseifblocks'}->[$i++];
|
||||
$o->write(" elsif (");
|
||||
$expr->asPerl_bool($bp, $o);
|
||||
$o->write(") ");
|
||||
$block->asPerl($bp, $o);
|
||||
}
|
||||
|
||||
# else
|
||||
if ($this->{'elseblock'}) {
|
||||
$o->write(" else ");
|
||||
$this->{'elseblock'}->asPerl($bp, $o);
|
||||
}
|
||||
$o->newline();
|
||||
}
|
||||
88
wcmtools/s2/S2/NodeIncExpr.pm
Executable file
88
wcmtools/s2/S2/NodeIncExpr.pm
Executable file
@@ -0,0 +1,88 @@
|
||||
#!/usr/bin/perl
|
||||
#
|
||||
|
||||
package S2::NodeIncExpr;
|
||||
|
||||
use strict;
|
||||
use S2::Node;
|
||||
use S2::NodeTerm;
|
||||
use S2::TokenPunct;
|
||||
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) = @_;
|
||||
return $toker->peek() == $S2::TokenPunct::INCR ||
|
||||
$toker->peek() == $S2::TokenPunct::DEC ||
|
||||
S2::NodeTerm->canStart($toker);
|
||||
}
|
||||
|
||||
sub parse {
|
||||
my ($class, $toker) = @_;
|
||||
|
||||
my $n = new S2::NodeIncExpr;
|
||||
|
||||
if ($toker->peek() == $S2::TokenPunct::INCR ||
|
||||
$toker->peek() == $S2::TokenPunct::DEC) {
|
||||
$n->{'bPre'} = 1;
|
||||
$n->{'op'} = $toker->peek();
|
||||
$n->setStart($n->eatToken($toker));
|
||||
$n->skipWhite($toker);
|
||||
}
|
||||
|
||||
my $expr = parse S2::NodeTerm $toker;
|
||||
$n->addNode($expr);
|
||||
|
||||
if ($toker->peek() == $S2::TokenPunct::INCR ||
|
||||
$toker->peek() == $S2::TokenPunct::DEC) {
|
||||
if ($n->{'bPre'}) {
|
||||
S2::error($toker->peek(), "Unexpected " . $toker->peek()->getPunct());
|
||||
}
|
||||
$n->{'bPost'} = 1;
|
||||
$n->{'op'} = $toker->peek();
|
||||
$n->eatToken($toker);
|
||||
$n->skipWhite($toker);
|
||||
}
|
||||
|
||||
if ($n->{'bPre'} || $n->{'bPost'}) {
|
||||
$n->{'expr'} = $expr;
|
||||
return $n;
|
||||
}
|
||||
|
||||
return $expr;
|
||||
}
|
||||
|
||||
sub getType {
|
||||
my ($this, $ck, $wanted) = @_;
|
||||
my $t = $this->{'expr'}->getType($ck);
|
||||
|
||||
unless ($this->{'expr'}->isLValue() &&
|
||||
$t->equals($S2::Type::INT)) {
|
||||
S2::error($this->{'expr'}, "Post/pre-increment must operate on an integer lvalue");
|
||||
}
|
||||
|
||||
return $t;
|
||||
}
|
||||
|
||||
sub asS2 {
|
||||
my ($this, $o) = @_;
|
||||
if ($this->{'bPre'}) { $o->write($this->{'op'}->getPunct()); }
|
||||
$this->{'expr'}->asS2($o);
|
||||
if ($this->{'bPost'}) { $o->write($this->{'op'}->getPunct()); }
|
||||
}
|
||||
|
||||
sub asPerl {
|
||||
my ($this, $bp, $o) = @_;
|
||||
if ($this->{'bPre'}) { $o->write($this->{'op'}->getPunct()); }
|
||||
$this->{'expr'}->asPerl($bp, $o);
|
||||
if ($this->{'bPost'}) { $o->write($this->{'op'}->getPunct()); }
|
||||
}
|
||||
|
||||
69
wcmtools/s2/S2/NodeLayerInfo.pm
Executable file
69
wcmtools/s2/S2/NodeLayerInfo.pm
Executable file
@@ -0,0 +1,69 @@
|
||||
#!/usr/bin/perl
|
||||
#
|
||||
|
||||
package S2::NodeLayerInfo;
|
||||
|
||||
use strict;
|
||||
use S2::Node;
|
||||
use S2::NodeText;
|
||||
use S2::TokenKeyword;
|
||||
use S2::TokenPunct;
|
||||
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 parse {
|
||||
my ($class, $toker) = @_;
|
||||
my $n = new S2::NodeLayerInfo;
|
||||
|
||||
my ($nkey, $nval);
|
||||
|
||||
$n->requireToken($toker, $S2::TokenKeyword::LAYERINFO);
|
||||
$n->addNode($nkey = S2::NodeText->parse($toker));
|
||||
$n->requireToken($toker, $S2::TokenPunct::ASSIGN);
|
||||
$n->addNode($nval = S2::NodeText->parse($toker));
|
||||
$n->requireToken($toker, $S2::TokenPunct::SCOLON);
|
||||
|
||||
$n->{'key'} = $nkey->getText();
|
||||
$n->{'val'} = $nval->getText();
|
||||
|
||||
return $n;
|
||||
}
|
||||
|
||||
sub canStart {
|
||||
my ($class, $toker) = @_;
|
||||
return $toker->peek() == $S2::TokenKeyword::LAYERINFO;
|
||||
}
|
||||
|
||||
sub getKey { shift->{'key'}; }
|
||||
sub getValue { shift->{'val'}; }
|
||||
|
||||
sub asS2 {
|
||||
my ($this, $o) = @_;
|
||||
$o->tabwrite("layerinfo ");
|
||||
$o->write(S2::Backend::quoteString($this->{'key'}));
|
||||
$o->write(" = ");
|
||||
$o->write(S2::Backend::quoteString($this->{'val'}));
|
||||
$o->writeln(";");
|
||||
}
|
||||
|
||||
sub asPerl {
|
||||
my ($this, $bp, $o) = @_;
|
||||
$o->tabwriteln("set_layer_info(" .
|
||||
$bp->getLayerIDString() . "," .
|
||||
$bp->quoteString($this->{'key'}) . "," .
|
||||
$bp->quoteString($this->{'val'}) . ");");
|
||||
}
|
||||
|
||||
sub check {
|
||||
my ($this, $l, $ck) = @_;
|
||||
$l->setLayerInfo($this->{'key'}, $this->{'val'});
|
||||
}
|
||||
|
||||
70
wcmtools/s2/S2/NodeLogAndExpr.pm
Executable file
70
wcmtools/s2/S2/NodeLogAndExpr.pm
Executable file
@@ -0,0 +1,70 @@
|
||||
#!/usr/bin/perl
|
||||
#
|
||||
|
||||
package S2::NodeLogAndExpr;
|
||||
|
||||
use strict;
|
||||
use S2::Node;
|
||||
use S2::NodeEqExpr;
|
||||
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::NodeEqExpr->canStart($toker);
|
||||
}
|
||||
|
||||
sub parse {
|
||||
my ($class, $toker) = @_;
|
||||
my $n = new S2::NodeLogAndExpr;
|
||||
|
||||
$n->{'lhs'} = parse S2::NodeEqExpr $toker;
|
||||
$n->addNode($n->{'lhs'});
|
||||
|
||||
return $n->{'lhs'} unless
|
||||
$toker->peek() == $S2::TokenKeyword::AND;
|
||||
|
||||
$n->eatToken($toker);
|
||||
|
||||
$n->{'rhs'} = parse S2::NodeLogAndExpr $toker;
|
||||
$n->addNode($n->{'rhs'});
|
||||
|
||||
return $n;
|
||||
}
|
||||
|
||||
sub getType {
|
||||
my ($this, $ck) = @_;
|
||||
|
||||
my $lt = $this->{'lhs'}->getType($ck);
|
||||
my $rt = $this->{'rhs'}->getType($ck);
|
||||
|
||||
if (! $lt->equals($rt) || ! $lt->isBoolable()) {
|
||||
S2::error($this, "The left and right side of the 'or' expression must ".
|
||||
"both be of either type bool or int.");
|
||||
}
|
||||
|
||||
return $S2::Type::BOOL;
|
||||
}
|
||||
|
||||
sub asS2 {
|
||||
my ($this, $o) = @_;
|
||||
$this->{'lhs'}->asS2($o);
|
||||
$o->write(" and ");
|
||||
$this->{'rhs'}->asS2($o);
|
||||
}
|
||||
|
||||
sub asPerl {
|
||||
my ($this, $bp, $o) = @_;
|
||||
$this->{'lhs'}->asPerl($bp, $o);
|
||||
$o->write(" && ");
|
||||
$this->{'rhs'}->asPerl($bp, $o);
|
||||
}
|
||||
|
||||
70
wcmtools/s2/S2/NodeLogOrExpr.pm
Executable file
70
wcmtools/s2/S2/NodeLogOrExpr.pm
Executable file
@@ -0,0 +1,70 @@
|
||||
#!/usr/bin/perl
|
||||
#
|
||||
|
||||
package S2::NodeLogOrExpr;
|
||||
|
||||
use strict;
|
||||
use S2::Node;
|
||||
use S2::NodeLogAndExpr;
|
||||
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::NodeLogAndExpr->canStart($toker);
|
||||
}
|
||||
|
||||
sub parse {
|
||||
my ($class, $toker) = @_;
|
||||
my $n = new S2::NodeLogOrExpr;
|
||||
|
||||
$n->{'lhs'} = parse S2::NodeLogAndExpr $toker;
|
||||
$n->addNode($n->{'lhs'});
|
||||
|
||||
return $n->{'lhs'} unless
|
||||
$toker->peek() == $S2::TokenKeyword::OR;
|
||||
|
||||
$n->eatToken($toker);
|
||||
|
||||
$n->{'rhs'} = parse S2::NodeLogOrExpr $toker;
|
||||
$n->addNode($n->{'rhs'});
|
||||
|
||||
return $n;
|
||||
}
|
||||
|
||||
sub getType {
|
||||
my ($this, $ck) = @_;
|
||||
|
||||
my $lt = $this->{'lhs'}->getType($ck);
|
||||
my $rt = $this->{'rhs'}->getType($ck);
|
||||
|
||||
if (! $lt->equals($rt) || ! $lt->isBoolable()) {
|
||||
S2::error($this, "The left and right side of the 'or' expression must ".
|
||||
"both be of either type bool or int.");
|
||||
}
|
||||
|
||||
return $S2::Type::BOOL;
|
||||
}
|
||||
|
||||
sub asS2 {
|
||||
my ($this, $o) = @_;
|
||||
$this->{'lhs'}->asS2($o);
|
||||
$o->write(" or ");
|
||||
$this->{'rhs'}->asS2($o);
|
||||
}
|
||||
|
||||
sub asPerl {
|
||||
my ($this, $bp, $o) = @_;
|
||||
$this->{'lhs'}->asPerl($bp, $o);
|
||||
$o->write(" || ");
|
||||
$this->{'rhs'}->asPerl($bp, $o);
|
||||
}
|
||||
|
||||
53
wcmtools/s2/S2/NodeNamedType.pm
Executable file
53
wcmtools/s2/S2/NodeNamedType.pm
Executable file
@@ -0,0 +1,53 @@
|
||||
#!/usr/bin/perl
|
||||
#
|
||||
|
||||
package S2::NodeNamedType;
|
||||
|
||||
use strict;
|
||||
use S2::Node;
|
||||
use S2::NodeType;
|
||||
use vars qw($VERSION @ISA);
|
||||
|
||||
$VERSION = '1.0';
|
||||
@ISA = qw(S2::Node);
|
||||
|
||||
sub new {
|
||||
my ($class, $name, $type) = @_;
|
||||
my $node = new S2::Node;
|
||||
$node->{'name'} = $name;
|
||||
$node->{'type'} = $type;
|
||||
bless $node, $class;
|
||||
}
|
||||
|
||||
sub cleanForFreeze {
|
||||
my $this = shift;
|
||||
delete $this->{'tokenlist'};
|
||||
$this->{'typenode'}->cleanForFreeze();
|
||||
}
|
||||
|
||||
sub parse {
|
||||
my ($class, $toker) = @_;
|
||||
my $n = new S2::NodeNamedType;
|
||||
|
||||
$n->{'typenode'} = S2::NodeType->parse($toker);
|
||||
$n->{'type'} = $n->{'typenode'}->getType();
|
||||
|
||||
$n->addNode($n->{'typenode'});
|
||||
$n->{'name'} = $n->getIdent($toker)->getIdent();
|
||||
|
||||
return $n;
|
||||
}
|
||||
|
||||
sub getType { shift->{'type'}; }
|
||||
sub getName { shift->{'name'}; }
|
||||
|
||||
sub asS2 {
|
||||
my ($this, $o) = @_;
|
||||
$this->{'typenode'}->asS2($o);
|
||||
}
|
||||
|
||||
sub toString {
|
||||
my ($this, $l, $ck) = @_;
|
||||
$this->{'type'}->toString() . " $this->{'name'}";
|
||||
}
|
||||
|
||||
82
wcmtools/s2/S2/NodePrintStmt.pm
Executable file
82
wcmtools/s2/S2/NodePrintStmt.pm
Executable file
@@ -0,0 +1,82 @@
|
||||
#!/usr/bin/perl
|
||||
#
|
||||
|
||||
package S2::NodePrintStmt;
|
||||
|
||||
use strict;
|
||||
use S2::Node;
|
||||
use vars qw($VERSION @ISA);
|
||||
|
||||
$VERSION = '1.0';
|
||||
@ISA = qw(S2::Node);
|
||||
|
||||
sub new {
|
||||
my ($class) = @_;
|
||||
my $n = new S2::Node;
|
||||
bless $n, $class;
|
||||
}
|
||||
|
||||
sub canStart {
|
||||
my ($class, $toker) = @_;
|
||||
my $p = $toker->peek();
|
||||
return
|
||||
$p->isa('S2::TokenStringLiteral') ||
|
||||
$p == $S2::TokenKeyword::PRINT ||
|
||||
$p == $S2::TokenKeyword::PRINTLN;
|
||||
}
|
||||
|
||||
sub parse {
|
||||
my ($class, $toker) = @_;
|
||||
|
||||
my $n = new S2::NodePrintStmt;
|
||||
my $t = $toker->peek();
|
||||
|
||||
if ($t == $S2::TokenKeyword::PRINT) {
|
||||
$n->setStart($n->eatToken($toker));
|
||||
}
|
||||
if ($t == $S2::TokenKeyword::PRINTLN) {
|
||||
$n->setStart($n->eatToken($toker));
|
||||
$n->{'doNewline'} = 1;
|
||||
}
|
||||
|
||||
$t = $toker->peek();
|
||||
if ($t->isa("S2::TokenIdent") && $t->getIdent() eq "safe") {
|
||||
$n->{'safe'} = 1;
|
||||
$n->eatToken($toker);
|
||||
}
|
||||
|
||||
$n->addNode($n->{'expr'} = S2::NodeExpr->parse($toker));
|
||||
$n->requireToken($toker, $S2::TokenPunct::SCOLON);
|
||||
return $n;
|
||||
}
|
||||
|
||||
sub check {
|
||||
my ($this, $l, $ck) = @_;
|
||||
my $t = $this->{'expr'}->getType($ck);
|
||||
return if $t->equals($S2::Type::INT) ||
|
||||
$t->equals($S2::Type::STRING);
|
||||
unless ($this->{'expr'}->makeAsString($ck)) {
|
||||
S2::error($this, "Print statement must print an expression of type int or string, not " .
|
||||
$t->toString);
|
||||
}
|
||||
}
|
||||
|
||||
sub asS2 {
|
||||
my ($this, $o) = @_;
|
||||
$o->tabwrite($this->{'doNewline'} ? "println " : "print ");
|
||||
$this->{'expr'}->asS2($o);
|
||||
$o->writeln(";");
|
||||
}
|
||||
|
||||
sub asPerl {
|
||||
my ($this, $bp, $o) = @_;
|
||||
if ($bp->untrusted() || $this->{'safe'}) {
|
||||
$o->tabwrite("\$S2::pout_s->(");
|
||||
} else {
|
||||
$o->tabwrite("\$S2::pout->(");
|
||||
}
|
||||
$this->{'expr'}->asPerl($bp, $o);
|
||||
$o->write(" . \"\\n\"") if $this->{'doNewline'};
|
||||
$o->writeln(");");
|
||||
}
|
||||
|
||||
101
wcmtools/s2/S2/NodeProduct.pm
Executable file
101
wcmtools/s2/S2/NodeProduct.pm
Executable file
@@ -0,0 +1,101 @@
|
||||
#!/usr/bin/perl
|
||||
#
|
||||
|
||||
package S2::NodeProduct;
|
||||
|
||||
use strict;
|
||||
use S2::Node;
|
||||
use S2::NodeUnaryExpr;
|
||||
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::NodeUnaryExpr->canStart($toker);
|
||||
}
|
||||
|
||||
sub parse {
|
||||
my ($class, $toker) = @_;
|
||||
|
||||
my $lhs = parse S2::NodeUnaryExpr $toker;
|
||||
|
||||
while ($toker->peek() == $S2::TokenPunct::MULT ||
|
||||
$toker->peek() == $S2::TokenPunct::DIV ||
|
||||
$toker->peek() == $S2::TokenPunct::MOD) {
|
||||
$lhs = parseAnother($toker, $lhs);
|
||||
}
|
||||
|
||||
return $lhs;
|
||||
}
|
||||
|
||||
sub parseAnother {
|
||||
my ($toker, $lhs) = @_;
|
||||
|
||||
my $n = new S2::NodeProduct();
|
||||
|
||||
$n->{'lhs'} = $lhs;
|
||||
$n->addNode($n->{'lhs'});
|
||||
|
||||
$n->{'op'} = $toker->peek();
|
||||
$n->eatToken($toker);
|
||||
$n->skipWhite($toker);
|
||||
|
||||
$n->{'rhs'} = parse S2::NodeUnaryExpr $toker;
|
||||
$n->addNode($n->{'rhs'});
|
||||
$n->skipWhite($toker);
|
||||
|
||||
return $n;
|
||||
}
|
||||
|
||||
sub getType {
|
||||
my ($this, $ck, $wanted) = @_;
|
||||
|
||||
my $lt = $this->{'lhs'}->getType($ck, $wanted);
|
||||
my $rt = $this->{'rhs'}->getType($ck, $wanted);
|
||||
|
||||
unless ($lt->equals($S2::Type::INT)) {
|
||||
S2::error($this->{'lhs'}, "Left hand side of " . $this->{'op'}->getPunct() . " operator is " .
|
||||
$lt->toString() . ", not an integer.");
|
||||
}
|
||||
|
||||
unless ($rt->equals($S2::Type::INT)) {
|
||||
S2::error($this->{'rhs'}, "Right hand side of " . $this->{'op'}->getPunct() . " operator is " .
|
||||
$rt->toString() . ", not an integer.");
|
||||
}
|
||||
|
||||
return $S2::Type::INT;
|
||||
}
|
||||
|
||||
sub asS2 {
|
||||
my ($this, $o) = @_;
|
||||
$this->{'lhs'}->asS2($o);
|
||||
$o->write(" " . $this->{'op'}->getPunct() . " ");
|
||||
$this->{'rhs'}->asS2($o);
|
||||
}
|
||||
|
||||
sub asPerl {
|
||||
my ($this, $bp, $o) = @_;
|
||||
|
||||
$o->write("int(") if $this->{'op'} == $S2::TokenPunct::DIV;
|
||||
$this->{'lhs'}->asPerl($bp, $o);
|
||||
|
||||
if ($this->{'op'} == $S2::TokenPunct::MULT) {
|
||||
$o->write(" * ");
|
||||
} elsif ($this->{'op'} == $S2::TokenPunct::DIV) {
|
||||
$o->write(" / ");
|
||||
} elsif ($this->{'op'} == $S2::TokenPunct::MOD) {
|
||||
$o->write(" % ");
|
||||
}
|
||||
|
||||
$this->{'rhs'}->asPerl($bp, $o);
|
||||
$o->write(")") if $this->{'op'} == $S2::TokenPunct::DIV;
|
||||
}
|
||||
|
||||
106
wcmtools/s2/S2/NodePropGroup.pm
Executable file
106
wcmtools/s2/S2/NodePropGroup.pm
Executable file
@@ -0,0 +1,106 @@
|
||||
#!/usr/bin/perl
|
||||
#
|
||||
|
||||
package S2::NodePropGroup;
|
||||
|
||||
use strict;
|
||||
use S2::Node;
|
||||
use S2::NodeProperty;
|
||||
use S2::NodeSet;
|
||||
use vars qw($VERSION @ISA);
|
||||
|
||||
$VERSION = '1.0';
|
||||
@ISA = qw(S2::Node);
|
||||
|
||||
sub new {
|
||||
my ($class) = @_;
|
||||
my $node = new S2::Node;
|
||||
$node->{'groupident'} = "";
|
||||
$node->{'set_list'} = 0; # true if setting a propgroup list
|
||||
$node->{'list_props'} = []; # array of NodeProperty
|
||||
$node->{'list_sets'} = []; # array of NodeSet
|
||||
$node->{'set_name'} = 0; # true if setting the propgroup name
|
||||
$node->{'name'} = undef;
|
||||
bless $node, $class;
|
||||
}
|
||||
|
||||
sub canStart {
|
||||
my ($class, $toker) = @_;
|
||||
return $toker->peek() == $S2::TokenKeyword::PROPGROUP;
|
||||
}
|
||||
|
||||
sub parse {
|
||||
my ($class, $toker) = @_;
|
||||
my $n = new S2::NodePropGroup;
|
||||
|
||||
$n->setStart($n->requireToken($toker, $S2::TokenKeyword::PROPGROUP));
|
||||
my $ident = $n->getIdent($toker);
|
||||
$n->{'groupident'} = $ident->getIdent();
|
||||
|
||||
if ($toker->peek() == $S2::TokenPunct::LBRACE) {
|
||||
$n->{'set_list'} = 1;
|
||||
$n->requireToken($toker, $S2::TokenPunct::LBRACE);
|
||||
while ($toker->peek() && $toker->peek() != $S2::TokenPunct::RBRACE)
|
||||
{
|
||||
my $node;
|
||||
if (S2::NodeProperty->canStart($toker)) {
|
||||
$node = S2::NodeProperty->parse($toker);
|
||||
push @{$n->{'list_props'}}, $node;
|
||||
}
|
||||
elsif (S2::NodeSet->canStart($toker)) {
|
||||
$node = S2::NodeSet->parse($toker);
|
||||
push @{$n->{'list_sets'}}, $node;
|
||||
}
|
||||
else {
|
||||
my $offender = $toker->peek();
|
||||
S2::error($offender, "Unexpected " . $offender->toString());
|
||||
}
|
||||
$n->addNode($node);
|
||||
}
|
||||
$n->requireToken($toker, $S2::TokenPunct::RBRACE);
|
||||
} else {
|
||||
$n->{'set_name'} = 1;
|
||||
$n->requireToken($toker, $S2::TokenPunct::ASSIGN);
|
||||
my $sl = $n->getStringLiteral($toker);
|
||||
$n->{'name'} = $sl->getString();
|
||||
$n->requireToken($toker, $S2::TokenPunct::SCOLON);
|
||||
}
|
||||
|
||||
return $n;
|
||||
}
|
||||
|
||||
sub check {
|
||||
my ($this, $l, $ck) = @_;
|
||||
|
||||
if ($this->{'set_list'}) {
|
||||
foreach my $prop (@{$this->{'list_props'}}, @{$this->{'list_sets'}}) {
|
||||
$prop->check($l, $ck);
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
sub asS2 {
|
||||
my ($this, $o) = @_;
|
||||
}
|
||||
|
||||
sub asPerl {
|
||||
my ($this, $bp, $o) = @_;
|
||||
|
||||
if ($this->{'set_name'}) {
|
||||
$o->tabwriteln("register_propgroup_name(" .
|
||||
$bp->getLayerIDString() . "," .
|
||||
"'$this->{groupident}', " .
|
||||
$bp->quoteString($this->{'name'}) . ");");
|
||||
return;
|
||||
}
|
||||
|
||||
foreach (@{$this->{'list_props'}}, @{$this->{'list_sets'}}) {
|
||||
$_->asPerl($bp, $o);
|
||||
}
|
||||
|
||||
$o->tabwriteln("register_propgroup_props(" .
|
||||
$bp->getLayerIDString() . "," .
|
||||
"'$this->{groupident}', [".
|
||||
join(', ', map { $bp->quoteString($_->getName) } @{$this->{'list_props'}}) .
|
||||
"]);");
|
||||
}
|
||||
191
wcmtools/s2/S2/NodeProperty.pm
Executable file
191
wcmtools/s2/S2/NodeProperty.pm
Executable file
@@ -0,0 +1,191 @@
|
||||
#!/usr/bin/perl
|
||||
#
|
||||
|
||||
package S2::NodeProperty;
|
||||
|
||||
use strict;
|
||||
use S2::Node;
|
||||
use S2::NodeNamedType;
|
||||
use S2::NodePropertyPair;
|
||||
use vars qw($VERSION @ISA);
|
||||
|
||||
$VERSION = '1.0';
|
||||
@ISA = qw(S2::Node);
|
||||
|
||||
sub new {
|
||||
my ($class) = @_;
|
||||
my $node = new S2::Node;
|
||||
$node->{'nt'} = undef;
|
||||
$node->{'pairs'} = [];
|
||||
$node->{'builtin'} = 0;
|
||||
$node->{'use'} = 0;
|
||||
$node->{'hide'} = 0;
|
||||
$node->{'uhName'} = undef; # if use or hide, then this is property to use/hide
|
||||
bless $node, $class;
|
||||
}
|
||||
|
||||
sub canStart {
|
||||
my ($class, $toker) = @_;
|
||||
return $toker->peek() == $S2::TokenKeyword::PROPERTY;
|
||||
}
|
||||
|
||||
sub parse {
|
||||
my ($class, $toker) = @_;
|
||||
my $n = new S2::NodeProperty;
|
||||
$n->{'pairs'} = [];
|
||||
|
||||
$n->setStart($n->requireToken($toker, $S2::TokenKeyword::PROPERTY));
|
||||
|
||||
if ($toker->peek() == $S2::TokenKeyword::BUILTIN) {
|
||||
$n->{'builtin'} = 1;
|
||||
$n->eatToken($toker);
|
||||
}
|
||||
|
||||
# parse the use/hide case
|
||||
if ($toker->peek()->isa('S2::TokenIdent')) {
|
||||
my $ident = $toker->peek()->getIdent();
|
||||
if ($ident eq "use" || $ident eq "hide") {
|
||||
$n->{'use'} = 1 if $ident eq "use";
|
||||
$n->{'hide'} = 1 if $ident eq "hide";
|
||||
$n->eatToken($toker);
|
||||
|
||||
my $t = $toker->peek();
|
||||
unless ($t->isa('S2::TokenIdent')) {
|
||||
S2::error($t, "Expecting identifier after $ident");
|
||||
}
|
||||
|
||||
$n->{'uhName'} = $t->getIdent();
|
||||
$n->eatToken($toker);
|
||||
$n->requireToken($toker, $S2::TokenPunct::SCOLON);
|
||||
return $n;
|
||||
}
|
||||
}
|
||||
|
||||
$n->addNode($n->{'nt'} = S2::NodeNamedType->parse($toker));
|
||||
|
||||
my $t = $toker->peek();
|
||||
if ($t == $S2::TokenPunct::SCOLON) {
|
||||
$n->eatToken($toker);
|
||||
return $n;
|
||||
}
|
||||
|
||||
$n->requireToken($toker, $S2::TokenPunct::LBRACE);
|
||||
while (S2::NodePropertyPair->canStart($toker)) {
|
||||
my $pair = S2::NodePropertyPair->parse($toker);
|
||||
push @{$n->{'tokenlist'}}, $pair;
|
||||
push @{$n->{'pairs'}}, $pair;
|
||||
}
|
||||
$n->requireToken($toker, $S2::TokenPunct::RBRACE);
|
||||
|
||||
return $n;
|
||||
}
|
||||
|
||||
sub check {
|
||||
my ($this, $l, $ck) = @_;
|
||||
|
||||
if ($this->{'use'}) {
|
||||
unless ($l->getType() eq "layout") {
|
||||
S2::error($this, "Can't declare property usage in non-layout layer");
|
||||
}
|
||||
unless ($ck->propertyType($this->{'uhName'})) {
|
||||
S2::error($this, "Can't declare usage of non-existent property");
|
||||
}
|
||||
return;
|
||||
}
|
||||
|
||||
if ($this->{'hide'}) {
|
||||
unless ($ck->propertyType($this->{'uhName'})) {
|
||||
S2::error($this, "Can't hide non-existent property");
|
||||
}
|
||||
return;
|
||||
}
|
||||
|
||||
my $name = $this->{'nt'}->getName();
|
||||
my $type = $this->{'nt'}->getType();
|
||||
|
||||
if ($l->getType() eq "i18n") {
|
||||
# FIXME: as a special case, allow an i18n layer to
|
||||
# to override the 'des' property of a property, so
|
||||
# that stuff can be translated
|
||||
return;
|
||||
}
|
||||
|
||||
# only core and layout layers can define properties
|
||||
unless ($l->isCoreOrLayout()) {
|
||||
S2::error($this, "Only core and layout layers can define new properties.");
|
||||
}
|
||||
|
||||
# make sure they aren't overriding a property from a lower layer
|
||||
my $existing = $ck->propertyType($name);
|
||||
if ($existing && ! $type->equals($existing)) {
|
||||
S2::error($this, "Can't override property '$name' of type " .
|
||||
$existing->toString . " with new type " .
|
||||
$type->toString . ".");
|
||||
}
|
||||
|
||||
my $basetype = $type->baseType;
|
||||
if (! S2::Type::isPrimitive($basetype) && ! defined $ck->getClass($basetype)) {
|
||||
S2::error($this, "Can't define a property of an unknown class");
|
||||
}
|
||||
|
||||
# all is well, so register this property with its type
|
||||
$ck->addProperty($name, $type, $this->{'builtin'});
|
||||
}
|
||||
|
||||
sub asS2 {
|
||||
my ($this, $o) = @_;
|
||||
$o->tabwrite("property ");
|
||||
$o->write("builtin ") if $this->{'builtin'};
|
||||
if ($this->{'use'} || $this->{'hide'}) {
|
||||
$o->write("use ") if $this->{'use'};
|
||||
$o->write("hide ") if $this->{'hide'};
|
||||
$o->writeln("$this->{'uhName'};");
|
||||
return;
|
||||
}
|
||||
if (@{$this->{'pairs'}}) {
|
||||
$o->writeln(" {");
|
||||
$o->tabIn();
|
||||
foreach my $pp (@{$this->{'pairs'}}) {
|
||||
$pp->asS2($o);
|
||||
}
|
||||
$o->tabOut();
|
||||
$o->writeln("}");
|
||||
} else {
|
||||
$o->writeln(";");
|
||||
}
|
||||
}
|
||||
|
||||
sub getName {
|
||||
my $this = shift;
|
||||
$this->{'uhName'} || $this->{'nt'}->getName();
|
||||
}
|
||||
|
||||
sub asPerl {
|
||||
my ($this, $bp, $o) = @_;
|
||||
|
||||
if ($this->{'use'}) {
|
||||
$o->tabwriteln("register_property_use(" .
|
||||
$bp->getLayerIDString() . "," .
|
||||
$bp->quoteString($this->{'uhName'}) . ");");
|
||||
return;
|
||||
}
|
||||
|
||||
if ($this->{'hide'}) {
|
||||
$o->tabwriteln("register_property_hide(" .
|
||||
$bp->getLayerIDString() . "," .
|
||||
$bp->quoteString($this->{'uhName'}) . ");");
|
||||
return;
|
||||
}
|
||||
|
||||
$o->tabwriteln("register_property(" .
|
||||
$bp->getLayerIDString() . "," .
|
||||
$bp->quoteString($this->{'nt'}->getName()) . ",{");
|
||||
$o->tabIn();
|
||||
$o->tabwriteln("\"type\"=>" . $bp->quoteString($this->{'nt'}->getType->toString) . ",");
|
||||
foreach my $pp (@{$this->{'pairs'}}) {
|
||||
$o->tabwriteln($bp->quoteString($pp->getKey()) . "=>" .
|
||||
$bp->quoteString($pp->getVal()) . ",");
|
||||
}
|
||||
$o->tabOut();
|
||||
$o->writeln("});");
|
||||
}
|
||||
45
wcmtools/s2/S2/NodePropertyPair.pm
Executable file
45
wcmtools/s2/S2/NodePropertyPair.pm
Executable file
@@ -0,0 +1,45 @@
|
||||
#!/usr/bin/perl
|
||||
#
|
||||
|
||||
package S2::NodePropertyPair;
|
||||
|
||||
use strict;
|
||||
use S2::Node;
|
||||
use S2::NodeText;
|
||||
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 S2::NodeText->canStart($toker);
|
||||
}
|
||||
|
||||
sub getKey { shift->{'key'}->getText(); }
|
||||
sub getVal { shift->{'val'}->getText(); }
|
||||
|
||||
sub parse {
|
||||
my ($class, $toker) = @_;
|
||||
my $n = new S2::NodePropertyPair;
|
||||
$n->addNode($n->{'key'} = S2::NodeText->parse($toker));
|
||||
$n->requireToken($toker, $S2::TokenPunct::ASSIGN);
|
||||
$n->addNode($n->{'val'} = S2::NodeText->parse($toker));
|
||||
$n->requireToken($toker, $S2::TokenPunct::SCOLON);
|
||||
return $n;
|
||||
}
|
||||
|
||||
sub asS2 {
|
||||
my ($this, $o) = @_;
|
||||
$o->tabwrite("");
|
||||
$this->{'key'}->asS2($o);
|
||||
$o->write(" = ");
|
||||
$this->{'val'}->asS2($o);
|
||||
$o->write(";");
|
||||
}
|
||||
78
wcmtools/s2/S2/NodeRange.pm
Executable file
78
wcmtools/s2/S2/NodeRange.pm
Executable file
@@ -0,0 +1,78 @@
|
||||
#!/usr/bin/perl
|
||||
#
|
||||
|
||||
package S2::NodeRange;
|
||||
|
||||
use strict;
|
||||
use S2::Node;
|
||||
use S2::NodeLogOrExpr;
|
||||
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::NodeLogOrExpr->canStart($toker);
|
||||
}
|
||||
|
||||
sub parse {
|
||||
my ($class, $toker) = @_;
|
||||
my $n = new S2::NodeRange;
|
||||
|
||||
$n->{'lhs'} = parse S2::NodeLogOrExpr $toker;
|
||||
$n->addNode($n->{'lhs'});
|
||||
|
||||
return $n->{'lhs'} unless
|
||||
$toker->peek() == $S2::TokenPunct::DOTDOT;
|
||||
|
||||
$n->eatToken($toker);
|
||||
|
||||
$n->{'rhs'} = parse S2::NodeLogOrExpr $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, $wanted);
|
||||
|
||||
unless ($lt->equals($S2::Type::INT)) {
|
||||
die "Left operand of range operator is not an integer at ".
|
||||
$this->getFilePos->toString . "\n";
|
||||
}
|
||||
unless ($rt->equals($S2::Type::INT)) {
|
||||
die "Right operand of range operator is not an integer at ".
|
||||
$this->getFilePos->toString . "\n";
|
||||
}
|
||||
|
||||
my $ret = new S2::Type "int";
|
||||
$ret->makeArrayOf();
|
||||
return $ret;
|
||||
}
|
||||
|
||||
sub asS2 {
|
||||
my ($this, $o) = @_;
|
||||
$this->{'lhs'}->asS2($o);
|
||||
$o->write(" .. ");
|
||||
$this->{'rhs'}->asS2($o);
|
||||
}
|
||||
|
||||
sub asPerl {
|
||||
my ($this, $bp, $o) = @_;
|
||||
$o->write("[");
|
||||
$this->{'lhs'}->asPerl($bp, $o);
|
||||
$o->write(" .. ");
|
||||
$this->{'rhs'}->asPerl($bp, $o);
|
||||
$o->write("]");
|
||||
}
|
||||
|
||||
106
wcmtools/s2/S2/NodeRelExpr.pm
Executable file
106
wcmtools/s2/S2/NodeRelExpr.pm
Executable file
@@ -0,0 +1,106 @@
|
||||
#!/usr/bin/perl
|
||||
#
|
||||
|
||||
package S2::NodeRelExpr;
|
||||
|
||||
use strict;
|
||||
use S2::Node;
|
||||
use S2::NodeSum;
|
||||
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::NodeSum->canStart($toker);
|
||||
}
|
||||
|
||||
sub parse {
|
||||
my ($class, $toker) = @_;
|
||||
my $n = new S2::NodeRelExpr;
|
||||
|
||||
$n->{'lhs'} = parse S2::NodeSum $toker;
|
||||
$n->addNode($n->{'lhs'});
|
||||
|
||||
return $n->{'lhs'} unless
|
||||
$toker->peek() == $S2::TokenPunct::LT ||
|
||||
$toker->peek() == $S2::TokenPunct::LTE ||
|
||||
$toker->peek() == $S2::TokenPunct::GT ||
|
||||
$toker->peek() == $S2::TokenPunct::GTE;
|
||||
|
||||
$n->{'op'} = $toker->peek();
|
||||
$n->eatToken($toker);
|
||||
|
||||
$n->{'rhs'} = parse S2::NodeSum $toker;
|
||||
$n->addNode($n->{'rhs'});
|
||||
|
||||
return $n;
|
||||
}
|
||||
|
||||
sub getType {
|
||||
my ($this, $ck) = @_;
|
||||
|
||||
my $lt = $this->{'lhs'}->getType($ck);
|
||||
my $rt = $this->{'rhs'}->getType($ck);
|
||||
|
||||
if (! $lt->equals($rt)) {
|
||||
S2::error($this, "The types of the left and right hand side of " .
|
||||
"equality test expression don't match.");
|
||||
}
|
||||
|
||||
if ($lt->equals($S2::Type::STRING) ||
|
||||
$lt->equals($S2::Type::INT)) {
|
||||
$this->{'myType'} = $lt;
|
||||
return $S2::Type::BOOL;
|
||||
}
|
||||
|
||||
S2::error($this, "Only string and int types can be compared>");
|
||||
}
|
||||
|
||||
sub asS2 {
|
||||
my ($this, $o) = @_;
|
||||
$this->{'lhs'}->asS2($o);
|
||||
$o->write(" " . $this->{'op'}->getPunct() . " ");
|
||||
$this->{'rhs'}->asS2($o);
|
||||
}
|
||||
|
||||
sub asPerl {
|
||||
my ($this, $bp, $o) = @_;
|
||||
$this->{'lhs'}->asPerl($bp, $o);
|
||||
|
||||
if ($this->{'op'} == $S2::TokenPunct::LT) {
|
||||
if ($this->{'myType'}->equals($S2::Type::STRING)) {
|
||||
$o->write(" lt ");
|
||||
} else {
|
||||
$o->write(" < ");
|
||||
}
|
||||
} elsif ($this->{'op'} == $S2::TokenPunct::LTE) {
|
||||
if ($this->{'myType'}->equals($S2::Type::STRING)) {
|
||||
$o->write(" le ");
|
||||
} else {
|
||||
$o->write(" <= ");
|
||||
}
|
||||
} elsif ($this->{'op'} == $S2::TokenPunct::GT) {
|
||||
if ($this->{'myType'}->equals($S2::Type::STRING)) {
|
||||
$o->write(" gt ");
|
||||
} else {
|
||||
$o->write(" > ");
|
||||
}
|
||||
} elsif ($this->{'op'} == $S2::TokenPunct::GTE) {
|
||||
if ($this->{'myType'}->equals($S2::Type::STRING)) {
|
||||
$o->write(" ge ");
|
||||
} else {
|
||||
$o->write(" >= ");
|
||||
}
|
||||
}
|
||||
|
||||
$this->{'rhs'}->asPerl($bp, $o);
|
||||
}
|
||||
|
||||
72
wcmtools/s2/S2/NodeReturnStmt.pm
Executable file
72
wcmtools/s2/S2/NodeReturnStmt.pm
Executable file
@@ -0,0 +1,72 @@
|
||||
#!/usr/bin/perl
|
||||
#
|
||||
|
||||
package S2::NodeReturnStmt;
|
||||
|
||||
use strict;
|
||||
use S2::Node;
|
||||
use S2::NodeExpr;
|
||||
use vars qw($VERSION @ISA);
|
||||
|
||||
$VERSION = '1.0';
|
||||
@ISA = qw(S2::Node);
|
||||
|
||||
sub canStart {
|
||||
my ($class, $toker) = @_;
|
||||
return $toker->peek() == $S2::TokenKeyword::RETURN;
|
||||
}
|
||||
|
||||
sub parse {
|
||||
my ($class, $toker) = @_;
|
||||
my $n = new S2::NodeReturnStmt;
|
||||
$n->setStart($n->requireToken($toker, $S2::TokenKeyword::RETURN));
|
||||
|
||||
# optional return expression
|
||||
if (S2::NodeExpr->canStart($toker)) {
|
||||
$n->addNode($n->{'expr'} = S2::NodeExpr->parse($toker));
|
||||
}
|
||||
|
||||
$n->requireToken($toker, $S2::TokenPunct::SCOLON);
|
||||
return $n;
|
||||
}
|
||||
|
||||
sub check {
|
||||
my ($this, $l, $ck) = @_;
|
||||
|
||||
my $exptype = $ck->getReturnType();
|
||||
my $rettype = $this->{'expr'} ?
|
||||
$this->{'expr'}->getType($ck) :
|
||||
$S2::Type::VOID;
|
||||
|
||||
if ($ck->checkFuncAttr($ck->getInFunction(), "notags")) {
|
||||
$this->{'notags_func'} = 1;
|
||||
}
|
||||
|
||||
unless ($ck->typeIsa($rettype, $exptype)) {
|
||||
S2::error($this, "Return type of " . $rettype->toString . " doesn't match expected type of " . $exptype->toString);
|
||||
}
|
||||
}
|
||||
|
||||
sub asS2 {
|
||||
my ($this, $o) = @_;
|
||||
$o->tabwrite("return");
|
||||
if ($this->{'expr'}) {
|
||||
$o->write(" ");
|
||||
$this->{'expr'}->asS2($o);
|
||||
}
|
||||
$o->writeln(";");
|
||||
}
|
||||
|
||||
sub asPerl {
|
||||
my ($this, $bp, $o) = @_;
|
||||
$o->tabwrite("return");
|
||||
if ($this->{'expr'}) {
|
||||
my $need_notags = $bp->untrusted() && $this->{'notags_func'};
|
||||
$o->write(" ");
|
||||
$o->write("S2::notags(") if $need_notags;
|
||||
$this->{'expr'}->asPerl($bp, $o);
|
||||
$o->write(")") if $need_notags;
|
||||
}
|
||||
$o->writeln(";");
|
||||
}
|
||||
|
||||
101
wcmtools/s2/S2/NodeSet.pm
Executable file
101
wcmtools/s2/S2/NodeSet.pm
Executable file
@@ -0,0 +1,101 @@
|
||||
#!/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;
|
||||
}
|
||||
60
wcmtools/s2/S2/NodeStmt.pm
Executable file
60
wcmtools/s2/S2/NodeStmt.pm
Executable file
@@ -0,0 +1,60 @@
|
||||
#!/usr/bin/perl
|
||||
#
|
||||
|
||||
package S2::NodeStmt;
|
||||
|
||||
use strict;
|
||||
use S2::Node;
|
||||
use S2::NodePrintStmt;
|
||||
use S2::NodeIfStmt;
|
||||
use S2::NodeReturnStmt;
|
||||
use S2::NodeDeleteStmt;
|
||||
use S2::NodeForeachStmt;
|
||||
use S2::NodeVarDeclStmt;
|
||||
use S2::NodeExprStmt;
|
||||
use vars qw($VERSION @ISA);
|
||||
|
||||
$VERSION = '1.0';
|
||||
@ISA = qw(S2::Node);
|
||||
|
||||
sub canStart {
|
||||
my ($class, $toker) = @_;
|
||||
return
|
||||
S2::NodePrintStmt->canStart($toker) ||
|
||||
S2::NodeIfStmt->canStart($toker) ||
|
||||
S2::NodeReturnStmt->canStart($toker) ||
|
||||
S2::NodeDeleteStmt->canStart($toker) ||
|
||||
S2::NodeForeachStmt->canStart($toker) ||
|
||||
S2::NodeVarDeclStmt->canStart($toker) ||
|
||||
S2::NodeExprStmt->canStart($toker);
|
||||
}
|
||||
|
||||
sub parse {
|
||||
my ($class, $toker, $isDecl) = @_;
|
||||
|
||||
return S2::NodePrintStmt->parse($toker)
|
||||
if S2::NodePrintStmt->canStart($toker);
|
||||
|
||||
return S2::NodeIfStmt->parse($toker)
|
||||
if S2::NodeIfStmt->canStart($toker);
|
||||
|
||||
return S2::NodeReturnStmt->parse($toker)
|
||||
if S2::NodeReturnStmt->canStart($toker);
|
||||
|
||||
return S2::NodeDeleteStmt->parse($toker)
|
||||
if S2::NodeDeleteStmt->canStart($toker);
|
||||
|
||||
return S2::NodeForeachStmt->parse($toker)
|
||||
if S2::NodeForeachStmt->canStart($toker);
|
||||
|
||||
return S2::NodeVarDeclStmt->parse($toker)
|
||||
if S2::NodeVarDeclStmt->canStart($toker);
|
||||
|
||||
# important that this is last:
|
||||
# (otherwise idents would be seen as function calls)
|
||||
return S2::NodeExprStmt->parse($toker)
|
||||
if S2::NodeExprStmt->canStart($toker);
|
||||
|
||||
S2::error($toker->peek(), "Don't know how to parse this type of statement");
|
||||
}
|
||||
|
||||
142
wcmtools/s2/S2/NodeStmtBlock.pm
Executable file
142
wcmtools/s2/S2/NodeStmtBlock.pm
Executable file
@@ -0,0 +1,142 @@
|
||||
#!/usr/bin/perl
|
||||
#
|
||||
|
||||
package S2::NodeStmtBlock;
|
||||
|
||||
use strict;
|
||||
use S2::Node;
|
||||
use S2::NodeStmt;
|
||||
use vars qw($VERSION @ISA);
|
||||
|
||||
$VERSION = '1.0';
|
||||
@ISA = qw(S2::Node);
|
||||
|
||||
sub new {
|
||||
my ($class) = @_;
|
||||
my $node = new S2::Node;
|
||||
$node->{'stmtlist'} = [];
|
||||
$node->{'returnType'} = undef;
|
||||
$node->{'localvars'} = {}; # string -> Type
|
||||
bless $node, $class;
|
||||
}
|
||||
|
||||
sub parse {
|
||||
my ($class, $toker, $isDecl) = @_;
|
||||
my $ns = new S2::NodeStmtBlock;
|
||||
$ns->setStart($ns->requireToken($toker, $S2::TokenPunct::LBRACE));
|
||||
|
||||
my $loop = 1;
|
||||
my $closed = 0;
|
||||
|
||||
do {
|
||||
$ns->skipWhite($toker);
|
||||
my $p = $toker->peek();
|
||||
|
||||
if (! defined $p) {
|
||||
$loop = 0;
|
||||
} elsif ($p == $S2::TokenPunct::RBRACE) {
|
||||
$ns->eatToken($toker);
|
||||
$closed = 1;
|
||||
$loop = 0;
|
||||
} elsif (S2::NodeStmt->canStart($toker)) {
|
||||
my $s = parse S2::NodeStmt $toker;
|
||||
push @{$ns->{'stmtlist'}}, $s;
|
||||
$ns->addNode($s);
|
||||
} else {
|
||||
S2::error($p, "Unexpected token parsing statement block");
|
||||
}
|
||||
|
||||
} while ($loop);
|
||||
|
||||
S2::error($ns, "Didn't find closing brace in statement block")
|
||||
unless $closed;
|
||||
|
||||
return $ns;
|
||||
}
|
||||
|
||||
sub addLocalVar {
|
||||
my ($this, $v, $t) = @_;
|
||||
$this->{'localvars'}->{$v} = $t;
|
||||
}
|
||||
|
||||
sub getLocalVar {
|
||||
my ($this, $v) = @_;
|
||||
$this->{'localvars'}->{$v};
|
||||
}
|
||||
|
||||
sub setReturnType {
|
||||
my ($this, $t) = @_;
|
||||
$this->{'returnType'} = $t;
|
||||
}
|
||||
|
||||
sub willReturn {
|
||||
my ($this) = @_;
|
||||
|
||||
return 0 unless @{$this->{'stmtlist'}};
|
||||
my $ns = $this->{'stmtlist'}->[-1];
|
||||
|
||||
# a return statement obviously returns
|
||||
return 1 if $ns->isa('S2::NodeReturnStmt');
|
||||
|
||||
# and if statement at the end of a function returns
|
||||
# if all paths return, so ask the ifstatement
|
||||
if ($ns->isa('S2::NodeIfStmt')) {
|
||||
return $ns->willReturn();
|
||||
}
|
||||
|
||||
# all other types don't return
|
||||
return 0;
|
||||
}
|
||||
|
||||
sub check {
|
||||
my ($this, $l, $ck) = @_;
|
||||
|
||||
# set the return type for any returnstmts that need it.
|
||||
# NOTE: the returnType is non-null if and only if it's
|
||||
# attached to a function.
|
||||
$ck->setReturnType($this->{'returnType'})
|
||||
if $this->{'returnType'};
|
||||
|
||||
foreach my $ns (@{$this->{'stmtlist'}}) {
|
||||
$ns->check($l, $ck);
|
||||
}
|
||||
|
||||
if ($this->{'returnType'} &&
|
||||
! $this->{'returnType'}->equals($S2::Type::VOID) &&
|
||||
! $this->willReturn()) {
|
||||
S2::error($this, "Statement block isn't guaranteed to return (should return " .
|
||||
$this->{'returnType'}->toString . ")");
|
||||
}
|
||||
}
|
||||
|
||||
sub asS2 {
|
||||
my ($this, $o) = @_;
|
||||
$o->writeln("{");
|
||||
$o->tabIn();
|
||||
foreach my $ns (@{$this->{'stmtlist'}}) {
|
||||
$ns->asS2($o);
|
||||
}
|
||||
$o->tabOut();
|
||||
$o->tabwrite("}");
|
||||
}
|
||||
|
||||
sub asPerl {
|
||||
my ($this, $bp, $o, $doCurlies) = @_;
|
||||
$doCurlies = 1 unless defined $doCurlies;
|
||||
|
||||
if ($doCurlies) {
|
||||
$o->writeln("{");
|
||||
$o->tabIn();
|
||||
}
|
||||
|
||||
foreach my $ns (@{$this->{'stmtlist'}}) {
|
||||
$ns->asPerl($bp, $o);
|
||||
}
|
||||
|
||||
if ($doCurlies) {
|
||||
$o->tabOut();
|
||||
$o->tabwrite("}");
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
124
wcmtools/s2/S2/NodeSum.pm
Executable file
124
wcmtools/s2/S2/NodeSum.pm
Executable file
@@ -0,0 +1,124 @@
|
||||
#!/usr/bin/perl
|
||||
#
|
||||
|
||||
package S2::NodeSum;
|
||||
|
||||
use strict;
|
||||
use S2::Node;
|
||||
use S2::NodeProduct;
|
||||
use vars qw($VERSION @ISA);
|
||||
|
||||
$VERSION = '1.0';
|
||||
@ISA = qw(S2::Node);
|
||||
|
||||
sub new {
|
||||
my ($class, $lhs, $op, $rhs) = @_;
|
||||
my $node = new S2::Node;
|
||||
$node->{'lhs'} = $lhs;
|
||||
$node->{'op'} = $op;
|
||||
$node->{'rhs'} = $rhs;
|
||||
bless $node, $class;
|
||||
}
|
||||
|
||||
sub canStart {
|
||||
my ($class, $toker) = @_;
|
||||
S2::NodeProduct->canStart($toker);
|
||||
}
|
||||
|
||||
sub parse {
|
||||
my ($class, $toker) = @_;
|
||||
|
||||
my $lhs = parse S2::NodeProduct $toker;
|
||||
$lhs->skipWhite($toker);
|
||||
|
||||
while ($toker->peek() == $S2::TokenPunct::PLUS ||
|
||||
$toker->peek() == $S2::TokenPunct::MINUS) {
|
||||
$lhs = parseAnother($toker, $lhs);
|
||||
}
|
||||
|
||||
return $lhs;
|
||||
}
|
||||
|
||||
sub parseAnother {
|
||||
my ($toker, $lhs) = @_;
|
||||
|
||||
my $n = new S2::NodeSum();
|
||||
|
||||
$n->{'lhs'} = $lhs;
|
||||
$n->addNode($n->{'lhs'});
|
||||
|
||||
$n->{'op'} = $toker->peek();
|
||||
$n->eatToken($toker);
|
||||
$n->skipWhite($toker);
|
||||
|
||||
$n->{'rhs'} = parse S2::NodeProduct $toker;
|
||||
$n->addNode($n->{'rhs'});
|
||||
$n->skipWhite($toker);
|
||||
|
||||
return $n;
|
||||
}
|
||||
|
||||
sub getType {
|
||||
my ($this, $ck, $wanted) = @_;
|
||||
|
||||
my $lt = $this->{'lhs'}->getType($ck, $wanted);
|
||||
my $rt = $this->{'rhs'}->getType($ck, $wanted);
|
||||
|
||||
unless ($lt->equals($S2::Type::INT) ||
|
||||
$lt->equals($S2::Type::STRING))
|
||||
{
|
||||
if ($this->{'lhs'}->makeAsString($ck)) {
|
||||
$lt = $S2::Type::STRING;
|
||||
} else {
|
||||
S2::error($this->{'lhs'}, "Left hand side of " . $this->{'op'}->getPunct() .
|
||||
" operator is " . $lt->toString() . ", not a string or integer");
|
||||
}
|
||||
}
|
||||
|
||||
unless ($rt->equals($S2::Type::INT) ||
|
||||
$rt->equals($S2::Type::STRING))
|
||||
{
|
||||
if ($this->{'rhs'}->makeAsString($ck)) {
|
||||
$rt = $S2::Type::STRING;
|
||||
} else {
|
||||
S2::error($this->{'rhs'}, "Right hand side of " . $this->{'op'}->getPunct() .
|
||||
" operator is " . $rt->toString() . ", not a string or integer");
|
||||
}
|
||||
}
|
||||
|
||||
if ($this->{'op'} == $S2::TokenPunct::MINUS &&
|
||||
($lt->equals($S2::Type::STRING) ||
|
||||
$rt->equals($S2::Type::STRING))) {
|
||||
S2::error($this->{'rhs'}, "Can't substract strings.");
|
||||
}
|
||||
|
||||
if ($lt->equals($S2::Type::STRING) ||
|
||||
$rt->equals($S2::Type::STRING)) {
|
||||
return $this->{'myType'} = $S2::Type::STRING;
|
||||
}
|
||||
|
||||
return $this->{'myType'} = $S2::Type::INT;
|
||||
}
|
||||
|
||||
sub asS2 {
|
||||
my ($this, $o) = @_;
|
||||
$this->{'lhs'}->asS2($o);
|
||||
$o->write(" " . $this->{'op'}->getPunct() . " ");
|
||||
$this->{'rhs'}->asS2($o);
|
||||
}
|
||||
|
||||
sub asPerl {
|
||||
my ($this, $bp, $o) = @_;
|
||||
$this->{'lhs'}->asPerl($bp, $o);
|
||||
|
||||
if ($this->{'myType'} == $S2::Type::STRING) {
|
||||
$o->write(" . ");
|
||||
} elsif ($this->{'op'} == $S2::TokenPunct::PLUS) {
|
||||
$o->write(" + ");
|
||||
} elsif ($this->{'op'} == $S2::TokenPunct::MINUS) {
|
||||
$o->write(" - ");
|
||||
}
|
||||
|
||||
$this->{'rhs'}->asPerl($bp, $o);
|
||||
}
|
||||
|
||||
666
wcmtools/s2/S2/NodeTerm.pm
Executable file
666
wcmtools/s2/S2/NodeTerm.pm
Executable file
@@ -0,0 +1,666 @@
|
||||
#!/usr/bin/perl
|
||||
#
|
||||
|
||||
package S2::NodeTerm;
|
||||
|
||||
use strict;
|
||||
use S2::Node;
|
||||
use S2::NodeExpr;
|
||||
use S2::NodeArrayLiteral;
|
||||
use S2::NodeArguments;
|
||||
|
||||
use vars qw($VERSION @ISA
|
||||
$INTEGER $STRING $BOOL $VARREF $SUBEXPR
|
||||
$DEFINEDTEST $SIZEFUNC $REVERSEFUNC $ISNULLFUNC
|
||||
$NEW $NEWNULL $FUNCCALL $METHCALL $ARRAY $OBJ_INTERPOLATE);
|
||||
|
||||
$VERSION = '1.0';
|
||||
@ISA = qw(S2::NodeExpr);
|
||||
|
||||
$INTEGER = 1;
|
||||
$STRING = 2;
|
||||
$BOOL = 3;
|
||||
$VARREF = 4;
|
||||
$SUBEXPR = 5;
|
||||
$DEFINEDTEST = 6;
|
||||
$SIZEFUNC = 7;
|
||||
$REVERSEFUNC = 8;
|
||||
$ISNULLFUNC = 12;
|
||||
$NEW = 9;
|
||||
$NEWNULL = 13;
|
||||
$FUNCCALL = 10;
|
||||
$METHCALL = 11;
|
||||
$ARRAY = 14;
|
||||
$OBJ_INTERPOLATE = 15;
|
||||
|
||||
sub new {
|
||||
my ($class, $n) = @_;
|
||||
my $node = new S2::NodeExpr;
|
||||
bless $node, $class;
|
||||
}
|
||||
|
||||
sub canStart {
|
||||
my ($class, $toker) = @_;
|
||||
my $t = $toker->peek();
|
||||
|
||||
return $t->isa('S2::TokenIntegerLiteral') ||
|
||||
$t->isa('S2::TokenStringLiteral') ||
|
||||
$t->isa('S2::TokenIdent') ||
|
||||
$t == $S2::TokenPunct::DOLLAR ||
|
||||
$t == $S2::TokenPunct::LPAREN ||
|
||||
$t == $S2::TokenPunct::LBRACK ||
|
||||
$t == $S2::TokenPunct::LBRACE ||
|
||||
$t == $S2::TokenKeyword::DEFINED ||
|
||||
$t == $S2::TokenKeyword::TRUE ||
|
||||
$t == $S2::TokenKeyword::FALSE ||
|
||||
$t == $S2::TokenKeyword::NEW ||
|
||||
$t == $S2::TokenKeyword::SIZE ||
|
||||
$t == $S2::TokenKeyword::REVERSE ||
|
||||
$t == $S2::TokenKeyword::ISNULL ||
|
||||
$t == $S2::TokenKeyword::NULL;
|
||||
}
|
||||
|
||||
sub getType {
|
||||
my ($this, $ck, $wanted) = @_;
|
||||
return $this->{'_cache_type'} if exists $this->{'_cache_type'};
|
||||
$this->{'_cache_type'} = _getType($this, $ck, $wanted);
|
||||
}
|
||||
|
||||
sub _getType {
|
||||
my ($this, $ck, $wanted) = @_;
|
||||
my $type = $this->{'type'};
|
||||
|
||||
if ($type == $INTEGER) { return $S2::Type::INT; }
|
||||
|
||||
if ($type == $STRING) {
|
||||
return $this->{'nodeString'}->getType($ck, $S2::Type::STRING)
|
||||
if $this->{'nodeString'};
|
||||
if ($ck->isStringCtor($wanted)) {
|
||||
$this->{'ctorclass'} = $wanted->baseType();
|
||||
return $wanted;
|
||||
}
|
||||
return $S2::Type::STRING;
|
||||
}
|
||||
|
||||
if ($type == $SUBEXPR) { return $this->{'subExpr'}->getType($ck, $wanted); }
|
||||
|
||||
if ($type == $BOOL) { return $S2::Type::BOOL; }
|
||||
|
||||
if ($type == $SIZEFUNC) {
|
||||
$this->{'subType'} = $this->{'subExpr'}->getType($ck);
|
||||
return $S2::Type::INT if
|
||||
$this->{'subType'}->isArrayOf() ||
|
||||
$this->{'subType'}->isHashOf() ||
|
||||
$this->{'subType'}->equals($S2::Type::STRING);
|
||||
S2::error($this, "Can't use size on expression that's not a string, hash or array.");
|
||||
}
|
||||
|
||||
if ($type == $REVERSEFUNC) {
|
||||
$this->{'subType'} = $this->{'subExpr'}->getType($ck);
|
||||
|
||||
# reverse a string
|
||||
return $S2::Type::STRING if
|
||||
$this->{'subType'}->equals($S2::Type::STRING);
|
||||
|
||||
# reverse an array
|
||||
return $this->{'subType'} if
|
||||
$this->{'subType'}->isArrayOf();
|
||||
|
||||
S2::error($this, "Can't reverse on expression that's not a string or array.");
|
||||
}
|
||||
|
||||
if ($type == $ISNULLFUNC || $type == $DEFINEDTEST) {
|
||||
my $op = ($type == $ISNULLFUNC) ? "isnull" : "defined";
|
||||
$this->{'subType'} = $this->{'subExpr'}->getType($ck);
|
||||
|
||||
if ($this->{'subExpr'}->isa('S2::NodeTerm')) {
|
||||
my $nt = $this->{'subExpr'};
|
||||
if ($nt->{'type'} != $VARREF && $nt->{'type'} != $FUNCCALL &&
|
||||
$nt->{'type'} != $METHCALL) {
|
||||
S2::error($this, "$op must only be used on an object variable, ".
|
||||
"function call or method call.");
|
||||
}
|
||||
} else {
|
||||
S2::error($this, "$op must only be used on an object variable, ".
|
||||
"function call or method call.");
|
||||
}
|
||||
|
||||
# can't be used on arrays and hashes
|
||||
unless ($this->{'subType'}->isSimple()) {
|
||||
S2::error($this, "Can't use $op on an array or hash.");
|
||||
}
|
||||
|
||||
# not primitive types either
|
||||
if ($this->{'subType'}->isPrimitive()) {
|
||||
S2::error($this, "Can't use $op on primitive types.");
|
||||
}
|
||||
|
||||
# nor void
|
||||
if ($this->{'subType'}->equals($S2::Type::VOID)) {
|
||||
S2::error($this, "Can't use $op on a void value.");
|
||||
}
|
||||
|
||||
return $S2::Type::BOOL;
|
||||
}
|
||||
|
||||
if ($type == $NEW || $type == $NEWNULL) {
|
||||
my $clas = $this->{'newClass'}->getIdent();
|
||||
if ($clas eq "int" || $clas eq "string") {
|
||||
S2::error($this, "Can't use 'new' with primitive type '$clas'");
|
||||
}
|
||||
my $nc = $ck->getClass($clas);
|
||||
unless ($nc) {
|
||||
S2::error($this, "Can't instantiate unknown class.");
|
||||
}
|
||||
return new S2::Type $clas;
|
||||
}
|
||||
|
||||
if ($type == $VARREF) {
|
||||
unless ($ck->getInFunction()) {
|
||||
S2::error($this, "Can't reference a variable outside of a function.");
|
||||
}
|
||||
return $this->{'var'}->getType($ck, $wanted);
|
||||
}
|
||||
|
||||
if ($type == $METHCALL || $type == $FUNCCALL) {
|
||||
S2::error($this, "Can't call a function or method outside of a function")
|
||||
unless $ck->getInFunction();
|
||||
|
||||
if ($type == $METHCALL) {
|
||||
my $vartype = $this->{'var'}->getType($ck, $wanted);
|
||||
S2::error($this, "Cannot call a method on an array or hash")
|
||||
unless $vartype->isSimple();
|
||||
|
||||
$this->{'funcClass'} = $vartype->toString;
|
||||
|
||||
my $methClass = $ck->getClass($this->{'funcClass'});
|
||||
S2::error($this, "Can't call a method on an instance of an undefined class")
|
||||
unless $methClass;
|
||||
}
|
||||
|
||||
$this->{'funcID'} =
|
||||
S2::Checker::functionID($this->{'funcClass'},
|
||||
$this->{'funcIdent'}->getIdent(),
|
||||
$this->{'funcArgs'}->typeList($ck));
|
||||
$this->{'funcBuiltin'} = $ck->isFuncBuiltin($this->{'funcID'});
|
||||
|
||||
$this->{'funcID_noclass'} =
|
||||
S2::Checker::functionID(undef,
|
||||
$this->{'funcIdent'}->getIdent(),
|
||||
$this->{'funcArgs'}->typeList($ck));
|
||||
|
||||
my $t = $ck->functionType($this->{'funcID'});
|
||||
$this->{'funcNum'} = $ck->functionNum($this->{'funcID'})
|
||||
unless $this->{'funcBuiltin'};
|
||||
|
||||
S2::error($this, "Unknown function $this->{'funcID'}")
|
||||
unless $t;
|
||||
|
||||
return $t;
|
||||
}
|
||||
|
||||
if ($type == $ARRAY) {
|
||||
return $this->{'subExpr'}->getType($ck, $wanted);
|
||||
}
|
||||
|
||||
S2::error($this, "Unknown NodeTerm type");
|
||||
}
|
||||
|
||||
sub isLValue {
|
||||
my $this = shift;
|
||||
return 1 if $this->{'type'} == $VARREF;
|
||||
return $this->{'subExpr'}->isLValue()
|
||||
if $this->{'type'} == $SUBEXPR;
|
||||
return 0;
|
||||
}
|
||||
|
||||
# make the object interpolate in a string
|
||||
sub makeAsString {
|
||||
my ($this, $ck) = @_;
|
||||
|
||||
if ($this->{'type'} == $STRING) {
|
||||
return $this->{'nodeString'}->makeAsString($ck);
|
||||
}
|
||||
return 0 unless $this->{'type'} == $VARREF;
|
||||
|
||||
my $t = $this->{'var'}->getType($ck);
|
||||
return 0 unless $t->isSimple();
|
||||
|
||||
my $bt = $t->baseType;
|
||||
|
||||
# class has .toString() or .as_string() method?
|
||||
if (my $methname = $ck->classHasToString($bt)) {
|
||||
# let's change this VARREF into a METHCALL!
|
||||
# warning: ugly hacks ahead...
|
||||
my $funcID = "${bt}::$methname()";
|
||||
if ($ck->isFuncBuiltin($funcID)) {
|
||||
# builtins map to a normal function call.
|
||||
# the builtin function is responsible for checking if the
|
||||
# object is S2::check_defined() and then returning nothing.
|
||||
$this->{'type'} = $METHCALL;
|
||||
$this->{'funcIdent'} = new S2::TokenIdent $methname;
|
||||
$this->{'funcClass'} = $bt;
|
||||
$this->{'funcArgs'} = new S2::NodeArguments; # empty
|
||||
$this->{'funcID_noclass'} = "$methname()";
|
||||
$this->{'funcID'} = $funcID;
|
||||
$this->{'funcBuiltin'} = 1;
|
||||
} else {
|
||||
# if it's S2-level as_string(), then we call
|
||||
# S2::interpolate_object($ctx, "ClassName", $obj, $methname)
|
||||
$this->{'type'} = $OBJ_INTERPOLATE;
|
||||
$this->{'funcClass'} = $bt;
|
||||
$this->{'objint_method'} = $methname;
|
||||
|
||||
}
|
||||
return 1;
|
||||
}
|
||||
|
||||
# class has $.as_string string member?
|
||||
if ($ck->classHasAsString($bt)) {
|
||||
$this->{'var'}->useAsString();
|
||||
return 1;
|
||||
}
|
||||
|
||||
return 0;
|
||||
}
|
||||
|
||||
sub parse {
|
||||
my ($class, $toker) = @_;
|
||||
my $nt = new S2::NodeTerm;
|
||||
my $t = $toker->peek();
|
||||
|
||||
# integer literal
|
||||
if ($t->isa('S2::TokenIntegerLiteral')) {
|
||||
$nt->{'type'} = $INTEGER;
|
||||
$nt->{'tokInt'} = $nt->eatToken($toker);
|
||||
return $nt;
|
||||
}
|
||||
|
||||
# boolean literal
|
||||
if ($t == $S2::TokenKeyword::TRUE ||
|
||||
$t == $S2::TokenKeyword::FALSE) {
|
||||
$nt->{'type'} = $BOOL;
|
||||
$nt->{'boolValue'} = $t == $S2::TokenKeyword::TRUE;
|
||||
$nt->eatToken($toker);
|
||||
return $nt;
|
||||
}
|
||||
|
||||
# string literal
|
||||
if ($t->isa('S2::TokenStringLiteral')) {
|
||||
my $ts = $t;
|
||||
my $ql = $ts->getQuotesLeft();
|
||||
my $qr = $ts->getQuotesRight();
|
||||
|
||||
if ($qr) {
|
||||
# whole string literal
|
||||
$nt->{'type'} = $STRING;
|
||||
$nt->{'tokStr'} = $nt->eatToken($toker);
|
||||
$nt->setStart($nt->{'tokStr'});
|
||||
return $nt;
|
||||
}
|
||||
|
||||
# interpolated string literal (turn into a subexpr)
|
||||
my $toklist = [];
|
||||
$toker->pushInString($ql);
|
||||
|
||||
$nt->{'type'} = $STRING;
|
||||
$nt->{'tokStr'} = $nt->eatToken($toker);
|
||||
push @$toklist, $nt->{'tokStr'}->clone();
|
||||
$nt->{'tokStr'}->setQuotesRight($ql);
|
||||
|
||||
my $lhs = $nt;
|
||||
my $filepos = $nt->{'tokStr'}->getFilePos();
|
||||
|
||||
my $loop = 1;
|
||||
while ($loop) {
|
||||
my $rhs = undef;
|
||||
my $tok = $toker->peek();
|
||||
unless ($tok) {
|
||||
S2::error($tok, "Unexpected end of file. Unclosed string literal?");
|
||||
}
|
||||
if ($tok->isa('S2::TokenStringLiteral')) {
|
||||
$rhs = new S2::NodeTerm;
|
||||
$ts = $tok;
|
||||
$rhs->{'type'} = $STRING;
|
||||
$rhs->{'tokStr'} = $rhs->eatToken($toker);
|
||||
push @$toklist, $rhs->{'tokStr'}->clone();
|
||||
|
||||
$loop = 0 if $ts->getQuotesRight() == $ql;
|
||||
$ts->setQuotesRight($ql);
|
||||
$ts->setQuotesLeft($ql);
|
||||
} elsif ($tok == $S2::TokenPunct::DOLLAR) {
|
||||
$rhs = parse S2::NodeTerm $toker;
|
||||
push @$toklist, @{$rhs->getTokenList()};
|
||||
} else {
|
||||
S2::error($tok, "Error parsing interpolated string: " . $tok->toString);
|
||||
}
|
||||
|
||||
# don't make a sum out of a blank string on either side
|
||||
my $join = 1;
|
||||
if ($lhs->isa('S2::NodeTerm') &&
|
||||
$lhs->{'type'} == $STRING &&
|
||||
length($lhs->{'tokStr'}->getString()) == 0)
|
||||
{
|
||||
$lhs = $rhs;
|
||||
$join = 0;
|
||||
}
|
||||
if ($rhs->isa('S2::NodeTerm') &&
|
||||
$rhs->{'type'} == $STRING &&
|
||||
length($rhs->{'tokStr'}->getString()) == 0)
|
||||
{
|
||||
$join = 0;
|
||||
}
|
||||
|
||||
if ($join) {
|
||||
$lhs = S2::NodeSum->new($lhs, $S2::TokenPunct::PLUS, $rhs);
|
||||
}
|
||||
}
|
||||
|
||||
$toker->popInString();
|
||||
|
||||
$lhs->setTokenList($toklist);
|
||||
$lhs->setStart($filepos);
|
||||
|
||||
my $rnt = new S2::NodeTerm;
|
||||
$rnt->{'type'} = $STRING;
|
||||
$rnt->{'nodeString'} = $lhs;
|
||||
$rnt->addNode($lhs);
|
||||
|
||||
return $rnt;
|
||||
}
|
||||
|
||||
# Sub-expression (in parenthesis)
|
||||
if ($t == $S2::TokenPunct::LPAREN) {
|
||||
$nt->{'type'} = $SUBEXPR;
|
||||
$nt->setStart($nt->eatToken($toker));
|
||||
|
||||
$nt->{'subExpr'} = parse S2::NodeExpr $toker;
|
||||
$nt->addNode($nt->{'subExpr'});
|
||||
|
||||
$nt->requireToken($toker, $S2::TokenPunct::RPAREN);
|
||||
return $nt;
|
||||
}
|
||||
|
||||
# defined test
|
||||
if ($t == $S2::TokenKeyword::DEFINED) {
|
||||
$nt->{'type'} = $DEFINEDTEST;
|
||||
$nt->setStart($nt->eatToken($toker));
|
||||
$nt->{'subExpr'} = parse S2::NodeTerm $toker;
|
||||
$nt->addNode($nt->{'subExpr'});
|
||||
return $nt;
|
||||
}
|
||||
|
||||
# reverse function
|
||||
if ($t == $S2::TokenKeyword::REVERSE) {
|
||||
$nt->{'type'} = $REVERSEFUNC;
|
||||
$nt->eatToken($toker);
|
||||
$nt->{'subExpr'} = parse S2::NodeTerm $toker;
|
||||
$nt->addNode($nt->{'subExpr'});
|
||||
return $nt;
|
||||
}
|
||||
|
||||
# size function
|
||||
if ($t == $S2::TokenKeyword::SIZE) {
|
||||
$nt->{'type'} = $SIZEFUNC;
|
||||
$nt->eatToken($toker);
|
||||
$nt->{'subExpr'} = parse S2::NodeTerm $toker;
|
||||
$nt->addNode($nt->{'subExpr'});
|
||||
return $nt;
|
||||
}
|
||||
|
||||
# isnull function
|
||||
if ($t == $S2::TokenKeyword::ISNULL) {
|
||||
$nt->{'type'} = $ISNULLFUNC;
|
||||
$nt->eatToken($toker);
|
||||
$nt->{'subExpr'} = parse S2::NodeTerm $toker;
|
||||
$nt->addNode($nt->{'subExpr'});
|
||||
return $nt;
|
||||
}
|
||||
|
||||
# new andnull
|
||||
if ($t == $S2::TokenKeyword::NEW ||
|
||||
$t == $S2::TokenKeyword::NULL) {
|
||||
$nt->{'type'} = $t == $S2::TokenKeyword::NEW ? $NEW : $NEWNULL;
|
||||
$nt->eatToken($toker);
|
||||
$nt->{'newClass'} = $nt->getIdent($toker);
|
||||
return $nt;
|
||||
}
|
||||
|
||||
# VarRef
|
||||
if ($t == $S2::TokenPunct::DOLLAR) {
|
||||
$nt->{'type'} = $VARREF;
|
||||
$nt->{'var'} = parse S2::NodeVarRef $toker;
|
||||
$nt->addNode($nt->{'var'});
|
||||
|
||||
# check for -> after, like: $object->method(arg1, arg2, ...)
|
||||
if ($toker->peek() == $S2::TokenPunct::DEREF) {
|
||||
$nt->{'derefLine'} = $toker->peek()->getFilePos()->line;
|
||||
$nt->eatToken($toker);
|
||||
$nt->{'type'} = $METHCALL;
|
||||
# don't return... parsing continues below.
|
||||
} else {
|
||||
return $nt;
|
||||
}
|
||||
}
|
||||
|
||||
# function/method call
|
||||
if ($nt->{'type'} == $METHCALL || $t->isa('S2::TokenIdent')) {
|
||||
$nt->{'type'} = $FUNCCALL unless $nt->{'type'} == $METHCALL;
|
||||
$nt->{'funcIdent'} = $nt->getIdent($toker);
|
||||
$nt->{'funcArgs'} = parse S2::NodeArguments $toker;
|
||||
$nt->addNode($nt->{'funcArgs'});
|
||||
return $nt;
|
||||
}
|
||||
|
||||
# array/hash literal
|
||||
if (S2::NodeArrayLiteral->canStart($toker)) {
|
||||
$nt->{'type'} = $ARRAY;
|
||||
$nt->{'subExpr'} = parse S2::NodeArrayLiteral $toker;
|
||||
$nt->addNode($nt->{'subExpr'});
|
||||
return $nt;
|
||||
}
|
||||
|
||||
S2::error($toker->peek(), "Can't finish parsing NodeTerm");
|
||||
}
|
||||
|
||||
|
||||
sub asS2 {
|
||||
my ($this, $o) = @_;
|
||||
die "NodeTerm::asS2(): not implemented";
|
||||
}
|
||||
|
||||
sub asPerl {
|
||||
my ($this, $bp, $o) = @_;
|
||||
my $type = $this->{'type'};
|
||||
|
||||
if ($type == $INTEGER) {
|
||||
$this->{'tokInt'}->asPerl($bp, $o);
|
||||
return;
|
||||
}
|
||||
|
||||
if ($type == $STRING) {
|
||||
if (defined $this->{'nodeString'}) {
|
||||
$o->write("(");
|
||||
$this->{'nodeString'}->asPerl($bp, $o);
|
||||
$o->write(")");
|
||||
return;
|
||||
}
|
||||
if ($this->{'ctorclass'}) {
|
||||
my $pkg = $bp->getBuiltinPackage() || "S2::Builtin";
|
||||
$o->write("${pkg}::$this->{'ctorclass'}__$this->{'ctorclass'}(");
|
||||
}
|
||||
$this->{'tokStr'}->asPerl($bp, $o);
|
||||
$o->write(")") if $this->{'ctorclass'};
|
||||
return;
|
||||
}
|
||||
|
||||
if ($type == $BOOL) {
|
||||
$o->write($this->{'boolValue'} ? "1" : "0");
|
||||
return;
|
||||
}
|
||||
|
||||
if ($type == $SUBEXPR) {
|
||||
$o->write("(");
|
||||
$this->{'subExpr'}->asPerl($bp, $o);
|
||||
$o->write(")");
|
||||
return;
|
||||
}
|
||||
|
||||
if ($type == $ARRAY) {
|
||||
$this->{'subExpr'}->asPerl($bp, $o);
|
||||
return;
|
||||
}
|
||||
|
||||
if ($type == $NEW) {
|
||||
$o->write("{'_type'=>" .
|
||||
$bp->quoteString($this->{'newClass'}->getIdent()) .
|
||||
"}");
|
||||
return;
|
||||
}
|
||||
|
||||
if ($type == $NEWNULL) {
|
||||
$o->write("{'_type'=>" .
|
||||
$bp->quoteString($this->{'newClass'}->getIdent()) .
|
||||
", '_isnull'=>1}");
|
||||
return;
|
||||
}
|
||||
|
||||
if ($type == $REVERSEFUNC) {
|
||||
if ($this->{'subType'}->isArrayOf()) {
|
||||
$o->write("[reverse(\@{");
|
||||
$this->{'subExpr'}->asPerl($bp, $o);
|
||||
$o->write("})]");
|
||||
} elsif ($this->{'subType'}->equals($S2::Type::STRING)) {
|
||||
$o->write("reverse(");
|
||||
$this->{'subExpr'}->asPerl($bp, $o);
|
||||
$o->write(")");
|
||||
}
|
||||
return;
|
||||
}
|
||||
|
||||
if ($type == $SIZEFUNC) {
|
||||
if ($this->{'subType'}->isArrayOf()) {
|
||||
$o->write("scalar(\@{");
|
||||
$this->{'subExpr'}->asPerl($bp, $o);
|
||||
$o->write("})");
|
||||
} elsif ($this->{'subType'}->isHashOf()) {
|
||||
$o->write("scalar(keys \%{");
|
||||
$this->{'subExpr'}->asPerl($bp, $o);
|
||||
$o->write("})");
|
||||
} elsif ($this->{'subType'}->equals($S2::Type::STRING)) {
|
||||
$o->write("length(");
|
||||
$this->{'subExpr'}->asPerl($bp, $o);
|
||||
$o->write(")");
|
||||
}
|
||||
return;
|
||||
}
|
||||
|
||||
if ($type == $DEFINEDTEST) {
|
||||
$o->write("S2::check_defined(");
|
||||
$this->{'subExpr'}->asPerl($bp, $o);
|
||||
$o->write(")");
|
||||
return;
|
||||
}
|
||||
|
||||
if ($type == $ISNULLFUNC) {
|
||||
$o->write("(ref ");
|
||||
$this->{'subExpr'}->asPerl($bp, $o);
|
||||
$o->write(" ne \"HASH\" || ");
|
||||
$this->{'subExpr'}->asPerl($bp, $o);
|
||||
$o->write("->{'_isnull'})");
|
||||
return;
|
||||
}
|
||||
|
||||
if ($type == $VARREF) {
|
||||
$this->{'var'}->asPerl($bp, $o);
|
||||
return;
|
||||
}
|
||||
|
||||
if ($type == $OBJ_INTERPOLATE) {
|
||||
$o->write("S2::interpolate_object(\$_ctx, '$this->{'funcClass'}', ");
|
||||
$this->{'var'}->asPerl($bp, $o);
|
||||
$o->write(", '$this->{'objint_method'}()')");
|
||||
return;
|
||||
}
|
||||
|
||||
if ($type == $FUNCCALL || $type == $METHCALL) {
|
||||
|
||||
# builtin functions can be optimized.
|
||||
if ($this->{'funcBuiltin'}) {
|
||||
# these built-in functions can be inlined.
|
||||
if ($this->{'funcID'} eq "string(int)") {
|
||||
$this->{'funcArgs'}->asPerl($bp, $o, 0);
|
||||
return;
|
||||
}
|
||||
if ($this->{'funcID'} eq "int(string)") {
|
||||
# cast from string to int by adding zero to it
|
||||
$o->write("int(");
|
||||
$this->{'funcArgs'}->asPerl($bp, $o, 0);
|
||||
$o->write(")");
|
||||
return;
|
||||
}
|
||||
|
||||
# otherwise, call the builtin function (avoid a layer
|
||||
# of indirection), unless it's for a class that has
|
||||
# children (won't know until run-time which class to call)
|
||||
my $pkg = $bp->getBuiltinPackage() || "S2::Builtin";
|
||||
$o->write("${pkg}::");
|
||||
if ($this->{'funcClass'}) {
|
||||
$o->write("$this->{'funcClass'}__");
|
||||
}
|
||||
$o->write($this->{'funcIdent'}->getIdent());
|
||||
} else {
|
||||
if ($type == $METHCALL && $this->{'funcClass'} ne "string") {
|
||||
$o->write("\$_ctx->[VTABLE]->{get_object_func_num(");
|
||||
$o->write($bp->quoteString($this->{'funcClass'}));
|
||||
$o->write(",");
|
||||
$this->{'var'}->asPerl($bp, $o);
|
||||
$o->write(",");
|
||||
$o->write($bp->quoteString($this->{'funcID_noclass'}));
|
||||
$o->write(",");
|
||||
$o->write($bp->getLayerID());
|
||||
$o->write(",");
|
||||
$o->write($this->{'derefLine'}+0);
|
||||
if ($this->{'var'}->isSuper()) {
|
||||
$o->write(",1");
|
||||
}
|
||||
$o->write(")}->");
|
||||
} elsif ($type == $METHCALL) {
|
||||
$o->write("\$_ctx->[VTABLE]->{get_func_num(");
|
||||
$o->write($bp->quoteString($this->{'funcID'}));
|
||||
$o->write(")}->");
|
||||
} else {
|
||||
$o->write("\$_ctx->[VTABLE]->{\$_l2g_func[$this->{'funcNum'}]}->");
|
||||
}
|
||||
}
|
||||
|
||||
$o->write("(\$_ctx, ");
|
||||
|
||||
# this pointer
|
||||
if ($type == $METHCALL) {
|
||||
$this->{'var'}->asPerl($bp, $o);
|
||||
$o->write(", ");
|
||||
}
|
||||
|
||||
$this->{'funcArgs'}->asPerl($bp, $o, 0);
|
||||
|
||||
$o->write(")");
|
||||
return;
|
||||
}
|
||||
|
||||
die "Unknown term type";
|
||||
}
|
||||
|
||||
sub isProperty {
|
||||
my $this = shift;
|
||||
return 0 unless $this->{'type'} == $VARREF;
|
||||
return $this->{'var'}->isProperty();
|
||||
}
|
||||
|
||||
sub isBuiltinProperty {
|
||||
my ($this, $ck) = @_;
|
||||
return 0 unless $this->{'type'} == $VARREF;
|
||||
return 0 unless $this->{'var'}->isProperty();
|
||||
my $name = $this->{'var'}->propName();
|
||||
return $ck->propertyBuiltin($name);
|
||||
}
|
||||
59
wcmtools/s2/S2/NodeText.pm
Executable file
59
wcmtools/s2/S2/NodeText.pm
Executable file
@@ -0,0 +1,59 @@
|
||||
#!/usr/bin/perl
|
||||
#
|
||||
|
||||
package S2::NodeText;
|
||||
|
||||
use strict;
|
||||
use S2::Node;
|
||||
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 parse {
|
||||
my ($class, $toker) = @_;
|
||||
my $nt = new S2::NodeText;
|
||||
|
||||
$nt->skipWhite($toker);
|
||||
my $t = $toker->peek();
|
||||
|
||||
if ($t->isa('S2::TokenIdent')) {
|
||||
my $ti = $toker->getToken();
|
||||
$nt->addToken($ti);
|
||||
$nt->{'text'} = $ti->getIdent();
|
||||
$ti->setType($S2::TokenIdent::STRING);
|
||||
} elsif ($t->isa('S2::TokenIntegerLiteral')) {
|
||||
$nt->addToken($toker->getToken());
|
||||
$nt->{'text'} = $t->getInteger();
|
||||
} elsif ($t->isa('S2::TokenStringLiteral')) {
|
||||
$nt->addToken($toker->getToken());
|
||||
$nt->{'text'} = $t->getString();
|
||||
} else {
|
||||
S2::error($t, "Expecting text (integer, string, or identifer)");
|
||||
}
|
||||
|
||||
return $nt;
|
||||
}
|
||||
|
||||
sub canStart {
|
||||
my ($class, $toker) = @_;
|
||||
my $t = $toker->peek();
|
||||
return $t->isa("S2::TokenIdent") ||
|
||||
$t->isa("S2::TokenIntegerLiteral") ||
|
||||
$t->isa("S2::TokenStringLiteral");
|
||||
}
|
||||
|
||||
sub getText { shift->{'text'}; }
|
||||
|
||||
sub asS2 {
|
||||
my ($this, $o) = @_;
|
||||
$o->write(S2::Backend::quoteString($this->{'text'}));
|
||||
}
|
||||
|
||||
|
||||
56
wcmtools/s2/S2/NodeType.pm
Executable file
56
wcmtools/s2/S2/NodeType.pm
Executable file
@@ -0,0 +1,56 @@
|
||||
#!/usr/bin/perl
|
||||
#
|
||||
|
||||
package S2::NodeType;
|
||||
|
||||
use strict;
|
||||
use S2::Node;
|
||||
use S2::Type;
|
||||
use vars qw($VERSION @ISA);
|
||||
|
||||
$VERSION = '1.0';
|
||||
@ISA = qw(S2::Node);
|
||||
|
||||
sub new {
|
||||
my ($class, $name, $type) = @_;
|
||||
my $node = new S2::Node;
|
||||
$node->{'type'} = undef;
|
||||
bless $node, $class;
|
||||
}
|
||||
|
||||
sub parse {
|
||||
my ($class, $toker) = @_;
|
||||
my $n = new S2::NodeType;
|
||||
|
||||
my $base = $n->getIdent($toker, 1, 0);
|
||||
$base->setType($S2::TokenIdent::TYPE);
|
||||
|
||||
$n->{'type'} = S2::Type->new($base->getIdent());
|
||||
while ($toker->peek() == $S2::TokenPunct::LBRACK ||
|
||||
$toker->peek() == $S2::TokenPunct::LBRACE) {
|
||||
my $t = $toker->peek();
|
||||
$n->eatToken($toker, 0);
|
||||
|
||||
if ($t == $S2::TokenPunct::LBRACK) {
|
||||
$n->requireToken($toker, $S2::TokenPunct::RBRACK, 0);
|
||||
$n->{'type'}->makeArrayOf();
|
||||
} elsif ($t == $S2::TokenPunct::LBRACE) {
|
||||
$n->requireToken($toker, $S2::TokenPunct::RBRACE, 0);
|
||||
$n->{'type'}->makeHashOf();
|
||||
}
|
||||
}
|
||||
|
||||
# If the type was a simple type, we have to remove whitespace,
|
||||
# since we explictly said not to above.
|
||||
$n->skipWhite($toker);
|
||||
return $n;
|
||||
}
|
||||
|
||||
sub getType { shift->{'type'}; }
|
||||
|
||||
sub asS2 {
|
||||
my ($this, $o) = @_;
|
||||
$o->write($this->{'type'}->toString());
|
||||
}
|
||||
|
||||
|
||||
84
wcmtools/s2/S2/NodeUnaryExpr.pm
Executable file
84
wcmtools/s2/S2/NodeUnaryExpr.pm
Executable file
@@ -0,0 +1,84 @@
|
||||
#!/usr/bin/perl
|
||||
#
|
||||
|
||||
package S2::NodeUnaryExpr;
|
||||
|
||||
use strict;
|
||||
use S2::Node;
|
||||
use S2::NodeIncExpr;
|
||||
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) = @_;
|
||||
return $toker->peek() == $S2::TokenPunct::MINUS ||
|
||||
$toker->peek() == $S2::TokenPunct::NOT ||
|
||||
S2::NodeIncExpr->canStart($toker);
|
||||
}
|
||||
|
||||
sub parse {
|
||||
my ($class, $toker) = @_;
|
||||
|
||||
my $n = new S2::NodeUnaryExpr();
|
||||
|
||||
if ($toker->peek() == $S2::TokenPunct::MINUS) {
|
||||
$n->{'bNegative'} = 1;
|
||||
$n->eatToken($toker);
|
||||
} elsif ($toker->peek() == $S2::TokenKeyword::NOT) {
|
||||
$n->{'bNot'} = 1;
|
||||
$n->eatToken($toker);
|
||||
}
|
||||
|
||||
my $expr = parse S2::NodeIncExpr $toker;
|
||||
|
||||
if ($n->{'bNegative'} || $n->{'bNot'}) {
|
||||
$n->{'expr'} = $expr;
|
||||
$n->addNode($n->{'expr'});
|
||||
return $n;
|
||||
}
|
||||
|
||||
return $expr;
|
||||
}
|
||||
|
||||
sub getType {
|
||||
my ($this, $ck, $wanted) = @_;
|
||||
|
||||
my $t = $this->{'expr'}->getType($ck);
|
||||
|
||||
if ($this->{'bNegative'}) {
|
||||
unless ($t->equals($S2::Type::INT)) {
|
||||
S2::error($this->{'expr'}, "Can't use unary minus on non-integer.");
|
||||
}
|
||||
return $S2::Type::INT;
|
||||
}
|
||||
if ($this->{'bNot'}) {
|
||||
unless ($t->equals($S2::Type::BOOL)) {
|
||||
S2::error($this->{'expr'}, "Can't use negation operator on boolean-integer.");
|
||||
}
|
||||
return $S2::Type::BOOL;
|
||||
}
|
||||
return undef
|
||||
}
|
||||
|
||||
sub asS2 {
|
||||
my ($this, $o) = @_;
|
||||
if ($this->{'bNot'}) { $o->write("not "); }
|
||||
if ($this->{'bNegative'}) { $o->write("-"); }
|
||||
$this->{'expr'}->asS2($o);
|
||||
}
|
||||
|
||||
sub asPerl {
|
||||
my ($this, $bp, $o) = @_;
|
||||
if ($this->{'bNot'}) { $o->write("! "); }
|
||||
if ($this->{'bNegative'}) { $o->write("-"); }
|
||||
$this->{'expr'}->asPerl($bp, $o);
|
||||
}
|
||||
|
||||
46
wcmtools/s2/S2/NodeUnnecessary.pm
Executable file
46
wcmtools/s2/S2/NodeUnnecessary.pm
Executable file
@@ -0,0 +1,46 @@
|
||||
#!/usr/bin/perl
|
||||
#
|
||||
|
||||
package S2::NodeUnnecessary;
|
||||
|
||||
use strict;
|
||||
use S2::Node;
|
||||
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 parse {
|
||||
my ($class, $toker) = @_;
|
||||
my $n = new S2::NodeUnnecessary;
|
||||
$n->skipWhite($toker);
|
||||
return $n;
|
||||
}
|
||||
|
||||
sub canStart {
|
||||
my ($class, $toker) = @_;
|
||||
return ! $toker->peek()->isNecessary();
|
||||
}
|
||||
|
||||
sub asS2 {
|
||||
my ($this, $o) = @_;
|
||||
# do nothing when making the canonical S2 (the
|
||||
# nodes write their whitespace)
|
||||
}
|
||||
|
||||
sub asPerl {
|
||||
my ($this, $bp, $o) = @_;
|
||||
# do nothing when making the perl output
|
||||
}
|
||||
|
||||
sub check {
|
||||
my ($this, $l, $ck) = @_;
|
||||
# nothing can be wrong with whitespace and comments
|
||||
}
|
||||
|
||||
56
wcmtools/s2/S2/NodeVarDecl.pm
Executable file
56
wcmtools/s2/S2/NodeVarDecl.pm
Executable file
@@ -0,0 +1,56 @@
|
||||
#!/usr/bin/perl
|
||||
#
|
||||
|
||||
package S2::NodeVarDecl;
|
||||
|
||||
use strict;
|
||||
use S2::Node;
|
||||
use S2::NodeNamedType;
|
||||
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 ($this, $toker) = @_;
|
||||
return $toker->peek() == $S2::TokenKeyword::VAR;
|
||||
}
|
||||
|
||||
sub parse {
|
||||
my ($class, $toker) = @_;
|
||||
my $n = new S2::NodeVarDecl;
|
||||
|
||||
$n->setStart($n->requireToken($toker, $S2::TokenKeyword::VAR));
|
||||
$n->addNode($n->{'nt'} = S2::NodeNamedType->parse($toker));
|
||||
return $n;
|
||||
}
|
||||
|
||||
sub getType { shift->{'nt'}->getType; }
|
||||
sub getName { shift->{'nt'}->getName; }
|
||||
|
||||
sub populateScope {
|
||||
my ($this, $nb) = @_; # NodeStmtBlock
|
||||
my $name = $this->{'nt'}->getName;
|
||||
my $et = $nb->getLocalVar($name);
|
||||
S2::error("Can't mask local variable '$name'") if $et;
|
||||
$nb->addLocalVar($name, $this->{'nt'}->getType());
|
||||
}
|
||||
|
||||
sub asS2 {
|
||||
my ($this, $o) = @_;
|
||||
$o->write("var ");
|
||||
$this->{'nt'}->asS2($o);
|
||||
}
|
||||
|
||||
sub asPerl {
|
||||
my ($this, $bp, $o) = @_;
|
||||
$o->write("my \$" . $this->{'nt'}->getName());
|
||||
}
|
||||
|
||||
|
||||
94
wcmtools/s2/S2/NodeVarDeclStmt.pm
Executable file
94
wcmtools/s2/S2/NodeVarDeclStmt.pm
Executable file
@@ -0,0 +1,94 @@
|
||||
#!/usr/bin/perl
|
||||
#
|
||||
|
||||
package S2::NodeVarDeclStmt;
|
||||
|
||||
use strict;
|
||||
use S2::Node;
|
||||
use S2::NodeVarDecl;
|
||||
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 ($this, $toker) = @_;
|
||||
return S2::NodeVarDecl->canStart($toker);
|
||||
}
|
||||
|
||||
sub parse {
|
||||
my ($class, $toker) = @_;
|
||||
my $n = new S2::NodeVarDeclStmt;
|
||||
|
||||
$n->addNode($n->{'nvd'} = S2::NodeVarDecl->parse($toker));
|
||||
if ($toker->peek() == $S2::TokenPunct::ASSIGN) {
|
||||
$n->eatToken($toker);
|
||||
$n->addNode($n->{'expr'} = S2::NodeExpr->parse($toker));
|
||||
}
|
||||
$n->requireToken($toker, $S2::TokenPunct::SCOLON);
|
||||
return $n;
|
||||
}
|
||||
|
||||
sub check {
|
||||
my ($this, $l, $ck) = @_;
|
||||
|
||||
$this->{'nvd'}->populateScope($ck->getLocalScope());
|
||||
|
||||
# check that the variable type is a known class
|
||||
my $t = $this->{'nvd'}->getType();
|
||||
my $bt = $t->baseType();
|
||||
|
||||
S2::error($this, "Unknown type or class '$bt'")
|
||||
unless S2::Type::isPrimitive($bt) || $ck->getClass($bt);
|
||||
|
||||
my $vname = $this->{'nvd'}->getName();
|
||||
|
||||
if ($this->{'expr'}) {
|
||||
my $et = $this->{'expr'}->getType($ck, $t);
|
||||
S2::error($this, "Can't initialize variable '$vname' " .
|
||||
"of type " . $t->toString . " with expression of type " .
|
||||
$et->toString())
|
||||
unless $ck->typeIsa($et, $t);
|
||||
}
|
||||
|
||||
S2::error($this, "Reserved variable name") if $vname eq "_ctx";
|
||||
}
|
||||
|
||||
sub asS2 {
|
||||
my ($this, $o) = @_;
|
||||
$o->tabwrite("");
|
||||
$this->{'nvd'}->asS2($o);
|
||||
if ($this->{'expr'}) {
|
||||
$o->write(" = ");
|
||||
$this->{'expr'}->asS2($o);
|
||||
}
|
||||
$o->writeln(";");
|
||||
}
|
||||
|
||||
sub asPerl {
|
||||
my ($this, $bp, $o) = @_;
|
||||
$o->tabwrite("");
|
||||
$this->{'nvd'}->asPerl($bp, $o);
|
||||
if ($this->{'expr'}) {
|
||||
$o->write(" = ");
|
||||
$this->{'expr'}->asPerl($bp, $o);
|
||||
} else {
|
||||
my $t = $this->{'nvd'}->getType();
|
||||
if ($t->equals($S2::Type::STRING)) {
|
||||
$o->write(" = \"\"");
|
||||
} elsif ($t->equals($S2::Type::BOOL) ||
|
||||
$t->equals($S2::Type::INT)) {
|
||||
$o->write(" = 0");
|
||||
}
|
||||
}
|
||||
$o->writeln(";");
|
||||
}
|
||||
|
||||
|
||||
301
wcmtools/s2/S2/NodeVarRef.pm
Executable file
301
wcmtools/s2/S2/NodeVarRef.pm
Executable file
@@ -0,0 +1,301 @@
|
||||
#!/usr/bin/perl
|
||||
#
|
||||
|
||||
package S2::NodeVarRef;
|
||||
|
||||
use strict;
|
||||
use S2::Node;
|
||||
use S2::NodeExpr;
|
||||
use S2::Type;
|
||||
use vars qw($VERSION @ISA $LOCAL $OBJECT $PROPERTY);
|
||||
|
||||
$LOCAL = 1;
|
||||
$OBJECT = 2;
|
||||
$PROPERTY = 3;
|
||||
$VERSION = '1.0';
|
||||
@ISA = qw(S2::Node);
|
||||
|
||||
sub new {
|
||||
my ($class) = @_;
|
||||
my $n = new S2::Node;
|
||||
bless $n, $class;
|
||||
}
|
||||
|
||||
sub canStart {
|
||||
my ($class, $toker) = @_;
|
||||
return $toker->peek() == $S2::TokenPunct::DOLLAR;
|
||||
}
|
||||
|
||||
sub parse {
|
||||
my ($class, $toker) = @_;
|
||||
|
||||
my $n = new S2::NodeVarRef();
|
||||
$n->{'levels'} = [];
|
||||
$n->{'type'} = $LOCAL;
|
||||
|
||||
# voo-doo so tokenizer won't continue parsing a string
|
||||
# if we're in a string and trying to parse interesting things
|
||||
# involved in a VarRef:
|
||||
|
||||
$n->setStart($n->requireToken($toker, $S2::TokenPunct::DOLLAR, 0));
|
||||
|
||||
$toker->pushInString(0); # pretend we're not, even if we are.
|
||||
|
||||
if ($toker->peekChar() eq "{") {
|
||||
$n->requireToken($toker, $S2::TokenPunct::LBRACE, 0);
|
||||
$n->{'braced'} = 1;
|
||||
} else {
|
||||
$n->{'braced'} = 0;
|
||||
}
|
||||
|
||||
if ($toker->peekChar() eq ".") {
|
||||
$n->requireToken($toker, $S2::TokenPunct::DOT, 0);
|
||||
$n->{'type'} = $OBJECT;
|
||||
} elsif ($toker->peekChar() eq "*") {
|
||||
$n->requireToken($toker, $S2::TokenPunct::MULT, 0);
|
||||
$n->{'type'} = $PROPERTY;
|
||||
}
|
||||
|
||||
my $requireDot = 0;
|
||||
|
||||
# only peeking at characters, not tokens, otherwise
|
||||
# we could force tokens could be created in the wrong
|
||||
# context.
|
||||
while ($toker->peekChar() =~ /[a-zA-Z\_\.]/)
|
||||
{
|
||||
if ($requireDot) {
|
||||
$n->requireToken($toker, $S2::TokenPunct::DOT, 0);
|
||||
} else {
|
||||
$requireDot = 1;
|
||||
}
|
||||
|
||||
my $ident = $n->getIdent($toker, 1, 0);
|
||||
|
||||
my $vl = {
|
||||
'var' => $ident->getIdent(),
|
||||
'derefs' => [],
|
||||
};
|
||||
|
||||
# more preventing of token peeking:
|
||||
while ($toker->peekChar() eq '[' ||
|
||||
$toker->peekChar() eq '{')
|
||||
{
|
||||
my $dr = {}; # Deref, 'type', 'expr'
|
||||
my $t = $n->eatToken($toker, 0);
|
||||
|
||||
if ($t == $S2::TokenPunct::LBRACK) {
|
||||
$dr->{'type'} = '[';
|
||||
$n->addNode($dr->{'expr'} = S2::NodeExpr->parse($toker));
|
||||
$n->requireToken($toker, $S2::TokenPunct::RBRACK, 0);
|
||||
} elsif ($t == $S2::TokenPunct::LBRACE) {
|
||||
$dr->{'type'} = '{';
|
||||
$n->addNode($dr->{'expr'} = S2::NodeExpr->parse($toker));
|
||||
$n->requireToken($toker, $S2::TokenPunct::RBRACE, 0);
|
||||
} else {
|
||||
die;
|
||||
}
|
||||
|
||||
push @{$vl->{'derefs'}}, $dr;
|
||||
}
|
||||
|
||||
push @{$n->{'levels'}}, $vl;
|
||||
} # end while
|
||||
|
||||
# did we parse just $ ?
|
||||
S2::error($n, "Malformed variable reference") unless
|
||||
@{$n->{'levels'}};
|
||||
|
||||
if ($n->{'braced'}) {
|
||||
# false argument necessary to prevent peeking at token
|
||||
# stream while it's in the interpolated variable parsing state,
|
||||
# else the string text following the variable would be
|
||||
# treated as if it were outside the string.
|
||||
$n->requireToken($toker, $S2::TokenPunct::RBRACE, 0);
|
||||
}
|
||||
|
||||
$toker->popInString(); # back to being in a string if we were
|
||||
|
||||
# now we must skip white space that requireToken above would've
|
||||
# done had we not told it not to, but not if the main tokenizer
|
||||
# is in a quoted string
|
||||
if ($toker->{'inString'} == 0) {
|
||||
$n->skipWhite($toker);
|
||||
}
|
||||
return $n;
|
||||
}
|
||||
|
||||
# if told by NodeTerm.java, add another varlevel to point to
|
||||
# this object's $.as_string
|
||||
sub useAsString {
|
||||
my $this = shift;
|
||||
push @{$this->{'levels'}}, {
|
||||
'var' => 'as_string',
|
||||
'derefs' => [],
|
||||
};
|
||||
}
|
||||
|
||||
sub isHashElement {
|
||||
my $this = 0;
|
||||
|
||||
return 0 unless @{$this->{'levels'}};
|
||||
my $l = $this->{'levels'}->[-1];
|
||||
return 0 unless @$l;
|
||||
my $d = $l->[-1];
|
||||
return $d->{'type'} eq "{";
|
||||
}
|
||||
|
||||
sub getType {
|
||||
my ($this, $ck, $wanted) = @_;
|
||||
|
||||
if (defined $wanted) {
|
||||
my $t = getType($this, $ck);
|
||||
return $t unless
|
||||
$wanted->equals($S2::Type::STRING);
|
||||
my $type = $t->toString();
|
||||
if ($ck->classHasAsString($type)) {
|
||||
$this->{'useAsString'} = 1;
|
||||
return $S2::Type::STRING;
|
||||
}
|
||||
}
|
||||
|
||||
# must have at least reference something.
|
||||
return undef unless @{$this->{'levels'}};
|
||||
|
||||
my @levs = @{$this->{'levels'}};
|
||||
my $lev = shift @levs; # VarLevel
|
||||
my $vart = undef; # Type
|
||||
|
||||
# properties
|
||||
if ($this->{'type'} == $PROPERTY) {
|
||||
$vart = $ck->propertyType($lev->{'var'});
|
||||
S2::error($this, "Unknown property") unless $vart;
|
||||
$vart = $vart->clone();
|
||||
}
|
||||
|
||||
# local variables.
|
||||
if ($this->{'type'} == $LOCAL) {
|
||||
$vart = $ck->localType($lev->{'var'});
|
||||
S2::error($this, "Unknown local variable \$$lev->{'var'}") unless $vart;
|
||||
}
|
||||
|
||||
# properties & locals
|
||||
if ($this->{'type'} == $PROPERTY ||
|
||||
$this->{'type'} == $LOCAL)
|
||||
{
|
||||
$vart = $vart->clone();
|
||||
|
||||
# dereference [] and {} stuff
|
||||
$this->doDerefs($ck, $lev->{'derefs'}, $vart);
|
||||
|
||||
# if no more levels, return now. otherwise deferencing
|
||||
# happens below.
|
||||
return $vart unless @levs;
|
||||
$lev = shift @levs;
|
||||
}
|
||||
|
||||
# initialize the name of the current object
|
||||
if ($this->{'type'} == $OBJECT) {
|
||||
my $curclass = $ck->getCurrentFunctionClass();
|
||||
S2::error($this, "Can't reference member variable in non-class function") unless $curclass;
|
||||
$vart = new S2::Type($curclass);
|
||||
}
|
||||
|
||||
while ($lev) {
|
||||
my $nc = $ck->getClass($vart->toString());
|
||||
S2::error($this, "Can't use members of an undefined class") unless $nc;
|
||||
$vart = $nc->getMemberType($lev->{'var'});
|
||||
S2::error($this, "Can't find member '$lev->{'var'}' in " . $nc->getName()) unless $vart;
|
||||
$vart = $vart->clone();
|
||||
|
||||
# dereference [] and {} stuff
|
||||
$this->doDerefs($ck, $lev->{'derefs'}, $vart);
|
||||
$lev = shift @levs;
|
||||
}
|
||||
return $vart;
|
||||
}
|
||||
|
||||
# private
|
||||
sub doDerefs {
|
||||
my ($this, $ck, $derefs, $vart) = @_;
|
||||
foreach my $d (@{$derefs}) {
|
||||
my $et = $d->{'expr'}->getType($ck);
|
||||
if ($d->{'type'} eq "{") {
|
||||
S2::error($this, "Can't dereference a non-hash as a hash")
|
||||
unless $vart->isHashOf();
|
||||
S2::error($this, "Must dereference a hash with a string or int")
|
||||
unless ($et->equals($S2::Type::STRING) ||
|
||||
$et->equals($S2::Type::INT));
|
||||
$vart->removeMod(); # not a hash anymore
|
||||
} elsif ($d->{'type'} eq "[") {
|
||||
S2::error($this, "Can't dereference a non-array as an array ")
|
||||
unless $vart->isArrayOf();
|
||||
S2::error($this, "Must dereference an array with an int")
|
||||
unless $et->equals($S2::Type::INT);
|
||||
$vart->removeMod(); # not an array anymore
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
# is this variable $super ?
|
||||
sub isSuper {
|
||||
my ($this) = @_;
|
||||
return 0 if $this->{'type'} != $LOCAL;
|
||||
return 0 if @{$this->{'levels'}} > 1;
|
||||
my $v = $this->{'levels'}->[0];
|
||||
return ($v->{'var'} eq "super" &&
|
||||
@{$v->{'derefs'}} == 0);
|
||||
}
|
||||
|
||||
sub asS2 {
|
||||
my ($this, $o) = @_;
|
||||
die "Unported";
|
||||
}
|
||||
|
||||
sub asPerl {
|
||||
my ($this, $bp, $o) = @_;
|
||||
my $first = 1;
|
||||
|
||||
if ($this->{'type'} == $LOCAL) {
|
||||
$o->write("\$");
|
||||
} elsif ($this->{'type'} == $OBJECT) {
|
||||
$o->write("\$this");
|
||||
} elsif ($this->{'type'} == $PROPERTY) {
|
||||
$o->write("\$_ctx->[PROPS]");
|
||||
$first = 0;
|
||||
}
|
||||
|
||||
foreach my $lev (@{$this->{'levels'}}) {
|
||||
if (! $first || $this->{'type'} == $OBJECT) {
|
||||
$o->write("->{'$lev->{'var'}'}");
|
||||
} else {
|
||||
my $v = $lev->{'var'};
|
||||
if ($first && $this->{'type'} == $LOCAL &&
|
||||
$v eq "super") {
|
||||
$v = "this";
|
||||
}
|
||||
$o->write($v);
|
||||
$first = 0;
|
||||
}
|
||||
|
||||
foreach my $d (@{$lev->{'derefs'}}) {
|
||||
$o->write("->$d->{'type'}"); # [ or {
|
||||
$d->{'expr'}->asPerl($bp, $o);
|
||||
$o->write($d->{'type'} eq "[" ? "]" : "}");
|
||||
}
|
||||
} # end levels
|
||||
|
||||
if ($this->{'useAsString'}) {
|
||||
$o->write("->{'as_string'}");
|
||||
}
|
||||
}
|
||||
|
||||
sub isProperty {
|
||||
my $this = shift;
|
||||
return $this->{'type'} == $PROPERTY;
|
||||
}
|
||||
|
||||
sub propName {
|
||||
my $this = shift;
|
||||
return "" unless $this->{'type'} == $PROPERTY;
|
||||
return $this->{'levels'}->[0]->{'var'};
|
||||
}
|
||||
29
wcmtools/s2/S2/OutputConsole.pm
Executable file
29
wcmtools/s2/S2/OutputConsole.pm
Executable file
@@ -0,0 +1,29 @@
|
||||
#!/usr/bin/perl
|
||||
#
|
||||
|
||||
package S2::OutputConsole;
|
||||
|
||||
use strict;
|
||||
|
||||
sub new {
|
||||
my $class = shift;
|
||||
my $this = {};
|
||||
bless $this, $class;
|
||||
}
|
||||
|
||||
sub write {
|
||||
print $_[1];
|
||||
}
|
||||
|
||||
sub writeln {
|
||||
print $_[1], "\n";
|
||||
}
|
||||
|
||||
sub newline {
|
||||
print "\n";
|
||||
}
|
||||
|
||||
sub flush { }
|
||||
|
||||
|
||||
1;
|
||||
29
wcmtools/s2/S2/OutputScalar.pm
Executable file
29
wcmtools/s2/S2/OutputScalar.pm
Executable file
@@ -0,0 +1,29 @@
|
||||
#!/usr/bin/perl
|
||||
#
|
||||
|
||||
package S2::OutputScalar;
|
||||
|
||||
use strict;
|
||||
|
||||
sub new {
|
||||
my ($class, $scalar) = @_;
|
||||
my $ref = [ $scalar ];
|
||||
bless $ref, $class;
|
||||
}
|
||||
|
||||
sub write {
|
||||
${$_[0]->[0]} .= $_[1];
|
||||
}
|
||||
|
||||
sub writeln {
|
||||
${$_[0]->[0]} .= $_[1] . "\n";
|
||||
}
|
||||
|
||||
sub newline {
|
||||
${$_[0]->[0]} .= "\n";
|
||||
}
|
||||
|
||||
sub flush { }
|
||||
|
||||
|
||||
1;
|
||||
36
wcmtools/s2/S2/Token.pm
Executable file
36
wcmtools/s2/S2/Token.pm
Executable file
@@ -0,0 +1,36 @@
|
||||
#!/usr/bin/perl
|
||||
#
|
||||
|
||||
package S2::Token;
|
||||
|
||||
use strict;
|
||||
|
||||
sub getFilePos {
|
||||
return $_[0]->{'pos'};
|
||||
}
|
||||
|
||||
sub isNecessary { 1; }
|
||||
|
||||
sub toString {
|
||||
die "Abstract! " . Data::Dumper::Dumper(@_);
|
||||
}
|
||||
|
||||
sub asHTML {
|
||||
my $this = shift;
|
||||
die "No asHTML defined for " . ref $this;
|
||||
}
|
||||
|
||||
sub asS2 {
|
||||
my ($this, $o) = @_; # Indenter o
|
||||
$o->write("##Token::asS2##");
|
||||
}
|
||||
|
||||
sub asPerl {
|
||||
my ($this, $bp, $o) = @_; # BackendPerl bp, Indenter o
|
||||
$o->write("##Token::asPerl##");
|
||||
}
|
||||
|
||||
|
||||
|
||||
|
||||
1;
|
||||
40
wcmtools/s2/S2/TokenComment.pm
Executable file
40
wcmtools/s2/S2/TokenComment.pm
Executable file
@@ -0,0 +1,40 @@
|
||||
#!/usr/bin/perl
|
||||
#
|
||||
|
||||
package S2::TokenComment;
|
||||
|
||||
use strict;
|
||||
use S2::Token;
|
||||
use vars qw($VERSION @ISA);
|
||||
|
||||
$VERSION = '1.0';
|
||||
@ISA = qw(S2::Token);
|
||||
|
||||
sub new
|
||||
{
|
||||
my ($class, $com) = @_;
|
||||
bless {
|
||||
'chars' => $com,
|
||||
}, $class;
|
||||
}
|
||||
|
||||
sub getComment
|
||||
{
|
||||
shift->{'chars'};
|
||||
}
|
||||
|
||||
sub toString
|
||||
{
|
||||
"[TokenComment]";
|
||||
}
|
||||
|
||||
sub isNecessary { return 0; }
|
||||
|
||||
sub asHTML
|
||||
{
|
||||
my ($this, $o) = @_;
|
||||
$o->write("<span class=\"c\">" . S2::BackendHTML::quoteHTML($this->{'chars'}) . "</span>");
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
57
wcmtools/s2/S2/TokenIdent.pm
Executable file
57
wcmtools/s2/S2/TokenIdent.pm
Executable file
@@ -0,0 +1,57 @@
|
||||
#!/usr/bin/perl
|
||||
#
|
||||
|
||||
package S2::TokenIdent;
|
||||
|
||||
use strict;
|
||||
use S2::Token;
|
||||
use S2::TokenKeyword;
|
||||
use vars qw($VERSION @ISA $DEFAULT $TYPE $STRING);
|
||||
|
||||
$VERSION = '1.0';
|
||||
@ISA = qw(S2::Token);
|
||||
|
||||
# numeric values for $this->{'type'}
|
||||
$DEFAULT = 0;
|
||||
$TYPE = 1;
|
||||
$STRING = 2;
|
||||
|
||||
sub new
|
||||
{
|
||||
my ($class, $ident) = @_;
|
||||
my $kwtok = S2::TokenKeyword->tokenFromString($ident);
|
||||
return $kwtok if $kwtok;
|
||||
bless {
|
||||
'chars' => $ident,
|
||||
}, $class;
|
||||
}
|
||||
|
||||
sub getIdent {
|
||||
shift->{'chars'};
|
||||
}
|
||||
|
||||
sub toString {
|
||||
my $this = shift;
|
||||
"[TokenIdent] = $this->{'chars'}";
|
||||
}
|
||||
|
||||
sub setType {
|
||||
my ($this, $type) = @_;
|
||||
$this->{'type'} = $type;
|
||||
}
|
||||
|
||||
sub asHTML {
|
||||
my ($this, $o) = @_;
|
||||
my $ident = $this->{'chars'};
|
||||
# FIXME: TODO: Don't hardcode internal types, intelligently recognise
|
||||
# places where types and class references occur and
|
||||
# make them class="t"
|
||||
if ($ident =~ /^(int|string|void|bool)$/) {
|
||||
$o->write("<span class=\"t\">$ident</span>");
|
||||
} else {
|
||||
$o->write("<span class=\"i\">$ident</span>");
|
||||
}
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
53
wcmtools/s2/S2/TokenIntegerLiteral.pm
Executable file
53
wcmtools/s2/S2/TokenIntegerLiteral.pm
Executable file
@@ -0,0 +1,53 @@
|
||||
#!/usr/bin/perl
|
||||
#
|
||||
|
||||
package S2::TokenIntegerLiteral;
|
||||
|
||||
use strict;
|
||||
use S2::Token;
|
||||
use vars qw($VERSION @ISA);
|
||||
|
||||
$VERSION = '1.0';
|
||||
@ISA = qw(S2::Token);
|
||||
|
||||
sub new
|
||||
{
|
||||
my ($class, $val) = @_;
|
||||
bless {
|
||||
'chars' => $val+0,
|
||||
};
|
||||
}
|
||||
|
||||
sub getInteger
|
||||
{
|
||||
my $this = shift;
|
||||
$this->{'chars'};
|
||||
}
|
||||
|
||||
sub asS2
|
||||
{
|
||||
my ($this, $o) = @_;
|
||||
$o->write($this->{'chars'});
|
||||
}
|
||||
|
||||
sub asHTML
|
||||
{
|
||||
my ($this, $o) = @_;
|
||||
$o->write("<span class=\"n\">$this->{'chars'}</span>");
|
||||
}
|
||||
|
||||
sub asPerl
|
||||
{
|
||||
my ($this, $bp, $o) = @_;
|
||||
$o->write($this->{'chars'});
|
||||
}
|
||||
|
||||
sub toString
|
||||
{
|
||||
my $this = shift;
|
||||
"[TokenIntegerLiteral] = $this->{'chars'}";
|
||||
}
|
||||
|
||||
|
||||
1;
|
||||
|
||||
50
wcmtools/s2/S2/TokenKeyword.pm
Executable file
50
wcmtools/s2/S2/TokenKeyword.pm
Executable file
@@ -0,0 +1,50 @@
|
||||
#!/usr/bin/perl
|
||||
#
|
||||
|
||||
package S2::TokenKeyword;
|
||||
|
||||
use strict;
|
||||
use S2::Token;
|
||||
use vars qw($VERSION @ISA %keywords);
|
||||
|
||||
$VERSION = '1.0';
|
||||
@ISA = qw(S2::TokenIdent);
|
||||
|
||||
%keywords = ();
|
||||
foreach my $kw (qw(class else elseif function if builtin
|
||||
property propgroup set static var while foreach print
|
||||
println not and or xor layerinfo extends
|
||||
return delete defined new true false reverse
|
||||
size isnull null readonly)) {
|
||||
my $uc = uc($kw);
|
||||
eval "use vars qw(\$$uc); \$keywords{\"$kw\"} = \$$uc = S2::TokenKeyword->new(\"$kw\");";
|
||||
}
|
||||
|
||||
sub new
|
||||
{
|
||||
my ($class, $ident) = @_;
|
||||
bless {
|
||||
'chars' => $ident,
|
||||
}, $class;
|
||||
}
|
||||
|
||||
sub tokenFromString
|
||||
{
|
||||
my ($class, $ident) = @_;
|
||||
return $keywords{$ident};
|
||||
}
|
||||
|
||||
sub toString
|
||||
{
|
||||
my $this = shift;
|
||||
"[TokenKeyword] = $this->{'chars'}";
|
||||
}
|
||||
|
||||
sub asHTML
|
||||
{
|
||||
my ($this, $o) = @_;
|
||||
$o->write("<span class=\"k\">$this->{'chars'}</span>");
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
90
wcmtools/s2/S2/TokenPunct.pm
Executable file
90
wcmtools/s2/S2/TokenPunct.pm
Executable file
@@ -0,0 +1,90 @@
|
||||
#!/usr/bin/perl
|
||||
#
|
||||
|
||||
package S2::TokenPunct;
|
||||
|
||||
use strict;
|
||||
use S2::Token;
|
||||
use vars qw($VERSION @ISA
|
||||
$LT $LTE $GTE $GT $EQ $NE $ASSIGN $INCR $PLUS
|
||||
$DEC $MINUS $DEREF $SCOLON $COLON $DCOLON $LOGAND
|
||||
$BITAND $LOGOR $BITOR $MULT $DIV $MOD $NOT $DOT
|
||||
$DOTDOT $LBRACE $RBRACE $LBRACK $RBRACK $LPAREN
|
||||
$RPAREN $COMMA $QMARK $DOLLAR $HASSOC
|
||||
%finals
|
||||
);
|
||||
|
||||
$VERSION = '1.0';
|
||||
@ISA = qw(S2::Token);
|
||||
|
||||
$LTE = new S2::TokenPunct '<=', 1;
|
||||
$LT = new S2::TokenPunct '<', 1;
|
||||
$GTE = new S2::TokenPunct '>=', 1;
|
||||
$GT = new S2::TokenPunct '>', 1;
|
||||
$EQ = new S2::TokenPunct "==", 1;
|
||||
$HASSOC = new S2::TokenPunct "=>", 1;
|
||||
$ASSIGN = new S2::TokenPunct "=", 1;
|
||||
$NE = new S2::TokenPunct "!=", 1;
|
||||
$INCR = new S2::TokenPunct "++", 1;
|
||||
$PLUS = new S2::TokenPunct "+", 1;
|
||||
$DEC = new S2::TokenPunct "--", 1;
|
||||
$MINUS = new S2::TokenPunct "-", 1;
|
||||
$DEREF = new S2::TokenPunct "->", 1;
|
||||
$SCOLON = new S2::TokenPunct ";", 1;
|
||||
$DCOLON = new S2::TokenPunct "::", 1;
|
||||
$COLON = new S2::TokenPunct ":", 1;
|
||||
$LOGAND = new S2::TokenPunct "&&", 1;
|
||||
$BITAND = new S2::TokenPunct "&", 1;
|
||||
$LOGOR = new S2::TokenPunct "||", 1;
|
||||
$BITOR = new S2::TokenPunct "|", 1;
|
||||
$MULT = new S2::TokenPunct "*", 1;
|
||||
$DIV = new S2::TokenPunct "/", 1;
|
||||
$MOD = new S2::TokenPunct "%", 1;
|
||||
$NOT = new S2::TokenPunct "!", 1;
|
||||
$DOT = new S2::TokenPunct ".", 1;
|
||||
$DOTDOT = new S2::TokenPunct "..", 1;
|
||||
$LBRACE = new S2::TokenPunct "{", 1;
|
||||
$RBRACE = new S2::TokenPunct "}", 1;
|
||||
$LBRACK = new S2::TokenPunct "[", 1;
|
||||
$RBRACK = new S2::TokenPunct "]", 1;
|
||||
$LPAREN = new S2::TokenPunct "(", 1;
|
||||
$RPAREN = new S2::TokenPunct ")", 1;
|
||||
$COMMA = new S2::TokenPunct ",", 1;
|
||||
$QMARK = new S2::TokenPunct "?", 1;
|
||||
$DOLLAR = new S2::TokenPunct '$', 1;
|
||||
|
||||
sub new
|
||||
{
|
||||
my ($class, $punct, $final) = @_;
|
||||
return $finals{$punct} if defined $finals{$punct};
|
||||
my $this = { 'chars' => $punct };
|
||||
$finals{$punct} = $this if $final;
|
||||
bless $this, $class;
|
||||
}
|
||||
|
||||
sub getPunct { shift->{'chars'}; }
|
||||
|
||||
sub asHTML
|
||||
{
|
||||
my ($this, $o) = @_;
|
||||
if ($this->{'chars'} =~ m![\[\]\(\)\{\}]!) {
|
||||
$o->write("<span class=\"b\">$this->{'chars'}</span>");
|
||||
} else {
|
||||
$o->write("<span class=\"p\">" . S2::BackendHTML::quoteHTML($this->{'chars'}) . "</span>");
|
||||
}
|
||||
}
|
||||
|
||||
sub asS2
|
||||
{
|
||||
my ($this, $o) = @_;
|
||||
$o->write($this->{'chars'});
|
||||
}
|
||||
|
||||
sub toString
|
||||
{
|
||||
my $this = shift;
|
||||
"[TokenPunct] = $this->{'chars'}";
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
201
wcmtools/s2/S2/TokenStringLiteral.pm
Executable file
201
wcmtools/s2/S2/TokenStringLiteral.pm
Executable file
@@ -0,0 +1,201 @@
|
||||
#!/usr/bin/perl
|
||||
#
|
||||
|
||||
package S2::TokenStringLiteral;
|
||||
|
||||
use strict;
|
||||
use S2::Token;
|
||||
use vars qw($VERSION @ISA);
|
||||
|
||||
$VERSION = '1.0';
|
||||
@ISA = qw(S2::Token);
|
||||
|
||||
# int quotesLeft;
|
||||
# int quotesRight;
|
||||
# String text;
|
||||
# String source;
|
||||
|
||||
sub new
|
||||
{
|
||||
my $class = shift;
|
||||
my ($text, $source, $ql, $qr);
|
||||
if (@_ == 1) {
|
||||
$text = shift;
|
||||
($ql, $qr) = (1, 1);
|
||||
$source = $text;
|
||||
} elsif (@_ == 3) {
|
||||
($text, $ql, $qr) = @_;
|
||||
$source = $text;
|
||||
} elsif (@_ == 4) {
|
||||
($text, $source, $ql, $qr) = @_;
|
||||
unless (defined $text) {
|
||||
$text = $source;
|
||||
$text =~ s/\\n/\n/g;
|
||||
$text =~ s/\\\"/\"/g;
|
||||
$text =~ s/\\\$/\$/g;
|
||||
$text =~ s/\\\\/\\/g;
|
||||
}
|
||||
} else {
|
||||
die;
|
||||
}
|
||||
|
||||
bless {
|
||||
'text' => $text,
|
||||
'chars' => $source,
|
||||
'quotesLeft' => $ql,
|
||||
'quotesRight' => $qr,
|
||||
}, $class;
|
||||
}
|
||||
|
||||
sub getQuotesLeft { shift->{'quotesLeft'}; }
|
||||
sub getQuotesRight { shift->{'quotesRight'}; }
|
||||
sub setQuotesLeft { my $this = shift; $this->{'quotesLeft'} = shift; }
|
||||
sub setQuotesRight { my $this = shift; $this->{'quotesRight'} = shift; }
|
||||
|
||||
sub clone {
|
||||
my $this = shift;
|
||||
return S2::TokenStringLiteral->new($this->{'text'},
|
||||
$this->{'chars'},
|
||||
$this->{'quotesLeft'},
|
||||
$this->{'quotesRight'});
|
||||
}
|
||||
|
||||
sub getString
|
||||
{
|
||||
shift->{'text'};
|
||||
}
|
||||
|
||||
sub toString
|
||||
{
|
||||
my $this = shift;
|
||||
my $buf = "[TokenStringLiteral] = ";
|
||||
if ($this->{'quotesLeft'} == 0) { $buf .= "("; }
|
||||
elsif ($this->{'quotesLeft'} == 1) { $buf .= "<"; }
|
||||
elsif ($this->{'quotesLeft'} == 3) { $buf .= "<<"; }
|
||||
else { die; }
|
||||
$buf .= $this->{'text'};
|
||||
if ($this->{'quotesRight'} == 0) { $buf .= ")"; }
|
||||
elsif ($this->{'quotesRight'} == 1) { $buf .= ">"; }
|
||||
elsif ($this->{'quotesRight'} == 3) { $buf .= ">>"; }
|
||||
else { die; }
|
||||
return $buf;
|
||||
}
|
||||
|
||||
sub asHTML
|
||||
{
|
||||
my ($this, $o) = @_;
|
||||
my $ret;
|
||||
$ret .= makeQuotes($this->{'quotesLeft'});
|
||||
$ret .= $this->{'chars'};
|
||||
$ret .= makeQuotes($this->{'quotesRight'});
|
||||
$o->write("<span class=\"s\">" . S2::BackendHTML::quoteHTML($ret) . "</span>");
|
||||
}
|
||||
|
||||
sub scan
|
||||
{
|
||||
my ($class, $t) = @_;
|
||||
|
||||
my $inTriple = 0;
|
||||
my $continued = 0;
|
||||
my $pos = $t->getPos();
|
||||
|
||||
if ($t->{'inString'} == 0) {
|
||||
# see if this is a triple quoted string,
|
||||
# like python. if so, don't need to escape quotes
|
||||
$t->getRealChar(); # 1
|
||||
if ($t->peekChar() eq '"') {
|
||||
$t->getChar(); # 2
|
||||
if ($t->peekChar() eq '"') {
|
||||
$t->getChar(); # 3
|
||||
$inTriple = 1;
|
||||
} else {
|
||||
$t->{'inString'} = 0;
|
||||
return S2::TokenStringLiteral->new("", 1, 1);
|
||||
}
|
||||
}
|
||||
} elsif ($t->{'inString'} == 3) {
|
||||
$continued = 1;
|
||||
$inTriple = 1;
|
||||
} elsif ($t->{'inString'} == 1) {
|
||||
$continued = 1;
|
||||
}
|
||||
|
||||
my $tbuf; # text buffer (escaped)
|
||||
my $sbuf; # source buffer
|
||||
|
||||
while (1) {
|
||||
my $peekchar = $t->peekChar();
|
||||
if (! defined $peekchar) {
|
||||
die "Run-away string. Check for unbalanced quotes on string literals.\n";
|
||||
} elsif ($peekchar eq '"') {
|
||||
if (! $inTriple) {
|
||||
$t->getChar();
|
||||
$t->{'inString'} = 0;
|
||||
return S2::TokenStringLiteral->new($tbuf, $sbuf, $continued ? 0 : 1, 1);
|
||||
} else {
|
||||
$t->getChar(); # 1
|
||||
if ($t->peekChar() eq '"') {
|
||||
$t->getChar(); # 2
|
||||
if ($t->peekChar() eq '"') {
|
||||
$t->getChar(); # 3
|
||||
$t->{'inString'} = 0;
|
||||
return S2::TokenStringLiteral->new($tbuf, $sbuf, $continued ? 0 : 3, 3);
|
||||
} else {
|
||||
$tbuf .= '""';
|
||||
$sbuf .= '""';
|
||||
}
|
||||
} else {
|
||||
$tbuf .= '"';
|
||||
$sbuf .= '"';
|
||||
}
|
||||
}
|
||||
} else {
|
||||
if ($t->peekChar() eq '$') {
|
||||
$t->{'inString'} = $inTriple ? 3 : 1;
|
||||
return S2::TokenStringLiteral->new($tbuf, $sbuf,
|
||||
$continued ? 0 : ($inTriple ? 3 : 1),
|
||||
0);
|
||||
}
|
||||
|
||||
if ($t->peekChar() eq "\\") {
|
||||
$sbuf .= $t->getRealChar(); # skip the backslash. next thing will be literal.
|
||||
$sbuf .= $t->peekChar();
|
||||
if ($t->peekChar() eq 'n') {
|
||||
$t->forceNextChar("\n");
|
||||
}
|
||||
$tbuf .= $t->getRealChar();
|
||||
} else {
|
||||
my $c = $t->getRealChar();
|
||||
$tbuf .= $c;
|
||||
$sbuf .= $c;
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
sub asS2
|
||||
{
|
||||
my ($this, $o) = @_;
|
||||
$o->write(makesQuote($this->{'quotesLeft'}));
|
||||
$o->write(S2::Backend::quoteStringInner($this->{'text'}));
|
||||
$o->write(makesQuote($this->{'quotesRight'}));
|
||||
}
|
||||
|
||||
sub asPerl
|
||||
{
|
||||
my ($this, $bp, $o) = @_;
|
||||
$o->write($bp->quoteString($this->{'text'}));
|
||||
}
|
||||
|
||||
sub makeQuotes
|
||||
{
|
||||
my $i = shift;
|
||||
return "" if $i == 0;
|
||||
return "\"" if $i == 1;
|
||||
return "\"\"\"" if $i == 3;
|
||||
return "XXX";
|
||||
}
|
||||
|
||||
|
||||
1;
|
||||
|
||||
38
wcmtools/s2/S2/TokenWhitespace.pm
Executable file
38
wcmtools/s2/S2/TokenWhitespace.pm
Executable file
@@ -0,0 +1,38 @@
|
||||
#!/usr/bin/perl
|
||||
#
|
||||
|
||||
package S2::TokenWhitespace;
|
||||
|
||||
use strict;
|
||||
use S2::Token;
|
||||
use vars qw($VERSION @ISA);
|
||||
|
||||
$VERSION = '1.0';
|
||||
@ISA = qw(S2::Token);
|
||||
|
||||
sub new {
|
||||
my ($class, $ws) = @_;
|
||||
my $this = {
|
||||
'chars' => $ws,
|
||||
};
|
||||
bless $this, $class;
|
||||
}
|
||||
|
||||
sub isNecessary { 0; }
|
||||
|
||||
sub getWhiteSpace {
|
||||
my $this = shift;
|
||||
$this->{'chars'};
|
||||
}
|
||||
|
||||
sub toString {
|
||||
return "[TokenWhitespace]";
|
||||
}
|
||||
|
||||
sub asHTML {
|
||||
my ($this, $o) = @_;
|
||||
$o->write($this->{'chars'});
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
189
wcmtools/s2/S2/Tokenizer.pm
Executable file
189
wcmtools/s2/S2/Tokenizer.pm
Executable file
@@ -0,0 +1,189 @@
|
||||
#!/usr/bin/perl
|
||||
#
|
||||
|
||||
use strict;
|
||||
use S2::FilePos;
|
||||
use S2::TokenPunct;
|
||||
use S2::TokenWhitespace;
|
||||
use S2::TokenIdent;
|
||||
use S2::TokenIntegerLiteral;
|
||||
use S2::TokenPunct;
|
||||
use S2::TokenComment;
|
||||
use S2::TokenStringLiteral;
|
||||
|
||||
package S2::Tokenizer;
|
||||
|
||||
sub new # (fh) class method
|
||||
{
|
||||
my ($class, $content) = @_;
|
||||
|
||||
my $this = {};
|
||||
bless $this, $class;
|
||||
|
||||
if (ref $content eq "SCALAR") {
|
||||
$this->{'content'} = $content;
|
||||
$this->{'length'} = length $$content;
|
||||
}
|
||||
$this->{'pos'} = 0;
|
||||
$this->{'line'} = 1;
|
||||
$this->{'col'} = 1;
|
||||
$this->{'inString'} = 0; # (accessed directly elsewhere)
|
||||
$this->{'inStringStack'} = [];
|
||||
$this->{'peekedToken'} = undef;
|
||||
return $this;
|
||||
}
|
||||
|
||||
sub pushInString {
|
||||
my ($this, $val) = @_;
|
||||
push @{$this->{'inStringStack'}}, $this->{'inString'};
|
||||
$this->{'inString'} = $val;
|
||||
#print STDERR "PUSH: $val Stack: @{$this->{'inStringStack'}}\n";
|
||||
}
|
||||
|
||||
sub popInString {
|
||||
my ($this) = @_;
|
||||
my $was = $this->{'inString'};
|
||||
$this->{'inString'} = pop @{$this->{'inStringStack'}};
|
||||
#print STDERR "POP: $this->{'inString'} Stack: @{$this->{'inStringStack'}}\n";
|
||||
if ($was != $this->{'inString'} && $this->{'peekedToken'}) {
|
||||
# back tokenizer up and discard our peeked token
|
||||
pos(${$this->{'content'}}) = $this->{'peekedToken'}->{'pos_re'};
|
||||
$this->{'peekedToken'} = undef;
|
||||
}
|
||||
}
|
||||
|
||||
sub peek # () method : Token
|
||||
{
|
||||
$_[0]->{'peekedToken'} ||= $_[0]->getToken(1);
|
||||
}
|
||||
|
||||
sub getToken # () method : Token
|
||||
{
|
||||
my ($this, $just_peek) = @_;
|
||||
|
||||
# return peeked token if we have one
|
||||
if (my $t = $this->{'peekedToken'}) {
|
||||
$this->{'peekedToken'} = undef;
|
||||
$this->moveLineCol($t) unless $just_peek;
|
||||
return $t;
|
||||
}
|
||||
|
||||
my $pos = $this->getPos();
|
||||
my $pos_re = pos(${$this->{'content'}});
|
||||
my $nxtoken = $this->makeToken();
|
||||
if ($nxtoken) {
|
||||
$nxtoken->{'pos'} = $pos;
|
||||
$nxtoken->{'pos_re'} = $pos_re;
|
||||
$this->moveLineCol($nxtoken) unless $just_peek;
|
||||
}
|
||||
# print STDERR "Token: ", $nxtoken->toString, "\n";
|
||||
return $nxtoken;
|
||||
}
|
||||
|
||||
sub getPos # () method : FilePos
|
||||
{
|
||||
return new S2::FilePos($_[0]->{'line'},
|
||||
$_[0]->{'col'});
|
||||
}
|
||||
|
||||
sub moveLineCol {
|
||||
my ($this, $t) = @_;
|
||||
if (my $newlines = ($t->{'chars'} =~ tr/\n/\n/)) {
|
||||
# print STDERR "Chars: $t [$t->{'chars'}] Lines: $newlines\n";
|
||||
$this->{'line'} += $newlines;
|
||||
$t->{'chars'} =~ /\n(.+)$/m;
|
||||
$this->{'col'} = 1 + length $1;
|
||||
} else {
|
||||
# print STDERR "Chars: $t [$t->{'chars'}]\n";
|
||||
$this->{'col'} += length $t->{'chars'};
|
||||
}
|
||||
}
|
||||
|
||||
sub makeToken # () method private : Token
|
||||
{
|
||||
my $this = shift;
|
||||
my $c = $this->{'content'};
|
||||
|
||||
# finishing or trying to finish an open quoted string
|
||||
if ($this->{'inString'} == 1 &&
|
||||
$$c =~ /\G((\\[\\\"\$]|[^\"\$])*)(\")?/sgc) {
|
||||
my $source = $1;
|
||||
my $closed = $3 ? 1 : 0;
|
||||
return S2::TokenStringLiteral->new(undef, $source, 0, $closed);
|
||||
}
|
||||
|
||||
# finishing a triple quoted string
|
||||
if ($this->{'inString'} == 3) {
|
||||
if ($$c =~ /\G((\\[\\\"\$]|[^\$])*?)\"\"\"/sgc) {
|
||||
my $source = $1;
|
||||
return S2::TokenStringLiteral->new(undef, $source, 0, 3);
|
||||
}
|
||||
|
||||
# not finishing a triple quoted string (end in $)
|
||||
if ($$c =~ /\G((\\[\\\"\$]|[^\$])*)/sgc) {
|
||||
my $source = $1;
|
||||
return S2::TokenStringLiteral->new(undef, $source, 0, 0);
|
||||
}
|
||||
}
|
||||
|
||||
# not in a string, but one's starting
|
||||
if ($this->{'inString'} == 0 && $$c =~ /\G\"/gc) {
|
||||
# triple start and triple end
|
||||
if ($$c =~ /\G\"\"((\\[\\\"\$]|[^\$])*?)\"\"\"/gc) {
|
||||
my $source = $1;
|
||||
return S2::TokenStringLiteral->new(undef, $source, 3, 3);
|
||||
}
|
||||
|
||||
# triple start and variable end
|
||||
if ($$c =~ /\G\"\"((\\[\\\"\$]|[^\$])*)/gc) {
|
||||
my $source = $1;
|
||||
return S2::TokenStringLiteral->new(undef, $source, 3, 0);
|
||||
}
|
||||
|
||||
# single start and maybe end
|
||||
if ($$c =~ /\G((\\[\\\"\$]|[^\"\$])*)(\")?/gc) {
|
||||
my $source = $1;
|
||||
my $closed = $3 ? 1 : 0;
|
||||
return S2::TokenStringLiteral->new(undef, $source, 1, $closed);
|
||||
}
|
||||
}
|
||||
|
||||
if ($$c =~ /\G\s+/gc) {
|
||||
my $ws = $&;
|
||||
return S2::TokenWhitespace->new($ws);
|
||||
}
|
||||
|
||||
if ($$c =~ /\G(<=?|>=?|==|=>?|!=|\+\+?|->|--?|;|::?|&&?|\|\|?|\*|\/|%|!|\.\.?|\{|\}|\[|\]|\(|\)|,|\?|\$)/gc) {
|
||||
return S2::TokenPunct->new($1);
|
||||
}
|
||||
|
||||
if ($$c =~ /\G[a-zA-Z\_]\w*/gc) {
|
||||
my $ident = $&;
|
||||
return S2::TokenIdent->new($ident);
|
||||
}
|
||||
|
||||
if ($$c =~ /\G(\d+)/gc) {
|
||||
my $iv = $1;
|
||||
return S2::TokenIntegerLiteral->new($iv);
|
||||
}
|
||||
|
||||
if ($$c =~ /\G\#.*\n?/gc) {
|
||||
return S2::TokenComment->new($&);
|
||||
}
|
||||
|
||||
if ($$c =~ /.+/gc) {
|
||||
S2::error($this->getPos(), "Parse error! Unknown token. ($&)");
|
||||
}
|
||||
|
||||
return undef;
|
||||
}
|
||||
|
||||
sub peekChar {
|
||||
my $this = shift;
|
||||
my $pos = pos(${$this->{'content'}});
|
||||
my $ch = substr(${$this->{'content'}}, $pos, 1);
|
||||
#print STDERR "pos = $pos, char = $ch\n";
|
||||
return $ch;
|
||||
}
|
||||
|
||||
1;
|
||||
149
wcmtools/s2/S2/Type.pm
Executable file
149
wcmtools/s2/S2/Type.pm
Executable file
@@ -0,0 +1,149 @@
|
||||
#!/usr/bin/perl
|
||||
#
|
||||
|
||||
package S2::Type;
|
||||
|
||||
use strict;
|
||||
use S2::Node;
|
||||
use S2::Type;
|
||||
use vars qw($VOID $STRING $INT $BOOL);
|
||||
|
||||
$VOID = new S2::Type("void", 1);
|
||||
$STRING = new S2::Type("string", 1);
|
||||
$INT = new S2::Type("int", 1);
|
||||
$BOOL = new S2::Type("bool", 1);
|
||||
|
||||
sub new {
|
||||
my ($class, $base, $final) = @_;
|
||||
my $this = {
|
||||
'baseType' => $base,
|
||||
'typeMods' => "",
|
||||
};
|
||||
$this->{'final'} = 1 if $final;
|
||||
bless $this, $class;
|
||||
}
|
||||
|
||||
sub clone {
|
||||
my $this = shift;
|
||||
my $nt = S2::Type->new($this->{'baseType'});
|
||||
$nt->{'typeMods'} = $this->{'typeMods'};
|
||||
$nt->{'readOnly'} = $this->{'readOnly'};
|
||||
return $nt;
|
||||
}
|
||||
|
||||
# return true if the type can be interpretted in a boolean context
|
||||
sub isBoolable {
|
||||
my $this = shift;
|
||||
|
||||
# everything is boolable but void
|
||||
# int: != 0
|
||||
# bool: obvious
|
||||
# string: != ""
|
||||
# Object: defined
|
||||
# array: elements > 0
|
||||
# hash: elements > 0
|
||||
|
||||
return ! $this->equals($VOID);
|
||||
}
|
||||
|
||||
sub subTypes {
|
||||
my ($this, $ck) = @_;
|
||||
my $l = [];
|
||||
|
||||
my $nc = $ck->getClass($this->{'baseType'});
|
||||
unless ($nc) {
|
||||
# no sub-classes. just return our type.
|
||||
push @$l, $this;
|
||||
return $l;
|
||||
}
|
||||
|
||||
foreach my $der (@{$nc->getDerClasses()}) {
|
||||
# add a copy of this type to the list, but with
|
||||
# the derivative class type. that way it
|
||||
# saves the varlevels: A[] .. B[] .. C[], etc
|
||||
my $c = $der->{'nc'}->getName();
|
||||
my $newt = $this->clone();
|
||||
$newt->{'baseType'} = $c;
|
||||
push @$l, $newt;
|
||||
}
|
||||
|
||||
return $l;
|
||||
}
|
||||
|
||||
sub equals {
|
||||
my ($this, $o) = @_;
|
||||
return unless $o->isa('S2::Type');
|
||||
return $o->{'baseType'} eq $this->{'baseType'} &&
|
||||
$o->{'typeMods'} eq $this->{'typeMods'};
|
||||
}
|
||||
|
||||
sub sameMods {
|
||||
my ($class, $a, $b) = @_;
|
||||
return $a->{'typeMods'} eq $b->{'typeMods'};
|
||||
}
|
||||
|
||||
sub makeArrayOf {
|
||||
my ($this) = @_;
|
||||
S2::error('', "Internal error") if $this->{'final'};
|
||||
$this->{'typeMods'} .= "[]";
|
||||
}
|
||||
|
||||
sub makeHashOf {
|
||||
my ($this) = @_;
|
||||
S2::error('', "Internal error") if $this->{'final'};
|
||||
$this->{'typeMods'} .= "{}";
|
||||
}
|
||||
|
||||
sub removeMod {
|
||||
my ($this) = @_;
|
||||
S2::error('', "Internal error") if $this->{'final'};
|
||||
$this->{'typeMods'} =~ s/..$//;
|
||||
}
|
||||
|
||||
sub isSimple {
|
||||
my ($this) = @_;
|
||||
return ! length $this->{'typeMods'};
|
||||
}
|
||||
|
||||
sub isHashOf {
|
||||
my ($this) = @_;
|
||||
return $this->{'typeMods'} =~ /\{\}$/;
|
||||
}
|
||||
|
||||
sub isArrayOf {
|
||||
my ($this) = @_;
|
||||
return $this->{'typeMods'} =~ /\[\]$/;
|
||||
}
|
||||
|
||||
sub baseType {
|
||||
shift->{'baseType'};
|
||||
}
|
||||
|
||||
sub toString {
|
||||
my $this = shift;
|
||||
"$this->{'baseType'}$this->{'typeMods'}";
|
||||
}
|
||||
|
||||
sub isPrimitive {
|
||||
my $arg = shift;
|
||||
my $t;
|
||||
if (ref $arg) { $t = $arg; }
|
||||
else {
|
||||
$t = S2::Type->new($arg);
|
||||
}
|
||||
return $t->equals($STRING) ||
|
||||
$t->equals($INT) ||
|
||||
$t->equals($BOOL);
|
||||
}
|
||||
|
||||
sub isReadOnly {
|
||||
shift->{'readOnly'};
|
||||
}
|
||||
|
||||
sub setReadOnly {
|
||||
my ($this, $v) = @_;
|
||||
S2::error('', "Internal error") if $this->{'final'};
|
||||
$this->{'readOnly'} = $v;
|
||||
}
|
||||
|
||||
|
||||
26
wcmtools/s2/S2/Util.pm
Executable file
26
wcmtools/s2/S2/Util.pm
Executable file
@@ -0,0 +1,26 @@
|
||||
#!/usr/bin/perl
|
||||
#
|
||||
|
||||
package S2;
|
||||
|
||||
sub error {
|
||||
my ($where, $msg) = @_;
|
||||
if (ref $where && ($where->isa('S2::Token') ||
|
||||
$where->isa('S2::Node'))) {
|
||||
$where = $where->getFilePos();
|
||||
}
|
||||
if (ref $where eq "S2::FilePos") {
|
||||
$where = $where->locationString;
|
||||
}
|
||||
|
||||
my $i = 0;
|
||||
my $errmsg = "$where: $msg\n";
|
||||
while (my ($p, $f, $l) = caller($i++)) {
|
||||
$errmsg .= " $p, $f, $l\n";
|
||||
}
|
||||
undef $S2::CUR_COMPILER;
|
||||
die $errmsg;
|
||||
}
|
||||
|
||||
|
||||
1;
|
||||
Reference in New Issue
Block a user