regexp.fs 10.4 KB
Newer Older
pazsan's avatar
pazsan committed
1
\ Regexp compiler
pazsan's avatar
pazsan committed
2

3
\ Authors: Bernd Paysan, Anton Ertl
Anton Ertl's avatar
Anton Ertl committed
4
\ Copyright (C) 2005,2006,2007,2008,2010,2015,2016,2018,2019 Free Software Foundation, Inc.
5 6 7 8 9

\ 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
anton's avatar
anton committed
10
\ as published by the Free Software Foundation, either version 3
11 12 13 14 15 16 17 18
\ 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
anton's avatar
anton committed
19
\ along with this program. If not, see http://www.gnu.org/licenses/.
20

pazsan's avatar
pazsan committed
21 22 23 24 25 26 27 28 29
\ 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

pazsan's avatar
pazsan committed
30
\ special control structure
pazsan's avatar
pazsan committed
31

32 33
: FORK ( compilation -- orig ; run-time f -- ) \ gforth
    \G AHEAD-like control structure: calls the code after JOIN.
pazsan's avatar
pazsan committed
34
    POSTPONE call >mark ; immediate restrict
35 36 37
: JOIN ( orig -- ) \ gforth
    \G THEN-like control structure for FORK
    postpone THEN ; immediate restrict
pazsan's avatar
pazsan committed
38 39 40 41 42 43 44 45

\ Charclasses

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

0 Value cur-class
46 47 48 49 50 51 52 53 54 55 56 57
: 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 ;
Bernd Paysan's avatar
merged  
Bernd Paysan committed
58 59 60
: +chars ( addr u -- ) \ regexp-cg
    \G add a string of chars to the current charclass
    bounds ?DO  I c@ +char  LOOP ;
pazsan's avatar
pazsan committed
61 62
: or! ( n addr -- )  dup @ rot or swap ! ;
: and! ( n addr -- )  dup @ rot and swap ! ;
63 64 65 66 67 68 69 70
: +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 ;
pazsan's avatar
pazsan committed
71 72 73 74 75 76

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

\ Charclass tests

77 78 79 80 81 82
: 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
pazsan's avatar
pazsan committed
83 84 85 86 87 88 89

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

