scsh-conservatory
/
scx
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

- 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).
This commit is contained in:
frese 2002-01-06 16:53:13 +00:00
parent ef23f9f7c7
commit b4f1bcad78
12 changed files with 961 additions and 837 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

267
c/xlib/client.c
View File

@ -1,5 +1,4 @@
#include "xlib.h" #include "xlib.h"
#include "scheme48.h"
s48_value scx_Iconify_Window (s48_value Xdisplay, s48_value w, s48_value scr) { s48_value scx_Iconify_Window (s48_value Xdisplay, s48_value w, s48_value scr) {
if (!XIconifyWindow (SCX_EXTRACT_DISPLAY(Xdisplay), 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 scx_Reconfigure_Wm_Window (s48_value dpy, s48_value w, s48_value scr,
s48_value conf) { s48_value conf) {
XWindowChanges WC; 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), if (!XReconfigureWMWindow (SCX_EXTRACT_DISPLAY(dpy),
SCX_EXTRACT_WINDOW(w), 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)); S48_VECTOR_SET(res, 2, SCX_ENTER_PIXMAP(p->icon_pixmap));
if (p->flags && IconWindowHint) if (p->flags && IconWindowHint)
S48_VECTOR_SET(res, 3, SCX_ENTER_WINDOW(p->icon_window)); S48_VECTOR_SET(res, 3, SCX_ENTER_WINDOW(p->icon_window));
if (p->flags && IconPositionHint) { if (p->flags && IconPositionHint)
S48_VECTOR_SET(res, 4, s48_enter_integer(p->icon_x)); S48_VECTOR_SET(res, 4, s48_cons(s48_enter_integer(p->icon_x),
S48_VECTOR_SET(res, 5, s48_enter_integer(p->icon_y)); s48_enter_integer(p->icon_y)));
}
if (p->flags && IconMaskHint) 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) if (p->flags && WindowGroupHint)
// Elk says a window-group is a window...?? // Elk says a window-group is a window...??
S48_VECTOR_SET(res, 7, SCX_ENTER_WINDOW(p->window_group)); S48_VECTOR_SET(res, 6, SCX_ENTER_WINDOW(p->window_group));
S48_VECTOR_SET(res, 8, S48_ENTER_BOOLEAN(p->flags && XUrgencyHint)); S48_VECTOR_SET(res, 7, S48_ENTER_BOOLEAN(p->flags & XUrgencyHint));
// XLib man-pages say this constant is called UrgencyHint !! // XLib man-pages say this constant is called UrgencyHint !!
S48_GC_UNPROTECT(); S48_GC_UNPROTECT();
@ -257,46 +255,45 @@ s48_value scx_Wm_Hints (s48_value dpy, s48_value w) {
return res; return res;
} }
s48_value scx_Set_Wm_Hints (s48_value dpy, s48_value w, s48_value alist) { s48_value scx_Set_Wm_Hints (s48_value dpy, s48_value w, s48_value hints) {
unsigned long mask = 0; long mask = 0;
s48_value l, p, v;
XWMHints WMH; XWMHints WMH;
char* cname; int i;
for (l = alist; !S48_NULL_P(l); l = S48_CDR(l)) { for (i=0; i<8; i++) {
p = S48_CAR(l); s48_value value = S48_VECTOR_REF(hints, i);
v = S48_CDR(p); if (S48_FALSE != value) {
cname = s48_extract_symbol(S48_CAR(p)); switch (i) {
if (strcmp(cname, "input?") == 0) { case 0: mask |= InputHint;
mask |= InputHint; WMH.input = (Bool)s48_extract_integer(value);
WMH.input = !S48_FALSE_P(v); break;
} else if (strcmp(cname, "initial-state") == 0) { case 1: mask |= StateHint;
mask |= StateHint; WMH.initial_state =
WMH.initial_state = Symbol_To_Bit((unsigned long)s48_extract_integer(v), Symbol_To_Bit(value,
Initial_State_Syms); Initial_State_Syms);
} else if (strcmp(cname, "icon-pixmap") == 0) { break;
mask |= IconPixmapHint; case 2: mask |= IconPixmapHint;
WMH.icon_pixmap = SCX_EXTRACT_PIXMAP(v); WMH.icon_pixmap = SCX_EXTRACT_PIXMAP(value);
} else if (strcmp(cname, "icon-window") == 0) { break;
mask |= IconWindowHint; case 3: mask |= IconWindowHint;
WMH.icon_window = SCX_EXTRACT_WINDOW(v); WMH.icon_window = SCX_EXTRACT_WINDOW(value);
} else if (strcmp(cname, "icon-x") == 0) { break;
mask |= IconPositionHint; case 4: mask |= IconPositionHint;
WMH.icon_x = (int)s48_extract_integer(v); WMH.icon_x = (int)s48_extract_integer(S48_CAR(value));
} else if (strcmp(cname, "icon-y") == 0) { WMH.icon_y = (int)s48_extract_integer(S48_CDR(value));
mask |= IconPositionHint; break;
WMH.icon_y = (int)s48_extract_integer(v); case 5: mask |= IconMaskHint;
} else if (strcmp(cname, "icon-mask") == 0) { WMH.icon_mask = SCX_EXTRACT_PIXMAP(value);
mask |= IconMaskHint; break;
WMH.icon_mask = SCX_EXTRACT_PIXMAP(v); case 6: mask |= WindowGroupHint;
} else if (strcmp(cname, "window-group") == 0) { WMH.window_group = SCX_EXTRACT_WINDOW(value);
mask |= WindowGroupHint; break;
WMH.window_group = SCX_EXTRACT_WINDOW(v); case 7: mask |= s48_extract_integer(value) ? XUrgencyHint : 0;
} else if (strcmp(cname, "urgency") == 0) {
mask |= XUrgencyHint;
// XLib man-pages say this constant is called UrgencyHint !! // XLib man-pages say this constant is called UrgencyHint !!
} }
} }
}
WMH.flags = mask;
XSetWMHints(SCX_EXTRACT_DISPLAY(dpy), XSetWMHints(SCX_EXTRACT_DISPLAY(dpy),
SCX_EXTRACT_WINDOW(w), SCX_EXTRACT_WINDOW(w),
@ -390,117 +387,103 @@ s48_value scx_Wm_Normal_Hints(s48_value dpy, s48_value win) {
&SH, &supplied)) &SH, &supplied))
SH.flags = 0; SH.flags = 0;
v = s48_make_vector(19, S48_NULL); v = s48_make_vector(10, S48_NULL);
S48_GC_PROTECT_1(v); S48_GC_PROTECT_1(v);
if ((SH.flags & PPosition) == PPosition) { if (((SH.flags & PPosition) != 0) || ((SH.flags & USPosition) != 0))
S48_VECTOR_SET(v, 0, s48_enter_integer(SH.x)); S48_VECTOR_SET(v, 2, s48_cons(s48_enter_integer(SH.x),
S48_VECTOR_SET(v, 1, s48_enter_integer(SH.y)); s48_enter_integer(SH.y)));
}
if ((SH.flags & PSize) == PSize) { if (((SH.flags & PSize) != 0) || ((SH.flags & USSize) != 0))
S48_VECTOR_SET(v, 2, s48_enter_integer(SH.width)); S48_VECTOR_SET(v, 3, s48_cons(s48_enter_integer(SH.width),
S48_VECTOR_SET(v, 3, s48_enter_integer(SH.height)); s48_enter_integer(SH.height)));
}
if ((SH.flags & USPosition) == USPosition) { if ((SH.flags & USPosition) != 0)
S48_VECTOR_SET(v, 0, s48_enter_integer(SH.x)); S48_VECTOR_SET(v, 0, S48_VECTOR_REF(v, 2));
S48_VECTOR_SET(v, 1, s48_enter_integer(SH.y));
S48_VECTOR_SET(v, 4, S48_TRUE); // us-position -> #t if ((SH.flags & USSize) != 0)
} S48_VECTOR_SET(v, 1, S48_VECTOR_REF(v, 3));
if ((SH.flags & USSize) == USSize) {
S48_VECTOR_SET(v, 2, s48_enter_integer(SH.width)); if ((SH.flags & PMinSize) != 0)
S48_VECTOR_SET(v, 3, s48_enter_integer(SH.height)); S48_VECTOR_SET(v, 4, s48_cons(s48_enter_integer(SH.min_width),
S48_VECTOR_SET(v, 5, S48_TRUE); // us-size -> #t s48_enter_integer(SH.min_height)));
}
if ((SH.flags & PMinSize) == PMinSize) { if ((SH.flags & PMaxSize) != 0)
S48_VECTOR_SET(v, 6, s48_enter_integer(SH.min_width)); S48_VECTOR_SET(v, 5, s48_cons(s48_enter_integer(SH.max_width),
S48_VECTOR_SET(v, 7, s48_enter_integer(SH.min_height)); s48_enter_integer(SH.max_height)));
}
if ((SH.flags & PMaxSize) == PMaxSize) { if ((SH.flags & PResizeInc) != 0)
S48_VECTOR_SET(v, 8, s48_enter_integer(SH.max_width)); S48_VECTOR_SET(v, 6, s48_cons(s48_enter_integer(SH.width_inc),
S48_VECTOR_SET(v, 9, s48_enter_integer(SH.max_height)); s48_enter_integer(SH.height_inc)));
}
if ((SH.flags & PResizeInc) == PResizeInc) { if ((SH.flags & PAspect) != 0)
S48_VECTOR_SET(v, 10, s48_enter_integer(SH.width_inc)); S48_VECTOR_SET(v, 7,
S48_VECTOR_SET(v, 11, s48_enter_integer(SH.height_inc)); s48_cons(s48_cons(s48_enter_integer(SH.min_aspect.x),
} s48_enter_integer(SH.min_aspect.y)),
if ((SH.flags & PAspect) == PAspect) { s48_cons(s48_enter_integer(SH.max_aspect.x),
S48_VECTOR_SET(v, 12, s48_enter_integer(SH.min_aspect.x)); s48_enter_integer(SH.max_aspect.y))));
S48_VECTOR_SET(v, 13, s48_enter_integer(SH.min_aspect.y));
S48_VECTOR_SET(v, 14, s48_enter_integer(SH.max_aspect.x)); if ((SH.flags & PBaseSize) != 0)
S48_VECTOR_SET(v, 15, s48_enter_integer(SH.max_aspect.y)); S48_VECTOR_SET(v, 8, s48_cons(s48_enter_integer(SH.base_width),
} s48_enter_integer(SH.base_height)));
if ((SH.flags & PBaseSize) == PBaseSize) {
S48_VECTOR_SET(v, 16, s48_enter_integer(SH.base_width)); if ((SH.flags & PWinGravity) != 0)
S48_VECTOR_SET(v, 17, s48_enter_integer(SH.base_height));
}
if ((SH.flags & PWinGravity) == PWinGravity) {
S48_VECTOR_SET(v, 18, Bit_To_Symbol(SH.win_gravity, Grav_Syms)); S48_VECTOR_SET(v, 18, Bit_To_Symbol(SH.win_gravity, Grav_Syms));
}
S48_GC_UNPROTECT(); S48_GC_UNPROTECT();
return v; return v;
} }
s48_value scx_Set_Wm_Normal_Hints(s48_value dpy, s48_value win, s48_value scx_Set_Wm_Normal_Hints(s48_value dpy, s48_value win,
s48_value alist) { s48_value hints) {
XSizeHints SH; XSizeHints SH;
long mask = 0; long mask = 0;
s48_value l; int i;
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);
if (strcmp(name, "x") == 0) { for (i=0; i<10; i++) {
mask |= PPosition; SH.x = s48_extract_integer(v); s48_value v = S48_VECTOR_REF(hints, i);
}
if (strcmp(name, "y") == 0) { switch (i) {
mask |= PPosition; SH.y = s48_extract_integer(v); case 0: mask |= USPosition;
} SH.x = s48_extract_integer(S48_CAR(v));
if (strcmp(name, "width") == 0) { SH.y = s48_extract_integer(S48_CDR(v));
mask |= PSize; SH.width = s48_extract_integer(v); break;
} case 1: mask |= USSize;
if (strcmp(name, "height") == 0) { SH.width = s48_extract_integer(S48_CAR(v));
mask |= PSize; SH.height = s48_extract_integer(v); SH.height = s48_extract_integer(S48_CDR(v));
} break;
if (strcmp(name, "min-width") == 0) { case 2: mask |= PPosition;
mask |= PMinSize; SH.min_width = s48_extract_integer(v); SH.x = s48_extract_integer(S48_CAR(v));
} SH.y = s48_extract_integer(S48_CDR(v));
if (strcmp(name, "min-height") == 0) { break;
mask |= PMinSize; SH.min_height = s48_extract_integer(v); case 3: mask |= PSize;
} SH.width = s48_extract_integer(S48_CAR(v));
if (strcmp(name, "max-width") == 0) { SH.height = s48_extract_integer(S48_CDR(v));
mask |= PMaxSize; SH.max_width = s48_extract_integer(v); break;
} case 4: mask |= PMinSize;
if (strcmp(name, "max-height") == 0) { SH.min_width = s48_extract_integer(S48_CAR(v));
mask |= PMaxSize; SH.max_height = s48_extract_integer(v); SH.min_height = s48_extract_integer(S48_CDR(v));
} break;
if (strcmp(name, "width-inc") == 0) { case 5: mask |= PMaxSize;
mask |= PResizeInc; SH.width_inc = s48_extract_integer(v); SH.max_width = s48_extract_integer(S48_CAR(v));
} SH.max_height = s48_extract_integer(S48_CDR(v));
if (strcmp(name, "height-inc") == 0) { break;
mask |= PResizeInc; SH.height_inc = s48_extract_integer(v); case 6: mask |= PResizeInc;
} SH.width_inc = s48_extract_integer(S48_CAR(v));
if (strcmp(name, "min-aspect-x") == 0) { SH.height_inc = s48_extract_integer(S48_CDR(v));
mask |= PAspect; SH.min_aspect.x = s48_extract_integer(v); break;
} case 7: mask |= PAspect;
if (strcmp(name, "min-aspect-y") == 0) { SH.min_aspect.x = s48_extract_integer(S48_CAR(S48_CAR(v)));
mask |= PAspect; SH.min_aspect.y = s48_extract_integer(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)));
if (strcmp(name, "max-aspect-x") == 0) { SH.max_aspect.y = s48_extract_integer(S48_CDR(S48_CDR(v)));
mask |= PAspect; SH.max_aspect.x = s48_extract_integer(v); break;
} case 8: mask |= PBaseSize;
if (strcmp(name, "max-aspect-y") == 0) { SH.base_width = s48_extract_integer(S48_CAR(v));
mask |= PAspect; SH.max_aspect.y = s48_extract_integer(v); SH.base_height = s48_extract_integer(S48_CDR(v));
} break;
if (strcmp(name, "base-width") == 0) { case 9: mask |= PWinGravity;
mask |= PBaseSize; SH.base_width = s48_extract_integer(v); SH.win_gravity = Symbol_To_Bit(v, Grav_Syms);
}
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);
} }
} }
SH.flags = mask; SH.flags = mask;

