diff options
| -rw-r--r-- | lib/Compiler.pm | 65 | ||||
| -rw-r--r-- | lib/Parser.pm | 89 | ||||
| -rw-r--r-- | test.pl | 26 |
3 files changed, 180 insertions, 0 deletions
diff --git a/lib/Compiler.pm b/lib/Compiler.pm new file mode 100644 index 0000000..23fad01 --- /dev/null +++ b/lib/Compiler.pm @@ -0,0 +1,65 @@ +package Compiler; +use strict; +use warnings; +use Tree::Transform::XSLTish; + +default_rules; + +tree_rule match => '/', action => sub { + my $prog=<<'PROG'; +#!/usr/bin/perl +use strict; +use warnings; +PROG + $prog.=$_ for $_[0]->apply_rules; + return $prog; +}; + +tree_rule match => 'line[@label]', action => sub { + return $_[0]->it->attributes->{label}.': '.(($_[0]->apply_rules)[0]); +}; + +tree_rule match => 'assign', action => sub { + my ($var)=$_[0]->apply_rules($_[0]->engine->findnodes('var',$_[0]->it)); + my ($value)=$_[0]->apply_rules($_[0]->engine->findnodes('*[name()!="var"]',$_[0]->it)); + + return "$var = $value;\n"; +}; + +tree_rule match => 'if', action => sub { + my ($guard,$then,$else)=map {$_[0]->engine->findnodes($_,$_[0]->it)} + qw(guard then else); + + ($guard)=$_[0]->apply_rules($guard); + ($then,$else)=map {$_->attributes->{label}} $then,$else; + + return "if ($guard) { goto $then } else { goto $else }\n"; +}; + +tree_rule match => 'goto', action => sub { + return 'goto '.$_[0]->it->attributes->{label}.";\n"; +}; + +tree_rule match => 'print', action => sub { + return 'print '.(join '',$_[0]->apply_rules).";\n"; +}; + +tree_rule match => 'var', action => sub { + return '$'.$_[0]->it->attributes->{name}; #' +}; + +sub joiner { + my $j=$_[0]; + return sub { + join $j,$_[0]->apply_rules; + } +} + +tree_rule match => 'add', action => joiner('+'); +tree_rule match => 'mult', action => joiner('*'); + +tree_rule match => 'const', action => sub { + return $_[0]->it->attributes->{value}; +}; + +1; diff --git a/lib/Parser.pm b/lib/Parser.pm new file mode 100644 index 0000000..c10a8f9 --- /dev/null +++ b/lib/Parser.pm @@ -0,0 +1,89 @@ +package Parser; +use strict; +use warnings; +use Parse::RecDescent; + +my $parser=Parse::RecDescent->new(do {local $/;<DATA>}); + +sub parse { + return $parser->program($_[0]); +} + +__DATA__ +{ +use Tree::DAG_Node::XPath; +use Tree::Template::Declare::DAG_Node; +use Tree::Template::Declare + builder => + Tree::Template::Declare::DAG_Node->new('Tree::DAG_Node::XPath'); + +sub diag { +# warn '#'.(shift)."\n <".join('><',@_).">\n"; +} + +} + +word: /[[:alpha:]]\w*/ +number: /\d+/ + +program: line(s) + { diag 'program',@item; + tree { node { name 'program'; attach_nodes @{$item[1]} }; }; + } + +line: label(?) statement + { diag 'line',@item; + node { name 'line'; + if (@{$item[1]}) { + diag 'line-label',$item[1]->[0]; + attribs label => $item[1]->[0]; + }; + attach_nodes $item{statement}; + }; + } + +statement: word '=' expression + { diag 'assign'; + node { name 'assign'; + node { name 'var'; attribs name => $item{word} }; + attach_nodes $item{expression}; + }; + } + | 'if' expression 'then' word 'else' word + { diag 'if'; + node { name 'if'; + node { name 'guard'; attach_nodes $item{expression} }; + node { name 'then'; attribs label => $item[4] }; + node { name 'else'; attribs label => $item[6] }; + }; + } + | 'goto' word + { diag 'goto'; + node { name 'goto'; attribs label => $item{label} }; + } + | 'print' expression + { diag 'print'; + node { name 'print'; attach_nodes $item{expression} }; + } + +label: word ':' { $item{word} } + +expression: mult_expr '+' expression + { diag 'add'; + node { name 'add'; + attach_nodes $item{mult_expr}, $item{expression} }; + } + | mult_expr + { diag 'add->mult'; $item[1]; } + +mult_expr: simple_expr '*' mult_expr + { diag 'mult'; + node { name 'mult'; + attach_nodes $item{simple_expr}, $item{expression} }; + } + | simple_expr + { diag 'mult->simple'; $item[1]; } + +simple_expr: '(' expression ')' { diag 'parens'; $item{expression} } + | word { diag 'var'; node { name 'var'; attribs name => $item[1] } } + | number { diag 'const',@item; node { name 'const'; attribs value => $item[1] } } @@ -0,0 +1,26 @@ +#!/usr/bin/perl +use strict; +use warnings; +use lib '../Tree-Template-Declare/blib/lib/'; +use lib '../Tree-Transform-XSLTish/blib/lib/'; +use lib './lib'; +use Parser; +use Compiler; + +sub Tree::DAG_Node::XPath::Root::xpath_get_root_node { return $_[0] } +sub Tree::DAG_Node::XPath::Root::xpath_get_parent_node { return } + +my $src=do {local $/;<DATA>}; +print $src,"----\n\n"; +#$::RD_TRACE=1; +my $doc=Parser::parse(\$src); +print "\n----\n$src----\n"; +print map "$_\n", @{$doc->draw_ascii_tree}; +print "\n----\n"; +my $comp=Compiler->new(); +print $comp->transform($doc); + +__DATA__ +gino = 5 +if 5 + 3 then pino else rino +pino: print gino |