diff options
| author |   Yang Zhang <yang.z.zhang@intel.com> | 2015-08-28 09:58:54 +0800 |
|---|---|---|
| committer | Yang Zhang <yang.z.zhang@intel.com> | 2015-09-01 12:44:00 +0800 |
| commit | e44e3482bdb4d0ebde2d8b41830ac2cdb07948fb (patch) | |
| tree | 66b09f592c55df2878107a468a91d21506104d3f /qemu/roms/openbios/forth | |
| parent | 9ca8dbcc65cfc63d6f5ef3312a33184e1d726e00 (diff) | |
Add qemu 2.4.0
Change-Id: Ic99cbad4b61f8b127b7dc74d04576c0bcbaaf4f5
Signed-off-by: Yang Zhang <yang.z.zhang@intel.com>
Diffstat (limited to 'qemu/roms/openbios/forth')
79 files changed, 10929 insertions, 0 deletions
diff --git a/qemu/roms/openbios/forth/Kconfig b/qemu/roms/openbios/forth/Kconfig new file mode 100644 index 000000000..87ff19172 --- /dev/null +++ b/qemu/roms/openbios/forth/Kconfig @@ -0,0 +1,9 @@ +# +# +# + +#menu "Packages" +# +#source "forth/packages/Kconfig" +# +#endmenu diff --git a/qemu/roms/openbios/forth/admin/README b/qemu/roms/openbios/forth/admin/README new file mode 100644 index 000000000..711f7e0e8 --- /dev/null +++ b/qemu/roms/openbios/forth/admin/README @@ -0,0 +1,3 @@ +\ This directory contains code that implements +\ the Administration command group +\ (Chapter 7.4 in the IEEE 1275-1994) diff --git a/qemu/roms/openbios/forth/admin/banner.fs b/qemu/roms/openbios/forth/admin/banner.fs new file mode 100644 index 000000000..5439fc082 --- /dev/null +++ b/qemu/roms/openbios/forth/admin/banner.fs @@ -0,0 +1,49 @@ +\ 7.4.10 Banner + +defer builtin-logo +defer builtin-banner +0 value suppress-banner? + +:noname + 0 0 +; to builtin-logo + +:noname + builddate s" built on " version s" Welcome to OpenBIOS v" pocket + tmpstrcat tmpstrcat tmpstrcat drop +; to builtin-banner + +: suppress-banner ( -- ) + 1 to suppress-banner? +; + +: banner ( -- ) + suppress-banner + stdout @ ?dup 0= if exit then + + \ draw logo if stdout is a "display" node + dup ihandle>phandle " device_type" rot get-package-property if 0 0 then + " display" strcmp if + drop + else + \ draw logo ( ihandle ) + dup ihandle>phandle " draw-logo" rot find-method if + ( ihandle xt ) + swap >r >r + 0 \ line # + oem-logo? if oem-logo else builtin-logo then + ( 0 addr logo-len ) + 200 = if + d# 64 d# 64 + r> r> call-package + else + r> r> 2drop 2drop + then + else + drop + then + then + + oem-banner? if oem-banner else builtin-banner then + type cr +; diff --git a/qemu/roms/openbios/forth/admin/build.xml b/qemu/roms/openbios/forth/admin/build.xml new file mode 100644 index 000000000..665449672 --- /dev/null +++ b/qemu/roms/openbios/forth/admin/build.xml @@ -0,0 +1,25 @@ +<build> + + <!-- + build description for forth administrative command group + + Copyright (C) 2003-2005 by Stefan Reinauer + See the file "COPYING" for further information about + the copyright and warranty status of this work. + --> + + <dictionary name="openbios" target="forth"> + <object source="devices.fs"/> + <object source="nvram.fs"/> + <object source="callback.fs"/> + <object source="help.fs"/> + <object source="iocontrol.fs"/> + <object source="banner.fs"/> + <object source="reset.fs"/> + <object source="script.fs"/> + <object source="security.fs"/> + <object source="selftest.fs"/> + <object source="userboot.fs"/> + </dictionary> + +</build> diff --git a/qemu/roms/openbios/forth/admin/callback.fs b/qemu/roms/openbios/forth/admin/callback.fs new file mode 100644 index 000000000..e318af23b --- /dev/null +++ b/qemu/roms/openbios/forth/admin/callback.fs @@ -0,0 +1,10 @@ +\ 7.4.9 Client program callback + +: callback ( "service-name< >" "arguments<cr>" -- ) + ; + +: $callback ( argn ... arg1 nargs addr len -- retn ... ret2 Nreturns-1 ) + ; + +: sync ( -- ) + ; diff --git a/qemu/roms/openbios/forth/admin/devices.fs b/qemu/roms/openbios/forth/admin/devices.fs new file mode 100644 index 000000000..6f9e8efbb --- /dev/null +++ b/qemu/roms/openbios/forth/admin/devices.fs @@ -0,0 +1,515 @@ +\ tag: device tree administration +\ +\ this code implements IEEE 1275-1994 +\ +\ Copyright (C) 2003 Samuel Rydh +\ Copyright (C) 2003-2006 Stefan Reinauer +\ +\ See the file "COPYING" for further information about +\ the copyright and warranty status of this work. +\ + + +\ 7.4.11.1 Device alias + +: devalias ( "{alias-name}< >{device-specifier}<cr>" -- ) + ; + +: nvalias ( "alias-name< >device-specifier<cr>" -- ) + ; + +: $nvalias ( name-str name-len dev-str dev-len -- ) + ; + +: nvunalias ( "alias-name< >" -- ) + ; + +: $nvunalias ( name-str name-len -- ) + ; + + +\ 7.4.11.2 Device tree browsing + +: dev ( "<spaces>device-specifier" -- ) + bl parse + find-device +; + +: cd + dev +; + +\ find-device ( dev-str dev-len -- ) +\ implemented in pathres.fs + +: device-end ( -- ) + 0 active-package! + ; + +\ Open selected device node and make it the current instance +\ section H.8 errata: pre OpenFirmware, but Sun OBP compatible +: select-dev ( -- ) + open-dev dup 0= abort" failed opening parent." + dup to my-self + ihandle>phandle active-package! +; + +\ Close current node, deselect active package and current instance, +\ leaving no instance selected +\ section H.8 errata: pre OpenFirmware, but Sun OBP compatible +: unselect-dev ( -- ) + my-self close-dev + device-end + 0 to my-self +; + +: begin-package ( arg-str arg-len reg-str reg-len dev-str dev-len -- ) + select-dev + new-device + set-args +; + +: end-package ( -- ) + finish-device + unselect-dev +; + +: ?active-package ( -- phandle ) + active-package dup 0= abort" no active device" +; + +\ ------------------------------------------------------- +\ path handling +\ ------------------------------------------------------- + +\ used if parent lacks an encode-unit method +: def-encode-unit ( unitaddr ... ) + pocket tohexstr +; + +: get-encode-unit-xt ( phandle.parent -- xt ) + >dn.parent @ + " encode-unit" rot find-method + 0= if ['] def-encode-unit then +; + +: get-nodename ( phandle -- str len ) + " name" rot get-package-property if " <noname>" else 1- then +; + +\ helper, return the node name in the format 'cpus@addr' +: pnodename ( phandle -- str len ) + dup get-nodename rot + dup " reg" rot get-package-property if drop exit then rot + + \ set active-package and clear my-self (decode-phys needs this) + my-self >r 0 to my-self + active-package >r + dup active-package! + + ( name len prop len phandle ) + get-encode-unit-xt + + ( name len prop len xt ) + depth >r >r + decode-phys r> execute + r> -rot >r >r depth! 3drop + + ( name len R: len str ) + r> r> " @" + here 20 + \ abuse dictionary for temporary storage + tmpstrcat >r + 2swap r> tmpstrcat drop + pocket tmpstrcpy drop + + r> active-package! + r> to my-self +; + +: inodename ( ihandle -- str len ) + my-self over to my-self >r + ihandle>phandle get-nodename + + \ nonzero unit number? + false >r + depth >r my-unit r> 1+ + begin depth over > while + swap 0<> if r> drop true >r then + repeat + drop + + \ if not... check for presence of "reg" property + r> ?dup 0= if + " reg" my-self ihandle>phandle get-package-property + if false else 2drop true then + then + + ( name len print-unit-flag ) + if + my-self ihandle>phandle get-encode-unit-xt + + ( name len xt ) + depth >r >r + my-unit r> execute + r> -rot >r >r depth! drop + r> r> + ( name len str len ) + here 20 + tmpstrcpy + " @" rot tmpstrcat drop + 2swap pocket tmpstrcat drop + then + + \ add :arguments + my-args dup if + " :" pocket tmpstrcat drop + 2swap pocket tmpstrcat drop + else + 2drop + then + + r> to my-self +; + +\ helper, also used by client interface (package-to-path) +: get-package-path ( phandle -- str len ) + ?dup 0= if 0 0 then + + dup >dn.parent @ 0= if drop " /" exit then + \ dictionary abused for temporary storage + >r 0 0 here 40 + + begin r> dup >dn.parent @ dup >r while + ( path len tempbuf phandle R: phandle.parent ) + pnodename rot tmpstrcat + " /" rot tmpstrcat + repeat + r> 3drop + pocket tmpstrcpy drop +; + +\ used by client interface (instance-to-path) +: get-instance-path ( ihandle -- str len ) + ?dup 0= if 0 0 then + + dup ihandle>phandle >dn.parent @ 0= if drop " /" exit then + + \ dictionary abused for temporary storage + >r 0 0 here 40 + + begin r> dup >in.my-parent @ dup >r while + ( path len tempbuf ihandle R: ihandle.parent ) + dup >in.interposed @ 0= if + inodename rot tmpstrcat + " /" rot tmpstrcat + else + drop + then + repeat + r> 3drop + pocket tmpstrcpy drop +; + +\ used by client interface (instance-to-interposed-path) +: get-instance-interposed-path ( ihandle -- str len ) + ?dup 0= if 0 0 then + + dup ihandle>phandle >dn.parent @ 0= if drop " /" exit then + + \ dictionary abused for temporary storage + >r 0 0 here 40 + + begin r> dup >in.my-parent @ dup >r while + ( path len tempbuf ihandle R: ihandle.parent ) + dup >r inodename rot tmpstrcat + r> >in.interposed @ if " /%" else " /" then + rot tmpstrcat + repeat + r> 3drop + pocket tmpstrcpy drop +; + +: pwd ( -- ) + ?active-package get-package-path type +; + +: ls ( -- ) + cr + ?active-package >dn.child @ + begin dup while + dup u. dup pnodename type cr + >dn.peer @ + repeat + drop +; + + +\ ------------------------------------------- +\ property printing +\ ------------------------------------------- + +: .p-string? ( data len -- true | data len false ) + \ no trailing zero? + 2dup + 1- c@ if 0 exit then + + swap >r 0 + \ count zeros and detect unprintable characters? + over 1- begin 1- dup 0>= while + dup r@ + c@ + ( len zerocnt n ch ) + + ?dup 0= if + swap 1+ swap + else + dup 1b <= swap 80 >= or + if 2drop r> swap 0 exit then + then + repeat drop r> -rot + ( data len zerocnt ) + + \ simple string + 0= if + ascii " emit 1- type ascii " emit true exit + then + + \ make sure there are no double zeros (except possibly at the end) + 2dup over + swap + ( data len end ptr ) + begin 2dup <> while + dup c@ 0= if + 2dup 1+ <> if 2drop false exit then + then + dup cstrlen 1+ + + repeat + 2drop + + ." {" + 0 -rot over + swap + \ multistring ( cnt end ptr ) + begin 2dup <> while + rot dup if ." , " then 1+ -rot + dup cstrlen 2dup + ascii " emit type ascii " emit + 1+ + + repeat + ." }" + 3drop true +; + +: .p-int? ( data len -- 1 | data len 0 ) + dup 4 <> if false exit then + decode-int -rot 2drop true swap + dup 0>= if . exit then + dup -ff < if u. exit then + . +; + +\ Print a number zero-padded +: 0.r ( u minlen -- ) + 0 swap <# 1 ?do # loop #s #> type +; + +: .p-bytes? ( data len -- 1 | data len 0 ) + ." -- " dup . ." : " + swap >r 0 + begin 2dup > while + dup r@ + c@ + ( len n ch ) + + 2 0.r space + 1+ + repeat + 2drop r> drop 1 +; + +\ this function tries to heuristically determine the data format +: (.property) ( data len -- ) + dup 0= if 2drop ." <empty>" exit then + + .p-string? if exit then + .p-int? if exit then + .p-bytes? if exit then + 2drop ." <unimplemented type>" +; + +\ Print the value of a property in "reg" format +: .p-reg ( #acells #scells data len -- ) + 2dup + -rot ( #acells #scells data+len data len ) + >r >r -rot ( data+len #acells #scells R: len data ) + 4 * swap 4 * dup r> r> ( data+len #sbytes #abytes #abytes data len ) + bounds ( data+len #sbytes #abytes #abytes data+len data ) ?do + dup 0= if 2 spaces then \ start of "size" part + 2dup <> if \ non-first byte in row + dup 3 and 0= if space then \ make numbers more readable + then + i c@ 2 0.r \ print byte + 1- 3dup nip + 0= if \ end of row + 3 pick i 1+ > if \ non-last byte + cr \ start new line + d# 26 spaces \ indentation + then + drop dup \ update counter + then + loop + 3drop drop +; + +\ Return the number of cells per physical address +: .p-translations-#pacells ( -- #cells ) + " /" find-package if + " #address-cells" rot get-package-property if + 1 + else + decode-int nip nip 1 max + then + else + 1 + then +; + +\ Return the number of cells per translation entry +: .p-translations-#cells ( -- #cells ) + [IFDEF] CONFIG_PPC + my-#acells 3 * + .p-translations-#pacells + + [ELSE] + my-#acells 3 * + [THEN] +; + +\ Set up column offsets +: .p-translations-cols ( -- col1 ... coln #cols ) + .p-translations-#cells 4 * + [IFDEF] CONFIG_PPC + 4 - + dup 4 - + dup .p-translations-#pacells 4 * - + 3 + [ELSE] + my-#acells 4 * - + dup my-#scells 4 * - + 2 + [THEN] +; + +\ Print the value of the MMU translations property +: .p-translations ( data len -- ) + >r >r .p-translations-cols r> r> ( col1 ... coln #cols data len ) + 2dup + -rot ( col1 ... coln #cols data+len data len ) + >r >r .p-translations-#cells 4 * dup r> r> + ( col1 ... coln #cols data+len #bytes #bytes len data ) + bounds ( col1 ... coln #cols data+len #bytes #bytes data+len data ) ?do + 3 pick 4 + 4 ?do \ check all defined columns + i pick over = if + 2 spaces \ start new column + then + loop + 2dup <> if \ non-first byte in row + dup 3 and 0= if space then \ make numbers more readable + then + i c@ 2 0.r \ print byte + 1- dup 0= if \ end of row + 2 pick i 1+ > if \ non-last byte + cr \ start new line + d# 26 spaces \ indentation + then + drop dup \ update counter + then + loop + 2drop drop 0 ?do drop loop +; + +\ This function hardwires data formats to particular node properties +: (.property-by-name) ( name-str name-len data len -- ) + 2over " reg" strcmp 0= if + my-#acells my-#scells 2swap .p-reg + 2drop exit + then + + active-package get-nodename " memory" strcmp 0= if + 2over " available" strcmp 0= if + my-#acells my-#scells 2swap .p-reg + 2drop exit + then + then + " /chosen" find-dev if + " mmu" rot get-package-property 0= if + decode-int nip nip ihandle>phandle active-package = if + 2over " available" strcmp 0= if + my-#acells my-#scells 1 max 2swap .p-reg + 2drop exit + then + 2over " translations" strcmp 0= if + .p-translations + 2drop exit + then + then + then + then + + 2swap 2drop ( data len ) + (.property) +; + +: .properties ( -- ) + ?active-package dup >r if + 0 0 + begin + r@ next-property + while + cr 2dup dup -rot type + begin ." " 1+ dup d# 26 >= until drop + 2dup + 2dup active-package get-package-property drop + ( name-str name-len data len ) + (.property-by-name) + repeat + then + r> drop + cr +; + + +\ 7.4.11 Device tree + +: print-dev ( phandle -- phandle ) + dup u. + dup get-package-path type + dup " device_type" rot get-package-property if + cr + else + ." (" decode-string type ." )" cr 2drop + then + ; + +: show-sub-devs ( subtree-phandle -- ) + print-dev + >dn.child @ + begin dup while + dup recurse + >dn.peer @ + repeat + drop + ; + +: show-all-devs ( -- ) + active-package + cr " /" find-device + ?active-package show-sub-devs + active-package! + ; + + +: show-devs ( "{device-specifier}<cr>" -- ) + active-package + cr " /" find-device + linefeed parse find-device + ?active-package show-sub-devs + active-package! + ; + + + +\ 7.4.11.3 Device probing + +\ Set to true if the last probe-self was successful +0 value probe-fcode? + +: probe-all ( -- ) + ; diff --git a/qemu/roms/openbios/forth/admin/help.fs b/qemu/roms/openbios/forth/admin/help.fs new file mode 100644 index 000000000..e6e624b2a --- /dev/null +++ b/qemu/roms/openbios/forth/admin/help.fs @@ -0,0 +1,51 @@ +\ tag: firmware help +\ +\ this code implements IEEE 1275-1994 ch. 7.4.1 +\ +\ Copyright (C) 2003 Stefan Reinauer +\ +\ See the file "COPYING" for further information about +\ the copyright and warranty status of this work. +\ + +hex + +: (help-generic) + ." Enter 'help command-name' or 'help category-name' for more help" cr + ." (Use ONLY the first word of a category description)" cr + ." Examples: help select -or- help line" cr cr + ." Categories:" cr + ." boot (Load and execute a client program)" cr + ." diag (Diagnostic routines)" cr + ; + +: (help-diag) + ." test <device> Run the selftest method for specified device" cr + ." test-all Execute test for all devices using selftest method" cr + ; + +: (help-boot) + ." boot [<device-specifier>:<device-arguments>] [boot-arguments]" cr + ." Examples:" cr + ." boot Default boot (values specified in nvram variables)" cr + ." boot disk1:a Boot from disk1 partition a" cr + ." boot hd:1,\boot\vmlinuz root=/dev/hda1" cr + ; + +: help ( "{name}<cr>" -- ) + \ Provide information for category or specific command. + linefeed parse cr + dup 0= if + (help-generic) + 2drop + else + 2dup " diag" rot min comp not if + (help-diag) 2drop exit + then + 2dup " boot" rot min comp not if + (help-boot) 2drop exit + then + ." No help available for " type cr + then + ; + diff --git a/qemu/roms/openbios/forth/admin/iocontrol.fs b/qemu/roms/openbios/forth/admin/iocontrol.fs new file mode 100644 index 000000000..b0f578f4d --- /dev/null +++ b/qemu/roms/openbios/forth/admin/iocontrol.fs @@ -0,0 +1,168 @@ +\ tag: stdin/stdout handling +\ +\ Copyright (C) 2003 Samuel Rydh +\ +\ See the file "COPYING" for further information about +\ the copyright and warranty status of this work. +\ + +\ 7.4.5 I/O control + +variable stdout +variable stdin + +: input ( dev-str dev-len -- ) + 2dup find-dev 0= if + ." Input device " type ." not found." cr exit + then + + " read" rot find-method 0= if + type ." has no read method." cr exit + then + drop + + \ open stdin device + 2dup open-dev ?dup 0= if + ." Opening " type ." failed." cr exit + then + -rot 2drop + + \ call install-abort if present + dup " install-abort" rot ['] $call-method catch if 3drop then + + \ close old stdin + stdin @ ?dup if + dup " remove-abort" rot ['] $call-method catch if 3drop then + close-dev + then + stdin ! + + \ update /chosen + " /chosen" find-package if + >r stdin @ encode-int " stdin" r> (property) + then + +[IFDEF] CONFIG_SPARC32 + \ update stdin-path properties + \ (this isn't part of the IEEE1275 spec but needed by older Solaris) + " /" find-package if + >r stdin @ get-instance-path encode-string " stdin-path" r> (property) + then +[THEN] +; + +: output ( dev-str dev-len -- ) + 2dup find-dev 0= if + ." Output device " type ." not found." cr exit + then + + " write" rot find-method 0= if + type ." has no write method." cr exit + then + drop + + \ open stdin device + 2dup open-dev ?dup 0= if + ." Opening " type ." failed." cr exit + then + -rot 2drop + + \ close old stdout + stdout @ ?dup if close-dev then + stdout ! + + \ update /chosen + " /chosen" find-package if + >r stdout @ encode-int " stdout" r> (property) + then + +[IFDEF] CONFIG_SPARC32 + \ update stdout-path properties + \ (this isn't part of the IEEE1275 spec but needed by older Solaris) + " /" find-package if + >r stdout @ get-instance-path encode-string " stdout-path" r> (property) + then +[THEN] +; + +: io ( dev-str dev-len -- ) + 2dup input output +; + +\ key?, key and emit implementation +variable io-char +variable io-out-char + +: io-key? ( -- available? ) + io-char @ -1 <> if true exit then + io-char 1 " read" stdin @ $call-method + 1 = +; + +: io-key ( -- key ) + \ poll for key + begin io-key? until + io-char c@ -1 to io-char +; + +: io-emit ( char -- ) + stdout @ if + io-out-char c! + io-out-char 1 " write" stdout @ $call-method + then + drop +; + +variable CONSOLE-IN-list +variable CONSOLE-OUT-list + +: CONSOLE-IN-initializer ( xt -- ) + CONSOLE-IN-list list-add , +; +: CONSOLE-OUT-initializer ( xt -- ) + CONSOLE-OUT-list list-add , +; + +: install-console ( -- ) + + \ create screen alias + " /aliases" find-package if + >r + " screen" find-package if drop else + \ bad (or missing) screen alias + 0 " display" iterate-device-type ?dup if + ( display-ph R: alias-ph ) + get-package-path encode-string " screen" r@ (property) + then + then + r> drop + then + + output-device output + input-device input + + \ let arch determine a useful output device + CONSOLE-OUT-list begin list-get while + stdout @ if drop else @ execute then + repeat + + \ let arch determine a useful input device + CONSOLE-IN-list begin list-get while + stdin @ if drop else @ execute then + repeat + + \ activate console + stdout @ if + ['] io-emit to emit + then + + stdin @ if + -1 to io-char + ['] io-key? to key? + ['] io-key to key + then +; + +:noname + " screen" output +; CONSOLE-OUT-initializer diff --git a/qemu/roms/openbios/forth/admin/nvram.fs b/qemu/roms/openbios/forth/admin/nvram.fs new file mode 100644 index 000000000..20f6462b9 --- /dev/null +++ b/qemu/roms/openbios/forth/admin/nvram.fs @@ -0,0 +1,385 @@ +\ tag: nvram config handling +\ +\ this code implements IEEE 1275-1994 +\ +\ Copyright (C) 2003, 2004 Samuel Rydh +\ +\ See the file "COPYING" for further information about +\ the copyright and warranty status of this work. +\ + +struct ( config ) + 2 cells field >cf.name + 2 cells field >cf.default \ 0 -1 if no default + /n field >cf.check-xt + /n field >cf.exec-xt + /n field >cf.next +constant config-info.size + +0 value config-root + +\ -------------------------------------------------------- +\ config handling +\ -------------------------------------------------------- + +: find-config ( name-str len -- 0|configptr ) + config-root + begin ?dup while + -rot + 2dup 4 pick >cf.name 2@ + strcmp 0= if + 2drop exit + then + rot >cf.next @ + repeat + 2drop 0 +; + +: is-config-word ( configp -- ) + dup >cf.name 2@ $create , + does> @ + dup >cf.name 2@ + s" /options" find-dev if + get-package-property if 0 -1 then + ( configp prop-str prop-len ) + \ drop trailing zero + ?dup if 1- then + else + 2drop 0 -1 + then + \ use default value if property is missing + dup 0< if 2drop dup >cf.default 2@ then + \ no default value, use empty string + dup 0< if 2drop 0 0 then + + rot >cf.exec-xt @ execute +; + +: new-config ( name-str name-len -- configp ) + 2dup find-config ?dup if + nip nip + 0 0 2 pick >cf.default 2! + else + dict-strdup + here config-info.size allot + dup config-info.size 0 fill + config-root over >cf.next ! + dup to config-root + dup >r >cf.name 2! r> + dup is-config-word + then + ( configp ) +; + +: config-default ( str len configp -- ) + -rot + dup 0> if dict-strdup then + rot >cf.default 2! +; + +: no-conf-def ( configp -- ) + 0 -1 +; + +\ -------------------------------------------------------- +\ config types +\ -------------------------------------------------------- + +: exec-str-conf ( str len -- str len ) + \ trivial +; +: check-str-conf ( str len -- str len valid? ) + \ nothing + true +; + +: str-config ( def-str len name len -- configp ) + new-config >r + ['] exec-str-conf r@ >cf.exec-xt ! + ['] check-str-conf r@ >cf.check-xt ! + r> config-default +; + +\ ------------------------------------------------------------ + +: exec-int-conf ( str len -- value ) + \ fixme + parse-hex +; +: check-int-conf ( str len -- str len valid? ) + true +; + +: int-config ( def-str len name len -- configp ) + new-config >r + ['] exec-int-conf r@ >cf.exec-xt ! + ['] check-int-conf r@ >cf.check-xt ! + r> config-default +; + +\ ------------------------------------------------------------ + +: exec-secmode-conf ( str len -- n ) + 2dup s" command" strcmp 0= if 2drop 1 exit then + 2dup s" full" strcmp 0= if 2drop 2 exit then + 2drop 0 +; +: check-secmode-conf ( str len -- str len valid? ) + 2dup s" none" strcmp 0= if true exit then + 2dup s" command" strcmp 0= if true exit then + 2dup s" full" strcmp 0= if true exit then + false +; + +: secmode-config ( def-str len name len -- configp ) + new-config >r + ['] exec-secmode-conf r@ >cf.exec-xt ! + ['] check-secmode-conf r@ >cf.check-xt ! + r> config-default +; + +\ ------------------------------------------------------------ + +: exec-bool-conf ( str len -- value ) + 2dup s" true" strcmp 0= if 2drop true exit then + 2dup s" false" strcmp 0= if 2drop false exit then + 2dup s" TRUE" strcmp 0= if 2drop false exit then + 2dup s" FALSE" strcmp 0= if 2drop false exit then + parse-hex 0<> +; + +: check-bool-conf ( name len -- str len valid? ) + 2dup s" true" strcmp 0= if true exit then + 2dup s" false" strcmp 0= if true exit then + 2dup s" TRUE" strcmp 0= if 2drop s" true" true exit then + 2dup s" FALSE" strcmp 0= if 2drop s" false" true exit then + false +; + +: bool-config ( configp -- configp ) + new-config >r + ['] exec-bool-conf r@ >cf.exec-xt ! + ['] check-bool-conf r@ >cf.check-xt ! + r> config-default +; + + +\ -------------------------------------------------------- +\ 7.4.4 Nonvolatile memory +\ -------------------------------------------------------- + +: $setenv ( data-addr data-len name-str name-len -- ) + 2dup find-config ?dup if + >r 2swap r> + ( name len data len configptr ) + >cf.check-xt @ execute + 0= abort" Invalid value." + 2swap + else + \ create string config type + 2dup no-conf-def 2swap str-config + then + + 2swap encode-string 2swap + s" /options" find-package drop + encode-property +; + +: setenv ( "nv-param< >new-value<eol>" -- ) + parse-word + \ XXX drop blanks + dup if linefeed parse else 0 0 then + + dup 0= abort" Invalid value." + 2swap $setenv +; + +: printenv ( "{param-name}<eol>" -- ) + \ XXX temporary implementation + linefeed parse 2drop + + active-package + s" /options" find-device + .properties + active-package! +; + +: (set-default) ( configptr -- ) + dup >cf.default 2@ dup 0>= if + rot >cf.name 2@ $setenv + else + \ no default value + 3drop + then +; + +: set-default ( "param-name<eol>" -- ) + linefeed parse + find-config ?dup if + (set-default) + else + ." No such parameter." -2 throw + then +; + +: set-defaults ( -- ) + config-root + begin ?dup while + dup (set-default) + >cf.next @ + repeat +; + +( maxlen "new-name< >" -- ) ( E: -- addr len ) +: nodefault-bytes + ; + + +\ -------------------------------------------------------- +\ initialize config from nvram +\ -------------------------------------------------------- + +\ CHRP format (array of null-terminated strings, "variable=value") +: nvram-load-configs ( data len -- ) + \ XXX: no len checking performed... + drop + begin dup c@ while + ( data ) + dup cstrlen 2dup + 1+ -rot + ( next str len ) + ascii = left-split ( next val len name str ) + ['] $setenv catch if + 2drop 2drop + then + repeat drop +; + +: (nvram-store-one) ( buf len str len -- buf len success? ) + swap >r + 2dup < if r> 2drop 2drop false exit then + ( buf len strlen R: str ) + swap over - r> swap >r -rot + ( str buf strlen R: res_len ) + 2dup + >r move r> r> true +; + +: (make-configstr) ( configptr ph -- str len ) + >r + >cf.name 2@ + 2dup r> get-package-property if + 2drop 0 0 exit + else + dup if 1- then + then + ( name len value-str len ) + 2swap s" =" 2swap + pocket tmpstrcat tmpstrcat drop + 2dup + 0 swap c! + 1+ +; + +: nvram-store-configs ( data len -- ) + 2 - \ make room for two trailing zeros + + s" /options" find-dev 0= if 2drop exit then + >r + config-root + ( data len configptr R: phandle ) + begin ?dup while + r@ over >r (make-configstr) + ( buf len val len R: configptr phandle ) + (nvram-store-one) drop + r> >cf.next @ + repeat + \ null terminate + 2 + 0 fill + r> drop +; + + +\ -------------------------------------------------------- +\ NVRAM variables +\ -------------------------------------------------------- +\ fcode-debug? input-device output-device +s" true" s" auto-boot?" bool-config \ 7.4.3.5 +s" boot" s" boot-command" str-config \ 7.4.3.5 +s" " s" boot-file" str-config \ 7.4.3.5 +s" false" s" diag-switch?" bool-config \ 7.4.3.5 +no-conf-def s" diag-device" str-config \ 7.4.3.5 +no-conf-def s" diag-file" str-config \ 7.4.3.5 +s" false" s" fcode-debug?" bool-config \ 7.7 +s" " s" nvramrc" str-config \ 7.4.4.2 +s" false" s" oem-banner?" bool-config +s" " s" oem-banner" str-config +s" false" s" oem-logo?" bool-config +no-conf-def s" oem-logo" str-config +s" false" s" use-nvramrc?" bool-config \ 7.4.4.2 +s" keyboard" s" input-device" str-config \ 7.4.5 +s" screen" s" output-device" str-config \ 7.4.5 +s" 80" s" screen-#columns" int-config \ 7.4.5 +s" 24" s" screen-#rows" int-config \ 7.4.5 +s" 0" s" selftest-#megs" int-config +no-conf-def s" security-mode" secmode-config + +\ --- devices --- +s" -1" s" pci-probe-mask" int-config +s" false" s" default-mac-address" bool-config +s" false" s" skip-netboot?" bool-config +s" true" s" scroll-lock" bool-config + +[IFDEF] CONFIG_PPC +\ ---- PPC ---- +s" false" s" little-endian?" bool-config +s" false" s" real-mode?" bool-config +s" -1" s" real-base" int-config +s" -1" s" real-size" int-config +s" 4000000" s" load-base" int-config +s" -1" s" virt-base" int-config +s" -1" s" virt-size" int-config +[THEN] + +[IFDEF] CONFIG_X86 +\ ---- X86 ---- +s" true" s" little-endian?" bool-config +[THEN] + +[IFDEF] CONFIG_SPARC32 +\ ---- SPARC32 ---- +s" 4000" s" load-base" int-config +s" true" s" tpe-link-test?" bool-config +s" 9600,8,n,1,-" s" ttya-mode" str-config +s" true" s" ttya-ignore-cd" bool-config +s" false" s" ttya-rts-dtr-off" bool-config +s" 9600,8,n,1,-" s" ttyb-mode" str-config +s" true" s" ttyb-ignore-cd" bool-config +s" false" s" ttyb-rts-dtr-off" bool-config +[THEN] + +[IFDEF] CONFIG_SPARC64 +\ ---- SPARC64 ---- +s" 4000" s" load-base" int-config +s" false" s" little-endian?" bool-config +[THEN] + +\ --- ??? --- +s" " s" boot-screen" str-config +s" " s" boot-script" str-config +s" false" s" use-generic?" bool-config +s" disk" s" boot-device" str-config \ 7.4.3.5 +s" " s" boot-args" str-config \ ??? + +\ defers +['] fcode-debug? to _fcode-debug? +['] diag-switch? to _diag-switch? + +\ Hack for load-base: it seems that some Sun bootloaders try +\ and execute "<value> to load-base" which will only work if +\ load-base is value. Hence we redefine load-base here as a +\ value using its normal default. +[IFDEF] CONFIG_SPARC64 +load-base value load-base +[THEN] + +: release-load-area + drop +; diff --git a/qemu/roms/openbios/forth/admin/reset.fs b/qemu/roms/openbios/forth/admin/reset.fs new file mode 100644 index 000000000..565692658 --- /dev/null +++ b/qemu/roms/openbios/forth/admin/reset.fs @@ -0,0 +1,12 @@ +\ 7.4.7 Reset + +defer reset-all ( -- ) + +: no-reset-all + s" reset-all is not available on this platform." type cr + ; + +' no-reset-all to reset-all + +\ OpenBOOT knows reset as well. +: reset reset-all ; diff --git a/qemu/roms/openbios/forth/admin/script.fs b/qemu/roms/openbios/forth/admin/script.fs new file mode 100644 index 000000000..a65adb207 --- /dev/null +++ b/qemu/roms/openbios/forth/admin/script.fs @@ -0,0 +1,16 @@ +\ 7.4.4.2 The script + +: nvedit ( -- ) + ; + +: nvstore ( -- ) + ; + +: nvquit ( -- ) + ; + +: nvrecover ( -- ) + ; + +: nvrun ( -- ) + ; diff --git a/qemu/roms/openbios/forth/admin/security.fs b/qemu/roms/openbios/forth/admin/security.fs new file mode 100644 index 000000000..ef2ec30be --- /dev/null +++ b/qemu/roms/openbios/forth/admin/security.fs @@ -0,0 +1,10 @@ +\ 7.4.6 Security + +: password ( -- ) + ; + +: security-password ( -- password-str password-len ) + ; + +: security-#badlogins ( -- n ) + ; diff --git a/qemu/roms/openbios/forth/admin/selftest.fs b/qemu/roms/openbios/forth/admin/selftest.fs new file mode 100644 index 000000000..20c0c963b --- /dev/null +++ b/qemu/roms/openbios/forth/admin/selftest.fs @@ -0,0 +1,49 @@ +\ tag: self-test +\ +\ this code implements IEEE 1275-1994 ch. 7.4.8 +\ +\ Copyright (C) 2003 Stefan Reinauer +\ +\ See the file "COPYING" for further information about +\ the copyright and warranty status of this work. +\ + +\ +\ 7.4.8 Self-test +\ + +: $test ( devname-addr devname-len -- ) + 2dup ." Testing device " type ." : " + find-dev if + s" self-test" rot find-method if + execute + else + ." no self-test method." + then + else + ." no such device." + then + cr +; + +: test ( "device-specifier<cr>"-- ) + linefeed parse cr $test + ; + +: test-sub-devs + >dn.child @ + begin dup while + dup get-package-path $test + dup recurse + >dn.peer @ + repeat + drop +; + +: test-all ( "{device-specifier}<cr>" -- ) + active-package + cr " /" find-device + linefeed parse find-device + ?active-package test-sub-devs + active-package! + ; diff --git a/qemu/roms/openbios/forth/admin/userboot.fs b/qemu/roms/openbios/forth/admin/userboot.fs new file mode 100644 index 000000000..3ae899c2f --- /dev/null +++ b/qemu/roms/openbios/forth/admin/userboot.fs @@ -0,0 +1,29 @@ +\ 7.4.3.5 User commands for booting + +: boot ( "{param-text}<cr>" -- ) + linefeed parse + + \ Copy NVRAM parameters from boot-file to bootargs in case any parameters have + \ been specified for the platform-specific boot code + s" boot-file" $find drop execute + encode-string + " /chosen" (find-dev) if + " bootargs" rot (property) + then + + \ Execute platform-specific boot code, e.g. kernel + s" platform-boot" $find if + execute + then + + (find-bootdevice) \ Setup bootargs + $load \ load and go + go +; + + +\ : diagnostic-mode? ( -- diag? ) +\ ; + +\ : diag-switch? ( -- diag? ) +\ ; diff --git a/qemu/roms/openbios/forth/bootstrap/bootstrap.fs b/qemu/roms/openbios/forth/bootstrap/bootstrap.fs new file mode 100644 index 000000000..0668cf7d8 --- /dev/null +++ b/qemu/roms/openbios/forth/bootstrap/bootstrap.fs @@ -0,0 +1,1590 @@ +\ tag: bootstrap of basic forth words +\ +\ Copyright (C) 2003-2005 Stefan Reinauer, Patrick Mauritz +\ +\ See the file "COPYING" for further information about +\ the copyright and warranty status of this work. +\ + +\ +\ this file contains almost all forth words described +\ by the open firmware user interface. Some more complex +\ parts are found in seperate files (memory management, +\ vocabulary support) +\ + +\ +\ often used constants (reduces dictionary size) +\ + +1 constant 1 +2 constant 2 +3 constant 3 +-1 constant -1 +0 constant 0 + +0 value my-self + +\ +\ 7.3.5.1 Numeric-base control +\ + +: decimal 10 base ! ; +: hex 16 base ! ; +: octal 8 base ! ; +hex + +\ +\ vocabulary words +\ + +variable current forth-last current ! + +: last + current @ + ; + +variable #order 0 #order ! + +defer context +0 value vocabularies? + +defer locals-end +0 value locals-dict +variable locals-dict-buf + +\ +\ 7.3.7 Flag constants +\ + +1 1 = constant true +0 1 = constant false + +\ +\ 7.3.9.2.2 Immediate words (part 1) +\ + +: (immediate) ( xt -- ) + 1 - dup c@ 1 or swap c! + ; + +: (compile-only) + 1 - dup c@ 2 or swap c! + ; + +: immediate + last @ (immediate) + ; + +: compile-only + last @ (compile-only) + ; + +: flags? ( xt -- flags ) + /n /c + - c@ 7f and + ; + +: immediate? ( xt -- true|false ) + flags? 1 and 1 = + ; + +: compile-only? ( xt -- true|false ) + flags? 2 and 2 = + ; + +: [ 0 state ! ; compile-only +: ] -1 state ! ; + + + +\ +\ 7.3.9.2.1 Data space allocation +\ + +: allot here + here! ; +: , here /n allot ! ; +: c, here /c allot c! ; + +: align + /n here /n 1 - and - \ how many bytes to next alignment + /n 1 - and allot \ mask out everything that is bigger + ; \ than cellsize-1 + +: null-align + here dup align here swap - 0 fill + ; + +: w, + here 1 and allot \ if here is not even, we have to align. + here /w allot w! + ; + +: l, + /l here /l 1 - and - \ same as in align, with /l + /l 1 - and \ if it's /l we are already aligned. + allot + here /l allot l! + ; + + +\ +\ 7.3.6 comparison operators (part 1) +\ + +: <> = invert ; + + +\ +\ 7.3.9.2.4 Miscellaneous dictionary (part 1) +\ + +: (to) ( xt-new xt-defer -- ) + /n + ! + ; + +: >body ( xt -- a-addr ) /n 1 lshift + ; +: body> ( a-addr -- xt ) /n 1 lshift - ; + +: reveal latest @ last ! ; +: recursive reveal ; immediate +: recurse latest @ /n + , ; immediate + +: noop ; + +defer environment? +: no-environment? + 2drop false + ; + +['] no-environment? ['] environment? (to) + + +\ +\ 7.3.8.1 Conditional branches +\ + +\ A control stack entry is implemented using 2 data stack items +\ of the form ( addr type ). type can be one of the +\ following: +\ 0 - orig +\ 1 - dest +\ 2 - do-sys + +: resolve-orig here nip over /n + - swap ! ; +: (if) ['] do?branch , here 0 0 , ; compile-only +: (then) resolve-orig ; compile-only + +variable tmp-comp-depth -1 tmp-comp-depth ! +variable tmp-comp-buf 0 tmp-comp-buf ! + +: setup-tmp-comp ( -- ) + state @ 0 = (if) + here tmp-comp-buf @ here! , \ save here and switch to tmp directory + 1 , \ DOCOL + depth tmp-comp-depth ! \ save control depth + ] + (then) +; + +: execute-tmp-comp ( -- ) + depth tmp-comp-depth @ = + (if) + -1 tmp-comp-depth ! + ['] (semis) , + tmp-comp-buf @ + dup @ here! + 0 state ! + /n + execute + (then) +; + +: if setup-tmp-comp ['] do?branch , here 0 0 , ; immediate +: then resolve-orig execute-tmp-comp ; compile-only +: else ['] dobranch , here 0 0 , 2swap resolve-orig ; compile-only + +\ +\ 7.3.8.3 Conditional loops +\ + +\ some dummy words for see +: (begin) ; +: (again) ; +: (until) ; +: (while) ; +: (repeat) ; + +\ resolve-dest requires a loop... +: (resolve-dest) here /n + nip - , ; +: (resolve-begin) setup-tmp-comp ['] (begin) , here 1 ; immediate +: (resolve-until) ['] (until) , ['] do?branch , (resolve-dest) execute-tmp-comp ; compile-only + +: resolve-dest ( dest origN ... orig ) + 2 >r + (resolve-begin) + \ Find topmost control stack entry with a type of 1 (dest) + r> dup dup pick 1 = if + \ Move it to the top + roll + swap 1 - roll + \ Resolve it + (resolve-dest) + 1 \ force exit + else + drop + 2 + >r + 0 + then + (resolve-until) +; + +: begin + setup-tmp-comp + ['] (begin) , + here + 1 + ; immediate + +: again + ['] (again) , + ['] dobranch , + resolve-dest + execute-tmp-comp + ; compile-only + +: until + ['] (until) , + ['] do?branch , + resolve-dest + execute-tmp-comp + ; compile-only + +: while + setup-tmp-comp + ['] (while) , + ['] do?branch , + here 0 0 , 2swap + ; immediate + +: repeat + ['] (repeat) , + ['] dobranch , + resolve-dest resolve-orig + execute-tmp-comp + ; compile-only + + +\ +\ 7.3.8.4 Counted loops +\ + +variable leaves 0 leaves ! + +: resolve-loop + leaves @ + begin + ?dup + while + dup @ \ leaves -- leaves *leaves ) + swap \ -- *leaves leaves ) + here over - \ -- *leaves leaves here-leaves + swap ! \ -- *leaves + repeat + here nip - , + leaves ! + ; + +: do + setup-tmp-comp + leaves @ + here 2 + ['] (do) , + 0 leaves ! + ; immediate + +: ?do + setup-tmp-comp + leaves @ + ['] (?do) , + here 2 + here leaves ! + 0 , + ; immediate + +: loop + ['] (loop) , + resolve-loop + execute-tmp-comp + ; immediate + +: +loop + ['] (+loop) , + resolve-loop + execute-tmp-comp + ; immediate + + +\ Using primitive versions of i and j +\ speeds up loops by 300% +\ : i r> r@ swap >r ; +\ : j r> r> r> r@ -rot >r >r swap >r ; + +: unloop r> r> r> 2drop >r ; + +: leave + ['] unloop , + ['] dobranch , + leaves @ + here leaves ! + , + ; immediate + +: ?leave if leave then ; + +\ +\ 7.3.8.2 Case statement +\ + +: case + setup-tmp-comp + 0 +; immediate + +: endcase + ['] drop , + 0 ?do + ['] then execute + loop + execute-tmp-comp +; immediate + +: of + 1 + >r + ['] over , + ['] = , + ['] if execute + ['] drop , + r> + ; immediate + +: endof + >r + ['] else execute + r> + ; immediate + +\ +\ 7.3.8.5 Other control flow commands +\ + +: exit r> drop ; + + +\ +\ 7.3.4.3 ASCII constants (part 1) +\ + +20 constant bl +07 constant bell +08 constant bs +0d constant carret +0a constant linefeed + + +\ +\ 7.3.1.1 - stack duplication +\ +: tuck swap over ; +: 3dup 2 pick 2 pick 2 pick ; + +\ +\ 7.3.1.2 - stack removal +\ +: clear 0 depth! ; +: 3drop 2drop drop ; + +\ +\ 7.3.1.3 - stack rearrangement +\ + +: 2rot >r >r 2swap r> r> 2swap ; + +\ +\ 7.3.1.4 - return stack +\ + +\ Note: these words are not part of the official OF specification, however +\ they are part of the ANSI DPANS94 core extensions (see section 6.2) and +\ so this seems an appropriate place for them. +: 2>r r> -rot swap >r >r >r ; +: 2r> r> r> r> rot >r swap ; +: 2r@ r> r> r> 2dup >r >r rot >r swap ; + +\ +\ 7.3.2.1 - single precision integer arithmetic (part 1) +\ + +: u/mod 0 swap mu/mod drop ; +: 1+ 1 + ; +: 1- 1 - ; +: 2+ 2 + ; +: 2- 2 - ; +: even 1+ -2 and ; +: bounds over + swap ; + +\ +\ 7.3.2.2 bitwise logical operators +\ +: << lshift ; +: >> rshift ; +: 2* 1 lshift ; +: u2/ 1 rshift ; +: 2/ 1 >>a ; +: not invert ; + +\ +\ 7.3.2.3 double number arithmetic +\ + +: s>d dup 0 < ; +: dnegate 0 0 2swap d- ; +: dabs dup 0 < if dnegate then ; +: um/mod mu/mod drop ; + +\ symmetric division +: sm/rem ( d n -- rem quot ) + over >r >r dabs r@ abs um/mod r> 0 < + if + negate + then + r> 0 < if + negate swap negate swap + then + ; + +\ floored division +: fm/mod ( d n -- rem quot ) + dup >r 2dup xor 0 < >r sm/rem over 0 <> r> and if + 1 - swap r> + swap exit + then + r> drop + ; + +\ +\ 7.3.2.1 - single precision integer arithmetic (part 2) +\ + +: */mod ( n1 n2 n3 -- quot rem ) >r m* r> fm/mod ; +: */ ( n1 n2 n3 -- n1*n2/n3 ) */mod nip ; +: /mod >r s>d r> fm/mod ; +: mod /mod drop ; +: / /mod nip ; + + +\ +\ 7.3.2.4 Data type conversion +\ + +: lwsplit ( quad -- w.lo w.hi ) + dup ffff and swap 10 rshift ffff and +; + +: wbsplit ( word -- b.lo b.hi ) + dup ff and swap 8 rshift ff and +; + +: lbsplit ( quad -- b.lo b2 b3 b.hi ) + lwsplit swap wbsplit rot wbsplit +; + +: bwjoin ( b.lo b.hi -- word ) + ff and 8 lshift swap ff and or +; + +: wljoin ( w.lo w.hi -- quad ) + ffff and 10 lshift swap ffff and or +; + +: bljoin ( b.lo b2 b3 b.hi -- quad ) + bwjoin -rot bwjoin swap wljoin +; + +: wbflip ( word -- word ) \ flips bytes in a word + dup 8 rshift ff and swap ff and bwjoin +; + +: lwflip ( q1 -- q2 ) + dup 10 rshift ffff and swap ffff and wljoin +; + +: lbflip ( q1 -- q2 ) + dup 10 rshift ffff and wbflip swap ffff and wbflip wljoin +; + +\ +\ 7.3.2.5 address arithmetic +\ + +: /c* /c * ; +: /w* /w * ; +: /l* /l * ; +: /n* /n * ; +: ca+ /c* + ; +: wa+ /w* + ; +: la+ /l* + ; +: na+ /n* + ; +: ca1+ /c + ; +: wa1+ /w + ; +: la1+ /l + ; +: na1+ /n + ; +: aligned /n 1- + /n negate and ; +: char+ ca1+ ; +: cell+ na1+ ; +: chars /c* ; +: cells /n* ; +/n constant cell + +\ +\ 7.3.6 Comparison operators +\ + +: <= > not ; +: >= < not ; +: 0= 0 = ; +: 0<= 0 <= ; +: 0< 0 < ; +: 0<> 0 <> ; +: 0> 0 > ; +: 0>= 0 >= ; +: u<= u> not ; +: u>= u< not ; +: within >r over > swap r> >= or not ; +: between 1 + within ; + +\ +\ 7.3.3.1 Memory access +\ + +: 2@ dup cell+ @ swap @ ; +: 2! dup >r ! r> cell+ ! ; + +: <w@ w@ dup 8000 >= if 10000 - then ; + +: comp ( str1 str2 len -- 0|1|-1 ) + >r 0 -rot r> + bounds ?do + dup c@ i c@ - dup if + < if 1 else -1 then swap leave + then + drop ca1+ + loop + drop +; + +\ compare two string + +: $= ( str1 len1 str2 len2 -- true|false ) + rot ( str1 str2 len2 len1 ) + over ( str1 str2 len2 len1 len2 ) + <> if ( str1 str2 len2 ) + 3drop + false + else ( str1 str2 len2 ) + comp + 0= + then +; + +\ : +! tuck @ + swap ! ; +: off false swap ! ; +: on true swap ! ; +: blank bl fill ; +: erase 0 fill ; +: wbflips ( waddr len -- ) + bounds do i w@ wbflip i w! /w +loop +; + +: lwflips ( qaddr len -- ) + bounds do i l@ lwflip i l! /l +loop +; + +: lbflips ( qaddr len -- ) + bounds do i l@ lbflip i l! /l +loop +; + + +\ +\ 7.3.8.6 Error handling (part 1) +\ + +variable catchframe +0 catchframe ! + +: catch + my-self >r + depth >r + catchframe @ >r + rdepth catchframe ! + execute + r> catchframe ! + r> r> 2drop 0 + ; + +: throw + ?dup if + catchframe @ rdepth! + r> catchframe ! + r> swap >r depth! + drop r> + r> ['] my-self (to) + then + ; + +\ +\ 7.3.3.2 memory allocation +\ + +include memory.fs + + +\ +\ 7.3.4.4 Console output (part 1) +\ + +defer emit + +: type bounds ?do i c@ emit loop ; + +\ this one obviously only works when called +\ with a forth string as count fetches addr-1. +\ openfirmware has no such req. therefore it has to go: + +\ : type 0 do count emit loop drop ; + +: debug-type bounds ?do i c@ (emit) loop ; + +\ +\ 7.3.4.1 Text Input +\ + +0 value source-id +0 value ib +variable #ib 0 #ib ! +variable >in 0 >in ! + +: source ( -- addr len ) + ib #ib @ + ; + +: /string ( c-addr1 u1 n -- c-addr2 u2 ) + tuck - -rot + swap +; + + +\ +\ pockets implementation for 7.3.4.1 + +100 constant pocketsize +4 constant numpockets +variable pockets 0 pockets ! +variable whichpocket 0 whichpocket ! + +\ allocate 4 pockets to begin with +: init-pockets ( -- ) + pocketsize numpockets * alloc-mem pockets ! + ; + +: pocket ( ?? -- ?? ) + pocketsize whichpocket @ * + pockets @ + + whichpocket @ 1 + numpockets mod + whichpocket ! + ; + +\ span variable from 7.3.4.2 +variable span 0 span ! + +\ if char is bl then any control character is matched +: findchar ( str len char -- offs true | false ) + swap 0 do + over i + c@ + over dup bl = if <= else = then if + 2drop i dup dup leave + \ i nip nip true exit \ replaces above + then + loop + = + \ drop drop false + ; + +: parse ( delim text<delim> -- str len ) + >r \ save delimiter + ib >in @ + + span @ >in @ - \ ib+offs len-offset. + dup 0 < if \ if we are already at the end of the string, return an empty string + + 0 \ move to end of input string + r> drop + exit + then + 2dup r> \ ib+offs len-offset ib+offs len-offset delim + findchar if \ look for the delimiter. + nip dup 1+ + else + dup + then + >in +! + \ dup -1 = if drop 0 then \ workaround for negative length + ; + +: skipws ( -- ) + ib span @ ( -- ib recvchars ) + begin + dup >in @ > if ( -- recvchars>offs ) + over >in @ + + c@ bl <= + else + false + then + while + 1 >in +! + repeat + 2drop + ; + +: parse-word ( < >text< > -- str len ) + skipws bl parse + ; + +: word ( delim <delims>text<delim> -- pstr ) + pocket >r parse dup r@ c! bounds r> dup 2swap + do + char+ i c@ over c! + loop + drop + ; + +: ( 29 parse 2drop ; immediate +: \ span @ >in ! ; immediate + + + +\ +\ 7.3.4.7 String literals +\ + +: ", + bounds ?do + i c@ c, + loop + ; + +: (") ( -- addr len ) + r> dup + 2 cells + ( r-addr addr ) + over cell+ @ ( r-addr addr len ) + rot over + aligned cell+ >r ( addr len R: r-addr ) + ; + +: handle-text ( temp-addr len -- addr len ) + state @ if + ['] (") , dup , ", null-align + else + pocket swap + dup >r + 0 ?do + over i + c@ over i + c! + loop + nip r> + then + ; + +: s" + 22 parse handle-text + ; immediate + + + +\ +\ 7.3.4.4 Console output (part 2) +\ + +: ." + 22 parse handle-text + ['] type + state @ if + , + else + execute + then + ; immediate + +: .( + 29 parse handle-text + ['] type + state @ if + , + else + execute + then + ; immediate + + + +\ +\ 7.3.4.8 String manipulation +\ + +: count ( pstr -- str len ) 1+ dup 1- c@ ; + +: pack ( str len addr -- pstr ) + 2dup c! \ store len + 1+ swap 0 ?do + over i + c@ over i + c! + loop nip 1- + ; + +: lcc ( char1 -- char2 ) dup 41 5a between if 20 + then ; +: upc ( char1 -- char2 ) dup 61 7a between if 20 - then ; + +: -trailing ( str len1 -- str len2 ) + begin + dup 0<> if \ len != 0 ? + 2dup 1- + + c@ bl = + else + false + then + while + 1- + repeat + ; + + +\ +\ 7.3.4.5 Output formatting +\ + +: cr linefeed emit ; +: debug-cr linefeed (emit) ; +: (cr carret emit ; +: space bl emit ; +: spaces 0 ?do space loop ; +variable #line 0 #line ! +variable #out 0 #out ! + + +\ +\ 7.3.9.2.3 Dictionary search +\ + +\ helper functions + +: lfa2name ( lfa -- name len ) + 1- \ skip flag byte + begin \ skip 0 padding + 1- dup c@ ?dup + until + 7f and \ clear high bit in length + + tuck - swap ( ptr-to-len len - name len ) + ; + +: comp-nocase ( str1 str2 len -- true|false ) + 0 do + 2dup i + c@ upc ( str1 str2 byteX ) + swap i + c@ upc ( str1 str2 byte1 byte2 ) + <> if + 0 leave + then + loop + if -1 else drop 0 then + swap drop + ; + +: comp-word ( b-str len lfa -- true | false ) + lfa2name ( str len str len -- ) + >r swap r> ( str str len len ) + over = if ( str str len ) + comp-nocase + else + drop drop drop false \ if len does not match, string does not match + then +; + +\ $find is an fcode word, but we place it here since we use it for find. + +: find-wordlist ( name-str name-len last -- xt true | name-str name-len false ) + + @ >r + + begin + 2dup r@ dup if comp-word dup false = then + while + r> @ >r drop + repeat + + r@ if \ successful? + -rot 2drop r> cell+ swap + else + r> drop drop drop false + then + + ; + +: $find ( name-str name-len -- xt true | name-str name-len false ) + locals-dict 0<> if + locals-dict-buf @ find-wordlist ?dup if + exit + then + then + vocabularies? if + #order @ 0 ?do + i cells context + @ + find-wordlist + ?dup if + unloop exit + then + loop + false + else + forth-last find-wordlist + then + ; + +\ look up a word in the current wordlist +: $find1 ( name-str name-len -- xt true | name-str name-len false ) + vocabularies? if + current @ + else + forth-last + then + find-wordlist + ; + + +: ' + parse-word $find 0= if + type 3a emit -13 throw + then + ; + +: ['] + parse-word $find 0= if + type 3a emit -13 throw + then + state @ if + ['] (lit) , , + then + ; immediate + +: find ( pstr -- xt n | pstr false ) + dup count $find \ pstr xt true | pstr name-str name-len false + if + nip true + over immediate? if + negate \ immediate returns 1 + then + else + 2drop false + then + ; + + +\ +\ 7.3.9.2.2 Immediate words (part 2) +\ + +: literal ['] (lit) , , ; immediate +: compile, , ; immediate +: compile r> cell+ dup @ , >r ; +: [compile] ['] ' execute , ; immediate + +: postpone + parse-word $find if + dup immediate? not if + ['] (lit) , , ['] , + then + , + else + s" undefined word " type type cr + then + ; immediate + + +\ +\ 7.3.9.2.4 Miscellaneous dictionary (part 2) +\ + +variable #instance + +: instance ( -- ) + true #instance ! +; + +: #instance-base + my-self dup if @ then +; + +: #instance-offs + my-self dup if na1+ then +; + +\ the following instance words are used internally +\ to implement variable instantiation. + +: instance-cfa? ( cfa -- true | false ) + b e within \ b,c and d are instance defining words +; + +: behavior ( xt-defer -- xt ) + dup @ instance-cfa? if + #instance-base ?dup if + swap na1+ @ + @ + else + 3 /n* + @ + then + else + na1+ @ + then +; + +: (ito) ( xt-new xt-defer -- ) + #instance-base ?dup if + swap na1+ @ + ! + else + 3 /n* + ! + then +; + +: (to-xt) ( xt -- ) + dup @ instance-cfa? + state @ if + swap ['] (lit) , , if ['] (ito) else ['] (to) then , + else + if (ito) else /n + ! then + then +; + +: to + ['] ' execute + (to-xt) + ; immediate + +: is ( xt "wordname<>" -- ) + parse-word $find if + (to) + else + s" could not find " type type + then + ; + +\ +\ 7.3.4.2 Console Input +\ + +defer key? +defer key + +: accept ( addr len -- len2 ) + tuck 0 do + key + dup linefeed = if + space drop drop drop i 0 leave + then + dup emit over c! 1 + + loop + drop ( cr ) + ; + +: expect ( addr len -- ) + accept span ! + ; + + +\ +\ 7.3.4.3 ASCII constants (part 2) +\ + +: handle-lit + state @ if + 2 = if + ['] (lit) , , + then + ['] (lit) , , + else + drop + then + ; + +: char + parse-word 0<> if c@ else s" Unexpected EOL." type cr then ; + ; + +: ascii char 1 handle-lit ; immediate +: [char] char 1 handle-lit ; immediate + +: control + char bl 1- and 1 handle-lit +; immediate + + + +\ +\ 7.3.8.6 Error handling (part 2) +\ + +: abort + -1 throw + ; + +: abort" + ['] if execute + 22 parse handle-text + ['] type , + ['] (lit) , + -2 , + ['] throw , + ['] then execute + ; compile-only + +\ +\ 7.5.3.1 Dictionary search +\ + +\ this does not belong here, but its nice for testing + +: words ( -- ) + last + begin @ + ?dup while + dup lfa2name + + \ Don't print spaces for headerless words + dup if + type space + else + type + then + + repeat + cr + ; + +\ +\ 7.3.5.4 Numeric output primitives +\ + +false value capital-hex? + +: pad ( -- addr ) here 100 + aligned ; + +: todigit ( num -- ascii ) + dup 9 > if + capital-hex? not if + 20 + + then + 7 + + then + 30 + + ; + +: <# pad dup ! ; +: hold pad dup @ 1- tuck swap ! c! ; +: sign + 0< if + 2d hold + then + ; + +: # base @ mu/mod rot todigit hold ; +: #s begin # 2dup or 0= until ; +: #> 2drop pad dup @ tuck - ; +: (.) <# dup >r abs 0 #s r> sign #> ; + +: u# base @ u/mod swap todigit hold ; +: u#s begin u# dup 0= until ; +: u#> 0 #> ; +: (u.) <# u#s u#> ; + +\ +\ 7.3.5.3 Numeric output +\ + +: . (.) type space ; +: s. . ; +: u. (u.) type space ; +: .r swap (.) rot 2dup < if over - spaces else drop then type ; +: u.r swap (u.) rot 2dup < if over - spaces else drop then type ; +: .d base @ swap decimal . base ! ; +: .h base @ swap hex . base ! ; + +: .s + 3c emit depth dup (.) type 3e emit space + 0 + ?do + depth i - 1- pick . + loop + cr + ; + +\ +\ 7.3.5.2 Numeric input +\ + +: digit ( char base -- n true | char false ) + swap dup upc dup + 41 5a ( A - Z ) between if + 7 - + else + dup 39 > if \ protect from : and ; + -rot 2drop false exit + then + then + + 30 ( number 0 ) - rot over swap 0 swap within if + nip true + else + drop false + then + ; + +: >number + begin + dup + while + over c@ base @ digit 0= if + drop exit + then >r 2swap r> swap base @ um* drop rot base @ um* d+ 2swap + 1 /string + repeat + ; + +: numdelim? + dup 2e = swap 2c = or +; + + +: $dnumber? + 0 0 2swap dup 0= if + 2drop 2drop 0 exit + then over c@ 2d = dup >r negate /string begin + >number dup 1 > + while + over c@ numdelim? 0= if + 2drop 2drop r> drop 0 exit + then 1 /string + repeat if + c@ 2e = if + true + else + 2drop r> drop 0 exit + then + else + drop false + then over or if + r> if + dnegate + then 2 + else + drop r> if + negate + then 1 + then +; + + +: $number ( ) + $dnumber? + case + 0 of true endof + 1 of false endof + 2 of drop false endof + endcase +; + +: d# + parse-word + base @ >r + + decimal + + $number if + s" illegal number" type cr 0 + then + r> base ! + 1 handle-lit + ; immediate + +: h# + parse-word + base @ >r + + hex + + $number if + s" illegal number" type cr 0 + then + r> base ! + 1 handle-lit + ; immediate + +: o# + parse-word + base @ >r + + octal + + $number if + s" illegal number" type cr 0 + then + r> base ! + 1 handle-lit + ; immediate + + +\ +\ 7.3.4.7 String Literals (part 2) +\ + +: " + pocket dup + begin + span @ >in @ > if + 22 parse >r ( pocket pocket str R: len ) + over r@ move \ copy string + r> + ( pocket nextdest ) + ib >in @ + c@ ( pocket nextdest nexchar ) + 1 >in +! + 28 = \ is nextchar a parenthesis? + span @ >in @ > \ more input? + and + else + false + then + while + 29 parse \ parse everything up to the next ')' + bounds ?do + i c@ 10 digit if + i 1+ c@ 10 digit if + swap 4 lshift or + else + drop + then + over c! 1+ + 2 + else + drop 1 + then + +loop + repeat + over - + handle-text +; immediate + + +\ +\ 7.3.3.1 Memory Access (part 2) +\ + +: dump ( addr len -- ) + over + swap + cr + do i u. space + 10 0 do + j i + c@ + dup 10 / todigit emit + 10 mod todigit emit + space + i 7 = if space then + loop + 3 spaces + 10 0 do + j i + c@ + dup 20 < if drop 2e then \ non-printables as dots? + emit + loop + cr + 10 +loop +; + + + +\ +\ 7.3.9.1 Defining words +\ + +: header ( name len -- ) + dup if \ might be a noname... + 2dup $find1 if + drop 2dup type s" isn't unique." type cr + else + 2drop + then + then + null-align + dup -rot ", 80 or c, \ write name and len + here /n 1- and 0= if 0 c, then \ pad and space for flags + null-align + 80 here 1- c! \ write flags byte + here last @ , latest ! \ write backlink and set latest + ; + + +: : + parse-word header + 1 , ] + ; + +: :noname + 0 0 header + here + 1 , ] + ; + +: ; + locals-dict 0<> if + 0 ['] locals-dict /n + ! + ['] locals-end , + then + ['] (semis) , reveal ['] [ execute + ; immediate + +: constant + parse-word header + 3 , , \ compile DOCON and value + reveal + ; + +0 value active-package +: instance, ( size -- ) + \ first word of the device node holds the instance size + dup active-package @ dup rot + active-package ! + , , \ offset size +; + +: instance? ( -- flag ) + #instance @ dup if + false #instance ! + then +; + +: value + parse-word header + instance? if + /n b , instance, , \ DOIVAL + else + 3 , , + then + reveal + ; + +: variable + parse-word header + instance? if + /n c , instance, 0 , + else + 4 , 0 , + then + reveal + ; + +: $buffer: ( size str len -- where ) + header + instance? if + /n over /n 1- and - /n 1- and + \ align buffer size + dup c , instance, \ DOIVAR + else + 4 , + then + here swap + 2dup 0 fill \ zerofill + allot + reveal +; + +: buffer: ( size -- ) + parse-word $buffer: drop +; + +: (undefined-defer) ( -- ) + \ XXX: this does not work with behavior ... execute + r@ 2 cells - lfa2name + s" undefined defer word " type type cr ; + +: (undefined-idefer) ( -- ) + s" undefined idefer word " type cr ; + +: defer ( new-name< > -- ) + parse-word header + instance? if + 2 /n* d , instance, \ DOIDEFER + ['] (undefined-idefer) + else + 5 , + ['] (undefined-defer) + then + , + ['] (semis) , + reveal + ; + +: alias ( new-name< >old-name< > -- ) + parse-word + parse-word $find if + -rot \ move xt behind. + header + 1 , \ fixme we want our own cfa here. + , \ compile old name xt + ['] (semis) , + reveal + else + s" undefined word " type type space + 2drop + then + ; + +: $create + header 6 , + ['] noop , + reveal + ; + +: create + parse-word $create + ; + +: (does>) + r> cell+ \ get address of code to execute + latest @ \ backlink of just "create"d word + cell+ cell+ ! \ write code to execute after the + \ new word's CFA + ; + +: does> + ['] (does>) , \ compile does handling + 1 , \ compile docol + ; immediate + +0 constant struct + +: field + create + over , + + + does> + @ + + ; + +: 2constant + create , , + does> 2@ reveal + ; + +\ +\ initializer for the temporary compile buffer +\ + +: init-tmp-comp + here 200 allot tmp-comp-buf ! +; + +\ the end diff --git a/qemu/roms/openbios/forth/bootstrap/build.xml b/qemu/roms/openbios/forth/bootstrap/build.xml new file mode 100644 index 000000000..d950a46df --- /dev/null +++ b/qemu/roms/openbios/forth/bootstrap/build.xml @@ -0,0 +1,16 @@ +<build> + <!-- + build description for openbios forth bootstrap + + Copyright (C) 2004-2005 by Stefan Reinauer + See the file "COPYING" for further information about + the copyright and warranty status of this work. + --> + + <dictionary name="bootstrap"> + <object source="start.fs" target="forth"/> + </dictionary> + + <dictionary name="openbios" init="bootstrap"/> + +</build> diff --git a/qemu/roms/openbios/forth/bootstrap/builtin.fs b/qemu/roms/openbios/forth/bootstrap/builtin.fs new file mode 100644 index 000000000..03f5fde1f --- /dev/null +++ b/qemu/roms/openbios/forth/bootstrap/builtin.fs @@ -0,0 +1,28 @@ +\ tag: initialize builtin functionality +\ +\ Copyright (C) 2003 Stefan Reinauer +\ +\ See the file "COPYING" for further information about +\ the copyright and warranty status of this work. +\ + + + +: init-builtin-terminal ( -- ) + + \ define key, key? and emit + ['] (key) ['] key (to) + ['] (key?) ['] key? (to) + ['] (emit) ['] emit (to) + + \ 2 bytes band guard on each side + 100 #ib ! + #ib @ dup ( -- ibs ibs ) + cell+ alloc-mem ( -- ibs addr ) + dup -rot ( -- addr ibs addr ) + + /w + ['] ib (to) \ assign input buffer + 0 fill \ erase tib + 0 ['] source-id (to) \ builtin terminal has id 0 + + ; diff --git a/qemu/roms/openbios/forth/bootstrap/hayes.fs b/qemu/roms/openbios/forth/bootstrap/hayes.fs new file mode 100644 index 000000000..e5a46f406 --- /dev/null +++ b/qemu/roms/openbios/forth/bootstrap/hayes.fs @@ -0,0 +1,1064 @@ +\ From: John Hayes S1I +\ Subject: tester.fr +\ Date: Mon, 27 Nov 95 13:10:09 PST + +\ (C) 1995 JOHNS HOPKINS UNIVERSITY / APPLIED PHYSICS LABORATORY +\ MAY BE DISTRIBUTED FREELY AS LONG AS THIS COPYRIGHT NOTICE REMAINS. +\ VERSION 1.1 + +HEX + +\ switch output of hex values to capital letters +true to capital-hex? + + +\ SET THE FOLLOWING FLAG TO TRUE FOR MORE VERBOSE OUTPUT; THIS MAY +\ ALLOW YOU TO TELL WHICH TEST CAUSED YOUR SYSTEM TO HANG. + +VARIABLE VERBOSE + FALSE VERBOSE ! + +: EMPTY-STACK \ ( ... -- ) EMPTY STACK: HANDLES UNDERFLOWED STACK TOO. + DEPTH ?DUP IF DUP 0< IF NEGATE 0 DO 0 LOOP ELSE 0 DO DROP LOOP THEN THEN ; + +: ERROR \ ( C-ADDR U -- ) DISPLAY AN ERROR MESSAGE FOLLOWED BY + \ THE LINE THAT HAD THE ERROR. + \ TYPE SOURCE TYPE CR \ DISPLAY LINE CORRESPONDING TO ERROR + + \ FIXME beginagain wants the following for output: + TYPE SOURCE drop span @ TYPE CR \ DISPLAY LINE CORRESPONDING TO ERROR + EMPTY-STACK \ THROW AWAY EVERY THING ELSE + -99 SYS-DEBUG \ MAKE BEGINAGAIN BOOTSTRAP FAIL. +; + +VARIABLE ACTUAL-DEPTH \ STACK RECORD +CREATE ACTUAL-RESULTS 20 CELLS ALLOT + +: { \ ( -- ) SYNTACTIC SUGAR. + ; + +: -> \ ( ... -- ) RECORD DEPTH AND CONTENT OF STACK. + DEPTH DUP ACTUAL-DEPTH ! \ RECORD DEPTH + ?DUP IF \ IF THERE IS SOMETHING ON STACK + 0 DO ACTUAL-RESULTS I CELLS + ! LOOP \ SAVE THEM + THEN ; + +: } \ ( ... -- ) COMPARE STACK (EXPECTED) CONTENTS WITH SAVED + \ (ACTUAL) CONTENTS. + DEPTH ACTUAL-DEPTH @ = IF \ IF DEPTHS MATCH + DEPTH ?DUP IF \ IF THERE IS SOMETHING ON THE STACK + 0 DO \ FOR EACH STACK ITEM + ACTUAL-RESULTS I CELLS + @ \ COMPARE ACTUAL WITH EXPECTED + <> IF S" INCORRECT RESULT: " ERROR LEAVE THEN + LOOP + THEN + ELSE \ DEPTH MISMATCH + S" WRONG NUMBER OF RESULTS: " ERROR + THEN ; + +: TESTING \ ( -- ) TALKING COMMENT. + SOURCE VERBOSE @ + IF DUP >R TYPE CR R> >IN ! + ELSE >IN ! DROP + THEN + ; + +\ From: John Hayes S1I +\ Subject: core.fr +\ Date: Mon, 27 Nov 95 13:10 + +\ (C) 1995 JOHNS HOPKINS UNIVERSITY / APPLIED PHYSICS LABORATORY +\ MAY BE DISTRIBUTED FREELY AS LONG AS THIS COPYRIGHT NOTICE REMAINS. +\ VERSION 1.2 +\ THIS PROGRAM TESTS THE CORE WORDS OF AN ANS FORTH SYSTEM. +\ THE PROGRAM ASSUMES A TWO'S COMPLEMENT IMPLEMENTATION WHERE +\ THE RANGE OF SIGNED NUMBERS IS -2^(N-1) ... 2^(N-1)-1 AND +\ THE RANGE OF UNSIGNED NUMBERS IS 0 ... 2^(N)-1. +\ I HAVEN'T FIGURED OUT HOW TO TEST KEY, QUIT, ABORT, OR ABORT"... +\ I ALSO HAVEN'T THOUGHT OF A WAY TO TEST ENVIRONMENT?... + +TESTING CORE WORDS +HEX + +\ ------------------------------------------------------------------------ +TESTING BASIC ASSUMPTIONS + +{ -> } \ START WITH CLEAN SLATE +( TEST IF ANY BITS ARE SET; ANSWER IN BASE 1 ) +{ : BITSSET? IF 0 0 ELSE 0 THEN ; -> } +{ 0 BITSSET? -> 0 } ( ZERO IS ALL BITS CLEAR ) +{ 1 BITSSET? -> 0 0 } ( OTHER NUMBER HAVE AT LEAST ONE BIT ) +{ -1 BITSSET? -> 0 0 } + +\ ------------------------------------------------------------------------ +TESTING BOOLEANS: INVERT AND OR XOR + +{ 0 0 AND -> 0 } +{ 0 1 AND -> 0 } +{ 1 0 AND -> 0 } +{ 1 1 AND -> 1 } + +{ 0 INVERT 1 AND -> 1 } +{ 1 INVERT 1 AND -> 0 } + +0 CONSTANT 0S +0 INVERT CONSTANT 1S + +{ 0S INVERT -> 1S } +{ 1S INVERT -> 0S } + +{ 0S 0S AND -> 0S } +{ 0S 1S AND -> 0S } +{ 1S 0S AND -> 0S } +{ 1S 1S AND -> 1S } + +{ 0S 0S OR -> 0S } +{ 0S 1S OR -> 1S } +{ 1S 0S OR -> 1S } +{ 1S 1S OR -> 1S } + +{ 0S 0S XOR -> 0S } +{ 0S 1S XOR -> 1S } +{ 1S 0S XOR -> 1S } +{ 1S 1S XOR -> 0S } + +\ ------------------------------------------------------------------------ +TESTING 2* 2/ LSHIFT RSHIFT + +( WE TRUST 1S, INVERT, AND BITSSET?; WE WILL CONFIRM RSHIFT LATER ) +1S 1 RSHIFT INVERT CONSTANT MSB +{ MSB BITSSET? -> 0 0 } + +{ 0S 2* -> 0S } +{ 1 2* -> 2 } +{ 4000 2* -> 8000 } +{ 1S 2* 1 XOR -> 1S } +{ MSB 2* -> 0S } + +{ 0S 2/ -> 0S } +{ 1 2/ -> 0 } +{ 4000 2/ -> 2000 } +{ 1S 2/ -> 1S } \ MSB PROPOGATED +{ 1S 1 XOR 2/ -> 1S } +{ MSB 2/ MSB AND -> MSB } + +{ 1 0 LSHIFT -> 1 } +{ 1 1 LSHIFT -> 2 } +{ 1 2 LSHIFT -> 4 } +{ 1 F LSHIFT -> 8000 } \ BIGGEST GUARANTEED SHIFT +{ 1S 1 LSHIFT 1 XOR -> 1S } +{ MSB 1 LSHIFT -> 0 } + +{ 1 0 RSHIFT -> 1 } +{ 1 1 RSHIFT -> 0 } +{ 2 1 RSHIFT -> 1 } +{ 4 2 RSHIFT -> 1 } +{ 8000 F RSHIFT -> 1 } \ BIGGEST +{ MSB 1 RSHIFT MSB AND -> 0 } \ RSHIFT ZERO FILLS MSBS +{ MSB 1 RSHIFT 2* -> MSB } + +\ ------------------------------------------------------------------------ +TESTING COMPARISONS: 0= = 0< < > U< MIN MAX +0 INVERT CONSTANT MAX-UINT +0 INVERT 1 RSHIFT CONSTANT MAX-INT +0 INVERT 1 RSHIFT INVERT CONSTANT MIN-INT +0 INVERT 1 RSHIFT CONSTANT MID-UINT +0 INVERT 1 RSHIFT INVERT CONSTANT MID-UINT+1 + +0S CONSTANT <FALSE> +1S CONSTANT <TRUE> + +{ 0 0= -> <TRUE> } +{ 1 0= -> <FALSE> } +{ 2 0= -> <FALSE> } +{ -1 0= -> <FALSE> } +{ MAX-UINT 0= -> <FALSE> } +{ MIN-INT 0= -> <FALSE> } +{ MAX-INT 0= -> <FALSE> } + +{ 0 0 = -> <TRUE> } +{ 1 1 = -> <TRUE> } +{ -1 -1 = -> <TRUE> } +{ 1 0 = -> <FALSE> } +{ -1 0 = -> <FALSE> } +{ 0 1 = -> <FALSE> } +{ 0 -1 = -> <FALSE> } + +{ 0 0< -> <FALSE> } +{ -1 0< -> <TRUE> } +{ MIN-INT 0< -> <TRUE> } +{ 1 0< -> <FALSE> } +{ MAX-INT 0< -> <FALSE> } + +{ 0 1 < -> <TRUE> } +{ 1 2 < -> <TRUE> } +{ -1 0 < -> <TRUE> } +{ -1 1 < -> <TRUE> } +{ MIN-INT 0 < -> <TRUE> } +{ MIN-INT MAX-INT < -> <TRUE> } +{ 0 MAX-INT < -> <TRUE> } +{ 0 0 < -> <FALSE> } +{ 1 1 < -> <FALSE> } +{ 1 0 < -> <FALSE> } +{ 2 1 < -> <FALSE> } +{ 0 -1 < -> <FALSE> } +{ 1 -1 < -> <FALSE> } +{ 0 MIN-INT < -> <FALSE> } +{ MAX-INT MIN-INT < -> <FALSE> } +{ MAX-INT 0 < -> <FALSE> } + +{ 0 1 > -> <FALSE> } +{ 1 2 > -> <FALSE> } +{ -1 0 > -> <FALSE> } +{ -1 1 > -> <FALSE> } +{ MIN-INT 0 > -> <FALSE> } +{ MIN-INT MAX-INT > -> <FALSE> } +{ 0 MAX-INT > -> <FALSE> } +{ 0 0 > -> <FALSE> } +{ 1 1 > -> <FALSE> } +{ 1 0 > -> <TRUE> } +{ 2 1 > -> <TRUE> } +{ 0 -1 > -> <TRUE> } +{ 1 -1 > -> <TRUE> } +{ 0 MIN-INT > -> <TRUE> } +{ MAX-INT MIN-INT > -> <TRUE> } +{ MAX-INT 0 > -> <TRUE> } + +{ 0 1 U< -> <TRUE> } +{ 1 2 U< -> <TRUE> } +{ 0 MID-UINT U< -> <TRUE> } +{ 0 MAX-UINT U< -> <TRUE> } +{ MID-UINT MAX-UINT U< -> <TRUE> } +{ 0 0 U< -> <FALSE> } +{ 1 1 U< -> <FALSE> } +{ 1 0 U< -> <FALSE> } +{ 2 1 U< -> <FALSE> } +{ MID-UINT 0 U< -> <FALSE> } +{ MAX-UINT 0 U< -> <FALSE> } +{ MAX-UINT MID-UINT U< -> <FALSE> } + +{ 0 1 MIN -> 0 } +{ 1 2 MIN -> 1 } +{ -1 0 MIN -> -1 } +{ -1 1 MIN -> -1 } +{ MIN-INT 0 MIN -> MIN-INT } +{ MIN-INT MAX-INT MIN -> MIN-INT } +{ 0 MAX-INT MIN -> 0 } +{ 0 0 MIN -> 0 } +{ 1 1 MIN -> 1 } +{ 1 0 MIN -> 0 } +{ 2 1 MIN -> 1 } +{ 0 -1 MIN -> -1 } +{ 1 -1 MIN -> -1 } +{ 0 MIN-INT MIN -> MIN-INT } +{ MAX-INT MIN-INT MIN -> MIN-INT } +{ MAX-INT 0 MIN -> 0 } + +{ 0 1 MAX -> 1 } +{ 1 2 MAX -> 2 } +{ -1 0 MAX -> 0 } +{ -1 1 MAX -> 1 } +{ MIN-INT 0 MAX -> 0 } +{ MIN-INT MAX-INT MAX -> MAX-INT } +{ 0 MAX-INT MAX -> MAX-INT } +{ 0 0 MAX -> 0 } +{ 1 1 MAX -> 1 } +{ 1 0 MAX -> 1 } +{ 2 1 MAX -> 2 } +{ 0 -1 MAX -> 0 } +{ 1 -1 MAX -> 1 } +{ 0 MIN-INT MAX -> 0 } +{ MAX-INT MIN-INT MAX -> MAX-INT } +{ MAX-INT 0 MAX -> MAX-INT } + +\ ------------------------------------------------------------------------ +TESTING STACK OPS: 2DROP 2DUP 2OVER 2SWAP ?DUP DEPTH DROP DUP OVER ROT SWAP + +{ 1 2 2DROP -> } +{ 1 2 2DUP -> 1 2 1 2 } +{ 1 2 3 4 2OVER -> 1 2 3 4 1 2 } +{ 1 2 3 4 2SWAP -> 3 4 1 2 } +{ 0 ?DUP -> 0 } +{ 1 ?DUP -> 1 1 } +{ -1 ?DUP -> -1 -1 } +{ DEPTH -> 0 } +{ 0 DEPTH -> 0 1 } +{ 0 1 DEPTH -> 0 1 2 } +{ 0 DROP -> } +{ 1 2 DROP -> 1 } +{ 1 DUP -> 1 1 } +{ 1 2 OVER -> 1 2 1 } +{ 1 2 3 ROT -> 2 3 1 } +{ 1 2 SWAP -> 2 1 } + +\ ------------------------------------------------------------------------ +TESTING >R R> R@ + +{ : GR1 >R R> ; -> } +{ : GR2 >R R@ R> DROP ; -> } +{ 123 GR1 -> 123 } +{ 123 GR2 -> 123 } +{ 1S GR1 -> 1S } ( RETURN STACK HOLDS CELLS ) + +\ ------------------------------------------------------------------------ +TESTING ADD/SUBTRACT: + - 1+ 1- ABS NEGATE + +{ 0 5 + -> 5 } +{ 5 0 + -> 5 } +{ 0 -5 + -> -5 } +{ -5 0 + -> -5 } +{ 1 2 + -> 3 } +{ 1 -2 + -> -1 } +{ -1 2 + -> 1 } +{ -1 -2 + -> -3 } +{ -1 1 + -> 0 } +{ MID-UINT 1 + -> MID-UINT+1 } + +{ 0 5 - -> -5 } +{ 5 0 - -> 5 } +{ 0 -5 - -> 5 } +{ -5 0 - -> -5 } +{ 1 2 - -> -1 } +{ 1 -2 - -> 3 } +{ -1 2 - -> -3 } +{ -1 -2 - -> 1 } +{ 0 1 - -> -1 } +{ MID-UINT+1 1 - -> MID-UINT } + +{ 0 1+ -> 1 } +{ -1 1+ -> 0 } +{ 1 1+ -> 2 } +{ MID-UINT 1+ -> MID-UINT+1 } + +{ 2 1- -> 1 } +{ 1 1- -> 0 } +{ 0 1- -> -1 } +{ MID-UINT+1 1- -> MID-UINT } + +{ 0 NEGATE -> 0 } +{ 1 NEGATE -> -1 } +{ -1 NEGATE -> 1 } +{ 2 NEGATE -> -2 } +{ -2 NEGATE -> 2 } + +{ 0 ABS -> 0 } +{ 1 ABS -> 1 } +{ -1 ABS -> 1 } +{ MIN-INT ABS -> MID-UINT+1 } + +\ ------------------------------------------------------------------------ +TESTING MULTIPLY: S>D * M* UM* + +{ 0 S>D -> 0 0 } +{ 1 S>D -> 1 0 } +{ 2 S>D -> 2 0 } +{ -1 S>D -> -1 -1 } +{ -2 S>D -> -2 -1 } +{ MIN-INT S>D -> MIN-INT -1 } +{ MAX-INT S>D -> MAX-INT 0 } + +{ 0 0 M* -> 0 S>D } +{ 0 1 M* -> 0 S>D } +{ 1 0 M* -> 0 S>D } +{ 1 2 M* -> 2 S>D } +{ 2 1 M* -> 2 S>D } +{ 3 3 M* -> 9 S>D } +{ -3 3 M* -> -9 S>D } +{ 3 -3 M* -> -9 S>D } +{ -3 -3 M* -> 9 S>D } +{ 0 MIN-INT M* -> 0 S>D } +{ 1 MIN-INT M* -> MIN-INT S>D } +{ 2 MIN-INT M* -> 0 1S } +{ 0 MAX-INT M* -> 0 S>D } +{ 1 MAX-INT M* -> MAX-INT S>D } +{ 2 MAX-INT M* -> MAX-INT 1 LSHIFT 0 } +{ MIN-INT MIN-INT M* -> 0 MSB 1 RSHIFT } +{ MAX-INT MIN-INT M* -> MSB MSB 2/ } +{ MAX-INT MAX-INT M* -> 1 MSB 2/ INVERT } + +{ 0 0 * -> 0 } \ TEST IDENTITIES +{ 0 1 * -> 0 } +{ 1 0 * -> 0 } +{ 1 2 * -> 2 } +{ 2 1 * -> 2 } +{ 3 3 * -> 9 } +{ -3 3 * -> -9 } +{ 3 -3 * -> -9 } +{ -3 -3 * -> 9 } + +{ MID-UINT+1 1 RSHIFT 2 * -> MID-UINT+1 } +{ MID-UINT+1 2 RSHIFT 4 * -> MID-UINT+1 } +{ MID-UINT+1 1 RSHIFT MID-UINT+1 OR 2 * -> MID-UINT+1 } + +{ 0 0 UM* -> 0 0 } +{ 0 1 UM* -> 0 0 } +{ 1 0 UM* -> 0 0 } +{ 1 2 UM* -> 2 0 } +{ 2 1 UM* -> 2 0 } +{ 3 3 UM* -> 9 0 } + +{ MID-UINT+1 1 RSHIFT 2 UM* -> MID-UINT+1 0 } +{ MID-UINT+1 2 UM* -> 0 1 } +{ MID-UINT+1 4 UM* -> 0 2 } +{ 1S 2 UM* -> 1S 1 LSHIFT 1 } +{ MAX-UINT MAX-UINT UM* -> 1 1 INVERT } + +\ ------------------------------------------------------------------------ +TESTING DIVIDE: FM/MOD SM/REM UM/MOD */ */MOD / /MOD MOD + +{ 0 S>D 1 FM/MOD -> 0 0 } +{ 1 S>D 1 FM/MOD -> 0 1 } +{ 2 S>D 1 FM/MOD -> 0 2 } +{ -1 S>D 1 FM/MOD -> 0 -1 } +{ -2 S>D 1 FM/MOD -> 0 -2 } +{ 0 S>D -1 FM/MOD -> 0 0 } +{ 1 S>D -1 FM/MOD -> 0 -1 } +{ 2 S>D -1 FM/MOD -> 0 -2 } +{ -1 S>D -1 FM/MOD -> 0 1 } +{ -2 S>D -1 FM/MOD -> 0 2 } +{ 2 S>D 2 FM/MOD -> 0 1 } +{ -1 S>D -1 FM/MOD -> 0 1 } +{ -2 S>D -2 FM/MOD -> 0 1 } +{ 7 S>D 3 FM/MOD -> 1 2 } +{ 7 S>D -3 FM/MOD -> -2 -3 } +{ -7 S>D 3 FM/MOD -> 2 -3 } +{ -7 S>D -3 FM/MOD -> -1 2 } +{ MAX-INT S>D 1 FM/MOD -> 0 MAX-INT } +{ MIN-INT S>D 1 FM/MOD -> 0 MIN-INT } +{ MAX-INT S>D MAX-INT FM/MOD -> 0 1 } +{ MIN-INT S>D MIN-INT FM/MOD -> 0 1 } +{ 1S 1 4 FM/MOD -> 3 MAX-INT } +{ 1 MIN-INT M* 1 FM/MOD -> 0 MIN-INT } +{ 1 MIN-INT M* MIN-INT FM/MOD -> 0 1 } +{ 2 MIN-INT M* 2 FM/MOD -> 0 MIN-INT } +{ 2 MIN-INT M* MIN-INT FM/MOD -> 0 2 } +{ 1 MAX-INT M* 1 FM/MOD -> 0 MAX-INT } +{ 1 MAX-INT M* MAX-INT FM/MOD -> 0 1 } +{ 2 MAX-INT M* 2 FM/MOD -> 0 MAX-INT } +{ 2 MAX-INT M* MAX-INT FM/MOD -> 0 2 } +{ MIN-INT MIN-INT M* MIN-INT FM/MOD -> 0 MIN-INT } +{ MIN-INT MAX-INT M* MIN-INT FM/MOD -> 0 MAX-INT } +{ MIN-INT MAX-INT M* MAX-INT FM/MOD -> 0 MIN-INT } +{ MAX-INT MAX-INT M* MAX-INT FM/MOD -> 0 MAX-INT } + +{ 0 S>D 1 SM/REM -> 0 0 } +{ 1 S>D 1 SM/REM -> 0 1 } +{ 2 S>D 1 SM/REM -> 0 2 } +{ -1 S>D 1 SM/REM -> 0 -1 } +{ -2 S>D 1 SM/REM -> 0 -2 } +{ 0 S>D -1 SM/REM -> 0 0 } +{ 1 S>D -1 SM/REM -> 0 -1 } +{ 2 S>D -1 SM/REM -> 0 -2 } +{ -1 S>D -1 SM/REM -> 0 1 } +{ -2 S>D -1 SM/REM -> 0 2 } +{ 2 S>D 2 SM/REM -> 0 1 } +{ -1 S>D -1 SM/REM -> 0 1 } +{ -2 S>D -2 SM/REM -> 0 1 } +{ 7 S>D 3 SM/REM -> 1 2 } +{ 7 S>D -3 SM/REM -> 1 -2 } +{ -7 S>D 3 SM/REM -> -1 -2 } +{ -7 S>D -3 SM/REM -> -1 2 } +{ MAX-INT S>D 1 SM/REM -> 0 MAX-INT } +{ MIN-INT S>D 1 SM/REM -> 0 MIN-INT } +{ MAX-INT S>D MAX-INT SM/REM -> 0 1 } +{ MIN-INT S>D MIN-INT SM/REM -> 0 1 } +{ 1S 1 4 SM/REM -> 3 MAX-INT } +{ 2 MIN-INT M* 2 SM/REM -> 0 MIN-INT } +{ 2 MIN-INT M* MIN-INT SM/REM -> 0 2 } +{ 2 MAX-INT M* 2 SM/REM -> 0 MAX-INT } +{ 2 MAX-INT M* MAX-INT SM/REM -> 0 2 } +{ MIN-INT MIN-INT M* MIN-INT SM/REM -> 0 MIN-INT } +{ MIN-INT MAX-INT M* MIN-INT SM/REM -> 0 MAX-INT } +{ MIN-INT MAX-INT M* MAX-INT SM/REM -> 0 MIN-INT } +{ MAX-INT MAX-INT M* MAX-INT SM/REM -> 0 MAX-INT } + +{ 0 0 1 UM/MOD -> 0 0 } +{ 1 0 1 UM/MOD -> 0 1 } +{ 1 0 2 UM/MOD -> 1 0 } +{ 3 0 2 UM/MOD -> 1 1 } +{ MAX-UINT 2 UM* 2 UM/MOD -> 0 MAX-UINT } +{ MAX-UINT 2 UM* MAX-UINT UM/MOD -> 0 2 } +{ MAX-UINT MAX-UINT UM* MAX-UINT UM/MOD -> 0 MAX-UINT } + +: IFFLOORED + [ -3 2 / -2 = INVERT ] LITERAL IF POSTPONE \ THEN ; +: IFSYM + [ -3 2 / -1 = INVERT ] LITERAL IF POSTPONE \ THEN ; + +\ THE SYSTEM MIGHT DO EITHER FLOORED OR SYMMETRIC DIVISION. +\ SINCE WE HAVE ALREADY TESTED M*, FM/MOD, AND SM/REM WE CAN USE THEM IN TEST. +IFFLOORED : T/MOD >R S>D R> FM/MOD ; +IFFLOORED : T/ T/MOD SWAP DROP ; +IFFLOORED : TMOD T/MOD DROP ; +IFFLOORED : T*/MOD >R M* R> FM/MOD ; +IFFLOORED : T*/ T*/MOD SWAP DROP ; +IFSYM : T/MOD >R S>D R> SM/REM ; +IFSYM : T/ T/MOD SWAP DROP ; +IFSYM : TMOD T/MOD DROP ; +IFSYM : T*/MOD >R M* R> SM/REM ; +IFSYM : T*/ T*/MOD SWAP DROP ; + +{ 0 1 /MOD -> 0 1 T/MOD } +{ 1 1 /MOD -> 1 1 T/MOD } +{ 2 1 /MOD -> 2 1 T/MOD } +{ -1 1 /MOD -> -1 1 T/MOD } +{ -2 1 /MOD -> -2 1 T/MOD } +{ 0 -1 /MOD -> 0 -1 T/MOD } +{ 1 -1 /MOD -> 1 -1 T/MOD } +{ 2 -1 /MOD -> 2 -1 T/MOD } +{ -1 -1 /MOD -> -1 -1 T/MOD } +{ -2 -1 /MOD -> -2 -1 T/MOD } +{ 2 2 /MOD -> 2 2 T/MOD } +{ -1 -1 /MOD -> -1 -1 T/MOD } +{ -2 -2 /MOD -> -2 -2 T/MOD } +{ 7 3 /MOD -> 7 3 T/MOD } +{ 7 -3 /MOD -> 7 -3 T/MOD } +{ -7 3 /MOD -> -7 3 T/MOD } +{ -7 -3 /MOD -> -7 -3 T/MOD } +{ MAX-INT 1 /MOD -> MAX-INT 1 T/MOD } +{ MIN-INT 1 /MOD -> MIN-INT 1 T/MOD } +{ MAX-INT MAX-INT /MOD -> MAX-INT MAX-INT T/MOD } +{ MIN-INT MIN-INT /MOD -> MIN-INT MIN-INT T/MOD } + +{ 0 1 / -> 0 1 T/ } +{ 1 1 / -> 1 1 T/ } +{ 2 1 / -> 2 1 T/ } +{ -1 1 / -> -1 1 T/ } +{ -2 1 / -> -2 1 T/ } +{ 0 -1 / -> 0 -1 T/ } +{ 1 -1 / -> 1 -1 T/ } +{ 2 -1 / -> 2 -1 T/ } +{ -1 -1 / -> -1 -1 T/ } +{ -2 -1 / -> -2 -1 T/ } +{ 2 2 / -> 2 2 T/ } +{ -1 -1 / -> -1 -1 T/ } +{ -2 -2 / -> -2 -2 T/ } +{ 7 3 / -> 7 3 T/ } +{ 7 -3 / -> 7 -3 T/ } +{ -7 3 / -> -7 3 T/ } +{ -7 -3 / -> -7 -3 T/ } +{ MAX-INT 1 / -> MAX-INT 1 T/ } +{ MIN-INT 1 / -> MIN-INT 1 T/ } +{ MAX-INT MAX-INT / -> MAX-INT MAX-INT T/ } +{ MIN-INT MIN-INT / -> MIN-INT MIN-INT T/ } + +{ 0 1 MOD -> 0 1 TMOD } +{ 1 1 MOD -> 1 1 TMOD } +{ 2 1 MOD -> 2 1 TMOD } +{ -1 1 MOD -> -1 1 TMOD } +{ -2 1 MOD -> -2 1 TMOD } +{ 0 -1 MOD -> 0 -1 TMOD } +{ 1 -1 MOD -> 1 -1 TMOD } +{ 2 -1 MOD -> 2 -1 TMOD } +{ -1 -1 MOD -> -1 -1 TMOD } +{ -2 -1 MOD -> -2 -1 TMOD } +{ 2 2 MOD -> 2 2 TMOD } +{ -1 -1 MOD -> -1 -1 TMOD } +{ -2 -2 MOD -> -2 -2 TMOD } +{ 7 3 MOD -> 7 3 TMOD } +{ 7 -3 MOD -> 7 -3 TMOD } +{ -7 3 MOD -> -7 3 TMOD } +{ -7 -3 MOD -> -7 -3 TMOD } +{ MAX-INT 1 MOD -> MAX-INT 1 TMOD } +{ MIN-INT 1 MOD -> MIN-INT 1 TMOD } +{ MAX-INT MAX-INT MOD -> MAX-INT MAX-INT TMOD } +{ MIN-INT MIN-INT MOD -> MIN-INT MIN-INT TMOD } + +{ 0 2 1 */ -> 0 2 1 T*/ } +{ 1 2 1 */ -> 1 2 1 T*/ } +{ 2 2 1 */ -> 2 2 1 T*/ } +{ -1 2 1 */ -> -1 2 1 T*/ } +{ -2 2 1 */ -> -2 2 1 T*/ } +{ 0 2 -1 */ -> 0 2 -1 T*/ } +{ 1 2 -1 */ -> 1 2 -1 T*/ } +{ 2 2 -1 */ -> 2 2 -1 T*/ } +{ -1 2 -1 */ -> -1 2 -1 T*/ } +{ -2 2 -1 */ -> -2 2 -1 T*/ } +{ 2 2 2 */ -> 2 2 2 T*/ } +{ -1 2 -1 */ -> -1 2 -1 T*/ } +{ -2 2 -2 */ -> -2 2 -2 T*/ } +{ 7 2 3 */ -> 7 2 3 T*/ } +{ 7 2 -3 */ -> 7 2 -3 T*/ } +{ -7 2 3 */ -> -7 2 3 T*/ } +{ -7 2 -3 */ -> -7 2 -3 T*/ } +{ MAX-INT 2 MAX-INT */ -> MAX-INT 2 MAX-INT T*/ } +{ MIN-INT 2 MIN-INT */ -> MIN-INT 2 MIN-INT T*/ } + +{ 0 2 1 */MOD -> 0 2 1 T*/MOD } +{ 1 2 1 */MOD -> 1 2 1 T*/MOD } +{ 2 2 1 */MOD -> 2 2 1 T*/MOD } +{ -1 2 1 */MOD -> -1 2 1 T*/MOD } +{ -2 2 1 */MOD -> -2 2 1 T*/MOD } +{ 0 2 -1 */MOD -> 0 2 -1 T*/MOD } +{ 1 2 -1 */MOD -> 1 2 -1 T*/MOD } +{ 2 2 -1 */MOD -> 2 2 -1 T*/MOD } +{ -1 2 -1 */MOD -> -1 2 -1 T*/MOD } +{ -2 2 -1 */MOD -> -2 2 -1 T*/MOD } +{ 2 2 2 */MOD -> 2 2 2 T*/MOD } +{ -1 2 -1 */MOD -> -1 2 -1 T*/MOD } +{ -2 2 -2 */MOD -> -2 2 -2 T*/MOD } +{ 7 2 3 */MOD -> 7 2 3 T*/MOD } +{ 7 2 -3 */MOD -> 7 2 -3 T*/MOD } +{ -7 2 3 */MOD -> -7 2 3 T*/MOD } +{ -7 2 -3 */MOD -> -7 2 -3 T*/MOD } +{ MAX-INT 2 MAX-INT */MOD -> MAX-INT 2 MAX-INT T*/MOD } +{ MIN-INT 2 MIN-INT */MOD -> MIN-INT 2 MIN-INT T*/MOD } + +\ ------------------------------------------------------------------------ +TESTING HERE , @ ! CELL+ CELLS C, C@ C! CHARS 2@ 2! ALIGN ALIGNED +! ALLOT + +HERE 1 ALLOT +HERE +CONSTANT 2NDA +CONSTANT 1STA +{ 1STA 2NDA U< -> <TRUE> } \ HERE MUST GROW WITH ALLOT +{ 1STA 1+ -> 2NDA } \ ... BY ONE ADDRESS UNIT +( MISSING TEST: NEGATIVE ALLOT ) + +HERE 1 , +HERE 2 , +CONSTANT 2ND +CONSTANT 1ST +{ 1ST 2ND U< -> <TRUE> } \ HERE MUST GROW WITH ALLOT +{ 1ST CELL+ -> 2ND } \ ... BY ONE CELL +{ 1ST 1 CELLS + -> 2ND } +{ 1ST @ 2ND @ -> 1 2 } +{ 5 1ST ! -> } +{ 1ST @ 2ND @ -> 5 2 } +{ 6 2ND ! -> } +{ 1ST @ 2ND @ -> 5 6 } +{ 1ST 2@ -> 6 5 } +{ 2 1 1ST 2! -> } +{ 1ST 2@ -> 2 1 } +{ 1S 1ST ! 1ST @ -> 1S } \ CAN STORE CELL-WIDE VALUE + +HERE 1 C, +HERE 2 C, +CONSTANT 2NDC +CONSTANT 1STC +{ 1STC 2NDC U< -> <TRUE> } \ HERE MUST GROW WITH ALLOT +{ 1STC CHAR+ -> 2NDC } \ ... BY ONE CHAR +{ 1STC 1 CHARS + -> 2NDC } +{ 1STC C@ 2NDC C@ -> 1 2 } +{ 3 1STC C! -> } +{ 1STC C@ 2NDC C@ -> 3 2 } +{ 4 2NDC C! -> } +{ 1STC C@ 2NDC C@ -> 3 4 } + +ALIGN 1 ALLOT HERE ALIGN HERE 3 CELLS ALLOT +CONSTANT A-ADDR CONSTANT UA-ADDR +{ UA-ADDR ALIGNED -> A-ADDR } +{ 1 A-ADDR C! A-ADDR C@ -> 1 } +{ 1234 A-ADDR ! A-ADDR @ -> 1234 } +{ 123 456 A-ADDR 2! A-ADDR 2@ -> 123 456 } +{ 2 A-ADDR CHAR+ C! A-ADDR CHAR+ C@ -> 2 } +{ 3 A-ADDR CELL+ C! A-ADDR CELL+ C@ -> 3 } +{ 1234 A-ADDR CELL+ ! A-ADDR CELL+ @ -> 1234 } +{ 123 456 A-ADDR CELL+ 2! A-ADDR CELL+ 2@ -> 123 456 } + +: BITS ( X -- U ) + 0 SWAP BEGIN DUP WHILE DUP MSB AND IF >R 1+ R> THEN 2* REPEAT DROP ; +( CHARACTERS >= 1 AU, <= SIZE OF CELL, >= 8 BITS ) +{ 1 CHARS 1 < -> <FALSE> } +{ 1 CHARS 1 CELLS > -> <FALSE> } +( TBD: HOW TO FIND NUMBER OF BITS? ) + +( CELLS >= 1 AU, INTEGRAL MULTIPLE OF CHAR SIZE, >= 16 BITS ) +{ 1 CELLS 1 < -> <FALSE> } +{ 1 CELLS 1 CHARS MOD -> 0 } +{ 1S BITS 10 < -> <FALSE> } + +{ 0 1ST ! -> } +{ 1 1ST +! -> } +{ 1ST @ -> 1 } +{ -1 1ST +! 1ST @ -> 0 } + +\ ------------------------------------------------------------------------ +TESTING CHAR [CHAR] [ ] BL S" + +{ BL -> 20 } +{ CHAR X -> 58 } +{ CHAR HELLO -> 48 } +{ : GC1 [CHAR] X ; -> } +{ : GC2 [CHAR] HELLO ; -> } +{ GC1 -> 58 } +{ GC2 -> 48 } +{ : GC3 [ GC1 ] LITERAL ; -> } +{ GC3 -> 58 } +{ : GC4 S" XY" ; -> } +{ GC4 SWAP DROP -> 2 } +{ GC4 DROP DUP C@ SWAP CHAR+ C@ -> 58 59 } + +\ ------------------------------------------------------------------------ +TESTING ' ['] FIND EXECUTE IMMEDIATE COUNT LITERAL POSTPONE STATE + +{ : GT1 123 ; -> } +{ ' GT1 EXECUTE -> 123 } +{ : GT2 ['] GT1 ; IMMEDIATE -> } +{ GT2 EXECUTE -> 123 } +HERE 3 C, CHAR G C, CHAR T C, CHAR 1 C, CONSTANT GT1STRING +HERE 3 C, CHAR G C, CHAR T C, CHAR 2 C, CONSTANT GT2STRING +{ GT1STRING FIND -> ' GT1 -1 } +{ GT2STRING FIND -> ' GT2 1 } +( HOW TO SEARCH FOR NON-EXISTENT WORD? ) +{ : GT3 GT2 LITERAL ; -> } +{ GT3 -> ' GT1 } +{ GT1STRING COUNT -> GT1STRING CHAR+ 3 } + +{ : GT4 POSTPONE GT1 ; IMMEDIATE -> } +{ : GT5 GT4 ; -> } +{ GT5 -> 123 } +{ : GT6 345 ; IMMEDIATE -> } +{ : GT7 POSTPONE GT6 ; -> } +{ GT7 -> 345 } + +{ : GT8 STATE @ ; IMMEDIATE -> } +{ GT8 -> 0 } +{ : GT9 GT8 LITERAL ; -> } +{ GT9 0= -> <FALSE> } + +\ ------------------------------------------------------------------------ +TESTING IF ELSE THEN BEGIN WHILE REPEAT UNTIL RECURSE + +{ : GI1 IF 123 THEN ; -> } +{ : GI2 IF 123 ELSE 234 THEN ; -> } +{ 0 GI1 -> } +{ 1 GI1 -> 123 } +{ -1 GI1 -> 123 } +{ 0 GI2 -> 234 } +{ 1 GI2 -> 123 } +{ -1 GI1 -> 123 } + +{ : GI3 BEGIN DUP 5 < WHILE DUP 1+ REPEAT ; -> } +{ 0 GI3 -> 0 1 2 3 4 5 } +{ 4 GI3 -> 4 5 } +{ 5 GI3 -> 5 } +{ 6 GI3 -> 6 } + +{ : GI4 BEGIN DUP 1+ DUP 5 > UNTIL ; -> } +{ 3 GI4 -> 3 4 5 6 } +{ 5 GI4 -> 5 6 } +{ 6 GI4 -> 6 7 } + +{ : GI5 BEGIN DUP 2 > WHILE DUP 5 < WHILE DUP 1+ REPEAT 123 ELSE 345 THEN ; -> } +{ 1 GI5 -> 1 345 } +{ 2 GI5 -> 2 345 } +{ 3 GI5 -> 3 4 5 123 } +{ 4 GI5 -> 4 5 123 } +{ 5 GI5 -> 5 123 } + +{ : GI6 ( N -- 0,1,..N ) DUP IF DUP >R 1- RECURSE R> THEN ; -> } +{ 0 GI6 -> 0 } +{ 1 GI6 -> 0 1 } +{ 2 GI6 -> 0 1 2 } +{ 3 GI6 -> 0 1 2 3 } +{ 4 GI6 -> 0 1 2 3 4 } + +\ ------------------------------------------------------------------------ +TESTING DO LOOP +LOOP I J UNLOOP LEAVE EXIT + +{ : GD1 DO I LOOP ; -> } +{ 4 1 GD1 -> 1 2 3 } +{ 2 -1 GD1 -> -1 0 1 } +{ MID-UINT+1 MID-UINT GD1 -> MID-UINT } + +{ : GD2 DO I -1 +LOOP ; -> } +{ 1 4 GD2 -> 4 3 2 1 } +{ -1 2 GD2 -> 2 1 0 -1 } +{ MID-UINT MID-UINT+1 GD2 -> MID-UINT+1 MID-UINT } + +{ : GD3 DO 1 0 DO J LOOP LOOP ; -> } +{ 4 1 GD3 -> 1 2 3 } +{ 2 -1 GD3 -> -1 0 1 } +{ MID-UINT+1 MID-UINT GD3 -> MID-UINT } + +{ : GD4 DO 1 0 DO J LOOP -1 +LOOP ; -> } +{ 1 4 GD4 -> 4 3 2 1 } +{ -1 2 GD4 -> 2 1 0 -1 } +{ MID-UINT MID-UINT+1 GD4 -> MID-UINT+1 MID-UINT } + +{ : GD5 123 SWAP 0 DO I 4 > IF DROP 234 LEAVE THEN LOOP ; -> } +{ 1 GD5 -> 123 } +{ 5 GD5 -> 123 } +{ 6 GD5 -> 234 } + +{ : GD6 ( PAT: {0 0},{0 0}{1 0}{1 1},{0 0}{1 0}{1 1}{2 0}{2 1}{2 2} ) + 0 SWAP 0 DO + I 1+ 0 DO I J + 3 = IF I UNLOOP I UNLOOP EXIT THEN 1+ LOOP + LOOP ; -> } +{ 1 GD6 -> 1 } +{ 2 GD6 -> 3 } +{ 3 GD6 -> 4 1 2 } + +\ ------------------------------------------------------------------------ +TESTING DEFINING WORDS: : ; CONSTANT VARIABLE CREATE DOES> >BODY + +{ 123 CONSTANT X123 -> } +{ X123 -> 123 } +{ : EQU CONSTANT ; -> } +{ X123 EQU Y123 -> } +{ Y123 -> 123 } + +{ VARIABLE V1 -> } +{ 123 V1 ! -> } +{ V1 @ -> 123 } + +{ : NOP : POSTPONE ; ; -> } +{ NOP NOP1 NOP NOP2 -> } +{ NOP1 -> } +{ NOP2 -> } + +{ : DOES1 DOES> @ 1 + ; -> } +{ : DOES2 DOES> @ 2 + ; -> } +{ CREATE CR1 -> } +{ CR1 -> HERE } +{ ' CR1 >BODY -> HERE } +{ 1 , -> } +{ CR1 @ -> 1 } +{ DOES1 -> } +{ CR1 -> 2 } +{ DOES2 -> } +{ CR1 -> 3 } + +{ : WEIRD: CREATE DOES> 1 + DOES> 2 + ; -> } +{ WEIRD: W1 -> } +{ ' W1 >BODY -> HERE } +{ W1 -> HERE 1 + } +{ W1 -> HERE 2 + } + +\ ------------------------------------------------------------------------ +TESTING EVALUATE + +: GE1 S" 123" ; IMMEDIATE +: GE2 S" 123 1+" ; IMMEDIATE +: GE3 S" : GE4 345 ;" ; +: GE5 EVALUATE ; IMMEDIATE + +{ GE1 EVALUATE -> 123 } ( TEST EVALUATE IN INTERP. STATE ) +{ GE2 EVALUATE -> 124 } +{ GE3 EVALUATE -> } +{ GE4 -> 345 } + +{ : GE6 GE1 GE5 ; -> } ( TEST EVALUATE IN COMPILE STATE ) +{ GE6 -> 123 } +{ : GE7 GE2 GE5 ; -> } +{ GE7 -> 124 } + +\ ------------------------------------------------------------------------ +TESTING SOURCE >IN WORD + +: GS1 S" SOURCE" 2DUP EVALUATE + >R SWAP >R = R> R> = ; +{ GS1 -> <TRUE> <TRUE> } + +VARIABLE SCANS +: RESCAN? -1 SCANS +! SCANS @ IF 0 >IN ! THEN ; + +{ 2 SCANS ! +345 RESCAN? +-> 345 345 } + +: GS2 5 SCANS ! S" 123 RESCAN?" EVALUATE ; +{ GS2 -> 123 123 123 123 123 } + +: GS3 WORD COUNT SWAP C@ ; +{ BL GS3 HELLO -> 5 CHAR H } +{ CHAR " GS3 GOODBYE" -> 7 CHAR G } +{ BL GS3 +DROP -> 0 } \ BLANK LINE RETURN ZERO-LENGTH STRING + +: GS4 SOURCE >IN ! DROP ; +{ GS4 123 456 +-> } + +\ ------------------------------------------------------------------------ +TESTING <# # #S #> HOLD SIGN BASE >NUMBER HEX DECIMAL + +: S= \ ( ADDR1 C1 ADDR2 C2 -- T/F ) COMPARE TWO STRINGS. + >R SWAP R@ = IF \ MAKE SURE STRINGS HAVE SAME LENGTH + R> ?DUP IF \ IF NON-EMPTY STRINGS + 0 DO + OVER C@ OVER C@ - IF 2DROP <FALSE> UNLOOP EXIT THEN + SWAP CHAR+ SWAP CHAR+ + LOOP + THEN + 2DROP <TRUE> \ IF WE GET HERE, STRINGS MATCH + ELSE + R> DROP 2DROP <FALSE> \ LENGTHS MISMATCH + THEN ; + +: GP1 <# 41 HOLD 42 HOLD 0 0 #> S" BA" S= ; +{ GP1 -> <TRUE> } + +: GP2 <# -1 SIGN 0 SIGN -1 SIGN 0 0 #> S" --" S= ; +{ GP2 -> <TRUE> } + +: GP3 <# 1 0 # # #> S" 01" S= ; +{ GP3 -> <TRUE> } + +: GP4 <# 1 0 #S #> S" 1" S= ; +{ GP4 -> <TRUE> } + +24 CONSTANT MAX-BASE \ BASE 2 .. 36 +: COUNT-BITS + 0 0 INVERT BEGIN DUP WHILE >R 1+ R> 2* REPEAT DROP ; +COUNT-BITS 2* CONSTANT #BITS-UD \ NUMBER OF BITS IN UD + +: GP5 + BASE @ <TRUE> + MAX-BASE 1+ 2 DO \ FOR EACH POSSIBLE BASE + I BASE ! \ TBD: ASSUMES BASE WORKS + I 0 <# #S #> S" 10" S= AND + LOOP + SWAP BASE ! ; +{ GP5 -> <TRUE> } + +: GP6 + BASE @ >R 2 BASE ! + MAX-UINT MAX-UINT <# #S #> \ MAXIMUM UD TO BINARY + R> BASE ! \ S: C-ADDR U + DUP #BITS-UD = SWAP + 0 DO \ S: C-ADDR FLAG + OVER C@ [CHAR] 1 = AND \ ALL ONES + >R CHAR+ R> + LOOP SWAP DROP ; +{ GP6 -> <TRUE> } + +: GP7 + BASE @ >R MAX-BASE BASE ! + <TRUE> + A 0 DO + I 0 <# #S #> + 1 = SWAP C@ I 30 + = AND AND + LOOP + MAX-BASE A DO + I 0 <# #S #> + 1 = SWAP C@ 41 I A - + = AND AND + LOOP + R> BASE ! ; + +{ GP7 -> <TRUE> } + +\ >NUMBER TESTS +CREATE GN-BUF 0 C, +: GN-STRING GN-BUF 1 ; +: GN-CONSUMED GN-BUF CHAR+ 0 ; +: GN' [CHAR] ' WORD CHAR+ C@ GN-BUF C! GN-STRING ; + +{ 0 0 GN' 0' >NUMBER -> 0 0 GN-CONSUMED } +{ 0 0 GN' 1' >NUMBER -> 1 0 GN-CONSUMED } +{ 1 0 GN' 1' >NUMBER -> BASE @ 1+ 0 GN-CONSUMED } +{ 0 0 GN' -' >NUMBER -> 0 0 GN-STRING } \ SHOULD FAIL TO CONVERT THESE +{ 0 0 GN' +' >NUMBER -> 0 0 GN-STRING } +{ 0 0 GN' .' >NUMBER -> 0 0 GN-STRING } + +: >NUMBER-BASED + BASE @ >R BASE ! >NUMBER R> BASE ! ; + +{ 0 0 GN' 2' 10 >NUMBER-BASED -> 2 0 GN-CONSUMED } +{ 0 0 GN' 2' 2 >NUMBER-BASED -> 0 0 GN-STRING } +{ 0 0 GN' F' 10 >NUMBER-BASED -> F 0 GN-CONSUMED } +{ 0 0 GN' G' 10 >NUMBER-BASED -> 0 0 GN-STRING } +{ 0 0 GN' G' MAX-BASE >NUMBER-BASED -> 10 0 GN-CONSUMED } +{ 0 0 GN' Z' MAX-BASE >NUMBER-BASED -> 23 0 GN-CONSUMED } + +: GN1 \ ( UD BASE -- UD' LEN ) UD SHOULD EQUAL UD' AND LEN SHOULD BE ZERO. + BASE @ >R BASE ! + <# #S #> + 0 0 2SWAP >NUMBER SWAP DROP \ RETURN LENGTH ONLY + R> BASE ! ; +{ 0 0 2 GN1 -> 0 0 0 } +{ MAX-UINT 0 2 GN1 -> MAX-UINT 0 0 } +{ MAX-UINT DUP 2 GN1 -> MAX-UINT DUP 0 } +{ 0 0 MAX-BASE GN1 -> 0 0 0 } +{ MAX-UINT 0 MAX-BASE GN1 -> MAX-UINT 0 0 } +{ MAX-UINT DUP MAX-BASE GN1 -> MAX-UINT DUP 0 } + +: GN2 \ ( -- 16 10 ) + BASE @ >R HEX BASE @ DECIMAL BASE @ R> BASE ! ; +{ GN2 -> 10 A } + +\ ------------------------------------------------------------------------ +TESTING FILL MOVE + +CREATE FBUF 00 C, 00 C, 00 C, +CREATE SBUF 12 C, 34 C, 56 C, +: SEEBUF FBUF C@ FBUF CHAR+ C@ FBUF CHAR+ CHAR+ C@ ; + +{ FBUF 0 20 FILL -> } +{ SEEBUF -> 00 00 00 } + +{ FBUF 1 20 FILL -> } +{ SEEBUF -> 20 00 00 } + +{ FBUF 3 20 FILL -> } +{ SEEBUF -> 20 20 20 } + +{ FBUF FBUF 3 CHARS MOVE -> } \ BIZARRE SPECIAL CASE +{ SEEBUF -> 20 20 20 } + +{ SBUF FBUF 0 CHARS MOVE -> } +{ SEEBUF -> 20 20 20 } + +{ SBUF FBUF 1 CHARS MOVE -> } +{ SEEBUF -> 12 20 20 } + +{ SBUF FBUF 3 CHARS MOVE -> } +{ SEEBUF -> 12 34 56 } + +{ FBUF FBUF CHAR+ 2 CHARS MOVE -> } +{ SEEBUF -> 12 12 34 } + +{ FBUF CHAR+ FBUF 2 CHARS MOVE -> } +{ SEEBUF -> 12 34 34 } + +\ ------------------------------------------------------------------------ +TESTING OUTPUT: . ." CR EMIT SPACE SPACES TYPE U. + +: OUTPUT-TEST + ." YOU SHOULD SEE THE STANDARD GRAPHIC CHARACTERS:" CR + 41 BL DO I EMIT LOOP CR + 61 41 DO I EMIT LOOP CR + 7F 61 DO I EMIT LOOP CR + ." YOU SHOULD SEE 0-9 SEPARATED BY A SPACE:" CR + 9 1+ 0 DO I . LOOP CR + ." YOU SHOULD SEE 0-9 (WITH NO SPACES):" CR + [CHAR] 9 1+ [CHAR] 0 DO I 0 SPACES EMIT LOOP CR + ." YOU SHOULD SEE A-G SEPARATED BY A SPACE:" CR + [CHAR] G 1+ [CHAR] A DO I EMIT SPACE LOOP CR + ." YOU SHOULD SEE 0-5 SEPARATED BY TWO SPACES:" CR + 5 1+ 0 DO I [CHAR] 0 + EMIT 2 SPACES LOOP CR + ." YOU SHOULD SEE TWO SEPARATE LINES:" CR + S" LINE 1" TYPE CR S" LINE 2" TYPE CR + ." YOU SHOULD SEE THE NUMBER RANGES OF SIGNED AND UNSIGNED NUMBERS:" CR + ." SIGNED: " MIN-INT . MAX-INT . CR + ." UNSIGNED: " 0 U. MAX-UINT U. CR +; + +{ OUTPUT-TEST -> } + +\ ------------------------------------------------------------------------ +TESTING INPUT: ACCEPT + +CREATE ABUF 80 CHARS ALLOT + +: ACCEPT-TEST + CR ." PLEASE TYPE UP TO 80 CHARACTERS:" CR + ABUF 80 ACCEPT + CR ." RECEIVED: " [CHAR] " EMIT + ABUF SWAP TYPE [CHAR] " EMIT CR +; + +{ ACCEPT-TEST -> } + +\ ------------------------------------------------------------------------ +TESTING DICTIONARY SEARCH RULES + +{ : GDX 123 ; : GDX GDX 234 ; -> } + +{ GDX -> 123 234 } + + +\ test suite finished. leaving engine. + +bye diff --git a/qemu/roms/openbios/forth/bootstrap/interpreter.fs b/qemu/roms/openbios/forth/bootstrap/interpreter.fs new file mode 100644 index 000000000..51870581f --- /dev/null +++ b/qemu/roms/openbios/forth/bootstrap/interpreter.fs @@ -0,0 +1,175 @@ +\ tag: forth interpreter +\ +\ Copyright (C) 2003 Stefan Reinauer +\ +\ See the file "COPYING" for further information about +\ the copyright and warranty status of this work. +\ + + +\ +\ 7.3.4.6 Display pause +\ + +0 value interactive? +0 value terminate? + +: exit? + interactive? 0= if + false exit + then + false \ FIXME we should check whether to interrupt output + \ and ask the user how to proceed. + ; + + +\ +\ 7.3.9.1 Defining words +\ + +: forget + s" This word is obsolescent." type cr + ['] ' execute + cell - dup + @ dup + last ! latest ! + here! + ; + +\ +\ 7.3.9.2.4 Miscellaneous dictionary +\ + +\ interpreter. This word checks whether the interpreted word +\ is a word in dictionary or a number. It honours compile mode +\ and immediate/compile-only words. + +: interpret + 0 >in ! + begin + parse-word dup 0> \ was there a word at all? + while + $find + if + dup flags? 0<> state @ 0= or if + execute + else + , \ compile mode && !immediate + then + else \ word is not known. maybe it's a number + 2dup $number + if + span @ >in ! \ if we encountered an error, don't continue parsing + type 3a emit + -13 throw + else + -rot 2drop 1 handle-lit + then + then + depth 200 >= if -3 throw then + depth 0< if -4 throw then + rdepth 200 >= if -5 throw then + rdepth 0< if -6 throw then + repeat + 2drop + ; + +: refill ( -- ) + ib #ib @ expect 0 >in ! ; + +: print-status ( exception -- ) + space + ?dup if + dup sys-debug \ system debug hook + case + -1 of s" Aborted." type endof + -2 of s" Aborted." type endof + -3 of s" Stack Overflow." type 0 depth! endof + -4 of s" Stack Underflow." type 0 depth! endof + -5 of s" Return Stack Overflow." type endof + -6 of s" Return Stack Underflow." type endof + -13 of s" undefined word." type endof + -15 of s" out of memory." type endof + -21 of s" undefined method." type endof + -22 of s" no such device." type endof + dup s" Exception #" type . + 0 state ! + endcase + else + state @ 0= if + s" ok" + else + s" compiled" + then + type + then + cr + ; + +defer status +['] noop ['] status (to) + +: print-prompt + status + depth . 3e emit space + ; + +defer outer-interpreter +:noname + cr + begin + print-prompt + source 0 fill \ clean input buffer + refill + + ['] interpret catch print-status + terminate? + until +; ['] outer-interpreter (to) + +\ +\ 7.3.8.5 Other control flow commands +\ + +: save-source ( -- ) + r> \ fetch our caller + ib >r #ib @ >r \ save current input buffer + source-id >r \ and all variables + span @ >r \ associated with it. + >in @ >r + >r \ move back our caller + ; + +: restore-source ( -- ) + r> + r> >in ! + r> span ! + r> ['] source-id (to) + r> #ib ! + r> ['] ib (to) + >r + ; + +: (evaluate) ( str len -- ??? ) + save-source + -1 ['] source-id (to) + dup + #ib ! span ! + ['] ib (to) + interpret + restore-source + ; + +: evaluate ( str len -- ?? ) + 2dup + -rot + over + over do + i c@ 0a = if + i over - + (evaluate) + i 1+ + then + loop + swap over - (evaluate) + ; + +: eval evaluate ; diff --git a/qemu/roms/openbios/forth/bootstrap/memory.fs b/qemu/roms/openbios/forth/bootstrap/memory.fs new file mode 100644 index 000000000..6fa4a2cc7 --- /dev/null +++ b/qemu/roms/openbios/forth/bootstrap/memory.fs @@ -0,0 +1,216 @@ +\ tag: forth memory allocation +\ +\ Copyright (C) 2002-2003 Stefan Reinauer +\ +\ See the file "COPYING" for further information about +\ the copyright and warranty status of this work. +\ + +\ 7.3.3.2 memory allocation + +\ these need to be initialized by the forth kernel by now. +variable start-mem 0 start-mem ! \ start of memory +variable end-mem 0 end-mem ! \ end of memory +variable free-list 0 free-list ! \ free list head + +\ initialize necessary variables and write a valid +\ free-list entry containing all of the memory. +\ start-mem: pointer to start of memory. +\ end-mem: pointer to end of memory. +\ free-list: head of linked free list + +: init-mem ( start-addr size ) + over dup + start-mem ! \ write start-mem + free-list ! \ write first freelist entry + 2dup /n - swap ! \ write 'len' entry + over cell+ 0 swap ! \ write 'next' entry + + end-mem ! \ write end-mem + ; + +\ -------------------------------------------------------------------- + +\ return pointer to smallest free block that contains +\ at least nb bytes and the block previous the the +\ actual block. On failure the pointer to the smallest +\ free block is 0. + +: smallest-free-block ( nb -- prev ptr | 0 0 ) + 0 free-list @ + fffffff 0 0 >r >r >r + begin + dup + while + ( nb prev pp R: best_nb best_pp ) + dup @ 3 pick r@ within if + ( nb prev pp ) + r> r> r> 3drop \ drop old smallest + 2dup >r >r dup @ >r \ new smallest + then + nip dup \ prev = pp + cell + @ \ pp = pp->next + repeat + 3drop r> drop r> r> +; + + +\ -------------------------------------------------------------------- + +\ allocate size bytes of memory +\ return pointer to memory (or throws an exception on failure). + +: alloc-mem ( size -- addr ) + + \ make it legal (and fast) to allocate 0 bytes + dup 0= if exit then + + aligned \ keep memory aligned. + dup smallest-free-block \ look up smallest free block. + + dup 0= if + \ 2drop + -15 throw \ out of memory + then + + ( al-size prev addr ) + + \ If the smallest fitting block found is bigger than + \ the size of the requested block plus 2*cellsize we + \ can split the block in 2 parts. otherwise return a + \ slightly bigger block than requested. + + dup @ ( d->len ) 3 pick cell+ cell+ > if + + \ splitting the block in 2 pieces. + \ new block = old block + len field + size of requested mem + dup 3 pick cell+ + ( al-size prev addr nd ) + + \ new block len = old block len - req. mem size - 1 cell + over @ ( al-size prev addr nd addr->len ) + 4 pick ( ... al-size ) + cell+ - ( al-size prev addr nd nd nd->len ) + over ! ( al-size prev addr nd ) + + over cell+ @ ( al-size prev addr nd addr->next ) + \ write addr->next to nd->next + over cell+ ! ( al-size prev addr nd ) + over 4 pick swap ! + else + \ don't split the block, it's too small. + dup cell+ @ + then + + ( al-size prev addr nd ) + + \ If the free block we got is the first one rewrite free-list + \ pointer instead of the previous entry's next field. + rot dup 0= if drop free-list else cell+ then + ( al-size addr nd prev->next|fl ) + ! + nip cell+ \ remove al-size and skip len field of returned pointer + + ; + + +\ -------------------------------------------------------------------- + +\ free block given by addr. The length of the +\ given block is stored at addr - cellsize. +\ +\ merge with blocks to the left and right +\ immediately, if they are free. + +: free-mem ( addr len -- ) + + \ we define that it is legal to free 0-byte areas + 0= if drop exit then + ( addr ) + + \ check if the address to free is somewhere within + \ our available memory. This fails badly on discontigmem + \ architectures. If we need more RAM than fits on one + \ contiguous memory area we are too bloated anyways. ;) + + dup start-mem @ end-mem @ within 0= if + \ ." free-mem: no such memory: 0x" u. cr + exit + then + + /n - \ get real block address + 0 free-list @ ( addr prev l ) + + begin \ now scan the free list + dup 0<> if \ only check len, if block ptr != 0 + dup dup @ cell+ + 3 pick < + else + false + then + while + nip dup \ prev=l + cell+ @ \ l=l->next + repeat + + ( addr prev l ) + + dup 0<> if \ do we have free memory to merge with? + + dup dup @ cell+ + 3 pick = if \ hole hit. adding bytes. + \ freeaddr = end of current block -> merge + ( addr prev l ) + rot @ cell+ ( prev l f->len+cellsize ) + over @ + \ add l->len + over ! ( prev l ) + swap over cell+ @ \ f = l; l = l->next; + + \ The free list is sorted by addresses. When merging at the + \ start of our block we might also want to merge at the end + \ of it. Therefore we fall through to the next border check + \ instead of returning. + true \ fallthrough value + else + false \ no fallthrough + then + >r \ store fallthrough on ret stack + + ( addr prev l ) + + dup 3 pick dup @ cell+ + = if \ hole hit. real merging. + \ current block starts where block to free ends. + \ end of free block addr = current block -> merge and exit + ( addr prev l ) + 2 pick dup @ ( f f->len ) + 2 pick @ cell+ + ( f newlen ) + swap ! ( addr prev l ) + 3dup drop + 0= if + free-list + else + 2 pick cell+ + then ( value prev->next|free-list ) + ! ( addr prev l ) + cell+ @ rot ( prev l->next addr ) + cell+ ! drop + r> drop exit \ clean up return stack + then + + r> if 3drop exit then \ fallthrough? -> exit + then + + \ loose block - hang it before current. + + ( addr prev l ) + + \ hang block to free in front of the current entry. + dup 3 pick cell+ ! \ f->next = l; + free-list @ = if \ is block to free new list head? + over free-list ! + then + + ( addr prev ) + dup 0<> if \ if (prev) prev->next=f + cell+ ! + else + 2drop \ no fixup needed. clean up. + then + + ; diff --git a/qemu/roms/openbios/forth/bootstrap/start.fs b/qemu/roms/openbios/forth/bootstrap/start.fs new file mode 100644 index 000000000..9aabfa2c4 --- /dev/null +++ b/qemu/roms/openbios/forth/bootstrap/start.fs @@ -0,0 +1,69 @@ +\ tag: forth bootstrap starter. +\ +\ Copyright (C) 2003 Patrick Mauritz, Stefan Reinauer +\ +\ See the file "COPYING" for further information about +\ the copyright and warranty status of this work. +\ + +include bootstrap.fs \ all base words +include interpreter.fs \ interpreter +include builtin.fs \ builtin terminal. + +: include ( >filename<eol> -- ) + linefeed parse $include +; + +: encode-file ( >filename< > -- dictptr size ) + parse-word $encode-file +; + +: bye + s" Farewell!" cr type cr cr + 0 rdepth! + ; + +\ quit starts the outer interpreter of the forth system. +\ zech describes quit as being the outer interpreter, but +\ we split it apart to keep the interpreter elsewhere. + +: quit ( -- ) + 2 rdepth! + outer-interpreter +; + +\ initialize is the first forth word run by the kernel. +\ this word is automatically executed by the C core on start +\ and it's never left unless something goes really wrong or +\ the user decides to leave the engine. + +variable init-chain + +\ :noname <definition> ; initializer +: initializer ( xt -- ) + here swap , 0 , \ xt, next + init-chain + begin dup @ while @ na1+ repeat + ! +; + +: initialize-forth ( startmem endmem -- ) + over - init-mem + init-pockets + init-tmp-comp + init-builtin-terminal + + init-chain @ \ execute initializers + begin dup while + dup @ execute + na1+ @ + repeat + drop +; + +\ compiler entrypoint +: initialize ( startmem endmem -- ) + initialize-forth + s" OpenBIOS kernel started." type cr + quit +; diff --git a/qemu/roms/openbios/forth/build.xml b/qemu/roms/openbios/forth/build.xml new file mode 100644 index 000000000..0d699c935 --- /dev/null +++ b/qemu/roms/openbios/forth/build.xml @@ -0,0 +1,13 @@ +<?xml version="1.0" ?> + +<build> + <!-- don't change this order --> + <include href="bootstrap/build.xml"/> + <include href="lib/build.xml"/> + <include href="device/build.xml"/> + <include href="debugging/build.xml"/> + <include href="admin/build.xml"/> + <include href="util/build.xml"/> + <include href="packages/build.xml"/> + <include href="system/build.xml"/> +</build> diff --git a/qemu/roms/openbios/forth/debugging/build.xml b/qemu/roms/openbios/forth/debugging/build.xml new file mode 100644 index 000000000..3b9a0ca44 --- /dev/null +++ b/qemu/roms/openbios/forth/debugging/build.xml @@ -0,0 +1,18 @@ +<build> + + <!-- + build description for forth debugging command group + + Copyright (C) 2004-2005 by Stefan Reinauer + See the file "COPYING" for further information about + the copyright and warranty status of this work. + --> + + <dictionary name="openbios" target="forth"> + <object source="client.fs"/> + <object source="fcode.fs"/> + <object source="firmware.fs"/> + <object source="see.fs"/> + </dictionary> + +</build> diff --git a/qemu/roms/openbios/forth/debugging/client.fs b/qemu/roms/openbios/forth/debugging/client.fs new file mode 100644 index 000000000..f37440445 --- /dev/null +++ b/qemu/roms/openbios/forth/debugging/client.fs @@ -0,0 +1,299 @@ +\ 7.6 Client Program Debugging command group + + +\ 7.6.1 Registers display + +: ctrace ( -- ) + ; + +: .registers ( -- ) + ; + +: .fregisters ( -- ) + ; + +\ to ( param [old-name< >] -- ) + + +\ 7.6.2 Program download and execute + +struct ( saved-program-state ) + /n field >sps.entry + /n field >sps.file-size + /n field >sps.file-type +constant saved-program-state.size +create saved-program-state saved-program-state.size allot + +variable state-valid +0 state-valid ! + +variable file-size + +: !load-size file-size ! ; + +: load-size file-size @ ; + + +\ File types identified by (init-program) + +0 constant elf-boot +1 constant elf +2 constant bootinfo +3 constant xcoff +4 constant pe +5 constant aout +10 constant fcode +11 constant forth +12 constant bootcode + + +: init-program ( -- ) + \ Call down to the lower level for relocation etc. + s" (init-program)" $find if + execute + else + s" Unable to locate (init-program)!" type cr + then + ; + +: (find-bootdevice) ( param-str param-len -- bootpath-str bootpath-len) + \ Parse the <param> string which is a space-separated list of one or + \ more potential boot devices, and return the first one that can be + \ successfully opened. + + \ Space-separated bootpath string + bl left-split \ bootpathstr bootpathstr-len bootdevstr bootdevstr-len + dup 0= if + + \ None specified. As per IEEE-1275 specification, search through each value + \ in boot-device and use the first that returns a valid ihandle on open. + + 2drop \ drop the empty device string as we're going to use our own + + s" boot-device" $find drop execute + bl left-split + begin + dup + while + 2dup s" Trying " type type s" ..." type cr + 2dup open-dev ?dup if + close-dev + 2swap drop 0 \ Fake end of string so we exit loop + else + 2drop + bl left-split + then + repeat + 2drop + then + + \ bootargs + 2swap dup 0= if + \ None specified, use default from nvram + 2drop s" boot-file" $find drop execute + then + + \ Set the bootargs property + encode-string + " /chosen" (find-dev) if + " bootargs" rot (property) + then +; + +\ Locate the boot-device opened by this ihandle (currently taken as being +\ the first non-interposed package in the instance chain) + +: ihandle>boot-device-handle ( ihandle -- 0 | device-ihandle -1 ) + >r 0 + begin r> dup >in.my-parent @ dup >r while + ( result ihandle R: ihandle.parent ) + dup >in.interposed @ 0= if + \ Find the first non-interposed package + over 0= if + swap drop + else + drop + then + else + drop + then + repeat + r> drop drop + + dup 0<> if + -1 + then +; + +: $load ( devstr len ) + open-dev ( ihandle ) + dup 0= if + drop + exit + then + dup >r + " load-base" evaluate swap ( load-base ihandle ) + dup ihandle>phandle " load" rot find-method ( xt 0|1 ) + if swap call-package !load-size else cr ." Cannot find load for this package" 2drop then + + \ If the boot device path doesn't contain an explicit partition id, e.g. cd:,\\:tbxi + \ then the interposed partition package may have auto-probed a suitable partition. If + \ this is the case then it will have set the " selected-partition-args" property in + \ the partition package to contain the new device arguments. + \ + \ In order to ensure that bootpath contains the partition argument, we use the contents + \ of this property if it exists to override the boot device arguments when generating + \ the full bootpath using get-instance-path. + + my-self + r@ to my-self + " selected-partition-args" get-inherited-property 0= if + decode-string 2swap 2drop + ( myself-save partargs-str partargs-len ) + r@ ihandle>boot-device-handle if + ( myself-save partargs-str partargs-len block-ihandle ) + \ Override the arguments before get-instance-path + dup >in.arguments 2@ >r >r dup >r ( R: block-ihandle arg-len arg-str ) + >in.arguments 2! ( myself-save ) + r@ " get-instance-path" $find if + execute ( myself-save bootpathstr bootpathlen ) + then + \ Now write the original arguments back + r> r> r> rot >in.arguments 2! ( myself-save bootpathstr bootpathlen R: ) + rot ( bootpathstr bootpathlen myself-save ) + then + else + my-self " get-instance-path" $find if + execute ( myself-save bootpathstr pathlen ) + rot ( bootpathstr bootpathlen myself-save ) + then + then + to my-self + + \ Set bootpath property in /chosen + encode-string " /chosen" (find-dev) if + " bootpath" rot (property) + then + + r> close-dev + init-program + ; + +: load ( "{params}<cr>" -- ) + linefeed parse + (find-bootdevice) + $load +; + +: dir ( "{paths}<cr>" -- ) + linefeed parse + ascii , split-after + 2dup open-dev dup 0= if + drop + cr ." Unable to locate device " type + 2drop + exit + then + -rot 2drop -rot 2 pick + " dir" rot ['] $call-method catch + if + 3drop + cr ." Cannot find dir for this package" + then + close-dev +; + +: go ( -- ) + state-valid @ not if + s" No valid state has been set by load or init-program" type cr + exit + then + + \ Call the architecture-specific code to launch the client image + s" (go)" $find if + execute + else + ." go is not yet implemented" + 2drop + then + ; + + +\ 7.6.3 Abort and resume + +\ already defined !? +\ : go ( -- ) +\ ; + + +\ 7.6.4 Disassembler + +: dis ( addr -- ) + ; + +: +dis ( -- ) + ; + +\ 7.6.5 Breakpoints +: .bp ( -- ) + ; + +: +bp ( addr -- ) + ; + +: -bp ( addr -- ) + ; + +: --bp ( -- ) + ; + +: bpoff ( -- ) + ; + +: step ( -- ) + ; + +: steps ( n -- ) + ; + +: hop ( -- ) + ; + +: hops ( n -- ) + ; + +\ already defined +\ : go ( -- ) +\ ; + +: gos ( n -- ) + ; + +: till ( addr -- ) + ; + +: return ( -- ) + ; + +: .breakpoint ( -- ) + ; + +: .step ( -- ) + ; + +: .instruction ( -- ) + ; + + +\ 7.6.6 Symbolic debugging +: .adr ( addr -- ) + ; + +: sym ( "name< >" -- n ) + ; + +: sym>value ( addr len -- addr len false | n true ) + ; + +: value>sym ( n1 -- n1 false | n2 addr len true ) + ; diff --git a/qemu/roms/openbios/forth/debugging/fcode.fs b/qemu/roms/openbios/forth/debugging/fcode.fs new file mode 100644 index 000000000..76099558d --- /dev/null +++ b/qemu/roms/openbios/forth/debugging/fcode.fs @@ -0,0 +1,14 @@ +\ 7.7 FCode Debugging command group + +\ The user interface versions of these FCode functions allow +\ the user to debug FCode programs by providing named commands +\ corresponding to FCode functions. + +: headerless ( -- ) + ; + +: headers ( -- ) + ; + +: apply ( ... "method-name< >device-specifier< >" -- ??? ) + ; diff --git a/qemu/roms/openbios/forth/debugging/firmware.fs b/qemu/roms/openbios/forth/debugging/firmware.fs new file mode 100644 index 000000000..5e16a6c57 --- /dev/null +++ b/qemu/roms/openbios/forth/debugging/firmware.fs @@ -0,0 +1,90 @@ +\ 7.5 Firmware Debugging command group + + +\ 7.5.1 Automatic stack display + +: (.s + depth 0 ?do + depth i - 1- pick . + loop + depth 0<> if ascii < emit space then + ; + +: showstack ( -- ) + ['] (.s to status + ; + +: noshowstack ( -- ) + ['] noop to status + ; + +\ 7.5.2 Serial download + +: dl ( -- ) + ; + + +\ 7.5.3 Dictionary + +\ 7.5.3.1 Dictionary search +: .calls ( xt -- ) + ; + +: $sift ( text-addr text-len -- ) + ; + +: sifting ( "text< >" -- ) + ; + +\ : words ( -- ) +\ \ Implemented in forth bootstrap. +\ ; + + +\ 7.5.3.2 Decompiler + +\ implemented in see.fs + +\ : see ( "old-name< >" -- ) +\ ; + +\ : (see) ( xt -- ) +\ ; + + +\ 7.5.3.3 Patch + +: patch ( "new-name< >old-name< >word-to-patch< >" -- ) + ; + +: (patch) ( new-n1 num1? old-n2 num2? xt -- ) + ; + + +\ 7.5.3.4 Forth source-level debugger + +: debug ( "old-name< >" -- ) + parse-word \ Look up word CFA in dictionary + $find + 0 = if + ." could not locate word for debugging" + 2drop + else + (debug + then + ; + +: stepping ( -- ) + ; + +: tracing ( -- ) + ; + +: debug-off ( -- ) + (debug-off) + ; + +: resume ( -- ) + \ Set interpreter termination flag + 1 to terminate? + ; diff --git a/qemu/roms/openbios/forth/debugging/see.fs b/qemu/roms/openbios/forth/debugging/see.fs new file mode 100644 index 000000000..6977d29eb --- /dev/null +++ b/qemu/roms/openbios/forth/debugging/see.fs @@ -0,0 +1,114 @@ +\ tag: Forth Decompiler +\ +\ this code implements IEEE 1275-1994 ch. 7.5.3.2 +\ +\ Copyright (C) 2003 Stefan Reinauer +\ +\ See the file "COPYING" for further information about +\ the copyright and warranty status of this work. +\ + +1 value (see-indent) + +: (see-cr) + cr (see-indent) spaces + ; + +: indent+ + (see-indent) 2+ to (see-indent) + ; + +: indent- + (see-indent) 2- to (see-indent) + ; + +: (see-colon) + dup ." : " cell - lfa2name type (see-cr) + begin + cell+ dup @ dup ['] (semis) <> + while + space + dup + case + + ['] do?branch of + ." if" (see-cr) indent+ + drop cell+ + endof + + ['] dobranch of + ." then" indent- (see-cr) + drop cell+ + endof + + ['] (begin) of + ." begin" indent+ (see-cr) + drop + endof + + ['] (again) of + ." again" (see-cr) + drop + endof + + ['] (until) of + ." until" (see-cr) + drop + endof + + ['] (while) of + indent- (see-cr) + ." while" + indent+ (see-cr) + drop 2 cells + + endof + + ['] (repeat) of + indent- (see-cr) + ." repeat" + (see-cr) + drop 2 cells + + endof + + ['] (lit) of + ." ( lit ) h# " + drop 1 cells + + dup @ u. + endof + + ['] (") of + 22 emit space drop dup cell+ @ + 2dup swap 2 cells + swap type + 22 emit + + aligned cell+ + endof + + cell - lfa2name type + endcase + repeat + cr ." ;" + 2drop + ; + +: (see) ( xt -- ) + cr + dup @ case + 1 of + (see-colon) + endof + 3 of + ." constant " dup cell - lfa2name type ." = " execute . + endof + 4 of + ." variable " dup cell - lfa2name type ." = " execute @ . + endof + 5 of + ." defer " dup cell - lfa2name type cr + ." is " cell+ @ cell - lfa2name type cr + endof + ." primword " swap cell - lfa2name type + endcase + cr + ; + +: see ' (see) ; diff --git a/qemu/roms/openbios/forth/device/README.device b/qemu/roms/openbios/forth/device/README.device new file mode 100644 index 000000000..0d4d6e58d --- /dev/null +++ b/qemu/roms/openbios/forth/device/README.device @@ -0,0 +1,22 @@ +The code you find here implements the IEEE 1275-1994 Open Firmware +device interface. + +Chapter File Comment +<none> structures.fs generic structures used by 5.3 +5.3.2 <none> defined in user interface +5.3.3 fcode.fs complete, partly untested +5.3.4 package.fs incomplete +5.3.5 property.fs incomplete +5.3.6 display.fs incomplete +5.3.7 other.fs incomplete + +H2 and +5.3.1.1.1 preof.fs pre-IEEE-1275-1994 words + split.fs + pathres.fs path resolution + + table.fs fcode evaluator + feval.fs (byte-load) + + +2003/11/12 Stefan Reinauer <stepan@openbios.org> diff --git a/qemu/roms/openbios/forth/device/build.xml b/qemu/roms/openbios/forth/device/build.xml new file mode 100644 index 000000000..11544964a --- /dev/null +++ b/qemu/roms/openbios/forth/device/build.xml @@ -0,0 +1,31 @@ +<build> + + <!-- + build description for open firmware device interface + + Copyright (C) 2004-2005 by Stefan Reinauer + See the file "COPYING" for further information about + the copyright and warranty status of this work. + --> + + <dictionary name="openbios" target="forth"> + <object source="structures.fs"/> + <object source="fcode.fs"/> + <object source="property.fs"/> + <object source="device.fs"/> + <object source="package.fs"/> + <object source="other.fs"/> + <object source="pathres.fs"/> + <object source="preof.fs"/> + <object source="font.fs"/> + <object source="logo.fs"/> + <object source="display.fs"/> + <object source="terminal.fs"/> + <object source="extra.fs"/> + <object source="feval.fs"/> + <object source="table.fs"/> + <object source="tree.fs"/> + <object source="builtin.fs"/> + </dictionary> + +</build> diff --git a/qemu/roms/openbios/forth/device/builtin.fs b/qemu/roms/openbios/forth/device/builtin.fs new file mode 100644 index 000000000..aaefba87b --- /dev/null +++ b/qemu/roms/openbios/forth/device/builtin.fs @@ -0,0 +1,30 @@ +\ tag: builtin devices +\ +\ this code implements IEEE 1275-1994 +\ +\ Copyright (C) 2003 Stefan Reinauer +\ +\ See the file "COPYING" for further information about +\ the copyright and warranty status of this work. +\ + +\ nodes it's children: + +" /" find-device + +new-device + " builtin" device-name + : open true ; + : close ; + +new-device + " console" device-name + : open true ; + : close ; + : write dup >r bounds ?do i c@ (emit) loop r> ; + : read dup >r bounds ?do (key) i c! loop r> ; +finish-device + +\ clean up afterwards +finish-device +0 active-package! diff --git a/qemu/roms/openbios/forth/device/device.fs b/qemu/roms/openbios/forth/device/device.fs new file mode 100644 index 000000000..562c9196e --- /dev/null +++ b/qemu/roms/openbios/forth/device/device.fs @@ -0,0 +1,202 @@ +\ tag: Package creation and deletion +\ +\ this code implements IEEE 1275-1994 +\ +\ Copyright (C) 2003, 2004 Samuel Rydh +\ +\ See the file "COPYING" for further information about +\ the copyright and warranty status of this work. +\ + +variable device-tree + +\ make defined words globally visible +\ +: external ( -- ) + active-package ?dup if + >dn.methods @ set-current + then +; + +\ make the private wordlist active (not an OF word) +\ +: private ( -- ) + active-package ?dup if + >r + forth-wordlist r@ >dn.methods @ r@ >dn.priv-methods @ 3 set-order + r> >dn.priv-methods @ set-current + then +; + +\ set activate package and make the world visible package wordlist +\ the current one. +\ +: active-package! ( phandle -- ) + dup to active-package + \ locally defined words are not available + ?dup if + forth-wordlist over >dn.methods @ 2 set-order + >dn.methods @ set-current + else + forth-wordlist dup 1 set-order set-current + then +; + + +\ new-device ( -- ) +\ +\ Start new package, as child of active package. +\ Create a new device node as a child of the active package and make the +\ new node the active package. Create a new instance and make it the current +\ instance; the instance that invoked new-device becomes the parent instance +\ of the new instance. +\ Subsequently, newly defined Forth words become the methods of the new node +\ and newly defined data items (such as types variable, value, buffer:, and +\ defer) are allocated and stored within the new instance. + +: new-device ( -- ) + align-tree dev-node.size alloc-tree >r + active-package + dup r@ >dn.parent ! + + \ ( parent ) hook up at the end of the peer list + ?dup if + >dn.child + begin dup @ while @ >dn.peer repeat + r@ swap ! + else + \ we are the root node! + r@ to device-tree + then + + \ ( -- ) fill in device node stuff + inst-node.size r@ >dn.isize ! + + \ create two wordlists + wordlist r@ >dn.methods ! + wordlist r@ >dn.priv-methods ! + + \ initialize template data + r@ >dn.itemplate + r@ over >in.device-node ! + my-self over >in.my-parent ! + + \ make it the active package and current instance + to my-self + r@ active-package! + + \ swtich to public wordlist + external + r> drop +; + +\ helpers for finish-device (OF does not actually define words +\ for device node deletion) + +: (delete-device) \ ( phandle ) + >r + r@ >dn.parent @ + ?dup if + >dn.child \ ( &first-child ) + begin dup @ r@ <> while @ >dn.peer repeat + r@ >dn.peer @ swap ! + else + \ root node + 0 to device-tree + then + + \ XXX: free any memory related to this node. + \ we could have a list with free device-node headers... + r> drop +; + +: delete-device \ ( phandle ) + >r + \ first, get rid of any children + begin r@ >dn.child @ dup while + (delete-device) + repeat + drop + + \ then free this node + r> (delete-device) +; + +\ finish-device ( -- ) +\ +\ Finish this package, set active package to parent. +\ Complete a device node that was created by new-device, as follows: If the +\ device node has no "name" property, remove the device node from the device +\ tree. Otherwise, save the current values of the current instance's +\ initialized data items within the active package for later use in +\ initializing the data items of instances created from that node. In any +\ case, destroy the current instance, make its parent instance the current +\ instance, and select the parent node of the device node just completed, +\ making the parent node the active package again. + +: finish-device \ ( -- ) + my-self + dup >in.device-node @ >r + >in.my-parent @ to my-self + + ( -- ) + r@ >dn.parent @ active-package! + s" name" r@ get-package-property if + \ delete the node (and any children) + r@ delete-device + else + 2drop + \ node OK + then + r> drop +; + + +\ helper function which creates and initializes an instance. +\ open is not called. The current instance is not changed. +\ +: create-instance ( phandle -- ihandle|0 ) + dup >dn.isize @ ['] alloc-mem catch if 2drop 0 exit then + >r + \ we need to save the size in order to be able to release it properly + dup >dn.isize @ r@ >in.alloced-size ! + + \ clear memory (we only need to clear the head; all other data is copied) + r@ inst-node.size 0 fill + + ( phandle R: ihandle ) + + \ instantiate data + dup >dn.methods @ r@ instance-init + dup >dn.priv-methods @ r@ instance-init + + \ instantiate + dup >dn.itemplate r@ inst-node.size move + r@ r@ >in.instance-data ! + my-self r@ >in.my-parent ! + drop + + r> +; + +\ helper function which tears down and frees an instance +: destroy-instance ( ihandle ) + ?dup if + \ free arguments + dup >in.arguments 2@ free-mem + \ and the instance block + dup >in.alloced-size @ + free-mem + then +; + +\ Redefine to word so that statements of the form "0 to active-package" +\ are supported for bootloaders that require it +: to + ['] ' execute + dup ['] active-package = if + drop active-package! + else + (to-xt) + then +; immediate diff --git a/qemu/roms/openbios/forth/device/display.fs b/qemu/roms/openbios/forth/device/display.fs new file mode 100644 index 000000000..fff44e00a --- /dev/null +++ b/qemu/roms/openbios/forth/device/display.fs @@ -0,0 +1,421 @@ +\ tag: Display device management +\ +\ this code implements IEEE 1275-1994 ch. 5.3.6 +\ +\ Copyright (C) 2003 Stefan Reinauer +\ +\ See the file "COPYING" for further information about +\ the copyright and warranty status of this work. +\ + +hex + +\ +\ 5.3.6.1 Terminal emulator routines +\ + +\ The following values are used and set by the terminal emulator +\ defined and described in 3.8.4.2 +0 value line# ( -- line# ) +0 value column# ( -- column# ) +0 value inverse? ( -- white-on-black? ) +0 value inverse-screen? ( -- black? ) +0 value #lines ( -- rows ) +0 value #columns ( -- columns ) + +\ The following values are used internally by both the 1-bit and the +\ 8-bit frame-buffer support routines. + +0 value frame-buffer-adr ( -- addr ) +0 value screen-height ( -- height ) +0 value screen-width ( -- width ) +0 value window-top ( -- border-height ) +0 value window-left ( -- border-width ) +0 value char-height ( -- height ) +0 value char-width ( -- width ) +0 value fontbytes ( -- bytes ) + +\ these values are used internally and do not represent any +\ official open firmware words +0 value char-min +0 value char-num +0 value font + +0 value foreground-color +0 value background-color +create color-palette 100 cells allot + +2 value font-spacing +0 value depth-bits +0 value line-bytes +0 value display-ih + +\ internal values +0 value openbios-video-height +0 value openbios-video-width + +\ The following wordset is called the "defer word interface" of the +\ terminal-emulator support package. It gets overloaded by fb1-install +\ or fb8-install (initiated by the framebuffer fcode driver) + +defer draw-character ( char -- ) +defer reset-screen ( -- ) +defer toggle-cursor ( -- ) +defer erase-screen ( -- ) +defer blink-screen ( -- ) +defer invert-screen ( -- ) +defer insert-characters ( n -- ) +defer delete-characters ( n -- ) +defer insert-lines ( n -- ) +defer delete-lines ( n -- ) +defer draw-logo ( line# addr width height -- ) + +defer fb-emit ( x -- ) + +: depth-bytes ( -- bytes ) + depth-bits 1+ 8 / +; + +\ +\ 5.3.6.2 Frame-buffer support routines +\ + +: default-font ( -- addr width height advance min-char #glyphs ) + (romfont) (romfont-width) (romfont-height) (romfont-height) 0 100 + ; + +: set-font ( addr width height advance min-char #glyphs -- ) + to char-num + to char-min + to fontbytes + font-spacing + to char-height + to char-width + to font + ; + +: >font ( char -- addr ) + char-min - + char-num min + fontbytes * + font + + ; + +\ +\ 5.3.6.3 Display device support +\ + +\ +\ 5.3.6.3.1 Frame-buffer package interface +\ + +: is-install ( xt -- ) + external + \ Create open and other methods for this display device. + \ Methods to be created: open, write, draw-logo, restore + s" open" header + 1 , \ colon definition + , + ['] (lit) , + -1 , + ['] (semis) , + reveal + s" : write dup >r bounds do i c@ fb-emit loop r> ; " evaluate + s" : draw-logo draw-logo ; " evaluate + s" : restore reset-screen ; " evaluate + ; + +: is-remove ( xt -- ) + external + \ Create close method for this display device. + s" close" header + 1 , \ colon definition + , + ['] (semis) , + reveal + ; + +: is-selftest ( xt -- ) + external + \ Create selftest method for this display device. + s" selftest" header + 1 , \ colon definition + , + ['] (semis) , + reveal + ; + + +\ 5.3.6.3.2 Generic one-bit frame-buffer support (optional) + +: fb1-nonimplemented + ." Monochrome framebuffer support is not implemented." cr + end0 + ; + +: fb1-draw-character fb1-nonimplemented ; \ historical +: fb1-reset-screen fb1-nonimplemented ; +: fb1-toggle-cursor fb1-nonimplemented ; +: fb1-erase-screen fb1-nonimplemented ; +: fb1-blink-screen fb1-nonimplemented ; +: fb1-invert-screen fb1-nonimplemented ; +: fb1-insert-characters fb1-nonimplemented ; +: fb1-delete-characters fb1-nonimplemented ; +: fb1-insert-lines fb1-nonimplemented ; +: fb1-delete-lines fb1-nonimplemented ; +: fb1-slide-up fb1-nonimplemented ; +: fb1-draw-logo fb1-nonimplemented ; +: fb1-install fb1-nonimplemented ; + + +\ 5.3.6.3.3 Generic eight-bit frame-buffer support + +\ bind to low-level C function later +defer fb8-blitmask +defer fb8-fillrect +defer fb8-invertrect + +: fb8-line2addr ( line -- addr ) + window-top + + screen-width * depth-bytes * + frame-buffer-adr + + window-left depth-bytes * + +; + +: fb8-curpos2addr ( col line -- addr ) + char-height * fb8-line2addr + swap char-width * depth-bytes * + +; + +: fb8-copy-lines ( count from to -- ) + fb8-line2addr swap + fb8-line2addr swap + #columns char-width * depth-bytes * + 3 pick * move drop +; + +: fb8-clear-lines ( count line -- ) + background-color 0 + 2 pick window-top + + #columns char-width * + 5 pick + fb8-fillrect + 2drop +; + +: fb8-draw-character ( char -- ) + \ erase the current character + background-color + column# char-width * window-left + + line# char-height * window-top + + char-width char-height fb8-fillrect + \ draw the character: + >font + line# char-height * window-top + screen-width * depth-bytes * + column# char-width * depth-bytes * + window-left depth-bytes * + + frame-buffer-adr + + swap char-width char-height font-spacing - + \ normal or inverse? + foreground-color background-color + inverse? if + swap + then + fb8-blitmask + ; + +: fb8-reset-screen ( -- ) + false to inverse? + false to inverse-screen? + 0 to foreground-color + d# 15 to background-color + + \ override with OpenBIOS defaults + fe to background-color + 0 to foreground-color + ; + +: fb8-toggle-cursor ( -- ) + column# char-width * window-left + + line# char-height * window-top + + char-width char-height font-spacing - + foreground-color background-color + fb8-invertrect + ; + +: fb8-erase-screen ( -- ) + inverse-screen? if + foreground-color + else + background-color + then + 0 0 screen-width screen-height + fb8-fillrect + ; + +: fb8-invert-screen ( -- ) + 0 0 screen-width screen-height + background-color foreground-color + fb8-invertrect + ; + +: fb8-blink-screen ( -- ) + fb8-invert-screen 2000 ms + fb8-invert-screen + ; + +: fb8-insert-characters ( n -- ) + \ numcopy = ( #columns - column# - n ) + #columns over - column# - + char-width * depth-bytes * ( n numbytescopy ) + + over column# + line# fb8-curpos2addr + column# line# fb8-curpos2addr ( n numbytescopy destaddr srcaddr ) + char-height 0 do + 3dup swap rot move + line-bytes + swap line-bytes + swap + loop 3drop + + background-color + column# char-width * window-left + line# char-height * window-top + + 3 pick char-width * char-height + fb8-fillrect + drop + ; + +: fb8-delete-characters ( n -- ) + \ numcopy = ( #columns - column# - n ) + #columns over - column# - + char-width * depth-bytes * ( n numbytescopy ) + + over column# + line# fb8-curpos2addr + column# line# fb8-curpos2addr swap ( n numbytescopy destaddr srcaddr ) + char-height 0 do + 3dup swap rot move + line-bytes + swap line-bytes + swap + loop 3drop + + background-color + over #columns swap - char-width * window-left + line# char-height * window-top + + 3 pick char-width * char-height + fb8-fillrect + drop + ; + +: fb8-insert-lines ( n -- ) + \ numcopy = ( #lines - n ) + #lines over - char-height * + over line# char-height * + swap char-height * over + + fb8-copy-lines + + char-height * line# char-height * + fb8-clear-lines + ; + +: fb8-delete-lines ( n -- ) + \ numcopy = ( #lines - ( line# + n )) * char-height + #lines over line# + - char-height * + over line# + char-height * + line# char-height * + fb8-copy-lines + + #lines over - char-height * + dup #lines char-height * swap - swap + fb8-clear-lines + drop +; + + +: fb8-draw-logo ( line# addr width height -- ) + 2swap swap + char-height * window-top + + screen-width * window-left + + frame-buffer-adr + + swap 2swap + \ in-fb-start-adr logo-adr logo-width logo-height + + fb8-blitmask ( fbaddr mask-addr width height -- ) +; + + +: fb8-install ( width height #columns #lines -- ) + + \ set state variables + to #lines + to #columns + to screen-height + to screen-width + + screen-width #columns char-width * - 2/ to window-left + screen-height #lines char-height * - 2/ to window-top + + 0 to column# + 0 to line# + 0 to inverse? + 0 to inverse-screen? + + my-self to display-ih + + \ set /chosen display property + my-self active-package 0 to my-self + " /chosen" (find-dev) 0<> if + active-package! + display-ih encode-int " display" property + then + active-package! to my-self + + \ set defer functions to 8bit versions + + ['] fb8-draw-character to draw-character + ['] fb8-toggle-cursor to toggle-cursor + ['] fb8-erase-screen to erase-screen + ['] fb8-blink-screen to blink-screen + ['] fb8-invert-screen to invert-screen + ['] fb8-insert-characters to insert-characters + ['] fb8-delete-characters to delete-characters + ['] fb8-insert-lines to insert-lines + ['] fb8-delete-lines to delete-lines + ['] fb8-draw-logo to draw-logo + ['] fb8-reset-screen to reset-screen + + \ recommended practice + s" iso6429-1983-colors" get-my-property if + 0 ff + else + 2drop d# 15 0 + then + to foreground-color to background-color + + \ setup palette + 10101 ['] color-palette cell+ ff 0 do + dup 2 pick i * swap ! cell+ + loop 2drop + + \ special background color + ffffcc ['] color-palette cell+ fe cells + ! + + \ load palette onto the hardware + ['] color-palette cell+ ff 0 do + dup @ ff0000 and d# 16 rshift + 1 pick @ ff00 and d# 8 rshift + 2 pick @ ff and + i + s" color!" $find if + execute + else + 2drop + then + cell+ + loop drop + + \ ... but let's override with some better defaults + fe to background-color + 0 to foreground-color + + fb8-erase-screen + + \ If we have a startup splash then display it + [IFDEF] CONFIG_MOL + mol-startup-splash 2000 ms + fb8-erase-screen + [THEN] +; diff --git a/qemu/roms/openbios/forth/device/extra.fs b/qemu/roms/openbios/forth/device/extra.fs new file mode 100644 index 000000000..9ca6b78e3 --- /dev/null +++ b/qemu/roms/openbios/forth/device/extra.fs @@ -0,0 +1,103 @@ +\ tag: Useful device related functions +\ +\ Copyright (C) 2003, 2004 Samuel Rydh +\ +\ See the file "COPYING" for further information about +\ the copyright and warranty status of this work. +\ + + +: parent ( phandle -- parent.phandle|0 ) + >dn.parent @ +; + +\ ------------------------------------------------------------------- +\ property helpers +\ ------------------------------------------------------------------- + +: int-property ( value name-str name-len -- ) + rot encode-int 2swap property +; + +\ ------------------------------------------------------------------------- +\ property utils +\ ------------------------------------------------------------------------- + +\ like property (except it takes a phandle as an argument) +: encode-property ( buf len propname propname-len phandle -- ) + dup 0= abort" null phandle" + + my-self >r 0 to my-self + active-package >r active-package! + + property + + r> active-package! + r> to my-self +; + +\ ------------------------------------------------------------------- +\ device tree iteration +\ ------------------------------------------------------------------- + +: iterate-tree ( phandle -- phandle|0 ) + ?dup 0= if device-tree @ exit then + + \ children first + dup child if + child exit + then + + \ then peers + dup peer if + peer exit + then + + \ then peer of a parent + begin >dn.parent @ dup while + dup peer if peer exit then + repeat +; + +: iterate-tree-begin ( -- first_node ) + device-tree @ +; + + +\ ------------------------------------------------------------------- +\ device tree iteration +\ ------------------------------------------------------------------- + +: iterate-device-type ( lastph|0 type-str type-len -- 0|nextph ) + rot + begin iterate-tree ?dup while + >r + 2dup " device_type" r@ get-package-property if 0 0 then + dup 0> if 1- then + strcmp 0= if 2drop r> exit then + r> + repeat + 2drop 0 +; + +\ ------------------------------------------------------------------- +\ device tree "cut and paste" +\ ------------------------------------------------------------------- + +\ add a subtree to the current device node +: link-nodes ( phandle -- ) + \ reparent phandle and peers + dup begin ?dup while + dup >dn.parent active-package ! + >dn.peer @ + repeat + + \ add to list of children + active-package >dn.child + begin dup @ while @ >dn.peer repeat dup . ! +; + +: link-node ( phandle -- ) + 0 over >dn.peer ! + link-nodes +; 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 diff --git a/qemu/roms/openbios/forth/device/feval.fs b/qemu/roms/openbios/forth/device/feval.fs new file mode 100644 index 000000000..9e2773db2 --- /dev/null +++ b/qemu/roms/openbios/forth/device/feval.fs @@ -0,0 +1,100 @@ +\ tag: FCode evaluator +\ +\ this code implements an fcode evaluator +\ as described in IEEE 1275-1994 +\ +\ Copyright (C) 2003 Stefan Reinauer +\ +\ See the file "COPYING" for further information about +\ the copyright and warranty status of this work. +\ + +defer init-fcode-table + +: alloc-fcode-table + 4096 cells alloc-mem to fcode-table + ?fcode-verbose if + ." fcode-table at 0x" fcode-table . cr + then + init-fcode-table + ; + +: free-fcode-table + fcode-table 4096 cells free-mem + 0 to fcode-table + ; + +: (debug-feval) ( fcode# -- fcode# ) + \ Address + fcode-stream 1 - . ." : " + + \ Indicate if word is compiled + state @ 0<> if + ." (compile) " + then + dup fcode>xt cell - lfa2name type + dup ." [ 0x" . ." ]" cr + ; + +: (feval) ( -- ?? ) + begin + fcode# + ?fcode-verbose if + (debug-feval) + then + fcode>xt + dup flags? 0<> state @ 0= or if + execute + else + , + then + fcode-end @ until + + \ If we've executed incorrect FCode we may have reached the end of the FCode + \ program but still be in compile mode. Make sure that if this has happened + \ then we switch back to immediate mode to prevent internal OpenBIOS errors. + tmp-comp-depth @ -1 <> if + -1 tmp-comp-depth ! + tmp-comp-buf @ @ here! + 0 state ! + then +; + +: byte-load ( addr xt -- ) + ?fcode-verbose if + cr ." byte-load: evaluating fcode at 0x" over . cr + then + + \ save state + >r >r fcode-push-state r> r> + + \ set fcode-c@ defer + dup 1 = if drop ['] c@ then \ FIXME: uses c@ rather than rb@ for now... + to fcode-c@ + dup to fcode-stream-start + to fcode-stream + 1 to fcode-spread + false to ?fcode-offset16 + alloc-fcode-table + false fcode-end ! + + \ protect against stack overflow/underflow + 0 0 0 0 0 0 depth >r + + ['] (feval) catch if + cr ." byte-load: exception caught!" cr + then + + s" fcode-debug?" evaluate if + depth r@ <> if + cr ." byte-load: warning stack overflow, diff " depth r@ - . cr + then + then + + r> depth! 3drop 3drop + + free-fcode-table + + \ restore state + fcode-pop-state +; diff --git a/qemu/roms/openbios/forth/device/font.fs b/qemu/roms/openbios/forth/device/font.fs new file mode 100644 index 000000000..7b742fac4 --- /dev/null +++ b/qemu/roms/openbios/forth/device/font.fs @@ -0,0 +1,17 @@ +\ tag: 8x16 bitmap font +\ +\ Terminus font +\ +\ The Terminus Font is developed by and is a property +\ of Dimitar Toshkov Zhekov <jimmy@is-vn.bg> +\ +\ See the file "COPYING" for further information about +\ the copyright and warranty status of this work. +\ + +0 value (romfont) +0 value (romfont-width) +0 value (romfont-height) + +\ encode-file romfont.bin +\ drop value (romfont-8x16) diff --git a/qemu/roms/openbios/forth/device/logo.fs b/qemu/roms/openbios/forth/device/logo.fs new file mode 100644 index 000000000..4db31ef54 --- /dev/null +++ b/qemu/roms/openbios/forth/device/logo.fs @@ -0,0 +1,98 @@ +\ tag: monochrome logo +\ +\ simple monochrome logo +\ as described in IEEE 1275-1994 +\ +\ Copyright (C) 2003 Stefan Reinauer +\ +\ See the file "COPYING" for further information about +\ the copyright and warranty status of this work. +\ + + +\ FIXME : This is currently just a test file, it contains +\ a Pi symbol of size 64x64, not really nicely streched. + +\ To use an XBM (X Bitmap), the bits in the bitmap array +\ have to be reversed, i.e. like this: +\ +\ int main(void) +\ { +\ int i,j; unsigned char bit, bitnew; +\ for (i=0; i<512; i++) { +\ bit=openbios_bits[i]; bitnew=0; +\ for (j=0; j<8; j++) +\ if (bit & (1<<j)) bitnew |= (1<<(7-j)); +\ printf("%02x c, ", bitnew); if(i%8 == 7) printf("\n"); +\ } +\ return 0; +\ } + +here + +00 c, 00 c, 00 c, 00 c, 00 c, 00 c, 00 c, 00 c, +00 c, 00 c, 00 c, 00 c, 00 c, 00 c, 00 c, 00 c, +07 c, ff c, ff c, ff c, ff c, ff c, ff c, e0 c, +07 c, ff c, ff c, ff c, ff c, ff c, ff c, e0 c, +07 c, ff c, ff c, ff c, ff c, ff c, ff c, e0 c, +07 c, ff c, ff c, ff c, ff c, ff c, ff c, e0 c, +7f c, ff c, ff c, ff c, ff c, ff c, ff c, e0 c, +7f c, ff c, ff c, ff c, ff c, ff c, ff c, e0 c, +7f c, ff c, ff c, ff c, ff c, ff c, ff c, e0 c, +7f c, ff c, ff c, ff c, ff c, ff c, ff c, e0 c, +7f c, df c, ff c, ff c, 7f c, ff c, ff c, 90 c, +78 c, 03 c, fe c, 00 c, 07 c, fc c, 00 c, 00 c, +78 c, 03 c, fe c, 00 c, 07 c, fc c, 00 c, 00 c, +78 c, 03 c, fe c, 00 c, 07 c, fc c, 00 c, 00 c, +70 c, 03 c, fe c, 00 c, 07 c, fc c, 00 c, 00 c, +00 c, 03 c, fe c, 00 c, 07 c, fc c, 00 c, 00 c, +00 c, 03 c, fe c, 00 c, 07 c, fc c, 00 c, 00 c, +00 c, 03 c, fe c, 00 c, 07 c, fc c, 00 c, 00 c, +00 c, 03 c, fe c, 00 c, 07 c, fc c, 00 c, 00 c, +00 c, 03 c, fe c, 00 c, 07 c, fc c, 00 c, 00 c, +00 c, 03 c, fe c, 00 c, 07 c, fc c, 00 c, 00 c, +00 c, 03 c, fe c, 00 c, 07 c, fc c, 00 c, 00 c, +00 c, 03 c, fe c, 00 c, 07 c, fc c, 00 c, 00 c, +00 c, 03 c, fe c, 00 c, 07 c, fc c, 00 c, 00 c, +00 c, 03 c, fe c, 00 c, 07 c, fc c, 00 c, 00 c, +00 c, 03 c, fe c, 00 c, 07 c, fc c, 00 c, 00 c, +00 c, 03 c, fe c, 00 c, 07 c, fc c, 00 c, 00 c, +00 c, 03 c, fe c, 00 c, 07 c, fc c, 00 c, 00 c, +00 c, 03 c, fe c, 00 c, 07 c, fc c, 00 c, 00 c, +00 c, 03 c, fe c, 00 c, 07 c, fc c, 00 c, 00 c, +00 c, 03 c, fe c, 00 c, 07 c, fc c, 00 c, 00 c, +00 c, 03 c, fe c, 00 c, 07 c, fc c, 00 c, 00 c, +00 c, 03 c, fe c, 00 c, 07 c, fc c, 00 c, 00 c, +00 c, 03 c, fe c, 00 c, 07 c, fc c, 00 c, 00 c, +00 c, 03 c, fe c, 00 c, 07 c, fc c, 00 c, 00 c, +00 c, 03 c, fe c, 00 c, 07 c, fc c, 00 c, 00 c, +00 c, 03 c, fe c, 00 c, 07 c, fc c, 00 c, 00 c, +00 c, 03 c, fe c, 00 c, 07 c, fc c, 00 c, 00 c, +00 c, 03 c, fe c, 00 c, 07 c, fc c, 00 c, 00 c, +00 c, 03 c, fe c, 00 c, 07 c, fc c, 00 c, 00 c, +00 c, 03 c, fe c, 00 c, 07 c, fc c, 00 c, 00 c, +00 c, 03 c, fe c, 00 c, 07 c, fc c, 00 c, 00 c, +00 c, 03 c, fe c, 00 c, 07 c, fc c, 00 c, 00 c, +00 c, 03 c, fe c, 00 c, 07 c, fc c, 00 c, 00 c, +00 c, 03 c, fe c, 00 c, 07 c, fc c, 00 c, 00 c, +00 c, 03 c, fe c, 00 c, 07 c, fc c, 00 c, 00 c, +00 c, 03 c, fe c, 00 c, 07 c, fc c, 01 c, 80 c, +00 c, 03 c, fe c, 00 c, 07 c, f8 c, 01 c, e0 c, +00 c, 03 c, fe c, 00 c, 07 c, f8 c, 01 c, e0 c, +00 c, 03 c, fe c, 00 c, 07 c, fc c, 03 c, e0 c, +00 c, 07 c, fe c, 00 c, 07 c, fc c, 07 c, e0 c, +00 c, 3f c, fe c, 00 c, 07 c, ff c, ff c, e0 c, +00 c, 3f c, fe c, 00 c, 07 c, ff c, ff c, e0 c, +00 c, 3f c, fe c, 00 c, 07 c, ff c, ff c, e0 c, +00 c, 3f c, fc c, 00 c, 07 c, ff c, ff c, c0 c, +00 c, 3f c, f8 c, 00 c, 07 c, ff c, ff c, 80 c, +00 c, 7f c, e0 c, 00 c, 0f c, ff c, fe c, 00 c, +00 c, 3f c, e0 c, 00 c, 07 c, ff c, fe c, 00 c, +00 c, 3f c, c0 c, 00 c, 07 c, ff c, fc c, 00 c, +00 c, 00 c, 00 c, 00 c, 00 c, 00 c, 00 c, 00 c, +00 c, 00 c, 00 c, 00 c, 00 c, 00 c, 00 c, 00 c, +00 c, 00 c, 00 c, 00 c, 00 c, 00 c, 00 c, 00 c, +00 c, 00 c, 00 c, 00 c, 00 c, 00 c, 00 c, 00 c, +00 c, 00 c, 00 c, 00 c, 00 c, 00 c, 00 c, 00 c, + +value (romlogo-64x64) diff --git a/qemu/roms/openbios/forth/device/missing b/qemu/roms/openbios/forth/device/missing new file mode 100644 index 000000000..8ea954ed7 --- /dev/null +++ b/qemu/roms/openbios/forth/device/missing @@ -0,0 +1,38 @@ +5.3.3.1 + + * (is-user-word) + +5.3.4 Package access + +5.3.6 Display + * default-font + * set-font + * >font + * is-install + * is-remove + * is-selftest + +5.3.7 Other + * cpeek + * wpeek + * lpeek + * cpoke + * wpoke + * lpoke + * rb@ + * rw@ + * rl@ + * rb! + * rw! + * rl! + * get-msecs + * ms + * alarm + * user-abort + * mac-address + * display-status + * memory-test-suite + * mask + * diagnostic-mode? + * suspend-fcode + * set-args diff --git a/qemu/roms/openbios/forth/device/other.fs b/qemu/roms/openbios/forth/device/other.fs new file mode 100644 index 000000000..b39007301 --- /dev/null +++ b/qemu/roms/openbios/forth/device/other.fs @@ -0,0 +1,233 @@ +\ tag: Other FCode functions +\ +\ this code implements IEEE 1275-1994 ch. 5.3.7 +\ +\ Copyright (C) 2003 Stefan Reinauer +\ +\ See the file "COPYING" for further information about +\ the copyright and warranty status of this work. +\ + +\ The current diagnostic setting +defer _diag-switch? + + +\ +\ 5.3.7 Other FCode functions +\ + +hex + +\ 5.3.7.1 Peek/poke + +defer (peek) +:noname + execute true +; to (peek) + +: cpeek ( addr -- false | byte true ) + ['] c@ (peek) + ; + +: wpeek ( waddr -- false | w true ) + ['] w@ (peek) + ; + +: lpeek ( qaddr -- false | quad true ) + ['] l@ (peek) + ; + +defer (poke) +:noname + execute true +; to (poke) + +: cpoke ( byte addr -- okay? ) + ['] c! (poke) + ; + +: wpoke ( w waddr -- okay? ) + ['] w! (poke) + ; + +: lpoke ( quad qaddr -- okay? ) + ['] l! (poke) + ; + + +\ 5.3.7.2 Device-register access + +: rb@ ( addr -- byte ) + ; + +: rw@ ( waddr -- w ) + ; + +: rl@ ( qaddr -- quad ) + ; + +: rb! ( byte addr -- ) + ; + +: rw! ( w waddr -- ) + ; + +: rl! ( quad qaddr -- ) + ; + +: rx@ ( oaddr - o ) + state @ if + h# 22e get-token if , else execute then + else + h# 22e get-token drop execute + then + ; immediate + +: rx! ( o oaddr -- ) + state @ if + h# 22f get-token if , else execute then + else + h# 22f get-token drop execute + then + ; immediate + +\ 5.3.7.3 Time + +\ Pointer to OBP tick value updated by timer interrupt +variable obp-ticks + +\ Dummy implementation for platforms without a timer interrupt +0 value dummy-msecs + +: get-msecs ( -- n ) + \ If obp-ticks pointer is set, use it. Otherwise fall back to + \ dummy implementation + obp-ticks @ 0<> if + obp-ticks @ + else + dummy-msecs dup 1+ to dummy-msecs + then + ; + +: ms ( n -- ) + get-msecs + + begin dup get-msecs < until + drop + ; + +: alarm ( xt n -- ) + 2drop + ; + +: user-abort ( ... -- ) ( R: ... -- ) + ; + + +\ 5.3.7.4 System information +0003.0000 value fcode-revision ( -- n ) + +: mac-address ( -- mac-str mac-len ) + ; + + +\ 5.3.7.5 FCode self-test +: display-status ( n -- ) + ; + +: memory-test-suite ( addr len -- fail? ) + ; + +: mask ( -- a-addr ) + ; + +: diagnostic-mode? ( -- diag? ) + \ Return the NVRAM diag-switch? setting + _diag-switch? + ; + +\ 5.3.7.6 Start and end. + +\ Begin program with spread 0 followed by FCode-header. +: start0 ( -- ) + 0 fcode-spread ! + offset16 + fcode-header + ; + +\ Begin program with spread 1 followed by FCode-header. +: start1 ( -- ) + 1 to fcode-spread + offset16 + fcode-header + ; + +\ Begin program with spread 2 followed by FCode-header. +: start2 ( -- ) + 2 to fcode-spread + offset16 + fcode-header + ; + +\ Begin program with spread 4 followed by FCode-header. +: start4 ( -- ) + 4 to fcode-spread + offset16 + fcode-header + ; + +\ Begin program with spread 1 followed by FCode-header. +: version1 ( -- ) + 1 to fcode-spread + fcode-header + ; + +\ Cease evaluating this FCode program. +: end0 ( -- ) + true fcode-end ! + ; immediate + +\ Cease evaluating this FCode program. +: end1 ( -- ) + end0 + ; + +\ Standard FCode number for undefined FCode functions. +: ferror ( -- ) + ." undefined fcode# encountered." cr + true fcode-end ! + ; + +\ Pause FCode evaluation if desired; can resume later. +: suspend-fcode ( -- ) + \ NOT YET IMPLEMENTED. + ; + + +\ Evaluate FCode beginning at location addr. + +\ : byte-load ( addr xt -- ) +\ \ this word is implemented in feval.fs +\ ; + +\ Set address and arguments of new device node. +: set-args ( arg-str arg-len unit-str unit-len -- ) + ?my-self drop + + depth 1- >r + " decode-unit" ['] $call-parent catch if + 2drop 2drop + then + + my-self ihandle>phandle >dn.probe-addr \ offset + begin depth r@ > while + dup na1+ >r ! r> + repeat + r> 2drop + + my-self >in.arguments 2@ free-mem + strdup my-self >in.arguments 2! +; + +: dma-alloc + s" dma-alloc" $call-parent + ; diff --git a/qemu/roms/openbios/forth/device/package.fs b/qemu/roms/openbios/forth/device/package.fs new file mode 100644 index 000000000..d5b52c3eb --- /dev/null +++ b/qemu/roms/openbios/forth/device/package.fs @@ -0,0 +1,287 @@ +\ tag: Package access. +\ +\ this code implements IEEE 1275-1994 ch. 5.3.4 +\ +\ Copyright (C) 2003 Stefan Reinauer +\ +\ See the file "COPYING" for further information about +\ the copyright and warranty status of this work. +\ + +\ variable last-package 0 last-package ! +\ 0 value active-package +: current-device active-package ; + +\ +\ 5.3.4.1 Open/Close packages (part 1) +\ + +\ 0 value my-self ( -- ihandle ) +: ?my-self + my-self dup 0= abort" no current instance." + ; + +: my-parent ( -- ihandle ) + ?my-self >in.my-parent @ +; + +: ihandle>non-interposed-phandle ( ihandle -- phandle ) + begin dup >in.interposed @ while + >in.my-parent @ + repeat + >in.device-node @ +; + +: ihandle>phandle ( ihandle -- phandle ) + >in.device-node @ +; + + +\ next-property +\ defined in property.c + +: peer ( phandle -- phandle.sibling ) + ?dup if + >dn.peer @ + else + device-tree @ + then +; + +: child ( phandle.parent -- phandle.child ) + \ Assume phandle == 0 indicates root node (not documented but similar + \ behaviour to "peer"). Used by some versions of Solaris (e.g. 9). + ?dup if else device-tree @ then + + >dn.child @ +; + + +\ +\ 5.3.4.2 Call methods from other packages +\ + +: find-method ( method-str method-len phandle -- false | xt true ) + \ should we search the private wordlist too? I don't think so... + >dn.methods @ find-wordlist if + true + else + 2drop false + then +; + +: call-package ( ... xt ihandle -- ??? ) + my-self >r + to my-self + execute + r> to my-self +; + + +: $call-method ( ... method-str method-len ihandle -- ??? ) + dup >r >in.device-node @ find-method if + r> call-package + else + -21 throw + then +; + +: $call-parent ( ... method-str method-len -- ??? ) + my-parent $call-method +; + + +\ +\ 5.3.4.1 Open/Close packages (part 2) +\ + +\ find-dev ( dev-str dev-len -- false | phandle true ) +\ find-rel-dev ( dev-str dev-len phandle -- false | phandle true ) +\ +\ These function works just like find-device but without +\ any side effects (or exceptions). +\ +defer find-dev + +: find-rel-dev ( dev-str dev-len phandle -- false | phandle true ) + active-package >r active-package! + find-dev + r> active-package! +; + +: find-package ( name-str name-len -- false | phandle true ) +\ Locate the support package named by name string. +\ If the package can be located, return its phandle and true; otherwise, +\ return false. +\ Interpret the name in name string relative to the "packages" device node. +\ If there are multiple packages with the same name (within the "packages" +\ node), return the phandle for the most recently created one. + + \ This does the full path resolution stuff (including + \ alias expansion. If we don't want that, then we should just + \ iterade the children of /packages. + " /packages" find-dev 0= if 2drop false exit then + find-rel-dev 0= if false exit then + + true +; + +: open-package ( arg-str arg-len phandle -- ihandle | 0 ) +\ Open the package indicated by phandle. +\ Create an instance of the package identified by phandle, save in that +\ instance the instance-argument specified by arg-string and invoke the +\ package's open method. +\ Return the instance handle ihandle of the new instance, or 0 if the package +\ could not be opened. This could occur either because that package has no +\ open method, or because its open method returned false, indicating an error. +\ The parent instance of the new instance is the instance that invoked +\ open-package. The current instance is not changed. + + create-instance dup 0= if + 3drop 0 exit + then + >r + + \ clone arg-str + strdup r@ >in.arguments 2! + + \ open the package + " open" r@ ['] $call-method catch if 3drop false then + if + r> + else + r> destroy-instance false + then +; + + +: $open-package ( arg-str arg-len name-str name-len -- ihandle | 0 ) + \ Open the support package named by name string. + find-package if + open-package + else + 2drop false + then +; + + +: close-package ( ihandle -- ) +\ Close the instance identified by ihandle by calling the package's close +\ method and then destroying the instance. + dup " close" rot ['] $call-method catch if 3drop then + destroy-instance +; + +\ +\ 5.3.4.3 Get local arguments +\ + +: my-address ( -- phys.lo ... ) + ?my-self >in.device-node @ + >dn.probe-addr + my-#acells tuck /l* + swap 1- 0 + ?do + /l - dup l@ swap + loop + drop + ; + +: my-space ( -- phys.hi ) + ?my-self >in.device-node @ + >dn.probe-addr @ + ; + +: my-unit ( -- phys.lo ... phys.hi ) + ?my-self >in.my-unit + my-#acells tuck /l* + swap 0 ?do + /l - dup l@ swap + loop + drop + ; + +: my-args ( -- arg-str arg-len ) + ?my-self >in.arguments 2@ + ; + +\ char is not included. If char is not found, then R-len is zero +: left-parse-string ( str len char -- R-str R-len L-str L-len ) + left-split +; + +\ parse ints "hi,...,lo" separated by comma +: parse-ints ( str len num -- val.lo .. val.hi ) + -rot 2 pick -rot + begin + rot 1- -rot 2 pick 0>= + while + ( num n str len ) + 2dup ascii , strchr ?dup if + ( num n str len p ) + 1+ -rot + 2 pick 2 pick - ( num n p str len len1+1 ) + dup -rot - ( num n p str len1+1 len2 ) + -rot 1- ( num n p len2 str len1 ) + else + 0 0 2swap + then + $number if 0 then >r + repeat + 3drop + + ( num ) + begin 1- dup 0>= while r> swap repeat + drop +; + +: parse-2int ( str len -- val.lo val.hi ) + 2 parse-ints +; + + +\ +\ 5.3.4.4 Mapping tools +\ + +: map-low ( phys.lo ... size -- virt ) + my-space swap s" map-in" $call-parent + ; + +: free-virtual ( virt size -- ) + over s" address" get-my-property 0= if + decode-int -rot 2drop = if + s" address" delete-property + then + else + drop + then + s" map-out" $call-parent + ; + + +\ Deprecated functions (required for compatibility with older loaders) + +variable package-stack-pos 0 package-stack-pos ! +create package-stack 8 cells allot + +: push-package ( phandle -- ) + \ Throw an error if we attempt to push a full stack + package-stack-pos @ 8 >= if + ." cannot push-package onto full stack" cr + -99 throw + then + active-package + package-stack-pos @ /n * package-stack + ! + package-stack-pos @ 1 + package-stack-pos ! + active-package! + ; + +: pop-package ( -- ) + \ Throw an error if we attempt to pop an empty stack + package-stack-pos @ 0 = if + ." cannot pop-package from empty stack" cr + -99 throw + then + package-stack-pos @ 1 - package-stack-pos ! + package-stack-pos @ /n * package-stack + @ + active-package! + ; diff --git a/qemu/roms/openbios/forth/device/pathres.fs b/qemu/roms/openbios/forth/device/pathres.fs new file mode 100644 index 000000000..a185b95a1 --- /dev/null +++ b/qemu/roms/openbios/forth/device/pathres.fs @@ -0,0 +1,522 @@ +\ tag: Path resolution +\ +\ this code implements IEEE 1275-1994 path resolution +\ +\ Copyright (C) 2003 Samuel Rydh +\ +\ See the file "COPYING" for further information about +\ the copyright and warranty status of this work. +\ + +0 value interpose-ph +0 0 create interpose-args , , + +: expand-alias ( alias-addr alias-len -- exp-addr exp-len expanded? ) + 2dup + " /aliases" find-dev 0= if 2drop false exit then + get-package-property if + false + else + 2swap 2drop + \ drop trailing 0 from string + dup if 1- then + true + then +; + +\ +\ 4.3.1 Resolve aliases +\ + +\ the returned string is allocated with alloc-mem +: pathres-resolve-aliases ( path-addr path-len -- path-addr path-len ) + over c@ 2f <> if + 200 here + >r \ abuse dictionary for temporary storage + + \ If the pathname does not begin with "/", and its first node name + \ component is an alias, replace the alias with its expansion. + ascii / split-before \ (PATH_NAME, "/") -> (TAIL HEAD) + ascii : split-before \ (HEAD, ":") -> (ALIAS_ARGS AL_NAME) + expand-alias ( TAIL ALIAS_ARGS EXP_ALIAS_NAME expanded? ) + if + 2 pick 0<> if \ If ALIAS_ARGS is not empty + ascii / split-after \ (ALIAS_NAME, "/") -> (AL_TAIL AL_HEAD/) + 2swap ( TAIL AL_HEAD/ AL_TAIL ) + ascii : split-before \ (AL_TAIL, ":") -> (DEAD_ARGS AL_TAIL) + 2swap 2drop ( TAIL AL_ARGS AL_HEAD ALIAS_TAIL ) + 2swap ( TAIL AL_ARGS AL_TAIL AL_HEAD ) + r> tmpstrcat tmpstrcat >r + else + 2swap 2drop \ drop ALIAS_ARGS + then + r> tmpstrcat drop + else + \ put thing back together again + r> tmpstrcat tmpstrcat drop + then + then + + strdup + ( path-addr path-len ) +; + +\ +\ search struct +\ + +struct ( search information ) + 2 cells field >si.path + 2 cells field >si.arguments + 2 cells field >si.unit_addr + 2 cells field >si.node_name + 2 cells field >si.free_me + 4 cells field >si.unit_phys + /n field >si.unit_phys_len + /n field >si.save-ihandle + /n field >si.save-phandle + /n field >si.top-ihandle + /n field >si.top-opened \ set after successful open + /n field >si.child \ node to match +constant sinfo.size + + +\ +\ 4.3.6 node name match criteria +\ + +: match-nodename ( childname len sinfo -- match? ) + >r + 2dup r@ >si.node_name 2@ + ( [childname] [childname] [nodename] ) + strcmp 0= if r> 3drop true exit then + + \ does NODE_NAME contain a comma? + r@ >si.node_name 2@ ascii , strchr + if r> 3drop false exit then + + ( [childname] ) + ascii , left-split 2drop r@ >si.node_name 2@ + r> drop + strcmp if false else true then +; + + +\ +\ 4.3.4 exact match child node +\ + +\ If NODE_NAME is not empty, make sure it matches the name property +: common-match ( sinfo -- ) + >r + \ a) NODE_NAME nonempty + r@ >si.node_name 2@ nip if + " name" r@ >si.child @ get-package-property if -1 throw then + \ name is supposed to be null-terminated + dup 0> if 1- then + \ exit if NODE_NAME does not match + r@ match-nodename 0= if -2 throw then + then + r> drop +; + +: (exact-match) ( sinfo -- ) + >r + \ a) If NODE_NAME is not empty, make sure it matches the name property + r@ common-match + + \ b) UNIT_PHYS nonempty? + r@ >si.unit_phys_len @ /l* ?dup if + \ check if unit_phys matches + " reg" r@ >si.child @ get-package-property if -3 throw then + ( unitbytes propaddr proplen ) + rot r@ >si.unit_phys -rot + ( propaddr unit_phys proplen unitbytes ) + swap over < if -4 throw then + comp if -5 throw then + else + \ c) both NODE_NAME and UNIT_PHYS empty? + r@ >si.node_name 2@ nip 0= if -6 throw then + then + + r> drop +; + +: exact-match ( sinfo -- match? ) + ['] (exact-match) catch if drop false exit then + true +; + +\ +\ 4.3.5 wildcard match child node +\ + +: (wildcard-match) ( sinfo -- match? ) + >r + \ a) If NODE_NAME is not empty, make sure it matches the name property + r@ common-match + + \ b) Fail if "reg" property exist + " reg" r@ >si.child @ get-package-property 0= if -7 throw then + + \ c) Fail if both NODE_NAME and UNIT_ADDR are both empty + r@ >si.unit_phys_len @ + r@ >si.node_name 2@ nip + or 0= if -1 throw then + + \ SUCCESS + r> drop +; + +: wildcard-match ( sinfo -- match? ) + ['] (wildcard-match) catch if drop false exit then + true +; + + +\ +\ 4.3.3 match child node +\ + +\ used if package lacks a decode-unit method +: def-decode-unit ( str len -- unitaddr ... ) + parse-hex +; + +: get-decode-unit-xt ( phandle -- xt ) + " decode-unit" rot find-method + 0= if ['] def-decode-unit then +; + +: find-child ( sinfo -- phandle ) + >r + \ decode unit address string + r@ >si.unit_addr 2@ dup if + ( str len ) + active-package get-decode-unit-xt + depth 3 - >r execute depth r@ - r> swap + ( ... a_lo ... a_hi olddepth n ) + 4 min 0 max + dup r@ >si.unit_phys_len ! + ( ... a_lo ... a_hi olddepth n ) + r@ >si.unit_phys >r + begin 1- dup 0>= while + rot r> dup la1+ >r l!-be + repeat + r> 2drop + depth! + else + 2drop + \ clear unit_phys + 0 r@ >si.unit_phys_len ! + \ r@ >si.unit_phys 4 cells 0 fill + then + + ( R: sinfo ) + ['] exact-match + begin dup while + active-package >dn.child @ + begin ?dup while + dup r@ >si.child ! + ( xt phandle R: sinfo ) + r@ 2 pick execute if 2drop r> >si.child @ exit then + >dn.peer @ + repeat + ['] exact-match = if ['] wildcard-match else 0 then + repeat + + -99 throw +; + + +\ +\ 4.3.2 Create new linked instance procedure +\ + +: link-one ( sinfo -- ) + >r + active-package create-instance + dup 0= if -99 throw then + + \ change instance parent + r@ >si.top-ihandle @ over >in.my-parent ! + dup r@ >si.top-ihandle ! + to my-self + + \ b) set my-args field + r@ >si.arguments 2@ strdup my-self >in.arguments 2! + + \ e) set my-unit field + r@ >si.unit_addr 2@ nip if + \ copy UNIT_PHYS to the my-unit field + r@ >si.unit_phys my-self >in.my-unit 4 cells move + else + \ set unit-addr from reg property + " reg" active-package get-package-property 0= if + \ ( ihandle prop proplen ) + \ copy address to my-unit + 4 cells min my-self >in.my-unit swap move + else + \ clear my-unit + my-self >in.my-unit 4 cells 0 fill + then + then + + \ top instance has not been opened (yet) + false r> >si.top-opened ! +; + +: invoke-open ( sinfo -- ) + " open" my-self ['] $call-method + catch if 3drop false then + 0= if -99 throw then + + true swap >si.top-opened ! +; + +\ +\ 4.3.7 Handle interposers procedure (supplement) +\ + +: handle-interposers ( sinfo -- ) + >r + begin + interpose-ph ?dup + while + 0 to interpose-ph + active-package swap active-package! + + \ clear unit address and set arguments + 0 0 r@ >si.unit_addr 2! + interpose-args 2@ r@ >si.arguments 2! + r@ link-one + true my-self >in.interposed ! + interpose-args 2@ free-mem + r@ invoke-open + + active-package! + repeat + + r> drop +; + +\ +\ 4.3.1 Path resolution procedure +\ + +\ close-dev ( ihandle -- ) +\ +: close-dev + begin + dup + while + dup >in.my-parent @ + swap close-package + repeat + drop +; + +: path-res-cleanup ( sinfo close? ) + + \ tear down all instances if close? is set + if + dup >si.top-opened @ if + dup >si.top-ihandle @ + ?dup if close-dev then + else + dup >si.top-ihandle @ dup + ( sinfo ihandle ihandle ) + dup if >in.my-parent @ swap then + ( sinfo parent ihandle ) + ?dup if destroy-instance then + ?dup if close-dev then + then + then + + \ restore active-package and my-self + dup >si.save-ihandle @ to my-self + dup >si.save-phandle @ active-package! + + \ free any allocated memory + dup >si.free_me 2@ free-mem + sinfo.size free-mem +; + +: (path-resolution) ( context sinfo -- ) + >r r@ >si.path 2@ + ( context pathstr pathlen ) + + \ this allocates a copy of the string + pathres-resolve-aliases + 2dup r@ >si.free_me 2! + + \ If the pathname, after possible alias expansion, begins with "/", + \ begin the search at the root node. Otherwise, begin at the active + \ package. + + dup if \ make sure string is not empty + over c@ 2f = if + swap char+ swap /c - \ Remove the "/" from PATH_NAME. + \ Set the active package to the root node. + device-tree @ active-package! + then + then + + r@ >si.path 2! + 0 0 r@ >si.unit_addr 2! + 0 0 r@ >si.arguments 2! + 0 r@ >si.top-ihandle ! + + \ If there is no active package, exit this procedure, returning false. + ( context ) + active-package 0= if -99 throw then + + \ Begin the creation of an instance chain. + \ NOTE--If, at this step, the active package is not the root node and + \ we are in open-dev or execute-device-method contexts, the instance + \ chain that results from the path resolution process may be incomplete. + + active-package swap + ( virt-active-node context ) + begin + r@ >si.path 2@ nip \ nonzero path? + while + \ ( active-node context ) + \ is this open-dev or execute-device-method context? + dup if + r@ link-one + over active-package <> my-self >in.interposed ! + r@ invoke-open + r@ handle-interposers + then + over active-package! + + r@ >si.path 2@ ( PATH ) + + ascii / left-split ( PATH COMPONENT ) + ascii : left-split ( PATH ARGS NODE_ADDR ) + ascii @ left-split ( PATH ARGS UNIT_ADDR NODE_NAME ) + + r@ >si.node_name 2! + r@ >si.unit_addr 2! + r@ >si.arguments 2! + r@ >si.path 2! + + ( virt-active-node context ) + + \ 4.3.1 i) pathname has a leading %? + r@ >si.node_name 2@ 2dup 2dup ascii % strchr nip = if + 1- swap 1+ swap r@ >si.node_name 2! + " /packages" find-dev drop active-package! + r@ find-child + else + 2drop + nip r@ find-child swap over + ( new-node context new-node ) + then + + \ (optional: open any nodes between parent and child ) + + active-package! + repeat + + ( virt-active-node type ) + dup if r@ link-one then + 1 = if + dup active-package <> my-self >in.interposed ! + r@ invoke-open + r@ handle-interposers + then + active-package! + + r> drop +; + +: path-resolution ( context path-addr path-len -- sinfo true | false ) + \ allocate and clear the search block + sinfo.size alloc-mem >r + r@ sinfo.size 0 fill + + \ store path + r@ >si.path 2! + + \ save ihandle and phandle + my-self r@ >si.save-ihandle ! + active-package r@ >si.save-phandle ! + + \ save context (if we take an exception) + dup + + r@ ['] (path-resolution) + catch ?dup if + ( context xxx xxx error ) + r> true path-res-cleanup + + \ rethrow everything except our "cleanup throw" + dup -99 <> if throw then + 3drop + + \ ( context ) throw an exception if this is find-device context + if false else -22 throw then + exit + then + + \ ( context ) + drop r> true + ( sinfo true ) +; + + +: open-dev ( dev-str dev-len -- ihandle | 0 ) + 1 -rot path-resolution 0= if false exit then + + ( sinfo ) + my-self swap + false path-res-cleanup + + ( ihandle ) +; + +: execute-device-method +( ... dev-str dev-len met-str met-len -- ... false | ?? true ) + 2swap + 2 -rot path-resolution 0= if 2drop false exit then + ( method-str method-len sinfo ) + >r + my-self ['] $call-method catch + if 3drop false else true then + r> true path-res-cleanup +; + +: find-device ( dev-str dev-len -- ) + 2dup " .." strcmp 0= if + 2drop + active-package dup if >dn.parent @ then + \ ".." in root note? + dup 0= if -22 throw then + active-package! + exit + then + 0 -rot path-resolution 0= if false exit then + ( sinfo ) + active-package swap + true path-res-cleanup + active-package! +; + +\ find-device, but without side effects +: (find-dev) ( dev-str dev-len -- phandle true | false ) + active-package -rot + ['] find-device catch if 3drop false exit then + active-package swap active-package! true +; + +\ Tuck on a node at the end of the chain being created. +\ This implementation follows the interpose recommended practice +\ (v0.2 draft). + +: interpose ( arg-str arg-len phandle -- ) + to interpose-ph + strdup interpose-args 2! +; + +['] (find-dev) to find-dev diff --git a/qemu/roms/openbios/forth/device/preof.fs b/qemu/roms/openbios/forth/device/preof.fs new file mode 100644 index 000000000..131beacd3 --- /dev/null +++ b/qemu/roms/openbios/forth/device/preof.fs @@ -0,0 +1,49 @@ +\ tag: historical and pre open firmware fcode functions +\ +\ this code implements IEEE 1275-1994 ch. H.2.2 and 5.3.1.1.1 +\ +\ Copyright (C) 2003 Stefan Reinauer +\ +\ See the file "COPYING" for further information about +\ the copyright and warranty status of this work. +\ + +\ H.2.2 Non-implemented FCodes +\ Pre-Open Firmware systems assigned the following FCode numbers, +\ but the functions were not supported. These FCode numbers stay +\ reserved to avoid confusion. + +: non-implemented + ." Non-implemented historical or pre-Open Firmware FCode occured." cr + end0 + ; + +: adr-mask non-implemented ; +: b(code) non-implemented ; +: 4-byte-id non-implemented ; +: convert non-implemented ; +: frame-buffer-busy? non-implemented ; +: poll-packet non-implemented ; +: return-buffer non-implemented ; +: set-token-table non-implemented ; +: set-table non-implemented ; +: xmit-packet non-implemented ; + +\ historical fcode words defined by 5.3.1.1.1 + +30000 constant fcode-version \ this opcode is considered obsolete +30000 constant firmware-version \ this opcode is considered obsolete + +\ historical - Returns the type of processor. +\ 0x5 indicates SPARC, other values are not used. +\ ?? this could be set by the kernel during bootstrap. +deadbeef constant processor-type ( -- processor-type ) + +: memmap non-implemented ; +: >physical non-implemented ; +: my-params non-implemented ; +: intr non-implemented ; +: driver non-implemented ; +: group-code non-implemented ; +: probe non-implemented ; +: probe-virtual non-implemented ; diff --git a/qemu/roms/openbios/forth/device/property.fs b/qemu/roms/openbios/forth/device/property.fs new file mode 100644 index 000000000..1d54e3ec3 --- /dev/null +++ b/qemu/roms/openbios/forth/device/property.fs @@ -0,0 +1,335 @@ +\ tag: Property management +\ +\ this code implements IEEE 1275-1994 ch. 5.3.5 +\ +\ Copyright (C) 2003 Stefan Reinauer +\ +\ See the file "COPYING" for further information about +\ the copyright and warranty status of this work. +\ + +\ small helpers.. these should go elsewhere. +: bigendian? + 10 here ! here c@ 10 <> + ; + +: l!-be ( val addr ) + 3 bounds swap do + dup ff and i c! + 8 rshift + -1 +loop + drop + ; + +: l@-be ( addr ) + 0 swap 4 bounds do + i c@ swap 8 << or + loop + ; + +\ allocate n bytes for device tree information +\ until I know where to put this, I put it in the +\ dictionary. + +: alloc-tree ( n -- addr ) + dup >r \ save len + here swap allot + dup r> 0 fill \ clear memory + ; + +: align-tree ( -- ) + null-align + ; + +: no-active true abort" no active package." ; + +\ +\ 5.3.5 Property management +\ + +\ Helper function +: find-property ( name len phandle -- &&prop|0 ) + >dn.properties + begin + dup @ + while + dup @ >prop.name @ ( name len prop propname ) + 2over comp0 ( name len prop equal? ) + 0= if nip nip exit then + >prop.next @ + repeat + ( name len false ) + 3drop false + ; + +\ From package (5.3.4.1) +: next-property +( previous-str previous-len phandle -- false | name-str name-len true ) + >r + 2dup 0= swap 0= or if + 2drop r> >dn.properties @ + else + r> find-property dup if @ then + dup if >prop.next @ then + then + + ?dup if + >prop.name @ dup cstrlen true + ( phandle name-str name-len true ) + else + false + then +; + + +\ +\ 5.3.5.4 Property value access +\ + +\ Return value for name string property in package phandle. +: get-package-property + ( name-str name-len phandle -- true | prop-addr prop-len false ) + find-property ?dup if + @ dup >prop.addr @ + swap >prop.len @ + false + else + true + then + ; + +\ Return value for given property in the current instance or its parents. +: get-inherited-property + ( name-str name-len -- true | prop-addr prop-len false ) + my-self + begin + ?dup + while + dup >in.device-node @ ( str len ihandle phandle ) + 2over rot find-property ?dup if + @ + ( str len ihandle prop ) + nip nip nip ( prop ) + dup >prop.addr @ swap >prop.len @ + false + exit + then + ( str len ihandle ) + >in.my-parent @ + repeat + 2drop + true + ; + +\ Return value for given property in this package. +: get-my-property ( name-str name-len -- true | prop-addr prop-len false ) + my-self >in.device-node @ ( -- phandle ) + get-package-property + ; + + +\ +\ 5.3.5.2 Property array decoding +\ + +: decode-int ( prop-addr1 prop-len1 -- prop-addr2 prop-len2 n ) + dup 0> if + dup 4 min >r ( addr1 len1 R:minlen ) + over r@ + swap ( addr1 addr2 len1 R:minlen ) + r> - ( addr1 addr2 len2 ) + rot l@-be + else + 0 + then + ; + +\ HELPER: get #address-cell value (from parent) +\ Legal values are 1..4 (we may optionally support longer addresses) +: my-#acells ( -- #address-cells ) + my-self ?dup if >in.device-node @ else active-package then + ?dup if >dn.parent @ then + ?dup if + " #address-cells" rot get-package-property if 2 exit then + \ we don't have to support more than 4 (and 0 is illegal) + decode-int nip nip 4 min 1 max + else + 2 + then +; + +\ HELPER: get #size-cells value (from parent) +: my-#scells ( -- #size-cells ) + my-self ?dup if >in.device-node @ else active-package then + ?dup if >dn.parent @ then + ?dup if + " #size-cells" rot get-package-property if 1 exit then + decode-int nip nip + else + 1 + then +; + +: decode-string ( prop-addr1 prop-len1 -- prop-addr2 prop-len2 str len ) + dup 0> if + 2dup bounds \ check property for 0 bytes + 0 -rot \ initial string len is 0 + do + i c@ 0= if + leave + then + 1+ + loop ( prop-addr1 prop-len1 len ) + 1+ rot >r ( prop-len1 len R: prop-addr1 ) + over min 2dup - ( prop-len1 nlen prop-len2 R: prop-addr1 ) + r@ 2 pick + ( prop-len1 nlen prop-len2 prop-addr2 ) + >r >r >r ( R: prop-addr1 prop-addr2 prop-len2 nlen ) + drop + r> r> r> ( nlen prop-len2 prop-addr2 ) + -rot swap 1- ( prop-addr2 prop-len2 nlen ) + r> swap ( prop-addr2 prop-len2 str len ) + else + 0 0 + then + ; + +: decode-bytes ( addr1 len1 #bytes -- addr len2 addr1 #bytes ) + tuck - ( addr1 #bytes len2 ) + r> 2dup + ( addr1 #bytes addr2 ) ( R: len2 ) + r> 2swap + ; + +: decode-phys + ( prop-addr1 prop-len1 -- prop-addr2 prop-len2 phys.lo ... phys.hi ) + my-#acells 0 ?do + decode-int r> r> rot >r >r >r + loop + my-#acells 0 ?do + r> r> r> -rot >r >r + loop + ; + + +\ +\ 5.3.5.1 Property array encoding +\ + +: encode-int ( n -- prop-addr prop-len ) + /l alloc-tree tuck l!-be /l + ; + +: encode-string ( str len -- prop-addr prop-len ) + \ we trust len here. should probably check string? + tuck char+ alloc-tree ( len str prop-addr ) + tuck 3 pick move ( len prop-addr ) + swap 1+ + ; + +: encode-bytes ( data-addr data-len -- prop-addr prop-len ) + tuck alloc-tree ( len str prop-addr ) + tuck 3 pick move + swap + ; + +: encode+ ( prop-addr1 prop-len1 prop-addr2 prop-len2 -- prop-addr3 prop-len3 ) + nip + + ; + +: encode-phys ( phys.lo ... phys.hi -- prop-addr prop-len ) + encode-int my-#acells 1- 0 ?do + rot encode-int encode+ + loop + ; + +defer sbus-intr>cpu ( sbus-intr# -- cpu-intr# ) +: (sbus-intr>cpu) ." No SBUS present on this machine." cr ; +['] (sbus-intr>cpu) to sbus-intr>cpu + + +\ +\ 5.3.5.3 Property declaration +\ + +: (property) ( prop-addr prop-len name-str name-len dnode -- ) + >r 2dup r@ + align-tree + find-property ?dup if + \ If a property with that property name already exists in the + \ package in which the property would be created, replace its + \ value with the new value. + @ r> drop \ don't need the device node anymore. + -rot 2drop tuck \ drop property name + >prop.len ! \ overwrite old values + >prop.addr ! + exit + then + + ( prop-addr prop-len name-str name-len R: dn ) + prop-node.size alloc-tree + dup >prop.next off + + dup r> >dn.properties + begin dup @ while @ >prop.next repeat ! + >r + + ( prop-addr prop-len name-str name-len R: prop ) + + \ create copy of property name + dup char+ alloc-tree + dup >r swap move r> + ( prop-addr prop-len new-name R: prop ) + r@ >prop.name ! + r@ >prop.len ! + r> >prop.addr ! + align-tree + ; + +: property ( prop-addr prop-len name-str name-len -- ) + my-self ?dup if + >in.device-node @ + else + active-package + then + dup if + (property) + else + no-active + then + ; + +: (delete-property) ( name len dnode -- ) + find-property ?dup if + dup @ >prop.next @ swap ! + \ maybe we should try to reclaim the space? + then +; + +: delete-property ( name-str name-len -- ) + active-package ?dup if + (delete-property) + else + 2drop + then + ; + +\ Create the "name" property; value is indicated string. +: device-name ( str len -- ) + encode-string " name" property + ; + +\ Create "device_type" property, value is indicated string. +: device-type ( str len -- ) + encode-string " device_type" property + ; + +\ Create the "reg" property with the given values. +: reg ( phys.lo ... phys.hi size -- ) + >r ( phys.lo ... phys.hi ) encode-phys ( addr len ) + r> ( addr1 len1 size ) encode-int ( addr1 len1 addr2 len2 ) + encode+ ( addr len ) + " reg" property + ; + +\ Create the "model" property; value is indicated string. +: model ( str len -- ) + encode-string " model" property + ; diff --git a/qemu/roms/openbios/forth/device/romfont.bin b/qemu/roms/openbios/forth/device/romfont.bin Binary files differnew file mode 100644 index 000000000..0b60b6fb4 --- /dev/null +++ b/qemu/roms/openbios/forth/device/romfont.bin diff --git a/qemu/roms/openbios/forth/device/structures.fs b/qemu/roms/openbios/forth/device/structures.fs new file mode 100644 index 000000000..14dd881e5 --- /dev/null +++ b/qemu/roms/openbios/forth/device/structures.fs @@ -0,0 +1,54 @@ +\ tag: device interface structures +\ +\ this code implements data structures used by the +\ IEEE 1275-1994 Open Firmware Device Interface. +\ +\ Copyright (C) 2003 Stefan Reinauer +\ +\ See the file "COPYING" for further information about +\ the copyright and warranty status of this work. +\ + +\ this file contains the struct definitions for the following +\ device tree structures: +\ device-node +\ active-package +\ property +\ instance + + +struct ( instance ) + /n field >in.instance-data \ must go first + /n field >in.alloced-size \ alloced size + /n field >in.device-node + /n field >in.my-parent + /n field >in.interposed + 4 cells field >in.my-unit + 2 cells field >in.arguments + \ instance-data should be null during packet initialization + \ this diverts access to instance variables to the dictionary +constant inst-node.size + +struct ( device node ) + /n field >dn.isize \ instance size (must go first) + /n field >dn.parent + /n field >dn.child + /n field >dn.peer + /n field >dn.properties + /n field >dn.methods + /n field >dn.priv-methods + /n field >dn.#acells + /n field >dn.probe-addr + inst-node.size field >dn.itemplate +constant dev-node.size + +struct ( property ) + /n field >prop.next + /n field >prop.name + /n field >prop.addr + /n field >prop.len +constant prop-node.size + +struct ( active package ) + /n field >ap.device-str +constant active-package.size diff --git a/qemu/roms/openbios/forth/device/table.fs b/qemu/roms/openbios/forth/device/table.fs new file mode 100644 index 000000000..5c58f2d9d --- /dev/null +++ b/qemu/roms/openbios/forth/device/table.fs @@ -0,0 +1,462 @@ +\ tag: FCode table setup +\ +\ this code implements an fcode evaluator +\ as described in IEEE 1275-1994 +\ +\ Copyright (C) 2003 Stefan Reinauer +\ +\ See the file "COPYING" for further information about +\ the copyright and warranty status of this work. +\ + +hex + +: undefined-fcode ." undefined fcode word." cr ; +: reserved-fcode ." reserved fcode word." cr ; + +: ['], ( <word> -- ) + ' , +; + +: n['], ( n <word> -- ) + ' swap 0 do + dup , + loop + drop +; + +\ the table used +create fcode-master-table + ['], end0 + f n['], reserved-fcode + ['], b(lit) + ['], b(') + ['], b(") + ['], bbranch + ['], b?branch + ['], b(loop) + ['], b(+loop) + ['], b(do) + ['], b(?do) + ['], i + ['], j + ['], b(leave) + ['], b(of) + ['], execute + ['], + + ['], - + ['], * + ['], / + ['], mod + ['], and + ['], or + ['], xor + ['], invert + ['], lshift + ['], rshift + ['], >>a + ['], /mod + ['], u/mod + ['], negate + ['], abs + ['], min + ['], max + ['], >r + ['], r> + ['], r@ + ['], exit + ['], 0= + ['], 0<> + ['], 0< + ['], 0<= + ['], 0> + ['], 0>= + ['], < + ['], > + ['], = + ['], <> + ['], u> + ['], u<= + ['], u< + ['], u>= + ['], >= + ['], <= + ['], between + ['], within + ['], drop + ['], dup + ['], over + ['], swap + ['], rot + ['], -rot + ['], tuck + ['], nip + ['], pick + ['], roll + ['], ?dup + ['], depth + ['], 2drop + ['], 2dup + ['], 2over + ['], 2swap + ['], 2rot + ['], 2/ + ['], u2/ + ['], 2* + ['], /c + ['], /w + ['], /l + ['], /n + ['], ca+ + ['], wa+ + ['], la+ + ['], na+ + ['], char+ + ['], wa1+ + ['], la1+ + ['], cell+ + ['], chars + ['], /w* + ['], /l* + ['], cells + ['], on + ['], off + ['], +! + ['], @ + ['], l@ + ['], w@ + ['], <w@ + ['], c@ + ['], ! + ['], l! + ['], w! + ['], c! + ['], 2@ + ['], 2! + ['], move + ['], fill + ['], comp + ['], noop + ['], lwsplit + ['], wljoin + ['], lbsplit + ['], bljoin + ['], wbflip + ['], upc + ['], lcc + ['], pack + ['], count + ['], body> + ['], >body + ['], fcode-revision + ['], span + ['], unloop + ['], expect + ['], alloc-mem + ['], free-mem + ['], key? + ['], key + ['], emit + ['], type + ['], (cr + ['], cr + ['], #out + ['], #line + ['], hold + ['], <# + ['], u#> + ['], sign + ['], u# + ['], u#s + ['], u. + ['], u.r + ['], . + ['], .r + ['], .s + ['], base + ['], convert \ reserved (compatibility) + ['], $number + ['], digit + ['], -1 + ['], 0 + ['], 1 + ['], 2 + ['], 3 + ['], bl + ['], bs + ['], bell + ['], bounds + ['], here + ['], aligned + ['], wbsplit + ['], bwjoin + ['], b(<mark) + ['], b(>resolve) + ['], set-token-table + ['], set-table + ['], new-token + ['], named-token + ['], b(:) + ['], b(value) + ['], b(variable) + ['], b(constant) + ['], b(create) + ['], b(defer) + ['], b(buffer:) + ['], b(field) + ['], b(code) + ['], instance + ['], reserved-fcode + ['], b(;) + ['], b(to) + ['], b(case) + ['], b(endcase) + ['], b(endof) + ['], # + ['], #s + ['], #> + ['], external-token + ['], $find + ['], offset16 + ['], evaluate + ['], reserved-fcode + ['], reserved-fcode + ['], c, + ['], w, + ['], l, + ['], , + ['], um* + ['], um/mod + ['], reserved-fcode + ['], reserved-fcode + ['], d+ + ['], d- + ['], get-token + ['], set-token + ['], state + ['], compile, + ['], behavior + 11 n['], reserved-fcode + ['], start0 + ['], start1 + ['], start2 + ['], start4 + 8 n['], reserved-fcode + ['], ferror + ['], version1 + ['], 4-byte-id + ['], end1 + ['], reserved-fcode + ['], dma-alloc + ['], my-address + ['], my-space + ['], memmap + ['], free-virtual + ['], >physical + 8 n['], reserved-fcode + ['], my-params + ['], property + ['], encode-int + ['], encode+ + ['], encode-phys + ['], encode-string + ['], encode-bytes + ['], reg + ['], intr + ['], driver + ['], model + ['], device-type + ['], parse-2int + ['], is-install + ['], is-remove + ['], is-selftest + ['], new-device + ['], diagnostic-mode? + ['], display-status + ['], memory-test-suite + ['], group-code + ['], mask + ['], get-msecs + ['], ms + ['], finish-device + ['], decode-phys \ 128 + ['], push-package + ['], pop-package + ['], interpose \ extension (recommended practice) + 4 n['], reserved-fcode + ['], map-low + ['], sbus-intr>cpu + 1e n['], reserved-fcode + ['], #lines + ['], #columns + ['], line# + ['], column# + ['], inverse? + ['], inverse-screen? + ['], frame-buffer-busy? + ['], draw-character + ['], reset-screen + ['], toggle-cursor + ['], erase-screen + ['], blink-screen + ['], invert-screen + ['], insert-characters + ['], delete-characters + ['], insert-lines + ['], delete-lines + ['], draw-logo + ['], frame-buffer-adr + ['], screen-height + ['], screen-width + ['], window-top + ['], window-left + 3 n['], reserved-fcode + ['], default-font + ['], set-font + ['], char-height + ['], char-width + ['], >font + ['], fontbytes + 10 n['], reserved-fcode \ fb1 words + ['], fb8-draw-character + ['], fb8-reset-screen + ['], fb8-toggle-cursor + ['], fb8-erase-screen + ['], fb8-blink-screen + ['], fb8-invert-screen + ['], fb8-insert-characters + ['], fb8-delete-characters + ['], fb8-insert-lines + ['], fb8-delete-lines + ['], fb8-draw-logo + ['], fb8-install + 4 n['], reserved-fcode \ reserved + 7 n['], reserved-fcode \ VME-bus support + 9 n['], reserved-fcode \ reserved + ['], return-buffer + ['], xmit-packet + ['], poll-packet + ['], reserved-fcode + ['], mac-address + 5c n['], reserved-fcode \ 1a5-200 reserved + ['], device-name + ['], my-args + ['], my-self + ['], find-package + ['], open-package + ['], close-package + ['], find-method + ['], call-package + ['], $call-parent + ['], my-parent + ['], ihandle>phandle + ['], reserved-fcode + ['], my-unit + ['], $call-method + ['], $open-package + ['], processor-type + ['], firmware-version + ['], fcode-version + ['], alarm + ['], (is-user-word) + ['], suspend-fcode + ['], abort + ['], catch + ['], throw + ['], user-abort + ['], get-my-property + ['], decode-int + ['], decode-string + ['], get-inherited-property + ['], delete-property + ['], get-package-property + ['], cpeek + ['], wpeek + ['], lpeek + ['], cpoke + ['], wpoke + ['], lpoke + ['], lwflip + ['], lbflip + ['], lbflips + ['], adr-mask + 4 n['], reserved-fcode \ 22a-22d +64bit? [IF] + ['], (rx@) + ['], (rx!) +[ELSE] + 2 n['], reserved-fcode \ 22e-22f +[THEN] + ['], rb@ + ['], rb! + ['], rw@ + ['], rw! + ['], rl@ + ['], rl! + ['], wbflips + ['], lwflips + ['], probe + ['], probe-virtual + ['], reserved-fcode + ['], child + ['], peer + ['], next-property + ['], byte-load + ['], set-args + ['], left-parse-string \ 240 +64bit? [IF] + ['], bxjoin + ['], <l@ + ['], lxjoin + ['], wxjoin + ['], x, + ['], x@ + ['], x! + ['], /x + ['], /x* +\ ['], /xa+ +\ ['], /xa1+ + ['], xbflip + ['], xbflips + ['], xbsplit + ['], xlflip + ['], xlflips + ['], xlsplit + ['], xwflip + ['], xwflips + ['], xwsplit +[ELSE] + 7 n['], reserved-fcode \ 241-247 (Part of IEEE1275 64-bit draft standard) + ['], /x + c n['], reserved-fcode \ 249-254 (Part of IEEE1275 64-bit draft standard) +[THEN] + + +here fcode-master-table - constant fcode-master-table-size + + +: nreserved ( fcode-table-ptr first last xt -- ) + -rot 1+ swap do + 2dup swap i cells + ! + loop + 2drop +; + +:noname + 800 cells alloc-mem to fcode-sys-table + + fcode-sys-table + dup 0 5ff ['] reserved-fcode nreserved \ built-in fcodes + dup 600 7ff ['] undefined-fcode nreserved \ vendor fcodes + + \ copy built-in fcodes + fcode-master-table swap fcode-master-table-size move +; initializer + +: (init-fcode-table) ( -- ) + fcode-sys-table fcode-table 800 cells move + \ clear local fcodes + fcode-table 800 fff ['] undefined-fcode nreserved +; + +['] (init-fcode-table) to init-fcode-table diff --git a/qemu/roms/openbios/forth/device/terminal.fs b/qemu/roms/openbios/forth/device/terminal.fs new file mode 100644 index 000000000..24b2d10c9 --- /dev/null +++ b/qemu/roms/openbios/forth/device/terminal.fs @@ -0,0 +1,302 @@ +\ tag: terminal emulation +\ +\ this code implements IEEE 1275-1994 ANNEX B +\ +\ Copyright (C) 2003 Stefan Reinauer +\ +\ See the file "COPYING" for further information about +\ the copyright and warranty status of this work. +\ + +0 value (escseq) +10 buffer: (sequence) + +: (match-number) ( x y [1|2] [1|2] -- x [z] ) + 2dup = if \ 1 1 | 2 2 + drop exit + then + 2dup > if + 2drop drop 1 exit + then + 2drop 0 + ; + +: (esc-number) ( maxchar -- ?? ?? num ) + >r depth >r ( R: depth maxchar ) + 0 (sequence) 2+ (escseq) 2- ( 0 seq+2 seqlen-2 ) + \ if numerical, scan until non-numerical + 0 ?do + ( 0 seq+2 ) + dup i + c@ a + digit if + ( 0 ptr n ) + rot a * + ( ptr val ) + swap + else + ( 0 ptr asc ) + ascii ; = if + 0 swap + else + drop leave + then + then + + loop + depth r> - r> + 0 to (escseq) + (match-number) + ; + +: (match-seq) + (escseq) 1- (sequence) + c@ \ get last character in sequence + \ dup draw-character + case + ascii A of \ CUU - cursor up + 1 (esc-number) + 0> if + 1 max + else + 1 + then + negate line# + + 0 max to line# + endof + ascii B of \ CUD - cursor down + 1 (esc-number) + 0> if + 1 max + line# + + #lines 1- min to line# + then + endof + ascii C of \ CUF - cursor forward + 1 (esc-number) + 0> if + 1 max + column# + + #columns 1- min to column# + then + endof + ascii D of \ CUB - cursor backward + 1 (esc-number) + 0> if + 1 max + negate column# + + 0 max to column# + then + endof + ascii E of \ Cursor next line (CNL) + \ FIXME - check agains ANSI3.64 + 1 (esc-number) + 0> if + 1 max + line# + + #lines 1- min to line# + then + 0 to column# + endof + ascii f of + 2 (esc-number) + case + 2 of + 1- #columns 1- min to column# + 1- #lines 1- min to line# + endof + 1 of + 0 to column# + 1- #lines 1- min to line# + endof + 0 of + 0 to column# + 0 to line# + drop + endof + endcase + endof + ascii H of + 2 (esc-number) + case + 2 of + 1- #columns 1- min to column# + 1- #lines 1- min to line# + endof + 1 of + 0 to column# + 1- #lines 1- min to line# + endof + 0 of + 0 to column# + 0 to line# + drop + endof + endcase + endof + ascii J of + 0 to (escseq) + #columns column# - delete-characters + #lines line# - delete-lines + endof + ascii K of + 0 to (escseq) + #columns column# - delete-characters + endof + ascii L of + 1 (esc-number) + 0> if + 1 max + insert-lines + then + endof + ascii M of + 1 (esc-number) + 1 = if + 1 max + delete-lines + then + endof + ascii @ of + 1 (esc-number) + 1 = if + 1 max + insert-characters + then + endof + ascii P of + 1 (esc-number) + 1 = if + 1 max + delete-characters + then + endof + ascii m of + 1 (esc-number) + 1 = if + 7 = if + true to inverse? + else + false to inverse? + then + then + endof + ascii p of \ normal text colors + 0 to (escseq) + inverse-screen? if + false to inverse-screen? + inverse? 0= to inverse? + invert-screen + then + endof + ascii q of \ inverse text colors + 0 to (escseq) + inverse-screen? not if + true to inverse-screen? + inverse? 0= to inverse? + invert-screen + then + endof + ascii s of + \ Resets the display device associated with the terminal emulator. + 0 to (escseq) + reset-screen + endof + endcase + ; + +: (term-emit) ( char -- ) + toggle-cursor + + (escseq) 0> if + (escseq) 10 = if + 0 to (escseq) + ." overflow in esc" cr + drop + then + (escseq) 1 = if + dup ascii [ = if \ not a [ + (sequence) 1+ c! + 2 to (escseq) + else + 0 to (escseq) \ break out of ESC sequence + ." out of ESC" cr + drop \ don't print breakout character + then + toggle-cursor exit + else + (sequence) (escseq) + c! + (escseq) 1+ to (escseq) + (match-seq) + toggle-cursor exit + then + then + + case + 0 of \ NULL + toggle-cursor exit + endof + 7 of \ BEL + blink-screen + s" /screen" s" ring-bell" + execute-device-method + endof + 8 of \ BS + column# 0<> if + column# 1- to column# + toggle-cursor exit + then + endof + 9 of \ TAB + column# dup #columns = if + drop + else + 8 + -8 and ff and to column# + then + toggle-cursor exit + endof + a of \ LF + line# 1+ to line# + 0 to column# + line# #lines >= if + 0 to line# + 1 delete-lines + #lines 1- to line# + toggle-cursor exit + then + endof + b of \ VT + line# 0<> if + line# 1- to line# + then + toggle-cursor exit + endof + c of \ FF + 0 to column# 0 to line# + erase-screen + endof + d of \ CR + 0 to column# + toggle-cursor exit + endof + 1b of \ ESC + 1b (sequence) c! + 1 to (escseq) + endof + + \ draw character and advance position + column# #columns >= if + 0 to column# + line# 1+ to line# + line# #lines >= if + 0 to line# + 1 delete-lines + #lines 1- to line# + then + then + + dup draw-character + column# 1+ to column# + + endcase + toggle-cursor + ; + +['] (term-emit) to fb-emit diff --git a/qemu/roms/openbios/forth/device/tree.fs b/qemu/roms/openbios/forth/device/tree.fs new file mode 100644 index 000000000..04f85b5c1 --- /dev/null +++ b/qemu/roms/openbios/forth/device/tree.fs @@ -0,0 +1,59 @@ +\ tag: Device Tree +\ +\ this code implements IEEE 1275-1994 ch. 3.5 +\ +\ Copyright (C) 2003 Stefan Reinauer +\ +\ See the file "COPYING" for further information about +\ the copyright and warranty status of this work. +\ + + +\ root node +new-device + " OpenBiosTeam,OpenBIOS" device-name + 1 encode-int " #address-cells" property + : open true ; + : close ; + : decode-unit parse-hex ; + : encode-unit ( addr -- str len ) + pocket tohexstr + ; + +new-device + " aliases" device-name + : open true ; + : close ; +finish-device + +new-device + " openprom" device-name + " BootROM" device-type + " OpenFirmware 3" model + 0 0 " relative-addressing" property + 0 0 " supports-bootinfo" property + 1 encode-int " boot-syntax" property + + : selftest + ." OpenBIOS selftest... succeded" cr + true + ; + : open true ; + : close ; + +finish-device + +new-device + " options" device-name +finish-device + +new-device + " chosen" device-name + 0 encode-int " stdin" property + 0 encode-int " stdout" property + \ " hda1:/boot/vmunix" encode-string " bootpath" property + \ " -as" encode-string " bootargs" property +finish-device + +\ END +finish-device diff --git a/qemu/roms/openbios/forth/lib/64bit.fs b/qemu/roms/openbios/forth/lib/64bit.fs new file mode 100644 index 000000000..239ddd028 --- /dev/null +++ b/qemu/roms/openbios/forth/lib/64bit.fs @@ -0,0 +1,128 @@ +\ +\ Copyright (C) 2009 Stefan Reinauer +\ +\ See the file "COPYING" for further information about +\ the copyright and warranty status of this work. +\ + +\ Implementation of IEEE Draft Std P1275.6/D5 +\ Standard for Boot (Initialization Configuration) Firmware +\ 64 Bit Extensions + + +cell /x = constant 64bit? + +64bit? [IF] + +: 32>64 ( 32bitsigned -- 64bitsigned ) + dup 80000000 and if \ is it negative? + ffffffff00000000 or \ then set all high bits + then +; + +: 64>32 ( 64bitsigned -- 32bitsigned ) + h# ffffffff and +; + +: lxjoin ( quad.lo quad.hi -- o ) + d# 32 lshift or +; + +: wxjoin ( w.lo w.2 w.3 w.hi -- o ) + wljoin >r wljoin r> lxjoin +; + +: bxjoin ( b.lo b.2 b.3 b.4 b.5 b.6 b.7 b.hi -- o ) + bljoin >r bljoin r> lxjoin +; + +: <l@ ( qaddr -- n ) + l@ 32>64 +; + +: unaligned-x@ ( addr - o ) + dup la1+ unaligned-l@ 64>32 swap unaligned-l@ 64>32 lxjoin +; + +: unaligned-x! ( o oaddr -- ) + >r dup d# 32 rshift r@ unaligned-l! + h# ffffffff and r> la1+ unaligned-l! +; + +: x@ ( oaddr -- o ) + unaligned-x@ \ for now +; + +: x! ( o oaddr -- ) + unaligned-x! \ for now +; + +: (rx@) ( oaddr - o ) + x@ +; + +: (rx!) ( o oaddr -- ) + x! +; + +: x, ( o -- ) + here /x allot x! +; + +: /x* ( nu1 -- nu2 ) + /x * +; + +: xa+ ( addr1 index -- addr2 ) + /x* + +; + +: xa1+ ( addr1 -- addr2 ) + /x + +; + +: xlsplit ( o -- quad.lo quad.hi ) + dup h# ffffffff and swap d# 32 rshift +; + +: xwsplit ( o -- w.lo w.2 w.3 w.hi ) + xlsplit >r lwsplit r> lwsplit +; + +: xbsplit ( o -- b.lo b.2 b.3 b.4 b.5 b.6 b.7 b.hi ) + xlsplit >r lbsplit r> lbsplit +; + +: xlflip ( oct1 -- oct2 ) + xlsplit swap lxjoin +; + +: xlflips ( oaddr len -- ) + bounds ?do + i unaligned-x@ xlflip i unaligned-x! + /x +loop +; + +: xwflip ( oct1 -- oct2 ) + xlsplit lwflip swap lwflip lxjoin +; + +: xwflips ( oaddr len -- ) + bounds ?do + i unaligned-x@ xwflip i unaligned-x! /x + +loop +; + +: xbflip ( oct1 -- oct2 ) + xlsplit lbflip swap lbflip lxjoin +; + +: xbflips ( oaddr len -- ) + bounds ?do + i unaligned-x@ xbflip i unaligned-x! + /x +loop +; + +\ : b(lit) b(lit) 32>64 ; + +[THEN] diff --git a/qemu/roms/openbios/forth/lib/build.xml b/qemu/roms/openbios/forth/lib/build.xml new file mode 100644 index 000000000..34eee4072 --- /dev/null +++ b/qemu/roms/openbios/forth/lib/build.xml @@ -0,0 +1,22 @@ +<build> + <!-- + build description for openbios forth library functions + + Copyright (C) 2003-2005 by Stefan Reinauer + See the file "COPYING" for further information about + the copyright and warranty status of this work. + --> + + <dictionary name="openbios" target="forth"> + <object source="vocabulary.fs"/> + <object source="string.fs"/> + <object source="preprocessor.fs"/> + <object source="preinclude.fs" /> <!-- FIXME dependencies --> + <object source="creation.fs"/> + <object source="split.fs"/> + <object source="lists.fs"/> + <object source="64bit.fs"/> + <object source="locals.fs"/> + </dictionary> + +</build> diff --git a/qemu/roms/openbios/forth/lib/creation.fs b/qemu/roms/openbios/forth/lib/creation.fs new file mode 100644 index 000000000..c3d0db84c --- /dev/null +++ b/qemu/roms/openbios/forth/lib/creation.fs @@ -0,0 +1,52 @@ +\ tag: misc useful functions +\ +\ C bindings +\ +\ Copyright (C) 2003, 2004 Samuel Rydh +\ +\ See the file "COPYING" for further information about +\ the copyright and warranty status of this work. +\ + +\ return xt of the word just defined +: last-xt ( -- xt ) + latest @ na1+ +; + +\ ------------------------------------------------------------------------- +\ word creation +\ ------------------------------------------------------------------------- + +: $is-ibuf ( size name name-len -- xt ) + instance $buffer: drop + last-xt +; + +: is-ibuf ( size -- xt ) + 0 0 $is-ibuf +; + +: is-ivariable ( size name len -- xt ) + 4 -rot instance $buffer: drop + last-xt +; + +: is-xt-func ( xt|0 wordstr len ) + header 1 , + ?dup if , then + ['] (semis) , reveal +; + +: is-2xt-func ( xt1 xt2 wordstr len ) + header 1 , + swap , , + ['] (semis) , reveal +; + +: is-func-begin ( wordstr len ) + header 1 , +; + +: is-func-end ( wordstr len ) + ['] (semis) , reveal +; diff --git a/qemu/roms/openbios/forth/lib/lists.fs b/qemu/roms/openbios/forth/lib/lists.fs new file mode 100644 index 000000000..91f7867b9 --- /dev/null +++ b/qemu/roms/openbios/forth/lib/lists.fs @@ -0,0 +1,26 @@ +\ tag: misc useful functions +\ +\ Misc useful functions +\ +\ Copyright (C) 2003 Samuel Rydh +\ +\ See the file "COPYING" for further information about +\ the copyright and warranty status of this work. +\ + +\ ------------------------------------------------------------------------- +\ statically allocated lists +\ ------------------------------------------------------------------------- +\ list-head should be a variable + +: list-add ( listhead -- ) + here 0 , swap \ next, [data...] + ( here listhead ) + begin dup @ while @ repeat ! +; + +: list-get ( listptr -- nextlistptr dictptr true | false ) + @ dup if + dup na1+ true + then +; diff --git a/qemu/roms/openbios/forth/lib/locals.fs b/qemu/roms/openbios/forth/lib/locals.fs new file mode 100644 index 000000000..e697383b6 --- /dev/null +++ b/qemu/roms/openbios/forth/lib/locals.fs @@ -0,0 +1,197 @@ +\ tag: local variables +\ +\ Copyright (C) 2012 Mark Cave-Ayland +\ +\ See the file "COPYING" for further information about +\ the copyright and warranty status of this work. +\ + +[IFDEF] CONFIG_LOCALS + +\ Init local variable stack +variable locals-var-stack +here 200 cells allot locals-var-stack ! + +\ Set initial stack pointer +\ +\ Stack looks like this: +\ ... (sp n-2) local1 ... localm-1 localm (sp n-1) <-- sp + +locals-var-stack @ value locals-var-sp +locals-var-sp locals-var-stack @ ! + +0 value locals-var-count +0 value locals-flags + +here 200 cells allot locals-dict-buf ! + +8 constant #locals + +: (local1) locals-var-sp @ /n + ; +: (local2) locals-var-sp @ 2 cells + ; +: (local3) locals-var-sp @ 3 cells + ; +: (local4) locals-var-sp @ 4 cells + ; +: (local5) locals-var-sp @ 5 cells + ; +: (local6) locals-var-sp @ 6 cells + ; +: (local7) locals-var-sp @ 7 cells + ; +: (local8) locals-var-sp @ 8 cells + ; + +: local1@ (local1) @ ; +: local2@ (local2) @ ; +: local3@ (local3) @ ; +: local4@ (local4) @ ; +: local5@ (local5) @ ; +: local6@ (local6) @ ; +: local7@ (local7) @ ; +: local8@ (local8) @ ; + +: local1! (local1) ! ; +: local2! (local2) ! ; +: local3! (local3) ! ; +: local4! (local4) ! ; +: local5! (local5) ! ; +: local6! (local6) ! ; +: local7! (local7) ! ; +: local8! (local8) ! ; + +create locals-read-table +['] local1@ , +['] local2@ , +['] local3@ , +['] local4@ , +['] local5@ , +['] local6@ , +['] local7@ , +['] local8@ , + +create locals-write-table +['] local1! , +['] local2! , +['] local3! , +['] local4! , +['] local5! , +['] local6! , +['] local7! , +['] local8! , + + +: locals-push ( n -- ) + locals-var-sp /n + to locals-var-sp + locals-var-sp ! +; + +: locals-0-push ( -- ) + 0 locals-push +; + +: (apply-local-flags) ( lfa -- ) + 1 - dup c@ locals-flags or swap c! +; + +: locals-no-pop? ( lfa -- ? ) + 1 - c@ 8 and 0<> +; + +: locals-drop \ Destroy current stack frame + locals-var-sp @ to locals-var-sp +; + +['] locals-drop to locals-end + +: (local-init) ( str len -- ) + header 1 , \ DOCOL + ['] (lit) , ['] noop , \ read-xt + ['] (lit) , ['] noop , \ write-xt + ['] 2drop , \ do nothing + ['] (lit) , + here 5 cells - , + ['] @ , ['] , , \ store read-xt + ['] (semis) , + reveal + immediate + last @ (apply-local-flags) +; + +: (local-noop) ( str len -- ) + 2drop +; + +\ Word called when consuming a local variable +defer (local) + +: } ( C: current latest here -- ) + here! latest ! current ! \ Switch back to normal dict + locals-dict-buf @ to locals-dict \ Make locals-dict visible to $find + 0 to locals-var-count + ['] locals-var-sp , \ save previous sp on rstack + ['] >r , + locals-dict @ \ ( last -- ) + begin + ?dup 0<> + while + >r + locals-var-count /n * + locals-read-table + @ r@ 3 cells + ! \ set read-xt + locals-var-count /n * + locals-write-table + @ r@ 5 cells + ! \ set write-xt + locals-var-count 1+ to locals-var-count + r@ locals-no-pop? if + ['] locals-0-push , \ initialise with 0 + else + ['] locals-push , \ initialise from stack + then + r> @ \ next lfa + repeat + ['] r> , + ['] locals-push , \ write previous sp +; immediate + +: { ( C: -- current latest here ) + current @ latest @ here + ['] (local-init) to (local) + 0 to locals-flags + 0 to locals-var-count + locals-dict-buf @ 200 cells 0 fill \ Zero out temporary dictionary + locals-dict-buf @ current ! \ Switch to locals dictionary + locals-dict-buf @ /n + here! + + begin + parse-word + 2dup s" }" strcmp 0= if + 2drop + ['] } execute -1 + else + 2dup s" ;" strcmp 0= if + 2drop + 8 to locals-flags 0 \ Don't init from stack + else + 2dup s" |" strcmp 0= if + 2drop + 8 to locals-flags 0 \ Don't init from stack + else + 2dup s" --" strcmp 0= if + 2drop + ['] (local-noop) to (local) 0 + else + locals-var-count #locals < if + (local) 0 \ accept local + else + s" maximum locals used ignoring " type type cr 0 + then + locals-var-count 1+ to locals-var-count + then + then + then + then + until +; immediate + +: -> ( n -- ) + parse-word $find if + 4 cells + @ , + else + s" unable to find word " type type + then +; immediate + +[THEN] diff --git a/qemu/roms/openbios/forth/lib/preinclude.fs b/qemu/roms/openbios/forth/lib/preinclude.fs new file mode 100644 index 000000000..6f20ea8f7 --- /dev/null +++ b/qemu/roms/openbios/forth/lib/preinclude.fs @@ -0,0 +1,11 @@ +\ +\ config and build date includes +\ +\ Copyright (C) 2005 Stefan Reinauer +\ +\ See the file "COPYING" for further information about +\ the copyright and warranty status of this work. +\ + +include config.fs +include version.fs diff --git a/qemu/roms/openbios/forth/lib/preprocessor.fs b/qemu/roms/openbios/forth/lib/preprocessor.fs new file mode 100644 index 000000000..89d478cff --- /dev/null +++ b/qemu/roms/openbios/forth/lib/preprocessor.fs @@ -0,0 +1,76 @@ +\ tag: Forth preprocessor +\ +\ Forth preprocessor +\ +\ Copyright (C) 2003, 2004 Samuel Rydh +\ +\ See the file "COPYING" for further information about +\ the copyright and warranty status of this work. +\ + +0 value prep-wid +0 value prep-dict +0 value prep-here + +: ([IF]) + begin + begin parse-word dup 0= while + 2drop refill + repeat + + 2dup " [IF]" strcmp 0= if 1 throw then + 2dup " [IFDEF]" strcmp 0= if 1 throw then + 2dup " [ELSE]" strcmp 0= if 2 throw then + 2dup " [THEN]" strcmp 0= if 3 throw then + " \\" strcmp 0= if linefeed parse 2drop then + again +; + +: [IF] ( flag -- ) + if exit then + 1 begin + ['] ([IF]) catch case + \ EOF (FIXME: this does not work) + \ -1 of ." Missing [THEN]" abort exit endof + \ [IF] + 1 of 1+ endof + \ [ELSE] + 2 of dup 1 = if 1- then endof + \ [THEN] + 3 of 1- endof + endcase + dup 0 <= + until drop +; immediate + +: [ELSE] 0 [ ['] [IF] , ] ; immediate +: [THEN] ; immediate + +:noname + 0 to prep-wid + 0 to prep-dict +; initializer + +: [IFDEF] ( <word> -- ) + prep-wid if + parse-word prep-wid search-wordlist dup if nip then + else 0 then + [ ['] [IF] , ] +; immediate + +: [DEFINE] ( <word> -- ) + parse-word here get-current >r >r + prep-dict 0= if + 2000 alloc-mem here! + here to prep-dict + wordlist to prep-wid + here to prep-here + then + prep-wid set-current prep-here here! + $create + here to prep-here + r> r> set-current here! +; immediate + +: [0] 0 ; immediate +: [1] 1 ; immediate diff --git a/qemu/roms/openbios/forth/lib/split.fs b/qemu/roms/openbios/forth/lib/split.fs new file mode 100644 index 000000000..1a7ac3a0a --- /dev/null +++ b/qemu/roms/openbios/forth/lib/split.fs @@ -0,0 +1,49 @@ +\ implements split-before, split-after and left-split +\ as described in 4.3 (Path resolution) + +\ delimeter returned in R-string +: split-before ( addr len delim -- addr-R len-R addr-L len-L ) + 0 rot dup >r 0 ?do + ( str char cnt R: len <sys> ) + 2 pick over + c@ 2 pick = if leave then + 1+ + loop + nip + 2dup + r> 2 pick - + 2swap +; + +\ delimeter returned in L-string +: split-after ( addr len delim -- addr-R len-R addr-L len-L ) + over 1- rot dup >r 0 ?do + ( str char cnt R: len <sys> ) + 2 pick over + c@ 2 pick = if leave then + 1- + loop + nip + dup 0 >= if 1+ else drop r@ then + 2dup + r> 2 pick - + 2swap +; + +\ delimiter not returned +: left-split ( addr len delim -- addr-R len-R addr-L len-L ) + 0 rot dup >r 0 ?do + ( str char cnt R: len <sys> ) + 2 pick i + c@ 2 pick = if leave then + 1+ + loop + nip + 2dup + 1+ r> 2 pick - + dup if 1- then + 2swap +; + +\ delimiter not returned [THIS FUNCTION IS NOT NEEDED] +: right-split ( addr len delim -- addr-R len-R addr-L len-L ) + dup >r + split-after + dup if 2dup + 1- + c@ r@ = if 1- then then + r> drop +; diff --git a/qemu/roms/openbios/forth/lib/string.fs b/qemu/roms/openbios/forth/lib/string.fs new file mode 100644 index 000000000..eb6474917 --- /dev/null +++ b/qemu/roms/openbios/forth/lib/string.fs @@ -0,0 +1,127 @@ +\ tag: misc useful functions +\ +\ Misc useful functions +\ +\ Copyright (C) 2003 Samuel Rydh +\ +\ See the file "COPYING" for further information about +\ the copyright and warranty status of this work. +\ + +\ compare c-string with (str len) pair +: comp0 ( cstr str len -- 0|-1|1 ) + 3dup + comp ?dup if >r 3drop r> exit then + nip + c@ 0<> if 1 else 0 then +; + +\ returns 0 if the strings match +: strcmp ( str1 len1 str2 len2 -- 0|1 ) + rot over <> if 3drop 1 exit then + comp if 1 else 0 then +; + +: strchr ( str len char -- where|0 ) + >r + begin + 1- dup 0>= + while + ( str len ) + over c@ r@ = if r> 2drop exit then + swap 1+ swap + repeat + r> 3drop 0 +; + +: cstrlen ( cstr -- len ) + dup + begin dup c@ while 1+ repeat + swap - +; + +: strdup ( str len -- newstr len ) + dup if + dup >r + dup alloc-mem dup >r swap move + r> r> + else + 2drop 0 0 + then +; + +: dict-strdup ( str len -- dict-addr len ) + dup here swap allot null-align + swap 2dup >r >r move r> r> +; + +\ ----------------------------------------------------- +\ string copy and cat variants +\ ----------------------------------------------------- + +: tmpstrcat ( addr2 len2 addr1 len1 tmpbuf -- buf len1+len2 tmpbuf+l1+l2 ) + \ save return arguments + dup 2 pick + 4 pick + >r ( R: buf+l1+l2 ) + over 4 pick + >r + dup >r + \ copy... + 2dup + >r + swap move r> swap move + r> r> r> +; + +: tmpstrcpy ( addr1 len1 tmpbuf -- tmpbuf len1 tmpbuf+len1 ) + swap 2dup >r >r move + r> r> 2dup + +; + + + +\ ----------------------------------------------------- +\ number to string conversion +\ ----------------------------------------------------- + +: numtostr ( num buf -- buf len ) + swap rdepth -rot + ( rdepth buf num ) + begin + base @ u/mod swap + \ dup 0< if base @ + then + dup a < if ascii 0 else ascii a a - then + >r + ?dup 0= + until + + rdepth rot - 0 + ( buf len cnt ) + begin + r> over 4 pick + c! + 1+ 2dup <= + until + drop +; + +: tohexstr ( num buf -- buf len ) + base @ hex -rot numtostr rot base ! +; + +: toudecstr ( num buf -- buf len ) + base @ decimal -rot numtostr rot base ! +; + +: todecstr ( num buf -- buf len ) + over 0< if + swap negate over ascii - over c! 1+ + ( buf num buf+1 ) + toudecstr 1+ nip + else + toudecstr + then +; + + +\ ----------------------------------------------------- +\ string to number conversion +\ ----------------------------------------------------- + +: parse-hex ( str len -- value ) + base @ hex -rot $number if 0 then swap base ! +; diff --git a/qemu/roms/openbios/forth/lib/vocabulary.fs b/qemu/roms/openbios/forth/lib/vocabulary.fs new file mode 100644 index 000000000..faa75ea87 --- /dev/null +++ b/qemu/roms/openbios/forth/lib/vocabulary.fs @@ -0,0 +1,153 @@ +\ tag: vocabulary implementation for openbios +\ +\ Copyright (C) 2003 Stefan Reinauer +\ +\ See the file "COPYING" for further information about +\ the copyright and warranty status of this work. +\ + +\ +\ this is an implementation of DPANS94 wordlists (SEARCH EXT) +\ + + +16 constant #vocs +create vocabularies #vocs cells allot \ word lists +['] vocabularies to context + +: search-wordlist ( c-addr u wid -- 0 | xt 1 | xt -1 ) + \ Find the definition identified by the string c-addr u in the word + \ list identified by wid. If the definition is not found, return zero. + \ If the definition is found, return its execution token xt and + \ one (1) if the definition is immediate, minus-one (-1) otherwise. + find-wordlist + if + true over immediate? if + negate + then + else + 2drop false + then + ; + +: wordlist ( -- wid ) + \ Creates a new empty word list, returning its word list identifier + \ wid. The new word list may be returned from a pool of preallocated + \ word lists or may be dynamically allocated in data space. A system + \ shall allow the creation of at least 8 new word lists in addition + \ to any provided as part of the system. + here 0 , + ; + +: get-order ( -- wid1 .. widn n ) + #order @ 0 ?do + #order @ i - 1- cells context + @ + loop + #order @ + ; + +: set-order ( wid1 .. widn n -- ) + dup -1 = if + drop forth-last 1 \ push system default word list and number of lists + then + dup #order ! + 0 ?do + i cells context + ! + loop + ; + +: order ( -- ) + \ display word lists in the search order in their search order sequence + \ from the first searched to last searched. Also display word list into + \ which new definitions will be placed. + cr + get-order 0 ?do + ." wordlist " i (.) type 2e emit space u. cr + loop + cr ." definitions: " current @ u. cr + ; + + +: previous ( -- ) + \ Transform the search order consisting of widn, ... wid2, wid1 (where + \ wid1 is searched first) into widn, ... wid2. An ambiguous condition + \ exists if the search order was empty before PREVIOUS was executed. + get-order nip 1- set-order + ; + + +: do-vocabulary ( -- ) \ implementation factor + does> + @ >r ( ) ( R: widnew ) + get-order swap drop ( wid1 ... widn-1 n ) + r> swap set-order + ; + +: discard ( x1 .. xu u - ) \ implementation factor + 0 ?do + drop + loop + ; + +: vocabulary ( >name -- ) + wordlist create , do-vocabulary + ; + +: also ( -- ) + get-order over swap 1+ set-order + ; + +: only ( -- ) + -1 set-order also + ; + +only + +\ create forth forth-wordlist , do-vocabulary +create forth get-order over , discard do-vocabulary + +: findw ( c-addr -- c-addr 0 | w 1 | w -1 ) + 0 ( c-addr 0 ) + #order @ 0 ?do + over count ( c-addr 0 c-addr' u ) + i cells context + @ ( c-addr 0 c-addr' u wid ) + search-wordlist ( c-addr 0; 0 | w 1 | w -1 ) + ?dup if ( c-addr 0; w 1 | w -1 ) + 2swap 2drop leave ( w 1 | w -1 ) + then ( c-addr 0 ) + loop ( c-addr 0 | w 1 | w -1 ) + ; + +: get-current ( -- wid ) + current @ + ; + +: set-current ( wid -- ) + current ! + ; + +: definitions ( -- ) + \ Make the compilation word list the same as the first word list in + \ the search order. Specifies that the names of subsequent definitions + \ will be placed in the compilation word list. + \ Subsequent changes in the search order will not affect the + \ compilation word list. + context @ set-current + ; + +: forth-wordlist ( -- wid ) + forth-last + ; + +: #words ( -- ) + 0 last + begin + @ ?dup + while + swap 1+ swap + repeat + + cr + ; + +true to vocabularies? diff --git a/qemu/roms/openbios/forth/packages/Kconfig b/qemu/roms/openbios/forth/packages/Kconfig new file mode 100644 index 000000000..16fa30657 --- /dev/null +++ b/qemu/roms/openbios/forth/packages/Kconfig @@ -0,0 +1,16 @@ + +config PKG_DEBLOCKER + bool "Deblocker" + default y + +config PKG_DISKLABEL + bool "Disk Label" + default y + +config PKG_OBP_TFTP + bool "OBP-TFTP" + default y + +config PKG_TERMINAL_EMULATOR + bool "Terminal Emulator" + default y diff --git a/qemu/roms/openbios/forth/packages/README b/qemu/roms/openbios/forth/packages/README new file mode 100644 index 000000000..009f9ec35 --- /dev/null +++ b/qemu/roms/openbios/forth/packages/README @@ -0,0 +1,11 @@ +IEEE 1275-1994 support packages +------------------------------- + +These files create the sub nodes of the /packages node. The nodes +do normally not need an open or close method since their methods are +called statically. + +Currently there are the following support packages: +* deblocker +* obp-tftp +* diff --git a/qemu/roms/openbios/forth/packages/build.xml b/qemu/roms/openbios/forth/packages/build.xml new file mode 100644 index 000000000..16184717e --- /dev/null +++ b/qemu/roms/openbios/forth/packages/build.xml @@ -0,0 +1,19 @@ +<build> + + <!-- + build description for Open Firmware support packages + + Copyright (C) 2004-2005 by Stefan Reinauer + See the file "COPYING" for further information about + the copyright and warranty status of this work. + --> + + <dictionary name="openbios" target="forth"> + <object source="packages.fs"/> + <object source="deblocker.fs" condition="PKG_DEBLOCKER"/> + <object source="disklabel.fs" condition="PKG_DISKLABEL"/> + <object source="terminal-emulator.fs" condition="PKG_TERM_EMUL"/> + <object source="obp-tftp.fs" condition="OBP_TFTP"/> + </dictionary> + +</build> diff --git a/qemu/roms/openbios/forth/packages/deblocker.fs b/qemu/roms/openbios/forth/packages/deblocker.fs new file mode 100644 index 000000000..31a37d002 --- /dev/null +++ b/qemu/roms/openbios/forth/packages/deblocker.fs @@ -0,0 +1,63 @@ +\ tag: deblocker support package +\ +\ Copyright (C) 2003 Stefan Reinauer +\ +\ See the file "COPYING" for further information about +\ the copyright and warranty status of this work. +\ + +" /packages" find-device + +\ The deblocker package makes it easy to implement byte-oriented device +\ methods, using the block-oriented or record-oriented methods defined by +\ devices such as disks or tapes. It provides a layer of buffering between +\ the high-level byte-oriented interface and the low-level block-oriented +\ interface. deblocker uses the max-transfer, block-size, read-blocks and +\ write-blocks methods of its parent. + +new-device + " deblocker" device-name + \ open ( -- flag ) + \ Prepares the package for subsequent use, allocating the buffers used + \ by the deblocking process based upon the values returned by the parent + \ instance's max-transfer and block-size methods. Returns -1 if the + \ operation succeeds, 0 otherwise. + : open ( -- flag ) + + ; + + \ close ( -- ) + \ Frees all resources that were allocated by open. + : close ( -- ) + ; + + \ read ( adr len -- actual ) + \ Reads at most len bytes from the device into the memory buffer + \ beginning at adr. Returns actual, the number of bytes actually + \ read, or 0 if the read operation failed. Uses the parent's read- + \ blocks method as necessary to satisfy the request, buffering any + \ unused bytes for the next request. + + : read ( adr len -- actual ) + ; + + \ Writes at most len bytes from the device into the memory buffer + \ beginning at adr. Returns actual, the number of bytes actually + \ read, or 0 if the write operation failed. Uses the parent's write- + \ blocks method as necessary to satisfy the request, buffering any + \ unused bytes for the next request. + + : write ( adr len -- actual ) + ; + + \ Sets the device position at which the next read or write will take + \ place. The position is specified by the 64-bit number x.position. + \ Returns 0 if the operation succeeds or -1 if it fails. + + : seek ( x.position -- flag ) + ; + +finish-device + +\ clean up afterwards +device-end diff --git a/qemu/roms/openbios/forth/packages/disklabel.fs b/qemu/roms/openbios/forth/packages/disklabel.fs new file mode 100644 index 000000000..39aa13e50 --- /dev/null +++ b/qemu/roms/openbios/forth/packages/disklabel.fs @@ -0,0 +1,22 @@ +\ tag: disklabel support package +\ +\ Copyright (C) 2003 Stefan Reinauer +\ +\ See the file "COPYING" for further information about +\ the copyright and warranty status of this work. +\ + +" /packages" find-device + +\ +\ IEEE 1275 disklabel package +\ + +new-device + " disklabel" device-name + \ now the methods... + +finish-device + +\ clean up afterwards +device-end diff --git a/qemu/roms/openbios/forth/packages/obp-tftp.fs b/qemu/roms/openbios/forth/packages/obp-tftp.fs new file mode 100644 index 000000000..62f0e72e5 --- /dev/null +++ b/qemu/roms/openbios/forth/packages/obp-tftp.fs @@ -0,0 +1,22 @@ +\ tag: tftp support package +\ +\ Copyright (C) 2003 Stefan Reinauer +\ +\ See the file "COPYING" for further information about +\ the copyright and warranty status of this work. +\ + +" /packages" find-device + +\ +\ IEEE 1275 obp-tftp package +\ + +new-device + " obp-tftp" device-name + \ now the methods... + +finish-device + +\ clean up afterwards +device-end diff --git a/qemu/roms/openbios/forth/packages/packages.fs b/qemu/roms/openbios/forth/packages/packages.fs new file mode 100644 index 000000000..9f79f9e5f --- /dev/null +++ b/qemu/roms/openbios/forth/packages/packages.fs @@ -0,0 +1,17 @@ +\ tag: /packages sub device tree +\ +\ Copyright (C) 2003 Stefan Reinauer +\ +\ See the file "COPYING" for further information about +\ the copyright and warranty status of this work. +\ + +" /" find-device + +new-device + " packages" device-name + : open true ; + : close ; +finish-device + +device-end diff --git a/qemu/roms/openbios/forth/packages/terminal-emulator.fs b/qemu/roms/openbios/forth/packages/terminal-emulator.fs new file mode 100644 index 000000000..0ecd348be --- /dev/null +++ b/qemu/roms/openbios/forth/packages/terminal-emulator.fs @@ -0,0 +1,23 @@ +\ tag: terminal emulator support package +\ +\ Copyright (C) 2003 Stefan Reinauer +\ +\ See the file "COPYING" for further information about +\ the copyright and warranty status of this work. +\ + +" /packages" find-device + +\ +\ IEEE 1275 terminal-emulator package +\ + +new-device + " terminal-emulator" device-name + \ now the methods... + +finish-device + +\ clean up afterwards + +device-end diff --git a/qemu/roms/openbios/forth/system/build.xml b/qemu/roms/openbios/forth/system/build.xml new file mode 100644 index 000000000..f15440a07 --- /dev/null +++ b/qemu/roms/openbios/forth/system/build.xml @@ -0,0 +1,16 @@ +<build> + + <!-- + build description for openbios system bindings + + Copyright (C) 2004-2005 by Stefan Reinauer + See the file "COPYING" for further information about + the copyright and warranty status of this work. + --> + + <dictionary name="openbios" target="forth"> + <object source="main.fs"/> + <object source="ciface.fs"/> + </dictionary> + +</build> diff --git a/qemu/roms/openbios/forth/system/ciface.fs b/qemu/roms/openbios/forth/system/ciface.fs new file mode 100644 index 000000000..fd6c54efd --- /dev/null +++ b/qemu/roms/openbios/forth/system/ciface.fs @@ -0,0 +1,363 @@ + +0 value ciface-ph + +dev /openprom/ +new-device +" client-services" device-name + +active-package to ciface-ph + +\ ------------------------------------------------------------- +\ private stuff +\ ------------------------------------------------------------- + +private + +variable callback-function + +: ?phandle ( phandle -- phandle ) + dup 0= if ." NULL phandle" -1 throw then +; +: ?ihandle ( ihandle -- ihandle ) + dup 0= if ." NULL ihandle" -2 throw then +; + +\ copy and null terminate return string +: ci-strcpy ( buf buflen str len -- len ) + >r -rot dup + ( str buf buflen buflen R: len ) + r@ min swap + ( str buf n buflen R: len ) + over > if + ( str buf n ) + 2dup + 0 swap c! + then + move r> +; + +0 value memory-ih +0 value mmu-ih + +:noname ( -- ) + " /chosen" find-device + + " mmu" active-package get-package-property 0= if + decode-int nip nip to mmu-ih + then + + " memory" active-package get-package-property 0= if + decode-int nip nip to memory-ih + then + device-end +; SYSTEM-initializer + +: safetype + ." <" dup cstrlen dup 20 < if type else 2drop ." BAD" then ." >" +; + +: phandle-exists? ( phandle -- found? ) + false swap 0 + begin iterate-tree ?dup while + ( found? find-ph current-ph ) + over over = if + rot drop true -rot + then + repeat + drop +; + +\ ------------------------------------------------------------- +\ public interface +\ ------------------------------------------------------------- + +external + +\ ------------------------------------------------------------- +\ 6.3.2.1 Client interface +\ ------------------------------------------------------------- + +\ returns -1 if missing +: test ( name -- 0|-1 ) + dup cstrlen ciface-ph find-method + if drop 0 else -1 then +; + +\ ------------------------------------------------------------- +\ 6.3.2.2 Device tree +\ ------------------------------------------------------------- + +: peer peer ; +: child child ; +: parent parent ; + +: getproplen ( name phandle -- len|-1 ) + over cstrlen swap + ?phandle get-package-property + if -1 else nip then +; + +: getprop ( buflen buf name phandle -- size|-1 ) + \ detect phandle == -1 + dup -1 = if + 2drop 2drop -1 exit + then + + \ return -1 if phandle is 0 (MacOS actually does this) + ?dup 0= if drop 2drop -1 exit then + + over cstrlen swap + ?phandle get-package-property if 2drop -1 exit then + ( buflen buf prop proplen ) + >r swap rot r> + ( prop buf buflen proplen ) + dup >r min move r> +; + +\ 1 OK, 0 no more prop, -1 prev invalid +: nextprop ( buf prev phandle -- 1|0|-1 ) + >r + dup 0= if 0 else dup cstrlen then + + ( buf prev prev_len ) + + \ verify that prev exists (overkill...) + dup if + 2dup r@ get-package-property if + r> 2drop drop + 0 swap c! + -1 exit + else + 2drop + then + then + + ( buf prev prev_len ) + + r> next-property if + ( buf name name_len ) + dup 1+ -rot ci-strcpy drop 1 + else + ( buf ) + 0 swap c! + 0 + then +; + +: setprop ( len buf name phandle -- size ) + 3 pick >r + >r >r swap encode-bytes \ ( prop-addr prop-len R: phandle name ) + r> dup cstrlen r> + (property) + r> +; + +: finddevice ( dev_spec -- phandle|-1 ) + dup cstrlen + \ ." FIND-DEVICE " 2dup type + find-dev 0= if -1 then + \ ." -- " dup . cr +; + +: instance-to-package ( ihandle -- phandle ) + ?ihandle ihandle>phandle +; + +: package-to-path ( buflen buf phandle -- length ) + \ XXX improve error checking + dup 0= if 3drop -1 exit then + >r swap r> + get-package-path + ( buf buflen str len ) + ci-strcpy +; + +: canon ( buflen buf dev_specifier -- len ) + dup cstrlen find-dev if + ( buflen buf phandle ) + package-to-path + else + 2drop -1 + then +; + +: instance-to-path ( buflen buf ihandle -- length ) + \ XXX improve error checking + dup 0= if 3drop -1 exit then + >r swap r> + get-instance-path + \ ." INSTANCE: " 2dup type cr dup . + ( buf buflen str len ) + ci-strcpy +; + +: instance-to-interposed-path ( buflen buf ihandle -- length ) + \ XXX improve error checking + dup 0= if 3drop -1 exit then + >r swap r> + get-instance-interposed-path + ( buf buflen str len ) + ci-strcpy +; + +: call-method ( ihandle method -- xxxx catch-result ) + dup 0= if ." call of null method" -1 exit then + dup >r + dup cstrlen + \ ." call-method " 2dup type cr + rot ?ihandle ['] $call-method catch dup if + \ not necessary an error but very useful for debugging... + ." call-method " r@ dup cstrlen type ." : exception " dup . cr + then + r> drop +; + + +\ ------------------------------------------------------------- +\ 6.3.2.3 Device I/O +\ ------------------------------------------------------------- + +: open ( dev_spec -- ihandle|0 ) + dup cstrlen open-dev +; + +: close ( ihandle -- ) + close-dev +; + +: read ( len addr ihandle -- actual ) + >r swap r> + dup ihandle>phandle " read" rot find-method + if swap call-package else 3drop -1 then +; + +: write ( len addr ihandle -- actual ) + >r swap r> + dup ihandle>phandle " write" rot find-method + if swap call-package else 3drop -1 then +; + +: seek ( pos_lo pos_hi ihandle -- status ) + dup ihandle>phandle " seek" rot find-method + if swap call-package else 3drop -1 then +; + + +\ ------------------------------------------------------------- +\ 6.3.2.4 Memory +\ ------------------------------------------------------------- + +: claim ( align size virt -- baseaddr|-1 ) + -rot swap + ciface-ph " cif-claim" rot find-method + if execute else 3drop -1 then +; + +: release ( size virt -- ) + swap + ciface-ph " cif-release" rot find-method + if execute else 2drop -1 then +; + +\ ------------------------------------------------------------- +\ 6.3.2.5 Control transfer +\ ------------------------------------------------------------- + +: boot ( bootspec -- ) + ." BOOT" +; + +: enter ( -- ) + ." ENTER" +; + +\ exit ( -- ) is defined later (clashes with builtin exit) + +: chain ( virt size entry args len -- ) + ." CHAIN" +; + +\ ------------------------------------------------------------- +\ 6.3.2.6 User interface +\ ------------------------------------------------------------- + +: interpret ( xxx cmdstring -- ??? catch-reult ) + dup cstrlen + \ ." INTERPRETE: --- " 2dup type + ['] evaluate catch dup if + \ this is not necessary an error... + ." interpret: exception " dup . ." caught" cr + + \ Force back to interpret state on error, otherwise the next call to + \ interpret gets confused if the error occurred in compile mode + 0 state ! + then + \ ." --- " cr +; + +: set-callback ( newfunc -- oldfunc ) + callback-function @ + swap + callback-function ! +; + +\ : set-symbol-lookup ( sym-to-value -- value-to-sym ) ; + + +\ ------------------------------------------------------------- +\ 6.3.2.7 Time +\ ------------------------------------------------------------- + +: milliseconds ( -- ms ) + get-msecs +; + +\ ------------------------------------------------------------- +\ arch? +\ ------------------------------------------------------------- + +: start-cpu ( xxx xxx xxx --- ) + ." Start CPU unimplemented" cr + 3drop +; + +\ ------------------------------------------------------------- +\ special +\ ------------------------------------------------------------- + +: exit ( -- ) + ." EXIT" + outer-interpreter +; + +: test-method ( cstring-method phandle -- missing? ) + swap dup cstrlen rot + + \ Check for incorrect phandle + dup phandle-exists? false = if + -1 throw + then + + find-method 0= if -1 else drop 0 then +; + +finish-device +device-end + + +\ ------------------------------------------------------------- +\ entry point +\ ------------------------------------------------------------- + +: client-iface ( [args] name len -- [args] -1 | [rets] 0 ) + ciface-ph find-method 0= if -1 exit then + catch ?dup if + cr ." Unexpected client interface exception: " . -2 cr exit + then + 0 +; + +: client-call-iface ( [args] name len -- [args] -1 | [rets] 0 ) + ciface-ph find-method 0= if -1 exit then + execute + 0 +; diff --git a/qemu/roms/openbios/forth/system/main.fs b/qemu/roms/openbios/forth/system/main.fs new file mode 100644 index 000000000..122ab1fa3 --- /dev/null +++ b/qemu/roms/openbios/forth/system/main.fs @@ -0,0 +1,60 @@ +\ tag: misc useful functions +\ +\ Open Firmware Startup +\ +\ Copyright (C) 2003 Samuel Rydh +\ +\ See the file "COPYING" for further information about +\ the copyright and warranty status of this work. +\ + +variable PREPOST-list +variable POST-list +variable SYSTEM-list +variable DIAG-list + +: PREPOST-initializer ( xt -- ) + PREPOST-list list-add , +; + +: POST-initializer ( xt -- ) + POST-list list-add , +; + +: SYSTEM-initializer ( xt -- ) + SYSTEM-list list-add , +; + +: DIAG-initializer ( xt -- ) + DIAG-list list-add , +; + + +\ OpenFirmware entrypoint +: initialize-of ( startmem endmem -- ) + initialize-forth + + PREPOST-list begin list-get while @ execute repeat + POST-list begin list-get while @ execute repeat + SYSTEM-list begin list-get while @ execute repeat + + \ evaluate nvramrc script + use-nvramrc? if + nvramrc evaluate + then + + \ probe-all etc. + suppress-banner? 0= if + probe-all + install-console + banner + then + + DIAG-list begin list-get while @ execute repeat + + auto-boot? if + boot-command evaluate + then + + outer-interpreter +; diff --git a/qemu/roms/openbios/forth/testsuite/README b/qemu/roms/openbios/forth/testsuite/README new file mode 100644 index 000000000..7aa98dea3 --- /dev/null +++ b/qemu/roms/openbios/forth/testsuite/README @@ -0,0 +1,8 @@ +TESTSUITES +---------- + +This directory contains additional testsuites for some open +firmware components. They are not built per default. + + +tag: testsuites readme diff --git a/qemu/roms/openbios/forth/testsuite/build.xml b/qemu/roms/openbios/forth/testsuite/build.xml new file mode 100644 index 000000000..7b7d62bcf --- /dev/null +++ b/qemu/roms/openbios/forth/testsuite/build.xml @@ -0,0 +1,16 @@ +<build> + + <!-- + build description for OpenBIOS test suite + + Copyright (C) 2004-2005 by Stefan Reinauer + See the file "COPYING" for further information about + the copyright and warranty status of this work. + --> + + <dictionary name="testsuite" target="forth"> + <object source="memory-testsuite.fs"/> + <object source="splitfunc-testsuite.fs"/> + </dictionary> + +</build> diff --git a/qemu/roms/openbios/forth/testsuite/fract.fs b/qemu/roms/openbios/forth/testsuite/fract.fs new file mode 100644 index 000000000..39c984056 --- /dev/null +++ b/qemu/roms/openbios/forth/testsuite/fract.fs @@ -0,0 +1,35 @@ +\ tag: forth fractal example +\ +\ Copyright (C) 2002, 2003 Volker Poplawski <volker@poplawski.de> +\ Stefan Reinauer + +\ This example even fits in a signature ;-) + +\ hex 4666 dup negate do i 4000 dup 2* negate do 2a 0 dup 2dup 1e 0 do +\ 2swap * d >>a 4 pick + -rot - j + dup dup * e >>a rot dup dup * e >>a +\ rot swap 2dup + 10000 > if 3drop 2drop 20 0 dup 2dup leave then loop +\ 2drop 2drop type 268 +loop cr drop 5de +loop + + +: fract +4666 dup negate +do + i 4000 dup 2* negate + do + 2a 0 dup 2dup 1e 0 + do + 2swap * d >>a 4 pick + + -rot - j + + dup dup * e >>a rot + dup dup * e >>a rot + swap + 2dup + 10000 > if + 3drop 2drop 20 0 dup 2dup leave + then + loop + 2drop 2drop + emit + 268 +loop + cr drop +5de +loop +; diff --git a/qemu/roms/openbios/forth/testsuite/framebuffer-test.fs b/qemu/roms/openbios/forth/testsuite/framebuffer-test.fs new file mode 100644 index 000000000..110993259 --- /dev/null +++ b/qemu/roms/openbios/forth/testsuite/framebuffer-test.fs @@ -0,0 +1,10 @@ + +: test-screen + 10 10 pci-l@ + f0 0 do + dup d# 1280 i * + + 500 i fill + loop + ; + + test-screen diff --git a/qemu/roms/openbios/forth/testsuite/memory-testsuite.fs b/qemu/roms/openbios/forth/testsuite/memory-testsuite.fs new file mode 100644 index 000000000..9dace5117 --- /dev/null +++ b/qemu/roms/openbios/forth/testsuite/memory-testsuite.fs @@ -0,0 +1,106 @@ +\ this is the memory management testsuite. +\ +\ run it with paflof < memory-testsuite.fs 2>/dev/null + +s" memory.fs" included + +\ dumps all free-list entries +\ useful for debugging. + +: dump-freelist ( -- ) + ." Dumping freelist:" cr + free-list @ + + \ If the free list is empty we notify the user. + dup 0= if ." empty." drop cr exit then + + begin dup 0<> while + dup ." entry 0x" . \ print pointer to entry + dup cell+ @ ." , next=0x" u. \ pointer to next entry + dup @ ." , size=0x" u. cr \ len of current entry + + cell+ @ + repeat + cr drop + ; + +\ simple testsuite. run testsuite-init to initialize +\ with some dummy memory in the dictionary. +\ run testsuite-test[1..3] for different tests. + +: testsuite-init ( -- ) + here 40000 cell+ dup allot ( -- ptr len ) + init-mem + + ." start-mem = 0x" start-mem @ . cr + ." end-mem = 0x" end-mem @ . cr + ." free-list = 0x" free-list @ . cr + + ." Memory management initialized." cr + dump-freelist + ; + +: testsuite-test1 ( -- ) + ." Test No. 1: Allocating all available memory (256k)" cr + + 40000 alloc-mem + dup 0<> if + ." worked, ptr=0x" dup . + else + ." did not work." + then + cr + + dump-freelist + ." Freeing memory." cr + ." stack=" .s cr + free-mem + dump-freelist + ; + +: testsuite-test2 ( -- ) + ." Test No. 2: Allocating 5 blocks" cr + 4000 alloc-mem + 4000 alloc-mem + 4000 alloc-mem + 4000 alloc-mem + 4000 alloc-mem + + ." Allocated 5 blocks. Stack:" cr .s cr + + dump-freelist + + ." Freeing Block 2" cr + 3 pick free-mem dump-freelist + + ." Freeing Block 4" cr + over free-mem dump-freelist + + ." Freeing Block 3" cr + 2 pick free-mem dump-freelist + + ." Cleaning up blocks 1 and 5" cr + free-mem \ Freeing block 5 + dump-freelist + 3drop \ blocks 4, 3, 2 + free-mem + + dump-freelist + ; + +: testsuite-test3 ( -- ) + ." Test No. 3: freeing illegal address 0xdeadbeef." cr + deadbeef free-mem + dump-freelist + ; + +: testsuite ( -- ) + testsuite-init + testsuite-test1 + testsuite-test2 + testsuite-test3 + ; + +testsuite + +bye diff --git a/qemu/roms/openbios/forth/testsuite/splitfunc-testsuite.fs b/qemu/roms/openbios/forth/testsuite/splitfunc-testsuite.fs new file mode 100644 index 000000000..00469bb57 --- /dev/null +++ b/qemu/roms/openbios/forth/testsuite/splitfunc-testsuite.fs @@ -0,0 +1,38 @@ +\ this is the splitfunc testsuite. +\ +\ run it with paflof < splitfunc-testsuite.fs 2>/dev/null + +\ implements split-before, split-after and left-split +\ as described in 4.3 (Path resolution) + +s" splitfunc.fs" included + +: test-split + s" var/log/messages" 2dup + + cr ." split-before test:" cr + 2dup ." String: " type cr + 2f split-before + 2swap + ." initial: " type cr ." remainder:" type cr + cr + ." split-after test:" cr + 2f split-after cr + 2swap + ." initial: " type cr ." remainder:" type cr + + ." foobar test" cr + + s" foobar" 2dup + + 2f split-after cr + 2swap + ." initial: " type cr ." remainder:" type cr + + 2f split-after cr + 2swap + ." initial: " type cr ." remainder:" type cr + ; + + + diff --git a/qemu/roms/openbios/forth/util/apic.fs b/qemu/roms/openbios/forth/util/apic.fs new file mode 100644 index 000000000..82a62aa7b --- /dev/null +++ b/qemu/roms/openbios/forth/util/apic.fs @@ -0,0 +1,62 @@ +\ +\ ioapic and local apic tester +\ +\ Copyright (C) 2003 Stefan Reinauer +\ +\ See the file "COPYING" for further information about +\ the copyright and warranty status of this work. +\ + +hex + +fee00000 constant lapic_base +fec00000 constant ioapic_base + +: read_lapic ( regoffset -- value ) + lapic_base + l@ + ; + +: write_lapic ( value regoffset -- ) + lapic_base + l! + ; + +: read_ioapic ( regoffset -- low_value high_value ) + 2* 10 + dup + ioapic_base l! ioapic_base 4 cells + l@ + swap 1+ + ioapic_base l! ioapic_base 4 cells + l@ + ; + +: write_ioapic ( low high regoffset -- ) + 2* 10 + dup ( low high offs offs ) + ioapic_base l! rot ioapic_base 4 cells + l! ( high offs ) + 1+ + ioapic_base l! ioapic_base 4 cells + l! ( high offs ) + ; + +: test-lapic + s" Dumping local apic:" type cr + 3f0 0 do + i dup ( lapic_base + ) s" 0x" type . s" = 0x" type read_lapic space . + i 30 and 0= if cr then + 10 +loop + cr + ; + +: test-ioapic + s" Dumping io apic:" type cr + 17 0 do + i dup s" irq=" type . read_ioapic s" = 0x" type . s" ." type . + i 1 and 0<> if + cr + then + loop + cr + ; + +: dump-apics + test-lapic + test-ioapic + ; + +\ tag: apic test utility diff --git a/qemu/roms/openbios/forth/util/build.xml b/qemu/roms/openbios/forth/util/build.xml new file mode 100644 index 000000000..4839d2cd3 --- /dev/null +++ b/qemu/roms/openbios/forth/util/build.xml @@ -0,0 +1,19 @@ +<build> + + <!-- + build description for OpenBIOS utility functions + + Copyright (C) 2004-2005 by Stefan Reinauer + See the file "COPYING" for further information about + the copyright and warranty status of this work. + --> + + <dictionary name="openbios" target="forth"> + <object source="util.fs"/> + <object source="pci.fs"/> + <!-- We don't want/need these at the moment + <object source="apic.fs"/> + --> + </dictionary> + +</build> diff --git a/qemu/roms/openbios/forth/util/pci.fs b/qemu/roms/openbios/forth/util/pci.fs new file mode 100644 index 000000000..57ded6265 --- /dev/null +++ b/qemu/roms/openbios/forth/util/pci.fs @@ -0,0 +1,92 @@ +\ tag: PCI helper functions +\ +\ Copyright (C) 2003-2004 Stefan Reinauer +\ Copyright (C) 2003 Samuel Rydh +\ +\ See the file "COPYING" for further information about +\ the copyright and warranty status of this work. +\ + +\ simple set of words for pci access, these are not +\ compliant to the PCI bus binding of OpenFirmware. + +\ only forth +\ vocabulary pci +\ also pci definitions + +hex + +: busdevfn ( bus dev fn -- busdevfn ) + 7 and swap + 1f and 3 << or ( dev fn -- devfn ) + swap 8 << or ( bus devfn -- busdevfn ) + ; + +: config-command ( busdevfn reg -- reg addr ) + dup -rot + 3 invert and + swap 8 << or + 80000000 or + ; + +: pci-c@ ( busdevfn reg -- x ) + config-command + cf8 iol! + 3 and cfc + + ioc@ + ; + +: pci-w@ ( busdevfn reg -- x ) + config-command + cf8 iol! + 2 and cfc + iow@ + ; + +: pci-l@ ( busdevfn reg -- x ) + config-command + cf8 iol! + drop + cfc iol@ + ; + +: pci-c! ( busdevfn reg val -- ) + -rot config-command + cf8 iol! + 3 and cfc + ioc! + ; + +: pci-w! ( busdevfn reg val -- ) + -rot config-command + cf8 iol! + 2 and cfc + iow! + ; + +: pci-l! ( busdevfn reg val -- ) + -rot config-command + cf8 iol! + drop + cfc iol! + ; + +: dump-pci-device ( bus dev fn -- ) + 2 pick (.) type 3a emit over + (.) type 2e emit dup (.) type 20 emit 5b emit \ 0:18.0 [ + busdevfn >r + r@ 0 pci-w@ u. 2f emit r@ 2 pci-w@ u. 5d emit \ 1022/1100] + r> + \ now we iterate + 10 0 do + cr i todigit emit 30 emit 3a emit 20 emit + 10 0 do + dup i j 4 << or pci-c@ + dup 4 >> todigit emit f and todigit emit + 20 emit + loop + loop + drop + cr cr + ; + +\ : test-pci +\ 0 2 0 dump-pci-device +\ ; diff --git a/qemu/roms/openbios/forth/util/util.fs b/qemu/roms/openbios/forth/util/util.fs new file mode 100644 index 000000000..6f549bf54 --- /dev/null +++ b/qemu/roms/openbios/forth/util/util.fs @@ -0,0 +1,95 @@ +\ tag: Utility functions +\ +\ Utility functions +\ +\ Copyright (C) 2003, 2004 Samuel Rydh +\ +\ See the file "COPYING" for further information about +\ the copyright and warranty status of this work. +\ + +\ ------------------------------------------------------------------------- +\ package utils +\ ------------------------------------------------------------------------- + +( method-str method-len package-str package-len -- xt|0 ) +: $find-package-method + find-package 0= if 2drop false exit then + find-method 0= if 0 then +; + +\ like $call-parent but takes an xt +: call-parent ( ... xt -- ??? ) + my-parent call-package +; + +: [active-package], + ['] (lit) , active-package , +; immediate + +\ ------------------------------------------------------------------------- +\ word creation +\ ------------------------------------------------------------------------- + +: ?mmissing ( name len -- 1 name len | 0 ) + 2dup active-package find-method + if 3drop false else true then +; + +\ install trivial open and close functions +: is-open ( -- ) + " open" ?mmissing if ['] true -rot is-xt-func then + " close" ?mmissing if 0 -rot is-xt-func then +; + +\ is-relay installs a relay function (a function that calls +\ a function with the same name but belonging to a different node). +\ The execution behaviour of xt should be ( -- ptr-to-ihandle ). +\ +: is-relay ( xt ph name-str name-len -- ) + rot >r 2dup r> find-method 0= if + \ function missing (not necessarily an error) + 3drop exit + then + + -rot is-func-begin + ( xt method-xt ) + ['] (lit) , , \ ['] method + , ['] @ , \ xt @ + ['] call-package , \ call-package + is-func-end +; + +\ ------------------------------------------------------------------------- +\ install deblocker bindings +\ ------------------------------------------------------------------------- + +: (open-deblocker) ( varaddr -- ) + " deblocker" find-package if + 0 0 rot open-package + else 0 then + swap ! +; + +: is-deblocker ( -- ) + " deblocker" find-package 0= if exit then >r + " deblocker" is-ivariable + + \ create open-deblocker + " open-deblocker" is-func-begin + dup , ['] (open-deblocker) , + is-func-end + + \ create close-deblocker + " close-deblocker" is-func-begin + dup , ['] @ , ['] close-package , + is-func-end + + ( save-ph deblk-xt R: deblocker-ph ) + r> + 2dup " read" is-relay + 2dup " seek" is-relay + 2dup " write" is-relay + 2dup " tell" is-relay + 2drop +; |