From 1d3b996dee09880c20dbe40dab96158ba1dfe220 Mon Sep 17 00:00:00 2001
From: Bruce Keeler <bruce@drangle.com>
Date: Sun, 28 Feb 2010 20:36:20 -0800
Subject: [PATCH] Implementation of grammars

---
 build/Makefile.in          |    2 +-
 src/Perl6/Actions.pm       |  186 +++++++++++++++++++++++++++++++++++---------
 src/Perl6/Grammar.pm       |   44 ++++++++---
 src/builtins/Grammar.pir   |   94 ----------------------
 src/core/Grammar.pm        |   16 ++++
 src/metamodel/ClassHOW.pir |    3 +-
 t/spectest.data            |    6 +-
 7 files changed, 206 insertions(+), 145 deletions(-)
 delete mode 100644 src/builtins/Grammar.pir
 create mode 100644 src/core/Grammar.pm

diff --git a/build/Makefile.in b/build/Makefile.in
index edfb97c..5a7a98b 100644
--- a/build/Makefile.in
+++ b/build/Makefile.in
@@ -98,7 +98,6 @@ BUILTINS_PIR = \
   src/builtins/EMPTY.pir \
   src/builtins/ParrotIter.pir \
   src/builtins/List.pir \
-  src/builtins/Grammar.pir \
   src/builtins/Parcel.pir \
   src/builtins/Bool.pir \
   src/builtins/Int.pir \
@@ -190,6 +189,7 @@ CORE_SOURCES = \
   src/core/Block.pm \
   src/core/Regex.pm \
   src/core/Junction.pm \
+  src/core/Grammar.pm \
   src/core/system.pm \
   src/cheats/match-bool.pm \
   src/cheats/setup-io.pm \
diff --git a/src/Perl6/Actions.pm b/src/Perl6/Actions.pm
index 5c65c0a..3ee710a 100644
--- a/src/Perl6/Actions.pm
+++ b/src/Perl6/Actions.pm
@@ -1035,33 +1035,135 @@ method method_def($/) {
     make $past;
 }
 
