Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
tree: 7d10d1aae2
Fetching contributors…

Cannot retrieve contributors at this time

5711 lines (5219 sloc) 216.447 kb
use NQPP6QRegex;
use NQPP5QRegex;
use Perl6::Pod;
use Perl6::ConstantFolder;
use Perl6::Ops;
use QRegex;
use QAST;
class Perl6::Actions is HLL::Actions {
our @MAX_PERL_VERSION;
our $FORBID_PIR;
our $STATEMENT_PRINT;
INIT {
# Tell QAST::SVal how to encode Perl6Str and Str values
# XXX Needs review...
my %valflags :=
Q:PIR { %r = get_hll_global ['PAST';'Compiler'], '%valflags' };
%valflags<Perl6Str> := 'e';
%valflags<Str> := 'e';
# If, e.g., we support Perl up to v6.1.2, set
# @MAX_PERL_VERSION to [6, 1, 2].
@MAX_PERL_VERSION[0] := 6;
$FORBID_PIR := 0;
$STATEMENT_PRINT := 0;
}
sub p6box_s($s) {
nqp::box_s($s, $*W.find_symbol(['Str']));
}
method ints_to_string($ints) {
if pir::does($ints, 'array') {
my $result := '';
for $ints {
$result := $result ~ nqp::chr(nqp::unbox_i($_.ast));
}
$result;
} else {
nqp::chr(nqp::unbox_i($ints.ast));
}
}
# TODO: inline string_to_bigint?
my sub string_to_bigint($src, $base) {
my $res := nqp::radix_I($base, ~$src, 0, 2, $*W.find_symbol(['Int']));
$src.CURSOR.panic("'$src' is not a valid number")
unless nqp::iseq_i(nqp::unbox_i(nqp::atkey($res, 2)), nqp::chars($src));
nqp::atkey($res, 0);
}
sub xblock_immediate($xblock) {
$xblock[1] := pblock_immediate($xblock[1]);
$xblock;
}
sub pblock_immediate($pblock) {
block_immediate($pblock<uninstall_if_immediately_used>.shift);
}
our sub block_immediate($block) {
$block.blocktype('immediate');
$block;
}
# Given a sigil and the the value type specified, works out the
# container type (what should we instantiate and bind into the
# attribute/lexpad), bind constraint (what could we bind to this
# slot later), and if specified a constraint on the inner value
# and a default value.
sub container_type_info($/, $sigil, @value_type, $shape?) {
my %info;
if $sigil eq '@' {
%info<container_base> := $*W.find_symbol(['Array']);
%info<bind_constraint> := $*W.find_symbol(['Positional']);
if @value_type {
%info<container_type> := $*W.parameterize_type_with_args(
%info<container_base>, [@value_type[0]], nqp::hash());
%info<bind_constraint> := $*W.parameterize_type_with_args(
%info<bind_constraint>, [@value_type[0]], nqp::hash());
%info<value_type> := @value_type[0];
}
else {
%info<container_type> := %info<container_base>;
%info<value_type> := $*W.find_symbol(['Mu']);
}
if $shape {
$*W.throw($/, 'X::Comp::NYI', feature => 'Shaped arrays');
}
}
elsif $sigil eq '%' {
%info<container_base> := $*W.find_symbol(['Hash']);
%info<bind_constraint> := $*W.find_symbol(['Associative']);
if $shape {
@value_type[0] := $*W.find_symbol(['Mu']) unless +@value_type;
my $shape_ast := $shape[0].ast;
if $shape_ast.isa(QAST::Stmts) && +@($shape_ast) == 1 && $shape_ast[0].has_compile_time_value {
@value_type[1] := $shape_ast[0].compile_time_value;
}
else {
nqp::die("Invalid hash shape; type expected");
}
}
if @value_type {
%info<container_type> := $*W.parameterize_type_with_args(
%info<container_base>, @value_type, nqp::hash());
%info<bind_constraint> := $*W.parameterize_type_with_args(
%info<bind_constraint>, @value_type, nqp::hash());
%info<value_type> := @value_type[0];
}
else {
%info<container_type> := %info<container_base>;
%info<value_type> := $*W.find_symbol(['Mu']);
}
}
elsif $sigil eq '&' {
%info<container_base> := $*W.find_symbol(['Scalar']);
%info<container_type> := %info<container_base>;
%info<bind_constraint> := $*W.find_symbol(['Callable']);
if @value_type {
%info<bind_constraint> := $*W.parameterize_type_with_args(
%info<bind_constraint>, [@value_type[0]], nqp::hash());
}
%info<value_type> := %info<bind_constraint>;
%info<default_value> := $*W.find_symbol(['Any']);
}
else {
%info<container_base> := $*W.find_symbol(['Scalar']);
%info<container_type> := %info<container_base>;
if @value_type {
%info<bind_constraint> := @value_type[0];
%info<value_type> := @value_type[0];
%info<default_value> := @value_type[0];
}
else {
%info<bind_constraint> := $*W.find_symbol(['Mu']);
%info<value_type> := $*W.find_symbol(['Mu']);
%info<default_value> := $*W.find_symbol(['Any']);
}
}
%info
}
method deflongname($/) {
if $<colonpair> {
my $name := ~$<name>;
if $<colonpair>[0] {
$name := $name ~ ':';
}
if $<colonpair>[0]<identifier> {
$name := $name ~ ~$<colonpair>[0]<identifier>;
}
if $<colonpair>[0]<circumfix> {
$name := $name ~ '<' ~ ~$<colonpair>[0]<circumfix><quote_EXPR><quote_delimited><quote_atom>[0] ~ '>';
}
make $name;
}
else {
make ~$<name>;
}
}
# Turn $code into "for lines() { $code }"
sub wrap_option_n_code($/, $code) {
$code := make_topic_block_ref($code, copy => 1);
return QAST::Op.new(
:op<call>, :name<&eager>,
QAST::Op.new(:op<callmethod>, :name<map>,
QAST::Op.new( :op<call>, :name<&flat>,
QAST::Op.new(
:op<call>, :name<&flat>,
QAST::Op.new(
:name<&lines>,
:op<call>
)
)
),
$code
)
);
}
# 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) {
return wrap_option_n_code($/,
QAST::Stmts.new(
$code,
QAST::Op.new(:name<&say>, :op<call>,
QAST::Var.new(:name<$_>)
)
)
);
}
method comp_unit($/) {
# Finish up code object for the mainline.
if $*DECLARAND {
$*W.attach_signature($*DECLARAND, $*W.create_signature(nqp::hash('parameters', [])));
$*W.finish_code_object($*DECLARAND, $*UNIT);
}
# Checks.
$*W.assert_stubs_defined($/);
# Get the block for the unit mainline code.
my $unit := $*UNIT;
my $mainline := QAST::Stmts.new(
$*POD_PAST,
$<statementlist>.ast,
);
if %*COMPILING<%?OPTIONS><p> { # also covers the -np case, like Perl 5
$mainline := wrap_option_p_code($/, $mainline);
}
elsif %*COMPILING<%?OPTIONS><n> {
$mainline := wrap_option_n_code($/, $mainline);
}
# 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::VM.new(
pirop => 'set_hll_global vsP',
QAST::SVal.new( :value('GLOBAL') ),
QAST::WVal.new( :value($*GLOBALish) )
);
$*W.add_fixup_task(:deserialize_past($global_install), :fixup_past($global_install));
# Mainline should have fresh lexicals.
$*W.get_static_lexpad($unit).set_fresh_magicals();
# Get the block for the entire compilation unit.
my $outer := $*UNIT_OUTER;
$outer.node($/);
# Load the needed libraries.
$*W.add_libs($unit);
# If the unit defines &MAIN, and this is in the mainline,
# add a &MAIN_HELPER.
if !$*W.is_precompilation_mode && +@*MODULES == 0 && $unit.symbol('&MAIN') {
$mainline := QAST::Op.new(
:op('call'),
:name('&MAIN_HELPER'),
$mainline,
);
}
# 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 ));
# Wrap everything in a QAST::CompUnit.
my $compunit := 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()),
# 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
);
# Pass some extra bits along to the optimizer.
$compunit<UNIT> := $unit;
$compunit<GLOBALish> := $*GLOBALish;
$compunit<W> := $*W;
make $compunit;
}
# XXX Move to HLL::Actions after NQP gets QAST.
method CTXSAVE() {
QAST::Stmt.new(
QAST::Op.new(
:op('bind'),
QAST::Var.new( :name('ctxsave'), :scope('local'), :decl('var') ),
QAST::Var.new( :name('$*CTXSAVE'), :scope('contextual') )
),
QAST::Op.new(
:op('unless'),
QAST::Op.new(
:op('isnull'),
QAST::Var.new( :name('ctxsave'), :scope('local') )
),
QAST::Op.new(
:op('if'),
QAST::VM.new(
:pirop('can IPs'),
QAST::Var.new( :name('ctxsave'), :scope('local') ),
QAST::SVal.new( :value('ctxsave') )
),
QAST::Op.new(
:op('callmethod'), :name('ctxsave'),
QAST::Var.new( :name('ctxsave'), :scope('local')
)))))
}
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, $*GLOBALish);
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<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_simple_code_object($block, 'Block')
);
}
}
method pod_content_toplevel($/) {
my $child := $<pod_block>.ast;
# make sure we don't push the same thing twice
if $child {
my $id := $/.from ~ "," ~ ~$/.to;
if !$*POD_BLOCKS_SEEN{$id} {
$*POD_BLOCKS.push($child);
$*POD_BLOCKS_SEEN{$id} := 1;
}
}
make $child;
}
method pod_content:sym<block>($/) {
make $<pod_block>.ast;
}
method pod_configuration($/) {
make Perl6::Pod::make_config($/);
}
method pod_block:sym<delimited>($/) {
make Perl6::Pod::any_block($/);
}
method pod_block:sym<delimited_raw>($/) {
make Perl6::Pod::raw_block($/);
}
method pod_block:sym<delimited_table>($/) {
make Perl6::Pod::table($/);
}
method pod_block:sym<paragraph>($/) {
make Perl6::Pod::any_block($/);
}
method pod_block:sym<paragraph_raw>($/) {
make Perl6::Pod::raw_block($/);
}
method pod_block:sym<paragraph_table>($/) {
make Perl6::Pod::table($/);
}
method pod_block:sym<abbreviated>($/) {
make Perl6::Pod::any_block($/);
}
method pod_block:sym<abbreviated_raw>($/) {
make Perl6::Pod::raw_block($/);
}
method pod_block:sym<abbreviated_table>($/) {
make Perl6::Pod::table($/);
}
method pod_block:sym<end>($/) {
}
method pod_content:sym<config>($/) {
make Perl6::Pod::config($/);
}
method pod_content:sym<text>($/) {
my @ret := [];
for $<pod_textcontent> {
@ret.push($_.ast);
}
my $past := Perl6::Pod::serialize_array(@ret);
make $past.compile_time_value;
}
method pod_textcontent:sym<regular>($/) {
my @t := Perl6::Pod::merge_twines($<pod_string>);
my $twine := Perl6::Pod::serialize_array(@t).compile_time_value;
make Perl6::Pod::serialize_object(
'Pod::Block::Para', :content($twine)
).compile_time_value
}
method pod_textcontent:sym<code>($/) {
my $s := $<spaces>.Str;
my $t := subst($<text>.Str, /\n$s/, "\n", :global);
$t := subst($t, /\n$/, ''); # chomp!
my $past := Perl6::Pod::serialize_object(
'Pod::Block::Code',
:content(Perl6::Pod::serialize_aos([$t]).compile_time_value),
);
make $past.compile_time_value;
}
method pod_formatting_code($/) {
if ~$<code> eq 'V' {
make ~$<content>;
} else {
my @content := [];
for $<pod_string_character> {
@content.push($_.ast)
}
my @t := Perl6::Pod::build_pod_string(@content);
my $past := Perl6::Pod::serialize_object(
'Pod::FormattingCode',
:type(
$*W.add_string_constant(~$<code>).compile_time_value
),
:content(
Perl6::Pod::serialize_array(@t).compile_time_value
)
);
make $past.compile_time_value;
}
}
method pod_string($/) {
my @content := [];
for $<pod_string_character> {
@content.push($_.ast)
}
make Perl6::Pod::build_pod_string(@content);
}
method pod_string_character($/) {
if $<pod_formatting_code> {
make $<pod_formatting_code>.ast
} else {
make ~$<char>;
}
}
method table_row($/) {
make ~$/
}
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> {
for $<statement> {
my $ast := $_.ast;
if $ast {
if $ast<sink_past> {
$ast := QAST::Want.new($ast, 'v', $ast<sink_past>);
}
elsif $ast<bare_block> {
$ast := $ast<bare_block>;
}
else {
$ast := QAST::Stmt.new($ast, :returns($ast.returns)) if $ast ~~ QAST::Node;
}
$past.push( $ast );
}
}
}
if +$past.list < 1 {
$past.push(QAST::Var.new(:name('Nil'), :scope('lexical')));
}
else {
$past.returns($past[+@($past) - 1].returns);
}
make $past;
}
method semilist($/) {
my $past := QAST::Stmts.new( :node($/) );
if $<statement> {
for $<statement> { $past.push($_.ast); }
}
else {
$past.push( QAST::Op.new( :op('call'), :name('&infix:<,>') ) );
}
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 {
$mc.ast.push($past);
$mc.ast.push(QAST::Var.new(:name('Nil'), :scope('lexical')));
$past := $mc.ast;
}
if $ml {
my $cond := $ml<smexpr>.ast;
if ~$ml<sym> eq 'given' {
$past := QAST::Op.new(
:op('call'),
make_topic_block_ref($past),
$cond
);
}
elsif ~$ml<sym> eq 'for' {
unless $past<past_block> {
$past := make_topic_block_ref($past);
}
$past := QAST::Op.new(
:op<call>, :name<&eager>, :node($/),
QAST::Op.new(
:op<callmethod>, :name<map>, :node($/),
QAST::Op.new(:op('call'), :name('&infix:<,>'), $cond),
block_closure($past)
));
}
else {
$past := QAST::Op.new($cond, $past, :op(~$ml<sym>), :node($/) );
}
}
}
elsif $<statement_control> { $past := $<statement_control>.ast; }
else { $past := 0; }
if $STATEMENT_PRINT && $past {
$past := QAST::Stmts.new(:node($/),
QAST::Op.new(
:op<say>,
QAST::SVal.new(:value(~$/))
),
$past
);
}
make $past;
}
method xblock($/) {
make QAST::Op.new( $<EXPR>.ast, $<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<placeholder_sig> && $<signature> {
$*W.throw($/, ['X', 'Signature', 'Placeholder'],
placeholder => $block<placeholder_sig>[0]<placeholder>,
);
}
elsif $block<placeholder_sig> {
@params := $block<placeholder_sig>;
%sig_info<parameters> := @params;
}
elsif $<signature> {
%sig_info := $<signature>.ast;
@params := %sig_info<parameters>;
}
else {
unless $block.symbol('$_') {
if $*IMPLICIT {
@params.push(hash(
:variable_name('$_'), :optional(1),
:nominal_type($*W.find_symbol(['Mu'])),
:default_from_outer(1), :is_parcel(1),
));
}
add_implicit_var($block, '$_');
}
%sig_info<parameters> := @params;
}
# Create signature object and set up binding.
if $<lambda> eq '<->' {
for @params { $_<is_rw> := 1 }
}
set_default_parameter_type(@params, 'Mu');
my $signature := create_signature_object($<signature>, %sig_info, $block);
add_signature_binding_code($block, $signature, @params);
# Add a slot for a $*DISPATCHER, and a call to take one.
add_implicit_var($block, '$*DISPATCHER');
$block[0].unshift(QAST::Op.new(:op('p6takedisp')));
# 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.cur_lexpad())[0].push(my $uninst := QAST::Stmts.new($block));
$*W.attach_signature($*DECLARAND, $signature);
$*W.finish_code_object($*DECLARAND, $block);
my $ref := reference_to_code_object($*DECLARAND, $block);
$ref<uninstall_if_immediately_used> := $uninst;
make $ref;
}
}
method block($/) {
my $block := $<blockoid>.ast;
if $block<placeholder_sig> {
my $name := $block<placeholder_sig>[0]<variable_name>;
unless $name eq '%_' || $name eq '@_' {
$name := nqp::concat_s(nqp::substr($name, 0, 1),
nqp::concat_s('^', 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('parameters', [])));
$*W.finish_code_object($*DECLARAND, $block);
my $ref := reference_to_code_object($*DECLARAND, $block);
$ref<uninstall_if_immediately_used> := $uninst;
make $ref;
}
method blockoid($/) {
if $<statementlist> {
my $past := $<statementlist>.ast;
if %*HANDLERS {
$past := QAST::Op.new( :op('handle'), $past );
for %*HANDLERS {
$past.push($_.key);
$past.push($_.value);
}
}
my $BLOCK := $*CURPAD;
$BLOCK.push($past);
$BLOCK.node($/);
$BLOCK<statementlist> := $<statementlist>.ast;
$BLOCK<handlers> := %*HANDLERS if %*HANDLERS;
make $BLOCK;
}
else {
if $*HAS_YOU_ARE_HERE {
$/.CURSOR.panic('{YOU_ARE_HERE} may only appear once in a setting');
}
$*HAS_YOU_ARE_HERE := 1;
make $<you_are_here>.ast;
}
}
method you_are_here($/) {
make self.CTXSAVE();
}
method newpad($/) {
my $new_block := $*W.cur_lexpad();
$new_block<IN_DECL> := $*IN_DECL;
}
method finishpad($/) {
# Generate the $_, $/, and $! lexicals if they aren't already
# declared. We don't actually give them a value, but rather the
# Perl6LexPad will generate containers (and maybe fill them with
# the outer's value) on demand.
my $BLOCK := $*W.cur_lexpad();
my $type := $BLOCK<IN_DECL>;
my $is_routine := $type eq 'sub' || $type eq 'method' ||
$type eq 'submethod' || $type eq 'mainline';
for ($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($_) || ($_ eq '$_' && $*IMPLICIT) {
add_implicit_var($BLOCK, $_);
}
}
}
## Statement control
method statement_control:sym<if>($/) {
my $count := +$<xblock> - 1;
my $past := xblock_immediate( $<xblock>[$count].ast );
# push the else block if any, otherwise 'if' returns C<Nil> (per S04)
$past.push( $<else>
?? pblock_immediate( $<else>[0].ast )
!! QAST::Var.new(:name('Nil'), :scope('lexical'))
);
# 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.op('unless');
make $past;
}
method statement_control:sym<while>($/) {
my $past := xblock_immediate( $<xblock>.ast );
$past.op(~$<sym>);
make $past;
}
method statement_control:sym<repeat>($/) {
my $op := 'repeat_' ~ ~$<wu>;
my $past;
if $<xblock> {
$past := xblock_immediate( $<xblock>.ast );
$past.op($op);
}
else {
$past := QAST::Op.new( $<EXPR>.ast, pblock_immediate( $<pblock>.ast ),
:op($op), :node($/) );
}
make $past;
}
method statement_control:sym<for>($/) {
my $xblock := $<xblock>.ast;
my $past := QAST::Op.new(
:op<callmethod>, :name<map>, :node($/),
QAST::Op.new(:name('&infix:<,>'), :op('call'), $xblock[0]),
block_closure($xblock[1])
);
$past := QAST::Op.new( :name<&eager>, :op<call>, $past, :node($/) );
make $past;
}
method statement_control:sym<loop>($/) {
my $block := pblock_immediate($<block>.ast);
my $cond := $<e2> ?? $<e2>[0].ast !! QAST::Var.new(:name<True>, :scope<lexical>);
my $loop := QAST::Op.new( $cond, :op('while'), :node($/) );
$loop.push($block);
if $<e3> {
$loop.push($<e3>[0].ast);
}
if $<e1> {
$loop := QAST::Stmts.new( $<e1>[0].ast, $loop, :node($/) );
}
make $loop;
}
method statement_control:sym<need>($/) {
my $past := QAST::Var.new( :name('Nil'), :scope('lexical') );
for $<version> {
# XXX TODO: Version checks.
}
make $past;
}
method statement_control:sym<import>($/) {
my $past := QAST::Var.new( :name('Nil'), :scope('lexical') );
make $past;
}
method statement_control:sym<use>($/) {
my $past := QAST::Var.new( :name('Nil'), :scope('lexical') );
if $<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);
# $/.CURSOR.panic("Perl $<version> required--this is only v$mpv")
# }
# }
} elsif $<module_name> {
if ~$<module_name> eq 'fatal' {
my $*SCOPE := 'my';
declare_variable($/, QAST::Stmts.new(), '$', '*', 'FATAL', []);
$past := QAST::Op.new(
:op('p6store'), :node($/),
QAST::Var.new( :name('$*FATAL'), :scope('lexical') ),
QAST::Op.new( :op('p6bool'), QAST::IVal.new( :value(1) ) )
);
}
elsif ~$<module_name> eq 'FORBID_PIR' {
$FORBID_PIR := 1;
}
elsif ~$<module_name> eq 'Devel::Trace' {
$STATEMENT_PRINT := 1;
}
}
make $past;
}
method statement_control:sym<require>($/) {
my $past := QAST::Stmts.new(:node($/));
my $name_past := $<module_name>
?? QAST::SVal.new(:value($<module_name><longname><name>.Str))
!! $<EXPR>[0].ast;
$past.push(QAST::Op.new(
:op('callmethod'), :name('load_module'),
QAST::VM.new( pirop => 'get_hll_global Ps',
QAST::SVal.new( :value('ModuleLoader') ) ),
$name_past, $*W.symbol_lookup(['GLOBAL'], $/)
));
if $<module_name> && $<EXPR> {
my $p6_arglist := $*W.compile_time_evaluate($/, $<EXPR>[0].ast).list.eager;
my $arglist := nqp::getattr($p6_arglist, $*W.find_symbol(['List']), '$!items');
my $lexpad := $*W.cur_lexpad();
my $*SCOPE := 'my';
my $import_past := QAST::Op.new(:node($/), :op<call>,
:name<&REQUIRE_IMPORT>,
$name_past);
for $arglist {
my $symbol := nqp::unbox_s($_.Str());
$*W.throw($/, ['X', 'Redeclaration'], :$symbol)
if $lexpad.symbol($symbol);
declare_variable($/, $past,
nqp::substr($symbol, 0, 1), '', nqp::substr($symbol, 1),
[]);
$import_past.push($*W.add_string_constant($symbol));
}
$past.push($import_past);
}
$past.push(QAST::Var.new( :name('Nil'), :scope('lexical') ));
make $past;
}
method statement_control:sym<given>($/) {
my $past := $<xblock>.ast;
$past.push($past.shift); # swap [0] and [1] elements
$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;
# Handle the smart-match.
my $match_past := QAST::Op.new( :op('callmethod'), :name('ACCEPTS'),
$sm_exp,
QAST::Var.new( :name('$_'), :scope('lexical') )
);
# 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::Var.new( :name('Nil'), :scope('lexical') );
}
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::Var.new( :name('Nil'), :scope('lexical') );
}
method statement_prefix:sym<BEGIN>($/) { make $*W.add_phaser($/, 'BEGIN', ($<blorst>.ast)<code_object>); }
method statement_prefix:sym<CHECK>($/) { make $*W.add_phaser($/, 'CHECK', ($<blorst>.ast)<code_object>); }
method statement_prefix:sym<INIT>($/) { make $*W.add_phaser($/, 'INIT', ($<blorst>.ast)<code_object>); }
method statement_prefix:sym<START>($/) { make $*W.add_phaser($/, 'START', ($<blorst>.ast)<code_object>); }
method statement_prefix:sym<ENTER>($/) { make $*W.add_phaser($/, 'ENTER', ($<blorst>.ast)<code_object>); }
method statement_prefix:sym<FIRST>($/) { make $*W.add_phaser($/, 'FIRST', ($<blorst>.ast)<code_object>); }
method statement_prefix:sym<END>($/) { make $*W.add_phaser($/, 'END', ($<blorst>.ast)<code_object>); }
method statement_prefix:sym<LEAVE>($/) { make $*W.add_phaser($/, 'LEAVE', ($<blorst>.ast)<code_object>); }
method statement_prefix:sym<KEEP>($/) { make $*W.add_phaser($/, 'KEEP', ($<blorst>.ast)<code_object>); }
method statement_prefix:sym<UNDO>($/) { make $*W.add_phaser($/, 'UNDO', ($<blorst>.ast)<code_object>); }
method statement_prefix:sym<NEXT>($/) { make $*W.add_phaser($/, 'NEXT', ($<blorst>.ast)<code_object>); }
method statement_prefix:sym<LAST>($/) { make $*W.add_phaser($/, 'LAST', ($<blorst>.ast)<code_object>); }
method statement_prefix:sym<PRE>($/) { make $*W.add_phaser($/, 'PRE', ($<blorst>.ast)<code_object>, ($<blorst>.ast)<past_block>); }
method statement_prefix:sym<POST>($/) { make $*W.add_phaser($/, 'POST', ($<blorst>.ast)<code_object>, ($<blorst>.ast)<past_block>); }
method statement_prefix:sym<LAZY>($/) {
make $*W.create_lazy($/, $<blorst>.ast()<code_object>);
}
method statement_prefix:sym<DOC>($/) {
$*W.add_phaser($/, ~$<phase>, ($<blorst>.ast)<code_object>)
if %*COMPILING<%?OPTIONS><doc>;
}
method statement_prefix:sym<do>($/) {
make QAST::Op.new( :op('call'), $<blorst>.ast );
}
method statement_prefix:sym<gather>($/) {
my $past := block_closure($<blorst>.ast);
make QAST::Op.new( :op('call'), :name('&GATHER'), $past );
}
method statement_prefix:sym<sink>($/) {
my $blast := QAST::Op.new( :op('call'), $<blorst>.ast );
make QAST::Stmts.new(
QAST::Op.new( :name('&eager'), :op('call'), $blast ),
QAST::Var.new( :name('Nil'), :scope('lexical')),
:node($/)
);
}
method statement_prefix:sym<try>($/) {
my $block := $<blorst>.ast;
my $past;
if $block<past_block><handlers> && $block<past_block><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); # XXX should be immediate
$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(
:resultchild(0),
QAST::Op.new(
:op('p6store'),
QAST::Var.new(:name<$!>, :scope<lexical>),
QAST::Op.new(
:name<&EXCEPTION>, :op<call>,
QAST::Op.new( :op('exception') )
),
),
QAST::VM.new(
pirop => 'perl6_invoke_catchhandler 1PP',
QAST::Op.new( :op('null') ),
QAST::Op.new( :op('exception') )
)
)
);
}
make $past;
}
method blorst($/) {
make $<block> ?? $<block>.ast !! make_thunk_ref($<statement>.ast, $/);
}
# Statement modifiers
method modifier_expr($/) { make $<EXPR>.ast; }
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>($/) {
make QAST::Op.new( :op<if>,
QAST::Op.new( :name('ACCEPTS'), :op('callmethod'),
$<modifier_expr>.ast,
QAST::Var.new( :name('$_'), :scope('lexical') ) ),
:node($/)
);
}
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<lambda>($/) { make block_closure($<pblock>.ast); }
method term:sym<sigterm>($/) { make $<sigterm>.ast; }
method term:sym<unquote>($/) {
make QAST::Unquote.new(:position(+@*UNQUOTE_ASTS));
@*UNQUOTE_ASTS.push($<statementlist>.ast);
}
method name($/) { }
method fatarrow($/) {
make make_pair($<key>.Str, $<val>.ast);
}
method colonpair($/) {
if $*key {
if $<var> {
make make_pair($*key, make_variable($/<var>, [~$<var>]));
}
elsif $*value ~~ NQPMatch {
my $val_ast := $*value.ast;
if $val_ast.isa(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('p6bool'),
QAST::IVal.new( :value($*value) )
));
}
}
elsif $<fakesignature> {
make $<fakesignature>.ast;
}
else {
make $*value.ast;
}
}
sub make_pair($key_str, $value) {
my $key := $*W.add_string_constant($key_str);
$key.named('key');
$value.named('value');
QAST::Op.new(
:op('callmethod'), :name('new'), :returns($*W.find_symbol(['Pair'])),
QAST::Var.new( :name('Pair'), :scope('lexical') ),
$key, $value
)
}
method desigilname($/) {
if $<variable> {
make QAST::Op.new( :op('callmethod'), $<variable>.ast );
}
}
method variable($/) {
my $past;
if $<index> {
$past := QAST::Op.new(
:op('callmethod'),
:name('postcircumfix:<[ ]>'),
QAST::Var.new(:name('$/'), :scope('lexical')),
$*W.add_constant('Int', 'int', +$<index>),
);
}
elsif $<postcircumfix> {
$past := $<postcircumfix>.ast;
$past.unshift( QAST::Var.new( :name('$/'), :scope('lexical') ) );
}
elsif $<infixish> {
my $name := '&infix:<' ~ $<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 '@' ?? 'list' !!
~$<sigil> eq '%' ?? 'hash' !!
'item');
}
else {
my $indirect;
if $<desigilname> && $<desigilname><longname> {
my $longname := $*W.disect_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.variable_components(
~$<sigil>, $<twigil> ?? ~$<twigil>[0] !! ''));
}
}
else {
$past := make_variable($/, [~$/]);
}
}
make $past;
}
sub make_variable($/, @name) {
make_variable_from_parts($/, @name, $<sigil>.Str, $<twigil>[0], ~$<desigilname>);
}
sub make_variable_from_parts($/, @name, $sigil, $twigil, $desigilname) {
my $past := QAST::Var.new( :name(@name[+@name - 1]), :node($/));
if $twigil eq '*' {
$past := QAST::Op.new(
:op('call'), :name('&DYNAMIC'),
$*W.add_string_constant($past.name()));
}
elsif $twigil eq '!' {
# In a declaration, don't produce anything here.
if $*IN_DECL ne 'variable' {
unless $*HAS_SELF {
$*W.throw($/, ['X', 'Syntax', 'NoSelf'], variable => $past.name());
}
my $attr := get_attribute_meta_object($/, $past.name());
$past.scope('attribute');
$past.returns($attr.type);
$past.unshift(instantiated_type(['$?CLASS'], $/));
$past.unshift(QAST::Var.new( :name('self'), :scope('lexical') ));
}
}
elsif $twigil eq '.' && $*IN_DECL ne 'variable' {
if !$*HAS_SELF {
$*W.throw($/, ['X', 'Syntax', 'NoSelf'], variable => $past.name());
} elsif $*HAS_SELF eq 'partial' {
$*W.throw($/, ['X', 'Syntax', 'VirtualCall'], call => $past.name());
}
# Need to transform this to a method call.
$past := $<arglist> ?? $<arglist>[0].ast !! QAST::Op.new();
$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($past.name()));
}
elsif $past.name() eq '@_' {
if $*W.nearest_signatured_block_declares('@_') {
$past.scope('lexical');
}
else {
$past := add_placeholder_parameter($/, '@', '_',
:pos_slurpy(1), :full_name($past.name()));
}
}
elsif $past.name() eq '%_' {
if $*W.nearest_signatured_block_declares('%_') || $*METHODTYPE {
$past.scope('lexical');
}
else {
$past := add_placeholder_parameter($/, '%', '_', :named_slurpy(1),
:full_name($past.name()));
}
}
elsif $past.name() eq '$?LINE' || $past.name eq '$?FILE' {
if $*IN_DECL eq 'variable' {
$*W.throw($/, 'X::Syntax::Variable::Twigil',
twigil => '?',
scope => $*SCOPE,
);
}
if $past.name() eq '$?LINE' {
$past := $*W.add_constant('Int', 'int',
HLL::Compiler.lineof($/.orig, $/.from ));
}
else {
$past := $*W.add_string_constant(pir::find_caller_lex__ps('$?FILES') // '<unknown file>');
}
}
elsif +@name > 1 {
$past := $*W.symbol_lookup(@name, $/, :lvalue(1));
}
elsif $*IN_DECL ne 'variable' && (my $attr_alias := $*W.is_attr_alias($past.name)) {
$past.name($attr_alias);
$past.scope('attribute');
$past.unshift(instantiated_type(['$?CLASS'], $/));
$past.unshift(QAST::Var.new( :name('self'), :scope('lexical') ));
}
elsif $*IN_DECL ne 'variable' {
# the $*QSGIL part is a hack:
# when we parse double-quoted strings like "@a", the @a is
# first parsed as a variable, and thus checked. So it throws
# an exception even if turns out not to end in a postcircumfix
#
# I don't know what the correct solution is. Disabling the check
# inside double quotes fixes the most common case, but fails to
# catch undeclared variables in double-quoted strings.
if $sigil ne '&' && !$*IN_DECL && ($*QSIGIL eq '' || $*QSIGIL eq '$') && !$*W.is_lexical($past.name) {
$*W.throw($/, ['X', 'Undeclared'], symbol => $past.name());
}
# Expect variable to have been declared somewhere.
# Locate descriptor and thus type.
$past.scope('lexical');
try {
my $type := $*W.find_lexical_container_type($past.name);
$past.returns($type);
}
# If it's a late-bound sub lookup, we may not find it, so be sure
# to handle the case where the lookup comes back null.
if $sigil eq '&' {
$past := QAST::Op.new(
:op('ifnull'), $past,
QAST::Var.new(:name('Nil'), :scope('lexical')));
}
}
$past
}
sub get_attribute_meta_object($/, $name) {
unless nqp::can($*PACKAGE.HOW, 'get_attribute_for_usage') {
$/.CURSOR.panic("Cannot understand $name in this context");
}
my $attr;
my $found := 0;
try {
$attr := $*PACKAGE.HOW.get_attribute_for_usage($*PACKAGE, $name);
$found := 1;
}
unless $found {
$*W.throw($/, ['X', 'Attribute', 'Undeclared'],
symbol => $name,
package-kind => $*PKGDECL,
package-name => $*PACKAGE.HOW.name($*PACKAGE),
what => 'attribute',
);
}
$attr
}
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<knowhow>($/) { make $<package_def>.ast; }
method package_declarator:sym<native>($/) { make $<package_def>.ast; }
method package_declarator:sym<trusts>($/) {
$*W.apply_trait($/, '&trait_mod:<trusts>', $*PACKAGE, $<typename>.ast);
}
method package_declarator:sym<also>($/) {
for $<trait> {
if $_.ast { ($_.ast)($*DECLARAND) }
}
}
method package_def($/) {
# Get the body block PAST.
my $block;
if $<blockoid> {
$block := $<blockoid>.ast;
}
else {
$block := $*CURPAD;
$block.push($<statementlist>.ast);
$block.node($/);
}
$block.blocktype('immediate');
if $*PKGDECL ne 'role' && $block<placeholder_sig> {
my $name := $block<placeholder_sig>[0]<variable_name>;
unless $name eq '%_' || $name eq '@_' {
$name := nqp::concat_s(nqp::substr($name, 0, 1),
nqp::concat_s('^', nqp::substr($name, 1)));
}
$*W.throw( $/, ['X', 'Placeholder', 'Block'],
placeholder => $name,
);
}
# If it's a stub, add it to the "must compose at some point" list,
# then just evaluate to the type object. Don't need to do any more
# just yet.
if nqp::substr($<blockoid><statementlist><statement>[0], 0, 3) eq '...' {
unless $*PKGDECL eq 'role' {
$*W.add_stub_to_check($*PACKAGE);
}
$block.blocktype('declaration');
make QAST::Stmts.new( $block, QAST::WVal.new( :value($*PACKAGE) ) );
return 1;
}
# Handle parametricism for roles.
if $*PKGDECL eq 'role' {
# Set up signature. Needs to have $?CLASS as an implicit
# parameter, since any mention of it is generic.
my %sig_info := $<signature> ?? $<signature>[0].ast !! hash(parameters => []);
my @params := %sig_info<parameters>;
@params.unshift(hash(
is_multi_invocant => 1,
type_captures => ['$?CLASS', '::?CLASS']
));
set_default_parameter_type(@params, 'Mu');
my $sig := create_signature_object($<signature>, %sig_info, $block);
add_signature_binding_code($block, $sig, @params);
$block.blocktype('declaration');
# Need to ensure we get lexical outers fixed up properly. To
# do this we make a list of closures, which each point to the
# outer context. These surive serialization and thus point at
# what has to be fixed up.
my $throwaway_block_past := QAST::Block.new(
:blocktype('declaration'),
QAST::Var.new( :name('$_'), :scope('lexical'), :decl('var') )
);
$throwaway_block_past<outer> := $block;
$block[0].push($throwaway_block_past);
my $throwaway_block := $*W.create_code_object($throwaway_block_past,
'Block', $*W.create_signature(nqp::hash('parameters', [])));
my $fixup := $*W.create_lexical_capture_fixup();
$fixup.push(QAST::Op.new(
:op('callmethod'), :name('clone'),
QAST::WVal.new( :value($throwaway_block) )
));
$block[1].push($fixup);
# As its last act, it should grab the current lexpad so that
# we have the type environment, and also return the parametric
# role we're in (because if we land it through a multi-dispatch,
# we won't know).
$block[1].push(QAST::Op.new(
:op('list'),
QAST::WVal.new( :value($*PACKAGE) ),
QAST::Op.new( :op('curlexpad') )));
# Create code object and add it as the role's body block.
my $code := $*W.create_code_object($block, 'Sub', $sig);
$*W.pkg_set_role_body_block($/, $*PACKAGE, $code, $block);
# Compose before we add the role to the group, so the group sees
# it composed.
$*W.pkg_compose($*PACKAGE);
# Add this role to the group if needed.
my $group := $*PACKAGE.HOW.group($*PACKAGE);
unless $group =:= $*PACKAGE {
$*W.pkg_add_role_group_possibility($/, $group, $*PACKAGE);
}
}
else {
# Compose.
$*W.pkg_compose($*PACKAGE);
# Make a code object for the block.
$*W.create_code_object($block, 'Block',
$*W.create_signature(nqp::hash('parameters', [])));
}
# Document
Perl6::Pod::document($/, $*PACKAGE, $*DOC);
make QAST::Stmts.new(
$block, QAST::WVal.new( :value($*PACKAGE) )
);
}
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<anon>($/) { make $<scoped>.ast; }
method scope_declarator:sym<augment>($/) { make $<scoped>.ast; }
method scope_declarator:sym<state>($/) { make $<scoped>.ast; }
method declarator($/) {
if $<routine_declarator> { make $<routine_declarator>.ast }
elsif $<regex_declarator> { make $<regex_declarator>.ast }
elsif $<type_declarator> { make $<type_declarator>.ast }
elsif $<variable_declarator> {
my $past := $<variable_declarator>.ast;
if $<initializer> {
my $orig_past := $past;
if $*SCOPE eq 'has' {
if $<initializer>[0]<sym> eq '=' {
self.install_attr_init($<initializer>[0], $past<metaattr>,
$<initializer>[0].ast, $*ATTR_INIT_BLOCK);
}
else {
$/.CURSOR.panic("Cannot use " ~ $<initializer>[0]<sym> ~
" to initialize an attribute");
}
}
elsif $<initializer>[0]<sym> eq '=' {
$past := assign_op($/, $past, $<initializer>[0].ast);
}
elsif $<initializer>[0]<sym> eq '.=' {
$past := make_dot_equals($past, $<initializer>[0].ast);
}
else {
$past := bind_op($/, $past, $<initializer>[0].ast,
$<initializer>[0]<sym> eq '::=');
}
if $*SCOPE eq 'state' {
$past := QAST::Op.new( :op('if'),
QAST::Op.new( :op('p6stateinit') ),
$past,
$orig_past);
}
}
make $past;
}
elsif $<signature> {
# Go over the params and declare the variable defined
# in them.
my $list := QAST::Op.new( :op('call'), :name('&infix:<,>') );
my @params := $<signature>.ast<parameters>;
for @params {
if $_<variable_name> {
my $past := QAST::Var.new( :name($_<variable_name>) );
$past := declare_variable($/, $past, $_<sigil>, $_<twigil>,
$_<desigilname>, []);
unless $past.isa(QAST::Op) && $past.op eq 'null' {
$list.push($past);
}
}
else {
my %cont_info := container_type_info($/, $_<sigil> || '$', []);
$list.push($*W.build_container_past(
%cont_info,
$*W.create_container_descriptor(%cont_info<value_type>, 1, 'anon')));
}
}
if $<initializer> {
my $orig_list := $list;
if $<initializer>[0]<sym> eq '=' {
$/.CURSOR.panic("Cannot assign to a list of 'has' scoped declarations")
if $*SCOPE eq 'has';
$list := assign_op($/, $list, $<initializer>[0].ast);
}
elsif $<initializer>[0]<sym> eq '.=' {
$/.CURSOR.panic("Cannot use .= initializer with a list of declarations");
}
else {
$*W.throw($/, 'X::Comp::NYI', feature => "Binding to signatures in $*SCOPE declarations");
}
if $*SCOPE eq 'state' {
$list := QAST::Op.new( :op('if'),
QAST::Op.new( :op('p6stateinit') ),
$list, $orig_list);
}
}
make $list;
}
elsif $<identifier> {
# '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 := ~$<identifier>;
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>);
make QAST::Op.new(
:op<bind>,
QAST::Var.new(:$name, :scope<lexical>),
QAST::Op.new(
:op('p6bindassert'),
$<term_init>.ast,
QAST::WVal.new( :value($type) ),
)
);
}
else {
$cur_lexpad[0].push(QAST::Var.new(:$name, :scope('lexical'), :decl('var')));
$cur_lexpad.symbol($name, :scope('lexical'));
make QAST::Op.new(
:op<bind>,
QAST::Var.new(:$name, :scope<lexical>),
$<term_init>.ast
);
}
}
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 $<variable><desigilname> && $*W.cur_lexpad().symbol($name) {
$*W.throw($/, ['X', 'Redeclaration'], symbol => $name);
}
make declare_variable($/, $past, ~$sigil, ~$twigil, ~$<variable><desigilname>, $<trait>, $<semilist>);
}
sub declare_variable($/, $past, $sigil, $twigil, $desigilname, $trait_list, $shape?) {
my $name := $sigil ~ $twigil ~ $desigilname;
my $BLOCK := $*W.cur_lexpad();
if $*SCOPE eq 'has' {
# Ensure current package can take attributes.
unless nqp::can($*PACKAGE.HOW, 'add_attribute') {
if $*PKGDECL {
$*W.throw($/, ['X', 'Attribute', 'Package'],
package-kind => $*PKGDECL,
:$name,
);
} else {
$*W.throw($/, ['X', 'Attribute', 'NoPackage'], :$name);
}
}
# Create container descriptor and decide on any default value..
my $attrname := ~$sigil ~ '!' ~ $desigilname;
my %cont_info := container_type_info($/, $sigil, $*OFTYPE ?? [$*OFTYPE.ast] !! [], $shape);
my $descriptor := $*W.create_container_descriptor(%cont_info<value_type>, 1, $attrname);
# Create meta-attribute and add it.
my $metaattr := %*HOW{$*PKGDECL ~ '-attr'};
my $attr := $*W.pkg_add_attribute($/, $*PACKAGE, $metaattr,
hash(
name => $attrname,
has_accessor => $twigil eq '.'
),
hash(
container_descriptor => $descriptor,
type => %cont_info<bind_constraint>,
package => $*W.find_symbol(['$?CLASS'])),
%cont_info, $descriptor);
# Document it
# Perl6::Pod::document($/, $attr, $*DOC); #XXX var traits NYI
# If no twigil, note $foo is an alias to $!foo.
if $twigil eq '' {
$BLOCK.symbol($name, :attr_alias($attrname));
}
# Apply any traits.
for $trait_list {
my $applier := $_.ast;
if $applier { $applier($attr); }
}
# Nothing to emit here; hand back a Nil.
$past := QAST::Var.new(:name('Nil'), :scope('lexical'));
$past<metaattr> := $attr;
}
elsif $*SCOPE eq 'my' || $*SCOPE eq 'state' {
# Twigil handling.
if $twigil eq '.' {
add_lexical_accessor($/, $past, $desigilname, $*W.cur_lexpad());
$name := $sigil ~ $desigilname;
}
elsif $twigil eq '!' {
$*W.throw($/, ['X', 'Syntax', 'Variable', 'Twigil'],
twigil => $twigil,
scope => $*SCOPE,
);
}
# Create a container descriptor. Default to rw and set a
# type if we have one; a trait may twiddle with that later.
my %cont_info := container_type_info($/, $sigil, $*OFTYPE ?? [$*OFTYPE.ast] !! [], $shape);
my $descriptor := $*W.create_container_descriptor(%cont_info<value_type>, 1, $name);
# Install the container.
$*W.install_lexical_container($BLOCK, $name, %cont_info, $descriptor,
:state($*SCOPE eq 'state'));
# Set scope and type on container, and if needed emit code to
# reify a generic type.
if $past.isa(QAST::Var) {
$past.name($name);
$past.scope('lexical');
$past.returns(%cont_info<bind_constraint>);
if %cont_info<bind_constraint>.HOW.archetypes.generic {
$past := QAST::Op.new(
:op('callmethod'), :name('instantiate_generic'),
QAST::Op.new( :op('p6var'), $past ),
QAST::Op.new( :op('curlexpad') ));
}
}
}
elsif $*SCOPE eq 'our' {
# Twigil handling.
if $twigil eq '.' {
add_lexical_accessor($/, $past, $desigilname, $*W.cur_lexpad());
$name := $sigil ~ $desigilname;
$past.name($name);
$past.scope('lexical');
}
elsif $twigil eq '!' {
$*W.throw($/, ['X', 'Syntax', 'Variable', 'Twigil'],
twigil => $twigil,
scope => $*SCOPE,
);
}
elsif $twigil ne '*' {
$past.scope('lexical');
}
if $*OFTYPE {
$/.CURSOR.panic("Cannot put a type constraint on an 'our'-scoped variable");
}
elsif $shape {
$/.CURSOR.panic("Cannot put a shape on an 'our'-scoped variable");
}
$BLOCK[0].push(QAST::Op.new(
:op('bind'),
QAST::Var.new( :name($name), :scope('lexical'), :decl('var') ),
$*W.symbol_lookup([$name], $/, :package_only(1), :lvalue(1))));
$BLOCK.symbol($name, :scope('lexical'));
}
else {
$*W.throw($/, 'X::Comp::NYI',
feature => "$*SCOPE scoped variables");
}
return $past;
}
sub add_lexical_accessor($/, $var_past, $meth_name, $install_in) {
# Generate and install code block for accessor.
my $a_past := $*W.push_lexpad($/);
$a_past.name($meth_name);
$a_past.push($var_past);
$*W.pop_lexpad();
$install_in[0].push($a_past);
# Produce a code object and install it.
my $invocant_type := $*W.find_symbol([$*W.is_lexical('$?CLASS') ?? '$?CLASS' !! 'Mu']);
my %sig_info := hash(parameters => []);
my $code := methodize_block($/, $*W.stub_code_object('Method'),
$a_past, %sig_info, $invocant_type);
install_method($/, $meth_name, 'has', $code, $install_in);
}
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 $block;
if $<onlystar> {
$block := $<onlystar>.ast;
}
else {
$block := $<blockoid>.ast;
$block.blocktype('declaration');
if is_clearly_returnless($block) {
unless pir::repr_get_primitive_type_spec__IP($block[1].returns) {
$block[1] := QAST::Op.new(
:op('p6decontrv'),
$block[1]);
}
$block[1] := QAST::Op.new(
:op('p6typecheckrv'),
$block[1],
QAST::WVal.new( :value($*DECLARAND) ));
}
else {
$block[1] := wrap_return_handler($block[1]);
}
}
# Obtain parameters, create signature object and generate code to
# call binder.
if $block<placeholder_sig> && $<multisig> {
$*W.throw($/, ['X', 'Signature', 'Placeholder'],
placeholder => $block<placeholder_sig>[0]<placeholder>,
);
}
my %sig_info;
if $<multisig> {
%sig_info := $<multisig>[0].ast;
}
else {
%sig_info<parameters> := $block<placeholder_sig> ?? $block<placeholder_sig> !!
[];
}
my @params := %sig_info<parameters>;
set_default_parameter_type(@params, 'Any');
my $signature := create_signature_object($<multisig> ?? $<multisig>[0] !! $/, %sig_info, $block);
add_signature_binding_code($block, $signature, @params);
# Needs a slot that can hold a (potentially unvivified) dispatcher;
# if this is a multi then we'll need it to vivify to a MultiDispatcher.
if $*MULTINESS eq 'multi' {
$*W.install_lexical_symbol($block, '$*DISPATCHER', $*W.find_symbol(['MultiDispatcher']));
}
else {
add_implicit_var($block, '$*DISPATCHER');
}
$block[0].unshift(QAST::Op.new(:op('p6takedisp')));
# Set name.
if $<deflongname> {
$block.name(~$<deflongname>[0].ast);
}
# Finish code object, associating it with the routine body.
my $code := $*DECLARAND;
$*W.attach_signature($code, $signature);
$*W.finish_code_object($code, $block, $*MULTINESS eq 'proto', :yada(is_yada($/)));
# attach return type
if $*OFTYPE {
my $sig := $code.signature;
if $sig.has_returns {
my $prev_returns := $sig.returns;
$*W.throw($*OFTYPE, 'X::Redeclaration',
what => 'return type for',
symbol => $code,
postfix => " (previous return type was "
~ $prev_returns.HOW.name($prev_returns)
~ ')',
);
}
$sig.set_returns($*OFTYPE.ast);
}
# Document it
Perl6::Pod::document($/, $code, $*DOC);
# Install PAST block so that it gets capture_lex'd correctly and also
# install it in the lexpad.
my $outer := $*W.cur_lexpad();
$outer[0].push(QAST::Stmt.new($block));
# Install &?ROUTINE.
$*W.install_lexical_symbol($block, '&?ROUTINE', $code);
my $past;
if $<deflongname> {
# If it's a multi, need to associate it with the surrounding
# proto.
# XXX Also need to auto-multi things with a proto in scope.
my $name := '&' ~ ~$<deflongname>[0].ast;
if $*MULTINESS eq 'multi' {
# Do we have a proto in the current scope?
my $proto;
if $outer.symbol($name) {
$proto := $outer.symbol($name)<value>;
}
else {
unless $*SCOPE eq '' || $*SCOPE eq 'my' {
$*W.throw($/, 'X::Declaration::Scope::Multi',
scope => $*SCOPE,
declaration => 'multi',
);
}
# None; search outer scopes.
my $new_proto;
try {
$proto := $*W.find_symbol([$name]);
}
if $proto && $proto.is_dispatcher {
# Found in outer scope. Need to derive.
$new_proto := $*W.derive_dispatcher($proto);
}
else {
$new_proto := self.autogenerate_proto($/, $block.name, $outer[0]);
}
# Install in current scope.
$*W.install_lexical_symbol($outer, $name, $new_proto, :clone(1));
$proto := $new_proto;
}
# Ensure it's actually a dispatcher.
unless $proto.is_dispatcher {
$*W.throw($/, ['X', 'Redeclaration'],
what => 'routine',
symbol => ~$<deflongname>[0].ast,
);
}
# Install the candidate.
$*W.add_dispatchee_to_proto($proto, $code);
}
else {
# Install.
if $outer.symbol($name) {
$*W.throw($/, ['X', 'Redeclaration'],
symbol => ~$<deflongname>[0].ast,
what => 'routine',
);
}
if $*SCOPE eq '' || $*SCOPE eq 'my' {
$*W.install_lexical_symbol($outer, $name, $code, :clone(1));
}
elsif $*SCOPE eq 'our' {
# Install in lexpad and in package, and set up code to
# re-bind it per invocation of its outer.
$*W.install_lexical_symbol($outer, $name, $code, :clone(1));
$*W.install_package_symbol($*PACKAGE, $name, $code);
$outer[0].push(QAST::Op.new(
:op('bindkey'),
QAST::Op.new( :op('who'), QAST::WVal.new( :value($*PACKAGE) ) ),
QAST::SVal.new( :value($name) ),
QAST::Var.new( :name($name), :scope('lexical') )
));
}
elsif $*SCOPE eq 'anon' {
# don't do anything
}
else {
$*W.throw($/, 'X::Declaration::Scope',
scope => $*SCOPE,
declaration => 'sub',
);
}
}
}
elsif $*MULTINESS {
$*W.throw($/, 'X::Anon::Multi', multiness => $*MULTINESS);
}
# Apply traits.
for $<trait> -> $t {
if $t.ast { $*W.ex-handle($t, { ($t.ast)($code) }) }
}
# Add inlining information if it's inlinable; also mark soft if the
# appropriate pragma is in effect.
if $<deflongname> {
if $*SOFT {
$*W.find_symbol(['&infix:<does>'])($code, $*W.find_symbol(['SoftRoutine']));
}
else {
self.add_inlining_info_if_possible($/, $code, $block, @params);
}
}
my $closure := block_closure(reference_to_code_object($code, $past));
$closure<sink_past> := QAST::Op.new( :op('null') );
make $closure;
}
method autogenerate_proto($/, $name, $install_in) {
my $p_past := $*W.push_lexpad($/);
$p_past.name(~$name);
$p_past.push(QAST::Op.new( :op('p6multidispatch') ));
$*W.pop_lexpad();
$install_in.push(QAST::Stmt.new($p_past));
my @p_params := [hash(is_capture => 1, nominal_type => $*W.find_symbol(['Mu']) )];
my $p_sig := $*W.create_signature(nqp::hash('parameters', [$*W.create_parameter(@p_params[0])]));
add_signature_binding_code($p_past, $p_sig, @p_params);
$*W.create_code_object($p_past, 'Sub', $p_sig, 1);
}
method add_inlining_info_if_possible($/, $code, $past, @params) {
# Make sure the block has the common structure we expect
# (decls then statements).
return 0 unless +@($past) == 2;
# Ensure all parameters are simple and build placeholders for
# them.
my %arg_placeholders;
my $arg_num := 0;
for @params {
return 0 if $_<optional> || $_<is_capture> || $_<pos_slurpy> ||
$_<named_slurpy> || $_<pos_lol> || $_<bind_attr> ||
$_<bind_accessor> || $_<nominal_generic> || $_<named_names> ||
$_<type_captures> || $_<post_constraints>;
%arg_placeholders{$_<variable_name>} :=
QAST::InlinePlaceholder.new( :position($arg_num) );
$arg_num := $arg_num + 1;
}
# Ensure nothing extra is declared.
for @($past[0]) {
if nqp::istype($_, QAST::Var) && $_.scope eq 'lexical' {
my $name := $_.name;
return 0 if $name ne '$_' &&
$name ne '$/' && $name ne '$!' && $name ne '&?ROUTINE' &&
$name ne '$*DISPATCHER' && $name ne 'call_sig' &&
!nqp::existskey(%arg_placeholders, $name);
}
}
# If all is well, we try to build the QAST for inlining. This dies
# if we fail.
my $PseudoStash;
try $PseudoStash := $*W.find_symbol(['PseudoStash']);
sub clear_node($qast) {
$qast.node(nqp::null());
$qast
}
sub clone_qast($qast) {
my $cloned := pir::repr_clone__PP($qast);
nqp::bindattr($cloned, QAST::Node, '@!array',
nqp::clone(nqp::getattr($cloned, QAST::Node, '@!array')));
$cloned
}
sub node_walker($node) {
# Simple values are always fine; just return them as they are, modulo
# removing any :node(...).
if nqp::istype($node, QAST::IVal) || nqp::istype($node, QAST::SVal)
|| nqp::istype($node, QAST::NVal) {
return $node.node ?? clear_node(clone_qast($node)) !! $node;
}
# WVal is OK, though special case for PseudoStash usage (which means
# we are doing funny lookup stuff).
elsif nqp::istype($node, QAST::WVal) {
if $node.value =:= $PseudoStash {
nqp::die("Routines using pseudo-stashes are not inlinable");
}
else {
return $node.node ?? clear_node(clone_qast($node)) !! $node;
}
}
# Operations need checking for their inlinability. If they are OK in
# themselves, it comes down to the children.
elsif nqp::istype($node, QAST::Op) {
if QAST::Operations.is_inlinable('perl6', $node.op) {
my $replacement := clone_qast($node);
my $i := 0;
my $n := +@($node);
while $i < $n {
$replacement[$i] := node_walker($node[$i]);
$i := $i + 1;
}
return clear_node($replacement);
}
else {
nqp::die("Non-inlinable op '" ~ $node.op ~ "' encountered");
}
}
# Variables are fine *if* they are arguments.
elsif nqp::istype($node, QAST::Var) && ($node.scope eq 'lexical' || $node.scope eq '') {
if nqp::existskey(%arg_placeholders, $node.name) {
my $replacement := %arg_placeholders{$node.name};
if $node.named || $node.flat {
$replacement := clone_qast($replacement);
if $node.named { $replacement.named($node.named) }
if $node.flat { $replacement.flat($node.flat) }
}
return $replacement;
}
else {
nqp::die("Cannot inline with non-argument variables");
}
}
# Statements need to be cloned and then each of the nodes below them
# visited.
elsif nqp::istype($node, QAST::Stmt) || nqp::istype($node, QAST::Stmts) {
my $replacement := clone_qast($node);
my $i := 0;
my $n := +@($node);
while $i < $n {
$replacement[$i] := node_walker($node[$i]);
$i := $i + 1;
}
return clear_node($replacement);
}
# Want nodes need copying and every other child visiting.
elsif nqp::istype($node, QAST::Want) {
my $replacement := clone_qast($node);
my $i := 0;
my $n := +@($node);
while $i < $n {
$replacement[$i] := node_walker($node[$i]);
$i := $i + 2;
}
return clear_node($replacement);
}
# Otherwise, we don't know what to do with it.
else {
nqp::die("Unhandled node type; won't inline");
}
};
my $inline_info;
try $inline_info := node_walker($past[1]);
return 0 unless nqp::istype($inline_info, QAST::Node);
# Attach inlining information.
$*W.apply_trait($/, '&trait_mod:<is>', $code, inlinable => $inline_info)
}
method method_def($/) {
my $past;
if $<onlystar> {
$past := $<onlystar>.ast;
}
else {
$past := $<blockoid>.ast;
$past.blocktype('declaration');
if is_clearly_returnless($past) {
$past[1] := QAST::Op.new(
:op('p6typecheckrv'),
QAST::Op.new( :op('p6decontrv'), $past[1]),
QAST::WVal.new( :value($*DECLARAND) ));
}
else {
$past[1] := wrap_return_handler($past[1]);
}
}
my $name;
if $<longname> {
$name := $<longname>.Str;
}
elsif $<sigil> {
if $<sigil> eq '@' { $name := 'postcircumfix:<[ ]>' }
elsif $<sigil> eq '%' { $name := 'postcircumfix:<{ }>' }
elsif $<sigil> eq '&' { $name := 'postcircumfix:<( )>' }
else {
$/.CURSOR.panic("Cannot use " ~ $<sigil> ~ " sigil as a method name");
}
}
$past.name($name ?? $name !! '<anon>');
# Do the various tasks to trun the block into a method code object.
my %sig_info := $<multisig> ?? $<multisig>[0].ast !! hash(parameters => []);
my $inv_type := $*W.find_symbol([
$<longname> && $*W.is_lexical('$?CLASS') ?? '$?CLASS' !! 'Mu']);
my $code := methodize_block($/, $*DECLARAND, $past, %sig_info, $inv_type, :yada(is_yada($/)));
# Document it
Perl6::Pod::document($/, $code, $*DOC);
# Install &?ROUTINE.
$*W.install_lexical_symbol($past, '&?ROUTINE', $code);
# Install PAST block so that it gets capture_lex'd correctly.
my $outer := $*W.cur_lexpad();
$outer[0].push($past);
# Apply traits.
for $<trait> {
if $_.ast { ($_.ast)($code) }
}
# Install method.
if $name {
install_method($/, $name, $*SCOPE, $code, $outer,
:private($<specials> && ~$<specials> eq '!'));
}
elsif $*MULTINESS {
$*W.throw($/, 'X::Anon::Multi',
multiness => $*MULTINESS,
routine-type => 'method',
);
}
my $closure := block_closure(reference_to_code_object($code, $past));
$closure<sink_past> := QAST::Op.new( :op('null') );
make $closure;
}
method macro_def($/) {
my $block;
$block := $<blockoid>.ast;
$block.blocktype('declaration');
if is_clearly_returnless($block) {
$block[1] := QAST::Op.new(
:op('p6decontrv'),
$block[1]);
}
else {
$block[1] := wrap_return_handler($block[1]);
}
# Obtain parameters, create signature object and generate code to
# call binder.
if $block<placeholder_sig> && $<multisig> {
$*W.throw($/, 'X::Signature::Placeholder',
placeholder => $block<placeholder_sig>[0]<placeholder>,
);
}
my %sig_info;
if $<multisig> {
%sig_info := $<multisig>[0].ast;
}
else {
%sig_info<parameters> := $block<placeholder_sig> ?? $block<placeholder_sig> !!
[];
}
my @params := %sig_info<parameters>;
set_default_parameter_type(@params, 'Any');
my $signature := create_signature_object($<multisig> ?? $<multisig>[0] !! $/, %sig_info, $block);
add_signature_binding_code($block, $signature, @params);
# Finish code object, associating it with the routine body.
if $<deflongname> {
$block.name(~$<deflongname>[0].ast);
}
my $code := $*DECLARAND;
$*W.attach_signature($code, $signature);
$*W.finish_code_object($code, $block, $*MULTINESS eq 'proto');
# Document it
Perl6::Pod::document($/, $code, $*DOC);
# Install PAST block so that it gets capture_lex'd correctly and also
# install it in the lexpad.
my $outer := $*W.cur_lexpad();
$outer[0].push(QAST::Stmt.new($block));
# Install &?ROUTINE.
$*W.install_lexical_symbol($block, '&?ROUTINE', $code);
my $past;
if $<deflongname> {
my $name := '&' ~ ~$<deflongname>[0].ast;
# Install.
if $outer.symbol($name) {
$/.CURSOR.panic("Illegal redeclaration of macro '" ~
~$<deflongname>[0].ast ~ "'");
}
if $*SCOPE eq '' || $*SCOPE eq 'my' {
$*W.install_lexical_symbol($outer, $name, $code);
}
elsif $*SCOPE eq 'our' {
# Install in lexpad and in package, and set up code to
# re-bind it per invocation of its outer.
$*W.install_lexical_symbol($outer, $name, $code);
$*W.install_package_symbol($*PACKAGE, $name, $code);
$outer[0].push(QAST::Op.new(
:op('bind'),
$*W.symbol_lookup([$name], $/, :package_only(1)),
QAST::Var.new( :name($name), :scope('lexical') )
));
}
else {
$/.CURSOR.panic("Cannot use '$*SCOPE' scope with a macro");
}
}
elsif $*MULTINESS {
$/.CURSOR.panic('Cannot put ' ~ $*MULTINESS ~ ' on anonymous macro');
}
# Apply traits.
for $<trait> {
if $_.ast { ($_.ast)($code) }
}
my $closure := block_closure(reference_to_code_object($code, $past));
$closure<sink_past> := QAST::Op.new( :op('null') );
make $closure;
}
sub methodize_block($/, $code, $past, %sig_info, $invocant_type, :$yada) {
# Get signature and ensure it has an invocant and *%_.
my @params := %sig_info<parameters>;
if $past<placeholder_sig> {
$/.CURSOR.panic('Placeholder variables cannot be used in a method');
}
unless @params[0]<is_invocant> {
@params.unshift(hash(
nominal_type => $invocant_type,
is_invocant => 1,
is_multi_invocant => 1
));
}
unless @params[+@params - 1]<named_slurpy> {
@params.push(hash(
variable_name => '%_',
nominal_type => $*W.find_symbol(['Mu']),
named_slurpy => 1,
is_multi_invocant => 1,
is_method_named_slurpy => 1
));
$past[0].unshift(QAST::Var.new( :name('%_'), :scope('lexical'), :decl('var') ));
$past.symbol('%_', :scope('lexical'), :lazyinit(1));
}
set_default_parameter_type(@params, 'Any');
my $signature := create_signature_object($/, %sig_info, $past);
add_signature_binding_code($past, $signature, @params);
# Place to store invocant.
$past[0].unshift(QAST::Var.new( :name('self'), :scope('lexical'), :decl('var') ));
$past.symbol('self', :scope('lexical'));
# Needs a slot to hold a multi or method dispatcher.
$*W.install_lexical_symbol($past, '$*DISPATCHER',
$*W.find_symbol([$*MULTINESS eq 'multi' ?? 'MultiDispatcher' !! 'MethodDispatcher']));
$past[0].unshift(QAST::Op.new(:op('p6takedisp')));
# Finish up code object.
$*W.attach_signature($code, $signature);
$*W.finish_code_object($code, $past, $*MULTINESS eq 'proto', :yada($yada));
return $code;
}
# Installs a method into the various places it needs to go.
sub install_method($/, $name, $scope, $code, $outer, :$private) {
# Ensure that current package supports methods, and if so
# add the method.
my $meta_meth;
if $private {
if $*MULTINESS { $/.CURSOR.panic("Private multi-methods are not supported"); }
$meta_meth := 'add_private_method';
}
else {
$meta_meth := $*MULTINESS eq 'multi' ?? 'add_multi_method' !! 'add_method';
}
if $scope ne 'anon' && nqp::can($*PACKAGE.HOW, $meta_meth) {
$*W.pkg_add_method($/, $*PACKAGE, $meta_meth, $name, $code);
}
elsif $scope eq '' || $scope eq 'has' {
my $nocando := $*MULTINESS eq 'multi' ?? 'multi-method' !! 'method';
pir::printerr__vS("Useless declaration of a has-scoped $nocando in " ~
($*PKGDECL || "mainline") ~ "\n");
}
# May also need it in lexpad and/or package.
if $*SCOPE eq 'my' {
$*W.install_lexical_symbol($outer, '&' ~ $name, $code, :clone(1));
}
elsif $*SCOPE eq 'our' {
$*W.install_lexical_symbol($outer, '&' ~ $name, $code, :clone(1));
$*W.install_package_symbol($*PACKAGE, '&' ~ $name, $code);
}
}
sub is_clearly_returnless($block) {
sub returnless_past($past) {
return 0 unless
# It's a simple operation.
nqp::istype($past, QAST::Op)
&& QAST::Operations.is_inlinable('perl6', $past.op) ||
# Just a variable lookup.
nqp::istype($past, QAST::Var) ||
# Just a QAST::Want
nqp::istype($past, QAST::Want) ||
# Just a primitive or world value.
nqp::istype($past, QAST::WVal) ||
nqp::istype($past, QAST::IVal) ||
nqp::istype($past, QAST::NVal) ||
nqp::istype($past, QAST::SVal);
for @($past) {
if nqp::istype($_, QAST::Node) {
if !returnless_past($_) {
return 0;
}
}
}
1;
}
# Only analyse things with a single simple statement.
if +$block[1].list == 1 && nqp::istype($block[1][0], QAST::Stmt) && +$block[1][0].list == 1 {
# Ensure there's no nested blocks.
for @($block[0]) {
if nqp::istype($_, QAST::Block) { return 0; }
if nqp::istype($_, QAST::Stmts) {
for @($_) {
if nqp::istype($_, QAST::Block) { return 0; }
}
}
}
# Ensure that the PAST is whitelisted things.
returnless_past($block[1][0][0])
}
else {
0
}
}
sub is_yada($/) {
if $<blockoid><statementlist> && +$<blockoid><statementlist><statement> == 1 {
my $btxt := ~$<blockoid><statementlist><statement>[0];
if $btxt ~~ /^ \s* ['...'|'???'|'!!!'] \s* $/ {
return 1;
}
}
0
}
method onlystar($/) {
my $BLOCK := $*CURPAD;
$BLOCK.push(QAST::Op.new( :op('p6multidispatch') ));
$BLOCK.node($/);
make $BLOCK;
}
method regex_declarator:sym<regex>($/, $key?) {
make $<regex_def>.ast;
}
method regex_declarator:sym<token>($/, $key?) {
make $<regex_def>.ast;
}
method regex_declarator:sym<rule>($/, $key?) {
make $<regex_def>.ast;
}
method regex_def($/) {
my $coderef;
my $name := ~%*RX<name>;
my %sig_info := $<signature> ?? $<signature>[0].ast !! hash(parameters => []);
if $*MULTINESS eq 'proto' {
unless $<onlystar> {
$/.CURSOR.panic("Proto regex body must be \{*\} (or <*> or <...>, which are deprecated)");
}
my $proto_body := QAST::Op.new(
:op('callmethod'), :name('!protoregex'),
QAST::Var.new( :name('self'), :scope('local') ),
QAST::SVal.new( :value($name) ));
$coderef := regex_coderef($/, $*DECLARAND, $proto_body, $*SCOPE, $name, %sig_info, $*CURPAD, $<trait>, :proto(1));
} else {
$coderef := regex_coderef($/, $*DECLARAND, $<p6regex>.ast, $*SCOPE, $name, %sig_info, $*CURPAD, $<trait>);
}
# Return closure if not in sink context.
my $closure := block_closure($coderef);
$closure<sink_past> := QAST::Op.new( :op('null') );
make $closure;
}
sub regex_coderef($/, $code, $qast, $scope, $name, %sig_info, $block, $traits?, :$proto, :$use_outer_match) {
# create a code reference from a regex qast tree
my $past;
if $proto {
$block[1] := $qast;
$past := $block;
}
else {
$block[0].push(QAST::Var.new(:name<$¢>, :scope<lexical>, :decl('var')));
$block.symbol('', :scope<lexical>);
unless $use_outer_match {
$block[0].push(QAST::Var.new(:name<$/>, :scope<lexical>, :decl('var')));
$block.symbol('$/', :scope<lexical>, :lazyinit(1));
}
$past := QRegex::P6Regex::Actions::qbuildsub($qast, $block);
}
$past.name($name);
$past.blocktype("declaration");
# Install a $?REGEX (mostly for the benefit of <~~>).
$block[0].push(QAST::Op.new(
:op('bind'),
QAST::Var.new(:name<$?REGEX>, :scope<lexical>, :decl('var')),
QAST::Op.new(
:op('p6vmcodetoobj'),
QAST::Op.new( :op('curcode') )
)));
$block.symbol('$?REGEX', :scope<lexical>);
# Do the various tasks to turn the block into a method code object.
my $inv_type := $*W.find_symbol([ # XXX Maybe Cursor below, not Mu...
$name && $*W.is_lexical('$?CLASS') ?? '$?CLASS' !! 'Mu']);
methodize_block($/, $code, $past, %sig_info, $inv_type);
# Need to put self into a register for the regex engine.
$past[0].push(QAST::Op.new(
:op('bind'),
QAST::Var.new( :name('self'), :scope('local'), :decl('var') ),
QAST::Var.new( :name('self'), :scope('lexical') )));
# Install PAST block so that it gets capture_lex'd correctly.
my $outer := $*W.cur_lexpad();
$outer[0].push($past);
# Apply traits.
if $traits {
for $traits {
if $_.ast { ($_.ast)($code) }
}
}
# Install in needed scopes.
install_method($/, $name, $scope, $code, $outer) if $name ne '';
# Return a reference to the code object
reference_to_code_object($code, $past);
}
method type_declarator:sym<enum>($/) {
# If it's an anonymous enum, just call anonymous enum former
# and we're done.
unless $<longname> || $<variable> {
make QAST::Op.new( :op('call'), :name('&ANON_ENUM'), $<term>.ast );
return 1;
}
# Get, or find, enumeration base type and create type object with
# correct base type.
my $longname := $<longname> ?? $*W.disect_longname($<longname>) !! 0;
my $name := $<longname> ?? $longname.name() !! $<variable><desigilname>;
my $type_obj;
my sub make_type_obj($base_type) {
$type_obj := $*W.pkg_create_mo($/, %*HOW<enum>, :$name, :$base_type);
# Add roles (which will provide the enum-related methods).
$*W.apply_trait($/, '&trait_mod:<does>', $type_obj, $*W.find_symbol(['Enumeration']));
if istype($type_obj, $*W.find_symbol(['Numeric'])) {
$*W.apply_trait($/, '&trait_mod:<does>', $type_obj, $*W.find_symbol(['NumericEnumeration']));
}
if istype($type_obj, $*W.find_symbol(['Stringy'])) {
$*W.apply_trait($/, '&trait_mod:<does>', $type_obj, $*W.find_symbol(['StringyEnumeration']));
}
# Apply traits, compose and install package.
for $<trait> {
($_.ast)($type_obj) if $_.ast;
}
$*W.pkg_compose($type_obj);
}
my $base_type;
my $has_base_type;
if $*OFTYPE {
$base_type := $*OFTYPE.ast;
$has_base_type := 1;
make_type_obj($base_type);
}
if $<variable> {
$*W.throw($/, 'X::Comp::NYI',
feature => "Variable case of enums",
);
}
# Get list of either values or pairs; fail if we can't.
my $Pair := $*W.find_symbol(['Pair']);
my @values;
my $term_ast := $<term>.ast;
if $term_ast.isa(QAST::Stmts) && +@($term_ast) == 1 {
$term_ast := $term_ast[0];
}
if $term_ast.isa(QAST::Op) && $term_ast.name eq '&infix:<,>' {
for @($term_ast) {
if istype($_.returns(), $Pair) && $_[1].has_compile_time_value {
@values.push($_);
}
elsif $_.has_compile_time_value {
@values.push($_);
}
else {
@values.push($*W.compile_time_evaluate($<term>, $_));
}
}
}
elsif $term_ast.has_compile_time_value {
@values.push($term_ast);
}
elsif istype($term_ast.returns, $Pair) && $term_ast[1].has_compile_time_value {
@values.push($term_ast);
}
else {
@values.push($*W.compile_time_evaluate($<term>, $<term>.ast));
}
# Now we have them, we can go about computing the value
# for each of the keys, unless they have them supplied.
# XXX Should not assume integers, and should use lexically
# scoped &postfix:<++> or so.
my $cur_value := nqp::box_i(-1, $*W.find_symbol(['Int']));
for @values {
# If it's a pair, take that as the value; also find
# key.
my $cur_key;
if istype($_.returns(), $Pair) {
$cur_key := $_[1].compile_time_value;
if $_[2].has_compile_time_value {
$cur_value := $_[2].compile_time_value;
}
else {
my $ok;
try {
$cur_value := Perl6::ConstantFolder.fold(
$_[2], $*W.cur_lexpad(), $*W
).compile_time_value;
$ok := 1;
}
unless $ok {
$cur_value := $*W.compile_time_evaluate($<term>, $_[2]);
}
}
if $has_base_type {
unless istype($cur_value, $base_type) {
$/.CURSOR.panic("Type error in enum. Got '"
~ $cur_value.HOW.name($cur_value)
~ "' Expected: '"
~ $base_type.HOW.name($base_type)
~ "'"
);
}
}
else {
$base_type := $cur_value.WHAT;
$has_base_type := 1;
make_type_obj($base_type);
}
}
else {
unless $has_base_type {
$base_type := $*W.find_symbol(['Int']);
make_type_obj($base_type);
$has_base_type := 1;
}
$cur_key := $_.compile_time_value;
$cur_value := $cur_value.succ();
}
# Create and install value.
my $val_obj := $*W.create_enum_value($type_obj, $cur_key, $cur_value);
$*W.install_package_symbol($type_obj, nqp::unbox_s($cur_key), $val_obj);
if $*SCOPE ne 'anon' {
$*W.install_lexical_symbol($*W.cur_lexpad(), nqp::unbox_s($cur_key), $val_obj);
}
if $*SCOPE eq '' || $*SCOPE eq 'our' {
$*W.install_package_symbol($*PACKAGE, nqp::unbox_s($cur_key), $val_obj);
}
}
# create a type object even for empty enums
make_type_obj($*W.find_symbol(['Int'])) unless $has_base_type;
$*W.install_package($/, $longname.type_name_parts('enum name', :decl(1)),
($*SCOPE || 'our'), 'enum', $*PACKAGE, $*W.cur_lexpad(), $type_obj);
# We evaluate to the enum type object.
make QAST::WVal.new( :value($type_obj) );
}
method type_declarator:sym<subset>($/) {
# We refine Any by default; "of" may override.
my $refinee := $*W.find_symbol(['Any']);
# If we have a refinement, make sure it's thunked if needed. If none,
# just always true.
my $refinement := make_where_block($<EXPR> ?? $<EXPR>[0].ast !!
QAST::Op.new( :op('p6bool'), QAST::IVal.new( :value(1) ) ));
# Create the meta-object.
my $longname := $<longname> ?? $*W.disect_longname($<longname>[0]) !! 0;
my $subset := $<longname> ??
$*W.create_subset(%*HOW<subset>, $refinee, $refinement, :name($longname.name())) !!
$*W.create_subset(%*HOW<subset>, $refinee, $refinement);
# Apply traits.
for $<trait> {
($_.ast)($subset) if $_.ast;
}
# Install it as needed.
if $<longname> && $longname.type_name_parts('subset name', :decl(1)) {
$*W.install_package($/, $longname.type_name_parts('subset name', :decl(1)),
($*SCOPE || 'our'), 'subset', $*PACKAGE, $*W.cur_lexpad(), $subset);
}
# We evaluate to the refinement type object.
make QAST::WVal.new( :value($subset) );
}
method type_declarator:sym<constant>($/) {
# Get constant value.
my $con_block := $*W.pop_lexpad();
my $value_ast := $<initializer>.ast;
my $value;
if $value_ast.has_compile_time_value {
$value := $value_ast.compile_time_value;
}
else {
$con_block.push($value_ast);
my $value_thunk := $*W.create_simple_code_object($con_block, 'Block');
$value := $value_thunk();
$*W.add_constant_folded_result($value);
}
# Provided it's named, install it.
my $name;
if $<identifier> {
$name := ~$<identifier>;
}
elsif $<variable> {
# Don't handle twigil'd case yet.
if $<variable><twigil> {
$*W.throw($/, 'X::Comp::NYI',
feature => "Twigil-Variable constants"
);
}
$name := ~$<variable>;
}
if $name {
$*W.install_package($/, [$name], ($*SCOPE || 'our'),
'constant', $*PACKAGE, $*W.cur_lexpad(), $value);
}
# Evaluate to the constant.
make QAST::WVal.new( :value($value) );
}
method initializer:sym<=>($/) {
make $<EXPR>.ast;
}
method initializer:sym<:=>($/) {
make $<EXPR>.ast;
}
method initializer:sym<::=>($/) {
make $<EXPR>.ast;
}
method initializer:sym<.=>($/) {
make $<dottyopish><term>.ast;
}
method capterm($/) {
# Construct a Parcel, and then call .Capture to coerce it to a capture.
my $past := $<termish> ?? $<termish>.ast !!
$<capture> ?? $<capture>[0].ast !!
QAST::Op.new( :op('call'), :name('&infix:<,>') );
unless $past.isa(QAST::Op) && $past.name eq '&infix:<,>' {
$past := QAST::Op.new( :op('call'), :name('&infix:<,>'), $past );
}
make QAST::Op.new( :op('callmethod'), :name('Capture'), $past);
}
method capture($/) {
make $<EXPR>.ast;
}
method multisig($/) {
make $<signature>.ast;
}
method fakesignature($/) {
my %sig_info := $<signature>.ast;
my @params := %sig_info<parameters>;
set_default_parameter_type(@params, 'Mu');
my $sig := create_signature_object($/, %sig_info, $*FAKE_PAD, :no_attr_check(1));
make QAST::WVal.new( :value($sig) );
}
method signature($/) {
# Fix up parameters with flags according to the separators.
# TODO: Handle $<typename>, which contains the return type declared
# with the --> syntax.
my %signature;
my @parameter_infos;
my $param_idx := 0;
my $multi_invocant := 1;
for $<parameter> {
my %info := $_.ast;
%info<is_multi_invocant> := $multi_invocant;
my $sep := @*seps[$param_idx];
if ~$sep eq ':' {
if $param_idx != 0 {
$*W.throw($/, 'X::Syntax::Signature::InvocantMarker')
}
%info<is_invocant> := 1;
}
elsif ~$sep eq ';;' {
$multi_invocant := 0;
}
@parameter_infos.push(%info);
$param_idx := $param_idx + 1;
}
%signature<parameters> := @parameter_infos;
if $<typename> {
%signature<returns> := $<typename>[0].ast;
}
# Mark current block as having a signature.
$*W.mark_cur_lexpad_signatured();
# Result is set of parameter descriptors.
make %signature;
}
method parameter($/) {
# Sanity checks.
my $quant := $<quant>;
if $<default_value> {
my $name := %*PARAM_INFO<variable_name> // '';
if $quant eq '*' {
$*W.throw($/, ['X', 'Parameter', 'Default'], how => 'slurpy',
parameter => $name);
}
if $quant eq '!' {
$*W.throw($/, ['X', 'Parameter', 'Default'], how => 'required',
parameter => $name);
}
my $val := $<default_value>[0].ast;
if $val.has_compile_time_value {
%*PARAM_INFO<default_value> := $val.compile_time_value;
%*PARAM_INFO<default_is_literal> := 1;
}
else {
%*PARAM_INFO<default_value> :=
$*W.create_thunk($<default_value>[0], $val);
}
}
# Set up various flags.
%*PARAM_INFO<pos_slurpy> := $quant eq '*' && %*PARAM_INFO<sigil> eq '@';
%*PARAM_INFO<pos_lol> := $quant eq '**' && %*PARAM_INFO<sigil> eq '@';
%*PARAM_INFO<named_slurpy> := $quant eq '*' && %*PARAM_INFO<sigil> eq '%';
%*PARAM_INFO<optional> := $quant eq '?' || $<default_value> || ($<named_param> && $quant ne '!');
%*PARAM_INFO<is_parcel> := $quant eq '\\';
%*PARAM_INFO<is_capture> := $quant eq '|';
# Stash any traits.
%*PARAM_INFO<traits> := $<trait>;
# Result is the parameter info hash.
make %*PARAM_INFO;
}
method param_var($/) {
if $<signature> {
if nqp::existskey(%*PARAM_INFO, 'sub_signature_params') {
$/.CURSOR.panic('Cannot have more than one sub-signature for a parameter');
}
%*PARAM_INFO<sub_signature_params> := $<signature>.ast;
if nqp::substr(~$/, 0, 1) eq '[' {
%*PARAM_INFO<sigil> := '@';
%*PARAM_INFO<nominal_type> := $*W.find_symbol(['Positional']);
}
}
else {
# Set name, if there is one.
if $<name> {
%*PARAM_INFO<variable_name> := ~$/;
%*PARAM_INFO<desigilname> := ~$<name>[0];
}
%*PARAM_INFO<sigil> := my $sigil := ~$<sigil>;
# Depending on sigil, use appropriate role.
my $need_role;
my $role_type;
if $sigil eq '@' {
$role_type := $*W.find_symbol(['Positional']);
$need_role := 1;
}
elsif $sigil eq '%' {
$role_type := $*W.find_symbol(['Associative']);
$need_role := 1;
}
elsif $sigil eq '&' {
$role_type := $*W.find_symbol(['Callable']);
$need_role := 1;
}
if $need_role {
if nqp::existskey(%*PARAM_INFO, 'nominal_type') {
%*PARAM_INFO<nominal_type> := $*W.parameterize_type_with_args(
$role_type, [%*PARAM_INFO<nominal_type>], nqp::hash());
}
else {
%*PARAM_INFO<nominal_type> := $role_type;
}
}
# Handle twigil.
my $twigil := $<twigil> ?? ~$<twigil>[0] !! '';
%*PARAM_INFO<twigil> := $twigil;
if $twigil eq '' || $twigil eq '*' {
# Need to add the name.
if $<name> {
self.declare_param($/, ~$/);
}
}
elsif $twigil eq '!' {
%*PARAM_INFO<bind_attr> := 1;
%*PARAM_INFO<attr_package> := $*PACKAGE;
}
elsif $twigil eq '.' {
%*PARAM_INFO<bind_accessor> := 1;
if $<name> {
%*PARAM_INFO<variable_name> := ~$<name>[0];
}
else {
$/.CURSOR.panic("Cannot declare $. parameter in signature without an accessor name");
}
}
else {
if $twigil eq ':' {
$*W.throw($/, ['X', 'Parameter', 'Placeholder'],
parameter => ~$/,
right => ':' ~ $<sigil> ~ ~$<name>[0],
);
}
else {
$*W.throw($/, ['X', 'Parameter', 'Twigil'],
parameter => ~$/,
twigil => $twigil,
);
}
}
}
}
method declare_param($/, $name) {
my $cur_pad := $*W.cur_lexpad();
if $cur_pad.symbol($name) {
$*W.throw($/, ['X', 'Redeclaration'], symbol => $name);
}
if nqp::existskey(%*PARAM_INFO, 'nominal_type') {
$cur_pad[0].push(QAST::Var.new( :$name, :scope('lexical'),
:decl('var'), :returns(%*PARAM_INFO<nominal_type>) ));
%*PARAM_INFO<container_descriptor> := $*W.create_container_descriptor(
%*PARAM_INFO<nominal_type>, 0, %*PARAM_INFO<variable_name>);
$cur_pad.symbol(%*PARAM_INFO<variable_name>, :descriptor(%*PARAM_INFO<container_descriptor>),
:type(%*PARAM_INFO<nominal_type>));
} else {
$cur_pad[0].push(QAST::Var.new( :name(~$/), :scope('lexical'), :decl('var') ));
}
$cur_pad.symbol($name, :scope('lexical'));
}
method named_param($/) {
%*PARAM_INFO<named_names> := %*PARAM_INFO<named_names> || [];
if $<name> { %*PARAM_INFO<named_names>.push(~$<name>); }
elsif $<param_var><name> { %*PARAM_INFO<named_names>.push(~$<param_var><name>[0]); }
else { %*PARAM_INFO<named_names>.push(''); }
}
method defterm($/) {
my $name := ~$<identifier>;
%*PARAM_INFO<variable_name> := $name;
%*PARAM_INFO<desigilname> := $name;
%*PARAM_INFO<sigil> := '';
self.declare_param($/, $name);
}
method default_value($/) {
make $<EXPR>.ast;
}
method type_constraint($/) {
if $<typename> {
if nqp::substr(~$<typename>, 0, 2) eq '::' && nqp::substr(~$<typename>, 2, 1) ne '?' {
# Set up signature so it will find the typename.
my $desigilname := nqp::substr(~$<typename>, 2);
unless %*PARAM_INFO<type_captures> {
%*PARAM_INFO<type_captures> := []
}
%*PARAM_INFO<type_captures>.push($desigilname);
# Install type variable in the static lexpad. Of course,
# we'll find the real thing at runtime, but in the static
# view it's a type variable to be reified.
$*W.install_lexical_symbol($*W.cur_lexpad(), $desigilname,
$<typename>.ast);
}
else {
if nqp::existskey(%*PARAM_INFO, 'nominal_type') {
$*W.throw($/, ['X', 'Parameter', 'MultipleTypeConstraints'],
parameter => (%*PARAM_INFO<variable_name> // ''),
);
}
my $type := $<typename>.ast;
if nqp::isconcrete($type) {
# Actual a value that parses type-ish.
%*PARAM_INFO<nominal_type> := $type.WHAT;
unless %*PARAM_INFO<post_constraints> {
%*PARAM_INFO<post_constraints> := [];
}
%*PARAM_INFO<post_constraints>.push($type);
}
elsif $type.HOW.archetypes.nominal {
%*PARAM_INFO<nominal_type> := $type;
}
elsif $type.HOW.archetypes.generic {
%*PARAM_INFO<nominal_type> := $type;
%*PARAM_INFO<nominal_generic> := 1;
}
elsif $type.HOW.archetypes.nominalizable {
my $nom := $type.HOW.nominalize($type);
%*PARAM_INFO<nominal_type> := $nom;
unless %*PARAM_INFO<post_constraints> {
%*PARAM_INFO<post_constraints> := [];
}
%*PARAM_INFO<post_constraints>.push($type);
}
else {
$/.CURSOR.panic("Type " ~ ~$<typename><longname> ~
" cannot be used as a nominal type on a parameter");
}
for ($<typename><longname> ?? $<typename><longname><colonpair> !! $<typename><colonpair>) {
if $_<identifier> {
if $_<identifier>.Str eq 'D' {
%*PARAM_INFO<defined_only> := 1;
}
elsif $_<identifier>.Str eq 'U' {
%*PARAM_INFO<undefined_only> := 1;
}
}
}
}
}
elsif $<value> {
if nqp::existskey(%*PARAM_INFO, 'nominal_type') {
$*W.throw($/, ['X', 'Parameter', 'MultipleTypeConstraints'],
parameter => (%*PARAM_INFO<variable_name> // ''),
);
}
my $ast := $<value>.ast;
unless $ast.has_compile_time_value {
$/.CURSOR.panic('Cannot use a value type constraints whose value is unknown at compile time');
}
my $val := $ast.compile_time_value;
%*PARAM_INFO<nominal_type> := $val.WHAT;
unless %*PARAM_INFO<post_constraints> {
%*PARAM_INFO<post_constraints> := [];
}
%*PARAM_INFO<post_constraints>.push($val);
}
else {
$/.CURSOR.panic('Cannot do non-typename cases of type_constraint yet');
}
}
method post_constraint($/) {
if $<signature> {
if nqp::existskey(%*PARAM_INFO, 'sub_signature_params') {
$/.CURSOR.panic('Cannot have more than one sub-signature for a parameter');
}
%*PARAM_INFO<sub_signature_params> := $<signature>.ast;
if nqp::substr(~$/, 0, 1) eq '[' {
%*PARAM_INFO<sigil> := '@';
}
}
else {
unless %*PARAM_INFO<post_constraints> {
%*PARAM_INFO<post_constraints> := [];
}
%*PARAM_INFO<post_constraints>.push(make_where_block($<EXPR>.ast));
}
}
# Sets the default parameter type for a signature.
sub set_default_parameter_type(@parameter_infos, $type_name) {
my $type := $*W.find_symbol([$type_name]);
for @parameter_infos {
unless nqp::existskey($_, 'nominal_type') {
$_<nominal_type> := $type;
}
if nqp::existskey($_, 'sub_signature_params') {
set_default_parameter_type($_<sub_signature_params><parameters>, $type_name);
}
}
}
# Create Parameter objects, along with container descriptors
# if needed. Parameters will be bound into the specified
# lexpad.
sub create_signature_object($/, %signature_info, $lexpad, :$no_attr_check) {
my @parameters;
my %seen_names;
for %signature_info<parameters> {
# Check we don't have duplicated named parameter names.
if $_<named_names> {
for $_<named_names> {
if %seen_names{$_} {
$*W.throw($/, ['X', 'Signature', 'NameClash'],
name => $_
);
}
%seen_names{$_} := 1;
}
}
# If it's !-twigil'd, ensure the attribute it mentions exists unless
# we're in a context where we should not do that.
if $_<bind_attr> && !$no_attr_check {
get_attribute_meta_object($/, $_<variable_name>);
}
# If we have a sub-signature, create that.
if nqp::existskey($_, 'sub_signature_params') {
$_<sub_signature> := create_signature_object($/, $_<sub_signature_params>, $lexpad);
}
# Add variable as needed.
if $_<variable_name> {
my %sym := $lexpad.symbol($_<variable_name>);
if +%sym && !nqp::existskey(%sym, 'descriptor') {
$_<container_descriptor> := $*W.create_container_descriptor(
$_<nominal_type>, $_<is_rw> ?? 1 !! 0, $_<variable_name>);
$lexpad.symbol($_<variable_name>, :descriptor($_<container_descriptor>));
}
}
# Create parameter object and apply any traits.
my $param_obj := $*W.create_parameter($_);
for $_<traits> {
($_.ast)($param_obj) if $_.ast;
}
# Add it to the signature.
@parameters.push($param_obj);
}
%signature_info<parameters> := @parameters;
$*W.create_signature(%signature_info)
}
method trait($/) {
make $<trait_mod> ?? $<trait_mod>.ast !! $<colonpair>.ast;
}
method trait_mod:sym<is>($/) {
# Handle is repr specially.
if ~$<longname> eq 'repr' {
if $<circumfix> {
$*REPR := compile_time_value_str($<circumfix>[0].ast[0], "is repr(...) trait", $/);
}
else {
$/.CURSOR.panic("is repr(...) trait needs a parameter");
}
}
else
{
# If we have an argument, get its compile time value or
# evaluate it to get that.
my @trait_arg;
if $<circumfix> {
my $arg := $<circumfix>[0].ast[0];
@trait_arg[0] := $arg.has_compile_time_value ??
$arg.compile_time_value !!
$*W.create_thunk($/, $<circumfix>[0].ast)();
}
# If we have a type name then we need to dispatch with that type; otherwise
# we need to dispatch with it as a named argument.
my @name := $*W.disect_longname($<longname>).components();
if $*W.is_name(@name) {
my $trait := $*W.find_symbol(@name);
make -> $declarand {
$*W.apply_trait($/, '&trait_mod:<is>', $declarand, $trait, |@trait_arg);
};
}
else {
my %arg;
%arg{~$<longname>} := @trait_arg ?? @trait_arg[0] !!
$*W.find_symbol(['Bool', 'True']);
make -> $declarand {
$*W.apply_trait($/, '&trait_mod:<is>', $declarand, |%arg);
};
}
}
}
method trait_mod:sym<hides>($/) {
make -> $declarand {
$*W.apply_trait($/, '&trait_mod:<hides>', $declarand, $<typename>.ast);
};
}
method trait_mod:sym<does>($/) {
make -> $declarand {
$*W.apply_trait($/, '&trait_mod:<does>', $declarand, $<typename>.ast);
};
}
method trait_mod:sym<will>($/) {
my %arg;
%arg{~$<identifier>} := ($*W.add_constant('Int', 'int', 1)).compile_time_value;
make -> $declarand {
$*W.apply_trait($/, '&trait_mod:<will>', $declarand,
($<pblock>.ast)<code_object>, |%arg);
};
}
method trait_mod:sym<of>($/) {
make -> $declarand {
$*W.apply_trait($/, '&trait_mod:<of>', $declarand, $<typename>.ast);
};
}
method trait_mod:sym<as>($/) {
make -> $declarand {
$*W.apply_trait($/, '&trait_mod:<as>', $declarand, $<typename>.ast);
};
}
method trait_mod:sym<returns>($/) {
make -> $declarand {
$*W.apply_trait($/, '&trait_mod:<returns>', $declarand, $<typename>.ast);
};
}
method trait_mod:sym<handles>($/) {
# The term may be fairly complex. Thus we make it into a thunk
# which the trait handler can use to get the term and work with
# it.
my $thunk := $*W.create_thunk($/, $<term>.ast);
make -> $declarand {
$*W.apply_trait($/, '&trait_mod:<handles>', $declarand, $thunk);
};
}
method postop($/) {
make $<postfix> ?? $<postfix>.ast !! $<postcircumfix>.ast;
}
method dotty:sym<.>($/) { make $<dottyop>.ast; }
method dotty:sym<.*>($/) {
my $past := $<dottyop>.ast;
unless $past.isa(QAST::Op) && $past.op() eq 'callmethod' {
$/.CURSOR.panic("Cannot use " ~ $<sym>.Str ~ " on a non-identifier method call");
}
$past.unshift($*W.add_string_constant($past.name))
if $past.name ne '';
$past.name('dispatch:<' ~ ~$<sym> ~ '>');
make $past;
}
method dottyop($/) {
if $<methodop> {
make $<methodop>.ast;
} else {
make $<postop>.ast;
}
}
method privop($/) {
# Compiling private method calls is somewhat interesting. If it's
# in any way qualified, we need to ensure that the current package
# is trusted by the target class. Otherwise we assume that the call
# is to a private method in the current (non-virtual) package.
# XXX Optimize the case where the method is declared up front - but
# maybe this is for the optimizer, not for here.
# XXX Attribute accesses? Again, maybe for the optimizer, since it
# runs after CHECK time.
my $past := $<methodop>.ast;
if $<methodop><longname> {
my @parts := $*W.disect_longname($<methodop><longname>).components();
my $name := @parts.pop;
if @parts {
my $methpkg := $*W.find_symbol(@parts);
unless $methpkg.HOW.is_trusted($methpkg, $*PACKAGE) {