Powered by ViewCVS 1.0-dev
| 1 : | pazsan | 1.1 | \ Regexp compile |
| 2 : | |||
| 3 : | anton | 1.9 | \ Copyright (C) 2005,2006,2007 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 : | |||
| 105 : | \ A word for string comparison | ||
| 106 : | |||
| 107 : | : $= ( addr1 addr2 u -- f ) tuck compare ; | ||
| 108 : | : ,=" ( addr u -- ) tuck ]] dup SLiteral $= ?LEAVE Literal + noop [[ ; | ||
| 109 : | pazsan | 1.8 | : =" ( <string>" -- ) \ regexp-pattern |
| 110 : | \G check for string | ||
| 111 : | '" parse ,=" ; immediate | ||
| 112 : | pazsan | 1.1 | |
| 113 : | \ loop stack | ||
| 114 : | |||
| 115 : | Variable loops $40 3 * cells allot | ||
| 116 : | : 3@ ( addr -- a b c ) dup >r 2 cells + @ r> 2@ ; | ||
| 117 : | : 3! ( a b c addr -- ) dup >r 2! r> 2 cells + ! ; | ||
| 118 : | : loops> ( -- addr ) -3 loops +! loops @+ swap cells + 3@ ; | ||
| 119 : | : >loops ( addr -- ) loops @+ swap cells + 3! 3 loops +! ; | ||
| 120 : | : BEGIN, ( -- ) ]] BEGIN [[ >loops ; | ||
| 121 : | : DONE, ( -- ) loops @ IF loops> ]] DONE [[ THEN ]] noop [[ ; | ||
| 122 : | |||
| 123 : | \ variables | ||
| 124 : | |||
| 125 : | Variable vars &18 cells allot | ||
| 126 : | Variable varstack 9 cells allot | ||
| 127 : | Variable varsmax | ||
| 128 : | : >var ( -- addr ) vars @+ swap 2* cells + | ||
| 129 : | vars @ varstack @+ swap cells + ! | ||
| 130 : | 1 vars +! 1 varstack +! ; | ||
| 131 : | : var> ( -- addr ) -1 varstack +! | ||
| 132 : | varstack @+ swap cells + @ | ||
| 133 : | 1+ 2* cells vars + ; | ||
| 134 : | |||
| 135 : | \ start end | ||
| 136 : | |||
| 137 : | 0 Value end$ | ||
| 138 : | 0 Value start$ | ||
| 139 : | : !end ( addr u -- addr ) over + to end$ dup to start$ ; | ||
| 140 : | pazsan | 1.12 | : end-rex? ( addr -- addr flag ) dup end$ u< ; |
| 141 : | : start-rex? ( addr -- addr flag ) dup start$ u> ; | ||
| 142 : | pazsan | 1.1 | : ?end ( addr -- addr ) ]] dup end$ u> ?LEAVE [[ ; immediate |
| 143 : | |||
| 144 : | \ start and end | ||
| 145 : | |||
| 146 : | pazsan | 1.8 | : \^ ( addr -- addr ) \ regexp-pattern |
| 147 : | \G check for string start | ||
| 148 : | pazsan | 1.12 | ]] start-rex? ?LEAVE [[ ; immediate |
| 149 : | pazsan | 1.8 | : \$ ( addr -- addr ) \ regexp-pattern |
| 150 : | \G check for string end | ||
| 151 : | pazsan | 1.12 | ]] end-rex? ?LEAVE [[ ; immediate |
| 152 : | pazsan | 1.1 | |
| 153 : | \ regexp block | ||
| 154 : | |||
| 155 : | \ FORK/JOIN are like AHEAD THEN, but producing a call on AHEAD | ||
| 156 : | \ instead of a jump. | ||
| 157 : | |||
| 158 : | pazsan | 1.8 | : (( ( addr u -- ) \ regexp-pattern |
| 159 : | \G start regexp block | ||
| 160 : | vars off varsmax off loops off | ||
| 161 : | pazsan | 1.1 | ]] FORK AHEAD BUT JOIN !end [[ BEGIN, ; immediate |
| 162 : | pazsan | 1.8 | : )) ( -- addr f ) \ regexp-pattern |
| 163 : | \G end regexp block | ||
| 164 : | pazsan | 1.1 | ]] ?end drop true EXIT [[ |
| 165 : | DONE, ]] drop false EXIT THEN [[ ; immediate | ||
| 166 : | |||
| 167 : | \ greedy loops | ||
| 168 : | |||
| 169 : | \ Idea: scan as many characters as possible, try the rest of the pattern | ||
| 170 : | \ and then back off one pattern at a time | ||
| 171 : | |||
| 172 : | : drops ( n -- ) 1+ cells sp@ + sp! ; | ||
| 173 : | |||
| 174 : | pazsan | 1.8 | : {** ( addr -- addr addr ) \ regexp-pattern |
| 175 : | \G greedy zero-or-more pattern | ||
| 176 : | pazsan | 1.1 | 0 ]] Literal >r BEGIN dup [[ BEGIN, ; immediate |
| 177 : | pazsan | 1.8 | ' {** Alias {++ ( addr -- addr addr ) \ regexp-pattern |
| 178 : | \G greedy one-or-more pattern | ||
| 179 : | immediate | ||
| 180 : | : n*} ( sys n -- ) \ regexp-pattern | ||
| 181 : | \G At least @var{n} pattern | ||
| 182 : | pazsan | 1.12 | >r ]] r> 1+ >r end-rex? 0= UNTIL dup [[ DONE, ]] drop [[ |
| 183 : | pazsan | 1.1 | r@ IF r@ ]] r@ Literal u< IF r> 1+ drops false EXIT THEN [[ THEN |
| 184 : | r@ ]] r> 1+ Literal U+DO FORK BUT [[ | ||
| 185 : | ]] IF I' I - [[ r@ 1- ]] Literal + drops true UNLOOP EXIT THEN LOOP [[ | ||
| 186 : | r@ IF r@ ]] Literal drops [[ THEN | ||
| 187 : | rdrop ]] false EXIT JOIN [[ ; immediate | ||
| 188 : | pazsan | 1.8 | : **} ( sys -- ) \ regexp-pattern |
| 189 : | \G end of greedy zero-or-more pattern | ||
| 190 : | 0 postpone n*} ; immediate | ||
| 191 : | : ++} ( sys -- ) \ regexp-pattern | ||
| 192 : | \G end of greedy zero-or-more pattern | ||
| 193 : | 1 postpone n*} ; immediate | ||
| 194 : | pazsan | 1.1 | |
| 195 : | \ non-greedy loops | ||
| 196 : | |||
| 197 : | \ Idea: Try to match rest of the regexp, and if that fails, try match | ||
| 198 : | \ first expr and then try again rest of regexp. | ||
| 199 : | |||
| 200 : | pazsan | 1.8 | : {+ ( addr -- addr addr ) \ regexp-pattern |
| 201 : | \G non-greedy one-or-more pattern | ||
| 202 : | pazsan | 1.1 | ]] BEGIN [[ BEGIN, ; immediate |
| 203 : | pazsan | 1.8 | : {* ( addr -- addr addr ) \ regexp-pattern |
| 204 : | \G non-greedy zero-or-more pattern | ||
| 205 : | pazsan | 1.1 | ]] {+ dup FORK BUT IF drop true EXIT THEN [[ ; immediate |
| 206 : | pazsan | 1.8 | : *} ( addr addr' -- addr' ) \ regexp-pattern |
| 207 : | \G end of non-greedy zero-or-more pattern | ||
| 208 : | pazsan | 1.1 | ]] dup end$ u> UNTIL [[ |
| 209 : | DONE, ]] drop false EXIT JOIN [[ ; immediate | ||
| 210 : | pazsan | 1.8 | : +} ( addr addr' -- addr' ) \ regexp-pattern |
| 211 : | \G end of non-greedy one-or-more pattern | ||
| 212 : | pazsan | 1.1 | ]] dup FORK BUT IF drop true EXIT [[ |
| 213 : | DONE, ]] drop false EXIT THEN *} [[ ; immediate | ||
| 214 : | |||
| 215 : | pazsan | 1.8 | : // ( -- ) \ regexp-pattern |
| 216 : | \G search for string | ||
| 217 : | ]] {* 1+ *} [[ ; immediate | ||
| 218 : | pazsan | 1.1 | |
| 219 : | \ alternatives | ||
| 220 : | |||
| 221 : | \ idea: try to match one alternative and then the rest of regexp. | ||
| 222 : | \ if that fails, jump back to second alternative | ||
| 223 : | |||
| 224 : | : THENs ( sys -- ) BEGIN dup WHILE ]] THEN [[ REPEAT drop ; | ||
| 225 : | |||
| 226 : | pazsan | 1.8 | : {{ ( addr -- addr addr ) \ regexp-pattern |
| 227 : | \G Start of alternatives | ||
| 228 : | 0 ]] dup BEGIN [[ vars @ ; immediate | ||
| 229 : | : || ( addr addr -- addr addr ) \ regexp-pattern | ||
| 230 : | \G separator between alternatives | ||
| 231 : | vars @ varsmax @ max varsmax ! | ||
| 232 : | pazsan | 1.1 | ]] nip AHEAD [[ >r >r >r vars ! |
| 233 : | ]] DONE drop dup [[ r> r> r> ]] BEGIN [[ vars @ ; immediate | ||
| 234 : | pazsan | 1.8 | : }} ( addr addr -- addr addr ) \ regexp-pattern |
| 235 : | \G end of alternatives | ||
| 236 : | vars @ varsmax @ max vars ! | ||
| 237 : | pazsan | 1.1 | ]] nip AHEAD [[ >r >r >r drop |
| 238 : | ]] DONE drop LEAVE [[ r> r> r> THENs ; immediate | ||
| 239 : | |||
| 240 : | \ match variables | ||
| 241 : | |||
| 242 : | pazsan | 1.8 | : \( ( addr -- addr ) \ regexp-pattern |
| 243 : | \G start of matching variable; variables are referred as \\1--9 | ||
| 244 : | ]] dup [[ | ||
| 245 : | pazsan | 1.1 | >var ]] ALiteral ! [[ ; immediate |
| 246 : | pazsan | 1.8 | : \) ( addr -- addr ) \ regexp-pattern |
| 247 : | \G end of matching variable | ||
| 248 : | ]] dup [[ | ||
| 249 : | pazsan | 1.1 | var> ]] ALiteral ! [[ ; immediate |
| 250 : | pazsan | 1.8 | : \0 ( -- addr u ) \ regexp-pattern |
| 251 : | \G the whole string | ||
| 252 : | start$ end$ over - ; | ||
| 253 : | pazsan | 1.1 | : \: ( i -- ) |
| 254 : | Create 2* 1+ cells vars + , | ||
| 255 : | DOES> ( -- addr u ) @ 2@ tuck - ; | ||
| 256 : | : \:s ( n -- ) 0 ?DO I \: LOOP ; | ||
| 257 : | 9 \:s \1 \2 \3 \4 \5 \6 \7 \8 \9 | ||
| 258 : | pazsan | 1.6 | |
| 259 : | \ replacements, needs string.fs | ||
| 260 : | |||
| 261 : | require string.fs | ||
| 262 : | |||
| 263 : | 0 Value >>ptr | ||
| 264 : | 0 Value <<ptr | ||
| 265 : | Variable >>string | ||
| 266 : | pazsan | 1.8 | : >> ( addr -- addr ) \ regexp-replace |
| 267 : | \G Start replace pattern region | ||
| 268 : | dup to >>ptr ; | ||
| 269 : | : << ( run-addr addr u -- run-addr ) \ regexp-replace | ||
| 270 : | \G Replace string from start of replace pattern region with | ||
| 271 : | \G @var{addr} @var{u} | ||
| 272 : | pazsan | 1.6 | <<ptr 0= IF start$ to <<ptr THEN |
| 273 : | >>string @ 0= IF s" " >>string $! THEN | ||
| 274 : | <<ptr >>ptr over - >>string $+! | ||
| 275 : | >>string $+! dup to <<ptr ; | ||
| 276 : | pazsan | 1.8 | : <<" ( "string<">" -- ) \ regexp-replace |
| 277 : | \G Replace string from start of replace pattern region with | ||
| 278 : | \G @var{string} | ||
| 279 : | '" parse postpone SLiteral postpone << ; immediate | ||
| 280 : | pazsan | 1.6 | : >>string@ ( -- addr u ) |
| 281 : | >>string $@ >>string off | ||
| 282 : | 0 to >>ptr 0 to <<ptr ; | ||
| 283 : | : >>next ( -- addr u ) <<ptr end$ over - ; | ||
| 284 : | pazsan | 1.8 | : s// ( -- sys ) \ regexp-replace |
| 285 : | \G start search/replace loop | ||
| 286 : | ]] BEGIN [[ ; immediate | ||
| 287 : | : //g ( sys -- ) \ regexp-replace | ||
| 288 : | \G end search/replace loop | ||
| 289 : | ]] WHILE >>next REPEAT end$ [[ | ||
| 290 : | pazsan | 1.6 | s" " ]] SLiteral << >>string@ rot drop [[ ; immediate |
|
CVS Admin Powered by ViewCVS 1.0-dev |
ViewCVS and CVS Help |