90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106
: \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
pazsan's avatar
pazsan committed
107
    ]] count [[  char ]] Literal <> ?LEAVE [[ ;  immediate
Bernd Paysan's avatar
Bernd Paysan committed
108 109
: `? ( "char" -- ) \ regexp-pattern
    ]] count [[  char ]] Literal <> + [[ ; immediate
pazsan's avatar
pazsan committed
110 111 112
: -` ( "char" -- ) \ regexp-pattern
    \G check for particular char
    ]] count [[  char ]] Literal = ?LEAVE [[ ;  immediate
pazsan's avatar
pazsan committed
113 114 115 116 117 118 119 120 121

\ 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 ;
pazsan's avatar
pazsan committed
122
: DONE, ( -- )  loops @ IF  loops> ]] DONE [[ ELSE ." no done left!" cr THEN ;
pazsan's avatar
pazsan committed
123 124 125

\ variables

Bernd Paysan's avatar
Bernd Paysan committed
126 127
Variable vars     #20 cells allot
Variable varstack #10 cells allot
pazsan's avatar
pazsan committed
128
Variable varsmax
129 130
: >var ( -- addr )
    vars @+ swap 2* cells +
pazsan's avatar
pazsan committed
131 132
    vars @ varstack @+ swap cells + !
    1 vars +! 1 varstack +! ;
133 134
: var> ( -- addr )
    -1 varstack +!
pazsan's avatar
pazsan committed
135 136
    varstack @+ swap cells + @
    1+ 2* cells vars + ;
pazsan's avatar
pazsan committed
137 138
Variable greed-counts  9 cells allot \ no more than 9 nested greedy loops
: greed' ( -- addr )  greed-counts dup @ + ;
pazsan's avatar
pazsan committed
139 140 141 142

\ start end

0 Value end$
pazsan's avatar
pazsan committed
143
0 Value last$
pazsan's avatar
pazsan committed
144 145
0 Value start$
: !end ( addr u -- addr )  over + to end$ dup to start$ ;
146 147
: end-rex? ( addr -- addr flag ) dup end$ u< ;
: start-rex? ( addr -- addr flag ) dup start$ u> ;
pazsan's avatar
pazsan committed
148
: ?end ( addr -- addr ) ]] dup end$ u> ?LEAVE [[ ; immediate
pazsan's avatar
pazsan committed
149
: rest$ ( addr -- addr addr u ) dup end$ over - ;
pazsan's avatar
pazsan committed
150
: >last ( addr -- flag )  dup to last$ end$ u<= ;
pazsan's avatar
pazsan committed
151 152 153

\ start and end

154 155
: \^ ( addr -- addr ) \ regexp-pattern
    \G check for string start
156
    ]] start-rex? ?LEAVE [[ ; immediate
157 158
: \$ ( addr -- addr ) \ regexp-pattern
    \G check for string end
159
    ]] end-rex? ?LEAVE [[ ; immediate
pazsan's avatar
pazsan committed
160

pazsan's avatar
pazsan committed
161 162
\ A word for string comparison

pazsan's avatar
pazsan committed
163
: (str=?) ( addr1 addr u -- addr2 )
pazsan's avatar
pazsan committed
164
    dup >r 2>r rest$ r@ umin 2r> compare IF rdrop true ELSE r> + false THEN ;
pazsan's avatar
pazsan committed
165 166
: str=? ( addr1 addr u -- addr2 ) ]] (str=?) ?LEAVE [[ ; immediate
: ,=" ( addr u -- ) tuck dup ]] rest$ Literal umin SLiteral compare ?LEAVE Literal + [[ ;
pazsan's avatar
pazsan committed
167 168 169 170
: =" ( <string>" -- ) \ regexp-pattern
    \G check for string
    '" parse ,=" ; immediate

pazsan's avatar
pazsan committed
171 172 173 174 175
\ regexp block

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

176 177
: (( ( addr u -- ) \ regexp-pattern
    \G start regexp block
pazsan's avatar
pazsan committed
178
    vars off varsmax off loops off greed-counts off
pazsan's avatar
pazsan committed
179
    ]] FORK  AHEAD BUT JOIN !end [[ BEGIN, ; immediate
pazsan's avatar
pazsan committed
180
: )) ( -- flag ) \ regexp-pattern
181
    \G end regexp block
pazsan's avatar
pazsan committed
182
    ]] >last  ;S [[
pazsan's avatar
pazsan committed
183
    DONE, ]] drop false ;S THEN [[ ; immediate
pazsan's avatar
pazsan committed
184 185 186 187 188 189 190 191

\ 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! ;

192 193
: {** ( addr -- addr addr ) \ regexp-pattern
    \G greedy zero-or-more pattern
pazsan's avatar
pazsan committed
194
    ]] false >r BEGIN  dup  FORK  BUT  WHILE  last$ r> 1+ >r  REPEAT [[
195 196
    ]] r>  AHEAD  BUT  JOIN [[
    BEGIN, ; immediate
197 198 199 200 201
' {** Alias {++ ( addr -- addr addr ) \ regexp-pattern
    \G greedy one-or-more pattern
    immediate
: **} ( sys -- ) \ regexp-pattern
    \G end of greedy zero-or-more pattern
pazsan's avatar
pazsan committed
202 203
    ]] >last  ;S [[ DONE, ]] drop false ;S  THEN [[
    ]] 1+ false  U+DO  FORK BUT [[
pazsan's avatar
pazsan committed
204
    ]] IF  I' I - 1- drops UNLOOP  true ;S  THEN  LOOP [[
pazsan's avatar
pazsan committed
205
    ]] false ;S JOIN [[ ; immediate
206
: ++} ( sys -- ) \ regexp-pattern
207
    \G end of greedy one-or-more pattern
pazsan's avatar
pazsan committed
208 209
    ]] >last  ;S [[ DONE, ]] drop false ;S  THEN [[
    ]] false  U+DO  FORK BUT [[
pazsan's avatar
pazsan committed
210
    ]] IF  I' I - drops UNLOOP  true ;S  THEN  LOOP [[
