Annotation of gforth/regexp.fs, revision 1.1
1.1 ! pazsan 1: \ Regexp compile
! 2:
! 3: \ The idea of the parser is the following:
! 4: \ As long as there's a match, continue
! 5: \ On a mismatch, LEAVE.
! 6: \ Insert appropriate control structures on alternative branches
! 7: \ Keep the old pointer (backtracking) on the stack
! 8: \ I try to keep the syntax as close to a real regexp system as possible
! 9: \ All regexp stuff is compiled into one function as forward branching
! 10: \ state machine
! 11:
! 12: \ bulk-postponing
! 13:
! 14: : FORK ( compilation -- orig ; run-time f -- ) \ core
! 15: POSTPONE call >mark ; immediate restrict
! 16: : JOIN ( orig -- ) postpone THEN ; immediate restrict
! 17:
! 18: \ Charclasses
! 19:
! 20: : +bit ( addr n -- ) + 1 swap c! ;
! 21: : -bit ( addr n -- ) + 0 swap c! ;
! 22: : @+ ( addr -- n addr' ) dup @ swap cell+ ;
! 23:
! 24: 0 Value cur-class
! 25: : charclass ( -- ) Create here dup to cur-class $100 dup allot erase ;
! 26: : +char ( char -- ) cur-class swap +bit ;
! 27: : -char ( char -- ) cur-class swap -bit ;
! 28: : ..char ( start end -- ) 1+ swap ?DO I +char LOOP ;
! 29: : or! ( n addr -- ) dup @ rot or swap ! ;
! 30: : and! ( n addr -- ) dup @ rot and swap ! ;
! 31: : +class ( class -- ) $100 0 ?DO @+ swap
! 32: cur-class I + or! cell +LOOP drop ;
! 33: : -class ( class -- ) $100 0 ?DO @+ swap invert
! 34: cur-class I + and! cell +LOOP drop ;
! 35:
! 36: : char? ( addr class -- addr' flag )
! 37: >r count r> + c@ ;
! 38:
! 39: \ Charclass tests
! 40:
! 41: : c? ( addr class -- ) ]] char? 0= ?LEAVE [[ ; immediate
! 42: : -c? ( addr class -- ) ]] char? ?LEAVE [[ ; immediate
! 43:
! 44: charclass digit '0 '9 ..char
! 45: charclass blanks 0 bl ..char
! 46: \ bl +char #tab +char #cr +char #lf +char ctrl L +char
! 47: charclass letter 'a 'z ..char 'A 'Z ..char
! 48: charclass any 0 $FF ..char #lf -char
! 49:
! 50: : \d ( addr -- addr' ) ]] digit c? [[ ; immediate
! 51: : \s ( addr -- addr' ) ]] blanks c? [[ ; immediate
! 52: : .? ( addr -- addr' ) ]] any c? [[ ; immediate
! 53: : -\d ( addr -- addr' ) ]] digit -c? [[ ; immediate
! 54: : -\s ( addr -- addr' ) ]] blanks -c? [[ ; immediate
! 55: : ` ( -- )
! 56: ]] count [[ char ]] Literal <> ?LEAVE [[ ; immediate
! 57:
! 58: \ A word for string comparison
! 59:
! 60: : $= ( addr1 addr2 u -- f ) tuck compare ;
! 61: : ,=" ( addr u -- ) tuck ]] dup SLiteral $= ?LEAVE Literal + noop [[ ;
! 62: : =" ( <string>" -- ) '" parse ,=" ; immediate
! 63:
! 64: \ loop stack
! 65:
! 66: Variable loops $40 3 * cells allot
! 67: : 3@ ( addr -- a b c ) dup >r 2 cells + @ r> 2@ ;
! 68: : 3! ( a b c addr -- ) dup >r 2! r> 2 cells + ! ;
! 69: : loops> ( -- addr ) -3 loops +! loops @+ swap cells + 3@ ;
! 70: : >loops ( addr -- ) loops @+ swap cells + 3! 3 loops +! ;
! 71: : BEGIN, ( -- ) ]] BEGIN [[ >loops ;
! 72: : DONE, ( -- ) loops @ IF loops> ]] DONE [[ THEN ]] noop [[ ;
! 73:
! 74: \ variables
! 75:
! 76: Variable vars &18 cells allot
! 77: Variable varstack 9 cells allot
! 78: Variable varsmax
! 79: : >var ( -- addr ) vars @+ swap 2* cells +
! 80: vars @ varstack @+ swap cells + !
! 81: 1 vars +! 1 varstack +! ;
! 82: : var> ( -- addr ) -1 varstack +!
! 83: varstack @+ swap cells + @
! 84: 1+ 2* cells vars + ;
! 85:
! 86: \ start end
! 87:
! 88: 0 Value end$
! 89: 0 Value start$
! 90: : !end ( addr u -- addr ) over + to end$ dup to start$ ;
! 91: : $? ( addr -- addr flag ) dup end$ u< ;
! 92: : ^? ( addr -- addr flag ) dup start$ u> ;
! 93: : ?end ( addr -- addr ) ]] dup end$ u> ?LEAVE [[ ; immediate
! 94:
! 95: \ start and end
! 96:
! 97: : \^ ( addr -- addr )
! 98: ]] ^? ?LEAVE [[ ; immediate
! 99: : \$ ( addr -- addr )
! 100: ]] $? ?LEAVE [[ ; immediate
! 101:
! 102: \ regexp block
! 103:
! 104: \ FORK/JOIN are like AHEAD THEN, but producing a call on AHEAD
! 105: \ instead of a jump.
! 106:
! 107: : (( ( addr u -- ) vars off varsmax off loops off
! 108: ]] FORK AHEAD BUT JOIN !end [[ BEGIN, ; immediate
! 109: : )) ( -- addr f )
! 110: ]] ?end drop true EXIT [[
! 111: DONE, ]] drop false EXIT THEN [[ ; immediate
! 112:
! 113: \ greedy loops
! 114:
! 115: \ Idea: scan as many characters as possible, try the rest of the pattern
! 116: \ and then back off one pattern at a time
! 117:
! 118: : drops ( n -- ) 1+ cells sp@ + sp! ;
! 119:
! 120: : {** ( addr -- addr addr )
! 121: 0 ]] Literal >r BEGIN dup [[ BEGIN, ; immediate
! 122: ' {** Alias {++ ( addr -- addr addr ) immediate
! 123: : n*} ( sys n -- ) >r ]] r> 1+ >r $? 0= UNTIL dup [[ DONE, ]] drop [[
! 124: r@ IF r@ ]] r@ Literal u< IF r> 1+ drops false EXIT THEN [[ THEN
! 125: r@ ]] r> 1+ Literal U+DO FORK BUT [[
! 126: ]] IF I' I - [[ r@ 1- ]] Literal + drops true UNLOOP EXIT THEN LOOP [[
! 127: r@ IF r@ ]] Literal drops [[ THEN
! 128: rdrop ]] false EXIT JOIN [[ ; immediate
! 129: : **} 0 postpone n*} ; immediate
! 130: : ++} 1 postpone n*} ; immediate
! 131:
! 132: \ non-greedy loops
! 133:
! 134: \ Idea: Try to match rest of the regexp, and if that fails, try match
! 135: \ first expr and then try again rest of regexp.
! 136:
! 137: : {+ ( addr -- addr addr )
! 138: ]] BEGIN [[ BEGIN, ; immediate
! 139: : {* ( addr -- addr addr )
! 140: ]] {+ dup FORK BUT IF drop true EXIT THEN [[ ; immediate
! 141: : *} ( addr addr' -- addr' )
! 142: ]] dup end$ u> UNTIL [[
! 143: DONE, ]] drop false EXIT JOIN [[ ; immediate
! 144: : +} ( addr addr' -- addr' )
! 145: ]] dup FORK BUT IF drop true EXIT [[
! 146: DONE, ]] drop false EXIT THEN *} [[ ; immediate
! 147:
! 148: : // ( -- ) ]] {* 1+ *} [[ ; immediate
! 149:
! 150: \ alternatives
! 151:
! 152: \ idea: try to match one alternative and then the rest of regexp.
! 153: \ if that fails, jump back to second alternative
! 154:
! 155: : THENs ( sys -- ) BEGIN dup WHILE ]] THEN [[ REPEAT drop ;
! 156:
! 157: : {{ ( addr -- addr addr ) 0 ]] dup BEGIN [[ vars @ ; immediate
! 158: : || ( addr addr -- addr addr ) vars @ varsmax @ max varsmax !
! 159: ]] nip AHEAD [[ >r >r >r vars !
! 160: ]] DONE drop dup [[ r> r> r> ]] BEGIN [[ vars @ ; immediate
! 161: : }} ( addr addr -- addr addr ) vars @ varsmax @ max vars !
! 162: ]] nip AHEAD [[ >r >r >r drop
! 163: ]] DONE drop LEAVE [[ r> r> r> THENs ; immediate
! 164:
! 165: \ match variables
! 166:
! 167: : \( ( addr -- addr ) ]] dup [[
! 168: >var ]] ALiteral ! [[ ; immediate
! 169: : \) ( addr -- addr ) ]] dup [[
! 170: var> ]] ALiteral ! [[ ; immediate
! 171: : \0 ( -- addr u ) start$ end$ over - ;
! 172: : \: ( i -- )
! 173: Create 2* 1+ cells vars + ,
! 174: DOES> ( -- addr u ) @ 2@ tuck - ;
! 175: : \:s ( n -- ) 0 ?DO I \: LOOP ;
! 176: 9 \:s \1 \2 \3 \4 \5 \6 \7 \8 \9
FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>
![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to regexp.fs CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [gforth] / gforth