Changeset 21819 for src/perl6

Timestamp:

08/07/08 11:01:41 (4 months ago)

Author:

lwall

Message:

[STD vs t] user-defined prefix, infix, and postfix ops now derive new languages
(no support for equiv or assoc traits yet, nor for circumfix etc.)
start of support for $?PARSER, now parses 99.74% of t/
traits and sigs may now be intermixed
an anonumous subname may be represented with '&' in sub & is foo {...}
now parses 99.74% of t

Location:

src/perl6

Files:

• Cursor.pmc (modified) (2 diffs)
• STD.pm (modified) (12 diffs)
• gimme5 (modified) (2 diffs)
• mangle.pl (modified) (1 diff)

src/perl6/Cursor.pmc

@@ -12 +12 @@
 our $DEBUG = $ENV{STD5DEBUG} // 0;
 $::DEBUG = $DEBUG;
+
+# various bits of info useful for error messages
 $::HIGHWATER = 0;
 $::HIGHMESS = '';
@@ -918 +920 @@
 sub add_macro { my $lang = shift;
     my $start = shift;
+    state $GEN = "500";
     $lang->{_from} = $start->{_from};
     my $name = $lang->text;
+    my $WHAT = ref $lang;
     if ($name =~ s/:/:sym/) {
-        print "macro $name\n";
-        eval <<'END';
-#package $genpkg;
-#use Moose ':all' => { -prefix => 'moose_' };
-#moose_extends('$WHAT');
-#moose_with(" . join(',', map {"'$_'"} @newmix) . ");
+        my ($sym) = $name =~ /:sym(.*)/;
+        if ($sym =~ s/^«(.*)»$/$1/) {
+            my $ok = "'";
+            for my $try (qw( ' / ! : ; | + - = )) {
+                $ok = $try, last if index($sym,$try) < 0;
+            }
+            $sym = $ok . $sym . $ok;
+        }
+
+        my $rule = "token $name { <sym> }";
+
+        my $mangle = $name;
+        $mangle =~ s/^(\w*):(sym)?//;
+        my $category = $1;
+        my @list;
+        if ($mangle =~ s/^<(.*)>$/$1/ or
+            $mangle =~ s/^«(.*)»$/$1/) {
+            $mangle =~ s/\\(.)/$1/g;
+            @list = $mangle =~ /(\S+)/g;
+        }
+        elsif ($mangle =~ s/^\[(.*)\]$/$1/ or
+            $mangle =~ s/^\{(.*)\}$/$1/) {
+            @list = eval $mangle;
+        }
+        else {
+            @list = $mangle;
+        }
+        $mangle = ::mangle(@list);
+        $mangle = $category . '__S_' . sprintf("%03d",$GEN++) . $mangle;
+
+        # XXX assuming no equiv
+        my $coercion = 'Additive';
+        if ($name =~ /^prefix:/) {
+            if ($sym =~ /^\W/) {
+                $coercion = 'Symbolic_unary';
+            }
+            else {
+                $coercion = 'Named_unary';
+            }
+        }
+        elsif ($name =~ /^postfix:/) {
+            $coercion = 'Methodcall';
+        }
+
+        my $genpkg = $WHAT . '::_' . $mangle;
+        my $e = <<"END";
+package $genpkg;
+use Moose ':all' => { -prefix => 'moose_' };
+moose_extends('$WHAT');
+
+# $rule
+
+my \$retree = {
+    '$mangle' => bless({
+        'kind' => 'token',
+        'min' => 12345,
+        're' => bless({
+            'a' => 0,
+            'i' => 0,
+            'min' => 12345,
+            'name' => 'sym',
+            'rest' => '',
+            'sym' => q$sym,
+        }, 'RE_method'),
+    }, 'RE'),
+};
+
+sub $mangle {
+    my \$self = shift;
+    local \$CTX = \$self->callm() if \$::DEBUG & DEBUG::trace_call;
+    if (\$self->{_peek}) {
+        return \$self->_AUTOLEXpeek('$mangle',\$retree)
+    }
+    my %args = \@_;
+    my \$sym = \$args{sym} // q$sym;
+
+    my \$C = \$self;
+    \$C->{'sym'} = \$sym;
+
+    \$self->_MATCHIFY( Cursor::lazymap sub { STD::$coercion->coerce(\$_[0]) },
+        \$C->_SYM(\$sym, 0)
+    );
+}
+1;
 END
+        eval $e or die "Can't create $name: $@\n";
+        $::PARSER = $lang->cursor_fresh($genpkg);
     }
     $lang;

src/perl6/STD.pm

@@ -6 +6 @@
 my @PKGS;
 my $GOAL is context = "(eof)";
+my $PARSER is context<rw>;
 
 # random rule for debugging, please ignore
@@ -532 +533 @@
 # statement semantics
 rule statementlist {
+    :my $PARSER is context<rw> = self;
     [
     | <?before <[\)\]\}]> >
@@ -563 +565 @@
     :my $endargs is context = -1;
     <!before <[\)\]\}]> >
