summaryrefslogtreecommitdiffstats
path: root/qemu/roms/openbios/forth/device
diff options
context:
space:
mode:
Diffstat (limited to 'qemu/roms/openbios/forth/device')
-rw-r--r--qemu/roms/openbios/forth/device/README.device22
-rw-r--r--qemu/roms/openbios/forth/device/build.xml31
-rw-r--r--qemu/roms/openbios/forth/device/builtin.fs30
-rw-r--r--qemu/roms/openbios/forth/device/device.fs202
-rw-r--r--qemu/roms/openbios/forth/device/display.fs421
-rw-r--r--qemu/roms/openbios/forth/device/extra.fs103
-rw-r--r--qemu/roms/openbios/forth/device/fcode.fs573
-rw-r--r--qemu/roms/openbios/forth/device/feval.fs100
-rw-r--r--qemu/roms/openbios/forth/device/font.fs17
-rw-r--r--qemu/roms/openbios/forth/device/logo.fs98
-rw-r--r--qemu/roms/openbios/forth/device/missing38
-rw-r--r--qemu/roms/openbios/forth/device/other.fs233
-rw-r--r--qemu/roms/openbios/forth/device/package.fs287
-rw-r--r--qemu/roms/openbios/forth/device/pathres.fs522
-rw-r--r--qemu/roms/openbios/forth/device/preof.fs49
-rw-r--r--qemu/roms/openbios/forth/device/property.fs335
-rw-r--r--qemu/roms/openbios/forth/device/romfont.binbin0 -> 4096 bytes
-rw-r--r--qemu/roms/openbios/forth/device/structures.fs54
-rw-r--r--qemu/roms/openbios/forth/device/table.fs462
-rw-r--r--qemu/roms/openbios/forth/device/terminal.fs302
-rw-r--r--qemu/roms/openbios/forth/device/tree.fs59
21 files changed, 3938 insertions, 0 deletions
diff --git a/qemu/roms/openbios/forth/device/README.device b/qemu/roms/openbios/forth/device/README.device
new file mode 100644
index 000000000..0d4d6e58d
--- /dev/null
+++ b/qemu/roms/openbios/forth/device/README.device
@@ -0,0 +1,22 @@
+The code you find here implements the IEEE 1275-1994 Open Firmware
+device interface.
+
+Chapter File Comment
+<none> structures.fs generic structures used by 5.3
+5.3.2 <none> defined in user interface
+5.3.3 fcode.fs complete, partly untested
+5.3.4 package.fs incomplete
+5.3.5 property.fs incomplete
+5.3.6 display.fs incomplete
+5.3.7 other.fs incomplete
+
+H2 and
+5.3.1.1.1 preof.fs pre-IEEE-1275-1994 words
+ split.fs
+ pathres.fs path resolution
+
+ table.fs fcode evaluator
+ feval.fs (byte-load)
+
+
+2003/11/12 Stefan Reinauer <stepan@openbios.org>
diff --git a/qemu/roms/openbios/forth/device/build.xml b/qemu/roms/openbios/forth/device/build.xml
new file mode 100644
index 000000000..11544964a
--- /dev/null
+++ b/qemu/roms/openbios/forth/device/build.xml
@@ -0,0 +1,31 @@
+<build>
+
+ <!--
+ build description for open firmware device interface
+
+ Copyright (C) 2004-2005 by Stefan Reinauer
+ See the file "COPYING" for further information about
+ the copyright and warranty status of this work.
+ -->
+
+ <dictionary name="openbios" target="forth">
+ <object source="structures.fs"/>
+ <object source="fcode.fs"/>
+ <object source="property.fs"/>
+ <object source="device.fs"/>
+ <object source="package.fs"/>
+ <object source="other.fs"/>
+ <object source="pathres.fs"/>
+ <object source="preof.fs"/>
+ <object source="font.fs"/>
+ <object source="logo.fs"/>
+ <object source="display.fs"/>
+ <object source="terminal.fs"/>
+ <object source="extra.fs"/>
+ <object source="feval.fs"/>
+ <object source="table.fs"/>
+ <object source="tree.fs"/>
+ <object source="builtin.fs"/>
+ </dictionary>
+
+</build>
diff --git a/qemu/roms/openbios/forth/device/builtin.fs b/qemu/roms/openbios/forth/device/builtin.fs
new file mode 100644
index 000000000..aaefba87b
--- /dev/null
+++ b/qemu/roms/openbios/forth/device/builtin.fs
@@ -0,0 +1,30 @@
+\ tag: builtin devices
+\
+\ this code implements IEEE 1275-1994
+\
+\ Copyright (C) 2003 Stefan Reinauer
+\
+\ See the file "COPYING" for further information about
+\ the copyright and warranty status of this work.
+\
+
+\ nodes it's children:
+
+" /" find-device
+
+new-device
+ " builtin" device-name
+ : open true ;
+ : close ;
+
+new-device
+ " console" device-name
+ : open true ;
+ : close ;
+ : write dup >r bounds ?do i c@ (emit) loop r> ;
+ : read dup >r bounds ?do (key) i c! loop r> ;
+finish-device
+
+\ clean up afterwards
+finish-device
+0 active-package!
diff --git a/qemu/roms/openbios/forth/device/device.fs b/qemu/roms/openbios/forth/device/device.fs
new file mode 100644
index 000000000..562c9196e
--- /dev/null
+++ b/qemu/roms/openbios/forth/device/device.fs
@@ -0,0 +1,202 @@
+\ tag: Package creation and deletion
+\
+\ this code implements IEEE 1275-1994
+\
+\ Copyright (C) 2003, 2004 Samuel Rydh
+\
+\ See the file "COPYING" for further information about
+\ the copyright and warranty status of this work.
+\
+
+variable device-tree
+
+\ make defined words globally visible
+\
+: external ( -- )
+ active-package ?dup if
+ >dn.methods @ set-current
+ then
+;
+
+\ make the private wordlist active (not an OF word)
+\
+: private ( -- )
+ active-package ?dup if
+ >r
+ forth-wordlist r@ >dn.methods @ r@ >dn.priv-methods @ 3 set-order
+ r> >dn.priv-methods @ set-current
+ then
+;
+
+\ set activate package and make the world visible package wordlist
+\ the current one.
+\
+: active-package! ( phandle -- )
+ dup to active-package
+ \ locally defined words are not available
+ ?dup if
+ forth-wordlist over >dn.methods @ 2 set-order
+ >dn.methods @ set-current
+ else
+ forth-wordlist dup 1 set-order set-current
+ then
+;
+
+
+\ new-device ( -- )
+\
+\ Start new package, as child of active package.
+\ Create a new device node as a child of the active package and make the
+\ new node the active package. Create a new instance and make it the current
+\ instance; the instance that invoked new-device becomes the parent instance
+\ of the new instance.
+\ Subsequently, newly defined Forth words become the methods of the new node
+\ and newly defined data items (such as types variable, value, buffer:, and
+\ defer) are allocated and stored within the new instance.
+
+: new-device ( -- )
+ align-tree dev-node.size alloc-tree >r
+ active-package
+ dup r@ >dn.parent !
+
+ \ ( parent ) hook up at the end of the peer list
+ ?dup if
+ >dn.child
+ begin dup @ while @ >dn.peer repeat
+ r@ swap !
+ else
+ \ we are the root node!
+ r@ to device-tree
+ then
+
+ \ ( -- ) fill in device node stuff
+ inst-node.size r@ >dn.isize !
+
+ \ create two wordlists
+ wordlist r@ >dn.methods !
+ wordlist r@ >dn.priv-methods !
+
+ \ initialize template data
+ r@ >dn.itemplate
+ r@ over >in.device-node !
+ my-self over >in.my-parent !
+
+ \ make it the active package and current instance
+ to my-self
+ r@ active-package!
+
+ \ swtich to public wordlist
+ external
+ r> drop
+;
+
+\ helpers for finish-device (OF does not actually define words
+\ for device node deletion)
+
+: (delete-device) \ ( phandle )
+ >r
+ r@ >dn.parent @
+ ?dup if
+ >dn.child \ ( &first-child )
+ begin dup @ r@ <> while @ >dn.peer repeat
+ r@ >dn.peer @ swap !
+ else
+ \ root node
+ 0 to device-tree
+ then
+
+ \ XXX: free any memory related to this node.
+ \ we could have a list with free device-node headers...
+ r> drop
+;
+
+: delete-device \ ( phandle )
+ >r
+ \ first, get rid of any children
+ begin r@ >dn.child @ dup while
+ (delete-device)
+ repeat
+ drop
+
+ \ then free this node
+ r> (delete-device)
+;
+
+\ finish-device ( -- )
+\
+\ Finish this package, set active package to parent.
+\ Complete a device node that was created by new-device, as follows: If the
+\ device node has no "name" property, remove the device node from the device
+\ tree. Otherwise, save the current values of the current instance's
+\ initialized data items within the active package for later use in
+\ initializing the data items of instances created from that node. In any
+\ case, destroy the current instance, make its parent instance the current
+\ instance, and select the parent node of the device node just completed,
+\ making the parent node the active package again.
+
+: finish-device \ ( -- )
+ my-self
+ dup >in.device-node @ >r
+ >in.my-parent @ to my-self
+
+ ( -- )
+ r@ >dn.parent @ active-package!
+ s" name" r@ get-package-property if
+ \ delete the node (and any children)
+ r@ delete-device
+ else
+ 2drop
+ \ node OK
+ then
+ r> drop
+;
+
+
+\ helper function which creates and initializes an instance.
+\ open is not called. The current instance is not changed.
+\
+: create-instance ( phandle -- ihandle|0 )
+ dup >dn.isize @ ['] alloc-mem catch if 2drop 0 exit then
+ >r
+ \ we need to save the size in order to be able to release it properly
+ dup >dn.isize @ r@ >in.alloced-size !
+
+ \ clear memory (we only need to clear the head; all other data is copied)
+ r@ inst-node.size 0 fill
+
+ ( phandle R: ihandle )
+
+ \ instantiate data
+ dup >dn.methods @ r@ instance-init
+ dup >dn.priv-methods @ r@ instance-init
+
+ \ instantiate
+ dup >dn.itemplate r@ inst-node.size move
+ r@ r@ >in.instance-data !
+ my-self r@ >in.my-parent !
+ drop
+
+ r>
+;
+
+\ helper function which tears down and frees an instance
+: destroy-instance ( ihandle )
+ ?dup if
+ \ free arguments
+ dup >in.arguments 2@ free-mem
+ \ and the instance block
+ dup >in.alloced-size @
+ free-mem
+ then
+;
+
+\ Redefine to word so that statements of the form "0 to active-package"
+\ are supported for bootloaders that require it
+: to
+ ['] ' execute
+ dup ['] active-package = if
+ drop active-package!
+ else
+ (to-xt)
+ then
+; immediate
diff --git a/qemu/roms/openbios/forth/device/display.fs b/qemu/roms/openbios/forth/device/display.fs
new file mode 100644
index 000000000..fff44e00a
--- /dev/null
+++ b/qemu/roms/openbios/forth/device/display.fs
@@ -0,0 +1,421 @@
+\ tag: Display device management
+\
+\ this code implements IEEE 1275-1994 ch. 5.3.6
+\
+\ Copyright (C) 2003 Stefan Reinauer
+\
+\ See the file "COPYING" for further information about
+\ the copyright and warranty status of this work.
+\
+
+hex
+
+\
+\ 5.3.6.1 Terminal emulator routines
+\
+
+\ The following values are used and set by the terminal emulator
+\ defined and described in 3.8.4.2
+0 value line# ( -- line# )
+0 value column# ( -- column# )
+0 value inverse? ( -- white-on-black? )
+0 value inverse-screen? ( -- black? )
+0 value #lines ( -- rows )
+0 value #columns ( -- columns )
+
+\ The following values are used internally by both the 1-bit and the
+\ 8-bit frame-buffer support routines.
+
+0 value frame-buffer-adr ( -- addr )
+0 value screen-height ( -- height )
+0 value screen-width ( -- width )
+0 value window-top ( -- border-height )
+0 value window-left ( -- border-width )
+0 value char-height ( -- height )
+0 value char-width ( -- width )
+0 value fontbytes ( -- bytes )
+
+\ these values are used internally and do not represent any
+\ official open firmware words
+0 value char-min
+0 value char-num
+0 value font
+
+0 value foreground-color
+0 value background-color
+create color-palette 100 cells allot
+
+2 value font-spacing
+0 value depth-bits
+0 value line-bytes
+0 value display-ih
+
+\ internal values
+0 value openbios-video-height
+0 value openbios-video-width
+
+\ The following wordset is called the "defer word interface" of the
+\ terminal-emulator support package. It gets overloaded by fb1-install
+\ or fb8-install (initiated by the framebuffer fcode driver)
+
+defer draw-character ( char -- )
+defer reset-screen ( -- )
+defer toggle-cursor ( -- )
+defer erase-screen ( -- )
+defer blink-screen ( -- )
+defer invert-screen ( -- )
+defer insert-characters ( n -- )
+defer delete-characters ( n -- )
+defer insert-lines ( n -- )
+defer delete-lines ( n -- )
+defer draw-logo ( line# addr width height -- )
+
+defer fb-emit ( x -- )
+
+: depth-bytes ( -- bytes )
+ depth-bits 1+ 8 /
+;
+
+\
+\ 5.3.6.2 Frame-buffer support routines
+\
+
+: default-font ( -- addr width height advance min-char #glyphs )
+ (romfont) (romfont-width) (romfont-height) (romfont-height) 0 100
+ ;
+
+: set-font ( addr width height advance min-char #glyphs -- )
+ to char-num
+ to char-min
+ to fontbytes
+ font-spacing + to char-height
+ to char-width
+ to font
+ ;
+
+: >font ( char -- addr )
+ char-min -
+ char-num min
+ fontbytes *
+ font +
+ ;
+
+\
+\ 5.3.6.3 Display device support
+\
+
+\
+\ 5.3.6.3.1 Frame-buffer package interface
+\
+
+: is-install ( xt -- )
+ external
+ \ Create open and other methods for this display device.
+ \ Methods to be created: open, write, draw-logo, restore
+ s" open" header
+ 1 , \ colon definition
+ ,
+ ['] (lit) ,
+ -1 ,
+ ['] (semis) ,
+ reveal
+ s" : write dup >r bounds do i c@ fb-emit loop r> ; " evaluate
+ s" : draw-logo draw-logo ; " evaluate
+ s" : restore reset-screen ; " evaluate
+ ;
+
+: is-remove ( xt -- )
+ external
+ \ Create close method for this display device.
+ s" close" header
+ 1 , \ colon definition
+ ,
+ ['] (semis) ,
+ reveal
+ ;
+
+: is-selftest ( xt -- )
+ external
+ \ Create selftest method for this display device.
+ s" selftest" header
+ 1 , \ colon definition
+ ,
+ ['] (semis) ,
+ reveal
+ ;
+
+
+\ 5.3.6.3.2 Generic one-bit frame-buffer support (optional)
+
+: fb1-nonimplemented
+ ." Monochrome framebuffer support is not implemented." cr
+ end0
+ ;
+
+: fb1-draw-character fb1-nonimplemented ; \ historical
+: fb1-reset-screen fb1-nonimplemented ;
+: fb1-toggle-cursor fb1-nonimplemented ;
+: fb1-erase-screen fb1-nonimplemented ;
+: fb1-blink-screen fb1-nonimplemented ;
+: fb1-invert-screen fb1-nonimplemented ;
+: fb1-insert-characters fb1-nonimplemented ;
+: fb1-delete-characters fb1-nonimplemented ;
+: fb1-insert-lines fb1-nonimplemented ;
+: fb1-delete-lines fb1-nonimplemented ;
+: fb1-slide-up fb1-nonimplemented ;
+: fb1-draw-logo fb1-nonimplemented ;
+: fb1-install fb1-nonimplemented ;
+
+
+\ 5.3.6.3.3 Generic eight-bit frame-buffer support
+
+\ bind to low-level C function later
+defer fb8-blitmask
+defer fb8-fillrect
+defer fb8-invertrect
+
+: fb8-line2addr ( line -- addr )
+ window-top +
+ screen-width * depth-bytes *
+ frame-buffer-adr +
+ window-left depth-bytes * +
+;
+
+: fb8-curpos2addr ( col line -- addr )
+ char-height * fb8-line2addr
+ swap char-width * depth-bytes * +
+;
+
+: fb8-copy-lines ( count from to -- )
+ fb8-line2addr swap
+ fb8-line2addr swap
+ #columns char-width * depth-bytes *
+ 3 pick * move drop
+;
+
+: fb8-clear-lines ( count line -- )
+ background-color 0
+ 2 pick window-top +
+ #columns char-width *
+ 5 pick
+ fb8-fillrect
+ 2drop
+;
+
+: fb8-draw-character ( char -- )
+ \ erase the current character
+ background-color
+ column# char-width * window-left +
+ line# char-height * window-top +
+ char-width char-height fb8-fillrect
+ \ draw the character:
+ >font
+ line# char-height * window-top + screen-width * depth-bytes *
+ column# char-width * depth-bytes *
+ window-left depth-bytes * + + frame-buffer-adr +
+ swap char-width char-height font-spacing -
+ \ normal or inverse?
+ foreground-color background-color
+ inverse? if
+ swap
+ then
+ fb8-blitmask
+ ;
+
+: fb8-reset-screen ( -- )
+ false to inverse?
+ false to inverse-screen?
+ 0 to foreground-color
+ d# 15 to background-color
+
+ \ override with OpenBIOS defaults
+ fe to background-color
+ 0 to foreground-color
+ ;
+
+: fb8-toggle-cursor ( -- )
+ column# char-width * window-left +
+ line# char-height * window-top +
+ char-width char-height font-spacing -
+ foreground-color background-color
+ fb8-invertrect
+ ;
+
+: fb8-erase-screen ( -- )
+ inverse-screen? if
+ foreground-color
+ else
+ background-color
+ then
+ 0 0 screen-width screen-height
+ fb8-fillrect
+ ;
+
+: fb8-invert-screen ( -- )
+ 0 0 screen-width screen-height
+ background-color foreground-color
+ fb8-invertrect
+ ;
+
+: fb8-blink-screen ( -- )
+ fb8-invert-screen 2000 ms
+ fb8-invert-screen
+ ;
+
+: fb8-insert-characters ( n -- )
+ \ numcopy = ( #columns - column# - n )
+ #columns over - column# -
+ char-width * depth-bytes * ( n numbytescopy )
+
+ over column# + line# fb8-curpos2addr
+ column# line# fb8-curpos2addr ( n numbytescopy destaddr srcaddr )
+ char-height 0 do
+ 3dup swap rot move
+ line-bytes + swap line-bytes + swap
+ loop 3drop
+
+ background-color
+ column# char-width * window-left + line# char-height * window-top +
+ 3 pick char-width * char-height
+ fb8-fillrect
+ drop
+ ;
+
+: fb8-delete-characters ( n -- )
+ \ numcopy = ( #columns - column# - n )
+ #columns over - column# -
+ char-width * depth-bytes * ( n numbytescopy )
+
+ over column# + line# fb8-curpos2addr
+ column# line# fb8-curpos2addr swap ( n numbytescopy destaddr srcaddr )
+ char-height 0 do
+ 3dup swap rot move
+ line-bytes + swap line-bytes + swap
+ loop 3drop
+
+ background-color
+ over #columns swap - char-width * window-left + line# char-height * window-top +
+ 3 pick char-width * char-height
+ fb8-fillrect
+ drop
+ ;
+
+: fb8-insert-lines ( n -- )
+ \ numcopy = ( #lines - n )
+ #lines over - char-height *
+ over line# char-height *
+ swap char-height * over +
+ fb8-copy-lines
+
+ char-height * line# char-height *
+ fb8-clear-lines
+ ;
+
+: fb8-delete-lines ( n -- )
+ \ numcopy = ( #lines - ( line# + n )) * char-height
+ #lines over line# + - char-height *
+ over line# + char-height *
+ line# char-height *
+ fb8-copy-lines
+
+ #lines over - char-height *
+ dup #lines char-height * swap - swap
+ fb8-clear-lines
+ drop
+;
+
+
+: fb8-draw-logo ( line# addr width height -- )
+ 2swap swap
+ char-height * window-top +
+ screen-width * window-left +
+ frame-buffer-adr +
+ swap 2swap
+ \ in-fb-start-adr logo-adr logo-width logo-height
+
+ fb8-blitmask ( fbaddr mask-addr width height -- )
+;
+
+
+: fb8-install ( width height #columns #lines -- )
+
+ \ set state variables
+ to #lines
+ to #columns
+ to screen-height
+ to screen-width
+
+ screen-width #columns char-width * - 2/ to window-left
+ screen-height #lines char-height * - 2/ to window-top
+
+ 0 to column#
+ 0 to line#
+ 0 to inverse?
+ 0 to inverse-screen?
+
+ my-self to display-ih
+
+ \ set /chosen display property
+ my-self active-package 0 to my-self
+ " /chosen" (find-dev) 0<> if
+ active-package!
+ display-ih encode-int " display" property
+ then
+ active-package! to my-self
+
+ \ set defer functions to 8bit versions
+
+ ['] fb8-draw-character to draw-character
+ ['] fb8-toggle-cursor to toggle-cursor
+ ['] fb8-erase-screen to erase-screen
+ ['] fb8-blink-screen to blink-screen
+ ['] fb8-invert-screen to invert-screen
+ ['] fb8-insert-characters to insert-characters
+ ['] fb8-delete-characters to delete-characters
+ ['] fb8-insert-lines to insert-lines
+ ['] fb8-delete-lines to delete-lines
+ ['] fb8-draw-logo to draw-logo
+ ['] fb8-reset-screen to reset-screen
+
+ \ recommended practice
+ s" iso6429-1983-colors" get-my-property if
+ 0 ff
+ else
+ 2drop d# 15 0
+ then
+ to foreground-color to background-color
+
+ \ setup palette
+ 10101 ['] color-palette cell+ ff 0 do
+ dup 2 pick i * swap ! cell+
+ loop 2drop
+
+ \ special background color
+ ffffcc ['] color-palette cell+ fe cells + !
+
+ \ load palette onto the hardware
+ ['] color-palette cell+ ff 0 do
+ dup @ ff0000 and d# 16 rshift
+ 1 pick @ ff00 and d# 8 rshift
+ 2 pick @ ff and
+ i
+ s" color!" $find if
+ execute
+ else
+ 2drop
+ then
+ cell+
+ loop drop
+
+ \ ... but let's override with some better defaults
+ fe to background-color
+ 0 to foreground-color
+
+ fb8-erase-screen
+
+ \ If we have a startup splash then display it
+ [IFDEF] CONFIG_MOL
+ mol-startup-splash 2000 ms
+ fb8-erase-screen
+ [THEN]
+;
diff --git a/qemu/roms/openbios/forth/device/extra.fs b/qemu/roms/openbios/forth/device/extra.fs
new file mode 100644
index 000000000..9ca6b78e3
--- /dev/null
+++ b/qemu/roms/openbios/forth/device/extra.fs
@@ -0,0 +1,103 @@
+\ tag: Useful device related functions
+\
+\ Copyright (C) 2003, 2004 Samuel Rydh
+\
+\ See the file "COPYING" for further information about
+\ the copyright and warranty status of this work.
+\
+
+
+: parent ( phandle -- parent.phandle|0 )
+ >dn.parent @
+;
+
+\ -------------------------------------------------------------------
+\ property helpers
+\ -------------------------------------------------------------------
+
+: int-property ( value name-str name-len -- )
+ rot encode-int 2swap property
+;
+
+\ -------------------------------------------------------------------------
+\ property utils
+\ -------------------------------------------------------------------------
+
+\ like property (except it takes a phandle as an argument)
+: encode-property ( buf len propname propname-len phandle -- )
+ dup 0= abort" null phandle"
+
+ my-self >r 0 to my-self
+ active-package >r active-package!
+
+ property
+
+ r> active-package!
+ r> to my-self
+;
+
+\ -------------------------------------------------------------------
+\ device tree iteration
+\ -------------------------------------------------------------------
+
+: iterate-tree ( phandle -- phandle|0 )
+ ?dup 0= if device-tree @ exit then
+
+ \ children first
+ dup child if
+ child exit
+ then
+
+ \ then peers
+ dup peer if
+ peer exit
+ then
+
+ \ then peer of a parent
+ begin >dn.parent @ dup while
+ dup peer if peer exit then
+ repeat
+;
+
+: iterate-tree-begin ( -- first_node )
+ device-tree @
+;
+
+
+\ -------------------------------------------------------------------
+\ device tree iteration
+\ -------------------------------------------------------------------
+
+: iterate-device-type ( lastph|0 type-str type-len -- 0|nextph )
+ rot
+ begin iterate-tree ?dup while
+ >r
+ 2dup " device_type" r@ get-package-property if 0 0 then
+ dup 0> if 1- then
+ strcmp 0= if 2drop r> exit then
+ r>
+ repeat
+ 2drop 0
+;
+
+\ -------------------------------------------------------------------
+\ device tree "cut and paste"
+\ -------------------------------------------------------------------
+
+\ add a subtree to the current device node
+: link-nodes ( phandle -- )
+ \ reparent phandle and peers
+ dup begin ?dup while
+ dup >dn.parent active-package !
+ >dn.peer @
+ repeat
+
+ \ add to list of children
+ active-package >dn.child
+ begin dup @ while @ >dn.peer repeat dup . !
+;
+
+: link-node ( phandle -- )
+ 0 over >dn.peer !
+ link-nodes
+;
diff --git a/qemu/roms/openbios/forth/device/fcode.fs b/qemu/roms/openbios/forth/device/fcode.fs
new file mode 100644
index 000000000..9083ed0e0
--- /dev/null
+++ b/qemu/roms/openbios/forth/device/fcode.fs
@@ -0,0 +1,573 @@
+\ tag: FCode implementation functions
+\
+\ this code implements IEEE 1275-1994 ch. 5.3.3
+\
+\ Copyright (C) 2003 Stefan Reinauer
+\
+\ See the file "COPYING" for further information about
+\ the copyright and warranty status of this work.
+\
+
+hex
+
+0 value fcode-sys-table \ table with built-in fcodes (0-0x7ff)
+
+true value ?fcode-offset16 \ fcode offsets are 16 instead of 8 bit?
+1 value fcode-spread \ fcode spread (1, 2 or 4)
+0 value fcode-table \ pointer to fcode table
+false value ?fcode-verbose \ do verbose fcode execution?
+
+defer _fcode-debug? \ If true, save names for FCodes with headers
+true value fcode-headers? \ If true, possibly save names for FCodes.
+
+0 value fcode-stream-start \ start address of fcode stream
+0 value fcode-stream \ current fcode stream address
+
+variable fcode-end \ state variable, if true, fcode program terminates.
+defer fcode-c@ \ get byte
+
+: fcode-push-state ( -- <state information> )
+ ?fcode-offset16
+ fcode-spread
+ fcode-table
+ fcode-headers?
+ fcode-stream-start
+ fcode-stream
+ fcode-end @
+ ['] fcode-c@ behavior
+;
+
+: fcode-pop-state ( <state information> -- )
+ to fcode-c@
+ fcode-end !
+ to fcode-stream
+ to fcode-stream-start
+ to fcode-headers?
+ to fcode-table
+ to fcode-spread
+ to ?fcode-offset16
+;
+
+\
+\ fcode access helper functions
+\
+
+\ fcode-ptr
+\ convert FCode number to pointer to xt in FCode table.
+
+: fcode-ptr ( u16 -- *xt )
+ cells
+ fcode-table ?dup if + exit then
+
+ \ we are not parsing fcode at the moment
+ dup 800 cells u>= abort" User FCODE# referenced."
+ fcode-sys-table +
+;
+
+\ fcode>xt
+\ get xt according to an FCode#
+
+: fcode>xt ( u16 -- xt )
+ fcode-ptr @
+ ;
+
+\ fcode-num8
+\ get 8bit from FCode stream, taking spread into regard.
+
+: fcode-num8 ( -- c ) ( F: c -- )
+ fcode-stream
+ dup fcode-spread + to fcode-stream
+ fcode-c@
+ ;
+
+\ fcode-num8-signed ( -- c ) ( F: c -- )
+\ get 8bit signed from FCode stream
+
+: fcode-num8-signed
+ fcode-num8
+ dup 80 and 0> if
+ ff invert or
+ then
+ ;
+
+\ fcode-num16
+\ get 16bit from FCode stream
+
+: fcode-num16 ( -- num16 )
+ fcode-num8 fcode-num8 swap bwjoin
+ ;
+
+\ fcode-num16-signed ( -- c ) ( F: c -- )
+\ get 16bit signed from FCode stream
+
+: fcode-num16-signed
+ fcode-num16
+ dup 8000 and 0> if
+ ffff invert or
+ then
+ ;
+
+\ fcode-num32
+\ get 32bit from FCode stream
+
+: fcode-num32 ( -- num32 )
+ fcode-num8 fcode-num8
+ fcode-num8 fcode-num8
+ swap 2swap swap bljoin
+ ;
+
+\ fcode#
+\ Get an FCode# from FCode stream
+
+: fcode# ( -- fcode# )
+ fcode-num8
+ dup 1 f between if
+ fcode-num8 swap bwjoin
+ then
+ ;
+
+\ fcode-offset
+\ get offset from FCode stream.
+
+: fcode-offset ( -- offset )
+ ?fcode-offset16 if
+ fcode-num16-signed
+ else
+ fcode-num8-signed
+ then
+
+ \ Display offset in verbose mode
+ ?fcode-verbose if
+ dup ." (offset) " . cr
+ then
+ ;
+
+\ fcode-string
+\ get a string from FCode stream, store in pocket.
+
+: fcode-string ( -- addr len )
+ pocket dup
+ fcode-num8
+ dup rot c!
+ 2dup bounds ?do
+ fcode-num8 i c!
+ loop
+
+ \ Display string in verbose mode
+ ?fcode-verbose if
+ 2dup ." (const) " type cr
+ then
+ ;
+
+\ fcode-header
+\ retrieve FCode header from FCode stream
+
+: fcode-header
+ fcode-num8
+ fcode-num16
+ fcode-num32
+ ?fcode-verbose if
+ ." Found FCode header:" cr rot
+ ." Format : " u. cr swap
+ ." Checksum : " u. cr
+ ." Length : " u. cr
+ else
+ 3drop
+ then
+ \ TODO checksum
+ ;
+
+\ writes currently created word as fcode# read from stream
+\
+
+: fcode! ( F:FCode# -- )
+ here fcode#
+
+ \ Display fcode# in verbose mode
+ ?fcode-verbose if
+ dup ." (fcode#) " . cr
+ then
+ fcode-ptr !
+ ;
+
+
+\
+\ 5.3.3.1 Defining new FCode functions.
+\
+
+\ instance ( -- )
+\ Mark next defining word as instance specific.
+\ (defined in bootstrap.fs)
+
+\ instance-init ( wid buffer -- )
+\ Copy template from specified wordlist to instance
+\
+
+: instance-init
+ swap
+ begin @ dup 0<> while
+ dup /n + @ instance-cfa? if \ buffer dict
+ 2dup 2 /n* + @ + \ buffer dict dest
+ over 3 /n* + @ \ buffer dict dest size
+ 2 pick 4 /n* + \ buffer dict dest size src
+ -rot
+ move
+ then
+ repeat
+ 2drop
+ ;
+
+
+\ new-token ( F:/FCode#/ -- )
+\ Create a new unnamed FCode function
+
+: new-token
+ 0 0 header
+ fcode!
+ ;
+
+
+\ named-token (F:FCode-string FCode#/ -- )
+\ Create a new possibly named FCode function.
+
+: named-token
+ fcode-string
+ _fcode-debug? not if
+ 2drop 0 0
+ then
+ header
+ fcode!
+ ;
+
+
+\ external-token (F:/FCode-string FCode#/ -- )
+\ Create a new named FCode function
+
+: external-token
+ fcode-string header
+ fcode!
+ ;
+
+
+\ b(;) ( -- )
+\ End an FCode colon definition.
+
+: b(;)
+ ['] ; execute
+ ; immediate
+
+
+\ b(:) ( -- ) ( E: ... -- ??? )
+\ Defines type of new FCode function as colon definition.
+
+: b(:)
+ 1 , ]
+ ;
+
+
+\ b(buffer:) ( size -- ) ( E: -- a-addr )
+\ Defines type of new FCode function as buffer:.
+
+: b(buffer:)
+ 4 , allot
+ reveal
+ ;
+
+\ b(constant) ( nl -- ) ( E: -- nl )
+\ Defines type of new FCode function as constant.
+
+: b(constant)
+ 3 , ,
+ reveal
+ ;
+
+
+\ b(create) ( -- ) ( E: -- a-addr )
+\ Defines type of new FCode function as create word.
+
+: b(create)
+ 6 ,
+ ['] noop ,
+ reveal
+ ;
+
+
+\ b(defer) ( -- ) ( E: ... -- ??? )
+\ Defines type of new FCode function as defer word.
+
+: b(defer)
+ 5 ,
+ ['] (undefined-defer) ,
+ ['] (semis) ,
+ reveal
+ ;
+
+
+\ b(field) ( offset size -- offset+size ) ( E: addr -- addr+offset )
+\ Defines type of new FCode function as field.
+
+: b(field)
+ 6 ,
+ ['] noop ,
+ reveal
+ over ,
+ +
+ does>
+ @ +
+ ;
+
+
+\ b(value) ( x -- ) (E: -- x )
+\ Defines type of new FCode function as value.
+
+: b(value)
+ 3 , , reveal
+ ;
+
+
+\ b(variable) ( -- ) ( E: -- a-addr )
+\ Defines type of new FCode function as variable.
+
+: b(variable)
+ 4 , 0 ,
+ reveal
+ ;
+
+
+\ (is-user-word) ( name-str name-len xt -- ) ( E: ... -- ??? )
+\ Create a new named user interface command.
+
+: (is-user-word)
+ ;
+
+
+\ get-token ( fcode# -- xt immediate? )
+\ Convert FCode number to function execution token.
+
+: get-token
+ fcode>xt dup immediate?
+ ;
+
+
+\ set-token ( xt immediate? fcode# -- )
+\ Assign FCode number to existing function.
+
+: set-token
+ nip \ TODO we use the xt's immediate state for now.
+ fcode-ptr !
+ ;
+
+
+
+
+\
+\ 5.3.3.2 Literals
+\
+
+
+\ b(lit) ( -- n1 )
+\ Numeric literal FCode. Followed by FCode-num32.
+
+64bit? [IF]
+: b(lit)
+ fcode-num32 32>64
+ state @ if
+ ['] (lit) , ,
+ then
+ ; immediate
+[ELSE]
+: b(lit)
+ fcode-num32
+ state @ if
+ ['] (lit) , ,
+ then
+ ; immediate
+[THEN]
+
+
+\ b(') ( -- xt )
+\ Function literal FCode. Followed by FCode#
+
+: b(')
+ fcode# fcode>xt
+ state @ if
+ ['] (lit) , ,
+ then
+ ; immediate
+
+
+\ b(") ( -- str len )
+\ String literal FCode. Followed by FCode-string.
+
+: b(")
+ fcode-string
+ state @ if
+ \ only run handle-text in compile-mode,
+ \ otherwise we would waste a pocket.
+ handle-text
+ then
+ ; immediate
+
+
+\
+\ 5.3.3.3 Controlling values and defers
+\
+
+\ behavior ( defer-xt -- contents-xt )
+\ defined in bootstrap.fs
+
+\ b(to) ( new-value -- )
+\ FCode for setting values and defers. Followed by FCode#.
+
+: b(to)
+ fcode# fcode>xt
+ 1 handle-lit
+ ['] (to)
+ state @ if
+ ,
+ else
+ execute
+ then
+ ; immediate
+
+
+
+\
+\ 5.3.3.4 Control flow
+\
+
+
+\ offset16 ( -- )
+\ Makes subsequent FCode-offsets use 16-bit (not 8-bit) form.
+
+: offset16
+ true to ?fcode-offset16
+ ;
+
+
+\ bbranch ( -- )
+\ Unconditional branch FCode. Followed by FCode-offset.
+
+: bbranch
+ fcode-offset 0< if \ if we jump backwards, we can forsee where it goes
+ ['] dobranch ,
+ resolve-dest
+ execute-tmp-comp
+ else
+ setup-tmp-comp ['] dobranch ,
+ here 0
+ 0 ,
+ 2swap
+ then
+ ; immediate
+
+
+\ b?branch ( continue? -- )
+\ Conditional branch FCode. Followed by FCode-offset.
+
+: b?branch
+ fcode-offset 0< if \ if we jump backwards, we can forsee where it goes
+ ['] do?branch ,
+ resolve-dest
+ execute-tmp-comp
+ else
+ setup-tmp-comp ['] do?branch ,
+ here 0
+ 0 ,
+ then
+ ; immediate
+
+
+\ b(<mark) ( -- )
+\ Target of backward branches.
+
+: b(<mark)
+ setup-tmp-comp
+ here 1
+ ; immediate
+
+
+\ b(>resolve) ( -- )
+\ Target of forward branches.
+
+: b(>resolve)
+ resolve-orig
+ execute-tmp-comp
+ ; immediate
+
+
+\ b(loop) ( -- )
+\ End FCode do..loop. Followed by FCode-offset.
+
+: b(loop)
+ fcode-offset drop
+ postpone loop
+ ; immediate
+
+
+\ b(+loop) ( delta -- )
+\ End FCode do..+loop. Followed by FCode-offset.
+
+: b(+loop)
+ fcode-offset drop
+ postpone +loop
+ ; immediate
+
+
+\ b(do) ( limit start -- )
+\ Begin FCode do..loop. Followed by FCode-offset.
+
+: b(do)
+ fcode-offset drop
+ postpone do
+ ; immediate
+
+
+\ b(?do) ( limit start -- )
+\ Begin FCode ?do..loop. Followed by FCode-offset.
+
+: b(?do)
+ fcode-offset drop
+ postpone ?do
+ ; immediate
+
+
+\ b(leave) ( -- )
+\ Exit from a do..loop.
+
+: b(leave)
+ postpone leave
+ ; immediate
+
+
+\ b(case) ( sel -- sel )
+\ Begin a case (multiple selection) statement.
+
+: b(case)
+ postpone case
+ ; immediate
+
+
+\ b(endcase) ( sel | <nothing> -- )
+\ End a case (multiple selection) statement.
+
+: b(endcase)
+ postpone endcase
+ ; immediate
+
+
+\ b(of) ( sel of-val -- sel | <nothing> )
+\ FCode for of in case statement. Followed by FCode-offset.
+
+: b(of)
+ fcode-offset drop
+ postpone of
+ ; immediate
+
+\ b(endof) ( -- )
+\ FCode for endof in case statement. Followed by FCode-offset.
+
+: b(endof)
+ fcode-offset drop
+ postpone endof
+ ; immediate
diff --git a/qemu/roms/openbios/forth/device/feval.fs b/qemu/roms/openbios/forth/device/feval.fs
new file mode 100644
index 000000000..9e2773db2
--- /dev/null
+++ b/qemu/roms/openbios/forth/device/feval.fs
@@ -0,0 +1,100 @@
+\ tag: FCode evaluator
+\
+\ this code implements an fcode evaluator
+\ as described in IEEE 1275-1994
+\
+\ Copyright (C) 2003 Stefan Reinauer
+\
+\ See the file "COPYING" for further information about
+\ the copyright and warranty status of this work.
+\
+
+defer init-fcode-table
+
+: alloc-fcode-table
+ 4096 cells alloc-mem to fcode-table
+ ?fcode-verbose if
+ ." fcode-table at 0x" fcode-table . cr
+ then
+ init-fcode-table
+ ;
+
+: free-fcode-table
+ fcode-table 4096 cells free-mem
+ 0 to fcode-table
+ ;
+
+: (debug-feval) ( fcode# -- fcode# )
+ \ Address
+ fcode-stream 1 - . ." : "
+
+ \ Indicate if word is compiled
+ state @ 0<> if
+ ." (compile) "
+ then
+ dup fcode>xt cell - lfa2name type
+ dup ." [ 0x" . ." ]" cr
+ ;
+
+: (feval) ( -- ?? )
+ begin
+ fcode#
+ ?fcode-verbose if
+ (debug-feval)
+ then
+ fcode>xt
+ dup flags? 0<> state @ 0= or if
+ execute
+ else
+ ,
+ then
+ fcode-end @ until
+
+ \ If we've executed incorrect FCode we may have reached the end of the FCode
+ \ program but still be in compile mode. Make sure that if this has happened
+ \ then we switch back to immediate mode to prevent internal OpenBIOS errors.
+ tmp-comp-depth @ -1 <> if
+ -1 tmp-comp-depth !
+ tmp-comp-buf @ @ here!
+ 0 state !
+ then
+;
+
+: byte-load ( addr xt -- )
+ ?fcode-verbose if
+ cr ." byte-load: evaluating fcode at 0x" over . cr
+ then
+
+ \ save state
+ >r >r fcode-push-state r> r>
+
+ \ set fcode-c@ defer
+ dup 1 = if drop ['] c@ then \ FIXME: uses c@ rather than rb@ for now...
+ to fcode-c@
+ dup to fcode-stream-start
+ to fcode-stream
+ 1 to fcode-spread
+ false to ?fcode-offset16
+ alloc-fcode-table
+ false fcode-end !
+
+ \ protect against stack overflow/underflow
+ 0 0 0 0 0 0 depth >r
+
+ ['] (feval) catch if
+ cr ." byte-load: exception caught!" cr
+ then
+
+ s" fcode-debug?" evaluate if
+ depth r@ <> if
+ cr ." byte-load: warning stack overflow, diff " depth r@ - . cr
+ then
+ then
+
+ r> depth! 3drop 3drop
+
+ free-fcode-table
+
+ \ restore state
+ fcode-pop-state
+;
diff --git a/qemu/roms/openbios/forth/device/font.fs b/qemu/roms/openbios/forth/device/font.fs
new file mode 100644
index 000000000..7b742fac4
--- /dev/null
+++ b/qemu/roms/openbios/forth/device/font.fs
@@ -0,0 +1,17 @@
+\ tag: 8x16 bitmap font
+\
+\ Terminus font
+\
+\ The Terminus Font is developed by and is a property
+\ of Dimitar Toshkov Zhekov <jimmy@is-vn.bg>
+\
+\ See the file "COPYING" for further information about
+\ the copyright and warranty status of this work.
+\
+
+0 value (romfont)
+0 value (romfont-width)
+0 value (romfont-height)
+
+\ encode-file romfont.bin
+\ drop value (romfont-8x16)
diff --git a/qemu/roms/openbios/forth/device/logo.fs b/qemu/roms/openbios/forth/device/logo.fs
new file mode 100644
index 000000000..4db31ef54
--- /dev/null
+++ b/qemu/roms/openbios/forth/device/logo.fs
@@ -0,0 +1,98 @@
+\ tag: monochrome logo
+\
+\ simple monochrome logo
+\ as described in IEEE 1275-1994
+\
+\ Copyright (C) 2003 Stefan Reinauer
+\
+\ See the file "COPYING" for further information about
+\ the copyright and warranty status of this work.
+\
+
+
+\ FIXME : This is currently just a test file, it contains
+\ a Pi symbol of size 64x64, not really nicely streched.
+
+\ To use an XBM (X Bitmap), the bits in the bitmap array
+\ have to be reversed, i.e. like this:
+\
+\ int main(void)
+\ {
+\ int i,j; unsigned char bit, bitnew;
+\ for (i=0; i<512; i++) {
+\ bit=openbios_bits[i]; bitnew=0;
+\ for (j=0; j<8; j++)
+\ if (bit & (1<<j)) bitnew |= (1<<(7-j));
+\ printf("%02x c, ", bitnew); if(i%8 == 7) printf("\n");
+\ }
+\ return 0;
+\ }
+
+here
+
+00 c, 00 c, 00 c, 00 c, 00 c, 00 c, 00 c, 00 c,
+00 c, 00 c, 00 c, 00 c, 00 c, 00 c, 00 c, 00 c,
+07 c, ff c, ff c, ff c, ff c, ff c, ff c, e0 c,
+07 c, ff c, ff c, ff c, ff c, ff c, ff c, e0 c,
+07 c, ff c, ff c, ff c, ff c, ff c, ff c, e0 c,
+07 c, ff c, ff c, ff c, ff c, ff c, ff c, e0 c,
+7f c, ff c, ff c, ff c, ff c, ff c, ff c, e0 c,
+7f c, ff c, ff c, ff c, ff c, ff c, ff c, e0 c,
+7f c, ff c, ff c, ff c, ff c, ff c, ff c, e0 c,
+7f c, ff c, ff c, ff c, ff c, ff c, ff c, e0 c,
+7f c, df c, ff c, ff c, 7f c, ff c, ff c, 90 c,
+78 c, 03 c, fe c, 00 c, 07 c, fc c, 00 c, 00 c,
+78 c, 03 c, fe c, 00 c, 07 c, fc c, 00 c, 00 c,
+78 c, 03 c, fe c, 00 c, 07 c, fc c, 00 c, 00 c,
+70 c, 03 c, fe c, 00 c, 07 c, fc c, 00 c, 00 c,
+00 c, 03 c, fe c, 00 c, 07 c, fc c, 00 c, 00 c,
+00 c, 03 c, fe c, 00 c, 07 c, fc c, 00 c, 00 c,
+00 c, 03 c, fe c, 00 c, 07 c, fc c, 00 c, 00 c,
+00 c, 03 c, fe c, 00 c, 07 c, fc c, 00 c, 00 c,
+00 c, 03 c, fe c, 00 c, 07 c, fc c, 00 c, 00 c,
+00 c, 03 c, fe c, 00 c, 07 c, fc c, 00 c, 00 c,
+00 c, 03 c, fe c, 00 c, 07 c, fc c, 00 c, 00 c,
+00 c, 03 c, fe c, 00 c, 07 c, fc c, 00 c, 00 c,
+00 c, 03 c, fe c, 00 c, 07 c, fc c, 00 c, 00 c,
+00 c, 03 c, fe c, 00 c, 07 c, fc c, 00 c, 00 c,
+00 c, 03 c, fe c, 00 c, 07 c, fc c, 00 c, 00 c,
+00 c, 03 c, fe c, 00 c, 07 c, fc c, 00 c, 00 c,
+00 c, 03 c, fe c, 00 c, 07 c, fc c, 00 c, 00 c,
+00 c, 03 c, fe c, 00 c, 07 c, fc c, 00 c, 00 c,
+00 c, 03 c, fe c, 00 c, 07 c, fc c, 00 c, 00 c,
+00 c, 03 c, fe c, 00 c, 07 c, fc c, 00 c, 00 c,
+00 c, 03 c, fe c, 00 c, 07 c, fc c, 00 c, 00 c,
+00 c, 03 c, fe c, 00 c, 07 c, fc c, 00 c, 00 c,
+00 c, 03 c, fe c, 00 c, 07 c, fc c, 00 c, 00 c,
+00 c, 03 c, fe c, 00 c, 07 c, fc c, 00 c, 00 c,
+00 c, 03 c, fe c, 00 c, 07 c, fc c, 00 c, 00 c,
+00 c, 03 c, fe c, 00 c, 07 c, fc c, 00 c, 00 c,
+00 c, 03 c, fe c, 00 c, 07 c, fc c, 00 c, 00 c,
+00 c, 03 c, fe c, 00 c, 07 c, fc c, 00 c, 00 c,
+00 c, 03 c, fe c, 00 c, 07 c, fc c, 00 c, 00 c,
+00 c, 03 c, fe c, 00 c, 07 c, fc c, 00 c, 00 c,
+00 c, 03 c, fe c, 00 c, 07 c, fc c, 00 c, 00 c,
+00 c, 03 c, fe c, 00 c, 07 c, fc c, 00 c, 00 c,
+00 c, 03 c, fe c, 00 c, 07 c, fc c, 00 c, 00 c,
+00 c, 03 c, fe c, 00 c, 07 c, fc c, 00 c, 00 c,
+00 c, 03 c, fe c, 00 c, 07 c, fc c, 00 c, 00 c,
+00 c, 03 c, fe c, 00 c, 07 c, fc c, 01 c, 80 c,
+00 c, 03 c, fe c, 00 c, 07 c, f8 c, 01 c, e0 c,
+00 c, 03 c, fe c, 00 c, 07 c, f8 c, 01 c, e0 c,
+00 c, 03 c, fe c, 00 c, 07 c, fc c, 03 c, e0 c,
+00 c, 07 c, fe c, 00 c, 07 c, fc c, 07 c, e0 c,
+00 c, 3f c, fe c, 00 c, 07 c, ff c, ff c, e0 c,
+00 c, 3f c, fe c, 00 c, 07 c, ff c, ff c, e0 c,
+00 c, 3f c, fe c, 00 c, 07 c, ff c, ff c, e0 c,
+00 c, 3f c, fc c, 00 c, 07 c, ff c, ff c, c0 c,
+00 c, 3f c, f8 c, 00 c, 07 c, ff c, ff c, 80 c,
+00 c, 7f c, e0 c, 00 c, 0f c, ff c, fe c, 00 c,
+00 c, 3f c, e0 c, 00 c, 07 c, ff c, fe c, 00 c,
+00 c, 3f c, c0 c, 00 c, 07 c, ff c, fc c, 00 c,
+00 c, 00 c, 00 c, 00 c, 00 c, 00 c, 00 c, 00 c,
+00 c, 00 c, 00 c, 00 c, 00 c, 00 c, 00 c, 00 c,
+00 c, 00 c, 00 c, 00 c, 00 c, 00 c, 00 c, 00 c,
+00 c, 00 c, 00 c, 00 c, 00 c, 00 c, 00 c, 00 c,
+00 c, 00 c, 00 c, 00 c, 00 c, 00 c, 00 c, 00 c,
+
+value (romlogo-64x64)
diff --git a/qemu/roms/openbios/forth/device/missing b/qemu/roms/openbios/forth/device/missing
new file mode 100644
index 000000000..8ea954ed7
--- /dev/null
+++ b/qemu/roms/openbios/forth/device/missing
@@ -0,0 +1,38 @@
+5.3.3.1
+
+ * (is-user-word)
+
+5.3.4 Package access
+
+5.3.6 Display
+ * default-font
+ * set-font
+ * >font
+ * is-install
+ * is-remove
+ * is-selftest
+
+5.3.7 Other
+ * cpeek
+ * wpeek
+ * lpeek
+ * cpoke
+ * wpoke
+ * lpoke
+ * rb@
+ * rw@
+ * rl@
+ * rb!
+ * rw!
+ * rl!
+ * get-msecs
+ * ms
+ * alarm
+ * user-abort
+ * mac-address
+ * display-status
+ * memory-test-suite
+ * mask
+ * diagnostic-mode?
+ * suspend-fcode
+ * set-args
diff --git a/qemu/roms/openbios/forth/device/other.fs b/qemu/roms/openbios/forth/device/other.fs
new file mode 100644
index 000000000..b39007301
--- /dev/null
+++ b/qemu/roms/openbios/forth/device/other.fs
@@ -0,0 +1,233 @@
+\ tag: Other FCode functions
+\
+\ this code implements IEEE 1275-1994 ch. 5.3.7
+\
+\ Copyright (C) 2003 Stefan Reinauer
+\
+\ See the file "COPYING" for further information about
+\ the copyright and warranty status of this work.
+\
+
+\ The current diagnostic setting
+defer _diag-switch?
+
+
+\
+\ 5.3.7 Other FCode functions
+\
+
+hex
+
+\ 5.3.7.1 Peek/poke
+
+defer (peek)
+:noname
+ execute true
+; to (peek)
+
+: cpeek ( addr -- false | byte true )
+ ['] c@ (peek)
+ ;
+
+: wpeek ( waddr -- false | w true )
+ ['] w@ (peek)
+ ;
+
+: lpeek ( qaddr -- false | quad true )
+ ['] l@ (peek)
+ ;
+
+defer (poke)
+:noname
+ execute true
+; to (poke)
+
+: cpoke ( byte addr -- okay? )
+ ['] c! (poke)
+ ;
+
+: wpoke ( w waddr -- okay? )
+ ['] w! (poke)
+ ;
+
+: lpoke ( quad qaddr -- okay? )
+ ['] l! (poke)
+ ;
+
+
+\ 5.3.7.2 Device-register access
+
+: rb@ ( addr -- byte )
+ ;
+
+: rw@ ( waddr -- w )
+ ;
+
+: rl@ ( qaddr -- quad )
+ ;
+
+: rb! ( byte addr -- )
+ ;
+
+: rw! ( w waddr -- )
+ ;
+
+: rl! ( quad qaddr -- )
+ ;
+
+: rx@ ( oaddr - o )
+ state @ if
+ h# 22e get-token if , else execute then
+ else
+ h# 22e get-token drop execute
+ then
+ ; immediate
+
+: rx! ( o oaddr -- )
+ state @ if
+ h# 22f get-token if , else execute then
+ else
+ h# 22f get-token drop execute
+ then
+ ; immediate
+
+\ 5.3.7.3 Time
+
+\ Pointer to OBP tick value updated by timer interrupt
+variable obp-ticks
+
+\ Dummy implementation for platforms without a timer interrupt
+0 value dummy-msecs
+
+: get-msecs ( -- n )
+ \ If obp-ticks pointer is set, use it. Otherwise fall back to
+ \ dummy implementation
+ obp-ticks @ 0<> if
+ obp-ticks @
+ else
+ dummy-msecs dup 1+ to dummy-msecs
+ then
+ ;
+
+: ms ( n -- )
+ get-msecs +
+ begin dup get-msecs < until
+ drop
+ ;
+
+: alarm ( xt n -- )
+ 2drop
+ ;
+
+: user-abort ( ... -- ) ( R: ... -- )
+ ;
+
+
+\ 5.3.7.4 System information
+0003.0000 value fcode-revision ( -- n )
+
+: mac-address ( -- mac-str mac-len )
+ ;
+
+
+\ 5.3.7.5 FCode self-test
+: display-status ( n -- )
+ ;
+
+: memory-test-suite ( addr len -- fail? )
+ ;
+
+: mask ( -- a-addr )
+ ;
+
+: diagnostic-mode? ( -- diag? )
+ \ Return the NVRAM diag-switch? setting
+ _diag-switch?
+ ;
+
+\ 5.3.7.6 Start and end.
+
+\ Begin program with spread 0 followed by FCode-header.
+: start0 ( -- )
+ 0 fcode-spread !
+ offset16
+ fcode-header
+ ;
+
+\ Begin program with spread 1 followed by FCode-header.
+: start1 ( -- )
+ 1 to fcode-spread
+ offset16
+ fcode-header
+ ;
+
+\ Begin program with spread 2 followed by FCode-header.
+: start2 ( -- )
+ 2 to fcode-spread
+ offset16
+ fcode-header
+ ;
+
+\ Begin program with spread 4 followed by FCode-header.
+: start4 ( -- )
+ 4 to fcode-spread
+ offset16
+ fcode-header
+ ;
+
+\ Begin program with spread 1 followed by FCode-header.
+: version1 ( -- )
+ 1 to fcode-spread
+ fcode-header
+ ;
+
+\ Cease evaluating this FCode program.
+: end0 ( -- )
+ true fcode-end !
+ ; immediate
+
+\ Cease evaluating this FCode program.
+: end1 ( -- )
+ end0
+ ;
+
+\ Standard FCode number for undefined FCode functions.
+: ferror ( -- )
+ ." undefined fcode# encountered." cr
+ true fcode-end !
+ ;
+
+\ Pause FCode evaluation if desired; can resume later.
+: suspend-fcode ( -- )
+ \ NOT YET IMPLEMENTED.
+ ;
+
+
+\ Evaluate FCode beginning at location addr.
+
+\ : byte-load ( addr xt -- )
+\ \ this word is implemented in feval.fs
+\ ;
+
+\ Set address and arguments of new device node.
+: set-args ( arg-str arg-len unit-str unit-len -- )
+ ?my-self drop
+
+ depth 1- >r
+ " decode-unit" ['] $call-parent catch if
+ 2drop 2drop
+ then
+
+ my-self ihandle>phandle >dn.probe-addr \ offset
+ begin depth r@ > while
+ dup na1+ >r ! r>
+ repeat
+ r> 2drop
+
+ my-self >in.arguments 2@ free-mem
+ strdup my-self >in.arguments 2!
+;
+
+: dma-alloc
+ s" dma-alloc" $call-parent
+ ;
diff --git a/qemu/roms/openbios/forth/device/package.fs b/qemu/roms/openbios/forth/device/package.fs
new file mode 100644
index 000000000..d5b52c3eb
--- /dev/null
+++ b/qemu/roms/openbios/forth/device/package.fs
@@ -0,0 +1,287 @@
+\ tag: Package access.
+\
+\ this code implements IEEE 1275-1994 ch. 5.3.4
+\
+\ Copyright (C) 2003 Stefan Reinauer
+\
+\ See the file "COPYING" for further information about
+\ the copyright and warranty status of this work.
+\
+
+\ variable last-package 0 last-package !
+\ 0 value active-package
+: current-device active-package ;
+
+\
+\ 5.3.4.1 Open/Close packages (part 1)
+\
+
+\ 0 value my-self ( -- ihandle )
+: ?my-self
+ my-self dup 0= abort" no current instance."
+ ;
+
+: my-parent ( -- ihandle )
+ ?my-self >in.my-parent @
+;
+
+: ihandle>non-interposed-phandle ( ihandle -- phandle )
+ begin dup >in.interposed @ while
+ >in.my-parent @
+ repeat
+ >in.device-node @
+;
+
+: ihandle>phandle ( ihandle -- phandle )
+ >in.device-node @
+;
+
+
+\ next-property
+\ defined in property.c
+
+: peer ( phandle -- phandle.sibling )
+ ?dup if
+ >dn.peer @
+ else
+ device-tree @
+ then
+;
+
+: child ( phandle.parent -- phandle.child )
+ \ Assume phandle == 0 indicates root node (not documented but similar
+ \ behaviour to "peer"). Used by some versions of Solaris (e.g. 9).
+ ?dup if else device-tree @ then
+
+ >dn.child @
+;
+
+
+\
+\ 5.3.4.2 Call methods from other packages
+\
+
+: find-method ( method-str method-len phandle -- false | xt true )
+ \ should we search the private wordlist too? I don't think so...
+ >dn.methods @ find-wordlist if
+ true
+ else
+ 2drop false
+ then
+;
+
+: call-package ( ... xt ihandle -- ??? )
+ my-self >r
+ to my-self
+ execute
+ r> to my-self
+;
+
+
+: $call-method ( ... method-str method-len ihandle -- ??? )
+ dup >r >in.device-node @ find-method if
+ r> call-package
+ else
+ -21 throw
+ then
+;
+
+: $call-parent ( ... method-str method-len -- ??? )
+ my-parent $call-method
+;
+
+
+\
+\ 5.3.4.1 Open/Close packages (part 2)
+\
+
+\ find-dev ( dev-str dev-len -- false | phandle true )
+\ find-rel-dev ( dev-str dev-len phandle -- false | phandle true )
+\
+\ These function works just like find-device but without
+\ any side effects (or exceptions).
+\
+defer find-dev
+
+: find-rel-dev ( dev-str dev-len phandle -- false | phandle true )
+ active-package >r active-package!
+ find-dev
+ r> active-package!
+;
+
+: find-package ( name-str name-len -- false | phandle true )
+\ Locate the support package named by name string.
+\ If the package can be located, return its phandle and true; otherwise,
+\ return false.
+\ Interpret the name in name string relative to the "packages" device node.
+\ If there are multiple packages with the same name (within the "packages"
+\ node), return the phandle for the most recently created one.
+
+ \ This does the full path resolution stuff (including
+ \ alias expansion. If we don't want that, then we should just
+ \ iterade the children of /packages.
+ " /packages" find-dev 0= if 2drop false exit then
+ find-rel-dev 0= if false exit then
+
+ true
+;
+
+: open-package ( arg-str arg-len phandle -- ihandle | 0 )
+\ Open the package indicated by phandle.
+\ Create an instance of the package identified by phandle, save in that
+\ instance the instance-argument specified by arg-string and invoke the
+\ package's open method.
+\ Return the instance handle ihandle of the new instance, or 0 if the package
+\ could not be opened. This could occur either because that package has no
+\ open method, or because its open method returned false, indicating an error.
+\ The parent instance of the new instance is the instance that invoked
+\ open-package. The current instance is not changed.
+
+ create-instance dup 0= if
+ 3drop 0 exit
+ then
+ >r
+
+ \ clone arg-str
+ strdup r@ >in.arguments 2!
+
+ \ open the package
+ " open" r@ ['] $call-method catch if 3drop false then
+ if
+ r>
+ else
+ r> destroy-instance false
+ then
+;
+
+
+: $open-package ( arg-str arg-len name-str name-len -- ihandle | 0 )
+ \ Open the support package named by name string.
+ find-package if
+ open-package
+ else
+ 2drop false
+ then
+;
+
+
+: close-package ( ihandle -- )
+\ Close the instance identified by ihandle by calling the package's close
+\ method and then destroying the instance.
+ dup " close" rot ['] $call-method catch if 3drop then
+ destroy-instance
+;
+
+\
+\ 5.3.4.3 Get local arguments
+\
+
+: my-address ( -- phys.lo ... )
+ ?my-self >in.device-node @
+ >dn.probe-addr
+ my-#acells tuck /l* + swap 1- 0
+ ?do
+ /l - dup l@ swap
+ loop
+ drop
+ ;
+
+: my-space ( -- phys.hi )
+ ?my-self >in.device-node @
+ >dn.probe-addr @
+ ;
+
+: my-unit ( -- phys.lo ... phys.hi )
+ ?my-self >in.my-unit
+ my-#acells tuck /l* + swap 0 ?do
+ /l - dup l@ swap
+ loop
+ drop
+ ;
+
+: my-args ( -- arg-str arg-len )
+ ?my-self >in.arguments 2@
+ ;
+
+\ char is not included. If char is not found, then R-len is zero
+: left-parse-string ( str len char -- R-str R-len L-str L-len )
+ left-split
+;
+
+\ parse ints "hi,...,lo" separated by comma
+: parse-ints ( str len num -- val.lo .. val.hi )
+ -rot 2 pick -rot
+ begin
+ rot 1- -rot 2 pick 0>=
+ while
+ ( num n str len )
+ 2dup ascii , strchr ?dup if
+ ( num n str len p )
+ 1+ -rot
+ 2 pick 2 pick - ( num n p str len len1+1 )
+ dup -rot - ( num n p str len1+1 len2 )
+ -rot 1- ( num n p len2 str len1 )
+ else
+ 0 0 2swap
+ then
+ $number if 0 then >r
+ repeat
+ 3drop
+
+ ( num )
+ begin 1- dup 0>= while r> swap repeat
+ drop
+;
+
+: parse-2int ( str len -- val.lo val.hi )
+ 2 parse-ints
+;
+
+
+\
+\ 5.3.4.4 Mapping tools
+\
+
+: map-low ( phys.lo ... size -- virt )
+ my-space swap s" map-in" $call-parent
+ ;
+
+: free-virtual ( virt size -- )
+ over s" address" get-my-property 0= if
+ decode-int -rot 2drop = if
+ s" address" delete-property
+ then
+ else
+ drop
+ then
+ s" map-out" $call-parent
+ ;
+
+
+\ Deprecated functions (required for compatibility with older loaders)
+
+variable package-stack-pos 0 package-stack-pos !
+create package-stack 8 cells allot
+
+: push-package ( phandle -- )
+ \ Throw an error if we attempt to push a full stack
+ package-stack-pos @ 8 >= if
+ ." cannot push-package onto full stack" cr
+ -99 throw
+ then
+ active-package
+ package-stack-pos @ /n * package-stack + !
+ package-stack-pos @ 1 + package-stack-pos !
+ active-package!
+ ;
+
+: pop-package ( -- )
+ \ Throw an error if we attempt to pop an empty stack
+ package-stack-pos @ 0 = if
+ ." cannot pop-package from empty stack" cr
+ -99 throw
+ then
+ package-stack-pos @ 1 - package-stack-pos !
+ package-stack-pos @ /n * package-stack + @
+ active-package!
+ ;
diff --git a/qemu/roms/openbios/forth/device/pathres.fs b/qemu/roms/openbios/forth/device/pathres.fs
new file mode 100644
index 000000000..a185b95a1
--- /dev/null
+++ b/qemu/roms/openbios/forth/device/pathres.fs
@@ -0,0 +1,522 @@
+\ tag: Path resolution
+\
+\ this code implements IEEE 1275-1994 path resolution
+\
+\ Copyright (C) 2003 Samuel Rydh
+\
+\ See the file "COPYING" for further information about
+\ the copyright and warranty status of this work.
+\
+
+0 value interpose-ph
+0 0 create interpose-args , ,
+
+: expand-alias ( alias-addr alias-len -- exp-addr exp-len expanded? )
+ 2dup
+ " /aliases" find-dev 0= if 2drop false exit then
+ get-package-property if
+ false
+ else
+ 2swap 2drop
+ \ drop trailing 0 from string
+ dup if 1- then
+ true
+ then
+;
+
+\
+\ 4.3.1 Resolve aliases
+\
+
+\ the returned string is allocated with alloc-mem
+: pathres-resolve-aliases ( path-addr path-len -- path-addr path-len )
+ over c@ 2f <> if
+ 200 here + >r \ abuse dictionary for temporary storage
+
+ \ If the pathname does not begin with "/", and its first node name
+ \ component is an alias, replace the alias with its expansion.
+ ascii / split-before \ (PATH_NAME, "/") -> (TAIL HEAD)
+ ascii : split-before \ (HEAD, ":") -> (ALIAS_ARGS AL_NAME)
+ expand-alias ( TAIL ALIAS_ARGS EXP_ALIAS_NAME expanded? )
+ if
+ 2 pick 0<> if \ If ALIAS_ARGS is not empty
+ ascii / split-after \ (ALIAS_NAME, "/") -> (AL_TAIL AL_HEAD/)
+ 2swap ( TAIL AL_HEAD/ AL_TAIL )
+ ascii : split-before \ (AL_TAIL, ":") -> (DEAD_ARGS AL_TAIL)
+ 2swap 2drop ( TAIL AL_ARGS AL_HEAD ALIAS_TAIL )
+ 2swap ( TAIL AL_ARGS AL_TAIL AL_HEAD )
+ r> tmpstrcat tmpstrcat >r
+ else
+ 2swap 2drop \ drop ALIAS_ARGS
+ then
+ r> tmpstrcat drop
+ else
+ \ put thing back together again
+ r> tmpstrcat tmpstrcat drop
+ then
+ then
+
+ strdup
+ ( path-addr path-len )
+;
+
+\
+\ search struct
+\
+
+struct ( search information )
+ 2 cells field >si.path
+ 2 cells field >si.arguments
+ 2 cells field >si.unit_addr
+ 2 cells field >si.node_name
+ 2 cells field >si.free_me
+ 4 cells field >si.unit_phys
+ /n field >si.unit_phys_len
+ /n field >si.save-ihandle
+ /n field >si.save-phandle
+ /n field >si.top-ihandle
+ /n field >si.top-opened \ set after successful open
+ /n field >si.child \ node to match
+constant sinfo.size
+
+
+\
+\ 4.3.6 node name match criteria
+\
+
+: match-nodename ( childname len sinfo -- match? )
+ >r
+ 2dup r@ >si.node_name 2@
+ ( [childname] [childname] [nodename] )
+ strcmp 0= if r> 3drop true exit then
+
+ \ does NODE_NAME contain a comma?
+ r@ >si.node_name 2@ ascii , strchr
+ if r> 3drop false exit then
+
+ ( [childname] )
+ ascii , left-split 2drop r@ >si.node_name 2@
+ r> drop
+ strcmp if false else true then
+;
+
+
+\
+\ 4.3.4 exact match child node
+\
+
+\ If NODE_NAME is not empty, make sure it matches the name property
+: common-match ( sinfo -- )
+ >r
+ \ a) NODE_NAME nonempty
+ r@ >si.node_name 2@ nip if
+ " name" r@ >si.child @ get-package-property if -1 throw then
+ \ name is supposed to be null-terminated
+ dup 0> if 1- then
+ \ exit if NODE_NAME does not match
+ r@ match-nodename 0= if -2 throw then
+ then
+ r> drop
+;
+
+: (exact-match) ( sinfo -- )
+ >r
+ \ a) If NODE_NAME is not empty, make sure it matches the name property
+ r@ common-match
+
+ \ b) UNIT_PHYS nonempty?
+ r@ >si.unit_phys_len @ /l* ?dup if
+ \ check if unit_phys matches
+ " reg" r@ >si.child @ get-package-property if -3 throw then
+ ( unitbytes propaddr proplen )
+ rot r@ >si.unit_phys -rot
+ ( propaddr unit_phys proplen unitbytes )
+ swap over < if -4 throw then
+ comp if -5 throw then
+ else
+ \ c) both NODE_NAME and UNIT_PHYS empty?
+ r@ >si.node_name 2@ nip 0= if -6 throw then
+ then
+
+ r> drop
+;
+
+: exact-match ( sinfo -- match? )
+ ['] (exact-match) catch if drop false exit then
+ true
+;
+
+\
+\ 4.3.5 wildcard match child node
+\
+
+: (wildcard-match) ( sinfo -- match? )
+ >r
+ \ a) If NODE_NAME is not empty, make sure it matches the name property
+ r@ common-match
+
+ \ b) Fail if "reg" property exist
+ " reg" r@ >si.child @ get-package-property 0= if -7 throw then
+
+ \ c) Fail if both NODE_NAME and UNIT_ADDR are both empty
+ r@ >si.unit_phys_len @
+ r@ >si.node_name 2@ nip
+ or 0= if -1 throw then
+
+ \ SUCCESS
+ r> drop
+;
+
+: wildcard-match ( sinfo -- match? )
+ ['] (wildcard-match) catch if drop false exit then
+ true
+;
+
+
+\
+\ 4.3.3 match child node
+\
+
+\ used if package lacks a decode-unit method
+: def-decode-unit ( str len -- unitaddr ... )
+ parse-hex
+;
+
+: get-decode-unit-xt ( phandle -- xt )
+ " decode-unit" rot find-method
+ 0= if ['] def-decode-unit then
+;
+
+: find-child ( sinfo -- phandle )
+ >r
+ \ decode unit address string
+ r@ >si.unit_addr 2@ dup if
+ ( str len )
+ active-package get-decode-unit-xt
+ depth 3 - >r execute depth r@ - r> swap
+ ( ... a_lo ... a_hi olddepth n )
+ 4 min 0 max
+ dup r@ >si.unit_phys_len !
+ ( ... a_lo ... a_hi olddepth n )
+ r@ >si.unit_phys >r
+ begin 1- dup 0>= while
+ rot r> dup la1+ >r l!-be
+ repeat
+ r> 2drop
+ depth!
+ else
+ 2drop
+ \ clear unit_phys
+ 0 r@ >si.unit_phys_len !
+ \ r@ >si.unit_phys 4 cells 0 fill
+ then
+
+ ( R: sinfo )
+ ['] exact-match
+ begin dup while
+ active-package >dn.child @
+ begin ?dup while
+ dup r@ >si.child !
+ ( xt phandle R: sinfo )
+ r@ 2 pick execute if 2drop r> >si.child @ exit then
+ >dn.peer @
+ repeat
+ ['] exact-match = if ['] wildcard-match else 0 then
+ repeat
+
+ -99 throw
+;
+
+
+\
+\ 4.3.2 Create new linked instance procedure
+\
+
+: link-one ( sinfo -- )
+ >r
+ active-package create-instance
+ dup 0= if -99 throw then
+
+ \ change instance parent
+ r@ >si.top-ihandle @ over >in.my-parent !
+ dup r@ >si.top-ihandle !
+ to my-self
+
+ \ b) set my-args field
+ r@ >si.arguments 2@ strdup my-self >in.arguments 2!
+
+ \ e) set my-unit field
+ r@ >si.unit_addr 2@ nip if
+ \ copy UNIT_PHYS to the my-unit field
+ r@ >si.unit_phys my-self >in.my-unit 4 cells move
+ else
+ \ set unit-addr from reg property
+ " reg" active-package get-package-property 0= if
+ \ ( ihandle prop proplen )
+ \ copy address to my-unit
+ 4 cells min my-self >in.my-unit swap move
+ else
+ \ clear my-unit
+ my-self >in.my-unit 4 cells 0 fill
+ then
+ then
+
+ \ top instance has not been opened (yet)
+ false r> >si.top-opened !
+;
+
+: invoke-open ( sinfo -- )
+ " open" my-self ['] $call-method
+ catch if 3drop false then
+ 0= if -99 throw then
+
+ true swap >si.top-opened !
+;
+
+\
+\ 4.3.7 Handle interposers procedure (supplement)
+\
+
+: handle-interposers ( sinfo -- )
+ >r
+ begin
+ interpose-ph ?dup
+ while
+ 0 to interpose-ph
+ active-package swap active-package!
+
+ \ clear unit address and set arguments
+ 0 0 r@ >si.unit_addr 2!
+ interpose-args 2@ r@ >si.arguments 2!
+ r@ link-one
+ true my-self >in.interposed !
+ interpose-args 2@ free-mem
+ r@ invoke-open
+
+ active-package!
+ repeat
+
+ r> drop
+;
+
+\
+\ 4.3.1 Path resolution procedure
+\
+
+\ close-dev ( ihandle -- )
+\
+: close-dev
+ begin
+ dup
+ while
+ dup >in.my-parent @
+ swap close-package
+ repeat
+ drop
+;
+
+: path-res-cleanup ( sinfo close? )
+
+ \ tear down all instances if close? is set
+ if
+ dup >si.top-opened @ if
+ dup >si.top-ihandle @
+ ?dup if close-dev then
+ else
+ dup >si.top-ihandle @ dup
+ ( sinfo ihandle ihandle )
+ dup if >in.my-parent @ swap then
+ ( sinfo parent ihandle )
+ ?dup if destroy-instance then
+ ?dup if close-dev then
+ then
+ then
+
+ \ restore active-package and my-self
+ dup >si.save-ihandle @ to my-self
+ dup >si.save-phandle @ active-package!
+
+ \ free any allocated memory
+ dup >si.free_me 2@ free-mem
+ sinfo.size free-mem
+;
+
+: (path-resolution) ( context sinfo -- )
+ >r r@ >si.path 2@
+ ( context pathstr pathlen )
+
+ \ this allocates a copy of the string
+ pathres-resolve-aliases
+ 2dup r@ >si.free_me 2!
+
+ \ If the pathname, after possible alias expansion, begins with "/",
+ \ begin the search at the root node. Otherwise, begin at the active
+ \ package.
+
+ dup if \ make sure string is not empty
+ over c@ 2f = if
+ swap char+ swap /c - \ Remove the "/" from PATH_NAME.
+ \ Set the active package to the root node.
+ device-tree @ active-package!
+ then
+ then
+
+ r@ >si.path 2!
+ 0 0 r@ >si.unit_addr 2!
+ 0 0 r@ >si.arguments 2!
+ 0 r@ >si.top-ihandle !
+
+ \ If there is no active package, exit this procedure, returning false.
+ ( context )
+ active-package 0= if -99 throw then
+
+ \ Begin the creation of an instance chain.
+ \ NOTE--If, at this step, the active package is not the root node and
+ \ we are in open-dev or execute-device-method contexts, the instance
+ \ chain that results from the path resolution process may be incomplete.
+
+ active-package swap
+ ( virt-active-node context )
+ begin
+ r@ >si.path 2@ nip \ nonzero path?
+ while
+ \ ( active-node context )
+ \ is this open-dev or execute-device-method context?
+ dup if
+ r@ link-one
+ over active-package <> my-self >in.interposed !
+ r@ invoke-open
+ r@ handle-interposers
+ then
+ over active-package!
+
+ r@ >si.path 2@ ( PATH )
+
+ ascii / left-split ( PATH COMPONENT )
+ ascii : left-split ( PATH ARGS NODE_ADDR )
+ ascii @ left-split ( PATH ARGS UNIT_ADDR NODE_NAME )
+
+ r@ >si.node_name 2!
+ r@ >si.unit_addr 2!
+ r@ >si.arguments 2!
+ r@ >si.path 2!
+
+ ( virt-active-node context )
+
+ \ 4.3.1 i) pathname has a leading %?
+ r@ >si.node_name 2@ 2dup 2dup ascii % strchr nip = if
+ 1- swap 1+ swap r@ >si.node_name 2!
+ " /packages" find-dev drop active-package!
+ r@ find-child
+ else
+ 2drop
+ nip r@ find-child swap over
+ ( new-node context new-node )
+ then
+
+ \ (optional: open any nodes between parent and child )
+
+ active-package!
+ repeat
+
+ ( virt-active-node type )
+ dup if r@ link-one then
+ 1 = if
+ dup active-package <> my-self >in.interposed !
+ r@ invoke-open
+ r@ handle-interposers
+ then
+ active-package!
+
+ r> drop
+;
+
+: path-resolution ( context path-addr path-len -- sinfo true | false )
+ \ allocate and clear the search block
+ sinfo.size alloc-mem >r
+ r@ sinfo.size 0 fill
+
+ \ store path
+ r@ >si.path 2!
+
+ \ save ihandle and phandle
+ my-self r@ >si.save-ihandle !
+ active-package r@ >si.save-phandle !
+
+ \ save context (if we take an exception)
+ dup
+
+ r@ ['] (path-resolution)
+ catch ?dup if
+ ( context xxx xxx error )
+ r> true path-res-cleanup
+
+ \ rethrow everything except our "cleanup throw"
+ dup -99 <> if throw then
+ 3drop
+
+ \ ( context ) throw an exception if this is find-device context
+ if false else -22 throw then
+ exit
+ then
+
+ \ ( context )
+ drop r> true
+ ( sinfo true )
+;
+
+
+: open-dev ( dev-str dev-len -- ihandle | 0 )
+ 1 -rot path-resolution 0= if false exit then
+
+ ( sinfo )
+ my-self swap
+ false path-res-cleanup
+
+ ( ihandle )
+;
+
+: execute-device-method
+( ... dev-str dev-len met-str met-len -- ... false | ?? true )
+ 2swap
+ 2 -rot path-resolution 0= if 2drop false exit then
+ ( method-str method-len sinfo )
+ >r
+ my-self ['] $call-method catch
+ if 3drop false else true then
+ r> true path-res-cleanup
+;
+
+: find-device ( dev-str dev-len -- )
+ 2dup " .." strcmp 0= if
+ 2drop
+ active-package dup if >dn.parent @ then
+ \ ".." in root note?
+ dup 0= if -22 throw then
+ active-package!
+ exit
+ then
+ 0 -rot path-resolution 0= if false exit then
+ ( sinfo )
+ active-package swap
+ true path-res-cleanup
+ active-package!
+;
+
+\ find-device, but without side effects
+: (find-dev) ( dev-str dev-len -- phandle true | false )
+ active-package -rot
+ ['] find-device catch if 3drop false exit then
+ active-package swap active-package! true
+;
+
+\ Tuck on a node at the end of the chain being created.
+\ This implementation follows the interpose recommended practice
+\ (v0.2 draft).
+
+: interpose ( arg-str arg-len phandle -- )
+ to interpose-ph
+ strdup interpose-args 2!
+;
+
+['] (find-dev) to find-dev
diff --git a/qemu/roms/openbios/forth/device/preof.fs b/qemu/roms/openbios/forth/device/preof.fs
new file mode 100644
index 000000000..131beacd3
--- /dev/null
+++ b/qemu/roms/openbios/forth/device/preof.fs
@@ -0,0 +1,49 @@
+\ tag: historical and pre open firmware fcode functions
+\
+\ this code implements IEEE 1275-1994 ch. H.2.2 and 5.3.1.1.1
+\
+\ Copyright (C) 2003 Stefan Reinauer
+\
+\ See the file "COPYING" for further information about
+\ the copyright and warranty status of this work.
+\
+
+\ H.2.2 Non-implemented FCodes
+\ Pre-Open Firmware systems assigned the following FCode numbers,
+\ but the functions were not supported. These FCode numbers stay
+\ reserved to avoid confusion.
+
+: non-implemented
+ ." Non-implemented historical or pre-Open Firmware FCode occured." cr
+ end0
+ ;
+
+: adr-mask non-implemented ;
+: b(code) non-implemented ;
+: 4-byte-id non-implemented ;
+: convert non-implemented ;
+: frame-buffer-busy? non-implemented ;
+: poll-packet non-implemented ;
+: return-buffer non-implemented ;
+: set-token-table non-implemented ;
+: set-table non-implemented ;
+: xmit-packet non-implemented ;
+
+\ historical fcode words defined by 5.3.1.1.1
+
+30000 constant fcode-version \ this opcode is considered obsolete
+30000 constant firmware-version \ this opcode is considered obsolete
+
+\ historical - Returns the type of processor.
+\ 0x5 indicates SPARC, other values are not used.
+\ ?? this could be set by the kernel during bootstrap.
+deadbeef constant processor-type ( -- processor-type )
+
+: memmap non-implemented ;
+: >physical non-implemented ;
+: my-params non-implemented ;
+: intr non-implemented ;
+: driver non-implemented ;
+: group-code non-implemented ;
+: probe non-implemented ;
+: probe-virtual non-implemented ;
diff --git a/qemu/roms/openbios/forth/device/property.fs b/qemu/roms/openbios/forth/device/property.fs
new file mode 100644
index 000000000..1d54e3ec3
--- /dev/null
+++ b/qemu/roms/openbios/forth/device/property.fs
@@ -0,0 +1,335 @@
+\ tag: Property management
+\
+\ this code implements IEEE 1275-1994 ch. 5.3.5
+\
+\ Copyright (C) 2003 Stefan Reinauer
+\
+\ See the file "COPYING" for further information about
+\ the copyright and warranty status of this work.
+\
+
+\ small helpers.. these should go elsewhere.
+: bigendian?
+ 10 here ! here c@ 10 <>
+ ;
+
+: l!-be ( val addr )
+ 3 bounds swap do
+ dup ff and i c!
+ 8 rshift
+ -1 +loop
+ drop
+ ;
+
+: l@-be ( addr )
+ 0 swap 4 bounds do
+ i c@ swap 8 << or
+ loop
+ ;
+
+\ allocate n bytes for device tree information
+\ until I know where to put this, I put it in the
+\ dictionary.
+
+: alloc-tree ( n -- addr )
+ dup >r \ save len
+ here swap allot
+ dup r> 0 fill \ clear memory
+ ;
+
+: align-tree ( -- )
+ null-align
+ ;
+
+: no-active true abort" no active package." ;
+
+\
+\ 5.3.5 Property management
+\
+
+\ Helper function
+: find-property ( name len phandle -- &&prop|0 )
+ >dn.properties
+ begin
+ dup @
+ while
+ dup @ >prop.name @ ( name len prop propname )
+ 2over comp0 ( name len prop equal? )
+ 0= if nip nip exit then
+ >prop.next @
+ repeat
+ ( name len false )
+ 3drop false
+ ;
+
+\ From package (5.3.4.1)
+: next-property
+( previous-str previous-len phandle -- false | name-str name-len true )
+ >r
+ 2dup 0= swap 0= or if
+ 2drop r> >dn.properties @
+ else
+ r> find-property dup if @ then
+ dup if >prop.next @ then
+ then
+
+ ?dup if
+ >prop.name @ dup cstrlen true
+ ( phandle name-str name-len true )
+ else
+ false
+ then
+;
+
+
+\
+\ 5.3.5.4 Property value access
+\
+
+\ Return value for name string property in package phandle.
+: get-package-property
+ ( name-str name-len phandle -- true | prop-addr prop-len false )
+ find-property ?dup if
+ @ dup >prop.addr @
+ swap >prop.len @
+ false
+ else
+ true
+ then
+ ;
+
+\ Return value for given property in the current instance or its parents.
+: get-inherited-property
+ ( name-str name-len -- true | prop-addr prop-len false )
+ my-self
+ begin
+ ?dup
+ while
+ dup >in.device-node @ ( str len ihandle phandle )
+ 2over rot find-property ?dup if
+ @
+ ( str len ihandle prop )
+ nip nip nip ( prop )
+ dup >prop.addr @ swap >prop.len @
+ false
+ exit
+ then
+ ( str len ihandle )
+ >in.my-parent @
+ repeat
+ 2drop
+ true
+ ;
+
+\ Return value for given property in this package.
+: get-my-property ( name-str name-len -- true | prop-addr prop-len false )
+ my-self >in.device-node @ ( -- phandle )
+ get-package-property
+ ;
+
+
+\
+\ 5.3.5.2 Property array decoding
+\
+
+: decode-int ( prop-addr1 prop-len1 -- prop-addr2 prop-len2 n )
+ dup 0> if
+ dup 4 min >r ( addr1 len1 R:minlen )
+ over r@ + swap ( addr1 addr2 len1 R:minlen )
+ r> - ( addr1 addr2 len2 )
+ rot l@-be
+ else
+ 0
+ then
+ ;
+
+\ HELPER: get #address-cell value (from parent)
+\ Legal values are 1..4 (we may optionally support longer addresses)
+: my-#acells ( -- #address-cells )
+ my-self ?dup if >in.device-node @ else active-package then
+ ?dup if >dn.parent @ then
+ ?dup if
+ " #address-cells" rot get-package-property if 2 exit then
+ \ we don't have to support more than 4 (and 0 is illegal)
+ decode-int nip nip 4 min 1 max
+ else
+ 2
+ then
+;
+
+\ HELPER: get #size-cells value (from parent)
+: my-#scells ( -- #size-cells )
+ my-self ?dup if >in.device-node @ else active-package then
+ ?dup if >dn.parent @ then
+ ?dup if
+ " #size-cells" rot get-package-property if 1 exit then
+ decode-int nip nip
+ else
+ 1
+ then
+;
+
+: decode-string ( prop-addr1 prop-len1 -- prop-addr2 prop-len2 str len )
+ dup 0> if
+ 2dup bounds \ check property for 0 bytes
+ 0 -rot \ initial string len is 0
+ do
+ i c@ 0= if
+ leave
+ then
+ 1+
+ loop ( prop-addr1 prop-len1 len )
+ 1+ rot >r ( prop-len1 len R: prop-addr1 )
+ over min 2dup - ( prop-len1 nlen prop-len2 R: prop-addr1 )
+ r@ 2 pick + ( prop-len1 nlen prop-len2 prop-addr2 )
+ >r >r >r ( R: prop-addr1 prop-addr2 prop-len2 nlen )
+ drop
+ r> r> r> ( nlen prop-len2 prop-addr2 )
+ -rot swap 1- ( prop-addr2 prop-len2 nlen )
+ r> swap ( prop-addr2 prop-len2 str len )
+ else
+ 0 0
+ then
+ ;
+
+: decode-bytes ( addr1 len1 #bytes -- addr len2 addr1 #bytes )
+ tuck - ( addr1 #bytes len2 )
+ r> 2dup + ( addr1 #bytes addr2 ) ( R: len2 )
+ r> 2swap
+ ;
+
+: decode-phys
+ ( prop-addr1 prop-len1 -- prop-addr2 prop-len2 phys.lo ... phys.hi )
+ my-#acells 0 ?do
+ decode-int r> r> rot >r >r >r
+ loop
+ my-#acells 0 ?do
+ r> r> r> -rot >r >r
+ loop
+ ;
+
+
+\
+\ 5.3.5.1 Property array encoding
+\
+
+: encode-int ( n -- prop-addr prop-len )
+ /l alloc-tree tuck l!-be /l
+ ;
+
+: encode-string ( str len -- prop-addr prop-len )
+ \ we trust len here. should probably check string?
+ tuck char+ alloc-tree ( len str prop-addr )
+ tuck 3 pick move ( len prop-addr )
+ swap 1+
+ ;
+
+: encode-bytes ( data-addr data-len -- prop-addr prop-len )
+ tuck alloc-tree ( len str prop-addr )
+ tuck 3 pick move
+ swap
+ ;
+
+: encode+ ( prop-addr1 prop-len1 prop-addr2 prop-len2 -- prop-addr3 prop-len3 )
+ nip +
+ ;
+
+: encode-phys ( phys.lo ... phys.hi -- prop-addr prop-len )
+ encode-int my-#acells 1- 0 ?do
+ rot encode-int encode+
+ loop
+ ;
+
+defer sbus-intr>cpu ( sbus-intr# -- cpu-intr# )
+: (sbus-intr>cpu) ." No SBUS present on this machine." cr ;
+['] (sbus-intr>cpu) to sbus-intr>cpu
+
+
+\
+\ 5.3.5.3 Property declaration
+\
+
+: (property) ( prop-addr prop-len name-str name-len dnode -- )
+ >r 2dup r@
+ align-tree
+ find-property ?dup if
+ \ If a property with that property name already exists in the
+ \ package in which the property would be created, replace its
+ \ value with the new value.
+ @ r> drop \ don't need the device node anymore.
+ -rot 2drop tuck \ drop property name
+ >prop.len ! \ overwrite old values
+ >prop.addr !
+ exit
+ then
+
+ ( prop-addr prop-len name-str name-len R: dn )
+ prop-node.size alloc-tree
+ dup >prop.next off
+
+ dup r> >dn.properties
+ begin dup @ while @ >prop.next repeat !
+ >r
+
+ ( prop-addr prop-len name-str name-len R: prop )
+
+ \ create copy of property name
+ dup char+ alloc-tree
+ dup >r swap move r>
+ ( prop-addr prop-len new-name R: prop )
+ r@ >prop.name !
+ r@ >prop.len !
+ r> >prop.addr !
+ align-tree
+ ;
+
+: property ( prop-addr prop-len name-str name-len -- )
+ my-self ?dup if
+ >in.device-node @
+ else
+ active-package
+ then
+ dup if
+ (property)
+ else
+ no-active
+ then
+ ;
+
+: (delete-property) ( name len dnode -- )
+ find-property ?dup if
+ dup @ >prop.next @ swap !
+ \ maybe we should try to reclaim the space?
+ then
+;
+
+: delete-property ( name-str name-len -- )
+ active-package ?dup if
+ (delete-property)
+ else
+ 2drop
+ then
+ ;
+
+\ Create the "name" property; value is indicated string.
+: device-name ( str len -- )
+ encode-string " name" property
+ ;
+
+\ Create "device_type" property, value is indicated string.
+: device-type ( str len -- )
+ encode-string " device_type" property
+ ;
+
+\ Create the "reg" property with the given values.
+: reg ( phys.lo ... phys.hi size -- )
+ >r ( phys.lo ... phys.hi ) encode-phys ( addr len )
+ r> ( addr1 len1 size ) encode-int ( addr1 len1 addr2 len2 )
+ encode+ ( addr len )
+ " reg" property
+ ;
+
+\ Create the "model" property; value is indicated string.
+: model ( str len -- )
+ encode-string " model" property
+ ;
diff --git a/qemu/roms/openbios/forth/device/romfont.bin b/qemu/roms/openbios/forth/device/romfont.bin
new file mode 100644
index 000000000..0b60b6fb4
--- /dev/null
+++ b/qemu/roms/openbios/forth/device/romfont.bin
Binary files differ
diff --git a/qemu/roms/openbios/forth/device/structures.fs b/qemu/roms/openbios/forth/device/structures.fs
new file mode 100644
index 000000000..14dd881e5
--- /dev/null
+++ b/qemu/roms/openbios/forth/device/structures.fs
@@ -0,0 +1,54 @@
+\ tag: device interface structures
+\
+\ this code implements data structures used by the
+\ IEEE 1275-1994 Open Firmware Device Interface.
+\
+\ Copyright (C) 2003 Stefan Reinauer
+\
+\ See the file "COPYING" for further information about
+\ the copyright and warranty status of this work.
+\
+
+\ this file contains the struct definitions for the following
+\ device tree structures:
+\ device-node
+\ active-package
+\ property
+\ instance
+
+
+struct ( instance )
+ /n field >in.instance-data \ must go first
+ /n field >in.alloced-size \ alloced size
+ /n field >in.device-node
+ /n field >in.my-parent
+ /n field >in.interposed
+ 4 cells field >in.my-unit
+ 2 cells field >in.arguments
+ \ instance-data should be null during packet initialization
+ \ this diverts access to instance variables to the dictionary
+constant inst-node.size
+
+struct ( device node )
+ /n field >dn.isize \ instance size (must go first)
+ /n field >dn.parent
+ /n field >dn.child
+ /n field >dn.peer
+ /n field >dn.properties
+ /n field >dn.methods
+ /n field >dn.priv-methods
+ /n field >dn.#acells
+ /n field >dn.probe-addr
+ inst-node.size field >dn.itemplate
+constant dev-node.size
+
+struct ( property )
+ /n field >prop.next
+ /n field >prop.name
+ /n field >prop.addr
+ /n field >prop.len
+constant prop-node.size
+
+struct ( active package )
+ /n field >ap.device-str
+constant active-package.size
diff --git a/qemu/roms/openbios/forth/device/table.fs b/qemu/roms/openbios/forth/device/table.fs
new file mode 100644
index 000000000..5c58f2d9d
--- /dev/null
+++ b/qemu/roms/openbios/forth/device/table.fs
@@ -0,0 +1,462 @@
+\ tag: FCode table setup
+\
+\ this code implements an fcode evaluator
+\ as described in IEEE 1275-1994
+\
+\ Copyright (C) 2003 Stefan Reinauer
+\
+\ See the file "COPYING" for further information about
+\ the copyright and warranty status of this work.
+\
+
+hex
+
+: undefined-fcode ." undefined fcode word." cr ;
+: reserved-fcode ." reserved fcode word." cr ;
+
+: ['], ( <word> -- )
+ ' ,
+;
+
+: n['], ( n <word> -- )
+ ' swap 0 do
+ dup ,
+ loop
+ drop
+;
+
+\ the table used
+create fcode-master-table
+ ['], end0
+ f n['], reserved-fcode
+ ['], b(lit)
+ ['], b(')
+ ['], b(")
+ ['], bbranch
+ ['], b?branch
+ ['], b(loop)
+ ['], b(+loop)
+ ['], b(do)
+ ['], b(?do)
+ ['], i
+ ['], j
+ ['], b(leave)
+ ['], b(of)
+ ['], execute
+ ['], +
+ ['], -
+ ['], *
+ ['], /
+ ['], mod
+ ['], and
+ ['], or
+ ['], xor
+ ['], invert
+ ['], lshift
+ ['], rshift
+ ['], >>a
+ ['], /mod
+ ['], u/mod
+ ['], negate
+ ['], abs
+ ['], min
+ ['], max
+ ['], >r
+ ['], r>
+ ['], r@
+ ['], exit
+ ['], 0=
+ ['], 0<>
+ ['], 0<
+ ['], 0<=
+ ['], 0>
+ ['], 0>=
+ ['], <
+ ['], >
+ ['], =
+ ['], <>
+ ['], u>
+ ['], u<=
+ ['], u<
+ ['], u>=
+ ['], >=
+ ['], <=
+ ['], between
+ ['], within
+ ['], drop
+ ['], dup
+ ['], over
+ ['], swap
+ ['], rot
+ ['], -rot
+ ['], tuck
+ ['], nip
+ ['], pick
+ ['], roll
+ ['], ?dup
+ ['], depth
+ ['], 2drop
+ ['], 2dup
+ ['], 2over
+ ['], 2swap
+ ['], 2rot
+ ['], 2/
+ ['], u2/
+ ['], 2*
+ ['], /c
+ ['], /w
+ ['], /l
+ ['], /n
+ ['], ca+
+ ['], wa+
+ ['], la+
+ ['], na+
+ ['], char+
+ ['], wa1+
+ ['], la1+
+ ['], cell+
+ ['], chars
+ ['], /w*
+ ['], /l*
+ ['], cells
+ ['], on
+ ['], off
+ ['], +!
+ ['], @
+ ['], l@
+ ['], w@
+ ['], <w@
+ ['], c@
+ ['], !
+ ['], l!
+ ['], w!
+ ['], c!
+ ['], 2@
+ ['], 2!
+ ['], move
+ ['], fill
+ ['], comp
+ ['], noop
+ ['], lwsplit
+ ['], wljoin
+ ['], lbsplit
+ ['], bljoin
+ ['], wbflip
+ ['], upc
+ ['], lcc
+ ['], pack
+ ['], count
+ ['], body>
+ ['], >body
+ ['], fcode-revision
+ ['], span
+ ['], unloop
+ ['], expect
+ ['], alloc-mem
+ ['], free-mem
+ ['], key?
+ ['], key
+ ['], emit
+ ['], type
+ ['], (cr
+ ['], cr
+ ['], #out
+ ['], #line
+ ['], hold
+ ['], <#
+ ['], u#>
+ ['], sign
+ ['], u#
+ ['], u#s
+ ['], u.
+ ['], u.r
+ ['], .
+ ['], .r
+ ['], .s
+ ['], base
+ ['], convert \ reserved (compatibility)
+ ['], $number
+ ['], digit
+ ['], -1
+ ['], 0
+ ['], 1
+ ['], 2
+ ['], 3
+ ['], bl
+ ['], bs
+ ['], bell
+ ['], bounds
+ ['], here
+ ['], aligned
+ ['], wbsplit
+ ['], bwjoin
+ ['], b(<mark)
+ ['], b(>resolve)
+ ['], set-token-table
+ ['], set-table
+ ['], new-token
+ ['], named-token
+ ['], b(:)
+ ['], b(value)
+ ['], b(variable)
+ ['], b(constant)
+ ['], b(create)
+ ['], b(defer)
+ ['], b(buffer:)
+ ['], b(field)
+ ['], b(code)
+ ['], instance
+ ['], reserved-fcode
+ ['], b(;)
+ ['], b(to)
+ ['], b(case)
+ ['], b(endcase)
+ ['], b(endof)
+ ['], #
+ ['], #s
+ ['], #>
+ ['], external-token
+ ['], $find
+ ['], offset16
+ ['], evaluate
+ ['], reserved-fcode
+ ['], reserved-fcode
+ ['], c,
+ ['], w,
+ ['], l,
+ ['], ,
+ ['], um*
+ ['], um/mod
+ ['], reserved-fcode
+ ['], reserved-fcode
+ ['], d+
+ ['], d-
+ ['], get-token
+ ['], set-token
+ ['], state
+ ['], compile,
+ ['], behavior
+ 11 n['], reserved-fcode
+ ['], start0
+ ['], start1
+ ['], start2
+ ['], start4
+ 8 n['], reserved-fcode
+ ['], ferror
+ ['], version1
+ ['], 4-byte-id
+ ['], end1
+ ['], reserved-fcode
+ ['], dma-alloc
+ ['], my-address
+ ['], my-space
+ ['], memmap
+ ['], free-virtual
+ ['], >physical
+ 8 n['], reserved-fcode
+ ['], my-params
+ ['], property
+ ['], encode-int
+ ['], encode+
+ ['], encode-phys
+ ['], encode-string
+ ['], encode-bytes
+ ['], reg
+ ['], intr
+ ['], driver
+ ['], model
+ ['], device-type
+ ['], parse-2int
+ ['], is-install
+ ['], is-remove
+ ['], is-selftest
+ ['], new-device
+ ['], diagnostic-mode?
+ ['], display-status
+ ['], memory-test-suite
+ ['], group-code
+ ['], mask
+ ['], get-msecs
+ ['], ms
+ ['], finish-device
+ ['], decode-phys \ 128
+ ['], push-package
+ ['], pop-package
+ ['], interpose \ extension (recommended practice)
+ 4 n['], reserved-fcode
+ ['], map-low
+ ['], sbus-intr>cpu
+ 1e n['], reserved-fcode
+ ['], #lines
+ ['], #columns
+ ['], line#
+ ['], column#
+ ['], inverse?
+ ['], inverse-screen?
+ ['], frame-buffer-busy?
+ ['], draw-character
+ ['], reset-screen
+ ['], toggle-cursor
+ ['], erase-screen
+ ['], blink-screen
+ ['], invert-screen
+ ['], insert-characters
+ ['], delete-characters
+ ['], insert-lines
+ ['], delete-lines
+ ['], draw-logo
+ ['], frame-buffer-adr
+ ['], screen-height
+ ['], screen-width
+ ['], window-top
+ ['], window-left
+ 3 n['], reserved-fcode
+ ['], default-font
+ ['], set-font
+ ['], char-height
+ ['], char-width
+ ['], >font
+ ['], fontbytes
+ 10 n['], reserved-fcode \ fb1 words
+ ['], fb8-draw-character
+ ['], fb8-reset-screen
+ ['], fb8-toggle-cursor
+ ['], fb8-erase-screen
+ ['], fb8-blink-screen
+ ['], fb8-invert-screen
+ ['], fb8-insert-characters
+ ['], fb8-delete-characters
+ ['], fb8-insert-lines
+ ['], fb8-delete-lines
+ ['], fb8-draw-logo
+ ['], fb8-install
+ 4 n['], reserved-fcode \ reserved
+ 7 n['], reserved-fcode \ VME-bus support
+ 9 n['], reserved-fcode \ reserved
+ ['], return-buffer
+ ['], xmit-packet
+ ['], poll-packet
+ ['], reserved-fcode
+ ['], mac-address
+ 5c n['], reserved-fcode \ 1a5-200 reserved
+ ['], device-name
+ ['], my-args
+ ['], my-self
+ ['], find-package
+ ['], open-package
+ ['], close-package
+ ['], find-method
+ ['], call-package
+ ['], $call-parent
+ ['], my-parent
+ ['], ihandle>phandle
+ ['], reserved-fcode
+ ['], my-unit
+ ['], $call-method
+ ['], $open-package
+ ['], processor-type
+ ['], firmware-version
+ ['], fcode-version
+ ['], alarm
+ ['], (is-user-word)
+ ['], suspend-fcode
+ ['], abort
+ ['], catch
+ ['], throw
+ ['], user-abort
+ ['], get-my-property
+ ['], decode-int
+ ['], decode-string
+ ['], get-inherited-property
+ ['], delete-property
+ ['], get-package-property
+ ['], cpeek
+ ['], wpeek
+ ['], lpeek
+ ['], cpoke
+ ['], wpoke
+ ['], lpoke
+ ['], lwflip
+ ['], lbflip
+ ['], lbflips
+ ['], adr-mask
+ 4 n['], reserved-fcode \ 22a-22d
+64bit? [IF]
+ ['], (rx@)
+ ['], (rx!)
+[ELSE]
+ 2 n['], reserved-fcode \ 22e-22f
+[THEN]
+ ['], rb@
+ ['], rb!
+ ['], rw@
+ ['], rw!
+ ['], rl@
+ ['], rl!
+ ['], wbflips
+ ['], lwflips
+ ['], probe
+ ['], probe-virtual
+ ['], reserved-fcode
+ ['], child
+ ['], peer
+ ['], next-property
+ ['], byte-load
+ ['], set-args
+ ['], left-parse-string \ 240
+64bit? [IF]
+ ['], bxjoin
+ ['], <l@
+ ['], lxjoin
+ ['], wxjoin
+ ['], x,
+ ['], x@
+ ['], x!
+ ['], /x
+ ['], /x*
+\ ['], /xa+
+\ ['], /xa1+
+ ['], xbflip
+ ['], xbflips
+ ['], xbsplit
+ ['], xlflip
+ ['], xlflips
+ ['], xlsplit
+ ['], xwflip
+ ['], xwflips
+ ['], xwsplit
+[ELSE]
+ 7 n['], reserved-fcode \ 241-247 (Part of IEEE1275 64-bit draft standard)
+ ['], /x
+ c n['], reserved-fcode \ 249-254 (Part of IEEE1275 64-bit draft standard)
+[THEN]
+
+
+here fcode-master-table - constant fcode-master-table-size
+
+
+: nreserved ( fcode-table-ptr first last xt -- )
+ -rot 1+ swap do
+ 2dup swap i cells + !
+ loop
+ 2drop
+;
+
+:noname
+ 800 cells alloc-mem to fcode-sys-table
+
+ fcode-sys-table
+ dup 0 5ff ['] reserved-fcode nreserved \ built-in fcodes
+ dup 600 7ff ['] undefined-fcode nreserved \ vendor fcodes
+
+ \ copy built-in fcodes
+ fcode-master-table swap fcode-master-table-size move
+; initializer
+
+: (init-fcode-table) ( -- )
+ fcode-sys-table fcode-table 800 cells move
+ \ clear local fcodes
+ fcode-table 800 fff ['] undefined-fcode nreserved
+;
+
+['] (init-fcode-table) to init-fcode-table
diff --git a/qemu/roms/openbios/forth/device/terminal.fs b/qemu/roms/openbios/forth/device/terminal.fs
new file mode 100644
index 000000000..24b2d10c9
--- /dev/null
+++ b/qemu/roms/openbios/forth/device/terminal.fs
@@ -0,0 +1,302 @@
+\ tag: terminal emulation
+\
+\ this code implements IEEE 1275-1994 ANNEX B
+\
+\ Copyright (C) 2003 Stefan Reinauer
+\
+\ See the file "COPYING" for further information about
+\ the copyright and warranty status of this work.
+\
+
+0 value (escseq)
+10 buffer: (sequence)
+
+: (match-number) ( x y [1|2] [1|2] -- x [z] )
+ 2dup = if \ 1 1 | 2 2
+ drop exit
+ then
+ 2dup > if
+ 2drop drop 1 exit
+ then
+ 2drop 0
+ ;
+
+: (esc-number) ( maxchar -- ?? ?? num )
+ >r depth >r ( R: depth maxchar )
+ 0 (sequence) 2+ (escseq) 2- ( 0 seq+2 seqlen-2 )
+ \ if numerical, scan until non-numerical
+ 0 ?do
+ ( 0 seq+2 )
+ dup i + c@ a
+ digit if
+ ( 0 ptr n )
+ rot a * + ( ptr val )
+ swap
+ else
+ ( 0 ptr asc )
+ ascii ; = if
+ 0 swap
+ else
+ drop leave
+ then
+ then
+
+ loop
+ depth r> - r>
+ 0 to (escseq)
+ (match-number)
+ ;
+
+: (match-seq)
+ (escseq) 1- (sequence) + c@ \ get last character in sequence
+ \ dup draw-character
+ case
+ ascii A of \ CUU - cursor up
+ 1 (esc-number)
+ 0> if
+ 1 max
+ else
+ 1
+ then
+ negate line# +
+ 0 max to line#
+ endof
+ ascii B of \ CUD - cursor down
+ 1 (esc-number)
+ 0> if
+ 1 max
+ line# +
+ #lines 1- min to line#
+ then
+ endof
+ ascii C of \ CUF - cursor forward
+ 1 (esc-number)
+ 0> if
+ 1 max
+ column# +
+ #columns 1- min to column#
+ then
+ endof
+ ascii D of \ CUB - cursor backward
+ 1 (esc-number)
+ 0> if
+ 1 max
+ negate column# +
+ 0 max to column#
+ then
+ endof
+ ascii E of \ Cursor next line (CNL)
+ \ FIXME - check agains ANSI3.64
+ 1 (esc-number)
+ 0> if
+ 1 max
+ line# +
+ #lines 1- min to line#
+ then
+ 0 to column#
+ endof
+ ascii f of
+ 2 (esc-number)
+ case
+ 2 of
+ 1- #columns 1- min to column#
+ 1- #lines 1- min to line#
+ endof
+ 1 of
+ 0 to column#
+ 1- #lines 1- min to line#
+ endof
+ 0 of
+ 0 to column#
+ 0 to line#
+ drop
+ endof
+ endcase
+ endof
+ ascii H of
+ 2 (esc-number)
+ case
+ 2 of
+ 1- #columns 1- min to column#
+ 1- #lines 1- min to line#
+ endof
+ 1 of
+ 0 to column#
+ 1- #lines 1- min to line#
+ endof
+ 0 of
+ 0 to column#
+ 0 to line#
+ drop
+ endof
+ endcase
+ endof
+ ascii J of
+ 0 to (escseq)
+ #columns column# - delete-characters
+ #lines line# - delete-lines
+ endof
+ ascii K of
+ 0 to (escseq)
+ #columns column# - delete-characters
+ endof
+ ascii L of
+ 1 (esc-number)
+ 0> if
+ 1 max
+ insert-lines
+ then
+ endof
+ ascii M of
+ 1 (esc-number)
+ 1 = if
+ 1 max
+ delete-lines
+ then
+ endof
+ ascii @ of
+ 1 (esc-number)
+ 1 = if
+ 1 max
+ insert-characters
+ then
+ endof
+ ascii P of
+ 1 (esc-number)
+ 1 = if
+ 1 max
+ delete-characters
+ then
+ endof
+ ascii m of
+ 1 (esc-number)
+ 1 = if
+ 7 = if
+ true to inverse?
+ else
+ false to inverse?
+ then
+ then
+ endof
+ ascii p of \ normal text colors
+ 0 to (escseq)
+ inverse-screen? if
+ false to inverse-screen?
+ inverse? 0= to inverse?
+ invert-screen
+ then
+ endof
+ ascii q of \ inverse text colors
+ 0 to (escseq)
+ inverse-screen? not if
+ true to inverse-screen?
+ inverse? 0= to inverse?
+ invert-screen
+ then
+ endof
+ ascii s of
+ \ Resets the display device associated with the terminal emulator.
+ 0 to (escseq)
+ reset-screen
+ endof
+ endcase
+ ;
+
+: (term-emit) ( char -- )
+ toggle-cursor
+
+ (escseq) 0> if
+ (escseq) 10 = if
+ 0 to (escseq)
+ ." overflow in esc" cr
+ drop
+ then
+ (escseq) 1 = if
+ dup ascii [ = if \ not a [
+ (sequence) 1+ c!
+ 2 to (escseq)
+ else
+ 0 to (escseq) \ break out of ESC sequence
+ ." out of ESC" cr
+ drop \ don't print breakout character
+ then
+ toggle-cursor exit
+ else
+ (sequence) (escseq) + c!
+ (escseq) 1+ to (escseq)
+ (match-seq)
+ toggle-cursor exit
+ then
+ then
+
+ case
+ 0 of \ NULL
+ toggle-cursor exit
+ endof
+ 7 of \ BEL
+ blink-screen
+ s" /screen" s" ring-bell"
+ execute-device-method
+ endof
+ 8 of \ BS
+ column# 0<> if
+ column# 1- to column#
+ toggle-cursor exit
+ then
+ endof
+ 9 of \ TAB
+ column# dup #columns = if
+ drop
+ else
+ 8 + -8 and ff and to column#
+ then
+ toggle-cursor exit
+ endof
+ a of \ LF
+ line# 1+ to line#
+ 0 to column#
+ line# #lines >= if
+ 0 to line#
+ 1 delete-lines
+ #lines 1- to line#
+ toggle-cursor exit
+ then
+ endof
+ b of \ VT
+ line# 0<> if
+ line# 1- to line#
+ then
+ toggle-cursor exit
+ endof
+ c of \ FF
+ 0 to column# 0 to line#
+ erase-screen
+ endof
+ d of \ CR
+ 0 to column#
+ toggle-cursor exit
+ endof
+ 1b of \ ESC
+ 1b (sequence) c!
+ 1 to (escseq)
+ endof
+
+ \ draw character and advance position
+ column# #columns >= if
+ 0 to column#
+ line# 1+ to line#
+ line# #lines >= if
+ 0 to line#
+ 1 delete-lines
+ #lines 1- to line#
+ then
+ then
+
+ dup draw-character
+ column# 1+ to column#
+
+ endcase
+ toggle-cursor
+ ;
+
+['] (term-emit) to fb-emit
diff --git a/qemu/roms/openbios/forth/device/tree.fs b/qemu/roms/openbios/forth/device/tree.fs
new file mode 100644
index 000000000..04f85b5c1
--- /dev/null
+++ b/qemu/roms/openbios/forth/device/tree.fs
@@ -0,0 +1,59 @@
+\ tag: Device Tree
+\
+\ this code implements IEEE 1275-1994 ch. 3.5
+\
+\ Copyright (C) 2003 Stefan Reinauer
+\
+\ See the file "COPYING" for further information about
+\ the copyright and warranty status of this work.
+\
+
+
+\ root node
+new-device
+ " OpenBiosTeam,OpenBIOS" device-name
+ 1 encode-int " #address-cells" property
+ : open true ;
+ : close ;
+ : decode-unit parse-hex ;
+ : encode-unit ( addr -- str len )
+ pocket tohexstr
+ ;
+
+new-device
+ " aliases" device-name
+ : open true ;
+ : close ;
+finish-device
+
+new-device
+ " openprom" device-name
+ " BootROM" device-type
+ " OpenFirmware 3" model
+ 0 0 " relative-addressing" property
+ 0 0 " supports-bootinfo" property
+ 1 encode-int " boot-syntax" property
+
+ : selftest
+ ." OpenBIOS selftest... succeded" cr
+ true
+ ;
+ : open true ;
+ : close ;
+
+finish-device
+
+new-device
+ " options" device-name
+finish-device
+
+new-device
+ " chosen" device-name
+ 0 encode-int " stdin" property
+ 0 encode-int " stdout" property
+ \ " hda1:/boot/vmunix" encode-string " bootpath" property
+ \ " -as" encode-string " bootargs" property
+finish-device
+
+\ END
+finish-device