- 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

c/xlib/client.c

@@ -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) {
+    p->flags |= (1L << h);
-    case 0:
+    switch (1L << h) {
-      p->flags |= InputHint;
+    case InputHint:
       p->input = S48_EXTRACT_BOOLEAN(v);
       break;
-    case 1:
+    case StateHint:
-      p->flags |= StateHint;
       p->initial_state = scx_extract_initial_state(v);
       break;
-    case 2:
+    case IconPixmapHint:
-      p->flags |= IconPixmapHint;
       p->icon_pixmap = scx_extract_pixmap(v);
       break;
-    case 3:
+    case IconWindowHint:
-      p->flags |= IconWindowHint;
       p->icon_window = scx_extract_window(v);
       break;
-    case 4:
+    case IconPositionHint:
-      p->flags |= IconPositionHint;
       p->icon_x = s48_extract_integer(S48_CAR(v));
       p->icon_y = s48_extract_integer(S48_CDR(v));
       break;
-    case 5:
+    case IconMaskHint:
-      p->flags |= IconMaskHint;
       p->icon_mask = scx_extract_pixmap(v);
       break;
-    case 6:
+    case WindowGroupHint:
-      p->flags |= WindowGroupHint;
       p->window_group = scx_extract_window(v);
       break;
-    case 7:
+    case XUrgencyHint:
-      if (S48_EXTRACT_BOOLEAN(v))
+      if (v == S48_FALSE)
-	p->flags |= XUrgencyHint;
+	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--)

c/xlib/display.c

@@ -14,9 +14,13 @@ 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_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)));
@@ -25,7 +29,7 @@ s48_value scx_enter_screen(Screen* 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, 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)));
@@ -38,6 +42,7 @@ s48_value scx_enter_screen(Screen* 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);

c/xlib/error.c

@@ -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,
+  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 */
+static int fatal_error_handler_wrapper(Display* d) {
-extern int _XDefaultIOError();   
-extern int _XDefaultError();
-
-static X_Fatal_Error (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),
+  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:
+  // 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_Set_Error_Handler);
-  S48_EXPORT_FUNCTION(scx_Call_C_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)XSetIOErrorHandler(fatal_error_handler_wrapper);
-  //(void)XSetErrorHandler(X_Error);
+  (void)XSetErrorHandler(error_handler_wrapper);
 }

c/xlib/event-types.c

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

c/xlib/gcontext.c

@@ -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;
+    mask = mask | (1L << mv);
-    switch (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:
@@ -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), 

c/xlib/types.c

@@ -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_value previous = S48_FALSE;
-  S48_DECLARE_GC_PROTECT(2);
+  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_value entry = S48_WEAK_POINTER_REF(S48_CDR(S48_CAR(list)));
-      S48_GC_PROTECT_1(list);
+    if ((entry == S48_FALSE) || (S48_EXTRACT_POINTER(entry) == cpointer))
-      wp = s48_make_weak_pointer(v);
+      S48_SET_CDR(previous, S48_CDR(list));
-      S48_SET_CDR(S48_CAR(list), wp);
+    else
-      S48_GC_UNPROTECT();
+      previous = list;
-      return;
-    }
     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();
 }
 

c/xlib/window.c

@@ -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;
+    mask = mask | (1L << mv);
-    switch (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;
+    mask = mask | (1L << mv);
-    switch (mv) {
+    switch (1L << mv) {
     case CWX:
       WC->x = s48_extract_integer(v); break;
     case CWY:

c/xlib/xlib.h

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

scheme/xlib/client.scm

@@ -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)
+(define (get-wm-name display w)
-  (get-text-property w xa-wm-name))
+  (get-text-property display w xa-wm-name))
 
-(define (get-wm-icon-name w)
+(define (get-wm-icon-name display w)
-  (get-text-property w xa-wm-icon-name))
+  (get-text-property display w xa-wm-icon-name))
 
-(define (get-wm-client-machine w)
+(define (get-wm-client-machine display w)
-  (get-text-property w xa-wm-client-machine))
+  (get-text-property display w xa-wm-client-machine))
 
-(define (set-wm-name! w s)
+(define (set-wm-name! display w s)
-  (set-text-property! w s xa-wm-name))
+  (set-text-property! display w s xa-wm-name))
 
-(define (set-wm-icon-name! w s)
+(define (set-wm-icon-name! display w s)
-  (set-text-property! w s xa-wm-icon-name))
+  (set-text-property! display w s xa-wm-icon-name))
 
-(define (set-wm-client-machine! w s)
+(define (set-wm-client-machine! display w s)
-  (set-text-property! w s xa-wm-client-machine))
+  (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!

scheme/xlib/colormap.scm

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

scheme/xlib/display.scm

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

scheme/xlib/error.scm

@@ -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)
+(define *x-error-handler* #f)
-  "scx_Set_Error_Handler")
+(define-exported-binding "internal-x-error-handler" *x-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)))
+  (let ((old-handler *x-error-handler*))
-    (if (number? res)
+    (set! *x-error-handler* handler)
-	(lambda (display event) (call-c-error-handler (res display event)))
+    old-handler))
-	res)))
+
+;(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??
+(define *x-fatal-error-handler* #f)
-  (lambda (display)
-    #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!)

scheme/xlib/event.scm

@@ -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!)
+    (call-with-values
-    (if (not (char-ready? port))
+     (lambda () (select (vector port) (vector) (vector)))
-	(begin 
+     (lambda (ready-read ready-write ex)
-	  (obtain-lock (port-lock port))
+       (if (not (member port (vector->list ready-read)))
-	  (add-pending-channel (port->channel port))
+	   (block-on-message-inport dpy))))))
-	  (wait-for-channel (port->channel port)) ;; enables interrupts
-	  (release-lock (port-lock port)))
-	(enable-interrupts!))))
 
-;;; Only here until scsh provides us with select
+;(define (block-on-message-inport dpy) ; needs ports, locks
-(import-lambda-definition add-pending-channel (channel)
+;  (let ((port (display-message-inport dpy)))
-  "scx_add_pending_channel")
+;    (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 *********************
 

scheme/xlib/sync-event.scm

@@ -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)
+(define *most-recent-sync-x-event* (make-sync-x-event 'no-event))
-  (let ((most-recent-sync-x-event (make-sync-x-event 'no-event)))
+(define *most-recent-lock* (make-lock))
-    (spawn (lambda ()
+
+(define (init-sync-x-events display)
+  (spawn
+   (lambda ()
      (let lp ()
-	       (let ((next (wait-event dpy)))
+       (let ((next (wait-event display)))
-		 (set-next-sync-x-event! most-recent-sync-x-event
+	 (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
+		      (set! *most-recent-sync-x-event*
 			    (placeholder-value (really-next-sync-x-event
-					   most-recent-sync-x-event))))
+						*most-recent-sync-x-event*)))))
-	       (lp))))
+	 (lp))))))
-    (lambda () most-recent-sync-x-event)))
+
+(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 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)))

scheme/xlib/window.scm

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

scheme/xlib/xlib-interfaces.scm

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

scheme/xlib/xlib-packages.scm

@@ -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)
+(define-structures ((xlib xlib-interface)
-		    (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