From 84ca2f8675d0bd94089d248dfeefe21aa50ef3c3 Mon Sep 17 00:00:00 2001 From: frese Date: Mon, 25 Feb 2002 13:10:11 +0000 Subject: [PATCH] + fixed some bugs. + added optional screen argument to some display-functions. + added more any-event-* functions. + implemented send-event. + updated interfaces. --- c/xlib/client.c | 16 +- c/xlib/display.c | 36 +- c/xlib/event.c | 304 +++++++++- c/xlib/property.c | 5 +- c/xlib/window.c | 20 +- scheme/xlib/client.scm | 9 +- scheme/xlib/display.scm | 93 +-- scheme/xlib/event-types.scm | 714 +++++++++++++++++++---- scheme/xlib/event.scm | 25 +- scheme/xlib/types.scm | 4 +- scheme/xlib/xlib-interfaces.scm | 83 ++- scheme/xlib/xlib-internal-interfaces.scm | 2 +- 12 files changed, 1074 insertions(+), 237 deletions(-) diff --git a/c/xlib/client.c b/c/xlib/client.c index 6974dc4..608868c 100644 --- a/c/xlib/client.c +++ b/c/xlib/client.c @@ -382,6 +382,12 @@ s48_value scx_Wm_Normal_Hints(s48_value dpy, s48_value win) { v = s48_make_vector(10, S48_NULL); S48_GC_PROTECT_1(v); + if ((SH.flags & USPosition) != 0) + S48_VECTOR_SET(v, 0, S48_VECTOR_REF(v, 2)); + + if ((SH.flags & USSize) != 0) + S48_VECTOR_SET(v, 1, S48_VECTOR_REF(v, 3)); + if (((SH.flags & PPosition) != 0) || ((SH.flags & USPosition) != 0)) S48_VECTOR_SET(v, 2, s48_cons(s48_enter_fixnum(SH.x), s48_enter_fixnum(SH.y))); @@ -390,12 +396,6 @@ s48_value scx_Wm_Normal_Hints(s48_value dpy, s48_value win) { 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)); - - if ((SH.flags & USSize) != 0) - S48_VECTOR_SET(v, 1, S48_VECTOR_REF(v, 3)); - if ((SH.flags & PMinSize) != 0) S48_VECTOR_SET(v, 4, s48_cons(s48_enter_fixnum(SH.min_width), s48_enter_fixnum(SH.min_height))); @@ -420,7 +420,7 @@ s48_value scx_Wm_Normal_Hints(s48_value dpy, s48_value win) { s48_enter_fixnum(SH.base_height))); if ((SH.flags & PWinGravity) != 0) - S48_VECTOR_SET(v, 18, s48_enter_integer(SH.win_gravity)); + S48_VECTOR_SET(v, 9, s48_enter_integer(SH.win_gravity)); v = s48_cons(s48_enter_integer(SH.flags), v); @@ -431,7 +431,7 @@ 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 = S48_CAR(hints); + long mask = s48_extract_integer(S48_CAR(hints)); s48_value v = S48_CDR(hints); if (mask & USPosition) { diff --git a/c/xlib/display.c b/c/xlib/display.c index aba4ab1..1809f12 100644 --- a/c/xlib/display.c +++ b/c/xlib/display.c @@ -62,21 +62,27 @@ s48_value scx_Display_Default_Root_Window(s48_value Xdisplay) { return SCX_ENTER_WINDOW(wnd); } -s48_value scx_Display_Default_Colormap(s48_value Xdisplay) { +s48_value scx_Display_Root_Window(s48_value Xdisplay, s48_value scr_num) { + Window wnd = RootWindow(SCX_EXTRACT_DISPLAY(Xdisplay), + s48_extract_integer(scr_num)); + return SCX_ENTER_WINDOW(wnd); +} + +s48_value scx_Display_Default_Colormap(s48_value Xdisplay, s48_value scr) { Display* dpy = SCX_EXTRACT_DISPLAY(Xdisplay); - Colormap cmp = DefaultColormap(dpy, DefaultScreen(dpy)); + Colormap cmp = DefaultColormap(dpy, s48_extract_integer(scr)); return SCX_ENTER_COLORMAP(cmp); } -s48_value scx_Display_Default_Gcontext(s48_value Xdisplay) { +s48_value scx_Display_Default_Gcontext(s48_value Xdisplay, s48_value scr) { Display* dpy = SCX_EXTRACT_DISPLAY(Xdisplay); - GC gc = DefaultGC(dpy, DefaultScreen(dpy)); + GC gc = DefaultGC(dpy, s48_extract_integer(scr)); return SCX_ENTER_GCONTEXT(gc); } -s48_value scx_Display_Default_Depth(s48_value Xdisplay) { +s48_value scx_Display_Default_Depth(s48_value Xdisplay, s48_value scr) { Display* dpy = SCX_EXTRACT_DISPLAY(Xdisplay); - int depth = DefaultDepth(dpy, DefaultScreen(dpy)); + int depth = DefaultDepth(dpy, s48_extract_integer(scr)); return s48_enter_fixnum(depth); } @@ -159,24 +165,24 @@ s48_value scx_Display_Bitmap_Pad(s48_value Xdisplay) { return s48_enter_integer(bp); } -s48_value scx_Display_Width(s48_value Xdisplay) { +s48_value scx_Display_Width(s48_value Xdisplay, s48_value scr) { Display* dpy = SCX_EXTRACT_DISPLAY(Xdisplay); - return s48_enter_fixnum(DisplayWidth(dpy, DefaultScreen(dpy))); + return s48_enter_fixnum(DisplayWidth(dpy, s48_extract_integer(scr))); } -s48_value scx_Display_Height(s48_value Xdisplay) { +s48_value scx_Display_Height(s48_value Xdisplay, s48_value scr) { Display* dpy = SCX_EXTRACT_DISPLAY(Xdisplay); - return s48_enter_fixnum(DisplayHeight(dpy, DefaultScreen(dpy))); + return s48_enter_fixnum(DisplayHeight(dpy, s48_extract_integer(scr))); } -s48_value scx_Display_Width_Mm (s48_value Xdisplay) { +s48_value scx_Display_Width_Mm (s48_value Xdisplay, s48_value scr) { Display* dpy = SCX_EXTRACT_DISPLAY(Xdisplay); - return s48_enter_fixnum(DisplayWidthMM(dpy, DefaultScreen(dpy))); + return s48_enter_fixnum(DisplayWidthMM(dpy, s48_extract_integer(scr))); } -s48_value scx_Display_Height_Mm (s48_value Xdisplay) { +s48_value scx_Display_Height_Mm (s48_value Xdisplay, s48_value scr) { Display* dpy = SCX_EXTRACT_DISPLAY(Xdisplay); - return s48_enter_fixnum(DisplayHeightMM(dpy, DefaultScreen(dpy))); + return s48_enter_fixnum(DisplayHeightMM(dpy, s48_extract_integer(scr))); } s48_value scx_Display_Motion_Buffer_Size(s48_value Xdisplay) { @@ -249,6 +255,7 @@ s48_value scx_Display_Select_Input(s48_value Xdisplay, s48_value Xwindow, XSelectInput(SCX_EXTRACT_DISPLAY(Xdisplay), SCX_EXTRACT_WINDOW(Xwindow), s48_extract_integer(event_mask)); + return S48_UNSPECIFIC; } void scx_init_display(void) { @@ -261,6 +268,7 @@ void scx_init_display(void) { S48_EXPORT_FUNCTION(scx_Close_Display); S48_EXPORT_FUNCTION(scx_Display_Message_fd); S48_EXPORT_FUNCTION(scx_Display_Default_Root_Window); + S48_EXPORT_FUNCTION(scx_Display_Root_Window); S48_EXPORT_FUNCTION(scx_Display_Default_Colormap); S48_EXPORT_FUNCTION(scx_Display_Default_Gcontext); S48_EXPORT_FUNCTION(scx_Display_Default_Depth); diff --git a/c/xlib/event.c b/c/xlib/event.c index 3b9bdbd..40b8806 100644 --- a/c/xlib/event.c +++ b/c/xlib/event.c @@ -2,13 +2,13 @@ #include "scheme48.h" #define ECAST(name, type) type* name = (type*)e -#define sidx 4 +#define sidx 5 #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; + s48_value temp = S48_FALSE; int i; S48_DECLARE_GC_PROTECT(2); S48_GC_PROTECT_2(r, temp); @@ -76,9 +76,13 @@ s48_value scx_enter_event(XEvent* e) { case KeymapNotify : { ECAST(q, XKeymapEvent); SETSIZE(1); - temp = s48_make_string(32, (char)0); - for (i=0; i < 32; i++) - S48_STRING_SET(temp, i, q->key_vector[i]); + temp = s48_make_vector(32*8, s48_enter_integer(0)); + for (i=0; i < 32; i++) { + int j; + char b = q->key_vector[i]; + for (j = 0; j < 8; j++) + S48_VECTOR_SET(temp, i*8 + j, (b & (1 << j)) ? 1 : 0); + } SET(sidx+0, temp); } break; @@ -281,7 +285,7 @@ s48_value scx_enter_event(XEvent* e) { default : temp = s48_enter_integer(q->format); //?? } - SET(sidx+1, temp); + SET(sidx+2, temp); } break; case MappingNotify : { @@ -301,21 +305,292 @@ s48_value scx_enter_event(XEvent* e) { // XAnyEvent entries { ECAST(q, XAnyEvent); - SET(0, s48_enter_integer(q->serial)); - SET(1, S48_ENTER_BOOLEAN(q->send_event)); - SET(2, SCX_ENTER_DISPLAY(q->display)); - SET(3, SCX_ENTER_WINDOW(q->window)); + SET(0, s48_enter_integer(q->type)); + SET(1, s48_enter_integer(q->serial)); + SET(2, S48_ENTER_BOOLEAN(q->send_event)); + SET(3, SCX_ENTER_DISPLAY(q->display)); + SET(4, SCX_ENTER_WINDOW(q->window)); } // more?? - // And the Event-Name - temp = s48_enter_integer(e->type); - r = s48_cons(temp, r); - S48_GC_UNPROTECT(); return r; } +#define REF(i) S48_VECTOR_REF(v, i) + +XEvent scx_extract_event(s48_value type, s48_value v) { + XEvent e; + + e.xany.type = s48_extract_integer(REF(0)); + e.xany.serial = s48_extract_integer(REF(1)); + e.xany.send_event = S48_EXTRACT_BOOLEAN(REF(2)); + e.xany.display = SCX_EXTRACT_DISPLAY(REF(3)); + + switch (s48_extract_integer(type)) { + case KeyPress: case KeyRelease: { + e.xkey.window = SCX_EXTRACT_WINDOW(REF(4)); + e.xkey.root = SCX_EXTRACT_WINDOW(REF(5)); + e.xkey.subwindow = SCX_EXTRACT_WINDOW(REF(6)); + e.xkey.time = SCX_EXTRACT_TIME(REF(7)); + e.xkey.x = s48_extract_integer(REF(8)); + e.xkey.y = s48_extract_integer(REF(9)); + e.xkey.x_root = s48_extract_integer(REF(10)); + e.xkey.y_root = s48_extract_integer(REF(11)); + e.xkey.state = s48_extract_integer(REF(12)); + e.xkey.keycode = s48_extract_integer(REF(13)); + e.xkey.same_screen = S48_EXTRACT_BOOLEAN(REF(14)); + } break; + case ButtonPress: case ButtonRelease: { + e.xbutton.window = SCX_EXTRACT_WINDOW(REF(4)); + e.xbutton.root = SCX_EXTRACT_WINDOW(REF(5)); + e.xbutton.subwindow = SCX_EXTRACT_WINDOW(REF(6)); + e.xbutton.time = SCX_EXTRACT_TIME(REF(7)); + e.xbutton.x = s48_extract_integer(REF(8)); + e.xbutton.y = s48_extract_integer(REF(9)); + e.xbutton.x_root = s48_extract_integer(REF(10)); + e.xbutton.y_root = s48_extract_integer(REF(11)); + e.xbutton.state = s48_extract_integer(REF(12)); + e.xbutton.button = s48_extract_integer(REF(13)); + e.xbutton.same_screen = S48_EXTRACT_BOOLEAN(REF(14)); + } break; + case MotionNotify: { + e.xmotion.window = SCX_EXTRACT_WINDOW(REF(4)); + e.xmotion.root = SCX_EXTRACT_WINDOW(REF(5)); + e.xmotion.subwindow = SCX_EXTRACT_WINDOW(REF(6)); + e.xmotion.time = SCX_EXTRACT_TIME(REF(7)); + e.xmotion.x = s48_extract_integer(REF(8)); + e.xmotion.y = s48_extract_integer(REF(9)); + e.xmotion.x_root = s48_extract_integer(REF(10)); + e.xmotion.y_root = s48_extract_integer(REF(11)); + e.xmotion.state = s48_extract_integer(REF(12)); + e.xmotion.is_hint = s48_extract_integer(REF(13)); + e.xmotion.same_screen = S48_EXTRACT_BOOLEAN(REF(14)); + } break; + case EnterNotify: case LeaveNotify: { + e.xcrossing.window = SCX_EXTRACT_WINDOW(REF(4)); + e.xcrossing.root = SCX_EXTRACT_WINDOW(REF(5)); + e.xcrossing.subwindow = SCX_EXTRACT_WINDOW(REF(6)); + e.xcrossing.time = SCX_EXTRACT_TIME(REF(7)); + e.xcrossing.x = s48_extract_integer(REF(8)); + e.xcrossing.y = s48_extract_integer(REF(9)); + e.xcrossing.x_root = s48_extract_integer(REF(10)); + e.xcrossing.y_root = s48_extract_integer(REF(11)); + e.xcrossing.mode = s48_extract_integer(REF(12)); + e.xcrossing.detail = s48_extract_integer(REF(13)); + e.xcrossing.same_screen = S48_EXTRACT_BOOLEAN(REF(14)); + e.xcrossing.focus = S48_EXTRACT_BOOLEAN(REF(15)); + e.xcrossing.state = s48_extract_integer(REF(16)); + } break; + case Expose: { + e.xexpose.window = SCX_EXTRACT_WINDOW(REF(4)); + e.xexpose.x = s48_extract_integer(REF(5)); + e.xexpose.y = s48_extract_integer(REF(6)); + e.xexpose.width = s48_extract_integer(REF(7)); + e.xexpose.height = s48_extract_integer(REF(8)); + e.xexpose.count = s48_extract_integer(REF(9)); + } break; + case GraphicsExpose: { + e.xgraphicsexpose.drawable = SCX_EXTRACT_WINDOW(REF(4)); + e.xgraphicsexpose.x = s48_extract_integer(REF(5)); + e.xgraphicsexpose.y = s48_extract_integer(REF(6)); + e.xgraphicsexpose.width = s48_extract_integer(REF(7)); + e.xgraphicsexpose.height = s48_extract_integer(REF(8)); + e.xgraphicsexpose.count = s48_extract_integer(REF(9)); + e.xgraphicsexpose.major_code = s48_extract_integer(REF(10)); + e.xgraphicsexpose.minor_code = s48_extract_integer(REF(11)); + } break; + case NoExpose: { + e.xnoexpose.drawable = SCX_EXTRACT_WINDOW(REF(4)); + e.xnoexpose.major_code = s48_extract_integer(REF(5)); + e.xnoexpose.minor_code = s48_extract_integer(REF(6)); + } break; + case VisibilityNotify: { + e.xvisibility.window = SCX_EXTRACT_WINDOW(REF(4)); + e.xvisibility.state = s48_extract_integer(REF(5)); + } break; + case CreateNotify: { + e.xcreatewindow.window = SCX_EXTRACT_WINDOW(REF(4)); + e.xcreatewindow.x = s48_extract_integer(REF(5)); + e.xcreatewindow.y = s48_extract_integer(REF(6)); + e.xcreatewindow.width = s48_extract_integer(REF(7)); + e.xcreatewindow.height = s48_extract_integer(REF(8)); + e.xcreatewindow.border_width = s48_extract_integer(REF(9)); + e.xcreatewindow.override_redirect = S48_EXTRACT_BOOLEAN(REF(10)); + } break; + case DestroyNotify: { + e.xdestroywindow.event = SCX_EXTRACT_WINDOW(REF(4)); + e.xdestroywindow.window = SCX_EXTRACT_WINDOW(REF(5)); + } break; + case UnmapNotify: { + e.xunmap.event = SCX_EXTRACT_WINDOW(REF(4)); + e.xunmap.window = SCX_EXTRACT_WINDOW(REF(5)); + e.xunmap.from_configure = S48_EXTRACT_BOOLEAN(REF(6)); + } break; + case MapNotify: { + e.xmap.event = SCX_EXTRACT_WINDOW(REF(4)); + e.xmap.window = SCX_EXTRACT_WINDOW(REF(5)); + e.xmap.override_redirect = S48_EXTRACT_BOOLEAN(REF(6)); + } break; + case MapRequest: { + e.xmaprequest.window = SCX_EXTRACT_WINDOW(REF(4)); + e.xmaprequest.parent = SCX_EXTRACT_WINDOW(REF(5)); + } break; + case ReparentNotify: { + e.xreparent.event = SCX_EXTRACT_WINDOW(REF(4)); + e.xreparent.window = SCX_EXTRACT_WINDOW(REF(5)); + e.xreparent.parent = SCX_EXTRACT_WINDOW(REF(6)); + e.xreparent.x = s48_extract_integer(REF(7)); + e.xreparent.y = s48_extract_integer(REF(8)); + e.xreparent.override_redirect = S48_EXTRACT_BOOLEAN(REF(9)); + } break; + case ConfigureNotify: { + e.xconfigure.event = SCX_EXTRACT_WINDOW(REF(4)); + e.xconfigure.window = SCX_EXTRACT_WINDOW(REF(5)); + e.xconfigure.x = s48_extract_integer(REF(6)); + e.xconfigure.y = s48_extract_integer(REF(7)); + e.xconfigure.width = s48_extract_integer(REF(8)); + e.xconfigure.height = s48_extract_integer(REF(9)); + e.xconfigure.border_width = s48_extract_integer(REF(10)); + e.xconfigure.above = SCX_EXTRACT_WINDOW(REF(11)); + e.xconfigure.override_redirect = S48_EXTRACT_BOOLEAN(REF(12)); + } break; + case GravityNotify: { + e.xgravity.event = SCX_EXTRACT_WINDOW(REF(4)); + e.xgravity.window = SCX_EXTRACT_WINDOW(REF(5)); + e.xgravity.x = s48_extract_integer(REF(6)); + e.xgravity.y = s48_extract_integer(REF(7)); + } break; + case ResizeRequest: { + e.xresizerequest.window = SCX_EXTRACT_WINDOW(REF(4)); + e.xresizerequest.width = s48_extract_integer(REF(5)); + e.xresizerequest.height = s48_extract_integer(REF(6)); + } break; + case ConfigureRequest: { + e.xconfigurerequest.parent = SCX_EXTRACT_WINDOW(REF(4)); + e.xconfigurerequest.window = SCX_EXTRACT_WINDOW(REF(5)); + { + XWindowChanges WC; + unsigned long mask = Changes_To_XWindowChanges(REF(6), &WC); + e.xconfigurerequest.x = WC.x; + e.xconfigurerequest.y = WC.y; + e.xconfigurerequest.width = WC.width; + e.xconfigurerequest.height = WC.height; + e.xconfigurerequest.border_width = WC.border_width; + e.xconfigurerequest.above = WC.sibling; + e.xconfigurerequest.detail = WC.stack_mode; + e.xconfigurerequest.value_mask = mask; + } + } break; + case CirculateNotify: { + e.xcirculate.event = SCX_EXTRACT_WINDOW(REF(4)); + e.xcirculate.window = SCX_EXTRACT_WINDOW(REF(5)); + e.xcirculate.place = s48_extract_integer(REF(6)); + } break; + case CirculateRequest: { + e.xcirculaterequest.parent = SCX_EXTRACT_WINDOW(REF(4)); + e.xcirculaterequest.window = SCX_EXTRACT_WINDOW(REF(5)); + e.xcirculaterequest.place = s48_extract_integer(REF(6)); + } break; + case PropertyNotify: { + e.xproperty.window = SCX_EXTRACT_WINDOW(REF(4)); + e.xproperty.atom = SCX_EXTRACT_ATOM(REF(5)); + e.xproperty.time = SCX_EXTRACT_TIME(REF(6)); + e.xproperty.state = s48_extract_integer(REF(7)); + } break; + case SelectionClear: { + e.xselectionclear.window = SCX_EXTRACT_WINDOW(REF(4)); + e.xselectionclear.selection = SCX_EXTRACT_ATOM(REF(5)); + e.xselectionclear.time = SCX_EXTRACT_TIME(REF(6)); + } break; + case SelectionRequest: { + e.xselectionrequest.owner = SCX_EXTRACT_WINDOW(REF(4)); + e.xselectionrequest.requestor = SCX_EXTRACT_WINDOW(REF(5)); + e.xselectionrequest.selection = SCX_EXTRACT_ATOM(REF(6)); + e.xselectionrequest.target = SCX_EXTRACT_ATOM(REF(7)); + e.xselectionrequest.property = SCX_EXTRACT_ATOM(REF(8)); + e.xselectionrequest.time = SCX_EXTRACT_TIME(REF(9)); + } break; + case SelectionNotify: { + e.xselection.requestor = SCX_EXTRACT_WINDOW(REF(4)); + e.xselection.selection = SCX_EXTRACT_ATOM(REF(5)); + e.xselection.target = SCX_EXTRACT_ATOM(REF(6)); + e.xselection.property = SCX_EXTRACT_ATOM(REF(7)); + e.xselection.time = SCX_EXTRACT_TIME(REF(8)); + } break; + case ColormapNotify: { + e.xcolormap.window = SCX_EXTRACT_WINDOW(REF(4)); + e.xcolormap.colormap = SCX_EXTRACT_COLORMAP(REF(5)); + e.xcolormap.new = S48_EXTRACT_BOOLEAN(REF(6)); + e.xcolormap.state = s48_extract_integer(REF(7)); + } break; + case ClientMessage: { + e.xclient.window = SCX_EXTRACT_WINDOW(REF(4)); + e.xclient.message_type = SCX_EXTRACT_ATOM(REF(5)); + e.xclient.format = s48_extract_integer(REF(6)); + { + s48_value data = REF(7); + int i; + for (i = 0; i < S48_VECTOR_LENGTH(data); i++) { + switch (e.xclient.format) { + case 8: + if (i < 20) + e.xclient.data.b[i] = + (char)s48_extract_integer(S48_VECTOR_REF(data, i)); + case 16: + if (i < 10) + e.xclient.data.s[i] = + (short)s48_extract_integer(S48_VECTOR_REF(data, i)); + case 32: + if (i < 5) + e.xclient.data.l[i] = + (long)s48_extract_integer(S48_VECTOR_REF(data, i)); + } + } + } + } break; + case MappingNotify: { + e.xmapping.window = SCX_EXTRACT_WINDOW(REF(4)); + e.xmapping.request = s48_extract_integer(REF(5)); + e.xmapping.first_keycode = s48_extract_integer(REF(6)); + e.xmapping.count = s48_extract_integer(REF(7)); + } break; + // Error Event... + case KeymapNotify: { + e.xkeymap.window = (Window)0; // not used. + { + s48_value bits = REF(4); + int j, bn; + char b; + for (bn = 0; bn < 32; bn++) { + b = 0; + for (j = 0; j < 8; j++) + b = b | ((char)S48_VECTOR_REF(bits, bn*8 + j) << j); + e.xkeymap.key_vector[bn] = b; + } + } + } break; + // default ?? + } // switch. + + return e; +} + +s48_value scx_Send_Event(s48_value Xdisplay, s48_value Xwindow, + s48_value propagate, + s48_value event_mask, s48_value vector, + s48_value type) { + XEvent e = scx_extract_event(type, vector); + + Status r = XSendEvent(SCX_EXTRACT_DISPLAY(Xdisplay), + SCX_EXTRACT_WINDOW(Xwindow), + S48_EXTRACT_BOOLEAN(propagate), + s48_extract_integer(event_mask), + &e); + return r ? S48_TRUE : S48_FALSE; +} + + s48_value scx_Next_Event(s48_value Xdisplay) { XEvent e; XNextEvent(SCX_EXTRACT_DISPLAY(Xdisplay), &e); @@ -369,6 +644,7 @@ s48_value scx_add_pending_channel (channel){ return S48_UNSPECIFIC; } void scx_init_event(void) { + S48_EXPORT_FUNCTION(scx_Send_Event); S48_EXPORT_FUNCTION(scx_Next_Event); S48_EXPORT_FUNCTION(scx_Peek_Event); S48_EXPORT_FUNCTION(scx_Events_Pending); diff --git a/c/xlib/property.c b/c/xlib/property.c index 32e92a5..18966b7 100644 --- a/c/xlib/property.c +++ b/c/xlib/property.c @@ -17,9 +17,10 @@ s48_value scx_Find_Atom (s48_value Xdisplay, s48_value name){ } s48_value scx_Atom_Name (s48_value Xdisplay, s48_value a) { - register char *s; + char* s; // not used: Disalbe_Interrupts - s = XGetAtomName (SCX_EXTRACT_DISPLAY(Xdisplay), a); + s = XGetAtomName (SCX_EXTRACT_DISPLAY(Xdisplay), + s48_extract_integer(a)); // not used: Enable_Interrupts return s48_enter_string (s); } diff --git a/c/xlib/window.c b/c/xlib/window.c index b1d4ac8..88786c8 100644 --- a/c/xlib/window.c +++ b/c/xlib/window.c @@ -141,12 +141,20 @@ s48_value Changes_To_XWindowChanges(s48_value changes, XWindowChanges* WC) { 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)); + if (mask & CWX) + WC->x = s48_extract_integer(S48_VECTOR_REF(v, 0)); + if (mask & CWY) + WC->y = s48_extract_integer(S48_VECTOR_REF(v, 1)); + if (mask & CWWidth) + WC->width = s48_extract_integer(S48_VECTOR_REF(v, 2)); + if (mask & CWHeight) + WC->height = s48_extract_integer(S48_VECTOR_REF(v, 3)); + if (mask & CWBorderWidth) + WC->height = s48_extract_integer(S48_VECTOR_REF(v, 4)); + if (mask & CWSibling) + WC->sibling = SCX_EXTRACT_WINDOW(S48_VECTOR_REF(v, 5)); + if (mask & CWStackMode) + WC->stack_mode = s48_extract_integer(S48_VECTOR_REF(v, 6)); return mask; } diff --git a/scheme/xlib/client.scm b/scheme/xlib/client.scm index b7418d5..2090edc 100644 --- a/scheme/xlib/client.scm +++ b/scheme/xlib/client.scm @@ -348,8 +348,8 @@ (else (lambda (x) x)))))) (define integer+vector->size-hint-alist - (make-vector->enum-alist - size-hints + (make-integer+vector->enum-alist + size-hints size-hint-index (lambda (v) (cond ((eq? v (size-hint win-gravity)) @@ -366,14 +366,13 @@ (define (get-wm-normal-hints window) (let* ((v (%wm-normal-hints (display-Xdisplay (window-display window)) (window-Xwindow window)))) - (filter (lambda (x) (not (null? (cdr x)))) - (integer+vector->size-hint-alist v)))) + (integer+vector->size-hint-alist v))) (import-lambda-definition %wm-normal-hints (Xdisplay Xwindow) "scx_Wm_Normal_Hints") (define (set-wm-normal-hints! window size-hint-alist) - (%set-wm-normal-hints! (display-Xdisplay (window-Xwindow window)) + (%set-wm-normal-hints! (display-Xdisplay (window-display window)) (window-Xwindow window) (size-hint-alist->integer+vector size-hint-alist))) diff --git a/scheme/xlib/display.scm b/scheme/xlib/display.scm index b6c6d44..8575a9c 100644 --- a/scheme/xlib/display.scm +++ b/scheme/xlib/display.scm @@ -30,47 +30,59 @@ (define (display-default-root-window display) (let* ((Xdisplay (display-Xdisplay display)) (Xwindow (%default-root-window Xdisplay))) - (make-window Xwindow (make-display Xdisplay #f) #f))) - -;; for compatibility with Elk. -(define display-root-window display-default-root-window) + (make-window Xwindow display #f))) (import-lambda-definition %default-root-window (Xdisplay) "scx_Display_Default_Root_Window") +;; display-root-window returns the root window of the specified screen. +;; See RootWindow. + +(define (display-root-window display screen-number) + (let* ((Xdisplay (display-Xdisplay display)) + (Xwindow (%root-window Xdisplay screen-number))) + (make-window Xwindow display #f))) + +(import-lambda-definition %root-window (Xdisplay scr_num) + "scx_Display_Root_Window") + ;; display-default-colormap return the default colormap for allocation on the ;; default screen of the specified display. See DefaultColormap. -(define (display-default-colormap display) +(define (display-default-colormap display . maybe-screen-number) (let* ((Xdisplay (display-Xdisplay display)) - (Xcolormap (%default-colormap Xdisplay))) + (scr (get-maybe-screen-number display maybe-screen-number)) + (Xcolormap (%default-colormap Xdisplay + scr))) (make-colormap Xcolormap display #f))) ;; for compatibility with Elk. (define display-colormap display-default-colormap) -(import-lambda-definition %default-colormap (Xdisplay) +(import-lambda-definition %default-colormap (Xdisplay scr) "scx_Display_Default_Colormap") ;; display-default-gcontext return the default graphics context for the root ;; window of the default screen of the specified display. See DefaultGC. -(define (display-default-gcontext display) +(define (display-default-gcontext display . maybe-screen-number) (let* ((Xdisplay (display-Xdisplay display)) - (Xgcontext (%default-gcontext Xdisplay))) + (scr (get-maybe-screen-number display maybe-screen-number)) + (Xgcontext (%default-gcontext Xdisplay scr))) (make-gcontext Xgcontext display #f))) -(import-lambda-definition %default-gcontext (Xdisplay) +(import-lambda-definition %default-gcontext (Xdisplay scr) "scx_Display_Default_Gcontext") ;; display-default-depth returns the depth (number of planes) of the default ;; root window of the default screen of the specified display. See DefaultDepth. -(define (display-default-depth display) - (let ((Xdisplay (display-Xdisplay display))) - (%default-depth Xdisplay))) +(define (display-default-depth display . maybe-screen-number) + (let ((Xdisplay (display-Xdisplay display)) + (scr (get-maybe-screen-number display maybe-screen-number))) + (%default-depth Xdisplay scr))) -(import-lambda-definition %default-depth (Xdisplay) +(import-lambda-definition %default-depth (Xdisplay scr) "scx_Display_Default_Depth") ;; display-default-screen-number returns the default screen number of the given @@ -90,16 +102,19 @@ (define (display-default-visual display . screen-number) (make-visual (%default-visual (display-Xdisplay display) - (if (null? screen-number) - (display-default-screen-number display) - (begin - (check-screen-number display (car screen-number)) - (car screen-number)))))) + (get-maybe-screen-number display screen-number)))) (import-lambda-definition %default-visual (Xdisplay scr-num) "scx_Display_Default_Visual") ;; internal function +(define (get-maybe-screen-number dpy maybe-screen-number) + (if (null? maybe-screen-number) + (display-default-screen-number dpy) + (begin + (check-screen-number dpy (car maybe-screen-number)) + (car maybe-screen-number)))) + (define (check-screen-number display screen-number) (if (or (< screen-number 0) (>= screen-number (display-screen-count display))) @@ -108,9 +123,9 @@ ;; display-cells returns the number of entries in the default colormap of the ;; specified screen. See DisplayCells. -(define (display-cells display screen-number) - (check-screen-number display screen-number) - (%display-cells (display-Xdisplay display) screen-number)) +(define (display-cells display . maybe-screen-number) + (%display-cells (display-Xdisplay display) + (get-maybe-screen-number display maybe-screen-number))) (import-lambda-definition %display-cells (Xdisplay screen-number) "scx_Display_Cells") @@ -118,9 +133,9 @@ ;; display-planes returns the depth of the root window of the specified screen. ;; See DisplayPlanes. -(define (display-planes display screen-number) - (check-screen-number display screen-number) - (%display-planes (display-Xdisplay display) screen-number)) +(define (display-planes display . maybe-screen-number) + (%display-planes (display-Xdisplay display) + (get-maybe-screen-number display maybe-screen-number))) (import-lambda-definition %display-planes (Xdisplay screen-number) "scx_Display_Planes") @@ -200,31 +215,35 @@ ;; display-width (-height) returns the width (height) of the screen in pixels. ;; See DisplayWidth (DisplayHeight). -(define (display-width display) - (%display-width (display-Xdisplay display))) +(define (display-width display . maybe-screen-number) + (%display-width (display-Xdisplay display) + (get-maybe-screen-number display maybe-screen-number))) -(import-lambda-definition %display-width (Xdisplay) +(import-lambda-definition %display-width (Xdisplay scr) "scx_Display_Width") -(define (display-height display) - (%display-height (display-Xdisplay display))) +(define (display-height display . maybe-screen-number) + (%display-height (display-Xdisplay display) + (get-maybe-screen-number display maybe-screen-number))) -(import-lambda-definition %display-height (Xdisplay) +(import-lambda-definition %display-height (Xdisplay scr) "scx_Display_Height") ;; display-width-mm (-height-mm) returns the width (height) of the screen in ;; millimeters. See DisplayWidthMM (DisplayHeightMM). -(define (display-width-mm display) - (%display-width-mm (display-Xdisplay display))) +(define (display-width-mm display . maybe-screen-number) + (%display-width-mm (display-Xdisplay display) + (get-maybe-screen-number display maybe-screen-number))) -(import-lambda-definition %display-width-mm (Xdisplay) +(import-lambda-definition %display-width-mm (Xdisplay scr) "scx_Display_Width_Mm") -(define (display-height-mm display) - (%display-height-mm (display-Xdisplay display))) +(define (display-height-mm display . maybe-screen-number) + (%display-height-mm (display-Xdisplay display) + (get-maybe-screen-number display maybe-screen-number))) -(import-lambda-definition %display-height-mm (Xdisplay) +(import-lambda-definition %display-height-mm (Xdisplay scr) "scx_Display_Height_Mm") ;; See XDisplayMotionBufferSize. diff --git a/scheme/xlib/event-types.scm b/scheme/xlib/event-types.scm index 8d392e9..b2bd92a 100644 --- a/scheme/xlib/event-types.scm +++ b/scheme/xlib/event-types.scm @@ -18,6 +18,9 @@ (define (integer->event-type i) (vector-ref event-types i)) +(define (event-type->integer e) + (event-type-index e)) + ;; ******************************************************************* (define (any-event-type event) @@ -46,17 +49,196 @@ ((circulate-request-event? event) circulate-request-event-type) ((property-event? event) property-event-type) ((selection-clear-event? event) selection-clear-event-type) + ((selection-request-event? event) selection-request-event-type) + ((selection-event? event) selection-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 (any-event-serial event) + (let ((f + (cond + ((key-event? event) key-event-serial) + ((button-event? event) button-event-serial) + ((motion-event? event) motion-event-serial) + ((crossing-event? event) crossing-event-serial) + ((focus-change-event? event) focus-change-event-serial) + ((expose-event? event) expose-event-serial) + ((graphics-expose-event? event) graphics-expose-event-serial) + ((no-expose-event? event) no-expose-event-serial) + ((visibility-event? event) visibility-event-serial) + ((create-window-event? event) create-window-event-serial) + ((destroy-window-event? event) destroy-window-event-serial) + ((unmap-event? event) unmap-event-serial) + ((map-event? event) map-event-serial) + ((map-request-event? event) map-request-event-serial) + ((reparent-event? event) reparent-event-serial) + ((configure-event? event) configure-event-serial) + ((gravity-event? event) gravity-event-serial) + ((resize-request-event? event) resize-request-event-serial) + ((configure-request-event? event) configure-request-event-serial) + ((circulate-event? event) circulate-event-serial) + ((circulate-request-event? event) circulate-request-event-serial) + ((property-event? event) property-event-serial) + ((selection-clear-event? event) selection-clear-event-serial) + ((selection-request-event? event) selection-request-event-serial) + ((selection-event? event) selection-event-serial) + ((colormap-event? event) colormap-event-serial) + ((client-message-event? event) client-message-event-serial) + ((mapping-event? event) mapping-event-serial) + ((keymap-event? event) keymap-event-serial)))) + (f event))) + +(define (any-event-send-event? event) + (let ((f + (cond + ((key-event? event) key-event-send-event?) + ((button-event? event) button-event-send-event?) + ((motion-event? event) motion-event-send-event?) + ((crossing-event? event) crossing-event-send-event?) + ((focus-change-event? event) focus-change-event-send-event?) + ((expose-event? event) expose-event-send-event?) + ((graphics-expose-event? event) graphics-expose-event-send-event?) + ((no-expose-event? event) no-expose-event-send-event?) + ((visibility-event? event) visibility-event-send-event?) + ((create-window-event? event) create-window-event-send-event?) + ((destroy-window-event? event) destroy-window-event-send-event?) + ((unmap-event? event) unmap-event-send-event?) + ((map-event? event) map-event-send-event?) + ((map-request-event? event) map-request-event-send-event?) + ((reparent-event? event) reparent-event-send-event?) + ((configure-event? event) configure-event-send-event?) + ((gravity-event? event) gravity-event-send-event?) + ((resize-request-event? event) resize-request-event-send-event?) + ((configure-request-event? event) + configure-request-event-send-event?) + ((circulate-event? event) circulate-event-send-event?) + ((circulate-request-event? event) + circulate-request-event-send-event?) + ((property-event? event) property-event-send-event?) + ((selection-clear-event? event) selection-clear-event-send-event?) + ((selection-request-event? event) selection-request-event-send-event?) + ((selection-event? event) selection-event-send-event?) + ((colormap-event? event) colormap-event-send-event?) + ((client-message-event? event) client-message-event-send-event?) + ((mapping-event? event) mapping-event-send-event?) + ((keymap-event? event) keymap-event-send-event?)))) + (f event))) + +(define (any-event-display event) + (let ((f + (cond + ((key-event? event) key-event-display) + ((button-event? event) button-event-display) + ((motion-event? event) motion-event-display) + ((crossing-event? event) crossing-event-display) + ((focus-change-event? event) focus-change-event-display) + ((expose-event? event) expose-event-display) + ((graphics-expose-event? event) graphics-expose-event-display) + ((no-expose-event? event) no-expose-event-display) + ((visibility-event? event) visibility-event-display) + ((create-window-event? event) create-window-event-display) + ((destroy-window-event? event) destroy-window-event-display) + ((unmap-event? event) unmap-event-display) + ((map-event? event) map-event-display) + ((map-request-event? event) map-request-event-display) + ((reparent-event? event) reparent-event-display) + ((configure-event? event) configure-event-display) + ((gravity-event? event) gravity-event-display) + ((resize-request-event? event) resize-request-event-display) + ((configure-request-event? event) configure-request-event-display) + ((circulate-event? event) circulate-event-display) + ((circulate-request-event? event) circulate-request-event-display) + ((property-event? event) property-event-display) + ((selection-clear-event? event) selection-clear-event-display) + ((selection-request-event? event) selection-request-event-display) + ((selection-event? event) selection-event-display) + ((colormap-event? event) colormap-event-display) + ((client-message-event? event) client-message-event-display) + ((mapping-event? event) mapping-event-display) + ((keymap-event? event) keymap-event-display)))) + (f event))) + +;; any-event-window does not return the window-element of some event, +;; but the first element that is a window - that is always the 5th +;; element. So it behaves like (XAnyEvent)e->window in C. + +(define (any-event-window event) + (let ((f + (cond + ((key-event? event) key-event-window) + ((button-event? event) button-event-window) + ((motion-event? event) motion-event-window) + ((crossing-event? event) crossing-event-window) + ((focus-change-event? event) focus-change-event-window) + ((expose-event? event) expose-event-window) + ((visibility-event? event) visibility-event-window) + ((create-window-event? event) create-window-event-parent) + ((destroy-window-event? event) destroy-window-event-event) + ((unmap-event? event) unmap-event-event) + ((map-event? event) map-event-event) + ((map-request-event? event) map-request-event-parent) + ((reparent-event? event) reparent-event-event) + ((configure-event? event) configure-event-event) + ((gravity-event? event) gravity-event-event) + ((resize-request-event? event) resize-request-event-window) + ((configure-request-event? event) configure-request-event-parent) + ((circulate-event? event) circulate-event-event) + ((circulate-request-event? event) circulate-request-event-parent) + ((property-event? event) property-event-window) + ((selection-clear-event? event) selection-clear-event-window) + ((selection-request-event? event) selection-request-event-owner) + ((selection-event? event) selection-event-requestor) + ((colormap-event? event) colormap-event-window) + ((client-message-event? event) client-message-event-window) + ((mapping-event? event) mapping-event-window) + ; exceptions: + ((no-expose-event? event) no-expose-event-drawable) + ((graphics-expose-event? event) graphics-expose-event-drawable) + ; keymap-event + (else (lambda (x) #f))))) + (f event))) + +(define (any-event->vector event) + (let ((f + (cond + ((key-event? event) key-event->vector) + ((button-event? event) button-event->vector) + ((motion-event? event) motion-event->vector) + ((crossing-event? event) crossing-event->vector) + ((focus-change-event? event) focus-change-event->vector) + ((expose-event? event) expose-event->vector) + ((graphics-expose-event? event) graphics-expose-event->vector) + ((no-expose-event? event) no-expose-event->vector) + ((visibility-event? event) visibility-event->vector) + ((create-window-event? event) create-window-event->vector) + ((destroy-window-event? event) destroy-window-event->vector) + ((unmap-event? event) unmap-event->vector) + ((map-event? event) map-event->vector) + ((map-request-event? event) map-request-event->vector) + ((reparent-event? event) reparent-event->vector) + ((configure-event? event) configure-event->vector) + ((gravity-event? event) gravity-event->vector) + ((resize-request-event? event) resize-request-event->vector) + ((configure-request-event? event) configure-request-event->vector) + ((circulate-event? event) circulate-event->vector) + ((circulate-request-event? event) circulate-request-event->vector) + ((property-event? event) property-event->vector) + ((selection-clear-event? event) selection-clear-event->vector) + ((selection-request-event? event) selection-request-event->vector) + ((selection-event? event) selection-event->vector) + ((colormap-event? event) colormap-event->vector) + ((client-message-event? event) client-message-event->vector) + ((mapping-event? event) mapping-event->vector) + ((keymap-event? event) keymap-event->vector)))) + (f event))) + ;; ******************************************************************* (define-record-type key-event :key-event - (really-make-key-event type serial send-event? display window root subwindow + (create-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) @@ -75,18 +257,10 @@ (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 + (create-key-event type serial send-event? display (make-window window display #f) (make-window root display #f) @@ -95,10 +269,27 @@ (integer->state-set state) keycode same-screen?))) +(define (key-event->vector e) + (list->vector (list (event-type->integer (key-event-type e)) + (key-event-serial e) + (key-event-send-event? e) + (display-Xdisplay (key-event-display e)) + (window-Xwindow (key-event-window e)) + (window-Xwindow (key-event-root e)) + (window-Xwindow (key-event-subwindow e)) + (key-event-time e) + (key-event-x e) + (key-event-y e) + (key-event-x-root e) + (key-event-y-root e) + (state-set->integer (key-event-state e)) + (key-event-keycode e) + (key-event-same-screen? e)))) + ;; ******************************************************************* (define-record-type button-event :button-event - (really-make-button-event type serial send-event? display window root + (create-button-event type serial send-event? display window root subwindow time x y x-root y-root state button same-screen?) button-event? @@ -118,19 +309,11 @@ (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 + (create-button-event type serial send-event? display (make-window window display #f) (make-window root display #f) @@ -140,10 +323,27 @@ (integer->button button) same-screen?))) +(define (button-event->vector e) + (list->vector (list (event-type->integer (button-event-type e)) + (button-event-serial e) + (button-event-send-event? e) + (display-Xdisplay (button-event-display e)) + (window-Xwindow (button-event-window e)) + (window-Xwindow (button-event-root e)) + (window-Xwindow (button-event-subwindow e)) + (button-event-time e) + (button-event-x e) + (button-event-y e) + (button-event-x-root e) + (button-event-y-root e) + (state-set->integer (button-event-state e)) + (button->integer (button-event-button e)) + (button-event-same-screen? e)))) + ;; ******************************************************************* (define-record-type motion-event :motion-event - (really-make-motion-event type serial send-event? display window root + (create-motion-event type serial send-event? display window root subwindow time x y x-root y-root state is-hint? same-screen?) motion-event? @@ -167,7 +367,7 @@ subwindow time x y x-root y-root state is-hint? same-screen?) (let ((display (make-display display #f))) - (really-make-button-event + (create-button-event type serial send-event? display (make-window window display #f) (make-window root display #f) @@ -177,10 +377,27 @@ (integer->is-hint? is-hint?) ;; subset of Notify Mode same-screen?))) +(define (motion-event->vector e) + (list->vector (list (event-type->integer (motion-event-type e)) + (motion-event-serial e) + (motion-event-send-event? e) + (display-Xdisplay (motion-event-display e)) + (window-Xwindow (motion-event-window e)) + (window-Xwindow (motion-event-root e)) + (window-Xwindow (motion-event-subwindow e)) + (motion-event-time e) + (motion-event-x e) + (motion-event-y e) + (motion-event-x-root e) + (motion-event-y-root e) + (state-set->integer (motion-event-state e)) + (is-hint?->integer (motion-event-is-hint? e)) + (motion-event-same-screen? e)))) + ;; ******************************************************************* (define-record-type crossing-event :crossing-event - (really-make-crossing-event type serial send-event? display window root + (create-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? @@ -202,19 +419,11 @@ (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 + (create-crossing-event type serial send-event? display (make-window window display #f) (make-window root display #f) @@ -225,10 +434,29 @@ same-screen? focus? (integer->state-set state)))) ;; Elk treats state a button ?! +(define (crossing-event->vector e) + (list->vector (list (event-type->integer (crossing-event-type e)) + (crossing-event-serial e) + (crossing-event-send-event? e) + (display-Xdisplay (crossing-event-display e)) + (window-Xwindow (crossing-event-window e)) + (window-Xwindow (crossing-event-root e)) + (window-Xwindow (crossing-event-subwindow e)) + (crossing-event-time e) + (crossing-event-x e) + (crossing-event-y e) + (crossing-event-x-root e) + (crossing-event-y-root e) + (notify-mode->integer (crossing-event-mode e)) + (notify-detail->integer (crossing-event-detail e)) + (crossing-event-same-screen? e) + (crossing-event-focus? e) + (state-set->integer (crossing-event-state e))))) + ;; ******************************************************************* (define-record-type focus-change-event :focus-change-event - (really-make-focus-change-event type serial send-event? display window mode + (create-focus-change-event type serial send-event? display window mode detail) focus-change-event? (type focus-change-event-type) @@ -239,27 +467,28 @@ (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 + (create-focus-change-event type serial send-event? display (make-window window display #f) (integer->notify-mode mode) (integer->notify-detail detail)))) +(define (focus-change-event->vector e) + (list->vector (list (event-type->integer (focus-change-event-type e)) + (focus-change-event-serial e) + (focus-change-event-send-event? e) + (display-Xdisplay (focus-change-event-display e)) + (window-Xwindow (focus-change-event-window e)) + (notify-mode->integer (focus-change-event-mode e)) + (notify-detail->integer (focus-change-event-detail e))))) + ;; ******************************************************************* (define-record-type expose-event :expose-event - (really-make-expose-event type serial send-event? display window x y width + (create-expose-event type serial send-event? display window x y width height count) expose-event? (type expose-event-type) @@ -276,15 +505,28 @@ (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 + (create-expose-event type serial send-event? display (make-window window display #f) x y width height count))) +(define (expose-event->vector e) + (list->vector (list (event-type->integer (expose-event-type e)) + (expose-event-serial e) + (expose-event-send-event? e) + (display-Xdisplay (expose-event-display e)) + (window-Xwindow (expose-event-window e)) + (expose-event-x e) + (expose-event-y e) + (expose-event-width e) + (expose-event-height e) + (expose-event-count e)))) + + ;; ******************************************************************* (define-record-type graphics-expose-event :graphics-expose-event - (really-make-graphics-expose-event type serial send-event? display drawable + (create-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) @@ -303,15 +545,28 @@ x y width height count major-code minor-code) (let ((display (make-display display #f))) - (really-make-graphics-expose-event + (create-graphics-expose-event type serial send-event? display (make-drawable drawable display) x y width height count major-code minor-code))) +(define (graphics-expose-event->vector e) + (list->vector (list (event-type->integer (graphics-expose-event-type e)) + (graphics-expose-event-serial e) + (graphics-expose-event-send-event? e) + (display-Xdisplay (graphics-expose-event-display e)) + (drawable-Xobject (graphics-expose-event-drawable e)) + (graphics-expose-event-x e) + (graphics-expose-event-y e) + (graphics-expose-event-width e) + (graphics-expose-event-height e) + (graphics-expose-event-major-code e) + (graphics-expose-event-minor-code e)))) + ;; ******************************************************************* (define-record-type no-expose-event :no-expose-event - (really-make-no-expose-event type serial send-event? display drawable + (create-no-expose-event type serial send-event? display drawable major-code minor-code) no-expose-event? (type no-expose-event-type) @@ -325,15 +580,24 @@ (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 + (create-no-expose-event type serial send-event? display (make-drawable drawable display) major-code minor-code))) +(define (no-expose-event->vector e) + (list->vector (list (event-type->integer (no-expose-event-type e)) + (no-expose-event-serial e) + (no-expose-event-send-event? e) + (display-Xdisplay (no-expose-event-display e)) + (drawable-Xobject (no-expose-event-drawable e)) + (no-expose-event-major-code e) + (no-expose-event-minor-code e)))) + ;; ******************************************************************* (define-record-type visibility-event :visibility-event - (really-make-visibility-event type serial send-event? display window state) + (create-visibility-event type serial send-event? display window state) visibility-event? (type visibility-event-type) (serial visibility-event-serial) @@ -344,15 +608,23 @@ (define (make-visibility-event type serial send-event? display window state) (let ((display (make-display display #f))) - (really-make-visibility-event + (create-visibility-event type serial send-event? display (make-window window display #f) (integer->visibility-state state)))) +(define (visibility-event->vector e) + (list->vector (list (event-type->integer (visibility-event-type e)) + (visibility-event-serial e) + (visibility-event-send-event? e) + (display-Xdisplay (visibility-event-display e)) + (window-Xwindow (visibility-event-window e)) + (visibility-state->integer (visibility-event-state e))))) + ;; ******************************************************************* (define-record-type create-window-event :create-window-event - (really-make-create-window-event type serial send-event? display parent + (create-create-window-event type serial send-event? display parent window x y width height border-width override-redirect?) create-window-event? @@ -373,16 +645,30 @@ window x y width height border-width override-redirect?) (let ((display (make-display display #f))) - (really-make-create-window-event + (create-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 (create-window-event->vector e) + (list->vector (list (event-type->integer (create-window-event-type e)) + (create-window-event-serial e) + (create-window-event-send-event? e) + (display-Xdisplay (create-window-event-display e)) + (window-Xwindow (create-window-event-parent e)) + (window-Xwindow (create-window-event-window e)) + (create-window-event-x e) + (create-window-event-y e) + (create-window-event-width e) + (create-window-event-height e) + (create-window-event-border-width e) + (create-window-event-override-redirect? e)))) + ;; ******************************************************************* (define-record-type destroy-window-event :destroy-window-event - (really-make-destroy-window-event type serial send-event? display event + (create-destroy-window-event type serial send-event? display event window) destroy-window-event? (type destroy-window-event-type) @@ -395,15 +681,23 @@ (define (make-destroy-window-event type serial send-event? display event window) (let ((display (make-display display #f))) - (really-make-destroy-window-event + (create-destroy-window-event type serial send-event? display (make-window event display #f) (make-window window display #f)))) +(define (destroy-window-event->vector e) + (list->vector (list (event-type->integer (destroy-window-event-type e)) + (destroy-window-event-serial e) + (destroy-window-event-send-event? e) + (display-Xdisplay (destroy-window-event-display e)) + (window-Xwindow (destroy-window-event-event e)) + (window-Xwindow (destroy-window-event-window e))))) + ;; ******************************************************************* (define-record-type unmap-event :unmap-event - (really-make-unmap-event type serial send-event? display event window + (create-unmap-event type serial send-event? display event window from-configure?) unmap-event? (type unmap-event-type) @@ -417,16 +711,25 @@ (define (make-unmap-event type serial send-event? display event window from-configure?) (let ((display (make-display display #f))) - (really-make-unmap-event + (create-unmap-event type serial send-event? display (make-window event display #f) (make-window window display #f) from-configure?))) +(define (unmap-event->vector e) + (list->vector (list (event-type->integer (unmap-event-type e)) + (unmap-event-serial e) + (unmap-event-send-event? e) + (display-Xdisplay (unmap-event-display e)) + (window-Xwindow (unmap-event-event e)) + (window-Xwindow (unmap-event-window e)) + (unmap-event-from-configure? e)))) + ;; ******************************************************************* (define-record-type map-event :map-event - (really-make-map-event type serial send-event? display event window + (create-map-event type serial send-event? display event window override-redirect?) map-event? (type map-event-type) @@ -438,18 +741,27 @@ (override-redirect? map-event-override-redirect?)) (define (make-map-event type serial send-event? display event window - from-configure?) + override-redirect?) (let ((display (make-display display #f))) - (really-make-map-event + (create-map-event type serial send-event? display (make-window event display #f) (make-window window display #f) - from-configure?))) + override-redirect?))) + +(define (map-event->vector e) + (list->vector (list (event-type->integer (map-event-type e)) + (map-event-serial e) + (map-event-send-event? e) + (display-Xdisplay (map-event-display e)) + (window-Xwindow (map-event-event e)) + (window-Xwindow (map-event-window e)) + (map-event-override-redirect? e)))) ;; ******************************************************************* (define-record-type map-request-event :map-request-event - (really-make-map-request-event type serial send-event? display parent window) + (create-map-request-event type serial send-event? display parent window) map-request-event? (type map-request-event-type) (serial map-request-event-serial) @@ -460,15 +772,23 @@ (define (make-map-request-event type serial send-event? display parent window) (let ((display (make-display display #f))) - (really-make-map-request-event + (create-map-request-event type serial send-event? display (make-window parent display #f) (make-window window display #f)))) +(define (map-request-event->vector e) + (list->vector (list (event-type->integer (map-request-event-type e)) + (map-request-event-serial e) + (map-request-event-send-event? e) + (display-Xdisplay (map-request-event-display e)) + (window-Xwindow (map-request-event-parent e)) + (window-Xwindow (map-request-event-window e))))) + ;; ******************************************************************* (define-record-type reparent-event :reparent-event - (really-make-reparent-event type serial send-event? display event window + (create-reparent-event type serial send-event? display event window parent x y override-redirect?) reparent-event? (type reparent-event-type) @@ -485,17 +805,29 @@ (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 + (create-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 (reparent-event->vector e) + (list->vector (list (event-type->integer (reparent-event-type e)) + (reparent-event-serial e) + (reparent-event-send-event? e) + (display-Xdisplay (reparent-event-display e)) + (window-Xwindow (reparent-event-event e)) + (window-Xwindow (reparent-event-window e)) + (window-Xwindow (reparent-event-parent e)) + (reparent-event-x e) + (reparent-event-y e) + (reparent-event-override-redirect? e)))) + ;; ******************************************************************* (define-record-type configure-event :configure-event - (really-make-configure-event type serial send-event? display event window + (create-configure-event type serial send-event? display event window x y width height border-width above override-redirect?) configure-event? @@ -517,7 +849,7 @@ x y width height border-width above override-redirect?) (let ((display (make-display display #f))) - (really-make-configure-event + (create-configure-event type serial send-event? display (make-window event display #f) (make-window window display #f) @@ -525,10 +857,25 @@ (make-window above display #f) override-redirect?))) +(define (configure-event->vector e) + (list->vector (list (event-type->integer (configure-event-type e)) + (configure-event-serial e) + (configure-event-send-event? e) + (display-Xdisplay (configure-event-display e)) + (window-Xwindow (configure-event-event e)) + (window-Xwindow (configure-event-window e)) + (configure-event-x e) + (configure-event-y e) + (configure-event-width e) + (configure-event-height e) + (configure-event-border-width e) + (window-Xwindow (configure-event-above e)) + (configure-event-override-redirect? e)))) + ;; ******************************************************************* (define-record-type gravity-event :gravity-event - (really-make-gravity-event type serial send-event? display event window x y) + (create-gravity-event type serial send-event? display event window x y) gravity-event? (type gravity-event-type) (serial gravity-event-serial) @@ -541,16 +888,26 @@ (define (make-gravity-event type serial send-event? display event window x y) (let ((display (make-display display #f))) - (really-make-gravity-event + (create-gravity-event type serial send-event? display (make-window event display #f) (make-window window display #f) x y))) +(define (gravity-event->vector e) + (list->vector (list (event-type->integer (gravity-event-type e)) + (gravity-event-serial e) + (gravity-event-send-event? e) + (display-Xdisplay (gravity-event-display e)) + (window-Xwindow (gravity-event-event e)) + (window-Xwindow (gravity-event-window e)) + (gravity-event-x e) + (gravity-event-y e)))) + ;; ******************************************************************* (define-record-type resize-request-event :resize-request-event - (really-make-resize-request-event type serial send-event? display window + (create-resize-request-event type serial send-event? display window width height) resize-request-event? (type resize-request-event-type) @@ -564,16 +921,25 @@ (define (make-resize-request-event type serial send-event? display window width height) (let ((display (make-display display #f))) - (really-make-resize-request-event + (create-resize-request-event type serial send-event? display (make-window window display #f) width height))) +(define (resize-request-event->vector e) + (list->vector (list (event-type->integer (resize-request-event-type e)) + (resize-request-event-serial e) + (resize-request-event-send-event? e) + (display-Xdisplay (resize-request-event-display e)) + (window-Xwindow (resize-request-event-window e)) + (resize-request-event-width e) + (resize-request-event-height e)))) + ;; ******************************************************************* (define-record-type configure-request-event :configure-request-event - (really-make-configure-request-event type serial send-event? display parent - window window-changes-alist) + (create-configure-request-event type serial send-event? display parent + window window-change-alist) configure-request-event? (type configure-request-event-type) (serial configure-request-event-serial) @@ -581,24 +947,38 @@ (display configure-request-event-display) (parent configure-request-event-parent) (window configure-request-event-window) - (window-changes-alist configure-request-event-window-changes-alist)) + (window-change-alist configure-request-event-window-change-alist)) -(define (make-configure-request-event type serial send-event? display window - x y width height border-width above - detail value-mask) +(define (make-configure-request-event type serial send-event? display parent + window x y width height border-width + above detail value-mask) (let ((display (make-display display #f))) - (really-make-configure-request-event + (create-configure-request-event type serial send-event? display + (make-window parent display #f) (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 (configure-request-event->vector e) + (list->vector (append + (list (event-type->integer (configure-request-event-type e)) + (configure-request-event-serial e) + (configure-request-event-send-event? e) + (display-Xdisplay (configure-request-event-display e)) + (window-Xwindow (configure-request-event-parent e)) + (window-Xwindow (configure-request-event-window e))) + (let ((i+v (window-change-alist->integer+vector + (configure-request-event-window-change-alist e)))) + (append (vector->list (cdr i+v)) + (list (car i+v))))))) + ;; ******************************************************************* (define-record-type circulate-event :circulate-event - (really-make-circulate-event type serial send-event? display event window + (create-circulate-event type serial send-event? display event window place) circulate-event? (type circulate-event-type) @@ -612,16 +992,25 @@ (define (make-circulate-event type serial send-event? display event window place) (let ((display (make-display display #f))) - (really-make-circulate-event + (create-circulate-event type serial send-event? display (make-window event display #f) (make-window window display #f) (integer->place place)))) +(define (circulate-event->vector e) + (list->vector (list (event-type->integer (circulate-event-type e)) + (circulate-event-serial e) + (circulate-event-send-event? e) + (display-Xdisplay (circulate-event-display e)) + (window-Xwindow (circulate-event-event e)) + (window-Xwindow (circulate-event-window e)) + (place->integer (circulate-event-place e))))) + ;; ******************************************************************* (define-record-type circulate-request-event :circulate-request-event - (really-make-circulate-request-event type serial send-event? display parent + (create-circulate-request-event type serial send-event? display parent window place) circulate-request-event? (type circulate-request-event-type) @@ -635,16 +1024,25 @@ (define (make-circulate-request-event type serial send-event? display parent window place) (let ((display (make-display display #f))) - (really-make-circulate-request-event + (create-circulate-request-event type serial send-event? display (make-window parent display #f) (make-window window display #f) (integer->place place)))) +(define (circulate-request-event->vector e) + (list->vector (list (event-type->integer (circulate-request-event-type e)) + (circulate-request-event-serial e) + (circulate-request-event-send-event? e) + (display-Xdisplay (circulate-request-event-display e)) + (window-Xwindow (circulate-request-event-parent e)) + (window-Xwindow (circulate-request-event-window e)) + (place->integer (circulate-request-event-place e))))) + ;; ******************************************************************* (define-record-type property-event :property-event - (really-make-property-event type serial send-event? display window atom time + (create-property-event type serial send-event? display window atom time state) property-event? (type property-event-type) @@ -659,17 +1057,27 @@ (define (make-property-event type serial send-event? display window atom time state) (let ((display (make-display display #f))) - (really-make-property-event + (create-property-event type serial send-event? display (make-window window display #f) (make-atom atom) time (integer->property-state state)))) +(define (property-event->vector e) + (list->vector (list (event-type->integer (property-event-type e)) + (property-event-serial e) + (property-event-send-event? e) + (display-Xdisplay (property-event-display e)) + (window-Xwindow (property-event-window e)) + (atom-Xatom (property-event-atom e)) + (property-event-time e) + (property-state->integer (property-event-state))))) + ;; ******************************************************************* (define-record-type selection-clear-event :selection-clear-event - (really-make-selection-clear-event type serial send-event? display window + (create-selection-clear-event type serial send-event? display window selection time) selection-clear-event? (type selection-clear-event-type) @@ -683,17 +1091,27 @@ (define (make-selection-clear-event type serial send-event? display window selection time) (let ((display (make-display display #f))) - (really-make-selection-clear-event + (create-selection-clear-event type serial send-event? display (make-window window display #f) (make-atom selection) time))) +(define (selection-clear-event->vector e) + (list->vector (list (event-type->integer (selection-clear-event-type e)) + (selection-clear-event-serial e) + (selection-clear-event-send-event? e) + (display-Xdisplay (selection-clear-event-display e)) + (window-Xwindow (selection-clear-event-window e)) + (atom-Xatom (selection-clear-event-selection e)) + (selection-clear-event-time e)))) + ;; ******************************************************************* (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) + (create-selection-request-event type serial send-event? display owner + requestor selection target property + time) selection-request-event? (type selection-request-event-type) (serial selection-request-event-serial) @@ -701,24 +1119,39 @@ (display selection-request-event-display) (owner selection-request-event-owner) (requestor selection-request-event-requestor) - (atom selection-request-event-atom) + (selection selection-request-event-selection) (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) +(define (make-selection-request-event type serial send-event? display owner + requestor selection target property time) (let ((display (make-display display #f))) - (really-make-selection-request-event + (create-selection-request-event type serial send-event? display - (make-window window display #f) + (make-window owner display #f) + (make-window requestor display #f) (make-atom selection) + (make-atom target) + (make-atom property) time))) +(define (selection-request-event->vector e) + (list->vector (list (event-type->integer (selection-request-event-type e)) + (selection-request-event-serial e) + (selection-request-event-send-event? e) + (display-Xdisplay (selection-request-event-display e)) + (window-Xwindow (selection-request-event-owner e)) + (window-Xwindow (selection-request-event-requestor e)) + (atom-Xatom (selection-request-event-selection e)) + (atom-Xatom (selection-request-event-target e)) + (atom-Xatom (selection-request-event-property e)) + (selection-request-event-time e)))) + ;; ******************************************************************* (define-record-type selection-event :selection-event - (really-make-selection-event type serial send-event? display requestor + (create-selection-event type serial send-event? display requestor selection target property time) selection-event? (type selection-event-type) @@ -734,7 +1167,7 @@ (define (make-selection-event type serial send-event? display requestor selection target property time) (let ((display (make-display display #f))) - (really-make-selection-event + (create-selection-event type serial send-event? display (make-window requestor display #f) (make-atom selection) @@ -742,10 +1175,21 @@ (make-atom property) time))) +(define (selection-event->vector e) + (list->vector (list (event-type->integer (selection-event-type e)) + (selection-event-serial e) + (selection-event-send-event? e) + (display-Xdisplay (selection-event-display e)) + (window-Xwindow (selection-event-requestor e)) + (atom-Xatom (selection-event-selection e)) + (atom-Xatom (selection-event-target e)) + (atom-Xatom (selection-event-property e)) + (selection-event-time e)))) + ;; ******************************************************************* (define-record-type colormap-event :colormap-event - (really-make-colormap-event type serial send-event? display window colormap + (create-colormap-event type serial send-event? display window colormap new? state) colormap-event? (type colormap-event-type) @@ -760,17 +1204,27 @@ (define (make-colormap-event type serial send-event? display window colormap new? state) (let ((display (make-display display #f))) - (really-make-colormap-event + (create-colormap-event type serial send-event? display (make-window window display #f) (make-colormap colormap display #f) new? (integer->colormap-state state)))) +(define (colormap-event->vector e) + (list->vector (list (event-type->integer (colormap-event-type e)) + (colormap-event-serial e) + (colormap-event-send-event? e) + (display-Xdisplay (colormap-event-display e)) + (window-Xwindow (colormap-event-window e)) + (colormap-Xcolormap (colormap-event-colormap e)) + (colormap-event-new? e) + (colormap-state->integer (colormap-event-state e))))) + ;; ******************************************************************* (define-record-type client-message-event :client-message-event - (really-make-client-message-event type serial send-event? display window + (create-client-message-event type serial send-event? display window message-type format data) client-message-event? (type client-message-event-type) @@ -783,19 +1237,30 @@ (data client-message-event-data)) (define (make-client-message-event type serial send-event? display window - message-type data) + message-type format data) (let ((display (make-display display #f))) - (really-make-client-message-event + (create-client-message-event type serial send-event? display (make-window window display #f) (make-atom message-type) format data))) +(define (client-message-event->vector e) + (list->vector (list (event-type->integer (client-message-event-type e)) + (client-message-event-serial e) + (client-message-event-send-event? e) + (display-Xdisplay (client-message-event-display e)) + (window-Xwindow (client-message-event-window e)) + (atom-Xatom (client-message-event-message-type e)) + (client-message-event-format e) + ;; has data the correct length ?? + (client-message-event-data e)))) + ;; ******************************************************************* (define-record-type mapping-event :mapping-event - (really-make-mapping-event type serial send-event? display window request + (create-mapping-event type serial send-event? display window request first-keycode count) mapping-event? (type mapping-event-type) @@ -810,40 +1275,27 @@ (define (make-mapping-event type serial send-event? display window request first-keycode count) (let ((display (make-display display #f))) - (really-make-mapping-event + (create-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 (mapping-event->vector e) + (list->vector (list (event-type->integer (mapping-event-type e)) + (mapping-event-serial e) + (mapping-event-send-event? e) + (display-Xdisplay (mapping-event-display e)) + (window-Xwindow (mapping-event-window e)) + (mapping-request->integer + (mapping-event-request e)) + (mapping-event-first-keycode e) + (mapping-event-count e)))) ;; ******************************************************************* (define-record-type keymap-event :keymap-event - (really-make-keymap-event type serial send-event? display bit-vector) + (create-keymap-event type serial send-event? display bit-vector) keymap-event? (type keymap-event-type) (serial keymap-event-serial) @@ -854,6 +1306,14 @@ (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 + (create-keymap-event type serial send-event? display bit-vector))) + +(define (keymap-event->vector e) + (list->vector (list (event-type->integer (keymap-event-type e)) + (keymap-event-serial e) + (keymap-event-send-event? e) + (display-Xdisplay (keymap-event-display e)) + ;; corrent length? only 0 and 1's ??!! + (keymap-event-bit-vector e)))) diff --git a/scheme/xlib/event.scm b/scheme/xlib/event.scm index 6385d3b..b5bbfb3 100644 --- a/scheme/xlib/event.scm +++ b/scheme/xlib/event.scm @@ -16,12 +16,24 @@ (define (event-ready? display) (char-ready? (display-message-inport display))) +(define (send-event window propagate? event-mask event) + (let ((Xdisplay (display-Xdisplay (window-display window))) + (Xwindow (window-Xwindow window)) + (mask (event-mask->integer event-mask)) + (v (any-event->vector event)) + (type (event-type->integer (any-event-type event)))) + (%send-event Xdisplay Xwindow propagate? mask v type))) + +(import-lambda-definition %send-event (Xdisplay Xwindow propagate mask v type) + "scx_Send_Event") + ;; creates an event type -(define (complete-event type args) - (let ((constructor (event-constructor type))) - (apply constructor (cons type (vector->list args))))) - +(define (complete-event v) + (vector-set! v 0 (integer->event-type (vector-ref v 0))) + (let ((constructor (event-constructor (vector-ref v 0)))) + (apply constructor (vector->list v)))) + (define (event-constructor type) (cond ((or (eq? type (event-type key-press)) @@ -63,15 +75,14 @@ (define (next-event display) (let ((r (%next-event (display-Xdisplay display)))) - (complete-event (integer->event-type (car r)) (cdr r)))) + (complete-event r))) (import-lambda-definition %next-event (Xdisplay) "scx_Next_Event") (define (peek-event display) (let ((r (%peek-event (display-Xdisplay display)))) - (complete-event (integer->event-type (car r)) - (cdr r)))) + (complete-event r))) (import-lambda-definition %peek-event (Xdisplay) "scx_Peek_Event") diff --git a/scheme/xlib/types.scm b/scheme/xlib/types.scm index 3a80c87..e15a66e 100644 --- a/scheme/xlib/types.scm +++ b/scheme/xlib/types.scm @@ -84,7 +84,7 @@ (define-enumerated-type button :button button? buttons button-name button-index - (button1 button2 button3 button4 button5)) + (any-button button1 button2 button3 button4 button5)) (define (integer->button int) (vector-ref buttons int)) @@ -346,7 +346,7 @@ (define-enumerated-type window-class :window-class window-class? window-classs window-class-name window-class-index - (input-output input-only)) + (copy-from-parent input-output input-only)) (define (integer->window-class int) (vector-ref window-classs int)) diff --git a/scheme/xlib/xlib-interfaces.scm b/scheme/xlib/xlib-interfaces.scm index 1bc6101..556868d 100644 --- a/scheme/xlib/xlib-interfaces.scm +++ b/scheme/xlib/xlib-interfaces.scm @@ -1,7 +1,7 @@ (define-interface xlib-display-interface (export open-display display-default-root-window - display-root-window ;; same as above + display-root-window display-default-colormap display-colormap ;; same as above display-default-gcontext @@ -42,6 +42,7 @@ map-window unmap-window + change-window-attributes set-window-background-pixmap! set-window-background-pixel! set-window-border-pixmap! @@ -58,6 +59,7 @@ set-window-colormap! set-window-cursor! + configure-window set-window-x! set-window-y! set-window-width! @@ -66,6 +68,7 @@ set-window-sibling! set-window-stack-mode! + get-window-attributes window-x window-y window-width @@ -278,10 +281,16 @@ next-event peek-event wait-event + send-event ((event-type) :syntax) any-event-type + any-event-serial + any-event-send-event? + any-event-display + any-event-window + create-key-event key-event? key-event-type key-event-serial @@ -298,6 +307,8 @@ key-event-state key-event-keycode key-event-same-screen? + + create-button-event button-event? button-event-type button-event-serial @@ -314,6 +325,8 @@ button-event-state button-event-button button-event-same-screen? + + create-motion-event motion-event? motion-event-type motion-event-serial @@ -330,6 +343,8 @@ motion-event-state motion-event-is-hint? motion-event-same-screen? + + create-crossing-event crossing-event? crossing-event-type crossing-event-serial @@ -348,6 +363,8 @@ crossing-event-same-screen? crossing-event-focus? crossing-event-state + + create-focus-change-event focus-change-event? focus-change-event-type focus-change-event-serial @@ -356,6 +373,8 @@ focus-change-event-window focus-change-event-mode focus-change-event-detail + + create-expose-event expose-event? expose-event-type expose-event-serial @@ -367,6 +386,8 @@ expose-event-width expose-event-height expose-event-count + + create-graphics-expose-event graphics-expose-event? graphics-expose-event-type graphics-expose-event-serial @@ -379,6 +400,8 @@ graphics-expose-event-height graphics-expose-event-major-code graphics-expose-event-minor-code + + create-no-expose-event no-expose-event? no-expose-event-type no-expose-event-serial @@ -387,6 +410,8 @@ no-expose-event-drawable no-expose-event-major-code no-expose-event-minor-code + + create-visibility-event visibility-event? visibility-event-type visibility-event-serial @@ -394,6 +419,8 @@ visibility-event-display visibility-event-window visibility-event-state + + create-create-window-event create-window-event? create-window-event-type create-window-event-serial @@ -407,6 +434,8 @@ create-window-event-height create-window-event-border-width create-window-event-override-redirect? + + create-destroy-window-event destroy-window-event? destroy-window-event-type destroy-window-event-serial @@ -414,6 +443,8 @@ destroy-window-event-display destroy-window-event-event destroy-window-event-window + + create-unmap-event unmap-event? unmap-event-type unmap-event-serial @@ -422,6 +453,8 @@ unmap-event-event unmap-event-window unmap-event-from-configure? + + create-map-event map-event? map-event-type map-event-serial @@ -430,6 +463,8 @@ map-event-event map-event-window map-event-override-redirect? + + create-map-request-event map-request-event? map-request-event-type map-request-event-serial @@ -437,6 +472,8 @@ map-request-event-display map-request-event-parent map-request-event-window + + create-reparent-event reparent-event? reparent-event-type reparent-event-serial @@ -448,6 +485,8 @@ reparent-event-x reparent-event-y reparent-event-override-redirect? + + create-configure-event configure-event? configure-event-type configure-event-serial @@ -462,6 +501,8 @@ configure-event-border-width configure-event-above configure-event-override-redirect? + + create-gravity-event gravity-event? gravity-event-type gravity-event-serial @@ -471,6 +512,8 @@ gravity-event-window gravity-event-x gravity-event-y + + create-resize-request-event resize-request-event? resize-request-event-type resize-request-event-serial @@ -479,6 +522,8 @@ resize-request-event-window resize-request-event-width resize-request-event-height + + create-configure-request-event configure-request-event? configure-request-event-type configure-request-event-serial @@ -486,7 +531,9 @@ configure-request-event-display configure-request-event-parent configure-request-event-window - configure-request-event-window-changes-alist + configure-request-event-window-change-alist + + create-circulate-event circulate-event? circulate-event-type circulate-event-serial @@ -495,6 +542,8 @@ circulate-event-event circulate-event-window circulate-event-place + + create-circulate-request-event circulate-request-event? circulate-request-event-type circulate-request-event-serial @@ -503,6 +552,8 @@ circulate-request-event-parent circulate-request-event-window circulate-request-event-place + + create-property-event property-event? property-event-type property-event-serial @@ -512,6 +563,8 @@ property-event-atom property-event-time property-event-state + + create-selection-clear-event selection-clear-event? selection-clear-event-type selection-clear-event-serial @@ -520,6 +573,8 @@ selection-clear-event-window selection-clear-event-selection selection-clear-event-time + + create-selection-request-event selection-request-event? selection-request-event-type selection-request-event-serial @@ -527,10 +582,12 @@ selection-request-event-display selection-request-event-owner selection-request-event-requestor - selection-request-event-atom + selection-request-event-selection selection-request-event-target selection-request-event-property selection-request-event-time + + create-selection-event selection-event? selection-event-type selection-event-serial @@ -541,6 +598,8 @@ selection-event-target selection-event-property selection-event-time + + create-colormap-event colormap-event? colormap-event-type colormap-event-serial @@ -550,6 +609,8 @@ colormap-event-colormap colormap-event-new? colormap-event-state + + create-client-message-event client-message-event? client-message-event-type client-message-event-serial @@ -559,6 +620,8 @@ client-message-event-message-type client-message-event-format client-message-event-data + + create-mapping-event mapping-event? mapping-event-type mapping-event-serial @@ -568,16 +631,8 @@ 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 + + create-keymap-event keymap-event? keymap-event-type keymap-event-serial @@ -797,7 +852,7 @@ mapping-request bit-gravity gravity) :syntax) ((set-window-attribute window-change stack-mode - window-attribute + window-attribute map-state make-set-window-attribute-alist make-window-attribute-alist make-window-change-alist) :syntax) diff --git a/scheme/xlib/xlib-internal-interfaces.scm b/scheme/xlib/xlib-internal-interfaces.scm index 8c2f532..324da9a 100644 --- a/scheme/xlib/xlib-internal-interfaces.scm +++ b/scheme/xlib/xlib-internal-interfaces.scm @@ -77,7 +77,7 @@ ((window-attribute make-window-attribute-alist) :syntax) integer+vector->window-attribute-alist - ((window-class) :syntax) + ((window-class map-state) :syntax) ((byte-order bit-order) :syntax) integer->byte-order integer->bit-order