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

273
c/xlib/client.c
View File

@ -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;

170
c/xlib/gcontext.c
View File

@ -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);

10
c/xlib/type.c
View File

@ -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 },

277
c/xlib/window.c
View File

@ -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;

172
scheme/xlib/client.scm
View File

@ -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

256
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
;; 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))

55
scheme/xlib/helper.scm
View File

@ -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))))
v))))

93
scheme/xlib/visual.scm
View File

@ -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)

428
scheme/xlib/window.scm
View File

@ -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")
"scx_Query_Pointer")

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

@ -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
))
))

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

@ -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))

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

@ -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
))
))