1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
|
\ 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
;
: 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
depth r@ <> if
cr ." byte-load: stack overflow, diff " depth r@ - . cr
then
r> depth! 3drop 3drop
free-fcode-table
\ restore state
fcode-pop-state
;
|
