blob: b0f578f4dc31be1396bc2276e725d71404a2a395 (
plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
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
|
