- using select in wait-event now
- modified error handling - added cml-based event dispatcher to sync-event.scm - fixed some bugs in mask-handling - fixed a bug with enum-sets
This commit is contained in:
frese
parent
829150be2f
commit
fa5085eccf
|
|
@ -1,13 +1,10 @@
|
|||
#include "xlib.h"
|
||||
|
||||
// TODO
|
||||
#define scx_raise_status_error(sname, cname) return S48_FALSE
|
||||
|
||||
s48_value scx_Iconify_Window(s48_value display, s48_value w, s48_value scr) {
|
||||
if (!XIconifyWindow(scx_extract_display(display),
|
||||
scx_extract_window(w),
|
||||
s48_extract_integer(scr)))
|
||||
scx_raise_status_error("iconify-window", "XIconifyWindow");
|
||||
return S48_FALSE;
|
||||
return S48_UNSPECIFIC;
|
||||
}
|
||||
|
||||
|
|
@ -15,7 +12,7 @@ s48_value scx_Withdraw_Window(s48_value display, s48_value w, s48_value scr) {
|
|||
if (!XWithdrawWindow(scx_extract_display(display),
|
||||
scx_extract_window(w),
|
||||
s48_extract_integer(scr)))
|
||||
scx_raise_status_error("withdraw-window", "XWithdrawWindow");
|
||||
return S48_FALSE;
|
||||
return S48_UNSPECIFIC;
|
||||
}
|
||||
|
||||
|
|
@ -28,7 +25,7 @@ s48_value scx_Reconfigure_Wm_Window(s48_value dpy, s48_value w, s48_value scr,
|
|||
scx_extract_window(w),
|
||||
s48_extract_integer(scr),
|
||||
mask, &WC))
|
||||
scx_raise_status_error("reconfigure-wm-window", "XReconfigureWMWindow");
|
||||
return S48_FALSE;
|
||||
return S48_UNSPECIFIC;
|
||||
}
|
||||
|
||||
|
|
@ -41,7 +38,7 @@ s48_value scx_Get_Wm_Command(s48_value dpy, s48_value w) {
|
|||
if (!XGetCommand (scx_extract_display(dpy),
|
||||
scx_extract_window(w),
|
||||
&av, &ac))
|
||||
scx_raise_status_error("get-wm-command", "XGetCommand");
|
||||
return S48_FALSE;
|
||||
|
||||
S48_GC_PROTECT_1(ret);
|
||||
for (i = ac-1; i >= 0; i--)
|
||||
|
|
@ -72,7 +69,7 @@ s48_value scx_Get_Wm_Protocols(s48_value display, s48_value w) {
|
|||
|
||||
if (!XGetWMProtocols (scx_extract_display(display),
|
||||
scx_extract_window(w), &p, &n))
|
||||
scx_raise_status_error("get-wm-protocols", "XGetWMProtocols");
|
||||
return S48_FALSE;
|
||||
|
||||
S48_GC_PROTECT_1(ret);
|
||||
for (i = n-1; i >= 0; i--)
|
||||
|
|
@ -94,7 +91,7 @@ s48_value scx_Set_Wm_Protocols (s48_value display, s48_value w, s48_value v) {
|
|||
if (!XSetWMProtocols (scx_extract_display(display),
|
||||
scx_extract_window(w),
|
||||
p, n))
|
||||
scx_raise_status_error("set-wm-protocols", "XSetWMProtocols");
|
||||
return S48_FALSE;
|
||||
|
||||
return S48_UNSPECIFIC;
|
||||
}
|
||||
|
|
@ -107,7 +104,7 @@ s48_value scx_Get_Wm_Class (s48_value display, s48_value w) {
|
|||
c.res_name = c.res_class = 0;
|
||||
if (!XGetClassHint(scx_extract_display(display),
|
||||
scx_extract_window(w), &c))
|
||||
scx_raise_status_error("get-wm-class", "XGetClassHint");
|
||||
return S48_FALSE;
|
||||
|
||||
ret = s48_cons(S48_FALSE, S48_FALSE);
|
||||
S48_GC_PROTECT_1(ret);
|
||||
|
|
@ -188,39 +185,33 @@ void scx_extract_wm_hint_alist(s48_value alist, XWMHints* p) {
|
|||
while (alist != S48_NULL) {
|
||||
int h = scx_extract_wm_hint(S48_CAR(S48_CAR(alist)));
|
||||
s48_value v = S48_CDR(S48_CAR(alist));
|
||||
switch (h) {
|
||||
case 0:
|
||||
p->flags |= InputHint;
|
||||
p->flags |= (1L << h);
|
||||
switch (1L << h) {
|
||||
case InputHint:
|
||||
p->input = S48_EXTRACT_BOOLEAN(v);
|
||||
break;
|
||||
case 1:
|
||||
p->flags |= StateHint;
|
||||
case StateHint:
|
||||
p->initial_state = scx_extract_initial_state(v);
|
||||
break;
|
||||
case 2:
|
||||
p->flags |= IconPixmapHint;
|
||||
case IconPixmapHint:
|
||||
p->icon_pixmap = scx_extract_pixmap(v);
|
||||
break;
|
||||
case 3:
|
||||
p->flags |= IconWindowHint;
|
||||
case IconWindowHint:
|
||||
p->icon_window = scx_extract_window(v);
|
||||
break;
|
||||
case 4:
|
||||
p->flags |= IconPositionHint;
|
||||
case IconPositionHint:
|
||||
p->icon_x = s48_extract_integer(S48_CAR(v));
|
||||
p->icon_y = s48_extract_integer(S48_CDR(v));
|
||||
break;
|
||||
case 5:
|
||||
p->flags |= IconMaskHint;
|
||||
case IconMaskHint:
|
||||
p->icon_mask = scx_extract_pixmap(v);
|
||||
break;
|
||||
case 6:
|
||||
p->flags |= WindowGroupHint;
|
||||
case WindowGroupHint:
|
||||
p->window_group = scx_extract_window(v);
|
||||
break;
|
||||
case 7:
|
||||
if (S48_EXTRACT_BOOLEAN(v))
|
||||
p->flags |= XUrgencyHint;
|
||||
case XUrgencyHint:
|
||||
if (v == S48_FALSE)
|
||||
p->flags &= ~XUrgencyHint;
|
||||
break;
|
||||
}
|
||||
alist = S48_CDR(alist);
|
||||
|
|
@ -237,7 +228,7 @@ s48_value scx_Get_Wm_Hints(s48_value dpy, s48_value w) {
|
|||
res = scx_enter_wm_hint_alist(p);
|
||||
XFree(p);
|
||||
} else
|
||||
scx_raise_status_error("get-wm-hints", "XGetWMHints");
|
||||
return S48_FALSE;
|
||||
return res;
|
||||
}
|
||||
|
||||
|
|
@ -255,7 +246,7 @@ s48_value scx_Get_Transient_For(s48_value dpy, s48_value w) {
|
|||
if (!XGetTransientForHint(scx_extract_display(dpy),
|
||||
scx_extract_window(w),
|
||||
&win))
|
||||
scx_raise_status_error("get-transient-for", "XGetTransientForHint");
|
||||
return S48_FALSE;
|
||||
return scx_enter_window(win);
|
||||
}
|
||||
|
||||
|
|
@ -273,7 +264,7 @@ s48_value scx_Get_Text_Property(s48_value dpy, s48_value w, s48_value a) {
|
|||
scx_extract_window(w),
|
||||
&ret,
|
||||
scx_extract_atom(a)))
|
||||
scx_raise_status_error("get-text-property", "XGetTextProperty");
|
||||
return S48_FALSE;
|
||||
res = scx_enter_property(ret.encoding, ret.format, ret.value, ret.nitems);
|
||||
XFree(ret.value);
|
||||
return res;
|
||||
|
|
@ -397,7 +388,7 @@ s48_value scx_Get_Wm_Normal_Hints(s48_value dpy, s48_value win) {
|
|||
if (!XGetWMNormalHints(scx_extract_display(dpy),
|
||||
scx_extract_window(win),
|
||||
&SH, &supplied_by_user))
|
||||
scx_raise_status_error("get-wm-normal-hints", "XGetWMNormalHints");
|
||||
return S48_FALSE;
|
||||
// ignoring supplied_by_user ... ?!
|
||||
return scx_enter_size_hint_alist(&SH);
|
||||
}
|
||||
|
|
@ -446,7 +437,7 @@ s48_value scx_Get_Icon_Sizes(s48_value dpy, s48_value w) {
|
|||
if (!XGetIconSizes (scx_extract_display(dpy),
|
||||
scx_extract_window(w),
|
||||
&p, &n))
|
||||
scx_raise_status_error("get-icon-sizes", "XGetIconSizes");
|
||||
return S48_FALSE;
|
||||
|
||||
S48_GC_PROTECT_1(v);
|
||||
for (i = n-1; i >= 0; i--)
|
||||
|
|
|
|||
|
|
@ -14,30 +14,35 @@ s48_value scx_enter_screenformat(ScreenFormat* sf) {
|
|||
return res;
|
||||
}
|
||||
|
||||
s48_value scx_screen_list = S48_NULL;
|
||||
|
||||
s48_value scx_enter_screen(Screen* scr) {
|
||||
s48_value s = s48_make_record(scx_screen);
|
||||
S48_DECLARE_GC_PROTECT(1);
|
||||
S48_GC_PROTECT_1(s);
|
||||
S48_RECORD_SET(s, 0, s48_enter_integer((long)scr));
|
||||
S48_RECORD_SET(s, 1, scx_enter_display(DisplayOfScreen(scr)));
|
||||
S48_RECORD_SET(s, 2, scx_enter_window(RootWindowOfScreen(scr)));
|
||||
S48_RECORD_SET(s, 3, s48_enter_integer(WidthOfScreen(scr)));
|
||||
S48_RECORD_SET(s, 4, s48_enter_integer(HeightOfScreen(scr)));
|
||||
S48_RECORD_SET(s, 5, s48_enter_integer(WidthMMOfScreen(scr)));
|
||||
S48_RECORD_SET(s, 6, s48_enter_integer(HeightMMOfScreen(scr)));
|
||||
S48_RECORD_SET(s, 7, S48_FALSE); // TODO depths
|
||||
S48_RECORD_SET(s, 8, s48_enter_integer(DefaultDepthOfScreen(scr)));
|
||||
S48_RECORD_SET(s, 9, scx_enter_visual(DefaultVisualOfScreen(scr)));
|
||||
S48_RECORD_SET(s, 10, scx_enter_gc(DefaultGCOfScreen(scr)));
|
||||
S48_RECORD_SET(s, 11, scx_enter_colormap(DefaultColormapOfScreen(scr)));
|
||||
S48_RECORD_SET(s, 12, scx_enter_pixel(BlackPixelOfScreen(scr)));
|
||||
S48_RECORD_SET(s, 13, scx_enter_pixel(WhitePixelOfScreen(scr)));
|
||||
S48_RECORD_SET(s, 14, s48_enter_integer(MinCmapsOfScreen(scr)));
|
||||
S48_RECORD_SET(s, 15, s48_enter_integer(MaxCmapsOfScreen(scr)));
|
||||
S48_RECORD_SET(s, 16, scx_enter_backing_store(DoesBackingStore(scr)));
|
||||
S48_RECORD_SET(s, 17, S48_ENTER_BOOLEAN(DoesSaveUnders(scr)));
|
||||
S48_RECORD_SET(s, 18, scx_enter_event_mask(EventMaskOfScreen(scr)));
|
||||
S48_GC_UNPROTECT();
|
||||
s48_value s = scx_struct_cache_ref(scr, scx_screen_list);
|
||||
if (s == S48_FALSE) {
|
||||
S48_DECLARE_GC_PROTECT(1);
|
||||
s = s48_make_record(scx_screen);
|
||||
S48_GC_PROTECT_1(s);
|
||||
S48_RECORD_SET(s, 0, s48_enter_integer((long)scr));
|
||||
S48_RECORD_SET(s, 1, scx_enter_display(DisplayOfScreen(scr)));
|
||||
S48_RECORD_SET(s, 2, scx_enter_window(RootWindowOfScreen(scr)));
|
||||
S48_RECORD_SET(s, 3, s48_enter_integer(WidthOfScreen(scr)));
|
||||
S48_RECORD_SET(s, 4, s48_enter_integer(HeightOfScreen(scr)));
|
||||
S48_RECORD_SET(s, 5, s48_enter_integer(WidthMMOfScreen(scr)));
|
||||
S48_RECORD_SET(s, 6, s48_enter_integer(HeightMMOfScreen(scr)));
|
||||
S48_RECORD_SET(s, 7, s48_enter_integer(XScreenNumberOfScreen(scr)));
|
||||
S48_RECORD_SET(s, 8, s48_enter_integer(DefaultDepthOfScreen(scr)));
|
||||
S48_RECORD_SET(s, 9, scx_enter_visual(DefaultVisualOfScreen(scr)));
|
||||
S48_RECORD_SET(s, 10, scx_enter_gc(DefaultGCOfScreen(scr)));
|
||||
S48_RECORD_SET(s, 11, scx_enter_colormap(DefaultColormapOfScreen(scr)));
|
||||
S48_RECORD_SET(s, 12, scx_enter_pixel(BlackPixelOfScreen(scr)));
|
||||
S48_RECORD_SET(s, 13, scx_enter_pixel(WhitePixelOfScreen(scr)));
|
||||
S48_RECORD_SET(s, 14, s48_enter_integer(MinCmapsOfScreen(scr)));
|
||||
S48_RECORD_SET(s, 15, s48_enter_integer(MaxCmapsOfScreen(scr)));
|
||||
S48_RECORD_SET(s, 16, scx_enter_backing_store(DoesBackingStore(scr)));
|
||||
S48_RECORD_SET(s, 17, S48_ENTER_BOOLEAN(DoesSaveUnders(scr)));
|
||||
S48_RECORD_SET(s, 18, scx_enter_event_mask(EventMaskOfScreen(scr)));
|
||||
S48_GC_UNPROTECT();
|
||||
}
|
||||
return s;
|
||||
}
|
||||
|
||||
|
|
@ -74,7 +79,8 @@ s48_value scx_enter_display(Display* dpy) {
|
|||
S48_RECORD_SET(d, 9, s48_enter_integer(VendorRelease(dpy)));
|
||||
S48_RECORD_SET(d, 10, s48_enter_integer(QLength(dpy)));
|
||||
S48_RECORD_SET(d, 11, s48_enter_string(DisplayString(dpy)));
|
||||
S48_RECORD_SET(d, 12, s48_enter_integer(DefaultScreen(dpy)));
|
||||
S48_RECORD_SET(d, 12,
|
||||
scx_enter_screen(ScreenOfDisplay(dpy, DefaultScreen(dpy))));
|
||||
for (i = ScreenCount(dpy)-1; i >= 0; i--)
|
||||
l = s48_cons(scx_enter_screen(ScreenOfDisplay(dpy, i)), l);
|
||||
S48_RECORD_SET(d, 13, l);
|
||||
|
|
@ -135,6 +141,7 @@ s48_value scx_Display_Select_Input(s48_value display, s48_value window,
|
|||
|
||||
void scx_init_display(void) {
|
||||
S48_GC_PROTECT_GLOBAL(scx_display_list);
|
||||
S48_GC_PROTECT_GLOBAL(scx_screen_list);
|
||||
|
||||
S48_EXPORT_FUNCTION(scx_Open_Display);
|
||||
S48_EXPORT_FUNCTION(scx_Close_Display);
|
||||
|
|
|
|||
|
|
@ -49,15 +49,25 @@ void scx_extract_x_error(s48_value e, XErrorEvent* xe) {
|
|||
xe->resourceid = s48_extract_integer(S48_RECORD_REF(e, 5));
|
||||
}
|
||||
|
||||
static s48_value internal_error_handler_binding = S48_FALSE;
|
||||
/* Default error handlers of the Xlib */
|
||||
extern int _XDefaultIOError();
|
||||
extern int _XDefaultError();
|
||||
|
||||
static s48_value internal_x_error_handler_binding = S48_FALSE;
|
||||
|
||||
static int error_handler_wrapper(Display* dpy, XErrorEvent* e) {
|
||||
s48_call_scheme(internal_error_handler_binding, 2,
|
||||
scx_enter_display(dpy),
|
||||
scx_enter_x_error(e));
|
||||
if ((internal_x_error_handler_binding != S48_FALSE) &&
|
||||
(S48_SHARED_BINDING_REF(internal_x_error_handler_binding) != S48_FALSE))
|
||||
s48_call_scheme(S48_SHARED_BINDING_REF(internal_x_error_handler_binding),
|
||||
2,
|
||||
scx_enter_display(dpy),
|
||||
scx_enter_x_error(e));
|
||||
else
|
||||
_XDefaultError(dpy, e);
|
||||
return 0;
|
||||
}
|
||||
|
||||
/*
|
||||
s48_value scx_Set_Error_Handler(s48_value fun) {
|
||||
s48_value maybe_previous = internal_error_handler_binding;
|
||||
int (*previous)() = NULL;
|
||||
|
|
@ -81,6 +91,7 @@ s48_value scx_Call_C_Error_Handler(s48_value pointer, s48_value display,
|
|||
result = procedure(scx_extract_display(display), &ev);
|
||||
return s48_enter_integer(result);
|
||||
}
|
||||
*/
|
||||
|
||||
s48_value scx_Get_Error_Text(s48_value display, s48_value code) {
|
||||
char buf[1024];
|
||||
|
|
@ -104,35 +115,37 @@ s48_value scx_Get_Error_Database_Text(s48_value display, s48_value name,
|
|||
|
||||
s48_value internal_x_fatal_error_handler_binding = S48_FALSE;
|
||||
|
||||
/* Default error handlers of the Xlib */
|
||||
extern int _XDefaultIOError();
|
||||
extern int _XDefaultError();
|
||||
|
||||
static X_Fatal_Error (Display* d) {
|
||||
static int fatal_error_handler_wrapper(Display* d) {
|
||||
// call the scheme-func internal-x-fatal-error-handler, which does the rest.
|
||||
s48_call_scheme(S48_SHARED_BINDING_REF(internal_x_fatal_error_handler_binding),
|
||||
1, scx_enter_display(d));
|
||||
|
||||
if ((internal_x_fatal_error_handler_binding != S48_FALSE) &&
|
||||
(S48_SHARED_BINDING_REF(internal_x_fatal_error_handler_binding)
|
||||
!= S48_FALSE))
|
||||
s48_call_scheme(S48_SHARED_BINDING_REF(
|
||||
internal_x_fatal_error_handler_binding),
|
||||
1, scx_enter_display(d));
|
||||
// In case the scheme error handler does not exit (or none exists):
|
||||
_XDefaultIOError (d);
|
||||
// And if event the default handler does not exit:
|
||||
exit (1);
|
||||
// And if even the default handler does not exit:
|
||||
exit(1);
|
||||
/*NOTREACHED*/
|
||||
return 0;
|
||||
}
|
||||
|
||||
void scx_init_error() {
|
||||
S48_GC_PROTECT_GLOBAL(internal_error_handler_binding);
|
||||
S48_GC_PROTECT_GLOBAL(internal_x_error_handler_binding);
|
||||
S48_GC_PROTECT_GLOBAL(internal_x_fatal_error_handler_binding);
|
||||
|
||||
S48_EXPORT_FUNCTION(scx_Set_Error_Handler);
|
||||
S48_EXPORT_FUNCTION(scx_Call_C_Error_Handler);
|
||||
//S48_EXPORT_FUNCTION(scx_Set_Error_Handler);
|
||||
//S48_EXPORT_FUNCTION(scx_Call_C_Error_Handler);
|
||||
S48_EXPORT_FUNCTION(scx_Get_Error_Text);
|
||||
S48_EXPORT_FUNCTION(scx_Get_Error_Database_Text);
|
||||
//S48_EXPORT_FUNCTION(scx_Set_IO_Error_Handler); TODO!
|
||||
//S48_EXPORT_FUNCTION(scx_Set_IO_Error_Handler);
|
||||
|
||||
internal_x_fatal_error_handler_binding =
|
||||
s48_get_imported_binding("internal-x-fatal-error-handler");
|
||||
internal_x_error_handler_binding =
|
||||
s48_get_imported_binding("internal-x-error-handler");
|
||||
|
||||
(void)XSetIOErrorHandler(X_Fatal_Error);
|
||||
//(void)XSetErrorHandler(X_Error);
|
||||
(void)XSetIOErrorHandler(fatal_error_handler_wrapper);
|
||||
(void)XSetErrorHandler(error_handler_wrapper);
|
||||
}
|
||||
|
|
|
|||
|
|
@ -14,6 +14,7 @@
|
|||
EENTER(3, display, scx_enter_display);
|
||||
|
||||
#define EENTER_END() \
|
||||
S48_GC_UNPROTECT(); \
|
||||
return e
|
||||
|
||||
s48_value scx_enter_key_event(XKeyEvent* xe) {
|
||||
|
|
|
|||
|
|
@ -98,8 +98,8 @@ unsigned long scx_extract_gc_value_alist(s48_value values, XGCValues* GCV) {
|
|||
int mv = scx_extract_gc_value(S48_CAR(S48_CAR(values)));
|
||||
s48_value v = S48_CDR(S48_CAR(values));
|
||||
values = S48_CDR(values);
|
||||
mask = mask | mv;
|
||||
switch (mv) {
|
||||
mask = mask | (1L << mv);
|
||||
switch (1L << mv) {
|
||||
case GCFunction:
|
||||
GCV->function = scx_extract_gc_function(v); break;
|
||||
case GCPlaneMask:
|
||||
|
|
@ -158,7 +158,7 @@ static s48_value scx_enter_gc_value_alist(s48_value values, XGCValues* GCV) {
|
|||
S48_GC_PROTECT_3(res, v, values);
|
||||
while (values != S48_NULL) {
|
||||
int mv = scx_extract_gc_value(S48_CAR(values));
|
||||
switch (mv) {
|
||||
switch (1L << mv) {
|
||||
case GCFunction:
|
||||
v = scx_extract_gc_function(GCV->function); break;
|
||||
case GCPlaneMask:
|
||||
|
|
@ -234,7 +234,7 @@ s48_value scx_Copy_Gc(s48_value display, s48_value source, s48_value mask,
|
|||
s48_value scx_Change_Gc(s48_value display, s48_value gc, s48_value values) {
|
||||
XGCValues GCV;
|
||||
unsigned long mask = scx_extract_gc_value_alist(values, &GCV);
|
||||
XChangeGC(scx_extract_display(display), scx_extract_gc(gc),
|
||||
XChangeGC(scx_extract_display(display), scx_extract_gc(gc),
|
||||
mask, &GCV);
|
||||
return S48_UNSPECIFIC;
|
||||
}
|
||||
|
|
@ -252,7 +252,7 @@ s48_value scx_Get_Gc_Values(s48_value display, s48_value gc,
|
|||
unsigned long mask = 0;
|
||||
XGCValues GCV;
|
||||
for (; values != S48_NULL; values = S48_CDR(values))
|
||||
mask |= scx_extract_gc_value(S48_CAR(values));
|
||||
mask |= (1L << scx_extract_gc_value(S48_CAR(values)));
|
||||
|
||||
if (!XGetGCValues(scx_extract_display(display),
|
||||
scx_extract_gc(gc),
|
||||
|
|
|
|||
|
|
@ -39,23 +39,26 @@ s48_value scx_struct_cache_ref(void* cpointer, s48_value list) {
|
|||
|
||||
void scx_struct_cache_set(void* cpointer, s48_value* l, s48_value v) {
|
||||
s48_value list = *l;
|
||||
s48_value wp = S48_FALSE;
|
||||
S48_DECLARE_GC_PROTECT(2);
|
||||
s48_value previous = S48_FALSE;
|
||||
s48_value pair = S48_FALSE;
|
||||
S48_DECLARE_GC_PROTECT(3);
|
||||
S48_GC_PROTECT_3(list, pair, previous);
|
||||
|
||||
// create the new entry
|
||||
pair = s48_make_weak_pointer(v);
|
||||
pair = s48_cons(S48_ENTER_POINTER(cpointer), pair);
|
||||
*l = s48_cons(pair, *l);
|
||||
previous = *l;
|
||||
|
||||
// remove all empty and duplicate entries
|
||||
while (list != S48_NULL) {
|
||||
if (S48_EXTRACT_POINTER(S48_CAR(S48_CAR(list))) == cpointer) {
|
||||
S48_GC_PROTECT_1(list);
|
||||
wp = s48_make_weak_pointer(v);
|
||||
S48_SET_CDR(S48_CAR(list), wp);
|
||||
S48_GC_UNPROTECT();
|
||||
return;
|
||||
}
|
||||
s48_value entry = S48_WEAK_POINTER_REF(S48_CDR(S48_CAR(list)));
|
||||
if ((entry == S48_FALSE) || (S48_EXTRACT_POINTER(entry) == cpointer))
|
||||
S48_SET_CDR(previous, S48_CDR(list));
|
||||
else
|
||||
previous = list;
|
||||
list = S48_CDR(list);
|
||||
}
|
||||
S48_GC_PROTECT_2(list, wp);
|
||||
// TODO: if not found, use first free entry to keep list small...
|
||||
wp = s48_make_weak_pointer(v);
|
||||
wp = s48_cons(S48_ENTER_POINTER(cpointer), wp);
|
||||
*l = s48_cons(wp, *l);
|
||||
S48_GC_UNPROTECT();
|
||||
}
|
||||
|
||||
|
|
|
|||
|
|
@ -2,16 +2,19 @@
|
|||
|
||||
#include "xlib.h"
|
||||
|
||||
#define scx_extract_set_window_attribute(x) \
|
||||
S48_EXTRACT_ENUM(x, "scx-set-window-attribute")
|
||||
|
||||
static unsigned long
|
||||
scx_extract_set_window_attribute_alist(s48_value attribs,
|
||||
XSetWindowAttributes* Xattrs) {
|
||||
unsigned long mask = 0;
|
||||
while (attribs != S48_NULL) {
|
||||
int mv = scx_extract_gc_value(S48_CAR(S48_CAR(attribs)));
|
||||
int mv = scx_extract_set_window_attribute(S48_CAR(S48_CAR(attribs)));
|
||||
s48_value v = S48_CDR(S48_CAR(attribs));
|
||||
attribs = S48_CDR(attribs);
|
||||
mask = mask | mv;
|
||||
switch (mv) {
|
||||
mask = mask | (1L << mv);
|
||||
switch (1L << mv) {
|
||||
case CWBackPixmap:
|
||||
Xattrs->background_pixmap = scx_extract_pixmap(v); break;
|
||||
case CWBackPixel:
|
||||
|
|
@ -93,7 +96,6 @@ s48_value scx_Change_Window_Attributes(s48_value display, s48_value window,
|
|||
XSetWindowAttributes Xattrs;
|
||||
unsigned long mask =
|
||||
scx_extract_set_window_attribute_alist(attribs, &Xattrs);
|
||||
|
||||
XChangeWindowAttributes(scx_extract_display(display),
|
||||
scx_extract_window(window),
|
||||
mask, &Xattrs);
|
||||
|
|
@ -151,8 +153,8 @@ unsigned long scx_extract_window_changes(s48_value changes,
|
|||
int mv = scx_extract_window_change(S48_CAR(S48_CAR(changes)));
|
||||
s48_value v = S48_CDR(S48_CAR(changes));
|
||||
changes = S48_CDR(changes);
|
||||
mask = mask | mv;
|
||||
switch (mv) {
|
||||
mask = mask | (1L << mv);
|
||||
switch (1L << mv) {
|
||||
case CWX:
|
||||
WC->x = s48_extract_integer(v); break;
|
||||
case CWY:
|
||||
|
|
|
|||
|
|
@ -37,14 +37,16 @@ extern int s48_list_length(s48_value list);
|
|||
|
||||
#define S48_EXTRACT_ENUM(x, typestr) \
|
||||
s48_extract_integer(s48_checked_record_ref(x, 1, \
|
||||
S48_SHARED_BINDING_REF(s48_get_imported_binding(typestr))))
|
||||
s48_get_imported_binding(typestr)))
|
||||
// S48_SHARED_BINDING_REF(s48_get_imported_binding(typestr))))
|
||||
#define S48_ENTER_ENUM(index, vvectorstr) \
|
||||
S48_VECTOR_REF(S48_SHARED_BINDING_REF(s48_get_imported_binding(vvectorstr)),\
|
||||
index)
|
||||
|
||||
#define S48_EXTRACT_ENUM_SET(x, typestr) \
|
||||
s48_extract_integer(s48_checked_record_ref(x, 1, \
|
||||
S48_SHARED_BINDING_REF(s48_get_imported_binding(typestr))))
|
||||
s48_get_imported_binding("s48-enum-set-type")))
|
||||
// TODO check type in record-field 0
|
||||
extern s48_value s48_enter_enum_set(unsigned long v, char* typestr);
|
||||
|
||||
// *** Extraction-Macros for the XIDs ********************************
|
||||
|
|
|
|||
|
|
@ -4,7 +4,7 @@
|
|||
;; format), to the root window of the specified screen. See
|
||||
;; XIconifyWindow.
|
||||
|
||||
;; raises scx-status-error on error.
|
||||
;; returns #f on error.
|
||||
(import-lambda-definition iconify-window (display window screen-num)
|
||||
"scx_Iconify_Window")
|
||||
|
||||
|
|
@ -12,7 +12,7 @@
|
|||
;; UnmapNotify event to the root window of the specified screen. See
|
||||
;; XWithdrawWindow.
|
||||
|
||||
;; raises scx-status-error on error.
|
||||
;; returns #f on error.
|
||||
(import-lambda-definition withdraw-window (display window scr-num)
|
||||
"scx_Withdraw_Window")
|
||||
|
||||
|
|
@ -21,7 +21,7 @@
|
|||
;; the root window if that fails. See XReconfigureWMWindow. See
|
||||
;; configure-window.
|
||||
|
||||
;; raises scx-status-error on error.
|
||||
;; returns #f on error.
|
||||
(import-lambda-definition reconfigure-wm-window
|
||||
(display window scr-num changes)
|
||||
"scx_Reconfigure_Wm_Window")
|
||||
|
|
@ -31,7 +31,7 @@
|
|||
;; get-wm-command reads the WM_COMMAND property from the specified
|
||||
;; window and returns it as a list of strings. See XGetCommand.
|
||||
|
||||
;; raises scx-status-error on error.
|
||||
;; returns #f on error.
|
||||
(import-lambda-definition get-wm-command (display window)
|
||||
"scx_Get_Wm_Command")
|
||||
|
||||
|
|
@ -48,28 +48,28 @@
|
|||
;; window manager protocols in which the owner of this window is
|
||||
;; willing to participate. See XGetWMProtocols.
|
||||
|
||||
;; raises scx-status-error on error.
|
||||
;; returns #f on error.
|
||||
(import-lambda-definition get-wm-protocols (display window)
|
||||
"scx_Get_Wm_Protocols")
|
||||
|
||||
;; set-wm-protocols! sets the WM_PROTOCOLS property of the specified
|
||||
;; window. protocols has to be a list of atoms. See XSetWMProtocols.
|
||||
|
||||
;; raises scx-status-error on error.
|
||||
;; returns #f on error.
|
||||
(import-lambda-definition set-wm-protocols! (display window protocols)
|
||||
"scx_Set_Wm_Protocols")
|
||||
|
||||
;; get-wm-class returns the class hint for the specified window. That
|
||||
;; is a pair of strings (name . class) See XGetClassHint.
|
||||
|
||||
;; raises scx-status-error on error.
|
||||
;; returns #f on error.
|
||||
(import-lambda-definition get-wm-class (display window)
|
||||
"scx_Get_Wm_Class")
|
||||
|
||||
;; set-wm-class! sets the class hint for the specified window. See
|
||||
;; XSetClassHint.
|
||||
|
||||
;; raises scx-status-error on error.
|
||||
;; returns #f on error.
|
||||
(import-lambda-definition set-wm-class! (display window name class)
|
||||
"scx_Set_Wm_Class")
|
||||
|
||||
|
|
@ -146,7 +146,7 @@
|
|||
(define xa-string 31) ;; defined in Xatom.h
|
||||
|
||||
(define (string-list->property strings)
|
||||
(make-property xa-string 8
|
||||
(make-property xa-string (property-format char)
|
||||
(string-list->string strings)))
|
||||
|
||||
;; The following function a wrappers for the get/set-text-property
|
||||
|
|
@ -156,23 +156,23 @@
|
|||
(define xa-wm-icon-name 37)
|
||||
(define xa-wm-client-machine 36)
|
||||
|
||||
(define (get-wm-name w)
|
||||
(get-text-property w xa-wm-name))
|
||||
(define (get-wm-name display w)
|
||||
(get-text-property display w xa-wm-name))
|
||||
|
||||
(define (get-wm-icon-name w)
|
||||
(get-text-property w xa-wm-icon-name))
|
||||
(define (get-wm-icon-name display w)
|
||||
(get-text-property display w xa-wm-icon-name))
|
||||
|
||||
(define (get-wm-client-machine w)
|
||||
(get-text-property w xa-wm-client-machine))
|
||||
(define (get-wm-client-machine display w)
|
||||
(get-text-property display w xa-wm-client-machine))
|
||||
|
||||
(define (set-wm-name! w s)
|
||||
(set-text-property! w s xa-wm-name))
|
||||
(define (set-wm-name! display w s)
|
||||
(set-text-property! display w s xa-wm-name))
|
||||
|
||||
(define (set-wm-icon-name! w s)
|
||||
(set-text-property! w s xa-wm-icon-name))
|
||||
(define (set-wm-icon-name! display w s)
|
||||
(set-text-property! display w s xa-wm-icon-name))
|
||||
|
||||
(define (set-wm-client-machine! w s)
|
||||
(set-text-property! w s xa-wm-client-machine))
|
||||
(define (set-wm-client-machine! display w s)
|
||||
(set-text-property! display w s xa-wm-client-machine))
|
||||
|
||||
;; an enumerated type for XSizeHints used by get-wm-normal-hints and
|
||||
;; set-wm-normal-hints!
|
||||
|
|
|
|||
|
|
@ -8,6 +8,8 @@
|
|||
(green color:green set-color:green!)
|
||||
(blue color:blue set-color:blue!))
|
||||
|
||||
(define-exported-binding "scx-color" :color)
|
||||
|
||||
(define-enumerated-type colormap-state :colormap-state
|
||||
colormap-state? colormap-states colormap-state-name colormap-state-index
|
||||
(uninstalled installed))
|
||||
|
|
|
|||
|
|
@ -53,9 +53,10 @@
|
|||
|
||||
(define-record-type screen :screen
|
||||
(make-screen cpointer display root-window width height width-mm
|
||||
height-mm depths root-depth default-visual default-gc
|
||||
height-mm number root-depth default-visual default-gc
|
||||
default-colormap white-pixel black-pixel max-maps min-maps
|
||||
does-backing-store does-save-unders? event-mask)
|
||||
;; maybe add depths ?? (TODO)
|
||||
;; does event-mask change ?? (TODO)
|
||||
screen?
|
||||
(cpointer screen:cpointer)
|
||||
|
|
@ -65,7 +66,7 @@
|
|||
(height screen:height)
|
||||
(width-mm screen:width-mm)
|
||||
(height-mm screen:height-mm)
|
||||
(depths screen:depths)
|
||||
(number screen:number)
|
||||
(root-depth screen:root-depth)
|
||||
(default-visual screen:default-visual)
|
||||
(default-gc screen:default-gc)
|
||||
|
|
@ -113,8 +114,6 @@
|
|||
(define no-symbol 0)
|
||||
(define all-planes (- (arithmetic-shift 1 32) 1))
|
||||
|
||||
;; *** record types **************************************************
|
||||
|
||||
(import-lambda-definition display:last-request-read (display)
|
||||
"scx_Display_Last_Request_Read")
|
||||
|
||||
|
|
@ -124,6 +123,14 @@
|
|||
(screen:root-window (list-ref (display:screens display)
|
||||
(display:default-screen display))))
|
||||
|
||||
(define (black-pixel display)
|
||||
(screen:black-pixel (list-ref (display:screens display)
|
||||
(display:default-screen display))))
|
||||
|
||||
(define (white-pixel display)
|
||||
(screen:white-pixel (list-ref (display:screens display)
|
||||
(display:default-screen display))))
|
||||
|
||||
(import-lambda-definition next-request (display)
|
||||
"scx_Next_Request")
|
||||
|
||||
|
|
|
|||
|
|
@ -26,11 +26,148 @@
|
|||
|
||||
;; *** error exceptions **********************************************
|
||||
|
||||
;; Call synchronize to have the exceptions signaled where they belong to.
|
||||
(define (opcode->string oc)
|
||||
(case oc
|
||||
((1) "X_CreateWindow")
|
||||
((2) "X_ChangeWindowAttributes")
|
||||
((3) "X_GetWindowAttributes")
|
||||
((4) "X_DestroyWindow")
|
||||
((5) "X_DestroySubwindows")
|
||||
((6) "X_ChangeSaveSet")
|
||||
((7) "X_ReparentWindow")
|
||||
((8) "X_MapWindow")
|
||||
((9) "X_MapSubwindows")
|
||||
((10) "X_UnmapWindow")
|
||||
((11) "X_UnmapSubwindows")
|
||||
((12) "X_ConfigureWindow")
|
||||
((13) "X_CirculateWindow")
|
||||
((14) "X_GetGeometry")
|
||||
((15) "X_QueryTree")
|
||||
((16) "X_InternAtom")
|
||||
((17) "X_GetAtomName")
|
||||
((18) "X_ChangeProperty")
|
||||
((19) "X_DeleteProperty")
|
||||
((20) "X_GetProperty")
|
||||
((21) "X_ListProperties")
|
||||
((22) "X_SetSelectionOwner")
|
||||
((23) "X_GetSelectionOwner")
|
||||
((24) "X_ConvertSelection")
|
||||
((25) "X_SendEvent")
|
||||
((26) "X_GrabPointer")
|
||||
((27) "X_UngrabPointer")
|
||||
((28) "X_GrabButton")
|
||||
((29) "X_UngrabButton")
|
||||
((30) "X_ChangeActivePointerGrab")
|
||||
((31) "X_GrabKeyboard")
|
||||
((32) "X_UngrabKeyboard")
|
||||
((33) "X_GrabKey")
|
||||
((34) "X_UngrabKey")
|
||||
((35) "X_AllowEvents")
|
||||
((36) "X_GrabServer")
|
||||
((37) "X_UngrabServer")
|
||||
((38) "X_QueryPointer")
|
||||
((39) "X_GetMotionEvents")
|
||||
((40) "X_TranslateCoords")
|
||||
((41) "X_WarpPointer")
|
||||
((42) "X_SetInputFocus")
|
||||
((43) "X_GetInputFocus")
|
||||
((44) "X_QueryKeymap")
|
||||
((45) "X_OpenFont")
|
||||
((46) "X_CloseFont")
|
||||
((47) "X_QueryFont")
|
||||
((48) "X_QueryTextExtents")
|
||||
((49) "X_ListFonts")
|
||||
((50) "X_ListFontsWithInfo")
|
||||
((51) "X_SetFontPath")
|
||||
((52) "X_GetFontPath")
|
||||
((53) "X_CreatePixmap")
|
||||
((54) "X_FreePixmap")
|
||||
((55) "X_CreateGC")
|
||||
((56) "X_ChangeGC")
|
||||
((57) "X_CopyGC")
|
||||
((58) "X_SetDashes")
|
||||
((59) "X_SetClipRectangles")
|
||||
((60) "X_FreeGC")
|
||||
((61) "X_ClearArea")
|
||||
((62) "X_CopyArea")
|
||||
((63) "X_CopyPlane")
|
||||
((64) "X_PolyPoint")
|
||||
((65) "X_PolyLine")
|
||||
((66) "X_PolySegment")
|
||||
((67) "X_PolyRectangle")
|
||||
((68) "X_PolyArc")
|
||||
((69) "X_FillPoly")
|
||||
((70) "X_PolyFillRectangle")
|
||||
((71) "X_PolyFillArc")
|
||||
((72) "X_PutImage")
|
||||
((73) "X_GetImage")
|
||||
((74) "X_PolyText8")
|
||||
((75) "X_PolyText16")
|
||||
((76) "X_ImageText8")
|
||||
((77) "X_ImageText16")
|
||||
((78) "X_CreateColormap")
|
||||
((79) "X_FreeColormap")
|
||||
((80) "X_CopyColormapAndFree")
|
||||
((81) "X_InstallColormap")
|
||||
((82) "X_UninstallColormap")
|
||||
((83) "X_ListInstalledColormaps")
|
||||
((84) "X_AllocColor")
|
||||
((85) "X_AllocNamedColor")
|
||||
((86) "X_AllocColorCells")
|
||||
((87) "X_AllocColorPlanes")
|
||||
((88) "X_FreeColors")
|
||||
((89) "X_StoreColors")
|
||||
((90) "X_StoreNamedColor")
|
||||
((91) "X_QueryColors")
|
||||
((92) "X_LookupColor")
|
||||
((93) "X_CreateCursor")
|
||||
((94) "X_CreateGlyphCursor")
|
||||
((95) "X_FreeCursor")
|
||||
((96) "X_RecolorCursor")
|
||||
((97) "X_QueryBestSize")
|
||||
((98) "X_QueryExtension")
|
||||
((99) "X_ListExtensions")
|
||||
((100) "X_ChangeKeyboardMapping")
|
||||
((101) "X_GetKeyboardMapping")
|
||||
((102) "X_ChangeKeyboardControl")
|
||||
((103) "X_GetKeyboardControl")
|
||||
((104) "X_Bell")
|
||||
((105) "X_ChangePointerControl")
|
||||
((106) "X_GetPointerControl")
|
||||
((107) "X_SetScreenSaver")
|
||||
((108) "X_GetScreenSaver")
|
||||
((109) "X_ChangeHosts")
|
||||
((110) "X_ListHosts")
|
||||
((111) "X_SetAccessControl")
|
||||
((112) "X_SetCloseDownMode")
|
||||
((113) "X_KillClient")
|
||||
((114) "X_RotateProperties")
|
||||
((115) "X_ForceScreenSaver")
|
||||
((116) "X_SetPointerMapping")
|
||||
((117) "X_GetPointerMapping")
|
||||
((118) "X_SetModifierMapping")
|
||||
((119) "X_GetModifierMapping")
|
||||
((127) "X_NoOperation")
|
||||
(else "unknown")))
|
||||
|
||||
(define (use-x-error-exceptions!)
|
||||
(define (x-error->string e)
|
||||
(string-append (x-error:text e) "\n"
|
||||
" Major Opcode: " (number->string (x-error:major-opcode e))
|
||||
" (" (opcode->string (x-error:major-opcode e)) ")\n"
|
||||
" Resource ID: " (number->string (x-error:resource-id e))))
|
||||
|
||||
(define-condition-type 'x-warning '(warning))
|
||||
(define x-warning? (condition-predicate 'x-warning))
|
||||
(define (x-warning:x-error w)
|
||||
(cadr (condition-stuff w)))
|
||||
(define (signal-x-warning x-error)
|
||||
(signal 'x-warning (x-error->string x-error) x-error))
|
||||
|
||||
;; Call synchronize to have the warnings signaled where they belong to.
|
||||
|
||||
(define (use-x-error-warnings!)
|
||||
(set-error-handler! (lambda (display error)
|
||||
(error "x-exception: " display error)))) ;; TODO
|
||||
(signal-x-warning error))))
|
||||
|
||||
;; *** error-queue ***************************************************
|
||||
|
||||
|
|
@ -73,17 +210,25 @@
|
|||
|
||||
;; *** default error handlers ****************************************
|
||||
|
||||
(import-lambda-definition %set-error-handler (handler)
|
||||
"scx_Set_Error_Handler")
|
||||
|
||||
(import-lambda-definition call-c-error-handler (pointer display event)
|
||||
"scx_Call_C_Error_Handler")
|
||||
(define *x-error-handler* #f)
|
||||
(define-exported-binding "internal-x-error-handler" *x-error-handler*)
|
||||
|
||||
(define (set-error-handler! handler)
|
||||
(let ((res (%set-error-handler handler)))
|
||||
(if (number? res)
|
||||
(lambda (display event) (call-c-error-handler (res display event)))
|
||||
res)))
|
||||
(let ((old-handler *x-error-handler*))
|
||||
(set! *x-error-handler* handler)
|
||||
old-handler))
|
||||
|
||||
;(import-lambda-definition %set-error-handler (handler)
|
||||
; "scx_Set_Error_Handler")
|
||||
|
||||
;(import-lambda-definition call-c-error-handler (pointer display event)
|
||||
; "scx_Call_C_Error_Handler")
|
||||
|
||||
;(define (set-error-handler! handler)
|
||||
; (let ((res (%set-error-handler handler)))
|
||||
; (if (number? res)
|
||||
; (lambda (display event) (call-c-error-handler (res display event)))
|
||||
; res)))
|
||||
|
||||
(import-lambda-definition get-error-text (display code)
|
||||
"scx_Get_Error_Text")
|
||||
|
|
@ -95,14 +240,15 @@
|
|||
;(import-lambda-definition %set-io-error-handler (handler)
|
||||
; "scx_Set_IO_Error_Handler")
|
||||
|
||||
(define *x-fatal-error-handler* ;; TODO do it like above??
|
||||
(lambda (display)
|
||||
#f))
|
||||
|
||||
(define *x-fatal-error-handler* #f)
|
||||
(define-exported-binding "internal-x-fatal-error-handler"
|
||||
*x-fatal-error-handler*)
|
||||
|
||||
(define (set-io-error-handler handler)
|
||||
(define (set-fatal-error-handler! handler)
|
||||
(let ((old-handler *x-fatal-error-handler*))
|
||||
(set! *x-fatal-error-handler* handler)
|
||||
old-handler))
|
||||
|
||||
;; *** The default is to use warnings ********************************
|
||||
|
||||
(use-x-error-warnings!)
|
||||
|
|
|
|||
|
|
@ -8,20 +8,28 @@
|
|||
(block-on-message-inport dpy))
|
||||
(next-event dpy))
|
||||
|
||||
(define (block-on-message-inport dpy) ; needs ports, locks
|
||||
(define (block-on-message-inport dpy)
|
||||
(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!))))
|
||||
(call-with-values
|
||||
(lambda () (select (vector port) (vector) (vector)))
|
||||
(lambda (ready-read ready-write ex)
|
||||
(if (not (member port (vector->list ready-read)))
|
||||
(block-on-message-inport dpy))))))
|
||||
|
||||
;;; Only here until scsh provides us with select
|
||||
(import-lambda-definition add-pending-channel (channel)
|
||||
"scx_add_pending_channel")
|
||||
;(define (block-on-message-inport 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!))))
|
||||
|
||||
;;;; Only here until scsh provides us with select
|
||||
;(import-lambda-definition add-pending-channel (channel)
|
||||
; "scx_add_pending_channel")
|
||||
|
||||
;; How to find out if there are events available *********************
|
||||
|
||||
|
|
|
|||
|
|
@ -1,3 +1,11 @@
|
|||
(define (with-lock lock thunk)
|
||||
(obtain-lock lock)
|
||||
(let ((res (thunk)))
|
||||
(release-lock lock)
|
||||
res))
|
||||
|
||||
;; Thread-safe event queue *******************************************
|
||||
|
||||
(define-record-type sync-x-event :sync-x-event
|
||||
(really-make-sync-x-event event next)
|
||||
sync-x-event?
|
||||
|
|
@ -18,15 +26,206 @@
|
|||
(really-next-sync-x-event sync-x-event)
|
||||
next-sync-x-event))
|
||||
|
||||
(define (init-sync-x-events dpy)
|
||||
(let ((most-recent-sync-x-event (make-sync-x-event 'no-event)))
|
||||
(define *most-recent-sync-x-event* (make-sync-x-event 'no-event))
|
||||
(define *most-recent-lock* (make-lock))
|
||||
|
||||
(define (init-sync-x-events display)
|
||||
(spawn
|
||||
(lambda ()
|
||||
(let lp ()
|
||||
(let ((next (wait-event display)))
|
||||
(with-lock *most-recent-lock*
|
||||
(lambda ()
|
||||
(set-next-sync-x-event! *most-recent-sync-x-event*
|
||||
(make-sync-x-event next))
|
||||
(set! *most-recent-sync-x-event*
|
||||
(placeholder-value (really-next-sync-x-event
|
||||
*most-recent-sync-x-event*)))))
|
||||
(lp))))))
|
||||
|
||||
(define (most-recent-sync-x-event)
|
||||
*most-recent-sync-x-event*)
|
||||
|
||||
;; High-Level Event-Dispatcher ***************************************
|
||||
|
||||
;; contains (display window event-mask) triples
|
||||
(define *event-requests* '())
|
||||
(define *event-requests-lock* (make-lock))
|
||||
|
||||
(define (make-request display window event-mask)
|
||||
(list display window event-mask))
|
||||
|
||||
(define (add-request! req)
|
||||
(with-lock *event-requests-lock*
|
||||
(lambda ()
|
||||
(set! *event-requests*
|
||||
(cons req *event-requests*))
|
||||
(select-requests))))
|
||||
|
||||
(define (remove-request! req)
|
||||
(with-lock *event-requests-lock*
|
||||
(lambda ()
|
||||
(set! *event-requests*
|
||||
(filter (lambda (r) (not (eq? r req))) *event-requests*))
|
||||
(select-requests))))
|
||||
|
||||
(define request:display car)
|
||||
(define request:window cadr)
|
||||
(define request:event-mask caddr)
|
||||
|
||||
(define (event-masks-union masks)
|
||||
(fold-right (lambda (m res)
|
||||
(enum-set-union m res))
|
||||
(event-mask)
|
||||
masks))
|
||||
|
||||
(define (select-requests)
|
||||
(let loop ((rest *event-requests*))
|
||||
(if (not (null? rest))
|
||||
(let ((r (car rest)))
|
||||
(call-with-values
|
||||
(lambda ()
|
||||
(partition (lambda (r2)
|
||||
;; find all with the same display and window
|
||||
(and (eq? (request:display r2) (request:display r))
|
||||
(eq? (request:window r2) (request:window r))))
|
||||
(cdr rest)))
|
||||
(lambda (same rest)
|
||||
(let ((mask (event-masks-union (map request:event-mask
|
||||
(cons r same)))))
|
||||
(display-select-input (request:display r) (request:window r)
|
||||
mask))
|
||||
(loop rest)))))))
|
||||
|
||||
(define (call-with-event-channel display window event-mask fun)
|
||||
(let ((r (make-request display window event-mask))
|
||||
(channel (make-channel)))
|
||||
(spawn-event-filter (most-recent-sync-x-event)
|
||||
channel display window event-mask)
|
||||
(dynamic-wind
|
||||
(lambda () (add-request! r))
|
||||
(lambda () (fun channel))
|
||||
(lambda () (remove-request! r)))))
|
||||
|
||||
(define (spawn-event-filter se out-channel display window event-mask)
|
||||
(let ((pred (lambda (e)
|
||||
(and (eq? (any-event-display e) display)
|
||||
(matches-event-mask? window event-mask e)))))
|
||||
(spawn (lambda ()
|
||||
(let lp ()
|
||||
(let ((next (wait-event dpy)))
|
||||
(set-next-sync-x-event! most-recent-sync-x-event
|
||||
(make-sync-x-event next))
|
||||
(set! most-recent-sync-x-event
|
||||
(placeholder-value (really-next-sync-x-event
|
||||
most-recent-sync-x-event))))
|
||||
(lp))))
|
||||
(lambda () most-recent-sync-x-event)))
|
||||
(let loop ((se se))
|
||||
(let ((nse (next-sync-x-event se pred)))
|
||||
(send out-channel (sync-x-event-event nse))
|
||||
(loop nse)))))))
|
||||
|
||||
(define (matches-event-mask? window event-mask event)
|
||||
(let ((type (any-event-type event)))
|
||||
(cond
|
||||
;; keymap-event has no window element
|
||||
((eq? type (event-type keymap-notify))
|
||||
(enum-set-member? event-mask (event-mask-item keymap-state)))
|
||||
;; other events must have at least the correct window
|
||||
((not (eq? window (any-event-window event)))
|
||||
#f)
|
||||
;; these event are send always because they do not depend on a mask
|
||||
((or (eq? type (event-type client-message))
|
||||
(eq? type (event-type mapping-notify))
|
||||
(eq? type (event-type selection-clear))
|
||||
(eq? type (event-type selection-notify))
|
||||
(eq? type (event-type selection-request)))
|
||||
#t)
|
||||
;; these do not depend an an event-mask too, but on a flag in GC,
|
||||
;; so we sent it too
|
||||
((or (eq? type (event-type graphics-expose))
|
||||
(eq? type (event-type no-expose)))
|
||||
#t)
|
||||
|
||||
;; OwnerGrabButtonMask only generates extra events between a
|
||||
;; ButtonPress and ButtonRelease event and does not be respected
|
||||
;; here
|
||||
|
||||
;; PointerMotionHintMask only has an effect if one of the
|
||||
;; ButtonMotion Masks or PointerMotionMask is selected, so we
|
||||
;; don't have to take a look at it here.
|
||||
|
||||
;; for the rest one of the event-mask items must match the type
|
||||
((any (lambda (mask-item)
|
||||
(matches-event-mask-2? type window event mask-item))
|
||||
(enum-set->list event-mask))
|
||||
#t)
|
||||
(else #f))))
|
||||
|
||||
(define (matches-event-mask-2? type window event mask-item)
|
||||
(cond
|
||||
((or (eq? mask-item (event-mask-item button-motion))
|
||||
(eq? mask-item (event-mask-item button-1-motion))
|
||||
(eq? mask-item (event-mask-item button-2-motion))
|
||||
(eq? mask-item (event-mask-item button-3-motion))
|
||||
(eq? mask-item (event-mask-item button-4-motion))
|
||||
(eq? mask-item (event-mask-item button-5-motion)))
|
||||
(eq? type (event-type motion-notify)))
|
||||
((eq? mask-item (event-mask-item button-press))
|
||||
(eq? type (event-type button-press)))
|
||||
((eq? mask-item (event-mask-item button-release))
|
||||
(eq? type (event-type button-release)))
|
||||
((eq? mask-item (event-mask-item colormap-change))
|
||||
(eq? type (event-type colormap-notify)))
|
||||
((eq? mask-item (event-mask-item enter-window))
|
||||
(eq? type (event-type enter-notify)))
|
||||
((eq? mask-item (event-mask-item leave-window))
|
||||
(eq? type (event-type leave-notify)))
|
||||
((eq? mask-item (event-mask-item exposure))
|
||||
(eq? type (event-type expose)))
|
||||
((eq? mask-item (event-mask-item focus-change))
|
||||
(or (eq? type (event-type focus-in))
|
||||
(eq? type (event-type focus-out))))
|
||||
((eq? mask-item (event-mask-item keymap-state))
|
||||
(eq? type (event-type keymap-notify)))
|
||||
((eq? mask-item (event-mask-item key-press))
|
||||
(eq? type (event-type key-press)))
|
||||
((eq? mask-item (event-mask-item key-release))
|
||||
(eq? type (event-type key-release)))
|
||||
((eq? mask-item (event-mask-item pointer-motion))
|
||||
(eq? type (event-type motion-notify)))
|
||||
((eq? mask-item (event-mask-item property-change))
|
||||
(eq? type (event-type property-notify)))
|
||||
((eq? mask-item (event-mask-item resize-redirect))
|
||||
(eq? type (event-type resize-request)))
|
||||
((eq? mask-item (event-mask-item structure-notify))
|
||||
(or (and (eq? type (event-type circulate-notify))
|
||||
(eq? window (circulate-event-window event)))
|
||||
(and (eq? type (event-type configure-notify))
|
||||
(eq? window (configure-event-window event)))
|
||||
(and (eq? type (event-type destroy-notify))
|
||||
(eq? window (destroy-window-event-window event)))
|
||||
(and (eq? type (event-type gravity-notify))
|
||||
(eq? window (gravity-event-window event)))
|
||||
(and (eq? type (event-type map-notify))
|
||||
(eq? window (map-event-window event)))
|
||||
(and (eq? type (event-type reparent-notify))
|
||||
(eq? window (reparent-event-window event)))
|
||||
(and (eq? type (event-type unmap-notify))
|
||||
(eq? window (unmap-event-window event)))))
|
||||
((eq? mask-item (event-mask-item substructure-notify))
|
||||
(or (and (eq? type (event-type circulate-notify))
|
||||
(not (eq? window (circulate-event-window event))))
|
||||
(and (eq? type (event-type configure-notify))
|
||||
(not (eq? window (configure-event-window event))))
|
||||
(and (eq? type (event-type create-notify))
|
||||
(not (eq? window (create-window-event-window event))))
|
||||
(and (eq? type (event-type destroy-notify))
|
||||
(not (eq? window (destroy-window-event-window event))))
|
||||
(and (eq? type (event-type gravity-notify))
|
||||
(not (eq? window (gravity-event-window event))))
|
||||
(and (eq? type (event-type map-notify))
|
||||
(not (eq? window (map-event-window event))))
|
||||
(and (eq? type (event-type reparent-notify))
|
||||
(not (eq? window (reparent-event-window event))))
|
||||
(and (eq? type (event-type unmap-notify))
|
||||
(not (eq? window (unmap-event-window event))))))
|
||||
((eq? mask-item (event-mask-item substructure-redirect))
|
||||
(or (eq? type (event-type circulate-request))
|
||||
(eq? type (event-type configure-request))
|
||||
(eq? type (event-type map-request))))
|
||||
((eq? mask-item (event-mask-item visibility-change))
|
||||
(eq? type (event-type visibility-notify)))
|
||||
(else #f)))
|
||||
|
|
|
|||
|
|
@ -37,6 +37,8 @@
|
|||
override-redirect save-under event-mask do-not-propagate-mask colormap
|
||||
cursor))
|
||||
|
||||
(define-exported-binding "scx-set-window-attribute" :set-window-attribute)
|
||||
|
||||
(define-syntax make-set-window-attribute-alist
|
||||
(syntax-rules
|
||||
()
|
||||
|
|
|
|||
|
|
@ -1,4 +1,6 @@
|
|||
(define :enumeration :syntax)
|
||||
(define :display :value)
|
||||
(define :x-error :value)
|
||||
|
||||
(define-interface xlib-internal-interface
|
||||
(export
|
||||
|
|
@ -28,7 +30,7 @@
|
|||
|
||||
screen?
|
||||
screen:display screen:root-window screen:width screen:height
|
||||
screen:width-mm screen:height-mm screen:depths screen:root-depth
|
||||
screen:width-mm screen:height-mm screen:number screen:root-depth
|
||||
screen:default-visual screen:default-gc screen:default-colormap
|
||||
screen:white-pixel screen:black-pixel screen:max-maps
|
||||
screen:min-maps screen:does-backing-store screen:does-save-unders?
|
||||
|
|
@ -173,26 +175,32 @@
|
|||
x-error:text
|
||||
|
||||
(error-code :syntax) error-code?
|
||||
use-x-error-exceptions!
|
||||
use-x-error-warnings!
|
||||
use-x-error-queue!
|
||||
|
||||
x-error-queue? x-error-queue:this
|
||||
empty-x-error-queue?
|
||||
next-x-error-queue
|
||||
|
||||
set-error-handler!
|
||||
((set-error-handler!) (proc ((proc (:display :x-error) :value))
|
||||
(proc (:display :x-error) :value)))
|
||||
get-error-text
|
||||
get-error-database-text
|
||||
|
||||
set-io-error-handler
|
||||
((set-fatal-error-handler!) (proc ((proc (:display) :value))
|
||||
(proc (:display) :value)))
|
||||
|
||||
;; sync-event.scm *************************************************
|
||||
init-sync-x-events
|
||||
sync-x-event? sync-x-event-event
|
||||
next-sync-x-event
|
||||
most-recent-sync-x-event
|
||||
|
||||
call-with-event-channel
|
||||
|
||||
;; event-types.scm ************************************************
|
||||
(event-type :enumeration)
|
||||
(event-mask :syntax)
|
||||
any-event-type
|
||||
any-event-serial
|
||||
any-event-send-event?
|
||||
|
|
|
|||
|
|
@ -12,8 +12,8 @@
|
|||
(define :enum-set-type (record-ref test-value 0))
|
||||
(define-exported-binding "s48-enum-set-type" :enum-set-type)))
|
||||
|
||||
(define-structures ((xlib-internal xlib-internal-interface)
|
||||
(xlib xlib-interface))
|
||||
(define-structures ((xlib xlib-interface)
|
||||
(xlib-internal xlib-internal-interface))
|
||||
(open scsh-level-0
|
||||
scheme
|
||||
list-lib
|
||||
|
|
@ -30,7 +30,9 @@
|
|||
ports locks
|
||||
channel-i/o
|
||||
interrupts
|
||||
ascii)
|
||||
ascii
|
||||
conditions
|
||||
rendezvous-channels)
|
||||
(files display
|
||||
visual
|
||||
colormap
|
||||
|
|
|
|||
Loading…
Reference in New Issue