« back to all changes in this revision
Viewing changes to src/Perl6/Actions.pm
- browse files at revision 6
- compare with another revision
- download diff
- download tarball
- view history from revision 6
- Committer: Bazaar Package Importer
- Author(s): Alessandro Ghedini
- Date: 2011-05-17 11:31:09 UTC
- mfrom: (1.1.2 upstream)
- Revision ID: james.westby@ubuntu.com-20110517113109-rmfir654u1axbpt4
Tags: 0.1~2011.04-1
* New upstream release (Closes: #601862, #585762, #577502)
* New maintainer
* Switch to 3.0 (quilt) format
* Update dependencies (Closes: #584498)
* Update debian/copyright to lastest DEP5 revision
* Do not generate/install perl6 manpage (now done by the build system)
* Enable tests
* Bump Standards-Version to 3.9.2 (no changes needed)
* Do not install extra LICENSE files and duplicated docs
* Remove debian/clean (no more needed)
* Add Vcs-* fields in debian/control
* Rewrite (short) description
* Update upstream copyright years
* Upload to unstable
* New maintainer
* Switch to 3.0 (quilt) format
* Update dependencies (Closes: #584498)
* Update debian/copyright to lastest DEP5 revision
* Do not generate/install perl6 manpage (now done by the build system)
* Enable tests
* Bump Standards-Version to 3.9.2 (no changes needed)
* Do not install extra LICENSE files and duplicated docs
* Remove debian/clean (no more needed)
* Add Vcs-* fields in debian/control
* Rewrite (short) description
* Update upstream copyright years
* Upload to unstable
- files added:
- VERSION
- build/lib
- build/lib/Parrot
- debian/source
- src/Perl6
- src/Perl6/Compiler
- src/Perl6/Module
- src/cheats
- src/cheats/parrot
- src/core
- src/core/IO
- src/core/IO/Socket
- src/gen
- src/glue
- src/metamodel
- t/02-embed
- files removed:
- build/gen_junction_pir.pl
- lib
- src/classes
- src/parrot
- src/parser
- src/setting
- src/setting/IO
- src/setting/IO/Socket
- files modified:
- .gitignore
added
removed
src/Perl6/Actions.pm
1
class Perl6::Actions is HLL::Actions;
2
3
our @BLOCK;
4
our @PACKAGE;
5
our $TRUE;
6
our @MAX_PERL_VERSION;
7
8
our $FORBID_PIR;
9
our $STATEMENT_PRINT;
10
11
INIT {
12
# initialize @BLOCK and @PACKAGE
13
our @BLOCK := Q:PIR { %r = root_new ['parrot';'ResizablePMCArray'] };
14
our @PACKAGE := Q:PIR { %r = root_new ['parrot';'ResizablePMCArray'] };
15
our $TRUE := PAST::Var.new( :name('true'), :scope('register') );
16
17
# Tell PAST::Var how to encode Perl6Str and Str values
18
my %valflags :=
19
Q:PIR { %r = get_hll_global ['PAST';'Compiler'], '%valflags' };
20
%valflags<Perl6Str> := 'e';
21
%valflags<Str> := 'e';
22
23
# If, e.g., we support Perl up to v6.1.2, set
24
# @MAX_PERL_VERSION to [6, 1, 2].
25
@MAX_PERL_VERSION[0] := 6;
26
27
$FORBID_PIR := 0;
28
$STATEMENT_PRINT := 0;
29
}
30
31
sub xblock_immediate($xblock) {
32
$xblock[1] := pblock_immediate($xblock[1]);
33
$xblock;
34
}
35
36
sub pblock_immediate($pblock) {
37
block_immediate($pblock);
38
}
39
40
sub block_immediate($block) {
41
$block.blocktype('immediate');
42
$block;
43
}
44
45
sub sigiltype($sigil) {
46
$sigil eq '%'
47
?? 'Hash'
48
!! ($sigil eq '@' ?? 'Array' !! 'Perl6Scalar');
49
}
50
51
method deflongname($/) {
52
make $<colonpair>
53
?? ~$<name> ~ ':<' ~ ~$<colonpair>[0]<circumfix><quote_EXPR><quote_delimited><quote_atom>[0] ~ '>'
54
!! ~$<name>;
55
}
56
57
# Turn $code into "for lines() { $code }"
58
sub wrap_option_n_code($code) {
59
return PAST::Op.new(:name<&eager>,
60
PAST::Op.new(:pasttype<callmethod>, :name<map>,
61
PAST::Op.new( :name<&flat>,
62
PAST::Op.new(:name<&flat>,
63
PAST::Op.new(
64
:name<&lines>,
65
:pasttype<call>
66
)
67
)
68
),
69
make_block_from(
70
Perl6::Compiler::Signature.new(
71
Perl6::Compiler::Parameter.new(
72
:var_name('$_'), :is_copy(1)
73
)
74
),
75
$code
76
)
77
)
78
);
79
}
80
81
# Turn $code into "for lines() { $code; say $_ }"
82
# &wrap_option_n_code already does the C<for> loop, so we just add the
83
# C<say> call here
84
sub wrap_option_p_code($code) {
85
return wrap_option_n_code(
86
PAST::Stmts.new(
87
$code,
88
PAST::Op.new(:name<&say>, :pasttype<call>,
89
PAST::Var.new(:name<$_>)
90
)
91
)
92
);
93
}
94
95
method comp_unit($/, $key?) {
96
our $?RAKUDO_HLL;
97
98
# Get the block for the unit mainline code.
99
my $unit := @BLOCK.shift;
100
my $mainline := $<statementlist>.ast;
101
102
if %*COMPILING<%?OPTIONS><p> { # also covers the -np case, like Perl 5
103
$mainline := wrap_option_p_code($mainline);
104
}
105
elsif %*COMPILING<%?OPTIONS><n> {
106
$mainline := wrap_option_n_code($mainline);
107
}
108
109
# Get the block for the entire compilation unit.
110
my $outer := @BLOCK.shift;
111
$outer.node($/);
112
$outer.hll($?RAKUDO_HLL);
113
114
# If it's the setting, just need to run the mainline.
115
if $*SETTING_MODE {
116
$unit.push($mainline);
117
$unit.hll($?RAKUDO_HLL);
118
$unit.pirflags(':init :load');
119
make $unit;
120
return 1;
121
}
122
123
# XXX To work around the role outers bug, we need to fix up the
124
# contexts marked for re-capture.
125
$mainline.unshift(PAST::Op.new(
126
:inline(' $P0 = get_hll_global "@!recapture"',
127
' recapture_loop:',
128
' unless $P0 goto recapture_loop_end',
129
' $P1 = shift $P0',
130
' fixup_outer_ctx $P1',
131
' goto recapture_loop',
132
' recapture_loop_end:',)
133
));
134
135
$unit.loadinit.unshift(
136
PAST::Op.new( :pasttype<inline>,
137
:inline(' $P0 = find_name "!UNIT_OUTER"',
138
' unless null $P0 goto have_perl6',
139
' load_language "perl6"',
140
' have_perl6:',
141
' "!UNIT_OUTER"(block)')
142
)
143
);
144
145
my $mainparam := PAST::Var.new(:name('$MAIN'), :scope('parameter'),
146
:viviself( PAST::Val.new( :value(0) ) ) );
147
$unit.symbol('$MAIN', :scope<lexical>);
148
# If the unit defines &MAIN, add a &MAIN_HELPER.
149
if $unit.symbol('&MAIN') {
150
$mainline :=
151
PAST::Op.new(
152
:pasttype('call'),
153
:name('&MAIN_HELPER'),
154
$mainline,
155
$mainparam
156
);
157
}
158
else {
159
$unit.push($mainparam);
160
}
161
$unit.push( self.CTXSAVE() );
162
$unit.push($mainline);
163
164
# Executing the compilation unit causes the mainline to be executed.
165
# We force a return here, because we have other :load/:init blocks
166
# that have to be done at the end of the unit, and we don't want them
167
# executed by the mainline.
168
$outer.push(
169
PAST::Op.new(
170
:pirop('return'),
171
PAST::Op.new( :pasttype<call>,
172
PAST::Var.new( :name('!UNIT_START'), :namespace(''), :scope('package') ),
173
$unit,
174
PAST::Var.new( :scope('parameter'), :name('@_'), :slurpy(1) )
175
)
176
)
177
);
178
179
# CHECK time occurs at the end of the compilation unit, :load/:init.
180
# (We can't # use the .loadinit property because that will generate
181
# the CHECK block too early.)
182
$outer.push(
183
PAST::Block.new(
184
:pirflags(':load :init'), :lexical(0), :namespace(''),
185
PAST::Op.new( :name('!fire_phasers'), 'CHECK' )
186
)
187
);
188
189
# If this unit is loaded via load_bytecode, we want it to automatically
190
# execute the mainline code above after all other initializations have
191
# occurred.
192
$outer.push(
193
PAST::Block.new(
194
:pirflags(':load'), :lexical(0), :namespace(''),
195
PAST::Op.new(
196
:name('!UNIT_START'), :pasttype('call'),
197
PAST::Val.new( :value($outer) ),
198
)
199
)
200
);
201
202
# Add file annotation.
203
my $file := pir::find_caller_lex__ps('$?FILES');
204
unless pir::isnull($file) {
205
$outer.unshift(PAST::Op.new(:inline(".annotate 'file', '" ~ $file ~ "'")));
206
}
207
208
# Remove the outer module package.
209
@PACKAGE.shift;
210
211
make $outer;
212
}
213
214
method unitstart($/) {
215
# Create a block for the compilation unit.
216
self.newpad($/);
217
# Use SET_BLOCK_OUTER_CTX (inherited from HLL::Actions)
218
# to set dynamic outer lexical context and namespace details
219
# for the compilation unit.
220
self.SET_BLOCK_OUTER_CTX(@BLOCK[0]);
221
222
self.newpad($/);
223
self.finishpad($/);
224
225
# set up initial package and $*UNITPAST
226
@PACKAGE.unshift(Perl6::Compiler::Module.new());
227
@PACKAGE[0].block(@BLOCK[0]);
228
$*UNITPAST := @BLOCK[0];
229
}
230
231
method statementlist($/) {
232
my $past := PAST::Stmts.new( :node($/) );
233
if $<statement> {
234
for $<statement> {
235
my $ast := $_.ast;
236
if $ast {
237
if $ast<bareblock> {
238
$ast := PAST::Op.new(
239
:pirop<setprop__0PsP>,
240
block_immediate($ast<block_past>),
241
'$!lazysig',
242
$ast[2]);
243
}
244
elsif $ast.isa(PAST::Block) && !$ast.blocktype {
245
$ast := block_immediate($ast);
246
}
247
$past.push( $ast );
248
}
249
}
250
}
251
$past.push(PAST::Var.new(:name('Nil'), :namespace([]), :scope('package'))) if +$past.list < 1;
252
make $past;
253
}
254
255
method semilist($/) {
256
my $past := PAST::Stmts.new( :node($/) );
257
if $<statement> {
258
for $<statement> { $past.push($_.ast); }
259
}
260
else {
261
$past.push( PAST::Op.new( :name('&infix:<,>') ) );
262
}
263
make $past;
264
}
265
266
method statement($/, $key?) {
267
my $past;
268
if $<EXPR> {
269
my $mc := $<statement_mod_cond>[0];
270
my $ml := $<statement_mod_loop>[0];
271
$past := $<EXPR>.ast;
272
if $mc {
273
$mc.ast.push($past);
274
$mc.ast.push(PAST::Var.new(:name('Nil'), :namespace([]), :scope('package')));
275
$past := $mc.ast;
276
}
277
if $ml {
278
my $cond := $ml<smexpr>.ast;
279
if ~$ml<sym> eq 'given' {
280
$past := PAST::Op.new(
281
:pasttype('call'),
282
PAST::Block.new(
283
:blocktype('declaration'),
284
PAST::Var.new( :name('$_'), :scope('parameter'), :isdecl(1) ),
285
$past
286
),
287
$cond
288
);
289
}
290
elsif ~$ml<sym> eq 'for' {
291
unless $past<block_past> {
292
my $sig := Perl6::Compiler::Signature.new(
293
Perl6::Compiler::Parameter.new(:var_name('$_')));
294
$past := block_closure(blockify($past, $sig), 'Block', 0);
295
}
296
$past := PAST::Op.new(
297
:pasttype<callmethod>, :name<map>, :node($/),
298
PAST::Op.new( :name<&flat>, $cond ),
299
$past
300
);
301
$past := PAST::Op.new( :name<&eager>, $past, :node($/) );
302
}
303
else {
304
$past := PAST::Op.new($cond, $past, :pasttype(~$ml<sym>), :node($/) );
305
}
306
}
307
}
308
elsif $<statement_control> { $past := $<statement_control>.ast; }
309
else { $past := 0; }
310
if $STATEMENT_PRINT && $past {
311
$past := PAST::Stmts.new(:node($/),
312
PAST::Op.new(
313
:pirop<say__vs>,
314
PAST::Val.new(:value(~$/))
315
),
316
$past
317
);
318
}
319
make $past;
320
}
321
322
method xblock($/) {
323
make PAST::Op.new( $<EXPR>.ast, $<pblock>.ast, :pasttype('if'), :node($/) );
324
}
325
326
method pblock($/) {
327
my $block := $<blockoid>.ast;
328
my $signature;
329
if pir::defined__IP($block<placeholder_sig>) && $<signature> {
330
$/.CURSOR.panic('Placeholder variable cannot override existing signature');
331
}
332
elsif pir::defined__IP($block<placeholder_sig>) {
333
$signature := $block<placeholder_sig>;
334
}
335
elsif $<signature> {
336
$signature := $<signature>.ast;
337
$block.blocktype('declaration');
338
}
339
else {
340
$signature := Perl6::Compiler::Signature.new();
341
unless $block.symbol('$_') {
342
if $*IMPLICIT {
343
$signature.add_parameter(Perl6::Compiler::Parameter.new(
344
:var_name('$_'), :optional(1),
345
:is_parcel(1), :default_from_outer(1)
346
));
347
}
348
else {
349
add_implicit_var($block, '$_', 1);
350
}
351
}
352
}
353
if $<lambda> eq '<->' {
354
$signature.set_rw_by_default();
355
}
356
add_signature($block, $signature);
357
# We ought to find a way to avoid this, but it seems necessary for now.
358
$block.loadinit.push(
359
PAST::Op.new( :pirop<setprop__vPsP>,
360
PAST::Val.new( :value($block) ),
361
'$!lazysig',
362
$block<lazysig> )
363
);
364
make $block;
365
}
366
367
method block($/) {
368
make $<blockoid>.ast;
369
}
370
371
method blockoid($/) {
372
my $past := $<statementlist>.ast;
373
my $BLOCK := @BLOCK.shift;
374
$BLOCK.push($past);
375
$BLOCK.node($/);
376
make $BLOCK;
377
}
378
379
method newpad($/) {
380
our @BLOCK;
381
our @PACKAGE;
382
my $new_block := PAST::Block.new( PAST::Stmts.new(
383
PAST::Op.new(
384
:inline(" .local pmc true\n true = get_hll_global 'True'")
385
),
386
PAST::Var.new(
387
:name('__CANDIDATE_LIST__'), :scope('lexical'), :isdecl(1)
388
)
389
));
390
$new_block<IN_DECL> := $*IN_DECL;
391
@BLOCK.unshift($new_block);
392
}
393
394
395
method finishpad($/) {
396
# Generate the $_, $/, and $! lexicals if they aren't already
397
# declared. For routines and methods, they're simply created as
398
# undefs; for other blocks they initialize to their outer lexical.
399
400
my $BLOCK := @BLOCK[0];
401
my $outer := $BLOCK<IN_DECL> ne 'routine' && $BLOCK<IN_DECL> ne 'method';
402
403
for <$_ $/ $!> {
404
# Generate the lexical variable except if...
405
# (1) the block already has one, or
406
# (2) the variable is '$_' and $*IMPLICIT is set
407
# (this case gets handled by getsig)
408
unless $BLOCK.symbol($_) || ($_ eq '$_' && $*IMPLICIT) {
409
add_implicit_var($BLOCK, $_, $outer);
410
}
411
}
412
}
413
414
415
## Statement control
416
417
method statement_control:sym<if>($/) {
418
my $count := +$<xblock> - 1;
419
my $past := xblock_immediate( $<xblock>[$count].ast );
420
# push the else block if any, otherwise 'if' returns C<Nil> (per S04)
421
$past.push( $<else>
422
?? pblock_immediate( $<else>[0].ast )
423
!! PAST::Var.new(:name('Nil'), :namespace([]), :scope('package'))
424
);
425
# build if/then/elsif structure
426
while $count > 0 {
427
$count--;
428
my $else := $past;
429
$past := xblock_immediate( $<xblock>[$count].ast );
430
$past.push($else);
431
}
432
make $past;
433
}
434
435
method statement_control:sym<unless>($/) {
436
my $past := xblock_immediate( $<xblock>.ast );
437
$past.pasttype('unless');
438
make $past;
439
}
440
441
method statement_control:sym<while>($/) {
442
my $past := xblock_immediate( $<xblock>.ast );
443
$past.pasttype(~$<sym>);
444
make $past;
445
}
446
447
method statement_control:sym<repeat>($/) {
448
my $pasttype := 'repeat_' ~ ~$<wu>;
449
my $past;
450
if $<xblock> {
451
$past := xblock_immediate( $<xblock>.ast );
452
$past.pasttype($pasttype);
453
}
454
else {
455
$past := PAST::Op.new( $<EXPR>.ast, pblock_immediate( $<pblock>.ast ),
456
:pasttype($pasttype), :node($/) );
457
}
458
make $past;
459
}
460
461
method statement_control:sym<for>($/) {
462
my $xblock := $<xblock>.ast;
463
my $past := PAST::Op.new(
464
:pasttype<callmethod>, :name<map>, :node($/),
465
PAST::Op.new( :name<&flat>, $xblock[0] ),
466
block_closure($xblock[1], 'Block', 0)
467
);
468
$past := PAST::Op.new( :name<&eager>, $past, :node($/) );
469
make $past;
470
}
471
472
method statement_control:sym<loop>($/) {
473
my $block := block_immediate($<block>.ast);
474
my $cond := $<e2> ?? $<e2>[0].ast !! 1;
475
my $loop := PAST::Op.new( $cond, $block, :pasttype('while'), :node($/) );
476
if $<e3> {
477
$loop.push( $<e3>[0].ast );
478
}
479
if $<e1> {
480
$loop := PAST::Stmts.new( $<e1>[0].ast, $loop, :node($/) );
481
}
482
make $loop;
483
}
484
485
method statement_control:sym<need>($/) {
486
my $past := PAST::Stmts.new( :node($/) );
487
for $<module_name> {
488
need($_);
489
}
490
make $past;
491
}
492
493
sub need($module_name) {
494
# Build up adverbs hash if we have them. Note that we need a hash
495
# for now (the compile time call) and an AST that builds said hash
496
# for the runtime call once we've compiled the module.
497
my $name := $module_name<longname><name>.Str;
498
my %adverbs;
499
my $adverbs_ast := PAST::Op.new(
500
:name('&circumfix:<{ }>'), PAST::Op.new( :name('&infix:<,>') )
501
);
502
if $module_name<longname><colonpair> {
503
for $module_name<longname><colonpair> {
504
my $ast := $_.ast;
505
$adverbs_ast[0].push($ast);
506
%adverbs{$ast[1].value()} := $ast[2].value();
507
}
508
}
509
510
# Need to immediately load module and get lexicals stubbed in.
511
Perl6::Module::Loader.need($name, %adverbs);
512
513
# Also need code to do the actual loading emitting (though need
514
# won't repeat its work if already carried out; we mainly need
515
# this for pre-compilation to PIR to work).
516
my @ns := pir::split__PSS('::', 'Perl6::Module');
517
@BLOCK[0].loadinit.push(
518
PAST::Op.new( :pasttype('callmethod'), :name('need'),
519
PAST::Var.new( :name('Loader'), :namespace(@ns), :scope('package') ),
520
$name,
521
PAST::Op.new( :pirop('getattribute PPS'), $adverbs_ast, '$!storage' )
522
));
523
}
524
525
method statement_control:sym<import>($/) {
526
my $past := PAST::Stmts.new( :node($/) );
527
import($/);
528
make $past;
529
}
530
531
sub import($/) {
532
my $name := $<module_name><longname><name>.Str;
533
Perl6::Module::Loader.stub_lexical_imports($name, @BLOCK[0]);
534
my @ns := pir::split__PSS('::', 'Perl6::Module');
535
@BLOCK[0].push(
536
PAST::Op.new( :pasttype('callmethod'), :name('import'),
537
PAST::Var.new( :name('Loader'), :namespace(@ns), :scope('package') ),
538
$name
539
));
540
}
541
542
method statement_control:sym<use>($/) {
543
my $past := PAST::Stmts.new( :node($/) );
544
if $<version> {
545
my $i := -1;
546
for $<version><vnum> {
547
++$i;
548
if $_ ne '*' && $_ < @MAX_PERL_VERSION[$i] {
549
last;
550
} elsif $_ > @MAX_PERL_VERSION[$i] {
551
my $mpv := pir::join('.', @MAX_PERL_VERSION);
552
$/.CURSOR.panic("Perl $<version> required--this is only v$mpv")
553
}
554
}
555
} elsif $<module_name> {
556
if ~$<module_name> eq 'fatal' {
557
declare_variable($/, PAST::Stmts.new(), '$', '*', 'FATAL', 0);
558
$past := PAST::Op.new(
559
:name('&infix:<=>'),
560
:node($/),
561
PAST::Op.new(
562
:name('!find_contextual'),
563
:pasttype('call'),
564
:lvalue(0),
565
'$*FATAL',
566
),
567
PAST::Var.new(
568
:name('True'),
569
:namespace(['Bool']),
570
:scope('package'),
571
),
572
);
573
}
574
elsif ~$<module_name> eq 'MONKEY_TYPING' {
575
$*MONKEY_TYPING := 1;
576
}
577
elsif ~$<module_name> eq 'SETTING_MODE' {
578
$*SETTING_MODE := 1;
579
}
580
elsif ~$<module_name> eq 'FORBID_PIR' {
581
$FORBID_PIR := 1;
582
}
583
elsif ~$<module_name> eq 'Devel::Trace' {
584
$STATEMENT_PRINT := 1;
585
}
586
else {
587
need($<module_name>);
588
import($/);
589
}
590
}
591
make $past;
592
}
593
594
method statement_control:sym<require>($/) {
595
if $<module_name> && $<EXPR> {
596
$/.CURSOR.panic("require with argument list not yet implemented");
597
}
598
my $name_past := $<module_name>
599
?? PAST::Val.new(:value($<module_name><longname><name>.Str))
600
!! $<EXPR>[0].ast;
601
my @module_loader := Perl6::Grammar::parse_name('Perl6::Module::Loader');
602
my $past := PAST::Op.new(
603
:node($/),
604
:pasttype('callmethod'),
605
:name('need'),
606
PAST::Var.new( :name(@module_loader.pop),
607
:namespace(@module_loader), :scope('package') ),
608
$name_past
609
);
610
make $past;
611
}
612
613
method statement_control:sym<given>($/) {
614
my $past := $<xblock>.ast;
615
$past.push($past.shift); # swap [0] and [1] elements
616
$past.pasttype('call');
617
make $past;
618
}
619
620
method statement_control:sym<when>($/) {
621
# Get hold of the smartmatch expression and the block.
622
my $xblock := $<xblock>.ast;
623
my $sm_exp := $xblock.shift;
624
my $pblock := $xblock.shift;
625
626
# Add exception handler to the block so we fall out of the enclosing block
627
# after it's executed.
628
$pblock := pblock_immediate($pblock);
629
when_handler_helper($pblock);
630
631
# Handle the smart-match. XXX Need to handle syntactic cases too.
632
my $match_past := PAST::Op.new( :pasttype('call'), :name('&infix:<~~>'),
633
PAST::Var.new( :name('$_'), :scope('lexical') ),
634
$sm_exp
635
);
636
637
# Use the smartmatch result as the condition for running the block.
638
make PAST::Op.new( :pasttype('if'), :node( $/ ),
639
$match_past, $pblock,
640
);
641
}
642
643
method statement_control:sym<default>($/) {
644
# We always execute this, so just need the block, however we also
645
# want to make sure we break after running it.
646
my $block := block_immediate($<block>.ast);
647
when_handler_helper($block);
648
make $block;
649
}
650
651
method statement_control:sym<CATCH>($/) {
652
my $block := $<block>.ast;
653
push_block_handler($/, @BLOCK[0], $block);
654
@BLOCK[0].handlers()[0].handle_types_except('CONTROL');
655
make PAST::Stmts.new(:node($/));
656
}
657
658
method statement_control:sym<CONTROL>($/) {
659
my $block := $<block>.ast;
660
push_block_handler($/, @BLOCK[0], $block);
661
@BLOCK[0].handlers()[0].handle_types('CONTROL');
662
make PAST::Stmts.new(:node($/));
663
}
664
665
method statement_prefix:sym<BEGIN>($/) { self.add_phaser($/, $<blorst>.ast, 'BEGIN'); }
666
method statement_prefix:sym<CHECK>($/) { self.add_phaser($/, $<blorst>.ast, 'CHECK'); }
667
method statement_prefix:sym<INIT>($/) { self.add_phaser($/, $<blorst>.ast, 'INIT'); }
668
method statement_prefix:sym<END>($/) { self.add_phaser($/, $<blorst>.ast, 'END'); }
669
670
method statement_prefix:sym<do>($/) {
671
my $past := $<blorst>.ast;
672
$past.blocktype('immediate');
673
make $past;
674
}
675
676
method statement_prefix:sym<gather>($/) {
677
my $past := block_closure($<blorst>.ast);
678
make PAST::Op.new( :pasttype('call'), :name('!GATHER'), $past );
679
}
680
681
method statement_prefix:sym<sink>($/) {
682
my $blast := $<blorst>.ast;
683
$blast.blocktype('immediate');
684
make PAST::Stmts.new(
685
PAST::Op.new( :name('&eager'), $blast ),
686
PAST::Var.new( :name('Nil'), :namespace([]), :scope('package')),
687
:node($/)
688
);
689
}
690
691
method statement_prefix:sym<try>($/) {
692
my $block := $<blorst>.ast;
693
$block.blocktype('immediate');
694
my $past := PAST::Op.new( :pasttype('try'), $block );
695
696
# On failure, capture the exception object into $!.
697
$past.push(PAST::Op.new(
698
:inline( ' .get_results (%r)',
699
' $P0 = new ["Perl6Exception"]',
700
' setattribute $P0, "$!exception", %r',
701
' store_lex "$!", $P0' )
702
));
703
704
# Otherwise, put a failure into $!.
705
$past.push(PAST::Op.new( :pasttype('bind'),
706
PAST::Var.new( :name('$!'), :scope('lexical') ),
707
PAST::Op.new( :pasttype('call'), :name('!FAIL') )
708
));
709
710
make $past;
711
}
712
713
method blorst($/) {
714
my $block := $<block>
715
?? $<block>.ast
716
!! PAST::Block.new( $<statement>.ast, :node($/) );
717
$block.blocktype('declaration');
718
make $block;
719
}
720
721
method add_phaser($/, $blorst, $bank) {
722
my $subid := $blorst.subid();
723
724
# We always emit code to the add and fire the phaser.
725
my $add_phaser := PAST::Op.new(
726
:pasttype('call'), :name('!add_phaser'),
727
$bank, PAST::Val.new( :value($blorst) ), :node($/)
728
);
729
@BLOCK[0].loadinit.push($add_phaser);
730
@BLOCK[0][0].push($blorst);
731
732
# If it's a BEGIN phaser, we also need it to run asap.
733
if $bank eq 'BEGIN' {
734
# add code to immediately fire the BEGIN phaser
735
my $fire := PAST::Op.new( :pasttype('call'), :name('!fire_phasers'), 'BEGIN' );
736
@BLOCK[0].loadinit.push($fire);
737
738
# and execute the phaser immediately in the current UNIT_OUTER
739
our $?RAKUDO_HLL;
740
$blorst.hll($?RAKUDO_HLL);
741
my $compiled := PAST::Compiler.compile($blorst);
742
Q:PIR {
743
$P0 = find_lex '$compiled'
744
$P0 = $P0[0]
745
'!UNIT_OUTER'($P0)
746
'!add_phaser'('BEGIN', $P0)
747
'!fire_phasers'('BEGIN')
748
}
749
}
750
751
# Need to get return value of phaser at "runtime".
752
make PAST::Op.new( :pasttype('call'), :name('!get_phaser_result'), $subid );
753
}
754
755
# Statement modifiers
756
757
method modifier_expr($/) { make $<EXPR>.ast; }
758
759
method statement_mod_cond:sym<if>($/) {
760
make PAST::Op.new( :pasttype<if>, $<modifier_expr>.ast, :node($/) );
761
}
762
763
method statement_mod_cond:sym<unless>($/) {
764
make PAST::Op.new( :pasttype<unless>, $<modifier_expr>.ast, :node($/) );
765
}
766
767
method statement_mod_cond:sym<when>($/) {
768
make PAST::Op.new( :pasttype<if>,
769
PAST::Op.new( :name('&infix:<~~>'),
770
PAST::Var.new( :name('$_') ),
771
$<modifier_expr>.ast ),
772
:node($/)
773
);
774
}
775
776
method statement_mod_loop:sym<while>($/) { make $<smexpr>.ast; }
777
method statement_mod_loop:sym<until>($/) { make $<smexpr>.ast; }
778
method statement_mod_loop:sym<for>($/) { make $<smexpr>.ast; }
779
method statement_mod_loop:sym<given>($/) { make $<smexpr>.ast; }
780
781
## Terms
782
783
method term:sym<fatarrow>($/) { make $<fatarrow>.ast; }
784
method term:sym<colonpair>($/) { make $<colonpair>.ast; }
785
method term:sym<variable>($/) { make $<variable>.ast; }
786
method term:sym<package_declarator>($/) { make $<package_declarator>.ast; }
787
method term:sym<scope_declarator>($/) { make $<scope_declarator>.ast; }
788
method term:sym<routine_declarator>($/) { make $<routine_declarator>.ast; }
789
method term:sym<multi_declarator>($/) { make $<multi_declarator>.ast; }
790
method term:sym<regex_declarator>($/) { make $<regex_declarator>.ast; }
791
method term:sym<type_declarator>($/) { make $<type_declarator>.ast; }
792
method term:sym<circumfix>($/) { make $<circumfix>.ast; }
793
method term:sym<statement_prefix>($/) { make $<statement_prefix>.ast; }
794
method term:sym<lambda>($/) { make block_closure($<pblock>.ast, 'Block', 0); }
795
method term:sym<sigterm>($/) { make $<sigterm>.ast; }
796
797
method term:sym<YOU_ARE_HERE>($/) {
798
my $past := PAST::Block.new(
799
:name('!YOU_ARE_HERE'),
800
PAST::Op.new(
801
:inline(
802
'$P0 = getinterp',
803
'$P0 = $P0["context"]',
804
'$P0 = getattribute $P0, "outer_ctx"',
805
'$P1 = getattribute $P0, "current_sub"',
806
'%0."set_outer"($P1)',
807
'%0."set_outer_ctx"($P0)',
808
'%r = %0'
809
),
810
PAST::Var.new( :name('mainline'), :scope('parameter') )
811
)
812
);
813
@BLOCK[0][0].push(PAST::Var.new(
814
:name('!YOU_ARE_HERE'), :isdecl(1), :viviself($past), :scope('lexical')
815
));
816
make PAST::Op.new( :pasttype('call'),
817
PAST::Var.new( :name('!YOU_ARE_HERE'), :scope('lexical') ),
818
PAST::Block.new( )
819
);
820
}
821
822
method name($/) { }
823
824
method module_name($/) {
825
my @name := Perl6::Grammar::parse_name(~$<longname>);
826
my $var := PAST::Var.new(
827
:name(@name.pop),
828
:namespace(@name),
829
:scope(is_lexical(~$<longname>) ?? 'lexical' !! 'package')
830
);
831
if $<arglist> {
832
my $past := $<arglist>[0].ast;
833
$past.pasttype('callmethod');
834
$past.name('!select');
835
$past.unshift($var);
836
make $past;
837
}
838
else {
839
make $var;
840
}
841
}
842
843
method fatarrow($/) {
844
make make_pair($<key>.Str, $<val>.ast);
845
}
846
847
method colonpair($/) {
848
if $*key {
849
if $<var> {
850
make make_pair($*key, make_variable($/<var>, ~$<var>));
851
}
852
elsif $*value ~~ Regex::Match {
853
make make_pair($*key, $*value.ast);
854
}
855
elsif $*value == 0 {
856
make make_pair($*key, PAST::Var.new( :name('False'), :namespace('Bool'), :scope('package') ));
857
}
858
else {
859
make make_pair($*key, PAST::Var.new( :name('True'), :namespace('Bool'), :scope('package') ));
860
}
861
}
862
elsif $<fakesignature> {
863
make $<fakesignature>.ast.ast; # XXX: Huh?
864
}
865
else {
866
make $*value.ast;
867
}
868
}
869
870
sub make_pair($key, $value) {
871
my @name := Perl6::Grammar::parse_name('Pair');
872
$value.named('value');
873
PAST::Op.new(
874
:pasttype('callmethod'),
875
:returns('Pair'),
876
:name('new'),
877
PAST::Var.new( :name(@name.pop), :namespace(@name), :scope('package') ),
878
PAST::Val.new( :value($key), :named('key') ),
879
$value
880
)
881
}
882
883
method variable($/) {
884
my $past;
885
if $<index> {
886
$past := PAST::Op.new(
887
:name('!postcircumfix:<[ ]>'),
888
PAST::Var.new( :name('$/') ),
889
+$<index>
890
);
891
}
892
elsif $<postcircumfix> {
893
$past := $<postcircumfix>.ast;
894
$past.unshift( PAST::Var.new( :name('$/') ) );
895
}
896
elsif $<infixish> {
897
$past := PAST::Op.new( :pirop('find_sub_not_null__Ps'), '&infix:<' ~ $<infixish>.Str ~ '>' );
898
}
899
else {
900
$past := make_variable($/, ~$/);
901
}
902
make $past;
903
}
904
905
sub make_variable($/, $name) {
906
my @name := Perl6::Grammar::parse_name($name);
907
my $past := PAST::Var.new( :name(@name.pop), :node($/));
908
if @name {
909
$past.namespace(@name);
910
$past.scope('package');
911
}
912
if $<twigil>[0] eq '*' {
913
$past := PAST::Op.new( $past.name(), :pasttype('call'), :name('!find_contextual'), :lvalue(0) );
914
}
915
elsif $<twigil>[0] eq '!' {
916
$past.scope('attribute');
917
$past.viviself( sigiltype( $<sigil> ) );
918
$past.unshift(PAST::Var.new( :name('self'), :scope('lexical') ));
919
}
920
elsif $<twigil>[0] eq '.' && $*IN_DECL ne 'variable' {
921
# Need to transform this to a method call.
922
$past := $<arglist> ?? $<arglist>[0].ast !! PAST::Op.new();
923
$past.pasttype('callmethod');
924
$past.name(~$<desigilname>);
925
$past.unshift(PAST::Var.new( :name('self'), :scope('lexical') ));
926
}
927
elsif $<twigil>[0] eq '^' || $<twigil>[0] eq ':' {
928
$past := add_placeholder_parameter($<sigil>.Str, $<desigilname>.Str, :named($<twigil>[0] eq ':'));
929
}
930
elsif ~$/ eq '@_' {
931
unless get_nearest_signature().declares_symbol('@_') {
932
$past := add_placeholder_parameter('@', '_', :slurpy_pos(1));
933
}
934
}
935
elsif ~$/ eq '%_' {
936
unless get_nearest_signature().declares_symbol('%_') {
937
$past := add_placeholder_parameter('%', '_', :slurpy_named(1));
938
}
939
}
940
else {
941
my $attr_alias := is_attr_alias($past.name);
942
if $attr_alias {
943
$past.name($attr_alias);
944
$past.scope('attribute');
945
$past.viviself( sigiltype( $<sigil> ) );
946
$past.unshift(PAST::Var.new( :name('self'), :scope('lexical') ));
947
}
948
elsif $<sigil> eq '&' {
949
if !@name {
950
$past := PAST::Op.new(:pirop('find_sub_not_null__Ps'), $past.name);
951
}
952
else {
953
$past.viviself(PAST::Var.new(
954
:namespace(''), :name('Code'), :scope('package')
955
));
956
}
957
}
958
}
959
$past
960
}
961
962
method package_declarator:sym<package>($/) { make $<package_def>.ast; }
963
method package_declarator:sym<module>($/) { make $<package_def>.ast; }
964
method package_declarator:sym<class>($/) { make $<package_def>.ast; }
965
method package_declarator:sym<grammar>($/) { make $<package_def>.ast; }
966
method package_declarator:sym<role>($/) { make $<package_def>.ast; }
967
968
method package_declarator:sym<does>($/) {
969
our @PACKAGE;
970
@PACKAGE[0].traits.push(PAST::Op.new(
971
:pasttype('call'),
972
:name('&trait_mod:<does>'),
973
$<typename>.ast
974
));
975
make PAST::Stmts.new();
976
}
977
978
method package_def($/, $key?) {
979
our @PACKAGE;
980
981
# Is this the opening of a new package?
982
if $key eq 'open' {
983
# Create the right kind of package compiler.
984
my $pkg_compiler := %*PKGCOMPILER{$*PKGDECL};
985
if pir::isa__IPS($pkg_compiler, 'Undef') { $pkg_compiler := Perl6::Compiler::Package; }
986
my $package := $pkg_compiler.new();
987
988
# Set HOW and other details.
989
my $how := %*HOW{$*PKGDECL};
990
unless $how { $/.CURSOR.panic("No HOW declared for package declarator $*PKGDECL"); }
991
$package.how($how);
992
$*SCOPE := $*SCOPE || 'our';
993
$package.scope($*SCOPE);
994
if $<def_module_name> {
995
my $name := ~$<def_module_name>[0]<longname><name>;
996
if $name ne '::' {
997
if $*SCOPE ne 'anon' {
998
$/.CURSOR.add_name($name, 1);
999
}
1000
$package.name($name);
1001
}
1002
if $<def_module_name>[0]<signature> {
1003
$package.signature($<def_module_name>[0]<signature>[0].ast);
1004
$package.signature_text(~$<def_module_name>[0]<signature>[0]);
1005
}
1006
if $<def_module_name>[0]<longname><colonpair> {
1007
for $<def_module_name>[0]<longname><colonpair> {
1008
$package.name_adverbs.push($_.ast);
1009
}
1010
}
1011
}
1012
1013
# Add traits.
1014
for $<trait> {
1015
$package.traits.push($_.ast);
1016
}
1017
1018
# Claim currently open block as the package's block.
1019
$package.block(@BLOCK[0]);
1020
1021
# Put on front of packages list. Note - nesting a package in a role is
1022
# not supported (gets really tricky in the parametric case - needs more
1023
# thought and consideration).
1024
if +@PACKAGE && pir::isa__IPS(@PACKAGE[0], 'Role') {
1025
$/.CURSOR.panic("Cannot nest a package inside a role");
1026
}
1027
@PACKAGE.unshift($package);
1028
}
1029
else {
1030
# We just need to finish up the current package.
1031
my $package := @PACKAGE.shift;
1032
if pir::substr__SSII($<blockoid><statementlist><statement>[0], 0, 3) eq '...' {
1033
# Just a stub, so don't do any more work.
1034
if $*SCOPE eq 'our' || $*SCOPE eq '' {
1035
%Perl6::Grammar::STUBCOMPILINGPACKAGES{~$<def_module_name>[0]<longname>} := 1;
1036
}
1037
@BLOCK[0].symbol(~$<def_module_name>[0]<longname>, :stub(1));
1038
make PAST::Stmts.new( );
1039
}
1040
else {
1041
my $block;
1042
if $<blockoid> {
1043
$block := $<blockoid>.ast;
1044
}
1045
else {
1046
$block := @BLOCK.shift;
1047
$block.push($<statementlist>.ast);
1048
$block.node($/);
1049
}
1050
make $package.finish($block);
1051
}
1052
}
1053
}
1054
1055
method scope_declarator:sym<my>($/) { make $<scoped>.ast; }
1056
method scope_declarator:sym<our>($/) { make $<scoped>.ast; }
1057
method scope_declarator:sym<has>($/) { make $<scoped>.ast; }
1058
method scope_declarator:sym<anon>($/) { make $<scoped>.ast; }
1059
method scope_declarator:sym<augment>($/) { make $<scoped>.ast; }
1060
1061
method declarator($/) {
1062
if $<variable_declarator> { make $<variable_declarator>.ast }
1063
elsif $<routine_declarator> { make $<routine_declarator>.ast }
1064
elsif $<regex_declarator> { make $<regex_declarator>.ast }
1065
elsif $<signature> {
1066
my $list := PAST::Op.new( :pasttype('call'), :name('&infix:<,>') );
1067
my $decls := $<signature>.ast.get_declarations;
1068
for @($decls) {
1069
if $_.isa(PAST::Var) {
1070
my $decl := declare_variable($/, $_, $_<sigil>, $_<twigil>, $_<desigilname>, $_<traits>);
1071
unless $decl.isa(PAST::Op) && $decl.pasttype() eq 'null' {
1072
$list.push($decl);
1073
}
1074
}
1075
else {
1076
$list.push($_);
1077
}
1078
}
1079
$list<signature_from_declarator> := $<signature>.ast;
1080
make $list;
1081
}
1082
else {
1083
$/.CURSOR.panic('Unknown declarator type');
1084
}
1085
}
1086
1087
method multi_declarator:sym<multi>($/) { make $<declarator> ?? $<declarator>.ast !! $<routine_def>.ast }
1088
method multi_declarator:sym<proto>($/) { make $<declarator> ?? $<declarator>.ast !! $<routine_def>.ast }
1089
method multi_declarator:sym<only>($/) { make $<declarator> ?? $<declarator>.ast !! $<routine_def>.ast }
1090
method multi_declarator:sym<null>($/) { make $<declarator>.ast }
1091
1092
method scoped($/) {
1093
make $<DECL>.ast;
1094
}
1095
1096
method variable_declarator($/) {
1097
my $past := $<variable>.ast;
1098
my $sigil := $<variable><sigil>;
1099
my $twigil := $<variable><twigil>[0];
1100
my $name := ~$sigil ~ ~$twigil ~ ~$<variable><desigilname>;
1101
if @BLOCK[0].symbol($name) {
1102
$/.CURSOR.panic("Redeclaration of symbol ", $name);
1103
}
1104
make declare_variable($/, $past, ~$sigil, ~$twigil, ~$<variable><desigilname>, $<trait>);
1105
}
1106
1107
sub declare_variable($/, $past, $sigil, $twigil, $desigilname, $trait_list) {
1108
my $name := $sigil ~ $twigil ~ $desigilname;
1109
my $BLOCK := @BLOCK[0];
1110
1111
if $*SCOPE eq 'has' {
1112
# Find the current package and add the attribute.
1113
my $attrname := ~$sigil ~ '!' ~ $desigilname;
1114
our @PACKAGE;
1115
unless +@PACKAGE {
1116
$/.CURSOR.panic("Cannot declare an attribute outside of a package");
1117
}
1118
if @PACKAGE[0].has_attribute($attrname) {
1119
$/.CURSOR.panic("Cannot re-declare attribute " ~ $attrname);
1120
}
1121
my %attr_info;
1122
%attr_info<name> := $attrname;
1123
%attr_info<type> := $*TYPENAME;
1124
%attr_info<accessor> := $twigil eq '.' ?? 1 !! 0;
1125
if $trait_list && has_compiler_trait_with_val($trait_list, '&trait_mod:<is>', 'rw') {
1126
%attr_info<rw> := 1;
1127
}
1128
if $trait_list && has_compiler_trait_with_val($trait_list, '&trait_mod:<is>', 'readonly') {
1129
%attr_info<rw> := 0;
1130
}
1131
my $has_handles := has_compiler_trait($trait_list, '&trait_mod:<handles>');
1132
if $has_handles {
1133
%attr_info<handles> := $has_handles[0];
1134
}
1135
@PACKAGE[0].attributes.push(%attr_info);
1136
1137
# If no twigil, note $foo is an alias to $!foo.
1138
if $twigil eq '' {
1139
$BLOCK.symbol($name, :attr_alias($attrname));
1140
}
1141
1142
# Nothing to emit here; just hand back an empty node, but also
1143
# annotate it with the attribute table.
1144
$past := PAST::Op.new( :pasttype('null') );
1145
$past<attribute_data> := %attr_info;
1146
}
1147
else {
1148
# Not an attribute - need to emit delcaration here.
1149
# Create the container
1150
my $cont := $sigil eq '%' ??
1151
PAST::Op.new( :name('&CREATE_HASH_FROM_LOW_LEVEL'), :pasttype('call') ) !!
1152
PAST::Op.new( sigiltype($sigil), :pirop('new Ps') );
1153
1154
# Give it a 'rw' property unless it's explicitly readonly.
1155
my $readtype := trait_readtype($trait_list);
1156
if $readtype eq 'CONFLICT' {
1157
$/.CURSOR.panic('Cannot apply more than one of: is copy, is rw, is readonly');
1158
}
1159
if $readtype eq 'copy' {
1160
$/.CURSOR.panic("'is copy' trait not valid on variable declaration");
1161
}
1162
my $true := PAST::Var.new( :name('true'), :scope('register') );
1163
my $vivipast := $readtype ne 'readonly' ??
1164
PAST::Op.new( $cont, 'rw', $true, :pirop('setprop')) !!
1165
$cont;
1166
1167
# If it's a scalar, mark it as scalar (non-flattening)
1168
if $sigil eq '$' || $sigil eq '&' {
1169
$vivipast := PAST::Op.new($vivipast,'scalar',$true,:pirop('setprop'));
1170
}
1171
1172
# For 'our' variables, we first bind or lookup in the namespace
1173
if $*SCOPE eq 'our' {
1174
$vivipast := PAST::Var.new( :name($name), :scope('package'), :isdecl(1),
1175
:lvalue(1), :viviself($vivipast), :node($/) );
1176
}
1177
1178
# Now bind a lexical in the block
1179
my $decl := PAST::Var.new( :name($name), :scope('lexical'), :isdecl(1),
1180
:lvalue(1), :viviself($vivipast), :node($/) );
1181
$BLOCK.symbol($name, :scope('lexical'), :decl_node($decl) );
1182
$BLOCK[0].push($decl);
1183
1184
# If we have traits, set up us the node to emit handlers into, then
1185
# emit them.
1186
my $init_type := 0;
1187
if $trait_list || $*TYPENAME {
1188
my $trait_node := get_var_traits_node($BLOCK, $name);
1189
for $trait_list {
1190
my $trait := $_.ast;
1191
unless $trait<trait_is_compiler_handled> {
1192
$trait.unshift(PAST::Var.new( :name('declarand'), :scope('register') ));
1193
if $trait.name() eq '&trait_mod:<of>' && $*TYPENAME {
1194
$init_type := $trait[1] := PAST::Op.new(
1195
:pasttype('callmethod'), :name('postcircumfix:<[ ]>'),
1196
$*TYPENAME, $trait[1]
1197
);
1198
$*TYPENAME := '';
1199
}
1200
$trait_node.push($trait);
1201
}
1202
}
1203
if $*TYPENAME {
1204
$trait_node.push(PAST::Op.new(
1205
:pasttype('call'), :name('&trait_mod:<of>'),
1206
PAST::Var.new( :name('declarand'), :scope('register') ),
1207
$*TYPENAME
1208
));
1209
$init_type := $*TYPENAME;
1210
}
1211
}
1212
1213
# For arrays, need to transform_to_p6opaque. XXX Find a neater way
1214
# to do this.
1215
if $sigil eq '@' {
1216
get_var_traits_node($BLOCK, $name).push(PAST::Op.new(
1217
:pirop('transform_to_p6opaque vP'),
1218
PAST::Var.new( :name('$P0'), :scope('register') )
1219
));
1220
}
1221
1222
# If we've a type to init with and it's a scalar, do so.
1223
if $init_type && $sigil eq '$' {
1224
$cont.pirop('new PsP');
1225
$cont.push($init_type);
1226
}
1227
}
1228
1229
return $past;
1230
}
1231
1232
method routine_declarator:sym<sub>($/) { make $<routine_def>.ast; }
1233
method routine_declarator:sym<method>($/) { make $<method_def>.ast; }
1234
method routine_declarator:sym<submethod>($/) { make $<method_def>.ast; }
1235
1236
method routine_def($/) {
1237
my $block := $<blockoid>.ast;
1238
$block.blocktype('declaration');
1239
$block.control('return_pir');
1240
if pir::defined__IP($block<placeholder_sig>) && $<multisig> {
1241
$/.CURSOR.panic('Placeholder variable cannot override existing signature');
1242
}
1243
my $signature := $<multisig> ?? $<multisig>[0].ast !!
1244
pir::defined__IP($block<placeholder_sig>) ?? $block<placeholder_sig> !!
1245
Perl6::Compiler::Signature.new();
1246
$signature.set_default_parameter_type('Any');
1247
add_signature($block, $signature);
1248
if $<trait> {
1249
emit_routine_traits($block, $<trait>, 'Sub');
1250
}
1251
my $past;
1252
if $<deflongname> {
1253
# Set name.
1254
my $name := '&' ~ ~$<deflongname>[0].ast;
1255
$block.name(~$<deflongname>[0].ast);
1256
$block.nsentry('');
1257
1258
# Create a code object for the routine
1259
my $symbol := @BLOCK[0].symbol($name);
1260
1261
# Check for common error conditions.
1262
if $symbol {
1263
if $*MULTINESS eq 'only' {
1264
$/.CURSOR.panic('Cannot declare only routine ' ~ $name ~
1265
' when another routine with this name was already declared');
1266
}
1267
if !$symbol<proto> && !$*MULTINESS {
1268
$/.CURSOR.panic('Cannot re-declare sub ' ~ $name ~ ' without declaring it multi');
1269
}
1270
}
1271
else {
1272
$symbol := @BLOCK[0].symbol($name, :scope<lexical>);
1273
}
1274
1275
# Create a code object for use in the block
1276
my $multiflag := $*MULTINESS eq 'proto' ?? 2 !! $*MULTINESS eq 'multi';
1277
my $code := block_closure($block, 'Sub', $multiflag);
1278
# Bind the code object to a unique register
1279
$code := PAST::Var.new( :name($block.unique('code_')), :viviself($code),
1280
:scope<register>, :isdecl(1) );
1281
# ..and use the code object as the result for this node.
1282
$past := PAST::Var.new( :name($code.name), :scope<register> );
1283
1284
# Handle multisubs...
1285
if $multiflag || $symbol<proto> {
1286
# If this is a proto, stash that information.
1287
if $*MULTINESS eq 'proto' { $symbol<proto> := $code; }
1288
1289
# If we already have a multi candidate, just add to it.
1290
if $symbol<multi> {
1291
$symbol<multi>.push($code); $code := 0 ;
1292
}
1293
else {
1294
# Otherwise, built a multi candidate.
1295
$symbol<multi> := PAST::Op.new( :pasttype<callmethod>,
1296
:name('set_candidates'),
1297
PAST::Op.new( :pirop<new__Ps>, 'Perl6MultiSub'),
1298
$code );
1299
# Merge it with outer (lexical) or existing (package) candidates
1300
$code := PAST::Op.new( :pasttype<callmethod>,
1301
:name<merge_candidates>,
1302
$symbol<multi>,
1303
$*SCOPE eq 'our'
1304
?? PAST::Var.new( :name($name), :scope('package') )
1305
!! PAST::Op.new( :pirop<find_lex_skip_current__Ps>, $name ) );
1306
}
1307
}
1308
1309
# Bind the block code or multisub object
1310
if $code {
1311
# If it's package scoped, also bind into the package
1312
if $*SCOPE eq 'our' {
1313
$code := PAST::Op.new( :pasttype<bind>,
1314
PAST::Var.new( :name($name), :scope('package'), :isdecl(1) ),
1315
$code);
1316
}
1317
# Always bind lexically (like 'our' variables do)
1318
@BLOCK[0][0].push(
1319
PAST::Var.new( :name($name), :scope('lexical'), :isdecl(1),
1320
:lvalue(1), :viviself($code), :node($/) ) );
1321
}
1322
1323
# If it's package scoped, we also need a separate compile-time binding into the package
1324
if $*SCOPE eq 'our' {
1325
my $code := block_code($block, 'Sub', $multiflag);
1326
$symbol := @PACKAGE[0].block.symbol($name);
1327
if $multiflag || $symbol<pkgproto> {
1328
# If this is a proto, stash that information.
1329
if $*MULTINESS eq 'proto' { $symbol<pkgproto> := $code; }
1330
1331
if $symbol<pkgmulti> {
1332
$symbol<pkgmulti>.push($code);
1333
$code := 0;
1334
}
1335
else {
1336
$symbol<pkgmulti> := PAST::Op.new( :pasttype<callmethod>,
1337
:name('set_candidates'),
1338
PAST::Op.new( :pirop<new__Ps>, 'Perl6MultiSub'),
1339
$code );
1340
$code := PAST::Op.new( :pasttype<callmethod>,
1341
:name<merge_candidates>,
1342
$symbol<pkgmulti>,
1343
PAST::Var.new( :name($name), :scope('package') ) );
1344
}
1345
}
1346
if $code {
1347
@PACKAGE[0].block.loadinit.push(
1348
PAST::Op.new( :pasttype<bind>,
1349
PAST::Var.new( :name($name), :scope('package') ),
1350
$code) );
1351
}
1352
}
1353
}
1354
elsif $*MULTINESS {
1355
$/.CURSOR.panic('Cannot put ' ~ $*MULTINESS ~ ' on anonymous routine');
1356
}
1357
else {
1358
# Just wrap in a Sub.
1359
$past := block_closure($block, 'Sub', 0);
1360
}
1361
make $past;
1362
}
1363
1364
1365
method method_def($/) {
1366
my $past := $<blockoid>.ast;
1367
$past.blocktype('declaration');
1368
$past.control('return_pir');
1369
1370
# Get signature - or create - and sort out invocant handling.
1371
if pir::defined__IP($past<placeholder_sig>) {
1372
$/.CURSOR.panic('Placeholder variables cannot be used in a method');
1373
}
1374
my $sig := $<multisig> ?? $<multisig>[0].ast !! Perl6::Compiler::Signature.new();
1375
$sig.add_invocant();
1376
$sig.set_default_parameter_type('Any');
1377
1378
# Add *%_ parameter if there's no other named slurpy and the package isn't hidden.
1379
my $need_slurpy_hash := !$sig.has_named_slurpy();
1380
if $need_slurpy_hash { # XXX ADD BACK: && !package_has_trait('hidden') {
1381
my $param := Perl6::Compiler::Parameter.new();
1382
$param.var_name('%_');
1383
$param.named_slurpy(1);
1384
$sig.add_parameter($param);
1385
}
1386
1387
# Add signature to block.
1388
add_signature($past, $sig);
1389
$past[0].unshift(PAST::Var.new( :name('self'), :scope('lexical'), :isdecl(1), :viviself(sigiltype('$')) ));
1390
$past.symbol('self', :scope('lexical'));
1391
1392
# Emit traits.
1393
if $<trait> {
1394
emit_routine_traits($past, $<trait>, $*METHODTYPE);
1395
}
1396
1397
# Method container.
1398
if $<longname> {
1399
# Set up us the name.
1400
my $name := $<longname>.Str;
1401
if $<specials> eq '!' { $name := '!' ~ $name; }
1402
$past.name($name);
1403
$past.nsentry('');
1404
my $multi_flag := $*MULTINESS eq 'proto' ?? 2 !!
1405
$*MULTINESS eq 'multi' ?? 1 !!
1406
0;
1407
1408
# Create code object using a reference to $past.
1409
my $code := block_code($past, $*METHODTYPE, $multi_flag);
1410
1411
# Get hold of the correct table to install it in, and install.
1412
our @PACKAGE;
1413
unless +@PACKAGE { $/.CURSOR.panic("Cannot declare method outside of a package"); }
1414
my %table;
1415
if $<specials> eq '^' {
1416
%table := @PACKAGE[0].meta_methods();
1417
}
1418
else {
1419
%table := @PACKAGE[0].methods();
1420
}
1421
install_method($/, $code, $name, %table);
1422
}
1423
elsif $*MULTINESS {
1424
$/.CURSOR.panic('Cannot put ' ~ $*MULTINESS ~ ' on anonymous routine');
1425
}
1426
else {
1427
$past := block_closure($past, $*METHODTYPE, 0);
1428
}
1429
1430
make $past;
1431
}
1432
1433
sub install_method($/, $code, $name, %table) {
1434
my $installed;
1435
1436
# Create method table entry if we need one.
1437
unless %table{$name} { my %tmp; %table{$name} := %tmp; }
1438
1439
# If it's an only and there's already a symbol, problem.
1440
if $*MULTINESS eq 'only' && %table{$name} {
1441
$/.CURSOR.panic('Cannot declare only method ' ~ $name ~
1442
' when another method with this name was already declared');
1443
}
1444
elsif $*MULTINESS || %table{$name}<multis> {
1445
# If no multi declarator and no proto, error.
1446
if !$*MULTINESS && !%table{$name}<proto> {
1447
$/.CURSOR.panic('Cannot re-declare method ' ~ $name ~ ' without declaring it multi');
1448
}
1449
1450
# If it's a proto, stash it away in the symbol entry.
1451
if $*MULTINESS eq 'proto' { %table{$name}<proto> := $code; }
1452
1453
# Create multi container if we don't have one; otherwise, just push
1454
# this candidate onto it.
1455
if %table{$name}<multis> {
1456
%table{$name}<multis>.push($code);
1457
}
1458
else {
1459
$code := PAST::Op.new(
1460
:pasttype('callmethod'),
1461
:name('set_candidates'),
1462
PAST::Op.new( :inline(' %r = new ["Perl6MultiSub"]') ),
1463
$code
1464
);
1465
%table{$name}<code_ref> := %table{$name}<multis> := $installed := $code;
1466
}
1467
}
1468
else {
1469
%table{$name}<code_ref> := $installed := $code;
1470
}
1471
1472
# If we did install something (we maybe didn't need to if this is a multi),
1473
# we may need to also pop it in other places.
1474
if $installed {
1475
if $*SCOPE eq 'my' {
1476
@BLOCK[0][0].push(PAST::Var.new( :name('&' ~ $name), :isdecl(1),
1477
:viviself($installed), :scope('lexical') ));
1478
@BLOCK[0].symbol($name, :scope('lexical') );
1479
}
1480
elsif $*SCOPE eq 'our' {
1481
@PACKAGE[0].block.loadinit.push(PAST::Op.new(
1482
:pasttype('bind'),
1483
PAST::Var.new( :name('&' ~ $name), :scope('package') ),
1484
$installed
1485
));
1486
}
1487
}
1488
}
1489
1490
our %REGEX_MODIFIERS;
1491
method regex_declarator:sym<regex>($/, $key?) {
1492
if ($key) {
1493
my %h;
1494
%REGEX_MODIFIERS := %h;
1495
} else {
1496
make $<regex_def>.ast;
1497
}
1498
}
1499
1500
method regex_declarator:sym<token>($/, $key?) {
1501
if ($key) {
1502
my %h;
1503
%h<r> := 1;
1504
%REGEX_MODIFIERS := %h;
1505
} else {
1506
make $<regex_def>.ast;
1507
}
1508
}
1509
1510
method regex_declarator:sym<rule>($/, $key?) {
1511
if ($key) {
1512
my %h;
1513
%h<r> := 1; %h<s> :=1;
1514
%REGEX_MODIFIERS := %h;
1515
} else {
1516
make $<regex_def>.ast;
1517
}
1518
}
1519
1520
method regex_def($/, $key?) {
1521
my $name := ~$<deflongname>[0];
1522
my @MODIFIERS := Q:PIR {
1523
%r = get_hll_global ['Regex';'P6Regex';'Actions'], '@MODIFIERS'
1524
};
1525
1526
my $past;
1527
if $key eq 'open' {
1528
@MODIFIERS.unshift(%REGEX_MODIFIERS);
1529
# The following is so that <sym> can work
1530
Q:PIR {
1531
$P0 = find_lex '$name'
1532
set_hll_global ['Regex';'P6Regex';'Actions'], '$REGEXNAME', $P0
1533
};
1534
return 0;
1535
} elsif $*MULTINESS eq 'proto' {
1536
# Need to build code for setting up a proto-regex.
1537
@MODIFIERS.shift;
1538
@BLOCK.shift;
1539
unless ($name) {
1540
$/.CURSOR.panic('proto ' ~ ~$<sym> ~ 's cannot be anonymous');
1541
}
1542
our @PACKAGE;
1543
unless +@PACKAGE {
1544
$/.CURSOR.panic("Cannot declare named " ~ ~$<sym> ~ " outside of a package");
1545
}
1546
my %table;
1547
%table := @PACKAGE[0].methods();
1548
unless %table{$name} { my %tmp; %table{$name} := %tmp; }
1549
if %table{$name} {
1550
$/.CURSOR.panic('Cannot declare proto ' ~ ~$<sym> ~ ' ' ~ $name ~
1551
' when another with this name was already declared');
1552
}
1553
%table{$name}<code_ref> :=
1554
block_closure(
1555
PAST::Block.new( :name($name),
1556
PAST::Op.new(
1557
PAST::Var.new( :name('self'), :scope('register') ),
1558
$name,
1559
:name('!protoregex'),
1560
:pasttype('callmethod')
1561
),
1562
:lexical(0),
1563
:blocktype('method'),
1564
:pirflags(':anon'),
1565
:node($/)
1566
),
1567
'Regex', 0);
1568
%table{'!PREFIX__' ~ $name}<code_ref> :=
1569
block_closure(
1570
PAST::Block.new( :name('!PREFIX__' ~ $name),
1571
PAST::Op.new(
1572
PAST::Var.new( :name('self'), :scope('register') ),
1573
$name,
1574
:name('!PREFIX__!protoregex'),
1575
:pasttype('callmethod')
1576
),
1577
:blocktype('method'),
1578
:pirflags(':anon'),
1579
:lexical(0),
1580
:node($/)
1581
),
1582
'Regex', 0);
1583
} else {
1584
# Clear modifiers stack entry for this regex.
1585
@MODIFIERS.shift;
1586
1587
# Create the regex sub along with its signature.
1588
$past := Regex::P6Regex::Actions::buildsub($<p6regex>.ast, @BLOCK.shift);
1589
$past.unshift(PAST::Op.new(
1590
:pasttype('inline'),
1591
:inline(" .local pmc self\n self = find_lex 'self'")
1592
));
1593
my $sig := $<signature> ?? $<signature>[0].ast !! Perl6::Compiler::Signature.new();
1594
$sig.add_invocant();
1595
$sig.set_default_parameter_type('Any');
1596
$past[0].unshift(PAST::Var.new( :name('self'), :scope('lexical'), :isdecl(1), :viviself(sigiltype('$')) ));
1597
$past.symbol('self', :scope('lexical'));
1598
add_signature($past, $sig);
1599
$past.name($name);
1600
$past.blocktype("declaration");
1601
1602
# If the methods are not :anon they'll conflict at class composition time.
1603
$past.pirflags(':anon');
1604
1605
# Create code object and install it provided it has a name.
1606
if ($name) {
1607
my $code := block_closure(blockref($past), 'Regex', 0);
1608
our @PACKAGE;
1609
unless +@PACKAGE {
1610
$/.CURSOR.panic("Cannot declare named " ~ ~$<sym> ~ " outside of a package");
1611
}
1612
my %table;
1613
%table := @PACKAGE[0].methods();
1614
install_method($/, $code, $name, %table);
1615
}
1616
else {
1617
$past := block_closure($past, 'Regex', 0);
1618
}
1619
}
1620
make $past;
1621
}
1622
1623
method type_declarator:sym<enum>($/) {
1624
my $value_ast := PAST::Op.new(
1625
:pasttype('call'),
1626
:name('!create_anon_enum'),
1627
$<circumfix>.ast
1628
);
1629
if $<name> {
1630
# Named; need to compile and run the AST right away.
1631
our $?RAKUDO_HLL;
1632
my $compiled := PAST::Compiler.compile(PAST::Block.new(
1633
:hll($?RAKUDO_HLL), $value_ast
1634
));
1635
my $result := (pir::find_sub_not_null__ps('!YOU_ARE_HERE'))($compiled)();
1636
1637
# Only support our-scoped so far.
1638
unless $*SCOPE eq '' || $*SCOPE eq 'our' {
1639
$/.CURSOR.panic("Do not yet support $*SCOPE scoped enums");
1640
}
1641
1642
if $/.CURSOR.is_name(~$<name>[0]) {
1643
$/.CURSOR.panic("Illegal redeclaration of symbol '"
1644
~ $<name>[0] ~ "'");
1645
}
1646
1647
# Install names.
1648
$/.CURSOR.add_name(~$<name>[0]);
1649
for $result {
1650
$/.CURSOR.add_name(~$_.key);
1651
$/.CURSOR.add_name(~$<name>[0] ~ '::' ~ ~$_.key);
1652
}
1653
1654
# Emit code to set up named enum.
1655
@PACKAGE[0].block.loadinit.push(PAST::Op.new(
1656
:pasttype('call'),
1657
:name('&SETUP_NAMED_ENUM'),
1658
~$<name>[0],
1659
$value_ast
1660
));
1661
my @name := Perl6::Grammar::parse_name(~$<name>[0]);
1662
make PAST::Var.new( :name(@name.pop), :namespace(@name), :scope('package') );
1663
}
1664
else {
1665
# Anonymous, so we're done.
1666
make $value_ast;
1667
}
1668
}
1669
1670
method type_declarator:sym<subset>($/) {
1671
# Figure out our refinee.
1672
my $of_trait := has_compiler_trait($<trait>, '&trait_mod:<of>');
1673
my $refinee := $of_trait ??
1674
$of_trait[0] !!
1675
PAST::Var.new( :name('Any'), :namespace([]), :scope('package') );
1676
1677
# Construct subset and install it in the right place.
1678
my $cons_past := PAST::Op.new(
1679
:name('&CREATE_SUBSET_TYPE'),
1680
$refinee,
1681
$<EXPR> ?? where_blockify($<EXPR>[0].ast) !!
1682
PAST::Var.new( :name('True'), :namespace('Bool'), :scope('package') )
1683
);
1684
1685
# Stick it somewhere appropriate.
1686
if $<longname> {
1687
my $name := $<longname>[0].Str;
1688
if $*SCOPE eq '' || $*SCOPE eq 'our' {
1689
# Goes in the package.
1690
@PACKAGE[0].block.loadinit.push(PAST::Op.new(
1691
:pasttype('bind'),
1692
PAST::Var.new( :name($name), :scope('package') ),
1693
$cons_past
1694
));
1695
@BLOCK[0].symbol($name, :scope('package') );
1696
}
1697
elsif $*SCOPE eq 'my' {
1698
# Install in the lexpad.
1699
@BLOCK[0][0].push(PAST::Var.new(
1700
:name($name), :isdecl(1),
1701
:viviself($cons_past), :scope('lexical')
1702
));
1703
@BLOCK[0].symbol($name, :scope('lexical') );
1704
}
1705
else {
1706
$/.CURSOR.panic("Cannot declare a subset with scope declarator " ~ $*SCOPE);
1707
}
1708
make PAST::Var.new( :name($name) );
1709
}
1710
else {
1711
if $*SCOPE ne '' && $*SCOPE ne 'anon' {
1712
$/.CURSOR.panic('A ' ~ $*SCOPE ~ ' scoped subset must have a name.');
1713
}
1714
make $cons_past;
1715
}
1716
}
1717
1718
method type_declarator:sym<constant>($/) {
1719
$/.CURSOR.panic('Constant type declarator not yet implemented');
1720
}
1721
1722
method capterm($/) {
1723
# Construct a Parcel, and then call .Capture to coerce it to a capture.
1724
my $past := $<termish> ?? $<termish>.ast !!
1725
$<capture> ?? $<capture>[0].ast !!
1726
PAST::Op.new( :name('&infix:<,>') );
1727
unless $past.isa(PAST::Op) && $past.name() eq '&infix:<,>' {
1728
$past := PAST::Op.new( :name('&infix:<,>'), $past );
1729
}
1730
make PAST::Op.new( :pasttype('callmethod'), :name('Capture'), $past);
1731
}
1732
1733
method capture($/) {
1734
make $<EXPR>.ast;
1735
}
1736
1737
method multisig($/) {
1738
make $<signature>.ast;
1739
}
1740
1741
method fakesignature($/) {
1742
@BLOCK.shift;
1743
make $<signature>.ast;
1744
}
1745
1746
method signature($/) {
1747
my $signature := Perl6::Compiler::Signature.new();
1748
my $cur_param := 0;
1749
my $is_multi_invocant := 1;
1750
for $<parameter> {
1751
my $param := $_.ast;
1752
$param.multi_invocant($is_multi_invocant);
1753
if ~@*seps[$cur_param] eq ':' {
1754
if $cur_param == 0 {
1755
$param.invocant(1);
1756
}
1757
else {
1758
$/.CURSOR.panic("Cannot put ':' parameter separator after first parameter");
1759
}
1760
}
1761
if @*seps[$cur_param] eq ';;' {
1762
$is_multi_invocant := 0;
1763
}
1764
$signature.add_parameter($param);
1765
$cur_param := $cur_param + 1;
1766
}
1767
@BLOCK[0]<signature> := $signature;
1768
make $signature;
1769
}
1770
1771
method parameter($/) {
1772
my $quant := $<quant>;
1773
1774
# Sanity checks.
1775
if $<default_value> {
1776
if $quant eq '*' {
1777
$/.CURSOR.panic("Cannot put default on slurpy parameter");
1778
}
1779
if $quant eq '!' {
1780
$/.CURSOR.panic("Cannot put default on required parameter");
1781
}
1782
}
1783
1784
# Set various flags on the parameter.
1785
$*PARAMETER.pos_slurpy( $quant eq '*' && $*PARAMETER.sigil eq '@' );
1786
$*PARAMETER.named_slurpy( $quant eq '*' && $*PARAMETER.sigil eq '%' );
1787
$*PARAMETER.optional( $quant eq '?' || $<default_value> || ($<named_param> && $quant ne '!') );
1788
$*PARAMETER.is_parcel( $quant eq '\\' );
1789
$*PARAMETER.is_capture( $quant eq '|' );
1790
if $<default_value> {
1791
$*PARAMETER.default( PAST::Block.new( $<default_value>[0]<EXPR>.ast ) );
1792
}
1793
1794
# Handle traits.
1795
$*PARAMETER.traits($<trait>);
1796
if $<trait> {
1797
# Handle built-in ones.
1798
my $read_type := trait_readtype($<trait>);
1799
if $read_type eq 'CONFLICT' {
1800
$/.CURSOR.panic('Cannot apply more than one of: is copy, is rw, is readonly');
1801
}
1802
$*PARAMETER.is_rw( $read_type eq 'rw' );
1803
$*PARAMETER.is_copy( $read_type eq 'copy' );
1804
my $coerce := has_compiler_trait($<trait>, '&trait_mod:<as>');
1805
if $coerce {
1806
$*PARAMETER.coerce_to(PAST::Op.new( :pasttype('callmethod'), :name('perl'), $coerce[0]));
1807
}
1808
}
1809
1810
make $*PARAMETER;
1811
}
1812
1813
method param_var($/) {
1814
if $<signature> {
1815
if pir::defined__IP($*PARAMETER.sub_llsig) {
1816
$/.CURSOR.panic('Cannot have more than one sub-signature for a parameter');
1817
}
1818
$*PARAMETER.sub_llsig( $<signature>.ast );
1819
if pir::substr(~$/, 0, 1) eq '[' {
1820
$*PARAMETER.var_name('@');
1821
}
1822
}
1823
else {
1824
my $twigil := $<twigil> ?? ~$<twigil>[0] !! '';
1825
$*PARAMETER.var_name(~$/);
1826
if $twigil eq '' {
1827
if $<name> {
1828
if @BLOCK[0].symbol(~$/) {
1829
$/.CURSOR.panic("Redeclaration of symbol ", ~$/);
1830
}
1831
@BLOCK[0].symbol(~$/, :scope($*SCOPE eq 'my' ?? 'lexical' !! 'package'));
1832
}
1833
}
1834
elsif $twigil ne '!' && $twigil ne '.' && $twigil ne '*' {
1835
my $error := "In signature parameter, '" ~ ~$/ ~ "', it is illegal to use '" ~ $twigil ~ "' twigil";
1836
if $twigil eq ':' {
1837
$error := "In signature parameter, placeholder variables like " ~ ~$/ ~ " are illegal\n"
1838
~ "you probably meant a named parameter: ':" ~ $<sigil> ~ ~$<name>[0] ~ "'";
1839
}
1840
$/.CURSOR.panic($error);
1841
}
1842
}
1843
}
1844
1845
method named_param($/) {
1846
if $<name> { $*PARAMETER.names.push(~$<name>); }
1847
elsif $<param_var><name> { $*PARAMETER.names.push(~$<param_var><name>[0]); }
1848
else { $*PARAMETER.names.push(''); }
1849
}
1850
1851
method type_constraint($/) {
1852
if $<typename> {
1853
if pir::substr(~$<typename>, 0, 2) eq '::' {
1854
my $desigilname := pir::substr(~$<typename>, 2);
1855
$*PARAMETER.type_captures.push($desigilname);
1856
my @BlOCK;
1857
@BLOCK[0].symbol($desigilname, :scope('lexical'));
1858
}
1859
else {
1860
if $*PARAMETER.nom_type {
1861
$/.CURSOR.panic('Parameter may only have one prefix type constraint');
1862
}
1863
$*PARAMETER.nom_type($<typename>.ast);
1864
}
1865
}
1866
elsif $<value> {
1867
if $*PARAMETER.nom_type {
1868
$/.CURSOR.panic('Parameter may only have one prefix type constraint');
1869
}
1870
$*PARAMETER.nom_type(PAST::Op.new(
1871
:pirop('deobjectref__PP'),
1872
PAST::Op.new( :pasttype('callmethod'), :name('WHAT'), $<value>.ast )
1873
));
1874
$*PARAMETER.cons_types.push($<value>.ast);
1875
}
1876
else {
1877
$/.CURSOR.panic('Cannot do non-typename cases of type_constraint yet');
1878
}
1879
}
1880
1881
method post_constraint($/) {
1882
if $<signature> {
1883
if pir::defined__IP($*PARAMETER.sub_llsig) {
1884
$/.CURSOR.panic('Cannot have more than one sub-signature for a parameter');
1885
}
1886
$*PARAMETER.sub_llsig( $<signature>.ast );
1887
}
1888
else {
1889
$*PARAMETER.cons_types.push(where_blockify($<EXPR>.ast));
1890
}
1891
}
1892
1893
method trait($/) {
1894
my $past;
1895
if $<trait_mod> {
1896
$past := $<trait_mod>.ast;
1897
}
1898
elsif $<colonpair> {
1899
$/.CURSOR.panic('traits specified as colon pairs not yet understood');
1900
}
1901
make $past;
1902
}
1903
1904
method trait_mod:sym<is>($/) {
1905
my $trait := PAST::Op.new( :pasttype('call'), :name('&trait_mod:<is>') );
1906
if $<circumfix> { $trait.push($<circumfix>[0].ast); }
1907
1908
if $/.CURSOR.is_name(~$<longname>) {
1909
# It's a type - look it up and send it in as a positional, before
1910
# the parameter.
1911
my @name := Perl6::Grammar::parse_name(~$<longname>);
1912
$trait.unshift(PAST::Var.new(
1913
:scope(is_lexical(~$<longname>) ?? 'lexical' !! 'package'),
1914
:name(@name.pop()),
1915
:namespace(@name)
1916
));
1917
}
1918
else {
1919
# Not a type name, so construct a named parameter with this name; it
1920
# is a named param so it has to go on the end.
1921
$trait.push(PAST::Var.new(
1922
:name('True'),
1923
:namespace('Bool'),
1924
:scope('package'),
1925
:named(~$<longname>)
1926
));
1927
}
1928
1929
$trait<is_name> := ~$<longname>;
1930
make $trait;
1931
}
1932
1933
method trait_mod:sym<hides>($/) {
1934
make PAST::Op.new(
1935
:pasttype('call'),
1936
:name('&trait_mod:<hides>'),
1937
$<module_name>.ast
1938
);
1939
}
1940
1941
method trait_mod:sym<does>($/) {
1942
make PAST::Op.new(
1943
:pasttype('call'),
1944
:name('&trait_mod:<does>'),
1945
$<module_name>.ast
1946
);
1947
}
1948
1949
method trait_mod:sym<will>($/) {
1950
my $trait := PAST::Op.new(
1951
:pasttype('call'),
1952
:name('&trait_mod:will'),
1953
$<pblock>.ast
1954
);
1955
1956
if $/.CURSOR.is_name(~$<identifier>) {
1957
# It's a type - look it up and send it in as a positional, before
1958
# the parameter.
1959
$trait.unshift(PAST::Var.new(
1960
:scope('package'),
1961
:name(~$<identifier>)
1962
));
1963
}
1964
else {
1965
# Not a type name, so construct a named parameter with this name; it
1966
# is a named param so it has to go on the end.
1967
$trait.push(PAST::Val.new(
1968
:value(PAST::Var.new( :name('True'), :namespace('Bool'), :scope('package') )),
1969
:named(~$<identifier>)
1970
));
1971
}
1972
1973
make $trait;
1974
}
1975
1976
method trait_mod:sym<of>($/) {
1977
make PAST::Op.new(
1978
:pasttype('call'),
1979
:name('&trait_mod:<of>'),
1980
$<typename>.ast
1981
);
1982
}
1983
1984
method trait_mod:sym<as>($/) {
1985
make PAST::Op.new(
1986
:pasttype('call'),
1987
:name('&trait_mod:<as>'),
1988
$<typename>.ast
1989
);
1990
}
1991
1992
method trait_mod:sym<returns>($/) {
1993
make PAST::Op.new(
1994
:pasttype('call'),
1995
:name('&trait_mod:<returns>'),
1996
$<typename>.ast
1997
);
1998
}
1999
2000
method trait_mod:sym<handles>($/) {
2001
make PAST::Op.new(
2002
:pasttype('call'),
2003
:name('&trait_mod:<handles>'),
2004
$<term>.ast
2005
);
2006
}
2007
2008
method postop($/) {
2009
make $<postfix> ?? $<postfix>.ast !! $<postcircumfix>.ast;
2010
}
2011
2012
method dotty:sym<.>($/) { make $<dottyop>.ast; }
2013
2014
method dotty:sym<.*>($/) {
2015
my $past := $<dottyop>.ast;
2016
unless $past.isa(PAST::Op) && $past.pasttype() eq 'callmethod' {
2017
$/.CURSOR.panic("Cannot use " ~ $<sym>.Str ~ " on a non-identifier method call");
2018
}
2019
$past.unshift($past.name);
2020
$past.name('!dispatch_' ~ $<sym>.Str);
2021
$past.pasttype('call');
2022
make $past;
2023
}
2024
2025
method dottyop($/) {
2026
if $<methodop> {
2027
make $<methodop>.ast;
2028
} else {
2029
make $<postop>.ast;
2030
}
2031
}
2032
2033
method privop($/) {
2034
my $past := $<methodop>.ast;
2035
if $<methodop><quote> {
2036
$past.name(PAST::Op.new( :pasttype('call'), :name('&infix:<~>'), '!', $past.name ));
2037
}
2038
else {
2039
$past.name( '!' ~ $past.name );
2040
}
2041
make $past;
2042
}
2043
2044
method methodop($/) {
2045
my $past := $<args> ?? $<args>[0].ast !! PAST::Op.new( :node($/) );
2046
$past.pasttype('callmethod');
2047
if $<longname> {
2048
# May just be .foo, but could also be .Foo::bar
2049
my @parts := Perl6::Grammar::parse_name(~$<longname>);
2050
my $name := @parts.pop;
2051
if +@parts {
2052
my $scope := is_lexical(pir::join('::', @parts)) ?? 'lexical' !! 'package';
2053
$past.unshift(PAST::Var.new(
2054
:name(@parts.pop),
2055
:namespace(@parts),
2056
:scope($scope)
2057
));
2058
$past.unshift($name);
2059
$past.name('!dispatch_::');
2060
$past.pasttype('call');
2061
}
2062
else {
2063
$past.name( $name );
2064
}
2065
}
2066
elsif $<quote> {
2067
$past.name( $<quote>.ast );
2068
}
2069
elsif $<variable> {
2070
$past.unshift($<variable>.ast);
2071
$past.name('!dispatch_variable');
2072
$past.pasttype('call');
2073
}
2074
make $past;
2075
}
2076
2077
2078
method term:sym<self>($/) {
2079
make PAST::Var.new( :name('self'), :node($/) );
2080
}
2081
2082
method term:sym<now>($/) {
2083
make PAST::Op.new( :name('&term:<now>'), :node($/) );
2084
}
2085
2086
method term:sym<time>($/) {
2087
make PAST::Op.new( :name('&term:<time>'), :node($/) );
2088
}
2089
2090
method term:sym<rand>($/) {
2091
make PAST::Op.new(:name('&rand'), :node($/) );
2092
}
2093
2094
method term:sym<...>($/) {
2095
make PAST::Op.new( :pasttype('call'), :name('&fail'), 'Stub code executed', :node($/) );
2096
}
2097
2098
method term:sym<???>($/) {
2099
make PAST::Op.new( :pasttype('call'), :name('&warn'), 'Stub code executed', :node($/) );
2100
}
2101
2102
method term:sym<!!!>($/) {
2103
make PAST::Op.new( :pasttype('call'), :name('&die'), 'Stub code executed', :node($/) );
2104
}
2105
2106
method term:sym<dotty>($/) {
2107
my $past := $<dotty>.ast;
2108
$past.unshift(PAST::Var.new( :name('$_'), :scope('lexical') ) );
2109
make $past;
2110
}
2111
2112
method term:sym<identifier>($/) {
2113
my $past := capture_or_parcel($<args>.ast, ~$<identifier>);
2114
$past.name('&' ~ $<identifier>);
2115
make $past;
2116
}
2117
2118
method term:sym<name>($/) {
2119
my $ns := Perl6::Grammar::parse_name(~$<longname>);
2120
$ns := pir::clone__PP($ns);
2121
my $name := $ns.pop;
2122
my $var;
2123
if is_lexical(~$<longname>) {
2124
$var := PAST::Var.new( :name(~$<longname>), :scope('lexical') );
2125
}
2126
else {
2127
$var := PAST::Var.new(
2128
:name(~$name), :namespace($ns), :scope('package'),
2129
:viviself(PAST::Op.new(
2130
:pasttype('call'), :name('!FAIL'),
2131
"Cannot find sub " ~ ~$<longname>
2132
))
2133
);
2134
}
2135
my $past := $var;
2136
if $<args> {
2137
$past := capture_or_parcel($<args>.ast, ~$<longname>);
2138
if $ns {
2139
$past.unshift($var);
2140
unless pir::substr($var.name, 0, 1) eq '&' {
2141
$var.name('&' ~ $var.name);
2142
}
2143
}
2144
else { $past.name('&' ~ $name); }
2145
}
2146
elsif $<arglist> {
2147
$past := $<arglist>[0].ast;
2148
$past.pasttype('callmethod');
2149
$past.name('!select');
2150
$past.unshift($var);
2151
}
2152
$past.node($/);
2153
make $past;
2154
}
2155
2156
method term:sym<pir::op>($/) {
2157
if $FORBID_PIR {
2158
pir::die("pir::op forbidden in safe mode\n");
2159
}
2160
my $past := $<args> ?? $<args>[0].ast !! PAST::Op.new( :node($/) );
2161
my $pirop := ~$<op>;
2162
$pirop := Q:PIR {
2163
$P0 = find_lex '$pirop'
2164
$S0 = $P0
2165
$P0 = split '__', $S0
2166
$S0 = join ' ', $P0
2167
%r = box $S0
2168
};
2169
$past.pirop($pirop);
2170
$past.pasttype('pirop');
2171
make $past;
2172
}
2173
2174
method term:sym<*>($/) {
2175
my @name := Perl6::Grammar::parse_name('Whatever');
2176
make PAST::Op.new(
2177
:pasttype('callmethod'), :name('new'), :node($/), :lvalue(1), :returns('Whatever'),
2178
PAST::Var.new( :name(@name.pop), :namespace(@name), :scope('package') )
2179
)
2180
}
2181
2182
method term:sym<capterm>($/) {
2183
make $<capterm>.ast;
2184
}
2185
2186
method args($/) {
2187
my $past;
2188
if $<semiarglist> { $past := $<semiarglist>.ast; }
2189
elsif $<arglist> { $past := $<arglist>.ast; }
2190
else {
2191
$past := PAST::Op.new( :pasttype('call'), :node($/) );
2192
}
2193
make $past;
2194
}
2195
2196
method semiarglist($/) { make $<arglist>.ast; }
2197
2198
method arglist($/) {
2199
# Build up argument list, hanlding nameds as we go.
2200
my $past := PAST::Op.new( );
2201
if $<EXPR> {
2202
my $expr := $<EXPR>.ast;
2203
if $expr.name eq '&infix:<,>' {
2204
for $expr.list { $past.push(handle_named_parameter($_)); }
2205
}
2206
else { $past.push(handle_named_parameter($expr)); }
2207
}
2208
2209
# See if we have any uses of prefix:<|>; if we have, then we take it and
2210
# evaluate it once. We then stick it in a register, and pull out an RPA
2211
# and a Hash that Parrot knows what to do with.
2212
my $result := PAST::Op.new( :pasttype('call'), :node($/) );
2213
for @($past) {
2214
if $_.isa(PAST::Op) && $_.name() eq '&prefix:<|>' {
2215
my $reg_name := $past.unique('flatten_tmp_');
2216
my $steps := PAST::Stmts.new(
2217
PAST::Op.new( :pasttype('bind'),
2218
PAST::Var.new( :name($reg_name), :scope('register'), :isdecl(1) ),
2219
$_
2220
),
2221
PAST::Op.new(
2222
:pasttype('callmethod'), :name('!PARROT_POSITIONALS'),
2223
PAST::Var.new( :name($reg_name), :scope('register') )
2224
)
2225
);
2226
$steps.flat(1);
2227
$result.push($steps);
2228
$result.push(PAST::Op.new(
2229
:flat(1), :named(1),
2230
:pasttype('callmethod'), :name('!PARROT_NAMEDS'),
2231
PAST::Var.new( :name($reg_name), :scope('register') )
2232
));
2233
}
2234
else {
2235
$result.push($_);
2236
}
2237
}
2238
2239
make $result;
2240
}
2241
2242
sub handle_named_parameter($arg) {
2243
if $arg ~~ PAST::Op && $arg.returns() eq 'Pair' {
2244
my $result := $arg[2];
2245
$result.named(~$arg[1].value());
2246
$result<before_promotion> := $arg;
2247
$result;
2248
}
2249
else {
2250
$arg;
2251
}
2252
}
2253
2254
method term:sym<value>($/) { make $<value>.ast; }
2255
2256
method circumfix:sym<( )>($/) {
2257
my $past := $<semilist>.ast;
2258
my $size := +$past.list;
2259
if $size == 0 {
2260
$past := PAST::Op.new( :name('&infix:<,>') );
2261
}
2262
else {
2263
my $last := $past[ $size - 1 ];
2264
if pir::defined($last.returns) {
2265
$past.returns($last.returns);
2266
}
2267
if pir::defined($last.arity) {
2268
$past.arity($last.arity);
2269
}
2270
}
2271
make $past;
2272
}
2273
2274
method circumfix:sym<ang>($/) { make $<quote_EXPR>.ast; }
2275
2276
method circumfix:sym<« »>($/) { make $<quote_EXPR>.ast; }
2277
2278
method circumfix:sym<{ }>($/) {
2279
# If it is completely empty or consists of a single list, the first
2280
# element of which is either a hash or a pair, it's a hash constructor.
2281
my $past := $<pblock>.ast;
2282
my $is_hash := 0;
2283
my $stmts := +$<pblock><blockoid><statementlist><statement>;
2284
if $stmts == 0 {
2285
# empty block, so a hash
2286
$is_hash := 1;
2287
}
2288
elsif $stmts == 1 {
2289
my $elem := $past[1][0];
2290
if $elem ~~ PAST::Op && $elem.name eq '&infix:<,>' {
2291
# block contains a list, so test the first element
2292
$elem := $elem[0];
2293
}
2294
if $elem ~~ PAST::Op
2295
&& ($elem.returns eq 'Pair' || $elem.name eq '&infix:<=>>') {
2296
# first item is a pair
2297
$is_hash := 1;
2298
}
2299
elsif $elem ~~ PAST::Var
2300
&& pir::substr($elem.name, 0, 1) eq '%' {
2301
# first item is a hash
2302
$is_hash := 1;
2303
}
2304
}
2305
if $is_hash && $past.arity < 1 {
2306
my @children := @($past[1]);
2307
$past := PAST::Op.new(
2308
:pasttype('call'),
2309
:name('&circumfix:<{ }>'),
2310
:node($/)
2311
);
2312
for @children {
2313
$past.push($_);
2314
}
2315
}
2316
else {
2317
$past := block_closure($past, 'Block', 0);
2318
$past<bareblock> := 1;
2319
}
2320
make $past;
2321
}
2322
2323
method circumfix:sym<[ ]>($/) {
2324
make PAST::Op.new( :name('&circumfix:<[ ]>'), $<semilist>.ast, :node($/) );
2325
}
2326
2327
method circumfix:sym<sigil>($/) {
2328
my $name := ~$<sigil> eq '@' ?? 'list' !!
2329
~$<sigil> eq '%' ?? 'hash' !!
2330
'item';
2331
make PAST::Op.new( :pasttype('callmethod'), :name($name), $<semilist>.ast );
2332
}
2333
2334
## Expressions
2335
2336
method EXPR($/, $key?) {
2337
unless $key { return 0; }
2338
if $/<drop> { make PAST::Stmts.new(); return 0; }
2339
my $past := $/.ast // $<OPER>.ast;
2340
my $sym := ~$<infix><sym>;
2341
if !$past && $sym eq '.=' {
2342
make make_dot_equals($/[0].ast, $/[1].ast);
2343
return 1;
2344
}
2345
elsif $sym eq '==>' || $sym eq '<==' || $sym eq '==>>' || $sym eq '<<==' {
2346
make make_feed($/);
2347
return 1;
2348
}
2349
elsif $sym eq '~~' {
2350
make make_smartmatch($/, 0);
2351
return 1;
2352
}
2353
elsif $sym eq '!~~' {
2354
make make_smartmatch($/, 1);
2355
return 1;
2356
}
2357
unless $past {
2358
$past := PAST::Op.new( :node($/) );
2359
if $<OPER><O><pasttype> { $past.pasttype( ~$<OPER><O><pasttype> ); }
2360
elsif $<OPER><O><pirop> { $past.pirop( ~$<OPER><O><pirop> ); }
2361
unless $past.name {
2362
if $key eq 'LIST' { $key := 'infix'; }
2363
my $name := Q:PIR {
2364
$P0 = find_lex '$key'
2365
$S0 = $P0
2366
$S0 = downcase $S0
2367
%r = box $S0
2368
} ~ ':<' ~ $<OPER><sym> ~ '>';
2369
$past.name('&' ~ $name);
2370
}
2371
}
2372
if $key eq 'POSTFIX' {
2373
my $inv := $/[0].ast;
2374
$past.unshift(
2375
PAST::Op.ACCEPTS($past) && $past.pasttype eq 'callmethod'
2376
?? PAST::Op.new( :pirop('deref_unless_object PP'), $inv, :returns($inv.returns), :arity($inv.arity) )
2377
!! $inv
2378
);
2379
}
2380
else {
2381
for $/.list { if $_.ast { $past.push($_.ast); } }
2382
}
2383
if $sym eq '^^' || $sym eq 'xor' {
2384
$past := PAST::Op.new(
2385
:pasttype<call>, :name('!Undef_to_False'), $past
2386
);
2387
}
2388
if $key eq 'PREFIX' || $key eq 'INFIX' || $key eq 'POSTFIX' {
2389
$past := whatever_curry($/, $past, $key eq 'INFIX' ?? 2 !! 1);
2390
}
2391
make $past;
2392
}
2393
2394
sub make_feed($/) {
2395
# Assemble into list of AST of each step in the pipeline.
2396
my @stages;
2397
if $/<infix><sym> eq '==>' {
2398
for @($/) { @stages.push($_.ast); }
2399
}
2400
elsif $/<infix><sym> eq '<==' {
2401
for @($/) { @stages.unshift($_.ast); }
2402
}
2403
else {
2404
$/.CURSOR.panic('Sorry, the ' ~ $/<infix> ~ ' feed operator is not yet implemented');
2405
}
2406
2407
# Check what's in each stage and make a chain of blocks
2408
# that call each other. They'll return lazy things, which
2409
# will be passed in as var-arg parts to other things. The
2410
# first thing is just considered the result.
2411
my $result := @stages.shift;
2412
for @stages {
2413
# Wrap current result in a block, so it's thunked and can be
2414
# called at the right point.
2415
$result := PAST::Block.new( $result );
2416
2417
# Check what we have. XXX Real first step should be looking
2418
# for @(*) since if we find that it overrides all other things.
2419
# But that's todo...soon. :-)
2420
if $_ ~~ PAST::Op && $_.pasttype eq 'call' {
2421
# It's a call. Stick a call to the current supplier in
2422
# as its last argument.
2423
$_.push(PAST::Op.new( :pasttype('call'), $result ));
2424
}
2425
elsif $_ ~~ PAST::Var {
2426
# It's a variable. We need code that gets the results, pushes
2427
# them onto the variable and then returns them (since this
2428
# could well be a tap.
2429
$_ := PAST::Stmts.new(
2430
PAST::Op.new(
2431
:pasttype('bind'),
2432
PAST::Var.new( :scope('register'), :name('tmp'), :isdecl(1) ),
2433
PAST::Op.new( :pasttype('call'), $result )
2434
),
2435
PAST::Op.new(
2436
:pasttype('callmethod'), :name('push'),
2437
$_,
2438
PAST::Var.new( :scope('register'), :name('tmp') )
2439
),
2440
PAST::Var.new( :scope('register'), :name('tmp') )
2441
);
2442
}
2443
else {
2444
$/.CURSOR.panic('Sorry, do not know how to handle this case of a feed operator yet.');
2445
}
2446
$result := $_;
2447
}
2448
2449
return $result;
2450
}
2451
2452
sub make_smartmatch($/, $negated) {
2453
my $lhs := $/[0].ast;
2454
my $rhs := $/[1].ast;
2455
my $old_topic_var := $lhs.unique('old_topic');
2456
my $result_var := $lhs.unique('sm_result');
2457
PAST::Op.new(
2458
:pasttype('stmts'),
2459
2460
# Stash original $_.
2461
PAST::Op.new( :pasttype('bind'),
2462
PAST::Var.new( :name($old_topic_var), :scope('register'), :isdecl(1) ),
2463
PAST::Var.new( :name('$_'), :scope('lexical') )
2464
),
2465
2466
# Evaluate LHS and bind it to $_.
2467
PAST::Op.new( :pasttype('bind'),
2468
PAST::Var.new( :name('$_'), :scope('lexical') ),
2469
$lhs
2470
),
2471
2472
# Evaluate RHS and call ACCEPTS on it, passing in $_. Bind the
2473
# return value to a result variable.
2474
PAST::Op.new( :pasttype('bind'),
2475
PAST::Var.new( :name($result_var), :scope('lexical'), :isdecl(1) ),
2476
PAST::Op.new( :pasttype('call'), :name('&coerce-smartmatch-result'),
2477
PAST::Op.new( :pasttype('callmethod'), :name('ACCEPTS'),
2478
$rhs,
2479
PAST::Var.new( :name('$_'), :scope('lexical') )
2480
),
2481
$negated
2482
)
2483
),
2484
2485
# Re-instate original $_.
2486
PAST::Op.new( :pasttype('bind'),
2487
PAST::Var.new( :name('$_'), :scope('lexical') ),
2488
PAST::Var.new( :name($old_topic_var), :scope('register') )
2489
),
2490
2491
# And finally evaluate to the smart-match result.
2492
PAST::Var.new( :name($result_var), :scope('lexical') )
2493
);
2494
}
2495
2496
method prefixish($/) {
2497
if $<prefix_postfix_meta_operator> {
2498
my $opsub := '&prefix:<' ~ $<OPER>.Str ~ '<<>';
2499
unless %*METAOPGEN{$opsub} {
2500
my $base_op := '&prefix:<' ~ $<OPER>.Str ~ '>';
2501
$*UNITPAST.loadinit.push(PAST::Op.new(
2502
:pasttype('bind'),
2503
PAST::Var.new( :name($opsub), :scope('package') ),
2504
PAST::Op.new(
2505
:pasttype('callmethod'), :name('assuming'),
2506
PAST::Op.new( :pirop('find_sub_not_null__Ps'), '&hyper' ),
2507
PAST::Op.new( :pirop('find_sub_not_null__Ps'), $base_op )
2508
)
2509
));
2510
%*METAOPGEN{$opsub} := 1;
2511
}
2512
make PAST::Op.new( :name($opsub), :pasttype('call') );
2513
}
2514
}
2515
2516
method infixish($/) {
2517
if $<infix_postfix_meta_operator> {
2518
my $sym := ~$<infix><sym>;
2519
my $opsub := "&infix:<$sym=>";
2520
unless %*METAOPGEN{$opsub} {
2521
$*UNITPAST.loadinit.push(
2522
PAST::Op.new( :name('!gen_assign_metaop'), $sym,
2523
:pasttype('call') )
2524
);
2525
%*METAOPGEN{$opsub} := 1;
2526
}
2527
make PAST::Op.new( :name($opsub), :pasttype('call') );
2528
}
2529
2530
if $<infix_prefix_meta_operator> {
2531
my $metaop := ~$<infix_prefix_meta_operator><sym>;
2532
my $sym := ~$<infix_prefix_meta_operator><infixish><OPER>;
2533
my $opsub := "&infix:<$/>";
2534
my $base_opsub := "&infix:<$sym>";
2535
if $opsub eq "&infix:<!=>" {
2536
$base_opsub := "&infix:<==>";
2537
}
2538
unless %*METAOPGEN{$opsub} {
2539
my $helper := "";
2540
if $metaop eq '!' {
2541
$helper := '&negate';
2542
} elsif $metaop eq 'R' {
2543
$helper := '&reverseargs';
2544
} elsif $metaop eq 'S' {
2545
$helper := '&sequentialargs';
2546
} elsif $metaop eq 'X' {
2547
$helper := '&crosswith';
2548
} elsif $metaop eq 'Z' {
2549
$helper := '&zipwith';
2550
}
2551
2552
$*UNITPAST.loadinit.push(
2553
PAST::Op.new( :pasttype('bind'),
2554
PAST::Var.new( :name($opsub), :scope('package') ),
2555
PAST::Op.new( :pasttype('callmethod'),
2556
:name('assuming'),
2557
PAST::Op.new( :pirop('find_sub_not_null__Ps'),
2558
$helper ),
2559
PAST::Op.new( :pirop('find_sub_not_null__Ps'),
2560
$base_opsub ) ) ) );
2561
%*METAOPGEN{$opsub} := 1;
2562
}
2563
2564
make PAST::Op.new( :name($opsub), :pasttype('call') );
2565
}
2566
2567
if $<infixish> {
2568
make $<infixish>.ast;
2569
}
2570
}
2571
2572
method prefix_circumfix_meta_operator:sym<reduce>($/) {
2573
my $opsub := '&prefix:<' ~ ~$/ ~ '>';
2574
unless %*METAOPGEN{$opsub} {
2575
my $base_op := '&infix:<' ~ $<op><OPER>.Str ~ '>';
2576
$*UNITPAST.loadinit.push(PAST::Op.new(
2577
:pasttype('bind'),
2578
PAST::Var.new( :name($opsub), :scope('package') ),
2579
PAST::Op.new(
2580
:pasttype('callmethod'), :name('assuming'),
2581
PAST::Op.new( :pirop('find_sub_not_null__Ps'), '&reducewith' ),
2582
PAST::Op.new( :pirop('find_sub_not_null__Ps'), $base_op ),
2583
PAST::Val.new( :named('triangle'), :value($<triangle> ?? 1 !! 0) ),
2584
PAST::Val.new( :named('chaining'), :value($<op><OPER><O><prec> eq 'm=') ),
2585
PAST::Val.new( :named('right-assoc'), :value($<op><OPER><O><assoc> eq 'right') ),
2586
PAST::Val.new( :named('xor'), :value($<op><OPER><O><pasttype> eq 'xor') )
2587
)
2588
));
2589
%*METAOPGEN{$opsub} := 1;
2590
}
2591
make PAST::Op.new( :name($opsub), :pasttype('call') );
2592
}
2593
2594
method infix_circumfix_meta_operator:sym«<< >>»($/) {
2595
make make_hyperop($/);
2596
}
2597
2598
method infix_circumfix_meta_operator:sym<« »>($/) {
2599
make make_hyperop($/);
2600
}
2601
2602
sub make_hyperop($/) {
2603
my $opsub := '&infix:<' ~ ~$/ ~ '>';
2604
unless %*METAOPGEN{$opsub} {
2605
my $base_op := '&infix:<' ~ $<infixish>.Str ~ '>';
2606
my $dwim_lhs := $<opening> eq '<<' || $<opening> eq '«';
2607
my $dwim_rhs := $<closing> eq '>>' || $<closing> eq '»';
2608
$*UNITPAST.loadinit.push(PAST::Op.new(
2609
:pasttype('bind'),
2610
PAST::Var.new( :name($opsub), :scope('package') ),
2611
PAST::Op.new(
2612
:pasttype('callmethod'), :name('assuming'),
2613
PAST::Op.new( :pirop('find_sub_not_null__Ps'), '&hyper' ),
2614
PAST::Op.new( :pirop('find_sub_not_null__Ps'), $base_op ),
2615
PAST::Val.new( :value($dwim_lhs), :named('dwim-left') ),
2616
PAST::Val.new( :value($dwim_rhs), :named('dwim-right') )
2617
)
2618
));
2619
%*METAOPGEN{$opsub} := 1;
2620
}
2621
return PAST::Op.new( :name($opsub), :pasttype('call') );
2622
}
2623
2624
method postfixish($/) {
2625
if $<postfix_prefix_meta_operator> {
2626
my $past := $<OPER>.ast;
2627
if $past && $past.isa(PAST::Op) && $past.pasttype() eq 'call' {
2628
if ($past.name() eq '') {
2629
$past.name('!dispatch_invocation_parallel');
2630
}
2631
else {
2632
$past.unshift($past.name());
2633
$past.name('!dispatch_dispatcher_parallel');
2634
}
2635
}
2636
elsif $past && $past.isa(PAST::Op) && $past.pasttype() eq 'callmethod' {
2637
$past.unshift($past.name());
2638
$past.name('!dispatch_method_parallel');
2639
$past.pasttype('call');
2640
}
2641
else {
2642
# Hyper-op over a normal postfix.
2643
my $opsub := '&postfix:<>>' ~ $<OPER>.Str ~ '>';
2644
unless %*METAOPGEN{$opsub} {
2645
my $base_op := '&postfix:<' ~ $<OPER>.Str ~ '>';
2646
$*UNITPAST.loadinit.push(PAST::Op.new(
2647
:pasttype('bind'),
2648
PAST::Var.new( :name($opsub), :scope('package') ),
2649
PAST::Op.new(
2650
:pasttype('callmethod'), :name('assuming'),
2651
PAST::Op.new( :pirop('find_sub_not_null__Ps'), '&hyper' ),
2652
PAST::Op.new( :pirop('find_sub_not_null__Ps'), $base_op )
2653
)
2654
));
2655
%*METAOPGEN{$opsub} := 1;
2656
}
2657
$past := PAST::Op.new( :name($opsub), :pasttype('call') );
2658
}
2659
make $past;
2660
}
2661
}
2662
2663
method postcircumfix:sym<[ ]>($/) {
2664
my $past := PAST::Op.new( :name('!postcircumfix:<[ ]>'), :pasttype('call'), :node($/) );
2665
if $<semilist><statement> { $past.push($<semilist>.ast); }
2666
make $past;
2667
}
2668
2669
method postcircumfix:sym<{ }>($/) {
2670
my $past := PAST::Op.new( :name('!postcircumfix:<{ }>'), :pasttype('call'), :node($/) );
2671
if $<semilist><statement> {
2672
if +$<semilist><statement> > 1 {
2673
$/.CURSOR.panic("Sorry, multi-dimensional indexes are not yet supported");
2674
}
2675
$past.push($<semilist>.ast);
2676
}
2677
make $past;
2678
}
2679
2680
method postcircumfix:sym<ang>($/) {
2681
my $past := PAST::Op.new( :name('!postcircumfix:<{ }>'), :pasttype('call'), :node($/) );
2682
$past.push( $<quote_EXPR>.ast )
2683
if +$<quote_EXPR><quote_delimited><quote_atom> > 0;
2684
make $past;
2685
}
2686
2687
method postcircumfix:sym<( )>($/) {
2688
make $<arglist>.ast;
2689
}
2690
2691
method value:sym<quote>($/) {
2692
make $<quote>.ast;
2693
}
2694
2695
method value:sym<number>($/) {
2696
make $<number>.ast;
2697
}
2698
2699
method number:sym<complex>($/) {
2700
make PAST::Op.new(
2701
:pasttype('callmethod'), :name('new'),
2702
PAST::Var.new( :name('Complex'), :namespace(''), :scope('package') ),
2703
($<re> ?? $<re>.ast !! 0), $<im>.ast
2704
);
2705
}
2706
2707
method number:sym<numish>($/) {
2708
make $<numish>.ast;
2709
}
2710
2711
method numish($/) {
2712
if $<integer> { make PAST::Val.new( :value($<integer>.ast), :returns('Int') ); }
2713
elsif $<dec_number> { make $<dec_number>.ast; }
2714
elsif $<rad_number> { make $<rad_number>.ast; }
2715
else {
2716
make PAST::Var.new( :name(~$/), :namespace(''), :scope('package') );
2717
}
2718
}
2719
2720
method dec_number($/) {
2721
my $int := $<int> ?? ~$<int> !! "0";
2722
my $frac := $<frac> ?? ~$<frac> !! "0";
2723
if $<escale> {
2724
my $exp := ~$<escale>[0]<decint>;
2725
make PAST::Op.new(
2726
:pasttype('call'),
2727
PAST::Var.new(:scope('package'), :name('&str2num-num'), :namespace('Str')),
2728
0, $int, $frac, ($<escale>[0]<sign> eq '-'), $exp
2729
);
2730
} else {
2731
make PAST::Op.new(
2732
:pasttype('call'),
2733
PAST::Var.new(:scope('package'), :name('&str2num-rat'), :namespace('Str')),
2734
0, $int, $frac
2735
);
2736
}
2737
}
2738
2739
method rad_number($/) {
2740
my $radix := +($<radix>.Str);
2741
if $<circumfix> {
2742
make PAST::Op.new(:name('&radcalc'), :pasttype('call'),
2743
$radix, $<circumfix>.ast);
2744
} else {
2745
my $intpart := $<intpart>.Str;
2746
my $fracpart := $<fracpart> ?? $<fracpart>.Str !! "0";
2747
my $intfrac := $intpart ~ $fracpart; #the dot is a part of $fracpart, so no need for ~ "." ~
2748
my $base := $<base> ?? +($<base>[0].Str) !! 0;
2749
my $exp := $<exp> ?? +($<exp>[0].Str) !! 0;
2750
2751
make PAST::Op.new( :name('&radcalc'), :pasttype('call'),
2752
$radix, $intfrac, $base, $exp
2753
);
2754
}
2755
}
2756
2757
method typename($/) {
2758
my $past;
2759
2760
if is_lexical($<longname>.Str) {
2761
# We need to build a thunk.
2762
my $sig := Perl6::Compiler::Signature.new(
2763
Perl6::Compiler::Parameter.new(:var_name('$_')));
2764
$past := make_block_from(
2765
$sig,
2766
PAST::Op.new( :pasttype('callmethod'), :name('ACCEPTS'),
2767
PAST::Var.new(:name($<longname>.Str),:scope('lexical')),
2768
PAST::Var.new(:name('$_'), :scope('lexical') ) ),
2769
'Block'
2770
);
2771
}
2772
else {
2773
my @name := Perl6::Grammar::parse_name($<longname>.Str);
2774
$past := PAST::Var.new(
2775
:name(@name.pop),
2776
:namespace(@name),
2777
:scope('package')
2778
);
2779
}
2780
2781
# Parametric type?
2782
if $<arglist> {
2783
my $args := $<arglist>[0].ast;
2784
$args.pasttype('callmethod');
2785
$args.name('!select');
2786
$args.unshift($past);
2787
$past := $args;
2788
}
2789
if $<typename> {
2790
$past := PAST::Op.new(
2791
:pasttype('callmethod'), :name('!select'),
2792
$past, $<typename>[0].ast
2793
);
2794
}
2795
2796
make $past;
2797
}
2798
2799
our %SUBST_ALLOWED_ADVERBS;
2800
our %SHARED_ALLOWED_ADVERBS;
2801
our %MATCH_ALLOWED_ADVERBS;
2802
INIT {
2803
my $mods := 'i ignorecase s sigspace r ratchet';
2804
for pir::split__PSS(' ', $mods) {
2805
%SHARED_ALLOWED_ADVERBS{$_} := 1;
2806
}
2807
2808
$mods := 'g global ii samecase x c continue p pos nth th st nd rd';
2809
for pir::split__PSS(' ', $mods) {
2810
%SUBST_ALLOWED_ADVERBS{$_} := 1;
2811
}
2812
2813
# TODO: add g global ov overlap once they actually work
2814
$mods := 'x c continue p pos nth th st nd rd';
2815
for pir::split__PSS(' ', $mods) {
2816
%MATCH_ALLOWED_ADVERBS{$_} := 1;
2817
}
2818
}
2819
2820
2821
method quotepair($/) {
2822
unless $*value ~~ PAST::Node {
2823
if ($*key eq 'c' || $*key eq 'continue'
2824
|| $*key eq 'p' || $*key eq 'pos') && $*value == 1 {
2825
$*value := PAST::Op.new(
2826
:node($/),
2827
:pasttype<if>,
2828
PAST::Var.new(:name('$/'), :scope('lexical')),
2829
PAST::Op.new(:pasttype('callmethod'),
2830
PAST::Var.new(:name('$/'), :scope<lexical>),
2831
:name<to>
2832
),
2833
PAST::Val.new(:value(0)),
2834
);
2835
} else {
2836
$*value := PAST::Val.new( :value($*value) );
2837
}
2838
}
2839
$*value.named(~$*key);
2840
make $*value;
2841
}
2842
2843
method setup_quotepairs($/) {
2844
my %h;
2845
for @*REGEX_ADVERBS {
2846
my $key := $_.ast.named;
2847
my $value := $_.ast;
2848
if $value ~~ PAST::Val {
2849
$value := $value.value;
2850
} else {
2851
if %SHARED_ALLOWED_ADVERBS{$key} {
2852
$/.CURSOR.panic('Value of adverb :' ~ $key ~ ' must be known at compile time');
2853
}
2854
}
2855
if $key eq 'samecase' || $key eq 'ii' {
2856
%h{'i'} := 1;
2857
}
2858
%h{$key} := $value;
2859
}
2860
2861
my @MODIFIERS := Q:PIR {
2862
%r = get_hll_global ['Regex';'P6Regex';'Actions'], '@MODIFIERS'
2863
};
2864
@MODIFIERS.unshift(%h);
2865
}
2866
2867
method cleanup_modifiers($/) {
2868
my @MODIFIERS := Q:PIR {
2869
%r = get_hll_global ['Regex';'P6Regex';'Actions'], '@MODIFIERS'
2870
};
2871
@MODIFIERS.shift();
2872
2873
}
2874
2875
method quote:sym<apos>($/) { make $<quote_EXPR>.ast; }
2876
method quote:sym<dblq>($/) { make $<quote_EXPR>.ast; }
2877
method quote:sym<qq>($/) { make $<quote_EXPR>.ast; }
2878
method quote:sym<qw>($/) { make $<quote_EXPR>.ast; }
2879
method quote:sym<q>($/) { make $<quote_EXPR>.ast; }
2880
method quote:sym<Q>($/) { make $<quote_EXPR>.ast; }
2881
method quote:sym<Q:PIR>($/) {
2882
if $FORBID_PIR {
2883
pir::die("Q:PIR forbidden in safe mode\n");
2884
}
2885
make PAST::Op.new( :inline( $<quote_EXPR>.ast.value ),
2886
:pasttype('inline'),
2887
:node($/) );
2888
}
2889
method quote:sym<qx>($/) {
2890
make PAST::Op.new( :name('!qx'), :pasttype('call'),
2891
$<quote_EXPR>.ast
2892
);
2893
}
2894
method quote:sym<qqx>($/) {
2895
make PAST::Op.new( :name('!qx'), :pasttype('call'),
2896
$<quote_EXPR>.ast
2897
);
2898
}
2899
method quote:sym</ />($/) {
2900
my $past := Regex::P6Regex::Actions::buildsub($<p6regex>.ast);
2901
make block_closure($past, 'Regex', 0);
2902
}
2903
method quote:sym<rx>($/) {
2904
2905
self.handle_and_check_adverbs($/, %SHARED_ALLOWED_ADVERBS, 'rx');
2906
my $past := Regex::P6Regex::Actions::buildsub($<p6regex>.ast);
2907
make block_closure($past, 'Regex', 0);
2908
}
2909
method quote:sym<m>($/) {
2910
$regex := Regex::P6Regex::Actions::buildsub($<p6regex>.ast);
2911
my $regex := block_closure($regex, 'Regex', 0);
2912
2913
my $past := PAST::Op.new(
2914
:node($/),
2915
:pasttype('callmethod'), :name('match'),
2916
PAST::Var.new( :name('$_'), :scope('lexical') ),
2917
$regex
2918
);
2919
self.handle_and_check_adverbs($/, %MATCH_ALLOWED_ADVERBS, 'm', $past);
2920
$past := PAST::Op.new(
2921
:node($/),
2922
:pasttype('call'), :name('&infix:<:=>'),
2923
PAST::Var.new(:name('$/'), :scope('lexical')),
2924
$past
2925
);
2926
2927
make $past;
2928
}
2929
2930
method handle_and_check_adverbs($/, %adverbs, $what, $past?) {
2931
for $<quotepair> {
2932
unless %SHARED_ALLOWED_ADVERBS{$_.ast.named} || %adverbs{$_.ast.named} {
2933
$/.CURSOR.panic("Adverb '" ~ $_.ast.named ~ "' not allowed on " ~ $what);
2934
}
2935
if $past {
2936
$past.push($_.ast);
2937
}
2938
}
2939
}
2940
2941
method quote:sym<s>($/) {
2942
# Build the regex.
2943
my $regex_ast := Regex::P6Regex::Actions::buildsub($<p6regex>.ast);
2944
my $regex := block_closure($regex_ast, 'Regex', 0);
2945
2946
# Quote needs to be closure-i-fied.
2947
my $closure_ast := PAST::Block.new(
2948
PAST::Stmts.new(),
2949
PAST::Stmts.new(
2950
$<quote_EXPR> ?? $<quote_EXPR>.ast !! $<EXPR>.ast
2951
)
2952
);
2953
my $closure := block_closure($closure_ast, 'Block', 0);
2954
2955
# make $_ = $_.subst(...)
2956
my $past := PAST::Op.new(
2957
:node($/),
2958
:pasttype('callmethod'), :name('subst'),
2959
PAST::Var.new( :name('$_'), :scope('lexical') ),
2960
$regex, $closure
2961
);
2962
self.handle_and_check_adverbs($/, %SUBST_ALLOWED_ADVERBS, 'substitution', $past);
2963
if $/[0] {
2964
pir::push__vPP($past, PAST::Val.new(:named('samespace'), :value(1)));
2965
}
2966
2967
$past := PAST::Op.new(
2968
:node($/),
2969
:pasttype('call'),
2970
:name('&infix:<=>'),
2971
PAST::Var.new(:name('$_'), :scope('lexical')),
2972
$past
2973
);
2974
2975
make $past;
2976
}
2977
2978
method quote_escape:sym<$>($/) {
2979
make steal_back_spaces($/, PAST::Op.new( $<EXPR>.ast, :pirop('set SP') ));
2980
}
2981
2982
method quote_escape:sym<array>($/) {
2983
make steal_back_spaces($/, PAST::Op.new( $<EXPR>.ast, :pirop('set SP') ));
2984
}
2985
2986
method quote_escape:sym<%>($/) {
2987
make steal_back_spaces($/, PAST::Op.new( $<EXPR>.ast, :pirop('set SP') ));
2988
}
2989
2990
method quote_escape:sym<&>($/) {
2991
make steal_back_spaces($/, PAST::Op.new( $<EXPR>.ast, :pirop('set SP') ));
2992
}
2993
2994
# Unfortunately, the operator precedence parser (probably correctly)
2995
# steals spaces after a postfixish. Thus "$a $b" would get messed up.
2996
# Here we take them back again. Hacky, better solutions welcome.
2997
sub steal_back_spaces($/, $expr) {
2998
my $pos := pir::length__IS($/) - 1;
2999
while pir::is_cclass__IISI(32, $/, $pos) {
3000
$pos--;
3001
}
3002
my $nab_back := pir::substr__SSI($/, $pos + 1);
3003
if $nab_back {
3004
PAST::Op.new( :pasttype('call'), :name('&infix:<~>'), $expr, ~$nab_back )
3005
}
3006
else {
3007
$expr
3008
}
3009
}
3010
3011
method quote_escape:sym<{ }>($/) {
3012
make PAST::Op.new(
3013
:pirop('set S*'), block_immediate($<block>.ast), :node($/)
3014
);
3015
}
3016
3017
# overrides versions from HLL::Actions to handle Perl6Str
3018
# and use &infix:<,> to build the parcel
3019
method quote_EXPR($/) {
3020
my $past := $<quote_delimited>.ast;
3021
if $/.CURSOR.quotemod_check('w') {
3022
if !$past.isa(PAST::Val) {
3023
$/.CURSOR.panic("Cannot form :w list from non-constant strings (yet)");
3024
}
3025
else {
3026
my @words := HLL::Grammar::split_words($/, $past.value);
3027
if +@words != 1 {
3028
$past := PAST::Op.new( :name('&infix:<,>'), :node($/) );
3029
for @words { $past.push($_); }
3030
$past := PAST::Stmts.new($past);
3031
}
3032
else {
3033
$past := PAST::Val.new( :value(~@words[0]), :returns('Str') );
3034
}
3035
}
3036
}
3037
make $past;
3038
}
3039
3040
method quote_delimited($/) {
3041
my @parts;
3042
my $lastlit := '';
3043
for $<quote_atom> {
3044
my $ast := $_.ast;
3045
if !PAST::Node.ACCEPTS($ast) {
3046
$lastlit := $lastlit ~ $ast;
3047
}
3048
elsif $ast.isa(PAST::Val) {
3049
$lastlit := $lastlit ~ $ast.value;
3050
}
3051
else {
3052
if $lastlit gt '' {
3053
@parts.push(
3054
PAST::Val.new( :value($lastlit), :returns('Str') )
3055
);
3056
}
3057
@parts.push($ast);
3058
$lastlit := '';
3059
}
3060
}
3061
if $lastlit gt '' || !@parts {
3062
@parts.push(
3063
PAST::Val.new( :value($lastlit), :returns('Str') )
3064
);
3065
}
3066
my $past := @parts ?? @parts.shift !! '';
3067
while @parts {
3068
$past := PAST::Op.new( $past, @parts.shift, :pirop('concat') );
3069
}
3070
make $past;
3071
}
3072
3073
## Operators
3074
3075
class Perl6::RegexActions is Regex::P6Regex::Actions {
3076
3077
method metachar:sym<:my>($/) {
3078
my $past := $<statement>.ast;
3079
make PAST::Regex.new( $past, :pasttype('pastnode') );
3080
}
3081
3082
method metachar:sym<{ }>($/) {
3083
make PAST::Regex.new( $<codeblock>.ast,
3084
:pasttype<pastnode>, :node($/) );
3085
}
3086
3087
method metachar:sym<rakvar>($/) {
3088
make PAST::Regex.new( '!INTERPOLATE', $<var>.ast,
3089
:pasttype<subrule>, :subtype<method>, :node($/));
3090
}
3091
3092
method assertion:sym<{ }>($/) {
3093
make PAST::Regex.new( '!INTERPOLATE',
3094
PAST::Op.new( :name<!MAKE_REGEX>, $<codeblock>.ast ),
3095
:pasttype<subrule>, :subtype<method>, :node($/));
3096
}
3097
3098
method assertion:sym<?{ }>($/) {
3099
make PAST::Regex.new( $<codeblock>.ast,
3100
:subtype<zerowidth>, :negate( $<zw> eq '!' ),
3101
:pasttype<pastnode>, :node($/) );
3102
}
3103
3104
method assertion:sym<var>($/) {
3105
make PAST::Regex.new( '!INTERPOLATE',
3106
PAST::Op.new( :name<!MAKE_REGEX>, $<var>.ast ),
3107
:pasttype<subrule>, :subtype<method>, :node($/));
3108
}
3109
3110
method codeblock($/) {
3111
my $block := Perl6::Actions::block_immediate($<block>.ast);
3112
my $past :=
3113
PAST::Stmts.new(
3114
PAST::Op.new(
3115
PAST::Var.new( :name('$/') ),
3116
PAST::Op.new(
3117
PAST::Var.new( :name('$¢') ),
3118
:name('MATCH'),
3119
:pasttype('callmethod')
3120
),
3121
:pasttype('bind')
3122
),
3123
$block
3124
);
3125
make $past;
3126
}
3127
3128
method p6arglist($/) {
3129
my $arglist := $<arglist>.ast;
3130
make $arglist;
3131
}
3132
3133
}
3134
3135
# Takes a block and adds a signature to it, as well as code to bind the call
3136
# capture against the signature. Returns the modified block.
3137
sub add_signature($block, $sig_obj) {
3138
# Set arity.
3139
$block.arity($sig_obj.arity);
3140
3141
# Add call to signature binder as well as lexical declarations
3142
# to the start of the block.
3143
$block[0].push(PAST::Var.new( :name('call_sig'), :scope('parameter'), :call_sig(1) ));
3144
my $decls := $sig_obj.get_declarations();
3145
for @($decls) {
3146
if $_.isa(PAST::Var) {
3147
$_.isdecl(1);
3148
$block.symbol( $_.name, :scope('lexical') );
3149
}
3150
}
3151
$block[0].push($decls);
3152
$block[0].push(PAST::Op.new(
3153
:pirop('bind_llsig vP'),
3154
PAST::Var.new( :name('call_sig'), :scope('lexical') )
3155
));
3156
3157
# make signature setup block
3158
my $lazysig := PAST::Block.new(:blocktype<declaration>, $sig_obj.ast(1));
3159
$block[0].push($lazysig);
3160
$block<lazysig> := PAST::Val.new( :value($lazysig) );
3161
$block;
3162
}
3163
3164
# Makes a lazy signature building block.
3165
sub make_lazy_sig_block($block) {
3166
my $sig_setup_block :=
3167
PAST::Block.new( :blocktype<declaration>, $block<signature_ast> );
3168
$block[0].push($sig_setup_block);
3169
PAST::Val.new(:value($sig_setup_block));
3170
}
3171
3172
# Adds a placeholder parameter to this block's signature.
3173
sub add_placeholder_parameter($sigil, $ident, :$named, :$slurpy_pos, :$slurpy_named) {
3174
our @BLOCK;
3175
my $block := @BLOCK[0];
3176
3177
# Add entry to the block signature.
3178
my $placeholder_sig := $block<placeholder_sig>;
3179
unless pir::defined__IP($placeholder_sig) {
3180
$block<placeholder_sig> := $placeholder_sig := Perl6::Compiler::Signature.new();
3181
}
3182
my $param := Perl6::Compiler::Parameter.new();
3183
$param.var_name(~$sigil ~ ~$ident);
3184
$param.pos_slurpy($slurpy_pos);
3185
$param.named_slurpy($slurpy_named);
3186
if $named { $param.names.push($ident) }
3187
$placeholder_sig.add_placeholder_parameter($param);
3188
3189
# Just want a lookup of the variable here.
3190
return PAST::Var.new( :name(~$sigil ~ ~$ident), :scope('lexical') );
3191
}
3192
3193
# Looks through the blocks for the first one with a signature and returns
3194
# that signature.
3195
sub get_nearest_signature() {
3196
for @BLOCK {
3197
if pir::defined__IP($_<signature>) {
3198
return $_<signature>;
3199
}
3200
}
3201
Perl6::Compiler::Signature.new()
3202
}
3203
3204
3205
sub blockref($block) {
3206
my $ref := PAST::Val.new( :value($block) );
3207
$ref<block_past> := $block;
3208
$ref<lazysig> := $block<lazysig>;
3209
$ref;
3210
}
3211
3212
# Returns the (static) code object for a block.
3213
# Note that it never holds the block directly -- it's always
3214
# obtained by reference.
3215
sub block_code($block, $type = 'Block', $multiness?) {
3216
my @name := Perl6::Grammar::parse_name($type);
3217
my $past := PAST::Op.new(
3218
:pasttype('callmethod'),
3219
:name('!get_code'),
3220
PAST::Val.new( :value($block) ),
3221
PAST::Var.new( :name(@name.pop), :namespace(@name), :scope('package') )
3222
);
3223
$past.push($block<lazysig>) if pir::defined($block<lazysig>);
3224
$past.push($multiness) if $multiness;
3225
$past<block_past> := $block;
3226
$past<block_type> := $type;
3227
$past;
3228
}
3229
3230
# Returns the (dynamic) closure for a block. Unlike
3231
# block_code above, this *does* hold the block directly.
3232
sub block_closure($block, $type = 'Block', $multiness?) {
3233
my @name := Perl6::Grammar::parse_name($type);
3234
my $past := PAST::Op.new(
3235
:pasttype('callmethod'),
3236
:name('!get_closure'),
3237
$block,
3238
PAST::Var.new( :name(@name.pop), :namespace(@name), :scope('package') )
3239
);
3240
$past.push($block<lazysig>) if pir::defined($block<lazysig>);
3241
$past.push($multiness) if pir::defined($multiness);
3242
$past<block_past> := $block;
3243
$past<block_type> := $type;
3244
$past;
3245
}
3246
3247
# Returns the (dynamic) closure for a block, taking a reference
3248
# to it rather than holding it directly.
3249
sub block_ref_closure($block, $type = 'Block', $multiness?) {
3250
my @name := Perl6::Grammar::parse_name($type);
3251
my $past := PAST::Op.new(
3252
:pasttype('callmethod'),
3253
:name('!get_closure'),
3254
PAST::Val.new( :value($block) ),
3255
PAST::Var.new( :name(@name.pop), :namespace(@name), :scope('package') )
3256
);
3257
$past.push($block<lazysig>) if pir::defined($block<lazysig>);
3258
$past.push($multiness) if pir::defined($multiness);
3259
$past<block_past> := $block;
3260
$past<block_type> := $type;
3261
$past;
3262
}
3263
3264
# Wraps a sub up in a block type.
3265
sub create_code_object($block, $type, $multiness) {
3266
my @name := Perl6::Grammar::parse_name($type);
3267
my $past := PAST::Op.new(
3268
:pasttype('callmethod'),
3269
:name('new'),
3270
PAST::Var.new( :name(@name.pop), :namespace(@name), :scope('package') ),
3271
$block,
3272
$multiness
3273
);
3274
$past.push($block<lazysig>) if pir::defined($block<lazysig>);
3275
$past<past_block> := $block;
3276
$past<block_class> := $type;
3277
$past.returns($type);
3278
$past.arity($block.arity);
3279
$past
3280
}
3281
3282
# This routine checks if the given list of traits contains one of the given
3283
# name. If so, it marks it as compiler handled so no multi call will be
3284
# emitted when we emit the traits. If there is such a trait, it returns it's
3285
# AST.
3286
sub has_compiler_trait($trait_list, $name) {
3287
if $trait_list {
3288
for $trait_list {
3289
my $ast := $_.ast;
3290
if $ast.name eq $name {
3291
$ast<trait_is_compiler_handled> := 1;
3292
return $ast;
3293
}
3294
}
3295
}
3296
return 0;
3297
}
3298
3299
3300
# This routine checks if the given list of traits contains one of the given
3301
# names and also that it carries the given value as a named parameter. If so,
3302
# it marks it as compiler handled so no multi call will be emitted when we emit
3303
# the traits. If there is such a trait, it returns it's AST.
3304
sub has_compiler_trait_with_val($trait_list, $name, $value) {
3305
if $trait_list {
3306
for $trait_list {
3307
my $ast := $_.ast;
3308
if $ast.name eq $name && $ast<is_name> eq $value {
3309
$ast<trait_is_compiler_handled> := 1;
3310
return $ast;
3311
}
3312
}
3313
}
3314
return 0;
3315
}
3316
3317
3318
# Emits routine traits into the loadinit for the routine.
3319
sub emit_routine_traits($routine, @trait_list, $type) {
3320
$routine.loadinit.push(
3321
PAST::Var.new(
3322
:name('trait_subject'), :scope('register'), :isdecl(1),
3323
:viviself(block_code($routine, $type, $*MULTINESS eq 'multi') ) )
3324
);
3325
for @trait_list {
3326
my $ast := $_.ast;
3327
$ast.unshift(PAST::Var.new( :name('trait_subject'), :scope('register') ));
3328
$routine.loadinit.push($ast);
3329
}
3330
}
3331
3332
3333
# Finds out which readtype trait we have, and marks all of the relevant ones
3334
# as compiler handled.
3335
sub trait_readtype($traits) {
3336
my $readtype;
3337
if has_compiler_trait_with_val($traits, '&trait_mod:<is>', 'readonly') {
3338
$readtype := 'readonly';
3339
}
3340
if has_compiler_trait_with_val($traits, '&trait_mod:<is>', 'rw') {
3341
$readtype := $readtype ?? 'CONFLICT' !! 'rw';
3342
}
3343
if has_compiler_trait_with_val($traits, '&trait_mod:<is>', 'copy') {
3344
$readtype := $readtype ?? 'CONFLICT' !! 'copy';
3345
}
3346
$readtype;
3347
}
3348
3349
3350
# Handles trait node on a block and setting up the ContainerDeclarand.
3351
sub get_var_traits_node($block, $name) {
3352
# Do we already have a traits node?
3353
my %symtab := $block.symbol($name);
3354
if %symtab<traits_node> {
3355
return %symtab<traits_node>;
3356
}
3357
3358
# Create one, in the viviself.
3359
my $decl := %symtab<decl_node>;
3360
my @cd_name := Perl6::Grammar::parse_name('ContainerDeclarand');
3361
my $traits_node := PAST::Stmts.new();
3362
my $vivinode := PAST::Stmts.new(
3363
PAST::Op.new( :pasttype('bind'),
3364
PAST::Var.new( :name('$P0'), :scope('register') ),
3365
$decl.viviself()
3366
),
3367
PAST::Op.new( :pasttype('bind'),
3368
PAST::Var.new( :name('declarand'), :scope('register'), :isdecl(1) ),
3369
PAST::Op.new(
3370
:pasttype('callmethod'), :name('new'),
3371
PAST::Var.new( :name(@cd_name.pop), :namespace(@cd_name), :scope('package') ),
3372
PAST::Var.new( :name('$P0'), :scope('register') ),
3373
PAST::Val.new( :value($name), :named('name') )
3374
)
3375
),
3376
$traits_node,
3377
PAST::Op.new( :inline(' %r = $P0') )
3378
);
3379
$decl.viviself($vivinode);
3380
$block.symbol($name, :traits_node($traits_node));
3381
$traits_node;
3382
}
3383
3384
sub add_implicit_var($block, $name, $outer) {
3385
my $base := $outer
3386
?? PAST::Op.new( :inline(" %r = new ['Perl6Scalar'], %0"),
3387
PAST::Op.new(:pirop('find_lex_skip_current Ps'), $name)
3388
)
3389
!! PAST::Op.new( :inline(" %r = new ['Perl6Scalar']") );
3390
$base := PAST::Op.new( $base, 'rw', $TRUE, :pirop('setprop') );
3391
$block[0].push(
3392
PAST::Var.new( :name($name), :scope('lexical'), :isdecl(1),
3393
:viviself($base) )
3394
);
3395
$block.symbol($name, :scope('lexical') );
3396
}
3397
3398
sub when_handler_helper($block) {
3399
our @BLOCK;
3400
my $BLOCK := @BLOCK[0];
3401
# XXX TODO: This isn't quite the right way to check this...
3402
unless $BLOCK.handlers() {
3403
my @handlers;
3404
@handlers.push(
3405
PAST::Control.new(
3406
PAST::Op.new(
3407
:pasttype('pirop'),
3408
:pirop('return'),
3409
PAST::Var.new(
3410
:scope('keyed'),
3411
PAST::Var.new( :name('exception'), :scope('register') ),
3412
'payload',
3413
),
3414
),
3415
:handle_types('BREAK')
3416
)
3417
);
3418
$BLOCK.handlers(@handlers);
3419
}
3420
3421
# push a control exception throw onto the end of the block so we
3422
# exit the innermost block in which $_ was set.
3423
my $last := $block.pop();
3424
$block.push(
3425
PAST::Op.new(
3426
:pasttype('call'),
3427
:name('&succeed'),
3428
$last
3429
)
3430
);
3431
3432
# Push a handler onto the block to handle CONTINUE exceptions so we can
3433
# skip throwing the BREAK exception
3434
my @handlers;
3435
if $block.handlers() {
3436
@handlers := $block.handlers();
3437
}
3438
@handlers.push(
3439
PAST::Control.new(
3440
PAST::Op.new(
3441
:pasttype('pirop'),
3442
:pirop('return'),
3443
),
3444
:handle_types('CONTINUE')
3445
)
3446
);
3447
$block.handlers(@handlers);
3448
}
3449
3450
sub make_dot_equals($thingy, $call) {
3451
$call.unshift($call.name);
3452
$call.unshift($thingy);
3453
$call.name('!dispatch_.=');
3454
$call.pasttype('call');
3455
$call;
3456
}
3457
3458
# XXX This isn't quite right yet... need to evaluate these semantics
3459
sub push_block_handler($/, $block, $handler) {
3460
unless $block.handlers() {
3461
$block.handlers([]);
3462
}
3463
$handler.blocktype('declaration');
3464
$handler := PAST::Block.new(
3465
:blocktype('declaration'),
3466
PAST::Var.new( :scope('parameter'), :name('$_') ),
3467
PAST::Op.new( :pasttype('bind'),
3468
PAST::Var.new( :scope('lexical'), :name('$_') ),
3469
PAST::Op.new(
3470
:pasttype('callmethod'),
3471
:name('new'),
3472
PAST::Var.new(
3473
:name('Exception'),
3474
:namespace([]),
3475
:scope('package'),
3476
),
3477
PAST::Var.new( :scope('lexical'), :name('$_') ),
3478
),
3479
),
3480
PAST::Op.new( :pasttype('bind'),
3481
PAST::Var.new( :scope('lexical'), :name('$!'), :isdecl(1) ),
3482
PAST::Var.new( :scope('lexical'), :name('$_') ),
3483
),
3484
PAST::Op.new( :pasttype('call'),
3485
$handler,
3486
),
3487
);
3488
$handler.symbol('$_', :scope('lexical'));
3489
$handler.symbol('$!', :scope('lexical'));
3490
$handler := PAST::Stmts.new(
3491
PAST::Op.new( :pasttype('call'),
3492
$handler,
3493
PAST::Var.new( :scope('register'), :name('exception') ),
3494
),
3495
# XXX Rakudo needs to set this when $! is inspected
3496
# We just cheat for now. Call .rethrow() if you want it rethrown.
3497
PAST::Op.new( :pasttype('bind'),
3498
PAST::Var.new( :scope('keyed'),
3499
PAST::Var.new( :scope('register'), :name('exception')),
3500
'handled'
3501
),
3502
1
3503
)
3504
);
3505
3506
$block.handlers.unshift(
3507
PAST::Control.new(
3508
:node($/),
3509
$handler,
3510
)
3511
);
3512
}
3513
3514
# Makes the closure for the RHS of has $.answer = 42.
3515
sub make_attr_init_closure($init_value) {
3516
# Build the closure and install the block in the current lexical
3517
# scope we're in, so it gets its outer right.
3518
my $block := PAST::Block.new(
3519
:blocktype('declaration'),
3520
PAST::Stmts.new( ),
3521
PAST::Stmts.new( $init_value )
3522
);
3523
$block[0].unshift(PAST::Var.new( :name('self'), :scope('lexical'), :isdecl(1), :viviself(sigiltype('$')) ));
3524
$block.symbol('self', :scope('lexical'));
3525
my $sig := Perl6::Compiler::Signature.new(
3526
Perl6::Compiler::Parameter.new(:var_name('$_')));
3527
$sig.add_invocant();
3528
add_signature($block, $sig);
3529
@BLOCK[0].push($block);
3530
3531
# Return a code object using a reference to the block.
3532
block_ref_closure($block, 'Method', 0);
3533
}
3534
3535
# Looks through the lexpads and sees if we recognize the symbol as a lexical.
3536
sub is_lexical($name) {
3537
our @BLOCK;
3538
for @BLOCK {
3539
my %entry := $_.symbol($name);
3540
if %entry && %entry<scope> eq 'lexical' {
3541
return 1;
3542
}
3543
}
3544
return 0;
3545
}
3546
3547
# Looks to see if a variable has been set up as an alias to an attribute.
3548
sub is_attr_alias($name) {
3549
our @BLOCK;
3550
for @BLOCK {
3551
my %entry := $_.symbol($name);
3552
if %entry {
3553
return %entry<attr_alias>;
3554
}
3555
}
3556
return "";
3557
}
3558
3559
# Takes something that may be a block already, and if not transforms it into
3560
# one. Used by things doing where clause-ish things.
3561
sub where_blockify($expr) {
3562
my $past;
3563
if $expr<past_block> && $expr<block_class> eq 'Block' {
3564
my $lazy_name := make_lazy_sig_block($expr<past_block>);
3565
$past := create_code_object($expr<past_block>, 'Block', 0);
3566
}
3567
else {
3568
my $sig := Perl6::Compiler::Signature.new(
3569
Perl6::Compiler::Parameter.new(:var_name('$_')));
3570
$past := make_block_from($sig, PAST::Op.new(
3571
:pasttype('call'), :name('&infix:<~~>'),
3572
PAST::Var.new( :name('$_'), :scope('lexical') ),
3573
$expr
3574
));
3575
}
3576
$past
3577
}
3578
3579
# This is the hook where, in the future, we'll use this as the hook to check
3580
# if we have a proto or other declaration in scope that states that this sub
3581
# has a signature of the form :(\|$parcel), in which case we don't promote
3582
# the Parcel to a Capture when calling it. For now, we just worry about the
3583
# special case, return.
3584
sub capture_or_parcel($args, $name) {
3585
if $name eq 'return' {
3586
# Need to demote pairs again.
3587
my $parcel := PAST::Op.new();
3588
for @($args) {
3589
$parcel.push($_<before_promotion> ?? $_<before_promotion> !! $_);
3590
}
3591
$parcel
3592
}
3593
else {
3594
$args
3595
}
3596
}
3597
3598
# This checks if we have something of the form * op *, * op <thing> or
3599
# <thing> op * and if so, and if it's not one of the ops we do not
3600
# auto-curry for, emits a closure instead. We hard-code the things not
3601
# to curry for now; in the future, we will inspect the multi signatures
3602
# of the op to decide, or likely store things in this hash from that
3603
# introspection and keep it as a quick cache.
3604
3605
# not_curried = 1 means do not curry Whatever, but do curry WhateverCode
3606
# not_curried = 2 means do not curry either.
3607
3608
our %not_curried;
3609
INIT {
3610
%not_curried{'&infix:<...>'} := 2;
3611
%not_curried{'&infix:<...^>'} := 2;
3612
%not_curried{'&infix:<..>'} := 1;
3613
%not_curried{'&infix:<..^>'} := 1;
3614
%not_curried{'&infix:<^..>'} := 1;
3615
%not_curried{'&infix:<^..^>'} := 1;
3616
%not_curried{'&prefix:<^>'} := 2;
3617
%not_curried{'&infix:<xx>'} := 1;
3618
%not_curried{'&infix:<~~>'} := 2;
3619
%not_curried{'&infix:<=>'} := 2;
3620
%not_curried{'&infix:<:=>'} := 2;
3621
%not_curried{'WHAT'} := 2;
3622
%not_curried{'HOW'} := 2;
3623
%not_curried{'WHO'} := 2;
3624
%not_curried{'WHERE'} := 2;
3625
}
3626
sub whatever_curry($/, $past, $upto_arity) {
3627
if $past.isa(PAST::Op) && %not_curried{$past.name} != 2
3628
&& ($past<pasttype> ne 'call' || pir::index($past.name, '&infix:') == 0) {
3629
if ($upto_arity >= 1 && (($past[0].returns eq 'Whatever' && !%not_curried{$past.name})
3630
|| $past[0].returns eq 'WhateverCode'))
3631
|| ($upto_arity == 2 && (($past[1].returns eq 'Whatever' && !%not_curried{$past.name})
3632
|| $past[1].returns eq 'WhateverCode')) {
3633
3634
my $counter := 0;
3635
my $sig := Perl6::Compiler::Signature.new();
3636
my $left := $past.shift;
3637
my $left_new;
3638
my $right_new;
3639
3640
if $left.returns eq 'WhateverCode' {
3641
$left_new := PAST::Op.new( :pasttype('call'), :node($/), $left);
3642
my $left_arity := $left.arity;
3643
while $counter < $left_arity {
3644
$counter++;
3645
$left_new.push(PAST::Var.new( :name('$x' ~ $counter), :scope('lexical') ));
3646
$sig.add_parameter(Perl6::Compiler::Parameter.new(:var_name('$x' ~ $counter)));
3647
}
3648
}
3649
elsif $left.returns eq 'Whatever' {
3650
$counter++;
3651
$left_new := PAST::Var.new( :name('$x' ~ $counter), :scope('lexical') );
3652
$sig.add_parameter(Perl6::Compiler::Parameter.new(:var_name('$x' ~ $counter)));
3653
}
3654
else {
3655
$left_new := $left;
3656
}
3657
3658
if $upto_arity == 2 {
3659
my $right := $past.shift;
3660
3661
if $right.returns eq 'WhateverCode' {
3662
$right_new := PAST::Op.new( :pasttype('call'), :node($/), $right);
3663
# Next block is a bit weird, because $counter + $right.arity was
3664
# consistently failing. So we create a new variable as a temporary
3665
# counter.
3666
my $right_arity := $right.arity;
3667
my $right_counter := 0;
3668
while $right_counter < $right_arity {
3669
$counter++;
3670
$right_counter++;
3671
$right_new.push(PAST::Var.new( :name('$x' ~ $counter), :scope('lexical') ));
3672
$sig.add_parameter(Perl6::Compiler::Parameter.new(:var_name('$x' ~ $counter)));
3673
}
3674
}
3675
elsif $right.returns eq 'Whatever' {
3676
$counter++;
3677
$right_new := PAST::Var.new( :name('$x' ~ $counter), :scope('lexical') );
3678
$sig.add_parameter(Perl6::Compiler::Parameter.new(:var_name('$x' ~ $counter)));
3679
}
3680
else {
3681
$right_new := $right;
3682
}
3683
}
3684
3685
if $upto_arity == 2 {
3686
$past.unshift($right_new);
3687
}
3688
$past.unshift($left_new);
3689
$past := block_closure(blockify($past, $sig), 'WhateverCode', 0);
3690
$past.returns('WhateverCode');
3691
$past.arity($sig.arity);
3692
}
3693
}
3694
$past
3695
}
3696
3697
sub blockify($past, $sig) {
3698
add_signature( PAST::Block.new( :blocktype('declaration'),
3699
PAST::Stmts.new( ),
3700
PAST::Stmts.new( $past )
3701
),
3702
$sig);
3703
}
3704
3705
# Helper for constructing a simple Perl 6 Block with the given signature
3706
# and body.
3707
sub make_block_from($sig, $body, $type = 'Block') {
3708
my $past := PAST::Block.new( :blocktype('declaration'),
3709
PAST::Stmts.new( ),
3710
PAST::Stmts.new(
3711
$body
3712
)
3713
);
3714
add_signature($past, $sig);
3715
create_code_object($past, $type, 0);
3716
}
3717
3718
# vim: ft=perl6
Loggerhead is a web-based interface for Breezy
Version: 2.0.1