![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to 1275.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 / SLOF / slof / fs / fcode|
Return to 1275.fs CVS log | Up to [Qemu by Fabrice Bellard] / qemu / roms / SLOF / slof / fs / fcode |
1.1 root 1: \ *****************************************************************************
2: \ * Copyright (c) 2004, 2008 IBM Corporation
3: \ * All rights reserved.
4: \ * This program and the accompanying materials
5: \ * are made available under the terms of the BSD License
6: \ * which accompanies this distribution, and is available at
7: \ * http://www.opensource.org/licenses/bsd-license.php
8: \ *
9: \ * Contributors:
10: \ * IBM Corporation - initial implementation
11: \ ****************************************************************************/
12:
13: 0 value function-type ' function-type @ constant <value>
14: variable function-type ' function-type @ constant <variable>
15: 0 constant function-type ' function-type @ constant <constant>
16: : function-type ; ' function-type @ constant <colon>
17: create function-type ' function-type @ constant <create>
18: defer function-type ' function-type @ constant <defer>
19:
20: \ variable tmp-buf-current
21: \ variable orig-here
22: \ create tmp-buf 10000 allot
23:
24: ( ---------------------------------------------------- )
25:
26: : fcode-revision ( -- n )
27: 00030000 \ major * 65536 + minor
28: ;
29:
30: : b(lit) ( -- n )
31: next-ip read-fcode-num32
32: ?compile-mode IF literal, THEN
33: ;
34:
35: : b(")
36: next-ip read-fcode-string
37: ?compile-mode IF fc-string, align postpone count THEN
38: ;
39:
40: : b(')
41: next-ip read-fcode# get-token drop ?compile-mode IF literal, THEN
42: ;
43:
44: : ?jump-direction ( n -- )
45: dup 8000 >= IF FFFF swap - negate 2- THEN
46: ;
47:
48: : ?negative
49: 8000 and
50: ;
51:
52: : dest-on-top
53: 0 >r BEGIN dup @ 0= WHILE >r REPEAT
54: BEGIN r> dup WHILE swap REPEAT
55: drop
56: ;
57:
58: : ?branch
59: true =
60: ;
61:
62: : read-fcode-offset \ ELSE needs to be fixed!
63: ?offset16 IF next-ip read-fcode-num16 ELSE THEN
64: ;
65:
66: : b?branch ( flag -- )
67: ?compile-mode IF
68: read-fcode-offset ?negative IF dest-on-top postpone until
69: ELSE postpone if
70: THEN
71: ELSE
72: ?branch IF 2 jump-n-ip
73: ELSE read-fcode-offset
74: ?jump-direction 2- jump-n-ip
75: THEN
76: THEN
77: ; immediate
78:
79: : bbranch ( -- )
80: ?compile-mode IF
81: read-fcode-offset
82: ?negative IF dest-on-top postpone again
83: ELSE postpone else
84: get-ip next-ip fcode@ B2 = IF drop ELSE set-ip THEN
85: THEN
86: ELSE
87: read-fcode-offset ?jump-direction 2- jump-n-ip
88: THEN
89: ; immediate
90:
91: : b(<mark) ( -- )
92: ?compile-mode IF postpone begin THEN
93: ; immediate
94:
95: : b(>resolve) ( -- )
96: ?compile-mode IF postpone then THEN
97: ; immediate
98:
99: : ffwto; ( -- )
100: BEGIN fcode@ dup c2 <> WHILE
101: ." ffwto: skipping " dup . ." @ " get-ip . cr
102: CASE 10 OF ( lit ) read-fcode-num32 drop ENDOF
103: 11 OF ( ' ) read-fcode# drop ENDOF
104: 12 OF ( " ) read-fcode-string 2drop ENDOF
105: 13 OF ( bbranch ) read-fcode-offset drop ENDOF
106: 14 OF ( b?branch ) read-fcode-offset drop ENDOF
107: 15 OF ( loop ) read-fcode-offset drop ENDOF
108: 16 OF ( +loop ) read-fcode-offset drop ENDOF
109: 17 OF ( do ) read-fcode-offset drop ENDOF
110: 18 OF ( ?do ) read-fcode-offset drop ENDOF
111: 1C OF ( of ) read-fcode-offset drop ENDOF
112: C6 OF ( endof ) read-fcode-offset drop ENDOF
113: C3 OF ( to ) read-fcode# drop ENDOF
114: dup OF next-ip ENDOF
115: ENDCASE
116: REPEAT next-ip
117: ;
118:
119: : rpush ( rparm -- ) \ push the rparm to be on top of return stack after exit
120: r> swap >r >r
121: ;
122:
123: : rpop ( -- rparm ) \ pop the rparm that was on top of return stack before this
124: r> r> swap >r
125: ;
126:
127: : b1(;) ( -- )
128: ." b1(;)" cr
129: rpop set-ip
130: ;
131:
132: \ : b1(:) ( -- )
133: \ ." b1(:)" cr
134: \ <colon> compile, get-ip 1+ literal ] get-ip rpush set-ip [
135: \ ffwto;
136: \ ; immediate
137:
138: : b(;) ( -- )
139: postpone exit reveal postpone [
140: ; immediate
141:
142: : b(:) ( -- )
143: <colon> compile, ]
144: ; immediate
145:
146: : b(case) ( sel -- sel )
147: postpone case
148: ; immediate
149:
150: : b(endcase)
151: postpone endcase
152: ; immediate
153:
154: : b(of)
155: postpone of
156: read-fcode-offset drop \ read and discard offset
157: ; immediate
158:
159: : b(endof)
160: postpone endof
161: read-fcode-offset drop
162: ; immediate
163:
164: : b(do)
165: postpone do
166: read-fcode-offset drop
167: ; immediate
168:
169: : b(?do)
170: postpone ?do
171: read-fcode-offset drop
172: ; immediate
173:
174: : b(loop)
175: postpone loop
176: read-fcode-offset drop
177: ; immediate
178:
179: : b(+loop)
180: postpone +loop
181: read-fcode-offset drop
182: ; immediate
183:
184: : b(leave)
185: postpone leave
186: ; immediate
187:
188: : new-token \ unnamed local fcode function
189: align here next-ip read-fcode# 0 swap set-token
190: ;
191:
192: : external-token ( -- ) \ named local fcode function
193: next-ip read-fcode-string
194: header ( str len -- ) \ create a header in the current dictionary entry
195: new-token
196: ;
197:
198: : new-token
199: eva-debug? IF
200: s" x" get-ip >r next-ip read-fcode# r> set-ip (u.) $cat strdup
201: header
202: THEN new-token
203: ;
204:
205: : named-token \ decide wether or not to give a new token an own name in the dictionary
206: fcode-debug? IF new-token ELSE external-token THEN
207: ;
208:
209: : b(to) ( x -- )
210: next-ip read-fcode#
211: get-token drop
212: >body cell -
213: ?compile-mode IF literal, postpone ! ELSE ! THEN
214: ; immediate
215:
216: : b(value)
217: <value> , , reveal
218: ;
219:
220: : b(variable)
221: <variable> , 0 , reveal
222: ;
223:
224: : b(constant)
225: <constant> , , reveal
226: ;
227:
228: : undefined-defer
229: cr cr ." Unititialized defer word has been executed!" cr cr
230: true fcode-end !
231: ;
232:
233: : b(defer)
234: <defer> , reveal
235: postpone undefined-defer
236: ;
237:
238: : b(create)
239: <variable> ,
240: postpone noop reveal
241: ;
242:
243: : b(field) ( E: addr -- addr+offset ) ( F: offset size -- offset+size )
244: <colon> , over literal,
245: postpone + postpone exit
246: +
247: ;
248:
249: : b(buffer:) ( E: -- a-addr) ( F: size -- )
250: <variable> , allot
251: ;
252:
253: : suspend-fcode ( -- )
254: noop \ has to be implemented more efficiently ;-)
255: ;
256:
257: : offset16 ( -- )
258: 16 to fcode-offset
259: ;
260:
261: : version1 ( -- )
262: 1 to fcode-spread
263: 8 to fcode-offset
264: read-header
265: ;
266:
267: : start0 ( -- )
268: 0 to fcode-spread
269: offset16
270: read-header
271: ;
272:
273: : start1 ( -- )
274: 1 to fcode-spread
275: offset16
276: read-header
277: ;
278:
279: : start2 ( -- )
280: 2 to fcode-spread
281: offset16
282: read-header
283: ;
284:
285: : start4 ( -- )
286: 4 to fcode-spread
287: offset16
288: read-header
289: ;
290:
291: : end0 ( -- )
292: true fcode-end !
293: ;
294:
295: : end1 ( -- )
296: end0
297: ;
298:
299: : ferror ( -- )
300: clear end0
301: cr ." FCode# " fcode-num @ . ." not assigned!"
302: cr ." FCode evaluation aborted." cr
303: ." ( -- S:" depth . ." R:" rdepth . ." ) " .s cr
304: abort
305: ;
306:
307: : reset-local-fcodes
308: FFF 800 DO ['] ferror 0 i set-token LOOP
309: ;
310:
311: : byte-load ( addr xt -- )
312: >r >r
313: save-evaluator-state
314: r> r>
315: reset-fcode-end
316: 1 to fcode-spread
317: dup 1 = IF drop ['] rb@ THEN to fcode-rb@
318: set-ip
319: reset-local-fcodes
320: depth >r
321: evaluate-fcode
322: r> depth 1- <> IF clear end0
323: cr ." Ambiguous stack depth after byte-load!"
324: cr ." FCode evaluation aborted." cr cr
325: ELSE restore-evaluator-state
326: THEN
327: ['] c@ to fcode-rb@
328: ;
329:
330: create byte-load-test-fcode
331: f1 c, 08 c, 18 c, 69 c, 00 c, 00 c, 00 c, 68 c,
332: 12 c, 16 c, 62 c, 79 c, 74 c, 65 c, 2d c, 6c c,
333: 6f c, 61 c, 64 c, 2d c, 74 c, 65 c, 73 c, 74 c,
334: 2d c, 66 c, 63 c, 6f c, 64 c, 65 c, 21 c, 21 c,
335: 90 c, 92 c, ( a6 c, a7 c, 2e c, ) 00 c,
336:
337: : byte-load-test
338: byte-load-test-fcode ['] w@
339: ; immediate
340:
341: : fcode-ms
342: s" ms" $find IF 0= IF compile, ELSE execute THEN THEN ; immediate
343:
344: : fcode-$find
345: $find
346: IF
347: drop true
348: ELSE
349: false
350: THEN
351: ;
352:
353: ( ---------------------------------------------------- )
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.