Annotation of gforth/regexp.fs, revision 1.8
1.1 pazsan 1: \ Regexp compile
2:
1.7 anton 3: \ Copyright (C) 2005,2006 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
9: \ as published by the Free Software Foundation; either version 2
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
18: \ along with this program; if not, write to the Free Software
19: \ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111, USA.
20:
1.1 pazsan 21: \ The idea of the parser is the following:
22: \ As long as there's a match, continue
23: \ On a mismatch, LEAVE.
24: \ Insert appropriate control structures on alternative branches
25: \ Keep the old pointer (backtracking) on the stack
26: \ I try to keep the syntax as close to a real regexp system as possible
27: \ All regexp stuff is compiled into one function as forward branching
28: \ state machine
29:
1.2 pazsan 30: \ special control structure
1.1 pazsan 31:
1.8 ! pazsan 32: : FORK ( compilation -- orig ; run-time f -- ) \ gforth
! 33: \G AHEAD-like control structure: calls the code after JOIN.
1.1 pazsan 34: POSTPONE call >mark ; immediate restrict
1.8 ! pazsan 35: : JOIN ( orig -- ) \ gforth
! 36: \G THEN-like control structure for FORK
! 37: postpone THEN ; immediate restrict
1.1 pazsan 38:
39: \ Charclasses
40:
41: : +bit ( addr n -- ) + 1 swap c! ;
42: : -bit ( addr n -- ) + 0 swap c! ;
43: : @+ ( addr -- n addr' ) dup @ swap cell+ ;
44:
45: 0 Value cur-class
1.8 ! pazsan 46: : charclass ( -- ) \ regexp-cg
! 47: \G Create a charclass
! 48: Create here dup to cur-class $100 dup allot erase ;
! 49: : +char ( char -- ) \ regexp-cg
! 50: \G add a char to the current charclass
! 51: cur-class swap +bit ;
! 52: : -char ( char -- ) \ regexp-cg
! 53: \G remove a char from the current charclass
! 54: cur-class swap -bit ;
! 55: : ..char ( start end -- ) \ regexp-cg
! 56: \G add a range of chars to the current charclass
! 57: 1+ swap ?DO I +char LOOP ;
1.1 pazsan 58: : or! ( n addr -- ) dup @ rot or swap ! ;
59: : and! ( n addr -- ) dup @ rot and swap ! ;
1.8 ! pazsan 60: : +class ( class -- ) \ regexp-cg
! 61: \G union of charclass @var{class} and the current charclass
! 62: $100 0 ?DO @+ swap
! 63: cur-class I + or! cell +LOOP drop ;
! 64: : -class ( class -- ) \ regexp-cg
! 65: \G subtract the charclass @var{class} from the current charclass
! 66: $100 0 ?DO @+ swap invert
! 67: cur-class I + and! cell +LOOP drop ;
1.1 pazsan 68:
69: : char? ( addr class -- addr' flag )
70: >r count r> + c@ ;
71:
72: \ Charclass tests
73:
1.8 ! pazsan 74: : c? ( addr class -- ) \ regexp-pattern
! 75: \G check @var{addr} for membership in charclass @var{class}
! 76: ]] char? 0= ?LEAVE [[ ; immediate
! 77: : -c? ( addr class -- ) \ regexp-pattern
! 78: \G check @var{addr} for not membership in charclass @var{class}
! 79: ]] char? ?LEAVE [[ ; immediate
1.1 pazsan 80:
81: charclass digit '0 '9 ..char
82: charclass blanks 0 bl ..char
83: \ bl +char #tab +char #cr +char #lf +char ctrl L +char
84: charclass letter 'a 'z ..char 'A 'Z ..char
85: charclass any 0 $FF ..char #lf -char
86:
1.8 ! pazsan 87: : \d ( addr -- addr' ) \ regexp-pattern
! 88: \G check for digit
! 89: ]] digit c? [[ ; immediate
! 90: : \s ( addr -- addr' ) \ regexp-pattern
! 91: \G check for blanks
! 92: ]] blanks c? [[ ; immediate
! 93: : .? ( addr -- addr' ) \ regexp-pattern
! 94: \G check for any single charachter
! 95: ]] any c? [[ ; immediate
! 96: : -\d ( addr -- addr' ) \ regexp-pattern
! 97: \G check for not digit
! 98: ]] digit -c? [[ ; immediate
! 99: : -\s ( addr -- addr' ) \ regexp-pattern
! 100: \G check for not blank
! 101: ]] blanks -c? [[ ; immediate
! 102: : ` ( "char" -- ) \ regexp-pattern
! 103: \G check for particular char
1.1 pazsan 104: ]] count [[ char ]] Literal <> ?LEAVE [[ ; immediate
105:
106: \ A word for string comparison
107:
108: : $= ( addr1 addr2 u -- f ) tuck compare ;
109: : ,=" ( addr u -- ) tuck ]] dup SLiteral $= ?LEAVE Literal + noop [[ ;
1.8 ! pazsan 110: : =" ( <string>" -- ) \ regexp-pattern
! 111: \G check for string
! 112: '" parse ,=" ; immediate
1.1 pazsan 113:
114: \ loop stack
115:
116: Variable loops $40 3 * cells allot
117: : 3@ ( addr -- a b c ) dup >r 2 cells + @ r> 2@ ;
118: : 3! ( a b c addr -- ) dup >r 2! r> 2 cells + ! ;
119: : loops> ( -- addr ) -3 loops +! loops @+ swap cells + 3@ ;
120: : >loops ( addr -- ) loops @+ swap cells + 3! 3 loops +! ;
121: : BEGIN, ( -- ) ]] BEGIN [[ >loops ;
122: : DONE, ( -- ) loops @ IF loops> ]] DONE [[ THEN ]] noop [[ ;
123:
124: \ variables
125:
126: Variable vars &18 cells allot
127: Variable varstack 9 cells allot
128: Variable varsmax
129: : >var ( -- addr ) vars @+ swap 2* cells +
130: vars @ varstack @+ swap cells + !
131: 1 vars +! 1 varstack +! ;
132: : var> ( -- addr ) -1 varstack +!
133: varstack @+ swap cells + @
134: 1+ 2* cells vars + ;
135:
136: \ start end
137:
138: 0 Value end$
139: 0 Value start$
140: : !end ( addr u -- addr ) over + to end$ dup to start$ ;
141: : $? ( addr -- addr flag ) dup end$ u< ;
142: : ^? ( addr -- addr flag ) dup start$ u> ;
143: : ?end ( addr -- addr ) ]] dup end$ u> ?LEAVE [[ ; immediate
144:
145: \ start and end
146:
1.8 ! pazsan 147: : \^ ( addr -- addr ) \ regexp-pattern
! 148: \G check for string start
1.1 pazsan 149: ]] ^? ?LEAVE [[ ; immediate
1.8 ! pazsan 150: : \$ ( addr -- addr ) \ regexp-pattern
! 151: \G check for string end
1.1 pazsan 152: ]] $? ?LEAVE [[ ; immediate
153:
154: \ regexp block
155:
156: \ FORK/JOIN are like AHEAD THEN, but producing a call on AHEAD
157: \ instead of a jump.
158:
1.8 ! pazsan 159: : (( ( addr u -- ) \ regexp-pattern
! 160: \G start regexp block
! 161: vars off varsmax off loops off
1.1 pazsan 162: ]] FORK AHEAD BUT JOIN !end [[ BEGIN, ; immediate
1.8 ! pazsan 163: : )) ( -- addr f ) \ regexp-pattern
! 164: \G end regexp block
1.1 pazsan 165: ]] ?end drop true EXIT [[
166: DONE, ]] drop false EXIT THEN [[ ; immediate
167:
168: \ greedy loops
169:
170: \ Idea: scan as many characters as possible, try the rest of the pattern
171: \ and then back off one pattern at a time
172:
173: : drops ( n -- ) 1+ cells sp@ + sp! ;
174:
1.8 ! pazsan 175: : {** ( addr -- addr addr ) \ regexp-pattern
! 176: \G greedy zero-or-more pattern
1.1 pazsan 177: 0 ]] Literal >r BEGIN dup [[ BEGIN, ; immediate
1.8 ! pazsan 178: ' {** Alias {++ ( addr -- addr addr ) \ regexp-pattern
! 179: \G greedy one-or-more pattern
! 180: immediate
! 181: : n*} ( sys n -- ) \ regexp-pattern
! 182: \G At least @var{n} pattern
! 183: >r ]] r> 1+ >r $? 0= UNTIL dup [[ DONE, ]] drop [[
1.1 pazsan 184: r@ IF r@ ]] r@ Literal u< IF r> 1+ drops false EXIT THEN [[ THEN
185: r@ ]] r> 1+ Literal U+DO FORK BUT [[
186: ]] IF I' I - [[ r@ 1- ]] Literal + drops true UNLOOP EXIT THEN LOOP [[
187: r@ IF r@ ]] Literal drops [[ THEN
188: rdrop ]] false EXIT JOIN [[ ; immediate
1.8 ! pazsan 189: : **} ( sys -- ) \ regexp-pattern
! 190: \G end of greedy zero-or-more pattern
! 191: 0 postpone n*} ; immediate
! 192: : ++} ( sys -- ) \ regexp-pattern
! 193: \G end of greedy zero-or-more pattern
! 194: 1 postpone n*} ; immediate
1.1 pazsan 195:
196: \ non-greedy loops
197:
198: \ Idea: Try to match rest of the regexp, and if that fails, try match
199: \ first expr and then try again rest of regexp.
200:
1.8 ! pazsan 201: : {+ ( addr -- addr addr ) \ regexp-pattern
! 202: \G non-greedy one-or-more pattern
1.1 pazsan 203: ]] BEGIN [[ BEGIN, ; immediate
1.8 ! pazsan 204: : {* ( addr -- addr addr ) \ regexp-pattern
! 205: \G non-greedy zero-or-more pattern
1.1 pazsan 206: ]] {+ dup FORK BUT IF drop true EXIT THEN [[ ; immediate
1.8 ! pazsan 207: : *} ( addr addr' -- addr' ) \ regexp-pattern
! 208: \G end of non-greedy zero-or-more pattern
1.1 pazsan 209: ]] dup end$ u> UNTIL [[
210: DONE, ]] drop false EXIT JOIN [[ ; immediate
1.8 ! pazsan 211: : +} ( addr addr' -- addr' ) \ regexp-pattern
! 212: \G end of non-greedy one-or-more pattern
1.1 pazsan 213: ]] dup FORK BUT IF drop true EXIT [[
214: DONE, ]] drop false EXIT THEN *} [[ ; immediate
215:
1.8 ! pazsan 216: : // ( -- ) \ regexp-pattern
! 217: \G search for string
! 218: ]] {* 1+ *} [[ ; immediate
1.1 pazsan 219:
220: \ alternatives
221:
222: \ idea: try to match one alternative and then the rest of regexp.
223: \ if that fails, jump back to second alternative
224:
225: : THENs ( sys -- ) BEGIN dup WHILE ]] THEN [[ REPEAT drop ;
226:
1.8 ! pazsan 227: : {{ ( addr -- addr addr ) \ regexp-pattern
! 228: \G Start of alternatives
! 229: 0 ]] dup BEGIN [[ vars @ ; immediate
! 230: : || ( addr addr -- addr addr ) \ regexp-pattern
! 231: \G separator between alternatives
! 232: vars @ varsmax @ max varsmax !
1.1 pazsan 233: ]] nip AHEAD [[ >r >r >r vars !
234: ]] DONE drop dup [[ r> r> r> ]] BEGIN [[ vars @ ; immediate
1.8 ! pazsan 235: : }} ( addr addr -- addr addr ) \ regexp-pattern
! 236: \G end of alternatives
! 237: vars @ varsmax @ max vars !
1.1 pazsan 238: ]] nip AHEAD [[ >r >r >r drop
239: ]] DONE drop LEAVE [[ r> r> r> THENs ; immediate
240:
241: \ match variables
242:
1.8 ! pazsan 243: : \( ( addr -- addr ) \ regexp-pattern
! 244: \G start of matching variable; variables are referred as \\1--9
! 245: ]] dup [[
1.1 pazsan 246: >var ]] ALiteral ! [[ ; immediate
1.8 ! pazsan 247: : \) ( addr -- addr ) \ regexp-pattern
! 248: \G end of matching variable
! 249: ]] dup [[
1.1 pazsan 250: var> ]] ALiteral ! [[ ; immediate
1.8 ! pazsan 251: : \0 ( -- addr u ) \ regexp-pattern
! 252: \G the whole string
! 253: start$ end$ over - ;
1.1 pazsan 254: : \: ( i -- )
255: Create 2* 1+ cells vars + ,
256: DOES> ( -- addr u ) @ 2@ tuck - ;
257: : \:s ( n -- ) 0 ?DO I \: LOOP ;
258: 9 \:s \1 \2 \3 \4 \5 \6 \7 \8 \9
1.6 pazsan 259:
260: \ replacements, needs string.fs
261:
262: require string.fs
263:
264: 0 Value >>ptr
265: 0 Value <<ptr
266: Variable >>string
1.8 ! pazsan 267: : >> ( addr -- addr ) \ regexp-replace
! 268: \G Start replace pattern region
! 269: dup to >>ptr ;
! 270: : << ( run-addr addr u -- run-addr ) \ regexp-replace
! 271: \G Replace string from start of replace pattern region with
! 272: \G @var{addr} @var{u}
1.6 pazsan 273: <<ptr 0= IF start$ to <<ptr THEN
274: >>string @ 0= IF s" " >>string $! THEN
275: <<ptr >>ptr over - >>string $+!
276: >>string $+! dup to <<ptr ;
1.8 ! pazsan 277: : <<" ( "string<">" -- ) \ regexp-replace
! 278: \G Replace string from start of replace pattern region with
! 279: \G @var{string}
! 280: '" parse postpone SLiteral postpone << ; immediate
1.6 pazsan 281: : >>string@ ( -- addr u )
282: >>string $@ >>string off
283: 0 to >>ptr 0 to <<ptr ;
284: : >>next ( -- addr u ) <<ptr end$ over - ;
1.8 ! pazsan 285: : s// ( -- sys ) \ regexp-replace
! 286: \G start search/replace loop
! 287: ]] BEGIN [[ ; immediate
! 288: : //g ( sys -- ) \ regexp-replace
! 289: \G end search/replace loop
! 290: ]] WHILE >>next REPEAT end$ [[
1.6 pazsan 291: s" " ]] SLiteral << >>string@ rot drop [[ ; immediate
FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>
![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to regexp.fs CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [gforth] / gforth