diff options
| author |   RajithaY <rajithax.yerrumsetty@intel.com> | 2017-04-25 03:31:15 -0700 |
|---|---|---|
| committer | Rajitha Yerrumchetty <rajithax.yerrumsetty@intel.com> | 2017-05-22 06:48:08 +0000 |
| commit | bb756eebdac6fd24e8919e2c43f7d2c8c4091f59 (patch) | |
| tree | ca11e03542edf2d8f631efeca5e1626d211107e3 /qemu/roms/openbios/forth | |
| parent | a14b48d18a9ed03ec191cf16b162206998a895ce (diff) | |
Adding qemu as a submodule of KVMFORNFV
This Patch includes the changes to add qemu as a submodule to
kvmfornfv repo and make use of the updated latest qemu for the
execution of all testcase
Change-Id: I1280af507a857675c7f81d30c95255635667bdd7
Signed-off-by:RajithaY<rajithax.yerrumsetty@intel.com>
Diffstat (limited to 'qemu/roms/openbios/forth')
79 files changed, 0 insertions, 10951 deletions
diff --git a/qemu/roms/openbios/forth/Kconfig b/qemu/roms/openbios/forth/Kconfig deleted file mode 100644 index 87ff19172..000000000 --- a/qemu/roms/openbios/forth/Kconfig +++ /dev/null @@ -1,9 +0,0 @@ -# -# -# - -#menu "Packages" -# -#source "forth/packages/Kconfig" -# -#endmenu diff --git a/qemu/roms/openbios/forth/admin/README b/qemu/roms/openbios/forth/admin/README deleted file mode 100644 index 711f7e0e8..000000000 --- a/qemu/roms/openbios/forth/admin/README +++ /dev/null @@ -1,3 +0,0 @@ -\ 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 deleted file mode 100644 index 5439fc082..000000000 --- a/qemu/roms/openbios/forth/admin/banner.fs +++ /dev/null @@ -1,49 +0,0 @@ -\ 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 deleted file mode 100644 index 665449672..000000000 --- a/qemu/roms/openbios/forth/admin/build.xml +++ /dev/null @@ -1,25 +0,0 @@ -<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 deleted file mode 100644 index e318af23b..000000000 --- a/qemu/roms/openbios/forth/admin/callback.fs +++ /dev/null @@ -1,10 +0,0 @@ -\ 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 deleted file mode 100644 index 6f9e8efbb..000000000 --- a/qemu/roms/openbios/forth/admin/devices.fs +++ /dev/null @@ -1,515 +0,0 @@ -\ 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 deleted file mode 100644 index e6e624b2a..000000000 --- a/qemu/roms/openbios/forth/admin/help.fs +++ /dev/null @@ -1,51 +0,0 @@ -\ 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 deleted file mode 100644 index b0f578f4d..000000000 --- a/qemu/roms/openbios/forth/admin/iocontrol.fs +++ /dev/null @@ -1,168 +0,0 @@ -\ 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 deleted file mode 100644 index 20f6462b9..000000000 --- a/qemu/roms/openbios/forth/admin/nvram.fs +++ /dev/null @@ -1,385 +0,0 @@ -\ 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 deleted file mode 100644 index 565692658..000000000 --- a/qemu/roms/openbios/forth/admin/reset.fs +++ /dev/null @@ -1,12 +0,0 @@ -\ 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 deleted file mode 100644 index a65adb207..000000000 --- a/qemu/roms/openbios/forth/admin/script.fs +++ /dev/null @@ -1,16 +0,0 @@ -\ 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 deleted file mode 100644 index ef2ec30be..000000000 --- a/qemu/roms/openbios/forth/admin/security.fs +++ /dev/null @@ -1,10 +0,0 @@ -\ 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 deleted file mode 100644 index 20c0c963b..000000000 --- a/qemu/roms/openbios/forth/admin/selftest.fs +++ /dev/null @@ -1,49 +0,0 @@ -\ 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 deleted file mode 100644 index 3ae899c2f..000000000 --- a/qemu/roms/openbios/forth/admin/userboot.fs +++ /dev/null @@ -1,29 +0,0 @@ -\ 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 deleted file mode 100644 index 0668cf7d8..000000000 --- a/qemu/roms/openbios/forth/bootstrap/bootstrap.fs +++ /dev/null @@ -1,1590 +0,0 @@ -\ 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 deleted file mode 100644 index d950a46df..000000000 --- a/qemu/roms/openbios/forth/bootstrap/build.xml +++ /dev/null @@ -1,16 +0,0 @@ -<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 deleted file mode 100644 index 03f5fde1f..000000000 --- a/qemu/roms/openbios/forth/bootstrap/builtin.fs +++ /dev/null @@ -1,28 +0,0 @@ -\ 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 deleted file mode 100644 index e5a46f406..000000000 --- a/qemu/roms/openbios/forth/bootstrap/hayes.fs +++ /dev/null @@ -1,1064 +0,0 @@ -\ 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 deleted file mode 100644 index 51870581f..000000000 --- a/qemu/roms/openbios/forth/bootstrap/interpreter.fs +++ /dev/null @@ -1,175 +0,0 @@ -\ 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 deleted file mode 100644 index 6fa4a2cc7..000000000 --- a/qemu/roms/openbios/forth/bootstrap/memory.fs +++ /dev/null @@ -1,216 +0,0 @@ -\ 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 deleted file mode 100644 index 9aabfa2c4..000000000 --- a/qemu/roms/openbios/forth/bootstrap/start.fs +++ /dev/null @@ -1,69 +0,0 @@ -\ 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 deleted file mode 100644 index 0d699c935..000000000 --- a/qemu/roms/openbios/forth/build.xml +++ /dev/null @@ -1,13 +0,0 @@ -<?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 deleted file mode 100644 index 3b9a0ca44..000000000 --- a/qemu/roms/openbios/forth/debugging/build.xml +++ /dev/null @@ -1,18 +0,0 @@ -<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 deleted file mode 100644 index f37440445..000000000 --- a/qemu/roms/openbios/forth/debugging/client.fs +++ /dev/null @@ -1,299 +0,0 @@ -\ 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 deleted file mode 100644 index 76099558d..000000000 --- a/qemu/roms/openbios/forth/debugging/fcode.fs +++ /dev/null @@ -1,14 +0,0 @@ -\ 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 deleted file mode 100644 index 5e16a6c57..000000000 --- a/qemu/roms/openbios/forth/debugging/firmware.fs +++ /dev/null @@ -1,90 +0,0 @@ -\ 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 deleted file mode 100644 index 6977d29eb..000000000 --- a/qemu/roms/openbios/forth/debugging/see.fs +++ /dev/null @@ -1,114 +0,0 @@ -\ 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 deleted file mode 100644 index 0d4d6e58d..000000000 --- a/qemu/roms/openbios/forth/device/README.device +++ /dev/null @@ -1,22 +0,0 @@ -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 deleted file mode 100644 index 11544964a..000000000 --- a/qemu/roms/openbios/forth/device/build.xml +++ /dev/null @@ -1,31 +0,0 @@ -<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 deleted file mode 100644 index aaefba87b..000000000 --- a/qemu/roms/openbios/forth/device/builtin.fs +++ /dev/null @@ -1,30 +0,0 @@ -\ 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 deleted file mode 100644 index 562c9196e..000000000 --- a/qemu/roms/openbios/forth/device/device.fs +++ /dev/null @@ -1,202 +0,0 @@ -\ 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 deleted file mode 100644 index fff44e00a..000000000 --- a/qemu/roms/openbios/forth/device/display.fs +++ /dev/null @@ -1,421 +0,0 @@ -\ 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 deleted file mode 100644 index 9ca6b78e3..000000000 --- a/qemu/roms/openbios/forth/device/extra.fs +++ /dev/null @@ -1,103 +0,0 @@ -\ 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 deleted file mode 100644 index 9083ed0e0..000000000 --- a/qemu/roms/openbios/forth/device/fcode.fs +++ /dev/null @@ -1,573 +0,0 @@ -\ 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 deleted file mode 100644 index 9e2773db2..000000000 --- a/qemu/roms/openbios/forth/device/feval.fs +++ /dev/null @@ -1,100 +0,0 @@ -\ 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 deleted file mode 100644 index 7b742fac4..000000000 --- a/qemu/roms/openbios/forth/device/font.fs +++ /dev/null @@ -1,17 +0,0 @@ -\ 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 deleted file mode 100644 index 4db31ef54..000000000 --- a/qemu/roms/openbios/forth/device/logo.fs +++ /dev/null @@ -1,98 +0,0 @@ -\ 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 deleted file mode 100644 index 8ea954ed7..000000000 --- a/qemu/roms/openbios/forth/device/missing +++ /dev/null @@ -1,38 +0,0 @@ -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 deleted file mode 100644 index b39007301..000000000 --- a/qemu/roms/openbios/forth/device/other.fs +++ /dev/null @@ -1,233 +0,0 @@ -\ 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 deleted file mode 100644 index d5b52c3eb..000000000 --- a/qemu/roms/openbios/forth/device/package.fs +++ /dev/null @@ -1,287 +0,0 @@ -\ 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 deleted file mode 100644 index a185b95a1..000000000 --- a/qemu/roms/openbios/forth/device/pathres.fs +++ /dev/null @@ -1,522 +0,0 @@ -\ 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 deleted file mode 100644 index 131beacd3..000000000 --- a/qemu/roms/openbios/forth/device/preof.fs +++ /dev/null @@ -1,49 +0,0 @@ -\ 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 deleted file mode 100644 index 1d54e3ec3..000000000 --- a/qemu/roms/openbios/forth/device/property.fs +++ /dev/null @@ -1,335 +0,0 @@ -\ 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 differdeleted file mode 100644 index 0b60b6fb4..000000000 --- a/qemu/roms/openbios/forth/device/romfont.bin +++ /dev/null diff --git a/qemu/roms/openbios/forth/device/structures.fs b/qemu/roms/openbios/forth/device/structures.fs deleted file mode 100644 index 14dd881e5..000000000 --- a/qemu/roms/openbios/forth/device/structures.fs +++ /dev/null @@ -1,54 +0,0 @@ -\ 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 deleted file mode 100644 index 5c58f2d9d..000000000 --- a/qemu/roms/openbios/forth/device/table.fs +++ /dev/null @@ -1,462 +0,0 @@ -\ 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 deleted file mode 100644 index 24b2d10c9..000000000 --- a/qemu/roms/openbios/forth/device/terminal.fs +++ /dev/null @@ -1,302 +0,0 @@ -\ 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 deleted file mode 100644 index 04f85b5c1..000000000 --- a/qemu/roms/openbios/forth/device/tree.fs +++ /dev/null @@ -1,59 +0,0 @@ -\ 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 deleted file mode 100644 index 239ddd028..000000000 --- a/qemu/roms/openbios/forth/lib/64bit.fs +++ /dev/null @@ -1,128 +0,0 @@ -\ -\ 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 deleted file mode 100644 index 34eee4072..000000000 --- a/qemu/roms/openbios/forth/lib/build.xml +++ /dev/null @@ -1,22 +0,0 @@ -<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 deleted file mode 100644 index c3d0db84c..000000000 --- a/qemu/roms/openbios/forth/lib/creation.fs +++ /dev/null @@ -1,52 +0,0 @@ -\ 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 deleted file mode 100644 index 91f7867b9..000000000 --- a/qemu/roms/openbios/forth/lib/lists.fs +++ /dev/null @@ -1,26 +0,0 @@ -\ 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 deleted file mode 100644 index e697383b6..000000000 --- a/qemu/roms/openbios/forth/lib/locals.fs +++ /dev/null @@ -1,197 +0,0 @@ -\ 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 deleted file mode 100644 index 6f20ea8f7..000000000 --- a/qemu/roms/openbios/forth/lib/preinclude.fs +++ /dev/null @@ -1,11 +0,0 @@ -\ -\ 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 deleted file mode 100644 index 89d478cff..000000000 --- a/qemu/roms/openbios/forth/lib/preprocessor.fs +++ /dev/null @@ -1,76 +0,0 @@ -\ 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 deleted file mode 100644 index 1a7ac3a0a..000000000 --- a/qemu/roms/openbios/forth/lib/split.fs +++ /dev/null @@ -1,49 +0,0 @@ -\ 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 deleted file mode 100644 index f97db232f..000000000 --- a/qemu/roms/openbios/forth/lib/string.fs +++ /dev/null @@ -1,141 +0,0 @@ -\ 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 ! -; - - -\ ----------------------------------------------------- -\ miscellaneous functions -\ ----------------------------------------------------- - -: rot13 ( c - c ) - dup upc [char] A [char] M between if d# 13 + exit then - dup upc [char] N [char] Z between if d# 13 - then -; - -: rot13-str ( str len -- newstr len ) - strdup 2dup bounds ?do i c@ rot13 i c! loop -; diff --git a/qemu/roms/openbios/forth/lib/vocabulary.fs b/qemu/roms/openbios/forth/lib/vocabulary.fs deleted file mode 100644 index faa75ea87..000000000 --- a/qemu/roms/openbios/forth/lib/vocabulary.fs +++ /dev/null @@ -1,153 +0,0 @@ -\ 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 deleted file mode 100644 index 16fa30657..000000000 --- a/qemu/roms/openbios/forth/packages/Kconfig +++ /dev/null @@ -1,16 +0,0 @@ - -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 deleted file mode 100644 index 009f9ec35..000000000 --- a/qemu/roms/openbios/forth/packages/README +++ /dev/null @@ -1,11 +0,0 @@ -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 deleted file mode 100644 index 16184717e..000000000 --- a/qemu/roms/openbios/forth/packages/build.xml +++ /dev/null @@ -1,19 +0,0 @@ -<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 deleted file mode 100644 index 31a37d002..000000000 --- a/qemu/roms/openbios/forth/packages/deblocker.fs +++ /dev/null @@ -1,63 +0,0 @@ -\ 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 deleted file mode 100644 index 39aa13e50..000000000 --- a/qemu/roms/openbios/forth/packages/disklabel.fs +++ /dev/null @@ -1,22 +0,0 @@ -\ 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 deleted file mode 100644 index 62f0e72e5..000000000 --- a/qemu/roms/openbios/forth/packages/obp-tftp.fs +++ /dev/null @@ -1,22 +0,0 @@ -\ 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 deleted file mode 100644 index 9f79f9e5f..000000000 --- a/qemu/roms/openbios/forth/packages/packages.fs +++ /dev/null @@ -1,17 +0,0 @@ -\ 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 deleted file mode 100644 index 0ecd348be..000000000 --- a/qemu/roms/openbios/forth/packages/terminal-emulator.fs +++ /dev/null @@ -1,23 +0,0 @@ -\ 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 deleted file mode 100644 index f15440a07..000000000 --- a/qemu/roms/openbios/forth/system/build.xml +++ /dev/null @@ -1,16 +0,0 @@ -<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 deleted file mode 100644 index 85a607627..000000000 --- a/qemu/roms/openbios/forth/system/ciface.fs +++ /dev/null @@ -1,371 +0,0 @@ - -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" - - \ Execute (exit) hook if one exists - s" (exit)" $find if - execute - else - 2drop - then - - 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 deleted file mode 100644 index 122ab1fa3..000000000 --- a/qemu/roms/openbios/forth/system/main.fs +++ /dev/null @@ -1,60 +0,0 @@ -\ 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 deleted file mode 100644 index 7aa98dea3..000000000 --- a/qemu/roms/openbios/forth/testsuite/README +++ /dev/null @@ -1,8 +0,0 @@ -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 deleted file mode 100644 index 7b7d62bcf..000000000 --- a/qemu/roms/openbios/forth/testsuite/build.xml +++ /dev/null @@ -1,16 +0,0 @@ -<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 deleted file mode 100644 index 39c984056..000000000 --- a/qemu/roms/openbios/forth/testsuite/fract.fs +++ /dev/null @@ -1,35 +0,0 @@ -\ 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 deleted file mode 100644 index 110993259..000000000 --- a/qemu/roms/openbios/forth/testsuite/framebuffer-test.fs +++ /dev/null @@ -1,10 +0,0 @@ - -: 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 deleted file mode 100644 index 9dace5117..000000000 --- a/qemu/roms/openbios/forth/testsuite/memory-testsuite.fs +++ /dev/null @@ -1,106 +0,0 @@ -\ 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 deleted file mode 100644 index 00469bb57..000000000 --- a/qemu/roms/openbios/forth/testsuite/splitfunc-testsuite.fs +++ /dev/null @@ -1,38 +0,0 @@ -\ 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 deleted file mode 100644 index 82a62aa7b..000000000 --- a/qemu/roms/openbios/forth/util/apic.fs +++ /dev/null @@ -1,62 +0,0 @@ -\ -\ 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 deleted file mode 100644 index 4839d2cd3..000000000 --- a/qemu/roms/openbios/forth/util/build.xml +++ /dev/null @@ -1,19 +0,0 @@ -<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 deleted file mode 100644 index 57ded6265..000000000 --- a/qemu/roms/openbios/forth/util/pci.fs +++ /dev/null @@ -1,92 +0,0 @@ -\ 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 deleted file mode 100644 index 6f549bf54..000000000 --- a/qemu/roms/openbios/forth/util/util.fs +++ /dev/null @@ -1,95 +0,0 @@ -\ 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 -; |