\ 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 ( -- ) ?fcode-offset16 fcode-spread fcode-table fcode-headers? fcode-stream-start fcode-stream fcode-end @ ['] fcode-c@ behavior ; : fcode-pop-state ( -- ) 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(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 | -- ) \ End a case (multiple selection) statement. : b(endcase) postpone endcase ; immediate \ b(of) ( sel of-val -- sel | ) \ 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