[gforth] / gforth / regexp.fs  

gforth: gforth/regexp.fs

Diff for /gforth/regexp.fs between version 1.2 and 1.27

version 1.2, Sat Nov 5 23:29:06 2005 UTC version 1.27, Tue Dec 28 22:43:24 2010 UTC
Line 1 
Line 1 
 \ Regexp compile  \ Regexp compile
   
   \ Copyright (C) 2005,2006,2007,2008 Free Software Foundation, Inc.
   
   \ This file is part of Gforth.
   
   \ Gforth is free software; you can redistribute it and/or
   \ modify it under the terms of the GNU General Public License
   \ as published by the Free Software Foundation, either version 3
   \ of the License, or (at your option) any later version.
   
   \ This program is distributed in the hope that it will be useful,
   \ but WITHOUT ANY WARRANTY; without even the implied warranty of
   \ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
   \ GNU General Public License for more details.
   
   \ You should have received a copy of the GNU General Public License
   \ along with this program. If not, see http://www.gnu.org/licenses/.
   
 \ The idea of the parser is the following:  \ The idea of the parser is the following:
 \ As long as there's a match, continue  \ As long as there's a match, continue
 \ On a mismatch, LEAVE.  \ On a mismatch, LEAVE.
Line 11 
Line 28 
   
 \ special control structure  \ special control structure
   
 : FORK ( compilation -- orig ; run-time f -- ) \ core  : FORK ( compilation -- orig ; run-time f -- ) \ gforth
       \G AHEAD-like control structure: calls the code after JOIN.
     POSTPONE call >mark ; immediate restrict      POSTPONE call >mark ; immediate restrict
 : JOIN ( orig -- )  postpone THEN ; immediate restrict  : JOIN ( orig -- ) \ gforth
       \G THEN-like control structure for FORK
       postpone THEN ; immediate restrict
   
 \ Charclasses  \ Charclasses
   
Line 22 
Line 42 
 : @+ ( addr -- n addr' )  dup @ swap cell+ ;  : @+ ( addr -- n addr' )  dup @ swap cell+ ;
   
 0 Value cur-class  0 Value cur-class
 : charclass ( -- )  Create here dup to cur-class $100 dup allot erase ;  : charclass ( -- ) \ regexp-cg
 : +char ( char -- )  cur-class swap +bit ;      \G Create a charclass
 : -char ( char -- )  cur-class swap -bit ;      Create here dup to cur-class $100 dup allot erase ;
 : ..char ( start end -- )  1+ swap ?DO  I +char  LOOP ;  : +char ( char -- ) \ regexp-cg
       \G add a char to the current charclass
       cur-class swap +bit ;
   : -char ( char -- ) \ regexp-cg
       \G remove a char from the current charclass
       cur-class swap -bit ;
   : ..char ( start end -- ) \ regexp-cg
       \G add a range of chars to the current charclass
       1+ swap ?DO  I +char  LOOP ;
 : or! ( n addr -- )  dup @ rot or swap ! ;  : or! ( n addr -- )  dup @ rot or swap ! ;
 : and! ( n addr -- )  dup @ rot and swap ! ;  : and! ( n addr -- )  dup @ rot and swap ! ;
 : +class ( class -- )  $100 0 ?DO  @+ swap  : +class ( class -- ) \ regexp-cg
       \G union of charclass @var{class} and the current charclass
       $100 0 ?DO  @+ swap
         cur-class I + or!  cell +LOOP  drop ;          cur-class I + or!  cell +LOOP  drop ;
 : -class ( class -- )  $100 0 ?DO  @+ swap invert  : -class ( class -- ) \ regexp-cg
       \G subtract the charclass @var{class} from the current charclass
       $100 0 ?DO  @+ swap invert
         cur-class I + and!  cell +LOOP  drop ;          cur-class I + and!  cell +LOOP  drop ;
   
 : char? ( addr class -- addr' flag )  : char? ( addr class -- addr' flag )