pazsan's avatar
pazsan committed
211
    ]] drop false ;S JOIN [[ ; immediate
pazsan's avatar
pazsan committed
212 213 214 215 216 217

\ 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.

218 219
: {+ ( addr -- addr addr ) \ regexp-pattern
    \G non-greedy one-or-more pattern
pazsan's avatar
pazsan committed
220
    ]] BEGIN  [[ BEGIN, ; immediate
221 222
: {* ( addr -- addr addr ) \ regexp-pattern
    \G non-greedy zero-or-more pattern
pazsan's avatar
pazsan committed
223
    ]] {+ dup FORK BUT  IF  drop true  ;S THEN [[ ; immediate
224 225
: *} ( addr addr' -- addr' ) \ regexp-pattern
    \G end of non-greedy zero-or-more pattern
pazsan's avatar
pazsan committed
226
    ]] dup end$ u>  UNTIL [[
pazsan's avatar
pazsan committed
227
    DONE, ]] drop false  ;S  JOIN [[ ; immediate
228 229
: +} ( addr addr' -- addr' ) \ regexp-pattern
    \G end of non-greedy one-or-more pattern
pazsan's avatar
pazsan committed
230
    ]] dup FORK BUT  IF  drop true  ;S [[
pazsan's avatar
pazsan committed
231
    DONE, ]] drop false  ;S [[ BEGIN, ]] THEN *} [[ ; immediate
pazsan's avatar
pazsan committed
232

233 234 235
: // ( -- ) \ regexp-pattern
    \G search for string
    ]] {* 1+ *} [[ ; immediate
pazsan's avatar
pazsan committed
236 237 238 239 240 241

\ alternatives

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

pazsan's avatar
pazsan committed
242
: THENs ( sys -- )  BEGIN  dup  WHILE  ]] THEN [[  REPEAT  drop ;
pazsan's avatar
pazsan committed
243

244 245
: {{ ( addr -- addr addr ) \ regexp-pattern
    \G Start of alternatives
pazsan's avatar
pazsan committed
246
    0 ]] dup FORK  IF  drop true ;S  BUT  JOIN [[ vars @ ; immediate
247 248
: || ( addr addr -- addr addr ) \ regexp-pattern
    \G separator between alternatives
pazsan's avatar
pazsan committed
249
    vars @ varsmax @ max varsmax !  vars !
pazsan's avatar
pazsan committed
250 251
    ]] AHEAD  BUT  THEN  [[
    ]] dup FORK  IF  drop true ;S  BUT  JOIN [[ vars @ ; immediate
pazsan's avatar
pazsan committed
252
: }} ( addr addr -- addr ) \ regexp-pattern
253
    \G end of alternatives
pazsan's avatar
pazsan committed
254
    vars @ varsmax @ max vars !  drop
pazsan's avatar
pazsan committed
255
    ]] AHEAD  BUT  THEN  drop false ;S [[  THENs ; immediate
pazsan's avatar
pazsan committed
256 257 258

\ match variables

259 260 261
: \( ( addr -- addr ) \ regexp-pattern
    \G start of matching variable; variables are referred as \\1--9
    ]] dup [[
pazsan's avatar
pazsan committed
262
    >var ]] ALiteral ! [[ ; immediate
263 264 265
: \) ( addr -- addr ) \ regexp-pattern
    \G end of matching variable
    ]] dup [[
pazsan's avatar
pazsan committed
266
    var> ]] ALiteral ! [[ ; immediate
267 268 269
: \0 ( -- addr u ) \ regexp-pattern
    \G the whole string
    start$ end$ over - ;
pazsan's avatar
pazsan committed
270 271 272 273 274
: \: ( 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
pazsan's avatar
pazsan committed
275 276 277 278 279 280 281 282

\ replacements, needs string.fs

require string.fs

0 Value >>ptr
0 Value <<ptr
Variable >>string
pazsan's avatar
pazsan committed
283
: s>>  ( addr -- addr ) \ regexp-replace
284 285 286 287 288
    \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}
pazsan's avatar
pazsan committed
289 290
    <<ptr >>ptr over - >>string $+!
    >>string $+! dup to <<ptr ;
291 292 293 294
: <<" ( "string<">" -- ) \ regexp-replace
    \G Replace string from start of replace pattern region with
    \G @var{string}
    '" parse postpone SLiteral postpone << ; immediate
pazsan's avatar
pazsan committed
295
: >>string@ ( -- addr u )
pazsan's avatar
pazsan committed
296
    >>string $@ ;
297 298
: >>string0 ( addr u -- addr u )
    s" " >>string $!
pazsan's avatar
pazsan committed
299
    0 to >>ptr  over to <<ptr ;
pazsan's avatar
pazsan committed
300
: >>next ( -- addr u ) <<ptr end$ over - ;
pazsan's avatar
pazsan committed
301 302
: >>rest ( -- ) >>next >>string $+! ;
: s// ( addr u -- ptr )
303
    \G start search/replace loop
pazsan's avatar
pazsan committed
304 305 306 307 308 309
    ]] >>string0 (( // s>> [[ ; immediate
: >> ( addr -- addr )
    ]] <<ptr >>ptr u> ?LEAVE ?end [[ ; immediate
: //s ( ptr -- )
    \G search end
    ]] )) drop >>rest >>string@ [[ ; immediate
pazsan's avatar
pazsan committed
310
: //o ( ptr addr u -- addr' u' )
pazsan's avatar
pazsan committed
311
    \G end search/replace single loop
pazsan's avatar
pazsan committed
312
    ]] << //s [[ ; immediate
pazsan's avatar
pazsan committed
313 314
: //g ( ptr addr u -- addr' u' )
    \G end search/replace all loop
pazsan's avatar
pazsan committed
315
    ]] << LEAVE //s [[ ; immediate