obsolete
This commit is contained in:
frese
parent
a36065a672
commit
829150be2f
106
Makefile
106
Makefile
|
|
@ -1,106 +0,0 @@
|
||||||
### update this to fit your system
|
|
||||||
SCSH_PREFIX = /afs/wsi/i386_fbsd43/scsh-0.6.1/
|
|
||||||
X11_PATH = /usr/X11R6
|
|
||||||
LIB_DL =
|
|
||||||
|
|
||||||
### the following does not have to be changed (hopefully)
|
|
||||||
SCHEME_INCLUDE = $(SCSH_PREFIX)/include
|
|
||||||
SCSH_LIB = $(SCSH_PREFIX)/lib/scsh
|
|
||||||
X11_INCLUDE = $(X11_PATH)/include
|
|
||||||
X11_LIB = $(X11_PATH)/lib
|
|
||||||
|
|
||||||
CC = gcc
|
|
||||||
|
|
||||||
SCX_VERSION = "0.1"
|
|
||||||
SCX_VM = scxvm
|
|
||||||
SCX_IMAGE = scx.image
|
|
||||||
SCX = scx
|
|
||||||
|
|
||||||
LIBS = -lscsh -lm -lX11 -lcrypt -lXpm $(LIB_DL)
|
|
||||||
|
|
||||||
### The first=default target
|
|
||||||
enough: $(SCX)
|
|
||||||
|
|
||||||
### Making the VM
|
|
||||||
### The VM is scsh plus all new primitives from the c files
|
|
||||||
|
|
||||||
OBJECTS = \
|
|
||||||
c/xlib/display.o c/xlib/window.o c/xlib/color.o \
|
|
||||||
c/xlib/colormap.o c/xlib/pixel.o c/xlib/gcontext.o c/xlib/event.o \
|
|
||||||
c/xlib/pixmap.o c/xlib/graphics.o c/xlib/font.o \
|
|
||||||
c/xlib/cursor.o c/xlib/text.o c/xlib/property.o c/xlib/wm.o \
|
|
||||||
c/xlib/client.o c/xlib/key.o c/xlib/error.o \
|
|
||||||
c/xlib/extension.o c/xlib/init.o c/xlib/util.o c/xlib/grab.o \
|
|
||||||
c/xlib/visual.o c/xlib/region.o \
|
|
||||||
c/libs/xpm.o
|
|
||||||
|
|
||||||
SCM_FILES = scheme/xlib/types.scm \
|
|
||||||
scheme/xlib/atom-type.scm scheme/xlib/client.scm \
|
|
||||||
scheme/xlib/color-type.scm scheme/xlib/color.scm \
|
|
||||||
scheme/xlib/colormap-type.scm scheme/xlib/colormap.scm \
|
|
||||||
scheme/xlib/cursor-type.scm scheme/xlib/cursor.scm \
|
|
||||||
scheme/xlib/display-type.scm \
|
|
||||||
scheme/xlib/display.scm scheme/xlib/drawable-type.scm \
|
|
||||||
scheme/xlib/drawable.scm scheme/xlib/error.scm \
|
|
||||||
scheme/xlib/event-types.scm scheme/xlib/event.scm \
|
|
||||||
scheme/xlib/extension.scm scheme/xlib/font-type.scm \
|
|
||||||
scheme/xlib/font.scm scheme/xlib/gcontext-type.scm \
|
|
||||||
scheme/xlib/gcontext.scm scheme/xlib/grab.scm scheme/xlib/graphics.scm \
|
|
||||||
scheme/xlib/helper.scm scheme/xlib/key.scm scheme/xlib/pixel-type.scm \
|
|
||||||
scheme/xlib/pixel.scm scheme/xlib/pixmap-type.scm \
|
|
||||||
scheme/xlib/pixmap.scm scheme/xlib/property.scm \
|
|
||||||
scheme/xlib/region-type.scm scheme/xlib/region.scm \
|
|
||||||
scheme/xlib/text.scm scheme/xlib/utility.scm \
|
|
||||||
scheme/xlib/visual-type.scm scheme/xlib/visual.scm \
|
|
||||||
scheme/xlib/window-type.scm scheme/xlib/window.scm \
|
|
||||||
scheme/xlib/sync-event.scm \
|
|
||||||
scheme/xlib/wm.scm \
|
|
||||||
scheme/libs/xpm.scm
|
|
||||||
|
|
||||||
SCM_CONFIG_FILES = scheme/xlib/xlib-internal-interfaces.scm \
|
|
||||||
scheme/xlib/xlib-internal-packages.scm \
|
|
||||||
scheme/xlib/xlib-interfaces.scm \
|
|
||||||
scheme/xlib/xlib-packages.scm \
|
|
||||||
scheme/libs/libs-interfaces.scm scheme/libs/libs-packages.scm
|
|
||||||
|
|
||||||
PACKAGES = xlib xlib-types xpm
|
|
||||||
|
|
||||||
$(SCX_VM): tmpmain.o $(OBJECTS)
|
|
||||||
$(CC) -g -o $(SCX_VM) -L $(SCSH_LIB) -L $(X11_LIB) \
|
|
||||||
tmpmain.o $(OBJECTS) $(LIBS)
|
|
||||||
|
|
||||||
$(OBJECTS): c/xlib/xlib.h
|
|
||||||
.c.o:
|
|
||||||
$(CC) -g -c -I $(X11_INCLUDE) -I $(SCHEME_INCLUDE) -o $@ $<
|
|
||||||
|
|
||||||
tmpmain.o: c/main.c
|
|
||||||
$(CC) -g -c -DSCSHIMAGE=\"$(SCSH_LIB)/scsh.image\" -I $(X11_INCLUDE) -I $(SCHEME_INCLUDE) -o $@ $<
|
|
||||||
|
|
||||||
main.o: c/main.c
|
|
||||||
$(CC) -g -c -DSCSHIMAGE=\"`pwd`/scx.image\" -I $(X11_INCLUDE) -I $(SCHEME_INCLUDE) -o $@ $<
|
|
||||||
|
|
||||||
|
|
||||||
### Making the Image
|
|
||||||
### The Image is a dump of the VM with all new packages loaded, and
|
|
||||||
### xlib opened.
|
|
||||||
|
|
||||||
STARTUP_MSG = "with SCX $(SCX_VERSION), the X11 support"
|
|
||||||
|
|
||||||
$(SCX_IMAGE): $(SCX_VM) $(SCM_FILES) $(SCM_CONFIG_FILES)
|
|
||||||
( \
|
|
||||||
echo ",batch on"; \
|
|
||||||
echo ",config ,load $(SCM_CONFIG_FILES)"; \
|
|
||||||
echo ",load-package xlib"; \
|
|
||||||
echo ",load-package xpm"; \
|
|
||||||
echo "(dump-scsh \"$(SCX_IMAGE)\")"; \
|
|
||||||
) | ./$(SCX_VM)
|
|
||||||
|
|
||||||
$(SCX): $(SCX_IMAGE) main.o $(OBJECTS)
|
|
||||||
$(CC) -g -o $@ -L $(SCSH_LIB) -L $(X11_LIB) \
|
|
||||||
main.o $(OBJECTS) $(LIBS)
|
|
||||||
|
|
||||||
clean:
|
|
||||||
rm -f $(SCX_VM) $(SCX) $(SCX_IMAGE) *.o c/*.o c/xlib/*.o c/libs/*.o
|
|
||||||
|
|
||||||
tags:
|
|
||||||
find . -name "*.c" -or -name "*.h" -or -name "*.scm" | etags -
|
|
||||||
|
|
@ -1,10 +0,0 @@
|
||||||
OBJECTS = main.o display.o window.o type.o color.o colormap.o pixel.o gcontext.o event.o pixmap.o graphics.o font.o cursor.o text.o property.o wm.o client.o key.o error.o extension.o init.o util.o grab.o visual.o region.o
|
|
||||||
|
|
||||||
$(OBJECTS): xlib.h
|
|
||||||
.c.o:
|
|
||||||
gcc -g -c -I /usr/X11R6/include/ -I /afs/wsi/home/dfreese/scsh-0.6/c/ -o $@ $<
|
|
||||||
|
|
||||||
test: $(OBJECTS)
|
|
||||||
gcc -g -o test -L /afs/wsi/home/dfreese/i386_fbsd43/scsh-0.6/lib/scsh/ \
|
|
||||||
-L /usr/X11R6/lib \
|
|
||||||
$(OBJECTS) -lscsh -lm -lX11 -lcrypt
|
|
||||||
|
|
@ -1,92 +0,0 @@
|
||||||
#include "xlib.h"
|
|
||||||
|
|
||||||
s48_value scx_Create_Color(s48_value r, s48_value g, s48_value b) {
|
|
||||||
s48_value col = S48_MAKE_VALUE(XColor);
|
|
||||||
XColor* c = S48_EXTRACT_VALUE_POINTER(col, XColor);
|
|
||||||
c->red = s48_extract_integer(r);
|
|
||||||
c->green = s48_extract_integer(g);
|
|
||||||
c->blue = s48_extract_integer(b);
|
|
||||||
|
|
||||||
return col;
|
|
||||||
}
|
|
||||||
|
|
||||||
s48_value scx_Int_Extract_RGB_Values(XColor col) {
|
|
||||||
s48_value res = S48_NULL;
|
|
||||||
S48_DECLARE_GC_PROTECT(1);
|
|
||||||
S48_GC_PROTECT_1(res);
|
|
||||||
|
|
||||||
res = s48_cons( s48_enter_integer(col.blue), res );
|
|
||||||
res = s48_cons( s48_enter_integer(col.green), res );
|
|
||||||
res = s48_cons( s48_enter_integer(col.red), res );
|
|
||||||
|
|
||||||
S48_GC_UNPROTECT();
|
|
||||||
return res;
|
|
||||||
}
|
|
||||||
|
|
||||||
s48_value scx_Extract_RGB_Values(s48_value Xcolor) {
|
|
||||||
return scx_Int_Extract_RGB_Values(*SCX_EXTRACT_COLOR(Xcolor));
|
|
||||||
}
|
|
||||||
|
|
||||||
s48_value scx_Query_Color (s48_value Xcolormap, s48_value Xpixel,
|
|
||||||
s48_value Xdisplay) {
|
|
||||||
XColor c;
|
|
||||||
|
|
||||||
c.pixel = SCX_EXTRACT_PIXEL(Xpixel);
|
|
||||||
XQueryColor(SCX_EXTRACT_DISPLAY(Xdisplay),
|
|
||||||
SCX_EXTRACT_COLORMAP(Xcolormap),
|
|
||||||
&c);
|
|
||||||
|
|
||||||
return scx_Int_Extract_RGB_Values(c);
|
|
||||||
}
|
|
||||||
|
|
||||||
|
|
||||||
s48_value scx_Query_Colors(s48_value Xcolormap, s48_value Xpixels,
|
|
||||||
s48_value Xdisplay) {
|
|
||||||
s48_value result = S48_FALSE;
|
|
||||||
S48_DECLARE_GC_PROTECT(1);
|
|
||||||
|
|
||||||
long n = S48_VECTOR_LENGTH(Xpixels);
|
|
||||||
XColor p[n];
|
|
||||||
int i;
|
|
||||||
|
|
||||||
for (i=0; i < n; i++)
|
|
||||||
p[i].pixel = SCX_EXTRACT_PIXEL(S48_VECTOR_REF(Xpixels, i));
|
|
||||||
|
|
||||||
XQueryColors( SCX_EXTRACT_DISPLAY(Xdisplay),
|
|
||||||
SCX_EXTRACT_COLORMAP(Xcolormap), p, n );
|
|
||||||
|
|
||||||
S48_GC_PROTECT_1(result);
|
|
||||||
result = s48_make_vector(n, S48_FALSE);
|
|
||||||
for (i=0; i < n; i++)
|
|
||||||
S48_VECTOR_SET(result, i, scx_Int_Extract_RGB_Values(p[i]));
|
|
||||||
|
|
||||||
S48_GC_UNPROTECT();
|
|
||||||
return result;
|
|
||||||
}
|
|
||||||
|
|
||||||
s48_value scx_Lookup_Color(s48_value Xcolormap, s48_value Xdisplay,
|
|
||||||
s48_value color_name) {
|
|
||||||
XColor visual, exact;
|
|
||||||
|
|
||||||
s48_value res = S48_FALSE;
|
|
||||||
S48_DECLARE_GC_PROTECT(1);
|
|
||||||
|
|
||||||
if (XLookupColor( SCX_EXTRACT_DISPLAY(Xdisplay),
|
|
||||||
SCX_EXTRACT_COLORMAP(Xcolormap),
|
|
||||||
s48_extract_string(color_name), &visual, &exact )) {
|
|
||||||
S48_GC_PROTECT_1(res);
|
|
||||||
res = scx_Int_Extract_RGB_Values( visual );
|
|
||||||
res = s48_cons(res, scx_Int_Extract_RGB_Values( exact ) );
|
|
||||||
}
|
|
||||||
|
|
||||||
S48_GC_UNPROTECT();
|
|
||||||
return res;
|
|
||||||
}
|
|
||||||
|
|
||||||
void scx_init_color(void) {
|
|
||||||
S48_EXPORT_FUNCTION(scx_Create_Color);
|
|
||||||
S48_EXPORT_FUNCTION(scx_Extract_RGB_Values);
|
|
||||||
S48_EXPORT_FUNCTION(scx_Query_Color);
|
|
||||||
S48_EXPORT_FUNCTION(scx_Query_Colors);
|
|
||||||
S48_EXPORT_FUNCTION(scx_Lookup_Color);
|
|
||||||
}
|
|
||||||
|
|
@ -1,60 +0,0 @@
|
||||||
#include "scheme48.h"
|
|
||||||
|
|
||||||
extern void scx_init_window();
|
|
||||||
extern void scx_init_display();
|
|
||||||
extern void scx_init_type();
|
|
||||||
extern void scx_init_color();
|
|
||||||
extern void scx_init_colormap();
|
|
||||||
extern void scx_init_pixel();
|
|
||||||
extern void scx_init_gcontext();
|
|
||||||
extern void scx_init_event();
|
|
||||||
extern void scx_init_pixmap();
|
|
||||||
extern void scx_init_graphics();
|
|
||||||
extern void scx_init_font();
|
|
||||||
extern void scx_init_cursor();
|
|
||||||
extern void scx_init_text();
|
|
||||||
extern void scx_init_property();
|
|
||||||
extern void scx_init_wm();
|
|
||||||
extern void scx_init_client();
|
|
||||||
extern void scx_init_key();
|
|
||||||
extern void scx_init_error();
|
|
||||||
extern void scx_init_extension();
|
|
||||||
extern void scx_init_init();
|
|
||||||
extern void scx_init_util();
|
|
||||||
extern void scx_init_grab();
|
|
||||||
extern void scx_init_visual();
|
|
||||||
extern void scx_init_region();
|
|
||||||
|
|
||||||
|
|
||||||
int main(){
|
|
||||||
s48_add_external_init(scx_init_window);
|
|
||||||
s48_add_external_init(scx_init_display);
|
|
||||||
s48_add_external_init(scx_init_type);
|
|
||||||
s48_add_external_init(scx_init_color);
|
|
||||||
s48_add_external_init(scx_init_color);
|
|
||||||
s48_add_external_init(scx_init_colormap);
|
|
||||||
s48_add_external_init(scx_init_pixel);
|
|
||||||
s48_add_external_init(scx_init_gcontext);
|
|
||||||
s48_add_external_init(scx_init_event);
|
|
||||||
s48_add_external_init(scx_init_pixmap);
|
|
||||||
s48_add_external_init(scx_init_graphics);
|
|
||||||
s48_add_external_init(scx_init_font);
|
|
||||||
s48_add_external_init(scx_init_text);
|
|
||||||
s48_add_external_init(scx_init_property);
|
|
||||||
s48_add_external_init(scx_init_cursor);
|
|
||||||
s48_add_external_init(scx_init_wm);
|
|
||||||
s48_add_external_init(scx_init_client);
|
|
||||||
s48_add_external_init(scx_init_key);
|
|
||||||
s48_add_external_init(scx_init_error);
|
|
||||||
s48_add_external_init(scx_init_extension);
|
|
||||||
s48_add_external_init(scx_init_init);
|
|
||||||
s48_add_external_init(scx_init_util);
|
|
||||||
s48_add_external_init(scx_init_grab);
|
|
||||||
s48_add_external_init(scx_init_visual);
|
|
||||||
s48_add_external_init(scx_init_region);
|
|
||||||
|
|
||||||
s48_main(8000000, 64000,
|
|
||||||
"/afs/wsi/home/dfreese/i386_fbsd43/scsh-0.6/lib/scheme48/scsh.image",
|
|
||||||
0,(char**) 0);
|
|
||||||
}
|
|
||||||
|
|
||||||
|
|
@ -1,29 +0,0 @@
|
||||||
#include "xlib.h"
|
|
||||||
#include "scheme48.h"
|
|
||||||
|
|
||||||
s48_value scx_Black_Pixel(s48_value Xdisplay) {
|
|
||||||
Display* dpy = SCX_EXTRACT_DISPLAY(Xdisplay);
|
|
||||||
return SCX_ENTER_PIXEL( BlackPixel(dpy, DefaultScreen(dpy)) );
|
|
||||||
}
|
|
||||||
|
|
||||||
s48_value scx_White_Pixel(s48_value Xdisplay) {
|
|
||||||
Display* dpy = SCX_EXTRACT_DISPLAY(Xdisplay);
|
|
||||||
return SCX_ENTER_PIXEL( WhitePixel(dpy, DefaultScreen(dpy)) );
|
|
||||||
}
|
|
||||||
|
|
||||||
s48_value scx_Free_Pixel(s48_value Xpixel, s48_value Xdisplay,
|
|
||||||
s48_value Xcolormap) {
|
|
||||||
unsigned long pixels[1];
|
|
||||||
pixels[0] = SCX_EXTRACT_PIXEL(Xpixel);
|
|
||||||
|
|
||||||
XFreeColors(SCX_EXTRACT_DISPLAY(Xdisplay), SCX_EXTRACT_COLORMAP(Xcolormap),
|
|
||||||
pixels, 1, 0);
|
|
||||||
|
|
||||||
return S48_UNSPECIFIC;
|
|
||||||
}
|
|
||||||
|
|
||||||
void scx_init_pixel(void) {
|
|
||||||
S48_EXPORT_FUNCTION(scx_Black_Pixel);
|
|
||||||
S48_EXPORT_FUNCTION(scx_White_Pixel);
|
|
||||||
S48_EXPORT_FUNCTION(scx_Free_Pixel);
|
|
||||||
}
|
|
||||||
BIN
c/xlib/test
BIN
c/xlib/test
Binary file not shown.
|
|
@ -1,59 +0,0 @@
|
||||||
;; the atom-datatype ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
||||||
|
|
||||||
(define-record-type atom :atom
|
|
||||||
(really-make-atom tag Xatom)
|
|
||||||
atom?
|
|
||||||
(tag atom-tag atom-set-tag!)
|
|
||||||
(Xatom atom-Xatom atom-set-Xatom!))
|
|
||||||
|
|
||||||
(define (make-atom Xatom)
|
|
||||||
(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)
|
|
||||||
(make-atom (%intern-atom (display-Xdisplay display)
|
|
||||||
(if (symbol? name)
|
|
||||||
(symbol->string name)
|
|
||||||
name))))
|
|
||||||
|
|
||||||
(import-lambda-definition %intern-atom (Xdisplay name)
|
|
||||||
"scx_Intern_Atom")
|
|
||||||
|
|
||||||
;; finalize-atom is called, when the garbage collector removes the last
|
|
||||||
;; reference to the atom from the heap. Then we can savely close the
|
|
||||||
;; atom and remove the weak-pointer from our list.
|
|
||||||
|
|
||||||
(define (finalize-atom atom)
|
|
||||||
(let ((Xatom (atom-Xatom atom)))
|
|
||||||
;(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
|
|
||||||
|
|
||||||
(define *weak-atom-list* (make-integer-table))
|
|
||||||
|
|
||||||
(define (atom-list-find Xatom)
|
|
||||||
(let ((r (table-ref *weak-atom-list* Xatom)))
|
|
||||||
(if r
|
|
||||||
(weak-pointer-ref r)
|
|
||||||
r)))
|
|
||||||
|
|
||||||
(define (atom-list-set! Xatom atom)
|
|
||||||
(let ((p (make-weak-pointer atom)))
|
|
||||||
(table-set! *weak-atom-list* Xatom p)))
|
|
||||||
|
|
||||||
(define (atom-list-delete! Xatom)
|
|
||||||
(table-set! *weak-atom-list* Xatom #f))
|
|
||||||
|
|
||||||
;; Special atom value
|
|
||||||
|
|
||||||
(define special-atom:none (make-atom 0))
|
|
||||||
|
|
@ -1,85 +0,0 @@
|
||||||
;; the color-datatype ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
||||||
|
|
||||||
(define-record-type color :color
|
|
||||||
(really-make-color tag Xcolor)
|
|
||||||
color?
|
|
||||||
(tag color-tag color-set-tag!)
|
|
||||||
(Xcolor color-Xcolor color-set-Xcolor!))
|
|
||||||
|
|
||||||
(define-record-discloser :color
|
|
||||||
(lambda (c)
|
|
||||||
(let ((rgb (extract-rgb-values c)))
|
|
||||||
`(Color ,(/ (car rgb) 65535.) ,(/ (cadr rgb) 65535.)
|
|
||||||
,(/ (caddr rgb) 65535.)))))
|
|
||||||
|
|
||||||
(define (internal-make-color Xcolor)
|
|
||||||
(let ((maybe-color (color-list-find Xcolor)))
|
|
||||||
(if maybe-color
|
|
||||||
maybe-color
|
|
||||||
(let ((color (really-make-color #f Xcolor)))
|
|
||||||
(add-finalizer! color color-list-delete!)
|
|
||||||
(color-list-set! Xcolor color)
|
|
||||||
color))))
|
|
||||||
|
|
||||||
;; r, g, b should be integers from 0 to 65535
|
|
||||||
(define (create-color r g b)
|
|
||||||
(let ((maybe-color (color-list-find* r g b)))
|
|
||||||
(if maybe-color
|
|
||||||
maybe-color
|
|
||||||
(internal-make-color (%create-color r g b)))))
|
|
||||||
|
|
||||||
(import-lambda-definition %create-color (r g b)
|
|
||||||
"scx_Create_Color")
|
|
||||||
|
|
||||||
;; returns a list of r,g,b as integers from 0 - 2^16
|
|
||||||
(define (extract-rgb-values color)
|
|
||||||
(%extract-rgb-values (color-Xcolor color)))
|
|
||||||
|
|
||||||
(import-lambda-definition %extract-rgb-values (XColor)
|
|
||||||
"scx_Extract_RGB_Values")
|
|
||||||
|
|
||||||
;; All color records need to be saved in a weak-list, to have only one record
|
|
||||||
;; for the same r,g,b value in the heap.
|
|
||||||
|
|
||||||
;; A color is generate with S48_MAKE_VALUE, thus it is a byte-vector that cannot
|
|
||||||
;; be kept in an integer-table like the other datatypes. So let's create a
|
|
||||||
;; byte-vector table.
|
|
||||||
|
|
||||||
(define make-byte-vector-table
|
|
||||||
(make-table-maker eq?
|
|
||||||
(lambda (bv)
|
|
||||||
(let loop ((i (byte-vector-length bv))
|
|
||||||
(bytes '()))
|
|
||||||
(if (= i 0)
|
|
||||||
(apply + bytes)
|
|
||||||
(loop (- i 1)
|
|
||||||
(cons (byte-vector-ref bv (- i 1))
|
|
||||||
bytes)))))))
|
|
||||||
|
|
||||||
(define *weak-color-list* (make-byte-vector-table))
|
|
||||||
|
|
||||||
(define (color-list-find Xcolor)
|
|
||||||
(let ((r (table-ref *weak-color-list* Xcolor)))
|
|
||||||
(if r
|
|
||||||
(weak-pointer-ref r)
|
|
||||||
r)))
|
|
||||||
|
|
||||||
(define (color-list-find* r g b) ;; r,g,b as integers
|
|
||||||
(call-with-current-continuation
|
|
||||||
(lambda (return)
|
|
||||||
(table-walk (lambda (key value)
|
|
||||||
(let ((color (weak-pointer-ref value)))
|
|
||||||
;; color can be #f for some strange reasons
|
|
||||||
(if (and color (equal? (list r g b)
|
|
||||||
(extract-rgb-values color)))
|
|
||||||
(return color))))
|
|
||||||
*weak-color-list*)
|
|
||||||
#f)))
|
|
||||||
|
|
||||||
(define (color-list-set! Xcolor color)
|
|
||||||
(let ((p (make-weak-pointer color)))
|
|
||||||
(table-set! *weak-color-list* Xcolor p)))
|
|
||||||
|
|
||||||
(define (color-list-delete! color)
|
|
||||||
(table-set! *weak-color-list*
|
|
||||||
(color-Xcolor color) #f))
|
|
||||||
|
|
@ -1,66 +0,0 @@
|
||||||
;; Author: David Frese
|
|
||||||
|
|
||||||
;; make-color creates a color with the given r,g,b values, which should be
|
|
||||||
;; values between 0.0 to 1.0 inclusive.
|
|
||||||
|
|
||||||
(define (my-floor v)
|
|
||||||
(if (exact? v)
|
|
||||||
(floor v)
|
|
||||||
(floor (inexact->exact v))))
|
|
||||||
|
|
||||||
(define (make-color r g b)
|
|
||||||
(create-color (my-floor (* r 65535))
|
|
||||||
(my-floor (* g 65535))
|
|
||||||
(my-floor (* b 65535))))
|
|
||||||
|
|
||||||
;; color-rgb-values returns a list of the rgb-values (see make-color).
|
|
||||||
|
|
||||||
(define (color-rgb-values color)
|
|
||||||
(map (lambda (x)
|
|
||||||
(/ x 65535)) ;; exact<->inexact?
|
|
||||||
(extract-rgb-values color)))
|
|
||||||
|
|
||||||
;; query-color returns the color of the given pixel in the given colormap.
|
|
||||||
;; See XQueryColor.
|
|
||||||
|
|
||||||
(define (query-color colormap pixel)
|
|
||||||
(apply create-color
|
|
||||||
(%query-color (colormap-Xcolormap colormap)
|
|
||||||
(pixel-Xpixel pixel)
|
|
||||||
(display-Xdisplay (colormap-display colormap)))))
|
|
||||||
|
|
||||||
(import-lambda-definition %query-color (Xcolormap Xpixel Xdisplay)
|
|
||||||
"scx_Query_Color")
|
|
||||||
|
|
||||||
;; query-colors does the same as query-color but on vectors of pixels and
|
|
||||||
;; colors. See XQueryColors.
|
|
||||||
|
|
||||||
(define (query-colors colormap pixels)
|
|
||||||
(let ((res (%query-colors (colormap-Xcolormap colormap)
|
|
||||||
(vector-map! pixel-Xpixel (list->vector pixels))
|
|
||||||
(display-Xdisplay (colormap-display colormap)))))
|
|
||||||
(vector->list (vector-map! (lambda (r-g-b)
|
|
||||||
(apply create-color r-g-b))
|
|
||||||
res))))
|
|
||||||
|
|
||||||
(import-lambda-definition %query-colors (Xcolormap Xpixels Xdisplay)
|
|
||||||
"scx_Query_Colors")
|
|
||||||
|
|
||||||
;; lookup-color takes the name of a color (a string or symbol) looks it up in
|
|
||||||
;; the colormap and returns a pair of colors: the exact color and the closest
|
|
||||||
;; color provided by the screen associated to the colormap. If the color-name
|
|
||||||
;; can't be found an error is raised. See XLookupColor.
|
|
||||||
|
|
||||||
(define (lookup-color colormap color-name)
|
|
||||||
(let ((r (%lookup-color (colormap-Xcolormap colormap)
|
|
||||||
(display-Xdisplay (colormap-display colormap))
|
|
||||||
(if (symbol? color-name)
|
|
||||||
(symbol->string color-name)
|
|
||||||
color-name))))
|
|
||||||
(if r
|
|
||||||
(cons (apply create-color (car r))
|
|
||||||
(apply create-color (cdr r)))
|
|
||||||
(error "no such color:" color-name))))
|
|
||||||
|
|
||||||
(import-lambda-definition %lookup-color (Xcolormap Xdisplay name)
|
|
||||||
"scx_Lookup_Color")
|
|
||||||
|
|
@ -1,51 +0,0 @@
|
||||||
;; the colormap-datatype ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
||||||
|
|
||||||
(define-record-type colormap :colormap
|
|
||||||
(really-make-colormap tag Xcolormap display)
|
|
||||||
colormap?
|
|
||||||
(tag colormap-tag colormap-set-tag!)
|
|
||||||
(Xcolormap colormap-Xcolormap colormap-set-Xcolormap!)
|
|
||||||
(display colormap-display colormap-set-display!))
|
|
||||||
|
|
||||||
(define (make-colormap Xcolormap display finalize?)
|
|
||||||
(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)))
|
|
||||||
(if (integer? Xcolormap)
|
|
||||||
(begin
|
|
||||||
(colormap-list-delete! colormap)
|
|
||||||
(%free-colormap Xcolormap
|
|
||||||
(display-Xdisplay (colormap-display colormap)))
|
|
||||||
(colormap-set-Xcolormap! colormap 'already-freed)))))
|
|
||||||
|
|
||||||
(import-lambda-definition %free-colormap (Xcolormap Xdisplay)
|
|
||||||
"scx_Free_Colormap")
|
|
||||||
|
|
||||||
;; All colormap records need to be saved in a weak-list, to have only one record
|
|
||||||
;; for the same XLib colormap
|
|
||||||
|
|
||||||
(define *weak-colormap-list* (make-integer-table))
|
|
||||||
|
|
||||||
(define (colormap-list-find Xcolormap)
|
|
||||||
(let ((r (table-ref *weak-colormap-list* Xcolormap)))
|
|
||||||
(if r
|
|
||||||
(weak-pointer-ref r)
|
|
||||||
r)))
|
|
||||||
|
|
||||||
(define (colormap-list-set! Xcolormap colormap)
|
|
||||||
(let ((p (make-weak-pointer colormap)))
|
|
||||||
(table-set! *weak-colormap-list* Xcolormap p)))
|
|
||||||
|
|
||||||
(define (colormap-list-delete! colormap)
|
|
||||||
(table-set! *weak-colormap-list*
|
|
||||||
(colormap-Xcolormap colormap) #f))
|
|
||||||
|
|
||||||
|
|
@ -1,50 +0,0 @@
|
||||||
(define-record-type cursor :cursor
|
|
||||||
(really-make-cursor tag Xcursor display)
|
|
||||||
cursor?
|
|
||||||
(tag cursor-tag cursor-set-tag!)
|
|
||||||
(Xcursor cursor-Xcursor cursor-set-Xcursor!)
|
|
||||||
(display cursor-display cursor-set-display!))
|
|
||||||
|
|
||||||
(define (make-cursor Xcursor display finalize?)
|
|
||||||
(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))))
|
|
||||||
|
|
||||||
;; ...
|
|
||||||
|
|
||||||
(define (free-cursor cursor)
|
|
||||||
(let ((Xdisplay (display-Xdisplay (cursor-display cursor)))
|
|
||||||
(Xcursor (cursor-Xcursor cursor)))
|
|
||||||
(if (integer? Xcursor)
|
|
||||||
(begin
|
|
||||||
(cursor-list-delete! cursor)
|
|
||||||
(%free-cursor Xdisplay Xcursor)
|
|
||||||
(cursor-set-Xcursor! cursor 'already-destroyed)))))
|
|
||||||
|
|
||||||
(import-lambda-definition %free-cursor (Xdisplay Xcursor)
|
|
||||||
"scx_Free_Cursor")
|
|
||||||
|
|
||||||
;; All cursor records need to be saved in a weak-list, to have only one record
|
|
||||||
;; for the same Xlib cursor-structure in the heap.
|
|
||||||
|
|
||||||
(define *weak-cursor-list* (make-integer-table))
|
|
||||||
|
|
||||||
(define (cursor-list-find Xcursor)
|
|
||||||
(let ((r (table-ref *weak-cursor-list* Xcursor)))
|
|
||||||
(if r
|
|
||||||
(weak-pointer-ref r)
|
|
||||||
r)))
|
|
||||||
|
|
||||||
(define (cursor-list-set! Xcursor cursor)
|
|
||||||
(let ((p (make-weak-pointer cursor)))
|
|
||||||
(table-set! *weak-cursor-list* Xcursor p)))
|
|
||||||
|
|
||||||
(define (cursor-list-delete! cursor)
|
|
||||||
(table-set! *weak-cursor-list*
|
|
||||||
(cursor-Xcursor cursor) #f))
|
|
||||||
|
|
@ -1,95 +0,0 @@
|
||||||
;; the display-datatype ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
||||||
|
|
||||||
(define-record-type display :display
|
|
||||||
(really-make-display after-function Xdisplay)
|
|
||||||
display?
|
|
||||||
(after-function display-after-function real-display-set-after-function!)
|
|
||||||
(Xdisplay display-Xdisplay display-set-Xdisplay!))
|
|
||||||
|
|
||||||
;; the real AfterFunction registered at the xlib is either none or the
|
|
||||||
;; c-function X_After_Function, which then calls
|
|
||||||
;; internal-after-function.
|
|
||||||
|
|
||||||
(define (display-set-after-function! display proc)
|
|
||||||
(let ((old (display-after-function display)))
|
|
||||||
(real-display-set-after-function! display proc)
|
|
||||||
(%set-after-function (display-Xdisplay display) proc)
|
|
||||||
old))
|
|
||||||
|
|
||||||
(import-lambda-definition %set-after-function (Xdisplay active?)
|
|
||||||
"scx_Set_After_Function")
|
|
||||||
|
|
||||||
(define (internal-after-function Xdisplay)
|
|
||||||
(let ((display (make-display Xdisplay #f)))
|
|
||||||
(if (display-after-function display)
|
|
||||||
((display-after-function display) display))))
|
|
||||||
|
|
||||||
(define-exported-binding "internal-after-function" internal-after-function)
|
|
||||||
|
|
||||||
;; the constructor
|
|
||||||
|
|
||||||
(define (make-display Xdisplay finalize?)
|
|
||||||
(let ((maybe-display (display-list-find Xdisplay)))
|
|
||||||
(if maybe-display
|
|
||||||
maybe-display
|
|
||||||
(let ((display (really-make-display #f Xdisplay)))
|
|
||||||
(if finalize?
|
|
||||||
(add-finalizer! display close-display)
|
|
||||||
(add-finalizer! display display-list-delete!))
|
|
||||||
(display-list-set! Xdisplay display)
|
|
||||||
display))))
|
|
||||||
|
|
||||||
;; close-display closes the corresponding Xlib-display struct, by calling a
|
|
||||||
;; c-function and marks the scheme-record to be invalid (with the
|
|
||||||
;; 'already-closed symbol). Calling close-display more than once has no
|
|
||||||
;; effects.
|
|
||||||
|
|
||||||
(define (close-display display)
|
|
||||||
(let ((Xdisplay (display-Xdisplay display)))
|
|
||||||
(if (integer? Xdisplay)
|
|
||||||
(begin
|
|
||||||
(display-list-delete! display)
|
|
||||||
(%close-display Xdisplay)
|
|
||||||
(display-set-Xdisplay! display 'already-closed)))))
|
|
||||||
|
|
||||||
(import-lambda-definition %close-display (Xdisplay)
|
|
||||||
"scx_Close_Display")
|
|
||||||
|
|
||||||
;; All display records need to be saved in a weak-list, to have only one record
|
|
||||||
;; for the same Xlib display-structure in the heap.
|
|
||||||
|
|
||||||
(define *weak-display-list* (make-integer-table))
|
|
||||||
|
|
||||||
(define (display-list-find Xdisplay)
|
|
||||||
(let ((r (table-ref *weak-display-list* Xdisplay)))
|
|
||||||
(if r
|
|
||||||
(weak-pointer-ref r)
|
|
||||||
r)))
|
|
||||||
|
|
||||||
(define (display-list-set! Xdisplay display)
|
|
||||||
(let ((p (make-weak-pointer display)))
|
|
||||||
(table-set! *weak-display-list* Xdisplay p)))
|
|
||||||
|
|
||||||
(define (display-list-delete! display)
|
|
||||||
(table-set! *weak-display-list*
|
|
||||||
(display-Xdisplay display) #f))
|
|
||||||
|
|
||||||
;; The message port is used to efficiently check for pending messages, which
|
|
||||||
;; are then read normally with XNextEvent.
|
|
||||||
|
|
||||||
(define message-port #f)
|
|
||||||
|
|
||||||
(define (display-message-inport display)
|
|
||||||
(if message-port
|
|
||||||
message-port
|
|
||||||
(let* ((fd (%display-message-fd (display-Xdisplay display)))
|
|
||||||
(p (fdes->inport fd)))
|
|
||||||
(set! message-port p)
|
|
||||||
p)))
|
|
||||||
|
|
||||||
(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)
|
|
||||||
|
|
@ -1,37 +0,0 @@
|
||||||
;; A "drawable" is a window or a pixmap. But sometimes we can't know
|
|
||||||
;; what it is. So in that case we just remember the display and the
|
|
||||||
;; Xlib ID.
|
|
||||||
|
|
||||||
(define-record-type drawable :drawable
|
|
||||||
(really-make-drawable Xobject display)
|
|
||||||
really-drawable?
|
|
||||||
(Xobject really-drawable-Xobject)
|
|
||||||
(display really-drawable-display))
|
|
||||||
|
|
||||||
(define (drawable? object)
|
|
||||||
(or (window? object)
|
|
||||||
(pixmap? object)
|
|
||||||
(really-drawable? object)))
|
|
||||||
|
|
||||||
(define (make-drawable Xobject display)
|
|
||||||
;; let's see if we can find out what this object is? window/pixmap
|
|
||||||
(let ((is-window? (window-list-find Xobject))
|
|
||||||
(is-pixmap? (pixmap-list-find Xobject)))
|
|
||||||
(cond
|
|
||||||
(is-window? (make-window Xobject display #f))
|
|
||||||
(is-pixmap? (make-pixmap Xobject display #f))
|
|
||||||
(else (really-make-drawable Xobject display)))))
|
|
||||||
|
|
||||||
(define (drawable-abstraction drawable-fun pixmap-fun window-fun)
|
|
||||||
(lambda (drawable)
|
|
||||||
(cond
|
|
||||||
((really-drawable? drawable) (drawable-fun drawable))
|
|
||||||
((pixmap? drawable) (pixmap-fun drawable))
|
|
||||||
((window? drawable) (window-fun drawable))
|
|
||||||
(else (error "expected a drawable object" drawable)))))
|
|
||||||
|
|
||||||
(define drawable-display
|
|
||||||
(drawable-abstraction really-drawable-display pixmap-display window-display))
|
|
||||||
|
|
||||||
(define drawable-Xobject
|
|
||||||
(drawable-abstraction really-drawable-Xobject pixmap-Xpixmap window-Xwindow))
|
|
||||||
|
|
@ -1,27 +0,0 @@
|
||||||
;; defined in window.c
|
|
||||||
(import-lambda-definition %get-geometry (Xdisplay Xdrawable)
|
|
||||||
"scx_Get_Geometry")
|
|
||||||
|
|
||||||
(define (get-geometry drawable)
|
|
||||||
(let* ((display (drawable-display drawable))
|
|
||||||
(v (%get-geometry (display-Xdisplay display)
|
|
||||||
(drawable-Xobject drawable))))
|
|
||||||
;; wrap the root-window
|
|
||||||
(vector-set! v 0 (make-window (vector-ref v 0) display #f))
|
|
||||||
v))
|
|
||||||
|
|
||||||
(define (make-geometry-getter num)
|
|
||||||
(lambda (drawable)
|
|
||||||
(vector-ref (get-geometry drawable) num)))
|
|
||||||
|
|
||||||
;; the drawable-* functions return common information of a window or a
|
|
||||||
;; pixmap. drawable-root returns a window, all other functions return
|
|
||||||
;; an integer. See XGetGeometry.
|
|
||||||
|
|
||||||
(define drawable-root (make-geometry-getter 0))
|
|
||||||
(define drawable-x (make-geometry-getter 1))
|
|
||||||
(define drawable-y (make-geometry-getter 2))
|
|
||||||
(define drawable-width (make-geometry-getter 3))
|
|
||||||
(define drawable-height (make-geometry-getter 4))
|
|
||||||
(define drawable-border-width (make-geometry-getter 5))
|
|
||||||
(define drawable-depth (make-geometry-getter 6))
|
|
||||||
|
|
@ -1,103 +0,0 @@
|
||||||
(define-record-type font :font
|
|
||||||
(really-make-font name Xfont Xfontstruct display)
|
|
||||||
font?
|
|
||||||
(name font-name font-set-name!)
|
|
||||||
(Xfont font-Xfont font-set-Xfont!)
|
|
||||||
(Xfontstruct font-Xfontstruct font-set-Xfontstruct!)
|
|
||||||
(display font-display font-set-display!))
|
|
||||||
|
|
||||||
;; 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
|
|
||||||
;; Xlib documentation says, that the resulting Font does not work
|
|
||||||
;; properly in all functions.
|
|
||||||
|
|
||||||
(define (make-font name Xfont Xfontstruct display finalize?)
|
|
||||||
(if (not (or Xfont Xfontstruct))
|
|
||||||
(error "Not enough information the make the font. Either Xfont or Xfontstruct has to be specified." name Xfont Xfontstruct display finalize?))
|
|
||||||
(let ((Xfontstruct (if (not Xfontstruct)
|
|
||||||
(%font->fontstruct (display-Xdisplay display)
|
|
||||||
Xfont)
|
|
||||||
Xfontstruct)))
|
|
||||||
(let ((maybe-font (font-list-find Xfontstruct)))
|
|
||||||
(if maybe-font
|
|
||||||
maybe-font
|
|
||||||
(let* ((Xfont (if Xfont Xfont
|
|
||||||
(%Get_Xfont Xfontstruct)))
|
|
||||||
(font (really-make-font name Xfont Xfontstruct display)))
|
|
||||||
(if finalize?
|
|
||||||
(add-finalizer! font unload-font)
|
|
||||||
(add-finalizer! font font-list-delete!))
|
|
||||||
(font-list-set! Xfontstruct font)
|
|
||||||
font)))))
|
|
||||||
|
|
||||||
(import-lambda-definition %Get_Xfont (Xfontstruct)
|
|
||||||
"scx_Get_Xfont")
|
|
||||||
|
|
||||||
(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)
|
|
||||||
(let ((Xfontstruct (%load-font (display-Xdisplay display)
|
|
||||||
(if (symbol? font-name)
|
|
||||||
(symbol->string font-name)
|
|
||||||
font-name))))
|
|
||||||
(if (= Xfontstruct 0)
|
|
||||||
#f
|
|
||||||
(make-font font-name #f Xfontstruct display #t))))
|
|
||||||
|
|
||||||
(import-lambda-definition %load-font (Xdisplay font_name)
|
|
||||||
"scx_Load_Font")
|
|
||||||
|
|
||||||
;; for compatibility with Elk:
|
|
||||||
|
|
||||||
(define open-font load-font)
|
|
||||||
|
|
||||||
;; unload-font unloads a font. This is also automatically called on
|
|
||||||
;; garbage collection. See XUnloadFont.
|
|
||||||
|
|
||||||
(define (unload-font font)
|
|
||||||
(let ((Xfontstruct (font-Xfontstruct font))
|
|
||||||
(Xdisplay (display-Xdisplay (font-display font))))
|
|
||||||
(if (integer? Xfontstruct)
|
|
||||||
(begin
|
|
||||||
(font-list-delete! font)
|
|
||||||
(%free-font Xdisplay Xfontstruct)))
|
|
||||||
(font-set-Xfontstruct! font 'already-freed)
|
|
||||||
(font-set-Xfont! font 'already-freed)))
|
|
||||||
|
|
||||||
;; for compatibility with Elk:
|
|
||||||
(define close-font unload-font)
|
|
||||||
|
|
||||||
;; %free-font frees the Xfontstruct and also deletes the association between
|
|
||||||
;; the Xfont (the resource id) and the specified font. See XFreeFont.
|
|
||||||
;; Elk uses only XUnloadFont, but then the XFontStruct is not freed ??
|
|
||||||
|
|
||||||
(import-lambda-definition %free-font (Xdisplay Xfontstruct)
|
|
||||||
"scx_Free_Font")
|
|
||||||
|
|
||||||
;; All font records need to be saved in a weak-list, to have only one record
|
|
||||||
;; for the same font in the heap.
|
|
||||||
|
|
||||||
(define *weak-font-list* (make-integer-table))
|
|
||||||
|
|
||||||
(define (font-list-find Xfontstruct)
|
|
||||||
(let ((r (table-ref *weak-font-list* Xfontstruct)))
|
|
||||||
(if r
|
|
||||||
(weak-pointer-ref r)
|
|
||||||
r)))
|
|
||||||
|
|
||||||
(define (font-list-set! Xfontstruct font)
|
|
||||||
(let ((p (make-weak-pointer font)))
|
|
||||||
(table-set! *weak-font-list* Xfontstruct p)))
|
|
||||||
|
|
||||||
(define (font-list-delete! font)
|
|
||||||
(table-set! *weak-font-list*
|
|
||||||
(font-Xfontstruct font) #f))
|
|
||||||
|
|
@ -1,56 +0,0 @@
|
||||||
(define-record-type gcontext :gcontext
|
|
||||||
(really-make-gcontext tag Xgcontext display)
|
|
||||||
gcontext?
|
|
||||||
(tag gcontext-tag gcontext-set-tag!)
|
|
||||||
(Xgcontext gcontext-Xgcontext gcontext-set-Xgcontext!)
|
|
||||||
(display gcontext-display gcontext-set-display!))
|
|
||||||
|
|
||||||
(define (make-gcontext Xgcontext display finalize?)
|
|
||||||
(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.
|
|
||||||
|
|
||||||
(define (free-gcontext gcontext)
|
|
||||||
(let ((Xgcontext (gcontext-Xgcontext gcontext)))
|
|
||||||
(if (integer? Xgcontext)
|
|
||||||
(begin
|
|
||||||
(gcontext-list-delete! gcontext)
|
|
||||||
(%free-gcontext Xgcontext
|
|
||||||
(display-Xdisplay (gcontext-display gcontext)))
|
|
||||||
(gcontext-set-Xgcontext! gcontext 'already-freed)))))
|
|
||||||
|
|
||||||
(import-lambda-definition %free-gcontext (Xgcontext Xdisplay)
|
|
||||||
"scx_Free_Gc")
|
|
||||||
|
|
||||||
;; All gcontext records need to be saved in a weak-list, to have only one record
|
|
||||||
;; for the same XLib gcontext
|
|
||||||
|
|
||||||
(define *weak-gcontext-list* (make-integer-table))
|
|
||||||
|
|
||||||
(define (gcontext-list-find Xgcontext)
|
|
||||||
(let ((r (table-ref *weak-gcontext-list* Xgcontext)))
|
|
||||||
(if r
|
|
||||||
(weak-pointer-ref r)
|
|
||||||
r)))
|
|
||||||
|
|
||||||
(define (gcontext-list-set! Xgcontext gcontext)
|
|
||||||
(let ((p (make-weak-pointer gcontext)))
|
|
||||||
(table-set! *weak-gcontext-list* Xgcontext p)))
|
|
||||||
|
|
||||||
(define (gcontext-list-delete! gcontext)
|
|
||||||
(table-set! *weak-gcontext-list*
|
|
||||||
(gcontext-Xgcontext gcontext) #f))
|
|
||||||
|
|
@ -1,11 +0,0 @@
|
||||||
;;
|
|
||||||
|
|
||||||
(define (vector-map! f v)
|
|
||||||
(let ((n (vector-length v)))
|
|
||||||
(let loop ((i 0))
|
|
||||||
(if (< i n)
|
|
||||||
(begin
|
|
||||||
(vector-set! v i (f (vector-ref v i)))
|
|
||||||
(loop (+ i 1)))
|
|
||||||
v))))
|
|
||||||
|
|
||||||
|
|
@ -1,52 +0,0 @@
|
||||||
(define-record-type pixel :pixel
|
|
||||||
(really-make-pixel tag Xpixel colormap)
|
|
||||||
pixel?
|
|
||||||
(tag pixel-tag pixel-set-tag!)
|
|
||||||
(Xpixel pixel-Xpixel pixel-set-Xpixel!)
|
|
||||||
(colormap pixel-colormap pixel-set-colormap!))
|
|
||||||
|
|
||||||
;; Attention: colormap can be #f if finalize? is #f
|
|
||||||
(define (make-pixel Xpixel colormap finalize?)
|
|
||||||
(let ((maybe-pixel (pixel-list-find Xpixel)))
|
|
||||||
(if maybe-pixel
|
|
||||||
(begin
|
|
||||||
;; now free the Xpixel if it has been allocated
|
|
||||||
(if finalize?
|
|
||||||
(%free-pixel Xpixel
|
|
||||||
(display-Xdisplay (colormap-display colormap))
|
|
||||||
(colormap-Xcolormap colormap)))
|
|
||||||
maybe-pixel)
|
|
||||||
(let ((pixel (really-make-pixel #f Xpixel colormap)))
|
|
||||||
(if finalize?
|
|
||||||
(add-finalizer! pixel free-pixel)
|
|
||||||
(add-finalizer! pixel pixel-list-delete!))
|
|
||||||
(pixel-list-set! Xpixel pixel)
|
|
||||||
pixel))))
|
|
||||||
|
|
||||||
(define (free-pixel pixel)
|
|
||||||
(%free-pixel (pixel-Xpixel pixel)
|
|
||||||
(display-Xdisplay (colormap-display (pixel-colormap pixel)))
|
|
||||||
(colormap-Xcolormap (pixel-colormap pixel)))
|
|
||||||
(pixel-list-delete! pixel))
|
|
||||||
|
|
||||||
(import-lambda-definition %free-pixel (Xpixel Xdisplay Xcolormap)
|
|
||||||
"scx_Free_Pixel")
|
|
||||||
|
|
||||||
;; All pixel records need to be saved in a weak-list, to have only one record
|
|
||||||
;; for the same XLib pixel
|
|
||||||
|
|
||||||
(define *weak-pixel-list* (make-integer-table))
|
|
||||||
|
|
||||||
(define (pixel-list-find Xpixel)
|
|
||||||
(let ((r (table-ref *weak-pixel-list* Xpixel)))
|
|
||||||
(if r
|
|
||||||
(weak-pointer-ref r)
|
|
||||||
r)))
|
|
||||||
|
|
||||||
(define (pixel-list-set! Xpixel pixel)
|
|
||||||
(let ((p (make-weak-pointer pixel)))
|
|
||||||
(table-set! *weak-pixel-list* Xpixel p)))
|
|
||||||
|
|
||||||
(define (pixel-list-delete! pixel)
|
|
||||||
(table-set! *weak-pixel-list*
|
|
||||||
(pixel-Xpixel pixel) #f))
|
|
||||||
|
|
@ -1,15 +0,0 @@
|
||||||
(define pixel-value pixel-Xpixel)
|
|
||||||
|
|
||||||
(define (black-pixel display)
|
|
||||||
(make-pixel (%black-pixel (display-Xdisplay display))
|
|
||||||
#f #f))
|
|
||||||
|
|
||||||
(import-lambda-definition %black-pixel (Xdisplay)
|
|
||||||
"scx_Black_Pixel")
|
|
||||||
|
|
||||||
(define (white-pixel display)
|
|
||||||
(make-pixel (%white-pixel (display-Xdisplay display))
|
|
||||||
#f #f))
|
|
||||||
|
|
||||||
(import-lambda-definition %white-pixel (Xdisplay)
|
|
||||||
"scx_White_Pixel")
|
|
||||||
|
|
@ -1,50 +0,0 @@
|
||||||
;; the window-datatype ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
||||||
|
|
||||||
(define-record-type pixmap :pixmap
|
|
||||||
(really-make-pixmap tag Xpixmap display)
|
|
||||||
pixmap?
|
|
||||||
(tag pixmap-tag pixmap-set-tag!)
|
|
||||||
(Xpixmap pixmap-Xpixmap pixmap-set-Xpixmap!)
|
|
||||||
(display pixmap-display pixmap-set-display!))
|
|
||||||
|
|
||||||
(define (make-pixmap Xpixmap display finalize?)
|
|
||||||
(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)))
|
|
||||||
(Xpixmap (pixmap-Xpixmap pixmap)))
|
|
||||||
(if (integer? Xpixmap)
|
|
||||||
(begin
|
|
||||||
(pixmap-list-delete! pixmap)
|
|
||||||
(%free-pixmap Xdisplay Xpixmap)
|
|
||||||
(pixmap-set-Xpixmap! pixmap 'already-destroyed)))))
|
|
||||||
|
|
||||||
(import-lambda-definition %free-pixmap (Xdisplay Xpixmap)
|
|
||||||
"scx_Free_Pixmap")
|
|
||||||
|
|
||||||
;; All pixmap records need to be saved in a weak-list, to have only one record
|
|
||||||
;; for the same Xlib pixmap-structure in the heap.
|
|
||||||
|
|
||||||
(define *weak-pixmap-list* (make-integer-table))
|
|
||||||
|
|
||||||
(define (pixmap-list-find Xpixmap)
|
|
||||||
(let ((r (table-ref *weak-pixmap-list* Xpixmap)))
|
|
||||||
(if r
|
|
||||||
(weak-pointer-ref r)
|
|
||||||
r)))
|
|
||||||
|
|
||||||
(define (pixmap-list-set! Xpixmap pixmap)
|
|
||||||
(let ((p (make-weak-pointer pixmap)))
|
|
||||||
(table-set! *weak-pixmap-list* Xpixmap p)))
|
|
||||||
|
|
||||||
(define (pixmap-list-delete! pixmap)
|
|
||||||
(table-set! *weak-pixmap-list*
|
|
||||||
(pixmap-Xpixmap pixmap) #f))
|
|
||||||
|
|
@ -1,494 +0,0 @@
|
||||||
;; Extensions to enum-sets (some are defined in enum-sets-internal,
|
|
||||||
;; but that is not exported)
|
|
||||||
|
|
||||||
(define (integer->enum-list all-elements element-index int)
|
|
||||||
(let loop ((res '())
|
|
||||||
(test (vector->list all-elements)))
|
|
||||||
(if (null? test)
|
|
||||||
(reverse res)
|
|
||||||
(if (> (bitwise-and
|
|
||||||
(arithmetic-shift int (- (element-index (car test))))
|
|
||||||
1)
|
|
||||||
0)
|
|
||||||
(loop (cons (car test) res)
|
|
||||||
(cdr test))
|
|
||||||
(loop res
|
|
||||||
(cdr test))))))
|
|
||||||
|
|
||||||
(define (make-integer->enum-set all-elements element-index constructor)
|
|
||||||
(lambda (int)
|
|
||||||
(constructor (integer->enum-list all-elements element-index
|
|
||||||
int))))
|
|
||||||
|
|
||||||
(define (enum-list->integer element-index elements)
|
|
||||||
(fold-right (lambda (e res)
|
|
||||||
(bitwise-ior (arithmetic-shift 1 (element-index e))
|
|
||||||
res))
|
|
||||||
0
|
|
||||||
elements))
|
|
||||||
|
|
||||||
(define (make-enum-set->integer element-index)
|
|
||||||
(lambda (set)
|
|
||||||
(enum-list->integer element-index (enum-set->list set))))
|
|
||||||
|
|
||||||
;; alists mapping enum-types to some values
|
|
||||||
|
|
||||||
(define (make-enum-alist->integer+vector all-elements element-index-ref
|
|
||||||
converter)
|
|
||||||
(lambda (enum-alist)
|
|
||||||
(cons (enum-list->integer element-index-ref
|
|
||||||
(map car enum-alist))
|
|
||||||
(let ((v (make-vector (vector-length all-elements)
|
|
||||||
(unspecific))))
|
|
||||||
(for-each (lambda (a)
|
|
||||||
(vector-set! v
|
|
||||||
(element-index-ref (car a))
|
|
||||||
((converter (car a)) (cdr a))))
|
|
||||||
enum-alist)
|
|
||||||
v))))
|
|
||||||
|
|
||||||
(define (make-integer+vector->enum-alist all-elements element-index-ref
|
|
||||||
converter)
|
|
||||||
(lambda (int-vec)
|
|
||||||
(let ((int (car int-vec))
|
|
||||||
(vec (cdr int-vec)))
|
|
||||||
(let* ((enums (integer->enum-list all-elements element-index-ref
|
|
||||||
int))
|
|
||||||
(values (map (lambda (e)
|
|
||||||
((converter e)
|
|
||||||
(vector-ref vec
|
|
||||||
(element-index-ref e))))
|
|
||||||
enums)))
|
|
||||||
(map cons enums values)))))
|
|
||||||
|
|
||||||
;; *******************************************************************
|
|
||||||
|
|
||||||
(define-enumerated-type state :state
|
|
||||||
state? states state-name state-index
|
|
||||||
(shift lock control mod1 mod2 mod3 mod4 mod5
|
|
||||||
button1 button2 button3 button4 button5
|
|
||||||
state-13 state-14
|
|
||||||
any-modifier))
|
|
||||||
|
|
||||||
(define-enum-set-type state-set :state-set
|
|
||||||
state-set? make-state-set
|
|
||||||
state state? states state-index)
|
|
||||||
|
|
||||||
(define integer->state-set
|
|
||||||
(make-integer->enum-set states state-index make-state-set))
|
|
||||||
|
|
||||||
(define state-set->integer
|
|
||||||
(make-enum-set->integer state-index))
|
|
||||||
|
|
||||||
;; *******************************************************************
|
|
||||||
|
|
||||||
(define-enumerated-type button :button
|
|
||||||
button? buttons button-name button-index
|
|
||||||
(any-button button1 button2 button3 button4 button5))
|
|
||||||
|
|
||||||
(define (integer->button int)
|
|
||||||
(vector-ref buttons int))
|
|
||||||
|
|
||||||
(define (button->integer b)
|
|
||||||
(button-index b))
|
|
||||||
|
|
||||||
;; *******************************************************************
|
|
||||||
|
|
||||||
;; this is a special NotifyMode for MotionNotify events.
|
|
||||||
;; NotifyNormal = 0, NotifyHint = 1
|
|
||||||
;; therefore we just represent it as the boolean is-hint?
|
|
||||||
|
|
||||||
(define (integer->is-hint? int)
|
|
||||||
(= int 1))
|
|
||||||
|
|
||||||
(define (is-hint?->integer is-hint?)
|
|
||||||
(if is-hint? 1 0))
|
|
||||||
|
|
||||||
;; *******************************************************************
|
|
||||||
|
|
||||||
(define-enumerated-type notify-mode :notify-mode
|
|
||||||
notify-mode? notify-modes notify-mode-name notify-mode-index
|
|
||||||
(normal grab ungrab while-grabbed))
|
|
||||||
|
|
||||||
(define (integer->notify-mode int)
|
|
||||||
(vector-ref notify-modes int))
|
|
||||||
|
|
||||||
(define (notify-mode->integer v)
|
|
||||||
(notify-mode-index v))
|
|
||||||
|
|
||||||
;; *******************************************************************
|
|
||||||
|
|
||||||
(define-enumerated-type notify-detail :notify-detail
|
|
||||||
notify-detail? notify-details notify-detail-name notify-detail-index
|
|
||||||
(ancestor virtual inferior nonlinear nonlinear-virtual pointer
|
|
||||||
pointer-root detail-none))
|
|
||||||
|
|
||||||
(define (integer->notify-detail int)
|
|
||||||
(vector-ref notify-details int))
|
|
||||||
|
|
||||||
(define (notify-detail->integer v)
|
|
||||||
(notify-detail-index v))
|
|
||||||
|
|
||||||
;; *******************************************************************
|
|
||||||
|
|
||||||
(define-enumerated-type visibility-state :visibility-state
|
|
||||||
visibility-state? visibility-states visibility-state-name
|
|
||||||
visibility-state-index
|
|
||||||
(unobscured partially-obscured fully-obscured))
|
|
||||||
|
|
||||||
(define (integer->visibility-state int)
|
|
||||||
(vector-ref visibility-states int))
|
|
||||||
|
|
||||||
(define (visibility-state->integer v)
|
|
||||||
(visibility-state-index v))
|
|
||||||
|
|
||||||
;; *******************************************************************
|
|
||||||
|
|
||||||
(define-enumerated-type place :place
|
|
||||||
place? places place-name place-index
|
|
||||||
(on-top on-bottom))
|
|
||||||
|
|
||||||
(define (integer->place int)
|
|
||||||
(vector-ref places int))
|
|
||||||
|
|
||||||
(define (place->integer v)
|
|
||||||
(place-index v))
|
|
||||||
|
|
||||||
;; *******************************************************************
|
|
||||||
|
|
||||||
(define-enumerated-type property-state :property-state
|
|
||||||
property-state? property-states property-state-name property-state-index
|
|
||||||
(new-value delete))
|
|
||||||
|
|
||||||
(define (integer->property-state int)
|
|
||||||
(vector-ref property-states int))
|
|
||||||
|
|
||||||
(define (property-state->integer v)
|
|
||||||
(property-state-index v))
|
|
||||||
|
|
||||||
;; *******************************************************************
|
|
||||||
|
|
||||||
(define-enumerated-type colormap-state :colormap-state
|
|
||||||
colormap-state? colormap-states colormap-state-name colormap-state-index
|
|
||||||
(uninstalled installed))
|
|
||||||
|
|
||||||
(define (integer->colormap-state int)
|
|
||||||
(vector-ref colormap-states int))
|
|
||||||
|
|
||||||
(define (colormap-state->integer v)
|
|
||||||
(colormap-state-index v))
|
|
||||||
|
|
||||||
;; *******************************************************************
|
|
||||||
|
|
||||||
(define-enumerated-type mapping-request :mapping-request
|
|
||||||
mapping-request? mapping-requests mapping-request-name mapping-request-index
|
|
||||||
(modifier keyboard pointer))
|
|
||||||
|
|
||||||
(define (integer->mapping-request int)
|
|
||||||
(vector-ref mapping-requests int))
|
|
||||||
|
|
||||||
(define (mapping-request->integer v)
|
|
||||||
(mapping-request-index v))
|
|
||||||
|
|
||||||
;; *******************************************************************
|
|
||||||
|
|
||||||
(define-enumerated-type bit-gravity :bit-gravity
|
|
||||||
bit-gravity? bit-gravities bit-gravity-name bit-gravity-index
|
|
||||||
(forget north-west north north-east west center east south-west
|
|
||||||
south south-east static))
|
|
||||||
|
|
||||||
(define (integer->bit-gravity int)
|
|
||||||
(vector-ref bit-gravities int))
|
|
||||||
|
|
||||||
(define (bit-gravity->integer v)
|
|
||||||
(bit-gravity-index v))
|
|
||||||
|
|
||||||
;; *******************************************************************
|
|
||||||
|
|
||||||
(define-enumerated-type gravity :gravity
|
|
||||||
gravity? gravities gravity-name gravity-index
|
|
||||||
(unmap north-west north north-east west center east south-west
|
|
||||||
south south-east static))
|
|
||||||
|
|
||||||
(define (integer->gravity int)
|
|
||||||
(vector-ref gravities int))
|
|
||||||
|
|
||||||
(define (gravity->integer v)
|
|
||||||
(gravity-index v))
|
|
||||||
|
|
||||||
;; *******************************************************************
|
|
||||||
|
|
||||||
(define-enumerated-type backing-store :backing-store
|
|
||||||
backing-store? backing-stores backing-store-name backing-store-index
|
|
||||||
(not-useful when-mapped always))
|
|
||||||
|
|
||||||
(define (integer->backing-store int)
|
|
||||||
(vector-ref backing-stores int))
|
|
||||||
|
|
||||||
(define (backing-store->integer v)
|
|
||||||
(backing-store-index v))
|
|
||||||
|
|
||||||
;; *******************************************************************
|
|
||||||
|
|
||||||
(define-enumerated-type event-mask-item :event-mask-item
|
|
||||||
event-mask-item? event-mask-items event-mask-item-name event-mask-item-index
|
|
||||||
(key-press key-release button-press button-release enter-window leave-window
|
|
||||||
pointer-motion pointer-motion-hint button-1-motion button-2-motion
|
|
||||||
button-3-motion button-4-motion button-5-motion button-motion keymap-state
|
|
||||||
exposure visibility-change structure-notify resize-redirect
|
|
||||||
substructure-notify substructure-redirect focus-change property-change
|
|
||||||
colormap-change owner-grab-button))
|
|
||||||
|
|
||||||
(define (integer->event-mask-item int)
|
|
||||||
(vector-ref event-mask-items int))
|
|
||||||
|
|
||||||
(define (event-mask-item->integer v)
|
|
||||||
(event-mask-item-index v))
|
|
||||||
|
|
||||||
(define-enum-set-type event-mask :event-mask
|
|
||||||
event-mask? make-event-mask
|
|
||||||
event-mask-item event-mask-item? event-mask-items event-mask-item-index)
|
|
||||||
|
|
||||||
(define integer->event-mask
|
|
||||||
(make-integer->enum-set event-mask-items event-mask-item-index
|
|
||||||
make-event-mask))
|
|
||||||
|
|
||||||
(define event-mask->integer
|
|
||||||
(make-enum-set->integer event-mask-item-index))
|
|
||||||
|
|
||||||
(define event-mask-all-events
|
|
||||||
(make-event-mask (vector->list event-mask-items)))
|
|
||||||
|
|
||||||
;; *******************************************************************
|
|
||||||
|
|
||||||
;; enumerated type for window attributes that can be changed in
|
|
||||||
;; create-window and with change-window-attributes.
|
|
||||||
|
|
||||||
(define-enumerated-type set-window-attribute :set-window-attribute
|
|
||||||
set-window-attribute?
|
|
||||||
set-window-attributes
|
|
||||||
set-window-attribute-name
|
|
||||||
set-window-attribute-index
|
|
||||||
;; 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
|
|
||||||
cursor))
|
|
||||||
|
|
||||||
(define-syntax make-set-window-attribute-alist
|
|
||||||
(syntax-rules
|
|
||||||
()
|
|
||||||
((make-set-window-attribute-alist (attr arg) rest ...)
|
|
||||||
(cons (cons (set-window-attribute attr) arg)
|
|
||||||
(make-set-window-attribute-alist rest ...)))
|
|
||||||
((make-set-window-attribute-alist)
|
|
||||||
'())))
|
|
||||||
|
|
||||||
(define set-window-attribute-alist->integer+vector
|
|
||||||
(make-enum-alist->integer+vector
|
|
||||||
set-window-attributes
|
|
||||||
set-window-attribute-index
|
|
||||||
(lambda (attr)
|
|
||||||
(cond
|
|
||||||
((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))
|
|
||||||
(eq? attr (set-window-attribute backing-planes)))
|
|
||||||
pixel-Xpixel)
|
|
||||||
((eq? attr (set-window-attribute bit-gravity))
|
|
||||||
bit-gravity->integer)
|
|
||||||
((eq? attr (set-window-attribute gravity))
|
|
||||||
gravity->integer)
|
|
||||||
((eq? attr (set-window-attribute backing-store))
|
|
||||||
backing-store->integer)
|
|
||||||
((or (eq? attr (set-window-attribute override-redirect))
|
|
||||||
(eq? attr (set-window-attribute save-under)))
|
|
||||||
(lambda (v)
|
|
||||||
(if v 1 0)))
|
|
||||||
((or (eq? attr (set-window-attribute event-mask))
|
|
||||||
(eq? attr (set-window-attribute do-not-propagate-mask)))
|
|
||||||
event-mask->integer)
|
|
||||||
((eq? attr (set-window-attribute colormap))
|
|
||||||
colormap-Xcolormap)
|
|
||||||
((eq? attr (set-window-attribute cursor))
|
|
||||||
cursor-Xcursor)
|
|
||||||
(else (error "invalid set-window-attribute" attr))))))
|
|
||||||
|
|
||||||
;; *******************************************************************
|
|
||||||
|
|
||||||
(define-enumerated-type map-state :map-state
|
|
||||||
map-state? map-states map-state-name map-state-index
|
|
||||||
(is-unmapped is-unviewable is-viewable))
|
|
||||||
|
|
||||||
(define (integer->map-state int)
|
|
||||||
(vector-ref map-states int))
|
|
||||||
|
|
||||||
(define (map-state->integer v)
|
|
||||||
(map-state-index v))
|
|
||||||
|
|
||||||
;; *******************************************************************
|
|
||||||
|
|
||||||
(define-enumerated-type window-class :window-class
|
|
||||||
window-class? window-classs window-class-name window-class-index
|
|
||||||
(copy-from-parent input-output input-only))
|
|
||||||
|
|
||||||
(define (integer->window-class int)
|
|
||||||
(vector-ref window-classs int))
|
|
||||||
|
|
||||||
(define (window-class->integer v)
|
|
||||||
(window-class-index v))
|
|
||||||
|
|
||||||
;; *******************************************************************
|
|
||||||
|
|
||||||
(define-enumerated-type window-attribute :window-attribute
|
|
||||||
window-attribute?
|
|
||||||
window-attributes
|
|
||||||
window-attribute-name
|
|
||||||
window-attribute-index
|
|
||||||
;; screen is not supported yet - so it will be always #f
|
|
||||||
(x y width height border-width depth visual root class bit-gravity
|
|
||||||
gravity backing-store backing-planes backing-pixel save-under
|
|
||||||
colormap map-installed map-state all-event-masks your-event-mask
|
|
||||||
do-not-propagate-mask override-redirect screen))
|
|
||||||
|
|
||||||
(define-syntax make-window-attribute-alist
|
|
||||||
(syntax-rules
|
|
||||||
()
|
|
||||||
((make-window-attribute-alist (attr arg) rest ...)
|
|
||||||
(cons (cons (window-attribute attr) arg)
|
|
||||||
(make-window-attribute-alist rest ...)))
|
|
||||||
((make-window-attribute-alist)
|
|
||||||
'())))
|
|
||||||
|
|
||||||
(define (integer+vector->window-attribute-alist display)
|
|
||||||
(make-integer+vector->enum-alist
|
|
||||||
window-attributes window-attribute-index
|
|
||||||
(lambda (v)
|
|
||||||
(cond
|
|
||||||
((eq? v (window-attribute visual))
|
|
||||||
make-visual)
|
|
||||||
((eq? v (window-attribute root))
|
|
||||||
(lambda (Xwindow)
|
|
||||||
(make-window Xwindow display #f)))
|
|
||||||
((eq? v (window-attribute class))
|
|
||||||
integer->window-class)
|
|
||||||
((eq? v (window-attribute bit-gravity))
|
|
||||||
integer->bit-gravity)
|
|
||||||
((eq? v (window-attribute gravity))
|
|
||||||
integer->gravity)
|
|
||||||
((eq? v (window-attribute backing-store))
|
|
||||||
integer->backing-store)
|
|
||||||
((or (eq? v (window-attribute backing-planes))
|
|
||||||
(eq? v (window-attribute backing-pixel)))
|
|
||||||
(lambda (Xpixel)
|
|
||||||
(make-pixel Xpixel #f #f)))
|
|
||||||
((or (eq? v (window-attribute save-under))
|
|
||||||
(eq? v (window-attribute map-installed))
|
|
||||||
(eq? v (window-attribute override-redirect)))
|
|
||||||
(lambda (x) (not (= x 0))))
|
|
||||||
((eq? v (window-attribute colormap))
|
|
||||||
(lambda (Xcolormap)
|
|
||||||
(make-colormap Xcolormap display #f)))
|
|
||||||
((eq? v (window-attribute map-state))
|
|
||||||
integer->map-state)
|
|
||||||
((or (eq? v (window-attribute all-event-masks))
|
|
||||||
(eq? v (window-attribute your-event-mask))
|
|
||||||
(eq? v (window-attribute do-not-propagate-mask)))
|
|
||||||
integer->event-mask)
|
|
||||||
((eq? v (window-attribute screen))
|
|
||||||
(lambda (x) x))
|
|
||||||
(else (lambda (x) x))))))
|
|
||||||
|
|
||||||
;; *******************************************************************
|
|
||||||
|
|
||||||
(define-enumerated-type stack-mode :stack-mode
|
|
||||||
stack-mode? stack-modes stack-mode-name stack-mode-index
|
|
||||||
(above below top-if buttom-if opposite))
|
|
||||||
|
|
||||||
(define (integer->stack-mode int)
|
|
||||||
(vector-ref stack-modes int))
|
|
||||||
|
|
||||||
(define (stack-mode->integer v)
|
|
||||||
(stack-mode-index v))
|
|
||||||
|
|
||||||
;; an enumerated type for XWindowChange. Used in configure-window
|
|
||||||
|
|
||||||
(define-enumerated-type window-change :window-change
|
|
||||||
window-change? window-changes window-change-name window-change-index
|
|
||||||
(x y width height border-width sibling stack-mode))
|
|
||||||
|
|
||||||
(define-syntax make-window-change-alist
|
|
||||||
(syntax-rules
|
|
||||||
()
|
|
||||||
((make-window-change-alist (attr arg) rest ...)
|
|
||||||
(cons (cons (window-change attr) arg)
|
|
||||||
(make-window-change-alist rest ...)))
|
|
||||||
((make-window-change-alist)
|
|
||||||
'())))
|
|
||||||
|
|
||||||
(define window-change-alist->integer+vector
|
|
||||||
(make-enum-alist->integer+vector
|
|
||||||
window-changes window-change-index
|
|
||||||
(lambda (v)
|
|
||||||
(cond
|
|
||||||
((eq? v (window-change sibling))
|
|
||||||
window-Xwindow)
|
|
||||||
((eq? v (window-change stack-mode))
|
|
||||||
stack-mode->integer)
|
|
||||||
(else (lambda (x) x))))))
|
|
||||||
|
|
||||||
(define (integer+vector->window-change-alist display)
|
|
||||||
(make-integer+vector->enum-alist
|
|
||||||
window-changes window-change-index
|
|
||||||
(lambda (v)
|
|
||||||
(cond
|
|
||||||
((eq? v (window-change sibling))
|
|
||||||
(lambda (Xwindow)
|
|
||||||
(make-window Xwindow display #f)))
|
|
||||||
((eq? v (window-change stack-mode))
|
|
||||||
integer->stack-mode)
|
|
||||||
(else (lambda (x) x))))))
|
|
||||||
|
|
||||||
;; *******************************************************************
|
|
||||||
|
|
||||||
(define-enumerated-type byte-order :byte-order
|
|
||||||
byte-order? byte-orders byte-order-name byte-order-index
|
|
||||||
(lsb-first msb-first))
|
|
||||||
|
|
||||||
(define (integer->byte-order int)
|
|
||||||
(vector-ref byte-orders int))
|
|
||||||
|
|
||||||
(define (byte-order->integer v)
|
|
||||||
(byte-order-index v))
|
|
||||||
|
|
||||||
;; *******************************************************************
|
|
||||||
|
|
||||||
(define-enumerated-type bit-order :bit-order
|
|
||||||
bit-order? bit-orders bit-order-name bit-order-index
|
|
||||||
(lsb-first msb-first))
|
|
||||||
|
|
||||||
(define (integer->bit-order int)
|
|
||||||
(vector-ref bit-orders int))
|
|
||||||
|
|
||||||
(define (bit-order->integer v)
|
|
||||||
(bit-order-index v))
|
|
||||||
|
|
||||||
;; *******************************************************************
|
|
||||||
|
|
||||||
(define-enumerated-type fill-rule :fill-rule
|
|
||||||
fill-rule? fill-rules fill-rule-name fill-rule-index
|
|
||||||
(even-odd winding))
|
|
||||||
|
|
||||||
(define (integer->fill-rule int)
|
|
||||||
(vector-ref fill-rules int))
|
|
||||||
|
|
||||||
(define (fill-rule->integer v)
|
|
||||||
(fill-rule-index v))
|
|
||||||
|
|
||||||
|
|
@ -1,33 +0,0 @@
|
||||||
(define-record-type visual :visual
|
|
||||||
(really-make-visual tag Xvisual)
|
|
||||||
visual?
|
|
||||||
(tag visual-tag visual-set-tag!)
|
|
||||||
(Xvisual visual-Xvisual visual-set-Xvisual!))
|
|
||||||
|
|
||||||
(define (make-visual Xvisual)
|
|
||||||
(let ((maybe-visual (visual-list-find Xvisual)))
|
|
||||||
(if maybe-visual
|
|
||||||
maybe-visual
|
|
||||||
(let ((visual (really-make-visual #f Xvisual)))
|
|
||||||
(add-finalizer! visual visual-list-delete!)
|
|
||||||
(visual-list-set! Xvisual visual)
|
|
||||||
visual))))
|
|
||||||
|
|
||||||
;; All visual records need to be saved in a weak-list, to have only one
|
|
||||||
;; record for the same XLib visual
|
|
||||||
|
|
||||||
(define *weak-visual-list* (make-integer-table))
|
|
||||||
|
|
||||||
(define (visual-list-find Xvisual)
|
|
||||||
(let ((r (table-ref *weak-visual-list* Xvisual)))
|
|
||||||
(if r
|
|
||||||
(weak-pointer-ref r)
|
|
||||||
r)))
|
|
||||||
|
|
||||||
(define (visual-list-set! Xvisual visual)
|
|
||||||
(let ((p (make-weak-pointer visual)))
|
|
||||||
(table-set! *weak-visual-list* Xvisual p)))
|
|
||||||
|
|
||||||
(define (visual-list-delete! visual)
|
|
||||||
(table-set! *weak-visual-list*
|
|
||||||
(visual-Xvisual visual) #f))
|
|
||||||
|
|
@ -1,87 +0,0 @@
|
||||||
;; the window-datatype ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
||||||
|
|
||||||
(define-record-type window :window
|
|
||||||
(really-make-window tag Xwindow display destroyed?)
|
|
||||||
window?
|
|
||||||
(tag window-tag window-set-tag!)
|
|
||||||
(Xwindow real-window-Xwindow window-set-Xwindow!)
|
|
||||||
(destroyed? window-destroyed? window-set-destroyed?!)
|
|
||||||
(display window-display window-set-display!))
|
|
||||||
|
|
||||||
(define (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?)
|
|
||||||
(let ((maybe-window (window-list-find Xwindow)))
|
|
||||||
(if maybe-window
|
|
||||||
maybe-window
|
|
||||||
(let ((window (really-make-window #f Xwindow display #f)))
|
|
||||||
(if finalize?
|
|
||||||
(add-finalizer! window destroy-window)
|
|
||||||
(add-finalizer! window window-list-delete!))
|
|
||||||
(window-list-set! Xwindow window)
|
|
||||||
window))))
|
|
||||||
|
|
||||||
;; 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)))
|
|
||||||
(Xwindow (window-Xwindow window)))
|
|
||||||
(window-list-delete! window)
|
|
||||||
(if (not (window-destroyed? window))
|
|
||||||
(%destroy-window Xdisplay Xwindow))
|
|
||||||
(window-set-destroyed?! window #t)))
|
|
||||||
|
|
||||||
(import-lambda-definition %destroy-window (Xdisplay Xwindow)
|
|
||||||
"scx_Destroy_Window")
|
|
||||||
|
|
||||||
;; All window records need to be saved in a weak-list, to have only one record
|
|
||||||
;; for the same Xlib window-structure in the heap.
|
|
||||||
|
|
||||||
(define *weak-window-list* (make-integer-table))
|
|
||||||
|
|
||||||
(define (window-list-find Xwindow)
|
|
||||||
(let ((r (table-ref *weak-window-list* Xwindow)))
|
|
||||||
(if r
|
|
||||||
(weak-pointer-ref r)
|
|
||||||
r)))
|
|
||||||
|
|
||||||
(define (window-list-set! Xwindow window)
|
|
||||||
(let ((p (make-weak-pointer window)))
|
|
||||||
(table-set! *weak-window-list* Xwindow p)))
|
|
||||||
|
|
||||||
(define (window-list-delete! window)
|
|
||||||
(table-set! *weak-window-list*
|
|
||||||
(window-Xwindow window) #f))
|
|
||||||
|
|
||||||
|
|
@ -1,88 +0,0 @@
|
||||||
;;; Helper functions
|
|
||||||
|
|
||||||
(define-interface xlib-helper-interface
|
|
||||||
(export vector-map!))
|
|
||||||
|
|
||||||
;; these are internal interfaces that describe the construction and access
|
|
||||||
;; functions to all the new datatypes. They are not needed by the user
|
|
||||||
|
|
||||||
(define-interface xlib-internal-types-interface
|
|
||||||
(export
|
|
||||||
|
|
||||||
display? make-display display-Xdisplay display-after-function
|
|
||||||
display-set-after-function! close-display display-message-inport
|
|
||||||
special-time:current-time
|
|
||||||
|
|
||||||
window? make-window destroy-window window-Xwindow window-display
|
|
||||||
window-tag window-set-tag!
|
|
||||||
special-window:none special-window:pointer-window
|
|
||||||
special-window:input-focus special-window:pointer-root
|
|
||||||
|
|
||||||
drawable? make-drawable drawable-abstraction drawable-display
|
|
||||||
drawable-Xobject
|
|
||||||
|
|
||||||
color? internal-make-color extract-rgb-values create-color color-Xcolor
|
|
||||||
|
|
||||||
colormap? make-colormap free-colormap colormap-display colormap-Xcolormap
|
|
||||||
|
|
||||||
pixel? make-pixel pixel-Xpixel pixel-colormap
|
|
||||||
|
|
||||||
gcontext? make-gcontext free-gcontext gcontext? gcontext-display
|
|
||||||
gcontext-Xgcontext special-gcontext:none
|
|
||||||
|
|
||||||
pixmap? make-pixmap free-pixmap pixmap-Xpixmap pixmap-display
|
|
||||||
|
|
||||||
font? make-font font-Xfont font-Xfontstruct font-display font-name
|
|
||||||
load-font open-font unload-font close-font
|
|
||||||
special-font:none
|
|
||||||
|
|
||||||
atom? make-atom atom-Xatom intern-atom special-atom:none
|
|
||||||
|
|
||||||
cursor? make-cursor cursor-display cursor-Xcursor free-cursor
|
|
||||||
|
|
||||||
visual? make-visual visual-Xvisual
|
|
||||||
|
|
||||||
region? make-region destroy-region region-Xregion
|
|
||||||
|
|
||||||
((event-mask) :syntax) event-mask-all-events
|
|
||||||
integer->event-mask event-mask->integer
|
|
||||||
|
|
||||||
integer->state-set state-set->integer
|
|
||||||
integer->button button->integer
|
|
||||||
integer->is-hint? is-hint?->integer
|
|
||||||
integer->notify-mode notify-mode->integer
|
|
||||||
integer->notify-detail notify-detail->integer
|
|
||||||
integer->visibility-state visibility-state->integer
|
|
||||||
integer->place place->integer
|
|
||||||
integer->property-state property-state->integer
|
|
||||||
integer->colormap-state colormap-state->integer
|
|
||||||
integer->mapping-request mapping-request->integer
|
|
||||||
|
|
||||||
((state state-set button notify-mode notify-detail
|
|
||||||
visibility-state place property-state colormap-state
|
|
||||||
mapping-request bit-gravity gravity backing-store) :syntax)
|
|
||||||
|
|
||||||
gravity->integer integer->gravity
|
|
||||||
|
|
||||||
make-enum-alist->integer+vector
|
|
||||||
make-integer+vector->enum-alist
|
|
||||||
make-integer->enum-set make-enum-set->integer
|
|
||||||
|
|
||||||
set-window-attribute-alist->integer+vector
|
|
||||||
((set-window-attribute make-set-window-attribute-alist) :syntax)
|
|
||||||
|
|
||||||
((window-change make-window-change-alist stack-mode) :syntax)
|
|
||||||
window-change-alist->integer+vector integer+vector->window-change-alist
|
|
||||||
|
|
||||||
((window-attribute make-window-attribute-alist) :syntax)
|
|
||||||
integer+vector->window-attribute-alist
|
|
||||||
|
|
||||||
((window-class map-state) :syntax)
|
|
||||||
|
|
||||||
((byte-order bit-order) :syntax)
|
|
||||||
integer->byte-order integer->bit-order
|
|
||||||
|
|
||||||
((fill-rule) :syntax)
|
|
||||||
fill-rule->integer integer->fill-rule
|
|
||||||
|
|
||||||
))
|
|
||||||
|
|
@ -1,41 +0,0 @@
|
||||||
;; Things we still need from the scsh package:
|
|
||||||
(define-structure fdes
|
|
||||||
(export fdes->inport)
|
|
||||||
(open scsh))
|
|
||||||
|
|
||||||
;; the other xlib packages need this to gain direct access to the new datatypes.
|
|
||||||
;; Normal users shouldn't use this package.
|
|
||||||
|
|
||||||
(define-structure xlib-helper xlib-helper-interface
|
|
||||||
(open scheme
|
|
||||||
external-calls
|
|
||||||
list-lib)
|
|
||||||
(files helper))
|
|
||||||
|
|
||||||
(define-structure xlib-internal-types xlib-internal-types-interface
|
|
||||||
(open scheme
|
|
||||||
signals ;; for error
|
|
||||||
fdes ;; see above
|
|
||||||
list-lib
|
|
||||||
weak
|
|
||||||
general-tables
|
|
||||||
primitives
|
|
||||||
define-record-types
|
|
||||||
external-calls
|
|
||||||
byte-vectors ;; for color-type.scm
|
|
||||||
finite-types enum-sets bitwise
|
|
||||||
xlib-helper)
|
|
||||||
(files display-type
|
|
||||||
color-type
|
|
||||||
colormap-type
|
|
||||||
pixel-type
|
|
||||||
pixmap-type
|
|
||||||
window-type
|
|
||||||
drawable-type
|
|
||||||
gcontext-type
|
|
||||||
font-type
|
|
||||||
atom-type
|
|
||||||
cursor-type
|
|
||||||
visual-type
|
|
||||||
region-type
|
|
||||||
types))
|
|
||||||
Loading…
Reference in New Issue