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