version 1.7, 2006/12/31 13:39:13
|
version 1.8, 2007/10/03 18:41:09
|
Line 29
|
Line 29
|
|
|
\ special control structure |
\ special control structure |
|
|
: FORK ( compilation -- orig ; run-time f -- ) \ core |
: FORK ( compilation -- orig ; run-time f -- ) \ gforth |
|
\G AHEAD-like control structure: calls the code after JOIN. |
POSTPONE call >mark ; immediate restrict |
POSTPONE call >mark ; immediate restrict |
: JOIN ( orig -- ) postpone THEN ; immediate restrict |
: JOIN ( orig -- ) \ gforth |
|
\G THEN-like control structure for FORK |
|
postpone THEN ; immediate restrict |
|
|
\ Charclasses |
\ Charclasses |
|
|
Line 40
|
Line 43
|
: @+ ( addr -- n addr' ) dup @ swap cell+ ; |
: @+ ( addr -- n addr' ) dup @ swap cell+ ; |
|
|
0 Value cur-class |
0 Value cur-class |
: charclass ( -- ) Create here dup to cur-class $100 dup allot erase ; |
: charclass ( -- ) \ regexp-cg |
: +char ( char -- ) cur-class swap +bit ; |
\G Create a charclass |
: -char ( char -- ) cur-class swap -bit ; |
Create here dup to cur-class $100 dup allot erase ; |
: ..char ( start end -- ) 1+ swap ?DO I +char LOOP ; |
: +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 ; |
: or! ( n addr -- ) dup @ rot or swap ! ; |
: or! ( n addr -- ) dup @ rot or swap ! ; |
: and! ( n addr -- ) dup @ rot and swap ! ; |
: and! ( n addr -- ) dup @ rot and swap ! ; |
: +class ( class -- ) $100 0 ?DO @+ swap |
: +class ( class -- ) \ regexp-cg |
cur-class I + or! cell +LOOP drop ; |
\G union of charclass @var{class} and the current charclass |
: -class ( class -- ) $100 0 ?DO @+ swap invert |
$100 0 ?DO @+ swap |
cur-class I + and! cell +LOOP drop ; |
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 ; |
|
|
: char? ( addr class -- addr' flag ) |
: char? ( addr class -- addr' flag ) |
>r count r> + c@ ; |
>r count r> + c@ ; |
|
|
\ Charclass tests |
\ Charclass tests |
|
|
: c? ( addr class -- ) ]] char? 0= ?LEAVE [[ ; immediate |
: c? ( addr class -- ) \ regexp-pattern |
: -c? ( addr class -- ) ]] char? ?LEAVE [[ ; immediate |
\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 |
|
|
charclass digit '0 '9 ..char |
charclass digit '0 '9 ..char |
charclass blanks 0 bl ..char |
charclass blanks 0 bl ..char |
Line 65 charclass blanks 0 bl ..char
|
Line 84 charclass blanks 0 bl ..char
|
charclass letter 'a 'z ..char 'A 'Z ..char |
charclass letter 'a 'z ..char 'A 'Z ..char |
charclass any 0 $FF ..char #lf -char |
charclass any 0 $FF ..char #lf -char |
|
|
: \d ( addr -- addr' ) ]] digit c? [[ ; immediate |
: \d ( addr -- addr' ) \ regexp-pattern |
: \s ( addr -- addr' ) ]] blanks c? [[ ; immediate |
\G check for digit |
: .? ( addr -- addr' ) ]] any c? [[ ; immediate |
]] digit c? [[ ; immediate |
: -\d ( addr -- addr' ) ]] digit -c? [[ ; immediate |
: \s ( addr -- addr' ) \ regexp-pattern |
: -\s ( addr -- addr' ) ]] blanks -c? [[ ; immediate |
\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 |
]] count [[ char ]] Literal <> ?LEAVE [[ ; immediate |
]] count [[ char ]] Literal <> ?LEAVE [[ ; immediate |
|
|
\ A word for string comparison |
\ A word for string comparison |
|
|
: $= ( addr1 addr2 u -- f ) tuck compare ; |
: $= ( addr1 addr2 u -- f ) tuck compare ; |
: ,=" ( addr u -- ) tuck ]] dup SLiteral $= ?LEAVE Literal + noop [[ ; |
: ,=" ( addr u -- ) tuck ]] dup SLiteral $= ?LEAVE Literal + noop [[ ; |
: =" ( <string>" -- ) '" parse ,=" ; immediate |
: =" ( <string>" -- ) \ regexp-pattern |
|
\G check for string |
|
'" parse ,=" ; immediate |
|
|
\ loop stack |
\ loop stack |
|
|
Line 112 Variable varsmax
|
Line 144 Variable varsmax
|
|
|
\ start and end |
\ start and end |
|
|
: \^ ( addr -- addr ) |
: \^ ( addr -- addr ) \ regexp-pattern |
|
\G check for string start |
]] ^? ?LEAVE [[ ; immediate |
]] ^? ?LEAVE [[ ; immediate |
: \$ ( addr -- addr ) |
: \$ ( addr -- addr ) \ regexp-pattern |
|
\G check for string end |
]] $? ?LEAVE [[ ; immediate |
]] $? ?LEAVE [[ ; immediate |
|
|
\ regexp block |
\ regexp block |
Line 122 Variable varsmax
|
Line 156 Variable varsmax
|
\ FORK/JOIN are like AHEAD THEN, but producing a call on AHEAD |
\ FORK/JOIN are like AHEAD THEN, but producing a call on AHEAD |
\ instead of a jump. |
\ instead of a jump. |
|
|
: (( ( addr u -- ) vars off varsmax off loops off |
: (( ( addr u -- ) \ regexp-pattern |
|
\G start regexp block |
|
vars off varsmax off loops off |
]] FORK AHEAD BUT JOIN !end [[ BEGIN, ; immediate |
]] FORK AHEAD BUT JOIN !end [[ BEGIN, ; immediate |
: )) ( -- addr f ) |
: )) ( -- addr f ) \ regexp-pattern |
|
\G end regexp block |
]] ?end drop true EXIT [[ |
]] ?end drop true EXIT [[ |
DONE, ]] drop false EXIT THEN [[ ; immediate |
DONE, ]] drop false EXIT THEN [[ ; immediate |
|
|
Line 135 Variable varsmax
|
Line 172 Variable varsmax
|
|
|
: drops ( n -- ) 1+ cells sp@ + sp! ; |
: drops ( n -- ) 1+ cells sp@ + sp! ; |
|
|
: {** ( addr -- addr addr ) |
: {** ( addr -- addr addr ) \ regexp-pattern |
|
\G greedy zero-or-more pattern |
0 ]] Literal >r BEGIN dup [[ BEGIN, ; immediate |
0 ]] Literal >r BEGIN dup [[ BEGIN, ; immediate |
' {** Alias {++ ( addr -- addr addr ) immediate |
' {** Alias {++ ( addr -- addr addr ) \ regexp-pattern |
: n*} ( sys n -- ) >r ]] r> 1+ >r $? 0= UNTIL dup [[ DONE, ]] drop [[ |
\G greedy one-or-more pattern |
|
immediate |
|
: n*} ( sys n -- ) \ regexp-pattern |
|
\G At least @var{n} pattern |
|
>r ]] r> 1+ >r $? 0= UNTIL dup [[ DONE, ]] drop [[ |
r@ IF r@ ]] r@ Literal u< IF r> 1+ drops false EXIT THEN [[ THEN |
r@ IF r@ ]] r@ Literal u< IF r> 1+ drops false EXIT THEN [[ THEN |
r@ ]] r> 1+ Literal U+DO FORK BUT [[ |
r@ ]] r> 1+ Literal U+DO FORK BUT [[ |
]] IF I' I - [[ r@ 1- ]] Literal + drops true UNLOOP EXIT THEN LOOP [[ |
]] IF I' I - [[ r@ 1- ]] Literal + drops true UNLOOP EXIT THEN LOOP [[ |
r@ IF r@ ]] Literal drops [[ THEN |
r@ IF r@ ]] Literal drops [[ THEN |
rdrop ]] false EXIT JOIN [[ ; immediate |
rdrop ]] false EXIT JOIN [[ ; immediate |
: **} 0 postpone n*} ; immediate |
: **} ( sys -- ) \ regexp-pattern |
: ++} 1 postpone n*} ; immediate |
\G end of greedy zero-or-more pattern |
|
0 postpone n*} ; immediate |
|
: ++} ( sys -- ) \ regexp-pattern |
|
\G end of greedy zero-or-more pattern |
|
1 postpone n*} ; immediate |
|
|
\ non-greedy loops |
\ non-greedy loops |
|
|
\ Idea: Try to match rest of the regexp, and if that fails, try match |
\ Idea: Try to match rest of the regexp, and if that fails, try match |
\ first expr and then try again rest of regexp. |
\ first expr and then try again rest of regexp. |
|
|
: {+ ( addr -- addr addr ) |
: {+ ( addr -- addr addr ) \ regexp-pattern |
|
\G non-greedy one-or-more pattern |
]] BEGIN [[ BEGIN, ; immediate |
]] BEGIN [[ BEGIN, ; immediate |
: {* ( addr -- addr addr ) |
: {* ( addr -- addr addr ) \ regexp-pattern |
|
\G non-greedy zero-or-more pattern |
]] {+ dup FORK BUT IF drop true EXIT THEN [[ ; immediate |
]] {+ dup FORK BUT IF drop true EXIT THEN [[ ; immediate |
: *} ( addr addr' -- addr' ) |
: *} ( addr addr' -- addr' ) \ regexp-pattern |
|
\G end of non-greedy zero-or-more pattern |
]] dup end$ u> UNTIL [[ |
]] dup end$ u> UNTIL [[ |
DONE, ]] drop false EXIT JOIN [[ ; immediate |
DONE, ]] drop false EXIT JOIN [[ ; immediate |
: +} ( addr addr' -- addr' ) |
: +} ( addr addr' -- addr' ) \ regexp-pattern |
|
\G end of non-greedy one-or-more pattern |
]] dup FORK BUT IF drop true EXIT [[ |
]] dup FORK BUT IF drop true EXIT [[ |
DONE, ]] drop false EXIT THEN *} [[ ; immediate |
DONE, ]] drop false EXIT THEN *} [[ ; immediate |
|
|
: // ( -- ) ]] {* 1+ *} [[ ; immediate |
: // ( -- ) \ regexp-pattern |
|
\G search for string |
|
]] {* 1+ *} [[ ; immediate |
|
|
\ alternatives |
\ alternatives |
|
|
Line 172 Variable varsmax
|
Line 224 Variable varsmax
|
|
|
: THENs ( sys -- ) BEGIN dup WHILE ]] THEN [[ REPEAT drop ; |
: THENs ( sys -- ) BEGIN dup WHILE ]] THEN [[ REPEAT drop ; |
|
|
: {{ ( addr -- addr addr ) 0 ]] dup BEGIN [[ vars @ ; immediate |
: {{ ( addr -- addr addr ) \ regexp-pattern |
: || ( addr addr -- addr addr ) vars @ varsmax @ max varsmax ! |
\G Start of alternatives |
|
0 ]] dup BEGIN [[ vars @ ; immediate |
|
: || ( addr addr -- addr addr ) \ regexp-pattern |
|
\G separator between alternatives |
|
vars @ varsmax @ max varsmax ! |
]] nip AHEAD [[ >r >r >r vars ! |
]] nip AHEAD [[ >r >r >r vars ! |
]] DONE drop dup [[ r> r> r> ]] BEGIN [[ vars @ ; immediate |
]] DONE drop dup [[ r> r> r> ]] BEGIN [[ vars @ ; immediate |
: }} ( addr addr -- addr addr ) vars @ varsmax @ max vars ! |
: }} ( addr addr -- addr addr ) \ regexp-pattern |
|
\G end of alternatives |
|
vars @ varsmax @ max vars ! |
]] nip AHEAD [[ >r >r >r drop |
]] nip AHEAD [[ >r >r >r drop |
]] DONE drop LEAVE [[ r> r> r> THENs ; immediate |
]] DONE drop LEAVE [[ r> r> r> THENs ; immediate |
|
|
\ match variables |
\ match variables |
|
|
: \( ( addr -- addr ) ]] dup [[ |
: \( ( addr -- addr ) \ regexp-pattern |
|
\G start of matching variable; variables are referred as \\1--9 |
|
]] dup [[ |
>var ]] ALiteral ! [[ ; immediate |
>var ]] ALiteral ! [[ ; immediate |
: \) ( addr -- addr ) ]] dup [[ |
: \) ( addr -- addr ) \ regexp-pattern |
|
\G end of matching variable |
|
]] dup [[ |
var> ]] ALiteral ! [[ ; immediate |
var> ]] ALiteral ! [[ ; immediate |
: \0 ( -- addr u ) start$ end$ over - ; |
: \0 ( -- addr u ) \ regexp-pattern |
|
\G the whole string |
|
start$ end$ over - ; |
: \: ( i -- ) |
: \: ( i -- ) |
Create 2* 1+ cells vars + , |
Create 2* 1+ cells vars + , |
DOES> ( -- addr u ) @ 2@ tuck - ; |
DOES> ( -- addr u ) @ 2@ tuck - ; |
Line 200 require string.fs
|
Line 264 require string.fs
|
0 Value >>ptr |
0 Value >>ptr |
0 Value <<ptr |
0 Value <<ptr |
Variable >>string |
Variable >>string |
: >> ( addr -- addr ) dup to >>ptr ; |
: >> ( addr -- addr ) \ regexp-replace |
: << ( run-addr addr u -- run-addr ) |
\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} |
<<ptr 0= IF start$ to <<ptr THEN |
<<ptr 0= IF start$ to <<ptr THEN |
>>string @ 0= IF s" " >>string $! THEN |
>>string @ 0= IF s" " >>string $! THEN |
<<ptr >>ptr over - >>string $+! |
<<ptr >>ptr over - >>string $+! |
>>string $+! dup to <<ptr ; |
>>string $+! dup to <<ptr ; |
: <<" '" parse postpone SLiteral postpone << ; immediate |
: <<" ( "string<">" -- ) \ regexp-replace |
|
\G Replace string from start of replace pattern region with |
|
\G @var{string} |
|
'" parse postpone SLiteral postpone << ; immediate |
: >>string@ ( -- addr u ) |
: >>string@ ( -- addr u ) |
>>string $@ >>string off |
>>string $@ >>string off |
0 to >>ptr 0 to <<ptr ; |
0 to >>ptr 0 to <<ptr ; |
: >>next ( -- addr u ) <<ptr end$ over - ; |
: >>next ( -- addr u ) <<ptr end$ over - ; |
: s// ]] BEGIN [[ ; immediate |
: s// ( -- sys ) \ regexp-replace |
: //g ]] WHILE >>next REPEAT end$ [[ |
\G start search/replace loop |
|
]] BEGIN [[ ; immediate |
|
: //g ( sys -- ) \ regexp-replace |
|
\G end search/replace loop |
|
]] WHILE >>next REPEAT end$ [[ |
s" " ]] SLiteral << >>string@ rot drop [[ ; immediate |
s" " ]] SLiteral << >>string@ rot drop [[ ; immediate |