Skip to content

HTTPS clone URL

Subversion checkout URL

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