Root/
Source at commit 1305 created 12 years 8 months ago. By meklort, Cleanup arch makefiles. Begin merging of BootX source - will need cleaning up | |
---|---|
1 | /*␊ |
2 | * Copyright (c) 2000 Apple Computer, Inc. All rights reserved.␊ |
3 | *␊ |
4 | * @APPLE_LICENSE_HEADER_START@␊ |
5 | * ␊ |
6 | * The contents of this file constitute Original Code as defined in and␊ |
7 | * are subject to the Apple Public Source License Version 1.1 (the␊ |
8 | * "License"). You may not use this file except in compliance with the␊ |
9 | * License. Please obtain a copy of the License at␊ |
10 | * http://www.apple.com/publicsource and read it before using this file.␊ |
11 | * ␊ |
12 | * This Original Code and all software distributed under the License are␊ |
13 | * distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY KIND, EITHER␊ |
14 | * EXPRESS OR IMPLIED, AND APPLE HEREBY DISCLAIMS ALL SUCH WARRANTIES,␊ |
15 | * INCLUDING WITHOUT LIMITATION, ANY WARRANTIES OF MERCHANTABILITY,␊ |
16 | * FITNESS FOR A PARTICULAR PURPOSE OR NON-INFRINGEMENT. Please see the␊ |
17 | * License for the specific language governing rights and limitations␊ |
18 | * under the License.␊ |
19 | * ␊ |
20 | * @APPLE_LICENSE_HEADER_END@␊ |
21 | */␊ |
22 | /*␊ |
23 | * Control2.c - OF replacement driver for Control.␊ |
24 | *␊ |
25 | * Copyright (c) 1998-2000 Apple Computer, Inc.␊ |
26 | *␊ |
27 | * DRI: Josh de Cesare␊ |
28 | */␊ |
29 | ␊ |
30 | const char *gControl2Source[] = {␊ |
31 | ␉"\" /chaos/control\" find-device "␊ |
32 | ␉"-1 value bankB? "␊ |
33 | ␉"-1 value REGS "␊ |
34 | ␉"-1 value FB-ADDRESS "␊ |
35 | ␉"-1 value phys-regs "␊ |
36 | ␉"-1 value phys-fb-address "␊ |
37 | ␉"0 value mono-mode? "␊ |
38 | ␉"0 value width "␊ |
39 | ␉"0 value height "␊ |
40 | ␉"0 value sense-code "␊ |
41 | ␉"0 value ext-sense "␊ |
42 | ␉"h# F301B000 constant RADACAL "␊ |
43 | ␉"h# F301B000 constant RADACAL-base "␊ |
44 | ␉"variable RGB-temp "␊ |
45 | ␉"struct "␊ |
46 | ␉"( 000 )␉d# 16␉field␉>C.CUR-LINE "␊ |
47 | ␉"( 010 )␉d# 16␉field␉>C.VFPEQ "␊ |
48 | ␉"( 020 )␉d# 16␉field␉>C.VFP "␊ |
49 | ␉"( 030 )␉d# 16␉field␉>C.VAL "␊ |
50 | ␉"( 040 )␉d# 16␉field␉>C.VBP "␊ |
51 | ␉"( 050 )␉d# 16␉field␉>C.VBPEQ "␊ |
52 | ␉"( 060 )␉d# 16␉field␉>C.VSYNC "␊ |
53 | ␉"( 070 )␉d# 16␉field␉>C.VHLINE "␊ |
54 | ␉"( 080 )␉d# 16␉field␉>C.PIPED "␊ |
55 | ␉"( 090 )␉d# 16␉field␉>C.HPIX "␊ |
56 | ␉"( 0A0 )␉d# 16␉field␉>C.HFP "␊ |
57 | ␉"( 0B0 )␉d# 16␉field␉>C.HAL "␊ |
58 | ␉"( 0C0 )␉d# 16␉field␉>C.HBWAY "␊ |
59 | ␉"( 0D0 )␉d# 16␉field␉>C.HSP "␊ |
60 | ␉"( 0E0 )␉d# 16␉field␉>C.HEQ "␊ |
61 | ␉"( 0F0 )␉d# 16␉field␉>C.HLFLN "␊ |
62 | ␉"( 100 )␉d# 16␉field␉>C.HSERR "␊ |
63 | ␉"( 110 )␉d# 16␉field␉>C.CNTTST "␊ |
64 | ␉"( 120 )␉d# 16␉field␉>C.TEST "␊ |
65 | ␉"( 130 )␉d# 16␉field␉>C.GBASE "␊ |
66 | ␉"( 140 )␉d# 16␉field␉>C.ROW-WORDS "␊ |
67 | ␉"( 150 )␉d# 16␉field␉>C.MON-SENSE "␊ |
68 | ␉"( 160 )␉d# 16␉field␉>C.ENABLE "␊ |
69 | ␉"( 170 )␉d# 16␉field␉>C.GSC-DIVIDE "␊ |
70 | ␉"( 180 )␉d# 16␉field␉>C.REFRESH-COUNT "␊ |
71 | ␉"( 190 )␉d# 16␉field␉>C.INT-ENABLE "␊ |
72 | ␉"( 1A0 )␉d# 16␉field␉>C.INT-STATUS "␊ |
73 | ␉"drop "␊ |
74 | ␉"struct "␊ |
75 | ␉"d# 16␉field␉>R.REG-ADDR "␊ |
76 | ␉"d# 16␉field␉>R.CRSR-PALETTE "␊ |
77 | ␉"d# 16␉field␉>R.REG-DATA "␊ |
78 | ␉"d# 16␉field␉>R.COLOR-PALETTE "␊ |
79 | ␉"drop "␊ |
80 | ␉"create k512x384@60 "␊ |
81 | ␉"h# 0E1B6210 L, "␊ |
82 | ␉"d# 811 w, d# 810 w, d# 42 w, d# 23 w, d# 4 w, d# 812 w, d# 814 w, d# 48 w, "␊ |
83 | ␉"d# 318 w, d# 305 w, d# 49 w, d# 15 w, d# 319 w, d# 8 w, d# 160 w, d# 304 w, "␊ |
84 | ␉"d# 2 w, d# 512 w, d# 384 w, "␊ |
85 | ␉"create k640x480@67 "␊ |
86 | ␉"h# 0E1B0210 L, "␊ |
87 | ␉"d# 1045 w, d# 1042 w, d# 82 w, d# 43 w, d# 4 w, d# 1048 w, d# 1050 w, d# 72 w, "␊ |
88 | ␉"d# 430 w, d# 393 w, d# 73 w, d# 31 w, d# 431 w, d# 16 w, d# 216 w, d# 400 w, "␊ |
89 | ␉"d# 2 w, d# 640 w, d# 480 w, "␊ |
90 | ␉"create k640x870@75 "␊ |
91 | ␉"h# 172A0310 L, "␊ |
92 | ␉"d# 1831 w, d# 1828 w, d# 88 w, d# 46 w, d# 4 w, d# 1834 w, d# 1836 w, d# 72 w, "␊ |
93 | ␉"d# 414 w, d# 393 w, d# 73 w, d# 39 w, d# 415 w, d# 20 w, d# 208 w, d# 376 w, "␊ |
94 | ␉"d# 2 w, d# 640 w, d# 870 w, "␊ |
95 | ␉"create k640x480@60VGA "␊ |
96 | ␉"h# 17250210 L, "␊ |
97 | ␉"d# 1037 w, d# 1026 w, d# 66 w, d# 34 w, d# 2 w, d# 1048 w, d# 1050 w, d# 64 w, "␊ |
98 | ␉"d# 398 w, d# 385 w, d# 65 w, d# 47 w, d# 399 w, d# 24 w, d# 200 w, d# 352 w, "␊ |
99 | ␉"d# 2 w, d# 640 w, d# 480 w, "␊ |
100 | ␉"create k832x624@75 "␊ |
101 | ␉"h# 172A0310 L, "␊ |
102 | ␉"d# 1331 w, d# 1330 w, d# 82 w, d# 43 w, d# 4 w, d# 1332 w, d# 1334 w, d# 136 w, "␊ |
103 | ␉"d# 574 w, d# 553 w, d# 137 w, d# 31 w, d# 575 w, d# 16 w, d# 288 w, d# 544 w, "␊ |
104 | ␉"d# 2 w, d# 832 w, d# 624 w, "␊ |
105 | ␉"create k1024x768@75 "␊ |
106 | ␉"h# 0B1C0310 L, "␊ |
107 | ␉"d# 1603 w, d# 1600 w, d# 64 w, d# 34 w, d# 4 w, d# 1606 w, d# 1608 w, d# 128 w, "␊ |
108 | ␉"d# 662 w, d# 641 w, d# 129 w, d# 47 w, d# 663 w, d# 24 w, d# 332 w, d# 616 w, "␊ |
109 | ␉"d# 2 w, d# 1024 w, d# 768 w, "␊ |
110 | ␉"create k1152x870@75 "␊ |
111 | ␉"h# 133D0310 L, "␊ |
112 | ␉"d# 1825 w, d# 1822 w, d# 82 w, d# 43 w, d# 4 w, d# 1828 w, d# 1830 w, d# 128 w, "␊ |
113 | ␉"d# 726 w, d# 705 w, d# 129 w, d# 63 w, d# 727 w, d# 32 w, d# 364 w, d# 664 w, "␊ |
114 | ␉"d# 2 w, d# 1152 w, d# 870 w, "␊ |
115 | ␉": SENSE! 5 ms regs >C.MON-SENSE rl! 5 ms ; "␊ |
116 | ␉": SENSE@ 5 ms regs >C.MON-SENSE rl@ 5 ms ; "␊ |
117 | ␉": MON-SENSE␉( -- ) "␊ |
118 | ␉"o# 70 sense! "␊ |
119 | ␉"sense@ 6 >> 7 and dup to sense-code "␊ |
120 | ␉"dup 6 < if "␊ |
121 | ␉"b# 1000000 or "␊ |
122 | ␉"else drop "␊ |
123 | ␉"o# 30 sense! "␊ |
124 | ␉"sense@ 2 >> b# 110000 and "␊ |
125 | ␉"o# 50 sense! "␊ |
126 | ␉"sense@ dup 4 >> b# 000100 and swap 5 >> b# 001000 and or or "␊ |
127 | ␉"o# 60 sense! sense@ 7 >> b# 000011 and or "␊ |
128 | ␉"to ext-sense "␊ |
129 | ␉"then "␊ |
130 | ␉"o# 70 sense! "␊ |
131 | ␉"; "␊ |
132 | ␉": get-mode ( -- mode-table mono-mode? ) "␊ |
133 | ␉"sense-code case "␊ |
134 | ␉"0 of "␊ |
135 | ␉"false "␊ |
136 | ␉"k1152x870@75 "␊ |
137 | ␉"endof "␊ |
138 | ␉"1 of "␊ |
139 | ␉"true "␊ |
140 | ␉"k640x870@75 "␊ |
141 | ␉"endof "␊ |
142 | ␉"2 of "␊ |
143 | ␉"false "␊ |
144 | ␉"k512x384@60 "␊ |
145 | ␉"endof "␊ |
146 | ␉"3 of "␊ |
147 | ␉"true "␊ |
148 | ␉"k1152x870@75 "␊ |
149 | ␉"endof "␊ |
150 | ␉"5 of "␊ |
151 | ␉"false "␊ |
152 | ␉"k640x870@75 "␊ |
153 | ␉"endof "␊ |
154 | ␉"6 of "␊ |
155 | ␉"ext-sense case "␊ |
156 | ␉"3 of "␊ |
157 | ␉"false "␊ |
158 | ␉"k832x624@75 "␊ |
159 | ␉"endof "␊ |
160 | ␉"h# 0b of "␊ |
161 | ␉"false "␊ |
162 | ␉"k1024x768@75 "␊ |
163 | ␉"endof "␊ |
164 | ␉"h# 23 of "␊ |
165 | ␉"false "␊ |
166 | ␉"k1152x870@75 "␊ |
167 | ␉"endof "␊ |
168 | ␉"drop "␊ |
169 | ␉"false "␊ |
170 | ␉"k640x480@67 "␊ |
171 | ␉"0 endcase "␊ |
172 | ␉"endof "␊ |
173 | ␉"7 of "␊ |
174 | ␉"ext-sense case "␊ |
175 | ␉"h# 2d of "␊ |
176 | ␉"false "␊ |
177 | ␉"k832x624@75 "␊ |
178 | ␉"endof "␊ |
179 | ␉"h# 3a of "␊ |
180 | ␉"false "␊ |
181 | ␉"k1024x768@75 "␊ |
182 | ␉"endof "␊ |
183 | ␉"h# 17 of "␊ |
184 | ␉"false "␊ |
185 | ␉"k640x480@60VGA "␊ |
186 | ␉"endof "␊ |
187 | ␉"h# 3f of "␊ |
188 | ␉"false "␊ |
189 | ␉"0 "␊ |
190 | ␉"endof "␊ |
191 | ␉"drop "␊ |
192 | ␉"false "␊ |
193 | ␉"k640x480@67 "␊ |
194 | ␉"0 endcase "␊ |
195 | ␉"endof "␊ |
196 | ␉"drop "␊ |
197 | ␉"false "␊ |
198 | ␉"k640x480@67 "␊ |
199 | ␉"0 endcase "␊ |
200 | ␉"; "␊ |
201 | ␉"HEADERLESS "␊ |
202 | ␉"create std-16 "␊ |
203 | ␉"\" \"(000000 0000AA 00AA00 00AAAA AA0000 AA00AA AA5500 AAAAAA)\" $c, "␊ |
204 | ␉"\" \"(555555 5555FF 55FF55 55FFFF FF5555 FF55FF FFFF55 FFFFFF)\" $c, "␊ |
205 | ␉"create std-gamma "␊ |
206 | ␉"\" \"(00 05 09 0B 0E 10 13 15 17 19 1B 1D 1E 20 22 24)\" $c, "␊ |
207 | ␉"\" \"(25 27 28 2A 2C 2D 2F 30 31 33 34 36 37 38 3A 3B)\" $c, "␊ |
208 | ␉"\" \"(3C 3E 3F 40 42 43 44 45 47 48 49 4A 4B 4D 4E 4F)\" $c, "␊ |
209 | ␉"\" \"(50 51 52 54 55 56 57 58 59 5A 5B 5C 5E 5F 60 61)\" $c, "␊ |
210 | ␉"\" \"(62 63 64 65 66 67 68 69 6A 6B 6C 6D 6E 6F 70 71)\" $c, "␊ |
211 | ␉"\" \"(72 73 74 75 76 77 78 79 7A 7B 7C 7D 7E 7F 80 81)\" $c, "␊ |
212 | ␉"\" \"(81 82 83 84 85 86 87 88 89 8A 8B 8C 8C 8D 8E 8F)\" $c, "␊ |
213 | ␉"\" \"(90 91 92 93 94 95 95 96 97 98 99 9A 9B 9B 9C 9D)\" $c, "␊ |
214 | ␉"\" \"(9E 9F A0 A1 A1 A2 A3 A4 A5 A6 A6 A7 A8 A9 AA AB)\" $c, "␊ |
215 | ␉"\" \"(AB AC AD AE AF B0 B0 B1 B2 B3 B4 B4 B5 B6 B7 B8)\" $c, "␊ |
216 | ␉"\" \"(B8 B9 BA BB BC BC BD BE BF C0 C0 C1 C2 C3 C3 C4)\" $c, "␊ |
217 | ␉"\" \"(C5 C6 C7 C7 C8 C9 CA CA CB CC CD CD CE CF D0 D0)\" $c, "␊ |
218 | ␉"\" \"(D1 D2 D3 D3 D4 D5 D6 D6 D7 D8 D9 D9 DA DB DC DC)\" $c, "␊ |
219 | ␉"\" \"(DD DE DF DF E0 E1 E1 E2 E3 E4 E4 E5 E6 E7 E7 E8)\" $c, "␊ |
220 | ␉"\" \"(E9 E9 EA EB EC EC ED EE EE EF F0 F1 F1 F2 F3 F3)\" $c, "␊ |
221 | ␉"\" \"(F4 F5 F5 F6 F7 F8 F8 F9 FA FA FB FC FC FD FE FF)\" $c, "␊ |
222 | ␉": c+␉␉( adr -- adr+1 val ) "␊ |
223 | ␉"dup 1+ swap c@ "␊ |
224 | ␉"; "␊ |
225 | ␉": c!+␉␉( adr val -- adr+1 ) "␊ |
226 | ␉"swap dup 1+ -rot c! "␊ |
227 | ␉"; "␊ |
228 | ␉": do-gamma "␊ |
229 | ␉"std-gamma + c@ "␊ |
230 | ␉"; "␊ |
231 | ␉": anti-gamma␉( val -- orig ) "␊ |
232 | ␉"h# 100 0 do "␊ |
233 | ␉"std-gamma i + c@ over >= if "␊ |
234 | ␉"drop i unloop exit "␊ |
235 | ␉"then "␊ |
236 | ␉"loop "␊ |
237 | ␉"drop h# ff "␊ |
238 | ␉"; "␊ |
239 | ␉": W@++␉( addr -- addr word ) "␊ |
240 | ␉"dup 2+ swap w@ "␊ |
241 | ␉"; "␊ |
242 | ␉": CLUT@ ( -- ) "␊ |
243 | ␉"3 0 do RADACAL-base >R.COLOR-PALETTE rb@ loop 2 ms "␊ |
244 | ␉"; "␊ |
245 | ␉": CLUT!␉( -- ) "␊ |
246 | ␉"3 0 do RADACAL-base >R.COLOR-PALETTE rb! loop 2 ms "␊ |
247 | ␉"; "␊ |
248 | ␉": RAD-REG-ADDR! "␊ |
249 | ␉"RADACAL-base >R.REG-ADDR rb! 2 ms "␊ |
250 | ␉"; "␊ |
251 | ␉": RAD!␉( c a -- ) "␊ |
252 | ␉"( a ) rad-reg-addr! "␊ |
253 | ␉"( c ) ␉RADACAL-base >R.REG-DATA rb! 2 ms "␊ |
254 | ␉"; "␊ |
255 | ␉": init-RADACAL ( val -- ) "␊ |
256 | ␉"( val ) h# 20 rad! "␊ |
257 | ␉"bankb? 1 and h# 21 rad! "␊ |
258 | ␉"0␉h# 10 rad! "␊ |
259 | ␉"0␉h# 11 rad! "␊ |
260 | ␉"; "␊ |
261 | ␉"h# F3016000 constant vPortB "␊ |
262 | ␉"h# F3016400 constant vDDRB "␊ |
263 | ␉"h# F3017400 constant vSHR "␊ |
264 | ␉"h# F3017600 constant vACR "␊ |
265 | ␉"h# F3017800 constant vPCR "␊ |
266 | ␉"h# F3017A00 constant vIFR "␊ |
267 | ␉"h# F3017C00 constant vIER "␊ |
268 | ␉"h# 0C constant kSRModeIn "␊ |
269 | ␉"h# 1C constant kSRModeOut "␊ |
270 | ␉"h# 04 constant kSRIReq "␊ |
271 | ␉"h# 10 constant kByteAckBit "␊ |
272 | ␉"h# DF constant kAssertTIP "␊ |
273 | ␉"h# 20 constant kNegateTIP "␊ |
274 | ␉"h# EF constant kAssertByteAck "␊ |
275 | ␉"h# 10 constant kNegateByteAck "␊ |
276 | ␉"h# 30 constant kTIPByteAckNeg "␊ |
277 | ␉"h# 08 constant kTREQBit "␊ |
278 | ␉": setByteAck "␊ |
279 | ␉"vPortB rb@ swap if "␊ |
280 | ␉"kAssertByteAck and "␊ |
281 | ␉"else "␊ |
282 | ␉"kNegateByteAck or "␊ |
283 | ␉"then "␊ |
284 | ␉"vPortB rb! "␊ |
285 | ␉"; "␊ |
286 | ␉": ToggleByteAck "␊ |
287 | ␉"vPortB rb@ kByteAckBit and setByteAck "␊ |
288 | ␉"; "␊ |
289 | ␉": setTIP "␊ |
290 | ␉"vPortB rb@ swap if "␊ |
291 | ␉"kAssertTIP and "␊ |
292 | ␉"else "␊ |
293 | ␉"kTIPByteAckNeg or "␊ |
294 | ␉"then "␊ |
295 | ␉"vPortB rb! "␊ |
296 | ␉"; "␊ |
297 | ␉": ?TREQ␉vPortB rb@ kTREQbit and 0= ; "␊ |
298 | ␉": WaitTREQ "␊ |
299 | ␉"begin "␊ |
300 | ␉"?TREQ until "␊ |
301 | ␉"; "␊ |
302 | ␉": WaitVIAInt "␊ |
303 | ␉"begin "␊ |
304 | ␉"vIFR rb@ kSRIReq and until "␊ |
305 | ␉"; "␊ |
306 | ␉": WaitATTN "␊ |
307 | ␉"WaitVIAInt "␊ |
308 | ␉"vSHR rb@ drop "␊ |
309 | ␉"; "␊ |
310 | ␉": get-response␉( -- ) "␊ |
311 | ␉"WaitATTN "␊ |
312 | ␉"true setTIP "␊ |
313 | ␉"begin "␊ |
314 | ␉"WaitATTN "␊ |
315 | ␉"?TREQ while "␊ |
316 | ␉"ToggleByteAck "␊ |
317 | ␉"repeat "␊ |
318 | ␉"false setTIP "␊ |
319 | ␉"false setByteAck "␊ |
320 | ␉"WaitATTN "␊ |
321 | ␉"; "␊ |
322 | ␉": start-send␉( c -- ) "␊ |
323 | ␉"kSRModeOut vACR rb! "␊ |
324 | ␉"( c ) vSHR rb! "␊ |
325 | ␉"true setTIP "␊ |
326 | ␉"; "␊ |
327 | ␉": cuda-write␉{ _adr _len ; _actual _data } "␊ |
328 | ␉"?TREQ if get-response then "␊ |
329 | ␉"_adr c@ start-send "␊ |
330 | ␉"begin "␊ |
331 | ␉"WaitVIAInt "␊ |
332 | ␉"?TREQ while "␊ |
333 | ␉"vSHR rb@ drop "␊ |
334 | ␉"false setTIP "␊ |
335 | ␉"get-response "␊ |
336 | ␉"_adr c@ start-send "␊ |
337 | ␉"repeat "␊ |
338 | ␉"1 -> _actual "␊ |
339 | ␉"_len 1 ?do "␊ |
340 | ␉"_adr i + c@ vSHR rb! "␊ |
341 | ␉"_actual 1+ -> _actual "␊ |
342 | ␉"ToggleByteAck "␊ |
343 | ␉"WaitVIAInt "␊ |
344 | ␉"loop "␊ |
345 | ␉"2 ms "␊ |
346 | ␉"kSRModeIn vACR rb! "␊ |
347 | ␉"vSHR rb@ drop "␊ |
348 | ␉"false setTIP "␊ |
349 | ␉"false setByteAck "␊ |
350 | ␉"_actual "␊ |
351 | ␉"; "␊ |
352 | ␉": cuda-read␉( _adr _len -- _actual ) "␊ |
353 | ␉"get-response "␊ |
354 | ␉"nip "␊ |
355 | ␉"; "␊ |
356 | ␉"8 buffer: athens-data␉\" \"(012250FFFF)\" athens-data swap move "␊ |
357 | ␉"8 buffer: athens-rsp "␊ |
358 | ␉": write-IIC␉( -- ) "␊ |
359 | ␉"athens-data 5 cuda-write drop "␊ |
360 | ␉"athens-rsp 3 cuda-read drop "␊ |
361 | ␉"; "␊ |
362 | ␉": init-ATHENS␉( P2Mux N2 D2 -- ) "␊ |
363 | ␉"4 1 do "␊ |
364 | ␉"i athens-data 3 + c! ( val ) athens-data 4 + c! "␊ |
365 | ␉"( athens-data 5 dump cr ) "␊ |
366 | ␉"write-IIC "␊ |
367 | ␉"loop "␊ |
368 | ␉"; "␊ |
369 | ␉": ping-CONTROL␉( enable-bit -- ) "␊ |
370 | ␉"5 ms "␊ |
371 | ␉"dup 8 or swap "␊ |
372 | ␉"dup regs >C.TEST rl! 5 ms "␊ |
373 | ␉"swap dup regs >C.TEST rl! 5 ms "␊ |
374 | ␉"swap dup regs >C.TEST rl! 5 ms "␊ |
375 | ␉"swap dup regs >C.TEST rl! 5 ms "␊ |
376 | ␉"2drop "␊ |
377 | ␉"; "␊ |
378 | ␉": reset-CONTROL "␊ |
379 | ␉"h# 433 ping-CONTROL "␊ |
380 | ␉"1 regs >C.GSC-DIVIDE rl! "␊ |
381 | ␉"; "␊ |
382 | ␉": enable-CONTROL "␊ |
383 | ␉"h# 033 ping-CONTROL "␊ |
384 | ␉"; "␊ |
385 | ␉": init-CONTROL␉( tbl-ptr -- ) "␊ |
386 | ␉"-1 to bankb? "␊ |
387 | ␉"phys-fb-address dup h# 1000 _I_G do-map "␊ |
388 | ␉"h# 31 regs >C.ENABLE rl! "␊ |
389 | ␉"h# 12345678 phys-fb-address rl! "␊ |
390 | ␉"regs >C.ENABLE rl@ drop "␊ |
391 | ␉"h# 12345678 phys-fb-address rl@ <> "␊ |
392 | ␉"phys-fb-address h# 1000 do-unmap "␊ |
393 | ␉"if "␊ |
394 | ␉"0 to bankb? "␊ |
395 | ␉"phys-fb-address h# 600000 or to phys-fb-address "␊ |
396 | ␉"then "␊ |
397 | ␉"dup @ ( dup .h ) lbsplit init-ATHENS init-RADACAL cell+ "␊ |
398 | ␉"d# 16 0 do "␊ |
399 | ␉"w@++ ( dup .d ) regs >C.VFPEQ i 4 << + ( dup .h cr ) rl! "␊ |
400 | ␉"loop "␊ |
401 | ␉"w@++␉regs >C.GSC-DIVIDE rl! "␊ |
402 | ␉"w@++ dup to width␉regs >C.ROW-WORDS rl! "␊ |
403 | ␉"w@ to height "␊ |
404 | ␉"h# 31 bankB? not 8 and or "␊ |
405 | ␉"little? 2 and or␉regs >C.ENABLE rl! "␊ |
406 | ␉"0␉␉regs >C.GBASE rl! "␊ |
407 | ␉"h# 01e4␉regs >C.REFRESH-COUNT rl! "␊ |
408 | ␉"0␉␉regs >C.INT-ENABLE rl! "␊ |
409 | ␉"; "␊ |
410 | ␉": my-open "␊ |
411 | ␉"\" assigned-addresses\" get-my-property "␊ |
412 | ␉"abort\" no REG property\"␉( prop-adr prop-len ) "␊ |
413 | ␉"begin "␊ |
414 | ␉"dup 0> while "␊ |
415 | ␉"decode-int h# FF and >r decode-int drop decode-int >r "␊ |
416 | ␉"8 - swap 8 + swap␉␉␉␉␉␉␉( prop-adr prop-len ) "␊ |
417 | ␉"r> r> case "␊ |
418 | ␉"h# 14 of "␊ |
419 | ␉"to phys-regs "␊ |
420 | ␉"endof "␊ |
421 | ␉"h# 18 of "␊ |
422 | ␉"h# 00800000 + to phys-fb-address "␊ |
423 | ␉"endof "␊ |
424 | ␉"swap drop "␊ |
425 | ␉"endcase "␊ |
426 | ␉"repeat "␊ |
427 | ␉"2drop "␊ |
428 | ␉"phys-regs 0 my-space h# 02000000 or h# 1000 \" map-in\" $call-parent to regs "␊ |
429 | ␉"reset-CONTROL "␊ |
430 | ␉"mon-sense "␊ |
431 | ␉"get-mode swap to mono-mode? "␊ |
432 | ␉"( mode-dependent-table-addr ) "␊ |
433 | ␉"dup 0= if "␊ |
434 | ␉"abort "␊ |
435 | ␉"then "␊ |
436 | ␉"( mode-dependent-table-addr ) "␊ |
437 | ␉"init-CONTROL "␊ |
438 | ␉"std-16 0 d# 16 set-colors "␊ |
439 | ␉"enable-CONTROL "␊ |
440 | ␉"phys-fb-address 0 my-space h# 02000000 or width height * \" map-in\" $call-parent to fb-address "␊ |
441 | ␉"fb-address width height * 7 fill "␊ |
442 | ␉"default-font set-font "␊ |
443 | ␉"width height over 20 - char-width / over 20 - char-height / fb8-install "␊ |
444 | ␉"width #columns char-width * - 2/ to window-left "␊ |
445 | ␉"height #lines char-height * - 2/ to window-top "␊ |
446 | ␉"fb-address to frame-buffer-adr "␊ |
447 | ␉"width encode-int \" width\" property "␊ |
448 | ␉"height encode-int \" height\" property "␊ |
449 | ␉"width encode-int \" linebytes\" property "␊ |
450 | ␉"8 encode-int \" depth\" property "␊ |
451 | ␉"; "␊ |
452 | ␉": my-close "␊ |
453 | ␉"fb-address height width * \" map-out\" $call-parent "␊ |
454 | ␉"regs h# 1000 \" map-out\" $call-parent "␊ |
455 | ␉"; "␊ |
456 | ␉"EXTERNAL "␊ |
457 | ␉": DIMENSIONS "␊ |
458 | ␉"width height "␊ |
459 | ␉"; "␊ |
460 | ␉": SET-COLORS␉( adr index #indices ) "␊ |
461 | ␉"swap RAD-REG-ADDR! "␊ |
462 | ␉"( #indices ) 0 ?do␉␉␉␉( adr ) "␊ |
463 | ␉"mono-mode? if "␊ |
464 | ␉"c+ h# 4d * >r␉␉␉␉( red adr ) "␊ |
465 | ␉"c+ h# 97 * >r␉␉␉␉( red green adr ) "␊ |
466 | ␉"c+ h# 1c * ␉␉␉␉␉( red green blue adr ) "␊ |
467 | ␉"r> + r> + 8 >>␉␉␉␉( luminance ) "␊ |
468 | ␉"do-gamma "␊ |
469 | ␉"dup "␊ |
470 | ␉"dup "␊ |
471 | ␉"CLUT! "␊ |
472 | ␉"( adr ) "␊ |
473 | ␉"else "␊ |
474 | ␉"c+ do-gamma swap␉␉␉( R adr ) "␊ |
475 | ␉"c+ do-gamma swap␉␉␉( R G adr ) "␊ |
476 | ␉"c+ do-gamma swap ␉␉␉( R G B adr ) "␊ |
477 | ␉">r swap rot CLUT! r>␉␉( B G R ) "␊ |
478 | ␉"then "␊ |
479 | ␉"loop␉␉␉␉␉␉( adr ) "␊ |
480 | ␉"drop "␊ |
481 | ␉"; "␊ |
482 | ␉": GET-COLORS␉( adr index #indices -- ) "␊ |
483 | ␉"swap ( index ) RAD-REG-ADDR! ( #indices ) 0 ?do "␊ |
484 | ␉"CLUT@ anti-gamma >r anti-gamma >r anti-gamma␉␉( R ) "␊ |
485 | ␉"c!+ r> c!+ r> c!+ "␊ |
486 | ␉"loop "␊ |
487 | ␉"drop "␊ |
488 | ␉"; "␊ |
489 | ␉": COLOR!␉␉( r g b index -- ) "␊ |
490 | ␉">r RGB-temp 2+ c! RGB-temp 1+ c! RGB-temp c! "␊ |
491 | ␉"RGB-temp r> 1 set-colors "␊ |
492 | ␉"; "␊ |
493 | ␉": COLOR@␉␉( index -- r g b ) "␊ |
494 | ␉"RGB-temp swap 1 get-colors "␊ |
495 | ␉"RGB-temp c+ swap c+ swap c@ "␊ |
496 | ␉"; "␊ |
497 | ␉": rect-setup␉( adr|index x y w h -- w adr|index xy-adr h ) "␊ |
498 | ␉">r >r width * + fb-address + r> -rot r> "␊ |
499 | ␉"; "␊ |
500 | ␉": DRAW-RECTANGLE␉( adr x y w h -- ) "␊ |
501 | ␉"rect-setup "␊ |
502 | ␉"( h ) 0 ?do␉␉␉␉␉␉␉␉( w adr xy-adr ) "␊ |
503 | ␉"2dup 4 pick move "␊ |
504 | ␉"2 pick width d+ "␊ |
505 | ␉"loop "␊ |
506 | ␉"3drop "␊ |
507 | ␉"; "␊ |
508 | ␉": FILL-RECTANGLE␉( index x y w h -- ) "␊ |
509 | ␉"rect-setup ␉␉␉␉␉␉␉␉( w index xy-adr h ) "␊ |
510 | ␉"( h ) 0 ?do␉␉␉␉␉␉␉␉( w index xy-adr ) "␊ |
511 | ␉"dup 3 pick 3 pick fill "␊ |
512 | ␉"width + "␊ |
513 | ␉"loop "␊ |
514 | ␉"3drop "␊ |
515 | ␉"; "␊ |
516 | ␉": READ-RECTANGLE␉( adr x y w h -- ) "␊ |
517 | ␉"rect-setup >r swap r>␉␉␉␉␉( w xy-adr adr h ) "␊ |
518 | ␉"( h ) 0 ?do "␊ |
519 | ␉"2dup 4 pick move "␊ |
520 | ␉"width 3 pick d+ "␊ |
521 | ␉"loop "␊ |
522 | ␉"3drop "␊ |
523 | ␉"; "␊ |
524 | ␉"['] my-open is-install "␊ |
525 | ␉"['] my-close is-remove "␊ |
526 | ,␊ |
527 | " device-end",0};␊ |
528 |