From b4f1bcad7894d777f1863414f3fd42b704f78ce2 Mon Sep 17 00:00:00 2001 From: frese Date: Sun, 6 Jan 2002 16:53:13 +0000 Subject: [PATCH] - changed variable arguments and return values in set-wm-hints!, get-wm-hints, set-wm-normal-hints!, get-wm-normal-hints, create-gcontext, change-gcontext, get-visual-info, change-window-attributes, get-window-attributes, configure-window, create-window to use an enumerated type instead of symbols. - renamed functions in xlib-client (e.g. wm-hints to get-wm-hints). --- c/xlib/client.c | 273 ++++++++--------- c/xlib/gcontext.c | 170 +++++------ c/xlib/type.c | 10 +- c/xlib/window.c | 277 ++++++++--------- scheme/xlib/client.scm | 172 ++++++----- scheme/xlib/gcontext.scm | 256 ++++++++-------- scheme/xlib/helper.scm | 55 +++- scheme/xlib/visual.scm | 93 +++--- scheme/xlib/window.scm | 428 +++++++++++++++++---------- scheme/xlib/xlib-interfaces.scm | 53 ++-- scheme/xlib/xlib-packages.scm | 6 + scheme/xlib/xlib-type-interfaces.scm | 5 +- 12 files changed, 961 insertions(+), 837 deletions(-) diff --git a/c/xlib/client.c b/c/xlib/client.c index 36e5788..3935dba 100644 --- a/c/xlib/client.c +++ b/c/xlib/client.c @@ -1,5 +1,4 @@ #include "xlib.h" -#include "scheme48.h" s48_value scx_Iconify_Window (s48_value Xdisplay, s48_value w, s48_value scr) { if (!XIconifyWindow (SCX_EXTRACT_DISPLAY(Xdisplay), @@ -22,7 +21,7 @@ s48_value scx_Withdraw_Window (s48_value Xdisplay, s48_value w, s48_value scr) { s48_value scx_Reconfigure_Wm_Window (s48_value dpy, s48_value w, s48_value scr, s48_value conf) { XWindowChanges WC; - unsigned long mask = AList_To_XWindowChanges(conf, &WC); + unsigned long mask = 0;//AList_To_XWindowChanges(conf, &WC); if (!XReconfigureWMWindow (SCX_EXTRACT_DISPLAY(dpy), SCX_EXTRACT_WINDOW(w), @@ -237,16 +236,15 @@ s48_value scx_Wm_Hints (s48_value dpy, s48_value w) { S48_VECTOR_SET(res, 2, SCX_ENTER_PIXMAP(p->icon_pixmap)); if (p->flags && IconWindowHint) S48_VECTOR_SET(res, 3, SCX_ENTER_WINDOW(p->icon_window)); - if (p->flags && IconPositionHint) { - S48_VECTOR_SET(res, 4, s48_enter_integer(p->icon_x)); - S48_VECTOR_SET(res, 5, s48_enter_integer(p->icon_y)); - } + if (p->flags && IconPositionHint) + S48_VECTOR_SET(res, 4, s48_cons(s48_enter_integer(p->icon_x), + s48_enter_integer(p->icon_y))); if (p->flags && IconMaskHint) - S48_VECTOR_SET(res, 6, SCX_ENTER_PIXMAP(p->icon_mask)); + S48_VECTOR_SET(res, 5, SCX_ENTER_PIXMAP(p->icon_mask)); if (p->flags && WindowGroupHint) // Elk says a window-group is a window...?? - S48_VECTOR_SET(res, 7, SCX_ENTER_WINDOW(p->window_group)); - S48_VECTOR_SET(res, 8, S48_ENTER_BOOLEAN(p->flags && XUrgencyHint)); + S48_VECTOR_SET(res, 6, SCX_ENTER_WINDOW(p->window_group)); + S48_VECTOR_SET(res, 7, S48_ENTER_BOOLEAN(p->flags & XUrgencyHint)); // XLib man-pages say this constant is called UrgencyHint !! S48_GC_UNPROTECT(); @@ -257,46 +255,45 @@ s48_value scx_Wm_Hints (s48_value dpy, s48_value w) { return res; } -s48_value scx_Set_Wm_Hints (s48_value dpy, s48_value w, s48_value alist) { - unsigned long mask = 0; - s48_value l, p, v; +s48_value scx_Set_Wm_Hints (s48_value dpy, s48_value w, s48_value hints) { + long mask = 0; XWMHints WMH; - char* cname; - - for (l = alist; !S48_NULL_P(l); l = S48_CDR(l)) { - p = S48_CAR(l); - v = S48_CDR(p); - cname = s48_extract_symbol(S48_CAR(p)); - if (strcmp(cname, "input?") == 0) { - mask |= InputHint; - WMH.input = !S48_FALSE_P(v); - } else if (strcmp(cname, "initial-state") == 0) { - mask |= StateHint; - WMH.initial_state = Symbol_To_Bit((unsigned long)s48_extract_integer(v), - Initial_State_Syms); - } else if (strcmp(cname, "icon-pixmap") == 0) { - mask |= IconPixmapHint; - WMH.icon_pixmap = SCX_EXTRACT_PIXMAP(v); - } else if (strcmp(cname, "icon-window") == 0) { - mask |= IconWindowHint; - WMH.icon_window = SCX_EXTRACT_WINDOW(v); - } else if (strcmp(cname, "icon-x") == 0) { - mask |= IconPositionHint; - WMH.icon_x = (int)s48_extract_integer(v); - } else if (strcmp(cname, "icon-y") == 0) { - mask |= IconPositionHint; - WMH.icon_y = (int)s48_extract_integer(v); - } else if (strcmp(cname, "icon-mask") == 0) { - mask |= IconMaskHint; - WMH.icon_mask = SCX_EXTRACT_PIXMAP(v); - } else if (strcmp(cname, "window-group") == 0) { - mask |= WindowGroupHint; - WMH.window_group = SCX_EXTRACT_WINDOW(v); - } else if (strcmp(cname, "urgency") == 0) { - mask |= XUrgencyHint; - // XLib man-pages say this constant is called UrgencyHint !! + int i; + + for (i=0; i<8; i++) { + s48_value value = S48_VECTOR_REF(hints, i); + if (S48_FALSE != value) { + switch (i) { + case 0: mask |= InputHint; + WMH.input = (Bool)s48_extract_integer(value); + break; + case 1: mask |= StateHint; + WMH.initial_state = + Symbol_To_Bit(value, + Initial_State_Syms); + break; + case 2: mask |= IconPixmapHint; + WMH.icon_pixmap = SCX_EXTRACT_PIXMAP(value); + break; + case 3: mask |= IconWindowHint; + WMH.icon_window = SCX_EXTRACT_WINDOW(value); + break; + case 4: mask |= IconPositionHint; + WMH.icon_x = (int)s48_extract_integer(S48_CAR(value)); + WMH.icon_y = (int)s48_extract_integer(S48_CDR(value)); + break; + case 5: mask |= IconMaskHint; + WMH.icon_mask = SCX_EXTRACT_PIXMAP(value); + break; + case 6: mask |= WindowGroupHint; + WMH.window_group = SCX_EXTRACT_WINDOW(value); + break; + case 7: mask |= s48_extract_integer(value) ? XUrgencyHint : 0; + // XLib man-pages say this constant is called UrgencyHint !! + } } } + WMH.flags = mask; XSetWMHints(SCX_EXTRACT_DISPLAY(dpy), SCX_EXTRACT_WINDOW(w), @@ -390,117 +387,103 @@ s48_value scx_Wm_Normal_Hints(s48_value dpy, s48_value win) { &SH, &supplied)) SH.flags = 0; - v = s48_make_vector(19, S48_NULL); + v = s48_make_vector(10, S48_NULL); S48_GC_PROTECT_1(v); - if ((SH.flags & PPosition) == PPosition) { - S48_VECTOR_SET(v, 0, s48_enter_integer(SH.x)); - S48_VECTOR_SET(v, 1, s48_enter_integer(SH.y)); - } - if ((SH.flags & PSize) == PSize) { - S48_VECTOR_SET(v, 2, s48_enter_integer(SH.width)); - S48_VECTOR_SET(v, 3, s48_enter_integer(SH.height)); - } - if ((SH.flags & USPosition) == USPosition) { - S48_VECTOR_SET(v, 0, s48_enter_integer(SH.x)); - S48_VECTOR_SET(v, 1, s48_enter_integer(SH.y)); - S48_VECTOR_SET(v, 4, S48_TRUE); // us-position -> #t - } - if ((SH.flags & USSize) == USSize) { - S48_VECTOR_SET(v, 2, s48_enter_integer(SH.width)); - S48_VECTOR_SET(v, 3, s48_enter_integer(SH.height)); - S48_VECTOR_SET(v, 5, S48_TRUE); // us-size -> #t - } - if ((SH.flags & PMinSize) == PMinSize) { - S48_VECTOR_SET(v, 6, s48_enter_integer(SH.min_width)); - S48_VECTOR_SET(v, 7, s48_enter_integer(SH.min_height)); - } - if ((SH.flags & PMaxSize) == PMaxSize) { - S48_VECTOR_SET(v, 8, s48_enter_integer(SH.max_width)); - S48_VECTOR_SET(v, 9, s48_enter_integer(SH.max_height)); - } - if ((SH.flags & PResizeInc) == PResizeInc) { - S48_VECTOR_SET(v, 10, s48_enter_integer(SH.width_inc)); - S48_VECTOR_SET(v, 11, s48_enter_integer(SH.height_inc)); - } - if ((SH.flags & PAspect) == PAspect) { - S48_VECTOR_SET(v, 12, s48_enter_integer(SH.min_aspect.x)); - S48_VECTOR_SET(v, 13, s48_enter_integer(SH.min_aspect.y)); - S48_VECTOR_SET(v, 14, s48_enter_integer(SH.max_aspect.x)); - S48_VECTOR_SET(v, 15, s48_enter_integer(SH.max_aspect.y)); - } - if ((SH.flags & PBaseSize) == PBaseSize) { - S48_VECTOR_SET(v, 16, s48_enter_integer(SH.base_width)); - S48_VECTOR_SET(v, 17, s48_enter_integer(SH.base_height)); - } - if ((SH.flags & PWinGravity) == PWinGravity) { + if (((SH.flags & PPosition) != 0) || ((SH.flags & USPosition) != 0)) + S48_VECTOR_SET(v, 2, s48_cons(s48_enter_integer(SH.x), + s48_enter_integer(SH.y))); + + if (((SH.flags & PSize) != 0) || ((SH.flags & USSize) != 0)) + S48_VECTOR_SET(v, 3, s48_cons(s48_enter_integer(SH.width), + s48_enter_integer(SH.height))); + + if ((SH.flags & USPosition) != 0) + S48_VECTOR_SET(v, 0, S48_VECTOR_REF(v, 2)); + + if ((SH.flags & USSize) != 0) + S48_VECTOR_SET(v, 1, S48_VECTOR_REF(v, 3)); + + if ((SH.flags & PMinSize) != 0) + S48_VECTOR_SET(v, 4, s48_cons(s48_enter_integer(SH.min_width), + s48_enter_integer(SH.min_height))); + + if ((SH.flags & PMaxSize) != 0) + S48_VECTOR_SET(v, 5, s48_cons(s48_enter_integer(SH.max_width), + s48_enter_integer(SH.max_height))); + + if ((SH.flags & PResizeInc) != 0) + S48_VECTOR_SET(v, 6, s48_cons(s48_enter_integer(SH.width_inc), + s48_enter_integer(SH.height_inc))); + + if ((SH.flags & PAspect) != 0) + S48_VECTOR_SET(v, 7, + s48_cons(s48_cons(s48_enter_integer(SH.min_aspect.x), + s48_enter_integer(SH.min_aspect.y)), + s48_cons(s48_enter_integer(SH.max_aspect.x), + s48_enter_integer(SH.max_aspect.y)))); + + if ((SH.flags & PBaseSize) != 0) + S48_VECTOR_SET(v, 8, s48_cons(s48_enter_integer(SH.base_width), + s48_enter_integer(SH.base_height))); + + if ((SH.flags & PWinGravity) != 0) S48_VECTOR_SET(v, 18, Bit_To_Symbol(SH.win_gravity, Grav_Syms)); - } S48_GC_UNPROTECT(); return v; } s48_value scx_Set_Wm_Normal_Hints(s48_value dpy, s48_value win, - s48_value alist) { + s48_value hints) { XSizeHints SH; long mask = 0; - s48_value l; - for (l = alist; !S48_NULL_P(l); l = S48_CDR(l)) { - s48_value p = S48_CAR(l); - char* name = s48_extract_string(S48_CAR(p)); - s48_value v = S48_CDR(p); + int i; + + for (i=0; i<10; i++) { + s48_value v = S48_VECTOR_REF(hints, i); - if (strcmp(name, "x") == 0) { - mask |= PPosition; SH.x = s48_extract_integer(v); - } - if (strcmp(name, "y") == 0) { - mask |= PPosition; SH.y = s48_extract_integer(v); - } - if (strcmp(name, "width") == 0) { - mask |= PSize; SH.width = s48_extract_integer(v); - } - if (strcmp(name, "height") == 0) { - mask |= PSize; SH.height = s48_extract_integer(v); - } - if (strcmp(name, "min-width") == 0) { - mask |= PMinSize; SH.min_width = s48_extract_integer(v); - } - if (strcmp(name, "min-height") == 0) { - mask |= PMinSize; SH.min_height = s48_extract_integer(v); - } - if (strcmp(name, "max-width") == 0) { - mask |= PMaxSize; SH.max_width = s48_extract_integer(v); - } - if (strcmp(name, "max-height") == 0) { - mask |= PMaxSize; SH.max_height = s48_extract_integer(v); - } - if (strcmp(name, "width-inc") == 0) { - mask |= PResizeInc; SH.width_inc = s48_extract_integer(v); - } - if (strcmp(name, "height-inc") == 0) { - mask |= PResizeInc; SH.height_inc = s48_extract_integer(v); - } - if (strcmp(name, "min-aspect-x") == 0) { - mask |= PAspect; SH.min_aspect.x = s48_extract_integer(v); - } - if (strcmp(name, "min-aspect-y") == 0) { - mask |= PAspect; SH.min_aspect.y = s48_extract_integer(v); - } - if (strcmp(name, "max-aspect-x") == 0) { - mask |= PAspect; SH.max_aspect.x = s48_extract_integer(v); - } - if (strcmp(name, "max-aspect-y") == 0) { - mask |= PAspect; SH.max_aspect.y = s48_extract_integer(v); - } - if (strcmp(name, "base-width") == 0) { - mask |= PBaseSize; SH.base_width = s48_extract_integer(v); - } - if (strcmp(name, "base-height") == 0) { - mask |= PBaseSize; SH.base_height = s48_extract_integer(v); - } - if (strcmp(name, "gravity") == 0) { - mask |= PWinGravity; SH.win_gravity = Symbol_To_Bit(v, Grav_Syms); + switch (i) { + case 0: mask |= USPosition; + SH.x = s48_extract_integer(S48_CAR(v)); + SH.y = s48_extract_integer(S48_CDR(v)); + break; + case 1: mask |= USSize; + SH.width = s48_extract_integer(S48_CAR(v)); + SH.height = s48_extract_integer(S48_CDR(v)); + break; + case 2: mask |= PPosition; + SH.x = s48_extract_integer(S48_CAR(v)); + SH.y = s48_extract_integer(S48_CDR(v)); + break; + case 3: mask |= PSize; + SH.width = s48_extract_integer(S48_CAR(v)); + SH.height = s48_extract_integer(S48_CDR(v)); + break; + case 4: mask |= PMinSize; + SH.min_width = s48_extract_integer(S48_CAR(v)); + SH.min_height = s48_extract_integer(S48_CDR(v)); + break; + case 5: mask |= PMaxSize; + SH.max_width = s48_extract_integer(S48_CAR(v)); + SH.max_height = s48_extract_integer(S48_CDR(v)); + break; + case 6: mask |= PResizeInc; + SH.width_inc = s48_extract_integer(S48_CAR(v)); + SH.height_inc = s48_extract_integer(S48_CDR(v)); + break; + case 7: mask |= PAspect; + SH.min_aspect.x = s48_extract_integer(S48_CAR(S48_CAR(v))); + SH.min_aspect.y = s48_extract_integer(S48_CDR(S48_CAR(v))); + SH.max_aspect.x = s48_extract_integer(S48_CAR(S48_CDR(v))); + SH.max_aspect.y = s48_extract_integer(S48_CDR(S48_CDR(v))); + break; + case 8: mask |= PBaseSize; + SH.base_width = s48_extract_integer(S48_CAR(v)); + SH.base_height = s48_extract_integer(S48_CDR(v)); + break; + case 9: mask |= PWinGravity; + SH.win_gravity = Symbol_To_Bit(v, Grav_Syms); } } SH.flags = mask; diff --git a/c/xlib/gcontext.c b/c/xlib/gcontext.c index 95028c8..6a7ffbd 100644 --- a/c/xlib/gcontext.c +++ b/c/xlib/gcontext.c @@ -1,97 +1,91 @@ #include "xlib.h" -#include "scheme48.h" -unsigned long AList_To_GCValues(s48_value alist, XGCValues* GCV) { +unsigned long Values_To_GCValues(s48_value values, XGCValues* GCV) { unsigned long mask = 0; - s48_value l, p; - char* cname; - s48_value name, value; - - for (l = alist; !S48_NULL_P(l); l = S48_CDR(l)) { - p = S48_CAR(l); - name = S48_CAR(p); - value = S48_CDR(p); - cname = s48_extract_string(S48_SYMBOL_TO_STRING(name)); - - if (strcmp(cname, "function") == 0) { - GCV->function = Symbol_To_Bit(value, Func_Syms); - mask |= GCFunction; - } else if (strcmp(cname, "plane-mask") == 0) { - GCV->plane_mask = SCX_EXTRACT_PIXEL(value); - mask |= GCPlaneMask; - } else if (strcmp(cname, "foreground") == 0) { - GCV->foreground = SCX_EXTRACT_PIXEL(value); - mask |= GCForeground; - } else if (strcmp(cname, "background") == 0) { - GCV->background = SCX_EXTRACT_PIXEL(value); - mask |= GCBackground; - } else if (strcmp(cname, "line-width") == 0) { - GCV->line_width = s48_extract_integer(value); - mask |= GCLineWidth; - } else if (strcmp(cname, "line-style") == 0) { - GCV->line_style = Symbol_To_Bit(value,Line_Style_Syms); - mask |= GCLineStyle; - } else if (strcmp(cname, "cap-style") == 0) { - GCV->cap_style = Symbol_To_Bit(value, Cap_Style_Syms); - mask |= GCCapStyle; - } else if (strcmp(cname, "join-style") == 0) { - GCV->join_style = Symbol_To_Bit(value, Join_Style_Syms); - mask |= GCJoinStyle; - } else if (strcmp(cname, "fill-style") == 0) { - GCV->fill_style = Symbol_To_Bit(value, Fill_Style_Syms); - mask |= GCFillStyle; - } else if (strcmp(cname, "fill-rule") == 0) { - GCV->fill_rule = Symbol_To_Bit(value, Fill_Rule_Syms); - mask |= GCFillRule; - } else if (strcmp(cname, "arc-mode") == 0) { - GCV->arc_mode = Symbol_To_Bit(value, Arc_Mode_Syms); - mask |= GCArcMode; - } else if (strcmp(cname, "tile") == 0) { - GCV->tile = SCX_EXTRACT_PIXMAP(value); - mask |= GCTile; - } else if (strcmp(cname, "stipple") == 0) { - GCV->stipple = SCX_EXTRACT_PIXMAP(value); - mask |= GCStipple; - } else if (strcmp(cname, "ts-x") == 0) { - GCV->ts_x_origin = s48_extract_integer(value); - mask |= GCTileStipXOrigin; - } else if (strcmp(cname, "ts-y") == 0) { - GCV->ts_y_origin = s48_extract_integer(value); - mask |= GCTileStipYOrigin; - } else if (strcmp(cname, "font") == 0) { - GCV->font = SCX_EXTRACT_FONT(value); - mask |= GCFont; - } else if (strcmp(cname, "subwindow-mode") == 0) { - GCV->subwindow_mode = Symbol_To_Bit(value, Subwin_Mode_Syms); - mask |= GCSubwindowMode; - } else if (strcmp(cname, "exposures") == 0) { - GCV->graphics_exposures = !S48_FALSE_P(value); - mask |= GCGraphicsExposures; - } else if (strcmp(cname, "clip-x") == 0) { - GCV->clip_x_origin = s48_extract_integer(value); - mask |= GCClipXOrigin; - } else if (strcmp(cname, "clip-y") == 0) { - GCV->clip_y_origin = s48_extract_integer(value); - mask |= GCClipYOrigin; - } else if (strcmp(cname, "clip-mask") == 0) { - GCV->clip_mask = SCX_EXTRACT_PIXMAP(value); - mask |= GCClipMask; - } else if (strcmp(cname, "dash-offset") == 0) { - GCV->dash_offset = s48_extract_integer(value); - mask |= GCDashOffset; - } else if (strcmp(cname, "dashes") == 0) { - GCV->dashes = (char)s48_extract_integer(value); - mask |= GCDashList; + int i; + for (i=0; i<23; i++) { + s48_value value = S48_VECTOR_REF(values, i); + if (S48_FALSE != value) { + switch (i) { + case 0: GCV->function = Symbol_To_Bit(value, Func_Syms); + mask |= GCFunction; + break; + case 1: GCV->plane_mask = SCX_EXTRACT_PIXEL(value); + mask |= GCPlaneMask; + break; + case 2: GCV->foreground = SCX_EXTRACT_PIXEL(value); + mask |= GCForeground; + break; + case 3: GCV->background = SCX_EXTRACT_PIXEL(value); + mask |= GCBackground; + break; + case 4: GCV->line_style = Symbol_To_Bit(value,Line_Style_Syms); + mask |= GCLineStyle; + break; + case 5: GCV->cap_style = Symbol_To_Bit(value, Cap_Style_Syms); + mask |= GCCapStyle; + break; + case 6: GCV->cap_style = Symbol_To_Bit(value, Cap_Style_Syms); + mask |= GCCapStyle; + break; + case 7: GCV->join_style = Symbol_To_Bit(value, Join_Style_Syms); + mask |= GCJoinStyle; + break; + case 8: GCV->fill_style = Symbol_To_Bit(value, Fill_Style_Syms); + mask |= GCFillStyle; + break; + case 9: GCV->fill_rule = Symbol_To_Bit(value, Fill_Rule_Syms); + mask |= GCFillRule; + break; + case 10: GCV->tile = SCX_EXTRACT_PIXMAP(value); + mask |= GCTile; + break; + case 11: GCV->stipple = SCX_EXTRACT_PIXMAP(value); + mask |= GCStipple; + break; + case 12: GCV->ts_x_origin = s48_extract_integer(value); + mask |= GCTileStipXOrigin; + break; + case 13: GCV->ts_y_origin = s48_extract_integer(value); + mask |= GCTileStipYOrigin; + break; + case 14: GCV->font = SCX_EXTRACT_FONT(value); + mask |= GCFont; + break; + case 15: GCV->subwindow_mode = Symbol_To_Bit(value, Subwin_Mode_Syms); + mask |= GCSubwindowMode; + break; + case 16: GCV->graphics_exposures = !S48_FALSE_P(value); + mask |= GCGraphicsExposures; + break; + case 17: GCV->clip_x_origin = s48_extract_integer(value); + mask |= GCClipXOrigin; + break; + case 18: GCV->clip_y_origin = s48_extract_integer(value); + mask |= GCClipYOrigin; + break; + case 19: GCV->clip_mask = SCX_EXTRACT_PIXMAP(value); + mask |= GCClipMask; + break; + case 20: GCV->dash_offset = s48_extract_integer(value); + mask |= GCDashOffset; + break; + case 21: GCV->dashes = (char)s48_extract_integer(value); + mask |= GCDashList; + break; + case 22: GCV->arc_mode = Symbol_To_Bit(value, Arc_Mode_Syms); + mask |= GCArcMode; + break; + } } - // else error ?? - } // for - + } return mask; -} +} -s48_value scx_Create_Gc(s48_value Xdisplay, s48_value Xdrawable, s48_value args) { +s48_value scx_Create_Gc(s48_value Xdisplay, s48_value Xdrawable, + s48_value values) { XGCValues GCV; - unsigned long mask = AList_To_GCValues(args, &GCV); + unsigned long mask = Values_To_GCValues(values, &GCV); GC Xgcontext = XCreateGC(SCX_EXTRACT_DISPLAY(Xdisplay), SCX_EXTRACT_DRAWABLE(Xdrawable), @@ -174,7 +168,7 @@ s48_value scx_Get_Gc_Values (s48_value Xgcontext, s48_value Xdisplay) { s48_value scx_Change_Gc (s48_value Xgcontext, s48_value Xdisplay, s48_value args) { XGCValues GCV; - unsigned long mask = AList_To_GCValues(args, &GCV); + unsigned long mask = Values_To_GCValues(args, &GCV); XChangeGC(SCX_EXTRACT_DISPLAY(Xdisplay), SCX_EXTRACT_GCONTEXT(Xgcontext), mask, &GCV); diff --git a/c/xlib/type.c b/c/xlib/type.c index 567f040..92b4189 100644 --- a/c/xlib/type.c +++ b/c/xlib/type.c @@ -521,13 +521,13 @@ SYMDESCR Gcontext_Values_Syms[] = { { "arc-mode", GCArcMode }, { "tile", GCTile }, { "stipple", GCStipple }, - { "ts-x", GCTileStipXOrigin }, - { "ts-y", GCTileStipYOrigin }, + { "ts-x-origin", GCTileStipXOrigin }, + { "ts-y-origin", GCTileStipYOrigin }, { "font", GCFont }, { "subwindow-mode", GCSubwindowMode }, - { "exposures", GCGraphicsExposures }, - { "clip-x", GCClipXOrigin }, - { "clip-y", GCClipYOrigin }, + { "graphics-exposures", GCGraphicsExposures }, + { "clip-x-origin", GCClipXOrigin }, + { "clip-y-origin", GCClipYOrigin }, { "clip-mask", GCClipMask }, { "dash-offset", GCDashOffset }, { "dashes", GCDashList }, diff --git a/c/xlib/window.c b/c/xlib/window.c index 43a4141..2bafaaf 100644 --- a/c/xlib/window.c +++ b/c/xlib/window.c @@ -1,114 +1,95 @@ #include "xlib.h" -#include "scheme48.h" -unsigned long AList_To_XSetWindowAttributes(s48_value attrAlist, - XSetWindowAttributes* Xattrs) { - unsigned long mask = 0; - s48_value l; - s48_value p; - char* cname; - s48_value name, value; - - for (l = attrAlist; !S48_NULL_P(l); l = S48_CDR(l)) { - p = S48_CAR(l); - name = S48_CAR(p); - value = S48_CDR(p); - cname = s48_extract_symbol(name); - - if (strcmp(cname, "background-pixmap") == 0) { - Xattrs->background_pixmap = extract_background(value); - mask |= CWBackPixmap; - } else if (strcmp(cname, "background-pixel") == 0) { - Xattrs->background_pixel = s48_extract_integer(value); - mask |= CWBackPixel; - } else if (strcmp(cname, "border-pixmap") == 0) { - Xattrs->border_pixmap = extract_border(value); - mask |= CWBorderPixmap; - } else if (strcmp(cname, "border-pixel") == 0) { - Xattrs->border_pixel = s48_extract_integer(value); - mask |= CWBorderPixel; - } else if (strcmp(cname, "bit-gravity") == 0) { - Xattrs->bit_gravity = Symbol_To_Bit(value, Bit_Grav_Syms); - mask |= CWBitGravity; - } else if (strcmp(cname, "gravity") == 0) { - Xattrs->win_gravity = Symbol_To_Bit(value, Grav_Syms); - mask |= CWWinGravity; - } else if (strcmp(cname, "backing-store") == 0) { - Xattrs->backing_store = Symbol_To_Bit(value, Backing_Store_Syms); - mask |= CWBackingStore; - } else if (strcmp(cname, "backing-planes") == 0) { - Xattrs->backing_planes = s48_extract_integer(value); - mask |= CWBackingPlanes; - } else if (strcmp(cname, "backing-pixel") == 0) { - Xattrs->backing_pixel = s48_extract_integer(value); - mask |= CWBackingPixel; - } else if (strcmp(cname, "save-under") == 0) { - Xattrs->save_under = !S48_FALSE_P(value); - mask |= CWSaveUnder; - } else if (strcmp(cname, "event-mask") == 0) { - Xattrs->event_mask = Symbols_To_Bits(value, Event_Mask_Syms); - mask |= CWEventMask; - } else if (strcmp(cname, "do-not-propagate-mask") == 0) { - Xattrs->do_not_propagate_mask = Symbols_To_Bits(value, Event_Mask_Syms); - mask |= CWDontPropagate; - } else if (strcmp(cname, "override-redirect") == 0) { - Xattrs->override_redirect = !S48_FALSE_P(value); - mask |= CWOverrideRedirect; - } else if (strcmp(cname, "colormap") == 0) { - Xattrs->colormap = s48_extract_integer(value); - mask |= CWColormap; - } else if (strcmp(cname, "cursor") == 0) { - Xattrs->cursor = s48_extract_integer(value); - mask |= CWCursor; - } // else error ?? - } /* for */ - return mask; -} - -int extract_background(s48_value value) { - if (S48_SYMBOL_P(value)) { - char* v = s48_extract_string(S48_SYMBOL_TO_STRING(value)); - if (strcmp(v, "none") == 0) - return None; - else if (strcmp(v, "parent-relative") == 0) - return ParentRelative; - //else // error ... +unsigned long Attribs_To_XSetWindowAttributes(s48_value attribs, + XSetWindowAttributes* Xattrs) { + int i; unsigned long mask = 0; + for (i=0; i<15; i++) { + s48_value value = S48_VECTOR_REF(attribs, i); + if (S48_FALSE != value) { + switch (i) { + case 0: Xattrs->background_pixmap = + S48_SYMBOL_P(value) ? ParentRelative : SCX_EXTRACT_PIXMAP(value); + mask |= CWBackPixmap; + break; + case 1: Xattrs->background_pixel = s48_extract_integer(value); + mask |= CWBackPixel; + break; + case 2: Xattrs->border_pixmap = + S48_SYMBOL_P(value) ? CopyFromParent : s48_extract_integer(value); + mask |= CWBorderPixmap; + break; + case 3: Xattrs->border_pixel = s48_extract_integer(value); + mask |= CWBitGravity; + break; + case 4: Xattrs->bit_gravity = Symbol_To_Bit(value, Bit_Grav_Syms); + mask |= CWBitGravity; + break; + case 5: Xattrs->win_gravity = Symbol_To_Bit(value, Grav_Syms); + mask |= CWWinGravity; + break; + case 6: Xattrs->backing_store = Symbol_To_Bit(value, Backing_Store_Syms); + mask |= CWBackingStore; + break; + case 7: Xattrs->backing_planes = s48_extract_integer(value); + mask |= CWBackingPlanes; + break; + case 8: Xattrs->backing_pixel = s48_extract_integer(value); + mask |= CWBackingPixel; + break; + case 9: Xattrs->override_redirect = s48_extract_integer(value); + mask |= CWOverrideRedirect; + break; + case 10: Xattrs->save_under = s48_extract_integer(value); + mask |= CWSaveUnder; + break; + case 11: Xattrs->event_mask = Symbols_To_Bits(value, Event_Mask_Syms); + mask |= CWEventMask; + break; + case 12: Xattrs->do_not_propagate_mask = + Symbols_To_Bits(value, Event_Mask_Syms); + mask |= CWDontPropagate; + break; + case 13: Xattrs->colormap = s48_extract_integer(value); + mask |= CWColormap; + break; + case 14: Xattrs->cursor = s48_extract_integer(value); + mask |= CWCursor; + break; + } + } } - return SCX_EXTRACT_PIXMAP(value); + return mask; } -int extract_border(s48_value value) { - if (S48_SYMBOL_P(value)) { - char* v = s48_extract_string(S48_SYMBOL_TO_STRING(value)); - if (strcmp(v, "copy-from-parent") == 0) - return CopyFromParent; - // else error - } else - return s48_extract_integer(value); -} - -s48_value scx_Create_Window (s48_value Xdisplay, s48_value Xparent, s48_value x, - s48_value y, s48_value width, s48_value height, - s48_value border_width, s48_value Xvisual, - s48_value attrAlist) { - - XSetWindowAttributes Xattrs; - unsigned long mask = AList_To_XSetWindowAttributes( attrAlist, &Xattrs ); - +s48_value scx_Create_Window (s48_value Xdisplay, s48_value Xparent, + s48_value x, s48_value y, + s48_value width, s48_value height, + s48_value border_width, s48_value depth, + s48_value class, s48_value Xvisual, + s48_value attribs) { Window win; + XSetWindowAttributes Xattrs; + unsigned long mask = Attribs_To_XSetWindowAttributes( attribs, &Xattrs ); + int dep = S48_FALSE_P(depth) ? CopyFromParent : s48_extract_integer(depth); + int cla = 0; Visual* vis = S48_FALSE_P(Xvisual) ? CopyFromParent : SCX_EXTRACT_VISUAL(Xvisual); - win = XCreateWindow( SCX_EXTRACT_DISPLAY(Xdisplay), SCX_EXTRACT_WINDOW(Xparent), + + switch (s48_extract_integer(class)) { + case 0: cla = InputOutput; + case 1: cla = InputOnly; + case 2: cla = CopyFromParent; + } + + win = XCreateWindow( SCX_EXTRACT_DISPLAY(Xdisplay), + SCX_EXTRACT_WINDOW(Xparent), (int)s48_extract_integer(x), (int)s48_extract_integer(y), (int)s48_extract_integer (width), (int)s48_extract_integer (height), (int)s48_extract_integer (border_width), - CopyFromParent, - CopyFromParent, - vis, - mask, - &Xattrs ); + dep, cla, vis, + mask,&Xattrs ); return SCX_ENTER_WINDOW(win); } @@ -118,16 +99,19 @@ s48_value scx_Destroy_Window (s48_value Xdisplay, s48_value Xwindow) { } s48_value scx_Change_Window_Attributes(s48_value Xwindow, s48_value Xdisplay, - s48_value attrAlist) { + s48_value attribs) { XSetWindowAttributes Xattrs; - unsigned long mask = AList_To_XSetWindowAttributes( attrAlist, &Xattrs ); + unsigned long mask = Attribs_To_XSetWindowAttributes( attribs, &Xattrs ); + + XChangeWindowAttributes(SCX_EXTRACT_DISPLAY(Xdisplay), + SCX_EXTRACT_WINDOW(Xwindow), + mask, &Xattrs); - XChangeWindowAttributes(SCX_EXTRACT_DISPLAY(Xdisplay), SCX_EXTRACT_WINDOW(Xwindow), - mask, &Xattrs); return S48_UNSPECIFIC; } + s48_value scx_Get_Window_Attributes(s48_value Xdisplay, s48_value Xwindow) { XWindowAttributes WA; @@ -169,59 +153,52 @@ s48_value scx_Get_Window_Attributes(s48_value Xdisplay, s48_value Xwindow) { S48_VECTOR_SET(res, 20, Bits_To_Symbols( WA.do_not_propagate_mask, Event_Mask_Syms )); S48_VECTOR_SET(res, 21, WA.override_redirect ? S48_TRUE : S48_FALSE); - S48_VECTOR_SET(res, 22, s48_enter_integer((long)WA.screen)); //?? - // WA.screen - ignored/not supported in Elk + + S48_VECTOR_SET(res, 22, S48_FALSE); + //S48_VECTOR_SET(res, 22, s48_enter_integer((long)WA.screen)); + // WA.screen not yet supported } S48_GC_UNPROTECT(); return res; } -unsigned long AList_To_XWindowChanges(s48_value alist, XWindowChanges* WC) { - unsigned long mask = 0; - s48_value l, p; - char* cname; - int cvalue; - s48_value name, value; - for (l = alist; !S48_NULL_P(l); l = S48_CDR(l)) { - p = S48_CAR(l); - name = S48_CAR(p); - value = S48_CDR(p); - cname = s48_extract_string(S48_SYMBOL_TO_STRING(name)); - cvalue = (int)s48_extract_integer(value); // only ints here - - if (strcmp(cname, "x") == 0) { - WC->x = cvalue; - mask |= CWX; - } else if (strcmp(cname, "y") == 0) { - WC->y = cvalue; - mask |= CWY; - } else if (strcmp(cname, "width") == 0) { - WC->width = cvalue; - mask |= CWWidth; - } else if (strcmp(cname, "height") == 0) { - WC->height = cvalue; - mask |= CWHeight; - } else if (strcmp(cname, "border-width") == 0) { - WC->border_width = cvalue; - mask |= CWBorderWidth; - } else if (strcmp(cname, "sibling") == 0) { - WC->sibling = (Window)s48_extract_integer(value); - mask |= CWSibling; - } else if (strcmp(cname, "stack-mode") == 0) { - WC->stack_mode = cvalue; - mask |= CWStackMode; +s48_value Changes_To_XWindowChanges(s48_value changes, XWindowChanges* WC) { + int i; unsigned long mask = 0; + for (i=0; i<7; i++) { + s48_value value = S48_VECTOR_REF(changes, i); + if (S48_FALSE != value) { + switch (i) { + case 0: WC->x = s48_extract_integer(value); + mask |= CWX; + break; + case 2: WC->y = s48_extract_integer(value); + mask |= CWY; + break; + case 3: WC->width = s48_extract_integer(value); + mask |= CWWidth; + break; + case 4: WC->height = s48_extract_integer(value); + mask |= CWHeight; + break; + case 5: WC->sibling = SCX_EXTRACT_WINDOW(value); + mask |= CWSibling; + break; + case 6: WC->stack_mode = Symbol_To_Bit(value, Stack_Mode_Syms); + mask |= CWStackMode; + break; + } } - } // for + } return mask; } s48_value scx_Configure_Window (s48_value Xwindow, s48_value Xdisplay, - s48_value alist) { + s48_value changes) { XWindowChanges WC; - unsigned long mask = AList_To_XWindowChanges(alist, &WC); + unsigned long mask = Changes_To_XWindowChanges(changes, &WC); - XConfigureWindow (SCX_EXTRACT_DISPLAY(Xdisplay), SCX_EXTRACT_WINDOW(Xwindow), + XConfigureWindow (SCX_EXTRACT_DISPLAY(Xdisplay), SCX_EXTRACT_WINDOW(Xwindow), mask, &WC); return S48_UNSPECIFIC; } @@ -258,22 +235,6 @@ s48_value scx_Circulate_Subwindows(s48_value Xwindow, s48_value Xdisplay, return S48_UNSPECIFIC; } -/* - -static s48_value P_Get_Geometry (d) s48_value d; { - Display *dpy; - Drawable dr = Get_Drawable (d, &dpy); - - // GEO.width, GEO.height, etc. should really be unsigned, not int. - - XGetGeometry (dpy, dr, &GEO.root, &GEO.x, &GEO.y, (unsigned *)&GEO.width, - (unsigned *)&GEO.height, (unsigned *)&GEO.border_width, - (unsigned *)&GEO.depth); - return Record_To_Vector (Geometry_Rec, Geometry_Size, Sym_Geo, dpy, ~0L); -} - -*/ - s48_value scx_Query_Tree (s48_value Xwindow, s48_value Xdisplay) { Window root, parent, *children; int i; diff --git a/scheme/xlib/client.scm b/scheme/xlib/client.scm index dbc12e7..c07a5ba 100644 --- a/scheme/xlib/client.scm +++ b/scheme/xlib/client.scm @@ -33,22 +33,24 @@ ;; the root window if that fails. See XReconfigureWMWindow. See ;; configure-window. -(define (reconfigure-wm-window window screen-number . args) +(define (reconfigure-wm-window window screen-number window-change-alist) (check-screen-number screen-number) (if (not (%reconfigure-wm-window (display-Xdisplay (window-display window)) (window-Xwindow window) screen-number - (named-args->alist args))) + (window-change-alist->vector + window-change-alist))) (error "cannot reconfigure window" window))) -(import-lambda-definition %reconfigure-wm-window (Xdisplay Xwindow scrnum alist) +(import-lambda-definition %reconfigure-wm-window + (Xdisplay Xwindow scrnum changes) "scx_Reconfigure_Wm_Window") -;; wm-command reads the WM_COMMAND property from the specified window -;; and returns is as a list of strings. See XGetCommand. +;; get-wm-command reads the WM_COMMAND property from the specified +;; window and returns is as a list of strings. See XGetCommand. -(define (wm-command window) +(define (get-wm-command window) (vector->list (%wm-command (display-Xdisplay (window-display window)) (window-Xwindow window)))) @@ -101,12 +103,12 @@ (import-lambda-definition %set-text-property! (Xdisplay Xwindow value XAtom) "scx_Set_Text_Property") -;; wm-protocols function returns the list of atoms stored in the +;; get-wm-protocols function returns the list of atoms stored in the ;; WM_PROTOCOLS property on the specified window. These atoms describe ;; window manager protocols in which the owner of this window is ;; willing to participate. See XGetWMProtocols. -(define (wm-protocols window) +(define (get-wm-protocols window) (let ((res (%wm-protocols (display-Xdisplay (window-display window)) (window-Xwindow window)))) (if res @@ -131,10 +133,10 @@ (import-lambda-definition %set-wm-protocols! (Xdisplay Xwindow protocols) "scx_Set_Wm_Protocols") -;; wm-class returns the class hint for the specified window. See +;; get-wm-class returns the class hint for the specified window. See ;; XGetClassHint. -(define (wm-class window) +(define (get-wm-class window) (let ((res (%wm-class (display-Xdisplay (window-display window)) (window-Xwindow window)))) (if res @@ -160,61 +162,73 @@ (import-lambda-definition %set-wm-class! (Xdisplay Xwindow name class) "scx_Set_Wm_Class") -;; wm-hints reads the window manager hints and returns them as an -;; alist mapping symbols to specific values. The hints are: 'input? -;; 'initial-state 'icon-pixmap 'icon-window 'icon-x 'icon-y 'icon-mask -;; 'window-group 'urgency. See XGetWMHints for a description. +;; enumerated type for the XWMHints type. used by set-wm-hints! and +;; get-wm-hints. -(define (wm-hints window) +(define-enumerated-type wm-hint :wm-hint + wm-hint? + wm-hints + wm-hint-name + wm-hint-index + (input? initial-state icon-pixmap icon-window icon-position icon-mask + window-group urgency)) + +(define wm-hint-alist->vector + (make-enum-alist->vector + wm-hints wm-hint-index + (lambda (i) + (case i + ((0 7) (lambda (x) (if x 1 0))) + ((2 5) pixmap-Xpixmap) + ((3 6) window-Xwindow) + (else (lambda (x) x)))))) + +(define vector->wm-hint-alist + (make-vector->enum-alist + wm-hints + (lambda (i display) + (case i + ((2 5) (lambda (Xpixmap) + (if (null? Xpixmap) + '() + (make-pixmap Xpixmap display #f)))) + ((3 6) (lambda (Xwindow) + (if (null? Xwindow) + '() + (make-window Xwindow display #f)))) + (else (lambda (x) x)))))) + +;; get-wm-hints reads the window manager hints and returns them as an +;; alist mapping wm-hint types to specific values. If a hints is not +;; defined, it is not included in the alist. See wm-hint. See +;; XGetWMHints for a description. + +(define (get-wm-hints window) (let ((res (%wm-hints (display-Xdisplay (window-display window)) - (window-Xwindow window))) - (make-window* (lambda (Xwindow) - (if (null? Xwindow) - Xwindow - (make-window Xwindow (window-display window) - #f)))) - (make-pixmap* (lambda (Xpixmap) - (if (null? Xpixmap) - Xpixmap - (make-pixmap Xpixmap (window-display window) - #f))))) - (vector-set! res 2 (make-pixmap* (vector-ref res 2))) - (vector-set! res 3 (make-window* (vector-ref res 3))) - (vector-set! res 6 (make-pixmap* (vector-ref res 6))) - (vector-set! res 7 (make-window* (vector-ref res 7))) - (map cons - '(input? initial-state icon-pixmap icon-window icon-x icon-y - icon-mask window-group urgency) - (vector->list res)))) + (window-Xwindow window)))) + (filter (lambda (x) (not (null? (cdr x)))) + (vector->wm-hint-alist res (window-display window))))) (import-lambda-definition %wm-hints (Xdisplay Xwindow) "scx_Wm_Hints") ;; set-wm-hints! sets the specified window manager hints. The hints -;; must be specified together with their names. Either by giving two -;; parameter 'name value, or the last argument may be an alist, as -;; returned by wm-hints. See XSetWMHints. +;; must be specified as an alist of wm-hint values (see above) mapping +;; to the appropiate values. See XSetWMHints. -(define (set-wm-hints! window . args) +(define (set-wm-hints! window wm-hint-alist) (%set-wm-hints! (display-Xdisplay (window-display window)) (window-Xwindow window) - (map (lambda (p) - (case (car p) - ((icon-pixmap icon-mask) - (cons (car p) (pixmap-Xpixmap (cdr p)))) - ((icon-window window-group) - (cons (car p) (window-Xwindow (cdr p)))) - (else p))) - (named-args->alist args)))) + (wm-hint-alist->vector wm-hint-alist))) (import-lambda-definition %set-wm-hints! (Xdisplay Xwindow args) "scx_Set_Wm_Hints") -;; transient-for returns the WM_TRANSIENT_FOR property for the +;; get-transient-for returns the WM_TRANSIENT_FOR property for the ;; specified window. The value of that property is a window. See ;; XGetTransientForHint. -(define (transient-for window) +(define (get-transient-for window) (make-window (%transient-for (display-Xdisplay (window-display window)) (window-Xwindow window)) (window-display window) @@ -243,13 +257,13 @@ (define xa-wm-icon-name (make-atom 37)) (define xa-wm-client-machine (make-atom 36)) -(define (wm-name w) +(define (get-wm-name w) (get-text-property w xa-wm-name)) -(define (wm-icon-name w) +(define (get-wm-icon-name w) (get-text-property w xa-wm-icon-name)) -(define (wm-client-machine w) +(define (get-wm-client-machine w) (get-text-property w xa-wm-client-machine)) (define (set-wm-name! w s) @@ -261,44 +275,64 @@ (define (set-wm-client-machine! w s) (set-text-property! w s xa-wm-client-machine)) -;; wm-normal-hints/set-wm-normal-hints! get or set the size hints +;; an enumerated type for XSizeHints used by get-wm-normal-hints and +;; set-wm-normal-hints! + +(define-enumerated-type size-hint :size-hint + size-hint? + size-hints + size-hint-name + size-hint-index + ;; aspect should have the form ((min-x . min-y) . (max-x . max-y)) + ;; for win-gravity see gravity in create-window. + ;; the other hints must be pairs of integers - (x . y) or (width . height) + ;; us-position, us-size .....!!?? + (us-position us-size position size min-size max-size resize-inc aspect + base-size win-gravity)) + +(define size-hint-alist->vector + (make-enum-alist->vector + size-hints size-hint-index + (lambda (i) + (lambda (x) x)))) + +(define vector->size-hint-alist + (make-vector->enum-alist + size-hints + (lambda (i extra) + (lambda (x) x)))) + +;; get-wm-normal-hints/set-wm-normal-hints! get or set the size hints ;; stored in the WM_NORMAL_HINTS property on the specified window. The ;; hints are '(x y width height us-position us-size min-width ;; min-height max-width max-height width-inc height-inc min-aspect-x ;; min-aspect-y max-aspect-x max-aspect-y base-width base-height ;; gravity). See XGetWMNormalHints, XSetWMNormalHints. -(define (wm-normal-hints window) +(define (get-wm-normal-hints window) (let* ((v (%wm-normal-hints (display-Xdisplay (window-display window)) - (window-Xwindow window))) - (alist (map cons - '(x y width height us-position us-size - min-width min-height max-width max-height - width-inc height-inc min-aspect-x min-aspect-y - max-aspect-x max-aspect-y base-width base-height - gravity) - (vector->list v)))) - alist)) + (window-Xwindow window)))) + (filter (lambda (x) (not (null? (cdr x)))) + (vector->size-hint-alist v #f)))) (import-lambda-definition %wm-normal-hints (Xdisplay Xwindow) "scx_Wm_Normal_Hints") -(define (set-wm-normal-hints! window . args) - (let ((alist (named-args->alist args))) - (%set-wm-normal-hints! (display-Xdisplay (window-Xwindow window)) - (window-Xwindow window) - alist))) +(define (set-wm-normal-hints! window size-hint-alist) + (%set-wm-normal-hints! (display-Xdisplay (window-Xwindow window)) + (window-Xwindow window) + (size-hint-alist->vector size-hint-alist))) (import-lambda-definition %set-wm-normal-hints! (Xdisplay Xwindow alist) "scx_Set_Wm_Normal_Hints") -;; icon-sizes returns the icon sizes specified by a window manager as +;; get-icon-sizes returns the icon sizes specified by a window manager as ;; a list. If no icon sizes are specified the list is empty. An icon ;; size itself is a list consisting of integers meaning '(min-width ;; min-height max-width max-height width-inc height-inc). See ;; XGetIconSizes. -(define (icon-sizes window) +(define (get-icon-sizes window) (let ((r (%icon-sizes (display-Xdisplay (window-display window)) (window-Xwindow window)))) (map vector->list diff --git a/scheme/xlib/gcontext.scm b/scheme/xlib/gcontext.scm index 9c357e0..33281b8 100644 --- a/scheme/xlib/gcontext.scm +++ b/scheme/xlib/gcontext.scm @@ -1,34 +1,48 @@ +;; an enumerated type corresponding to XGCValues. + +(define-enumerated-type gc-value :gc-value + gc-value? + gc-values + gc-value-name + gc-value-index + (function plane-mask foreground background line-width line-style cap-style + join-style fill-style fill-rule tile stipple ts-x-origin ts-y-origin + font subwindow-mode graphics-exposures clip-x-origin clip-y-origin + clip-mask dash-offset dash-list arc-mode)) + +(define gc-value-alist->vector + (make-enum-alist->vector + gc-values gc-value-index + (lambda (i) + (case i + ((1 2 3) pixel-Xpixel) + ((10 11 19) pixmap-Xpixmap) + ((14) font-Xfont) + ((16) (lambda (x) (if x 1 0))) + (else (lambda (x) x)))))) + ;; create-gcontext returns a newly create graphic context for the -;; specified drawable (a window or a pixmap). Optional arguments are -;; all attributes that can be set by the set-gcontext-xyz! functions -;; below. They can be specified by name: 'function 'xor. Or the last -;; argument can be an alist of such mappings. See XCreateGC. +;; specified drawable (a window or a pixmap). The gc-value-alist has +;; to be an alist mapping a gc-value (defined above) to a +;; corresponding value. See XCreateGC. -(define (create-gcontext drawable . args) - (let ((alist (named-args->alist args))) - (let* ((rest (map cons - (map car alist) - (map (lambda (obj) - (cond - ((pixel? obj) (pixel-Xpixel obj)) - ((font? obj) (font-Xfont obj)) - ((pixmap? obj) (pixmap-Xpixmap obj)) - (else obj))) - (map cdr alist)))) - (display (drawable-display drawable)) - (Xdisplay (display-Xdisplay display)) - (Xobject (drawable-Xobject drawable))) - (let ((Xgcontext (%create-gcontext Xdisplay Xobject rest))) - (make-gcontext Xgcontext display #t))))) +(define (create-gcontext drawable gc-value-alist) + (let ((display (drawable-display drawable)) + (Xobject (drawable-Xobject drawable)) + (values (gc-value-alist->vector gc-value-alist))) + (let ((Xgcontext (%create-gcontext (display-Xdisplay display) + Xobject + values))) + (make-gcontext Xgcontext display #t)))) -(import-lambda-definition %create-gcontext (Xdisplay Xdrawable alist) +(import-lambda-definition %create-gcontext (Xdisplay Xdrawable values) "scx_Create_Gc") ;; copy-gcontext returns a newly create duplicate of the given ;; gcontext, and assigns it to the specified drawable. See XCopyGC. (define (copy-gcontext gcontext drawable) - (let* ((new-gcontext (create-gcontext 'drawable drawable)) + (let* ((new-gcontext (create-gcontext drawable '())) (new-Xgcontext (gcontext-Xgcontext new-gcontext)) (Xgcontext (gcontext-Xgcontext gcontext)) (Xdisplay (display-Xdisplay (gcontext-display gcontext)))) @@ -39,25 +53,25 @@ "scx_Copy_Gc") ;; copy-gcontext! copies the specified attributes from gc-from to -;; gc-to. The attributes have to be a list of the names in the -;; set-gcontext-*! functions. If that argument is not specified, then -;; all atributes are copied. See XCopyGC. +;; gc-to. The attributes have to be a list of gc-values as defined +;; above. if no gc-values list is specified, then all attributes are +;; copied. See XCopyGC. -(define (copy-gcontext! gc-from gc-to . attributes) - (let ((attributes (if (null? attributes) - 'all - (car attributes)))) +(define (copy-gcontext! gc-from gc-to . maybe-gc-values) + (let ((gc-values (if (null? maybe-gc-values) + 'all + (map gc-value-name (car maybe-gc-values))))) (%copy-gcontext! (display-Xdisplay (gcontext-display gc-from)) (gcontext-Xgcontext gc-from) (gcontext-Xgcontext gc-to) - attributes))) + gc-values))) (import-lambda-definition %copy-gcontext! (Xdisplay Xfrom Xto attrs) "scx_Copy_Gc_To_Gc") ;; get-gontext-values returns an alist of all attributes for the -;; specified graphic context. See the gcontext-xyz functions -;; below. See XGetGCValues. +;; specified graphic context. See the gc-value and create-gcontext +;; above. See XGetGCValues. (define (get-gcontext-values gcontext) (let* ((Xgcontext (gcontext-Xgcontext gcontext)) @@ -66,66 +80,54 @@ (let ((vals (%get-gcontext-values Xgcontext Xdisplay))) (if (not vals) (error "cannot get gcontext values." gcontext) - (let* - ((pack (lambda (i fun) - (vector-set! vals i (fun (vector-ref vals i))))) - (make-pixmap* (lambda (Xpixmap) - (make-pixmap Xpixmap display #f))) - (make-font* (lambda (Xfont) - ; this might not work properly, see Xlib Programming - ; Manual chapter 5.12 - (make-font #f Xfont #f display #t))) - (make-pixel* (lambda (Xpixel) - (make-pixel Xpixel #f #f))) - (mod-vals (begin - (pack 1 make-pixel*) ;; plane-mask - (pack 2 make-pixel*) ;; foreground - (pack 3 make-pixel*) ;; background - (pack 11 make-pixmap*) ;; tile - (pack 12 make-pixmap*) ;; stipple - (pack 15 make-font*) ;; font - (pack 20 make-pixmap*) ;; clip-mask - vals)) - (alist - (map cons - '(function plane-mask foreground background - line-width line-style cap-style join-style - fill-style fill-rule arc-mode tile stipple ts-x ts-y - font subwindow-mode exposures clip-x clip-y - clip-mask dash-offset dashes) - (vector->list mod-vals)))) - alist))))) + (vector->gc-value-alist vals display))))) (import-lambda-definition %get-gcontext-values (Xgcontext Xdisplay) "scx_Get_Gc_Values") +(define vector->gc-value-alist + (make-vector->enum-alist + gc-values + (lambda (i display) + (case i + ((1 2 3) (lambda (Xpixel) + (make-pixel Xpixel #f #f))) + ((11 12 20) (lambda (Xpixmap) + (make-pixmap Xpixmap display #f))) + ((15) (lambda (Xfont) + ;; -> see Xlib Programming Manual 5.12 + (make-font #f Xfont #f display #t))) + (else (lambda (x) x)))))) + (define (make-gcontext-getter name) (lambda (gcontext) (cdr (assq name (get-gcontext-values gcontext))))) -(define gcontext-function (make-gcontext-getter 'function)) -(define gcontext-plane-mask (make-gcontext-getter 'plane-mask)) -(define gcontext-foreground (make-gcontext-getter 'foreground)) -(define gcontext-background (make-gcontext-getter 'background)) -(define gcontext-line-width (make-gcontext-getter 'line-width)) -(define gcontext-line-style (make-gcontext-getter 'line-style)) -(define gcontext-cap-style (make-gcontext-getter 'cap-style)) -(define gcontext-join-style (make-gcontext-getter 'join-style)) -(define gcontext-fill-style (make-gcontext-getter 'fill-style)) -(define gcontext-fill-rule (make-gcontext-getter 'fill-rule)) -(define gcontext-arc-mode (make-gcontext-getter 'arc-mode)) -(define gcontext-tile (make-gcontext-getter 'tile)) -(define gcontext-stipple (make-gcontext-getter 'stipple)) -(define gcontext-ts-x (make-gcontext-getter 'ts-x)) -(define gcontext-ts-y (make-gcontext-getter 'ts-y)) -(define gcontext-font (make-gcontext-getter 'font)) -(define gcontext-subwindow-mode (make-gcontext-getter 'subwindow-mode)) -(define gcontext-exposures (make-gcontext-getter 'exposures)) -(define gcontext-clip-x (make-gcontext-getter 'clip-x)) -(define gcontext-clip-y (make-gcontext-getter 'clip-y)) -(define gcontext-clip-mask (make-gcontext-getter 'clip-mask)) -(define gcontext-dash-offset (make-gcontext-getter 'dash-offset)) -(define gcontext-dashes (make-gcontext-getter 'dashes)) +(define gcontext-function (make-gcontext-getter (gc-value function))) +(define gcontext-plane-mask (make-gcontext-getter (gc-value plane-mask))) +(define gcontext-foreground (make-gcontext-getter (gc-value foreground))) +(define gcontext-background (make-gcontext-getter (gc-value background))) +(define gcontext-line-width (make-gcontext-getter (gc-value line-width))) +(define gcontext-line-style (make-gcontext-getter (gc-value line-style))) +(define gcontext-cap-style (make-gcontext-getter (gc-value cap-style))) +(define gcontext-join-style (make-gcontext-getter (gc-value join-style))) +(define gcontext-fill-style (make-gcontext-getter (gc-value fill-style))) +(define gcontext-fill-rule (make-gcontext-getter (gc-value fill-rule))) +(define gcontext-arc-mode (make-gcontext-getter (gc-value arc-mode))) +(define gcontext-tile (make-gcontext-getter (gc-value tile))) +(define gcontext-stipple (make-gcontext-getter (gc-value stipple))) +(define gcontext-ts-x-origin (make-gcontext-getter (gc-value ts-x-origin))) +(define gcontext-ts-y-origin (make-gcontext-getter (gc-value ts-y-origin))) +(define gcontext-font (make-gcontext-getter (gc-value font))) +(define gcontext-subwindow-mode + (make-gcontext-getter (gc-value subwindow-mode))) +(define gcontext-graphics-exposures + (make-gcontext-getter (gc-value graphics-exposures))) +(define gcontext-clip-x-origin (make-gcontext-getter (gc-value clip-x-origin))) +(define gcontext-clip-y-origin (make-gcontext-getter (gc-value clip-y-origin))) +(define gcontext-clip-mask (make-gcontext-getter (gc-value clip-mask))) +(define gcontext-dash-offset (make-gcontext-getter (gc-value dash-offset))) +(define gcontext-dash-list (make-gcontext-getter (gc-value dash-list))) ;; Alternative definition of gcontext-font. See XGcontextFromGC ; @@ -143,23 +145,10 @@ ;; context. The format of the arguments is like for ;; create-gcontext. See XChangeGC. -(define (change-gcontext gcontext . attrs) - (let* ((alist (named-args->alist attrs)) - (prep-alist - (map cons - (map car alist) - (map (lambda (value) - (cond - ((pixmap? value) (pixmap-Xpixmap value)) - ((font? value) (font-Xfont value)) ;;?? - ((pixel? value) (pixel-Xpixel value)) - ;; ??... - (else value))) - (map cdr alist))))) - (%change-gcontext (gcontext-Xgcontext gcontext) - (display-Xdisplay (gcontext-display gcontext)) - prep-alist))) - +(define (change-gcontext gcontext gc-value-alist) + (%change-gcontext (gcontext-Xgcontext gcontext) + (display-Xdisplay (gcontext-display gcontext)) + (gc-value-alist->vector gc-value-alist))) (import-lambda-definition %change-gcontext (Xgcontext Xdisplay args) "scx_Change_Gc") @@ -168,29 +157,48 @@ (lambda (gcontext value) (change-gcontext gcontext (list (cons name value))))) -(define set-gcontext-function! (make-gcontext-setter 'function)) -(define set-gcontext-plane-mask! (make-gcontext-setter 'plane-mask)) -(define set-gcontext-foreground! (make-gcontext-setter 'foreground)) -(define set-gcontext-background! (make-gcontext-setter 'background)) -(define set-gcontext-line-width! (make-gcontext-setter 'line-width)) -(define set-gcontext-line-style! (make-gcontext-setter 'line-style)) -(define set-gcontext-cap-style! (make-gcontext-setter 'cap-style)) -(define set-gcontext-join-style! (make-gcontext-setter 'join-style)) -(define set-gcontext-fill-style! (make-gcontext-setter 'fill-style)) -(define set-gcontext-fill-rule! (make-gcontext-setter 'fill-rule)) -(define set-gcontext-arc-mode! (make-gcontext-setter 'arc-mode)) -(define set-gcontext-tile! (make-gcontext-setter 'tile)) -(define set-gcontext-stipple! (make-gcontext-setter 'stipple)) -(define set-gcontext-ts-x! (make-gcontext-setter 'ts-x)) -(define set-gcontext-ts-y! (make-gcontext-setter 'ts-y)) -(define set-gcontext-font! (make-gcontext-setter 'font)) -(define set-gcontext-subwindow-mode! (make-gcontext-setter 'subwindow-mode)) -(define set-gcontext-exposures! (make-gcontext-setter 'exposures)) -(define set-gcontext-clip-x! (make-gcontext-setter 'clip-x)) -(define set-gcontext-clip-y! (make-gcontext-setter 'clip-y)) -(define set-gcontext-clip-mask! (make-gcontext-setter 'clip-mask)) -(define set-gcontext-dash-offset! (make-gcontext-setter 'dash-offset)) -(define set-gcontext-dashes! (make-gcontext-setter 'dashes)) +(define set-gcontext-function! + (make-gcontext-setter (gc-value function))) +(define set-gcontext-plane-mask! + (make-gcontext-setter (gc-value plane-mask))) +(define set-gcontext-foreground! + (make-gcontext-setter (gc-value foreground))) +(define set-gcontext-background! + (make-gcontext-setter (gc-value background))) +(define set-gcontext-line-width! + (make-gcontext-setter (gc-value line-width))) +(define set-gcontext-line-style! + (make-gcontext-setter (gc-value line-style))) +(define set-gcontext-cap-style! + (make-gcontext-setter (gc-value cap-style))) +(define set-gcontext-join-style! + (make-gcontext-setter (gc-value join-style))) +(define set-gcontext-fill-style! + (make-gcontext-setter (gc-value fill-style))) +(define set-gcontext-fill-rule! + (make-gcontext-setter (gc-value fill-rule))) +(define set-gcontext-arc-mode! (make-gcontext-setter (gc-value arc-mode))) +(define set-gcontext-tile! (make-gcontext-setter (gc-value tile))) +(define set-gcontext-stipple! (make-gcontext-setter (gc-value stipple))) +(define set-gcontext-ts-x-origin! + (make-gcontext-setter (gc-value ts-x-origin))) +(define set-gcontext-ts-y-origin! + (make-gcontext-setter (gc-value ts-y-origin))) +(define set-gcontext-font! (make-gcontext-setter (gc-value font))) +(define set-gcontext-subwindow-mode! + (make-gcontext-setter (gc-value subwindow-mode))) +(define set-gcontext-graphics-exposures! + (make-gcontext-setter (gc-value graphics-exposures))) +(define set-gcontext-clip-x-origin! + (make-gcontext-setter (gc-value clip-x-origin))) +(define set-gcontext-clip-y-origin! + (make-gcontext-setter (gc-value clip-y-origin))) +(define set-gcontext-clip-mask! + (make-gcontext-setter (gc-value clip-mask))) +(define set-gcontext-dash-offset! + (make-gcontext-setter (gc-value dash-offset))) +(define set-gcontext-dash-list! + (make-gcontext-setter (gc-value dash-list))) ;; set-dashlist! is a more complex form of set-dashes!. (set-dashes! N) is ;; equivalent to (set-dash-list! .. #(N N)) diff --git a/scheme/xlib/helper.scm b/scheme/xlib/helper.scm index 57841af..4b53fa6 100644 --- a/scheme/xlib/helper.scm +++ b/scheme/xlib/helper.scm @@ -1,20 +1,43 @@ -;; named-args->alist does this: -;; '(a 5 b 6 ((c . 10) (d . 5))) -> '((a . 5) (b . 6) (c . 10) (d . 5)) -;; '(e 3) -> '((e . 3)) -;; '((f . 0)) -> '((f . 0)) -;; (hard to explain :-) +;; make-enum-alist->vector creates a function that converts an +;; association list, that maps from an enumerated type to some values, +;; into a vector. The vector element i contains #f if the +;; corresponding element i of the enumerated type was not defined in +;; the alist, and the value ((converter i) value) otherwise. Be sure +;; to convert boolean values to something else, if you want to know if +;; a value was not defined, or defined as #f afterwards. -(define (named-args->alist args) - (let loop ((alist '()) - (args args)) - (cond - ((null? args) (reverse alist)) - ((null? (cdr args)) (loop (append (car args) alist) '())) - (else (let ((sym (car args)) - (val (cadr args))) - (loop (cons (cons sym val) alist) - (cddr args))))))) +(define (make-enum-alist->vector enum-vector index-fun converter) + (lambda (alist) + (let ((res (make-vector (vector-length enum-vector) #f))) + (for-each (lambda (a) + (vector-set! res (index-fun (car a)) + a)) + alist) + (let loop ((i 0)) + (if (< i (vector-length res)) + (begin + (if (vector-ref res i) + (vector-set! res i + ((converter i) (cdr (vector-ref res i))))) + (loop (+ i 1))))) + res))) +;; and the other way round... + +(define (make-vector->enum-alist enum-vector converter) + (lambda (vector extra-arg) + (let loop ((i 0)) + (if (< i (vector-length vector)) + (begin + (vector-set! vector + i + ((converter i extra-arg) (vector-ref vector i))) + (loop (+ i 1))) + (map cons + (vector->list enum-vector) + (vector->list vector)))))) + +;; (define-exported-binding "string->symbol" string->symbol) @@ -52,4 +75,4 @@ (begin (vector-set! v i (f (vector-ref v i))) (loop (+ i 1))) - v)))) \ No newline at end of file + v)))) diff --git a/scheme/xlib/visual.scm b/scheme/xlib/visual.scm index 2a07c0f..ede1bb1 100644 --- a/scheme/xlib/visual.scm +++ b/scheme/xlib/visual.scm @@ -1,56 +1,53 @@ -;; A visual information is an alist with the following keys: -;; 'screen-number the screen this visual belongs to -;; 'depth the depth of the screen -;; 'class one of 'direct-color 'gray-scale 'pseudo-color -;; 'static-color 'static-gray 'true-color -;; 'red-mask these masks are used for direct-color and true-color -;; 'green-mask to specify which bits of the pixel value specify -;; 'blue-mask red, green or blue values. -;; 'colormap-size tells how many different pixel value are valid -;; 'bits-per-rgb specifies how many bits in each of the red, green -;; and blue values in a colorcell are used to drive -;; the rgb gun in the screen. -;; 'visual this value can be passed to other functions, e.g. -;; create-window. -;; 'visual-id this value is not normally needed by applications. +;; A visual information is an alist with keys of the type +;; visual-info. The corresponding values have the following meaning: +;; screen-number the screen this visual belongs to +;; depth the depth of the screen +;; class one of 'direct-color 'gray-scale 'pseudo-color +;; 'static-color 'static-gray 'true-color +;; red-mask these masks are used for direct-color and true-color +;; green-mask to specify which bits of the pixel value specify +;; blue-mask red, green or blue values. +;; colormap-size tells how many different pixel value are valid +;; bits-per-rgb specifies how many bits in each of the red, green +;; and blue values in a colorcell are used to drive +;; the rgb gun in the screen. +;; visual this value can be passed to other functions, e.g. +;; create-window. +;; visual-id this value is not normally needed by applications. -;; returns a list of visual informations that match the template given -;; by args. args can consist of the same fields as a visual -;; information (see above) except 'visual that may not be -;; specified. But usually only the fields 'screen 'depth and 'class -;; make sense. See create-window for the syntax of args. +(define-enumerated-type visual-info :visual-info + visual-info? + visual-infos + visual-info-name + visual-info-index + (visual visual-id screen depth class red-mask green-mask blue-mask + colormap-size bits-per-rgp)) -(define (get-visual-info display . args) - (let* ((alist (named-args->alist args)) - (vector (pack-visual-info alist))) - (let ((res (%get-visual-info (display-Xdisplay display) - vector))) - (map unpack-visual-info - (vector->list res))))) +(define visual-info-alist->vector + (make-enum-alist->vector + visual-infos visual-info-index + (lambda (i) + (lambda (x) x)))) + +(define (vector->visual-info-alist vector) + (vector-set! vector 0 (make-visual (vector-ref vector 0))) + (map cons + (vector->list visual-infos) + (vector->list vector))) + +;; returns a list of visual informations of visuals that match the +;; template given by visual-info-alist. the 'visual element is not +;; allowed here. See XGetVisualInfo. + +(define (get-visual-info display visual-info-alist) + (let ((res (%get-visual-info (display-Xdisplay display) + (visual-info-alist->vector visual-info-alist)))) + (map vector->visual-info-alist + (vector->list res)))) (import-lambda-definition %get-visual-info (Xdisplay v) "scx_Get_Visual_Info") -(define (pack-visual-info vi) - (let ((mapping (map cons - '(visual visual-id screen-number depth class - red-mask green-mask blue-mask colormap-size - bits-per-rgb) - '(0 1 2 3 4 5 6 7 8 9))) - (r (make-vector 10 #f))) - (for-each (lambda (p) - (vector-set! r (cdr (assq (car p) mapping)) - (cdr p))) - vi) - r)) - -(define (unpack-visual-info v) - (vector-set! v 0 (make-visual (vector-ref v 0))) - (map cons - '(visual visual-id screen-number depth class red-mask green-mask - blue-mask colormap-size bits-per-rgb) - (vector->list v))) - ;; visual-id returns the id of a given visual. (define (visual-id visual) @@ -68,7 +65,7 @@ depth class))) (if res - (unpack-visual-info res) + (visual-info-alist->vector res) res))) (import-lambda-definition %match-visual-info (Xdisplay scrnum depth class) diff --git a/scheme/xlib/window.scm b/scheme/xlib/window.scm index bc70d60..2a56171 100644 --- a/scheme/xlib/window.scm +++ b/scheme/xlib/window.scm @@ -1,190 +1,302 @@ ;; Author: David Frese -;; create-window takes an alist of names and values - see -;; change-window-attributes and configure-window. Mandatory arguments for -;; create-window are parent, width and height. Example: -;; (create-window root 500 300 'x 0 '((border-width . 4))) -;; Returns the new window or raises an exception if something went wrong. +;; create-window creates an unmapped subwindow for a specified parent +;; window. depth can be 'copy-from-parent. class can be one of +;; 'input-output, 'input-only or 'copy-from-parent. visual can be +;; 'copy-from-parent too (see create-simple-window). See +;; change-window-attributes and make-set-window-attribute-alist for +;; the attributes argument. -(define (create-window parent width height . args) - (let ((alist (named-args->alist args))) - (receive (x y border-width visual change-win-attr-list) - (alist-split alist '((x . 0) (y . 0) (border-width . 2) - (visual . #f))) - (let* ((change-win-attr-list - (map cons - (map car change-win-attr-list) - (map (lambda (obj) - (cond - ((pixel? obj) (pixel-Xpixel obj)) - ((pixmap? obj) (pixmap-Xpixmap obj)) - ((colormap? obj) (colormap-Xcolormap obj)) - ((cursor? obj) (cursor-Xcursor obj)) - (else obj))) - (map cdr change-win-attr-list)))) - (display (window-display parent)) - (Xwindow (%create-window (display-Xdisplay display) - (window-Xwindow parent) - x y width height border-width - (if visual - (visual-Xvisual visual) - #f) - change-win-attr-list))) - (if (= Xwindow 0) - (error "cannot create window") - (make-window Xwindow display #t)))))) +(define (create-window parent x y width height border-width depth class + visual set-window-attribute-alist) + (let ((attribs (set-window-attribute-alist->vector + set-window-attribute-alist)) + (depth (cond + ((eq? depth 'copy-from-parent) #f) + ((number? depth) depth) + (else (error "invalid depth" depth)))) + (class (case class + ((input-output) 0) + ((input-only) 1) + ((copy-from-parent) 2) + (else (error "invalid class specifier" class)))) + (visual (cond + ((eq? visual 'copy-from-parent) #f) + ((visual? visual) (visual-Xvisual visual)) + (else (error "invalid visual") visual))) + (display (window-display parent))) + (let ((Xwindow (%create-window + (display-Xdisplay display) + (window-Xwindow parent) + x y width height border-width + depth class visual + attribs))) + (if (= Xwindow 0) + (error "cannot create window") + (make-window Xwindow display #t))))) -(import-lambda-definition %create-window (Xdisplay Xparent x y width height - border-width visual attrAlist) +(import-lambda-definition %create-window + (Xdisplay Xparent x y width height border_width depth class Xvisual attribs) "scx_Create_Window") -;; change-window-attributes takes an alist of names and values... -;; names can be: background-pixmap, background-pixel, border-pixmap, -;; border-pixel, bit-gravity, gravity, backing-store, backing-planes, -;; backing-pixel, save-under, event-mask, do-not-propagate-mask, -;; override-redirect, colormap, cursor. +;; create-simple-window calls create-window with the default value 1 +;; for border-width, 0 for x and y, and 'copy-from-parent for depth, +;; class and visual. -(define (change-window-attributes window . attrs) - (let* ((alist (named-args->alist attrs)) - (prep-alist - (map cons - (map car alist) - (map (lambda (value) - (cond - ;; Abstractions ?? : - ((pixmap? value) (pixmap-Xpixmap value)) - ((pixel? value) (pixel-Xpixel value)) - ((colormap? value) (colormap-Xcolormap value)) - ((cursor? value) (cursor-Xcursor value)) - (else value))) - (map cdr alist))))) - (%change-window-attributes (window-Xwindow window) - (display-Xdisplay (window-display window)) - prep-alist))) +(define (create-simple-window parent width height + set-window-attribute-alist) + (create-window parent 0 0 width height 1 + 'copy-from-parent 'copy-from-parent 'copy-from-parent + set-window-attribute-alist)) -(import-lambda-definition %change-window-attributes (Xwindow Xdisplay alist) +;; *** change-window-attributes ************************************** + +;; enumerated type for window attributes that can be changed in +;; create-window and with change-window-attributes. + +(define-enumerated-type set-window-attribute :set-window-attribute + set-window-attribute? + set-window-attributes + set-window-attribute-name + set-window-attribute-index + ;; don't change the order of the attributes! + ;; special values: background-pixmap can be a pixmap, + ;; 'parent-relative or 'none. border-pixmap can be a pixmap or + ;; 'copy-from-parent. + (background-pixmap background-pixel border-pixmap border-pixel + bit-gravity gravity backing-store backing-planes backing-pixel + override-redirect save-under event-mask do-not-propagate-mask colormap + cursor)) + +(define set-window-attribute-alist->vector + (make-enum-alist->vector + set-window-attributes set-window-attribute-index + (lambda (i) + (case i + ((0) (lambda (background) + (cond + ((pixmap? background) (pixmap-Xpixmap background)) + ((eq? background 'parent-relative) background) + ((none-resource? background) 0) + (else (error "invalid background pixmap" + background))))) + ((1) pixel-Xpixel) + ((2) (lambda (border) + (cond + ((pixmap? border) (pixmap-Xpixmap border)) + ((eq? border 'copy-from-parent) border) + (else (error "invalid border pixmap" + border))))) + ((3) pixel-Xpixel) + ((8) pixel-Xpixel) + ((9) (lambda (override-redirect) + (if override-redirect 1 0))) + ((10) (lambda (save-under) + (if save-under 1 0))) + ((13) colormap-Xcolormap) + ((14) cursor-Xcursor) + (else (lambda (x) x)))))) + +;; a macro for an easier creation of such an alist. + +(define set-window-attribute-by-name + (let* ((attributes (vector->list set-window-attributes)) + (alist (map cons (map set-window-attribute-name + attributes) + attributes))) + (lambda (name) + (let ((r (assq name alist))) + (if r + (cdr r) + (error "attribute name not defined" name)))))) + +;(define-syntax make-set-window-attribute-alist +; (syntax-rules () +; ((make-set-window-attribute-alist) '()) +; ((make-set-window-attribute-alist 'item) +; `(cons (cons ,(set-window-attribute-by-name (car item)) +; ,(cadr item)) +; '())) +; ((make-set-window-attribute-alist item1 item2 ...) +; (cons (cons (set-window-attribute-by-name (car item1)) +; (cadr item1)) +; (make-set-window-attribute-alist item2 ...))))) + +;; change-window-attributes takes an alist of set-window-attributes +;; mapping to specific values. See XChangeWindowAttributes. + +(define (change-window-attributes window set-window-attribute-alist) + (%change-window-attributes (window-Xwindow window) + (display-Xdisplay (window-display window)) + (set-window-attribute-alist->vector + set-window-attribute-alist))) + +(import-lambda-definition %change-window-attributes (Xwindow Xdisplay attribs) "scx_Change_Window_Attributes") ;; simple functions that use change-window-attributes ;; TODO: a caching system for multiple calls to these functions -(define (make-win-attr-setter name) +(define (make-win-attr-setter attribute) (lambda (window value) - (change-window-attributes window (list (cons name value))))) + (change-window-attributes window (list (cons attribute value))))) -(define set-window-background-pixmap! (make-win-attr-setter 'background-pixmap)) -(define set-window-background-pixel! (make-win-attr-setter 'background-pixel)) -(define set-window-border-pixmap! (make-win-attr-setter 'border-pixmap)) -(define set-window-border-pixel! (make-win-attr-setter 'border-pixel)) -(define set-window-bit-gravity! (make-win-attr-setter 'bit-gravity)) -(define set-window-gravity! (make-win-attr-setter 'gravity)) -(define set-window-backing-store! (make-win-attr-setter 'backing-store)) -(define set-window-backing-planes! (make-win-attr-setter 'backing-planes)) -(define set-window-backing-pixel! (make-win-attr-setter 'backing-pixel)) -(define set-window-save-under! (make-win-attr-setter 'save-under)) -(define set-window-event-mask! (make-win-attr-setter 'event-mask)) +(define set-window-background-pixmap! + (make-win-attr-setter (set-window-attribute background-pixmap))) +(define set-window-background-pixel! + (make-win-attr-setter (set-window-attribute background-pixel))) +(define set-window-border-pixmap! + (make-win-attr-setter (set-window-attribute border-pixmap))) +(define set-window-border-pixel! + (make-win-attr-setter (set-window-attribute border-pixel))) +(define set-window-bit-gravity! + (make-win-attr-setter (set-window-attribute bit-gravity))) +(define set-window-gravity! + (make-win-attr-setter (set-window-attribute gravity))) +(define set-window-backing-store! + (make-win-attr-setter (set-window-attribute backing-store))) +(define set-window-backing-planes! + (make-win-attr-setter (set-window-attribute backing-planes))) +(define set-window-backing-pixel! + (make-win-attr-setter (set-window-attribute backing-pixel))) +(define set-window-save-under! + (make-win-attr-setter (set-window-attribute save-under))) +(define set-window-event-mask! + (make-win-attr-setter (set-window-attribute event-mask))) (define set-window-do-not-propagate-mask! - (make-win-attr-setter 'do-not-propagate-mask)) -(define set-window-override-redirect! (make-win-attr-setter 'override-redirect)) -(define set-window-colormap! (make-win-attr-setter 'colormap)) -(define set-window-cursor! (make-win-attr-setter 'cursor)) + (make-win-attr-setter (set-window-attribute do-not-propagate-mask))) +(define set-window-override-redirect! + (make-win-attr-setter (set-window-attribute override-redirect))) +(define set-window-colormap! + (make-win-attr-setter (set-window-attribute colormap))) +(define set-window-cursor! + (make-win-attr-setter (set-window-attribute cursor))) -;; get-window-attributes gives back the same attributes that -;; set-window-attributes sets and some more ... +;; *** configure-window ********************************************** +;; an enumerated type for configure-window (see XConfigureWindow) -(define (get-window-attributes window) - (let ((Xwindow (window-Xwindow window)) - (Xdisplay (display-Xdisplay (window-display window)))) - (let ((v (%get-window-attributes Xdisplay Xwindow))) - (if (not v) - (error "cannot get window attributes." window) - (let* - ((comp (lambda (i f) (vector-set! v i (f (vector-ref v i))))) - (mod-v (begin - (comp 13 (lambda (Xpixel) ;; backing-pixel - (make-pixel Xpixel #f #f))) - (comp 7 (lambda (Xwin) ;; root - (make-window Xwin (window-display window) - #f))) - (comp 15 (lambda (Xcolormap) - (make-colormap Xcolormap - (window-display window) - #f))) - (comp 6 make-visual) ;; visual - v)) - (alist (map cons - '(x y width height border-width depth visual root - class bit-gravity win-gravity backing-store - backing-planes backing-pixel save-under colormap - map-installed map-state all-event-masks - your-event-mask do-not-propagate-mask - override-redirect screen - ; screen not supported - ) - (vector->list mod-v)))) - alist))))) +(define-enumerated-type window-change :window-change + window-change? + window-changes + window-change-name + window-change-index + ; do not change this order + ; sibling is a window, stack-mode can be one of 'above, 'below, + ; 'top-if, 'buttom-if and 'opposite. + (x y width height border-width sibling stack-mode)) -(import-lambda-definition %get-window-attributes (Xdisplay Xwindow) - "scx_Get_Window_Attributes") +(define window-change-alist->vector + (make-enum-alist->vector + window-changes window-change-index + (lambda (i) + (case i + ((5) window-Xwindow) + (else (lambda (x) x)))))) -(define (make-win-attr-getter name) - (lambda (window) - (cdr (assq name (get-window-attributes window))))) +;; This sets the window-attributes listed above -(define window-x (make-win-attr-getter 'x)) -(define window-y (make-win-attr-getter 'y)) -(define window-width (make-win-attr-getter 'width)) -(define window-height (make-win-attr-getter 'height)) -(define window-border-width (make-win-attr-getter 'border-width)) -(define window-depth (make-win-attr-getter 'depth)) -(define window-visual (make-win-attr-getter 'visual)) -(define window-root (make-win-attr-getter 'root)) -(define window-class (make-win-attr-getter 'class)) -(define window-bit-gravity (make-win-attr-getter 'bit-gravity)) -(define window-backing-store (make-win-attr-getter 'backing-store)) -(define window-backing-planes (make-win-attr-getter 'backing-planes)) -(define window-backing-pixel (make-win-attr-getter 'backing-pixel)) -(define window-save-under (make-win-attr-getter 'save-under)) -(define window-colormap (make-win-attr-getter 'colormap)) -(define window-map-installed (make-win-attr-getter 'map-installed)) -(define window-map-state (make-win-attr-getter 'map-state)) -(define window-all-event-masks (make-win-attr-getter 'all-event-masks)) -(define window-your-event-mask (make-win-attr-getter 'your-event-mask)) -(define window-do-not-propagate-mask - (make-win-attr-getter 'do-not-propagate-mask)) -(define window-override-redirect (make-win-attr-getter 'override-redirect)) - -;; This sets the window-attributes listed below - call like create-window. - -(define (configure-window window . args) - (let* ((args (named-args->alist args)) - (prep-alist (map cons - (map car args) - (map (lambda (val) - (if (window? val) - (window-Xwindow val) - val)) - (map cdr args))))) +(define (configure-window window window-change-alist) (%configure-window (window-Xwindow window) (display-Xdisplay (window-display window)) - prep-alist))) + (window-change-alist->vector + window-change-alist))) -(import-lambda-definition %configure-window (Xwindow Xdisplay alist) +(import-lambda-definition %configure-window (Xwindow Xdisplay changes) "scx_Configure_Window") ;; the following mutators are based on configure-window -(define (make-win-configurer name) +(define (make-win-configurer change) (lambda (window value) - (configure-window window (list (cons name value))))) + (configure-window window (list (cons change value))))) -(define set-window-x! (make-win-configurer 'x)) -(define set-window-y! (make-win-configurer 'y)) -(define set-window-width! (make-win-configurer 'width)) -(define set-window-height! (make-win-configurer 'height)) -(define set-window-border-width! (make-win-configurer 'border-width)) -(define set-window-sibling! (make-win-configurer 'sibling)) -(define set-window-stack-mode! (make-win-configurer 'stack-mode)) +(define set-window-x! (make-win-configurer (window-change x))) +(define set-window-y! (make-win-configurer (window-change y))) +(define set-window-width! (make-win-configurer (window-change width))) +(define set-window-height! (make-win-configurer (window-change height))) +(define set-window-border-width! + (make-win-configurer (window-change border-width))) +(define set-window-sibling! (make-win-configurer (window-change sibling))) +(define set-window-stack-mode! + (make-win-configurer (window-change stack-mode))) + +;; *** get-window-attributes ***************************************** +;; get-window-attributes returns attributes of the specified window. + +(define-enumerated-type window-attribute :window-attribute + window-attribute? + window-attributes + window-attribute-name + window-attribute-index + ;; don't change the order of the attributes! + ;; screen is not supported yet - so it will be always #f + (x y width height border-width depth visual root class bit-gravity + gravity backing-store backing-planes backing-pixel save-under + colormap map-installed map-state all-event-masks your-event-mask + do-not-propagate-mask override-redirect screen)) + +(define vector->window-attribute-alist + (make-vector->enum-alist + window-attributes + (lambda (i display) + (case i + ((13) (lambda (Xpixel) ; backing-pixel + (make-pixel Xpixel #f #f))) + ((7) (lambda (Xwindow) ; root + (make-window Xwindow display #f))) + ((15) (lambda (Xcolormap) + (make-colormap Xcolormap display #f))) + ((6) make-visual) + (else (lambda (x) x)))))) + +(define (get-window-attributes window) + (let ((Xwindow (window-Xwindow window)) + (Xdisplay (display-Xdisplay (window-display window)))) + (let ((values (%get-window-attributes Xdisplay Xwindow))) + (if (not values) + (error "cannot get window attributes." window) + (vector->window-attribute-alist values (window-display window)))))) + +(import-lambda-definition %get-window-attributes (Xdisplay Xwindow) + "scx_Get_Window_Attributes") + +(define (make-win-attr-getter attribute) + (lambda (window) + (cdr (assq attribute (get-window-attributes window))))) + +(define window-x (make-win-attr-getter (window-attribute x))) +(define window-y (make-win-attr-getter (window-attribute y))) +(define window-width (make-win-attr-getter (window-attribute width))) +(define window-height (make-win-attr-getter (window-attribute height))) +(define window-border-width + (make-win-attr-getter (window-attribute border-width))) +(define window-depth (make-win-attr-getter (window-attribute depth))) +(define window-visual (make-win-attr-getter (window-attribute visual))) +(define window-root (make-win-attr-getter (window-attribute root))) +(define window-class (make-win-attr-getter (window-attribute class))) +(define window-bit-gravity + (make-win-attr-getter (window-attribute bit-gravity))) +(define window-gravity + (make-win-attr-getter (window-attribute gravity))) +(define window-backing-store + (make-win-attr-getter (window-attribute backing-store))) +(define window-backing-planes + (make-win-attr-getter (window-attribute backing-planes))) +(define window-backing-pixel + (make-win-attr-getter (window-attribute backing-pixel))) +(define window-save-under (make-win-attr-getter (window-attribute save-under))) +(define window-colormap (make-win-attr-getter (window-attribute colormap))) +(define window-map-installed + (make-win-attr-getter (window-attribute map-installed))) +(define window-map-state (make-win-attr-getter (window-attribute map-state))) +(define window-all-event-masks + (make-win-attr-getter (window-attribute all-event-masks))) +(define window-your-event-mask + (make-win-attr-getter (window-attribute your-event-mask))) +(define window-do-not-propagate-mask + (make-win-attr-getter (window-attribute do-not-propagate-mask))) +(define window-override-redirect + (make-win-attr-getter (window-attribute override-redirect))) ;; The map-window function maps the window and all of its subwindows that have ;; had map requests. See XMapWindow. @@ -332,4 +444,4 @@ (vector->list res))) (import-lambda-definition %query-pointer (Xdisplay Xwindow) - "scx_Query_Pointer") \ No newline at end of file + "scx_Query_Pointer") diff --git a/scheme/xlib/xlib-interfaces.scm b/scheme/xlib/xlib-interfaces.scm index ca85bd6..892d7dd 100644 --- a/scheme/xlib/xlib-interfaces.scm +++ b/scheme/xlib/xlib-interfaces.scm @@ -44,18 +44,21 @@ check-screen-number ;; for internal use (e.g. by client.scm) )) - (define-interface xlib-window-interface (export window? drawable? window-display create-window + create-simple-window destroy-window change-window-attributes get-window-attributes map-window unmap-window + ((set-window-attribute window-attribute window-change) :syntax) + window-change-alist->vector ; has to be exported for client.scm + set-window-background-pixmap! set-window-background-pixel! set-window-border-pixmap! @@ -166,6 +169,8 @@ copy-gcontext! free-gcontext + ((gc-value) :syntax) + query-best-size query-best-cursor query-best-tile @@ -185,16 +190,16 @@ gcontext-arc-mode gcontext-tile gcontext-stipple - gcontext-ts-x - gcontext-ts-y + gcontext-ts-x-origin + gcontext-ts-y-origin gcontext-font gcontext-subwindow-mode - gcontext-exposures - gcontext-clip-x - gcontext-clip-y + gcontext-graphics-exposures + gcontext-clip-x-origin + gcontext-clip-y-origin gcontext-clip-mask gcontext-dash-offset - gcontext-dashes + gcontext-dash-list change-gcontext set-gcontext-function! @@ -210,13 +215,13 @@ set-gcontext-arc-mode! set-gcontext-tile! set-gcontext-stipple! - set-gcontext-ts-x! - set-gcontext-ts-y! + set-gcontext-ts-x-origin! + set-gcontext-ts-y-origin! set-gcontext-font! set-gcontext-subwindow-mode! - set-gcontext-exposures! - set-gcontext-clip-x! - set-gcontext-clip-y! + set-gcontext-graphics-exposures! + set-gcontext-clip-x-origin! + set-gcontext-clip-y-origin! set-gcontext-clip-mask! set-gcontext-dash-offset! @@ -224,7 +229,6 @@ set-gcontext-dashlist! )) - (define-interface xlib-graphics-interface (export clear-area copy-area @@ -374,25 +378,26 @@ reconfigure-wm-window get-text-property set-text-property! - wm-protocols + get-wm-protocols set-wm-protocols! - wm-name + get-wm-name set-wm-name! - wm-icon-name + get-wm-icon-name set-wm-icon-name! - wm-client-machine + get-wm-client-machine set-wm-client-machine! - wm-class + get-wm-class set-wm-class! - wm-command + get-wm-command set-wm-command! - transient-for + get-transient-for set-transient-for! - wm-normal-hints + get-wm-normal-hints set-wm-normal-hints! - wm-hints + ((wm-hint size-hint) :syntax) ;; should be replaced by make-*-hint-alist + get-wm-hints set-wm-hints! - icon-sizes + get-icon-sizes set-icon-sizes! )) @@ -508,4 +513,4 @@ xlib-grab-interface xlib-visual-interface xlib-region-interface - )) \ No newline at end of file + )) diff --git a/scheme/xlib/xlib-packages.scm b/scheme/xlib/xlib-packages.scm index 0fb934c..02ea7ec 100644 --- a/scheme/xlib/xlib-packages.scm +++ b/scheme/xlib/xlib-packages.scm @@ -12,6 +12,7 @@ receiving xlib-types xlib-graphics ;; for clear-window + finite-types ;; for define-enumerated-type ) (files window)) @@ -52,6 +53,7 @@ signals ;; for error external-calls receiving + finite-types ;; for define-enumerated-type xlib-types) (files gcontext)) @@ -124,7 +126,10 @@ external-calls xlib-types xlib-display ;; for check-screen-number + xlib-window ; for window-change-alist->vector signals ;; for error + finite-types ;; for define-enumerated-type + list-lib ;; for filter ) (files client)) @@ -166,6 +171,7 @@ (define-structure xlib-visual xlib-visual-interface (open scheme external-calls + finite-types ;; for enumerated types xlib-types) (files visual)) diff --git a/scheme/xlib/xlib-type-interfaces.scm b/scheme/xlib/xlib-type-interfaces.scm index 076f2bc..ace0f2d 100644 --- a/scheme/xlib/xlib-type-interfaces.scm +++ b/scheme/xlib/xlib-type-interfaces.scm @@ -1,7 +1,8 @@ ;;; Helper functions (define-interface xlib-helper-interface - (export named-args->alist + (export make-enum-alist->vector + make-vector->enum-alist none-resource? none-resource alist-split @@ -127,4 +128,4 @@ xlib-cursor-type-interface xlib-visual-type-interface xlib-region-type-interface - )) \ No newline at end of file + ))