File: regexp.fs

package info (click to toggle)
gforth 0.7.3+dfsg-9
  • links: PTS, VCS
  • area: main
  • in suites: bullseye, buster, sid
  • size: 5,992 kB
  • sloc: ansic: 8,535; sh: 3,666; lisp: 1,778; makefile: 1,019; yacc: 186; sed: 141; lex: 102; awk: 21
file content (290 lines) | stat: -rw-r--r-- 9,673 bytes parent folder | download | duplicates (5)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
\ Regexp compile

\ Copyright (C) 2005,2006,2007,2008 Free Software Foundation, Inc.

\ This file is part of Gforth.

\ Gforth is free software; you can redistribute it and/or
\ modify it under the terms of the GNU General Public License
\ as published by the Free Software Foundation, either version 3
\ of the License, or (at your option) any later version.

\ This program is distributed in the hope that it will be useful,
\ but WITHOUT ANY WARRANTY; without even the implied warranty of
\ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
\ GNU General Public License for more details.

\ You should have received a copy of the GNU General Public License
\ along with this program. If not, see http://www.gnu.org/licenses/.

\ The idea of the parser is the following:
\ As long as there's a match, continue
\ On a mismatch, LEAVE.
\ Insert appropriate control structures on alternative branches
\ Keep the old pointer (backtracking) on the stack
\ I try to keep the syntax as close to a real regexp system as possible
\ All regexp stuff is compiled into one function as forward branching
\ state machine

\ special control structure

: FORK ( compilation -- orig ; run-time f -- ) \ gforth
    \G AHEAD-like control structure: calls the code after JOIN.
    POSTPONE call >mark ; immediate restrict
: JOIN ( orig -- ) \ gforth
    \G THEN-like control structure for FORK
    postpone THEN ; immediate restrict

\ Charclasses

