573 lines
9.4 KiB
Forth
573 lines
9.4 KiB
Forth
\ tag: FCode implementation functions
|
|
\
|
|
\ this code implements IEEE 1275-1994 ch. 5.3.3
|
|
\
|
|
\ Copyright (C) 2003 Stefan Reinauer
|
|
\
|
|
\ See the file "COPYING" for further information about
|
|
\ the copyright and warranty status of this work.
|
|
\
|
|
|
|
hex
|
|
|
|
0 value fcode-sys-table \ table with built-in fcodes (0-0x7ff)
|
|
|
|
true value ?fcode-offset16 \ fcode offsets are 16 instead of 8 bit?
|
|
1 value fcode-spread \ fcode spread (1, 2 or 4)
|
|
0 value fcode-table \ pointer to fcode table
|
|
false value ?fcode-verbose \ do verbose fcode execution?
|
|
|
|
defer _fcode-debug? \ If true, save names for FCodes with headers
|
|
true value fcode-headers? \ If true, possibly save names for FCodes.
|
|
|
|
0 value fcode-stream-start \ start address of fcode stream
|
|
0 value fcode-stream \ current fcode stream address
|
|
|
|
variable fcode-end \ state variable, if true, fcode program terminates.
|
|
defer fcode-c@ \ get byte
|
|
|
|
: fcode-push-state ( -- <state information> )
|
|
?fcode-offset16
|
|
fcode-spread
|
|
fcode-table
|
|
fcode-headers?
|
|
fcode-stream-start
|
|
fcode-stream
|
|
fcode-end @
|
|
['] fcode-c@ behavior
|
|
;
|
|
|
|
: fcode-pop-state ( <state information> -- )
|
|
to fcode-c@
|
|
fcode-end !
|
|
to fcode-stream
|
|
to fcode-stream-start
|
|
to fcode-headers?
|
|
to fcode-table
|
|
to fcode-spread
|
|
to ?fcode-offset16
|
|
;
|
|
|
|
\
|
|
\ fcode access helper functions
|
|
\
|
|
|
|
\ fcode-ptr
|
|
\ convert FCode number to pointer to xt in FCode table.
|
|
|
|
: fcode-ptr ( u16 -- *xt )
|
|
cells
|
|
fcode-table ?dup if + exit then
|
|
|
|
\ we are not parsing fcode at the moment
|
|
dup 800 cells u>= abort" User FCODE# referenced."
|
|
fcode-sys-table +
|
|
;
|
|
|
|
\ fcode>xt
|
|
\ get xt according to an FCode#
|
|
|
|
: fcode>xt ( u16 -- xt )
|
|
fcode-ptr @
|
|
;
|
|
|
|
\ fcode-num8
|
|
\ get 8bit from FCode stream, taking spread into regard.
|
|
|
|
: fcode-num8 ( -- c ) ( F: c -- )
|
|
fcode-stream
|
|
dup fcode-spread + to fcode-stream
|
|
fcode-c@
|
|
;
|
|
|
|
\ fcode-num8-signed ( -- c ) ( F: c -- )
|
|
\ get 8bit signed from FCode stream
|
|
|
|
: fcode-num8-signed
|
|
fcode-num8
|
|
dup 80 and 0> if
|
|
ff invert or
|
|
then
|
|
;
|
|
|
|
\ fcode-num16
|
|
\ get 16bit from FCode stream
|
|
|
|
: fcode-num16 ( -- num16 )
|
|
fcode-num8 fcode-num8 swap bwjoin
|
|
;
|
|
|
|
\ fcode-num16-signed ( -- c ) ( F: c -- )
|
|
\ get 16bit signed from FCode stream
|
|
|
|
: fcode-num16-signed
|
|
fcode-num16
|
|
dup 8000 and 0> if
|
|
ffff invert or
|
|
then
|
|
;
|
|
|
|
\ fcode-num32
|
|
\ get 32bit from FCode stream
|
|
|
|
: fcode-num32 ( -- num32 )
|
|
fcode-num8 fcode-num8
|
|
fcode-num8 fcode-num8
|
|
swap 2swap swap bljoin
|
|
;
|
|
|
|
\ fcode#
|
|
\ Get an FCode# from FCode stream
|
|
|
|
: fcode# ( -- fcode# )
|
|
fcode-num8
|
|
dup 1 f between if
|
|
fcode-num8 swap bwjoin
|
|
then
|
|
;
|
|
|
|
\ fcode-offset
|
|
\ get offset from FCode stream.
|
|
|
|
: fcode-offset ( -- offset )
|
|
?fcode-offset16 if
|
|
fcode-num16-signed
|
|
else
|
|
fcode-num8-signed
|
|
then
|
|
|
|
\ Display offset in verbose mode
|
|
?fcode-verbose if
|
|
dup ." (offset) " . cr
|
|
then
|
|
;
|
|
|
|
\ fcode-string
|
|
\ get a string from FCode stream, store in pocket.
|
|
|
|
: fcode-string ( -- addr len )
|
|
pocket dup
|
|
fcode-num8
|
|
dup rot c!
|
|
2dup bounds ?do
|
|
fcode-num8 i c!
|
|
loop
|
|
|
|
\ Display string in verbose mode
|
|
?fcode-verbose if
|
|
2dup ." (const) " type cr
|
|
then
|
|
;
|
|
|
|
\ fcode-header
|
|
\ retrieve FCode header from FCode stream
|
|
|
|
: fcode-header
|
|
fcode-num8
|
|
fcode-num16
|
|
fcode-num32
|
|
?fcode-verbose if
|
|
." Found FCode header:" cr rot
|
|
." Format : " u. cr swap
|
|
." Checksum : " u. cr
|
|
." Length : " u. cr
|
|
else
|
|
3drop
|
|
then
|
|
\ TODO checksum
|
|
;
|
|
|
|
\ writes currently created word as fcode# read from stream
|
|
\
|
|
|
|
: fcode! ( F:FCode# -- )
|
|
here fcode#
|
|
|
|
\ Display fcode# in verbose mode
|
|
?fcode-verbose if
|
|
dup ." (fcode#) " . cr
|
|
then
|
|
fcode-ptr !
|
|
;
|
|
|
|
|
|
\
|
|
\ 5.3.3.1 Defining new FCode functions.
|
|
\
|
|
|
|
\ instance ( -- )
|
|
\ Mark next defining word as instance specific.
|
|
\ (defined in bootstrap.fs)
|
|
|
|
\ instance-init ( wid buffer -- )
|
|
\ Copy template from specified wordlist to instance
|
|
\
|
|
|
|
: instance-init
|
|
swap
|
|
begin @ dup 0<> while
|
|
dup /n + @ instance-cfa? if \ buffer dict
|
|
2dup 2 /n* + @ + \ buffer dict dest
|
|
over 3 /n* + @ \ buffer dict dest size
|
|
2 pick 4 /n* + \ buffer dict dest size src
|
|
-rot
|
|
move
|
|
then
|
|
repeat
|
|
2drop
|
|
;
|
|
|
|
|
|
\ new-token ( F:/FCode#/ -- )
|
|
\ Create a new unnamed FCode function
|
|
|
|
: new-token
|
|
0 0 header
|
|
fcode!
|
|
;
|
|
|
|
|
|
\ named-token (F:FCode-string FCode#/ -- )
|
|
\ Create a new possibly named FCode function.
|
|
|
|
: named-token
|
|
fcode-string
|
|
_fcode-debug? not if
|
|
2drop 0 0
|
|
then
|
|
header
|
|
fcode!
|
|
;
|
|
|
|
|
|
\ external-token (F:/FCode-string FCode#/ -- )
|
|
\ Create a new named FCode function
|
|
|
|
: external-token
|
|
fcode-string header
|
|
fcode!
|
|
;
|
|
|
|
|
|
\ b(;) ( -- )
|
|
\ End an FCode colon definition.
|
|
|
|
: b(;)
|
|
['] ; execute
|
|
; immediate
|
|
|
|
|
|
\ b(:) ( -- ) ( E: ... -- ??? )
|
|
\ Defines type of new FCode function as colon definition.
|
|
|
|
: b(:)
|
|
1 , ]
|
|
;
|
|
|
|
|
|
\ b(buffer:) ( size -- ) ( E: -- a-addr )
|
|
\ Defines type of new FCode function as buffer:.
|
|
|
|
: b(buffer:)
|
|
4 , allot
|
|
reveal
|
|
;
|
|
|
|
\ b(constant) ( nl -- ) ( E: -- nl )
|
|
\ Defines type of new FCode function as constant.
|
|
|
|
: b(constant)
|
|
3 , ,
|
|
reveal
|
|
;
|
|
|
|
|
|
\ b(create) ( -- ) ( E: -- a-addr )
|
|
\ Defines type of new FCode function as create word.
|
|
|
|
: b(create)
|
|
6 ,
|
|
['] noop ,
|
|
reveal
|
|
;
|
|
|
|
|
|
\ b(defer) ( -- ) ( E: ... -- ??? )
|
|
\ Defines type of new FCode function as defer word.
|
|
|
|
: b(defer)
|
|
5 ,
|
|
['] (undefined-defer) ,
|
|
['] (semis) ,
|
|
reveal
|
|
;
|
|
|
|
|
|
\ b(field) ( offset size -- offset+size ) ( E: addr -- addr+offset )
|
|
\ Defines type of new FCode function as field.
|
|
|
|
: b(field)
|
|
6 ,
|
|
['] noop ,
|
|
reveal
|
|
over ,
|
|
+
|
|
does>
|
|
@ +
|
|
;
|
|
|
|
|
|
\ b(value) ( x -- ) (E: -- x )
|
|
\ Defines type of new FCode function as value.
|
|
|
|
: b(value)
|
|
3 , , reveal
|
|
;
|
|
|
|
|
|
\ b(variable) ( -- ) ( E: -- a-addr )
|
|
\ Defines type of new FCode function as variable.
|
|
|
|
: b(variable)
|
|
4 , 0 ,
|
|
reveal
|
|
;
|
|
|
|
|
|
\ (is-user-word) ( name-str name-len xt -- ) ( E: ... -- ??? )
|
|
\ Create a new named user interface command.
|
|
|
|
: (is-user-word)
|
|
;
|
|
|
|
|
|
\ get-token ( fcode# -- xt immediate? )
|
|
\ Convert FCode number to function execution token.
|
|
|
|
: get-token
|
|
fcode>xt dup immediate?
|
|
;
|
|
|
|
|
|
\ set-token ( xt immediate? fcode# -- )
|
|
\ Assign FCode number to existing function.
|
|
|
|
: set-token
|
|
nip \ TODO we use the xt's immediate state for now.
|
|
fcode-ptr !
|
|
;
|
|
|
|
|
|
|
|
|
|
\
|
|
\ 5.3.3.2 Literals
|
|
\
|
|
|
|
|
|
\ b(lit) ( -- n1 )
|
|
\ Numeric literal FCode. Followed by FCode-num32.
|
|
|
|
64bit? [IF]
|
|
: b(lit)
|
|
fcode-num32 32>64
|
|
state @ if
|
|
['] (lit) , ,
|
|
then
|
|
; immediate
|
|
[ELSE]
|
|
: b(lit)
|
|
fcode-num32
|
|
state @ if
|
|
['] (lit) , ,
|
|
then
|
|
; immediate
|
|
[THEN]
|
|
|
|
|
|
\ b(') ( -- xt )
|
|
\ Function literal FCode. Followed by FCode#
|
|
|
|
: b(')
|
|
fcode# fcode>xt
|
|
state @ if
|
|
['] (lit) , ,
|
|
then
|
|
; immediate
|
|
|
|
|
|
\ b(") ( -- str len )
|
|
\ String literal FCode. Followed by FCode-string.
|
|
|
|
: b(")
|
|
fcode-string
|
|
state @ if
|
|
\ only run handle-text in compile-mode,
|
|
\ otherwise we would waste a pocket.
|
|
handle-text
|
|
then
|
|
; immediate
|
|
|
|
|
|
\
|
|
\ 5.3.3.3 Controlling values and defers
|
|
\
|
|
|
|
\ behavior ( defer-xt -- contents-xt )
|
|
\ defined in bootstrap.fs
|
|
|
|
\ b(to) ( new-value -- )
|
|
\ FCode for setting values and defers. Followed by FCode#.
|
|
|
|
: b(to)
|
|
fcode# fcode>xt
|
|
1 handle-lit
|
|
['] (to)
|
|
state @ if
|
|
,
|
|
else
|
|
execute
|
|
then
|
|
; immediate
|
|
|
|
|
|
|
|
\
|
|
\ 5.3.3.4 Control flow
|
|
\
|
|
|
|
|
|
\ offset16 ( -- )
|
|
\ Makes subsequent FCode-offsets use 16-bit (not 8-bit) form.
|
|
|
|
: offset16
|
|
true to ?fcode-offset16
|
|
;
|
|
|
|
|
|
\ bbranch ( -- )
|
|
\ Unconditional branch FCode. Followed by FCode-offset.
|
|
|
|
: bbranch
|
|
fcode-offset 0< if \ if we jump backwards, we can forsee where it goes
|
|
['] dobranch ,
|
|
resolve-dest
|
|
execute-tmp-comp
|
|
else
|
|
setup-tmp-comp ['] dobranch ,
|
|
here 0
|
|
0 ,
|
|
2swap
|
|
then
|
|
; immediate
|
|
|
|
|
|
\ b?branch ( continue? -- )
|
|
\ Conditional branch FCode. Followed by FCode-offset.
|
|
|
|
: b?branch
|
|
fcode-offset 0< if \ if we jump backwards, we can forsee where it goes
|
|
['] do?branch ,
|
|
resolve-dest
|
|
execute-tmp-comp
|
|
else
|
|
setup-tmp-comp ['] do?branch ,
|
|
here 0
|
|
0 ,
|
|
then
|
|
; immediate
|
|
|
|
|
|
\ b(<mark) ( -- )
|
|
\ Target of backward branches.
|
|
|
|
: b(<mark)
|
|
setup-tmp-comp
|
|
here 1
|
|
; immediate
|
|
|
|
|
|
\ b(>resolve) ( -- )
|
|
\ Target of forward branches.
|
|
|
|
: b(>resolve)
|
|
resolve-orig
|
|
execute-tmp-comp
|
|
; immediate
|
|
|
|
|
|
\ b(loop) ( -- )
|
|
\ End FCode do..loop. Followed by FCode-offset.
|
|
|
|
: b(loop)
|
|
fcode-offset drop
|
|
postpone loop
|
|
; immediate
|
|
|
|
|
|
\ b(+loop) ( delta -- )
|
|
\ End FCode do..+loop. Followed by FCode-offset.
|
|
|
|
: b(+loop)
|
|
fcode-offset drop
|
|
postpone +loop
|
|
; immediate
|
|
|
|
|
|
\ b(do) ( limit start -- )
|
|
\ Begin FCode do..loop. Followed by FCode-offset.
|
|
|
|
: b(do)
|
|
fcode-offset drop
|
|
postpone do
|
|
; immediate
|
|
|
|
|
|
\ b(?do) ( limit start -- )
|
|
\ Begin FCode ?do..loop. Followed by FCode-offset.
|
|
|
|
: b(?do)
|
|
fcode-offset drop
|
|
postpone ?do
|
|
; immediate
|
|
|
|
|
|
\ b(leave) ( -- )
|
|
\ Exit from a do..loop.
|
|
|
|
: b(leave)
|
|
postpone leave
|
|
; immediate
|
|
|
|
|
|
\ b(case) ( sel -- sel )
|
|
\ Begin a case (multiple selection) statement.
|
|
|
|
: b(case)
|
|
postpone case
|
|
; immediate
|
|
|
|
|
|
\ b(endcase) ( sel | <nothing> -- )
|
|
\ End a case (multiple selection) statement.
|
|
|
|
: b(endcase)
|
|
postpone endcase
|
|
; immediate
|
|
|
|
|
|
\ b(of) ( sel of-val -- sel | <nothing> )
|
|
\ FCode for of in case statement. Followed by FCode-offset.
|
|
|
|
: b(of)
|
|
fcode-offset drop
|
|
postpone of
|
|
; immediate
|
|
|
|
\ b(endof) ( -- )
|
|
\ FCode for endof in case statement. Followed by FCode-offset.
|
|
|
|
: b(endof)
|
|
fcode-offset drop
|
|
postpone endof
|
|
; immediate
|