From d38b8605ec96ce8128104a6bf66281e66fc9a309 Mon Sep 17 00:00:00 2001
From: Stefan O'Rear <stefanor@cox.net>
Date: Sat, 17 Jul 2010 19:03:52 -0700
Subject: [PATCH] Implement parsing for package, module, grammar, role

---
 Decl.pm           |  9 +++++----
 Niecza/Actions.pm | 36 +++++++++++++++++++++---------------
 2 files changed, 26 insertions(+), 19 deletions(-)

diff --git a/Decl.pm b/Decl.pm
index da6227e4..d601860e 100644
--- a/Decl.pm
+++ b/Decl.pm
@@ -190,6 +190,7 @@ use CgOp;
 
     has name => (is => 'ro', isa => 'Str', predicate => 'has_name');
     has var  => (is => 'ro', isa => 'Str', required => 1);
+    has bodyvar => (is => 'ro', isa => 'Str');
     has stub => (is => 'ro', isa => 'Bool', default => 0);
     has parents => (is => 'ro', isa => 'ArrayRef', default => sub { [] });
     has body => (is => 'ro', isa => 'Body');
@@ -199,7 +200,7 @@ use CgOp;
         if ($self->stub) {
             ($self->var, $self->var . '!HOW');
         } else {
-            ($self->var, $self->var . '!HOW', $self->var . '!BODY');
+            ($self->var, $self->var . '!HOW', $self->bodyvar);
         }
     }
 
@@ -225,7 +226,7 @@ use CgOp;
             # a BEGIN.
             CgOp::proto_var($self->var, CgOp::null('Variable')),
 
-            CgOp::proto_var($self->var . '!BODY',
+            CgOp::proto_var($self->bodyvar,
                 CgOp::newscalar(
                     CgOp::protosub($self->body))),
             CgOp::scopedlex($self->var,
@@ -239,8 +240,8 @@ use CgOp;
             CgOp::share_lex($self->var),
             ($self->stub ? () :
                 ($body->mainline ?
-                    CgOp::share_lex($self->var . '!BODY') :
-                    CgOp::clone_lex($self->var . '!BODY'))));
+                    CgOp::share_lex($self->bodyvar) :
+                    CgOp::clone_lex($self->bodyvar))));
     }
 
     sub write   {
diff --git a/Niecza/Actions.pm b/Niecza/Actions.pm
index 47bedd5d..52956d8a 100644
--- a/Niecza/Actions.pm
+++ b/Niecza/Actions.pm
@@ -819,26 +819,28 @@ sub statement_control__S_until { my ($cl, $M) = @_;
         until => 1, once => 0);
 }
 
+# All package defs have a couple things in common - a special-ish block,
+# with a special decl, and some nice runtimey code
 sub package_def { my ($cl, $M) = @_;
-    if ($::PKGDECL ne 'class') {
-        $M->sorry('Non-class package definitions are not yet supported');
-        return;
-    }
     my $scope = $::SCOPE;
     if (!$M->{longname}[0]) {
         $scope = 'anon';
     }
     if ($::SCOPE ne 'anon' && $::SCOPE ne 'my') {
-        $M->sorry('Non-lexical class definitions are not yet supported');
+        $M->sorry('Non-lexical package definitions are not yet supported');
         return;
     }
     my $name = $M->{longname}[0] ?
         $cl->mangle_longname($M->{longname}[0]) : 'ANON';
     my $outer = $cl->get_outer($::CURLEX);
     my $outervar = $::SCOPE eq 'my' ? $name : $cl->gensym;
-    if (!$M->{decl}{stub}) {
 
-        my $stmts = $M->{statementlist} // $M->{blockoid};
+    my $decltype = 'Decl::' . ucfirst $::PKGDECL;
+    my $blocktype = $::PKGDECL;
+    my $bodyvar = $cl->gensym;
+
+    if (($blocktype eq 'class' || $blocktype eq 'grammar')
+            && !$M->{decl}{stub}) {
         unshift @{ $::CURLEX->{'!decls'} //= [] },
             map { $_->{_ast} } @{ $M->{trait} };
 
@@ -849,29 +851,33 @@ sub package_def { my ($cl, $M) = @_;
             }
 
             push @{ $::CURLEX->{'!decls'} //= [] },
-                Decl::Super->new(name => 'Any');
+                Decl::Super->new(name => ($blocktype eq 'grammar' ?
+                        'Cursor' : 'Any'));
         }
+    }
 
-        my $cbody = $cl->sl_to_block('class', $stmts->{_ast},
+    if (!$M->{decl}{stub}) {
+        my $stmts = $M->{statementlist} // $M->{blockoid};
+
+        my $cbody = $cl->sl_to_block($blocktype, $stmts->{_ast},
             name => $name);
-        my $cdecl = Decl::Class->new(
+        my $cdecl = $decltype->new(
             name    => $name,
             var     => $outervar,
+            bodyvar => $bodyvar,
             body    => $cbody);
         push @{ $outer->{'!decls'} //= [] }, $cdecl;
         $M->{_ast} = Op::StatementList->new(
             children => [
                 Op::CallSub->new(
-                    invocant => Op::Lexical->new(name => $outervar . '!BODY')),
+                    invocant => Op::Lexical->new(name => $bodyvar)),
                 Op::Lexical->new(name => $outervar)]);
     } else {
-
-        push @{ $outer->{'!decls'} //= [] }, Decl::Class->new(
+        push @{ $outer->{'!decls'} //= [] }, $decltype->new(
             name    => $name,
             var     => $outervar,
             stub    => 1);
-
-        #XXX: What should this return?
+        # XXX return what?
     }
 }