126
c/xlib/gcontext.c
View File

@ -1,97 +1,91 @@
#include "xlib.h" #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; unsigned long mask = 0;
s48_value l, p; int i;
char* cname; for (i=0; i<23; i++) {
s48_value name, value; s48_value value = S48_VECTOR_REF(values, i);
if (S48_FALSE != value) {
for (l = alist; !S48_NULL_P(l); l = S48_CDR(l)) { switch (i) {
p = S48_CAR(l); case 0: GCV->function = Symbol_To_Bit(value, Func_Syms);
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; mask |= GCFunction;
} else if (strcmp(cname, "plane-mask") == 0) { break;
GCV->plane_mask = SCX_EXTRACT_PIXEL(value); case 1: GCV->plane_mask = SCX_EXTRACT_PIXEL(value);
mask |= GCPlaneMask; mask |= GCPlaneMask;
} else if (strcmp(cname, "foreground") == 0) { break;
GCV->foreground = SCX_EXTRACT_PIXEL(value); case 2: GCV->foreground = SCX_EXTRACT_PIXEL(value);
mask |= GCForeground; mask |= GCForeground;
} else if (strcmp(cname, "background") == 0) { break;
GCV->background = SCX_EXTRACT_PIXEL(value); case 3: GCV->background = SCX_EXTRACT_PIXEL(value);
mask |= GCBackground; mask |= GCBackground;
} else if (strcmp(cname, "line-width") == 0) { break;
GCV->line_width = s48_extract_integer(value); case 4: GCV->line_style = Symbol_To_Bit(value,Line_Style_Syms);
mask |= GCLineWidth;
} else if (strcmp(cname, "line-style") == 0) {
GCV->line_style = Symbol_To_Bit(value,Line_Style_Syms);
mask |= GCLineStyle; mask |= GCLineStyle;
} else if (strcmp(cname, "cap-style") == 0) { break;
GCV->cap_style = Symbol_To_Bit(value, Cap_Style_Syms); case 5: GCV->cap_style = Symbol_To_Bit(value, Cap_Style_Syms);
mask |= GCCapStyle; mask |= GCCapStyle;
} else if (strcmp(cname, "join-style") == 0) { break;
GCV->join_style = Symbol_To_Bit(value, Join_Style_Syms); 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; mask |= GCJoinStyle;
} else if (strcmp(cname, "fill-style") == 0) { break;
GCV->fill_style = Symbol_To_Bit(value, Fill_Style_Syms); case 8: GCV->fill_style = Symbol_To_Bit(value, Fill_Style_Syms);
mask |= GCFillStyle; mask |= GCFillStyle;
} else if (strcmp(cname, "fill-rule") == 0) { break;
GCV->fill_rule = Symbol_To_Bit(value, Fill_Rule_Syms); case 9: GCV->fill_rule = Symbol_To_Bit(value, Fill_Rule_Syms);
mask |= GCFillRule; mask |= GCFillRule;
} else if (strcmp(cname, "arc-mode") == 0) { break;
GCV->arc_mode = Symbol_To_Bit(value, Arc_Mode_Syms); case 10: GCV->tile = SCX_EXTRACT_PIXMAP(value);
mask |= GCArcMode;
} else if (strcmp(cname, "tile") == 0) {
GCV->tile = SCX_EXTRACT_PIXMAP(value);
mask |= GCTile; mask |= GCTile;
} else if (strcmp(cname, "stipple") == 0) { break;
GCV->stipple = SCX_EXTRACT_PIXMAP(value); case 11: GCV->stipple = SCX_EXTRACT_PIXMAP(value);
mask |= GCStipple; mask |= GCStipple;
} else if (strcmp(cname, "ts-x") == 0) { break;
GCV->ts_x_origin = s48_extract_integer(value); case 12: GCV->ts_x_origin = s48_extract_integer(value);
mask |= GCTileStipXOrigin; mask |= GCTileStipXOrigin;
} else if (strcmp(cname, "ts-y") == 0) { break;
GCV->ts_y_origin = s48_extract_integer(value); case 13: GCV->ts_y_origin = s48_extract_integer(value);
mask |= GCTileStipYOrigin; mask |= GCTileStipYOrigin;
} else if (strcmp(cname, "font") == 0) { break;
GCV->font = SCX_EXTRACT_FONT(value); case 14: GCV->font = SCX_EXTRACT_FONT(value);
mask |= GCFont; mask |= GCFont;
} else if (strcmp(cname, "subwindow-mode") == 0) { break;
GCV->subwindow_mode = Symbol_To_Bit(value, Subwin_Mode_Syms); case 15: GCV->subwindow_mode = Symbol_To_Bit(value, Subwin_Mode_Syms);
mask |= GCSubwindowMode; mask |= GCSubwindowMode;
} else if (strcmp(cname, "exposures") == 0) { break;
GCV->graphics_exposures = !S48_FALSE_P(value); case 16: GCV->graphics_exposures = !S48_FALSE_P(value);
mask |= GCGraphicsExposures; mask |= GCGraphicsExposures;
} else if (strcmp(cname, "clip-x") == 0) { break;
GCV->clip_x_origin = s48_extract_integer(value); case 17: GCV->clip_x_origin = s48_extract_integer(value);
mask |= GCClipXOrigin; mask |= GCClipXOrigin;
} else if (strcmp(cname, "clip-y") == 0) { break;
GCV->clip_y_origin = s48_extract_integer(value); case 18: GCV->clip_y_origin = s48_extract_integer(value);
mask |= GCClipYOrigin; mask |= GCClipYOrigin;
} else if (strcmp(cname, "clip-mask") == 0) { break;
GCV->clip_mask = SCX_EXTRACT_PIXMAP(value); case 19: GCV->clip_mask = SCX_EXTRACT_PIXMAP(value);
mask |= GCClipMask; mask |= GCClipMask;
} else if (strcmp(cname, "dash-offset") == 0) { break;
GCV->dash_offset = s48_extract_integer(value); case 20: GCV->dash_offset = s48_extract_integer(value);
mask |= GCDashOffset; mask |= GCDashOffset;
} else if (strcmp(cname, "dashes") == 0) { break;
GCV->dashes = (char)s48_extract_integer(value); case 21: GCV->dashes = (char)s48_extract_integer(value);
mask |= GCDashList; mask |= GCDashList;
break;
case 22: GCV->arc_mode = Symbol_To_Bit(value, Arc_Mode_Syms);
mask |= GCArcMode;
break;
}
}
} }
// else error ??
} // for
return mask; 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; 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), GC Xgcontext = XCreateGC(SCX_EXTRACT_DISPLAY(Xdisplay),
SCX_EXTRACT_DRAWABLE(Xdrawable), 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) { s48_value scx_Change_Gc (s48_value Xgcontext, s48_value Xdisplay, s48_value args) {
XGCValues GCV; 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), XChangeGC(SCX_EXTRACT_DISPLAY(Xdisplay), SCX_EXTRACT_GCONTEXT(Xgcontext),
mask, &GCV); mask, &GCV);

