Author: pmichaud
Date: Sat Dec 27 13:36:20 2008
New Revision: 34448
Modified:
trunk/compilers/pge/PGE/Exp.pir
trunk/compilers/pge/PGE/Perl6Regex.pir
trunk/compilers/pge/PGE/Regex.pir
trunk/t/compilers/pge/perl6regex/01-regex.t
Log:
[pge]: Initial implementation of goal matching '(' ~ ')' <expr>
Modified: trunk/compilers/pge/PGE/Exp.pir
==============================================================================
--- trunk/compilers/pge/PGE/Exp.pir (original)
+++ trunk/compilers/pge/PGE/Exp.pir Sat Dec 27 13:36:20 2008
@@ -780,11 +780,18 @@
.local string subarg
subarg = ''
$I0 = exists self['arg']
- if $I0 == 0 goto subarg_end
+ if $I0 == 0 goto subarg_dba
subarg = self['arg']
subarg = code.'escape'(subarg)
subarg = concat ', ', subarg
args['A'] = $S0
+ subarg_dba:
+ $I0 = exists self['dba']
+ if $I0 == 0 goto subarg_end
+ $S0 = self['dba']
+ $S0 = code.'escape'($S0)
+ subarg .= ", 'dba'=>"
+ subarg .= $S0
subarg_end:
.local string cname, captgen, captsave, captback
Modified: trunk/compilers/pge/PGE/Perl6Regex.pir
==============================================================================
--- trunk/compilers/pge/PGE/Perl6Regex.pir (original)
+++ trunk/compilers/pge/PGE/Perl6Regex.pir Sat Dec 27 13:36:20 2008
@@ -130,15 +130,16 @@
.param pmc mob
.param pmc adverbs :slurpy :named
- .local string stop
+ .local string stop, tighter
.local pmc stopstack, optable, match
stopstack = get_global '@!stopstack'
optable = get_global '$optable'
stop = adverbs['stop']
+ tighter = adverbs['tighter']
push stopstack, stop
- match = optable.'parse'(mob, 'stop'=>stop)
+ match = optable.'parse'(mob, 'stop'=>stop, 'tighter'=>tighter)
$S0 = pop stopstack
.return (match)
@@ -212,6 +213,9 @@
$P0 = get_global 'parse_quoted_literal'
optable.'newtok'("term:'", 'equiv'=>'term:', 'nows'=>1, 'parsed'=>$P0)
+ $P0 = get_global 'parse_goal'
+ optable.'newtok'('term:~', 'equiv'=>'term:', 'parsed'=>$P0)
+
optable.'newtok'('term:::', 'equiv'=>'term:', 'nows'=>1,
'match'=>'PGE::Exp::Cut')
optable.'newtok'('term::::', 'equiv'=>'term:', 'nows'=>1,
'match'=>'PGE::Exp::Cut')
optable.'newtok'('term:<cut>', 'equiv'=>'term:', 'nows'=>1,
'match'=>'PGE::Exp::Cut')
@@ -1037,6 +1041,56 @@
.end
+=item C<parse_goal>
+
+Parse a goal.
+
+=cut
+
+.sub 'parse_goal'
+ .param pmc mob
+ .local int pos, lastpos
+ .local string target
+ (mob, pos, target) = mob.'new'(mob, 'grammar'=>'PGE::Exp::Concat')
+ lastpos = length target
+ ## skip any leading whitespace before goal
+ pos = find_not_cclass .CCLASS_WHITESPACE, target, pos, lastpos
+ .local pmc regex, goal, expr, alt, failsub
+ regex = get_global 'regex'
+ ## parse the goal, down to concatenation precedence
+ mob.'to'(pos)
+ goal = regex(mob, 'tighter'=>'infix:')
+ unless goal goto fail_goal
+ goal = goal['expr']
+ pos = goal.'to'()
+ ## skip any leading whitespace before expression
+ pos = find_not_cclass .CCLASS_WHITESPACE, target, pos, lastpos
+ ## parse the goal, down to concatenation precedence
+ mob.'to'(pos)
+ expr = regex(mob, 'tighter'=>'infix:')
+ unless expr goto fail_expr
+ expr = expr['expr']
+ pos = expr.'to'()
+ mob.'to'(pos)
+ failsub = mob.'new'(mob, 'grammar'=>'PGE::Exp::Subrule')
+ failsub.'to'(pos)
+ failsub['subname'] = 'FAILGOAL'
+ $S0 = goal.'text'()
+ failsub['arg'] = $S0
+ alt = mob.'new'(mob, 'grammar'=>'PGE::Exp::Alt')
+ alt.'to'(pos)
+ push alt, goal
+ push alt, failsub
+ push mob, expr
+ push mob, alt
+ .return (mob)
+ fail_goal:
+ 'parse_error'(mob, pos, 'Unable to parse goal after ~')
+ fail_expr:
+ 'parse_error'(mob, pos, 'Unable to parse expression after ~')
+.end
+
+
=item C<parse_modifier>
Parse a modifier.
@@ -1387,6 +1441,8 @@
inc $I0
pad['subpats'] = $I0
end:
+ $S0 = pad['dba']
+ self['dba'] = $S0
.return (self)
.end
Modified: trunk/compilers/pge/PGE/Regex.pir
==============================================================================
--- trunk/compilers/pge/PGE/Regex.pir (original)
+++ trunk/compilers/pge/PGE/Regex.pir Sat Dec 27 13:36:20 2008
@@ -433,6 +433,29 @@
.return (mob)
.end
+=item FAILGOAL(pmc mob, string goal [, 'dba'=>dba])
+
+Throw an exception when parsing fails in goal matching.
+
+=cut
+
+.sub 'FAILGOAL' :method
+ .param string goal
+ .param pmc options :slurpy :named
+ .local string dba
+ dba = options['dba']
+ if dba goto have_dba
+ $P0 = getinterp
+ $P0 = $P0['sub'; 1]
+ dba = $P0
+ have_dba:
+ .local string message
+ message = concat "Unable to parse ", dba
+ message .= ", couldn't find final "
+ message .= goal
+ die message
+.end
+
=back
=head2 Support subroutines
Modified: trunk/t/compilers/pge/perl6regex/01-regex.t
==============================================================================
--- trunk/t/compilers/pge/perl6regex/01-regex.t (original)
+++ trunk/t/compilers/pge/perl6regex/01-regex.t Sat Dec 27 13:36:20 2008
@@ -81,6 +81,7 @@
push test_files, 'rx_captures'
push test_files, 'rx_modifiers'
push test_files, 'rx_syntax'
+ push test_files, 'rx_goal'
.local pmc interp # a handle to our interpreter object.
interp = getinterp
