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