Permalink
Browse files

[GGE] Further adaptations to Rakudo master

- Replaced more Str.trans calls with Str.subst calls.

- 'our'-scoped the workarounded enums so that they'll be reachable from
  outside the GGE::Exp module.

- Worked around the lack of hash slices.

- Turned off calls to .name on enums, because these are workarounded as
  functions returning ints.

- Added a {} to some function calls whose function has a '%hash? is copy'
  parameter.

- Added stringifications to a lot of places, because Regex::Match is not cool.

- Made the 'parse_*' subs in GGE::Perl6Regex 'our'-scoped so that they could
  be referred to in their package.

- Discovered (and fixed) a bug wherein a Nil value evaluated as defined
  because it had been stored in a variable and expanded into a Seq object,
  contrary to S02.

- Worked around the lack of functioning $/ in closures in Str.subst, by
  writing a sub 'replace_x' doing string plumbing.
  • Loading branch information...
1 parent e55d0e9 commit 131525a3523736a651ef0c303a04672526bebf4d @masak committed Apr 18, 2010
Showing with 91 additions and 50 deletions.
  1. +29 −15 lib/GGE/Exp.pm
  2. +2 −1 lib/GGE/Match.pm
  3. +38 −30 lib/GGE/Perl6Regex.pm
  4. +11 −2 t/perl6regex/01-regex.t
  5. +11 −2 test-regex
