summaryrefslogtreecommitdiffstats
path: root/qemu/roms/SLOF/slof/fs
diff options
context:
space:
mode:
Diffstat (limited to 'qemu/roms/SLOF/slof/fs')
-rw-r--r--qemu/roms/SLOF/slof/fs/accept.fs410
-rw-r--r--qemu/roms/SLOF/slof/fs/alloc-mem-debug.fs116
-rw-r--r--qemu/roms/SLOF/slof/fs/alloc-mem.fs75
-rw-r--r--qemu/roms/SLOF/slof/fs/archsupport.fs38
-rw-r--r--qemu/roms/SLOF/slof/fs/available.fs72
-rw-r--r--qemu/roms/SLOF/slof/fs/banner.fs23
-rw-r--r--qemu/roms/SLOF/slof/fs/base.fs611
-rw-r--r--qemu/roms/SLOF/slof/fs/boot.fs300
-rw-r--r--qemu/roms/SLOF/slof/fs/bootmsg.fs74
-rw-r--r--qemu/roms/SLOF/slof/fs/claim.fs415
-rw-r--r--qemu/roms/SLOF/slof/fs/client.fs299
-rw-r--r--qemu/roms/SLOF/slof/fs/debug.fs422
-rw-r--r--qemu/roms/SLOF/slof/fs/devices/pci-class_02.fs37
-rw-r--r--qemu/roms/SLOF/slof/fs/devices/pci-class_0c.fs71
-rw-r--r--qemu/roms/SLOF/slof/fs/devices/pci-device_10de_0141.fs49
-rw-r--r--qemu/roms/SLOF/slof/fs/dictionary.fs74
-rw-r--r--qemu/roms/SLOF/slof/fs/display.fs123
-rw-r--r--qemu/roms/SLOF/slof/fs/dma-function.fs36
-rw-r--r--qemu/roms/SLOF/slof/fs/dump.fs42
-rw-r--r--qemu/roms/SLOF/slof/fs/elf.fs71
-rw-r--r--qemu/roms/SLOF/slof/fs/envvar.fs412
-rw-r--r--qemu/roms/SLOF/slof/fs/envvar_defaults.fs44
-rw-r--r--qemu/roms/SLOF/slof/fs/exception.fs154
-rw-r--r--qemu/roms/SLOF/slof/fs/fbuffer.fs264
-rw-r--r--qemu/roms/SLOF/slof/fs/fcode/1275.fs465
-rw-r--r--qemu/roms/SLOF/slof/fs/fcode/core.fs173
-rw-r--r--qemu/roms/SLOF/slof/fs/fcode/evaluator.fs119
-rw-r--r--qemu/roms/SLOF/slof/fs/fcode/little-big.fs96
-rw-r--r--qemu/roms/SLOF/slof/fs/fcode/locals.fs155
-rw-r--r--qemu/roms/SLOF/slof/fs/fcode/tokens.fs480
-rw-r--r--qemu/roms/SLOF/slof/fs/find-hash.fs77
-rw-r--r--qemu/roms/SLOF/slof/fs/generic-disk.fs68
-rw-r--r--qemu/roms/SLOF/slof/fs/graphics.fs87
-rw-r--r--qemu/roms/SLOF/slof/fs/history.fs107
-rw-r--r--qemu/roms/SLOF/slof/fs/ide.fs612
-rw-r--r--qemu/roms/SLOF/slof/fs/instance.fs193
-rw-r--r--qemu/roms/SLOF/slof/fs/little-endian.fs77
-rw-r--r--qemu/roms/SLOF/slof/fs/loaders.fs94
-rw-r--r--qemu/roms/SLOF/slof/fs/logging.fs45
-rw-r--r--qemu/roms/SLOF/slof/fs/node.fs766
-rw-r--r--qemu/roms/SLOF/slof/fs/nvram.fs182
-rw-r--r--qemu/roms/SLOF/slof/fs/packages.fs52
-rw-r--r--qemu/roms/SLOF/slof/fs/packages/deblocker.fs70
-rw-r--r--qemu/roms/SLOF/slof/fs/packages/disk-label.fs660
-rw-r--r--qemu/roms/SLOF/slof/fs/packages/ext2-files.fs188
-rw-r--r--qemu/roms/SLOF/slof/fs/packages/fat-files.fs188
-rw-r--r--qemu/roms/SLOF/slof/fs/packages/filler.fs21
-rw-r--r--qemu/roms/SLOF/slof/fs/packages/iso-9660.fs325
-rw-r--r--qemu/roms/SLOF/slof/fs/packages/obp-tftp.fs71
-rw-r--r--qemu/roms/SLOF/slof/fs/packages/rom-files.fs85
-rw-r--r--qemu/roms/SLOF/slof/fs/packages/sms.fs29
-rw-r--r--qemu/roms/SLOF/slof/fs/pci-bridge.fs65
-rw-r--r--qemu/roms/SLOF/slof/fs/pci-class-code-names.fs264
-rw-r--r--qemu/roms/SLOF/slof/fs/pci-config-bridge.fs111
-rw-r--r--qemu/roms/SLOF/slof/fs/pci-device.fs105
-rw-r--r--qemu/roms/SLOF/slof/fs/pci-helper.fs195
-rw-r--r--qemu/roms/SLOF/slof/fs/pci-properties.fs668
-rw-r--r--qemu/roms/SLOF/slof/fs/pci-scan.fs344
-rw-r--r--qemu/roms/SLOF/slof/fs/preprocessor.fs41
-rw-r--r--qemu/roms/SLOF/slof/fs/property.fs192
-rw-r--r--qemu/roms/SLOF/slof/fs/quiesce.fs58
-rw-r--r--qemu/roms/SLOF/slof/fs/rmove.fs53
-rw-r--r--qemu/roms/SLOF/slof/fs/romfs.fs123
-rw-r--r--qemu/roms/SLOF/slof/fs/root.fs84
-rw-r--r--qemu/roms/SLOF/slof/fs/rtas/rtas-cpu.fs23
-rw-r--r--qemu/roms/SLOF/slof/fs/rtas/rtas-flash.fs46
-rw-r--r--qemu/roms/SLOF/slof/fs/rtas/rtas-init.fs121
-rw-r--r--qemu/roms/SLOF/slof/fs/rtas/rtas-reboot.fs33
-rw-r--r--qemu/roms/SLOF/slof/fs/rtas/rtas-vpd.fs33
-rw-r--r--qemu/roms/SLOF/slof/fs/scsi-disk.fs324
-rw-r--r--qemu/roms/SLOF/slof/fs/scsi-host-helpers.fs127
-rw-r--r--qemu/roms/SLOF/slof/fs/scsi-loader.fs77
-rw-r--r--qemu/roms/SLOF/slof/fs/scsi-probe-helpers.fs95
-rw-r--r--qemu/roms/SLOF/slof/fs/scsi-support.fs847
-rw-r--r--qemu/roms/SLOF/slof/fs/search.fs89
-rw-r--r--qemu/roms/SLOF/slof/fs/slof-logo.fs20
-rw-r--r--qemu/roms/SLOF/slof/fs/sms/sms-load.fs70
-rw-r--r--qemu/roms/SLOF/slof/fs/sms/sms-nvram.fs124
-rw-r--r--qemu/roms/SLOF/slof/fs/stack.fs57
-rw-r--r--qemu/roms/SLOF/slof/fs/start-up.fs171
-rw-r--r--qemu/roms/SLOF/slof/fs/term-io.fs97
-rw-r--r--qemu/roms/SLOF/slof/fs/terminal.fs212
-rw-r--r--qemu/roms/SLOF/slof/fs/timebase.fs24
-rw-r--r--qemu/roms/SLOF/slof/fs/translate.fs150
-rw-r--r--qemu/roms/SLOF/slof/fs/update_flash.fs110
-rw-r--r--qemu/roms/SLOF/slof/fs/usb/dev-hci.fs71
-rw-r--r--qemu/roms/SLOF/slof/fs/usb/dev-hub.fs32
-rw-r--r--qemu/roms/SLOF/slof/fs/usb/dev-keyb.fs54
-rw-r--r--qemu/roms/SLOF/slof/fs/usb/dev-mouse.fs20
-rw-r--r--qemu/roms/SLOF/slof/fs/usb/dev-parent-calls.fs15
-rw-r--r--qemu/roms/SLOF/slof/fs/usb/dev-storage.fs361
-rw-r--r--qemu/roms/SLOF/slof/fs/usb/slofdev.fs8
-rw-r--r--qemu/roms/SLOF/slof/fs/usb/usb-static.fs70
-rw-r--r--qemu/roms/SLOF/slof/fs/vpd-bootlist.fs134
-rw-r--r--qemu/roms/SLOF/slof/fs/xmodem.fs120
95 files changed, 15755 insertions, 0 deletions
diff --git a/qemu/roms/SLOF/slof/fs/accept.fs b/qemu/roms/SLOF/slof/fs/accept.fs
new file mode 100644
index 000000000..7e8e2717e
--- /dev/null
+++ b/qemu/roms/SLOF/slof/fs/accept.fs
@@ -0,0 +1,410 @@
+\ *****************************************************************************
+\ * Copyright (c) 2004, 2008 IBM Corporation
+\ * All rights reserved.
+\ * This program and the accompanying materials
+\ * are made available under the terms of the BSD License
+\ * which accompanies this distribution, and is available at
+\ * http://www.opensource.org/licenses/bsd-license.php
+\ *
+\ * Contributors:
+\ * IBM Corporation - initial implementation
+\ ****************************************************************************/
+
+
+\ Implementation of ACCEPT. Using ECMA-48 for terminal control.
+
+: beep bell emit ;
+
+: TABLE-EXECUTE
+ CREATE DOES> swap cells+ @ ?dup IF execute ELSE beep THEN ;
+
+0 VALUE accept-adr
+0 VALUE accept-max
+0 VALUE accept-len
+0 VALUE accept-cur
+
+: esc 1b emit ;
+: csi esc 5b emit ;
+
+: move-cursor ( -- )
+ esc ." 8" accept-cur IF
+ csi base @ decimal accept-cur 0 .r base ! ." C"
+ THEN
+;
+
+: redraw-line ( -- )
+ accept-cur accept-len = IF EXIT THEN
+ move-cursor
+ accept-adr accept-len accept-cur /string type
+ csi ." K" move-cursor
+;
+
+: full-redraw-line ( -- )
+ accept-cur 0 to accept-cur move-cursor
+ accept-adr accept-len type
+ csi ." K" to accept-cur move-cursor
+;
+
+: redraw-prompt ( -- )
+ cr depth . [char] > emit
+;
+
+: insert-char ( char -- )
+ accept-len accept-max = IF drop beep EXIT THEN
+ accept-cur accept-len <> IF csi ." @" dup emit
+ accept-adr accept-cur + dup 1+ accept-len accept-cur - move
+ ELSE dup emit THEN
+ accept-adr accept-cur + c!
+ accept-cur 1+ to accept-cur
+ accept-len 1+ to accept-len redraw-line
+;
+
+: delete-char ( -- )
+ accept-cur accept-len = IF beep EXIT THEN
+ accept-len 1- to accept-len
+ accept-adr accept-cur + dup 1+ swap accept-len accept-cur - move
+ csi ." P" redraw-line
+;
+
+\ *
+\ * History handling
+\ *
+
+STRUCT
+cell FIELD his>next
+cell FIELD his>prev
+cell FIELD his>len
+ 0 FIELD his>buf
+CONSTANT /his
+0 VALUE his-head
+0 VALUE his-tail
+0 VALUE his-cur
+
+: add-history ( -- )
+ accept-len 0= IF EXIT THEN
+ /his accept-len + alloc-mem
+ his-tail IF dup his-tail his>next ! ELSE dup to his-head THEN
+ his-tail over his>prev ! 0 over his>next ! dup to his-tail
+ accept-len over his>len ! accept-adr swap his>buf accept-len move
+;
+
+: history ( -- )
+ his-head BEGIN dup WHILE
+ cr dup his>buf over his>len @ type
+ his>next @ REPEAT drop
+;
+
+: select-history ( his -- )
+ dup to his-cur dup IF
+ dup his>len @ accept-max min dup to accept-len to accept-cur
+ his>buf accept-adr accept-len move ELSE
+ drop 0 to accept-len 0 to accept-cur THEN
+ full-redraw-line
+;
+
+
+\
+\ tab completion
+\
+
+\ tab completion state variables
+0 value ?tab-pressed
+0 value tab-last-adr
+0 value tab-last-len
+
+\ compares two strings and returns the longest equal substring.
+: $same-string ( addr-1 len-1 addr-2 len-2 -- addr-1 len-1' )
+ dup 0= IF \ The second parameter is not a string.
+ 2drop EXIT \ bail out
+ THEN
+ rot min 0 0 -rot ( addr1 addr2 0 len' 0 )
+ DO ( addr1 addr2 len-1' )
+ 2 pick i + c@ lcc
+ 2 pick i + c@ lcc
+ = IF 1 + ELSE leave THEN
+ LOOP
+ nip
+;
+
+: $tab-sift-words ( text-addr text-len -- sift-count )
+ sift-compl-only >r true to sift-compl-only \ save sifting mode
+
+ last BEGIN @ ?dup WHILE \ loop over all words
+ $inner-sift IF \ any completions possible?
+ \ convert to lower case for user interface sanity
+ 2dup bounds DO I c@ lcc I c! LOOP
+ ?tab-pressed IF 2dup type space THEN \ <tab><tab> prints possibilities
+ tab-last-adr tab-last-len $same-string \ find matching substring ...
+ to tab-last-len to tab-last-adr \ ... and save it
+ THEN
+ repeat
+ 2drop
+
+ #sift-count 0 to #sift-count \ how many words were found?
+ r> to sift-compl-only \ restore sifting completion mode
+;
+
+\ 8< node sifting for tab completion on device tree nodes below this line 8<
+
+#include <stack.fs>
+
+10 new-stack device-stack
+
+: (next-dev) ( node -- node' addr len )
+ device-stack
+ dup (node>path) rot
+ dup child IF dup push child -rot EXIT THEN
+ dup peer IF peer -rot EXIT THEN
+ drop
+ BEGIN
+ stack-depth
+ WHILE
+ pop peer ?dup IF -rot EXIT THEN
+ REPEAT
+ 0 -rot
+;
+
+: $inner-sift-nodes ( text-addr text-len node -- ... path-addr path-len true | false )
+ (next-dev) ( text-addr text-len node' path-addr path-len )
+ dup 0= IF drop false EXIT THEN
+ 2dup 6 pick 6 pick find-isubstr ( text-addr text-len node' path-addr path-len pos )
+ 0= IF
+ #sift-count 1+ to #sift-count \ count completions
+ true
+ ELSE
+ 2drop false
+ THEN
+;
+
+\
+\ test function for (next-dev)
+: .nodes ( -- )
+ s" /" find-node BEGIN dup WHILE
+ (next-dev)
+ type cr
+ REPEAT
+ drop
+ reset-stack
+;
+
+\ node sifting wants its own pockets
+create sift-node-buffer 1000 allot
+0 value sift-node-num
+: sift-node-buffer
+ sift-node-buffer sift-node-num 100 * +
+ sift-node-num 1+ dup 10 = IF drop 0 THEN
+ to sift-node-num
+;
+
+: $tab-sift-nodes ( text-addr text-len -- sift-count )
+ s" /" find-node BEGIN dup WHILE
+ $inner-sift-nodes IF \ any completions possible?
+ sift-node-buffer swap 2>r 2r@ move 2r> \ make an almost permanent copy without strdup
+ ?tab-pressed IF 2dup type space THEN \ <tab><tab> prints possibilities
+ tab-last-adr tab-last-len $same-string \ find matching substring ...
+ to tab-last-len to tab-last-adr \ ... and save it
+ THEN
+ REPEAT
+ 2drop drop
+ #sift-count 0 to #sift-count \ how many words were found?
+ reset-stack
+;
+
+: $tab-sift ( text-addr text-len -- sift-count )
+ ?tab-pressed IF beep space THEN \ cosmetical fix for <tab><tab>
+
+ dup IF bl rsplit dup IF 2swap THEN ELSE 0 0 THEN >r >r
+
+ 0 dup to tab-last-len to tab-last-adr \ reset last possible match
+ current-node @ IF \ if we are in a node?
+ 2dup 2>r \ save text
+ $tab-sift-words to #sift-count \ search in current node first
+ 2r> \ fetch text to complete, again
+ THEN
+ 2dup 2>r
+ current-node @ >r 0 set-node \ now search in global words
+ $tab-sift-words to #sift-count
+ r> set-node
+ 2r> $tab-sift-nodes
+ \ concatenate previous commands
+ r> r> dup IF s" " $cat THEN tab-last-adr tab-last-len $cat
+ to tab-last-len to tab-last-adr \ ... and save the whole string
+;
+
+\ 8< node sifting for tab completion on device tree nodes above this line 8<
+
+: handle-^A
+ 0 to accept-cur move-cursor ;
+: handle-^B
+ accept-cur ?dup IF 1- to accept-cur ( csi ." D" ) move-cursor THEN ;
+: handle-^D
+ delete-char ( redraw-line ) ;
+: handle-^E
+ accept-len to accept-cur move-cursor ;
+: handle-^F
+ accept-cur accept-len <> IF accept-cur 1+ to accept-cur csi ." C" THEN ;
+: handle-^H
+ accept-cur 0= IF beep EXIT THEN
+ handle-^B delete-char
+;
+: handle-^I
+ accept-adr accept-len
+ $tab-sift 0 > IF
+ ?tab-pressed IF
+ redraw-prompt full-redraw-line
+ false to ?tab-pressed
+ ELSE
+ tab-last-adr accept-adr tab-last-len move \ copy matching substring
+ tab-last-len dup to accept-len to accept-cur \ len and cursor position
+ full-redraw-line \ redraw new string
+ true to ?tab-pressed \ second tab will print possible matches
+ THEN
+ THEN
+;
+
+: handle-^K
+ BEGIN accept-cur accept-len <> WHILE delete-char REPEAT ;
+: handle-^L
+ history redraw-prompt full-redraw-line ;
+: handle-^N
+ his-cur IF his-cur his>next @ ELSE his-head THEN
+ dup to his-cur select-history
+;
+: handle-^P
+ his-cur IF his-cur his>prev @ ELSE his-tail THEN
+ dup to his-cur select-history
+;
+: handle-^Q \ Does not handle terminal formatting yet.
+ key insert-char ;
+: handle-^R
+ full-redraw-line ;
+: handle-^U
+ 0 to accept-len 0 to accept-cur full-redraw-line ;
+
+: handle-fn
+ key drop beep
+;
+
+TABLE-EXECUTE handle-CSI
+0 , ' handle-^P , ' handle-^N , ' handle-^F ,
+' handle-^B , 0 , 0 , 0 ,
+' handle-^A , 0 , 0 , ' handle-^E ,
+0 , 0 , 0 , 0 ,
+0 , 0 , 0 , 0 ,
+0 , 0 , 0 , 0 ,
+0 , 0 , 0 , 0 ,
+0 , 0 , 0 , 0 ,
+
+TABLE-EXECUTE handle-meta
+0 , 0 , 0 , 0 ,
+0 , 0 , 0 , 0 ,
+0 , 0 , 0 , 0 ,
+0 , 0 , 0 , ' handle-fn ,
+0 , 0 , 0 , 0 ,
+0 , 0 , 0 , 0 ,
+0 , 0 , 0 , ' handle-CSI ,
+0 , 0 , 0 , 0 ,
+
+: handle-ESC-O
+ key
+ dup 48 = IF
+ handle-^A
+ ELSE
+ dup 46 = IF
+ handle-^E
+ THEN
+ THEN drop
+;
+
+: handle-ESC-5b
+ key
+ dup 31 = IF \ HOME
+ key drop ( drops closing 7e ) handle-^A
+ ELSE
+ dup 33 = IF \ DEL
+ key drop handle-^D
+ ELSE
+ dup 34 = IF \ END
+ key drop handle-^E
+ ELSE
+ dup 1f and handle-CSI
+ THEN
+ THEN
+ THEN drop
+;
+
+: handle-ESC
+ key
+ dup 5b = IF
+ handle-ESC-5b
+ ELSE
+ dup 4f = IF
+ handle-ESC-O
+ ELSE
+ dup 1f and handle-meta
+ THEN
+ THEN drop
+;
+
+TABLE-EXECUTE handle-control
+0 , \ ^@:
+' handle-^A ,
+' handle-^B ,
+0 , \ ^C:
+' handle-^D ,
+' handle-^E ,
+' handle-^F ,
+0 , \ ^G:
+' handle-^H ,
+' handle-^I , \ tab
+0 , \ ^J:
+' handle-^K ,
+' handle-^L ,
+0 , \ ^M: enter: handled in main loop
+' handle-^N ,
+0 , \ ^O:
+' handle-^P ,
+' handle-^Q ,
+' handle-^R ,
+0 , \ ^S:
+0 , \ ^T:
+' handle-^U ,
+0 , \ ^V:
+0 , \ ^W:
+0 , \ ^X:
+0 , \ ^Y: insert save buffer
+0 , \ ^Z:
+' handle-ESC ,
+0 , \ ^\:
+0 , \ ^]:
+0 , \ ^^:
+0 , \ ^_:
+
+: (accept) ( adr len -- len' )
+ cursor-on
+ to accept-max to accept-adr
+ 0 to accept-len 0 to accept-cur
+ 0 to his-cur
+ 1b emit 37 emit
+ BEGIN
+ key dup 0d <>
+ WHILE
+ dup 9 <> IF 0 to ?tab-pressed THEN \ reset state machine
+ dup 7f = IF drop 8 THEN \ Handle DEL as if it was BS. ??? bogus
+ dup bl < IF handle-control ELSE
+ dup 80 and IF
+ dup a0 < IF 7f and handle-meta ELSE drop beep THEN
+ ELSE
+ insert-char
+ THEN
+ THEN
+ REPEAT
+ drop add-history
+ accept-len to accept-cur
+ move-cursor space
+ accept-len
+ cursor-off
+;
+
+' (accept) to accept
+
diff --git a/qemu/roms/SLOF/slof/fs/alloc-mem-debug.fs b/qemu/roms/SLOF/slof/fs/alloc-mem-debug.fs
new file mode 100644
index 000000000..d4ca70bbd
--- /dev/null
+++ b/qemu/roms/SLOF/slof/fs/alloc-mem-debug.fs
@@ -0,0 +1,116 @@
+\ *****************************************************************************
+\ * Copyright (c) 2011 IBM Corporation
+\ * All rights reserved.
+\ * This program and the accompanying materials
+\ * are made available under the terms of the BSD License
+\ * which accompanies this distribution, and is available at
+\ * http://www.opensource.org/licenses/bsd-license.php
+\ *
+\ * Contributors:
+\ * IBM Corporation - initial implementation
+\ ****************************************************************************/
+\ * Dynamic memory allocation/de-allocation debug functions
+\ *****************************************************************************
+
+
+\ Uncomment the following code for debugging bad write accesses beyond
+\ the end of the allocated block:
+\ Store magic value past the end of the block during alloc-mem and
+\ check for this magic value when free-mem has been called.
+#if 1
+: alloc-mem ( len -- addr )
+ dup /n + alloc-mem ( len addr )
+ 2dup + 3141592653589793 swap ! nip
+;
+
+: free-mem ( addr len -- )
+ 2dup + @ 3141592653589793 <> IF
+ cr ." Detected memory corrupt during free-mem of "
+ swap . . cr EXIT
+ THEN
+ /n + free-mem
+;
+#endif
+
+
+\ Never ever assume that allocated memory is pre-initialized with 0 ...
+: alloc-mem ( len -- addr )
+ dup alloc-mem swap 2dup ff fill drop
+;
+
+\ Make sure that memory block do not contain "valid" data after free-mem:
+: free-mem ( addr len -- )
+ 2dup ff fill free-mem
+;
+
+
+\ The following definitions are used for debugging the parameters of free-mem:
+\ Store block address and size of allocated blocks
+\ in an array, then check for right values on free-mem.
+
+1000 CONSTANT max-malloced-blocks
+CREATE malloced-blocks max-malloced-blocks 2 * cells allot
+malloced-blocks max-malloced-blocks 2 * cells erase
+
+
+: alloc-mem ( len -- addr )
+ dup alloc-mem dup 0= IF
+ cr ." alloc-mem returned 0 for size " swap . cr EXIT
+ THEN ( len addr )
+ malloced-blocks max-malloced-blocks 0 DO ( len addr m-blocks-ptr )
+ dup @ 0= IF ( len addr m-blocks-ptr )
+ \ Found a free entry: store addr and len
+ over >r dup >r !
+ r> cell+ !
+ r> UNLOOP EXIT
+ THEN
+ cell+ cell+ ( len addr next-m-blocks-ptr )
+ LOOP
+ ." Please increase max-malloced-blocks." cr ( len addr next-m-blocks-ptr )
+ drop nip
+;
+
+
+: free-mem ( addr len -- )
+ malloced-blocks max-malloced-blocks 0 DO ( addr len m-blocks-ptr )
+ dup @ ?dup IF
+ ( addr len m-blocks-ptr s-addr )
+ 3 pick = IF
+ ( addr len m-blocks-ptr )
+ dup cell+ @ ( addr len m-blocks-ptr s-len )
+ 2 pick = IF ( addr len m-blocks-ptr )
+ \ All right, addr and len matched,
+ \ clear entry and call original free-mem.
+ dup cell+ 0 swap !
+ 0 swap !
+ free-mem
+ ELSE
+ >r swap cr
+ ." free-mem called for block " . ." with wrong size=" . cr
+ ." ( correct size should be: " r> cell+ @ . ." )" cr
+ THEN
+ UNLOOP EXIT
+ THEN ( addr len m-blocks-ptr )
+ THEN
+ cell+ cell+ ( addr len next-m-blocks-ptr )
+ LOOP
+ drop swap cr
+ ." free-mem called for block " .
+ ." ( size=" .
+ ." ) which has never been allocated before!" cr
+;
+
+
+\ Enable these for verbose debug messages:
+#if 0
+: alloc-mem
+ cr ." alloc-mem with len=" dup .
+ alloc-mem
+ ." returned addr=" dup . cr
+;
+
+: free-mem
+ cr ." free mem addr=" over . ." len=" dup . cr
+ free-mem
+;
+#endif
diff --git a/qemu/roms/SLOF/slof/fs/alloc-mem.fs b/qemu/roms/SLOF/slof/fs/alloc-mem.fs
new file mode 100644
index 000000000..59381a72b
--- /dev/null
+++ b/qemu/roms/SLOF/slof/fs/alloc-mem.fs
@@ -0,0 +1,75 @@
+\ *****************************************************************************
+\ * Copyright (c) 2004, 2008 IBM Corporation
+\ * All rights reserved.
+\ * This program and the accompanying materials
+\ * are made available under the terms of the BSD License
+\ * which accompanies this distribution, and is available at
+\ * http://www.opensource.org/licenses/bsd-license.php
+\ *
+\ * Contributors:
+\ * IBM Corporation - initial implementation
+\ ****************************************************************************/
+
+#include <claim.fs>
+\ Memory "heap" (de-)allocation.
+
+\ Keep a linked list of free blocks per power-of-two size.
+\ Never coalesce entries when freed; split blocks when needed while allocating.
+
+\ 3f CONSTANT (max-heads#)
+heap-end heap-start - log2 1+ CONSTANT (max-heads#)
+
+CREATE heads (max-heads#) cells allot
+heads (max-heads#) cells erase
+
+
+: size>head ( size -- headptr ) log2 3 max cells heads + ;
+
+
+\ Allocate a memory block
+: alloc-mem ( len -- a-addr )
+ dup 0= IF EXIT THEN
+ 1 over log2 3 max ( len 1 log_len )
+ dup (max-heads#) >= IF cr ." Out of internal memory." cr 3drop 0 EXIT THEN
+ lshift >r ( len R: 1<<log_len )
+ size>head dup @ IF
+ dup @ dup >r @ swap ! r> r> drop EXIT
+ THEN ( headptr R: 1<<log_len)
+ r@ 2* recurse dup ( headptr a-addr2 a-addr2 R: 1<<log_len)
+ dup 0= IF r> 2drop 2drop 0 EXIT THEN
+ r> + >r 0 over ! swap ! r>
+;
+
+
+\ Free a memory block
+
+: free-mem ( a-addr len -- )
+ dup 0= IF 2drop EXIT THEN size>head 2dup @ swap ! !
+;
+
+
+: #links ( a -- n )
+ @ 0 BEGIN over WHILE 1+ swap @ swap REPEAT nip
+;
+
+
+: .free ( -- )
+ 0 (max-heads#) 0 DO
+ heads i cells + #links dup IF
+ cr dup . ." * " 1 i lshift dup . ." = " * dup .
+ THEN
+ +
+ LOOP
+ cr ." Total " .
+;
+
+
+\ Start with just one free block.
+heap-start heap-end heap-start - free-mem
+
+
+\ : free-mem ( a-addr len -- ) 2drop ;
+
+\ Uncomment the following line for debugging:
+\ #include <alloc-mem-debug.fs>
+
diff --git a/qemu/roms/SLOF/slof/fs/archsupport.fs b/qemu/roms/SLOF/slof/fs/archsupport.fs
new file mode 100644
index 000000000..cc4668769
--- /dev/null
+++ b/qemu/roms/SLOF/slof/fs/archsupport.fs
@@ -0,0 +1,38 @@
+\ *****************************************************************************
+\ * Copyright (c) 2011 IBM Corporation
+\ * All rights reserved.
+\ * This program and the accompanying materials
+\ * are made available under the terms of the BSD License
+\ * which accompanies this distribution, and is available at
+\ * http://www.opensource.org/licenses/bsd-license.php
+\ *
+\ * Contributors:
+\ * IBM Corporation - initial implementation
+\ ****************************************************************************/
+
+\ Qemu supports max 256cpus, 32K will be able to accomodate the fdt changes if
+\ needed.
+8000 VALUE size
+: ibm,client-architecture-support ( vec -- err? )
+ \ Store require parameters in nvram
+ \ to come back to right boot device
+ \ Allocate memory for H_CALL
+ size alloc-mem ( vec memaddr )
+ swap over size ( memaddr vec memaddr size )
+ \ make h_call to hypervisor
+ hv-cas 0= IF ( memaddr )
+ dup l@ 1 >= IF \ Version number >= 1
+ \ Make required changes
+ " /" find-node set-node
+ dup 4 + fdt-init
+ fdt-check-header
+ fdt-struct fdt-fix-cas-node
+ fdt-fix-cas-success NOT
+ ELSE
+ FALSE
+ THEN
+ ELSE
+ TRUE
+ THEN
+ >r size free-mem r>
+;
diff --git a/qemu/roms/SLOF/slof/fs/available.fs b/qemu/roms/SLOF/slof/fs/available.fs
new file mode 100644
index 000000000..5eb8fa93a
--- /dev/null
+++ b/qemu/roms/SLOF/slof/fs/available.fs
@@ -0,0 +1,72 @@
+\ *****************************************************************************
+\ * Copyright (c) 2004, 2008 IBM Corporation
+\ * All rights reserved.
+\ * This program and the accompanying materials
+\ * are made available under the terms of the BSD License
+\ * which accompanies this distribution, and is available at
+\ * http://www.opensource.org/licenses/bsd-license.php
+\ *
+\ * Contributors:
+\ * IBM Corporation - initial implementation
+\ ****************************************************************************/
+
+VARIABLE chosen-memory-ih 0 chosen-memory-ih !
+
+\ +
+\ Maintain "available" property.
+\ Sun has a single memory node with "available" property
+\ and separate memory controller nodes.
+\ We corespond memory nodes with their respective memory controllers
+\ and use /chosen/memory as default memory node to hold the "available" map
+\ NOTE -> /chosen/memory is expected 2B initialized before using claim/release
+\ +
+
+: (chosen-memory-ph) ( -- phandle )
+ chosen-memory-ih @ ?dup 0= IF
+ s" memory" get-chosen IF
+ decode-int nip nip dup chosen-memory-ih !
+ ihandle>phandle
+ ELSE 0 THEN
+ ELSE ihandle>phandle THEN
+;
+
+: (set-available-prop) ( prop plen -- )
+ s" available"
+ (chosen-memory-ph) ?dup 0<> IF set-property ELSE
+ cr ." Can't find chosen memory node - "
+ ." no available property created" cr
+ 2dup 2dup
+ THEN
+;
+
+: update-available-property ( available-ptr -- )
+ dup >r available>size@
+ 0= r@ available AVAILABLE-SIZE /available * + >= or IF
+ available r> available - encode-bytes (set-available-prop)
+ ELSE
+ r> /available + RECURSE
+ THEN
+;
+
+: update-available-property available update-available-property ;
+
+\ \\\\\\\\\\\\\\ Exported Interface:
+\ +
+\ IEEE 1275 implementation:
+\ claim
+\ Claim the region with given start address and size (if align parameter is 0);
+\ alternatively claim any region of given alignment
+\ +
+\ Throw an exception if failed
+\ +
+: claim ( [ addr ] len align -- base ) claim update-available-property ;
+
+\ +
+\ IEEE 1275 implementation:
+\ release
+\ Free the region with given start address and size
+\ +
+: release ( addr len -- ) release update-available-property ;
+
+update-available-property
+
diff --git a/qemu/roms/SLOF/slof/fs/banner.fs b/qemu/roms/SLOF/slof/fs/banner.fs
new file mode 100644
index 000000000..efdba0c5a
--- /dev/null
+++ b/qemu/roms/SLOF/slof/fs/banner.fs
@@ -0,0 +1,23 @@
+\ *****************************************************************************
+\ * Copyright (c) 2004, 2008 IBM Corporation
+\ * All rights reserved.
+\ * This program and the accompanying materials
+\ * are made available under the terms of the BSD License
+\ * which accompanies this distribution, and is available at
+\ * http://www.opensource.org/licenses/bsd-license.php
+\ *
+\ * Contributors:
+\ * IBM Corporation - initial implementation
+\ ****************************************************************************/
+
+: banner
+ cr ." Type 'boot' and press return to continue booting the system."
+ s" /packages/sms" find-node IF
+ cr ." Type 'sms-start' and press return to enter the configuration menu."
+ THEN
+ cr ." Type 'reset-all' and press return to reboot the system."
+ cr cr
+;
+
+: .banner banner console-clean-fifo ;
+
diff --git a/qemu/roms/SLOF/slof/fs/base.fs b/qemu/roms/SLOF/slof/fs/base.fs
new file mode 100644
index 000000000..e71e087eb
--- /dev/null
+++ b/qemu/roms/SLOF/slof/fs/base.fs
@@ -0,0 +1,611 @@
+\ *****************************************************************************
+\ * Copyright (c) 2004, 2008 IBM Corporation
+\ * All rights reserved.
+\ * This program and the accompanying materials
+\ * are made available under the terms of the BSD License
+\ * which accompanies this distribution, and is available at
+\ * http://www.opensource.org/licenses/bsd-license.php
+\ *
+\ * Contributors:
+\ * IBM Corporation - initial implementation
+\ ****************************************************************************/
+
+\ Hash for faster lookup
+#include <find-hash.fs>
+
+: >name ( xt -- nfa ) \ note: still has the "immediate" field!
+ BEGIN char- dup c@ UNTIL ( @lastchar )
+ dup dup aligned - cell+ char- ( @lastchar lenmodcell )
+ dup >r -
+ BEGIN dup c@ r@ <> WHILE
+ cell- r> cell+ >r
+ REPEAT
+ r> drop char-
+;
+
+\ Words missing in *.in files
+VARIABLE mask -1 mask !
+
+VARIABLE huge-tftp-load 1 huge-tftp-load !
+\ Default implementation for sms-get-tftp-blocksize that return 1432 (decimal)
+: sms-get-tftp-blocksize 598 ;
+
+: default-hw-exception s" Exception #" type . ;
+
+' default-hw-exception to hw-exception-handler
+
+: diagnostic-mode? false ; \ 2B DOTICK'D later in envvar.fs
+
+: memory-test-suite ( addr len -- fail? )
+ diagnostic-mode? IF
+ ." Memory test mask value: " mask @ . cr
+ ." No memory test suite currently implemented! " cr
+ THEN
+ false
+;
+
+: 0.r 0 swap <# 0 ?DO # LOOP #> type ;
+
+\ count the number of bits equal 1
+\ the idea is to clear in each step the least significant bit
+\ v&(v-1) does exactly this, so count the steps until v == 0
+: cnt-bits ( 64-bit-value -- #bits=1 )
+ dup IF
+ 41 1 DO dup 1- and dup 0= IF drop i LEAVE THEN LOOP
+ THEN
+;
+
+: bcd-to-bin ( bcd -- bin )
+ dup f and swap 4 rshift a * +
+;
+
+\ calcs the exponent of the highest power of 2 not greater than n
+: 2log ( n -- lb{n} )
+ 8 cells 0 DO 1 rshift dup 0= IF drop i LEAVE THEN LOOP
+;
+
+\ calcs the exponent of the lowest power of 2 not less than n
+: log2 ( n -- log2-n )
+ 1- 2log 1+
+;
+
+
+CREATE $catpad 400 allot
+: $cat ( str1 len1 str2 len2 -- str3 len3 )
+ >r >r dup >r $catpad swap move
+ r> dup $catpad + r> swap r@ move
+ r> + $catpad swap ;
+
+\ WARNING: The following two ($cat-comm & $cat-space) are dirty in a sense
+\ that they add 1 or 2 characters to str1 before executing $cat
+\ The ASSUMPTION is that str1 buffer provides that extra space and it is
+\ responsibility of the code owner to ensure that
+: $cat-comma ( str2 len2 str1 len1 -- "str1, str2" len1+len2+2 )
+ 2dup + s" , " rot swap move 2+ 2swap $cat
+;
+
+: $cat-space ( str2 len2 str1 len1 -- "str1 str2" len1+len2+1 )
+ 2dup + bl swap c! 1+ 2swap $cat
+;
+: $cathex ( str len val -- str len' )
+ (u.) $cat
+;
+
+
+: 2CONSTANT CREATE , , DOES> [ here ] 2@ ;
+
+\ Save XT of 2CONSTANT, put on the stack by "[ here ]" :
+CONSTANT <2constant>
+
+: $2CONSTANT $CREATE , , DOES> 2@ ;
+
+: 2VARIABLE CREATE 0 , 0 , DOES> ;
+
+
+: (is-user-word) ( name-str name-len xt -- ) -rot $CREATE , DOES> @ execute ;
+
+: zplace ( str len buf -- ) 2dup + 0 swap c! swap move ;
+: rzplace ( str len buf -- ) 2dup + 0 swap rb! swap rmove ;
+
+: strdup ( str len -- dupstr len ) here over allot swap 2dup 2>r move 2r> ;
+
+: str= ( str1 len1 str2 len2 -- equal? )
+ rot over <> IF 3drop false ELSE comp 0= THEN ;
+
+: test-string ( param len -- true | false )
+ 0 ?DO
+ dup i + c@ \ Get character / byte at current index
+ dup 20 < swap 7e > OR IF \ Is it out of range 32 to 126 (=ASCII)
+ drop FALSE UNLOOP EXIT \ FALSE means: No ASCII string
+ THEN
+ LOOP
+ drop TRUE \ Only ASCII found --> it is a string
+;
+
+: #aligned ( adr alignment -- adr' ) negate swap negate and negate ;
+: #join ( lo hi #bits -- x ) lshift or ;
+: #split ( x #bits -- lo hi ) 2dup rshift dup >r swap lshift xor r> ;
+
+: /string ( str len u -- str' len' )
+ >r swap r@ chars + swap r> - ;
+: skip ( str len c -- str' len' )
+ >r BEGIN dup WHILE over c@ r@ = WHILE 1 /string REPEAT THEN r> drop ;
+: scan ( str len c -- str' len' )
+ >r BEGIN dup WHILE over c@ r@ <> WHILE 1 /string REPEAT THEN r> drop ;
+: split ( str len char -- left len right len )
+ >r 2dup r> findchar IF >r over r@ 2swap r> 1+ /string ELSE 0 0 THEN ;
+\ reverse findchar -- search from the end of the string
+: rfindchar ( str len char -- offs true | false )
+ swap 1 - 0 swap do
+ over i + c@
+ over dup bl = if <= else = then if
+ 2drop i dup dup leave
+ then
+ -1 +loop =
+;
+\ reverse split -- split at the last occurrence of char
+: rsplit ( str len char -- left len right len )
+ >r 2dup r> rfindchar IF >r over r@ 2swap r> 1+ /string ELSE 0 0 THEN ;
+
+: left-parse-string ( str len char -- R-str R-len L-str L-len )
+ split 2swap ;
+: replace-char ( str len chout chin -- )
+ >r -rot BEGIN 2dup 4 pick findchar WHILE tuck - -rot + r@ over c! swap REPEAT
+ r> 2drop 2drop
+;
+\ Duplicate string and replace \ with /
+: \-to-/ ( str len -- str' len ) strdup 2dup [char] \ [char] / replace-char ;
+
+: isdigit ( char -- true | false )
+ 30 39 between
+;
+
+: ishexdigit ( char -- true | false )
+ 30 39 between 41 46 between OR 61 66 between OR
+;
+
+\ Variant of $number that defaults to decimal unless "0x" is
+\ a prefix
+: $dh-number ( addr len -- true | number false )
+ base @ >r
+ decimal
+ dup 2 > IF
+ over dup c@ [char] 0 =
+ over 1 + c@ 20 or [char] x =
+ AND IF hex 2 + swap 2 - rot THEN drop
+ THEN
+ $number
+ r> base !
+;
+
+: // dup >r 1- + r> / ; \ division, round up
+
+: c@+ ( adr -- c adr' ) dup c@ swap char+ ;
+: 2c@ ( adr -- c1 c2 ) c@+ c@ ;
+: 4c@ ( adr -- c1 c2 c3 c4 ) c@+ c@+ c@+ c@ ;
+: 8c@ ( adr -- c1 c2 c3 c4 c5 c6 c7 c8 ) c@+ c@+ c@+ c@+ c@+ c@+ c@+ c@ ;
+
+
+: 4dup ( n1 n2 n3 n4 -- n1 n2 n3 n4 n1 n2 n3 n4 ) 2over 2over ;
+: 4drop ( n1 n2 n3 n4 -- ) 2drop 2drop ;
+
+\ yes sometimes even something like this is needed
+: 5dup ( 1 2 3 4 5 -- 1 2 3 4 5 1 2 3 4 5 )
+ 4 pick 4 pick 4 pick 4 pick 4 pick ;
+: 5drop 4drop drop ;
+: 5nip
+ nip nip nip nip nip ;
+
+: 6dup ( 1 2 3 4 5 6 -- 1 2 3 4 5 6 1 2 3 4 5 6 )
+ 5 pick 5 pick 5 pick 5 pick 5 pick 5 pick ;
+
+\ convert a 32 bit signed into a 64 signed
+\ ( propagate bit 31 to all bits 32:63 )
+: signed ( n1 -- n2 ) dup 80000000 and IF FFFFFFFF00000000 or THEN ;
+
+: <l@ ( addr -- x ) l@ signed ;
+
+: -leading BEGIN dup WHILE over c@ bl <= WHILE 1 /string REPEAT THEN ;
+: (parse-line) skipws 0 parse ;
+
+
+\ Append two character to hex byte, if possible
+
+: hex-byte ( char0 char1 -- value true|false )
+ 10 digit IF
+ swap 10 digit IF
+ 4 lshift or true EXIT
+ ELSE
+ 2drop 0
+ THEN
+ ELSE
+ drop
+ THEN
+ false EXIT
+;
+
+\ Parse hex string within brackets
+
+: parse-hexstring ( dst-adr -- dst-adr' )
+ [char] ) parse cr ( dst-adr str len )
+ bounds ?DO ( dst-adr )
+ i c@ i 1+ c@ hex-byte IF ( dst-adr hex-byte )
+ >r dup r> swap c! 1+ 2 ( dst-adr+1 2 )
+ ELSE
+ drop 1 ( dst-adr 1 )
+ THEN
+ +LOOP
+;
+
+\ Add special character to string
+
+: add-specialchar ( dst-adr special -- dst-adr' )
+ over c! 1+ ( dst-adr' )
+ 1 >in +! \ advance input-index
+;
+
+\ Parse up to next "
+
+: parse-" ( dst-adr -- dst-adr' )
+ [char] " parse dup 3 pick + >r ( dst-adr str len R: dst-adr' )
+ >r swap r> move r> ( dst-adr' )
+;
+
+: (") ( dst-adr -- dst-adr' )
+ begin ( dst-adr )
+ parse-" ( dst-adr' )
+ >in @ dup span @ >= IF ( dst-adr' >in-@ )
+ drop
+ EXIT
+ THEN
+
+ ib + c@
+ CASE
+ [char] ( OF parse-hexstring ENDOF
+ [char] " OF [char] " add-specialchar ENDOF
+ dup OF EXIT ENDOF
+ ENDCASE
+ again
+;
+
+CREATE "pad 100 allot
+
+\ String with embedded hex strings
+\ Example: " ba"( 12 34,4567)ab" -> >x62x61x12x34x45x67x61x62<
+
+: " ( [text<">< >] -- text-str text-len )
+ state @ IF \ compile sliteral, pstr into dict
+ "pad dup (") over - ( str len )
+ ['] sliteral compile, dup c, ( str len )
+ bounds ?DO i c@ c, LOOP
+ align ['] count compile,
+ ELSE
+ pocket dup (") over - \ Interpretation, put string
+ THEN \ in temp buffer
+; immediate
+
+
+\ Output the carriage-return character
+: (cr carret emit ;
+
+
+\ Remove command old-name and all subsequent definitions
+
+: $forget ( str len -- )
+ 2dup last @ ( str len str len last-bc )
+ BEGIN
+ dup >r ( str len str len last-bc R: last-bc )
+ cell+ char+ count ( str len str len found-str found-len R: last-bc )
+ string=ci IF ( str len R: last-bc )
+ r> @ last ! 2drop clean-hash EXIT ( -- )
+ THEN
+ 2dup r> @ dup 0= ( str len str len next-bc next-bc )
+ UNTIL
+ drop 2drop 2drop \ clean hash table
+;
+
+: forget ( "old-name<>" -- )
+ parse-word $forget
+;
+
+#include <search.fs>
+
+\ The following constants are required in some parts
+\ of the code, mainly instance variables and see. Having to reverse
+\ engineer our own CFAs seems somewhat weird, but we gained a bit speed.
+
+\ Each colon definition is surrounded by colon and semicolon
+\ constant below contain address of their xt
+
+: (function) ;
+defer (defer)
+0 value (value)
+0 constant (constant)
+variable (variable)
+create (create)
+alias (alias) (function)
+cell buffer: (buffer:)
+
+' (function) @ \ ( <colon> )
+' (function) cell + @ \ ( ... <semicolon> )
+' (defer) @ \ ( ... <defer> )
+' (value) @ \ ( ... <value> )
+' (constant) @ \ ( ... <constant> )
+' (variable) @ \ ( ... <variable> )
+' (create) @ \ ( ... <create> )
+' (alias) @ \ ( ... <alias> )
+' (buffer:) @ \ ( ... <buffer:> )
+
+\ now clean up the test functions
+forget (function)
+
+\ and remember the constants
+constant <buffer:>
+constant <alias>
+constant <create>
+constant <variable>
+constant <constant>
+constant <value>
+constant <defer>
+constant <semicolon>
+constant <colon>
+
+' lit constant <lit>
+' sliteral constant <sliteral>
+' 0branch constant <0branch>
+' branch constant <branch>
+' doloop constant <doloop>
+' dotick constant <dotick>
+' doto constant <doto>
+' do?do constant <do?do>
+' do+loop constant <do+loop>
+' do constant <do>
+' exit constant <exit>
+' doleave constant <doleave>
+' do?leave constant <do?leave>
+
+
+\ provide the memory management words
+\ #include <claim.fs>
+\ #include "memory.fs"
+#include <alloc-mem.fs>
+
+#include <node.fs>
+
+: find-substr ( basestr-ptr basestr-len substr-ptr substr-len -- pos )
+ \ if substr-len == 0 ?
+ dup 0 = IF
+ \ return 0
+ 2drop 2drop 0 exit THEN
+ \ if substr-len <= basestr-len ?
+ dup 3 pick <= IF
+ \ run J from 0 to "basestr-len"-"substr-len" and I from 0 to "substr-len"-1
+ 2 pick over - 1+ 0 DO dup 0 DO
+ \ substr-ptr[i] == basestr-ptr[j+i] ?
+ over i + c@ 4 pick j + i + c@ = IF
+ \ (I+1) == substr-len ?
+ dup i 1+ = IF
+ \ return J
+ 2drop 2drop j unloop unloop exit THEN
+ ELSE leave THEN
+ LOOP LOOP
+ THEN
+ \ if there is no match then exit with basestr-len as return value
+ 2drop nip
+;
+
+: find-isubstr ( basestr-ptr basestr-len substr-ptr substr-len -- pos )
+ \ if substr-len == 0 ?
+ dup 0 = IF
+ \ return 0
+ 2drop 2drop 0 exit THEN
+ \ if substr-len <= basestr-len ?
+ dup 3 pick <= IF
+ \ run J from 0 to "basestr-len"-"substr-len" and I from 0 to "substr-len"-1
+ 2 pick over - 1+ 0 DO dup 0 DO
+ \ substr-ptr[i] == basestr-ptr[j+i] ?
+ over i + c@ lcc 4 pick j + i + c@ lcc = IF
+ \ (I+1) == substr-len ?
+ dup i 1+ = IF
+ \ return J
+ 2drop 2drop j unloop unloop exit THEN
+ ELSE leave THEN
+ LOOP LOOP
+ THEN
+ \ if there is no match then exit with basestr-len as return value
+ 2drop nip
+;
+
+: find-nextline ( str-ptr str-len -- pos )
+ \ run I from 0 to "str-len"-1 and check str-ptr[i]
+ dup 0 ?DO over i + c@ CASE
+ \ 0x0a (=LF) found ?
+ 0a OF
+ \ if current cursor is at end position (I == "str-len"-1) ?
+ dup 1- i = IF
+ \ return I+1
+ 2drop i 1+ unloop exit THEN
+ \ if str-ptr[I+1] == 0x0d (=CR) ?
+ over i 1+ + c@ 0d = IF
+ \ return I+2
+ 2drop i 2+ ELSE
+ \ else return I+1
+ 2drop i 1+ THEN
+ unloop exit
+ ENDOF
+ \ 0x0d (=CR) found ?
+ 0d OF
+ \ if current cursor is at end position (I == "str-len"-1) ?
+ dup 1- i = IF
+ \ return I+1
+ 2drop i 1+ unloop exit THEN
+ \ str-ptr[I+1] == 0x0a (=LF) ?
+ over i 1+ + c@ 0a = IF
+ \ return I+2
+ 2drop i 2+ ELSE
+ \ return I+1
+ 2drop i 1+ THEN
+ unloop exit
+ ENDOF
+ ENDCASE LOOP nip
+;
+
+: string-at ( str1-ptr str1-len pos -- str2-ptr str2-len )
+ -rot 2 pick - -rot swap chars + swap
+;
+
+\ appends the string beginning at addr2 to the end of the string
+\ beginning at addr1
+\ !!! THERE MUST BE SUFFICIENT MEMORY RESERVED FOR THE STRING !!!
+\ !!! BEGINNING AT ADDR1 (cp. 'strcat' in 'C' ) !!!
+
+: string-cat ( addr1 len1 addr2 len2 -- addr1 len1+len2 )
+ \ len1 := len1+len2
+ rot dup >r over + -rot
+ ( addr1 len1+len2 dest-ptr src-ptr len2 )
+ 3 pick r> chars + -rot
+ ( ... dest-ptr src-ptr )
+ 0 ?DO
+ 2dup c@ swap c!
+ char+ swap char+ swap
+ LOOP 2drop
+;
+
+\ appends a character to the end of the string beginning at addr
+\ !!! THERE MUST BE SUFFICIENT MEMORY RESERVED FOR THE STRING !!!
+\ !!! BEGINNING AT ADDR1 (cp. 'strcat' in 'C' ) !!!
+
+: char-cat ( addr len character -- addr len+1 )
+ -rot 2dup >r >r 1+ rot r> r> chars + c!
+;
+
+\ Returns true if source and destination overlap
+: overlap ( src dest size -- true|false )
+ 3dup over + within IF 3drop true ELSE rot tuck + within THEN
+;
+
+: parse-2int ( str len -- val.lo val.hi )
+\ ." parse-2int ( " 2dup swap . . ." -- "
+ [char] , split ?dup IF eval ELSE drop 0 THEN
+ -rot ?dup IF eval ELSE drop 0 THEN
+\ 2dup swap . . ." )" cr
+;
+
+\ peek/poke minimal implementation, just to support FCode drivers
+\ Any implmentation with full error detection will be platform specific
+: cpeek ( addr -- false | byte true ) c@ true ;
+: cpoke ( byte addr -- success? ) c! true ;
+: wpeek ( addr -- false | word true ) w@ true ;
+: wpoke ( word addr -- success? ) w! true ;
+: lpeek ( addr -- false | lword true ) l@ true ;
+: lpoke ( lword addr -- success? ) l! true ;
+
+defer reboot ( -- )
+defer halt ( -- )
+defer disable-watchdog ( -- )
+defer reset-watchdog ( -- )
+defer set-watchdog ( +n -- )
+defer set-led ( type instance state -- status )
+defer get-flashside ( -- side )
+defer set-flashside ( side -- status )
+defer read-bootlist ( -- )
+defer furnish-boot-file ( -- adr len )
+defer set-boot-file ( adr len -- )
+defer mfg-mode? ( -- flag )
+defer of-prompt? ( -- flag )
+defer debug-boot? ( -- flag )
+defer bmc-version ( -- adr len )
+defer cursor-on ( -- )
+defer cursor-off ( -- )
+
+: nop-reboot ( -- ) ." reboot not available" abort ;
+: nop-halt ( -- ) ." halt not available" abort ;
+: nop-disable-watchdog ( -- ) ;
+: nop-reset-watchdog ( -- ) ;
+: nop-set-watchdog ( +n -- ) drop ;
+: nop-set-led ( type instance state -- status ) drop drop drop ;
+: nop-get-flashside ( -- side ) ." Cannot get flashside" cr ABORT ;
+: nop-set-flashside ( side -- status ) ." Cannot set flashside" cr ABORT ;
+: nop-read-bootlist ( -- ) ;
+: nop-furnish-bootfile ( -- adr len ) s" net:" ;
+: nop-set-boot-file ( adr len -- ) 2drop ;
+: nop-mfg-mode? ( -- flag ) false ;
+: nop-of-prompt? ( -- flag ) false ;
+: nop-debug-boot? ( -- flag ) false ;
+: nop-bmc-version ( -- adr len ) s" XXXXX" ;
+: nop-cursor-on ( -- ) ;
+: nop-cursor-off ( -- ) ;
+
+' nop-reboot to reboot
+' nop-halt to halt
+' nop-disable-watchdog to disable-watchdog
+' nop-reset-watchdog to reset-watchdog
+' nop-set-watchdog to set-watchdog
+' nop-set-led to set-led
+' nop-get-flashside to get-flashside
+' nop-set-flashside to set-flashside
+' nop-read-bootlist to read-bootlist
+' nop-furnish-bootfile to furnish-boot-file
+' nop-set-boot-file to set-boot-file
+' nop-mfg-mode? to mfg-mode?
+' nop-of-prompt? to of-prompt?
+' nop-debug-boot? to debug-boot?
+' nop-bmc-version to bmc-version
+' nop-cursor-on to cursor-on
+' nop-cursor-off to cursor-off
+
+: reset-all reboot ;
+
+\ load-base is an env. variable now, but it can
+\ be overriden temporarily provided users use
+\ get-load-base rather than load-base directly
+\
+\ default-load-base is set here and can be
+\ overriden by the board code. It will be used
+\ to set the default value of the envvar "load-base"
+\ when booting without a valid nvram
+
+10000000 VALUE default-load-base
+2000000 VALUE flash-load-base
+0 VALUE load-base-override
+
+: get-load-base
+ load-base-override 0<> IF load-base-override ELSE
+ " load-base" evaluate
+ THEN
+;
+
+\ provide first level debug support
+#include "debug.fs"
+\ provide 7.5.3.1 Dictionary search
+#include "dictionary.fs"
+\ block data access for IO devices - ought to be implemented in engine
+#include "rmove.fs"
+\ provide a simple run time preprocessor
+#include <preprocessor.fs>
+
+: $dnumber base @ >r decimal $number r> base ! ;
+: (.d) base @ >r decimal (.) r> base ! ;
+
+\ IP address conversion
+
+: (ipaddr) ( "a.b.c.d" -- FALSE | n1 n2 n3 n4 TRUE )
+ base @ >r decimal
+ over s" 000.000.000.000" comp 0= IF 2drop false r> base ! EXIT THEN
+ [char] . left-parse-string $number IF 2drop false r> base ! EXIT THEN -rot
+ [char] . left-parse-string $number IF 2drop false r> base ! EXIT THEN -rot
+ [char] . left-parse-string $number IF 2drop false r> base ! EXIT THEN -rot
+ $number IF false r> base ! EXIT THEN
+ true r> base !
+;
+
+: (ipformat) ( n1 n2 n3 n4 -- str len )
+ base @ >r decimal
+ 0 <# # # # [char] . hold drop # # # [char] . hold
+ drop # # # [char] . hold drop # # #s #>
+ r> base !
+;
+
+: ipformat ( n1 n2 n3 n4 -- ) (ipformat) type ;
+
+
diff --git a/qemu/roms/SLOF/slof/fs/boot.fs b/qemu/roms/SLOF/slof/fs/boot.fs
new file mode 100644
index 000000000..9a0ded0c2
--- /dev/null
+++ b/qemu/roms/SLOF/slof/fs/boot.fs
@@ -0,0 +1,300 @@
+\ *****************************************************************************
+\ * Copyright (c) 2004, 2008 IBM Corporation
+\ * All rights reserved.
+\ * This program and the accompanying materials
+\ * are made available under the terms of the BSD License
+\ * which accompanies this distribution, and is available at
+\ * http://www.opensource.org/licenses/bsd-license.php
+\ *
+\ * Contributors:
+\ * IBM Corporation - initial implementation
+\ ****************************************************************************/
+
+0 VALUE load-size
+0 VALUE go-entry
+VARIABLE state-valid false state-valid !
+CREATE go-args 2 cells allot go-args 2 cells erase
+
+\ \\\\\\\\\\\\\\ Structure/Implementation Dependent Methods
+
+: $bootargs
+ bootargs 2@ ?dup IF
+ ELSE s" diagnostic-mode?" evaluate and IF s" diag-file" evaluate
+ ELSE s" boot-file" evaluate THEN THEN
+;
+
+: $bootdev ( -- device-name len )
+ bootdevice 2@ dup IF s" " $cat THEN
+ s" diagnostic-mode?" evaluate IF
+ s" diag-device" evaluate
+ ELSE
+ s" boot-device" evaluate
+ THEN
+ $cat \ prepend bootdevice setting from vpd-bootlist
+ strdup
+ ?dup 0= IF
+ disable-watchdog
+ drop true ABORT" No boot device!"
+ THEN
+;
+
+
+\ \\\\\\\\\\\\\\ Implementation Independent Methods (Depend on Previous)
+\ *
+\ *
+: set-boot-args ( str len -- ) dup IF strdup ELSE nip dup THEN bootargs 2! ;
+
+: (set-boot-device) ( str len -- )
+ ?dup IF 1+ strdup 1- ELSE drop 0 0 THEN bootdevice 2!
+;
+
+' (set-boot-device) to set-boot-device
+
+: (add-boot-device) ( str len -- ) \ Concatenate " str" to "bootdevice"
+ bootdevice 2@ ?dup IF $cat-space ELSE drop THEN set-boot-device
+;
+
+' (add-boot-device) to add-boot-device
+
+0 value claim-list
+
+: no-go ( -- ) -64 boot-exception-handler ABORT ;
+
+defer go ( -- )
+
+: go-32 ( -- )
+ state-valid @ IF
+ 0 ciregs >r3 ! 0 ciregs >r4 !
+ go-args 2@ go-entry start-elf client-data
+ claim-list elf-release 0 to claim-list
+ THEN
+ -6d boot-exception-handler ABORT
+;
+
+: go-64 ( args len entry r2 -- )
+ 0 ciregs >r3 ! 0 ciregs >r4 !
+ start-elf64 client-data
+ claim-list elf-release 0 to claim-list
+;
+
+: set-le ( -- )
+ 1 ciregs >r13 !
+;
+
+: set-be ( -- )
+ 0 ciregs >r13 !
+;
+
+: go-64-be ( -- )
+ state-valid @ IF
+ set-be
+ go-args 2@
+ go-entry @
+ go-entry 8 + @
+ go-64
+ THEN
+ -6d boot-exception-handler ABORT
+;
+
+
+: go-32-be
+ set-be
+ go-32
+;
+
+: go-32-lev1
+ set-le
+ go-32
+;
+
+: go-64-lev1
+ state-valid @ IF
+ go-args 2@
+ go-entry @ xbflip
+ go-entry 8 + @ xbflip
+ set-le
+ go-64
+ THEN
+ -6d boot-exception-handler ABORT
+;
+
+: go-64-lev2
+ state-valid @ IF
+ go-args 2@
+ go-entry 0
+ set-le
+ go-64
+ THEN
+ -6d boot-exception-handler ABORT
+;
+
+: load-elf-init ( arg len file-addr -- success )
+ false state-valid ! \ Not valid anymore ...
+ claim-list IF \ Release claimed mem
+ claim-list elf-release 0 to claim-list \ from last load
+ THEN
+
+ true swap -1 ( arg len true file-addr -1 )
+ elf-load-claim ( arg len true claim-list entry elftype )
+
+ ( arg len true claim-list entry elftype )
+ CASE
+ 1 OF ['] go-32-be ENDOF ( arg len true claim-list entry go )
+ 2 OF ['] go-64-be ENDOF ( arg len true claim-list entry go )
+ 3 OF ['] go-64-lev1 ENDOF ( arg len true claim-list entry go )
+ 4 OF ['] go-64-lev2 ENDOF ( arg len true claim-list entry go )
+ 5 OF ['] go-32-lev1 ENDOF ( arg len true claim-list entry go )
+ dup OF ['] no-go to go
+ 2drop 3drop false EXIT ENDOF ( false )
+ ENDCASE
+
+ to go to go-entry to claim-list
+ dup state-valid ! -rot
+
+ 2 pick IF
+ go-args 2!
+ ELSE
+ 2drop
+ THEN
+;
+
+: init-program ( -- )
+ $bootargs get-load-base ['] load-elf-init CATCH ?dup IF
+ boot-exception-handler
+ 2drop 2drop false \ Could not claim
+ ELSE IF
+ 0 ciregs 2dup >r3 ! >r4 ! \ Valid (ELF ) Image
+ THEN
+ THEN
+;
+
+
+\ \\\\\\\\\\\\\\ Exported Interface:
+\ *
+\ Generic device load method:
+\ *
+
+: do-load ( devstr len -- img-size ) \ Device method wrapper
+ use-load-watchdog? IF
+ \ Set watchdog timer to 10 minutes, multiply with 2 because DHCP
+ \ needs 1 second per try and add 1 min to avoid race conditions
+ \ with watchdog timeout.
+ 4ec set-watchdog
+ THEN
+ my-self >r current-node @ >r \ Save my-self
+ ." Trying to load: " $bootargs type ." from: " 2dup type ." ... "
+ 2dup open-dev dup IF
+ dup to my-self
+ dup ihandle>phandle set-node
+ -rot ( ihandle devstr len )
+ my-args nip 0= IF
+ 2dup 1- + c@ [char] : <> IF \ Add : to device path if missing
+ 1+ strdup 2dup 1- + [char] : swap c!
+ THEN
+ THEN
+ encode-string s" bootpath" set-chosen
+ $bootargs encode-string s" bootargs" set-chosen
+ get-load-base s" load" 3 pick ['] $call-method CATCH IF
+ -67 boot-exception-handler 3drop drop false
+ ELSE
+ dup 0> IF
+ init-program
+ ELSE
+ false state-valid !
+ drop 0 \ Could not load
+ THEN
+ THEN
+ swap close-dev device-end dup to load-size
+ ELSE -68 boot-exception-handler 3drop false THEN
+ r> set-node r> to my-self \ Restore my-self
+;
+
+: parse-load ( "{devlist}" -- success ) \ Parse-execute boot-device list
+ cr BEGIN parse-word dup WHILE
+ ( de-alias ) do-load dup 0< IF drop 0 THEN IF
+ state-valid @ IF ." Successfully loaded" cr THEN
+ true 0d parse strdup load-list 2! EXIT
+ THEN
+ REPEAT 2drop 0 0 load-list 2! false
+;
+
+: load ( "{params}<eol>"} -- success ) \ Client interface to load
+ parse-word 0d parse -leading 2swap ?dup IF
+ de-alias
+ set-boot-device
+ ELSE
+ drop
+ THEN
+ set-boot-args s" parse-load " $bootdev $cat strdup evaluate
+;
+
+: load-next ( -- success ) \ Continue after go failed
+ load-list 2@ ?dup IF s" parse-load " 2swap $cat strdup evaluate
+ ELSE drop false THEN
+;
+
+\ \\\\\\\\\\\\\\\\\\\\\\\\\\
+\ load/go utilities
+\ -> Should be in loaders.fs
+
+: noload false ;
+
+' no-go to go
+
+: (go-and-catch) ( -- )
+ \ Recommended Practice: Forth Source Support (scripts starting with comment)
+ get-load-base c@ 5c = get-load-base 1+ c@ 20 = AND IF
+ load-size alloc-mem ( allocated-addr )
+ ?dup 0= IF ." alloc-mem failed." cr EXIT THEN
+ load-size >r >r ( R: allocate-addr load-size )
+ get-load-base r@ load-size move \ Move away from load-base
+ r@ load-size evaluate \ Run the script
+ r> r> free-mem
+ EXIT
+ THEN
+ \ Assume it's a normal executable, use "go" to run it:
+ ['] go behavior CATCH IF -69 boot-exception-handler THEN
+;
+
+
+\ if the board does not get the bootlist from the nvram
+\ then this word is supposed to be overloaded with the
+\ word to get the bootlist from VPD (or from wheresoever)
+read-bootlist
+
+\ \\\\\\\\\\\\\\ Exported Interface:
+\ *
+\ IEEE 1275 : load (user interface)
+\ *
+: boot
+ load 0= IF -65 boot-exception-handler EXIT THEN
+ disable-watchdog (go-and-catch)
+ BEGIN load-next WHILE
+ disable-watchdog (go-and-catch)
+ REPEAT
+
+ \ When we return from boot print the banner again.
+ .banner
+;
+
+: load load 0= IF -65 boot-exception-handler THEN ;
+
+\ \\\\ Temporary hacks for backwards compatibility
+: yaboot ." Use 'boot disk' instead " ;
+
+: netboot ( -- rc ) ." Use 'boot net' instead " ;
+
+: netboot-arg ( arg-string -- rc )
+ s" boot net " 2swap $cat (parse-line) $cat
+ evaluate
+;
+
+: netload ( -- rc ) (parse-line)
+ load-base-override >r flash-load-base to load-base-override
+ s" load net:" strdup 2swap $cat strdup evaluate
+ r> to load-base-override
+ load-size
+;
+
+: neteval ( -- ) FLASH-LOAD-BASE netload evaluate ;
+
diff --git a/qemu/roms/SLOF/slof/fs/bootmsg.fs b/qemu/roms/SLOF/slof/fs/bootmsg.fs
new file mode 100644
index 000000000..524d46908
--- /dev/null
+++ b/qemu/roms/SLOF/slof/fs/bootmsg.fs
@@ -0,0 +1,74 @@
+\ *****************************************************************************
+\ * Copyright (c) 2004, 2008 IBM Corporation
+\ * All rights reserved.
+\ * This program and the accompanying materials
+\ * are made available under the terms of the BSD License
+\ * which accompanies this distribution, and is available at
+\ * http://www.opensource.org/licenses/bsd-license.php
+\ *
+\ * Contributors:
+\ * IBM Corporation - initial implementation
+\ ****************************************************************************/
+create debugstr 255 allot
+0 VALUE debuglen
+\ tbl@ d# 1000 * 196e6aa / VALUE TIME1
+\ 0 VALUE TIME2
+
+\ Usage: 42 cp
+: cp ( checkpoint -- )
+ \ cr depth 2 0.r s" : " type .s cr \ DEBUG
+ \ cr ." time: " tbl@ d# 1000 * 196e6aa / dup TIME1 - dup . cr TIME2 + TO TIME2 TO TIME1
+ bootmsg-cp ;
+
+: (warning) ( id level ptr len -- )
+ dup TO debuglen
+ debugstr swap move \ copy into buffer
+ 0 debuglen debugstr + c! \ terminate '\0'
+ debugstr bootmsg-warning
+;
+
+\ Usage: 42 0 warning" warning-txt"
+: warning" ( id level [text<">] -- )
+ postpone s" state @
+ IF
+ ['] (warning) compile,
+ ELSE
+ (warning)
+ THEN
+; immediate
+
+: (debug-cp) ( id level ptr len -- )
+ dup TO debuglen
+ debugstr swap move \ copy into buffer
+ 0 debuglen debugstr + c! \ terminate '\0'
+ debugstr bootmsg-debugcp
+;
+
+\ Usage: 42 0 debug-cp" debug-cp-txt"
+: debug-cp" ( id level [text<">] -- )
+ postpone s" state @
+ IF
+ ['] (debug-cp) compile,
+ ELSE
+ (debug-cp)
+ THEN
+; immediate
+
+: (error) ( id ptr len -- )
+ dup TO debuglen
+ debugstr swap move \ copy into buffer
+ 0 debuglen debugstr + c! \ terminate '\0'
+ debugstr bootmsg-error
+;
+
+\ Usage: 42 error" error-txt"
+: error" ( id level [text<">] -- )
+ postpone s" state @
+ IF
+ ['] (error) compile,
+ ELSE
+ (error)
+ THEN
+; immediate
+
+bootmsg-nvupdate
diff --git a/qemu/roms/SLOF/slof/fs/claim.fs b/qemu/roms/SLOF/slof/fs/claim.fs
new file mode 100644
index 000000000..d012d3db8
--- /dev/null
+++ b/qemu/roms/SLOF/slof/fs/claim.fs
@@ -0,0 +1,415 @@
+\ *****************************************************************************
+\ * Copyright (c) 2004, 2011 IBM Corporation
+\ * All rights reserved.
+\ * This program and the accompanying materials
+\ * are made available under the terms of the BSD License
+\ * which accompanies this distribution, and is available at
+\ * http://www.opensource.org/licenses/bsd-license.php
+\ *
+\ * Contributors:
+\ * IBM Corporation - initial implementation
+\ ****************************************************************************/
+
+\ \\\\\\\\\\\\\\ Constants
+500 CONSTANT AVAILABLE-SIZE
+4000 CONSTANT MIN-RAM-RESERVE \ prevent from using first pages
+
+: MIN-RAM-SIZE \ Initially available memory size
+ epapr-ima-size IF
+ epapr-ima-size
+ ELSE
+ 20000000 \ assumed minimal memory size
+ THEN
+;
+MIN-RAM-SIZE CONSTANT MIN-RAM-SIZE
+
+\ \\\\\\\\\\\\\\ Structures
+\ +
+\ The available element size depends strictly on the address/size
+\ value formats and will be different for various device types
+\ +
+STRUCT
+ cell field available>address
+ cell field available>size
+CONSTANT /available
+
+
+\ \\\\\\\\\\\\\\ Global Data
+CREATE available AVAILABLE-SIZE /available * allot available AVAILABLE-SIZE /available * erase
+VARIABLE mem-pre-released 0 mem-pre-released !
+
+\ \\\\\\\\\\\\\\ Structure/Implementation Dependent Methods
+: available>size@ available>size @ ;
+: available>address@ available>address @ ;
+: available>size! available>size ! ;
+: available>address! available>address ! ;
+
+: available! ( addr size available-ptr -- )
+ dup -rot available>size! available>address!
+;
+
+: available@ ( available-ptr -- addr size )
+ dup available>address@ swap available>size@
+;
+
+
+\ \\\\\\\\\\\\\\ Implementation Independent Methods (Depend on Previous)
+\ +
+\ Warning: They are not yet really independent from available formatting
+\ +
+
+\ +
+\ Find position in the "available" where given range exists or can be inserted,
+\ return pointer and logical found/notfound value
+\ If error, return NULL pointer in addition to notfound code
+\ +
+: (?available-segment<) ( start1 end1 start2 end2 -- true/false ) drop < nip ;
+
+: (?available-segment>) ( start1 end1 start2 end2 -- true/false ) -rot 2drop > ;
+
+\ start1 to end1 is the area that should be claimed
+\ start2 to end2 is the available segment
+\ return true if it can not be claimed, false if it can be claimed
+: (?available-segment-#) ( start1 end1 start2 end2 -- true/false )
+ 2dup 5 roll -rot ( e1 s2 e2 s1 s2 e2 )
+ between >r between r> and not
+;
+
+: (find-available) ( addr addr+size-1 a-ptr a-size -- a-ptr' found )
+ ?dup 0= IF -rot 2drop false EXIT THEN \ Not Found
+
+ 2dup 2/ dup >r /available * +
+ ( addr addr+size-1 a-ptr a-size a-ptr' R: a-size' )
+ dup available>size@ 0= IF 2drop r> RECURSE EXIT THEN
+
+ ( addr addr+size-1 a-ptr a-size a-ptr' R: a-size' )
+ dup >r available@
+ ( addr addr+size-1 a-ptr a-size addr' size' R: a-size' a-ptr' )
+ over + 1- 2>r 2swap
+ ( a-ptr a-size addr addr+size-1 )
+ ( R: a-size' a-ptr' addr' addr'+size'-1 )
+
+ 2dup 2r@ (?available-segment>) IF
+ 2swap 2r> 2drop r>
+ /available + -rot r> - 1- nip RECURSE EXIT \ Look Right
+ THEN
+ 2dup 2r@ (?available-segment<) IF
+ 2swap 2r> 2drop r>
+ 2drop r> RECURSE EXIT \ Look Left
+ THEN
+ 2dup 2r@ (?available-segment-#) IF \ Conflict - segments overlap
+ 2r> 2r> 3drop 3drop 2drop
+ 1212 throw
+ THEN
+ 2r> 3drop 3drop r> r> drop ( a-ptr' -- )
+ dup available>size@ 0<> ( a-ptr' found -- )
+;
+
+: (find-available) ( addr size -- seg-ptr found )
+ over + 1- available AVAILABLE-SIZE ['] (find-available) catch IF
+ 2drop 2drop 0 false
+ THEN
+;
+
+
+: dump-available ( available-ptr -- )
+ cr
+ dup available - /available / AVAILABLE-SIZE swap - 0 ?DO
+ dup available@ ?dup 0= IF
+ 2drop UNLOOP EXIT
+ THEN
+ swap . . cr
+ /available +
+ LOOP
+ dup
+;
+
+: .available available dump-available ;
+
+\ +
+\ release utils:
+\ +
+
+\ +
+\ (drop-available) just blindly compresses space of available map
+\ +
+: (drop-available) ( available-ptr -- )
+ dup available - /available / \ current element index
+ AVAILABLE-SIZE swap - \ # of remaining elements
+
+ ( first nelements ) 1- 0 ?DO
+ dup /available + dup available@
+
+ ( current next next>address next>size ) ?dup 0= IF
+ 2drop LEAVE \ NULL element - goto last copy
+ THEN
+ 3 roll available! ( next )
+ LOOP
+
+ \ Last element : just zero it out
+ 0 0 rot available!
+;
+
+\ +
+\ (stick-to-previous-available) merge the segment on stack
+\ with the previous one, if possible, and modified segment parameters if merged
+\ Return success code
+\ +
+: (stick-to-previous-available) ( addr size available-ptr -- naddr nsize nptr success )
+ dup available = IF
+ false EXIT \ This was the first available segment
+ THEN
+
+ dup /available - dup available@
+ + 4 pick = IF
+ nip \ Drop available-ptr since we are going to previous one
+ rot drop \ Drop start addr, we take the previous one
+
+ dup available@ 3 roll + rot true
+ ( prev-addr prev-size+size prev-ptr true )
+ ELSE
+ drop false
+ ( addr size available-ptr false )
+ THEN
+;
+
+\ +
+\ (insert-available) just blindly makes space for another element on given
+\ position
+\ +
+\ insert-available should also check adjacent elements and merge if new
+\ region is contiguos w. others
+\ +
+: (insert-available) ( available-ptr -- available-ptr )
+ dup \ current element
+ dup available - /available / \ current element index
+ AVAILABLE-SIZE swap - \ # of remaining elements
+
+ dup 0<= 3 pick available>size@ 0= or IF
+ \ End of "available" or came to an empty element - Exit
+ drop drop EXIT
+ THEN
+
+ over available@ rot
+
+ ( first first/=current/ first>address first>size nelements ) 1- 0 ?DO
+ 2>r
+ ( first current R: current>address current>size )
+
+ /available + dup available@
+ ( first current+1/=next/ next>address next>size )
+ ( R: current>address current>size )
+
+ 2r> 4 pick available! dup 0= IF
+ \ NULL element - last copy
+ rot /available + available!
+ UNLOOP EXIT
+ THEN
+ LOOP
+
+ ( first next/=last/ last[0]>address last[0]>size ) ?dup 0<> IF
+ cr ." release error: available map overflow"
+ cr ." Dumping available property"
+ .available
+ cr ." No space for one before last entry:" cr swap . .
+ cr ." Dying ..." cr 123 throw
+ THEN
+
+ 2drop
+;
+
+: insert-available ( addr size available-ptr -- addr size available-ptr )
+ dup available>address@ 0<> IF
+ \ Not empty :
+ dup available>address@ rot dup -rot -
+
+ ( addr available-ptr size available>address@-size )
+
+ 3 pick = IF \ if (available>address@ - size == addr)
+ \ Merge w. next segment - no insert needed
+
+ over available>size@ + swap
+ ( addr size+available>size@ available-ptr )
+
+ (stick-to-previous-available) IF
+ \ Merged w. prev & next one : discard extra seg
+ dup /available + (drop-available)
+ THEN
+ ELSE
+ \ shift the rest of "available" to make space
+
+ swap (stick-to-previous-available)
+ not IF (insert-available) THEN
+ THEN
+ ELSE
+ (stick-to-previous-available) drop
+ THEN
+;
+
+defer release
+
+\ +
+\ claim utils:
+\ +
+: drop-available ( addr size available-ptr -- addr )
+ dup >r available@
+ ( req_addr req_size segment_addr segment_size R: available-ptr )
+
+ over 4 pick swap - ?dup 0<> IF
+ \ Segment starts before requested address : free the head space
+ dup 3 roll swap r> available! -
+
+ ( req_addr req_size segment_size-segment_addr+req_addr )
+ over - ?dup 0= IF
+ \ That's it - remainder of segment is what we claim
+ drop
+ ELSE
+ \ Both head and tail of segment remain unclaimed :
+ \ need an extra available element
+ swap 2 pick + swap release
+ THEN
+ ELSE
+ nip ( req_addr req_size segment_size )
+ over - ?dup 0= IF
+ \ Exact match : drop the whole available segment
+ drop r> (drop-available)
+ ELSE
+ \ We claimed the head, need to leave the tail available
+ -rot over + rot r> available!
+ THEN
+ THEN
+ ( base R: -- )
+;
+
+: pwr2roundup ( value -- pwr2value )
+ dup CASE
+ 0 OF EXIT ENDOF
+ 1 OF EXIT ENDOF
+ ENDCASE
+ dup 1 DO drop i dup +LOOP
+ dup +
+;
+
+: (claim-best-fit) ( len align -- len base )
+ pwr2roundup 1- -1 -1
+ ( len align-1 best-fit-residue/=-1/ best-fit-base/=-1/ )
+
+ available AVAILABLE-SIZE /available * + available DO
+ i \ Must be saved now, before we use Return stack
+ -rot >r >r swap >r
+
+ ( len i R: best-fit-base best-fit-residue align-1 )
+
+ available@ ?dup 0= IF drop r> r> r> LEAVE THEN \ EOL
+
+ 2 pick - dup 0< IF
+ 2drop \ Can't Fit: Too Small
+ ELSE
+ dup 2 pick r@ and - 0< IF
+ 2drop \ Can't Fit When Aligned
+ ELSE
+ ( len i>address i>size-len )
+ ( R: best-fit-base best-fit-residue align-1 )
+ r> -rot dup r@ U< IF
+ \ Best Fit so far: drop the old one
+ 2r> 2drop
+
+ ( len align-1 nu-base nu-residue R: )
+ \ Now align new base and push to R:
+ swap 2 pick + 2 pick invert and >r >r >r
+ ELSE
+ 2drop >r
+ THEN
+ THEN
+ THEN
+ r> r> r>
+ /available +LOOP
+
+ -rot 2drop ( len best-fit-base/or -1 if none found/ )
+;
+
+: (adjust-release0) ( 0 size -- addr' size' )
+ \ segment 0 already pre-relased in early phase: adjust
+ 2dup MIN-RAM-SIZE dup 3 roll + -rot -
+ dup 0< IF 2drop ELSE
+ 2swap 2drop 0 mem-pre-released !
+ THEN
+;
+
+
+\ \\\\\\\\\\\\\\ Exported Interface:
+\ +
+\ IEEE 1275 implementation:
+\ claim
+\ Claim the region with given start address and size (if align parameter is 0);
+\ alternatively claim any region of given alignment
+\ +
+\ Throw an exception if failed
+\ +
+: claim ( [ addr ] len align -- base )
+ ?dup 0<> IF
+ (claim-best-fit) dup -1 = IF
+ 2drop cr ." claim error : aligned allocation failed" cr
+ ." available:" cr .available
+ 321 throw EXIT
+ THEN
+ swap
+ THEN
+
+ 2dup (find-available) not IF
+ drop
+\ cr ." claim error : requested " . ." bytes of memory at " .
+\ ." not available" cr
+\ ." available:" cr .available
+ 2drop
+ 321 throw EXIT
+ THEN
+ ( req_addr req_size available-ptr ) drop-available
+
+ ( req_addr )
+;
+
+
+\ +
+\ IEEE 1275 implementation:
+\ release
+\ Free the region with given start address and size
+\ +
+: .release ( addr len -- )
+ over 0= mem-pre-released @ and IF (adjust-release0) THEN
+
+ 2dup (find-available) IF
+ drop swap
+ cr ." release error: region " . ." , " . ." already released" cr
+ ELSE
+ ?dup 0= IF
+ swap
+ cr ." release error: Bad/conflicting region " . ." , " .
+ ." or available list full " cr
+ ELSE
+ ( addr size available-ptr ) insert-available
+
+ \ NOTE: insert did not change the stack layout
+ \ but it may have changed any of the three values
+ \ in order to implement merge of free regions
+ \ We do not interpret these values any more
+ \ just blindly copy it in
+
+ ( addr size available-ptr ) available!
+ THEN
+ THEN
+;
+
+' .release to release
+
+
+\ pre-release minimal memory size
+0 MIN-RAM-SIZE release 1 mem-pre-released !
+
+\ claim first pages used for PPC exception vectors
+0 MIN-RAM-RESERVE 0 ' claim CATCH IF ." claim failed!" cr 2drop THEN drop
+
+\ claim region used by firmware (assume 31 MiB size right now)
+paflof-start ffff not and 1f00000 0 ' claim CATCH IF
+ ." claim failed!" cr 2drop
+THEN drop
diff --git a/qemu/roms/SLOF/slof/fs/client.fs b/qemu/roms/SLOF/slof/fs/client.fs
new file mode 100644
index 000000000..1b2bb0326
--- /dev/null
+++ b/qemu/roms/SLOF/slof/fs/client.fs
@@ -0,0 +1,299 @@
+\ *****************************************************************************
+\ * Copyright (c) 2004, 2008 IBM Corporation
+\ * All rights reserved.
+\ * This program and the accompanying materials
+\ * are made available under the terms of the BSD License
+\ * which accompanies this distribution, and is available at
+\ * http://www.opensource.org/licenses/bsd-license.php
+\ *
+\ * Contributors:
+\ * IBM Corporation - initial implementation
+\ ****************************************************************************/
+
+
+\ Client interface.
+
+0 VALUE debug-client-interface?
+
+\ First, the machinery.
+
+VOCABULARY client-voc \ We store all client-interface callable words here.
+
+6789 CONSTANT sc-exit
+4711 CONSTANT sc-yield
+
+VARIABLE client-callback \ Address of client's callback function
+
+: client-data ciregs >r3 @ ;
+: nargs client-data la1+ l@ ;
+: nrets client-data la1+ la1+ l@ ;
+: client-data-to-stack
+ client-data 3 la+ nargs 0 ?DO dup l@ swap la1+ LOOP drop ;
+: stack-to-client-data
+ client-data nargs nrets + 2 + la+ nrets 0 ?DO tuck l! /l - LOOP drop ;
+
+: call-client ( args len client-entry -- )
+ \ (args, len) describe the argument string, client-entry is the address of
+ \ the client's .entry symbol, i.e. where we eventually branch to.
+ \ ciregs is a variable that describes the register set of the host processor,
+ \ see slof/fs/exception.fs for details
+ \ client-entry-point maps to client_entry_point in slof/entry.S which is
+ \ the SLOF entry point when calling a SLOF client interface word from the
+ \ client.
+ \ We pass the arguments for the client in R6 and R7, the client interface
+ \ entry point address is passed in R5.
+ >r ciregs >r7 ! ciregs >r6 ! client-entry-point @ ciregs >r5 !
+ \ Initialise client-stack-pointer
+ cistack ciregs >r1 !
+ \ jump-client maps to call_client in slof/entry.S
+ \ When jump-client returns, R3 holds the address of a NUL-terminated string
+ \ that holds the client interface word the client wants to call, R4 holds
+ \ the return address.
+ r> jump-client drop
+ BEGIN
+ client-data-to-stack
+ \ Now create a Forth-style string, look it up in the client dictionary and
+ \ execute it, guarded by CATCH. Result of xt == 0 is stored on the return
+ \ stack
+ client-data l@ zcount
+ \ XXX: Should only look in client-voc...
+ ALSO client-voc $find PREVIOUS
+ dup 0= >r IF
+ CATCH
+ \ If a client interface word needs some special treatment, like exit and
+ \ yield, then the implementation needs to use THROW to indicate its needs
+ ?dup IF
+ dup CASE
+ sc-exit OF drop r> drop EXIT ENDOF
+ sc-yield OF drop r> drop EXIT ENDOF
+ ENDCASE
+ \ Some special call was made but we don't know that to do with it...
+ THROW
+ THEN
+ stack-to-client-data
+ ELSE
+ cr type ." NOT FOUND"
+ THEN
+ \ Return to the client
+ r> ciregs >r3 ! ciregs >r4 @ jump-client
+ UNTIL ;
+
+: flip-stack ( a1 ... an n -- an ... a1 ) ?dup IF 1 ?DO i roll LOOP THEN ;
+
+: (callback) ( "service-name<>" "arguments<cr>" -- )
+ client-callback @ \ client-callback points to the function prolog
+ dup 8 + @ ciregs >r2 ! \ Set up the TOC pointer (???)
+ @ call-client ; \ Resolve the function's address from the prolog
+' (callback) to callback
+
+: (continue-client)
+ s" " \ make call-client happy, client won't use the string anyways.
+ ciregs >r4 @ call-client ;
+' (continue-client) to continue-client
+
+\ Utility.
+: string-to-buffer ( str len buf len -- len' )
+ 2dup erase rot min dup >r move r> ;
+
+\ Now come the actual client interface words.
+
+ALSO client-voc DEFINITIONS
+
+: exit sc-exit THROW ;
+
+: yield sc-yield THROW ;
+
+: test ( zstr -- missing? )
+ \ XXX: Should only look in client-voc...
+ zcount
+ debug-client-interface? IF
+ ." ci: test " 2dup type cr
+ THEN
+ ALSO client-voc $find PREVIOUS IF
+ drop FALSE
+ ELSE
+ 2drop TRUE
+ THEN
+;
+
+: finddevice ( zstr -- phandle )
+ zcount
+ debug-client-interface? IF
+ ." ci: finddevice " 2dup type cr
+ THEN
+ 2dup " /memory" str= IF
+ \ Workaround: grub passes /memory instead of /memory@0
+ 2drop
+ " /memory@0"
+ THEN
+ find-node dup 0= IF drop -1 THEN
+;
+
+: getprop ( phandle zstr buf len -- len' )
+ >r >r zcount rot ( str-adr str-len phandle R: len buf )
+ debug-client-interface? IF
+ ." ci: getprop " 3dup . ." '" type ." '"
+ THEN
+ get-property
+ debug-client-interface? IF
+ dup IF ." ** not found **" THEN
+ cr
+ THEN
+ 0= IF
+ r> swap dup r> min swap >r move r>
+ ELSE
+ r> r> 2drop -1
+ THEN
+;
+
+: getproplen ( phandle zstr -- len )
+ zcount rot get-property 0= IF nip ELSE -1 THEN ;
+
+: setprop ( phandle zstr buf len -- size|-1 )
+ dup >r \ save len
+ encode-bytes ( phandle zstr prop-addr prop-len )
+ 2swap zcount rot ( prop-addr prop-len name-addr name-len phandle )
+ current-node @ >r \ save current node
+ set-node \ change to specified node
+ property \ set property
+ r> set-node \ restore original node
+ r> \ always return size, because we can not fail.
+;
+
+\ VERY HACKISH
+: canon ( zstr buf len -- len' )
+ 2dup erase
+ >r >r zcount
+ >r dup c@ [char] / = IF
+ r> r> swap r> over >r min move r>
+ ELSE
+ r> find-alias ?dup 0= IF
+ r> r> 2drop -1
+ ELSE
+ dup -rot r> swap r> min move
+ THEN
+ THEN
+;
+
+: nextprop ( phandle zstr buf -- flag ) \ -1 invalid, 0 end, 1 ok
+ >r zcount rot next-property IF r> zplace 1 ELSE r> drop 0 THEN ;
+
+: open ( zstr -- ihandle )
+ zcount
+ debug-client-interface? IF
+ ." ci: open " 2dup type cr
+ THEN
+ open-dev
+;
+
+: close ( ihandle -- )
+ debug-client-interface? IF
+ ." ci: close " dup . cr
+ THEN
+ s" stdin" get-chosen IF
+ decode-int nip nip over = IF
+ \ End of life of SLOF now, call platform quiesce as quiesce
+ \ is an undocumented extension and not everybody supports it
+ close-dev
+ quiesce
+ ELSE
+ close-dev
+ THEN
+ ELSE
+ close-dev
+ THEN
+;
+
+\ Now implemented: should return -1 if no such method exists in that node
+: write ( ihandle str len -- len' ) rot s" write" rot
+ ['] $call-method CATCH IF 2drop 3drop -1 THEN ;
+: read ( ihandle str len -- len' ) rot s" read" rot
+ ['] $call-method CATCH IF 2drop 3drop -1 THEN ;
+: seek ( ihandle hi lo -- status ) swap rot s" seek" rot
+ ['] $call-method CATCH IF 2drop 3drop -1 THEN ;
+
+\ A real claim implementation: 3.2% memory fat :-)
+: claim ( addr len align -- base )
+ debug-client-interface? IF
+ ." ci: claim " .s cr
+ THEN
+ dup IF rot drop
+ ['] claim CATCH IF 2drop -1 THEN
+ ELSE
+ ['] claim CATCH IF 3drop -1 THEN
+ THEN
+;
+
+: release ( addr len -- )
+ debug-client-interface? IF
+ ." ci: release " .s cr
+ THEN
+ release
+;
+
+: instance-to-package ( ihandle -- phandle )
+ ihandle>phandle ;
+
+: package-to-path ( phandle buf len -- len' )
+ 2>r node>path 2r> string-to-buffer ;
+: instance-to-path ( ihandle buf len -- len' )
+ 2>r instance>path 2r> string-to-buffer ;
+: instance-to-interposed-path ( ihandle buf len -- len' )
+ 2>r instance>qpath 2r> string-to-buffer ;
+
+: call-method ( str ihandle arg ... arg -- result return ... return )
+ nargs flip-stack zcount
+ debug-client-interface? IF
+ ." ci: call-method " 2dup type cr
+ THEN
+ rot ['] $call-method CATCH
+ nrets 0= IF drop ELSE \ if called with 0 return args do not return the catch result
+ dup IF nrets 1 ?DO -444 LOOP THEN
+ nrets flip-stack
+ THEN
+;
+
+\ From the PAPR.
+: test-method ( phandle str -- missing? )
+ zcount
+ debug-client-interface? IF
+ ." ci: test-method " 2dup type cr
+ THEN
+ rot find-method dup IF nip THEN 0=
+;
+
+: milliseconds milliseconds ;
+
+: start-cpu ( phandle addr r3 -- )
+ >r >r
+ s" reg" rot get-property 0= IF drop l@
+ ELSE true ABORT" start-cpu called with invalid phandle" THEN
+ r> r> of-start-cpu drop
+;
+
+\ Quiesce firmware and assert that all hardware is in a sane state
+\ (e.g. assert that no background DMA is running anymore)
+: quiesce ( -- )
+ debug-client-interface? IF
+ ." ci: quiesce" cr
+ THEN
+ \ The main quiesce call is defined in quiesce.fs
+ quiesce
+;
+
+\
+\ User Interface, defined in 6.3.2.6
+\
+: interpret ( ... zstr -- result ... )
+ zcount
+ debug-client-interface? IF
+ ." ci: interpret " 2dup type cr
+ THEN
+ ['] evaluate CATCH
+;
+
+\ Allow the client to register a callback
+: set-callback ( newfunc -- oldfunc )
+ client-callback @ swap client-callback ! ;
+
+PREVIOUS DEFINITIONS
diff --git a/qemu/roms/SLOF/slof/fs/debug.fs b/qemu/roms/SLOF/slof/fs/debug.fs
new file mode 100644
index 000000000..e54f729fe
--- /dev/null
+++ b/qemu/roms/SLOF/slof/fs/debug.fs
@@ -0,0 +1,422 @@
+\ *****************************************************************************
+\ * Copyright (c) 2004, 2008 IBM Corporation
+\ * All rights reserved.
+\ * This program and the accompanying materials
+\ * are made available under the terms of the BSD License
+\ * which accompanies this distribution, and is available at
+\ * http://www.opensource.org/licenses/bsd-license.php
+\ *
+\ * Contributors:
+\ * IBM Corporation - initial implementation
+\ ****************************************************************************/
+
+
+\ Get the name of Forth command whose execution token is xt
+
+: xt>name ( xt -- str len )
+ BEGIN
+ cell - dup c@ 0 2 within IF
+ dup 2+ swap 1+ c@ exit
+ THEN
+ AGAIN
+;
+
+cell -1 * CONSTANT -cell
+: cell- ( n -- n-cell-size )
+ [ cell -1 * ] LITERAL +
+;
+
+\ Search for xt of given address
+: find-xt-addr ( addr -- xt )
+ BEGIN
+ dup @ <colon> = IF
+ EXIT
+ THEN
+ cell-
+ AGAIN
+;
+
+: (.immediate) ( xt -- )
+ \ is it immediate?
+ xt>name drop 2 - c@ \ skip len and flags
+ immediate? IF
+ ." IMMEDIATE"
+ THEN
+;
+
+: (.xt) ( xt -- )
+ xt>name type
+;
+
+\ Trace back on current return stack.
+\ Start at 1, since 0 is return of trace-back itself
+
+: trace-back ( )
+ 1
+ BEGIN
+ cr dup dup . ." : " rpick dup . ." : "
+ ['] tib here within IF
+ dup rpick find-xt-addr (.xt)
+ THEN
+ 1+ dup rdepth 5 - >= IF cr drop EXIT THEN
+ AGAIN
+;
+
+VARIABLE see-my-type-column
+
+: (see-my-type) ( indent limit xt str len -- indent limit xt )
+ dup see-my-type-column @ + dup 50 >= IF
+ -rot over " " comp 0= IF
+ \ blank causes overflow: just enforce new line with next call
+ 2drop see-my-type-column !
+ ELSE
+ rot drop ( indent limit xt str len )
+ \ Need to copy string since we use (u.) again (kills internal buffer):
+ pocket swap 2dup >r >r ( indent limit xt str pk len R: len pk )
+ move r> r> ( indent limit xt pk len )
+ 2 pick (u.) dup -rot
+ cr type ( indent limit xt pk len xt-len )
+ " :" type 1+ ( indent limit xt pk len prefix-len )
+ 5 pick dup spaces + ( indent limit xt pk len prefix-len )
+ over + see-my-type-column ! ( indent limit xt pk len )
+ type
+ THEN ( indent limit xt )
+ ELSE
+ see-my-type-column ! type ( indent limit xt )
+ THEN
+;
+
+: (see-my-type-init) ( -- )
+ ffff see-my-type-column ! \ just enforce a new line
+;
+
+: (see-colon-body) ( indent limit xt -- indent limit xt )
+ (see-my-type-init) \ enforce new line
+ BEGIN ( indent limit xt )
+ cell+ 2dup <>
+ over @
+ dup <semicolon> <>
+ rot and ( indent limit xt @xt flag )
+ WHILE ( indent limit xt @xt )
+ xt>name (see-my-type) " " (see-my-type)
+ dup @ ( indent limit xt @xt)
+ CASE
+ <0branch> OF cell+ dup @
+ over + cell+ dup >r
+ (u.) (see-my-type) r> ( indent limit xt target)
+ 2dup < IF
+ over 4 pick 3 + -rot recurse
+ nip nip nip cell- ( indent limit xt )
+ ELSE
+ drop ( indent limit xt )
+ THEN
+ (see-my-type-init) ENDOF \ enforce new line
+ <branch> OF cell+ dup @ over + cell+ (u.)
+ (see-my-type) " " (see-my-type) ENDOF
+ <do?do> OF cell+ dup @ (u.) (see-my-type)
+ " " (see-my-type) ENDOF
+ <lit> OF cell+ dup @ (u.) (see-my-type)
+ " " (see-my-type) ENDOF
+ <dotick> OF cell+ dup @ xt>name (see-my-type)
+ " " (see-my-type) ENDOF
+ <doloop> OF cell+ dup @ (u.) (see-my-type)
+ " " (see-my-type) ENDOF
+ <do+loop> OF cell+ dup @ (u.) (see-my-type)
+ " " (see-my-type) ENDOF
+ <doleave> OF cell+ dup @ over + cell+ (u.)
+ (see-my-type) " " (see-my-type) ENDOF
+ <do?leave> OF cell+ dup @ over + cell+ (u.)
+ (see-my-type) " " (see-my-type) ENDOF
+ <sliteral> OF cell+ " """ (see-my-type) dup count dup >r
+ (see-my-type) " """ (see-my-type)
+ " " (see-my-type)
+ r> -cell and + ENDOF
+ ENDCASE
+ REPEAT
+ drop
+;
+
+: (see-colon) ( xt -- )
+ (see-my-type-init)
+ 1 swap 0 swap ( indent limit xt )
+ " : " (see-my-type) dup xt>name (see-my-type)
+ rot drop 4 -rot (see-colon-body) ( indent limit xt )
+ rot drop 1 -rot (see-my-type-init) " ;" (see-my-type)
+ 3drop
+;
+
+\ Create words are a bit tricky. We find out where their code points.
+\ If this code is part of SLOF, it is not a user generated CREATE.
+
+: (see-create) ( xt -- )
+ dup cell+ @
+ CASE
+ <2constant> OF
+ dup cell+ cell+ dup @ swap cell+ @ . . ." 2CONSTANT "
+ ENDOF
+
+ <instancevalue> OF
+ dup cell+ cell+ @ . ." INSTANCE VALUE "
+ ENDOF
+
+ <instancevariable> OF
+ ." INSTANCE VARIABLE "
+ ENDOF
+
+ dup OF
+ ." CREATE "
+ ENDOF
+ ENDCASE
+ (.xt)
+;
+
+\ Decompile Forth command whose execution token is xt
+
+: (see) ( xt -- )
+ cr dup dup @
+ CASE
+ <variable> OF ." VARIABLE " (.xt) ENDOF
+ <value> OF dup execute . ." VALUE " (.xt) ENDOF
+ <constant> OF dup execute . ." CONSTANT " (.xt) ENDOF
+ <defer> OF dup cell+ @ swap ." DEFER " (.xt) ." is " (.xt) ENDOF
+ <alias> OF dup cell+ @ swap ." ALIAS " (.xt) ." " (.xt) ENDOF
+ <buffer:> OF ." BUFFER: " (.xt) ENDOF
+ <create> OF (see-create) ENDOF
+ <colon> OF (see-colon) ENDOF
+ dup OF ." ??? PRIM " (.xt) ENDOF
+ ENDCASE
+ (.immediate) cr
+ ;
+
+\ Decompile Forth command old-name
+
+: see ( "old-name<>" -- )
+ ' (see)
+;
+
+\ Work in progress...
+
+0 value forth-ip
+true value trace>stepping?
+true value trace>print?
+true value trace>up?
+0 value trace>depth
+0 value trace>rdepth
+0 value trace>recurse
+: trace-depth+ ( -- ) trace>depth 1+ to trace>depth ;
+: trace-depth- ( -- ) trace>depth 1- to trace>depth ;
+
+: stepping ( -- )
+ true to trace>stepping?
+;
+
+: tracing ( -- )
+ false to trace>stepping?
+;
+
+: trace-print-on ( -- )
+ true to trace>print?
+;
+
+: trace-print-off ( -- )
+ false to trace>print?
+;
+
+
+\ Add n to ip
+
+: fip-add ( n -- )
+ forth-ip + to forth-ip
+;
+
+\ Save execution token address and content
+
+0 value debug-last-xt
+0 value debug-last-xt-content
+
+: trace-print ( -- )
+ forth-ip cr u. ." : "
+ forth-ip @
+ dup ['] breakpoint = IF drop debug-last-xt-content THEN
+ xt>name type ." "
+ ." ( " .s ." ) | "
+;
+
+: trace-interpret ( -- )
+ rdepth 1- to trace>rdepth
+ BEGIN
+ depth . [char] > dup emit emit space
+ source expect ( str len )
+ ['] interpret catch print-status
+ AGAIN
+;
+
+\ Main trace routine, trace a colon definition
+
+: trace-xt ( xt -- )
+ trace>recurse IF
+ r> drop \ Drop return of 'trace-xt call
+ cell+ \ Step over ":"
+ ELSE
+ debug-last-xt-content <colon> = IF
+ \ debug colon-definition
+ ['] breakpoint @ debug-last-xt ! \ Re-arm break point
+ r> drop \ Drop return of 'trace-xt call
+ cell+ \ Step over ":"
+ ELSE
+ ['] breakpoint debug-last-xt ! \ Re-arm break point
+ 2r> 2drop
+ THEN
+ THEN
+
+ to forth-ip
+ true to trace>print?
+ BEGIN
+ trace>print? IF trace-print THEN
+
+ forth-ip ( ip )
+ trace>stepping? IF
+ BEGIN
+ key
+ CASE
+ [char] d OF dup @ @ <colon> = IF \ recurse only into colon definitions
+ trace-depth+
+ 1 to trace>recurse
+ dup >r @ recurse
+ THEN true ENDOF
+ [char] u OF trace>depth IF tracing trace-print-off true ELSE false THEN ENDOF
+ [char] f OF drop cr trace-interpret ENDOF \ quit trace and start interpreter FIXME rstack
+ [char] c OF tracing true ENDOF
+ [char] t OF trace-back false ENDOF
+ [char] q OF drop cr quit ENDOF
+ 20 OF true ENDOF
+ dup OF cr ." Press d: Down into current word" cr
+ ." Press u: Up to caller" cr
+ ." Press f: Switch to forth interpreter, 'resume' will continue tracing" cr
+ ." Press c: Switch to tracing" cr
+ ." Press <space>: Execute current word" cr
+ ." Press q: Abort execution, switch to interpreter" cr
+ false ENDOF
+ ENDCASE
+ UNTIL
+ THEN ( ip' )
+ dup to forth-ip @ ( xt )
+ dup ['] breakpoint = IF drop debug-last-xt-content THEN
+ dup ( xt xt )
+
+ CASE
+ <sliteral> OF drop forth-ip cell+ dup dup c@ + -cell and to forth-ip ENDOF
+ <dotick> OF drop forth-ip cell+ @ cell fip-add ENDOF
+ <lit> OF drop forth-ip cell+ @ cell fip-add ENDOF
+ <doto> OF drop forth-ip cell+ @ cell+ ! cell fip-add ENDOF
+ <(doito)> OF drop forth-ip cell+ @ cell+ cell+ @ >instance ! cell fip-add ENDOF
+ <0branch> OF drop IF
+ cell fip-add
+ ELSE
+ forth-ip cell+ @ cell+ fip-add THEN
+ ENDOF
+ <do?do> OF drop 2dup <> IF
+ swap >r >r cell fip-add
+ ELSE
+ forth-ip cell+ @ cell+ fip-add 2drop THEN
+ ENDOF
+ <branch> OF drop forth-ip cell+ @ cell+ fip-add ENDOF
+ <doleave> OF drop r> r> 2drop forth-ip cell+ @ cell+ fip-add ENDOF
+ <do?leave> OF drop IF
+ r> r> 2drop forth-ip cell+ @ cell+ fip-add
+ ELSE
+ cell fip-add
+ THEN
+ ENDOF
+ <doloop> OF drop r> 1+ r> 2dup = IF
+ 2drop cell fip-add
+ ELSE >r >r
+ forth-ip cell+ @ cell+ fip-add THEN
+ ENDOF
+ <do+loop> OF drop r> + r> 2dup >= IF
+ 2drop cell fip-add
+ ELSE >r >r
+ forth-ip cell+ @ cell+ fip-add THEN
+ ENDOF
+
+ <semicolon> OF trace>depth 0> IF
+ trace-depth- 1 to trace>recurse
+ stepping drop r> recurse
+ ELSE
+ drop exit THEN
+ ENDOF
+ <exit> OF trace>depth 0> IF
+ trace-depth- stepping drop r> recurse
+ ELSE
+ drop exit THEN
+ ENDOF
+ dup OF execute ENDOF
+ ENDCASE
+ forth-ip cell+ to forth-ip
+ AGAIN
+;
+
+\ Resume execution from tracer
+: resume ( -- )
+ trace>rdepth rdepth!
+ forth-ip cell - trace-xt
+;
+
+\ Turn debug off, by erasing breakpoint
+
+: debug-off ( -- )
+ debug-last-xt IF
+ debug-last-xt-content debug-last-xt ! \ Restore overwritten token
+ 0 to debug-last-xt
+ THEN
+;
+
+
+
+\ Entry point for debug
+
+: (break-entry) ( -- )
+ debug-last-xt dup @ ['] breakpoint <> swap ( debug-addr? debug-last-xt )
+ debug-last-xt-content swap ! \ Restore overwritten token
+ r> drop \ Don't return to bp, but to caller
+ debug-last-xt-content <colon> <> and IF \ Execute non colon definition
+ debug-last-xt cr u. ." : "
+ debug-last-xt xt>name type ." "
+ ." ( " .s ." ) | "
+ key drop
+ debug-last-xt execute
+ ELSE
+ debug-last-xt 0 to trace>depth 0 to trace>recurse trace-xt \ Trace colon definition
+ THEN
+;
+
+\ Put entry point bp defer
+' (break-entry) to BP
+
+\ Mark an address for debugging
+
+: debug-address ( addr -- )
+ debug-off ( xt ) \ Remove active breakpoint
+ dup to debug-last-xt ( xt ) \ Save token for later debug
+ dup @ to debug-last-xt-content ( xt ) \ Save old value
+ ['] breakpoint swap !
+;
+
+\ Mark the command indicated by xt for debugging
+
+: (debug ( xt -- )
+ debug-off ( xt ) \ Remove active breakpoint
+ dup to debug-last-xt ( xt ) \ Save token for later debug
+ dup @ to debug-last-xt-content ( xt ) \ Save old value
+ ['] breakpoint @ swap !
+;
+
+\ Mark the command indicated by xt for debugging
+
+: debug ( "old-name<>" -- )
+ parse-word $find IF \ Get xt for old-name
+ (debug
+ ELSE
+ ." undefined word " type cr
+ THEN
+;
diff --git a/qemu/roms/SLOF/slof/fs/devices/pci-class_02.fs b/qemu/roms/SLOF/slof/fs/devices/pci-class_02.fs
new file mode 100644
index 000000000..271420f03
--- /dev/null
+++ b/qemu/roms/SLOF/slof/fs/devices/pci-class_02.fs
@@ -0,0 +1,37 @@
+\ *****************************************************************************
+\ * Copyright (c) 2004, 2008 IBM Corporation
+\ * All rights reserved.
+\ * This program and the accompanying materials
+\ * are made available under the terms of the BSD License
+\ * which accompanies this distribution, and is available at
+\ * http://www.opensource.org/licenses/bsd-license.php
+\ *
+\ * Contributors:
+\ * IBM Corporation - initial implementation
+\ ****************************************************************************/
+
+s" network [ " type my-space pci-class-name type s" ]" type
+
+my-space pci-device-generic-setup
+my-space pci-alias-net
+
+s" network" device-type
+
+cr
+
+INSTANCE VARIABLE obp-tftp-package
+: open ( -- okay? )
+ open IF \ enables PCI mem, io and Bus master and returns TRUE
+ my-args s" obp-tftp" $open-package obp-tftp-package ! true
+ ELSE
+ false
+ THEN ;
+
+: close ( -- )
+ obp-tftp-package @ close-package
+ close ; \ disables PCI mem, io and Bus master
+
+: load ( addr -- len )
+ s" load" obp-tftp-package @ $call-method ;
+
+: ping ( -- ) s" ping" obp-tftp-package @ $call-method ;
diff --git a/qemu/roms/SLOF/slof/fs/devices/pci-class_0c.fs b/qemu/roms/SLOF/slof/fs/devices/pci-class_0c.fs
new file mode 100644
index 000000000..39453fbc0
--- /dev/null
+++ b/qemu/roms/SLOF/slof/fs/devices/pci-class_0c.fs
@@ -0,0 +1,71 @@
+\ *****************************************************************************
+\ * Copyright (c) 2004, 2011 IBM Corporation
+\ * All rights reserved.
+\ * This program and the accompanying materials
+\ * are made available under the terms of the BSD License
+\ * which accompanies this distribution, and is available at
+\ * http://www.opensource.org/licenses/bsd-license.php
+\ *
+\ * Contributors:
+\ * IBM Corporation - initial implementation
+\ ****************************************************************************/
+
+s" serial bus [ " type my-space pci-class-name type s" ]" type cr
+
+my-space pci-device-generic-setup
+
+STRUCT
+ /n FIELD hcd>base
+ /n FIELD hcd>type
+ /n FIELD hcd>num
+ /n FIELD hcd>ops
+ /n FIELD hcd>priv
+ /n FIELD hcd>nextaddr
+CONSTANT /hci-dev
+
+: usb-setup-hcidev ( num hci-dev -- )
+ >r
+ 10 config-l@ F AND case
+ 0 OF 10 config-l@ translate-my-address ENDOF \ 32-bit memory space
+ 4 OF \ 64-bit memory space
+ 14 config-l@ 20 lshift \ Read two bars
+ 10 config-l@ OR translate-my-address
+ ENDOF
+ ENDCASE
+ F not AND
+ ( io-base ) r@ hcd>base !
+ 08 config-l@ 8 rshift 0000000F0 AND 4 rshift
+ ( usb-type ) r@ hcd>type !
+ ( usb-num ) r@ hcd>num !
+ r> drop
+;
+
+\ Handle USB OHCI controllers:
+: handle-usb-class ( -- )
+ \ set Memory Write and Invalidate Enable, SERR# Enable
+ \ (see PCI 3.0 Spec Chapter 6.2.2 device control):
+ 4 config-w@ 110 or 4 config-w!
+ pci-master-enable \ set PCI Bus master bit and
+ pci-mem-enable \ memory space enable for USB scan
+;
+
+\ Check PCI sub-class and interface type of Serial Bus Controller
+\ to include the appropriate driver:
+: handle-sbc-subclass ( -- )
+ my-space pci-class@ ffff and CASE \ get PCI sub-class and interface
+ 0310 OF \ OHCI controller
+ handle-usb-class
+ set-ohci-alias
+ ENDOF
+ 0320 OF \ EHCI controller
+ handle-usb-class
+ set-ehci-alias
+ ENDOF
+ 0330 OF \ XHCI controller
+ handle-usb-class
+ set-xhci-alias
+ ENDOF
+ ENDCASE
+;
+
+handle-sbc-subclass
diff --git a/qemu/roms/SLOF/slof/fs/devices/pci-device_10de_0141.fs b/qemu/roms/SLOF/slof/fs/devices/pci-device_10de_0141.fs
new file mode 100644
index 000000000..bb3b83516
--- /dev/null
+++ b/qemu/roms/SLOF/slof/fs/devices/pci-device_10de_0141.fs
@@ -0,0 +1,49 @@
+\ *****************************************************************************
+\ * Copyright (c) 2004, 2008 IBM Corporation
+\ * All rights reserved.
+\ * This program and the accompanying materials
+\ * are made available under the terms of the BSD License
+\ * which accompanies this distribution, and is available at
+\ * http://www.opensource.org/licenses/bsd-license.php
+\ *
+\ * Contributors:
+\ * IBM Corporation - initial implementation
+\ ****************************************************************************/
+
+my-space pci-class-name type
+
+my-space pci-device-generic-setup
+
+pci-io-enable
+pci-mem-enable
+
+30 config-l@ pci-find-fcode execute-rom-fcode
+
+: check-display ( nodepath len -- true|false ) \ true if display found and "screen" alias set
+\ check if display available, set screen alias
+2dup find-node \ ( path len phandle|0 ) find node
+?dup IF
+ \ node found, get "display-type" property
+ s" display-type" rot get-property ( path len true|propaddr proplen 0 )
+ 0= IF
+ ( path len propaddr proplen ) \ property found, check if the value is not "NONE"
+ s" NONE" 0 char-cat ( path len propaddr proplen str strlen ) \ null-terminated NONE string
+ str= 0= IF
+ ( path len ) \ "display-type" property is not "NONE" so we can set "screen" alias
+ s" screen" 2swap set-alias
+ true ( true ) \ return true
+ ELSE
+ 2drop false ( false ) \ return false
+ THEN
+ THEN
+THEN
+;
+
+get-node node>path s" /NVDA,DISPLAY-A" $cat check-display
+0= IF
+ \ no display found on DISPLAY-A ... check DISPLAY-B
+ get-node node>path s" /NVDA,DISPLAY-B" $cat check-display
+ drop \ drop result
+THEN
+
+s" name" get-my-property drop s" ( " type type s" ) " type cr
diff --git a/qemu/roms/SLOF/slof/fs/dictionary.fs b/qemu/roms/SLOF/slof/fs/dictionary.fs
new file mode 100644
index 000000000..3e5b29332
--- /dev/null
+++ b/qemu/roms/SLOF/slof/fs/dictionary.fs
@@ -0,0 +1,74 @@
+\ *****************************************************************************
+\ * Copyright (c) 2004, 2008 IBM Corporation
+\ * All rights reserved.
+\ * This program and the accompanying materials
+\ * are made available under the terms of the BSD License
+\ * which accompanies this distribution, and is available at
+\ * http://www.opensource.org/licenses/bsd-license.php
+\ *
+\ * Contributors:
+\ * IBM Corporation - initial implementation
+\ ****************************************************************************/
+
+: words
+ last @
+ BEGIN ?dup WHILE
+ dup cell+ char+ count type space @
+ REPEAT
+;
+
+: .calls ( xt -- )
+ current-node @ >r 0 set-node \ only search commands, according too IEEE1275
+
+ last BEGIN @ ?dup WHILE ( xt currxt )
+ dup cell+ char+ ( xt currxt name* )
+ dup dup c@ + 1+ aligned ( xt currxt name* CFA )
+ dup @ <colon> = IF ( xt currxt name* CFA )
+ BEGIN
+ cell+ dup @ ['] semicolon <>
+ WHILE ( xt currxt *name pos )
+ dup @ 4 pick = IF ( xt currxt *name pos )
+ over count type space
+ BEGIN cell+ dup @ ['] semicolon = UNTIL cell - \ eat up other occurrences
+ THEN
+ REPEAT
+ THEN
+ 2drop ( xt currxt )
+ REPEAT
+ drop
+
+ r> set-node \ restore node
+;
+
+0 value #sift-count
+false value sift-compl-only
+
+: $inner-sift ( text-addr text-len LFA -- ... word-addr word-len true | false )
+ dup cell+ char+ count \ get word name
+ 2dup 6 pick 6 pick find-isubstr \ is there a partly match?
+ \ in tab completion mode the substring has to be at the beginning
+ sift-compl-only IF 0= ELSE over < THEN
+ IF
+ #sift-count 1+ to #sift-count \ count completions
+ true
+ ELSE
+ 2drop false
+ THEN
+;
+
+: $sift ( text-addr text-len -- )
+ current-node @ >r 0 set-node \ only search commands, according too IEEE1275
+ sift-compl-only >r false to sift-compl-only \ all substrings, not only compl.
+ last BEGIN @ ?dup WHILE \ walk the whole dictionary
+ $inner-sift IF type space THEN
+ REPEAT
+ 2drop
+ 0 to #sift-count \ we don't need completions here.
+ r> to sift-compl-only \ restore previous sifting mode
+ r> set-node \ restore node
+;
+
+: sifting ( "text< >" -- )
+ parse-word $sift
+;
+
diff --git a/qemu/roms/SLOF/slof/fs/display.fs b/qemu/roms/SLOF/slof/fs/display.fs
new file mode 100644
index 000000000..5bb8797a2
--- /dev/null
+++ b/qemu/roms/SLOF/slof/fs/display.fs
@@ -0,0 +1,123 @@
+\ *****************************************************************************
+\ * Copyright (c) 2004, 2008 IBM Corporation
+\ * All rights reserved.
+\ * This program and the accompanying materials
+\ * are made available under the terms of the BSD License
+\ * which accompanies this distribution, and is available at
+\ * http://www.opensource.org/licenses/bsd-license.php
+\ *
+\ * Contributors:
+\ * IBM Corporation - initial implementation
+\ ****************************************************************************/
+
+0 VALUE char-height
+0 VALUE char-width
+0 VALUE fontbytes
+
+CREATE display-emit-buffer 20 allot
+
+\ \\\\\\\\\\\\\\ Global Data
+
+\ \\\\\\\\\\\\\\ Structure/Implementation Dependent Methods
+
+\ \\\\\\\\\\\\\\ Implementation Independent Methods (Depend on Previous)
+\ *
+\ *
+defer dis-old-emit
+' emit behavior to dis-old-emit
+
+: display-write terminal-write ;
+: display-emit dup dis-old-emit display-emit-buffer tuck c! 1 terminal-write drop ;
+
+\ \\\\\\\\\\\\\\ Exported Interface:
+\ *
+\ Generic device methods:
+\ *
+
+
+\ \\\\\\\\\\\\\\ Exported Interface:
+\ *
+\ IEEE 1275 : display device driver initialization
+\ *
+: is-install ( 'open -- )
+ s" defer vendor-open to vendor-open" eval
+ s" : open deadbeef vendor-open dup deadbeef = IF drop true ELSE nip THEN ;" eval
+ s" defer write ' display-write to write" eval
+ s" : draw-logo ['] draw-logo CATCH IF 2drop 2drop THEN ;" eval
+ s" : reset-screen ['] reset-screen CATCH drop ;" eval
+;
+
+: is-remove ( 'close -- )
+ s" defer close to close" eval
+;
+
+: is-selftest ( 'selftest -- )
+ s" defer selftest to selftest" eval
+;
+
+
+STRUCT
+ cell FIELD font>addr
+ cell FIELD font>width
+ cell FIELD font>height
+ cell FIELD font>advance
+ cell FIELD font>min-char
+ cell FIELD font>#glyphs
+CONSTANT /font
+
+CREATE default-font-ctrblk /font allot default-font-ctrblk
+ dup font>addr 0 swap !
+ dup font>width 8 swap !
+ dup font>height -10 swap !
+ dup font>advance 1 swap !
+ dup font>min-char 20 swap !
+ font>#glyphs 7f swap !
+
+: display-default-font ( str len -- )
+ romfs-lookup dup 0= IF drop EXIT THEN
+ 600 <> IF ." Only support 60x8x16 fonts ! " drop EXIT THEN
+ default-font-ctrblk font>addr !
+;
+
+s" default-font.bin" display-default-font
+
+\ \\\\\\\\\\\\\\ Implementation Independent Methods (Depend on Previous)
+\ *
+\ *
+
+
+\ \\\\\\\\\\\\\\ Exported Interface:
+\ *
+\ Generic device methods:
+\ *
+: .scan-lines ( height -- scanlines ) dup 0>= IF 1- ELSE negate THEN ;
+
+
+\ \\\\\\\\\\\\\\ Exported Interface:
+\ *
+\ *
+
+: set-font ( addr width height advance min-char #glyphs -- )
+ default-font-ctrblk /font + /font 0
+ DO
+ 1 cells - dup >r ! r> 1 cells
+ +LOOP drop
+ default-font-ctrblk dup font>height @ abs to char-height
+ dup font>width @ to char-width font>advance @ to fontbytes
+;
+
+: >font ( char -- addr )
+ dup default-font-ctrblk dup >r font>min-char @ dup r@ font>#glyphs + within
+ IF
+ r@ font>min-char @ -
+ r@ font>advance @ * r@ font>height @ .scan-lines *
+ r> font>addr @ +
+ ELSE
+ drop r> font>addr @
+ THEN
+;
+
+: default-font ( -- addr width height advance min-char #glyphs )
+ default-font-ctrblk /font 0 DO dup cell+ >r @ r> 1 cells +LOOP drop
+;
+
diff --git a/qemu/roms/SLOF/slof/fs/dma-function.fs b/qemu/roms/SLOF/slof/fs/dma-function.fs
new file mode 100644
index 000000000..c1c8716ca
--- /dev/null
+++ b/qemu/roms/SLOF/slof/fs/dma-function.fs
@@ -0,0 +1,36 @@
+\ *****************************************************************************
+\ * Copyright (c) 2004, 2014 IBM Corporation
+\ * All rights reserved.
+\ * This program and the accompanying materials
+\ * are made available under the terms of the BSD License
+\ * which accompanies this distribution, and is available at
+\ * http://www.opensource.org/licenses/bsd-license.php
+\ *
+\ * Contributors:
+\ * IBM Corporation - initial implementation
+\ ****************************************************************************/
+
+\ DMA memory allocation functions
+: dma-alloc ( size -- virt )
+ my-phandle TO calling-child
+ s" dma-alloc" my-phandle parent $call-static
+ 0 TO calling-child
+;
+
+: dma-free ( virt size -- )
+ my-phandle TO calling-child
+ s" dma-free" my-phandle parent $call-static
+ 0 TO calling-child
+;
+
+: dma-map-in ( virt size cacheable? -- devaddr )
+ my-phandle TO calling-child
+ s" dma-map-in" my-phandle parent $call-static
+ 0 TO calling-child
+;
+
+: dma-map-out ( virt devaddr size -- )
+ my-phandle TO calling-child
+ s" dma-map-out" my-phandle parent $call-static
+ 0 TO calling-child
+;
diff --git a/qemu/roms/SLOF/slof/fs/dump.fs b/qemu/roms/SLOF/slof/fs/dump.fs
new file mode 100644
index 000000000..90d60c412
--- /dev/null
+++ b/qemu/roms/SLOF/slof/fs/dump.fs
@@ -0,0 +1,42 @@
+\ *****************************************************************************
+\ * Copyright (c) 2004, 2008 IBM Corporation
+\ * All rights reserved.
+\ * This program and the accompanying materials
+\ * are made available under the terms of the BSD License
+\ * which accompanies this distribution, and is available at
+\ * http://www.opensource.org/licenses/bsd-license.php
+\ *
+\ * Contributors:
+\ * IBM Corporation - initial implementation
+\ ****************************************************************************/
+
+
+\ Hex dump facilities.
+
+1 VALUE /dump
+' c@ VALUE 'dump
+0 VALUE dump-first
+0 VALUE dump-last
+0 VALUE dump-cur
+: .char ( c -- ) dup bl 7f within 0= IF drop [char] . THEN emit ;
+: dump-line ( -- )
+ cr dump-cur dup 8 0.r [char] : emit 10 /dump / 0 DO
+ space dump-cur dump-first dump-last within IF
+ dump-cur 'dump execute /dump 2* 0.r ELSE
+ /dump 2* spaces THEN dump-cur /dump + to dump-cur LOOP
+ /dump 1 <> IF drop EXIT THEN
+ to dump-cur 2 spaces
+ 10 0 DO dump-cur dump-first dump-last within IF
+ dump-cur 'dump execute .char ELSE space THEN dump-cur 1+ to dump-cur LOOP ;
+: (dump) ( addr len reader size -- )
+ to /dump to 'dump bounds /dump negate and to dump-first to dump-last
+ dump-first f invert and to dump-cur
+ base @ hex BEGIN dump-line dump-cur dump-last >= UNTIL base ! ;
+: du ( -- ) dump-last 100 'dump /dump (dump) ;
+: dump ['] c@ 1 (dump) ;
+: wdump ['] w@ 2 (dump) ;
+: ldump ['] l@ 4 (dump) ;
+: xdump ['] x@ 8 (dump) ;
+: rdump ['] rb@ 1 (dump) ;
+\ : iodump ['] io-c@ 1 (dump) ;
+\ : siodump ['] siocfg@ 1 (dump) ;
diff --git a/qemu/roms/SLOF/slof/fs/elf.fs b/qemu/roms/SLOF/slof/fs/elf.fs
new file mode 100644
index 000000000..5a80c78d5
--- /dev/null
+++ b/qemu/roms/SLOF/slof/fs/elf.fs
@@ -0,0 +1,71 @@
+\ *****************************************************************************
+\ * Copyright (c) 2004, 2011 IBM Corporation
+\ * All rights reserved.
+\ * This program and the accompanying materials
+\ * are made available under the terms of the BSD License
+\ * which accompanies this distribution, and is available at
+\ * http://www.opensource.org/licenses/bsd-license.php
+\ *
+\ * Contributors:
+\ * IBM Corporation - initial implementation
+\ ****************************************************************************/
+
+\ Claim memory for segment
+\ Abort, if no memory available
+
+false value elf-claim?
+0 value last-claim
+
+\ cur-brk is set by elf loader to end of data segment
+0 VALUE cur-brk
+
+
+: elf-claim-segment ( addr size -- errorcode )
+ 2dup
+ elf-claim? IF
+ >r
+ here last-claim , to last-claim \ Setup ptr to last claim
+ \ Put addr and size in the data space
+ dup , r> dup , ( addr size )
+ 0 ['] claim CATCH IF
+ ." Memory for ELF file is already in use!" cr
+ true ABORT" Memory for ELF file already in use "
+ THEN
+ drop
+ ELSE
+ 2drop
+ THEN
+ + to cur-brk
+ 0
+;
+
+
+\ Load ELF file and claim the corresponding memory regions.
+\ A destination address can be specified. If the parameter is -1 then
+\ the file is loaded to the ddress that is specified in its header.
+: elf-load-claim ( file-addr destaddr -- claim-list entry imagetype )
+ true to elf-claim?
+ 0 to last-claim
+ dup -1 = IF \ If destaddr == -1 then load to addr from ELF header
+ drop ['] elf-load-file CATCH IF false to elf-claim? ABORT THEN
+ ELSE
+ ['] elf-load-file-to-addr CATCH IF false to elf-claim? ABORT THEN
+ THEN
+ >r
+ last-claim swap
+ false to elf-claim?
+ r>
+;
+
+
+\ Release memory claimed before
+
+: elf-release ( claim-list -- )
+ BEGIN
+ dup cell+ ( claim-list claim-list-addr )
+ dup @ swap cell+ @ ( claim-list claim-list-addr claim-list-sz )
+ release ( claim-list )
+ @ dup 0= ( Next-element )
+ UNTIL
+ drop
+;
diff --git a/qemu/roms/SLOF/slof/fs/envvar.fs b/qemu/roms/SLOF/slof/fs/envvar.fs
new file mode 100644
index 000000000..33643130c
--- /dev/null
+++ b/qemu/roms/SLOF/slof/fs/envvar.fs
@@ -0,0 +1,412 @@
+\ *****************************************************************************
+\ * Copyright (c) 2004, 2012 IBM Corporation
+\ * All rights reserved.
+\ * This program and the accompanying materials
+\ * are made available under the terms of the BSD License
+\ * which accompanies this distribution, and is available at
+\ * http://www.opensource.org/licenses/bsd-license.php
+\ *
+\ * Contributors:
+\ * IBM Corporation - initial implementation
+\ ****************************************************************************/
+
+
+\ configuration variables
+
+wordlist CONSTANT envvars
+
+\ list the names in envvars
+: listenv ( -- )
+ get-current envvars set-current words set-current
+;
+
+\ create a definition in envvars
+: create-env ( "name" -- )
+ get-current envvars set-current CREATE set-current
+;
+
+\ lay out the data for the separate envvar types
+: env-int ( n -- ) 1 c, align , DOES> char+ aligned @ ;
+: env-bytes ( a len -- )
+ 2 c, align dup , here swap dup allot move
+ DOES> char+ aligned dup @ >r cell+ r>
+;
+: env-string ( str len -- ) 3 c, align dup , here over allot swap move DOES> char+ aligned dup @ >r cell+ r> ;
+: env-flag ( f -- ) 4 c, c, DOES> char+ c@ 0<> ;
+: env-secmode ( sm -- ) 5 c, c, DOES> char+ c@ ;
+
+\ create default envvars
+: default-int ( n "name" -- ) create-env env-int ;
+: default-bytes ( a len "name" -- ) create-env env-bytes ;
+: default-string ( a len "name" -- ) create-env env-string ;
+: default-flag ( f "name" -- ) create-env env-flag ;
+: default-secmode ( sm "name" -- ) create-env env-secmode ;
+
+: set-option ( option-name len option len -- )
+ 2swap encode-string
+ 2swap s" /options" find-node dup IF set-property ELSE drop 2drop 2drop THEN
+;
+
+\ find an envvar's current and default value, and its type
+: findenv ( name len -- adr def-adr type | 0 )
+ 2dup envvars voc-find dup 0<> IF ( ABORT" not a configuration variable" )
+ link> >body char+ >r (find-order) link> >body dup char+ swap c@ r> swap
+ ELSE
+ nip nip
+ THEN
+;
+
+
+: test-flag ( param len -- true | false )
+ 2dup s" true" string=ci -rot s" false" string=ci or
+;
+
+: test-secmode ( param len -- true | false )
+ 2dup s" none" string=ci -rot 2dup s" command" string=ci -rot s" full"
+ string=ci or or
+;
+
+: test-int ( param len -- true | false )
+ $dh-number IF false ELSE drop true THEN
+;
+
+: findtype ( param len name len -- param len name len type )
+ 2dup findenv \ try to find type of envvar
+ dup IF \ found a type?
+ nip nip
+ EXIT
+ THEN
+
+ \ No type found yet, try to auto-detect:
+ drop 2swap
+ 2dup test-flag IF
+ 4 -rot \ boolean type
+ ELSE
+ 2dup test-secmode IF
+ 5 -rot \ secmode type
+ ELSE
+ 2dup test-int IF
+ 1 -rot \ integer type
+ ELSE
+ 2dup test-string
+ IF 3 ELSE 2 THEN \ 3 = string, 2 = default to bytes
+ -rot
+ THEN
+ THEN
+ THEN
+ rot
+ >r 2swap r>
+;
+
+\ set an envvar
+: $setenv ( param len name len -- )
+ 4dup set-option
+ findtype
+ -rot $CREATE
+ CASE
+ 1 OF $dh-number IF 0 THEN env-int ENDOF \ XXX: wants decimal and 0x...
+ 2 OF env-bytes ENDOF
+ 3 OF env-string ENDOF
+ 4 OF evaluate env-flag ENDOF
+ 5 OF evaluate env-secmode ENDOF \ XXX: recognize none, command, full
+ ENDCASE
+;
+
+\ print an envvar
+: (printenv) ( adr type -- )
+ CASE
+ 1 OF aligned @ . ENDOF
+ 2 OF aligned dup cell+ swap @ swap . . ENDOF
+ 3 OF aligned dup @ >r cell+ r> type ENDOF
+ 4 OF c@ IF ." true" ELSE ." false" THEN ENDOF
+ 5 OF c@ . ENDOF \ XXX: print symbolically
+ ENDCASE
+;
+
+: .printenv-header ( -- )
+ cr
+ s" ---environment variable--------current value-------------default value------"
+ type cr
+;
+
+DEFER old-emit
+0 VALUE emit-counter
+
+: emit-and-count emit-counter 1 + to emit-counter old-emit ;
+
+: .enable-emit-counter
+ 0 to emit-counter
+ ['] emit behavior to old-emit
+ ['] emit-and-count to emit
+;
+
+: .disable-emit-counter
+ ['] old-emit behavior to emit
+;
+
+: .spaces ( number-of-spaces -- )
+ dup 0 > IF
+ spaces
+ ELSE
+ drop space
+ THEN
+;
+
+: .print-one-env ( name len -- )
+ 3 .spaces
+ 2dup dup -rot type 1c swap - .spaces
+ findenv rot over
+ .enable-emit-counter
+ (printenv) .disable-emit-counter
+ 1a emit-counter - .spaces
+ (printenv)
+;
+
+: .print-all-env
+ .printenv-header
+ envvars cell+
+ BEGIN
+ @ dup
+ WHILE
+ dup link> >name
+ name>string .print-one-env cr
+ REPEAT
+ drop
+;
+
+: printenv
+ parse-word dup 0= IF
+ 2drop .print-all-env
+ ELSE
+ findenv dup 0= ABORT" not a configuration variable"
+ rot over cr ." Current: " (printenv)
+ cr ." Default: " (printenv)
+ THEN
+;
+
+\ set envvar(s) to default value
+: (set-default) ( def-xt -- )
+ dup >name name>string $CREATE dup >body c@ >r execute r> CASE
+ 1 OF env-int ENDOF
+ 2 OF env-bytes ENDOF
+ 3 OF env-string ENDOF
+ 4 OF env-flag ENDOF
+ 5 OF env-secmode ENDOF ENDCASE
+;
+
+\ Environment variables might be board specific
+
+#include <envvar_defaults.fs>
+
+VARIABLE nvoff \ offset in envvar partition
+
+: (nvupdate-one) ( adr type -- "value" )
+ CASE
+ 1 OF aligned @ (.d) ENDOF
+ 2 OF drop 0 0 ENDOF
+ 3 OF aligned dup @ >r cell+ r> ENDOF
+ 4 OF c@ IF s" true" ELSE s" false" THEN ENDOF
+ 5 OF c@ (.) ENDOF \ XXX: print symbolically
+ ENDCASE
+;
+
+: nvupdate-one ( def-xt -- )
+ >r nvram-partition-type-common get-nvram-partition ( part.addr part.len FALSE|TRUE R: def-xt )
+ ABORT" No valid NVRAM." r> ( part.addr part.len def-xt )
+ >name name>string ( part.addr part.len var.a var.l )
+ 2dup findenv nip (nvupdate-one)
+ ( part.addr part.len var.addr var.len val.addr val.len )
+ internal-add-env
+ drop
+;
+
+: (nvupdate) ( -- )
+ nvram-partition-type-common get-nvram-partition ABORT" No valid NVRAM."
+ erase-nvram-partition drop
+ envvars cell+
+ BEGIN @ dup WHILE dup link> nvupdate-one REPEAT
+ drop
+;
+
+: nvupdate ( -- )
+ ." nvupdate is obsolete." cr
+;
+
+: set-default
+ parse-word envvars voc-find
+ dup 0= ABORT" not a configuration variable" link> (set-default)
+;
+
+: (set-defaults)
+ envvars cell+
+ BEGIN @ dup WHILE dup link> (set-default) REPEAT
+ drop
+;
+
+\ Preset nvram variables in RAM, but do not overwrite them in NVRAM
+(set-defaults)
+
+: set-defaults
+ (set-defaults) (nvupdate)
+;
+
+: setenv parse-word ( skipws ) 0d parse -leading 2swap $setenv (nvupdate) ;
+
+: get-nv ( -- )
+ nvram-partition-type-common get-nvram-partition ( addr offset not-found | not-found ) \ find partition header
+ IF
+ ." No NVRAM common partition, re-initializing..." cr
+ internal-reset-nvram
+ (nvupdate)
+ nvram-partition-type-common get-nvram-partition IF ." NVRAM seems to be broken." cr EXIT THEN
+ THEN
+ \ partition header found: read data from nvram
+ drop ( addr ) \ throw away offset
+ BEGIN
+ dup rzcount dup \ make string from offset and make condition
+ WHILE ( offset offset length )
+ 2dup [char] = split \ Split string at equal sign (=)
+ ( offset offset length name len param len )
+ 2swap ( offset offset length param len name len )
+ $setenv \ Set envvar
+ nip \ throw away old string begin
+ + 1+ \ calc new offset
+ REPEAT
+ 2drop drop \ cleanup
+;
+
+get-nv
+
+: check-for-nvramrc ( -- )
+ use-nvramrc? IF
+ s" Executing following code from nvramrc: "
+ s" nvramrc" evaluate $cat
+ nvramlog-write-string-cr
+ s" (!) Executing code specified in nvramrc" type
+ cr s" SLOF Setup = " type
+ \ to remove the string from the console if the nvramrc is broken
+ \ we need to know how many chars are printed
+ .enable-emit-counter
+ s" nvramrc" evaluate ['] evaluate CATCH IF
+ \ dropping the rest of the nvram string
+ 2drop
+ \ delete the chars we do not want to see
+ emit-counter 0 DO 8 emit LOOP
+ s" (!) Code in nvramrc triggered exception. "
+ 2dup nvramlog-write-string
+ type cr 12 spaces s" Aborting nvramrc execution" 2dup
+ nvramlog-write-string-cr type cr
+ s" SLOF Setup = " type
+ THEN
+ .disable-emit-counter
+ THEN
+;
+
+
+: (nv-findalias) ( alias-ptr alias-len -- pos )
+ \ create a temporary empty string
+ here 0
+ \ append "devalias " to the temporary string
+ s" devalias " string-cat
+ \ append "<name-str>" to the temporary string
+ 3 pick 3 pick string-cat
+ \ append a SPACE character to the temporary string
+ s" " string-cat
+ \ get nvramrc
+ s" nvramrc" evaluate
+ \ get position of the temporary string inside of nvramrc
+ 2swap find-substr
+ nip nip
+;
+
+: (nv-build-real-entry) ( name-ptr name-len dev-ptr dev-len -- str-ptr str-len )
+ \ create a temporary empty string
+ 2swap here 0
+ \ append "devalias " to the temporary string
+ s" devalias " string-cat
+ \ append "<name-ptr>" to the temporary string
+ 2swap string-cat
+ \ append a SPACE character to the temporary string
+ s" " string-cat
+ \ append "<dev-ptr> to the temporary string
+ 2swap string-cat
+ \ append a CR character to the temporary string
+ 0d char-cat
+ \ append a LF character to the temporary string
+ 0a char-cat
+;
+
+: (nv-build-null-entry) ( name-ptr name-len dev-ptr dev-len -- str-ptr str-len )
+ 4drop here 0
+;
+
+: (nv-build-nvramrc) ( name-str name-len dev-str dev-len xt-build-entry -- )
+ \ *** PART 1: check if there is still an alias definition available ***
+ ( alias-ptr alias-len path-ptr path-ptr call-build-entry alias-pos )
+ 4 pick 4 pick (nv-findalias)
+ \ if our alias definition is a new one
+ dup s" nvramrc" evaluate nip >= IF
+ \ call-build-entry
+ drop execute
+ \ append content of "nvramrc" to the temporary string
+ s" nvramrc" evaluate string-cat
+ \ Allocate the temporary string
+ dup allot
+ \ write the string into nvramrc
+ s" nvramrc" $setenv
+ ELSE \ if our alias is still defined in nvramrc
+ \ *** PART 2: calculate the memory size for the new content of nvramrc ***
+ \ add number of bytes needed for nvramrc-prefix to number of bytes needed
+ \ for the new entry
+ 5 pick 5 pick 5 pick 5 pick 5 pick execute nip over +
+ ( alias-ptr alias-len path-ptr path-ptr build-entry-xt alias-pos tmp-len )
+ \ add number of bytes needed for nvramrc-postfix
+ s" nvramrc" evaluate 3 pick string-at
+ 2dup find-nextline string-at nip +
+ \ *** PART 3: build the new content ***
+ \ allocate enough memory for new content
+ alloc-mem 0
+ ( alias-ptr alias-len path-ptr path-ptr build-entry-xt alias-pos mem len )
+ \ add nvramrc-prefix
+ s" nvramrc" evaluate drop 3 pick string-cat
+ \ add new entry
+ rot >r >r >r execute r> r> 2swap string-cat
+ ( mem, len ) ( R: alias-pos )
+ \ add nvramrc-postfix
+ s" nvramrc" evaluate r> string-at
+ 2dup find-nextline string-at string-cat
+ ( mem len )
+ \ write the temporary string into nvramrc and clean up memory
+ 2dup s" nvramrc" $setenv free-mem
+ THEN
+;
+
+: $nvalias ( name-str name-len dev-str dev-len -- )
+ 4dup ['] (nv-build-real-entry) (nv-build-nvramrc)
+ set-alias
+ s" true" s" use-nvramrc?" $setenv
+ (nvupdate)
+;
+
+: nvalias ( "alias-name< >device-specifier<eol>" -- )
+ parse-word parse-word dup 0<> IF
+ $nvalias
+ ELSE
+ 2drop 2drop
+ cr
+ " Usage: nvalias (""alias-name< >device-specifier<eol>"" -- )" type
+ cr
+ THEN
+;
+
+: $nvunalias ( name-str name-len -- )
+ s" " ['] (nv-build-null-entry) (nv-build-nvramrc)
+ (nvupdate)
+;
+
+: nvunalias ( "alias-name< >" -- )
+ parse-word $nvunalias
+;
+
+: diagnostic-mode? ( -- diag-switch? ) diag-switch? ;
+
diff --git a/qemu/roms/SLOF/slof/fs/envvar_defaults.fs b/qemu/roms/SLOF/slof/fs/envvar_defaults.fs
new file mode 100644
index 000000000..86716eff0
--- /dev/null
+++ b/qemu/roms/SLOF/slof/fs/envvar_defaults.fs
@@ -0,0 +1,44 @@
+\ *****************************************************************************
+\ * Copyright (c) 2004, 2008 IBM Corporation
+\ * All rights reserved.
+\ * This program and the accompanying materials
+\ * are made available under the terms of the BSD License
+\ * which accompanies this distribution, and is available at
+\ * http://www.opensource.org/licenses/bsd-license.php
+\ *
+\ * Contributors:
+\ * IBM Corporation - initial implementation
+\ ****************************************************************************/
+
+\ the defaults
+\ some of those are platform dependent, and should e.g. be
+\ created from VPD values
+true default-flag auto-boot?
+s" " default-string boot-device
+s" " default-string boot-file
+s" boot" default-string boot-command
+s" " default-string diag-device
+s" " default-string diag-file
+false default-flag diag-switch?
+true default-flag fcode-debug?
+s" " default-string input-device
+s" " default-string nvramrc
+s" " default-string oem-banner
+false default-flag oem-banner?
+0 0 default-bytes oem-logo
+false default-flag oem-logo?
+s" " default-string output-device
+200 default-int screen-#columns
+200 default-int screen-#rows
+0 default-int security-#badlogins
+0 default-secmode security-mode
+s" " default-string security-password
+0 default-int selftest-#megs
+false default-flag use-nvramrc?
+false default-flag direct-serial?
+true default-flag real-mode?
+default-load-base default-int load-base
+#ifdef BIOSEMU
+true default-flag use-biosemu?
+0 default-int biosemu-debug
+#endif
diff --git a/qemu/roms/SLOF/slof/fs/exception.fs b/qemu/roms/SLOF/slof/fs/exception.fs
new file mode 100644
index 000000000..dbf11fb46
--- /dev/null
+++ b/qemu/roms/SLOF/slof/fs/exception.fs
@@ -0,0 +1,154 @@
+\ *****************************************************************************
+\ * Copyright (c) 2004, 2008 IBM Corporation
+\ * All rights reserved.
+\ * This program and the accompanying materials
+\ * are made available under the terms of the BSD License
+\ * which accompanies this distribution, and is available at
+\ * http://www.opensource.org/licenses/bsd-license.php
+\ *
+\ * Contributors:
+\ * IBM Corporation - initial implementation
+\ ****************************************************************************/
+
+STRUCT
+ cell FIELD >r0 cell FIELD >r1 cell FIELD >r2 cell FIELD >r3
+ cell FIELD >r4 cell FIELD >r5 cell FIELD >r6 cell FIELD >r7
+ cell FIELD >r8 cell FIELD >r9 cell FIELD >r10 cell FIELD >r11
+ cell FIELD >r12 cell FIELD >r13 cell FIELD >r14 cell FIELD >r15
+ cell FIELD >r16 cell FIELD >r17 cell FIELD >r18 cell FIELD >r19
+ cell FIELD >r20 cell FIELD >r21 cell FIELD >r22 cell FIELD >r23
+ cell FIELD >r24 cell FIELD >r25 cell FIELD >r26 cell FIELD >r27
+ cell FIELD >r28 cell FIELD >r29 cell FIELD >r30 cell FIELD >r31
+ cell FIELD >cr cell FIELD >xer cell FIELD >lr cell FIELD >ctr
+ cell FIELD >srr0 cell FIELD >srr1 cell FIELD >dar cell FIELD >dsisr
+CONSTANT ciregs-size
+
+
+
+: .16 10 0.r 3 spaces ;
+: .8 8 spaces 8 0.r 3 spaces ;
+: .4regs cr 4 0 DO dup @ .16 8 cells+ LOOP drop ;
+: .fixed-regs
+ cr ." R0 .. R7 R8 .. R15 R16 .. R23 R24 .. R31"
+ dup 8 0 DO dup .4regs cell+ LOOP drop
+;
+
+: .special-regs
+ cr ." CR / XER LR / CTR SRR0 / SRR1 DAR / DSISR"
+ cr dup >cr @ .8 dup >lr @ .16 dup >srr0 @ .16 dup >dar @ .16
+ cr dup >xer @ .16 dup >ctr @ .16 dup >srr1 @ .16 >dsisr @ .8
+;
+
+: .regs
+ cr .fixed-regs
+ cr .special-regs
+ cr cr
+;
+
+: .hw-exception ( reason-code exception-nr -- )
+ ." ( " dup . ." ) "
+ CASE
+ 200 OF ." Machine Check" ENDOF
+ 300 OF ." Data Storage" ENDOF
+ 380 OF ." Data Segment" ENDOF
+ 400 OF ." Instruction Storage" ENDOF
+ 480 OF ." Instruction Segment" ENDOF
+ 500 OF ." External" ENDOF
+ 600 OF ." Alignment" ENDOF
+ 700 OF ." Program" ENDOF
+ 800 OF ." Floating-point unavailable" ENDOF
+ 900 OF ." Decrementer" ENDOF
+ 980 OF ." Hypervisor Decrementer" ENDOF
+ C00 OF ." System Call" ENDOF
+ D00 OF ." Trace" ENDOF
+ F00 OF ." Performance Monitor" ENDOF
+ F20 OF ." VMX Unavailable" ENDOF
+ 1200 OF ." System Error" ENDOF
+ 1600 OF ." Maintenance" ENDOF
+ 1800 OF ." Thermal" ENDOF
+ dup OF ." Unknown" ENDOF
+ ENDCASE
+ ." Exception [ " . ." ]"
+;
+
+: .sw-exception ( exception-nr -- )
+ ." Exception [ " . ." ] triggered by boot firmware."
+;
+
+\ this word gets also called for non-hardware exceptions.
+: be-hw-exception ( [reason-code] exception-nr -- )
+ cr cr
+ dup 0> IF .hw-exception ELSE .sw-exception THEN
+ cr eregs .regs
+;
+' be-hw-exception to hw-exception-handler
+
+: (boot-exception-handler) ( x1...xn exception-nr -- x1...xn)
+ dup IF
+ dup 0 > IF
+ negate cp 9 emit ." : " type
+ ELSE
+ CASE
+ -6d OF cr ." W3411: Client application returned." cr ENDOF
+ -6c OF cr ." E3400: It was not possible to boot from any device "
+ ." specified in the VPD." cr
+ ENDOF
+ -6b OF cr ." E3410: Boot list successfully read from VPD "
+ ." but no useful information received." cr
+ ENDOF
+ -6a OF cr ." E3420: Boot list could not be read from VPD." cr
+ ENDOF
+ -69 OF
+ cr ." E3406: Client application returned an error"
+ abort"-str @ count dup IF
+ ." : " type cr
+ ELSE
+ ." ." cr
+ 2drop
+ THEN
+ ENDOF
+ -68 OF cr ." E3405: No such device" cr ENDOF
+ -67 OF cr ." E3404: Not a bootable device!" cr ENDOF
+ -66 OF cr ." E3408: Failed to claim memory for the executable" cr
+ ENDOF
+ -65 OF cr ." E3407: Load failed" cr ENDOF
+ -64 OF cr ." E3403: Bad executable: " abort"-str @ count type cr
+ ENDOF
+ -63 OF cr ." E3409: Unknown FORTH Word" cr ENDOF
+ -2 OF cr ." E3401: Aborting boot, " abort"-str @ count type cr
+ ENDOF
+ dup OF ." E3402: Aborting boot, internal error" cr ENDOF
+ ENDCASE
+ THEN
+ ELSE
+ drop
+ THEN
+;
+
+' (boot-exception-handler) to boot-exception-handler
+
+: throw-error ( error-code "error-string" -- )
+ skipws 0a parse rot throw
+;
+
+\ Enable external interrupt in msr
+
+: enable-ext-int ( -- )
+ msr@ 8000 or msr!
+;
+
+\ Disable external interrupt in msr
+
+: disable-ext-int ( -- )
+ msr@ 8000 not and msr!
+;
+
+\ Generate external interrupt through Internal Interrupt Controller of BE
+
+: gen-ext-int ( -- )
+ 7fffffff dec! \ Reset decrementer
+ enable-ext-int \ Enable interrupt
+ FF 20000508418 rx! \ Interrupt priority mask
+ 10 20000508410 rx! \ Interrupt priority
+;
+
diff --git a/qemu/roms/SLOF/slof/fs/fbuffer.fs b/qemu/roms/SLOF/slof/fs/fbuffer.fs
new file mode 100644
index 000000000..756f05a95
--- /dev/null
+++ b/qemu/roms/SLOF/slof/fs/fbuffer.fs
@@ -0,0 +1,264 @@
+\ *****************************************************************************
+\ * Copyright (c) 2004, 2008 IBM Corporation
+\ * All rights reserved.
+\ * This program and the accompanying materials
+\ * are made available under the terms of the BSD License
+\ * which accompanies this distribution, and is available at
+\ * http://www.opensource.org/licenses/bsd-license.php
+\ *
+\ * Contributors:
+\ * IBM Corporation - initial implementation
+\ ****************************************************************************/
+
+#include "terminal.fs"
+#include "display.fs"
+
+\ \\\\\\\\\\\\\\ Global Data
+
+0 VALUE frame-buffer-adr
+0 VALUE screen-height
+0 VALUE screen-width
+0 VALUE screen-depth
+0 VALUE window-top
+0 VALUE window-left
+
+0 VALUE .sc
+
+: screen-#rows ( -- rows )
+ .sc IF
+ screen-height char-height /
+ ELSE
+ true to .sc
+ s" screen-#rows" eval
+ false to .sc
+ THEN
+;
+
+: screen-#columns ( -- columns )
+ .sc IF
+ screen-width char-width /
+ ELSE
+ true to .sc
+ s" screen-#columns" eval
+ false to .sc
+ THEN
+;
+
+\ \\\\\\\\\\\\\\ Structure/Implementation Dependent Methods
+
+
+\ \\\\\\\\\\\\\\ Implementation Independent Methods (Depend on Previous)
+\ *
+\ *
+
+: fb8-background inverse? ;
+: fb8-foreground inverse? invert ;
+
+: fb8-lines2bytes ( #lines -- #bytes ) char-height * screen-width * screen-depth * ;
+: fb8-columns2bytes ( #columns -- #bytes ) char-width * screen-depth * ;
+: fb8-line2addr ( line# -- addr )
+ char-height * window-top + screen-width * screen-depth *
+ frame-buffer-adr + window-left screen-depth * +
+;
+
+: fb8-erase-block ( addr len ) fb8-background rfill ;
+
+
+0 VALUE .ab
+CREATE bitmap-buffer 400 4 * allot
+
+: active-bits ( -- new ) .ab dup 8 > IF 8 - to .ab 8 ELSE
+ char-width to .ab ?dup 0= IF recurse THEN
+ THEN ;
+
+: fb8-char2bitmap ( font-height font-addr -- bitmap-buffer )
+ bitmap-buffer >r
+ char-height rot 0> IF r> char-width 2dup fb8-erase-block + >r 1- THEN
+
+ r> -rot char-width to .ab
+ ( fb-addr font-addr font-height )
+ fontbytes * bounds ?DO
+ i c@ active-bits 0 ?DO
+ dup 80 and IF fb8-foreground ELSE fb8-background THEN
+ ( fb-addr fbyte colr ) 2 pick ! 1 lshift
+ swap screen-depth + swap
+ LOOP drop
+ LOOP drop
+ bitmap-buffer
+;
+
+\ \\\\\\\\\\\\\\ Exported Interface:
+\ *
+\ * IEEE 1275: Frame buffer support routines
+\ *
+
+: fb8-draw-logo ( line# addr width height -- ) ." fb8-draw-logo ( " .s ." )" cr
+ 2drop 2drop
+;
+
+: fb8-toggle-cursor ( -- )
+ line# fb8-line2addr column# fb8-columns2bytes +
+ char-height 0 ?DO
+ char-width screen-depth * 0 ?DO dup dup rb@ -1 xor swap rb! 1+ LOOP
+ screen-width screen-depth * + char-width screen-depth * -
+ LOOP drop
+;
+
+: fb8-draw-character ( char -- )
+ >r default-font over + r@ -rot between IF
+ 2swap 3drop r> >font fb8-char2bitmap ( bitmap-buf )
+ line# fb8-line2addr column# fb8-columns2bytes + ( bitmap-buf fb-addr )
+ char-height 0 ?DO
+ 2dup char-width screen-depth * mrmove
+ screen-width screen-depth * + >r char-width screen-depth * + r>
+ LOOP 2drop
+ ELSE 2drop r> 3drop THEN
+;
+
+: fb8-insert-lines ( n -- )
+ fb8-lines2bytes >r line# fb8-line2addr dup dup r@ +
+ #lines line# - fb8-lines2bytes r@ - rmove
+ r> fb8-erase-block
+;
+
+: fb8-delete-lines ( n -- )
+ fb8-lines2bytes >r line# fb8-line2addr dup dup r@ + swap
+ #lines fb8-lines2bytes r@ - dup >r rmove
+ r> + r> fb8-erase-block
+;
+
+: fb8-insert-characters ( n -- )
+ line# fb8-line2addr column# fb8-columns2bytes + >r
+ #columns column# - 2dup >= IF
+ nip dup 0> IF fb8-columns2bytes r> ELSE r> 2drop EXIT THEN
+ ELSE
+ fb8-columns2bytes swap fb8-columns2bytes tuck -
+ over r@ tuck + rot char-height 0 ?DO
+ 3dup rmove
+ -rot screen-width screen-depth * tuck + -rot + swap rot
+ LOOP
+ 3drop r>
+ THEN
+ char-height 0 ?DO
+ dup 2 pick fb8-erase-block screen-width screen-depth * +
+ LOOP
+ 2drop
+;
+
+: fb8-delete-characters ( n -- )
+ line# fb8-line2addr column# fb8-columns2bytes + >r
+ #columns column# - 2dup >= IF
+ nip dup 0> IF fb8-columns2bytes r> ELSE r> 2drop EXIT THEN
+ ELSE
+ fb8-columns2bytes swap fb8-columns2bytes tuck -
+ over r@ + 2dup + r> swap >r rot char-height 0 ?DO
+ 3dup rmove
+ -rot screen-width screen-depth * tuck + -rot + swap rot
+ LOOP
+ 3drop r> over -
+ THEN
+ char-height 0 ?DO
+ dup 2 pick fb8-erase-block screen-width screen-depth * +
+ LOOP
+ 2drop
+;
+
+: fb8-reset-screen ( -- ) ( Left as no-op by design ) ;
+
+: fb8-erase-screen ( -- )
+ frame-buffer-adr screen-height screen-width * screen-depth * fb8-erase-block
+;
+
+: fb8-invert-screen ( -- )
+ frame-buffer-adr screen-height screen-width * screen-depth * 2dup /x / 0 ?DO
+ dup rx@ -1 xor over rx! xa1+
+ LOOP 3drop
+;
+
+: fb8-blink-screen ( -- ) fb8-invert-screen fb8-invert-screen ;
+
+: fb8-install ( width height #columns #lines -- )
+ 1 to screen-depth
+ 2swap to screen-height to screen-width
+ screen-#rows min to #lines
+ screen-#columns min to #columns
+ screen-height char-height #lines * - 2/ to window-top
+ screen-width char-width #columns * - 2/ to window-left
+ ['] fb8-toggle-cursor to toggle-cursor
+ ['] fb8-draw-character to draw-character
+ ['] fb8-insert-lines to insert-lines
+ ['] fb8-delete-lines to delete-lines
+ ['] fb8-insert-characters to insert-characters
+ ['] fb8-delete-characters to delete-characters
+ ['] fb8-erase-screen to erase-screen
+ ['] fb8-blink-screen to blink-screen
+ ['] fb8-invert-screen to invert-screen
+ ['] fb8-reset-screen to reset-screen
+ ['] fb8-draw-logo to draw-logo
+;
+
+: fb-install ( width height #columns #lines depth -- )
+ >r
+ fb8-install
+ r> to screen-depth
+;
+
+
+\ Install display related FCODE evaluator tokens
+: fb8-set-tokens ( -- )
+ ['] is-install 0 11C set-token
+ ['] is-remove 0 11D set-token
+ ['] is-selftest 0 11E set-token
+
+ ['] #lines 0 150 set-token
+ ['] #columns 0 151 set-token
+ ['] line# 0 152 set-token
+ ['] column# 0 153 set-token
+ ['] inverse? 0 154 set-token
+ ['] inverse-screen? 0 155 set-token
+ ['] draw-character 0 157 set-token
+ ['] reset-screen 0 158 set-token
+ ['] toggle-cursor 0 159 set-token
+ ['] erase-screen 0 15A set-token
+ ['] blink-screen 0 15B set-token
+ ['] invert-screen 0 15C set-token
+ ['] insert-characters 0 15D set-token
+ ['] delete-characters 0 15E set-token
+ ['] insert-lines 0 15F set-token
+ ['] delete-lines 0 160 set-token
+ ['] draw-logo 0 161 set-token
+ ['] frame-buffer-adr 0 162 set-token
+ ['] screen-height 0 163 set-token
+ ['] screen-width 0 164 set-token
+ ['] window-top 0 165 set-token
+ ['] window-left 0 166 set-token
+ \ ['] foreground-color 0 168 set-token \ 16-color extension - n/a
+ \ ['] background-color 0 169 set-token \ 16-color extension - n/a
+ ['] default-font 0 16A set-token
+ ['] set-font 0 16B set-token
+ ['] char-height 0 16C set-token
+ ['] char-width 0 16D set-token
+ ['] >font 0 16E set-token
+ ['] fontbytes 0 16F set-token
+
+ ['] fb8-draw-character 0 180 set-token
+ ['] fb8-reset-screen 0 181 set-token
+ ['] fb8-toggle-cursor 0 182 set-token
+ ['] fb8-erase-screen 0 183 set-token
+ ['] fb8-blink-screen 0 184 set-token
+ ['] fb8-invert-screen 0 185 set-token
+ ['] fb8-insert-characters 0 186 set-token
+ ['] fb8-delete-characters 0 187 set-token
+ ['] fb8-insert-lines 0 188 set-token
+ ['] fb8-delete-lines 0 189 set-token
+ ['] fb8-draw-logo 0 18A set-token
+ ['] fb8-install 0 18B set-token
+;
+fb8-set-tokens
+
+
+\ \\\\\\\\\\\\ Debug Stuff \\\\\\\\\\\\\\\\
+
+: fb8-dump-bitmap cr char-height 0 ?do char-width 0 ?do dup c@ if ." @" else ." ." then 1+ loop cr loop drop ;
+
+: fb8-dump-char >font -b swap fb8-char2bitmap fb8-dump-bitmap ;
diff --git a/qemu/roms/SLOF/slof/fs/fcode/1275.fs b/qemu/roms/SLOF/slof/fs/fcode/1275.fs
new file mode 100644
index 000000000..c2a67bcc9
--- /dev/null
+++ b/qemu/roms/SLOF/slof/fs/fcode/1275.fs
@@ -0,0 +1,465 @@
+\ *****************************************************************************
+\ * Copyright (c) 2004, 2011 IBM Corporation
+\ * All rights reserved.
+\ * This program and the accompanying materials
+\ * are made available under the terms of the BSD License
+\ * which accompanies this distribution, and is available at
+\ * http://www.opensource.org/licenses/bsd-license.php
+\ *
+\ * Contributors:
+\ * IBM Corporation - initial implementation
+\ ****************************************************************************/
+
+
+: fcode-revision ( -- n )
+ 00030000 \ major * 65536 + minor
+ ;
+
+: b(lit) ( -- n )
+ next-ip read-fcode-num32
+ ?compile-mode IF literal, THEN
+ ;
+
+: b(")
+ next-ip read-fcode-string
+ ?compile-mode IF fc-string, align postpone count THEN
+ ;
+
+: b(')
+ next-ip read-fcode# get-token drop ?compile-mode IF literal, THEN
+ ;
+
+: ?jump-direction ( n -- )
+ dup 8000 >= IF
+ 10000 - \ Create cell-sized negative value
+ THEN
+ fcode-offset - \ IP is already behind offset, so subtract offset size
+;
+
+: ?negative
+ 8000 and
+ ;
+
+: dest-on-top
+ 0 >r BEGIN dup @ 0= WHILE >r REPEAT
+ BEGIN r> dup WHILE swap REPEAT
+ drop
+ ;
+
+: read-fcode-offset
+ next-ip
+ ?offset16 IF
+ read-fcode-num16
+ ELSE
+ read-byte
+ dup 80 and IF FF00 or THEN \ Fake 16-bit signed offset
+ THEN
+;
+
+: b?branch ( flag -- )
+ ?compile-mode IF
+ read-fcode-offset ?negative IF
+ dest-on-top postpone until
+ ELSE
+ postpone if
+ THEN
+ ELSE
+ ( flag ) IF
+ fcode-offset jump-n-ip \ Skip over offset value
+ ELSE
+ read-fcode-offset
+ ?jump-direction jump-n-ip
+ THEN
+ THEN
+; immediate
+
+: bbranch ( -- )
+ ?compile-mode IF
+ read-fcode-offset
+ ?negative IF
+ dest-on-top postpone again
+ ELSE
+ postpone else
+ get-ip next-ip fcode@ B2 = IF
+ drop
+ ELSE
+ set-ip
+ THEN
+ THEN
+ ELSE
+ read-fcode-offset ?jump-direction jump-n-ip
+ THEN
+; immediate
+
+: b(<mark) ( -- )
+ ?compile-mode IF postpone begin THEN
+ ; immediate
+
+: b(>resolve) ( -- )
+ ?compile-mode IF postpone then THEN
+ ; immediate
+
+: b(;)
+ <semicolon> compile, reveal
+ postpone [
+; immediate
+
+: b(:) ( -- )
+ <colon> compile, ]
+ ; immediate
+
+: b(case) ( sel -- sel )
+ postpone case
+ ; immediate
+
+: b(endcase)
+ postpone endcase
+ ; immediate
+
+: b(of)
+ postpone of
+ read-fcode-offset drop \ read and discard offset
+ ; immediate
+
+: b(endof)
+ postpone endof
+ read-fcode-offset drop
+ ; immediate
+
+: b(do)
+ postpone do
+ read-fcode-offset drop
+ ; immediate
+
+: b(?do)
+ postpone ?do
+ read-fcode-offset drop
+ ; immediate
+
+: b(loop)
+ postpone loop
+ read-fcode-offset drop
+ ; immediate
+
+: b(+loop)
+ postpone +loop
+ read-fcode-offset drop
+ ; immediate
+
+: b(leave)
+ postpone leave
+ ; immediate
+
+
+0 VALUE fc-instance?
+: fc-instance ( -- ) \ Mark next defining word as instance-specific.
+ TRUE TO fc-instance?
+;
+
+: new-token \ unnamed local fcode function
+ align here next-ip read-fcode# 0 swap set-token
+ ;
+
+: external-token ( -- ) \ named local fcode function
+ next-ip read-fcode-string
+ \ fc-instance? IF cr ." ext instance token: " 2dup type ." in " pwd cr THEN
+ header ( str len -- ) \ create a header in the current dictionary entry
+ new-token
+ ;
+
+: new-token
+ eva-debug? IF
+ s" x" get-ip >r next-ip read-fcode# r> set-ip (u.) $cat strdup
+ header
+ THEN
+ new-token
+;
+
+\ decide wether or not to give a new token an own name in the dictionary
+: named-token
+ fcode-debug? IF
+ external-token
+ ELSE
+ next-ip read-fcode-string 2drop \ Forget about the name
+ new-token
+ THEN
+;
+
+: b(to) ( val -- )
+ next-ip read-fcode#
+ get-token drop ( val xt )
+ dup @ ( val xt @xt )
+ dup <value> = over <defer> = OR IF
+ \ Destination is value or defer
+ drop
+ >body cell -
+ ( val addr )
+ ?compile-mode IF
+ literal, postpone !
+ ELSE
+ !
+ THEN
+ ELSE
+ <create> <> IF ( val xt )
+ TRUE ABORT" Invalid destination for FCODE b(to)"
+ THEN
+ dup cell+ @ ( val xt @xt+1cell )
+ dup <instancevalue> <> swap <instancedefer> <> AND IF
+ TRUE ABORT" Invalid destination for FCODE b(to)"
+ THEN
+ \ Destination is instance-value or instance-defer
+ >body @ ( val instance-offset )
+ ?compile-mode IF
+ literal, postpone >instance postpone !
+ ELSE
+ >instance !
+ THEN
+ ELSE
+ THEN
+; immediate
+
+: b(value)
+ fc-instance? IF
+ <create> , \ Needed for "(instance?)" for example
+ <instancevalue> ,
+ (create-instance-var)
+ FALSE TO fc-instance?
+ ELSE
+ <value> , ,
+ THEN
+ reveal
+;
+
+: b(variable)
+ fc-instance? IF
+ <create> , \ Needed for "(instance?)"
+ <instancevariable> ,
+ 0 (create-instance-var)
+ FALSE TO fc-instance?
+ ELSE
+ <variable> , 0 ,
+ THEN
+ reveal
+;
+
+: b(constant)
+ <constant> , , reveal
+ ;
+
+: undefined-defer
+ cr cr ." Uninitialized defer word has been executed!" cr cr
+ true fcode-end !
+ ;
+
+: b(defer)
+ fc-instance? IF
+ <create> , \ Needed for "(instance?)"
+ <instancedefer> ,
+ ['] undefined-defer (create-instance-var)
+ reveal
+ FALSE TO fc-instance?
+ ELSE
+ <defer> , reveal
+ postpone undefined-defer
+ THEN
+;
+
+: b(create)
+ <variable> ,
+ postpone noop reveal
+ ;
+
+: b(field) ( E: addr -- addr+offset ) ( F: offset size -- offset+size )
+ <colon> , over literal,
+ postpone +
+ <semicolon> compile,
+ reveal
+ +
+;
+
+: b(buffer:) ( E: -- a-addr) ( F: size -- )
+ fc-instance? IF
+ <create> , \ Needed for "(instance?)"
+ <instancebuffer> ,
+ (create-instance-buf)
+ FALSE TO fc-instance?
+ ELSE
+ <buffer:> , allot
+ THEN
+ reveal
+;
+
+: suspend-fcode ( -- )
+ noop \ has to be implemented more efficiently ;-)
+ ;
+
+: offset16 ( -- )
+ 2 to fcode-offset
+ ;
+
+: version1 ( -- )
+ 1 to fcode-spread
+ 1 to fcode-offset
+ read-header
+ ;
+
+: start0 ( -- )
+ 0 to fcode-spread
+ offset16
+ read-header
+ ;
+
+: start1 ( -- )
+ 1 to fcode-spread
+ offset16
+ read-header
+ ;
+
+: start2 ( -- )
+ 2 to fcode-spread
+ offset16
+ read-header
+ ;
+
+: start4 ( -- )
+ 4 to fcode-spread
+ offset16
+ read-header
+ ;
+
+: end0 ( -- )
+ true fcode-end !
+ ;
+
+: end1 ( -- )
+ end0
+ ;
+
+: ferror ( -- )
+ clear end0
+ cr ." FCode# " fcode-num @ . ." not assigned!"
+ cr ." FCode evaluation aborted." cr
+ ." ( -- S:" depth . ." R:" rdepth . ." ) " .s cr
+ abort
+ ;
+
+: reset-local-fcodes
+ FFF 800 DO ['] ferror 0 i set-token LOOP
+ ;
+
+: byte-load ( addr xt -- )
+ >r >r
+ save-evaluator-state
+ r> r>
+ reset-fcode-end
+ 1 to fcode-spread
+ dup 1 = IF drop ['] rb@ THEN to fcode-rb@
+ set-ip
+ reset-local-fcodes
+ depth >r
+ evaluate-fcode
+ r> depth 1- <> IF
+ clear end0
+ cr ." Ambiguous stack depth after byte-load!"
+ cr ." FCode evaluation aborted." cr cr
+ ELSE
+ restore-evaluator-state
+ THEN
+ ['] c@ to fcode-rb@
+;
+
+\ Functions for accessing memory ... since some FCODE programs use the normal
+\ memory access functions for accessing MMIO memory, too, we got to use a little
+\ hack to support them: When address is bigger than MIN-RAM-SIZE, assume the
+\ FCODE is trying to access MMIO memory and use the register based access
+\ functions instead!
+: fc-c@ ( addr -- byte ) dup MIN-RAM-SIZE > IF rb@ ELSE c@ THEN ;
+: fc-w@ ( addr -- word ) dup MIN-RAM-SIZE > IF rw@ ELSE w@ THEN ;
+: fc-<w@ ( addr -- word ) fc-w@ dup 8000 >= IF 10000 - THEN ;
+: fc-l@ ( addr -- long ) dup MIN-RAM-SIZE > IF rl@ ELSE l@ THEN ;
+: fc-<l@ ( addr -- long ) fc-l@ signed ;
+: fc-x@ ( addr -- dlong ) dup MIN-RAM-SIZE > IF rx@ ELSE x@ THEN ;
+: fc-c! ( byte addr -- ) dup MIN-RAM-SIZE > IF rb! ELSE c! THEN ;
+: fc-w! ( word addr -- ) dup MIN-RAM-SIZE > IF rw! ELSE w! THEN ;
+: fc-l! ( long addr -- ) dup MIN-RAM-SIZE > IF rl! ELSE l! THEN ;
+: fc-x! ( dlong addr -- ) dup MIN-RAM-SIZE > IF rx! ELSE x! THEN ;
+
+: fc-fill ( add len byte -- ) 2 pick MIN-RAM-SIZE > IF rfill ELSE fill THEN ;
+: fc-move ( src dst len -- )
+ 2 pick MIN-RAM-SIZE > \ Check src
+ 2 pick MIN-RAM-SIZE > \ Check dst
+ OR IF rmove ELSE move THEN
+;
+
+\ Destroy virtual mapping (should maybe also update "address" property here?)
+: free-virtual ( virt size -- )
+ s" map-out" $call-parent
+;
+
+\ Map the specified region, return virtual address
+: map-low ( phys.lo ... size -- virt )
+ my-space swap s" map-in" $call-parent
+;
+
+\ Get MAC address
+: mac-address ( -- mac-str mac-len )
+ s" local-mac-address" get-my-property IF
+ 0 0
+ THEN
+;
+
+\ Output line and column number - not used yet
+VARIABLE #line
+0 #line !
+VARIABLE #out
+0 #out !
+
+\ Display device status
+: display-status ( n -- )
+ ." Device status: " . cr
+;
+
+\ Obsolete variables:
+VARIABLE group-code
+0 group-code !
+
+\ Obsolete: Allocate memory for DMA
+: dma-alloc ( byte -- virtual )
+ s" dma-alloc" $call-parent
+;
+
+\ Obsolete: Get params property
+: my-params ( -- addr len )
+ s" params" get-my-property IF
+ 0 0
+ THEN
+;
+
+\ Obsolete: Convert SBus interrupt level to CPU interrupt level
+: sbus-intr>cpu ( sbus-intr# -- cpu-intr# )
+;
+
+\ Obsolete: Set "intr" property
+: intr ( interrupt# vector -- )
+ >r sbus-intr>cpu encode-int r> encode-int+ s" intr" property
+;
+
+\ Obsolete: Create the "name" property
+: driver ( addr len -- )
+ encode-string s" name" property
+;
+
+\ Obsolete: Return type of CPU
+: processor-type ( -- cpu-type )
+ 0
+;
+
+\ Obsolete: Return firmware version
+: firmware-version ( -- n )
+ 10000 \ Just a dummy value
+;
+
+\ Obsolete: Return fcode-version
+: fcode-version ( -- n )
+ fcode-revision
+;
diff --git a/qemu/roms/SLOF/slof/fs/fcode/core.fs b/qemu/roms/SLOF/slof/fs/fcode/core.fs
new file mode 100644
index 000000000..8fd98ec19
--- /dev/null
+++ b/qemu/roms/SLOF/slof/fs/fcode/core.fs
@@ -0,0 +1,173 @@
+\ *****************************************************************************
+\ * Copyright (c) 2004, 2008 IBM Corporation
+\ * All rights reserved.
+\ * This program and the accompanying materials
+\ * are made available under the terms of the BSD License
+\ * which accompanies this distribution, and is available at
+\ * http://www.opensource.org/licenses/bsd-license.php
+\ *
+\ * Contributors:
+\ * IBM Corporation - initial implementation
+\ ****************************************************************************/
+
+: ?offset16 ( -- true|false )
+ fcode-offset 2 =
+ ;
+
+: ?arch64 ( -- true|false )
+ cell 8 =
+ ;
+
+: ?bigendian ( -- true|false )
+ deadbeef fcode-num !
+ fcode-num ?arch64 IF 4 + THEN
+ c@ de =
+ ;
+
+: reset-fcode-end ( -- )
+ false fcode-end !
+ ;
+
+: get-ip ( -- n )
+ ip @
+ ;
+
+: set-ip ( n -- )
+ ip !
+ ;
+
+: next-ip ( -- )
+ get-ip 1+ set-ip
+ ;
+
+: jump-n-ip ( n -- )
+ get-ip + set-ip
+ ;
+
+: read-byte ( -- n )
+ get-ip fcode-rb@
+ ;
+
+: ?compile-mode ( -- on|off )
+ state @
+ ;
+
+: save-evaluator-state
+ get-ip eva-debug? IF ." saved ip " dup . cr THEN
+ fcode-end @ eva-debug? IF ." saved fcode-end " dup . cr THEN
+ fcode-offset eva-debug? IF ." saved fcode-offset " dup . cr THEN
+\ local fcodes are currently NOT saved!
+ fcode-spread eva-debug? IF ." saved fcode-spread " dup . cr THEN
+ ['] fcode@ behavior eva-debug? IF ." saved fcode@ " dup . cr THEN
+ ;
+
+: restore-evaluator-state
+ eva-debug? IF ." restored fcode@ " dup . cr THEN to fcode@
+ eva-debug? IF ." restored fcode-spread " dup . cr THEN to fcode-spread
+\ local fcodes are currently NOT restored!
+ eva-debug? IF ." restored fcode-offset " dup . cr THEN to fcode-offset
+ eva-debug? IF ." restored fcode-end " dup . cr THEN fcode-end !
+ eva-debug? IF ." restored ip " dup . cr THEN set-ip
+ ;
+
+: token-table-index ( fcode# -- addr )
+ cells token-table +
+ ;
+
+: join-immediate ( xt immediate? addr -- xt+immediate? addr )
+ -rot + swap
+ ;
+
+: split-immediate ( xt+immediate? -- xt immediate? )
+ dup 1 and 2dup - rot drop swap
+ ;
+
+: literal, ( n -- )
+ postpone literal
+ ;
+
+: fc-string,
+ postpone sliteral
+ dup c, bounds ?do i c@ c, loop
+ ;
+
+: set-token ( xt immediate? fcode# -- )
+ token-table-index join-immediate !
+ ;
+
+: get-token ( fcode# -- xt immediate? )
+ token-table-index @ split-immediate
+ ;
+
+( ---------------------------------------------------- )
+
+#include "little-big.fs"
+
+( ---------------------------------------------------- )
+
+: read-fcode# ( -- FCode# )
+ read-byte
+ dup 01 0F between IF drop read-fcode-num16 THEN
+ ;
+
+: read-header ( adr -- )
+ next-ip read-byte drop
+ next-ip read-fcode-num16 drop
+ next-ip read-fcode-num32 drop
+ ;
+
+: read-fcode-string ( -- str len )
+ read-byte \ get string length ( -- len )
+ next-ip get-ip \ get string addr ( -- len str )
+ swap \ type needs the parameters swapped ( -- str len )
+ dup 1- jump-n-ip \ jump to the end of the string in FCode
+ ;
+
+
+-1 VALUE break-fcode-addr
+0 VALUE break-fcode-steps
+
+: evaluate-fcode ( -- )
+ BEGIN
+ get-ip break-fcode-addr = IF
+ TRUE fcode-end !
+ THEN
+ fcode-end @ 0=
+ WHILE
+ fcode@ ( fcode# )
+ eva-debug? IF
+ dup
+ get-ip 8 u.r ." : "
+ ." [" 3 u.r ." ] "
+ THEN
+ \ When it is not immediate and in compile-mode, then compile
+ get-token 0= ?compile-mode AND IF ( xt )
+ compile,
+ ELSE \ immediate or "interpretation" mode
+ eva-debug? IF dup xt>name type space THEN
+ execute
+ THEN
+ eva-debug? IF .s cr THEN
+ break-fcode-steps IF
+ break-fcode-steps 1- TO break-fcode-steps
+ break-fcode-steps 0= IF
+ TRUE fcode-end !
+ THEN
+ THEN
+ next-ip
+ REPEAT
+;
+
+\ Run FCODE for n steps
+: steps-fcode ( n -- )
+ to break-fcode-steps
+ break-fcode-addr >r -1 to break-fcode-addr
+ reset-fcode-end
+ evaluate-fcode
+ r> to break-fcode-addr
+;
+
+\ Step through one FCODE instruction
+: step-fcode ( -- )
+ 1 steps-fcode
+;
diff --git a/qemu/roms/SLOF/slof/fs/fcode/evaluator.fs b/qemu/roms/SLOF/slof/fs/fcode/evaluator.fs
new file mode 100644
index 000000000..8f0bae527
--- /dev/null
+++ b/qemu/roms/SLOF/slof/fs/fcode/evaluator.fs
@@ -0,0 +1,119 @@
+\ *****************************************************************************
+\ * Copyright (c) 2004, 2011 IBM Corporation
+\ * All rights reserved.
+\ * This program and the accompanying materials
+\ * are made available under the terms of the BSD License
+\ * which accompanies this distribution, and is available at
+\ * http://www.opensource.org/licenses/bsd-license.php
+\ *
+\ * Contributors:
+\ * IBM Corporation - initial implementation
+\ ****************************************************************************/
+
+
+variable ip
+variable fcode-end
+variable fcode-num
+ 1 value fcode-spread
+ 2 value fcode-offset
+false value eva-debug?
+true value fcode-debug?
+defer fcode-rb@
+defer fcode@
+
+' c@ to fcode-rb@
+
+create token-table 2000 cells allot \ 1000h = 4096d
+
+#include "core.fs"
+#include "1275.fs"
+#include "tokens.fs"
+#include "locals.fs"
+
+0 value buff
+0 value buff-size
+
+' read-fcode# to fcode@
+
+( ---------------------------------------------------- )
+
+: execute-rom-fcode ( addr len | false -- )
+ reset-fcode-end
+ ?dup IF
+ diagnostic-mode? IF ." , executing ..." cr THEN
+ dup >r r@ alloc-mem dup >r swap rmove
+ r@ set-ip evaluate-fcode
+ diagnostic-mode? IF ." Done." cr THEN
+ r> r> free-mem
+ THEN
+;
+
+: rom-code-ignored ( image-addr name len -- image-addr )
+ diagnostic-mode? IF
+ type ." code found in image " dup . ." , ignoring ..." cr
+ ELSE
+ 2drop
+ THEN
+;
+
+: pci-find-rom ( baseaddr -- addr )
+ dup IF
+ dup rw@-le aa55 = IF
+ diagnostic-mode? IF ." Device ROM header found at " dup . cr THEN
+ ELSE
+ drop 0
+ THEN
+ THEN
+;
+
+: pci-find-fcode ( baseaddr -- addr len | false )
+ BEGIN
+ 1ff NOT and \ Image must start at 512 byte boundary
+ pci-find-rom dup
+ WHILE
+ dup 18 + rw@-le + ( pcir-addr )
+ \ Check for PCIR magic ... since pcir-addr might not be
+ \ 4-byte aligned, we've got to use two reads here:
+ dup rw@-le 4350 ( 'PC' ) <> ( pcir-addr hasPC? )
+ over 2+ rw@-le 5249 ( 'IR' ) <> OR IF
+ diagnostic-mode? IF
+ ." Invalid PCI Data structure, ignoring ROM contents" cr
+ THEN
+ drop false EXIT
+ THEN ( pcir-addr )
+ dup 14 + rb@ CASE \ Get image code type
+ 0 OF s" Intel x86 BIOS" rom-code-ignored ENDOF
+ 1 OF
+ diagnostic-mode? IF
+ ." Open Firmware FCode found in image at " dup . cr
+ THEN
+ dup 1ff NOT AND \ Back to the ROM image header
+ dup 2+ rw@-le + \ Pointer to FCODE (PCI bus binding ch.9)
+ swap 10 + rw@-le 200 * \ Image length
+ EXIT
+ ENDOF
+ 2 OF s" HP PA RISC" rom-code-ignored ENDOF
+ 3 OF s" EFI" rom-code-ignored ENDOF
+ dup OF s" Unknown type" rom-code-ignored ENDOF
+ ENDCASE
+ dup 15 + rb@ 80 and IF \ End of last image?
+ drop false EXIT
+ THEN
+ dup 10 + rw@-le 200 * + \ Next image start
+ REPEAT
+;
+
+
+\ Prepare and run a FCODE program from a PCI Option ROM.
+: pci-execute-fcode ( baseaddr -- )
+ pci-find-fcode dup 0= IF
+ 2drop EXIT
+ THEN ( addr len )
+ fc-set-pci-mmio-tokens \ Prepare PCI access functions
+ \ Now run the FCODE:
+ ['] execute-rom-fcode CATCH IF
+ cr ." FCODE failed!" cr
+ 2drop
+ THEN
+ fc-set-normal-mmio-tokens \ Restore normal MMIO access functions
+;
diff --git a/qemu/roms/SLOF/slof/fs/fcode/little-big.fs b/qemu/roms/SLOF/slof/fs/fcode/little-big.fs
new file mode 100644
index 000000000..309c626a9
--- /dev/null
+++ b/qemu/roms/SLOF/slof/fs/fcode/little-big.fs
@@ -0,0 +1,96 @@
+\ *****************************************************************************
+\ * Copyright (c) 2004, 2011 IBM Corporation
+\ * All rights reserved.
+\ * This program and the accompanying materials
+\ * are made available under the terms of the BSD License
+\ * which accompanies this distribution, and is available at
+\ * http://www.opensource.org/licenses/bsd-license.php
+\ *
+\ * Contributors:
+\ * IBM Corporation - initial implementation
+\ ****************************************************************************/
+
+\ little- and big-endian FCODE IP access functions
+
+
+?bigendian [IF] \ Big endian access functions first
+
+
+: read-fcode-num16 ( -- n )
+ 0 fcode-num !
+ ?arch64 IF
+ read-byte fcode-num 6 + C!
+ next-ip
+ read-byte fcode-num 7 + C!
+ ELSE
+ read-byte fcode-num 2 + C!
+ next-ip
+ read-byte fcode-num 3 + C!
+ THEN
+ fcode-num @
+;
+
+: read-fcode-num32 ( -- n )
+ 0 fcode-num !
+ ?arch64 IF
+ read-byte fcode-num 4 + C!
+ next-ip
+ read-byte fcode-num 5 + C!
+ next-ip
+ read-byte fcode-num 6 + C!
+ next-ip
+ read-byte fcode-num 7 + C!
+ ELSE
+ read-byte fcode-num 0 + C!
+ next-ip
+ read-byte fcode-num 1 + C!
+ next-ip
+ read-byte fcode-num 2 + C!
+ next-ip
+ read-byte fcode-num 3 + C!
+ THEN
+ fcode-num @
+;
+
+
+[ELSE] \ Now the little endian access functions
+
+
+: read-fcode-num16 ( -- n )
+ 0 fcode-num !
+ ?arch64 IF
+ read-byte fcode-num 7 + C!
+ next-ip
+ read-byte fcode-num 6 + C!
+ ELSE
+ read-byte fcode-num 1 + C!
+ next-ip
+ read-byte fcode-num 0 + C!
+ THEN
+ fcode-num @
+;
+
+: read-fcode-num32 ( adr -- n )
+ 0 fcode-num !
+ ?arch64 IF
+ read-byte fcode-num 7 + C!
+ next-ip
+ read-byte fcode-num 6 + C!
+ next-ip
+ read-byte fcode-num 5 + C!
+ next-ip
+ read-byte fcode-num 4 + C!
+ ELSE
+ read-byte fcode-num 3 + C!
+ next-ip
+ read-byte fcode-num 2 + C!
+ next-ip
+ read-byte fcode-num 1 + C!
+ next-ip
+ read-byte fcode-num 0 + C!
+ THEN
+ fcode-num @
+;
+
+
+[THEN]
diff --git a/qemu/roms/SLOF/slof/fs/fcode/locals.fs b/qemu/roms/SLOF/slof/fs/fcode/locals.fs
new file mode 100644
index 000000000..5381df058
--- /dev/null
+++ b/qemu/roms/SLOF/slof/fs/fcode/locals.fs
@@ -0,0 +1,155 @@
+\ *****************************************************************************
+\ * Copyright (c) 2011 IBM Corporation
+\ * All rights reserved.
+\ * This program and the accompanying materials
+\ * are made available under the terms of the BSD License
+\ * which accompanies this distribution, and is available at
+\ * http://www.opensource.org/licenses/bsd-license.php
+\ *
+\ * Contributors:
+\ * IBM Corporation - initial implementation
+\ ****************************************************************************/
+\ *
+\ * Support for old-fashioned local values in FCODE.
+\ *
+\ * There is one old FCODE tokenizer that uses the FCODE opcodes in the range
+\ * of 0x407 to 0x41f for supporting Forth local values. Each locals stack
+\ * frame contains 8 variables. The opcodes from 0x407 to 0x40f are used to
+\ * push 0 up to 8 values from the normal data stack into the current locals
+\ * stack frame. All other variables in the current stack frame are not
+\ * pre-initialized.
+\ * The opcodes from 0x410 to 0x417 can be used for reading the first, second,
+\ * ... eighth value out of the locals stack frame, and the opcode from 0x418
+\ * to 0x41f can be used to set the first, second, ... eighth value in the
+\ * stack frame respectively.
+\ *
+
+80 cells CONSTANT LOCALS-STACK-SIZE
+
+LOCALS-STACK-SIZE BUFFER: localsstackbuf
+
+localsstackbuf VALUE localsstack
+
+
+: fc-local@ ( n -- val )
+ cells localsstack swap - @
+;
+
+: fc-local-1-@ 1 fc-local@ ;
+: fc-local-2-@ 2 fc-local@ ;
+: fc-local-3-@ 3 fc-local@ ;
+: fc-local-4-@ 4 fc-local@ ;
+: fc-local-5-@ 5 fc-local@ ;
+: fc-local-6-@ 6 fc-local@ ;
+: fc-local-7-@ 7 fc-local@ ;
+: fc-local-8-@ 8 fc-local@ ;
+
+
+: fc-local! ( val n -- )
+ cells localsstack swap - !
+;
+
+: fc-local-1-! 1 fc-local! ;
+: fc-local-2-! 2 fc-local! ;
+: fc-local-3-! 3 fc-local! ;
+: fc-local-4-! 4 fc-local! ;
+: fc-local-5-! 5 fc-local! ;
+: fc-local-6-! 6 fc-local! ;
+: fc-local-7-! 7 fc-local! ;
+: fc-local-8-! 8 fc-local! ;
+
+
+0 VALUE uses-locals?
+
+\ Create space for the current function on the locals stack.
+\ Pre-initialized the n first locals with the n top-most data stack items.
+\ Note: Each function can use up to 8 (initialized or uninitialized) locals.
+: (fc-push-locals) ( ... n -- )
+ \ cr ." pushing " dup . ." locals" cr
+ 8 cells localsstack + TO localsstack
+ localsstack localsstackbuf -
+ LOCALS-STACK-SIZE > ABORT" Locals stack exceeded!"
+ ?dup IF
+ ( ... n ) 1 swap DO
+ i fc-local! \ Store pre-initialized locals
+ -1 +LOOP
+ THEN
+;
+
+: fc-push-locals ( n -- )
+ \ cr ." compiling push for " dup . ." locals" cr
+ uses-locals? ABORT" Definition pushes locals multiple times!"
+ true TO uses-locals?
+ ( n ) ['] literal execute
+ ['] (fc-push-locals) compile,
+;
+
+: fc-push-0-locals 0 fc-push-locals ;
+: fc-push-1-locals 1 fc-push-locals ;
+: fc-push-2-locals 2 fc-push-locals ;
+: fc-push-3-locals 3 fc-push-locals ;
+: fc-push-4-locals 4 fc-push-locals ;
+: fc-push-5-locals 5 fc-push-locals ;
+: fc-push-6-locals 6 fc-push-locals ;
+: fc-push-7-locals 7 fc-push-locals ;
+: fc-push-8-locals 8 fc-push-locals ;
+
+
+: fc-pop-locals ( -- )
+ \ ." popping locals" cr
+ localsstack 8 cells - TO localsstack
+ localsstack localsstackbuf - 0 < ABORT" Locals stack undeflow!"
+;
+
+
+: fc-locals-exit
+ uses-locals? IF
+ \ ." compiling pop-locals for exit" cr
+ ['] fc-pop-locals compile,
+ THEN
+ ['] exit compile,
+;
+
+: fc-locals-b(;)
+ uses-locals? IF
+ \ ." compiling pop-locals for b(;)" cr
+ ['] fc-pop-locals compile,
+ THEN
+ false TO uses-locals?
+ ['] b(;) execute
+;
+
+
+: fc-set-locals-tokens ( -- )
+ ['] fc-push-0-locals 1 407 set-token
+ ['] fc-push-1-locals 1 408 set-token
+ ['] fc-push-2-locals 1 409 set-token
+ ['] fc-push-3-locals 1 40a set-token
+ ['] fc-push-4-locals 1 40b set-token
+ ['] fc-push-5-locals 1 40c set-token
+ ['] fc-push-6-locals 1 40d set-token
+ ['] fc-push-7-locals 1 40e set-token
+ ['] fc-push-8-locals 1 40f set-token
+
+ ['] fc-local-1-@ 0 410 set-token
+ ['] fc-local-2-@ 0 411 set-token
+ ['] fc-local-3-@ 0 412 set-token
+ ['] fc-local-4-@ 0 413 set-token
+ ['] fc-local-5-@ 0 414 set-token
+ ['] fc-local-6-@ 0 415 set-token
+ ['] fc-local-7-@ 0 416 set-token
+ ['] fc-local-8-@ 0 417 set-token
+
+ ['] fc-local-1-! 0 418 set-token
+ ['] fc-local-2-! 0 419 set-token
+ ['] fc-local-3-! 0 41a set-token
+ ['] fc-local-4-! 0 41b set-token
+ ['] fc-local-5-! 0 41c set-token
+ ['] fc-local-6-! 0 41d set-token
+ ['] fc-local-7-! 0 41e set-token
+ ['] fc-local-8-! 0 41f set-token
+
+ ['] fc-locals-exit 1 33 set-token
+ ['] fc-locals-b(;) 1 c2 set-token
+;
+fc-set-locals-tokens
diff --git a/qemu/roms/SLOF/slof/fs/fcode/tokens.fs b/qemu/roms/SLOF/slof/fs/fcode/tokens.fs
new file mode 100644
index 000000000..3efc17e06
--- /dev/null
+++ b/qemu/roms/SLOF/slof/fs/fcode/tokens.fs
@@ -0,0 +1,480 @@
+\ *****************************************************************************
+\ * Copyright (c) 2004, 2011 IBM Corporation
+\ * All rights reserved.
+\ * This program and the accompanying materials
+\ * are made available under the terms of the BSD License
+\ * which accompanies this distribution, and is available at
+\ * http://www.opensource.org/licenses/bsd-license.php
+\ *
+\ * Contributors:
+\ * IBM Corporation - initial implementation
+\ ****************************************************************************/
+
+: fc-abort ." FCode called abort: IP " get-ip . ( ." STACK: " .s ) depth dup 0< IF abort THEN . rdepth . cr abort ;
+: fc-0 ." 0(lit): STACK ( S: " depth . ." R: " rdepth . ." ): " depth 0> IF .s THEN 0 ;
+: fc-1 ." 1(lit): STACK ( S: " depth . ." R: " rdepth . ." ): " depth 0> IF .s THEN 1 ;
+
+: parse-1hex 1 hex-decode-unit ;
+
+\ Adjust functions for accessing MMIO registers. According to IEEE 1275,
+\ a bus device can substitute bus-specific implementations of r*@ and r*!
+\ for use by its children, e.g. with respect to byte-order. Since PCI is
+\ little endian by default, we've got to use the little endian accessor
+\ functions for the PCI bus (some FCODE programs are expecting this behavior).
+: fc-set-pci-mmio-tokens ( -- )
+ ['] rw@-le 0 232 set-token
+ ['] rw!-le 0 233 set-token
+ ['] rl@-le 0 234 set-token
+ ['] rl!-le 0 235 set-token
+ ['] rx@-le 0 22E set-token
+ ['] rx!-le 0 22F set-token
+;
+
+\ Set normal MMIO access token behavior:
+: fc-set-normal-mmio-tokens ( -- )
+ ['] rw@ 0 232 set-token
+ ['] rw! 0 233 set-token
+ ['] rl@ 0 234 set-token
+ ['] rl! 0 235 set-token
+ ['] rx@ 0 22E set-token
+ ['] rx! 0 22F set-token
+;
+
+: reset-token-table
+ FFF 0 DO ['] ferror 0 i set-token LOOP
+ ;
+
+reset-token-table
+
+' end0 0 00 set-token
+
+\ 01...0F beginning code of 2-byte FCode sequences
+
+' b(lit) 1 10 set-token
+
+' b(') 1 11 set-token
+' b(") 1 12 set-token
+' bbranch 1 13 set-token
+' b?branch 1 14 set-token
+' b(loop) 1 15 set-token
+' b(+loop) 1 16 set-token
+' b(do) 1 17 set-token
+' b(?do) 1 18 set-token
+' i 0 19 set-token
+' j 0 1A set-token
+' b(leave) 1 1B set-token
+' b(of) 1 1C set-token
+' execute 0 1D set-token
+' + 0 1E set-token
+' - 0 1F set-token
+' * 0 20 set-token
+' / 0 21 set-token
+' mod 0 22 set-token
+' and 0 23 set-token
+' or 0 24 set-token
+' xor 0 25 set-token
+' invert 0 26 set-token
+' lshift 0 27 set-token
+' rshift 0 28 set-token
+' >>a 0 29 set-token
+' /mod 0 2A set-token
+' u/mod 0 2B set-token
+' negate 0 2C set-token
+' abs 0 2D set-token
+' min 0 2E set-token
+' max 0 2F set-token
+' >r 0 30 set-token
+' r> 0 31 set-token
+' r@ 0 32 set-token
+' exit 0 33 set-token
+' 0= 0 34 set-token
+' 0<> 0 35 set-token
+' 0< 0 36 set-token
+' 0<= 0 37 set-token
+' 0> 0 38 set-token
+' 0>= 0 39 set-token
+' < 0 3A set-token
+' > 0 3B set-token
+' = 0 3C set-token
+' <> 0 3D set-token
+' u> 0 3E set-token
+' u<= 0 3F set-token
+' u< 0 40 set-token
+' u>= 0 41 set-token
+' >= 0 42 set-token
+' <= 0 43 set-token
+' between 0 44 set-token
+' within 0 45 set-token
+' DROP 0 46 set-token
+' DUP 0 47 set-token
+' OVER 0 48 set-token
+' SWAP 0 49 set-token
+' ROT 0 4A set-token
+' -ROT 0 4B set-token
+' TUCK 0 4C set-token
+' nip 0 4D set-token
+' pick 0 4E set-token
+' roll 0 4F set-token
+' ?dup 0 50 set-token
+' depth 0 51 set-token
+' 2drop 0 52 set-token
+' 2dup 0 53 set-token
+' 2over 0 54 set-token
+' 2swap 0 55 set-token
+' 2rot 0 56 set-token
+' 2/ 0 57 set-token
+' u2/ 0 58 set-token
+' 2* 0 59 set-token
+' /c 0 5A set-token
+' /w 0 5B set-token
+' /l 0 5C set-token
+' /n 0 5D set-token
+' ca+ 0 5E set-token
+' wa+ 0 5F set-token
+' la+ 0 60 set-token
+' na+ 0 61 set-token
+' char+ 0 62 set-token
+' wa1+ 0 63 set-token
+' la1+ 0 64 set-token
+' cell+ 0 65 set-token
+' chars 0 66 set-token
+' /w* 0 67 set-token
+' /l* 0 68 set-token
+' cells 0 69 set-token
+' on 0 6A set-token
+' off 0 6B set-token
+' +! 0 6C set-token
+' @ 0 6D set-token
+' fc-l@ 0 6E set-token
+' fc-w@ 0 6F set-token
+' fc-<w@ 0 70 set-token
+' fc-c@ 0 71 set-token
+' ! 0 72 set-token
+' fc-l! 0 73 set-token
+' fc-w! 0 74 set-token
+' fc-c! 0 75 set-token
+' 2@ 0 76 set-token
+' 2! 0 77 set-token
+' fc-move 0 78 set-token
+' fc-fill 0 79 set-token
+' comp 0 7A set-token
+' noop 0 7B set-token
+' lwsplit 0 7C set-token
+' wljoin 0 7D set-token
+' lbsplit 0 7E set-token
+' bljoin 0 7F set-token
+' wbflip 0 80 set-token
+' upc 0 81 set-token
+' lcc 0 82 set-token
+' pack 0 83 set-token
+' count 0 84 set-token
+' body> 0 85 set-token
+' >body 0 86 set-token
+' fcode-revision 0 87 set-token
+' span 0 88 set-token
+' unloop 0 89 set-token
+' expect 0 8A set-token
+' alloc-mem 0 8B set-token
+' free-mem 0 8C set-token
+' key? 0 8D set-token
+' key 0 8E set-token
+' emit 0 8F set-token
+' type 0 90 set-token
+' (cr 0 91 set-token
+' cr 0 92 set-token
+' #out 0 93 set-token
+' #line 0 94 set-token
+' hold 0 95 set-token
+' <# 0 96 set-token
+' u#> 0 97 set-token
+' sign 0 98 set-token
+' u# 0 99 set-token
+' u#s 0 9A set-token
+' u. 0 9B set-token
+' u.r 0 9C set-token
+' . 0 9D set-token
+' .r 0 9E set-token
+' .s 0 9F set-token
+' base 0 A0 set-token
+\ ' convert 0 A1 set-token \ historical, not supported
+' $number 0 A2 set-token
+' digit 0 A3 set-token
+' -1 0 A4 set-token
+' 0 0 A5 set-token
+' 1 0 A6 set-token
+' 2 0 A7 set-token
+' 3 0 A8 set-token
+' bl 0 A9 set-token
+' bs 0 AA set-token
+' bell 0 AB set-token
+' bounds 0 AC set-token
+' here 0 AD set-token
+' aligned 0 AE set-token
+' wbsplit 0 AF set-token
+' bwjoin 0 B0 set-token
+' b(<mark) 1 B1 set-token
+' b(>resolve) 1 B2 set-token
+\ ' set-token-table 0 B3 set-token \ historical, not supported
+\ ' set-table 0 B4 set-token \ historical, not supported
+' new-token 0 B5 set-token
+' named-token 0 B6 set-token
+' b(:) 1 B7 set-token
+' b(value) 1 B8 set-token
+' b(variable) 1 B9 set-token
+' b(constant) 1 BA set-token
+' b(create) 1 BB set-token
+' b(defer) 1 BC set-token
+' b(buffer:) 1 BD set-token
+' b(field) 1 BE set-token
+\ ' b(code) 0 BF set-token \ historical, not supported
+' fc-instance 1 C0 set-token
+\ ' ferror 0 C1 set-token \ Reserved
+' b(;) 1 C2 set-token
+' b(to) 1 C3 set-token
+' b(case) 1 C4 set-token
+' b(endcase) 1 C5 set-token
+' b(endof) 1 C6 set-token
+' # 0 C7 set-token
+' #s 0 C8 set-token
+' #> 0 C9 set-token
+' external-token 0 CA set-token
+' $find 0 CB set-token
+' offset16 0 CC set-token
+' evaluate 0 CD set-token
+\ 0 CE reserved
+\ 0 CF reserved
+' c, 0 D0 set-token
+' w, 0 D1 set-token
+' l, 0 D2 set-token
+' , 0 D3 set-token
+' um* 0 D4 set-token
+' um/mod 0 D5 set-token
+\ 0 D6 reserved
+\ 0 D7 reserved
+' d+ 0 D8 set-token
+' d- 0 D9 set-token
+' get-token 0 DA set-token
+' set-token 0 DB set-token
+' state 0 DC set-token \ possibly broken
+' compile, 0 DD set-token
+' behavior 0 DE set-token
+
+\ Tokens 0xDF to 0xEF are reserved
+
+' start0 0 F0 set-token
+' start1 0 F1 set-token
+' start2 0 F2 set-token
+' start4 0 F3 set-token
+
+\ Tokens 0xF4 to 0xFB are reserved
+
+' ferror 0 FC set-token
+' version1 0 FD set-token
+
+\ ' 4-byte-id 0 FE set-token \ Historical, not supported
+' end1 0 FF set-token
+
+\ 0 100 set-token \ reserved
+' dma-alloc 0 101 set-token \ Obsolete
+' my-address 0 102 set-token
+' my-space 0 103 set-token
+\ ' memmap 0 104 set-token \ Obsolete
+' free-virtual 0 105 set-token
+\ ' >physical 0 106 set-token \ Obsolete
+
+\ Tokens 0x107 to 0x10e are reserved
+
+' my-params 0 10f set-token \ Obsolete
+' property 0 110 set-token
+' encode-int 0 111 set-token
+' encode+ 0 112 set-token
+' encode-phys 0 113 set-token
+' encode-string 0 114 set-token
+' encode-bytes 0 115 set-token
+' reg 0 116 set-token
+' intr 0 117 set-token \ Obsolete
+' driver 0 118 set-token \ Obsolete
+' model 0 119 set-token
+' device-type 0 11A set-token
+' parse-2int 0 11B set-token
+\ ' is-install 0 11C set-token \ Will be set by framebuffer code
+\ ' is-remove 0 11D set-token \ Will be set by framebuffer code
+\ ' is-selftest 0 11E set-token \ Will be set by framebuffer code
+' new-device 0 11F set-token
+' diagnostic-mode? 0 120 set-token
+' display-status 0 121 set-token \ Maybe obsolete
+' memory-test-suite 0 122 set-token
+' group-code 0 123 set-token \ Obsolete
+' mask 0 124 set-token
+' get-msecs 0 125 set-token
+' ms 0 126 set-token
+' finish-device 0 127 set-token
+' decode-phys 0 128 set-token
+\ ' push-package 0 129 set-token \ TODO - from proposal 215
+\ ' pop-package 0 12A set-token \ TODO - from proposal 215
+' interpose 0 12B set-token \ Recommended practice: Interposition
+
+\ Tokens 0x12C to 0x12F are reserved
+
+' map-low 0 130 set-token
+' sbus-intr>cpu 0 131 set-token \ Obsolete
+
+\ Tokens 0x132 to 0x14f are reserved
+
+\ The following tokens will be set by the framebuffer code:
+\ ' #lines 0 150 set-token
+\ ' #columns 0 151 set-token
+\ ' line# 0 152 set-token
+\ ' column# 0 153 set-token
+\ ' inverse? 0 154 set-token
+\ ' inverse-screen? 0 155 set-token
+\ ' frame-buffer-busy 0 156 set-token \ Historical, not supported
+\ ' draw-character 0 157 set-token
+\ ' reset-screen 0 158 set-token
+\ ' toggle-cursor 0 159 set-token
+\ ' erase-screen 0 15A set-token
+\ ' blink-screen 0 15B set-token
+\ ' invert-screen 0 15C set-token
+\ ' insert-characters 0 15D set-token
+\ ' delete-characters 0 15E set-token
+\ ' insert-lines 0 15F set-token
+\ ' delete-lines 0 160 set-token
+\ ' draw-logo 0 161 set-token
+\ ' frame-buffer-adr 0 162 set-token
+\ ' screen-height 0 163 set-token
+\ ' screen-width 0 164 set-token
+\ ' window-top 0 165 set-token
+\ ' window-left 0 166 set-token
+\ ' 0 167 set-token \ Reserved
+\ ' foreground-color 0 168 set-token \ From 16-color recommended practice
+\ ' background-color 0 169 set-token \ From 16-color recommended practice
+\ ' default-font 0 16A set-token
+\ ' set-font 0 16B set-token
+\ ' char-height 0 16C set-token
+\ ' char-width 0 16D set-token
+\ ' >font 0 16E set-token
+\ ' fontbytes 0 16F set-token
+
+\ Tokens 0x170 to 0x17C are obsolete fb1 functions
+\ Tokens 0x17D to 0x17F are reserved
+
+\ The following tokens will be set by the framebuffer code, too:
+\ ' fb8-draw-character 0 180 set-token
+\ ' fb8-reset-screen 0 181 set-token
+\ ' fb8-toggle-cursor 0 182 set-token
+\ ' fb8-erase-screen 0 183 set-token
+\ ' fb8-blink-screen 0 184 set-token
+\ ' fb8-invert-screen 0 185 set-token
+\ ' fb8-insert-characters 0 186 set-token
+\ ' fb8-delete-characters 0 187 set-token
+\ ' fb8-insert-lines 0 188 set-token
+\ ' fb8-delete-lines 0 189 set-token
+\ ' fb8-draw-logo 0 18A set-token
+\ ' fb8-install 0 18B set-token
+
+\ Tokens 0x18C to 0x18F are reserved
+\ Tokens 0x190 to 0x196 are obsolete VMEbus tokens
+\ Tokens 0x197 to 0x19F are reserved
+
+\ ' return-buffer 0 1A0 set-token \ Historical, not supported
+\ ' xmit-packet 0 1A1 set-token \ Historical, not supported
+\ ' poll-packet 0 1A2 set-token \ Historical, not supported
+\ 0 1A3 set-token \ reserved
+' mac-address 0 1A4 set-token
+
+\ Tokens 0x1A5 to 0x200 are reserved
+
+' device-name 0 201 set-token
+' my-args 0 202 set-token
+' my-self 0 203 set-token
+' find-package 0 204 set-token
+' open-package 0 205 set-token
+' close-package 0 206 set-token
+' find-method 0 207 set-token
+' call-package 0 208 set-token
+' $call-parent 0 209 set-token
+' my-parent 0 20A set-token
+' ihandle>phandle 0 20B set-token
+\ 0 20C set-token \ reserved
+' my-unit 0 20D set-token
+' $call-method 0 20E set-token
+' $open-package 0 20F set-token
+' processor-type 0 210 set-token \ Obsolete
+' firmware-version 0 211 set-token \ Obsolete
+' fcode-version 0 212 set-token \ Obsolete
+\ ' alarm 0 213 set-token \ TODO
+' (is-user-word) 0 214 set-token
+' suspend-fcode 0 215 set-token
+' fc-abort 0 216 set-token
+' catch 0 217 set-token
+' throw 0 218 set-token
+\ ' user-abort 0 219 set-token \ TODO
+' get-my-property 0 21A set-token
+' decode-int 0 21B set-token
+' decode-string 0 21C set-token
+' get-inherited-property 0 21D set-token
+' delete-property 0 21E set-token
+' get-package-property 0 21F set-token
+' cpeek 0 220 set-token
+' wpeek 0 221 set-token
+' lpeek 0 222 set-token
+' cpoke 0 223 set-token
+' wpoke 0 224 set-token
+' lpoke 0 225 set-token
+' lwflip 0 226 set-token
+' lbflip 0 227 set-token
+' lbflips 0 228 set-token
+\ ' adr-mask 0 229 set-token \ Historical, not supported
+
+\ Tokens 0x22A to 0x22F are reserved
+
+' rb@ 0 230 set-token
+' rb! 0 231 set-token
+fc-set-normal-mmio-tokens \ Set rw@, rw!, rl@, rl!, rx@ and rx!
+
+' wbflips 0 236 set-token
+' lwflips 0 237 set-token
+\ ' probe 0 238 set-token \ Obsolete
+\ ' probe-virtual 0 239 set-token \ Obsolete
+\ 0 23A reserved
+' child 0 23B set-token
+' peer 0 23C set-token
+' next-property 0 23D set-token
+' byte-load 0 23E set-token
+' set-args 0 23F set-token
+' left-parse-string 0 240 set-token
+
+\ 64-bit extension tokens:
+' bxjoin 0 241 set-token
+' fc-<l@ 0 242 set-token
+' lxjoin 0 243 set-token
+' wxjoin 0 244 set-token
+' x, 0 245 set-token
+' fc-x@ 0 246 set-token
+' fc-x! 0 247 set-token
+' /x 0 248 set-token
+' /x* 0 249 set-token
+' xa+ 0 24A set-token
+' xa1+ 0 24B set-token
+' xbflip 0 24C set-token
+' xbflips 0 24D set-token
+' xbsplit 0 24E set-token
+' xlflip 0 24F set-token
+' xlflips 0 250 set-token
+' xlsplit 0 251 set-token
+' xwflip 0 252 set-token
+' xwflips 0 253 set-token
+' xwsplit 0 254 set-token
+
+\ 0 255 RESERVED FCODES
+\ ...
+\ 0 5FF RESERVED FCODES
+
+\ 0 600 VENDOR FCODES
+\ ...
+\ 0 7FF VENDOR FCODES
+
+\ 0 800 LOCAL FCODES
+\ ...
+\ 0 FFF LOCAL FCODES
+
diff --git a/qemu/roms/SLOF/slof/fs/find-hash.fs b/qemu/roms/SLOF/slof/fs/find-hash.fs
new file mode 100644
index 000000000..a40ccbd4f
--- /dev/null
+++ b/qemu/roms/SLOF/slof/fs/find-hash.fs
@@ -0,0 +1,77 @@
+\ *****************************************************************************
+\ * Copyright (c) 2004, 2008 IBM Corporation
+\ * All rights reserved.
+\ * This program and the accompanying materials
+\ * are made available under the terms of the BSD License
+\ * which accompanies this distribution, and is available at
+\ * http://www.opensource.org/licenses/bsd-license.php
+\ *
+\ * Contributors:
+\ * IBM Corporation - initial implementation
+\ ****************************************************************************/
+
+#ifdef HASH_DEBUG
+0 value from-hash
+0 value not-from-hash
+0 value hash-collisions
+#endif
+
+clean-hash
+
+: hash-find ( str len head -- 0 | link )
+ >r 2dup 2dup hash ( str len str len hash R: head )
+ dup >r @ dup ( str len str len *hash *hash R: head hash )
+ IF ( str len str len *hash R: head hash )
+ link>name name>string string=ci ( str len true|false R: head hash )
+ dup 0=
+ IF
+#ifdef HASH_DEBUG
+ hash-collisions 1+
+ to hash-collisions
+#endif
+ THEN
+ ELSE
+ nip nip ( str len 0 R: head hash )
+ THEN
+ IF \ hash found
+ 2drop r> @ r> drop ( *hash R: )
+#ifdef HASH_DEBUG
+ from-hash 1+ to from-hash
+#endif
+ exit
+ THEN \ hash not found
+ r> r> swap >r ((find)) ( str len head R: hash=0 )
+ dup
+ IF
+#ifdef HASH_DEBUG
+ not-from-hash 1+
+ to not-from-hash
+#endif
+ dup r> ! ( link R: )
+ ELSE
+ r> drop ( 0 R: )
+ THEN
+;
+
+: hash-reveal hash off ;
+
+' hash-reveal to (reveal)
+' hash-find to (find)
+
+#ifdef HASH_DEBUG
+\ print out all entries in the hash table
+: dump-hash-table ( -- )
+ cr
+ hash-table hash-size 0 DO
+ dup @ dup 0<> IF
+ over . s" : " type link>name name>string type cr
+ ELSE
+ drop
+ THEN
+ cell+
+ LOOP drop
+ s" hash-collisions: " type hash-collisions . cr
+ s" from-hash: " type from-hash . cr
+ s" not-from-hash: " type not-from-hash . cr
+;
+#endif
diff --git a/qemu/roms/SLOF/slof/fs/generic-disk.fs b/qemu/roms/SLOF/slof/fs/generic-disk.fs
new file mode 100644
index 000000000..0543c890e
--- /dev/null
+++ b/qemu/roms/SLOF/slof/fs/generic-disk.fs
@@ -0,0 +1,68 @@
+\ *****************************************************************************
+\ * Copyright (c) 2004, 2008 IBM Corporation
+\ * All rights reserved.
+\ * This program and the accompanying materials
+\ * are made available under the terms of the BSD License
+\ * which accompanies this distribution, and is available at
+\ * http://www.opensource.org/licenses/bsd-license.php
+\ *
+\ * Contributors:
+\ * IBM Corporation - initial implementation
+\ ****************************************************************************/
+
+
+\ Generic disk support
+
+\ Input:
+\ name of device ( e.g. "disk", "cdrom", ... )
+\ dev#
+
+\ Needs from parent in device tree:
+\ dev-read-blocks ( addr block# #blocks phys.lo ... phys.hi -- #read )
+\ block-size
+\ max-transfer
+
+\ Provides:
+\ open ( -- okay? )
+\ close ( -- )
+\ read ( addr len -- actual )
+\ seek ( pos.lo pos.hi -- status )
+\ read-blocks ( addr block# #blocks -- #read )
+\ Uses:
+\ disk-label package interpose for partition and file systems support
+\ deblocker package for byte read support
+
+( str len phys.lo ... phys.hi -- )
+new-device set-unit ( str len )
+ 2dup device-name
+ s" 0 pci-alias-" 2swap $cat evaluate
+ s" block" device-type
+
+\ Requiered interface for deblocker
+
+ s" block-size" $call-parent CONSTANT block-size
+ s" max-transfer" $call-parent CONSTANT max-transfer
+
+: read-blocks ( addr block# #blocks -- #read )
+ my-unit s" dev-read-blocks" $call-parent
+;
+
+INSTANCE VARIABLE deblocker
+
+: open ( -- okay? )
+ 0 0 s" deblocker" $open-package dup deblocker ! dup IF
+ s" disk-label" find-package IF
+ my-args rot interpose
+ THEN
+ THEN 0<> ;
+
+: close ( -- )
+ deblocker @ close-package ;
+
+: seek ( pos.lo pos.hi -- status )
+ s" seek" deblocker @ $call-method ;
+
+: read ( addr len -- actual )
+ s" read" deblocker @ $call-method ;
+
+finish-device
diff --git a/qemu/roms/SLOF/slof/fs/graphics.fs b/qemu/roms/SLOF/slof/fs/graphics.fs
new file mode 100644
index 000000000..7d5d9306d
--- /dev/null
+++ b/qemu/roms/SLOF/slof/fs/graphics.fs
@@ -0,0 +1,87 @@
+\ *****************************************************************************
+\ * Copyright (c) 2015 IBM Corporation
+\ * All rights reserved.
+\ * This program and the accompanying materials
+\ * are made available under the terms of the BSD License
+\ * which accompanies this distribution, and is available at
+\ * http://www.opensource.org/licenses/bsd-license.php
+\ *
+\ * Contributors:
+\ * IBM Corporation - initial implementation
+\ ****************************************************************************/
+
+\ Provide some of the functions that are defined in the
+\ "OF Recommended Practice: 8bit Graphics Extension" document
+
+: draw-rectangle ( adr x y w h -- )
+ frame-buffer-adr 0= IF 4drop drop EXIT THEN
+ 0 ?DO
+ 4dup drop ( adr x y w adr x y )
+ \ calculate offset into framebuffer: ((y + i) * width + x) * depth
+ i + screen-width * + screen-depth * ( adr x y w adr offs )
+ frame-buffer-adr + ( adr x y w adr fb_adr )
+ over 3 pick screen-depth * i * + ( adr x y w adr fb_adr src )
+ swap 3 pick screen-depth * ( adr x y w adr src fb_adr len )
+ rmove \ copy line ( adr x y w adr )
+ drop ( adr x y w )
+ LOOP
+ 4drop
+;
+
+: fill-rectangle ( col x y w h -- )
+ frame-buffer-adr 0= IF 4drop drop EXIT THEN
+ 0 ?DO
+ 4dup drop ( col x y w col x y )
+ \ calculate offset into framebuffer: ((y + i) * width + x) * depth
+ i + screen-width * + screen-depth * ( col x y w col offs )
+ frame-buffer-adr + ( col x y w col adr )
+ 2 pick screen-depth * 2 pick ( col x y w col adr len col )
+ rfill \ draw line ( col x y w col )
+ drop ( col x y w )
+ LOOP
+ 4drop
+;
+
+: read-rectangle ( adr x y w h -- )
+ frame-buffer-adr 0= IF 4drop drop EXIT THEN
+ 0 ?DO
+ 4dup drop ( adr x y w adr x y )
+ \ calculate offset into framebuffer: ((y + i) * width + x) * depth
+ i + screen-width * + screen-depth * ( adr x y w adr offs )
+ frame-buffer-adr + ( adr x y w adr fb_adr )
+ over 3 pick screen-depth * i * + ( adr x y w adr fb_adr dst )
+ 3 pick ( adr x y w adr fb_adr dst w )
+ rmove \ copy line ( adr x y w adr )
+ drop ( adr x y w )
+ LOOP
+ 4drop
+;
+
+: dimensions ( -- width height )
+ screen-width screen-height
+;
+
+\ Initialize a default palette (not a standard command, but useful anyway)
+: init-default-palette
+ \ Grayscale ramp for upper colors
+ 100 10 DO
+ i i i i color!
+ LOOP
+ \ Standard colors from "16-color Text Extension" specification
+ 00 00 00 0 color!
+ 00 00 aa 1 color!
+ 00 aa 00 2 color!
+ 00 aa aa 3 color!
+ aa 00 00 4 color!
+ aa 00 aa 5 color!
+ aa 55 00 6 color!
+ aa aa aa 7 color!
+ 55 55 55 8 color!
+ 55 55 ff 9 color!
+ 55 ff 55 a color!
+ 55 ff ff b color!
+ ff 55 55 c color!
+ ff 55 ff d color!
+ ff ff 55 e color!
+ ff ff ff f color!
+;
diff --git a/qemu/roms/SLOF/slof/fs/history.fs b/qemu/roms/SLOF/slof/fs/history.fs
new file mode 100644
index 000000000..2c2c70fe0
--- /dev/null
+++ b/qemu/roms/SLOF/slof/fs/history.fs
@@ -0,0 +1,107 @@
+\ *****************************************************************************
+\ * Copyright (c) 2004, 2008 IBM Corporation
+\ * All rights reserved.
+\ * This program and the accompanying materials
+\ * are made available under the terms of the BSD License
+\ * which accompanies this distribution, and is available at
+\ * http://www.opensource.org/licenses/bsd-license.php
+\ *
+\ * Contributors:
+\ * IBM Corporation - initial implementation
+\ ****************************************************************************/
+
+\ Create debug section in NVRAM
+: debug-init-nvram ( -- )
+ nvram-partition-type-debug get-nvram-partition IF
+ cr ." Could not find debug partition in NVRAM - "
+ nvram-partition-type-debug s" debug" d# 1024 new-nvram-partition
+ ABORT" Failed to create DEBUG NVRAM partition"
+ 2dup erase-nvram-partition drop
+ ." created." cr
+ THEN
+ s" debug-nvram-partition" $2constant
+;
+
+debug-init-nvram
+
+: debug-add-env ( "name" "value" -- ) debug-nvram-partition 2rot 2rot internal-add-env drop ;
+: debug-set-env ( "name" "value" -- ) debug-nvram-partition 2rot 2rot internal-set-env drop ;
+: debug-get-env ( "name" -- "value" TRUE | FALSE) debug-nvram-partition 2swap internal-get-env ;
+
+: debug-get-history-enabled ( -- n ) s" history-enabled?" debug-get-env IF $number IF 0 THEN ELSE 0 THEN ;
+: debug-set-history-enabled ( n -- ) (.) s" history-enabled?" 2swap debug-set-env ;
+
+
+debug-get-history-enabled constant nvram-history?
+
+nvram-history? [IF]
+
+: history-init-nvram ( -- )
+ nvram-partition-type-history get-nvram-partition IF
+ cr ." Could not find history partition in NVRAM - "
+ nvram-partition-type-history s" history" d# 2048 new-nvram-partition
+ ABORT" Failed to create SMS NVRAM partition"
+ 2dup erase-nvram-partition drop
+ ." created" cr
+ THEN
+ s" history-nvram-partition" $2constant
+;
+
+history-init-nvram
+
+0 value (history-len)
+0 value (history-adr)
+
+: (history-load-one) ( str len -- len )
+ \ 2dup ." loading " type cr
+ to (history-len) to (history-adr)
+ /his (history-len) + alloc-mem ( his )
+ his-tail 0= IF dup to his-tail THEN
+ his-head over his>next ! to his-head
+ his-head his>next @ his>prev his-head swap !
+ (history-len) his-head his>len !
+ (history-adr) his-head his>buf (history-len) move
+ (history-len) 1+
+;
+
+: history-load ( -- )
+ history-nvram-partition drop BEGIN dup WHILE
+ dup rzcount ( part str len )
+ dup IF
+ (history-load-one) +
+ ELSE
+ 3drop 0
+ THEN
+ REPEAT
+ drop
+;
+
+: (history-store-one) ( pos len saddr slen -- FALSE | npos nlen TRUE )
+ dup 3 pick < IF \ enough space
+ dup >r rot >r
+ \ 2dup ." storing " type cr
+ bounds DO dup i c@ swap nvram-c! 1+ LOOP
+ dup 0 swap nvram-c! 1+
+ r> r> - 1- true
+ ELSE
+ 2drop false
+ THEN
+;
+
+: history-store ( -- )
+ history-nvram-partition erase-nvram-partition drop
+ history-nvram-partition his-tail BEGIN dup WHILE
+ dup his>buf over his>len @
+ ( position len link saddr slen )
+ rot >r (history-store-one) r>
+ swap IF his>prev @ ELSE drop 0 THEN
+ REPEAT
+ 2drop drop
+;
+
+\ redefine "end of SLOF" words to safe history
+: reset-all history-store reset-all ;
+: reboot history-store reboot ;
+: boot history-store boot ;
+
+[THEN]
diff --git a/qemu/roms/SLOF/slof/fs/ide.fs b/qemu/roms/SLOF/slof/fs/ide.fs
new file mode 100644
index 000000000..d6f16edd0
--- /dev/null
+++ b/qemu/roms/SLOF/slof/fs/ide.fs
@@ -0,0 +1,612 @@
+\ *****************************************************************************
+\ * Copyright (c) 2004, 2008 IBM Corporation
+\ * All rights reserved.
+\ * This program and the accompanying materials
+\ * are made available under the terms of the BSD License
+\ * which accompanies this distribution, and is available at
+\ * http://www.opensource.org/licenses/bsd-license.php
+\ *
+\ * Contributors:
+\ * IBM Corporation - initial implementation
+\ ****************************************************************************/
+\
+\ 26.06.2007 added: two devices (Master/Slave) per channel
+
+1 encode-int s" #address-cells" property
+0 encode-int s" #size-cells" property
+
+: decode-unit 1 hex-decode-unit ;
+: encode-unit 1 hex-encode-unit ;
+
+0 VALUE >ata \ base address for command-block
+0 VALUE >ata1 \ base address for control block
+
+true VALUE no-timeout \ flag that no timeout occurred
+
+0c CONSTANT #cdb-bytes \ command descriptor block (12 bytes)
+800 CONSTANT atapi-size
+200 CONSTANT ata-size
+
+\ *****************************
+\ Some register access helpers.
+\ *****************************
+: ata-ctrl! 2 >ata1 + io-c! ; \ device control reg
+: ata-astat@ 2 >ata1 + io-c@ ; \ read alternate status
+
+: ata-data@ 0 >ata + io-w@ ; \ data reg
+: ata-data! 0 >ata + io-w! ; \ data reg
+: ata-err@ 1 >ata + io-c@ ; \ error reg
+: ata-feat! 1 >ata + io-c! ; \ feature reg
+: ata-cnt@ 2 >ata + io-c@ ; \ sector count reg
+: ata-cnt! 2 >ata + io-c! ; \ sector count reg
+: ata-lbal! 3 >ata + io-c! ; \ lba low reg
+: ata-lbal@ 3 >ata + io-c@ ; \ lba low reg
+: ata-lbam! 4 >ata + io-c! ; \ lba mid reg
+: ata-lbam@ 4 >ata + io-c@ ; \ lba mid reg
+: ata-lbah! 5 >ata + io-c! ; \ lba high reg
+: ata-lbah@ 5 >ata + io-c@ ; \ lba high reg
+: ata-dev! 6 >ata + io-c! ; \ device reg
+: ata-dev@ 6 >ata + io-c@ ; \ device reg
+: ata-cmd! 7 >ata + io-c! ; \ command reg
+: ata-stat@ 7 >ata + io-c@ ; \ status reg
+
+\ **********************************************************************
+\ ATA / ATAPI Commands specifications:
+\ - AT Attachment 8 - ATA/ATAPI Command Set (ATA8-ACS)
+\ - ATA Packet Interface for CD-ROMs SFF-8020i
+\ - ATA/ATAPI Host Adapters Standard (T13/1510D)
+\ **********************************************************************
+00 CONSTANT cmd#nop \ ATA and ATAPI
+08 CONSTANT cmd#device-reset \ ATAPI only (mandatory)
+20 CONSTANT cmd#read-sector \ ATA and ATAPI
+90 CONSTANT cmd#execute-device-diagnostic \ ATA and ATAPI
+a0 CONSTANT cmd#packet \ ATAPI only (mandatory)
+a1 CONSTANT cmd#identify-packet-device \ ATAPI only (mandatory)
+ec CONSTANT cmd#identify-device \ ATA and ATAPI
+
+\ *****************************
+\ Setup Regs for ATA:
+\ BAR 0 & 1 : Device 0
+\ BAR 2 & 3 : Device 1
+\ *****************************
+: set-regs ( n -- )
+ dup
+ 01 and \ only Chan 0 or Chan 1 allowed
+ 3 lshift dup 10 + config-l@ -4 and to >ata
+ 14 + config-l@ -4 and to >ata1
+ 02 ata-ctrl! \ disable interrupts
+ 02 and
+ IF
+ 10
+ ELSE
+ 00
+ THEN
+ ata-dev!
+;
+
+ata-size VALUE block-size
+80000 VALUE max-transfer \ Arbitrary, really
+
+CREATE sector d# 512 allot
+CREATE packet-cdb #cdb-bytes allot
+CREATE return-buffer atapi-size allot
+
+scsi-open \ add scsi functions
+
+\ ********************************
+\ show all ATAPI-registers
+\ data-register not read in order
+\ to not influence PIO mode
+\ ********************************
+: show-regs
+ cr
+ cr ." alt. Status: " ata-astat@ .
+ cr ." Status : " ata-stat@ .
+ cr ." Device : " ata-dev@ .
+ cr ." Error-Reg : " ata-err@ .
+ cr ." Sect-Count : " ata-cnt@ .
+ cr ." LBA-Low : " ata-lbal@ .
+ cr ." LBA-Med : " ata-lbam@ .
+ cr ." LBA-High : " ata-lbah@ .
+;
+
+\ ***************************************************
+\ reads ATAPI-Status and displays it if check-bit set
+\ ***************************************************
+: status-check ( -- )
+ ata-stat@
+ dup
+ 01 and \ is 'check' flag set ?
+ IF
+ cr
+ ." - ATAPI-Status: " .
+ ata-err@ \ retrieve sense code
+ dup
+ 60 = \ sense code = 6 ?
+ IF
+ ." ( media changed or reset )" \ 'unit attention'
+ drop \ drop err-reg content
+ ELSE
+ dup
+ ." (Err : " . \ show err-reg content
+ space
+ rshift 4 .sense-text \ show text string
+ 29 emit
+ THEN
+ cr
+ ELSE
+ drop \ remove unused status
+ THEN
+;
+
+\ *************************************
+\ Wait for interface ready condition
+\ Bit 7 of Status-Register is busy flag
+\ new version with abort after 5 sec.
+\ *************************************
+: wait-for-ready
+ get-msecs \ start timer
+ BEGIN
+ ata-stat@ 80 and 0<> \ busy flag still set ?
+ no-timeout and
+ WHILE \ yes
+ dup get-msecs swap
+ - \ calculate timer difference
+ FFFF AND \ reduce to 65.5 seconds
+ d# 5000 > \ difference > 5 seconds ?
+ IF
+ false to no-timeout
+ THEN
+ REPEAT
+ drop
+;
+
+\ *************************************
+\ wait for specific status bits
+\ new version with abort after 5 sec.
+\ *************************************
+: wait-for-status ( val mask -- )
+ get-msecs \ initial timer value (start)
+ >r
+ BEGIN
+ 2dup \ val mask
+ ata-stat@ and <> \ expected status ?
+ no-timeout and \ and no timeout ?
+ WHILE
+ get-msecs r@ - \ calculate timer difference
+ FFFF AND \ mask-off overflow bits
+ d# 5000 > \ 5 seconds exceeded ?
+ IF
+ false to no-timeout \ set global flag
+ THEN
+ REPEAT
+ r> \ clean return stack
+ 3drop
+;
+
+\ *********************************
+\ remove extra spaces from string end
+\ *********************************
+: cut-string ( saddr nul -- )
+ swap
+ over +
+ swap
+ 1 rshift \ bytecount -> wordcount
+ 0 do
+ /w -
+ dup ( addr -- addr addr )
+ w@ ( addr addr -- addr nuw )
+ dup ( addr nuw -- addr nuw nuw )
+ 2020 =
+ IF
+ drop
+ 0
+ ELSE
+ LEAVE
+ THEN
+ over
+ w!
+ LOOP
+ drop
+ drop
+;
+
+\ ****************************************************
+\ prints model-string received by identify device
+\ ****************************************************
+: show-model ( dev# chan# -- )
+ 2dup
+ ." CH " . \ channel 0 / 1
+ 0= IF ." / MA" \ Master / Slave
+ ELSE ." / SL"
+ THEN
+ swap
+ 2 * + ." (@" . ." ) : " \ device number
+ sector 1 +
+ c@
+ 80 AND 0=
+ IF
+ ." ATA-Drive "
+ ELSE
+ ." ATAPI-Drive "
+ THEN
+
+ 22 emit \ start string display with "
+ sector d# 54 + \ string starts 54 bytes from buffer start
+ dup
+ d# 40 \ and is 40 chars long
+ cut-string \ remove all trailing spaces
+
+ BEGIN
+ dup
+ w@
+ wbflip
+ wbsplit
+ dup 0<> \ first char
+ IF
+ emit
+ dup 0<> \ second char
+ IF
+ emit
+ wa1+ \ increment address for next
+ false
+ ELSE \ second char = EndOfString
+ drop
+ true
+ THEN
+ ELSE \ first char = EndOfString
+ drop
+ drop
+ true
+ THEN
+ UNTIL \ end of string detected
+ drop
+ 22 emit \ end string display
+
+ sector c@ \ get lower byte of first doublet
+ 80 AND \ check bit 7
+ IF
+ ." (removable media)"
+ THEN
+
+ sector 1 +
+ c@
+ 80 AND 0= IF \ is this an ATA drive ?
+ sector d# 120 + \ get word 60 + 61
+ rl@-le \ read 32-bit as little endian value
+ d# 512 \ standard ATA block-size
+ swap
+ .capacity-text ( block-size #blocks -- )
+ THEN
+
+ sector d# 98 + \ goto word 49
+ w@
+ wbflip
+ 200 and 0= IF cr ." ** LBA is not supported " THEN
+
+ sector c@ \ get lower byte of first doublet
+ 03 AND 01 = \ we use 12-byte packet commands (=00b)
+ IF
+ cr ." packet size = 16 ** not supported ! **"
+ THEN
+ no-timeout not \ any timeout occurred so far ?
+ IF
+ cr ." ** timeout **"
+ THEN
+;
+
+\ ****************************
+\ ATA functions
+\ ****************************
+: pio-sector ( addr -- ) 100 0 DO ata-data@
+ over w! wa1+ LOOP drop ;
+: pio-sector ( addr -- )
+ wait-for-ready pio-sector ;
+: pio-sectors ( n addr -- ) swap 0 ?DO dup pio-sector 200 + LOOP drop ;
+
+: lba! lbsplit
+ 0f and 40 or \ always set LBA-mode + LBA (27..24)
+ ata-dev@ 10 and or \ add current device-bit (DEV)
+ ata-dev! \ set LBA (27..24)
+ ata-lbah! \ set LBA (23..16)
+ ata-lbam! \ set LBA (15..8)
+ ata-lbal! \ set LBA (7..0)
+;
+
+: read-sectors ( lba count addr -- )
+ >r dup >r ata-cnt! lba! 20 ata-cmd! r> r> pio-sectors ;
+
+: read-sectors ( lba count addr dev-nr -- )
+ set-regs ( lba count addr ) \ Set ata regs
+ BEGIN >r dup 100 > WHILE
+ over 100 r@ read-sectors
+ >r 100 + r> 100 - r> 20000 + REPEAT
+ r> read-sectors
+;
+
+: ata-read-blocks ( addr block# #blocks dev# -- #read )
+ swap dup >r swap >r rot r> ( addr block# #blocks dev # R: #blocks )
+ read-sectors r> ( R: #read )
+;
+
+\ *******************************
+\ ATAPI functions
+\ preset LBA register with maximum
+\ allowed block-size (16-bits)
+\ *******************************
+: set-lba ( block-length -- )
+ lbsplit ( quad -- b1.lo b2 b3 b4.hi )
+ drop \ skip upper two bytes
+ drop
+ ata-lbah!
+ ata-lbam!
+;
+
+\ *******************************************
+\ gets byte-count and reads a block of words
+\ from data-register to a buffer
+\ *******************************************
+: read-pio-block ( buff-addr -- buff-addr-new )
+ ata-lbah@ 8 lshift \ get block length High
+ ata-lbam@ or \ get block length Low
+ 1 rshift \ bcount -> wcount
+ dup
+ 0> IF \ any data to transfer?
+ 0 DO \ words to read
+ dup \ buffer-address
+ ata-data@ swap w! \ write 16-bits
+ wa1+ \ address of next entry
+ LOOP
+ ELSE
+ drop ( buff-addr wcount -- buff-addr )
+ THEN
+ wait-for-ready
+;
+
+\ ********************************************
+\ ATAPI support
+\ Send a command block (12 bytes) in PIO mode
+\ read data if requested
+\ ********************************************
+: send-atapi-packet ( req-buffer -- )
+ >r ( R: req-buffer )
+ atapi-size set-lba \ set regs to length limit
+ 00 ata-feat!
+ cmd#packet ata-cmd! \ A0 = ATAPI packet command
+ 48 C8 wait-for-status ( val mask -- ) \ BSY:0 DRDY:1 DRQ:1
+ 6 0 do
+ packet-cdb i 2 * + \ transfer command block (12 bytes)
+ w@
+ ata-data! \ 6 doublets PIO transfer to device
+ loop \ copy packet to data-reg
+ status-check ( -- ) \ status err bit set ? -> display
+ wait-for-ready ( -- ) \ busy released ?
+ BEGIN
+ ata-stat@ 08 and 08 = WHILE \ Data-Request-Bit set ?
+ r> \ get last target buffer address
+ read-pio-block \ only if from device requested
+ >r \ start of next block
+ REPEAT
+ r> \ original value
+ drop \ return clean
+;
+
+: atapi-packet-io ( -- )
+ return-buffer atapi-size erase \ clear return buffer
+ return-buffer send-atapi-packet \ send 'packet-cdb' , get 'return-buffer'
+;
+
+
+
+\ ********************************
+\ ATAPI packet commands
+\ ********************************
+
+\ Methods to access atapi disk
+
+: atapi-test ( -- true|false )
+ packet-cdb scsi-build-test-unit-ready \ command-code: 00
+ atapi-packet-io ( ) \ send CDB, get return-buffer
+ ata-stat@ 1 and IF false ELSE true THEN
+;
+
+: atapi-sense ( -- ascq asc sense-key )
+ d# 252 packet-cdb scsi-build-request-sense ( alloc-len cdb -- )
+ atapi-packet-io ( ) \ send CDB, get return-buffer
+ return-buffer scsi-get-sense-data ( cdb-addr -- ascq asc sense-key )
+;
+
+: atapi-read-blocks ( address block# #blocks dev# -- #read-blocks )
+ set-regs ( address block# #blocks )
+ dup >r ( address block# #blocks )
+ packet-cdb scsi-build-read-10 ( address block# #blocks cdb -- )
+ send-atapi-packet ( address -- )
+ r> \ return requested number of blocks
+;
+
+\ ***************************************
+\ read capacity of drive medium
+\ use SCSI-Support Package
+\ ***************************************
+: atapi-read-capacity ( -- )
+ packet-cdb scsi-build-read-cap-10 \ fill block with command
+ atapi-packet-io ( ) \ send CDB, get return-buffer
+ return-buffer scsi-get-capacity-10 ( cdb -- block-size #blocks )
+ .capacity-text ( block-size #blocks -- )
+ status-check ( -- )
+;
+
+\ ***************************************
+\ read capacity of drive medium
+\ use SCSI-Support Package
+\ ***************************************
+: atapi-read-capacity-ext ( -- )
+ packet-cdb scsi-build-read-cap-16 \ fill block with command
+ atapi-packet-io ( ) \ send CDB, get return-buffer
+ return-buffer scsi-get-capacity-16 ( cdb -- block-size #blocks )
+ .capacity-text ( block-size #blocks -- )
+ status-check ( -- )
+;
+
+
+\ ***********************************************
+\ wait until media in drive is ready ( max 5 sec)
+\ ***********************************************
+: wait-for-media-ready ( -- true|false )
+ get-msecs \ initial timer value (start)
+ >r
+ BEGIN
+ atapi-test \ unit ready? false if not
+ not
+ no-timeout and
+ WHILE
+ atapi-sense ( -- ascq asc sense-key )
+ 02 = \ sense key 2 = media error
+ IF \ check add. sense code
+ 3A = \ asc: device not ready ?
+ IF
+ false to no-timeout
+ ." empty (" . 29 emit \ show asc qualifier
+ ELSE
+ drop \ discard asc qualifier
+ THEN \ medium not present, abort waiting
+ ELSE
+ drop \ discard asc
+ drop \ discard ascq
+ THEN
+ get-msecs r@ - \ calculate timer difference
+ FFFF AND \ mask-off overflow bits
+ d# 5000 > \ 5 seconds exceeded ?
+ IF
+ false to no-timeout \ set global flag
+ THEN
+ REPEAT
+ r>
+ drop
+ no-timeout
+;
+
+\ ******************************************************
+\ Method pointer for read-blocks methods
+\ controller implements 2 channels (primary / secondary)
+\ for 2 devices each (master / slasve)
+\ ******************************************************
+\ 2 channels (primary/secondary) per controller
+2 CONSTANT #chan
+
+\ 2 devices (master/slave) per channel
+2 CONSTANT #dev
+
+\ results in a total of devices
+\ connected to a controller with
+\ two separate channels (4)
+: #totaldev #dev #chan * ;
+
+CREATE read-blocks-xt #totaldev cells allot read-blocks-xt #totaldev cells erase
+
+\ Execute read-blocks of device
+: dev-read-blocks ( address block# #blocks dev# -- #read-blocks )
+ dup cells read-blocks-xt + @ execute
+;
+
+\ **********************************************************
+\ Read device type
+\ Signature ATAPI ATA
+\ ---------------------------------------------
+\ Sector Count 01h 01h
+\ Sector Number 01h 01h
+\ Cylinder Low 14h 00h
+\ Cylinder High EBh 00h
+\ Device/Head 00h or 10h 00h or 01h
+\ see also ATA/ATAPI errata at:
+\ http://suif.stanford.edu/~csapuntz/blackmagic.html
+\ **********************************************************
+: read-ident ( -- true|false )
+ false
+ 00 ata-lbal! \ clear previous signature
+ 00 ata-lbam!
+ 00 ata-lbah!
+ cmd#identify-device ata-cmd! wait-for-ready \ first try ATA, ATAPI aborts command
+ ata-stat@ CF and 48 =
+ IF
+ drop true \ cmd accepted, this is a ATA
+ d# 512 set-lba \ set LBA to sector-length
+ ELSE \ ATAPI sends signature instead
+ ata-lbam@ 14 = IF \ cylinder low = 14 ?
+ ata-lbah@ EB = IF \ cylinder high = EB ?
+ cmd#device-reset ata-cmd! wait-for-ready \ only supported by ATAPI
+ cmd#identify-packet-device ata-cmd! wait-for-ready \ first try ata
+ ata-stat@ CF and 48 = IF
+ drop true \ replace flag
+ THEN
+ THEN
+ THEN
+ THEN
+ dup IF
+ ata-stat@ 8 AND IF \ data requested (as expected) ?
+ sector read-pio-block
+ drop \ discard address end
+ ELSE
+ drop false
+ THEN
+ THEN
+
+ no-timeout not IF \ check without any timeout ?
+ drop
+ false \ no, detection discarded
+ THEN
+;
+
+scsi-close \ remove scsi commands from word list
+
+
+\ *************************************************
+\ Init controller ( chan 0 and 1 )
+\ device 0 (= master) and device 1 ( = slave)
+\ #dev #chan Dev-ID
+\ ----------------------
+\ 0 0 0 Master of Channel 0
+\ 0 1 1 Master of Channel 1
+\ 1 0 2 Slave of Channel 0
+\ 1 1 3 Slave of Channel 1
+\ *************************************************
+: find-disks ( -- )
+ #chan 0 DO \ check 2 channels (primary & secondary)
+ #dev 0 DO \ check 2 devices per channel (master / slave)
+ i 2 * j +
+ set-regs \ set base address and dev-register for register access
+ ata-stat@ 7f and 7f <> \ Check, if device is connected
+ IF
+ true to no-timeout \ preset timeout-flag
+ read-ident ( -- true|false )
+ IF
+ i j show-model \ print manufacturer + device string
+ sector 1+ c@ C0 and 80 = \ Check for ata or atapi
+ IF
+ wait-for-media-ready \ wait up to 5 sec if not ready
+ no-timeout and
+ IF
+ atapi-read-capacity
+ atapi-size to block-size \ ATAPI: 2048 bytes
+ 80000 to max-transfer
+ ['] atapi-read-blocks i 2 * j + cells read-blocks-xt + !
+ s" cdrom" strdup i 2 * j + s" generic-disk.fs" included
+ ELSE
+ ." -" \ show hint for not registered
+ THEN
+ ELSE
+ ata-size to block-size \ ATA: 512 bytes
+ 80000 to max-transfer
+ ['] ata-read-blocks i 2 * j + cells read-blocks-xt + !
+ s" disk" strdup i 2 * j + s" generic-disk.fs" included
+ THEN
+ cr
+ THEN
+ THEN
+ i 2 * j + 200 + cp
+ LOOP
+ LOOP
+;
+
+find-disks
+
diff --git a/qemu/roms/SLOF/slof/fs/instance.fs b/qemu/roms/SLOF/slof/fs/instance.fs
new file mode 100644
index 000000000..9e5c9215e
--- /dev/null
+++ b/qemu/roms/SLOF/slof/fs/instance.fs
@@ -0,0 +1,193 @@
+\ *****************************************************************************
+\ * Copyright (c) 2004, 2011 IBM Corporation
+\ * All rights reserved.
+\ * This program and the accompanying materials
+\ * are made available under the terms of the BSD License
+\ * which accompanies this distribution, and is available at
+\ * http://www.opensource.org/licenses/bsd-license.php
+\ *
+\ * Contributors:
+\ * IBM Corporation - initial implementation
+\ ****************************************************************************/
+
+\ Support for device node instances.
+
+0 VALUE my-self
+
+400 CONSTANT max-instance-size
+
+STRUCT
+ /n FIELD instance>node
+ /n FIELD instance>parent
+ /n FIELD instance>args
+ /n FIELD instance>args-len
+ /n FIELD instance>size
+ /n FIELD instance>#units
+ /n FIELD instance>unit1 \ For instance-specific "my-unit"
+ /n FIELD instance>unit2
+ /n FIELD instance>unit3
+ /n FIELD instance>unit4
+CONSTANT /instance-header
+
+: >instance ( offset -- myself+offset )
+ my-self 0= ABORT" No instance!"
+ dup my-self instance>size @ >= ABORT" Instance access out of bounds!"
+ my-self +
+;
+
+: (create-instance-var) ( initial-value -- )
+ get-node
+ dup node>instance-size @ cell+ max-instance-size
+ >= ABORT" Instance is bigger than max-instance-size!"
+ dup node>instance-template @ ( iv phandle tmp-ih )
+ swap node>instance-size dup @ ( iv tmp-ih *instance-size instance-size )
+ dup , \ compile current instance ptr
+ swap 1 cells swap +! ( iv tmp-ih instance-size )
+ + !
+;
+
+: create-instance-var ( "name" initial-value -- )
+ CREATE (create-instance-var) PREVIOUS
+;
+
+: (create-instance-buf) ( buffersize -- )
+ aligned \ align size to multiples of cells
+ dup get-node node>instance-size @ + ( buffersize' newinstancesize )
+ max-instance-size > ABORT" Instance is bigger than max-instance-size!"
+ get-node node>instance-template @ get-node node>instance-size @ +
+ over erase \ clear according to IEEE 1275
+ get-node node>instance-size @ ( buffersize' old-instance-size )
+ dup , \ compile current instance ptr
+ + get-node node>instance-size ! \ store new size
+;
+
+: create-instance-buf ( "name" buffersize -- )
+ CREATE (create-instance-buf) PREVIOUS
+;
+
+VOCABULARY instance-words ALSO instance-words DEFINITIONS
+
+: VARIABLE 0 create-instance-var DOES> [ here ] @ >instance ;
+: VALUE create-instance-var DOES> [ here ] @ >instance @ ;
+: DEFER 0 create-instance-var DOES> [ here ] @ >instance @ execute ;
+: BUFFER: create-instance-buf DOES> [ here ] @ >instance ;
+
+PREVIOUS DEFINITIONS
+
+\ Save XTs of the above instance-words (put on the stack with "[ here ]")
+CONSTANT <instancebuffer>
+CONSTANT <instancedefer>
+CONSTANT <instancevalue>
+CONSTANT <instancevariable>
+
+\ check whether a value or a defer word is an
+\ instance word: It must be a CREATE word and
+\ the DOES> part must do >instance as first thing
+
+: (instance?) ( xt -- xt true|false )
+ dup @ <create> = IF
+ dup cell+ @ cell+ @ ['] >instance =
+ ELSE
+ false
+ THEN
+;
+
+\ This word does instance values in compile mode.
+\ It corresponds to DOTO from engine.in
+: (doito) ( value R:*CFA -- )
+ r> cell+ dup >r
+ @ cell+ cell+ @ >instance !
+;
+' (doito) CONSTANT <(doito)>
+
+: to ( value wordname<> -- )
+ ' (instance?)
+ state @ IF
+ \ compile mode handling normal or instance value
+ IF ['] (doito) ELSE ['] DOTO THEN
+ , , EXIT
+ THEN
+ IF
+ cell+ cell+ @ >instance ! \ interp mode instance value
+ ELSE
+ cell+ ! \ interp mode normal value
+ THEN
+; IMMEDIATE
+
+: behavior ( defer-xt -- contents-xt )
+ dup cell+ @ <instancedefer> = IF \ Is defer-xt an INSTANCE DEFER ?
+ 2 cells + @ >instance @
+ ELSE
+ behavior
+ THEN
+;
+
+: INSTANCE ALSO instance-words ;
+
+: my-parent my-self instance>parent @ ;
+: my-args my-self instance>args 2@ swap ;
+
+\ copy args from original instance to new created
+: set-my-args ( old-addr len -- )
+ dup IF \ IF len > 0 ( old-addr len )
+ dup alloc-mem \ | allocate space for new args ( old-addr len new-addr )
+ 2dup my-self instance>args 2! \ | write into instance struct ( old-addr len new-addr )
+ swap move \ | and copy the args ( )
+ ELSE \ ELSE ( old-addr len )
+ my-self instance>args 2! \ | set new args to zero, too ( )
+ THEN \ FI
+;
+
+\ Current node has already been set, when this is called.
+: create-instance-data ( -- instance )
+ get-node dup node>instance-template @ ( phandle instance-template )
+ swap node>instance-size @ ( instance-template instance-size )
+ dup >r
+ dup alloc-mem dup >r swap move r> ( instance )
+ dup instance>size r> swap ! \ Store size for destroy-instance
+ dup instance>#units 0 swap ! \ Use node unit by default
+;
+: create-instance ( -- )
+ my-self create-instance-data
+ dup to my-self instance>parent !
+ get-node my-self instance>node !
+;
+
+: destroy-instance ( instance -- )
+ dup instance>args @ ?dup IF \ Free instance args?
+ over instance>args-len @ free-mem
+ THEN
+ dup instance>size @ free-mem
+;
+
+: ihandle>phandle ( ihandle -- phandle )
+ dup 0= ABORT" no current instance" instance>node @
+;
+
+: push-my-self ( ihandle -- ) r> my-self >r >r to my-self ;
+: pop-my-self ( -- ) r> r> to my-self >r ;
+: call-package push-my-self execute pop-my-self ;
+: $call-static ( ... str len node -- ??? )
+\ cr ." call for " 3dup -rot type ." on node " .
+ find-method IF execute ELSE -1 throw THEN
+;
+
+: $call-my-method ( str len -- )
+ my-self ihandle>phandle $call-static
+;
+
+: $call-method ( str len ihandle -- )
+ push-my-self
+ ['] $call-my-method CATCH ?dup IF
+ pop-my-self THROW
+ THEN
+ pop-my-self
+;
+
+0 VALUE calling-child
+
+: $call-parent
+ my-self ihandle>phandle TO calling-child
+ my-parent $call-method
+ 0 TO calling-child
+;
diff --git a/qemu/roms/SLOF/slof/fs/little-endian.fs b/qemu/roms/SLOF/slof/fs/little-endian.fs
new file mode 100644
index 000000000..f2e4e8d42
--- /dev/null
+++ b/qemu/roms/SLOF/slof/fs/little-endian.fs
@@ -0,0 +1,77 @@
+\ *****************************************************************************
+\ * Copyright (c) 2004, 2011 IBM Corporation
+\ * All rights reserved.
+\ * This program and the accompanying materials
+\ * are made available under the terms of the BSD License
+\ * which accompanies this distribution, and is available at
+\ * http://www.opensource.org/licenses/bsd-license.php
+\ *
+\ * Contributors:
+\ * IBM Corporation - initial implementation
+\ ****************************************************************************/
+
+deadbeef here l!
+here c@ de = CONSTANT ?bigendian
+here c@ ef = CONSTANT ?littleendian
+
+
+?bigendian [IF]
+
+: l!-le >r lbflip r> l! ;
+: l@-le l@ lbflip ;
+
+: w!-le >r wbflip r> w! ;
+: w@-le w@ wbflip ;
+
+: rx!-le >r xbflip r> rx! ;
+: rx@-le rx@ xbflip ;
+
+: rl!-le >r lbflip r> rl! ;
+: rl@-le rl@ lbflip ;
+
+: rw!-le >r wbflip r> rw! ;
+: rw@-le rw@ wbflip ;
+
+: l!-be l! ;
+: l@-be l@ ;
+
+: w!-be w! ;
+: w@-be w@ ;
+
+: rl!-be rl! ;
+: rl@-be rl@ ;
+
+: rw!-be rw! ;
+: rw@-be rw@ ;
+
+
+[ELSE]
+
+: l!-le l! ;
+: l@-le l@ ;
+
+: w!-le w! ;
+: w@-le w@ ;
+
+: rx!-le rx! ;
+: rx@-le rx@ ;
+
+: rl!-le rl! ;
+: rl@-le rl@ ;
+
+: rw!-le rw! ;
+: rw@-le rw@ ;
+
+: l!-be >r lbflip r> l! ;
+: l@-be l@ lbflip ;
+
+: w!-be >r wbflip r> w! ;
+: w@-be w@ wbflip ;
+
+: rl!-be >r lbflip r> rl! ;
+: rl@-be rl@ lbflip ;
+
+: rw!-be >r wbflip r> rw! ;
+: rw@-be rw@ wbflip ;
+
+[THEN]
diff --git a/qemu/roms/SLOF/slof/fs/loaders.fs b/qemu/roms/SLOF/slof/fs/loaders.fs
new file mode 100644
index 000000000..276ba6bca
--- /dev/null
+++ b/qemu/roms/SLOF/slof/fs/loaders.fs
@@ -0,0 +1,94 @@
+\ *****************************************************************************
+\ * Copyright (c) 2004, 2008 IBM Corporation
+\ * All rights reserved.
+\ * This program and the accompanying materials
+\ * are made available under the terms of the BSD License
+\ * which accompanies this distribution, and is available at
+\ * http://www.opensource.org/licenses/bsd-license.php
+\ *
+\ * Contributors:
+\ * IBM Corporation - initial implementation
+\ ****************************************************************************/
+
+\ \\\\\\\\\\\\\\ Global Data
+CREATE bootdevice 2 cells allot bootdevice 2 cells erase
+CREATE bootargs 2 cells allot bootargs 2 cells erase
+CREATE load-list 2 cells allot load-list 2 cells erase
+
+: start-elf ( arg len entry -- )
+ msr@ 7fffffffffffffff and 2000 or ciregs >srr1 ! call-client
+;
+
+: start-elf64 ( arg len entry r2 -- )
+ msr@ 2000 or ciregs >srr1 !
+ ciregs >r2 !
+ call-client \ entry point is pointer to .opd
+;
+
+: set-bootpath
+ s" disk" find-alias
+ dup IF ELSE drop s" boot-device" evaluate find-alias THEN
+ dup IF strdup ELSE 0 THEN
+ encode-string s" bootpath" set-chosen
+;
+
+: set-netbootpath
+ s" net" find-alias
+ ?dup IF strdup encode-string s" bootpath" set-chosen THEN
+;
+
+: set-bootargs
+ skipws 0 parse dup 0= IF
+ 2drop s" boot-file" evaluate
+ THEN
+ encode-string s" bootargs" set-chosen
+;
+
+: .(client-exec) ( arg len -- rc )
+ s" snk" romfs-lookup 0<> IF
+ \ Load SNK client 15 MiB after Paflof... FIXME: Hard-coded offset is ugly!
+ paflof-start f00000 +
+ elf-load-file-to-addr drop \ FIXME - check this for LE, currently its BE only
+ dup @ swap 8 + @ \ populate entry r2
+ start-elf64 client-data
+ ELSE
+ 2drop false
+ THEN
+;
+' .(client-exec) to (client-exec)
+
+: .client-exec ( arg len -- rc ) set-bootargs (client-exec) ;
+' .client-exec to client-exec
+
+: netflash ( -- rc ) s" netflash 2000000 " (parse-line) $cat set-netbootpath
+ client-exec
+;
+
+: netsave ( "addr len {filename}[,params]" -- rc )
+ (parse-line) dup 0> IF
+ s" netsave " 2swap $cat set-netbootpath client-exec
+ ELSE
+ cr
+ ." Usage: netsave addr len [bootp|dhcp,]filename[,siaddr][,ciaddr][,giaddr][,bootp-retries][,tftp-retries][,use_ci]"
+ cr 2drop
+ THEN
+;
+
+: ping ( "{device-path:[device-args,]server-ip,[client-ip],[gateway-ip][,timeout]}" -- )
+ my-self >r current-node @ >r \ Save my-self
+ (parse-line) open-dev dup IF
+ dup to my-self dup ihandle>phandle set-node
+ dup
+ s" ping" rot ['] $call-method CATCH IF
+ cr
+ ." Not a pingable device"
+ cr 3drop
+ THEN
+ swap close-dev
+ ELSE
+ cr
+ ." Usage: ping device-path:[device-args,]server-ip,[client-ip],[gateway-ip][,timeout]"
+ cr drop
+ THEN
+ r> set-node r> to my-self \ Restore my-self
+;
diff --git a/qemu/roms/SLOF/slof/fs/logging.fs b/qemu/roms/SLOF/slof/fs/logging.fs
new file mode 100644
index 000000000..002c48091
--- /dev/null
+++ b/qemu/roms/SLOF/slof/fs/logging.fs
@@ -0,0 +1,45 @@
+\ *****************************************************************************
+\ * Copyright (c) 2004, 2008 IBM Corporation
+\ * All rights reserved.
+\ * This program and the accompanying materials
+\ * are made available under the terms of the BSD License
+\ * which accompanies this distribution, and is available at
+\ * http://www.opensource.org/licenses/bsd-license.php
+\ *
+\ * Contributors:
+\ * IBM Corporation - initial implementation
+\ ****************************************************************************/
+
+\ Words to write to nvram log
+
+defer nvramlog-write-byte
+
+: .nvramlog-write-byte ( byte -- )
+#if defined(DISABLE_NVRAM) || defined(RTAS_NVRAM)
+ drop
+#else
+ 0 1 asm-cout
+#endif
+;
+
+' .nvramlog-write-byte to nvramlog-write-byte
+
+: nvramlog-write-string ( str len -- )
+ dup 0> IF
+ 0 DO dup c@
+ nvramlog-write-byte char+ LOOP
+ ELSE
+ drop
+ THEN drop ;
+
+: nvramlog-write-number ( number format -- )
+ 0 swap <# 0 ?DO # LOOP #>
+ nvramlog-write-string ;
+
+: nvramlog-write-string-cr ( str len -- )
+ nvramlog-write-string
+ a nvramlog-write-byte d nvramlog-write-byte ;
+
+\ as long as dual-emit is enabled
+\ the string is written into NVRAM as well!!
+: log-string ( str len -- ) type ;
diff --git a/qemu/roms/SLOF/slof/fs/node.fs b/qemu/roms/SLOF/slof/fs/node.fs
new file mode 100644
index 000000000..22bf77b6f
--- /dev/null
+++ b/qemu/roms/SLOF/slof/fs/node.fs
@@ -0,0 +1,766 @@
+\ *****************************************************************************
+\ * Copyright (c) 2004, 2008 IBM Corporation
+\ * All rights reserved.
+\ * This program and the accompanying materials
+\ * are made available under the terms of the BSD License
+\ * which accompanies this distribution, and is available at
+\ * http://www.opensource.org/licenses/bsd-license.php
+\ *
+\ * Contributors:
+\ * IBM Corporation - initial implementation
+\ ****************************************************************************/
+
+
+\ Device nodes.
+
+false VALUE debug-find-component?
+
+VARIABLE device-tree
+VARIABLE current-node
+: get-node current-node @ dup 0= ABORT" No active device tree node" ;
+
+STRUCT
+ cell FIELD node>peer
+ cell FIELD node>parent
+ cell FIELD node>child
+ cell FIELD node>properties
+ cell FIELD node>words
+ cell FIELD node>instance-template
+ cell FIELD node>instance-size
+ cell FIELD node>space?
+ cell FIELD node>space
+ cell FIELD node>addr1
+ cell FIELD node>addr2
+ cell FIELD node>addr3
+END-STRUCT
+
+: find-method ( str len phandle -- false | xt true )
+ node>words @ voc-find dup IF link> true THEN ;
+
+\ Instances.
+#include "instance.fs"
+
+: create-node ( parent -- new )
+ max-instance-size alloc-mem ( parent instance-mem )
+ dup max-instance-size erase >r ( parent R: instance-mem )
+ align wordlist >r wordlist >r ( parent R: instance-mem wl wl )
+ here ( parent new R: instance-mem wl wl )
+ 0 , swap , 0 , \ Set node>peer, node>parent & node>child
+ r> , r> , \ Set node>properties & node>words to wl
+ r> , /instance-header , \ Set instance-template & instance-size
+ FALSE , 0 , \ Set node>space? and node>space
+ 0 , 0 , 0 , \ Set node>addr*
+;
+
+: peer node>peer @ ;
+: parent node>parent @ ;
+: child node>child @ ;
+: peer dup IF peer ELSE drop device-tree @ THEN ;
+
+
+: link ( new head -- ) \ link a new node at the end of a linked list
+ BEGIN dup @ WHILE @ REPEAT ! ;
+: link-node ( parent child -- )
+ swap dup IF node>child link ELSE drop device-tree ! THEN ;
+
+\ Set a node as active node.
+: set-node ( phandle -- )
+ current-node @ IF previous THEN
+ dup current-node !
+ ?dup IF node>words @ also context ! THEN
+ definitions ;
+: get-parent get-node parent ;
+
+
+: new-node ( -- phandle ) \ active node becomes new node's parent;
+ \ new node becomes active node
+\ XXX: change to get-node, handle root node creation specially
+ current-node @ dup create-node
+ tuck link-node dup set-node ;
+
+: finish-node ( -- )
+ \ TODO: maybe resize the instance template buffer here (or in finish-device)?
+ get-node parent set-node
+;
+
+: device-end ( -- ) 0 set-node ;
+
+\ Properties.
+CREATE $indent 100 allot VARIABLE indent 0 indent !
+#include "property.fs"
+
+\ Unit address.
+: #address-cells s" #address-cells" rot parent get-property
+ ABORT" parent doesn't have a #address-cells property!"
+ decode-int nip nip
+;
+
+\ my-#address-cells returns the #address-cells property of the parent node.
+\ child-#address-cells returns the #address-cells property of the current node.
+
+\ This is confusing in several ways: Remember that a node's address is always
+\ described in the parent's address space, thus the parent's property is taken
+\ into regard, rather than the own.
+
+\ Also, an address-cell here is always a 32bit cell, no matter whether the
+\ "real" cell size is 32bit or 64bit.
+
+: my-#address-cells ( -- #address-cells )
+ get-node #address-cells
+;
+
+: child-#address-cells ( -- #address-cells )
+ s" #address-cells" get-node get-property
+ ABORT" node doesn't have a #address-cells property!"
+ decode-int nip nip
+;
+
+: child-#size-cells ( -- #address-cells )
+ s" #size-cells" get-node get-property
+ ABORT" node doesn't have a #size-cells property!"
+ decode-int nip nip
+;
+
+: encode-phys ( phys.hi ... phys.low -- prop len )
+ encode-first? IF encode-start ELSE here 0 THEN
+ my-#address-cells 0 ?DO rot encode-int+ LOOP
+;
+
+: encode-child-phys ( phys.hi ... phys.low -- prop len )
+ encode-first? IF encode-start ELSE here 0 THEN
+ child-#address-cells 0 ?DO rot encode-int+ LOOP
+;
+
+: encode-child-size ( size.hi ... size.low -- prop len )
+ encode-first? IF encode-start ELSE here 0 THEN
+ child-#size-cells 0 ?DO rot encode-int+ LOOP
+;
+
+: decode-phys
+ my-#address-cells BEGIN dup WHILE 1- >r decode-int r> swap >r REPEAT drop
+ my-#address-cells BEGIN dup WHILE 1- r> swap REPEAT drop ;
+: decode-phys-and-drop
+ my-#address-cells BEGIN dup WHILE 1- >r decode-int r> swap >r REPEAT 3drop
+ my-#address-cells BEGIN dup WHILE 1- r> swap REPEAT drop ;
+: reg >r encode-phys r> encode-int+ s" reg" property ;
+
+
+: >space node>space @ ;
+: >space? node>space? @ ;
+: >address dup >r #address-cells dup 3 > IF r@ node>addr3 @ swap THEN
+ dup 2 > IF r@ node>addr2 @ swap THEN
+ 1 > IF r@ node>addr1 @ THEN r> drop ;
+: >unit dup >r >address r> >space ;
+
+: (my-phandle) ( -- phandle )
+ my-self ?dup IF
+ ihandle>phandle
+ ELSE
+ get-node dup 0= ABORT" no active node"
+ THEN
+;
+
+: my-space ( -- phys.hi )
+ (my-phandle) >space
+;
+: my-address (my-phandle) >address ;
+
+\ my-unit returns the unit address of the current _instance_ - that means
+\ it returns the same values as my-space and my-address together _or_ it
+\ returns a unit address that has been set manually while opening the node.
+: my-unit
+ my-self instance>#units @ IF
+ 0 my-self instance>#units @ 1- DO
+ my-self instance>unit1 i cells + @
+ -1 +LOOP
+ ELSE
+ my-self ihandle>phandle >unit
+ THEN
+;
+
+\ Return lower 64 bit of address
+: my-unit-64 ( -- phys.lo+1|phys.lo )
+ my-unit ( phys.lo ... phys.hi )
+ (my-phandle) #address-cells ( phys.lo ... phys.hi #ad-cells )
+ CASE
+ 1 OF EXIT ENDOF
+ 2 OF lxjoin EXIT ENDOF
+ 3 OF drop lxjoin EXIT ENDOF
+ dup OF 2drop lxjoin EXIT ENDOF
+ ENDCASE
+;
+
+: set-space get-node dup >r node>space ! true r> node>space? ! ;
+: set-address my-#address-cells 1 ?DO
+ get-node node>space i cells + ! LOOP ;
+: set-unit set-space set-address ;
+: set-unit-64 ( phys.lo|phys.hi -- )
+ my-#address-cells 2 <> IF
+ ." set-unit-64: #address-cells <> 2 " abort
+ THEN
+ xlsplit set-unit
+;
+
+\ Never ever use this in actual code, only when debugging interactively.
+\ Thank you.
+: set-args ( arg-str len unit-str len -- )
+ s" decode-unit" get-parent $call-static set-unit set-my-args
+;
+
+: $cat-unit
+ dup parent 0= IF drop EXIT THEN
+ dup >space? not IF drop EXIT THEN
+ dup >r >unit s" encode-unit" r> parent $call-static
+ dup IF
+ dup >r here swap move s" @" $cat here r> $cat
+ ELSE
+ 2drop
+ THEN
+;
+
+: $cat-instance-unit
+ dup parent 0= IF drop EXIT THEN
+ \ No instance unit, use node unit
+ dup instance>#units @ 0= IF
+ ihandle>phandle $cat-unit
+ EXIT
+ THEN
+ dup >r push-my-self
+ ['] my-unit CATCH IF pop-my-self r> drop EXIT THEN
+ pop-my-self
+ s" encode-unit"
+ r> ihandle>phandle parent
+ $call-static
+ dup IF
+ dup >r here swap move s" @" $cat here r> $cat
+ ELSE
+ 2drop
+ THEN
+;
+
+\ Getting basic info about a node.
+: node>name dup >r s" name" rot get-property IF r> (u.) ELSE 1- r> drop THEN ;
+: node>qname dup node>name rot ['] $cat-unit CATCH IF drop THEN ;
+: node>path
+ here 0 rot
+ BEGIN dup WHILE dup parent REPEAT
+ 2drop
+ dup 0= IF [char] / c, THEN
+ BEGIN
+ dup
+ WHILE
+ [char] / c, node>qname here over allot swap move
+ REPEAT
+ drop here 2dup - allot over -
+;
+
+: interposed? ( ihandle -- flag )
+ \ We cannot actually detect if an instance is interposed; instead, we look
+ \ if an instance is part of the "normal" chain that would be opened by
+ \ open-dev and friends, if there were no interposition.
+ dup instance>parent @ dup 0= IF 2drop false EXIT THEN
+ ihandle>phandle swap ihandle>phandle parent <> ;
+
+: instance>qname
+ dup >r interposed? IF s" %" ELSE 0 0 THEN
+ r@ dup ihandle>phandle node>name
+ rot ['] $cat-instance-unit CATCH IF drop THEN
+ $cat r> instance>args 2@ swap
+ dup IF 2>r s" :" $cat 2r> $cat ELSE 2drop THEN
+;
+
+: instance>qpath \ With interposed nodes.
+ here 0 rot BEGIN dup WHILE dup instance>parent @ REPEAT 2drop
+ dup 0= IF [char] / c, THEN
+ BEGIN dup WHILE [char] / c, instance>qname here over allot swap move
+ REPEAT drop here 2dup - allot over - ;
+: instance>path \ Without interposed nodes.
+ here 0 rot BEGIN dup WHILE
+ dup interposed? 0= IF dup THEN instance>parent @ REPEAT 2drop
+ dup 0= IF [char] / c, THEN
+ BEGIN dup WHILE [char] / c, instance>qname here over allot swap move
+ REPEAT drop here 2dup - allot over - ;
+
+: .node node>path type ;
+: pwd get-node .node ;
+
+: .instance instance>qpath type ;
+: .chain dup instance>parent @ ?dup IF recurse THEN
+ cr dup . instance>qname type ;
+
+
+\ Alias helper
+defer find-node
+: set-alias ( alias-name len device-name len -- )
+ encode-string
+ 2swap s" /aliases" find-node ?dup IF
+ set-property
+ ELSE
+ 4drop
+ THEN
+;
+
+: find-alias ( alias-name len -- false | dev-path len )
+ s" /aliases" find-node dup IF
+ get-property 0= IF 1- dup 0= IF nip THEN ELSE false THEN
+ THEN
+;
+
+: .alias ( alias-name len -- )
+ find-alias dup IF type ELSE ." no alias available" THEN ;
+
+: (.print-alias) ( lfa -- )
+ link> dup >name name>string
+ \ Don't print name property
+ 2dup s" name" string=ci IF 2drop drop
+ ELSE cr type space ." : " execute type
+ THEN ;
+
+: (.list-alias) ( phandle -- )
+ node>properties @ cell+ @ BEGIN dup WHILE dup (.print-alias) @ REPEAT drop ;
+
+: list-alias ( -- )
+ s" /aliases" find-node dup IF (.list-alias) THEN ;
+
+\ return next available name for aliasing or
+\ false if more than MAX-ALIAS aliases found
+8 CONSTANT MAX-ALIAS
+1 VALUE alias-ind
+: get-next-alias ( $alias-name -- $next-alias-name|FALSE )
+ 2dup find-alias IF
+ drop
+ 1 TO alias-ind
+ BEGIN
+ 2dup alias-ind $cathex 2dup find-alias
+ WHILE
+ drop 2drop
+ alias-ind 1 + TO alias-ind
+ alias-ind MAX-ALIAS = IF
+ 2drop FALSE EXIT
+ THEN
+ REPEAT
+ strdup 2swap 2drop
+ THEN
+;
+
+: devalias ( "{alias-name}<>{device-specifier}<cr>" -- )
+ parse-word parse-word dup IF set-alias
+ ELSE 2drop dup IF .alias
+ ELSE 2drop list-alias THEN THEN ;
+
+\ sub-alias does a single iteration of an alias at the beginning od dev path
+\ expression. de-alias will repeat this until all indirect alising is resolved
+: sub-alias ( arg-str arg-len -- arg' len' | false )
+ 2dup
+ 2dup [char] / findchar ?dup IF ELSE 2dup [char] : findchar THEN
+ ( a l a l [p] -1|0 ) IF nip dup ELSE 2drop 0 THEN >r
+ ( a l l p -- R:p | a l -- R:0 )
+ find-alias ?dup IF ( a l a' p' -- R:p | a' l' -- R:0 )
+ r@ IF
+ 2swap r@ - swap r> + swap $cat strdup ( a" l-p+p' -- )
+ ELSE
+ ( a' l' -- R:0 ) r> drop ( a' l' -- )
+ THEN
+ ELSE
+ ( a l -- R:p | -- R:0 ) r> IF 2drop THEN
+ false ( 0 -- )
+ THEN
+;
+
+: de-alias ( arg-str arg-len -- arg' len' )
+ BEGIN
+ over c@ [char] / <> dup IF drop 2dup sub-alias ?dup THEN
+ WHILE
+ 2swap 2drop
+ REPEAT
+;
+
+
+\ Display the device tree.
+: +indent ( not-last? -- )
+ IF s" | " ELSE s" " THEN $indent indent @ + swap move 4 indent +! ;
+: -indent ( -- ) -4 indent +! ;
+
+: ls-phandle ( node -- ) . ." : " ;
+
+: ls-node ( node -- )
+ cr dup ls-phandle
+ $indent indent @ type
+ dup peer IF ." |-- " ELSE ." +-- " THEN
+ node>qname type
+;
+
+: (ls) ( node -- )
+ child BEGIN dup WHILE dup ls-node dup child IF
+ dup peer +indent dup recurse -indent THEN peer REPEAT drop ;
+
+: ls ( -- )
+ get-node cr
+ dup ls-phandle
+ dup node>path type
+ (ls)
+ 0 indent !
+;
+
+: show-devs ( {device-specifier}<eol> -- )
+ skipws 0 parse dup IF de-alias ELSE 2drop s" /" THEN ( str len )
+ find-node dup 0= ABORT" No such device path" (ls)
+;
+
+
+VARIABLE interpose-node
+2VARIABLE interpose-args
+: interpose ( arg len phandle -- ) interpose-node ! interpose-args 2! ;
+
+
+0 VALUE user-instance-#units
+CREATE user-instance-units 4 cells allot
+
+\ Copy the unit information (specified by the user) that we've found during
+\ "find-component" into the current instance data structure
+: copy-instance-unit ( -- )
+ user-instance-#units IF
+ user-instance-#units my-self instance>#units !
+ user-instance-units my-self instance>unit1 user-instance-#units cells move
+ 0 to user-instance-#units
+ THEN
+;
+
+
+: open-node ( arg len phandle -- ihandle|0 )
+ current-node @ >r my-self >r \ Save current node and instance
+ set-node create-instance set-my-args
+ copy-instance-unit
+ \ Execute "open" method if available, and assume default of
+ \ success (=TRUE) for nodes without open method:
+ s" open" get-node find-method IF execute ELSE TRUE THEN
+ 0= IF
+ my-self destroy-instance 0 to my-self
+ THEN
+ my-self ( ihandle|0 )
+ r> to my-self r> set-node \ Restore current node and instance
+ \ Handle interposition:
+ interpose-node @ IF
+ my-self >r to my-self
+ interpose-args 2@ interpose-node @
+ interpose-node off recurse
+ r> to my-self
+ THEN
+;
+
+: close-node ( ihandle -- )
+ my-self >r to my-self
+ s" close" ['] $call-my-method CATCH IF 2drop THEN
+ my-self destroy-instance r> to my-self ;
+
+: close-dev ( ihandle -- )
+ my-self >r to my-self
+ BEGIN my-self WHILE my-parent my-self close-node to my-self REPEAT
+ r> to my-self ;
+
+: new-device ( -- )
+ my-self new-node ( parent-ihandle phandle )
+ node>instance-template @ ( parent-ihandle ihandle )
+ dup to my-self ( parent-ihanlde ihandle )
+ instance>parent !
+ get-node my-self instance>node !
+ max-instance-size my-self instance>size !
+;
+
+: finish-device ( -- )
+ \ Set unit address to first entry of reg property if it has not been set yet
+ get-node >space? 0= IF
+ s" reg" get-node get-property 0= IF
+ decode-int set-space 2drop
+ THEN
+ THEN
+ finish-node my-parent to my-self
+;
+
+\ Set the instance template as current instance for extending it
+\ (i.e. to be able to declare new INSTANCE VARIABLEs etc. there)
+: extend-device ( phandle -- )
+ my-self >r
+ dup set-node
+ node>instance-template @
+ dup to my-self
+ r> swap instance>parent !
+;
+
+: split ( str len char -- left len right len )
+ >r 2dup r> findchar IF >r over r@ 2swap r> 1+ /string ELSE 0 0 THEN ;
+: generic-decode-unit ( str len ncells -- addr.lo ... addr.hi )
+ dup >r -rot BEGIN r@ WHILE r> 1- >r [char] , split 2swap
+ $number IF 0 THEN r> swap >r >r REPEAT r> 3drop
+ BEGIN dup WHILE 1- r> swap REPEAT drop ;
+: generic-encode-unit ( addr.lo ... addr.hi ncells -- str len )
+ 0 0 rot ?dup IF 0 ?DO rot (u.) $cat s" ," $cat LOOP 1- THEN ;
+: hex-decode-unit ( str len ncells -- addr.lo ... addr.hi )
+ base @ >r hex generic-decode-unit r> base ! ;
+: hex-encode-unit ( addr.lo ... addr.hi ncells -- str len )
+ base @ >r hex generic-encode-unit r> base ! ;
+
+: hex64-decode-unit ( str len ncells -- addr.lo ... addr.hi )
+ dup 2 <> IF
+ hex-decode-unit
+ ELSE
+ drop
+ base @ >r hex
+ $number IF 0 0 ELSE xlsplit THEN
+ r> base !
+ THEN
+;
+
+: hex64-encode-unit ( addr.lo ... addr.hi ncells -- str len )
+ dup 2 <> IF
+ hex-encode-unit
+ ELSE
+ drop
+ base @ >r hex
+ lxjoin (u.)
+ r> base !
+ THEN
+;
+
+: handle-leading-/ ( path len -- path' len' )
+ dup IF over c@ [char] / = IF 1 /string device-tree @ set-node THEN THEN ;
+: match-name ( name len node -- match? )
+ over 0= IF 3drop true EXIT THEN
+ s" name" rot get-property IF 2drop false EXIT THEN
+ 1- string=ci ; \ XXX should use decode-string
+
+0 VALUE #search-unit
+CREATE search-unit 4 cells allot
+
+: match-unit ( node -- match? )
+ \ A node with no space is a wildcard and will always match
+ dup >space? IF
+ node>space search-unit #search-unit 0 ?DO 2dup @ swap @ <> IF
+ 2drop false UNLOOP EXIT THEN cell+ swap cell+ swap LOOP 2drop true
+ ELSE drop true THEN
+;
+: match-node ( name len node -- match? )
+ dup >r match-name r> match-unit and ; \ XXX e3d
+: find-kid ( name len -- node|0 )
+ dup -1 = IF \ are we supposed to stay in the same node? -> resolve-relatives
+ 2drop get-node
+ ELSE
+ get-node child >r BEGIN r@ WHILE 2dup r@ match-node
+ IF 2drop r> EXIT THEN r> peer >r REPEAT
+ r> 3drop false
+ THEN ;
+
+: set-search-unit ( unit len -- )
+ 0 to #search-unit
+ 0 to user-instance-#units
+ dup 0= IF 2drop EXIT THEN
+ s" #address-cells" get-node get-property THROW
+ decode-int to #search-unit 2drop
+ s" decode-unit" get-node $call-static
+ #search-unit 0 ?DO search-unit i cells + ! LOOP
+;
+
+: resolve-relatives ( path len -- path' len' )
+ \ handle ..
+ 2dup 2 = swap s" .." comp 0= and IF
+ get-node parent ?dup IF
+ set-node drop -1
+ ELSE
+ s" Already in root node." type
+ THEN
+ THEN
+ \ handle .
+ 2dup 1 = swap c@ [CHAR] . = and IF
+ drop -1
+ THEN
+;
+
+\ XXX This is an old hack that allows wildcard nodes to work
+\ by not having a #address-cells in the parent and no
+\ decode unit. This should be removed.
+\ (It appears to be still used on js2x)
+: set-instance-unit ( unitaddr len -- )
+ dup 0= IF 2drop 0 to user-instance-#units EXIT THEN
+ 2dup 0 -rot bounds ?DO
+ i c@ [char] , = IF 1+ THEN \ Count the commas
+ LOOP
+ 1+ dup to user-instance-#units
+ hex-decode-unit
+ user-instance-#units 0 ?DO
+ user-instance-units i cells + !
+ LOOP
+;
+
+: split-component ( path. -- path'. args. name. unit. )
+ [char] / split 2swap ( path'. component. )
+ [char] : split 2swap ( path'. args. name@unit. )
+ [char] @ split ( path'. args. name. unit. )
+;
+
+: find-component ( path len -- path' len' args len node|0 )
+ debug-find-component? IF
+ ." find-component for " 2dup type cr
+ THEN
+ split-component ( path'. args. name. unit. )
+ debug-find-component? IF
+ ." -> unit =" 2dup type cr
+ ." -> stack =" .s cr
+ THEN
+ ['] set-search-unit CATCH IF
+ \ XXX: See comment in set-instance-unit
+ ." WARNING: Obsolete old wildcard hack " .s cr
+ set-instance-unit
+ THEN
+ resolve-relatives find-kid ( path' len' args len node|0 )
+
+ \ If resolve returned a wildcard node, and we haven't hit
+ \ the above gross hack then copy the unit
+ dup IF dup >space? not #search-unit 0 > AND user-instance-#units 0= AND IF
+ #search-unit dup to user-instance-#units 0 ?DO
+ search-unit i cells + @ user-instance-units i cells + !
+ LOOP
+ THEN THEN
+
+ \ XXX This can go away with the old wildcard hack
+ dup IF dup >space? user-instance-#units 0 > AND IF
+ \ User supplied a unit value, but node also has different physical unit
+ cr ." find-component with unit mismatch!" .s cr
+ drop 0
+ THEN THEN
+;
+
+: .find-node ( path len -- phandle|0 )
+ current-node @ >r
+ handle-leading-/ current-node @ 0= IF 2drop r> set-node 0 EXIT THEN
+ BEGIN dup WHILE \ handle one component:
+ find-component ( path len args len node ) dup 0= IF
+ 3drop 2drop r> set-node 0 EXIT THEN
+ set-node 2drop REPEAT 2drop
+ get-node r> set-node ;
+' .find-node to find-node
+: find-node ( path len -- phandle|0 ) de-alias find-node ;
+
+: delete-node ( phandle -- )
+ dup node>instance-template @ max-instance-size free-mem
+ dup node>parent @ node>child @ ( phandle 1st peer )
+ 2dup = IF
+ node>peer @ swap node>parent @ node>child !
+ EXIT
+ THEN
+ dup node>peer @
+ BEGIN
+ 2 pick 2dup <>
+ WHILE
+ drop
+ nip dup node>peer @
+ dup 0= IF 2drop drop unloop EXIT THEN
+ REPEAT
+ drop
+ node>peer @ swap node>peer !
+ drop
+;
+
+: open-dev ( path len -- ihandle|0 )
+ 0 to user-instance-#units
+ de-alias current-node @ >r
+ handle-leading-/ current-node @ 0= IF 2drop r> set-node 0 EXIT THEN
+ my-self >r
+ 0 to my-self
+ 0 0 >r >r
+ BEGIN
+ dup
+ WHILE \ handle one component:
+ ( arg len ) r> r> get-node open-node to my-self
+ find-component ( path len args len node ) dup 0= IF
+ 3drop 2drop my-self close-dev
+ r> to my-self
+ r> set-node
+ 0 EXIT
+ THEN
+ set-node
+ >r >r
+ REPEAT
+ 2drop
+ \ open final node
+ r> r> get-node open-node to my-self
+ my-self r> to my-self r> set-node
+;
+
+: select-dev open-dev dup to my-self ihandle>phandle set-node ;
+: unselect-dev my-self close-dev 0 to my-self device-end ;
+
+: find-device ( str len -- ) \ set as active node
+ find-node dup 0= ABORT" No such device path" set-node ;
+: dev parse-word find-device ;
+
+: (lsprop) ( node --)
+ dup cr $indent indent @ type ." node: " node>qname type
+ false +indent (.properties) cr -indent
+;
+: (show-children) ( node -- )
+ child BEGIN
+ dup
+ WHILE
+ dup (lsprop) dup child IF false +indent dup recurse -indent THEN peer
+ REPEAT
+ drop
+;
+: lsprop ( {device-specifier}<eol> -- )
+ skipws 0 parse dup IF de-alias ELSE 2drop s" /" THEN
+ find-device get-node dup dup
+ cr ." node: " node>path type (.properties) cr (show-children)
+ 0 indent !
+;
+
+
+\ node>path does not allot the memory, since it is internally only used
+\ for typing.
+\ The external variant needs to allot memory !
+
+: (node>path) node>path ;
+
+: node>path ( phandle -- str len )
+ node>path dup allot
+;
+
+\ Support for support packages.
+
+\ The /packages node.
+0 VALUE packages
+
+\ Find a support package (or arbitrary nodes when name is absolute)
+: find-package ( name len -- false | phandle true )
+ dup 0 <= IF
+ 2drop FALSE EXIT
+ THEN
+ \ According to IEEE 1275 Proposal 215 (Extensible Client Services Package),
+ \ the find-package method can be used to get the phandle of arbitrary nodes
+ \ (i.e. not only support packages) when the name starts with a slash.
+ \ Some FCODE programs depend on this behavior so let's support this, too!
+ over c@ [char] / = IF
+ find-node dup IF TRUE THEN EXIT
+ THEN
+ \ Ok, let's look for support packages instead. We can't use the standard
+ \ find-node stuff, as we are required to find the newest (i.e., last in our
+ \ tree) matching package, not just any.
+ 0 >r packages child
+ BEGIN
+ dup
+ WHILE
+ dup >r node>name 2over string=ci r> swap IF
+ r> drop dup >r
+ THEN
+ peer
+ REPEAT
+ 3drop
+ r> dup IF true THEN
+;
+
+: open-package ( arg len phandle -- ihandle | 0 ) open-node ;
+: close-package ( ihandle -- ) close-node ;
+: $open-package ( arg len name len -- ihandle | 0 )
+ find-package IF open-package ELSE 2drop false THEN ;
+
+
+\ device tree translate-address
+#include <translate.fs>
diff --git a/qemu/roms/SLOF/slof/fs/nvram.fs b/qemu/roms/SLOF/slof/fs/nvram.fs
new file mode 100644
index 000000000..5ea58d17f
--- /dev/null
+++ b/qemu/roms/SLOF/slof/fs/nvram.fs
@@ -0,0 +1,182 @@
+\ *****************************************************************************
+\ * Copyright (c) 2004, 2014 IBM Corporation
+\ * All rights reserved.
+\ * This program and the accompanying materials
+\ * are made available under the terms of the BSD License
+\ * which accompanies this distribution, and is available at
+\ * http://www.opensource.org/licenses/bsd-license.php
+\ *
+\ * Contributors:
+\ * IBM Corporation - initial implementation
+\ ****************************************************************************/
+
+51 CONSTANT nvram-partition-type-cpulog
+\ types 53-55 are omitted because they have been used for
+\ storing binary tables in the past
+60 CONSTANT nvram-partition-type-sas
+61 CONSTANT nvram-partition-type-sms
+6e CONSTANT nvram-partition-type-debug
+6f CONSTANT nvram-partition-type-history
+70 CONSTANT nvram-partition-type-common
+7f CONSTANT nvram-partition-type-freespace
+a0 CONSTANT nvram-partition-type-linux
+
+: rztype ( str len -- ) \ stop at zero byte, read with nvram-c@
+ 0 DO
+ dup i + nvram-c@ ?dup IF ( str char )
+ emit
+ ELSE ( str )
+ drop UNLOOP EXIT
+ THEN
+ LOOP
+;
+
+create tmpStr 500 allot
+: rzcount ( zstr -- str len )
+ dup tmpStr >r BEGIN
+ dup nvram-c@ dup r> dup 1+ >r c!
+ WHILE
+ char+
+ REPEAT
+ r> drop over - swap drop tmpStr swap
+;
+
+: calc-header-cksum ( offset -- cksum )
+ dup nvram-c@
+ 10 2 DO
+ over I + nvram-c@ +
+ LOOP
+ wbsplit + nip
+;
+
+: bad-header? ( offset -- flag )
+ dup 2+ nvram-w@ ( offset length )
+ 0= IF ( offset )
+ drop true EXIT ( )
+ THEN
+ dup calc-header-cksum ( offset checksum' )
+ swap 1+ nvram-c@ ( checksum ' checksum )
+ <> ( flag )
+;
+
+: .header ( offset -- )
+ cr ( offset )
+ dup bad-header? IF ( offset )
+ ." BAD HEADER -- trying to print it anyway" cr
+ THEN
+ space ( offset )
+ \ print type
+ dup nvram-c@ 2 0.r ( offset )
+ space space ( offset )
+ \ print length
+ dup 2+ nvram-w@ 10 * 5 .r ( offset )
+ space space ( offset )
+ \ print name
+ 4 + 0c rztype ( )
+;
+
+: .headers ( -- )
+ cr cr ." Type Size Name"
+ cr ." ========================"
+ 0 BEGIN ( offset )
+ dup nvram-c@ ( offset type )
+ WHILE
+ dup .header ( offset )
+ dup 2+ nvram-w@ 10 * + ( offset offset' )
+ dup nvram-size < IF ( offset )
+ ELSE
+ drop EXIT ( )
+ THEN
+ REPEAT
+ drop ( )
+ cr cr
+;
+
+: reset-nvram ( -- )
+ internal-reset-nvram
+;
+
+: dump-partition ['] nvram-c@ 1 (dump) ;
+
+: type-no-zero ( addr len -- )
+ 0 DO
+ dup I + dup nvram-c@ 0= IF drop ELSE nvram-c@ emit THEN
+ LOOP
+ drop
+;
+
+: type-no-zero-part ( from-str cnt-str addr len )
+ 0 DO
+ dup i + dup nvram-c@ 0= IF
+ drop
+ ELSE
+ ( from-str cnt-str addr addr+i )
+ ( from-str==0 AND cnt-str > 0 )
+ 3 pick 0= 3 pick 0 > AND IF
+ dup 1 type-no-zero
+ THEN
+
+ nvram-c@ a = IF
+ 2 pick 0= IF
+ over 1- 0 max
+ rot drop swap
+ THEN
+ 2 pick 1- 0 max
+ 3 roll drop rot rot
+ ( from-str-- cnt-str-- addr addr+i )
+ THEN
+ THEN
+ LOOP
+ drop
+;
+
+: (dmesg-prepare) ( base-addr -- base-addr' addr len act-off )
+ 10 - \ go back to header
+ dup 14 + nvram-l@ dup >r
+ ( base-addr act-off ) ( R: act-off )
+ over over over + swap 10 + nvram-w@ + >r
+ ( base-addr act-off ) ( R: act-off nvram-act-addr )
+ over 2 + nvram-w@ 10 * swap - over swap
+ ( base-addr base-addr start-size ) ( R: act-off nvram-act-addr )
+ r> swap rot 10 + nvram-w@ - r>
+;
+
+: .dmesg ( base-addr -- )
+ (dmesg-prepare) >r
+ ( base-addr addr len )
+ cr type-no-zero
+ ( base-addr ) ( R: act-off )
+ dup 10 + nvram-w@ + r> type-no-zero
+;
+
+: .dmesg-part ( from-str cnt-str base-addr -- )
+ (dmesg-prepare) >r
+ ( from-str cnt-str base-addr addr len )
+ >r >r -rot r> r>
+ ( base-addr from-str cnt-str addr len )
+ cr type-no-zero-part rot
+ ( base-addr ) ( R: act-off )
+ dup 10 + nvram-w@ + r> type-no-zero-part
+;
+
+: dmesg-part ( from-str cnt-str -- left-from-str left-cnt-str )
+ 2dup
+ s" ibm,CPU0log" get-named-nvram-partition IF
+ 2drop EXIT
+ THEN
+ drop .dmesg-part nip nip
+;
+
+: dmesg2 ( -- )
+ s" ibm,CPU1log" get-named-nvram-partition IF
+ ." No log partition." cr EXIT
+ THEN
+ drop .dmesg
+;
+
+: dmesg ( -- )
+ s" ibm,CPU0log" get-named-nvram-partition IF
+ ." No log partition." cr EXIT
+ THEN
+ drop .dmesg
+;
diff --git a/qemu/roms/SLOF/slof/fs/packages.fs b/qemu/roms/SLOF/slof/fs/packages.fs
new file mode 100644
index 000000000..f640d8f61
--- /dev/null
+++ b/qemu/roms/SLOF/slof/fs/packages.fs
@@ -0,0 +1,52 @@
+\ *****************************************************************************
+\ * Copyright (c) 2004, 2015 IBM Corporation
+\ * All rights reserved.
+\ * This program and the accompanying materials
+\ * are made available under the terms of the BSD License
+\ * which accompanies this distribution, and is available at
+\ * http://www.opensource.org/licenses/bsd-license.php
+\ *
+\ * Contributors:
+\ * IBM Corporation - initial implementation
+\ ****************************************************************************/
+
+
+\ =============================================================================
+\ SUPPORT PACKAGES
+\ =============================================================================
+
+
+s" packages" device-name
+get-node to packages
+
+\ new-device
+\ #include "packages/filler.fs"
+\ finish-device
+
+new-device
+#include "packages/deblocker.fs"
+finish-device
+
+new-device
+#include "packages/disk-label.fs"
+finish-device
+
+new-device
+#include "packages/fat-files.fs"
+finish-device
+
+new-device
+#include "packages/rom-files.fs"
+finish-device
+
+new-device
+#include "packages/ext2-files.fs"
+finish-device
+
+new-device
+#include "packages/obp-tftp.fs"
+finish-device
+
+new-device
+#include "packages/iso-9660.fs"
+finish-device
diff --git a/qemu/roms/SLOF/slof/fs/packages/deblocker.fs b/qemu/roms/SLOF/slof/fs/packages/deblocker.fs
new file mode 100644
index 000000000..83cd71278
--- /dev/null
+++ b/qemu/roms/SLOF/slof/fs/packages/deblocker.fs
@@ -0,0 +1,70 @@
+\ *****************************************************************************
+\ * Copyright (c) 2004, 2008 IBM Corporation
+\ * All rights reserved.
+\ * This program and the accompanying materials
+\ * are made available under the terms of the BSD License
+\ * which accompanies this distribution, and is available at
+\ * http://www.opensource.org/licenses/bsd-license.php
+\ *
+\ * Contributors:
+\ * IBM Corporation - initial implementation
+\ ****************************************************************************/
+
+
+\ =============================================================================
+\ =============================================================================
+
+
+\ The deblocker. Allows block devices to be used as a (seekable) byte device.
+
+s" deblocker" device-name
+
+INSTANCE VARIABLE offset
+INSTANCE VARIABLE block-size
+INSTANCE VARIABLE max-transfer
+INSTANCE VARIABLE my-block
+INSTANCE VARIABLE adr
+INSTANCE VARIABLE len
+INSTANCE VARIABLE fail-count
+
+: open
+ s" block-size" ['] $call-parent CATCH IF 2drop false EXIT THEN
+ block-size !
+ s" max-transfer" ['] $call-parent CATCH IF 2drop false EXIT THEN
+ max-transfer !
+ block-size @ alloc-mem my-block !
+ 0 offset !
+ true ;
+: close my-block @ block-size @ free-mem ;
+
+: seek ( lo hi -- status ) \ XXX: perhaps we should fail if the underlying
+ \ device would fail at this offset
+ lxjoin offset ! 0 ;
+: block+remainder ( -- block# remainder ) offset @ block-size @ u/mod swap ;
+: read-blocks ( addr block# #blocks -- actual ) s" read-blocks" $call-parent ;
+: read ( addr len -- actual )
+ dup >r len ! adr !
+ \ First, handle a partial block at the start.
+ block+remainder dup IF ( block# offset-in-block )
+ >r my-block @ swap 1 read-blocks drop
+ my-block @ r@ + adr @ block-size @ r> - len @ min dup >r move
+ r> dup negate len +! dup adr +! offset +! ELSE 2drop THEN
+
+ \ Now, in a loop read max. max-transfer sized runs of whole blocks.
+ 0 fail-count !
+ BEGIN len @ block-size @ >= WHILE
+ adr @ block+remainder drop len @ max-transfer @ min block-size @ / read-blocks
+ dup 0= IF
+ 1 fail-count +!
+ fail-count @ 5 >= IF r> drop EXIT THEN
+ ELSE
+ 0 fail-count !
+ THEN
+ block-size @ * dup negate len +! dup adr +! offset +!
+ REPEAT
+
+ \ And lastly, handle a partial block at the end.
+ len @ IF my-block @ block+remainder drop 1 read-blocks drop
+ my-block @ adr @ len @ move THEN
+
+ r> ;
diff --git a/qemu/roms/SLOF/slof/fs/packages/disk-label.fs b/qemu/roms/SLOF/slof/fs/packages/disk-label.fs
new file mode 100644
index 000000000..fe1c25e7a
--- /dev/null
+++ b/qemu/roms/SLOF/slof/fs/packages/disk-label.fs
@@ -0,0 +1,660 @@
+\ *****************************************************************************
+\ * Copyright (c) 2004, 2008 IBM Corporation
+\ * All rights reserved.
+\ * This program and the accompanying materials
+\ * are made available under the terms of the BSD License
+\ * which accompanies this distribution, and is available at
+\ * http://www.opensource.org/licenses/bsd-license.php
+\ *
+\ * Contributors:
+\ * IBM Corporation - initial implementation
+\ ****************************************************************************/
+
+
+\ Set debug-disk-label? to true to get debug messages for the disk-label code.
+false VALUE debug-disk-label?
+
+\ This value defines the maximum number of blocks (512b) to load from a PREP
+\ partition. This is required to keep the load time in reasonable limits if the
+\ PREP partition becomes big.
+\ If we ever want to put a large kernel with initramfs from a PREP partition
+\ we might need to increase this value. The default value is 65536 blocks (32MB)
+d# 65536 value max-prep-partition-blocks
+
+s" disk-label" device-name
+
+0 INSTANCE VALUE partition
+0 INSTANCE VALUE part-offset
+0 INSTANCE VALUE disk-chrp-boot
+
+0 INSTANCE VALUE part-start
+0 INSTANCE VALUE lpart-start
+0 INSTANCE VALUE part-size
+0 INSTANCE VALUE dos-logical-partitions
+
+0 INSTANCE VALUE block-size
+0 INSTANCE VALUE block
+
+0 INSTANCE VALUE args
+0 INSTANCE VALUE args-len
+
+0 INSTANCE VALUE gpt-part-size
+0 INSTANCE VALUE seek-pos
+
+
+INSTANCE VARIABLE block# \ variable to store logical sector#
+INSTANCE VARIABLE hit# \ partition counter
+INSTANCE VARIABLE success-flag
+
+\ ISO9660 specific information
+0ff constant END-OF-DESC
+3 constant PARTITION-ID
+48 constant VOL-PART-LOC
+
+
+\ DOS partition label (MBR) specific structures
+
+STRUCT
+ 1b8 field mbr>boot-loader
+ /l field mbr>disk-signature
+ /w field mbr>null
+ 40 field mbr>partition-table
+ /w field mbr>magic
+
+CONSTANT /mbr
+
+STRUCT
+ /c field part-entry>active
+ /c field part-entry>start-head
+ /c field part-entry>start-sect
+ /c field part-entry>start-cyl
+ /c field part-entry>id
+ /c field part-entry>end-head
+ /c field part-entry>end-sect
+ /c field part-entry>end-cyl
+ /l field part-entry>sector-offset
+ /l field part-entry>sector-count
+
+CONSTANT /partition-entry
+
+STRUCT
+ 8 field gpt>signature
+ 4 field gpt>revision
+ 4 field gpt>header-size
+ 4 field gpt>header-crc32
+ 4 field gpt>reserved
+ 8 field gpt>current-lba
+ 8 field gpt>backup-lba
+ 8 field gpt>first-lba
+ 8 field gpt>last-lba
+ 10 field gpt>disk-guid
+ 8 field gpt>part-entry-lba
+ 4 field gpt>num-part-entry
+ 4 field gpt>part-entry-size
+ 4 field gpt>part-array-crc32
+ 1a4 field gpt>reserved
+
+CONSTANT /gpt-header
+
+STRUCT
+ 10 field gpt-part-entry>part-type-guid
+ 10 field gpt-part-entry>part-guid
+ 8 field gpt-part-entry>first-lba
+ 8 field gpt-part-entry>last-lba
+ 8 field gpt-part-entry>attribute
+ 48 field gpt-part-entry>part-name
+
+CONSTANT /gpt-part-entry
+
+\ Defined by IEEE 1275-1994 (3.8.1)
+
+: offset ( d.rel -- d.abs )
+ part-offset xlsplit d+
+;
+
+: seek ( pos.lo pos.hi -- status )
+ offset
+ debug-disk-label? IF 2dup ." seek-parent: pos.hi=0x" u. ." pos.lo=0x" u. THEN
+ s" seek" $call-parent
+ debug-disk-label? IF dup ." status=" . cr THEN
+;
+
+: read ( addr len -- actual )
+ debug-disk-label? IF 2dup swap ." read-parent: addr=0x" u. ." len=" .d THEN
+ s" read" $call-parent
+ debug-disk-label? IF dup ." actual=" .d cr THEN
+;
+
+
+\ read sector to array "block"
+: read-sector ( sector-number -- )
+ \ block-size is 0x200 on disks, 0x800 on cdrom drives
+ block-size * 0 seek drop \ seek to sector
+ block block-size read drop \ read sector
+;
+
+: (.part-entry) ( part-entry )
+ cr ." part-entry>active: " dup part-entry>active c@ .d
+ cr ." part-entry>start-head: " dup part-entry>start-head c@ .d
+ cr ." part-entry>start-sect: " dup part-entry>start-sect c@ .d
+ cr ." part-entry>start-cyl: " dup part-entry>start-cyl c@ .d
+ cr ." part-entry>id: " dup part-entry>id c@ .d
+ cr ." part-entry>end-head: " dup part-entry>end-head c@ .d
+ cr ." part-entry>end-sect: " dup part-entry>end-sect c@ .d
+ cr ." part-entry>end-cyl: " dup part-entry>end-cyl c@ .d
+ cr ." part-entry>sector-offset: " dup part-entry>sector-offset l@-le .d
+ cr ." part-entry>sector-count: " dup part-entry>sector-count l@-le .d
+ cr
+;
+
+: (.name) r@ begin cell - dup @ <colon> = UNTIL xt>name cr type space ;
+
+: init-block ( -- )
+ s" block-size" ['] $call-parent CATCH IF ABORT" parent has no block-size." THEN
+ to block-size
+ d# 4096 alloc-mem
+ dup d# 4096 erase
+ to block
+ debug-disk-label? IF
+ ." init-block: block-size=" block-size .d ." block=0x" block u. cr
+ THEN
+;
+
+: partition>part-entry ( partition -- part-entry )
+ 1- /partition-entry * block mbr>partition-table +
+;
+
+: partition>start-sector ( partition -- sector-offset )
+ partition>part-entry part-entry>sector-offset l@-le
+;
+
+\ This word returns true if the currently loaded block has _NO_ MBR magic
+: no-mbr? ( -- true|false )
+ 0 read-sector
+ 1 partition>part-entry part-entry>id c@ ee = IF TRUE EXIT THEN \ GPT partition found
+ block mbr>magic w@-le aa55 <>
+;
+
+\ This word returns true if the currently loaded block has _NO_ GPT partition id
+: no-gpt? ( -- true|false )
+ 0 read-sector
+ 1 partition>part-entry part-entry>id c@ ee <>
+;
+
+: pc-extended-partition? ( part-entry-addr -- true|false )
+ part-entry>id c@ ( id )
+ dup 5 = swap ( true|false id )
+ dup f = swap ( true|false true|false id )
+ 85 = ( true|false true|false true|false )
+ or or ( true|false )
+;
+
+: count-dos-logical-partitions ( -- #logical-partitions )
+ no-mbr? IF 0 EXIT THEN
+ 0 5 1 DO ( current )
+ i partition>part-entry ( current part-entry )
+ dup pc-extended-partition? IF
+ part-entry>sector-offset l@-le ( current sector )
+ dup to part-start to lpart-start ( current )
+ BEGIN
+ part-start read-sector \ read EBR
+ 1 partition>start-sector IF
+ \ ." Logical Partition found at " part-start .d cr
+ 1+
+ THEN \ another logical partition
+ 2 partition>start-sector
+ ( current relative-sector )
+ ?dup IF lpart-start + to part-start false ELSE true THEN
+ UNTIL
+ ELSE
+ drop
+ THEN
+ LOOP
+;
+
+: (get-dos-partition-params) ( ext-part-start part-entry -- offset count active? id )
+ dup part-entry>sector-offset l@-le rot + swap ( offset part-entry )
+ dup part-entry>sector-count l@-le swap ( offset count part-entry )
+ dup part-entry>active c@ 80 = swap ( offset count active? part-entry )
+ part-entry>id c@ ( offset count active? id )
+;
+
+: find-dos-partition ( partition# -- false | offset count active? id true )
+ to partition 0 to part-start 0 to part-offset
+
+ \ no negative partitions
+ partition 0<= IF 0 to partition false EXIT THEN
+
+ \ load MBR and check it
+ no-mbr? IF 0 to partition false EXIT THEN
+
+ partition 4 <= IF \ Is this a primary partition?
+ 0 partition partition>part-entry
+ (get-dos-partition-params)
+ \ FIXME sanity checks?
+ true EXIT
+ ELSE
+ partition 4 - 0 5 1 DO ( logical-partition current )
+ i partition>part-entry ( log-part current part-entry )
+ dup pc-extended-partition? IF
+ part-entry>sector-offset l@-le ( log-part current sector )
+ dup to part-start to lpart-start ( log-part current )
+ BEGIN
+ part-start read-sector \ read EBR
+ 1 partition>start-sector IF \ first partition entry
+ 1+ 2dup = IF ( log-part current )
+ 2drop
+ part-start 1 partition>part-entry
+ (get-dos-partition-params)
+ true UNLOOP EXIT
+ THEN
+ 2 partition>start-sector
+ ( log-part current relative-sector )
+
+ ?dup IF lpart-start + to part-start false ELSE true THEN
+ ELSE
+ true
+ THEN
+ UNTIL
+ ELSE
+ drop
+ THEN
+ LOOP
+ 2drop false
+ THEN
+;
+
+: try-dos-partition ( -- okay? )
+ \ Read partition table and check magic.
+ no-mbr? IF cr ." No DOS disk-label found." cr false EXIT THEN
+
+ count-dos-logical-partitions TO dos-logical-partitions
+
+ debug-disk-label? IF
+ ." Found " dos-logical-partitions .d ." logical partitions" cr
+ ." Partition = " partition .d cr
+ THEN
+
+ partition 1 5 dos-logical-partitions +
+ within 0= IF
+ cr ." Partition # not 1-" 4 dos-logical-partitions + . cr false EXIT
+ THEN
+
+ \ Could/should check for valid partition here... the magic is not enough really.
+
+ \ Get the partition offset.
+
+ partition find-dos-partition IF
+ ( offset count active? id )
+ 2drop
+ to part-size
+ block-size * to part-offset
+ true
+ ELSE
+ false
+ THEN
+;
+
+\ Check for an ISO-9660 filesystem on the disk
+\ : try-iso9660-partition ( -- true|false )
+\ implement me if you can ;-)
+\ ;
+
+
+\ Check for an ISO-9660 filesystem on the disk
+\ (cf. CHRP IEEE 1275 spec., chapter 11.1.2.3)
+: has-iso9660-filesystem ( -- TRUE|FALSE )
+ \ Seek to the beginning of logical 2048-byte sector 16
+ \ refer to Chapter C.11.1 in PAPR 2.0 Spec
+ \ was: 10 read-sector, but this might cause trouble if you
+ \ try booting an ISO image from a device with 512b sectors.
+ 10 800 * 0 seek drop \ seek to sector
+ block 800 read drop \ read sector
+ \ Check for CD-ROM volume magic:
+ block c@ 1 =
+ block 1+ 5 s" CD001" str=
+ and
+ dup IF 800 to block-size THEN
+;
+
+
+\ Load from first active DOS boot partition.
+
+\ NOTE: block-size is always 512 bytes for DOS partition tables.
+
+: load-from-dos-boot-partition ( addr -- size )
+ no-mbr? IF drop FALSE EXIT THEN \ read MBR and check for DOS disk-label magic
+
+ count-dos-logical-partitions TO dos-logical-partitions
+
+ debug-disk-label? IF
+ ." Found " dos-logical-partitions .d ." logical partitions" cr
+ ." Partition = " partition .d cr
+ THEN
+
+ \ Now walk through the partitions:
+ 5 dos-logical-partitions + 1 DO
+ \ ." checking partition " i .
+ i find-dos-partition IF ( addr offset count active? id )
+ 41 = and ( addr offset count prep-boot-part? )
+ IF ( addr offset count )
+ max-prep-partition-blocks min \ reduce load size
+ swap ( addr count offset )
+ block-size * to part-offset
+ 0 0 seek drop ( addr offset )
+ block-size * read ( size )
+ UNLOOP EXIT
+ ELSE
+ 2drop ( addr )
+ THEN
+ THEN
+ LOOP
+ drop 0
+;
+
+\ Check for GPT PReP partition GUID
+9E1A2D38 CONSTANT GPT-PREP-PARTITION-1
+C612 CONSTANT GPT-PREP-PARTITION-2
+4316 CONSTANT GPT-PREP-PARTITION-3
+AA26 CONSTANT GPT-PREP-PARTITION-4
+8B49521E5A8B CONSTANT GPT-PREP-PARTITION-5
+
+: gpt-prep-partition? ( -- true|false )
+ block gpt-part-entry>part-type-guid l@-le GPT-PREP-PARTITION-1 = IF
+ block gpt-part-entry>part-type-guid 4 + w@-le
+ GPT-PREP-PARTITION-2 = IF
+ block gpt-part-entry>part-type-guid 6 + w@-le
+ GPT-PREP-PARTITION-3 = IF
+ block gpt-part-entry>part-type-guid 8 + w@
+ GPT-PREP-PARTITION-4 = IF
+ block gpt-part-entry>part-type-guid a + w@
+ block gpt-part-entry>part-type-guid c + l@ swap lxjoin
+ GPT-PREP-PARTITION-5 = IF
+ TRUE EXIT
+ THEN
+ THEN
+ THEN
+ THEN
+ THEN
+ FALSE
+;
+
+: load-from-gpt-prep-partition ( addr -- size )
+ no-gpt? IF drop FALSE EXIT THEN
+ debug-disk-label? IF
+ cr ." GPT partition found " cr
+ THEN
+ 1 read-sector block gpt>part-entry-lba l@-le
+ block-size * to seek-pos
+ block gpt>part-entry-size l@-le to gpt-part-size
+ block gpt>num-part-entry l@-le dup 0= IF FALSE EXIT THEN
+ 1+ 1 ?DO
+ seek-pos 0 seek drop
+ block gpt-part-size read drop gpt-prep-partition? IF
+ debug-disk-label? IF
+ ." GPT PReP partition found " cr
+ THEN
+ block gpt-part-entry>first-lba x@ xbflip
+ block gpt-part-entry>last-lba x@ xbflip
+ over - 1+ ( addr offset len )
+ swap ( addr len offset )
+ block-size * to part-offset
+ 0 0 seek drop ( addr len )
+ block-size * read ( size )
+ UNLOOP EXIT
+ THEN
+ seek-pos gpt-part-size i * + to seek-pos
+ LOOP
+ FALSE
+;
+
+\ Extract the boot loader path from a bootinfo.txt file
+\ In: address and length of buffer where the bootinfo.txt has been loaded to.
+\ Out: string address and length of the boot loader (within the input buffer)
+\ or a string with length = 0 when parsing failed.
+
+\ Here is a sample bootinfo file:
+\ <chrp-boot>
+\ <description>Linux Distribution</description>
+\ <os-name>Linux</os-name>
+\ <boot-script>boot &device;:1,\boot\yaboot.ibm</boot-script>
+\ <icon size=64,64 color-space=3,3,2>
+\ <bitmap>[..]</bitmap>
+\ </icon>
+\ </chrp-boot>
+
+: parse-bootinfo-txt ( addr len -- str len )
+ 2dup s" <boot-script>" find-substr ( addr len pos1 )
+ 2dup = IF
+ \ String not found
+ 3drop 0 0 EXIT
+ THEN
+ dup >r - swap r> + swap ( addr1 len1 )
+
+ 2dup s" &device;:" find-substr ( addr1 len1 posdev )
+ 2dup = IF
+ 3drop 0 0 EXIT
+ THEN
+ 9 + \ Skip the "&device;:" string
+ dup >r - swap r> + swap ( addr2 len2 )
+ 2dup s" </boot-script>" find-substr nip ( addr2 len3 )
+
+ debug-disk-label? IF
+ ." Extracted boot loader from bootinfo.txt: '"
+ 2dup type ." '" cr
+ THEN
+;
+
+\ Try to load \ppc\bootinfo.txt from the disk (used mainly on CD-ROMs), and if
+\ available, get the boot loader path from this file and load it.
+\ See the "CHRP system binding to IEEE 1275" specification for more information
+\ about bootinfo.txt. An example file can be found in the comment of
+\ parse-bootinfo-txt ( addr len -- str len )
+
+: load-chrp-boot-file ( addr -- size )
+ \ Create bootinfo.txt path name and load that file:
+ my-parent instance>path
+ disk-chrp-boot @ 1 = IF
+ s" :1,\ppc\bootinfo.txt" $cat strdup ( addr str len )
+ ELSE
+ s" :\ppc\bootinfo.txt" $cat strdup ( addr str len )
+ THEN
+ open-dev dup 0= IF 2drop 0 EXIT THEN
+ >r dup ( addr addr R:ihandle )
+ dup s" load" r@ $call-method ( addr addr size R:ihandle )
+ r> close-dev ( addr addr size )
+
+ \ Now parse the information from bootinfo.txt:
+ parse-bootinfo-txt ( addr fnstr fnlen )
+ dup 0= IF 3drop 0 EXIT THEN
+ \ Does the string contain parameters (i.e. a white space)?
+ 2dup 20 findchar IF
+ ( addr fnstr fnlen offset )
+ >r 2dup r@ - 1- swap r@ + 1+ swap ( addr fnstr fnlen pstr plen R: offset )
+ encode-string s" bootargs" set-chosen
+ drop r>
+ THEN
+
+ \ Create the full path to the boot loader:
+ my-parent instance>path ( addr fnstr fnlen nstr nlen )
+ s" :" $cat 2swap $cat strdup ( addr str len )
+ \ Update the bootpath:
+ 2dup encode-string s" bootpath" set-chosen
+ \ And finally load the boot loader itself:
+ open-dev dup 0= IF ." failed to load CHRP boot loader." 2drop 0 EXIT THEN
+ >r s" load" r@ $call-method ( size R:ihandle )
+ r> close-dev ( size )
+;
+
+\ load from a bootable partition
+: load-from-boot-partition ( addr -- size )
+ debug-disk-label? IF ." Trying DOS boot " .s cr THEN
+ dup load-from-dos-boot-partition ?dup 0 <> IF nip EXIT THEN
+
+ debug-disk-label? IF ." Trying CHRP boot " .s cr THEN
+ 1 disk-chrp-boot !
+ dup load-chrp-boot-file ?dup 0 <> IF .s cr nip EXIT THEN
+ 0 disk-chrp-boot !
+
+ debug-disk-label? IF ." Trying GPT boot " .s cr THEN
+ load-from-gpt-prep-partition
+ \ More boot partition formats ...
+;
+
+\ parse partition number from my-args
+
+\ my-args has the following format
+\ [<partition>[,<path>]]
+
+\ | example my-args | example boot command |
+\ +------------------+---------------------------+
+\ | 1,\boot\vmlinuz | boot disk:1,\boot\vmlinuz |
+\ | 2 | boot disk:2 |
+
+\ 0 means the whole disk, this is the same behavior
+\ as if no partition is specified (yaboot wants this).
+
+: parse-partition ( -- okay? )
+ 0 to partition
+ 0 to part-offset
+ 0 to part-size
+
+ my-args to args-len to args
+
+ debug-disk-label? IF
+ cr ." disk-label parse-partition: my-args=" my-args type cr
+ THEN
+
+ \ Called without arguments?
+ args-len 0 = IF true EXIT THEN
+
+ \ Check for "full disk" arguments.
+ my-args [char] , findchar 0= IF \ no comma?
+ args c@ isdigit not IF \ ... and not a partition number?
+ true EXIT \ ... then it's not a partition we can parse
+ THEN
+ ELSE
+ drop
+ THEN
+ my-args [char] , split to args-len to args
+ dup 0= IF 2drop true EXIT THEN \ no first argument
+
+ \ Check partition #.
+ base @ >r decimal $number r> base !
+ IF cr ." Not a partition #" false EXIT THEN
+
+ \ Store part #, done.
+ to partition
+ true
+;
+
+
+\ try-files and try-partitions
+
+: (interpose-filesystem) ( str len -- )
+ find-package IF args args-len rot interpose THEN
+;
+
+: try-dos-files ( -- found? )
+ no-mbr? IF false EXIT THEN
+
+ \ block 0 byte 0-2 is a jump instruction in all FAT
+ \ filesystems.
+ \ e9 and eb are jump instructions in x86 assembler.
+ block c@ e9 <> IF
+ block c@ eb <>
+ block 2+ c@ 90 <> or
+ IF false EXIT THEN
+ THEN
+ s" fat-files" (interpose-filesystem)
+ true
+;
+
+: try-ext2-files ( -- found? )
+ 2 read-sector \ read first superblock
+ block d# 56 + w@-le \ fetch s_magic
+ ef53 <> IF false EXIT THEN \ s_magic found?
+ s" ext2-files" (interpose-filesystem)
+ true
+;
+
+
+: try-iso9660-files
+ has-iso9660-filesystem 0= IF false exit THEN
+ s" iso-9660" (interpose-filesystem)
+ true
+;
+
+: try-files ( -- found? )
+ \ If no path, then full disk.
+ args-len 0= IF true EXIT THEN
+
+ try-dos-files IF true EXIT THEN
+ try-ext2-files IF true EXIT THEN
+ try-iso9660-files IF true EXIT THEN
+
+ \ ... more filesystem types here ...
+
+ false
+;
+
+: try-partitions ( -- found? )
+ try-dos-partition IF try-files EXIT THEN
+ \ try-iso9660-partition IF try-files EXIT THEN
+ \ ... more partition types here...
+ false
+;
+
+\ Interface functions for disk-label package
+\ as defined by IEEE 1275-1994 3.8.1
+
+: close ( -- )
+ debug-disk-label? IF ." Closing disk-label: block=0x" block u. ." block-size=" block-size .d cr THEN
+ block d# 4096 free-mem
+;
+
+
+: open ( -- true|false )
+ init-block
+
+ parse-partition 0= IF
+ close
+ false EXIT
+ THEN
+
+ partition IF
+ try-partitions
+ ELSE
+ try-files
+ THEN
+ dup 0= IF debug-disk-label? IF ." not found." cr THEN close THEN \ free memory again
+;
+
+
+\ Boot & Load w/o arguments is assumed to be boot from boot partition
+
+: load ( addr -- size )
+ debug-disk-label? IF
+ ." load: " dup u. cr
+ THEN
+
+ args-len IF
+ TRUE ABORT" Load done w/o filesystem"
+ ELSE
+ partition IF
+ 0 0 seek drop
+ part-size IF
+ part-size max-prep-partition-blocks min \ Load size
+ ELSE
+ max-prep-partition-blocks
+ THEN
+ 200 * read
+ ELSE
+ has-iso9660-filesystem IF
+ dup load-chrp-boot-file ?dup 0 > IF nip EXIT THEN
+ THEN
+ load-from-boot-partition
+ dup 0= ABORT" No boot partition found"
+ THEN
+ THEN
+;
diff --git a/qemu/roms/SLOF/slof/fs/packages/ext2-files.fs b/qemu/roms/SLOF/slof/fs/packages/ext2-files.fs
new file mode 100644
index 000000000..262c64a34
--- /dev/null
+++ b/qemu/roms/SLOF/slof/fs/packages/ext2-files.fs
@@ -0,0 +1,188 @@
+\ *****************************************************************************
+\ * Copyright (c) 2004, 2011 IBM Corporation
+\ * All rights reserved.
+\ * This program and the accompanying materials
+\ * are made available under the terms of the BSD License
+\ * which accompanies this distribution, and is available at
+\ * http://www.opensource.org/licenses/bsd-license.php
+\ *
+\ * Contributors:
+\ * IBM Corporation - initial implementation
+\ ****************************************************************************/
+s" ext2-files" device-name
+
+INSTANCE VARIABLE first-block
+INSTANCE VARIABLE inode-size
+INSTANCE VARIABLE block-size
+INSTANCE VARIABLE inodes/group
+
+INSTANCE VARIABLE group-desc-size
+INSTANCE VARIABLE group-descriptors
+
+: seek s" seek" $call-parent ;
+: read s" read" $call-parent ;
+
+INSTANCE VARIABLE data
+INSTANCE VARIABLE #data
+INSTANCE VARIABLE indirect-block
+INSTANCE VARIABLE dindirect-block
+
+: free-data
+ data @ ?dup IF #data @ free-mem 0 data ! THEN ;
+: read-data ( offset size -- )
+ free-data dup #data ! alloc-mem data !
+ xlsplit seek -2 and ABORT" ext2-files read-data: seek failed"
+ data @ #data @ read #data @ <> ABORT" ext2-files read-data: read failed" ;
+
+: read-block ( block# -- )
+ block-size @ * block-size @ read-data ;
+
+INSTANCE VARIABLE inode
+INSTANCE VARIABLE file-len
+INSTANCE VARIABLE blocks
+INSTANCE VARIABLE #blocks
+INSTANCE VARIABLE ^blocks
+INSTANCE VARIABLE #blocks-left
+: blocks-read ( n -- ) dup negate #blocks-left +! 4 * ^blocks +! ;
+: read-indirect-blocks ( indirect-block# -- )
+ read-block data @ data off
+ dup #blocks-left @ 4 * block-size @ min dup >r ^blocks @ swap move
+ r> 2 rshift blocks-read block-size @ free-mem ;
+
+: read-double-indirect-blocks ( double-indirect-block# -- )
+ \ Resolve one level of indirection and call read-indirect-block
+ read-block data @ indirect-block ! data off
+ BEGIN
+ indirect-block @ l@-le dup 0 <>
+ WHILE
+ read-indirect-blocks
+ 4 indirect-block +! \ point to next indirect block
+ REPEAT
+ drop \ drop 0, the invalid block number
+;
+
+: read-triple-indirect-blocks ( triple-indirect-block# -- )
+ \ Resolve one level of indirection and call double-indirect-block
+ read-block data @ dindirect-block ! data off
+ BEGIN
+ dindirect-block @ l@-le dup 0 <>
+ WHILE
+ read-double-indirect-blocks
+ 4 dindirect-block +! \ point to next double indirect block
+ REPEAT
+ drop \ drop 0, the invalid block number
+;
+
+: read-block#s ( -- )
+ blocks @ ?dup IF #blocks @ 4 * free-mem THEN
+ inode @ 4 + l@-le file-len !
+ file-len @ block-size @ // #blocks !
+ #blocks @ 4 * alloc-mem blocks !
+ blocks @ ^blocks ! #blocks @ #blocks-left !
+ #blocks-left @ c min \ # direct blocks
+ inode @ 28 + over 4 * ^blocks @ swap move blocks-read
+ #blocks-left @ IF inode @ 58 + l@-le read-indirect-blocks THEN
+ #blocks-left @ IF inode @ 5c + l@-le read-double-indirect-blocks THEN
+ #blocks-left @ IF inode @ 60 + l@-le read-triple-indirect-blocks THEN ;
+: read-inode ( inode# -- )
+ 1- inodes/group @ u/mod \ # in group, group #
+ 20 * group-descriptors @ + 8 + l@-le block-size @ * \ # in group, inode table
+ swap inode-size @ * + xlsplit seek drop inode @ inode-size @ read drop
+;
+
+: .rwx ( bits last-char-if-special special? -- )
+ rot dup 4 and IF ." r" ELSE ." -" THEN
+ dup 2 and IF ." w" ELSE ." -" THEN
+ swap IF 1 and 0= IF upc THEN emit ELSE
+ 1 and IF ." x" ELSE ." -" THEN drop THEN ;
+CREATE mode-chars 10 allot s" ?pc?d?b?-?l?s???" mode-chars swap move
+: .mode ( mode -- )
+ dup c rshift f and mode-chars + c@ emit
+ dup 6 rshift 7 and over 800 and 73 swap .rwx
+ dup 3 rshift 7 and over 400 and 73 swap .rwx
+ dup 7 and swap 200 and 74 swap .rwx ;
+: .inode ( -- )
+ base @ >r decimal
+ inode @ w@-le .mode \ file mode
+ inode @ 1a + w@-le 5 .r \ link count
+ inode @ 02 + w@-le 9 .r \ uid
+ inode @ 18 + w@-le 9 .r \ gid
+ inode @ 04 + l@-le 9 .r \ size
+ r> base ! ;
+
+: do-super ( -- )
+ 400 400 read-data
+ data @ 14 + l@-le first-block !
+ 400 data @ 18 + l@-le lshift block-size !
+ data @ 28 + l@-le inodes/group !
+ \ Check revision level... in revision 0, the inode size is always 128
+ data @ 4c + l@-le 0= IF
+ 80 inode-size !
+ ELSE
+ data @ 58 + w@-le inode-size !
+ THEN
+ data @ 20 + l@-le group-desc-size !
+
+ \ Read the group descriptor table:
+ first-block @ 1+ block-size @ *
+ group-desc-size @
+ read-data
+ data @ group-descriptors !
+
+ \ We keep the group-descriptor memory area, so clear data pointer:
+ data off
+;
+
+INSTANCE VARIABLE current-pos
+
+: read ( adr len -- actual )
+ file-len @ current-pos @ - min \ can't go past end of file
+ current-pos @ block-size @ u/mod 4 * blocks @ + l@-le read-block
+ block-size @ over - rot min >r ( adr off r: len )
+ data @ + swap r@ move r> dup current-pos +! ;
+: read ( adr len -- actual )
+ ( check if a file is selected, first )
+ dup >r BEGIN dup WHILE 2dup read dup 0= ABORT" ext2-files: read failed"
+ /string REPEAT 2drop r> ;
+: seek ( lo hi -- status )
+ lxjoin dup file-len @ > IF drop true EXIT THEN current-pos ! false ;
+: load ( adr -- len )
+ file-len @ read dup file-len @ <> ABORT" ext2-files: failed loading file" ;
+
+: .name ( adr -- ) dup 8 + swap 6 + c@ type ;
+: read-dir ( inode# -- adr )
+ read-inode read-block#s file-len @ alloc-mem
+ 0 0 seek ABORT" ext2-files read-dir: seek failed"
+ dup file-len @ read file-len @ <> ABORT" ext2-files read-dir: read failed" ;
+: .dir ( inode# -- )
+ read-dir dup BEGIN 2dup file-len @ - > over l@-le tuck and WHILE
+ cr dup 8 0.r space read-inode .inode space space dup .name
+ dup 4 + w@-le + REPEAT 2drop file-len @ free-mem ;
+: (find-file) ( adr name len -- inode#|0 )
+ 2>r dup BEGIN 2dup file-len @ - > over l@-le and WHILE
+ dup 8 + over 6 + c@ 2r@ str= IF 2r> 2drop nip l@-le EXIT THEN
+ dup 4 + w@-le + REPEAT 2drop 2r> 2drop 0 ;
+: find-file ( inode# name len -- inode#|0 )
+ 2>r read-dir dup 2r> (find-file) swap file-len @ free-mem ;
+: find-path ( inode# name len -- inode#|0 )
+ dup 0= IF 3drop 0 ." empty name " EXIT THEN
+ over c@ [char] \ = IF 1 /string ." slash " RECURSE EXIT THEN
+ [char] \ split 2>r find-file ?dup 0= IF
+ 2r> 2drop false ." not found " EXIT THEN
+ r@ 0<> IF 2r> ." more... " RECURSE EXIT THEN
+ 2r> 2drop ." got it " ;
+
+: close
+ inode @ inode-size @ free-mem
+ group-descriptors @ group-desc-size @ free-mem
+ free-data
+ blocks @ ?dup IF #blocks @ 4 * free-mem THEN
+;
+
+: open
+ 0 data ! 0 blocks ! 0 #blocks !
+ do-super
+ inode-size @ alloc-mem inode !
+ my-args nip 0= IF 0 0 ELSE
+ 2 my-args find-path ?dup 0= IF close false EXIT THEN THEN
+ read-inode read-block#s 0 0 seek 0= ;
diff --git a/qemu/roms/SLOF/slof/fs/packages/fat-files.fs b/qemu/roms/SLOF/slof/fs/packages/fat-files.fs
new file mode 100644
index 000000000..0cec3664e
--- /dev/null
+++ b/qemu/roms/SLOF/slof/fs/packages/fat-files.fs
@@ -0,0 +1,188 @@
+\ *****************************************************************************
+\ * Copyright (c) 2004, 2008 IBM Corporation
+\ * All rights reserved.
+\ * This program and the accompanying materials
+\ * are made available under the terms of the BSD License
+\ * which accompanies this distribution, and is available at
+\ * http://www.opensource.org/licenses/bsd-license.php
+\ *
+\ * Contributors:
+\ * IBM Corporation - initial implementation
+\ ****************************************************************************/
+
+
+s" fat-files" device-name
+
+INSTANCE VARIABLE bytes/sector
+INSTANCE VARIABLE sectors/cluster
+INSTANCE VARIABLE #reserved-sectors
+INSTANCE VARIABLE #fats
+INSTANCE VARIABLE #root-entries
+INSTANCE VARIABLE total-#sectors
+INSTANCE VARIABLE media-descriptor
+INSTANCE VARIABLE sectors/fat
+INSTANCE VARIABLE sectors/track
+INSTANCE VARIABLE #heads
+INSTANCE VARIABLE #hidden-sectors
+
+INSTANCE VARIABLE fat-type
+INSTANCE VARIABLE bytes/cluster
+INSTANCE VARIABLE fat-offset
+INSTANCE VARIABLE root-offset
+INSTANCE VARIABLE cluster-offset
+INSTANCE VARIABLE #clusters
+
+: seek s" seek" $call-parent ;
+: read s" read" $call-parent ;
+
+INSTANCE VARIABLE data
+INSTANCE VARIABLE #data
+
+: free-data
+ data @ ?dup IF #data @ free-mem 0 data ! THEN ;
+: read-data ( offset size -- )
+ free-data dup #data ! alloc-mem data !
+ xlsplit seek -2 and ABORT" fat-files read-data: seek failed"
+ data @ #data @ read #data @ <> ABORT" fat-files read-data: read failed" ;
+
+CREATE fat-buf 8 allot
+: read-fat ( cluster# -- data )
+ fat-buf 8 erase
+ 1 #split fat-type @ * 2/ 2/ fat-offset @ +
+ xlsplit seek -2 and ABORT" fat-files read-fat: seek failed"
+ fat-buf 8 read 8 <> ABORT" fat-files read-fat: read failed"
+ fat-buf 8c@ bxjoin fat-type @ dup >r 2* #split drop r> #split
+ rot IF swap THEN drop ;
+
+INSTANCE VARIABLE next-cluster
+
+: read-cluster ( cluster# -- )
+ dup bytes/cluster @ * cluster-offset @ + bytes/cluster @ read-data
+ read-fat dup #clusters @ >= IF drop 0 THEN next-cluster ! ;
+: read-dir ( cluster# -- )
+ ?dup 0= IF root-offset @ #root-entries @ 20 * read-data 0 next-cluster !
+ ELSE read-cluster THEN ;
+
+: .time ( x -- )
+ base @ >r decimal
+ b #split 2 0.r [char] : emit 5 #split 2 0.r [char] : emit 2* 2 0.r
+ r> base ! ;
+: .date ( x -- )
+ base @ >r decimal
+ 9 #split 7bc + 4 0.r [char] - emit 5 #split 2 0.r [char] - emit 2 0.r
+ r> base ! ;
+: .attr ( attr -- )
+ 6 0 DO dup 1 and IF s" RHSLDA" drop i + c@ ELSE bl THEN emit u2/ LOOP drop ;
+: .dir-entry ( adr -- )
+ dup 0b + c@ 8 and IF drop EXIT THEN \ volume label, not a file
+ dup c@ e5 = IF drop EXIT THEN \ deleted file
+ cr
+ dup 1a + 2c@ bwjoin [char] # emit 4 0.r space \ starting cluster
+ dup 18 + 2c@ bwjoin .date space
+ dup 16 + 2c@ bwjoin .time space
+ dup 1c + 4c@ bljoin base @ decimal swap a .r base ! space \ size in bytes
+ dup 0b + c@ .attr space
+ dup 8 BEGIN 2dup 1- + c@ 20 = over and WHILE 1- REPEAT type
+ dup 8 + 3 BEGIN 2dup 1- + c@ 20 = over and WHILE 1- REPEAT dup IF
+ [char] . emit type ELSE 2drop THEN
+ drop ;
+: .dir-entries ( adr n -- )
+ 0 ?DO dup i 20 * + dup c@ 0= IF drop LEAVE THEN .dir-entry LOOP drop ;
+: .dir ( cluster# -- )
+ read-dir BEGIN data @ #data @ 20 / .dir-entries next-cluster @ WHILE
+ next-cluster @ read-cluster REPEAT ;
+
+: str-upper ( str len adr -- ) \ Copy string to adr, uppercase
+ -rot bounds ?DO i c@ upc over c! char+ LOOP drop ;
+CREATE dos-name b allot
+: make-dos-name ( str len -- )
+ dos-name b bl fill
+ 2dup [char] . findchar IF
+ 3dup 1+ /string 3 min dos-name 8 + str-upper nip THEN
+ 8 min dos-name str-upper ;
+
+: (find-file) ( -- cluster file-len is-dir? true | false )
+ data @ BEGIN dup data @ #data @ + < WHILE
+ dup dos-name b comp WHILE 20 + REPEAT
+ dup 1a + 2c@ bwjoin swap dup 1c + 4c@ bljoin swap 0b + c@ 10 and 0<> true
+ ELSE drop false THEN ;
+: find-file ( dir-cluster name len -- cluster file-len is-dir? true | false )
+ make-dos-name read-dir BEGIN (find-file) 0= WHILE next-cluster @ WHILE
+ next-cluster @ read-cluster REPEAT false ELSE true THEN ;
+: find-path ( dir-cluster name len -- cluster file-len true | false )
+ dup 0= IF 3drop false ." empty name " EXIT THEN
+ over c@ [char] \ = IF 1 /string RECURSE EXIT THEN
+ [char] \ split 2>r find-file 0= IF 2r> 2drop false ." not found " EXIT THEN
+ r@ 0<> <> IF 2drop 2r> 2drop false ." no dir<->file match " EXIT THEN
+ r@ 0<> IF drop 2r> RECURSE EXIT THEN
+ 2r> 2drop true ;
+
+: do-super ( -- )
+ 0 200 read-data
+ data @ 0b + 2c@ bwjoin bytes/sector !
+ data @ 0d + c@ sectors/cluster !
+ bytes/sector @ sectors/cluster @ * bytes/cluster !
+ data @ 0e + 2c@ bwjoin #reserved-sectors !
+ data @ 10 + c@ #fats !
+ data @ 11 + 2c@ bwjoin #root-entries !
+ data @ 13 + 2c@ bwjoin total-#sectors !
+ data @ 15 + c@ media-descriptor !
+ data @ 16 + 2c@ bwjoin sectors/fat !
+ data @ 18 + 2c@ bwjoin sectors/track !
+ data @ 1a + 2c@ bwjoin #heads !
+ data @ 1c + 2c@ bwjoin #hidden-sectors !
+
+ \ For FAT16 and FAT32:
+ total-#sectors @ 0= IF data @ 20 + 4c@ bljoin total-#sectors ! THEN
+
+ \ For FAT32:
+ sectors/fat @ 0= IF data @ 24 + 4c@ bljoin sectors/fat ! THEN
+
+ \ XXX add other FAT32 stuff (offsets 28, 2c, 30)
+
+ \ Compute the number of data clusters, decide what FAT type we are.
+ total-#sectors @ #reserved-sectors @ - sectors/fat @ #fats @ * -
+ #root-entries @ 20 * bytes/sector @ // - sectors/cluster @ /
+ dup #clusters !
+ dup ff5 < IF drop c ELSE fff5 < IF 10 ELSE 20 THEN THEN fat-type !
+ base @ decimal base !
+
+ \ Starting offset of first fat.
+ #reserved-sectors @ bytes/sector @ * fat-offset !
+
+ \ Starting offset of root dir.
+ #fats @ sectors/fat @ * bytes/sector @ * fat-offset @ + root-offset !
+
+ \ Starting offset of "cluster 0".
+ #root-entries @ 20 * bytes/sector @ tuck // * root-offset @ +
+ bytes/cluster @ 2* - cluster-offset ! ;
+
+
+INSTANCE VARIABLE file-cluster
+INSTANCE VARIABLE file-len
+INSTANCE VARIABLE current-pos
+INSTANCE VARIABLE pos-in-data
+
+: seek ( lo hi -- status )
+ lxjoin dup current-pos ! file-cluster @ read-cluster
+ \ Read and skip blocks until we are where we want to be.
+ BEGIN dup #data @ >= WHILE #data @ - next-cluster @ dup 0= IF
+ 2drop true EXIT THEN read-cluster REPEAT pos-in-data ! false ;
+: read ( adr len -- actual )
+ file-len @ current-pos @ - min \ can't go past end of file
+ #data @ pos-in-data @ - min >r \ length for this transfer
+ data @ pos-in-data @ + swap r@ move \ move the data
+ r@ pos-in-data +! r@ current-pos +! pos-in-data @ #data @ = IF
+ next-cluster @ ?dup IF read-cluster 0 pos-in-data ! THEN THEN r> ;
+: read ( adr len -- actual )
+ file-len @ min \ len cannot be greater than file size
+ dup >r BEGIN dup WHILE 2dup read dup 0= ABORT" fat-files: read failed"
+ /string ( tuck - >r + r> ) REPEAT 2drop r> ;
+: load ( adr -- len )
+ file-len @ read dup file-len @ <> ABORT" fat-files: failed loading file" ;
+
+: close free-data ;
+: open
+ do-super
+ 0 my-args find-path 0= IF close false EXIT THEN
+ file-len ! file-cluster ! 0 0 seek 0= ;
diff --git a/qemu/roms/SLOF/slof/fs/packages/filler.fs b/qemu/roms/SLOF/slof/fs/packages/filler.fs
new file mode 100644
index 000000000..bd5c17a39
--- /dev/null
+++ b/qemu/roms/SLOF/slof/fs/packages/filler.fs
@@ -0,0 +1,21 @@
+\ *****************************************************************************
+\ * Copyright (c) 2004, 2008 IBM Corporation
+\ * All rights reserved.
+\ * This program and the accompanying materials
+\ * are made available under the terms of the BSD License
+\ * which accompanies this distribution, and is available at
+\ * http://www.opensource.org/licenses/bsd-license.php
+\ *
+\ * Contributors:
+\ * IBM Corporation - initial implementation
+\ ****************************************************************************/
+
+
+s" filler" device-name
+
+: block-size s" block-size" $call-parent ;
+: seek s" seek" $call-parent ;
+: read s" read" $call-parent ;
+
+: open true ;
+: close ;
diff --git a/qemu/roms/SLOF/slof/fs/packages/iso-9660.fs b/qemu/roms/SLOF/slof/fs/packages/iso-9660.fs
new file mode 100644
index 000000000..6eda8be70
--- /dev/null
+++ b/qemu/roms/SLOF/slof/fs/packages/iso-9660.fs
@@ -0,0 +1,325 @@
+\ *****************************************************************************
+\ * Copyright (c) 2004, 2008 IBM Corporation
+\ * All rights reserved.
+\ * This program and the accompanying materials
+\ * are made available under the terms of the BSD License
+\ * which accompanies this distribution, and is available at
+\ * http://www.opensource.org/licenses/bsd-license.php
+\ *
+\ * Contributors:
+\ * IBM Corporation - initial implementation
+\ ****************************************************************************/
+
+
+s" iso-9660" device-name
+
+
+0 VALUE iso-debug-flag
+
+\ Method for code clean up - For release version of code iso-debug-flag is
+\ cleared and for debugging it is set
+
+: iso-debug-print ( str len -- ) iso-debug-flag IF type cr ELSE 2drop THEN ;
+
+
+\ --------------------------------------------------------
+\ GLOBAL VARIABLES
+\ --------------------------------------------------------
+
+
+0 VALUE path-tbl-size
+0 VALUE path-tbl-addr
+0 VALUE root-dir-size
+0 VALUE vol-size
+0 VALUE logical-blk-size
+0 VALUE path-table
+0 VALUE count
+
+
+\ INSTANCE VARIABLES
+
+
+INSTANCE VARIABLE dir-addr
+INSTANCE VARIABLE data-buff
+INSTANCE VARIABLE #data
+INSTANCE VARIABLE ptable
+INSTANCE VARIABLE file-loc
+INSTANCE VARIABLE file-size
+INSTANCE VARIABLE cur-file-offset
+INSTANCE VARIABLE self
+INSTANCE VARIABLE index
+
+
+\ --------------------------------------------------------
+\ COLON DEFINITIONS
+\ --------------------------------------------------------
+
+
+\ This method is used to seek to the required position
+\ Which calls seek of disk-label
+
+: seek ( pos.lo pos.hi -- status ) s" seek" $call-parent ;
+
+
+\ This method is used to read the contents of disk
+\ it calls read of disk-label
+
+
+ : read ( addr len -- actual ) s" read" $call-parent ;
+
+
+\ This method releases the memory used as scratch pad buffer.
+
+: free-data ( -- )
+ data-buff @ ( data-buff )
+ ?DUP IF #data @ free-mem 0 data-buff ! 0 #data ! THEN
+;
+
+
+\ This method will release the previous allocated scratch pad buffer and
+\ allocates a fresh buffer and copies the required number of bytes from the
+\ media in to it.
+
+: read-data ( offset size -- )
+ dup #data @ > IF
+ free-data dup dup ( offset size size size )
+ #data ! alloc-mem data-buff ! ( offset size )
+ THEN
+ swap xlsplit ( size pos.lo pos.hi )
+ seek -2 and ABORT" seek failed."
+ data-buff @ over read ( size actual )
+ <> ABORT" read failed."
+;
+
+
+\ This method extracts the information required from primary volume
+\ descriptor and stores the required information in the global variables
+
+: extract-vol-info ( -- )
+ 10 800 * 800 read-data
+ data-buff @ 88 + l@-be to path-tbl-size \ read path table size
+ data-buff @ 94 + l@-be to path-tbl-addr \ read big-endian path table
+ data-buff @ a2 + l@-be dir-addr ! \ gather of root directory info
+ data-buff @ 0aa + l@-be to root-dir-size \ get volume info
+ data-buff @ 54 + l@-be to vol-size \ size in blocks
+ data-buff @ 82 + l@-be to logical-blk-size
+ path-tbl-size alloc-mem dup TO path-table path-tbl-size erase
+ path-tbl-addr 800 * xlsplit seek drop
+ path-table path-tbl-size read drop \ pathtable in-system-memory copy
+;
+
+
+\ This method coverts the iso file name to user readble form
+
+: file-name ( str len -- str' len' )
+ 2dup [char] ; findchar IF
+ ( str len offset )
+ nip \ Omit the trailing ";1" revision of ISO9660 file name
+ 2dup + 1- ( str newlen endptr )
+ c@ [CHAR] . = IF
+ 1- ( str len' ) \ Remove trailing dot
+ THEN
+ THEN
+;
+
+
+\ triplicates top stack element
+
+: dup3 ( num -- num num num ) dup dup dup ;
+
+
+\ This method is used for traversing records of path table. If the
+\ file identifier length is odd 1 byte padding is done else not.
+
+: get-next-record ( rec-addr -- next-rec-offset )
+ dup3 ( rec-addr rec-addr rec-addr rec-addr )
+ self @ 1 + self ! ( rec-addr rec-addr rec-addr rec-addr )
+ c@ 1 AND IF ( rec-addr rec-addr rec-addr )
+ c@ + 9 ( rec-addr rec-addr' rec-len )
+ ELSE
+ c@ + 8 ( rec-addr rec-addr' rec-len )
+ THEN
+ + swap - ( next-rec-offset )
+;
+
+
+\ This method does search of given directory name in the path table
+\ and returns true if finds a match else false.
+
+: path-table-search ( str len -- TRUE | FALSE )
+ path-table path-tbl-size + path-table ptable @ + DO ( str len )
+ 2dup I 6 + w@-be index @ = ( str len str len )
+ -rot I 8 + I c@
+ iso-debug-flag IF
+ ." ISO: comparing path name '"
+ 4dup type ." ' with '" type ." '" cr
+ THEN
+ string=ci and IF ( str len )
+ s" Directory Matched!! " iso-debug-print ( str len )
+ self @ index ! ( str len )
+ I 2 + l@-be dir-addr ! I dup ( str len rec-addr )
+ get-next-record + path-table - ptable ! ( str len )
+ 2drop TRUE UNLOOP EXIT ( TRUE )
+ THEN
+ I get-next-record ( str len next-rec-offset )
+ +LOOP
+ 2drop
+ FALSE ( FALSE )
+ s" Invalid path / directory " iso-debug-print
+;
+
+
+\ METHOD for searching for a file with in a direcotory
+
+: search-file-dir ( str len -- TRUE | FALSE )
+ dir-addr @ 800 * dir-addr ! ( str len )
+ dir-addr @ 100 read-data ( str len )
+ data-buff @ 0e + l@-be dup >r ( str len rec-len )
+ 100 > IF ( str len )
+ s" size dir record" iso-debug-print ( str len )
+ dir-addr @ r@ read-data ( str len )
+ THEN
+ r> data-buff @ + data-buff @ DO ( str len )
+ I 19 + c@ 2 and 0= I c@ 0<> and IF ( str len )
+ 2dup ( str len str len )
+ I 21 + I 20 + c@ ( str len str len str' len' )
+ iso-debug-flag IF
+ ." ISO: comparing file name '"
+ 4dup type ." ' with '" type ." '" cr
+ THEN
+ file-name string=ci IF ( str len )
+ s" File found!" iso-debug-print ( str len )
+ I 6 + l@-be 800 * ( str len file-loc )
+ file-loc ! ( str len )
+ I 0e + l@-be file-size ! ( str len )
+ 2drop
+ TRUE ( TRUE )
+ UNLOOP
+ EXIT
+ THEN
+ THEN
+ ( str len )
+ I c@ ?dup 0= IF
+ 800 I 7ff AND -
+ iso-debug-flag IF
+ ." skipping " dup . ." bytes at end of sector" cr
+ THEN
+ THEN
+ ( str len offset )
+ +LOOP
+ 2drop
+ FALSE ( FALSE )
+ s" file not found" iso-debug-print
+;
+
+
+\ This method splits the given absolute path in to directories from root and
+\ calls search-path-table. when string reaches to state when it can not be
+\ split i.e., end of the path, calls search-file-dir is made to search for
+\ file .
+
+: search-path ( str len -- FALSE|TRUE )
+ 0 ptable !
+ 1 self !
+ 1 index !
+ dup ( str len len )
+ 0= IF
+ 3drop FALSE ( FALSE )
+ s" Empty path name " iso-debug-print EXIT ( FALSE )
+ THEN
+ OVER c@ ( str len char )
+ [char] \ = IF ( str len )
+ swap 1 + swap 1 - BEGIN ( str len )
+ [char] \ split ( str len str' len ' )
+ dup 0 = IF ( str len str' len ' )
+ 2drop search-file-dir EXIT ( TRUE | FALSE )
+ ELSE
+ 2swap path-table-search invert IF ( str' len ' )
+ 2drop FALSE EXIT ( FALSE )
+ THEN
+ THEN
+ AGAIN
+ ELSE BEGIN
+ [char] \ split dup 0 = IF ( str len str' len' )
+ 2drop search-file-dir EXIT ( TRUE | FALSE )
+ ELSE
+ 2swap path-table-search invert IF ( str' len ' )
+ 2drop FALSE EXIT ( FALSE )
+ THEN
+ THEN
+ AGAIN
+ THEN
+;
+
+
+\ this method will seek and read the file in to the given memory location
+
+0 VALUE loc
+: load ( addr -- len )
+ dup to loc ( addr )
+ file-loc @ xlsplit seek drop
+ file-size @ read ( file-size )
+ iso-debug-flag IF s" Bytes returned from read:" type dup . cr THEN
+ dup file-size @ <> ABORT" read failed!"
+;
+
+
+
+\ memory used by the file system will be freed
+
+: close ( -- )
+ free-data count 1 - dup to count 0 = IF
+ path-table path-tbl-size free-mem
+ 0 TO path-table
+ THEN
+;
+
+
+\ open method of the file system
+
+: open ( -- TRUE | FALSE )
+ 0 data-buff !
+ 0 #data !
+ 0 ptable !
+ 0 file-loc !
+ 0 file-size !
+ 0 cur-file-offset !
+ 1 self !
+ 1 index !
+ count 0 = IF
+ s" extract-vol-info called " iso-debug-print
+ extract-vol-info
+ THEN
+ count 1 + to count
+ my-args search-path IF
+ file-loc @ xlsplit seek drop
+ TRUE ( TRUE )
+ ELSE
+ close
+ FALSE ( FALSE )
+ THEN
+ 0 cur-file-offset !
+ s" opened ISO9660 package" iso-debug-print
+;
+
+
+\ public seek method
+
+: seek ( pos.lo pos.hi -- status )
+ lxjoin dup cur-file-offset ! ( offset )
+ file-loc @ + xlsplit ( pos.lo pos.hi )
+ s" seek" $call-parent ( status )
+;
+
+
+\ public read method
+
+ : read ( addr len -- actual )
+ file-size @ cur-file-offset @ - ( addr len remainder-of-file )
+ min ( addr len|remainder-of-file )
+ s" read" $call-parent ( actual )
+ dup cur-file-offset @ + cur-file-offset ! ( actual )
+ cur-file-offset @ ( offset actual )
+ xlsplit seek drop ( actual )
+;
+
diff --git a/qemu/roms/SLOF/slof/fs/packages/obp-tftp.fs b/qemu/roms/SLOF/slof/fs/packages/obp-tftp.fs
new file mode 100644
index 000000000..89143a669
--- /dev/null
+++ b/qemu/roms/SLOF/slof/fs/packages/obp-tftp.fs
@@ -0,0 +1,71 @@
+\ *****************************************************************************
+\ * Copyright (c) 2004, 2008 IBM Corporation
+\ * All rights reserved.
+\ * This program and the accompanying materials
+\ * are made available under the terms of the BSD License
+\ * which accompanies this distribution, and is available at
+\ * http://www.opensource.org/licenses/bsd-license.php
+\ *
+\ * Contributors:
+\ * IBM Corporation - initial implementation
+\ ****************************************************************************/
+
+s" obp-tftp" device-name
+
+INSTANCE VARIABLE ciregs-buffer
+
+: open ( -- okay? )
+ ciregs-size alloc-mem ciregs-buffer !
+ true
+;
+
+: load ( addr -- size )
+
+ \ Save old client interface register
+ ciregs ciregs-buffer @ ciregs-size move
+
+ s" bootargs" get-chosen 0= IF 0 0 THEN >r >r
+ s" bootpath" get-chosen 0= IF 0 0 THEN >r >r
+
+ \ Set bootpath to current device
+ my-parent ihandle>phandle node>path encode-string
+ s" bootpath" set-chosen
+
+ \ Generate arg string for snk like
+ \ "netboot load-addr length filename"
+ (u.) s" netboot " 2swap $cat s" 60000000 " $cat
+
+ \ Allocate 1720 bytes to store the BOOTP-REPLY packet
+ 6B8 alloc-mem dup >r (u.) $cat s" " $cat
+ huge-tftp-load @ IF s" 1 " ELSE s" 0 " THEN $cat
+ \ Add desired TFTP-Blocksize as additional argument
+ s" 1432 " $cat
+ \ Add OBP-TFTP Bootstring argument, e.g. "10.128.0.1,bootrom.bin,10.128.40.1"
+ my-args $cat
+
+ \ Call SNK netboot loadr
+ (client-exec) dup 0< IF drop 0 THEN
+
+ \ Restore to old client interface register
+ ciregs-buffer @ ciregs ciregs-size move
+
+ \ Recover buffer address of BOOTP-REPLY packet
+ r>
+
+ r> r> over IF s" bootpath" set-chosen ELSE 2drop THEN
+ r> r> over IF s" bootargs" set-chosen ELSE 2drop THEN
+
+ \ Store BOOTP-REPLY packet as property
+ dup 6B8 encode-bytes s" bootp-response" s" /chosen" find-node set-property
+
+ \ free buffer
+ 6B8 free-mem
+;
+
+: close ( -- )
+ ciregs-buffer @ ciregs-size free-mem
+;
+
+: ping ( -- )
+ s" ping " my-args $cat (client-exec)
+;
diff --git a/qemu/roms/SLOF/slof/fs/packages/rom-files.fs b/qemu/roms/SLOF/slof/fs/packages/rom-files.fs
new file mode 100644
index 000000000..418cf4e05
--- /dev/null
+++ b/qemu/roms/SLOF/slof/fs/packages/rom-files.fs
@@ -0,0 +1,85 @@
+\ *****************************************************************************
+\ * Copyright (c) 2004, 2008 IBM Corporation
+\ * All rights reserved.
+\ * This program and the accompanying materials
+\ * are made available under the terms of the BSD License
+\ * which accompanies this distribution, and is available at
+\ * http://www.opensource.org/licenses/bsd-license.php
+\ *
+\ * Contributors:
+\ * IBM Corporation - initial implementation
+\ ****************************************************************************/
+
+
+\ package which adds support to read the romfs
+\ this package is somehow limited as the maximum supported length
+\ for a file name is hardcoded to 0x100
+
+s" rom-files" device-name
+
+INSTANCE VARIABLE length
+INSTANCE VARIABLE next-file
+INSTANCE VARIABLE buffer
+INSTANCE VARIABLE buffer-size
+INSTANCE VARIABLE file
+INSTANCE VARIABLE file-size
+INSTANCE VARIABLE found
+
+: open true
+ 100 dup buffer-size ! alloc-mem buffer ! false found ! ;
+: close buffer @ buffer-size @ free-mem ;
+
+: read ( addr len -- actual ) s" read" $call-parent ;
+
+: seek ( lo hi -- status ) s" seek" $call-parent ;
+
+: .read-file-name ( offset -- str len )
+ \ move to the file name offset
+ 0 seek drop
+ \ read <buffer-size> bytes from that address
+ buffer @ buffer-size @ read drop
+ \ write a 0 to make sure it is a 0 terminated string
+ buffer-size @ 1 - buffer @ + 0 swap c!
+ buffer @ zcount ;
+
+: .print-info ( offset -- )
+ dup 2 spaces 6 0.r 2 spaces dup
+ 8 + 0 seek drop length 8 read drop
+ 6 length @ swap 0.r 2 spaces
+ 20 + .read-file-name type cr ;
+
+: .list-header cr
+ s" --offset---size-----file-name----" type cr ;
+
+: list
+ .list-header
+ 0 0 BEGIN + dup
+ .print-info dup 0 seek drop
+ next-file 8 read drop next-file @
+ dup 0= UNTIL 2drop ;
+
+: (find-file) ( name len -- offset | -1 )
+ 0 0 seek drop false found !
+ file-size ! file ! 0 0 BEGIN + dup
+ 20 + .read-file-name file @ file-size @
+ str= IF true found ! THEN
+ dup 0 seek drop
+ next-file 8 read drop next-file @
+ dup 0= found @ or UNTIL drop found @ 0=
+ IF drop -1 THEN ;
+
+: load ( addr -- size )
+ my-parent instance>args 2@ [char] \ left-parse-string 2drop
+ (find-file) dup -1 = IF 2drop 0 ELSE
+ \ got to the beginning
+ 0 0 seek drop
+ \ read the file size
+ dup 8 + 0 seek drop
+ here 8 read drop here @ ( dest-addr offset file-size )
+ \ read data start offset
+ over 18 + 0 seek drop
+ here 8 read drop here @ ( dest-addr offset file-size data-offset )
+ rot + 0 seek drop ( dest-addr file-size )
+ read
+ THEN
+;
diff --git a/qemu/roms/SLOF/slof/fs/packages/sms.fs b/qemu/roms/SLOF/slof/fs/packages/sms.fs
new file mode 100644
index 000000000..d8c672f72
--- /dev/null
+++ b/qemu/roms/SLOF/slof/fs/packages/sms.fs
@@ -0,0 +1,29 @@
+\ *****************************************************************************
+\ * Copyright (c) 2004, 2008 IBM Corporation
+\ * All rights reserved.
+\ * This program and the accompanying materials
+\ * are made available under the terms of the BSD License
+\ * which accompanies this distribution, and is available at
+\ * http://www.opensource.org/licenses/bsd-license.php
+\ *
+\ * Contributors:
+\ * IBM Corporation - initial implementation
+\ ****************************************************************************/
+
+
+s" /packages" find-device
+
+new-device
+ s" sms" device-name
+
+ : open true ;
+
+ : close ;
+
+ \ The rest of methods is loaded dynamically from the romfs
+ \ on a first call to sms-start
+
+finish-device
+
+device-end \ leave /packages
+
diff --git a/qemu/roms/SLOF/slof/fs/pci-bridge.fs b/qemu/roms/SLOF/slof/fs/pci-bridge.fs
new file mode 100644
index 000000000..e6af7b65c
--- /dev/null
+++ b/qemu/roms/SLOF/slof/fs/pci-bridge.fs
@@ -0,0 +1,65 @@
+\ *****************************************************************************
+\ * Copyright (c) 2004, 2008 IBM Corporation
+\ * All rights reserved.
+\ * This program and the accompanying materials
+\ * are made available under the terms of the BSD License
+\ * which accompanies this distribution, and is available at
+\ * http://www.opensource.org/licenses/bsd-license.php
+\ *
+\ * Contributors:
+\ * IBM Corporation - initial implementation
+\ ****************************************************************************/
+
+\ get the PUID from the node above
+get-node CONSTANT my-phandle
+s" my-puid" my-phandle parent $call-static CONSTANT my-puid
+
+\ Save the bus number provided by this bridge
+pci-bus-number 1+ CONSTANT my-bus
+
+s" pci-config-bridge.fs" included
+s" dma-function.fs" included
+
+\ generate the rom-fs filename from the vendor and device ID "pci-bridge_VENDORID_DEVICEID.fs"
+: filename ( -- str len )
+ s" pci-bridge_"
+ my-space pci-vendor@ 4 int2str $cat
+ s" _" $cat
+ my-space pci-device@ 4 int2str $cat
+ s" .fs" $cat
+;
+
+\ Set up the Bridge with either default or special settings
+: setup ( -- )
+ \ is there special handling for this device, given vendor and device id?
+ filename romfs-lookup ?dup
+ IF
+ \ give it a special treatment
+ evaluate
+ ELSE
+ \ no special handling for this device, attempt autoconfiguration
+ my-space pci-class-name type 2a emit cr
+ my-space pci-bridge-generic-setup
+ my-space pci-reset-2nd
+ THEN
+;
+
+\ Disable Bus Master, Memory Space and I/O Space for
+\ this device and so for the scanning for the devices behind
+pci-device-disable
+
+\ Enalbe #PERR and #SERR reporting
+pci-error-enable
+
+\ Print out device information
+my-space 42 pci-out \ config-addr ascii('B')
+
+\ and set up the bridge
+setup
+
+\ And enable Bus Master IO and MEM access again.
+\ we need that on bridges so that the devices behind
+\ can set their state on their own.
+pci-master-enable
+pci-mem-enable
+pci-io-enable
diff --git a/qemu/roms/SLOF/slof/fs/pci-class-code-names.fs b/qemu/roms/SLOF/slof/fs/pci-class-code-names.fs
new file mode 100644
index 000000000..f3a49454d
--- /dev/null
+++ b/qemu/roms/SLOF/slof/fs/pci-class-code-names.fs
@@ -0,0 +1,264 @@
+\ *****************************************************************************
+\ * Copyright (c) 2004, 2008 IBM Corporation
+\ * All rights reserved.
+\ * This program and the accompanying materials
+\ * are made available under the terms of the BSD License
+\ * which accompanies this distribution, and is available at
+\ * http://www.opensource.org/licenses/bsd-license.php
+\ *
+\ * Contributors:
+\ * IBM Corporation - initial implementation
+\ ****************************************************************************/
+
+: pci-class-name-00 ( addr -- str len )
+ pci-class@ 8 rshift FF and CASE
+ 01 OF s" display" ENDOF
+ dup OF s" unknown-legacy-device" ENDOF
+ ENDCASE
+;
+
+: pci-class-name-01 ( addr -- str len )
+ pci-class@ 8 rshift FF and CASE
+ 00 OF s" scsi" ENDOF
+ 01 OF s" ide" ENDOF
+ 02 OF s" fdc" ENDOF
+ 03 OF s" ipi" ENDOF
+ 04 OF s" raid" ENDOF
+ 05 OF s" ata" ENDOF
+ 06 OF s" sata" ENDOF
+ 07 OF s" sas" ENDOF
+ dup OF s" mass-storage" ENDOF
+ ENDCASE
+;
+
+: pci-class-name-02 ( addr -- str len )
+ pci-class@ 8 rshift FF and CASE
+ 00 OF s" ethernet" ENDOF
+ 01 OF s" token-ring" ENDOF
+ 02 OF s" fddi" ENDOF
+ 03 OF s" atm" ENDOF
+ 04 OF s" isdn" ENDOF
+ 05 OF s" worldfip" ENDOF
+ 05 OF s" picmg" ENDOF
+ dup OF s" network" ENDOF
+ ENDCASE
+;
+
+: pci-class-name-03 ( addr -- str len )
+ pci-class@ FFFF and CASE
+ 0000 OF s" vga" ENDOF
+ 0001 OF s" 8514-compatible" ENDOF
+ 0100 OF s" xga" ENDOF
+ 0200 OF s" 3d-controller" ENDOF
+ dup OF s" display" ENDOF
+ ENDCASE
+;
+
+: pci-class-name-04 ( addr -- str len )
+ pci-class@ 8 rshift FF and CASE
+ 00 OF s" video" ENDOF
+ 01 OF s" sound" ENDOF
+ 02 OF s" telephony" ENDOF
+ dup OF s" multimedia-device" ENDOF
+ ENDCASE
+;
+
+: pci-class-name-05 ( addr -- str len )
+ pci-class@ 8 rshift FF and CASE
+ 00 OF s" memory" ENDOF
+ 01 OF s" flash" ENDOF
+ dup OF s" memory-controller" ENDOF
+ ENDCASE
+;
+
+: pci-class-name-06 ( addr -- str len )
+ pci-class@ 8 rshift FF and CASE
+ 00 OF s" host" ENDOF
+ 01 OF s" isa" ENDOF
+ 02 OF s" eisa" ENDOF
+ 03 OF s" mca" ENDOF
+ 04 OF s" pci" ENDOF
+ 05 OF s" pcmcia" ENDOF
+ 06 OF s" nubus" ENDOF
+ 07 OF s" cardbus" ENDOF
+ 08 OF s" raceway" ENDOF
+ 09 OF s" semi-transparent-pci" ENDOF
+ 0A OF s" infiniband" ENDOF
+ dup OF s" unkown-bridge" ENDOF
+ ENDCASE
+;
+
+: pci-class-name-07 ( addr -- str len )
+ pci-class@ FFFF and CASE
+ 0000 OF s" serial" ENDOF
+ 0001 OF s" 16450-serial" ENDOF
+ 0002 OF s" 16550-serial" ENDOF
+ 0003 OF s" 16650-serial" ENDOF
+ 0004 OF s" 16750-serial" ENDOF
+ 0005 OF s" 16850-serial" ENDOF
+ 0006 OF s" 16950-serial" ENDOF
+ 0100 OF s" parallel" ENDOF
+ 0101 OF s" bi-directional-parallel" ENDOF
+ 0102 OF s" ecp-1.x-parallel" ENDOF
+ 0103 OF s" ieee1284-controller" ENDOF
+ 01FE OF s" ieee1284-device" ENDOF
+ 0200 OF s" multiport-serial" ENDOF
+ 0300 OF s" modem" ENDOF
+ 0301 OF s" 16450-modem" ENDOF
+ 0302 OF s" 16550-modem" ENDOF
+ 0303 OF s" 16650-modem" ENDOF
+ 0304 OF s" 16750-modem" ENDOF
+ 0400 OF s" gpib" ENDOF
+ 0500 OF s" smart-card" ENDOF
+ dup OF s" communication-controller" ENDOF
+ ENDCASE
+;
+
+
+: pci-class-name-08 ( addr -- str len )
+ pci-class@ FFFF and CASE
+ 0000 OF s" interrupt-controller" ENDOF
+ 0001 OF s" isa-pic" ENDOF
+ 0002 OF s" eisa-pic" ENDOF
+ 0010 OF s" io-apic" ENDOF
+ 0020 OF s" iox-apic" ENDOF
+ 0100 OF s" dma-controller" ENDOF
+ 0101 OF s" isa-dma" ENDOF
+ 0102 OF s" eisa-dma" ENDOF
+ 0200 OF s" timer" ENDOF
+ 0201 OF s" isa-system-timer" ENDOF
+ 0202 OF s" eisa-system-timer" ENDOF
+ 0300 OF s" rtc" ENDOF
+ 0301 OF s" isa-rtc" ENDOF
+ 0400 OF s" hot-plug-controller" ENDOF
+ 0500 OF s" sd-host-conrtoller" ENDOF
+ dup OF s" system-periphal" ENDOF
+ ENDCASE
+;
+
+: pci-class-name-09 ( addr -- str len )
+ pci-class@ 8 rshift FF and CASE
+ 00 OF s" keyboard" ENDOF
+ 01 OF s" pen" ENDOF
+ 02 OF s" mouse" ENDOF
+ 03 OF s" scanner" ENDOF
+ 04 OF s" gameport" ENDOF
+ dup OF s" input-controller" ENDOF
+ ENDCASE
+;
+
+: pci-class-name-0A ( addr -- str len )
+ pci-class@ 8 rshift FF and CASE
+ 00 OF s" dock" ENDOF
+ dup OF s" docking-station" ENDOF
+ ENDCASE
+;
+
+: pci-class-name-0B ( addr -- str len )
+ pci-class@ 8 rshift FF and CASE
+ 00 OF s" 386" ENDOF
+ 01 OF s" 486" ENDOF
+ 02 OF s" pentium" ENDOF
+ 10 OF s" alpha" ENDOF
+ 20 OF s" powerpc" ENDOF
+ 30 OF s" mips" ENDOF
+ 40 OF s" co-processor" ENDOF
+ dup OF s" cpu" ENDOF
+ ENDCASE
+;
+
+: pci-class-name-0C ( addr -- str len )
+ pci-class@ FFFF and CASE
+ 0000 OF s" firewire" ENDOF
+ 0100 OF s" access-bus" ENDOF
+ 0200 OF s" ssa" ENDOF
+ 0300 OF s" usb-uhci" ENDOF
+ 0310 OF s" usb-ohci" ENDOF
+ 0320 OF s" usb-ehci" ENDOF
+ 0330 OF s" usb-xhci" ENDOF
+ 0380 OF s" usb" ENDOF
+ 03FE OF s" usb-device" ENDOF
+ 0400 OF s" fibre-channel" ENDOF
+ 0500 OF s" smb" ENDOF
+ 0600 OF s" infiniband" ENDOF
+ 0700 OF s" ipmi-smic" ENDOF
+ 0701 OF s" ipmi-kbrd" ENDOF
+ 0702 OF s" ipmi-bltr" ENDOF
+ 0800 OF s" sercos" ENDOF
+ 0900 OF s" canbus" ENDOF
+ dup OF s" serial-bus" ENDOF
+ ENDCASE
+;
+
+: pci-class-name-0D ( addr -- str len )
+ pci-class@ 8 rshift FF and CASE
+ 00 OF s" irda" ENDOF
+ 01 OF s" consumer-ir" ENDOF
+ 10 OF s" rf-controller" ENDOF
+ 11 OF s" bluetooth" ENDOF
+ 12 OF s" broadband" ENDOF
+ 20 OF s" enet-802.11a" ENDOF
+ 21 OF s" enet-802.11b" ENDOF
+ dup OF s" wireless-controller" ENDOF
+ ENDCASE
+;
+
+
+: pci-class-name-0E ( addr -- str len )
+ pci-class@ 8 rshift FF and CASE
+ dup OF s" intelligent-io" ENDOF
+ ENDCASE
+;
+
+: pci-class-name-0F ( addr -- str len )
+ pci-class@ 8 rshift FF and CASE
+ 01 OF s" satelite-tv" ENDOF
+ 02 OF s" satelite-audio" ENDOF
+ 03 OF s" satelite-voice" ENDOF
+ 04 OF s" satelite-data" ENDOF
+ dup OF s" satelite-devoce" ENDOF
+ ENDCASE
+;
+
+: pci-class-name-10 ( addr -- str len )
+ pci-class@ 8 rshift FF and CASE
+ 00 OF s" network-encryption" ENDOF
+ 01 OF s" entertainment-encryption" ENDOF
+ dup OF s" encryption" ENDOF
+ ENDCASE
+;
+
+: pci-class-name-11 ( addr -- str len )
+ pci-class@ 8 rshift FF and CASE
+ 00 OF s" dpio" ENDOF
+ 01 OF s" counter" ENDOF
+ 10 OF s" measurement" ENDOF
+ 20 OF s" managment-card" ENDOF
+ dup OF s" data-processing-controller" ENDOF
+ ENDCASE
+;
+
+\ create a string holding the predefined Class-Code-Names
+: pci-class-name ( addr -- str len )
+ dup pci-class@ 10 rshift CASE
+ 00 OF pci-class-name-00 ENDOF
+ 01 OF pci-class-name-01 ENDOF
+ 02 OF pci-class-name-02 ENDOF
+ 03 OF pci-class-name-03 ENDOF
+ 04 OF pci-class-name-04 ENDOF
+ 05 OF pci-class-name-05 ENDOF
+ 06 OF pci-class-name-06 ENDOF
+ 07 OF pci-class-name-07 ENDOF
+ 08 OF pci-class-name-08 ENDOF
+ 09 OF pci-class-name-09 ENDOF
+ 0A OF pci-class-name-0A ENDOF
+ 0B OF pci-class-name-0B ENDOF
+ 0C OF pci-class-name-0C ENDOF
+ 0C OF pci-class-name-0D ENDOF
+ 0C OF pci-class-name-0E ENDOF
+ 0C OF pci-class-name-0F ENDOF
+ 0C OF pci-class-name-10 ENDOF
+ 0C OF pci-class-name-11 ENDOF
+ dup OF drop s" unknown" ENDOF
+ ENDCASE
+;
diff --git a/qemu/roms/SLOF/slof/fs/pci-config-bridge.fs b/qemu/roms/SLOF/slof/fs/pci-config-bridge.fs
new file mode 100644
index 000000000..689325318
--- /dev/null
+++ b/qemu/roms/SLOF/slof/fs/pci-config-bridge.fs
@@ -0,0 +1,111 @@
+\ *****************************************************************************
+\ * Copyright (c) 2004, 2011 IBM Corporation
+\ * All rights reserved.
+\ * This program and the accompanying materials
+\ * are made available under the terms of the BSD License
+\ * which accompanies this distribution, and is available at
+\ * http://www.opensource.org/licenses/bsd-license.php
+\ *
+\ * Contributors:
+\ * IBM Corporation - initial implementation
+\ ****************************************************************************/
+
+\ Generic config space access function - xt is execution token of rtas-config-xx
+: config-xt ( config-addr xt -- data )
+ puid >r \ Safe puid
+ my-puid TO puid \ Set my-puid
+ swap dup ffff00 AND 0= IF \ Has bus-device-function been specified?
+ my-space OR \ No: use my-space instead
+ THEN
+ swap execute \ Execute the rtas-config-xx function
+ r> TO puid \ Restore previous puid
+;
+
+\ define the config reads
+: config-b@ ( config-addr -- data ) ['] rtas-config-b@ config-xt ;
+: config-w@ ( config-addr -- data ) ['] rtas-config-w@ config-xt ;
+: config-l@ ( config-addr -- data ) ['] rtas-config-l@ config-xt ;
+
+\ define the config writes
+: config-b! ( data config-addr -- ) ['] rtas-config-b! config-xt ;
+: config-w! ( data config-addr -- ) ['] rtas-config-w! config-xt ;
+: config-l! ( data config-addr -- ) ['] rtas-config-l! config-xt ;
+
+\ for Debug purposes: dumps the whole config space
+: config-dump puid >r my-puid TO puid my-space pci-dump r> TO puid ;
+
+\ needed to find the right path in the device tree
+: decode-unit ( addr len -- phys.lo ... phys.hi )
+ 2 hex-decode-unit \ decode string
+ B lshift swap \ shift the devicenumber to the right spot
+ 8 lshift or \ add the functionnumber
+ my-bus 10 lshift or \ add the busnumber
+ 0 0 rot \ make phys.lo = 0 = phys.mid
+;
+
+\ needed to have the right unit address in the device tree listing
+\ phys.lo=phys.mid=0 , phys.hi=config-address
+: encode-unit ( phys.lo ... phys.hi -- unit-str unit-len )
+ nip nip \ forget the both zeros
+ dup 8 rshift 7 and swap \ calc Functionnumber
+ B rshift 1F and \ calc Devicenumber
+ over IF \ IF Function!=0
+ 2 hex-encode-unit \ | create string with DevNum,FnNum
+ ELSE \ ELSE
+ nip 1 hex-encode-unit \ | create string with only DevNum
+ THEN \ FI
+;
+
+: map-in ( phys.lo phys.mid phys.hi size -- virt )
+ \ ." map-in called: " .s cr
+ \ Ignore the size, phys.lo and phys.mid, get BAR from config space
+ drop nip nip ( phys.hi )
+ \ Sanity check whether config address is in expected range:
+ dup FF AND dup 10 28 WITHIN NOT swap 30 <> AND IF
+ cr ." phys.hi = " . cr
+ ABORT" map-in with illegal config space address"
+ THEN
+ 00FFFFFF AND \ Need only bus-dev-fn+register bits
+ dup config-l@ ( phys.hi' bar.lo )
+ dup 7 AND 4 = IF \ Is it a 64-bit BAR?
+ swap 4 + config-l@ lxjoin \ Add upper part of 64-bit BAR
+ ELSE
+ nip
+ THEN
+ F NOT AND \ Clear indicator bits
+ \ TODO: Use translate-address here!
+;
+
+: map-out ( virt size -- )
+ \ ." map-out called: " .s cr
+ 2drop
+;
+
+: dma-alloc ( ... size -- virt )
+ \ ." dma-alloc called: " .s cr
+ alloc-mem
+;
+
+: dma-free ( virt size -- )
+ \ ." dma-free called: " .s cr
+ free-mem
+;
+
+: dma-map-in ( ... virt size cacheable? -- devaddr )
+ \ ." dma-map-in called: " .s cr
+ 2drop
+;
+
+: dma-map-out ( virt devaddr size -- )
+ \ ." dma-map-out called: " .s cr
+ 2drop drop
+;
+
+: dma-sync ( virt devaddr size -- )
+ \ XXX should we add at least a memory barrier here?
+ \ ." dma-sync called: " .s cr
+ 2drop drop
+;
+
+: open true ;
+: close ;
diff --git a/qemu/roms/SLOF/slof/fs/pci-device.fs b/qemu/roms/SLOF/slof/fs/pci-device.fs
new file mode 100644
index 000000000..7b177585a
--- /dev/null
+++ b/qemu/roms/SLOF/slof/fs/pci-device.fs
@@ -0,0 +1,105 @@
+\ *****************************************************************************
+\ * Copyright (c) 2004, 2008 IBM Corporation
+\ * All rights reserved.
+\ * This program and the accompanying materials
+\ * are made available under the terms of the BSD License
+\ * which accompanies this distribution, and is available at
+\ * http://www.opensource.org/licenses/bsd-license.php
+\ *
+\ * Contributors:
+\ * IBM Corporation - initial implementation
+\ ****************************************************************************/
+
+get-node CONSTANT my-phandle
+
+\ get the PUID from the node above
+s" my-puid" my-phandle parent $call-static CONSTANT my-puid
+
+\ define the config reads
+: config-b@ puid >r my-puid TO puid my-space + rtas-config-b@ r> TO puid ;
+: config-w@ puid >r my-puid TO puid my-space + rtas-config-w@ r> TO puid ;
+: config-l@ puid >r my-puid TO puid my-space + rtas-config-l@ r> TO puid ;
+
+\ define the config writes
+: config-b! puid >r my-puid TO puid my-space + rtas-config-b! r> TO puid ;
+: config-w! puid >r my-puid TO puid my-space + rtas-config-w! r> TO puid ;
+: config-l! puid >r my-puid TO puid my-space + rtas-config-l! r> TO puid ;
+
+\ for Debug purposes: dumps the whole config space
+: config-dump puid >r my-puid TO puid my-space pci-dump r> TO puid ;
+
+\ prepare the device for subsequent use
+\ this word should be overloaded by the device file (if present)
+\ the device file can call this file before implementing
+\ its own open functionality
+: open
+ puid >r \ save the old puid
+ my-puid TO puid \ set up the puid to the devices Hostbridge
+ pci-master-enable \ And enable Bus Master, IO and MEM access again.
+ pci-mem-enable \ enable mem access
+ pci-io-enable \ enable io access
+ r> TO puid \ restore puid
+ true
+;
+
+\ close the previously opened device
+\ this word should be overloaded by the device file (if present)
+\ the device file can call this file after its implementation
+\ of own close functionality
+: close
+ puid >r \ save the old puid
+ my-puid TO puid \ set up the puid
+ pci-device-disable \ and disable the device
+ r> TO puid \ restore puid
+;
+
+s" dma-function.fs" included
+
+\ generate the rom-fs filename from the vendor and device ID "pci-device_VENDORID_DEVICEID.fs"
+: devicefile ( -- str len )
+ s" pci-device_"
+ my-space pci-vendor@ 4 int2str $cat
+ s" _" $cat
+ my-space pci-device@ 4 int2str $cat
+ s" .fs" $cat
+;
+
+\ generate the rom-fs filename from the base-class id "pci-class_BASECLASS.fs"
+: classfile ( -- str len )
+ s" pci-class_"
+ my-space pci-class@ 10 rshift 2 int2str $cat
+ s" .fs" $cat
+;
+
+\ Set up the device with either default or special settings
+: setup ( -- )
+ \ is there special handling for this device, given vendor and device id?
+ devicefile romfs-lookup ?dup
+ IF
+ \ give it a special treatment
+ evaluate
+ ELSE
+ classfile romfs-lookup ?dup
+ IF
+ \ give it a pci-class related treatment
+ evaluate
+ ELSE
+ \ no special handling for this device, attempt autoconfiguration
+ my-space pci-class-name type 2a emit cr
+ my-space pci-device-generic-setup
+ THEN
+ THEN
+;
+
+\ Disable Bus Master, Memory Space and I/O Space for this device
+\ if Bus Master function is needed it should be enabled/disabled by open/close in the device driver code
+pci-device-disable
+
+\ Enalbe #PERR and #SERR reporting
+pci-error-enable
+
+\ Print out device information
+my-space 44 pci-out \ config-addr ascii('D')
+
+\ and set up the device
+setup
diff --git a/qemu/roms/SLOF/slof/fs/pci-helper.fs b/qemu/roms/SLOF/slof/fs/pci-helper.fs
new file mode 100644
index 000000000..a4f69f1f3
--- /dev/null
+++ b/qemu/roms/SLOF/slof/fs/pci-helper.fs
@@ -0,0 +1,195 @@
+\ *****************************************************************************
+\ * Copyright (c) 2004, 2011 IBM Corporation
+\ * All rights reserved.
+\ * This program and the accompanying materials
+\ * are made available under the terms of the BSD License
+\ * which accompanies this distribution, and is available at
+\ * http://www.opensource.org/licenses/bsd-license.php
+\ *
+\ * Contributors:
+\ * IBM Corporation - initial implementation
+\ ****************************************************************************/
+
+\ ----------------------------------------------------------
+\ **************** PCI Helper functions *******************
+\ ----------------------------------------------------------
+
+\ convert an integer to string of len digits
+: int2str ( int len -- str len ) swap s>d rot <# 0 ?DO # LOOP #> ;
+
+\ convert addr to busnr
+: pci-addr2bus ( addr -- busnr ) 10 rshift FF and ;
+
+\ convert addr to devnr
+: pci-addr2dev ( addr -- dev ) B rshift 1F and ;
+
+\ convert addr to functionnumber
+: pci-addr2fn ( addr -- dev ) 8 rshift 7 and ;
+
+\ convert busnr devnr to addr
+: pci-bus2addr ( busnr devnr -- addr ) B lshift swap 10 lshift + ;
+
+\ print out a pci config addr
+: pci-addr-out ( addr -- ) dup pci-addr2bus 2 0.r space FFFF and 4 0.r ;
+
+\ Dump out the whole configspace
+: pci-dump ( addr -- )
+ 10 0 DO
+ dup
+ cr i 4 * +
+ dup pci-addr-out space
+ rtas-config-l@ 8 0.r
+ LOOP
+ drop cr
+;
+
+
+\ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+\ the following functions use l@ to fetch the data,
+\ that's because the some pcie cores have probs with w@
+\ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+\ read Vendor ID
+: pci-vendor@ ( addr -- id ) rtas-config-l@ FFFF and ;
+
+\ read Device ID
+: pci-device@ ( addr -- id ) rtas-config-l@ 10 rshift ;
+
+\ read Status
+: pci-status@ ( addr -- status ) 4 + rtas-config-l@ 10 rshift ;
+
+\ read Revision ID
+: pci-revision@ ( addr -- id ) 8 + rtas-config-b@ ;
+
+\ read Class Code
+: pci-class@ ( addr -- class ) 8 + rtas-config-l@ 8 rshift ;
+
+\ read Cache Line Size
+: pci-cache@ ( addr -- size ) C + rtas-config-b@ ;
+
+\ read Header Type
+: pci-htype@ ( addr -- type ) E + rtas-config-b@ ;
+
+\ read Sub Vendor ID
+: pci-sub-vendor@ ( addr -- sub-id ) 2C + rtas-config-l@ FFFF and ;
+
+\ read Sub Device ID
+: pci-sub-device@ ( addr -- sub-id ) 2C + rtas-config-l@ 10 rshift FFFF and ;
+
+\ read Interrupt Pin
+: pci-interrupt@ ( addr -- interrupt ) 3D + rtas-config-b@ ;
+
+\ read Minimum Grant
+: pci-min-grant@ ( addr -- min-gnt ) 3E + rtas-config-b@ ;
+
+\ read Maximum Latency
+: pci-max-lat@ ( addr -- max-lat ) 3F + rtas-config-b@ ;
+
+\ Check if Capabilities are valid
+: pci-capabilities? ( addr -- 0|1 ) pci-status@ 4 rshift 1 and ;
+
+\ fetch the offset of the next capability
+: pci-cap-next ( cap-addr -- next-cap-off ) rtas-config-b@ FC and ;
+
+\ calc the address of the next capability
+: pci-cap-next-addr ( cap-addr -- next-cap-addr ) 1+ dup pci-cap-next dup IF swap -100 and + ELSE nip THEN ;
+
+
+\ Dump out all capabilities
+: pci-cap-dump ( addr -- )
+ cr
+ dup pci-capabilities? IF
+ 33 + BEGIN
+ pci-cap-next-addr dup 0<>
+ WHILE
+ dup pci-addr-out s" : " type
+ dup rtas-config-b@ 2 0.r cr
+ REPEAT
+ s" end found "
+ ELSE
+ s" capabilities not enabled!"
+ THEN
+ type cr drop
+;
+
+\ search the capability-list for this id
+: pci-cap-find ( addr id -- capp-addr|0 )
+ swap dup pci-capabilities? IF
+ 33 + BEGIN
+ pci-cap-next-addr dup 0<> IF
+ dup rtas-config-b@ 2 pick =
+ ELSE
+ true
+ THEN
+ UNTIL
+ nip
+ ELSE
+ 2drop 0
+ THEN
+;
+
+\ check wether this device is a pci-express device
+: pci-express? ( addr -- 0|1 ) 10 pci-cap-find 0<> ;
+
+\ check wether this device is a pci-express device
+: pci-x? ( addr -- 0|1 ) 07 pci-cap-find 0<> ;
+
+\ check wether this device has extended config space
+: pci-config-ext? ( addr -- 0|1 ) pci-express? ;
+
+
+\ Disable Bus Master, Memory Space and I/O Space for this device
+: pci-device-disable ( -- ) my-space 4 + dup rtas-config-l@ 7 invert and swap rtas-config-l! ;
+
+\ Enable Bus Master
+: pci-master-enable ( -- ) my-space 4 + dup rtas-config-l@ 4 or swap rtas-config-l! ;
+
+\ Disable Bus Master
+: pci-master-disable ( -- ) my-space 4 + dup rtas-config-l@ 4 invert and swap rtas-config-l! ;
+
+\ Enable response to mem accesses of pci device
+: pci-mem-enable ( -- ) my-space 4 + dup rtas-config-w@ 2 or swap rtas-config-w! ;
+
+\ Enable response to I/O accesses of pci-device
+: pci-io-enable ( -- ) my-space 4 + dup rtas-config-w@ 1 or swap rtas-config-w! ;
+
+\ Enable Bus Master, I/O and mem access
+: pci-enable ( -- ) my-space 4 + dup rtas-config-w@ 7 or swap rtas-config-w! ;
+
+\ Enable #PERR and #SERR errors of pci-device
+: pci-error-enable ( -- ) my-space 4 + dup rtas-config-w@ 140 or swap rtas-config-w! ;
+
+\ prints out the ScanInformation about a device
+\ char is a sign for device type e.g. D - device ; B - bridge
+: pci-out ( addr char -- )
+ 15 spaces
+ over pci-addr-out
+ s" (" type emit s" ) : " type
+ dup pci-vendor@ 4 0.r space
+ pci-device@ 4 0.r
+ 4 spaces
+;
+
+
+\ set and fetch the interrupt Pin
+: pci-irq-line@ ( addr -- irq-pin ) 3C + rtas-config-b@ ;
+: pci-irq-line! ( pin addr -- ) 3C + rtas-config-b! ;
+
+\ set and fetch primary bus number
+: pci-bus-prim! ( nr addr -- ) 18 + dup rtas-config-l@ FFFFFF00 and rot + swap rtas-config-l! ;
+: pci-bus-prim@ ( addr -- nr ) 18 + rtas-config-l@ FF and ;
+
+\ set and fetch secondary bus number
+: pci-bus-scnd! ( nr addr -- ) 18 + dup rtas-config-l@ FFFF00FF and rot 8 lshift + swap rtas-config-l! ;
+: pci-bus-scnd@ ( addr -- nr ) 18 + rtas-config-l@ 8 rshift FF and ;
+
+\ set and fetch subordinate bus number
+: pci-bus-subo! ( nr addr -- ) 18 + dup rtas-config-l@ FF00FFFF and rot 10 lshift + swap rtas-config-l! ;
+: pci-bus-subo@ ( addr -- nr ) 18 + rtas-config-l@ 10 rshift FF and ;
+
+\ set and fetch primary, secondary and subordinate bus number
+: pci-bus! ( subo scnd prim addr -- ) swap rot 8 lshift + rot 10 lshift + swap 18 + dup rtas-config-l@ FF000000 and rot + swap rtas-config-l! ;
+: pci-bus@ ( addr -- subo scnd prim ) 18 + rtas-config-l@ dup 10 rshift FF and swap dup 8 rshift FF and swap FF and ;
+
+\ Reset secondary Status
+: pci-reset-2nd ( addr -- ) 1C + dup rtas-config-l@ FFFF0000 or swap rtas-config-l! ;
diff --git a/qemu/roms/SLOF/slof/fs/pci-properties.fs b/qemu/roms/SLOF/slof/fs/pci-properties.fs
new file mode 100644
index 000000000..4f134024f
--- /dev/null
+++ b/qemu/roms/SLOF/slof/fs/pci-properties.fs
@@ -0,0 +1,668 @@
+\ *****************************************************************************
+\ * Copyright (c) 2004, 2008 IBM Corporation
+\ * All rights reserved.
+\ * This program and the accompanying materials
+\ * are made available under the terms of the BSD License
+\ * which accompanies this distribution, and is available at
+\ * http://www.opensource.org/licenses/bsd-license.php
+\ *
+\ * Contributors:
+\ * IBM Corporation - initial implementation
+\ ****************************************************************************/
+
+#include "pci-class-code-names.fs"
+
+\ read the various bar type sizes
+: pci-bar-size@ ( bar-addr -- bar-size ) -1 over rtas-config-l! rtas-config-l@ ;
+: pci-bar-size-mem@ ( bar-addr -- mem-size ) pci-bar-size@ -10 and invert 1+ FFFFFFFF and ;
+: pci-bar-size-io@ ( bar-addr -- io-size ) pci-bar-size@ -4 and invert 1+ FFFFFFFF and ;
+
+\ fetch raw bar size but keep original BAR value
+: pci-bar-size ( bar-addr -- bar-size-raw )
+ dup rtas-config-l@ swap \ fetch original Value ( bval baddr )
+ -1 over rtas-config-l! \ make BAR show size ( bval baddr )
+ dup rtas-config-l@ \ and fetch the size ( bval baddr bsize )
+ -rot rtas-config-l! \ restore Value
+;
+
+\ calc 32 bit MEM BAR size
+: pci-bar-size-mem32 ( bar-addr -- bar-size )
+ pci-bar-size \ fetch raw size
+ -10 and invert 1+ \ calc size
+ FFFFFFFF and \ keep lower 32 bits
+;
+
+\ calc 32 bit ROM BAR size
+: pci-bar-size-rom ( bar-addr -- bar-size )
+ pci-bar-size \ fetch raw size
+ FFFFF800 and invert 1+ \ calc size
+ FFFFFFFF and \ keep lower 32 bits
+;
+
+\ calc 64 bit MEM BAR size
+: pci-bar-size-mem64 ( bar-addr -- bar-size )
+ dup pci-bar-size \ fetch raw size lower 32 bits
+ swap 4 + pci-bar-size \ fetch raw size upper 32 bits
+ 20 lshift + \ and put them together
+ -10 and invert 1+ \ calc size
+;
+
+\ calc IO BAR size
+: pci-bar-size-io ( bar-addr -- bar-size )
+ pci-bar-size \ fetch raw size
+ -4 and invert 1+ \ calc size
+ FFFFFFFF and \ keep lower 32 bits
+;
+
+
+\ decode the Bar Type
+\ +----------------------------------------------------------------------------------------+
+\ | 3 2 1 0 |
+\ | +----------------------------+-+--+-+ |
+\ | MEM-BAR : | Base Address |P|TT|0| P - prefechtable ; TT - 00 : 32 Bit |
+\ | +----------------------------+-+--+-+ 10 : 64 Bit |
+\ | +-------------------------------+-+-+ |
+\ | IO-BAR : | Base Address |0|1| |
+\ | +-------------------------------+-+-+ |
+\ | That is: 0 - no encoded BarType |
+\ | 1 - IO - Bar |
+\ | 2 - Memory 32 Bit |
+\ | 3 - Memory 32 Bit prefetchable |
+\ | 4 - Memory 64 Bit |
+\ | 5 - Memory 64 Bit prefetchable |
+\ +----------------------------------------------------------------------------------------+
+: pci-bar-code@ ( bar-addr -- 0|1..4|5 )
+ rtas-config-l@ dup \ fetch the BaseAddressRegister
+ 1 and IF \ IO BAR ?
+ 2 and IF 0 ELSE 1 THEN \ only '01' is valid
+ ELSE \ Memory BAR ?
+ F and CASE
+ 0 OF 2 ENDOF \ Memory 32 Bit Non-Prefetchable
+ 8 OF 3 ENDOF \ Memory 32 Bit Prefetchable
+ 4 OF 4 ENDOF \ Memory 64 Bit Non-Prefetchable
+ C OF 5 ENDOF \ Memory 64 Bit Prefechtable
+ dup OF 0 ENDOF \ Not a valid BarType
+ ENDCASE
+ THEN
+;
+
+\ ***************************************************************************************
+\ Assigning the new Value to the BARs
+\ ***************************************************************************************
+\ align the current mem and set var to next mem
+\ align with a size of 0 returns 0 !!!
+: assign-var ( size var -- al-mem )
+ 2dup @ \ ( size var size cur-mem ) read current free mem
+ swap #aligned \ ( size var al-mem ) align the mem to the size
+ dup 2swap -rot + \ ( al-mem var new-mem ) add size to aligned mem
+ swap ! \ ( al-mem ) set variable to new mem
+;
+
+\ set bar to current free mem ( in variable ) and set variable to next free mem
+: assign-bar-value32 ( bar size var -- 4 )
+ over IF \ IF size > 0
+ assign-var \ | ( bar al-mem ) set variable to next mem
+ swap rtas-config-l! \ | ( -- ) set the bar to al-mem
+ ELSE \ ELSE
+ 2drop drop \ | clear stack
+ THEN \ FI
+ 4 \ size of the base-address-register
+;
+
+\ set bar to current free mem ( in variable ) and set variable to next free mem
+: assign-bar-value64 ( bar size var -- 8 )
+ over IF \ IF size > 0
+ assign-var \ | ( bar al-mem ) set variable to next mem
+ swap \ | ( al-mem addr ) calc config-addr of this bar
+ 2dup rtas-config-l! \ | ( al-mem addr ) set the Lower part of the bar to al-mem
+ 4 + swap 20 rshift \ | ( al-mem>>32 addr ) prepare the upper part of the al-mem
+ swap rtas-config-l! \ | ( -- ) and set the upper part of the bar
+ ELSE \ ELSE
+ 2drop drop \ | clear stack
+ THEN \ FI
+ 8 \ size of the base-address-register
+;
+
+\ Setup a prefetchable 64bit BAR and return its size
+: assign-mem64-bar ( bar-addr -- 8 )
+ dup pci-bar-size-mem64 \ fetch size
+ pci-next-mem64 @ 0 = IF \ Check if we have 64-bit memory range
+ pci-next-mem
+ ELSE
+ pci-next-mem64
+ THEN
+ assign-bar-value64 \ and set it all
+;
+
+\ Setup a prefetchable 32bit BAR and return its size
+: assign-mem32-bar ( bar-addr -- 4 )
+ dup pci-bar-size-mem32 \ fetch size
+ pci-next-mem \ var to change
+ assign-bar-value32 \ and set it all
+;
+
+\ Setup a non-prefetchable 64bit BAR and return its size
+: assign-mmio64-bar ( bar-addr -- 8 )
+ dup pci-bar-size-mem64 \ fetch size
+ pci-next-mem64 @ 0 = IF \ Check if we have 64-bit memory range
+ pci-next-mmio
+ ELSE
+ pci-next-mem64 \ for board-qemu we will use same range
+ THEN
+ assign-bar-value64 \ and set it all
+;
+
+\ Setup a non-prefetchable 32bit BAR and return its size
+: assign-mmio32-bar ( bar-addr -- 4 )
+ dup pci-bar-size-mem32 \ fetch size
+ pci-next-mmio \ var to change
+ assign-bar-value32 \ and set it all
+;
+
+\ Setup an IO-Bar and return the size of the base-address-register
+: assign-io-bar ( bar-addr -- 4 )
+ dup pci-bar-size-io \ fetch size
+ pci-next-io \ var to change
+ assign-bar-value32 \ and set it all
+;
+
+\ Setup an Expansion ROM bar
+: assign-rom-bar ( bar-addr -- )
+ dup pci-bar-size-rom \ fetch size
+ dup IF \ IF size > 0
+ over >r \ | save bar addr for enable
+ pci-next-mmio \ | var to change
+ assign-bar-value32 \ | and set it
+ drop \ | forget the BAR length
+ r@ rtas-config-l@ \ | fetch BAR
+ 1 or r> rtas-config-l! \ | and enable the ROM
+ ELSE \ ELSE
+ 2drop \ | clear stack
+ THEN
+;
+
+\ Setup the BAR due to its type and return the size of the register (4 or 8 Bytes ) used as increment for the BAR-Loop
+: assign-bar ( bar-addr -- reg-size )
+ dup pci-bar-code@ \ calc BAR type
+ dup IF \ IF >0
+ CASE \ | CASE Setup the right type
+ 1 OF assign-io-bar ENDOF \ | - set up an IO-Bar
+ 2 OF assign-mmio32-bar ENDOF \ | - set up an 32bit MMIO-Bar
+ 3 OF assign-mem32-bar ENDOF \ | - set up an 32bit MEM-Bar (prefetchable)
+ 4 OF assign-mmio64-bar ENDOF \ | - set up an 64bit MMIO-Bar
+ 5 OF assign-mem64-bar ENDOF \ | - set up an 64bit MEM-Bar (prefetchable)
+ ENDCASE \ | ESAC
+ ELSE \ ELSE
+ ABORT \ | Throw an exception
+ THEN \ FI
+;
+
+\ Setup all the bars of a pci device
+: assign-all-device-bars ( configaddr -- )
+ 28 10 DO \ BARs start at 10 and end at 27
+ dup i + \ calc config-addr of the BAR
+ assign-bar \ and set it up
+ +LOOP \ add 4 or 8 to the index and loop
+ 30 + assign-rom-bar \ set up the ROM if available
+;
+
+\ Setup all the bars of a pci device
+: assign-all-bridge-bars ( configaddr -- )
+ 18 10 DO \ BARs start at 10 and end at 17
+ dup i + \ calc config-addr of the BAR
+ assign-bar \ and set it up
+ +LOOP \ add 4 or 8 to the index and loop
+ 38 + assign-rom-bar \ set up the ROM if available
+;
+
+\ +---------------------------------------------------------------------------------------+
+\ | Numerical Representaton of a PCI address (PCI Bus Binding 2.2.1.1) |
+\ | |
+\ | 31 24 16 11 8 0 |
+\ | +--------+--------+-----+---+--------+ |
+\ | phys.hi: |npt000ss| bus | dev |fnc| reg | n - 0 relocatable |
+\ | +--------+--------+-----+---+--------+ p - 1 prefetchable |
+\ | t - 1 aliased or <1MB or <64KB |
+\ | ss - 00 Configuration Space |
+\ | 01 I/O Space |
+\ | 10 Memory Space 32bits |
+\ | 11 Memory Space 64bits |
+\ +---------------------------------------------------------------------------------------+
+
+\ ***************************************************************************************
+\ Generating the assigned-addresses property
+\ ***************************************************************************************
+\ generate assigned-addresses property for 64Bit MEM-BAR and return BAR-reg-size
+: gen-mem64-bar-prop ( prop-addr prop-len bar-addr -- prop-addr prop-len 8 )
+ dup pci-bar-size-mem64 \ fetch BAR Size ( paddr plen baddr bsize )
+ dup IF \ IF Size > 0
+ >r dup rtas-config-l@ \ | save size and fetch lower 32 bits ( paddr plen baddr val.lo R: size)
+ over 4 + rtas-config-l@ \ | fetch upper 32 bits ( paddr plen baddr val.lo val.hi R: size)
+ 20 lshift + -10 and >r \ | calc 64 bit value and save it ( paddr plen baddr R: size val )
+ 83000000 or encode-int+ \ | Encode config addr ( paddr plen R: size val )
+ r> encode-64+ \ | Encode assigned addr ( paddr plen R: size )
+ r> encode-64+ \ | Encode size ( paddr plen )
+ ELSE \ ELSE
+ 2drop \ | don't do anything
+ THEN \ FI
+ 8 \ sizeof(BAR) = 8 Bytes
+;
+
+\ generate assigned-addresses property for prefetchable 64Bit MEM-BAR and return BAR-reg-size
+: gen-pmem64-bar-prop ( prop-addr prop-len bar-addr -- prop-addr prop-len 8 )
+ dup pci-bar-size-mem64 \ fetch BAR Size ( paddr plen baddr bsize )
+ dup IF \ IF Size > 0
+ >r dup rtas-config-l@ \ | save size and fetch lower 32 bits ( paddr plen baddr val.lo R: size)
+ over 4 + rtas-config-l@ \ | fetch upper 32 bits ( paddr plen baddr val.lo val.hi R: size)
+ 20 lshift + -10 and >r \ | calc 64 bit value and save it ( paddr plen baddr R: size val )
+ C3000000 or encode-int+ \ | Encode config addr ( paddr plen R: size val )
+ r> encode-64+ \ | Encode assigned addr ( paddr plen R: size )
+ r> encode-64+ \ | Encode size ( paddr plen )
+ ELSE \ ELSE
+ 2drop \ | don't do anything
+ THEN \ FI
+ 8 \ sizeof(BAR) = 8 Bytes
+;
+
+\ generate assigned-addresses property for 32Bit MEM-BAR and return BAR-reg-size
+: gen-mem32-bar-prop ( prop-addr prop-len bar-addr -- prop-addr prop-len 4 )
+ dup pci-bar-size-mem32 \ fetch BAR Size ( paddr plen baddr bsize )
+ dup IF \ IF Size > 0
+ >r dup rtas-config-l@ \ | save size and fetch value ( paddr plen baddr val R: size)
+ -10 and >r \ | calc 32 bit value and save it ( paddr plen baddr R: size val )
+ 82000000 or encode-int+ \ | Encode config addr ( paddr plen R: size val )
+ r> encode-64+ \ | Encode assigned addr ( paddr plen R: size )
+ r> encode-64+ \ | Encode size ( paddr plen )
+ ELSE \ ELSE
+ 2drop \ | don't do anything
+ THEN \ FI
+ 4 \ sizeof(BAR) = 4 Bytes
+;
+
+\ generate assigned-addresses property for prefetchable 32Bit MEM-BAR and return BAR-reg-size
+: gen-pmem32-bar-prop ( prop-addr prop-len bar-addr -- prop-addr prop-len 4 )
+ dup pci-bar-size-mem32 \ fetch BAR Size ( paddr plen baddr bsize )
+ dup IF \ IF Size > 0
+ >r dup rtas-config-l@ \ | save size and fetch value ( paddr plen baddr val R: size)
+ -10 and >r \ | calc 32 bit value and save it ( paddr plen baddr R: size val )
+ C2000000 or encode-int+ \ | Encode config addr ( paddr plen R: size val )
+ r> encode-64+ \ | Encode assigned addr ( paddr plen R: size )
+ r> encode-64+ \ | Encode size ( paddr plen )
+ ELSE \ ELSE
+ 2drop \ | don't do anything
+ THEN \ FI
+ 4 \ sizeof(BAR) = 4 Bytes
+;
+
+\ generate assigned-addresses property for IO-BAR and return BAR-reg-size
+: gen-io-bar-prop ( prop-addr prop-len bar-addr -- prop-addr prop-len 4 )
+ dup pci-bar-size-io \ fetch BAR Size ( paddr plen baddr bsize )
+ dup IF \ IF Size > 0
+ >r dup rtas-config-l@ \ | save size and fetch value ( paddr plen baddr val R: size)
+ -4 and >r \ | calc 32 bit value and save it ( paddr plen baddr R: size val )
+ 81000000 or encode-int+ \ | Encode config addr ( paddr plen R: size val )
+ r> encode-64+ \ | Encode assigned addr ( paddr plen R: size )
+ r> encode-64+ \ | Encode size ( paddr plen )
+ ELSE \ ELSE
+ 2drop \ | don't do anything
+ THEN \ FI
+ 4 \ sizeof(BAR) = 4 Bytes
+;
+
+\ generate assigned-addresses property for ROM-BAR
+: gen-rom-bar-prop ( prop-addr prop-len bar-addr -- prop-addr prop-len )
+ dup pci-bar-size-rom \ fetch BAR Size ( paddr plen baddr bsize )
+ dup IF \ IF Size > 0
+ >r dup rtas-config-l@ \ | save size and fetch value ( paddr plen baddr val R: size)
+ FFFFF800 and >r \ | calc 32 bit value and save it ( paddr plen baddr R: size val )
+ 82000000 or encode-int+ \ | Encode config addr ( paddr plen R: size val )
+ r> encode-64+ \ | Encode assigned addr ( paddr plen R: size )
+ r> encode-64+ \ | Encode size ( paddr plen )
+ ELSE \ ELSE
+ 2drop \ | don't do anything
+ THEN \ FI
+;
+
+\ add another BAR to the assigned addresses property and return the size of the encoded register
+: pci-add-assigned-address ( prop-addr prop-len bar-addr -- prop-addr prop-len bsize )
+ dup pci-bar-code@ \ calc BAR type ( paddr plen baddr btype)
+ CASE \ CASE for the BAR types ( paddr plen baddr )
+ 0 OF drop 4 ENDOF \ - not a valid type so do nothing
+ 1 OF gen-io-bar-prop ENDOF \ - IO-BAR
+ 2 OF gen-mem32-bar-prop ENDOF \ - MEM32
+ 3 OF gen-pmem32-bar-prop ENDOF \ - MEM32 prefetchable
+ 4 OF gen-mem64-bar-prop ENDOF \ - MEM64
+ 5 OF gen-pmem64-bar-prop ENDOF \ - MEM64 prefetchable
+ ENDCASE \ ESAC ( paddr plen bsize )
+;
+
+\ generate the assigned address property for a PCI device
+: pci-device-assigned-addresses-prop ( addr -- )
+ encode-start \ provide mem for property ( addr paddr plen )
+ 2 pick 30 + gen-rom-bar-prop \ assign the rom bar
+ 28 10 DO \ we have 6 possible BARs
+ 2 pick i + \ calc BAR address ( addr paddr plen bar-addr )
+ pci-add-assigned-address \ and generate the props for the BAR
+ +LOOP \ increase Index by returned len
+ s" assigned-addresses" property drop \ and write it into the device tree
+;
+
+\ generate the assigned address property for a PCI bridge
+: pci-bridge-assigned-addresses-prop ( addr -- )
+ encode-start \ provide mem for property
+ 2 pick 38 + gen-rom-bar-prop \ assign the rom bar
+ 18 10 DO \ we have 2 possible BARs
+ 2 pick i + \ ( addr paddr plen current-addr )
+ pci-add-assigned-address \ and generate the props for the BAR
+ +LOOP \ increase Index by returned len
+ s" assigned-addresses" property drop \ and write it into the device tree
+;
+
+\ check if the range is valid and if so encode it into
+\ child.hi child.mid child.lo parent.hi parent.mid parent.lo size.hi size.lo
+\ This is needed to translate the childrens addresses
+\ We implement only 1:1 mapping for all PCI bridges
+: pci-bridge-gen-range ( paddr plen base limit type -- paddr plen )
+ >r over - \ calc size ( paddr plen base size R:type )
+ dup 0< IF \ IF Size < 0 ( paddr plen base size R:type )
+ 2drop r> drop \ | forget values ( paddr plen )
+ ELSE \ ELSE
+ 1+ swap 2swap \ | adjust stack ( size base paddr plen R:type )
+ r@ encode-int+ \ | Child type ( size base paddr plen R:type )
+ 2 pick encode-64+ \ | Child address ( size base paddr plen R:type )
+ r> encode-int+ \ | Parent type ( size base paddr plen )
+ rot encode-64+ \ | Parent address ( size paddr plen )
+ rot encode-64+ \ | Encode size ( paddr plen )
+ THEN \ FI
+;
+
+
+\ generate an mmio space to the ranges property
+: pci-bridge-gen-mmio-range ( addr prop-addr prop-len -- addr prop-addr prop-len )
+ 2 pick 20 + rtas-config-l@ \ fetch Value ( addr paddr plen val )
+ dup 0000FFF0 and 10 lshift \ calc base-address ( addr paddr plen val base )
+ swap 000FFFFF or \ calc limit-address ( addr paddr plen base limit )
+ 02000000 pci-bridge-gen-range \ and generate it ( addr paddr plen )
+;
+
+\ generate an mem space to the ranges property
+: pci-bridge-gen-mem-range ( addr prop-addr prop-len -- addr prop-addr prop-len )
+ 2 pick 24 + rtas-config-l@ \ fetch Value ( addr paddr plen val )
+ dup 000FFFFF or \ calc limit Bits 31:0 ( addr paddr plen val limit.31:0 )
+ swap 0000FFF0 and 10 lshift \ calc base Bits 31:0 ( addr paddr plen limit.31:0 base.31:0 )
+ 4 pick 28 + rtas-config-l@ \ fetch upper Basebits ( addr paddr plen limit.31:0 base.31:0 base.63:32 )
+ 20 lshift or swap \ and calc Base ( addr paddr plen base.63:0 limit.31:0 )
+ 4 pick 2C + rtas-config-l@ \ fetch upper Limitbits ( addr paddr plen base.63:0 limit.31:0 limit.63:32 )
+ 20 lshift or \ and calc Limit ( addr paddr plen base.63:0 limit.63:0 )
+ 42000000 pci-bridge-gen-range \ and generate it ( addr paddr plen )
+;
+
+\ generate an io space to the ranges property
+: pci-bridge-gen-io-range ( addr prop-addr prop-len -- addr prop-addr prop-len )
+ 2 pick 1C + rtas-config-l@ \ fetch Value ( addr paddr plen val )
+ dup 0000F000 and 00000FFF or \ calc Limit Bits 15:0 ( addr paddr plen val limit.15:0 )
+ swap 000000F0 and 8 lshift \ calc Base Bits 15:0 ( addr paddr plen limit.15:0 base.15:0 )
+ 4 pick 30 + rtas-config-l@ \ fetch upper Bits ( addr paddr plen limit.15:0 base.15:0 val )
+ dup FFFF and 10 lshift rot or \ calc Base ( addr paddr plen limit.15:0 val base.31:0 )
+ -rot FFFF0000 and or \ calc Limit ( addr paddr plen base.31:0 limit.31:0 )
+ 01000000 pci-bridge-gen-range \ and generate it ( addr paddr plen )
+;
+
+\ generate the ranges property for a PCI bridge
+: pci-bridge-range-props ( addr -- )
+ encode-start \ provide mem for property
+ pci-bridge-gen-mmio-range \ generate the non prefetchable Memory Entry
+ pci-bridge-gen-mem-range \ generate the prefetchable Memory Entry
+ pci-bridge-gen-io-range \ generate the IO Entry
+ dup IF \ IF any space present (propsize>0)
+ s" ranges" property \ | write it into the device tree
+ ELSE \ ELSE
+ s" " s" ranges" property
+ 2drop \ | forget the properties
+ THEN \ FI
+ drop \ forget the address
+;
+
+\ create the interrupt map for this bridge
+: pci-bridge-interrupt-map ( -- )
+ encode-start \ create the property ( paddr plen )
+ get-node child \ find the first child ( paddr plen handle )
+ BEGIN dup WHILE \ Loop as long as the handle is non-zero ( paddr plen handle )
+ dup >r >space \ Get the my-space ( paddr plen addr R: handle )
+ pci-gen-irq-entry \ and Encode the interrupt settings ( paddr plen R: handle)
+ r> peer \ Get neighbour ( paddr plen handle )
+ REPEAT \ process next childe node ( paddr plen handle )
+ drop \ forget the null ( paddr plen )
+ s" interrupt-map" property \ and set it ( -- )
+ 1 encode-int s" #interrupt-cells" property \ encode the cell#
+ f800 encode-int 0 encode-int+ 0 encode-int+ \ encode the bit mask for config addr (Dev only)
+ 7 encode-int+ s" interrupt-map-mask" property \ encode IRQ#=7 and generate property
+;
+
+\ ***************************************************************************************
+\ Generating the reg property
+\ ***************************************************************************************
+\ reg = config-addr 0 0 0 0 [BAR-config-addr 0 0 size.high size.low]
+
+\ encode the reg prop for a nonprefetchable 32bit MEM-BAR
+: encode-mem32-bar ( prop-addr prop-len BAR-addr -- prop-addr prop-len 4 )
+ dup pci-bar-size-mem32 \ calc BAR-size ( not changing the BAR )
+ dup IF \ IF BAR-size > 0 ( paddr plen baddr bsize )
+ >r 02000000 or encode-int+ \ | save size and encode BAR addr
+ 0 encode-64+ \ | make mid and lo zero
+ r> encode-64+ \ | encode size
+ ELSE \ ELSE
+ 2drop \ | don't do anything
+ THEN \ FI
+ 4 \ BAR-Len = 4 (32Bit)
+;
+
+\ encode the reg prop for a prefetchable 32bit MEM-BAR
+: encode-pmem32-bar ( prop-addr prop-len BAR-addr -- prop-addr prop-len 4 )
+ dup pci-bar-size-mem32 \ calc BAR-size ( not changing the BAR )
+ dup IF \ IF BAR-size > 0 ( paddr plen baddr bsize )
+ >r 42000000 or encode-int+ \ | save size and encode BAR addr
+ 0 encode-64+ \ | make mid and lo zero
+ r> encode-64+ \ | encode size
+ ELSE \ ELSE
+ 2drop \ | don't do anything
+ THEN \ FI
+ 4 \ BAR-Len = 4 (32Bit)
+;
+
+\ encode the reg prop for a nonprefetchable 64bit MEM-BAR
+: encode-mem64-bar ( prop-addr prop-len BAR-addr -- prop-addr prop-len 8 )
+ dup pci-bar-size-mem64 \ calc BAR-size ( not changing the BAR )
+ dup IF \ IF BAR-size > 0 ( paddr plen baddr bsize )
+ >r 03000000 or encode-int+ \ | save size and encode BAR addr
+ 0 encode-64+ \ | make mid and lo zero
+ r> encode-64+ \ | encode size
+ ELSE \ ELSE
+ 2drop \ | don't do anything
+ THEN \ FI
+ 8 \ BAR-Len = 8 (64Bit)
+;
+
+\ encode the reg prop for a prefetchable 64bit MEM-BAR
+: encode-pmem64-bar ( prop-addr prop-len BAR-addr -- prop-addr prop-len 8 )
+ dup pci-bar-size-mem64 \ calc BAR-size ( not changing the BAR )
+ dup IF \ IF BAR-size > 0 ( paddr plen baddr bsize )
+ >r 43000000 or encode-int+ \ | save size and encode BAR addr
+ 0 encode-64+ \ | make mid and lo zero
+ r> encode-64+ \ | encode size
+ ELSE \ ELSE
+ 2drop \ | don't do anything
+ THEN \ FI
+ 8 \ BAR-Len = 8 (64Bit)
+;
+
+\ encode the reg prop for a ROM-BAR
+: encode-rom-bar ( prop-addr prop-len configaddr -- prop-addr prop-len )
+ dup pci-bar-size-rom \ fetch raw BAR-size
+ dup IF \ IF BAR is used
+ >r 02000000 or encode-int+ \ | save size and encode BAR addr
+ 0 encode-64+ \ | make mid and lo zero
+ r> encode-64+ \ | calc and encode the size
+ ELSE \ ELSE
+ 2drop \ | don't do anything
+ THEN \ FI
+;
+
+\ encode the reg prop for an IO-BAR
+: encode-io-bar ( prop-addr prop-len BAR-addr BAR-value -- prop-addr prop-len 4 )
+ dup pci-bar-size-io \ calc BAR-size ( not changing the BAR )
+ dup IF \ IF BAR-size > 0 ( paddr plen baddr bsize )
+ >r 01000000 or encode-int+ \ | save size and encode BAR addr
+ 0 encode-64+ \ | make mid and lo zero
+ r> encode-64+ \ | encode size
+ ELSE \ ELSE
+ 2drop \ | don't do anything
+ THEN \ FI
+ 4 \ BAR-Len = 4 (32Bit)
+;
+
+\ write the representation of this BAR into the reg property
+: encode-bar ( prop-addr prop-len bar-addr -- prop-addr prop-len bar-len )
+ dup pci-bar-code@ \ calc BAR type
+ CASE \ CASE for the BAR types ( paddr plen baddr val )
+ 0 OF drop 4 ENDOF \ - not a valid type so do nothing
+ 1 OF encode-io-bar ENDOF \ - IO-BAR
+ 2 OF encode-mem32-bar ENDOF \ - MEM32
+ 3 OF encode-pmem32-bar ENDOF \ - MEM32 prefetchable
+ 4 OF encode-mem64-bar ENDOF \ - MEM64
+ 5 OF encode-pmem64-bar ENDOF \ - MEM64 prefetchable
+ ENDCASE \ ESAC ( paddr plen blen )
+;
+
+\ Setup reg property
+\ first encode the configuration space address
+: pci-reg-props ( configaddr -- )
+ dup encode-int \ configuration space ( caddr paddr plen )
+ 0 encode-64+ \ make the rest 0
+ 0 encode-64+ \ encode the size as 0
+ 2 pick pci-htype@ \ fetch Header Type ( caddr paddr plen type )
+ 1 and IF \ IF Bridge ( caddr paddr plen )
+ 18 10 DO \ | loop over all BARs
+ 2 pick i + \ | calc bar-addr ( caddr paddr plen baddr )
+ encode-bar \ | encode this BAR ( caddr paddr plen blen )
+ +LOOP \ | increase LoopIndex by the BARlen
+ 2 pick 38 + \ | calc ROM-BAR for a bridge ( caddr paddr plen baddr )
+ encode-rom-bar \ | encode the ROM-BAR ( caddr paddr plen )
+ ELSE \ ELSE ordinary device ( caddr paddr plen )
+ 28 10 DO \ | loop over all BARs
+ 2 pick i + \ | calc bar-addr ( caddr paddr plen baddr )
+ encode-bar \ | encode this BAR ( caddr paddr plen blen )
+ +LOOP \ | increase LoopIndex by the BARlen
+ 2 pick 30 + \ | calc ROM-BAR for a device ( caddr paddr plen baddr )
+ encode-rom-bar \ | encode the ROM-BAR ( caddr paddr plen )
+ THEN \ FI ( caddr paddr plen )
+ s" reg" property \ and store it into the property
+ drop
+;
+
+\ ***************************************************************************************
+\ Generating common properties
+\ ***************************************************************************************
+\ set up common properties for devices and bridges
+: pci-common-props ( addr -- )
+ dup pci-class-name device-name
+ dup pci-vendor@ encode-int s" vendor-id" property
+ dup pci-device@ encode-int s" device-id" property
+ dup pci-revision@ encode-int s" revision-id" property
+ dup pci-class@ encode-int s" class-code" property
+ 3 encode-int s" #address-cells" property
+ 2 encode-int s" #size-cells" property
+
+ dup pci-config-ext? IF 1 encode-int s" ibm,pci-config-space-type" property THEN
+
+ dup pci-status@
+ dup 9 rshift 3 and encode-int s" devsel-speed" property
+ dup 7 rshift 1 and IF 0 0 s" fast-back-to-back" property THEN
+ dup 6 rshift 1 and IF 0 0 s" 66mhz-capable" property THEN
+ 5 rshift 1 and IF 0 0 s" udf-supported" property THEN
+ dup pci-cache@ ?dup IF encode-int s" cache-line-size" property THEN
+ pci-interrupt@ ?dup IF encode-int s" interrupts" property THEN
+;
+
+\ set up device only properties
+: pci-device-props ( addr -- )
+ \ FIXME no s" compatible" prop
+ \ FIXME no s" alternate-reg" prop
+ \ FIXME no s" fcode-rom-offset" prop
+ \ FIXME no s" power-consumption" prop
+ dup pci-common-props
+ dup pci-min-grant@ encode-int s" min-grant" property
+ dup pci-max-lat@ encode-int s" max-latency" property
+ dup pci-sub-device@ ?dup IF encode-int s" subsystem-id" property THEN
+ dup pci-sub-vendor@ ?dup IF encode-int s" subsystem-vendor-id" property THEN
+ dup pci-device-assigned-addresses-prop
+ pci-reg-props
+ pci-hotplug-enabled IF
+ \ QEMU uses static assignments for my-drc-index:
+ \ 40000000h + $bus << 8 + $slot << 3
+ dup dup pci-addr2bus 8 lshift
+ swap pci-addr2dev 3 lshift or
+ 40000000 + encode-int s" ibm,my-drc-index" property
+ \ QEMU uses "Slot $bus*32$slotno" for loc-code
+ dup dup pci-addr2bus 20 *
+ swap pci-addr2dev +
+ a base !
+ s" Slot " rot $cathex
+ hex
+ encode-string s" ibm,loc-code" property
+ THEN
+;
+
+\ set up bridge only properties
+: pci-bridge-props ( addr -- )
+ \ FIXME no s" slot-names" prop
+ \ FIXME no s" bus-master-capable" prop
+ \ FIXME no s" clock-frequency" prop
+ dup pci-bus@
+ encode-int s" primary-bus" property
+ encode-int s" secondary-bus" property
+ encode-int s" subordinate-bus" property
+ dup pci-bus@ drop encode-int rot encode-int+ s" bus-range" property
+ pci-device-slots encode-int s" slot-names" property
+ dup pci-bridge-range-props
+ dup pci-bridge-assigned-addresses-prop
+ \ Only create interrupt-map when it doesn't already exist
+ \ (it can be provided by qemu)
+ s" interrupt-map" get-node get-property IF
+ pci-bridge-interrupt-map
+ ELSE 2drop THEN
+ pci-reg-props
+;
+
+
+\ used to set up all unknown Bridges.
+\ If a Bridge has no special handling for setup
+\ the device file (pci-bridge_VENDOR_DEVICE.fs) can call
+\ this word to setup busses and scan beyond.
+: pci-bridge-generic-setup ( addr -- )
+ pci-device-slots >r \ save the slot array on return stack
+ dup pci-common-props \ set the common properties before scanning the bus
+ s" pci" device-type \ the type is allways "pci"
+ dup pci-bridge-probe \ find all device connected to it
+ dup assign-all-bridge-bars \ set up all memory access BARs
+ dup pci-set-irq-line \ set the interrupt pin
+ dup pci-set-capabilities \ set up the capabilities
+ pci-bridge-props \ and generate all properties
+ r> TO pci-device-slots \ and reset the slot array
+;
+
+DEFER func-pci-device-props
+
+\ used for an gerneric device set up
+\ if a device has no special handling for setup
+\ the device file (pci-device_VENDOR_DEVICE.fs) can call
+\ this word to setup the device
+: pci-device-generic-setup ( config-addr -- )
+ dup assign-all-device-bars \ calc all BARs
+ dup pci-set-irq-line \ set the interrupt pin
+ dup pci-set-capabilities \ set up the capabilities
+ dup func-pci-device-props \ and generate all properties
+ drop \ forget the config-addr
+;
+
+' pci-device-props TO func-pci-device-props
diff --git a/qemu/roms/SLOF/slof/fs/pci-scan.fs b/qemu/roms/SLOF/slof/fs/pci-scan.fs
new file mode 100644
index 000000000..b8b9fe61f
--- /dev/null
+++ b/qemu/roms/SLOF/slof/fs/pci-scan.fs
@@ -0,0 +1,344 @@
+\ *****************************************************************************
+\ * Copyright (c) 2004, 2008 IBM Corporation
+\ * All rights reserved.
+\ * This program and the accompanying materials
+\ * are made available under the terms of the BSD License
+\ * which accompanies this distribution, and is available at
+\ * http://www.opensource.org/licenses/bsd-license.php
+\ *
+\ * Contributors:
+\ * IBM Corporation - initial implementation
+\ ****************************************************************************/
+
+\ ----------------------------------------------------------
+\ ********** Variables to be set by host bridge **********
+\ ----------------------------------------------------------
+
+\ Values of the next free memory area
+VARIABLE pci-next-mem \ prefetchable memory mapped
+VARIABLE pci-max-mem
+VARIABLE pci-next-mmio \ non-prefetchable memory
+VARIABLE pci-max-mmio
+VARIABLE pci-next-io \ I/O space
+VARIABLE pci-max-io
+VARIABLE pci-next-mem64 \ prefetchable 64-bit memory mapped
+VARIABLE pci-max-mem64
+
+\ Counter of busses found
+0 VALUE pci-bus-number
+\ Counter of devices found
+0 VALUE pci-device-number
+\ bit field of devices plugged into this bridge
+0 VALUE pci-device-slots
+\ byte field holding the device-slot number vector of the current device
+\ the vector can be as deep as the max depth of bridges possible
+\ 3,4,5 means
+\ the 5th slot on the bus of the bridge in
+\ the 4th slot on the bus of the bridge in
+\ the 3rd slot on the HostBridge bus
+here 100 allot CONSTANT pci-device-vec
+0 VALUE pci-device-vec-len
+\ enable/disable creation of hotplug-specific properties
+0 VALUE pci-hotplug-enabled
+
+
+\ Fixme Glue to the pci-devices ... remove this later
+: next-pci-mem ( addr -- addr ) pci-next-mem ;
+: next-pci-mmio ( addr -- addr ) pci-next-mmio ;
+: next-pci-io ( addr -- addr ) pci-next-io ;
+
+
+#include "pci-helper.fs"
+
+\ Dump out the pci device-slot vector
+: pci-vec ( -- )
+ cr s" device-vec(" type
+ pci-device-vec-len dup 2 0.r s" ):" type
+ 1+ 0 DO
+ pci-device-vec i + c@
+ space 2 0.r
+ LOOP
+ cr
+;
+
+\ prints out all relevant pci variables
+: pci-var-out ( -- )
+ s" mem:" type pci-next-mem @ 16 0.r cr
+ s" mmio:" type pci-next-mmio @ 16 0.r cr
+ s" io:" type pci-next-io @ 16 0.r cr
+;
+
+
+\ Update the device-slot number vector
+\ Set the bit of the DeviceSlot in the Slot array
+: pci-set-slot ( addr -- )
+ pci-addr2dev dup \ calc slot number
+ pci-device-vec-len \ the end of the vector
+ pci-device-vec + c! \ and update the vector
+ 80000000 swap rshift \ calc bit position of the device slot
+ pci-device-slots or \ set this bit
+ TO pci-device-slots \ and write it back
+;
+
+\ Update pci-next-mmio to be 1MB aligned and set the mmio-base register
+\ and set the Limit register to the maximum available address space
+\ needed for scanning possible devices behind the bridge
+: pci-bridge-set-mmio-base ( addr -- )
+ pci-next-mmio @ 100000 #aligned \ read the current Value and align to 1MB boundary
+ dup 100000 + pci-next-mmio ! \ and write back with 1MB for bridge
+ 10 rshift \ mmio-base reg is only the upper 16 bits
+ pci-max-mmio @ 1- FFFF0000 and or \ and Insert mmio Limit (set it to max)
+ swap 20 + rtas-config-l! \ and write it into the bridge
+;
+
+\ Update pci-next-mmio to be 1MB aligned and set the mmio-limit register
+\ The Limit Value is one less then the upper boundary
+\ If the limit is less than the base the mmio is disabled
+: pci-bridge-set-mmio-limit ( addr -- )
+ pci-next-mmio @ 100000 #aligned \ fetch current value and align to 1MB
+ dup pci-next-mmio ! \ and write it back
+ 1- FFFF0000 and \ make it one less and keep upper 16 bits
+ over 20 + rtas-config-l@ 0000FFFF and \ fetch original value
+ or swap 20 + rtas-config-l! \ and write it into the Reg
+;
+
+\ Update pci-next-mem to be 1MB aligned and set the mem-base and mem-base-upper register
+\ and set the Limit register to the maximum available address space
+\ needed for scanning possible devices behind the bridge
+: pci-bridge-set-mem-base ( addr -- )
+ pci-next-mem @ 100000 #aligned \ read the current Value and align to 1MB boundary
+ dup 100000 + pci-next-mem ! \ and write back with 1MB for bridge
+ over 24 + rtas-config-w@ \ check if 64bit support
+ 1 and IF \ IF 64 bit support
+ 2dup 20 rshift \ | keep upper 32 bits
+ swap 28 + rtas-config-l! \ | and write it into the Base-Upper32-bits
+ pci-max-mem @ 20 rshift \ | fetch max Limit address and keep upper 32 bits
+ 2 pick 2C + rtas-config-l! \ | and set the Limit
+ THEN \ FI
+ 10 rshift \ keep upper 16 bits
+ pci-max-mem @ 1- FFFF0000 and or \ and Insert mmem Limit (set it to max)
+ swap 24 + rtas-config-l! \ and write it into the bridge
+;
+
+\ Update pci-next-mem to be 1MB aligned and set the mem-limit register
+\ The Limit Value is one less then the upper boundary
+\ If the limit is less than the base the mem is disabled
+: pci-bridge-set-mem-limit ( addr -- )
+ pci-next-mem @ 100000 #aligned \ read the current Value and align to 1MB boundary
+ dup pci-next-mem ! \ and write it back
+ 1- \ make limit one less than boundary
+ over 24 + rtas-config-w@ \ check if 64bit support
+ 1 and IF \ IF 64 bit support
+ 2dup 20 rshift \ | keep upper 32 bits
+ swap 2C + rtas-config-l! \ | and write it into the Limit-Upper32-bits
+ THEN \ FI
+ FFFF0000 and \ keep upper 16 bits
+ over 24 + rtas-config-l@ 0000FFFF and \ fetch original Value
+ or swap 24 + rtas-config-l! \ and write it into the bridge
+;
+
+\ Update pci-next-io to be 4KB aligned and set the io-base and io-base-upper register
+\ and set the Limit register to the maximum available address space
+\ needed for scanning possible devices behind the bridge
+: pci-bridge-set-io-base ( addr -- )
+ pci-next-io @ 1000 #aligned \ read the current Value and align to 4KB boundary
+ dup 1000 + pci-next-io ! \ and write back with 4K for bridge
+ over 1C + rtas-config-l@ \ check if 32bit support
+ 1 and IF \ IF 32 bit support
+ 2dup 10 rshift \ | keep upper 16 bits
+ pci-max-io @ FFFF0000 and or \ | insert upper 16 bits of Max-Limit
+ swap 30 + rtas-config-l! \ | and write it into the Base-Upper16-bits
+ THEN \ FI
+ 8 rshift 000000FF and \ keep upper 8 bits
+ pci-max-io @ 1- 0000FF00 and or \ insert upper 8 bits of Max-Limit
+ over rtas-config-l@ FFFF0000 and \ fetch original Value
+ or swap 1C + rtas-config-l! \ and write it into the bridge
+;
+
+\ Update pci-next-io to be 4KB aligned and set the io-limit register
+\ The Limit Value is one less then the upper boundary
+\ If the limit is less than the base the io is disabled
+: pci-bridge-set-io-limit ( addr -- )
+ pci-next-io @ 1000 #aligned \ read the current Value and align to 4KB boundary
+ dup pci-next-io ! \ and write it back
+ 1- \ make limit one less than boundary
+ over 1D + rtas-config-b@ \ check if 32bit support
+ 1 and IF \ IF 32 bit support
+ 2dup FFFF0000 and \ | keep upper 16 bits
+ over 30 + rtas-config-l@ \ | fetch original Value
+ or swap 30 + rtas-config-l! \ | and write it into the Limit-Upper16-bits
+ THEN \ FI
+ 0000FF00 and \ keep upper 8 bits
+ over 1C + rtas-config-l@ FFFF00FF and \ fetch original Value
+ or swap 1C + rtas-config-l! \ and write it into the bridge
+;
+
+\ set up all base registers to the current variable Values
+: pci-bridge-set-bases ( addr -- )
+ dup pci-bridge-set-mmio-base
+ dup pci-bridge-set-mem-base
+ pci-bridge-set-io-base
+;
+
+\ set up all limit registers to the current variable Values
+: pci-bridge-set-limits ( addr -- )
+ dup pci-bridge-set-mmio-limit
+ dup pci-bridge-set-mem-limit
+ pci-bridge-set-io-limit
+;
+
+\ ----------------------------------------------------------
+\ ****************** PCI Scan functions ******************
+\ ----------------------------------------------------------
+
+\ define function pointer as forward declaration of pci-probe-bus
+DEFER func-pci-probe-bus
+DEFER func-pci-bridge-range-props
+
+\ Setup the Base and Limits in the Bridge
+\ and scan the bus(es) beyond that Bridge
+: pci-bridge-probe ( addr -- )
+ dup pci-bridge-set-bases \ SetUp all Base Registers
+ dup func-pci-bridge-range-props \ Setup temporary "range
+ pci-bus-number 1+ TO pci-bus-number \ increase number of busses found
+ pci-device-vec-len 1+ TO pci-device-vec-len \ increase the device-slot vector depth
+ dup \ stack config-addr for pci-bus!
+ FF swap \ Subordinate Bus Number ( for now to max to open all subbusses )
+ pci-bus-number swap \ Secondary Bus Number ( the new busnumber )
+ dup pci-addr2bus swap \ Primary Bus Number ( the current bus )
+ pci-bus! \ and set them into the bridge
+ pci-enable \ enable mem/IO transactions
+ dup pci-bus-scnd@ func-pci-probe-bus \ and probe the secondary bus
+ dup pci-bus-number swap pci-bus-subo! \ set SubOrdinate Bus Number to current number of busses
+ pci-device-vec-len 1- TO pci-device-vec-len \ decrease the device-slot vector depth
+ dup pci-bridge-set-limits \ SetUp all Limit Registers
+ drop \ forget the config-addr
+;
+
+\ set up the pci-device
+: pci-device-setup ( addr -- )
+ drop \ since the config-addr is coded in my-space, drop it here
+ s" pci-device.fs" included \ and setup the device as node in the device tree
+;
+
+\ set up the pci bridge
+: pci-bridge-setup ( addr -- )
+ drop \ since the config-addr is coded in my-space, drop it here
+ s" pci-bridge.fs" included \ and setup the bridge as node in the device tree
+;
+
+\ add the new found device/bridge to the device tree and set it up
+: pci-add-device ( addr -- )
+ new-device \ create a new device-tree node
+ dup set-space \ set the config addr for this device tree entry
+ dup pci-set-slot \ set the slot bit
+ dup pci-htype@ \ read HEADER-Type
+ 7f and \ Mask bit 7 - multifunction device
+ CASE
+ 0 OF pci-device-setup ENDOF \ | set up the device
+ 1 OF pci-bridge-setup ENDOF \ | set up the bridge
+ dup OF dup pci-htype@ pci-out ENDOF
+ ENDCASE
+ finish-device \ and close the device-tree node
+;
+
+\ check for multifunction and for each function
+\ (dependig from header type) call device or bridge setup
+: pci-setup-device ( addr -- )
+ dup pci-htype@ \ read HEADER-Type
+ 80 and IF 8 ELSE 1 THEN \ check for multifunction
+ 0 DO \ LOOP over all possible functions (either 8 or only 1)
+ dup
+ i 8 lshift + \ calc device-function-config-addr
+ dup pci-vendor@ \ check if valid function
+ FFFF = IF
+ drop \ non-valid so forget the address
+ ELSE
+ pci-device-number 1+ \ increase the number of devices
+ TO pci-device-number \ and store it
+ pci-add-device \ and add the device to the device tree and set it up
+ THEN
+ LOOP \ next function
+ drop \ forget the device-addr
+;
+
+\ check if a device is plugged into this bus at this device number
+: pci-probe-device ( busnr devicenr -- )
+ pci-bus2addr \ calc pci-address
+ dup pci-vendor@ \ fetch Vendor-ID
+ FFFF = IF \ check if valid
+ drop \ if not forget it
+ ELSE
+ pci-setup-device \ if valid setup the device
+ THEN
+;
+
+\ walk through all 32 possible pci devices on this bus and probe them
+: pci-probe-bus ( busnr -- )
+ 0 TO pci-device-slots \ reset slot array to unpoppulated
+ 20 0 DO
+ dup
+ i pci-probe-device
+ LOOP
+ drop
+;
+
+\ setup the function pointer used in pci-bridge-setup
+' pci-probe-bus TO func-pci-probe-bus
+
+\ ----------------------------------------------------------
+\ ****************** System functions ********************
+\ ----------------------------------------------------------
+\ Setup the whole system for pci devices
+\ start with the bus-min and try all busses
+\ until at least 1 device was found
+\ ( needed for HostBridges that don't start with Bus 0 )
+: pci-probe-all ( bus-max bus-min -- ) \ Check all busses from bus-min up to bus-max if needed
+ 0 TO pci-device-vec-len \ reset the device-slot vector
+ DO
+ i TO pci-bus-number \ set current Busnumber
+ 0 TO pci-device-number \ reset Device Number
+ pci-bus-number pci-probe-bus \ and probe this bus
+ pci-device-number 0 > IF LEAVE THEN \ if we found a device we're done
+ LOOP \ else next bus
+;
+
+: (probe-pci-host-bridge) ( bus-max bus-min -- )
+ 0d emit ." Adapters on " puid 10 0.r cr \ print the puid we're looking at
+ ( bus-max bus-min ) pci-probe-all \ and walk the bus
+ pci-device-number 0= IF \ IF no devices found
+ 15 spaces \ | indent the output
+ ." None" cr \ | tell the world our result
+ THEN \ FI
+;
+
+\ probe the hostbridge that is specified in my-puid
+\ for the mmio mem and io addresses:
+\ base is the least available address
+\ max is the highest available address
+: probe-pci-host-bridge ( bus-max bus-min mmio-max mmio-base mem-max mem-base io-max io-base my-puid -- )
+ puid >r TO puid \ save puid and set the new
+ pci-next-io ! \ save the next io-base address
+ pci-max-io ! \ save the max io-space address
+ pci-next-mem ! \ save the next mem-base address
+ pci-max-mem ! \ save the max mem-space address
+ pci-next-mmio ! \ save the next mmio-base address
+ pci-max-mmio ! \ save the max mmio-space address
+ (probe-pci-host-bridge)
+ r> TO puid \ restore puid
+;
+
+\ provide the device-alias definition words
+#include <pci-aliases.fs>
+
+\ provide all words for the interrupts settings
+#include <pci-interrupts.fs>
+
+\ provide all words for the pci capabilities init
+#include <pci-capabilities.fs>
+
+\ provide all words needed to generate the properties and/or assign BAR values
+#include "pci-properties.fs"
+
+\ setup the function pointer for bridge ranges
+' pci-bridge-range-props TO func-pci-bridge-range-props
diff --git a/qemu/roms/SLOF/slof/fs/preprocessor.fs b/qemu/roms/SLOF/slof/fs/preprocessor.fs
new file mode 100644
index 000000000..a13fb3004
--- /dev/null
+++ b/qemu/roms/SLOF/slof/fs/preprocessor.fs
@@ -0,0 +1,41 @@
+\ *****************************************************************************
+\ * Copyright (c) 2004, 2008 IBM Corporation
+\ * All rights reserved.
+\ * This program and the accompanying materials
+\ * are made available under the terms of the BSD License
+\ * which accompanies this distribution, and is available at
+\ * http://www.opensource.org/licenses/bsd-license.php
+\ *
+\ * Contributors:
+\ * IBM Corporation - initial implementation
+\ ****************************************************************************/
+
+: ([IF])
+ BEGIN
+ BEGIN parse-word dup 0= WHILE
+ 2drop refill
+ REPEAT
+
+ 2dup s" [IF]" str= IF 1 throw THEN
+ 2dup s" [ELSE]" str= IF 2 throw THEN
+ 2dup s" [THEN]" str= IF 3 throw THEN
+ s" \" str= IF linefeed parse 2drop THEN
+ AGAIN
+ ;
+
+: [IF] ( flag -- )
+ IF exit THEN
+ 1 BEGIN
+ ['] ([IF]) catch
+ CASE
+ 1 OF 1+ ENDOF
+ 2 OF dup 1 = if 1- then ENDOF
+ 3 OF 1- ENDOF
+ ENDCASE
+ dup 0 <=
+ UNTIL drop
+; immediate
+
+: [ELSE] 0 [COMPILE] [IF] ; immediate
+: [THEN] ; immediate
+
diff --git a/qemu/roms/SLOF/slof/fs/property.fs b/qemu/roms/SLOF/slof/fs/property.fs
new file mode 100644
index 000000000..cb99fbe9d
--- /dev/null
+++ b/qemu/roms/SLOF/slof/fs/property.fs
@@ -0,0 +1,192 @@
+\ *****************************************************************************
+\ * Copyright (c) 2004, 2008 IBM Corporation
+\ * All rights reserved.
+\ * This program and the accompanying materials
+\ * are made available under the terms of the BSD License
+\ * which accompanies this distribution, and is available at
+\ * http://www.opensource.org/licenses/bsd-license.php
+\ *
+\ * Contributors:
+\ * IBM Corporation - initial implementation
+\ ****************************************************************************/
+
+
+\ Properties 5.3.5
+
+\ Words on the property list for a node are actually executable words,
+\ that return the address and length of the property's data. Special
+\ nodes like /options can have their properties use specialized code to
+\ dynamically generate their data; most nodes just use a 2CONSTANT.
+
+\ Put the type as byte before the property
+\ { int = 1, bytes = 2, string = 3 }
+\ This is used by .properties for pretty print
+
+\ Flag for type encoding, encode-* resets, set-property set the flag
+true value encode-first?
+
+: decode-int over >r 4 /string r> 4c@ swap 2swap swap bljoin ;
+: decode-64 decode-int -rot decode-int -rot 2swap swap lxjoin ;
+: decode-string ( prop-addr1 prop-len1 -- prop-addr2 prop-len2 str len )
+ dup 0= IF 2dup EXIT THEN \ string properties with zero length
+ over BEGIN dup c@ 0= IF 1+ -rot swap 2 pick over - rot over - -rot 1-
+ EXIT THEN 1+ AGAIN ;
+
+\ Remove a word from a wordlist.
+: (prune) ( name len head -- )
+ dup >r (find) ?dup IF r> BEGIN dup @ WHILE 2dup @ = IF
+ >r @ r> ! EXIT THEN @ REPEAT 2drop ELSE r> drop THEN ;
+: prune ( name len -- ) last (prune) ;
+
+: set-property ( data dlen name nlen phandle -- )
+ true to encode-first?
+ get-current >r node>properties @ set-current
+ 2dup prune $2CONSTANT r> set-current ;
+: delete-property ( name nlen -- )
+ get-node get-current >r node>properties @ set-current
+ prune r> set-current ;
+: property ( data dlen name nlen -- ) get-node set-property ;
+: get-property ( str len phandle -- true | data dlen false )
+ ?dup 0= IF cr cr cr ." get-property for " type ." on zero phandle"
+ cr cr true EXIT THEN
+ node>properties @ voc-find dup IF link> execute false ELSE drop true THEN ;
+: get-package-property ( str len phandle -- true | data dlen false )
+ get-property ;
+: get-my-property ( str len -- true | data dlen false )
+ my-self ihandle>phandle get-property ;
+: get-parent-property ( str len -- true | data dlen false )
+ my-parent ihandle>phandle get-property ;
+
+: get-inherited-property ( str len -- true | data dlen false )
+ my-self ihandle>phandle
+ BEGIN
+ 3dup get-property 0= IF
+ \ Property found
+ rot drop rot drop rot drop false EXIT
+ THEN
+ parent dup 0= IF
+ \ Root node has been reached, but property has not been found
+ 3drop true EXIT
+ THEN
+ AGAIN
+;
+
+\ Print out properties.
+
+20 CONSTANT indent-prop
+
+: .prop-int ( str len -- )
+ space
+ 400 min 0
+ ?DO
+ i over + dup ( str act-addr act-addr )
+ c@ 2 0.r 1+ dup c@ 2 0.r 1+ dup c@ 2 0.r 1+ c@ 2 0.r ( str )
+ i c and c = IF \ check for multipleof 16 bytes
+ cr indent @ indent-prop + 1+ 0 \ linefeed + indent
+ DO
+ space \ print spaces
+ LOOP
+ ELSE
+ space space \ print two spaces
+ THEN
+ 4 +LOOP
+ drop
+;
+
+: .prop-bytes ( str len -- )
+ 2dup -4 and .prop-int ( str len )
+
+ dup 3 and dup IF ( str len len%4 )
+ >r -4 and + r> ( str' len%4 )
+ bounds ( str' str'+len%4 )
+ DO
+ i c@ 2 0.r \ Print last 3 bytes
+ LOOP
+ ELSE
+ 3drop
+ THEN
+;
+
+: .prop-string ( str len )
+ 2dup space type
+ cr indent @ indent-prop + 0 DO space LOOP \ Linefeed
+ .prop-bytes
+;
+
+: .propbytes ( xt -- )
+ execute dup
+ IF
+ over cell- @ execute
+ ELSE
+ 2drop
+ THEN
+;
+: .property ( lfa -- )
+ cr indent @ 0
+ ?DO
+ space
+ LOOP
+ link> dup >name name>string 2dup type nip ( len )
+ indent-prop swap - ( xt 20-len )
+ dup 0< IF drop 0 THEN 0 ( xt number-of-space 0 )
+ ?DO
+ space
+ LOOP
+ .propbytes
+;
+: (.properties) ( phandle -- )
+ node>properties @ cell+ @ BEGIN dup WHILE dup .property @ REPEAT drop ;
+: .properties ( -- )
+ get-node (.properties) ;
+
+: next-property ( str len phandle -- false | str' len' true )
+ ?dup 0= IF device-tree @ THEN \ XXX: is this line required?
+ node>properties @
+ >r 2dup 0= swap 0= or IF 2drop r> cell+ ELSE r> voc-find THEN
+ @ dup IF link>name name>string true THEN ;
+
+
+\ encode-* words and all helpers
+
+\ Start a encoded property string
+: encode-start ( -- prop 0 )
+ ['] .prop-int compile,
+ false to encode-first?
+ here 0
+;
+
+: encode-int ( val -- prop prop-len )
+ encode-first? IF
+ ['] .prop-int compile, \ Execution token for print
+ false to encode-first?
+ THEN
+ here swap lbsplit c, c, c, c, /l
+;
+: encode-bytes ( str len -- prop-addr prop-len )
+ encode-first? IF
+ ['] .prop-bytes compile, \ Execution token for print
+ false to encode-first?
+ THEN
+ here over 2dup 2>r allot swap move 2r>
+;
+: encode-string ( str len -- prop-addr prop-len )
+ encode-first? IF
+ ['] .prop-string compile, \ Execution token for print
+ false to encode-first?
+ THEN
+ encode-bytes 0 c, char+
+;
+
+: encode+ ( prop1-addr prop1-len prop2-addr prop2-len -- prop-addr prop-len )
+ nip + ;
+: encode-int+ encode-int encode+ ;
+: encode-64 xlsplit encode-int rot encode-int+ ;
+: encode-64+ encode-64 encode+ ;
+
+
+\ Helpers for common nodes. Should perhaps remove "compatible", as it's
+\ not typically a single string.
+: device-name encode-string s" name" property ;
+: device-type encode-string s" device_type" property ;
+: model encode-string s" model" property ;
+: compatible encode-string s" compatible" property ;
diff --git a/qemu/roms/SLOF/slof/fs/quiesce.fs b/qemu/roms/SLOF/slof/fs/quiesce.fs
new file mode 100644
index 000000000..47006e44d
--- /dev/null
+++ b/qemu/roms/SLOF/slof/fs/quiesce.fs
@@ -0,0 +1,58 @@
+\ *****************************************************************************
+\ * Copyright (c) 2004, 2008 IBM Corporation
+\ * All rights reserved.
+\ * This program and the accompanying materials
+\ * are made available under the terms of the BSD License
+\ * which accompanies this distribution, and is available at
+\ * http://www.opensource.org/licenses/bsd-license.php
+\ *
+\ * Contributors:
+\ * IBM Corporation - initial implementation
+\ ****************************************************************************/
+
+
+100 CONSTANT quiesce-xt#
+
+\ The array with the quiesce execution tokens:
+CREATE quiesce-xts quiesce-xt# cells allot
+quiesce-xts quiesce-xt# cells erase
+
+0 VALUE quiesce-done?
+
+
+\ Add a token to the quiesce execution token array:
+: add-quiesce-xt ( xt -- )
+ quiesce-xt# 0 DO
+ quiesce-xts I cells + ( xt arrayptr )
+ dup @ 0= ( xt arrayptr true|false )
+ IF
+ ! UNLOOP EXIT
+ ELSE ( xt arrayptr )
+ over swap ( xt xt arrayptr )
+ @ = \ xt already stored ?
+ IF
+ drop UNLOOP EXIT
+ THEN ( xt )
+ THEN
+ LOOP
+ drop ( xt -- )
+ ." Warning: quiesce xt list is full." cr
+;
+
+
+\ The quiesce call asserts that the firmware and all hardware
+\ is in a sane state (e.g. assert that no background DMA is
+\ running anymore)
+: quiesce ( -- )
+ quiesce-done? IF EXIT THEN
+ true to quiesce-done?
+ quiesce-xt# 0 DO
+ quiesce-xts I cells + ( arrayptr )
+ @ dup IF ( xt )
+ EXECUTE
+ ELSE
+ drop UNLOOP EXIT
+ THEN
+ LOOP
+;
+
diff --git a/qemu/roms/SLOF/slof/fs/rmove.fs b/qemu/roms/SLOF/slof/fs/rmove.fs
new file mode 100644
index 000000000..c28dba9c4
--- /dev/null
+++ b/qemu/roms/SLOF/slof/fs/rmove.fs
@@ -0,0 +1,53 @@
+\ *****************************************************************************
+\ * Copyright (c) 2004, 2008 IBM Corporation
+\ * All rights reserved.
+\ * This program and the accompanying materials
+\ * are made available under the terms of the BSD License
+\ * which accompanies this distribution, and is available at
+\ * http://www.opensource.org/licenses/bsd-license.php
+\ *
+\ * Contributors:
+\ * IBM Corporation - initial implementation
+\ ****************************************************************************/
+
+defer '(r@)
+defer '(r!)
+1 VALUE /(r)
+
+
+\ The rest of the code already implemented in prim.in
+\ In the end all of this should be moved over there and this file terminated
+
+: (rfill) ( addr size pattern 'r! /r -- )
+ to /(r) to '(r!) ff and
+ dup 8 lshift or dup 10 lshift or dup 20 lshift or
+ -rot bounds ?do dup i '(r!) /(r) +loop drop
+;
+
+: (fwrmove) ( src dest size -- )
+ >r 0 -rot r> bounds ?do + dup '(r@) i '(r!) /(r) dup +loop 2drop
+;
+
+\ Move from main to device memory
+: mrmove ( src dest size -- )
+ 3dup or or 7 AND CASE
+ 0 OF ['] x@ ['] rx! /x ENDOF
+ 4 OF ['] l@ ['] rl! /l ENDOF
+ 2 OF ['] w@ ['] rw! /w ENDOF
+ dup OF ['] c@ ['] rb! /c ENDOF
+ ENDCASE
+ ( We already know that source and destination do not overlap )
+ to /(r) to '(r!) to '(r@) (fwrmove)
+;
+
+: rfill ( addr size pattern -- )
+ 3dup drop or 7 AND CASE
+ 0 OF ['] rx! /x ENDOF
+ 4 OF ['] rl! /l ENDOF
+ 2 OF ['] rw! /w ENDOF
+ dup OF ['] rb! /c ENDOF
+ ENDCASE (rfill)
+;
+
+
+
diff --git a/qemu/roms/SLOF/slof/fs/romfs.fs b/qemu/roms/SLOF/slof/fs/romfs.fs
new file mode 100644
index 000000000..7d7e4637e
--- /dev/null
+++ b/qemu/roms/SLOF/slof/fs/romfs.fs
@@ -0,0 +1,123 @@
+\ *****************************************************************************
+\ * Copyright (c) 2004, 2008 IBM Corporation
+\ * All rights reserved.
+\ * This program and the accompanying materials
+\ * are made available under the terms of the BSD License
+\ * which accompanies this distribution, and is available at
+\ * http://www.opensource.org/licenses/bsd-license.php
+\ *
+\ * Contributors:
+\ * IBM Corporation - initial implementation
+\ ****************************************************************************/
+
+STRUCT
+ cell field romfs>file-header
+ cell field romfs>data
+ cell field romfs>data-size
+ cell field romfs>flags
+
+CONSTANT /romfs-lookup-control-block
+
+CREATE romfs-lookup-cb /romfs-lookup-control-block allot
+romfs-lookup-cb /romfs-lookup-control-block erase
+
+: create-filename ( string -- string\0 )
+ here >r dup 8 + allot
+ r@ over 8 + erase
+ r@ zplace r> ;
+
+: romfs-lookup ( fn-str fn-len -- data size | false )
+ create-filename romfs-base
+ romfs-lookup-cb romfs-lookup-entry call-c
+ 0= IF romfs-lookup-cb dup romfs>data @ swap romfs>data-size @ ELSE
+ false THEN ;
+
+: ibm,romfs-lookup ( fn-str fn-len -- data-high data-low size | 0 0 false )
+ romfs-lookup dup
+ 0= if drop 0 0 false else
+ swap dup 20 rshift swap ffffffff and then ;
+
+\ FIXME For a short time ...
+: romfs-lookup-client ibm,romfs-lookup ;
+
+\ Fixme temp implementation
+
+STRUCT
+ cell field romfs>next-off
+ cell field romfs>size
+ cell field romfs>flags
+ cell field romfs>data-off
+ cell field romfs>name
+
+CONSTANT /romfs-cb
+
+: romfs-map-file ( fn-str fn-len -- file-addr file-size )
+ romfs-base >r
+ BEGIN 2dup r@ romfs>name zcount string=ci not WHILE
+ ( fn-str fn-len ) ( R: rom-cb-file-addr )
+ r> romfs>next-off dup @ dup 0= IF 1 THROW THEN + >r REPEAT
+ ( fn-str fn-len ) ( R: rom-cb-file-addr )
+ 2drop r@ romfs>data-off @ r@ + r> romfs>size @ ;
+
+\ returns address of romfs-header file
+: flash-header ( -- address | false )
+ get-flash-base 28 + \ prepare flash header file address
+ dup rx@ \ fetch "magic123"
+ 6d61676963313233 <> IF \ IF flash is not valid
+ drop \ | forget address
+ false \ | return false
+ THEN \ FI
+;
+
+CREATE bdate-str 10 allot
+: bdate2human ( -- addr len )
+ flash-header 40 + rx@ (.)
+ drop dup 0 + bdate-str 6 + 4 move
+ dup 4 + bdate-str 0 + 2 move
+ dup 6 + bdate-str 3 + 2 move
+ dup 8 + bdate-str b + 2 move
+ a + bdate-str e + 2 move
+ 2d bdate-str 2 + c!
+ 2d bdate-str 5 + c!
+ 20 bdate-str a + c!
+ 3a bdate-str d + c!
+ bdate-str 10
+;
+
+
+\ Look up a file in the ROM file system and evaluate it
+
+: included ( fn fn-len -- )
+ 2dup >r >r romfs-lookup dup IF
+ r> drop r> drop evaluate
+ ELSE
+ drop ." Cannot open file : " r> r> type cr
+ THEN
+;
+
+: include ( " fn " -- )
+ parse-word included
+;
+
+: ?include ( flag " fn " -- )
+ parse-word rot IF included ELSE 2drop THEN
+;
+
+: include? ( nargs flag " fn " -- )
+ parse-word rot IF
+ rot drop included
+ ELSE
+ 2drop 0 ?DO drop LOOP
+ THEN
+;
+
+
+\ List files in ROMfs
+
+: (print-romfs-file-info) ( file-addr -- )
+ 9 emit dup b 0.r 2 spaces dup 8 + @ 6 0.r 2 spaces 20 + zcount type cr
+;
+
+: romfs-list ( -- )
+ romfs-base 0 cr BEGIN + dup (print-romfs-file-info) dup @ dup 0= UNTIL 2drop
+;
diff --git a/qemu/roms/SLOF/slof/fs/root.fs b/qemu/roms/SLOF/slof/fs/root.fs
new file mode 100644
index 000000000..21c710951
--- /dev/null
+++ b/qemu/roms/SLOF/slof/fs/root.fs
@@ -0,0 +1,84 @@
+\ *****************************************************************************
+\ * Copyright (c) 2004, 2008 IBM Corporation
+\ * All rights reserved.
+\ * This program and the accompanying materials
+\ * are made available under the terms of the BSD License
+\ * which accompanies this distribution, and is available at
+\ * http://www.opensource.org/licenses/bsd-license.php
+\ *
+\ * Contributors:
+\ * IBM Corporation - initial implementation
+\ ****************************************************************************/
+
+\ this creates the root and common branches of the device tree
+
+defer (client-exec)
+defer client-exec
+
+\ defined in slof/fs/client.fs
+defer callback
+defer continue-client
+
+0 VALUE chosen-node
+
+: chosen
+ chosen-node dup 0= IF
+ drop s" /chosen" find-node dup to chosen-node
+ THEN
+;
+
+: set-chosen ( prop len name len -- )
+ chosen set-property ;
+
+: get-chosen ( name len -- [ prop len ] success )
+ chosen get-property 0= ;
+
+\ Look for an exising root, create one if needed
+" /" find-node dup 0= IF
+ drop
+ new-device
+ s" /" device-name
+ELSE
+ extend-device
+THEN
+
+\ Create /chosen if it doesn't exist
+" /chosen" find-node dup 0= IF
+ drop
+ new-device
+ s" chosen" device-name
+ s" " encode-string s" bootargs" property
+ s" " encode-string s" bootpath" property
+ finish-device
+ELSE
+ drop
+THEN
+
+\ Create /aliases
+new-device
+ s" aliases" device-name
+finish-device
+
+\ Create /options
+new-device
+ s" options" device-name
+finish-device
+
+\ Create /openprom
+new-device
+ s" openprom" device-name
+ 0 0 s" relative-addressing" property
+finish-device
+
+\ Create /packages
+new-device
+#include <packages.fs>
+finish-device
+
+: open true ;
+: close ;
+#include <archsupport.fs>
+
+\ Finish root
+finish-device
+
diff --git a/qemu/roms/SLOF/slof/fs/rtas/rtas-cpu.fs b/qemu/roms/SLOF/slof/fs/rtas/rtas-cpu.fs
new file mode 100644
index 000000000..c133abc40
--- /dev/null
+++ b/qemu/roms/SLOF/slof/fs/rtas/rtas-cpu.fs
@@ -0,0 +1,23 @@
+\ *****************************************************************************
+\ * Copyright (c) 2004, 2008 IBM Corporation
+\ * All rights reserved.
+\ * This program and the accompanying materials
+\ * are made available under the terms of the BSD License
+\ * which accompanies this distribution, and is available at
+\ * http://www.opensource.org/licenses/bsd-license.php
+\ *
+\ * Contributors:
+\ * IBM Corporation - initial implementation
+\ ****************************************************************************/
+
+: rtas-start-cpu ( pid loc r3 -- status )
+ [ s" start-cpu" rtas-get-token ] LITERAL rtas-cb rtas>token l!
+ 3 rtas-cb rtas>nargs l!
+ 1 rtas-cb rtas>nret l!
+ rtas-cb rtas>args2 l!
+ rtas-cb rtas>args1 l!
+ rtas-cb rtas>args0 l!
+ 0 rtas-cb rtas>args3 l!
+ enter-rtas
+ rtas-cb rtas>args3 l@
+;
diff --git a/qemu/roms/SLOF/slof/fs/rtas/rtas-flash.fs b/qemu/roms/SLOF/slof/fs/rtas/rtas-flash.fs
new file mode 100644
index 000000000..f8abeaaf0
--- /dev/null
+++ b/qemu/roms/SLOF/slof/fs/rtas/rtas-flash.fs
@@ -0,0 +1,46 @@
+\ *****************************************************************************
+\ * Copyright (c) 2004, 2008 IBM Corporation
+\ * All rights reserved.
+\ * This program and the accompanying materials
+\ * are made available under the terms of the BSD License
+\ * which accompanies this distribution, and is available at
+\ * http://www.opensource.org/licenses/bsd-license.php
+\ *
+\ * Contributors:
+\ * IBM Corporation - initial implementation
+\ ****************************************************************************/
+
+: rtas-ibm-update-flash-64-and-reboot ( block-list -- status )
+ [ s" ibm,update-flash-64-and-reboot" rtas-get-token ] LITERAL rtas-cb rtas>token l!
+ 1 rtas-cb rtas>nargs l!
+ 1 rtas-cb rtas>nret l!
+ rtas-cb rtas>args0 l!
+ enter-rtas
+ rtas-cb rtas>args1 l@
+;
+
+: rtas-ibm-manage-flash-image ( image-to-commit -- status )
+ [ s" ibm,manage-flash-image" rtas-get-token ] LITERAL rtas-cb rtas>token l!
+ 1 rtas-cb rtas>nargs l!
+ 1 rtas-cb rtas>nret l!
+ rtas-cb rtas>args0 l!
+ enter-rtas
+ rtas-cb rtas>args1 l@
+;
+
+: rtas-set-flashside ( flashside -- status )
+ [ s" rtas-set-flashside" rtas-get-token ] LITERAL rtas-cb rtas>token l!
+ 1 rtas-cb rtas>nargs l!
+ 1 rtas-cb rtas>nret l!
+ rtas-cb rtas>args0 l!
+ enter-rtas
+ rtas-cb rtas>args1 l@
+;
+
+: rtas-get-flashside ( -- status )
+ [ s" rtas-get-flashside" rtas-get-token ] LITERAL rtas-cb rtas>token l!
+ 0 rtas-cb rtas>nargs l!
+ 1 rtas-cb rtas>nret l!
+ enter-rtas
+ rtas-cb rtas>args0 l@
+;
diff --git a/qemu/roms/SLOF/slof/fs/rtas/rtas-init.fs b/qemu/roms/SLOF/slof/fs/rtas/rtas-init.fs
new file mode 100644
index 000000000..8451cfde7
--- /dev/null
+++ b/qemu/roms/SLOF/slof/fs/rtas/rtas-init.fs
@@ -0,0 +1,121 @@
+\ *****************************************************************************
+\ * Copyright (c) 2004, 2008 IBM Corporation
+\ * All rights reserved.
+\ * This program and the accompanying materials
+\ * are made available under the terms of the BSD License
+\ * which accompanies this distribution, and is available at
+\ * http://www.opensource.org/licenses/bsd-license.php
+\ *
+\ * Contributors:
+\ * IBM Corporation - initial implementation
+\ ****************************************************************************/
+
+\ (rtas-size) determines the size required for RTAS.
+\ It looks at the rtas binary in the flash and reads the rtas-size from
+\ its header at offset 8.
+: (rtas-size) ( -- rtas-size )
+ s" rtas" romfs-lookup dup 0=
+ ABORT" romfs-lookup for rtas failed"
+ drop 8 + @
+;
+
+(rtas-size) CONSTANT rtas-size
+
+: instantiate-rtas ( adr -- entry )
+ dup rtas-size erase
+ s" rtas" romfs-lookup 0=
+ ABORT" romfs-lookup for rtas failed"
+ rtas-config swap start-rtas ;
+
+here fff + fffffffffffff000 and here - allot
+here rtas-size allot CONSTANT rtas-start-addr
+
+rtas-start-addr instantiate-rtas CONSTANT rtas-entry-point
+
+: drone-rtas
+ rtas-start-addr
+ dup rtas-size erase
+ 2000000 start-rtas to rtas-entry-point
+;
+
+
+\ ffffffffffffffff CONSTANT rtas-entry-point
+
+\ rtas control block
+
+STRUCT
+ /l field rtas>token
+ /l field rtas>nargs
+ /l field rtas>nret
+ /l field rtas>args0
+ /l field rtas>args1
+ /l field rtas>args2
+ /l field rtas>args3
+ /l field rtas>args4
+ /l field rtas>args5
+ /l field rtas>args6
+ /l field rtas>args7
+ /l C * field rtas>args
+ /l field rtas>bla
+
+CONSTANT /rtas-control-block
+
+CREATE rtas-cb /rtas-control-block allot
+rtas-cb /rtas-control-block erase
+
+\ call-c ( p0 p1 p2 entry -- ret )
+
+: enter-rtas ( -- )
+ rtas-cb rtas-start-addr 0 rtas-entry-point call-c drop ;
+
+
+\ This is the structure of the RTAS function jump table in the C code:
+STRUCT
+ cell FIELD rtasfunctab>name
+ cell FIELD rtasfunctab>func
+ cell FIELD rtasfunctab>flags
+CONSTANT rtasfunctab-size
+
+\ Create RTAS token properties by analyzing the jump table in the C code:
+: rtas-create-token-properties ( -- )
+ rtas-start-addr 10 + @ rtas-start-addr + \ Get pointer to jump table
+ rtas-start-addr 18 + @ rtas-start-addr + l@ \ Get the number of entries
+ 0 DO
+ dup rtasfunctab>func @ 0<> \ function pointer must not be NULL
+ over rtasfunctab>flags @ 1 and 0= \ Check the only-internal flag
+ and
+ IF
+ i 1+ encode-int \ Create the token value
+ 2 pick rtasfunctab>name @ zcount \ Create the token name string
+ property \ Create the property
+ THEN
+ rtasfunctab-size + \ Proceed to the next entry
+ LOOP
+ drop
+;
+
+\ Get the RTAS token that corresponds to an RTAS property name:
+: rtas-get-token ( str len -- token|0 )
+ rtas-start-addr 10 + @ rtas-start-addr + \ Get pointer to jump table
+ rtas-start-addr 18 + @ rtas-start-addr + l@ \ Get the number of entries
+ 0 DO
+ dup rtasfunctab>name @ \ Get pointer to function name
+ dup 0<> \ function name must not be NULL
+ over zcount 5 pick = nip and \ Check if both strings have same length
+ IF
+ 3 pick 3 pick \ Make a copy of the token name string
+ comp 0=
+ IF
+ drop 2drop
+ i 1+ \ If the name matched, return the token
+ UNLOOP EXIT
+ THEN
+ ELSE
+ drop
+ THEN
+ rtasfunctab-size + \ Proceed to the next entry
+ LOOP
+ drop
+ ." RTAS token not found: " type cr
+ 0
+;
diff --git a/qemu/roms/SLOF/slof/fs/rtas/rtas-reboot.fs b/qemu/roms/SLOF/slof/fs/rtas/rtas-reboot.fs
new file mode 100644
index 000000000..a9539ecc1
--- /dev/null
+++ b/qemu/roms/SLOF/slof/fs/rtas/rtas-reboot.fs
@@ -0,0 +1,33 @@
+\ *****************************************************************************
+\ * Copyright (c) 2004, 2008 IBM Corporation
+\ * All rights reserved.
+\ * This program and the accompanying materials
+\ * are made available under the terms of the BSD License
+\ * which accompanies this distribution, and is available at
+\ * http://www.opensource.org/licenses/bsd-license.php
+\ *
+\ * Contributors:
+\ * IBM Corporation - initial implementation
+\ ****************************************************************************/
+
+: rtas-power-off ( x y -- status )
+ [ s" power-off" rtas-get-token ] LITERAL rtas-cb rtas>token l!
+ 2 rtas-cb rtas>nargs l!
+ 1 rtas-cb rtas>nret l!
+ rtas-cb rtas>args0 l!
+ rtas-cb rtas>args1 l!
+ enter-rtas
+ rtas-cb rtas>args2 l@
+;
+
+: power-off ( -- ) 0 0 rtas-power-off ;
+
+
+: rtas-system-reboot ( -- status )
+ [ s" system-reboot" rtas-get-token ] LITERAL rtas-cb rtas>token l!
+ 0 rtas-cb rtas>nargs l!
+ 1 rtas-cb rtas>nret l!
+ rtas-cb rtas>args0 l!
+ enter-rtas
+ rtas-cb rtas>args1 l@
+;
diff --git a/qemu/roms/SLOF/slof/fs/rtas/rtas-vpd.fs b/qemu/roms/SLOF/slof/fs/rtas/rtas-vpd.fs
new file mode 100644
index 000000000..7fb4b547d
--- /dev/null
+++ b/qemu/roms/SLOF/slof/fs/rtas/rtas-vpd.fs
@@ -0,0 +1,33 @@
+\ *****************************************************************************
+\ * Copyright (c) 2004, 2008 IBM Corporation
+\ * All rights reserved.
+\ * This program and the accompanying materials
+\ * are made available under the terms of the BSD License
+\ * which accompanies this distribution, and is available at
+\ * http://www.opensource.org/licenses/bsd-license.php
+\ *
+\ * Contributors:
+\ * IBM Corporation - initial implementation
+\ ****************************************************************************/
+
+: rtas-read-vpd ( offset length data -- status )
+ [ s" msg-read-vpd" rtas-get-token ] LITERAL rtas-cb rtas>token l!
+ 3 rtas-cb rtas>nargs l!
+ 1 rtas-cb rtas>nret l!
+ rtas-cb rtas>args2 l!
+ rtas-cb rtas>args1 l!
+ rtas-cb rtas>args0 l!
+ enter-rtas
+ rtas-cb rtas>args3 l@
+;
+
+: rtas-write-vpd ( offset length data -- status )
+ [ s" msg-write-vpd" rtas-get-token ] LITERAL rtas-cb rtas>token l!
+ 3 rtas-cb rtas>nargs l!
+ 1 rtas-cb rtas>nret l!
+ rtas-cb rtas>args2 l!
+ rtas-cb rtas>args1 l!
+ rtas-cb rtas>args0 l!
+ enter-rtas
+ rtas-cb rtas>args3 l@
+;
diff --git a/qemu/roms/SLOF/slof/fs/scsi-disk.fs b/qemu/roms/SLOF/slof/fs/scsi-disk.fs
new file mode 100644
index 000000000..197847147
--- /dev/null
+++ b/qemu/roms/SLOF/slof/fs/scsi-disk.fs
@@ -0,0 +1,324 @@
+\ *****************************************************************************
+\ * Copyright (c) 2011 IBM Corporation
+\ * All rights reserved.
+\ * This program and the accompanying materials
+\ * are made available under the terms of the BSD License
+\ * which accompanies this distribution, and is available at
+\ * http://www.opensource.org/licenses/bsd-license.php
+\ *
+\ * Contributors:
+\ * IBM Corporation - initial implementation
+\ ****************************************************************************/
+
+\ Create new VSCSI child device
+
+\ Create device
+new-device
+
+\ Set name
+s" disk" device-name
+
+s" block" device-type
+
+false VALUE scsi-disk-debug?
+
+\ Get SCSI bits
+scsi-open
+
+\ Send SCSI commands to controller
+
+: execute-scsi-command ( buf-addr buf-len dir cmd-addr cmd-len -- ... )
+ ( ... [ sense-buf sense-len ] stat )
+ " execute-scsi-command" $call-parent
+;
+
+: retry-scsi-command ( buf-addr buf-len dir cmd-addr cmd-len #retries -- ... )
+ ( ... 0 | [ sense-buf sense-len ] stat )
+ " retry-scsi-command" $call-parent
+;
+
+\ ---------------------------------\
+\ Common SCSI Commands and helpers \
+\ ---------------------------------\
+
+0 INSTANCE VALUE block-size
+0 INSTANCE VALUE max-transfer
+0 INSTANCE VALUE max-block-num
+0 INSTANCE VALUE is_cdrom
+INSTANCE VARIABLE deblocker
+
+\ This scratch area is made global for now as we only
+\ use it for small temporary commands such as inquiry
+\ read-capacity or media events
+CREATE scratch 100 allot
+CREATE cdb 10 allot
+
+: dump-scsi-error ( sense-buf sense-len stat name namelen -- )
+ ." SCSI-DISK: " my-self instance>path type ." ," type ." failed" cr
+ ." SCSI-DISK: Status " dup . .status-text
+ 0<> IF
+ ." Sense " scsi-get-sense-data dup . .sense-text
+ ." ASC " . ." ASCQ " . cr
+ ELSE drop THEN
+;
+
+: read-blocks ( addr block# #blocks -- #read )
+ scsi-disk-debug? IF
+ ." SCSI-DISK: read-blocks " .s cr
+ THEN
+
+ \ Bound check. This should probably be done by deblocker
+ \ but it doesn't at this point so do it here
+ 2dup + max-block-num > IF
+ ." SCSI-DISK: Access beyond end of device ! " cr
+ drop
+ dup max-block-num > IF
+ drop drop 0 EXIT
+ THEN
+ dup max-block-num swap -
+ THEN
+
+ dup block-size * ( addr block# #blocks len )
+ >r rot r> ( block# #blocks addr len )
+ 2swap ( addr len block# #blocks )
+ dup >r
+ cdb scsi-build-read-10 ( addr len )
+ r> -rot ( #blocks addr len )
+ scsi-dir-read cdb scsi-param-size 10
+ retry-scsi-command
+ ( #blocks [ sense-buf sense-len ] stat )
+ dup 0<> IF " read-blocks" dump-scsi-error -65 throw ELSE drop THEN
+;
+
+: (inquiry) ( size -- buffer | NULL )
+ dup cdb scsi-build-inquiry
+ \ 16 retries for inquiry to flush out any UAs
+ scratch swap scsi-dir-read cdb scsi-param-size 10 retry-scsi-command
+ \ Success ?
+ 0= IF scratch ELSE 2drop 0 THEN
+;
+
+: inquiry ( -- buffer | NULL )
+ scsi-disk-debug? IF
+ ." SCSI-DISK: inquiry " .s cr
+ THEN
+ d# 36 (inquiry) 0= IF 0 EXIT THEN
+ scratch inquiry-data>add-length c@ 5 +
+ (inquiry)
+;
+
+: read-capacity ( -- blocksize #blocks )
+ \ Now issue the read-capacity command
+ scsi-disk-debug? IF
+ ." SCSI-DISK: read-capacity " .s cr
+ THEN
+ \ Make sure that there are zeros in the buffer in case something goes wrong:
+ scratch 10 erase
+ cdb scsi-build-read-cap-10 scratch scsi-length-read-cap-10-data scsi-dir-read
+ cdb scsi-param-size 1 retry-scsi-command
+ \ Success ?
+ dup 0<> IF " read-capacity" dump-scsi-error 0 0 EXIT THEN
+ drop scratch scsi-get-capacity-10 1 +
+;
+
+100 CONSTANT test-unit-retries
+
+\ SCSI test-unit-read
+: test-unit-ready ( true | [ ascq asc sense-key false ] )
+ scsi-disk-debug? IF
+ ." SCSI-DISK: test-unit-ready " .s cr
+ THEN
+ cdb scsi-build-test-unit-ready
+ 0 0 0 cdb scsi-param-size test-unit-retries retry-scsi-command
+ \ stat == 0, return
+ 0= IF true EXIT THEN
+ \ check sense len, no sense -> return HW error
+ 0= IF drop 0 0 4 false EXIT THEN
+ \ get sense
+ scsi-get-sense-data false
+;
+
+
+: start-stop-unit ( state# -- true | false )
+ scsi-disk-debug? IF
+ ." SCSI-DISK: start-stop-unit " .s cr
+ THEN
+ cdb scsi-build-start-stop-unit
+ 0 0 0 cdb scsi-param-size 10 retry-scsi-command
+ \ Success ?
+ 0= IF true ELSE 2drop false THEN
+;
+
+: compare-sense ( ascq asc key ascq2 asc2 key2 -- true | false )
+ 3 pick = ( ascq asc key ascq2 asc2 keycmp )
+ swap 4 pick = ( ascq asc key ascq2 keycmp asccmp )
+ rot 5 pick = ( ascq asc key keycmp asccmp ascqcmp )
+ and and nip nip nip
+;
+
+\ -------------------------\
+\ CDROM specific functions \
+\ -------------------------\
+
+0 CONSTANT CDROM-READY
+1 CONSTANT CDROM-NOT-READY
+2 CONSTANT CDROM-NO-DISK
+3 CONSTANT CDROM-TRAY-OPEN
+4 CONSTANT CDROM-INIT-REQUIRED
+5 CONSTANT CDROM-TRAY-MAYBE-OPEN
+
+: cdrom-try-close-tray ( -- )
+ scsi-const-load start-stop-unit drop
+;
+
+: cdrom-must-close-tray ( -- )
+ scsi-const-load start-stop-unit not IF
+ ." Tray open !" cr -65 throw
+ THEN
+;
+
+: get-media-event ( -- true | false )
+ scsi-disk-debug? IF
+ ." SCSI-DISK: get-media-event " .s cr
+ THEN
+ cdb scsi-build-get-media-event
+ scratch scsi-length-media-event scsi-dir-read cdb scsi-param-size 1 retry-scsi-command
+ \ Success ?
+ 0= IF true ELSE 2drop false THEN
+;
+
+: cdrom-status ( -- status )
+ test-unit-ready
+ IF CDROM-READY EXIT THEN
+
+ scsi-disk-debug? IF
+ ." TestUnitReady sense: " 3dup . . . cr
+ THEN
+
+ 3dup 1 4 2 compare-sense IF
+ 3drop CDROM-NOT-READY EXIT
+ THEN
+
+ get-media-event IF
+ scratch w@ 4 >= IF
+ scratch 2 + c@ 04 = IF
+ scratch 5 + c@
+ dup 02 and 0<> IF drop 3drop CDROM-READY EXIT THEN
+ dup 01 and 0<> IF drop 3drop CDROM-TRAY-OPEN EXIT THEN
+ drop 3drop CDROM-NO-DISK EXIT
+ THEN
+ THEN
+ THEN
+
+ 3dup 2 4 2 compare-sense IF
+ 3drop CDROM-INIT-REQUIRED EXIT
+ THEN
+ over 4 = over 2 = and IF
+ \ Format in progress... what do we do ? Just ignore
+ 3drop CDROM-READY EXIT
+ THEN
+ over 3a = IF
+ 3drop CDROM-NO-DISK EXIT
+ THEN
+
+ \ Other error...
+ 3drop CDROM-TRAY-MAYBE-OPEN
+;
+
+: prep-cdrom ( -- ready? )
+ 5 0 DO
+ cdrom-status CASE
+ CDROM-READY OF UNLOOP true EXIT ENDOF
+ CDROM-NO-DISK OF ." No medium !" cr UNLOOP false EXIT ENDOF
+ CDROM-TRAY-OPEN OF cdrom-must-close-tray ENDOF
+ CDROM-INIT-REQUIRED OF cdrom-try-close-tray ENDOF
+ CDROM-TRAY-MAYBE-OPEN OF cdrom-try-close-tray ENDOF
+ ENDCASE
+ d# 1000 ms
+ LOOP
+ ." Drive not ready !" cr false
+;
+
+\ ------------------------\
+\ Disk specific functions \
+\ ------------------------\
+
+: prep-disk ( -- ready? )
+ test-unit-ready not IF
+ ." SCSI-DISK: Disk not ready ! "
+ ." Sense " dup .sense-text ." [" . ." ]"
+ ." ASC " . ." ASCQ " . cr
+ false EXIT THEN true
+;
+
+\ --------------------------\
+\ Standard device interface \
+\ --------------------------\
+
+: open ( -- true | false )
+ scsi-disk-debug? IF
+ ." SCSI-DISK: open [" .s ." ] unit is " my-unit . . ." [" .s ." ]" cr
+ THEN
+ my-unit " set-address" $call-parent
+
+ inquiry dup 0= IF drop false EXIT THEN
+ scsi-disk-debug? IF
+ ." ---- inquiry: ----" cr
+ dup 100 dump cr
+ ." ------------------" cr
+ THEN
+
+ \ Skip devices with PQ != 0
+ dup inquiry-data>peripheral c@ e0 and 0 <> IF
+ ." SCSI-DISK: Unsupported PQ != 0" cr
+ false EXIT
+ THEN
+
+ inquiry-data>peripheral c@ CASE
+ 5 OF true to is_cdrom ENDOF
+ 7 OF true to is_cdrom ENDOF
+ ENDCASE
+
+ scsi-disk-debug? IF
+ is_cdrom IF
+ ." SCSI-DISK: device treated as CD-ROM" cr
+ ELSE
+ ." SCSI-DISK: device treated as disk" cr
+ THEN
+ THEN
+
+ is_cdrom IF prep-cdrom ELSE prep-disk THEN
+ not IF false EXIT THEN
+
+ " max-transfer" $call-parent to max-transfer
+
+ read-capacity to max-block-num to block-size
+ max-block-num 0= block-size 0= OR IF
+ ." SCSI-DISK: Failed to get disk capacity!" cr
+ FALSE EXIT
+ THEN
+
+ scsi-disk-debug? IF
+ ." Capacity: " max-block-num . ." blocks of " block-size . cr
+ THEN
+
+ 0 0 " deblocker" $open-package dup deblocker ! dup IF
+ " disk-label" find-package IF
+ my-args rot interpose
+ THEN
+ THEN 0<>
+;
+
+: close ( -- )
+ deblocker @ close-package ;
+
+: seek ( pos.lo pos.hi -- status )
+ s" seek" deblocker @ $call-method ;
+
+: read ( addr len -- actual )
+ s" read" deblocker @ $call-method ;
+
+\ Get rid of SCSI bits
+scsi-close
+
+finish-device
diff --git a/qemu/roms/SLOF/slof/fs/scsi-host-helpers.fs b/qemu/roms/SLOF/slof/fs/scsi-host-helpers.fs
new file mode 100644
index 000000000..579ce37f9
--- /dev/null
+++ b/qemu/roms/SLOF/slof/fs/scsi-host-helpers.fs
@@ -0,0 +1,127 @@
+\ This file is meant to be included by SCSI hosts to provide
+\ helpers such as retry-scsi-command
+
+\ Returns 1 for retry, 0 for return with no error and
+\ -1 for return with an error
+\
+: check-retry-sense? ( sense-buf sense-len -- retry? )
+ \ Check if the sense-len is at least 8 bytes
+ 8 < IF -1 EXIT THEN
+
+ \ Fixed sense record, look for filemark etc...
+ dup sense-data>response-code c@ 7e and 70 = IF
+ dup sense-data>sense-key c@ e0 and IF drop -1 EXIT THEN
+ THEN
+
+ \ Get sense data
+ scsi-get-sense-data? IF ( ascq asc sense-key )
+ \ No sense or recoverable, return success
+ dup 2 < IF 3drop 0 EXIT THEN
+ \ not ready and unit attention, retry
+ dup 2 = swap 6 = or nip nip IF 1 EXIT THEN
+ THEN
+ \ Return failure
+ -1
+;
+
+\ This is almost as the standard retry-command but returns
+\ additionally the length of the returned sense information
+\
+\ The hw-err? field is gone, stat is -1 for a HW error, and
+\ the sense data is provided iff stat is CHECK_CONDITION (02)
+\
+\ Additionally we wait 10ms between retries
+\
+0 INSTANCE VALUE rcmd-buf-addr
+0 INSTANCE VALUE rcmd-buf-len
+0 INSTANCE VALUE rcmd-dir
+0 INSTANCE VALUE rcmd-cmd-addr
+0 INSTANCE VALUE rcmd-cmd-len
+
+: retry-scsi-command ( buf-addr buf-len dir cmd-addr cmd-len #retries -- ... )
+ ( ... 0 | [ sense-buf sense-len ] stat )
+ >r \ stash #retries
+ to rcmd-cmd-len to rcmd-cmd-addr to rcmd-dir to rcmd-buf-len to rcmd-buf-addr
+ 0 \ dummy status & sense
+ r> \ retreive #retries ( stat #retries )
+ 0 DO
+ \ drop previous status & sense
+ 0<> IF 2drop THEN
+
+ \ Restore arguments
+ rcmd-buf-addr
+ rcmd-buf-len
+ rcmd-dir
+ rcmd-cmd-addr
+ rcmd-cmd-len
+
+ \ Send command
+ execute-scsi-command ( [ sense-buf sense-len ] stat )
+
+ \ Success ?
+ dup 0= IF LEAVE THEN
+
+ \ HW error ?
+ dup -1 = IF LEAVE THEN
+
+ \ Check condition ?
+ dup 2 = IF ( sense-buf sense-len stat )
+ >r \ stash stat ( sense-buf sense len )
+ 2dup
+ check-retry-sense? ( sense-buf sense-len retry? )
+ r> swap \ unstash stat ( sense-buf sense-len stat retry? )
+ \ Check retry? result
+ CASE
+ 0 OF 3drop 0 LEAVE ENDOF \ Swallow error, return 0
+ -1 OF LEAVE ENDOF \ No retry
+ ENDCASE
+ ELSE \ Anything other than busy -> exit
+ dup 8 <> IF LEAVE THEN
+ THEN
+ a ms
+ LOOP
+;
+
+\ -----------------------------------------------------------
+\ Some command helpers
+\ -----------------------------------------------------------
+\
+\ TODO: Get rid of global "sector" and instead return an
+\ allocated block for the caller to free
+
+CREATE sector d# 512 allot
+CREATE cdb 10 allot
+
+: (inquiry) ( size -- buffer | NULL )
+ dup cdb scsi-build-inquiry
+ \ 16 retries for inquiry to flush out any UAs
+ sector swap scsi-dir-read cdb scsi-param-size 10 retry-scsi-command
+ \ Success ?
+ 0= IF sector ELSE 2drop 0 THEN
+;
+
+\ Read the initial 36bytes and then decide how much more is to be read
+: inquiry ( -- buffer | NULL )
+ d# 36 (inquiry) 0= IF 0 EXIT THEN
+ sector inquiry-data>add-length c@ 5 +
+ (inquiry)
+;
+
+: report-luns ( -- [ sector ] true | false )
+ 200 cdb scsi-build-report-luns
+ \ 16 retries to flush out any UAs
+ sector 200 scsi-dir-read cdb scsi-param-size 10 retry-scsi-command
+ \ Success ?
+ 0= IF sector true ELSE drop false THEN
+;
+
+\ This routine creates a disk alias for the first found disk/cdrom
+: make-disk-alias ( $name srplun -- )
+ >r 2dup r> -rot ( $name srplun $name)
+ find-alias 0<> IF 4drop exit THEN
+ get-node node>path
+ 20 allot
+ " /disk@" string-cat ( $name srplun npath npathl )
+ rot base @ >r hex (u.) r> base ! string-cat ( $name $diskpath )
+ set-alias
+;
diff --git a/qemu/roms/SLOF/slof/fs/scsi-loader.fs b/qemu/roms/SLOF/slof/fs/scsi-loader.fs
new file mode 100644
index 000000000..fec1f78dc
--- /dev/null
+++ b/qemu/roms/SLOF/slof/fs/scsi-loader.fs
@@ -0,0 +1,77 @@
+\ *****************************************************************************
+\ * Copyright (c) 2004, 2008 IBM Corporation
+\ * All rights reserved.
+\ * This program and the accompanying materials
+\ * are made available under the terms of the BSD License
+\ * which accompanies this distribution, and is available at
+\ * http://www.opensource.org/licenses/bsd-license.php
+\ *
+\ * Contributors:
+\ * IBM Corporation - initial implementation
+\ ****************************************************************************/
+
+\ **************************************
+\ Last change: MiR 13.11.2007 10:55:57
+\ **************************************
+
+: .ansi-attr-off 1b emit ." [0m" ; \ ESC Sequence: all terminal attributes off
+: .ansi-blue 1b emit ." [34m" ; \ ESC Sequence: foreground-color = blue
+: .ansi-green 1b emit ." [32m" ; \ ESC Sequence: foreground-color = green
+: .ansi-red 1b emit ." [31m" ; \ ESC Sequence: foreground-color = green
+: .ansi-bold 1b emit ." [1m" ; \ ESC Sequence: foreground-color bold
+
+false VALUE scsi-supp-present?
+
+: scsi-xt-err ." SCSI-ERROR (Intern) " ;
+' scsi-xt-err VALUE scsi-open-xt \ preset with an invalid token
+
+\ *************************************
+\ utility to show all active word-lists
+\ *************************************
+: .wordlists ( -- )
+ .ansi-red
+ get-order ( -- wid1 .. widn n )
+ dup space 28 emit .d ." word lists : "
+ 0 DO
+ . 08 emit 2c emit
+ LOOP
+ 08 emit \ 'bs'
+ 29 emit \ ')'
+ cr space 28 emit
+ ." Context: " context dup .
+ @ 5b emit . 8 emit 5d emit
+ space
+ ." / Current: " current .
+ .ansi-attr-off
+ cr
+;
+
+\ *************************************
+\ utility to show first word-lists
+\ *************************************
+: .context ( num -- )
+ .ansi-red
+ space
+ 5b emit
+ 23 emit . 3a emit
+ context @
+ . 8 emit 5d emit space
+ .ansi-attr-off
+;
+
+\ ****************************************************************************
+\ open scsi-support by adding a new word list on top of search path
+\ first check if scsi-support.fs must be included (first call)
+\ when open use execution pointer to access version in new word list
+\ ****************************************************************************
+: scsi-open ( -- )
+ scsi-supp-present? NOT
+ IF
+ s" scsi-support.fs" included ( xt-open )
+ to scsi-open-xt ( )
+ true to scsi-supp-present?
+ THEN
+ scsi-open-xt execute
+;
+
+
diff --git a/qemu/roms/SLOF/slof/fs/scsi-probe-helpers.fs b/qemu/roms/SLOF/slof/fs/scsi-probe-helpers.fs
new file mode 100644
index 000000000..6aec8b159
--- /dev/null
+++ b/qemu/roms/SLOF/slof/fs/scsi-probe-helpers.fs
@@ -0,0 +1,95 @@
+\ This file is meant to be included by SCSI hosts to provide
+\ probing helpers - scsi-find-disks
+
+: wrapped-inquiry ( -- true | false )
+ inquiry 0= IF false EXIT THEN
+ \ Skip devices with PQ != 0
+ sector inquiry-data>peripheral c@ e0 and 0 =
+;
+
+: scsi-read-lun ( addr -- lun true | false )
+ dup c@ C0 AND CASE
+ 40 OF w@-be 3FFF AND TRUE ENDOF
+ 0 OF w@-be TRUE ENDOF
+ dup dup OF ." Unsupported LUN format = " . cr FALSE ENDOF
+ ENDCASE
+;
+
+: vscsi-report-luns ( -- array ndev )
+ \ array of pointers, up to 8 devices
+ dev-max-target 3 << alloc-mem dup
+ 0 ( devarray devcur ndev )
+ dev-max-target 0 DO
+ i 0 dev-generate-srplun (set-target)
+ report-luns nip IF
+ sector l@ ( devarray devcur ndev size )
+ sector 8 + swap ( devarray devcur ndev lunarray size )
+ dup 8 + dup alloc-mem ( devarray devcur ndev lunarray size size+ mem )
+ dup rot 0 fill ( devarray devcur ndev lunarray size mem )
+ dup >r swap move r> ( devarray devcur ndev mem )
+ dup sector l@ 3 >> 0 ?DO ( devarray devcur ndev mem memcur )
+ dup dup scsi-read-lun IF
+ j swap dev-generate-srplun swap x! 8 +
+ ELSE
+ 2drop
+ THEN
+ LOOP drop
+ rot ( devarray ndev mem devcur )
+ dup >r x! r> 8 + ( devarray ndev devcur )
+ swap 1 +
+ ELSE
+ dev-max-target 1 = IF
+ \ Some USB MSC devices do not implement report
+ \ luns. That will stall the bulk pipe. These devices are
+ \ single lun devices, report it accordingly
+
+ ( devarray devcur ndev )
+ 16 alloc-mem ( devarray devcur ndev mem )
+ dup 16 0 fill ( devarray devcur ndev mem )
+ dup 0 0 dev-generate-srplun swap x! ( devarray devcur ndev mem )
+ rot x! ( devarray ndev )
+ 1 +
+ UNLOOP EXIT
+ THEN
+ THEN
+ LOOP
+ nip
+;
+
+: make-media-alias ( $name srplun -- )
+ >r
+ get-next-alias ?dup IF
+ r> make-disk-alias
+ ELSE
+ r> drop
+ THEN
+;
+
+: scsi-find-disks ( -- )
+ ." SCSI: Looking for devices" cr
+ vscsi-report-luns
+ 0 ?DO
+ dup x@
+ BEGIN
+ dup x@
+ dup 0= IF drop TRUE ELSE
+ (set-target) wrapped-inquiry IF
+ ." " current-target (u.) type ." "
+ \ XXX FIXME: Check top bits to ignore unsupported units
+ \ and maybe provide better printout & more cases
+ \ XXX FIXME: Actually check for LUNs
+ sector inquiry-data>peripheral c@ CASE
+ 0 OF ." DISK : " " disk" current-target make-media-alias ENDOF
+ 5 OF ." CD-ROM : " " cdrom" current-target make-media-alias ENDOF
+ 7 OF ." OPTICAL : " " cdrom" current-target make-media-alias ENDOF
+ e OF ." RED-BLOCK: " " disk" current-target make-media-alias ENDOF
+ dup dup OF ." ? (" . 8 emit 29 emit 5 spaces ENDOF
+ ENDCASE
+ sector .inquiry-text cr
+ THEN
+ 8 + FALSE
+ THEN
+ UNTIL drop
+ 8 +
+ LOOP drop
+;
diff --git a/qemu/roms/SLOF/slof/fs/scsi-support.fs b/qemu/roms/SLOF/slof/fs/scsi-support.fs
new file mode 100644
index 000000000..3e65c8781
--- /dev/null
+++ b/qemu/roms/SLOF/slof/fs/scsi-support.fs
@@ -0,0 +1,847 @@
+\ *****************************************************************************
+\ * Copyright (c) 2004, 2008 IBM Corporation
+\ * All rights reserved.
+\ * This program and the accompanying materials
+\ * are made available under the terms of the BSD License
+\ * which accompanies this distribution, and is available at
+\ * http://www.opensource.org/licenses/bsd-license.php
+\ *
+\ * Contributors:
+\ * IBM Corporation - initial implementation
+\ ****************************************************************************/
+
+\ ************************************************
+\ create a new scsi word-list named 'scsi-words'
+\ ************************************************
+vocabulary scsi-words \ create new word list named 'scsi-words'
+also scsi-words definitions \ place next definitions into new list
+
+\ for some commands specific parameters are used, which normally
+\ need not to be altered. These values are preset at include time
+\ or explicit by a call of 'scsi-supp-init'
+false value scsi-param-debug \ common debugging flag
+d# 0 value scsi-param-size \ length of CDB processed last
+h# 0 value scsi-param-control \ control word for CDBs as defined in SAM-4
+d# 0 value scsi-param-errors \ counter for detected errors
+
+\ utility to increment error counter
+: scsi-inc-errors
+ scsi-param-errors 1 + to scsi-param-errors
+;
+
+\ ***************************************************************************
+\ SCSI-Command: TEST UNIT READY
+\ Type: Primary Command (SPC-3 clause 6.33)
+\ ***************************************************************************
+\ Forth Word: scsi-build-test-unit-ready ( cdb -- )
+\ ***************************************************************************
+\ checks if a device is ready to receive commands
+\ ***************************************************************************
+\ command code:
+00 CONSTANT scsi-cmd-test-unit-ready
+\ CDB structure:
+STRUCT
+ /c FIELD test-unit-ready>operation-code \ 00h
+ 4 FIELD test-unit-ready>reserved \ unused
+ /c FIELD test-unit-ready>control \ control byte as specified in SAM-4
+CONSTANT scsi-length-test-unit-ready
+
+\ cdb build:
+\ all fields are zeroed
+: scsi-build-test-unit-ready ( cdb -- )
+ dup scsi-length-test-unit-ready erase ( cdb )
+ scsi-param-control swap test-unit-ready>control c! ( )
+ scsi-length-test-unit-ready to scsi-param-size \ update CDB length
+;
+
+\ ***************************************************************************
+\ SCSI-Command: REPORT LUNS
+\ Type: Primary Command
+\ ***************************************************************************
+\ Forth Word: scsi-build-report-luns ( cdb -- )
+\ ***************************************************************************
+\ report all LUNs supported by a device
+\ ***************************************************************************
+\ command code:
+a0 CONSTANT scsi-cmd-report-luns
+\ CDB structure:
+STRUCT
+ /c FIELD report-luns>operation-code \ a0h
+ 1 FIELD report-luns>reserved \ unused
+ /c FIELD report-luns>select-report \ report select byte
+ 3 FIELD report-luns>reserved2 \ unused
+ /l FIELD report-luns>alloc-length \ report length
+ 1 FIELD report-luns>reserved3 \ unused
+ /c FIELD report-luns>control \ control byte
+CONSTANT scsi-length-report-luns
+
+\ cdb build:
+\ all fields are zeroed
+: scsi-build-report-luns ( alloc-len cdb -- )
+ dup scsi-length-report-luns erase \ 12 bytes CDB
+ scsi-cmd-report-luns over ( alloc-len cdb cmd cdb )
+ report-luns>operation-code c! ( alloc-len cdb )
+ scsi-param-control over report-luns>control c! ( alloc-len cdb )
+ report-luns>alloc-length l! \ size of Data-In Buffer
+ scsi-length-report-luns to scsi-param-size \ update CDB length
+;
+
+\ ***************************************************************************
+\ SCSI-Command: REQUEST SENSE
+\ Type: Primary Command (SPC-3 clause 6.27)
+\ ***************************************************************************
+\ Forth Word: scsi-build-request-sense ( cdb -- )
+\ ***************************************************************************
+\ for return data a buffer of at least 252 bytes must be present!
+\ see spec: SPC-3 (r23) / clauses 4.5 and 6.27
+\ ***************************************************************************
+\ command code:
+03 CONSTANT scsi-cmd-request-sense
+\ CDB structure:
+STRUCT
+ /c FIELD request-sense>operation-code \ 03h
+ 3 FIELD request-sense>reserved \ unused
+ /c FIELD request-sense>allocation-length \ buffer-length for data response
+ /c FIELD request-sense>control \ control byte as specified in SAM-4
+CONSTANT scsi-length-request-sense
+
+\ cdb build:
+: scsi-build-request-sense ( alloc-len cdb -- )
+ >r ( alloc-len ) ( R: -- cdb )
+ r@ scsi-length-request-sense erase ( alloc-len )
+ scsi-cmd-request-sense r@ ( alloc-len cmd cdb )
+ request-sense>operation-code c! ( alloc-len )
+ dup d# 252 > \ buffer length too big ?
+ IF
+ scsi-inc-errors
+ drop d# 252 \ replace with 252
+ ELSE
+ dup d# 18 < \ allocated buffer too small ?
+ IF
+ scsi-inc-errors
+ drop 0 \ reject return data
+ THEN
+ THEN ( alloclen )
+ r@ request-sense>allocation-length c! ( )
+ scsi-param-control r> request-sense>control c! ( alloc-len cdb ) ( R: cdb -- )
+ scsi-length-request-sense to scsi-param-size \ update CDB length
+;
+
+\ ----------------------------------------
+\ SCSI-Response: SENSE_DATA
+\ ----------------------------------------
+70 CONSTANT scsi-response(request-sense-0)
+71 CONSTANT scsi-response(request-sense-1)
+
+STRUCT
+ /c FIELD sense-data>response-code \ 70h (current errors) or 71h (deferred errors)
+ /c FIELD sense-data>obsolete
+ /c FIELD sense-data>sense-key \ D3..D0 = sense key, D7 = EndOfMedium
+ /l FIELD sense-data>info
+ /c FIELD sense-data>alloc-length \ <= 244 (for max size)
+ /l FIELD sense-data>command-info
+ /c FIELD sense-data>asc \ additional sense key
+ /c FIELD sense-data>ascq \ additional sense key qualifier
+ /c FIELD sense-data>unit-code
+ 3 FIELD sense-data>key-specific
+ /c FIELD sense-data>add-sense-bytes \ start of appended extra bytes
+CONSTANT scsi-length-sense-data
+
+\ ----------------------------------------
+\ get from SCSI response block:
+\ - Additional Sense Code Qualifier
+\ - Additional Sense Code
+\ - sense-key
+\ ----------------------------------------
+\ Forth Word: scsi-get-sense-data ( addr -- ascq asc sense-key )
+\ ----------------------------------------
+: scsi-get-sense-data ( addr -- ascq asc sense-key )
+ >r ( R: -- addr )
+ r@ sense-data>response-code c@ 7f and 72 >= IF
+ r@ 3 + c@ ( ascq )
+ r@ 2 + c@ ( ascq asc )
+ r> 1 + c@ 0f and ( ascq asc sense-key )
+ ELSE
+ r@ sense-data>ASCQ c@ ( ascq )
+ r@ sense-data>ASC c@ ( ascq asc )
+ r> sense-data>sense-key c@ 0f and ( ascq asc sense-key ) ( R: addr -- )
+ THEN
+;
+
+\ --------------------------------------------------------------------------
+\ Forth Word: scsi-get-sense-data? ( addr -- false | ascq asc sense-key true )
+\ --------------------------------------------------------------------------
+: scsi-get-sense-data? ( addr -- false | ascq asc sense-key true )
+ dup
+ sense-data>response-code c@
+ 7e AND dup 70 = swap 72 = or \ Response code (some devices have MSB set)
+ IF
+ scsi-get-sense-data TRUE
+ ELSE
+ drop FALSE \ drop addr
+ THEN
+
+;
+
+\ --------------------------------------------------------------------------
+\ Forth Word: scsi-get-sense-ID? ( addr -- false | sense-ID true )
+\ same as scsi-get-sense-data? but returns
+\ a single word composed of: sense-key<<16 | asc<<8 | ascq
+\ --------------------------------------------------------------------------
+: scsi-get-sense-ID? ( addr -- false | ascq asc sense-key true )
+ dup
+ sense-data>response-code c@
+ 7e AND 70 = \ Response code (some devices have MSB set)
+ IF
+ scsi-get-sense-data ( ascq asc sense-key )
+ 10 lshift ( ascq asc sense-key16 )
+ swap 8 lshift or ( ascq sense-key+asc )
+ swap or \ 24-bit sense-ID ( sense-key+asc+ascq )
+ TRUE
+ ELSE
+ drop FALSE \ drop addr
+ THEN
+;
+
+\ ***************************************************************************
+\ SCSI-Command: INQUIRY
+\ Type: Primary Command (SPC-3 clause 6.4)
+\ ***************************************************************************
+\ Forth Word: scsi-build-inquiry ( alloc-len cdb -- )
+\ ***************************************************************************
+\ command code:
+12 CONSTANT scsi-cmd-inquiry
+
+\ CDB structure
+STRUCT
+ /c FIELD inquiry>operation-code \ 0x12
+ /c FIELD inquiry>reserved \ + EVPD-Bit (vital product data)
+ /c FIELD inquiry>page-code \ page code for vital product data (if used)
+ /w FIELD inquiry>allocation-length \ length of Data-In-Buffer
+ /c FIELD inquiry>control \ control byte as specified in SAM-4
+CONSTANT scsi-length-inquiry
+
+\ Setup command INQUIRY
+: scsi-build-inquiry ( alloc-len cdb -- )
+ dup scsi-length-inquiry erase \ 6 bytes CDB
+ scsi-cmd-inquiry over ( alloc-len cdb cmd cdb )
+ inquiry>operation-code c! ( alloc-len cdb )
+ scsi-param-control over inquiry>control c! ( alloc-len cdb )
+ inquiry>allocation-length w! \ size of Data-In Buffer
+ scsi-length-inquiry to scsi-param-size \ update CDB length
+;
+
+\ ----------------------------------------
+\ block structure of inquiry return data:
+\ ----------------------------------------
+STRUCT
+ /c FIELD inquiry-data>peripheral \ qualifier and device type
+ /c FIELD inquiry-data>reserved1
+ /c FIELD inquiry-data>version \ supported SCSI version (1,2,3)
+ /c FIELD inquiry-data>data-format
+ /c FIELD inquiry-data>add-length \ total block length - 4
+ /c FIELD inquiry-data>flags1
+ /c FIELD inquiry-data>flags2
+ /c FIELD inquiry-data>flags3
+ d# 8 FIELD inquiry-data>vendor-ident \ vendor string
+ d# 16 FIELD inquiry-data>product-ident \ device string
+ /l FIELD inquiry-data>product-revision \ revision string
+ d# 20 FIELD inquiry-data>vendor-specific \ optional params
+\ can be increased by vendor specific fields
+CONSTANT scsi-length-inquiry-data
+
+\ ***************************************************************************
+\ SCSI-Command: READ CAPACITY (10)
+\ Type: Block Command (SBC-3 clause 5.12)
+\ ***************************************************************************
+\ Forth Word: scsi-build-read-capacity-10 ( cdb -- )
+\ ***************************************************************************
+25 CONSTANT scsi-cmd-read-capacity-10 \ command code
+
+STRUCT \ SCSI 10-byte CDB structure
+ /c FIELD read-cap-10>operation-code
+ /c FIELD read-cap-10>reserved1
+ /l FIELD read-cap-10>lba
+ /w FIELD read-cap-10>reserved2
+ /c FIELD read-cap-10>reserved3
+ /c FIELD read-cap-10>control
+CONSTANT scsi-length-read-cap-10
+
+\ Setup READ CAPACITY (10) command
+: scsi-build-read-cap-10 ( cdb -- )
+ dup scsi-length-read-cap-10 erase ( cdb )
+ scsi-cmd-read-capacity-10 over ( cdb cmd cdb )
+ read-cap-10>operation-code c! ( cdb )
+ scsi-param-control swap read-cap-10>control c! ( )
+ scsi-length-read-cap-10 to scsi-param-size \ update CDB length
+;
+
+\ ----------------------------------------
+\ get from SCSI response block:
+\ - Additional Sense Code Qualifier
+\ - Additional Sense Code
+\ - sense-key
+\ ----------------------------------------
+\ Forth Word: scsi-get-capacity-10 ( addr -- block-size #blocks )
+\ ----------------------------------------
+\ Block structure
+STRUCT
+ /l FIELD read-cap-10-data>max-lba
+ /l FIELD read-cap-10-data>block-size
+CONSTANT scsi-length-read-cap-10-data
+
+\ get data-block
+: scsi-get-capacity-10 ( addr -- block-size #blocks )
+ >r ( addr -- ) ( R: -- addr )
+ r@ read-cap-10-data>block-size l@ ( block-size )
+ r> read-cap-10-data>max-lba l@ ( block-size #blocks ) ( R: addr -- )
+;
+
+\ ***************************************************************************
+\ SCSI-Command: READ CAPACITY (16)
+\ Type: Block Command (SBC-3 clause 5.13)
+\ ***************************************************************************
+\ Forth Word: scsi-build-read-capacity-16 ( cdb -- )
+\ ***************************************************************************
+9e CONSTANT scsi-cmd-read-capacity-16 \ command code
+
+STRUCT \ SCSI 16-byte CDB structure
+ /c FIELD read-cap-16>operation-code
+ /c FIELD read-cap-16>service-action
+ /l FIELD read-cap-16>lba-high
+ /l FIELD read-cap-16>lba-low
+ /l FIELD read-cap-16>allocation-length \ should be 32
+ /c FIELD read-cap-16>reserved
+ /c FIELD read-cap-16>control
+CONSTANT scsi-length-read-cap-16
+
+\ Setup READ CAPACITY (16) command
+: scsi-build-read-cap-16 ( cdb -- )
+ >r r@ ( R: -- cdb )
+ scsi-length-read-cap-16 erase ( )
+ scsi-cmd-read-capacity-16 ( code )
+ r@ read-cap-16>operation-code c! ( )
+ 10 r@ read-cap-16>service-action c!
+ d# 32 \ response size 32 bytes
+ r@ read-cap-16>allocation-length l! ( )
+ scsi-param-control r> read-cap-16>control c! ( R: cdb -- )
+ scsi-length-read-cap-16 to scsi-param-size \ update CDB length
+;
+
+\ ----------------------------------------
+\ get from SCSI response block:
+\ - Block Size (in Bytes)
+\ - Number of Blocks
+\ ----------------------------------------
+\ Forth Word: scsi-get-capacity-16 ( addr -- block-size #blocks )
+\ ----------------------------------------
+\ Block structure for return data
+STRUCT
+ /l FIELD read-cap-16-data>max-lba-high \ upper quadlet of Max-LBA
+ /l FIELD read-cap-16-data>max-lba-low \ lower quadlet of Max-LBA
+ /l FIELD read-cap-16-data>block-size \ logical block length in bytes
+ /c FIELD read-cap-16-data>protect \ type of protection (4 bits)
+ /c FIELD read-cap-16-data>exponent \ logical blocks per physical blocks
+ /w FIELD read-cap-16-data>lowest-aligned \ first LBA of a phsy. block
+ 10 FIELD read-cap-16-data>reserved \ 16 reserved bytes
+CONSTANT scsi-length-read-cap-16-data \ results in 32
+
+\ get data-block
+: scsi-get-capacity-16 ( addr -- block-size #blocks )
+ >r ( R: -- addr )
+ r@ read-cap-16-data>block-size l@ ( block-size )
+ r@ read-cap-16-data>max-lba-high l@ ( block-size #blocks-high )
+ d# 32 lshift ( block-size #blocks-upper )
+ r> read-cap-16-data>max-lba-low l@ + ( block-size #blocks ) ( R: addr -- )
+;
+
+\ ***************************************************************************
+\ SCSI-Command: MODE SENSE (10)
+\ Type: Primary Command (SPC-3 clause 6.10)
+\ ***************************************************************************
+\ Forth Word: scsi-build-mode-sense-10 ( alloc-len subpage page cdb -- )
+\ ***************************************************************************
+5a CONSTANT scsi-cmd-mode-sense-10
+
+\ CDB structure
+STRUCT
+ /c FIELD mode-sense-10>operation-code
+ /c FIELD mode-sense-10>res-llbaa-dbd-res
+ /c FIELD mode-sense-10>pc-page-code \ page code + page control
+ /c FIELD mode-sense-10>sub-page-code
+ 3 FIELD mode-sense-10>reserved2
+ /w FIELD mode-sense-10>allocation-length
+ /c FIELD mode-sense-10>control
+CONSTANT scsi-length-mode-sense-10
+
+: scsi-build-mode-sense-10 ( alloc-len subpage page cdb -- )
+ >r ( alloc-len subpage page ) ( R: -- cdb )
+ r@ scsi-length-mode-sense-10 erase \ 10 bytes CDB
+ scsi-cmd-mode-sense-10 ( alloc-len subpage page cmd )
+ r@ mode-sense-10>operation-code c! ( alloc-len subpage page )
+ 10 r@ mode-sense-10>res-llbaa-dbd-res c! \ long LBAs accepted
+ r@ mode-sense-10>pc-page-code c! ( alloc-len subpage )
+ r@ mode-sense-10>sub-page-code c! ( alloc-len )
+ r@ mode-sense-10>allocation-length w! ( )
+
+ scsi-param-control r> mode-sense-10>control c! ( R: cdb -- )
+ scsi-length-mode-sense-10 to scsi-param-size \ update CDB length
+;
+
+\ return data processing
+\ (see spec: SPC-3 clause 7.4.3)
+
+STRUCT
+ /w FIELD mode-sense-10-data>head-length
+ /c FIELD mode-sense-10-data>head-medium
+ /c FIELD mode-sense-10-data>head-param
+ /c FIELD mode-sense-10-data>head-longlba
+ /c FIELD mode-sense-10-data>head-reserved
+ /w FIELD mode-sense-10-data>head-descr-len
+CONSTANT scsi-length-mode-sense-10-data
+
+\ ****************************************
+\ This function shows the mode page header
+\ helpful for further analysis
+\ ****************************************
+: .mode-sense-data ( addr -- )
+ cr
+ dup mode-sense-10-data>head-length
+ w@ ." Mode Length: " .d space
+ dup mode-sense-10-data>head-medium
+ c@ ." / Medium Type: " .d space
+ dup mode-sense-10-data>head-longlba
+ c@ ." / Long LBA: " .d space
+ mode-sense-10-data>head-descr-len
+ w@ ." / Descr. Length: " .d
+;
+
+\ ***************************************************************************
+\ SCSI-Command: READ (6)
+\ Type: Block Command (SBC-3 clause 5.7)
+\ ***************************************************************************
+\ Forth Word: scsi-build-read-6 ( block# #blocks cdb -- )
+\ ***************************************************************************
+\ this SCSI command uses 21 bits to represent start LBA
+\ and 8 bits to specify the numbers of blocks to read
+\ The value of 0 blocks is interpreted as 256 blocks
+\
+\ command code
+08 CONSTANT scsi-cmd-read-6
+
+\ CDB structure
+STRUCT
+ /c FIELD read-6>operation-code \ 08h
+ /c FIELD read-6>block-address-msb \ upper 5 bits
+ /w FIELD read-6>block-address \ lower 16 bits
+ /c FIELD read-6>length \ number of blocks to read
+ /c FIELD read-6>control \ CDB control
+CONSTANT scsi-length-read-6
+
+: scsi-build-read-6 ( block# #blocks cdb -- )
+ >r ( block# #blocks ) ( R: -- cdb )
+ r@ scsi-length-read-6 erase \ 6 bytes CDB
+ scsi-cmd-read-6 r@ read-6>operation-code c! ( block# #blocks )
+
+ \ check block count to read (#blocks)
+ dup d# 255 > \ #blocks exceeded limit ?
+ IF
+ scsi-inc-errors
+ drop 1 \ replace with any valid number
+ THEN
+ r@ read-6>length c! \ set #blocks to read
+
+ \ check starting block number (block#)
+ dup 1fffff > \ check address upper limit
+ IF
+ scsi-inc-errors
+ drop \ remove original block#
+ 1fffff \ replace with any valid address
+ THEN
+ dup d# 16 rshift
+ r@ read-6>block-address-msb c! \ set upper 5 bits
+ ffff and
+ r@ read-6>block-address w! \ set lower 16 bits
+ scsi-param-control r> read-6>control c! ( R: cdb -- )
+ scsi-length-read-6 to scsi-param-size \ update CDB length
+;
+
+\ ***************************************************************************
+\ SCSI-Command: READ (10)
+\ Type: Block Command (SBC-3 clause 5.8)
+\ ***************************************************************************
+\ Forth Word: scsi-build-read-10 ( block# #blocks cdb -- )
+\ ***************************************************************************
+\ command code
+28 CONSTANT scsi-cmd-read-10
+
+\ CDB structure
+STRUCT
+ /c FIELD read-10>operation-code
+ /c FIELD read-10>protect
+ /l FIELD read-10>block-address \ logical block address (32bits)
+ /c FIELD read-10>group
+ /w FIELD read-10>length \ transfer length (16-bits)
+ /c FIELD read-10>control
+CONSTANT scsi-length-read-10
+
+: scsi-build-read-10 ( block# #blocks cdb -- )
+ >r ( block# #blocks ) ( R: -- cdb )
+ r@ scsi-length-read-10 erase \ 10 bytes CDB
+ scsi-cmd-read-10 r@ read-10>operation-code c! ( block# #blocks )
+ r@ read-10>length w! ( block# )
+ r@ read-10>block-address l! ( )
+ scsi-param-control r> read-10>control c! ( R: cdb -- )
+ scsi-length-read-10 to scsi-param-size \ update CDB length
+;
+
+\ ***************************************************************************
+\ SCSI-Command: READ (12)
+\ Type: Block Command (SBC-3 clause 5.9)
+\ ***************************************************************************
+\ Forth Word: scsi-build-read-12 ( block# #blocks cdb -- )
+\ ***************************************************************************
+\ command code
+a8 CONSTANT scsi-cmd-read-12
+
+\ CDB structure
+STRUCT
+ /c FIELD read-12>operation-code \ code: a8
+ /c FIELD read-12>protect \ RDPROTECT, DPO, FUA, FUA_NV
+ /l FIELD read-12>block-address \ lba
+ /l FIELD read-12>length \ transfer length (32bits)
+ /c FIELD read-12>group \ group number
+ /c FIELD read-12>control
+CONSTANT scsi-length-read-12
+
+: scsi-build-read-12 ( block# #blocks cdb -- )
+ >r ( block# #blocks ) ( R: -- cdb )
+ r@ scsi-length-read-12 erase \ 12 bytes CDB
+ scsi-cmd-read-12 r@ read-12>operation-code c! ( block# #blocks )
+ r@ read-12>length l! ( block# )
+ r@ read-12>block-address l! ( )
+ scsi-param-control r> read-12>control c! ( R: cdb -- )
+ scsi-length-read-12 to scsi-param-size \ update CDB length
+;
+
+\ ***************************************************************************
+\ SCSI-Command: READ with autodetection of required command
+\ read(10) or read(12) depending on parameter size
+\ (read(6) removed because obsolete in some cases (USB))
+\ Type: Block Command
+\ ***************************************************************************
+\ Forth Word: scsi-build-read? ( block# #blocks cdb -- )
+\
+\ +----------------+---------------------------|
+\ | block# (lba) | #block (transfer-length) |
+\ +-----------+----------------+---------------------------|
+\ | read-6 | 16-Bits | 8 Bits |
+\ | read-10 | 32-Bits | 16 Bits |
+\ | read-12 | 32-Bits | 32 Bits |
+\ ***************************************************************************
+: scsi-build-read? ( block# #blocks cdb -- length )
+ over ( block# #blocks cdb #blocks )
+ fffe > \ tx-length (#blocks) exceeds 16-bit limit ?
+ IF
+ scsi-build-read-12 ( block# #blocks cdb -- )
+ scsi-length-read-12 ( length )
+ ELSE ( block# #blocks cdb )
+ scsi-build-read-10 ( block# #blocks cdb -- )
+ scsi-length-read-10 ( length )
+ THEN
+;
+
+\ ***************************************************************************
+\ SCSI-Command: START STOP UNIT
+\ Type: Block Command (SBC-3 clause 5.19)
+\ ***************************************************************************
+\ Forth Word: scsi-build-start-stop-unit ( state# cdb -- )
+\ ***************************************************************************
+\ command code
+1b CONSTANT scsi-cmd-start-stop-unit
+
+\ CDB structure
+STRUCT
+ /c FIELD start-stop-unit>operation-code
+ /c FIELD start-stop-unit>immed
+ /w FIELD start-stop-unit>reserved
+ /c FIELD start-stop-unit>pow-condition
+ /c FIELD start-stop-unit>control
+CONSTANT scsi-length-start-stop-unit
+
+\ START/STOP constants
+\ (see spec: SBC-3 clause 5.19)
+f1 CONSTANT scsi-const-active-power \ param used for start-stop-unit
+f2 CONSTANT scsi-const-idle-power \ param used for start-stop-unit
+f3 CONSTANT scsi-const-standby-power \ param used for start-stop-unit
+3 CONSTANT scsi-const-load \ param used for start-stop-unit
+2 CONSTANT scsi-const-eject \ param used for start-stop-unit
+1 CONSTANT scsi-const-start
+0 CONSTANT scsi-const-stop
+
+: scsi-build-start-stop-unit ( state# cdb -- )
+ >r ( state# ) ( R: -- cdb )
+ r@ scsi-length-start-stop-unit erase \ 6 bytes CDB
+ scsi-cmd-start-stop-unit r@ start-stop-unit>operation-code c!
+ dup 3 >
+ IF
+ 4 lshift \ shift to upper nibble
+ THEN ( state )
+ r@ start-stop-unit>pow-condition c! ( )
+ scsi-param-control r> start-stop-unit>control c! ( R: cdb -- )
+ scsi-length-start-stop-unit to scsi-param-size \ update CDB length
+;
+
+\ ***************************************************************************
+\ SCSI-Command: SEEK(10)
+\ Type: Block Command (obsolete)
+\ ***************************************************************************
+\ Forth Word: scsi-build-seek ( state# cdb -- )
+\ Obsolete function (last listed in spec SBC / Nov. 1997)
+\ implemented only for the sake of completeness
+\ ***************************************************************************
+\ command code
+2b CONSTANT scsi-cmd-seek
+
+\ CDB structure
+STRUCT
+ /c FIELD seek>operation-code
+ /c FIELD seek>reserved1
+ /l FIELD seek>lba
+ 3 FIELD seek>reserved2
+ /c FIELD seek>control
+CONSTANT scsi-length-seek
+
+: scsi-build-seek ( lba cdb -- )
+ >r ( lba ) ( R: -- cdb )
+ r@ scsi-length-seek erase \ 10 bytes CDB
+ scsi-cmd-seek r@ seek>operation-code c!
+ r> seek>lba l! ( ) ( R: cdb -- )
+ scsi-length-seek to scsi-param-size \ update CDB length
+;
+
+\ ****************************************************************************
+\ CDROM media event stuff
+\ ****************************************************************************
+
+STRUCT
+ /w FIELD media-event-data-len
+ /c FIELD media-event-nea-class
+ /c FIELD media-event-supp-class
+ /l FIELD media-event-data
+CONSTANT scsi-length-media-event
+
+: scsi-build-get-media-event ( cdb -- )
+ dup c erase ( cdb )
+ 4a over c! ( cdb )
+ 01 over 1 + c!
+ 10 over 4 + c!
+ 08 over 8 + c!
+ drop
+;
+
+
+
+\ ***************************************************************************
+\ SCSI-Utility: .sense-code
+\ ***************************************************************************
+\ this utility prints a string associated to the sense code
+\ see specs: SPC-3/r23 clause 4.5.6
+\ ***************************************************************************
+: .sense-text ( scode -- )
+ case
+ 0 OF s" OK" ENDOF
+ 1 OF s" RECOVERED ERR" ENDOF
+ 2 OF s" NOT READY" ENDOF
+ 3 OF s" MEDIUM ERROR" ENDOF
+ 4 OF s" HARDWARE ERR" ENDOF
+ 5 OF s" ILLEGAL REQUEST" ENDOF
+ 6 OF s" UNIT ATTENTION" ENDOF
+ 7 OF s" DATA PROTECT" ENDOF
+ 8 OF s" BLANK CHECK" ENDOF
+ 9 OF s" VENDOR SPECIFIC" ENDOF
+ a OF s" COPY ABORTED" ENDOF
+ b OF s" ABORTED COMMAND" ENDOF
+ d OF s" VOLUME OVERFLOW" ENDOF
+ e OF s" MISCOMPARE" ENDOF
+ dup OF s" UNKNOWN" ENDOF
+ endcase
+ 5b emit type 5d emit
+;
+
+\ ***************************************************************************
+\ SCSI-Utility: .status-code
+\ ***************************************************************************
+\ this utility prints a string associated to the status code
+\ see specs: SAM-3/r14 clause 5.3
+\ ***************************************************************************
+: .status-text ( stat -- )
+ case
+ 00 OF s" GOOD" ENDOF
+ 02 OF s" CHECK CONDITION" ENDOF
+ 04 OF s" CONDITION MET" ENDOF
+ 08 OF s" BUSY" ENDOF
+ 18 OF s" RESERVATION CONFLICT" ENDOF
+ 28 OF s" TASK SET FULL" ENDOF
+ 30 OF s" ACA ACTIVE" ENDOF
+ 40 OF s" TASK ABORTED" ENDOF
+ dup OF s" UNKNOWN" ENDOF
+ endcase
+ 5b emit type 5d emit
+;
+
+\ ***************************************************************************
+\ SCSI-Utility: .capacity-text
+\ ***************************************************************************
+\ utility that shows total capacity on screen by use of the return data
+\ from read-capacity calculation is SI conform (base 10)
+\ ***************************************************************************
+\ sub function to print a 3 digit decimal
+\ number with 2 post decimal positions xxx.yy
+: .dec3-2 ( prenum postnum -- )
+ swap
+ base @ >r \ save actual base setting
+ decimal \ show decimal values
+ 4 .r 2e emit
+ dup 9 <= IF 30 emit THEN .d \ 3 pre-decimal, right aligned
+ r> base ! \ restore base
+;
+
+: .capacity-text ( block-size #blocks -- )
+ scsi-param-debug \ debugging flag set ?
+ IF \ show additional info
+ 2dup
+ cr
+ ." LBAs: " .d \ highest logical block number
+ ." / Block-Size: " .d
+ ." / Total Capacity: "
+ THEN
+ * \ calculate total capacity
+ dup d# 1000000000000 >= \ check terabyte limit
+ IF
+ d# 1000000000000 /mod
+ swap
+ d# 10000000000 / \ limit remainder to two digits
+ .dec3-2 ." TB" \ show terabytes as xxx.yy
+ ELSE
+ dup d# 1000000000 >= \ check gigabyte limit
+ IF
+ d# 1000000000 /mod
+ swap
+ d# 10000000 /
+ .dec3-2 ." GB" \ show gigabytes as xxx.yy
+ ELSE
+ dup d# 1000000 >=
+ IF
+ d# 1000000 /mod \ check mega byte limit
+ swap
+ d# 10000 /
+ .dec3-2 ." MB" \ show megabytes as xxx.yy
+ ELSE
+ dup d# 1000 >= \ check kilo byte limit
+ IF
+ d# 1000 /mod
+ swap
+ d# 10 /
+ .dec3-2 ." kB"
+ ELSE
+ .d ." Bytes"
+ THEN
+ THEN
+ THEN
+ THEN
+;
+
+\ ***************************************************************************
+\ SCSI-Utility: .inquiry-text ( addr -- )
+\ ***************************************************************************
+\ utility that shows:
+\ vendor-ident product-ident and revision
+\ from an inquiry return data block (addr)
+\ ***************************************************************************
+: .inquiry-text ( addr -- )
+ 22 emit \ enclose text with "
+ dup inquiry-data>vendor-ident 8 type space
+ dup inquiry-data>product-ident 10 type space
+ inquiry-data>product-revision 4 type
+ 22 emit
+;
+
+\ ***************************************************************************
+\ SCSI-Utility: scsi-supp-init ( -- )
+\ ***************************************************************************
+\ utility that helps to ensure that parameters are set to valid values
+: scsi-supp-init ( -- )
+ false to scsi-param-debug \ no debug strings
+ h# 0 to scsi-param-size
+ h# 0 to scsi-param-control \ common CDB control byte
+ d# 0 to scsi-param-errors \ local errors (param limits)
+;
+
+\ ***************************************************************************
+\ Constants used by SCSI controller's execute-scsi-command
+\ ***************************************************************************
+true CONSTANT scsi-dir-read
+false CONSTANT scsi-dir-write
+
+
+\ ***************************************************************************
+\ scsi loader
+\ ***************************************************************************
+0 VALUE scsi-context \ addr of word list on top
+
+
+\ ****************************************************************************
+\ open scsi-support by adding a new word list on top of search path
+\ precondition: scsi-support.fs must have been included
+\ ****************************************************************************
+: scsi-init ( -- )
+ also scsi-words \ append scsi word-list
+ context to scsi-context \ save for close process
+ scsi-supp-init \ preset all scsi-param-xxx values
+ scsi-param-debug
+ IF
+ space ." SCSI-SUPPORT OPENED" cr
+ .wordlists
+ THEN
+;
+
+\ ****************************************************************************
+\ close scsi-session and remove scsi word list (if exists)
+\ ****************************************************************************
+\ if 'previous' is used without a preceding 'also' all forth words are lost !
+\ ****************************************************************************
+: scsi-close ( -- )
+\ FIXME This only works if scsi-words is the last vocabulary on the stack
+\ Instead we could use get-order to find us on the "wordlist stack",
+\ remove us and write the wordlist stack back with set-order.
+\ BUT: Is this worth the effort?
+
+ scsi-param-debug
+ IF
+ space ." Closing SCSI-SUPPORT .. " cr
+ THEN
+ context scsi-context = \ scsi word list still active ?
+ IF
+ scsi-param-errors 0<> \ any errors occurred ?
+ IF
+ cr ." ** WARNING: " scsi-param-errors .d
+ ." SCSI Errors occurred ** " cr
+ THEN
+ previous \ remove scsi word list on top
+ 0 to scsi-context \ prevent from being misinterpreted
+ ELSE
+ cr ." ** WARNING: Trying to close non-open SCSI-SUPPORT (1) ** " cr
+ THEN
+ scsi-param-debug
+ IF
+ .wordlists
+ THEN
+;
+
+
+s" scsi-init" $find drop \ return execution pointer, when included
+
+previous \ remove scsi word list from search path
+definitions \ place next definitions into previous list
+
diff --git a/qemu/roms/SLOF/slof/fs/search.fs b/qemu/roms/SLOF/slof/fs/search.fs
new file mode 100644
index 000000000..3acca2f11
--- /dev/null
+++ b/qemu/roms/SLOF/slof/fs/search.fs
@@ -0,0 +1,89 @@
+\ *****************************************************************************
+\ * Copyright (c) 2004, 2008 IBM Corporation
+\ * All rights reserved.
+\ * This program and the accompanying materials
+\ * are made available under the terms of the BSD License
+\ * which accompanies this distribution, and is available at
+\ * http://www.opensource.org/licenses/bsd-license.php
+\ *
+\ * Contributors:
+\ * IBM Corporation - initial implementation
+\ ****************************************************************************/
+\
+\ Copyright 2002,2003,2004 Segher Boessenkool <segher@kernel.crashing.org>
+\
+
+
+\ stuff we should already have:
+
+: linked ( var -- ) here over @ , swap ! ;
+
+HEX
+
+\ \ \
+\ \ \ Wordlists
+\ \ \
+
+VARIABLE wordlists forth-wordlist wordlists !
+
+\ create a new wordlist
+: wordlist ( -- wid ) here wordlists linked 0 , ;
+
+
+\ \ \
+\ \ \ Search order
+\ \ \
+
+10 CONSTANT max-in-search-order \ should define elsewhere
+\ CREATE search-order max-in-search-order cells allot \ stack of wids \ is in engine now
+\ search-order VALUE context \ top of stack \ is in engine now
+
+: also ( -- ) clean-hash context dup cell+ dup to context >r @ r> ! ;
+: previous ( -- ) clean-hash context cell- to context ;
+: only ( -- ) clean-hash search-order to context ( minimal-wordlist search-order ! ) ;
+: seal ( -- ) clean-hash context @ search-order dup to context ! ;
+
+: get-order ( -- wid_n .. wid_1 n )
+ context >r search-order BEGIN dup r@ u<= WHILE
+ dup @ swap cell+ REPEAT r> drop
+ search-order - cell / ;
+: set-order ( wid_n .. wid_1 n -- ) \ XXX: special cases for 0, -1
+ clean-hash 1- cells search-order + dup to context
+ BEGIN dup search-order u>= WHILE
+ dup >r ! r> cell- REPEAT drop ;
+
+
+\ \ \
+\ \ \ Compilation wordlist
+\ \ \
+
+: get-current ( -- wid ) current ;
+: set-current ( wid -- ) to current ;
+
+: definitions ( -- ) context @ set-current ;
+
+
+\ \ \
+\ \ \ Vocabularies
+\ \ \
+
+: VOCABULARY ( C: "name" -- ) ( -- ) CREATE wordlist drop DOES> clean-hash context ! ;
+\ : VOCABULARY ( C: "name" -- ) ( -- ) wordlist CREATE , DOES> @ context ! ;
+\ XXX we'd like to swap forth and forth-wordlist around (for .voc 's sake)
+: FORTH ( -- ) clean-hash forth-wordlist context ! ;
+
+: .voc ( wid -- ) \ display name for wid \ needs work ( body> or something like that )
+ dup cell- @ ['] vocabulary ['] forth within IF
+ 2 cells - >name name>string type ELSE u. THEN space ;
+: vocs ( -- ) \ display all wordlist names
+ cr wordlists BEGIN @ dup WHILE dup .voc REPEAT drop ;
+: order ( -- )
+ cr ." context: " get-order 0 ?DO .voc LOOP
+ cr ." current: " get-current .voc ;
+
+
+
+
+\ some handy helper
+: voc-find ( wid -- 0 | link )
+ clean-hash cell+ @ (find) clean-hash ;
diff --git a/qemu/roms/SLOF/slof/fs/slof-logo.fs b/qemu/roms/SLOF/slof/fs/slof-logo.fs
new file mode 100644
index 000000000..53d318447
--- /dev/null
+++ b/qemu/roms/SLOF/slof/fs/slof-logo.fs
@@ -0,0 +1,20 @@
+\ *****************************************************************************
+\ * Copyright (c) 2004, 2008 IBM Corporation
+\ * All rights reserved.
+\ * This program and the accompanying materials
+\ * are made available under the terms of the BSD License
+\ * which accompanies this distribution, and is available at
+\ * http://www.opensource.org/licenses/bsd-license.php
+\ *
+\ * Contributors:
+\ * IBM Corporation - initial implementation
+\ ****************************************************************************/
+
+: .slof-logo
+ cr ." ..`. .. ....... .. ...... ......."
+ cr ." ..`...`''.`'. .''``````..''. .`''```''`. `''``````"
+ cr ." .`` .:' ': `''..... .''. ''` .''..''......."
+ cr ." ``.':.';. ``````''`.''. .''. ''``''`````'`"
+ cr ." ``.':':` .....`''.`'`...... `'`.....`''.`'` "
+ cr ." .`.`'`` .'`'`````. ``'''''' ``''`'''`. `'` "
+;
diff --git a/qemu/roms/SLOF/slof/fs/sms/sms-load.fs b/qemu/roms/SLOF/slof/fs/sms/sms-load.fs
new file mode 100644
index 000000000..8e4db8060
--- /dev/null
+++ b/qemu/roms/SLOF/slof/fs/sms/sms-load.fs
@@ -0,0 +1,70 @@
+\ *****************************************************************************
+\ * Copyright (c) 2004, 2008 IBM Corporation
+\ * All rights reserved.
+\ * This program and the accompanying materials
+\ * are made available under the terms of the BSD License
+\ * which accompanies this distribution, and is available at
+\ * http://www.opensource.org/licenses/bsd-license.php
+\ *
+\ * Contributors:
+\ * IBM Corporation - initial implementation
+\ ****************************************************************************/
+
+false VALUE (sms-loaded?)
+
+false value (sms-available?)
+
+s" sms.fs" romfs-lookup IF true to (sms-available?) drop THEN
+
+(sms-available?) [IF]
+
+#include "packages/sms.fs"
+
+\ Initialize SMS NVRAM handling.
+#include "sms-nvram.fs"
+
+\ Dynamically load sms code from the romfs file
+\ Assumption is that skeleton sms package already exists
+\ but aside of open & close, all other methods are in a romfs file (sms.fs)
+\ Here we open the package and load the rest of the functionality
+
+\ After that, one needs to find-device and execute sms-start method
+\ The shorthand for that is given as (global) sms-start word
+
+: $sms-node s" /packages/sms" ;
+
+: (sms-init-package) ( -- true|false )
+ (sms-loaded?) ?dup IF EXIT THEN
+ $sms-node ['] find-device catch IF 2drop false EXIT THEN
+ s" sms.fs" [COMPILE] included
+ device-end
+ true dup to (sms-loaded?)
+;
+
+\ External wrapper for sms package method
+: (sms-evaluate) ( addr len -- )
+ (sms-init-package) not IF
+ cr ." SMS is not available." cr 2drop exit
+ THEN
+
+ s" Entering SMS ..." type
+ disable-watchdog
+ reset-dual-emit
+
+ \ if we only had execute-device-method...
+ 2>r $sms-node find-device
+ 2r> evaluate
+ device-end
+ vpd-boot-import
+;
+
+: sms-start ( -- ) s" sms-start" (sms-evaluate) ;
+: sms-fru-replacement ( -- ) s" sms-fru-replacement" (sms-evaluate) ;
+
+[ELSE]
+
+: sms-start ( -- ) cr ." SMS is not available." cr ;
+: sms-fru-replacement ( -- ) cr ." SMS FRU replacement is not available." cr ;
+
+[THEN]
+
diff --git a/qemu/roms/SLOF/slof/fs/sms/sms-nvram.fs b/qemu/roms/SLOF/slof/fs/sms/sms-nvram.fs
new file mode 100644
index 000000000..4f5d6ddd5
--- /dev/null
+++ b/qemu/roms/SLOF/slof/fs/sms/sms-nvram.fs
@@ -0,0 +1,124 @@
+\ *****************************************************************************
+\ * Copyright (c) 2004, 2008 IBM Corporation
+\ * All rights reserved.
+\ * This program and the accompanying materials
+\ * are made available under the terms of the BSD License
+\ * which accompanies this distribution, and is available at
+\ * http://www.opensource.org/licenses/bsd-license.php
+\ *
+\ * Contributors:
+\ * IBM Corporation - initial implementation
+\ ****************************************************************************/
+
+\ Initialize SMS NVRAM handling.
+
+: sms-init-nvram ( -- )
+ nvram-partition-type-sms get-nvram-partition IF
+ cr ." Could not find SMS partition in NVRAM - "
+ nvram-partition-type-sms s" SMS" d# 1024 new-nvram-partition
+ ABORT" Failed to create SMS NVRAM partition"
+ 2dup erase-nvram-partition drop
+
+ 2dup s" lang" s" 1" internal-set-env drop
+
+ 2dup s" tftp-retries" s" 5" internal-set-env drop
+ 2dup s" tftp-blocksize" s" 512" internal-set-env drop
+ 2dup s" bootp-retries" s" 255" internal-set-env drop
+ 2dup s" client" s" 000.000.000.000" internal-set-env drop
+ 2dup s" server" s" 000.000.000.000" internal-set-env drop
+ 2dup s" gateway" s" 000.000.000.000" internal-set-env drop
+ 2dup s" netmask" s" 255.255.255.000" internal-set-env drop
+ 2dup s" net-protocol" s" 0" internal-set-env drop
+ 2dup s" net-flags" s" 0" internal-set-env drop
+ 2dup s" net-device" s" 0" internal-set-env drop
+ 2dup s" net-client-name" s" " internal-set-env drop
+
+ 2dup s" scsi-spinup" s" 6" internal-set-env drop
+ 2dup s" scsi-id-0" s" 7" internal-set-env drop
+ 2dup s" scsi-id-1" s" 7" internal-set-env drop
+ 2dup s" scsi-id-2" s" 7" internal-set-env drop
+ 2dup s" scsi-id-3" s" 7" internal-set-env drop
+ ." created" cr
+ THEN
+ s" sms-nvram-partition" $2constant
+;
+
+sms-init-nvram
+
+: sms-add-env ( "name" "value" -- ) sms-nvram-partition 2rot 2rot internal-add-env drop ;
+: sms-set-env ( "name" "value" -- ) sms-nvram-partition 2rot 2rot internal-set-env drop ;
+: sms-get-env ( "name" -- "value" TRUE | FALSE) sms-nvram-partition 2swap internal-get-env ;
+
+: sms-get-net-device ( -- n ) s" net-device" sms-get-env IF $dnumber IF 0 THEN ELSE 0 THEN ;
+: sms-set-net-device ( n -- ) (.d) s" net-device" 2swap sms-set-env ;
+
+: sms-get-net-flags ( -- n ) s" net-flags" sms-get-env IF $dnumber IF 0 THEN ELSE 0 THEN ;
+: sms-set-net-flags ( n -- ) (.d) s" net-flags" 2swap sms-set-env ;
+
+: sms-get-net-protocol ( -- n ) s" net-protocol" sms-get-env IF $dnumber IF 0 THEN ELSE 0 THEN ;
+: sms-set-net-protocol ( n -- ) (.d) s" net-protocol" 2swap sms-set-env ;
+
+: sms-get-lang ( -- n ) s" lang" sms-get-env IF $dnumber IF 1 THEN ELSE 1 THEN ;
+: sms-set-lang ( n -- ) (.d) s" lang" 2swap sms-set-env ;
+
+: sms-get-bootp-retries ( -- n ) s" bootp-retries" sms-get-env IF $dnumber IF 255 THEN ELSE 255 THEN ;
+: sms-set-bootp-retries ( n -- ) (.d) s" bootp-retries" 2swap sms-set-env ;
+
+: sms-get-tftp-retries ( -- n ) s" tftp-retries" sms-get-env IF $dnumber IF 5 THEN ELSE 5 THEN ;
+: sms-set-tftp-retries ( n -- ) (.d) s" tftp-retries" 2swap sms-set-env ;
+
+: sms-get-tftp-blocksize ( -- n ) s" tftp-blocksize" sms-get-env IF $dnumber IF 5 THEN ELSE 5 THEN ;
+: sms-set-tftp-blocksize ( n -- ) (.d) s" tftp-blocksize" 2swap sms-set-env ;
+
+: sms-get-client ( -- FALSE | n1 n2 n3 n4 TRUE ) s" client" sms-get-env IF (ipaddr) ELSE false THEN ;
+: sms-set-client ( n1 n2 n3 n4 -- ) (ipformat) s" client" 2swap sms-set-env ;
+
+: sms-get-server ( -- FALSE | n1 n2 n3 n4 TRUE ) s" server" sms-get-env IF (ipaddr) ELSE false THEN ;
+: sms-set-server ( n1 n2 n3 n4 -- ) (ipformat) s" server" 2swap sms-set-env ;
+
+: sms-get-gateway ( -- FALSE | n1 n2 n3 n4 TRUE ) s" gateway" sms-get-env IF (ipaddr) ELSE false THEN ;
+: sms-set-gateway ( n1 n2 n3 n4 -- ) (ipformat) s" gateway" 2swap sms-set-env ;
+
+: sms-get-subnet ( -- FALSE | n1 n2 n3 n4 TRUE ) s" netmask" sms-get-env IF (ipaddr) ELSE false THEN ;
+: sms-set-subnet ( n1 n2 n3 n4 -- ) (ipformat) s" netmask" 2swap sms-set-env ;
+
+: sms-get-client-name ( -- FALSE | addr len TRUE ) s" net-client-name" sms-get-env ;
+: sms-set-client-name ( addr len -- ) s" net-client-name" 2swap sms-set-env ;
+
+: sms-get-scsi-spinup ( -- n ) s" scsi-spinup" sms-get-env IF $dnumber IF 6 THEN ELSE 6 THEN ;
+: sms-set-scsi-spinup ( n -- ) (.d) s" scsi-spinup" 2swap sms-set-env ;
+
+: sms-get-scsi-id ( n -- id ) s" scsi-id-" rot (.) $cat sms-get-env IF $dnumber IF 6 THEN ELSE 6 THEN ;
+: sms-set-scsi-id ( id n -- ) swap (.d) rot s" scsi-id-" rot (.) $cat sms-set-env ;
+
+
+\ generates the boot-file part of the boot string
+
+: sms-get-net-boot-file ( -- addr len )
+ \ the format is
+ \ :[bootp,]siaddr,filename,ciaddr,giaddr,bootp-retries,tftp-retries
+ \ we choose dhcp as a default!
+ s" net" sms-get-net-device (.) $cat
+ s" :dhcp," $cat
+ sms-get-server IF (ipformat) $cat THEN
+ s" ," $cat
+ sms-get-client-name IF $cat THEN
+ s" ," $cat
+ sms-get-client IF (ipformat) $cat THEN
+ s" ," $cat
+ sms-get-gateway IF (ipformat) $cat THEN
+ s" ," $cat
+ \ If the number of retries is 255 (max), assume default timeout (10min)
+ sms-get-bootp-retries dup ff <> IF (.) $cat ELSE drop THEN
+ s" ," $cat
+ sms-get-tftp-retries (.) $cat
+ \ now write the string to the boot path
+ dup IF
+ \ This could be considered a memory leak, but it is only
+ \ executed once for booting so it is not a problem
+ strdup ( s" :" 2swap $cat strdup )
+ THEN
+;
+
+' sms-get-net-boot-file to furnish-boot-file
+
diff --git a/qemu/roms/SLOF/slof/fs/stack.fs b/qemu/roms/SLOF/slof/fs/stack.fs
new file mode 100644
index 000000000..0f7e097bf
--- /dev/null
+++ b/qemu/roms/SLOF/slof/fs/stack.fs
@@ -0,0 +1,57 @@
+\ *****************************************************************************
+\ * Copyright (c) 2004, 2008 IBM Corporation
+\ * All rights reserved.
+\ * This program and the accompanying materials
+\ * are made available under the terms of the BSD License
+\ * which accompanies this distribution, and is available at
+\ * http://www.opensource.org/licenses/bsd-license.php
+\ *
+\ * Contributors:
+\ * IBM Corporation - initial implementation
+\ ****************************************************************************/
+
+
+\ Example:
+\
+\ To get a 30 element stack, go:
+\
+\ 0 > 30 new-stack my-stack
+\ 0 > my-stack
+\ 0 > 20 push 30 push
+\ 0 > pop pop .s
+
+0 value current-stack
+
+: new-stack ( cells <>name -- )
+ create >r here ( here R: cells )
+ dup r@ 2 + cells ( here here bytes R: cells )
+ dup allot erase ( here R: cells)
+ cell+ r> ( here+1cell cells )
+ swap ! ( )
+ DOES> to current-stack
+;
+
+: reset-stack ( -- )
+ 0 current-stack !
+;
+
+: stack-depth ( -- depth )
+ current-stack @
+;
+
+: push ( value -- )
+ current-stack @
+ current-stack cell+ @ over <= ABORT" Stack overflow"
+ cells
+ 1 current-stack +!
+ current-stack 2 cells + + !
+;
+
+: pop ( -- value )
+ current-stack @ 0= ABORT" Stack underflow"
+ current-stack @ cells
+ current-stack + cell+ @
+ -1 current-stack +!
+;
+
+
diff --git a/qemu/roms/SLOF/slof/fs/start-up.fs b/qemu/roms/SLOF/slof/fs/start-up.fs
new file mode 100644
index 000000000..f1488fa38
--- /dev/null
+++ b/qemu/roms/SLOF/slof/fs/start-up.fs
@@ -0,0 +1,171 @@
+\ *****************************************************************************
+\ * Copyright (c) 2004, 2008 IBM Corporation
+\ * All rights reserved.
+\ * This program and the accompanying materials
+\ * are made available under the terms of the BSD License
+\ * which accompanies this distribution, and is available at
+\ * http://www.opensource.org/licenses/bsd-license.php
+\ *
+\ * Contributors:
+\ * IBM Corporation - initial implementation
+\ ****************************************************************************/
+
+: (boot) ( -- )
+ s" Executing following boot-command: "
+ boot-command $cat nvramlog-write-string-cr
+ s" boot-command" evaluate \ get boot command
+ ['] evaluate catch ?dup IF \ and execute it
+ ." boot attempt returned: "
+ abort"-str @ count type cr
+ nip nip \ drop string from 1st evaluate
+ throw
+ THEN
+;
+
+\ Note: The following ESC sequences has to be handled:
+\ 1B 4F 50
+\ 1B 5B 31 31 7E
+
+\ Reads and converts the function key.
+\ key = F1 -- n = 1
+: (function-key) ( -- n )
+ key? IF
+ key CASE
+ 50 OF 1 ENDOF
+ 7e OF 1 ENDOF
+ dup OF 0 ENDOF
+ ENDCASE
+ THEN
+;
+
+\ Checks if an ESC sequence occurs.
+: (esc-sequence) ( -- n )
+ key? IF
+ key CASE
+ 4f OF (function-key) ENDOF
+ 5b OF
+ key key (function-key) ENDOF
+ dup OF 0 ENDOF
+ ENDCASE
+ THEN
+;
+
+: (s-pressed) ( -- )
+ s" An 's' has been pressed. Entering Open Firmware Prompt"
+ nvramlog-write-string-cr
+;
+
+: (boot?) ( -- )
+ of-prompt? not auto-boot? and IF
+ (boot)
+ THEN
+;
+
+
+#include "sms/sms-load.fs"
+
+
+\ Watchdog will be rearmed during load if use-load-watchdog variable is TRUE
+TRUE VALUE use-load-watchdog?
+
+1 value my-boot-dev
+1 value digit-val
+0 value boot-dev-no
+
+: boot-selected
+ 1 to my-boot-dev
+ BEGIN parse-word dup WHILE
+ boot-dev-no my-boot-dev = IF
+ s" boot " 2swap $cat
+ ['] evaluate catch ?dup IF \ and execute it
+ ." boot attempt returned: "
+ abort"-str @ count type cr
+ throw
+ THEN
+ 0 0 load-list 2!
+ UNLOOP EXIT
+ ELSE
+ 2drop
+ THEN
+ my-boot-dev 1 + to my-boot-dev
+ REPEAT 2drop 0 0 load-list 2!
+
+ (boot)
+;
+
+: boot-start
+ \ Remove multiple F12 key presses if any
+ BEGIN key? WHILE
+ key drop
+ REPEAT
+
+ decimal
+ BEGIN parse-word dup WHILE
+ my-boot-dev (u.) s" . " $cat type 2dup type ." : " de-alias type cr
+ my-boot-dev 1 + to my-boot-dev
+ REPEAT 2drop 0 0 load-list 2!
+
+ cr BEGIN KEY dup emit
+ dup isdigit IF
+ dup 30 - to digit-val
+ boot-dev-no a * digit-val + to boot-dev-no
+ THEN
+ d = UNTIL
+
+ boot-dev-no my-boot-dev < IF
+ s" boot-selected " s" $bootdev" evaluate $cat strdup evaluate
+ ELSE
+ ." Invalid choice!" cr
+ THEN
+ hex
+;
+
+: boot-menu-start
+ ." Select boot device:" cr cr
+ s" boot-start " s" $bootdev" evaluate $cat strdup evaluate
+;
+
+: boot-menu-enabled? ( -- true|false )
+ s" qemu,boot-menu" get-chosen IF
+ decode-int 1 = IF
+ 2drop TRUE EXIT
+ THEN
+ 2drop
+ THEN
+ FALSE
+;
+
+: f12-pressed?
+ 34 = >r 32 = r> and IF
+ TRUE
+ ELSE
+ FALSE
+ THEN
+;
+
+: start-it ( -- )
+ key? IF
+ key CASE
+ [char] s OF (s-pressed) ENDOF
+ 1b OF
+ (esc-sequence) CASE
+ 1 OF
+ console-clean-fifo
+ f12-pressed? boot-menu-enabled? and IF
+ boot-menu-start
+ ELSE
+ (boot?)
+ THEN
+ ENDOF
+ dup OF (boot?) ENDOF
+ ENDCASE
+ ENDOF
+ dup OF (boot?) ENDOF
+ ENDCASE
+ ELSE
+ (boot?)
+ THEN
+
+ disable-watchdog FALSE to use-load-watchdog?
+ .banner
+;
diff --git a/qemu/roms/SLOF/slof/fs/term-io.fs b/qemu/roms/SLOF/slof/fs/term-io.fs
new file mode 100644
index 000000000..52ce12a5b
--- /dev/null
+++ b/qemu/roms/SLOF/slof/fs/term-io.fs
@@ -0,0 +1,97 @@
+\ *****************************************************************************
+\ * Copyright (c) 2004, 2008 IBM Corporation
+\ * All rights reserved.
+\ * This program and the accompanying materials
+\ * are made available under the terms of the BSD License
+\ * which accompanies this distribution, and is available at
+\ * http://www.opensource.org/licenses/bsd-license.php
+\ *
+\ * Contributors:
+\ * IBM Corporation - initial implementation
+\ ****************************************************************************/
+
+
+: input ( dev-str dev-len -- )
+ open-dev ?dup IF
+ \ Close old stdin:
+ s" stdin" get-chosen IF
+ decode-int nip nip ?dup IF close-dev THEN
+ THEN
+ \ Now set the new stdin:
+ encode-int s" stdin" set-chosen
+ THEN
+;
+
+: output ( dev-str dev-len -- )
+ open-dev ?dup IF
+ \ Close old stdout:
+ s" stdout" get-chosen IF
+ decode-int nip nip ?dup IF close-dev THEN
+ THEN
+ \ Now set the new stdout:
+ encode-int s" stdout" set-chosen
+ THEN
+;
+
+: io ( dev-str dev-len -- )
+ 2dup input output
+;
+
+
+1 BUFFER: (term-io-char-buf)
+
+: term-io-key ( -- char )
+ s" stdin" get-chosen IF
+ decode-int nip nip dup 0= IF 0 EXIT THEN
+ >r BEGIN
+ (term-io-char-buf) 1 s" read" r@ $call-method
+ 0 >
+ UNTIL
+ (term-io-char-buf) c@
+ r> drop
+ ELSE
+ [ ' key behavior compile, ]
+ THEN
+;
+
+' term-io-key to key
+
+\ this word will check what the current chosen input device is:
+\ - if it is a serial device, it will use serial-key? to check for available input
+\ - if it is a keyboard, it will check if the "key-available?" method is implemented (i.e. for usb-keyboard) and use that
+\ - if it's an hv console, use hvterm-key?
+\ otherwise it will always return false
+: term-io-key? ( -- true|false )
+ s" stdin" get-chosen IF
+ decode-int nip nip dup 0= IF drop 0 EXIT THEN \ return false and exit if no stdin set
+ >r \ store ihandle on return stack
+ s" device_type" r@ ihandle>phandle ( propstr len phandle )
+ get-property ( true | data dlen false )
+ IF
+ \ device_type not found, return false and exit
+ false
+ ELSE
+ 1 - \ remove 1 from length to ignore null-termination char
+ \ device_type found, check wether it is serial or keyboard
+ 2dup s" serial" str= IF
+ 2drop serial-key? r> drop EXIT
+ THEN \ call serial-key, cleanup return-stack, exit
+ 2dup s" keyboard" str= IF
+ 2drop ( )
+ \ keyboard found, check for key-available? method, execute it or return false
+ s" key-available?" r@ ihandle>phandle find-method IF
+ drop s" key-available?" r@ $call-method
+ ELSE
+ false
+ THEN
+ r> drop EXIT \ cleanup return-stack, exit
+ THEN
+ 2drop r> drop false EXIT \ unknown device_type cleanup return-stack, return false
+ THEN
+ ELSE
+ \ stdin not set, return false
+ false
+ THEN
+;
+
+' term-io-key? to key?
diff --git a/qemu/roms/SLOF/slof/fs/terminal.fs b/qemu/roms/SLOF/slof/fs/terminal.fs
new file mode 100644
index 000000000..582bedeb3
--- /dev/null
+++ b/qemu/roms/SLOF/slof/fs/terminal.fs
@@ -0,0 +1,212 @@
+\ *****************************************************************************
+\ * Copyright (c) 2004, 2008 IBM Corporation
+\ * All rights reserved.
+\ * This program and the accompanying materials
+\ * are made available under the terms of the BSD License
+\ * which accompanies this distribution, and is available at
+\ * http://www.opensource.org/licenses/bsd-license.php
+\ *
+\ * Contributors:
+\ * IBM Corporation - initial implementation
+\ ****************************************************************************/
+
+\ \\\\\\\\\\\\\\ Global Data
+
+0 VALUE line#
+0 VALUE column#
+false VALUE inverse?
+false VALUE inverse-screen?
+18 VALUE #lines
+50 VALUE #columns
+
+false VALUE cursor
+false VALUE saved-cursor
+
+
+\ \\\\\\\\\\\\\\ Structure/Implementation Dependent Methods
+
+defer draw-character \ 2B inited by display driver
+defer reset-screen \ 2B inited by display driver
+defer toggle-cursor \ 2B inited by display driver
+defer erase-screen \ 2B inited by display driver
+defer blink-screen \ 2B inited by display driver
+defer invert-screen \ 2B inited by display driver
+defer insert-characters \ 2B inited by display driver
+defer delete-characters \ 2B inited by display driver
+defer insert-lines \ 2B inited by display driver
+defer delete-lines \ 2B inited by display driver
+defer draw-logo \ 2B inited by display driver
+
+: nop-toggle-cursor ( nop ) ;
+' nop-toggle-cursor to toggle-cursor
+
+\ \\\\\\\\\\\\\\ Implementation Independent Methods (Depend on Previous)
+\ *
+\ *
+: (cursor-off) ( -- ) cursor dup to saved-cursor
+ IF toggle-cursor false to cursor THEN ;
+: (cursor-on) ( -- ) cursor dup to saved-cursor
+ 0= IF toggle-cursor true to cursor THEN ;
+: restore-cursor ( -- ) saved-cursor dup cursor
+ <> IF toggle-cursor to cursor ELSE drop THEN ;
+
+' (cursor-off) to cursor-off
+' (cursor-on) to cursor-on
+
+\ \\\\\\\\\\\\\\ Exported Interface:
+\ *
+\ Generic device methods:
+\ *
+
+
+\ \\\\\\\\\\\\\\ Exported Interface:
+\ *
+\ *
+
+false VALUE esc-on
+false VALUE csi-on
+defer esc-process
+0 VALUE esc-num-parm
+0 VALUE esc-num-parm2
+0 VALUE saved-line#
+0 VALUE saved-column#
+
+: get-esc-parm ( default -- value )
+ esc-num-parm dup 0> IF nip ELSE drop THEN 0 to esc-num-parm ;
+: get-esc-parm2 ( default -- value )
+ esc-num-parm2 dup 0> IF nip ELSE drop THEN 0 to esc-num-parm2 ;
+: set-esc-parm ( newdigit -- ) [char] 0 - esc-num-parm a * + to esc-num-parm ;
+
+: reverse-cursor ( oldpos -- newpos) dup IF 1 get-esc-parm - THEN ;
+: advance-cursor ( bound oldpos -- newpos) tuck > IF 1 get-esc-parm + THEN ;
+: erase-in-line #columns column# - dup 0> IF delete-characters ELSE drop THEN ;
+
+: terminal-line++ ( -- )
+ line# 1+ dup #lines = IF 1- 0 to line# 1 delete-lines THEN
+ to line#
+;
+
+0 VALUE dang
+0 VALUE blipp
+false VALUE stopcsi
+0 VALUE term-background
+7 VALUE term-foreground
+
+: set-term-color
+ dup d# 30 d# 39 between IF dup d# 30 - to term-foreground THEN
+ dup d# 40 d# 49 between IF dup d# 40 - to term-background THEN
+ 0 = IF
+ 0 to term-background
+ 7 to term-foreground
+ THEN
+ term-foreground term-background <= to inverse?
+;
+
+: ansi-esc ( char -- )
+ csi-on IF
+ dup [char] 0 [char] 9 between IF set-esc-parm
+ ELSE true to stopcsi CASE
+ [char] A OF line# reverse-cursor to line# ENDOF
+ [char] B OF #lines line# advance-cursor to line# ENDOF
+ [char] C OF #columns column# advance-cursor to column# ENDOF
+ [char] D OF column# reverse-cursor to column# ENDOF
+ [char] E OF ( FIXME: Cursor Next Line - No idea what does it mean )
+ #lines line# advance-cursor to line#
+ ENDOF
+ [char] f OF
+ 1 get-esc-parm2 to line# column# get-esc-parm to column#
+ ENDOF
+ [char] H OF
+ 1 get-esc-parm2 to line# column# get-esc-parm to column#
+ ENDOF
+ ( second parameter delimiter for f and H commands )
+ [char] ; OF false to stopcsi 0 get-esc-parm to esc-num-parm2 ENDOF
+ [char] ? OF false to stopcsi ENDOF ( FIXME: Ignore that for now )
+ [char] l OF ENDOF ( FIXME: ?25l should hide cursor )
+ [char] h OF ENDOF ( FIXME: ?25h should show cursor )
+ [char] J OF
+ #lines line# - dup 0> IF
+ line# 1+ to line# delete-lines line# 1- to line#
+ ELSE drop THEN
+ erase-in-line
+ ENDOF
+ [char] K OF erase-in-line ENDOF
+ [char] L OF 1 get-esc-parm insert-lines ENDOF
+ [char] M OF 1 get-esc-parm delete-lines ENDOF
+ [char] @ OF 1 get-esc-parm insert-characters ENDOF
+ [char] P OF 1 get-esc-parm delete-characters ENDOF
+ [char] m OF 0 get-esc-parm set-term-color ENDOF
+ ( These are non-ANSI commands recommended by OpenBoot )
+ [char] p OF inverse-screen? IF false to inverse-screen?
+ inverse? 0= to inverse? invert-screen
+ THEN
+ ENDOF
+ [char] q OF inverse-screen? 0= IF true to inverse-screen?
+ inverse? 0= to inverse? invert-screen
+ THEN
+ ENDOF
+\ [char] s OF reset-screen ENDOF ( FIXME: this conflicts w. ANSI )
+\ [char] s OF line# to saved-line# column# to saved-column# ENDOF
+ [char] u OF saved-line# to line# saved-column# to column# ENDOF
+ dup dup to dang OF blink-screen ENDOF
+ ENDCASE stopcsi IF false to csi-on
+ false to esc-on 0 to esc-num-parm 0 to esc-num-parm2 THEN
+ THEN
+ ELSE CASE
+ ( DEV VT compatibility stuff used by accept.fs )
+ [char] 7 OF line# to saved-line# column# to saved-column# ENDOF
+ [char] 8 OF saved-line# to line# saved-column# to column# ENDOF
+ [char] [ OF true to csi-on ENDOF
+ dup dup OF false to esc-on to blipp ENDOF
+ ENDCASE
+ csi-on 0= IF false to esc-on THEN 0 to esc-num-parm 0 to esc-num-parm2
+ THEN
+;
+
+' ansi-esc to esc-process
+CREATE twtracebuf 4000 allot twtracebuf 4000 erase
+twtracebuf VALUE twbp
+0 VALUE twbc
+
+: twtrace
+ twbc 4000 = IF 0 to twbc twtracebuf to twbp THEN
+ dup twbp c! twbp 1+ to twbp twbc 1+ to twbc
+;
+
+: terminal-write ( addr len -- actual-len )
+ cursor-off
+ tuck bounds ?DO i c@
+ twtrace
+ esc-on IF esc-process
+ ELSE CASE
+ 1B OF true to esc-on ENDOF
+ carret OF 0 to column# ENDOF
+ linefeed OF terminal-line++ ENDOF
+ bell OF blink-screen ENDOF
+ 9 ( TAB ) OF column# 7 + -8 and dup #columns < IF
+ to column#
+ ELSE drop THEN
+ ENDOF
+ B ( VT ) OF line# ?dup IF 1- to line# THEN ENDOF
+ C ( FF ) OF 0 to line# 0 to column# erase-screen ENDOF
+ bs OF column# 1- dup 0< IF
+ line# IF
+ line# 1- to line#
+ drop #columns 1-
+ ELSE drop column#
+ THEN
+ THEN
+ to column# ( bl draw-character )
+ ENDOF
+ dup OF
+ i c@ draw-character
+ column# 1+ dup #columns >= IF
+ drop 0 terminal-line++
+ THEN
+ to column#
+ ENDOF
+ ENDCASE
+ THEN
+ LOOP
+ restore-cursor
+;
diff --git a/qemu/roms/SLOF/slof/fs/timebase.fs b/qemu/roms/SLOF/slof/fs/timebase.fs
new file mode 100644
index 000000000..00a0bd203
--- /dev/null
+++ b/qemu/roms/SLOF/slof/fs/timebase.fs
@@ -0,0 +1,24 @@
+\ *****************************************************************************
+\ * Copyright (c) 2004, 2008 IBM Corporation
+\ * All rights reserved.
+\ * This program and the accompanying materials
+\ * are made available under the terms of the BSD License
+\ * which accompanies this distribution, and is available at
+\ * http://www.opensource.org/licenses/bsd-license.php
+\ *
+\ * Contributors:
+\ * IBM Corporation - initial implementation
+\ ****************************************************************************/
+\ Define all timebase related words
+
+: tb@ ( -- tb )
+ BEGIN tbu@ tbl@ tbu@ rot over <> WHILE 2drop REPEAT
+ 20 lshift swap ffffffff and or
+;
+
+: milliseconds ( -- ms ) tb@ d# 1000 * tb-frequency / ;
+: microseconds ( -- us ) tb@ d# 1000000 * tb-frequency / ;
+
+: ms ( ms-to-wait -- ) milliseconds + BEGIN milliseconds over >= UNTIL drop ;
+: get-msecs ( -- n ) milliseconds ;
+: us ( us-to-wait -- ) microseconds + BEGIN microseconds over >= UNTIL drop ;
diff --git a/qemu/roms/SLOF/slof/fs/translate.fs b/qemu/roms/SLOF/slof/fs/translate.fs
new file mode 100644
index 000000000..9654f242f
--- /dev/null
+++ b/qemu/roms/SLOF/slof/fs/translate.fs
@@ -0,0 +1,150 @@
+\ *****************************************************************************
+\ * Copyright (c) 2004, 2008 IBM Corporation
+\ * All rights reserved.
+\ * This program and the accompanying materials
+\ * are made available under the terms of the BSD License
+\ * which accompanies this distribution, and is available at
+\ * http://www.opensource.org/licenses/bsd-license.php
+\ *
+\ * Contributors:
+\ * IBM Corporation - initial implementation
+\ ****************************************************************************/
+
+\ this is a C-to-Forth translation from the translate
+\ address code in the client
+\ with extensions to handle different sizes of #size-cells
+
+\ this tries to figure out if it is a PCI device what kind of
+\ translation is wanted
+\ if prop_type is 0, "reg" property is used, otherwise "assigned-addresses"
+: pci-address-type ( node address prop_type -- type )
+ -rot 2 pick ( prop_type node address prop_type )
+ 0= IF
+ swap s" reg" rot get-property ( prop_type address data dlen false )
+ ELSE
+ swap s" assigned-addresses" rot get-property ( prop_type address data dlen false )
+ THEN
+ IF 2drop -1 EXIT THEN 4 / 5 /
+ \ advance (phys-addr(3) size(2)) steps
+ 0 DO
+ \ BARs and Expansion ROM must be in assigned-addresses...
+ \ so if prop_type is 0 ("reg") and a config space offset is set
+ \ we skip this entry...
+ dup l@ FF AND 0<> ( prop_type address data cfgspace_offset? )
+ 3 pick 0= ( prop_type address data cfgspace_offset? reg_prop? )
+ AND NOT IF
+ 2dup 4 + ( prop_type address data address data' )
+ 2dup @ 2 pick 8 + @ + <= -rot @ >= and IF
+ l@ 03000000 and 18 rshift nip
+ ( prop_type type )
+ swap drop ( type )
+ UNLOOP EXIT
+ THEN
+ THEN
+ \ advance in 4 byte steps and (phys-addr(3) size(2)) steps
+ 4 5 * +
+ LOOP
+ 3drop -1
+;
+
+: (range-read-cells) ( range-addr #cells -- range-value )
+ \ if number of cells != 1; do 64bit read; else a 32bit read
+ 1 = IF l@ ELSE @ THEN
+;
+
+\ this functions tries to find a mapping for the given address
+\ it assumes that if we have #address-cells == 3 that we are trying
+\ to do a PCI translation
+
+\ nac - #address-cells
+\ nsc - #size-cells
+\ pnac - parent #address-cells
+
+: (map-one-range) ( type range pnac nsc nac address -- address true | address false )
+ \ only check for the type if nac == 3 (PCI)
+ over 3 = 5 pick l@ 3000000 and 18 rshift 7 pick <> and IF
+ >r 2drop 3drop r> false EXIT
+ THEN
+ \ get size
+ 4 pick 4 pick 3 pick + 4 * +
+ \ get nsc
+ 3 pick
+ \ read size
+ ( type range pnac nsc nac address range nsc )
+ (range-read-cells)
+ ( type range pnac nsc nac address size )
+ \ skip type if PCI
+ 5 pick 3 pick 3 = IF
+ 4 +
+ THEN
+ \ get nac
+ 3 pick
+ ( type range pnac nsc nac address size range nac )
+ \ read child-mapping
+ (range-read-cells)
+ ( type range pnac nsc nac address size child-mapping )
+ dup >r dup 3 pick > >r + over <= r> or IF
+ \ address is not inside the mapping range
+ >r 2drop 3drop r> r> drop false EXIT
+ THEN
+ dup r> -
+ ( type range pnac nsc nac address offset )
+ \ add the offset on the parent mapping
+ 5 pick 5 pick 3 = IF
+ \ skip type if PCI
+ 4 +
+ THEN
+ 3 pick 4 * +
+ ( type range pnac nsc nac address offset parent-mapping-address )
+ \ get pnac
+ 5 pick
+ \ read parent mapping
+ (range-read-cells)
+ ( type range pnac nsc nac address offset parent-mapping )
+ + >r 3drop 3drop r> true
+;
+
+\ this word translates the given address starting from the node specified
+\ in node; the word will return to the node it was started from
+: translate-address ( node address -- address )
+ \ check for address type in "assigned-addresses"
+ 2dup 1 pci-address-type ( node address type )
+ dup -1 = IF
+ \ not found in "assigned-addresses", check in "reg"
+ drop 2dup 0 pci-address-type ( node address type )
+ THEN
+ rot parent BEGIN
+ \ check if it is the root node
+ dup parent 0= IF 2drop EXIT THEN
+ ( address type parent )
+ s" #address-cells" 2 pick get-property 2drop l@ >r \ nac
+ s" #size-cells" 2 pick get-property 2drop l@ >r \ nsc
+ s" #address-cells" 2 pick parent get-property 2drop l@ >r \ pnac
+ -rot ( node address type )
+ s" ranges" 4 pick get-property IF
+ 3drop
+ ABORT" no ranges property; not translatable"
+ THEN
+ r> r> r> 3 roll
+ ( node address type ranges pnac nsc nac length )
+ 4 / >r 3dup + + >r 5 roll r> r> swap / 0 ?DO
+ ( node type ranges pnac nsc nac address )
+ 6dup (map-one-range) IF
+ nip leave
+ THEN
+ nip
+ \ advance ranges
+ 4 roll
+ ( node type pnac nsc nac address ranges )
+ 4 pick 4 pick 4 pick + + 4 * + 4 -roll
+ LOOP
+ >r 2drop 2drop r> ( node type address )
+ swap rot parent ( address type node )
+ dup 0=
+ UNTIL
+;
+
+\ this words translates the given address starting from the current node
+: translate-my-address ( address -- address' )
+ get-node swap translate-address
+;
diff --git a/qemu/roms/SLOF/slof/fs/update_flash.fs b/qemu/roms/SLOF/slof/fs/update_flash.fs
new file mode 100644
index 000000000..e04869d77
--- /dev/null
+++ b/qemu/roms/SLOF/slof/fs/update_flash.fs
@@ -0,0 +1,110 @@
+\ *****************************************************************************
+\ * Copyright (c) 2004, 2008 IBM Corporation
+\ * All rights reserved.
+\ * This program and the accompanying materials
+\ * are made available under the terms of the BSD License
+\ * which accompanies this distribution, and is available at
+\ * http://www.opensource.org/licenses/bsd-license.php
+\ *
+\ * Contributors:
+\ * IBM Corporation - initial implementation
+\ ****************************************************************************/
+
+\ Set by update-flash -f to true, preventing update-flash -c
+false value flash-new
+
+: update-flash-help ( -- )
+ cr ." update-flash tool to flash host FW " cr
+ ." -f <filename> : Flash from file (e.g. net:\boot_rom.bin)" cr
+ ." -l : Flash from load-base" cr
+ ." -d : Flash from old load base (used by drone)" cr
+ ." -c : Flash from temp to perm" cr
+ ." -r : Flash from perm to temp" cr
+;
+
+: flash-read-temp ( -- success? )
+ get-flashside 1 = IF flash-addr get-load-base over flash-image-size rmove true
+ ELSE
+ false
+ THEN
+;
+
+: flash-read-perm ( -- success? )
+ get-flashside 0= IF
+ flash-addr get-load-base over flash-image-size rmove true
+ ELSE
+ false
+ THEN
+;
+
+: flash-switch-side ( side -- success? )
+ set-flashside 0<> IF
+ s" Cannot change flashside" type cr false
+ ELSE
+ true
+ THEN
+;
+
+: flash-ensure-temp ( -- success? )
+ get-flashside 0= IF
+ cr ." Cannot flash perm! Switching to temp side!"
+ 1 flash-switch-side
+ ELSE
+ true
+ THEN
+;
+
+\ update-flash -f <filename>
+\ -l
+\ -c
+\ -r
+
+: update-flash ( "text" )
+ get-flashside >r \ Save old flashside
+ parse-word ( str len ) \ Parse first string
+ drop dup c@ ( str first-char )
+ [char] - <> IF
+ update-flash-help r> 2drop EXIT
+ THEN
+
+ 1+ c@ ( second-char )
+ CASE
+ [char] f OF
+ parse-word cr s" do-load" evaluate
+ flash-ensure-temp TO flash-new
+ ENDOF
+ [char] l OF
+ flash-ensure-temp
+ ENDOF
+ [char] d OF
+ flash-load-base get-load-base 200000 move
+ flash-ensure-temp
+ ENDOF
+ [char] c OF
+ flash-read-temp 0= flash-new or IF
+ ." Cannot commit temp, need to boot on temp first " cr false
+ ELSE
+ 0 flash-switch-side
+ THEN
+ ENDOF
+ [char] r OF
+ flash-read-perm 0= IF
+ ." Cannot commit perm, need to boot on perm first " cr false
+ ELSE
+ 1 flash-switch-side
+ THEN
+ ENDOF
+ dup OF
+ false
+ ENDOF
+ ENDCASE
+
+ ( true| false )
+
+ 0= IF
+ update-flash-help r> drop EXIT
+ THEN
+
+ get-load-base flash-write 0= IF ." Flash write failed !! " cr THEN
+ r> set-flashside drop \ Restore old flashside
+;
diff --git a/qemu/roms/SLOF/slof/fs/usb/dev-hci.fs b/qemu/roms/SLOF/slof/fs/usb/dev-hci.fs
new file mode 100644
index 000000000..5fb25b8b6
--- /dev/null
+++ b/qemu/roms/SLOF/slof/fs/usb/dev-hci.fs
@@ -0,0 +1,71 @@
+\ *****************************************************************************
+\ * Copyright (c) 2006, 2012, 2013 IBM Corporation
+\ * All rights reserved.
+\ * This program and the accompanying materials
+\ * are made available under the terms of the BSD License
+\ * which accompanies this distribution, and is available at
+\ * http://www.opensource.org/licenses/bsd-license.php
+\ *
+\ * Contributors:
+\ * IBM Corporation - initial implementation
+\ ****************************************************************************/
+\ *
+\ * [OEX]HCI functions
+\ *
+\ ****************************************************************************
+
+\ ( num $name type )
+
+VALUE usb_type \ USB type
+
+\ Open Firmware Properties
+device-type
+" usb" 2dup device-name
+
+rot
+VALUE usb_num \ controller number
+usb_num $cathex strdup \ create alias name
+2dup find-alias 0= IF
+ get-node node>path set-alias
+ELSE 3drop THEN
+
+/hci-dev BUFFER: hcidev
+usb_num hcidev usb-setup-hcidev
+TRUE VALUE first-time-init?
+0 VALUE open-count
+
+false VALUE dev-hci-debug?
+
+1 encode-int s" #address-cells" property
+0 encode-int s" #size-cells" property
+
+\ converts physical address to text unit string
+: encode-unit ( port -- unit-str unit-len ) 1 hex-encode-unit ;
+
+\ Converts text unit string to phyical address
+: decode-unit ( addr len -- port ) 1 hex-decode-unit ;
+
+: get-hci-dev ( -- hcidev )
+ hcidev
+;
+
+: hc-cleanup ( -- )
+ my-phandle set-node
+ dev-hci-debug? IF ." USB-HCI: Cleaning up " pwd cr THEN
+ hcidev USB-HCD-EXIT
+ 0 set-node
+;
+
+: open ( -- true | false )
+ true
+;
+
+: close
+;
+
+\ create a new entry to cleanup and suspend HCI
+\ after first init
+first-time-init? IF
+ ['] hc-cleanup add-quiesce-xt
+ false to first-time-init?
+THEN
diff --git a/qemu/roms/SLOF/slof/fs/usb/dev-hub.fs b/qemu/roms/SLOF/slof/fs/usb/dev-hub.fs
new file mode 100644
index 000000000..ba0b33437
--- /dev/null
+++ b/qemu/roms/SLOF/slof/fs/usb/dev-hub.fs
@@ -0,0 +1,32 @@
+new-device
+
+VALUE sudev
+
+s" slofdev.fs" included
+sudev slof-dev>port l@ dup set-unit encode-phys " reg" property
+sudev slof-dev>udev @ VALUE udev
+
+s" hub" device-name
+
+s" dev-parent-calls.fs" included
+
+1 encode-int s" #address-cells" property
+0 encode-int s" #size-cells" property
+: decode-unit 1 hex-decode-unit ;
+: encode-unit 1 hex-encode-unit ;
+
+: usb-hub-init ( usbdev -- true | false )
+ udev USB-HUB-INIT
+;
+
+: open ( -- true | false )
+ TRUE
+;
+
+: close
+;
+
+." USB HUB " cr
+usb-hub-init drop
+
+finish-device
diff --git a/qemu/roms/SLOF/slof/fs/usb/dev-keyb.fs b/qemu/roms/SLOF/slof/fs/usb/dev-keyb.fs
new file mode 100644
index 000000000..db9e23ef1
--- /dev/null
+++ b/qemu/roms/SLOF/slof/fs/usb/dev-keyb.fs
@@ -0,0 +1,54 @@
+new-device
+
+VALUE sudev
+false VALUE usb-keyb-debug?
+
+s" slofdev.fs" included
+sudev slof-dev>port l@ dup set-unit encode-phys " reg" property
+sudev slof-dev>udev @ VALUE udev
+
+s" usb-keyboard" device-name
+s" keyboard" device-type
+s" EN" encode-string s" language" property
+s" keyboard" get-node node>path set-alias
+
+s" dev-parent-calls.fs" included
+
+0 VALUE open-count
+
+: open ( -- true | false )
+ usb-keyb-debug? IF ." USB-KEYB: Opening (count is " open-count . ." )" cr THEN
+ open-count 0= IF
+ udev USB-HID-INIT 0= IF
+ ." USB keyboard setup failed " pwd cr false EXIT
+ THEN
+ THEN
+ open-count 1 + to open-count
+ true
+;
+
+: close
+ usb-keyb-debug? IF ." USB-KEYB: Closing (count is " open-count . ." )" cr THEN
+ open-count 0> IF
+ open-count 1 - dup to open-count
+ 0= IF
+ my-phandle set-node
+ udev USB-HID-EXIT drop
+ 0 set-node
+ THEN
+ THEN
+;
+
+\ method to check if a key is present in output buffer
+\ used by 'term-io.fs'
+: key-available? ( -- true|false )
+ udev USB-KEY-AVAILABLE IF TRUE ELSE FALSE THEN
+;
+
+: read ( addr len -- actual )
+ 0= IF drop 0 EXIT THEN
+ udev USB-READ-KEYB ?dup IF swap c! 1 ELSE 0 swap c! 0 then
+;
+
+." USB Keyboard " cr
+finish-device
diff --git a/qemu/roms/SLOF/slof/fs/usb/dev-mouse.fs b/qemu/roms/SLOF/slof/fs/usb/dev-mouse.fs
new file mode 100644
index 000000000..f6acd7e28
--- /dev/null
+++ b/qemu/roms/SLOF/slof/fs/usb/dev-mouse.fs
@@ -0,0 +1,20 @@
+new-device
+
+VALUE sudev
+s" slofdev.fs" included
+sudev slof-dev>port l@ dup set-unit encode-phys " reg" property
+sudev slof-dev>udev @ VALUE udev
+
+s" usb-mouse" device-name
+
+\ .S cr
+\ dup slof-dev>udev dup . @ . cr
+\ dup slof-dev>port dup . l@ . cr
+\ dup slof-dev>devaddr dup . l@ . cr
+\ dup slof-dev>hcitype dup . l@ . cr
+\ dup slof-dev>num dup . l@ . cr
+\ dup slof-dev>devtype dup . l@ . cr
+
+." USB mouse " cr
+
+finish-device
diff --git a/qemu/roms/SLOF/slof/fs/usb/dev-parent-calls.fs b/qemu/roms/SLOF/slof/fs/usb/dev-parent-calls.fs
new file mode 100644
index 000000000..57fa8ebdc
--- /dev/null
+++ b/qemu/roms/SLOF/slof/fs/usb/dev-parent-calls.fs
@@ -0,0 +1,15 @@
+\ ****************************************************************************/
+\ * Copyright (c) 2011 IBM Corporation
+\ * All rights reserved.
+\ * This program and the accompanying materials
+\ * are made available under the terms of the BSD License
+\ * which accompanies this distribution, and is available at
+\ * http://www.opensource.org/licenses/bsd-license.php
+\ *
+\ * Contributors:
+\ * IBM Corporation - initial implementation
+\ ****************************************************************************/
+
+get-node CONSTANT my-phandle
+
+s" dma-function.fs" included
diff --git a/qemu/roms/SLOF/slof/fs/usb/dev-storage.fs b/qemu/roms/SLOF/slof/fs/usb/dev-storage.fs
new file mode 100644
index 000000000..94f8421d3
--- /dev/null
+++ b/qemu/roms/SLOF/slof/fs/usb/dev-storage.fs
@@ -0,0 +1,361 @@
+\ *****************************************************************************
+\ * Copyright (c) 2013 IBM Corporation
+\ * All rights reserved.
+\ * This program and the accompanying materials
+\ * are made available under the terms of the BSD License
+\ * which accompanies this distribution, and is available at
+\ * http://www.opensource.org/licenses/bsd-license.php
+\ *
+\ * Contributors:
+\ * IBM Corporation - initial implementation
+\ ****************************************************************************/
+
+\ ( usbdev -- )
+
+new-device
+
+VALUE usbdev
+
+s" slofdev.fs" included
+
+false VALUE usb-disk-debug?
+
+usbdev slof-dev>port l@ dup set-unit encode-phys " reg" property
+s" storage" device-name
+
+s" dev-parent-calls.fs" included
+
+2 encode-int s" #address-cells" property
+0 encode-int s" #size-cells" property
+
+: decode-unit 2 hex64-decode-unit ;
+: encode-unit 2 hex64-encode-unit ;
+
+0 CONSTANT USB_PIPE_OUT
+1 CONSTANT USB_PIPE_IN
+
+\ -----------------------------------------------------------
+\ Specific properties
+\ -----------------------------------------------------------
+
+usbdev slof-dev>udev @ VALUE udev
+usbdev slof-dev>port l@ VALUE port
+usbdev slof-dev>hcitype l@ VALUE hcitype
+
+0 INSTANCE VALUE lun
+10000 VALUE dev-max-transfer
+0 VALUE resp-buffer
+0 VALUE resp-size
+0f CONSTANT SCSI-COMMAND-OFFSET
+
+\ -------------------------------------------------------
+\ DMA-able buffers
+\ -------------------------------------------------------
+
+STRUCT
+ dev-max-transfer FIELD usb>data
+ 40 FIELD usb>cmd
+ 20 FIELD usb>csw
+CONSTANT /dma-buf
+
+0 VALUE dma-buf
+0 VALUE dma-buf-phys
+0 VALUE td-buf
+0 VALUE td-buf-phys
+1000 CONSTANT /td-buf
+
+: (dma-buf-init) ( -- )
+ /dma-buf dma-alloc TO dma-buf
+ dma-buf /dma-buf 0 dma-map-in TO dma-buf-phys
+ /td-buf dma-alloc TO td-buf
+ td-buf /td-buf 0 dma-map-in TO td-buf-phys
+;
+
+: (dma-buf-free) ( -- )
+ td-buf td-buf-phys /td-buf dma-map-out
+ td-buf /td-buf dma-free
+ 0 TO td-buf
+ 0 TO td-buf-phys
+ dma-buf dma-buf-phys /dma-buf dma-map-out
+ dma-buf /dma-buf dma-free
+ 0 TO dma-buf
+ 0 TO dma-buf-phys
+;
+
+
+scsi-open
+
+\ -----------------------------------------------------------
+\ Perform SCSI commands
+\ -----------------------------------------------------------
+
+0 INSTANCE VALUE current-target
+
+\ SCSI command. We do *NOT* implement the "standard" execute-command
+\ because that doesn't have a way to return the sense buffer back, and
+\ we do have auto-sense with some hosts. Instead we implement a made-up
+\ do-scsi-command.
+\
+\ Note: stat is -1 for "hw error" (ie, error queuing the command or
+\ getting the response).
+\
+\ A sense buffer is returned whenever the status is non-0 however
+\ if sense-len is 0 then no sense data is actually present
+\
+
+: do-bulk-command ( resp-buffer resp-size -- TRUE | FALSE )
+ TO resp-size
+ TO resp-buffer
+ udev USB_PIPE_OUT td-buf td-buf-phys dma-buf-phys usb>cmd 1F
+ usb-transfer-bulk IF \ transfer CBW
+ resp-size IF
+ d# 125 us
+ udev USB_PIPE_IN td-buf td-buf-phys resp-buffer resp-size
+ usb-transfer-bulk 1 = not IF \ transfer data
+ usb-disk-debug? IF ." Data phase failed " cr THEN
+ \ FALSE EXIT
+ \ in case of a stall/halted endpoint we clear the halt
+ \ Fall through and try reading the CSW
+ THEN
+ THEN
+ d# 125 us
+ udev USB_PIPE_IN td-buf td-buf-phys dma-buf-phys usb>csw 0D
+ usb-transfer-bulk \ transfer CSW
+ ELSE
+ FALSE EXIT
+ THEN
+;
+
+STRUCT \ cbw
+ /l FIELD cbw>sig
+ /l FIELD cbw>tag
+ /l FIELD cbw>len
+ /c FIELD cbw>flags
+ /c FIELD cbw>lun \ 0:3 bits
+ /c FIELD cbw>cblen \ 0:4 bits
+CONSTANT cbw-length
+
+STRUCT \ csw
+ /l FIELD csw>sig
+ /l FIELD csw>tag
+ /l FIELD csw>data-residue
+ /c FIELD csw>status
+CONSTANT cbw-length
+
+0 VALUE cbw-addr
+0 VALUE csw-addr
+
+: build-cbw ( tag xfer-len dir lun cmd-len addr -- )
+ TO cbw-addr ( tag xfer-len dir lun cmd-len )
+ cbw-addr cbw-length erase ( tag xfer-len dir lun cmd-len )
+ cbw-addr cbw>cblen c! ( tag xfer-len dir lun )
+ cbw-addr cbw>lun c! ( tag xfer-len dir )
+ \ dir is true or false
+ \ bmCBWFlags
+ \ BIT 7 Direction
+ \ 0 - OUT
+ \ 1 - IN
+ IF 80 ELSE 0 THEN
+ cbw-addr cbw>flags c! ( tag xfer-len )
+ cbw-addr cbw>len l!-le ( tag )
+ cbw-addr cbw>tag l!-le ( )
+ 43425355 cbw-addr cbw>sig l!-le
+;
+
+0 INSTANCE VALUE usb-buf-addr
+0 INSTANCE VALUE usb-buf-len
+0 INSTANCE VALUE usb-dir
+0 INSTANCE VALUE usb-cmd-addr
+0 INSTANCE VALUE usb-cmd-len
+1 VALUE tag
+
+: execute-scsi-command ( buf-addr buf-len dir cmd-addr cmd-len -- ... )
+ ( ... [ sense-buf sense-len ] stat )
+ \ Cleanup virtio request and response
+ to usb-cmd-len to usb-cmd-addr to usb-dir to usb-buf-len to usb-buf-addr
+
+ dma-buf usb>cmd 40 0 fill
+ dma-buf usb>csw 20 0 fill
+
+ tag usb-buf-len usb-dir lun usb-cmd-len dma-buf usb>cmd
+ ( tag transfer-len dir lun cmd-len addr )
+ build-cbw
+ 1 tag + to tag
+
+ usb-cmd-addr
+ dma-buf usb>cmd SCSI-COMMAND-OFFSET +
+ usb-cmd-len
+ move
+
+ \ Send it
+ dma-buf-phys usb>data usb-buf-len
+ do-bulk-command IF
+ dma-buf usb>data usb-buf-addr usb-buf-len move
+ ELSE
+ ." USB-DISK: Bulk commad failed!" cr
+ 0 0 -1 EXIT
+ THEN
+
+ dma-buf usb>csw to csw-addr
+ csw-addr csw>sig l@ 55534253 <> IF
+ ." USB-DISK: CSW signature invalid " cr
+ 0 0 -1 EXIT
+ THEN
+
+ csw-addr csw>status c@ CASE
+ 0 OF ENDOF \ Good
+ 1 OF
+ usb-disk-debug? IF
+ ." USB-DISK: CSW Data residue: "
+ csw-addr csw>data-residue l@-le . cr
+ THEN
+ 0 0 8 EXIT ENDOF \ Command failed, Retry
+ dup OF 0 0 -1 EXIT ENDOF \ Anything else -> HW error
+ ENDCASE
+
+ \ Other error status
+ csw-addr csw>status c@ dup 0<> IF
+ usb-disk-debug? IF
+ over scsi-get-sense-data
+ ." USB-DISK: Sense key [ " dup . ." ] " .sense-text
+ ." ASC,ASCQ: " . . cr
+ THEN
+ rot
+ THEN
+;
+
+\ --------------------------------
+\ Include the generic host helpers
+\ --------------------------------
+
+" scsi-host-helpers.fs" included
+
+0 VALUE open-count
+
+: usb-storage-init ( -- TRUE )
+ td-buf 0= IF
+ usb-disk-debug? IF ." USB-DISK: Allocating buffer " cr THEN
+ (dma-buf-init)
+ udev USB-MSC-INIT 0= IF
+ ." USB-DISK: Unable to initialize MSC " cr
+ FALSE
+ ELSE
+ TRUE
+ THEN
+ THEN
+;
+
+: usb-storage-cleanup
+ td-buf 0<> IF
+ usb-disk-debug? IF ." USB-DISK: Freeing buffer " cr THEN
+ (dma-buf-free)
+ udev USB-MSC-EXIT 0= IF ." USB-DISK: Unable to exit MSC " cr THEN
+ THEN
+;
+
+: open
+ usb-disk-debug? IF ." USB-DISK: Opening (count is " open-count . ." )" cr THEN
+
+ open-count 0= IF
+ usb-storage-init IF
+ 1 to open-count true
+ ELSE ." USB-DISK initialization failed !" cr false THEN
+ ELSE
+ open-count 1 + to open-count
+ true
+ THEN
+;
+
+: close
+ usb-disk-debug? IF ." USB-DISK: Closing (count is " open-count . ." )" cr THEN
+
+ open-count 0> IF
+ open-count 1 - dup to open-count
+ 0= IF
+ usb-storage-cleanup
+ THEN
+ THEN
+;
+
+\ -----------------------------------------------------------
+\ SCSI scan at boot and child device support
+\ -----------------------------------------------------------
+
+\ We use SRP luns of the form 01000000 | (target << 8) | lun
+\ in the top 32 bits of the 64-bit LUN
+: (set-target)
+ dup 20 >> FFFF and to lun
+ dup 30 >> FF and to port
+ to current-target
+ usb-disk-debug? IF ." USB-DISK: udev " udev . ." lun:" lun . ." port:" port . cr THEN
+;
+
+: dev-generate-srplun ( target lun-id -- srplun )
+ swap drop port 0100 or 10 << or 20 <<
+;
+
+\ FIXME: Check max transfer coming from virtio config
+: max-transfer ( -- n )
+ dev-max-transfer
+;
+
+\ We obtain here a unit address on the stack, since our #address-cells
+\ is 2, the 64-bit srplun is split in two cells that we need to join
+\
+\ Note: This diverges a bit from the original OF scsi spec as the two
+\ cells are the 2 words of a 64-bit SRP LUN
+: set-address ( srplun.lo srplun.hi -- )
+ lxjoin (set-target)
+ usb-disk-debug? IF ." USB-DISK: udev " udev . ." lun:" lun . ." port:" port . cr THEN
+;
+
+1 CONSTANT #target
+: dev-max-target ( -- #target )
+ #target
+;
+
+" scsi-probe-helpers.fs" included
+
+scsi-close \ no further scsi words required
+
+\ Set scsi alias if none is set yet
+: setup-alias
+ s" scsi" find-alias 0= IF
+ s" scsi" get-node node>path set-alias
+ ELSE
+ drop
+ THEN
+;
+
+: usb-storage-init-and-scan ( -- )
+ usb-disk-debug? IF ." Initializing usb-disk: udev " udev . cr THEN
+
+ \ Create instance for scanning:
+ 0 0 get-node open-node ?dup 0= IF EXIT THEN
+ my-self >r
+ dup to my-self
+
+ hcitype
+ CASE
+ 1 OF 4000 TO dev-max-transfer ENDOF \ OHCI
+ 2 OF 10000 TO dev-max-transfer ENDOF \ EHCI
+ 3 OF F000 TO dev-max-transfer ENDOF \ XHCI
+ ENDCASE
+ usb-storage-init
+ scsi-find-disks
+ setup-alias
+ usb-storage-cleanup
+ \ Close the temporary instance:
+ close-node
+ r> to my-self
+;
+
+." USB Storage " cr
+: usb-scsi-add-disk
+ " scsi-disk.fs" included
+;
+
+usb-scsi-add-disk
+usb-storage-init-and-scan
+
+finish-device
diff --git a/qemu/roms/SLOF/slof/fs/usb/slofdev.fs b/qemu/roms/SLOF/slof/fs/usb/slofdev.fs
new file mode 100644
index 000000000..d6e20fdcd
--- /dev/null
+++ b/qemu/roms/SLOF/slof/fs/usb/slofdev.fs
@@ -0,0 +1,8 @@
+STRUCT
+ /n FIELD slof-dev>udev
+ /l FIELD slof-dev>port
+ /l FIELD slof-dev>devaddr
+ /l FIELD slof-dev>hcitype
+ /l FIELD slof-dev>num
+ /l FIELD slof-dev>devtype
+CONSTANT slof-usb-dev
diff --git a/qemu/roms/SLOF/slof/fs/usb/usb-static.fs b/qemu/roms/SLOF/slof/fs/usb/usb-static.fs
new file mode 100644
index 000000000..47db7276a
--- /dev/null
+++ b/qemu/roms/SLOF/slof/fs/usb/usb-static.fs
@@ -0,0 +1,70 @@
+\ *****************************************************************************
+\ * Copyright (c) 2004, 2011, 2013 IBM Corporation
+\ * All rights reserved.
+\ * This program and the accompanying materials
+\ * are made available under the terms of the BSD License
+\ * which accompanies this distribution, and is available at
+\ * http://www.opensource.org/licenses/bsd-license.php
+\ *
+\ * Contributors:
+\ * IBM Corporation - initial implementation
+\ ****************************************************************************/
+
+\ Load dev hci
+: load-dev-hci ( num name-str name-len )
+ s" dev-hci.fs" INCLUDED
+;
+
+0 VALUE ohci-init
+0 VALUE ehci-init
+0 VALUE xhci-init
+0 VALUE usb-alias-num
+
+: get-usb-alias-num
+ usb-alias-num dup 1+ to usb-alias-num
+;
+
+\ create a new ohci device alias for the current node
+: set-ohci-alias ( -- )
+ 1 to ohci-init
+ get-usb-alias-num ( num )
+ s" ohci" 1 load-dev-hci
+;
+
+\ create a new ehci device alias for the current node
+: set-ehci-alias ( -- )
+ 1 to ehci-init
+ get-usb-alias-num ( num )
+ s" ehci" 2 load-dev-hci
+;
+
+\ create a new xhci device alias for the current node
+: set-xhci-alias ( -- )
+ 1 to xhci-init
+ get-usb-alias-num ( num )
+ s" xhci" 3 load-dev-hci
+;
+
+: usb-enumerate ( hcidev -- )
+ USB-HCD-INIT
+;
+
+: usb-scan ( -- )
+ ." Scanning USB " cr
+ ohci-init 1 = IF USB-OHCI-REGISTER THEN
+ ehci-init 1 = IF USB-EHCI-REGISTER THEN
+ xhci-init 1 = IF USB-XHCI-REGISTER THEN
+
+ usb-alias-num 0 ?DO
+ " usb" i $cathex find-device
+ " get-hci-dev" get-node find-method
+ IF
+ execute usb-enumerate
+ ELSE
+ ." get-base-address method not found for usb@" i .
+ ." Device type: "
+ " device_type" get-node get-property 0= IF decode-string type cr 2drop THEN
+ THEN
+ LOOP
+ 0 set-node \ FIXME Setting it back
+;
diff --git a/qemu/roms/SLOF/slof/fs/vpd-bootlist.fs b/qemu/roms/SLOF/slof/fs/vpd-bootlist.fs
new file mode 100644
index 000000000..5a082156f
--- /dev/null
+++ b/qemu/roms/SLOF/slof/fs/vpd-bootlist.fs
@@ -0,0 +1,134 @@
+\ *****************************************************************************
+\ * Copyright (c) 2004, 2008 IBM Corporation
+\ * All rights reserved.
+\ * This program and the accompanying materials
+\ * are made available under the terms of the BSD License
+\ * which accompanies this distribution, and is available at
+\ * http://www.opensource.org/licenses/bsd-license.php
+\ *
+\ * Contributors:
+\ * IBM Corporation - initial implementation
+\ ****************************************************************************/
+
+4 CONSTANT vpd-bootlist-size
+
+\ Bootable devices
+00 CONSTANT FLOPPY
+01 CONSTANT USB
+02 CONSTANT SAS
+03 CONSTANT SATA
+04 CONSTANT ISCSI
+05 CONSTANT ISCSICRITICAL
+06 CONSTANT NET
+07 CONSTANT NOTSPECIFIED
+08 CONSTANT HDD0
+09 CONSTANT HDD1
+0a CONSTANT HDD2
+0b CONSTANT HDD3
+0c CONSTANT CDROM
+0e CONSTANT HDD4
+10 CONSTANT SCSI
+
+: check-bootlist ( -- true | false )
+ vpd-bootlist l@
+ dup 0= IF
+ ( bootlist == 0 means that probably nothing from vpd has been received )
+ s" Boot list could not be read from VPD" log-string cr
+ s" Boot watchdog has been rearmed" log-string cr
+ 2 set-watchdog
+ EXIT
+ THEN
+
+ FFFFFFFF = IF
+ ( bootlist all FFs means that the vpd has no useful information )
+ .banner
+ -6b boot-exception-handler
+ \ The next message is duplicate, but sent w. log-string
+ s" Boot list successfully read from VPD but no useful information received" log-string cr
+ s" Please specify the boot device in the management module" log-string cr
+ s" Specified Boot Sequence not valid" mm-log-warning
+ false
+ EXIT
+ THEN
+
+ true
+;
+
+\ the following words are necessary for vpd-boot-import
+defer set-boot-device
+defer add-boot-device
+
+\ select-install? is a flag which is used in the SMS panel #20
+\ "Select/Install Boot Devices".
+\ This panel can be used to temporarily override the boot device.
+false VALUE select-install?
+
+\ select/install-path stores string address and string length of the
+\ device node chosen in the SMS panel #20 "Select/Install Boot Devices"
+\ This device node is prepended to the boot path if select-install? is
+\ true.
+CREATE select/install-path 2 cells allot
+
+\ Import boot device list from VPD
+\ If none, keep the existing list in NVRAM
+\ This word can be used to overwrite read-bootlist if wanted
+
+: vpd-boot-import ( -- )
+ 0 0 set-boot-device
+
+ select-install? IF
+ select/install-path 2@ add-boot-device
+ THEN
+
+ vpd-read-bootlist
+ check-bootlist IF
+ 4 0 DO vpd-bootlist i + c@
+ CASE
+ 6 OF \ cr s" 2B Booting from Network" log-string cr
+ furnish-boot-file strdup add-boot-device
+ ENDOF
+
+ HDD0 OF \ cr s" 2B Booting from hdd0" log-string cr
+ s" disk hdd0" add-boot-device ENDOF
+
+ HDD1 OF \ cr s" 2B Booting from hdd1" log-string cr
+ s" hdd1" add-boot-device ENDOF
+
+ HDD2 OF \ cr s" 2B Booting from hdd2" log-string cr
+ s" hdd2" add-boot-device ENDOF
+
+ HDD3 OF \ cr s" 2B Booting from hdd3" log-string cr
+ s" hdd3" add-boot-device ENDOF
+
+ CDROM OF \ cr s" 2B Booting from CDROM" log-string cr
+ s" cdrom" add-boot-device ENDOF
+
+ HDD4 OF \ cr s" 2B Booting from hdd4" log-string cr
+ s" hdd4" add-boot-device ENDOF
+
+ F OF \ cr s" 2B Booting from SAS - w. Timeout" log-string cr
+ s" sas" add-boot-device ENDOF
+
+ SCSI OF \ cr s" 2B Booting from SAS - Continuous Retry" log-string cr
+ s" sas" add-boot-device ENDOF
+
+ ENDCASE
+ LOOP
+ bootdevice 2@ nip
+ IF 0
+ ELSE
+ \ Check for all no device -> use boot-device
+ vpd-bootlist l@ 07070707 = IF 0 ELSE -6b THEN
+ THEN
+ ELSE -6a THEN
+ boot-exception-handler
+;
+
+: vpd-bootlist-restore-default ( -- )
+ NOTSPECIFIED vpd-bootlist 0 + c!
+ NOTSPECIFIED vpd-bootlist 1 + c!
+ NOTSPECIFIED vpd-bootlist 2 + c!
+ HDD0 vpd-bootlist 3 + c!
+ vpd-write-bootlist
+;
+
diff --git a/qemu/roms/SLOF/slof/fs/xmodem.fs b/qemu/roms/SLOF/slof/fs/xmodem.fs
new file mode 100644
index 000000000..122192212
--- /dev/null
+++ b/qemu/roms/SLOF/slof/fs/xmodem.fs
@@ -0,0 +1,120 @@
+\ *****************************************************************************
+\ * Copyright (c) 2004, 2008 IBM Corporation
+\ * All rights reserved.
+\ * This program and the accompanying materials
+\ * are made available under the terms of the BSD License
+\ * which accompanies this distribution, and is available at
+\ * http://www.opensource.org/licenses/bsd-license.php
+\ *
+\ * Contributors:
+\ * IBM Corporation - initial implementation
+\ ****************************************************************************/
+
+
+01 CONSTANT XM-SOH \ Start of header
+04 CONSTANT XM-EOT \ End-of-transmission
+06 CONSTANT XM-ACK \ Acknowledge
+15 CONSTANT XM-NAK \ Neg. acknowledge
+
+0 VALUE xm-retries \ Retry count
+0 VALUE xm-block#
+
+
+\ *
+\ * Internal function:
+\ * wait <timeout> seconds for a new character
+\ *
+: xmodem-get-byte ( timeout -- byte|-1 )
+ d# 1000 *
+ 0 DO
+ key? IF key UNLOOP EXIT THEN
+ 1 ms
+ LOOP
+ -1
+;
+
+
+\ *
+\ * Internal function:
+\ * Receive one XMODEM packet, check block number and check sum.
+\ *
+: xmodem-rx-packet ( address -- success? )
+ 1 xmodem-get-byte \ Get block number
+ dup 0 < IF
+ 2drop false EXIT \ Timeout
+ THEN
+ 1 xmodem-get-byte \ Get neg. block number
+ dup 0 < IF
+ 3drop false EXIT \ Timeout
+ THEN
+ rot 0 ( blk# ~blk# address chksum )
+ 80 0 DO
+ 1 xmodem-get-byte dup 0 < IF ( blk# ~blk# address chksum byte )
+ 3drop 2drop UNLOOP FALSE EXIT
+ THEN
+ dup 3 pick c! ( blk# ~blk# address chksum byte )
+ + swap 1+ swap ( blk# ~blk# address+1 chksum' )
+ LOOP
+ ( blk# ~blk# address chksum )
+ \ Check sum:
+ 0ff and
+ 1 xmodem-get-byte <> IF
+ \ CRC failed!
+ 3drop FALSE EXIT
+ THEN
+ drop ( blk# ~blk# )
+ \ finally check if block numbers are ok:
+ over xm-block# <> IF
+ \ Wrong block number!
+ 2drop FALSE EXIT
+ THEN ( blk# ~blk# )
+ ff xor =
+;
+
+
+\ *
+\ * Internal function:
+\ * Load file to given address via XMODEM protocol
+\ *
+: (xmodem-load) ( address -- bytes )
+ 1 to xm-block#
+ 0 to xm-retries
+ dup
+ BEGIN
+ d# 10 xmodem-get-byte dup >r
+ CASE
+ XM-SOH OF
+ dup xmodem-rx-packet IF
+ \ A packet has been received successfully
+ XM-ACK emit
+ 80 + ( start-addr next-addr R: rx-byte )
+ 0 to xm-retries \ Reset retry count
+ xm-block# 1+ ff and to xm-block# \ Increase current block#
+ ELSE
+ \ Error while receiving packet
+ XM-NAK emit
+ xm-retries 1+ to xm-retries \ Increase retry count
+ THEN
+ ENDOF
+ XM-EOT OF
+ XM-ACK emit
+ ENDOF
+ dup OF
+ XM-NAK emit
+ xm-retries 1+ to xm-retries \ Increase retry count
+ ENDOF
+ ENDCASE
+ r> XM-EOT =
+ xm-retries d# 10 >= OR
+ UNTIL ( start-address end-address )
+ swap - ( bytes received )
+;
+
+
+\ *
+\ * Load file to load-base via XMODEM protocol
+\ *
+: xmodem-load ( -- bytes )
+ cr ." Waiting for start of XMODEM upload..." cr
+ get-load-base (xmodem-load)
+;