Changeset 18681

Timestamp:

10/26/07 12:32:12 (13 months ago)

Author:

lwall

Message:

Cursor tweaks, new precedence for x and ~

Location:

src

Files:

• Pugs/Parser/Operator.hs (modified) (3 diffs)
• perl5/p5embed.c (modified) (1 diff)
• perl6/Cursor.pm (modified) (14 diffs)

src/Pugs/Parser/Operator.hs

@@ -48 +48 @@
     : multLevel                     -- Multiplicative
     : Map.foldWithKey foldInfix addiLevel (r_infix tights) -- Additive (user-definable)
+    : replLevel                     -- Replication
+    : concLevel                     -- Concatenation
     : junaLevel                     -- Junctive And
     : junoLevel                     -- Junctive Or
@@ -66 +68 @@
         -- _ -> error $ "Impossible: " ++ show op ++ " has no assoc?"
 
-termLevel, methLevel, incrLevel, expoLevel, symbLevel, multLevel, addiLevel, junaLevel, junoLevel :: [RuleOperator Exp]
+termLevel, methLevel, incrLevel, expoLevel, symbLevel, multLevel, addiLevel, replLevel, concLevel, junaLevel, junoLevel :: [RuleOperator Exp]
 termLevel = circumOps (Set.singleton (MkOpName (cast "\\( )")))
 methLevel = methOps (opWords " . .+ .? .* .+ .() .[] .{} .<<>> .= ")
@@ -72 +74 @@
 expoLevel = rightOps (opWords " ** ")
 symbLevel = preSyn (Set.singleton (MkOpName (cast "|"))) ++ preOps symbPreops
-multLevel = leftOps (opWords " * / % x xx +& +< +> ~& ~< ~> ?& ")
-addiLevel = leftOps (opWords " + - ~ +| +^ ~| ~^ ?| ")
+multLevel = leftOps (opWords " * / % +& +< +> ~& ~< ~> ?& ")
+addiLevel = leftOps (opWords " + - +| +^ ~| ~^ ?| ")
+replLevel = leftOps (opWords " x xx ")
+concLevel = leftOps (opWords " ~ ")
 junaLevel = listOps (opWords " & ")
 junoLevel = listOps (opWords " ^ | ")

src/perl5/p5embed.c

@@ -314 +314 @@
 #endif
 #ifdef PERL_SYS_INIT3
-    PERL_SYS_INIT3(&argc,&argv,&env);
+    PERL_SYS_INIT3(&argc,&argv,&environ);
 #endif
 

src/perl6/Cursor.pm

@@ -8 +8 @@
 # most cursors just copy forward the previous value of the following two items:
 has $.orig;        # per match, the original string we are matching against
-our %lexer;       # per language, the cache of lexers, keyed by (|) location
+our %lexers;       # per language, the cache of lexers, keyed by (|) location
 
 has Bool $.bool is rw = 1;
@@ -19 +19 @@
 has $!item;
 
-method lexer { %lexer }   # XXX should be different per language, sigh
+method lexers { %lexers }   # XXX should be different per language, sigh
 
 my $fakepos = 1;
