From 9967c456ee43efe7da1e21063f87824ab02c4e83 Mon Sep 17 00:00:00 2001 From: frese Date: Tue, 25 Mar 2003 18:27:18 +0000 Subject: [PATCH] - fixed some small bugs and typos - changed error and after-function handling a bit - added screen caching - added timeout in wait-event implementation (did not work with multiple threads) --- c/xlib/client.c | 2 +- c/xlib/display.c | 20 +++++++----- c/xlib/error.c | 45 ++++++-------------------- c/xlib/event-types.c | 16 +++++----- c/xlib/gcontext.c | 3 +- c/xlib/property.c | 3 ++ c/xlib/text.c | 6 ++-- c/xlib/types.c | 5 +-- c/xlib/window.c | 11 +++---- scheme/xlib/colormap.scm | 2 ++ scheme/xlib/display.scm | 56 +++++++++++++++++++++++++++------ scheme/xlib/error.scm | 12 +++++-- scheme/xlib/event-types.scm | 4 ++- scheme/xlib/event.scm | 19 +++++------ scheme/xlib/font.scm | 2 +- scheme/xlib/graphics.scm | 5 +++ scheme/xlib/sync-event.scm | 39 ++++++++++++----------- scheme/xlib/window.scm | 22 +++++++++++-- scheme/xlib/xlib-interfaces.scm | 13 +++++++- scheme/xlib/xlib-packages.scm | 2 +- 20 files changed, 175 insertions(+), 112 deletions(-) diff --git a/c/xlib/client.c b/c/xlib/client.c index 469c83b..7060318 100644 --- a/c/xlib/client.c +++ b/c/xlib/client.c @@ -131,7 +131,7 @@ s48_value scx_Set_Wm_Class(s48_value dpy, s48_value w, s48_value name, #define scx_enter_initial_state(x) S48_ENTER_ENUM(x, "scx-initial-states") #define scx_extract_wm_hint(x) S48_EXTRACT_ENUM(x, "scx-wm-hint") -#define scx_enter_wm_hint(x) S48_ENTER_ENUM(x, "scx-wm-hint") +#define scx_enter_wm_hint(x) S48_ENTER_ENUM(x, "scx-wm-hints") s48_value scx_enter_wm_hint_alist(XWMHints* p) { s48_value res = S48_NULL, t = S48_FALSE; diff --git a/c/xlib/display.c b/c/xlib/display.c index 316d4f1..6d2336d 100644 --- a/c/xlib/display.c +++ b/c/xlib/display.c @@ -22,6 +22,8 @@ s48_value scx_enter_screen(Screen* scr) { S48_DECLARE_GC_PROTECT(1); s = s48_make_record(scx_screen); S48_GC_PROTECT_1(s); + scx_struct_cache_set(scr, &scx_screen_list, 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))); @@ -34,10 +36,10 @@ s48_value scx_enter_screen(Screen* 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, 12, scx_enter_pixel(WhitePixelOfScreen(scr))); + S48_RECORD_SET(s, 13, scx_enter_pixel(BlackPixelOfScreen(scr))); + S48_RECORD_SET(s, 14, s48_enter_integer(MaxCmapsOfScreen(scr))); + S48_RECORD_SET(s, 15, s48_enter_integer(MinCmapsOfScreen(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))); @@ -50,7 +52,8 @@ s48_value scx_display_list = S48_NULL; static int scx_after_function_wrapper(Display* dpy) { s48_value display = scx_enter_display(dpy); - s48_value fun = SCX_DISPLAY_AFTER_FUNCTION(display); + s48_value fun = S48_SHARED_BINDING_REF( + s48_get_imported_binding("scx-general-after-function")); s48_call_scheme(fun, 1, display); return 0; } @@ -84,10 +87,11 @@ s48_value scx_enter_display(Display* 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); - S48_RECORD_SET(d, 14, S48_SHARED_BINDING_REF( - s48_get_imported_binding("scx-default-after-function"))); + S48_RECORD_SET(d, 14, S48_FALSE); XSetAfterFunction(dpy, &scx_after_function_wrapper); - + S48_RECORD_SET(d, 15, S48_FALSE); // wakeup placeholder + s48_call_scheme(S48_SHARED_BINDING_REF(s48_get_imported_binding( + "scx-initialize-display")), 1, d); S48_GC_UNPROTECT(); } return d; diff --git a/c/xlib/error.c b/c/xlib/error.c index 0fe1c7a..c2ad609 100644 --- a/c/xlib/error.c +++ b/c/xlib/error.c @@ -56,43 +56,21 @@ extern int _XDefaultError(); static s48_value internal_x_error_handler_binding = S48_FALSE; static int error_handler_wrapper(Display* dpy, XErrorEvent* e) { + char handled = 0; 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 + (S48_SHARED_BINDING_REF(internal_x_error_handler_binding) != S48_FALSE)){ + s48_value v = + s48_call_scheme(S48_SHARED_BINDING_REF(internal_x_error_handler_binding), + 2, + scx_enter_display(dpy), + scx_enter_x_error(e)); + handled = (v != S48_FALSE); + } + if (!handled) _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; - if (S48_POINTER_P(fun)) - previous = XSetErrorHandler(S48_EXTRACT_POINTER(fun)); - else if (S48_CLOSURE_P(fun)) { - previous = XSetErrorHandler(&error_handler_wrapper); - internal_error_handler_binding = fun; - } // TODO else error - if (previous == &error_handler_wrapper) - return maybe_previous; - else - return S48_ENTER_POINTER(previous); -} - -s48_value scx_Call_C_Error_Handler(s48_value pointer, s48_value display, - s48_value event) { - int (*procedure)() = S48_EXTRACT_POINTER(pointer); - XErrorEvent ev; int result; - scx_extract_x_error(event, &ev); - 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]; XGetErrorText(scx_extract_display(display), scx_extract_error_code(code), @@ -135,11 +113,8 @@ void scx_init_error() { 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_Get_Error_Text); S48_EXPORT_FUNCTION(scx_Get_Error_Database_Text); - //S48_EXPORT_FUNCTION(scx_Set_IO_Error_Handler); internal_x_fatal_error_handler_binding = s48_get_imported_binding("internal-x-fatal-error-handler"); diff --git a/c/xlib/event-types.c b/c/xlib/event-types.c index 39d0408..b4afb43 100644 --- a/c/xlib/event-types.c +++ b/c/xlib/event-types.c @@ -27,7 +27,7 @@ s48_value scx_enter_key_event(XKeyEvent* xe) { EENTER(9, y, s48_enter_integer); EENTER(10, x_root, s48_enter_integer); EENTER(11, y_root, s48_enter_integer); - EENTER(12, state, scx_enter_state); + EENTER(12, state, scx_enter_state_set); EENTER(13, keycode, scx_enter_keycode); EENTER(14, same_screen, S48_ENTER_BOOLEAN); EENTER_END(); @@ -43,7 +43,7 @@ s48_value scx_enter_button_event(XButtonEvent* xe) { EENTER(9, y, s48_enter_integer); EENTER(10, x_root, s48_enter_integer); EENTER(11, y_root, s48_enter_integer); - EENTER(12, state, scx_enter_state); + EENTER(12, state, scx_enter_state_set); EENTER(13, button, scx_enter_button); EENTER(14, same_screen, S48_ENTER_BOOLEAN); EENTER_END(); @@ -59,7 +59,7 @@ s48_value scx_enter_motion_event(XMotionEvent* xe) { EENTER(9, y, s48_enter_integer); EENTER(10, x_root, s48_enter_integer); EENTER(11, y_root, s48_enter_integer); - EENTER(12, state, scx_enter_state); + EENTER(12, state, scx_enter_state_set); EENTER(13, is_hint, S48_ENTER_BOOLEAN); EENTER(14, same_screen, S48_ENTER_BOOLEAN); EENTER_END(); @@ -79,7 +79,7 @@ s48_value scx_enter_crossing_event(XCrossingEvent* xe) { EENTER(13, detail, scx_enter_notify_detail); EENTER(14, same_screen, S48_ENTER_BOOLEAN); EENTER(15, focus, S48_ENTER_BOOLEAN); - EENTER(16, state, scx_enter_state); + EENTER(16, state, scx_enter_state_set); EENTER_END(); } @@ -406,7 +406,7 @@ void scx_extract_key_event(s48_value e, XKeyEvent* xe) { EEXTRACT(9, y, s48_extract_integer); EEXTRACT(10, x_root, s48_extract_integer); EEXTRACT(11, y_root, s48_extract_integer); - EEXTRACT(12, state, scx_extract_state); + EEXTRACT(12, state, scx_extract_state_set); EEXTRACT(13, keycode, scx_extract_keycode); EEXTRACT(14, same_screen, S48_EXTRACT_BOOLEAN); EEXTRACT_END(); @@ -422,7 +422,7 @@ void scx_extract_button_event(s48_value e, XButtonEvent* xe) { EEXTRACT(9, y, s48_extract_integer); EEXTRACT(10, x_root, s48_extract_integer); EEXTRACT(11, y_root, s48_extract_integer); - EEXTRACT(12, state, scx_extract_state); + EEXTRACT(12, state, scx_extract_state_set); EEXTRACT(13, button, scx_extract_button); EEXTRACT(14, same_screen, S48_EXTRACT_BOOLEAN); EEXTRACT_END(); @@ -438,7 +438,7 @@ void scx_extract_motion_event(s48_value e, XMotionEvent* xe) { EEXTRACT(9, y, s48_extract_integer); EEXTRACT(10, x_root, s48_extract_integer); EEXTRACT(11, y_root, s48_extract_integer); - EEXTRACT(12, state, scx_extract_state); + EEXTRACT(12, state, scx_extract_state_set); EEXTRACT(13, is_hint, S48_EXTRACT_BOOLEAN); EEXTRACT(14, same_screen, S48_EXTRACT_BOOLEAN); EEXTRACT_END(); @@ -458,7 +458,7 @@ void scx_extract_crossing_event(s48_value e, XCrossingEvent* xe) { EEXTRACT(13, detail, scx_extract_notify_detail); EEXTRACT(14, same_screen, S48_EXTRACT_BOOLEAN); EEXTRACT(15, focus, S48_EXTRACT_BOOLEAN); - EEXTRACT(16, state, scx_extract_state); + EEXTRACT(16, state, scx_extract_state_set); EEXTRACT_END(); } diff --git a/c/xlib/gcontext.c b/c/xlib/gcontext.c index 53d09a8..06c84b0 100644 --- a/c/xlib/gcontext.c +++ b/c/xlib/gcontext.c @@ -41,8 +41,7 @@ s48_value scx_enter_charstruct(XCharStruct* cs) { s48_value scx_enter_fontstruct(XFontStruct* fs) { int i; s48_value plist = S48_NULL, t = S48_NULL; - s48_value res = - s48_make_record(s48_get_imported_binding("scx-font-struct")); + s48_value res = s48_make_record(scx_fontstruct); S48_DECLARE_GC_PROTECT(3); S48_GC_PROTECT_3(res, plist, t); S48_RECORD_SET(res, 0, S48_ENTER_POINTER(fs)); diff --git a/c/xlib/property.c b/c/xlib/property.c index 4b55594..61e4783 100644 --- a/c/xlib/property.c +++ b/c/xlib/property.c @@ -129,14 +129,17 @@ s48_value scx_enter_property(Atom type, int format, char* data, switch (format) { case 8: S48_RECORD_SET(p, 2, s48_enter_substring(data, nelements)); + break; case 16: for (i = nelements-1; i >= 0; i--) l = s48_cons(s48_enter_integer(((short*)data)[i]), l); S48_RECORD_SET(p, 2, l); + break; case 32: for (i = nelements-1; i >= 0; i--) l = s48_cons(s48_enter_integer(((long*)data)[i]), l); S48_RECORD_SET(p, 2, l); + break; } S48_GC_UNPROTECT(); return p; diff --git a/c/xlib/text.c b/c/xlib/text.c index bf17720..7d103ad 100644 --- a/c/xlib/text.c +++ b/c/xlib/text.c @@ -115,16 +115,18 @@ s48_value scx_Draw_Text_16(s48_value display, s48_value drawable, s48_value scx_Text_Extents(s48_value font_struct, s48_value string) { XCharStruct overall; + int dir, ascent, descent; XTextExtents(scx_extract_fontstruct(font_struct), s48_extract_string(string), S48_STRING_LENGTH(string), - NULL, NULL, NULL, + &dir, &ascent, &descent, &overall); return scx_enter_charstruct(&overall); } s48_value scx_Text_Extents_16(s48_value font_struct, s48_value string) { XCharStruct overall; + int dir, ascent, descent; int i, len = s48_list_length(string); XChar2b chars[len]; for (i = 0; i < len; i++) { @@ -134,7 +136,7 @@ s48_value scx_Text_Extents_16(s48_value font_struct, s48_value string) { } XTextExtents16(scx_extract_fontstruct(font_struct), chars, len, - NULL, NULL, NULL, + &dir, &ascent, &descent, &overall); return scx_enter_charstruct(&overall); } diff --git a/c/xlib/types.c b/c/xlib/types.c index b55920c..f704fb8 100644 --- a/c/xlib/types.c +++ b/c/xlib/types.c @@ -52,8 +52,9 @@ void scx_struct_cache_set(void* cpointer, s48_value* l, s48_value v) { // remove all empty and duplicate entries while (list != S48_NULL) { - s48_value entry = S48_WEAK_POINTER_REF(S48_CDR(S48_CAR(list))); - if ((entry == S48_FALSE) || (S48_EXTRACT_POINTER(entry) == cpointer)) + s48_value entry = S48_CAR(list); + if ((S48_WEAK_POINTER_REF(S48_CDR(entry)) == S48_FALSE) || + (S48_EXTRACT_POINTER(S48_CAR(entry)) == cpointer)) S48_SET_CDR(previous, S48_CDR(list)); else previous = list; diff --git a/c/xlib/window.c b/c/xlib/window.c index 7efb97e..01bed35 100644 --- a/c/xlib/window.c +++ b/c/xlib/window.c @@ -184,10 +184,9 @@ s48_value scx_Configure_Window(s48_value display, s48_value window, return S48_UNSPECIFIC; } -s48_value scx_window_attributes; - s48_value scx_enter_window_attributes(XWindowAttributes* WA) { - s48_value v = s48_make_record(scx_window_attributes); + s48_value v = s48_make_record( + s48_get_imported_binding("scx-window-attributes")); S48_DECLARE_GC_PROTECT(1); S48_GC_PROTECT_1(v); S48_RECORD_SET(v, 0, s48_enter_integer(WA->x)); @@ -340,7 +339,7 @@ s48_value scx_Clear_Window(s48_value display, s48_value window) { return S48_UNSPECIFIC; } -s48_value scx_Query_Tree(s48_value Xwindow, s48_value Xdisplay) { +s48_value scx_Query_Tree(s48_value display, s48_value window) { Window root, parent, *children; int i; unsigned n; @@ -348,8 +347,8 @@ s48_value scx_Query_Tree(s48_value Xwindow, s48_value Xdisplay) { s48_value c = S48_NULL, res = S48_NULL; S48_DECLARE_GC_PROTECT(2); - if (! XQueryTree (scx_extract_display(Xdisplay), - scx_extract_window(Xwindow), + if (! XQueryTree (scx_extract_display(display), + scx_extract_window(window), &root, &parent, &children, &n)) return S48_FALSE; diff --git a/scheme/xlib/colormap.scm b/scheme/xlib/colormap.scm index a3aa80e..ab693b5 100644 --- a/scheme/xlib/colormap.scm +++ b/scheme/xlib/colormap.scm @@ -23,6 +23,8 @@ colormap-alloc? colormap-allocs colormap-alloc-name colormap-alloc-index (none all)) +(define-exported-binding "scx-colormap-alloc" :colormap-alloc) + (import-lambda-definition create-colormap (display window visual alloc) "scx_Create_Colormap") diff --git a/scheme/xlib/display.scm b/scheme/xlib/display.scm index 3d86ae2..1add966 100644 --- a/scheme/xlib/display.scm +++ b/scheme/xlib/display.scm @@ -5,7 +5,7 @@ (make-display cpointer connection-number protocol-version protocol-revision server-vendor image-byte-order bitmap-unit bitmap-pad bitmap-bit-order vendor-release queue-length name - default-screen screens after-function) + default-screen screens after-function wakeup) display? (cpointer display:cpointer) (connection-number display:connection-number) @@ -21,13 +21,43 @@ (name display:name) (default-screen display:default-screen) (screens display:screens) - (after-function display:after-function set-display:after-function!)) + (after-function display:after-function set-display:after-function!) + (wakeup display:wakeup set-display:wakeup!)) (define-exported-binding "scx-display" :display) +;(define (wakeup-display dpy) +; (placeholder-set! dpy #t)) + +;(define (sleep-display dpy) +; (let ((ph (make-placeholder))) +; (set-display:wakeup! dpy ph) +; (placeholder-value ph))) + +(define (initialize-display dpy) +; (set-display:wakeup! dpy (make-placeholder)) +; ;; spawn a thread that weaks up a waiting wait-event call if the +; ;; inport has data available +; (spawn (lambda () +; (let loop () +; (block-on-message-inport dpy) +; (wakeup-display dpy) +; (loop)))) + ;; the after-function may also send a wakup + #t) + +(define-exported-binding "scx-initialize-display" initialize-display) + (define (display-message-inport display) (fdes->inport (display:connection-number display))) +(define (block-on-message-inport dpy . maybe-timeout) + (let ((port (display-message-inport dpy))) + (call-with-values + (lambda () (apply select (vector port) (vector) (vector) maybe-timeout)) + (lambda (ready-read ready-write ex) + (member port (vector->list ready-read)))))) + (define-enumerated-type byte-order :byte-order byte-order? byte-orders byte-order-name byte-order-index (lsb-first msb-first)) @@ -133,19 +163,27 @@ ;; *** enable or disable synchronization ***************************** -(define (synchronize display on?) +(define (synchronize dpy on?) (if on? - (set-after-function! display - (lambda (display) (display-sync display #f))) - (set-after-function! display default-after-function))) + (set-after-function! dpy + (lambda (dpy) + (display-sync dpy #f))) + (set-after-function! dpy #f))) ;; returns the previous after-function. An after-function is called ;; with the display object. -(define (default-after-function display) ;; TODO: check if this is the real one - (display-flush display)) +(define (general-after-function display) + (if (display:after-function display) + ((display:after-function display) display) + ;; else the default behaviour ;; TODO: check if this is the real one + (display-flush display)) + ) + ;; if events are in the queue now, then wakeup a wait-event call + ;;(if (> (events-queued display (queued-mode already)) 0) + ;; (wakeup-display display))) -(define-exported-binding "scx-default-after-function" default-after-function) +(define-exported-binding "scx-general-after-function" general-after-function) (define (set-after-function! display fun) (let ((prev (display:after-function display))) diff --git a/scheme/xlib/error.scm b/scheme/xlib/error.scm index 722c5d6..d5972d7 100644 --- a/scheme/xlib/error.scm +++ b/scheme/xlib/error.scm @@ -211,7 +211,11 @@ ;; *** default error handlers **************************************** (define *x-error-handler* #f) -(define-exported-binding "internal-x-error-handler" *x-error-handler*) +(define (internal-x-error-handler display error) + (if *x-error-handler* + (*x-error-handler* display error) + #f)) +(define-exported-binding "internal-x-error-handler" internal-x-error-handler) (define (set-error-handler! handler) (let ((old-handler *x-error-handler*)) @@ -241,8 +245,12 @@ ; "scx_Set_IO_Error_Handler") (define *x-fatal-error-handler* #f) +(define (internal-x-fatal-error-handler display) + (if *x-fatal-error-handler* + (*x-fatal-error-handler* display) + #f)) (define-exported-binding "internal-x-fatal-error-handler" - *x-fatal-error-handler*) + internal-x-fatal-error-handler) (define (set-fatal-error-handler! handler) (let ((old-handler *x-fatal-error-handler*)) diff --git a/scheme/xlib/event-types.scm b/scheme/xlib/event-types.scm index 8747956..d3cbc59 100644 --- a/scheme/xlib/event-types.scm +++ b/scheme/xlib/event-types.scm @@ -392,7 +392,8 @@ (define-record-type graphics-expose-event :graphics-expose-event (create-graphics-expose-event type serial send-event? display drawable - x y width height major-code minor-code) + x y width height count major-code + minor-code) graphics-expose-event? (type graphics-expose-event-type) (serial graphics-expose-event-serial) @@ -403,6 +404,7 @@ (y graphics-expose-event-y) (width graphics-expose-event-width) (height graphics-expose-event-height) + (count graphics-expose-event-count) (major-code graphics-expose-event-major-code) (minor-code graphics-expose-event-minor-code)) diff --git a/scheme/xlib/event.scm b/scheme/xlib/event.scm index 0a15cd4..e3670ae 100644 --- a/scheme/xlib/event.scm +++ b/scheme/xlib/event.scm @@ -4,17 +4,12 @@ ;; and then it returns this new event. (define (wait-event dpy) - (if (not (> (events-queued dpy (queued-mode after-flush)) 0)) - (block-on-message-inport dpy)) - (next-event dpy)) - -(define (block-on-message-inport dpy) - (let ((port (display-message-inport dpy))) - (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)))))) + (if (> (events-queued dpy (queued-mode after-flush)) 0) + (next-event dpy) + (begin + ;;(sleep-display dpy) + (block-on-message-inport dpy) + (wait-event dpy)))) ;(define (block-on-message-inport dpy) ; needs ports, locks ; (let ((port (display-message-inport dpy))) @@ -27,7 +22,7 @@ ; (release-lock (port-lock port))) ; (enable-interrupts!)))) -;;;; Only here until scsh provides us with select +;;; Only here until scsh provides us with select ;(import-lambda-definition add-pending-channel (channel) ; "scx_add_pending_channel") diff --git a/scheme/xlib/font.scm b/scheme/xlib/font.scm index 0b16811..20aca56 100644 --- a/scheme/xlib/font.scm +++ b/scheme/xlib/font.scm @@ -44,7 +44,7 @@ (ascent font-struct:ascent) (descent font-struct:descent)) -(define-exported-binding "scx-font-struct" :font-struct) +(define-exported-binding "scx-fontstruct" :font-struct) ;; *** load or unload fonts ****************************************** diff --git a/scheme/xlib/graphics.scm b/scheme/xlib/graphics.scm index 1ddf58a..7321d2c 100644 --- a/scheme/xlib/graphics.scm +++ b/scheme/xlib/graphics.scm @@ -61,6 +61,11 @@ (width rectangle:width set-rectangle:width!) (height rectangle:height set-rectangle:height!)) +(define-record-discloser :rectangle + (lambda (r) + `(Rectangle ,(rectangle:x r) ,(rectangle:y r) + ,(rectangle:width r) ,(rectangle:height r)))) + (define-exported-binding "scx-rectangle" :rectangle) (import-lambda-definition draw-rectangles (display drawable gc rectangles) diff --git a/scheme/xlib/sync-event.scm b/scheme/xlib/sync-event.scm index 753e446..cf35b5b 100644 --- a/scheme/xlib/sync-event.scm +++ b/scheme/xlib/sync-event.scm @@ -29,11 +29,11 @@ (define *most-recent-sync-x-event* (make-sync-x-event 'no-event)) (define *most-recent-lock* (make-lock)) -(define (init-sync-x-events display) +(define (init-sync-x-events dpy) (spawn (lambda () (let lp () - (let ((next (wait-event display))) + (let ((next (wait-event dpy))) (with-lock *most-recent-lock* (lambda () (set-next-sync-x-event! *most-recent-sync-x-event* @@ -93,8 +93,9 @@ (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)) + (if (window-exists? (request:display r) (request:window r)) + (display-select-input (request:display r) (request:window r) + mask))) (loop rest))))))) (define (call-with-event-channel display window event-mask fun) @@ -195,36 +196,36 @@ (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))) + (eq? window (circulate-event-event event))) (and (eq? type (event-type configure-notify)) - (eq? window (configure-event-window event))) + (eq? window (configure-event-event event))) (and (eq? type (event-type destroy-notify)) - (eq? window (destroy-window-event-window event))) + (eq? window (destroy-window-event-event event))) (and (eq? type (event-type gravity-notify)) - (eq? window (gravity-event-window event))) + (eq? window (gravity-event-event event))) (and (eq? type (event-type map-notify)) - (eq? window (map-event-window event))) + (eq? window (map-event-event event))) (and (eq? type (event-type reparent-notify)) - (eq? window (reparent-event-window event))) + (eq? window (reparent-event-event event))) (and (eq? type (event-type unmap-notify)) - (eq? window (unmap-event-window event))))) + (eq? window (unmap-event-event event))))) ((eq? mask-item (event-mask-item substructure-notify)) (or (and (eq? type (event-type circulate-notify)) - (not (eq? window (circulate-event-window event)))) + (eq? window (circulate-event-event event))) (and (eq? type (event-type configure-notify)) - (not (eq? window (configure-event-window event)))) + (eq? window (configure-event-event event))) (and (eq? type (event-type create-notify)) - (not (eq? window (create-window-event-window event)))) + (eq? window (create-window-event-parent event))) (and (eq? type (event-type destroy-notify)) - (not (eq? window (destroy-window-event-window event)))) + (eq? window (destroy-window-event-event event))) (and (eq? type (event-type gravity-notify)) - (not (eq? window (gravity-event-window event)))) + (eq? window (gravity-event-event event))) (and (eq? type (event-type map-notify)) - (not (eq? window (map-event-window event)))) + (eq? window (map-event-event event))) (and (eq? type (event-type reparent-notify)) - (not (eq? window (reparent-event-window event)))) + (eq? window (reparent-event-event event))) (and (eq? type (event-type unmap-notify)) - (not (eq? window (unmap-event-window event)))))) + (eq? window (unmap-event-event event))))) ((eq? mask-item (event-mask-item substructure-redirect)) (or (eq? type (event-type circulate-request)) (eq? type (event-type configure-request)) diff --git a/scheme/xlib/window.scm b/scheme/xlib/window.scm index 3166cb0..4aa7238 100644 --- a/scheme/xlib/window.scm +++ b/scheme/xlib/window.scm @@ -129,8 +129,8 @@ "scx_Configure_Window") (define (make-win-configurer change) - (lambda (window value) - (configure-window window (list (cons change value))))) + (lambda (display window value) + (configure-window display window (list (cons change value))))) (define set-window-x! (make-win-configurer (window-change x))) (define set-window-y! (make-win-configurer (window-change y))) @@ -205,6 +205,8 @@ (override-redirect window-attribute:override-redirect) (screen window-attribute:screen)) +(define-exported-binding "scx-window-attributes" :window-attributes) + (import-lambda-definition get-window-attributes (display window) "scx_Get_Window_Attributes") @@ -335,3 +337,19 @@ ;; the pointer or None (vector-ref q 4) ;; x and y coordinates (vector-ref q 5))))) ;; relative to window + +;; *** convenience functions ***************************************** + +(define (window-exists? dpy window) + (let ((pe (use-x-error-warnings!))) + (let ((result + (call-with-current-continuation + (lambda (return) + (with-handler (lambda (condition punt) + (return #f)) + (lambda () + (query-tree dpy window) + (display-sync dpy #f) + #t)))))) + (set-error-handler! pe) + result))) diff --git a/scheme/xlib/xlib-interfaces.scm b/scheme/xlib/xlib-interfaces.scm index d47e8d7..e1d111c 100644 --- a/scheme/xlib/xlib-interfaces.scm +++ b/scheme/xlib/xlib-interfaces.scm @@ -45,9 +45,9 @@ display:last-request-read default-root-window + white-pixel black-pixel next-request synchronize - default-after-function set-after-function! display-flush display-sync @@ -126,6 +126,8 @@ query-pointer-state query-pointer + window-exists? + ;; colormap.scm *************************************************** make-color color? color:pixel set-color:pixel! color:red set-color:red! color:green set-color:green! @@ -201,6 +203,15 @@ ;; event-types.scm ************************************************ (event-type :enumeration) (event-mask :syntax) + + (notify-mode :enumeration) + (notify-detail :enumeration) + (visibility-state :enumeration) + (place :enumeration) + (property-state :enumeration) + (property-format :enumeration) + (mapping-request :enumeration) + any-event-type any-event-serial any-event-send-event? diff --git a/scheme/xlib/xlib-packages.scm b/scheme/xlib/xlib-packages.scm index 231602d..a29debe 100644 --- a/scheme/xlib/xlib-packages.scm +++ b/scheme/xlib/xlib-packages.scm @@ -19,7 +19,7 @@ scheme list-lib srfi-13 ;; strings - signals + signals handle bitwise external-calls define-record-types