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