![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to table.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 / device|
Return to table.fs CVS log | Up to [Qemu by Fabrice Bellard] / qemu / roms / openbios / forth / device |
1.1 root 1: \ tag: FCode table setup
2: \
3: \ this code implements an fcode evaluator
4: \ as described in IEEE 1275-1994
5: \
6: \ Copyright (C) 2003 Stefan Reinauer
7: \
8: \ See the file "COPYING" for further information about
9: \ the copyright and warranty status of this work.
10: \
11:
12: hex
13:
14: : undefined-fcode ." undefined fcode word." cr ;
15: : reserved-fcode ." reserved fcode word." cr ;
16:
17: : ['], ( <word> -- )
18: ' ,
19: ;
20:
21: : n['], ( n <word> -- )
22: ' swap 0 do
23: dup ,
24: loop
25: drop
26: ;
27:
28: \ the table used
29: create fcode-master-table
30: ['], end0
31: f n['], reserved-fcode
32: ['], b(lit)
33: ['], b(')
34: ['], b(")
35: ['], bbranch
36: ['], b?branch
37: ['], b(loop)
38: ['], b(+loop)
39: ['], b(do)
40: ['], b(?do)
41: ['], i
42: ['], j
43: ['], b(leave)
44: ['], b(of)
45: ['], execute
46: ['], +
47: ['], -
48: ['], *
49: ['], /
50: ['], mod
51: ['], and
52: ['], or
53: ['], xor
54: ['], invert
55: ['], lshift
56: ['], rshift
57: ['], >>a
58: ['], /mod
59: ['], u/mod
60: ['], negate
61: ['], abs
62: ['], min
63: ['], max
64: ['], >r
65: ['], r>
66: ['], r@
67: ['], exit
68: ['], 0=
69: ['], 0<>
70: ['], 0<
71: ['], 0<=
72: ['], 0>
73: ['], 0>=
74: ['], <
75: ['], >
76: ['], =
77: ['], <>
78: ['], u>
79: ['], u<=
80: ['], u<
81: ['], u>=
82: ['], >=
83: ['], <=
84: ['], between
85: ['], within
86: ['], drop
87: ['], dup
88: ['], over
89: ['], swap
90: ['], rot
91: ['], -rot
92: ['], tuck
93: ['], nip
94: ['], pick
95: ['], roll
96: ['], ?dup
97: ['], depth
98: ['], 2drop
99: ['], 2dup
100: ['], 2over
101: ['], 2swap
102: ['], 2rot
103: ['], 2/
104: ['], u2/
105: ['], 2*
106: ['], /c
107: ['], /w
108: ['], /l
109: ['], /n
110: ['], ca+
111: ['], wa+
112: ['], la+
113: ['], na+
114: ['], char+
115: ['], wa1+
116: ['], la1+
117: ['], cell+
118: ['], chars
119: ['], /w*
120: ['], /l*
121: ['], cells
122: ['], on
123: ['], off
124: ['], +!
125: ['], @
126: ['], l@
127: ['], w@
128: ['], <w@
129: ['], c@
130: ['], !
131: ['], l!
132: ['], w!
133: ['], c!
134: ['], 2@
135: ['], 2!
136: ['], move
137: ['], fill
138: ['], comp
139: ['], noop
140: ['], lwsplit
141: ['], wljoin
142: ['], lbsplit
143: ['], bljoin
144: ['], wbflip
145: ['], upc
146: ['], lcc
147: ['], pack
148: ['], count
149: ['], body>
150: ['], >body
151: ['], fcode-revision
152: ['], span
153: ['], unloop
154: ['], expect
155: ['], alloc-mem
156: ['], free-mem
157: ['], key?
158: ['], key
159: ['], emit
160: ['], type
161: ['], (cr
162: ['], cr
163: ['], #out
164: ['], #line
165: ['], hold
166: ['], <#
167: ['], u#>
168: ['], sign
169: ['], u#
170: ['], u#s
171: ['], u.
172: ['], u.r
173: ['], .
174: ['], .r
175: ['], .s
176: ['], base
177: ['], convert \ reserved (compatibility)
178: ['], $number
179: ['], digit
180: ['], -1
181: ['], 0
182: ['], 1
183: ['], 2
184: ['], 3
185: ['], bl
186: ['], bs
187: ['], bell
188: ['], bounds
189: ['], here
190: ['], aligned
191: ['], wbsplit
192: ['], bwjoin
193: ['], b(<mark)
194: ['], b(>resolve)
195: ['], set-token-table
196: ['], set-table
197: ['], new-token
198: ['], named-token
199: ['], b(:)
200: ['], b(value)
201: ['], b(variable)
202: ['], b(constant)
203: ['], b(create)
204: ['], b(defer)
205: ['], b(buffer:)
206: ['], b(field)
207: ['], b(code)
208: ['], instance
209: ['], reserved-fcode
210: ['], b(;)
211: ['], b(to)
212: ['], b(case)
213: ['], b(endcase)
214: ['], b(endof)
215: ['], #
216: ['], #s
217: ['], #>
218: ['], external-token
219: ['], $find
220: ['], offset16
221: ['], evaluate
222: ['], reserved-fcode
223: ['], reserved-fcode
224: ['], c,
225: ['], w,
226: ['], l,
227: ['], ,
228: ['], um*
229: ['], um/mod
230: ['], reserved-fcode
231: ['], reserved-fcode
232: ['], d+
233: ['], d-
234: ['], get-token
235: ['], set-token
236: ['], state
237: ['], compile,
238: ['], behavior
239: 11 n['], reserved-fcode
240: ['], start0
241: ['], start1
242: ['], start2
243: ['], start4
244: 8 n['], reserved-fcode
245: ['], ferror
246: ['], version1
247: ['], 4-byte-id
248: ['], end1
249: ['], reserved-fcode
250: ['], dma-alloc
251: ['], my-address
252: ['], my-space
253: ['], memmap
254: ['], free-virtual
255: ['], >physical
256: 8 n['], reserved-fcode
257: ['], my-params
258: ['], property
259: ['], encode-int
260: ['], encode+
261: ['], encode-phys
262: ['], encode-string
263: ['], encode-bytes
264: ['], reg
265: ['], intr
266: ['], driver
267: ['], model
268: ['], device-type
269: ['], parse-2int
270: ['], is-install
271: ['], is-remove
272: ['], is-selftest
273: ['], new-device
274: ['], diagnostic-mode?
275: ['], display-status
276: ['], memory-test-suite
277: ['], group-code
278: ['], mask
279: ['], get-msecs
280: ['], ms
281: ['], finish-device
282: ['], decode-phys \ 128
283: ['], push-package
284: ['], pop-package
285: ['], interpose \ extension (recommended practice)
286: 4 n['], reserved-fcode
287: ['], map-low
288: ['], sbus-intr>cpu
289: 1e n['], reserved-fcode
290: ['], #lines
291: ['], #columns
292: ['], line#
293: ['], column#
294: ['], inverse?
295: ['], inverse-screen?
296: ['], frame-buffer-busy?
297: ['], draw-character
298: ['], reset-screen
299: ['], toggle-cursor
300: ['], erase-screen
301: ['], blink-screen
302: ['], invert-screen
303: ['], insert-characters
304: ['], delete-characters
305: ['], insert-lines
306: ['], delete-lines
307: ['], draw-logo
308: ['], frame-buffer-adr
309: ['], screen-height
310: ['], screen-width
311: ['], window-top
312: ['], window-left
313: 3 n['], reserved-fcode
314: ['], default-font
315: ['], set-font
316: ['], char-height
317: ['], char-width
318: ['], >font
319: ['], fontbytes
320: 10 n['], reserved-fcode \ fb1 words
321: ['], fb8-draw-character
322: ['], fb8-reset-screen
323: ['], fb8-toggle-cursor
324: ['], fb8-erase-screen
325: ['], fb8-blink-screen
326: ['], fb8-invert-screen
327: ['], fb8-insert-characters
328: ['], fb8-delete-characters
329: ['], fb8-insert-lines
330: ['], fb8-delete-lines
331: ['], fb8-draw-logo
332: ['], fb8-install
333: 4 n['], reserved-fcode \ reserved
334: 7 n['], reserved-fcode \ VME-bus support
335: 9 n['], reserved-fcode \ reserved
336: ['], return-buffer
337: ['], xmit-packet
338: ['], poll-packet
339: ['], reserved-fcode
340: ['], mac-address
341: 5c n['], reserved-fcode \ 1a5-200 reserved
342: ['], device-name
343: ['], my-args
344: ['], my-self
345: ['], find-package
346: ['], open-package
347: ['], close-package
348: ['], find-method
349: ['], call-package
350: ['], $call-parent
351: ['], my-parent
352: ['], ihandle>phandle
353: ['], reserved-fcode
354: ['], my-unit
355: ['], $call-method
356: ['], $open-package
357: ['], processor-type
358: ['], firmware-version
359: ['], fcode-version
360: ['], alarm
361: ['], (is-user-word)
362: ['], suspend-fcode
363: ['], abort
364: ['], catch
365: ['], throw
366: ['], user-abort
367: ['], get-my-property
368: ['], decode-int
369: ['], decode-string
370: ['], get-inherited-property
371: ['], delete-property
372: ['], get-package-property
373: ['], cpeek
374: ['], wpeek
375: ['], lpeek
376: ['], cpoke
377: ['], wpoke
378: ['], lpoke
379: ['], lwflip
380: ['], lbflip
381: ['], lbflips
382: ['], adr-mask
383: 4 n['], reserved-fcode \ 22a-22d
384: 64bit? [IF]
385: ['], (rx@)
386: ['], (rx!)
387: [ELSE]
388: 2 n['], reserved-fcode \ 22e-22f
389: [THEN]
390: ['], rb@
391: ['], rb!
392: ['], rw@
393: ['], rw!
394: ['], rl@
395: ['], rl!
396: ['], wbflips
397: ['], lwflips
398: ['], probe
399: ['], probe-virtual
400: ['], reserved-fcode
401: ['], child
402: ['], peer
403: ['], next-property
404: ['], byte-load
405: ['], set-args
406: ['], left-parse-string \ 240
407: 64bit? [IF]
408: ['], bxjoin
409: ['], <l@
410: ['], lxjoin
411: ['], wxjoin
412: ['], x,
413: ['], x@
414: ['], x!
415: ['], /x
416: ['], /x*
417: \ ['], /xa+
418: \ ['], /xa1+
419: ['], xbflip
420: ['], xbflips
421: ['], xbsplit
422: ['], xlflip
423: ['], xlflips
424: ['], xlsplit
425: ['], xwflip
426: ['], xwflips
427: ['], xwsplit
428: [ELSE]
429: 7 n['], reserved-fcode \ 241-247 (Part of IEEE1275 64-bit draft standard)
430: ['], /x
431: c n['], reserved-fcode \ 249-254 (Part of IEEE1275 64-bit draft standard)
432: [THEN]
433:
434:
435: here fcode-master-table - constant fcode-master-table-size
436:
437:
438: : nreserved ( fcode-table-ptr first last xt -- )
439: -rot 1+ swap do
440: 2dup swap i cells + !
441: loop
442: 2drop
443: ;
444:
445: :noname
446: 800 cells alloc-mem to fcode-sys-table
447:
448: fcode-sys-table
449: dup 0 5ff ['] reserved-fcode nreserved \ built-in fcodes
450: dup 600 7ff ['] undefined-fcode nreserved \ vendor fcodes
451:
452: \ copy built-in fcodes
453: fcode-master-table swap fcode-master-table-size move
454: ; initializer
455:
456: : (init-fcode-table) ( -- )
457: fcode-sys-table fcode-table 800 cells move
458: \ clear local fcodes
459: fcode-table 800 fff ['] undefined-fcode nreserved
460: ;
461:
462: ['] (init-fcode-table) to init-fcode-table
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.