Return to regexp.fs CVS log

Up to [gforth] / gforth

R8C stuff

    1: \ Regexp compile
    2: 
    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: \ 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: \ special control structure
   31: 
   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: : -char ( char -- )  cur-class swap -bit ;
   46: : ..char ( start end -- )  1+ swap ?DO  I +char  LOOP ;
   47: : or! ( n addr -- )  dup @ rot or swap ! ;
   48: : and! ( n addr -- )  dup @ rot and swap ! ;
   49: : +class ( class -- )  $100 0 ?DO  @+ swap
   50:         cur-class I + or!  cell +LOOP  drop ;
   51: : -class ( class -- )  $100 0 ?DO  @+ swap invert
   52:         cur-class I + and!  cell +LOOP  drop ;
   53: 
   54: : char? ( addr class -- addr' flag )
   55:     >r count r> + c@ ;
   56: 
   57: \ Charclass tests
   58: 
   59: : c? ( addr class -- )   ]] char? 0= ?LEAVE [[ ; immediate
   60: : -c? ( addr class -- )  ]] char?    ?LEAVE [[ ; immediate
   61: 
   62: charclass digit  '0 '9 ..char
   63: charclass blanks 0 bl ..char
   64: \ bl +char #tab +char #cr +char #lf +char ctrl L +char
   65: charclass letter 'a 'z ..char 'A 'Z ..char
   66: charclass any    0 $FF ..char #lf -char
   67: 
   68: : \d ( addr -- addr' )   ]] digit c?        [[ ; immediate
   69: : \s ( addr -- addr' )   ]] blanks c?       [[ ; immediate
   70: : .? ( addr -- addr' )   ]] any c?          [[ ; immediate
   71: : -\d ( addr -- addr' )  ]] digit -c?       [[ ; immediate
   72: : -\s ( addr -- addr' )  ]] blanks -c?      [[ ; immediate
   73: : ` ( -- )
   74:     ]] count [[  char ]] Literal <> ?LEAVE [[ ;  immediate
   75: 
   76: \ A word for string comparison
   77: 
   78: : $= ( addr1 addr2 u -- f )  tuck compare ;
   79: : ,=" ( addr u -- ) tuck ]] dup SLiteral $= ?LEAVE Literal + noop [[ ;
   80: : =" ( <string>" -- )  '" parse ,=" ; immediate
   81: 
   82: \ loop stack
   83: 
   84: Variable loops  $40 3 * cells allot
   85: : 3@ ( addr -- a b c )  dup >r 2 cells + @ r> 2@ ;
   86: : 3! ( a b c addr -- )  dup >r 2! r> 2 cells + ! ;
   87: : loops> ( -- addr ) -3 loops +!  loops @+ swap cells + 3@ ;
   88: : >loops ( addr -- ) loops @+ swap cells + 3! 3 loops +! ;
   89: : BEGIN, ( -- )  ]] BEGIN [[ >loops ;
   90: : DONE, ( -- )  loops @ IF  loops> ]] DONE [[ THEN ]] noop [[ ;
   91: 
   92: \ variables
   93: 
   94: Variable vars   &18 cells allot
   95: Variable varstack 9 cells allot
   96: Variable varsmax
   97: : >var ( -- addr ) vars @+ swap 2* cells +
   98:     vars @ varstack @+ swap cells + !
   99:     1 vars +! 1 varstack +! ;
  100: : var> ( -- addr ) -1 varstack +!
  101:     varstack @+ swap cells + @
  102:     1+ 2* cells vars + ;
  103: 
  104: \ start end
  105: 
  106: 0 Value end$
  107: 0 Value start$
  108: : !end ( addr u -- addr )  over + to end$ dup to start$ ;
  109: : $? ( addr -- addr flag ) dup end$ u< ;
  110: : ^? ( addr -- addr flag ) dup start$ u> ;
  111: : ?end ( addr -- addr ) ]] dup end$ u> ?LEAVE [[ ; immediate
  112: 
  113: \ start and end
  114: 
  115: : \^ ( addr -- addr )
  116:     ]] ^? ?LEAVE [[ ; immediate
  117: : \$ ( addr -- addr )
  118:     ]] $? ?LEAVE [[ ; immediate
  119: 
  120: \ regexp block
  121: 
  122: \ FORK/JOIN are like AHEAD THEN, but producing a call on AHEAD
  123: \ instead of a jump.
  124: 
  125: : (( ( addr u -- )  vars off varsmax off loops off
  126:     ]] FORK  AHEAD BUT JOIN !end [[ BEGIN, ; immediate
  127: : )) ( -- addr f )
  128:     ]] ?end drop true EXIT [[
  129:     DONE, ]] drop false EXIT THEN [[ ; immediate
  130: 
  131: \ greedy loops
  132: 
  133: \ Idea: scan as many characters as possible, try the rest of the pattern
  134: \ and then back off one pattern at a time
  135: 
  136: : drops ( n -- ) 1+ cells sp@ + sp! ;
  137: 
  138: : {** ( addr -- addr addr )
  139:     0 ]] Literal >r BEGIN dup [[ BEGIN, ; immediate
  140: ' {** Alias {++ ( addr -- addr addr ) immediate
  141: : n*} ( sys n -- )  >r ]] r> 1+ >r $? 0= UNTIL dup [[ DONE, ]] drop [[
  142:     r@ IF r@ ]] r@ Literal u< IF  r> 1+ drops false  EXIT  THEN [[ THEN
  143:     r@ ]] r> 1+ Literal U+DO FORK BUT [[
  144:     ]] IF  I' I - [[ r@ 1- ]] Literal + drops true UNLOOP EXIT  THEN  LOOP [[
  145:     r@ IF  r@ ]] Literal drops [[ THEN
  146:     rdrop ]] false  EXIT  JOIN [[ ; immediate
  147: : **}  0 postpone n*} ; immediate
  148: : ++}  1 postpone n*} ; immediate
  149: 
  150: \ non-greedy loops
  151: 
  152: \ Idea: Try to match rest of the regexp, and if that fails, try match
  153: \ first expr and then try again rest of regexp.
  154: 
  155: : {+ ( addr -- addr addr )
  156:     ]] BEGIN  [[ BEGIN, ; immediate
  157: : {* ( addr -- addr addr )
  158:     ]] {+ dup FORK BUT  IF  drop true  EXIT THEN [[ ; immediate
  159: : *} ( addr addr' -- addr' )
  160:     ]] dup end$ u>  UNTIL [[
  161:     DONE, ]] drop false  EXIT  JOIN [[ ; immediate
  162: : +} ( addr addr' -- addr' )
  163:     ]] dup FORK BUT  IF  drop true  EXIT [[
  164:     DONE, ]] drop false  EXIT  THEN *} [[ ; immediate
  165: 
  166: : // ( -- ) ]] {* 1+ *} [[ ; immediate
  167: 
  168: \ alternatives
  169: 
  170: \ idea: try to match one alternative and then the rest of regexp.
  171: \ if that fails, jump back to second alternative
  172: 
  173: : THENs ( sys -- )  BEGIN  dup  WHILE  ]] THEN [[  REPEAT  drop ;
  174: 
  175: : {{ ( addr -- addr addr )  0 ]] dup BEGIN [[  vars @ ; immediate
  176: : || ( addr addr -- addr addr ) vars @ varsmax @ max varsmax !
  177:     ]] nip AHEAD [[ >r >r >r vars !
  178:     ]] DONE drop dup [[ r> r> r> ]] BEGIN [[ vars @ ; immediate
  179: : }} ( addr addr -- addr addr ) vars @ varsmax @ max vars !
  180:     ]] nip AHEAD [[ >r >r >r drop
  181:     ]] DONE drop LEAVE [[ r> r> r> THENs ; immediate
  182: 
  183: \ match variables
  184: 
  185: : \( ( addr -- addr )  ]] dup [[
  186:     >var ]] ALiteral ! [[ ; immediate
  187: : \) ( addr -- addr )  ]] dup [[
  188:     var> ]] ALiteral ! [[ ; immediate
  189: : \0 ( -- addr u )  start$ end$ over - ;
  190: : \: ( i -- )
  191:     Create 2* 1+ cells vars + ,
  192:   DOES> ( -- addr u ) @ 2@ tuck - ;
  193: : \:s ( n -- ) 0 ?DO  I \:  LOOP ;
  194: 9 \:s \1 \2 \3 \4 \5 \6 \7 \8 \9