@@ -25 +25 @@
 method _AUTOLEXpeek ($key) {
     die "Null key" if $key eq '';
-    if %.lexer{$key} {
+    if %.lexers{$key} {
         if %+AUTOLEXED{$key} {   # no left recursion allowed in lexer!
-            die "left recursion in $key" if $fakepos == %+AUTOLEXED{$key};
+            die "Left recursion in $key" if $fakepos == %+AUTOLEXED{$key};
+            warn "Suppressing lexer recursion on $key";
             return -> $¢ { '' };  # (but if we advanced just assume a :: here)
         }
-        elsif %.lexer{$key}.WHAT eq Hash {
-            return %.lexer{$key}<lexer> // -> $¢ { '' };
-        }
-        say "oops ", $key.WHAT;
+        elsif %.lexers{$key}.WHAT eq Hash {
+            return %.lexers{$key}<lexer> // -> $¢ { '' };
+        }
+        else {
+            say "oops ", $key.WHAT;
+        }
     }
     my $ast = eval("tmpyaml/$key.yml".slurp, :lang<yaml>);
-    %.lexer{$key} = hash(:$ast, :lexer(-> $¢ { '' }));
+    %.lexers{$key} = hash(:$ast, :lexer(-> $¢ { '' }));
     my $lexer = self._AUTOLEXgen($key,$ast);
-    %.lexer{$key}<lexer> = $lexer;
+    %.lexers{$key}<lexer> = $lexer;
     return $lexer;
 }
 
 method _AUTOLEXnow ($key) {
-    if %.lexer.exists($key) {
-        return %.lexer{$key}<lexer>;
+    if %.lexers.exists($key) {
+        return %.lexers{$key}<lexer>;
     }
     my %AUTOLEXED is context<rw>;
     my $ast = eval("tmpyaml/$key.yml".slurp, :lang<yaml>);
-    %.lexer{$key} = hash(:$ast, :lexer(undef));
+    %.lexers{$key} = hash(:$ast, :lexer(undef));
     my $lexer = self._AUTOLEXgen($key,$ast);
-    %.lexer{$key}<lexer> = $lexer;
+    %.lexers{$key}<lexer> = $lexer;
     return $lexer;
 }
@@ -60 +63 @@
     %+AUTOLEXED{$key} = $oldfakepos;
     sub ($¢) {
+        1 while $lexer ~~ s:P5/\n[\x20\t]*\n/\n/;
         $lexer;
     }
@@ -106 +110 @@
     my $r = self.new(
         :orig(self.orig),
-        #:lexer(self.lexer),
+        #:lexers(self.lexers),
         :from($fpos),
         :to($tpos),
@@ -120 +124 @@
     self.new(
         :orig(self.orig),
-        #:lexer(self.lexer),
+        #:lexers(self.lexers),
         :from(self.pos // 0),
         :to($tpos),
@@ -132 +136 @@
     self.new(
         :orig(self.orig),
-        #:lexer(self.lexer),
+        #:lexers(self.lexers),
         :pos($fpos),
         :from($fpos),
@@ -719 +723 @@
 
 our class RE_bracket is REbase {
-    method lexer ($¢) { here; "(\n" ~ indent(self.<re>.lexer($¢)) ~ "\n)" }
+    method lexer ($¢) { here; indent("\n(\n" ~ indent(self.<re>.lexer($¢)) ~ "\n)") }
 }
 
@@ -791 +795 @@
             when 'sym' {
                 $fakepos++;
-                return self.<sym>;
+                return quotemeta(self.<sym>);
             }
             when 'alpha' {
@@ -839 +843 @@
 
 our class RE_method_str is REbase {
-    #method lexer ($¢) { ... }
+    method lexer ($¢) {
+        my $name = self.<name>;
+        here $name;
+        my $str = self.<str>;
+        given $name {
+            when 'lex1' {
+                return '[]';
+            }
+            when 'panic' | 'obs' {
+                $+PURE = 0;
+                return '';
+            }
+            default {
+                my $lexer = $¢.$name($str, '?')[0];
+                return $lexer($¢);
+            }
+        }
+    }
 }
 
@@ -880 +901 @@
 
 our class RE_paren is REbase {
-    method lexer ($¢) { here; "(\n" ~ indent(self.<re>.lexer($¢)) ~ "\n)" }
+    method lexer ($¢) { here; indent("\n(\n" ~ indent(self.<re>.lexer($¢)) ~ "\n)") }
 }
 
@@ -946 +967 @@
             last unless $PURE;
         }
-        join '', @result;
+        join ' ', @result;
     }
 }
@@ -952 +973 @@
 our class RE_string is REbase {
     # XXX needs quoting
-    method lexer ($¢) {
+    method lexer ($c) {
         here ~self.<text>;
         my $text = self.<text>;
         $fakepos++ if self.<min>;
-        $text ~~ s:P5:g/([][\\*+?.^${}<>()]#)/\\$0/;
-        $text ~~ s:P5:g/\s/\\s/;  # XXX bogus, but who uses ws in tokens?
-        $text;
+        quotemeta($text);
     }
 }
@@ -987 +1006 @@
             $minfakepos = $oldfakepos if $fakepos == $oldfakepos;
         }
-        my $result = "(\n" ~ indent(join "\n| ", @result) ~ "\n)";
+        my $result = "\n(\n  " ~ indent(join "\n| ", @result) ~ "\n)";
         say $result;
         $fakepos = $minfakepos;  # Did all branches advance?