1 \ tag: forth interpreter
3 \ Copyright (C) 2003 Stefan Reinauer
5 \ See the file "COPYING" for further information about
6 \ the copyright and warranty status of this work.
11 \ 7.3.4.6 Display pause
21 false \ FIXME we should check whether to interrupt output
22 \ and ask the user how to proceed.
27 \ 7.3.9.1 Defining words
31 s" This word is obsolescent." type cr
40 \ 7.3.9.2.4 Miscellaneous dictionary
43 \ interpreter. This word checks whether the interpreted word
44 \ is a word in dictionary or a number. It honours compile mode
45 \ and immediate/compile-only words.
50 parse-word dup 0> \ was there a word at all?
54 dup flags? 0<> state @ 0= or if
57 , \ compile mode && !immediate
59 else \ word is not known. maybe it's a number
62 span @ >in ! \ if we encountered an error, don't continue parsing
66 -rot 2drop 1 handle-lit
69 depth 200 >= if -3 throw then
70 depth 0< if -4 throw then
71 rdepth 200 >= if -5 throw then
72 rdepth 0< if -6 throw then
78 ib #ib @ expect 0 >in ! ;
80 : print-status ( exception -- )
83 dup sys-debug \ system debug hook
85 -1 of s" Aborted." type endof
86 -2 of s" Aborted." type endof
87 -3 of s" Stack Overflow." type 0 depth! endof
88 -4 of s" Stack Underflow." type 0 depth! endof
89 -5 of s" Return Stack Overflow." type endof
90 -6 of s" Return Stack Underflow." type endof
91 -13 of s" undefined word." type endof
92 -15 of s" out of memory." type endof
93 -21 of s" undefined method." type endof
94 -22 of s" no such device." type endof
95 dup s" Exception #" type .
110 ['] noop ['] status (to)
114 depth . 3e emit space
117 defer outer-interpreter
122 source 0 fill \ clean input buffer
125 ['] interpret catch print-status
128 ; ['] outer-interpreter (to)
131 \ 7.3.8.5 Other control flow commands
135 r> \ fetch our caller
136 ib >r #ib @ >r \ save current input buffer
137 source-id >r \ and all variables
138 span @ >r \ associated with it.
140 >r \ move back our caller
143 : restore-source ( -- )
147 r> ['] source-id (to)
153 : (evaluate) ( str len -- ??? )
155 -1 ['] source-id (to)
163 : evaluate ( str len -- ?? )
172 swap over - (evaluate)