Changeset 21458

Show
Ignore:
Timestamp:
07/23/08 18:03:42 (6 months ago)
Author:
putter
Message:

[misc/elfish/rx_on_re] Moved p5 regex engine core into a p6 file.
Core now uses s///g, instead of a source filter, for the backtracking api.
Sub::Name use undisabled. Switched to elf_g.
Regressions exist - as yet undiagnosed. It's unexpectedly working "better".

Location:
misc/elfish/rx_on_re
Files:
4 modified

Legend:

Unmodified
Added
Removed

  • misc/elfish/rx_on_re/Makefile

    r21444 r21458  
    22check: 
    33        export ELF_STD_RED_RUN=./../../STD_red/STD_red_run 
    4         ../../elf/elf_f test.pm > tst_1 2> tst_2 
    5         diff tst_1 t_baseline.result 
     4        ../../elf/elf_g test.pm > tst_1 2> tst_2 
     5        diff t_baseline.result tst_1 
    66        @echo ok 
    77 

  • misc/elfish/rx_on_re/README

    r21389 r21458  
    6868Failed 1/1 test scripts. 52/536 subtests failed. 
    6969Files=1, Tests=536, 17 wallclock secs (17.30 cusr +  0.35 csys = 17.65 CPU) 
     70 
     71 
     72 
     73NOTES 
     74 
     75Comments from EmitRegexYare.pm. 
     76# Backtracking api changes from a Filter::Simple to a s/// method. 
     77# Engine core becomes a prelude. 
     78# Emitters become p6, emitting p5 source. 
     79# IR analysis becomes p6. 
     80# The regexp and regex parsers are temporarily retained, as some of the action logic will need to end up in IRx1_FromAST or elsewhere. 
     81# And the unicode rules will need to be metaprogrammed in p6. 
     82# Discarded: 
     83#  Match - no need for painful 'use overload' games. 
     84#  Functional regex representations - we're bootstrapping on STD. 
     85#  Api and Filter packages - emitter has understanding and control of the code. 
     86#  Interactive shell and command line - though may again need something like it for testing. 

  • misc/elfish/rx_on_re/emit5.pm

    r20727 r21458  
     1class EmitRegex { 
     2 
     3  method expand_backtrack_macros ($code) { 
     4 
     5    $code.re_sub('\bLET\(([^\)]+)\)\{','BacktrackMacrosKludge::_let_gen($1)','eg 
     6'); 
     7    $code.re_sub('\}LET;','BacktrackMacrosKludge::_let_end().";"','eg'); 
     8 
     9    $code.re_sub_g('\bFAIL_IF_FAILED\(([^\)]+)\);','return($1) if FAILED($1);'); 
     10    $code.re_sub_g('\bFAIL\(\)','return(undef)'); 
     11    $code.re_sub_g('\bFAILED\(([^\)]+)\)','(!defined($1)||(!ref($1)&&($1<=0)))') 
     12; 
     13 
     14    $code.re_sub_g('\bFAIL_SEQUENCE\(\)','die("fail sequence\\\\n")'); 
     15    $code.re_sub_g('\bFAIL_GROUP\(\)','die("fail group\\\\n")'); 
     16    $code.re_sub_g('\bFAIL_REGEX\(\)','die("fail regex\\\\n")'); 
     17    $code.re_sub_g('\bFAIL_MATCH\(\)','die("fail match\\\\n")'); 
     18 
     19    $code.re_sub_g('\bTAILCALL\(([^,\)]+),?([^\)]*)\);','\@_=($2);goto \&$1;'); 
     20 
     21    #print $code; 
     22    $code; 
     23  }; 
     24 
     25 
     26  method regex_prelude () { 
     27    self.expand_backtrack_macros(' 
     28 
     29{ package VersionConstraints; 
     30  use Regexp::Common 2.122; 
     31  use Sub::Name 0.03; 
     32  use Filter::Simple 0.82; 
     33} 
     34 
     35package Regexp::ModuleA; 
     36use strict; 
     37use warnings; 
     38use Carp; 
     39 
     40#====================================================================== 
     41# Core Regexp Engine ("RMARE") 
     42# 
     43# NOTE: Time to refactor.  A perlbug used to prevent it.  Should be ok now. 
     44 
     45package Regexp::ModuleA::ReentrantEngine; 
     46use strict; 
     47use warnings; 
     48 
     49local $Regexp::ModuleA::ReentrantEngine::Env::str; 
     50local $Regexp::ModuleA::ReentrantEngine::Env::pos; 
     51local $Regexp::ModuleA::ReentrantEngine::Env::current_match; 
     52local $Regexp::ModuleA::ReentrantEngine::Env::leaf_match; 
     53local $Regexp::ModuleA::ReentrantEngine::Env::pkg; 
     54local $Regexp::ModuleA::ReentrantEngine::Env::nested_data; 
     55local $Regexp::ModuleA::ReentrantEngine::Env::alias_match; 
     56#local $Regexp::ModuleA::ReentrantEngine::Env::stop; 
     57 
     58{ 
     59  package Regexp::ModuleA::AST::BaseClass; 
     60 
     61  use Sub::Name; 
     62  our $sub_id = 1; 
     63 
     64  sub RMARE_emit { 
     65    my $cls = ref($_[0]); 
     66    die "bug: $cls RMARE_emit() unimplemented\n"; 
     67  } 
     68 
     69  # noop 
     70 
     71  my $noop; 
     72  $noop = subname "<noop ".($sub_id++).">" => sub { 
     73    my $c = $_[0]; 
     74    return 1 if !defined($c) || $c eq $noop; 
     75    TAILCALL($c,$noop); 
     76  }; 
     77  sub RMARE_noop { $noop } 
     78  sub RMARE_is_noop { 
     79    my($o,$c)=@_; 
     80    return 1 if !defined($c) || $c eq $noop; 
     81    return 0; 
     82  } 
     83 
     84  sub RMARE_eat_backref { 
     85    my($o,$idx,$mod5_re)=@_; 
     86    my $noop = $o->RMARE_noop; 
     87    subname "<eat_backref ".($sub_id++).">" => sub { 
     88      my $c = $_[0]; 
     89      my $a = $$Regexp::ModuleA::ReentrantEngine::Env::leaf_match->{match_array}; 
     90      FAIL() if $idx >= @$a; 
     91      my $m = $a->[$idx]; 
     92      $m = $m->[-1] if defined($m) && ref($m) eq "ARRAY"; 
     93      FAIL() if !defined($m) || !$m->match_boolean; 
     94      my $re = $m->match_string; 
     95      $re =~ s/(\W)/\\$1/g; 
     96 
     97      my($str) = $Regexp::ModuleA::ReentrantEngine::Env::str; 
     98      pos($str) = $Regexp::ModuleA::ReentrantEngine::Env::pos; 
     99      $str =~ /\G$mod5_re($re)/ or FAIL(); 
     100      $Regexp::ModuleA::ReentrantEngine::Env::pos += length($1); 
     101      TAILCALL($c,$noop); 
     102    }; 
     103  } 
     104 
     105  { use re "eval"; 
     106  sub RMARE_eat_regexp { 
     107    my($o,$re)=@_; 
     108    my $noop = $o->RMARE_noop; 
     109    my $qr = qr/\G($re)/; 
     110    subname "<eat_regexp ".($sub_id++).">" => sub { 
     111      my $c = $_[0]; 
     112 
     113      my($str) = $Regexp::ModuleA::ReentrantEngine::Env::str; 
     114      pos($str) = $Regexp::ModuleA::ReentrantEngine::Env::pos; 
     115      $str =~ $qr or FAIL(); 
     116      $Regexp::ModuleA::ReentrantEngine::Env::pos += length($1); 
     117      TAILCALL($c,$noop); 
     118    } 
     119  } 
     120  } 
     121 
     122  sub RMARE_imsx { 
     123    my($o)=@_; 
     124    my $mod = ""; 
     125    $mod .= "i" if $o->{flags}{i}; 
     126    $mod .= "m" if $o->{flags}{perl5_m}; 
     127    $mod .= "s" if $o->{flags}{perl5_s}; 
     128    $mod .= "x" if $o->{flags}{perl5_x}; 
     129    $mod; 
     130  } 
     131 
     132  sub RMARE_wrap_re_with_mods { 
     133    my($o,$re)=@_; 
     134    my $mod = $o->RMARE_imsx; 
     135    return $re if $mod eq ""; 
     136    "(?$mod:$re)"; 
     137  } 
     138 
     139  sub RMARE_alt { 
     140    my($o,$aref)=@_; 
     141    die "bug $aref" if ref($aref) ne "ARRAY"; 
     142    my @fs = @$aref; 
     143    subname "<alt ".($sub_id++).">" => sub { 
     144      my $c = $_[0]; 
     145      for my $f (@fs) { 
     146        my $v = LET($Regexp::ModuleA::ReentrantEngine::Env::pos){ 
     147          my $v1 = eval { $f->($c) }; #try 
     148          if($@) { 
     149            next if $@ eq "fail sequence\n"; 
     150            die $@ unless $@ eq "fail group\n"; 
     151            FAIL(); 
     152          } 
     153          $v1; 
     154        }LET; 
     155        return $v if not FAILED($v); 
     156      } 
     157      FAIL(); 
     158    }; 
     159  } 
     160 
     161  sub RMARE_conj { 
     162    my($o,$aref)=@_; 
     163    die "bug $aref" if ref($aref) ne "ARRAY"; 
     164    my @fs = @$aref; 
     165    my $noop = $o->RMARE_noop; 
     166    return $noop if @fs == 0; 
     167    return $fs[0] if @fs == 1; 
     168    my $code1 = "()"; my $code2 = ""; 
     169    my $code0 = "my \$f0 = \$fs[0]; "; 
     170    { my $i = $#fs; 
     171      $code0 .= ""; 
     172      $code1 = \'sub { 
     173  FAIL() if $__end__ != $Regexp::ModuleA::ReentrantEngine::Env::pos; 
     174  @_=\'.$code1; 
     175      $code2 .= ";\ngoto \&\$cn}"; 
     176    } 
     177    for my $i (reverse(2..$#fs)) { 
     178      $code0 .= "my \$f$i = \$fs[$i]; "; 
     179      $code1 = \'sub { 
     180  FAIL() if $__end__ != $Regexp::ModuleA::ReentrantEngine::Env::pos; 
     181  $Regexp::ModuleA::ReentrantEngine::Env::pos = $__start__; 
     182  @_=\'.$code1; 
     183      $code2 .= ";\ngoto \&\$f$i}"; 
     184    } 
     185    { my $i = 1; 
     186      $code0 .= "my \$f$i = \$fs[$i]; "; 
     187      $code1 = \'sub { 
     188  $__end__ = $Regexp::ModuleA::ReentrantEngine::Env::pos; 
     189  $Regexp::ModuleA::ReentrantEngine::Env::pos = $__start__; 
     190  @_=\'.$code1; 
     191      $code2 .= ";\ngoto \&\$f$i}"; 
     192    } 
     193    my $code = $code0." 
     194#line 2 \"Regexp::ModuleA::AST::BaseClass RMARE_conj\" 
     195\n subname \'<conj \'.(\$sub_id++).">" => sub {my \$cn = \$_[0]; 
     196  my \$__start__ = \$Regexp::ModuleA::ReentrantEngine::Env::pos; 
     197  my \$__end__ = undef; 
     198  my \$__f__ = ".$code1.$code2.\'; 
     199    LET($Regexp::ModuleA::ReentrantEngine::Env::pos){ 
     200      $f0->($__f__); 
     201    }LET; 
     202  \'."}\n"; 
     203    #print STDERR $code; 
     204    # Currently expanded in the string itself. :/ 
     205    # $code = Regexp::ModuleA::ReentrantEngine::BacktrackMacros::filter_string($code); 
     206    eval($code) || die "$@"; 
     207  }    
     208 
     209  sub RMARE_concat { 
     210    my($o,$aref)=@_; 
     211    die "bug $aref" if ref($aref) ne "ARRAY"; 
     212    my @fs = @$aref; 
     213    return $o->RMARE_noop if @fs == 0; 
     214    return $fs[0] if @fs == 1; 
     215    my $code1 = ""; my $code2 = ""; 
     216    my $code0 = "my \$f0 = \$fs[0]; "; 
     217    for my $i (reverse(1..$#fs)) { 
     218      $code0 .= "my \$f$i = \$fs[$i]; "; 
     219      $code1 .= "sub {\@_="; 
     220      $code2 .= ";goto \&\$f$i}"; 
     221    } 
     222    my $code = $code0." 
     223#line 2 \"Regexp::ModuleA::AST::BaseClass RMARE_concat\" 
     224\n subname \'<concat \'.(\$sub_id++).\'>\' => sub {my \$cn = \$_[0]; \@_=".$code1."\$cn".$code2.";goto \&\$f0}\n"; 
     225    eval($code) || die "$@"; 
     226  }    
     227 
     228  my $repeat_id = 1; 
     229  our(%repeat_count,%repeat_previous_pos); 
     230  local %repeat_count; 
     231  local %repeat_previous_pos; 
     232  sub RMARE_repeat { 
     233    my($o,$f,$min,$max,$ng)=@_; 
     234    my $greedy = !$ng ? 1 : 0; 
     235    my $noop = $o->RMARE_noop; 
     236    my $myid = $sub_id++; 
     237    subname "<repeat ".($myid).">" => sub { 
     238      if(!defined $noop){die "this perl v5.8.8 bug workaround line didnt work"} 
     239      my $c = $_[0]; 
     240      my $rid = $repeat_id++; 
     241      local $repeat_previous_pos{$rid} = -1; 
     242      local $repeat_count{$rid} = 0; 
     243      my($get_minimum,$try_getting_more); 
     244      $get_minimum = subname "get_minimum" => sub { 
     245        if($repeat_count{$rid} < $min) { 
     246          local $repeat_count{$rid} = $repeat_count{$rid} +1; 
     247          $f->($get_minimum); 
     248        } else { 
     249          goto &$try_getting_more; 
     250        } 
     251      }; 
     252      $try_getting_more = subname "try_getting_more" => sub { 
     253        if( !($repeat_previous_pos{$rid} < $Regexp::ModuleA::ReentrantEngine::Env::pos) || 
     254            !($repeat_count{$rid} < $max)) 
     255        { 
     256          TAILCALL($c,$noop); 
     257        } 
     258        local $repeat_previous_pos{$rid} = $Regexp::ModuleA::ReentrantEngine::Env::pos; 
     259        local $repeat_count{$rid} = $repeat_count{$rid} +1; 
     260         
     261        my $v = LET($Regexp::ModuleA::ReentrantEngine::Env::pos){ 
     262          $greedy ? $f->($try_getting_more) : $c->($noop); 
     263        }LET; 
     264        return $v if not FAILED($v); 
     265        if($greedy){ 
     266          TAILCALL($c,$noop); # tailcall ok despite locals. 
     267        } else { 
     268          $f->($try_getting_more); 
     269        } 
     270      }; 
     271      $get_minimum->(); 
     272    }; 
     273  } 
     274 
     275  sub RMARE_group { 
     276    my($o,$f,$target_spec,$in_quant)=@_; 
     277    my $foo = subname "<group ".($sub_id++).">" => sub { 
     278      my $cn = $_[0]; 
     279      my $nd = $Regexp::ModuleA::ReentrantEngine::Env::nested_data; 
     280      my $close = sub { 
     281        my($c)=@_; 
     282        $Regexp::ModuleA::ReentrantEngine::Env::nested_data = $nd; 
     283        my $v = eval { $cn->($c) }; 
     284        if($@) { 
     285          die "jump ".$@ if $@ =~ /^fail /; 
     286          die $@; 
     287        } 
     288        return $v; 
     289      }; 
     290      my $v = eval {$f->($close)}; #try 
     291      if($@) { 
     292        die $1 if $@ =~ /^jump (.+)/s; 
     293        die $@ unless $@ eq "fail group\n" || $@ eq "fail sequence\n"; 
     294        FAIL(); 
     295      } 
     296      return $v; 
     297    }; 
     298    return $foo if !$target_spec; 
     299    return $foo if ($target_spec->[0] =~ /^\$/) && $in_quant; 
     300    my $cs = $o->RMARE_capture_string($foo); 
     301    $o->RMARE_alias_wrap($cs,undef,1,0,$in_quant,$target_spec); 
     302  } 
     303 
     304  sub RMARE_capture_string { 
     305    my($o,$f)=@_; 
     306    my $myid = $sub_id++; 
     307    subname \'<capture_string \'.($myid).">" => sub { 
     308      my($c)=@_; 
     309 
     310      my $m = $Regexp::ModuleA::ReentrantEngine::Env::alias_match; 
     311      my $from = $Regexp::ModuleA::ReentrantEngine::Env::pos; 
     312 
     313      my $close = subname \'<capture_string-close \'.($myid).">" => sub { 
     314        my $c0 = $_[0]; 
     315        my $to = $Regexp::ModuleA::ReentrantEngine::Env::pos; 
     316        $m->match_set(1,substr($Regexp::ModuleA::ReentrantEngine::Env::str,$from,$to-$from),$$m->{match_array},$$m->{match_hash},$from,$to); 
     317        TAILCALL($c0,$c); 
     318      }; 
     319 
     320      local $Regexp::ModuleA::ReentrantEngine::Env::alias_match = undef; 
     321 
     322      $f->($close); 
     323    }; 
     324  } 
     325 
     326  sub RMARE_capture { 
     327    my($o,$idx,$f,$is6,$nparen6,$in_quant,$target_spec)=@_; 
     328    my $myid = $sub_id++; 
     329    my $foo = subname \'<capture \'.($myid).">" => sub { 
     330      my($c)=@_; 
     331 
     332      my $m = $Regexp::ModuleA::ReentrantEngine::Env::alias_match; 
     333      my $from = $Regexp::ModuleA::ReentrantEngine::Env::pos; 
     334      my $nd = $Regexp::ModuleA::ReentrantEngine::Env::nested_data; 
     335      my $leaf = $Regexp::ModuleA::ReentrantEngine::Env::leaf_match; 
     336 
     337      my $close = subname \'<capture-close \'.($myid).">" => sub { 
     338        my $c0 = $_[0]; 
     339        $Regexp::ModuleA::ReentrantEngine::Env::nested_data = $nd; 
     340        $Regexp::ModuleA::ReentrantEngine::Env::leaf_match = $leaf if $is6; 
     341        my $to = $Regexp::ModuleA::ReentrantEngine::Env::pos; 
     342        $m->match_set(1,substr($Regexp::ModuleA::ReentrantEngine::Env::str,$from,$to-$from),$$m->{match_array},$$m->{match_hash},$from,$to); 
     343        my $v = eval { $c0->($c) }; 
     344        if($@) { 
     345          die "jump ".$@ if $@ =~ /^fail /; 
     346          die $@; 
     347        } 
     348        return $v; 
     349      }; 
     350 
     351      local $Regexp::ModuleA::ReentrantEngine::Env::alias_match; 
     352      local $Regexp::ModuleA::ReentrantEngine::Env::leaf_match = $is6 ? $m : $leaf; 
     353 
     354      my $v = eval { $f->($close) }; #try 
     355      if($@) { 
     356        die $1 if $@ =~ /^jump (.+)/s; 
     357        die $@ unless $@ eq "fail group\n" || $@ eq "fail sequence\n"; 
     358        $m->match_set_as_failed; 
     359        FAIL(); 
     360      } 
     361      $m->match_set_as_failed if FAILED($v); 
     362      $v; 
     363    }; 
     364    $o->RMARE_alias_wrap($foo,$idx,$is6,$nparen6,$in_quant,$target_spec); 
     365  } 
     366 
     367  sub RMARE_alias_wrap { 
     368    my($o,$f,$idx,$is6,$nparen6,$in_quant,$target_spec)=@_; 
     369    my $myid = $sub_id++; 
     370    my $spec = $target_spec ? [@$target_spec] : [\'$/\',\'[\'=>$idx]; 
     371    my $root = shift(@$spec); 
     372    my $top = \'$$Regexp::ModuleA::ReentrantEngine::Env::leaf_match\'; 
     373    my($copy,$access); 
     374    my $localize = $top; 
     375    for(my $i=0;$i<@$spec;$i+=2){ 
     376      my($flag,$key)=($spec->[$i],$spec->[$i+1]); 
     377      my $is_final = $i == (@$spec - 2); 
     378      if($flag eq \'[\'){ 
     379        $localize .= \'->{match_array}\'; 
     380        $localize .= "[$key]" if !$is_final; 
     381        if($is_final){ 
     382          $copy = \'[@{\'.$localize.\'}]\'; 
     383          $access = "[$key]"; 
     384        } 
     385      } elsif($flag eq \'{\'){ 
     386        $localize .= \'->{match_hash}\'; 
     387        $localize .= "{$key}" if !$is_final; 
     388        if($is_final){ 
     389          $copy = \'{%{\'.$localize.\'}}\'; 
     390          $access = "{$key}"; 
     391        } 
     392      } else { die "bug" }; 
     393    } 
     394    my $array_alias = $root =~ /^\@/; 
     395    my $code = \' 
     396sub { 
     397  my($c)=@_; 
     398  my $m = $Regexp::ModuleA::ReentrantEngine::Env::alias_match; 
     399  if(1 || !defined($m)){#XXXXX 
     400    $m = Regexp::ModuleA::ReentrantEngine::Match0->new_failed(); 
     401    if($is6) { 
     402      my $a = [map{Regexp::ModuleA::ReentrantEngine::Match0->new_failed()} (1..$nparen6)]; 
     403      $$m->{match_array} = $a; 
     404    } 
     405  } 
     406  return LET(\'.$localize.\'){ 
     407    my $newa = \'.$copy.\'; 
     408    \'.$localize.\' = $newa; 
     409    if(\'.($is6 && $in_quant ? 1 : 0).\') { 
     410      my $onto = $newa->\'.$access.\'; 
     411      $onto = [] if ref($onto) ne "ARRAY"; 
     412      $onto = [@$onto,($array_alias ? @{$$m->{match_array}} : $m)]; 
     413      $newa->\'.$access.\' = $onto; 
     414    } else { 
     415      $newa->\'.$access.\' = (\'.($array_alias?1:0).\' ? [$m] : $m); 
     416    } 
     417    local $Regexp::ModuleA::ReentrantEngine::Env::alias_match = $m; 
     418    $f->($c); 
     419  }LET; 
     420}\'; 
     421#print STDERR $code; 
     422    my $capf = subname "<alias_wrap ".($myid).">" => eval($code); 
     423    die "bug $@" if $@; 
     424    $capf; 
     425  } 
     426 
     427  sub RMARE_subrule { 
     428    my($o,$fetch,$pkg,$pkg_override,$name,$args,$neg,$nocap,$in_quant,$target_spec)=@_; 
     429    my $noop = $o->RMARE_noop; 
     430    my $myid = $sub_id++; 
     431    my $f1 = subname "<subrule ".($myid)." $name>" => sub { 
     432      my($c)=@_; 
     433      my $f = $fetch->(@$args); 
     434 
     435      my $pkg0 = $Regexp::ModuleA::ReentrantEngine::Env::pkg; 
     436      my $pkg2 = $pkg_override || $pkg0; 
     437      my $pkg9 = $pkg_override || $Regexp::ModuleA::ReentrantEngine::Env::pkg || $pkg; 
     438 
     439      my $pos = $Regexp::ModuleA::ReentrantEngine::Env::pos; 
     440      my $m0 = $Regexp::ModuleA::ReentrantEngine::Env::current_match; 
     441      my $m0b = $Regexp::ModuleA::ReentrantEngine::Env::leaf_match; 
     442 
     443      my $nd = $Regexp::ModuleA::ReentrantEngine::Env::nested_data; 
     444 
     445      my $m1 = $Regexp::ModuleA::ReentrantEngine::Env::alias_match; 
     446      if(defined($m1)) { 
     447      } else { 
     448        $m1 = Regexp::ModuleA::ReentrantEngine::Match0->new_failed; 
     449      } 
     450      $m1->match_set(1,"",[],{},$pos,undef); 
     451      $$m1->{RULE} ||= $name; #EEEP 
     452 
     453      my $close = subname "<subrule-close ".($myid)." $name>" => sub { 
     454        my $cn = $_[0]; 
     455 
     456        $Regexp::ModuleA::ReentrantEngine::Env::nested_data = $nd; 
     457 
     458        $$m1->{match_to} = $Regexp::ModuleA::ReentrantEngine::Env::pos; #EEEP 
     459        $$m1->{match_string} = substr($Regexp::ModuleA::ReentrantEngine::Env::str,$pos,$Regexp::ModuleA::ReentrantEngine::Env::pos-$pos); 
     460 
     461        my $post = $name."__post_action"; 
     462        if(UNIVERSAL::can($pkg9,$post)) { 
     463          $m1->_match_enable_overload1; 
     464          $pkg9->$post($m1); 
     465        } 
     466 
     467        $Regexp::ModuleA::ReentrantEngine::Env::current_match = $m0; 
     468        $Regexp::ModuleA::ReentrantEngine::Env::leaf_match = $m0b; 
     469        local $Regexp::ModuleA::ReentrantEngine::Env::pkg = $pkg0; 
     470 
     471# =pod 
     472#         if(!$nocap) { 
     473#           LET($$m0->{match_hash}{$name}){ 
     474#             if($in_quant) { 
     475#               $$m0->{match_hash}{$name} = [@{$$m0->{match_hash}{$name}||[]}]; 
     476#               push(@{$$m0->{match_hash}{$name}},$m1); 
     477#             } else { 
     478#               $$m0->{match_hash}{$name} = $m1; 
     479#             } 
     480#             $neg ? 1 : $cn->($c); 
     481#           }LET; 
     482#         } else { 
     483#             $neg ? 1 : $cn->($c); 
     484#         } 
     485# =cut 
     486            $neg ? 1 : $cn->($c); 
     487      }; 
     488 
     489      my $v; 
     490      { local $Regexp::ModuleA::ReentrantEngine::Env::current_match = $m1; 
     491        local $Regexp::ModuleA::ReentrantEngine::Env::leaf_match = $m1; 
     492        local $Regexp::ModuleA::ReentrantEngine::Env::pkg = $pkg2; 
     493        local $Regexp::ModuleA::ReentrantEngine::Env::nested_data->{args} = $args; 
     494        $v = eval { $f->($close) }; 
     495        if($@) { 
     496          die $@ unless $@ eq "fail regex\n"; 
     497          FAIL() if !$neg; 
     498          $v = undef; # FAILED #X 
     499        } 
     500      } 
     501      if($neg) { 
     502        if(FAILED($v)) { 
     503          $$m1->{match_to} = $$m1->{match_from}; 
     504          $$m1->{match_string} = ""; 
     505 
     506# =pod 
     507#           LET($$m0->{match_hash}{$name}){ 
     508#             $$m0->{match_hash}{$name} = [@{$$m0->{match_hash}{$name}||[]}]; 
     509#             push(@{$$m0->{match_hash}{$name}},$m1); 
     510#             $c->($noop); 
     511#           }LET; 
     512# =cut 
     513            $c->($noop); 
     514 
     515        } else { 
     516          FAIL(); 
     517        } 
     518      } else { 
     519        FAIL_IF_FAILED($v); 
     520        return $v; 
     521      } 
     522    }; 
     523    return $f1 if $nocap; 
     524    $target_spec ||= [\'$/\',\'{\'=>$name]; 
     525    $o->RMARE_alias_wrap($f1,undef,1,0,$in_quant,$target_spec); 
     526  } 
     527 
     528  sub RMARE_aregex { 
     529    my($o,$f)=@_; 
     530    my $nparenx = $o->{flags}{p5} ? $o->{nparen} : $o->{nparen6}; 
     531    $nparenx = 0 if !defined $nparenx; #XXX arguments to subrules.  aregex not seeing an init. 
     532    subname "<aregex ".($sub_id++).">" => sub { 
     533      my($c)=@_; 
     534 
     535      my $m = $Regexp::ModuleA::ReentrantEngine::Env::leaf_match; 
     536      my $a = [map{Regexp::ModuleA::ReentrantEngine::Match0->new_failed()} (1..$nparenx)]; 
     537      $$m->{match_array} = $a; 
     538 
     539      my $v = eval { $f->($c) }; #try 
     540      if($@) { 
     541        die $@ unless ($@ eq "fail group\n" || 
     542                       $@ eq "fail sequence\n"); 
     543        FAIL(); 
     544      } 
     545      $v; 
     546    }; 
     547  } 
     548 
     549  sub RMARE_do_match { 
     550    my($o,$f,$s,$beginat,$minlen)=@_; 
     551    my $nparen = $o->{nparen}; 
     552    my $len = length($s); 
     553    $beginat = 0 if !defined($beginat); 
     554    my $noop = $o->RMARE_noop; 
     555    my $atend = $noop; 
     556    if(defined $minlen) { 
     557      my $min_end = $minlen + $beginat; 
     558      $atend = subname "<atend ".($sub_id++).">" => sub {return undef if $Regexp::ModuleA::ReentrantEngine::Env::pos < $min_end;return 1;} 
     559    } 
     560    for my $start ($beginat..$len) { 
     561      local $Regexp::ModuleA::ReentrantEngine::Env::str = $s; 
     562      local $Regexp::ModuleA::ReentrantEngine::Env::pos = $start; 
     563      my $m = Regexp::ModuleA::ReentrantEngine::Match0->new_failed(); 
     564      local $Regexp::ModuleA::ReentrantEngine::Env::current_match = $m; 
     565      local $Regexp::ModuleA::ReentrantEngine::Env::leaf_match = $m; 
     566      local $Regexp::ModuleA::ReentrantEngine::Env::nested_data = {}; 
     567      local $Regexp::ModuleA::ReentrantEngine::Env::alias_match; 
     568      $Regexp::ModuleA::ReentrantEngine::Env::nested_data->{args} = []; 
     569       
     570      my $ok = eval { $f->($atend) }; #try 
     571      if($@) { 
     572        die $@ unless ($@ eq "fail match\n" || $@ eq "fail regex\n" || 
     573                       $@ eq "fail group\n" || $@ eq "fail sequence\n"); 
     574        last; 
     575      } 
     576      if(not FAILED($ok)) { 
     577        $m->match_set(1,substr($Regexp::ModuleA::ReentrantEngine::Env::str,$start,$Regexp::ModuleA::ReentrantEngine::Env::pos-$start),$$m->{match_array},$$m->{match_hash},$start,$Regexp::ModuleA::ReentrantEngine::Env::pos); 
     578        return $m; 
     579      } 
     580    } 
     581    return Regexp::ModuleA::ReentrantEngine::Match0->new_failed(); 
     582  } 
     583 
     584  # Commits 
     585 
     586  sub RMARE_commit_sequence { 
     587    my($o)=@_; 
     588    my $noop = $o->RMARE_noop; 
     589    subname "<commit_sequence ".($sub_id++).">" => sub { 
     590      my($c)=@_; 
     591      my $v = $c->($noop); 
     592      FAIL_SEQUENCE() if FAILED($v); 
     593      return $v; 
     594    }; 
     595  } 
     596 
     597  sub RMARE_commit_group { 
     598    my($o)=@_; 
     599    my $noop = $o->RMARE_noop; 
     600    subname "<commit_group ".($sub_id++).">" => sub { 
     601      my($c)=@_; 
     602      my $v = $c->($noop); 
     603      FAIL_GROUP() if FAILED($v); 
     604      return $v; 
     605    }; 
     606  } 
     607 
     608  sub RMARE_commit_regex { 
     609    my($o)=@_; 
     610    my $noop = $o->RMARE_noop; 
     611    subname "<commit_regex ".($sub_id++).">" => sub { 
     612      my($c)=@_; 
     613      my $v = $c->($noop); 
     614      FAIL_REGEX() if FAILED($v); 
     615      return $v; 
     616    }; 
     617  } 
     618 
     619  sub RMARE_commit_match { 
     620    my($o)=@_; 
     621    my $noop = $o->RMARE_noop; 
     622    subname "<commit_regex ".($sub_id++).">" => sub { 
     623      my($c)=@_; 
     624      my $v = $c->($noop); 
     625      FAIL_MATCH() if FAILED($v); 
     626      return $v; 
     627    }; 
     628  } 
     629 
     630  sub RMARE_independent { 
     631    my($o,$f)=@_; 
     632    my $noop = $o->RMARE_noop; 
     633    subname "<independent ".($sub_id++).">" => sub { 
     634      my $cn = $_[0]; 
     635      my $uid = "independent ".rand()."\n"; 
     636      my $nbt = sub { 
     637        my $c = $_[0]; 
     638        my $v = $c->($cn); 
     639        die $uid if FAILED($v); 
     640        $v; 
     641      }; 
     642      my $v = eval { $f->($nbt) }; 
     643      if($@) { 
     644        die if $@ ne $uid; 
     645        FAIL(); 
     646      } 
     647      $v; 
     648    }; 
     649  } 
     650 
     651} 
     652'); 
     653  }; 
     654}; 
     655 
     656eval_perl5( EmitRegex.regex_prelude() ); 

  • misc/elfish/rx_on_re/remains_of_Regexp_ModuleA.pm

    r21389 r21458  
    3030# Command-line and glue. 
    3131 
    32 { package VersionConstraints; 
    33   use Regexp::Common 2.122; 
    34   #use Sub::Name 0.03; 
    35   use Filter::Simple 0.82; 
    36 } 
    37  
    3832package Regexp::ModuleA; 
    3933use strict; 
    … …  
    9286use warnings; 
    9387 
    94 local $Regexp::ModuleA::ReentrantEngine::Env::str; 
    95 local $Regexp::ModuleA::ReentrantEngine::Env::pos; 
    96 local $Regexp::ModuleA::ReentrantEngine::Env::current_match; 
    97 local $Regexp::ModuleA::ReentrantEngine::Env::leaf_match; 
    98 local $Regexp::ModuleA::ReentrantEngine::Env::pkg; 
    99 local $Regexp::ModuleA::ReentrantEngine::Env::nested_data; 
    100 local $Regexp::ModuleA::ReentrantEngine::Env::alias_match; 
    101 #local $Regexp::ModuleA::ReentrantEngine::Env::stop; 
    102  
    103 { 
    104   package Regexp::ModuleA::AST::BaseClass; 
    105  
    106   #use Sub::Name; 
    107   sub subname { $_[1] } 
    108   our $sub_id = 1; 
    109  
    110   sub RMARE_emit { 
    111     my $cls = ref($_[0]); 
    112     die "bug: $cls RMARE_emit() unimplemented\n"; 
    113   } 
    114  
    115   my $noop; 
    116   $noop = subname "<noop ".($sub_id++).">" => sub { 
    117     my $c = $_[0]; 
    118     return 1 if !defined($c) || $c eq $noop; 
    119     TAILCALL($c,$noop); 
    120   }; 
    121   sub RMARE_noop { $noop } 
    122   sub RMARE_is_noop { 
    123     my($o,$c)=@_; 
    124     return 1 if !defined($c) || $c eq $noop; 
    125     return 0; 
    126   } 
    127  
    128   sub RMARE_eat_backref { 
    129     my($o,$idx,$mod5_re)=@_; 
    130     my $noop = $o->RMARE_noop; 
    131     subname "<eat_backref ".($sub_id++).">" => sub { 
    132       my $c = $_[0]; 
    133       my $a = $$Regexp::ModuleA::ReentrantEngine::Env::leaf_match->{match_array}; 
    134       FAIL() if $idx >= @$a; 
    135       my $m = $a->[$idx]; 
    136       $m = $m->[-1] if defined($m) && ref($m)eq'ARRAY'; 
    137       FAIL() if !defined($m) || !$m->match_boolean; 
    138       my $re = $m->match_string; 
    139       $re =~ s/(\W)/\\$1/g; 
    140  
    141       my($str) = $Regexp::ModuleA::ReentrantEngine::Env::str; 
    142       pos($str) = $Regexp::ModuleA::ReentrantEngine::Env::pos; 
    143       $str =~ /\G$mod5_re($re)/ or FAIL(); 
    144       $Regexp::ModuleA::ReentrantEngine::Env::pos += length($1); 
    145       TAILCALL($c,$noop); 
    146     }; 
    147   } 
    148   { use re 'eval'; 
    149   sub RMARE_eat_regexp { 
    150     my($o,$re)=@_; 
    151     my $noop = $o->RMARE_noop; 
    152     my $qr = qr/\G($re)/; 
    153     subname "<eat_regexp ".($sub_id++).">" => sub { 
    154       my $c = $_[0]; 
    155  
    156       my($str) = $Regexp::ModuleA::ReentrantEngine::Env::str; 
    157       pos($str) = $Regexp::ModuleA::ReentrantEngine::Env::pos; 
    158       $str =~ $qr or FAIL(); 
    159       $Regexp::ModuleA::ReentrantEngine::Env::pos += length($1); 
    160       TAILCALL($c,$noop); 
    161     } 
    162   } 
    163   } 
    164   sub RMARE_imsx { 
    165     my($o)=@_; 
    166     my $mod = ""; 
    167     $mod .= "i" if $o->{flags}{i}; 
    168     $mod .= "m" if $o->{flags}{perl5_m}; 
    169     $mod .= "s" if $o->{flags}{perl5_s}; 
    170     $mod .= "x" if $o->{flags}{perl5_x}; 
    171     $mod; 
    172   } 
    173   sub RMARE_wrap_re_with_mods {