Commit | Line | Data |
---|---|---|
920dae64 AT |
1 | \ ========== Copyright Header Begin ========================================== |
2 | \ | |
3 | \ Hypervisor Software File: io.fth | |
4 | \ | |
5 | \ Copyright (c) 2006 Sun Microsystems, Inc. All Rights Reserved. | |
6 | \ | |
7 | \ - Do no alter or remove copyright notices | |
8 | \ | |
9 | \ - Redistribution and use of this software in source and binary forms, with | |
10 | \ or without modification, are permitted provided that the following | |
11 | \ conditions are met: | |
12 | \ | |
13 | \ - Redistribution of source code must retain the above copyright notice, | |
14 | \ this list of conditions and the following disclaimer. | |
15 | \ | |
16 | \ - Redistribution in binary form must reproduce the above copyright notice, | |
17 | \ this list of conditions and the following disclaimer in the | |
18 | \ documentation and/or other materials provided with the distribution. | |
19 | \ | |
20 | \ Neither the name of Sun Microsystems, Inc. or the names of contributors | |
21 | \ may be used to endorse or promote products derived from this software | |
22 | \ without specific prior written permission. | |
23 | \ | |
24 | \ This software is provided "AS IS," without a warranty of any kind. | |
25 | \ ALL EXPRESS OR IMPLIED CONDITIONS, REPRESENTATIONS AND WARRANTIES, | |
26 | \ INCLUDING ANY IMPLIED WARRANTY OF MERCHANTABILITY, FITNESS FOR A | |
27 | \ PARTICULAR PURPOSE OR NON-INFRINGEMENT, ARE HEREBY EXCLUDED. SUN | |
28 | \ MICROSYSTEMS, INC. ("SUN") AND ITS LICENSORS SHALL NOT BE LIABLE FOR | |
29 | \ ANY DAMAGES SUFFERED BY LICENSEE AS A RESULT OF USING, MODIFYING OR | |
30 | \ DISTRIBUTING THIS SOFTWARE OR ITS DERIVATIVES. IN NO EVENT WILL SUN | |
31 | \ OR ITS LICENSORS BE LIABLE FOR ANY LOST REVENUE, PROFIT OR DATA, OR | |
32 | \ FOR DIRECT, INDIRECT, SPECIAL, CONSEQUENTIAL, INCIDENTAL OR PUNITIVE | |
33 | \ DAMAGES, HOWEVER CAUSED AND REGARDLESS OF THE THEORY OF LIABILITY, | |
34 | \ ARISING OUT OF THE USE OF OR INABILITY TO USE THIS SOFTWARE, EVEN IF | |
35 | \ SUN HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGES. | |
36 | \ | |
37 | \ You acknowledge that this software is not designed, licensed or | |
38 | \ intended for use in the design, construction, operation or maintenance of | |
39 | \ any nuclear facility. | |
40 | \ | |
41 | \ ========== Copyright Header End ============================================ | |
42 | \ @(#)io.fth 2.22 05/02/14 | |
43 | \ Copyright 1985-1994 Bradley Forthware | |
44 | \ Copyright 2005 Sun Microsystems, Inc. All Rights Reserved | |
45 | \ Copyright Use is subject to license terms. | |
46 | ||
47 | decimal | |
48 | ||
49 | \ Emit is a two-level vector. | |
50 | \ The low level is (emit and the high level is emit. | |
51 | \ The low-level vector just selects the output device. | |
52 | \ The high-level vector performs other processing such as keeping | |
53 | \ track of the current position on the line, pausing, etc. | |
54 | \ Terminal control with escape sequences should use the low-level vector | |
55 | \ to prevent a pause from garbling the escape sequence. | |
56 | \ Key is a two-level vector. | |
57 | \ The low level is (key and the high level is key. | |
58 | \ The low-level vector just selects the output device. | |
59 | \ The high-level vector performs other processing such as switching | |
60 | \ the input stream between different windows. | |
61 | ||
62 | defer (type ( adr len -- ) \ Low-level type; just outputs characters | |
63 | defer type ( adr len -- ) \ High-level type | |
64 | defer (emit ( c -- ) \ Low level emit; just puts out the character | |
65 | defer emit ( c -- ) \ Higher level; keeps track of position on the line, etc | |
66 | defer (key ( -- c ) \ Low level key; just gets key | |
67 | defer key ( -- c ) \ Higher level; may do other nonsense | |
68 | defer key? ( -- f ) \ Is a character waiting? | |
69 | defer bye ( -- ) \ Exit to the operating system, if any | |
70 | defer (interactive? ( -- f ) \ Is input coming from the keyboard? | |
71 | defer interactive? ( -- f ) \ Is input coming from the keyboard? | |
72 | ' (interactive? is interactive? | |
73 | ||
74 | defer prompt ( -- ) | |
75 | defer quit | |
76 | ||
77 | defer accept ( adr len -- ) \ Read up to len characters from keyboard | |
78 | ||
79 | defer alloc-mem ( #bytes -- address ) | |
80 | defer free-mem ( adr #bytes -- ) | |
81 | ||
82 | defer lock[ ( -- ) ' noop is lock[ | |
83 | defer ]unlock ( -- ) ' noop is ]unlock | |
84 | ||
85 | defer sync-cache ( adr len -- ) ' 2drop is sync-cache | |
86 | ||
87 | defer #out ( -- adr ) | |
88 | defer #line ( -- adr ) | |
89 | defer cr ( -- ) | |
90 | ||
91 | \ Default actions | |
92 | : key1 ( -- char ) begin pause key? until (key ; | |
93 | : emit1 ( char -- ) pause (emit 1 #out +! ; | |
94 | : type1 ( adr len -- ) pause dup #out +! (type ; | |
95 | : default-type ( adr len -- ) | |
96 | 0 max bounds ?do pause i c@ (emit loop | |
97 | ; | |
98 | \ headerless \ from campus version | |
99 | nuser (#out \ number of characters emitted | |
100 | \ headers \ from campus version | |
101 | nuser (#line \ the number of lines sent so far | |
102 | ||
103 | \ Install defaults | |
104 | ' emit1 is emit | |
105 | ' type1 is type | |
106 | ' key1 is key | |
107 | ' (#out is #out | |
108 | ' (#line is #line | |
109 | ||
110 | decimal | |
111 | ||
112 | 7 constant bell | |
113 | 8 constant bs | |
114 | 10 constant linefeed | |
115 | 13 constant carret | |
116 | ||
117 | \ Obsolescent, but required by the IEEE 1275 device interface | |
118 | nuser span \ number of characters received by expect | |
119 | ||
120 | \ A place to put the last word returned by blword | |
121 | 0 value 'word | |
122 | ||
123 | : expect ( adr len -- ) accept span ! ; | |
124 | ||
125 | defer newline-pstring | |
126 | : newline-string ( -- adr len ) newline-pstring count ; | |
127 | : newline ( -- char ) newline-string + 1- c@ ; \ Last character | |
128 | ||
129 | : space (s -- ) bl emit ; | |
130 | : spaces (s n -- ) 0 max 0 ?do space loop ; | |
131 | : backspaces (s n -- ) dup negate #out +! 0 ?do bs (emit loop ; | |
132 | : beep (s -- ) bell (emit ; | |
133 | : (lf (s -- ) 1 #line +! linefeed (emit ; | |
134 | : (cr (s -- ) carret (emit ; | |
135 | : lf (s -- ) #out off (lf ; | |
136 | : crlf (s -- ) (cr lf ; | |
137 | ||
138 | 0 value tib | |
139 | ||
140 | headerless | |
141 | 0 value #-buf | |
142 | chain: init ( -- ) | |
143 | 40 dup alloc-mem + is #-buf | |
144 | /tib alloc-mem is tib | |
145 | ; | |
146 | headers | |
147 | ||
148 | nuser base \ for numeric input and output | |
149 | ||
150 | nuser hld \ points to last character held in #-buf | |
151 | : hold (s char -- ) -1 hld +! hld @ c! ; | |
152 | : hold$ ( adr len -- ) | |
153 | dup if | |
154 | 1- bounds swap do i c@ hold -1 +loop | |
155 | else | |
156 | 2drop | |
157 | then | |
158 | ; | |
159 | : <# (s -- ) #-buf hld ! ; | |
160 | : sign (s n -- ) 0< if ascii - hold then ; | |
161 | \ for upper case hex output, change 39 to 7 | |
162 | : >digit (s n -- char ) dup 9 > if 39 + then 48 + ; | |
163 | : u# (s u1 -- u2 ) | |
164 | base @ u/mod ( nrem u2 ) swap >digit hold ( u2 ) | |
165 | ; | |
166 | : u#s (s u -- 0 ) begin u# dup 0= until ; | |
167 | : u#> (s u -- addr len ) drop hld @ #-buf over - ; | |
168 | ||
169 | : mu/mod (s d n1 -- rem d.quot ) | |
170 | >r 0 r@ um/mod r> swap >r um/mod r> | |
171 | ; | |
172 | ||
173 | : # (s ud1 -- ud2 ) | |
174 | base @ mu/mod ( nrem ud2 ) rot >digit hold ( ud2 ) | |
175 | ; | |
176 | : #s (s ud -- 0 0 ) begin # 2dup or 0= until ; | |
177 | : #> (s ud -- addr len ) drop u#> ; | |
178 | ||
179 | : (u.) (s u -- a len ) <# u#s u#> ; | |
180 | : u. (s u -- ) (u.) type space ; | |
181 | : u.r (s u len -- ) >r (u.) r> over - spaces type ; | |
182 | : (.) (s n -- a len ) dup abs <# u#s swap sign u#> ; | |
183 | : (.d) ( n -- adr len ) base @ >r decimal (.) r> base ! ; | |
184 | : (.h) ( n -- adr len ) base @ >r hex (.) r> base ! ; | |
185 | : s. (s n -- ) (.) type space ; | |
186 | : .r (s n l -- ) >r (.) r> over - spaces type ; | |
187 | ||
188 | [ifndef] run-time | |
189 | headerless | |
190 | : (ul.) (s ul -- a l ) n->l <# u#s u#> ; | |
191 | headers | |
192 | : ul. (s ul -- ) (ul.) type space ; | |
193 | headerless | |
194 | : ul.r (s ul l -- ) >r (ul.) r> over - spaces type ; | |
195 | ||
196 | : (l.) (s l -- a l ) dup l->n swap abs <# u#s swap sign u#> ; | |
197 | headers | |
198 | : l. (s l -- ) base @ d# 10 = if (l.) else (ul.) then type space ; | |
199 | headerless | |
200 | : l.r (s l l -- ) >r (l.) r> over - spaces type ; | |
201 | headers | |
202 | [then] | |
203 | ||
204 | \ smart print that knows that signed hex numbers are uninteresting | |
205 | : n. (s n -- ) base @ 10 = if s. else u. then ; | |
206 | : . (s n -- ) (.) type space ; | |
207 | : ? (s addr -- ) @ n. ; | |
208 | ||
209 | : (.s (s -- ) | |
210 | depth 0 ?do depth i - 1- pick n. loop | |
211 | ; | |
212 | : .s (s -- ) | |
213 | depth 0< | |
214 | if ." Stack Underflow " sp0 @ sp! | |
215 | else depth | |
216 | if (.s else ." Empty " then | |
217 | then | |
218 | ; | |
219 | : ". (s pstr -- ) count type ; |