1: \ Regexp compile
2:
3: \ Copyright (C) 2005,2006,2007,2008 Free Software Foundation, Inc.
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 3
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, see http://www.gnu.org/licenses/.
19:
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:
29: \ special control structure
30:
31: : FORK ( compilation -- orig ; run-time f -- ) \ gforth
32: \G AHEAD-like control structure: calls the code after JOIN.
33: POSTPONE call >mark ; immediate restrict
34: : JOIN ( orig -- ) \ gforth
35: \G THEN-like control structure for FORK
36: postpone THEN ; immediate restrict
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
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 ;
57: : or! ( n addr -- ) dup @ rot or swap ! ;
58: : and! ( n addr -- ) dup @ rot and swap ! ;
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 ;
67:
68: : char? ( addr class -- addr' flag )
69: >r count r> + c@ ;
70:
71: \ Charclass tests
72:
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
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:
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
103: ]] count [[ char ]] Literal <> ?LEAVE [[ ; immediate
104:
105: \ A word for string comparison
106:
107: : $= ( addr1 addr2 u -- f ) tuck compare ;
108: : ,=" ( addr u -- ) tuck ]] dup SLiteral $= ?LEAVE Literal + noop [[ ;
109: : =" ( <string>" -- ) \ regexp-pattern
110: \G check for string
111: '" parse ,=" ; immediate
112:
113: \ loop stack
114:
115: Variable loops $40 3 * cells allot
116: : 3@ ( addr -- a b c ) dup >r 2 cells + @ r> 2@ ;
117: : 3! ( a b c addr -- ) dup >r 2! r> 2 cells + ! ;
118: : loops> ( -- addr ) -3 loops +! loops @+ swap cells + 3@ ;
119: : >loops ( addr -- ) loops @+ swap cells + 3! 3 loops +! ;
120: : BEGIN, ( -- ) ]] BEGIN [[ >loops ;
121: : DONE, ( -- ) loops @ IF loops> ]] DONE [[ THEN ]] noop [[ ;
122:
123: \ variables
124:
125: Variable vars &18 cells allot
126: Variable varstack 9 cells allot
127: Variable varsmax
128: : >var ( -- addr ) vars @+ swap 2* cells +
129: vars @ varstack @+ swap cells + !
130: 1 vars +! 1 varstack +! ;
131: : var> ( -- addr ) -1 varstack +!
132: varstack @+ swap cells + @
133: 1+ 2* cells vars + ;
134:
135: \ start end
136:
137: 0 Value end$
138: 0 Value start$
139: : !end ( addr u -- addr ) over + to end$ dup to start$ ;
140: : end-rex? ( addr -- addr flag ) dup end$ u< ;
141: : start-rex? ( addr -- addr flag ) dup start$ u> ;
142: : ?end ( addr -- addr ) ]] dup end$ u> ?LEAVE [[ ; immediate
143:
144: \ start and end
145:
146: : \^ ( addr -- addr ) \ regexp-pattern
147: \G check for string start
148: ]] start-rex? ?LEAVE [[ ; immediate
149: : \$ ( addr -- addr ) \ regexp-pattern
150: \G check for string end
151: ]] end-rex? ?LEAVE [[ ; immediate
152:
153: \ regexp block
154:
155: \ FORK/JOIN are like AHEAD THEN, but producing a call on AHEAD
156: \ instead of a jump.
157:
158: : (( ( addr u -- ) \ regexp-pattern
159: \G start regexp block
160: vars off varsmax off loops off
161: ]] FORK AHEAD BUT JOIN !end [[ BEGIN, ; immediate
162: : )) ( -- addr f ) \ regexp-pattern
163: \G end regexp block
164: ]] ?end drop true EXIT [[
165: DONE, ]] drop false EXIT THEN [[ ; immediate
166:
167: \ greedy loops
168:
169: \ Idea: scan as many characters as possible, try the rest of the pattern
170: \ and then back off one pattern at a time
171:
172: : drops ( n -- ) 1+ cells sp@ + sp! ;
173:
174: : {** ( addr -- addr addr ) \ regexp-pattern
175: \G greedy zero-or-more pattern
176: 0 ]] Literal >r BEGIN dup [[ BEGIN, ; immediate
177: ' {** Alias {++ ( addr -- addr addr ) \ regexp-pattern
178: \G greedy one-or-more pattern
179: immediate
180: : n*} ( sys n -- ) \ regexp-pattern
181: \G At least @var{n} pattern
182: >r ]] r> 1+ >r end-rex? 0= UNTIL dup [[ DONE, ]] drop [[
183: r@ IF r@ ]] r@ Literal u< IF r> 1+ drops false EXIT THEN [[ THEN
184: r@ ]] r> 1+ Literal U+DO FORK BUT [[
185: ]] IF I' I - [[ r@ 1- ]] Literal + drops true UNLOOP EXIT THEN LOOP [[
186: r@ IF r@ ]] Literal drops [[ THEN
187: rdrop ]] false EXIT JOIN [[ ; immediate
188: : **} ( sys -- ) \ regexp-pattern
189: \G end of greedy zero-or-more pattern
190: 0 postpone n*} ; immediate
191: : ++} ( sys -- ) \ regexp-pattern
192: \G end of greedy zero-or-more pattern
193: 1 postpone n*} ; immediate
194:
195: \ non-greedy loops
196:
197: \ Idea: Try to match rest of the regexp, and if that fails, try match
198: \ first expr and then try again rest of regexp.
199:
200: : {+ ( addr -- addr addr ) \ regexp-pattern
201: \G non-greedy one-or-more pattern
202: ]] BEGIN [[ BEGIN, ; immediate
203: : {* ( addr -- addr addr ) \ regexp-pattern
204: \G non-greedy zero-or-more pattern
205: ]] {+ dup FORK BUT IF drop true EXIT THEN [[ ; immediate
206: : *} ( addr addr' -- addr' ) \ regexp-pattern
207: \G end of non-greedy zero-or-more pattern
208: ]] dup end$ u> UNTIL [[
209: DONE, ]] drop false EXIT JOIN [[ ; immediate
210: : +} ( addr addr' -- addr' ) \ regexp-pattern
211: \G end of non-greedy one-or-more pattern
212: ]] dup FORK BUT IF drop true EXIT [[
213: DONE, ]] drop false EXIT THEN *} [[ ; immediate
214:
215: : // ( -- ) \ regexp-pattern
216: \G search for string
217: ]] {* 1+ *} [[ ; immediate
218:
219: \ alternatives
220:
221: \ idea: try to match one alternative and then the rest of regexp.
222: \ if that fails, jump back to second alternative
223:
224: : THENs ( sys -- ) BEGIN dup WHILE ]] THEN [[ REPEAT drop ;
225:
226: : {{ ( addr -- addr addr ) \ regexp-pattern
227: \G Start of alternatives
228: 0 ]] dup BEGIN [[ vars @ ; immediate
229: : || ( addr addr -- addr addr ) \ regexp-pattern
230: \G separator between alternatives
231: vars @ varsmax @ max varsmax !
232: ]] nip AHEAD [[ >r >r >r vars !
233: ]] DONE drop dup [[ r> r> r> ]] BEGIN [[ vars @ ; immediate
234: : }} ( addr addr -- addr addr ) \ regexp-pattern
235: \G end of alternatives
236: vars @ varsmax @ max vars !
237: ]] nip AHEAD [[ >r >r >r drop
238: ]] DONE drop LEAVE [[ r> r> r> THENs ; immediate
239:
240: \ match variables
241:
242: : \( ( addr -- addr ) \ regexp-pattern
243: \G start of matching variable; variables are referred as \\1--9
244: ]] dup [[
245: >var ]] ALiteral ! [[ ; immediate
246: : \) ( addr -- addr ) \ regexp-pattern
247: \G end of matching variable
248: ]] dup [[
249: var> ]] ALiteral ! [[ ; immediate
250: : \0 ( -- addr u ) \ regexp-pattern
251: \G the whole string
252: start$ end$ over - ;
253: : \: ( i -- )
254: Create 2* 1+ cells vars + ,
255: DOES> ( -- addr u ) @ 2@ tuck - ;
256: : \:s ( n -- ) 0 ?DO I \: LOOP ;
257: 9 \:s \1 \2 \3 \4 \5 \6 \7 \8 \9
258:
259: \ replacements, needs string.fs
260:
261: require string.fs
262:
263: 0 Value >>ptr
264: 0 Value <<ptr
265: Variable >>string
266: : >> ( addr -- addr ) \ regexp-replace
267: \G Start replace pattern region
268: dup to >>ptr ;
269: : << ( run-addr addr u -- run-addr ) \ regexp-replace
270: \G Replace string from start of replace pattern region with
271: \G @var{addr} @var{u}
272: <<ptr 0= IF start$ to <<ptr THEN
273: >>string @ 0= IF s" " >>string $! THEN
274: <<ptr >>ptr over - >>string $+!
275: >>string $+! dup to <<ptr ;
276: : <<" ( "string<">" -- ) \ regexp-replace
277: \G Replace string from start of replace pattern region with
278: \G @var{string}
279: '" parse postpone SLiteral postpone << ; immediate
280: : >>string@ ( -- addr u )
281: >>string $@ >>string off
282: 0 to >>ptr 0 to <<ptr ;
283: : >>next ( -- addr u ) <<ptr end$ over - ;
284: : s// ( -- sys ) \ regexp-replace
285: \G start search/replace loop
286: ]] BEGIN [[ ; immediate
287: : //g ( sys -- ) \ regexp-replace
288: \G end search/replace loop
289: ]] WHILE >>next REPEAT end$ [[
290: s" " ]] SLiteral << >>string@ rot drop [[ ; immediate
FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>