diff options
Diffstat (limited to 'qemu/roms/openbios/forth/device/fcode.fs')
| -rw-r--r-- | qemu/roms/openbios/forth/device/fcode.fs | 573 |
1 files changed, 573 insertions, 0 deletions
diff --git a/qemu/roms/openbios/forth/device/fcode.fs b/qemu/roms/openbios/forth/device/fcode.fs new file mode 100644 index 000000000..9083ed0e0 --- /dev/null +++ b/qemu/roms/openbios/forth/device/fcode.fs @@ -0,0 +1,573 @@ +\ 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 |