qemu/roms/openbios/forth/admin/iocontrol.fs

   1 \ tag: stdin/stdout handling
   2 \
   3 \ Copyright (C) 2003 Samuel Rydh
   4 \
   5 \ See the file "COPYING" for further information about
   6 \ the copyright and warranty status of this work.
   7 \
   8
   9 \ 7.4.5    I/O control
  10
  11 variable stdout
  12 variable stdin
  13
  14 : input    ( dev-str dev-len -- )
  15   2dup find-dev 0= if
  16     ." Input device " type ."  not found." cr exit
  17   then
  18
  19   " read" rot find-method 0= if
  20     type ."  has no read method." cr exit
  21   then
  22   drop
  23
  24   \ open stdin device
  25   2dup open-dev ?dup 0= if
  26     ." Opening " type ."  failed." cr exit
  27   then
  28   -rot 2drop
  29
  30   \ call install-abort if present
  31   dup " install-abort" rot ['] $call-method catch if 3drop then
  32
  33   \ close old stdin
  34   stdin @ ?dup if
  35     dup " remove-abort" rot ['] $call-method catch if 3drop then
  36     close-dev
  37   then
  38   stdin !
  39
  40   \ update /chosen
  41   " /chosen" find-package if
  42     >r stdin @ encode-int " stdin" r> (property)
  43   then
  44
  45 [IFDEF] CONFIG_SPARC32
  46   \ update stdin-path properties
  47   \ (this isn't part of the IEEE1275 spec but needed by older Solaris)
  48   " /" find-package if
  49     >r stdin @ get-instance-path encode-string " stdin-path" r> (property)
  50   then
  51 [THEN]
  52 ;
  53
  54 : output    ( dev-str dev-len -- )
  55   2dup find-dev 0= if
  56     ." Output device " type ."  not found." cr exit
  57   then
  58
  59   " write" rot find-method 0= if
  60     type ."  has no write method." cr exit
  61   then
  62   drop
  63
  64   \ open stdin device
  65   2dup open-dev ?dup 0= if
  66     ." Opening " type ."  failed." cr exit
  67   then
  68   -rot 2drop
  69
  70   \ close old stdout
  71   stdout @ ?dup if close-dev then
  72   stdout !
  73
  74   \ update /chosen
  75   " /chosen" find-package if
  76     >r stdout @ encode-int " stdout" r> (property)
  77   then
  78
  79 [IFDEF] CONFIG_SPARC32
  80   \ update stdout-path properties
  81   \ (this isn't part of the IEEE1275 spec but needed by older Solaris)
  82   " /" find-package if
  83     >r stdout @ get-instance-path encode-string " stdout-path" r> (property)
  84   then
  85 [THEN]
  86 ;
  87
  88 : io    ( dev-str dev-len -- )
  89   2dup input output
  90 ;
  91
  92 \ key?, key and emit implementation
  93 variable io-char
  94 variable io-out-char
  95
  96 : io-key? ( -- available? )
  97   io-char @ -1 <> if true exit then
  98   io-char 1 " read" stdin @ $call-method
  99   1 =
 100 ;
 101
 102 : io-key ( -- key )
 103   \ poll for key
 104   begin io-key? until
 105   io-char c@ -1 to io-char
 106 ;
 107
 108 : io-emit ( char -- )
 109   stdout @ if
 110     io-out-char c!
 111     io-out-char 1 " write" stdout @ $call-method
 112   then
 113   drop
 114 ;
 115
 116 variable CONSOLE-IN-list
 117 variable CONSOLE-OUT-list
 118
 119 : CONSOLE-IN-initializer ( xt -- )
 120   CONSOLE-IN-list list-add ,
 121 ;
 122 : CONSOLE-OUT-initializer ( xt -- )
 123   CONSOLE-OUT-list list-add ,
 124 ;
 125
 126 : install-console    ( -- )
 127
 128   \ create screen alias
 129   " /aliases" find-package if
 130     >r
 131     " screen" find-package if drop else
 132       \ bad (or missing) screen alias
 133       0 " display" iterate-device-type ?dup if
 134         ( display-ph R: alias-ph )
 135         get-package-path encode-string " screen" r@ (property)
 136       then
 137     then
 138     r> drop
 139   then
 140
 141   output-device output
 142   input-device input
 143
 144   \ let arch determine a useful output device
 145   CONSOLE-OUT-list begin list-get while
 146     stdout @ if drop else @ execute then
 147   repeat
 148
 149   \ let arch determine a useful input device
 150   CONSOLE-IN-list begin list-get while
 151     stdin @ if drop else @ execute then
 152   repeat
 153
 154   \ activate console
 155   stdout @ if
 156     ['] io-emit to emit
 157   then
 158
 159   stdin @ if
 160     -1 to io-char
 161     ['] io-key? to key?
 162     ['] io-key to key
 163   then
 164 ;
 165
 166 :noname
 167   " screen" output
 168 ; CONSOLE-OUT-initializer