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

- fixed GC_PROTECT bugs 

- replaced most of symbol or symbol list arguments by enumerated types,
  enum-sets and alists of enumerated types.
- reformed event representation. Every event has it's own record-type now.
This commit is contained in:
frese 2002-02-08 17:09:43 +00:00
parent 4ae0c363d4
commit 10558fa5f0
52 changed files with 3139 additions and 1417 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

8
Makefile
View File

@ -25,7 +25,7 @@ enough: $(SCX)
### The VM is scsh plus all new primitives from the c files
OBJECTS = \
c/xlib/display.o c/xlib/window.o c/xlib/type.o c/xlib/color.o \
c/xlib/display.o c/xlib/window.o c/xlib/color.o \
c/xlib/colormap.o c/xlib/pixel.o c/xlib/gcontext.o c/xlib/event.o \
c/xlib/pixmap.o c/xlib/graphics.o c/xlib/font.o \
c/xlib/cursor.o c/xlib/text.o c/xlib/property.o c/xlib/wm.o \
@ -34,14 +34,15 @@ OBJECTS = \
c/xlib/visual.o c/xlib/region.o \
c/libs/xpm.o
SCM_FILES = scheme/xlib/atom-type.scm scheme/xlib/client.scm \
SCM_FILES = scheme/xlib/types.scm \
scheme/xlib/atom-type.scm scheme/xlib/client.scm \
scheme/xlib/color-type.scm scheme/xlib/color.scm \
scheme/xlib/colormap-type.scm scheme/xlib/colormap.scm \
scheme/xlib/cursor-type.scm scheme/xlib/cursor.scm \
scheme/xlib/display-type.scm \
scheme/xlib/display.scm scheme/xlib/drawable-type.scm \
scheme/xlib/drawable.scm scheme/xlib/error.scm \
scheme/xlib/event-type.scm scheme/xlib/event.scm \
scheme/xlib/event-types.scm scheme/xlib/event.scm \
scheme/xlib/extension.scm scheme/xlib/font-type.scm \
scheme/xlib/font.scm scheme/xlib/gcontext-type.scm \
scheme/xlib/gcontext.scm scheme/xlib/grab.scm scheme/xlib/graphics.scm \
@ -89,7 +90,6 @@ $(SCX_IMAGE): $(SCX_VM) $(SCM_FILES) $(SCM_CONFIG_FILES)
echo ",batch on"; \
echo ",config ,load $(SCM_CONFIG_FILES)"; \
echo ",load-package xlib"; \
echo ",load-package xlib-internals"; \
echo ",load-package xpm"; \
echo "(dump-scsh \"$(SCX_IMAGE)\")"; \
) | ./$(SCX_VM)

62
c/libs/xpm.c
View File

@ -7,37 +7,29 @@
void Attribs_To_XpmAttributes(s48_value attribs,
XpmAttributes* XA) {
int i; unsigned long mask = 0;
for (i=0; i<9; i++) {
s48_value v = S48_VECTOR_REF(attribs, i);
if (S48_FALSE != v) {
switch (i) {
case 0: mask |= XpmVisual;
unsigned long mask = s48_extract_integer(S48_CAR(attribs));
s48_value v = S48_CDR(attribs);
if (mask & XpmVisual)
XA->visual = SCX_EXTRACT_VISUAL(v);
break;
case 1: mask |= XpmColormap;
if (mask & XpmColormap)
XA->colormap = SCX_EXTRACT_COLORMAP(v);
break;
case 2: mask |= XpmDepth;
if (mask & XpmDepth)
XA->depth = s48_extract_integer(v);
break;
case 3: break; /*mask |= XpmColorSymbols;
ExtractColorsymbols(v, XA->colorsymbols, XA->numsymbols);
break;*/
case 4: mask |= XpmReturnPixels; break;
case 5: mask |= XpmExactColors;
if ((mask & XpmReturnPixels) && (S48_FALSE_P(v)))
mask = mask & (~XpmReturnPixels);
if (mask & XpmExactColors)
XA->exactColors = s48_extract_integer(v);
break;
case 6: mask |= XpmReturnAllocPixels; break;
case 7: mask |= XpmAllocCloseColors;
if ((mask & XpmReturnAllocPixels) && (S48_FALSE_P(v)))
mask = mask & (~XpmReturnAllocPixels);
if (mask & XpmAllocCloseColors)
XA->alloc_close_colors = s48_extract_integer(v);
break;
case 8: mask |= XpmBitmapFormat;
XA->bitmap_format = s48_extract_integer(v) ? XYBitmap : ZPixmap;
break;
}
}
}
if (mask & XpmBitmapFormat)
XA->bitmap_format = s48_extract_integer(v);
// if (mask & XpmColorSymbols)
// XA->colorsyms = ExtractColorsymbols(v, XA->colorsymbols, XA->numsymbols);
XA->valuemask = mask;
return;
}
@ -50,11 +42,11 @@ s48_value Make_XPM_Result(Pixmap* pixmap, Pixmap* shapemask,
S48_GC_PROTECT_1(res);
S48_VECTOR_SET(res, 0, SCX_ENTER_PIXMAP(*pixmap));
S48_VECTOR_SET(res, 1, s48_cons(s48_enter_integer(XA->width),
s48_enter_integer(XA->height)));
S48_VECTOR_SET(res, 1, s48_cons(s48_enter_fixnum(XA->width),
s48_enter_fixnum(XA->height)));
if (XA->valuemask & XpmHotspot != 0)
S48_VECTOR_SET(res, 2, s48_cons(s48_enter_integer(XA->x_hotspot),
s48_enter_integer(XA->y_hotspot)));
S48_VECTOR_SET(res, 2, s48_cons(s48_enter_fixnum(XA->x_hotspot),
s48_enter_fixnum(XA->y_hotspot)));
S48_VECTOR_SET(res, 3, SCX_ENTER_PIXMAP(*shapemask));
S48_GC_UNPROTECT();
@ -80,8 +72,8 @@ s48_value scx_Create_Pixmap_From_Data(s48_value Xdisplay, s48_value Xdrawable,
d,
&pixmap, &shapemask,
&XA );
if (r == XpmNoMemory) return s48_enter_integer(0);
else if (r == XpmFileInvalid) return s48_enter_integer(1);
if (r == XpmNoMemory) return s48_enter_fixnum(0);
else if (r == XpmFileInvalid) return s48_enter_fixnum(1);
else if (r == XpmSuccess)
return Make_XPM_Result(&pixmap, &shapemask, &XA);
}
@ -100,9 +92,9 @@ s48_value scx_Read_File_To_Pixmap(s48_value Xdisplay, s48_value Xdrawable,
s48_extract_string(filename),
&pixmap, &shapemask,
&XA );
if (r == XpmNoMemory) return s48_enter_integer(0);
else if (r == XpmFileInvalid) return s48_enter_integer(1);
else if (r == XpmOpenFailed) return s48_enter_integer(2);
if (r == XpmNoMemory) return s48_enter_fixnum(0);
else if (r == XpmFileInvalid) return s48_enter_fixnum(1);
else if (r == XpmOpenFailed) return s48_enter_fixnum(2);
else if (r == XpmSuccess)
return Make_XPM_Result(&pixmap, &shapemask, &XA);
}

3
c/main.c
View File