-method regex_declarator($/, $key?) {
-    if $key ne 'open' {
-        # Create regex code object.
-        # XXX TODO: token/regex/rule differences, signatures, traits.
-        my $past := Regex::P6Regex::Actions::buildsub($<p6regex>.ast);
-        $past := create_code_object($past, 'Regex', 0, '');
-
-        # Install in lexpad or namespace. XXX Need & on start of name?
-        my $name := ~$<deflongname>;
-        if $*SCOPE ne 'our' {
-            @BLOCK[0][0].push(PAST::Var.new( :name($name), :isdecl(1), 
-                                             :viviself($past), :scope('lexical') ) );
-            @BLOCK[0].symbol($name, :scope('lexical') );
-        }
+our %REGEX_MODIFIERS;
+method regex_declarator:sym<regex>($/, $key?) {
+    if ($key) {
+        my %h;
+        %REGEX_MODIFIERS := %h;
+    } else {
+        make $<regex_def>.ast;
+    }
+}
 
-        # Otherwise, package scoped; add something to loadinit to install them.
-        else {
-            @PACKAGE[0].block.loadinit.push(PAST::Op.new(
-                :pasttype('bind'),
-                PAST::Var.new( :name($name), :scope('package') ),
-                $past
-            ));
-            @BLOCK[0].symbol($name, :scope('package') );
+method regex_declarator:sym<token>($/, $key?) {
+    if ($key) {
+        my %h;
+        %h<r> := 1;
+        %REGEX_MODIFIERS := %h;
+    } else {
+        make $<regex_def>.ast;
+    }
+}
+
+method regex_declarator:sym<rule>($/, $key?) {
+    if ($key) {
+        my %h;
+        %h<r> := 1; %h<s> :=1;
+        %REGEX_MODIFIERS := %h;
+    } else {
+        make $<regex_def>.ast;
+    }
+}
+
+method regex_def($/, $key?) {
+    my $name := ~$<deflongname>[0];
+    my @MODIFIERS := Q:PIR {
+        %r = get_hll_global ['Regex';'P6Regex';'Actions'], '@MODIFIERS'
+    };
+    my $past;
+    if $key eq 'open' {
+        @MODIFIERS.unshift(%REGEX_MODIFIERS);
+        # The following is so that <sym> can work
+        Q:PIR {
+            $P0 = find_lex '$name'
+            set_hll_global ['Regex';'P6Regex';'Actions'], '$REGEXNAME', $P0
+        };
+        return 0;
+    } elsif $*MULTINESS eq 'proto' {
+        @MODIFIERS.shift;
+        @BLOCK.shift;
+        unless ($name) {
+            $/.CURSOR.panic('proto ' ~ ~$<sym> ~ 's cannot be anonymous');  
+        }
+#        $/.CURSOR.panic('proto ' ~ ~$<sym> ~ 's not implemented yet');
+        our @PACKAGE;
+        unless +@PACKAGE { 
+            $/.CURSOR.panic("Can not declare named " ~ ~$<sym> ~ " outside of a package");
+        }
+        my %table;
+        %table := @PACKAGE[0].methods();
+        unless %table{$name} { my %tmp; %table{$name} := %tmp; }
+        if %table{$name} {
+            $/.CURSOR.panic('Cannot declare proto ' ~ ~$<sym> ~ ' ' ~ $name ~ 
+                ' when another with this name was already declared');
         }
+        %table{$name}<code_ref> :=
+            create_code_object(
+                PAST::Block.new( :name($name),
+                    PAST::Op.new(
+                        PAST::Var.new( :name('self'), :scope('register') ),
+                        $name,
+                        :name('!protoregex'),
+                        :pasttype('callmethod')
+                    ),
+                    :lexical(0),
+                    :blocktype('method'),
+                    :pirflags(':anon'),
+                    :node($/)
+                ),
+                'Regex', 0, '');
+        %table{'!PREFIX__' ~ $name}<code_ref> :=
+            create_code_object(
+                PAST::Block.new( :name('!PREFIX__' ~ $name),
+                    PAST::Op.new(
+                        PAST::Var.new( :name('self'), :scope('register') ),
+                        $name,
+                        :name('!PREFIX__!protoregex'),
+                        :pasttype('callmethod')
+                    ),
+                    :blocktype('method'),
+                    :pirflags(':anon'),
+                    :lexical(0),
+                    :node($/)
+                ),
+                'Regex', 0, '');
+    } else {
+        @MODIFIERS.shift;
+        $past := Regex::P6Regex::Actions::buildsub($<p6regex>.ast, @BLOCK.shift);
+        $past.unshift(PAST::Op.new(
+            :pasttype('inline'),
+            :inline("    .local pmc self\n    self = find_lex 'self'")
+            ));
+        my $sig := $<signature> ?? $<signature>[0].ast !! Perl6::Compiler::Signature.new();
+        $sig.add_invocant();
+        $sig.set_default_parameter_type('Any');
+        $past[0].unshift(PAST::Var.new( :name('self'), :scope('lexical'), :isdecl(1), :viviself(sigiltype('$')) ));
+        $past.symbol('self', :scope('lexical'));
+        my $sig_setup_block := add_signature($past, $sig, 1);
+        $past.name($name);
+        $past.blocktype("declaration");
+        # If the methods are not :anon they'll conflict at class composition time.
+        $past.pirflags(':anon');
+        $past := create_code_object($past, 'Regex', 0, $sig_setup_block);
+        if ($name) {
+            our @PACKAGE;
+            unless +@PACKAGE { 
+                $/.CURSOR.panic("Can not declare named " ~ ~$<sym> ~ " outside of a package");
+            }
+            my %table;
+            %table := @PACKAGE[0].methods();
+            unless %table{$name} { my %tmp; %table{$name} := %tmp; }
 
-        make PAST::Var.new( :name($name) );
+            if %table{$name} {
+                $/.CURSOR.panic('Cannot declare ' ~ ~$<sym> ~ ' ' ~ $name ~ 
+                    ' when another with this name was already declared');
+            }
+            %table{$name}<code_ref> := $past;
+            make PAST::Stmts.new();
+            return 0;
+        }
     }
+    make $past;
 }
 
 method type_declarator:sym<enum>($/) {
@@ -1949,23 +2051,31 @@ class Perl6::RegexActions is Regex::P6Regex::Actions {
     method codeblock($/) {
         my $block := $<block>.ast;
         $block.blocktype('immediate');
-        my $past := 
-            PAST::Regex.new(
-                PAST::Stmts.new(
+        make bindmatch($block);
+    }
+    
+    method p6arglist($/) {
+        my $arglist := $<arglist>.ast;
+#        make bindmatch($arglist);
+        make $arglist;
+    }
+
+    sub bindmatch($past) {
+        PAST::Regex.new(
+            PAST::Stmts.new(
+                PAST::Op.new(
+                    PAST::Var.new( :name('$/') ),
                     PAST::Op.new(
-                        PAST::Var.new( :name('$/') ),
-                        PAST::Op.new(
-                            PAST::Var.new( :name('$¢') ),
-                            :name('MATCH'),
-                            :pasttype('callmethod')
-                        ),
-                        :pasttype('bind')
+                        PAST::Var.new( :name('$¢') ),
+                        :name('MATCH'),
+                        :pasttype('callmethod')
                     ),
-                    $block
+                    :pasttype('bind')
                 ),
-                :pasttype('pastnode')
-            );
-        make $past;
+                $past
+            ),
+            :pasttype('pastnode')
+        );
     }
 }
 
@@ -2321,3 +2431,5 @@ sub prevent_null_return($block) {
         $block[1].push(PAST::Op.new( :name('&Nil') ));
     }
 }
+
+# vim: ft=perl6
diff --git a/src/Perl6/Grammar.pm b/src/Perl6/Grammar.pm
index 41e1672..d325012 100644
--- a/src/Perl6/Grammar.pm
+++ b/src/Perl6/Grammar.pm
@@ -759,18 +759,28 @@ rule post_constraint {
     ]
 }
 
-rule regex_declarator {
+proto token regex_declarator { <...> }
+token regex_declarator:sym<rule> { 
+    <sym> {*} #= open
+    <regex_def> 
+}
+token regex_declarator:sym<token> { 
+    <sym> {*} #= open
+    <regex_def> 
+}
+token regex_declarator:sym<regex> { 
+    <sym> {*} #= open
+    <regex_def> 
+}
+
+rule regex_def {
     [
-    | $<proto>=[proto] [regex|token|rule] 
-      <deflongname> 
-      '{' '<...>' '}'<?ENDSTMT>
-    | $<sym>=[regex|token|rule]
-      <deflongname>
+      <deflongname>?
       <.newpad>
-      [ '(' <signature> ')' ]?
+      [ [ ':'?'(' <signature> ')'] | <trait> ]*
       {*} #= open
-      '{'<p6regex=.LANG('Regex','nibbler')>'}'<?ENDSTMT>
-    ]
+      '{'[ '<...>' |<p6regex=.LANG('Regex','nibbler')>]'}'<?ENDSTMT>
+    ] || <.panic: "Malformed regex">
 }
 
 proto token type_declarator { <...> }
@@ -1235,6 +1245,21 @@ grammar Perl6::Regex is Regex::P6Regex::Grammar {
     token codeblock {
         <block=.LANG('MAIN','block')>
     }
+
+    token assertion:sym<name> {
+        $<longname>=[\w+]
+            [
+            | <?before '>'>
+            | '=' <assertion>
+            | ':' <arglist>
+            | '(' <arglist=p6arglist> ')'
+            | <.normspace> <nibbler>
+            ]?
+    } 
+
+    token p6arglist {
+        <arglist=.LANG('MAIN','arglist')> 
+    }
 }
 
 
@@ -1285,4 +1310,3 @@ sub parse_name($name) {
         .return (list)
     }
 }
-
diff --git a/src/builtins/Grammar.pir b/src/builtins/Grammar.pir
deleted file mode 100644
index ab4fa01..0000000
--- a/src/builtins/Grammar.pir
+++ /dev/null
@@ -1,94 +0,0 @@
-## $Id$
-
-=head1 TITLE
-
-Grammar - Perl 6 Grammar class
-
-=head1 DESCRIPTION
-
-This file implements the Grammar class.
-
-=cut
-
-.sub '' :anon :init :load
-    .local pmc p6meta
-    p6meta = get_hll_global ['Mu'], '$!P6META'
-    p6meta.'new_class'('Grammar', 'parent'=>'Any')
-
-    # XXX pmichaud++ needs to fix this bunch. kplzthnxbai jnthn :-)
-    #p6meta.'new_class'('Grammar', 'parent'=>'Match')
-
-    #$P0 = get_root_namespace ['parrot';'PGE';'Grammar']
-    #$P0 = get_class $P0
-    #.const 'Sub' $P1 = 'Grammar.parse'
-    #$P0.'add_method'('parse', $P1)
-.end
-
-=head2 Methods
-
-=over
-
-=item parse(string)
-
-Parse a string according to the TOP rule in the grammar.
-
-=cut
-
-=item parse(topic)
-
-Invokes the TOP rule in the grammar on the given topic.
-
-=cut
-
-.namespace ['Grammar']
-.sub 'parse' :method :subid('Grammar.parse')
-    .param pmc topic
-    .param pmc options         :slurpy :named
-    .local pmc TOP
-
-    # If there's a TOP rule, invoke it.
-    push_eh no_TOP
-    TOP = find_method self, "TOP"
-    pop_eh
-    .local pmc match, p6meta
-    p6meta = get_hll_global ['Mu'], '$!P6META'
-    $P0 = p6meta.'get_parrotclass'(self)
-    $P0 = inspect $P0, 'namespace'
-    $P0 = $P0.'get_name'()
-    $S0 = shift $P0
-    $S0 = join '::', $P0
-    match = TOP(topic, options :named :flat, 'grammar' => $S0)
-    $P0 = getinterp
-    $P1 = $P0['lexpad';1]
-    $P1['$/'] = match
-    .return(match)
-
-  no_TOP:
-    pop_eh
-    'die'("The grammar has no TOP rule to invoke.")
-.end
-
-
-=item parsefile(filename)
-
-Reads in the file in filename and then invokes the TOP rule in the
-grammar on it.
-
-=cut
-
-.sub 'parsefile' :method
-    .param string filename
-    .param pmc options         :slurpy :named
-    $S0 = 'slurp'(filename)
-    .tailcall self.'parse'($S0, options :named :flat)
-.end
-
-=back
-
-=cut
-
-# Local Variables:
-#   mode: pir
-#   fill-column: 100
-# End:
-# vim: expandtab shiftwidth=4 ft=pir:
diff --git a/src/core/Grammar.pm b/src/core/Grammar.pm
new file mode 100644
index 0000000..f045243
--- /dev/null
+++ b/src/core/Grammar.pm
@@ -0,0 +1,16 @@
+class Grammar is Regex::Cursor {
+    method parsefile($file, *%options) {
+        my $fh = open($file, :r)
+            || die "$file: $!";
+        my $str = $fh.slurp;
+        self.parse($str, %options);
+    }
+}
+
+our sub make($ast) {
+    Q:PIR {
+        $P0 = find_dynamic_lex '$/'
+        $P1 = find_lex '$ast'
+        $P0.'!make'($P1)
+    }
+}
diff --git a/src/metamodel/ClassHOW.pir b/src/metamodel/ClassHOW.pir
index a9d338a..2f51316 100644
--- a/src/metamodel/ClassHOW.pir
+++ b/src/metamodel/ClassHOW.pir
@@ -108,7 +108,8 @@ Creates a new instance of the meta-class and returns it in an associated
 
     # Stash in metaclass instance.
   have_parrotclass:
-    how = new ['ClassHOW']
+    $P0 = typeof self
+    how = new [$P0]
     setattribute how, 'parrotclass', parrotclass
     $P0 = root_new ['parrot';'ResizablePMCArray']
     setattribute how, '$!composees', $P0
diff --git a/t/spectest.data b/t/spectest.data
index 6d16ff3..8ecca34 100644
--- a/t/spectest.data
+++ b/t/spectest.data
@@ -220,11 +220,13 @@ S04-statements/while.t
 # S05-capture/dot.t
 # S05-capture/named.t
 # S05-capture/subrule.t
-# S05-grammar/action-stubs.t
+S05-grammar/action-stubs.t
 # S05-grammar/inheritance.t
-# S05-grammar/methods.t
+S05-grammar/methods.t
 # S05-grammar/namespace.t
 # S05-grammar/parse_and_parsefile.t
+S05-grammar/protos.t
+S05-grammar/signatures.t
 # S05-grammar/ws.t
 # S05-mass/named-chars.t                                     # icu
 # S05-mass/properties-block.t                                # icu
-- 
1.7.0