Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
tree: 93fa3d5561
Fetching contributors…

Cannot retrieve contributors at this time

2872 lines (2602 sloc) 93.502 kB
class Perl6::Actions is HLL::Actions;
our @BLOCK;
our @PACKAGE;
our $TRUE;
our %BEGINDONE;
INIT {
# initialize @BLOCK and @PACKAGE
our @BLOCK := Q:PIR { %r = root_new ['parrot';'ResizablePMCArray'] };
our @PACKAGE := Q:PIR { %r = root_new ['parrot';'ResizablePMCArray'] };
@PACKAGE.unshift(Perl6::Compiler::Module.new());
our $TRUE := PAST::Var.new( :name('true'), :scope('register') );
our %BEGINDONE := Q:PIR { %r = root_new ['parrot';'Hash'] };
# Tell PAST::Var how to encode Perl6Str and Str values
my %valflags :=
Q:PIR { %r = get_hll_global ['PAST';'Compiler'], '%valflags' };
%valflags<Perl6Str> := 'e';
%valflags<Str> := 'e';
}
sub xblock_immediate($xblock) {
$xblock[1] := block_immediate($xblock[1]);
$xblock;
}
sub block_immediate($block) {
$block.blocktype('immediate');
$block;
}
sub sigiltype($sigil) {
$sigil eq '%'
?? 'Hash'
!! ($sigil eq '@' ?? 'Array' !! 'Perl6Scalar');
}
method deflongname($/) {
make $<colonpair>
?? ~$<name> ~ ':<' ~ ~$<colonpair>[0]<circumfix><quote_EXPR><quote_delimited><quote_atom>[0] ~ '>'
!! ~$<name>;
}
method comp_unit($/) {
# Create the block for the mainline code.
my $mainline := @BLOCK.shift;
$mainline.push($<statementlist>.ast);
# Create a block for the entire compilation unit.
our $?RAKUDO_HLL;
my $unit := PAST::Block.new( :node($/), :hll($?RAKUDO_HLL) );
# Executing the compilation unit causes the mainline to be executed.
# We force a tailcall here, because we have other :load/:init blocks
# that have to be done at the end of the unit, and we don't want them
# executed by the mainline.
$unit.push(
PAST::Op.new(
:pirop('tailcall'),
PAST::Var.new( :name('!UNIT_START'), :namespace(''), :scope('package') ),
$mainline,
PAST::Var.new( :scope('parameter'), :name('@_'), :slurpy(1) )
)
);
# CHECK time occurs at the end of the compilation unit, :load/:init.
# (We can't # use the .loadinit property because that will generate
# the CHECK block too early.)
$unit.push(
PAST::Block.new(
:pirflags(':load :init'), :lexical(0), :namespace(''),
PAST::Op.new( :name('!fire_phasers'), 'CHECK' )
)
);
# If this unit is loaded via load_bytecode, we want it to automatically
# execute the mainline code above after all other initializations have
# occurred.
$unit.push(
PAST::Block.new(
:pirflags(':load'), :lexical(0), :namespace(''),
PAST::Op.new(
:name('!UNIT_START'), :pasttype('call'),
PAST::Val.new( :value($unit) ),
)
)
);
# Make sure we have a clean @PACKAGE for next time.
@PACKAGE.shift;
@PACKAGE.unshift(Perl6::Compiler::Module.new());
make $unit;
}
method statementlist($/) {
my $past := PAST::Stmts.new( :node($/) );
if $<statement> {
for $<statement> {
my $ast := $_.ast;
if $ast {
if $ast.isa(PAST::Block) && !$ast.blocktype {
$ast := block_immediate($ast);
}
elsif $ast<past_block> && !$ast<past_block>.blocktype {
$ast := block_immediate($ast<past_block>);
}
$past.push( $ast );
}
}
}
make $past;
}
method semilist($/) {
my $past := PAST::Stmts.new( :node($/) );
if $<statement> {
for $<statement> { $past.push($_.ast); }
}
else { $past.push( PAST::Op.new( :name('&Nil') ) ); }
make $past;
}
method statement($/, $key?) {
my $past;
if $<EXPR> {
my $mc := $<statement_mod_cond>[0];
my $ml := $<statement_mod_loop>[0];
$past := $<EXPR>.ast;
if $mc {
$past := PAST::Op.new($mc<cond>.ast, $past, PAST::Op.new(:name('&Nil')),
:pasttype(~$mc<sym>), :node($/) );
}
if $ml {
my $cond := $ml<smexpr>.ast;
if ~$ml<sym> eq 'given' {
$past := PAST::Op.new(
:pasttype('call'),
PAST::Block.new(
:blocktype('declaration'),
PAST::Var.new( :name('$_'), :scope('parameter'), :isdecl(1) ),
$past
),
$cond
);
}
elsif ~$ml<sym> eq 'for' {
$past := PAST::Block.new( :blocktype('immediate'),
PAST::Var.new( :name('$_'), :scope('parameter'), :isdecl(1) ),
$past);
$cond := PAST::Op.new(:name('&eager'), $cond);
$past := PAST::Op.new($cond, $past, :pasttype(~$ml<sym>), :node($/) );
}
else {
$past := PAST::Op.new($cond, $past, :pasttype(~$ml<sym>), :node($/) );
}
}
}
elsif $<statement_control> { $past := $<statement_control>.ast; }
else { $past := 0; }
make $past;
}
method xblock($/) {
make PAST::Op.new( $<EXPR>.ast, $<pblock>.ast, :pasttype('if'), :node($/) );
}
method pblock($/) {
my $block := $<blockoid>.ast;
my $signature;
if pir::defined__IP($block<placeholder_sig>) && $<signature> {
$/.CURSOR.panic('Placeholder variable cannot override existing signature');
}
elsif pir::defined__IP($block<placeholder_sig>) {
$signature := $block<placeholder_sig>;
}
elsif $<signature> {
$signature := $<signature>.ast;
$block.blocktype('declaration');
}
else {
$signature := Perl6::Compiler::Signature.new();
unless $block.symbol('$_') {
if $*IMPLICIT {
my $parameter := Perl6::Compiler::Parameter.new();
$parameter.var_name('$_');
$parameter.optional(1);
$parameter.is_parcel(1);
$parameter.default_from_outer(1);
$signature.add_parameter($parameter);
}
else {
add_implicit_var($block, '$_', 1);
}
}
}
if $<lambda> eq '<->' {
$signature.set_rw_by_default();
}
add_signature($block, $signature, 0);
if $<lambda> {
prevent_null_return($block);
}
make $block;
}
method block($/) {
make $<blockoid>.ast;
}
method blockoid($/) {
my $past := $<statementlist>.ast;
my $BLOCK := @BLOCK.shift;
$BLOCK.push($past);
$BLOCK.node($/);
make $BLOCK;
}
method newpad($/) {
our @BLOCK;
our @PACKAGE;
my $new_block := PAST::Block.new( PAST::Stmts.new(
PAST::Op.new(
:inline(" .local pmc true\n true = get_hll_global 'True'")
),
PAST::Var.new(
:name('__CANDIDATE_LIST__'), :scope('lexical'), :isdecl(1)
)
));
@BLOCK.unshift($new_block);
unless @PACKAGE[0].block {
@PACKAGE[0].block($new_block);
}
}
method outerlex($/) {
my $outer_ctx := %*COMPILING<%?OPTIONS><outer_ctx>;
if pir::defined__IP($outer_ctx) {
my $block := @BLOCK[0];
my %lexinfo := Perl6::Compiler.get_lexinfo($outer_ctx);
for %lexinfo { $block.symbol($_.key, :scope<lexical>); }
my @ns := pir::getattribute__PPs($outer_ctx, 'current_namespace').get_name;
@ns.shift;
$block.namespace(@ns);
}
}
method finishpad($/) {
# Generate the $_, $/, and $! lexicals if they aren't already
# declared. For routines and methods, they're simply created as
# undefs; for other blocks they initialize to their outer lexical.
my $BLOCK := @BLOCK[0];
my $outer := $*IN_DECL ne 'routine' && $*IN_DECL ne 'method';
for <$_ $/ $!> {
# 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($_) || ($_ eq '$_' && $*IMPLICIT) {
add_implicit_var($BLOCK, $_, $outer);
}
}
}
## Statement control
method statement_control:sym<if>($/) {
my $count := +$<xblock> - 1;
my $past := xblock_immediate( $<xblock>[$count].ast );
if $<else> {
$past.push( block_immediate( $<else>[0].ast ) );
}
# build if/then/elsif structure
while $count > 0 {
$count--;
my $else := $past;
$past := xblock_immediate( $<xblock>[$count].ast );
$past.push($else);
}
make $past;
}
method statement_control:sym<unless>($/) {
my $past := xblock_immediate( $<xblock>.ast );
$past.pasttype('unless');
make $past;
}
method statement_control:sym<while>($/) {
my $past := xblock_immediate( $<xblock>.ast );
$past.pasttype(~$<sym>);
make $past;
}
method statement_control:sym<repeat>($/) {
my $pasttype := 'repeat_' ~ ~$<wu>;
my $past;
if $<xblock> {
$past := xblock_immediate( $<xblock>.ast );
$past.pasttype($pasttype);
}
else {
$past := PAST::Op.new( $<EXPR>.ast, block_immediate( $<pblock>.ast ),
:pasttype($pasttype), :node($/) );
}
make $past;
}
method statement_control:sym<for>($/) {
my $past := xblock_immediate($<xblock>.ast);
$past.pasttype('for');
$past[0] := PAST::Op.new(:name('&eager'), $past[0]);
$past.arity($past[1].arity || 1);
make $past;
}
method statement_control:sym<loop>($/) {
my $block := $<block>.ast;
$block.blocktype('immediate');
my $cond := $<e2> ?? $<e2>[0].ast !! 1;
my $loop := PAST::Op.new( $cond, $block, :pasttype('while'), :node($/) );
if $<e3> {
$loop.push( $<e3>[0].ast );
}
if $<e1> {
$loop := PAST::Stmts.new( $<e1>[0].ast, $loop, :node($/) );
}
make $loop;
}
method statement_control:sym<need>($/) {
my $past := PAST::Stmts.new( :node($/) );
for $<module_name> {
need($_);
}
make $past;
}
sub need($module_name) {
# Build up adverbs hash if we have them. Note that we need a hash
# for now (the compile time call) and an AST that builds said hash
# for the runtime call once we've compiled the module.
my $name := $module_name<longname><name>.Str;
my %adverbs;
my $adverbs_ast := PAST::Op.new(
:name('&circumfix:<{ }>'), PAST::Op.new( :name('&infix:<,>') )
);
if $module_name<longname><colonpair> {
for $module_name<longname><colonpair> {
my $ast := $_.ast;
$adverbs_ast[0].push($ast);
%adverbs{$ast[1].value()} := $ast[2].value();
}
}
# Need to immediately load module and get lexicals stubbed in.
Perl6::Module::Loader.need($name, %adverbs);
# Also need code to do the actual loading emitting (though need
# won't repeat its work if already carried out; we mainly need
# this for pre-compilation to PIR to work).
my @ns := pir::split__PSS('::', 'Perl6::Module');
@BLOCK[0].loadinit.push(
PAST::Op.new( :pasttype('callmethod'), :name('need'),
PAST::Var.new( :name('Loader'), :namespace(@ns), :scope('package') ),
$name,
PAST::Op.new( :pirop('getattribute PPS'), $adverbs_ast, '$!storage' )
));
}
method statement_control:sym<import>($/) {
my $past := PAST::Stmts.new( :node($/) );
import($/);
make $past;
}
sub import($/) {
my $name := $<module_name><longname><name>.Str;
Perl6::Module::Loader.stub_lexical_imports($name, @BLOCK[0]);
my @ns := pir::split__PSS('::', 'Perl6::Module');
@BLOCK[0].push(
PAST::Op.new( :pasttype('callmethod'), :name('import'),
PAST::Var.new( :name('Loader'), :namespace(@ns), :scope('package') ),
$name
));
}
method statement_control:sym<use>($/) {
my $past := PAST::Stmts.new( :node($/) );
if $<module_name> {
if ~$<module_name> eq 'fatal' {
declare_variable($/, PAST::Stmts.new(), '$', '*', 'FATAL', 0);
$past := PAST::Op.new(
:name('&infix:<=>'),
:node($/),
PAST::Op.new(
:name('!find_contextual'),
:pasttype('call'),
:lvalue(0),
'$*FATAL',
),
PAST::Var.new(
:name('True'),
:namespace(['Bool']),
:scope('package'),
),
);
}
elsif ~$<module_name> eq 'MONKEY_TYPING' {
$*MONKEY_TYPING := 1;
}
else {
need($<module_name>);
import($/);
}
}
make $past;
}
method statement_control:sym<given>($/) {
my $past := $<xblock>.ast;
$past.push($past.shift); # swap [0] and [1] elements
$past.pasttype('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 $block := $xblock.shift;
# Add exception handler to the block so we fall out of the enclosing block
# after it's executed.
$block.blocktype('immediate');
when_handler_helper($block);
# Handle the smart-match. XXX Need to handle syntactic cases too.
my $match_past := PAST::Op.new( :pasttype('call'), :name('&infix:<~~>'),
PAST::Var.new( :name('$_'), :scope('lexical') ),
$sm_exp
);
# Use the smartmatch result as the condition for running the block.
make PAST::Op.new( :pasttype('if'), :node( $/ ),
$match_past, $block,
);
}
method statement_control:sym<default>($/) {
# We always execute this, so just need the block, however we also
# want to make sure we break after running it.
my $block := $<block>.ast;
$block.blocktype('immediate');
when_handler_helper($block);
make $block;
}
method statement_control:sym<CATCH>($/) {
my $block := $<block>.ast;
push_block_handler($/, @BLOCK[0], $block);
@BLOCK[0].handlers()[0].handle_types_except('CONTROL');
make PAST::Stmts.new(:node($/));
}
method statement_control:sym<CONTROL>($/) {
my $block := $<block>.ast;
push_block_handler($/, @BLOCK[0], $block);
@BLOCK[0].handlers()[0].handle_types('CONTROL');
make PAST::Stmts.new(:node($/));
}
method statement_prefix:sym<BEGIN>($/) {
# BEGIN is kinda tricky. We actually need to run the code in it with
# immediate effect, and then have the BEGIN block evaluate to what
# was produced at runtime. But if we're in a pre-compiled module, we
# need to run the lot. Thus we keep a "already computed BEGIN values"
# hash and don't re-run if the value is in that. Of course, we still
# don't handle looking at things in outer lexical scopes here.
our %BEGINDONE;
our $?RAKUDO_HLL;
my $past := $<blorst>.ast;
$past.hll($?RAKUDO_HLL);
my $compiled := PAST::Compiler.compile($past);
my $begin_id := $past.unique('BEGINDONE_');
%BEGINDONE{$begin_id} := $compiled();
@BLOCK[0].loadinit.push(PAST::Op.new(
:pasttype('call'), :name('!begin_unless_begun'),
$begin_id, $past
));
make PAST::Var.new( :scope('keyed'),
PAST::Var.new( :name('%BEGINDONE'), :namespace(pir::split('::', 'Perl6::Actions')), :scope('package') ),
PAST::Val.new( :value($begin_id) )
);
}
method statement_prefix:sym<CHECK>($/) { add_phaser($/, 'CHECK'); }
method statement_prefix:sym<INIT>($/) { add_phaser($/, 'INIT'); }
method statement_prefix:sym<END>($/) { add_phaser($/, 'END'); }
method statement_prefix:sym<do>($/) {
my $past := $<blorst>.ast;
$past.blocktype('immediate');
make $past;
}
method statement_prefix:sym<gather>($/) {
my $past := $<blorst>.ast;
$past.blocktype('declaration');
make PAST::Op.new( :pasttype('call'), :name('!GATHER'), $past );
}
method statement_prefix:sym<try>($/) {
my $block := $<blorst>.ast;
$block.blocktype('immediate');
my $past := PAST::Op.new( :pasttype('try'), $block );
# On failure, capture the exception object into $!.
$past.push(PAST::Op.new(
:inline( ' .get_results (%r)',
' $P0 = new ["Perl6Exception"]',
' setattribute $P0, "$!exception", %r',
' store_lex "$!", $P0' )
));
# Otherwise, put a failure into $!.
$past.push(PAST::Op.new( :pasttype('bind'),
PAST::Var.new( :name('$!'), :scope('lexical') ),
PAST::Op.new( :pasttype('call'), :name('!FAIL') )
));
make $past;
}
method blorst($/) {
my $block := $<block>
?? $<block>.ast
!! PAST::Block.new( $<statement>.ast, :node($/) );
$block.blocktype('declaration');
make $block;
}
sub add_phaser($/, $bank) {
@BLOCK[0].loadinit.push(
PAST::Op.new( :pasttype('call'), :name('!add_phaser'),
$bank, $<blorst>.ast, :node($/))
);
make PAST::Stmts.new(:node($/));
}
# Statement modifiers
method statement_mod_cond:sym<if>($/) { make $<cond>.ast; }
method statement_mod_cond:sym<unless>($/) { make $<cond>.ast; }
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<statement_prefix>($/) { make $<statement_prefix>.ast; }
method term:sym<lambda>($/) { make create_code_object($<pblock>.ast, 'Block', 0, ''); }
method name($/) { }
method module_name($/) {
my @name := Perl6::Grammar::parse_name(~$<longname>);
my $var := PAST::Var.new(
:name(@name.pop),
:namespace(@name),
:scope('package')
);
if $<arglist> {
my $past := $<arglist>[0].ast;
$past.pasttype('callmethod');
$past.name('postcircumfix:<[ ]>');
$past.unshift($var);
make $past;
}
else {
make $var;
}
}
method fatarrow($/) {
make make_pair($<key>.Str, $<val>.ast);
}
method colonpair($/) {
if $*key {
if $<var> {
make make_pair($*key, make_variable($/, ~$<var>));
}
elsif $*value ~~ Regex::Match {
make make_pair($*key, $*value.ast);
}
elsif $*value == 0 {
make make_pair($*key, PAST::Var.new( :name('False'), :namespace('Bool'), :scope('package') ));
}
else {
make make_pair($*key, PAST::Var.new( :name('True'), :namespace('Bool'), :scope('package') ));
}
}
else {
make $*value.ast;
}
}
sub make_pair($key, $value) {
my @name := Perl6::Grammar::parse_name('Pair');
$value.named('value');
PAST::Op.new(
:pasttype('callmethod'),
:returns('Pair'),
:name('new'),
PAST::Var.new( :name(@name.pop), :namespace(@name), :scope('package') ),
PAST::Val.new( :value($key), :named('key') ),
$value
)
}
method variable($/) {
my $past;
if $<index> {
$past := PAST::Op.new(
:name('!postcircumfix:<[ ]>'),
PAST::Var.new( :name('$/') ),
+$<index>
);
}
elsif $<postcircumfix> {
$past := $<postcircumfix>.ast;
$past.unshift( PAST::Var.new( :name('$/') ) );
}
else {
$past := make_variable($/, ~$/);
}
make $past;
}
sub make_variable($/, $name) {
my @name := Perl6::Grammar::parse_name($name);
my $past := PAST::Var.new( :name(@name.pop) );
if @name {
$past.namespace(@name);
$past.scope('package');
}
if $<twigil>[0] eq '*' {
$past := PAST::Op.new( $past.name(), :pasttype('call'), :name('!find_contextual'), :lvalue(0) );
}
elsif $<twigil>[0] eq '!' {
$past.scope('attribute');
$past.viviself( sigiltype( $<sigil> ) );
$past.unshift(PAST::Var.new( :name('self'), :scope('lexical') ));
}
elsif $<twigil>[0] eq '.' && $*IN_DECL ne 'variable' {
# Need to transform this to a method call.
$past := $<arglist> ?? $<arglist>[0].ast !! PAST::Op.new();
$past.pasttype('callmethod');
$past.name(~$<desigilname>);
$past.unshift(PAST::Var.new( :name('self'), :scope('lexical') ));
}
elsif $<twigil>[0] eq '^' || $<twigil>[0] eq ':' {
$past := add_placeholder_parameter($<sigil>.Str, $<desigilname>.Str, :named($<twigil>[0] eq ':'));
}
elsif ~$/ eq '@_' {
$past := add_placeholder_parameter('@', '_', :slurpy_pos(1));
}
elsif ~$/ eq '%_' {
$past := add_placeholder_parameter('%', '_', :slurpy_named(1));
}
else {
my $attr_alias := is_attr_alias($past.name);
if $attr_alias {
$past.name($attr_alias);
$past.scope('attribute');
$past.viviself( sigiltype( $<sigil> ) );
$past.unshift(PAST::Var.new( :name('self'), :scope('lexical') ));
}
elsif $<sigil> eq '&' && !@name {
$past := PAST::Op.new(:pirop('find_sub_not_null__Ps'), $past.name);
}
}
$past
}
method package_declarator:sym<package>($/) { make $<package_def>.ast; }
method package_declarator:sym<module>($/) { make $<package_def>.ast; }
method package_declarator:sym<class>($/) { make $<package_def>.ast; }
method package_declarator:sym<grammar>($/) { make $<package_def>.ast; }
method package_declarator:sym<role>($/) { make $<package_def>.ast; }
method package_declarator:sym<does>($/) {
our @PACKAGE;
@PACKAGE[0].traits.push(PAST::Op.new(
:pasttype('call'),
:name('&trait_mod:<does>'),
$<typename>.ast
));
make PAST::Stmts.new();
}
method package_def($/, $key?) {
our @PACKAGE;
# Is this the opening of a new package?
if $key eq 'open' {
# Create the right kind of package compiler.
my $pkg_compiler := %*PKGCOMPILER{$*PKGDECL};
if pir::isa__IPS($pkg_compiler, 'Undef') { $pkg_compiler := Perl6::Compiler::Package; }
my $package := $pkg_compiler.new();
# Set HOW and other details.
my $how := %*HOW{$*PKGDECL};
unless $how { $/.CURSOR.panic("No HOW declared for package declarator $*PKGDECL"); }
$package.how($how);
$*SCOPE := $*SCOPE || 'our';
$package.scope($*SCOPE);
if $<def_module_name> {
my $name := ~$<def_module_name>[0]<longname><name>;
if $name ne '::' {
$/.CURSOR.add_name($name);
$package.name($name);
}
if $<def_module_name>[0]<signature> {
$package.signature($<def_module_name>[0]<signature>[0].ast);
$package.signature_text(~$<def_module_name>[0]<signature>[0]);
}
if $<def_module_name>[0]<longname><colonpair> {
for $<def_module_name>[0]<longname><colonpair> {
$package.name_adverbs.push($_.ast);
}
}
}
# Add traits.
for $<trait> {
$package.traits.push($_.ast);
}
# Put on front of packages list. Note - nesting a package in a role is
# not supported (gets really tricky in the parametric case - needs more
# thought and consideration).
if +@PACKAGE && pir::isa__IPS(@PACKAGE[0], 'Role') {
$/.CURSOR.panic("Can not nest a package inside a role");
}
@PACKAGE.unshift($package);
}
else {
# We just need to finish up the current package.
my $package := @PACKAGE.shift;
if pir::substr__SSII($<block><blockoid><statementlist><statement>[0], 0, 3) eq '...' {
# Just a stub, so don't do any more work.
if $*SCOPE eq 'our' || $*SCOPE eq '' {
%Perl6::Grammar::STUBCOMPILINGPACKAGES{~$<def_module_name>[0]<longname>} := 1;
}
@BLOCK[0].symbol(~$<def_module_name>[0]<longname>, :stub(1));
make PAST::Stmts.new( );
}
else {
my $block;
if $<block> {
$block := $<block>.ast;
}
else {
$block := @BLOCK.shift;
$block.push($<statementlist>.ast);
$block.node($/);
}
make $package.finish($block);
}
}
}
method scope_declarator:sym<my>($/) { make $<scoped>.ast; }
method scope_declarator:sym<our>($/) { make $<scoped>.ast; }
method scope_declarator:sym<has>($/) { make $<scoped>.ast; }
method scope_declarator:sym<augment>($/) { make $<scoped>.ast; }
method declarator($/) {
if $<variable_declarator> { make $<variable_declarator>.ast }
elsif $<routine_declarator> { make $<routine_declarator>.ast }
elsif $<regex_declarator> { make $<regex_declarator>.ast }
elsif $<signature> {
my $list := PAST::Op.new( :pasttype('call'), :name('&infix:<,>') );
my $decls := $<signature>.ast.get_declarations;
for @($decls) {
$list.push(declare_variable($/, $_, $_<sigil>, $_<twigil>, $_<desigilname>, $_<traits>));
}
$list<signature_from_declarator> := $<signature>.ast;
make $list;
}
else {
$/.CURSOR.panic('Unknown declarator type');
}
}
method multi_declarator:sym<multi>($/) { make $<declarator> ?? $<declarator>.ast !! $<routine_def>.ast }
method multi_declarator:sym<proto>($/) { make $<declarator> ?? $<declarator>.ast !! $<routine_def>.ast }
method multi_declarator:sym<only>($/) { make $<declarator> ?? $<declarator>.ast !! $<routine_def>.ast }
method multi_declarator:sym<null>($/) { make $<declarator>.ast }
method scoped($/) {
make $<DECL>.ast;
}
method variable_declarator($/) {
my $past := $<variable>.ast;
my $sigil := $<variable><sigil>;
my $twigil := $<variable><twigil>[0];
my $name := ~$sigil ~ ~$twigil ~ ~$<variable><desigilname>;
if @BLOCK[0].symbol($name) {
$/.CURSOR.panic("Redeclaration of symbol ", $name);
}
make declare_variable($/, $past, ~$sigil, ~$twigil, ~$<variable><desigilname>, $<trait>);
}
sub declare_variable($/, $past, $sigil, $twigil, $desigilname, $trait_list) {
my $name := $sigil ~ $twigil ~ $desigilname;
my $BLOCK := @BLOCK[0];
if $*SCOPE eq 'has' {
# Find the current package and add the attribute.
my $attrname := ~$sigil ~ '!' ~ $desigilname;
our @PACKAGE;
unless +@PACKAGE {
$/.CURSOR.panic("Can not declare an attribute outside of a package");
}
if @PACKAGE[0].has_attribute($attrname) {
$/.CURSOR.panic("Can not re-declare attribute " ~ $attrname);
}
my %attr_info;
%attr_info<name> := $attrname;
%attr_info<accessor> := $twigil eq '.' ?? 1 !! 0;
%attr_info<rw> := $trait_list && has_compiler_trait_with_val($trait_list, '&trait_mod:<is>', 'rw') ?? 1 !! 0;
@PACKAGE[0].attributes.push(%attr_info);
# If no twigil, note $foo is an alias to $!foo.
if $twigil eq '' {
$BLOCK.symbol($name, :attr_alias($attrname));
}
# Nothing to emit here; just hand back an empty node, but also
# annotate it with the attribute table.
$past := PAST::Stmts.new( );
$past<attribute_data> := %attr_info;
}
else {
# Not an attribute - need to emit delcaration here.
# First, create a container and give it a 'rw' property
# Create the container, give it a 'rw' property
my $cont := $sigil eq '%' ??
PAST::Op.new( :name('&CREATE_HASH_LOW_LEVEL'), :pasttype('call') ) !!
PAST::Op.new( sigiltype($sigil), :pirop('new Ps') );
my $true := PAST::Var.new( :name('true'), :scope('register') );
my $vivipast := PAST::Op.new( $cont, 'rw', $true, :pirop('setprop'));
# If it's a scalar, mark it as scalar (non-flattening)
if $sigil eq '$' || $sigil eq '&' {
$vivipast := PAST::Op.new($vivipast,'scalar',$true,:pirop('setprop'));
}
# For 'our' variables, we first bind or lookup in the namespace
if $*SCOPE eq 'our' {
$vivipast := PAST::Var.new( :name($name), :scope('package'), :isdecl(1),
:lvalue(1), :viviself($vivipast), :node($/) );
}
# Now bind a lexical in the block
my $decl := PAST::Var.new( :name($name), :scope('lexical'), :isdecl(1),
:lvalue(1), :viviself($vivipast), :node($/) );
$BLOCK.symbol($name, :scope('lexical'), :decl_node($decl) );
$BLOCK[0].push($decl);
# If we have traits, set up us the node to emit handlers into, then
# emit them.
my $init_type := 0;
if $trait_list || $*TYPENAME {
my $trait_node := get_var_traits_node($BLOCK, $name);
for $trait_list {
my $trait := $_.ast;
$trait.unshift(PAST::Var.new( :name('declarand'), :scope('register') ));
if $trait.name() eq '&trait_mod:<of>' && $*TYPENAME {
$init_type := $trait[1] := PAST::Op.new(
:pasttype('callmethod'), :name('postcircumfix:<[ ]>'),
$*TYPENAME, $trait[1]
);
$*TYPENAME := '';
}
$trait_node.push($trait);
}
if $*TYPENAME {
$trait_node.push(PAST::Op.new(
:pasttype('call'), :name('&trait_mod:<of>'),
PAST::Var.new( :name('declarand'), :scope('register') ),
$*TYPENAME
));
$init_type := $*TYPENAME;
}
}
# For arrays, need to transform_to_p6opaque. XXX Find a neater way
# to do this.
if $sigil eq '@' {
get_var_traits_node($BLOCK, $name).push(PAST::Op.new(
:pirop('transform_to_p6opaque vP'),
PAST::Var.new( :name('$P0'), :scope('register') )
));
}
# If we've a type to init with and it's a scalar, do so.
if $init_type && $sigil eq '$' {
$cont.pirop('new PsP');
$cont.push($init_type);
}
}
return $past;
}
method routine_declarator:sym<sub>($/) { make $<routine_def>.ast; }
method routine_declarator:sym<method>($/) { make $<method_def>.ast; }
method routine_declarator:sym<submethod>($/) { make $<method_def>.ast; }
method routine_def($/) {
my $past := $<blockoid>.ast;
$past.blocktype('declaration');
$past.control('return_pir');
if pir::defined__IP($past<placeholder_sig>) && $<multisig> {
$/.CURSOR.panic('Placeholder variable cannot override existing signature');
}
my $signature := $<multisig> ?? $<multisig>[0].ast !!
pir::defined__IP($past<placeholder_sig>) ?? $past<placeholder_sig> !!
Perl6::Compiler::Signature.new();
$signature.set_default_parameter_type('Any');
my $sig_setup_block := add_signature($past, $signature, 1);
if $<trait> {
emit_routine_traits($past, $<trait>, 'Sub', $sig_setup_block);
}
if $<deflongname> {
# Set name.
my $name := '&' ~ ~$<deflongname>[0].ast;
$past.name(~$<deflongname>[0].ast);
$past.nsentry('');
# Wrap it in the correct routine type.
my $multi_flag := PAST::Val.new( :value(0) );
$past := create_code_object($past, 'Sub', $multi_flag, $sig_setup_block);
# Handle multi-ness, if any.
my $symbol_holder := $*SCOPE eq 'our' ?? @PACKAGE[0].block !! @BLOCK[0];
my $symbol := $symbol_holder.symbol($name);
if $*MULTINESS eq 'only' {
if $symbol {
$/.CURSOR.panic('Can not declare only routine ' ~ $name ~
' when another routine with this name was already declared');
}
}
elsif $*MULTINESS || ($symbol && $symbol<multis>) {
# If no multi declarator and no proto, error.
if !$*MULTINESS && !$symbol<proto> {
$/.CURSOR.panic('Can not re-declare sub ' ~ $name ~ ' without declaring it multi');
}
# If it's a proto, stash it away in the symbol entry.
if $*MULTINESS eq 'proto' { $symbol_holder.symbol($name, :proto($past)) }
# Otherwise, create multi container if we don't have one; otherwise,
# just push this candidate onto it.
if $symbol<multis> {
$symbol<multis>.push($past);
$past := 0;
}
else {
$past := PAST::Op.new(
:pasttype('callmethod'),
:name('set_candidates'),
PAST::Op.new( :inline(' %r = new ["Perl6MultiSub"]') ),
$past
);
$symbol_holder.symbol($name, :multis($past));
$past := PAST::Op.new(
:pasttype('callmethod'), :name('incorporate_candidates'),
$past, PAST::Op.new( :pirop('find_lex_skip_current PS'), $name )
);
}
$multi_flag.value($*MULTINESS eq 'proto' ?? 2 !! 1);
}
# Install in lexical scope if it's not package scoped.
if $*SCOPE ne 'our' {
if $past {
@BLOCK[0][0].push(PAST::Var.new( :name($name), :isdecl(1),
:viviself($past), :scope('lexical') ) );
@BLOCK[0].symbol($name, :scope('lexical') );
}
}
# Otherwise, package scoped; add something to loadinit to install them.
else {
if $past {
if $symbol_holder.symbol($name)<multis> {
$past[0] := PAST::Var.new( :name($name), :scope('package'), :viviself($past[0]) );
}
@PACKAGE[0].block.loadinit.push(PAST::Op.new(
:pasttype('bind'),
PAST::Var.new( :name($name), :scope('package') ),
$past
));
}
@BLOCK[0].symbol($name, :scope('package') );
}
$past := PAST::Var.new( :name($name) );
}
elsif $*MULTINESS {
$/.CURSOR.panic('Can not put ' ~ $*MULTINESS ~ ' on anonymous routine');
}
else {
# Just wrap in a Sub.
$past := create_code_object($past, 'Sub', 0, $sig_setup_block);
}
make $past;
}
method method_def($/) {
my $past := $<blockoid>.ast;
$past.blocktype('declaration');
$past.control('return_pir');
# Get signature - or create - and sort out invocant handling.
if pir::defined__IP($past<placeholder_sig>) {
$/.CURSOR.panic('Placeholder variables cannot be used in a method');
}
my $sig := $<multisig> ?? $<multisig>[0].ast !! Perl6::Compiler::Signature.new();
$sig.add_invocant();
$sig.set_default_parameter_type('Any');
# Add *%_ parameter if there's no other named slurpy and the package isn't hidden.
my $need_slurpy_hash := !$sig.has_named_slurpy();
if $need_slurpy_hash { # XXX ADD BACK: && !package_has_trait('hidden') {
my $param := Perl6::Compiler::Parameter.new();
$param.var_name('%_');
$param.named_slurpy(1);
$sig.add_parameter($param);
}
# Add signature to block.
my $sig_setup_block := add_signature($past, $sig, 1);
$past[0].unshift(PAST::Var.new( :name('self'), :scope('lexical'), :isdecl(1), :viviself(sigiltype('$')) ));
$past.symbol('self', :scope('lexical'));
# Emit traits.
if $<trait> {
emit_routine_traits($past, $<trait>, $*METHODTYPE, $sig_setup_block);
}
# Method container.
if $<longname> {
# Set up us the name.
my $name := $<longname>.Str;
if $<specials> eq '!' { $name := '!' ~ $name; }
$past.name($name);
$past.nsentry('');
my $multi_flag := $*MULTINESS eq 'proto' ?? 2 !!
$*MULTINESS eq 'multi' ?? 1 !!
0;
# Create code object using a reference to $past.
my $code := create_code_object(PAST::Val.new(:value($past)), $*METHODTYPE, $multi_flag, $sig_setup_block);
# Get hold of the correct table to install it in, and install.
our @PACKAGE;
unless +@PACKAGE { $/.CURSOR.panic("Can not declare method outside of a package"); }
my %table;
if $<specials> eq '^' {
%table := @PACKAGE[0].meta_methods();
}
else {
%table := @PACKAGE[0].methods();
}
install_method($/, $code, $name, %table);
}
elsif $*MULTINESS {
$/.CURSOR.panic('Can not put ' ~ $*MULTINESS ~ ' on anonymous routine');
}
else {
$past := create_code_object($past, $*METHODTYPE, 0, $sig_setup_block);
}
make $past;
}
sub install_method($/, $code, $name, %table) {
my $installed;
# Create method table entry if we need one.
unless %table{$name} { my %tmp; %table{$name} := %tmp; }
# If it's an only and there's already a symbol, problem.
if $*MULTINESS eq 'only' && %table{$name} {
$/.CURSOR.panic('Can not declare only method ' ~ $name ~
' when another method with this name was already declared');
}
elsif $*MULTINESS || %table{$name}<multis> {
# If no multi declarator and no proto, error.
if !$*MULTINESS && !%table{$name}<proto> {
$/.CURSOR.panic('Can not re-declare method ' ~ $name ~ ' without declaring it multi');
}
# If it's a proto, stash it away in the symbol entry.
if $*MULTINESS eq 'proto' { %table{$name}<proto> := $code; }
# Create multi container if we don't have one; otherwise, just push
# this candidate onto it.
if %table{$name}<multis> {
%table{$name}<multis>.push($code);
}
else {
$code := PAST::Op.new(
:pasttype('callmethod'),
:name('set_candidates'),
PAST::Op.new( :inline(' %r = new ["Perl6MultiSub"]') ),
$code
);
%table{$name}<code_ref> := %table{$name}<multis> := $installed := $code;
}
}
else {
%table{$name}<code_ref> := $installed := $code;
}
# If we did install something (we maybe didn't need to if this is a multi),
# we may need to also pop it in other places.
if $installed {
if $*SCOPE eq 'my' {
@BLOCK[0][0].push(PAST::Var.new( :name('&' ~ $name), :isdecl(1),
:viviself($installed), :scope('lexical') ));
@BLOCK[0].symbol($name, :scope('lexical') );
}
elsif $*SCOPE eq 'our' {
@PACKAGE[0].block.loadinit.push(PAST::Op.new(
:pasttype('bind'),
PAST::Var.new( :name('&' ~ $name), :scope('package') ),
$installed
));
}
}
}
our %REGEX_MODIFIERS;
method regex_declarator:sym<regex>($/, $key?) {
if ($key) {
my %h;
%REGEX_MODIFIERS := %h;
} else {
make $<regex_def>.ast;
}
}
method regex_declarator:sym<token>($/, $key?) {
if ($key) {
my %h;
%h<r> := 1;
%REGEX_MODIFIERS := %h;
} else {
make $<regex_def>.ast;
}
}
method regex_declarator:sym<rule>($/, $key?) {
if ($key) {
my %h;
%h<r> := 1; %h<s> :=1;
%REGEX_MODIFIERS := %h;
} else {
make $<regex_def>.ast;
}
}
method regex_def($/, $key?) {
my $name := ~$<deflongname>[0];
my @MODIFIERS := Q:PIR {
%r = get_hll_global ['Regex';'P6Regex';'Actions'], '@MODIFIERS'
};
my $past;
if $key eq 'open' {
@MODIFIERS.unshift(%REGEX_MODIFIERS);
# The following is so that <sym> can work
Q:PIR {
$P0 = find_lex '$name'
set_hll_global ['Regex';'P6Regex';'Actions'], '$REGEXNAME', $P0
};
return 0;
} elsif $*MULTINESS eq 'proto' {
# Need to build code for setting up a proto-regex.
@MODIFIERS.shift;
@BLOCK.shift;
unless ($name) {
$/.CURSOR.panic('proto ' ~ ~$<sym> ~ 's cannot be anonymous');
}
our @PACKAGE;
unless +@PACKAGE {
$/.CURSOR.panic("Can not declare named " ~ ~$<sym> ~ " outside of a package");
}
my %table;
%table := @PACKAGE[0].methods();
unless %table{$name} { my %tmp; %table{$name} := %tmp; }
if %table{$name} {
$/.CURSOR.panic('Cannot declare proto ' ~ ~$<sym> ~ ' ' ~ $name ~
' when another with this name was already declared');
}
%table{$name}<code_ref> :=
create_code_object(
PAST::Block.new( :name($name),
PAST::Op.new(
PAST::Var.new( :name('self'), :scope('register') ),
$name,
:name('!protoregex'),
:pasttype('callmethod')
),
:lexical(0),
:blocktype('method'),
:pirflags(':anon'),
:node($/)
),
'Regex', 0, '');
%table{'!PREFIX__' ~ $name}<code_ref> :=
create_code_object(
PAST::Block.new( :name('!PREFIX__' ~ $name),
PAST::Op.new(
PAST::Var.new( :name('self'), :scope('register') ),
$name,
:name('!PREFIX__!protoregex'),
:pasttype('callmethod')
),
:blocktype('method'),
:pirflags(':anon'),
:lexical(0),
:node($/)
),
'Regex', 0, '');
} else {
# Clear modifiers stack entry for this regex.
@MODIFIERS.shift;
# Create the regex sub along with its signature.
$past := Regex::P6Regex::Actions::buildsub($<p6regex>.ast, @BLOCK.shift);
$past.unshift(PAST::Op.new(
:pasttype('inline'),
:inline(" .local pmc self\n self = find_lex 'self'")
));
my $sig := $<signature> ?? $<signature>[0].ast !! Perl6::Compiler::Signature.new();
$sig.add_invocant();
$sig.set_default_parameter_type('Any');
$past[0].unshift(PAST::Var.new( :name('self'), :scope('lexical'), :isdecl(1), :viviself(sigiltype('$')) ));
$past.symbol('self', :scope('lexical'));
my $sig_setup_block := add_signature($past, $sig, 1);
$past.name($name);
$past.blocktype("declaration");
# If the methods are not :anon they'll conflict at class composition time.
$past.pirflags(':anon');
# Create code object and install it provided it has a name.
if ($name) {
my $code := create_code_object(PAST::Val.new(:value($past)), 'Regex', 0, $sig_setup_block);
our @PACKAGE;
unless +@PACKAGE {
$/.CURSOR.panic("Can not declare named " ~ ~$<sym> ~ " outside of a package");
}
my %table;
%table := @PACKAGE[0].methods();
install_method($/, $code, $name, %table);
}
else {
$past := create_code_object($past, 'Regex', 0, $sig_setup_block);
}
}
make $past;
}
method type_declarator:sym<enum>($/) {
my $values := $<circumfix>.ast;
make PAST::Op.new(
:pasttype('call'),
:name('!create_anon_enum'),
$values
);
}
method type_declarator:sym<subset>($/) {
# Figure out our refinee.
my $of_trait := has_compiler_trait($<trait>, '&trait_mod:<of>');
my $refinee := $of_trait ??
$of_trait[0] !!
PAST::Var.new( :name('Any'), :namespace(Nil), :scope('package') );
# Construct subset and install it in the right place.
my $cons_past := PAST::Op.new(
:name('&CREATE_SUBSET_TYPE'),
$refinee,
$<EXPR> ?? where_blockify($<EXPR>[0].ast) !!
PAST::Var.new( :name('True'), :namespace('Bool'), :scope('package') )
);
# Stick it somewhere appropriate.
if $<longname> {
my $name := $<longname>[0].Str;
if $*SCOPE eq '' || $*SCOPE eq 'our' {
# Goes in the package.
@PACKAGE[0].block.loadinit.push(PAST::Op.new(
:pasttype('bind'),
PAST::Var.new( :name($name), :scope('package') ),
$cons_past
));
@BLOCK[0].symbol($name, :scope('package') );
}
elsif $*SCOPE eq 'my' {
# Install in the lexpad.
@BLOCK[0][0].push(PAST::Var.new(
:name($name), :isdecl(1),
:viviself($cons_past), :scope('lexical')
));
@BLOCK[0].symbol($name, :scope('lexical') );
}
else {
$/.CURSOR.panic("Can not declare a subset with scope declarator " ~ $*SCOPE);
}
make PAST::Var.new( :name($name) );
}
else {
if $*SCOPE ne '' && $*SCOPE ne 'anon' {
$/.CURSOR.panic('A ' ~ $*SCOPE ~ ' scoped subset must have a name.');
}
make $cons_past;
}
}
method capterm($/) {
# Construct a Parcel, and then call .Capture to coerce it to a capture.
my $past := $<termish> ?? $<termish>.ast !!
$<capture> ?? $<capture>[0].ast !!
PAST::Op.new( :name('&infix:<,>') );
unless $past.isa(PAST::Op) && $past.name() eq '&infix:<,>' {
$past := PAST::Op.new( :name('&infix:<,>'), $past );
}
make PAST::Op.new( :pasttype('callmethod'), :name('Capture'), $past);
}
method capture($/) {
make $<EXPR>.ast;
}
method multisig($/) {
make $<signature>.ast;
}
method signature($/) {
my $signature := Perl6::Compiler::Signature.new();
my $cur_param := 0;
my $is_multi_invocant := 1;
for $<parameter> {
my $param := $_.ast;
$param.multi_invocant($is_multi_invocant);
if ~@*seps[$cur_param] eq ':' {
if $cur_param == 0 {
$param.invocant(1);
}
else {
$/.CURSOR.panic("Can not put ':' parameter seperator after first parameter");
}
}
if @*seps[$cur_param] eq ';;' {
$is_multi_invocant := 0;
}
$signature.add_parameter($param);
$cur_param := $cur_param + 1;
}
make $signature;
}
method parameter($/) {
my $quant := $<quant>;
# Sanity checks.
if $<default_value> {
if $quant eq '*' {
$/.CURSOR.panic("Can't put default on slurpy parameter");
}
if $quant eq '!' {
$/.CURSOR.panic("Can't put default on required parameter");
}
}
# Set various flags on the parameter.
$*PARAMETER.pos_slurpy( $quant eq '*' && $*PARAMETER.sigil eq '@' );
$*PARAMETER.named_slurpy( $quant eq '*' && $*PARAMETER.sigil eq '%' );
$*PARAMETER.optional( $quant eq '?' || $<default_value> || ($<named_param> && $quant ne '!') );
$*PARAMETER.is_parcel( $quant eq '\\' );
$*PARAMETER.is_capture( $quant eq '|' );
if $<default_value> {
$*PARAMETER.default( PAST::Block.new( $<default_value>[0]<EXPR>.ast ) );
}
# Handle traits.
$*PARAMETER.traits($<trait>);
if $<trait> {
# Handle built-in ones.
my $read_type := trait_readtype($<trait>);
if $read_type eq 'CONFLICT' {
$/.CURSOR.panic('Can not apply more than one of: is copy, is rw, is readonly');
}
$*PARAMETER.is_rw( $read_type eq 'rw' );
$*PARAMETER.is_copy( $read_type eq 'copy' );
my $coerce := has_compiler_trait($<trait>, '&trait_mod:<as>');
if $coerce {
$*PARAMETER.coerce_to(PAST::Op.new( :pasttype('callmethod'), :name('perl'), $coerce[0]));
}
}
make $*PARAMETER;
}
method param_var($/) {
if $<signature> {
if pir::defined__IP($*PARAMETER.sub_signature) {
$/.CURSOR.panic('Can not have more than one sub-signature for a parameter');
}
$*PARAMETER.sub_signature( $<signature>.ast );
if pir::substr(~$/, 0, 1) eq '[' {
$*PARAMETER.var_name('@');
}
}
else {
my $twigil := $<twigil> ?? ~$<twigil>[0] !! '';
$*PARAMETER.var_name(~$/);
if $twigil eq '' {
if $<name> {
if @BLOCK[0].symbol(~$/) {
$/.CURSOR.panic("Redeclaration of symbol ", ~$/);
}
@BLOCK[0].symbol(~$/, :scope($*SCOPE eq 'my' ?? 'lexical' !! 'package'));
}
}
elsif $twigil ne '!' && $twigil ne '.' && $twigil ne '*' {
$/.CURSOR.panic("Illegal to use $twigil twigil in signature");
}
}
}
method named_param($/) {
if $<name> { $*PARAMETER.names.push(~$<name>); }
elsif $<param_var><name> { $*PARAMETER.names.push(~$<param_var><name>[0]); }
}
method type_constraint($/) {
if $<typename> {
if pir::substr(~$<typename>, 0, 2) eq '::' {
my $desigilname := pir::substr(~$<typename>, 2);
$*PARAMETER.type_captures.push($desigilname);
my @BlOCK;
@BLOCK[0].symbol($desigilname, :scope('lexical'));
}
else {
if $*PARAMETER.nom_type {
$/.CURSOR.panic('Parameter may only have one prefix type constraint');
}
$*PARAMETER.nom_type($<typename>.ast);
}
}
elsif $<value> {
if $*PARAMETER.nom_type {
$/.CURSOR.panic('Parameter may only have one prefix type constraint');
}
$*PARAMETER.nom_type(PAST::Op.new(
:pirop('deobjectref__PP'),
PAST::Op.new( :pasttype('callmethod'), :name('WHAT'), $<value>.ast )
));
$*PARAMETER.cons_types.push($<value>.ast);
}
else {
$/.CURSOR.panic('Can not do non-typename cases of type_constraint yet');
}
}
method post_constraint($/) {
if $<signature> {
if pir::defined__IP($*PARAMETER.sub_signature) {
$/.CURSOR.panic('Can not have more than one sub-signature for a parameter');
}
$*PARAMETER.sub_signature( $<signature>.ast );
}
else {
$*PARAMETER.cons_types.push(where_blockify($<EXPR>.ast));
}
}
method trait($/) {
my $past;
if $<trait_mod> {
$past := $<trait_mod>.ast;
}
elsif $<colonpair> {
$/.CURSOR.panic('traits specified as colon pairs not yet understood');
}
make $past;
}
method trait_mod:sym<is>($/) {
my $trait := PAST::Op.new( :pasttype('call'), :name('&trait_mod:<is>') );
if $<circumfix> { $trait.push($<circumfix>[0].ast); }
if $/.CURSOR.is_name(~$<longname>) {
# It's a type - look it up and send it in as a positional, before
# the parameter.
my @name := Perl6::Grammar::parse_name(~$<longname>);
$trait.unshift(PAST::Var.new(
:scope('package'),
:name(@name.pop()),
:namespace(@name)
));
}
else {
# Not a type name, so construct a named parameter with this name; it
# is a named param so it has to go on the end.
$trait.push(PAST::Var.new(
:name('True'),
:namespace('Bool'),
:scope('package'),
:named(~$<longname>)
));
}
$trait<is_name> := ~$<longname>;
make $trait;
}
method trait_mod:sym<hides>($/) {
make PAST::Op.new(
:pasttype('call'),
:name('&trait_mod:<hides>'),
$<module_name>.ast
);
}
method trait_mod:sym<does>($/) {
make PAST::Op.new(
:pasttype('call'),
:name('&trait_mod:<does>'),
$<module_name>.ast
);
}
method trait_mod:sym<will>($/) {
my $trait := PAST::Op.new(
:pasttype('call'),
:name('&trait_mod:will'),
$<pblock>.ast
);
if $/.CURSOR.is_name(~$<identifier>) {
# It's a type - look it up and send it in as a positional, before
# the parameter.
$trait.unshift(PAST::Var.new(
:scope('package'),
:name(~$<identifier>)
));
}
else {
# Not a type name, so construct a named parameter with this name; it
# is a named param so it has to go on the end.
$trait.push(PAST::Val.new(
:value(PAST::Var.new( :name('True'), :namespace('Bool'), :scope('package') )),
:named(~$<identifier>)
));
}
make $trait;
}
method trait_mod:sym<of>($/) {
make PAST::Op.new(
:pasttype('call'),
:name('&trait_mod:<of>'),
$<typename>.ast
);
}
method trait_mod:sym<as>($/) {
make PAST::Op.new(
:pasttype('call'),
:name('&trait_mod:<as>'),
$<typename>.ast
);
}
method trait_mod:sym<returns>($/) {
make PAST::Op.new(
:pasttype('call'),
:name('&trait_mod:<returns>'),
$<typename>.ast
);
}
method trait_mod:sym<handles>($/) {
make PAST::Op.new(
:pasttype('call'),
:name('&trait_mod:<handles>'),
$<term>.ast
);
}
method postop($/) {
make $<postfix> ?? $<postfix>.ast !! $<postcircumfix>.ast;
}
method dotty:sym<.>($/) { make $<dottyop>.ast; }
method dotty:sym<.*>($/) {
my $past := $<dottyop>.ast;
unless $past.isa(PAST::Op) && $past.pasttype() eq 'callmethod' {
$/.CURSOR.panic("Can not use " ~ $<sym>.Str ~ " on a non-identifier method call");
}
$past.unshift($past.name);
$past.name('!dispatch_' ~ $<sym>.Str);
$past.pasttype('call');
make $past;
}
method dottyop($/) {
if $<methodop> {
make $<methodop>.ast;
} else {
make $<postop>.ast;
}
}
method privop($/) {
my $past := $<methodop>.ast;
if $<methodop><quote> {
$past.name(PAST::Op.new( :pasttype('call'), :name('&infix:<~>'), '!', $past.name ));
}
else {
$past.name( '!' ~ $past.name );
}
make $past;
}
method methodop($/) {
my $past := $<args> ?? $<args>[0].ast !! PAST::Op.new( :node($/) );
$past.pasttype('callmethod');
if $<longname> {
# May just be .foo, but could also be .Foo::bar
my @parts := Perl6::Grammar::parse_name(~$<longname>);
my $name := @parts.pop;
if +@parts {
$past.unshift(PAST::Var.new(
:name(@parts.pop),
:namespace(@parts),
:scope('package')
));
$past.unshift($name);
$past.name('!dispatch_::');
$past.pasttype('call');
}
else {
$past.name( $name );
}
}
elsif $<quote> {
$past.name( $<quote>.ast );
}
elsif $<variable> {
$past.unshift($<variable>.ast);
$past.name('!dispatch_variable');
$past.pasttype('call');
}
make $past;
}
method term:sym<self>($/) {
make PAST::Var.new( :name('self'), :node($/) );
}
method term:sym<Nil>($/) {
make PAST::Op.new(:name('&Nil'), :node($/) );
}
method term:sym<rand>($/) {
make PAST::Op.new(:name('&rand'), :node($/) );
}
method term:sym<...>($/) {
make PAST::Op.new( :pasttype('call'), :name('&fail'), 'Stub code executed', :node($/) );
}
method term:sym<???>($/) {
make PAST::Op.new( :pasttype('call'), :name('&warn'), 'Stub code executed', :node($/) );
}
method term:sym<!!!>($/) {
make PAST::Op.new( :pasttype('call'), :name('&die'), 'Stub code executed', :node($/) );
}
method term:sym<dotty>($/) {
my $past := $<dotty>.ast;
$past.unshift(PAST::Op.new(
:pirop('descalarref PP'),
PAST::Var.new( :name('$_'), :scope('lexical') )
));
make $past;
}
method term:sym<identifier>($/) {
my $past := capture_or_parcel($<args>.ast, ~$<identifier>);
$past.name('&' ~ $<identifier>);
make $past;
}
method term:sym<name>($/) {
my $ns := Perl6::Grammar::parse_name(~$<longname>);
$ns := pir::clone__PP($ns);
my $name := $ns.pop;
my $var;
if is_lexical(~$<longname>) {
$var := PAST::Var.new( :name(~$<longname>), :scope('lexical') );
}
else {
$var := PAST::Var.new(
:name(~$name), :namespace($ns), :scope('package'),
:viviself(PAST::Op.new(
:pasttype('call'), :name('!FAIL'),
"Can not find sub " ~ ~$<longname>
))
);
}
my $past := $var;
if $<args> {
$past := capture_or_parcel($<args>.ast, ~$<longname>);
if $ns {
$past.unshift($var);
unless pir::substr($var.name, 0, 1) eq '&' {
$var.name('&' ~ $var.name);
}
}
else { $past.name('&' ~ $name); }
}
make $past;
}
method term:sym<pir::op>($/) {
my $past := $<args> ?? $<args>[0].ast !! PAST::Op.new( :node($/) );
my $pirop := ~$<op>;
$pirop := Q:PIR {
$P0 = find_lex '$pirop'
$S0 = $P0
$P0 = split '__', $S0
$S0 = join ' ', $P0
%r = box $S0
};
$past.pirop($pirop);
$past.pasttype('pirop');
make $past;
}
method term:sym<*>($/) {
my @name := Perl6::Grammar::parse_name('Whatever');
make PAST::Op.new(
:pasttype('callmethod'), :name('new'), :node($/), :lvalue(1),
PAST::Var.new( :name(@name.pop), :namespace(@name), :scope('package') )
)
}
method term:sym<capterm>($/) {
make $<capterm>.ast;
}
method args($/) {
my $past;
if $<semiarglist> { $past := $<semiarglist>.ast; }
elsif $<arglist> { $past := $<arglist>.ast; }
else {
$past := PAST::Op.new( :pasttype('call'), :node($/) );
}
make $past;
}
method semiarglist($/) { make $<arglist>.ast; }
method arglist($/) {
# Build up argument list, hanlding nameds as we go.
my $past := PAST::Op.new( );
if $<EXPR> {
my $expr := $<EXPR>.ast;
if $expr.name eq '&infix:<,>' {
for $expr.list { $past.push(handle_named_parameter($_)); }
}
else { $past.push(handle_named_parameter($expr)); }
}
# See if we have any uses of prefix:<|>; if we have, then we take it and
# evaluate it once. We then stick it in a register, and pull out an RPA
# and a Hash that Parrot knows what to do with.
my $result := PAST::Op.new( :pasttype('call'), :node($/) );
for @($past) {
if $_.isa(PAST::Op) && $_.name() eq '&prefix:<|>' {
my $reg_name := $past.unique('flatten_tmp_');
my $steps := PAST::Stmts.new(
PAST::Op.new( :pasttype('bind'),
PAST::Var.new( :name($reg_name), :scope('register'), :isdecl(1) ),
$_
),
PAST::Op.new(
:pasttype('callmethod'), :name('!PARROT_POSITIONALS'),
PAST::Var.new( :name($reg_name), :scope('register') )
)
);
$steps.flat(1);
$result.push($steps);
$result.push(PAST::Op.new(
:flat(1), :named(1),
:pasttype('callmethod'), :name('!PARROT_NAMEDS'),
PAST::Var.new( :name($reg_name), :scope('register') )
));
}
else {
$result.push($_);
}
}
make $result;
}
sub handle_named_parameter($arg) {
if $arg ~~ PAST::Node && $arg.returns() eq 'Pair' {
my $result := $arg[2];
$result.named(~$arg[1].value());
$result<before_promotion> := $arg;
$result;
}
else {
$arg;
}
}
method term:sym<value>($/) { make $<value>.ast; }
method circumfix:sym<( )>($/) { make $<semilist>.ast; }
method circumfix:sym<ang>($/) { make $<quote_EXPR>.ast; }
method circumfix:sym<« »>($/) { make $<quote_EXPR>.ast; }
method circumfix:sym<{ }>($/) {
# If it is completely empty or consists of a single list, the first
# element of which is either a hash or a pair, it's a hash constructor.
my $past := $<pblock>.ast;
my $is_hash := 0;
if +@($past) == 2 {
if +@($past[1]) == 0 {
# Empty block, so a hash.
$is_hash := 1;
}
elsif +@($past[1]) == 1 && $past[1][0].isa(PAST::Op) {
if $past[1][0].returns() eq 'Pair' || $past[1][0].name() eq '&infix:<=>>' {
# Block with just one pair in it, so a hash.
$is_hash := 1;
}
elsif $past[1][0].name() eq '&infix:<,>' {
# List, but first elements must be...
if $past[1][0][0].isa(PAST::Op) &&
($past[1][0][0].returns() eq 'Pair' || $past[1][0][0].name() eq '&infix:<=>>') {
# ...a Pair
$is_hash := 1;
}
elsif $past[1][0][0].isa(PAST::Var) &&
pir::substr__SSII($past[1][0][0].name(), 0, 1) eq '%' {
# ...or a hash.
$is_hash := 1
}
}
}
elsif +@($past[1]) == 1 && $past[1][0].isa(PAST::Var) {
if pir::substr__SSII($past[1][0].name(), 0, 1) eq '%' {
$is_hash := 1;
}
}
}
if $is_hash {
my @children := @($past[1]);
$past := PAST::Op.new(
:pasttype('call'),
:name('&circumfix:<{ }>'),
:node($/)
);
for @children {
$past.push($_);
}
}
else {
$past := create_code_object($past, 'Block', 0, '');
}
make $past;
}
method circumfix:sym<[ ]>($/) {
make PAST::Op.new( :name('&circumfix:<[ ]>'), $<semilist>.ast, :node($/) );
}
method circumfix:sym<sigil>($/) {
my $name := ~$<sigil> eq '@' ?? 'list' !!
~$<sigil> eq '%' ?? 'hash' !!
'item';
make PAST::Op.new( :pasttype('callmethod'), :name($name), $<semilist>.ast );
}
## Expressions
method EXPR($/, $key?) {
unless $key { return 0; }
if $/<drop> { make PAST::Stmts.new(); return 0; }
my $past := $/.ast // $<OPER>.ast;
if !$past && $<infix><sym> eq '.=' {
make make_dot_equals($/[0].ast, $/[1].ast);
return 1;
}
unless $past {
$past := PAST::Op.new( :node($/) );
if $<OPER><O><pasttype> { $past.pasttype( ~$<OPER><O><pasttype> ); }
elsif $<OPER><O><pirop> { $past.pirop( ~$<OPER><O><pirop> ); }
unless $past.name {
if $key eq 'LIST' { $key := 'infix'; }
my $name := Q:PIR {
$P0 = find_lex '$key'
$S0 = $P0
$S0 = downcase $S0
%r = box $S0
} ~ ':<' ~ $<OPER><sym> ~ '>';
$past.name('&' ~ $name);
}
}
if $key eq 'POSTFIX' {
$past.unshift(
PAST::Op.ACCEPTS($past) && $past.pasttype eq 'callmethod'
?? PAST::Op.new( :pirop('descalarref PP'), $/[0].ast )
!! $/[0].ast
);
}
else {
for $/.list { if $_.ast { $past.push($_.ast); } }
}
make $past;
}
method prefixish($/) {
if $<prefix_postfix_meta_operator> {
my $opsub := '&prefix:<' ~ $<OPER>.Str ~ '<<>';
unless %*METAOPGEN{$opsub} {
my $base_op := '&prefix:<' ~ $<OPER>.Str ~ '>';
@BLOCK[0].loadinit.push(PAST::Op.new(
:pasttype('bind'),
PAST::Var.new( :name($opsub), :scope('package') ),
PAST::Op.new(
:pasttype('callmethod'), :name('assuming'),
PAST::Op.new( :pirop('find_sub_not_null__Ps'), '&hyper' ),
PAST::Op.new( :pirop('find_sub_not_null__Ps'), $base_op )
)
));
%*METAOPGEN{$opsub} := 1;
}
make PAST::Op.new( :name($opsub), :pasttype('call') );
}
}
method infixish($/) {
if $<infix_postfix_meta_operator> {
my $sym := ~$<infix><sym>;
my $opsub := "&infix:<$sym=>";
unless %*METAOPGEN{$opsub} {
@BLOCK[0].loadinit.push(
PAST::Op.new( :name('!gen_assign_metaop'), $sym,
:pasttype('call') )
);
%*METAOPGEN{$opsub} := 1;
}
make PAST::Op.new( :name($opsub), :pasttype('call') );
}
if $<infix_prefix_meta_operator> {
my $metaop := ~$<infix_prefix_meta_operator><sym>;
my $sym := ~$<infix_prefix_meta_operator><infixish>;
my $opsub := "&infix:<$metaop$sym>";
my $base_opsub := "&infix:<$sym>";
if $opsub eq "&infix:<!=>" {
$base_opsub := "&infix:<==>";
}
unless %*METAOPGEN{$opsub} {
my $helper := "";
if $metaop eq '!' {
$helper := '&notresults';
} elsif $metaop eq 'R' {
$helper := '&reverseargs';
} elsif $metaop eq 'X' {
$helper := '&crosswith';
} elsif $metaop eq 'Z' {
$helper := '&zipwith';
}
@BLOCK[0].loadinit.push(
PAST::Op.new( :pasttype('bind'),
PAST::Var.new( :name($opsub), :scope('package') ),
PAST::Op.new( :pasttype('callmethod'),
:name('assuming'),
PAST::Op.new( :pirop('find_sub_not_null__Ps'),
$helper ),
PAST::Op.new( :pirop('find_sub_not_null__Ps'),
$base_opsub ) ) ) );
%*METAOPGEN{$opsub} := 1;
}
make PAST::Op.new( :name($opsub), :pasttype('call') );
}
}
method prefix_circumfix_meta_operator:sym<reduce>($/) {
my $opsub := '&prefix:<' ~ ~$/ ~ '>';
unless %*METAOPGEN{$opsub} {
my $base_op := '&infix:<' ~ $<op>.Str ~ '>';
@BLOCK[0].loadinit.push(PAST::Op.new(
:pasttype('bind'),
PAST::Var.new( :name($opsub), :scope('package') ),
PAST::Op.new(
:pasttype('callmethod'), :name('assuming'),
PAST::Op.new( :pirop('find_sub_not_null__Ps'), '&reducewith' ),
PAST::Op.new( :pirop('find_sub_not_null__Ps'), $base_op ),
PAST::Val.new( :named('triangle'), :value($<triangle> ?? 1 !! 0) ),
PAST::Val.new( :named('chaining'), :value($<op><OPER><O><prec> eq 'm=') ),
PAST::Val.new( :named('right-assoc'), :value($<op><OPER><O><assoc> eq 'right') )
)
));
%*METAOPGEN{$opsub} := 1;
}
make PAST::Op.new( :name($opsub), :pasttype('call') );
}
method infix_circumfix_meta_operator:sym«<< >>»($/) {
make make_hyperop($/);
}
method infix_circumfix_meta_operator:sym<« »>($/) {
make make_hyperop($/);
}
sub make_hyperop($/) {
my $opsub := '&infix:<' ~ ~$/ ~ '>';
unless %*METAOPGEN{$opsub} {
my $base_op := '&infix:<' ~ $<infixish>.Str ~ '>';
my $dwim_lhs := $<opening> eq '<<' || $<opening> eq '«';
my $dwim_rhs := $<closing> eq '>>' || $<closing> eq '»';
@BLOCK[0].loadinit.push(PAST::Op.new(
:pasttype('bind'),
PAST::Var.new( :name($opsub), :scope('package') ),
PAST::Op.new(
:pasttype('callmethod'), :name('assuming'),
PAST::Op.new( :pirop('find_sub_not_null__Ps'), '&hyper' ),
PAST::Op.new( :pirop('find_sub_not_null__Ps'), $base_op ),
PAST::Val.new( :value($dwim_lhs), :named('dwim-left') ),
PAST::Val.new( :value($dwim_rhs), :named('dwim-right') )
)
));
%*METAOPGEN{$opsub} := 1;
}
return PAST::Op.new( :name($opsub), :pasttype('call') );
}
method postfixish($/) {
if $<postfix_prefix_meta_operator> {
my $past := $<OPER>.ast;
if $past && $past.isa(PAST::Op) && $past.pasttype() eq 'call' {
$past.unshift($past.name());
$past.name('!dispatch_dispatcher_parallel');
}
elsif $past && $past.isa(PAST::Op) && $past.pasttype() eq 'callmethod' {
$past.unshift($past.name());
$past.name('!dispatch_method_parallel');
$past.pasttype('call');
}
else {
# Hyper-op over a normal postfix.
my $opsub := '&postfix:<>>' ~ $<OPER>.Str ~ '>';
unless %*METAOPGEN{$opsub} {
my $base_op := '&postfix:<' ~ $<OPER>.Str ~ '>';
@BLOCK[0].loadinit.push(PAST::Op.new(
:pasttype('bind'),
PAST::Var.new( :name($opsub), :scope('package') ),
PAST::Op.new(
:pasttype('callmethod'), :name('assuming'),
PAST::Op.new( :pirop('find_sub_not_null__Ps'), '&hyper' ),
PAST::Op.new( :pirop('find_sub_not_null__Ps'), $base_op )
)
));
%*METAOPGEN{$opsub} := 1;
}
$past := PAST::Op.new( :name($opsub), :pasttype('call') );
}
make $past;
}
}
method postcircumfix:sym<[ ]>($/) {
make PAST::Op.new( $<EXPR>.ast, :name('!postcircumfix:<[ ]>'),
:pasttype('call'), :node($/) );
}
method postcircumfix:sym<{ }>($/) {
make PAST::Op.new( $<EXPR>.ast, :name('!postcircumfix:<{ }>'),
:pasttype('call'), :node($/) );
}
method postcircumfix:sym<ang>($/) {
make PAST::Op.new( $<quote_EXPR>.ast, :name('!postcircumfix:<{ }>'),
:pasttype('call'), :node($/) );
}
method postcircumfix:sym<( )>($/) {
make $<arglist>.ast;
}
method value:sym<quote>($/) {
make $<quote>.ast;
}
method value:sym<number>($/) {
make $<number>.ast;
}
method number:sym<rational>($/) {
make PAST::Op.new(
:pasttype('callmethod'), :name('new'),
PAST::Var.new( :name('Rat'), :namespace(''), :scope('package') ),
$<nu>.ast, $<de>.ast
);
}
method number:sym<complex>($/) {
make PAST::Op.new(
:pasttype('callmethod'), :name('new'),
PAST::Var.new( :name('Complex'), :namespace(''), :scope('package') ),
($<re> ?? $<re>.ast !! 0), $<im>.ast
);
}
method number:sym<numish>($/) {
make $<numish>.ast;
}
method numish($/) {
if $<integer> { make PAST::Val.new( :value($<integer>.ast) ); }
elsif $<dec_number> { make $<dec_number>.ast; }
elsif $<rad_number> { make $<rad_number>.ast; }
else {
make PAST::Var.new( :name(~$/), :namespace(''), :scope('package') );
}
}
method dec_number($/) {
my $int := $<int> ?? $<int>.ast !! 0;
my $frac := $<frac> ?? $<frac>.ast !! 0;
my $base := Q:PIR {
$P0 = find_lex '$/'
$S0 = $P0['frac']
$I1 = length $S0
$I0 = 0
$I2 = 1
loop:
unless $I0 < $I1 goto done
$S1 = substr $S0, $I0, 1
inc $I0
if $S1 == '_' goto loop
$I2 *= 10
goto loop
done:
%r = box $I2
};
if $<escale> {
my $exp := $<escale>[0]<decint>.ast;
if $<escale>[0]<sign> eq '-' { $exp := -$exp; }
make PAST::Val.new(
:value(($int * $base + $frac) / $base * 10 ** +$exp ) ,
:returns('Num')
);
}
else {
make PAST::Op.new(
:pasttype('callmethod'), :name('new'),
PAST::Var.new( :name('Rat'), :namespace(''), :scope('package') ),
$int * $base + $frac, $base, :node($/)
);
}
}
method rad_number($/) {
my $radix := +($<radix>.Str);
if $<circumfix> {
make PAST::Op.new(:name('&radcalc'), :pasttype('call'),
$radix, $<circumfix>.ast);
} else {
my $intpart := $<intpart>.Str;
my $fracpart := $<fracpart> ?? $<fracpart>.Str !! "0";
my $intfrac := $intpart ~ $fracpart; #the dot is a part of $fracpart, so no need for ~ "." ~
my $base := $<base> ?? +($<base>[0].Str) !! 0;
my $exp := $<exp> ?? +($<exp>[0].Str) !! 0;
make PAST::Op.new( :name('&radcalc'), :pasttype('call'),
$radix, $intfrac, $base, $exp
);
}
}
method typename($/) {
my $past;
if is_lexical($<longname>.Str) {
# We need to build a thunk.
$past := PAST::Block.new(
PAST::Var.new( :name('$_'), :scope('parameter'), :isdecl(1) ),
PAST::Op.new( :pasttype('callmethod'), :name('ACCEPTS'),
PAST::Var.new( :name($<longname>.Str), :scope('lexical') ),
PAST::Var.new( :name('$_'), :scope('lexical') )
)
);
my $sig := Perl6::Compiler::Signature.new();
my $param := Perl6::Compiler::Parameter.new();
$param.var_name('$_');
$sig.add_parameter($param);
add_signature($past, $sig, 0);
$past := create_code_object($past, 'Block', 0, '');
}
else {
my @name := Perl6::Grammar::parse_name($<longname>.Str);
$past := PAST::Var.new(
:name(@name.pop),
:namespace(@name),
:scope('package')
);
}
# Parametric type?
if $<typename> {
$past := PAST::Op.new(
:pasttype('callmethod'), :name('postcircumfix:<[ ]>'),
$past, $<typename>[0].ast
);
}
make $past;
}
method quote:sym<apos>($/) { make $<quote_EXPR>.ast; }
method quote:sym<dblq>($/) { make $<quote_EXPR>.ast; }
method quote:sym<qq>($/) { make $<quote_EXPR>.ast; }
method quote:sym<q>($/) { make $<quote_EXPR>.ast; }
method quote:sym<Q>($/) { make $<quote_EXPR>.ast; }
method quote:sym<Q:PIR>($/) {
make PAST::Op.new( :inline( $<quote_EXPR>.ast.value ),
:pasttype('inline'),
:node($/) );
}
method quote:sym<qx>($/) {
make PAST::Op.new( :name('!qx'), :pasttype('call'),
$<quote_EXPR>.ast
);
}
method quote:sym<qqx>($/) {
make PAST::Op.new( :name('!qx'), :pasttype('call'),
$<quote_EXPR>.ast
);
}
method quote:sym</ />($/) {
my $past := Regex::P6Regex::Actions::buildsub($<p6regex>.ast);
make create_code_object($past, 'Regex', 0, '');
}
method quote:sym<rx>($/) {
my $past := Regex::P6Regex::Actions::buildsub($<p6regex>.ast);
make create_code_object($past, 'Regex', 0, '');
}
method quote:sym<m>($/) {
my $past := Regex::P6Regex::Actions::buildsub($<p6regex>.ast);
make create_code_object($past, 'Regex', 0, '');
}
method quote:sym<s>($/) {
# Build the regex.
my $regex_ast := Regex::P6Regex::Actions::buildsub($<p6regex>.ast);
my $regex := create_code_object($regex_ast, 'Regex', 0, '');
# Quote needs to be closure-i-fied.
my $closure_ast := PAST::Block.new(
PAST::Stmts.new(),
PAST::Stmts.new(
$<quote_EXPR> ?? $<quote_EXPR>.ast !! $<EXPR>.ast
)
);
my $closure := create_code_object($closure_ast, 'Block', 0, '');
# Make a Substitution.
$regex.named('matcher');
$closure.named('replacer');
make PAST::Op.new(
:pasttype('callmethod'), :name('new'),
PAST::Var.new( :name('Substitution'), :scope('package') ),
$regex, $closure
);
}
method quote_escape:sym<$>($/) {
make steal_back_spaces($/, PAST::Op.new( $<EXPR>.ast, :pirop('set SP') ));
}
method quote_escape:sym<array>($/) {
make steal_back_spaces($/, PAST::Op.new( $<EXPR>.ast, :pirop('set SP') ));
}
method quote_escape:sym<%>($/) {
make steal_back_spaces($/, PAST::Op.new( $<EXPR>.ast, :pirop('set SP') ));
}
# Unfortunately, the operator precedence parser (probably correctly)
# steals spaces after a postfixish. Thus "$a $b" would get messed up.
# Here we take them back again. Hacky, better solutions welcome.
sub steal_back_spaces($/, $expr) {
my $pos := pir::length__IS($/) - 1;
while pir::is_cclass__IISI(32, $/, $pos) {
$pos--;
}
my $nab_back := pir::substr__SSI($/, $pos + 1);
if $nab_back {
PAST::Op.new( :pasttype('call'), :name('&infix:<~>'), $expr, ~$nab_back )
}
else {
$expr
}
}
method quote_escape:sym<{ }>($/) {
make PAST::Op.new(
:pirop('set S*'), block_immediate($<block>.ast), :node($/)
);
}
# overrides versions from HLL::Actions to handle Perl6Str
# and use &infix:<,> to build the parcel
method quote_EXPR($/) {
my $past := $<quote_delimited>.ast;
if HLL::Grammar::quotemod_check($/, 'w') {
if !$past.isa(PAST::Val) {
$/.CURSOR.panic("Can't form :w list from non-constant strings (yet)");
}
else {
my @words := HLL::Grammar::split_words($/, $past.value);
if +@words > 1 {
$past := PAST::Op.new( :name('&infix:<,>'), :node($/) );
for @words { $past.push($_); }
$past := PAST::Stmts.new($past);
}
else {
$past := PAST::Val.new(:value(~@words[0]), :returns<Perl6Str>);
}
}
}
make $past;
}
method quote_delimited($/) {
my @parts;
my $lastlit := '';
for $<quote_atom> {
my $ast := $_.ast;
if !PAST::Node.ACCEPTS($ast) {
$lastlit := $lastlit ~ $ast;
}
elsif $ast.isa(PAST::Val) {
$lastlit := $lastlit ~ $ast.value;
}
else {
if $lastlit gt '' {
@parts.push(
PAST::Val.new( :value($lastlit), :returns('Perl6Str') )
);
}
@parts.push($ast);
$lastlit := '';
}
}
if $lastlit gt '' || !@parts {
@parts.push(
PAST::Val.new( :value($lastlit), :returns('Perl6Str') )
);
}
my $past := @parts ?? @parts.shift !! '';
while @parts {
$past := PAST::Op.new( $past, @parts.shift, :pirop('concat') );
}
make $past;
}
## Operators
class Perl6::RegexActions is Regex::P6Regex::Actions {
method metachar:sym<:my>($/) {
my $past := $<statement>.ast;
make PAST::Regex.new( $past, :pasttype('pastnode') );
}
method metachar:sym<{ }>($/) { make $<codeblock>.ast; }
method assertion:sym<{ }>($/) { make $<codeblock>.ast; }
method codeblock($/) {
my $block := $<block>.ast;
$block.blocktype('immediate');
make bindmatch($block);
}
method p6arglist($/) {
my $arglist := $<arglist>.ast;
# make bindmatch($arglist);
make $arglist;
}
sub bindmatch($past) {
PAST::Regex.new(
PAST::Stmts.new(
PAST::Op.new(
PAST::Var.new( :name('$/') ),
PAST::Op.new(
PAST::Var.new( :name('') ),
:name('MATCH'),
:pasttype('callmethod')
),
:pasttype('bind')
),
$past
),
:pasttype('pastnode')
);
}
}
# Takes a block and adds a signature ot it, as well as code to bind the call
# capture against the signature. Returns the name of the signature setup block.
sub add_signature($block, $sig_obj, $lazy) {
# Set arity.
$block.arity($sig_obj.arity);
# Add call to signature binder as well as lexical declarations
# to the start of the block.
$block[0].push(PAST::Var.new( :name('call_sig'), :scope('parameter'), :call_sig(1) ));
my $decls := $sig_obj.get_declarations();
for @($decls) {
$_.isdecl(1);
$block.symbol( $_.name, :scope('lexical') );
}
$block[0].push($decls);
$block[0].push(PAST::Op.new(
:pirop('bind_signature vP'),
PAST::Var.new( :name('call_sig'), :scope('lexical') )
));
# If lazy, make and push signature setup block.
if $lazy {
my $sig_setup_block :=
PAST::Block.new( :blocktype<declaration>, $sig_obj.ast(1) );
$block[0].push($sig_setup_block);
PAST::Val.new(:value($sig_setup_block));
}
else {
$block.loadinit.push($sig_obj.ast(1));
$block.loadinit.push(PAST::Op.new( :inline(' setprop block, "$!signature", signature') ));
}
}
# Adds a placeholder parameter to this block's signature.
sub add_placeholder_parameter($sigil, $ident, :$named, :$slurpy_pos, :$slurpy_named) {
our @BLOCK;
my $block := @BLOCK[0];
# Add entry to the block signature.
my $placeholder_sig := $block<placeholder_sig>;
unless pir::defined__IP($placeholder_sig) {
$block<placeholder_sig> := $placeholder_sig := Perl6::Compiler::Signature.new();
}
my $param := Perl6::Compiler::Parameter.new();
$param.var_name(~$sigil ~ ~$ident);
$param.pos_slurpy($slurpy_pos);
$param.named_slurpy($slurpy_named);
if $named { $param.names.push($ident) }
$placeholder_sig.add_placeholder_parameter($param);
# Just want a lookup of the variable here.
return PAST::Var.new( :name(~$sigil ~ ~$ident), :scope('lexical') );
}
# Wraps a sub up in a block type.
sub create_code_object($block, $type, $multiness, $lazy_init) {
my @name := Perl6::Grammar::parse_name($type);
my $past := PAST::Op.new(
:pasttype('callmethod'),
:name('new'),
PAST::Var.new( :name(@name.pop), :namespace(@name), :scope('package') ),
$block,
$multiness,
$lazy_init
);
$past<past_block> := $block;
$past
}
# This routine checks if the given list of traits contains one of the given
# name. If so, it marks it as compiler handled so no multi call will be
# emitted when we emit the traits. If there is such a trait, it returns it's
# AST.
sub has_compiler_trait($trait_list, $name) {
if $trait_list {
for $trait_list {
my $ast := $_.ast;
if $ast.name eq $name {
$ast<trait_is_compiler_handled> := 1;
return $ast;
}
}
}
return 0;
}
# This routine checks if the given list of traits contains one of the given
# names and also that it carries the given value as a named parameter. If so,
# it marks it as compiler handled so no multi call will be emitted when we emit
# the traits. If there is such a trait, it returns it's AST.
sub has_compiler_trait_with_val($trait_list, $name, $value) {
if $trait_list {
for $trait_list {
my $ast := $_.ast;
if $ast.name eq $name && $ast<is_name> eq $value {
$ast<trait_is_compiler_handled> := 1;
return $ast;
}
}
}
return 0;
}
# Emits routine traits into the loadinit for the routine.
sub emit_routine_traits($routine, @trait_list, $type, $sig_setup_block) {
$routine.loadinit.push(PAST::Op.new(
:pasttype('bind'),
PAST::Var.new( :name('trait_subject'), :scope('register'), :isdecl(1) ),
create_code_object(PAST::Var.new( :name('block'), :scope('register') ), $type, 0, $sig_setup_block)
));
for @trait_list {
my $ast := $_.ast;
$ast.unshift(PAST::Var.new( :name('trait_subject'), :scope('register') ));
$routine.loadinit.push($ast);
}
}
# Finds out which readtype trait we have, and marks all of the relevant ones
# as compiler handled.
sub trait_readtype($traits) {
my $readtype;
if has_compiler_trait_with_val($traits, '&trait_mod:<is>', 'readonly') {
$readtype := 'readonly';
}
if has_compiler_trait_with_val($traits, '&trait_mod:<is>', 'rw') {
$readtype := $readtype ?? 'CONFLICT' !! 'rw';
}
if has_compiler_trait_with_val($traits, '&trait_mod:<is>', 'copy') {
$readtype := $readtype ?? 'CONFLICT' !! 'copy';
}
$readtype;
}
# Handles trait node on a block and setting up the ContainerDeclarand.
sub get_var_traits_node($block, $name) {
# Do we already have a traits node?
my %symtab := $block.symbol($name);
if %symtab<traits_node> {
return %symtab<traits_node>;
}
# Create one, in the viviself.
my $decl := %symtab<decl_node>;
my @cd_name := Perl6::Grammar::parse_name('ContainerDeclarand');
my $traits_node := PAST::Stmts.new();
my $vivinode := PAST::Stmts.new(
PAST::Op.new( :pasttype('bind'),
PAST::Var.new( :name('$P0'), :scope('register') ),
$decl.viviself()
),
PAST::Op.new( :pasttype('bind'),
PAST::Var.new( :name('declarand'), :scope('register'), :isdecl(1) ),
PAST::Op.new(
:pasttype('callmethod'), :name('new'),
PAST::Var.new( :name(@cd_name.pop), :namespace(@cd_name), :scope('package') ),
PAST::Var.new( :name('$P0'), :scope('register') ),
PAST::Val.new( :value($name), :named('name') )
)
),
$traits_node,
PAST::Op.new( :inline(' %r = $P0') )
);
$decl.viviself($vivinode);
$block.symbol($name, :traits_node($traits_node));
$traits_node;
}
sub add_implicit_var($block, $name, $outer) {
my $base := $outer
?? PAST::Op.new( :inline(" %r = new ['Perl6Scalar'], %0"),
PAST::Op.new(:pirop('find_lex_skip_current Ps'), $name)
)
!! PAST::Op.new( :inline(" %r = new ['Perl6Scalar']") );
$base := PAST::Op.new( $base, 'rw', $TRUE, :pirop('setprop') );
$block[0].push(
PAST::Var.new( :name($name), :scope('lexical'), :isdecl(1),
:viviself($base) )
);
$block.symbol($name, :scope('lexical') );
}
sub when_handler_helper($block) {
our @BLOCK;
my $BLOCK := @BLOCK[0];
# XXX TODO: This isn't quite the right way to check this...
unless $BLOCK.handlers() {
my @handlers;
@handlers.push(
PAST::Control.new(
PAST::Op.new(
:pasttype('pirop'),
:pirop('return'),
PAST::Var.new(
:scope('keyed'),
PAST::Var.new( :name('exception'), :scope('register') ),
'payload',
),
),
:handle_types('BREAK')
)
);
$BLOCK.handlers(@handlers);
}
# push a control exception throw onto the end of the block so we
# exit the innermost block in which $_ was set.
my $last := $block.pop();
$block.push(
PAST::Op.new(
:pasttype('call'),
:name('&succeed'),
$last
)
);
# Push a handler onto the block to handle CONTINUE exceptions so we can
# skip throwing the BREAK exception
my @handlers;
if $block.handlers() {
@handlers := $block.handlers();
}
@handlers.push(
PAST::Control.new(
PAST::Op.new(
:pasttype('pirop'),
:pirop('return'),
),
:handle_types('CONTINUE')
)
);
$block.handlers(@handlers);
}
sub make_dot_equals($thingy, $call) {
$call.unshift($call.name);
$call.unshift($thingy);
$call.name('!dispatch_.=');
$call.pasttype('call');
$call;
}
# XXX This isn't quite right yet... need to evaluate these semantics
sub push_block_handler($/, $block, $handler) {
unless $block.handlers() {
$block.handlers([]);
}
$handler.blocktype('declaration');
$handler := PAST::Block.new(
:blocktype('declaration'),
PAST::Var.new( :scope('parameter'), :name('$_') ),
PAST::Op.new( :pasttype('bind'),
PAST::Var.new( :scope('lexical'), :name('$_') ),
PAST::Op.new(
:pasttype('callmethod'),
:name('new'),
PAST::Var.new(
:name('Exception'),
:namespace([]),
:scope('package'),
),
PAST::Var.new( :scope('lexical'), :name('$_') ),
),
),
PAST::Op.new( :pasttype('bind'),
PAST::Var.new( :scope('lexical'), :name('$!'), :isdecl(1) ),
PAST::Var.new( :scope('lexical'), :name('$_') ),
),
PAST::Op.new( :pasttype('call'),
$handler,
),
);
$handler.symbol('$_', :scope('lexical'));
$handler.symbol('$!', :scope('lexical'));
$handler := PAST::Stmts.new(
PAST::Op.new( :pasttype('call'),
$handler,
PAST::Var.new( :scope('register'), :name('exception') ),
),
# XXX Rakudo needs to set this when $! is inspected
# We just cheat for now. Call .rethrow() if you want it rethrown.
PAST::Op.new( :pasttype('bind'),
PAST::Var.new( :scope('keyed'),
PAST::Var.new( :scope('register'), :name('exception')),
'handled'
),
1
)
);
$block.handlers.unshift(
PAST::Control.new(
:node($/),
$handler,
)
);
}
# Makes the closure for the RHS of has $.answer = 42.
sub make_attr_init_closure($init_value) {
# Need to not just build the closure, but new_closure it; otherwise, we
# run into trouble if our initialization value involves a parameter from
# a parametric role.
my $block := PAST::Block.new(
:blocktype('declaration'),
PAST::Stmts.new( ),
PAST::Stmts.new( $init_value )
);
$block[0].unshift(PAST::Var.new( :name('self'), :scope('lexical'), :isdecl(1), :viviself(sigiltype('$')) ));
$block.symbol('self', :scope('lexical'));
my $sig := Perl6::Compiler::Signature.new();
my $parameter := Perl6::Compiler::Parameter.new();
$parameter.var_name('$_');
$sig.add_parameter($parameter);
$sig.add_invocant();
my $lazy_name := add_signature($block, $sig, 1);
create_code_object(PAST::Op.new( :pirop('newclosure PP'), $block ), 'Method', 0, $lazy_name);
}
# Looks through the lexpads and sees if we recognize the symbol as a lexical.
sub is_lexical($name) {
our @BLOCK;
for @BLOCK {
my %entry := $_.symbol($name);
if %entry && %entry<scope> eq 'lexical' {
return 1;
}
}
return 0;
}
# Looks to see if a variable has been set up as an alias to an attribute.
sub is_attr_alias($name) {
our @BLOCK;
for @BLOCK {
my %entry := $_.symbol($name);
if %entry {
return %entry<attr_alias>;
}
}
return "";
}
# Gives a block a Nil to return if it has no statements, to prevent Null
# PMCs being handed back.
sub prevent_null_return($block) {
if +@($block[1]) == 0 {
$block[1].push(PAST::Op.new( :name('&Nil') ));
}
}
# Takes something that may be a block already, and if not transforms it into
# one. Used by things doing where clause-ish things.
sub where_blockify($expr) {
my $past;
if $expr.isa(PAST::Block) {
$past := $expr;
}
else {
$past := PAST::Block.new( :blocktype('declaration'),
PAST::Stmts.new( ),
PAST::Stmts.new(
PAST::Op.new( :pasttype('call'), :name('&infix:<~~>'),
PAST::Var.new( :name('$_'), :scope('lexical') ),
$expr
)
)
);
my $sig := Perl6::Compiler::Signature.new();
my $param := Perl6::Compiler::Parameter.new();
$param.var_name('$_');
$sig.add_parameter($param);
my $lazy_name := add_signature($past, $sig, 1);
$past := create_code_object($past, 'Block', 0, $lazy_name);
}
$past
}
# This is the hook where, in the future, we'll use this as the hook to check
# if we have a proto or other declaration in scope that states that this sub
# has a signature of the form :(\|$parcel), in which case we don't promote
# the Parcel to a Capture when calling it. For now, we just worry about the
# special case, return.
sub capture_or_parcel($args, $name) {
if $name eq 'return' {
# Need to demote pairs again.
my $parcel := PAST::Op.new();
for @($args) {
$parcel.push($_<before_promotion> ?? $_<before_promotion> !! $_);
}
$parcel
}
else {
$args
}
}
# vim: ft=perl6
Jump to Line
Something went wrong with that request. Please try again.