scsh-conservatory
/
scx
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

modified and fixed xlib-error handling/signaling

This commit is contained in:
frese 2003-05-01 21:05:33 +00:00
parent 5f0df79c0f
commit 0afc105e6c
21 changed files with 265 additions and 221 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

9
c/xlib/display.c
View File

@ -55,9 +55,8 @@ s48_value scx_general_after_function_binding = S48_FALSE;
static int scx_after_function_wrapper(Display* dpy) { static int scx_after_function_wrapper(Display* dpy) {
s48_value display = scx_enter_display(dpy); s48_value display = scx_enter_display(dpy);
s48_value fun = S48_SHARED_BINDING_REF(scx_general_after_function_binding); s48_value fun = S48_SHARED_BINDING_REF(scx_general_after_function_binding);
s48_disable_interruptsB();
s48_call_scheme(fun, 1, display); s48_call_scheme(fun, 1, display);
s48_enable_interruptsB();
return 0; return 0;
} }
@ -93,9 +92,11 @@ s48_value scx_enter_display(Display* dpy) {
for (i = ScreenCount(dpy)-1; i >= 0; i--) for (i = ScreenCount(dpy)-1; i >= 0; i--)
l = s48_cons(scx_enter_screen(ScreenOfDisplay(dpy, i)), l); l = s48_cons(scx_enter_screen(ScreenOfDisplay(dpy, i)), l);
S48_RECORD_SET(d, 13, l); S48_RECORD_SET(d, 13, l);
S48_RECORD_SET(d, 14, S48_FALSE); S48_RECORD_SET(d, 14, S48_FALSE); /* the after-function */
XSetAfterFunction(dpy, &scx_after_function_wrapper); XSetAfterFunction(dpy, &scx_after_function_wrapper);
S48_RECORD_SET(d, 15, S48_FALSE); S48_RECORD_SET(d, 15, S48_FALSE); /* wakeup-port, set by initialize */
S48_RECORD_SET(d, 16, S48_TRUE); /* use-warnings? */
S48_RECORD_SET(d, 17, S48_FALSE); /* error-queue, set by initialize */
s48_call_scheme(S48_SHARED_BINDING_REF(scx_initialize_display_binding), s48_call_scheme(S48_SHARED_BINDING_REF(scx_initialize_display_binding),
1, d); 1, d);
S48_GC_UNPROTECT(); S48_GC_UNPROTECT();

2
c/xlib/types.c
View File

@ -57,7 +57,7 @@ s48_value scx_window_changes_binding = S48_FALSE;
s48_value s48_checked_record_ref(s48_value value, int i, s48_value s48_checked_record_ref(s48_value value, int i,
s48_value rectype) { s48_value rectype) {
s48_check_record_type(value, rectype); s48_check_record_type(value, rectype);
return S48_RECORD_REF(value, i); return S48_UNSAFE_RECORD_REF(value, i);
} }
int s48_list_length(s48_value list) { int s48_list_length(s48_value list) {

38
scheme/xlib/client.scm
View File

@ -5,7 +5,7 @@
;; XIconifyWindow. ;; XIconifyWindow.
;; returns #f on error. ;; returns #f on error.
(import-lambda-definition iconify-window (display window screen-num) (import-xlib-function iconify-window (display window screen-num)
"scx_Iconify_Window") "scx_Iconify_Window")
;; withdraw-window unmaps the specified window and sends a synthetic ;; withdraw-window unmaps the specified window and sends a synthetic
@ -13,7 +13,7 @@
;; XWithdrawWindow. ;; XWithdrawWindow.
;; returns #f on error. ;; returns #f on error.
(import-lambda-definition withdraw-window (display window scr-num) (import-xlib-function withdraw-window (display window scr-num)
"scx_Withdraw_Window") "scx_Withdraw_Window")
;; reconfigure-wm-window changes attributes of the specified window ;; reconfigure-wm-window changes attributes of the specified window
@ -22,7 +22,7 @@
;; configure-window. ;; configure-window.
;; returns #f on error. ;; returns #f on error.
(import-lambda-definition reconfigure-wm-window (import-xlib-function reconfigure-wm-window
(display window scr-num changes) (display window scr-num changes)
"scx_Reconfigure_Wm_Window") "scx_Reconfigure_Wm_Window")
@ -32,14 +32,14 @@
;; window and returns it as a list of strings. See XGetCommand. ;; window and returns it as a list of strings. See XGetCommand.
;; returns #f on error. ;; returns #f on error.
(import-lambda-definition get-wm-command (display window) (import-xlib-function get-wm-command (display window)
"scx_Get_Wm_Command") "scx_Get_Wm_Command")
;; set-wm-command! sets the WM_COMMAND property (the command and ;; set-wm-command! sets the WM_COMMAND property (the command and
;; arguments used to invoke the application). The command has to be ;; arguments used to invoke the application). The command has to be
;; specified as a list of strings. See XSetCommand. ;; specified as a list of strings. See XSetCommand.
(import-lambda-definition set-wm-command! (display window command) (import-xlib-function set-wm-command! (display window command)
"scx_Set_Wm_Command") "scx_Set_Wm_Command")
;; get-wm-protocols function returns the list of atoms stored in the ;; get-wm-protocols function returns the list of atoms stored in the
@ -49,28 +49,28 @@
;; willing to participate. See XGetWMProtocols. ;; willing to participate. See XGetWMProtocols.
;; returns #f on error. ;; returns #f on error.
(import-lambda-definition get-wm-protocols (display window) (import-xlib-function get-wm-protocols (display window)
"scx_Get_Wm_Protocols") "scx_Get_Wm_Protocols")
;; set-wm-protocols! sets the WM_PROTOCOLS property of the specified ;; set-wm-protocols! sets the WM_PROTOCOLS property of the specified
;; window. protocols has to be a list of atoms. See XSetWMProtocols. ;; window. protocols has to be a list of atoms. See XSetWMProtocols.
;; returns #f on error. ;; returns #f on error.
(import-lambda-definition set-wm-protocols! (display window protocols) (import-xlib-function set-wm-protocols! (display window protocols)
"scx_Set_Wm_Protocols") "scx_Set_Wm_Protocols")
;; get-wm-class returns the class hint for the specified window. That ;; get-wm-class returns the class hint for the specified window. That
;; is a pair of strings (name . class) See XGetClassHint. ;; is a pair of strings (name . class) See XGetClassHint.
;; returns #f on error. ;; returns #f on error.
(import-lambda-definition get-wm-class (display window) (import-xlib-function get-wm-class (display window)
"scx_Get_Wm_Class") "scx_Get_Wm_Class")
;; set-wm-class! sets the class hint for the specified window. See ;; set-wm-class! sets the class hint for the specified window. See
;; XSetClassHint. ;; XSetClassHint.
;; returns #f on error. ;; returns #f on error.
(import-lambda-definition set-wm-class! (display window name class) (import-xlib-function set-wm-class! (display window name class)
"scx_Set_Wm_Class") "scx_Set_Wm_Class")
;; *** set or read a window's WM_HINTS property ********************** ;; *** set or read a window's WM_HINTS property **********************
@ -103,41 +103,41 @@
;; alist mapping wm-hint types to specific values. See wm-hint. See ;; alist mapping wm-hint types to specific values. See wm-hint. See
;; XGetWMHints for a description. ;; XGetWMHints for a description.
(import-lambda-definition get-wm-hints (display window) (import-xlib-function get-wm-hints (display window)
"scx_Get_Wm_Hints") "scx_Get_Wm_Hints")
;; set-wm-hints! sets the specified window manager hints. The hints ;; set-wm-hints! sets the specified window manager hints. The hints
;; must be specified as an alist of wm-hint values (see above) mapping ;; must be specified as an alist of wm-hint values (see above) mapping
;; to the appropiate values. See XSetWMHints. ;; to the appropiate values. See XSetWMHints.
(import-lambda-definition set-wm-hints! (display window wm-hint-alist) (import-xlib-function set-wm-hints! (display window wm-hint-alist)
"scx_Set_Wm_Hints") "scx_Set_Wm_Hints")
;; get-transient-for returns the WM_TRANSIENT_FOR property for the ;; get-transient-for returns the WM_TRANSIENT_FOR property for the
;; specified window. The value of that property is a window. See ;; specified window. The value of that property is a window. See
;; XGetTransientForHint. ;; XGetTransientForHint.
(import-lambda-definition get-transient-for (display window) (import-xlib-function get-transient-for (display window)
"scx_Get_Transient_For") "scx_Get_Transient_For")
;; set-transient-for! sets the WM_TRANSIENT_FOR property of the ;; set-transient-for! sets the WM_TRANSIENT_FOR property of the
;; specified window to the specified property-window. See ;; specified window to the specified property-window. See
;; XSetTransientForHint. ;; XSetTransientForHint.
(import-lambda-definition set-transient-for! (display window prop_window) (import-xlib-function set-transient-for! (display window prop_window)
"scx_Set_Transient_For") "scx_Set_Transient_For")
;; get-text-property returns the property specified by atom of the ;; get-text-property returns the property specified by atom of the
;; specified window as a property record. See get-window-property. See ;; specified window as a property record. See get-window-property. See
;; XGetTextProperty. ;; XGetTextProperty.
(import-lambda-definition get-text-property (display window atom) (import-xlib-function get-text-property (display window atom)
"scx_Get_Text_Property") "scx_Get_Text_Property")
;; set-text-property! sets the property specified by atom of the ;; set-text-property! sets the property specified by atom of the
;; specified window to value - a property record. ;; specified window to value - a property record.
(import-lambda-definition set-text-property! (display window value atom) (import-xlib-function set-text-property! (display window value atom)
"scx_Set_Text_Property") "scx_Set_Text_Property")
(define (property->string-list property) (define (property->string-list property)
@ -208,10 +208,10 @@
;; min-aspect-y max-aspect-x max-aspect-y base-width base-height ;; min-aspect-y max-aspect-x max-aspect-y base-width base-height
;; gravity). See XGetWMNormalHints, XSetWMNormalHints. ;; gravity). See XGetWMNormalHints, XSetWMNormalHints.
(import-lambda-definition get-wm-normal-hints (display window) (import-xlib-function get-wm-normal-hints (display window)
"scx_Get_Wm_Normal_Hints") "scx_Get_Wm_Normal_Hints")
(import-lambda-definition set-wm-normal-hints! (display window alist) (import-xlib-function set-wm-normal-hints! (display window alist)
"scx_Set_Wm_Normal_Hints") "scx_Set_Wm_Normal_Hints")
;; get-icon-sizes returns the icon sizes specified by a window manager ;; get-icon-sizes returns the icon sizes specified by a window manager
@ -230,11 +230,11 @@
(define-exported-binding "scx-icon-size" :icon-size) (define-exported-binding "scx-icon-size" :icon-size)
(import-lambda-definition get-icon-sizes (display window) (import-xlib-function get-icon-sizes (display window)
"scx_Get_Icon_Sizes") "scx_Get_Icon_Sizes")
;; set-icon-sizes! is used only by window managers to set the ;; set-icon-sizes! is used only by window managers to set the
;; supported icon sizes. See icon-sizes, XSetIconSizes. ;; supported icon sizes. See icon-sizes, XSetIconSizes.
(import-lambda-definition set-icon-sizes! (display window sizes) (import-xlib-function set-icon-sizes! (display window sizes)
"scx_Set_Icon_Sizes") "scx_Set_Icon_Sizes")

26
scheme/xlib/colormap.scm
View File

@ -25,18 +25,18 @@
(define-exported-binding "scx-colormap-alloc" :colormap-alloc) (define-exported-binding "scx-colormap-alloc" :colormap-alloc)
(import-lambda-definition create-colormap (display window visual alloc) (import-xlib-function create-colormap (display window visual alloc)
"scx_Create_Colormap") "scx_Create_Colormap")
(import-lambda-definition copy-colormap-and-free (display colormap) (import-xlib-function copy-colormap-and-free (display colormap)
"scx_Copy_Colormap_And_Free") "scx_Copy_Colormap_And_Free")
(import-lambda-definition free-colormap (display colormap) (import-xlib-function free-colormap (display colormap)
"scx_Free_Colormap") "scx_Free_Colormap")
;; *** allocate and free colors ************************************** ;; *** allocate and free colors **************************************
(import-lambda-definition alloc-color! (display colormap color) (import-xlib-function alloc-color! (display colormap color)
"scx_Alloc_Color") "scx_Alloc_Color")
;; red, green and blue can be a number between 0 (inclusive) and 1 ;; red, green and blue can be a number between 0 (inclusive) and 1
@ -46,7 +46,7 @@
(and (alloc-color! display colormap color) (and (alloc-color! display colormap color)
(color:pixel color)))) (color:pixel color))))
(import-lambda-definition %alloc-named-color (display colormap color-name) (import-xlib-function %alloc-named-color (display colormap color-name)
"scx_Alloc_Named_Color") "scx_Alloc_Named_Color")
;; returns a pair (screen-color exact-color) or #f ;; returns a pair (screen-color exact-color) or #f
@ -58,7 +58,7 @@
(and res (car res)))) (and res (car res))))
;; returns a pair of two lists (plane-masks . pixels) or #f ;; returns a pair of two lists (plane-masks . pixels) or #f
(import-lambda-definition alloc-color-cells/planes (import-xlib-function alloc-color-cells/planes
(display colormap contig? nplanes npixels) (display colormap contig? nplanes npixels)
"scx_Alloc_Color_Cells") "scx_Alloc_Color_Cells")
@ -67,16 +67,16 @@
(and r (cdr r)))) (and r (cdr r))))
;; returns a list of lists (pixels redmask greenmask bluemask) or #f ;; returns a list of lists (pixels redmask greenmask bluemask) or #f
(import-lambda-definition alloc-color-planes (import-xlib-function alloc-color-planes
(display colormap contig? ncolors nreds ngreens nblues) (display colormap contig? ncolors nreds ngreens nblues)
"scx_Alloc_Color_Planes") "scx_Alloc_Color_Planes")
(import-lambda-definition free-colors (display colormap pixels planes) (import-xlib-function free-colors (display colormap pixels planes)
"scx_Free_Colors") "scx_Free_Colors")
;; *** obtain color values ******************************************* ;; *** obtain color values *******************************************
(import-lambda-definition query-colors! (display colormap colors) (import-xlib-function query-colors! (display colormap colors)
"scx_Query_Colors") "scx_Query_Colors")
(define (query-colors display colormap pixels) (define (query-colors display colormap pixels)
@ -90,21 +90,21 @@
(define (query-color display colormap pixel) (define (query-color display colormap pixel)
(car (query-colors display colormap (list pixel)))) (car (query-colors display colormap (list pixel))))
(import-lambda-definition lookup-color (display colormap color-name) (import-xlib-function lookup-color (display colormap color-name)
"scx_Lookup_Color") "scx_Lookup_Color")
(import-lambda-definition parse-color (display colormap spec) (import-xlib-function parse-color (display colormap spec)
"scx_Parse_Color") "scx_Parse_Color")
;; *** set colors **************************************************** ;; *** set colors ****************************************************
(import-lambda-definition store-colors (display colormap colors) (import-xlib-function store-colors (display colormap colors)
"scx_Store_Colors") "scx_Store_Colors")
(define (store-color display colormap color) (define (store-color display colormap color)
(store-colors display colormap (list color))) (store-colors display colormap (list color)))
(import-lambda-definition %store-named-color (import-xlib-function %store-named-color
(display colormap color-name pixel do-red do-green do-blue) (display colormap color-name pixel do-red do-green do-blue)
"scx_Store_Named_Color") "scx_Store_Named_Color")

14
scheme/xlib/cursor.scm
View File

@ -2,17 +2,17 @@
;; *** create cursors ************************************************ ;; *** create cursors ************************************************
(import-lambda-definition create-pixmap-cursor (import-xlib-function create-pixmap-cursor
(display source mask foreground-color background-color x y) (display source mask foreground-color background-color x y)
"scx_Create_Pixmap_Cursor") "scx_Create_Pixmap_Cursor")
;; source-char and mask-char have to be integers. ;; source-char and mask-char have to be integers.
(import-lambda-definition create-glyph-cursor (import-xlib-function create-glyph-cursor
(display source-font mask-font source-char mask-char foreground-color (display source-font mask-font source-char mask-char foreground-color
background-color) background-color)
"scx_Create_Glyph_Cursor") "scx_Create_Glyph_Cursor")
(import-lambda-definition create-font-cursor (display shape) (import-xlib-function create-font-cursor (display shape)
"scx_Create_Font_Cursor") "scx_Create_Font_Cursor")
(define xc-X-cursor 0) (define xc-X-cursor 0)
@ -95,19 +95,19 @@
;; *** define cursors ************************************************ ;; *** define cursors ************************************************
(import-lambda-definition define-cursor (display window cursor) (import-xlib-function define-cursor (display window cursor)
"scx_Define_Cursor") "scx_Define_Cursor")
(import-lambda-definition undefine-cursor (display window) (import-xlib-function undefine-cursor (display window)
"scx_Undefine_Cursor") "scx_Undefine_Cursor")
;; *** manipulate cursors ******************************************** ;; *** manipulate cursors ********************************************
(import-lambda-definition recolor-cursor (import-xlib-function recolor-cursor
(display cursor foreground-color background-color) (display cursor foreground-color background-color)
"scx_Recolor_Cursor") "scx_Recolor_Cursor")
(import-lambda-definition free-cursor (display cursor) (import-xlib-function free-cursor (display cursor)
"scx_Free_Cursor") "scx_Free_Cursor")
;; query-best-cursor defined in gcontext.scm ;; query-best-cursor defined in gcontext.scm

66
scheme/xlib/display.scm
View File

@ -1,11 +1,60 @@
;; Copyright (c) 2001-2003 by Norbert Freudemann, David Frese ;; Copyright (c) 2001-2003 by Norbert Freudemann, David Frese
(define-syntax import-xlib-function
(lambda (exp rename compare)
(let ((id (cadr exp))
(formals (caddr exp))
(external-id (cadddr exp))
(%define (rename 'define))
(%begin (rename 'begin))
(%lambda (rename 'lambda))
(%binding (rename 'binding))
(%import (rename 'import-lambda-definition))
(%call-xlib-function (rename 'call-xlib-function)))
`(,%begin
(,%import ,%binding ,formals ,external-id)
(,%define ,id
(,%lambda ,formals
(,%call-xlib-function ,(car formals) ,id
(,%lambda ()
(,%binding . ,formals)))))))))
(define (call-xlib-function display name thunk)
(if (display? display)
(if (display:warnings? display)
(call-critical
(lambda ()
(let* ((queue (display:error-queue display))
(result (thunk)))
(if (not (eq? queue (display:error-queue display)))
(let* ((next (next-x-error-queue queue))
(error (x-error-queue:this next)))
(signal-x-warning error))
result))))
(thunk))
(error "first argument of an xlib-function must be a display object"
name display)))
(define (call-critical thunk)
(let ((old-enabled (set-enabled-interrupts! no-interrupts))
(result (call-with-current-continuation
(lambda (return)
(cons #t
(with-handler (lambda (condition punt)
(return (cons #f condition)))
thunk))))))
(set-enabled-interrupts! old-enabled)
(if (car result)
(cdr result)
(signal-condition (cdr result)))))
;; TODO: pixmap-formats (XListPixmapFormats) ;; TODO: pixmap-formats (XListPixmapFormats)
(define-record-type display :display (define-record-type display :display
(make-display cpointer connection-number protocol-version protocol-revision (make-display cpointer connection-number protocol-version protocol-revision
server-vendor image-byte-order bitmap-unit bitmap-pad server-vendor image-byte-order bitmap-unit bitmap-pad
bitmap-bit-order vendor-release queue-length name bitmap-bit-order vendor-release queue-length name
default-screen screens after-function wakeup) default-screen screens after-function wakeup
warnings? error-queue)
display? display?
(cpointer display:cpointer) (cpointer display:cpointer)
(connection-number display:connection-number) (connection-number display:connection-number)
@ -22,7 +71,9 @@
(default-screen display:default-screen) (default-screen display:default-screen)
(screens display:screens) (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!)) (wakeup display:wakeup set-display:wakeup!)
(warnings? display:warnings? set-display:warnings?!)
(error-queue display:error-queue set-display:error-queue!))
(define-exported-binding "scx-display" :display) (define-exported-binding "scx-display" :display)
@ -33,6 +84,7 @@
(car (display:wakeup dpy))) (car (display:wakeup dpy)))
(define (initialize-display dpy) (define (initialize-display dpy)
(set-display:error-queue! dpy (empty-x-error-queue))
(call-with-values pipe (call-with-values pipe
(lambda (r w) (lambda (r w)
(set-display:wakeup! dpy (cons r w))))) (set-display:wakeup! dpy (cons r w)))))
@ -112,7 +164,7 @@
(error "invalid arguments" (cdr args))))));; TODO (error "invalid arguments" (cdr args))))));; TODO
(%open-display display-name))) (%open-display display-name)))
(import-lambda-definition close-display (display) (import-xlib-function close-display (display)
"scx_Close_Display") "scx_Close_Display")
(define none 0) (define none 0)
@ -176,19 +228,19 @@
;; *** handle output buffer or event queue *************************** ;; *** handle output buffer or event queue ***************************
(import-lambda-definition display-flush (display) (import-xlib-function display-flush (display)
"scx_Display_Flush") "scx_Display_Flush")
(import-lambda-definition display-sync (display discard?) (import-xlib-function display-sync (display discard?)
"scx_Display_Sync") "scx_Display_Sync")
;; display-no-op sends a NoOperation protocol request to the X server, thereby ;; display-no-op sends a NoOperation protocol request to the X server, thereby
;; exercising the connection. See XNoOp. ;; exercising the connection. See XNoOp.
(import-lambda-definition display-no-op (display) (import-xlib-function display-no-op (display)
"scx_No_Op") "scx_No_Op")
;; *** select input events ******************************************* ;; *** select input events *******************************************
(import-lambda-definition display-select-input (display window event-mask) (import-xlib-function display-select-input (display window event-mask)
"scx_Display_Select_Input") "scx_Display_Select_Input")

57
scheme/xlib/error.scm
View File

@ -161,33 +161,25 @@
(define (x-warning:x-error w) (define (x-warning:x-error w)
(cadr (condition-stuff w))) (cadr (condition-stuff w)))
(define (signal-x-warning x-error) (define (signal-x-warning x-error)
(signal 'x-warning (x-error->string x-error) x-error)) (signal 'x-warning (x-error:text x-error)
(opcode->string (x-error:major-opcode x-error))
(x-error:resource-id x-error)
x-error))
;; Call synchronize to have the warnings signaled where they belong to. ;; Call synchronize to have the warnings signaled where they belong to.
(define (use-x-error-warnings!) (define (use-x-error-warnings! display on?)
(set-error-handler! (lambda (display error) (let ((was (display:warnings? display))) ;; lock??
(signal-x-warning error)))) (set-display:warnings?! display on?)
was))
;; *** error-queue *************************************************** ;; *** error-queue ***************************************************
;; Interface: ;; Interface:
;; (use-x-error-queue!) returns a thunk that returns the most recent queue
;; element.
;; (empty-x-error-queue? q) return #t only for the initial queue. ;; (empty-x-error-queue? q) return #t only for the initial queue.
;; (next-x-error-queue q) returns the next queue element, blocks if necessary. ;; (next-x-error-queue q) returns the next queue element, blocks if necessary.
;; (x-error-queue:this q) returns the x-error of that queue. ;; (x-error-queue:this q) returns the x-error of that queue.
(define (use-x-error-queue!) ;; exp
(let* ((most-recent-x-error-queue empty-x-error-queue)
(handler (lambda (display error)
(set-next-x-error-queue! most-recent-x-error-queue
(make-x-error-queue error))
(set! most-recent-x-error-queue
(next-x-error-queue most-recent-x-error-queue)))))
(set-error-handler! handler)
(lambda () most-recent-x-error-queue)))
(define-record-type x-error-queue :x-error-queue (define-record-type x-error-queue :x-error-queue
(really-make-x-error-queue this next) (really-make-x-error-queue this next)
x-error-queue? x-error-queue?
@ -197,7 +189,9 @@
(define (make-x-error-queue error) (define (make-x-error-queue error)
(really-make-x-error-queue error (make-placeholder))) (really-make-x-error-queue error (make-placeholder)))
(define empty-x-error-queue (make-x-error-queue #f)) (define (empty-x-error-queue)
(make-x-error-queue #f))
(define (empty-x-error-queue? obj) (define (empty-x-error-queue? obj)
(eq? obj empty-x-error-queue)) (eq? obj empty-x-error-queue))
@ -210,30 +204,13 @@
;; *** default error handlers **************************************** ;; *** default error handlers ****************************************
(define *x-error-handler* #f)
(define (internal-x-error-handler display error) (define (internal-x-error-handler display error)
(if *x-error-handler* (let ((queue (make-x-error-queue error)))
(*x-error-handler* display error) (set-next-x-error-queue! (display:error-queue display) queue)
#f)) (set-display:error-queue! display queue)))
(define-exported-binding "internal-x-error-handler" internal-x-error-handler) (define-exported-binding "internal-x-error-handler" internal-x-error-handler)
(define (set-error-handler! handler)
(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) (import-lambda-definition get-error-text (display code)
"scx_Get_Error_Text") "scx_Get_Error_Text")
@ -256,7 +233,3 @@
(let ((old-handler *x-fatal-error-handler*)) (let ((old-handler *x-fatal-error-handler*))
(set! *x-fatal-error-handler* handler) (set! *x-fatal-error-handler* handler)
old-handler)) old-handler))
;; *** The default is to use warnings ********************************
(use-x-error-warnings!)

12
scheme/xlib/event.scm
View File

@ -39,7 +39,7 @@
(define-exported-binding "scx-queued-mode" :queued-mode) (define-exported-binding "scx-queued-mode" :queued-mode)
(import-lambda-definition events-queued (display mode) (import-xlib-function events-queued (display mode)
"scx_Events_Queued") "scx_Events_Queued")
(define (event-ready? display) (define (event-ready? display)
@ -49,22 +49,22 @@
;; events-pending is identical to events-queued with after-flush ;; events-pending is identical to events-queued with after-flush
;; mode. ;; mode.
(import-lambda-definition events-pending (display) (import-xlib-function events-pending (display)
"scx_Events_Pending") "scx_Events_Pending")
;; Other event reading *********************************************** ;; Other event reading ***********************************************
(import-lambda-definition next-event (display) (import-xlib-function next-event (display)
"scx_Next_Event") "scx_Next_Event")
(import-lambda-definition peek-event (display) (import-xlib-function peek-event (display)
"scx_Peek_Event") "scx_Peek_Event")
;; returns a list of (time . (x . y)) elements ;; returns a list of (time . (x . y)) elements
(import-lambda-definition get-motion-events (display window from to) (import-xlib-function get-motion-events (display window from to)
"scx_Get_Motion_Events") "scx_Get_Motion_Events")
;; Sending events **************************************************** ;; Sending events ****************************************************
(import-lambda-definition send-event (display window propagate mask event) (import-xlib-function send-event (display window propagate mask event)
"scx_Send_Event") "scx_Send_Event")

18
scheme/xlib/font.scm
View File

@ -48,21 +48,21 @@
;; *** load or unload fonts ****************************************** ;; *** load or unload fonts ******************************************
(import-lambda-definition load-font (display name) (import-xlib-function load-font (display name)
"scx_Load_Font") "scx_Load_Font")
(import-lambda-definition unload-font (display font) (import-xlib-function unload-font (display font)
"scx_Unload_Font") "scx_Unload_Font")
;; returns a font-struct record or #f ;; returns a font-struct record or #f
(import-lambda-definition query-font (display font-id) (import-xlib-function query-font (display font-id)
"scx_Query_Font") "scx_Query_Font")
;; returns a font-struct record or #f ;; returns a font-struct record or #f
(import-lambda-definition load-query-font (display name) (import-xlib-function load-query-font (display name)
"scx_Load_Query_Font") "scx_Load_Query_Font")
(import-lambda-definition free-font (display font-struct) (import-xlib-function free-font (display font-struct)
"scx_Free_Font") "scx_Free_Font")
(define (get-font-property font-struct atom) (define (get-font-property font-struct atom)
@ -71,19 +71,19 @@
;; *** obtain or free font names and information ********************* ;; *** obtain or free font names and information *********************
(import-lambda-definition list-fonts (display pattern maxnames) (import-xlib-function list-fonts (display pattern maxnames)
"scx_List_Fonts") "scx_List_Fonts")
;; returns an alist mapping name -> font-struct ;; returns an alist mapping name -> font-struct
(import-lambda-definition list-fonts-with-info (display pattern maxnames) (import-xlib-function list-fonts-with-info (display pattern maxnames)
"scx_List_Fonts_With_Info") "scx_List_Fonts_With_Info")
;; *** set or get the font search path ******************************* ;; *** set or get the font search path *******************************
(import-lambda-definition set-font-path (display directories) (import-xlib-function set-font-path (display directories)
"scx_Set_Font_Path") "scx_Set_Font_Path")
(import-lambda-definition get-font-path (display) (import-xlib-function get-font-path (display)
"scx_Get_Font_Path") "scx_Get_Font_Path")
;; TODO: ?? ;; TODO: ??

21
scheme/xlib/gcontext.scm
View File

@ -103,10 +103,10 @@
;; *** create or free graphics contexts ****************************** ;; *** create or free graphics contexts ******************************
(import-lambda-definition create-gc (display drawable gc-value-alist) (import-xlib-function create-gc (display drawable gc-value-alist)
"scx_Create_Gc") "scx_Create_Gc")
(import-lambda-definition copy-gc! (display srck dest mask) (import-xlib-function copy-gc! (display srck dest mask)
"scx_Copy_Gc") "scx_Copy_Gc")
(define (copy-gc display drawable src) (define (copy-gc display drawable src)
@ -114,7 +114,7 @@
(copy-gc! display src all-gc-values gc) (copy-gc! display src all-gc-values gc)
gc)) gc))
(import-lambda-definition change-gc (display gc values) (import-xlib-function change-gc (display gc values)
"scx_Change_Gc") "scx_Change_Gc")
(define (make-gc-setter name) (define (make-gc-setter name)
@ -146,7 +146,7 @@
(define set-gc-dash-offset! (make-gc-setter (gc-value dash-offset))) (define set-gc-dash-offset! (make-gc-setter (gc-value dash-offset)))
(define set-gc-dashes! (make-gc-setter (gc-value dashes))) (define set-gc-dashes! (make-gc-setter (gc-value dashes)))
(import-lambda-definition get-gc-values (display gc values) (import-xlib-function get-gc-values (display gc values)
"scx_Get_Gc_Values") "scx_Get_Gc_Values")
(define (make-gc-getter name) (define (make-gc-getter name)
@ -178,7 +178,7 @@
(define gc-dash-offset (make-gc-getter (gc-value dash-offset))) (define gc-dash-offset (make-gc-getter (gc-value dash-offset)))
(define gc-dashes (make-gc-getter (gc-value dashes))) (define gc-dashes (make-gc-getter (gc-value dashes)))
(import-lambda-definition free-gc (display gc) (import-xlib-function free-gc (display gc)
"scx_Free_Gc") "scx_Free_Gc")
(import-lambda-definition gcontext-from-gc (gc) (import-lambda-definition gcontext-from-gc (gc)
@ -194,7 +194,7 @@
(cap-style cap-style) (cap-style cap-style)
(join-style join-style)))) (join-style join-style))))
(import-lambda-definition set-dashes! (display gc dashoffset dashlist) (import-xlib-function set-dashes! (display gc dashoffset dashlist)
"scx_Set_Dashes") "scx_Set_Dashes")
(define (set-clip-origin display gc x-origin y-origin) (define (set-clip-origin display gc x-origin y-origin)
@ -211,16 +211,21 @@
(define-exported-binding "scx-rectangle-orderings" rectangle-orderings) (define-exported-binding "scx-rectangle-orderings" rectangle-orderings)
;; rectangles has to be list of (x y width height) lists. ;; rectangles has to be list of (x y width height) lists.
(import-lambda-definition set-clip-rectangles! (import-xlib-function set-clip-rectangles!
(display gc x-origin y-origin rectangles ordering) (display gc x-origin y-origin rectangles ordering)
"scx_Set_Clip_Rectangles") "scx_Set_Clip_Rectangles")
;; *** determine efficient sizes ************************************* ;; *** determine efficient sizes *************************************
;; returns a pair (width . height) ;; returns a pair (width . height)
(import-lambda-definition %query-best-size (screen class width height) (import-lambda-definition %%query-best-size (screen class width height)
"scx_Query_Best_Size") "scx_Query_Best_Size")
(define (%query-best-size screen class width height)
(call-xlib-function (screen:display screen) 'query-best-size
(lambda ()
(%%query-best-size screen class width height))))
(define (query-best-cursor screen width height) (define (query-best-cursor screen width height)
(%query-best-size screen 0 width height)) (%query-best-size screen 0 width height))

24
scheme/xlib/grab.scm
View File

@ -14,15 +14,15 @@
(define-exported-binding "scx-grab-states" grab-states) (define-exported-binding "scx-grab-states" grab-states)
(import-lambda-definition grab-pointer (import-xlib-function grab-pointer
(display grab-window owner-events? events ptr-mode kbd-mode (display grab-window owner-events? events ptr-mode kbd-mode
confine-to cursor time) confine-to cursor time)
"scx_Grab_Pointer") "scx_Grab_Pointer")
(import-lambda-definition ungrab-pointer (display time) (import-xlib-function ungrab-pointer (display time)
"scx_Ungrab_Pointer") "scx_Ungrab_Pointer")
(import-lambda-definition change-active-pointer-grab (import-xlib-function change-active-pointer-grab
(display events cursor time) (display events cursor time)
"scx_Change_Active_Pointer_Grab") "scx_Change_Active_Pointer_Grab")
@ -51,30 +51,30 @@
(define-exported-binding "scx-button" :button) (define-exported-binding "scx-button" :button)
(define-exported-binding "scx-buttons" buttons) (define-exported-binding "scx-buttons" buttons)
(import-lambda-definition grab-button (import-xlib-function grab-button
(display button modifiers grab-window owner-events? events ptr-mode (display button modifiers grab-window owner-events? events ptr-mode
kbd-mode confine-to cursor) kbd-mode confine-to cursor)
"scx_Grab_Button") "scx_Grab_Button")
(import-lambda-definition ungrab-button (display button modifiers grab-window) (import-xlib-function ungrab-button (display button modifiers grab-window)
"scx_Ungrab_Button") "scx_Ungrab_Button")
;; *** grab the keyboard ********************************************* ;; *** grab the keyboard *********************************************
(import-lambda-definition grab-keyboard (import-xlib-function grab-keyboard
(display grab-window owner-events? ptr-mode kbd-mode time) (display grab-window owner-events? ptr-mode kbd-mode time)
"scx_Grab_Keyboard") "scx_Grab_Keyboard")
(import-lambda-definition ungrab-keyboard (display time) (import-xlib-function ungrab-keyboard (display time)
"scx_Ungrab_Keyboard") "scx_Ungrab_Keyboard")
;; *** grab keyboard keys ******************************************** ;; *** grab keyboard keys ********************************************
(import-lambda-definition grab-key (import-xlib-function grab-key
(display keycode modifiers grab-window owner-events? ptr-mode kbd-mode) (display keycode modifiers grab-window owner-events? ptr-mode kbd-mode)
"scx_Grab_Key") "scx_Grab_Key")
(import-lambda-definition ungrab-key (display keycode modifiers grab-window) (import-xlib-function ungrab-key (display keycode modifiers grab-window)
"scx_Ungrab_Key") "scx_Ungrab_Key")
;; *** release queued events ***************************************** ;; *** release queued events *****************************************
@ -86,7 +86,7 @@
(define-exported-binding "scx-event-mode" :event-mode) (define-exported-binding "scx-event-mode" :event-mode)
(import-lambda-definition allow-events (display event-mode time) (import-xlib-function allow-events (display event-mode time)
"scx_Allow_Events") "scx_Allow_Events")
;; *** grab the server *********************************************** ;; *** grab the server ***********************************************
@ -96,12 +96,12 @@
;; not grab the X server any more than is absolutely necessary. See ;; not grab the X server any more than is absolutely necessary. See
;; XGrabServer. ;; XGrabServer.
(import-lambda-definition grab-server (display) (import-xlib-function grab-server (display)
"scx_Grab_Server") "scx_Grab_Server")
;; ungrab-server restarts processing of requests and close downs on ;; ungrab-server restarts processing of requests and close downs on
;; other connections. You should avoid grabbing the X server as much ;; other connections. You should avoid grabbing the X server as much
;; as possible. See XUngrabServer. ;; as possible. See XUngrabServer.
(import-lambda-definition ungrab-server (display) (import-xlib-function ungrab-server (display)
"scx_Ungrab_Server") "scx_Ungrab_Server")

32
scheme/xlib/graphics.scm
View File

@ -2,11 +2,11 @@
;; *** copy areas **************************************************** ;; *** copy areas ****************************************************
(import-lambda-definition copy-area (import-xlib-function copy-area
(display src dest gc src-x src-y width height dest-x dest-y) (display src dest gc src-x src-y width height dest-x dest-y)
"scx_Copy_Area") "scx_Copy_Area")
(import-lambda-definition copy-plane (import-xlib-function copy-plane
(display src dest gc src-x src-y width height dest-x dest-y plane) (display src dest gc src-x src-y width height dest-x dest-y plane)
"scx_Copy_Plane") "scx_Copy_Plane")
@ -18,23 +18,23 @@
(define-exported-binding "scx-coord-mode" :coord-mode) (define-exported-binding "scx-coord-mode" :coord-mode)
(import-lambda-definition draw-point (display drawable gc x y) (import-xlib-function draw-point (display drawable gc x y)
"scx_Draw_Point") "scx_Draw_Point")
;; points has to be a list of (x . y) pairs ;; points has to be a list of (x . y) pairs
(import-lambda-definition draw-points (display drawable gc points mode) (import-xlib-function draw-points (display drawable gc points mode)
"scx_Draw_Points") "scx_Draw_Points")
;; *** draw lines, polygons ****************************************** ;; *** draw lines, polygons ******************************************
(import-lambda-definition draw-line (display drawable gc x1 y1 x2 y2) (import-xlib-function draw-line (display drawable gc x1 y1 x2 y2)
"scx_Draw_Line") "scx_Draw_Line")
;; points has to be a list of (x . y) pairs ;; points has to be a list of (x . y) pairs
(import-lambda-definition draw-lines (display drawable gc points mode) (import-xlib-function draw-lines (display drawable gc points mode)
"scx_Draw_Lines") "scx_Draw_Lines")
(import-lambda-definition draw-segments (display drawable gc segments) (import-xlib-function draw-segments (display drawable gc segments)
"scx_Draw_Segments") "scx_Draw_Segments")
(define-record-type segment :segment (define-record-type segment :segment
@ -49,7 +49,7 @@
;; *** draw rectangles *********************************************** ;; *** draw rectangles ***********************************************
(import-lambda-definition draw-rectangle (import-xlib-function draw-rectangle
(display drawable gc x y width height) (display drawable gc x y width height)
"scx_Draw_Rectangle") "scx_Draw_Rectangle")
@ -68,12 +68,12 @@
(define-exported-binding "scx-rectangle" :rectangle) (define-exported-binding "scx-rectangle" :rectangle)
(import-lambda-definition draw-rectangles (display drawable gc rectangles) (import-xlib-function draw-rectangles (display drawable gc rectangles)
"scx_Draw_Rectangles") "scx_Draw_Rectangles")
;; *** draw arcs ***************************************************** ;; *** draw arcs *****************************************************
(import-lambda-definition draw-arc (import-xlib-function draw-arc
(display drawable gc x y width height angle1 angle2) (display drawable gc x y width height angle1 angle2)
"scx_Draw_Arc") "scx_Draw_Arc")
@ -89,16 +89,16 @@
(define-exported-binding "scx-arc" :arc) (define-exported-binding "scx-arc" :arc)
(import-lambda-definition draw-arcs (display drawable gc arcs) (import-xlib-function draw-arcs (display drawable gc arcs)
"scx_Draw_Arcs") "scx_Draw_Arcs")
;; *** fill rectangles, polygons, or arcs **************************** ;; *** fill rectangles, polygons, or arcs ****************************
(import-lambda-definition fill-rectangle (import-xlib-function fill-rectangle
(display drawable gc x y width height) (display drawable gc x y width height)
"scx_Fill_Rectangle") "scx_Fill_Rectangle")
(import-lambda-definition fill-rectangles (display drawable gc rectangles) (import-xlib-function fill-rectangles (display drawable gc rectangles)
"scx_Fill_Rectangles") "scx_Fill_Rectangles")
(define-enumerated-type polygon-shape :polygon-shape (define-enumerated-type polygon-shape :polygon-shape
@ -107,15 +107,15 @@
(define-exported-binding "scx-polygon-shape" :polygon-shape) (define-exported-binding "scx-polygon-shape" :polygon-shape)
(import-lambda-definition fill-polygon (display drawable gc points shape mode) (import-xlib-function fill-polygon (display drawable gc points shape mode)
"scx_Fill_Polygon") "scx_Fill_Polygon")
(import-lambda-definition fill-arc (import-xlib-function fill-arc
(display drawable gc x y width height angle1 angle2) (display drawable gc x y width height angle1 angle2)
"scx_Fill_Arc") "scx_Fill_Arc")
;; arcs has to be a list of (x y width height angle1 angle2) lists. ;; arcs has to be a list of (x y width height angle1 angle2) lists.
(import-lambda-definition fill-arcs (display drawable gc arcs) (import-xlib-function fill-arcs (display drawable gc arcs)
"scx_Fill_Arcs") "scx_Fill_Arcs")
;; *** auxiliary functions ******************************************* ;; *** auxiliary functions *******************************************

36
scheme/xlib/key.scm
View File

@ -9,17 +9,17 @@
;; a keyboard mapping is a list of lists of keysyms ;; a keyboard mapping is a list of lists of keysyms
(import-lambda-definition change-keyboard-mapping (import-xlib-function change-keyboard-mapping
(display first-keycode keysyms-lists) (display first-keycode keysyms-lists)
"scx_Change_Keyboard_Mapping") "scx_Change_Keyboard_Mapping")
;; returns keycode-count lists of keysyms ;; returns keycode-count lists of keysyms
(import-lambda-definition get-keyboard-mapping (import-xlib-function get-keyboard-mapping
(display first-keycode keycode-count) (display first-keycode keycode-count)
"scx_Get_Keyboard_Mapping") "scx_Get_Keyboard_Mapping")
;; returns a pair (min-keycodes . max-keycodes) ;; returns a pair (min-keycodes . max-keycodes)
(import-lambda-definition display-keycodes (display) (import-xlib-function display-keycodes (display)
"scx_Display_Keycodes") "scx_Display_Keycodes")
;; a modmap is an alist mapping a modifier to a list of ;; a modmap is an alist mapping a modifier to a list of
@ -27,10 +27,10 @@
;; control) (state mod1) (state mod2) (state mod3) (state mod4) ;; control) (state mod1) (state mod2) (state mod3) (state mod4)
;; (state mod5) ;; (state mod5)
(import-lambda-definition set-modifier-mapping (display modmap) (import-xlib-function set-modifier-mapping (display modmap)
"scx_Set_Modifier_Mapping") "scx_Set_Modifier_Mapping")
(import-lambda-definition get-modifier-mapping (display) (import-xlib-function get-modifier-mapping (display)
"scx_Get_Modifier_Mapping") "scx_Get_Modifier_Mapping")
;; *** convert keysyms *********************************************** ;; *** convert keysyms ***********************************************
@ -43,10 +43,10 @@
;; TODO include X11/keysymdef.h ?? ;; TODO include X11/keysymdef.h ??
(import-lambda-definition keycode->keysym (display keycode index) (import-xlib-function keycode->keysym (display keycode index)
"scx_Keycode_To_Keysym") "scx_Keycode_To_Keysym")
(import-lambda-definition keysym->keycode (display keysym) (import-xlib-function keysym->keycode (display keysym)
"scx_Keysym_To_Keycode") "scx_Keysym_To_Keycode")
;; returns a pair (lower . upper) ;; returns a pair (lower . upper)
@ -61,18 +61,32 @@
;; *** handle keyboard input events in Latin-1 *********************** ;; *** handle keyboard input events in Latin-1 ***********************
(import-lambda-definition lookup-keysym (key-event index) (import-lambda-definition %lookup-keysym (key-event index)
"scx_Lookup_Keysym") "scx_Lookup_Keysym")
(import-lambda-definition refresh-keyboard-mapping (mapping-event) (define (lookup-keysym key-event index)
(call-xlib-function (key-event-display key-event) 'lookup-keysym
(lambda () (%lookup-keysym key-event index))))
(import-lambda-definition %refresh-keyboard-mapping (mapping-event)
"scx_Refresh_Keyboard_Mapping") "scx_Refresh_Keyboard_Mapping")
(define (refresh-keyboard-mapping mapping-event)
(call-xlib-function (mapping-event-display mapping-event)
'refresh-keyboard-mapping
(lambda () (%refresh-keyboard-mapping mapping-event))))
;; returns a pair (keysym . string) ;; returns a pair (keysym . string)
(import-lambda-definition lookup-string/keysym (key-event) (import-lambda-definition %lookup-string/keysym (key-event)
"scx_Lookup_String") "scx_Lookup_String")
(define (lookup-string/keysym key-event)
(call-xlib-function (key-event-display key-event)
'lookup-string/keysym
(lambda () (%lookup-string/keysym key-event))))
(define (lookup-string key-event) (define (lookup-string key-event)
(cdr (lookup-string/keysym key-event))) (cdr (lookup-string/keysym key-event)))
(import-lambda-definition rebind-keysym (display keysym mod-keysyms string) (import-xlib-function rebind-keysym (display keysym mod-keysyms string)
"scx_Rebind_Keysym") "scx_Rebind_Keysym")

12
scheme/xlib/pixmap.scm
View File

@ -2,10 +2,10 @@
;; *** create or destroy pixmaps ************************************* ;; *** create or destroy pixmaps *************************************
(import-lambda-definition create-pixmap (display drawable width height depth) (import-xlib-function create-pixmap (display drawable width height depth)
"scx_Create_Pixmap") "scx_Create_Pixmap")
(import-lambda-definition free-pixmap (display pixmap) (import-xlib-function free-pixmap (display pixmap)
"scx_Free_Pixmap") "scx_Free_Pixmap")
;; *** manipulate bitmaps ******************************************** ;; *** manipulate bitmaps ********************************************
@ -17,7 +17,7 @@
((2) (error "invalid bitmap data in file" data)) ((2) (error "invalid bitmap data in file" data))
((3) (error "not enough memory to create bitmap" data)))) ((3) (error "not enough memory to create bitmap" data))))
(import-lambda-definition %read-bitmap-file (display drawable filename) (import-xlib-function %read-bitmap-file (display drawable filename)
"scx_Read_Bitmap_File") "scx_Read_Bitmap_File")
;; returns a list (pixmap width height x-hot y-hot). May raise an error. ;; returns a list (pixmap width height x-hot y-hot). May raise an error.
@ -27,7 +27,7 @@
(bitmap-error res filename) (bitmap-error res filename)
res))) res)))
(import-lambda-definition %write-bitmap-file (import-xlib-function %write-bitmap-file
(display filename bitmap width height x-hot y-hot) (display filename bitmap width height x-hot y-hot)
"scx_Write_Bitmap_File") "scx_Write_Bitmap_File")
@ -40,14 +40,14 @@
;; image found in data, which has to be a string. Such an image can be ;; image found in data, which has to be a string. Such an image can be
;; generated with write-bitmap-file. See XCreateBitmapFromData. ;; generated with write-bitmap-file. See XCreateBitmapFromData.
(import-lambda-definition create-bitmap-from-data (display drawable data w h) (import-xlib-function create-bitmap-from-data (display drawable data w h)
"scx_Create_Bitmap_From_Data") "scx_Create_Bitmap_From_Data")
;; create-pixmap-from-bitmap-data creates a pixmap of the given depth ;; create-pixmap-from-bitmap-data creates a pixmap of the given depth
;; and then does a bitmap-format XPutImage of the data into it. See ;; and then does a bitmap-format XPutImage of the data into it. See
;; XCreatePixmapFromBitmapData. ;; XCreatePixmapFromBitmapData.
(import-lambda-definition create-pixmap-from-bitmap-data (import-xlib-function create-pixmap-from-bitmap-data
(display drawable data width height foreground background depth) (display drawable data width height foreground background depth)
"scx_Create_Pixmap_From_Bitmap_Data") "scx_Create_Pixmap_From_Bitmap_Data")

22
scheme/xlib/property.scm
View File

@ -12,14 +12,14 @@
;; *** create or return atom names *********************************** ;; *** create or return atom names ***********************************
(import-lambda-definition intern-atom (display atom-name only-if-exists?) (import-xlib-function intern-atom (display atom-name only-if-exists?)
"scx_Intern_Atom") "scx_Intern_Atom")
;; returns a list of atoms or #f ;; returns a list of atoms or #f
(import-lambda-definition intern-atoms (display names only-if-exists?) (import-xlib-function intern-atoms (display names only-if-exists?)
"scx_Intern_Atoms") "scx_Intern_Atoms")
(import-lambda-definition get-atom-name (display atom) (import-xlib-function get-atom-name (display atom)
"scx_Get_Atom_Name") "scx_Get_Atom_Name")
(define (get-atom-names display atoms) (define (get-atom-names display atoms)
@ -27,19 +27,19 @@
;; *** obtain and change window properties**************************** ;; *** obtain and change window properties****************************
(import-lambda-definition list-properties (display window) (import-xlib-function list-properties (display window)
"scx_List_Properties") "scx_List_Properties")
;; Note: This does not change the list itself. ;; Note: This does not change the list itself.
(import-lambda-definition rotate-window-properties (import-xlib-function rotate-window-properties
(display window properties npositions) (display window properties npositions)
"scx_Rotate_Window_Properties") "scx_Rotate_Window_Properties")
(import-lambda-definition delete-property (display window property) (import-xlib-function delete-property (display window property)
"scx_Delete_Property") "scx_Delete_Property")
;; returns a pair (bytes-after . property) or #f ;; returns a pair (bytes-after . property) or #f
(import-lambda-definition get-window-property (import-xlib-function get-window-property
(display window atom offset length delete? req-type) (display window atom offset length delete? req-type)
"scx_Get_Window_Property") "scx_Get_Window_Property")
@ -50,7 +50,7 @@
(define-exported-binding "scx-change-property-mode" :change-property-mode) (define-exported-binding "scx-change-property-mode" :change-property-mode)
(import-lambda-definition change-property (import-xlib-function change-property
(display window atom mode property) (display window atom mode property)
"scx_Change_Property") "scx_Change_Property")
@ -81,12 +81,12 @@
;; *** manipulate window selection *********************************** ;; *** manipulate window selection ***********************************
(import-lambda-definition set-selection-owner (display selection owner time) (import-xlib-function set-selection-owner (display selection owner time)
"scx_Set_Selection_Owner") "scx_Set_Selection_Owner")
(import-lambda-definition get-selection-owner (display selection) (import-xlib-function get-selection-owner (display selection)
"scx_Get_Selection_Owner") "scx_Get_Selection_Owner")
(import-lambda-definition convert-selection (import-xlib-function convert-selection
(display selection target property requestor time) (display selection target property requestor time)
"scx_Convert_Selection") "scx_Convert_Selection")

8
scheme/xlib/text.scm
View File

@ -2,12 +2,12 @@
;; *** draw image text *********************************************** ;; *** draw image text ***********************************************
(import-lambda-definition draw-image-string (display drawable gc x y string) (import-xlib-function draw-image-string (display drawable gc x y string)
"scx_Draw_Image_String") "scx_Draw_Image_String")
;; string has to be a list of (byte1 . byte2) pairs, where byte1 and ;; string has to be a list of (byte1 . byte2) pairs, where byte1 and
;; byte2 are characters ;; byte2 are characters
(import-lambda-definition draw-image-string-16 (import-xlib-function draw-image-string-16
(display drawable gc x y string) (display drawable gc x y string)
"scx_Draw_Image_String_16") "scx_Draw_Image_String_16")
@ -37,10 +37,10 @@
((make-text-items) ((make-text-items)
'()))) '())))
(import-lambda-definition draw-text (display drawable gc x y items) (import-xlib-function draw-text (display drawable gc x y items)
"scx_Draw_Text") "scx_Draw_Text")
(import-lambda-definition draw-text-16 (display drawable gc x y items) (import-xlib-function draw-text-16 (display drawable gc x y items)
"scx_Draw_Text_16") "scx_Draw_Text_16")
;; *** compute or query text extents ********************************* ;; *** compute or query text extents *********************************

4
scheme/xlib/utility.scm
View File

@ -15,14 +15,14 @@
;; strings. On success a string is returned, otherwise #f. See ;; strings. On success a string is returned, otherwise #f. See
;; XGetDefault. ;; XGetDefault.
(import-lambda-definition get-default (display program option) (import-xlib-function get-default (display program option)
"scx_Get_Default") "scx_Get_Default")
;; resource-manager-string returns the RESOURCE_MANAGER property from ;; resource-manager-string returns the RESOURCE_MANAGER property from
;; the server's root window of screen 0, or #f if no such property ;; the server's root window of screen 0, or #f if no such property
;; exists. See XResourceManagerString. ;; exists. See XResourceManagerString.
(import-lambda-definition resource-manager-string (display) (import-xlib-function resource-manager-string (display)
"scx_Resource_Manager_String") "scx_Resource_Manager_String")
;; parse-geometry parses a string for the standard X format for x, y, ;; parse-geometry parses a string for the standard X format for x, y,

4
scheme/xlib/visual.scm
View File

@ -40,11 +40,11 @@
;; template. #f entries in the template are ignored. Use ;; template. #f entries in the template are ignored. Use
;; (empty-visual-info) to create a visual-info with all entries set to ;; (empty-visual-info) to create a visual-info with all entries set to
;; #f. ;; #f.
(import-lambda-definition get-visual-infos (display template) (import-xlib-function get-visual-infos (display template)
"scx_Get_Visual_Info") "scx_Get_Visual_Info")
;; returns a visual-info or #f ;; returns a visual-info or #f
(import-lambda-definition match-visual-info (display screen-number depth class) (import-xlib-function match-visual-info (display screen-number depth class)
"scx_Match_Visual_Info") "scx_Match_Visual_Info")
(import-lambda-definition visualid-from-visual (visual) (import-lambda-definition visualid-from-visual (visual)

49
scheme/xlib/window.scm
View File

@ -50,17 +50,17 @@
;; *** create windows ************************************************ ;; *** create windows ************************************************
(import-lambda-definition create-window (import-xlib-function create-window
(display parent x y width height border_width depth class visual attribs) (display parent x y width height border_width depth class visual attribs)
"scx_Create_Window") "scx_Create_Window")
(import-lambda-definition create-simple-window (import-xlib-function create-simple-window
(display parent x y width height border_width border background) (display parent x y width height border_width border background)
"scx_Create_Simple_Window") "scx_Create_Simple_Window")
;; *** change window attributes ************************************** ;; *** change window attributes **************************************
(import-lambda-definition change-window-attributes (display window attribs) (import-xlib-function change-window-attributes (display window attribs)
"scx_Change_Window_Attributes") "scx_Change_Window_Attributes")
(define (make-win-attr-setter attribute) (define (make-win-attr-setter attribute)
@ -125,7 +125,7 @@
((make-window-change-alist) ((make-window-change-alist)
'()))) '())))
(import-lambda-definition configure-window (display window changes) (import-xlib-function configure-window (display window changes)
"scx_Configure_Window") "scx_Configure_Window")
(define (make-win-configurer change) (define (make-win-configurer change)
@ -207,11 +207,11 @@
(define-exported-binding "scx-window-attributes" :window-attributes) (define-exported-binding "scx-window-attributes" :window-attributes)
(import-lambda-definition get-window-attributes (display window) (import-xlib-function get-window-attributes (display window)
"scx_Get_Window_Attributes") "scx_Get_Window_Attributes")
;; returns a vector #(root-window x y width height border-width depth) or #f ;; returns a vector #(root-window x y width height border-width depth) or #f
(import-lambda-definition get-geometry (display drawable) (import-xlib-function get-geometry (display drawable)
"scx_Get_Geometry") "scx_Get_Geometry")
(define (make-geometry-getter i) (define (make-geometry-getter i)
@ -229,37 +229,37 @@
;; *** map windows *************************************************** ;; *** map windows ***************************************************
(import-lambda-definition map-window (display window) (import-xlib-function map-window (display window)
"scx_Map_Window") "scx_Map_Window")
(import-lambda-definition map-raised (display window) (import-xlib-function map-raised (display window)
"scx_Map_Raised") "scx_Map_Raised")
(import-lambda-definition map-subwindows (display window) (import-xlib-function map-subwindows (display window)
"scx_Map_Subwindows") "scx_Map_Subwindows")
;; *** unmap windows ************************************************* ;; *** unmap windows *************************************************
(import-lambda-definition unmap-window (display window) (import-xlib-function unmap-window (display window)
"scx_Unmap_Window") "scx_Unmap_Window")
(import-lambda-definition unmap-subwindows (display window) (import-xlib-function unmap-subwindows (display window)
"scx_Unmap_Subwindows") "scx_Unmap_Subwindows")
;; *** destroy windows *********************************************** ;; *** destroy windows ***********************************************
(import-lambda-definition destroy-window (display window) (import-xlib-function destroy-window (display window)
"scx_Destroy_Window") "scx_Destroy_Window")
(import-lambda-definition destroy-subwindows (display window) (import-xlib-function destroy-subwindows (display window)
"scx_Destroy_Subwindows") "scx_Destroy_Subwindows")
;; *** change window stacking order ********************************** ;; *** change window stacking order **********************************
(import-lambda-definition raise-window (display window) (import-xlib-function raise-window (display window)
"scx_Raise_Window") "scx_Raise_Window")
(import-lambda-definition lower-window (display window) (import-xlib-function lower-window (display window)
"scx_Lower_Window") "scx_Lower_Window")
(define-enumerated-type circulate-direction :circulate-direction (define-enumerated-type circulate-direction :circulate-direction
@ -269,7 +269,7 @@
(define-exported-binding "scx-circulate-direction" :circulate-direction) (define-exported-binding "scx-circulate-direction" :circulate-direction)
(import-lambda-definition circulate-subwindows (display window direction) (import-xlib-function circulate-subwindows (display window direction)
"scx_Circulate_Subwindows") "scx_Circulate_Subwindows")
(define (circulate-subwindows-up display window) (define (circulate-subwindows-up display window)
@ -278,22 +278,22 @@
(define (circulate-subwindows-down display window) (define (circulate-subwindows-down display window)
(circulate-subwindows display window (circulate-direction lower-highest))) (circulate-subwindows display window (circulate-direction lower-highest)))
(import-lambda-definition restack-windows (display windows) (import-xlib-function restack-windows (display windows)
"scx_Restack_Windows") "scx_Restack_Windows")
;; *** clear area or window ****************************************** ;; *** clear area or window ******************************************
(import-lambda-definition clear-area (import-xlib-function clear-area
(display window x y width height exposures?) (display window x y width height exposures?)
"scx_Clear_Area") "scx_Clear_Area")
(import-lambda-definition clear-window (display window) (import-xlib-function clear-window (display window)
"scx_Clear_Window") "scx_Clear_Window")
;; *** query window tree information ********************************* ;; *** query window tree information *********************************
;; returns a list (root-window parent-window children) or #f ;; returns a list (root-window parent-window children) or #f
(import-lambda-definition query-tree (display window) (import-xlib-function query-tree (display window)
"scx_Query_Tree") "scx_Query_Tree")
(define (window-root display window) (define (window-root display window)
@ -311,13 +311,13 @@
;; *** translate window coordinates ********************************** ;; *** translate window coordinates **********************************
;; returns a list (dest-x dest-y child) or #f ;; returns a list (dest-x dest-y child) or #f
(import-lambda-definition translate-coordinates (import-xlib-function translate-coordinates
(display src-w dest-w src-x src-y) (display src-w dest-w src-x src-y)
"scx_Translate_Coordinates") "scx_Translate_Coordinates")
;; *** get pointer coordinates *************************************** ;; *** get pointer coordinates ***************************************
(import-lambda-definition %query-pointer (display window) (import-xlib-function %query-pointer (display window)
"scx_Query_Pointer") "scx_Query_Pointer")
(define (query-pointer-root display) (define (query-pointer-root display)
@ -341,7 +341,8 @@
;; *** convenience functions ***************************************** ;; *** convenience functions *****************************************
(define (window-exists? dpy window) (define (window-exists? dpy window)
(let ((pe (use-x-error-warnings!))) (display-sync dpy #f)
(let ((before (use-x-error-warnings! dpy #t)))
(let ((result (let ((result
(call-with-current-continuation (call-with-current-continuation
(lambda (return) (lambda (return)
@ -351,5 +352,5 @@
(query-tree dpy window) (query-tree dpy window)
(display-sync dpy #f) (display-sync dpy #f)
#t)))))) #t))))))
(set-error-handler! pe) (if (not before) (use-x-error-warnings! dpy #f))
result))) result)))

28
scheme/xlib/wm.scm
View File

@ -7,7 +7,7 @@
;; position in the hierarchy, and inserts it as the child of the ;; position in the hierarchy, and inserts it as the child of the
;; specified parent. See XReparentWindow. ;; specified parent. See XReparentWindow.
(import-lambda-definition reparent-window (display window parent x y) (import-xlib-function reparent-window (display window parent x y)
"scx_Reparent_Window") "scx_Reparent_Window")
;; *** control colormaps ********************************************* ;; *** control colormaps *********************************************
@ -15,20 +15,20 @@
;; install-colormap function installs the specified colormap for ;; install-colormap function installs the specified colormap for
;; its associated screen. See XInstallColormap. ;; its associated screen. See XInstallColormap.
(import-lambda-definition install-colormap (display colormap) (import-xlib-function install-colormap (display colormap)
"scx_Install_Colormap") "scx_Install_Colormap")
;; uninstall-colormap removes the specified colormap from the required ;; uninstall-colormap removes the specified colormap from the required
;; list for its screen. See XUninstallColormap. ;; list for its screen. See XUninstallColormap.
(import-lambda-definition uninstall-colormap (display colormap) (import-xlib-function uninstall-colormap (display colormap)
"scx_Uninstall_Colormap") "scx_Uninstall_Colormap")
;; list-installed-colormaps function returns a list of the currently ;; list-installed-colormaps function returns a list of the currently
;; installed colormaps for the screen of the specified window. See ;; installed colormaps for the screen of the specified window. See
;; XListInstalledColormaps. ;; XListInstalledColormaps.
(import-lambda-definition list-installed-colormaps (display window) (import-xlib-function list-installed-colormaps (display window)
"scx_List_Installed_Colormaps") "scx_List_Installed_Colormaps")
;; *** control input focus ******************************************* ;; *** control input focus *******************************************
@ -36,7 +36,7 @@
;; set-input-focus function changes the input focus and the ;; set-input-focus function changes the input focus and the
;; last-focus-change time. See XSetInputFocus. ;; last-focus-change time. See XSetInputFocus.
(import-lambda-definition set-input-focus (display window revert-to time) (import-xlib-function set-input-focus (display window revert-to time)
"scx_Set_Input_Focus") "scx_Set_Input_Focus")
(define-enumerated-type revert-to :revert-to (define-enumerated-type revert-to :revert-to
@ -49,7 +49,7 @@
;; get-input-focus returns the current focus window and the current focus ;; get-input-focus returns the current focus window and the current focus
;; state (revert-to) as a pair. See XGetInputFocus. ;; state (revert-to) as a pair. See XGetInputFocus.
(import-lambda-definition get-input-focus (display) (import-xlib-function get-input-focus (display)
"scx_Get_Input_Focus") "scx_Get_Input_Focus")
(define (get-input-focus-window display) (define (get-input-focus-window display)
@ -57,7 +57,7 @@
;; *** move pointer ************************************************** ;; *** move pointer **************************************************
(import-lambda-definition general-warp-pointer (import-xlib-function general-warp-pointer
(display src dest src-x src-y src-width src-height (display src dest src-x src-y src-width src-height
dest-x dest-y) dest-x dest-y)
"scx_Warp_Pointer") "scx_Warp_Pointer")
@ -87,7 +87,7 @@
;; possible. The optional percent argument specifies the volume in a ;; possible. The optional percent argument specifies the volume in a
;; range from -100 to 100. 0 is the default value. See XBell. ;; range from -100 to 100. 0 is the default value. See XBell.
(import-lambda-definition %bell (display percent) (import-xlib-function %bell (display percent)
"scx_Bell") "scx_Bell")
(define (bell display . percent) (define (bell display . percent)
@ -103,7 +103,7 @@
;; set-access-control either enables or disables the use of the access ;; set-access-control either enables or disables the use of the access
;; control list at each connection setup. See XSetAccessControl. ;; control list at each connection setup. See XSetAccessControl.
(import-lambda-definition set-access-control (display enable?) (import-xlib-function set-access-control (display enable?)
"scx_Set_Access_Control") "scx_Set_Access_Control")
;; *** change a client's save set ************************************ ;; *** change a client's save set ************************************
@ -114,7 +114,7 @@
;; BadMatch error results. mode is one of 'insert or 'delete. See ;; BadMatch error results. mode is one of 'insert or 'delete. See
;; XChangeSaveSet. ;; XChangeSaveSet.
(import-lambda-definition change-save-set (display window mode) (import-xlib-function change-save-set (display window mode)
"scx_Change_Save_Set") "scx_Change_Save_Set")
(define-enumerated-type save-set :save-set (define-enumerated-type save-set :save-set
@ -135,10 +135,10 @@
(define-exported-binding "scx-close-down-mode" :close-down-mode) (define-exported-binding "scx-close-down-mode" :close-down-mode)
(import-lambda-definition set-close-down-mode (display mode) (import-xlib-function set-close-down-mode (display mode)
"scx_Set_Close_Down_Mode") "scx_Set_Close_Down_Mode")
(import-lambda-definition kill-client (display xid) (import-xlib-function kill-client (display xid)
"scx_Kill_Client") "scx_Kill_Client")
;; *** manipulate pointer settings *********************************** ;; *** manipulate pointer settings ***********************************
@ -147,7 +147,7 @@
;; element the logical button number for the physical button i+1. See ;; element the logical button number for the physical button i+1. See
;; XGetPointerMapping. ;; XGetPointerMapping.
(import-lambda-definition get-pointer-mapping (display) (import-xlib-function get-pointer-mapping (display)
"scx_Get_Pointer_Mapping") "scx_Get_Pointer_Mapping")
;; set-pointer-mapping sets the mapping of the pointer. mapping must ;; set-pointer-mapping sets the mapping of the pointer. mapping must
@ -156,7 +156,7 @@
;; down state, then #f is returned and the mapping is not changed, #t ;; down state, then #f is returned and the mapping is not changed, #t
;; otherwise. See XSetPointerMapping. ;; otherwise. See XSetPointerMapping.
(import-lambda-definition set-pointer-mapping (display mapping) (import-xlib-function set-pointer-mapping (display mapping)
"scx_Set_Pointer_Mapping") "scx_Set_Pointer_Mapping")
;; TODO: there is a lot more... ;; TODO: there is a lot more...

4
scheme/xlib/xlib-interfaces.scm
View File

@ -21,6 +21,7 @@
display:bitmap-unit display:bitmap-pad display:bitmap-bit-order display:bitmap-unit display:bitmap-pad display:bitmap-bit-order
display:vendor-release display:queue-length display:name display:vendor-release display:queue-length display:name
display:default-screen display:screens display-message-inport display:default-screen display:screens display-message-inport
display:error-queue
(byte-order :syntax) byte-order? (byte-order :syntax) byte-order?
(bit-order :syntax) bit-order? (bit-order :syntax) bit-order?
@ -178,14 +179,11 @@
(error-code :syntax) error-code? (error-code :syntax) error-code?
use-x-error-warnings! use-x-error-warnings!
use-x-error-queue!
x-error-queue? x-error-queue:this x-error-queue? x-error-queue:this
empty-x-error-queue? empty-x-error-queue?
next-x-error-queue next-x-error-queue
((set-error-handler!) (proc ((proc (:display :x-error) :value))
(proc (:display :x-error) :value)))
get-error-text get-error-text
get-error-database-text get-error-database-text