Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Browse files

implemented quasi quotes and macros

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...
commit e29b2f18665dd3bd5aa31692317f64713d789a7a 1 parent df250d8
Carl Mäsak masak authored
267 src/Perl6/Actions.pm
View
@@ -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);
}
@@ -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> {
@@ -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) {
@@ -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.
@@ -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 {
@@ -3333,9 +3524,10 @@ 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
@@ -3343,6 +3535,42 @@ class Perl6::Actions is HLL::Actions {
} ~ ':<' ~ $<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
@@ -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);
}
36 src/Perl6/Grammar.pm
View
@@ -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;
@@ -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;
@@ -2142,6 +2170,10 @@ grammar Perl6::Grammar is HLL::Grammar {
}
}
+ token quote:sym<quasi> {
+ <sym> <.ws> <!before '('> <block>
+ }
+
token quote_escape:sym<$> {
<?[$]>
:my $*QSIGIL := '$';
23 src/Perl6/World.pm
View
@@ -726,6 +726,27 @@ class Perl6::World is HLL::World {
self.add_fixup_task(:deserialize_past($des), :fixup_past($fixups));
$code;
}
+
+ method add_quasi_fixups($quasi_ast, $block) {
+ $quasi_ast := pir::nqp_decontainerize__PP($quasi_ast);
+ self.add_object($quasi_ast);
+ unless $quasi_ast.is_quasi_ast {
+ return "";
+ }
+ my $fixups := PAST::Op.new(:name<set_outer_ctx>, :pasttype<callmethod>,
+ PAST::Val.new(:value($block)),
+ PAST::Op.new(
+ :pirop<perl6_get_outer_ctx__PP>,
+ PAST::Var.new(
+ :scope<attribute_6model>,
+ :name<$!quasi_context>,
+ self.get_ref($quasi_ast),
+ self.get_ref(self.find_symbol(['AST']))
+ )
+ )
+ );
+ self.add_fixup_task(:fixup_past($fixups));
+ }
# Adds any extra code needing for handling phasers.
method add_phasers_handling_code($code, $code_past) {
@@ -1525,7 +1546,7 @@ class Perl6::World is HLL::World {
}
}
}
-
+
# Generates a series of PAST operations that will build this context if
# it doesn't exist, and fix it up if it already does.
method to_past() {
20 src/core/AST.pm
View
@@ -0,0 +1,20 @@
+# XXX: Would like to have this class as Perl6::AST, but ran up against
+# problems with the serialization context calling it that.
+my class AST {
+ has $!past;
+ has $!quasi_context;
+
+ submethod BUILD(:$past) {
+ $!past := $past;
+ }
+
+ method incarnate($quasi_context) {
+ my $incarnation = self.clone();
+ nqp::bindattr(nqp::p6decont($incarnation), AST, '$!quasi_context', $quasi_context);
+ return $incarnation;
+ }
+
+ method is_quasi_ast {
+ so $!quasi_context;
+ }
+}
2  src/core/Macro.pm
View
@@ -0,0 +1,2 @@
+my class Macro is Routine {
+}
25 src/ops/perl6.ops
View
@@ -1780,6 +1780,31 @@ inline op perl6_capture_lex(in PMC) {
}
/*
+
+=item perl6_get_outer_ctx
+
+Returns the OUTER context of a Perl 6 code object. Needed for the fixups
+that macros do.
+
+=cut
+
+*/
+inline op perl6_get_outer_ctx(out PMC, in PMC) {
+ if ($2->vtable->base_type == smo_id) {
+ Rakudo_Code *code_obj = (Rakudo_Code *)PMC_data(Rakudo_cont_decontainerize(interp, $2));
+ if (code_obj->_do->vtable->base_type != enum_class_Sub)
+ Parrot_ex_throw_from_c_args(interp, NULL, EXCEPTION_INVALID_OPERATION,
+ "perl6_get_outer_ctx did not get a Parrot Sub as expected, got %Ss",
+ VTABLE_name(interp, VTABLE_get_class(interp, $2)));
+ $1 = PARROT_SUB(code_obj->_do)->outer_ctx;
+ }
+ else {
+ Parrot_ex_throw_from_c_args(interp, NULL, EXCEPTION_INVALID_OPERATION,
+ "Can only use perl6_get_outer_ctx with a SixModelObject");
+ }
+}
+
+/*
* Local variables:
* c-file-style: "parrot"
* End:
2  tools/build/Makefile.in
View
@@ -168,6 +168,7 @@ CORE_SOURCES = \
src/core/Attribute.pm \
src/core/Routine.pm \
src/core/Sub.pm \
+ src/core/Macro.pm \
src/core/Method.pm \
src/core/Submethod.pm \
src/core/Junction.pm \
@@ -213,6 +214,7 @@ CORE_SOURCES = \
src/core/Cursor.pm \
src/core/Grammar.pm \
src/core/Regex.pm \
+ src/core/AST.pm \
src/core/CallFrame.pm \
src/core/Main.pm \
src/core/tai-utc.pm \
Please sign in to comment.
Something went wrong with that request. Please try again.