Add qemu 2.4.0

[kvmfornfv.git] / qemu / roms / openbios / forth / admin / iocontrol.fs

diff --git a/qemu/roms/openbios/forth/admin/iocontrol.fs b/qemu/roms/openbios/forth/admin/iocontrol.fs
new file mode 100644 (file)
index 0000000..b0f578f
--- /dev/null
+++ b/qemu/roms/openbios/forth/admin/iocontrol.fs
@@ -0,0 +1,168 @@
+\ tag: stdin/stdout handling
+\ 
+\ Copyright (C) 2003 Samuel Rydh
+\ 
+\ See the file "COPYING" for further information about
+\ the copyright and warranty status of this work.
+\ 
+
+\ 7.4.5    I/O control
+
+variable stdout
+variable stdin
+
+: input    ( dev-str dev-len -- )
+  2dup find-dev 0= if
+    ." Input device " type ."  not found." cr exit
+  then
+
+  " read" rot find-method 0= if
+    type ."  has no read method." cr exit
+  then
+  drop
+  
+  \ open stdin device
+  2dup open-dev ?dup 0= if
+    ." Opening " type ."  failed." cr exit
+  then
+  -rot 2drop
+
+  \ call install-abort if present
+  dup " install-abort" rot ['] $call-method catch if 3drop then
+
+  \ close old stdin
+  stdin @ ?dup if
+    dup " remove-abort" rot ['] $call-method catch if 3drop then
+    close-dev
+  then
+  stdin !
+
+  \ update /chosen
+  " /chosen" find-package if
+    >r stdin @ encode-int " stdin" r> (property)
+  then
+
+[IFDEF] CONFIG_SPARC32
+  \ update stdin-path properties
+  \ (this isn't part of the IEEE1275 spec but needed by older Solaris)
+  " /" find-package if
+    >r stdin @ get-instance-path encode-string " stdin-path" r> (property)
+  then
+[THEN]
+;
+
+: output    ( dev-str dev-len -- )
+  2dup find-dev 0= if
+    ." Output device " type ."  not found." cr exit
+  then
+
+  " write" rot find-method 0= if
+    type ."  has no write method." cr exit
+  then
+  drop
+  
+  \ open stdin device
+  2dup open-dev ?dup 0= if
+    ." Opening " type ."  failed." cr exit
+  then
+  -rot 2drop
+
+  \ close old stdout
+  stdout @ ?dup if close-dev then
+  stdout !
+
+  \ update /chosen
+  " /chosen" find-package if
+    >r stdout @ encode-int " stdout" r> (property)
+  then
+
+[IFDEF] CONFIG_SPARC32
+  \ update stdout-path properties
+  \ (this isn't part of the IEEE1275 spec but needed by older Solaris)
+  " /" find-package if
+    >r stdout @ get-instance-path encode-string " stdout-path" r> (property)
+  then
+[THEN]
+;
+
+: io    ( dev-str dev-len -- )
+  2dup input output
+;
+
+\ key?, key and emit implementation
+variable io-char
+variable io-out-char
+
+: io-key? ( -- available? )
+  io-char @ -1 <> if true exit then
+  io-char 1 " read" stdin @ $call-method
+  1 =
+;
+
+: io-key ( -- key )
+  \ poll for key
+  begin io-key? until
+  io-char c@ -1 to io-char
+;
+
+: io-emit ( char -- )
+  stdout @ if
+    io-out-char c!
+    io-out-char 1 " write" stdout @ $call-method
+  then
+  drop
+;
+
+variable CONSOLE-IN-list
+variable CONSOLE-OUT-list
+
+: CONSOLE-IN-initializer ( xt -- )
+  CONSOLE-IN-list list-add , 
+;
+: CONSOLE-OUT-initializer ( xt -- )
+  CONSOLE-OUT-list list-add , 
+;
+
+: install-console    ( -- )
+  
+  \ create screen alias
+  " /aliases" find-package if
+    >r
+    " screen" find-package if drop else
+      \ bad (or missing) screen alias
+      0 " display" iterate-device-type ?dup if
+        ( display-ph R: alias-ph )
+        get-package-path encode-string " screen" r@ (property)
+      then
+    then
+    r> drop
+  then
+
+  output-device output
+  input-device input
+
+  \ let arch determine a useful output device
+  CONSOLE-OUT-list begin list-get while
+    stdout @ if drop else @ execute then
+  repeat
+
+  \ let arch determine a useful input device
+  CONSOLE-IN-list begin list-get while
+    stdin @ if drop else @ execute then
+  repeat
+
+  \ activate console
+  stdout @ if
+    ['] io-emit to emit
+  then
+
+  stdin @ if
+    -1 to io-char
+    ['] io-key? to key?
+    ['] io-key to key  
+  then
+;
+
+:noname
+  " screen" output
+; CONSOLE-OUT-initializer