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