[gforth] / gforth / regexp.fs  

gforth: gforth/regexp.fs

1 : pazsan 1.1 \ Regexp compile
2 :    
3 :     \ The idea of the parser is the following:
4 :     \ As long as there's a match, continue
5 :     \ On a mismatch, LEAVE.
6 :     \ Insert appropriate control structures on alternative branches
7 :     \ Keep the old pointer (backtracking) on the stack
8 :     \ I try to keep the syntax as close to a real regexp system as possible
9 :     \ All regexp stuff is compiled into one function as forward branching
10 :     \ state machine
11 :    
12 :     \ bulk-postponing
13 :    
14 :     : FORK ( compilation -- orig ; run-time f -- ) \ core
15 :     POSTPONE call >mark ; immediate restrict
16 :     : JOIN ( orig -- ) postpone THEN ; immediate restrict
17 :    
18 :     \ Charclasses
19 :    
20 :     : +bit ( addr n -- ) + 1 swap c! ;
21 :     : -bit ( addr n -- ) + 0 swap c! ;
22 :     : @+ ( addr -- n addr' ) dup @ swap cell+ ;
23 :    
24 :     0 Value cur-class
25 :     : charclass ( -- ) Create here dup to cur-class $100 dup allot erase ;
26 :     : +char ( char -- ) cur-class swap +bit ;
27 :     : -char ( char -- ) cur-class swap -bit ;
28 :     : ..char ( start end -- ) 1+ swap ?DO I +char LOOP ;
29 :     : or! ( n addr -- ) dup @ rot or swap ! ;
30 :     : and! ( n addr -- ) dup @ rot and swap ! ;
31 :     : +class ( class -- ) $100 0 ?DO @+ swap
32 :     cur-class I + or! cell +LOOP drop ;
33 :     : -class ( class -- ) $100 0 ?DO @+ swap invert
34 :     cur-class I + and! cell +LOOP drop ;
35 :    
36 :     : char? ( addr class -- addr' flag )
37 :     >r count r> + c@ ;
38 :    
39 :     \ Charclass tests
40 :    
41 :     : c? ( addr class -- ) ]] char? 0= ?LEAVE [[ ; immediate
42 :     : -c? ( addr class -- ) ]] char? ?LEAVE [[ ; immediate
43 :    
44 :     charclass digit '0 '9 ..char
45 :     charclass blanks 0 bl ..char
46 :     \ bl +char #tab +char #cr +char #lf +char ctrl L +char
47 :     charclass letter 'a 'z ..char 'A 'Z ..char
48 :     charclass any 0 $FF ..char #lf -char
49 :    
50 :     : \d ( addr -- addr' ) ]] digit c? [[ ; immediate
51 :     : \s ( addr -- addr' ) ]] blanks c? [[ ; immediate
52 :     : .? ( addr -- addr' ) ]] any c? [[ ; immediate
53 :     : -\d ( addr -- addr' ) ]] digit -c? [[ ; immediate
54 :     : -\s ( addr -- addr' ) ]] blanks -c? [[ ; immediate
55 :     : ` ( -- )
56 :     ]] count [[ char ]] Literal <> ?LEAVE [[ ; immediate
57 :    
58 :     \ A word for string comparison
59 :    
60 :     : $= ( addr1 addr2 u -- f ) tuck compare ;
61 :     : ,=" ( addr u -- ) tuck ]] dup SLiteral $= ?LEAVE Literal + noop [[ ;
62 :     : =" ( <string>" -- ) '" parse ,=" ; immediate
63 :    
64 :     \ loop stack
65 :    
66 :     Variable loops $40 3 * cells allot
67 :     : 3@ ( addr -- a b c ) dup >r 2 cells + @ r> 2@ ;
68 :     : 3! ( a b c addr -- ) dup >r 2! r> 2 cells + ! ;
69 :     : loops> ( -- addr ) -3 loops +! loops @+ swap cells + 3@ ;
70 :     : >loops ( addr -- ) loops @+ swap cells + 3! 3 loops +! ;
71 :     : BEGIN, ( -- ) ]] BEGIN [[ >loops ;
72 :     : DONE, ( -- ) loops @ IF loops> ]] DONE [[ THEN ]] noop [[ ;
73 :    
74 :     \ variables
75 :    
76 :     Variable vars &18 cells allot
77 :     Variable varstack 9 cells allot
78 :     Variable varsmax
79 :     : >var ( -- addr ) vars @+ swap 2* cells +
80 :     vars @ varstack @+ swap cells + !
81 :     1 vars +! 1 varstack +! ;
82 :     : var> ( -- addr ) -1 varstack +!
83 :     varstack @+ swap cells + @
84 :     1+ 2* cells vars + ;
85 :    
86 :     \ start end
87 :    
88 :     0 Value end$
89 :     0 Value start$
90 :     : !end ( addr u -- addr ) over + to end$ dup to start$ ;
91 :     : $? ( addr -- addr flag ) dup end$ u< ;
92 :     : ^? ( addr -- addr flag ) dup start$ u> ;
93 :     : ?end ( addr -- addr ) ]] dup end$ u> ?LEAVE [[ ; immediate
94 :    
95 :     \ start and end
96 :    
97 :     : \^ ( addr -- addr )
98 :     ]] ^? ?LEAVE [[ ; immediate
99 :     : \$ ( addr -- addr )
100 :     ]] $? ?LEAVE [[ ; immediate
101 :    
102 :     \ regexp block
103 :    
104 :     \ FORK/JOIN are like AHEAD THEN, but producing a call on AHEAD
105 :     \ instead of a jump.
106 :    
107 :     : (( ( addr u -- ) vars off varsmax off loops off
108 :     ]] FORK AHEAD BUT JOIN !end [[ BEGIN, ; immediate
109 :     : )) ( -- addr f )
110 :     ]] ?end drop true EXIT [[
111 :     DONE, ]] drop false EXIT THEN [[ ; immediate
112 :    
113 :     \ greedy loops
114 :    
115 :     \ Idea: scan as many characters as possible, try the rest of the pattern
116 :     \ and then back off one pattern at a time
117 :    
118 :     : drops ( n -- ) 1+ cells sp@ + sp! ;
119 :    
120 :     : {** ( addr -- addr addr )
121 :     0 ]] Literal >r BEGIN dup [[ BEGIN, ; immediate
122 :     ' {** Alias {++ ( addr -- addr addr ) immediate
123 :     : n*} ( sys n -- ) >r ]] r> 1+ >r $? 0= UNTIL dup [[ DONE, ]] drop [[
124 :     r@ IF r@ ]] r@ Literal u< IF r> 1+ drops false EXIT THEN [[ THEN
125 :     r@ ]] r> 1+ Literal U+DO FORK BUT [[
126 :     ]] IF I' I - [[ r@ 1- ]] Literal + drops true UNLOOP EXIT THEN LOOP [[
127 :     r@ IF r@ ]] Literal drops [[ THEN
128 :     rdrop ]] false EXIT JOIN [[ ; immediate
129 :     : **} 0 postpone n*} ; immediate
130 :     : ++} 1 postpone n*} ; immediate
131 :    
132 :     \ non-greedy loops
133 :    
134 :     \ Idea: Try to match rest of the regexp, and if that fails, try match
135 :     \ first expr and then try again rest of regexp.
136 :    
137 :     : {+ ( addr -- addr addr )
138 :     ]] BEGIN [[ BEGIN, ; immediate
139 :     : {* ( addr -- addr addr )
140 :     ]] {+ dup FORK BUT IF drop true EXIT THEN [[ ; immediate
141 :     : *} ( addr addr' -- addr' )
142 :     ]] dup end$ u> UNTIL [[
143 :     DONE, ]] drop false EXIT JOIN [[ ; immediate
144 :     : +} ( addr addr' -- addr' )
145 :     ]] dup FORK BUT IF drop true EXIT [[
146 :     DONE, ]] drop false EXIT THEN *} [[ ; immediate
147 :    
148 :     : // ( -- ) ]] {* 1+ *} [[ ; immediate
149 :    
150 :     \ alternatives
151 :    
152 :     \ idea: try to match one alternative and then the rest of regexp.
153 :     \ if that fails, jump back to second alternative
154 :    
155 :     : THENs ( sys -- ) BEGIN dup WHILE ]] THEN [[ REPEAT drop ;
156 :    
157 :     : {{ ( addr -- addr addr ) 0 ]] dup BEGIN [[ vars @ ; immediate
158 :     : || ( addr addr -- addr addr ) vars @ varsmax @ max varsmax !
159 :     ]] nip AHEAD [[ >r >r >r vars !
160 :     ]] DONE drop dup [[ r> r> r> ]] BEGIN [[ vars @ ; immediate
161 :     : }} ( addr addr -- addr addr ) vars @ varsmax @ max vars !
162 :     ]] nip AHEAD [[ >r >r >r drop
163 :     ]] DONE drop LEAVE [[ r> r> r> THENs ; immediate
164 :    
165 :     \ match variables
166 :    
167 :     : \( ( addr -- addr ) ]] dup [[
168 :     >var ]] ALiteral ! [[ ; immediate
169 :     : \) ( addr -- addr ) ]] dup [[
170 :     var> ]] ALiteral ! [[ ; immediate
171 :     : \0 ( -- addr u ) start$ end$ over - ;
172 :     : \: ( i -- )
173 :     Create 2* 1+ cells vars + ,
174 :     DOES> ( -- addr u ) @ 2@ tuck - ;
175 :     : \:s ( n -- ) 0 ?DO I \: LOOP ;
176 :     9 \:s \1 \2 \3 \4 \5 \6 \7 \8 \9
CVS Admin

Powered by ViewCVS 1.0-dev 		(Powered by ViewCVS)

ViewCVS and CVS Help