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 +++++++++++++++++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 65 insertions(+)
 create mode 100644 lib/Compiler.pm

(limited to 'lib/Compiler.pm')

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;
-- 
cgit v1.2.3