Skip to content
This repository

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Browse code

[Yapsi] big compiler/runtime refactor

Basically switched out everything. Yapsi now has a new Yapsi. It runs under
Rakudo master for the first time.

Three tests fail in t/compiler.t. Some odd effect cause t/runtime.t to fail
when nothing is printed from Yapsi.pm.
  • Loading branch information...
commit 62ff73d804541505edd65adb3cced9f9255bfdd2 1 parent 2c149f4
Carl Mäsak authored August 02, 2010
16  Makefile
... ...
@@ -1,16 +0,0 @@
1  
-PERL6=alpha
2  
-
3  
-SOURCES=lib/Yapsi.pm
4  
-
5  
-PIRS=$(SOURCES:.pm=.pir)
6  
-
7  
-all: $(PIRS)
8  
-
9  
-%.pir: %.pm
10  
-	env PERL6LIB=`pwd`/lib $(PERL6) --target=pir --output=$@ $<
11  
-
12  
-clean:
13  
-	rm -f $(PIRS)
14  
-
15  
-test: all
16  
-	env PERL6LIB=`pwd`/lib prove -e '$(PERL6)' -r --nocolor t/
846  lib/Yapsi.pm
@@ -2,18 +2,24 @@ use v6;
2 2
 
3 3
 my $VERSION = '2010.08';
4 4
 
  5
+my $_PROGRAM; # RAKUDO: Part of workaround required because of [perl #76894]
  6
+
5 7
 grammar Yapsi::Perl6::Grammar {
6 8
     regex TOP { ^ <statementlist> <.ws> $ }
7 9
     regex statementlist { <statement> ** <eat_terminator> }
8 10
     token statement { <statement_control> || <expression> || '' }
9  
-    token eat_terminator { <?after '}'> \n || <.ws> ';' }
  11
+    # RAKUDO: <?after '{'> NYRI [perl #76894]
  12
+    token eat_terminator { <?{ $/.CURSOR.pos > 1
  13
+                               && $_PROGRAM.substr($/.CURSOR.pos - 1, 1) eq "\{"
  14
+                           }> \n
  15
+                           || <.ws> ';' }
10 16
     token expression { <assignment> || <binding> || <variable> || <literal>
11 17
                        || <declaration> || <block>
12 18
                        || <saycall> || <increment> || <decrement> }
13 19
     token statement_control { <statement_control_if>
14 20
                               || <statement_control_while> }
15 21
     rule  statement_control_if { 'if' <expression> <block>
16  
-                                 [ 'else' <else=block> ]? }
  22
+                                 [ 'else' <else=.block> ]? }
17 23
     rule  statement_control_while { 'while' <expression> <block> }
18 24
     token lvalue { <declaration> || <variable> || <increment> }
