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