From bfed0bff47f9e854e587c852332ab9ea71993d37 Mon Sep 17 00:00:00 2001
From: Gianni Ceccarelli <dakkar@dechirico.(none)>
Date: Fri, 24 Apr 2009 17:31:29 +0200
Subject: first test

---
 lib/Compiler.pm | 65 +++++++++++++++++++++++++++++++++++++++++
 lib/Parser.pm   | 89 +++++++++++++++++++++++++++++++++++++++++++++++++++++++++
 test.pl         | 26 +++++++++++++++++
 3 files changed, 180 insertions(+)
 create mode 100644 lib/Compiler.pm
 create mode 100644 lib/Parser.pm
 create mode 100644 test.pl

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] } }
diff --git a/test.pl b/test.pl
new file mode 100644
index 0000000..04bcfbb
--- /dev/null
+++ b/test.pl
@@ -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
-- 
cgit v1.2.3