Add alias capturing of non-subrules.

perl6 · Oct 13, 2009 · 3de5a4f · 3de5a4f
1 parent 568cc9b
commit 3de5a4f
Show file tree

Hide file tree

Showing 2 changed files with 58 additions and 1 deletion.
diff --git a/src/PAST/Compiler-Regex.pir b/src/PAST/Compiler-Regex.pir
@@ -792,6 +792,55 @@ Code for initial regex scan.
 .end
 
 
+=item subcapture(PAST::Regex node)
+
+Perform a subcapture (capture of a portion of a regex).
+
+=cut
+
+.sub 'subcapture' :method :multi(_, ['PAST';'Regex'])
+    .param pmc node
+
+    .local pmc cur, pos, tgt, fail
+    (cur, pos, tgt, fail) = self.'!rxregs'('cur pos tgt fail')
+    .local pmc ops, cpast, cpost
+    ops = self.'post_new'('Ops', 'node'=>node, 'result'=>cur)
+    cpast = node[0]
+    cpost = self.'post_regex'(cpast)
+
+    .local pmc name
+    $P0 = node.'name'()
+    name = self.'as_post'($P0, 'rtype'=>'*')
+
+    .local string rxname 
+    rxname = self.'unique'('rxcap_')
+
+    .local pmc caplabel, donelabel
+    $S0 = concat rxname, '_fail'
+    caplabel = self.'post_new'('Label', 'result'=>$S0)
+    $S0 = concat rxname, '_done'
+    donelabel = self.'post_new'('Label', 'result'=>$S0)
+
+    ops.'push_pirop'('inline', name, 'inline'=>'  # rx subcapture %0')
+    ops.'push_pirop'('set_addr', '$I10', caplabel)
+    self.'!cursorop'(ops, '!mark_push', 0, 0, pos, '$I10')
+    ops.'push'(cpost)
+    ops.'push_pirop'('set_addr', '$I10', caplabel)
+    self.'!cursorop'(ops, '!mark_peek', 2, '$I12', '$I11', '$I10')
+    self.'!cursorop'(ops, '!cursor_pos', 0, '$I11')
+    self.'!cursorop'(ops, '!cursor_start', 1, '$P10')
+    ops.'push_pirop'('callmethod', '"!cursor_pass"', '$P10', pos, '""')
+    ops.'push'(name)
+    self.'!cursorop'(ops, '!mark_push', 0, 0, -1, 0, '$P10')
+    ops.'push_pirop'('callmethod', '"!cursor_names"', '$P10', name)
+    ops.'push_pirop'('goto', donelabel)
+    ops.'push'(caplabel)
+    ops.'push_pirop'('goto', fail)
+    ops.'push'(donelabel)
+    .return (ops)
+.end
+
+
 =item subrule(PAST::Regex node)
 
 Perform a subrule call.
@@ -808,7 +857,6 @@ Perform a subrule call.
     .local pmc name
     $P0 = node.'name'()
     name = self.'as_post'($P0, 'rtype'=>'*')
-    ops.'push'(name)
 
     .local pmc cpost, posargs, namedargs, subpost
     (cpost, posargs, namedargs) = self.'post_children'(node, 'signature'=>'v:')
@@ -832,6 +880,7 @@ Perform a subrule call.
     ops.'push_pirop'('callmethod', '"pos"', '$P10', 'result'=>pos)
     self.'!cursorop'(ops, '!mark_push', 0, 0, -1, 0, '$P10')
     if subtype == 'method' goto done
+    ops.'push'(name)
     ops.'push_pirop'('callmethod', '"!cursor_names"', '$P10', name)
   done:
     .return (ops)

diff --git a/src/Regex/P6Regex/Actions.pm b/src/Regex/P6Regex/Actions.pm
@@ -177,6 +177,9 @@ method metachar:sym<var>($/) {
             $past.subtype('capture');
             $past.name($name); 
         }
+        else {
+            $past := PAST::Regex.new( $past, :name($name), :pasttype('subcapture'));
+        }
     }
     else {
         $past := PAST::Regex.new( '!BACKREF', $name, :pasttype('subrule'),
@@ -349,6 +352,11 @@ sub capnames($ast, $count) {
         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; }
+        my %x := capnames($ast[0], $count);
+        $count := %x{''};
+    }
     elsif $pasttype eq 'quant' {
         my %astcap := capnames($ast[0], $count);
         for %astcap {