qemu/roms/openbios/forth/lib/preprocessor.fs

   1 \ tag: Forth preprocessor
   2 \
   3 \ Forth preprocessor
   4 \
   5 \ Copyright (C) 2003, 2004 Samuel Rydh
   6 \
   7 \ See the file "COPYING" for further information about
   8 \ the copyright and warranty status of this work.
   9 \
  10
  11 0 value prep-wid
  12 0 value prep-dict
  13 0 value prep-here
  14
  15 : ([IF])
  16   begin
  17     begin parse-word dup 0= while
  18       2drop refill
  19     repeat
  20
  21     2dup " [IF]" strcmp 0= if 1 throw then
  22     2dup " [IFDEF]" strcmp 0= if 1 throw then
  23     2dup " [ELSE]" strcmp 0= if 2 throw then
  24     2dup " [THEN]" strcmp 0= if 3 throw then
  25     " \\" strcmp 0= if linefeed parse 2drop then
  26   again
  27 ;
  28
  29 : [IF] ( flag -- )
  30   if exit then
  31   1 begin
  32     ['] ([IF]) catch case
  33       \ EOF (FIXME: this does not work)
  34       \ -1 of ." Missing [THEN]" abort exit endof
  35       \ [IF]
  36       1 of 1+ endof
  37       \ [ELSE]
  38       2 of dup 1 = if 1- then endof
  39       \ [THEN]
  40       3 of 1- endof
  41     endcase
  42   dup 0 <=
  43   until drop
  44 ; immediate
  45
  46 : [ELSE] 0 [ ['] [IF] , ] ; immediate
  47 : [THEN] ; immediate
  48
  49 :noname
  50   0 to prep-wid
  51   0 to prep-dict
  52 ; initializer
  53
  54 : [IFDEF] ( <word> -- )
  55   prep-wid if
  56     parse-word prep-wid search-wordlist dup if nip then
  57   else 0 then
  58   [ ['] [IF] , ]
  59 ; immediate
  60
  61 : [DEFINE] ( <word> -- )
  62   parse-word here get-current >r >r
  63   prep-dict 0= if
  64     2000 alloc-mem here!
  65     here to prep-dict
  66     wordlist to prep-wid
  67     here to prep-here
  68   then
  69   prep-wid set-current prep-here here!
  70   $create
  71   here to prep-here
  72   r> r> set-current here!
  73 ; immediate
  74
  75 : [0] 0 ; immediate
  76 : [1] 1 ; immediate