Allow multiple alias subrule bindings (e.g., <abc=def=subrule>).

perl6 · Oct 20, 2009 · 49572a7 · 49572a7
1 parent 29c3519
commit 49572a7
Show file tree

Hide file tree

Showing 4 changed files with 3,158 additions and 2,944 deletions.
diff --git a/src/Regex/Cursor.pir b/src/Regex/Cursor.pir
@@ -26,6 +26,9 @@ grammars.
     $P0 = box 0
     set_global '$!generation', $P0
     $P0 = new ['Boolean']
+    assign $P0, 0
+    set_global '$!FALSE', $P0
+    $P0 = new ['Boolean']
     assign $P0, 1
     set_global '$!TRUE', $P0
     .return ()
@@ -95,39 +98,50 @@ for the Cursor if one hasn't been created yet.
     cstack_it = iter cstack
   cstack_loop:
     unless cstack_it goto cstack_done
-    .local pmc subcur, submatch
+    .local pmc subcur, submatch, names
     subcur = shift cstack_it
     # If the subcursor isn't bound with a name, skip it
-    $P0 = getattribute subcur, '$!names'
-    if null $P0 goto cstack_loop
-    subname = $P0
+    names = getattribute subcur, '$!names'
+    if null names goto cstack_loop
     $I0 = isa subcur, ['Regex';'Cursor']
     unless $I0 goto cstack_1
     submatch = subcur.'MATCH'()
     goto cstack_2
   cstack_1:
     submatch = subcur
   cstack_2:
+    # See if we have multiple binds
+    .local pmc names_it
+    subname = names
+    names_it = get_global '$!FALSE'
+    $I0 = index subname, '='
+    if $I0 < 0 goto cstack_subname
+    names_it = split '=', subname
+  cstack_subname_loop:
+    subname = shift names_it
+  cstack_subname:
     keyint = is_cclass .CCLASS_NUMERIC, subname, 0
     if null caparray goto cstack_bind
     $I0 = exists caphash[subname]
     unless $I0 goto cstack_bind
     if keyint goto cstack_array_int
     $P0 = match[subname]
     push $P0, submatch
-    goto cstack_loop
+    goto cstack_bind_done
   cstack_array_int:
     $I0 = subname
     $P0 = match[$I0]
     push $P0, submatch
-    goto cstack_loop
+    goto cstack_bind_done
   cstack_bind:
     if keyint goto cstack_bind_int
     match[subname] = submatch
-    goto cstack_loop
+    goto cstack_bind_done
   cstack_bind_int:
     $I0 = subname
     match[$I0] = submatch
+  cstack_bind_done:
+    if names_it goto cstack_subname_loop
     goto cstack_loop
   cstack_done:
 

diff --git a/src/Regex/P6Regex/Actions.pm b/src/Regex/P6Regex/Actions.pm
@@ -204,13 +204,9 @@ method metachar:sym<var>($/) {
     if $<quantified_atom> {
         $past := $<quantified_atom>[0].ast;
         if $past.pasttype eq 'quant' && $past[0].pasttype eq 'subrule' {
-            $past[0].subtype('capture');
-            $past[0].name($name);
-        }
-        elsif $past.pasttype eq 'subrule' { 
-            $past.subtype('capture');
-            $past.name($name); 
+            subrule_alias($past[0], $name);
         }
+        elsif $past.pasttype eq 'subrule' { subrule_alias($past, $name); }
         else {
             $past := PAST::Regex.new( $past, :name($name), :pasttype('subcapture'), :node($/) );
         }
@@ -311,7 +307,7 @@ method assertion:sym<name>($/) {
     my $past;
     if $<assertion> {
         $past := $<assertion>[0].ast;
-        $past.name($name);
+        subrule_alias($past, $name);
     }
     else {
         $past := PAST::Regex.new( $name, :name($name),
@@ -439,16 +435,29 @@ sub capnames($ast, $count) {
         }
     }
     elsif $pasttype eq 'subrule' && $ast.subtype eq 'capture' {
-        if $ast.name eq '' { 
-            $ast.name($count);
-            $count := $count + 1;
+        my $name := $ast.name;
+        if $name eq '' { $name := $count; $ast.name($name); }
+        my @names := Q:PIR {
+            $P0 = find_lex '$name'
+            $S0 = $P0
+            %r = split '=', $S0
+        };
+        for @names {
+            if $_ eq '0' || $_ > 0 { $count := $_ + 1; }
+            %capnames{$_} := 1;
         }
-        elsif $ast.name eq '0' || $ast.name > 0 { $count := $ast.name + 1; }
-        %capnames{$ast.name} := 1;
     }
     elsif $pasttype eq 'subcapture' {
-        if $ast.name eq '0' || $ast.name > 0 { $count := $ast.name + 1; }
-        %capnames{$ast.name} := 1;
+        my $name := $ast.name;
+        my @names := Q:PIR {
+            $P0 = find_lex '$name'
+            $S0 = $P0
+            %r = split '=', $S0
+        };
+        for @names {
+            if $_ eq '0' || $_ > 0 { $count := $_ + 1; }
+            %capnames{$_} := 1;
+        }
         my %x := capnames($ast[0], $count);
         for %x {
             %capnames{$_} := +%capnames{$_} + %x{$_};
@@ -472,3 +481,9 @@ sub backmod($ast, $backmod) {
     elsif $backmod eq ':!' || $backmod eq '!' { $ast.backtrack('g') }
     $ast;
 }
+
+sub subrule_alias($past, $name) {
+    if $past<aliased> { $name := $name ~ '=' ~ $past.name; }
+    $past.name($name);
+    $past<aliased> := 1;
+}