qemu/roms/openbios/forth/device/feval.fs

   1 \ tag: FCode evaluator
   2 \
   3 \ this code implements an fcode evaluator
   4 \ as described in IEEE 1275-1994
   5 \
   6 \ Copyright (C) 2003 Stefan Reinauer
   7 \
   8 \ See the file "COPYING" for further information about
   9 \ the copyright and warranty status of this work.
  10 \
  11
  12 defer init-fcode-table
  13
  14 : alloc-fcode-table
  15   4096 cells alloc-mem to fcode-table
  16   ?fcode-verbose if
  17     ." fcode-table at 0x" fcode-table . cr
  18   then
  19   init-fcode-table
  20   ;
  21
  22 : free-fcode-table
  23   fcode-table 4096 cells free-mem
  24   0 to fcode-table
  25   ;
  26
  27 : (debug-feval) ( fcode# -- fcode# )
  28   \ Address
  29   fcode-stream 1 - . ." : "
  30
  31   \ Indicate if word is compiled
  32   state @ 0<> if
  33     ." (compile) "
  34   then
  35   dup fcode>xt cell - lfa2name type
  36   dup ."  [ 0x" . ." ]" cr
  37   ;
  38
  39 : (feval) ( -- ?? )
  40   begin
  41     fcode#
  42     ?fcode-verbose if
  43       (debug-feval)
  44     then
  45     fcode>xt
  46     dup flags? 0<> state @ 0= or if
  47       execute
  48     else
  49       ,
  50     then
  51   fcode-end @ until
  52
  53   \ If we've executed incorrect FCode we may have reached the end of the FCode
  54   \ program but still be in compile mode. Make sure that if this has happened
  55   \ then we switch back to immediate mode to prevent internal OpenBIOS errors.
  56   tmp-comp-depth @ -1 <> if
  57     -1 tmp-comp-depth !
  58     tmp-comp-buf @ @ here!
  59     0 state !
  60   then
  61 ;
  62
  63 : byte-load ( addr xt -- )
  64   ?fcode-verbose if
  65     cr ." byte-load: evaluating fcode at 0x" over . cr
  66   then
  67
  68   \ save state
  69   >r >r fcode-push-state r> r>
  70
  71   \ set fcode-c@ defer
  72   dup 1 = if drop ['] c@ then      \ FIXME: uses c@ rather than rb@ for now...
  73   to fcode-c@
  74   dup to fcode-stream-start
  75   to fcode-stream
  76   1 to fcode-spread
  77   false to ?fcode-offset16
  78   alloc-fcode-table
  79   false fcode-end !
  80
  81   \ protect against stack overflow/underflow
  82   0 0 0 0 0 0 depth >r
  83
  84   ['] (feval) catch if
  85     cr ." byte-load: exception caught!" cr
  86   then
  87
  88   s" fcode-debug?" evaluate if
  89     depth r@ <> if
  90       cr ." byte-load: warning stack overflow, diff " depth r@ - . cr
  91     then
  92   then
  93
  94   r> depth! 3drop 3drop
  95
  96   free-fcode-table
  97
  98   \ restore state
  99   fcode-pop-state
 100 ;