Line 38 
Line 70 
   
 \ Charclass tests  \ Charclass tests
   
 : c? ( addr class -- )   ]] char? 0= ?LEAVE [[ ; immediate  : c? ( addr class -- ) \ regexp-pattern
 : -c? ( addr class -- )  ]] char?    ?LEAVE [[ ; immediate      \G check @var{addr} for membership in charclass @var{class}
       ]] char? 0= ?LEAVE [[ ; immediate
   : -c? ( addr class -- ) \ regexp-pattern
       \G check @var{addr} for not membership in charclass @var{class}
       ]] char?    ?LEAVE [[ ; immediate
   
 charclass digit  '0 '9 ..char  charclass digit  '0 '9 ..char
 charclass blanks 0 bl ..char  charclass blanks 0 bl ..char
Line 47 
Line 83 
 charclass letter 'a 'z ..char 'A 'Z ..char  charclass letter 'a 'z ..char 'A 'Z ..char
 charclass any    0 $FF ..char #lf -char  charclass any    0 $FF ..char #lf -char
   
 : \d ( addr -- addr' )   ]] digit c?        [[ ; immediate  : \d ( addr -- addr' ) \ regexp-pattern
 : \s ( addr -- addr' )   ]] blanks c?       [[ ; immediate      \G check for digit
 : .? ( addr -- addr' )   ]] any c?          [[ ; immediate      ]] digit c?        [[ ; immediate
 : -\d ( addr -- addr' )  ]] digit -c?       [[ ; immediate  : \s ( addr -- addr' ) \ regexp-pattern
 : -\s ( addr -- addr' )  ]] blanks -c?      [[ ; immediate      \G check for blanks
 : ` ( -- )      ]] blanks c?       [[ ; immediate
   : .? ( addr -- addr' ) \ regexp-pattern
       \G check for any single charachter
       ]] any c?          [[ ; immediate
   : -\d ( addr -- addr' ) \ regexp-pattern
       \G check for not digit
       ]] digit -c?       [[ ; immediate
   : -\s ( addr -- addr' ) \ regexp-pattern
       \G check for not blank
       ]] blanks -c?      [[ ; immediate
   : ` ( "char" -- ) \ regexp-pattern
       \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>" -- )  '" parse ,=" ; immediate  
   
 \ loop stack  \ loop stack
   
Line 69 
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 82 
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 start$  0 Value start$
 : !end ( addr u -- addr )  over + to end$ dup to start$ ;  : !end ( addr u -- addr )  over + to end$ dup to start$ ;
 : $? ( addr -- addr flag ) dup end$ u< ;  : end-rex? ( addr -- addr flag ) dup end$ u< ;
 : ^? ( 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 - ;
   
 \ start and end  \ start and end
   
 : \^ ( addr -- addr )  : \^ ( addr -- addr ) \ regexp-pattern
     ]] ^? ?LEAVE [[ ; immediate      \G check for string start
 : \$ ( addr -- addr )      ]] start-rex? ?LEAVE [[ ; immediate
     ]] $? ?LEAVE [[ ; immediate  : \$ ( addr -- addr ) \ regexp-pattern
       \G check for string end
       ]] 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
 \ instead of a jump.  \ instead of a jump.
   
 : (( ( addr u -- )  vars off varsmax off loops off  : (( ( addr u -- ) \ regexp-pattern
       \G start regexp block
       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 )  : )) ( -- addr f ) \ regexp-pattern
     ]] ?end drop true EXIT [[      \G end regexp block
     DONE, ]] drop false EXIT THEN [[ ; immediate      ]] ?end drop true ;S [[
       DONE, ]] drop false ;S THEN [[ ; immediate
   
 \ greedy loops  \ greedy loops
   
Line 117 
Line 179 
   
 : drops ( n -- ) 1+ cells sp@ + sp! ;  : drops ( n -- ) 1+ cells sp@ + sp! ;
   
 : {** ( addr -- addr addr )  : {** ( addr -- addr addr ) \ regexp-pattern
     0 ]] Literal >r BEGIN dup [[ BEGIN, ; immediate      \G greedy zero-or-more pattern
 ' {** Alias {++ ( addr -- addr addr ) immediate      ]] false >r BEGIN  dup  FORK  BUT  WHILE  r> 1+ >r  REPEAT [[
 : n*} ( sys n -- )  >r ]] r> 1+ >r $? 0= UNTIL dup [[ DONE, ]] drop [[      ]] r>  AHEAD  BUT  JOIN [[
     r@ IF r@ ]] r@ Literal u< IF  r> 1+ drops false  EXIT  THEN [[ THEN      BEGIN, ; immediate
     r@ ]] r> 1+ Literal U+DO FORK BUT [[  ' {** Alias {++ ( addr -- addr addr ) \ regexp-pattern
     ]] IF  I' I - [[ r@ 1- ]] Literal + drops true UNLOOP EXIT  THEN  LOOP [[      \G greedy one-or-more pattern
     r@ IF  r@ ]] Literal drops [[ THEN      immediate
     rdrop ]] false  EXIT  JOIN [[ ; immediate  : **} ( sys -- ) \ regexp-pattern
 : **}  0 postpone n*} ; immediate      \G end of greedy zero-or-more pattern
 : ++}  1 postpone n*} ; immediate      ]] dup end$ u<=  ;S [[ DONE, ]] false ;S  THEN [[
       ]] nip 1+ false  U+DO  FORK BUT [[
       ]] IF  I' I - 1- drops true UNLOOP ;S  THEN  LOOP [[
       ]] dup LEAVE JOIN [[ ; immediate
   : ++} ( sys -- ) \ regexp-pattern
       \G end of greedy zero-or-more pattern
       ]] dup end$ u<=  ;S [[ DONE, ]] false ;S  THEN [[
       ]] nip false  U+DO  FORK BUT [[
       ]] IF  I' I - drops true UNLOOP ;S  THEN  LOOP [[
       ]] drop dup LEAVE JOIN [[ ; immediate
   
 \ non-greedy loops  \ non-greedy loops
   
 \ Idea: Try to match rest of the regexp, and if that fails, try match  \ Idea: Try to match rest of the regexp, and if that fails, try match
 \ first expr and then try again rest of regexp.  \ first expr and then try again rest of regexp.
   
 : {+ ( addr -- addr addr )  : {+ ( addr -- addr addr ) \ regexp-pattern
       \G non-greedy one-or-more pattern
     ]] BEGIN  [[ BEGIN, ; immediate      ]] BEGIN  [[ BEGIN, ; immediate
 : {* ( addr -- addr addr )  : {* ( addr -- addr addr ) \ regexp-pattern
     ]] {+ dup FORK BUT  IF  drop true  EXIT THEN [[ ; immediate      \G non-greedy zero-or-more pattern
 : *} ( addr addr' -- addr' )      ]] {+ dup FORK BUT  IF  drop true  ;S THEN [[ ; immediate
   : *} ( addr addr' -- addr' ) \ regexp-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' )  : +} ( addr addr' -- addr' ) \ regexp-pattern
     ]] dup FORK BUT  IF  drop true  EXIT [[      \G end of non-greedy one-or-more pattern
     DONE, ]] drop false  EXIT  THEN *} [[ ; immediate      ]] dup FORK BUT  IF  drop true  ;S [[
       DONE, ]] drop dup  LEAVE [[ BEGIN, ]] THEN *} [[ ; immediate
 : // ( -- ) ]] {* 1+ *} [[ ; immediate  
   : // ( -- ) \ regexp-pattern
       \G search for string
       ]] {* 1+ *} [[ ; immediate
   
 \ alternatives  \ alternatives
   
Line 154 
Line 231 
   
 : THENs ( sys -- )  BEGIN  dup  WHILE  ]] THEN [[  REPEAT  drop ;  : THENs ( sys -- )  BEGIN  dup  WHILE  ]] THEN [[  REPEAT  drop ;
   
 : {{ ( addr -- addr addr )  0 ]] dup BEGIN [[  vars @ ; immediate  : {{ ( addr -- addr addr ) \ regexp-pattern
 : || ( addr addr -- addr addr ) vars @ varsmax @ max varsmax !      \G Start of alternatives
     ]] nip AHEAD [[ >r >r >r vars !      0 ]] dup dup FORK  IF  2drop true ;S  BUT  JOIN [[ vars @ ; immediate
     ]] DONE drop dup [[ r> r> r> ]] BEGIN [[ vars @ ; immediate  : || ( addr addr -- addr addr ) \ regexp-pattern
 : }} ( addr addr -- addr addr ) vars @ varsmax @ max vars !      \G separator between alternatives
     ]] nip AHEAD [[ >r >r >r drop      vars @ varsmax @ max varsmax !  vars !
     ]] DONE drop LEAVE [[ r> r> r> THENs ; immediate      ]] AHEAD  BUT  THEN  drop [[
       ]] dup dup FORK  IF  2drop true ;S  BUT  JOIN [[ vars @ ; immediate
   : }} ( addr addr -- addr ) \ regexp-pattern
       \G end of alternatives
       vars @ varsmax @ max vars !  drop
       ]] AHEAD  BUT  THEN  drop LEAVE [[  THENs ; immediate
   
 \ match variables  \ match variables
   
 : \( ( addr -- addr )  ]] dup [[  : \( ( addr -- addr ) \ regexp-pattern
       \G start of matching variable; variables are referred as \\1--9
       ]] dup [[
     >var ]] ALiteral ! [[ ; immediate      >var ]] ALiteral ! [[ ; immediate
 : \) ( addr -- addr )  ]] dup [[  : \) ( addr -- addr ) \ regexp-pattern
       \G end of matching variable
       ]] dup [[
     var> ]] ALiteral ! [[ ; immediate      var> ]] ALiteral ! [[ ; immediate
 : \0 ( -- addr u )  start$ end$ over - ;  : \0 ( -- addr u ) \ regexp-pattern
       \G the whole string
       start$ end$ over - ;
 : \: ( i -- )  : \: ( i -- )
     Create 2* 1+ cells vars + ,      Create 2* 1+ cells vars + ,
   DOES> ( -- addr u ) @ 2@ tuck - ;    DOES> ( -- addr u ) @ 2@ tuck - ;
 : \:s ( n -- ) 0 ?DO  I \:  LOOP ;  : \:s ( n -- ) 0 ?DO  I \:  LOOP ;
 9 \:s \1 \2 \3 \4 \5 \6 \7 \8 \9  9 \:s \1 \2 \3 \4 \5 \6 \7 \8 \9
   
   \ replacements, needs string.fs
   
   require string.fs
   
   0 Value >>ptr
   0 Value <<ptr
   Variable >>string
   : s>>  ( addr -- addr ) \ regexp-replace
       \G Start replace pattern region
       dup to >>ptr ;
   : << ( run-addr addr u -- run-addr ) \ regexp-replace
       \G Replace string from start of replace pattern region with
       \G @var{addr} @var{u}
       <<ptr >>ptr over - >>string $+!
       >>string $+! dup to <<ptr ;
   : <<" ( "string<">" -- ) \ regexp-replace
       \G Replace string from start of replace pattern region with
       \G @var{string}
       '" parse postpone SLiteral postpone << ; immediate
   : >>string@ ( -- addr u )
       >>string $@ ;
   : >>string0 ( addr u -- addr u )  s" " >>string $!
       0 to >>ptr  over to <<ptr ;
   : >>next ( -- addr u ) <<ptr end$ over - ;
   : >>rest ( -- ) >>next >>string $+! ;
   : s// ( addr u -- ptr )
       \G start search/replace loop
       ]] >>string0 (( // s>> [[ ; immediate
   : >> ( 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
       ]] << //s [[ ; immediate
   : //g ( ptr addr u -- addr' u' )
       \G end search/replace all loop
       ]] << LEAVE //s [[ ; immediate

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

Powered by ViewCVS 1.0-dev 		(Powered by ViewCVS)

ViewCVS and CVS Help