19 25
     token value { <variable> || <literal> || <declaration> || <saycall>
@@ -29,187 +35,250 @@ grammar Yapsi::Perl6::Grammar {
29 35
     token block { <.ws> '{' <.ws> <statementlist> <.ws> '}' }
30 36
 }
31 37
 
32  
-class Yapsi::Environment {
33  
-    has %.pads;
34  
-    has @.containers;
  38
+my $block-number = 0;   # Can be done with 'state' when Rakudo has it
  39
+sub unique-block() {
  40
+    'B' ~ $block-number++;
35 41
 }
36 42
 
37  
-class Yapsi::Compiler {
38  
-    has @.warnings;
39  
-
40  
-    method compile($program, Yapsi::Environment :$env) {
41  
-        @!warnings = ();
42  
-        die "Could not parse"
43  
-            unless Yapsi::Perl6::Grammar.parse($program);
44  
-        my Yapsi::Environment $*env
45  
-            = $env ~~ Yapsi::Environment
46  
-                && defined $env
47  
-                ?? $env !! Yapsi::Environment.new;
48  
-        my $*current-block = '';
49  
-        my @*block-counters; # keeps track of nested block numbers
50  
-        self.find-vars($/, 'block');
51  
-        my @sic = "This is SIC v$VERSION", '', 'environment:';
52  
-        my $INDENT = '    ';
53  
-        for $*env.pads.keys.sort -> $pad {
54  
-            push @sic, $INDENT ~ $pad ~ ':';
55  
-            for $*env.pads{$pad}.keys -> $var {
56  
-                push @sic, $INDENT x 2 ~ $var ~ ': '
57  
-                           ~ $*env.pads{$pad}{$var}.perl;
58  
-            }
59  
-        }
60  
-        push @sic, $INDENT ~ 'containers: ' ~ $*env.containers.perl;
61  
-        my $*c = 0; # unique register counter
62  
-        my $*l = 0; # unique label    counter
63  
-        my @*block-order;
64  
-        my %*blocks;
65  
-        $*current-block = '';
66  
-        self.sicify($/, 'block');
67  
-        for @*block-order -> $block {
68  
-            push @sic, '';
69  
-            push @sic, "block '$block':";
70  
-            for renumber(declutter(%*blocks{$block})) {
71  
-                push @sic, $INDENT ~ $_;
72  
-            }
73  
-        }
74  
-        return @sic;
75  
-    }
76  
-
77  
-    multi method find-vars(Match $/, 'statement') {
78  
-        # RAKUDO: Autovivification
79  
-        if $<expression> && $<expression><block> -> $e {
80  
-            my $remember-block = $*current-block;
81  
-            self.find-vars($e, 'block');
82  
-            $*current-block = $remember-block;
83  
-        }
84  
-        elsif $<expression> -> $e {
85  
-            self.find-vars($e, 'expression');
86  
-        }
87  
-        # RAKUDO: Autovivification
88  
-        elsif $<statement_control>
89  
-              && $<statement_control><statement_control_if> -> $e {
90  
-            self.find-vars($e, 'statement_control_if');
91  
-        }
92  
-        # RAKUDO: Autovivification
93  
-        elsif $<statement_control>
94  
-              && $<statement_control><statement_control_while> -> $e {
95  
-            self.find-vars($e, 'statement_control_while');
96  
-        }
97  
-    }
98  
-
99  
-    multi method find-vars(Match $/, 'expression') {
100  
-        # XXX: This warning doesn't have much to do with finding vars
101  
-        if $/<block> {
102  
-            die "Can not handle non-immediate blocks yet. Sorry. :/";
103  
-        }
104  
-        for <assignment binding variable declaration saycall
105  
-             increment decrement> -> $subrule {
106  
-            if $/{$subrule} -> $e {
107  
-                self.find-vars($e, $subrule);
108  
-            }
109  
-        }
110  
-    }
111  
-
112  
-    multi method find-vars(Match $/, 'statement_control_if') {
113  
-        self.find-vars($<expression>, 'expression');
114  
-        my $remember-block = $*current-block;
115  
-        self.find-vars($<block>, 'block');
116  
-        $*current-block = $remember-block;
117  
-        # RAKUDO: Autovivification
118  
-        if $<else> && $<else>[0] -> $e {
119  
-            self.find-vars($e, 'block');
120  
-            $*current-block = $remember-block;
121  
-        }
122  
-    }
123  
-
124  
-    multi method find-vars(Match $/, 'statement_control_while') {
125  
-        self.find-vars($<expression>, 'expression');
126  
-        my $remember-block = $*current-block;
127  
-        self.find-vars($<block>, 'block');
128  
-        $*current-block = $remember-block;
129  
-    }
130  
-
131  
-    multi method find-vars(Match $/, 'lvalue') {
132  
-        for <variable declaration> -> $subrule {
133  
-            if $/{$subrule} -> $e {
134  
-                self.find-vars($e, $subrule);
135  
-            }
  43
+sub descend-into(Match $m, :$key = "TOP", :&action, :@skip) {
  44
+    action($m, $key);
  45
+    for %($m).keys -> $key {
  46
+        next if $key eq any @skip;
  47
+        given $m{$key} {
  48
+            when Match { descend-into($_, :$key, :&action, :@skip) }
  49
+            when Array { descend-into($_, :$key, :&action, :@skip) for .list }
  50
+            default { die "Unknown thing $_.WHAT() in parse tree!" }
136 51
         }
137 52
     }
  53
+}
138 54
 
139  
-    multi method find-vars(Match $/, 'value') {
140  
-        for <variable declaration saycall increment decrement> -> $subrule {
141  
-            if $/{$subrule} -> $e {
142  
-                self.find-vars($e, $subrule);
  55
+sub traverse-bottom-up(Match $m, :$key = "TOP", :&action, :@skip) {
  56
+    unless $key eq any @skip {
  57
+        for %($m).keys -> $key {
  58
+            given $m{$key} {
  59
+                when Match { traverse-bottom-up($_, :$key, :&action, :@skip) }
  60
+                when Array { traverse-bottom-up($_, :$key, :&action, :@skip)
  61
+                                for .list }
  62
+                default { die "Unknown thing $_.WHAT() in parse tree!" }
143 63
             }
144 64
         }
145 65
     }
  66
+    action($m, $key);
  67
+}
146 68
 
147  
-    multi method find-vars(Match $name, 'variable') {
148  
-        my $block = $*current-block;
149  
-        loop {
150  
-            return if $*env.pads{$block}.exists( ~$name );
151  
-            last unless $block ~~ / _\d+ $/;
152  
-            $block.=substr(0, $block.chars - $/.chars);
153  
-        }
154  
-        die "Invalid. $name not declared before use";
155  
-    }
156  
-
157  
-    multi method find-vars(Match $/, 'literal') {
158  
-        die "This multi variant should never be called";
159  
-    }
  69
+my %block-parents;
160 70
 
161  
-    multi method find-vars(Match $/, 'declaration') {
162  
-        my $name = ~$<variable>;
163  
-        if $*env.pads{$*current-block}{$name} {
164  
-            @!warnings.push: "Useless redeclaration of variable $name";
  71
+class Yapsi::Perl6::Actions {
  72
+    my @vars;
  73
+    my &find-declarations = sub ($m, $key) {
  74
+        if $key eq "declaration" {
  75
+            push @vars, ~$m<variable>;
165 76
         }
166  
-        else {
167  
-            $*env.pads{$*current-block}{$name}
168  
-                = { :type<container>, :n(+$*env.containers) };
169  
-            push $*env.containers, 'Any()';
  77
+    };
  78
+    my &connect-blocks = sub ($name, $block, $m, $key) {
  79
+        if $key eq "block" && $m.ast<name> ne $name {
  80
+            %block-parents{$m.ast<name>} = $block;
170 81
         }
171  
-    }
  82
+    };
172 83
 
173  
-    multi method find-vars(Match $/, 'assignment') {
174  
-        self.find-vars($<lvalue>, 'lvalue');
175  
-        self.find-vars($<expression>, 'expression');
  84
+    method TOP($/) {
  85
+        @vars = ();
  86
+        descend-into($/, :skip['block'], :action(&find-declarations));
  87
+        my $name = unique-block();
  88
+        make my $block = { :$name, :vars(@vars.clone) };
  89
+        descend-into($/, :action(&connect-blocks.assuming($name, $block)));
176 90
     }
177 91
 
178  
-    multi method find-vars(Match $/, 'binding') {
179  
-        self.find-vars($<lvalue>, 'lvalue');
180  
-        self.find-vars($<expression>, 'expression');
181  
-    }
182  
-
183  
-    multi method find-vars(Match $/, 'saycall') {
184  
-        self.find-vars($<expression>, 'expression');
185  
-    }
186  
-
187  
-    multi method find-vars(Match $/, 'increment') {
188  
-        self.find-vars($<value>, 'value');
189  
-    }
190  
-
191  
-    multi method find-vars(Match $/, 'decrement') {
192  
-        self.find-vars($<value>, 'value');
  92
+    method block($/) {
  93
+        @vars = ();
  94
+        descend-into($/, :skip['block'], :action(&find-declarations));
  95
+        my $name = unique-block();
  96
+        make my $block = { :$name, :vars(@vars.clone) };
  97
+        descend-into($/, :action(&connect-blocks.assuming($name, $block)));
193 98
     }
  99
+}
194 100
 
195  
-    multi method find-vars(Match $/, 'block') {
196  
-        if $*current-block {
197  
-            $*current-block ~= '_' ~ @*block-counters[*-1]++;
198  
-            push @*block-counters, 1;
199  
-        }
200  
-        else {
201  
-            $*current-block = 'main';
202  
-            @*block-counters = 1;
203  
-        }
204  
-        $*env.pads{$*current-block} //= {};
205  
-        for $<statementlist><statement> -> $statement {
206  
-            self.find-vars($statement, 'statement');
207  
-        }
208  
-        pop @*block-counters;
209  
-    }
  101
+class Yapsi::Compiler {
  102
+    has @.warnings;
210 103
 
211  
-    multi method find-vars($/, $node) {
212  
-        die "Don't know what to do with a $node";
  104
+    method compile($program) {
  105
+        @!warnings = ();
  106
+        $_PROGRAM = $program; # RAKUDO: Required because of [perl #76894]
  107
+        die "Could not parse"
  108
+            unless Yapsi::Perl6::Grammar.parse(
  109
+                        $program, :actions(Yapsi::Perl6::Actions));
  110
+        my @sic = "This is SIC v$VERSION";
  111
+        my $INDENT = '    ';
  112
+        descend-into($/, :action(-> $m, $key {
  113
+            if $key eq 'TOP'|'block'|'else' {
  114
+                push @sic, '';
  115
+                push @sic, "block '$m.ast<name>':";
  116
+                for $m.ast<vars>.list -> $var {
  117
+                    push @sic, "    `lexvar '$var'";
  118
+                }
  119
+                my @blocksic;
  120
+                my $*c = 0; # unique register counter
  121
+                my $*l = 0; # unique label    counter
  122
+                my @skip = 'block', 'statement_control_if',
  123
+                           'statement_control_while';
  124
+                my &sicify = -> $/, $key {
  125
+                    if $m !=== $/ && $key eq 'block' {
  126
+                        my $register = self.unique-register;
  127
+                        my $block-name = $/.ast<name>;
  128
+                        push @blocksic,
  129
+                            "$register = closure-from-block '$block-name'",
  130
+                            "call $register";
  131
+                    }
  132
+                    elsif $key eq 'statement_control_if' {
  133
+                        traverse-bottom-up(
  134
+                            $<expression>,
  135
+                            :key<expression>,
  136
+                            :@skip,
  137
+                            :action(&sicify)
  138
+                        );
  139
+                        my ($register, $) = $<expression>.ast.list;
  140
+                        my $block-name = $<block>.ast<name>;
  141
+                        my $after-if = self.unique-label;
  142
+                        push @blocksic, "jf $register, $after-if";
  143
+                        $register = self.unique-register;
  144
+                        push @blocksic,
  145
+                            "$register = closure-from-block '$block-name'",
  146
+                            "call $register";
  147
+                        my $after-else;
  148
+                        if $<else> {
  149
+                            $after-else = self.unique-label;
  150
+                            push @blocksic, "jmp $after-else";
  151
+                        }
  152
+                        push @blocksic, "`label $after-if";
  153
+                        if $<else> {
  154
+                            $block-name = $<else>[0].ast<name>;
  155
+                            $register = self.unique-register;
  156
+                            push @blocksic,
  157
+                                "$register = closure-from-block '$block-name'",
  158
+                                "call $register",
  159
+                                "`label $after-else";
  160
+                        }
  161
+                    }
  162
+                    elsif $key eq 'statement_control_while' {
  163
+                        my $before-while = self.unique-label;
  164
+                        my $after-while = self.unique-label;
  165
+                        push @blocksic, "`label $before-while";
  166
+                        traverse-bottom-up(
  167
+                            $<expression>,
  168
+                            :key<expression>,
  169
+                            :@skip,
  170
+                            :action(&sicify)
  171
+                        );
  172
+                        my ($register, $) = $<expression>.ast.list;
  173
+                        push @blocksic, "jf $register, $after-while";
  174
+                        my $block-name = $<block>.ast<name>;
  175
+                        $register = self.unique-register;
  176
+                        push @blocksic,
  177
+                            "$register = closure-from-block '$block-name'",
  178
+                            "call $register",
  179
+                            "jmp $before-while",
  180
+                            "`label $after-while";
  181
+                    }
  182
+                    elsif $key eq 'variable' {
  183
+                        my $register = self.unique-register;
  184
+                        my $current_block = $m.ast;
  185
+                        my $level = 0;
  186
+                        my $slot = -1;
  187
+                        while True {
  188
+                            my @vars = $current_block<vars>.list;
  189
+                            for ^@vars -> $i {
  190
+                                if ~$/ eq @vars[$i] {
  191
+                                    $slot = $i;
  192
+                                    # RAKUDO: Could use a 'last LOOP' here
  193
+                                    last;
  194
+                                }
  195
+                            }
  196
+                            last if $slot != -1;
  197
+                            --$level;
  198
+                            $current_block
  199
+                                = %block-parents{$current_block<name>};
  200
+                            die "Variable '$/' not declared"
  201
+                                unless defined $current_block;
  202
+                        }
  203
+                        my $locator = "[$level, $slot]";
  204
+                        push @blocksic, "$register = fetch $locator";
  205
+                        make [$register, $locator];
  206
+                    }
  207
+                    elsif $key eq 'assignment' {
  208
+                        my ($register, $) = $<expression>.ast.list;
  209
+                        my ($, $locator) = $<lvalue>.ast.list;
  210
+                        push @blocksic, "store $locator, $register";
  211
+                        make [$register, $locator];
  212
+                    }
  213
+                    elsif $key eq 'binding' {
  214
+                        my ($, $leftloc) = $<lvalue>.ast.list;
  215
+                        my ($register, $rightloc) = $<expression>.ast.list;
  216
+                        push @blocksic, "bind $leftloc, $rightloc";
  217
+                        make [$register, $leftloc];
  218
+                    }
  219
+                    elsif $key eq 'value' {
  220
+                        for <variable literal declaration saycall
  221
+                             increment decrement> -> $e {
  222
+                            if $/{$e} {
  223
+                                make $/{$e}.ast;
  224
+                            }
  225
+                        }
  226
+                    }
  227
+                    elsif $key eq 'lvalue' {
  228
+                        for <variable declaration increment decrement> -> $e {
  229
+                            if $/{$e} {
  230
+                                make $/{$e}.ast;
  231
+                            }
  232
+                        }
  233
+                    }
  234
+                    elsif $key eq 'expression' {
  235
+                        for <variable literal declaration assignment binding
  236
+                             saycall increment decrement> -> $e {
  237
+                            if $/{$e} {
  238
+                                make $/{$e}.ast;
  239
+                            }
  240
+                        }
  241
+                    }
  242
+                    elsif $key eq 'literal' {
  243
+                        my $register = self.unique-register;
  244
+                        my $literal = ~$/;
  245
+                        push @blocksic, "$register = $literal";
  246
+                        make [$register, '<constant>'];
  247
+                    }
  248
+                    elsif $key eq 'declaration' {
  249
+                        make $<variable>.ast;
  250
+                    }
  251
+                    elsif $key eq 'increment' {
  252
+                        my ($register, $locator) = $<value>.ast.list;
  253
+                        die "Can't increment a constant"
  254
+                            if $locator eq '<constant>';
  255
+                        push @blocksic, "inc $register",
  256
+                                        "store $locator, $register";
  257
+                        make [$register, $locator];
  258
+                    }
  259
+                    elsif $key eq 'decrement' {
  260
+                        my ($register, $locator) = $<value>.ast.list;
  261
+                        die "Can't increment a constant"
  262
+                            if $locator eq '<constant>';
  263
+                        push @blocksic, "dec $register",
  264
+                                        "store $locator, $register";
  265
+                        make [$register, $locator];
  266
+                    }
  267
+                    elsif $key eq 'saycall' {
  268
+                        my ($register, $) = $<expression>.ast.list;
  269
+                        my $result = self.unique-register;
  270
+                        push @blocksic, "say $register",
  271
+                                        "$result = 1";
  272
+                        make $result;
  273
+                    }
  274
+                };
  275
+                traverse-bottom-up($m, :@skip, :action(&sicify));
  276
+                for renumber declutter @blocksic {
  277
+                    push @sic, $INDENT ~ $_;
  278
+                }
  279
+            }
  280
+        }));
  281
+        return @sic;
213 282
     }
214 283
 
215 284
     method unique-register {
@@ -220,194 +289,20 @@ class Yapsi::Compiler {
220 289
         return 'L' ~ $*l++;
221 290
     }
222 291
 
223  
-    method add-code($line) {
224  
-        %*blocks{$*current-block}.push($line);
225  
-    }
226  
-
227  
-    multi method sicify(Match $/, 'statement') {
228  
-        # RAKUDO: Autovivification
229  
-        if $<expression> && $<expression><block> -> $e {
230  
-            my $remember-block = $*current-block;
231  
-            my $block = self.sicify($e, 'block');
232  
-            $*current-block = $remember-block;
233  
-            my $register = self.unique-register;
234  
-            self.add-code: "$register = fetch-block '$block'";
235  
-            self.add-code: "call $register";
236  
-        }
237  
-        elsif $<expression> -> $e {
238  
-            return self.sicify($e, 'expression');
239  
-        }
240  
-        elsif $<statement_control>
241  
-              && $<statement_control><statement_control_if> -> $e {
242  
-            return self.sicify($e, 'statement_control_if');
243  
-        }
244  
-        elsif $<statement_control>
245  
-              && $<statement_control><statement_control_while> -> $e {
246  
-            return self.sicify($e, 'statement_control_while');
247  
-        }
248  
-    }
249  
-
250  
-    multi method sicify(Match $/, 'statement_control_if') {
251  
-        my ($register, $) = self.sicify($<expression>, 'expression');
252  
-        my $remember-block = $*current-block;
253  
-        my $block = self.sicify($<block>, 'block');
254  
-        $*current-block = $remember-block;
255  
-        my $after-if = self.unique-label;
256  
-        self.add-code: "jf $register, $after-if";
257  
-        $register = self.unique-register;
258  
-        self.add-code: "$register = fetch-block '$block'";
259  
-        self.add-code: "call $register";
260  
-        my $after-else;
261  
-        if $<else> {
262  
-            $after-else = self.unique-label;
263  
-            self.add-code: "jmp $after-else";
264  
-        }
265  
-        self.add-code: "`label $after-if";
266  
-        if $<else> {
267  
-            $block = self.sicify($<else>[0], 'block');
268  
-            $*current-block = $remember-block;
269  
-            $register = self.unique-register;
270  
-            self.add-code: "$register = fetch-block '$block'";
271  
-            self.add-code: "call $register";
272  
-            self.add-code: "`label $after-else";
273  
-        }
274  
-    }
275  
-
276  
-    multi method sicify(Match $/, 'statement_control_while') {
277  
-        my $before-while = self.unique-label;
278  
-        my $after-while = self.unique-label;
279  
-        self.add-code: "`label $before-while";
280  
-        my ($register, $) = self.sicify($<expression>, 'expression');
281  
-        self.add-code: "jf $register, $after-while";
282  
-        my $remember-block = $*current-block;
283  
-        my $block = self.sicify($<block>, 'block');
284  
-        $*current-block = $remember-block;
285  
-        $register = self.unique-register;
286  
-        self.add-code: "$register = fetch-block '$block'";
287  
-        self.add-code: "call $register";
288  
-        self.add-code: "jmp $before-while";
289  
-        self.add-code: "`label $after-while";
290  
-    }
291  
-
292  
-    multi method sicify(Match $/, 'expression') {
293  
-        for <variable literal declaration assignment binding saycall
294  
-             increment decrement> -> $subrule {
295  
-            if $/{$subrule} -> $e {
296  
-                return self.sicify($e, $subrule);
297  
-            }
298  
-        }
299  
-    }
300  
-
301  
-    multi method sicify(Match $/, 'lvalue') {
302  
-        for <variable declaration increment decrement> -> $subrule {
303  
-            if $/{$subrule} -> $e {
304  
-                return self.sicify($e, $subrule);
305  
-            }
306  
-        }
307  
-    }
308  
-
309  
-    multi method sicify(Match $/, 'value') {
310  
-        for <variable literal declaration saycall increment decrement>
311  
-                -> $subrule {
312  
-            if $/{$subrule} -> $e {
313  
-                return self.sicify($e, $subrule);
314  
-            }
315  
-        }
316  
-    }
317  
-
318  
-    multi method sicify(Match $/, 'variable') {
319  
-        my $register = self.unique-register;
320  
-        my $variable = "'$/'";
321  
-        self.add-code: "$register = fetch $variable";
322  
-        return ($register, $variable);
323  
-    }
324  
-
325  
-    multi method sicify(Match $/, 'literal') {
326  
-        my $register = self.unique-register;
327  
-        my $literal = ~$/;
328  
-        self.add-code: "$register = $literal";
329  
-        return ($register, '<constant>');
330  
-    }
331  
-
332  
-    multi method sicify(Match $/, 'declaration') {
333  
-        return self.sicify($<variable>, 'variable');
334  
-    }
335  
-
336  
-    multi method sicify(Match $/, 'assignment') {
337  
-        my ($register, $) = self.sicify($<expression>, 'expression');
338  
-        my ($, $variable) = self.sicify($<lvalue>, 'lvalue');
339  
-        self.add-code: "store $variable, $register";
340  
-        return ($register, $variable);
341  
-    }
342  
-
343  
-    multi method sicify(Match $/, 'binding') {
344  
-        my ($register, $rightvar) = self.sicify($<expression>, 'expression');
345  
-        my ($, $leftvar) = self.sicify($<lvalue>, 'lvalue');
346  
-        if $rightvar ~~ / ^ \d+ $ / { # hm. this is brittle and suboptimal.
347  
-            $rightvar = $register;
348  
-        }
349  
-        self.add-code: "bind $leftvar, $rightvar";
350  
-        return ($register, $leftvar);
351  
-    }
352  
-
353  
-    multi method sicify(Match $/, 'saycall') {
354  
-        my ($register, $) = self.sicify($<expression>, 'expression');
355  
-        my $result = self.unique-register;
356  
-        self.add-code: "say $register";
357  
-        self.add-code: "$result = 1";
358  
-        return ($result, 1);
359  
-    }
360  
-
361  
-    multi method sicify(Match $/, 'increment') {
362  
-        my ($register, $variable) = self.sicify($<value>, 'value');
363  
-        die "Can't increment a constant"
364  
-            if $variable eq '<constant>';
365  
-        self.add-code: "inc $register";
366  
-        self.add-code: "store $variable, $register";
367  
-        return ($register, $variable);
368  
-    }
369  
-
370  
-    multi method sicify(Match $/, 'decrement') {
371  
-        my ($register, $variable) = self.sicify($<value>, 'value');
372  
-        die "Can't decrement a constant"
373  
-            if $variable eq '<constant>';
374  
-        self.add-code: "dec $register";
375  
-        self.add-code: "store $variable, $register";
376  
-        return ($register, $variable);
377  
-    }
378  
-
379  
-    multi method sicify(Match $/, 'block') {
380  
-        if $*current-block {
381  
-            $*current-block ~= '_' ~ @*block-counters[*-1]++;
382  
-            push @*block-counters, 1;
383  
-        }
384  
-        else {
385  
-            $*current-block = 'main';
386  
-            @*block-counters = 1;
387  
-        }
388  
-        @*block-order.push($*current-block);
389  
-        %*blocks{$*current-block} = [];
390  
-        for $<statementlist><statement> -> $statement {
391  
-            self.sicify($statement, 'statement');
392  
-        }
393  
-        pop @*block-counters;
394  
-        return $*current-block;
395  
-    }
396  
-
397  
-    multi method sicify(Match $/, $node) {
398  
-        die "Don't know what to do with a $node";
399  
-    }
400  
-
401 292
     sub declutter(@instructions) {
402 293
         my @decluttered;
403 294
         for @instructions.kv -> $i, $line {
404  
-            if $line !~~ / ^ ('$' \d+) ' =' / {
  295
+            # RAKUDO: !~~ doesn't bind $/
  296
+            if not $line ~~ / ^ ('$' \d+) ' =' / {
405 297
                 push @decluttered, $line;
406 298
             }
407 299
             else {
408 300
                 my $varname = ~$0;
409 301
                 my Bool $usages-later = False;
410  
-                for $i+1 ..^ @instructions -> $j {
  302
+                for $i+1 ..^ +@instructions -> $j {
  303
+                    # XXX: This heuristic fails when we reach many-digit
  304
+                    #      reguster names, since it gives false positives
  305
+                    #      for all prefixes
411 306
                     ++$usages-later
412 307
                         if defined index(@instructions[$j], $varname);
413 308
                 }
@@ -422,9 +317,11 @@ class Yapsi::Compiler {
422 317
     sub renumber(@instructions) {
423 318
         my $number = 0;
424 319
         my %mapping;
  320
+        # RAKUDO: $/ doesn't work in .subst closures
  321
+        my $hack;
425 322
         return @instructions.map: {
426  
-            .subst( :global, / ('$' \d+) /, {
427  
-                my $varname = ~$0;
  323
+            .subst( :global, / ('$' \d+) { $hack = ~$0 } /, {
  324
+                my $varname = $hack;
428 325
                 if !%mapping.exists($varname) {
429 326
                     %mapping{$varname} = '$' ~ $number++;
430 327
                 }
@@ -434,156 +331,153 @@ class Yapsi::Compiler {
434 331
     }
435 332
 }
436 333
 
  334
+class Value {
  335
+    has $.payload;
  336
+
  337
+    method store($v) { die "Can't assign to a readonly value" }
  338
+}
  339
+
  340
+class Container {
  341
+    has Value $!value;
  342
+
  343
+    method store(Value $v) { $!value = $v }
  344
+    method fetch() { $!value }
  345
+    method payload() { $!value.defined ?? $!value.payload !! "Any()" }
  346
+}
  347
+
  348
+class Lexpad {
  349
+    has @.slots;
  350
+    has %.names;
  351
+    has Lexpad $.outer;
  352
+
  353
+    method Str {
  354
+        "lexpad[" ~ %.names.sort(*.value)>>.key.join(", ") ~ "]";
  355
+    }
  356
+}
  357
+
  358
+class Closure {
  359
+    has $.block;
  360
+    has Lexpad $.outer;
  361
+}
  362
+
  363
+sub new-lexpad-from(@sic, $line is copy, Lexpad $outer?) {
  364
+    my @lexvars;
  365
+    while @sic[++$line] ~~ / '    `' (\S*) \s+ \'(<-[']>+)\' / {
  366
+        given $0 {
  367
+            when "lexvar" { push @lexvars, ~$1 }
  368
+            default { die "Unknown directive $0"; }
  369
+        }
  370
+    }
  371
+    return Lexpad.new(:slots(map { Container.new }, ^@lexvars),
  372
+                      :names((hash @lexvars.kv).invert),
  373
+                      :$outer);
  374
+}
  375
+
  376
+sub find-block(@sic, $name) {
  377
+    for @sic.kv -> $n, $line {
  378
+        return $n
  379
+            if $line ~~ / ^ 'block '\'(<-[']>+)\'':' $ / && $0 eq $name;
  380
+    }
  381
+    die "Didn't find block $name";
  382
+}
  383
+
  384
+sub find-label(@sic, $name) {
  385
+    for @sic.kv -> $n, $line {
  386
+        return $n
  387
+            if $line ~~ / ^ '    `label '(\S+) $ / && $0 eq $name;
  388
+    }
  389
+    die "Didn't find label $name";
  390
+}
  391
+
437 392
 subset Yapsi::IO where { .can('say') }
438 393
 
439 394
 class Yapsi::Runtime {
440 395
     has Yapsi::IO $!io = $*OUT;
441  
-    has Yapsi::Environment $.env;
442  
-
443  
-    has $!current-block;
444 396
 
445 397
     method run(@sic) {
446  
-        if @sic[0] !~~ /^ 'This is SIC v'(\d\d\d\d\.\d\d) $/ {
  398
+        # RAKUDO: Need to use 'not' here rather than '!~~' [perl #76892]
  399
+        if not @sic[0] ~~ /^ 'This is SIC v'(\d\d\d\d\.\d\d) $/ {
447 400
             die "Incompatible SIC version line";
448 401
         }
449 402
         elsif ~$0 ne $VERSION {
450 403
             die "SIC is $0 but this is $VERSION -- cannot run";
451 404
         }
452  
-        {
453  
-            $!env = Yapsi::Environment.new;
454  
-            my $line = 3;
455  
-            my $block;
456  
-            while @sic[$line++] -> $decl {
457  
-                if $decl ~~ /^ '    containers: ' (.+) $/ {
458  
-                    $!env.containers.push($_) for eval(~$0).list;
459  
-                }
460  
-                elsif $decl ~~ /^ '        ' (<-[:]>+) ': ' (.+) $/ {
461  
-                    $!env.pads{$block}{~$0} = eval(~$1);
462  
-                }
463  
-                elsif $decl ~~ /^ '    ' (<-[:]>+) ':' $/ {
464  
-                    $block = ~$0;
465  
-                    $!env.pads{$block} //= {};
466  
-                }
467  
-                else {
468  
-                    die "Unknown environment declaration `$decl`";
469  
-                }
470  
-            }
471  
-        }
472  
-        my @r;
473  
-        $!current-block = 'main';
474  
-        my $ip = find-block(@sic, $!current-block) + 1;
475  
-        my @stack;
476  
-        self.*tick;
477  
-        loop {
478  
-            if $ip >= @sic || @sic[$ip] eq '' {
479  
-                return unless @stack;
480  
-                $ip = pop @stack;
481  
-                $!current-block .= substr(0, -2);
482  
-                redo;
483  
-            }
484  
-            given @sic[$ip++].substr(4) {
485  
-                when /^ '$'(\d+) ' = ' (\d+) $/ {
486  
-                    @r[+$0] = +$1
487  
-                }
488  
-                when /^ 'store ' \'(<-[']>+)\' ', $'(\d+) $/ {
489  
-                    my $thing = locate-variable($!env.pads, $!current-block, ~$0);
490  
-                    if $thing<type> eq 'container' {
491  
-                        my $n = $thing<n>;
492  
-                        $!env.containers[$n] = @r[+$1];
  405
+
  406
+        my @registers-stack = [];
  407
+        my @ip-stack;
  408
+
  409
+        sub reg() { @registers-stack[@registers-stack - 1] }
  410
+        sub n-up-from($lexpad is copy, $levels) {
  411
+            $lexpad.=outer for ^$levels;
  412
+            die "Went too far and ended up nowhere"
  413
+                unless defined $lexpad;
  414
+            $lexpad;
  415
+        }
  416
+
  417
+        my $current-lexpad = new-lexpad-from(@sic, 2);
  418
+        my $ip = 3;
  419
+        while @registers-stack {
  420
+            while @sic[$ip++] -> $line {
  421
+                given $line.substr(4) {
  422
+                    when / ^ '`' / {}
  423
+                    when / ^ '$'(\d+) ' = ' (\d+) $ / { reg[+$0] = +$1 }
  424
+                    when / ^ 'store ['[(0)||'-'(\d+)]', '(\d+)'], $'(\d+) $ / {
  425
+                        my ($levels, $slot, $register) = +$0, +$1, +$2;
  426
+                        my $lexpad = n-up-from($current-lexpad, $levels);
  427
+                        $lexpad.slots[$slot].store(
  428
+                            Value.new( :payload(reg[$register]) )
  429
+                        );
493 430
                     }
494  
-                    else {
495  
-                        die "Cannot store something in readonly symbol ~$0";
  431
+                    when / ^ '$'(\d+)' = fetch ['[(0)||'-'(\d+)]', '(\d+)']' $ / {
  432
+                        my ($register, $levels, $slot) = +$0, +$1, +$2;
  433
+                        my $lexpad = n-up-from($current-lexpad, $levels);
  434
+                        reg[$register] = $lexpad.slots[$slot].payload();
496 435
                     }
497  
-                    self.*tick;
498  
-                }
499  
-                when /^ '$'(\d+) ' = fetch '\'(<-[']>+)\' $/ {
500  
-                    @r[+$0] = self.get-value-of(~$1);
501  
-                }
502  
-                when /^ 'bind ' \'(<-[']>+)\' ', ' \'(<-[']>+)\' $/ {
503  
-                    $!env.pads{$!current-block}{~$0} = $!env.pads{$!current-block}{~$1};
504  
-                    self.*tick;
505  
-                }
506  
-                when /^ 'bind ' \'(<-[']>+)\' ', $'(\d+) $/ {
507  
-                    $!env.pads{$!current-block}{~$0}
508  
-                        = { :type<immediate>, :value(+$1) };
509  
-                }
510  
-                when /^ 'say $'(\d+) $/ {
511  
-                    $!io.say: @r[+$0];
512  
-                    self.*tick;
513  
-                }
514  
-                when /^ 'inc $'(\d+) $/ {
515  
-                    if @r[+$0] eq 'Any()' {
516  
-                        @r[+$0] = 1;
  436
+                    when / ^ 'bind ['[(0)||'-'(\d+)]', '(\d+)'], '
  437
+                                  '['[(0)||'-'(\d+)]', '(\d+)']' $ / {
  438
+                        my ($var1-levels, $var1-slot) = +$0, +$1;
  439
+                        my $var1-lexpad = n-up-from($current-lexpad, $var1-levels);
  440
+                        my ($var2-levels, $var2-slot) = +$2, +$3;
  441
+                        my $var2-lexpad = n-up-from($current-lexpad, $var2-levels);
  442
+                        $var1-lexpad.slots[$var1-slot] = $var2-lexpad.slots[$var2-slot];
517 443
                     }
518  
-                    else {
519  
-                        ++@r[+$0];
  444
+                    when / ^ 'inc $'(\d+) $ / {
  445
+                        reg[+$0] = reg[+$0] eq 'Any()' ?? 1 !! reg[+$0] + 1;
520 446
                     }
521  
-                }
522  
-                when /^ 'dec $'(\d+) $/ {
523  
-                    if @r[+$0] eq 'Any()' {
524  
-                        @r[+$0] = -1;
  447
+                    when / ^ 'dec $'(\d+) $ / {
  448
+                        reg[+$0] = reg[+$0] eq 'Any()' ?? 1 !! reg[+$0] - 1;
525 449
                     }
526  
-                    else {
527  
-                        --@r[+$0];
  450
+                    when / ^ 'jf $'(\d+)', '(\S+) $ / {
  451
+                        if reg[+$0] == 0 {
  452
+                            $ip = find-label(@sic, ~$1);
  453
+                        }
528 454
                     }
529  
-                }
530  
-                when /^ '$'(\d+) ' = fetch-block '\'(<-[']>+)\' $/ {
531  
-                    @r[+$0] = ~$1;
532  
-                }
533  
-                when /^ 'call $'(\d+) $/ {
534  
-                    push @stack, $ip;
535  
-                    $ip = find-block(@sic, @r[+$0]) + 1;
536  
-                    $!current-block = @r[+$0];
537  
-                }
538  
-                when /^ 'jmp '(.*) $/ {
  455
+                    when / ^ 'jmp '(\S+) $ / {
539 456
                         $ip = find-label(@sic, ~$0);
540  
-                }
541  
-                when /^ 'jf $'(\d+)', '(.*) $/ {
542  
-                    if @r[+$0] == 0 {
543  
-                        $ip = find-label(@sic, ~$1);
544  
-                        # XXX: This could result in $!current-block no longer
545  
-                        #      being current, if the jump was to another block
  457
+                    }
  458
+                    when / ^ '$'(\d+)' = closure-from-block '\'(<-[']>+)\' $ / {
  459
+                        reg[+$0] = Closure.new(:block(~$1), :outer($current-lexpad));
  460
+                    }
  461
+                    when / ^ 'call $'(\d+) $ / {
  462
+                        die "Trying to call a non-closure"
  463
+                            if (my $closure = reg[+$0]) !~~ Closure;
  464
+                        push @registers-stack, [];
  465
+                        push @ip-stack, $ip;
  466
+                        $ip = find-block(@sic, $closure.block);
  467
+                        $current-lexpad = new-lexpad-from(@sic, $ip, $closure.outer);
  468
+                        ++$ip;
  469
+                    }
  470
+                    when / ^ 'say $'(\d+) $ / {
  471
+                        $!io.say(reg[+$0]);
  472
+                    }
  473
+                    default {
  474
+                        die "Unknown instruction: ", $_;
546 475
                     }
547 476
                 }
548  
-                when /^ '`' / {
549  
-                }
550  
-                default { die "Couldn't handle instruction `$_`" }
551  
-            }
552  
-        }
553  
-    }
554  
-
555  
-    sub find-block(@sic, Str $block-sought) {
556  
-        for ^@sic {
557  
-            if @sic[$_] ~~ /^'block ' \'(<-[']>+)\'/ && ~$0 eq $block-sought {
558  
-                return $_;
559  
-            }
560  
-        }
561  
-        die "Could not find block '$block-sought'";
562  
-    }
563  
-
564  
-    sub find-label(@sic, Str $label-sought) {
565  
-        for ^@sic {
566  
-            if @sic[$_] ~~ /^ \s+ '`label ' (.*)/ && ~$0 eq $label-sought {
567  
-                return $_;
568 477
             }
  478
+            pop @registers-stack;
  479
+            $ip = pop @ip-stack;
  480
+            $current-lexpad.=outer;
569 481
         }
570  
-        die "Could not find label '$label-sought'";
571  
-    }
572  
-
573  
-    sub locate-variable(%pads, $block is copy, Str $name) {
574  
-        loop {
575  
-            return %pads{$block}{$name}
576  
-                if %pads{$block}.exists($name);
577  
-            last unless $block ~~ / _\d+ $/;
578  
-            $block.=substr(0, $block.chars - $/.chars);
579  
-        }
580  
-        die "Runtime panic -- could not find variable $name";
581  
-    }
582  
-
583  
-    method get-value-of($variable) {
584  
-        my $thing = locate-variable($!env.pads, $!current-block, $variable);
585  
-        return $thing<type> eq 'container'
586  
-            ?? $!env.containers[$thing<n>]
587  
-            !! $thing<value>;
588 482
     }
589 483
 }
2  t/runtime.t
@@ -6,7 +6,7 @@ plan *;
6 6
 use Yapsi;
7 7
 
8 8
 my $out;
9  
-my $clear = method ($out:) { $out = '' }
  9
+my $clear = method ($out is rw:) { $out = '' }
10 10
 my $io-collector = class { method say($i) {$out ~= $i ~ "\n"} };
11 11
 
12 12
 my Yapsi::Compiler $compiler .= new;
11  yapsi
... ...
@@ -1,4 +1,4 @@
1  
-#!/usr/bin/env alpha
  1
+#!/usr/bin/env perl6
2 2
 use v6;
3 3
 
4 4
 use Yapsi;
@@ -34,10 +34,11 @@ else {
34 34
 }
35 35
 
36 36
 try {
37  
-    my Yapsi::Compiler $compiler .= new;
38  
-
39  
-    my @sic = $compiler.compile($program);
40  
-    warn $_ for $compiler.warnings;
  37
+    my @sic;
  38
+    given Yapsi::Compiler.new {
  39
+        @sic = .compile($program);
  40
+        warn $_ for .warnings;
  41
+    }
41 42
 
42 43
     if $target eq 'sic' {
43 44
         .say for @sic;

0 notes on commit 62ff73d

Please sign in to comment.
Something went wrong with that request. Please try again.