1 /* -*-C-*-
2
3 Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
4 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
5 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014 Massachusetts
6 Institute of Technology
7
8 This file is part of MIT/GNU Scheme.
9
10 MIT/GNU Scheme is free software; you can redistribute it and/or modify
11 it under the terms of the GNU General Public License as published by
12 the Free Software Foundation; either version 2 of the License, or (at
13 your option) any later version.
14
15 MIT/GNU Scheme is distributed in the hope that it will be useful, but
16 WITHOUT ANY WARRANTY; without even the implied warranty of
17 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
18 General Public License for more details.
19
20 You should have received a copy of the GNU General Public License
21 along with MIT/GNU Scheme; if not, write to the Free Software
22 Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
23 USA.
24
25 */
26
27 /* Primitives for dealing with colors and color maps */
28
29 #include "scheme.h"
30 #include "prims.h"
31 #include "x11.h"
32
33 DEFINE_PRIMITIVE ("X-GET-WINDOW-ATTRIBUTES", Prim_x_get_window_attributes, 1, 1, 0)
34 {
35 PRIMITIVE_HEADER(1);
36 {
37 struct xwindow * xw = (x_window_arg (1));
38 XWindowAttributes a;
39 if (! (XGetWindowAttributes ((XW_DISPLAY (xw)), (XW_WINDOW (xw)), (&a))))
40 error_external_return ();
41 {
42 SCHEME_OBJECT result = (allocate_marked_vector (TC_VECTOR, 23, true));
43 VECTOR_SET (result, 0, (long_to_integer (a . x)));
44 VECTOR_SET (result, 1, (long_to_integer (a . y)));
45 VECTOR_SET (result, 2, (long_to_integer (a . width)));
46 VECTOR_SET (result, 3, (long_to_integer (a . height)));
47 VECTOR_SET (result, 4, (long_to_integer (a . border_width)));
48 VECTOR_SET (result, 5, (long_to_integer (a . depth)));
49 VECTOR_SET (result, 6, (X_VISUAL_TO_OBJECT (a . visual)));
50 VECTOR_SET (result, 7, (long_to_integer (a . root)));
51 VECTOR_SET (result, 8, (long_to_integer (a . class)));
52 VECTOR_SET (result, 9, (long_to_integer (a . bit_gravity)));
53 VECTOR_SET (result, 10, (long_to_integer (a . win_gravity)));
54 VECTOR_SET (result, 11, (long_to_integer (a . backing_store)));
55 VECTOR_SET (result, 12, (long_to_integer (a . backing_planes)));
56 VECTOR_SET (result, 13, (long_to_integer (a . backing_pixel)));
57 VECTOR_SET (result, 14, (BOOLEAN_TO_OBJECT (a . save_under)));
58 VECTOR_SET (result, 15,
59 (X_COLORMAP_TO_OBJECT ((a . colormap), (XW_XD (xw)))));
60 VECTOR_SET (result, 16, (BOOLEAN_TO_OBJECT (a . map_installed)));
61 VECTOR_SET (result, 17, (long_to_integer (a . map_state)));
62 VECTOR_SET (result, 18, (long_to_integer (a . all_event_masks)));
63 VECTOR_SET (result, 19, (long_to_integer (a . your_event_mask)));
64 VECTOR_SET (result, 20, (long_to_integer (a . do_not_propagate_mask)));
65 VECTOR_SET (result, 21, (BOOLEAN_TO_OBJECT (a . override_redirect)));
66 VECTOR_SET (result, 22,
67 (long_to_integer (XScreenNumberOfScreen (a . screen))));
68 PRIMITIVE_RETURN (result);
69 }
70 }
71 }
72
73 /* Visuals */
74
75 DEFINE_PRIMITIVE ("X-GET-DEFAULT-VISUAL", Prim_x_get_default_visual, 2, 2, 0)
76 {
77 PRIMITIVE_HEADER (2);
78 PRIMITIVE_RETURN
79 (X_VISUAL_TO_OBJECT
80 (XDefaultVisual ((XD_DISPLAY (x_display_arg (1))), (arg_integer (2)))));
81 }
82
83 DEFINE_PRIMITIVE ("X-WINDOW-VISUAL", Prim_x_window_visual, 1, 1, 0)
84 {
85 PRIMITIVE_HEADER (1);
86 {
87 struct xwindow * xw = (x_window_arg (1));
88 XWindowAttributes a;
89 if (! (XGetWindowAttributes ((XW_DISPLAY (xw)), (XW_WINDOW (xw)), (&a))))
90 error_external_return ();
91 PRIMITIVE_RETURN (X_VISUAL_TO_OBJECT (a . visual));
92 }
93 }
94
95 DEFINE_PRIMITIVE ("X-VISUAL-DEALLOCATE", Prim_x_visual_deallocate, 1, 1, 0)
96 {
97 PRIMITIVE_HEADER (1);
98 deallocate_x_visual (x_visual_arg (1));
99 PRIMITIVE_RETURN (UNSPECIFIC);
100 }
101
102 DEFINE_PRIMITIVE("X-GET-VISUAL-INFO", Prim_x_get_visual_info, 10, 10, 0)
103 /* Inputs: Scheme window or display
104 (the remaining are either #F or a valid value)
105 Visual-ID
106 Screen number (or #F is window supplied)
107 Depth
108 Class
109 Red-mask (integer)
110 Green-mask (integer)
111 Blue-mask (integer)
112 Colormap size
113 Bits per RGB
114
115 Returns a vector of vectors, each of which has the following format:
116 Visual (Scheme format, for use in later calls)
117 Visual-ID
118 Screen number
119 Depth
120 Class
121 Red-mask (integer)
122 Green-mask (integer)
123 Blue-mask (integer)
124 Colormap size
125 Bits per RGB
126 */
127 #define LOAD_IF(argno, type, field, mask_bit) \
128 if (ARG_REF(argno) != SHARP_F) \
129 { VI.field = type arg_integer(argno); \
130 VIMask |= mask_bit; \
131 }
132 { PRIMITIVE_HEADER (10);
133 { Display *dpy;
134 long ScreenNumber;
135 XVisualInfo VI, *VIList, *ThisVI;
136 long VIMask = VisualNoMask;
137 long AnswerSize, i;
138 int AnswerCount;
139 SCHEME_OBJECT Result, This_Vector;
140
141 if (ARG_REF(3) == SHARP_F)
142 { struct xwindow * xw = x_window_arg (1);
143 XWindowAttributes attrs;
144
145 dpy = XW_DISPLAY(xw);
146 XGetWindowAttributes(dpy, XW_WINDOW(xw), &attrs);
147 ScreenNumber = XScreenNumberOfScreen(attrs.screen);
148 }
149 else
150 { struct xdisplay * xd = x_display_arg (1);
151 ScreenNumber = arg_integer(3);
152 dpy = XD_DISPLAY(xd);
153 }
154 VI.screen = ScreenNumber;
155 LOAD_IF(2, (VisualID), visualid, VisualIDMask);
156 LOAD_IF(4, (unsigned int), depth, VisualDepthMask);
157 LOAD_IF(5, (int), class, VisualClassMask);
158 LOAD_IF(6, (unsigned long), red_mask, VisualRedMaskMask);
159 LOAD_IF(7, (unsigned long), green_mask, VisualGreenMaskMask);
160 LOAD_IF(8, (unsigned long), blue_mask, VisualBlueMaskMask);
161 LOAD_IF(9, (int), colormap_size, VisualColormapSizeMask);
162 LOAD_IF(10, (int), bits_per_rgb, VisualBitsPerRGBMask);
163 VIList = XGetVisualInfo(dpy, VIMask, &VI, &AnswerCount);
164 AnswerSize = (AnswerCount + 1) + (11 * AnswerCount);
165 if (GC_NEEDED_P (AnswerSize))
166 { XFree((void *) VIList);
167 Primitive_GC (AnswerSize);
168 }
169 Result = allocate_marked_vector (TC_VECTOR, AnswerCount, false);
170 for (i=0, ThisVI=VIList; i < AnswerCount; i++, ThisVI++)
171 { This_Vector = allocate_marked_vector(TC_VECTOR, 10, false);
172 VECTOR_SET(This_Vector, 0, (X_VISUAL_TO_OBJECT (ThisVI->visual)));
173 VECTOR_SET(This_Vector, 1, long_to_integer((long) ThisVI->visualid));
174 VECTOR_SET(This_Vector, 2, long_to_integer(ThisVI->screen));
175 VECTOR_SET(This_Vector, 3, long_to_integer(ThisVI->depth));
176 VECTOR_SET(This_Vector, 4, long_to_integer(ThisVI->class));
177 VECTOR_SET(This_Vector, 5, long_to_integer(ThisVI->red_mask));
178 VECTOR_SET(This_Vector, 6, long_to_integer(ThisVI->green_mask));
179 VECTOR_SET(This_Vector, 7, long_to_integer(ThisVI->blue_mask));
180 VECTOR_SET(This_Vector, 8, long_to_integer(ThisVI->colormap_size));
181 VECTOR_SET(This_Vector, 9, long_to_integer(ThisVI->bits_per_rgb));
182 VECTOR_SET(Result, i, This_Vector);
183 }
184 XFree((void *) VIList);
185 PRIMITIVE_RETURN(Result);
186 }
187 }
188
189 /* Colormaps */
190
191 DEFINE_PRIMITIVE ("X-GET-DEFAULT-COLORMAP", Prim_x_get_default_colormap, 2, 2,
192 "Given DISPLAY and SCREEN-NUMBER, return default colormap for screen.")
193 {
194 PRIMITIVE_HEADER (2);
195 {
196 struct xdisplay * xd = (x_display_arg (1));
197 PRIMITIVE_RETURN
198 (X_COLORMAP_TO_OBJECT
199 ((XDefaultColormap ((XD_DISPLAY (xd)), (arg_integer (2)))), xd));
200 }
201 }
202
203 DEFINE_PRIMITIVE ("X-WINDOW-COLORMAP", Prim_x_window_colormap, 1, 1,
204 "Return WINDOW's colormap.")
205 {
206 PRIMITIVE_HEADER (1);
207 {
208 struct xwindow * xw = (x_window_arg (1));
209 XWindowAttributes a;
210 if (! (XGetWindowAttributes ((XW_DISPLAY (xw)), (XW_WINDOW (xw)), (&a))))
211 error_external_return ();
212 PRIMITIVE_RETURN (X_COLORMAP_TO_OBJECT ((a . colormap), (XW_XD (xw))));
213 }
214 }
215
216 DEFINE_PRIMITIVE ("X-SET-WINDOW-COLORMAP", Prim_x_set_window_colormap, 2, 2,
217 "Set WINDOW's colormap to COLORMAP.")
218 {
219 PRIMITIVE_HEADER (2);
220 {
221 struct xwindow * xw = (x_window_arg (1));
222 XSetWindowColormap ((XW_DISPLAY (xw)), (XW_WINDOW (xw)),
223 (XCM_COLORMAP (x_colormap_arg (2))));
224 }
225 PRIMITIVE_RETURN (UNSPECIFIC);
226 }
227
228 DEFINE_PRIMITIVE ("X-CREATE-COLORMAP", Prim_x_create_colormap, 3, 3,
229 "Given WINDOW, and VISUAL, create and return a colormap.\n\
230 If third arg WRITEABLE is true, returned colormap may be modified.")
231 {
232 PRIMITIVE_HEADER (3);
233 {
234 struct xwindow * xw = (x_window_arg (1));
235 PRIMITIVE_RETURN
236 (X_COLORMAP_TO_OBJECT
237 ((XCreateColormap ((XW_DISPLAY (xw)), (XW_WINDOW (xw)),
238 (XV_VISUAL (x_visual_arg (2))), (BOOLEAN_ARG (3)))),
239 (XW_XD (xw))));
240 }
241 }
242
243 DEFINE_PRIMITIVE ("X-COPY-COLORMAP-AND-FREE", Prim_x_copy_colormap_and_free, 1, 1,
244 "Return a new copy of COLORMAP.")
245 {
246 PRIMITIVE_HEADER (1);
247 {
248 struct xcolormap * xcm = (x_colormap_arg (1));
249 PRIMITIVE_RETURN
250 (X_COLORMAP_TO_OBJECT
251 ((XCopyColormapAndFree ((XCM_DISPLAY (xcm)), (XCM_COLORMAP (xcm)))),
252 (XCM_XD (xcm))));
253 }
254 }
255
256 DEFINE_PRIMITIVE ("X-FREE-COLORMAP", Prim_x_free_colormap, 1, 1,
257 "Deallocate COLORMAP.")
258 {
259 PRIMITIVE_HEADER (1);
260 {
261 struct xcolormap * xcm = (x_colormap_arg (1));
262 XFreeColormap ((XCM_DISPLAY (xcm)), (XCM_COLORMAP (xcm)));
263 deallocate_x_colormap (xcm);
264 }
265 PRIMITIVE_RETURN (UNSPECIFIC);
266 }
267
268 #define ARG_RGB_VALUE(argno) (arg_index_integer ((argno), 65536))
269
270 DEFINE_PRIMITIVE ("X-ALLOCATE-COLOR", Prim_x_allocate_color, 4, 4, 0)
271 {
272 /* Input: colormap, red, green, blue
273 Returns: pixel, or #F if unable to allocate color cell. */
274 PRIMITIVE_HEADER (4);
275 {
276 struct xcolormap * xcm = (x_colormap_arg (1));
277 XColor c;
278 (c . red) = (ARG_RGB_VALUE (2));
279 (c . green) = (ARG_RGB_VALUE (3));
280 (c . blue) = (ARG_RGB_VALUE (4));
281 PRIMITIVE_RETURN
282 ((XAllocColor ((XCM_DISPLAY (xcm)), (XCM_COLORMAP (xcm)), (&c)))
283 ? (long_to_integer (c . pixel))
284 : SHARP_F);
285 }
286 }
287
288 DEFINE_PRIMITIVE ("X-STORE-COLOR", Prim_x_store_color, 5, 5,
289 "Input: colormap, pixel, r, g, b (r/g/b may be #f).")
290 {
291 PRIMITIVE_HEADER (5);
292 {
293 struct xcolormap * xcm = (x_colormap_arg (1));
294 XColor c;
295 (c . pixel) = (arg_nonnegative_integer (2));
296 (c . flags) = 0;
297 if ((ARG_REF (3)) != SHARP_F)
298 {
299 (c . red) = (arg_index_integer (3, 65536));
300 (c . flags) |= DoRed;
301 }
302 if ((ARG_REF (4)) != SHARP_F)
303 {
304 (c . green) = (arg_index_integer (4, 65536));
305 (c . flags) |= DoGreen;
306 }
307 if ((ARG_REF (5)) != SHARP_F)
308 {
309 (c . blue) = (arg_index_integer (5, 65536));
310 (c . flags) |= DoBlue;
311 }
312 XStoreColor ((XCM_DISPLAY (xcm)), (XCM_COLORMAP (xcm)), (&c));
313 }
314 PRIMITIVE_RETURN (UNSPECIFIC);
315 }
316
317 #define CONVERT_COLOR_OBJECT(index, color, flag) \
318 { \
319 SCHEME_OBJECT object = (VECTOR_REF (color_object, (index))); \
320 if (object != SHARP_F) \
321 { \
322 if (! ((INTEGER_P (object)) && (integer_to_long_p (object)))) \
323 goto losing_color_object; \
324 { \
325 long value = (integer_to_long (object)); \
326 if ((value < 0) || (value > 65535)) \
327 goto losing_color_object; \
328 (colors_scan -> color) = value; \
329 (colors_scan -> flags) |= (flag); \
330 } \
331 } \
332 }
333
334 DEFINE_PRIMITIVE ("X-STORE-COLORS", Prim_x_store_colors, 2, 2,
335 "Input: colormap, vector of vectors, each of\n\
336 which contains pixel, r, g, b (where r/g/b can be #f or integer).")
337 {
338 PRIMITIVE_HEADER (2);
339 {
340 struct xcolormap * xcm = (x_colormap_arg (1));
341 SCHEME_OBJECT color_vector = (VECTOR_ARG (2));
342 unsigned long n_colors = (VECTOR_LENGTH (color_vector));
343 XColor * colors = (dstack_alloc ((sizeof (XColor)) * n_colors));
344 {
345 SCHEME_OBJECT * vector_scan = (VECTOR_LOC (color_vector, 0));
346 SCHEME_OBJECT * vector_end = (vector_scan + n_colors);
347 XColor * colors_scan = colors;
348 while (vector_scan < vector_end)
349 {
350 SCHEME_OBJECT color_object = (*vector_scan++);
351 if (! ((VECTOR_P (color_object))
352 && ((VECTOR_LENGTH (color_object)) == 4)))
353 {
354 losing_color_object:
355 error_wrong_type_arg (3);
356 }
357 {
358 SCHEME_OBJECT pixel_object = (VECTOR_REF (color_object, 0));
359 if (! ((INTEGER_P (pixel_object))
360 && (integer_to_long_p (pixel_object))))
361 goto losing_color_object;
362 (colors_scan -> pixel) = (integer_to_long (pixel_object));
363 }
364 (colors_scan -> flags) = 0;
365 CONVERT_COLOR_OBJECT (1, red, DoRed);
366 CONVERT_COLOR_OBJECT (2, green, DoGreen);
367 CONVERT_COLOR_OBJECT (3, blue, DoBlue);
368 colors_scan += 1;
369 }
370 }
371 XStoreColors ((XCM_DISPLAY (xcm)), (XCM_COLORMAP (xcm)), colors, n_colors);
372 }
373 PRIMITIVE_RETURN (UNSPECIFIC);
374 }
375
376 DEFINE_PRIMITIVE ("X-FREE-COLORS", Prim_x_free_colors, 1, -1, 0)
377 {
378 /* Input: colormap, pixel ... */
379 PRIMITIVE_HEADER (LEXPR);
380 if (GET_LEXPR_ACTUALS < 1)
381 signal_error_from_primitive (ERR_WRONG_NUMBER_OF_ARGUMENTS);
382 {
383 struct xcolormap * xcm = (x_colormap_arg (1));
384 unsigned int n_pixels = (GET_LEXPR_ACTUALS - 1);
385 unsigned long * pixels =
386 (dstack_alloc ((sizeof (unsigned long)) * n_pixels));
387 unsigned int i;
388 for (i = 0; (i < n_pixels); i += 1)
389 (pixels[i]) = (arg_integer (i + 2));
390 XFreeColors ((XCM_DISPLAY (xcm)), (XCM_COLORMAP (xcm)),
391 pixels, n_pixels, 0);
392 }
393 PRIMITIVE_RETURN(UNSPECIFIC);
394 }
395
396 DEFINE_PRIMITIVE ("X-QUERY-COLOR", Prim_x_query_color, 2, 2, 0)
397 {
398 /* Input: colormap, pixel
399 Output: vector of red, green, blue */
400 PRIMITIVE_HEADER (2);
401 {
402 struct xcolormap * xcm = (x_colormap_arg (1));
403 SCHEME_OBJECT result = (allocate_marked_vector (TC_VECTOR, 3, true));
404 XColor c;
405 c . pixel = (arg_integer (2));
406 XQueryColor ((XCM_DISPLAY (xcm)), (XCM_COLORMAP (xcm)), (&c));
407 VECTOR_SET (result, 0, (long_to_integer (c . red)));
408 VECTOR_SET (result, 1, (long_to_integer (c . green)));
409 VECTOR_SET (result, 2, (long_to_integer (c . blue)));
410 PRIMITIVE_RETURN (result);
411 }
412 }
413
414 DEFINE_PRIMITIVE ("X-QUERY-COLORS", Prim_x_query_colors, 1, -1, 0)
415 {
416 /* Input: colormap, pixel ...
417 Output: a vector of vectors, each with #(red, green, blue) */
418 PRIMITIVE_HEADER (LEXPR);
419 if (GET_LEXPR_ACTUALS < 1)
420 signal_error_from_primitive (ERR_WRONG_NUMBER_OF_ARGUMENTS);
421 {
422 struct xcolormap * xcm = (x_colormap_arg (1));
423 unsigned int n_colors = (GET_LEXPR_ACTUALS - 1);
424 XColor * colors = (dstack_alloc ((sizeof (XColor)) * n_colors));
425 unsigned int i;
426 for (i = 0; (i < n_colors); i += 1)
427 ((colors[i]) . pixel) = (arg_integer (i + 2));
428 XQueryColors ((XCM_DISPLAY (xcm)), (XCM_COLORMAP (xcm)), colors, n_colors);
429 {
430 SCHEME_OBJECT result =
431 (allocate_marked_vector (TC_VECTOR, n_colors, true));
432 for (i = 0; (i < n_colors); i += 1)
433 {
434 SCHEME_OBJECT cv = (allocate_marked_vector (TC_VECTOR, 3, true));
435 VECTOR_SET (cv, 0, (long_to_integer ((colors[i]) . red)));
436 VECTOR_SET (cv, 1, (long_to_integer ((colors[i]) . green)));
437 VECTOR_SET (cv, 2, (long_to_integer ((colors[i]) . blue)));
438 VECTOR_SET (result, i, cv);
439 }
440 PRIMITIVE_RETURN (result);
441 }
442 }
443 }
444
445 /* Named colors */
446
447 DEFINE_PRIMITIVE ("X-PARSE-COLOR", Prim_x_parse_color, 2, 2, 0)
448 { /* Input: colormap, string
449 Output: vector of pixel, red, green, blue
450 */
451 PRIMITIVE_HEADER (2);
452 {
453 struct xcolormap * xcm = (x_colormap_arg (1));
454 XColor TheColor;
455 if (! (XParseColor ((XCM_DISPLAY (xcm)), (XCM_COLORMAP (xcm)),
456 (STRING_ARG (2)), (&TheColor))))
457 PRIMITIVE_RETURN (SHARP_F);
458 {
459 SCHEME_OBJECT result = (allocate_marked_vector (TC_VECTOR, 4, true));
460 VECTOR_SET(result, 0, long_to_integer(TheColor.pixel));
461 VECTOR_SET(result, 1, long_to_integer(TheColor.red));
462 VECTOR_SET(result, 2, long_to_integer(TheColor.green));
463 VECTOR_SET(result, 3, long_to_integer(TheColor.blue));
464 PRIMITIVE_RETURN (result);
465 }
466 }
467 }
468
469 DEFINE_PRIMITIVE ("X-ALLOCATE-NAMED-COLOR", Prim_x_allocate_named_color, 2, 2, 0)
470 { /* Input: colormap, name
471 Returns: vector of closest pixel, red, green, blue
472 exact pixel, red, green, blue
473 */
474
475 SCHEME_OBJECT Result;
476 XColor Exact, Closest;
477 struct xcolormap * xcm;
478 PRIMITIVE_HEADER (2);
479
480 xcm = (x_colormap_arg (1));
481 XAllocNamedColor
482 ((XCM_DISPLAY (xcm)), (XCM_COLORMAP (xcm)),
483 (STRING_ARG (2)), &Exact, &Closest);
484 Result = allocate_marked_vector(TC_VECTOR, 8, true);
485 VECTOR_SET(Result, 0, long_to_integer(Closest.pixel));
486 VECTOR_SET(Result, 1, long_to_integer(Closest.red));
487 VECTOR_SET(Result, 2, long_to_integer(Closest.green));
488 VECTOR_SET(Result, 3, long_to_integer(Closest.blue));
489 VECTOR_SET(Result, 4, long_to_integer(Exact.pixel));
490 VECTOR_SET(Result, 5, long_to_integer(Exact.red));
491 VECTOR_SET(Result, 6, long_to_integer(Exact.green));
492 VECTOR_SET(Result, 7, long_to_integer(Exact.blue));
493 PRIMITIVE_RETURN(Result);
494 }
495
496 DEFINE_PRIMITIVE("X-STORE-NAMED-COLOR", Prim_x_store_named_color, 6, 6, 0)
497 {
498 /* Input: colormap, color name, pixel, DoRed, DoGreen, DoBlue */
499 PRIMITIVE_HEADER(6);
500 {
501 struct xcolormap * xcm = (x_colormap_arg (1));
502 XStoreNamedColor ((XCM_DISPLAY (xcm)), (XCM_COLORMAP (xcm)),
503 (STRING_ARG (2)), (arg_integer (4)),
504 (((BOOLEAN_ARG (4)) ? DoRed : 0)
505 | ((BOOLEAN_ARG (5)) ? DoGreen : 0)
506 | ((BOOLEAN_ARG (6)) ? DoBlue : 0)));
507 }
508 PRIMITIVE_RETURN(UNSPECIFIC);
509 }
510
511 DEFINE_PRIMITIVE("X-LOOKUP-COLOR", Prim_x_lookup_color, 2, 2, 0)
512 {
513 /* Input: colormap, name
514 Returns: vector of closest pixel, red, green, blue
515 exact pixel, red, green, blue
516 */
517
518 SCHEME_OBJECT Result;
519 XColor Exact, Closest;
520 struct xcolormap * xcm;
521 PRIMITIVE_HEADER (2);
522
523 xcm = (x_colormap_arg (1));
524 if (! (XAllocNamedColor
525 ((XCM_DISPLAY (xcm)), (XCM_COLORMAP (xcm)),
526 (STRING_ARG (2)), &Exact, &Closest)))
527 PRIMITIVE_RETURN (SHARP_F);
528 Result = allocate_marked_vector(TC_VECTOR, 8, true);
529 VECTOR_SET(Result, 0, long_to_integer(Closest.pixel));
530 VECTOR_SET(Result, 1, long_to_integer(Closest.red));
531 VECTOR_SET(Result, 2, long_to_integer(Closest.green));
532 VECTOR_SET(Result, 3, long_to_integer(Closest.blue));
533 VECTOR_SET(Result, 4, long_to_integer(Exact.pixel));
534 VECTOR_SET(Result, 5, long_to_integer(Exact.red));
535 VECTOR_SET(Result, 6, long_to_integer(Exact.green));
536 VECTOR_SET(Result, 7, long_to_integer(Exact.blue));
537 PRIMITIVE_RETURN(Result);
538 }
539
540 #ifdef COMPILE_AS_MODULE
541
542 /* sed -n -e 's/^DEFINE_PRIMITIVE *(\([^)]*\))$/ declare_primitive (\1);/pg' \
543 -e 's/^DEFINE_PRIMITIVE *(\([^)]*\)$/ declare_primitive (\1 0);/pg' */
544
545 void
dload_initialize_x11color(void)546 dload_initialize_x11color (void)
547 {
548 declare_primitive ("X-ALLOCATE-COLOR", Prim_x_allocate_color, 4, 4, 0);
549 declare_primitive ("X-ALLOCATE-NAMED-COLOR", Prim_x_allocate_named_color, 2, 2, 0);
550 declare_primitive ("X-COPY-COLORMAP-AND-FREE", Prim_x_copy_colormap_and_free, 1, 1, 0);
551 declare_primitive ("X-CREATE-COLORMAP", Prim_x_create_colormap, 3, 3, 0);
552 declare_primitive ("X-FREE-COLORMAP", Prim_x_free_colormap, 1, 1, 0);
553 declare_primitive ("X-FREE-COLORS", Prim_x_free_colors, 1, -1, 0);
554 declare_primitive ("X-GET-DEFAULT-COLORMAP", Prim_x_get_default_colormap, 2, 2, 0);
555 declare_primitive ("X-GET-DEFAULT-VISUAL", Prim_x_get_default_visual, 2, 2, 0);
556 declare_primitive ("X-GET-VISUAL-INFO", Prim_x_get_visual_info, 10, 10, 0);
557 declare_primitive ("X-GET-WINDOW-ATTRIBUTES", Prim_x_get_window_attributes, 1, 1, 0);
558 declare_primitive ("X-LOOKUP-COLOR", Prim_x_lookup_color, 2, 2, 0);
559 declare_primitive ("X-PARSE-COLOR", Prim_x_parse_color, 2, 2, 0);
560 declare_primitive ("X-QUERY-COLOR", Prim_x_query_color, 2, 2, 0);
561 declare_primitive ("X-QUERY-COLORS", Prim_x_query_colors, 1, -1, 0);
562 declare_primitive ("X-SET-WINDOW-COLORMAP", Prim_x_set_window_colormap, 2, 2, 0);
563 declare_primitive ("X-STORE-COLOR", Prim_x_store_color, 5, 5, 0);
564 declare_primitive ("X-STORE-COLORS", Prim_x_store_colors, 2, 2, 0);
565 declare_primitive ("X-STORE-NAMED-COLOR", Prim_x_store_named_color, 6, 6, 0);
566 declare_primitive ("X-VISUAL-DEALLOCATE", Prim_x_visual_deallocate, 1, 1, 0);
567 declare_primitive ("X-WINDOW-COLORMAP", Prim_x_window_colormap, 1, 1, 0);
568 declare_primitive ("X-WINDOW-VISUAL", Prim_x_window_visual, 1, 1, 0);
569 }
570
571 #endif /* defined (COMPILE_AS_MODULE) */
572