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