/* -*-C-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/x11color.c,v 1.2 1991/07/11 03:57:36 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/x11color.c,v 1.3 1991/07/23 08:16:51 cph Exp $
Copyright (c) 1991 Massachusetts Institute of Technology
#include "scheme.h"
#include "prims.h"
#include "x11.h"
-
-extern unsigned int allocate_x_visual ();
\f
-DEFINE_PRIMITIVE("X-GET-WINDOW-ATTRIBUTES", Prim_x_get_window_attributes, 1, 1, 0)
-{ PRIMITIVE_HEADER(1);
- { XWindowAttributes attrs;
- struct xwindow * xw = x_window_arg(1);
-
- if (XGetWindowAttributes(XW_DISPLAY(xw), XW_WINDOW(xw), &attrs) == 0)
- { PRIMITIVE_RETURN (SHARP_F);
- }
- else
- { SCHEME_OBJECT Result = allocate_marked_vector(TC_VECTOR, 23, true);
- VECTOR_SET(Result, 0, long_to_integer(attrs.x));
- VECTOR_SET(Result, 1, long_to_integer(attrs.y));
- VECTOR_SET(Result, 2, long_to_integer(attrs.width));
- VECTOR_SET(Result, 3, long_to_integer(attrs.height));
- VECTOR_SET(Result, 4, long_to_integer(attrs.border_width));
- VECTOR_SET(Result, 5, long_to_integer(attrs.depth));
- VECTOR_SET(Result, 6, XV_TO_OBJECT(allocate_x_visual(attrs.visual)));
- VECTOR_SET(Result, 7, long_to_integer(attrs.root));
- VECTOR_SET(Result, 8, long_to_integer(attrs.class));
- VECTOR_SET(Result, 9, long_to_integer(attrs.bit_gravity));
- VECTOR_SET(Result, 10, long_to_integer(attrs.win_gravity));
- VECTOR_SET(Result, 11, long_to_integer(attrs.backing_store));
- VECTOR_SET(Result, 12, long_to_integer(attrs.backing_planes));
- VECTOR_SET(Result, 13, long_to_integer(attrs.backing_pixel));
- VECTOR_SET(Result, 14, BOOLEAN_TO_OBJECT(attrs.save_under));
- VECTOR_SET(Result, 15, long_to_integer(attrs.colormap));
- VECTOR_SET(Result, 16, BOOLEAN_TO_OBJECT(attrs.map_installed));
- VECTOR_SET(Result, 17, long_to_integer(attrs.map_state));
- VECTOR_SET(Result, 18, long_to_integer(attrs.all_event_masks));
- VECTOR_SET(Result, 19, long_to_integer(attrs.your_event_mask));
- VECTOR_SET(Result, 20, long_to_integer(attrs.do_not_propagate_mask));
- VECTOR_SET(Result, 21, BOOLEAN_TO_OBJECT(attrs.override_redirect));
- VECTOR_SET(Result, 22,
- long_to_integer(XScreenNumberOfScreen(attrs.screen)));
- PRIMITIVE_RETURN(Result);
+DEFINE_PRIMITIVE ("X-GET-WINDOW-ATTRIBUTES", Prim_x_get_window_attributes, 1, 1, 0)
+{
+ PRIMITIVE_HEADER(1);
+ {
+ struct xwindow * xw = (x_window_arg (1));
+ XWindowAttributes a;
+ if (! (XGetWindowAttributes ((XW_DISPLAY (xw)), (XW_WINDOW (xw)), (&a))))
+ error_external_return ();
+ {
+ SCHEME_OBJECT result = (allocate_marked_vector (TC_VECTOR, 23, true));
+ VECTOR_SET (result, 0, (long_to_integer (a . x)));
+ VECTOR_SET (result, 1, (long_to_integer (a . y)));
+ VECTOR_SET (result, 2, (long_to_integer (a . width)));
+ VECTOR_SET (result, 3, (long_to_integer (a . height)));
+ VECTOR_SET (result, 4, (long_to_integer (a . border_width)));
+ VECTOR_SET (result, 5, (long_to_integer (a . depth)));
+ VECTOR_SET (result, 6, (X_VISUAL_TO_OBJECT (a . visual)));
+ VECTOR_SET (result, 7, (long_to_integer (a . root)));
+ VECTOR_SET (result, 8, (long_to_integer (a . class)));
+ VECTOR_SET (result, 9, (long_to_integer (a . bit_gravity)));
+ VECTOR_SET (result, 10, (long_to_integer (a . win_gravity)));
+ VECTOR_SET (result, 11, (long_to_integer (a . backing_store)));
+ VECTOR_SET (result, 12, (long_to_integer (a . backing_planes)));
+ VECTOR_SET (result, 13, (long_to_integer (a . backing_pixel)));
+ VECTOR_SET (result, 14, (BOOLEAN_TO_OBJECT (a . save_under)));
+ VECTOR_SET (result, 15,
+ (X_COLORMAP_TO_OBJECT ((a . colormap), (XW_XD (xw)))));
+ VECTOR_SET (result, 16, (BOOLEAN_TO_OBJECT (a . map_installed)));
+ VECTOR_SET (result, 17, (long_to_integer (a . map_state)));
+ VECTOR_SET (result, 18, (long_to_integer (a . all_event_masks)));
+ VECTOR_SET (result, 19, (long_to_integer (a . your_event_mask)));
+ VECTOR_SET (result, 20, (long_to_integer (a . do_not_propagate_mask)));
+ VECTOR_SET (result, 21, (BOOLEAN_TO_OBJECT (a . override_redirect)));
+ VECTOR_SET (result, 22,
+ (long_to_integer (XScreenNumberOfScreen (a . screen))));
+ PRIMITIVE_RETURN (result);
}
}
}
+\f
+/* Visuals */
-DEFINE_PRIMITIVE("X-GET-DEFAULT-VISUAL", Prim_x_get_default_visual, 2, 2, 0)
-/* Inputs: (Scheme window and #F) or (Scheme display and screen number)
- Returns: Scheme visual
-*/
-{ PRIMITIVE_HEADER(2);
- { Display *dpy;
- long ScreenNumber;
- Visual *answer;
+DEFINE_PRIMITIVE ("X-GET-DEFAULT-VISUAL", Prim_x_get_default_visual, 2, 2, 0)
+{
+ PRIMITIVE_HEADER (2);
+ PRIMITIVE_RETURN
+ (X_VISUAL_TO_OBJECT
+ (XDefaultVisual ((XD_DISPLAY (x_display_arg (1))), (arg_integer (2)))));
+}
- if (ARG_REF(2) == SHARP_F)
- { struct xwindow * xw = x_window_arg (1);
- XWindowAttributes attrs;
-
- dpy = XW_DISPLAY(xw);
- XGetWindowAttributes(dpy, XW_WINDOW(xw), &attrs);
- ScreenNumber = XScreenNumberOfScreen(attrs.screen);
- }
- else
- { struct xdisplay * xd = x_display_arg (1);
- ScreenNumber = arg_integer(2);
- dpy = XD_DISPLAY(xd);
- }
- answer = XDefaultVisual(dpy, ScreenNumber);
- PRIMITIVE_RETURN(XV_TO_OBJECT(allocate_x_visual(answer)));
+DEFINE_PRIMITIVE ("X-WINDOW-VISUAL", Prim_x_window_visual, 1, 1, 0)
+{
+ PRIMITIVE_HEADER (1);
+ {
+ struct xwindow * xw = (x_window_arg (1));
+ XWindowAttributes a;
+ if (! (XGetWindowAttributes ((XW_DISPLAY (xw)), (XW_WINDOW (xw)), (&a))))
+ error_external_return ();
+ PRIMITIVE_RETURN (X_VISUAL_TO_OBJECT (a . visual));
}
}
+
+DEFINE_PRIMITIVE ("X-VISUAL-DEALLOCATE", Prim_x_visual_deallocate, 1, 1, 0)
+{
+ PRIMITIVE_HEADER (1);
+ deallocate_x_visual (x_visual_arg (1));
+ PRIMITIVE_RETURN (UNSPECIFIC);
+}
\f
DEFINE_PRIMITIVE("X-GET-VISUAL-INFO", Prim_x_get_visual_info, 10, 10, 0)
/* Inputs: Scheme window or display
Result = allocate_marked_vector (TC_VECTOR, AnswerCount, false);
for (i=0, ThisVI=VIList; i < AnswerCount; i++, ThisVI++)
{ This_Vector = allocate_marked_vector(TC_VECTOR, 10, false);
- VECTOR_SET(This_Vector, 0, XV_TO_OBJECT(allocate_x_visual(ThisVI->visual)));
+ VECTOR_SET(This_Vector, 0, (X_VISUAL_TO_OBJECT (ThisVI->visual)));
VECTOR_SET(This_Vector, 1, long_to_integer((long) ThisVI->visualid));
VECTOR_SET(This_Vector, 2, long_to_integer(ThisVI->screen));
VECTOR_SET(This_Vector, 3, long_to_integer(ThisVI->depth));
}
}
\f
-DEFINE_PRIMITIVE("X-GET-DEFAULT-COLORMAP", Prim_x_get_default_colormap, 2, 2, 0)
-{ /* Input: (Scheme) display, screen number */
+/* Colormaps */
+
+DEFINE_PRIMITIVE ("X-GET-DEFAULT-COLORMAP", Prim_x_get_default_colormap, 2, 2,
+ "Given DISPLAY and SCREEN-NUMBER, return default colormap for screen.")
+{
PRIMITIVE_HEADER (2);
- PRIMITIVE_RETURN(
- long_to_integer(
- XDefaultColormap(XD_DISPLAY(x_display_arg(1)), arg_integer(2))));
+ {
+ struct xdisplay * xd = (x_display_arg (1));
+ PRIMITIVE_RETURN
+ (X_COLORMAP_TO_OBJECT
+ ((XDefaultColormap ((XD_DISPLAY (xd)), (arg_integer (2)))), xd));
+ }
}
-DEFINE_PRIMITIVE("X-PARSE-COLOR", Prim_x_parse_color, 3, 3, 0)
-{ /* Input: (Scheme) display, colormap, string
- Output: vector of pixel, red, green, blue
- */
- PRIMITIVE_HEADER (3);
- { XColor TheColor;
- if (XParseColor(XD_DISPLAY(x_display_arg(1)),
- arg_integer(2), STRING_ARG(3), &TheColor) == 0)
- { PRIMITIVE_RETURN(SHARP_F);
- }
- else
- { SCHEME_OBJECT Result;
-
- Result = allocate_marked_vector(TC_VECTOR, 4, true);
- VECTOR_SET(Result, 0, long_to_integer(TheColor.pixel));
- VECTOR_SET(Result, 1, long_to_integer(TheColor.red));
- VECTOR_SET(Result, 2, long_to_integer(TheColor.green));
- VECTOR_SET(Result, 3, long_to_integer(TheColor.blue));
- PRIMITIVE_RETURN(Result);
- }
+DEFINE_PRIMITIVE ("X-WINDOW-COLORMAP", Prim_x_window_colormap, 1, 1,
+ "Return WINDOW's colormap.")
+{
+ PRIMITIVE_HEADER (1);
+ {
+ struct xwindow * xw = (x_window_arg (1));
+ XWindowAttributes a;
+ if (! (XGetWindowAttributes ((XW_DISPLAY (xw)), (XW_WINDOW (xw)), (&a))))
+ error_external_return ();
+ PRIMITIVE_RETURN (X_COLORMAP_TO_OBJECT ((a . colormap), (XW_XD (xw))));
}
}
-DEFINE_PRIMITIVE("X-CREATE-COLORMAP", Prim_x_create_colormap, 3, 3, 0)
-{ /* Input: (Scheme) window, (Scheme) Visual, Allocate? */
-
- PRIMITIVE_HEADER(3);
- { struct xwindow * xw = x_window_arg (1);
- Display * dpy = XW_DISPLAY(xw);
- Visual * v = x_visual_arg (2);
- SCHEME_OBJECT Allocate = BOOLEAN_ARG (3);
-
- PRIMITIVE_RETURN(
- long_to_integer(XCreateColormap(dpy, XW_WINDOW(xw), v, Allocate)));
- }
+DEFINE_PRIMITIVE ("X-SET-WINDOW-COLORMAP", Prim_x_set_window_colormap, 2, 2,
+ "Set WINDOW's colormap to COLORMAP.")
+{
+ PRIMITIVE_HEADER (2);
+ {
+ struct xwindow * xw = (x_window_arg (1));
+ XSetWindowColormap ((XW_DISPLAY (xw)), (XW_WINDOW (xw)),
+ (XCM_COLORMAP (x_colormap_arg (2))));
+ }
+ PRIMITIVE_RETURN (UNSPECIFIC);
}
-DEFINE_PRIMITIVE("X-COPY-COLORMAP-AND-FREE", Prim_x_copy_colormap_and_free, 2, 2, 0)
-{ /* Input: (Scheme) display, colormap */
- PRIMITIVE_HEADER(2);
- PRIMITIVE_RETURN(
- long_to_integer(
- XCopyColormapAndFree(XD_DISPLAY(x_display_arg(1)), arg_integer(2))));
+DEFINE_PRIMITIVE ("X-CREATE-COLORMAP", Prim_x_create_colormap, 3, 3,
+ "Given WINDOW, and VISUAL, create and return a colormap.\n\
+If third arg WRITEABLE is true, returned colormap may be modified.")
+{
+ PRIMITIVE_HEADER (3);
+ {
+ struct xwindow * xw = (x_window_arg (1));
+ PRIMITIVE_RETURN
+ (X_COLORMAP_TO_OBJECT
+ ((XCreateColormap ((XW_DISPLAY (xw)), (XW_WINDOW (xw)),
+ (XV_VISUAL (x_visual_arg (2))), (BOOLEAN_ARG (3)))),
+ (XW_XD (xw))));
+ }
}
-DEFINE_PRIMITIVE("X-SET-WINDOW-COLORMAP", Prim_x_set_window_colormap, 2, 2, 0)
-{ /* Input: (Scheme) window, colormap */
- struct xwindow * xw = x_window_arg (1);
-
- PRIMITIVE_HEADER(2);
- XSetWindowColormap(XW_DISPLAY(xw), XW_WINDOW(xw), arg_integer(2));
- PRIMITIVE_RETURN(UNSPECIFIC);
+DEFINE_PRIMITIVE ("X-COPY-COLORMAP-AND-FREE", Prim_x_copy_colormap_and_free, 1, 1,
+ "Return a new copy of COLORMAP.")
+{
+ PRIMITIVE_HEADER (1);
+ {
+ struct xcolormap * xcm = (x_colormap_arg (1));
+ PRIMITIVE_RETURN
+ (X_COLORMAP_TO_OBJECT
+ ((XCopyColormapAndFree ((XCM_DISPLAY (xcm)), (XCM_COLORMAP (xcm)))),
+ (XCM_XD (xcm))));
+ }
}
-DEFINE_PRIMITIVE("X-FREE-COLORMAP", Prim_x_free_colormap, 2, 2, 0)
-{ /* Input: (Scheme) display, colormap */
- PRIMITIVE_HEADER (2);
- XFreeColormap(XD_DISPLAY(x_display_arg(1)), arg_integer(2));
- PRIMITIVE_RETURN(UNSPECIFIC);
+DEFINE_PRIMITIVE ("X-FREE-COLORMAP", Prim_x_free_colormap, 1, 1,
+ "Deallocate COLORMAP.")
+{
+ PRIMITIVE_HEADER (1);
+ {
+ struct xcolormap * xcm = (x_colormap_arg (1));
+ XFreeColormap ((XCM_DISPLAY (xcm)), (XCM_COLORMAP (xcm)));
+ deallocate_x_colormap (xcm);
+ }
+ PRIMITIVE_RETURN (UNSPECIFIC);
}
\f
-DEFINE_PRIMITIVE("X-ALLOCATE-COLOR", Prim_x_allocate_color, 5, 5, 0)
-{ /* Input: (Scheme) display, colormap, red, green, blue
- Returns: vector with pixel, red, green, blue
- */
- XColor ColorObj;
- SCHEME_OBJECT Result;
-
- PRIMITIVE_HEADER(5);
- ColorObj.red = arg_integer(3);
- ColorObj.green = arg_integer(4);
- ColorObj.blue = arg_integer(5);
- XAllocColor(XD_DISPLAY(x_display_arg(1)), arg_integer(2), &ColorObj);
- Result = allocate_marked_vector(TC_VECTOR, 4, true);
- VECTOR_SET(Result, 0, long_to_integer(ColorObj.pixel));
- VECTOR_SET(Result, 1, long_to_integer(ColorObj.red));
- VECTOR_SET(Result, 2, long_to_integer(ColorObj.green));
- VECTOR_SET(Result, 3, long_to_integer(ColorObj.blue));
- PRIMITIVE_RETURN(Result);
-}
+#define ARG_RGB_VALUE(argno) (arg_index_integer ((argno), 65536))
-DEFINE_PRIMITIVE("X-ALLOCATE-NAMED-COLOR", Prim_x_allocate_named_color, 3, 3, 0)
-{ /* Input: (Scheme) display, colormap, name
- Returns: vector of closest pixel, red, green, blue
- exact pixel, red, green, blue
- */
-
- SCHEME_OBJECT Result;
- XColor Exact, Closest;
-
- PRIMITIVE_HEADER(3);
- XAllocNamedColor(XD_DISPLAY(x_display_arg (1)),
- arg_integer(2), STRING_ARG(3), &Exact, &Closest);
- Result = allocate_marked_vector(TC_VECTOR, 8, true);
- VECTOR_SET(Result, 0, long_to_integer(Closest.pixel));
- VECTOR_SET(Result, 1, long_to_integer(Closest.red));
- VECTOR_SET(Result, 2, long_to_integer(Closest.green));
- VECTOR_SET(Result, 3, long_to_integer(Closest.blue));
- VECTOR_SET(Result, 4, long_to_integer(Exact.pixel));
- VECTOR_SET(Result, 5, long_to_integer(Exact.red));
- VECTOR_SET(Result, 6, long_to_integer(Exact.green));
- VECTOR_SET(Result, 7, long_to_integer(Exact.blue));
- PRIMITIVE_RETURN(Result);
-}
-
-DEFINE_PRIMITIVE("X-LOOKUP-COLOR", Prim_x_lookup_color, 3, 3, 0)
-{ /* Input: (Scheme) display, colormap, name
- Returns: vector of closest pixel, red, green, blue
- exact pixel, red, green, blue
- */
-
- SCHEME_OBJECT Result;
- XColor Exact, Closest;
- long Stat;
-
- PRIMITIVE_HEADER(3);
- Stat = XAllocNamedColor(XD_DISPLAY(x_display_arg (1)),
- arg_integer(2), STRING_ARG(3), &Exact, &Closest);
- if (Stat == 0)
- { PRIMITIVE_RETURN (SHARP_F);
- }
- else
- { Result = allocate_marked_vector(TC_VECTOR, 8, true);
- VECTOR_SET(Result, 0, long_to_integer(Closest.pixel));
- VECTOR_SET(Result, 1, long_to_integer(Closest.red));
- VECTOR_SET(Result, 2, long_to_integer(Closest.green));
- VECTOR_SET(Result, 3, long_to_integer(Closest.blue));
- VECTOR_SET(Result, 4, long_to_integer(Exact.pixel));
- VECTOR_SET(Result, 5, long_to_integer(Exact.red));
- VECTOR_SET(Result, 6, long_to_integer(Exact.green));
- VECTOR_SET(Result, 7, long_to_integer(Exact.blue));
- PRIMITIVE_RETURN(Result);
+DEFINE_PRIMITIVE ("X-ALLOCATE-COLOR", Prim_x_allocate_color, 4, 4, 0)
+{
+ /* Input: colormap, red, green, blue
+ Returns: pixel, or #F if unable to allocate color cell. */
+ PRIMITIVE_HEADER (4);
+ {
+ struct xcolormap * xcm = (x_colormap_arg (1));
+ XColor c;
+ (c . red) = (ARG_RGB_VALUE (2));
+ (c . green) = (ARG_RGB_VALUE (3));
+ (c . blue) = (ARG_RGB_VALUE (4));
+ PRIMITIVE_RETURN
+ ((XAllocColor ((XCM_DISPLAY (xcm)), (XCM_COLORMAP (xcm)), (&c)))
+ ? (long_to_integer (c . pixel))
+ : SHARP_F);
}
}
-\f
-DEFINE_PRIMITIVE ("X-STORE-COLOR", Prim_x_store_color, 6, 6,
- "Input: (Scheme) display, colormap, pixel, r, g, b (r/g/b may be #f).")
-{
- XColor c;
- PRIMITIVE_HEADER (6);
- (c . pixel) = (arg_nonnegative_integer (3));
- (c . flags) = 0;
- if ((ARG_REF (4)) != SHARP_F)
- {
- (c . red) = (arg_index_integer (4, 65536));
- (c . flags) |= DoRed;
- }
- if ((ARG_REF (5)) != SHARP_F)
- {
- (c . green) = (arg_index_integer (5, 65536));
- (c . flags) |= DoGreen;
- }
- if ((ARG_REF (6)) != SHARP_F)
- {
- (c . blue) = (arg_index_integer (6, 65536));
- (c . flags) |= DoBlue;
- }
- XStoreColor ((XD_DISPLAY (x_display_arg (1))), (arg_integer (2)), (&c));
+DEFINE_PRIMITIVE ("X-STORE-COLOR", Prim_x_store_color, 5, 5,
+ "Input: colormap, pixel, r, g, b (r/g/b may be #f).")
+{
+ PRIMITIVE_HEADER (5);
+ {
+ struct xcolormap * xcm = (x_colormap_arg (1));
+ XColor c;
+ (c . pixel) = (arg_nonnegative_integer (2));
+ (c . flags) = 0;
+ if ((ARG_REF (3)) != SHARP_F)
+ {
+ (c . red) = (arg_index_integer (3, 65536));
+ (c . flags) |= DoRed;
+ }
+ if ((ARG_REF (4)) != SHARP_F)
+ {
+ (c . green) = (arg_index_integer (4, 65536));
+ (c . flags) |= DoGreen;
+ }
+ if ((ARG_REF (5)) != SHARP_F)
+ {
+ (c . blue) = (arg_index_integer (5, 65536));
+ (c . flags) |= DoBlue;
+ }
+ XStoreColor ((XCM_DISPLAY (xcm)), (XCM_COLORMAP (xcm)), (&c));
+ }
PRIMITIVE_RETURN (UNSPECIFIC);
}
-
+\f
#define CONVERT_COLOR_OBJECT(index, color, flag) \
{ \
SCHEME_OBJECT object = (VECTOR_REF (color_object, (index))); \
} \
}
-DEFINE_PRIMITIVE ("X-STORE-COLORS", Prim_x_store_colors, 3, 3,
- "Input: (Scheme) display, colormap, vector of vectors, each of\n\
+DEFINE_PRIMITIVE ("X-STORE-COLORS", Prim_x_store_colors, 2, 2,
+ "Input: colormap, vector of vectors, each of\n\
which contains pixel, r, g, b (where r/g/b can be #f or integer).")
{
- PRIMITIVE_HEADER (3);
+ PRIMITIVE_HEADER (2);
{
- SCHEME_OBJECT color_vector = (VECTOR_ARG (3));
+ struct xcolormap * xcm = (x_colormap_arg (1));
+ SCHEME_OBJECT color_vector = (VECTOR_ARG (2));
unsigned long n_colors = (VECTOR_LENGTH (color_vector));
XColor * colors = (dstack_alloc ((sizeof (XColor)) * n_colors));
{
colors_scan += 1;
}
}
- XStoreColors
- ((XD_DISPLAY (x_display_arg (1))),
- (arg_integer (2)),
- colors,
- n_colors);
+ XStoreColors ((XCM_DISPLAY (xcm)), (XCM_COLORMAP (xcm)), colors, n_colors);
}
PRIMITIVE_RETURN (UNSPECIFIC);
}
\f
-DEFINE_PRIMITIVE("X-STORE-NAMED-COLOR", Prim_x_store_named_color, 7, 7, 0)
-{ /* Input: (Scheme) display, colormap, color name, pixel, DoRed, DoGreen,
- DoBlue */
- PRIMITIVE_HEADER(7);
- { long flags = 0;
- if (BOOLEAN_ARG(5)) flags |= DoRed;
- if (BOOLEAN_ARG(6)) flags |= DoGreen;
- if (BOOLEAN_ARG(7)) flags |= DoBlue;
- XStoreNamedColor(XD_DISPLAY(x_display_arg(1)), arg_integer(2),
- STRING_ARG(3), arg_integer(4), flags);
+DEFINE_PRIMITIVE ("X-FREE-COLORS", Prim_x_free_colors, 1, -1, 0)
+{
+ /* Input: colormap, pixel ... */
+ PRIMITIVE_HEADER (LEXPR);
+ if ((LEXPR_N_ARGUMENTS ()) < 1)
+ signal_error_from_primitive (ERR_WRONG_NUMBER_OF_ARGUMENTS);
+ {
+ struct xcolormap * xcm = (x_colormap_arg (1));
+ unsigned int n_pixels = ((LEXPR_N_ARGUMENTS ()) - 1);
+ unsigned long * pixels =
+ (dstack_alloc ((sizeof (unsigned long)) * n_pixels));
+ unsigned int i;
+ for (i = 0; (i < n_pixels); i += 1)
+ (pixels[i]) = (arg_integer (i + 2));
+ XFreeColors ((XCM_DISPLAY (xcm)), (XCM_COLORMAP (xcm)),
+ pixels, n_pixels, 0);
}
PRIMITIVE_RETURN(UNSPECIFIC);
}
-DEFINE_PRIMITIVE("X-FREE-COLORS", Prim_x_free_colors, 2, -1, 0)
-{ /* Input: (Scheme) display, colormap, pixel ... */
- PRIMITIVE_HEADER(LEXPR);
- { long npixels = (LEXPR_N_ARGUMENTS()) - 2;
- long * First_Pixel = (long *) Free;
- long i, *This_Pixel;
+DEFINE_PRIMITIVE ("X-QUERY-COLOR", Prim_x_query_color, 2, 2, 0)
+{
+ /* Input: colormap, pixel
+ Output: vector of red, green, blue */
+ PRIMITIVE_HEADER (2);
+ {
+ struct xcolormap * xcm = (x_colormap_arg (1));
+ SCHEME_OBJECT result = (allocate_marked_vector (TC_VECTOR, 3, true));
+ XColor c;
+ c . pixel = (arg_integer (2));
+ XQueryColor ((XCM_DISPLAY (xcm)), (XCM_COLORMAP (xcm)), (&c));
+ VECTOR_SET (result, 0, (long_to_integer (c . red)));
+ VECTOR_SET (result, 1, (long_to_integer (c . green)));
+ VECTOR_SET (result, 2, (long_to_integer (c . blue)));
+ PRIMITIVE_RETURN (result);
+ }
+}
- Primitive_GC_If_Needed (npixels);
- for (i=0, This_Pixel=First_Pixel; i < npixels; i++)
- { *This_Pixel++ = integer_to_long(ARG_REF(i+3));
+DEFINE_PRIMITIVE ("X-QUERY-COLORS", Prim_x_query_colors, 1, -1, 0)
+{
+ /* Input: colormap, pixel ...
+ Output: a vector of vectors, each with #(red, green, blue) */
+ PRIMITIVE_HEADER (LEXPR);
+ if ((LEXPR_N_ARGUMENTS ()) < 1)
+ signal_error_from_primitive (ERR_WRONG_NUMBER_OF_ARGUMENTS);
+ {
+ struct xcolormap * xcm = (x_colormap_arg (1));
+ unsigned int n_colors = ((LEXPR_N_ARGUMENTS ()) - 1);
+ XColor * colors = (dstack_alloc ((sizeof (XColor)) * n_colors));
+ unsigned int i;
+ for (i = 0; (i < n_colors); i += 1)
+ ((colors[i]) . pixel) = (arg_integer (i + 2));
+ XQueryColors ((XCM_DISPLAY (xcm)), (XCM_COLORMAP (xcm)), colors, n_colors);
+ {
+ SCHEME_OBJECT result =
+ (allocate_marked_vector (TC_VECTOR, n_colors, true));
+ for (i = 0; (i < n_colors); i += 1)
+ {
+ SCHEME_OBJECT cv = (allocate_marked_vector (TC_VECTOR, 3, true));
+ VECTOR_SET (cv, 0, (long_to_integer ((colors[i]) . red)));
+ VECTOR_SET (cv, 1, (long_to_integer ((colors[i]) . green)));
+ VECTOR_SET (cv, 2, (long_to_integer ((colors[i]) . blue)));
+ VECTOR_SET (result, i, cv);
+ }
+ PRIMITIVE_RETURN (result);
}
- XFreeColors(XD_DISPLAY(x_display_arg(1)), arg_integer(2),
- ((unsigned long *) First_Pixel), npixels, 0);
}
- PRIMITIVE_RETURN(UNSPECIFIC);
}
+\f
+/* Named colors */
-DEFINE_PRIMITIVE("X-QUERY-COLOR", Prim_x_query_color, 3, 3, 0)
-{ /* Input: (Scheme) display, colormap, pixel
- Output: vector of red, green, blue
+DEFINE_PRIMITIVE ("X-PARSE-COLOR", Prim_x_parse_color, 2, 2, 0)
+{ /* Input: colormap, string
+ Output: vector of pixel, red, green, blue
*/
- PRIMITIVE_HEADER(3);
- { XColor ThisColor;
- SCHEME_OBJECT Result = allocate_marked_vector(TC_VECTOR, 3, true);
-
- ThisColor.pixel = arg_integer(3);
- XQueryColor(XD_DISPLAY(x_display_arg(1)), arg_integer(2), &ThisColor);
- VECTOR_SET(Result, 0, long_to_integer(ThisColor.red));
- VECTOR_SET(Result, 1, long_to_integer(ThisColor.green));
- VECTOR_SET(Result, 2, long_to_integer(ThisColor.blue));
- PRIMITIVE_RETURN(Result);
+ PRIMITIVE_HEADER (2);
+ {
+ struct xcolormap * xcm = (x_colormap_arg (1));
+ XColor TheColor;
+ if (! (XParseColor ((XCM_DISPLAY (xcm)), (XCM_COLORMAP (xcm)),
+ (STRING_ARG (2)), (&TheColor))))
+ PRIMITIVE_RETURN (SHARP_F);
+ {
+ SCHEME_OBJECT result = (allocate_marked_vector (TC_VECTOR, 4, true));
+ VECTOR_SET(result, 0, long_to_integer(TheColor.pixel));
+ VECTOR_SET(result, 1, long_to_integer(TheColor.red));
+ VECTOR_SET(result, 2, long_to_integer(TheColor.green));
+ VECTOR_SET(result, 3, long_to_integer(TheColor.blue));
+ PRIMITIVE_RETURN (result);
+ }
}
}
-
-DEFINE_PRIMITIVE("X-QUERY-COLORS", Prim_x_query_colors, 2, -1, 0)
-{ /* Input: (Scheme) display, colormap, pixel ...
- Output: a vector of vectors, each with (red, green, blue)
+
+DEFINE_PRIMITIVE ("X-ALLOCATE-NAMED-COLOR", Prim_x_allocate_named_color, 2, 2, 0)
+{ /* Input: colormap, name
+ Returns: vector of closest pixel, red, green, blue
+ exact pixel, red, green, blue
*/
- PRIMITIVE_HEADER(LEXPR);
- { long npixels = (LEXPR_N_ARGUMENTS()) - 2;
- XColor * First_Color = (XColor *) Free;
- long i;
- XColor *This_Color;
- SCHEME_OBJECT Result, *Next_Result;
+ SCHEME_OBJECT Result;
+ XColor Exact, Closest;
+ struct xcolormap * xcm;
+ PRIMITIVE_HEADER (2);
- Primitive_GC_If_Needed(npixels * (BYTES_TO_WORDS(sizeof(XColor))));
- for (i=0, This_Color=First_Color; i < npixels; i++, This_Color++)
- { This_Color->pixel = integer_to_long(ARG_REF(i+3));
- }
- Free = (SCHEME_OBJECT *) This_Color;
- XQueryColors(XD_DISPLAY(x_display_arg(1)), arg_integer(2),
- First_Color, npixels);
- Result = allocate_marked_vector(TC_VECTOR, npixels, true);
- for (i=0, This_Color=First_Color, Next_Result=VECTOR_LOC(Result, 0);
- i < npixels; i++, This_Color++)
- { SCHEME_OBJECT This_Vector = allocate_marked_vector(TC_VECTOR, 3, true);
- *Next_Result++ = This_Vector;
- VECTOR_SET(This_Vector, 0, long_to_integer(This_Color->red));
- VECTOR_SET(This_Vector, 1, long_to_integer(This_Color->green));
- VECTOR_SET(This_Vector, 2, long_to_integer(This_Color->blue));
- }
- PRIMITIVE_RETURN(Result);
+ xcm = (x_colormap_arg (1));
+ XAllocNamedColor
+ ((XCM_DISPLAY (xcm)), (XCM_COLORMAP (xcm)),
+ (STRING_ARG (2)), &Exact, &Closest);
+ Result = allocate_marked_vector(TC_VECTOR, 8, true);
+ VECTOR_SET(Result, 0, long_to_integer(Closest.pixel));
+ VECTOR_SET(Result, 1, long_to_integer(Closest.red));
+ VECTOR_SET(Result, 2, long_to_integer(Closest.green));
+ VECTOR_SET(Result, 3, long_to_integer(Closest.blue));
+ VECTOR_SET(Result, 4, long_to_integer(Exact.pixel));
+ VECTOR_SET(Result, 5, long_to_integer(Exact.red));
+ VECTOR_SET(Result, 6, long_to_integer(Exact.green));
+ VECTOR_SET(Result, 7, long_to_integer(Exact.blue));
+ PRIMITIVE_RETURN(Result);
+}
+
+DEFINE_PRIMITIVE("X-STORE-NAMED-COLOR", Prim_x_store_named_color, 6, 6, 0)
+{
+ /* Input: colormap, color name, pixel, DoRed, DoGreen, DoBlue */
+ PRIMITIVE_HEADER(6);
+ {
+ struct xcolormap * xcm = (x_colormap_arg (1));
+ XStoreNamedColor ((XCM_DISPLAY (xcm)), (XCM_COLORMAP (xcm)),
+ (STRING_ARG (2)), (arg_integer (4)),
+ (((BOOLEAN_ARG (4)) ? DoRed : 0)
+ | ((BOOLEAN_ARG (5)) ? DoGreen : 0)
+ | ((BOOLEAN_ARG (6)) ? DoBlue : 0)));
}
+ PRIMITIVE_RETURN(UNSPECIFIC);
+}
+\f
+DEFINE_PRIMITIVE("X-LOOKUP-COLOR", Prim_x_lookup_color, 2, 2, 0)
+{
+ /* Input: colormap, name
+ Returns: vector of closest pixel, red, green, blue
+ exact pixel, red, green, blue
+ */
+
+ SCHEME_OBJECT Result;
+ XColor Exact, Closest;
+ struct xcolormap * xcm;
+ PRIMITIVE_HEADER (2);
+
+ xcm = (x_colormap_arg (1));
+ if (! (XAllocNamedColor
+ ((XCM_DISPLAY (xcm)), (XCM_COLORMAP (xcm)),
+ (STRING_ARG (2)), &Exact, &Closest)))
+ PRIMITIVE_RETURN (SHARP_F);
+ Result = allocate_marked_vector(TC_VECTOR, 8, true);
+ VECTOR_SET(Result, 0, long_to_integer(Closest.pixel));
+ VECTOR_SET(Result, 1, long_to_integer(Closest.red));
+ VECTOR_SET(Result, 2, long_to_integer(Closest.green));
+ VECTOR_SET(Result, 3, long_to_integer(Closest.blue));
+ VECTOR_SET(Result, 4, long_to_integer(Exact.pixel));
+ VECTOR_SET(Result, 5, long_to_integer(Exact.red));
+ VECTOR_SET(Result, 6, long_to_integer(Exact.green));
+ VECTOR_SET(Result, 7, long_to_integer(Exact.blue));
+ PRIMITIVE_RETURN(Result);
}
/* -*-C-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/x11graph.c,v 1.14 1991/07/08 17:39:44 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/x11graph.c,v 1.15 1991/07/23 08:16:38 cph Exp $
Copyright (c) 1989-91 Massachusetts Institute of Technology
}
\f
DEFINE_PRIMITIVE ("X-CREATE-IMAGE", Prim_x_create_image, 3, 3,
- " Arguments: Window, width, height\
- Returns: A Scheme image\
-\
- The window is used to find the Display, Visual, and Depth\
- information needed to crate an XImage structure.")
+ "Arguments: Window, width, height\n\
+Returns: A Scheme image\n\
+\n\
+The window is used to find the Display, Visual, and Depth\n\
+information needed to crate an XImage structure.")
{
- extern allocate_x_image ();
PRIMITIVE_HEADER (3);
{
struct xwindow * xw = (x_window_arg (1));
(((width + (byte_pad - 1)) / byte_pad) * byte_pad);
XWindowAttributes attrs;
XGetWindowAttributes (dpy, window, (&attrs));
- {
- struct ximage * xi = (x_malloc (sizeof (struct ximage)));
- (XI_ALLOCATION_INDEX (xi)) = (allocate_x_image (xi));
- (XI_IMAGE (xi)) =
- (XCreateImage
- (dpy,
- (DefaultVisualOfScreen (attrs . screen)),
- (attrs . depth),
- ZPixmap,
- 0,
- ((char *)
- (x_malloc (height
- * bytes_per_line
- * ((((attrs . depth) - 1) / 8) + 1)))),
- width,
- height,
- bitmap_pad,
- bytes_per_line));
- return (XI_TO_OBJECT (xi));
- }
+ PRIMITIVE_RETURN
+ (X_IMAGE_TO_OBJECT
+ (XCreateImage
+ (dpy,
+ (DefaultVisualOfScreen (attrs . screen)),
+ (attrs . depth),
+ ZPixmap,
+ 0,
+ ((char *)
+ (x_malloc (height
+ * bytes_per_line
+ * ((((attrs . depth) - 1) / 8) + 1)))),
+ width,
+ height,
+ bitmap_pad,
+ bytes_per_line)));
}
}
PRIMITIVE_RETURN (UNSPECIFIC);
}
}
-
+\f
DEFINE_PRIMITIVE("X-GET-PIXEL-FROM-IMAGE", Prim_x_get_image_pixel, 3, 3, 0)
{
PRIMITIVE_HEADER (3);
- PRIMITIVE_RETURN
- (long_to_integer
- (XGetPixel ((XI_IMAGE (x_image_arg (1))),
- (arg_nonnegative_integer (2)),
- (arg_nonnegative_integer (3)))));
+ {
+ XImage * image = (XI_IMAGE (x_image_arg (1)));
+ PRIMITIVE_RETURN
+ (long_to_integer
+ (XGetPixel (image,
+ (arg_index_integer (2, (image -> width))),
+ (arg_index_integer (3, (image -> height))))));
+ }
}
DEFINE_PRIMITIVE("X-SET-PIXEL-IN-IMAGE", Prim_x_set_image_pixel, 4, 4, 0)
-{ PRIMITIVE_HEADER (4);
- { struct ximage * xi = x_image_arg(1);
- long XCoord = arg_integer(2);
- long YCoord = arg_integer(3);
- long Pixel = arg_integer(4);
-
- XPutPixel (XI_IMAGE(xi), XCoord, YCoord, Pixel);
+{
+ PRIMITIVE_HEADER (4);
+ {
+ XImage * image = (XI_IMAGE (x_image_arg (1)));
+ XPutPixel (image,
+ (arg_index_integer (2, (image -> width))),
+ (arg_index_integer (3, (image -> height))),
+ (arg_integer (4)));
PRIMITIVE_RETURN (UNSPECIFIC);
}
}
DEFINE_PRIMITIVE ("X-DESTROY-IMAGE", Prim_x_destroy_image, 1, 1, 0)
-{ extern void x_destroy_image ();
+{
PRIMITIVE_HEADER (1);
- { struct ximage * xi = x_image_arg (1);
- x_destroy_image (xi);
+ {
+ struct ximage * xi = (x_image_arg (1));
+ XDestroyImage (XI_IMAGE (xi));
+ deallocate_x_image (xi);
PRIMITIVE_RETURN (UNSPECIFIC);
}
}
DEFINE_PRIMITIVE ("X-DISPLAY-IMAGE", Prim_x_display_image, 8, 8, 0)
-{ /* Called with Image, X-offset in image, Y-offset in image,
+{
+ /* Called with Image, X-offset in image, Y-offset in image,
Window, X-offset in window, Y-offset in window,
- Width, Height
- */
+ Width, Height */
PRIMITIVE_HEADER (8);
- { struct ximage * xi = x_image_arg (1);
- long XImageOffset = arg_integer(2);
- long YImageOffset = arg_integer(3);
- struct xwindow * xw = x_window_arg (4);
- long XWindowOffset = arg_integer(5);
- long YWindowOffset = arg_integer(6);
- long Width = arg_integer(7);
- long Height = arg_integer(8);
-
- XPutImage(XW_DISPLAY(xw), XW_WINDOW(xw), XW_NORMAL_GC(xw),
- XI_IMAGE(xi), XImageOffset, YImageOffset,
- XWindowOffset, YWindowOffset,
- Width, Height);
+ {
+ XImage * image = (XI_IMAGE (x_image_arg (1)));
+ unsigned int image_width = (image -> width);
+ unsigned int image_height = (image -> height);
+ unsigned int x_offset = (arg_index_integer (2, image_width));
+ unsigned int y_offset = (arg_index_integer (3, image_height));
+ struct xwindow * xw = (x_window_arg (4));
+ XPutImage
+ ((XW_DISPLAY (xw)),(XW_WINDOW (xw)),(XW_NORMAL_GC (xw)),
+ image, x_offset, y_offset,
+ (arg_x_coordinate (5, xw)),
+ (arg_y_coordinate (6, xw)),
+ (arg_index_integer (7, ((image_width - x_offset) + 1))),
+ (arg_index_integer (8, ((image_height - y_offset) + 1))));
PRIMITIVE_RETURN (UNSPECIFIC);
}
}
-
+\f
DEFINE_PRIMITIVE ("X-READ-IMAGE", Prim_x_read_image, 8, 8, 0)
-{ /* Called with Image, X-offset in image, Y-offset in image,
+{
+ /* Called with Image, X-offset in image, Y-offset in image,
Window, X-offset in window, Y-offset in window,
- Width, Height
- */
+ Width, Height */
PRIMITIVE_HEADER (8);
{ struct ximage * xi = x_image_arg (1);
long XImageOffset = arg_integer(2);
}
DEFINE_PRIMITIVE ("X-WINDOW-DEPTH", Prim_x_window_depth, 1, 1, 0)
-{ struct xwindow * xw = x_window_arg (1);
- XWindowAttributes attrs;
-
+{
PRIMITIVE_HEADER (1);
- XGetWindowAttributes(XW_DISPLAY(xw), XW_WINDOW(xw), &attrs);
- PRIMITIVE_RETURN (long_to_integer (attrs.depth));
+ {
+ struct xwindow * xw = (x_window_arg (1));
+ XWindowAttributes attrs;
+ XGetWindowAttributes ((XW_DISPLAY (xw)), (XW_WINDOW (xw)), (&attrs));
+ PRIMITIVE_RETURN (long_to_integer (attrs . depth));
+ }
}
DEFINE_PRIMITIVE ("X-GRAPHICS-MAP-X-COORDINATE", Prim_x_graphics_map_x_coordinate, 2, 2, 0)
projects / mit-scheme.git / commitdiff