lib/Compiler.pm


1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
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;