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
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
|
\ tag: forth interpreter
\
\ Copyright (C) 2003 Stefan Reinauer
\
\ See the file "COPYING" for further information about
\ the copyright and warranty status of this work.
\
\
\ 7.3.4.6 Display pause
\
0 value interactive?
0 value terminate?
: exit?
interactive? 0= if
false exit
then
false \ FIXME we should check whether to interrupt output
\ and ask the user how to proceed.
;
\
\ 7.3.9.1 Defining words
\
: forget
s" This word is obsolescent." type cr
['] ' execute
cell - dup
@ dup
last ! latest !
here!
;
\
\ 7.3.9.2.4 Miscellaneous dictionary
\
\ interpreter. This word checks whether the interpreted word
\ is a word in dictionary or a number. It honours compile mode
\ and immediate/compile-only words.
: interpret
0 >in !
begin
parse-word dup 0> \ was there a word at all?
while
$find
if
dup flags? 0<> state @ 0= or if
execute
else
, \ compile mode && !immediate
then
else \ word is not known. maybe it's a number
2dup $number
if
span @ >in ! \ if we encountered an error, don't continue parsing
type 3a emit
-13 throw
else
-rot 2drop 1 handle-lit
then
then
depth 200 >= if -3 throw then
depth 0< if -4 throw then
rdepth 200 >= if -5 throw then
rdepth 0< if -6 throw then
repeat
2drop
;
: refill ( -- )
ib #ib @ expect 0 >in ! ;
: print-status ( exception -- )
space
?dup if
dup sys-debug \ system debug hook
case
-1 of s" Aborted." type endof
-2 of s" Aborted." type endof
-3 of s" Stack Overflow." type 0 depth! endof
-4 of s" Stack Underflow." type 0 depth! endof
-5 of s" Return Stack Overflow." type endof
-6 of s" Return Stack Underflow." type endof
-13 of s" undefined word." type endof
-15 of s" out of memory." type endof
-21 of s" undefined method." type endof
-22 of s" no such device." type endof
dup s" Exception #" type .
0 state !
endcase
else
state @ 0= if
s" ok"
else
s" compiled"
then
type
then
cr
;
defer status
['] noop ['] status (to)
: print-prompt
status
depth . 3e emit space
;
defer outer-interpreter
:noname
cr
begin
print-prompt
source 0 fill \ clean input buffer
refill
['] interpret catch print-status
terminate?
until
; ['] outer-interpreter (to)
\
\ 7.3.8.5 Other control flow commands
\
: save-source ( -- )
r> \ fetch our caller
ib >r #ib @ >r \ save current input buffer
source-id >r \ and all variables
span @ >r \ associated with it.
>in @ >r
>r \ move back our caller
;
: restore-source ( -- )
r>
r> >in !
r> span !
r> ['] source-id (to)
r> #ib !
r> ['] ib (to)
>r
;
: (evaluate) ( str len -- ??? )
save-source
-1 ['] source-id (to)
dup
#ib ! span !
['] ib (to)
interpret
restore-source
;
: evaluate ( str len -- ?? )
2dup + -rot
over + over do
i c@ dup 0a = swap 0d = or if
i over -
rot >r
(evaluate)
r>
i 1+
then
loop
swap over - (evaluate)
;
: eval evaluate ;
|
