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
  54 : byte-load ( addr xt -- )
  55   ?fcode-verbose if
  56     cr ." byte-load: evaluating fcode at 0x" over . cr
  57   then
  58
  59   \ save state
  60   >r >r fcode-push-state r> r>
  61
  62   \ set fcode-c@ defer
  63   dup 1 = if drop ['] c@ then      \ FIXME: uses c@ rather than rb@ for now...
  64   to fcode-c@
  65   dup to fcode-stream-start
  66   to fcode-stream
  67   1 to fcode-spread
  68   false to ?fcode-offset16
  69   alloc-fcode-table
  70   false fcode-end !
  71
  72   \ protect against stack overflow/underflow
  73   0 0 0 0 0 0 depth >r
  74
  75   ['] (feval) catch if
  76     cr ." byte-load: exception caught!" cr
  77   then
  78
  79   s" fcode-debug?" evaluate if
  80     depth r@ <> if
  81       cr ." byte-load: warning stack overflow, diff " depth r@ - . cr
  82     then
  83   then
  84
  85   r> depth! 3drop 3drop
  86
  87   free-fcode-table
  88
  89   \ restore state
  90   fcode-pop-state
  91 ;