View
@@ -19,7 +19,7 @@ class CodeString {
}
method escape($string) {
- q['] ~ $string.trans( [ q['], q[\\] ] => [ q[\\'], q[\\\\] ] ) ~ q['];
+ q['] ~ $string.subst("\\", "\\\\").subst("'", "\\'") ~ q['];
}
method unique($prefix = '') {
@@ -39,18 +39,18 @@ role GGE::ShowContents {
# RAKUDO: Could name this one GGE::Exp::CUT or something, if enums
# with '::' in them worked, which they don't. [perl #71460]
-sub CUT_GROUP { -1 }
-sub CUT_RULE { -2 }
-sub CUT_MATCH { -3 }
+our sub CUT_GROUP { -1 }
+our sub CUT_RULE { -2 }
+our sub CUT_MATCH { -3 }
#enum CUT (
# CUT_GROUP => -1,
# CUT_RULE => -2,
# CUT_MATCH => -3,
#);
-sub GREEDY { 0 }
-sub EAGER { 1 }
-sub NONE { 2 }
+our sub GREEDY { 0 }
+our sub EAGER { 1 }
+our sub NONE { 2 }
#enum GGE_BACKTRACK <
# GREEDY
# EAGER
@@ -167,15 +167,21 @@ class GGE::Exp is GGE::Match {
~$code;
}
- method getargs($label, $next, %hash?) {
- %hash<L S> = $label, $next;
+ # RAKUDO: [perl #74454]
+ method getargs($label, $next, %hash is copy) {
+ # RAKUDO: Still waiting for hash slices to be brought back
+ # %hash<L S> = $label, $next;
+ %hash<L> = $label;
+ %hash<S> = $next;
if %hash.exists('quant') {
my $quant = %hash<quant>;
%hash<m> = $quant.hash-access('min');
%hash<M> = %hash<m> == 0 ?? '### ' !! '';
%hash<n> = $quant.hash-access('max');
%hash<N> = %hash<n> == Inf ?? '### ' !! '';
- my $bt = ($quant.hash-access('backtrack') // GREEDY).name.lc;
+ # RAKUDO: Waiting for named enums for this one
+ # my $bt = ($quant.hash-access('backtrack') // GREEDY).name.lc;
+ my $bt = 'no idea';
%hash<Q> = sprintf '%s..%s (%s)', %hash<m>, %hash<n>, $bt;
}
return %hash;
@@ -223,7 +229,8 @@ class GGE::Exp is GGE::Match {
class GGE::Exp::Literal is GGE::Exp does GGE::ShowContents {
method p6($code, $label, $next) {
- my %args = self.getargs($label, $next);
+ # RAKUDO: [perl #74454]
+ my %args = self.getargs($label, $next, {});
my $literal = self.ast;
my $litlen = $literal.chars;
%args<I> = '';
@@ -250,7 +257,9 @@ class GGE::Exp::Quant is GGE::Exp {
my ($min, $max, $bt) = map { self.hash-access($_) },
<min max backtrack>;
$bt //= GREEDY;
- "{$bt.name.lc} $min..$max"
+ # RAKUDO: Named enums
+ # "{$bt.name.lc} $min..$max"
+ "no idea $min..$max"
}
method p6($code, $label, $next) {
@@ -263,7 +272,10 @@ class GGE::Exp::Quant is GGE::Exp {
$seplabel = $code.unique('R');
$nextlabel = $label ~ '_sep';
}
- %args<c C> = 0, '### ';
+ # RAKUDO: Hash slices not implemented yet
+ # %args<c C> = 0, '### ';
+ %args<c> = 0;
+ %args<C> = '### ';
given self.hash-access('backtrack') {
when EAGER() {
$code.emit( q[[
@@ -643,7 +655,8 @@ class GGE::Exp::CGroup is GGE::Exp::Group {
method p6($code, $label, $next) {
my $explabel = $code.unique('R');
my $expnext = $label ~ '_close';
- my %args = self.getargs($label, $next);
+ # RAKUDO: [perl #74454]
+ my %args = self.getargs($label, $next, {});
my ($captgen, $captsave, $captback) = self.gencapture($label);
%args<c C> = self.hash-access('cutmark'), '### ';
%args<X> = self.hash-access('isscope') ?? '' !! '### ';
@@ -746,7 +759,8 @@ class GGE::Exp::Alias is GGE::Exp {
class GGE::Exp::Subrule is GGE::Exp does GGE::ShowContents {
method p6($code, $label, $next) {
- my %args = self.getargs($label, $next);
+ # RAKUDO: [perl #74454]
+ my %args = self.getargs($label, $next, {});
my $subname = self.hash-access('subname');
my ($captgen, $captsave, $captback) = self.gencapture($label);
my $subarg = self.hash-access('arg') // ''
View
@@ -98,7 +98,8 @@ class GGE::Match {
}
method Str() {
- $!target.substr($!from, $!to - $!from)
+ # RAKUDO: Stringification needed due to [perl #73462]
+ (~$!target).substr($!from, $!to - $!from)
}
# RAKUDO: There's a bug preventing me from using hash lookup in a
View
@@ -143,13 +143,15 @@ class GGE::Perl6Regex {
return $optable.parse($mob, :$tighter, :$stop);
}
- sub parse_term($mob) {
- if $mob.target.substr($mob.to, 1) ~~ /\s/ {
+ our sub parse_term($mob) {
+ # RAKUDO: Stringification needed due to [perl #73462]
+ if (~$mob.target).substr($mob.to, 1) ~~ /\s/ {
return parse_term_ws($mob);
}
my $m = GGE::Exp::Literal.new($mob);
my $pos = $mob.to;
- my $target = $m.target;
+ # RAKUDO: Stringification needed due to [perl #73462]
+ my $target = ~$m.target;
while $target.substr($pos, 1) ~~ /\w/ {
++$pos;
}
@@ -163,15 +165,16 @@ class GGE::Perl6Regex {
$m;
}
- sub parse_term_ws($mob) {
+ our sub parse_term_ws($mob) {
my $m = GGE::Exp::WS.new($mob);
$m.to = $mob.to;
- $m.to++ while $m.target.substr($m.to, 1) ~~ /\s/;
- if $m.target.substr($m.to, 1) eq '#' {
+ # RAKUDO: Stringification needed due to [perl #73462]
+ $m.to++ while (~$m.target).substr($m.to, 1) ~~ /\s/;
+ if (~$m.target).substr($m.to, 1) eq '#' {
my $delim = "\n";
- $m.to = defined $m.target.index($delim, $m.to)
- ?? $m.target.index($delim, $m.to) + 1
- !! $m.target.chars;
+ $m.to = defined (~$m.target).index($delim, $m.to)
+ ?? (~$m.target).index($delim, $m.to) + 1
+ !! (~$m.target).chars;
}
$m;
}
@@ -220,7 +223,7 @@ class GGE::Perl6Regex {
$m;
}
- sub parse_term_backslash($mob) {
+ our sub parse_term_backslash($mob) {
my $backchar = substr($mob.target, $mob.to, 1);
my $isnegated = $backchar eq $backchar.uc;
$backchar .= lc;
@@ -255,7 +258,7 @@ class GGE::Perl6Regex {
return $m;
}
- sub parse_subname($target, $pos is copy) {
+ our sub parse_subname($target, $pos is copy) {
my $targetlen = $target.chars;
my $startpos = $pos;
while $pos < $targetlen && $target.substr($pos, 1) ~~ /\w/ {
@@ -266,7 +269,7 @@ class GGE::Perl6Regex {
return ($subname, $pos);
}
- sub parse_subrule($mob) {
+ our sub parse_subrule($mob) {
my $m = GGE::Exp::Subrule.new($mob);
my $target = $mob.target;
my $key = $mob.hash-access('KEY');
@@ -300,9 +303,9 @@ class GGE::Perl6Regex {
return $m;
}
- sub parse_enumcharclass($mob) {
+ our sub parse_enumcharclass($mob) {
my $m;
- my $target = $mob.target;
+ my $target = ~$mob.target;
my $pos = $mob.to;
my $op = $mob.hash-access('KEY');
if $op.substr(-1) eq '[' {
@@ -421,7 +424,7 @@ class GGE::Perl6Regex {
return $m;
}
- sub parse_quoted_literal($mob) {
+ our sub parse_quoted_literal($mob) {
my $m = GGE::Exp::Literal.new($mob);
my $target = $m.target;
@@ -442,12 +445,13 @@ class GGE::Perl6Regex {
$m;
}
- sub parse_quant($mob) {
+ our sub parse_quant($mob) {
my $m = GGE::Exp::Quant.new($mob);
my $key = $mob.hash-access('KEY');
my ($mod2, $mod1);
- given $m.target {
+ # RAKUDO: Stringification needed due to [perl #73462]
+ given ~$m.target {
$mod2 = .substr($mob.to, 2);
$mod1 = .substr($mob.to, 1);
}
@@ -493,11 +497,12 @@ class GGE::Perl6Regex {
if $key eq '**' {
# XXX: Should also count ws before quant modifiers -- with tests
- my $sepws = ?($m.target.substr($m.to, 1) ~~ /\s/);
- ++$m.to while $m.target.substr($m.to, 1) ~~ /\s/;
- my $isconst = $m.target.substr($m.to, 1) ~~ /\d/;
+ # RAKUDO: Stringification needed due to [perl #73462]
+ my $sepws = ?((~$m.target).substr($m.to, 1) ~~ /\s/);
+ ++$m.to while (~$m.target).substr($m.to, 1) ~~ /\s/;
+ my $isconst = (~$m.target).substr($m.to, 1) ~~ /\d/;
my $sep = !$isconst;
- if $m.target.substr($m.to, 1) eq '{' {
+ if (~$m.target).substr($m.to, 1) eq '{' {
$sep = False;
++$m.to;
}
@@ -528,19 +533,20 @@ class GGE::Perl6Regex {
# XXX: Add test against non-digits inside braces .**{x..z}
# XXX: Need to generalize this into parsing several digits
$m.hash-access('min') = $m.hash-access('max')
- = $m.target.substr($m.to, 1);
+ # RAKUDO: Stringification needed due to [perl #73462]
+ = (~$m.target).substr($m.to, 1);
++$m.to;
- if $m.target.substr($m.to, 2) eq '..' {
+ if (~$m.target).substr($m.to, 2) eq '..' {
$m.to += 2;
- $m.hash-access('max') = $m.target.substr($m.to, 1);
+ $m.hash-access('max') = (~$m.target).substr($m.to, 1);
if $m.hash-access('max') eq '*' {
$m.hash-access('max') = 'Inf';
}
++$m.to;
}
if !$isconst {
die 'No "}" found'
- unless $m.target.substr($m.to, 1) eq '}';
+ unless (~$m.target).substr($m.to, 1) eq '}';
++$m.to
}
}
@@ -549,9 +555,9 @@ class GGE::Perl6Regex {
$m;
}
- sub parse_dollar($mob) {
+ our sub parse_dollar($mob) {
my $pos = $mob.to;
- my $target = $mob.target;
+ my $target = ~$mob.target;
if $target.substr($pos, 1) eq '<' {
my $closing-pos = $target.index('>', $pos);
die "perl6regex parse error: Missing close '>' in scalar"
@@ -576,7 +582,7 @@ class GGE::Perl6Regex {
return $m;
}
- sub parse_modifier($mob) {
+ our sub parse_modifier($mob) {
my $m = GGE::Exp::Modifier.new($mob);
my $target = $m.target;
my $pos = $mob.to;
@@ -631,7 +637,9 @@ class GGE::Perl6Regex {
$exp.clear;
for @old-children -> $old-child {
my $new-child = perl6exp($old-child, %pad);
- if defined $new-child {
+ # RAKUDO: Storing the result into a variable causes it to become
+ # defined.
+ if defined perl6exp($old-child, %pad) {
$exp.push($new-child);
}
}
@@ -745,7 +753,7 @@ class GGE::Perl6Regex {
return $exp;
}
else {
- return ();
+ return Nil;
}
}
@@ -74,12 +74,21 @@ sub match_perl6regex($pattern, $target) {
return $rule($target);
}
+sub replace_x($s is copy) {
+ while defined (my $start = $s.index("\\x")) {
+ my $end = $start + 1;
+ ++$end while $s.substr($end, 1) ~~ /<[0..9a..fA..F]>/;
+ my $n = $s.substr($start + 1, $end - $start - 1);
+ $s = $s.substr(0, $start) ~ chr(:16($n)) ~ $s.substr($end);
+ };
+ $s
+}
+
sub backslash_escape($string) {
# RAKUDO: No .trans again yet
#return $string.trans(['\n', '\r', '\e', '\t', '\f'] =>
# ["\n", "\r", "\e", "\t", "\f"])\
- return $string.subst(/\\n/, "\n", :g).subst(/\\r/, "\r", :g).subst(/\\e/, "\e", :g).subst(/\\t/, "\t", :g).subst(/\\f/, "\f", :g)\
- .subst(/'\\x' (<[0..9a..f]>**{2..4})/, { chr(:16($0)) }, :g);
+ return replace_x $string.subst(/\\n/, "\n", :g).subst(/\\r/, "\r", :g).subst(/\\e/, "\e", :g).subst(/\\t/, "\t", :g).subst(/\\f/, "\f", :g);
}
done_testing;
View
@@ -12,10 +12,19 @@ my GGE::Match $match
say $match ?? $match.dump_str('mob', ' ', '') !! "No match\n";
+sub replace_x($s is copy) {
+ while defined (my $start = $s.index("\\x")) {
+ my $end = $start + 1;
+ ++$end while $s.substr($end, 1) ~~ /<[0..9a..fA..F]>/;
+ my $n = $s.substr($start + 1, $end - $start - 1);
+ $s = $s.substr(0, $start) ~ chr(:16($n)) ~ $s.substr($end);
+ }
+ $s
+}
+
sub backslash_escape($string) {
# RAKUDO: No .trans again yet
#return $string.trans(['\n', '\r', '\e', '\t', '\f'] =>
# ["\n", "\r", "\e", "\t", "\f"])\
- return $string.subst(/\\n/, "\n", :g).subst(/\\r/, "\r", :g).subst(/\\e/, "\e", :g).subst(/\\t/, "\t", :g).subst(/\\f/, "\f", :g)\
- .subst(/'\\x' (<[0..9a..f]>**{2..4})/, { chr(:16($0)) }, :g);
+ return replace_x $string.subst(/\\n/, "\n", :g).subst(/\\r/, "\r", :g).subst(/\\e/, "\e", :g).subst(/\\t/, "\t", :g).subst(/\\f/, "\f", :g);
}

0 comments on commit 131525a

Please sign in to comment.