Skip to content
Newer
Older
100644 402 lines (367 sloc) 8.73 KB
99a7592 [STD et al.] rename .pm to .pm6 for all p6 modules in this dir
lwall authored
1 use YAML::XS;
2
8636e51 [viv] break out Actions.pm for use by others
lwall authored
3 package Actions;
4
5 # Generic ast translation done via autoload
6
7 our $AUTOLOAD;
8 my $SEQ = 1;
7af2d68 [viv] Store generated class information in compiled files
sorear authored
9 our %GENCLASS;
8636e51 [viv] break out Actions.pm for use by others
lwall authored
10
11 sub AUTOLOAD {
12 my $self = shift;
13 my $match = shift;
14 return if @_; # not interested in tagged reductions
15 return if $match->{_ast}{_specific} and ref($match->{_ast}) =~ /^VAST/;
16 print STDERR "AUTOLOAD $AUTOLOAD\n" if $OPT_log;
17 my $r = hoistast($match);
18 (my $class = $AUTOLOAD) =~ s/^Actions/VAST/;
19 $class =~ s/__S_\d\d\d/__S_/ and $r->{_specific} = 1;
20 if ($class =~ /::(infix|prefix|postfix|postcircumfix|dotty|regex_infix)__S_/) {
21 $r->{_op} = $class;
22 $class =~ s/::(infix|prefix|postfix|postcircumfix|dotty|regex_infix)__S_/::SYM_$1__S_/;
23 }
24 gen_class($class);
25 bless $r, $class unless ref($r) =~ /^VAST/;
26 $r->{MATCH} = $match if $OPT_match;
27 $match->{'_ast'} = $r;
28 }
29
30 # propagate ->{'_ast'} nodes upward
31 # (untransformed STD nodes in output indicate bugs)
32
33 sub hoistast {
34 my $node = shift;
35 my $text = $node->Str;
36 my %r;
37 my @all;
38 my @fake;
39 for my $k (keys %$node) {
40 print STDERR $node->{_reduced}, " $k\n" if $OPT_log;
41 my $v = $node->{$k};
42 if ($k eq 'O') {
43 for my $key (keys %$v) {
44 $r{$key} = $$v{$key};
45 }
46 }
47 elsif ($k eq 'PRE') {
48 }
49 elsif ($k eq 'POST') {
50 }
51 elsif ($k eq 'SIGIL') {
52 $r{SIGIL} = $v;
53 }
54 elsif ($k eq 'sym') {
55 if (ref $v) {
56 if (ref($v) eq 'ARRAY') {
57 $r{SYM} = $v;
58 }
59 elsif (ref($v) eq 'HASH') {
60 $r{SYM} = $v;
61 }
62 elsif ($v->{_pos}) {
63 $r{SYM} = $v->Str;
64 }
65 else {
66 $r{SYM} = $v->TEXT;
67 }
68 }
69 else {
70 $r{SYM} = $v;
71 }
72 }
73 elsif ($k eq '_arity') {
74 $r{ARITY} = $v;
75 }
76 elsif ($k eq '~CAPS') {
77 # print "CAPS ref ". ref($v) . "\n";
78 if (ref $v) {
79 for (@$v) {
80 next unless ref $_; # XXX skip keys?
81 push @all, $_->{'_ast'};
82 }
83 }
84 }
85 elsif ($k eq '_from') {
86 $r{BEG} = $v;
87 $r{END} = $node->{_pos};
88 if (exists $::MEMOS[$v]{'ws'}) {
89 my $wsstart = $::MEMOS[$v]{'ws'};
90 $r{WS} = $v - $wsstart if defined $wsstart and $wsstart < $v
91 }
92 }
93 elsif ($k =~ /^[a-zA-Z]/) {
94 if ($k eq 'noun') { # trim off PRE and POST
95 $r{BEG} = $v->{_from};
96 $r{END} = $v->{_pos};
97 }
98 if (ref($v) eq 'ARRAY') {
99 my $zyg = [];
100 for my $z (@$v) {
101 if (ref $z) {
102 if (ref($z) eq 'ARRAY') {
103 push @$zyg, $z;
104 push @fake, @$z;
105 }
106 elsif (exists $z->{'_ast'}) {
107 my $zy = $z->{'_ast'};
108 push @fake, $zy;
109 push @$zyg, $zy;
110 }
111 }
112 else {
113 push @$zyg, $z;
114 }
115 }
116 $r{$k} = $zyg;
117 # $r{zygs}{$k} = $SEQ++ if @$zyg and $k ne 'sym';
118 }
119 elsif (ref($v)) {
120 if (exists $v->{'_ast'}) {
121 push @fake, $v->{'_ast'};
122 $r{$k} = $v->{'_ast'};
123 }
124 elsif (exists $v->{'_from'}) {
125 $r{$k}{BEG} = $v->{'_from'};
126 $r{$k}{END} = $v->{'_pos'};
127 $r{$k}{TEXT} = $v->Str;
128 }
129 else {
130 # NAME or decl or sig or...
131 $r{$k} = $v;
132 next;
133 }
134 # $r{zygs}{$k} = $SEQ++;
135 unless (ref($r{$k}) =~ /^VAST/) {
136 my $class = "VAST::$k";
137 gen_class($class);
138 bless $r{$k}, $class unless ref($r{$k}) =~ /^VAST/;
139 }
140 }
141 else {
142 $r{$k} = $v;
143 }
144 }
145 }
146 if (@all == 1 and defined $all[0]) {
147 $r{'.'} = $all[0];
148 }
149 elsif (@all) {
150 $r{'.'} = \@all;
151 }
152 elsif (@fake) {
153 $r{'.'} = \@fake;
154 }
155 else {
156 $r{TEXT} = $text;
157 }
158 \%r;
159 }
160
161 sub hoist {
162 my $match = shift;
163
164 my %r;
165 my $v = $match->{O};
166 if ($v) {
167 for my $key (keys %$v) {
168 $r{$key} = $$v{$key};
169 }
170 }
171 if ($match->{sym}) {
172 # $r{sym} = $match->{sym};
173 }
174 if ($match->{ADV}) {
175 $r{ADV} = $match->{ADV};
176 }
177 \%r;
178 }
179
180 sub CHAIN {
181 my $self = shift;
182 my $match = shift;
183 my $r = hoistast($match);
184
185 my $class = 'VAST::Chaining';
186
187 gen_class($class);
188 $r = bless $r, $class;
189 $match->{'_ast'} = $r;
190 }
191
192 sub LIST {
193 my $self = shift;
194 my $match = shift;
195 my $r = hoist($match);
196
197 my @list = @{$match->{list}};
198 my @delims = @{$match->{delims}};
199 $r->{'args'} = [ map { $_->{_ast} } @list ];
200 my @all;
201 while (@delims) {
202 my $term = shift @list;
203 push @all, $term->{_ast};
204 my $infix = shift @delims;
205 push @all, $infix->{_ast};
206 }
207 push @all, $list[0]->{_ast} if @list;
208 pop @all while @all and not $all[-1]{END};
209 $r->{BEG} = $all[0]{BEG};
210 $r->{END} = $all[-1]{END} // $r->{BEG};
211 $r->{'infix'} = $all[-2]; # assume final one is most representative
212 $r->{'.'} = \@all;
213
214 my $base = ucfirst $match->{O}{dba} // $match->{sym} // 'termish';
215 $base =~ s/ /_/g;
216 $base =~ s/^/VAST::/;
217
218 my $class =
219 $match->{delims}[0]{_ast}{infix}{_op} //
220 $match->{delims}[0]{_ast}{regex_infix}{_op} //
221 warn ::Dump($match);
222 gen_class($class, $base);
223 $r = bless $r, $class;
224 $match->{'_ast'} = $r;
225 }
226
227 sub POSTFIX {
228 my $self = shift;
229 my $match = shift;
230 my $r = hoist($match);
231 my $arg = $match->{arg}->{_ast};
232 $r->{'arg'} = $arg;
233 $r->{postop} = $match->{postop}{_ast} if exists $match->{postop};
234 my $a = $r->{'.'} = [$arg,$match->{_ast}];
235 $r->{BEG} = $a->[0]->{BEG} // $match->{_from};
236 $r->{END} = $a->[-1]->{END} // $match->{_pos};
237
238 my $base = ucfirst $match->{O}{dba} // $match->{sym} // 'termish';
239 $base =~ s/ /_/g;
240 $base =~ s/^/VAST::/;
241
242 my $class;
243 if ($match->{fake}) {
244 $class = $base;
245 $base = '';
246 }
247 else {
248 $class =
249 $match->{_ast}{postop}{postfix}{_op} //
250 $match->{_ast}{postop}{postcircumfix}{_op} //
251 $match->{_ast}{dotty}{_op} //
252 warn ::Dump($match);
253 }
254
255 gen_class($class, $base);
256 $r = bless $r, $class;
257 $match->{'_ast'} = $r;
258 }
259
260 sub PREFIX {
261 my $self = shift;
262 my $match = shift;
263 my $r = hoist($match);
264 my $arg = $match->{arg}->{_ast};
265 $r->{'postop'} = $match->{postop}->{_ast} if exists $match->{postop};
266 $r->{'arg'} = $arg;
267 my $a = $r->{'.'} = [$match->{_ast},$arg];
268
269 $r->{BEG} = $a->[0]->{BEG} // $match->{_from};
270 $r->{END} = $a->[-1]->{END} // $match->{_pos};
271
272 my $base = ucfirst $match->{O}{dba} // $match->{sym} // 'termish';
273 $base =~ s/ /_/g;
274 $base =~ s/^/VAST::/;
275
276 my $class;
277 if ($match->{fake}) {
278 $class = $base;
279 $base = '';
280 }
281 else {
3974c7c [Actions] botched previous patch semantically
lwall authored
282 $class =
283 $match->{_ast}{prefix}{_op} //
284 $match->{_ast}{prefix_postfix_meta_operator}{_op} //
285 $match->{_ast}{prefix_circumfix_meta_operator}{_op} //
286 warn ::Dump($match);
8636e51 [viv] break out Actions.pm for use by others
lwall authored
287 }
288
289 gen_class($class,$base);
290 $r = bless $r, $class;
291 $match->{'_ast'} = $r;
292 }
293
294 sub INFIX {
295 my $self = shift;
296 my $match = shift;
297 my $r = hoist($match);
298 my $left = $match->{left}->{_ast};
299 my $right = $match->{right}->{_ast};
300 if ($match->{middle}) { # ternary
301 my $middle = $match->{middle}->{_ast};
302 $r->{'args'} = [$left,$middle,$right];
303 }
304 else {
305 $r->{'args'} = [$left,$right];
306 }
307 my $a = $r->{'.'} = [$left,$match->{_ast},$right];
308 $r->{BEG} = $a->[0]->{BEG} // $match->{_from};
309 $r->{END} = $a->[-1]->{END} // $match->{_pos};
310 $r->{'infix'} = $a->[1];
311
312 my $base = ucfirst $match->{O}{dba} // $match->{sym} // 'termish';
313 $base =~ s/ /_/g;
314 $base =~ s/^/VAST::/;
315
316 my $class;
317 if ($match->{fake}) {
318 $class = $base;
319 $base = '';
320 }
321 else {
322 $class =
323 $match->{_ast}{infix}{_op} //
324 $match->{_ast}{regex_infix}{_op} //
325 warn ::Dump($match);
326 }
327
328 gen_class($class, $base);
329 $r = bless $r, $class;
330 $match->{'_ast'} = $r;
331 }
332
333 sub nibbler {
334 my $self = shift;
335 my $match = shift;
336 my $r = hoist($match);
337 if ($match->{nibbles}) {
338 my @dot;
339 for my $n ( @{ $match->{nibbles} } ) {
340 if (ref $n eq 'Str') {
341 push @dot, bless($n,"VAST::Str");
342 }
343 elsif (ref $n eq 'VAST::Str') {
344 push @dot, $n;
345 }
346 elsif (ref $n eq 'ARRAY') {
347 push @dot, $n->[0]{_ast};
348 }
349 elsif ($n->{_ast}) {
350 push @dot, $n->{_ast};
351 }
352 elsif ($n->{EXPR}) {
353 push @dot, $n->{EXPR}->{_ast};
354 }
355 else {
356 warn "Oops", ::Dump($n);
357 exit;
358 }
359 }
360 my $a = $r->{'.'} = \@dot;
361 $r->{BEG} = $a->[0]->{BEG} // $match->{_from};
362 $r->{END} = $a->[-1]->{END} // $match->{_pos};
363 }
364 elsif ($match->{EXPR}) { # regex?
365 $r->{'.'} = $match->{EXPR}->{_ast};
366 $r->{BEG} = $r->{'.'}->{BEG} // $match->{_from};
367 $r->{END} = $r->{'.'}->{END} // $match->{_pos};
368 }
369
370 my $class = 'VAST::nibbler';
371 # print STDERR ::Dump($r);
372 gen_class($class);
373 $r = bless $r, $class;
374 $match->{'_ast'} = $r;
375 }
376
377 sub EXPR {
378 return;
379 }
380
381 sub termish {
382 my $self = shift;
383 my $match = shift;
384 $match->{'_ast'} = $match->{term}{'_ast'};
385 }
386
387 sub gen_class {
388 my $class = shift;
389 my $base = shift() // 'VAST::Base';
390 # say $class;
391 no strict 'refs';
392 if (@{$class . '::ISA'}) {
393 print STDERR "Existing class $class\n" if $OPT_log;
394 return;
395 }
7af2d68 [viv] Store generated class information in compiled files
sorear authored
396 $GENCLASS{$class} = $base;
8636e51 [viv] break out Actions.pm for use by others
lwall authored
397 print STDERR "Creating class $class\n" if $OPT_log;
398 @{$class . '::ISA'} = $base;
399 }
400
401 1;
Something went wrong with that request. Please try again.