Chameleon

Chameleon Svn Source Tree

Root/branches/xZenu/src/arch/ppc/boot2/Control2.c

Source at commit 1317 created 12 years 8 months ago.
By meklort, Update ppc boot2 file. File now compiles.
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␊
30const 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

Archive Download this file

Revision: 1317