summaryrefslogtreecommitdiff
path: root/lib
diff options
context:
space:
mode:
authorGianni Ceccarelli <dakkar@dechirico.(none)>2009-04-24 17:31:29 +0200
committerGianni Ceccarelli <dakkar@dechirico.(none)>2009-04-24 17:31:29 +0200
commitbfed0bff47f9e854e587c852332ab9ea71993d37 (patch)
tree618677d40a12bca3830d45964b2342974534dbb3 /lib
downloadTree-tests-bfed0bff47f9e854e587c852332ab9ea71993d37.tar.gz
Tree-tests-bfed0bff47f9e854e587c852332ab9ea71993d37.tar.bz2
Tree-tests-bfed0bff47f9e854e587c852332ab9ea71993d37.zip
first testHEADmaster
Diffstat (limited to 'lib')
-rw-r--r--lib/Compiler.pm65
-rw-r--r--lib/Parser.pm89
2 files changed, 154 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] } }