Skip to content

HTTPS clone URL

Subversion checkout URL

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