From 10558fa5f0d7b4e8e9ae84ce77c2ba2202a2e150 Mon Sep 17 00:00:00 2001 From: frese Date: Fri, 8 Feb 2002 17:09:43 +0000 Subject: [PATCH] - 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. --- Makefile | 8 +- c/libs/xpm.c | 72 +- c/main.c | 3 - c/xlib/client.c | 217 +++--- c/xlib/color.c | 5 +- c/xlib/colormap.c | 7 +- c/xlib/display.c | 51 +- c/xlib/error.c | 11 +- c/xlib/event.c | 131 ++-- c/xlib/font.c | 41 +- c/xlib/gcontext.c | 177 ++--- c/xlib/grab.c | 36 +- c/xlib/graphics.c | 2 +- c/xlib/init.c | 9 +- c/xlib/key.c | 15 +- c/xlib/pixel.c | 3 +- c/xlib/pixmap.c | 12 +- c/xlib/property.c | 6 +- c/xlib/region.c | 12 +- c/xlib/text.c | 12 +- c/xlib/util.c | 40 +- c/xlib/visual.c | 104 ++- c/xlib/window.c | 213 +++--- c/xlib/wm.c | 15 +- c/xlib/xlib.h | 28 +- scheme/libs/libs-packages.scm | 4 +- scheme/libs/xpm.scm | 83 ++- scheme/xlib/client.scm | 106 ++- scheme/xlib/colormap.scm | 23 +- scheme/xlib/display.scm | 6 +- scheme/xlib/drawable-type.scm | 32 +- scheme/xlib/error.scm | 13 +- scheme/xlib/event-types.scm | 859 +++++++++++++++++++++++ scheme/xlib/event.scm | 188 ++--- scheme/xlib/font.scm | 10 +- scheme/xlib/gcontext.scm | 296 ++++++-- scheme/xlib/grab.scm | 64 +- scheme/xlib/graphics.scm | 12 +- scheme/xlib/helper.scm | 2 +- scheme/xlib/key.scm | 5 +- scheme/xlib/pixmap.scm | 15 +- scheme/xlib/property.scm | 13 +- scheme/xlib/region.scm | 2 +- scheme/xlib/types.scm | 503 +++++++++++++ scheme/xlib/utility.scm | 2 +- scheme/xlib/visual.scm | 89 ++- scheme/xlib/window.scm | 223 ++---- scheme/xlib/wm.scm | 43 +- scheme/xlib/xlib-interfaces.scm | 475 ++++++++++--- scheme/xlib/xlib-internal-interfaces.scm | 161 ++--- scheme/xlib/xlib-internal-packages.scm | 18 +- scheme/xlib/xlib-packages.scm | 79 ++- 52 files changed, 3139 insertions(+), 1417 deletions(-) create mode 100644 scheme/xlib/event-types.scm create mode 100644 scheme/xlib/types.scm diff --git a/Makefile b/Makefile index 20a24db..733b0da 100644 --- a/Makefile +++ b/Makefile @@ -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) diff --git a/c/libs/xpm.c b/c/libs/xpm.c index 9b8f593..10bda89 100644 --- a/c/libs/xpm.c +++ b/c/libs/xpm.c @@ -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; - XA->visual = SCX_EXTRACT_VISUAL(v); - break; - case 1: mask |= XpmColormap; - XA->colormap = SCX_EXTRACT_COLORMAP(v); - break; - case 2: 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; - XA->exactColors = s48_extract_integer(v); - break; - case 6: mask |= XpmReturnAllocPixels; break; - case 7: 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; - } - } - } + unsigned long mask = s48_extract_integer(S48_CAR(attribs)); + s48_value v = S48_CDR(attribs); + + if (mask & XpmVisual) + XA->visual = SCX_EXTRACT_VISUAL(v); + if (mask & XpmColormap) + XA->colormap = SCX_EXTRACT_COLORMAP(v); + if (mask & XpmDepth) + XA->depth = s48_extract_integer(v); + if ((mask & XpmReturnPixels) && (S48_FALSE_P(v))) + mask = mask & (~XpmReturnPixels); + if (mask & XpmExactColors) + XA->exactColors = s48_extract_integer(v); + if ((mask & XpmReturnAllocPixels) && (S48_FALSE_P(v))) + mask = mask & (~XpmReturnAllocPixels); + if (mask & XpmAllocCloseColors) + XA->alloc_close_colors = s48_extract_integer(v); + 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); } diff --git a/c/main.c b/c/main.c index e3aabf9..8e1e5ec 100644 --- a/c/main.c +++ b/c/main.c @@ -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); diff --git a/c/xlib/client.c b/c/xlib/client.c index 3935dba..6974dc4 100644 --- a/c/xlib/client.c +++ b/c/xlib/client.c @@ -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); - - 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); - } + 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)); + SH.flags = mask; XSetWMNormalHints(SCX_EXTRACT_DISPLAY(dpy), diff --git a/c/xlib/color.c b/c/xlib/color.c index db3d881..6d599ab 100644 --- a/c/xlib/color.c +++ b/c/xlib/color.c @@ -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(); diff --git a/c/xlib/colormap.c b/c/xlib/colormap.c index b40216c..6bbb971 100644 --- a/c/xlib/colormap.c +++ b/c/xlib/colormap.c @@ -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; diff --git a/c/xlib/display.c b/c/xlib/display.c index e84dd30..aba4ab1 100644 --- a/c/xlib/display.c +++ b/c/xlib/display.c @@ -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) { diff --git a/c/xlib/error.c b/c/xlib/error.c index 58ee761..c053d4a 100644 --- a/c/xlib/error.c +++ b/c/xlib/error.c @@ -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)); diff --git a/c/xlib/event.c b/c/xlib/event.c index 30bf10e..3b9bdbd 100644 --- a/c/xlib/event.c +++ b/c/xlib/event.c @@ -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,9 +346,9 @@ 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 = SCX_ENTER_TIME(p[i].time); 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); } diff --git a/c/xlib/font.c b/c/xlib/font.c index f1b4c10..abc56c9 100644 --- a/c/xlib/font.c +++ b/c/xlib/font.c @@ -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; diff --git a/c/xlib/gcontext.c b/c/xlib/gcontext.c index 6a7ffbd..2b0979a 100644 --- a/c/xlib/gcontext.c +++ b/c/xlib/gcontext.c @@ -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; } @@ -100,11 +72,9 @@ s48_value scx_Copy_Gc(s48_value Xdisplay, s48_value Xsource, s48_value Xdest) { return S48_UNSPECIFIC; } -s48_value scx_Copy_Gc_To_Gc(s48_value Xdisplay, s48_value Xfrom, s48_value Xto, +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(); } - 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) { - + 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)); } diff --git a/c/xlib/grab.c b/c/xlib/grab.c index 6699e2b..0bfcf7c 100644 --- a/c/xlib/grab.c +++ b/c/xlib/grab.c @@ -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,17 +49,17 @@ 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; + return S48_UNSPECIFIC; } 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; diff --git a/c/xlib/graphics.c b/c/xlib/graphics.c index 8a1dce1..4a2c24c 100644 --- a/c/xlib/graphics.c +++ b/c/xlib/graphics.c @@ -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; diff --git a/c/xlib/init.c b/c/xlib/init.c index 947b9b4..9d30747 100644 --- a/c/xlib/init.c +++ b/c/xlib/init.c @@ -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); diff --git a/c/xlib/key.c b/c/xlib/key.c index dc548cf..fea8d1e 100644 --- a/c/xlib/key.c +++ b/c/xlib/key.c @@ -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; } diff --git a/c/xlib/pixel.c b/c/xlib/pixel.c index 7f06472..474ddd2 100644 --- a/c/xlib/pixel.c +++ b/c/xlib/pixel.c @@ -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); diff --git a/c/xlib/pixmap.c b/c/xlib/pixmap.c index 1f6fa23..ca13263 100644 --- a/c/xlib/pixmap.c +++ b/c/xlib/pixmap.c @@ -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); } diff --git a/c/xlib/property.c b/c/xlib/property.c index 2d5ffbb..32e92a5 100644 --- a/c/xlib/property.c +++ b/c/xlib/property.c @@ -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,8 +158,8 @@ 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), - SCX_EXTRACT_ATOM(Xatom_s))); + return SCX_ENTER_WINDOW(XGetSelectionOwner(SCX_EXTRACT_DISPLAY(Xdisplay), + SCX_EXTRACT_ATOM(Xatom_s))); } diff --git a/c/xlib/region.c b/c/xlib/region.c index 4076c84..48367ae 100644 --- a/c/xlib/region.c +++ b/c/xlib/region.c @@ -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++) { diff --git a/c/xlib/text.c b/c/xlib/text.c index 3e8d8df..f6303d1 100644 --- a/c/xlib/text.c +++ b/c/xlib/text.c @@ -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; } diff --git a/c/xlib/util.c b/c/xlib/util.c index eb9395a..11348bc 100644 --- a/c/xlib/util.c +++ b/c/xlib/util.c @@ -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; } diff --git a/c/xlib/visual.c b/c/xlib/visual.c index c8a922e..1935fb9 100644 --- a/c/xlib/visual.c +++ b/c/xlib/visual.c @@ -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; @@ -28,52 +57,9 @@ s48_value scx_Get_Visual_Info(s48_value Xdisplay, s48_value v) { long mask = VisualNoMask; 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; ibackground_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; } @@ -229,8 +188,9 @@ 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), + s48_value dir) { + XCirculateSubwindows(SCX_EXTRACT_DISPLAY(Xdisplay), + SCX_EXTRACT_WINDOW(Xwindow), S48_FALSE_P(dir) ? RaiseLowest : LowerHighest); return S48_UNSPECIFIC; } @@ -266,8 +226,8 @@ s48_value scx_Query_Tree (s48_value Xwindow, s48_value Xdisplay) { } s48_value scx_Translate_Coordinates (s48_value Xdisplay, s48_value srcXwindow, - s48_value x, s48_value y, - s48_value dstXwindow) { + s48_value x, s48_value y, + s48_value dstXwindow) { int rx, ry; Window child; s48_value v = S48_FALSE; @@ -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; } diff --git a/c/xlib/wm.c b/c/xlib/wm.c index 236d477..f7f9573 100644 --- a/c/xlib/wm.c +++ b/c/xlib/wm.c @@ -43,14 +43,11 @@ 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); + s48_value revert_to, s48_value time) { + 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; } diff --git a/c/xlib/xlib.h b/c/xlib/xlib.h index e443da0..c4e8fbb 100644 --- a/c/xlib/xlib.h +++ b/c/xlib/xlib.h @@ -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[]; diff --git a/scheme/libs/libs-packages.scm b/scheme/libs/libs-packages.scm index 5d6fd85..3b8ddf9 100644 --- a/scheme/libs/libs-packages.scm +++ b/scheme/libs/libs-packages.scm @@ -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)) diff --git a/scheme/libs/xpm.scm b/scheme/libs/xpm.scm index d051272..45f02e6 100644 --- a/scheme/libs/xpm.scm +++ b/scheme/libs/xpm.scm @@ -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)) diff --git a/scheme/xlib/client.scm b/scheme/xlib/client.scm index 44c6ca5..b7418d5 100644 --- a/scheme/xlib/client.scm +++ b/scheme/xlib/client.scm @@ -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") diff --git a/scheme/xlib/colormap.scm b/scheme/xlib/colormap.scm index 88a0258..b008726 100644 --- a/scheme/xlib/colormap.scm +++ b/scheme/xlib/colormap.scm @@ -114,9 +114,19 @@ (%store-color (display-Xdisplay (colormap-display colormap)) (colormap-Xcolormap colormap) (pixel-Xpixel pixel) (color-Xcolor color) - (if (null? flags) - '(do-red do-green do-blue) - (car flags)))) + (color-flags->integer + (if (null? flags) + '(do-red do-green do-blue) + (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)) - (if (null? (cddr p-c-f)) - '(do-red do-green do-blue) - (caddr p-c-f))))) + (color-flags->integer + (if (null? (cddr p-c-f)) + '(do-red do-green do-blue) + (caddr p-c-f)))))) cells)))) (%store-colors (display-Xdisplay (colormap-display colormap)) (colormap-Xcolormap colormap) diff --git a/scheme/xlib/display.scm b/scheme/xlib/display.scm index 7f1b83c..b6c6d44 100644 --- a/scheme/xlib/display.scm +++ b/scheme/xlib/display.scm @@ -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") diff --git a/scheme/xlib/drawable-type.scm b/scheme/xlib/drawable-type.scm index 76f395c..1d5d9f6 100644 --- a/scheme/xlib/drawable-type.scm +++ b/scheme/xlib/drawable-type.scm @@ -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)) \ No newline at end of file +(define drawable-display + (drawable-abstraction really-drawable-display pixmap-display window-display)) + +(define drawable-Xobject + (drawable-abstraction really-drawable-Xobject pixmap-Xpixmap window-Xwindow)) diff --git a/scheme/xlib/error.scm b/scheme/xlib/error.scm index 14077fc..153a82e 100644 --- a/scheme/xlib/error.scm +++ b/scheme/xlib/error.scm @@ -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)) diff --git a/scheme/xlib/event-types.scm b/scheme/xlib/event-types.scm new file mode 100644 index 0000000..8d392e9 --- /dev/null +++ b/scheme/xlib/event-types.scm @@ -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))) diff --git a/scheme/xlib/event.scm b/scheme/xlib/event.scm index 30975b7..6385d3b 100644 --- a/scheme/xlib/event.scm +++ b/scheme/xlib/event.scm @@ -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 - - (event-set-args! event (event-args->alist event)) - event))) +;; creates an event type -(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 (complete-event type args) + (let ((constructor (event-constructor type))) + (apply constructor (cons type (vector->list args))))) + +(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") diff --git a/scheme/xlib/font.scm b/scheme/xlib/font.scm index ed53331..4b889a0 100644 --- a/scheme/xlib/font.scm +++ b/scheme/xlib/font.scm @@ -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) diff --git a/scheme/xlib/gcontext.scm b/scheme/xlib/gcontext.scm index 8055f13..a87b691 100644 --- a/scheme/xlib/gcontext.scm +++ b/scheme/xlib/gcontext.scm @@ -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) - (display-Xdisplay (gcontext-display gcontext)) - x y - (list->vector rectangles) - ordering)) +(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) + (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)) diff --git a/scheme/xlib/grab.scm b/scheme/xlib/grab.scm index 45c2e5d..f944973 100644 --- a/scheme/xlib/grab.scm +++ b/scheme/xlib/grab.scm @@ -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) - (%grab-pointer (display-Xdisplay (window-display window)) - (window-Xwindow window) - owner? events - ptr-sync? kbd-sync? - (window-Xwindow confine-to) - (cursor-Xcursor cursor) - time)) + (integer->grab-status + (%grab-pointer (display-Xdisplay (window-display window)) + (window-Xwindow window) + owner? + (event-mask->integer events) + ptr-sync? kbd-sync? + (window-Xwindow confine-to) + (cursor-Xcursor cursor) + 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) - (%grab-keyboard (display-Xdisplay (window-display window)) - (window-Xwindow 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))) (import-lambda-definition %grab-keyboard (Xdisplay Xwindow owner? ptr-sync? kbd-sync? @@ -104,16 +121,20 @@ (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) - "scx_Grab_Key") + "scx_Grab_Key") (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") diff --git a/scheme/xlib/graphics.scm b/scheme/xlib/graphics.scm index 1cb8d32..b402304 100644 --- a/scheme/xlib/graphics.scm +++ b/scheme/xlib/graphics.scm @@ -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) @@ -257,4 +265,4 @@ (cdr rest))))) '(()) points))) - \ No newline at end of file + diff --git a/scheme/xlib/helper.scm b/scheme/xlib/helper.scm index 4b53fa6..318c347 100644 --- a/scheme/xlib/helper.scm +++ b/scheme/xlib/helper.scm @@ -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 diff --git a/scheme/xlib/key.scm b/scheme/xlib/key.scm index 8900462..5bc1b9d 100644 --- a/scheme/xlib/key.scm +++ b/scheme/xlib/key.scm @@ -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") diff --git a/scheme/xlib/pixmap.scm b/scheme/xlib/pixmap.scm index 26d8cdc..90cbfef 100644 --- a/scheme/xlib/pixmap.scm +++ b/scheme/xlib/pixmap.scm @@ -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))))) - (%write-bitmap-file dpy filename (pixmap-Xpixmap pixmap) width height - (car xy-hot) (cdr xy-hot)))) + (bitmap-error + (%write-bitmap-file dpy filename (pixmap-Xpixmap pixmap) width height + (car xy-hot) (cdr xy-hot)) + filename))) (import-lambda-definition %write-bitmap-file (Xdisplay file Xpixmap w h x y) "scx_Write_Bitmap_File") diff --git a/scheme/xlib/property.scm b/scheme/xlib/property.scm index 11d6100..d08a75e 100644 --- a/scheme/xlib/property.scm +++ b/scheme/xlib/property.scm @@ -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) @@ -143,4 +152,4 @@ - \ No newline at end of file + diff --git a/scheme/xlib/region.scm b/scheme/xlib/region.scm index 6b82c65..fc820a3 100644 --- a/scheme/xlib/region.scm +++ b/scheme/xlib/region.scm @@ -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) diff --git a/scheme/xlib/types.scm b/scheme/xlib/types.scm new file mode 100644 index 0000000..3a80c87 --- /dev/null +++ b/scheme/xlib/types.scm @@ -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)) + diff --git a/scheme/xlib/utility.scm b/scheme/xlib/utility.scm index b9059ec..aaca572 100644 --- a/scheme/xlib/utility.scm +++ b/scheme/xlib/utility.scm @@ -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") diff --git a/scheme/xlib/visual.scm b/scheme/xlib/visual.scm index 5e02e60..6b1e8aa 100644 --- a/scheme/xlib/visual.scm +++ b/scheme/xlib/visual.scm @@ -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)))))) + diff --git a/scheme/xlib/window.scm b/scheme/xlib/window.scm index 6ba80f0..74fd8ec 100644 --- a/scheme/xlib/window.scm +++ b/scheme/xlib/window.scm @@ -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) diff --git a/scheme/xlib/wm.scm b/scheme/xlib/wm.scm index 2877186..077e1a3 100644 --- a/scheme/xlib/wm.scm +++ b/scheme/xlib/wm.scm @@ -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") diff --git a/scheme/xlib/xlib-interfaces.scm b/scheme/xlib/xlib-interfaces.scm index e161271..1bc6101 100644 --- a/scheme/xlib/xlib-interfaces.scm +++ b/scheme/xlib/xlib-interfaces.scm @@ -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 diff --git a/scheme/xlib/xlib-internal-interfaces.scm b/scheme/xlib/xlib-internal-interfaces.scm index ace0f2d..8c2f532 100644 --- a/scheme/xlib/xlib-internal-interfaces.scm +++ b/scheme/xlib/xlib-internal-interfaces.scm @@ -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 + + display? make-display display-Xdisplay display-after-function + display-set-after-function! close-display display-message-inport -(define-interface xlib-window-type-interface - (export make-window - destroy-window - window? - window-Xwindow - window-display)) + window? make-window destroy-window window-Xwindow window-display -(define-interface xlib-drawable-type-interface - (export drawable? - drawable-abstraction - drawable-display - drawable-Xobject)) + drawable? make-drawable drawable-abstraction drawable-display + drawable-Xobject -(define-interface xlib-color-type-interface - (export internal-make-color - extract-rgb-values - create-color - color? - color-Xcolor)) + color? internal-make-color extract-rgb-values create-color color-Xcolor -(define-interface xlib-colormap-type-interface - (export make-colormap - colormap? - free-colormap - colormap-display - colormap-Xcolormap)) + colormap? make-colormap free-colormap colormap-display colormap-Xcolormap -(define-interface xlib-pixel-type-interface - (export make-pixel - pixel? - pixel-Xpixel)) + pixel? make-pixel pixel-Xpixel -(define-interface xlib-gcontext-type-interface - (export make-gcontext - free-gcontext - gcontext? - gcontext-display - gcontext-Xgcontext)) + gcontext? make-gcontext free-gcontext gcontext? gcontext-display + gcontext-Xgcontext -(define-interface xlib-pixmap-type-interface - (export make-pixmap - free-pixmap - pixmap? - pixmap-Xpixmap - pixmap-display)) + pixmap? make-pixmap free-pixmap pixmap-Xpixmap pixmap-display -(define-interface xlib-event-type-interface - (export make-event - event? - event-type - event-args - event-set-args!)) + font? make-font font-Xfont font-Xfontstruct font-display font-name + load-font open-font unload-font close-font -(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)) + atom? make-atom atom-Xatom intern-atom -(define-interface xlib-atom-type-interface - (export atom? - make-atom - atom-Xatom - intern-atom)) + cursor? make-cursor cursor-display cursor-Xcursor free-cursor -(define-interface xlib-cursor-type-interface - (export cursor? - make-cursor - cursor-display - cursor-Xcursor - free-cursor)) + visual? make-visual visual-Xvisual -(define-interface xlib-visual-type-interface - (export visual? - make-visual - visual-Xvisual)) + region? make-region destroy-region region-Xregion -(define-interface xlib-region-type-interface - (export region? - make-region - destroy-region - region-Xregion)) + ((event-mask) :syntax) event-mask-all-events + integer->event-mask event-mask->integer -;; all in one + 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 )) diff --git a/scheme/xlib/xlib-internal-packages.scm b/scheme/xlib/xlib-internal-packages.scm index f4a8b1f..7ea7dd5 100644 --- a/scheme/xlib/xlib-internal-packages.scm +++ b/scheme/xlib/xlib-internal-packages.scm @@ -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)) \ No newline at end of file + region-type + types)) diff --git a/scheme/xlib/xlib-packages.scm b/scheme/xlib/xlib-packages.scm index 02ea7ec..c5da9f4 100644 --- a/scheme/xlib/xlib-packages.scm +++ b/scheme/xlib/xlib-packages.scm @@ -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