: +bit ( addr n -- )  + 1 swap c! ;
: -bit ( addr n -- )  + 0 swap c! ;
: @+ ( addr -- n addr' )  dup @ swap cell+ ;

0 Value cur-class
: charclass ( -- ) \ regexp-cg
    \G Create a charclass
    Create here dup to cur-class $100 dup allot erase ;
: +char ( char -- ) \ regexp-cg
    \G add a char to the current charclass
    cur-class swap +bit ;
: -char ( char -- ) \ regexp-cg
    \G remove a char from the current charclass
    cur-class swap -bit ;
: ..char ( start end -- ) \ regexp-cg
    \G add a range of chars to the current charclass
    1+ swap ?DO  I +char  LOOP ;
: or! ( n addr -- )  dup @ rot or swap ! ;
: and! ( n addr -- )  dup @ rot and swap ! ;
: +class ( class -- ) \ regexp-cg
    \G union of charclass @var{class} and the current charclass
    $100 0 ?DO  @+ swap
    cur-class I + or!  cell +LOOP  drop ;
: -class ( class -- ) \ regexp-cg
    \G subtract the charclass @var{class} from the current charclass
    $100 0 ?DO  @+ swap invert
    cur-class I + and!  cell +LOOP  drop ;

: char? ( addr class -- addr' flag )
    >r count r> + c@ ;

\ Charclass tests

: c? ( addr class -- ) \ regexp-pattern
    \G check @var{addr} for membership in charclass @var{class}
    ]] char? 0= ?LEAVE [[ ; immediate
: -c? ( addr class -- ) \ regexp-pattern
    \G check @var{addr} for not membership in charclass @var{class}
    ]] char?    ?LEAVE [[ ; immediate

charclass digit  '0 '9 ..char
charclass blanks 0 bl ..char
\ bl +char #tab +char #cr +char #lf +char ctrl L +char
charclass letter 'a 'z ..char 'A 'Z ..char
charclass any    0 $FF ..char #lf -char

: \d ( addr -- addr' ) \ regexp-pattern
    \G check for digit
    ]] digit c?        [[ ; immediate
: \s ( addr -- addr' ) \ regexp-pattern
    \G check for blanks
    ]] blanks c?       [[ ; immediate
: .? ( addr -- addr' ) \ regexp-pattern
    \G check for any single charachter
    ]] any c?          [[ ; immediate
: -\d ( addr -- addr' ) \ regexp-pattern
    \G check for not digit
    ]] digit -c?       [[ ; immediate
: -\s ( addr -- addr' ) \ regexp-pattern
    \G check for not blank
    ]] blanks -c?      [[ ; immediate
: ` ( "char" -- ) \ regexp-pattern
    \G check for particular char
    ]] count [[  char ]] Literal <> ?LEAVE [[ ;  immediate

\ A word for string comparison

: $= ( addr1 addr2 u -- f )  tuck compare ;
: ,=" ( addr u -- ) tuck ]] dup SLiteral $= ?LEAVE Literal + noop [[ ;
: =" ( <string>" -- ) \ regexp-pattern
    \G check for string
    '" parse ,=" ; immediate

\ loop stack

Variable loops  $40 3 * cells allot
: 3@ ( addr -- a b c )  dup >r 2 cells + @ r> 2@ ;
: 3! ( a b c addr -- )  dup >r 2! r> 2 cells + ! ;
: loops> ( -- addr ) -3 loops +!  loops @+ swap cells + 3@ ;
: >loops ( addr -- ) loops @+ swap cells + 3! 3 loops +! ;
: BEGIN, ( -- )  ]] BEGIN [[ >loops ;
: DONE, ( -- )  loops @ IF  loops> ]] DONE [[ THEN ]] noop [[ ;

\ variables

Variable vars   &18 cells allot
Variable varstack 9 cells allot
Variable varsmax
: >var ( -- addr ) vars @+ swap 2* cells +
    vars @ varstack @+ swap cells + !
    1 vars +! 1 varstack +! ;
: var> ( -- addr ) -1 varstack +!
    varstack @+ swap cells + @
    1+ 2* cells vars + ;

\ start end

0 Value end$
0 Value start$
: !end ( addr u -- addr )  over + to end$ dup to start$ ;
: end-rex? ( addr -- addr flag ) dup end$ u< ;
: start-rex? ( addr -- addr flag ) dup start$ u> ;
: ?end ( addr -- addr ) ]] dup end$ u> ?LEAVE [[ ; immediate

\ start and end

: \^ ( addr -- addr ) \ regexp-pattern
    \G check for string start
    ]] start-rex? ?LEAVE [[ ; immediate
: \$ ( addr -- addr ) \ regexp-pattern
    \G check for string end
    ]] end-rex? ?LEAVE [[ ; immediate

\ regexp block

\ FORK/JOIN are like AHEAD THEN, but producing a call on AHEAD
\ instead of a jump.

: (( ( addr u -- ) \ regexp-pattern
    \G start regexp block
    vars off varsmax off loops off
    ]] FORK  AHEAD BUT JOIN !end [[ BEGIN, ; immediate
: )) ( -- addr f ) \ regexp-pattern
    \G end regexp block
    ]] ?end drop true EXIT [[
    DONE, ]] drop false EXIT THEN [[ ; immediate

\ greedy loops

\ Idea: scan as many characters as possible, try the rest of the pattern
\ and then back off one pattern at a time

: drops ( n -- ) 1+ cells sp@ + sp! ;

: {** ( addr -- addr addr ) \ regexp-pattern
    \G greedy zero-or-more pattern
    0 ]] Literal >r BEGIN dup [[ BEGIN, ; immediate
' {** Alias {++ ( addr -- addr addr ) \ regexp-pattern
    \G greedy one-or-more pattern
    immediate
: n*} ( sys n -- ) \ regexp-pattern
    \G At least @var{n} pattern
    >r ]] r> 1+ >r end-rex? 0= UNTIL dup [[ DONE, ]] drop [[
    r@ IF r@ ]] r@ Literal u< IF  r> 1+ drops false  EXIT  THEN [[ THEN
    r@ ]] r> 1+ Literal U+DO FORK BUT [[
    ]] IF  I' I - [[ r@ 1- ]] Literal + drops true UNLOOP EXIT  THEN  LOOP [[
    r@ IF  r@ ]] Literal drops [[ THEN
    rdrop ]] false  EXIT  JOIN [[ ; immediate
: **} ( sys -- ) \ regexp-pattern
    \G end of greedy zero-or-more pattern
    0 postpone n*} ; immediate
: ++} ( sys -- ) \ regexp-pattern
    \G end of greedy zero-or-more pattern
    1 postpone n*} ; immediate

\ non-greedy loops

\ Idea: Try to match rest of the regexp, and if that fails, try match
\ first expr and then try again rest of regexp.

: {+ ( addr -- addr addr ) \ regexp-pattern
    \G non-greedy one-or-more pattern
    ]] BEGIN  [[ BEGIN, ; immediate
: {* ( addr -- addr addr ) \ regexp-pattern
    \G non-greedy zero-or-more pattern
    ]] {+ dup FORK BUT  IF  drop true  EXIT THEN [[ ; immediate
: *} ( addr addr' -- addr' ) \ regexp-pattern
    \G end of non-greedy zero-or-more pattern
    ]] dup end$ u>  UNTIL [[
    DONE, ]] drop false  EXIT  JOIN [[ ; immediate
: +} ( addr addr' -- addr' ) \ regexp-pattern
    \G end of non-greedy one-or-more pattern
    ]] dup FORK BUT  IF  drop true  EXIT [[
    DONE, ]] drop false  EXIT  THEN *} [[ ; immediate

: // ( -- ) \ regexp-pattern
    \G search for string
    ]] {* 1+ *} [[ ; immediate

\ alternatives

\ idea: try to match one alternative and then the rest of regexp.
\ if that fails, jump back to second alternative

: THENs ( sys -- )  BEGIN  dup  WHILE  ]] THEN [[  REPEAT  drop ;

: {{ ( addr -- addr addr ) \ regexp-pattern
    \G Start of alternatives
    0 ]] dup BEGIN [[  vars @ ; immediate
: || ( addr addr -- addr addr ) \ regexp-pattern
    \G separator between alternatives
    vars @ varsmax @ max varsmax !
    ]] nip AHEAD [[ >r >r >r vars !
    ]] DONE drop dup [[ r> r> r> ]] BEGIN [[ vars @ ; immediate
: }} ( addr addr -- addr addr ) \ regexp-pattern
    \G end of alternatives
    vars @ varsmax @ max vars !
    ]] nip AHEAD [[ >r >r >r drop
    ]] DONE drop LEAVE [[ r> r> r> THENs ; immediate

\ match variables

: \( ( addr -- addr ) \ regexp-pattern
    \G start of matching variable; variables are referred as \\1--9
    ]] dup [[
    >var ]] ALiteral ! [[ ; immediate
: \) ( addr -- addr ) \ regexp-pattern
    \G end of matching variable
    ]] dup [[
    var> ]] ALiteral ! [[ ; immediate
: \0 ( -- addr u ) \ regexp-pattern
    \G the whole string
    start$ end$ over - ;
: \: ( i -- )
    Create 2* 1+ cells vars + ,
  DOES> ( -- addr u ) @ 2@ tuck - ;
: \:s ( n -- ) 0 ?DO  I \:  LOOP ;
9 \:s \1 \2 \3 \4 \5 \6 \7 \8 \9

\ replacements, needs string.fs

require string.fs

0 Value >>ptr
0 Value <<ptr
Variable >>string
: >>  ( addr -- addr ) \ regexp-replace
    \G Start replace pattern region
    dup to >>ptr ;
: << ( run-addr addr u -- run-addr ) \ regexp-replace
    \G Replace string from start of replace pattern region with
    \G @var{addr} @var{u}
    <<ptr 0= IF  start$ to <<ptr  THEN
    >>string @ 0= IF  s" " >>string $!  THEN
    <<ptr >>ptr over - >>string $+!
    >>string $+! dup to <<ptr ;
: <<" ( "string<">" -- ) \ regexp-replace
    \G Replace string from start of replace pattern region with
    \G @var{string}
    '" parse postpone SLiteral postpone << ; immediate
: >>string@ ( -- addr u )
    >>string $@ >>string off
    0 to >>ptr  0 to <<ptr ;
: >>next ( -- addr u ) <<ptr end$ over - ;
: s// ( -- sys ) \ regexp-replace
    \G start search/replace loop
    ]] BEGIN [[ ; immediate
: //g ( sys -- ) \ regexp-replace
    \G end search/replace loop
    ]] WHILE >>next REPEAT end$ [[
    s" " ]] SLiteral << >>string@ rot drop [[ ; immediate