Skip to content
This repository

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Browse code

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 authored
267  src/Perl6/Actions.pm
@@ -1181,12 +1181,15 @@ class Perl6::Actions is HLL::Actions {
1181 1181
             if $sigil ne '&' && !$*IN_DECL && ($*QSIGIL eq '' || $*QSIGIL eq '$') && !$*W.is_lexical($name) {
1182 1182
                 $*W.throw($/, ['X', 'Undeclared'], symbol => $name);
1183 1183
             }
  1184
+            elsif $sigil eq '&' {
  1185
+                $past.viviself(PAST::Var.new(:name('Nil'), :scope('lexical_6model')));
  1186
+            }
1184 1187
 
1185 1188
             # Expect variable to have been declared somewhere.
1186 1189
             # Locate descriptor and thus type.
  1190
+            $past.scope('lexical_6model');
1187 1191
             try {
1188 1192
                 my $type := $*W.find_lexical_container_type($past.name);
1189  
-                $past.scope('lexical_6model');
1190 1193
                 $past.type($type);
1191 1194
                 $past := box_native_if_needed($past, $type);
1192 1195
             }
@@ -1913,6 +1916,92 @@ class Perl6::Actions is HLL::Actions {
1913 1916
         make $closure;
1914 1917
     }
1915 1918
 
  1919
+    method macro_def($/) {
  1920
+        my $block;
  1921
+
  1922
+        $block := $<blockoid>.ast;
  1923
+        $block.blocktype('declaration');
  1924
+        if is_clearly_returnless($block) {
  1925
+            $block[1] := PAST::Op.new(
  1926
+                :pirop('perl6_decontainerize_return_value PP'),
  1927
+                $block[1]);
  1928
+        }
  1929
+        else {
  1930
+            $block[1] := wrap_return_handler($block[1]);
  1931
+        }
  1932
+
  1933
+        # Obtain parameters, create signature object and generate code to
  1934
+        # call binder.
  1935
+        if $block<placeholder_sig> && $<multisig> {
  1936
+            $/.CURSOR.panic('Placeholder variable cannot override existing signature');
  1937
+        }
  1938
+        my @params :=
  1939
+                $<multisig>             ?? $<multisig>[0].ast      !!
  1940
+                $block<placeholder_sig> ?? $block<placeholder_sig> !!
  1941
+                [];
  1942
+        set_default_parameter_type(@params, 'Any');
  1943
+        my $signature := create_signature_object($<multisig> ?? $<multisig>[0] !! $/, @params, $block);
  1944
+        add_signature_binding_code($block, $signature, @params);
  1945
+
  1946
+        # Create code object.
  1947
+        if $<deflongname> {
  1948
+            $block.name(~$<deflongname>[0].ast);
  1949
+            $block.nsentry('');
  1950
+        }
  1951
+        my $code := $*W.create_code_object($block, 'Macro', $signature,
  1952
+            $*MULTINESS eq 'proto');
  1953
+
  1954
+        # Document it
  1955
+        Perl6::Pod::document($code, $*DOC);
  1956
+
  1957
+        # Install PAST block so that it gets capture_lex'd correctly and also
  1958
+        # install it in the lexpad.
  1959
+        my $outer := $*W.cur_lexpad();
  1960
+        $outer[0].push(PAST::Stmt.new($block));
  1961
+
  1962
+        # Install &?ROUTINE.
  1963
+        $*W.install_lexical_symbol($block, '&?ROUTINE', $code);
  1964
+
  1965
+        my $past;
  1966
+        if $<deflongname> {
  1967
+            my $name := '&' ~ ~$<deflongname>[0].ast;
  1968
+            # Install.
  1969
+            if $outer.symbol($name) {
  1970
+                $/.CURSOR.panic("Illegal redeclaration of macro '" ~
  1971
+                    ~$<deflongname>[0].ast ~ "'");
  1972
+            }
  1973
+            if $*SCOPE eq '' || $*SCOPE eq 'my' {
  1974
+                $*W.install_lexical_symbol($outer, $name, $code);
  1975
+            }
  1976
+            elsif $*SCOPE eq 'our' {
  1977
+                # Install in lexpad and in package, and set up code to
  1978
+                # re-bind it per invocation of its outer.
  1979
+                $*W.install_lexical_symbol($outer, $name, $code);
  1980
+                $*W.install_package_symbol($*PACKAGE, $name, $code);
  1981
+                $outer[0].push(PAST::Op.new(
  1982
+                    :pasttype('bind_6model'),
  1983
+                    $*W.symbol_lookup([$name], $/, :package_only(1)),
  1984
+                    PAST::Var.new( :name($name), :scope('lexical_6model') )
  1985
+                ));
  1986
+            }
  1987
+            else {
  1988
+                $/.CURSOR.panic("Cannot use '$*SCOPE' scope with a macro");
  1989
+            }
  1990
+        }
  1991
+        elsif $*MULTINESS {
  1992
+            $/.CURSOR.panic('Cannot put ' ~ $*MULTINESS ~ ' on anonymous macro');
  1993
+        }
  1994
+
  1995
+        # Apply traits.
  1996
+        for $<trait> {
  1997
+            if $_.ast { ($_.ast)($code) }
  1998
+        }
  1999
+
  2000
+        my $closure := block_closure(reference_to_code_object($code, $past));
  2001
+        $closure<sink_past> := PAST::Op.new( :pasttype('null') );
  2002
+        make $closure;
  2003
+    }
  2004
+
1916 2005
     sub methodize_block($/, $code, $past, @params, $invocant_type, :$yada) {
1917 2006
         # Get signature and ensure it has an invocant and *%_.
1918 2007
         if $past<placeholder_sig> {
@@ -2959,10 +3048,66 @@ class Perl6::Actions is HLL::Actions {
2959 3048
     }
2960 3049
 
2961 3050
     method term:sym<identifier>($/) {
2962  
-        my $past := capture_or_parcel($<args>.ast, ~$<identifier>);
2963  
-        $past.name('&' ~ $<identifier>);
2964  
-        $past.node($/);
2965  
-        make $past;
  3051
+        my $is_macro := 0;
  3052
+        my $routine;
  3053
+        try {
  3054
+            $routine := $*W.find_symbol(['&' ~ ~$<identifier>]);
  3055
+            if nqp::istype($routine, $*W.find_symbol(['Macro'])) {
  3056
+                $is_macro := 1;
  3057
+            }
  3058
+        }
  3059
+        if $is_macro {
  3060
+            my $nil_class := $*W.find_symbol(['Nil']);
  3061
+            my $ast_class := $*W.find_symbol(['AST']);
  3062
+            my @argument_quasi_asts := [];
  3063
+            if $<args><semiarglist> {
  3064
+                for $<args><semiarglist><arglist> {
  3065
+                    if $_<EXPR> {
  3066
+                        my $expr := $_<EXPR>.ast;
  3067
+                        add_macro_arguments($expr, $ast_class, @argument_quasi_asts);
  3068
+                    }
  3069
+                }
  3070
+            }
  3071
+            my $quasi_ast := $routine(|@argument_quasi_asts);
  3072
+            if nqp::istype($quasi_ast, $nil_class) {
  3073
+                make PAST::Var.new(:name('Nil'), :scope('lexical_6model'));
  3074
+                return 1;
  3075
+            }
  3076
+            unless nqp::istype($quasi_ast, $ast_class) {
  3077
+                # XXX: Need to awesomeize with which type it got
  3078
+                $/.CURSOR.panic('Macro did not return AST');
  3079
+            }
  3080
+            my $past := PAST::Block.new(
  3081
+                :blocktype<immediate>,
  3082
+                :lexical(0),
  3083
+                nqp::getattr(pir::perl6_decontainerize__PP($quasi_ast),
  3084
+                    $ast_class,
  3085
+                    '$!past')
  3086
+            );
  3087
+            $*W.add_quasi_fixups($quasi_ast, $past);
  3088
+            make $past;
  3089
+        }
  3090
+        else {
  3091
+            my $past := capture_or_parcel($<args>.ast, ~$<identifier>);
  3092
+            $past.name('&' ~ $<identifier>);
  3093
+            $past.node($/);
  3094
+            make $past;
  3095
+        }
  3096
+    }
  3097
+
  3098
+    sub add_macro_arguments($expr, $ast_class, @argument_quasi_asts) {
  3099
+        if $expr.name eq '&infix:<,>' {
  3100
+            for $expr.list {
  3101
+                my $quasi_ast := $ast_class.new();
  3102
+                nqp::bindattr($quasi_ast, $ast_class, '$!past', $_);
  3103
+                @argument_quasi_asts.push($quasi_ast);
  3104
+            }
  3105
+        }
  3106
+        else {
  3107
+            my $quasi_ast := $ast_class.new();
  3108
+            nqp::bindattr($quasi_ast, $ast_class, '$!past', $expr);
  3109
+            @argument_quasi_asts.push($quasi_ast);
  3110
+        }
2966 3111
     }
2967 3112
 
2968 3113
     method is_indirect_lookup($longname) {
@@ -3001,8 +3146,8 @@ class Perl6::Actions is HLL::Actions {
3001 3146
                 $/.CURSOR.panic("Combination of indirect name lookup and call not (yet?) allowed");
3002 3147
             }
3003 3148
             $past := self.make_indirect_lookup($<longname>)
3004  
-
3005  
-        } elsif $<args> {
  3149
+        }
  3150
+        elsif $<args> {
3006 3151
             # If we have args, it's a call. Look it up dynamically
3007 3152
             # and make the call.
3008 3153
             # Add & to name.
@@ -3011,12 +3156,58 @@ class Perl6::Actions is HLL::Actions {
3011 3156
             if pir::substr($final, 0, 1) ne '&' {
3012 3157
                 @name[+@name - 1] := '&' ~ $final;
3013 3158
             }
3014  
-            $past := capture_or_parcel($<args>.ast, ~$<longname>);
3015  
-            if +@name == 1 {
3016  
-                $past.name(@name[0]);
  3159
+            my $is_macro := 0;
  3160
+            my $routine;
  3161
+            try {
  3162
+                $routine := $*W.find_symbol(@name);
  3163
+                if nqp::istype($routine, $*W.find_symbol(['Macro'])) {
  3164
+                    $is_macro := 1;
  3165
+                }
  3166
+            }
  3167
+            if $is_macro {
  3168
+                my $nil_class := $*W.find_symbol(['Nil']);
  3169
+                my $ast_class := $*W.find_symbol(['AST']);
  3170
+                my @argument_quasi_asts := [];
  3171
+                if $<args><semiarglist> {
  3172
+                    for $<args><semiarglist><arglist> {
  3173
+                        if $_<EXPR> {
  3174
+                            my $expr := $_<EXPR>.ast;
  3175
+                            add_macro_arguments($expr, $ast_class, @argument_quasi_asts);
  3176
+                        }
  3177
+                    }
  3178
+                }
  3179
+                elsif $<args><arglist> {
  3180
+                    if $<args><arglist><EXPR> {
  3181
+                        my $expr := $<args><arglist><EXPR>.ast;
  3182
+                        add_macro_arguments($expr, $ast_class, @argument_quasi_asts);
  3183
+                    }
  3184
+                }
  3185
+                my $quasi_ast := $routine(|@argument_quasi_asts);
  3186
+                if nqp::istype($quasi_ast, $nil_class) {
  3187
+                    make PAST::Var.new(:name('Nil'), :scope('lexical_6model'));
  3188
+                    return 1;
  3189
+                }
  3190
+                unless nqp::istype($quasi_ast, $ast_class) {
  3191
+                    # XXX: Need to awesomeize with which type it got
  3192
+                    $/.CURSOR.panic('Macro did not return AST');
  3193
+                }
  3194
+                $past := PAST::Block.new(
  3195
+                    :blocktype<immediate>,
  3196
+                    :lexical(0),
  3197
+                    nqp::getattr(pir::perl6_decontainerize__PP($quasi_ast),
  3198
+                        $ast_class,
  3199
+                        '$!past')
  3200
+                );
  3201
+                $*W.add_quasi_fixups($quasi_ast, $past);
3017 3202
             }
3018 3203
             else {
3019  
-                $past.unshift($*W.symbol_lookup(@name, $/));
  3204
+                $past := capture_or_parcel($<args>.ast, ~$<longname>);
  3205
+                if +@name == 1 {
  3206
+                    $past.name(@name[0]);
  3207
+                }
  3208
+                else {
  3209
+                    $past.unshift($*W.symbol_lookup(@name, $/));
  3210
+                }
3020 3211
             }
3021 3212
         }
3022 3213
         else {
@@ -3333,9 +3524,10 @@ class Perl6::Actions is HLL::Actions {
3333 3524
             $past := PAST::Op.new( :node($/) );
3334 3525
             if $<OPER><O><pasttype> { $past.pasttype( ~$<OPER><O><pasttype> ); }
3335 3526
             elsif $<OPER><O><pirop>    { $past.pirop( ~$<OPER><O><pirop> ); }
  3527
+            my $name;
3336 3528
             unless $past.name {
3337 3529
                 if $key eq 'LIST' { $key := 'infix'; }
3338  
-                my $name := Q:PIR {
  3530
+                $name := Q:PIR {
3339 3531
                     $P0 = find_lex '$key'
3340 3532
                     $S0 = $P0
3341 3533
                     $S0 = downcase $S0
@@ -3343,6 +3535,42 @@ class Perl6::Actions is HLL::Actions {
3343 3535
                 } ~ ':<' ~ $<OPER><sym> ~ '>';
3344 3536
                 $past.name('&' ~ $name);
3345 3537
             }
  3538
+            my $routine;
  3539
+            my $is_macro := 0;
  3540
+            try {
  3541
+                $routine := $*W.find_symbol(['&' ~ $name]);
  3542
+                if nqp::istype($routine, $*W.find_symbol(['Macro'])) {
  3543
+                    $is_macro := 1;
  3544
+                }
  3545
+            }
  3546
+            if $is_macro {
  3547
+                my $nil_class := $*W.find_symbol(['Nil']);
  3548
+                my $ast_class := $*W.find_symbol(['AST']);
  3549
+                my @argument_quasi_asts := [];
  3550
+                for @($/) {
  3551
+                    add_macro_arguments($_.ast, $ast_class, @argument_quasi_asts);
  3552
+                }
  3553
+
  3554
+                my $quasi_ast := $routine(|@argument_quasi_asts);
  3555
+                if nqp::istype($quasi_ast, $nil_class) {
  3556
+                    make PAST::Var.new(:name('Nil'), :scope('lexical_6model'));
  3557
+                    return 1;
  3558
+                }
  3559
+                unless nqp::istype($quasi_ast, $ast_class) {
  3560
+                    # XXX: Need to awesomeize with which type it got
  3561
+                    $/.CURSOR.panic('Macro did not return AST');
  3562
+                }
  3563
+                my $past := PAST::Block.new(
  3564
+                    :blocktype<immediate>,
  3565
+                    :lexical(0),
  3566
+                    nqp::getattr(pir::perl6_decontainerize__PP($quasi_ast),
  3567
+                        $ast_class,
  3568
+                        '$!past')
  3569
+                );
  3570
+                $*W.add_quasi_fixups($quasi_ast, $past);
  3571
+                make $past;
  3572
+                return 'an irrelevant value';
  3573
+            }
3346 3574
         }
3347 3575
         if $key eq 'POSTFIX' {
3348 3576
             # Method calls may be to a foreign language, and thus return
@@ -4081,6 +4309,21 @@ class Perl6::Actions is HLL::Actions {
4081 4309
         make $past;
4082 4310
     }
4083 4311
 
  4312
+    method quote:sym<quasi>($/) {
  4313
+        my $ast_class := $*W.find_symbol(['AST']);
  4314
+        my $quasi_ast := $ast_class.new();
  4315
+        nqp::bindattr($quasi_ast, $ast_class, '$!past', $<block>.ast<past_block>[1]);
  4316
+        $*W.add_object($quasi_ast);
  4317
+        my $throwaway_block := PAST::Block.new();
  4318
+        my $quasi_context := block_closure(
  4319
+            reference_to_code_object(
  4320
+                make_simple_code_object($throwaway_block, 'Block'),
  4321
+                $throwaway_block
  4322
+            ));
  4323
+        make PAST::Op.new(:pasttype<callmethod>, :name<incarnate>,
  4324
+                          $*W.get_ref($quasi_ast), $quasi_context);
  4325
+    }
  4326
+
4084 4327
     method quote_escape:sym<$>($/) {
4085 4328
         make steal_back_spaces($/, $<EXPR>.ast);
4086 4329
     }
36  src/Perl6/Grammar.pm
@@ -1494,8 +1494,7 @@ grammar Perl6::Grammar is HLL::Grammar {
1494 1494
     token routine_declarator:sym<submethod>
1495 1495
         { <sym> <.end_keyword> <method_def('submethod')> }
1496 1496
     token routine_declarator:sym<macro>
1497  
-        { <sym> <.end_keyword>
1498  
-          <.NYI: "Macros"> }
  1497
+        { <sym> <.end_keyword> <macro_def()> }
1499 1498
 
1500 1499
     rule routine_def($d) {
1501 1500
         :my $*IN_DECL := $d;
@@ -1556,6 +1555,35 @@ grammar Perl6::Grammar is HLL::Grammar {
1556 1555
             ]
1557 1556
         ] || <.malformed('method')>
1558 1557
     }
  1558
+
  1559
+    rule macro_def() {
  1560
+        :my $*IN_DECL := 'macro';
  1561
+        :my $*METHODTYPE;
  1562
+        :my $*IMPLICIT := 0;
  1563
+        :my $*DOC := $*DECLARATOR_DOCS;
  1564
+        :my $*DOCEE;
  1565
+        <.attach_docs>
  1566
+        <deflongname>?
  1567
+        {
  1568
+            if $<deflongname> && $<deflongname>[0]<colonpair> {
  1569
+                # It's an (potentially new) operator, circumfix, etc. that we
  1570
+                # need to tweak into the grammar.
  1571
+                my $category := $<deflongname>[0]<name>.Str;
  1572
+                my $opname := ~$<deflongname>[0]<colonpair>[0]<circumfix><quote_EXPR><quote_delimited><quote_atom>[0];
  1573
+                my $canname := $category ~ ":sym<" ~ $opname ~ ">";
  1574
+                $/.CURSOR.gen_op($category, $opname, $canname, $<deflongname>[0].ast)
  1575
+                    unless pir::can__IPs($/.CURSOR, $canname);
  1576
+            }
  1577
+        }
  1578
+        <.newpad>
  1579
+        [ '(' <multisig> ')' ]?
  1580
+        <trait>*
  1581
+        { $*IN_DECL := ''; }
  1582
+        [
  1583
+        | <onlystar>
  1584
+        | <blockoid>
  1585
+        ]
  1586
+    }
1559 1587
     
1560 1588
     token onlystar {
1561 1589
         :my $*CURPAD;
@@ -2142,6 +2170,10 @@ grammar Perl6::Grammar is HLL::Grammar {
2142 2170
         }
2143 2171
     }
2144 2172
 
  2173
+    token quote:sym<quasi> {
  2174
+        <sym> <.ws> <!before '('> <block>
  2175
+    }
  2176
+
2145 2177
     token quote_escape:sym<$> {
2146 2178
         <?[$]>
2147 2179
         :my $*QSIGIL := '$';
23  src/Perl6/World.pm
@@ -726,6 +726,27 @@ class Perl6::World is HLL::World {
726 726
         self.add_fixup_task(:deserialize_past($des), :fixup_past($fixups));
727 727
         $code;
728 728
     }
  729
+
  730
+    method add_quasi_fixups($quasi_ast, $block) {
  731
+        $quasi_ast := pir::nqp_decontainerize__PP($quasi_ast);
  732
+        self.add_object($quasi_ast);
  733
+        unless $quasi_ast.is_quasi_ast {
  734
+            return "";
  735
+        }
  736
+        my $fixups := PAST::Op.new(:name<set_outer_ctx>, :pasttype<callmethod>,
  737
+                                   PAST::Val.new(:value($block)),
  738
+                                   PAST::Op.new(
  739
+                                        :pirop<perl6_get_outer_ctx__PP>,
  740
+                                        PAST::Var.new(
  741
+                                            :scope<attribute_6model>,
  742
+                                            :name<$!quasi_context>,
  743
+                                            self.get_ref($quasi_ast),
  744
+                                            self.get_ref(self.find_symbol(['AST']))
  745
+                                        )
  746
+                                   )
  747
+                        );
  748
+        self.add_fixup_task(:fixup_past($fixups));
  749
+    }
729 750
     
730 751
     # Adds any extra code needing for handling phasers.
731 752
     method add_phasers_handling_code($code, $code_past) {
@@ -1525,7 +1546,7 @@ class Perl6::World is HLL::World {
1525 1546
             }
1526 1547
         }
1527 1548
     }
1528  
-    
  1549
+
1529 1550
     # Generates a series of PAST operations that will build this context if
1530 1551
     # it doesn't exist, and fix it up if it already does.
1531 1552
     method to_past() {
20  src/core/AST.pm
... ...
@@ -0,0 +1,20 @@
  1
+# XXX: Would like to have this class as Perl6::AST, but ran up against
  2
+#      problems with the serialization context calling it that.
  3
+my class AST {
  4
+    has $!past;
  5
+    has $!quasi_context;
  6
+
  7
+    submethod BUILD(:$past) {
  8
+        $!past := $past;
  9
+    }
  10
+
  11
+    method incarnate($quasi_context) {
  12
+        my $incarnation = self.clone();
  13
+        nqp::bindattr(nqp::p6decont($incarnation), AST, '$!quasi_context', $quasi_context);
  14
+        return $incarnation;
  15
+    }
  16
+
  17
+    method is_quasi_ast {
  18
+        so $!quasi_context;
  19
+    }
  20
+}
2  src/core/Macro.pm
... ...
@@ -0,0 +1,2 @@
  1
+my class Macro is Routine {
  2
+}
25  src/ops/perl6.ops
@@ -1780,6 +1780,31 @@ inline op perl6_capture_lex(in PMC) {
1780 1780
 }
1781 1781
 
1782 1782
 /*
  1783
+
  1784
+=item perl6_get_outer_ctx
  1785
+
  1786
+Returns the OUTER context of a Perl 6 code object. Needed for the fixups
  1787
+that macros do.
  1788
+
  1789
+=cut
  1790
+
  1791
+*/
  1792
+inline op perl6_get_outer_ctx(out PMC, in PMC) {
  1793
+    if ($2->vtable->base_type == smo_id) {
  1794
+        Rakudo_Code *code_obj = (Rakudo_Code *)PMC_data(Rakudo_cont_decontainerize(interp, $2));
  1795
+        if (code_obj->_do->vtable->base_type != enum_class_Sub)
  1796
+            Parrot_ex_throw_from_c_args(interp, NULL, EXCEPTION_INVALID_OPERATION,
  1797
+                "perl6_get_outer_ctx did not get a Parrot Sub as expected, got %Ss",
  1798
+                VTABLE_name(interp, VTABLE_get_class(interp, $2)));
  1799
+        $1 = PARROT_SUB(code_obj->_do)->outer_ctx;
  1800
+    }
  1801
+    else {
  1802
+        Parrot_ex_throw_from_c_args(interp, NULL, EXCEPTION_INVALID_OPERATION,
  1803
+            "Can only use perl6_get_outer_ctx with a SixModelObject");
  1804
+    }
  1805
+}
  1806
+
  1807
+/*
1783 1808
  * Local variables:
1784 1809
  *   c-file-style: "parrot"
1785 1810
  * End:
2  tools/build/Makefile.in
@@ -168,6 +168,7 @@ CORE_SOURCES = \
168 168
   src/core/Attribute.pm \
169 169
   src/core/Routine.pm \
170 170
   src/core/Sub.pm \
  171
+  src/core/Macro.pm \
171 172
   src/core/Method.pm \
172 173
   src/core/Submethod.pm \
173 174
   src/core/Junction.pm \
@@ -213,6 +214,7 @@ CORE_SOURCES = \
213 214
   src/core/Cursor.pm \
214 215
   src/core/Grammar.pm \
215 216
   src/core/Regex.pm \
  217
+  src/core/AST.pm \
216 218
   src/core/CallFrame.pm \
217 219
   src/core/Main.pm \
218 220
   src/core/tai-utc.pm \

0 notes on commit e29b2f1

Please sign in to comment.
Something went wrong with that request. Please try again.