Permalink
Branch: master
Find file Copy path
Fetching contributors…
Cannot retrieve contributors at this time
11190 lines (10374 sloc) 438 KB
use NQPP6QRegex;
use NQPP5QRegex;
use Perl6::Pod;
use Perl6::Ops;
use QRegex;
use QAST;
my $wantwant := Mu;
# block types
my $para-block := 'paragraph';
my $delim-block := 'delimited';
my $abbrev-block := 'abbreviated';
# 2147483648 == 2**31. By adding 1 to it with add_i op, on 32-bit boxes it will overflow
my int $?BITS := nqp::isgt_i(nqp::add_i(2147483648, 1), 0) ?? 64 !! 32;
sub block_closure($code, :$regex) {
my $clone := QAST::Op.new( :op('callmethod'), :name('clone'), $code );
if $regex {
if $*W.lang-ver-before('d') {
my $marker := $*W.find_symbol(['Rakudo', 'Internals', 'RegexBoolification6cMarker']);
$clone.push(QAST::WVal.new( :value($marker), :named('topic') ));
}
else {
$clone.push(QAST::Var.new( :name('$_'), :scope('lexical'), :named('topic') ));
$clone.push(QAST::Var.new( :name('$/'), :scope('lexical'), :named('slash') ));
}
}
QAST::Op.new( :op('p6capturelex'), $clone ).annotate_self(
'past_block', $code.ann('past_block')
).annotate_self(
'code_object', $code.ann('code_object'))
}
sub wantall($ast, $by) {
my int $i := 0;
my int $e := $ast ?? nqp::elems(@($ast)) !! 0;
while $i < $e { $ast[$i] := wanted($ast[$i], $by ~ ' wa'); $i := $i + 1 }
Nil;
}
sub WANTALL($ast, $by) {
my int $i := 0;
my int $e := $ast ?? nqp::elems(@($ast)) !! 0;
while $i < $e { $ast[$i] := WANTED($ast[$i], $by ~ ' WA'); $i := $i + 1 }
Nil;
}
sub unwantall($ast, $by) {
my int $i := 0;
my int $e := $ast ?? nqp::elems(@($ast)) !! 0;
while $i < $e { $ast[$i] := unwanted($ast[$i], $by ~ ' ua'); $i := $i + 1 }
Nil;
}
sub UNWANTALL($ast, $by) {
my int $i := 0;
my int $e := $ast ?? nqp::elems(@($ast)) !! 0;
while $i < $e { $ast[$i] := UNWANTED($ast[$i], $by ~ ' ua'); $i := $i + 1 }
Nil;
}
# Note that these wanted/unwanted routines can return a different ast
# from the one passed, so always store the result back from where
# got it. (Like how wantall does it above.)
sub wanted($ast,$by) {
# $wantwant := nqp::getenvhash<RAKUDO_WANT> unless nqp::isconcrete($wantwant);
my $byby := $wantwant ?? $by ~ ' u' !! $by;
return $ast unless nqp::can($ast,'ann');
my $addr := nqp::where($ast);
return $ast if $ast.wanted; # already marked from here down
return $ast if $ast.sunk; # already marked from here down
note('wanted ' ~ $addr ~ ' by ' ~ $by ~ "\n" ~ $ast.dump) if $wantwant;
# if $ast.sunk {
# note("Oops, already sunk node is now wanted!?! \n" ~ $ast.dump);
# $ast.sunk(0);
# }
my $e := nqp::elems(@($ast)) - 1;
$ast.annotate('BY',$byby) if $wantwant;
if nqp::istype($ast,QAST::Stmt) || nqp::istype($ast,QAST::Stmts) {
my $resultchild := $ast.resultchild // $e;
my int $i := 0;
while $i <= $e {
$ast[$i] := $i == $resultchild ?? wanted($ast[$i], $byby) !! unwanted($ast[$i], $byby);
++$i;
}
$ast.wanted(1);
}
elsif nqp::istype($ast,QAST::Block) {
my int $i := 1;
my $*WANTEDOUTERBLOCK := $ast;
while $i <= $e {
$ast[$i] := WANTED($ast[$i], $byby);
++$i;
}
$ast.wanted(1);
}
elsif nqp::istype($ast,QAST::Op) {
if $ast.op eq 'call' && (
!$ast.name ||
$ast.name eq '&infix:<,>' ||
$ast.name eq '&infix:<andthen>' ||
$ast.name eq '&infix:<orelse>' ||
$ast.name eq '&infix:<notandthen>' ||
$ast.name eq '&infix:<xx>') {
WANTALL($ast,$byby);
}
elsif $ast.op eq 'callmethod' {
WANTALL($ast,$byby);
}
elsif $ast.op eq 'p6capturelex' {
$ast.annotate('past_block', wanted($ast.ann('past_block'), $byby));
$ast.wanted(1);
}
elsif $ast.op eq 'call' ||
$ast.op eq 'callstatic' ||
$ast.op eq 'handle' ||
$ast.op eq 'locallifetime' ||
$ast.op eq 'p6typecheckrv' ||
$ast.op eq 'handlepayload' {
$ast[0] := WANTED($ast[0], $byby) if nqp::elems(@($ast));
$ast.wanted(1);
}
elsif $ast.op eq 'p6decontrv' || $ast.op eq 'p6decontrv_6c' {
$ast[1] := WANTED($ast[1], $byby) if nqp::elems(@($ast));
$ast.wanted(1);
}
elsif $ast.op eq 'while' ||
$ast.op eq 'until' ||
$ast.op eq 'repeat_while' ||
$ast.op eq 'repeat_until' {
my $repeat := nqp::eqat($ast.op,'repeat',0);
my $while := nqp::index($ast.op,'while',0) >= 0;
# we always have a body
my $cond := WANTED($ast[0],$byby);
my $body := WANTED($ast[1],$byby);
my $block;
my $block-closure;
if $body.ann('loop-already-block-first-phaser') -> $loop-goods {
$block := $loop-goods[0][1][0];
$block-closure := QAST::Op.new: :node($body.node),
:op<p6setfirstflag>, block_closure($block);
# get rid of now-useless var and other bits of the QAST.
# If we .shift off all items, the QAST::Stmts gets a null
# in them that I can't figure out where it's coming from,
# so shove an empty QAST::Smts to replace last item.
$loop-goods.shift;
$loop-goods[0] := QAST::Stmts.new;
}
else {
$block := Perl6::Actions::make_thunk_ref($body, $body.node);
$block-closure := block_closure($block);
}
my $past := QAST::Op.new: :node($body.node),
:op<callmethod>, :name<from-loop>,
QAST::WVal.new(:value($*W.find_symbol(['Seq']))),
$block-closure;
# Elevate statevars to enclosing thunk
if $body.has_ann('has_statevar') && $block.has_ann('past_block') {
Perl6::Actions::migrate_blocks(
$body, $block.ann('past_block'),
-> $n { nqp::istype($n, QAST::Var) && $n.decl eq 'statevar' }
)
}
# conditional (if not always true (or if repeat))
if $repeat || !$cond.has_compile_time_value || !$cond.compile_time_value == $while {
$cond := QAST::Op.new( :op<callmethod>, :name<not>, $cond ) unless $while;
$block := Perl6::Actions::make_thunk_ref($cond, nqp::can($cond,'node') ?? $cond.node !! $body.node);
$past.push( block_closure($block) );
}
# 3rd part of loop, if any
if nqp::elems(@($ast)) > 2 {
$block := Perl6::Actions::make_thunk_ref($ast[2], $ast[2].node);
$block.annotate('outer',$*WANTEDOUTERBLOCK) if $*WANTEDOUTERBLOCK;
$past.push( UNWANTED(block_closure($block),$byby) )
}
if $repeat {
my $wval := QAST::WVal.new( :value($*W.find_symbol(['True'])) );
$wval.named('repeat');
$past.push($wval);
}
$ast := $past;
$ast.wanted(1);
}
elsif $ast.op eq 'if' ||
$ast.op eq 'unless' ||
$ast.op eq 'with' ||
$ast.op eq 'without' {
$ast[1] := WANTED($ast[1], $byby);
$ast[2] := WANTED($ast[2], $byby)
if nqp::elems(@($ast)) > 2 && nqp::istype($ast[2],QAST::Node);
$ast.wanted(1);
}
}
elsif nqp::istype($ast,QAST::Want) {
$ast.wanted(1);
my $node := $ast[0];
if nqp::istype($node,QAST::Op) {
if $node.op eq 'call' && (!$node.name || $node.name eq '&infix:<xx>') {
$node := $node[0];
if nqp::istype($node,QAST::Op) && $node.op eq 'p6capturelex' {
$node.annotate('past_block', WANTED($node.ann('past_block'), $byby));
}
}
elsif $node.op eq 'call' || $node.op eq 'handle' {
$ast[0] := WANTED($node,$byby);
}
elsif $node.op eq 'callstatic' || $node.op eq 'hllize' {
$node[0] := WANTED($node[0], $byby);
}
elsif $node.op eq 'p6for' || $node.op eq 'p6forstmt' {
$node := $node[1];
if nqp::istype($node,QAST::Op) && $node.op eq 'p6capturelex' {
$node.annotate('past_block', WANTED($node.ann('past_block'), $byby));
}
}
elsif $node.op eq 'while' ||
$node.op eq 'until' ||
$node.op eq 'repeat_while' ||
$node.op eq 'repeat_until' {
return WANTED($node,$byby) if !$*COMPILING_CORE_SETTING;
$node[1] := WANTED($node[1], $byby);
$node.wanted(1);
}
elsif $node.op eq 'if' ||
$node.op eq 'unless' ||
$node.op eq 'with' ||
$node.op eq 'without' {
$node[1] := WANTED($node[1], $byby);
$node[2] := WANTED($node[2], $byby)
if nqp::elems(@($node)) > 2
&& nqp::istype($node[2],QAST::Node);
$node.wanted(1);
}
}
}
else {
$ast.wanted: 1;
}
$ast;
}
sub WANTED($ast, $by) {
if nqp::istype($ast, QAST::Node) {
$ast := wanted($ast, $by ~ ' W');
$ast.wanted(1); # force in case it's just a thunk
}
else {
note("Non ast passed to WANTED: " ~ $ast.HOW.name($ast));
}
$ast;
}
my %nosink := nqp::hash('sink',1,'push',1,'append',1,'unshift',1,'prepend',1,'splice',1);
sub unwanted($ast, $by) {
my $byby := $by ~ ' u';
return $ast unless nqp::can($ast,'ann');
my $addr := nqp::where($ast);
return $ast if $ast.sunk;
return $ast if $ast.wanted; # probably a loose thunk just stashed somewhere random
$ast.annotate('BY',$byby) if $wantwant;
my $e := nqp::elems(@($ast)) - 1;
note('unwanted ' ~ $addr ~ ' by ' ~ $by ~ "\n" ~ $ast.dump) if $wantwant;
if nqp::istype($ast,QAST::Stmt) || nqp::istype($ast,QAST::Stmts) {
# Unwant all kids, not just last one, so we recurse into blocks and such,
# don't just rely on the optimizer to default to void.
my int $i := 0;
while $i <= $e {
$ast[$i] := unwanted($ast[$i], $byby);
++$i;
}
$ast.sunk(1);
$ast.push(QAST::WVal.new( :value($*W.find_symbol(['True'])) ))
if $e >= 0 && nqp::istype($ast[$e],QAST::Op) && $ast[$e].op eq 'bind';
}
elsif nqp::istype($ast,QAST::Block) {
my int $i := 1;
my $*WANTEDOUTERBLOCK := $ast;
while $i <= $e {
$ast[$i] := UNWANTED($ast[$i], $byby);
++$i;
}
$ast.sunk(1);
}
elsif nqp::istype($ast,QAST::Op) {
if $ast.op eq 'call' {
if $ast.name eq '&infix:<,>' || $ast.name eq '&infix:<xx>' {
UNWANTALL($ast,$byby);
}
elsif $ast.name eq '&term:<now>' {
$ast.node.worry("Useless use of 'now' in sink context");
}
else {
$ast[0] := UNWANTED($ast[0], $byby) if nqp::elems(@($ast));
}
$ast.sunk(1);
}
elsif $ast.op eq 'p6capturelex' {
$ast.annotate('past_block', unwanted($ast.ann('past_block'), $byby));
$ast.sunk(1);
}
elsif $ast.op eq 'callstatic' ||
$ast.op eq 'handle' ||
$ast.op eq 'locallifetime' ||
$ast.op eq 'p6typecheckrv' ||
$ast.op eq 'handlepayload' ||
$ast.op eq 'ifnull' {
$ast[0] := UNWANTED($ast[0], $byby) if nqp::elems(@($ast));
$ast.sunk(1);
}
elsif $ast.op eq 'hllize' {
my $node := $ast[0];
if $node.op eq 'callmethod' && !$ast.nosink {
if !$node.nosink && !$*COMPILING_CORE_SETTING && !%nosink{$node.name} {
$ast.sunk(1);
$ast := QAST::Op.new(:op<callmethod>, :name<sink>, $ast);
$ast.sunk(1);
return $ast;
}
}
$ast.sunk(1);
}
elsif $ast.op eq 'callmethod' {
if !$ast.nosink && !$*COMPILING_CORE_SETTING && !%nosink{$ast.name} {
return $ast if $*ALREADY_ADDED_SINK_CALL;
$ast.sunk(1);
$ast := QAST::Op.new(:op<callmethod>, :name<sink>, $ast);
$ast.sunk(1);
return $ast;
}
$ast[0] := UNWANTED($ast[0], $byby) if nqp::elems(@($ast));
$ast.sunk(1);
}
elsif $ast.op eq 'p6decontrv' || $ast.op eq 'p6decontrv_6c' {
$ast[1] := UNWANTED($ast[1], $byby) if nqp::elems(@($ast));
$ast.sunk(1);
}
elsif $ast.op eq 'while' ||
$ast.op eq 'until' ||
$ast.op eq 'repeat_while' ||
$ast.op eq 'repeat_until' {
# Do we need to force loop to produce return values for internal reasons?
if !$*COMPILING_CORE_SETTING && $ast[1].ann('WANTMEPLEASE') {
$ast := QAST::Op.new(:op<callmethod>, :name<sink>, WANTED($ast, $byby));
$ast.sunk(1);
return $ast;
}
$ast[1] := UNWANTED($ast[1], $byby);
$ast.sunk(1);
}
elsif $ast.op eq 'if' ||
$ast.op eq 'unless' ||
$ast.op eq 'with' ||
$ast.op eq 'without' {
$ast[1] := UNWANTED($ast[1], $byby);
$ast[2] := UNWANTED($ast[2], $byby)
if nqp::elems(@($ast)) > 2 && nqp::istype($ast[2],QAST::Node);
$ast.sunk(1);
}
elsif $ast.op eq 'bind' {
$ast.sunk(1);
}
elsif $ast.op eq 'xor' {
my int $i := 1;
my int $elems := nqp::elems($ast);
while $i <= $e {
$ast[$i] := UNWANTED($ast[$i], $byby);
++$i;
}
$ast.sunk: 1;
}
}
elsif nqp::istype($ast,QAST::Want) {
$ast.sunk(1);
my $node := $ast[0];
if nqp::istype($node,QAST::WVal) {
$node.sunk(1);
$ast[2].sunk(1);
}
elsif nqp::istype($node,QAST::Op) {
if $node.op eq 'call' {
$node.sunk(1);
if !$node.name {
my $node0 := $node[0];
unwanted($node0, $byby);
if nqp::istype($node0,QAST::Op) && $node0.op eq 'call' && nqp::eqat($node0.name, '&META', 0) {
my $op := $node.node.Str;
my $t := nqp::index($op,' ');
$op := nqp::substr($op, 0, $t) if $t > 0;
my $purity := 0;
if $node0[0].ann('is_pure') {
$purity := 1 unless $node0.name eq '&METAOP_ASSIGN';
}
else {
my $subname := $node0[0].name;
my $subfun := try $*W.find_symbol([$subname]);
if $subfun {
if nqp::index($node0.name, 'ASSIGN') < 0 && nqp::can($subfun, 'is-pure') {
$purity := 1;
}
}
else {
$purity := 1; # "can't happen" except in setting, so assume will be pure
}
}
$node.node.PRECURSOR.worry("Useless use of $op in sink context") if $purity;
}
}
else {
my $infix := $node.node<infix>;
if $infix {
my $sym := $infix<sym>;
if $sym eq ',' || $sym eq 'xx' { unwantall($node, $byby) }
elsif $sym eq '...' ||
$sym eq '...^' ||
$sym eq '' ||
$sym eq '…^'
{
$node.annotate('useless', $sym);
$node.node.worry("Useless use of $sym in sink context");
}
}
elsif $node.name eq '&term:<now>' {
$node.annotate('useless', "'now'");
$node.node.worry("Useless use of 'now' in sink context");
}
}
}
elsif $node.op eq 'hllize' {
$ast[0] := UNWANTED($node,$byby);
}
elsif $node.op eq 'callmethod' {
if !$node.nosink && !%nosink{$node.name} {
$ast := QAST::Op.new(:op<callmethod>, :name<sink>, unwanted($node, $byby));
$ast.sunk(1);
return $ast;
}
$node.sunk(1);
}
elsif $node.op eq 'p6for' || $node.op eq 'p6forstmt' {
$node := $node[1];
if nqp::istype($node,QAST::Op) && $node.op eq 'p6capturelex' {
unless $*COMPILING_CORE_SETTING {
add-sink-to-final-call($node.ann('past_block'), 1);
my $*ALREADY_ADDED_SINK_CALL := 1;
$node.annotate('past_block', UNWANTED($node.ann('past_block'), $byby));
}
}
}
elsif $node.op eq 'while' || $node.op eq 'until' {
if !$*COMPILING_CORE_SETTING && $node[1].ann('WANTMEPLEASE') {
$ast := QAST::Op.new(:op<callmethod>, :name<sink>, WANTED($node, $byby));
$ast.sunk(1);
return $ast;
}
$node[1] := UNWANTED($node[1], $byby);
$node.sunk(1);
}
elsif $node.op eq 'if' || $node.op eq 'unless' || $node.op eq 'with' || $node.op eq 'without' {
for 1,2 {
if nqp::elems(@($node)) > $_
&& nqp::istype($node[$_],QAST::Node) {
if nqp::istype($node[$_],QAST::Op) && $node[$_].op eq 'bind' {
$node[$_] := QAST::Stmts.new(
$node[$_],
QAST::WVal.new( :value($*W.find_symbol(['True']))));
}
$node[$_] := UNWANTED($node[$_], $byby);
}
}
$node.sunk(1);
}
elsif $node.op eq 'callmethod' && $node.name eq 'new' {
$node.sunk(1);
}
}
}
$ast;
}
sub add-sink-to-final-call($parent, $pos, $qast = $parent[$pos]) {
if (nqp::istype($qast, QAST::Stmts) || nqp::istype($qast, QAST::Stmt))
&& nqp::elems($qast) {
add-sink-to-final-call($qast, nqp::elems($qast)-1)
}
elsif nqp::istype($qast, QAST::Want) {
add-sink-to-final-call($parent, $pos, $qast[0])
}
elsif nqp::istype($qast, QAST::Op) && $qast.op eq 'call' && !$qast.nosink {
$parent[$pos] := QAST::Op.new: :op<callmethod>, :name<sink>, $qast
}
}
sub UNWANTED($ast, $by) {
if nqp::istype($ast, QAST::Node) {
$ast := unwanted($ast, $by ~ ' U');
$ast.sunk(1);
}
else {
note("Non ast passed to UNWANTED: " ~ $ast.HOW.name($ast));
}
$ast;
}
register_op_desugar('p6box_i', -> $qast {
QAST::Op.new( :op('box_i'), $qast[0], QAST::Op.new( :op('hllboxtype_i') ) )
});
register_op_desugar('p6box_n', -> $qast {
QAST::Op.new( :op('box_n'), $qast[0], QAST::Op.new( :op('hllboxtype_n') ) )
});
register_op_desugar('p6box_s', -> $qast {
QAST::Op.new( :op('box_s'), $qast[0], QAST::Op.new( :op('hllboxtype_s') ) )
});
register_op_desugar('p6box_u', -> $qast {
QAST::Op.new( :op('box_u'), $qast[0], QAST::Op.new( :op('hllboxtype_i') ) )
});
register_op_desugar('p6reprname', -> $qast {
QAST::Op.new( :op('box_s'), QAST::Op.new( :op('reprname'), $qast[0]), QAST::Op.new( :op('hllboxtype_s') ) )
});
register_op_desugar('p6callmethodhow', -> $qast {
$qast := $qast.shallow_clone();
my $inv := $qast.shift;
my $tmp := QAST::Node.unique('how_invocant');
$qast.op('callmethod');
$qast.unshift(QAST::Var.new( :name($tmp), :scope('local') ));
$qast.unshift(QAST::Op.new(
:op('how'),
QAST::Var.new( :name($tmp), :scope('local') )
));
QAST::Stmts.new(
QAST::Op.new(
:op('bind'),
QAST::Var.new( :name($tmp), :scope('local'), :decl('var') ),
$inv
),
QAST::Op.new( :op('hllize'), $qast )
)
});
register_op_desugar('p6fatalize', -> $qast {
my $tmp := QAST::Node.unique('fatalizee');
QAST::Stmts.new(
:resultchild(0),
QAST::Op.new(
:op('bind'),
QAST::Var.new( :name($tmp), :scope('local'), :decl('var') ),
$qast[0]
),
QAST::Op.new(
:op('if'),
QAST::Op.new(
:op('istype'),
QAST::Var.new( :name($tmp), :scope('local') ),
$qast[1],
),
QAST::Op.new(
:op('callmethod'), :name('sink'),
QAST::Var.new( :name($tmp), :scope('local') )
)
))
});
register_op_desugar('p6for', -> $qast {
# Figure out the execution mode.
my $mode := $qast.ann('mode') || 'serial';
my $after-mode;
if $mode eq 'lazy' {
$after-mode := 'lazy';
$mode := 'serial';
}
else {
$after-mode := $qast.sunk ?? 'sink' !! 'eager';
}
my $cond := $qast[0];
my $block := $qast[1];
my $label := $qast[2];
my $for-list-name := QAST::Node.unique('for-list');
my $call := QAST::Op.new(
:op('if'),
QAST::Op.new( :op('iscont'), QAST::Var.new( :name($for-list-name), :scope('local') ) ),
QAST::Op.new(
:op<callmethod>, :name<map>, :node($qast),
QAST::Var.new( :name($for-list-name), :scope('local') ),
$block,
QAST::IVal.new( :value(1), :named('item') )
),
QAST::Op.new(
:op<callmethod>, :name<map>, :node($qast),
QAST::Op.new(
:op<callmethod>, :name($mode), :node($qast),
QAST::Var.new( :name($for-list-name), :scope('local') )
),
$block
)
);
if $label {
$call[1].push($label);
$call[2].push($label);
}
my $bind := QAST::Op.new(
:op('bind'),
QAST::Var.new( :name($for-list-name), :scope('local'), :decl('var') ),
$cond,
);
QAST::Stmts.new(
$bind,
QAST::Op.new( :op<callmethod>, :name($after-mode), $call )
);
});
register_op_desugar('p6forstmt', -> $qast {
my $for-target-name := QAST::Node.unique('for_target');
my $for-target := QAST::Op.new(
:op('bind'),
QAST::Var.new( :name($for-target-name), :scope('local'), :decl('var') ),
$qast[0]
);
my $iterator-name := QAST::Node.unique('for_iterator');
my $iterator := QAST::Op.new(
:op('bind'),
QAST::Var.new( :name($iterator-name), :scope('local'), :decl('var') ),
QAST::Op.new(
:op('callmethod'), :name('iterator'),
QAST::Op.new(
:op('if'),
QAST::Op.new(
:op('iscont'),
QAST::Var.new( :name($for-target-name), :scope('local') )
),
QAST::Op.new(
:op('callstatic'), :name('&infix:<,>'),
QAST::Var.new( :name($for-target-name), :scope('local') )
),
QAST::Var.new( :name($for-target-name), :scope('local') )
)));
my $iteration-end-name := QAST::Node.unique('for_iterationend');
my $iteration-end := QAST::Op.new(
:op('bind'),
QAST::Var.new( :name($iteration-end-name), :scope('local'), :decl('var') ),
QAST::WVal.new( :value($qast.ann('IterationEnd')) )
);
my $block-name := QAST::Node.unique('for_block');
my $block := QAST::Op.new(
:op('bind'),
QAST::Var.new( :name($block-name), :scope('local'), :decl('var') ),
$qast[1]
);
my $iter-val-name := QAST::Node.unique('for_iterval');
my $loop := QAST::Op.new(
:op('until'),
QAST::Op.new(
:op('eqaddr'),
QAST::Op.new(
:op('decont'),
QAST::Op.new(
:op('bind'),
QAST::Var.new( :name($iter-val-name), :scope('local'), :decl('var') ),
QAST::Op.new(
:op('callmethod'), :name('pull-one'),
QAST::Var.new( :name($iterator-name), :scope('local') )
)
)
),
QAST::Var.new( :name($iteration-end-name), :scope('local') )
),
QAST::Op.new(
:op('call'),
QAST::Var.new( :name($block-name), :scope('local') ),
QAST::Var.new( :name($iter-val-name), :scope('local') )
));
if $qast[2] {
$loop.push($qast[2]);
}
QAST::Stmts.new(
$for-target,
$iterator,
$iteration-end,
$block,
$loop,
QAST::WVal.new( :value($qast.ann('Nil')) )
)
});
register_op_desugar('p6scalarfromdesc', -> $qast {
my $desc := QAST::Node.unique('descriptor');
my $Scalar := QAST::WVal.new( :value(nqp::gethllsym('perl6', 'Scalar')) );
my $default_cont_spec := nqp::gethllsym('perl6', 'default_cont_spec');
QAST::Stmt.new(
QAST::Op.new(
:op('bind'),
QAST::Var.new( :name($desc), :scope('local'), :decl('var') ),
$qast[0]
),
QAST::Op.new(
:op('unless'),
QAST::Op.new(
:op('isconcrete'),
QAST::Var.new( :name($desc), :scope('local') ),
),
QAST::Op.new(
:op('bind'),
QAST::Var.new( :name($desc), :scope('local') ),
QAST::WVal.new( :value($default_cont_spec) )
)
),
QAST::Op.new(
:op('p6bindattrinvres'),
QAST::Op.new(
:op('p6bindattrinvres'),
QAST::Op.new( :op('create'), $Scalar ),
$Scalar,
QAST::SVal.new( :value('$!descriptor') ),
QAST::Var.new( :name($desc), :scope('local') )
),
$Scalar,
QAST::SVal.new( :value('$!value') ),
QAST::Op.new(
:op('callmethod'), :name('default'),
QAST::Var.new( :name($desc), :scope('local') )
)
)
)
});
# The "certain" variant is allowed to assume the container descriptor is
# reliably provided, so need not map it to the default one. Ideally, we'll
# eventually have everything using this version of the op.
register_op_desugar('p6scalarfromcertaindesc', -> $qast {
my $desc := QAST::Node.unique('descriptor');
my $Scalar := QAST::WVal.new( :value(nqp::gethllsym('perl6', 'Scalar')) );
QAST::Stmt.new(
QAST::Op.new(
:op('bind'),
QAST::Var.new( :name($desc), :scope('local'), :decl('var') ),
$qast[0]
),
QAST::Op.new(
:op('p6bindattrinvres'),
QAST::Op.new(
:op('p6bindattrinvres'),
QAST::Op.new( :op('create'), $Scalar ),
$Scalar,
QAST::SVal.new( :value('$!descriptor') ),
QAST::Var.new( :name($desc), :scope('local') )
),
$Scalar,
QAST::SVal.new( :value('$!value') ),
QAST::Op.new(
:op('callmethod'), :name('default'),
QAST::Var.new( :name($desc), :scope('local') )
)
)
)
});
register_op_desugar('p6scalarwithvalue', -> $qast {
my $Scalar := QAST::WVal.new( :value(nqp::gethllsym('perl6', 'Scalar')) );
QAST::Op.new(
:op('p6assign'),
QAST::Op.new(
:op('p6bindattrinvres'),
QAST::Op.new( :op('create'), $Scalar ),
$Scalar,
QAST::SVal.new( :value('$!descriptor') ),
$qast[0]
),
$qast[1]
)
});
register_op_desugar('p6recont_ro', -> $qast {
my $result := QAST::Node.unique('result');
my $Scalar := QAST::WVal.new( :value(nqp::gethllsym('perl6', 'Scalar')) );
QAST::Stmt.new(
QAST::Op.new(
:op('bind'),
QAST::Var.new( :name($result), :scope('local'), :decl('var') ),
$qast[0]
),
QAST::Op.new(
:op('if'),
QAST::Op.new(
:op('if'),
QAST::Op.new(
:op('isconcrete_nd'),
QAST::Var.new( :name($result), :scope('local') )
),
QAST::Op.new(
:op('isrwcont'),
QAST::Var.new( :name($result), :scope('local') )
)
),
QAST::Op.new(
:op('p6bindattrinvres'),
QAST::Op.new( :op('create'), $Scalar ),
$Scalar,
QAST::SVal.new( :value('$!value') ),
QAST::Op.new(
:op('decont'),
QAST::Var.new( :name($result), :scope('local') )
)
),
QAST::Var.new( :name($result), :scope('local') )
)
)
});
register_op_desugar('p6var', -> $qast {
my $result := QAST::Node.unique('result');
my $Scalar := QAST::WVal.new( :value(nqp::gethllsym('perl6', 'Scalar')) );
QAST::Stmt.new(
QAST::Op.new(
:op('bind'),
QAST::Var.new( :name($result), :scope('local'), :decl('var') ),
$qast[0]
),
QAST::Op.new(
:op('if'),
QAST::Op.new(
:op('if'),
QAST::Op.new(
:op('isconcrete_nd'),
QAST::Var.new( :name($result), :scope('local') )
),
QAST::Op.new(
:op('iscont'),
QAST::Var.new( :name($result), :scope('local') )
)
),
QAST::Op.new(
:op('p6bindattrinvres'),
QAST::Op.new( :op('create'), $Scalar ),
$Scalar,
QAST::SVal.new( :value('$!value') ),
QAST::Var.new( :name($result), :scope('local') )
),
QAST::Var.new( :name($result), :scope('local') )
)
)
});
{
my $is_moar;
register_op_desugar('p6decontrv_internal', -> $qast {
unless nqp::isconcrete($is_moar) {
$is_moar := nqp::getcomp('perl6').backend.name eq 'moar';
}
if $is_moar {
my $result := QAST::Node.unique('result');
QAST::Stmt.new(
QAST::Op.new(
:op('bind'),
QAST::Var.new( :name($result), :scope('local'), :decl('var') ),
QAST::Op.new( :op('wantdecont'), $qast[0] )
),
QAST::Op.new(
:op('call'),
QAST::Op.new(
:op('speshresolve'),
QAST::SVal.new( :value($qast[1] eq '6c' ?? 'decontrv_6c' !! 'decontrv') ),
QAST::Var.new( :name($result), :scope('local') )
),
QAST::Var.new( :name($result), :scope('local') ),
)
)
}
else {
my $result := QAST::Node.unique('result');
my $Scalar := QAST::WVal.new( :value(nqp::gethllsym('perl6', 'Scalar')) );
my $Iterable := QAST::WVal.new( :value(nqp::gethllsym('perl6', 'Iterable')) );
QAST::Stmt.new(
QAST::Op.new(
:op('bind'),
QAST::Var.new( :name($result), :scope('local'), :decl('var') ),
QAST::Op.new( :op('wantdecont'), $qast[0] )
),
QAST::Op.new(
# If it's a container...
:op('if'),
QAST::Op.new(
:op('if'),
QAST::Op.new(
:op('isconcrete_nd'),
QAST::Var.new( :name($result), :scope('local') )
),
QAST::Op.new(
:op('iscont'),
QAST::Var.new( :name($result), :scope('local') )
)
),
# It's a container; is it an rw one?
QAST::Op.new(
:op('if'),
QAST::Op.new(
:op('isrwcont'),
QAST::Var.new( :name($result), :scope('local') )
),
# Yes; does it contain an Iterable? If so, rewrap it. If
# not, strip it.
QAST::Op.new(
:op('if'),
QAST::Op.new(
:op('istype'),
QAST::Var.new( :name($result), :scope('local') ),
$Iterable
),
QAST::Op.new(
:op('p6bindattrinvres'),
QAST::Op.new( :op('create'), $Scalar ),
$Scalar,
QAST::SVal.new( :value('$!value') ),
QAST::Op.new(
:op('decont'),
QAST::Var.new( :name($result), :scope('local') )
)
),
QAST::Op.new(
:op('decont'),
QAST::Var.new( :name($result), :scope('local') )
)
),
# Not rw, so leave container in place.
QAST::Var.new( :name($result), :scope('local') )
),
# Not a container, so just hand back value
QAST::Var.new( :name($result), :scope('local') )
)
)
}
});
}
{
my $is_moar;
register_op_desugar('p6assign', -> $qast {
unless nqp::isconcrete($is_moar) {
$is_moar := nqp::getcomp('perl6').backend.name eq 'moar';
}
if $is_moar {
my $cont := QAST::Node.unique('assign_cont');
my $value := QAST::Node.unique('assign_value');
QAST::Stmts.new(
QAST::Op.new(
:op('bind'),
QAST::Var.new( :name($cont), :scope('local'), :decl('var') ),
$qast[0]
),
QAST::Op.new(
:op('bind'),
QAST::Var.new( :name($value), :scope('local'), :decl('var') ),
QAST::Op.new( :op('decont'), $qast[1] )
),
QAST::Op.new(
:op('call'),
QAST::Op.new(
:op('speshresolve'),
QAST::SVal.new( :value('assign') ),
QAST::Var.new( :name($cont), :scope('local') ),
QAST::Var.new( :name($value), :scope('local') ),
),
QAST::Var.new( :name($cont), :scope('local') ),
QAST::Var.new( :name($value), :scope('local') ),
),
QAST::Var.new( :name($cont), :scope('local') )
)
}
else {
QAST::Op.new( :op('assign'), $qast[0], $qast[1] )
}
});
}
sub can-use-p6forstmt($block) {
my $past_block := $block.ann('past_block');
my $count := $past_block.ann('count');
return 0 unless nqp::isconcrete($count) && $count == 1;
my $code := $block.ann('code_object');
my $block_type := $*W.find_symbol(['Block'], :setting-only);
return 1 unless nqp::istype($code, $block_type);
my $p := nqp::getattr($code, $block_type, '$!phasers');
nqp::isnull($p) ||
!(nqp::existskey($p, 'FIRST') || nqp::existskey($p, 'LAST') || nqp::existskey($p, 'NEXT'))
}
sub monkey_see_no_eval($/) {
my $msne := $*LANG.pragma('MONKEY-SEE-NO-EVAL');
nqp::defined($msne)
?? $msne # prevails if defined, can be either 1 or 0
!! $*COMPILING_CORE_SETTING
|| try { $*W.find_symbol(['&MONKEY-SEE-NO-EVAL'])() };
}
role STDActions {
method quibble($/) {
make $<nibble>.ast;
}
method trim_heredoc($/, $doc, $stop, $origast) {
$origast.pop();
$origast.pop();
my str $ws := $stop.MATCH<ws>.Str;
my int $actualchars := nqp::chars($ws);
my int $indent := -$actualchars;
my int $tabstop := $*W.find_symbol(['$?TABSTOP']);
my int $checkidx := 0;
while $checkidx < $actualchars {
if nqp::eqat($ws, "\t", $checkidx) {
$indent := $indent - ($tabstop - 1);
}
$checkidx := $checkidx + 1;
}
my $docast := $doc.MATCH.ast;
if $docast.has_compile_time_value {
my str $dedented := nqp::unbox_s($docast.compile_time_value.indent($indent));
$origast.push($*W.add_string_constant($dedented));
}
else {
# we need to remove spaces from the beginnings of only textual lines,
# so we have to track after each concatenation if the spaces at the
# beginning of our chunk belong to a fresh line or come after an
# interpolation or something
my $in-fresh-line := 1;
sub descend($node) {
if nqp::istype($node, QAST::Want) {
if +@($node) == 3 && $node[1] eq "Ss" {
my $strval := $node[0].compile_time_value;
if !$in-fresh-line {
if $strval ~~ /\n/ {
my $strbox := nqp::box_s(nqp::x(" ", -$indent) ~ nqp::unbox_s($strval), $*W.find_symbol(["Str"]));
$strval := nqp::unbox_s($strbox.indent($indent));
$in-fresh-line := 1;
return $*W.add_string_constant($strval);
}
} else {
$strval := nqp::unbox_s($strval.indent($indent));
return $*W.add_string_constant($strval);
}
}
} elsif nqp::istype($node, QAST::Op) && $node.op eq 'call' && $node.name eq '&infix:<~>' {
my @results;
# since we have the $in-fresh-line state, we need to traverse
# and replace the child nodes in order
for @($node) {
nqp::push(@results, descend($node.shift))
}
for @results {
nqp::push($node, $_)
}
return $node;
}
$in-fresh-line := 0;
return $node
}
$origast.push(descend($docast))
}
CONTROL {
if nqp::getextype($_) == nqp::const::CONTROL_WARN {
$/.worry(nqp::getmessage($_));
nqp::resume($_);
}
nqp::rethrow($_);
}
$origast;
}
}
class Perl6::Actions is HLL::Actions does STDActions {
#================================================================
# AMBIENT AND POD-COMMON CODE HANDLERS
#================================================================
our @MAX_PERL_VERSION;
# Could add to this based on signatures.
our %commatrap := nqp::hash(
'&categorize', 1,
'&classify', 1,
'&first', 2,
'&grep', 2,
'&map', 1,
'&reduce', 1,
'&sort', 1,
);
INIT {
# If, e.g., we support Perl up to v6.1.2, set
# @MAX_PERL_VERSION to [6, 1, 2].
@MAX_PERL_VERSION[0] := 6;
}
sub sink($past) {
QAST::Want.new(
$past,
'v', QAST::Op.new( :op('p6sink'), $past )
)
}
my %sinkable := nqp::hash(
'call', 1,
'callmethod', 1,
'if', 1,
'while', 1,
'unless', 1,
'until', 1,
'repeat_until', 1,
'repeat_while', 1,
'handle', 1,
'hllize', 1,
);
sub autosink($past) {
nqp::istype($past, QAST::Op) && %sinkable{$past.op} && $*statement_level && !$past.nosink
?? sink($past)
!! $past;
}
method ints_to_string($ints) {
if nqp::islist($ints) {
my $result := '';
for $ints {
$result := $result ~ nqp::chr(nqp::unbox_i($_.ast));
}
$result;
} else {
nqp::chr(nqp::unbox_i($ints.ast));
}
}
sub string_to_int($src, int $base, int $chars) {
my $res := nqp::radix($base, ~$src, 0, 2);
$src.panic("'$src' is not a valid number")
unless nqp::iseq_i(nqp::atpos($res, 2), $chars);
nqp::box_i(nqp::atpos($res, 0), $*W.find_symbol(['Int']));
}
sub string_to_bigint($src, int $base, int $chars) {
my $res := nqp::radix_I($base, ~$src, 0, 2, $*W.find_symbol(['Int']));
$src.panic("'$src' is not a valid number")
unless nqp::iseq_i(nqp::unbox_i(nqp::atpos($res, 2)), $chars);
nqp::atpos($res, 0);
}
sub xblock_immediate_with($xblock) {
$xblock[1] := pblock_immediate_with($xblock[1]);
$xblock;
}
sub xblock_immediate($xblock) {
$xblock[1] := pblock_immediate($xblock[1]);
$xblock;
}
sub pblock_immediate_with($pblock) {
my $pb := block_immediate($pblock.ann('uninstall_if_immediately_used').shift);
$pb.arity(1); # gotta force this, or Block node gets optimized away
$pb;
}
sub pblock_immediate($pblock) {
block_immediate($pblock.ann('uninstall_if_immediately_used').shift);
}
our sub block_immediate($block) {
$block.blocktype('immediate');
$block;
}
method deflongname($/) {
if $<colonpair> {
my $name := ~$<name>;
for $<colonpair> {
my $key := $_<identifier> || '';
if $_<coloncircumfix> -> $cf {
if $cf<circumfix> -> $op_name {
$name := $name ~ $*W.canonicalize_pair($key, $*W.colonpair_nibble_to_str(
$/, $op_name<nibble> // $op_name<semilist> // $op_name<pblock>));
}
else {
$name := $name ~ ':' ~ $key;
}
}
else {
$name := $name ~ ':' ~ $key;
}
}
make $name;
}
else {
make $*W.dissect_deflongname($/).name(
:dba("$*IN_DECL declaration"),
:decl<routine>,
);
}
}
method deftermnow($/) {
# 'my \foo' style declaration
if $*SCOPE ne 'my' {
$*W.throw($/, 'X::Comp::NYI',
feature => "$*SCOPE scoped term definitions (only 'my' is supported at the moment)");
}
my $name := $<defterm>.ast;
my $cur_lexpad := $*W.cur_lexpad;
if $cur_lexpad.symbol($name) {
$*W.throw($/, ['X', 'Redeclaration'], symbol => $name);
}
if $*OFTYPE {
my $type := $*OFTYPE.ast;
$cur_lexpad[0].push(QAST::Var.new( :$name, :scope('lexical'),
:decl('var'), :returns($type) ));
$cur_lexpad.symbol($name, :$type, :scope<lexical>);
}
else {
$cur_lexpad[0].push(QAST::Var.new(:$name, :scope('lexical'), :decl('var')));
$cur_lexpad.symbol($name, :scope('lexical'));
}
make $<defterm>.ast;
}
method defterm($/) {
my $name := ~$<identifier>;
if $<colonpair> {
for $<colonpair> {
my $key := $_<identifier> || '';
if $_<coloncircumfix> -> $cf {
if $cf<circumfix> -> $op_name {
$name := $name ~ $*W.canonicalize_pair($key, $*W.colonpair_nibble_to_str($/, $op_name<nibble>));
}
else {
$name := $name ~ ':' ~ $key;
}
}
else {
$name := $name ~ ':' ~ $key;
}
}
}
make $name;
}
# Turn $code into "for lines() { $code }"
sub wrap_option_n_code($/, $code) {
$code := make_topic_block_ref($/, $code, copy => 1);
my $past := QAST::Op.new(:op<callmethod>, :name<map>,
QAST::Op.new(:op<call>, :name<&lines>),
QAST::Op.new(:op<p6capturelex>, $code)
);
$past := QAST::Want.new(
QAST::Op.new( :op<callmethod>, :name<sink>, $past ),
'v', QAST::Op.new( :op<callmethod>, :name<sink>, $past )
);
}
# Turn $code into "for lines() { $code; say $_ }"
# &wrap_option_n_code already does the C<for> loop, so we just add the
# C<say> call here
sub wrap_option_p_code($/, $code) {
wrap_option_n_code($/,
QAST::Stmts.new(
$code,
QAST::Op.new(:name<&say>, :op<call>,
QAST::Var.new(:name<$_>, :scope<lexical>)
)
)
)
}
method comp_unit($/) {
# Finish up code object for the mainline.
if $*DECLARAND {
$*W.attach_signature($*DECLARAND, $*W.create_signature(
nqp::hash('parameter_objects', [])));
$*W.finish_code_object($*DECLARAND, $*UNIT);
$*W.add_phasers_handling_code($*DECLARAND, $*UNIT);
}
# Checks.
$*W.assert_stubs_defined($/);
$*W.sort_protos();
# Get the block for the unit mainline code.
my $unit := $*UNIT;
my $mainline := QAST::Stmts.new(
$*POD_PAST,
statementlist_with_handlers($/)
);
# Errors/warnings in sinking pass should ignore highwater mark.
$/.'!clear_highwater'();
unless $*NEED_RESULT {
# Evaluate last statement in sink context, by pushing another
# statement after it, unless we need the result.
unwantall($mainline, 'comp_unit');
$mainline.push(QAST::WVal.new( :value($*W.find_symbol(['Nil'])) ));
}
fatalize($mainline) if $*FATAL;
# Emit any worries. Note that unwanting $mainline can produce worries.
if @*WORRIES {
stderr().print($*W.group_exception().gist());
}
if %*COMPILING<%?OPTIONS><p> { # also covers the -np case, like Perl 5
$mainline[1] := QAST::Stmt.new(wrap_option_p_code($/, $mainline[1]));
}
elsif %*COMPILING<%?OPTIONS><n> {
$mainline[1] := QAST::Stmt.new(wrap_option_n_code($/, $mainline[1]));
}
# We'll install our view of GLOBAL as the main one; any other
# compilation unit that is using this one will then replace it
# with its view later (or be in a position to restore it).
my $global_install := QAST::Op.new(
:op('bindcurhllsym'),
QAST::SVal.new( :value('GLOBAL') ),
QAST::WVal.new( :value($*GLOBALish) )
);
$*W.add_fixup_task(:deserialize_ast($global_install), :fixup_ast($global_install));
# Get the block for the entire compilation unit.
my $outer := $*UNIT_OUTER;
$outer.node($/);
$*UNIT_OUTER.unshift(QAST::Var.new( :name('__args__'), :scope('local'), :decl('param'), :slurpy(1) ));
$unit.name('<unit>');
$outer.name('<unit-outer>');
# If the unit defines &MAIN, and this is in the mainline,
# add a call to &RUN-MAIN
if !$*W.is_precompilation_mode
&& !$*INSIDE-EVAL
&& +(@*MODULES // []) == 0
&& $unit.symbol('&MAIN') -> $main {
$mainline := QAST::Op.new(
:op('call'),
:name('&RUN-MAIN'),
QAST::WVal.new(:value($main<value>)),
$mainline # run the mainline and get its result
);
unless $*W.lang-ver-before('d') {
$mainline.push(
QAST::WVal.new( # $*IN as $*ARGSFILES
value => $*W.find_symbol(['Bool','True'], :setting-only),
:named('in-as-argsfiles')
)
);
}
}
# If our caller wants to know the mainline ctx, provide it here.
# (CTXSAVE is inherited from HLL::Actions.) Don't do this when
# there was an explicit {YOU_ARE_HERE}.
unless $*HAS_YOU_ARE_HERE {
$unit.push( self.CTXSAVE() );
}
# Add the mainline code to the unit.
$unit.push($mainline);
# Executing the compilation unit causes the mainline to be executed.
$outer.push(QAST::Op.new( :op<call>, $unit ));
# Do not want closure semantics on this outermost scope.
$unit.blocktype('declaration_static');
# Wrap everything in a QAST::CompUnit.
make QAST::CompUnit.new(
:hll('perl6'),
# Serialization related bits.
:sc($*W.sc()),
:code_ref_blocks($*W.code_ref_blocks()),
:compilation_mode($*W.is_precompilation_mode()),
:pre_deserialize($*W.load_dependency_tasks()),
:post_deserialize($*W.fixup_tasks()),
:is_nested($*W.is_nested()),
:repo_conflict_resolver(QAST::Op.new(
:op('callmethod'), :name('resolve_repossession_conflicts'),
QAST::WVal.new( :value($*W.find_symbol(['CompUnit', 'RepositoryRegistry'])) )
)),
# If this unit is loaded as a module, we want it to automatically
# execute the mainline code above after all other initializations
# have occurred.
:load(QAST::Op.new(
:op('call'),
QAST::BVal.new( :value($outer) ),
)),
# Finally, the outer block, which in turn contains all of the
# other program elements.
$outer
).annotate_self( # Pass some extra bits along to the optimizer.
'UNIT', $unit
).annotate_self(
'CAN_LOWER_TOPIC', $*CAN_LOWER_TOPIC
).annotate_self('GLOBALish', $*GLOBALish).annotate_self('W', $*W)
}
method install_doc_phaser($/) {
# Add a default DOC INIT phaser
my $doc := %*COMPILING<%?OPTIONS><doc>;
if $doc {
my $block := $*W.push_lexpad($/);
my $renderer := "Pod::To::$doc";
my $module := $*W.load_module($/, $renderer, {}, $block);
my $pod2text := QAST::Op.new(
:op<callmethod>, :name<render>, :node($/),
self.make_indirect_lookup([$renderer]),
QAST::Var.new(:name<$=pod>, :scope('lexical'), :node($/))
);
$block.push(
QAST::Op.new(
:op('if'),
$pod2text,
QAST::Op.new(
:op<call>, :node($/),
:name('&say'), $pod2text,
),
)
);
# TODO: We should print out $?USAGE too,
# once it's known at compile time
$block.push(
QAST::Op.new(
:op<call>, :node($/),
:name('&exit'),
)
);
$*W.pop_lexpad();
$*W.add_phaser(
$/, 'INIT', $*W.create_code_obj_and_add_child($block, 'Block'), $block
);
}
}
method unitstart($/) {
# Use SET_BLOCK_OUTER_CTX (inherited from HLL::Actions)
# to set dynamic outer lexical context and namespace details
# for the compilation unit.
self.SET_BLOCK_OUTER_CTX($*UNIT_OUTER);
}
method statementlist($/) {
my $past := QAST::Stmts.new( :node($/) );
if $<statement> {
my int $i := 0;
my int $e := nqp::elems($<statement>) - 1;
while $i <= $e {
my $ast := $<statement>[$i].ast;
if $ast {
if $ast.ann('statement_level') && $*statement_level {
$ast.ann('statement_level')();
}
if $ast.ann('sink_ast') {
$ast := QAST::Want.new($ast, 'v', $ast.ann('sink_ast'));
$ast := UNWANTED($ast, 'statementlist/sink_ast') if $i < $e;
}
elsif $ast.ann('bare_block') {
if $i < $e {
$ast := UNWANTED(autosink($ast.ann('bare_block')), "statementlist/bare_block");
}
elsif $*ESCAPEBLOCK {
$ast := WANTED($ast.ann('bare_block'),'statementlist/escape');
}
else {
$ast := autosink($ast.ann('bare_block'));
}
}
else {
if nqp::istype($ast,QAST::Op) && ($ast.op eq 'while' || $ast.op eq 'until' || $ast.op eq 'repeat_while' || $ast.op eq 'repeat_until') {
$ast := UNWANTED($ast,'statementlist/loop'); # statement level loops never want return value
}
elsif $i == $e && $*ESCAPEBLOCK {
$ast := QAST::Stmt.new(autosink(WANTED($ast,'statementlist/else')), :returns($ast.returns));
}
else {
$ast := QAST::Stmt.new(autosink($ast), :returns($ast.returns));
}
}
$ast.node($<statement>[$i]);
$past.push( $ast );
}
++$i;
}
}
if +$past.list < 1 {
$past.push(QAST::WVal.new( :value($*W.find_symbol(['Nil'])) ));
}
else {
my $pl := $past[+@($past) - 1];
if $pl.sunk {
$past.push(QAST::WVal.new( :value($*W.find_symbol(['Nil'])) ));
}
else {
$pl.final(1);
$past.returns($pl.returns);
}
}
make $past;
}
# Produces a LoL from a semicolon list
method semilist($/) {
if $<statement> {
my $past := QAST::Stmts.new( :node($/) );
if $<statement> > 1 {
my $l := QAST::Op.new( :name('&infix:<,>'), :op('call') );
for $<statement> {
my $sast := $_.ast || QAST::WVal.new( :value($*W.find_symbol(['Nil'])) );
$l.push(wanted($sast, 'semilist'));
}
$past.push($l);
$past.annotate('multislice', 1);
}
else {
$past.push($<statement>[0].ast || QAST::WVal.new( :value($*W.find_symbol(['Nil'])) ));
}
make $past;
}
else {
make QAST::Op.new( :op('call'), :name('&infix:<,>') );
}
}
method sequence($/) {
my $past := QAST::Stmts.new( :node($/) );
if $<statement> {
for $<statement> { $past.push($_.ast) if $_.ast; }
}
unless +@($past) {
$past.push( QAST::Op.new( :op('call'), :name('&infix:<,>') ) );
}
make $past;
}
method statement($/) {
my $past;
if $<EXPR> {
my $mc := $<statement_mod_cond>;
my $ml := $<statement_mod_loop>;
$past := $<EXPR>.ast;
if $mc {
if ~$mc<sym> eq 'with' {
make thunkity_thunk($/,'.b',QAST::Op.new( :op('call'), :name('&infix:<andthen>')),[$mc,$<EXPR>]);
return;
}
elsif ~$mc<sym> eq 'without' {
make thunkity_thunk($/,'.b',QAST::Op.new( :op('call'), :name('&infix:<notandthen>')),[$mc,$<EXPR>]);
return;
}
my $mc_ast := $mc.ast;
if $past.ann('bare_block') {
my $cond_block := $past.ann('past_block');
remove_block($*W.cur_lexpad(), $cond_block);
$cond_block.blocktype('immediate');
unless $cond_block.ann('placeholder_sig') {
$cond_block.arity(0);
$cond_block.annotate('count', 0);
}
$past := $cond_block;
}
$mc_ast.push($past);
$mc_ast.push(QAST::WVal.new( :value($*W.find_symbol(['Empty'])) ));
$past := $mc_ast;
}
if $ml {
$past.okifnil(1);
$past[0].okifnil(1) if +@($past);
my $cond := $ml<smexpr>.ast;
if ~$ml<sym> eq 'given' {
unless $past.ann('bare_block') {
$past := make_topic_block_ref($/, $past, migrate_stmt_id => $*STATEMENT_ID);
}
$past := QAST::Op.new( :op('call'), block_closure($past), $cond );
}
elsif ~$ml<sym> eq 'for' {
unless $past.ann('past_block') {
$past := make_topic_block_ref($/, $past, migrate_stmt_id => $*STATEMENT_ID);
}
my $fornode := QAST::Op.new(
:op<p6for>, :node($/),
$cond,
block_closure($past),
);
$past := QAST::Want.new(
$fornode,
'v', QAST::Op.new(:op<p6sink>, $fornode),
);
$past[2].sunk(1);
my $sinkee := $past[0];
$past.annotate('statement_level', -> {
UNWANTED($sinkee, 'force for mod');
$fornode.op('p6forstmt') if can-use-p6forstmt($fornode[1]);
$fornode.annotate('IterationEnd', $*W.find_symbol(['IterationEnd']));
$fornode.annotate('Nil', $*W.find_symbol(['Nil']));
});
}
else {
$past := QAST::Op.new($cond, $past, :op(~$ml<sym>), :node($/) );
}
}
}
elsif $<statement> { $past := $<statement>.ast; }
elsif $<statement_control> { $past := $<statement_control>.ast; }
else { $past := 0; }
if $past {
my $id := $*STATEMENT_ID;
$past.annotate('statement_id', $id);
# only trace when running in source
if $/.pragma('trace') && !$*W.is_precompilation_mode {
my $code := ~$/;
# don't bother putting ops for activating it
if $code eq 'use trace' {
$past := 0;
}
# need to generate code
else {
my $line := $*W.current_line($/);
my $file := $*W.current_file;
$code := subst($code, /\s+$/, ''); # chomp!
$past := QAST::Stmts.new(:node($/),
QAST::Op.new(
:op<writefh>,
QAST::Op.new(:op<getstderr>),
QAST::Op.new(
:op('encode'),
QAST::SVal.new(:value("$id ($file line $line)\n$code\n")),
QAST::SVal.new(:value('utf8')),
QAST::Op.new(
:op('callmethod'), :name('new'),
QAST::WVal.new( :value($*W.find_symbol(['Blob'])) )
)
)
),
$past
);
}
}
}
make $past;
}
method xblock($/) {
make QAST::Op.new( WANTED($<EXPR>.ast, 'xblock'), $<pblock>.ast, :op('if'), :node($/) );
}
method pblock($/) {
if $<blockoid><you_are_here> {
make $<blockoid>.ast;
}
else {
# Locate or build a set of parameters.
my %sig_info;
my @params;
my $block := $<blockoid>.ast;
if $block.ann('placeholder_sig') && $<signature> {
$*W.throw($/, ['X', 'Signature', 'Placeholder'],
precursor => '1',
placeholder => $block.ann('placeholder_sig')[0]<placeholder>,
);
}
elsif $block.ann('placeholder_sig') {
@params := $block.ann('placeholder_sig');
%sig_info<parameters> := @params;
if $*IMPLICIT {
$block[0].push(QAST::Op.new(
:op('bind'),
WANTED(QAST::Var.new( :name('$_'), :scope('lexical') ),'pblock/place'),
WANTED(QAST::Op.new( :op('getlexouter'), QAST::SVal.new( :value('$_') ) ),'pblock/place')
));
}
}
elsif $<signature> {
%sig_info := %*SIG_INFO;
@params := %sig_info<parameters>;
if $*IMPLICIT {
my int $declares_topic := 0;
for @params {
if $_<variable_name> eq '$_' {
$declares_topic := 1;
}
}
unless $declares_topic {
$block[0].push(QAST::Op.new(
:op('bind'),
WANTED(QAST::Var.new( :name('$_'), :scope('lexical') ),'pblock/sig'),
WANTED(QAST::Op.new( :op('getlexouter'), QAST::SVal.new( :value('$_') ) ),'pblock/sig')
));
}
}
$block[1] := wrap_return_type_check($block[1], $*DECLARAND);
}
else {
if $*IMPLICIT {
my $optional := $*IMPLICIT == 1;
@params.push(hash(
:variable_name('$_'), :$optional,
:nominal_type($*W.find_symbol(['Mu'])),
:default_from_outer($optional), :is_raw(1),
));
}
elsif !$block.symbol('$_') {
$block[0].push(QAST::Op.new(
:op('bind'),
WANTED(QAST::Var.new( :name('$_'), :scope('lexical'), :decl('var') ),'pblock/sawone'),
WANTED(QAST::Op.new( :op('getlexouter'), QAST::SVal.new( :value('$_') ) ),'pblock/sawone')
));
$block.symbol('$_', :scope('lexical'), :type($*W.find_symbol(['Mu'])));
}
%sig_info<parameters> := @params;
}
# Create signature object if we didn't already, and set up binding.
my $signature := $*SIG_OBJ // $*W.create_signature_and_params(
$<signature>, %sig_info, $block, 'Mu');
add_signature_binding_code($block, $signature, @params);
# We'll install PAST in current block so it gets capture_lex'd.
# Then evaluate to a reference to the block (non-closure - higher
# up stuff does that if it wants to).
$*W.push_inner_block(my $uninst := QAST::Stmts.new($block));
Perl6::Pod::document($/, $*DECLARAND, $*POD_BLOCK, :leading);
$*W.attach_signature($*DECLARAND, $signature);
$*W.finish_code_object($*DECLARAND, $block);
$*W.add_phasers_handling_code($*DECLARAND, $block);
make reference_to_code_object($*DECLARAND, $block).annotate_self(
'uninstall_if_immediately_used', $uninst
)
}
}
method block($/) {
my $block := $<blockoid>.ast;
if $block.ann('placeholder_sig') {
my $name := $block.ann('placeholder_sig')[0]<variable_name>;
unless $name eq '%_' || $name eq '@_' {
$name := nqp::concat(nqp::substr($name, 0, 1),
nqp::concat('^', nqp::substr($name, 1)));
}
$*W.throw( $/, ['X', 'Placeholder', 'Block'],
placeholder => $name,
);
}
($*W.cur_lexpad())[0].push(my $uninst := QAST::Stmts.new($block));
$*W.attach_signature($*DECLARAND,
$*W.create_signature(nqp::hash('parameter_objects', [])));
$*W.finish_code_object($*DECLARAND, $block);
$*W.add_phasers_handling_code($*DECLARAND, $block);
my $ref := reference_to_code_object($*DECLARAND, $block);
$ref.annotate('uninstall_if_immediately_used', $uninst);
make $ref;
}
method blockoid($/) {
if $<statementlist> {
my $past := statementlist_with_handlers($/);
my $BLOCK := $*CURPAD;
$BLOCK.blocktype('declaration_static');
$BLOCK.push($past);
$BLOCK.node($/);
$BLOCK.annotate('handlers', %*HANDLERS) if %*HANDLERS;
fatalize($past) if $*FATAL;
make $BLOCK;
}
else {
if $*HAS_YOU_ARE_HERE {
$/.panic('{YOU_ARE_HERE} may only appear once in a setting');
}
$*HAS_YOU_ARE_HERE := 1;
make $<you_are_here>.ast;
}
}
sub statementlist_with_handlers($/) {
my $past := $<statementlist>.ast;
my $ret := %*SIG_INFO<returns>;
$past.push(QAST::WVal.new(:value($ret))) if nqp::isconcrete($ret) || $ret.HOW.name($ret) eq 'Nil';
if %*HANDLERS {
$past := QAST::Op.new( :op('handle'), $past );
for %*HANDLERS {
$past.push($_.key);
$past.push($_.value);
}
}
$past
}
# Under "use fatal", re-write all calls to fatalize their return value
# unless we can see they are in a boolean context.
my %boolify_first_child_ops := nqp::hash(
'if', 1, 'unless', 1, 'defor', 1, 'hllbool', 1,
'while', 1, 'until', 1, 'repeat_while', 1, 'repeat_until', 1,
);
my %boolify_first_child_calls := nqp::hash(
'&prefix:<?>', 1, '&prefix:<so>', 1,
'&prefix:<!>', 1, '&prefix:<not>', 1,
'&defined', 1
);
sub fatalize($ast, $bool-context = 0) {
if nqp::istype($ast, QAST::Op) {
my str $op := $ast.op;
if $op eq 'p6fatalize' {
# We've been here before (tree with shared bits, presumably).
}
elsif nqp::existskey(%boolify_first_child_ops, $op) ||
$op eq 'call' && nqp::existskey(%boolify_first_child_calls, $ast.name) {
my int $first := 1;
for @($ast) {
if $first {
fatalize($_, 1);
$first := 0;
}
else {
fatalize($_);
}
}
}
elsif $op eq 'hllize' {
fatalize($_, $bool-context) for @($ast);
}
else {
fatalize($_) for @($ast);
if !$bool-context && ($op eq 'call' || $op eq 'callmethod') {
if $ast.name eq '&fail' {
$ast.name('&die');
}
else {
my $new-node := QAST::Op.new( :node($ast.node), :$op, :name($ast.name), :returns($ast.returns) );
$new-node.push($ast.shift) while @($ast);
$ast.op('p6fatalize');
$ast.push($new-node);
$ast.push(QAST::WVal.new( :value($*W.find_symbol(['Failure'])) ));
}
}
}
}
elsif nqp::istype($ast, QAST::Stmt) || nqp::istype($ast, QAST::Stmts) || nqp::istype($ast, QAST::Want) {
fatalize($_) for @($ast);
}
}
method you_are_here($/) {
make self.CTXSAVE();
}
method newpad($/) {
$*W.cur_lexpad().annotate_self('IN_DECL', $*IN_DECL);
}
method finishpad($/) {
# Generate the $_, $/, and $! lexicals for routines if they aren't
# already declared. For blocks, $_ will come from the outer if it
# isn't already declared.
my $BLOCK := $*W.cur_lexpad();
my $type := $BLOCK.ann('IN_DECL');
if $type eq 'mainline' && %*COMPILING<%?OPTIONS><setting> eq 'NULL' {
# Don't do anything in the case where we are in the mainline of
# the setting; we don't have any symbols (Scalar, etc.) yet.
return 1;
}
my $is_routine := $type eq 'sub' || $type eq 'method' ||
$type eq 'submethod' || $type eq 'mainline';
if $is_routine {
# Generate the lexical variable except if...
# (1) the block already has one, or
# (2) the variable is '$_' and $*IMPLICIT is set
# (this case gets handled by getsig)
unless $BLOCK.symbol('$_') || $*IMPLICIT {
$*W.install_lexical_magical($BLOCK, '$_');
}
for <$/ $! $¢> {
unless $BLOCK.symbol($_) {
$*W.install_lexical_magical($BLOCK, $_);
}
}
}
else {
unless $BLOCK.symbol('$_') {
$BLOCK[0].push(QAST::Var.new( :name('$_'), :scope('lexical'), :decl('var') ));
unless $*IMPLICIT {
$BLOCK[0].push(QAST::Op.new(
:op('bind'),
WANTED(QAST::Var.new( :name('$_'), :scope('lexical') ),'finishpad'),
WANTED(QAST::Op.new( :op('getlexouter'), QAST::SVal.new( :value('$_') ) ),'finishpad')
));
}
$BLOCK.symbol('$_', :scope('lexical'), :type($*W.find_symbol(['Mu'])));
}
}
}
## Statement control
method statement_control:sym<if>($/) {
my $count := +$<xblock> - 1;
my $past;
(my $empty := QAST::WVal.new: :value($*W.find_symbol: ['Empty'])
).annotate: 'ok_to_null_if_sunk', 1;
if ~$<sym>[$count] ~~ /with/ {
$past := xblock_immediate_with( $<xblock>[$count].ast );
$past.op('with');
$past.push: $<else> ?? pblock_immediate_with($<else>.ast) !! $empty;
}
else {
$past := xblock_immediate( $<xblock>[$count].ast );
$past.op('if');
$past.push: $<else> ?? pblock_immediate($<else>.ast) !! $empty;
}
# build if/then/elsif structure
while $count > 0 {
$count--;
my $else := $past;
if ~$<sym>[$count] ~~ /with/ {
$past := xblock_immediate_with( $<xblock>[$count].ast );
$past.op('with');
}
else {
$past := xblock_immediate( $<xblock>[$count].ast );
$past.op('if');
}
$past.push($else);
}
make $past;
}
method statement_control:sym<unless>($/) {
my $past := xblock_immediate( $<xblock>.ast );
$past.push(QAST::WVal.new( :value($*W.find_symbol(['Empty'])) ));
$past.op('unless');
make $past;
}
method statement_control:sym<without>($/) {
my $past := xblock_immediate_with( $<xblock>.ast );
$past.push(QAST::WVal.new( :value($*W.find_symbol(['Empty'])) ));
$past.op('without');
make $past;
}
method statement_control:sym<while>($/) {
my $past := $<xblock>.ast;
$past.op(~$<sym>);
make tweak_loop($past);
}
method statement_control:sym<repeat>($/) {
my $op := 'repeat_' ~ ~$<wu>;
my $past;
if $<xblock> {
$past := $<xblock>.ast;
$past.op($op);
}
else {
$past := QAST::Op.new( $<EXPR>.ast, $<pblock>.ast, :op($op), :node($/) );
}
make tweak_loop($past);
}
method statement_control:sym<for>($/) {
my $xblock := $<xblock>.ast;
my $fornode := QAST::Op.new(
:op<p6for>, :node($/),
$xblock[0],
block_closure($xblock[1]),
);
my $past := QAST::Want.new(
$fornode,
'v', QAST::Op.new(:op<p6sink>, $fornode),
);
if $*LABEL {
my $label := QAST::WVal.new( :value($*W.find_symbol([$*LABEL])), :named('label') );
$past[0].push($label);
}
$past[2].sunk(1);
my $sinkee := $past[0];
$past.annotate('statement_level', -> {
UNWANTED($sinkee,'force for');
if can-use-p6forstmt($fornode[1]) {
$fornode.op('p6forstmt');
$fornode.annotate('IterationEnd', $*W.find_symbol(['IterationEnd']));
$fornode.annotate('Nil', $*W.find_symbol(['Nil']));
}
});
make $past;
}
method statement_control:sym<whenever>($/) {
my $xblock := $<xblock>.ast;
make QAST::Op.new(
:op<call>, :name<&WHENEVER>, :node($/),
$xblock[0], block_closure($xblock[1])
);
}
method statement_control:sym<loop>($/) {
my $cond := $<e2> ?? WANTED($<e2>.ast, 'statement_control/e2') !! QAST::IVal.new( :value(1) );
my $loop := QAST::Op.new( $cond, :op('while'), :node($/) );
$loop.push($<block>.ast);
if $<e3> {
$loop.push(UNWANTED($<e3>.ast, 'statement_control/e3'));
}
$loop := tweak_loop($loop);
if $<e1> {
$loop := QAST::Stmts.new( UNWANTED($<e1>.ast, 'statement_control/e1'), $loop, :node($/) );
}
my $sinkee := $loop[1];
$loop.annotate('statement_level', -> {
UNWANTED($sinkee,'force loop');
if $<e1> {
$loop.push(QAST::WVal.new( :value($*W.find_symbol(['Nil'])) ));
}
});
make $loop;
}
sub tweak_loop($loop) {
if $*LABEL {
$loop.push(QAST::WVal.new( :value($*W.find_symbol([$*LABEL])), :named('label') ));
}
# Handle phasers.
my $code := $loop[1].ann('code_object');
my $block_type := $*W.find_symbol(['Block'], :setting-only);
my $phasers := nqp::getattr($code, $block_type, '$!phasers');
if nqp::isnull($phasers) {
$loop[1] := pblock_immediate($loop[1]);
}
else {
my $node := $loop.node;
if nqp::existskey($phasers, 'NEXT') {
my $phascode := $*W.run_phasers_code($code, $loop[1], $block_type, 'NEXT');
if +@($loop) == 2 {
$loop.push($phascode);
}
else {
$loop[2] := QAST::Stmts.new: :$node, $phascode, $loop[2];
}
}
if nqp::existskey($phasers, 'FIRST') {
my $tmp := QAST::Node.unique('LOOP_BLOCK');
my $var := QAST::Var.new: :$node, :name($tmp), :scope<local>;
$loop := QAST::Stmts.new(:$node,
QAST::Op.new(:$node, :op<bind>, $var.decl_as('var'),
QAST::Op.new: :$node, :op<p6setfirstflag>, $loop[1]),
$loop);
$loop[1][1] := QAST::Op.new(:$node, :op<call>, $var
).annotate_self: 'loop-already-block-first-phaser', $loop;
}
else {
$loop[1] := pblock_immediate($loop[1]);
}
if nqp::existskey($phasers, 'LAST') {
$loop := QAST::Stmts.new(:$node, :resultchild(0), $loop,
$*W.run_phasers_code: $code, $loop[1], $block_type, 'LAST');
}
}
$loop
}
method statement_control:sym<need>($/) {
my $past := QAST::WVal.new( :value($*W.find_symbol(['Nil'])) );
make $past;
}
method statement_control:sym<import>($/) {
# NB: Grammar already passed arglist directly to World, but this seems soon enough to want it.
if $<arglist> && $<arglist><EXPR> {
WANTED($<arglist><EXPR>.ast, 'import');
}
my $past := QAST::WVal.new( :value($*W.find_symbol(['Nil'])) );
make $past;
}
method statement_control:sym<use>($/) {
my $past := QAST::WVal.new( :value($*W.find_symbol(['Nil'])) );
if $<statementlist> {
$past := $<statementlist>.ast;
}
elsif $<arglist> {
WANTED($<arglist><EXPR>.ast, 'use');
}
elsif $<version> {
# TODO: replace this by code that doesn't always die with
# a useless error message
# my $i := -1;
# for $<version><vnum> {
# ++$i;
# if $_ ne '*' && $_ < @MAX_PERL_VERSION[$i] {
# last;
# } elsif $_ > @MAX_PERL_VERSION[$i] {
# my $mpv := nqp::join('.', @MAX_PERL_VERSION);
# $/.panic("Perl $<version> required--this is only v$mpv")
# }
# }
}
make $past;
}
method statement_control:sym<require>($/) {
my $past := QAST::Stmts.new(:node($/));
my $compunit_past;
my $target_package;
my $has_file;
my $longname;
my $*SCOPE := 'my';
if $<module_name> {
for $<module_name><longname><colonpair> -> $colonpair {
if ~$colonpair<identifier> eq 'file' {
$has_file := $colonpair.ast[2];
last;
}
}
$longname := $*W.dissect_longname($<module_name><longname>);
$target_package := $longname.name_past;
}
if $<module_name> && nqp::defined($has_file) == 0 {
my $short_name := nqp::clone($target_package);
$short_name.named('short-name');
my $spec := QAST::Op.new(
:op('callmethod'), :name('new'),
$*W.symbol_lookup(['CompUnit', 'DependencySpecification'], $/),
$short_name,
);
$compunit_past := QAST::Op.new(
:op('callmethod'), :name('need'),
QAST::Op.new(
:op('callmethod'), :name('head'),
$*W.symbol_lookup(['CompUnit', 'RepositoryRegistry'], $/),
),
$spec,
);
}
else {
my $file_past := WANTED(($has_file ?? $has_file !! $<file>.ast), 'require/name');
$compunit_past := QAST::Op.new(
:op('callmethod'), :name('load'),
QAST::Op.new(
:op('callmethod'), :name('head'),
$*W.symbol_lookup(['CompUnit', 'RepositoryRegistry'], $/),
),
QAST::Op.new(
:op('callmethod'), :name('IO'),
$file_past,
),
);
}
my $lexpad := $*W.cur_lexpad();
my $block := $lexpad.ann('code_object');
$block := $*W.blocks[+$*W.blocks - 2] if $block.HOW.name($block) eq 'Code';
if !$lexpad.symbol('%REQUIRE_SYMBOLS') {
declare_variable($/, $past, '%', '', 'REQUIRE_SYMBOLS', []);
$*W.mark_lexical_used_implicitly($lexpad, '%REQUIRE_SYMBOLS');
}
my $require_past := WANTED(QAST::Op.new(:node($/), :op<call>,
:name<&REQUIRE_IMPORT>,
$compunit_past,
),'require');
# An list of the components of the pre-existing outer symbols name (if any)
my $existing_path := $*W.symbol_lookup(['Any'], $/);
# The top level package object of the pre-existing outer package (if any)
my $top-existing := $*W.symbol_lookup(['Any'], $/);
# The name of the lexical stub we insert (if any)
my $lexical_stub;
if $target_package && !$longname.contains_indirect_lookup() {
my $current;
my @components := nqp::clone($longname.components);
my $top := @components.shift;
$existing_path := QAST::Op.new(:op<call>, :name('&infix:<,>'));
my $existing := try $*W.find_symbol([$top]);
if $existing =:= NQPMu {
my $stub := $*W.pkg_create_mo($/, $/.how('package'), :name($top));
$*W.pkg_compose($/, $stub);
$*W.install_lexical_symbol($lexpad,$top,$stub);
$current := nqp::who($stub);
$lexical_stub := QAST::SVal.new(:value($top));
}
else {
$top-existing := QAST::WVal.new(:value($existing));
$current := nqp::who($existing);
$existing_path.push: QAST::SVal.new(:value($top));
}
for @components -> $component {
if nqp::existskey($current,$component) {
$current := nqp::who($current{$component});
$existing_path.push: QAST::SVal.new(:value($component));
}
else {
$lexical_stub := QAST::SVal.new(:value($component)) unless $lexical_stub;
my $stub := $*W.pkg_create_mo($/, $/.how('package'), :name($component));
$*W.pkg_compose($/, $stub);
$current{$component} := $stub;
$current := nqp::who($stub);
}
}
}
$require_past.push($existing_path);
$require_past.push($top-existing);
$require_past.push($lexical_stub // $*W.symbol_lookup(['Any'], $/));
if $<EXPR> {
my $p6_argiter := $*W.compile_time_evaluate($/, WANTED($<EXPR>.ast,'require')).eager.iterator;
my $IterationEnd := $*W.find_symbol(['IterationEnd']);
while !((my $arg := $p6_argiter.pull-one) =:= $IterationEnd) {
my str $symbol := nqp::unbox_s($arg.Str());
$*W.throw($/, ['X', 'Redeclaration'], :$symbol)
if $lexpad.symbol($symbol);
declare_variable($/, $past,
nqp::substr($symbol, 0, 1), '', nqp::substr($symbol, 1),
[]);
$require_past.push($*W.add_string_constant($symbol));
}
}
$past.push($require_past);
my $unwanted := $past.shallow_clone();
$past.push($<module_name>
?? self.make_indirect_lookup($longname.components())
!! $<file>.ast);
make QAST::Want.new(
$past,
'v',
$unwanted
);
}
method statement_control:sym<given>($/) {
my $past := $<xblock>.ast;
$past.push($past.shift); # swap [0] and [1] elements
$past[0] := block_closure($past[0]);
$past.op('call');
make $past;
}
method statement_control:sym<when>($/) {
# Get hold of the smartmatch expression and the block.
my $xblock := $<xblock>.ast;
my $sm_exp := $xblock.shift;
my $pblock := $xblock.shift;
check_smartmatch($<xblock>,$sm_exp);
# Handle the smart-match.
my $match_past := QAST::Op.new( :op('callmethod'), :name('ACCEPTS'),
$sm_exp,
WANTED(QAST::Var.new( :name('$_'), :scope('lexical') ),'when')
);
# Use the smartmatch result as the condition for running the block,
# and ensure continue/succeed handlers are in place and that a
# succeed happens after the block.
$pblock := pblock_immediate($pblock);
make QAST::Op.new( :op('if'), :node( $/ ),
$match_past, when_handler_helper($pblock)
);
}
method statement_control:sym<default>($/) {
# We always execute this, so just need the block, however we also
# want to make sure we succeed after running it.
make when_handler_helper($<block>.ast);
}
method statement_control:sym<CATCH>($/) {
if nqp::existskey(%*HANDLERS, 'CATCH') {
$*W.throw($/, ['X', 'Phaser', 'Multiple'], block => 'CATCH');
}
my $block := $<block>.ast;
set_block_handler($/, $block, 'CATCH');
make QAST::WVal.new( :value($*W.find_symbol(['Nil'])) );
}
method statement_control:sym<CONTROL>($/) {
if nqp::existskey(%*HANDLERS, 'CONTROL') {
$*W.throw($/, ['X', 'Phaser', 'Multiple'], block => 'CONTROL');
}
my $block := $<block>.ast;
set_block_handler($/, $block, 'CONTROL');
make QAST::WVal.new( :value($*W.find_symbol(['Nil'])) );
}
method statement_control:sym<QUIT>($/) {
my $block := $<block>.ast;
# Take exception as parameter and bind into $_.
my $past := $block.ann('past_block');
$past[0].push(QAST::Op.new(
:op('bind'),
WANTED(QAST::Var.new( :name('$_'), :scope('lexical') ),'QUIT'),
WANTED(QAST::Var.new( :name('__param'), :scope('local'), :decl('param') ),'QUIT')
));
# If the handler has a succeed handler, then make sure we sink
# the exception it will produce.
if $past.ann('handlers') && nqp::existskey($past.ann('handlers'), 'SUCCEED') {
my $suc := $past.ann('handlers')<SUCCEED>;
$suc[0] := QAST::Stmts.new(
sink(QAST::Op.new(
:op('getpayload'),
QAST::Op.new( :op('exception') )
)),
QAST::WVal.new( :value($*W.find_symbol(['Nil'])) )
);
}
# If we don't handle the exception by succeeding, we'll return it.
if $past.ann('handlers') {
$past[1][0].push(WANTED(QAST::Var.new( :name('$_'), :scope('lexical') ),'QUIT/handlers'));
}
else {
$past[1].push(WANTED(QAST::Var.new( :name('$_'), :scope('lexical') ),'QUIT/handlers'));
}
# Add as a QUIT phaser, which evaluates to Nil.
make $*W.add_phaser($/, 'QUIT', $block.ann('code_object'));
}
method statement_prefix:sym<BEGIN>($/) {
my $qast_block := $<blorst>.ast.ann('past_block');
begin_time_lexical_fixup($qast_block);
$qast_block.annotate('BEGINISH', 1);
make $*W.add_phaser($/, 'BEGIN', wanted($<blorst>.ast,'BEGIN').ann('code_object'));
}
method statement_prefix:sym<CHECK>($/) {
my $qast_block := $<blorst>.ast.ann('past_block');
begin_time_lexical_fixup($qast_block);
$qast_block.annotate('BEGINISH', 1);
make $*W.add_phaser($/, 'CHECK', wanted($<blorst>.ast,'CHECK').ann('code_object'));
}
method statement_prefix:sym<COMPOSE>($/) { make $*W.add_phaser($/, 'COMPOSE', unwanted($<blorst>.ast,'COMPOSE').ann('code_object')); }
method statement_prefix:sym<INIT>($/) { make $*W.add_phaser($/, 'INIT', wanted($<blorst>.ast,'INIT').ann('code_object'), ($<blorst>.ast).ann('past_block')); }
method statement_prefix:sym<ENTER>($/) { make $*W.add_phaser($/, 'ENTER', wanted($<blorst>.ast,'ENTER').ann('code_object')); }
method statement_prefix:sym<FIRST>($/) { make $*W.add_phaser($/, 'FIRST', wanted($<blorst>.ast,'FIRST').ann('code_object')); }
method statement_prefix:sym<END>($/) { make $*W.add_phaser($/, 'END', unwanted($<blorst>.ast,'END').ann('code_object')); }
method statement_prefix:sym<LEAVE>($/) { make $*W.add_phaser($/, 'LEAVE', unwanted($<blorst>.ast,'LEAVE').ann('code_object')); }
method statement_prefix:sym<KEEP>($/) { make $*W.add_phaser($/, 'KEEP', unwanted($<blorst>.ast,'KEEP').ann('code_object')); }
method statement_prefix:sym<UNDO>($/) { make $*W.add_phaser($/, 'UNDO', unwanted($<blorst>.ast,'UNDO').ann('code_object')); }
method statement_prefix:sym<NEXT>($/) { make $*W.add_phaser($/, 'NEXT', unwanted($<blorst>.ast,'NEXT').ann('code_object')); }
method statement_prefix:sym<LAST>($/) { make $*W.add_phaser($/, 'LAST', unwanted($<blorst>.ast,'LAST').ann('code_object')); }
method statement_prefix:sym<PRE>($/) { make $*W.add_phaser($/, 'PRE', wanted($<blorst>.ast,'PRE').ann('code_object'), ($<blorst>.ast).ann('past_block')); }
method statement_prefix:sym<POST>($/) { make $*W.add_phaser($/, 'POST', wanted($<blorst>.ast,'POST').ann('code_object'), ($<blorst>.ast).ann('past_block')); }
method statement_prefix:sym<CLOSE>($/) { make $*W.add_phaser($/, 'CLOSE', unwanted($<blorst>.ast,'CLOSE').ann('code_object')); }
method statement_prefix:sym<DOC>($/) {
if %*COMPILING<%?OPTIONS><doc> {
make $*W.add_phaser($/, ~$<phase>, ($<blorst>.ast).ann('code_object'), wanted($<blorst>.ast,'DOC').ann('past_block'));
}
else {
make QAST::WVal.new( :value($*W.find_symbol(['Nil'])) );
}
}
method statement_prefix:sym<do>($/) {
make QAST::Op.new( :op('call'), $<blorst>.ast );
}
method statement_prefix:sym<gather>($/) {
my $past := unwanted($<blorst>.ast,'gather');
$past.ann('past_block').push(QAST::WVal.new( :value($*W.find_symbol(['Nil'])) ));
make QAST::Op.new( :op('call'), :name('&GATHER'), $past );
}
method statement_prefix:sym<supply>($/) {
# Case-analyze what's inside of the Supply, to spot cases that can be
# turned into something cheap rather than needing the whole supply
# concurrency control mechanism.
my $past := $<blorst>.ast;
my $block := $past.ann('past_block');
if $*WHENEVER_COUNT == 0 {
my $stmts := $block[1];
if nqp::istype($stmts, QAST::Stmts) && nqp::elems($stmts) == 1 {
my $stmt := $stmts[0];
$stmt := $stmt[0] if nqp::istype($stmt, QAST::Want);
if nqp::istype($stmt, QAST::Op) && $stmt.op eq 'call' && $stmt.name eq '&emit'
&& nqp::elems($stmt.list) == 1 {
# Single statement emit; make block just return the expression
# (or die) and pass it to something that'll cheaply do a one
# shot emit.
$stmts[0] := $stmt[0];
make QAST::Op.new( :op('call'), :name('&SUPPLY-ONE-EMIT'), $past );
return 1;
}
}
}
elsif single_top_level_whenever($block) {
$past.ann('past_block').push(QAST::WVal.new( :value($*W.find_symbol(['Nil'])) ));
make QAST::Op.new( :op('call'), :name('&SUPPLY-ONE-WHENEVER'), $past );
return 1;
}
$past.ann('past_block').push(QAST::WVal.new( :value($*W.find_symbol(['Nil'])) ));
make QAST::Op.new( :op('call'), :name('&SUPPLY'), $past );
}
sub single_top_level_whenever($block) {
if $*WHENEVER_COUNT == 1
&& nqp::getcomp('perl6').language_version ne '6.c' {
my $stmts := $block[1];
if nqp::istype($stmts, QAST::Stmts) {
my @stmts := $stmts.list;
my $last := @stmts[nqp::elems(@stmts) - 1];
if nqp::istype($last, QAST::Stmt) {
return 0 if nqp::elems($last.list) != 1;
$last := $last[0];
}
if nqp::istype($last, QAST::Want) {
$last := $last[0];
}
if nqp::istype($last, QAST::Op) && $last.op eq 'call' && $last.name eq '&WHENEVER' {
return 1;
}
}
}
return 0;
}
method statement_prefix:sym<react>($/) {
my $past := $<blorst>.ast;
my $block := $past.ann('past_block');
if single_top_level_whenever($block) {
$past.ann('past_block').push(QAST::WVal.new( :value($*W.find_symbol(['Nil'])) ));
make QAST::Op.new( :op('call'), :name('&REACT-ONE-WHENEVER'), $past );
}
else {
$past.ann('past_block').push(QAST::WVal.new( :value($*W.find_symbol(['Nil'])) ));
make QAST::Op.new( :op('call'), :name('&REACT'), $past );
}
}
method statement_prefix:sym<once>($/) {
# create state variable to remember whether we ran the block
my $pad := $*W.cur_lexpad();
my $sym := $pad.unique('once_');
my $mu := $*W.find_symbol(['Mu']);
my $descriptor := $*W.create_container_descriptor($mu, $sym);
my %info;
%info<container_type> := %info<container_base> := $*W.find_symbol(['Scalar']);
%info<scalar_value> := %info<default_value> := %info<bind_constraint> := %info<value_type> := $mu;
$*W.install_lexical_container($pad, $sym, %info, $descriptor, :scope('state'));
for @($pad[0]) {
if nqp::istype($_, QAST::Var) && $_.name eq $sym {
# Mark, so we can migrate the once into a correct scope.
$_.annotate('statement_id', $*STATEMENT_ID);
$_.annotate('in_stmt_mod', $*IN_STMT_MOD);
last;
}
}
# generate code that runs the block only once
make QAST::Op.new(
:op('decont'),
QAST::Op.new(
:op('if'),
QAST::Op.new( :op('p6stateinit') ),
QAST::Op.new(
:op('p6store'),
WANTED(QAST::Var.new(:name($sym), :scope('lexical')),'once'),
QAST::Op.new( :op('call'), wanted($<blorst>.ast,'once') )
),
WANTED(QAST::Var.new( :name($sym), :scope('lexical') ),'once')
)
);
}
method statement_prefix:sym<start>($/) {
my $block := $<blorst>.ast.ann('past_block');
unless $block.symbol('$/') {
$*W.install_lexical_magical($block, '$/');
}
unless $block.symbol('$!') {
$*W.install_lexical_magical($block, '$!');
}
my $qast := QAST::Op.new(
:op('callmethod'),
:name('start'),
:returns($*W.find_symbol(['Promise'])),
QAST::WVal.new( :value($*W.find_symbol(['Promise'])) ),
$<blorst>.ast
);
unless $*W.lang-ver-before('d') {
$qast.push(QAST::WVal.new(
:value($*W.find_symbol(['Bool', 'True'])),
:named('report-broken-if-sunk')
));
}
make $qast;
}
method statement_prefix:sym<lazy>($/) {
if $<for> {
my $ast := $<for>.ast;
$ast[0].annotate('mode', 'lazy');
$ast.annotate('statement_level', NQPMu);
make $ast;
}
else {
make QAST::Op.new(
:op('callmethod'), :name('lazy'),
QAST::Op.new( :op('call'), $<blorst>.ast )
);
}
}
method statement_prefix:sym<eager>($/) {
make QAST::Op.new(
:op('callmethod'), :name('eager'),
QAST::Op.new( :op('call'), $<blorst>.ast )
);
}
method statement_prefix:sym<hyper>($/) {
if $<for> {
my $ast := $<for>.ast;
$ast[0].annotate('mode', 'hyper');
$ast.annotate('statement_level', NQPMu);
make $ast;
}
else {
make QAST::Op.new(
:op('callmethod'), :name('hyper'),
QAST::Op.new( :op('call'), $<blorst>.ast )
);
}
}
method statement_prefix:sym<race>($/) {
if $<for> {
my $ast := $<for>.ast;
$ast[0].annotate('mode', 'race');
$ast.annotate('statement_level', NQPMu);
make $ast;
}
else {
make QAST::Op.new(
:op('callmethod'), :name('race'),
QAST::Op.new( :op('call'), $<blorst>.ast )
);
}
}
method statement_prefix:sym<sink>($/) {
my $qast :=
QAST::Stmts.new: :node($/),
QAST::Op.new(:op<callmethod>, :name<sink>,
QAST::Op.new(:op<call>, $<blorst>.ast)),
QAST::Var.new: :name<Nil>, :scope<lexical>;
# if user is trying to sink a variable, don't complain about uselessness
my $block-stmts := $<blorst>.ast.ann('past_block')[1];
$block-stmts[0] := WANTED($block-stmts[0], 'statement_prefix/sink')
if nqp::istype($block-stmts[0], QAST::Var);
make $qast;
}
method statement_prefix:sym<try>($/) {
my $block := $<blorst>.ast;
my $past;
if $block.ann('past_block').ann('handlers') && $block.ann('past_block').ann('handlers')<CATCH> {
# we already have a CATCH block, nothing to do here
$past := QAST::Op.new( :op('call'), $block );
} else {
$block := QAST::Op.new(:op<call>, $block);
$past := QAST::Op.new(
:op('handle'),
# Success path puts Any into $! and evaluates to the block.
QAST::Stmt.new(
:resultchild(0),
$block,
QAST::Op.new(
:op('p6store'),
QAST::Var.new( :name<$!>, :scope<lexical> ),
QAST::Var.new( :name<Any>, :scope<lexical> )
)
),
# On failure, capture the exception object into $!.
'CATCH', QAST::Stmts.new(
QAST::Op.new(
:op('p6store'),
QAST::Var.new(:name<$!>, :scope<lexical>),
QAST::Op.new(
:name<&EXCEPTION>, :op<call>,
QAST::Op.new( :op('exception') )
),
),
QAST::WVal.new(
:value( $*W.find_symbol(['Nil']) ),
),
)
);
}
make $past;
}
method statement_prefix:sym<quietly>($/) {
make QAST::Op.new(
:op('handle'),
QAST::Op.new( :op('call'), $<blorst>.ast ),
'WARN',
QAST::Op.new( :op('resume'), QAST::Op.new( :op('exception') ) )
);
}
method blorst($/) {
my $block;
if $<block> {
$block := $<block>.ast;
}
else {
my $stmt := $<statement>.ast;
$block := make_thunk_ref($stmt, $/);
migrate_blocks($*W.cur_lexpad, $block.ann('past_block'),
-> $b { ($b.ann('statement_id') // -1) == $stmt.ann('statement_id') });
}
make block_closure($block);
}
# Statement modifiers
method modifier_expr($/) { make WANTED($<EXPR>.ast, 'modifier_expr'); }
method statement_mod_cond:sym<if>($/) {
make QAST::Op.new( :op<if>, $<modifier_expr>.ast, :node($/) );
}
method statement_mod_cond:sym<unless>($/) {
make QAST::Op.new( :op<unless>, $<modifier_expr>.ast, :node($/) );
}
method statement_mod_cond:sym<when>($/) {
my $pat := $<modifier_expr>.ast;
check_smartmatch($<modifier_expr>,$pat);
make QAST::Op.new( :op<if>,
QAST::Op.new( :name('ACCEPTS'), :op('callmethod'),
$pat,
WANTED(QAST::Var.new( :name('$_'), :scope('lexical') ),'when') ),
:node($/)
);
}
method statement_mod_cond:sym<with>($/) { make $<modifier_expr>.ast; }
method statement_mod_cond:sym<without>($/) { make $<modifier_expr>.ast; }
method smexpr($/) { make WANTED($<EXPR>.ast, 'smexpr'); }
method statement_mod_loop:sym<while>($/) { make $<smexpr>.ast; }
method statement_mod_loop:sym<until>($/) { make $<smexpr>.ast; }
method statement_mod_loop:sym<for>($/) { make $<smexpr>.ast; }
method statement_mod_loop:sym<given>($/) { make $<smexpr>.ast; }
## Terms
method term:sym<fatarrow>($/) { make $<fatarrow>.ast; }
method term:sym<colonpair>($/) { make $<colonpair>.ast; }
method term:sym<variable>($/) { make $<variable>.ast; }
method term:sym<package_declarator>($/) { make $<package_declarator>.ast; }
method term:sym<scope_declarator>($/) { make $<scope_declarator>.ast; }
method term:sym<routine_declarator>($/) { make $<routine_declarator>.ast; }
method term:sym<multi_declarator>($/) { make $<multi_declarator>.ast; }
method term:sym<regex_declarator>($/) { make $<regex_declarator>.ast; }
method term:sym<type_declarator>($/) { make $<type_declarator>.ast; }
method term:sym<circumfix>($/) { make $<circumfix>.ast; }
method term:sym<statement_prefix>($/) { make $<statement_prefix>.ast; }
method term:sym<sigterm>($/) { make $<sigterm>.ast; }
method term:sym<lambda>($/) {
my $ast := $<pblock>.ast;
my $block := $ast.ann('past_block');
$block[0].push(QAST::Var.new( :name('$*DISPATCHER'), :scope('lexical'), :decl('var') ));
$block[0].push(QAST::Op.new(
:op('takedispatcher'),
QAST::SVal.new( :value('$*DISPATCHER') )
));
make block_closure($ast);
}
method term:sym<unquote>($/) {
make QAST::Unquote.new(:position(nqp::elems(@*UNQUOTE_ASTS)));
@*UNQUOTE_ASTS.push($<statementlist>.ast);
}
method name($/) { }
method fatarrow($/) {
make make_pair($/,$<key>.Str, wanted($<val>.ast, 'fatarrow'));
}
method coloncircumfix($/) {
make $<circumfix>
?? $<circumfix>.ast
!! QAST::WVal.new( :value($*W.find_symbol(['Nil'])) );
}
method colonpair($/) {
if $*key {
if $<var> {
make make_pair($/,$*key, $<var>.ast);
}
elsif $<num> {
make make_pair($/,$*key, $*W.add_numeric_constant($/, 'Int', $*value));
}
elsif $*value ~~ NQPCapture {
my $val_ast := $*value.ast;
if nqp::istype($val_ast, QAST::Stmts) && +@($val_ast) == 1 {
$val_ast := $val_ast[0];
}
make make_pair($/,$*key, $val_ast);
}
else {
make make_pair($/,$*key, QAST::Op.new(
:op('hllbool'),
QAST::IVal.new( :value($*value) )
));
}
}
elsif $<fakesignature> {
make $<fakesignature>.ast;
}
else {
make $*value.ast;
}
}
method colonpair_variable($/) {
if $<capvar> {
make QAST::Op.new(
:op('call'),
:name('&postcircumfix:<{ }>'),
QAST::Var.new(:name('$/'), :scope('lexical')),
$*W.add_string_constant(~$<desigilname>)
);
}
else {
make make_variable($/, [~$/]);
}
}
sub make_pair($/,$key_str, $value) {
my $key := $*W.add_string_constant($key_str);
my $pair := QAST::Op.new(
:op('callmethod'), :name('new'), :returns($*W.find_symbol(['Pair'])), :node($/),
WANTED(QAST::Var.new( :name('Pair'), :scope('lexical'), :node($/) ),'make_pair'),
$key, WANTED($value, 'make_pair')
);
$pair.nosink(1);
$pair;
}
method desigilname($/) {
if $<variable> {
make QAST::Op.new( :op('callmethod'), wanted($<variable>.ast, 'desigilname') );
}
}
method variable($/) {
my $past;
if $<index> {
$past := QAST::Op.new(
:op('call'),
:name('&postcircumfix:<[ ]>'),
QAST::Var.new(:name('$/'), :scope('lexical')),
$*W.add_constant('Int', 'int', nqp::radix(10, $<index>, 0, 0)[0]),
);
if $<sigil> eq '@' || $<sigil> eq '%' {
my $name := $<sigil> eq '@' ?? 'list' !! 'hash';
$past := QAST::Op.new( :op('callmethod'), :name($name), $past );
}
}
elsif $<postcircumfix> {
$past := $<postcircumfix>.ast;
$past.unshift( QAST::Var.new( :name('$/'), :scope('lexical') ) );
if $<sigil> eq '@' || $<sigil> eq '%' {
my $name := $<sigil> eq '@' ?? 'list' !! 'hash';
$past := QAST::Op.new( :op('callmethod'), :name($name), $past );
}
}
elsif $<contextualizer> {
$past := $<contextualizer>.ast;
}
elsif $<infixish> {
my $name := '&infix' ~ $*W.canonicalize_pair('', $<infixish>.Str);
$past := QAST::Op.new(
:op('ifnull'),
QAST::Var.new( :name($name), :scope('lexical') ),
QAST::Op.new(
:op('die_s'),
QAST::SVal.new( :value("Could not find sub $name") )
));
}
elsif $<desigilname><variable> {
$past := $<desigilname>.ast;
$past.name(~$<sigil> eq '@' ?? 'cache' !!
~$<sigil> eq '%' ?? 'hash' !!
'item');
}
else {
my $indirect;
if $<desigilname> && $<desigilname><longname> {
my $longname := $*W.dissect_longname($<desigilname><longname>);
if $longname.contains_indirect_lookup() {
if $*IN_DECL {
$*W.throw($/, ['X', 'Syntax', 'Variable', 'IndirectDeclaration']);
}
$past := self.make_indirect_lookup($longname.components(), ~$<sigil>);
$indirect := 1;
}
else {
$past := make_variable($/, $longname.attach_adverbs.variable_components(
~$<sigil>, $<twigil> ?? ~$<twigil> !! ''));
}
}
else {
my $name := ~$/;
if !$*IN_DECL && nqp::chars($name) == 1 && $name eq ~$<sigil> {
my $*IN_DECL := 'variable';
my $*SCOPE := 'state';
my $*OFTYPE; # should default to Mu/Mu/Any
$past := QAST::Var.new( :node($/) );
$past := declare_variable($/, $past, $name, '', '', []);
$past.nosink(1);
}
else {
$past := make_variable($/, [$name]);
}
}
}
if $*IN_DECL eq 'variable' {
$past.sinkok(1);
}
make $past;
}
method contextualizer($/) {
my $past := $<coercee>.ast;
my $has_magic := $*W.lang-ver-before('d') && $<coercee> eq '';
if $has_magic && $<sigil> eq '$' { # for '$()'
my $result_var := $past.unique('sm_result');
$past := QAST::Stmt.new(
# Evaluate RHS and call ACCEPTS on it, passing in $_. Bind the
# return value to a result variable.
QAST::Op.new( :op('bind'),
QAST::Var.new( :name($result_var), :scope('local'), :decl('var') ),
QAST::Op.new(
:op('if'),
# condition
QAST::Op.new(
:op('callmethod'), :name('ast'),
QAST::Var.new( :name('$/'), :scope('lexical') )
),
# when true
QAST::Op.new(
:op('callmethod'), :name('ast'),
QAST::Var.new( :name('$/'), :scope('lexical') )
),
# when false
QAST::Op.new(
:op('callmethod'), :name('Str'),
QAST::Var.new( :name('$/'), :scope('lexical') )
)
)
),
# And finally evaluate to the smart-match result.
WANTED(QAST::Var.new( :name($result_var), :scope('local') ),'make_smartmatch')
);
$past := QAST::Op.new( :op('locallifetime'), $past, $result_var );
}
else {
my $name := ~$<sigil> eq '@' ?? 'cache' !!
~$<sigil> eq '%' ?? 'hash' !!
'item';
# @() and %()
$past := QAST::Var.new( :name('$/'), :scope('lexical') ) if $has_magic;
$past := QAST::Op.new( :op('callmethod'), :name($name), $past );
}
make WANTED($past, 'contextualizer');
}
sub make_variable($/, @name) {
make_variable_from_parts($/, @name, ~$<sigil>, ~$<twigil>, ~$<desigilname>);
}
sub make_variable_from_parts($/, @name, $sigil, $twigil, $desigilname) {
my $past := QAST::Var.new( :name(@name[+@name - 1]), :node($/));
my $name := $past.name();
if $twigil eq '*' {
if +@name > 1 {
$*W.throw($/, 'X::Dynamic::Package', symbol => ~$/);
}
$past := QAST::Op.new(
:op('call'), :name('&DYNAMIC'),
$*W.add_string_constant($name));
}
elsif $twigil eq '?' && $*IN_DECL eq 'variable' && !$*COMPILING_CORE_SETTING {
$*W.throw($/, 'X::Syntax::Variable::Twigil',
twigil => $twigil,
scope => $*SCOPE,
additional => ' because it is reserved'
);
}
elsif $twigil eq '!' {
# In a declaration, don't produce anything here.
if $*IN_DECL ne 'variable' {
setup_attr_var($/, $past);
}
}
elsif ($twigil eq '.' || $twigil eq '.^') && $*IN_DECL ne 'variable' {
if !$*HAS_SELF {
$*W.throw($/, ['X', 'Syntax', 'NoSelf'], variable => $name);
} elsif $*HAS_SELF eq 'partial' {
$*W.throw($/, ['X', 'Syntax', 'VirtualCall'], call => $name);
}
# Need to transform this to a method call.
$past := $<arglist> ?? $<arglist>.ast !! QAST::Op.new();
if $twigil eq '.^' {
$past.op('p6callmethodhow');
}
else {
$past.op('callmethod');
}
$past.name($desigilname);
$past.unshift(QAST::Var.new( :name('self'), :scope('lexical') ));
# Contextualize based on sigil.
$past := QAST::Op.new(
:op('callmethod'),
:name($sigil eq '@' ?? 'list' !!
$sigil eq '%' ?? 'hash' !!
'item'),
$past);
}
elsif $twigil eq '^' || $twigil eq ':' {
$past := add_placeholder_parameter($/, $sigil, $desigilname,
:named($twigil eq ':'), :full_name($name));
}
elsif $twigil eq '~' {
$past := QAST::Op.new(
:op<callmethod>, :name<new>, :returns($*W.find_symbol(['Slang'])),
QAST::Var.new( :name<Slang>, :scope<lexical> ));
my $g := $/.slang_grammar($desigilname);
$*W.add_object_if_no_sc($g);
my $a := $/.slang_actions($desigilname);
if !nqp::isnull($g) {
my $wval := QAST::WVal.new( :value($g) );
$wval.named('grammar');
$past.push($wval);
$wval := QAST::WVal.new( :value($a) );
$wval.named('actions');
$past.push($wval);
}
}
elsif $twigil eq '=' && $desigilname ne 'pod' && $desigilname ne 'finish' {
$*W.throw($/,
'X::Comp::NYI', feature => 'Pod variable ' ~ $name);
}
elsif $name eq '@_' {
if $*W.nearest_signatured_block_declares('@_') {
$past.scope('lexical');
}
else {
$past := add_placeholder_parameter($/, '@', '_',
:pos_slurpy(1), :full_name($name));
}
}
elsif $name eq '%_' {
if $*W.nearest_signatured_block_declares('%_') || $*METHODTYPE {
$past.scope('lexical');
}
else {
$past := add_placeholder_parameter($/, '%', '_', :named_slurpy(1),
:full_name($name));
}
}
elsif $name eq '$?LANG' || $name eq '$?LINE' || $name eq '$?FILE' {
if $*IN_DECL eq 'variable' {
$*W.throw($/, 'X::Syntax::Variable::Twigil',
twigil => '?',
scope => $*SCOPE,
);
}
if $name eq '$?LANG' {
my $cursor := $/;
$*W.add_object_if_no_sc($cursor);
$past := QAST::WVal.new(:value($cursor));
}
elsif $name eq '$?LINE' {
$past := $*W.add_constant('Int', 'int', $*W.current_line($/));
}
else {
$past := $*W.add_string_constant($*W.current_file);
}
}
elsif $name eq '%?RESOURCES' {
my $resources := nqp::getlexdyn('$*RESOURCES');
unless $resources {
my $Resources := $*W.find_symbol(['Distribution', 'Resources']);
$resources := $Resources.from-precomp();
}
if $resources {
$past := QAST::WVal.new( :value($resources) );
if nqp::isnull(nqp::getobjsc($resources)) {
$*W.add_object_if_no_sc($resources);
}
}
else {
$past := QAST::WVal.new( :value($*W.find_symbol(['Nil'])) );
}
}
elsif $name eq '$?DISTRIBUTION' {
my $distribution := nqp::getlexdyn('$*DISTRIBUTION');
unless $distribution {
my $Distribution := $*W.find_symbol(['CompUnit', 'Repository', 'Distribution']);
$distribution := $Distribution.from-precomp();
}
if $distribution {
$past := QAST::WVal.new( :value($distribution) );
if nqp::isnull(nqp::getobjsc($distribution)) {
$*W.add_object_if_no_sc($distribution);
}
}
else {
$past := QAST::WVal.new( :value($*W.find_symbol(['Nil'])) );
}
}
elsif $name eq '&?BLOCK' || $name eq '&?ROUTINE' {
if $*IN_DECL eq 'variable' {