+    <!!{ bless $¢, ref $PARSER; }>
     [
     | <label> <statement>                        {*}            #= label
@@ -807 +810 @@
     | <circumfix>
     | <dotty>
-#    | <subcall>
     | <value>
     | <capterm>
@@ -933 +935 @@
 }
 
-# Note: backtracks, or we'd never get to parse [LIST] on seeing [+ and such.
-# (Also backtracks if on \op when no \op infix exists.)
 regex prefix_circumfix_meta_operator:reduce (--> List_prefix) {
     $<s> = (
@@ -1515 +1515 @@
 token deflongname {
     <name>
-    [ <colonpair>+ { $¢ = $¢.add_macro($<name>); } ]?
+    # XXX too soon
+    [ <colonpair>+ { $¢.add_macro($<name>); } ]?
 }
 
@@ -1541 +1542 @@
 token subshortname {
     [
-    | <category> <colonpair>+
+    | <category>
+        [ <colonpair>+ { $¢.add_macro($<category>); } ]?
     | <desigilname>
     ]
@@ -2346 +2348 @@
 
 rule routine_def {
-    <deflongname>?  <multisig>?
-    <trait>*
+    [ '&'<deflongname>? | <deflongname> ]? [ <multisig> | <trait> ]*
+    <!!{ bless $¢, ref $PARSER; }>
     <block>
 }
@@ -2353 +2355 @@
 rule method_def {
     [
-    | '!'?<longname>  <multisig>?
+    | '!'?<longname> [ <multisig> | <trait> ]*
     | <sigil> '.'
         [
@@ -2361 +2363 @@
         | <?before '<'> <postcircumfix>
         ]
-    ]
-    <trait>*
+        <trait>*
+    ]
     <block>
 }
@@ -2368 +2370 @@
 rule regex_def {
     <longname>?
-    [ ':'?'(' <signature> ')']?
-    <trait>*
+    [ [ ':'?'(' <signature> ')'] | <trait> ]*
     <regex_block>
 }
 
-# XXX redundant with routine_def?
 rule macro_def {
-    <deflongname>?  <multisig>?
-    <trait>*
+    [ '&'<deflongname>? | <deflongname> ]? [ <multisig> | <trait> ]*
     <block>
 }
@@ -2384 +2383 @@
     | <trait_verb>
     | <trait_auxiliary>
+    | <colonpair>
     ]
 }

src/perl6/gimme5

@@ -71 +71 @@
 sub un6 {
     my $f = shift;
+    #my $trace = $f =~ /PARSER/;
     my $t;
     $f =~ s/\\x([0-9a-fA-F]{3,4})/\\x{$1}/g;
     $f =~ s!\$([0-9]+)!\$\$C{$1}!g;
     while ($f ne "") {
+        #print "$f\n" if $trace;
         $f =~ s/^\)</.</                        and $t .= ')', next;
         $f =~ s/^\.\(/(/                        and $t .= '->', next;
@@ -184 +186 @@
         $f =~ s/^\bwhile\s+(.*?) \{/($1) {/     and $t .= qq/while /, next;
         $f =~ s/^\bfor\s+(.*?) \{/($1) {/       and $t .= qq/for /, next;
-        $f =~ s/^\bmy\s+(?:[A-Z]\w+)?\s*([\$\@%]\w+)\s+is\s+context(?:<rw>)?\s*(?:is\s*rw)?\s*=\s*(.*);/$2;/s
+        $f =~ s/^\bmy\s+(?:[A-Z]\w+)?\s*([\$\@%]\w+)\s+is\s+context(?:<rw>)?\s*(?:is\s*rw)?\s*=(\s*.*);/$2;/s
                                                 and $t .= qq/local $1 = /, $OUR{$1}++, next;
         $f =~ s/^\bdo given\s+(.*?\S)\s+\{/$1; if (0) {}/

src/perl6/mangle.pl

@@ -37 +37 @@
         s/\?/Question/g;
         s/\//Slash/g;
-        s/(\W)/sprintf("_%02x_",ord($1))/eg;
+        s/([^a-zA-Z_0-9])/sprintf("_%02x_",ord($1))/eg;
     }
     join '_', @list;