--- /dev/null
+\ 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
Code Review / kvmfornfv.git / blobdiff