![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to interpreter.fs CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [Qemu by Fabrice Bellard] / qemu / roms / openbios / forth / bootstrap|
Return to interpreter.fs CVS log | Up to [Qemu by Fabrice Bellard] / qemu / roms / openbios / forth / bootstrap |
1.1 root 1: \ tag: forth interpreter
2: \
3: \ Copyright (C) 2003 Stefan Reinauer
4: \
5: \ See the file "COPYING" for further information about
6: \ the copyright and warranty status of this work.
7: \
8:
9:
10: \
11: \ 7.3.4.6 Display pause
12: \
13:
14: 0 value interactive?
15: 0 value terminate?
16:
17: : exit?
18: interactive? 0= if
19: false exit
20: then
21: false \ FIXME we should check whether to interrupt output
22: \ and ask the user how to proceed.
23: ;
24:
25:
26: \
27: \ 7.3.9.1 Defining words
28: \
29:
30: : forget
31: s" This word is obsolescent." type cr
32: ['] ' execute
33: cell - dup
34: @ dup
35: last ! latest !
36: here!
37: ;
38:
39: \
40: \ 7.3.9.2.4 Miscellaneous dictionary
41: \
42:
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.
46:
47: : interpret
48: 0 >in !
49: begin
50: parse-word dup 0> \ was there a word at all?
51: while
52: $find
53: if
54: dup flags? 0<> state @ 0= or if
55: execute
56: else
57: , \ compile mode && !immediate
58: then
59: else \ word is not known. maybe it's a number
60: 2dup $number
61: if
62: span @ >in ! \ if we encountered an error, don't continue parsing
63: type 3a emit
64: -13 throw
65: else
66: -rot 2drop 1 handle-lit
67: then
68: then
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
73: repeat
74: 2drop
75: ;
76:
77: : refill ( -- )
78: ib #ib @ expect 0 >in ! ;
79:
80: : print-status ( exception -- )
81: space
82: ?dup if
83: dup sys-debug \ system debug hook
84: case
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 .
96: 0 state !
97: endcase
98: else
99: state @ 0= if
100: s" ok"
101: else
102: s" compiled"
103: then
104: type
105: then
106: cr
107: ;
108:
109: defer status
110: ['] noop ['] status (to)
111:
112: : print-prompt
113: status
114: depth . 3e emit space
115: ;
116:
117: defer outer-interpreter
118: :noname
119: cr
120: begin
121: print-prompt
122: source 0 fill \ clean input buffer
123: refill
124:
125: ['] interpret catch print-status
126: terminate?
127: until
128: ; ['] outer-interpreter (to)
129:
130: \
131: \ 7.3.8.5 Other control flow commands
132: \
133:
134: : save-source ( -- )
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.
139: >in @ >r
140: >r \ move back our caller
141: ;
142:
143: : restore-source ( -- )
144: r>
145: r> >in !
146: r> span !
147: r> ['] source-id (to)
148: r> #ib !
149: r> ['] ib (to)
150: >r
151: ;
152:
153: : (evaluate) ( str len -- ??? )
154: save-source
155: -1 ['] source-id (to)
156: dup
157: #ib ! span !
158: ['] ib (to)
159: interpret
160: restore-source
161: ;
162:
163: : evaluate ( str len -- ?? )
164: 2dup + -rot
165: over + over do
166: i c@ 0a = if
167: i over -
168: (evaluate)
169: i 1+
170: then
171: loop
172: swap over - (evaluate)
173: ;
174:
175: : eval evaluate ;
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.