[gforth] / gforth / regexp.fs  

gforth: gforth/regexp.fs

Diff for /gforth/regexp.fs between version 1.14 and 1.28

version 1.14, Thu May 27 08:58:57 2010 UTC version 1.28, Tue Dec 28 23:16:02 2010 UTC
Line 101 
Line 101 
 : ` ( "char" -- ) \ regexp-pattern  : ` ( "char" -- ) \ regexp-pattern
     \G check for particular char      \G check for particular char
     ]] count [[  char ]] Literal <> ?LEAVE [[ ;  immediate      ]] count [[  char ]] Literal <> ?LEAVE [[ ;  immediate
   : -` ( "char" -- ) \ regexp-pattern
 \ A word for string comparison      \G check for particular char
       ]] count [[  char ]] Literal = ?LEAVE [[ ;  immediate
 : $= ( addr1 addr2 u -- f )  tuck compare ;  
 : ,=" ( addr u -- ) tuck ]] dup SLiteral $= ?LEAVE Literal + noop [[ ;  
 : =" ( <string>" -- ) \ regexp-pattern  
     \G check for string  
     '" parse ,=" ; immediate  
   
 \ loop stack  \ loop stack
   
Line 118 
Line 113 
 : loops> ( -- addr ) -3 loops +!  loops @+ swap cells + 3@ ;  : loops> ( -- addr ) -3 loops +!  loops @+ swap cells + 3@ ;
 : >loops ( addr -- ) loops @+ swap cells + 3! 3 loops +! ;  : >loops ( addr -- ) loops @+ swap cells + 3! 3 loops +! ;
 : BEGIN, ( -- )  ]] BEGIN [[ >loops ;  : BEGIN, ( -- )  ]] BEGIN [[ >loops ;
 : DONE, ( -- )  loops @ IF  loops> ]] DONE [[ THEN ]] noop [[ ;  : DONE, ( -- )  loops @ IF  loops> ]] DONE [[ ELSE ." no done left!" cr THEN ;
   
 \ variables  \ variables
   
Line 131 
Line 126 
 : var> ( -- addr ) -1 varstack +!  : var> ( -- addr ) -1 varstack +!
     varstack @+ swap cells + @      varstack @+ swap cells + @
     1+ 2* cells vars + ;      1+ 2* cells vars + ;
   Variable greed-counts  9 cells allot \ no more than 9 nested greedy loops
   : greed' ( -- addr )  greed-counts dup @ + ;
   
 \ start end  \ start end
   
 0 Value end$  0 Value end$
   0 Value last$
 0 Value start$  0 Value start$
 : !end ( addr u -- addr )  over + to end$ dup to start$ ;  : !end ( addr u -- addr )  over + to end$ dup to start$ ;
 : end-rex? ( addr -- addr flag ) dup end$ u< ;  : end-rex? ( addr -- addr flag ) dup end$ u< ;
 : start-rex? ( addr -- addr flag ) dup start$ u> ;  : start-rex? ( addr -- addr flag ) dup start$ u> ;
 : ?end ( addr -- addr ) ]] dup end$ u> ?LEAVE [[ ; immediate  : ?end ( addr -- addr ) ]] dup end$ u> ?LEAVE [[ ; immediate
   : rest$ ( addr -- addr addr u ) dup end$ over - ;
   : >last ( addr -- flag )  dup to last$ end$ u<= ;
   
 \ start and end  \ start and end
   
Line 150 
Line 150 
     \G check for string end      \G check for string end
     ]] end-rex? ?LEAVE [[ ; immediate      ]] end-rex? ?LEAVE [[ ; immediate
   
   \ A word for string comparison
   
   : (str=?) ( addr1 addr u -- addr2 )
       dup >r 2>r rest$ r@ umin 2r> compare IF rdrop true ELSE r> + false THEN ;
   : str=? ( addr1 addr u -- addr2 ) ]] (str=?) ?LEAVE [[ ; immediate
   : ,=" ( addr u -- ) tuck dup ]] rest$ Literal umin SLiteral compare ?LEAVE Literal + [[ ;
   : =" ( <string>" -- ) \ regexp-pattern
       \G check for string
       '" parse ,=" ; immediate
   
 \ regexp block  \ regexp block
   
 \ FORK/JOIN are like AHEAD THEN, but producing a call on AHEAD  \ FORK/JOIN are like AHEAD THEN, but producing a call on AHEAD
Line 157 
Line 167 
   
 : (( ( addr u -- ) \ regexp-pattern  : (( ( addr u -- ) \ regexp-pattern
     \G start regexp block      \G start regexp block
     vars off varsmax off loops off      vars off varsmax off loops off greed-counts off
     ]] FORK  AHEAD BUT JOIN !end [[ BEGIN, ; immediate      ]] FORK  AHEAD BUT JOIN !end [[ BEGIN, ; immediate
 : )) ( -- addr f ) \ regexp-pattern  : )) ( -- addr f ) \ regexp-pattern
     \G end regexp block      \G end regexp block
     ]] ?end drop true EXIT [[      ]] >last  ;S [[
     DONE, ]] drop false EXIT THEN [[ ; immediate      DONE, ]] drop false ;S THEN [[ ; immediate
   
 \ greedy loops  \ greedy loops
   
Line 173 
Line 183 
   
 : {** ( addr -- addr addr ) \ regexp-pattern  : {** ( addr -- addr addr ) \ regexp-pattern
     \G greedy zero-or-more pattern      \G greedy zero-or-more pattern
     0 ]] Literal >r BEGIN dup [[ BEGIN, ; immediate      ]] false >r BEGIN  dup  FORK  BUT  WHILE  drop last$ r> 1+ >r  REPEAT [[
       ]] r>  AHEAD  BUT  JOIN [[
       BEGIN, ; immediate
 ' {** Alias {++ ( addr -- addr addr ) \ regexp-pattern  ' {** Alias {++ ( addr -- addr addr ) \ regexp-pattern
     \G greedy one-or-more pattern      \G greedy one-or-more pattern
     immediate      immediate
 : n*} ( sys n -- ) \ regexp-pattern  
     \G At least @var{n} pattern  
     >r ]] r> 1+ >r end-rex? 0= UNTIL dup [[ DONE, ]] drop [[  
     r@ IF r@ ]] r@ Literal u< IF  r> 1+ drops false  EXIT  THEN [[ THEN  
     r@ ]] r> 1+ Literal U+DO FORK BUT [[  
     ]] IF  I' I - [[ r@ 1- ]] Literal + drops true UNLOOP EXIT  THEN  LOOP [[  
     r@ IF  r@ ]] Literal drops [[ THEN  
     rdrop ]] false  EXIT  JOIN [[ ; immediate  
 : **} ( sys -- ) \ regexp-pattern  : **} ( sys -- ) \ regexp-pattern
     \G end of greedy zero-or-more pattern      \G end of greedy zero-or-more pattern
     0 postpone n*} ; immediate      ]] dup >last  ;S [[ DONE, ]] false ;S  THEN [[
       ]] nip 1+ false  U+DO  FORK BUT [[
       ]] IF  I' I - 1- drops UNLOOP  true ;S  THEN  LOOP [[
       ]] dup LEAVE JOIN [[ ; immediate
 : ++} ( sys -- ) \ regexp-pattern  : ++} ( sys -- ) \ regexp-pattern
     \G end of greedy zero-or-more pattern      \G end of greedy zero-or-more pattern
     1 postpone n*} ; immediate      ]] dup >last  ;S [[ DONE, ]] false ;S  THEN [[
       ]] nip false  U+DO  FORK BUT [[
       ]] IF  I' I - drops UNLOOP  true ;S  THEN  LOOP [[
       ]] LEAVE JOIN [[ ; immediate
   
 \ non-greedy loops  \ non-greedy loops
   
Line 202 
Line 212 
     ]] BEGIN  [[ BEGIN, ; immediate      ]] BEGIN  [[ BEGIN, ; immediate
 : {* ( addr -- addr addr ) \ regexp-pattern  : {* ( addr -- addr addr ) \ regexp-pattern
     \G non-greedy zero-or-more pattern      \G non-greedy zero-or-more pattern
     ]] {+ dup FORK BUT  IF  drop true  EXIT THEN [[ ; immediate      ]] {+ dup FORK BUT  IF  drop true  ;S THEN [[ ; immediate
 : *} ( addr addr' -- addr' ) \ regexp-pattern  : *} ( addr addr' -- addr' ) \ regexp-pattern
     \G end of non-greedy zero-or-more pattern      \G end of non-greedy zero-or-more pattern
     ]] dup end$ u>  UNTIL [[      ]] dup end$ u>  UNTIL [[
     DONE, ]] drop false  EXIT  JOIN [[ ; immediate      DONE, ]] drop false  ;S  JOIN [[ ; immediate
 : +} ( addr addr' -- addr' ) \ regexp-pattern  : +} ( addr addr' -- addr' ) \ regexp-pattern
     \G end of non-greedy one-or-more pattern      \G end of non-greedy one-or-more pattern
     ]] dup FORK BUT  IF  drop true  EXIT [[      ]] dup FORK BUT  IF  drop true  ;S [[
     DONE, ]] drop false  EXIT  THEN *} [[ ; immediate      DONE, ]] drop false  ;S [[ BEGIN, ]] THEN *} [[ ; immediate
   
 : // ( -- ) \ regexp-pattern  : // ( -- ) \ regexp-pattern
     \G search for string      \G search for string
Line 225 
Line 235 
   
 : {{ ( addr -- addr addr ) \ regexp-pattern  : {{ ( addr -- addr addr ) \ regexp-pattern
     \G Start of alternatives      \G Start of alternatives
     0 ]] dup BEGIN [[  vars @ ; immediate      0 ]] dup dup FORK  IF  2drop true ;S  BUT  JOIN [[ vars @ ; immediate
 : || ( addr addr -- addr addr ) \ regexp-pattern  : || ( addr addr -- addr addr ) \ regexp-pattern
     \G separator between alternatives      \G separator between alternatives
     vars @ varsmax @ max varsmax !      vars @ varsmax @ max varsmax !  vars !
     ]] nip AHEAD [[ >r >r >r vars !      ]] AHEAD  BUT  THEN  drop [[
     ]] DONE drop dup [[ r> r> r> ]] BEGIN [[ vars @ ; immediate      ]] dup dup FORK  IF  2drop true ;S  BUT  JOIN [[ vars @ ; immediate
 : }} ( addr addr -- addr addr ) \ regexp-pattern  : }} ( addr addr -- addr ) \ regexp-pattern
     \G end of alternatives      \G end of alternatives
     vars @ varsmax @ max vars !      vars @ varsmax @ max vars !  drop
     ]] nip AHEAD [[ >r >r >r drop      ]] AHEAD  BUT  THEN  2drop false ;S [[  THENs ; immediate
     ]] DONE drop LEAVE [[ r> r> r> THENs ; immediate  
   
 \ match variables  \ match variables
   
Line 263 
Line 272 
 0 Value >>ptr  0 Value >>ptr
 0 Value <<ptr  0 Value <<ptr
 Variable >>string  Variable >>string
 : >>  ( addr -- addr ) \ regexp-replace  : s>>  ( addr -- addr ) \ regexp-replace
     \G Start replace pattern region      \G Start replace pattern region
     dup to >>ptr ;      dup to >>ptr ;
 : << ( run-addr addr u -- run-addr ) \ regexp-replace  : << ( run-addr addr u -- run-addr ) \ regexp-replace
     \G Replace string from start of replace pattern region with      \G Replace string from start of replace pattern region with
     \G @var{addr} @var{u}      \G @var{addr} @var{u}
     <<ptr 0= IF  start$ to <<ptr  THEN  
     >>string @ 0= IF  s" " >>string $!  THEN  
     <<ptr >>ptr over - >>string $+!      <<ptr >>ptr over - >>string $+!
     >>string $+! dup to <<ptr ;      >>string $+! dup to <<ptr ;
 : <<" ( "string<">" -- ) \ regexp-replace  : <<" ( "string<">" -- ) \ regexp-replace
Line 278 
Line 285 
     \G @var{string}      \G @var{string}
     '" parse postpone SLiteral postpone << ; immediate      '" parse postpone SLiteral postpone << ; immediate
 : >>string@ ( -- addr u )  : >>string@ ( -- addr u )
     >>string $@ >>string off      >>string $@ ;
     0 to >>ptr  0 to <<ptr ;  : >>string0 ( addr u -- addr u )  s" " >>string $!
       0 to >>ptr  over to <<ptr ;
 : >>next ( -- addr u ) <<ptr end$ over - ;  : >>next ( -- addr u ) <<ptr end$ over - ;
 : >>rest ( -- ) >>next >>string $+! ;  : >>rest ( -- ) >>next >>string $+! ;
 : s// ( addr u -- ptr )  : s// ( addr u -- ptr )
     \G start search/replace loop      \G start search/replace loop
     ]] (( // >> [[ ; immediate      ]] >>string0 (( // s>> [[ ; immediate
 : // ( ptr addr u -- addr' u' )  : >> ( addr -- addr )
       ]] <<ptr >>ptr u> ?LEAVE ?end [[ ; immediate
   : //s ( ptr -- )
       \G search end
       ]] )) drop >>rest >>string@ [[ ; immediate
   : //o ( ptr addr u -- addr' u' )
     \G end search/replace single loop      \G end search/replace single loop
     ]] << )) drop >>rest >>string@ [[ ; immediate      ]] << //s [[ ; immediate
 : //g ( ptr addr u -- addr' u' )  : //g ( ptr addr u -- addr' u' )
     \G end search/replace all loop      \G end search/replace all loop
     ]] << LEAVE )) drop >>string@ [[ ; immediate      ]] << LEAVE //s [[ ; immediate

Generate output suitable for use with a patch program
Legend:
Removed from v.1.14  
changed lines
  Added in v.1.28
CVS Admin

Powered by ViewCVS 1.0-dev 		(Powered by ViewCVS)

ViewCVS and CVS Help