Skip to content
This repository

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Browse code

[GGE::Perl6Regex] implemented &before

This was possibly the hardest single commit so far, in terms of the time
it took and the thinking it required. Especially since it doesn't do very
much. A 'before' subrule call anchors the match at that point, checks if
it matches, and returns either a failed match or a zero-width successful
match.
  • Loading branch information...
commit 7c3c5bc4278c053cb61e03ba1ea38b5f35ab09a8 1 parent e6a9119
Carl Mäsak authored
18  lib/GGE/Exp.pm
@@ -84,10 +84,12 @@ class GGE::Exp is GGE::Match {
84 84
     method root-p6(:$debug) {
85 85
         my $code = CodeString.new();
86 86
         $code.unique(); # XXX: Remove this one when we do other real calls
87  
-        $code.emit( q[[sub ($target, :$debug) {
88  
-    my $mob = GGE::Match.new(:$target);
  87
+        $code.emit( q[[sub ($m, :$debug) {
  88
+    my $mob = GGE::Match.new($m);
  89
+    my $target = $mob.target;
  90
+    my $iscont = $mob.iscont;
89 91
     my $mfrom;
90  
-    my $cpos = 0;
  92
+    my $cpos = $mob.startpos;
91 93
     my $pos;
92 94
     my $rep;
93 95
     my $lastpos = $target.chars;
@@ -114,7 +116,8 @@ class GGE::Exp is GGE::Match {
114 116
             when 'try_match_cont' {
115 117
                 if $cutmark <= %0 { goto('fail_cut'); break; }
116 118
                 ++$cpos;
117  
-                goto('try_match');
  119
+                if $iscont { goto('try_match'); break; }
  120
+                goto('fail_rule');
118 121
             }
119 122
             when 'fail_rule' {
120 123
                 # $cutmark = %0 # XXX: Not needed yet
@@ -722,14 +725,17 @@ class GGE::Exp::Subrule is GGE::Exp does GGE::ShowContents {
722 725
         my %args = self.getargs($label, $next);
723 726
         my $subname = self.hash-access('subname');
724 727
         my ($captgen, $captsave, $captback) = self.gencapture($label);
  728
+        my $subarg = self.hash-access('arg') // ''
  729
+                        ?? $code.escape(self.hash-access('arg'))
  730
+                        !! '';
725 731
         $code.emit( q[[
726  
-            when '%L' {
  732
+            when '%L' { # grammar subrule %0
727 733
                 $captob = $captscope;
728 734
                 $captob.to = $pos;
729 735
                 unless $mob.can('%0') {
730 736
                     die "Unable to find regex '%0'";
731 737
                 }
732  
-                $captob = $captob.%0(); ]], $subname, |%args);
  738
+                $captob = $captob.%0(%1); ]], $subname, $subarg, |%args);
733 739
         if self.hash-access('iszerowidth') {
734 740
             my $test = self.hash-access('isnegated') ?? 'unless' !! 'if';
735 741
             $code.emit( q[[
14  lib/GGE/Match.pm
... ...
@@ -1,5 +1,8 @@
1 1
 use v6;
2 2
 
  3
+# XXX: See the file lib/GGE/Perl6Regex.pm for an explanation.
  4
+class GGE::Perl6Regex {}
  5
+
3 6
 # This is a workaround. See the postcircumfix:<{ }> comments below.
4 7
 class Store {
5 8
     has %!hash is rw;
@@ -23,6 +26,8 @@ class GGE::Match {
23 26
     has $.target;
24 27
     has $.from is rw = 0;
25 28
     has $.to is rw = 0;
  29
+    has $.iscont = False;
  30
+    has $.startpos = 0;
26 31
     has $!store = Store.new;
27 32
     has $!ast;
28 33
 
@@ -31,9 +36,14 @@ class GGE::Match {
31 36
         self.bless(*, |%_);
32 37
     }
33 38
 
34  
-    multi method new(GGE::Match $match, :$pos) {
  39
+    multi method new(Str $target) {
  40
+        self.new(:$target, :from(0), :to(-1), :iscont(True));
  41
+    }
  42
+
  43
+    multi method new(GGE::Match $match) {
35 44
         defined $match ?? self.new(:target($match.target), :from($match.from),
36  
-                                   :to(-1))
  45
+                                   :to(-1), :iscont(False),
  46
+                                   :startpos($match.to))
37 47
                        !! self.new();
38 48
     }
39 49
 
1  lib/GGE/OPTable.pm
@@ -93,6 +93,7 @@ class GGE::OPTable {
93 93
                                    !! GGE::Match.new(:target($mob), :from(0), :to(0));
94 94
         my $target = $mob ~~ GGE::Match ?? $mob.target !! $mob;
95 95
         my $pos = $mob ~~ GGE::Match ?? $mob.to !! 0;
  96
+        $m.from = $pos;
96 97
         my $tighter = defined %opts<tighter> && %!tokens.exists(%opts<tighter>)
97 98
                         ?? %!tokens{%opts<tighter>}<precedence>
98 99
                         !! '';
34  lib/GGE/Perl6Regex.pm
@@ -7,7 +7,12 @@ class GGE::Exp::WS is GGE::Exp::Subrule {
7 7
     method contents() { undef }
8 8
 }
9 9
 
10  
-class GGE::Perl6Regex {
  10
+# XXX: why 'is also'? Because we'd really like to do something like
  11
+# &::<GGE::Perl6Regex::parse_regex> in GGE::Match::before (and after), but
  12
+# that syntax isn't implemented yet. Thus, we do the next best thing and
  13
+# declare the GGE::Perl6Regex class in the GGE::Match module, and re-open it
  14
+# here.
  15
+class GGE::Perl6Regex is also {
11 16
     has GGE::Exp $!exp;
12 17
     has Callable $!binary;
13 18
 
@@ -124,9 +129,9 @@ class GGE::Perl6Regex {
124 129
         $!binary($target, :$debug);
125 130
     }
126 131
 
127  
-    sub parse_regex($mob, :$tighter) {
128  
-        my $p = $optable.parse($mob, :$tighter);
129  
-        return $p;
  132
+    # RAKUDO: Cannot call a sub named 'regex'.
  133
+    sub parse_regex($mob, :$tighter, :$stop) {
  134
+        return $optable.parse($mob, :$tighter, :$stop);
130 135
     }
131 136
 
132 137
     sub parse_term($mob) {
@@ -264,7 +269,15 @@ class GGE::Perl6Regex {
264 269
         }
265 270
         my ($subname, $pos) = parse_subname($target, $mob.to);
266 271
         my $cname = $subname;
267  
-        if $target.substr($pos, 1) eq '=' {
  272
+        if $target.substr($pos, 1) eq ' ' {
  273
+            $m.to = ++$pos;
  274
+            my $arg = parse_regex($m, :stop('>'));
  275
+            return $m unless $arg;
  276
+            $m.hash-access('arg') = ~$arg;
  277
+            $pos = $arg.to;
  278
+            $m.to = -1;
  279
+        }
  280
+        elsif $target.substr($pos, 1) eq '=' {
268 281
             ++$pos;
269 282
             ($subname, $pos) = parse_subname($target, $pos);
270 283
         }
@@ -754,3 +767,14 @@ class GGE::Perl6Regex {
754 767
         return $cexp;
755 768
     }
756 769
 }
  770
+
  771
+class GGE::Match is also {
  772
+    method before($pattern) {
  773
+        my $rule = GGE::Perl6Regex.new($pattern);
  774
+        my $mob = $rule(self);
  775
+        if $mob { # 'before' matches are always zero-width
  776
+            $mob.to = $mob.from;
  777
+        }
  778
+        return $mob;
  779
+    }
  780
+}

0 notes on commit 7c3c5bc

Please sign in to comment.
Something went wrong with that request. Please try again.