develooper Front page | perl.cvs.parrot | Postings from December 2008

[svn:parrot] r34448 - in trunk: compilers/pge/PGE t/compilers/pge/perl6regex

From:
pmichaud
Date:
December 27, 2008 13:36
Subject:
[svn:parrot] r34448 - in trunk: compilers/pge/PGE t/compilers/pge/perl6regex
Message ID:
20081227213621.C7DE2CBA12@x12.develooper.com
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



nntp.perl.org: Perl Programming lists via nntp and http.
Comments to Ask Bjørn Hansen at ask@perl.org | Group listing | About