Annotation of gforth/regexp.fs, revision 1.31

1.31    ! pazsan      1: \ Regexp compiler
1.1       pazsan      2: 
1.31    ! pazsan      3: \ Copyright (C) 2005,2006,2007,2008,2010 Free Software Foundation, Inc.
1.3       anton       4: 
                      5: \ This file is part of Gforth.
                      6: 
                      7: \ Gforth is free software; you can redistribute it and/or
                      8: \ modify it under the terms of the GNU General Public License
1.10      anton       9: \ as published by the Free Software Foundation, either version 3
1.3       anton      10: \ of the License, or (at your option) any later version.
                     11: 
                     12: \ This program is distributed in the hope that it will be useful,
                     13: \ but WITHOUT ANY WARRANTY; without even the implied warranty of
                     14: \ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
                     15: \ GNU General Public License for more details.
                     16: 
                     17: \ You should have received a copy of the GNU General Public License
1.10      anton      18: \ along with this program. If not, see http://www.gnu.org/licenses/.
1.3       anton      19: 
1.1       pazsan     20: \ The idea of the parser is the following:
                     21: \ As long as there's a match, continue
                     22: \ On a mismatch, LEAVE.
                     23: \ Insert appropriate control structures on alternative branches
                     24: \ Keep the old pointer (backtracking) on the stack
                     25: \ I try to keep the syntax as close to a real regexp system as possible
                     26: \ All regexp stuff is compiled into one function as forward branching
                     27: \ state machine
                     28: 
1.2       pazsan     29: \ special control structure
1.1       pazsan     30: 
1.8       pazsan     31: : FORK ( compilation -- orig ; run-time f -- ) \ gforth
                     32:     \G AHEAD-like control structure: calls the code after JOIN.
1.1       pazsan     33:     POSTPONE call >mark ; immediate restrict
1.8       pazsan     34: : JOIN ( orig -- ) \ gforth
                     35:     \G THEN-like control structure for FORK
                     36:     postpone THEN ; immediate restrict
