Annotation of gforth/regexp.fs, revision 1.6
1.1 pazsan 1: \ Regexp compile
2:
1.3 anton 3: \ Copyright (C) 2005 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 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:
32: : FORK ( compilation -- orig ; run-time f -- ) \ core
33: POSTPONE call >mark ; immediate restrict
34: : JOIN ( orig -- ) postpone THEN ; immediate restrict
35:
36: \ Charclasses
37:
38: : +bit ( addr n -- ) + 1 swap c! ;
39: : -bit ( addr n -- ) + 0 swap c! ;
40: : @+ ( addr -- n addr' ) dup @ swap cell+ ;
41:
42: 0 Value cur-class
43: : charclass ( -- ) Create here dup to cur-class $100 dup allot erase ;
44: : +char ( char -- ) cur-class swap +bit ;
45: : -char ( char -- ) cur-class swap -bit ;
46: : ..char ( start end -- ) 1+ swap ?DO I +char LOOP ;
47: : or! ( n addr -- ) dup @ rot or swap ! ;
48: : and! ( n addr -- ) dup @ rot and swap ! ;
49: : +class ( class -- ) $100 0 ?DO @+ swap
50: cur-class I + or! cell +LOOP drop ;
51: : -class ( class -- ) $100 0 ?DO @+ swap invert
52: cur-class I + and! cell +LOOP drop ;
53:
54: : char? ( addr class -- addr' flag )
55: >r count r> + c@ ;
56:
57: \ Charclass tests
58:
59: : c? ( addr class -- ) ]] char? 0= ?LEAVE [[ ; immediate
60: : -c? ( addr class -- ) ]] char? ?LEAVE [[ ; immediate
61:
62: charclass digit '0 '9 ..char
63: charclass blanks 0 bl ..char
64: \ bl +char #tab +char #cr +char #lf +char ctrl L +char
65: charclass letter 'a 'z ..char 'A 'Z ..char
66: charclass any 0 $FF ..char #lf -char
67:
68: : \d ( addr -- addr' ) ]] digit c? [[ ; immediate
69: : \s ( addr -- addr' ) ]] blanks c? [[ ; immediate
70: : .? ( addr -- addr' ) ]] any c? [[ ; immediate
71: : -\d ( addr -- addr' ) ]] digit -c? [[ ; immediate
72: : -\s ( addr -- addr' ) ]] blanks -c? [[ ; immediate
73: : ` ( -- )
74: ]] count [[ char ]] Literal <> ?LEAVE [[ ; immediate
75:
76: \ A word for string comparison
77:
78: : $= ( addr1 addr2 u -- f ) tuck compare ;
79: : ,=" ( addr u -- ) tuck ]] dup SLiteral $= ?LEAVE Literal + noop [[ ;
80: : =" ( <string>" -- ) '" parse ,=" ; immediate
81:
82: \ loop stack
83:
84: Variable loops $40 3 * cells allot
85: : 3@ ( addr -- a b c ) dup >r 2 cells + @ r> 2@ ;
86: : 3! ( a b c addr -- ) dup >r 2! r> 2 cells + ! ;
87: : loops> ( -- addr ) -3 loops +! loops @+ swap cells + 3@ ;
88: : >loops ( addr -- ) loops @+ swap cells + 3! 3 loops +! ;
89: : BEGIN, ( -- ) ]] BEGIN [[ >loops ;
90: : DONE, ( -- ) loops @ IF loops> ]] DONE [[ THEN ]] noop [[ ;
91:
92: \ variables
93:
94: Variable vars &18 cells allot
95: Variable varstack 9 cells allot
96: Variable varsmax
97: : >var ( -- addr ) vars @+ swap 2* cells +
98: vars @ varstack @+ swap cells + !
99: 1 vars +! 1 varstack +! ;
100: : var> ( -- addr ) -1 varstack +!
101: varstack @+ swap cells + @
102: 1+ 2* cells vars + ;
103:
104: \ start end
105:
106: 0 Value end$
107: 0 Value start$
108: : !end ( addr u -- addr ) over + to end$ dup to start$ ;
109: : $? ( addr -- addr flag ) dup end$ u< ;
110: : ^? ( addr -- addr flag ) dup start$ u> ;
111: : ?end ( addr -- addr ) ]] dup end$ u> ?LEAVE [[ ; immediate
112:
113: \ start and end
114:
115: : \^ ( addr -- addr )
116: ]] ^? ?LEAVE [[ ; immediate
117: : \$ ( addr -- addr )
118: ]] $? ?LEAVE [[ ; immediate
119:
120: \ regexp block
121:
122: \ FORK/JOIN are like AHEAD THEN, but producing a call on AHEAD
123: \ instead of a jump.
124:
125: : (( ( addr u -- ) vars off varsmax off loops off
126: ]] FORK AHEAD BUT JOIN !end [[ BEGIN, ; immediate
127: : )) ( -- addr f )
128: ]] ?end drop true EXIT [[
129: DONE, ]] drop false EXIT THEN [[ ; immediate
130:
131: \ greedy loops
132:
133: \ Idea: scan as many characters as possible, try the rest of the pattern
134: \ and then back off one pattern at a time
135:
136: : drops ( n -- ) 1+ cells sp@ + sp! ;
137:
138: : {** ( addr -- addr addr )
139: 0 ]] Literal >r BEGIN dup [[ BEGIN, ; immediate
140: ' {** Alias {++ ( addr -- addr addr ) immediate
141: : n*} ( sys n -- ) >r ]] r> 1+ >r $? 0= UNTIL dup [[ DONE, ]] drop [[
142: r@ IF r@ ]] r@ Literal u< IF r> 1+ drops false EXIT THEN [[ THEN
143: r@ ]] r> 1+ Literal U+DO FORK BUT [[
144: ]] IF I' I - [[ r@ 1- ]] Literal + drops true UNLOOP EXIT THEN LOOP [[
145: r@ IF r@ ]] Literal drops [[ THEN
146: rdrop ]] false EXIT JOIN [[ ; immediate
147: : **} 0 postpone n*} ; immediate
148: : ++} 1 postpone n*} ; immediate
149:
150: \ non-greedy loops
151:
152: \ Idea: Try to match rest of the regexp, and if that fails, try match
153: \ first expr and then try again rest of regexp.
154:
155: : {+ ( addr -- addr addr )
156: ]] BEGIN [[ BEGIN, ; immediate
157: : {* ( addr -- addr addr )
158: ]] {+ dup FORK BUT IF drop true EXIT THEN [[ ; immediate
159: : *} ( addr addr' -- addr' )
160: ]] dup end$ u> UNTIL [[
161: DONE, ]] drop false EXIT JOIN [[ ; immediate
162: : +} ( addr addr' -- addr' )
163: ]] dup FORK BUT IF drop true EXIT [[
164: DONE, ]] drop false EXIT THEN *} [[ ; immediate
165:
166: : // ( -- ) ]] {* 1+ *} [[ ; immediate
167:
168: \ alternatives
169:
170: \ idea: try to match one alternative and then the rest of regexp.
171: \ if that fails, jump back to second alternative
172:
173: : THENs ( sys -- ) BEGIN dup WHILE ]] THEN [[ REPEAT drop ;
174:
175: : {{ ( addr -- addr addr ) 0 ]] dup BEGIN [[ vars @ ; immediate
176: : || ( addr addr -- addr addr ) vars @ varsmax @ max varsmax !
177: ]] nip AHEAD [[ >r >r >r vars !
178: ]] DONE drop dup [[ r> r> r> ]] BEGIN [[ vars @ ; immediate
179: : }} ( addr addr -- addr addr ) vars @ varsmax @ max vars !
180: ]] nip AHEAD [[ >r >r >r drop
181: ]] DONE drop LEAVE [[ r> r> r> THENs ; immediate
182:
183: \ match variables
184:
185: : \( ( addr -- addr ) ]] dup [[
186: >var ]] ALiteral ! [[ ; immediate
187: : \) ( addr -- addr ) ]] dup [[
188: var> ]] ALiteral ! [[ ; immediate
189: : \0 ( -- addr u ) start$ end$ over - ;
190: : \: ( i -- )
191: Create 2* 1+ cells vars + ,
192: DOES> ( -- addr u ) @ 2@ tuck - ;
193: : \:s ( n -- ) 0 ?DO I \: LOOP ;
194: 9 \:s \1 \2 \3 \4 \5 \6 \7 \8 \9
1.6 ! pazsan 195:
! 196: \ replacements, needs string.fs
! 197:
! 198: require string.fs
! 199:
! 200: 0 Value >>ptr
! 201: 0 Value <<ptr
! 202: Variable >>string
! 203: : >> ( addr -- addr ) dup to >>ptr ;
! 204: : << ( run-addr addr u -- run-addr )
! 205: <<ptr 0= IF start$ to <<ptr THEN
! 206: >>string @ 0= IF s" " >>string $! THEN
! 207: <<ptr >>ptr over - >>string $+!
! 208: >>string $+! dup to <<ptr ;
! 209: : <<" '" parse postpone SLiteral postpone << ; immediate
! 210: : >>string@ ( -- addr u )
! 211: >>string $@ >>string off
! 212: 0 to >>ptr 0 to <<ptr ;
! 213: : >>next ( -- addr u ) <<ptr end$ over - ;
! 214: : s// ]] BEGIN [[ ; immediate
! 215: : //g ]] WHILE >>next REPEAT end$ [[
! 216: 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