diff options
Diffstat (limited to 'x.c')
| -rw-r--r-- | x.c | 2114 |
1 files changed, 2114 insertions, 0 deletions
@@ -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); +} |