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

- replaced the use of symbols 'none, 'parent-relative etc. by 

functions that create special X-Objects. e.g. special-window:none,
  special-pixmap:copy-from-parent.

- added a discloser for windows (makes debugging easier).

- fixed bugs in gcontext-font, get-window-attributes and text-width

- added enumerated types for colormap-alloc in create-colormap and grab-mode
This commit is contained in:
frese 2002-03-17 15:41:56 +00:00
parent 84ca2f8675
commit a7ec9ccd53
21 changed files with 216 additions and 266 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
c/xlib/colormap.c
View File

@ -68,7 +68,7 @@ s48_value scx_Create_Colormap (s48_value Xdisplay, s48_value Xwindow,
Colormap cm = XCreateColormap( SCX_EXTRACT_DISPLAY(Xdisplay),
SCX_EXTRACT_WINDOW(Xwindow),
SCX_EXTRACT_VISUAL(Xvisual),
S48_FALSE_P(alloc) ? AllocNone : AllocAll );
s48_extract_integer(alloc) );
return SCX_ENTER_COLORMAP(cm);
}

30
c/xlib/grab.c
View File

@ -1,21 +1,16 @@
#include "xlib.h"
int Get_Mode (s48_value m){
return S48_EXTRACT_BOOLEAN(m) ? GrabModeSync :GrabModeAsync;
}
s48_value scx_Grab_Pointer (s48_value dpy, s48_value win,
s48_value ownerp, s48_value events,
s48_value psyncp, s48_value ksyncp,
s48_value pmode, s48_value kmode,
s48_value confine_to, s48_value cursor,
s48_value time) {
int res = XGrabPointer(SCX_EXTRACT_DISPLAY(dpy),
SCX_EXTRACT_WINDOW(win),
S48_EXTRACT_BOOLEAN(ownerp),
s48_extract_integer(events),
Get_Mode(psyncp),
Get_Mode(ksyncp),
s48_extract_integer(pmode),
s48_extract_integer(kmode),
SCX_EXTRACT_WINDOW(confine_to),
SCX_EXTRACT_CURSOR(cursor),
SCX_EXTRACT_TIME(time));
@ -31,7 +26,7 @@ s48_value scx_Ungrab_Pointer (s48_value dpy, s48_value time) {
s48_value scx_Grab_Button (s48_value dpy, s48_value win, s48_value button,
s48_value mods, s48_value ownerp, s48_value events,
s48_value psyncp, s48_value ksyncp,
s48_value pmode, s48_value kmode,
s48_value confine_to, s48_value cursor){
XGrabButton(SCX_EXTRACT_DISPLAY(dpy),
s48_extract_integer(button),
@ -39,7 +34,8 @@ s48_value scx_Grab_Button (s48_value dpy, s48_value win, s48_value button,
SCX_EXTRACT_WINDOW(win),
S48_EXTRACT_BOOLEAN(ownerp),
s48_extract_integer(events),
Get_Mode(psyncp), Get_Mode(ksyncp),
s48_extract_integer(pmode),
s48_extract_integer(kmode),
SCX_EXTRACT_WINDOW(confine_to),
SCX_EXTRACT_CURSOR(cursor));
return S48_UNSPECIFIC;
@ -67,13 +63,13 @@ s48_value scx_Change_Active_Pointer_Grab (s48_value Xdpy, s48_value events,
s48_value scx_Grab_Keyboard (s48_value Xdpy, s48_value Xwin, s48_value ownerp,
s48_value psyncp, s48_value ksyncp,
s48_value pmode, s48_value kmode,
s48_value time){
int res = XGrabKeyboard( SCX_EXTRACT_DISPLAY(Xdpy),
SCX_EXTRACT_WINDOW(Xwin),
S48_EXTRACT_BOOLEAN(ownerp),
Get_Mode(psyncp),
Get_Mode (ksyncp),
s48_extract_integer(pmode),
s48_extract_integer(kmode),
SCX_EXTRACT_TIME(time));
return s48_enter_integer(res);
}
@ -87,8 +83,8 @@ s48_value scx_Ungrab_Keyboard (s48_value Xdpy, s48_value time){
s48_value scx_Grab_Key (s48_value Xdpy, s48_value Xwin, s48_value key,
s48_value mods, s48_value ownerp, s48_value psyncp,
s48_value ksyncp, s48_value flag){
s48_value mods, s48_value ownerp, s48_value pmode,
s48_value kmode, s48_value flag){
int keycode = AnyKey;
if (!S48_EXTRACT_BOOLEAN(flag))
keycode = (int)s48_extract_integer(key);
@ -97,8 +93,8 @@ s48_value scx_Grab_Key (s48_value Xdpy, s48_value Xwin, s48_value key,
s48_extract_integer(mods),
SCX_EXTRACT_WINDOW(Xwin),
S48_EXTRACT_BOOLEAN(ownerp),
Get_Mode(psyncp),
Get_Mode (ksyncp));
s48_extract_integer(pmode),
s48_extract_integer(kmode));
return S48_UNSPECIFIC;
}

9
c/xlib/init.c
View File

@ -20,16 +20,7 @@ s48_value scx_Xlib_Release_6_Or_Later () {
#endif
}
s48_value symbol_now_binding = S48_FALSE;
s48_value symbol_now() {
return S48_SHARED_BINDING_REF(symbol_now_binding);
}
void scx_init_init(void) {
S48_GC_PROTECT_GLOBAL(symbol_now_binding);
// *symbol-now* is defined in helper.scm
symbol_now_binding = s48_get_imported_binding("*symbol-now*");
S48_EXPORT_FUNCTION(scx_Xlib_Release_4_Or_Later);
S48_EXPORT_FUNCTION(scx_Xlib_Release_5_Or_Later);
S48_EXPORT_FUNCTION(scx_Xlib_Release_6_Or_Later);

6
c/xlib/xlib.h
View File

@ -21,8 +21,6 @@
#define S48_FALSE_P(x) S48_EQ(x, S48_FALSE)
#define S48_TRUE_P(x) S48_EQ(x, S48_TRUE)
extern s48_value symbol_now(); // defined in init.c
/* Extraction-Macros for the new types, from their s48_value wrapping.
*/
@ -42,8 +40,8 @@ extern s48_value symbol_now(); // defined in init.c
#define SCX_EXTRACT_DRAWABLE(x) (Drawable)s48_extract_integer(x)
#define SCX_ENTER_ATOM(x) s48_enter_integer((long)x)
#define SCX_EXTRACT_ATOM(x) (Atom)s48_extract_integer(x)
#define SCX_ENTER_TIME(x) x == CurrentTime ? symbol_now() : s48_enter_integer(x)
#define SCX_EXTRACT_TIME(x) S48_SYMBOL_P(x) ? CurrentTime : (int)s48_extract_integer(x)
#define SCX_ENTER_TIME(x) s48_enter_integer(x)
#define SCX_EXTRACT_TIME(x) (int)s48_extract_integer(x)
#define SCX_EXTRACT_CURSOR(x) (Cursor)s48_extract_integer(x)
#define SCX_ENTER_CURSOR(x) s48_enter_integer((long)x)
#define SCX_ENTER_FONT(x) s48_enter_integer((long)x)

38
scheme/xlib/atom-type.scm
View File

@ -4,31 +4,25 @@
(really-make-atom tag Xatom)
atom?
(tag atom-tag atom-set-tag!)
(Xatom real-atom-Xatom atom-set-Xatom!))
(define (atom-Xatom atom)
(if (none-resource? atom)
0
(real-atom-Xatom atom)))
(Xatom atom-Xatom atom-set-Xatom!))
(define (make-atom Xatom)
(if (= 0 Xatom)
none-resource
(let ((maybe-atom (atom-list-find Xatom)))
(if maybe-atom
maybe-atom
(let ((atom (really-make-atom #f Xatom)))
(add-finalizer! atom finalize-atom)
(atom-list-set! Xatom atom)
atom)))))
(let ((maybe-atom (atom-list-find Xatom)))
(if maybe-atom
maybe-atom
(let ((atom (really-make-atom #f Xatom)))
(add-finalizer! atom finalize-atom)
(atom-list-set! Xatom atom)
atom))))
;; intern-atom returns an atom. if an atom of that name did not exist
;; before, a new one is created. See XInternAtom.
(define (intern-atom display name)
(let ((Xatom (%intern-atom (display-Xdisplay display)
(if (symbol? name)
(symbol->string name)
name))))
(make-atom Xatom)))
(make-atom (%intern-atom (display-Xdisplay display)
(if (symbol? name)
(symbol->string name)
name))))
(import-lambda-definition %intern-atom (Xdisplay name)
"scx_Intern_Atom")
@ -42,7 +36,6 @@
;(atom-set-Xatom! atom 'already-freed)
(atom-list-delete! Xatom)))
;; All atom records need to be saved in a weak-list, to have only one record
;; for the same XLib atom
@ -61,3 +54,6 @@
(define (atom-list-delete! Xatom)
(table-set! *weak-atom-list* Xatom #f))
;; Special atom value
(define special-atom:none (make-atom 0))

4
scheme/xlib/color-type.scm
View File

@ -9,8 +9,8 @@
(define-record-discloser :color
(lambda (c)
(let ((rgb (extract-rgb-values c)))
`(Color ,(/ (car rgb) 65535) ,(/ (cadr rgb) 65535)
,(/ (caddr rgb) 65535)))))
`(Color ,(/ (car rgb) 65535.) ,(/ (cadr rgb) 65535.)
,(/ (caddr rgb) 65535.)))))
(define (internal-make-color Xcolor)
(let ((maybe-color (color-list-find Xcolor)))

27
scheme/xlib/colormap-type.scm
View File

@ -4,26 +4,19 @@
(really-make-colormap tag Xcolormap display)
colormap?
(tag colormap-tag colormap-set-tag!)
(Xcolormap real-colormap-Xcolormap colormap-set-Xcolormap!)
(Xcolormap colormap-Xcolormap colormap-set-Xcolormap!)
(display colormap-display colormap-set-display!))
(define (colormap-Xcolormap colormap)
(if (none-resource? colormap)
none-resource
(real-colormap-Xcolormap colormap)))
(define (make-colormap Xcolormap display finalize?)
(if (none-resource? Xcolormap)
'none
(let ((maybe-colormap (colormap-list-find Xcolormap)))
(if maybe-colormap
maybe-colormap
(let ((colormap (really-make-colormap #f Xcolormap display)))
(if finalize?
(add-finalizer! colormap free-colormap)
(add-finalizer! colormap colormap-list-delete!))
(colormap-list-set! Xcolormap colormap)
colormap)))))
(let ((maybe-colormap (colormap-list-find Xcolormap)))
(if maybe-colormap
maybe-colormap
(let ((colormap (really-make-colormap #f Xcolormap display)))
(if finalize?
(add-finalizer! colormap free-colormap)
(add-finalizer! colormap colormap-list-delete!))
(colormap-list-set! Xcolormap colormap)
colormap))))
(define (free-colormap colormap)
(let ((Xcolormap (colormap-Xcolormap colormap)))

25
scheme/xlib/colormap.scm
View File

@ -1,7 +1,13 @@
;; Author: David Frese
;; alloc-color returns the pixel closest to the specified color supported by the
;; hardware. See XAllocColor. The color parameter is mutated!
;; special colormaps
(define (special-colormap:none dpy)
(make-colormap 0 dpy #f))
;; alloc-color returns the pixel closest to the specified color
;; supported by the hardware. See XAllocColor. The color parameter is
;; mutated!
(define (alloc-color! colormap color)
(let ((Xpixel (%alloc-color (colormap-Xcolormap colormap)
@ -66,21 +72,26 @@
;; The create-colormap function creates a colormap of the specified
;; visual type for the screen on which the specified window resides.
;; alloc can be 'none or 'all. See XCreateColormap.
;; alloc can be (colormap-alloc none) or (colormap-alloc all). See
;; XCreateColormap.
(define (create-colormap window visual alloc)
(let ((Xcolormap (%create-colormap (display-Xdisplay (window-display window))
(window-Xwindow window)
(visual-Xvisual visual)
(if (eq? alloc 'none)
#f
#t) ; 'all
)))
(colormap-alloc->integer alloc))))
(make-colormap Xcolormap (window-display window) #t)))
(import-lambda-definition %create-colormap (Xdisplay Xwindow Xvisual alloc)
"scx_Create_Colormap")
(define-enumerated-type colormap-alloc :colormap-alloc
colormap-alloc? colormap-allocs colormap-alloc-name colormap-alloc-index
(none all))
(define (colormap-alloc->integer v)
(colormap-alloc-index v))
;; The alloc-color-cells function allocates read/write color cells.
;; The number of colors must be positive and the number of planes
;; nonnegative, or a BadValue error results. See XAllocColorCells.

27
scheme/xlib/cursor-type.scm
View File

@ -2,26 +2,19 @@
(really-make-cursor tag Xcursor display)
cursor?
(tag cursor-tag cursor-set-tag!)
(Xcursor real-cursor-Xcursor cursor-set-Xcursor!)
(Xcursor cursor-Xcursor cursor-set-Xcursor!)
(display cursor-display cursor-set-display!))
(define (cursor-Xcursor cursor)
(if (none-resource? cursor)
0
(real-cursor-Xcursor cursor)))
(define (make-cursor Xcursor display finalize?)
(if (= 0 Xcursor)
none-resource
(let ((maybe-cursor (cursor-list-find Xcursor)))
(if maybe-cursor
maybe-cursor
(let ((cursor (really-make-cursor #f Xcursor display)))
(if finalize?
(add-finalizer! cursor free-cursor)
(add-finalizer! cursor cursor-list-delete!))
(cursor-list-set! Xcursor cursor)
cursor)))))
(let ((maybe-cursor (cursor-list-find Xcursor)))
(if maybe-cursor
maybe-cursor
(let ((cursor (really-make-cursor #f Xcursor display)))
(if finalize?
(add-finalizer! cursor free-cursor)
(add-finalizer! cursor cursor-list-delete!))
(cursor-list-set! Xcursor cursor)
cursor))))
;; ...

5
scheme/xlib/cursor.scm
View File

@ -18,6 +18,11 @@
(import-lambda-definition %create-pixmap-cursor (Xdisplay src mask x y f b)
"scx_Create_Pixmap_Cursor")
;; Special cursor values
(define (special-cursor:none dpy)
(make-cursor 0 dpy #f))
;; create-glyph-cursor returns a cursor, that was build using the font
;; src, an integer src-char, a font mask, an integer mask-char, and
;; the colors foreground and background. See XCreateGlyphCursor.

4
scheme/xlib/display-type.scm
View File

@ -91,3 +91,7 @@
(import-lambda-definition %display-message-fd (Xdisplay)
"scx_Display_Message_fd")
;; this can be used as a time argument. (a little bit misplaced here)
(define special-time:current-time 0)

13
scheme/xlib/font-type.scm
View File

@ -2,15 +2,10 @@
(really-make-font name Xfont Xfontstruct display)
font?
(name font-name font-set-name!)
(Xfont real-font-Xfont font-set-Xfont!)
(Xfont font-Xfont font-set-Xfont!)
(Xfontstruct font-Xfontstruct font-set-Xfontstruct!)
(display font-display font-set-display!))
(define (font-Xfont font)
(if (none-resource? font)
0
(real-font-Xfont font)))
;; creates a font object. name can be #f. Either Xfont or Xfontstruct
;; has to bes specified. if Xfont is #f then it is obtained from the
;; Xfontstruct. if Xfontstruct is #f it queried with XQueryFont - but
@ -42,6 +37,11 @@
(import-lambda-definition %font->fontstruct (Xdisplay Xfont)
"scx_Font_ID_To_Font")
;; Special font values
(define (special-font:none dpy)
(make-font #f 0 #f dpy #f))
;; load-font loads a font by its name. See XLoadQueryFont.
(define (load-font display font-name)
@ -73,7 +73,6 @@
(font-set-Xfontstruct! font 'already-freed)
(font-set-Xfont! font 'already-freed)))
;; for compatibility with Elk:
(define close-font unload-font)

32
scheme/xlib/gcontext-type.scm
View File

@ -2,26 +2,24 @@
(really-make-gcontext tag Xgcontext display)
gcontext?
(tag gcontext-tag gcontext-set-tag!)
(Xgcontext real-gcontext-Xgcontext gcontext-set-Xgcontext!)
(Xgcontext gcontext-Xgcontext gcontext-set-Xgcontext!)
(display gcontext-display gcontext-set-display!))
(define (gcontext-Xgcontext gcontext)
(if (none-resource? gcontext)
0
(real-gcontext-Xgcontext gcontext)))
(define (make-gcontext Xgcontext display finalize?)
(if (= 0 Xgcontext)
none-resource
(let ((maybe-gcontext (gcontext-list-find Xgcontext)))
(if maybe-gcontext
maybe-gcontext
(let ((gcontext (really-make-gcontext #f Xgcontext display)))
(if finalize?
(add-finalizer! gcontext free-gcontext)
(add-finalizer! gcontext gcontext-list-delete!))
(gcontext-list-set! Xgcontext gcontext)
gcontext)))))
(let ((maybe-gcontext (gcontext-list-find Xgcontext)))
(if maybe-gcontext
maybe-gcontext
(let ((gcontext (really-make-gcontext #f Xgcontext display)))
(if finalize?
(add-finalizer! gcontext free-gcontext)
(add-finalizer! gcontext gcontext-list-delete!))
(gcontext-list-set! Xgcontext gcontext)
gcontext))))
;; special gcontext values
(define (special-gcontext:none dpy)
(make-gcontext 0 dpy #f))
;; to free the gcontext X-lib ressources call free-gcontext. if gcontext is
;; already freed, the function does nothing.

43
scheme/xlib/grab.scm
View File

@ -12,20 +12,21 @@
(define (integer->grab-status i)
(vector-ref grab-states i))
(define (grab-pointer window owner? events ptr-sync? kbd-sync?
(define (grab-pointer window owner? events ptr-mode kbd-mode
confine-to cursor time)
(integer->grab-status
(%grab-pointer (display-Xdisplay (window-display window))
(window-Xwindow window)
owner?
(event-mask->integer events)
ptr-sync? kbd-sync?
(grab-mode->integer ptr-mode)
(grab-mode->integer kbd-mode)
(window-Xwindow confine-to)
(cursor-Xcursor cursor)
time)))
(import-lambda-definition %grab-pointer (Xdisplay Xwindow owner? events
ptr-sync? kbd-sync?
ptr-mode kbd-mode
Xconfine-to Xcursor time)
"scx_Grab_Pointer")
@ -38,11 +39,20 @@
(import-lambda-definition %ungrab-pointer (Xdisplay time)
"scx_Ungrab_Pointer")
;; grab-button performs a grab-pointer depending on a corresponding
;; button press event. See XGrabButton.
(define (grab-button window button mod owner? events ptr-sync? kbd-sync?
(define-enumerated-type grab-mode :grab-mode
grab-mode? grab-modes grab-mode-name grab-mode-index
(sync async))
(define (grab-mode->integer m)
(grab-mode-index m))
(define (interger->grab-mode i)
(vector-ref grab-modes i))
(define (grab-button window button mod owner? events ptr-mode kbd-mode
confine-to cursor)
(%grab-button (display-Xdisplay (window-display window))
(window-Xwindow window)
@ -50,13 +60,14 @@
(state-set->integer mod)
owner?
(event-mask->integer events)
ptr-sync? kbd-sync?
(grab-mode->integer ptr-mode)
(grab-mode->integer kbd-mode)
(window-Xwindow confine-to)
(cursor-Xcursor cursor)))
(import-lambda-definition %grab-button (Xdisplay Xwindow button
mods ownerp events
ptr-sync? kbd-sync?
ptr-mode kbd-mode
Xconfine-to Xcursor)
"scx_Grab_Button")
@ -94,14 +105,17 @@
;; client has it actively grabbed from either grab-keyboard or
;; grab-Key. See XGrabKeyboard and XUngrabKeyboard.
(define (grab-keyboard window owner? ptr-sync? kbd-sync? time)
(define (grab-keyboard window owner? ptr-mode kbd-mode time)
(integer->grab-status
(%grab-keyboard (display-Xdisplay (window-display window))
(window-Xwindow window)
owner? ptr-sync? kbd-sync? time)))
owner?
(grab-mode->integer ptr-mode)
(grab-mode->integer kbd-mode)
time)))
(import-lambda-definition %grab-keyboard (Xdisplay Xwindow
owner? ptr-sync? kbd-sync?
owner? ptr-mode kbd-mode
time)
"scx_Grab_Keyboard")
@ -118,15 +132,18 @@
;; grabbed.
;; ungrab-key releases this passive grab. See XGrabKey and XUngrabKey.
(define (grab-key window key mod owner? ptr-sync? kbd-sync?)
(define (grab-key window key mod owner? ptr-mode kbd-mode)
(%grab-key (display-Xdisplay (window-display window))
(window-Xwindow window)
key
(state-set->integer mod)
owner? ptr-sync? kbd-sync? (symbol? key)))
owner?
(grab-mode->integer ptr-mode)
(grab-mode->integer kbd-mode)
(symbol? key)))
(import-lambda-definition %grab-key (Xdisplay xwindow key mod
owner ptr-sync? kbd-sync? flag)
owner ptr-mode kbd-mode flag)
"scx_Grab_Key")
(define (ungrab-key window key mod)

69
scheme/xlib/helper.scm
View File

@ -1,71 +1,3 @@
;; make-enum-alist->vector creates a function that converts an
;; association list, that maps from an enumerated type to some values,
;; into a vector. The vector element i contains #f if the
;; corresponding element i of the enumerated type was not defined in
;; the alist, and the value ((converter i) value) otherwise. Be sure
;; to convert boolean values to something else, if you want to know if
;; a value was not defined, or defined as #f afterwards.
(define (make-enum-alist->vector enum-vector index-fun converter)
(lambda (alist)
(let ((res (make-vector (vector-length enum-vector) #f)))
(for-each (lambda (a)
(vector-set! res (index-fun (car a))
a))
alist)
(let loop ((i 0))
(if (< i (vector-length res))
(begin
(if (vector-ref res i)
(vector-set! res i
((converter i) (cdr (vector-ref res i)))))
(loop (+ i 1)))))
res)))
;; and the other way round...
(define (make-vector->enum-alist enum-vector converter)
(lambda (vector extra-arg)
(let loop ((i 0))
(if (< i (vector-length vector))
(begin
(vector-set! vector
i
((converter i extra-arg) (vector-ref vector i)))
(loop (+ i 1)))
(map cons
(vector->list enum-vector)
(vector->list vector))))))
;;
(define-exported-binding "*symbol-now*" 'now)
;; alist-split returns multiple values. the first values are all associations
;; of the keys. and additionaly the "rest" of the alist as one value.
(define (alist-split alist key-def-list)
(let ((keys (map car key-def-list)))
(let ((vals (map (lambda (key)
(let ((v (assq key alist)))
(cdr (if v v (assq key key-def-list)))))
keys))
(rest (fold-right (lambda (this rest)
(if (memq (car this) keys)
rest
(cons this rest)))
'()
alist)))
(apply values (append vals (list rest))))))
;; compagnion to the XLib constant "None" which is defined as "0L"
(define (none-resource? obj)
(eq? obj none-resource))
(define none-resource 'none)
;;
(define (vector-map! f v)
@ -76,3 +8,4 @@
(vector-set! v i (f (vector-ref v i)))
(loop (+ i 1)))
v))))

29
scheme/xlib/pixmap-type.scm
View File

@ -4,28 +4,19 @@
(really-make-pixmap tag Xpixmap display)
pixmap?
(tag pixmap-tag pixmap-set-tag!)
(Xpixmap real-pixmap-Xpixmap pixmap-set-Xpixmap!)
(Xpixmap pixmap-Xpixmap pixmap-set-Xpixmap!)
(display pixmap-display pixmap-set-display!))
(define (pixmap-Xpixmap pixmap)
(if (none-resource? pixmap)
0
(real-pixmap-Xpixmap pixmap)))
(define (make-pixmap Xpixmap display finalize?)
(if (= 0 Xpixmap)
none-resource
(let ((maybe-pixmap (pixmap-list-find Xpixmap)))
(if maybe-pixmap
maybe-pixmap
(let ((pixmap (really-make-pixmap #f Xpixmap display)))
(if finalize?
(add-finalizer! pixmap free-pixmap)
(add-finalizer! pixmap pixmap-list-delete!))
(pixmap-list-set! Xpixmap pixmap)
pixmap)))))
;; ...
(let ((maybe-pixmap (pixmap-list-find Xpixmap)))
(if maybe-pixmap
maybe-pixmap
(let ((pixmap (really-make-pixmap #f Xpixmap display)))
(if finalize?
(add-finalizer! pixmap free-pixmap)
(add-finalizer! pixmap pixmap-list-delete!))
(pixmap-list-set! Xpixmap pixmap)
pixmap))))
(define (free-pixmap pixmap)
(let ((Xdisplay (display-Xdisplay (pixmap-display pixmap)))

9
scheme/xlib/pixmap.scm
View File

@ -14,6 +14,15 @@
(import-lambda-definition %create-pixmap (Xdisplay Xdrawable w h depth)
"scx_Create_Pixmap")
;; Special pixmap values
(define (special-pixmap:none dpy)
(make-pixmap 0 dpy #f))
(define (special-pixmap:copy-from-parent dpy)
(make-pixmap 0 dpy #f))
(define (special-pixmap:parent-relative dpy)
(make-pixmap 1 dpy #f))
;; create-bitmap-from-data creates a new pixmap, consisting of the
;; image found in data, which has to be a string. Such an image can be
;; generated with write-bitmap-file. See XCreateBitmapFromData.

2
scheme/xlib/text.scm
View File

@ -161,7 +161,7 @@
(not (list? text-or-font)))
(cons (if (font? (car text-or-font))
(font-Xfont (car text-or-font))
'none)
0)
(cdr text-or-font)))
(else (text->internal-text text-or-font
format))))

25
scheme/xlib/types.scm
View File

@ -269,10 +269,11 @@
set-window-attributes
set-window-attribute-name
set-window-attribute-index
;; don't change the order of the attributes!
;; special values: background-pixmap can be a pixmap,
;; 'parent-relative or 'none. border-pixmap can be a pixmap or
;; 'copy-from-parent.
;; don't change the order of the attributes! background-pixmap can
;; be a pixmap including (special-pixmap:none dpy) and
;; (special-pixmap:parent-relative dpy) border-pixmap can be a
;; pixmap or (special-pixmap:copy-from-parent dpy)
(background-pixmap background-pixel border-pixmap border-pixel
bit-gravity gravity backing-store backing-planes backing-pixel
override-redirect save-under event-mask do-not-propagate-mask colormap
@ -293,19 +294,9 @@
set-window-attribute-index
(lambda (attr)
(cond
((eq? attr (set-window-attribute background-pixmap))
(lambda (background)
(cond
((pixmap? background) (pixmap-Xpixmap background))
((eq? background 'parent-relative) 1)
((eq? background 'none) 0)
(else (error "invalid background-pixmap" background)))))
((eq? attr (set-window-attribute border-pixmap))
(lambda (border)
(cond
((pixmap? border) (pixmap-Xpixmap border))
((eq? border 'copy-from-parent) 0)
(else (error "invalid border-pixmap" border)))))
((or (eq? attr (set-window-attribute background-pixmap))
(eq? attr (set-window-attribute border-pixmap)))
pixmap-Xpixmap)
((or (eq? attr (set-window-attribute background-pixel))
(eq? attr (set-window-attribute border-pixel))
(eq? attr (set-window-attribute backing-pixel))

59
scheme/xlib/window-type.scm
View File

@ -8,26 +8,51 @@
(display window-display window-set-display!))
(define (window-Xwindow window)
(if (none-resource? window)
0
(real-window-Xwindow window)))
(real-window-Xwindow window))
(define-record-discloser :window
(lambda (window)
(let ((tag (window-tag window))
(ID (window-Xwindow window)))
(if tag
`(Window ,tag)
`(Window ,ID)))))
(define (make-window Xwindow display finalize?)
(if (= 0 Xwindow)
none-resource
(let ((maybe-window (window-list-find Xwindow)))
(if maybe-window
maybe-window
(let ((window (really-make-window #f Xwindow display)))
(if finalize?
(add-finalizer! window destroy-window)
(add-finalizer! window window-list-delete!))
(window-list-set! Xwindow window)
window)))))
(let ((maybe-window (window-list-find Xwindow)))
(if maybe-window
maybe-window
(let ((window (really-make-window #f Xwindow display)))
(if finalize?
(add-finalizer! window destroy-window)
(add-finalizer! window window-list-delete!))
(window-list-set! Xwindow window)
window))))
;; The destroy-window function destroys the specified window as well as all of
;; its subwindows and causes the X server to generate a destroy-notify event for
;; each window. See XDestroyWindow
;; Special windows that can be passed to some functions.
(define (special-window:none dpy) (make-window 0 dpy #f))
(define (special-window:pointer-window dpy) (make-window 0 dpy #f))
(define (special-window:input-focus dpy) (make-window 1 dpy #f))
(define (special-window:pointer-root dpy) (make-window 1 dpy #f))
; (define-syntax special-window ; (special-window none dpy)
; (lambda (form rename compare)
; (let ((id (cadr form))
; (dpy (caddr form))
; (%make-window (rename 'make-window))
; (%error (rename 'error)))
; (case id
; ((none) `(,%make-window 0 ,dpy #f))
; ((pointer-window) `(,%make-window 0 ,dpy #f))
; ((input-focus) `(,%make-window 1 ,dpy #f))
; ((pointer-root) `(,%make-window 1 ,dpy #f))
; (else `(,%error "Undefined special-window identifier" ',id)))))
; (make-window error))
;; The destroy-window function destroys the specified window as well
;; as all of its subwindows and causes the X server to generate a
;; destroy-notify event for each window. See XDestroyWindow
(define (destroy-window window)
(let ((Xdisplay (display-Xdisplay (window-display window)))

20
scheme/xlib/wm.scm
View File

@ -53,10 +53,7 @@
(define (set-input-focus display window revert-to time)
(%set-input-focus (display-Xdisplay display)
(case window
((none) 0)
((pointer-root) 1)
(else (window-Xwindow window)))
(window-Xwindow window)
(revert-to->integer revert-to)
time))
@ -100,22 +97,25 @@
Xsrc-win src-x src-y src-width src-height)
"scx_General_Warp_Pointer")
;; warp-pointer calls general-warp-pointer with using 'none as the
;; src-win and 0 for the src-* coordinates. The display is taken from
;; dst-window.
;; warp-pointer calls general-warp-pointer with using
;; (special-window:none dpy) as the src-win and 0 for the src-*
;; coordinates. The display is taken from dst-window.
(define (warp-pointer dst-window dst-x dst-y)
(general-warp-pointer (window-display dst-window)
dst-window dst-x dst-y
'none 0 0 0 0))
(special-window:none (window-display dst-window))
0 0 0 0))
;; warp-pointer-relative uses general-warp-pointer to move the pointer
;; by x-offset and y-offset away from it's current position.
(define (warp-pointer-relative display x-offset y-offset)
(general-warp-pointer display
'none x-offset y-offset
'none 0 0 0 0))
(special-window:none display)
x-offset y-offset
(special-window:none display)
0 0 0 0))
;; bell rings the bell on the keyboard on the specified display, if
;; possible. The optional percent argument specifies the volume in a