@ -4,7 +4,6 @@
extern void scx_init_window();
extern void scx_init_display();
extern void scx_init_type();
extern void scx_init_color();
extern void scx_init_colormap();
extern void scx_init_pixel();
@ -37,8 +36,6 @@ int main(int argc, char **argv) {
s48_add_external_init(scx_init_window);
s48_add_external_init(scx_init_display);
s48_add_external_init(scx_init_type);
s48_add_external_init(scx_init_color);
s48_add_external_init(scx_init_color);
s48_add_external_init(scx_init_colormap);
s48_add_external_init(scx_init_pixel);

215
c/xlib/client.c
View File

@ -18,10 +18,14 @@ s48_value scx_Withdraw_Window (s48_value Xdisplay, s48_value w, s48_value scr) {
return S48_UNSPECIFIC;
}
// defined in window.c
extern unsigned long Changes_To_XWindowChanges(s48_value conf,
XWindowChanges* WC);
s48_value scx_Reconfigure_Wm_Window (s48_value dpy, s48_value w, s48_value scr,
s48_value conf) {
XWindowChanges WC;
unsigned long mask = 0;//AList_To_XWindowChanges(conf, &WC);
unsigned long mask = Changes_To_XWindowChanges(conf, &WC);
if (!XReconfigureWMWindow (SCX_EXTRACT_DISPLAY(dpy),
SCX_EXTRACT_WINDOW(w),
@ -61,7 +65,7 @@ int String_Vector_To_Text_Property (s48_value x, XTextProperty* ret) {
for (i = 0; i < n; i++) {
t = S48_VECTOR_REF(x, i);
s[i] = S48_SYMBOL_P(t) ? s48_extract_symbol(t) : s48_extract_string(t);
s[i] = s48_extract_string(t);
}
return XStringListToTextProperty (s, n, ret);
@ -223,22 +227,22 @@ s48_value scx_Wm_Hints (s48_value dpy, s48_value w) {
p = XGetWMHints (SCX_EXTRACT_DISPLAY(dpy),
SCX_EXTRACT_WINDOW(w));
//Enable_Interrupts;
res = s48_make_vector(9, S48_NULL);
res = s48_make_vector(9, S48_UNSPECIFIC);
if (p) {
S48_GC_PROTECT_1(res);
if (p->flags && InputHint)
S48_VECTOR_SET(res, 0, S48_ENTER_BOOLEAN(p->input));
if (p->flags && StateHint)
S48_VECTOR_SET(res, 1, Bit_To_Symbol((unsigned long)p->initial_state,
Initial_State_Syms));
S48_VECTOR_SET(res, 1,
s48_enter_integer((unsigned long)p->initial_state));
if (p->flags && IconPixmapHint)
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_cons(s48_enter_integer(p->icon_x),
s48_enter_integer(p->icon_y)));
S48_VECTOR_SET(res, 4, s48_cons(s48_enter_fixnum(p->icon_x),
s48_enter_fixnum(p->icon_y)));
if (p->flags && IconMaskHint)
S48_VECTOR_SET(res, 5, SCX_ENTER_PIXMAP(p->icon_mask));
if (p->flags && WindowGroupHint)
@ -247,6 +251,7 @@ s48_value scx_Wm_Hints (s48_value dpy, s48_value w) {
S48_VECTOR_SET(res, 7, S48_ENTER_BOOLEAN(p->flags & XUrgencyHint));
// XLib man-pages say this constant is called UrgencyHint !!
res = s48_cons(s48_enter_integer(p->flags), res);
S48_GC_UNPROTECT();
}
@ -256,43 +261,30 @@ s48_value scx_Wm_Hints (s48_value dpy, s48_value w) {
}
s48_value scx_Set_Wm_Hints (s48_value dpy, s48_value w, s48_value hints) {
long mask = 0;
long mask = s48_extract_integer(S48_CAR(hints));
s48_value v = S48_CDR(hints);
XWMHints WMH;
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 !!
}
}
if (mask & InputHint)
WMH.input = S48_EXTRACT_BOOLEAN(S48_VECTOR_REF(v, 0));
if (mask & StateHint)
WMH.initial_state = s48_extract_integer(S48_VECTOR_REF(v, 1));
if (mask & IconPixmapHint)
WMH.icon_pixmap = SCX_EXTRACT_PIXMAP(S48_VECTOR_REF(v, 2));
if (mask & IconWindowHint)
WMH.icon_window = SCX_EXTRACT_WINDOW(S48_VECTOR_REF(v, 3));
if (mask & IconPositionHint) {
WMH.icon_x = (int)s48_extract_integer(S48_CAR(S48_VECTOR_REF(v, 4)));
WMH.icon_y = (int)s48_extract_integer(S48_CDR(S48_VECTOR_REF(v, 4)));
}
if (mask & IconMaskHint)
WMH.icon_mask = SCX_EXTRACT_PIXMAP(S48_VECTOR_REF(v, 5));
if (mask & WindowGroupHint)
WMH.window_group = SCX_EXTRACT_WINDOW(S48_VECTOR_REF(v, 6));
if (mask & XUrgencyHint)
if (S48_FALSE == S48_EXTRACT_BOOLEAN(S48_VECTOR_REF(v, 7)))
mask = mask & (~XUrgencyHint);
WMH.flags = mask;
XSetWMHints(SCX_EXTRACT_DISPLAY(dpy),
@ -321,12 +313,12 @@ s48_value scx_Icon_Sizes (s48_value dpy, s48_value w) {
s48_value t = s48_make_vector(6, S48_NULL);
S48_VECTOR_SET(v, i, t);
S48_VECTOR_SET(t, 0, s48_enter_integer (q->min_width));
S48_VECTOR_SET(t, 1, s48_enter_integer (q->min_height));
S48_VECTOR_SET(t, 2, s48_enter_integer (q->max_width));
S48_VECTOR_SET(t, 3, s48_enter_integer (q->max_height));
S48_VECTOR_SET(t, 4, s48_enter_integer (q->width_inc));
S48_VECTOR_SET(t, 5, s48_enter_integer (q->height_inc));
S48_VECTOR_SET(t, 0, s48_enter_fixnum(q->min_width));
S48_VECTOR_SET(t, 1, s48_enter_fixnum(q->min_height));
S48_VECTOR_SET(t, 2, s48_enter_fixnum(q->max_width));
S48_VECTOR_SET(t, 3, s48_enter_fixnum(q->max_height));
S48_VECTOR_SET(t, 4, s48_enter_fixnum(q->width_inc));
S48_VECTOR_SET(t, 5, s48_enter_fixnum(q->height_inc));
}
S48_GC_UNPROTECT();
if (n > 0)
@ -391,12 +383,12 @@ s48_value scx_Wm_Normal_Hints(s48_value dpy, s48_value win) {
S48_GC_PROTECT_1(v);
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)));
S48_VECTOR_SET(v, 2, s48_cons(s48_enter_fixnum(SH.x),
s48_enter_fixnum(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)));
S48_VECTOR_SET(v, 3, s48_cons(s48_enter_fixnum(SH.width),
s48_enter_fixnum(SH.height)));
if ((SH.flags & USPosition) != 0)
S48_VECTOR_SET(v, 0, S48_VECTOR_REF(v, 2));
@ -405,30 +397,32 @@ s48_value scx_Wm_Normal_Hints(s48_value dpy, s48_value win) {
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)));
S48_VECTOR_SET(v, 4, s48_cons(s48_enter_fixnum(SH.min_width),
s48_enter_fixnum(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)));
S48_VECTOR_SET(v, 5, s48_cons(s48_enter_fixnum(SH.max_width),
s48_enter_fixnum(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)));
S48_VECTOR_SET(v, 6, s48_cons(s48_enter_fixnum(SH.width_inc),
s48_enter_fixnum(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))));
s48_cons(s48_cons(s48_enter_fixnum(SH.min_aspect.x),
s48_enter_fixnum(SH.min_aspect.y)),
s48_cons(s48_enter_fixnum(SH.max_aspect.x),
s48_enter_fixnum(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)));
S48_VECTOR_SET(v, 8, s48_cons(s48_enter_fixnum(SH.base_width),
s48_enter_fixnum(SH.base_height)));
if ((SH.flags & PWinGravity) != 0)
S48_VECTOR_SET(v, 18, Bit_To_Symbol(SH.win_gravity, Grav_Syms));
S48_VECTOR_SET(v, 18, s48_enter_integer(SH.win_gravity));
v = s48_cons(s48_enter_integer(SH.flags), v);
S48_GC_UNPROTECT();
return v;
@ -437,55 +431,54 @@ s48_value scx_Wm_Normal_Hints(s48_value dpy, s48_value win) {
s48_value scx_Set_Wm_Normal_Hints(s48_value dpy, s48_value win,
s48_value hints) {
XSizeHints SH;
long mask = 0;
int i;
long mask = S48_CAR(hints);
s48_value v = S48_CDR(hints);
for (i=0; i<10; i++) {
s48_value v = S48_VECTOR_REF(hints, i);
if (mask & USPosition) {
SH.x = s48_extract_integer(S48_CAR(S48_VECTOR_REF(v, 0)));
SH.y = s48_extract_integer(S48_CDR(S48_VECTOR_REF(v, 0)));
}
if (mask & USSize) {
SH.width = s48_extract_integer(S48_CAR(S48_VECTOR_REF(v, 1)));
SH.height = s48_extract_integer(S48_CDR(S48_VECTOR_REF(v, 1)));
}
if (mask & PPosition) {
SH.x = s48_extract_integer(S48_CAR(S48_VECTOR_REF(v, 2)));
SH.y = s48_extract_integer(S48_CDR(S48_VECTOR_REF(v, 2)));
}
if (mask & PSize) {
SH.width = s48_extract_integer(S48_CAR(S48_VECTOR_REF(v, 3)));
SH.height = s48_extract_integer(S48_CDR(S48_VECTOR_REF(v, 3)));
}
if (mask & PMinSize) {
SH.min_width = s48_extract_integer(S48_CAR(S48_VECTOR_REF(v, 4)));
SH.min_height = s48_extract_integer(S48_CDR(S48_VECTOR_REF(v, 4)));
}
if (mask & PMaxSize) {
SH.max_width = s48_extract_integer(S48_CAR(S48_VECTOR_REF(v, 5)));
SH.max_height = s48_extract_integer(S48_CDR(S48_VECTOR_REF(v, 5)));
}
if (mask & PResizeInc) {
SH.width_inc = s48_extract_integer(S48_CAR(S48_VECTOR_REF(v, 6)));
SH.height_inc = s48_extract_integer(S48_CDR(S48_VECTOR_REF(v, 6)));
}
if (mask & PAspect) {
SH.min_aspect.x =
s48_extract_integer(S48_CAR(S48_CAR(S48_VECTOR_REF(v, 7))));
SH.min_aspect.y =
s48_extract_integer(S48_CDR(S48_CAR(S48_VECTOR_REF(v, 7))));
SH.max_aspect.x =
s48_extract_integer(S48_CAR(S48_CDR(S48_VECTOR_REF(v, 7))));
SH.max_aspect.y =
s48_extract_integer(S48_CDR(S48_CDR(S48_VECTOR_REF(v, 7))));
}
if (mask & PBaseSize) {
SH.base_width = s48_extract_integer(S48_CAR(S48_VECTOR_REF(v, 8)));
SH.base_height = s48_extract_integer(S48_CDR(S48_VECTOR_REF(v, 8)));
}
if (mask & PWinGravity)
SH.win_gravity = s48_extract_integer(S48_VECTOR_REF(v, 9));
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;
XSetWMNormalHints(SCX_EXTRACT_DISPLAY(dpy),

5
c/xlib/color.c
View File

@ -1,5 +1,4 @@
#include "xlib.h"
#include "scheme48.h"
s48_value scx_Create_Color(s48_value r, s48_value g, s48_value b) {
s48_value col = S48_MAKE_VALUE(XColor);
@ -76,8 +75,8 @@ s48_value scx_Lookup_Color(s48_value Xcolormap, s48_value Xdisplay,
SCX_EXTRACT_COLORMAP(Xcolormap),
s48_extract_string(color_name), &visual, &exact )) {
S48_GC_PROTECT_1(res);
res = s48_cons( scx_Int_Extract_RGB_Values( visual ),
scx_Int_Extract_RGB_Values( exact ) );
res = scx_Int_Extract_RGB_Values( visual );
res = s48_cons(res, scx_Int_Extract_RGB_Values( exact ) );
}
S48_GC_UNPROTECT();

7
c/xlib/colormap.c
View File

@ -112,7 +112,7 @@ s48_value scx_Store_Color(s48_value Xdisplay, s48_value Xcolormap,
t.red = c->red;
t.green = c->green;
t.blue = c->blue;
t.flags = Symbols_To_Bits(flags, Color_Flags_Syms);
t.flags = s48_extract_integer(flags);
XStoreColor(SCX_EXTRACT_DISPLAY(Xdisplay), SCX_EXTRACT_COLORMAP(Xcolormap),
&t);
@ -134,10 +134,11 @@ s48_value scx_Store_Colors(s48_value Xdisplay, s48_value Xcolormap,
colors[i].red = c->red;
colors[i].green = c->green;
colors[i].blue = c->blue;
colors[i].flags = Symbols_To_Bits(S48_VECTOR_REF(def, 2), Color_Flags_Syms);
colors[i].flags = s48_extract_integer(S48_VECTOR_REF(def, 2));
}
XStoreColors(SCX_EXTRACT_DISPLAY(Xdisplay), SCX_EXTRACT_COLORMAP(Xcolormap),
XStoreColors(SCX_EXTRACT_DISPLAY(Xdisplay),
SCX_EXTRACT_COLORMAP(Xcolormap),
colors, n);
return S48_UNSPECIFIC;

51
c/xlib/display.c
View File

@ -77,11 +77,11 @@ s48_value scx_Display_Default_Gcontext(s48_value Xdisplay) {
s48_value scx_Display_Default_Depth(s48_value Xdisplay) {
Display* dpy = SCX_EXTRACT_DISPLAY(Xdisplay);
int depth = DefaultDepth(dpy, DefaultScreen(dpy));
return s48_enter_integer(depth);
return s48_enter_fixnum(depth);
}
s48_value scx_Display_Default_Screen_Number(s48_value Xdisplay) {
return s48_enter_integer(DefaultScreen(SCX_EXTRACT_DISPLAY(Xdisplay)));
return s48_enter_fixnum(DefaultScreen(SCX_EXTRACT_DISPLAY(Xdisplay)));
}
s48_value scx_Display_Default_Visual(s48_value Xdisplay, s48_value scrnum) {
@ -108,28 +108,40 @@ s48_value scx_Display_Vendor(s48_value Xdisplay) {
Display* dpy = SCX_EXTRACT_DISPLAY(Xdisplay);
char* s = ServerVendor(dpy);
int i = VendorRelease(dpy);
return s48_cons( s48_enter_string(s),
s48_enter_integer(i) );
s48_value t = S48_FALSE;
S48_DECLARE_GC_PROTECT(1);
S48_GC_PROTECT_1(t);
t = s48_enter_string(s);
t = s48_cons(t, s48_enter_integer(i));
S48_GC_UNPROTECT();
return t;
}
s48_value scx_Display_Protocol_Version(s48_value Xdisplay) {
Display* dpy = SCX_EXTRACT_DISPLAY(Xdisplay);
int maj = ProtocolVersion(dpy);
int min = ProtocolRevision(dpy);
return s48_cons( s48_enter_integer(maj),
s48_enter_integer(min) );
s48_value t = S48_FALSE;
S48_DECLARE_GC_PROTECT(1);
S48_GC_PROTECT_1(t);
t = s48_enter_integer(maj);
t = s48_cons(t, s48_enter_integer(min));
S48_GC_UNPROTECT();
return t;
}
s48_value scx_Display_Screen_Count(s48_value Xdisplay) {
int cnt = ScreenCount(SCX_EXTRACT_DISPLAY(Xdisplay));
return s48_enter_integer(cnt);
return s48_enter_fixnum(cnt);
}
s48_value scx_Display_Image_Byte_Order(s48_value Xdisplay) {
Display* dpy = SCX_EXTRACT_DISPLAY(Xdisplay);
return Bits_To_Symbols( (unsigned long)ImageByteOrder(dpy),
Byte_Order_Syms );
return s48_enter_integer((unsigned long)ImageByteOrder(dpy));
}
s48_value scx_Display_Bitmap_Unit(s48_value Xdisplay) {
@ -139,8 +151,7 @@ s48_value scx_Display_Bitmap_Unit(s48_value Xdisplay) {
s48_value scx_Display_Bitmap_Bit_Order(s48_value Xdisplay) {
Display* dpy = SCX_EXTRACT_DISPLAY(Xdisplay);
return Bits_To_Symbols( (unsigned long)BitmapBitOrder(dpy),
Byte_Order_Syms );
return s48_enter_integer((unsigned long)BitmapBitOrder(dpy));
}
s48_value scx_Display_Bitmap_Pad(s48_value Xdisplay) {
@ -150,22 +161,22 @@ s48_value scx_Display_Bitmap_Pad(s48_value Xdisplay) {
s48_value scx_Display_Width(s48_value Xdisplay) {
Display* dpy = SCX_EXTRACT_DISPLAY(Xdisplay);
return s48_enter_integer(DisplayWidth(dpy, DefaultScreen(dpy)));
return s48_enter_fixnum(DisplayWidth(dpy, DefaultScreen(dpy)));
}
s48_value scx_Display_Height(s48_value Xdisplay) {
Display* dpy = SCX_EXTRACT_DISPLAY(Xdisplay);
return s48_enter_integer(DisplayHeight(dpy, DefaultScreen(dpy)));
return s48_enter_fixnum(DisplayHeight(dpy, DefaultScreen(dpy)));
}
s48_value scx_Display_Width_Mm (s48_value Xdisplay) {
Display* dpy = SCX_EXTRACT_DISPLAY(Xdisplay);
return s48_enter_integer(DisplayWidthMM(dpy, DefaultScreen(dpy)));
return s48_enter_fixnum(DisplayWidthMM(dpy, DefaultScreen(dpy)));
}
s48_value scx_Display_Height_Mm (s48_value Xdisplay) {
Display* dpy = SCX_EXTRACT_DISPLAY(Xdisplay);
return s48_enter_integer(DisplayHeightMM(dpy, DefaultScreen(dpy)));
return s48_enter_fixnum(DisplayHeightMM(dpy, DefaultScreen(dpy)));
}
s48_value scx_Display_Motion_Buffer_Size(s48_value Xdisplay) {
@ -200,7 +211,7 @@ s48_value scx_List_Depths (s48_value Xdisplay, s48_value scr) {
S48_GC_PROTECT_1(ret);
ret = s48_make_vector(num, S48_NULL);
for (i = 0; i < num; i++)
S48_VECTOR_SET(ret, i, s48_enter_integer(p[i]));
S48_VECTOR_SET(ret, i, s48_enter_fixnum(p[i]));
XFree((char *)p);
}
@ -220,9 +231,9 @@ s48_value scx_List_Pixmap_Formats (s48_value Xdisplay) {
S48_GC_PROTECT_2(ret, t);
ret = s48_make_vector (num, S48_FALSE);
for (i = 0; i < num; i++) {
t = s48_cons(s48_enter_integer(p[i].depth),
s48_cons(s48_enter_integer(p[i].bits_per_pixel),
s48_cons(s48_enter_integer(p[i].scanline_pad),
t = s48_cons(s48_enter_fixnum(p[i].depth),
s48_cons(s48_enter_fixnum(p[i].bits_per_pixel),
s48_cons(s48_enter_fixnum(p[i].scanline_pad),
S48_NULL)));
S48_VECTOR_SET(ret, i, t);
}
@ -237,7 +248,7 @@ s48_value scx_Display_Select_Input(s48_value Xdisplay, s48_value Xwindow,
s48_value event_mask) {
XSelectInput(SCX_EXTRACT_DISPLAY(Xdisplay),
SCX_EXTRACT_WINDOW(Xwindow),
Symbols_To_Bits(event_mask, Event_Mask_Syms));
s48_extract_integer(event_mask));
}
void scx_init_display(void) {

11
c/xlib/error.c
View File

@ -34,13 +34,10 @@ static X_Error(Display* d, XErrorEvent* ep) {
S48_GC_PROTECT_2(args, a);
S48_VECTOR_SET(args, 0, SCX_ENTER_DISPLAY(d));
S48_VECTOR_SET(args, 1, s48_enter_integer(ep->serial));
a = Bit_To_Symbol ((unsigned long)ep->error_code, Error_Syms);
if (S48_NULL_P (a))
a = s48_enter_integer (ep->error_code);
S48_VECTOR_SET(args, 2, a);
S48_VECTOR_SET(args, 3, s48_enter_integer (ep->request_code));
S48_VECTOR_SET(args, 4, s48_enter_integer (ep->minor_code));
S48_VECTOR_SET(args, 5, s48_enter_integer ((unsigned long)ep->resourceid));
S48_VECTOR_SET(args, 2, s48_enter_integer(ep->error_code));
S48_VECTOR_SET(args, 3, s48_enter_integer(ep->request_code));
S48_VECTOR_SET(args, 4, s48_enter_integer(ep->minor_code));
S48_VECTOR_SET(args, 5, s48_enter_integer((unsigned long)ep->resourceid));
XGetErrorText(d, ep->error_code, s, max_s);
S48_VECTOR_SET(args, 6, s48_enter_string(s));

129
c/xlib/event.c
View File

@ -3,15 +3,15 @@
#define ECAST(name, type) type* name = (type*)e
#define sidx 4
#define SET(i, v) temp2 = v; S48_VECTOR_SET(r, i, temp2)
#define SET(i, v) S48_VECTOR_SET(r, i, v)
#define SETSIZE(i) r = s48_make_vector(sidx+i, S48_FALSE)
s48_value scx_enter_event(XEvent* e) {
s48_value r = S48_FALSE;
s48_value temp, temp2 = S48_FALSE;
int i;
S48_DECLARE_GC_PROTECT(3);
S48_GC_PROTECT_3(r, temp, temp2);
S48_DECLARE_GC_PROTECT(2);
S48_GC_PROTECT_2(r, temp);
switch (e->type) {
@ -24,25 +24,25 @@ s48_value scx_enter_event(XEvent* e) {
SET(sidx+0, SCX_ENTER_WINDOW(q->root));
SET(sidx+1, SCX_ENTER_WINDOW(q->subwindow));
SET(sidx+2, SCX_ENTER_TIME(q->time));
SET(sidx+3, s48_enter_integer(q->x));
SET(sidx+4, s48_enter_integer(q->y));
SET(sidx+5, s48_enter_integer(q->x_root));
SET(sidx+6, s48_enter_integer(q->y_root));
SET(sidx+7, Bits_To_Symbols(q->state, State_Syms));
SET(sidx+3, s48_enter_fixnum(q->x));
SET(sidx+4, s48_enter_fixnum(q->y));
SET(sidx+5, s48_enter_fixnum(q->x_root));
SET(sidx+6, s48_enter_fixnum(q->y_root));
SET(sidx+7, s48_enter_fixnum(q->state));
// now they are different
switch (e->type) {
case KeyPress : case KeyRelease : {
SET(sidx+8, s48_enter_integer(q->keycode));
SET(sidx+8, s48_enter_fixnum(q->keycode));
SET(sidx+9, S48_ENTER_BOOLEAN(q->same_screen));
} break;
case ButtonPress : case ButtonRelease : {
ECAST(q, XButtonEvent);
SET(sidx+8, Bit_To_Symbol(q->button, Button_Syms));
SET(sidx+8, s48_enter_integer(q->button));
SET(sidx+9, S48_ENTER_BOOLEAN(q->same_screen));
} break;
case MotionNotify : {
ECAST(q, XMotionEvent);
SET(sidx+8, S48_ENTER_BOOLEAN(q->is_hint));
SET(sidx+8, s48_enter_fixnum(q->is_hint));
SET(sidx+9, S48_ENTER_BOOLEAN(q->same_screen));
} break;
}
@ -54,23 +54,23 @@ s48_value scx_enter_event(XEvent* e) {
SET(sidx+0, SCX_ENTER_WINDOW(q->root));
SET(sidx+1, SCX_ENTER_WINDOW(q->subwindow));
SET(sidx+2, SCX_ENTER_TIME(q->time));
SET(sidx+3, s48_enter_integer(q->x));
SET(sidx+4, s48_enter_integer(q->y));
SET(sidx+5, s48_enter_integer(q->x_root));
SET(sidx+6, s48_enter_integer(q->y_root));
SET(sidx+7, Bit_To_Symbol(q->mode, Cross_Mode_Syms));
SET(sidx+8, Bit_To_Symbol(q->detail, Cross_Detail_Syms));
SET(sidx+3, s48_enter_fixnum(q->x));
SET(sidx+4, s48_enter_fixnum(q->y));
SET(sidx+5, s48_enter_fixnum(q->x_root));
SET(sidx+6, s48_enter_fixnum(q->y_root));
SET(sidx+7, s48_enter_integer(q->mode));
SET(sidx+8, s48_enter_integer(q->detail));
SET(sidx+9, S48_ENTER_BOOLEAN(q->same_screen));
SET(sidx+10, S48_ENTER_BOOLEAN(q->focus));
// Elk does this; but why not State_Syms??
SET(sidx+11, Bit_To_Symbol(q->state, Button_Syms));
SET(sidx+11, s48_enter_integer(q->state));
} break;
case FocusIn : case FocusOut : {
ECAST(q, XFocusChangeEvent);
SETSIZE(2);
SET(sidx+0, Bit_To_Symbol(q->mode, Cross_Mode_Syms));
SET(sidx+1, Bit_To_Symbol(q->detail, Focus_Detail_Syms));
SET(sidx+0, s48_enter_integer(q->mode));
SET(sidx+1, s48_enter_integer(q->detail));
} break;
case KeymapNotify : {
@ -85,22 +85,22 @@ s48_value scx_enter_event(XEvent* e) {
case Expose : {
ECAST(q, XExposeEvent);
SETSIZE(5);
SET(sidx+0, s48_enter_integer(q->x));
SET(sidx+1, s48_enter_integer(q->y));
SET(sidx+2, s48_enter_integer(q->width));
SET(sidx+3, s48_enter_integer(q->height));
SET(sidx+4, s48_enter_integer(q->count));
SET(sidx+0, s48_enter_fixnum(q->x));
SET(sidx+1, s48_enter_fixnum(q->y));
SET(sidx+2, s48_enter_fixnum(q->width));
SET(sidx+3, s48_enter_fixnum(q->height));
SET(sidx+4, s48_enter_fixnum(q->count));
} break;
case GraphicsExpose : {
ECAST(q, XGraphicsExposeEvent);
SETSIZE(7);
// the ->window member is only a drawable here! ??
SET(sidx+0, s48_enter_integer(q->x));
SET(sidx+1, s48_enter_integer(q->y));
SET(sidx+2, s48_enter_integer(q->width));
SET(sidx+3, s48_enter_integer(q->height));
SET(sidx+4, s48_enter_integer(q->count));
SET(sidx+0, s48_enter_fixnum(q->x));
SET(sidx+1, s48_enter_fixnum(q->y));
SET(sidx+2, s48_enter_fixnum(q->width));
SET(sidx+3, s48_enter_fixnum(q->height));
SET(sidx+4, s48_enter_fixnum(q->count));
SET(sidx+5, s48_enter_integer(q->major_code));
SET(sidx+6, s48_enter_integer(q->minor_code));
} break;
@ -115,18 +115,18 @@ s48_value scx_enter_event(XEvent* e) {
case VisibilityNotify : {
ECAST(q, XVisibilityEvent);
SETSIZE(1);
SET(sidx+0, Bit_To_Symbol(q->state, Visibility_Syms));
SET(sidx+0, s48_enter_integer(q->state));
} break;
case CreateNotify : {
ECAST(q, XCreateWindowEvent);
SETSIZE(7);
SET(sidx+0, SCX_ENTER_WINDOW(q->window));
SET(sidx+1, s48_enter_integer(q->x));
SET(sidx+2, s48_enter_integer(q->y));
SET(sidx+3, s48_enter_integer(q->width));
SET(sidx+4, s48_enter_integer(q->height));
SET(sidx+5, s48_enter_integer(q->border_width));
SET(sidx+1, s48_enter_fixnum(q->x));
SET(sidx+2, s48_enter_fixnum(q->y));
SET(sidx+3, s48_enter_fixnum(q->width));
SET(sidx+4, s48_enter_fixnum(q->height));
SET(sidx+5, s48_enter_fixnum(q->border_width));
SET(sidx+6, S48_ENTER_BOOLEAN(q->override_redirect));
} break;
@ -161,8 +161,8 @@ s48_value scx_enter_event(XEvent* e) {
SETSIZE(5);
SET(sidx+0, SCX_ENTER_WINDOW(q->window));
SET(sidx+1, SCX_ENTER_WINDOW(q->parent));
SET(sidx+2, s48_enter_integer(q->x));
SET(sidx+3, s48_enter_integer(q->y));
SET(sidx+2, s48_enter_fixnum(q->x));
SET(sidx+3, s48_enter_fixnum(q->y));
SET(sidx+4, S48_ENTER_BOOLEAN(q->override_redirect));
} break;
@ -170,11 +170,11 @@ s48_value scx_enter_event(XEvent* e) {
ECAST(q, XConfigureEvent);
SETSIZE(8);
SET(sidx+0, SCX_ENTER_WINDOW(q->window));
SET(sidx+1, s48_enter_integer(q->x));
SET(sidx+2, s48_enter_integer(q->y));
SET(sidx+3, s48_enter_integer(q->width));
SET(sidx+4, s48_enter_integer(q->height));
SET(sidx+5, s48_enter_integer(q->border_width));
SET(sidx+1, s48_enter_fixnum(q->x));
SET(sidx+2, s48_enter_fixnum(q->y));
SET(sidx+3, s48_enter_fixnum(q->width));
SET(sidx+4, s48_enter_fixnum(q->height));
SET(sidx+5, s48_enter_fixnum(q->border_width));
SET(sidx+6, SCX_ENTER_WINDOW(q->above));
SET(sidx+7, S48_ENTER_BOOLEAN(q->override_redirect));
} break;
@ -183,13 +183,13 @@ s48_value scx_enter_event(XEvent* e) {
ECAST(q, XConfigureRequestEvent);
SETSIZE(9);
SET(sidx+0, SCX_ENTER_WINDOW(q->window));
SET(sidx+1, s48_enter_integer(q->x));
SET(sidx+2, s48_enter_integer(q->y));
SET(sidx+3, s48_enter_integer(q->width));
SET(sidx+4, s48_enter_integer(q->height));
SET(sidx+5, s48_enter_integer(q->border_width));
SET(sidx+1, s48_enter_fixnum(q->x));
SET(sidx+2, s48_enter_fixnum(q->y));
SET(sidx+3, s48_enter_fixnum(q->width));
SET(sidx+4, s48_enter_fixnum(q->height));
SET(sidx+5, s48_enter_fixnum(q->border_width));
SET(sidx+6, SCX_ENTER_WINDOW(q->above));
SET(sidx+7, Bit_To_Symbol(q->detail, Stack_Mode_Syms));
SET(sidx+7, s48_enter_integer(q->detail));
SET(sidx+8, s48_enter_integer(q->value_mask));
} break;
@ -197,22 +197,22 @@ s48_value scx_enter_event(XEvent* e) {
ECAST(q, XGravityEvent);
SETSIZE(3);
SET(sidx+0, SCX_ENTER_WINDOW(q->window));
SET(sidx+1, s48_enter_integer(q->x));
SET(sidx+2, s48_enter_integer(q->y));
SET(sidx+1, s48_enter_fixnum(q->x));
SET(sidx+2, s48_enter_fixnum(q->y));
} break;
case ResizeRequest : {
ECAST(q, XResizeRequestEvent);
SETSIZE(2);
SET(sidx+0, s48_enter_integer(q->width));
SET(sidx+1, s48_enter_integer(q->height));
SET(sidx+0, s48_enter_fixnum(q->width));
SET(sidx+1, s48_enter_fixnum(q->height));
} break;
case CirculateRequest : {
ECAST(q, XCirculateEvent);
SETSIZE(2);
SET(sidx+0, SCX_ENTER_WINDOW(q->window));
SET(sidx+1, Bit_To_Symbol(q->place, Place_Syms));
SET(sidx+1, s48_enter_integer(q->place));
} break;
case PropertyNotify : {
@ -220,7 +220,7 @@ s48_value scx_enter_event(XEvent* e) {
SETSIZE(3);
SET(sidx+0, SCX_ENTER_ATOM(q->atom));
SET(sidx+1, SCX_ENTER_TIME(q->time));
SET(sidx+2, Bit_To_Symbol(q->state, Prop_Syms));
SET(sidx+2, s48_enter_integer(q->state));
} break;
case SelectionClear : {
@ -254,13 +254,14 @@ s48_value scx_enter_event(XEvent* e) {
SETSIZE(3);
SET(sidx+0, SCX_ENTER_COLORMAP(q->colormap));
SET(sidx+1, S48_ENTER_BOOLEAN(q->new));
SET(sidx+2, q->state == ColormapInstalled ? S48_TRUE : S48_FALSE);
SET(sidx+2, s48_enter_integer(q->state));
} break;
case ClientMessage : {
ECAST(q, XClientMessageEvent);
SETSIZE(2);
SETSIZE(3);
SET(sidx+0, SCX_ENTER_ATOM(q->message_type));
SET(sidx+1, s48_enter_integer(q->format));
switch (q->format) {
case 8 : {
temp = s48_make_string(20, (char)0);
@ -270,7 +271,7 @@ s48_value scx_enter_event(XEvent* e) {
case 16 : {
temp = s48_make_vector(10, S48_FALSE);
for (i=0; i < 10; i++)
S48_VECTOR_SET(temp, i, s48_enter_integer(q->data.s[i]));
S48_VECTOR_SET(temp, i, s48_enter_fixnum(q->data.s[i]));
} break;
case 32 : {
temp = s48_make_vector(5, S48_FALSE);
@ -286,9 +287,9 @@ s48_value scx_enter_event(XEvent* e) {
case MappingNotify : {
ECAST(q, XMappingEvent);
SETSIZE(3);
SET(sidx+0, Bit_To_Symbol(q->request, Mapping_Syms));
SET(sidx+0, s48_enter_integer(q->request));
SET(sidx+1, s48_enter_integer(q->first_keycode));
SET(sidx+2, s48_enter_integer(q->count));
SET(sidx+2, s48_enter_fixnum(q->count));
} break;
default: {
@ -308,8 +309,8 @@ s48_value scx_enter_event(XEvent* e) {
// more??
// And the Event-Name
temp2 = Bit_To_Symbol(e->type, Event_Syms);
r = s48_cons(temp2, r);
temp = s48_enter_integer(e->type);
r = s48_cons(temp, r);
S48_GC_UNPROTECT();
return r;
@ -345,8 +346,8 @@ s48_value scx_Get_Motion_Events(s48_value Xdisplay, s48_value Xwindow,
S48_GC_PROTECT_3(v, l, t);
for (i = 0; i < n; i++) {
t = s48_enter_integer(p[i].y); l = s48_cons(t, S48_NULL);
t = s48_enter_integer(p[i].x); l = s48_cons(t, l);
t = s48_enter_fixnum(p[i].y); l = s48_cons(t, S48_NULL);
t = s48_enter_fixnum(p[i].x); l = s48_cons(t, l);
t = SCX_ENTER_TIME(p[i].time); l = s48_cons(t, l);
S48_VECTOR_SET(v, i, l);

41
c/xlib/font.c
View File

@ -107,21 +107,23 @@ s48_value scx_List_Fonts(s48_value Xdisplay, s48_value pattern) {
}
s48_value scx_Font_Properties(s48_value Xfontstruct) {
s48_value v = S48_FALSE;
s48_value v, t = S48_FALSE;
int i,n;
XFontStruct* fs = SCX_EXTRACT_FONTSTRUCT(Xfontstruct);
XFontProp* p;
S48_DECLARE_GC_PROTECT(1);
S48_DECLARE_GC_PROTECT(2);
n = fs->n_properties;
v = s48_make_vector(n, S48_FALSE);
S48_GC_PROTECT_1(v);
S48_GC_PROTECT_2(v, t);
for (i = 0; i < n; i++) {
p = fs->properties+i;
S48_VECTOR_SET(v, i, s48_cons( SCX_ENTER_ATOM(p->name),
s48_enter_integer(p->card32) ));
t = SCX_ENTER_ATOM(p->name);
t = s48_cons(t, s48_enter_integer(p->card32));
S48_VECTOR_SET(v, i, t);
}
S48_GC_UNPROTECT();
return v;
}
@ -142,15 +144,15 @@ s48_value scx_Font_Info(s48_value Xfontstruct) {
S48_DECLARE_GC_PROTECT(1);
S48_GC_PROTECT_1(v);
S48_VECTOR_SET(v, 0, Bit_To_Symbol(fs->direction, Direction_Syms));
S48_VECTOR_SET(v, 1, s48_enter_integer(fs->min_char_or_byte2));
S48_VECTOR_SET(v, 2, s48_enter_integer(fs->max_char_or_byte2));
S48_VECTOR_SET(v, 3, s48_enter_integer(fs->min_byte1));
S48_VECTOR_SET(v, 4, s48_enter_integer(fs->max_byte1));
S48_VECTOR_SET(v, 0, s48_enter_fixnum(fs->direction));
S48_VECTOR_SET(v, 1, s48_enter_fixnum(fs->min_char_or_byte2));
S48_VECTOR_SET(v, 2, s48_enter_fixnum(fs->max_char_or_byte2));
S48_VECTOR_SET(v, 3, s48_enter_fixnum(fs->min_byte1));
S48_VECTOR_SET(v, 4, s48_enter_fixnum(fs->max_byte1));
S48_VECTOR_SET(v, 5, S48_ENTER_BOOLEAN(fs->all_chars_exist));
S48_VECTOR_SET(v, 6, s48_enter_integer(fs->default_char));
S48_VECTOR_SET(v, 7, s48_enter_integer(fs->ascent));
S48_VECTOR_SET(v, 8, s48_enter_integer(fs->descent));
S48_VECTOR_SET(v, 6, s48_enter_fixnum(fs->default_char));
S48_VECTOR_SET(v, 7, s48_enter_fixnum(fs->ascent));
S48_VECTOR_SET(v, 8, s48_enter_fixnum(fs->descent));
S48_GC_UNPROTECT();
return v;
@ -172,12 +174,13 @@ s48_value scx_Char_Info(s48_value Xfontstruct, s48_value index) {
v = s48_make_vector(6, S48_FALSE);
S48_GC_PROTECT_1(v);
S48_VECTOR_SET(v, 0, s48_enter_integer(cp->lbearing));
S48_VECTOR_SET(v, 1, s48_enter_integer(cp->rbearing));
S48_VECTOR_SET(v, 2, s48_enter_integer(cp->width));
S48_VECTOR_SET(v, 3, s48_enter_integer(cp->ascent));
S48_VECTOR_SET(v, 4, s48_enter_integer(cp->descent));
S48_VECTOR_SET(v, 5, s48_enter_integer(cp->attributes));
S48_VECTOR_SET(v, 0, s48_enter_fixnum(cp->lbearing));
S48_VECTOR_SET(v, 1, s48_enter_fixnum(cp->rbearing));
S48_VECTOR_SET(v, 2, s48_enter_fixnum(cp->width));
S48_VECTOR_SET(v, 3, s48_enter_fixnum(cp->ascent));
S48_VECTOR_SET(v, 4, s48_enter_fixnum(cp->descent));
S48_VECTOR_SET(v, 5, s48_enter_fixnum(cp->attributes));
S48_GC_UNPROTECT();
return v;

173
c/xlib/gcontext.c
View File

@ -1,84 +1,56 @@
#include "xlib.h"
unsigned long Values_To_GCValues(s48_value values, XGCValues* GCV) {
unsigned long mask = 0;
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;
}
}
}
unsigned long mask = s48_extract_integer(S48_CAR(values));
s48_value v = S48_CDR(values);
if (mask & GCFunction)
GCV->function = s48_extract_integer(S48_VECTOR_REF(v, 0));
if (mask & GCPlaneMask)
GCV->plane_mask = SCX_EXTRACT_PIXEL(S48_VECTOR_REF(v, 1));
if (mask & GCForeground)
GCV->foreground = SCX_EXTRACT_PIXEL(S48_VECTOR_REF(v, 2));
if (mask & GCBackground)
GCV->background = SCX_EXTRACT_PIXEL(S48_VECTOR_REF(v, 3));
if (mask & GCLineWidth)
GCV->line_width = s48_extract_integer(S48_VECTOR_REF(v, 4));
if (mask & GCLineStyle)
GCV->line_style = s48_extract_integer(S48_VECTOR_REF(v, 5));
if (mask & GCCapStyle)
GCV->cap_style = s48_extract_integer(S48_VECTOR_REF(v, 6));
if (mask & GCJoinStyle)
GCV->join_style = s48_extract_integer(S48_VECTOR_REF(v, 7));
if (mask & GCFillStyle)
GCV->fill_style = s48_extract_integer(S48_VECTOR_REF(v, 8));
if (mask & GCFillRule)
GCV->fill_rule = s48_extract_integer(S48_VECTOR_REF(v, 9));
if (mask & GCTile)
GCV->tile = SCX_EXTRACT_PIXMAP(S48_VECTOR_REF(v, 10));
if (mask & GCStipple)
GCV->stipple = SCX_EXTRACT_PIXMAP(S48_VECTOR_REF(v, 11));
if (mask & GCTileStipXOrigin)
GCV->ts_x_origin = s48_extract_integer(S48_VECTOR_REF(v, 12));
if (mask & GCTileStipYOrigin)
GCV->ts_y_origin = s48_extract_integer(S48_VECTOR_REF(v, 13));
if (mask & GCFont)
GCV->font = SCX_EXTRACT_FONT(S48_VECTOR_REF(v, 14));
if (mask & GCSubwindowMode)
GCV->subwindow_mode = s48_extract_integer(S48_VECTOR_REF(v, 15));
if (mask & GCGraphicsExposures)
GCV->graphics_exposures = S48_ENTER_BOOLEAN(S48_VECTOR_REF(v, 16));
if (mask & GCClipXOrigin)
GCV->clip_x_origin = s48_extract_integer(S48_VECTOR_REF(v, 17));
if (mask & GCClipYOrigin)
GCV->clip_y_origin = s48_extract_integer(S48_VECTOR_REF(v, 18));
if (mask & GCClipMask)
GCV->clip_mask = SCX_EXTRACT_PIXMAP(S48_VECTOR_REF(v, 19));
if (mask & GCDashOffset)
GCV->dash_offset = s48_extract_integer(S48_VECTOR_REF(v, 20));
if (mask & GCDashList)
GCV->dashes = (char)s48_extract_integer(S48_VECTOR_REF(v, 21));
if (mask & GCArcMode)
GCV->arc_mode = s48_extract_integer(S48_VECTOR_REF(v, 22));
return mask;
}
@ -102,9 +74,7 @@ s48_value scx_Copy_Gc(s48_value Xdisplay, s48_value Xsource, s48_value Xdest) {
s48_value scx_Copy_Gc_To_Gc(s48_value Xdisplay, s48_value Xfrom, s48_value Xto,
s48_value attrs) {
unsigned long mask = 0;
mask = S48_SYMBOL_P(attrs) ? Symbol_To_Bit(attrs, Gcontext_Values_Syms) :
Symbols_To_Bits(attrs, Gcontext_Values_Syms);
unsigned long mask = s48_extract_integer(attrs); // -1 for all! ??
XCopyGC(SCX_EXTRACT_DISPLAY(Xdisplay), SCX_EXTRACT_GCONTEXT(Xfrom),
mask, SCX_EXTRACT_GCONTEXT(Xto));
return S48_UNSPECIFIC;
@ -137,32 +107,34 @@ s48_value scx_Get_Gc_Values (s48_value Xgcontext, s48_value Xdisplay) {
res = s48_make_vector(23, S48_FALSE);
S48_GC_PROTECT_1(res);
S48_VECTOR_SET(res, 0, Bit_To_Symbol(GCV.function, Func_Syms));
S48_VECTOR_SET(res, 0, s48_enter_integer(GCV.function));
S48_VECTOR_SET(res, 1, SCX_ENTER_PIXEL(GCV.plane_mask));
S48_VECTOR_SET(res, 2, SCX_ENTER_PIXEL(GCV.foreground));
S48_VECTOR_SET(res, 3, SCX_ENTER_PIXEL(GCV.background));
S48_VECTOR_SET(res, 4, s48_enter_integer(GCV.line_width));
S48_VECTOR_SET(res, 5, Bit_To_Symbol(GCV.line_style, Line_Style_Syms));
S48_VECTOR_SET(res, 6, Bit_To_Symbol(GCV.cap_style, Cap_Style_Syms));
S48_VECTOR_SET(res, 7, Bit_To_Symbol(GCV.join_style, Join_Style_Syms));
S48_VECTOR_SET(res, 8, Bit_To_Symbol(GCV.fill_style, Fill_Style_Syms));
S48_VECTOR_SET(res, 9, Bit_To_Symbol(GCV.fill_rule, Fill_Rule_Syms));
S48_VECTOR_SET(res, 10, Bit_To_Symbol(GCV.arc_mode, Arc_Mode_Syms));
S48_VECTOR_SET(res, 4, s48_enter_fixnum(GCV.line_width));
S48_VECTOR_SET(res, 5, s48_enter_integer(GCV.line_style));
S48_VECTOR_SET(res, 6, s48_enter_integer(GCV.cap_style));
S48_VECTOR_SET(res, 7, s48_enter_integer(GCV.join_style));
S48_VECTOR_SET(res, 8, s48_enter_integer(GCV.fill_style));
S48_VECTOR_SET(res, 9, s48_enter_integer(GCV.fill_rule));
S48_VECTOR_SET(res, 10, s48_enter_integer(GCV.arc_mode));
S48_VECTOR_SET(res, 11, SCX_ENTER_PIXMAP(GCV.tile));
S48_VECTOR_SET(res, 12, SCX_ENTER_PIXMAP(GCV.stipple));
S48_VECTOR_SET(res, 13, s48_enter_integer(GCV.ts_x_origin));
S48_VECTOR_SET(res, 14, s48_enter_integer(GCV.ts_y_origin));
S48_VECTOR_SET(res, 13, s48_enter_fixnum(GCV.ts_x_origin));
S48_VECTOR_SET(res, 14, s48_enter_fixnum(GCV.ts_y_origin));
S48_VECTOR_SET(res, 15, SCX_ENTER_FONT(GCV.font));
S48_VECTOR_SET(res, 16, Bit_To_Symbol(GCV.subwindow_mode,
Subwin_Mode_Syms));
S48_VECTOR_SET(res, 17, GCV.graphics_exposures ? S48_TRUE : S48_FALSE);
S48_VECTOR_SET(res, 18, s48_enter_integer(GCV.clip_x_origin));
S48_VECTOR_SET(res, 19, s48_enter_integer(GCV.clip_y_origin));
S48_VECTOR_SET(res, 16, s48_enter_integer(GCV.subwindow_mode));
S48_VECTOR_SET(res, 17, S48_ENTER_BOOLEAN(GCV.graphics_exposures));
S48_VECTOR_SET(res, 18, s48_enter_fixnum(GCV.clip_x_origin));
S48_VECTOR_SET(res, 19, s48_enter_fixnum(GCV.clip_y_origin));
S48_VECTOR_SET(res, 20, SCX_ENTER_PIXMAP(GCV.clip_mask));
S48_VECTOR_SET(res, 21, s48_enter_integer(GCV.dash_offset));
S48_VECTOR_SET(res, 22, s48_enter_integer(GCV.dashes));
}
res = s48_cons(s48_enter_integer(mask), res);
S48_GC_UNPROTECT();
}
return res;
}
@ -218,26 +190,25 @@ s48_value scx_Set_Gcontext_Clip_Rectangles (s48_value Xgcontext,
SCX_EXTRACT_GCONTEXT(Xgcontext),
(int)s48_extract_integer (x),
(int)s48_extract_integer (y), p, n,
Symbol_To_Bit(ord, Ordering_Syms));
s48_extract_integer(ord));
return S48_UNSPECIFIC;
}
s48_value scx_Query_Best_Size (s48_value Xdisplay, s48_value width,
s48_value height, s48_value shape) {
unsigned int rw, rh;
Display* dpy = SCX_EXTRACT_DISPLAY(Xdisplay);
if (!XQueryBestSize (dpy,
Symbol_To_Bit (shape, Shape_Syms),
s48_extract_integer(shape),
DefaultRootWindow (dpy), //??
(int)s48_extract_integer (width),
(int)s48_extract_integer (height),
&rw, &rh))
return S48_FALSE;
else
return s48_cons (s48_enter_integer (rw), s48_enter_integer (rh));
return s48_cons (s48_enter_fixnum (rw), s48_enter_fixnum (rh));
}

34
c/xlib/grab.c
View File

@ -1,7 +1,4 @@
#include "xlib.h"
#include "scheme48.h"
int Get_Mode (s48_value m){
return S48_EXTRACT_BOOLEAN(m) ? GrabModeSync :GrabModeAsync;
@ -16,13 +13,13 @@ s48_value scx_Grab_Pointer (s48_value dpy, s48_value win,
int res = XGrabPointer(SCX_EXTRACT_DISPLAY(dpy),
SCX_EXTRACT_WINDOW(win),
S48_EXTRACT_BOOLEAN(ownerp),
Symbols_To_Bits(events, Event_Syms),
s48_extract_integer(events),
Get_Mode(psyncp),
Get_Mode(ksyncp),
SCX_EXTRACT_WINDOW(confine_to),
SCX_EXTRACT_CURSOR(cursor),
SCX_EXTRACT_TIME(time));
return Bit_To_Symbol(res, Grabstatus_Syms);
return s48_enter_integer(res);
}
@ -37,11 +34,11 @@ s48_value scx_Grab_Button (s48_value dpy, s48_value win, s48_value button,
s48_value psyncp, s48_value ksyncp,
s48_value confine_to, s48_value cursor){
XGrabButton(SCX_EXTRACT_DISPLAY(dpy),
Symbol_To_Bit(button, Button_Syms),
Symbols_To_Bits (mods, State_Syms),
s48_extract_integer(button),
s48_extract_integer(mods),
SCX_EXTRACT_WINDOW(win),
S48_EXTRACT_BOOLEAN(ownerp),
Symbols_To_Bits(events, Event_Syms),
s48_extract_integer(events),
Get_Mode(psyncp), Get_Mode(ksyncp),
SCX_EXTRACT_WINDOW(confine_to),
SCX_EXTRACT_CURSOR(cursor));
@ -52,8 +49,8 @@ s48_value scx_Grab_Button (s48_value dpy, s48_value win, s48_value button,
s48_value scx_Ungrab_Button (s48_value Xdpy, s48_value Xwin,
s48_value button, s48_value mods){
XUngrabButton(SCX_EXTRACT_DISPLAY(Xdpy),
Symbol_To_Bit(button, Button_Syms),
Symbols_To_Bits (mods, State_Syms),
s48_extract_integer(button),
s48_extract_integer(mods),
SCX_EXTRACT_WINDOW(Xwin));
return S48_UNSPECIFIC;
}
@ -62,7 +59,7 @@ s48_value scx_Ungrab_Button (s48_value Xdpy, s48_value Xwin,
s48_value scx_Change_Active_Pointer_Grab (s48_value Xdpy, s48_value events,
s48_value cursor, s48_value time){
XChangeActivePointerGrab (SCX_EXTRACT_DISPLAY(Xdpy),
Symbols_To_Bits(events, Event_Syms),
s48_extract_integer(events),
SCX_EXTRACT_CURSOR(cursor),
SCX_EXTRACT_TIME(time));
return S48_UNSPECIFIC;
@ -72,14 +69,13 @@ s48_value scx_Change_Active_Pointer_Grab (s48_value Xdpy, s48_value events,
s48_value scx_Grab_Keyboard (s48_value Xdpy, s48_value Xwin, s48_value ownerp,
s48_value psyncp, s48_value ksyncp,
s48_value time){
return Bit_To_Symbol((unsigned long)XGrabKeyboard (
SCX_EXTRACT_DISPLAY(Xdpy),
int res = XGrabKeyboard( SCX_EXTRACT_DISPLAY(Xdpy),
SCX_EXTRACT_WINDOW(Xwin),
S48_EXTRACT_BOOLEAN(ownerp),
Get_Mode(psyncp),
Get_Mode (ksyncp),
SCX_EXTRACT_TIME(time)),
Grabstatus_Syms);
SCX_EXTRACT_TIME(time));
return s48_enter_integer(res);
}
@ -98,7 +94,7 @@ s48_value scx_Grab_Key (s48_value Xdpy, s48_value Xwin, s48_value key,
keycode = (int)s48_extract_integer(key);
XGrabKey (SCX_EXTRACT_DISPLAY(Xdpy),
keycode,
Symbols_To_Bits (mods, State_Syms),
s48_extract_integer(mods),
SCX_EXTRACT_WINDOW(Xwin),
S48_EXTRACT_BOOLEAN(ownerp),
Get_Mode(psyncp),
@ -114,7 +110,7 @@ s48_value scx_Ungrab_Key (s48_value Xdpy, s48_value Xwin, s48_value key,
keycode = (int)s48_extract_integer(key);
XUngrabKey (SCX_EXTRACT_DISPLAY(Xdpy),
keycode,
Symbols_To_Bits (mods, State_Syms),
s48_extract_integer(mods),
SCX_EXTRACT_WINDOW(Xwin));
return S48_UNSPECIFIC;
}
@ -122,14 +118,12 @@ s48_value scx_Ungrab_Key (s48_value Xdpy, s48_value Xwin, s48_value key,
s48_value scx_Allow_Events (s48_value Xdpy, s48_value mode, s48_value time){
XAllowEvents (SCX_EXTRACT_DISPLAY(Xdpy),
Symbol_To_Bit (mode, Allow_Events_Syms),
s48_extract_integer(mode),
SCX_EXTRACT_TIME(time));
return S48_UNSPECIFIC;
}
s48_value scx_Grab_Server (s48_value Xdpy){
XGrabServer(SCX_EXTRACT_DISPLAY(Xdpy));
return S48_UNSPECIFIC;

2
c/xlib/graphics.c
View File

@ -287,7 +287,7 @@ s48_value scx_Fill_Polygon (s48_value Xdisplay, s48_value Xdrawable,
s48_value relative, s48_value shape){
int n = S48_VECTOR_LENGTH(vec);
int mode;
int sh = (int)Symbol_To_Bit(shape, Polyshape_Syms);
int sh = s48_extract_integer(shape);
XPoint p[n];
Vector_To_XPoints(vec, p, n);
mode = !S48_FALSE_P(relative) ? CoordModePrevious : CoordModeOrigin;

9
c/xlib/init.c
View File

@ -1,5 +1,4 @@
#include "xlib.h"
#include "scheme48.h"
s48_value scx_Xlib_Release_4_Or_Later () {
return S48_TRUE;
@ -21,8 +20,16 @@ s48_value scx_Xlib_Release_6_Or_Later () {
#endif
}
s48_value symbol_now_binding = S48_FALSE;
s48_value symbol_now() {
return S48_SHARED_BINDING_REF(symbol_now_binding);
}
void scx_init_init(void) {
S48_GC_PROTECT_GLOBAL(symbol_now_binding);
// *symbol-now* is defined in helper.scm
symbol_now_binding = s48_get_imported_binding("*symbol-now*");
S48_EXPORT_FUNCTION(scx_Xlib_Release_4_Or_Later);
S48_EXPORT_FUNCTION(scx_Xlib_Release_5_Or_Later);
S48_EXPORT_FUNCTION(scx_Xlib_Release_6_Or_Later);

15
c/xlib/key.c
View File

@ -1,5 +1,4 @@
#include "xlib.h"
#include "scheme48.h"
//#ifdef XLIB_RELEASE_5_OR_LATER
// I don't know if XDisplayKeycodes() was already there in X11R4.
@ -8,13 +7,13 @@
s48_value scx_Display_Min_Keycode (s48_value d) {
int mink, maxk;
XDisplayKeycodes(SCX_EXTRACT_DISPLAY(d), &mink, &maxk);
return s48_enter_integer(mink);
return s48_enter_fixnum(mink);
}
s48_value scx_Display_Max_Keycode (s48_value d) {
int mink, maxk;
XDisplayKeycodes(SCX_EXTRACT_DISPLAY(d), &mink, &maxk);
return s48_enter_integer(maxk);
return s48_enter_fixnum(maxk);
}
//#ifdef XLIB_RELEASE_5_OR_LATER
@ -28,7 +27,7 @@ s48_value scx_Display_Keysyms_Per_Keycode (s48_value d) {
ksyms = XGetKeyboardMapping(SCX_EXTRACT_DISPLAY(d), (KeyCode)mink,
maxk - mink + 1, &ksyms_per_kode);
XFree(ksyms);
return s48_enter_integer(ksyms_per_kode);
return s48_enter_fixnum(ksyms_per_kode);
}
//#else
@ -38,7 +37,7 @@ s48_value scx_Display_Keysyms_Per_Keycode (s48_value d) {
// Disable_Interrupts;
// (void)XKeycodeToKeysym (DISPLAY(d)->dpy, DISPLAY(d)->dpy->min_keycode, 0);
// Enable_Interrupts;
// return s48_enter_integer (DISPLAY(d)->dpy->keysyms_per_keycode);
// return s48_enter_fixnum (DISPLAY(d)->dpy->keysyms_per_keycode);
//}
//#endif
@ -69,7 +68,7 @@ s48_value scx_Keysym_To_Keycode (s48_value d, s48_value k) {
kc = XKeysymToKeycode (SCX_EXTRACT_DISPLAY(d),
(KeySym)s48_extract_integer(k));
//Enable_Interrupts;
return s48_enter_integer(kc);
return s48_enter_fixnum(kc);
}
s48_value scx_Lookup_String (s48_value d, s48_value k, s48_value mask) {
@ -81,7 +80,7 @@ s48_value scx_Lookup_String (s48_value d, s48_value k, s48_value mask) {
e.display = SCX_EXTRACT_DISPLAY(d);
e.keycode = (int)s48_extract_integer(k);
e.state = Symbols_To_Bits(mask, State_Syms);
e.state = s48_extract_integer(mask);
//Disable_Interrupts;
len = XLookupString (&e, buf, 1024, &keysym_return, &status_return);
//Enable_Interrupts;
@ -109,7 +108,7 @@ s48_value scx_Refresh_Keyboard_Mapping (s48_value d, s48_value w,
fake.type = MappingNotify;
fake.display = SCX_EXTRACT_DISPLAY(d);
fake.window = SCX_EXTRACT_WINDOW(w);
fake.request = Symbol_To_Bit (event, Mapping_Syms);
fake.request = s48_extract_integer(event);
XRefreshKeyboardMapping (&fake);
return S48_UNSPECIFIC;
}

3
c/xlib/pixel.c
View File

@ -11,7 +11,8 @@ s48_value scx_White_Pixel(s48_value Xdisplay) {
return SCX_ENTER_PIXEL( WhitePixel(dpy, DefaultScreen(dpy)) );
}
s48_value scx_Free_Pixel(s48_value Xpixel, s48_value Xdisplay, s48_value Xcolormap) {
s48_value scx_Free_Pixel(s48_value Xpixel, s48_value Xdisplay,
s48_value Xcolormap) {
unsigned long pixels[1];
pixels[0] = SCX_EXTRACT_PIXEL(Xpixel);

12
c/xlib/pixmap.c
View File

@ -57,13 +57,13 @@ s48_value scx_Read_Bitmap_File (s48_value Xdisplay, s48_value Xdrawable,
&xhot, &yhot);
// Not used: Enable_Interrupts;
if (res != BitmapSuccess){
return Bit_To_Symbol ((unsigned long)ret, Bitmapstatus_Syms);
return s48_enter_integer(ret);
}
S48_GC_PROTECT_1 (ret);
ret = s48_cons (s48_enter_integer(yhot), S48_NULL);
ret = s48_cons (s48_enter_integer(xhot), ret);
ret = s48_cons (s48_enter_integer(height), ret);
ret = s48_cons (s48_enter_integer(width), ret);
ret = s48_cons (s48_enter_fixnum(yhot), S48_NULL);
ret = s48_cons (s48_enter_fixnum(xhot), ret);
ret = s48_cons (s48_enter_fixnum(height), ret);
ret = s48_cons (s48_enter_fixnum(width), ret);
ret = s48_cons (SCX_ENTER_PIXMAP(bitmap), ret);
S48_GC_UNPROTECT();
return ret;
@ -84,7 +84,7 @@ s48_value scx_Write_Bitmap_File (s48_value Xdisplay, s48_value file,
(int)s48_extract_integer(x),
(int)s48_extract_integer(y));
// Enable_Interrupts;
return Bit_To_Symbol ((unsigned long)ret, Bitmapstatus_Syms);
return s48_enter_integer(ret);
}

4
c/xlib/property.c
View File

@ -102,7 +102,7 @@ s48_value scx_Change_Property(s48_value Xdisplay, s48_value Xwindow,
s48_value data){
int i, x, f, m, nitems;
char* buf;
m = Symbol_To_Bit (mode, Propmode_Syms);
m = s48_extract_integer(mode);
f = (int)s48_extract_integer(format);
switch (f) {
case 8:
@ -158,7 +158,7 @@ s48_value scx_Set_Selection_Owner (s48_value Xdisplay, s48_value Xatom_s,
s48_value scx_Get_Selection_Owner (s48_value Xdisplay, s48_value Xatom_s){
return SCX_ENTER_WINDOW (XGetSelectionOwner (SCX_EXTRACT_DISPLAY(Xdisplay),
return SCX_ENTER_WINDOW(XGetSelectionOwner(SCX_EXTRACT_DISPLAY(Xdisplay),
SCX_EXTRACT_ATOM(Xatom_s)));
}

12
c/xlib/region.c
View File

@ -17,10 +17,10 @@ s48_value scx_Clip_Box(s48_value Xregion) {
XClipBox(SCX_EXTRACT_REGION(Xregion), &r);
S48_GC_PROTECT_1(v);
S48_VECTOR_SET(v, 0, s48_enter_integer(r.x));
S48_VECTOR_SET(v, 1, s48_enter_integer(r.y));
S48_VECTOR_SET(v, 2, s48_enter_integer(r.width));
S48_VECTOR_SET(v, 3, s48_enter_integer(r.height));
S48_VECTOR_SET(v, 0, s48_enter_fixnum(r.x));
S48_VECTOR_SET(v, 1, s48_enter_fixnum(r.y));
S48_VECTOR_SET(v, 2, s48_enter_fixnum(r.width));
S48_VECTOR_SET(v, 3, s48_enter_fixnum(r.height));
S48_GC_UNPROTECT();
return v;
@ -51,7 +51,7 @@ s48_value scx_Rect_In_Region(s48_value Xregion, s48_value x, s48_value y,
if (res == RectangleIn) res = 1;
else if (res == RectangleOut) res = 0;
else if (res == RectanglePart) res = 2;
return s48_enter_integer(res);
return s48_enter_fixnum(res);
}
s48_value scx_Intersect_Region(s48_value Xr1, s48_value Xr2) {
@ -126,7 +126,7 @@ s48_value scx_Copy_Region(s48_value Xfrom, s48_value Xto) {
s48_value scx_Polygon_Region(s48_value points, s48_value fillrule) {
int n = S48_VECTOR_LENGTH(points);
XPoint ps[n];
int fill_rule = Symbols_To_Bits(fillrule, Fill_Rule_Syms);
int fill_rule = s48_extract_integer(fillrule);
int i;
Region res;
for (i=0; i < n; i++) {

12
c/xlib/text.c
View File

@ -31,7 +31,7 @@ s48_value scx_Text_Width(s48_value Xfontstruct, s48_value text,
}
i = XTextWidth(font, s, len);
}
return s48_enter_integer((long)i);
return s48_enter_fixnum((long)i);
}
@ -57,15 +57,15 @@ s48_value scx_Extents_Text (s48_value Xfontstruct, s48_value text,
}
switch(s48_extract_integer(which)){
case 0:
return s48_enter_integer((long) CI.lbearing);
return s48_enter_fixnum((long) CI.lbearing);
case 1:
return s48_enter_integer((long) CI.rbearing);
return s48_enter_fixnum((long) CI.rbearing);
case 2:
return s48_enter_integer((long) CI.width);
return s48_enter_fixnum((long) CI.width);
case 3:
return s48_enter_integer((long) CI.ascent);
return s48_enter_fixnum((long) CI.ascent);
case 4:
return s48_enter_integer((long) CI.descent);
return s48_enter_fixnum((long) CI.descent);
}
return S48_FALSE;
}

40
c/xlib/util.c
View File

@ -28,38 +28,18 @@ s48_value scx_Parse_Geometry (s48_value strg) {
S48_DECLARE_GC_PROTECT(1);
res = XParseGeometry (s48_extract_string(strg), &x, &y, &w, &h);
ret = s48_make_vector(6, S48_FALSE);
S48_GC_PROTECT_1(ret);
if (res & XNegative) {
ret = s48_cons(S48_TRUE, S48_NULL);
}else{
ret = s48_cons(S48_FALSE, S48_NULL);
}
if (res & YNegative) {
ret = s48_cons(S48_TRUE, ret);
}else{
ret = s48_cons(S48_FALSE, ret);
}
if (res & XValue) {
ret = s48_cons(s48_enter_integer(x), ret);
}else{
ret = s48_cons(S48_FALSE, ret);
}
if (res & YValue) {
ret = s48_cons(s48_enter_integer(y), ret);
}else{
ret = s48_cons(S48_FALSE, ret);
}
if (res & WidthValue) {
ret = s48_cons(s48_enter_integer(w), ret);
}else{
ret = s48_cons(S48_FALSE, ret);
}
if (res & HeightValue) {
ret = s48_cons(s48_enter_integer (h), ret);
}else{
ret = s48_cons(S48_FALSE, ret);
}
if (res & XNegative) S48_VECTOR_SET(ret, 0, S48_TRUE);
if (res & YNegative) S48_VECTOR_SET(ret, 1, S48_TRUE);
if (res & XValue) S48_VECTOR_SET(ret, 2, s48_enter_fixnum(x));
if (res & YValue) S48_VECTOR_SET(ret, 3, s48_enter_fixnum(y));
if (res & WidthValue) S48_VECTOR_SET(ret, 4, s48_enter_fixnum(w));
if (res & HeightValue) S48_VECTOR_SET(ret, 5, s48_enter_fixnum (h));
S48_GC_UNPROTECT();
return ret;
}

102
c/xlib/visual.c
View File

@ -1,26 +1,55 @@
#include "xlib.h"
s48_value Enter_Visual_Info(XVisualInfo* vi) {
s48_value Enter_Visual_And_Visual_Info(XVisualInfo* vi) {
s48_value t = s48_make_vector(10, S48_FALSE);
S48_DECLARE_GC_PROTECT(1);
S48_GC_PROTECT_1(t);
S48_VECTOR_SET(t, 0, SCX_ENTER_VISUAL(vi->visual));
S48_VECTOR_SET(t, 1, s48_enter_integer(vi->visualid));
S48_VECTOR_SET(t, 2, s48_enter_integer(vi->screen));
S48_VECTOR_SET(t, 3, s48_enter_integer(vi->depth));
S48_VECTOR_SET(t, 4, Bit_To_Symbol(vi->class, Visual_Class_Syms));
S48_VECTOR_SET(t, 5, s48_enter_integer(vi->red_mask));
S48_VECTOR_SET(t, 6, s48_enter_integer(vi->green_mask));
S48_VECTOR_SET(t, 7, s48_enter_integer(vi->blue_mask));
S48_VECTOR_SET(t, 8, s48_enter_integer(vi->colormap_size));
S48_VECTOR_SET(t, 9, s48_enter_integer(vi->bits_per_rgb));
S48_VECTOR_SET(t, 0, s48_enter_integer(vi->visualid));
S48_VECTOR_SET(t, 1, s48_enter_fixnum(vi->screen));
S48_VECTOR_SET(t, 2, s48_enter_fixnum(vi->depth));
S48_VECTOR_SET(t, 3, s48_enter_integer(vi->class));
S48_VECTOR_SET(t, 4, s48_enter_integer(vi->red_mask));
S48_VECTOR_SET(t, 5, s48_enter_integer(vi->green_mask));
S48_VECTOR_SET(t, 6, s48_enter_integer(vi->blue_mask));
S48_VECTOR_SET(t, 7, s48_enter_integer(vi->colormap_size));
S48_VECTOR_SET(t, 8, s48_enter_fixnum(vi->bits_per_rgb));
t = s48_cons(s48_enter_integer(VisualAllMask), t);
t = s48_cons(SCX_ENTER_VISUAL(vi->visual), t);
S48_GC_UNPROTECT();
return t;
}
unsigned long Extract_Visual_Info(s48_value vi, XVisualInfo* VI) {
unsigned long mask = s48_extract_integer(S48_CAR(vi));
s48_value v = S48_CDR(vi);
if (mask & VisualIDMask)
VI->visualid = s48_extract_integer(S48_VECTOR_REF(v, 0));
if (mask & VisualScreenMask)
VI->screen = s48_extract_integer(S48_VECTOR_REF(v, 1));
if (mask & VisualDepthMask)
VI->depth = s48_extract_integer(S48_VECTOR_REF(v, 2));
if (mask & VisualClassMask)
VI->class = s48_extract_integer(S48_VECTOR_REF(v, 3));
if (mask & VisualRedMaskMask)
VI->red_mask = s48_extract_integer(S48_VECTOR_REF(v, 4));
if (mask & VisualGreenMaskMask)
VI->green_mask = s48_extract_integer(S48_VECTOR_REF(v, 5));
if (mask & VisualBlueMaskMask)
VI->blue_mask = s48_extract_integer(S48_VECTOR_REF(v, 6));
if (mask & VisualColormapSizeMask)
VI->colormap_size = s48_extract_integer(S48_VECTOR_REF(v, 7));
if (mask & VisualBitsPerRGBMask)
VI->bits_per_rgb = s48_extract_integer(S48_VECTOR_REF(v, 8));
return mask;
}
s48_value scx_Get_Visual_Info(s48_value Xdisplay, s48_value v) {
XVisualInfo template;
XVisualInfo* visualList;
@ -29,50 +58,7 @@ s48_value scx_Get_Visual_Info(s48_value Xdisplay, s48_value v) {
s48_value res = S48_FALSE;
S48_DECLARE_GC_PROTECT(1);
for (i=1; i<10; i++) {
s48_value val = S48_VECTOR_REF(v, i);
if (!S48_FALSE_P(val)) {
switch (i) {
// 0 = visual is not allowed here.
case 1: {
template.visualid = s48_extract_integer(val);
mask |= VisualIDMask;
} break;
case 2: {
template.screen = s48_extract_integer(val);
mask |= VisualScreenMask;
} break;
case 3: {
template.depth = s48_extract_integer(val);
mask |= VisualDepthMask;
} break;
case 4: {
template.class = Symbol_To_Bit(val, Visual_Class_Syms);
mask |= VisualClassMask;
} break;
case 5: {
template.red_mask = s48_extract_integer(val);
mask |= VisualRedMaskMask;
} break;
case 6: {
template.green_mask = s48_extract_integer(val);
mask |= VisualGreenMaskMask;
} break;
case 7: {
template.blue_mask = s48_extract_integer(val);
mask |= VisualBlueMaskMask;
} break;
case 8: {
template.colormap_size = s48_extract_integer(val);
mask |= VisualColormapSizeMask;
} break;
case 9: {
template.bits_per_rgb = s48_extract_integer(val);
mask |= VisualBitsPerRGBMask;
} break;
}
}
}
mask = Extract_Visual_Info(v, &template);
visualList = XGetVisualInfo( SCX_EXTRACT_DISPLAY(Xdisplay),
mask, &template, &visualsMatch);
@ -81,7 +67,7 @@ s48_value scx_Get_Visual_Info(s48_value Xdisplay, s48_value v) {
S48_GC_PROTECT_1(res);
for (i=0; i<visualsMatch; i++)
S48_VECTOR_SET(res, i, Enter_Visual_Info(&visualList[i]));
S48_VECTOR_SET(res, i, Enter_Visual_And_Visual_Info(&visualList[i]));
S48_GC_UNPROTECT();
return res;
@ -97,9 +83,9 @@ s48_value scx_Match_Visual_Info(s48_value Xdisplay, s48_value scrnum,
if (XMatchVisualInfo(SCX_EXTRACT_DISPLAY(Xdisplay),
s48_extract_integer(scrnum),
s48_extract_integer(depth),
Symbol_To_Bit(class, Visual_Class_Syms),
s48_extract_integer(class),
&r))
return Enter_Visual_Info(&r);
return Enter_Visual_And_Visual_Info(&r);
else
return S48_FALSE;
}

207
c/xlib/window.c
View File

@ -2,62 +2,39 @@
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;
}
}
}
unsigned long mask = s48_extract_integer(S48_CAR(attribs));
s48_value v = S48_CDR(attribs);
if (mask & CWBackPixmap)
Xattrs->background_pixmap = SCX_EXTRACT_PIXMAP(S48_VECTOR_REF(v, 0));
if (mask & CWBackPixel)
Xattrs->background_pixel = s48_extract_integer(S48_VECTOR_REF(v, 1));
if (mask & CWBorderPixmap)
Xattrs->border_pixmap = SCX_EXTRACT_PIXMAP(S48_VECTOR_REF(v, 2));
if (mask & CWBorderPixel)
Xattrs->border_pixel = s48_extract_integer(S48_VECTOR_REF(v, 3));
if (mask & CWBitGravity)
Xattrs->bit_gravity = s48_extract_integer(S48_VECTOR_REF(v, 4));
if (mask & CWWinGravity)
Xattrs->win_gravity = s48_extract_integer(S48_VECTOR_REF(v, 5));
if (mask & CWBackingStore)
Xattrs->backing_store = s48_extract_integer(S48_VECTOR_REF(v, 6));
if (mask & CWBackingPlanes)
Xattrs->backing_planes = s48_extract_integer(S48_VECTOR_REF(v, 7));
if (mask & CWBackingPixel)
Xattrs->backing_pixel = s48_extract_integer(S48_VECTOR_REF(v, 8));
if (mask & CWOverrideRedirect)
Xattrs->override_redirect = s48_extract_integer(S48_VECTOR_REF(v, 9));
if (mask & CWSaveUnder)
Xattrs->save_under = s48_extract_integer(S48_VECTOR_REF(v, 10));
if (mask & CWEventMask)
Xattrs->event_mask = s48_extract_integer(S48_VECTOR_REF(v, 11));
if (mask & CWDontPropagate)
Xattrs->do_not_propagate_mask = s48_extract_integer(S48_VECTOR_REF(v, 12));
if (mask & CWColormap)
Xattrs->colormap = SCX_EXTRACT_COLORMAP(S48_VECTOR_REF(v, 13));
if (mask & CWCursor)
Xattrs->cursor = SCX_EXTRACT_CURSOR(S48_VECTOR_REF(v, 14));
return mask;
}
@ -119,7 +96,8 @@ s48_value scx_Get_Window_Attributes(s48_value Xdisplay, s48_value Xwindow) {
s48_value res = S48_NULL;
if (!XGetWindowAttributes(SCX_EXTRACT_DISPLAY(Xdisplay),SCX_EXTRACT_WINDOW(Xwindow),
if (!XGetWindowAttributes(SCX_EXTRACT_DISPLAY(Xdisplay),
SCX_EXTRACT_WINDOW(Xwindow),
&WA))
res = S48_FALSE;
else {
@ -127,36 +105,32 @@ s48_value scx_Get_Window_Attributes(s48_value Xdisplay, s48_value Xwindow) {
res = s48_make_vector(23, S48_FALSE);
S48_VECTOR_SET(res, 0, s48_enter_integer(WA.x));
S48_VECTOR_SET(res, 1, s48_enter_integer(WA.y));
S48_VECTOR_SET(res, 2, s48_enter_integer(WA.width));
S48_VECTOR_SET(res, 3, s48_enter_integer(WA.height));
S48_VECTOR_SET(res, 4, s48_enter_integer(WA.border_width));
S48_VECTOR_SET(res, 5, s48_enter_integer(WA.depth));
S48_VECTOR_SET(res, 0, s48_enter_fixnum(WA.x));
S48_VECTOR_SET(res, 1, s48_enter_fixnum(WA.y));
S48_VECTOR_SET(res, 2, s48_enter_fixnum(WA.width));
S48_VECTOR_SET(res, 3, s48_enter_fixnum(WA.height));
S48_VECTOR_SET(res, 4, s48_enter_fixnum(WA.border_width));
S48_VECTOR_SET(res, 5, s48_enter_fixnum(WA.depth));
S48_VECTOR_SET(res, 6, SCX_ENTER_VISUAL(WA.visual));
S48_VECTOR_SET(res, 7, SCX_ENTER_WINDOW(WA.root));
S48_VECTOR_SET(res, 8, Bit_To_Symbol(WA.class, Class_Syms));
S48_VECTOR_SET(res, 9, Bit_To_Symbol(WA.bit_gravity, Bit_Grav_Syms));
S48_VECTOR_SET(res, 10, Bit_To_Symbol(WA.win_gravity, Grav_Syms));
S48_VECTOR_SET(res, 11, Bit_To_Symbol(WA.backing_store,
Backing_Store_Syms));
S48_VECTOR_SET(res, 8, s48_enter_integer(WA.class));
S48_VECTOR_SET(res, 9, s48_enter_integer(WA.bit_gravity));
S48_VECTOR_SET(res, 10, s48_enter_integer(WA.win_gravity));
S48_VECTOR_SET(res, 11, s48_enter_integer(WA.backing_store));
S48_VECTOR_SET(res, 12, s48_enter_integer(WA.backing_planes));
S48_VECTOR_SET(res, 13, SCX_ENTER_PIXEL(WA.backing_pixel));
S48_VECTOR_SET(res, 14, WA.save_under ? S48_TRUE : S48_FALSE );
S48_VECTOR_SET(res, 15, SCX_ENTER_COLORMAP( WA.colormap ));
S48_VECTOR_SET(res, 16, WA.map_installed ? S48_TRUE : S48_FALSE);
S48_VECTOR_SET(res, 17, Bit_To_Symbol( WA.map_state, Map_State_Syms));
S48_VECTOR_SET(res, 18, Bits_To_Symbols( WA.all_event_masks,
Event_Mask_Syms ));
S48_VECTOR_SET(res, 19, Bits_To_Symbols( WA.your_event_mask,
Event_Mask_Syms ));
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, 14, s48_enter_fixnum(WA.save_under));
S48_VECTOR_SET(res, 15, SCX_ENTER_COLORMAP(WA.colormap));
S48_VECTOR_SET(res, 16, s48_enter_fixnum(WA.map_installed));
S48_VECTOR_SET(res, 17, s48_enter_integer(WA.map_state));
S48_VECTOR_SET(res, 18, s48_enter_integer(WA.all_event_masks));
S48_VECTOR_SET(res, 19, s48_enter_integer(WA.your_event_mask));
S48_VECTOR_SET(res, 20, s48_enter_integer(WA.do_not_propagate_mask));
S48_VECTOR_SET(res, 21, s48_enter_fixnum(WA.override_redirect));
S48_VECTOR_SET(res, 22, S48_FALSE);
//S48_VECTOR_SET(res, 22, s48_enter_integer((long)WA.screen));
//S48_VECTOR_SET(res, 22, s48_enter_fixnum((long)WA.screen));
// WA.screen not yet supported
res = s48_cons(s48_enter_integer((1L<<23) - 1), res);
}
S48_GC_UNPROTECT();
@ -164,32 +138,16 @@ s48_value scx_Get_Window_Attributes(s48_value Xdisplay, s48_value Xwindow) {
}
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;
}
}
}
unsigned long mask = s48_extract_integer(S48_CAR(changes));
s48_value v = S48_CDR(changes);
WC->x = s48_extract_integer(S48_VECTOR_REF(v, 0));
WC->y = s48_extract_integer(S48_VECTOR_REF(v, 1));
WC->width = s48_extract_integer(S48_VECTOR_REF(v, 2));
WC->height = s48_extract_integer(S48_VECTOR_REF(v, 3));
WC->sibling = SCX_EXTRACT_WINDOW(S48_VECTOR_REF(v, 4));
WC->stack_mode = s48_extract_integer(S48_VECTOR_REF(v, 5));
return mask;
}
@ -214,7 +172,8 @@ s48_value scx_Unmap_Window(s48_value Xwindow, s48_value Xdisplay) {
}
s48_value scx_Destroy_Subwindows (s48_value Xwindow, s48_value Xdisplay) {
XDestroySubwindows(SCX_EXTRACT_DISPLAY(Xdisplay), SCX_EXTRACT_WINDOW(Xwindow));
XDestroySubwindows(SCX_EXTRACT_DISPLAY(Xdisplay),
SCX_EXTRACT_WINDOW(Xwindow));
return S48_UNSPECIFIC;
}
@ -230,7 +189,8 @@ s48_value scx_Unmap_Subwindows (s48_value Xwindow, s48_value Xdisplay) {
s48_value scx_Circulate_Subwindows(s48_value Xwindow, s48_value Xdisplay,
s48_value dir) {
XCirculateSubwindows(SCX_EXTRACT_DISPLAY(Xdisplay), SCX_EXTRACT_WINDOW(Xwindow),
XCirculateSubwindows(SCX_EXTRACT_DISPLAY(Xdisplay),
SCX_EXTRACT_WINDOW(Xwindow),
S48_FALSE_P(dir) ? RaiseLowest : LowerHighest);
return S48_UNSPECIFIC;
}
@ -285,8 +245,8 @@ s48_value scx_Translate_Coordinates (s48_value Xdisplay, s48_value srcXwindow,
S48_GC_PROTECT_1 (v);
v = s48_make_vector(3, S48_FALSE);
S48_VECTOR_SET(v, 0, s48_enter_integer(rx));
S48_VECTOR_SET(v, 1, s48_enter_integer(ry));
S48_VECTOR_SET(v, 0, s48_enter_fixnum(rx));
S48_VECTOR_SET(v, 1, s48_enter_fixnum(ry));
S48_VECTOR_SET(v, 2, SCX_ENTER_WINDOW(child));
S48_GC_UNPROTECT();
@ -308,14 +268,14 @@ s48_value scx_Query_Pointer (s48_value Xdisplay, s48_value Xwindow) {
v = s48_make_vector(8, S48_FALSE);
S48_GC_PROTECT_1(v);
S48_VECTOR_SET(v, 0, s48_enter_integer(x));
S48_VECTOR_SET(v, 1, s48_enter_integer(y));
S48_VECTOR_SET(v, 0, s48_enter_fixnum(x));
S48_VECTOR_SET(v, 1, s48_enter_fixnum(y));
S48_VECTOR_SET(v, 2, ret ? S48_TRUE : S48_FALSE);
S48_VECTOR_SET(v, 3, SCX_ENTER_WINDOW(root));
S48_VECTOR_SET(v, 4, s48_enter_integer(r_x));
S48_VECTOR_SET(v, 5, s48_enter_integer(r_y));
S48_VECTOR_SET(v, 4, s48_enter_fixnum(r_x));
S48_VECTOR_SET(v, 5, s48_enter_fixnum(r_y));
S48_VECTOR_SET(v, 6, SCX_ENTER_WINDOW(child));
S48_VECTOR_SET(v, 7, Bits_To_Symbols ((unsigned long)mask, State_Syms));
S48_VECTOR_SET(v, 7, s48_enter_integer((unsigned long)mask));
S48_GC_UNPROTECT();
return v;
@ -324,7 +284,8 @@ s48_value scx_Query_Pointer (s48_value Xdisplay, s48_value Xwindow) {
s48_value scx_Get_Geometry(s48_value Xdisplay, s48_value Xdrawable) {
s48_value v = S48_FALSE;
Window root;
unsigned int x,y,width,height,border_width,depth;
int x, y;
unsigned int width, height, border_width, depth;
S48_DECLARE_GC_PROTECT(1);
XGetGeometry(SCX_EXTRACT_DISPLAY(Xdisplay), SCX_EXTRACT_DRAWABLE(Xdrawable),
@ -333,12 +294,12 @@ s48_value scx_Get_Geometry(s48_value Xdisplay, s48_value Xdrawable) {
v = s48_make_vector(7, S48_FALSE);
S48_GC_PROTECT_1(v);
S48_VECTOR_SET(v, 0, SCX_ENTER_WINDOW(root));
S48_VECTOR_SET(v, 1, s48_enter_integer(x));
S48_VECTOR_SET(v, 2, s48_enter_integer(y));
S48_VECTOR_SET(v, 3, s48_enter_integer(width));
S48_VECTOR_SET(v, 4, s48_enter_integer(height));
S48_VECTOR_SET(v, 5, s48_enter_integer(border_width));
S48_VECTOR_SET(v, 6, s48_enter_integer(depth));
S48_VECTOR_SET(v, 1, s48_enter_fixnum(x));
S48_VECTOR_SET(v, 2, s48_enter_fixnum(y));
S48_VECTOR_SET(v, 3, s48_enter_fixnum(width));
S48_VECTOR_SET(v, 4, s48_enter_fixnum(height));
S48_VECTOR_SET(v, 5, s48_enter_fixnum(border_width));
S48_VECTOR_SET(v, 6, s48_enter_fixnum(depth));
S48_GC_UNPROTECT();
return v;
}

13
c/xlib/wm.c
View File

@ -44,13 +44,10 @@ s48_value scx_List_Installed_Colormaps(s48_value Xdisplay, s48_value Xwindow) {
s48_value scx_Set_Input_Focus(s48_value Xdisplay, s48_value Xwindow,
s48_value revert_to, s48_value time) {
Window focus = PointerRoot;
if (!S48_SYMBOL_P(Xwindow))
focus = SCX_EXTRACT_WINDOW(Xwindow);
Window focus = SCX_EXTRACT_WINDOW(Xwindow);
XSetInputFocus (SCX_EXTRACT_DISPLAY(Xdisplay), focus,
Symbol_To_Bit (revert_to, Revert_Syms),
s48_extract_integer(revert_to),
SCX_EXTRACT_TIME(time));
return S48_UNSPECIFIC;
}
@ -65,7 +62,7 @@ s48_value scx_Input_Focus (s48_value Xdisplay) {
ret = s48_cons (S48_NULL, S48_NULL);
S48_GC_PROTECT_1 (ret);
S48_SET_CAR(ret, SCX_ENTER_WINDOW(win));
S48_SET_CDR(ret, Bit_To_Symbol((unsigned long)revert_to, Revert_Syms));
S48_SET_CDR(ret, s48_enter_integer(revert_to));
S48_GC_UNPROTECT();
return ret;
@ -99,13 +96,13 @@ s48_value scx_Set_Access_Control(s48_value Xdisplay, s48_value on) {
s48_value scx_Change_Save_Set(s48_value Xdisplay, s48_value win,
s48_value mode) {
XChangeSaveSet(SCX_EXTRACT_DISPLAY(Xdisplay), SCX_EXTRACT_WINDOW(win),
Symbol_To_Bit(mode, Saveset_Syms));
s48_extract_integer(mode));
return S48_UNSPECIFIC;
}
s48_value scx_Set_Close_Down_Mode(s48_value Xdisplay, s48_value mode) {
XSetCloseDownMode(SCX_EXTRACT_DISPLAY(Xdisplay),
Symbol_To_Bit (mode, Closemode_Syms));
s48_extract_integer(mode));
return S48_UNSPECIFIC;
}

28
c/xlib/xlib.h
View File

@ -21,7 +21,7 @@
#define S48_FALSE_P(x) S48_EQ(x, S48_FALSE)
#define S48_TRUE_P(x) S48_EQ(x, S48_TRUE)
extern char* s48_extract_symbol(s48_value);
extern s48_value symbol_now(); // defined in init.c
/* Extraction-Macros for the new types, from their s48_value wrapping.
*/
@ -42,7 +42,7 @@ extern char* s48_extract_symbol(s48_value);
#define SCX_EXTRACT_DRAWABLE(x) (Drawable)s48_extract_integer(x)
#define SCX_ENTER_ATOM(x) s48_enter_integer((long)x)
#define SCX_EXTRACT_ATOM(x) (Atom)s48_extract_integer(x)
#define SCX_ENTER_TIME(x) x == CurrentTime ? s48_enter_symbol("now") : s48_enter_integer(x)
#define SCX_ENTER_TIME(x) x == CurrentTime ? symbol_now() : s48_enter_integer(x)
#define SCX_EXTRACT_TIME(x) S48_SYMBOL_P(x) ? CurrentTime : (int)s48_extract_integer(x)
#define SCX_EXTRACT_CURSOR(x) (Cursor)s48_extract_integer(x)
#define SCX_ENTER_CURSOR(x) s48_enter_integer((long)x)
@ -58,27 +58,3 @@ extern char* s48_extract_symbol(s48_value);
extern unsigned long AList_To_XWindowChanges(s48_value alist,
XWindowChanges* WC);
typedef struct {
Window root;
int x, y, width, height, border_width, depth;
} GEOMETRY;
typedef struct {
char *name;
unsigned long val;
} SYMDESCR;
extern SYMDESCR Func_Syms[], Bit_Grav_Syms[], Event_Syms[], Error_Syms[],
Grav_Syms[], Backing_Store_Syms[], Class_Syms[], Stack_Mode_Syms[],
Line_Style_Syms[], State_Syms[], Cap_Style_Syms[], Join_Style_Syms[],
Map_State_Syms[], Fill_Style_Syms[], Fill_Rule_Syms[], Arc_Mode_Syms[],
Subwin_Mode_Syms[], Button_Syms[], Cross_Mode_Syms[], Cross_Detail_Syms[],
Focus_Detail_Syms[], Place_Syms[], Visibility_Syms[], Prop_Syms[],
Mapping_Syms[], Direction_Syms[], Shape_Syms[], Propmode_Syms[],
Grabstatus_Syms[], Allow_Events_Syms[], Revert_Syms[], Polyshape_Syms[],
Initial_State_Syms[], Bitmapstatus_Syms[], Circulate_Syms[],
Ordering_Syms[], Byte_Order_Syms[], Saveset_Syms[], Closemode_Syms[],
Event_Mask_Syms[], Visual_Class_Syms[], Color_Flags_Syms[], Gcontext_Values_Syms[];

4
scheme/libs/libs-packages.scm
View File

@ -1,8 +1,8 @@
(define-structure xpm xpm-interface
(open scheme
xlib
xlib-types
signals
xlib-internal-types
signals primitives
external-calls
finite-types)
(files xpm))

83
scheme/libs/xpm.scm
View File

@ -5,43 +5,60 @@
xpm-attributes
xpm-attribute-name
xpm-attribute-index
(visual colormap depth color-symbols return-pixels exact-colors
;closeness rgb-closeness
return-alloc-pixels alloc-close-colors
bitmap-format
))
(visual colormap depth size hotspot char-per-pixel color-symbols rgb-filename
infos return-pixels extensions exact-colors closeness rgb-closeness
color-key color-table return-alloc-pixels alloc-close-colors bitmap-format
alloc-color free-colors color-closure))
(define-enumerated-type bitmap-format :bitmap-format
bitmap-format? bitmap-formats bitmap-format-name bitmap-format-index
(xy-bitmap
bitmap-format-1 ;; means xy-pixmap, but is not allowed as a bitmap-format
z-pixmap))
(define (integer->bitmap-format int)
(vector-ref bitmap-formats int))
(define (bitmap-format->integer v)
(bitmap-format-index v))
(define xpm-attribute-alist->integer+vector
(make-enum-alist->integer+vector
xpm-attributes xpm-attribute-index
(lambda (v)
(cond
((eq? v (xpm-attribute visual))
visual-Xvisual)
((eq? v (xpm-attribute colormap))
colormap-Xcolormap)
((eq? v (xpm-attribute depth))
(lambda (x) x))
; ((eq? v (xpm-attribute color-symbols))
; (lambda (color-symbols)
; (list->vector
; (map (lambda (mapping)
; (list->vector
; (list (name->string (car mapping))
; (name->string (cadr mapping))
; (pixel-Xpixel (caddr mapping)))))
; color-symbols))))
((or (eq? v (xpm-attribute return-pixels))
(eq? v (xpm-attribute return-alloc-pixels)))
(lambda (x) x))
((or (eq? v (xpm-attribute exact-colors))
(eq? v (xpm-attribute alloc-close-colors)))
(lambda (x) (if x 1 0)))
((eq? v (xpm-attribute bitmap-format))
bitmap-format->integer) ;; xypixmap not allowed
(else (lambda (x)
(warn "attribute not supported" v)
(unspecific)))))))
(define (name->string obj)
(if (symbol? obj)
(symbol->string obj)
obj))
(define xpm-attribute-alist->vector
(make-enum-alist->vector
xpm-attributes xpm-attribute-index
(lambda (i)
(case i
((0) visual-Xvisual)
((1) colormap-Xcolormap)
((2) (lambda (x) x))
((3) (lambda (color-symbols)
(list->vector
(map (lambda (mapping)
(list->vector
(list (name->string (car mapping))
(name->string (cadr mapping))
(pixel-Xpixel (caddr mapping)))))
color-symbols))))
((4 6) (lambda (x) x))
((5 7) (lambda (x)
(if x 1 0)))
((8) (lambda (bitmap-format)
(case bitmap-format
((z-pixmap) 0)
((xy-bitmap) 1)
(else (error "illegal bitmap format" bitmap-format)))))
))))
(define (make-result display vec)
(vector-set! vec 0 (make-pixmap (vector-ref vec 0)
display #t))
@ -54,7 +71,7 @@
(display-Xdisplay (drawable-display drawable))
(drawable-Xobject drawable)
data
(xpm-attribute-alist->vector xpm-attribute-alist))))
(xpm-attribute-alist->integer+vector xpm-attribute-alist))))
(case r
((0) (error "Not enough memory!"))
((1) (error "Invalid XPM-File data." data))
@ -74,7 +91,7 @@
(display-Xdisplay (drawable-display drawable))
(drawable-Xobject drawable)
filename
(xpm-attribute-alist->vector xpm-attribute-alist))))
(xpm-attribute-alist->integer+vector xpm-attribute-alist))))
(case r
((0) (error "Not enough memory!"))
((1) (error "Invalid XPM-File data." filename))

106
scheme/xlib/client.scm
View File

@ -38,7 +38,7 @@
(if (not (%reconfigure-wm-window (display-Xdisplay (window-display window))
(window-Xwindow window)
screen-number
(window-change-alist->vector
(window-change-alist->integer+vector
window-change-alist)))
(error "cannot reconfigure window"
window)))
@ -91,10 +91,15 @@
;; set-text-property! sets the property specified by atom of the
;; specified window to value - a list of strings or symbols.
(define (s->s s)
(if (symbol? s)
(symbol->string s)
s))
(define (set-text-property! window value atom)
(let ((res (%set-text-property! (display-Xdisplay (window-display window))
(window-Xwindow window)
(list->vector value)
(list->vector (map s->s value))
(atom-Xatom atom))))
(if res
res
@ -165,6 +170,16 @@
;; enumerated type for the XWMHints type. used by set-wm-hints! and
;; get-wm-hints.
(define-enumerated-type initial-state :initial-state
initial-state? initial-states initial-state-name initial-state-index
(withdrawn normal initial-state-2 iconic initial-state-4))
(define (initial-state->integer v)
(initial-state-index v))
(define (integer->initial-state i)
(vector-ref initial-states i))
(define-enumerated-type wm-hint :wm-hint
wm-hint?
wm-hints
@ -182,30 +197,45 @@
((make-wm-hint-alist)
'())))
(define wm-hint-alist->vector
(make-enum-alist->vector
(define wm-hint-alist->integer+vector
(make-enum-alist->integer+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))))))
(lambda (v)
(cond
((or (eq? v (wm-hint input?))
(eq? v (wm-hint urgency)))
(lambda (x) x))
((eq? v (wm-hint initial-state))
initial-state->integer)
((or (eq? v (wm-hint icon-pixmap))
(eq? v (wm-hint icon-mask)))
pixmap-Xpixmap)
((or (eq? v (wm-hint icon-window))
(eq? v (wm-hint window-group)))
window-Xwindow)
((eq? v (wm-hint icon-position))
(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))))))
(define (integer+vector->wm-hint-alist display)
(make-integer+vector->enum-alist
wm-hints wm-hint-index
(lambda (v)
(cond
((or (eq? v (wm-hint input?))
(eq? v (wm-hint urgency)))
(lambda (x) x))
((eq? v (wm-hint initial-state))
integer->initial-state)
((or (eq? v (wm-hint icon-pixmap))
(eq? v (wm-hint icon-mask)))
(lambda (Xpixmap)
(make-pixmap Xpixmap display #f)))
((or (eq? v (wm-hint icon-window))
(eq? v (wm-hint window-group)))
(lambda (Xwindow)
(make-window Xwindow display #f)))
((eq? v (wm-hint icon-position))
(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
@ -216,7 +246,7 @@
(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)))))
((integer+vector->wm-hint-alist (window-display window)) res))))
(import-lambda-definition %wm-hints (Xdisplay Xwindow)
"scx_Wm_Hints")
@ -228,7 +258,7 @@
(define (set-wm-hints! window wm-hint-alist)
(%set-wm-hints! (display-Xdisplay (window-display window))
(window-Xwindow window)
(wm-hint-alist->vector wm-hint-alist)))
(wm-hint-alist->integer+vector wm-hint-alist)))
(import-lambda-definition %set-wm-hints! (Xdisplay Xwindow args)
"scx_Set_Wm_Hints")
@ -308,17 +338,23 @@
((make-size-hint-alist)
'())))
(define size-hint-alist->vector
(make-enum-alist->vector
(define size-hint-alist->integer+vector
(make-enum-alist->integer+vector
size-hints size-hint-index
(lambda (i)
(lambda (x) x))))
(lambda (v)
(cond
((eq? v (size-hint win-gravity))
gravity->integer)
(else (lambda (x) x))))))
(define vector->size-hint-alist
(define integer+vector->size-hint-alist
(make-vector->enum-alist
size-hints
(lambda (i extra)
(lambda (x) x))))
(lambda (v)
(cond
((eq? v (size-hint win-gravity))
integer->gravity)
(else (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
@ -331,7 +367,7 @@
(let* ((v (%wm-normal-hints (display-Xdisplay (window-display window))
(window-Xwindow window))))
(filter (lambda (x) (not (null? (cdr x))))
(vector->size-hint-alist v #f))))
(integer+vector->size-hint-alist v))))
(import-lambda-definition %wm-normal-hints (Xdisplay Xwindow)
"scx_Wm_Normal_Hints")
@ -339,7 +375,7 @@
(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)))
(size-hint-alist->integer+vector size-hint-alist)))
(import-lambda-definition %set-wm-normal-hints! (Xdisplay Xwindow alist)
"scx_Set_Wm_Normal_Hints")

15
scheme/xlib/colormap.scm
View File

@ -114,9 +114,19 @@
(%store-color (display-Xdisplay (colormap-display colormap))
(colormap-Xcolormap colormap)
(pixel-Xpixel pixel) (color-Xcolor color)
(color-flags->integer
(if (null? flags)
'(do-red do-green do-blue)
(car flags))))
(car flags)))))
(define (color-flags->integer flags)
(fold-right (lambda (s res)
(case s
((do-red) (bitwise-ior res 1))
((do-green) (bitwise-ior res 2))
((do-blue) (bitwise-ior res 4))
(else (error "illegal color-flag" s))))
0 flags))
(import-lambda-definition %store-color (Xdisplay Xcolormap Xpixel Xcolor
flags)
@ -133,9 +143,10 @@
(list->vector
(list (pixel-Xpixel (car p-c-f))
(color-Xcolor (cadr p-c-f))
(color-flags->integer
(if (null? (cddr p-c-f))
'(do-red do-green do-blue)
(caddr p-c-f)))))
(caddr p-c-f))))))
cells))))
(%store-colors (display-Xdisplay (colormap-display colormap))
(colormap-Xcolormap colormap)

6
scheme/xlib/display.scm
View File

@ -165,7 +165,7 @@
;; 'msb-first.
(define (display-image-byte-order display)
(%display-image-byte-order (display-Xdisplay display)))
(integer->byte-order (%display-image-byte-order (display-Xdisplay display))))
(import-lambda-definition %display-image-byte-order (Xdisplay)
"scx_Display_Image_Byte_Order")
@ -183,7 +183,7 @@
;; See BitmapBitOrder.
(define (display-bitmap-bit-order display)
(%display-bitmap-bit-order (display-Xdisplay display)))
(integer->bit-order (%display-bitmap-bit-order (display-Xdisplay display))))
(import-lambda-definition %display-bitmap-bit-order (Xdisplay)
"scx_Display_Bitmap_Bit_Order")
@ -305,7 +305,7 @@
(define (display-select-input window event-mask)
(%display-select-input (display-Xdisplay (window-display window))
(window-Xwindow window)
event-mask))
(event-mask->integer event-mask)))
(import-lambda-definition %display-select-input (Xdisplay Xwindow Xevent-mask)
"scx_Display_Select_Input")

32
scheme/xlib/drawable-type.scm
View File

@ -1,15 +1,37 @@
;; abstractions for a "drawable" which is a window or a pixmap.
;; A "drawable" is a window or a pixmap. But sometimes we can't know
;; what it is. So in that case we just remember the display and the
;; Xlib ID.
(define-record-type drawable :drawable
(really-make-drawable Xobject display)
really-drawable?
(Xobject really-drawable-Xobject)
(display really-drawable-display))
(define (drawable? object)
(or (window? object)
(pixmap? object)))
(pixmap? object)
(really-drawable? object)))
(define (drawable-abstraction pixmap-fun window-fun)
(define (make-drawable Xobject display)
;; let's see if we can find out what this object is? window/pixmap
(let ((is-window? (window-list-find Xobject))
(is-pixmap? (pixmap-list-find Xobject)))
(cond
(is-window? (make-window Xobject display #f))
(is-pixmap? (make-pixmap Xobject display #f))
(else (really-make-drawable Xobject display)))))
(define (drawable-abstraction drawable-fun pixmap-fun window-fun)
(lambda (drawable)
(cond
((really-drawable? drawable) (drawable-fun drawable))
((pixmap? drawable) (pixmap-fun drawable))
((window? drawable) (window-fun drawable))
(else (error "expected a drawable object" drawable)))))
(define drawable-display (drawable-abstraction pixmap-display window-display))
(define drawable-Xobject (drawable-abstraction pixmap-Xpixmap window-Xwindow))
(define drawable-display
(drawable-abstraction really-drawable-display pixmap-display window-display))
(define drawable-Xobject
(drawable-abstraction really-drawable-Xobject pixmap-Xpixmap window-Xwindow))

13
scheme/xlib/error.scm
View File

@ -33,12 +33,23 @@
(set! *most-recent-x-error*
(next-x-error *most-recent-x-error*)))
(define-enumerated-type error-code :error-code
error-code? error-codes error-code-name error-code-index
(success bad-request bad-value bad-window bad-pixmap bad-atom
bad-cursor bad-font bad-match bad-drawable bad-access bad-alloc
bad-color bad-gc bad-id-choice bad-name bad-length bad-implementation))
(define (integer->error-code i)
(if (< i (vector-length error-codes))
(vector-ref error-codes i)
;; there can be larger numbers - extension errors
i))
(define internal-x-error-handler
(lambda (infos)
(let ((display (make-display (vector-ref infos 0) #f))
(ser-num (vector-ref infos 1))
(error-code (vector-ref infos 2))
(error-code (integer->error-code (vector-ref infos 2)))
(major-opcode (vector-ref infos 3))
(minor-opcode (vector-ref infos 4))
(res-id (vector-ref infos 5))

859
scheme/xlib/event-types.scm Normal file
View File

@ -0,0 +1,859 @@
;; An enumerated type for event types. They correspond to the
;; constants defined in X.h. So don't change the order!
(define-enumerated-type event-type :event-type
event-type?
event-types
event-type-name
event-type-index
(event-type-0 event-type-1 ;; those are not defined
key-press key-release button-press button-release motion-notify
enter-notify leave-notify focus-in focus-out keymap-notify expose
graphics-expose no-expose visibility-notify create-notify destroy-notify
unmap-notify map-notify map-request reparent-notify configure-notify
configure-request gravity-notify resize-request circulate-notify
circulate-request property-notify selection-clear selection-request
selection-notify colormap-notify client-message mapping-notify))
(define (integer->event-type i)
(vector-ref event-types i))
;; *******************************************************************
(define (any-event-type event)
(let ((f
(cond
((key-event? event) key-event-type)
((button-event? event) button-event-type)
((motion-event? event) motion-event-type)
((crossing-event? event) crossing-event-type)
((focus-change-event? event) focus-change-event-type)
((expose-event? event) expose-event-type)
((graphics-expose-event? event) graphics-expose-event-type)
((no-expose-event? event) no-expose-event-type)
((visibility-event? event) visibility-event-type)
((create-window-event? event) create-window-event-type)
((destroy-window-event? event) destroy-window-event-type)
((unmap-event? event) unmap-event-type)
((map-event? event) map-event-type)
((map-request-event? event) map-request-event-type)
((reparent-event? event) reparent-event-type)
((configure-event? event) configure-event-type)
((gravity-event? event) gravity-event-type)
((resize-request-event? event) resize-request-event-type)
((configure-request-event? event) configure-request-event-type)
((circulate-event? event) circulate-event-type)
((circulate-request-event? event) circulate-request-event-type)
((property-event? event) property-event-type)
((selection-clear-event? event) selection-clear-event-type)
((colormap-event? event) colormap-event-type)
((client-message-event? event) client-message-event-type)
((mapping-event? event) mapping-event-type)
((error-event? event) error-event-type)
((keymap-event? event) keymap-event-type))))
(f event)))
;; *******************************************************************
(define-record-type key-event :key-event
(really-make-key-event type serial send-event? display window root subwindow
time x y x-root y-root state keycode same-screen?)
key-event?
(type key-event-type)
(serial key-event-serial)
(send-event? key-event-send-event?)
(display key-event-display)
(window key-event-window)
(root key-event-root)
(subwindow key-event-subwindow)
(time key-event-time)
(x key-event-x)
(y key-event-y)
(x-root key-event-x-root)
(y-root key-event-y-root)
(state key-event-state)
(keycode key-event-keycode)
(same-screen? key-event-same-screen?))
;(define (key-pressed-event? event)
; (and (key-event? event)
; (eq? (key-event-type event) (event-type key-pressed))))
;(define (key-released-event? event)
; (and (key-event? event)
; (eq? (key-event-type event) (event-type key-released))))
(define (make-key-event type serial send-event? display window root subwindow
time x y x-root y-root state keycode same-screen?)
(let ((display (make-display display #f)))
(really-make-key-event
type serial send-event? display
(make-window window display #f)
(make-window root display #f)
(make-window subwindow display #f)
time x y x-root y-root
(integer->state-set state)
keycode same-screen?)))
;; *******************************************************************
(define-record-type button-event :button-event
(really-make-button-event type serial send-event? display window root
subwindow time x y x-root y-root state button
same-screen?)
button-event?
(type button-event-type)
(serial button-event-serial)
(send-event? button-event-send-event?)
(display button-event-display)
(window button-event-window)
(root button-event-root)
(subwindow button-event-subwindow)
(time button-event-time)
(x button-event-x)
(y button-event-y)
(x-root button-event-x-root)
(y-root button-event-y-root)
(state button-event-state)
(button button-event-button)
(same-screen? button-event-same-screen?))
;(define (button-pressed-event? event)
; (and (button-event? event)
; (eq? (button-event-type event) (event-type button-pressed))))
;(define (button-released-event? event)
; (and (button-event? event)
; (eq? (button-event-type event) (event-type button-released))))
(define (make-button-event type serial send-event? display window root
subwindow time x y x-root y-root state button
same-screen?)
(let ((display (make-display display #f)))
(really-make-button-event
type serial send-event? display
(make-window window display #f)
(make-window root display #f)
(make-window subwindow display #f)
time x y x-root y-root
(integer->state-set state)
(integer->button button)
same-screen?)))
;; *******************************************************************
(define-record-type motion-event :motion-event
(really-make-motion-event type serial send-event? display window root
subwindow time x y x-root y-root state is-hint?
same-screen?)
motion-event?
(type motion-event-type)
(serial motion-event-serial)
(send-event? motion-event-send-event?)
(display motion-event-display)
(window motion-event-window)
(root motion-event-root)
(subwindow motion-event-subwindow)
(time motion-event-time)
(x motion-event-x)
(y motion-event-y)
(x-root motion-event-x-root)
(y-root motion-event-y-root)
(state motion-event-state)
(is-hint? motion-event-is-hint?)
(same-screen? motion-event-same-screen?))
(define (make-motion-event type serial send-event? display window root
subwindow time x y x-root y-root state is-hint?
same-screen?)
(let ((display (make-display display #f)))
(really-make-button-event
type serial send-event? display
(make-window window display #f)
(make-window root display #f)
(make-window subwindow display #f)
time x y x-root y-root
(integer->state-set state)
(integer->is-hint? is-hint?) ;; subset of Notify Mode
same-screen?)))
;; *******************************************************************
(define-record-type crossing-event :crossing-event
(really-make-crossing-event type serial send-event? display window root
subwindow time x y x-root y-root mode detail
same-screen? focus? state)
crossing-event?
(type crossing-event-type)
(serial crossing-event-serial)
(send-event? crossing-event-send-event?)
(display crossing-event-display)
(window crossing-event-window)
(root crossing-event-root)
(subwindow crossing-event-subwindow)
(time crossing-event-time)
(x crossing-event-x)
(y crossing-event-y)
(x-root crossing-event-x-root)
(y-root crossing-event-y-root)
(mode crossing-event-mode)
(detail crossing-event-detail)
(same-screen? crossing-event-same-screen?)
(focus? crossing-event-focus?)
(state crossing-event-state))
;(define (enter-window-event? event)
; (and (crossing-event? event)
; (eq? (crossing-event-type event) (event-type enter-window))))
;(define (leave-window-event? event)
; (and (crossing-event? event)
; (eq? (crossing-event-type event) (event-type leave-window))))
(define (make-crossing-event type serial send-event? display window root
subwindow time x y x-root y-root mode detail
same-screen? focus? state)
(let ((display (make-display display #f)))
(really-make-crossing-event
type serial send-event? display
(make-window window display #f)
(make-window root display #f)
(make-window subwindow display #f)
time x y x-root y-root
(integer->notify-mode mode)
(integer->notify-detail detail)
same-screen? focus?
(integer->state-set state)))) ;; Elk treats state a button ?!
;; *******************************************************************
(define-record-type focus-change-event :focus-change-event
(really-make-focus-change-event type serial send-event? display window mode
detail)
focus-change-event?
(type focus-change-event-type)
(serial focus-change-event-serial)
(send-event? focus-change-event-send-event?)
(display focus-change-event-display)
(window focus-change-event-window)
(mode focus-change-event-mode)
(detail focus-change-event-detail))
;(define (focus-in-event? event)
; (and (focus-change-event? event)
; (eq? (focus-change-event-type event) (event-type focus-in))))
;(define (focus-out-event? event)
; (and (focus-change-event? event)
; (eq? (focus-change-event-type event) (event-type focus-out))))
(define (make-focus-change-event type serial send-event? display window mode
detail)
(let ((display (make-display display #f)))
(really-make-focus-change-event
type serial send-event? display
(make-window window display #f)
(integer->notify-mode mode)
(integer->notify-detail detail))))
;; *******************************************************************
(define-record-type expose-event :expose-event
(really-make-expose-event type serial send-event? display window x y width
height count)
expose-event?
(type expose-event-type)
(serial expose-event-serial)
(send-event? expose-event-send-event?)
(display expose-event-display)
(window expose-event-window)
(x expose-event-x)
(y expose-event-y)
(width expose-event-width)
(height expose-event-height)
(count expose-event-count))
(define (make-expose-event type serial send-event? display window x y
width height count)
(let ((display (make-display display #f)))
(really-make-expose-event
type serial send-event? display
(make-window window display #f)
x y width height count)))
;; *******************************************************************
(define-record-type graphics-expose-event :graphics-expose-event
(really-make-graphics-expose-event type serial send-event? display drawable
x y width height major-code minor-code)
graphics-expose-event?
(type graphics-expose-event-type)
(serial graphics-expose-event-serial)
(send-event? graphics-expose-event-send-event?)
(display graphics-expose-event-display)
(drawable graphics-expose-event-drawable)
(x graphics-expose-event-x)
(y graphics-expose-event-y)
(width graphics-expose-event-width)
(height graphics-expose-event-height)
(major-code graphics-expose-event-major-code)
(minor-code graphics-expose-event-minor-code))
(define (make-graphics-expose-event type serial send-event? display drawable
x y width height count
major-code minor-code)
(let ((display (make-display display #f)))
(really-make-graphics-expose-event
type serial send-event? display
(make-drawable drawable display)
x y width height count major-code minor-code)))
;; *******************************************************************
(define-record-type no-expose-event :no-expose-event
(really-make-no-expose-event type serial send-event? display drawable
major-code minor-code)
no-expose-event?
(type no-expose-event-type)
(serial no-expose-event-serial)
(send-event? no-expose-event-send-event?)
(display no-expose-event-display)
(drawable no-expose-event-drawable)
(major-code no-expose-event-major-code)
(minor-code no-expose-event-minor-code))
(define (make-no-expose-event type serial send-event? display drawable
major-code minor-code)
(let ((display (make-display display #f)))
(really-make-no-expose-event
type serial send-event? display
(make-drawable drawable display)
major-code minor-code)))
;; *******************************************************************
(define-record-type visibility-event :visibility-event
(really-make-visibility-event type serial send-event? display window state)
visibility-event?
(type visibility-event-type)
(serial visibility-event-serial)
(send-event? visibility-event-send-event?)
(display visibility-event-display)
(window visibility-event-window)
(state visibility-event-state))
(define (make-visibility-event type serial send-event? display window state)
(let ((display (make-display display #f)))
(really-make-visibility-event
type serial send-event? display
(make-window window display #f)
(integer->visibility-state state))))
;; *******************************************************************
(define-record-type create-window-event :create-window-event
(really-make-create-window-event type serial send-event? display parent
window x y width height border-width
override-redirect?)
create-window-event?
(type create-window-event-type)
(serial create-window-event-serial)
(send-event? create-window-event-send-event?)
(display create-window-event-display)
(parent create-window-event-parent)
(window create-window-event-window)
(x create-window-event-x)
(y create-window-event-y)
(width create-window-event-width)
(height create-window-event-height)
(border-width create-window-event-border-width)
(override-redirect? create-window-event-override-redirect?))
(define (make-create-window-event type serial send-event? display parent
window x y width height border-width
override-redirect?)
(let ((display (make-display display #f)))
(really-make-create-window-event
type serial send-event? display
(make-window parent display #f)
(make-window window display #f)
x y width height border-width override-redirect?)))
;; *******************************************************************
(define-record-type destroy-window-event :destroy-window-event
(really-make-destroy-window-event type serial send-event? display event
window)
destroy-window-event?
(type destroy-window-event-type)
(serial destroy-window-event-serial)
(send-event? destroy-window-event-send-event?)
(display destroy-window-event-display)
(event destroy-window-event-event)
(window destroy-window-event-window))
(define (make-destroy-window-event type serial send-event? display event
window)
(let ((display (make-display display #f)))
(really-make-destroy-window-event
type serial send-event? display
(make-window event display #f)
(make-window window display #f))))
;; *******************************************************************
(define-record-type unmap-event :unmap-event
(really-make-unmap-event type serial send-event? display event window
from-configure?)
unmap-event?
(type unmap-event-type)
(serial unmap-event-serial)
(send-event? unmap-event-send-event?)
(display unmap-event-display)
(event unmap-event-event)
(window unmap-event-window)
(from-configure? unmap-event-from-configure?))
(define (make-unmap-event type serial send-event? display event window
from-configure?)
(let ((display (make-display display #f)))
(really-make-unmap-event
type serial send-event? display
(make-window event display #f)
(make-window window display #f)
from-configure?)))
;; *******************************************************************
(define-record-type map-event :map-event
(really-make-map-event type serial send-event? display event window
override-redirect?)
map-event?
(type map-event-type)
(serial map-event-serial)
(send-event? map-event-send-event?)
(display map-event-display)
(event map-event-event)
(window map-event-window)
(override-redirect? map-event-override-redirect?))
(define (make-map-event type serial send-event? display event window
from-configure?)
(let ((display (make-display display #f)))
(really-make-map-event
type serial send-event? display
(make-window event display #f)
(make-window window display #f)
from-configure?)))
;; *******************************************************************
(define-record-type map-request-event :map-request-event
(really-make-map-request-event type serial send-event? display parent window)
map-request-event?
(type map-request-event-type)
(serial map-request-event-serial)
(send-event? map-request-event-send-event?)
(display map-request-event-display)
(parent map-request-event-parent)
(window map-request-event-window))
(define (make-map-request-event type serial send-event? display parent window)
(let ((display (make-display display #f)))
(really-make-map-request-event
type serial send-event? display
(make-window parent display #f)
(make-window window display #f))))
;; *******************************************************************
(define-record-type reparent-event :reparent-event
(really-make-reparent-event type serial send-event? display event window
parent x y override-redirect?)
reparent-event?
(type reparent-event-type)
(serial reparent-event-serial)
(send-event? reparent-event-send-event?)
(display reparent-event-display)
(event reparent-event-event)
(window reparent-event-window)
(parent reparent-event-parent)
(x reparent-event-x)
(y reparent-event-y)
(override-redirect? reparent-event-override-redirect?))
(define (make-reparent-event type serial send-event? display event window
parent x y override-redirect?)
(let ((display (make-display display #f)))
(really-make-reparent-event
type serial send-event? display
(make-window event display #f)
(make-window window display #f)
(make-window parent display #f)
x y override-redirect?)))
;; *******************************************************************
(define-record-type configure-event :configure-event
(really-make-configure-event type serial send-event? display event window
x y width height border-width above
override-redirect?)
configure-event?
(type configure-event-type)
(serial configure-event-serial)
(send-event? configure-event-send-event?)
(display configure-event-display)
(event configure-event-event)
(window configure-event-window)
(x configure-event-x)
(y configure-event-y)
(width configure-event-width)
(height configure-event-height)
(border-width configure-event-border-width)
(above configure-event-above)
(override-redirect? configure-event-override-redirect?))
(define (make-configure-event type serial send-event? display event window
x y width height border-width above
override-redirect?)
(let ((display (make-display display #f)))
(really-make-configure-event
type serial send-event? display
(make-window event display #f)
(make-window window display #f)
x y width height border-width
(make-window above display #f)
override-redirect?)))
;; *******************************************************************
(define-record-type gravity-event :gravity-event
(really-make-gravity-event type serial send-event? display event window x y)
gravity-event?
(type gravity-event-type)
(serial gravity-event-serial)
(send-event? gravity-event-send-event?)
(display gravity-event-display)
(event gravity-event-event)
(window gravity-event-window)
(x gravity-event-x)
(y gravity-event-y))
(define (make-gravity-event type serial send-event? display event window x y)
(let ((display (make-display display #f)))
(really-make-gravity-event
type serial send-event? display
(make-window event display #f)
(make-window window display #f)
x y)))
;; *******************************************************************
(define-record-type resize-request-event :resize-request-event
(really-make-resize-request-event type serial send-event? display window
width height)
resize-request-event?
(type resize-request-event-type)
(serial resize-request-event-serial)
(send-event? resize-request-event-send-event?)
(display resize-request-event-display)
(window resize-request-event-window)
(width resize-request-event-width)
(height resize-request-event-height))
(define (make-resize-request-event type serial send-event? display window
width height)
(let ((display (make-display display #f)))
(really-make-resize-request-event
type serial send-event? display
(make-window window display #f)
width height)))
;; *******************************************************************
(define-record-type configure-request-event :configure-request-event
(really-make-configure-request-event type serial send-event? display parent
window window-changes-alist)
configure-request-event?
(type configure-request-event-type)
(serial configure-request-event-serial)
(send-event? configure-request-event-send-event?)
(display configure-request-event-display)
(parent configure-request-event-parent)
(window configure-request-event-window)
(window-changes-alist configure-request-event-window-changes-alist))
(define (make-configure-request-event type serial send-event? display window
x y width height border-width above
detail value-mask)
(let ((display (make-display display #f)))
(really-make-configure-request-event
type serial send-event? display
(make-window window display #f)
((integer+vector->window-change-alist display)
(cons value-mask
(list->vector
(list x y width height border-width above detail)))))))
;; *******************************************************************
(define-record-type circulate-event :circulate-event
(really-make-circulate-event type serial send-event? display event window
place)
circulate-event?
(type circulate-event-type)
(serial circulate-event-serial)
(send-event? circulate-event-send-event?)
(display circulate-event-display)
(event circulate-event-event)
(window circulate-event-window)
(place circulate-event-place))
(define (make-circulate-event type serial send-event? display event window
place)
(let ((display (make-display display #f)))
(really-make-circulate-event
type serial send-event? display
(make-window event display #f)
(make-window window display #f)
(integer->place place))))
;; *******************************************************************
(define-record-type circulate-request-event :circulate-request-event
(really-make-circulate-request-event type serial send-event? display parent
window place)
circulate-request-event?
(type circulate-request-event-type)
(serial circulate-request-event-serial)
(send-event? circulate-request-event-send-event?)
(display circulate-request-event-display)
(parent circulate-request-event-parent)
(window circulate-request-event-window)
(place circulate-request-event-place))
(define (make-circulate-request-event type serial send-event? display parent
window place)
(let ((display (make-display display #f)))
(really-make-circulate-request-event
type serial send-event? display
(make-window parent display #f)
(make-window window display #f)
(integer->place place))))
;; *******************************************************************
(define-record-type property-event :property-event
(really-make-property-event type serial send-event? display window atom time
state)
property-event?
(type property-event-type)
(serial property-event-serial)
(send-event? property-event-send-event?)
(display property-event-display)
(window property-event-window)
(atom property-event-atom)
(time property-event-time)
(state property-event-state))
(define (make-property-event type serial send-event? display window atom
time state)
(let ((display (make-display display #f)))
(really-make-property-event
type serial send-event? display
(make-window window display #f)
(make-atom atom)
time
(integer->property-state state))))
;; *******************************************************************
(define-record-type selection-clear-event :selection-clear-event
(really-make-selection-clear-event type serial send-event? display window
selection time)
selection-clear-event?
(type selection-clear-event-type)
(serial selection-clear-event-serial)
(send-event? selection-clear-event-send-event?)
(display selection-clear-event-display)
(window selection-clear-event-window)
(selection selection-clear-event-selection)
(time selection-clear-event-time))
(define (make-selection-clear-event type serial send-event? display window
selection time)
(let ((display (make-display display #f)))
(really-make-selection-clear-event
type serial send-event? display
(make-window window display #f)
(make-atom selection)
time)))
;; *******************************************************************
(define-record-type selection-request-event :selection-request-event
(really-make-selection-request-event type serial send-event? display owner
requestor atom target property time)
selection-request-event?
(type selection-request-event-type)
(serial selection-request-event-serial)
(send-event? selection-request-event-send-event?)
(display selection-request-event-display)
(owner selection-request-event-owner)
(requestor selection-request-event-requestor)
(atom selection-request-event-atom)
(target selection-request-event-target)
(property selection-request-event-property)
(time selection-request-event-time))
(define (make-selection-request-event type serial send-event? display window
selection time)
(let ((display (make-display display #f)))
(really-make-selection-request-event
type serial send-event? display
(make-window window display #f)
(make-atom selection)
time)))
;; *******************************************************************
(define-record-type selection-event :selection-event
(really-make-selection-event type serial send-event? display requestor
selection target property time)
selection-event?
(type selection-event-type)
(serial selection-event-serial)
(send-event? selection-event-send-event?)
(display selection-event-display)
(requestor selection-event-requestor)
(selection selection-event-selection)
(target selection-event-target)
(property selection-event-property)
(time selection-event-time))
(define (make-selection-event type serial send-event? display requestor
selection target property time)
(let ((display (make-display display #f)))
(really-make-selection-event
type serial send-event? display
(make-window requestor display #f)
(make-atom selection)
(make-atom target)
(make-atom property)
time)))
;; *******************************************************************
(define-record-type colormap-event :colormap-event
(really-make-colormap-event type serial send-event? display window colormap
new? state)
colormap-event?
(type colormap-event-type)
(serial colormap-event-serial)
(send-event? colormap-event-send-event?)
(display colormap-event-display)
(window colormap-event-window)
(colormap colormap-event-colormap)
(new? colormap-event-new?)
(state colormap-event-state))
(define (make-colormap-event type serial send-event? display window colormap
new? state)
(let ((display (make-display display #f)))
(really-make-colormap-event
type serial send-event? display
(make-window window display #f)
(make-colormap colormap display #f)
new?
(integer->colormap-state state))))
;; *******************************************************************
(define-record-type client-message-event :client-message-event
(really-make-client-message-event type serial send-event? display window
message-type format data)
client-message-event?
(type client-message-event-type)
(serial client-message-event-serial)
(send-event? client-message-event-send-event?)
(display client-message-event-display)
(window client-message-event-window)
(message-type client-message-event-message-type)
(format client-message-event-format)
(data client-message-event-data))
(define (make-client-message-event type serial send-event? display window
message-type data)
(let ((display (make-display display #f)))
(really-make-client-message-event
type serial send-event? display
(make-window window display #f)
(make-atom message-type)
format
data)))
;; *******************************************************************
(define-record-type mapping-event :mapping-event
(really-make-mapping-event type serial send-event? display window request
first-keycode count)
mapping-event?
(type mapping-event-type)
(serial mapping-event-serial)
(send-event? mapping-event-send-event?)
(display mapping-event-display)
(window mapping-event-window)
(request mapping-event-request)
(first-keycode mapping-event-first-keycode)
(count mapping-event-count))
(define (make-mapping-event type serial send-event? display window request
first-keycode count)
(let ((display (make-display display #f)))
(really-make-mapping-event
type serial send-event? display
(make-window window display #f)
(integer->mapping-request request)
first-keycode count)))
;; *******************************************************************
(define-record-type error-event :error-event
(really-make-error-event type serial send-event? display serial error-code
request-code minor-code resourceid)
error-event?
(type error-event-type)
(serial error-event-serial)
(send-event? error-event-send-event?)
(display error-event-display)
(serial error-event-serial)
(error-code error-event-error-code)
(request-code error-event-request-code)
(minor-code error-event-minor-code)
(resourceid error-event-resourceid))
(define (make-error-event type display serial error-code request-code
minor-code resourceid)
(let ((display (make-display display #f)))
(really-make-error-event
type display serial
error-code request-code
minor-code resourceid)))
;; *******************************************************************
(define-record-type keymap-event :keymap-event
(really-make-keymap-event type serial send-event? display bit-vector)
keymap-event?
(type keymap-event-type)
(serial keymap-event-serial)
(send-event? keymap-event-send-event?)
(display keymap-event-display)
(bit-vector keymap-event-bit-vector))
(define (make-keymap-event type serial send-event? display window bit-vector)
;; window is not used...
(let ((display (make-display display #f)))
(really-make-keymap-event
type serial send-event? display
bit-vector)))

186
scheme/xlib/event.scm
View File

@ -1,128 +1,77 @@
;; wait-event blocks the current thread until an event is available,
;; and then it returns this new event.
(define (wait-event dpy) ; needs ports, locks
(let ((port (display-message-inport dpy)))
(disable-interrupts!)
(if (not (char-ready? port))
(begin
(obtain-lock (port-lock port))
(add-pending-channel (port->channel port))
(wait-for-channel (port->channel port)) ;; enables interrupts
(release-lock (port-lock port)))
(enable-interrupts!))
(next-event dpy)))
(define (event-ready? display)
(char-ready? (display-message-inport display)))
(define (complete-event event)
(let* ((type (event-type event))
(args (event-args event))
(comp (lambda (idx func)
(vector-set! args idx
(func (vector-ref args idx))))))
;; for all types
(comp 2 (lambda (Xdisplay) ;; Display the event was read from
(make-display Xdisplay #f)))
(comp 3 (lambda (Xwin) ;; event-window it is reported relative to
(make-window Xwin (vector-ref args 2) #f)))
(let* ((display (vector-ref args 2))
(window (vector-ref args 3))
(sidx 4) ;; start index of event-dependand fields
(make-window* (lambda (Xwindow)
(make-window Xwindow display #f))))
;; special entries
(case type
((key-press key-release button-press button-release motion-notify)
;; root window that the event occured on
(comp (+ sidx 0) make-window*)
;; child window
(comp (+ sidx 1) make-window*))
;; time in milliseconds ?? ...
((enter-notify leave-notify)
(comp (+ sidx 0) make-window*) ;; root window
(comp (+ sidx 1) make-window*));; subwindow
;; time??
((create-notify destroy-notify unmap-notify map-notify map-request
gravity-notify circulate-request)
(comp (+ sidx 0) make-window*))
((reparent-notify configure-request)
(comp (+ sidx 0) make-window*)
(comp (+ sidx 1) make-window*))
((property-notify selection-clear)
(comp (+ sidx 0) make-atom)) ;;??
;; time??
((selection-request)
(comp (+ sidx 0) make-window*)
(comp (+ sidx 1) make-atom) ;;??
(comp (+ sidx 2) make-atom)
(comp (+ sidx 3) make-atom))
((selection-notify)
(comp (+ sidx 0) make-atom)
(comp (+ sidx 1) make-atom)
(comp (+ sidx 2) make-atom))
((colormap-notify) ;;??
(comp (+ sidx 0) (lambda (Xcolormap)
(make-colormap Xcolormap #f))))
((client-message)
(comp (+ sidx 0) make-atom)) ;;??
) ;; case end
;; creates an event type
(event-set-args! event (event-args->alist event))
event)))
(define (complete-event type args)
(let ((constructor (event-constructor type)))
(apply constructor (cons type (vector->list args)))))
(define (event-args->alist event)
(let ((type (event-type event)))
(map cons
(append
;; these fields belong to all events
'(serial send-event? display) ; the window is named differently
(case type
((key-press key-release button-press button-release motion-notify)
(append '(window root-window sub-window time x y x-root y-root
state)
(case type
((key-press key-release) '(key-code))
((button-press button-release) '(button))
((motion-notify) '(is-hint?)))
'(same-screen?)))
((enter-notify leave-notify)
'(window root-window sub-window time x y x-root y-root cross-mode
cross-detail same-screen? focus? button-mask))
((focus-in focus-out) '(window cross-mode focus-detail))
((keymap-notify) '(window keymap))
((expose) '(window x y width height count))
((graphics-expose) '(window x y width height count major-code
minor-code))
((no-expose) '(window major-code minor-code))
((visibility-notify) '(window visibility-state))
((create-notify) '(root-window window x y width height border-width
override-redirect?))
((destroy-notify) '(event-window window))
((unmap-notify) '(event-window window from-configure))
((map-notify) '(event-window window override-redirect?))
((map-request) '(parent-window window))
((reparent-notify) '(event-window parent-window window x y
override-redirect?))
((configure-notify) '(event-window window x y width height
border-width above-window
override-redirect?))
((configure-request) '(parent-window window x y width height
border-width above-window
override-redirect?))
((gravity-notify) '(event-window window x y))
((resize-request) '(window width height))
((circulate-notify) '(event-window window place))
((circulate-request) '(parent-window window place))
((property-notify) '(window atom time property-state))
((selection-clear) '(window selection-atom time))
((selection-request) '(owner-window requestor-window selection-atom
target-atom property-atom time))
((selection-notify) '(requestor-window selection-atom target-atom
property-atom time))
((colormap-notify) '(window colormap new? colormap-installed?))
((client-message) '(window message-type message-data))
((mapping-notify) '(window request keycode count))))
(vector->list (event-args event)))))
(define (event-constructor type)
(cond
((or (eq? type (event-type key-press))
(eq? type (event-type key-release))) make-key-event)
((or (eq? type (event-type button-press))
(eq? type (event-type button-release))) make-button-event)
((eq? type (event-type motion-notify)) make-motion-event)
((or (eq? type (event-type enter-notify))
(eq? type (event-type leave-notify))) make-crossing-event)
((or (eq? type (event-type focus-in))
(eq? type (event-type focus-out))) make-focus-change-event)
((eq? type (event-type keymap-notify)) make-keymap-event)
((eq? type (event-type expose)) make-expose-event)
((eq? type (event-type graphics-expose)) make-graphics-expose-event)
((eq? type (event-type no-expose)) make-no-expose-event)
((eq? type (event-type visibility-notify)) make-visibility-event)
((eq? type (event-type create-notify)) make-create-window-event)
((eq? type (event-type destroy-notify)) make-destroy-window-event)
((eq? type (event-type unmap-notify)) make-unmap-event)
((eq? type (event-type map-notify)) make-map-event)
((eq? type (event-type map-request)) make-map-request-event)
((eq? type (event-type reparent-notify)) make-reparent-event)
((eq? type (event-type configure-notify)) make-configure-event)
((eq? type (event-type configure-request)) make-configure-request-event)
((eq? type (event-type gravity-notify)) make-gravity-event)
((eq? type (event-type resize-request)) make-resize-request-event)
((eq? type (event-type circulate-notify)) make-circulate-event)
((eq? type (event-type circulate-request)) make-circulate-request-event)
((eq? type (event-type property-notify)) make-property-event)
((eq? type (event-type selection-clear)) make-selection-clear-event)
((eq? type (event-type selection-request)) make-selection-request-event)
((eq? type (event-type selection-notify)) make-selection-event)
((eq? type (event-type colormap-notify)) make-colormap-event)
((eq? type (event-type client-message)) make-client-message-event)
((eq? type (event-type mapping-notify)) make-mapping-event)
(else (error "message type not supported" type))))
;;event-type-0 event-type-1 ;; those are not defined
(define (next-event display)
(let ((r (%next-event (display-Xdisplay display))))
(complete-event (make-event (car r)
(cdr r)))))
(complete-event (integer->event-type (car r)) (cdr r))))
(import-lambda-definition %next-event (Xdisplay)
"scx_Next_Event")
(define (peek-event display)
(let ((r (%peek-event (display-Xdisplay display))))
(complete-event (make-event (car r)
(cdr r)))))
(complete-event (integer->event-type (car r))
(cdr r))))
(import-lambda-definition %peek-event (Xdisplay)
"scx_Peek_Event")
@ -144,21 +93,6 @@
(import-lambda-definition %get-motion-events (Xdisplay Xwindow from to)
"scx_Get_Motion_Events")
;; wait-event blocks the current thread until an event is available,
;; and then it returns this new event.
(define (wait-event dpy) ; needs ports, locks
(let ((port (display-message-inport dpy)))
(disable-interrupts!)
(if (not (char-ready? port))
(begin
(obtain-lock (port-lock port))
(add-pending-channel (port->channel port))
(wait-for-channel (port->channel port)) ;; enables interrupts
(release-lock (port-lock port)))
(enable-interrupts!))
(next-event dpy)))
;;; Only here until scsh provides us with select
(import-lambda-definition add-pending-channel (channel)
"scx_add_pending_channel")

10
scheme/xlib/font.scm
View File

@ -79,11 +79,19 @@
;; the font. See XFontStruct.
(define (font-info font)
(%font-info (font-Xfontstruct font)))
(let ((v (%font-info (font-Xfontstruct font))))
(vector-set! v 0 (integer->font-direction (vector-ref v 0)))
v))
(import-lambda-definition %font-info (Xfontstruct)
"scx_Font_Info")
(define (integer->font-direction i)
(case i
((0) 'left-to-right)
((1) 'right-to-left)
(else i)))
(define (font-info-getter num)
(lambda (font)
(vector-ref (font-info font)

290
scheme/xlib/gcontext.scm
View File

@ -1,3 +1,106 @@
;; create-gcontext returns a newly create graphic context for the
;; 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 gc-value-alist)
(let ((display (drawable-display drawable))
(Xobject (drawable-Xobject drawable))
(values (gc-value-alist->integer+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 values)
"scx_Create_Gc")
;; *******************************************************************
(define-enumerated-type gc-function :gc-function
gc-function? gc-functions gc-function-name gc-function-index
(clear and and-reverse copy and-inverted no-op xor or nor equiv
invert or-reverse copy-inverted or-inverted nand set))
(define (integer->gc-function int)
(vector-ref gc-functions int))
(define (gc-function->integer v)
(gc-function-index v))
;; *******************************************************************
(define-enumerated-type line-style :line-style
line-style? line-styles line-style-name line-style-index
(solid on-off-dash double-dash))
(define (integer->line-style int)
(vector-ref line-styles int))
(define (line-style->integer v)
(line-style-index v))
;; *******************************************************************
(define-enumerated-type cap-style :cap-style
cap-style? cap-styles cap-style-name cap-style-index
(not-last butt round projecting))
(define (integer->cap-style int)
(vector-ref cap-styles int))
(define (cap-style->integer v)
(cap-style-index v))
;; *******************************************************************
(define-enumerated-type join-style :join-style
join-style? join-styles join-style-name join-style-index
(miter round bevel))
(define (integer->join-style int)
(vector-ref join-styles int))
(define (join-style->integer v)
(join-style-index v))
;; *******************************************************************
(define-enumerated-type fill-style :fill-style
fill-style? fill-styles fill-style-name fill-style-index
(solid tiled strippled opaque-strippled))
(define (integer->fill-style int)
(vector-ref fill-styles int))
(define (fill-style->integer v)
(fill-style-index v))
;; *******************************************************************
(define-enumerated-type subwindow-mode :subwindow-mode
subwindow-mode? subwindow-modes subwindow-mode-name subwindow-mode-index
(clip-by-children include-inferiors))
(define (integer->subwindow-mode int)
(vector-ref subwindow-modes int))
(define (subwindow-mode->integer v)
(subwindow-mode-index v))
;; *******************************************************************
(define-enumerated-type arc-mode :arc-mode
arc-mode? arc-modes arc-mode-name arc-mode-index
(chord pie-slice))
(define (integer->arc-mode int)
(vector-ref arc-modes int))
(define (arc-mode->integer v)
(arc-mode-index v))
;; *******************************************************************
;; an enumerated type corresponding to XGCValues.
(define-enumerated-type gc-value :gc-value
@ -19,33 +122,109 @@
((make-gc-value-alist)
'())))
(define gc-value-alist->vector
(make-enum-alist->vector
(define-enum-set-type gc-value-set :gc-value-set
gc-value-set? make-gc-value-set
gc-value gc-value? gc-values gc-value-index)
(define integer->gc-value-set
(make-integer->enum-set gc-values gc-value-index make-gc-value-set))
(define gc-value-set->integer
(make-enum-set->integer gc-value-index))
(define gc-value-alist->integer+vector
(make-enum-alist->integer+vector
gc-values
gc-value-index
(lambda (attr)
(cond
((eq? attr (gc-value function))
gc-function->integer)
((or (eq? attr (gc-value plane-mask))
(eq? attr (gc-value foreground))
(eq? attr (gc-value background)))
pixel-Xpixel)
((eq? attr (gc-value line-width))
(lambda (x) x))
((eq? attr (gc-value line-style))
line-style->integer)
((eq? attr (gc-value cap-style))
cap-style->integer)
((eq? attr (gc-value join-style))
join-style->integer)
((eq? attr (gc-value fill-style))
fill-style->integer)
((eq? attr (gc-value fill-rule))
fill-rule->integer)
((or (eq? attr (gc-value tile))
(eq? attr (gc-value stipple))
(eq? attr (gc-value clip-mask)))
pixmap-Xpixmap)
((or (eq? attr (gc-value ts-x-origin))
(eq? attr (gc-value ts-y-origin)))
(lambda (x) x))
((eq? attr (gc-value font))
font-Xfont)
((eq? attr (gc-value subwindow-mode))
subwindow-mode->integer)
((eq? attr (gc-value graphics-exposures))
(lambda (x) x))
((or (eq? attr (gc-value clip-x-origin))
(eq? attr (gc-value clip-y-origin)))
(lambda (x) x))
((or (eq? attr (gc-value dash-offset))
(eq? attr (gc-value dash-list)))
(lambda (x) x))
((eq? attr (gc-value arc-mode))
arc-mode->integer)))))
(define (integer+vector->gc-value-alist display)
(make-integer+vector->enum-alist
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). 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 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 values)
"scx_Create_Gc")
(lambda (v)
(cond
((eq? v (gc-value function))
integer->gc-function)
((or (eq? v (gc-value plane-mask))
(eq? v (gc-value foreground))
(eq? v (gc-value background)))
(lambda (Xpixel)
(make-pixel Xpixel #f #f)))
((eq? v (gc-value line-width))
(lambda (x) x))
((eq? v (gc-value line-style))
integer->line-style)
((eq? v (gc-value cap-style))
integer->cap-style)
((eq? v (gc-value join-style))
integer->join-style)
((eq? v (gc-value fill-style))
integer->fill-style)
((eq? v (gc-value fill-rule))
integer->fill-rule)
((or (eq? v (gc-value tile))
(eq? v (gc-value stipple))
(eq? v (gc-value clip-mask)))
(lambda (Xpixmap)
(make-pixmap Xpixmap display #f)))
((or (eq? v (gc-value ts-x-origin))
(eq? v (gc-value ts-y-origin))
(eq? v (gc-value clip-x-origin))
(eq? v (gc-value clip-y-origin)))
(lambda (x) x))
((eq? v (gc-value font))
(lambda (Xfont)
;; -> see Xlib Programming Manual 5.12
(make-font #f Xfont #f display #t)))
((eq? v (gc-value subwindow-mode))
integer->subwindow-mode)
((eq? v (gc-value graphics-exposures))
(lambda (x) x))
((or (eq? v (gc-value dash-offset))
(eq? v (gc-value dash-list)))
(lambda (x) x))
((eq? v (gc-value arc-mode))
integer->arc-mode)))))
;; copy-gcontext returns a newly create duplicate of the given
;; gcontext, and assigns it to the specified drawable. See XCopyGC.
@ -62,14 +241,15 @@
"scx_Copy_Gc")
;; copy-gcontext! copies the specified attributes from gc-from to
;; 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.
;; gc-to. The attributes have to be a enum-set of gc-value. It can be
;; created with the function make-gc-value-set or the macro
;; gc-value-set. if no gc-value-set is specified, then all attributes
;; are ;; copied. See XCopyGC.
(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)))))
-1
(gc-value-set->integer (car maybe-gc-values)))))
(%copy-gcontext! (display-Xdisplay (gcontext-display gc-from))
(gcontext-Xgcontext gc-from)
(gcontext-Xgcontext gc-to)
@ -89,25 +269,11 @@
(let ((vals (%get-gcontext-values Xgcontext Xdisplay)))
(if (not vals)
(error "cannot get gcontext values." gcontext)
(vector->gc-value-alist vals display)))))
((integer+vector->gc-value-alist display) vals)))))
(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)))
((14) (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)))))
@ -157,7 +323,7 @@
(define (change-gcontext gcontext gc-value-alist)
(%change-gcontext (gcontext-Xgcontext gcontext)
(display-Xdisplay (gcontext-display gcontext))
(gc-value-alist->vector gc-value-alist)))
(gc-value-alist->integer+vector gc-value-alist)))
(import-lambda-definition %change-gcontext (Xgcontext Xdisplay args)
"scx_Change_Gc")
@ -225,15 +391,27 @@
;; graphic context to the list of rectangles and sets the clip
;; origin. Each rectangle has to be a list (x y height width). The
;; coordinates of the rectangles are interpreted relative to the clip
;; origin specified by x and y. ordering can be one of 'unsorted,
;; 'y-sorted, 'xy-sorted or 'xy-banded. See XSetClipRectangles.
;; origin specified by x and y. possible values for ordering are
;; defined below. If none is specified (rectangle-ordering unsorted)
;; is used. See XSetClipRectangles.
(define (set-gcontext-clip-rectangles! gcontext x y rectangles ordering)
(%set-gcontext-clip-rectangles! (gcontext-Xgcontext gcontext)
(define-enumerated-type rectangle-ordering :rectangle-ordering
rectangle-ordering? rectangle-orderings
rectangle-ordering-name rectangle-ordering-index
(unsorted y-sorted xy-sorted xy-banded))
(define (rectangle-ordering->integer v)
(rectangle-ordering-index v))
(define (set-gcontext-clip-rectangles! gcontext x y rectangles . ordering)
(%set-gcontext-clip-rectangles!
(gcontext-Xgcontext gcontext)
(display-Xdisplay (gcontext-display gcontext))
x y
(list->vector rectangles)
ordering))
(rectangle-ordering->integer (if (null? ordering)
(rectangle-ordering unsorted)
(car ordering)))))
(import-lambda-definition %set-gcontext-clip-rectangles! (Xgcontext Xdisplay x
y v ord)
@ -246,7 +424,7 @@
;; fastest. For 'stipple, this is the size that can be stippled
;; fastest. See XQueryBestSize.
(define (query-best-size display width height shape)
(define (query-best-size display width height shape) ;; not exported
(%query-best-size (display-Xdisplay display)
width height shape))
@ -254,10 +432,10 @@
"scx_Query_Best_Size")
(define (query-best-cursor display width height)
(query-best-size display width height 'cursor))
(query-best-size display width height 0))
(define (query-best-tile display width height)
(query-best-size display width height 'tile))
(query-best-size display width height 1))
(define (query-best-stipple display width height)
(query-best-size display width height 'stipple))
(query-best-size display width height 2))

48
scheme/xlib/grab.scm
View File

@ -5,15 +5,24 @@
;; (success not-viewable already-grabbed frozen invalide-time)
;; See XGrabPointer.
(define-enumerated-type grab-status :grab-status
grab-status? grab-states grab-status-name grab-status-index
(success already-grabbed invalid-time not-viewable frozen))
(define (integer->grab-status i)
(vector-ref grab-states i))
(define (grab-pointer window owner? events ptr-sync? kbd-sync?
confine-to cursor time)
(integer->grab-status
(%grab-pointer (display-Xdisplay (window-display window))
(window-Xwindow window)
owner? events
owner?
(event-mask->integer events)
ptr-sync? kbd-sync?
(window-Xwindow confine-to)
(cursor-Xcursor cursor)
time))
time)))
(import-lambda-definition %grab-pointer (Xdisplay Xwindow owner? events
ptr-sync? kbd-sync?
@ -37,7 +46,11 @@
confine-to cursor)
(%grab-button (display-Xdisplay (window-display window))
(window-Xwindow window)
button mod owner? events ptr-sync? kbd-sync?
(button->integer button) ;; any-button
(state-set->integer mod)
owner?
(event-mask->integer events)
ptr-sync? kbd-sync?
(window-Xwindow confine-to)
(cursor-Xcursor cursor)))
@ -53,7 +66,8 @@
(define (ungrab-button window button modifiers)
(%ungrab-button (display-Xdisplay (window-display window))
(window-Xwindow window)
button modifiers))
(button->integer button)
(state-set->integer modifiers)))
(import-lambda-definition %ungrab-button (Xdisplay Xwindow
button modifiers)
@ -65,7 +79,9 @@
(define (change-active-pointer-grab display events cursor time)
(%change-active-p-g (display-Xdisplay display)
events cursor time))
(event-mask->integer events)
(cursor-Xcursor cursor)
time))
(import-lambda-definition %change-active-p-g (Xdislay events
cursor time)
@ -79,9 +95,10 @@
;; grab-Key. See XGrabKeyboard and XUngrabKeyboard.
(define (grab-keyboard window owner? ptr-sync? kbd-sync? time)
(integer->grab-status
(%grab-keyboard (display-Xdisplay (window-display window))
(window-Xwindow window)
owner? ptr-sync? kbd-sync? time))
owner? ptr-sync? kbd-sync? time)))
(import-lambda-definition %grab-keyboard (Xdisplay Xwindow
owner? ptr-sync? kbd-sync?
@ -104,7 +121,9 @@
(define (grab-key window key mod owner? ptr-sync? kbd-sync?)
(%grab-key (display-Xdisplay (window-display window))
(window-Xwindow window)
key mod owner? ptr-sync? kbd-sync? (symbol? key)))
key
(state-set->integer mod)
owner? ptr-sync? kbd-sync? (symbol? key)))
(import-lambda-definition %grab-key (Xdisplay xwindow key mod
owner ptr-sync? kbd-sync? flag)
@ -113,7 +132,9 @@
(define (ungrab-key window key mod)
(%ungrab-key (display-Xdisplay (window-display window))
(window-Xwindow window)
key mod (symbol? key)))
key
(state-set->integer mod)
(symbol? key)))
(import-lambda-definition %ungrab-key (Xdisplay Xwindow key mod
flag)
@ -122,9 +143,18 @@
;; allow-events function releases some queued events if the client has
;; caused a device to freeze. See XAllowEvents.
(define-enumerated-type allow-event :allow-event
allow-event? allow-events allow-event-name allow-event-index
(async-pointer sync-pointer replay-pointer async-keyboard
sync-keyboard replay-keyboard async-both sync-both))
(define (allow-event->integer v)
(allow-event-index v))
(define (allow-events display mode time)
(%allow-events (display-Xdisplay display)
mode time))
(allow-event->integer mode)
time))
(import-lambda-definition %allow-events (Xdisplay mode time)
"scx_Allow_Events")

10
scheme/xlib/graphics.scm
View File

@ -228,7 +228,15 @@
(%fill-polygon (display-Xdisplay (drawable-display drawable))
(drawable-Xobject drawable)
(gcontext-Xgcontext gcontext)
(list->vector points) relative? shape))
(list->vector points) relative?
(polygon-shape->integer shape)))
(define-enumerated-type polygon-shape :polygon-shape
polygon-shape? polygon-shapes polygon-shape-name polygon-shape-index
(complex non-convex convex))
(define (polygon-shape->integer v)
(polygon-shape-index v))
(import-lambda-definition %fill-polygon (Xdisplay Xdrawable Xgcontext
vec relative shape)

2
scheme/xlib/helper.scm
View File

@ -39,7 +39,7 @@
;;
(define-exported-binding "string->symbol" string->symbol)
(define-exported-binding "*symbol-now*" 'now)
;; alist-split returns multiple values. the first values are all associations

5
scheme/xlib/key.scm
View File

@ -68,7 +68,8 @@
(define (lookup-string display keycode mask)
(%lookup-string (display-Xdisplay display)
keycode mask))
keycode
(state-set->integer mask)))
(import-lambda-definition %lookup-string (Xdisplay kc m)
"scx_Lookup_String")
@ -95,7 +96,7 @@
(define (refresh-keyboard-mapping window type)
(%refresh-keyboard-mapping (display-Xdisplay (window-display window))
(window-Xwindow window)
type))
(mapping-request->integer type)))
(import-lambda-definition %refresh-keyboard-mapping (Xdisplay Xwindow type)
"scx_Refresh_Keyboard_Mapping")

13
scheme/xlib/pixmap.scm
View File

@ -57,7 +57,14 @@
filename)))
(if (pair? res)
(set-car! res (make-pixmap (car res) (drawable-display drawable) #t))
res)))
(bitmap-error res filename))))
(define (bitmap-error i data)
(case i
((0) #t) ;; no error
((1) (error "could not open file" data))
((2) (error "invalid bitmap data in file" data))
((3) (error "not enough memory to create bitmap" data))))
(import-lambda-definition %read-bitmap-file (Xdisplay Xdrawable file)
"scx_Read_Bitmap_File")
@ -72,8 +79,10 @@
(xy-hot (cond
((null? hotspot) (cons -1 -1))
(else (car hotspot)))))
(bitmap-error
(%write-bitmap-file dpy filename (pixmap-Xpixmap pixmap) width height
(car xy-hot) (cdr xy-hot))))
(car xy-hot) (cdr xy-hot))
filename)))
(import-lambda-definition %write-bitmap-file (Xdisplay file Xpixmap w h x y)
"scx_Write_Bitmap_File")

11
scheme/xlib/property.scm
View File

@ -68,7 +68,16 @@
(window-Xwindow window)
(atom-Xatom property)
(atom-Xatom type)
format mode data))
format
(property-mode->integer mode)
data))
(define (property-mode->integer mode)
(case mode
((replace) 0)
((prepend) 1)
((append) 2)
(else (error "illegal change-property mode" mode))))
(import-lambda-definition %change-property (Xdisplay Xwindow Xatom_prop
Xatom_type format mode data)

2
scheme/xlib/region.scm
View File

@ -146,7 +146,7 @@
(define (polygon-region points fill-rule)
(make-region (%polygon-region (list->vector points)
fill-rule)
(fill-rule->integer fill-rule))
#t))
(import-lambda-definition %polygon-region (points fillrule)

503
scheme/xlib/types.scm Normal file
View File

@ -0,0 +1,503 @@
;; Extensions to enum-sets (some are defined in enum-sets-internal,
;; but that is not exported)
(define (integer->enum-list all-elements element-index int)
(let loop ((res '())
(test (vector->list all-elements)))
(if (null? test)
(reverse res)
(if (> (bitwise-and
(arithmetic-shift int (- (element-index (car test))))
1)
0)
(loop (cons (car test) res)
(cdr test))
(loop res
(cdr test))))))
(define (make-integer->enum-set all-elements element-index constructor)
(lambda (int)
(constructor (integer->enum-list all-elements element-index
int))))
(define (enum-list->integer element-index elements)
(fold-right (lambda (e res)
(bitwise-ior (arithmetic-shift 1 (element-index e))
res))
0
elements))
(define (make-enum-set->integer element-index)
(lambda (set)
(enum-list->integer element-index (enum-set->list set))))
;; alists mapping enum-types to some values
(define (make-enum-alist->integer+vector all-elements element-index-ref
converter)
(lambda (enum-alist)
(cons (enum-list->integer element-index-ref
(map car enum-alist))
(let ((v (make-vector (vector-length all-elements)
(unspecific))))
(for-each (lambda (a)
(vector-set! v
(element-index-ref (car a))
((converter (car a)) (cdr a))))
enum-alist)
v))))
(define (make-integer+vector->enum-alist all-elements element-index-ref
converter)
(lambda (int-vec)
(let ((int (car int-vec))
(vec (cdr int-vec)))
(let* ((enums (integer->enum-list all-elements element-index-ref
int))
(values (map (lambda (e)
((converter e)
(vector-ref vec
(element-index-ref e))))
enums)))
(map cons enums values)))))
;; *******************************************************************
(define-enumerated-type state :state
state? states state-name state-index
(shift lock control mod1 mod2 mod3 mod4 mod5
button1 button2 button3 button4 button5
state-13 state-14
any-modifier))
(define-enum-set-type state-set :state-set
state-set? make-state-set
state state? states state-index)
(define integer->state-set
(make-integer->enum-set states state-index make-state-set))
(define state-set->integer
(make-enum-set->integer state-index))
;; *******************************************************************
(define-enumerated-type button :button
button? buttons button-name button-index
(button1 button2 button3 button4 button5))
(define (integer->button int)
(vector-ref buttons int))
(define (button->integer b)
(button-index b))
;; *******************************************************************
;; this is a special NotifyMode for MotionNotify events.
;; NotifyNormal = 0, NotifyHint = 1
;; therefore we just represent it as the boolean is-hint?
(define (integer->is-hint? int)
(= int 1))
(define (is-hint?->integer is-hint?)
(if is-hint? 1 0))
;; *******************************************************************
(define-enumerated-type notify-mode :notify-mode
notify-mode? notify-modes notify-mode-name notify-mode-index
(normal grab ungrab while-grabbed))
(define (integer->notify-mode int)
(vector-ref notify-modes int))
(define (notify-mode->integer v)
(notify-mode-index v))
;; *******************************************************************
(define-enumerated-type notify-detail :notify-detail
notify-detail? notify-details notify-detail-name notify-detail-index
(ancestor virtual inferior nonlinear nonlinear-virtual pointer
pointer-root detail-none))
(define (integer->notify-detail int)
(vector-ref notify-details int))
(define (notify-detail->integer v)
(notify-detail-index v))
;; *******************************************************************
(define-enumerated-type visibility-state :visibility-state
visibility-state? visibility-states visibility-state-name
visibility-state-index
(unobscured partially-obscured fully-obscured))
(define (integer->visibility-state int)
(vector-ref visibility-states int))
(define (visibility-state->integer v)
(visibility-state-index v))
;; *******************************************************************
(define-enumerated-type place :place
place? places place-name place-index
(on-top on-bottom))
(define (integer->place int)
(vector-ref places int))
(define (place->integer v)
(place-index v))
;; *******************************************************************
(define-enumerated-type property-state :property-state
property-state? property-states property-state-name property-state-index
(new-value delete))
(define (integer->property-state int)
(vector-ref property-states int))
(define (property-state->integer v)
(property-state-index v))
;; *******************************************************************
(define-enumerated-type colormap-state :colormap-state
colormap-state? colormap-states colormap-state-name colormap-state-index
(uninstalled installed))
(define (integer->colormap-state int)
(vector-ref colormap-states int))
(define (colormap-state->integer v)
(colormap-state-index v))
;; *******************************************************************
(define-enumerated-type mapping-request :mapping-request
mapping-request? mapping-requests mapping-request-name mapping-request-index
(modifier keyboard pointer))
(define (integer->mapping-request int)
(vector-ref mapping-requests int))
(define (mapping-request->integer v)
(mapping-request-index v))
;; *******************************************************************
(define-enumerated-type bit-gravity :bit-gravity
bit-gravity? bit-gravities bit-gravity-name bit-gravity-index
(forget north-west north north-east west center east south-west
south south-east static))
(define (integer->bit-gravity int)
(vector-ref bit-gravities int))
(define (bit-gravity->integer v)
(bit-gravity-index v))
;; *******************************************************************
(define-enumerated-type gravity :gravity
gravity? gravities gravity-name gravity-index
(unmap north-west north north-east west center east south-west
south south-east static))
(define (integer->gravity int)
(vector-ref gravities int))
(define (gravity->integer v)
(gravity-index v))
;; *******************************************************************
(define-enumerated-type backing-store :backing-store
backing-store? backing-stores backing-store-name backing-store-index
(not-useful when-mapped always))
(define (integer->backing-store int)
(vector-ref backing-stores int))
(define (backing-store->integer v)
(backing-store-index v))
;; *******************************************************************
(define-enumerated-type event-mask-item :event-mask-item
event-mask-item? event-mask-items event-mask-item-name event-mask-item-index
(key-press key-release button-press button-release enter-window leave-window
pointer-motion pointer-motion-hint button-1-motion button-2-motion
button-3-motion button-4-motion button-5-motion button-motion keymap-state
exposure visibility-change structure-notify resize-redirect
substructure-notify substructure-redirect focus-change property-change
colormap-change owner-grab-button))
(define (integer->event-mask-item int)
(vector-ref event-mask-items int))
(define (event-mask-item->integer v)
(event-mask-item-index v))
(define-enum-set-type event-mask :event-mask
event-mask? make-event-mask
event-mask-item event-mask-item? event-mask-items event-mask-item-index)
(define integer->event-mask
(make-integer->enum-set event-mask-items event-mask-item-index
make-event-mask))
(define event-mask->integer
(make-enum-set->integer event-mask-item-index))
(define event-mask-all-events
(make-event-mask (vector->list event-mask-items)))
;; *******************************************************************
;; 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-syntax make-set-window-attribute-alist
(syntax-rules
()
((make-set-window-attribute-alist (attr arg) rest ...)
(cons (cons (set-window-attribute attr) arg)
(make-set-window-attribute-alist rest ...)))
((make-set-window-attribute-alist)
'())))
(define set-window-attribute-alist->integer+vector
(make-enum-alist->integer+vector
set-window-attributes
set-window-attribute-index
(lambda (attr)
(cond
((eq? attr (set-window-attribute background-pixmap))
(lambda (background)
(cond
((pixmap? background) (pixmap-Xpixmap background))
((eq? background 'parent-relative) 1)
((eq? background 'none) 0)
(else (error "invalid background-pixmap" background)))))
((eq? attr (set-window-attribute border-pixmap))
(lambda (border)
(cond
((pixmap? border) (pixmap-Xpixmap border))
((eq? border 'copy-from-parent) 0)
(else (error "invalid border-pixmap" border)))))
((or (eq? attr (set-window-attribute background-pixel))
(eq? attr (set-window-attribute border-pixel))
(eq? attr (set-window-attribute backing-pixel))
(eq? attr (set-window-attribute backing-planes)))
pixel-Xpixel)
((eq? attr (set-window-attribute bit-gravity))
bit-gravity->integer)
((eq? attr (set-window-attribute gravity))
gravity->integer)
((eq? attr (set-window-attribute backing-store))
backing-store->integer)
((or (eq? attr (set-window-attribute override-redirect))
(eq? attr (set-window-attribute save-under)))
(lambda (v)
(if v 1 0)))
((or (eq? attr (set-window-attribute event-mask))
(eq? attr (set-window-attribute do-not-propagate-mask)))
event-mask->integer)
((eq? attr (set-window-attribute colormap))
colormap-Xcolormap)
((eq? attr (set-window-attribute cursor))
cursor-Xcursor)
(else (error "invalid set-window-attribute" attr))))))
;; *******************************************************************
(define-enumerated-type map-state :map-state
map-state? map-states map-state-name map-state-index
(is-unmapped is-unviewable is-viewable))
(define (integer->map-state int)
(vector-ref map-states int))
(define (map-state->integer v)
(map-state-index v))
;; *******************************************************************
(define-enumerated-type window-class :window-class
window-class? window-classs window-class-name window-class-index
(input-output input-only))
(define (integer->window-class int)
(vector-ref window-classs int))
(define (window-class->integer v)
(window-class-index v))
;; *******************************************************************
(define-enumerated-type window-attribute :window-attribute
window-attribute?
window-attributes
window-attribute-name
window-attribute-index
;; 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-syntax make-window-attribute-alist
(syntax-rules
()
((make-window-attribute-alist (attr arg) rest ...)
(cons (cons (window-attribute attr) arg)
(make-window-attribute-alist rest ...)))
((make-window-attribute-alist)
'())))
(define (integer+vector->window-attribute-alist display)
(make-integer+vector->enum-alist
window-attributes window-attribute-index
(lambda (v)
(cond
((eq? v (window-attribute visual))
make-visual)
((eq? v (window-attribute root))
(lambda (Xwindow)
(make-window Xwindow display #f)))
((eq? v (window-attribute class))
integer->window-class)
((eq? v (window-attribute bit-gravity))
integer->bit-gravity)
((eq? v (window-attribute gravity))
integer->gravity)
((eq? v (window-attribute backing-store))
integer->backing-store)
((or (eq? v (window-attribute backing-planes))
(eq? v (window-attribute backing-pixel)))
(lambda (Xpixel)
(make-pixel Xpixel #f #f)))
((or (eq? v (window-attribute save-under))
(eq? v (window-attribute map-installed))
(eq? v (window-attribute override-redirect)))
(lambda (x) (not (= x 0))))
((eq? v (window-attribute colormap))
(lambda (Xcolormap)
(make-colormap Xcolormap display #f)))
((eq? v (window-attribute map-state))
integer->map-state)
((or (eq? v (window-attribute all-event-masks))
(eq? v (window-attribute your-event-mask))
(eq? v (window-attribute do-not-propagate-mask)))
integer->event-mask)
((eq? v (window-attribute screen))
(lambda (x) x))
(else (lambda (x) x))))))
;; *******************************************************************
(define-enumerated-type stack-mode :stack-mode
stack-mode? stack-modes stack-mode-name stack-mode-index
(above below top-if buttom-if opposite))
(define (integer->stack-mode int)
(vector-ref stack-modes int))
(define (stack-mode->integer v)
(stack-mode-index v))
;; an enumerated type for XWindowChange. Used in configure-window
(define-enumerated-type window-change :window-change
window-change? window-changes window-change-name window-change-index
(x y width height border-width sibling stack-mode))
(define-syntax make-window-change-alist
(syntax-rules
()
((make-window-change-alist (attr arg) rest ...)
(cons (cons (window-change attr) arg)
(make-window-change-alist rest ...)))
((make-window-change-alist)
'())))
(define window-change-alist->integer+vector
(make-enum-alist->integer+vector
window-changes window-change-index
(lambda (v)
(cond
((eq? v (window-change sibling))
window-Xwindow)
((eq? v (window-change stack-mode))
stack-mode->integer)
(else (lambda (x) x))))))
(define (integer+vector->window-change-alist display)
(make-integer+vector->enum-alist
window-changes window-change-index
(lambda (v)
(cond
((eq? v (window-change sibling))
(lambda (Xwindow)
(make-window Xwindow display #f)))
((eq? v (window-change stack-mode))
integer->stack-mode)
(else (lambda (x) x))))))
;; *******************************************************************
(define-enumerated-type byte-order :byte-order
byte-order? byte-orders byte-order-name byte-order-index
(lsb-first msb-first))
(define (integer->byte-order int)
(vector-ref byte-orders int))
(define (byte-order->integer v)
(byte-order-index v))
;; *******************************************************************
(define-enumerated-type bit-order :bit-order
bit-order? bit-orders bit-order-name bit-order-index
(lsb-first msb-first))
(define (integer->bit-order int)
(vector-ref bit-orders int))
(define (bit-order->integer v)
(bit-order-index v))
;; *******************************************************************
(define-enumerated-type fill-rule :fill-rule
fill-rule? fill-rules fill-rule-name fill-rule-index
(even-odd winding))
(define (integer->fill-rule int)
(vector-ref fill-rules int))
(define (fill-rule->integer v)
(fill-rule-index v))

2
scheme/xlib/utility.scm
View File

@ -49,7 +49,7 @@
;; string. See XParseGeometry.
(define (parse-geometry string)
(reverse (%parse-geometry string)))
(vector->list (%parse-geometry string)))
(import-lambda-definition %parse-geometry (string)
"scx_Parse_Geometry")

89
scheme/xlib/visual.scm
View File

@ -2,8 +2,7 @@
;; 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
;; class the visual-class (see below)
;; 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.
@ -32,26 +31,13 @@
((make-visual-info-alist)
'())))
(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
(visual-info-alist->integer+vector
visual-info-alist))))
(map (lambda (p)
(cons (make-visual (car p))
(integer+vector->visual-info-alist (cdr p))))
(vector->list res))))
(import-lambda-definition %get-visual-info (Xdisplay v)
@ -65,17 +51,72 @@
(import-lambda-definition %visual-id (Xvisual)
"scx_Visual_ID")
;; match-visual-info returns info on a matching visual or #f if none
;; exists.
;; match-visual-info returns a pair of a visual that matches the given
;; criteria and a visual-info-alist of it.#f is returned if no such
;; visual exists.
(define (match-visual-info display screen-number depth class)
(let ((res (%match-visual-info (display-Xdisplay display)
screen-number
depth
class)))
(visual-class->integer class))))
(if res
(visual-info-alist->vector res)
(cons (make-visual (car res))
(visual-info-alist->integer+vector (cdr res)))
res)))
(import-lambda-definition %match-visual-info (Xdisplay scrnum depth class)
"scx_Match_Visual_Info")
;; *******************************************************************
(define-enumerated-type visual-class :visual-class
visual-class? visual-classs visual-class-name visual-class-index
(static-gray gray-scale static-color pseudo-color true-color direct-color))
(define (integer->visual-class int)
(vector-ref visual-classs int))
(define (visual-class->integer v)
(visual-class-index v))
;; 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.
(define-enumerated-type visual-info :visual-info
visual-info? visual-infos visual-info-name visual-info-index
(visual-id screen depth class red-mask green-mask blue-mask
colormap-size bits-per-rgp))
(define visual-info-alist->integer+vector
(make-enum-alist->integer+vector
visual-infos visual-info-index
(lambda (v)
(cond
((eq? v (visual-info class))
visual-class->integer)
(else (lambda (x) x))))))
(define integer+vector->visual-info-alist
(make-integer+vector->enum-alist
visual-infos visual-info-index
(lambda (v)
(cond
((eq? v (visual-info class))
integer->visual-class)
(else (lambda (x) x))))))

223
scheme/xlib/window.scm
View File

@ -9,7 +9,7 @@
(define (create-window parent x y width height border-width depth class
visual set-window-attribute-alist)
(let ((attribs (set-window-attribute-alist->vector
(let ((attribs (set-window-attribute-alist->integer+vector
set-window-attribute-alist))
(depth (cond
((eq? depth 'copy-from-parent) #f)
@ -51,93 +51,13 @@
;; *** 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-syntax make-set-window-attribute-alist
(syntax-rules
()
((make-set-window-attribute-alist (attr arg) rest ...)
(cons (cons (set-window-attribute attr) arg)
(make-set-window-attribute-alist rest ...)))
((make-set-window-attribute-alist)
'())))
(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->integer+vector
set-window-attribute-alist)))
(import-lambda-definition %change-window-attributes (Xwindow Xdisplay attribs)
@ -182,41 +102,12 @@
(make-win-attr-setter (set-window-attribute cursor)))
;; *** configure-window **********************************************
;; an enumerated type for configure-window (see XConfigureWindow)
(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))
(define-syntax make-window-change-alist
(syntax-rules
()
((make-window-change-alist (attr arg) rest ...)
(cons (cons (window-change attr) arg)
(make-window-change-alist rest ...)))
((make-window-change-alist)
'())))
(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))))))
;; This sets the window-attributes listed above
;; This set the window-attributes.
(define (configure-window window window-change-alist)
(%configure-window (window-Xwindow window)
(display-Xdisplay (window-display window))
(window-change-alist->vector
(window-change-alist->integer+vector
window-change-alist)))
(import-lambda-definition %configure-window (Xwindow Xdisplay changes)
@ -241,48 +132,14 @@
;; *** 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-syntax make-window-attribute-alist
(syntax-rules
()
((make-window-attribute-alist (attr arg) rest ...)
(cons (cons (window-attribute attr) arg)
(make-window-attribute-alist rest ...)))
((make-window-attribute-alist)
'())))
(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))))))
((integer+vector->window-attribute-alist (window-display window))
values)))))
(import-lambda-definition %get-window-attributes (Xdisplay Xwindow)
"scx_Get_Window_Attributes")
@ -300,7 +157,7 @@
(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-window-class (make-win-attr-getter (window-attribute class)))
(define window-bit-gravity
(make-win-attr-getter (window-attribute bit-gravity)))
(define window-gravity
@ -325,8 +182,8 @@
(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.
;; The map-window function maps the window and all of its subwindows
;; that have had map requests. See XMapWindow.
(define (map-window window)
(%map-window (window-Xwindow window)
@ -335,8 +192,8 @@
(import-lambda-definition %map-window (Xwindow Xdisplay)
"scx_Map_Window")
;; The unmap-window function unmaps the specified window and causes the
;; X server to generate an unmap-notify event. See XUnmapWindow.
;; The unmap-window function unmaps the specified window and causes
;; the X server to generate an unmap-notify event. See XUnmapWindow.
(define (unmap-window window)
(%unmap-window (window-Xwindow window)
@ -345,8 +202,9 @@
(import-lambda-definition %unmap-window (Xwindow Xdisplay)
"scx_Unmap_Window")
;; The destroy-subwindows function destroys all inferior windows of the
;; specified window, in bottom-to-top stacking order. See XDestroySubWindows.
;; The destroy-subwindows function destroys all inferior windows of
;; the specified window, in bottom-to-top stacking order. See
;; XDestroySubWindows.
(define (destroy-subwindows window)
(%destroy-subwindows (window-Xwindow window)
@ -355,8 +213,8 @@
(import-lambda-definition %destroy-subwindows (Xwindow Xdisplay)
"scx_Destroy_Subwindows")
;; The map-subwindows function maps all subwindows for a specified window in
;; top-to-bottom stacking order. See XMapSubwindows
;; The map-subwindows function maps all subwindows for a specified
;; window in top-to-bottom stacking order. See XMapSubwindows
(define (map-subwindows window)
(%map-subwindows (window-Xwindow window)
@ -365,8 +223,9 @@
(import-lambda-definition %map-subwindows (Xwindow Xdisplay)
"scx_Map_Subwindows")
;; The unmap-subwindows function unmaps all subwindows for each subwindow
;; and expose events on formerly obscured windows. See XUnmapSubwindow.
;; The unmap-subwindows function unmaps all subwindows for each
;; subwindow and expose events on formerly obscured windows. See
;; XUnmapSubwindow.
(define (unmap-subwindows window)
(%unmap-subwindows (window-Xwindow window)
@ -386,15 +245,16 @@
(import-lambda-definition %circulate-subwindows (Xwindow Xdisplay dir)
"scx_Circulate_Subwindows")
;; The clear-window function clears the entire area in the specified window.
;; See XClearWindow.
;; The clear-window function clears the entire area in the specified
;; window. See XClearWindow.
(define (clear-window window)
(clear-area window 0 0 0 0 #f))
;; The raise-window (lower-window) function raises (lowers) the specified window
;; to the top (button) of the stack so that no sibling window obscures it (it
;; does not obscure any sibling windows). See XRaiseWindow.
;; The raise-window (lower-window) function raises (lowers) the
;; specified window to the top (button) of the stack so that no
;; sibling window obscures it (it does not obscure any sibling
;; windows). See XRaiseWindow.
(define (raise-window window)
(set-window-stack-mode! window 'above))
@ -402,10 +262,11 @@
(define (lower-window window)
(set-window-stack-mode! window 'below))
;; The restack-windows function restacks the windows in the order specified,
;; from top to bottom. The stacking order of the first window in the windows
;; list is unaffected, but the other windows in the array are stacked underneath
;; the first window, in the order of the list. See XRestackWindows.
;; The restack-windows function restacks the windows in the order
;; specified, from top to bottom. The stacking order of the first
;; window in the windows list is unaffected, but the other windows in
;; the array are stacked underneath the first window, in the order of
;; the list. See XRestackWindows.
(define (restack-windows window-list)
(let loop ((w (car window-list))
@ -416,8 +277,8 @@
(set-window-stack-mode! n 'below)
(loop n (cdr t))))))
;; query-tree returns a list of three elements: root window, parent window and
;; child windows of the given window. See XQueryTree.
;; query-tree returns a list of three elements: root window, parent
;; window and child windows of the given window. See XQueryTree.
(define (query-tree window)
(let* ((display (window-display window))
@ -433,11 +294,11 @@
(import-lambda-definition %query-tree (Xwindow Xdisplay)
"scx_Query_Tree")
;; translate-coordinates takes the x and y coordinates relative to the source
;; window's origin and returns a list of three elements: the x and y coordinates
;; relative to the destination window's origin. If the source window and the
;; destination window are on different screens the result is #f. See
;; XTranslateCoordinates.
;; translate-coordinates takes the x and y coordinates relative to the
;; source window's origin and returns a list of three elements: the x
;; and y coordinates relative to the destination window's origin. If
;; the source window and the destination window are on different
;; screens the result is #f. See XTranslateCoordinates.
(define (translate-coordinates src-window x y dst-window)
(let* ((display (window-display src-window))
@ -457,10 +318,11 @@
"scx_Translate_Coordinates")
;; query-pointer returns a list of eight elements: x and y coordinates, a
;; boolean indicating whether the pointer is on the same screen as the specified
;; window, the root window, the root window's x and y coordinates, the child
;; window and a list of modifier names (see grab-button). See XQueryPointer.
;; query-pointer returns a list of eight elements: x and y
;; coordinates, a boolean indicating whether the pointer is on the
;; same screen as the specified window, the root window, the root
;; window's x and y coordinates, the child window and a list of
;; modifier names (see grab-button). See XQueryPointer.
(define (query-pointer window)
(let* ((display (window-display window))
@ -468,6 +330,7 @@
(window-Xwindow window))))
(vector-set! res 3 (make-window (vector-ref res 3) display #f))
(vector-set! res 6 (make-window (vector-ref res 6) display #f))
(vector-set! res 7 (integer->state-set (vector-ref res 7)))
(vector->list res)))
(import-lambda-definition %query-pointer (Xdisplay Xwindow)

43
scheme/xlib/wm.scm
View File

@ -53,24 +53,33 @@
(define (set-input-focus display window revert-to time)
(%set-input-focus (display-Xdisplay display)
(begin
(if (not (or (window? window)
(eq? window 'pointer-root)))
(error "expected argument of type window; given"
window))
window)
(case window
((none) 0)
((pointer-root) 1)
(else (window-Xwindow window)))
(revert-to->integer revert-to)
time))
(import-lambda-definition %set-input-focus (Xdisplay Xwindow)
(import-lambda-definition %set-input-focus (Xdisplay Xwindow revert-to time)
"scx_Set_Input_Focus")
(define-enumerated-type revert-to :revert-to
revert-to? revert-tos revert-to-name revert-to-index
(none pointer-root parent))
(define (integer->revert-to i)
(vector-ref revert-tos i))
(define (revert-to->integer v)
(revert-to-index v))
;; input-focus returns the current focus window and the current focus
;; state as a pair. See XGetInputFocus.
(define (input-focus display)
(let ((ret (%input-focus (display-Xdisplay display))))
(cons (make-window (car ret) display #f)
(cdr ret))))
(integer->revert-to (cdr ret)))))
(import-lambda-definition %input-focus (Xdisplay)
"scx_Input_Focus")
@ -140,7 +149,14 @@
(define (change-save-set window mode)
(%change-save-set (display-Xdisplay (window-display window))
(window-Xwindow window)
mode))
(save-set-mode->integer mode)))
(define-enumerated-type save-set :save-set
save-set? save-sets save-set-name save-set-index
(insert delete))
(define (save-set-mode->integer v)
(save-set-index v))
(import-lambda-definition %change-save-set (Xdisplay Xwindow mode)
"scx_Change_Save_Set")
@ -151,7 +167,14 @@
(define (set-close-down-mode display mode)
(%set-close-down-mode (display-Xdisplay display)
mode))
(close-down-mode->integer mode)))
(define-enumerated-type close-down-mode :close-down-mode
close-down-mode? close-down-modes close-down-mode-name close-down-mode-index
(destroy-all retain-permanent retain-temporary))
(define (close-down-mode->integer v)
(close-down-mode-index v))
(import-lambda-definition %set-close-down-mode (Xdisplay mode)
"scx_Set_Close_Down_Mode")

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

@ -1,12 +1,5 @@
(define-interface xlib-display-interface
(export display?
open-display
close-display
display-after-function
after-function ;; compatibility with Elk, same as above
display-set-after-function!
set-after-function! ;; compatibility with Elk, same as above
(export open-display
display-default-root-window
display-root-window ;; same as above
display-default-colormap
@ -33,11 +26,8 @@
display-flush-output
display-wait-output
display-no-op
no-op ;; compatibility with Elk, same as above
display-list-depths
list-depths ;; compatibility with Elk, same as above
display-list-pixmap-formats
list-pixmap-formats ;; compatibility with Elk, same as above
synchronize
display-select-input
@ -45,25 +35,13 @@
))
(define-interface xlib-window-interface
(export window?
drawable?
window-display
create-window
(export create-window
create-simple-window
destroy-window
change-window-attributes
get-window-attributes
map-window
unmap-window
((set-window-attribute
window-attribute
window-change
make-set-window-attribute-alist
make-window-attribute-alist
make-window-change-alist) :syntax)
window-change-alist->vector ; has to be exported for client.scm
set-window-background-pixmap!
set-window-background-pixel!
set-window-border-pixmap!
@ -96,7 +74,7 @@
window-depth
window-visual
window-root
window-class
window-window-class
window-bit-gravity
window-backing-store
window-backing-planes
@ -122,8 +100,7 @@
query-tree
translate-coordinates
query-pointer
))
query-pointer))
(define-interface xlib-drawable-interface
(export drawable?
@ -137,17 +114,13 @@
(define-interface xlib-color-interface
(export make-color
color?
color-rgb-values
query-color
query-colors
lookup-color))
(define-interface xlib-colormap-interface
(export make-colormap
colormap?
free-colormap
colormap-display
(export create-colormap
alloc-color!
query/alloc-named-color
alloc-named-color
@ -155,33 +128,28 @@
alloc-color-cells
store-color
store-colors
create-colormap
copy-colormap-and-free
))
copy-colormap-and-free))
(define-interface xlib-pixel-interface
(export pixel?
pixel-value
(export pixel-value
black-pixel
white-pixel
))
white-pixel))
(define-interface xlib-gcontext-interface
(export gcontext?
gcontext-display
create-gcontext
(export create-gcontext
copy-gcontext
copy-gcontext!
free-gcontext
((gc-value make-gc-value-alist) :syntax)
((gc-value gc-value-set make-gc-value-alist) :syntax)
make-gc-value-set
query-best-size
query-best-cursor
query-best-tile
query-best-stipple
get-gcontext-values
((gc-function line-style cap-style join-style fill-style
subwindow-mode arc-mode rectangle-ordering) :syntax)
gcontext-function
gcontext-plane-mask
gcontext-foreground
@ -231,8 +199,7 @@
set-gcontext-dash-offset!
set-gcontext-clip-rectangles!
set-gcontext-dashlist!
))
set-gcontext-dashlist!))
(define-interface xlib-graphics-interface
(export clear-area
@ -251,18 +218,14 @@
fill-arc
draw-arcs
fill-arcs
((polygon-shape) :syntax)
fill-polygon
rectangle
bounds
points->segments))
(define-interface xlib-font-interface
(export font?
font-display
open-font
close-font
font-name
list-font-names
(export list-font-names
list-fonts
font-info
@ -303,24 +266,325 @@
set-font-path!))
(define-interface xlib-pixmap-interface
(export pixmap?
free-pixmap
pixmap-display
create-pixmap
(export create-pixmap
create-bitmap-from-data
create-pixmap-from-bitmap-data
read-bitmap-file
write-bitmap-file))
(define-interface xlib-event-interface
(export event-type
event-args
event?
event-ready?
(export event-ready?
events-pending
next-event
peek-event
wait-event))
wait-event
((event-type) :syntax)
any-event-type
key-event?
key-event-type
key-event-serial
key-event-send-event?
key-event-display
key-event-window
key-event-root
key-event-subwindow
key-event-time
key-event-x
key-event-y
key-event-x-root
key-event-y-root
key-event-state
key-event-keycode
key-event-same-screen?
button-event?
button-event-type
button-event-serial
button-event-send-event?
button-event-display
button-event-window
button-event-root
button-event-subwindow
button-event-time
button-event-x
button-event-y
button-event-x-root
button-event-y-root
button-event-state
button-event-button
button-event-same-screen?
motion-event?
motion-event-type
motion-event-serial
motion-event-send-event?
motion-event-display
motion-event-window
motion-event-root
motion-event-subwindow
motion-event-time
motion-event-x
motion-event-y
motion-event-x-root
motion-event-y-root
motion-event-state
motion-event-is-hint?
motion-event-same-screen?
crossing-event?
crossing-event-type
crossing-event-serial
crossing-event-send-event?
crossing-event-display
crossing-event-window
crossing-event-root
crossing-event-subwindow
crossing-event-time
crossing-event-x
crossing-event-y
crossing-event-x-root
crossing-event-y-root
crossing-event-mode
crossing-event-detail
crossing-event-same-screen?
crossing-event-focus?
crossing-event-state
focus-change-event?
focus-change-event-type
focus-change-event-serial
focus-change-event-send-event?
focus-change-event-display
focus-change-event-window
focus-change-event-mode
focus-change-event-detail
expose-event?
expose-event-type
expose-event-serial
expose-event-send-event?
expose-event-display
expose-event-window
expose-event-x
expose-event-y
expose-event-width
expose-event-height
expose-event-count
graphics-expose-event?
graphics-expose-event-type
graphics-expose-event-serial
graphics-expose-event-send-event?
graphics-expose-event-display
graphics-expose-event-drawable
graphics-expose-event-x
graphics-expose-event-y
graphics-expose-event-width
graphics-expose-event-height
graphics-expose-event-major-code
graphics-expose-event-minor-code
no-expose-event?
no-expose-event-type
no-expose-event-serial
no-expose-event-send-event?
no-expose-event-display
no-expose-event-drawable
no-expose-event-major-code
no-expose-event-minor-code
visibility-event?
visibility-event-type
visibility-event-serial
visibility-event-send-event?
visibility-event-display
visibility-event-window
visibility-event-state
create-window-event?
create-window-event-type
create-window-event-serial
create-window-event-send-event?
create-window-event-display
create-window-event-parent
create-window-event-window
create-window-event-x
create-window-event-y
create-window-event-width
create-window-event-height
create-window-event-border-width
create-window-event-override-redirect?
destroy-window-event?
destroy-window-event-type
destroy-window-event-serial
destroy-window-event-send-event?
destroy-window-event-display
destroy-window-event-event
destroy-window-event-window
unmap-event?
unmap-event-type
unmap-event-serial
unmap-event-send-event?
unmap-event-display
unmap-event-event
unmap-event-window
unmap-event-from-configure?
map-event?
map-event-type
map-event-serial
map-event-send-event?
map-event-display
map-event-event
map-event-window
map-event-override-redirect?
map-request-event?
map-request-event-type
map-request-event-serial
map-request-event-send-event?
map-request-event-display
map-request-event-parent
map-request-event-window
reparent-event?
reparent-event-type
reparent-event-serial
reparent-event-send-event?
reparent-event-display
reparent-event-event
reparent-event-window
reparent-event-parent
reparent-event-x
reparent-event-y
reparent-event-override-redirect?
configure-event?
configure-event-type
configure-event-serial
configure-event-send-event?
configure-event-display
configure-event-event
configure-event-window
configure-event-x
configure-event-y
configure-event-width
configure-event-height
configure-event-border-width
configure-event-above
configure-event-override-redirect?
gravity-event?
gravity-event-type
gravity-event-serial
gravity-event-send-event?
gravity-event-display
gravity-event-event
gravity-event-window
gravity-event-x
gravity-event-y
resize-request-event?
resize-request-event-type
resize-request-event-serial
resize-request-event-send-event?
resize-request-event-display
resize-request-event-window
resize-request-event-width
resize-request-event-height
configure-request-event?
configure-request-event-type
configure-request-event-serial
configure-request-event-send-event?
configure-request-event-display
configure-request-event-parent
configure-request-event-window
configure-request-event-window-changes-alist
circulate-event?
circulate-event-type
circulate-event-serial
circulate-event-send-event?
circulate-event-display
circulate-event-event
circulate-event-window
circulate-event-place
circulate-request-event?
circulate-request-event-type
circulate-request-event-serial
circulate-request-event-send-event?
circulate-request-event-display
circulate-request-event-parent
circulate-request-event-window
circulate-request-event-place
property-event?
property-event-type
property-event-serial
property-event-send-event?
property-event-display
property-event-window
property-event-atom
property-event-time
property-event-state
selection-clear-event?
selection-clear-event-type
selection-clear-event-serial
selection-clear-event-send-event?
selection-clear-event-display
selection-clear-event-window
selection-clear-event-selection
selection-clear-event-time
selection-request-event?
selection-request-event-type
selection-request-event-serial
selection-request-event-send-event?
selection-request-event-display
selection-request-event-owner
selection-request-event-requestor
selection-request-event-atom
selection-request-event-target
selection-request-event-property
selection-request-event-time
selection-event?
selection-event-type
selection-event-serial
selection-event-send-event?
selection-event-display
selection-event-requestor
selection-event-selection
selection-event-target
selection-event-property
selection-event-time
colormap-event?
colormap-event-type
colormap-event-serial
colormap-event-send-event?
colormap-event-display
colormap-event-window
colormap-event-colormap
colormap-event-new?
colormap-event-state
client-message-event?
client-message-event-type
client-message-event-serial
client-message-event-send-event?
client-message-event-display
client-message-event-window
client-message-event-message-type
client-message-event-format
client-message-event-data
mapping-event?
mapping-event-type
mapping-event-serial
mapping-event-send-event?
mapping-event-display
mapping-event-window
mapping-event-request
mapping-event-first-keycode
mapping-event-count
error-event?
error-event-type
error-event-serial
error-event-send-event?
error-event-display
error-event-serial
error-event-error-code
error-event-request-code
error-event-minor-code
error-event-resourceid
keymap-event?
keymap-event-type
keymap-event-serial
keymap-event-send-event?
keymap-event-display
keymap-event-bit-vector
))
(define-interface xlib-text-interface
(export text-width
@ -335,10 +599,7 @@
))
(define-interface xlib-property-interface
(export atom?
make-atom
intern-atom
find-atom
(export find-atom
atom-name
list-properties
get-property
@ -350,21 +611,18 @@
convert-selection))
(define-interface xlib-cursor-interface
(export cursor?
cursor-display
free-cursor
create-pixmap-cursor
(export create-pixmap-cursor
create-cursor ;; same as above
create-glyph-cursor
create-font-cursor
recolor-cursor))
(define-interface xlib-wm-interface
(export reparent-window
install-colormap
uninstall-colormap
list-installed-colormaps
((revert-to save-set close-down-mode) :syntax)
set-input-focus
input-focus
general-warp-pointer
@ -397,12 +655,13 @@
set-wm-command!
get-transient-for
set-transient-for!
get-wm-normal-hints
set-wm-normal-hints!
((wm-hint
size-hint
((wm-hint size-hint initial-state
make-wm-hint-alist
make-size-hint-alist) :syntax)
get-wm-normal-hints
set-wm-normal-hints!
get-wm-hints
set-wm-hints!
get-icon-sizes
@ -431,7 +690,8 @@
x-error-text
most-recent-x-error
next-x-error
x-fatal-error-handler))
x-fatal-error-handler
((error-code) :syntax)))
(define-interface xlib-extension-interface
(export list-extensions
@ -462,21 +722,21 @@
allow-events
grab-server
ungrab-server
((grab-status allow-event) :syntax)
;; syntax: with-server-grabbed
))
(define-interface xlib-visual-interface
(export visual?
get-visual-info
(export get-visual-info
visual-id
match-visual-info
(make-visual-info-alist :syntax)
((visual-info visual-class window-class
make-visual-info-alist bit-order byte-order) :syntax)
))
(define-interface xlib-region-interface
(export region?
destroy-region
create-region
(export create-region
clip-box
region-empty?
region-equal?
@ -498,8 +758,57 @@
;; all together
(define-interface xlib-types-interface
;; a subset of xlib-internal-types-interface
(export
display? display-after-function
display-set-after-function! close-display
window? destroy-window window-display
drawable? drawable-display
color?
colormap? free-colormap colormap-display
pixel?
gcontext? free-gcontext gcontext? gcontext-display
pixmap? free-pixmap pixmap-display
font? font-display font-name open-font close-font
atom? make-atom intern-atom
cursor? cursor-display free-cursor
visual?
region? destroy-region
((event-mask) :syntax)
event-mask-all-events
((state state-set button notify-mode notify-detail
visibility-state place property-state colormap-state
mapping-request bit-gravity gravity) :syntax)
((set-window-attribute window-change stack-mode
window-attribute
make-set-window-attribute-alist
make-window-attribute-alist
make-window-change-alist) :syntax)
((fill-rule) :syntax)
))
(define-interface xlib-interface
(compound-interface xlib-display-interface
(compound-interface xlib-types-interface
xlib-display-interface
xlib-pixmap-interface
xlib-window-interface
xlib-drawable-interface

161
scheme/xlib/xlib-internal-interfaces.scm
View File

@ -11,121 +11,78 @@
;; these are internal interfaces that describe the construction and access
;; functions to all the new datatypes. They are not needed by the user
(define-interface xlib-display-type-interface
(export make-display
display?
display-Xdisplay
display-after-function
display-set-after-function!
close-display
display-message-inport))
(define-interface xlib-internal-types-interface
(export
(define-interface xlib-window-type-interface
(export make-window
destroy-window
window?
window-Xwindow
window-display))
display? make-display display-Xdisplay display-after-function
display-set-after-function! close-display display-message-inport
(define-interface xlib-drawable-type-interface
(export drawable?
drawable-abstraction
drawable-display
drawable-Xobject))
window? make-window destroy-window window-Xwindow window-display
(define-interface xlib-color-type-interface
(export internal-make-color
extract-rgb-values
create-color
color?
color-Xcolor))
drawable? make-drawable drawable-abstraction drawable-display
drawable-Xobject
(define-interface xlib-colormap-type-interface
(export make-colormap
colormap?
free-colormap
colormap-display
colormap-Xcolormap))
color? internal-make-color extract-rgb-values create-color color-Xcolor
(define-interface xlib-pixel-type-interface
(export make-pixel
pixel?
pixel-Xpixel))
colormap? make-colormap free-colormap colormap-display colormap-Xcolormap
(define-interface xlib-gcontext-type-interface
(export make-gcontext
free-gcontext
gcontext?
gcontext-display
gcontext-Xgcontext))
pixel? make-pixel pixel-Xpixel
(define-interface xlib-pixmap-type-interface
(export make-pixmap
free-pixmap
pixmap?
pixmap-Xpixmap
pixmap-display))
gcontext? make-gcontext free-gcontext gcontext? gcontext-display
gcontext-Xgcontext
(define-interface xlib-event-type-interface
(export make-event
event?
event-type
event-args
event-set-args!))
pixmap? make-pixmap free-pixmap pixmap-Xpixmap pixmap-display
(define-interface xlib-font-type-interface
(export make-font
font?
font-Xfont
font-Xfontstruct
font-display
font-name
load-font
open-font
unload-font
close-font))
font? make-font font-Xfont font-Xfontstruct font-display font-name
load-font open-font unload-font close-font
(define-interface xlib-atom-type-interface
(export atom?
make-atom
atom-Xatom
intern-atom))
atom? make-atom atom-Xatom intern-atom
(define-interface xlib-cursor-type-interface
(export cursor?
make-cursor
cursor-display
cursor-Xcursor
free-cursor))
cursor? make-cursor cursor-display cursor-Xcursor free-cursor
(define-interface xlib-visual-type-interface
(export visual?
make-visual
visual-Xvisual))
visual? make-visual visual-Xvisual
(define-interface xlib-region-type-interface
(export region?
make-region
destroy-region
region-Xregion))
region? make-region destroy-region region-Xregion
;; all in one
((event-mask) :syntax) event-mask-all-events
integer->event-mask event-mask->integer
integer->state-set state-set->integer
integer->button button->integer
integer->is-hint? is-hint?->integer
integer->notify-mode notify-mode->integer
integer->notify-detail notify-detail->integer
integer->visibility-state visibility-state->integer
integer->place place->integer
integer->property-state property-state->integer
integer->colormap-state colormap-state->integer
integer->mapping-request mapping-request->integer
((state state-set button notify-mode notify-detail
visibility-state place property-state colormap-state
mapping-request bit-gravity gravity backing-store) :syntax)
gravity->integer integer->gravity
make-enum-alist->integer+vector
make-integer+vector->enum-alist
make-integer->enum-set make-enum-set->integer
set-window-attribute-alist->integer+vector
((set-window-attribute make-set-window-attribute-alist) :syntax)
((window-change make-window-change-alist stack-mode) :syntax)
window-change-alist->integer+vector integer+vector->window-change-alist
((window-attribute make-window-attribute-alist) :syntax)
integer+vector->window-attribute-alist
((window-class) :syntax)
((byte-order bit-order) :syntax)
integer->byte-order integer->bit-order
((fill-rule) :syntax)
fill-rule->integer integer->fill-rule
(define-interface xlib-types-interface
(compound-interface
xlib-helper-interface
xlib-display-type-interface
xlib-window-type-interface
xlib-drawable-type-interface
xlib-color-type-interface
xlib-colormap-type-interface
xlib-pixel-type-interface
xlib-gcontext-type-interface
xlib-pixmap-type-interface
xlib-event-type-interface
xlib-font-type-interface
xlib-atom-type-interface
xlib-cursor-type-interface
xlib-visual-type-interface
xlib-region-type-interface
))

18
scheme/xlib/xlib-internal-packages.scm
View File

@ -6,7 +6,13 @@
;; the other xlib packages need this to gain direct access to the new datatypes.
;; Normal users shouldn't use this package.
(define-structure xlib-types xlib-types-interface
(define-structure xlib-helper xlib-helper-interface
(open scheme
external-calls
list-lib)
(files helper))
(define-structure xlib-internal-types xlib-internal-types-interface
(open scheme
signals ;; for error
fdes ;; see above
@ -17,9 +23,9 @@
define-record-types
external-calls
byte-vectors ;; for color-type.scm
)
(files helper
display-type
finite-types enum-sets bitwise
xlib-helper)
(files display-type
color-type
colormap-type
pixel-type
@ -27,9 +33,9 @@
window-type
drawable-type
gcontext-type
event-type
font-type
atom-type
cursor-type
visual-type
region-type))
region-type
types))

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

@ -2,7 +2,7 @@
(open scheme
signals ;; for error
external-calls
xlib-types)
xlib-internal-types)
(files display))
(define-structure xlib-window xlib-window-interface
@ -10,7 +10,8 @@
signals ;; for error
external-calls
receiving
xlib-types
xlib-internal-types
xlib-helper
xlib-graphics ;; for clear-window
finite-types ;; for define-enumerated-type
)
@ -20,7 +21,7 @@
(define-structure xlib-drawable xlib-drawable-interface
(open scheme
external-calls
xlib-types
xlib-internal-types
xlib-window
xlib-pixmap)
(files drawable))
@ -30,21 +31,25 @@
(open scheme
signals ;; for error
external-calls
xlib-types)
xlib-internal-types
xlib-helper)
(files color))
(define-structure xlib-colormap xlib-colormap-interface
(open scheme
external-calls
xlib-types)
bitwise
signals
list-lib
xlib-internal-types)
(files colormap))
(define-structure xlib-pixel xlib-pixel-interface
(open scheme
external-calls
xlib-types)
xlib-internal-types)
(files pixel))
@ -53,8 +58,8 @@
signals ;; for error
external-calls
receiving
finite-types ;; for define-enumerated-type
xlib-types)
finite-types enum-sets
xlib-internal-types)
(files gcontext))
@ -62,15 +67,15 @@
(open scheme
signals ;; for error
external-calls
xlib-types)
xlib-internal-types)
(files pixmap)) ;;...
(define-structure xlib-graphics xlib-graphics-interface
(open scheme
external-calls
xlib-types
xlib-internal-types
list-lib ;; for fold-right
)
finite-types)
(files graphics))
(define-structure xlib-event xlib-event-interface
@ -81,14 +86,16 @@
ports locks ;; for locking the port
channel-i/o ;; for wait-for-channel
interrupts
xlib-types)
(files event))
finite-types define-record-types
xlib-internal-types)
(files event event-types))
(define-structure xlib-font xlib-font-interface
(open scheme
signals ;; for error
external-calls
xlib-types
xlib-internal-types
xlib-helper
bitwise ;; for bitwise-and, arithmetix-shift
)
(files font))
@ -98,45 +105,50 @@
signals ;; for error
external-calls
ascii ;; for char->ascii etc.
xlib-types)
xlib-internal-types
xlib-helper)
(files text))
(define-structure xlib-property xlib-property-interface
(open scheme
external-calls
xlib-types)
signals
xlib-internal-types
xlib-helper)
(files property))
(define-structure xlib-cursor xlib-cursor-interface
(open scheme
external-calls
xlib-types)
xlib-internal-types
xlib-helper)
(files cursor))
(define-structure xlib-wm xlib-wm-interface
(open scheme
external-calls
xlib-types
xlib-internal-types
signals ;; for error
)
finite-types
xlib-helper)
(files wm))
(define-structure xlib-client xlib-client-interface
(open scheme
external-calls
xlib-types
xlib-internal-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
)
xlib-helper)
(files client))
(define-structure xlib-key xlib-key-interface
(open scheme
external-calls
xlib-types)
xlib-internal-types)
(files key))
(define-structure xlib-error xlib-error-interface
@ -144,20 +156,21 @@
external-calls
placeholders
define-record-types
xlib-types)
finite-types
xlib-internal-types)
(files error))
(define-structure xlib-extension xlib-extension-interface
(open scheme
external-calls
xlib-types)
xlib-internal-types)
(files extension))
(define-structure xlib-utility xlib-utility-interface
(open scheme
external-calls
receiving
xlib-types
xlib-internal-types
xlib-display
xlib-property)
(files utility))
@ -165,26 +178,34 @@
(define-structure xlib-grab xlib-grab-interface
(open scheme
external-calls
xlib-types)
finite-types
xlib-internal-types)
(files grab))
(define-structure xlib-visual xlib-visual-interface
(open scheme
external-calls
finite-types ;; for enumerated types
xlib-types)
xlib-internal-types)
(files visual))
(define-structure xlib-region xlib-region-interface
(open scheme
external-calls
xlib-types)
xlib-internal-types)
(files region))
(define-structure xlib-types xlib-types-interface
(open scheme
finite-types
define-record-types
xlib-internal-types))
;; all together
(define-structure xlib xlib-interface
(open xlib-display
(open xlib-types
xlib-display
xlib-pixmap
xlib-window
xlib-drawable