101 lines
2 KiB
Forth
101 lines
2 KiB
Forth
|
\ tag: FCode evaluator
|
||
|
|
\
|
||
|
|
\ this code implements an fcode evaluator
|
||
|
|
\ as described in IEEE 1275-1994
|
||
|
|
\
|
||
|
|
\ Copyright (C) 2003 Stefan Reinauer
|
||
|
|
\
|
||
|
|
\ See the file "COPYING" for further information about
|
||
|
|
\ the copyright and warranty status of this work.
|
||
|
|
\
|
||
|
|
|
||
|
|
defer init-fcode-table
|
||
|
|
|
||
|
|
: alloc-fcode-table
|
||
|
|
4096 cells alloc-mem to fcode-table
|
||
|
|
?fcode-verbose if
|
||
|
|
." fcode-table at 0x" fcode-table . cr
|
||
|
|
then
|
||
|
|
init-fcode-table
|
||
|
|
;
|
||
|
|
|
||
|
|
: free-fcode-table
|
||
|
|
fcode-table 4096 cells free-mem
|
||
|
|
0 to fcode-table
|
||
|
|
;
|
||
|
|
|
||
|
|
: (debug-feval) ( fcode# -- fcode# )
|
||
|
|
\ Address
|
||
|
|
fcode-stream 1 - . ." : "
|
||
|
|
|
||
|
|
\ Indicate if word is compiled
|
||
|
|
state @ 0<> if
|
||
|
|
." (compile) "
|
||
|
|
then
|
||
|
|
dup fcode>xt cell - lfa2name type
|
||
|
|
dup ." [ 0x" . ." ]" cr
|
||
|
|
;
|
||
|
|
|
||
|
|
: (feval) ( -- ?? )
|
||
|
|
begin
|
||
|
|
fcode#
|
||
|
|
?fcode-verbose if
|
||
|
|
(debug-feval)
|
||
|
|
then
|
||
|
|
fcode>xt
|
||
|
|
dup flags? 0<> state @ 0= or if
|
||
|
|
execute
|
||
|
|
else
|
||
|
|
,
|
||
|
|
then
|
||
|
|
fcode-end @ until
|
||
|
|
|
||
|
|
\ If we've executed incorrect FCode we may have reached the end of the FCode
|
||
|
|
\ program but still be in compile mode. Make sure that if this has happened
|
||
|
|
\ then we switch back to immediate mode to prevent internal OpenBIOS errors.
|
||
|
|
tmp-comp-depth @ -1 <> if
|
||
|
|
-1 tmp-comp-depth !
|
||
|
|
tmp-comp-buf @ @ here!
|
||
|
|
0 state !
|
||
|
|
then
|
||
|
|
;
|
||
|
|
|
||
|
|
: byte-load ( addr xt -- )
|
||
|
|
?fcode-verbose if
|
||
|
|
cr ." byte-load: evaluating fcode at 0x" over . cr
|
||
|
|
then
|
||
|
|
|
||
|
|
\ save state
|
||
|
|
>r >r fcode-push-state r> r>
|
||
|
|
|
||
|
|
\ set fcode-c@ defer
|
||
|
|
dup 1 = if drop ['] c@ then \ FIXME: uses c@ rather than rb@ for now...
|
||
|
|
to fcode-c@
|
||
|
|
dup to fcode-stream-start
|
||
|
|
to fcode-stream
|
||
|
|
1 to fcode-spread
|
||
|
|
false to ?fcode-offset16
|
||
|
|
alloc-fcode-table
|
||
|
|
false fcode-end !
|
||
|
|
|
||
|
|
\ protect against stack overflow/underflow
|
||
|
|
0 0 0 0 0 0 depth >r
|
||
|
|
|
||
|
|
['] (feval) catch if
|
||
|
|
cr ." byte-load: exception caught!" cr
|
||
|
|
then
|
||
|
|
|
||
|
|
s" fcode-debug?" evaluate if
|
||
|
|
depth r@ <> if
|
||
|
|
cr ." byte-load: warning stack overflow, diff " depth r@ - . cr
|
||
|
|
then
|
||
|
|
then
|
||
|
|
|
||
|
|
r> depth! 3drop 3drop
|
||
|
|
|
||
|
|
free-fcode-table
|
||
|
|
|
||
|
|
\ restore state
|
||
|
|
fcode-pop-state
|
||
|
|
;
|