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
11hex
12
130    value fcode-sys-table \ table with built-in fcodes (0-0x7ff)
14
15true value ?fcode-offset16 \ fcode offsets are 16 instead of 8 bit?
161    value fcode-spread    \ fcode spread (1, 2 or 4)
170    value fcode-table     \ pointer to fcode table
18false value ?fcode-verbose  \ do verbose fcode execution?
19
20defer _fcode-debug?        \ If true, save names for FCodes with headers
21true value fcode-headers?  \ If true, possibly save names for FCodes.
22
230 value fcode-stream-start \ start address of fcode stream
240 value fcode-stream       \ current fcode stream address
25
26variable fcode-end         \ state variable, if true, fcode program terminates.
27defer 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
37164bit? [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
574