Skip to content

Commit

Permalink
implemented quasi quotes and macros
Browse files Browse the repository at this point in the history 
This works:

- Macro declarations
- Calling a macro (using `macro()` and `macro` and operators)
- Quasi quotes
- Variable lookup from within the quasi quote

This doesn't, yet:

- Variable lookup from within a macro parameter
  • Loading branch information
Carl Masak committed Mar 7, 2012
1 parent df250d8 commit e29b2f1
Show file tree
Hide file tree
Showing 7 changed files with 360 additions and 15 deletions.
267 changes: 255 additions & 12 deletions src/Perl6/Actions.pm
View file
Expand Up @@ -1181,12 +1181,15 @@ class Perl6::Actions is HLL::Actions {
if $sigil ne '&' && !$*IN_DECL && ($*QSIGIL eq '' || $*QSIGIL eq '$') && !$*W.is_lexical($name) {
$*W.throw($/, ['X', 'Undeclared'], symbol => $name);
}
elsif $sigil eq '&' {
$past.viviself(PAST::Var.new(:name('Nil'), :scope('lexical_6model')));
}

# Expect variable to have been declared somewhere.
# Locate descriptor and thus type.
$past.scope('lexical_6model');
try {
my $type := $*W.find_lexical_container_type($past.name);
$past.scope('lexical_6model');
$past.type($type);
$past := box_native_if_needed($past, $type);
}
Expand Down Expand Up @@ -1913,6 +1916,92 @@ class Perl6::Actions is HLL::Actions {
make $closure;
}

method macro_def($/) {
my $block;

$block := $<blockoid>.ast;
$block.blocktype('declaration');
if is_clearly_returnless($block) {
$block[1] := PAST::Op.new(
:pirop('perl6_decontainerize_return_value PP'),
$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> {
$/.CURSOR.panic('Placeholder variable cannot override existing signature');
}
my @params :=
$<multisig> ?? $<multisig>[0].ast !!
$block<placeholder_sig> ?? $block<placeholder_sig> !!
[];
set_default_parameter_type(@params, 'Any');
my $signature := create_signature_object($<multisig> ?? $<multisig>[0] !! $/, @params, $block);
add_signature_binding_code($block, $signature, @params);

# Create code object.
if $<deflongname> {
$block.name(~$<deflongname>[0].ast);
$block.nsentry('');
}
my $code := $*W.create_code_object($block, 'Macro', $signature,
$*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(PAST::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(PAST::Op.new(
:pasttype('bind_6model'),
$*W.symbol_lookup([$name], $/, :package_only(1)),
PAST::Var.new( :name($name), :scope('lexical_6model') )
));
}
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> := PAST::Op.new( :pasttype('null') );
make $closure;
}

sub methodize_block($/, $code, $past, @params, $invocant_type, :$yada) {
# Get signature and ensure it has an invocant and *%_.
if $past<placeholder_sig> {
Expand Down Expand Up @@ -2959,10 +3048,66 @@ class Perl6::Actions is HLL::Actions {
}

method term:sym<identifier>($/) {
my $past := capture_or_parcel($<args>.ast, ~$<identifier>);
$past.name('&' ~ $<identifier>);
$past.node($/);
make $past;
my $is_macro := 0;
my $routine;
try {
$routine := $*W.find_symbol(['&' ~ ~$<identifier>]);
if nqp::istype($routine, $*W.find_symbol(['Macro'])) {
$is_macro := 1;
}
}
if $is_macro {
my $nil_class := $*W.find_symbol(['Nil']);
my $ast_class := $*W.find_symbol(['AST']);
my @argument_quasi_asts := [];
if $<args><semiarglist> {
for $<args><semiarglist><arglist> {
if $_<EXPR> {
my $expr := $_<EXPR>.ast;
add_macro_arguments($expr, $ast_class, @argument_quasi_asts);
}
}
}
my $quasi_ast := $routine(|@argument_quasi_asts);
if nqp::istype($quasi_ast, $nil_class) {
make PAST::Var.new(:name('Nil'), :scope('lexical_6model'));
return 1;
}
unless nqp::istype($quasi_ast, $ast_class) {
# XXX: Need to awesomeize with which type it got
$/.CURSOR.panic('Macro did not return AST');
}
my $past := PAST::Block.new(
:blocktype<immediate>,
:lexical(0),
nqp::getattr(pir::perl6_decontainerize__PP($quasi_ast),
$ast_class,
'$!past')
);
$*W.add_quasi_fixups($quasi_ast, $past);
make $past;
}
else {
my $past := capture_or_parcel($<args>.ast, ~$<identifier>);
$past.name('&' ~ $<identifier>);
$past.node($/);
make $past;
}
}

sub add_macro_arguments($expr, $ast_class, @argument_quasi_asts) {
if $expr.name eq '&infix:<,>' {
for $expr.list {
my $quasi_ast := $ast_class.new();
nqp::bindattr($quasi_ast, $ast_class, '$!past', $_);
@argument_quasi_asts.push($quasi_ast);
}
}
else {
my $quasi_ast := $ast_class.new();
nqp::bindattr($quasi_ast, $ast_class, '$!past', $expr);
@argument_quasi_asts.push($quasi_ast);
}
}

method is_indirect_lookup($longname) {
Expand Down Expand Up @@ -3001,8 +3146,8 @@ class Perl6::Actions is HLL::Actions {
$/.CURSOR.panic("Combination of indirect name lookup and call not (yet?) allowed");
}
$past := self.make_indirect_lookup($<longname>)

} elsif $<args> {
}
elsif $<args> {
# If we have args, it's a call. Look it up dynamically
# and make the call.
# Add & to name.
Expand All @@ -3011,12 +3156,58 @@ class Perl6::Actions is HLL::Actions {
if pir::substr($final, 0, 1) ne '&' {
@name[+@name - 1] := '&' ~ $final;
}
$past := capture_or_parcel($<args>.ast, ~$<longname>);
if +@name == 1 {
$past.name(@name[0]);
my $is_macro := 0;
my $routine;
try {
$routine := $*W.find_symbol(@name);
if nqp::istype($routine, $*W.find_symbol(['Macro'])) {
$is_macro := 1;
}
}
if $is_macro {
my $nil_class := $*W.find_symbol(['Nil']);
my $ast_class := $*W.find_symbol(['AST']);
my @argument_quasi_asts := [];
if $<args><semiarglist> {
for $<args><semiarglist><arglist> {
if $_<EXPR> {
my $expr := $_<EXPR>.ast;
add_macro_arguments($expr, $ast_class, @argument_quasi_asts);
}
}
}
elsif $<args><arglist> {
if $<args><arglist><EXPR> {
my $expr := $<args><arglist><EXPR>.ast;
add_macro_arguments($expr, $ast_class, @argument_quasi_asts);
}
}
my $quasi_ast := $routine(|@argument_quasi_asts);
if nqp::istype($quasi_ast, $nil_class) {
make PAST::Var.new(:name('Nil'), :scope('lexical_6model'));
return 1;
}
unless nqp::istype($quasi_ast, $ast_class) {
# XXX: Need to awesomeize with which type it got
$/.CURSOR.panic('Macro did not return AST');
}
$past := PAST::Block.new(
:blocktype<immediate>,
:lexical(0),
nqp::getattr(pir::perl6_decontainerize__PP($quasi_ast),
$ast_class,
'$!past')
);
$*W.add_quasi_fixups($quasi_ast, $past);
}
else {
$past.unshift($*W.symbol_lookup(@name, $/));
$past := capture_or_parcel($<args>.ast, ~$<longname>);
if +@name == 1 {
$past.name(@name[0]);
}
else {
$past.unshift($*W.symbol_lookup(@name, $/));
}
}
}
else {
Expand Down Expand Up @@ -3333,16 +3524,53 @@ class Perl6::Actions is HLL::Actions {
$past := PAST::Op.new( :node($/) );
if $<OPER><O><pasttype> { $past.pasttype( ~$<OPER><O><pasttype> ); }
elsif $<OPER><O><pirop> { $past.pirop( ~$<OPER><O><pirop> ); }
my $name;
unless $past.name {
if $key eq 'LIST' { $key := 'infix'; }
my $name := Q:PIR {
$name := Q:PIR {
$P0 = find_lex '$key'
$S0 = $P0
$S0 = downcase $S0
%r = box $S0
} ~ ':<' ~ $<OPER><sym> ~ '>';
$past.name('&' ~ $name);
}
my $routine;
my $is_macro := 0;
try {
$routine := $*W.find_symbol(['&' ~ $name]);
if nqp::istype($routine, $*W.find_symbol(['Macro'])) {
$is_macro := 1;
}
}
if $is_macro {
my $nil_class := $*W.find_symbol(['Nil']);
my $ast_class := $*W.find_symbol(['AST']);
my @argument_quasi_asts := [];
for @($/) {
add_macro_arguments($_.ast, $ast_class, @argument_quasi_asts);
}

my $quasi_ast := $routine(|@argument_quasi_asts);
if nqp::istype($quasi_ast, $nil_class) {
make PAST::Var.new(:name('Nil'), :scope('lexical_6model'));
return 1;
}
unless nqp::istype($quasi_ast, $ast_class) {
# XXX: Need to awesomeize with which type it got
$/.CURSOR.panic('Macro did not return AST');
}
my $past := PAST::Block.new(
:blocktype<immediate>,
:lexical(0),
nqp::getattr(pir::perl6_decontainerize__PP($quasi_ast),
$ast_class,
'$!past')
);
$*W.add_quasi_fixups($quasi_ast, $past);
make $past;
return 'an irrelevant value';
}
}
if $key eq 'POSTFIX' {
# Method calls may be to a foreign language, and thus return
Expand Down Expand Up @@ -4081,6 +4309,21 @@ class Perl6::Actions is HLL::Actions {
make $past;
}

method quote:sym<quasi>($/) {
my $ast_class := $*W.find_symbol(['AST']);
my $quasi_ast := $ast_class.new();
nqp::bindattr($quasi_ast, $ast_class, '$!past', $<block>.ast<past_block>[1]);
$*W.add_object($quasi_ast);
my $throwaway_block := PAST::Block.new();
my $quasi_context := block_closure(
reference_to_code_object(
make_simple_code_object($throwaway_block, 'Block'),
$throwaway_block
));
make PAST::Op.new(:pasttype<callmethod>, :name<incarnate>,
$*W.get_ref($quasi_ast), $quasi_context);
}

method quote_escape:sym<$>($/) {
make steal_back_spaces($/, $<EXPR>.ast);
}
Expand Down
36 changes: 34 additions & 2 deletions src/Perl6/Grammar.pm
View file
Expand Up @@ -1494,8 +1494,7 @@ grammar Perl6::Grammar is HLL::Grammar {
token routine_declarator:sym<submethod>
{ <sym> <.end_keyword> <method_def('submethod')> }
token routine_declarator:sym<macro>
{ <sym> <.end_keyword>
<.NYI: "Macros"> }
{ <sym> <.end_keyword> <macro_def()> }

rule routine_def($d) {
:my $*IN_DECL := $d;
Expand Down Expand Up @@ -1556,6 +1555,35 @@ grammar Perl6::Grammar is HLL::Grammar {
]
] || <.malformed('method')>
}

rule macro_def() {
:my $*IN_DECL := 'macro';
:my $*METHODTYPE;
:my $*IMPLICIT := 0;
:my $*DOC := $*DECLARATOR_DOCS;
:my $*DOCEE;
<.attach_docs>
<deflongname>?
{
if $<deflongname> && $<deflongname>[0]<colonpair> {
# It's an (potentially new) operator, circumfix, etc. that we
# need to tweak into the grammar.
my $category := $<deflongname>[0]<name>.Str;
my $opname := ~$<deflongname>[0]<colonpair>[0]<circumfix><quote_EXPR><quote_delimited><quote_atom>[0];
my $canname := $category ~ ":sym<" ~ $opname ~ ">";
$/.CURSOR.gen_op($category, $opname, $canname, $<deflongname>[0].ast)
unless pir::can__IPs($/.CURSOR, $canname);
}
}
<.newpad>
[ '(' <multisig> ')' ]?
<trait>*
{ $*IN_DECL := ''; }
[
| <onlystar>
| <blockoid>
]
}

token onlystar {
:my $*CURPAD;
Expand Down Expand Up @@ -2142,6 +2170,10 @@ grammar Perl6::Grammar is HLL::Grammar {
}
}

token quote:sym<quasi> {
<sym> <.ws> <!before '('> <block>
}

token quote_escape:sym<$> {
<?[$]>
:my $*QSIGIL := '$';
Expand Down

0 comments on commit e29b2f1

Please sign in to comment.