1.1       pazsan     37: 
                     38: \ Charclasses
                     39: 
                     40: : +bit ( addr n -- )  + 1 swap c! ;
                     41: : -bit ( addr n -- )  + 0 swap c! ;
                     42: : @+ ( addr -- n addr' )  dup @ swap cell+ ;
                     43: 
                     44: 0 Value cur-class
1.8       pazsan     45: : charclass ( -- ) \ regexp-cg
                     46:     \G Create a charclass
                     47:     Create here dup to cur-class $100 dup allot erase ;
                     48: : +char ( char -- ) \ regexp-cg
                     49:     \G add a char to the current charclass
                     50:     cur-class swap +bit ;
                     51: : -char ( char -- ) \ regexp-cg
                     52:     \G remove a char from the current charclass
                     53:     cur-class swap -bit ;
                     54: : ..char ( start end -- ) \ regexp-cg
                     55:     \G add a range of chars to the current charclass
                     56:     1+ swap ?DO  I +char  LOOP ;
1.1       pazsan     57: : or! ( n addr -- )  dup @ rot or swap ! ;
                     58: : and! ( n addr -- )  dup @ rot and swap ! ;
1.8       pazsan     59: : +class ( class -- ) \ regexp-cg
                     60:     \G union of charclass @var{class} and the current charclass
                     61:     $100 0 ?DO  @+ swap
                     62:     cur-class I + or!  cell +LOOP  drop ;
                     63: : -class ( class -- ) \ regexp-cg
                     64:     \G subtract the charclass @var{class} from the current charclass
                     65:     $100 0 ?DO  @+ swap invert
                     66:     cur-class I + and!  cell +LOOP  drop ;
1.1       pazsan     67: 
                     68: : char? ( addr class -- addr' flag )
                     69:     >r count r> + c@ ;
                     70: 
                     71: \ Charclass tests
                     72: 
1.8       pazsan     73: : c? ( addr class -- ) \ regexp-pattern
                     74:     \G check @var{addr} for membership in charclass @var{class}
                     75:     ]] char? 0= ?LEAVE [[ ; immediate
                     76: : -c? ( addr class -- ) \ regexp-pattern
                     77:     \G check @var{addr} for not membership in charclass @var{class}
                     78:     ]] char?    ?LEAVE [[ ; immediate
1.1       pazsan     79: 
                     80: charclass digit  '0 '9 ..char
                     81: charclass blanks 0 bl ..char
                     82: \ bl +char #tab +char #cr +char #lf +char ctrl L +char
                     83: charclass letter 'a 'z ..char 'A 'Z ..char
                     84: charclass any    0 $FF ..char #lf -char
                     85: 
1.8       pazsan     86: : \d ( addr -- addr' ) \ regexp-pattern
                     87:     \G check for digit
                     88:     ]] digit c?        [[ ; immediate
                     89: : \s ( addr -- addr' ) \ regexp-pattern
                     90:     \G check for blanks
                     91:     ]] blanks c?       [[ ; immediate
                     92: : .? ( addr -- addr' ) \ regexp-pattern
                     93:     \G check for any single charachter
                     94:     ]] any c?          [[ ; immediate
                     95: : -\d ( addr -- addr' ) \ regexp-pattern
                     96:     \G check for not digit
                     97:     ]] digit -c?       [[ ; immediate
                     98: : -\s ( addr -- addr' ) \ regexp-pattern
                     99:     \G check for not blank
                    100:     ]] blanks -c?      [[ ; immediate
                    101: : ` ( "char" -- ) \ regexp-pattern
                    102:     \G check for particular char
1.1       pazsan    103:     ]] count [[  char ]] Literal <> ?LEAVE [[ ;  immediate
1.17      pazsan    104: : -` ( "char" -- ) \ regexp-pattern
                    105:     \G check for particular char
                    106:     ]] count [[  char ]] Literal = ?LEAVE [[ ;  immediate
1.1       pazsan    107: 
                    108: \ loop stack
                    109: 
                    110: Variable loops  $40 3 * cells allot
                    111: : 3@ ( addr -- a b c )  dup >r 2 cells + @ r> 2@ ;
                    112: : 3! ( a b c addr -- )  dup >r 2! r> 2 cells + ! ;
                    113: : loops> ( -- addr ) -3 loops +!  loops @+ swap cells + 3@ ;
                    114: : >loops ( addr -- ) loops @+ swap cells + 3! 3 loops +! ;
                    115: : BEGIN, ( -- )  ]] BEGIN [[ >loops ;
1.23      pazsan    116: : DONE, ( -- )  loops @ IF  loops> ]] DONE [[ ELSE ." no done left!" cr THEN ;
1.1       pazsan    117: 
                    118: \ variables
                    119: 
                    120: Variable vars   &18 cells allot
                    121: Variable varstack 9 cells allot
                    122: Variable varsmax
                    123: : >var ( -- addr ) vars @+ swap 2* cells +
                    124:     vars @ varstack @+ swap cells + !
                    125:     1 vars +! 1 varstack +! ;
                    126: : var> ( -- addr ) -1 varstack +!
                    127:     varstack @+ swap cells + @
                    128:     1+ 2* cells vars + ;
1.26      pazsan    129: Variable greed-counts  9 cells allot \ no more than 9 nested greedy loops
                    130: : greed' ( -- addr )  greed-counts dup @ + ;
1.1       pazsan    131: 
                    132: \ start end
                    133: 
                    134: 0 Value end$
1.28      pazsan    135: 0 Value last$
1.1       pazsan    136: 0 Value start$
                    137: : !end ( addr u -- addr )  over + to end$ dup to start$ ;
1.12      pazsan    138: : end-rex? ( addr -- addr flag ) dup end$ u< ;
                    139: : start-rex? ( addr -- addr flag ) dup start$ u> ;
1.1       pazsan    140: : ?end ( addr -- addr ) ]] dup end$ u> ?LEAVE [[ ; immediate
1.20      pazsan    141: : rest$ ( addr -- addr addr u ) dup end$ over - ;
1.28      pazsan    142: : >last ( addr -- flag )  dup to last$ end$ u<= ;
1.1       pazsan    143: 
                    144: \ start and end
                    145: 
1.8       pazsan    146: : \^ ( addr -- addr ) \ regexp-pattern
                    147:     \G check for string start
1.12      pazsan    148:     ]] start-rex? ?LEAVE [[ ; immediate
1.8       pazsan    149: : \$ ( addr -- addr ) \ regexp-pattern
                    150:     \G check for string end
1.12      pazsan    151:     ]] end-rex? ?LEAVE [[ ; immediate
1.1       pazsan    152: 
1.17      pazsan    153: \ A word for string comparison
                    154: 
1.22      pazsan    155: : (str=?) ( addr1 addr u -- addr2 )
1.20      pazsan    156:     dup >r 2>r rest$ r@ umin 2r> compare IF rdrop true ELSE r> + false THEN ;
1.22      pazsan    157: : str=? ( addr1 addr u -- addr2 ) ]] (str=?) ?LEAVE [[ ; immediate
                    158: : ,=" ( addr u -- ) tuck dup ]] rest$ Literal umin SLiteral compare ?LEAVE Literal + [[ ;
1.17      pazsan    159: : =" ( <string>" -- ) \ regexp-pattern
                    160:     \G check for string
                    161:     '" parse ,=" ; immediate
                    162: 
1.1       pazsan    163: \ regexp block
                    164: 
                    165: \ FORK/JOIN are like AHEAD THEN, but producing a call on AHEAD
                    166: \ instead of a jump.
                    167: 
1.8       pazsan    168: : (( ( addr u -- ) \ regexp-pattern
                    169:     \G start regexp block
1.26      pazsan    170:     vars off varsmax off loops off greed-counts off
1.1       pazsan    171:     ]] FORK  AHEAD BUT JOIN !end [[ BEGIN, ; immediate
1.29      pazsan    172: : )) ( -- flag ) \ regexp-pattern
1.8       pazsan    173:     \G end regexp block
1.28      pazsan    174:     ]] >last  ;S [[
1.19      pazsan    175:     DONE, ]] drop false ;S THEN [[ ; immediate
1.1       pazsan    176: 
                    177: \ greedy loops
                    178: 
                    179: \ Idea: scan as many characters as possible, try the rest of the pattern
                    180: \ and then back off one pattern at a time
                    181: 
                    182: : drops ( n -- ) 1+ cells sp@ + sp! ;
                    183: 
1.8       pazsan    184: : {** ( addr -- addr addr ) \ regexp-pattern
                    185:     \G greedy zero-or-more pattern
1.30      pazsan    186:     ]] false >r BEGIN  dup  FORK  BUT  WHILE  last$ r> 1+ >r  REPEAT [[
1.27      pazsan    187:     ]] r>  AHEAD  BUT  JOIN [[
                    188:     BEGIN, ; immediate
1.8       pazsan    189: ' {** Alias {++ ( addr -- addr addr ) \ regexp-pattern
                    190:     \G greedy one-or-more pattern
                    191:     immediate
                    192: : **} ( sys -- ) \ regexp-pattern
                    193:     \G end of greedy zero-or-more pattern
1.30      pazsan    194:     ]] >last  ;S [[ DONE, ]] drop false ;S  THEN [[
                    195:     ]] 1+ false  U+DO  FORK BUT [[
1.28      pazsan    196:     ]] IF  I' I - 1- drops UNLOOP  true ;S  THEN  LOOP [[
1.29      pazsan    197:     ]] false ;S JOIN [[ ; immediate
1.8       pazsan    198: : ++} ( sys -- ) \ regexp-pattern
                    199:     \G end of greedy zero-or-more pattern
1.30      pazsan    200:     ]] >last  ;S [[ DONE, ]] drop false ;S  THEN [[
                    201:     ]] false  U+DO  FORK BUT [[
1.28      pazsan    202:     ]] IF  I' I - drops UNLOOP  true ;S  THEN  LOOP [[
1.29      pazsan    203:     ]] drop false ;S JOIN [[ ; immediate
1.1       pazsan    204: 
                    205: \ non-greedy loops
                    206: 
                    207: \ Idea: Try to match rest of the regexp, and if that fails, try match
                    208: \ first expr and then try again rest of regexp.
                    209: 
1.8       pazsan    210: : {+ ( addr -- addr addr ) \ regexp-pattern
                    211:     \G non-greedy one-or-more pattern
1.1       pazsan    212:     ]] BEGIN  [[ BEGIN, ; immediate
1.8       pazsan    213: : {* ( addr -- addr addr ) \ regexp-pattern
                    214:     \G non-greedy zero-or-more pattern
1.19      pazsan    215:     ]] {+ dup FORK BUT  IF  drop true  ;S THEN [[ ; immediate
1.8       pazsan    216: : *} ( addr addr' -- addr' ) \ regexp-pattern
                    217:     \G end of non-greedy zero-or-more pattern
1.1       pazsan    218:     ]] dup end$ u>  UNTIL [[
1.19      pazsan    219:     DONE, ]] drop false  ;S  JOIN [[ ; immediate
1.8       pazsan    220: : +} ( addr addr' -- addr' ) \ regexp-pattern
                    221:     \G end of non-greedy one-or-more pattern
1.19      pazsan    222:     ]] dup FORK BUT  IF  drop true  ;S [[
1.28      pazsan    223:     DONE, ]] drop false  ;S [[ BEGIN, ]] THEN *} [[ ; immediate
1.1       pazsan    224: 
1.8       pazsan    225: : // ( -- ) \ regexp-pattern
                    226:     \G search for string
                    227:     ]] {* 1+ *} [[ ; immediate
1.1       pazsan    228: 
                    229: \ alternatives
                    230: 
                    231: \ idea: try to match one alternative and then the rest of regexp.
                    232: \ if that fails, jump back to second alternative
                    233: 
1.24      pazsan    234: : THENs ( sys -- )  BEGIN  dup  WHILE  ]] THEN [[  REPEAT  drop ;
1.1       pazsan    235: 
1.8       pazsan    236: : {{ ( addr -- addr addr ) \ regexp-pattern
                    237:     \G Start of alternatives
1.29      pazsan    238:     0 ]] dup FORK  IF  drop true ;S  BUT  JOIN [[ vars @ ; immediate
1.8       pazsan    239: : || ( addr addr -- addr addr ) \ regexp-pattern
                    240:     \G separator between alternatives
1.24      pazsan    241:     vars @ varsmax @ max varsmax !  vars !
1.29      pazsan    242:     ]] AHEAD  BUT  THEN  [[
                    243:     ]] dup FORK  IF  drop true ;S  BUT  JOIN [[ vars @ ; immediate
1.21      pazsan    244: : }} ( addr addr -- addr ) \ regexp-pattern
1.8       pazsan    245:     \G end of alternatives
1.24      pazsan    246:     vars @ varsmax @ max vars !  drop
1.29      pazsan    247:     ]] AHEAD  BUT  THEN  drop false ;S [[  THENs ; immediate
1.1       pazsan    248: 
                    249: \ match variables
                    250: 
1.8       pazsan    251: : \( ( addr -- addr ) \ regexp-pattern
                    252:     \G start of matching variable; variables are referred as \\1--9
                    253:     ]] dup [[
1.1       pazsan    254:     >var ]] ALiteral ! [[ ; immediate
1.8       pazsan    255: : \) ( addr -- addr ) \ regexp-pattern
                    256:     \G end of matching variable
                    257:     ]] dup [[
1.1       pazsan    258:     var> ]] ALiteral ! [[ ; immediate
1.8       pazsan    259: : \0 ( -- addr u ) \ regexp-pattern
                    260:     \G the whole string
                    261:     start$ end$ over - ;
1.1       pazsan    262: : \: ( i -- )
                    263:     Create 2* 1+ cells vars + ,
                    264:   DOES> ( -- addr u ) @ 2@ tuck - ;
                    265: : \:s ( n -- ) 0 ?DO  I \:  LOOP ;
                    266: 9 \:s \1 \2 \3 \4 \5 \6 \7 \8 \9
1.6       pazsan    267: 
                    268: \ replacements, needs string.fs
                    269: 
                    270: require string.fs
                    271: 
                    272: 0 Value >>ptr
                    273: 0 Value <<ptr
                    274: Variable >>string
1.17      pazsan    275: : s>>  ( addr -- addr ) \ regexp-replace
1.8       pazsan    276:     \G Start replace pattern region
                    277:     dup to >>ptr ;
                    278: : << ( run-addr addr u -- run-addr ) \ regexp-replace
                    279:     \G Replace string from start of replace pattern region with
                    280:     \G @var{addr} @var{u}
1.6       pazsan    281:     <<ptr >>ptr over - >>string $+!
                    282:     >>string $+! dup to <<ptr ;
1.8       pazsan    283: : <<" ( "string<">" -- ) \ regexp-replace
                    284:     \G Replace string from start of replace pattern region with
                    285:     \G @var{string}
                    286:     '" parse postpone SLiteral postpone << ; immediate
1.6       pazsan    287: : >>string@ ( -- addr u )
1.16      pazsan    288:     >>string $@ ;
                    289: : >>string0 ( addr u -- addr u )  s" " >>string $!
                    290:     0 to >>ptr  over to <<ptr ;
1.6       pazsan    291: : >>next ( -- addr u ) <<ptr end$ over - ;
1.14      pazsan    292: : >>rest ( -- ) >>next >>string $+! ;
                    293: : s// ( addr u -- ptr )
1.8       pazsan    294:     \G start search/replace loop
1.17      pazsan    295:     ]] >>string0 (( // s>> [[ ; immediate
                    296: : >> ( addr -- addr )
                    297:     ]] <<ptr >>ptr u> ?LEAVE ?end [[ ; immediate
                    298: : //s ( ptr -- )
                    299:     \G search end
                    300:     ]] )) drop >>rest >>string@ [[ ; immediate
1.15      pazsan    301: : //o ( ptr addr u -- addr' u' )
1.14      pazsan    302:     \G end search/replace single loop
1.17      pazsan    303:     ]] << //s [[ ; immediate
1.14      pazsan    304: : //g ( ptr addr u -- addr' u' )
                    305:     \G end search/replace all loop
1.17      pazsan    306:     ]] << LEAVE //s [[ ; immediate

FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>