10
c/xlib/type.c
View File

@ -521,13 +521,13 @@ SYMDESCR Gcontext_Values_Syms[] = {
{ "arc-mode", GCArcMode }, { "arc-mode", GCArcMode },
{ "tile", GCTile }, { "tile", GCTile },
{ "stipple", GCStipple }, { "stipple", GCStipple },
{ "ts-x", GCTileStipXOrigin }, { "ts-x-origin", GCTileStipXOrigin },
{ "ts-y", GCTileStipYOrigin }, { "ts-y-origin", GCTileStipYOrigin },
{ "font", GCFont }, { "font", GCFont },
{ "subwindow-mode", GCSubwindowMode }, { "subwindow-mode", GCSubwindowMode },
{ "exposures", GCGraphicsExposures }, { "graphics-exposures", GCGraphicsExposures },
{ "clip-x", GCClipXOrigin }, { "clip-x-origin", GCClipXOrigin },
{ "clip-y", GCClipYOrigin }, { "clip-y-origin", GCClipYOrigin },
{ "clip-mask", GCClipMask }, { "clip-mask", GCClipMask },
{ "dash-offset", GCDashOffset }, { "dash-offset", GCDashOffset },
{ "dashes", GCDashList }, { "dashes", GCDashList },

237
c/xlib/window.c
View File

@ -1,114 +1,95 @@
#include "xlib.h" #include "xlib.h"
#include "scheme48.h"
unsigned long AList_To_XSetWindowAttributes(s48_value attrAlist, unsigned long Attribs_To_XSetWindowAttributes(s48_value attribs,
XSetWindowAttributes* Xattrs) { XSetWindowAttributes* Xattrs) {
unsigned long mask = 0; int i; unsigned long mask = 0;
s48_value l; for (i=0; i<15; i++) {
s48_value p; s48_value value = S48_VECTOR_REF(attribs, i);
char* cname; if (S48_FALSE != value) {
s48_value name, value; switch (i) {
case 0: Xattrs->background_pixmap =
for (l = attrAlist; !S48_NULL_P(l); l = S48_CDR(l)) { S48_SYMBOL_P(value) ? ParentRelative : SCX_EXTRACT_PIXMAP(value);
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; mask |= CWBackPixmap;
} else if (strcmp(cname, "background-pixel") == 0) { break;
Xattrs->background_pixel = s48_extract_integer(value); case 1: Xattrs->background_pixel = s48_extract_integer(value);
mask |= CWBackPixel; mask |= CWBackPixel;
} else if (strcmp(cname, "border-pixmap") == 0) { break;
Xattrs->border_pixmap = extract_border(value); case 2: Xattrs->border_pixmap =
S48_SYMBOL_P(value) ? CopyFromParent : s48_extract_integer(value);
mask |= CWBorderPixmap; mask |= CWBorderPixmap;
} else if (strcmp(cname, "border-pixel") == 0) { break;
Xattrs->border_pixel = s48_extract_integer(value); case 3: 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; mask |= CWBitGravity;
} else if (strcmp(cname, "gravity") == 0) { break;
Xattrs->win_gravity = Symbol_To_Bit(value, Grav_Syms); 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; mask |= CWWinGravity;
} else if (strcmp(cname, "backing-store") == 0) { break;
Xattrs->backing_store = Symbol_To_Bit(value, Backing_Store_Syms); case 6: Xattrs->backing_store = Symbol_To_Bit(value, Backing_Store_Syms);
mask |= CWBackingStore; mask |= CWBackingStore;
} else if (strcmp(cname, "backing-planes") == 0) { break;
Xattrs->backing_planes = s48_extract_integer(value); case 7: Xattrs->backing_planes = s48_extract_integer(value);
mask |= CWBackingPlanes; mask |= CWBackingPlanes;
} else if (strcmp(cname, "backing-pixel") == 0) { break;
Xattrs->backing_pixel = s48_extract_integer(value); case 8: Xattrs->backing_pixel = s48_extract_integer(value);
mask |= CWBackingPixel; mask |= CWBackingPixel;
} else if (strcmp(cname, "save-under") == 0) { break;
Xattrs->save_under = !S48_FALSE_P(value); case 9: Xattrs->override_redirect = s48_extract_integer(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; mask |= CWOverrideRedirect;
} else if (strcmp(cname, "colormap") == 0) { break;
Xattrs->colormap = s48_extract_integer(value); 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; mask |= CWColormap;
} else if (strcmp(cname, "cursor") == 0) { break;
Xattrs->cursor = s48_extract_integer(value); case 14: Xattrs->cursor = s48_extract_integer(value);
mask |= CWCursor; mask |= CWCursor;
} // else error ?? break;
} /* for */ }
}
}
return mask; return mask;
} }
int extract_background(s48_value value) { s48_value scx_Create_Window (s48_value Xdisplay, s48_value Xparent,
if (S48_SYMBOL_P(value)) { s48_value x, s48_value y,
char* v = s48_extract_string(S48_SYMBOL_TO_STRING(value)); s48_value width, s48_value height,
if (strcmp(v, "none") == 0) s48_value border_width, s48_value depth,
return None; s48_value class, s48_value Xvisual,
else if (strcmp(v, "parent-relative") == 0) s48_value attribs) {
return ParentRelative;
//else // error ...
}
return SCX_EXTRACT_PIXMAP(value);
}
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 );
Window win; 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 : Visual* vis = S48_FALSE_P(Xvisual) ? CopyFromParent :
SCX_EXTRACT_VISUAL(Xvisual); 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(x),
(int)s48_extract_integer(y), (int)s48_extract_integer(y),
(int)s48_extract_integer (width), (int)s48_extract_integer (width),
(int)s48_extract_integer (height), (int)s48_extract_integer (height),
(int)s48_extract_integer (border_width), (int)s48_extract_integer (border_width),
CopyFromParent, dep, cla, vis,
CopyFromParent, mask,&Xattrs );
vis,
mask,
&Xattrs );
return SCX_ENTER_WINDOW(win); 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 scx_Change_Window_Attributes(s48_value Xwindow, s48_value Xdisplay,
s48_value attrAlist) { s48_value attribs) {
XSetWindowAttributes Xattrs; 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), XChangeWindowAttributes(SCX_EXTRACT_DISPLAY(Xdisplay),
SCX_EXTRACT_WINDOW(Xwindow),
mask, &Xattrs); mask, &Xattrs);
return S48_UNSPECIFIC; return S48_UNSPECIFIC;
} }
s48_value scx_Get_Window_Attributes(s48_value Xdisplay, s48_value Xwindow) { s48_value scx_Get_Window_Attributes(s48_value Xdisplay, s48_value Xwindow) {
XWindowAttributes WA; XWindowAttributes WA;
@ -169,57 +153,50 @@ 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, S48_VECTOR_SET(res, 20, Bits_To_Symbols( WA.do_not_propagate_mask,
Event_Mask_Syms )); Event_Mask_Syms ));
S48_VECTOR_SET(res, 21, WA.override_redirect ? S48_TRUE : S48_FALSE); 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(); S48_GC_UNPROTECT();
return res; return res;
} }
unsigned long AList_To_XWindowChanges(s48_value alist, XWindowChanges* WC) { s48_value Changes_To_XWindowChanges(s48_value changes, XWindowChanges* WC) {
unsigned long mask = 0; int i; unsigned long mask = 0;
s48_value l, p; for (i=0; i<7; i++) {
char* cname; s48_value value = S48_VECTOR_REF(changes, i);
int cvalue; if (S48_FALSE != value) {
s48_value name, value; switch (i) {
for (l = alist; !S48_NULL_P(l); l = S48_CDR(l)) { case 0: WC->x = s48_extract_integer(value);
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; mask |= CWX;
} else if (strcmp(cname, "y") == 0) { break;
WC->y = cvalue; case 2: WC->y = s48_extract_integer(value);
mask |= CWY; mask |= CWY;
} else if (strcmp(cname, "width") == 0) { break;
WC->width = cvalue; case 3: WC->width = s48_extract_integer(value);
mask |= CWWidth; mask |= CWWidth;
} else if (strcmp(cname, "height") == 0) { break;
WC->height = cvalue; case 4: WC->height = s48_extract_integer(value);
mask |= CWHeight; mask |= CWHeight;
} else if (strcmp(cname, "border-width") == 0) { break;
WC->border_width = cvalue; case 5: WC->sibling = SCX_EXTRACT_WINDOW(value);
mask |= CWBorderWidth;
} else if (strcmp(cname, "sibling") == 0) {
WC->sibling = (Window)s48_extract_integer(value);
mask |= CWSibling; mask |= CWSibling;
} else if (strcmp(cname, "stack-mode") == 0) { break;
WC->stack_mode = cvalue; case 6: WC->stack_mode = Symbol_To_Bit(value, Stack_Mode_Syms);
mask |= CWStackMode; mask |= CWStackMode;
break;
}
}
} }
} // for
return mask; return mask;
} }
s48_value scx_Configure_Window (s48_value Xwindow, s48_value Xdisplay, s48_value scx_Configure_Window (s48_value Xwindow, s48_value Xdisplay,
s48_value alist) { s48_value changes) {
XWindowChanges WC; 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); mask, &WC);
@ -258,22 +235,6 @@ s48_value scx_Circulate_Subwindows(s48_value Xwindow, s48_value Xdisplay,
return S48_UNSPECIFIC; 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) { s48_value scx_Query_Tree (s48_value Xwindow, s48_value Xdisplay) {
Window root, parent, *children; Window root, parent, *children;
int i; int i;

168
scheme/xlib/client.scm
View File

@ -33,22 +33,24 @@
;; the root window if that fails. See XReconfigureWMWindow. See ;; the root window if that fails. See XReconfigureWMWindow. See
;; configure-window. ;; 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) (check-screen-number screen-number)
(if (not (%reconfigure-wm-window (display-Xdisplay (window-display window)) (if (not (%reconfigure-wm-window (display-Xdisplay (window-display window))
(window-Xwindow window) (window-Xwindow window)
screen-number screen-number
(named-args->alist args))) (window-change-alist->vector
window-change-alist)))
(error "cannot reconfigure window" (error "cannot reconfigure window"
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") "scx_Reconfigure_Wm_Window")
;; wm-command reads the WM_COMMAND property from the specified window ;; get-wm-command reads the WM_COMMAND property from the specified
;; and returns is as a list of strings. See XGetCommand. ;; 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)) (vector->list (%wm-command (display-Xdisplay (window-display window))
(window-Xwindow window)))) (window-Xwindow window))))
@ -101,12 +103,12 @@
(import-lambda-definition %set-text-property! (Xdisplay Xwindow value XAtom) (import-lambda-definition %set-text-property! (Xdisplay Xwindow value XAtom)
"scx_Set_Text_Property") "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 ;; WM_PROTOCOLS property on the specified window. These atoms describe
;; window manager protocols in which the owner of this window is ;; window manager protocols in which the owner of this window is
;; willing to participate. See XGetWMProtocols. ;; willing to participate. See XGetWMProtocols.
(define (wm-protocols window) (define (get-wm-protocols window)
(let ((res (%wm-protocols (display-Xdisplay (window-display window)) (let ((res (%wm-protocols (display-Xdisplay (window-display window))
(window-Xwindow window)))) (window-Xwindow window))))
(if res (if res
@ -131,10 +133,10 @@
(import-lambda-definition %set-wm-protocols! (Xdisplay Xwindow protocols) (import-lambda-definition %set-wm-protocols! (Xdisplay Xwindow protocols)
"scx_Set_Wm_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. ;; XGetClassHint.
(define (wm-class window) (define (get-wm-class window)
(let ((res (%wm-class (display-Xdisplay (window-display window)) (let ((res (%wm-class (display-Xdisplay (window-display window))
(window-Xwindow window)))) (window-Xwindow window))))
(if res (if res
@ -160,61 +162,73 @@
(import-lambda-definition %set-wm-class! (Xdisplay Xwindow name class) (import-lambda-definition %set-wm-class! (Xdisplay Xwindow name class)
"scx_Set_Wm_Class") "scx_Set_Wm_Class")
;; wm-hints reads the window manager hints and returns them as an ;; enumerated type for the XWMHints type. used by set-wm-hints! and
;; alist mapping symbols to specific values. The hints are: 'input? ;; get-wm-hints.
;; 'initial-state 'icon-pixmap 'icon-window 'icon-x 'icon-y 'icon-mask
;; 'window-group 'urgency. See XGetWMHints for a description.
(define (wm-hints window) (define-enumerated-type wm-hint :wm-hint
(let ((res (%wm-hints (display-Xdisplay (window-display window)) wm-hint?
(window-Xwindow window))) wm-hints
(make-window* (lambda (Xwindow) wm-hint-name
(if (null? Xwindow) wm-hint-index
Xwindow (input? initial-state icon-pixmap icon-window icon-position icon-mask
(make-window Xwindow (window-display window) window-group urgency))
#f))))
(make-pixmap* (lambda (Xpixmap) (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) (if (null? Xpixmap)
Xpixmap '()
(make-pixmap Xpixmap (window-display window) (make-pixmap Xpixmap display #f))))
#f))))) ((3 6) (lambda (Xwindow)
(vector-set! res 2 (make-pixmap* (vector-ref res 2))) (if (null? Xwindow)
(vector-set! res 3 (make-window* (vector-ref res 3))) '()
(vector-set! res 6 (make-pixmap* (vector-ref res 6))) (make-window Xwindow display #f))))
(vector-set! res 7 (make-window* (vector-ref res 7))) (else (lambda (x) x))))))
(map cons
'(input? initial-state icon-pixmap icon-window icon-x icon-y ;; get-wm-hints reads the window manager hints and returns them as an
icon-mask window-group urgency) ;; alist mapping wm-hint types to specific values. If a hints is not
(vector->list res)))) ;; 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))))
(filter (lambda (x) (not (null? (cdr x))))
(vector->wm-hint-alist res (window-display window)))))
(import-lambda-definition %wm-hints (Xdisplay Xwindow) (import-lambda-definition %wm-hints (Xdisplay Xwindow)
"scx_Wm_Hints") "scx_Wm_Hints")
;; set-wm-hints! sets the specified window manager hints. The hints ;; set-wm-hints! sets the specified window manager hints. The hints
;; must be specified together with their names. Either by giving two ;; must be specified as an alist of wm-hint values (see above) mapping
;; parameter 'name value, or the last argument may be an alist, as ;; to the appropiate values. See XSetWMHints.
;; returned by wm-hints. See XSetWMHints.
(define (set-wm-hints! window . args) (define (set-wm-hints! window wm-hint-alist)
(%set-wm-hints! (display-Xdisplay (window-display window)) (%set-wm-hints! (display-Xdisplay (window-display window))
(window-Xwindow window) (window-Xwindow window)
(map (lambda (p) (wm-hint-alist->vector wm-hint-alist)))
(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))))
(import-lambda-definition %set-wm-hints! (Xdisplay Xwindow args) (import-lambda-definition %set-wm-hints! (Xdisplay Xwindow args)
"scx_Set_Wm_Hints") "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 ;; specified window. The value of that property is a window. See
;; XGetTransientForHint. ;; XGetTransientForHint.
(define (transient-for window) (define (get-transient-for window)
(make-window (%transient-for (display-Xdisplay (window-display window)) (make-window (%transient-for (display-Xdisplay (window-display window))
(window-Xwindow window)) (window-Xwindow window))
(window-display window) (window-display window)
@ -243,13 +257,13 @@
(define xa-wm-icon-name (make-atom 37)) (define xa-wm-icon-name (make-atom 37))
(define xa-wm-client-machine (make-atom 36)) (define xa-wm-client-machine (make-atom 36))
(define (wm-name w) (define (get-wm-name w)
(get-text-property w xa-wm-name)) (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)) (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)) (get-text-property w xa-wm-client-machine))
(define (set-wm-name! w s) (define (set-wm-name! w s)
@ -261,44 +275,64 @@
(define (set-wm-client-machine! w s) (define (set-wm-client-machine! w s)
(set-text-property! w s xa-wm-client-machine)) (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 ;; stored in the WM_NORMAL_HINTS property on the specified window. The
;; hints are '(x y width height us-position us-size min-width ;; 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-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 ;; min-aspect-y max-aspect-x max-aspect-y base-width base-height
;; gravity). See XGetWMNormalHints, XSetWMNormalHints. ;; 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)) (let* ((v (%wm-normal-hints (display-Xdisplay (window-display window))
(window-Xwindow window))) (window-Xwindow window))))
(alist (map cons (filter (lambda (x) (not (null? (cdr x))))
'(x y width height us-position us-size (vector->size-hint-alist v #f))))
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))
(import-lambda-definition %wm-normal-hints (Xdisplay Xwindow) (import-lambda-definition %wm-normal-hints (Xdisplay Xwindow)
"scx_Wm_Normal_Hints") "scx_Wm_Normal_Hints")
(define (set-wm-normal-hints! window . args) (define (set-wm-normal-hints! window size-hint-alist)
(let ((alist (named-args->alist args)))
(%set-wm-normal-hints! (display-Xdisplay (window-Xwindow window)) (%set-wm-normal-hints! (display-Xdisplay (window-Xwindow window))
(window-Xwindow window) (window-Xwindow window)
alist))) (size-hint-alist->vector size-hint-alist)))
(import-lambda-definition %set-wm-normal-hints! (Xdisplay Xwindow alist) (import-lambda-definition %set-wm-normal-hints! (Xdisplay Xwindow alist)
"scx_Set_Wm_Normal_Hints") "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 ;; 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 ;; size itself is a list consisting of integers meaning '(min-width
;; min-height max-width max-height width-inc height-inc). See ;; min-height max-width max-height width-inc height-inc). See
;; XGetIconSizes. ;; XGetIconSizes.
(define (icon-sizes window) (define (get-icon-sizes window)
(let ((r (%icon-sizes (display-Xdisplay (window-display window)) (let ((r (%icon-sizes (display-Xdisplay (window-display window))
(window-Xwindow window)))) (window-Xwindow window))))
(map vector->list (map vector->list

250
scheme/xlib/gcontext.scm
View File

@ -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 ;; create-gcontext returns a newly create graphic context for the
;; specified drawable (a window or a pixmap). Optional arguments are ;; specified drawable (a window or a pixmap). The gc-value-alist has
;; all attributes that can be set by the set-gcontext-xyz! functions ;; to be an alist mapping a gc-value (defined above) to a
;; below. They can be specified by name: 'function 'xor. Or the last ;; corresponding value. See XCreateGC.
;; argument can be an alist of such mappings. See XCreateGC.
(define (create-gcontext drawable . args) (define (create-gcontext drawable gc-value-alist)
(let ((alist (named-args->alist args))) (let ((display (drawable-display drawable))
(let* ((rest (map cons (Xobject (drawable-Xobject drawable))
(map car alist) (values (gc-value-alist->vector gc-value-alist)))
(map (lambda (obj) (let ((Xgcontext (%create-gcontext (display-Xdisplay display)
(cond Xobject
((pixel? obj) (pixel-Xpixel obj)) values)))
((font? obj) (font-Xfont obj)) (make-gcontext Xgcontext display #t))))
((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)))))
(import-lambda-definition %create-gcontext (Xdisplay Xdrawable alist) (import-lambda-definition %create-gcontext (Xdisplay Xdrawable values)
"scx_Create_Gc") "scx_Create_Gc")
;; copy-gcontext returns a newly create duplicate of the given ;; copy-gcontext returns a newly create duplicate of the given
;; gcontext, and assigns it to the specified drawable. See XCopyGC. ;; gcontext, and assigns it to the specified drawable. See XCopyGC.
(define (copy-gcontext gcontext drawable) (define (copy-gcontext gcontext drawable)
(let* ((new-gcontext (create-gcontext 'drawable drawable)) (let* ((new-gcontext (create-gcontext drawable '()))
(new-Xgcontext (gcontext-Xgcontext new-gcontext)) (new-Xgcontext (gcontext-Xgcontext new-gcontext))
(Xgcontext (gcontext-Xgcontext gcontext)) (Xgcontext (gcontext-Xgcontext gcontext))
(Xdisplay (display-Xdisplay (gcontext-display gcontext)))) (Xdisplay (display-Xdisplay (gcontext-display gcontext))))
@ -39,25 +53,25 @@
"scx_Copy_Gc") "scx_Copy_Gc")
;; copy-gcontext! copies the specified attributes from gc-from to ;; copy-gcontext! copies the specified attributes from gc-from to
;; gc-to. The attributes have to be a list of the names in the ;; gc-to. The attributes have to be a list of gc-values as defined
;; set-gcontext-*! functions. If that argument is not specified, then ;; above. if no gc-values list is specified, then all attributes are
;; all atributes are copied. See XCopyGC. ;; copied. See XCopyGC.
(define (copy-gcontext! gc-from gc-to . attributes) (define (copy-gcontext! gc-from gc-to . maybe-gc-values)
(let ((attributes (if (null? attributes) (let ((gc-values (if (null? maybe-gc-values)
'all 'all
(car attributes)))) (map gc-value-name (car maybe-gc-values)))))
(%copy-gcontext! (display-Xdisplay (gcontext-display gc-from)) (%copy-gcontext! (display-Xdisplay (gcontext-display gc-from))
(gcontext-Xgcontext gc-from) (gcontext-Xgcontext gc-from)
(gcontext-Xgcontext gc-to) (gcontext-Xgcontext gc-to)
attributes))) gc-values)))
(import-lambda-definition %copy-gcontext! (Xdisplay Xfrom Xto attrs) (import-lambda-definition %copy-gcontext! (Xdisplay Xfrom Xto attrs)
"scx_Copy_Gc_To_Gc") "scx_Copy_Gc_To_Gc")
;; get-gontext-values returns an alist of all attributes for the ;; get-gontext-values returns an alist of all attributes for the
;; specified graphic context. See the gcontext-xyz functions ;; specified graphic context. See the gc-value and create-gcontext
;; below. See XGetGCValues. ;; above. See XGetGCValues.
(define (get-gcontext-values gcontext) (define (get-gcontext-values gcontext)
(let* ((Xgcontext (gcontext-Xgcontext gcontext)) (let* ((Xgcontext (gcontext-Xgcontext gcontext))
@ -66,66 +80,54 @@
(let ((vals (%get-gcontext-values Xgcontext Xdisplay))) (let ((vals (%get-gcontext-values Xgcontext Xdisplay)))
(if (not vals) (if (not vals)
(error "cannot get gcontext values." gcontext) (error "cannot get gcontext values." gcontext)
(let* (vector->gc-value-alist vals display)))))
((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)))))
(import-lambda-definition %get-gcontext-values (Xgcontext Xdisplay) (import-lambda-definition %get-gcontext-values (Xgcontext Xdisplay)
"scx_Get_Gc_Values") "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) (define (make-gcontext-getter name)
(lambda (gcontext) (lambda (gcontext)
(cdr (assq name (get-gcontext-values gcontext))))) (cdr (assq name (get-gcontext-values gcontext)))))
(define gcontext-function (make-gcontext-getter 'function)) (define gcontext-function (make-gcontext-getter (gc-value function)))
(define gcontext-plane-mask (make-gcontext-getter 'plane-mask)) (define gcontext-plane-mask (make-gcontext-getter (gc-value plane-mask)))
(define gcontext-foreground (make-gcontext-getter 'foreground)) (define gcontext-foreground (make-gcontext-getter (gc-value foreground)))
(define gcontext-background (make-gcontext-getter 'background)) (define gcontext-background (make-gcontext-getter (gc-value background)))
(define gcontext-line-width (make-gcontext-getter 'line-width)) (define gcontext-line-width (make-gcontext-getter (gc-value line-width)))
(define gcontext-line-style (make-gcontext-getter 'line-style)) (define gcontext-line-style (make-gcontext-getter (gc-value line-style)))
(define gcontext-cap-style (make-gcontext-getter 'cap-style)) (define gcontext-cap-style (make-gcontext-getter (gc-value cap-style)))
(define gcontext-join-style (make-gcontext-getter 'join-style)) (define gcontext-join-style (make-gcontext-getter (gc-value join-style)))
(define gcontext-fill-style (make-gcontext-getter 'fill-style)) (define gcontext-fill-style (make-gcontext-getter (gc-value fill-style)))
(define gcontext-fill-rule (make-gcontext-getter 'fill-rule)) (define gcontext-fill-rule (make-gcontext-getter (gc-value fill-rule)))
(define gcontext-arc-mode (make-gcontext-getter 'arc-mode)) (define gcontext-arc-mode (make-gcontext-getter (gc-value arc-mode)))
(define gcontext-tile (make-gcontext-getter 'tile)) (define gcontext-tile (make-gcontext-getter (gc-value tile)))
(define gcontext-stipple (make-gcontext-getter 'stipple)) (define gcontext-stipple (make-gcontext-getter (gc-value stipple)))
(define gcontext-ts-x (make-gcontext-getter 'ts-x)) (define gcontext-ts-x-origin (make-gcontext-getter (gc-value ts-x-origin)))
(define gcontext-ts-y (make-gcontext-getter 'ts-y)) (define gcontext-ts-y-origin (make-gcontext-getter (gc-value ts-y-origin)))
(define gcontext-font (make-gcontext-getter 'font)) (define gcontext-font (make-gcontext-getter (gc-value font)))
(define gcontext-subwindow-mode (make-gcontext-getter 'subwindow-mode)) (define gcontext-subwindow-mode
(define gcontext-exposures (make-gcontext-getter 'exposures)) (make-gcontext-getter (gc-value subwindow-mode)))
(define gcontext-clip-x (make-gcontext-getter 'clip-x)) (define gcontext-graphics-exposures
(define gcontext-clip-y (make-gcontext-getter 'clip-y)) (make-gcontext-getter (gc-value graphics-exposures)))
(define gcontext-clip-mask (make-gcontext-getter 'clip-mask)) (define gcontext-clip-x-origin (make-gcontext-getter (gc-value clip-x-origin)))
(define gcontext-dash-offset (make-gcontext-getter 'dash-offset)) (define gcontext-clip-y-origin (make-gcontext-getter (gc-value clip-y-origin)))
(define gcontext-dashes (make-gcontext-getter 'dashes)) (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 ;; Alternative definition of gcontext-font. See XGcontextFromGC
; ;
@ -143,23 +145,10 @@
;; context. The format of the arguments is like for ;; context. The format of the arguments is like for
;; create-gcontext. See XChangeGC. ;; create-gcontext. See XChangeGC.
(define (change-gcontext gcontext . attrs) (define (change-gcontext gcontext gc-value-alist)
(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) (%change-gcontext (gcontext-Xgcontext gcontext)
(display-Xdisplay (gcontext-display gcontext)) (display-Xdisplay (gcontext-display gcontext))
prep-alist))) (gc-value-alist->vector gc-value-alist)))
(import-lambda-definition %change-gcontext (Xgcontext Xdisplay args) (import-lambda-definition %change-gcontext (Xgcontext Xdisplay args)
"scx_Change_Gc") "scx_Change_Gc")
@ -168,29 +157,48 @@
(lambda (gcontext value) (lambda (gcontext value)
(change-gcontext gcontext (list (cons name value))))) (change-gcontext gcontext (list (cons name value)))))
(define set-gcontext-function! (make-gcontext-setter 'function)) (define set-gcontext-function!
(define set-gcontext-plane-mask! (make-gcontext-setter 'plane-mask)) (make-gcontext-setter (gc-value function)))
(define set-gcontext-foreground! (make-gcontext-setter 'foreground)) (define set-gcontext-plane-mask!
(define set-gcontext-background! (make-gcontext-setter 'background)) (make-gcontext-setter (gc-value plane-mask)))
(define set-gcontext-line-width! (make-gcontext-setter 'line-width)) (define set-gcontext-foreground!
(define set-gcontext-line-style! (make-gcontext-setter 'line-style)) (make-gcontext-setter (gc-value foreground)))
(define set-gcontext-cap-style! (make-gcontext-setter 'cap-style)) (define set-gcontext-background!
(define set-gcontext-join-style! (make-gcontext-setter 'join-style)) (make-gcontext-setter (gc-value background)))
(define set-gcontext-fill-style! (make-gcontext-setter 'fill-style)) (define set-gcontext-line-width!
(define set-gcontext-fill-rule! (make-gcontext-setter 'fill-rule)) (make-gcontext-setter (gc-value line-width)))
(define set-gcontext-arc-mode! (make-gcontext-setter 'arc-mode)) (define set-gcontext-line-style!
(define set-gcontext-tile! (make-gcontext-setter 'tile)) (make-gcontext-setter (gc-value line-style)))
(define set-gcontext-stipple! (make-gcontext-setter 'stipple)) (define set-gcontext-cap-style!
(define set-gcontext-ts-x! (make-gcontext-setter 'ts-x)) (make-gcontext-setter (gc-value cap-style)))
(define set-gcontext-ts-y! (make-gcontext-setter 'ts-y)) (define set-gcontext-join-style!
(define set-gcontext-font! (make-gcontext-setter 'font)) (make-gcontext-setter (gc-value join-style)))
(define set-gcontext-subwindow-mode! (make-gcontext-setter 'subwindow-mode)) (define set-gcontext-fill-style!
(define set-gcontext-exposures! (make-gcontext-setter 'exposures)) (make-gcontext-setter (gc-value fill-style)))
(define set-gcontext-clip-x! (make-gcontext-setter 'clip-x)) (define set-gcontext-fill-rule!
(define set-gcontext-clip-y! (make-gcontext-setter 'clip-y)) (make-gcontext-setter (gc-value fill-rule)))
(define set-gcontext-clip-mask! (make-gcontext-setter 'clip-mask)) (define set-gcontext-arc-mode! (make-gcontext-setter (gc-value arc-mode)))
(define set-gcontext-dash-offset! (make-gcontext-setter 'dash-offset)) (define set-gcontext-tile! (make-gcontext-setter (gc-value tile)))
(define set-gcontext-dashes! (make-gcontext-setter 'dashes)) (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 ;; set-dashlist! is a more complex form of set-dashes!. (set-dashes! N) is
;; equivalent to (set-dash-list! .. #(N N)) ;; equivalent to (set-dash-list! .. #(N N))

53
scheme/xlib/helper.scm
View File

@ -1,20 +1,43 @@
;; named-args->alist does this: ;; make-enum-alist->vector creates a function that converts an
;; '(a 5 b 6 ((c . 10) (d . 5))) -> '((a . 5) (b . 6) (c . 10) (d . 5)) ;; association list, that maps from an enumerated type to some values,
;; '(e 3) -> '((e . 3)) ;; into a vector. The vector element i contains #f if the
;; '((f . 0)) -> '((f . 0)) ;; corresponding element i of the enumerated type was not defined in
;; (hard to explain :-) ;; 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) (define (make-enum-alist->vector enum-vector index-fun converter)
(let loop ((alist '()) (lambda (alist)
(args args)) (let ((res (make-vector (vector-length enum-vector) #f)))
(cond (for-each (lambda (a)
((null? args) (reverse alist)) (vector-set! res (index-fun (car a))
((null? (cdr args)) (loop (append (car args) alist) '())) a))
(else (let ((sym (car args)) alist)
(val (cadr args))) (let loop ((i 0))
(loop (cons (cons sym val) alist) (if (< i (vector-length res))
(cddr args))))))) (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) (define-exported-binding "string->symbol" string->symbol)

83
scheme/xlib/visual.scm
View File

@ -1,56 +1,53 @@
;; A visual information is an alist with the following keys: ;; A visual information is an alist with keys of the type
;; 'screen-number the screen this visual belongs to ;; visual-info. The corresponding values have the following meaning:
;; 'depth the depth of the screen ;; screen-number the screen this visual belongs to
;; 'class one of 'direct-color 'gray-scale 'pseudo-color ;; depth the depth of the screen
;; class one of 'direct-color 'gray-scale 'pseudo-color
;; 'static-color 'static-gray 'true-color ;; 'static-color 'static-gray 'true-color
;; 'red-mask these masks are used for direct-color and 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 ;; green-mask to specify which bits of the pixel value specify
;; 'blue-mask red, green or blue values. ;; blue-mask red, green or blue values.
;; 'colormap-size tells how many different pixel value are valid ;; colormap-size tells how many different pixel value are valid
;; 'bits-per-rgb specifies how many bits in each of the red, green ;; bits-per-rgb specifies how many bits in each of the red, green
;; and blue values in a colorcell are used to drive ;; and blue values in a colorcell are used to drive
;; the rgb gun in the screen. ;; the rgb gun in the screen.
;; 'visual this value can be passed to other functions, e.g. ;; visual this value can be passed to other functions, e.g.
;; create-window. ;; create-window.
;; 'visual-id this value is not normally needed by applications. ;; visual-id this value is not normally needed by applications.
;; returns a list of visual informations that match the template given (define-enumerated-type visual-info :visual-info
;; by args. args can consist of the same fields as a visual visual-info?
;; information (see above) except 'visual that may not be visual-infos
;; specified. But usually only the fields 'screen 'depth and 'class visual-info-name
;; make sense. See create-window for the syntax of args. 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) (define visual-info-alist->vector
(let* ((alist (named-args->alist args)) (make-enum-alist->vector
(vector (pack-visual-info alist))) 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) (let ((res (%get-visual-info (display-Xdisplay display)
vector))) (visual-info-alist->vector visual-info-alist))))
(map unpack-visual-info (map vector->visual-info-alist
(vector->list res))))) (vector->list res))))
(import-lambda-definition %get-visual-info (Xdisplay v) (import-lambda-definition %get-visual-info (Xdisplay v)
"scx_Get_Visual_Info") "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. ;; visual-id returns the id of a given visual.
(define (visual-id visual) (define (visual-id visual)
@ -68,7 +65,7 @@
depth depth
class))) class)))
(if res (if res
(unpack-visual-info res) (visual-info-alist->vector res)
res))) res)))
(import-lambda-definition %match-visual-info (Xdisplay scrnum depth class) (import-lambda-definition %match-visual-info (Xdisplay scrnum depth class)

412
scheme/xlib/window.scm
View File

@ -1,190 +1,302 @@
;; Author: David Frese ;; Author: David Frese
;; create-window takes an alist of names and values - see ;; create-window creates an unmapped subwindow for a specified parent
;; change-window-attributes and configure-window. Mandatory arguments for ;; window. depth can be 'copy-from-parent. class can be one of
;; create-window are parent, width and height. Example: ;; 'input-output, 'input-only or 'copy-from-parent. visual can be
;; (create-window root 500 300 'x 0 '((border-width . 4))) ;; 'copy-from-parent too (see create-simple-window). See
;; Returns the new window or raises an exception if something went wrong. ;; change-window-attributes and make-set-window-attribute-alist for
;; the attributes argument.
(define (create-window parent width height . args) (define (create-window parent x y width height border-width depth class
(let ((alist (named-args->alist args))) visual set-window-attribute-alist)
(receive (x y border-width visual change-win-attr-list) (let ((attribs (set-window-attribute-alist->vector
(alist-split alist '((x . 0) (y . 0) (border-width . 2) set-window-attribute-alist))
(visual . #f))) (depth (cond
(let* ((change-win-attr-list ((eq? depth 'copy-from-parent) #f)
(map cons ((number? depth) depth)
(map car change-win-attr-list) (else (error "invalid depth" depth))))
(map (lambda (obj) (class (case class
(cond ((input-output) 0)
((pixel? obj) (pixel-Xpixel obj)) ((input-only) 1)
((pixmap? obj) (pixmap-Xpixmap obj)) ((copy-from-parent) 2)
((colormap? obj) (colormap-Xcolormap obj)) (else (error "invalid class specifier" class))))
((cursor? obj) (cursor-Xcursor obj)) (visual (cond
(else obj))) ((eq? visual 'copy-from-parent) #f)
(map cdr change-win-attr-list)))) ((visual? visual) (visual-Xvisual visual))
(display (window-display parent)) (else (error "invalid visual") visual)))
(Xwindow (%create-window (display-Xdisplay display) (display (window-display parent)))
(let ((Xwindow (%create-window
(display-Xdisplay display)
(window-Xwindow parent) (window-Xwindow parent)
x y width height border-width x y width height border-width
(if visual depth class visual
(visual-Xvisual visual) attribs)))
#f)
change-win-attr-list)))
(if (= Xwindow 0) (if (= Xwindow 0)
(error "cannot create window") (error "cannot create window")
(make-window Xwindow display #t)))))) (make-window Xwindow display #t)))))
(import-lambda-definition %create-window (Xdisplay Xparent x y width height (import-lambda-definition %create-window
border-width visual attrAlist) (Xdisplay Xparent x y width height border_width depth class Xvisual attribs)
"scx_Create_Window") "scx_Create_Window")
;; change-window-attributes takes an alist of names and values... ;; create-simple-window calls create-window with the default value 1
;; names can be: background-pixmap, background-pixel, border-pixmap, ;; for border-width, 0 for x and y, and 'copy-from-parent for depth,
;; border-pixel, bit-gravity, gravity, backing-store, backing-planes, ;; class and visual.
;; backing-pixel, save-under, event-mask, do-not-propagate-mask,
;; override-redirect, colormap, cursor.
(define (change-window-attributes window . attrs) (define (create-simple-window parent width height
(let* ((alist (named-args->alist attrs)) set-window-attribute-alist)
(prep-alist (create-window parent 0 0 width height 1
(map cons 'copy-from-parent 'copy-from-parent 'copy-from-parent
(map car alist) set-window-attribute-alist))
(map (lambda (value)
;; *** 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 (cond
;; Abstractions ?? : ((pixmap? background) (pixmap-Xpixmap background))
((pixmap? value) (pixmap-Xpixmap value)) ((eq? background 'parent-relative) background)
((pixel? value) (pixel-Xpixel value)) ((none-resource? background) 0)
((colormap? value) (colormap-Xcolormap value)) (else (error "invalid background pixmap"
((cursor? value) (cursor-Xcursor value)) background)))))
(else value))) ((1) pixel-Xpixel)
(map cdr alist))))) ((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) (%change-window-attributes (window-Xwindow window)
(display-Xdisplay (window-display window)) (display-Xdisplay (window-display window))
prep-alist))) (set-window-attribute-alist->vector
set-window-attribute-alist)))
(import-lambda-definition %change-window-attributes (Xwindow Xdisplay alist) (import-lambda-definition %change-window-attributes (Xwindow Xdisplay attribs)
"scx_Change_Window_Attributes") "scx_Change_Window_Attributes")
;; simple functions that use change-window-attributes ;; simple functions that use change-window-attributes
;; TODO: a caching system for multiple calls to these functions ;; 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) (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-pixmap!
(define set-window-background-pixel! (make-win-attr-setter 'background-pixel)) (make-win-attr-setter (set-window-attribute background-pixmap)))
(define set-window-border-pixmap! (make-win-attr-setter 'border-pixmap)) (define set-window-background-pixel!
(define set-window-border-pixel! (make-win-attr-setter 'border-pixel)) (make-win-attr-setter (set-window-attribute background-pixel)))
(define set-window-bit-gravity! (make-win-attr-setter 'bit-gravity)) (define set-window-border-pixmap!
(define set-window-gravity! (make-win-attr-setter 'gravity)) (make-win-attr-setter (set-window-attribute border-pixmap)))
(define set-window-backing-store! (make-win-attr-setter 'backing-store)) (define set-window-border-pixel!
(define set-window-backing-planes! (make-win-attr-setter 'backing-planes)) (make-win-attr-setter (set-window-attribute border-pixel)))
(define set-window-backing-pixel! (make-win-attr-setter 'backing-pixel)) (define set-window-bit-gravity!
(define set-window-save-under! (make-win-attr-setter 'save-under)) (make-win-attr-setter (set-window-attribute bit-gravity)))
(define set-window-event-mask! (make-win-attr-setter 'event-mask)) (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! (define set-window-do-not-propagate-mask!
(make-win-attr-setter 'do-not-propagate-mask)) (make-win-attr-setter (set-window-attribute do-not-propagate-mask)))
(define set-window-override-redirect! (make-win-attr-setter 'override-redirect)) (define set-window-override-redirect!
(define set-window-colormap! (make-win-attr-setter 'colormap)) (make-win-attr-setter (set-window-attribute override-redirect)))
(define set-window-cursor! (make-win-attr-setter 'cursor)) (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 ;; *** configure-window **********************************************
;; set-window-attributes sets and some more ... ;; an enumerated type for configure-window (see XConfigureWindow)
(define (get-window-attributes window) (define-enumerated-type window-change :window-change
(let ((Xwindow (window-Xwindow window)) window-change?
(Xdisplay (display-Xdisplay (window-display window)))) window-changes
(let ((v (%get-window-attributes Xdisplay Xwindow))) window-change-name
(if (not v) window-change-index
(error "cannot get window attributes." window) ; do not change this order
(let* ; sibling is a window, stack-mode can be one of 'above, 'below,
((comp (lambda (i f) (vector-set! v i (f (vector-ref v i))))) ; 'top-if, 'buttom-if and 'opposite.
(mod-v (begin (x y width height border-width sibling stack-mode))
(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)))))
(import-lambda-definition %get-window-attributes (Xdisplay Xwindow) (define window-change-alist->vector
"scx_Get_Window_Attributes") (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) ;; This sets the window-attributes listed above
(lambda (window)
(cdr (assq name (get-window-attributes window)))))
(define window-x (make-win-attr-getter 'x)) (define (configure-window window window-change-alist)
(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)))))
(%configure-window (window-Xwindow window) (%configure-window (window-Xwindow window)
(display-Xdisplay (window-display 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") "scx_Configure_Window")
;; the following mutators are based on configure-window ;; the following mutators are based on configure-window
(define (make-win-configurer name) (define (make-win-configurer change)
(lambda (window value) (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-x! (make-win-configurer (window-change x)))
(define set-window-y! (make-win-configurer 'y)) (define set-window-y! (make-win-configurer (window-change y)))
(define set-window-width! (make-win-configurer 'width)) (define set-window-width! (make-win-configurer (window-change width)))
(define set-window-height! (make-win-configurer 'height)) (define set-window-height! (make-win-configurer (window-change height)))
(define set-window-border-width! (make-win-configurer 'border-width)) (define set-window-border-width!
(define set-window-sibling! (make-win-configurer 'sibling)) (make-win-configurer (window-change border-width)))
(define set-window-stack-mode! (make-win-configurer 'stack-mode)) (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 ;; The map-window function maps the window and all of its subwindows that have
;; had map requests. See XMapWindow. ;; had map requests. See XMapWindow.

51
scheme/xlib/xlib-interfaces.scm
View File

@ -44,18 +44,21 @@
check-screen-number ;; for internal use (e.g. by client.scm) check-screen-number ;; for internal use (e.g. by client.scm)
)) ))
(define-interface xlib-window-interface (define-interface xlib-window-interface
(export window? (export window?
drawable? drawable?
window-display window-display
create-window create-window
create-simple-window
destroy-window destroy-window
change-window-attributes change-window-attributes
get-window-attributes get-window-attributes
map-window map-window
unmap-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-pixmap!
set-window-background-pixel! set-window-background-pixel!
set-window-border-pixmap! set-window-border-pixmap!
@ -166,6 +169,8 @@
copy-gcontext! copy-gcontext!
free-gcontext free-gcontext
((gc-value) :syntax)
query-best-size query-best-size
query-best-cursor query-best-cursor
query-best-tile query-best-tile
@ -185,16 +190,16 @@
gcontext-arc-mode gcontext-arc-mode
gcontext-tile gcontext-tile
gcontext-stipple gcontext-stipple
gcontext-ts-x gcontext-ts-x-origin
gcontext-ts-y gcontext-ts-y-origin
gcontext-font gcontext-font
gcontext-subwindow-mode gcontext-subwindow-mode
gcontext-exposures gcontext-graphics-exposures
gcontext-clip-x gcontext-clip-x-origin
gcontext-clip-y gcontext-clip-y-origin
gcontext-clip-mask gcontext-clip-mask
gcontext-dash-offset gcontext-dash-offset
gcontext-dashes gcontext-dash-list
change-gcontext change-gcontext
set-gcontext-function! set-gcontext-function!
@ -210,13 +215,13 @@
set-gcontext-arc-mode! set-gcontext-arc-mode!
set-gcontext-tile! set-gcontext-tile!
set-gcontext-stipple! set-gcontext-stipple!
set-gcontext-ts-x! set-gcontext-ts-x-origin!
set-gcontext-ts-y! set-gcontext-ts-y-origin!
set-gcontext-font! set-gcontext-font!
set-gcontext-subwindow-mode! set-gcontext-subwindow-mode!
set-gcontext-exposures! set-gcontext-graphics-exposures!
set-gcontext-clip-x! set-gcontext-clip-x-origin!
set-gcontext-clip-y! set-gcontext-clip-y-origin!
set-gcontext-clip-mask! set-gcontext-clip-mask!
set-gcontext-dash-offset! set-gcontext-dash-offset!
@ -224,7 +229,6 @@
set-gcontext-dashlist! set-gcontext-dashlist!
)) ))
(define-interface xlib-graphics-interface (define-interface xlib-graphics-interface
(export clear-area (export clear-area
copy-area copy-area
@ -374,25 +378,26 @@
reconfigure-wm-window reconfigure-wm-window
get-text-property get-text-property
set-text-property! set-text-property!
wm-protocols get-wm-protocols
set-wm-protocols! set-wm-protocols!
wm-name get-wm-name
set-wm-name! set-wm-name!
wm-icon-name get-wm-icon-name
set-wm-icon-name! set-wm-icon-name!
wm-client-machine get-wm-client-machine
set-wm-client-machine! set-wm-client-machine!
wm-class get-wm-class
set-wm-class! set-wm-class!
wm-command get-wm-command
set-wm-command! set-wm-command!
transient-for get-transient-for
set-transient-for! set-transient-for!
wm-normal-hints get-wm-normal-hints
set-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! set-wm-hints!
icon-sizes get-icon-sizes
set-icon-sizes! set-icon-sizes!
)) ))

6
scheme/xlib/xlib-packages.scm
View File

@ -12,6 +12,7 @@
receiving receiving
xlib-types xlib-types
xlib-graphics ;; for clear-window xlib-graphics ;; for clear-window
finite-types ;; for define-enumerated-type
) )
(files window)) (files window))
@ -52,6 +53,7 @@
signals ;; for error signals ;; for error
external-calls external-calls
receiving receiving
finite-types ;; for define-enumerated-type
xlib-types) xlib-types)
(files gcontext)) (files gcontext))
@ -124,7 +126,10 @@
external-calls external-calls
xlib-types xlib-types
xlib-display ;; for check-screen-number xlib-display ;; for check-screen-number
xlib-window ; for window-change-alist->vector
signals ;; for error signals ;; for error
finite-types ;; for define-enumerated-type
list-lib ;; for filter
) )
(files client)) (files client))
@ -166,6 +171,7 @@
(define-structure xlib-visual xlib-visual-interface (define-structure xlib-visual xlib-visual-interface
(open scheme (open scheme
external-calls external-calls
finite-types ;; for enumerated types
xlib-types) xlib-types)
(files visual)) (files visual))

3
scheme/xlib/xlib-type-interfaces.scm
View File

@ -1,7 +1,8 @@
;;; Helper functions ;;; Helper functions
(define-interface xlib-helper-interface (define-interface xlib-helper-interface
(export named-args->alist (export make-enum-alist->vector
make-vector->enum-alist
none-resource? none-resource?
none-resource none-resource
alist-split alist-split