diff options
Diffstat (limited to 'qemu/roms/openbios/forth/device')
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 Binary files differnew file mode 100644 index 000000000..0b60b6fb4 --- /dev/null +++ b/qemu/roms/openbios/forth/device/romfont.bin diff --git a/qemu/roms/openbios/forth/device/structures.fs b/qemu/roms/openbios/forth/device/structures.fs new file mode 100644 index 000000000..14dd881e5 --- /dev/null +++ b/qemu/roms/openbios/forth/device/structures.fs @@ -0,0 +1,54 @@ +\ tag: device interface structures +\ +\ this code implements data structures used by the +\ IEEE 1275-1994 Open Firmware Device Interface. +\ +\ Copyright (C) 2003 Stefan Reinauer +\ +\ See the file "COPYING" for further information about +\ the copyright and warranty status of this work. +\ + +\ this file contains the struct definitions for the following +\ device tree structures: +\ device-node +\ active-package +\ property +\ instance + + +struct ( instance ) + /n field >in.instance-data \ must go first + /n field >in.alloced-size \ alloced size + /n field >in.device-node + /n field >in.my-parent + /n field >in.interposed + 4 cells field >in.my-unit + 2 cells field >in.arguments + \ instance-data should be null during packet initialization + \ this diverts access to instance variables to the dictionary +constant inst-node.size + +struct ( device node ) + /n field >dn.isize \ instance size (must go first) + /n field >dn.parent + /n field >dn.child + /n field >dn.peer + /n field >dn.properties + /n field >dn.methods + /n field >dn.priv-methods + /n field >dn.#acells + /n field >dn.probe-addr + inst-node.size field >dn.itemplate +constant dev-node.size + +struct ( property ) + /n field >prop.next + /n field >prop.name + /n field >prop.addr + /n field >prop.len +constant prop-node.size + +struct ( active package ) + /n field >ap.device-str +constant active-package.size diff --git a/qemu/roms/openbios/forth/device/table.fs b/qemu/roms/openbios/forth/device/table.fs new file mode 100644 index 000000000..5c58f2d9d --- /dev/null +++ b/qemu/roms/openbios/forth/device/table.fs @@ -0,0 +1,462 @@ +\ tag: FCode table setup +\ +\ this code implements an fcode evaluator +\ as described in IEEE 1275-1994 +\ +\ Copyright (C) 2003 Stefan Reinauer +\ +\ See the file "COPYING" for further information about +\ the copyright and warranty status of this work. +\ + +hex + +: undefined-fcode ." undefined fcode word." cr ; +: reserved-fcode ." reserved fcode word." cr ; + +: ['], ( <word> -- ) + ' , +; + +: n['], ( n <word> -- ) + ' swap 0 do + dup , + loop + drop +; + +\ the table used +create fcode-master-table + ['], end0 + f n['], reserved-fcode + ['], b(lit) + ['], b(') + ['], b(") + ['], bbranch + ['], b?branch + ['], b(loop) + ['], b(+loop) + ['], b(do) + ['], b(?do) + ['], i + ['], j + ['], b(leave) + ['], b(of) + ['], execute + ['], + + ['], - + ['], * + ['], / + ['], mod + ['], and + ['], or + ['], xor + ['], invert + ['], lshift + ['], rshift + ['], >>a + ['], /mod + ['], u/mod + ['], negate + ['], abs + ['], min + ['], max + ['], >r + ['], r> + ['], r@ + ['], exit + ['], 0= + ['], 0<> + ['], 0< + ['], 0<= + ['], 0> + ['], 0>= + ['], < + ['], > + ['], = + ['], <> + ['], u> + ['], u<= + ['], u< + ['], u>= + ['], >= + ['], <= + ['], between + ['], within + ['], drop + ['], dup + ['], over + ['], swap + ['], rot + ['], -rot + ['], tuck + ['], nip + ['], pick + ['], roll + ['], ?dup + ['], depth + ['], 2drop + ['], 2dup + ['], 2over + ['], 2swap + ['], 2rot + ['], 2/ + ['], u2/ + ['], 2* + ['], /c + ['], /w + ['], /l + ['], /n + ['], ca+ + ['], wa+ + ['], la+ + ['], na+ + ['], char+ + ['], wa1+ + ['], la1+ + ['], cell+ + ['], chars + ['], /w* + ['], /l* + ['], cells + ['], on + ['], off + ['], +! + ['], @ + ['], l@ + ['], w@ + ['], <w@ + ['], c@ + ['], ! + ['], l! + ['], w! + ['], c! + ['], 2@ + ['], 2! + ['], move + ['], fill + ['], comp + ['], noop + ['], lwsplit + ['], wljoin + ['], lbsplit + ['], bljoin + ['], wbflip + ['], upc + ['], lcc + ['], pack + ['], count + ['], body> + ['], >body + ['], fcode-revision + ['], span + ['], unloop + ['], expect + ['], alloc-mem + ['], free-mem + ['], key? + ['], key + ['], emit + ['], type + ['], (cr + ['], cr + ['], #out + ['], #line + ['], hold + ['], <# + ['], u#> + ['], sign + ['], u# + ['], u#s + ['], u. + ['], u.r + ['], . + ['], .r + ['], .s + ['], base + ['], convert \ reserved (compatibility) + ['], $number + ['], digit + ['], -1 + ['], 0 + ['], 1 + ['], 2 + ['], 3 + ['], bl + ['], bs + ['], bell + ['], bounds + ['], here + ['], aligned + ['], wbsplit + ['], bwjoin + ['], b(<mark) + ['], b(>resolve) + ['], set-token-table + ['], set-table + ['], new-token + ['], named-token + ['], b(:) + ['], b(value) + ['], b(variable) + ['], b(constant) + ['], b(create) + ['], b(defer) + ['], b(buffer:) + ['], b(field) + ['], b(code) + ['], instance + ['], reserved-fcode + ['], b(;) + ['], b(to) + ['], b(case) + ['], b(endcase) + ['], b(endof) + ['], # + ['], #s + ['], #> + ['], external-token + ['], $find + ['], offset16 + ['], evaluate + ['], reserved-fcode + ['], reserved-fcode + ['], c, + ['], w, + ['], l, + ['], , + ['], um* + ['], um/mod + ['], reserved-fcode + ['], reserved-fcode + ['], d+ + ['], d- + ['], get-token + ['], set-token + ['], state + ['], compile, + ['], behavior + 11 n['], reserved-fcode + ['], start0 + ['], start1 + ['], start2 + ['], start4 + 8 n['], reserved-fcode + ['], ferror + ['], version1 + ['], 4-byte-id + ['], end1 + ['], reserved-fcode + ['], dma-alloc + ['], my-address + ['], my-space + ['], memmap + ['], free-virtual + ['], >physical + 8 n['], reserved-fcode + ['], my-params + ['], property + ['], encode-int + ['], encode+ + ['], encode-phys + ['], encode-string + ['], encode-bytes + ['], reg + ['], intr + ['], driver + ['], model + ['], device-type + ['], parse-2int + ['], is-install + ['], is-remove + ['], is-selftest + ['], new-device + ['], diagnostic-mode? + ['], display-status + ['], memory-test-suite + ['], group-code + ['], mask + ['], get-msecs + ['], ms + ['], finish-device + ['], decode-phys \ 128 + ['], push-package + ['], pop-package + ['], interpose \ extension (recommended practice) + 4 n['], reserved-fcode + ['], map-low + ['], sbus-intr>cpu + 1e n['], reserved-fcode + ['], #lines + ['], #columns + ['], line# + ['], column# + ['], inverse? + ['], inverse-screen? + ['], frame-buffer-busy? + ['], draw-character + ['], reset-screen + ['], toggle-cursor + ['], erase-screen + ['], blink-screen + ['], invert-screen + ['], insert-characters + ['], delete-characters + ['], insert-lines + ['], delete-lines + ['], draw-logo + ['], frame-buffer-adr + ['], screen-height + ['], screen-width + ['], window-top + ['], window-left + 3 n['], reserved-fcode + ['], default-font + ['], set-font + ['], char-height + ['], char-width + ['], >font + ['], fontbytes + 10 n['], reserved-fcode \ fb1 words + ['], fb8-draw-character + ['], fb8-reset-screen + ['], fb8-toggle-cursor + ['], fb8-erase-screen + ['], fb8-blink-screen + ['], fb8-invert-screen + ['], fb8-insert-characters + ['], fb8-delete-characters + ['], fb8-insert-lines + ['], fb8-delete-lines + ['], fb8-draw-logo + ['], fb8-install + 4 n['], reserved-fcode \ reserved + 7 n['], reserved-fcode \ VME-bus support + 9 n['], reserved-fcode \ reserved + ['], return-buffer + ['], xmit-packet + ['], poll-packet + ['], reserved-fcode + ['], mac-address + 5c n['], reserved-fcode \ 1a5-200 reserved + ['], device-name + ['], my-args + ['], my-self + ['], find-package + ['], open-package + ['], close-package + ['], find-method + ['], call-package + ['], $call-parent + ['], my-parent + ['], ihandle>phandle + ['], reserved-fcode + ['], my-unit + ['], $call-method + ['], $open-package + ['], processor-type + ['], firmware-version + ['], fcode-version + ['], alarm + ['], (is-user-word) + ['], suspend-fcode + ['], abort + ['], catch + ['], throw + ['], user-abort + ['], get-my-property + ['], decode-int + ['], decode-string + ['], get-inherited-property + ['], delete-property + ['], get-package-property + ['], cpeek + ['], wpeek + ['], lpeek + ['], cpoke + ['], wpoke + ['], lpoke + ['], lwflip + ['], lbflip + ['], lbflips + ['], adr-mask + 4 n['], reserved-fcode \ 22a-22d +64bit? [IF] + ['], (rx@) + ['], (rx!) +[ELSE] + 2 n['], reserved-fcode \ 22e-22f +[THEN] + ['], rb@ + ['], rb! + ['], rw@ + ['], rw! + ['], rl@ + ['], rl! + ['], wbflips + ['], lwflips + ['], probe + ['], probe-virtual + ['], reserved-fcode + ['], child + ['], peer + ['], next-property + ['], byte-load + ['], set-args + ['], left-parse-string \ 240 +64bit? [IF] + ['], bxjoin + ['], <l@ + ['], lxjoin + ['], wxjoin + ['], x, + ['], x@ + ['], x! + ['], /x + ['], /x* +\ ['], /xa+ +\ ['], /xa1+ + ['], xbflip + ['], xbflips + ['], xbsplit + ['], xlflip + ['], xlflips + ['], xlsplit + ['], xwflip + ['], xwflips + ['], xwsplit +[ELSE] + 7 n['], reserved-fcode \ 241-247 (Part of IEEE1275 64-bit draft standard) + ['], /x + c n['], reserved-fcode \ 249-254 (Part of IEEE1275 64-bit draft standard) +[THEN] + + +here fcode-master-table - constant fcode-master-table-size + + +: nreserved ( fcode-table-ptr first last xt -- ) + -rot 1+ swap do + 2dup swap i cells + ! + loop + 2drop +; + +:noname + 800 cells alloc-mem to fcode-sys-table + + fcode-sys-table + dup 0 5ff ['] reserved-fcode nreserved \ built-in fcodes + dup 600 7ff ['] undefined-fcode nreserved \ vendor fcodes + + \ copy built-in fcodes + fcode-master-table swap fcode-master-table-size move +; initializer + +: (init-fcode-table) ( -- ) + fcode-sys-table fcode-table 800 cells move + \ clear local fcodes + fcode-table 800 fff ['] undefined-fcode nreserved +; + +['] (init-fcode-table) to init-fcode-table diff --git a/qemu/roms/openbios/forth/device/terminal.fs b/qemu/roms/openbios/forth/device/terminal.fs new file mode 100644 index 000000000..24b2d10c9 --- /dev/null +++ b/qemu/roms/openbios/forth/device/terminal.fs @@ -0,0 +1,302 @@ +\ tag: terminal emulation +\ +\ this code implements IEEE 1275-1994 ANNEX B +\ +\ Copyright (C) 2003 Stefan Reinauer +\ +\ See the file "COPYING" for further information about +\ the copyright and warranty status of this work. +\ + +0 value (escseq) +10 buffer: (sequence) + +: (match-number) ( x y [1|2] [1|2] -- x [z] ) + 2dup = if \ 1 1 | 2 2 + drop exit + then + 2dup > if + 2drop drop 1 exit + then + 2drop 0 + ; + +: (esc-number) ( maxchar -- ?? ?? num ) + >r depth >r ( R: depth maxchar ) + 0 (sequence) 2+ (escseq) 2- ( 0 seq+2 seqlen-2 ) + \ if numerical, scan until non-numerical + 0 ?do + ( 0 seq+2 ) + dup i + c@ a + digit if + ( 0 ptr n ) + rot a * + ( ptr val ) + swap + else + ( 0 ptr asc ) + ascii ; = if + 0 swap + else + drop leave + then + then + + loop + depth r> - r> + 0 to (escseq) + (match-number) + ; + +: (match-seq) + (escseq) 1- (sequence) + c@ \ get last character in sequence + \ dup draw-character + case + ascii A of \ CUU - cursor up + 1 (esc-number) + 0> if + 1 max + else + 1 + then + negate line# + + 0 max to line# + endof + ascii B of \ CUD - cursor down + 1 (esc-number) + 0> if + 1 max + line# + + #lines 1- min to line# + then + endof + ascii C of \ CUF - cursor forward + 1 (esc-number) + 0> if + 1 max + column# + + #columns 1- min to column# + then + endof + ascii D of \ CUB - cursor backward + 1 (esc-number) + 0> if + 1 max + negate column# + + 0 max to column# + then + endof + ascii E of \ Cursor next line (CNL) + \ FIXME - check agains ANSI3.64 + 1 (esc-number) + 0> if + 1 max + line# + + #lines 1- min to line# + then + 0 to column# + endof + ascii f of + 2 (esc-number) + case + 2 of + 1- #columns 1- min to column# + 1- #lines 1- min to line# + endof + 1 of + 0 to column# + 1- #lines 1- min to line# + endof + 0 of + 0 to column# + 0 to line# + drop + endof + endcase + endof + ascii H of + 2 (esc-number) + case + 2 of + 1- #columns 1- min to column# + 1- #lines 1- min to line# + endof + 1 of + 0 to column# + 1- #lines 1- min to line# + endof + 0 of + 0 to column# + 0 to line# + drop + endof + endcase + endof + ascii J of + 0 to (escseq) + #columns column# - delete-characters + #lines line# - delete-lines + endof + ascii K of + 0 to (escseq) + #columns column# - delete-characters + endof + ascii L of + 1 (esc-number) + 0> if + 1 max + insert-lines + then + endof + ascii M of + 1 (esc-number) + 1 = if + 1 max + delete-lines + then + endof + ascii @ of + 1 (esc-number) + 1 = if + 1 max + insert-characters + then + endof + ascii P of + 1 (esc-number) + 1 = if + 1 max + delete-characters + then + endof + ascii m of + 1 (esc-number) + 1 = if + 7 = if + true to inverse? + else + false to inverse? + then + then + endof + ascii p of \ normal text colors + 0 to (escseq) + inverse-screen? if + false to inverse-screen? + inverse? 0= to inverse? + invert-screen + then + endof + ascii q of \ inverse text colors + 0 to (escseq) + inverse-screen? not if + true to inverse-screen? + inverse? 0= to inverse? + invert-screen + then + endof + ascii s of + \ Resets the display device associated with the terminal emulator. + 0 to (escseq) + reset-screen + endof + endcase + ; + +: (term-emit) ( char -- ) + toggle-cursor + + (escseq) 0> if + (escseq) 10 = if + 0 to (escseq) + ." overflow in esc" cr + drop + then + (escseq) 1 = if + dup ascii [ = if \ not a [ + (sequence) 1+ c! + 2 to (escseq) + else + 0 to (escseq) \ break out of ESC sequence + ." out of ESC" cr + drop \ don't print breakout character + then + toggle-cursor exit + else + (sequence) (escseq) + c! + (escseq) 1+ to (escseq) + (match-seq) + toggle-cursor exit + then + then + + case + 0 of \ NULL + toggle-cursor exit + endof + 7 of \ BEL + blink-screen + s" /screen" s" ring-bell" + execute-device-method + endof + 8 of \ BS + column# 0<> if + column# 1- to column# + toggle-cursor exit + then + endof + 9 of \ TAB + column# dup #columns = if + drop + else + 8 + -8 and ff and to column# + then + toggle-cursor exit + endof + a of \ LF + line# 1+ to line# + 0 to column# + line# #lines >= if + 0 to line# + 1 delete-lines + #lines 1- to line# + toggle-cursor exit + then + endof + b of \ VT + line# 0<> if + line# 1- to line# + then + toggle-cursor exit + endof + c of \ FF + 0 to column# 0 to line# + erase-screen + endof + d of \ CR + 0 to column# + toggle-cursor exit + endof + 1b of \ ESC + 1b (sequence) c! + 1 to (escseq) + endof + + \ draw character and advance position + column# #columns >= if + 0 to column# + line# 1+ to line# + line# #lines >= if + 0 to line# + 1 delete-lines + #lines 1- to line# + then + then + + dup draw-character + column# 1+ to column# + + endcase + toggle-cursor + ; + +['] (term-emit) to fb-emit diff --git a/qemu/roms/openbios/forth/device/tree.fs b/qemu/roms/openbios/forth/device/tree.fs new file mode 100644 index 000000000..04f85b5c1 --- /dev/null +++ b/qemu/roms/openbios/forth/device/tree.fs @@ -0,0 +1,59 @@ +\ tag: Device Tree +\ +\ this code implements IEEE 1275-1994 ch. 3.5 +\ +\ Copyright (C) 2003 Stefan Reinauer +\ +\ See the file "COPYING" for further information about +\ the copyright and warranty status of this work. +\ + + +\ root node +new-device + " OpenBiosTeam,OpenBIOS" device-name + 1 encode-int " #address-cells" property + : open true ; + : close ; + : decode-unit parse-hex ; + : encode-unit ( addr -- str len ) + pocket tohexstr + ; + +new-device + " aliases" device-name + : open true ; + : close ; +finish-device + +new-device + " openprom" device-name + " BootROM" device-type + " OpenFirmware 3" model + 0 0 " relative-addressing" property + 0 0 " supports-bootinfo" property + 1 encode-int " boot-syntax" property + + : selftest + ." OpenBIOS selftest... succeded" cr + true + ; + : open true ; + : close ; + +finish-device + +new-device + " options" device-name +finish-device + +new-device + " chosen" device-name + 0 encode-int " stdin" property + 0 encode-int " stdout" property + \ " hda1:/boot/vmunix" encode-string " bootpath" property + \ " -as" encode-string " bootargs" property +finish-device + +\ END +finish-device |