![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to iocontrol.fs CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [Qemu by Fabrice Bellard] / qemu / roms / openbios / forth / admin|
Return to iocontrol.fs CVS log | Up to [Qemu by Fabrice Bellard] / qemu / roms / openbios / forth / admin |
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.