![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to fcode.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 fcode.fs CVS log | Up to [Qemu by Fabrice Bellard] / qemu / roms / openbios / forth / device |
1.1 root 1: \ tag: FCode implementation functions
2: \
3: \ this code implements IEEE 1275-1994 ch. 5.3.3
4: \
5: \ Copyright (C) 2003 Stefan Reinauer
6: \
7: \ See the file "COPYING" for further information about
8: \ the copyright and warranty status of this work.
9: \
10:
11: hex
12:
13: 0 value fcode-sys-table \ table with built-in fcodes (0-0x7ff)
14:
15: true value ?fcode-offset16 \ fcode offsets are 16 instead of 8 bit?
16: 1 value fcode-spread \ fcode spread (1, 2 or 4)
17: 0 value fcode-table \ pointer to fcode table
18: false value ?fcode-verbose \ do verbose fcode execution?
19:
20: defer _fcode-debug? \ If true, save names for FCodes with headers
21: true value fcode-headers? \ If true, possibly save names for FCodes.
22:
23: 0 value fcode-stream-start \ start address of fcode stream
24: 0 value fcode-stream \ current fcode stream address
25:
26: variable fcode-end \ state variable, if true, fcode program terminates.
27: defer fcode-c@ \ get byte
28:
29: : fcode-push-state ( -- <state information> )
30: ?fcode-offset16
31: fcode-spread
32: fcode-table
33: fcode-headers?
34: fcode-stream-start
35: fcode-stream
36: fcode-end @
37: ['] fcode-c@ behavior
38: ;
39:
40: : fcode-pop-state ( <state information> -- )
41: to fcode-c@
42: fcode-end !
43: to fcode-stream
44: to fcode-stream-start
45: to fcode-headers?
46: to fcode-table
47: to fcode-spread
48: to ?fcode-offset16
49: ;
50:
51: \
52: \ fcode access helper functions
53: \
54:
55: \ fcode-ptr
56: \ convert FCode number to pointer to xt in FCode table.
57:
58: : fcode-ptr ( u16 -- *xt )
59: cells
60: fcode-table ?dup if + exit then
61:
62: \ we are not parsing fcode at the moment
63: dup 800 cells u>= abort" User FCODE# referenced."
64: fcode-sys-table +
65: ;
66:
67: \ fcode>xt
68: \ get xt according to an FCode#
69:
70: : fcode>xt ( u16 -- xt )
71: fcode-ptr @
72: ;
73:
74: \ fcode-num8
75: \ get 8bit from FCode stream, taking spread into regard.
76:
77: : fcode-num8 ( -- c ) ( F: c -- )
78: fcode-stream
79: dup fcode-spread + to fcode-stream
80: fcode-c@
81: ;
82:
83: \ fcode-num8-signed ( -- c ) ( F: c -- )
84: \ get 8bit signed from FCode stream
85:
86: : fcode-num8-signed
87: fcode-num8
88: dup 80 and 0> if
89: ff invert or
90: then
91: ;
92:
93: \ fcode-num16
94: \ get 16bit from FCode stream
95:
96: : fcode-num16 ( -- num16 )
97: fcode-num8 fcode-num8 swap bwjoin
98: ;
99:
100: \ fcode-num16-signed ( -- c ) ( F: c -- )
101: \ get 16bit signed from FCode stream
102:
103: : fcode-num16-signed
104: fcode-num16
105: dup 8000 and 0> if
106: ffff invert or
107: then
108: ;
109:
110: \ fcode-num32
111: \ get 32bit from FCode stream
112:
113: : fcode-num32 ( -- num32 )
114: fcode-num8 fcode-num8
115: fcode-num8 fcode-num8
116: swap 2swap swap bljoin
117: ;
118:
119: \ fcode#
120: \ Get an FCode# from FCode stream
121:
122: : fcode# ( -- fcode# )
123: fcode-num8
124: dup 1 f between if
125: fcode-num8 swap bwjoin
126: then
127: ;
128:
129: \ fcode-offset
130: \ get offset from FCode stream.
131:
132: : fcode-offset ( -- offset )
133: ?fcode-offset16 if
134: fcode-num16-signed
135: else
136: fcode-num8-signed
137: then
138:
139: \ Display offset in verbose mode
140: ?fcode-verbose if
141: dup ." (offset) " . cr
142: then
143: ;
144:
145: \ fcode-string
146: \ get a string from FCode stream, store in pocket.
147:
148: : fcode-string ( -- addr len )
149: pocket dup
150: fcode-num8
151: dup rot c!
152: 2dup bounds ?do
153: fcode-num8 i c!
154: loop
155:
156: \ Display string in verbose mode
157: ?fcode-verbose if
158: 2dup ." (const) " type cr
159: then
160: ;
161:
162: \ fcode-header
163: \ retrieve FCode header from FCode stream
164:
165: : fcode-header
166: fcode-num8
167: fcode-num16
168: fcode-num32
169: ?fcode-verbose if
170: ." Found FCode header:" cr rot
171: ." Format : " u. cr swap
172: ." Checksum : " u. cr
173: ." Length : " u. cr
174: else
175: 3drop
176: then
177: \ TODO checksum
178: ;
179:
180: \ writes currently created word as fcode# read from stream
181: \
182:
183: : fcode! ( F:FCode# -- )
184: here fcode#
185:
186: \ Display fcode# in verbose mode
187: ?fcode-verbose if
188: dup ." (fcode#) " . cr
189: then
190: fcode-ptr !
191: ;
192:
193:
194: \
195: \ 5.3.3.1 Defining new FCode functions.
196: \
197:
198: \ instance ( -- )
199: \ Mark next defining word as instance specific.
200: \ (defined in bootstrap.fs)
201:
202: \ instance-init ( wid buffer -- )
203: \ Copy template from specified wordlist to instance
204: \
205:
206: : instance-init
207: swap
208: begin @ dup 0<> while
209: dup /n + @ instance-cfa? if \ buffer dict
210: 2dup 2 /n* + @ + \ buffer dict dest
211: over 3 /n* + @ \ buffer dict dest size
212: 2 pick 4 /n* + \ buffer dict dest size src
213: -rot
214: move
215: then
216: repeat
217: 2drop
218: ;
219:
220:
221: \ new-token ( F:/FCode#/ -- )
222: \ Create a new unnamed FCode function
223:
224: : new-token
225: 0 0 header
226: fcode!
227: ;
228:
229:
230: \ named-token (F:FCode-string FCode#/ -- )
231: \ Create a new possibly named FCode function.
232:
233: : named-token
234: fcode-string
235: _fcode-debug? not if
236: 2drop 0 0
237: then
238: header
239: fcode!
240: ;
241:
242:
243: \ external-token (F:/FCode-string FCode#/ -- )
244: \ Create a new named FCode function
245:
246: : external-token
247: fcode-string header
248: fcode!
249: ;
250:
251:
252: \ b(;) ( -- )
253: \ End an FCode colon definition.
254:
255: : b(;)
256: ['] ; execute
257: ; immediate
258:
259:
260: \ b(:) ( -- ) ( E: ... -- ??? )
261: \ Defines type of new FCode function as colon definition.
262:
263: : b(:)
264: 1 , ]
265: ;
266:
267:
268: \ b(buffer:) ( size -- ) ( E: -- a-addr )
269: \ Defines type of new FCode function as buffer:.
270:
271: : b(buffer:)
272: 4 , allot
273: reveal
274: ;
275:
276: \ b(constant) ( nl -- ) ( E: -- nl )
277: \ Defines type of new FCode function as constant.
278:
279: : b(constant)
280: 3 , ,
281: reveal
282: ;
283:
284:
285: \ b(create) ( -- ) ( E: -- a-addr )
286: \ Defines type of new FCode function as create word.
287:
288: : b(create)
289: 6 ,
290: ['] noop ,
291: reveal
292: ;
293:
294:
295: \ b(defer) ( -- ) ( E: ... -- ??? )
296: \ Defines type of new FCode function as defer word.
297:
298: : b(defer)
299: 5 ,
300: ['] (undefined-defer) ,
301: ['] (semis) ,
302: reveal
303: ;
304:
305:
306: \ b(field) ( offset size -- offset+size ) ( E: addr -- addr+offset )
307: \ Defines type of new FCode function as field.
308:
309: : b(field)
310: 6 ,
311: ['] noop ,
312: reveal
313: over ,
314: +
315: does>
316: @ +
317: ;
318:
319:
320: \ b(value) ( x -- ) (E: -- x )
321: \ Defines type of new FCode function as value.
322:
323: : b(value)
324: 3 , , reveal
325: ;
326:
327:
328: \ b(variable) ( -- ) ( E: -- a-addr )
329: \ Defines type of new FCode function as variable.
330:
331: : b(variable)
332: 4 , 0 ,
333: reveal
334: ;
335:
336:
337: \ (is-user-word) ( name-str name-len xt -- ) ( E: ... -- ??? )
338: \ Create a new named user interface command.
339:
340: : (is-user-word)
341: ;
342:
343:
344: \ get-token ( fcode# -- xt immediate? )
345: \ Convert FCode number to function execution token.
346:
347: : get-token
348: fcode>xt dup immediate?
349: ;
350:
351:
352: \ set-token ( xt immediate? fcode# -- )
353: \ Assign FCode number to existing function.
354:
355: : set-token
356: nip \ TODO we use the xt's immediate state for now.
357: fcode-ptr !
358: ;
359:
360:
361:
362:
363: \
364: \ 5.3.3.2 Literals
365: \
366:
367:
368: \ b(lit) ( -- n1 )
369: \ Numeric literal FCode. Followed by FCode-num32.
370:
371: 64bit? [IF]
372: : b(lit)
373: fcode-num32 32>64
374: state @ if
375: ['] (lit) , ,
376: then
377: ; immediate
378: [ELSE]
379: : b(lit)
380: fcode-num32
381: state @ if
382: ['] (lit) , ,
383: then
384: ; immediate
385: [THEN]
386:
387:
388: \ b(') ( -- xt )
389: \ Function literal FCode. Followed by FCode#
390:
391: : b(')
392: fcode# fcode>xt
393: state @ if
394: ['] (lit) , ,
395: then
396: ; immediate
397:
398:
399: \ b(") ( -- str len )
400: \ String literal FCode. Followed by FCode-string.
401:
402: : b(")
403: fcode-string
404: state @ if
405: \ only run handle-text in compile-mode,
406: \ otherwise we would waste a pocket.
407: handle-text
408: then
409: ; immediate
410:
411:
412: \
413: \ 5.3.3.3 Controlling values and defers
414: \
415:
416: \ behavior ( defer-xt -- contents-xt )
417: \ defined in bootstrap.fs
418:
419: \ b(to) ( new-value -- )
420: \ FCode for setting values and defers. Followed by FCode#.
421:
422: : b(to)
423: fcode# fcode>xt
424: 1 handle-lit
425: ['] (to)
426: state @ if
427: ,
428: else
429: execute
430: then
431: ; immediate
432:
433:
434:
435: \
436: \ 5.3.3.4 Control flow
437: \
438:
439:
440: \ offset16 ( -- )
441: \ Makes subsequent FCode-offsets use 16-bit (not 8-bit) form.
442:
443: : offset16
444: true to ?fcode-offset16
445: ;
446:
447:
448: \ bbranch ( -- )
449: \ Unconditional branch FCode. Followed by FCode-offset.
450:
451: : bbranch
452: fcode-offset 0< if \ if we jump backwards, we can forsee where it goes
453: ['] dobranch ,
454: resolve-dest
455: execute-tmp-comp
456: else
457: setup-tmp-comp ['] dobranch ,
458: here 0
459: 0 ,
460: 2swap
461: then
462: ; immediate
463:
464:
465: \ b?branch ( continue? -- )
466: \ Conditional branch FCode. Followed by FCode-offset.
467:
468: : b?branch
469: fcode-offset 0< if \ if we jump backwards, we can forsee where it goes
470: ['] do?branch ,
471: resolve-dest
472: execute-tmp-comp
473: else
474: setup-tmp-comp ['] do?branch ,
475: here 0
476: 0 ,
477: then
478: ; immediate
479:
480:
481: \ b(<mark) ( -- )
482: \ Target of backward branches.
483:
484: : b(<mark)
485: setup-tmp-comp
486: here 1
487: ; immediate
488:
489:
490: \ b(>resolve) ( -- )
491: \ Target of forward branches.
492:
493: : b(>resolve)
494: resolve-orig
495: execute-tmp-comp
496: ; immediate
497:
498:
499: \ b(loop) ( -- )
500: \ End FCode do..loop. Followed by FCode-offset.
501:
502: : b(loop)
503: fcode-offset drop
504: postpone loop
505: ; immediate
506:
507:
508: \ b(+loop) ( delta -- )
509: \ End FCode do..+loop. Followed by FCode-offset.
510:
511: : b(+loop)
512: fcode-offset drop
513: postpone +loop
514: ; immediate
515:
516:
517: \ b(do) ( limit start -- )
518: \ Begin FCode do..loop. Followed by FCode-offset.
519:
520: : b(do)
521: fcode-offset drop
522: postpone do
523: ; immediate
524:
525:
526: \ b(?do) ( limit start -- )
527: \ Begin FCode ?do..loop. Followed by FCode-offset.
528:
529: : b(?do)
530: fcode-offset drop
531: postpone ?do
532: ; immediate
533:
534:
535: \ b(leave) ( -- )
536: \ Exit from a do..loop.
537:
538: : b(leave)
539: postpone leave
540: ; immediate
541:
542:
543: \ b(case) ( sel -- sel )
544: \ Begin a case (multiple selection) statement.
545:
546: : b(case)
547: postpone case
548: ; immediate
549:
550:
551: \ b(endcase) ( sel | <nothing> -- )
552: \ End a case (multiple selection) statement.
553:
554: : b(endcase)
555: postpone endcase
556: ; immediate
557:
558:
559: \ b(of) ( sel of-val -- sel | <nothing> )
560: \ FCode for of in case statement. Followed by FCode-offset.
561:
562: : b(of)
563: fcode-offset drop
564: postpone of
565: ; immediate
566:
567: \ b(endof) ( -- )
568: \ FCode for endof in case statement. Followed by FCode-offset.
569:
570: : b(endof)
571: fcode-offset drop
572: postpone endof
573: ; immediate
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.