]>
Commit | Line | Data |
---|---|---|
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}; |