Annotation of gforth/regexp.fs, revision 1.28
1.1 pazsan 1: \ Regexp compile
2:
1.13 anton 3: \ Copyright (C) 2005,2006,2007,2008 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.8 pazsan 172: : )) ( -- addr f ) \ regexp-pattern
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.28 ! pazsan 186: ]] false >r BEGIN dup FORK BUT WHILE drop 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.28 ! pazsan 194: ]] dup >last ;S [[ DONE, ]] false ;S THEN [[
1.27 pazsan 195: ]] nip 1+ false U+DO FORK BUT [[
1.28 ! pazsan 196: ]] IF I' I - 1- drops UNLOOP true ;S THEN LOOP [[
1.27 pazsan 197: ]] dup LEAVE JOIN [[ ; immediate
1.8 pazsan 198: : ++} ( sys -- ) \ regexp-pattern
199: \G end of greedy zero-or-more pattern
1.28 ! pazsan 200: ]] dup >last ;S [[ DONE, ]] false ;S THEN [[
1.27 pazsan 201: ]] nip false U+DO FORK BUT [[
1.28 ! pazsan 202: ]] IF I' I - drops UNLOOP true ;S THEN LOOP [[
! 203: ]] LEAVE 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.24 pazsan 238: 0 ]] dup dup FORK IF 2drop 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 !
242: ]] AHEAD BUT THEN drop [[
243: ]] dup dup FORK IF 2drop 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.28 ! pazsan 247: ]] AHEAD BUT THEN 2drop 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>