summaryrefslogtreecommitdiffstats
path: root/x.c
diff options
context:
space:
mode:
Diffstat (limited to 'x.c')
-rw-r--r--x.c2114
1 files changed, 2114 insertions, 0 deletions
diff --git a/x.c b/x.c
new file mode 100644
index 0000000..6070ef2
--- /dev/null
+++ b/x.c
@@ -0,0 +1,2114 @@
+/* Copyright (C) 1999 Free Software Foundation, Inc.
+ *
+ * This program is free software; you can redistribute it and/or modify
+ * it under the terms of the GNU General Public License as published by
+ * the Free Software Foundation; either version 2, or (at your option)
+ * any later version.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with this software; see the file COPYING. If not, write to
+ * the Free Software Foundation, 59 Temple Place, Suite 330, Boston, MA 02111, USA.
+ *
+ * As a special exception, the Free Software Foundation gives permission
+ * for additional uses of the text contained in its release of GUILE.
+ *
+ * The exception is that, if you link the GUILE library with other files
+ * to produce an executable, this does not by itself cause the
+ * resulting executable to be covered by the GNU General Public License.
+ * Your use of that executable is in no way restricted on account of
+ * linking the GUILE library code into it.
+ *
+ * This exception does not however invalidate any other reasons why
+ * the executable file might be covered by the GNU General Public License.
+ *
+ * This exception applies only to the code released by the
+ * Free Software Foundation under the name GUILE. If you copy
+ * code from other Free Software Foundation releases into a copy of
+ * GUILE, as the General Public License permits, the exception does
+ * not apply to the code that you add in this way. To avoid misleading
+ * anyone as to the status of such modified files, you must delete
+ * this exception notice from them.
+ *
+ * If you write modifications of your own for GUILE, it is your choice
+ * whether to permit this exception to apply to your modifications.
+ * If you do not wish that, delete this exception notice.
+ */
+
+/* "x.c" SCM interface to Xlib.
+ * Authors: Aubrey Jaffer (I have rewritten nearly all of it) and:
+ *
+ * Modified by Shigenobu Kimura (skimu@izanagi.phys.s.u-tokyo.ac.jp)
+ * Author: Larry Campbell (campbell@world.std.com)
+ *
+ * Copyright 1992 by The Boston Software Works, Inc.
+ * Permission to use for any purpose whatsoever granted, as long
+ * as this copyright notice remains intact. Please send bug fixes
+ * or enhancements to the above email address.
+ *
+ * Generic X and Xlib functions for scm.
+ * These functions do not depend on any toolkit.
+ */
+
+#include <stdio.h>
+#include <X11/X.h>
+#include <X11/Xlib.h>
+#include <X11/Xutil.h>
+
+#include "scm.h"
+
+/* These structs are mallocated for use in SMOBS. */
+
+struct xs_Display {
+ SCM after;
+ int screen_count;
+ Display *dpy;
+};
+
+/* An array of struct xs_screen (following xs_Display) holds the
+ root-windows and default colormaps. */
+
+struct xs_screen {
+ SCM root_window;
+ SCM default_gcontext;
+ SCM default_visual;
+ SCM default_colormap;
+};
+
+struct xs_Window {
+ SCM display;
+ int screen_number;
+ Display *dpy;
+ union {
+ Window win;
+ Pixmap pm;
+ Drawable drbl;
+ } p;
+};
+
+struct xs_GContext {
+ SCM display;
+ int screen_number;
+ Display *dpy;
+ GC gc;
+ SCM font;
+ SCM tile;
+ SCM stipple;
+ SCM clipmask;
+};
+
+struct xs_Cursor {
+ SCM display;
+ Cursor cursor;
+};
+
+struct xs_Font {
+ SCM display;
+ Font font;
+ SCM name;
+};
+
+struct xs_Colormap {
+ SCM display;
+ Display *dpy;
+ Colormap cm;
+};
+
+/* These structs are for returning multiple values when processing
+ procedure arguments. */
+
+struct display_screen{
+ SCM display;
+ Display *dpy;
+ int screen_number;
+};
+
+/* The cproto program fills x.h with ANSI-C prototypes of the
+ functions in x.c. */
+
+#include "x.h"
+
+ /* Macros for accessing these structs */
+
+#define DISPLAY(x) ((struct xs_Display *) CDR(x))
+#define WINDOW(x) ((struct xs_Window *) CDR(x))
+#define CURSOR(x) ((struct xs_Cursor *) CDR(x))
+#define FONT(x) ((struct xs_Font *) CDR(x))
+#define COLORMAP(x) ((struct xs_Colormap *) CDR(x))
+#define GCONTEXT(x) ((struct xs_GContext *) CDR(x))
+
+#define XDISPLAY(x) (DISPLAY(x)->dpy)
+#define XWINDOW(x) (WINDOW(x)->p.win)
+#define XWINDISPLAY(x) (WINDOW(x)->dpy)
+#define XCURSOR(x) (CURSOR(x)->cursor)
+#define XFONT(x) (FONT(x)->font)
+#define XGCONTEXT(x) (GCONTEXT(x)->gc)
+#define XCOLORMAP(x) (COLORMAP(x)->cm)
+#define XGCONDISPLAY(x) (GCONTEXT(x)->dpy)
+
+/* Notice that types Visual and XEvent don't have struct wrappers. */
+
+#define XVISUAL(x) ((Visual *) CDR(x))
+#define XEVENT(x) ((XEvent *) CDR(x))
+
+ /* Type predicates */
+
+#define DISPLAYP(x) (TYP16(x)==tc16_xdisplay)
+#define OPDISPLAYP(x) (((0xffff | OPN) & (int)CAR(x))==(tc16_xdisplay | OPN))
+#define WINDOWP(x) (TYP16(x)==tc16_xwindow)
+#define OPWINDOWP(x) (((0xffff | OPN) & (int)CAR(x))==(tc16_xwindow | OPN))
+#define COLORMAPP(x) (TYP16(x)==tc16_xcolormap)
+#define GCONTEXTP(x) (TYP16(x)==tc16_xgcontext)
+#define CURSORP(x) (TYP16(x)==tc16_xcursor)
+#define FONTP(x) (TYP16(x)==tc16_xfont)
+#define VISUALP(x) (TYP16(x)==tc16_xvisual)
+#define XEVENTP(x) (TYP16(x)==tc16_xevent)
+
+ /* Scheme Procedure Names */
+
+static char s_x_open_display[] = "x:open-display";
+static char s_x_close[] = "x:close";
+static char s_x_display_debug[] = "x:display-debug";
+static char s_x_default_screen[] = "x:default-screen";
+static char s_x_root_window[] = "x:root-window";
+static char s_x_default_gcontext[] = "x:default-gc";
+static char s_x_default_visual[] = "x:default-visual";
+static char s_x_default_colormap[] = "x:default-colormap";
+static char s_x_create_window[] = "x:create-window";
+static char s_x_window_set[] = "x:window-set!";
+/* static char s_x_window_ref[] = "x:window-ref"; */
+static char s_x_create_pixmap[] = "x:create-pixmap";
+
+static char s_x_map_window[] = "x:map-window";
+static char s_x_map_raised[] = "x:map-raised";
+static char s_x_map_subwindows[] = "x:map-subwindows";
+static char s_x_unmap_window[] = "x:unmap-window";
+static char s_x_unmap_subwindows[] = "x:unmap-subwindows";
+
+static char s_x_create_gc[] = "x:create-gc";
+static char s_x_gc_set[] = "x:gc-set!";
+static char s_x_gc_ref[] = "x:gc-ref";
+static char s_x_copy_gc[] = "x:copy-gc-fields!";
+
+static char s_x_create_cursor[] = "x:create-cursor";
+
+static char s_x_load_font[] = "x:load-font";
+
+static char s_x_protocol_version[] = "x:protocol-version";
+static char s_x_vendor_release[] = "x:vendor-release";
+static char s_x_server_vendor[] = "x:server-vendor";
+static char s_x_next_event[] = "x:next-event";
+static char s_x_peek_event[] = "x:peek-event";
+static char s_x_events_queued[] = "x:events-queued";
+static char s_x_q_length[] = "x:q-length";
+static char s_x_pending[] = "x:pending";
+static char s_x_screen_count[] = "x:screen-count";
+static char s_x_screen_cells[] = "x:screen-cells";
+static char s_x_screen_depths[] = "x:screen-depths";
+static char s_x_screen_depth[] = "x:screen-depth";
+static char s_x_screen_size[] = "x:screen-size";
+static char s_x_screen_dimm[] = "x:screen-dimensions";
+static char s_x_screen_white[] = "x:screen-white";
+static char s_x_screen_black[] = "x:screen-black";
+static char s_x_make_visual[] = "x:make-visual";
+static char s_x_window_geometry[] = "x:window-geometry";
+
+static char s_x_create_colormap[] = "x:create-colormap";
+static char s_x_recreate_colormap[] = "x:copy-colormap-and-free";
+static char s_x_alloc_color_cells[] = "x:alloc-colormap-cells";
+static char s_x_free_color_cells[] = "x:free-colormap-cells";
+static char s_x_find_color[] = "x:colormap-find-color";
+static char s_x_color_set[] = "x:colormap-set!";
+static char s_x_color_ref[] = "x:colormap-ref";
+static char s_x_install_colormap[] = "x:install-colormap";
+
+static char s_x_clear_area[] = "x:clear-area";
+static char s_x_fill_rectangle[] = "x:fill-rectangle";
+/* static char s_x_copy_area[] = "x:copy-area"; */
+static char s_x_draw_points[] = "x:draw-points";
+static char s_x_draw_segments[] = "x:draw-segments";
+static char s_x_draw_lines[] = "x:draw-lines";
+static char s_x_fill_poly[] = "x:fill-polygon";
+static char s_x_draw_string[] = "x:draw-string";
+static char s_x_image_string[] = "x:image-string";
+
+static char s_x_flush[] = "x:flush";
+static char s_x_event_ref[] = "x:event-ref";
+
+ /* Type-name strings */
+
+static char s_gc[] = "graphics-context";
+#define s_display (&s_x_open_display[7])
+#define s_window (&s_x_root_window[7])
+#define s_cursor (&s_x_create_cursor[9])
+#define s_font (&s_x_load_font[7])
+#define s_colormap (&s_x_create_colormap[9])
+
+ /* Scheme (SMOB) types defined in this module */
+
+long tc16_xdisplay;
+long tc16_xgcontext;
+long tc16_xcolormap;
+long tc16_xwindow;
+long tc16_xcursor;
+long tc16_xfont;
+long tc16_xvisual;
+long tc16_xevent;
+
+/* We use OPN (which is already defined and used for PTOB ports) to
+ keep track of whether objects of types Display and Window are open.
+ The type xs_Window includes screen root-windows and pixmaps. The
+ SMOB (CAR) header bits SCROOT and PXMP keep track of which type of
+ window the SMOB is. */
+
+/* #define OPN (1L<<16) */
+/* #define RDNG (2L<<16) */
+/* #define WRTNG (4L<<16) */
+#define SCROOT (8L<<16)
+#define PXMP (16L<<16)
+
+/* Utility routines for creating SCM-wrapped X structs and the SMOB
+ routines for collecting them. */
+
+SCM make_xwindow(display, screen_number, win, pxmp, rootp)
+ SCM display;
+ int screen_number;
+ Drawable win;
+ char pxmp, rootp;
+{
+ SCM z;
+ struct xs_Window *xsw;
+ DEFER_INTS;
+ z = must_malloc_cell((long)sizeof(struct xs_Window),
+ (SCM)(tc16_xwindow | OPN
+ | (pxmp ? PXMP : 0L)
+ | (rootp ? SCROOT : 0L)),
+ s_window);
+ xsw = WINDOW(z);
+ xsw->display = display;
+ xsw->dpy = XDISPLAY(display);
+ xsw->screen_number = screen_number;
+ if (pxmp) xsw->p.pm = (Pixmap)win;
+ else xsw->p.win = (Window)win;
+ ALLOW_INTS;
+ return z;
+}
+static SCM mark_xwindow(ptr)
+ SCM ptr;
+{
+ if CLOSEDP(ptr) return BOOL_F;
+ return WINDOW(ptr)->display;
+}
+static sizet free_xwindow(ptr)
+ CELLPTR ptr;
+{
+ SCM td = CAR((SCM)ptr);
+ if (!(td & OPN)) return 0;
+ if (!(td & SCROOT)) {
+ struct xs_Window *xsw = WINDOW((SCM)ptr);
+ SCM sd = xsw->display;
+ if (NIMP(sd) && OPDISPLAYP(sd)) {
+ if (td & PXMP) XFreePixmap(xsw->dpy, xsw->p.pm);
+ else XDestroyWindow(xsw->dpy, xsw->p.win);
+ }
+ }
+ must_free((char *)CDR((SCM)ptr), sizeof(struct xs_Window));
+ CAR((SCM)ptr) = td & ~OPN;
+ return sizeof(struct xs_Window);
+}
+
+SCM make_xcolormap(sdpy, cmp)
+ SCM sdpy;
+ Colormap cmp;
+{
+ SCM z;
+ struct xs_Colormap *xcm;
+ DEFER_INTS;
+ z = must_malloc_cell((long)sizeof(struct xs_Colormap),
+ (SCM)tc16_xcolormap,
+ s_colormap);
+ xcm = COLORMAP(z);
+ xcm->display = sdpy;
+ xcm->dpy = DISPLAY(xcm->display)->dpy;
+ xcm->cm = cmp;
+ ALLOW_INTS;
+ return z;
+}
+static SCM mark_xcolormap(ptr)
+ SCM ptr;
+{
+ if CLOSEDP(ptr) return BOOL_F;
+ return COLORMAP(ptr)->display;
+}
+static sizet free_xcolormap(ptr)
+ CELLPTR ptr;
+{
+ struct xs_Colormap *xcmp = COLORMAP((SCM)ptr);
+ SCM sdpy = xcmp->display;
+ if (NIMP(sdpy) && OPDISPLAYP(sdpy))
+ XFreeColormap(xcmp->dpy, xcmp->cm);
+ must_free((char *)CDR((SCM)ptr), sizeof(struct xs_Colormap));
+ return sizeof(struct xs_Colormap);
+}
+
+SCM make_xdisplay(d)
+ Display *d;
+{
+ SCM z;
+ struct xs_screen *scrns;
+ struct xs_Display *xsd;
+ int idx = ScreenCount(d);
+ DEFER_INTS;
+ z = must_malloc_cell((long)sizeof(struct xs_Display)
+ + idx * sizeof(struct xs_screen),
+ (SCM)tc16_xdisplay | OPN,
+ s_display);
+ xsd = DISPLAY(z);
+ xsd->after = BOOL_F;
+ xsd->screen_count = idx;
+ xsd->dpy = d;
+ scrns = (struct xs_screen *)(xsd + 1);
+ while (idx--) {
+ scrns[idx].root_window = BOOL_F;
+ scrns[idx].default_gcontext = BOOL_F;
+ scrns[idx].default_visual = BOOL_F;
+ scrns[idx].default_colormap = BOOL_F;
+ }
+ ALLOW_INTS;
+ idx = xsd->screen_count;
+ while (idx--) {
+ scrns[idx].root_window =
+ make_xwindow(z, idx, RootWindow(d, idx), (char) 0, (char) 1);
+ scrns[idx].default_gcontext =
+ make_xgcontext(z, idx, XDefaultGC(d, idx), !0);
+ scrns[idx].default_colormap =
+ make_xcolormap(z, DefaultColormap(d, idx));
+ scrns[idx].default_visual =
+ make_xvisual(DefaultVisual(d, idx));
+ }
+ return z;
+}
+static SCM mark_xdisplay(ptr)
+ SCM ptr;
+{
+ if CLOSEDP(ptr) return BOOL_F;
+ {
+ struct xs_Display *xsd = DISPLAY((SCM)ptr);
+ struct xs_screen *scrns = (struct xs_screen *)(xsd + 1);
+ int idx = xsd->screen_count;
+ while (--idx) {
+ gc_mark(scrns[idx].root_window);
+ gc_mark(scrns[idx].default_gcontext);
+ gc_mark(scrns[idx].default_visual);
+ gc_mark(scrns[idx].default_colormap);
+ }
+ gc_mark(scrns[idx].root_window);
+ gc_mark(scrns[idx].default_gcontext);
+ gc_mark(scrns[idx].default_visual);
+ return scrns[idx].default_colormap;
+ }
+}
+static sizet free_xdisplay(ptr)
+ CELLPTR ptr;
+{
+ SCM td = CAR((SCM)ptr);
+ if (!(td & OPN)) return 0;
+ {
+ struct xs_Display *xsd = DISPLAY((SCM)ptr);
+ sizet len = sizeof(struct xs_Display) +
+ xsd->screen_count * sizeof(struct xs_screen);
+ XCloseDisplay(xsd->dpy);
+ must_free((char *)xsd, len);
+ CAR((SCM)ptr) = td & ~OPN;
+ return len;
+ }
+}
+
+SCM make_xgcontext(d, screen_number, gc, rootp)
+ SCM d;
+ int screen_number;
+ GC gc;
+ int rootp;
+{
+ SCM z;
+ struct xs_GContext *xgc;
+ DEFER_INTS;
+ z = must_malloc_cell((long)sizeof(struct xs_GContext),
+ (SCM)tc16_xgcontext | (rootp ? SCROOT : 0L),
+ s_gc);
+ xgc = GCONTEXT(z);
+ xgc->display = d;
+ xgc->screen_number = screen_number;
+ xgc->dpy = XDISPLAY(d);
+ xgc->gc = gc;
+ xgc->font = BOOL_F;
+ xgc->tile = BOOL_F;
+ xgc->stipple = BOOL_F;
+ xgc->clipmask = BOOL_F;
+ ALLOW_INTS;
+ return z;
+}
+static SCM mark_xgcontext(ptr)
+ SCM ptr;
+{
+ struct xs_GContext *xgc = GCONTEXT(ptr);
+ gc_mark(xgc->font);
+ gc_mark(xgc->tile);
+ gc_mark(xgc->stipple);
+ gc_mark(xgc->clipmask);
+ return xgc->display;
+}
+static sizet free_xgcontext(ptr)
+ CELLPTR ptr;
+{
+ SCM td = CAR((SCM)ptr);
+ if (!(td & OPN)) return 0;
+ if (!(td & SCROOT)) {
+ struct xs_GContext *xgc = GCONTEXT((SCM)ptr);
+ SCM sd = xgc->display;
+ if (NIMP(sd) && OPDISPLAYP(sd)) XFreeGC(xgc->dpy, xgc->gc);
+ }
+ must_free((char *)CDR((SCM)ptr), sizeof(struct xs_GContext));
+ return sizeof(struct xs_GContext);
+}
+
+SCM make_xcursor(display, cursor)
+ SCM display;
+ Cursor cursor;
+{
+ SCM z;
+ struct xs_Cursor *xcsr;
+ DEFER_INTS;
+ z = must_malloc_cell((long)sizeof(struct xs_Cursor),
+ (SCM)tc16_xcursor,
+ s_cursor);
+ xcsr = CURSOR(z);
+ xcsr->display = display;
+ xcsr->cursor = cursor;
+ ALLOW_INTS;
+ return z;
+}
+static SCM mark_xcursor(ptr)
+ SCM ptr;
+{
+ if CLOSEDP(ptr) return BOOL_F;
+ return CURSOR(ptr)->display;
+}
+static sizet free_xcursor(ptr)
+ CELLPTR ptr;
+{
+ struct xs_Cursor *xcsr = CURSOR((SCM)ptr);
+ SCM sdpy = xcsr->display;
+ if (NIMP(sdpy) && OPDISPLAYP(sdpy)) {
+ struct xs_Display *xdp = DISPLAY(sdpy);
+ XFreeCursor(xdp->dpy, xcsr->cursor);
+ }
+ must_free((char *)CDR((SCM)ptr), sizeof(struct xs_Cursor));
+ return sizeof(struct xs_Cursor);
+}
+SCM make_xfont(display, font, name)
+ SCM display;
+ Font font;
+ SCM name;
+{
+ SCM z;
+ struct xs_Font *xfnt;
+ DEFER_INTS;
+ z = must_malloc_cell((long)sizeof(struct xs_Font),
+ (SCM)tc16_xfont,
+ s_font);
+ xfnt = FONT(z);
+ xfnt->display = display;
+ xfnt->font = font;
+ xfnt->name = name;
+ ALLOW_INTS;
+ return z;
+}
+static SCM mark_xfont(ptr)
+ SCM ptr;
+{
+ struct xs_Font *xfn = FONT(ptr);
+ gc_mark(xfn->name);
+ return xfn->display;
+}
+static sizet free_xfont(ptr)
+ CELLPTR ptr;
+{
+ struct xs_Font *xfnt = FONT((SCM)ptr);
+ SCM sdpy = xfnt->display;
+ if (NIMP(sdpy) && OPDISPLAYP(sdpy)) {
+ struct xs_Display *xdp = DISPLAY(sdpy);
+ XUnloadFont(xdp->dpy, xfnt->font);
+ }
+ must_free((char *)CDR((SCM)ptr), sizeof(struct xs_Font));
+ return sizeof(struct xs_Font);
+}
+
+SCM make_xvisual(vsl)
+ Visual *vsl;
+{
+ SCM s_vsl;
+ NEWCELL(s_vsl);
+ DEFER_INTS;
+ CAR(s_vsl) = tc16_xvisual;
+ SETCDR(s_vsl, vsl);
+ ALLOW_INTS;
+ return s_vsl;
+}
+
+SCM make_xevent(e)
+XEvent *e;
+{
+ SCM w;
+ XEvent *ec;
+
+ ec = (XEvent *) must_malloc(sizeof(XEvent), "X event");
+ (void)memcpy(ec, e, sizeof(XEvent));
+ NEWCELL(w);
+ DEFER_INTS;
+ CAR(w) = tc16_xevent;
+ SETCDR(w,ec);
+ ALLOW_INTS;
+ return w;
+}
+sizet x_free_xevent(ptr)
+ CELLPTR ptr;
+{
+ must_free(CHARS(ptr), sizeof(XEvent));
+ return sizeof(XEvent);
+}
+
+/* Utility macro and functions for checking and coercing SCM arguments. */
+
+#define GET_NEXT_INT(result, args, err, rtn) \
+ ASSERT(NIMP(args) && CONSP(args) && INUMP(CAR(args)), args, err, rtn); \
+ result = INUM(CAR(args)); \
+ args = CDR(args);
+
+void scm2XPoint(signp, dat, ipr, pos, s_caller)
+ int signp;
+ SCM dat;
+ XPoint *ipr;
+ char *pos, *s_caller;
+{
+ SCM x, y;
+ if IMP(dat) badarg: wta(dat, pos, s_caller);
+ if CONSP(dat) {
+ if INUMP(CDR(dat)) {
+ x = CAR(dat);
+ y = CDR(dat);
+ }
+ else {
+ ASRTGO(2==ilength(dat), badarg);
+ x = CAR(dat);
+ y = CAR(CDR(dat));
+ }
+ }
+ else switch TYP7(dat) {
+ default: goto badarg;
+ case tc7_vector:
+ ASRTGO(2==LENGTH(dat), badarg);
+ x = VELTS(dat)[0];
+ y = VELTS(dat)[1];
+ break;
+ case tc7_uvect: case tc7_ivect:
+ ASRTGO(2==LENGTH(dat), badarg);
+ x = MAKINUM(((long *)VELTS(dat))[0]);
+ y = MAKINUM(((long *)VELTS(dat))[1]);
+ break;
+ case tc7_svect:
+ ASRTGO(2==LENGTH(dat), badarg);
+ x = MAKINUM(((short *)VELTS(dat))[0]);
+ y = MAKINUM(((short *)VELTS(dat))[1]);
+ break;
+ case tc7_smob:
+ ASRTGO(ARRAYP(dat) && 1==ARRAY_NDIM(dat) &&
+ 0==ARRAY_DIMS(dat)[0].lbnd && 1==ARRAY_DIMS(dat)[0].ubnd,
+ badarg);
+ x = aref(dat, MAKINUM(0));
+ y = aref(dat, MAKINUM(1));
+ break;
+ }
+ ASRTGO(INUMP(x) && INUMP(y), badarg);
+ ipr->x = INUM(x);
+ ipr->y = INUM(y);
+ ASRTGO((ipr->x==INUM(x)) && (ipr->y==INUM(y))
+ && (signp ? !0 : ((x >= 0) && (y >= 0))), badarg);
+}
+int scm2XColor(s_dat, xclr)
+ SCM s_dat;
+ XColor *xclr;
+{
+ SCM dat = s_dat;
+ unsigned int ura[3];
+ int idx;
+/* if INUMP(dat) { */
+/* xclr->red = (dat>>16 & 0x00ff) * 0x0101; */
+/* xclr->green = (dat>>8 & 0x00ff) * 0x0101; */
+/* xclr->blue = (dat & 0x00ff) * 0x0101; */
+/* } */
+/* else */
+ if IMP(dat) return 0;
+ else if (3==ilength(dat))
+ for (idx = 0; idx < 3; idx++) {
+ SCM clr = CAR(dat);
+ if (!INUMP(clr)) return 0;
+ ura[idx] = INUM(clr);
+ dat = CDR(dat);
+ }
+ else if (VECTORP(dat) && (3==LENGTH(dat)))
+ for (idx = 0; idx < 3; idx++) {
+ if (!INUMP(VELTS(dat)[idx])) return 0;
+ ura[idx] = INUM(VELTS(dat)[idx]);
+ }
+ else return 0;
+ xclr->red = ura[0];
+ xclr->green = ura[1];
+ xclr->blue = ura[2];
+ return !0;
+}
+int scm2xpointslen(sara, s_caller)
+ SCM sara;
+ char *s_caller;
+{
+ array_dim *adm;
+ int len;
+ if (!(NIMP(sara) && ARRAYP(sara) && 2==ARRAY_NDIM(sara))) return -1;
+ adm = ARRAY_DIMS(sara);
+ if (!((1==(adm[1].ubnd - adm[1].lbnd))
+ && (1==adm[1].inc)
+ && ARRAY_CONTP(sara)
+ && (tc7_svect==TYP7(ARRAY_V(sara))))) return -1;
+ len = adm[0].ubnd - adm[0].lbnd;
+ if (len < 0) return 0;
+ return len;
+}
+void scm2display_screen(dat, optidx, dspscn, s_caller)
+ SCM dat;
+ SCM optidx;
+ struct display_screen *dspscn;
+ char *s_caller;
+{
+ ASRTGO(NIMP(dat), badarg);
+ if OPDISPLAYP(dat) {
+ dspscn->display = dat;
+ dspscn->dpy = XDISPLAY(dat);
+ if UNBNDP(optidx) dspscn->screen_number = DefaultScreen(dspscn->dpy);
+ else if (INUMP(optidx) && (INUM(optidx) < DISPLAY(dat)->screen_count))
+ dspscn->screen_number = INUM(optidx);
+ else wta(optidx, (char *)ARG2, s_caller);
+ }
+ else if OPWINDOWP(dat) {
+ struct xs_Window *xsw = WINDOW(dat);
+ dspscn->display = xsw->display;
+ dspscn->dpy = xsw->dpy;
+ dspscn->screen_number = xsw->screen_number;
+ ASRTGO(UNBNDP(optidx), badarg);
+ }
+ else badarg: wta(dat, (char *)ARG1, s_caller);
+}
+
+#define OpPxmpMask (0xffff | OPN | PXMP)
+#define OpPxmp (tc16_xwindow | OPN | PXMP)
+
+SCM thevalue(obj)
+ SCM obj;
+{
+ if (NIMP(obj) && SYMBOLP(obj))
+ return ceval(obj, (SCM)EOL);
+ else return obj;
+}
+
+Pixmap thepxmap(obj, s_caller)
+ SCM obj;
+ char *s_caller;
+{
+ if (FALSEP(obj) || (INUM0==obj)) return 0L;
+ ASSERT(NIMP(obj) && ((OpPxmpMask & (int)CAR(obj))==OpPxmp),
+ obj, ARGn, s_caller);
+ return WINDOW(obj)->p.pm;
+}
+Font thefont(obj, s_caller)
+ SCM obj;
+ char *s_caller;
+{
+ ASSERT(NIMP(obj) && FONTP(obj), obj, ARGn, s_caller);
+ return FONT(obj)->font;
+}
+Colormap thecmap(obj, s_caller)
+ SCM obj;
+ char *s_caller;
+{
+ if (FALSEP(obj) || (INUM0==obj)) return 0L;
+ ASSERT(NIMP(obj) && COLORMAPP(obj), obj, ARGn, s_caller);
+ return COLORMAP(obj)->cm;
+}
+Cursor thecsr(obj, s_caller)
+ SCM obj;
+ char *s_caller;
+{
+ if (FALSEP(obj) || (INUM0==obj)) return 0L;
+ ASSERT(NIMP(obj) && CURSORP(obj), obj, ARGn, s_caller);
+ return CURSOR(obj)->cursor;
+}
+Bool thebool(obj, s_caller)
+ SCM obj;
+ char *s_caller;
+{
+ SCM val = thevalue(obj);
+ ASSERT(BOOL_F==val || BOOL_T==val, obj, ARGn, s_caller);
+ return NFALSEP(val);
+}
+int theint(obj, s_caller)
+ SCM obj;
+ char *s_caller;
+{
+ SCM val = thevalue(obj);
+ ASSERT(INUMP(val), obj, ARGn, s_caller);
+ return INUM(val);
+}
+int theuint(obj, s_caller)
+ SCM obj;
+ char *s_caller;
+{
+ SCM val = thevalue(obj);
+ ASSERT(INUMP(val) && (0 <= INUM(val)), obj, ARGn, s_caller);
+ return INUM(val);
+}
+
+static int args2xgcvalmask(oargs)
+ SCM oargs;
+{
+ SCM args = oargs;
+ int attr, len, attr_mask = 0;
+ if (!(len = ilength(args))) return 0;
+ while (len) {
+ ASSERT(NIMP(args), oargs, WNA, s_gc);
+ attr = theint(CAR(args), s_gc); args = CDR(args);
+ attr_mask |= attr;
+ len -= 1;
+ }
+ return attr_mask;
+}
+static int args2xgcvalues(sgc, vlu, oargs)
+ SCM sgc;
+ XGCValues *vlu;
+ SCM oargs;
+{
+ struct xs_GContext *xgc = GCONTEXT(sgc);
+ SCM sval, args = oargs;
+ int attr, len, attr_mask = 0;
+/* (void)memset((char *)vlu, 0, sizeof(XGCValues)); */
+ if (!(len = ilength(args))) return 0;
+ ASSERT(len > 0 && (! (len & 1)), oargs, WNA, s_gc);
+ while (len) {
+ ASSERT(NIMP(args), oargs, WNA, s_gc);
+ attr = theint(CAR(args), s_gc); args = CDR(args);
+ ASSERT(NIMP(args), oargs, WNA, s_gc);
+ sval = CAR(args); args = CDR(args);
+ attr_mask |= attr;
+ switch (attr) {
+
+ case GCFunction: vlu->function = theint(sval, s_gc); break;
+ case GCPlaneMask: vlu->plane_mask = theuint(sval, s_gc); break;
+ case GCForeground: vlu->foreground = theuint(sval, s_gc); break;
+ case GCBackground: vlu->background = theuint(sval, s_gc); break;
+ case GCLineWidth: vlu->line_width = theint(sval, s_gc); break;
+ case GCLineStyle: vlu->line_style = theint(sval, s_gc); break;
+ case GCCapStyle: vlu->cap_style = theint(sval, s_gc); break;
+ case GCJoinStyle: vlu->join_style = theint(sval, s_gc); break;
+ case GCFillStyle: vlu->fill_style = theint(sval, s_gc); break;
+ case GCFillRule: vlu->fill_rule = theint(sval, s_gc); break;
+ case GCTile: vlu->tile = thepxmap(sval, s_gc);
+ xgc->tile = sval;
+ break;
+ case GCStipple: vlu->stipple = thepxmap(sval, s_gc);
+ xgc->stipple = sval;
+ break;
+ case GCTileStipXOrigin: vlu->ts_x_origin = theint(sval, s_gc); break;
+ case GCTileStipYOrigin: vlu->ts_y_origin = theint(sval, s_gc); break;
+ case (GCTileStipXOrigin | GCTileStipYOrigin): {
+ XPoint position;
+ scm2XPoint(!0, sval, &position, (char *)ARGn, s_gc);
+ vlu->ts_x_origin = position.x;
+ vlu->ts_y_origin = position.y;
+ } break;
+ case GCFont: vlu->font = thefont(sval, s_gc);
+ xgc->font = sval;
+ break;
+ case GCSubwindowMode: vlu->subwindow_mode = theint(sval, s_gc); break;
+ case GCGraphicsExposures: vlu->graphics_exposures = thebool(sval, s_gc); break;
+ case GCClipXOrigin: vlu->clip_x_origin = theint(sval, s_gc); break;
+ case GCClipYOrigin: vlu->clip_y_origin = theint(sval, s_gc); break;
+ case (GCClipXOrigin | GCClipYOrigin): {
+ XPoint position;
+ scm2XPoint(!0, sval, &position, (char *)ARGn, s_gc);
+ vlu->clip_x_origin = position.x;
+ vlu->clip_y_origin = position.y;
+ } break;
+ case GCClipMask: vlu->clip_mask = thepxmap(sval, s_gc);
+ xgc->clipmask = sval;
+ break;
+ case GCDashOffset: vlu->dash_offset = theint(sval, s_gc); break;
+ case GCDashList: vlu->dashes = (char)theint(sval, s_gc); break;
+ case GCArcMode: vlu->arc_mode = theint(sval, s_gc); break;
+
+ default: ASSERT(0, MAKINUM(attr), ARGn, s_gc);
+ }
+ len -= 2;
+ }
+ return attr_mask;
+}
+static int args2winattribs(vlu, oargs)
+ XSetWindowAttributes *vlu;
+ SCM oargs;
+{
+ SCM sval, args = oargs;
+ int attr, len, attr_mask = 0;
+ /* (void)memset((char *)vlu, 0, sizeof(XSetWindowAttributes)); */
+ if (!(len = ilength(args))) return 0;
+ ASSERT(len > 0 && (! (len & 1)), oargs, WNA, s_window);
+ while (len) {
+ ASSERT(NIMP(args), oargs, WNA, s_window);
+ attr = theint(CAR(args), s_window); args = CDR(args);
+ ASSERT(NIMP(args), oargs, WNA, s_window);
+ sval = CAR(args); args = CDR(args);
+ attr_mask |= attr;
+ switch (attr) {
+
+ case CWBackPixmap: vlu->background_pixmap=thepxmap(sval, s_window); break;
+ case CWBackPixel: vlu->background_pixel = theuint(sval, s_window); break;
+ case CWBorderPixmap:vlu->border_pixmap =thepxmap(sval, s_window); break;
+ case CWBorderPixel: vlu->border_pixel = theuint(sval, s_window); break;
+ case CWBitGravity: vlu->bit_gravity = theint(sval, s_window); break;
+ case CWWinGravity: vlu->win_gravity = theint(sval, s_window); break;
+ case CWBackingStore:vlu->backing_store = theint(sval, s_window); break;
+ case CWBackingPlanes:vlu->backing_planes = theuint(sval, s_window); break;
+ case CWBackingPixel:vlu->backing_pixel = theuint(sval, s_window); break;
+ case CWOverrideRedirect:vlu->override_redirect =
+ thebool(sval, s_window); break;
+ case CWSaveUnder: vlu->save_under = thebool(sval, s_window); break;
+ case CWEventMask: vlu->event_mask = theint(sval, s_window); break;
+ case CWDontPropagate:vlu->do_not_propagate_mask =
+ thebool(sval, s_window); break;
+ case CWColormap: vlu->colormap = thecmap(sval, s_window); break;
+ case CWCursor: vlu->cursor = thecsr(sval, s_window); break;
+
+ default: ASSERT(0, MAKINUM(attr), ARGn, s_window);
+ }
+ len -= 2;
+ }
+ return attr_mask;
+}
+
+ /* Scheme-visible procedures */
+
+SCM x_open_display(dpy_name)
+ SCM dpy_name;
+{
+ Display *display;
+ if FALSEP(dpy_name) dpy_name = nullstr;
+ ASSERT(NIMP(dpy_name) && STRINGP(dpy_name), dpy_name, ARG1, s_x_open_display);
+ display = XOpenDisplay(CHARS(dpy_name));
+ return (display ? make_xdisplay(display) : BOOL_F);
+}
+SCM x_display_debug(sd, si)
+ SCM sd, si;
+{
+ int (*previous_after_function)();
+ struct display_screen dspscn;
+ scm2display_screen(sd, UNDEFINED, &dspscn, s_x_display_debug);
+ previous_after_function =
+ XSynchronize(dspscn.dpy, thebool(si, s_x_display_debug));
+ return UNSPECIFIED;
+}
+SCM x_default_screen(sdpy)
+ SCM sdpy;
+{
+ ASSERT(NIMP(sdpy) && OPDISPLAYP(sdpy), sdpy, ARG1, s_x_default_screen);
+ return MAKINUM(DefaultScreen(XDISPLAY(sdpy)));
+}
+
+SCM x_create_window(swin, spos, sargs)
+ SCM swin, spos, sargs;
+{
+ XPoint position, size;
+ unsigned int border_width;
+ Window window;
+ int len = ilength(sargs);
+
+ ASSERT(NIMP(swin) && OPWINDOWP(swin), swin, ARG1, s_x_create_window);
+ scm2XPoint(!0, spos, &position, (char *)ARG2, s_x_create_window);
+ scm2XPoint(0, CAR(sargs), &size, (char *)ARG3, s_x_create_window);
+ sargs = CDR(sargs);
+ GET_NEXT_INT(border_width, sargs, ARG4, s_x_create_window);
+ if (4==len) {
+ unsigned long border;
+ unsigned long background;
+ GET_NEXT_INT(border, sargs, ARG5, s_x_create_window);
+ GET_NEXT_INT(background, sargs, ARGn, s_x_create_window);
+ window = XCreateSimpleWindow(XWINDISPLAY(swin), XWINDOW(swin),
+ position.x, position.y, /* initial placement */
+ size.x, size.y,
+ border_width,
+ border, background); /* pixel values */
+ } else {
+ int depth;
+ unsigned int class;
+ SCM svis;
+ unsigned long valuemask;
+ XSetWindowAttributes attributes;
+ ASSERT(5 <= len, sargs, WNA, s_x_create_window);
+ GET_NEXT_INT(depth, sargs, ARG5, s_x_create_window);
+ GET_NEXT_INT(class, sargs, ARGn, s_x_create_window);
+ svis = CAR(sargs); sargs = CDR(sargs);
+ ASSERT(NIMP(svis) && VISUALP(svis), svis, ARGn, s_x_create_window);
+ valuemask = args2winattribs(&attributes, sargs);
+ window = XCreateWindow(XWINDISPLAY(swin), XWINDOW(swin),
+ position.x, position.y, /* initial placement */
+ size.x, size.y,
+ border_width,
+ depth,
+ class,
+ XVISUAL(svis),
+ valuemask,
+ &attributes);
+ }
+ return window ? make_xwindow(WINDOW(swin)->display,
+ WINDOW(swin)->screen_number,
+ window, (char) 0, (char) 0)
+ : BOOL_F;
+}
+SCM x_create_pixmap(obj, s_size, s_depth)
+ SCM obj, s_size, s_depth;
+{
+ unsigned int depth = INUM(s_depth);
+ SCM display;
+ Display *dpy;
+ int scn;
+ Drawable drawable;
+ Pixmap p;
+ XPoint size;
+ if IMP(obj) badarg1: wta(obj, (char *)ARG1, s_x_create_pixmap);
+ if OPDISPLAYP(obj) {
+ display = obj;
+ dpy = XDISPLAY(display);
+ scn = DefaultScreen(dpy);
+ drawable = RootWindow(dpy, scn);
+ }
+ else if OPWINDOWP(obj) {
+ display = WINDOW(obj)->display;
+ dpy = XDISPLAY(display);
+ scn = WINDOW(obj)->screen_number;
+ drawable = WINDOW(obj)->p.drbl;
+ }
+ else goto badarg1;
+ scm2XPoint(0, s_size, &size, (char *)ARG2, s_x_create_pixmap);
+ ASSERT(INUMP(s_depth) && depth >= 0, s_depth, ARG3, s_x_create_pixmap);
+ p = XCreatePixmap(dpy, drawable, size.x, size.y, depth);
+ return make_xwindow(display, scn, p, (char) 1, (char) 0);
+}
+SCM x_window_set(args)
+ SCM args;
+{
+ SCM swn;
+ struct xs_Window *xwn;
+ XSetWindowAttributes vlu;
+ unsigned long mask;
+
+ ASSERT(NIMP(args), args, WNA, s_x_window_set);
+ swn = CAR(args); args = CDR(args);
+ ASSERT(NIMP(swn) && WINDOWP(swn), swn, ARG1, s_x_window_set);
+ xwn = WINDOW(swn);
+ mask = args2winattribs(&vlu, args);
+ XChangeWindowAttributes(xwn->dpy, xwn->p.win, mask, &vlu);
+ return UNSPECIFIED;
+}
+
+SCM x_window_geometry(swin)
+ SCM swin;
+{
+ struct xs_Window *sxw;
+ Window root;
+ Status sts;
+ int x, y;
+ unsigned int w, h, border_width, depth;
+
+ ASSERT(NIMP(swin) && OPWINDOWP(swin), swin, ARG1, s_x_window_geometry);
+ sxw = WINDOW(swin);
+ sts = XGetGeometry(sxw->dpy, sxw->p.drbl, &root, &x, &y,
+ &w, &h, &border_width, &depth);
+ if (!sts) return BOOL_F;
+ return cons2(cons2(MAKINUM(x), MAKINUM(y), EOL),
+ cons2(MAKINUM(w), MAKINUM(h), EOL),
+ cons2(MAKINUM(border_width), MAKINUM(depth), EOL));
+}
+
+SCM x_close(obj)
+ SCM obj;
+{
+ ASSERT(NIMP(obj), obj, ARG1, s_x_close);
+ if WINDOWP(obj) {
+ Display *dpy;
+ ASSERT(!(CAR((SCM)obj) & SCROOT), obj, ARG1, s_x_close);
+ if CLOSEDP(obj) return UNSPECIFIED;
+ DEFER_INTS;
+ dpy = XWINDISPLAY(obj);
+ free_xwindow((CELLPTR)obj);
+ XFlush(dpy);
+ ALLOW_INTS;
+ } else {
+ ASSERT(DISPLAYP(obj), obj, ARG1, s_x_close);
+ DEFER_INTS;
+ free_xdisplay((CELLPTR)obj);
+ ALLOW_INTS;
+ }
+ return UNSPECIFIED;
+}
+SCM x_flush(sd, si)
+ SCM sd, si;
+{
+ struct display_screen dspscn;
+ if (NIMP(sd) && UNBNDP(si) && GCONTEXTP(sd)) {
+ dspscn.dpy = XGCONDISPLAY(sd);
+ XFlushGC(dspscn.dpy, XGCONTEXT(sd));
+ } else {
+ scm2display_screen(sd, si, &dspscn, s_x_flush);
+ XFlush(dspscn.dpy);
+ }
+ return UNSPECIFIED;
+}
+ /* Colormaps */
+
+SCM x_create_colormap(swin, s_vis, s_alloc)
+ SCM swin, s_vis, s_alloc;
+{
+ SCM alloc;
+ int allo;
+ struct xs_Window *sxw;
+ ASSERT(NIMP(swin) && WINDOWP(swin), swin, ARG1, s_x_create_colormap);
+ sxw = WINDOW(swin);
+ ASSERT(NIMP(s_vis) && VISUALP(s_vis), s_vis, ARG2, s_x_create_colormap);
+ alloc = thevalue(s_alloc);
+ allo = INUM(alloc);
+ ASSERT(INUMP(alloc) && (allo==AllocNone || allo==AllocAll),
+ s_alloc, ARG3, s_x_create_colormap);
+ return make_xcolormap(sxw->display,
+ XCreateColormap(sxw->dpy, sxw->p.win,
+ XVISUAL(s_vis), allo));
+}
+SCM x_recreate_colormap(s_cm)
+ SCM s_cm;
+{
+ struct xs_Colormap *sxw;
+ ASSERT(NIMP(s_cm) && COLORMAPP(s_cm), s_cm, ARG1, s_x_recreate_colormap);
+ sxw = COLORMAP(s_cm);
+ return make_xcolormap(sxw->display,
+ XCopyColormapAndFree(XDISPLAY(sxw->display), sxw->cm));
+}
+SCM x_install_colormap(s_cm, s_flg)
+ SCM s_cm, s_flg;
+{
+ struct xs_Colormap *xcm;
+ ASSERT(NIMP(s_cm) && COLORMAPP(s_cm), s_cm, ARG1, s_x_install_colormap);
+ if UNBNDP(s_flg) s_flg = BOOL_T;
+ xcm = COLORMAP(s_cm);
+ if FALSEP(s_flg) XUninstallColormap(XDISPLAY(xcm->display), xcm->cm);
+ XInstallColormap(XDISPLAY(xcm->display), xcm->cm);
+ return UNSPECIFIED;
+}
+ /* Colors in Colormap */
+
+SCM x_alloc_color_cells(scmap, spxls, sargs)
+ SCM scmap, spxls, sargs;
+{
+ XColor xclr;
+ Status sts;
+ struct xs_Colormap *xcm;
+ Bool contig = 0;
+ SCM pxra, plra;
+ unsigned int npixels, nplanes;
+ ASSERT(NIMP(scmap) && COLORMAPP(scmap), scmap, ARG1, s_x_alloc_color_cells);
+ xcm = COLORMAP(scmap);
+ npixels = INUM(spxls);
+ ASSERT(INUMP(spxls) && npixels > 0, spxls, ARG2, s_x_alloc_color_cells);
+ pxra = make_uve(npixels, MOST_POSITIVE_FIXNUM); /* Uniform vector of long */
+ switch (ilength(sargs) + 2) {
+ default: wta(sargs, (char *)WNA, s_x_alloc_color_cells);
+ case 3: case 4:
+ if (scm2XColor(CAR(sargs), &xclr)) {
+ unsigned long rmask_return, gmask_return, bmask_return;
+ sargs = CDR(sargs);
+ if NNULLP(sargs) contig = thebool(CAR(sargs), s_x_alloc_color_cells);
+ sts = XAllocColorPlanes(xcm->dpy, xcm->cm, contig,
+ VELTS(pxra), npixels,
+ xclr.red, xclr.green, xclr.blue,
+ &rmask_return, &gmask_return, &bmask_return);
+ if (!sts) return BOOL_F;
+ return cons2(pxra, MAKINUM(rmask_return),
+ cons2(MAKINUM(gmask_return),
+ MAKINUM(bmask_return), EOL));
+ }
+ nplanes = theuint(CAR(sargs), s_x_alloc_color_cells);
+ sargs = CDR(sargs);
+ if NNULLP(sargs) contig = thebool(CAR(sargs), s_x_alloc_color_cells);
+ plra = make_uve(nplanes, MOST_POSITIVE_FIXNUM); /* Uniform vector of long */
+ sts = XAllocColorCells(xcm->dpy, xcm->cm, contig,
+ VELTS(plra), nplanes, VELTS(pxra), npixels);
+ if (!sts) return BOOL_F;
+ return cons2(pxra, plra, EOL);
+ }
+}
+SCM x_free_color_cells(scmap, spxls, sargs)
+ SCM scmap, spxls, sargs;
+{
+ struct xs_Colormap *xcm;
+ unsigned int planes = 0;
+ ASSERT(NIMP(scmap) && COLORMAPP(scmap), scmap, ARG1, s_x_free_color_cells);
+ xcm = COLORMAP(scmap);
+ ASSERT(NIMP(spxls) && (TYP7(spxls)==tc7_uvect), spxls, ARG2,
+ s_x_free_color_cells);
+ switch (ilength(sargs) + 2) {
+ default: wta(sargs, (char *)WNA, s_x_free_color_cells);
+ case 4:
+ planes = theuint(CAR(sargs), s_x_free_color_cells);
+ case 3:
+ XFreeColors(xcm->dpy, xcm->cm, VELTS(spxls), INUM(spxls), planes);
+ return UNSPECIFIED;
+ }
+}
+
+SCM x_find_color(scmap, dat)
+ SCM scmap, dat;
+{
+ XColor xclr;
+ struct xs_Colormap *xcm;
+ (void)memset((char *)&xclr, 0, sizeof(xclr));
+ ASSERT(NIMP(scmap) && COLORMAPP(scmap), scmap, ARG1, s_x_find_color);
+ xcm = COLORMAP(scmap);
+ if (!scm2XColor(dat, &xclr)) {
+ ASSERT(NIMP(dat) && STRINGP(dat), dat, (char*)ARG2, s_x_find_color);
+ if (XAllocNamedColor(xcm->dpy, xcm->cm, CHARS(dat), &xclr, &xclr))
+ return MAKINUM(xclr.pixel);
+ else return BOOL_F;
+ }
+ if (XAllocColor(xcm->dpy, xcm->cm, &xclr))
+ return MAKINUM(xclr.pixel);
+ else return BOOL_F;
+}
+SCM x_color_set(scmap, s_pix, dat)
+ SCM scmap, s_pix, dat;
+{
+ XColor xclr;
+ struct xs_Colormap *xcm;
+ (void)memset((char *)&xclr, 0, sizeof(xclr));
+ ASSERT(NIMP(scmap) && COLORMAPP(scmap), scmap, ARG1, s_x_color_set);
+ ASSERT(INUMP(s_pix), s_pix, ARG2, s_x_color_set);
+ xcm = COLORMAP(scmap);
+ xclr.pixel = INUM(s_pix);
+ xclr.flags = DoRed | DoGreen | DoBlue;
+ if (!scm2XColor(dat, &xclr)) {
+ ASSERT(NIMP(dat) && STRINGP(dat), dat, (char*)ARG3, s_x_color_set);
+ XStoreNamedColor(xcm->dpy, xcm->cm, CHARS(dat), xclr.pixel, xclr.flags);
+ }
+ else XStoreColor(xcm->dpy, xcm->cm, &xclr);
+ return UNSPECIFIED;
+}
+SCM x_color_ref(scmap, sidx)
+ SCM scmap, sidx;
+{
+ XColor xclr;
+ struct xs_Colormap *xcm;
+ (void)memset((char *)&xclr, 0, sizeof(xclr));
+ ASSERT(NIMP(scmap) && COLORMAPP(scmap), scmap, ARG1, s_x_color_ref);
+ xcm = COLORMAP(scmap);
+ ASSERT(INUMP(sidx), sidx, (char*)ARG2, s_x_color_ref);
+ xclr.pixel = INUM(sidx);
+ XQueryColor(xcm->dpy, xcm->cm, &xclr);
+ if (xclr.flags==(DoRed | DoGreen | DoBlue))
+ return cons2(MAKINUM(xclr.red), MAKINUM(xclr.green),
+ cons(MAKINUM(xclr.blue), EOL));
+ else return BOOL_F;
+}
+
+ /* Window Mapping */
+
+SCM x_map_window(swin)
+ SCM swin;
+{
+ struct xs_Window *w;
+ ASSERT(NIMP(swin) && WINDOWP(swin), swin, ARG1, s_x_map_window);
+ w = WINDOW(swin);
+ XMapWindow(w->dpy, w->p.win);
+ return UNSPECIFIED;
+}
+SCM x_map_raised(swin)
+ SCM swin;
+{
+ struct xs_Window *w;
+ ASSERT(NIMP(swin) && WINDOWP(swin), swin, ARG1, s_x_map_raised);
+ w = WINDOW(swin);
+ XMapRaised(w->dpy, w->p.win);
+ return UNSPECIFIED;
+}
+SCM x_map_subwindows(swin)
+ SCM swin;
+{
+ struct xs_Window *w;
+ ASSERT(NIMP(swin) && WINDOWP(swin), swin, ARG1, s_x_map_subwindows);
+ w = WINDOW(swin);
+ XMapSubwindows(w->dpy, w->p.win);
+ return UNSPECIFIED;
+}
+SCM x_unmap_window(swin)
+ SCM swin;
+{
+ struct xs_Window *w;
+ ASSERT(NIMP(swin) && WINDOWP(swin), swin, ARG1, s_x_unmap_window);
+ w = WINDOW(swin);
+ XUnmapWindow(w->dpy, w->p.win);
+ return UNSPECIFIED;
+}
+SCM x_unmap_subwindows(swin)
+ SCM swin;
+{
+ struct xs_Window *w;
+ ASSERT(NIMP(swin) && WINDOWP(swin), swin, ARG1, s_x_unmap_subwindows);
+ w = WINDOW(swin);
+ XUnmapSubwindows(w->dpy, w->p.win);
+ return UNSPECIFIED;
+}
+
+SCM x_create_gc(args)
+ SCM args;
+{
+ SCM swin;
+ struct xs_Window *xsw;
+ struct xs_GContext *xgc;
+ XGCValues v;
+ unsigned long mask;
+ SCM ans;
+
+ ASSERT(NIMP(args), args, WNA, s_x_create_gc);
+ swin = CAR(args); args = CDR(args);
+ ASSERT(NIMP(swin) && WINDOWP(swin), swin, ARG1, s_x_create_gc);
+ xsw = WINDOW(swin);
+ ans = make_xgcontext(xsw->display, xsw->screen_number,
+ XCreateGC(xsw->dpy, xsw->p.drbl, 0L, &v), 0);
+ xgc = GCONTEXT(ans);
+ mask = args2xgcvalues(ans, &v, args);
+ XChangeGC(xgc->dpy, xgc->gc, mask, &v);
+ return ans;
+}
+SCM x_gc_set(args)
+ SCM args;
+{
+ SCM sgc;
+ struct xs_GContext *xgc;
+ XGCValues v;
+ unsigned long mask;
+
+ ASSERT(NIMP(args), args, WNA, s_x_gc_set);
+ sgc = CAR(args); args = CDR(args);
+ ASSERT(NIMP(sgc) && GCONTEXTP(sgc), sgc, ARG1, s_x_gc_set);
+ xgc = GCONTEXT(sgc);
+ mask = args2xgcvalues(sgc, &v, args);
+ XChangeGC(xgc->dpy, xgc->gc, mask, &v);
+ return UNSPECIFIED;
+}
+SCM x_copy_gc(dst, src, args)
+ SCM dst;
+ SCM src;
+ SCM args;
+{
+ struct xs_GContext *dgc, *sgc;
+ unsigned long mask;
+
+ ASSERT(NIMP(dst) && GCONTEXTP(dst), dst, ARG1, s_x_copy_gc);
+ ASSERT(NIMP(src) && GCONTEXTP(src), src, ARG2, s_x_copy_gc);
+ dgc = GCONTEXT(dst);
+ sgc = GCONTEXT(src);
+ mask = args2xgcvalmask(args);
+ XCopyGC(dgc->dpy, sgc->gc, mask, dgc->gc);
+ return UNSPECIFIED;
+}
+SCM x_gc_ref(oargs)
+ SCM oargs;
+{
+ SCM sgc, args = oargs, sval = BOOL_F;
+ SCM vals = cons(BOOL_T, EOL), valend = vals;
+ struct xs_GContext *xgc;
+ unsigned long valuemask;
+ XGCValues vlu;
+ int attr, len = ilength(args);
+/* (void)memset((char *)&vlu, 0, sizeof(XGCValues)); */
+ ASSERT(len > 0, oargs, WNA, s_x_gc_ref);
+ if (1==len--) return EOL;
+ sgc = CAR(args); args = CDR(args);
+ xgc = GCONTEXT(sgc);
+ valuemask = args2xgcvalmask(args);
+/* printf("valuemask = %lx\n", valuemask); */
+ valuemask &= (GCFunction | GCPlaneMask | GCForeground | GCBackground |
+ GCLineWidth | GCLineStyle | GCCapStyle | GCJoinStyle |
+ GCFillStyle | GCFillRule |
+ GCTileStipXOrigin | GCTileStipYOrigin |
+ GCSubwindowMode | GCGraphicsExposures |
+ GCClipXOrigin | GCClipYOrigin | GCDashOffset | GCArcMode);
+ if (!XGetGCValues(xgc->dpy, xgc->gc, valuemask, &vlu)) return BOOL_F;
+ while (len) {
+ attr = theint(CAR(args), s_gc); args = CDR(args);
+ switch (attr) {
+
+ case GCFunction: sval = MAKINUM(vlu.function ); break;
+ case GCPlaneMask: sval = MAKINUM(vlu.plane_mask); break;
+ case GCForeground: sval = MAKINUM(vlu.foreground); break;
+ case GCBackground: sval = MAKINUM(vlu.background); break;
+ case GCLineWidth: sval = MAKINUM(vlu.line_width); break;
+ case GCLineStyle: sval = MAKINUM(vlu.line_style); break;
+ case GCCapStyle: sval = MAKINUM(vlu.cap_style ); break;
+ case GCJoinStyle: sval = MAKINUM(vlu.join_style); break;
+ case GCFillStyle: sval = MAKINUM(vlu.fill_style); break;
+ case GCFillRule: sval = MAKINUM(vlu.fill_rule ); break;
+ case GCTile: sval = xgc->tile; break;
+ case GCStipple: sval = xgc->stipple; break;
+ case GCTileStipXOrigin: sval = MAKINUM(vlu.ts_x_origin); break;
+ case GCTileStipYOrigin: sval = MAKINUM(vlu.ts_y_origin); break;
+ case (GCTileStipXOrigin | GCTileStipYOrigin):
+ sval = cons2(MAKINUM(vlu.ts_x_origin), MAKINUM(vlu.ts_y_origin), EOL);
+ break;
+ case GCFont: sval = xgc->font; break;
+ case GCSubwindowMode: sval = MAKINUM(vlu.subwindow_mode); break;
+ case GCGraphicsExposures:
+ sval = x_make_bool(vlu.graphics_exposures); break;
+ case GCClipXOrigin: sval = MAKINUM(vlu.clip_x_origin); break;
+ case GCClipYOrigin: sval = MAKINUM(vlu.clip_y_origin); break;
+ case (GCClipXOrigin | GCClipYOrigin):
+ sval = cons2(MAKINUM(vlu.clip_x_origin),
+ MAKINUM(vlu.clip_y_origin), EOL);
+ break;
+ case GCClipMask: sval = xgc->clipmask; break;
+ case GCDashOffset: sval = MAKINUM(vlu.dash_offset); break;
+ case GCDashList: sval = MAKINUM(vlu.dashes); break;
+ case GCArcMode: sval = MAKINUM(vlu.arc_mode); break;
+
+ default: ASSERT(0, MAKINUM(attr), ARGn, s_x_gc_ref);
+ }
+ CAR(valend) = sval;
+ CDR(valend) = cons(BOOL_T, EOL);
+ valend = CDR(valend);
+ len -= 1;
+ }
+ return vals;
+}
+
+SCM x_create_cursor(sdpy, scsr, sargs)
+ SCM sdpy, scsr, sargs;
+{
+ Cursor cursor;
+
+ switch (ilength(sargs)) {
+ default: ASSERT(0, sargs, WNA, s_x_create_cursor);
+ case 0: {
+ SCM shape;
+ ASSERT(NIMP(sdpy) && DISPLAYP(sdpy), sdpy, ARG1, s_x_create_cursor);
+ shape = thevalue(scsr);
+ ASSERT(INUMP(shape) && 0 <= INUM(shape), scsr, ARG2, s_x_create_cursor);
+ cursor = XCreateFontCursor(XDISPLAY(sdpy), INUM(shape));
+ return make_xcursor(sdpy, cursor);
+ }
+ case 3: {
+ XColor foreground_color, background_color;
+ XPoint origin;
+ int sts;
+ ASSERT(NIMP(sdpy) && WINDOWP(sdpy), sdpy, ARG1, s_x_create_cursor);
+ ASSERT(FALSEP(scsr) || (NIMP(scsr) && WINDOWP(scsr)), scsr, ARG2,
+ s_x_create_cursor);
+ sts = scm2XColor(CAR(sargs), &foreground_color);
+ ASSERT(sts, CAR(sargs), ARG3, s_x_create_cursor);
+ sargs = CDR(sargs);
+ sts = scm2XColor(CAR(sargs), &background_color);
+ ASSERT(sts, CAR(sargs), ARG4, s_x_create_cursor);
+ sargs = CDR(sargs);
+ scm2XPoint(0, CAR(sargs), &origin, (char*)ARG5, s_x_create_cursor);
+ cursor = XCreatePixmapCursor(XWINDISPLAY(sdpy), XWINDOW(sdpy),
+ FALSEP(scsr) ? 0L : XWINDOW(scsr),
+ &foreground_color, &background_color,
+ origin.x, origin.y);
+ return make_xcursor(WINDOW(sdpy)->display, cursor);
+ }
+ case 4: {
+ XColor foreground_color, background_color;
+ Font source_font, mask_font = 0;
+ unsigned int source_char, mask_char = 0;
+ int sts;
+ source_font = thefont(sdpy, s_x_create_cursor);
+ GET_NEXT_INT(source_char, sargs, ARG2, s_x_create_cursor);
+ if FALSEP(CAR(sargs)) {
+ sargs = CDR(sargs);
+ ASSERT(FALSEP(CAR(sargs)), sargs, ARG4, s_x_create_cursor);
+ sargs = CDR(sargs);
+ } else {
+ mask_font = thefont(CAR(sargs), s_x_create_cursor);
+ sargs = CDR(sargs);
+ GET_NEXT_INT(mask_char, sargs, ARG4, s_x_create_cursor);
+ }
+ sts = scm2XColor(CAR(sargs), &foreground_color);
+ ASSERT(sts, CAR(sargs), ARG5, s_x_create_cursor);
+ sargs = CDR(sargs);
+ sts = scm2XColor(CAR(sargs), &background_color);
+ ASSERT(sts, CAR(sargs), ARGn, s_x_create_cursor);
+ cursor = XCreateGlyphCursor(XWINDISPLAY(sdpy),
+ source_font, mask_font, source_char, mask_char,
+ &foreground_color, &background_color);
+ return make_xcursor(FONT(sdpy)->display, cursor);
+ }}
+}
+
+SCM x_load_font(sdpy, fntnam)
+ SCM sdpy, fntnam;
+{
+ Font font;
+
+ ASSERT(NIMP(sdpy) && DISPLAYP(sdpy), sdpy, ARG1, s_x_load_font);
+ ASSERT(NIMP(fntnam) && STRINGP(fntnam), fntnam, ARG2, s_x_load_font);
+ font = XLoadFont(XDISPLAY(sdpy), CHARS(fntnam));
+ return make_xfont(sdpy, font, fntnam);
+}
+
+ /* Xlib information functions. */
+
+SCM x_protocol_version(sd, si)
+ SCM sd, si;
+{
+ struct display_screen dspscn;
+ scm2display_screen(sd, si, &dspscn, s_x_protocol_version);
+ return cons(MAKINUM(ProtocolVersion(dspscn.dpy)),
+ MAKINUM(ProtocolRevision(dspscn.dpy)));
+}
+SCM x_server_vendor(sd, si)
+ SCM sd, si;
+{
+ struct display_screen dspscn;
+ scm2display_screen(sd, si, &dspscn, s_x_server_vendor);
+ return makfrom0str(ServerVendor(dspscn.dpy));
+}
+SCM x_vendor_release(sd, si)
+ SCM sd, si;
+{
+ struct display_screen dspscn;
+ scm2display_screen(sd, si, &dspscn, s_x_vendor_release);
+ return MAKINUM(VendorRelease(dspscn.dpy));
+}
+int x_scm_error_handler(display, xee)
+ Display *display;
+ XErrorEvent *xee;
+{
+ char buffer_return[1024];
+ fflush(stdout);
+ XGetErrorText(display, xee->error_code, buffer_return, sizeof buffer_return);
+ *loc_errobj = MAKINUM((xee->request_code<<8) + xee->minor_code);
+ fputs(buffer_return, stderr);
+ fputc('\n', stderr);
+ fflush(stderr);
+ return 0;
+}
+SCM x_q_length(sd, si)
+ SCM sd, si;
+{
+ struct display_screen dspscn;
+ scm2display_screen(sd, si, &dspscn, s_x_q_length);
+ return MAKINUM(QLength(dspscn.dpy));
+}
+SCM x_pending(sd, si)
+ SCM sd, si;
+{
+ struct display_screen dspscn;
+ scm2display_screen(sd, si, &dspscn, s_x_pending);
+ return MAKINUM(XPending(dspscn.dpy));
+}
+SCM x_events_queued(sd, si)
+ SCM sd, si;
+{
+ struct display_screen dspscn;
+ scm2display_screen(sd, si, &dspscn, s_x_events_queued);
+ return MAKINUM(XEventsQueued(dspscn.dpy, QueuedAfterReading));
+}
+SCM x_next_event(sd, si)
+ SCM sd, si;
+{
+ struct display_screen dspscn;
+ XEvent event_return;
+ scm2display_screen(sd, si, &dspscn, s_x_next_event);
+ XNextEvent(dspscn.dpy, &event_return);
+ return make_xevent(&event_return);
+}
+SCM x_peek_event(sd, si)
+ SCM sd, si;
+{
+ struct display_screen dspscn;
+ XEvent event_return;
+ scm2display_screen(sd, si, &dspscn, s_x_peek_event);
+ XPeekEvent(dspscn.dpy, &event_return);
+ return make_xevent(&event_return);
+}
+ /* Screen information functions */
+
+SCM x_screen_count(sd, si)
+ SCM sd, si;
+{
+ struct display_screen dspscn;
+ scm2display_screen(sd, si, &dspscn, s_x_screen_count);
+ return MAKINUM(ScreenCount(dspscn.dpy));
+}
+SCM x_screen_cells(sd, si)
+ SCM sd, si;
+{
+ struct display_screen dspscn;
+ scm2display_screen(sd, si, &dspscn, s_x_screen_cells);
+ return MAKINUM(DisplayCells(dspscn.dpy, dspscn.screen_number));
+}
+SCM x_screen_depth(sd, si)
+ SCM sd, si;
+{
+ struct display_screen dspscn;
+ scm2display_screen(sd, si, &dspscn, s_x_screen_depth);
+ return MAKINUM(DisplayPlanes(dspscn.dpy, dspscn.screen_number));
+}
+SCM x_screen_depths(sd, si)
+ SCM sd, si;
+{
+ int count_return = 0;
+ int *depths;
+ SCM depra;
+ struct display_screen dspscn;
+ scm2display_screen(sd, si, &dspscn, s_x_screen_depths);
+ depths = XListDepths(dspscn.dpy, dspscn.screen_number, &count_return);
+ if (!depths) return BOOL_F;
+ depra = make_uve(count_return, MOST_POSITIVE_FIXNUM); /* Uniform vector of long */
+ for (;count_return--;) VELTS(depra)[count_return] = depths[count_return];
+ XFree(depths);
+ return depra;
+}
+SCM x_screen_size(sd, si)
+ SCM sd, si;
+{
+ struct display_screen dspscn;
+ scm2display_screen(sd, si, &dspscn, s_x_screen_size);
+ return cons2(MAKINUM(DisplayWidth(dspscn.dpy, dspscn.screen_number)),
+ MAKINUM(DisplayHeight(dspscn.dpy, dspscn.screen_number)),
+ EOL);
+}
+SCM x_screen_dimm(sd, si)
+ SCM sd, si;
+{
+ struct display_screen dspscn;
+ scm2display_screen(sd, si, &dspscn, s_x_screen_dimm);
+ return cons2(MAKINUM(DisplayWidthMM(dspscn.dpy, dspscn.screen_number)),
+ MAKINUM(DisplayHeightMM(dspscn.dpy, dspscn.screen_number)),
+ EOL);
+}
+SCM x_screen_black(sd, si)
+ SCM sd, si;
+{
+ struct display_screen dspscn;
+ Screen *scn;
+ scm2display_screen(sd, si, &dspscn, s_x_screen_black);
+ scn = ScreenOfDisplay(dspscn.dpy, dspscn.screen_number);
+ return ulong2num(BlackPixelOfScreen(scn));
+}
+SCM x_screen_white(sd, si)
+ SCM sd, si;
+{
+ struct display_screen dspscn;
+ Screen *scn;
+ scm2display_screen(sd, si, &dspscn, s_x_screen_white);
+ scn = ScreenOfDisplay(dspscn.dpy, dspscn.screen_number);
+ return ulong2num(WhitePixelOfScreen(scn));
+}
+
+SCM x_make_visual(sd, sdepth, sclass)
+ SCM sd, sdepth, sclass;
+{
+ struct display_screen dspscn;
+ XVisualInfo vis;
+ Status sts;
+ scm2display_screen(sd, UNDEFINED, &dspscn, s_x_make_visual);
+ sts = XMatchVisualInfo(dspscn.dpy, dspscn.screen_number,
+ theuint(sdepth, s_x_make_visual),
+ theuint(sclass, s_x_make_visual),
+ &vis);
+ if (!sts) return BOOL_F;
+ return make_xvisual(vis.visual);
+}
+SCM x_root_window(sdpy, sscr)
+ SCM sdpy, sscr;
+{
+ struct display_screen dspscn;
+ struct xs_Display *xsd;
+ struct xs_screen *scrns;
+ scm2display_screen(sdpy, sscr, &dspscn, s_x_root_window);
+ xsd = DISPLAY(dspscn.display);
+ scrns = (struct xs_screen *)(xsd + 1);
+ return scrns[dspscn.screen_number].root_window;
+}
+SCM x_default_colormap(sdpy, sscr)
+ SCM sdpy, sscr;
+{
+ struct display_screen dspscn;
+ struct xs_Display *xsd;
+ struct xs_screen *scrns;
+ scm2display_screen(sdpy, sscr, &dspscn, s_x_default_colormap);
+ xsd = DISPLAY(dspscn.display);
+ scrns = (struct xs_screen *)(xsd + 1);
+ return scrns[dspscn.screen_number].default_colormap;
+}
+SCM x_default_gcontext(sdpy, sscr)
+ SCM sdpy, sscr;
+{
+ struct display_screen dspscn;
+ struct xs_Display *xsd;
+ struct xs_screen *scrns;
+ scm2display_screen(sdpy, sscr, &dspscn, s_x_default_gcontext);
+ xsd = DISPLAY(dspscn.display);
+ scrns = (struct xs_screen *)(xsd + 1);
+ return scrns[dspscn.screen_number].default_gcontext;
+}
+SCM x_default_visual(sdpy, sscr)
+ SCM sdpy, sscr;
+{
+ struct display_screen dspscn;
+ struct xs_Display *xsd;
+ struct xs_screen *scrns;
+ scm2display_screen(sdpy, sscr, &dspscn, s_x_default_visual);
+ xsd = DISPLAY(dspscn.display);
+ scrns = (struct xs_screen *)(xsd + 1);
+ return scrns[dspscn.screen_number].default_visual;
+}
+
+ /* Rendering */
+
+SCM x_clear_area(swin, spos, sargs)
+ SCM swin, spos, sargs;
+{
+ XPoint position, size;
+ ASSERT(2==ilength(sargs), sargs, WNA, s_x_clear_area);
+ ASSERT(NIMP(swin) && WINDOWP(swin), swin, ARG1, s_x_clear_area);
+ scm2XPoint(!0, spos, &position, (char *)ARG2, s_x_clear_area);
+ scm2XPoint(0, CAR(sargs), &size, (char *)ARG3, s_x_clear_area);
+ sargs = CDR(sargs);
+ XClearArea(XWINDISPLAY(swin), XWINDOW(swin),
+ position.x, position.y, size.x, size.y,
+ NFALSEP(CAR(sargs)));
+ return UNSPECIFIED;
+}
+SCM x_fill_rectangle(swin, sgc, sargs)
+ SCM swin, sgc, sargs;
+{
+ XPoint position, size;
+ ASSERT(2==ilength(sargs), sargs, WNA, s_x_fill_rectangle);
+ ASSERT(NIMP(swin) && WINDOWP(swin), swin, ARG1, s_x_fill_rectangle);
+ ASSERT(NIMP(sgc) && GCONTEXTP(sgc), sgc, ARG2, s_x_fill_rectangle);
+ scm2XPoint(!0, CAR(sargs), &position, (char *)ARG3, s_x_fill_rectangle);
+ sargs = CDR(sargs);
+ scm2XPoint(0, CAR(sargs), &size, (char *)ARG4, s_x_fill_rectangle);
+ XFillRectangle(XWINDISPLAY(swin), XWINDOW(swin), XGCONTEXT(sgc),
+ position.x, position.y, size.x, size.y);
+ return UNSPECIFIED;
+}
+
+void xldraw_string(sdbl, sgc, sargs, proc, s_caller)
+ SCM sdbl, sgc, sargs;
+ int (*proc)();
+ char *s_caller;
+{
+ XPoint position;
+ ASSERT(2==ilength(sargs), sargs, WNA, s_caller);
+ ASSERT(NIMP(sdbl) && WINDOWP(sdbl), sdbl, ARG1, s_caller);
+ ASSERT(NIMP(sgc) && GCONTEXTP(sgc), sgc, ARG2, s_caller);
+ scm2XPoint(!0, CAR(sargs), &position, (char *)ARG3, s_caller);
+ sargs = CDR(sargs);
+ sargs = CAR(sargs);
+ ASSERT(NIMP(sargs) && STRINGP(sargs), sargs, ARG4, s_caller);
+ proc(XWINDISPLAY(sdbl), XWINDOW(sdbl), XGCONTEXT(sgc),
+ position.x, position.y, CHARS(sargs), LENGTH(sargs));
+}
+SCM x_draw_string(sdbl, sgc, sargs)
+ SCM sdbl, sgc, sargs;
+{
+ xldraw_string(sdbl, sgc, sargs, &XDrawString, s_x_draw_string);
+ return UNSPECIFIED;
+}
+SCM x_image_string(sdbl, sgc, sargs)
+ SCM sdbl, sgc, sargs;
+{
+ xldraw_string(sdbl, sgc, sargs, &XDrawImageString, s_x_image_string);
+ return UNSPECIFIED;
+}
+
+SCM x_draw_points(sdbl, sgc, sargs)
+ SCM sdbl, sgc, sargs;
+{
+ XPoint pos[1];
+ int len;
+ SCM sarg;
+ ASSERT(NIMP(sdbl) && WINDOWP(sdbl), sdbl, ARG1, s_x_draw_points);
+ ASSERT(NIMP(sgc) && GCONTEXTP(sgc), sgc, ARG2, s_x_draw_points);
+ loop:
+ if NULLP(sargs) return UNSPECIFIED;
+ sarg = CAR(sargs); sargs = CDR(sargs);
+ if (INUMP(sarg)) {
+ ASSERT(NNULLP(sargs), sargs, WNA, s_x_draw_points);
+ pos[0].x = INUM(sarg);
+ GET_NEXT_INT(pos[0].y, sargs, ARGn, s_x_draw_points);
+ goto drawshort;
+ }
+ len = scm2xpointslen(sarg, s_x_draw_points);
+ if (len < 0) {
+ scm2XPoint(!0, sarg, &(pos[0]), (char *)ARG3, s_x_draw_points);
+ drawshort:
+ XDrawPoints(XWINDISPLAY(sdbl), XWINDOW(sdbl), XGCONTEXT(sgc),
+ &(pos[0]), 1, CoordModeOrigin);
+ goto loop;
+ } else {
+ ASSERT(NULLP(sargs), sargs, WNA, s_x_draw_points);
+ XDrawPoints(XWINDISPLAY(sdbl), XWINDOW(sdbl), XGCONTEXT(sgc),
+ (XPoint *)scm_base_addr(sarg, s_x_draw_points), len,
+ CoordModeOrigin);
+ return UNSPECIFIED;
+ }
+}
+SCM xldraw_lines(sdbl, sgc, sargs, funcod, s_caller)
+ SCM sdbl, sgc, sargs;
+ int funcod;
+ char *s_caller;
+{
+ XPoint pos[2];
+ int len;
+ SCM sarg;
+ ASSERT(NIMP(sdbl) && WINDOWP(sdbl), sdbl, ARG1, s_caller);
+ ASSERT(NIMP(sgc) && GCONTEXTP(sgc), sgc, ARG2, s_caller);
+ loop:
+ if NULLP(sargs) return UNSPECIFIED;
+ sarg = CAR(sargs); sargs = CDR(sargs);
+ if (INUMP(sarg)) {
+ ASSERT(NNULLP(sargs), sargs, WNA, s_caller);
+ pos[0].x = INUM(sarg);
+ GET_NEXT_INT(pos[0].y, sargs, ARGn, s_caller);
+ GET_NEXT_INT(pos[1].x, sargs, ARGn, s_caller);
+ GET_NEXT_INT(pos[1].y, sargs, ARGn, s_caller);
+ goto drawshort;
+ }
+ len = scm2xpointslen(sarg, s_caller);
+ if (len < 0) {
+ scm2XPoint(!0, sarg, &(pos[0]), (char *)ARG3, s_caller);
+ scm2XPoint(!0, sarg, &(pos[1]), (char *)ARG4, s_caller);
+ drawshort:
+ switch (funcod) {
+ default: wna: wta(sargs, (char *)WNA, s_caller);
+ case 0:
+ XDrawSegments(XWINDISPLAY(sdbl), XWINDOW(sdbl), XGCONTEXT(sgc),
+ (XSegment *) &(pos[0]), 1);
+ goto loop;
+ case 1:
+ XDrawLines(XWINDISPLAY(sdbl), XWINDOW(sdbl), XGCONTEXT(sgc),
+ &(pos[0]), 2, CoordModeOrigin);
+ goto loop;
+ }
+ } else {
+ unsigned long rabase;
+ ASRTGO(NULLP(sargs), wna);
+ rabase = scm_base_addr(sarg, s_caller);
+ switch (funcod) {
+ default: goto wna;
+ case 0:
+ XDrawSegments(XWINDISPLAY(sdbl), XWINDOW(sdbl), XGCONTEXT(sgc),
+ (XSegment *)rabase, len/2);
+ return UNSPECIFIED;
+ case 1:
+ XDrawLines(XWINDISPLAY(sdbl), XWINDOW(sdbl), XGCONTEXT(sgc),
+ (XPoint *)rabase, len, CoordModeOrigin);
+ return UNSPECIFIED;
+ case 2:
+ XFillPolygon(XWINDISPLAY(sdbl), XWINDOW(sdbl), XGCONTEXT(sgc),
+ (XPoint *)rabase, len, Complex, CoordModeOrigin);
+ return UNSPECIFIED;
+ }
+ }
+}
+
+SCM x_draw_segments(sdbl, sgc, sargs)
+ SCM sdbl, sgc, sargs;
+{
+ return xldraw_lines(sdbl, sgc, sargs, 0, s_x_draw_segments);
+}
+SCM x_draw_lines(sdbl, sgc, sargs)
+ SCM sdbl, sgc, sargs;
+{
+ return xldraw_lines(sdbl, sgc, sargs, 1, s_x_draw_lines);
+}
+SCM x_fill_poly(sdbl, sgc, sargs)
+ SCM sdbl, sgc, sargs;
+{
+ return xldraw_lines(sdbl, sgc, sargs, 2, s_x_fill_poly);
+}
+
+ /* XEvents */
+
+/* x_make_bool() is used in xevent.h */
+SCM x_make_bool(f)
+ Bool f;
+{
+ return f ? BOOL_F : BOOL_T;
+}
+
+SCM x_event_ref(sevent, sfield)
+ SCM sevent, sfield;
+{
+ void *x;
+ ASSERT(NIMP(sevent) && XEVENTP(sevent), sevent, ARG1, s_x_event_ref);
+ ASSERT(INUMP(sfield), sfield, ARG2, s_x_event_ref);
+ x = (void *) CHARS(sevent);
+ switch (((((XEvent*)x)->type)<<8)+INUM(sfield)) {
+ default: wta(sevent, "Incompatible field for", s_x_event_ref);
+#define SCM_EVENT_FIELDS
+#include "xevent.h"
+ }
+}
+
+static struct {
+ int type;
+ char *name;
+} event_names[] = {
+#undef SCM_EVENT_FIELDS
+#include "xevent.h"
+};
+
+static char *x__event_name(type)
+ int type;
+{
+ int i;
+ for (i = 0; i < sizeof(event_names) / sizeof(event_names[0]); i++)
+ if (type==event_names[i].type) return event_names[i].name;
+ return "unknown";
+}
+ /* SMOB print routines */
+
+static int print_xevent(exp, f, writing)
+ SCM exp;
+ SCM f;
+ int writing;
+{
+ lputs("#<X event: ", f);
+ lputs(x__event_name(XEVENT(exp)->type), f);
+ lputc('>', f);
+ return 1;
+}
+static int print_xdisplay(exp, f, writing)
+ SCM exp;
+ SCM f;
+ int writing;
+{
+ if CLOSEDP(exp) lputs("#<closed-X display>", f);
+ else {
+ lputs("#<X display \"", f);
+ lputs(DisplayString(XDISPLAY(exp)), f);
+ lputs("\">", f);
+ }
+ return 1;
+}
+static int print_xwindow(exp, f, writing)
+ SCM exp;
+ SCM f;
+ int writing;
+{
+ lputs(CLOSEDP(exp) ? "#<closed-X " : "#<X ", f);
+ lputs((CAR(exp) & PXMP) ? "pixmap #x" : "window #x", f);
+ intprint((long) XWINDOW(exp), 16, f);
+ lputc('>', f);
+ return 1;
+}
+static int print_xcursor(exp, f, writing)
+ SCM exp;
+ SCM f;
+ int writing;
+{
+ lputs("#<X cursor #x", f);
+ intprint((long) XCURSOR(exp), 16, f);
+ lputc('>', f);
+ return 1;
+}
+static int print_xfont(exp, f, writing)
+ SCM exp;
+ SCM f;
+ int writing;
+{
+ lputs("#<X font \"", f);
+ lputs(CHARS((FONT(exp))->name), f);
+ lputs("\">", f);
+ return 1;
+}
+static int print_xcolormap(exp, f, writing)
+ SCM exp;
+ SCM f;
+ int writing;
+{
+ lputs("#<X colormap ID #x", f);
+ intprint((long) XCOLORMAP(exp), 16, f);
+ lputc('>', f);
+ return 1;
+}
+static int print_xgcontext(exp, f, writing)
+ SCM exp;
+ SCM f;
+ int writing;
+{
+ lputs("#<X graphics context, ID #x", f);
+ /* intprint((long) GCONTEXT(exp)->gid, 16, f); skimu */
+ intprint((long) XGContextFromGC(XGCONTEXT(exp)), 16, f);
+ lputc('>', f);
+ return 1;
+}
+static int print_xvisual(exp, f, writing)
+ SCM exp;
+ SCM f;
+ int writing;
+{
+ lputs("#<X visual #x", f);
+ intprint((long) XVisualIDFromVisual(XVISUAL(exp)), 16, f);
+ lputc('>', f);
+ return 1;
+}
+
+static smobfuns smob_xdisplay = {mark_xdisplay, free_xdisplay, print_xdisplay, 0};
+static smobfuns smob_xwindow = {mark_xwindow, free_xwindow, print_xwindow, 0};
+static smobfuns smob_xcursor = {mark_xcursor, free_xcursor, print_xcursor, 0};
+static smobfuns smob_xfont = {mark_xfont, free_xfont, print_xfont, 0};
+static smobfuns smob_xgcontext = {mark_xgcontext, free_xgcontext, print_xgcontext, 0};
+static smobfuns smob_xcolormap = {mark_xcolormap, free_xcolormap, print_xcolormap, 0};
+static smobfuns smob_xvisual = {mark0, free0, print_xvisual, 0};
+static smobfuns smob_xevent = {mark0, x_free_xevent, print_xevent, 0};
+
+static iproc x_subr3s[] = {
+ {s_x_make_visual, x_make_visual},
+ {s_x_create_pixmap, x_create_pixmap},
+ {s_x_create_colormap, x_create_colormap},
+ {s_x_color_set, x_color_set},
+ {0, 0}
+};
+
+static iproc x_lsubr2s[] = {
+ {s_x_create_window, x_create_window},
+ {s_x_create_cursor, x_create_cursor},
+ {s_x_alloc_color_cells, x_alloc_color_cells},
+ {s_x_free_color_cells, x_free_color_cells},
+ {s_x_clear_area, x_clear_area},
+ {s_x_fill_rectangle, x_fill_rectangle},
+ {s_x_draw_string, x_draw_string},
+ {s_x_image_string, x_image_string},
+ {s_x_draw_points, x_draw_points},
+ {s_x_draw_segments, x_draw_segments},
+ {s_x_draw_lines, x_draw_lines},
+ {s_x_fill_poly, x_fill_poly},
+ {0, 0}
+};
+
+static iproc x_lsubrs[] = {
+ {s_x_create_gc, x_create_gc},
+ {s_x_gc_set, x_gc_set},
+ {s_x_gc_ref, x_gc_ref},
+ {s_x_copy_gc, x_copy_gc},
+ {s_x_window_set, x_window_set},
+/* {s_x_window_ref, x_window_ref}, */
+ {0, 0}
+};
+
+static iproc x_subr2s[] = {
+ {s_x_event_ref, x_event_ref},
+ {s_x_find_color, x_find_color},
+ {s_x_color_ref, x_color_ref},
+ {s_x_load_font, x_load_font},
+ {0, 0}
+};
+
+static iproc x_subr2os[] = {
+ {s_x_display_debug, x_display_debug},
+ {s_x_screen_cells, x_screen_cells},
+ {s_x_screen_depth, x_screen_depth},
+ {s_x_screen_depths, x_screen_depths},
+ {s_x_screen_size, x_screen_size},
+ {s_x_screen_dimm, x_screen_dimm},
+ {s_x_screen_black, x_screen_black},
+ {s_x_screen_white, x_screen_white},
+ {s_x_protocol_version, x_protocol_version},
+ {s_x_vendor_release, x_vendor_release},
+ {s_x_server_vendor, x_server_vendor},
+ {s_x_screen_count, x_screen_count},
+ {s_x_events_queued, x_events_queued},
+ {s_x_next_event, x_next_event},
+ {s_x_peek_event, x_peek_event},
+ {s_x_pending, x_pending},
+ {s_x_q_length, x_q_length},
+ {s_x_root_window, x_root_window},
+ {s_x_default_gcontext, x_default_gcontext},
+ {s_x_default_visual, x_default_visual},
+ {s_x_default_colormap, x_default_colormap},
+ {s_x_install_colormap, x_install_colormap},
+ {s_x_flush, x_flush},
+ {0, 0}
+};
+
+static iproc x_subr1s[] = {
+ {s_x_open_display, x_open_display},
+ {s_x_close, x_close},
+ {s_x_default_screen, x_default_screen},
+ {s_x_window_geometry, x_window_geometry},
+ {s_x_map_window, x_map_window},
+ {s_x_map_raised, x_map_raised},
+ {s_x_map_subwindows, x_map_subwindows},
+ {s_x_unmap_window, x_unmap_window},
+ {s_x_unmap_subwindows, x_unmap_subwindows},
+ {s_x_recreate_colormap, x_recreate_colormap},
+ {0, 0}
+};
+
+int (*x_scm_prev_error_handler)() = 0;
+void x_scm_final()
+{
+ if (x_scm_prev_error_handler) XSetErrorHandler(x_scm_prev_error_handler);
+ x_scm_prev_error_handler = 0;
+}
+
+void init_x()
+{
+ init_iprocs(x_subr3s, tc7_subr_3);
+ init_iprocs(x_lsubr2s, tc7_lsubr_2);
+ init_iprocs(x_lsubrs, tc7_lsubr);
+ init_iprocs(x_subr2s, tc7_subr_2);
+ init_iprocs(x_subr2os, tc7_subr_2o);
+ init_iprocs(x_subr1s, tc7_subr_1);
+
+ tc16_xdisplay = newsmob(&smob_xdisplay);
+ tc16_xwindow = newsmob(&smob_xwindow);
+ tc16_xcursor = newsmob(&smob_xcursor);
+ tc16_xfont = newsmob(&smob_xfont);
+ tc16_xcolormap = newsmob(&smob_xcolormap);
+ tc16_xgcontext = newsmob(&smob_xgcontext);
+ tc16_xvisual = newsmob(&smob_xvisual);
+ tc16_xevent = newsmob(&smob_xevent);
+
+ scm_ldprog("x11.scm");
+ scm_ldprog("xevent.scm");
+ scm_ldstr("\
+(define x:GC-Clip-Origin (logior x:GC-Clip-X-Origin x:GC-Clip-Y-Origin))\n\
+(define x:GC-Tile-Stip-Origin \n\
+ (logior x:GC-Tile-Stip-X-Origin x:GC-Tile-Stip-Y-Origin))\n\
+");
+ add_feature("xlib");
+
+ add_final(x_scm_final);
+ XSetErrorHandler(x_scm_error_handler);
+}