Return to iocontrol.fs CVS log

Up to [Qemu by Fabrice Bellard] / qemu / roms / openbios / forth / admin

Annotation of qemu/roms/openbios/forth/admin/iocontrol.fs, revision 1.1

1.1     ! root        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: 
        !            41: : output    ( dev-str dev-len -- )
        !            42:   2dup find-dev 0= if
        !            43:     ." Output device " type ."  not found." cr exit
        !            44:   then
        !            45: 
        !            46:   " write" rot find-method 0= if
        !            47:     type ."  has no write method." cr exit
        !            48:   then
        !            49:   drop
        !            50:   
        !            51:   \ open stdin device
        !            52:   2dup open-dev ?dup 0= if
        !            53:     ." Opening " type ."  failed." cr exit
        !            54:   then
        !            55:   -rot 2drop
        !            56: 
        !            57:   \ close old stdout
        !            58:   stdout @ ?dup if close-dev then
        !            59:   stdout !
        !            60: ;
        !            61: 
        !            62: : io    ( dev-str dev-len -- )
        !            63:   2dup input output
        !            64: ;
        !            65: 
        !            66: \ key?, key and emit implementation
        !            67: variable io-char
        !            68: variable io-out-char
        !            69: 
        !            70: : io-key? ( -- available? )
        !            71:   io-char @ -1 <> if true exit then
        !            72:   io-char 1 " read" stdin @ $call-method
        !            73:   1 =
        !            74: ;
        !            75: 
        !            76: : io-key ( -- key )
        !            77:   \ poll for key
        !            78:   begin io-key? until
        !            79:   io-char c@ -1 to io-char
        !            80: ;
        !            81: 
        !            82: : io-emit ( char -- )
        !            83:   io-out-char c!
        !            84:   io-out-char 1 " write" stdout @ $call-method drop
        !            85: ;
        !            86: 
        !            87: variable CONSOLE-IN-list
        !            88: variable CONSOLE-OUT-list
        !            89: 
        !            90: : CONSOLE-IN-initializer ( xt -- )
        !            91:   CONSOLE-IN-list list-add , 
        !            92: ;
        !            93: : CONSOLE-OUT-initializer ( xt -- )
        !            94:   CONSOLE-OUT-list list-add , 
        !            95: ;
        !            96: 
        !            97: : install-console    ( -- )
        !            98:   
        !            99:   \ create screen alias
        !           100:   " /aliases" find-package if
        !           101:     >r
        !           102:     " screen" find-package if drop else
        !           103:       \ bad (or missing) screen alias
        !           104:       0 " display" iterate-device-type ?dup if
        !           105:         ( display-ph R: alias-ph )
        !           106:         get-package-path encode-string " screen" r@ (property)
        !           107:       then
        !           108:     then
        !           109:     r> drop
        !           110:   then
        !           111: 
        !           112:   output-device output
        !           113:   input-device input
        !           114: 
        !           115:   \ let arch determine a useful output device
        !           116:   CONSOLE-OUT-list begin list-get while
        !           117:     stdout @ if drop else @ execute then
        !           118:   repeat
        !           119: 
        !           120:   \ let arch determine a useful input device
        !           121:   CONSOLE-IN-list begin list-get while
        !           122:     stdin @ if drop else @ execute then
        !           123:   repeat
        !           124: 
        !           125:   \ activate console
        !           126:   stdout @ if
        !           127:     ['] io-emit to emit
        !           128:   then
        !           129: 
        !           130:   stdin @ if
        !           131:     -1 to io-char
        !           132:     ['] io-key? to key?
        !           133:     ['] io-key to key  
        !           134:   then
        !           135: ;
        !           136: 
        !           137: :noname
        !           138:   " screen" output
        !           139: ; CONSOLE-OUT-initializer

This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.