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

- changed xid-types to simple numbers 

- added "display" to function interfaces
- moved type extraction/creation to C
- more simplifications
This commit is contained in:
frese 2003-03-11 02:47:38 +00:00
parent 1b05b00ec5
commit aaf82e55b6
45 changed files with 6043 additions and 7788 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

64
c/main.c
View File

@ -1,67 +1,11 @@
#include "scheme48.h"
/* Xlib */
extern void scx_init_window();
extern void scx_init_display();
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();
/* Xpm */
extern void scx_init_xpm();
extern void scx_init_xlib();
//extern void scx_init_xpm();
int main(int argc, char **argv) {
/* Xlib */
s48_add_external_init(scx_init_window);
s48_add_external_init(scx_init_display);
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);
/* Xpm */
s48_add_external_init(scx_init_xpm);
s48_add_external_init(scx_init_xlib);
//s48_add_external_init(scx_init_xpm);
s48_main(8000000, 64000,
SCSHIMAGE,

846
c/xlib/client.c
View File

@ -1,493 +1,471 @@
#include "xlib.h"
s48_value scx_Iconify_Window (s48_value Xdisplay, s48_value w, s48_value scr) {
if (!XIconifyWindow (SCX_EXTRACT_DISPLAY(Xdisplay),
SCX_EXTRACT_WINDOW(w),
s48_extract_integer(scr)))
return S48_FALSE;
else
return S48_UNSPECIFIC;
}
// TODO
#define scx_raise_status_error(sname, cname) return S48_FALSE
s48_value scx_Withdraw_Window (s48_value Xdisplay, s48_value w, s48_value scr) {
if (!XWithdrawWindow (SCX_EXTRACT_DISPLAY(Xdisplay),
SCX_EXTRACT_WINDOW(w),
s48_extract_integer(scr)))
return S48_FALSE;
else
return S48_UNSPECIFIC;
}
// defined in window.c
extern unsigned long Changes_To_XWindowChanges(s48_value conf,
XWindowChanges* WC);
s48_value scx_Reconfigure_Wm_Window (s48_value dpy, s48_value w, s48_value scr,
s48_value conf) {
XWindowChanges WC;
unsigned long mask = Changes_To_XWindowChanges(conf, &WC);
if (!XReconfigureWMWindow (SCX_EXTRACT_DISPLAY(dpy),
SCX_EXTRACT_WINDOW(w),
s48_extract_integer(scr),
mask, &WC))
return S48_FALSE;
else
return S48_UNSPECIFIC;
}
s48_value scx_Wm_Command (s48_value dpy, s48_value w) {
int i, ac;
char** av;
s48_value ret;
S48_DECLARE_GC_PROTECT(1);
// Disable_Interrupts;
if (!XGetCommand (SCX_EXTRACT_DISPLAY(dpy),
SCX_EXTRACT_WINDOW(w),
&av, &ac))
ac = 0;
// Enable_Interrupts;
ret = s48_make_vector(ac, S48_FALSE);
S48_GC_PROTECT_1 (ret);
for (i = 0; i < ac; i++) {
S48_VECTOR_SET(ret, i, s48_enter_string(av[i]));
}
S48_GC_UNPROTECT();
if (ac) XFreeStringList (av);
return ret;
}
int String_Vector_To_Text_Property (s48_value x, XTextProperty* ret) {
s48_value t = S48_FALSE;
int i, n = S48_VECTOR_LENGTH(x);
char* s[n];
for (i = 0; i < n; i++) {
t = S48_VECTOR_REF(x, i);
s[i] = s48_extract_string(t);
}
return XStringListToTextProperty (s, n, ret);
// Primitive_Error ("cannot create text property");
}
s48_value Text_Property_To_String_Vector (XTextProperty *p) {
int n, i;
char **s;
s48_value ret;
S48_DECLARE_GC_PROTECT(2);
if (!XTextPropertyToStringList (p, &s, &n))
return S48_FALSE;
// Primitive_Error ("cannot convert from text property");
ret = s48_make_vector(n, S48_FALSE);
S48_GC_PROTECT_1 (ret);
for (i = 0; i < n; i++) {
S48_VECTOR_SET(ret, i, s48_enter_string(s[i]));
}
S48_GC_UNPROTECT();
XFreeStringList (s);
return ret;
}
s48_value scx_Get_Text_Property (s48_value dpy, s48_value w, s48_value a) {
XTextProperty ret;
// Disable_Interrupts;
if (!XGetTextProperty (SCX_EXTRACT_DISPLAY(dpy),
SCX_EXTRACT_WINDOW(w),
&ret,
SCX_EXTRACT_ATOM(a))) {
//Enable_Interrupts;
return S48_TRUE; // little hack to distinguish between this error and a
// possible Text_Pr._To_S._L. error
}
//Enable_Interrupts;
return Text_Property_To_String_Vector (&ret);
}
s48_value scx_Set_Text_Property (s48_value dpy, s48_value w, s48_value prop,
s48_value a) {
XTextProperty p;
if (!String_Vector_To_Text_Property (prop, &p))
return S48_FALSE;
XSetTextProperty (SCX_EXTRACT_DISPLAY(dpy),
SCX_EXTRACT_WINDOW(w),
&p, SCX_EXTRACT_ATOM(a));
XFree ((char *)p.value);
s48_value scx_Iconify_Window(s48_value display, s48_value w, s48_value scr) {
if (!XIconifyWindow(scx_extract_display(display),
scx_extract_window(w),
s48_extract_integer(scr)))
scx_raise_status_error("iconify-window", "XIconifyWindow");
return S48_UNSPECIFIC;
}
s48_value scx_Wm_Protocols (s48_value Xdisplay, s48_value w) {
Atom *p;
int i, n;
s48_value ret;
s48_value scx_Withdraw_Window(s48_value display, s48_value w, s48_value scr) {
if (!XWithdrawWindow(scx_extract_display(display),
scx_extract_window(w),
s48_extract_integer(scr)))
scx_raise_status_error("withdraw-window", "XWithdrawWindow");
return S48_UNSPECIFIC;
}
s48_value scx_Reconfigure_Wm_Window(s48_value dpy, s48_value w, s48_value scr,
s48_value conf) {
XWindowChanges WC;
unsigned long mask = scx_extract_window_changes(conf, &WC);
if (!XReconfigureWMWindow(scx_extract_display(dpy),
scx_extract_window(w),
s48_extract_integer(scr),
mask, &WC))
scx_raise_status_error("reconfigure-wm-window", "XReconfigureWMWindow");
return S48_UNSPECIFIC;
}
s48_value scx_Get_Wm_Command(s48_value dpy, s48_value w) {
int i, ac;
char** av;
s48_value ret = S48_NULL;
S48_DECLARE_GC_PROTECT(1);
//Disable_Interrupts;
if (!XGetWMProtocols (SCX_EXTRACT_DISPLAY(Xdisplay),
SCX_EXTRACT_WINDOW(w), &p, &n))
return S48_FALSE;
//Enable_Interrupts;
if (!XGetCommand (scx_extract_display(dpy),
scx_extract_window(w),
&av, &ac))
scx_raise_status_error("get-wm-command", "XGetCommand");
ret = s48_make_vector (n, S48_NULL);
S48_GC_PROTECT_1 (ret);
for (i = 0; i < n; i++) {
S48_VECTOR_SET(ret, i, SCX_ENTER_ATOM(p[i]));
}
XFree ((char *)p);
S48_GC_PROTECT_1(ret);
for (i = ac-1; i >= 0; i--)
ret = s48_cons(s48_enter_string(av[i]), ret);
S48_GC_UNPROTECT();
if (av != NULL) XFreeStringList(av);
return ret;
}
s48_value scx_Set_Wm_Protocols (s48_value Xdisplay, s48_value w, s48_value v) {
int i, n = S48_VECTOR_LENGTH(v);
Atom p[n];
for (i = 0; i < n; i++)
p[i] = SCX_EXTRACT_ATOM(S48_VECTOR_REF(v, i));
if (!XSetWMProtocols (SCX_EXTRACT_DISPLAY(Xdisplay),
SCX_EXTRACT_WINDOW(w),
p, n))
return S48_FALSE;
else
return S48_UNSPECIFIC;
s48_value scx_Set_Wm_Command(s48_value dpy, s48_value w, s48_value cmd) {
int i, n = s48_list_length(cmd);
char *argv[n];
for (i = 0; i < n; i++) {
argv[i] = s48_extract_string(S48_CAR(cmd));
cmd = S48_CDR(cmd);
}
XSetCommand(scx_extract_display(dpy),
scx_extract_window(w),
argv, n);
return S48_UNSPECIFIC;
}
s48_value scx_Wm_Class (s48_value Xdisplay, s48_value w) {
s48_value scx_Get_Wm_Protocols(s48_value display, s48_value w) {
Atom *p;
int i, n;
s48_value ret = S48_NULL;
S48_DECLARE_GC_PROTECT(1);
if (!XGetWMProtocols (scx_extract_display(display),
scx_extract_window(w), &p, &n))
scx_raise_status_error("get-wm-protocols", "XGetWMProtocols");
S48_GC_PROTECT_1(ret);
for (i = n-1; i >= 0; i--)
ret = s48_cons(scx_enter_atom(p[i]), ret);
S48_GC_UNPROTECT();
XFree((char *)p);
return ret;
}
s48_value scx_Set_Wm_Protocols (s48_value display, s48_value w, s48_value v) {
int i, n = s48_list_length(v);
Atom p[n];
for (i = 0; i < n; i++) {
p[i] = scx_extract_atom(S48_CAR(v));
v = S48_CDR(v);
}
if (!XSetWMProtocols (scx_extract_display(display),
scx_extract_window(w),
p, n))
scx_raise_status_error("set-wm-protocols", "XSetWMProtocols");
return S48_UNSPECIFIC;
}
s48_value scx_Get_Wm_Class (s48_value display, s48_value w) {
s48_value ret, x;
XClassHint c;
S48_DECLARE_GC_PROTECT(1);
// Elk says:
// > In X11.2 XGetClassHint() returns either 0 or Success, which happens
// > to be defined as 0. So until this bug is fixed, we must
// > explicitly check whether the XClassHint structure has been filled.
// but on the other hand, it doesn't even support X11.3, so I think
// <this> is fixed!
c.res_name = c.res_class = 0;
// Disable_Interrupts;
if (!XGetClassHint (SCX_EXTRACT_DISPLAY(Xdisplay),
SCX_EXTRACT_WINDOW(w), &c)) {
// Enable_Interrupts;
return S48_FALSE;
}
// Enable_Interrupts;
if (!XGetClassHint(scx_extract_display(display),
scx_extract_window(w), &c))
scx_raise_status_error("get-wm-class", "XGetClassHint");
ret = s48_cons (S48_FALSE, S48_FALSE);
S48_GC_PROTECT_1 (ret);
if (c.res_name) {
S48_SET_CAR(ret, s48_enter_string(c.res_name));
XFree (c.res_name);
}
if (c.res_class) {
S48_SET_CDR(ret, s48_enter_string(c.res_class));
XFree (c.res_class);
}
ret = s48_cons(S48_FALSE, S48_FALSE);
S48_GC_PROTECT_1(ret);
S48_SET_CAR(ret, s48_enter_string(c.res_name));
S48_SET_CDR(ret, s48_enter_string(c.res_class));
XFree(c.res_name);
XFree(c.res_class);
S48_GC_UNPROTECT();
return ret;
}
s48_value scx_Set_Wm_Class (s48_value dpy, s48_value w, s48_value name,
s48_value class) {
s48_value scx_Set_Wm_Class(s48_value dpy, s48_value w, s48_value name,
s48_value class) {
XClassHint c;
c.res_name = s48_extract_string(name);
c.res_class = s48_extract_string(class);
XSetClassHint (SCX_EXTRACT_DISPLAY(dpy),
SCX_EXTRACT_WINDOW(dpy),
&c);
XSetClassHint(scx_extract_display(dpy),
scx_extract_window(dpy),
&c);
return S48_UNSPECIFIC;
}
s48_value scx_Set_Wm_Command (s48_value dpy, s48_value w, s48_value cmd) {
int i, n = S48_VECTOR_LENGTH(cmd);
char *argv[n];
for (i = 0; i < n; i++)
argv[i] = s48_extract_string(S48_VECTOR_REF(cmd, i));
#define scx_extract_initial_state(x) S48_EXTRACT_ENUM(x, "scx-initial-state")
#define scx_enter_initial_state(x) S48_ENTER_ENUM(x, "scx-initial-states")
XSetCommand (SCX_EXTRACT_DISPLAY(dpy),
SCX_EXTRACT_WINDOW(w),
argv, n);
return S48_UNSPECIFIC;
}
#define scx_extract_wm_hint(x) S48_EXTRACT_ENUM(x, "scx-wm-hint")
#define scx_enter_wm_hint(x) S48_ENTER_ENUM(x, "scx-wm-hint")
s48_value scx_Wm_Hints (s48_value dpy, s48_value w) {
XWMHints* p = (XWMHints*)0;
s48_value res;
S48_DECLARE_GC_PROTECT(1);
//Disable_Interrupts;
p = XGetWMHints (SCX_EXTRACT_DISPLAY(dpy),
SCX_EXTRACT_WINDOW(w));
//Enable_Interrupts;
if (p) {
res = s48_make_vector(9, S48_UNSPECIFIC);
S48_GC_PROTECT_1(res);
if (p->flags & InputHint)
S48_VECTOR_SET(res, 0, S48_ENTER_BOOLEAN(p->input));
if (p->flags & StateHint)
S48_VECTOR_SET(res, 1,
s48_enter_integer(p->initial_state));
if (p->flags & IconPixmapHint)
S48_VECTOR_SET(res, 2, SCX_ENTER_PIXMAP(p->icon_pixmap));
if (p->flags & IconWindowHint)
S48_VECTOR_SET(res, 3, SCX_ENTER_WINDOW(p->icon_window));
if (p->flags & IconPositionHint)
S48_VECTOR_SET(res, 4, s48_cons(s48_enter_fixnum(p->icon_x),
s48_enter_fixnum(p->icon_y)));
if (p->flags & IconMaskHint)
S48_VECTOR_SET(res, 5, SCX_ENTER_PIXMAP(p->icon_mask));
if (p->flags & WindowGroupHint)
// Elk says a window-group is a window...??
S48_VECTOR_SET(res, 6, SCX_ENTER_WINDOW(p->window_group));
S48_VECTOR_SET(res, 7, S48_ENTER_BOOLEAN(p->flags & XUrgencyHint));
// XLib man-pages say this constant is called UrgencyHint !!
res = s48_cons(s48_enter_integer(p->flags), res);
S48_GC_UNPROTECT();
XFree((char*)p);
} else {
res = S48_FALSE;
s48_value scx_enter_wm_hint_alist(XWMHints* p) {
s48_value res = S48_NULL, t = S48_FALSE;
S48_DECLARE_GC_PROTECT(2);
S48_GC_PROTECT_2(res, t);
if (p->flags & InputHint) {
t = scx_enter_wm_hint(0); t = s48_cons(t, S48_ENTER_BOOLEAN(p->input));
res = s48_cons(t, res);
}
if (p->flags & StateHint) {
t = scx_enter_wm_hint(1);
t = s48_cons(t, scx_enter_initial_state(p->initial_state));
res = s48_cons(t, res);
}
if (p->flags & IconPixmapHint) {
t = scx_enter_wm_hint(2);
t = s48_cons(t, scx_enter_pixmap(p->icon_pixmap));
res = s48_cons(t, res);
}
if (p->flags & IconWindowHint) {
t = scx_enter_wm_hint(3);
t = s48_cons(t, scx_enter_window(p->icon_window));
res = s48_cons(t, res);
}
if (p->flags & IconPositionHint) {
t = s48_enter_integer(p->icon_y);
t = s48_cons(s48_enter_integer(p->icon_x), t);
t = s48_cons(scx_enter_wm_hint(4), t);
res = s48_cons(t, res);
}
if (p->flags & IconMaskHint) {
t = scx_enter_wm_hint(5);
t = s48_cons(t, scx_enter_pixmap(p->icon_mask));
res = s48_cons(t, res);
}
if (p->flags & WindowGroupHint) {
t = scx_enter_wm_hint(6);
t = s48_cons(t, scx_enter_window(p->window_group));
res = s48_cons(t, res);
}
t = scx_enter_wm_hint(8);
t = s48_cons(t, S48_ENTER_BOOLEAN(p->flags & XUrgencyHint));
res = s48_cons(t, res);
S48_GC_UNPROTECT();
return res;
}
void scx_extract_wm_hint_alist(s48_value alist, XWMHints* p) {
p->flags = 0;
while (alist != S48_NULL) {
int h = scx_extract_wm_hint(S48_CAR(S48_CAR(alist)));
s48_value v = S48_CDR(S48_CAR(alist));
switch (h) {
case 0:
p->flags |= InputHint;
p->input = S48_EXTRACT_BOOLEAN(v);
break;
case 1:
p->flags |= StateHint;
p->initial_state = scx_extract_initial_state(v);
break;
case 2:
p->flags |= IconPixmapHint;
p->icon_pixmap = scx_extract_pixmap(v);
break;
case 3:
p->flags |= IconWindowHint;
p->icon_window = scx_extract_window(v);
break;
case 4:
p->flags |= IconPositionHint;
p->icon_x = s48_extract_integer(S48_CAR(v));
p->icon_y = s48_extract_integer(S48_CDR(v));
break;
case 5:
p->flags |= IconMaskHint;
p->icon_mask = scx_extract_pixmap(v);
break;
case 6:
p->flags |= WindowGroupHint;
p->window_group = scx_extract_window(v);
break;
case 7:
if (S48_EXTRACT_BOOLEAN(v))
p->flags |= XUrgencyHint;
break;
}
alist = S48_CDR(alist);
}
}
s48_value scx_Get_Wm_Hints(s48_value dpy, s48_value w) {
XWMHints* p;
s48_value res = S48_NULL;
p = XGetWMHints(scx_extract_display(dpy),
scx_extract_window(w));
if (p) {
res = scx_enter_wm_hint_alist(p);
XFree(p);
} else
scx_raise_status_error("get-wm-hints", "XGetWMHints");
return res;
}
s48_value scx_Set_Wm_Hints (s48_value dpy, s48_value w, s48_value hints) {
long mask = s48_extract_integer(S48_CAR(hints));
s48_value v = S48_CDR(hints);
XWMHints WMH;
if (mask & InputHint)
WMH.input = S48_EXTRACT_BOOLEAN(S48_VECTOR_REF(v, 0));
if (mask & StateHint)
WMH.initial_state = s48_extract_integer(S48_VECTOR_REF(v, 1));
if (mask & IconPixmapHint)
WMH.icon_pixmap = SCX_EXTRACT_PIXMAP(S48_VECTOR_REF(v, 2));
if (mask & IconWindowHint)
WMH.icon_window = SCX_EXTRACT_WINDOW(S48_VECTOR_REF(v, 3));
if (mask & IconPositionHint) {
WMH.icon_x = (int)s48_extract_integer(S48_CAR(S48_VECTOR_REF(v, 4)));
WMH.icon_y = (int)s48_extract_integer(S48_CDR(S48_VECTOR_REF(v, 4)));
}
if (mask & IconMaskHint)
WMH.icon_mask = SCX_EXTRACT_PIXMAP(S48_VECTOR_REF(v, 5));
if (mask & WindowGroupHint)
WMH.window_group = SCX_EXTRACT_WINDOW(S48_VECTOR_REF(v, 6));
if (mask & XUrgencyHint)
if (S48_FALSE == S48_EXTRACT_BOOLEAN(S48_VECTOR_REF(v, 7)))
mask = mask & (~XUrgencyHint);
WMH.flags = mask;
XSetWMHints(SCX_EXTRACT_DISPLAY(dpy),
SCX_EXTRACT_WINDOW(w),
scx_extract_wm_hint_alist(hints, &WMH);
XSetWMHints(scx_extract_display(dpy),
scx_extract_window(w),
&WMH);
return S48_UNSPECIFIC;
}
s48_value scx_Icon_Sizes (s48_value dpy, s48_value w) {
XIconSize *p;
int i, n;
s48_value v;
S48_DECLARE_GC_PROTECT(1);
//Disable_Interrupts;
if (!XGetIconSizes (SCX_EXTRACT_DISPLAY(dpy),
SCX_EXTRACT_WINDOW(w),
&p, &n))
n = 0;
//Enable_Interrupts;
v = s48_make_vector (n, S48_NULL);
S48_GC_PROTECT_1 (v);
for (i = 0; i < n; i++) {
XIconSize* q = &p[i];
s48_value t = s48_make_vector(6, S48_NULL);
S48_VECTOR_SET(v, i, t);
S48_VECTOR_SET(t, 0, s48_enter_fixnum(q->min_width));
S48_VECTOR_SET(t, 1, s48_enter_fixnum(q->min_height));
S48_VECTOR_SET(t, 2, s48_enter_fixnum(q->max_width));
S48_VECTOR_SET(t, 3, s48_enter_fixnum(q->max_height));
S48_VECTOR_SET(t, 4, s48_enter_fixnum(q->width_inc));
S48_VECTOR_SET(t, 5, s48_enter_fixnum(q->height_inc));
}
S48_GC_UNPROTECT();
if (n > 0)
XFree ((char *)p);
return v;
}
s48_value scx_Set_Icon_Sizes (s48_value dpy, s48_value w, s48_value v) {
int i, n = S48_VECTOR_LENGTH(v);
XIconSize p[n];
for (i = 0; i < n; i++) {
XIconSize *q = &p[i];
s48_value t = S48_VECTOR_REF(v, i);
q->min_width = (int)s48_extract_integer(S48_VECTOR_REF(t, 0));
q->min_height = (int)s48_extract_integer(S48_VECTOR_REF(t, 1));
q->max_width = (int)s48_extract_integer(S48_VECTOR_REF(t, 2));
q->max_height = (int)s48_extract_integer(S48_VECTOR_REF(t, 3));
q->width_inc = (int)s48_extract_integer(S48_VECTOR_REF(t, 4));
q->height_inc = (int)s48_extract_integer(S48_VECTOR_REF(t, 5));
}
XSetIconSizes (SCX_EXTRACT_DISPLAY(dpy),
SCX_EXTRACT_WINDOW(w),
p, n);
return S48_UNSPECIFIC;
}
s48_value scx_Transient_For(s48_value dpy, s48_value w) {
s48_value scx_Get_Transient_For(s48_value dpy, s48_value w) {
Window win;
//Disable_Interrupts;
if (!XGetTransientForHint(SCX_EXTRACT_DISPLAY(dpy),
SCX_EXTRACT_WINDOW(w),
if (!XGetTransientForHint(scx_extract_display(dpy),
scx_extract_window(w),
&win))
win = None;
//Enable_Interrupts;
return SCX_ENTER_WINDOW(win);
scx_raise_status_error("get-transient-for", "XGetTransientForHint");
return scx_enter_window(win);
}
s48_value scx_Set_Transient_For(s48_value dpy, s48_value w, s48_value pw) {
XSetTransientForHint (SCX_EXTRACT_DISPLAY(dpy),
SCX_EXTRACT_WINDOW(w),
SCX_EXTRACT_WINDOW(pw));
XSetTransientForHint(scx_extract_display(dpy),
scx_extract_window(w),
scx_extract_window(pw));
return S48_UNSPECIFIC;
}
s48_value scx_Wm_Normal_Hints(s48_value dpy, s48_value win) {
XSizeHints SH;
long supplied;
s48_value v;
S48_DECLARE_GC_PROTECT(1);
s48_value scx_Get_Text_Property(s48_value dpy, s48_value w, s48_value a) {
XTextProperty ret;
s48_value res = S48_FALSE;
if (!XGetTextProperty (scx_extract_display(dpy),
scx_extract_window(w),
&ret,
scx_extract_atom(a)))
scx_raise_status_error("get-text-property", "XGetTextProperty");
res = scx_enter_property(ret.encoding, ret.format, ret.value, ret.nitems);
XFree(ret.value);
return res;
}
if (!XGetWMNormalHints(SCX_EXTRACT_DISPLAY(dpy),
SCX_EXTRACT_WINDOW(win),
&SH, &supplied))
SH.flags = 0;
v = s48_make_vector(10, S48_NULL);
S48_GC_PROTECT_1(v);
s48_value scx_Set_Text_Property(s48_value dpy, s48_value w, s48_value prop,
s48_value a) {
XTextProperty p;
scx_extract_property(prop, &p.encoding, &p.format,
(char**)&p.value,
(int*)&p.nitems);
XSetTextProperty(scx_extract_display(dpy),
scx_extract_window(w),
&p, scx_extract_atom(a));
return S48_UNSPECIFIC;
}
if ((SH.flags & USPosition) != 0)
S48_VECTOR_SET(v, 0, S48_VECTOR_REF(v, 2));
if ((SH.flags & USSize) != 0)
S48_VECTOR_SET(v, 1, S48_VECTOR_REF(v, 3));
if (((SH.flags & PPosition) != 0) || ((SH.flags & USPosition) != 0))
S48_VECTOR_SET(v, 2, s48_cons(s48_enter_fixnum(SH.x),
s48_enter_fixnum(SH.y)));
if (((SH.flags & PSize) != 0) || ((SH.flags & USSize) != 0))
S48_VECTOR_SET(v, 3, s48_cons(s48_enter_fixnum(SH.width),
s48_enter_fixnum(SH.height)));
if ((SH.flags & PMinSize) != 0)
S48_VECTOR_SET(v, 4, s48_cons(s48_enter_fixnum(SH.min_width),
s48_enter_fixnum(SH.min_height)));
if ((SH.flags & PMaxSize) != 0)
S48_VECTOR_SET(v, 5, s48_cons(s48_enter_fixnum(SH.max_width),
s48_enter_fixnum(SH.max_height)));
if ((SH.flags & PResizeInc) != 0)
S48_VECTOR_SET(v, 6, s48_cons(s48_enter_fixnum(SH.width_inc),
s48_enter_fixnum(SH.height_inc)));
if ((SH.flags & PAspect) != 0)
S48_VECTOR_SET(v, 7,
s48_cons(s48_cons(s48_enter_fixnum(SH.min_aspect.x),
s48_enter_fixnum(SH.min_aspect.y)),
s48_cons(s48_enter_fixnum(SH.max_aspect.x),
s48_enter_fixnum(SH.max_aspect.y))));
if ((SH.flags & PBaseSize) != 0)
S48_VECTOR_SET(v, 8, s48_cons(s48_enter_fixnum(SH.base_width),
s48_enter_fixnum(SH.base_height)));
if ((SH.flags & PWinGravity) != 0)
S48_VECTOR_SET(v, 9, s48_enter_integer(SH.win_gravity));
v = s48_cons(s48_enter_integer(SH.flags), v);
#define scx_extract_size_hint(h) S48_EXTRACT_ENUM(h, "scx-size-hint")
#define scx_enter_size_hint(h) S48_ENTER_ENUM(h, "scx-size-hints")
s48_value scx_enter_size_hint_alist(XSizeHints* sh) {
int i;
s48_value res = S48_NULL, v = S48_FALSE, t = S48_FALSE;
S48_DECLARE_GC_PROTECT(3);
S48_GC_PROTECT_3(res, v, t);
for (i = 0; i < 10; i++) {
if (sh->flags & (1L << i)) {
switch (1L << i) {
case USPosition: case PPosition:
v = s48_enter_integer(sh->x);
v = s48_cons(v, s48_enter_integer(sh->y));
break;
case USSize: case PSize:
v = s48_enter_integer(sh->width);
v = s48_cons(v, s48_enter_integer(sh->height));
break;
case PMinSize:
v = s48_enter_integer(sh->min_width);
v = s48_cons(v, s48_enter_integer(sh->min_height));
break;
case PMaxSize:
v = s48_enter_integer(sh->max_width);
v = s48_cons(v, s48_enter_integer(sh->max_width));
break;
case PResizeInc:
v = s48_enter_integer(sh->width_inc);
v = s48_cons(v, s48_enter_integer(sh->height_inc));
break;
case PAspect:
v = s48_enter_integer(sh->min_aspect.x);
v = s48_cons(v, s48_enter_integer(sh->min_aspect.y));
t = s48_enter_integer(sh->max_aspect.x);
t = s48_cons(t, s48_enter_integer(sh->max_aspect.y));
v = s48_cons(v, t);
break;
case PBaseSize:
v = s48_enter_integer(sh->base_width);
v = s48_cons(v, s48_enter_integer(sh->base_height));
break;
case PWinGravity:
v = scx_enter_win_gravity(sh->win_gravity);
break;
default: v = S48_FALSE;
}
t = scx_enter_size_hint(i);
t = s48_cons(t, v);
res = s48_cons(t, res);
}
}
S48_GC_UNPROTECT();
return v;
return res;
}
void scx_extract_size_hint_alist(s48_value l, XSizeHints* sh) {
sh->flags = 0;
for (; l != S48_NULL; l = S48_CDR(l)) {
int m = scx_extract_size_hint(S48_CAR(S48_CAR(l)));
s48_value v = S48_CDR(S48_CAR(l));
sh->flags |= (1L << m);
switch (1L << m) {
case USPosition: case PPosition:
sh->x = s48_extract_integer(S48_CAR(v));
sh->y = s48_extract_integer(S48_CDR(v));
break;
case USSize: case PSize:
sh->width = s48_extract_integer(S48_CAR(v));
sh->height = s48_extract_integer(S48_CDR(v));
break;
case PMinSize:
sh->min_width = s48_extract_integer(S48_CAR(v));
sh->min_height = s48_extract_integer(S48_CDR(v));
break;
case PMaxSize:
sh->max_width = s48_extract_integer(S48_CAR(v));
sh->max_height = s48_extract_integer(S48_CDR(v));
break;
case PResizeInc:
sh->width_inc = s48_extract_integer(S48_CAR(v));
sh->height_inc = s48_extract_integer(S48_CDR(v));
break;
case PAspect:
sh->min_aspect.x = s48_extract_integer(S48_CAR(S48_CAR(v)));
sh->min_aspect.y = s48_extract_integer(S48_CDR(S48_CAR(v)));
sh->max_aspect.x = s48_extract_integer(S48_CAR(S48_CDR(v)));
sh->max_aspect.y = s48_extract_integer(S48_CDR(S48_CDR(v)));
break;
case PBaseSize:
sh->base_width = s48_extract_integer(S48_CAR(v));
sh->base_height = s48_extract_integer(S48_CDR(v));
break;
case PWinGravity:
sh->win_gravity = scx_extract_win_gravity(v);
break;
}
}
}
s48_value scx_Get_Wm_Normal_Hints(s48_value dpy, s48_value win) {
XSizeHints SH;
long supplied_by_user;
if (!XGetWMNormalHints(scx_extract_display(dpy),
scx_extract_window(win),
&SH, &supplied_by_user))
scx_raise_status_error("get-wm-normal-hints", "XGetWMNormalHints");
// ignoring supplied_by_user ... ?!
return scx_enter_size_hint_alist(&SH);
}
s48_value scx_Set_Wm_Normal_Hints(s48_value dpy, s48_value win,
s48_value hints) {
XSizeHints SH;
long mask = s48_extract_integer(S48_CAR(hints));
s48_value v = S48_CDR(hints);
scx_extract_size_hint_alist(hints, &SH);
if (mask & USPosition) {
SH.x = s48_extract_integer(S48_CAR(S48_VECTOR_REF(v, 0)));
SH.y = s48_extract_integer(S48_CDR(S48_VECTOR_REF(v, 0)));
}
if (mask & USSize) {
SH.width = s48_extract_integer(S48_CAR(S48_VECTOR_REF(v, 1)));
SH.height = s48_extract_integer(S48_CDR(S48_VECTOR_REF(v, 1)));
}
if (mask & PPosition) {
SH.x = s48_extract_integer(S48_CAR(S48_VECTOR_REF(v, 2)));
SH.y = s48_extract_integer(S48_CDR(S48_VECTOR_REF(v, 2)));
}
if (mask & PSize) {
SH.width = s48_extract_integer(S48_CAR(S48_VECTOR_REF(v, 3)));
SH.height = s48_extract_integer(S48_CDR(S48_VECTOR_REF(v, 3)));
}
if (mask & PMinSize) {
SH.min_width = s48_extract_integer(S48_CAR(S48_VECTOR_REF(v, 4)));
SH.min_height = s48_extract_integer(S48_CDR(S48_VECTOR_REF(v, 4)));
}
if (mask & PMaxSize) {
SH.max_width = s48_extract_integer(S48_CAR(S48_VECTOR_REF(v, 5)));
SH.max_height = s48_extract_integer(S48_CDR(S48_VECTOR_REF(v, 5)));
}
if (mask & PResizeInc) {
SH.width_inc = s48_extract_integer(S48_CAR(S48_VECTOR_REF(v, 6)));
SH.height_inc = s48_extract_integer(S48_CDR(S48_VECTOR_REF(v, 6)));
}
if (mask & PAspect) {
SH.min_aspect.x =
s48_extract_integer(S48_CAR(S48_CAR(S48_VECTOR_REF(v, 7))));
SH.min_aspect.y =
s48_extract_integer(S48_CDR(S48_CAR(S48_VECTOR_REF(v, 7))));
SH.max_aspect.x =
s48_extract_integer(S48_CAR(S48_CDR(S48_VECTOR_REF(v, 7))));
SH.max_aspect.y =
s48_extract_integer(S48_CDR(S48_CDR(S48_VECTOR_REF(v, 7))));
}
if (mask & PBaseSize) {
SH.base_width = s48_extract_integer(S48_CAR(S48_VECTOR_REF(v, 8)));
SH.base_height = s48_extract_integer(S48_CDR(S48_VECTOR_REF(v, 8)));
}
if (mask & PWinGravity)
SH.win_gravity = s48_extract_integer(S48_VECTOR_REF(v, 9));
SH.flags = mask;
XSetWMNormalHints(SCX_EXTRACT_DISPLAY(dpy),
SCX_EXTRACT_WINDOW(win),
XSetWMNormalHints(scx_extract_display(dpy),
scx_extract_window(win),
&SH);
return S48_UNSPECIFIC;
}
s48_value scx_enter_icon_size(XIconSize* is) {
s48_value res = s48_make_record(s48_get_imported_binding("scx-icon-size"));
S48_DECLARE_GC_PROTECT(1);
S48_GC_PROTECT_1(res);
S48_RECORD_SET(res, 0, s48_enter_integer(is->min_width));
S48_RECORD_SET(res, 1, s48_enter_integer(is->min_height));
S48_RECORD_SET(res, 2, s48_enter_integer(is->max_width));
S48_RECORD_SET(res, 3, s48_enter_integer(is->max_height));
S48_RECORD_SET(res, 4, s48_enter_integer(is->width_inc));
S48_RECORD_SET(res, 5, s48_enter_integer(is->height_inc));
S48_GC_UNPROTECT();
return res;
}
void scx_extract_icon_size(s48_value r, XIconSize* is) {
s48_check_record_type(r, s48_get_imported_binding("scx-icon-size"));
is->min_width = s48_extract_integer(S48_RECORD_REF(r, 0));
is->min_height = s48_extract_integer(S48_RECORD_REF(r, 1));
is->max_width = s48_extract_integer(S48_RECORD_REF(r, 2));
is->max_height = s48_extract_integer(S48_RECORD_REF(r, 3));
is->width_inc = s48_extract_integer(S48_RECORD_REF(r, 4));
is->height_inc = s48_extract_integer(S48_RECORD_REF(r, 5));
}
s48_value scx_Get_Icon_Sizes(s48_value dpy, s48_value w) {
XIconSize *p;
int i, n;
s48_value v = S48_NULL;
S48_DECLARE_GC_PROTECT(1);
if (!XGetIconSizes (scx_extract_display(dpy),
scx_extract_window(w),
&p, &n))
scx_raise_status_error("get-icon-sizes", "XGetIconSizes");
S48_GC_PROTECT_1(v);
for (i = n-1; i >= 0; i--)
v = s48_cons(scx_enter_icon_size(&p[i]), v);
S48_GC_UNPROTECT();
XFree((char *)p);
return v;
}
s48_value scx_Set_Icon_Sizes(s48_value dpy, s48_value w, s48_value v) {
int i, n = s48_list_length(v);
XIconSize p[n];
for (i = 0; i < n; i++) {
scx_extract_icon_size(S48_CAR(v), &p[i]);
v = S48_CDR(v);
}
XSetIconSizes(scx_extract_display(dpy),
scx_extract_window(w),
p, n);
return S48_UNSPECIFIC;
}
@ -495,20 +473,20 @@ scx_init_client() {
S48_EXPORT_FUNCTION(scx_Iconify_Window);
S48_EXPORT_FUNCTION(scx_Withdraw_Window);
S48_EXPORT_FUNCTION(scx_Reconfigure_Wm_Window);
S48_EXPORT_FUNCTION(scx_Wm_Command);
S48_EXPORT_FUNCTION(scx_Get_Wm_Command);
S48_EXPORT_FUNCTION(scx_Get_Text_Property);
S48_EXPORT_FUNCTION(scx_Set_Text_Property);
S48_EXPORT_FUNCTION(scx_Wm_Protocols);
S48_EXPORT_FUNCTION(scx_Get_Wm_Protocols);
S48_EXPORT_FUNCTION(scx_Set_Wm_Protocols);
S48_EXPORT_FUNCTION(scx_Wm_Class);
S48_EXPORT_FUNCTION(scx_Get_Wm_Class);
S48_EXPORT_FUNCTION(scx_Set_Wm_Class);
S48_EXPORT_FUNCTION(scx_Set_Wm_Command);
S48_EXPORT_FUNCTION(scx_Wm_Hints);
S48_EXPORT_FUNCTION(scx_Get_Wm_Hints);
S48_EXPORT_FUNCTION(scx_Set_Wm_Hints);
S48_EXPORT_FUNCTION(scx_Icon_Sizes);
S48_EXPORT_FUNCTION(scx_Set_Icon_Sizes);
S48_EXPORT_FUNCTION(scx_Transient_For);
S48_EXPORT_FUNCTION(scx_Get_Transient_For);
S48_EXPORT_FUNCTION(scx_Set_Transient_For);
S48_EXPORT_FUNCTION(scx_Wm_Normal_Hints);
S48_EXPORT_FUNCTION(scx_Get_Wm_Normal_Hints);
S48_EXPORT_FUNCTION(scx_Set_Wm_Normal_Hints);
S48_EXPORT_FUNCTION(scx_Get_Icon_Sizes);
S48_EXPORT_FUNCTION(scx_Set_Icon_Sizes);
}

328
c/xlib/colormap.c
View File

@ -1,163 +1,273 @@
#include "xlib.h"
#include "scheme48.h"
s48_value scx_Free_Colormap (s48_value Xcolormap, s48_value Xdisplay) {
XFreeColormap(SCX_EXTRACT_DISPLAY(Xdisplay),
SCX_EXTRACT_COLORMAP(Xcolormap));
#define scx_extract_colormap_alloc(x) S48_EXTRACT_ENUM(x, "scx-colormap-alloc")
double s48_extract_number(s48_value v) {
if (S48_DOUBLE_P(v))
return s48_extract_double(v);
else return s48_extract_integer(v);
}
void scx_extract_color(s48_value v, XColor* c) {
s48_check_record_type(v, scx_color);
c->pixel = scx_extract_pixel(S48_RECORD_REF(v, 0));
c->flags = 0;
if (S48_RECORD_REF(v, 1) != S48_FALSE) {
c->flags |= DoRed;
c->red = s48_extract_number(S48_RECORD_REF(v, 1)) * 65536;
}
if (S48_RECORD_REF(v, 2) != S48_FALSE) {
c->flags |= DoGreen;
c->green = s48_extract_number(S48_RECORD_REF(v, 2)) * 65536;
}
if (S48_RECORD_REF(v, 3) != S48_FALSE) {
c->flags |= DoBlue;
c->blue = s48_extract_number(S48_RECORD_REF(v, 3)) * 65536;
}
}
void scx_copy_color(const XColor* c, s48_value v) {
S48_DECLARE_GC_PROTECT(1);
s48_check_record_type(v, scx_color);
S48_GC_PROTECT_1(v);
S48_RECORD_SET(v, 0, scx_enter_pixel(c->pixel));
S48_RECORD_SET(v, 1, (c->flags & DoRed) ?
s48_enter_double((double)c->red / 65636.0) : S48_FALSE);
S48_RECORD_SET(v, 2, (c->flags & DoGreen) ?
s48_enter_double((double)c->green / 65636.0) : S48_FALSE);
S48_RECORD_SET(v, 3, (c->flags & DoBlue) ?
s48_enter_double((double)c->blue / 65636.0) : S48_FALSE);
S48_GC_UNPROTECT();
}
s48_value scx_enter_color(const XColor* c) {
s48_value res = s48_make_record(scx_color);
scx_copy_color(c, res);
return res;
}
s48_value scx_Create_Colormap (s48_value display, s48_value window,
s48_value visual, s48_value alloc) {
Colormap cm = XCreateColormap(scx_extract_display(display),
scx_extract_window(window),
scx_extract_visual(visual),
scx_extract_colormap_alloc(alloc));
return scx_enter_colormap(cm);
}
s48_value scx_Copy_Colormap_And_Free(s48_value display, s48_value colormap) {
Colormap cm = XCopyColormapAndFree(scx_extract_display(display),
scx_extract_colormap(colormap));
return scx_enter_colormap(cm);
}
s48_value scx_Free_Colormap (s48_value display, s48_value colormap) {
XFreeColormap(scx_extract_display(display),
scx_extract_colormap(colormap));
return S48_UNSPECIFIC;
}
s48_value scx_Alloc_Color(s48_value Xcolormap, s48_value Xcolor,
s48_value Xdisplay) {
XColor* cp = SCX_EXTRACT_COLOR(Xcolor);
s48_value scx_Alloc_Color(s48_value display, s48_value colormap,
s48_value color) {
XColor cp;
scx_extract_color(color, &cp);
if (!XAllocColor(SCX_EXTRACT_DISPLAY(Xdisplay),
SCX_EXTRACT_COLORMAP(Xcolormap), cp))
if (!XAllocColor(scx_extract_display(display),
scx_extract_colormap(colormap), &cp))
return S48_FALSE;
else
return SCX_ENTER_PIXEL(cp->pixel);
else {
scx_copy_color(&cp, color);
return S48_UNSPECIFIC;
}
}
s48_value scx_Alloc_Named_Color(s48_value Xcolormap, s48_value color_name,
s48_value Xdisplay) {
s48_value scx_Alloc_Named_Color(s48_value display, s48_value colormap,
s48_value color_name) {
XColor screen, exact;
int r;
s48_value ret = S48_FALSE;
S48_DECLARE_GC_PROTECT(2);
S48_DECLARE_GC_PROTECT(1);
r = XAllocNamedColor(scx_extract_display(display),
scx_extract_colormap(colormap),
s48_extract_string(color_name),
&screen, &exact);
r = XAllocNamedColor (SCX_EXTRACT_DISPLAY(Xdisplay),
SCX_EXTRACT_COLORMAP(Xcolormap),
s48_extract_string(color_name),
&screen, &exact);
if (r) {
S48_GC_PROTECT_1(ret);
ret = s48_cons(scx_Int_Extract_RGB_Values(exact), S48_NULL);
ret = s48_cons(scx_Int_Extract_RGB_Values(screen), ret);
ret = s48_cons(SCX_ENTER_PIXEL(screen.pixel), ret);
}
S48_GC_UNPROTECT();
return ret;
}
// swaped from util.c to this file
s48_value scx_Parse_Color (s48_value Xdpy, s48_value cmap, s48_value spec) {
XColor ret;
if (XParseColor (SCX_EXTRACT_DISPLAY(Xdpy),
SCX_EXTRACT_COLORMAP(cmap),
s48_extract_string(spec),
&ret)) {
s48_value res = s48_make_vector(3, S48_FALSE);
S48_DECLARE_GC_PROTECT(1);
S48_GC_PROTECT_1(res);
S48_VECTOR_SET(res, 0, s48_enter_integer(ret.red));
S48_VECTOR_SET(res, 1, s48_enter_integer(ret.green));
S48_VECTOR_SET(res, 2, s48_enter_integer(ret.blue));
if (r != 0) {
s48_value s = S48_NULL, e = S48_NULL;
S48_GC_PROTECT_2(s, e);
s = scx_enter_color(&screen);
e = scx_enter_color(&exact);
S48_GC_UNPROTECT();
return res;
}
return S48_FALSE;
return s48_cons(s, e);
} else
return S48_FALSE;
}
s48_value scx_Create_Colormap (s48_value Xdisplay, s48_value Xwindow,
s48_value Xvisual, s48_value alloc) {
Colormap cm = XCreateColormap( SCX_EXTRACT_DISPLAY(Xdisplay),
SCX_EXTRACT_WINDOW(Xwindow),
SCX_EXTRACT_VISUAL(Xvisual),
s48_extract_integer(alloc) );
return SCX_ENTER_COLORMAP(cm);
}
s48_value scx_Alloc_Color_Cells (s48_value Xdisplay, s48_value Xcolormap,
s48_value scx_Alloc_Color_Cells (s48_value display, s48_value colormap,
s48_value contig, s48_value nplanes,
s48_value npixels) {
int npl = s48_extract_integer(nplanes);
int npx = s48_extract_integer(npixels);
unsigned long plane_masks[npl];
unsigned long pixels[npx];
s48_value pls = S48_FALSE, pxs = S48_FALSE;
s48_value pls = S48_NULL, pxs = S48_NULL;
S48_DECLARE_GC_PROTECT(2);
if (XAllocColorCells(SCX_EXTRACT_DISPLAY(Xdisplay),
SCX_EXTRACT_COLORMAP(Xcolormap),
if (XAllocColorCells(scx_extract_display(display),
scx_extract_colormap(colormap),
!S48_FALSE_P(contig),
plane_masks, npl,
pixels, npx)) {
int i;
pls = s48_make_vector(npl, S48_FALSE);
pxs = s48_make_vector(npx, S48_FALSE);
S48_GC_PROTECT_2(pls, pxs);
for (i = 0; i < npl; i++)
S48_VECTOR_SET(pls, i, s48_enter_integer(plane_masks[i]));
for (i = 0; i < npx; i++)
S48_VECTOR_SET(pxs, i, s48_enter_integer(pixels[i]));
for (i = npl-1; i >= 0; i--)
pls = s48_cons(s48_enter_integer(plane_masks[i]), pls);
for (i = npx-1; i >= 0; i--)
pxs = s48_cons(scx_enter_pixel(pixels[i]), pxs);
S48_GC_UNPROTECT();
return s48_cons(pls, pxs);
} else
return S48_FALSE;
}
s48_value scx_Store_Color(s48_value Xdisplay, s48_value Xcolormap,
s48_value Xpixel, s48_value Xcolor,
s48_value flags) {
XColor t;
XColor* c;
c = SCX_EXTRACT_COLOR(Xcolor);
t.pixel = SCX_EXTRACT_PIXEL(Xpixel);
t.red = c->red;
t.green = c->green;
t.blue = c->blue;
t.flags = s48_extract_integer(flags);
XStoreColor(SCX_EXTRACT_DISPLAY(Xdisplay), SCX_EXTRACT_COLORMAP(Xcolormap),
&t);
s48_value scx_Alloc_Color_Planes(s48_value display, s48_value colormap,
s48_value contig, s48_value ncolors,
s48_value nreds, s48_value ngreens,
s48_value nblues) {
int npx = s48_extract_integer(ncolors);
int nre = s48_extract_integer(nreds);
int ngr = s48_extract_integer(ngreens);
int nbl = s48_extract_integer(nblues);
unsigned long pixels[npx];
unsigned long rmask, gmask, bmask;
s48_value pxs = S48_NULL;
s48_value res = S48_NULL;
S48_DECLARE_GC_PROTECT(2);
if (XAllocColorPlanes(scx_extract_display(display),
scx_extract_colormap(colormap),
!S48_FALSE_P(contig),
pixels, npx,
nre, ngr, nbl,
&rmask, &gmask, &bmask)) {
int i;
S48_GC_PROTECT_2(pxs, res);
for (i = npx-1; i >= 0; i--)
pxs = s48_cons(scx_enter_pixel(pixels[i]), pxs);
res = s48_cons(s48_enter_integer(bmask), res);
res = s48_cons(s48_enter_integer(gmask), res);
res = s48_cons(s48_enter_integer(rmask), res);
res = s48_cons(pxs, res);
S48_GC_UNPROTECT();
return res;
} else
return S48_FALSE;
}
s48_value scx_Free_Colors(s48_value display, s48_value colormap,
s48_value pixels, s48_value planes) {
int i, n = s48_list_length(pixels);
unsigned long cpixels[n];
s48_value l = pixels;
for (i = 0; i < n; i++) {
cpixels[i] = scx_extract_pixel(S48_CAR(l));
l = S48_CDR(l);
}
XFreeColors(scx_extract_display(display), scx_extract_colormap(colormap),
cpixels, n, s48_extract_integer(planes));
return S48_UNSPECIFIC;
}
s48_value scx_Store_Colors(s48_value Xdisplay, s48_value Xcolormap,
s48_value cells) {
int n = S48_VECTOR_LENGTH(cells);
XColor colors[n];
XColor* c;
int i;
s48_value scx_Query_Colors(s48_value display, s48_value colormap,
s48_value colors) {
int i, n = s48_list_length(colors);
XColor ccolors[n];
s48_value l = colors;
for (i = 0; i < n; i++) {
s48_value def = S48_VECTOR_REF(cells, i);
colors[i].pixel = SCX_EXTRACT_PIXEL(S48_VECTOR_REF(def, 0));
c = SCX_EXTRACT_COLOR(S48_VECTOR_REF(def, 1));
colors[i].red = c->red;
colors[i].green = c->green;
colors[i].blue = c->blue;
colors[i].flags = s48_extract_integer(S48_VECTOR_REF(def, 2));
scx_extract_color(S48_CAR(l), &ccolors[i]);
l = S48_CDR(l);
}
XQueryColors(scx_extract_display(display), scx_extract_colormap(colormap),
ccolors, n);
l = colors;
for (i = 0; i < n; i++) {
scx_copy_color(&ccolors[i], S48_CAR(l));
l = S48_CDR(l);
}
return S48_UNSPECIFIC;
}
s48_value scx_Lookup_Color(s48_value display, s48_value colormap,
s48_value color_name) {
XColor cexact, cscreen;
S48_DECLARE_GC_PROTECT(1);
s48_value r = S48_NULL;
int res = XLookupColor(scx_extract_display(display),
scx_extract_colormap(colormap),
s48_extract_string(color_name),
&cexact, &cscreen);
if (res == 0) return S48_FALSE;
S48_GC_PROTECT_1(r);
r = scx_enter_color(&cscreen);
r = s48_cons(scx_enter_color(&cexact), r);
S48_GC_UNPROTECT();
return r;
}
s48_value scx_Parse_Color(s48_value display, s48_value colormap,
s48_value spec) {
XColor ret;
if (XParseColor(scx_extract_display(display),
scx_extract_colormap(colormap),
s48_extract_string(spec),
&ret)) {
return scx_enter_color(&ret);
} else
return S48_FALSE;
}
s48_value scx_Store_Colors(s48_value display, s48_value colormap,
s48_value colors) {
int i, n = s48_list_length(colors);
XColor ccolors[n];
s48_value l = colors;
for (i = 0; i < n; i++) {
scx_extract_color(S48_CAR(l), &ccolors[i]);
l = S48_CDR(l);
}
XStoreColors(SCX_EXTRACT_DISPLAY(Xdisplay),
SCX_EXTRACT_COLORMAP(Xcolormap),
colors, n);
XStoreColors(scx_extract_display(display),
scx_extract_colormap(colormap),
ccolors, n);
return S48_UNSPECIFIC;
}
s48_value scx_Copy_Colormap_And_Free(s48_value Xdisplay, s48_value Xcolormap) {
Colormap cm = XCopyColormapAndFree(SCX_EXTRACT_DISPLAY(Xdisplay),
SCX_EXTRACT_COLORMAP(Xcolormap));
return SCX_ENTER_COLORMAP(cm);
s48_value scx_Store_Named_Color(s48_value display, s48_value colormap,
s48_value color_name, s48_value pixel,
s48_value do_red, s48_value do_green,
s48_value do_blue) {
XStoreNamedColor(scx_extract_display(display),
scx_extract_colormap(colormap),
s48_extract_string(color_name),
scx_extract_pixel(pixel),
(S48_EXTRACT_BOOLEAN(do_red) ? DoRed : 0) |
(S48_EXTRACT_BOOLEAN(do_green) ? DoGreen : 0) |
(S48_EXTRACT_BOOLEAN(do_blue) ? DoBlue : 0));
return S48_UNSPECIFIC;
}
void scx_init_colormap(void) {
S48_EXPORT_FUNCTION(scx_Create_Colormap);
S48_EXPORT_FUNCTION(scx_Copy_Colormap_And_Free);
S48_EXPORT_FUNCTION(scx_Free_Colormap);
S48_EXPORT_FUNCTION(scx_Alloc_Color);
S48_EXPORT_FUNCTION(scx_Alloc_Named_Color);
S48_EXPORT_FUNCTION(scx_Parse_Color);
S48_EXPORT_FUNCTION(scx_Create_Colormap);
S48_EXPORT_FUNCTION(scx_Alloc_Color_Cells);
S48_EXPORT_FUNCTION(scx_Store_Color);
S48_EXPORT_FUNCTION(scx_Alloc_Color_Planes);
S48_EXPORT_FUNCTION(scx_Free_Colors);
S48_EXPORT_FUNCTION(scx_Query_Colors);
S48_EXPORT_FUNCTION(scx_Lookup_Color);
S48_EXPORT_FUNCTION(scx_Parse_Color);
S48_EXPORT_FUNCTION(scx_Store_Colors);
S48_EXPORT_FUNCTION(scx_Copy_Colormap_And_Free);
S48_EXPORT_FUNCTION(scx_Store_Named_Color);
}

104
c/xlib/cursor.c
View File

@ -1,52 +1,84 @@
#include "xlib.h"
#include "scheme48.h"
/* Copyright 2001-2003 by Norbert Freudemann, David Frese */
s48_value scx_Free_Cursor(s48_value Xdisplay, s48_value Xcursor) {
XFreeCursor(SCX_EXTRACT_DISPLAY(Xdisplay),
SCX_EXTRACT_CURSOR(Xcursor));
#include "xlib.h"
s48_value scx_Create_Pixmap_Cursor(s48_value display,
s48_value src, s48_value mask,
s48_value foreground,
s48_value background,
s48_value x, s48_value y) {
XColor f, b;
Cursor xc;
scx_extract_color(foreground, &f);
scx_extract_color(background, &b);
xc = XCreatePixmapCursor(scx_extract_display(display),
scx_extract_pixmap(src),
scx_extract_pixmap(mask),
&f, &b,
s48_extract_integer(x),
s48_extract_integer(y));
return scx_enter_cursor(xc);
}
s48_value scx_Create_Glyph_Cursor(s48_value display,
s48_value src_font, s48_value mask_font,
s48_value srcc, s48_value maskc,
s48_value foreground, s48_value background) {
XColor f, b;
Cursor xc;
scx_extract_color(foreground, &f);
scx_extract_color(background, &b);
xc = XCreateGlyphCursor(scx_extract_display(display),
scx_extract_font(src_font),
scx_extract_font(mask_font),
s48_extract_integer(srcc),
s48_extract_integer(maskc),
&f, &b);
return scx_enter_cursor(xc);
}
s48_value scx_Create_Font_Cursor(s48_value display, s48_value shape) {
Cursor xc = XCreateFontCursor(scx_extract_display(display),
s48_extract_integer(shape));
return scx_enter_cursor(xc);
}
s48_value scx_Define_Cursor(s48_value display, s48_value window,
s48_value cursor) {
XDefineCursor(scx_extract_display(display), scx_extract_window(window),
scx_extract_cursor(cursor));
return S48_UNSPECIFIC;
}
s48_value scx_Create_Pixmap_Cursor(s48_value Xdisplay,
s48_value src, s48_value mask, s48_value x,
s48_value y, s48_value foreground,
s48_value background) {
Cursor xc = XCreatePixmapCursor(SCX_EXTRACT_DISPLAY(Xdisplay),
SCX_EXTRACT_PIXMAP(src),
SCX_EXTRACT_PIXMAP(mask),
SCX_EXTRACT_COLOR(foreground),
SCX_EXTRACT_COLOR(background),
s48_extract_integer(x),
s48_extract_integer(y));
return SCX_ENTER_CURSOR(xc);
s48_value scx_Undefine_Cursor(s48_value display, s48_value window) {
XUndefineCursor(scx_extract_display(display),
scx_extract_window(window));
return S48_UNSPECIFIC;
}
s48_value scx_Create_Glyph_Cursor(s48_value Xdisplay,
s48_value src, s48_value srcc,
s48_value mask, s48_value maskc,
s48_value foreground, s48_value background) {
Cursor xc = XCreateGlyphCursor(SCX_EXTRACT_DISPLAY(Xdisplay),
SCX_EXTRACT_FONT(src),
SCX_EXTRACT_FONT(mask),
s48_extract_integer(srcc),
s48_extract_integer(maskc),
SCX_EXTRACT_COLOR(foreground),
SCX_EXTRACT_COLOR(background));
return SCX_ENTER_CURSOR(xc);
s48_value scx_Recolor_Cursor(s48_value display, s48_value cursor,
s48_value foreground, s48_value background) {
XColor f, b;
scx_extract_color(foreground, &f);
scx_extract_color(background, &b);
XRecolorCursor(scx_extract_display(display),
scx_extract_cursor(cursor),
&f, &b);
return S48_UNSPECIFIC;
}
s48_value scx_Recolor_Cursor(s48_value Xdisplay, s48_value Xcursor,
s48_value f, s48_value b) {
XRecolorCursor(SCX_EXTRACT_DISPLAY(Xdisplay),
SCX_EXTRACT_CURSOR(Xcursor),
SCX_EXTRACT_COLOR(f),
SCX_EXTRACT_COLOR(b));
s48_value scx_Free_Cursor(s48_value display, s48_value cursor) {
XFreeCursor(scx_extract_display(display),
scx_extract_cursor(cursor));
return S48_UNSPECIFIC;
}
void scx_init_cursor(void) {
S48_EXPORT_FUNCTION(scx_Free_Cursor);
S48_EXPORT_FUNCTION(scx_Create_Pixmap_Cursor);
S48_EXPORT_FUNCTION(scx_Create_Glyph_Cursor);
S48_EXPORT_FUNCTION(scx_Create_Font_Cursor);
S48_EXPORT_FUNCTION(scx_Define_Cursor);
S48_EXPORT_FUNCTION(scx_Undefine_Cursor);
S48_EXPORT_FUNCTION(scx_Recolor_Cursor);
S48_EXPORT_FUNCTION(scx_Free_Cursor);
}

388
c/xlib/display.c
View File

@ -1,299 +1,147 @@
/* Copyright 2001-2003 by Norbert Freudemann, David Frese */
#include "xlib.h"
#include "scheme48.h"
#include <sys/time.h>
s48_value internal_after_function_binding = S48_FALSE;
s48_value scx_enter_screenformat(ScreenFormat* sf) {
s48_value res =
s48_make_record(s48_get_imported_binding("scx-screen-format"));
S48_DECLARE_GC_PROTECT(1);
S48_GC_PROTECT_1(res);
S48_RECORD_SET(res, 0, s48_enter_integer(sf->depth));
S48_RECORD_SET(res, 1, s48_enter_integer(sf->bits_per_pixel));
S48_RECORD_SET(res, 2, s48_enter_integer(sf->scanline_pad));
S48_GC_UNPROTECT();
return res;
}
s48_value scx_enter_screen(Screen* scr) {
s48_value s = s48_make_record(scx_screen);
S48_DECLARE_GC_PROTECT(1);
S48_GC_PROTECT_1(s);
S48_RECORD_SET(s, 0, s48_enter_integer((long)scr));
S48_RECORD_SET(s, 1, scx_enter_display(DisplayOfScreen(scr)));
S48_RECORD_SET(s, 2, scx_enter_window(RootWindowOfScreen(scr)));
S48_RECORD_SET(s, 3, s48_enter_integer(WidthOfScreen(scr)));
S48_RECORD_SET(s, 4, s48_enter_integer(HeightOfScreen(scr)));
S48_RECORD_SET(s, 5, s48_enter_integer(WidthMMOfScreen(scr)));
S48_RECORD_SET(s, 6, s48_enter_integer(HeightMMOfScreen(scr)));
S48_RECORD_SET(s, 7, S48_FALSE); // TODO depths
S48_RECORD_SET(s, 8, s48_enter_integer(DefaultDepthOfScreen(scr)));
S48_RECORD_SET(s, 9, scx_enter_visual(DefaultVisualOfScreen(scr)));
S48_RECORD_SET(s, 10, scx_enter_gc(DefaultGCOfScreen(scr)));
S48_RECORD_SET(s, 11, scx_enter_colormap(DefaultColormapOfScreen(scr)));
S48_RECORD_SET(s, 12, scx_enter_pixel(BlackPixelOfScreen(scr)));
S48_RECORD_SET(s, 13, scx_enter_pixel(WhitePixelOfScreen(scr)));
S48_RECORD_SET(s, 14, s48_enter_integer(MinCmapsOfScreen(scr)));
S48_RECORD_SET(s, 15, s48_enter_integer(MaxCmapsOfScreen(scr)));
S48_RECORD_SET(s, 16, scx_enter_backing_store(DoesBackingStore(scr)));
S48_RECORD_SET(s, 17, S48_ENTER_BOOLEAN(DoesSaveUnders(scr)));
S48_RECORD_SET(s, 18, scx_enter_event_mask(EventMaskOfScreen(scr)));
S48_GC_UNPROTECT();
return s;
}
s48_value scx_display_list = S48_NULL;
static int scx_after_function_wrapper(Display* dpy) {
s48_value display = scx_enter_display(dpy);
s48_value fun = SCX_DISPLAY_AFTER_FUNCTION(display);
s48_call_scheme(fun, 1, display);
return 0;
}
s48_value scx_enter_display(Display* dpy) {
s48_value d = scx_struct_cache_ref(dpy, scx_display_list);
if (d == S48_FALSE) {
int i;
s48_value l = S48_NULL;
S48_DECLARE_GC_PROTECT(2);
d = s48_make_record(scx_display);
S48_GC_PROTECT_2(d, l);
// have to do this first, because screens want to reference their display
scx_struct_cache_set(dpy, &scx_display_list, d);
S48_RECORD_SET(d, 0, s48_enter_integer((long)dpy));
S48_RECORD_SET(d, 1, s48_enter_integer(ConnectionNumber(dpy)));
S48_RECORD_SET(d, 2, s48_enter_integer(ProtocolVersion(dpy)));
S48_RECORD_SET(d, 3, s48_enter_integer(ProtocolRevision(dpy)));
S48_RECORD_SET(d, 4, s48_enter_string(ServerVendor(dpy)));
S48_RECORD_SET(d, 5, scx_enter_byte_order(ImageByteOrder(dpy)));
S48_RECORD_SET(d, 6, s48_enter_integer(BitmapUnit(dpy)));
S48_RECORD_SET(d, 7, scx_enter_bit_order(BitmapBitOrder(dpy)));
S48_RECORD_SET(d, 8, s48_enter_integer(BitmapPad(dpy)));
S48_RECORD_SET(d, 9, s48_enter_integer(VendorRelease(dpy)));
S48_RECORD_SET(d, 10, s48_enter_integer(QLength(dpy)));
S48_RECORD_SET(d, 11, s48_enter_string(DisplayString(dpy)));
S48_RECORD_SET(d, 12, s48_enter_integer(DefaultScreen(dpy)));
for (i = ScreenCount(dpy)-1; i >= 0; i--)
l = s48_cons(scx_enter_screen(ScreenOfDisplay(dpy, i)), l);
S48_RECORD_SET(d, 13, l);
S48_RECORD_SET(d, 14, S48_SHARED_BINDING_REF(
s48_get_imported_binding("scx-default-after-function")));
XSetAfterFunction(dpy, &scx_after_function_wrapper);
S48_GC_UNPROTECT();
}
return d;
}
// Open_Display(name) name should be a string or S48_FALSE (=> Null)
s48_value scx_Open_Display (s48_value name) {
char* cname = (char*)0;
if (!S48_FALSE_P(name))
cname = s48_extract_string(name);
return SCX_ENTER_DISPLAY(XOpenDisplay(cname));
}
// Close_Display( Xdisplay ) Xdisplay should be a pointer to the X-lib struct
// cast into a Scheme-Integer.
s48_value scx_Close_Display(s48_value Xdisplay) {
XCloseDisplay(SCX_EXTRACT_DISPLAY(Xdisplay));
return S48_UNSPECIFIC;
}
// After-Function routines
static X_After_Function(Display* d) {
s48_call_scheme(S48_SHARED_BINDING_REF(internal_after_function_binding),
1, SCX_ENTER_DISPLAY(d));
}
s48_value scx_Set_After_Function(s48_value Xdisplay, s48_value active) {
if (S48_FALSE_P(active))
(void)XSetAfterFunction(SCX_EXTRACT_DISPLAY(Xdisplay),
(int (*)())0);
else
(void)XSetAfterFunction(SCX_EXTRACT_DISPLAY(Xdisplay),
X_After_Function);
return S48_UNSPECIFIC;
}
// This function returns the file destriptor of the message-channel.
s48_value scx_Display_Message_fd(s48_value Xdisplay) {
int fd = ConnectionNumber(SCX_EXTRACT_DISPLAY(Xdisplay));
/* struct timeval timeout;
fd_set fdset;
FD_ZERO(&fdset);
FD_SET(fd, &fdset);
timeout.tv_sec = 20; // 20 seconds
timeout.tv_usec = 0;
if (select(1, &fdset, NULL, NULL, &timeout) != 0)
return S48_TRUE;
else
Display* res = XOpenDisplay(s48_extract_string(name));
if (res == NULL)
return S48_FALSE;
*/
return s48_enter_integer(fd);
else
return scx_enter_display(res);
}
// The following procedure mainly wrap a corresponding XLib macro without
// underscores...
s48_value scx_Display_Default_Root_Window(s48_value Xdisplay) {
Window wnd = DefaultRootWindow(SCX_EXTRACT_DISPLAY(Xdisplay));
return SCX_ENTER_WINDOW(wnd);
}
s48_value scx_Display_Root_Window(s48_value Xdisplay, s48_value scr_num) {
Window wnd = RootWindow(SCX_EXTRACT_DISPLAY(Xdisplay),
s48_extract_integer(scr_num));
return SCX_ENTER_WINDOW(wnd);
}
s48_value scx_Display_Default_Colormap(s48_value Xdisplay, s48_value scr) {
Display* dpy = SCX_EXTRACT_DISPLAY(Xdisplay);
Colormap cmp = DefaultColormap(dpy, s48_extract_integer(scr));
return SCX_ENTER_COLORMAP(cmp);
}
s48_value scx_Display_Default_Gcontext(s48_value Xdisplay, s48_value scr) {
Display* dpy = SCX_EXTRACT_DISPLAY(Xdisplay);
GC gc = DefaultGC(dpy, s48_extract_integer(scr));
return SCX_ENTER_GCONTEXT(gc);
}
s48_value scx_Display_Default_Depth(s48_value Xdisplay, s48_value scr) {
Display* dpy = SCX_EXTRACT_DISPLAY(Xdisplay);
int depth = DefaultDepth(dpy, s48_extract_integer(scr));
return s48_enter_fixnum(depth);
}
s48_value scx_Display_Default_Screen_Number(s48_value Xdisplay) {
return s48_enter_fixnum(DefaultScreen(SCX_EXTRACT_DISPLAY(Xdisplay)));
}
s48_value scx_Display_Default_Visual(s48_value Xdisplay, s48_value scrnum) {
return SCX_ENTER_VISUAL( DefaultVisual( SCX_EXTRACT_DISPLAY(Xdisplay),
s48_extract_integer(scrnum) ));
}
s48_value scx_Display_Cells(s48_value Xdisplay, s48_value ScrNum) {
int num = (int)s48_extract_integer(ScrNum);
return s48_enter_integer(DisplayCells(SCX_EXTRACT_DISPLAY(Xdisplay), num));
}
s48_value scx_Display_Planes(s48_value Xdisplay, s48_value ScrNum) {
int num = (int)s48_extract_integer(ScrNum);
return s48_enter_integer(DisplayPlanes(SCX_EXTRACT_DISPLAY(Xdisplay), num));
}
s48_value scx_Display_String(s48_value Xdisplay) {
char* s = DisplayString(SCX_EXTRACT_DISPLAY(Xdisplay));
return s48_enter_string(s);
}
s48_value scx_Display_Vendor(s48_value Xdisplay) {
Display* dpy = SCX_EXTRACT_DISPLAY(Xdisplay);
char* s = ServerVendor(dpy);
int i = VendorRelease(dpy);
s48_value t = S48_FALSE;
S48_DECLARE_GC_PROTECT(1);
S48_GC_PROTECT_1(t);
t = s48_enter_string(s);
t = s48_cons(t, s48_enter_integer(i));
S48_GC_UNPROTECT();
return t;
}
s48_value scx_Display_Protocol_Version(s48_value Xdisplay) {
Display* dpy = SCX_EXTRACT_DISPLAY(Xdisplay);
int maj = ProtocolVersion(dpy);
int min = ProtocolRevision(dpy);
s48_value t = S48_FALSE;
S48_DECLARE_GC_PROTECT(1);
S48_GC_PROTECT_1(t);
t = s48_enter_integer(maj);
t = s48_cons(t, s48_enter_integer(min));
S48_GC_UNPROTECT();
return t;
}
s48_value scx_Display_Screen_Count(s48_value Xdisplay) {
int cnt = ScreenCount(SCX_EXTRACT_DISPLAY(Xdisplay));
return s48_enter_fixnum(cnt);
}
s48_value scx_Display_Image_Byte_Order(s48_value Xdisplay) {
Display* dpy = SCX_EXTRACT_DISPLAY(Xdisplay);
return s48_enter_integer((unsigned long)ImageByteOrder(dpy));
}
s48_value scx_Display_Bitmap_Unit(s48_value Xdisplay) {
int bu = BitmapUnit(SCX_EXTRACT_DISPLAY(Xdisplay));
return s48_enter_integer(bu);
}
s48_value scx_Display_Bitmap_Bit_Order(s48_value Xdisplay) {
Display* dpy = SCX_EXTRACT_DISPLAY(Xdisplay);
return s48_enter_integer((unsigned long)BitmapBitOrder(dpy));
}
s48_value scx_Display_Bitmap_Pad(s48_value Xdisplay) {
int bp = BitmapPad(SCX_EXTRACT_DISPLAY(Xdisplay));
return s48_enter_integer(bp);
}
s48_value scx_Display_Width(s48_value Xdisplay, s48_value scr) {
Display* dpy = SCX_EXTRACT_DISPLAY(Xdisplay);
return s48_enter_fixnum(DisplayWidth(dpy, s48_extract_integer(scr)));
}
s48_value scx_Display_Height(s48_value Xdisplay, s48_value scr) {
Display* dpy = SCX_EXTRACT_DISPLAY(Xdisplay);
return s48_enter_fixnum(DisplayHeight(dpy, s48_extract_integer(scr)));
}
s48_value scx_Display_Width_Mm (s48_value Xdisplay, s48_value scr) {
Display* dpy = SCX_EXTRACT_DISPLAY(Xdisplay);
return s48_enter_fixnum(DisplayWidthMM(dpy, s48_extract_integer(scr)));
}
s48_value scx_Display_Height_Mm (s48_value Xdisplay, s48_value scr) {
Display* dpy = SCX_EXTRACT_DISPLAY(Xdisplay);
return s48_enter_fixnum(DisplayHeightMM(dpy, s48_extract_integer(scr)));
}
s48_value scx_Display_Motion_Buffer_Size(s48_value Xdisplay) {
int mbs = XDisplayMotionBufferSize(SCX_EXTRACT_DISPLAY(Xdisplay));
return s48_enter_integer(mbs);
}
s48_value scx_Display_Flush_Output (s48_value Xdisplay) {
XFlush (SCX_EXTRACT_DISPLAY(Xdisplay));
s48_value scx_Close_Display(s48_value display) {
XCloseDisplay(scx_extract_display(display));
return S48_UNSPECIFIC;
}
s48_value scx_Display_Wait_Output (s48_value Xdisplay, s48_value discard) {
XSync (SCX_EXTRACT_DISPLAY(Xdisplay), !S48_FALSE_P(discard));
s48_value scx_Display_Last_Request_Read(s48_value display) {
Display* d = scx_extract_display(display);
return s48_enter_integer(LastKnownRequestProcessed(d));
}
s48_value scx_Next_Request(s48_value display) {
Display* d = scx_extract_display(display);
return s48_enter_integer(NextRequest(d));
}
s48_value scx_Display_Flush(s48_value display) {
XFlush(scx_extract_display(display));
return S48_UNSPECIFIC;
}
s48_value scx_No_Op (s48_value Xdisplay) {
XNoOp(SCX_EXTRACT_DISPLAY(Xdisplay));
s48_value scx_Display_Sync(s48_value display, s48_value discard) {
XSync(scx_extract_display(display), S48_EXTRACT_BOOLEAN(discard));
return S48_UNSPECIFIC;
}
s48_value scx_List_Depths (s48_value Xdisplay, s48_value scr) {
int i, num;
int* p;
s48_value ret = S48_FALSE;
S48_DECLARE_GC_PROTECT(1);
p = XListDepths(SCX_EXTRACT_DISPLAY(Xdisplay),
s48_extract_integer(scr), &num);
if (p) {
S48_GC_PROTECT_1(ret);
ret = s48_make_vector(num, S48_NULL);
for (i = 0; i < num; i++)
S48_VECTOR_SET(ret, i, s48_enter_fixnum(p[i]));
XFree((char *)p);
}
S48_GC_UNPROTECT();
return ret;
s48_value scx_No_Op(s48_value display) {
XNoOp(scx_extract_display(display));
return S48_UNSPECIFIC;
}
s48_value scx_List_Pixmap_Formats (s48_value Xdisplay) {
int num, i;
XPixmapFormatValues* p;
s48_value ret = S48_FALSE, t = S48_FALSE;
S48_DECLARE_GC_PROTECT(2);
p = XListPixmapFormats(SCX_EXTRACT_DISPLAY(Xdisplay), &num);
if (p) {
S48_GC_PROTECT_2(ret, t);
ret = s48_make_vector (num, S48_FALSE);
for (i = 0; i < num; i++) {
t = s48_cons(s48_enter_fixnum(p[i].depth),
s48_cons(s48_enter_fixnum(p[i].bits_per_pixel),
s48_cons(s48_enter_fixnum(p[i].scanline_pad),
S48_NULL)));
S48_VECTOR_SET(ret, i, t);
}
XFree ((char *)p);
}
S48_GC_UNPROTECT();
return ret;
}
s48_value scx_Display_Select_Input(s48_value Xdisplay, s48_value Xwindow,
s48_value scx_Display_Select_Input(s48_value display, s48_value window,
s48_value event_mask) {
XSelectInput(SCX_EXTRACT_DISPLAY(Xdisplay),
SCX_EXTRACT_WINDOW(Xwindow),
s48_extract_integer(event_mask));
XSelectInput(scx_extract_display(display),
scx_extract_window(window),
scx_extract_event_mask(event_mask));
return S48_UNSPECIFIC;
}
void scx_init_display(void) {
S48_GC_PROTECT_GLOBAL(internal_after_function_binding);
internal_after_function_binding =
s48_get_imported_binding("internal-after-function");
S48_GC_PROTECT_GLOBAL(scx_display_list);
S48_EXPORT_FUNCTION(scx_Set_After_Function);
S48_EXPORT_FUNCTION(scx_Open_Display);
S48_EXPORT_FUNCTION(scx_Close_Display);
S48_EXPORT_FUNCTION(scx_Display_Message_fd);
S48_EXPORT_FUNCTION(scx_Display_Default_Root_Window);
S48_EXPORT_FUNCTION(scx_Display_Root_Window);
S48_EXPORT_FUNCTION(scx_Display_Default_Colormap);
S48_EXPORT_FUNCTION(scx_Display_Default_Gcontext);
S48_EXPORT_FUNCTION(scx_Display_Default_Depth);
S48_EXPORT_FUNCTION(scx_Display_Default_Screen_Number);
S48_EXPORT_FUNCTION(scx_Display_Default_Visual);
S48_EXPORT_FUNCTION(scx_Display_Cells);
S48_EXPORT_FUNCTION(scx_Display_Planes);
S48_EXPORT_FUNCTION(scx_Display_String);
S48_EXPORT_FUNCTION(scx_Display_Vendor);
S48_EXPORT_FUNCTION(scx_Display_Protocol_Version);
S48_EXPORT_FUNCTION(scx_Display_Screen_Count);
S48_EXPORT_FUNCTION(scx_Display_Image_Byte_Order);
S48_EXPORT_FUNCTION(scx_Display_Bitmap_Unit);
S48_EXPORT_FUNCTION(scx_Display_Bitmap_Bit_Order);
S48_EXPORT_FUNCTION(scx_Display_Bitmap_Pad);
S48_EXPORT_FUNCTION(scx_Display_Width);
S48_EXPORT_FUNCTION(scx_Display_Height);
S48_EXPORT_FUNCTION(scx_Display_Width_Mm);
S48_EXPORT_FUNCTION(scx_Display_Height_Mm);
S48_EXPORT_FUNCTION(scx_Display_Motion_Buffer_Size);
S48_EXPORT_FUNCTION(scx_Display_Flush_Output);
S48_EXPORT_FUNCTION(scx_Display_Wait_Output);
S48_EXPORT_FUNCTION(scx_Display_Last_Request_Read);
S48_EXPORT_FUNCTION(scx_Next_Request);
S48_EXPORT_FUNCTION(scx_Display_Flush);
S48_EXPORT_FUNCTION(scx_Display_Sync);
S48_EXPORT_FUNCTION(scx_No_Op);
S48_EXPORT_FUNCTION(scx_List_Depths);
S48_EXPORT_FUNCTION(scx_List_Pixmap_Formats);
S48_EXPORT_FUNCTION(scx_Display_Select_Input);
}

150
c/xlib/error.c
View File

@ -1,7 +1,107 @@
#include "xlib.h"
#include <stdio.h>
s48_value internal_x_error_handler_binding = S48_FALSE;
s48_value scx_enter_error_code(int code) {
s48_value v =
S48_SHARED_BINDING_REF(s48_get_imported_binding("scx-error-codes"));
if (code < S48_VECTOR_LENGTH(v))
return S48_VECTOR_REF(v, code);
else
return s48_enter_integer(code); // Extension Errors
}
s48_value scx_extract_error_code(s48_value code) {
if (S48_RECORD_P(code)) {
s48_value t =
S48_SHARED_BINDING_REF(s48_get_imported_binding("scx-error-code"));
return s48_extract_integer(s48_checked_record_ref(code, 1, t));
} else
return s48_extract_integer(code);
}
s48_value scx_enter_x_error(XErrorEvent* xe) {
s48_value e = s48_make_record(s48_get_imported_binding("scx-x-error"));
char s[1024];
S48_DECLARE_GC_PROTECT(1);
S48_GC_PROTECT_1(e);
S48_RECORD_SET(e, 0, scx_enter_display(xe->display));
S48_RECORD_SET(e, 1, s48_enter_integer(xe->serial));
S48_RECORD_SET(e, 2, scx_enter_error_code(xe->error_code));
S48_RECORD_SET(e, 3, s48_enter_integer(xe->request_code));
S48_RECORD_SET(e, 4, s48_enter_integer(xe->minor_code));
S48_RECORD_SET(e, 5, s48_enter_integer(xe->resourceid));
XGetErrorText(xe->display, xe->error_code, s, 1023);
S48_RECORD_SET(e, 6, s48_enter_string(s));
S48_GC_UNPROTECT();
return e;
}
void scx_extract_x_error(s48_value e, XErrorEvent* xe) {
s48_check_record_type(e, s48_get_imported_binding("scx-x-error"));
xe->type = 1;
xe->display = scx_extract_display(S48_RECORD_REF(e, 0));
xe->serial = s48_extract_integer(S48_RECORD_REF(e, 1));
xe->error_code = scx_extract_error_code(S48_RECORD_REF(e, 2));
xe->request_code = s48_extract_integer(S48_RECORD_REF(e, 3));
xe->minor_code = s48_extract_integer(S48_RECORD_REF(e, 4));
xe->resourceid = s48_extract_integer(S48_RECORD_REF(e, 5));
}
static s48_value internal_error_handler_binding = S48_FALSE;
static int error_handler_wrapper(Display* dpy, XErrorEvent* e) {
s48_call_scheme(internal_error_handler_binding, 2,
scx_enter_display(dpy),
scx_enter_x_error(e));
return 0;
}
s48_value scx_Set_Error_Handler(s48_value fun) {
s48_value maybe_previous = internal_error_handler_binding;
int (*previous)() = NULL;
if (S48_POINTER_P(fun))
previous = XSetErrorHandler(S48_EXTRACT_POINTER(fun));
else if (S48_CLOSURE_P(fun)) {
previous = XSetErrorHandler(&error_handler_wrapper);
internal_error_handler_binding = fun;
} // TODO else error
if (previous == &error_handler_wrapper)
return maybe_previous;
else
return S48_ENTER_POINTER(previous);
}
s48_value scx_Call_C_Error_Handler(s48_value pointer, s48_value display,
s48_value event) {
int (*procedure)() = S48_EXTRACT_POINTER(pointer);
XErrorEvent ev; int result;
scx_extract_x_error(event, &ev);
result = procedure(scx_extract_display(display), &ev);
return s48_enter_integer(result);
}
s48_value scx_Get_Error_Text(s48_value display, s48_value code) {
char buf[1024];
XGetErrorText(scx_extract_display(display), scx_extract_error_code(code),
buf, 1024);
buf[1023] = 0;
return s48_enter_string(buf);
}
s48_value scx_Get_Error_Database_Text(s48_value display, s48_value name,
s48_value message, s48_value def) {
char buf[1024];
XGetErrorDatabaseText(scx_extract_display(display),
s48_extract_string(name),
s48_extract_string(message),
s48_extract_string(def),
buf, 1024);
buf[1023] = 0;
return s48_enter_string(buf);
}
s48_value internal_x_fatal_error_handler_binding = S48_FALSE;
/* Default error handlers of the Xlib */
@ -9,11 +109,9 @@ extern int _XDefaultIOError();
extern int _XDefaultError();
static X_Fatal_Error (Display* d) {
//Reset_IO (0); //??
// call the scheme-func internal-x-fatal-error-handler, which does the rest.
s48_call_scheme(S48_SHARED_BINDING_REF(internal_x_fatal_error_handler_binding),
1, SCX_ENTER_DISPLAY(d));
1, scx_enter_display(d));
// In case the scheme error handler does not exit (or none exists):
_XDefaultIOError (d);
@ -22,43 +120,19 @@ static X_Fatal_Error (Display* d) {
/*NOTREACHED*/
}
static X_Error(Display* d, XErrorEvent* ep) {
s48_value args = s48_make_vector(7, S48_FALSE);
s48_value a = S48_FALSE, r = S48_FALSE;
int max_s = 1024;
char s[max_s];
S48_DECLARE_GC_PROTECT(2);
//Reset_IO (0); //??
S48_GC_PROTECT_2(args, a);
S48_VECTOR_SET(args, 0, SCX_ENTER_DISPLAY(d));
S48_VECTOR_SET(args, 1, s48_enter_integer(ep->serial));
S48_VECTOR_SET(args, 2, s48_enter_integer(ep->error_code));
S48_VECTOR_SET(args, 3, s48_enter_integer(ep->request_code));
S48_VECTOR_SET(args, 4, s48_enter_integer(ep->minor_code));
S48_VECTOR_SET(args, 5, s48_enter_integer((unsigned long)ep->resourceid));
XGetErrorText(d, ep->error_code, s, max_s);
S48_VECTOR_SET(args, 6, s48_enter_string(s));
r = s48_call_scheme(S48_SHARED_BINDING_REF(internal_x_error_handler_binding),
1, args);
S48_GC_UNPROTECT();
if S48_FALSE_P( r )
_XDefaultError (d, ep);
}
void scx_init_error() {
S48_GC_PROTECT_GLOBAL(internal_x_error_handler_binding);
S48_GC_PROTECT_GLOBAL(internal_error_handler_binding);
S48_GC_PROTECT_GLOBAL(internal_x_fatal_error_handler_binding);
internal_x_error_handler_binding =
s48_get_imported_binding("internal-x-error-handler");
S48_EXPORT_FUNCTION(scx_Set_Error_Handler);
S48_EXPORT_FUNCTION(scx_Call_C_Error_Handler);
S48_EXPORT_FUNCTION(scx_Get_Error_Text);
S48_EXPORT_FUNCTION(scx_Get_Error_Database_Text);
//S48_EXPORT_FUNCTION(scx_Set_IO_Error_Handler); TODO!
internal_x_fatal_error_handler_binding =
s48_get_imported_binding("internal-x-fatal-error-handler");
(void)XSetIOErrorHandler (X_Fatal_Error);
(void)XSetErrorHandler (X_Error);
(void)XSetIOErrorHandler(X_Fatal_Error);
//(void)XSetErrorHandler(X_Error);
}

774
c/xlib/event-types.c Normal file
View File

@ -0,0 +1,774 @@
/* Copyright 2001-2003 by Norbert Freudemann, David Frese */
#include "xlib.h"
#define EENTER(i, n, f) S48_RECORD_SET(e, i, f(xe->n))
#define EENTER_START(stype) \
s48_value e = s48_make_record(s48_get_imported_binding(stype)); \
S48_DECLARE_GC_PROTECT(1); \
S48_GC_PROTECT_1(e); \
EENTER(0, type, scx_enter_event_type); \
EENTER(1, serial, s48_enter_integer); \
EENTER(2, send_event, S48_ENTER_BOOLEAN); \
EENTER(3, display, scx_enter_display);
#define EENTER_END() \
return e
s48_value scx_enter_key_event(XKeyEvent* xe) {
EENTER_START("scx-key-event");
EENTER(4, window, scx_enter_window);
EENTER(5, root, scx_enter_window);
EENTER(6, subwindow, scx_enter_window);
EENTER(7, time, scx_enter_time);
EENTER(8, x, s48_enter_integer);
EENTER(9, y, s48_enter_integer);
EENTER(10, x_root, s48_enter_integer);
EENTER(11, y_root, s48_enter_integer);
EENTER(12, state, scx_enter_state);
EENTER(13, keycode, scx_enter_keycode);
EENTER(14, same_screen, S48_ENTER_BOOLEAN);
EENTER_END();
}
s48_value scx_enter_button_event(XButtonEvent* xe) {
EENTER_START("scx-button-event");
EENTER(4, window, scx_enter_window);
EENTER(5, root, scx_enter_window);
EENTER(6, subwindow, scx_enter_window);
EENTER(7, time, scx_enter_time);
EENTER(8, x, s48_enter_integer);
EENTER(9, y, s48_enter_integer);
EENTER(10, x_root, s48_enter_integer);
EENTER(11, y_root, s48_enter_integer);
EENTER(12, state, scx_enter_state);
EENTER(13, button, scx_enter_button);
EENTER(14, same_screen, S48_ENTER_BOOLEAN);
EENTER_END();
}
s48_value scx_enter_motion_event(XMotionEvent* xe) {
EENTER_START("scx-motion-event");
EENTER(4, window, scx_enter_window);
EENTER(5, root, scx_enter_window);
EENTER(6, subwindow, scx_enter_window);
EENTER(7, time, scx_enter_time);
EENTER(8, x, s48_enter_integer);
EENTER(9, y, s48_enter_integer);
EENTER(10, x_root, s48_enter_integer);
EENTER(11, y_root, s48_enter_integer);
EENTER(12, state, scx_enter_state);
EENTER(13, is_hint, S48_ENTER_BOOLEAN);
EENTER(14, same_screen, S48_ENTER_BOOLEAN);
EENTER_END();
}
s48_value scx_enter_crossing_event(XCrossingEvent* xe) {
EENTER_START("scx-crossing-event");
EENTER(4, window, scx_enter_window);
EENTER(5, root, scx_enter_window);
EENTER(6, subwindow, scx_enter_window);
EENTER(7, time, scx_enter_time);
EENTER(8, x, s48_enter_integer);
EENTER(9, y, s48_enter_integer);
EENTER(10, x_root, s48_enter_integer);
EENTER(11, y_root, s48_enter_integer);
EENTER(12, mode, scx_enter_notify_mode);
EENTER(13, detail, scx_enter_notify_detail);
EENTER(14, same_screen, S48_ENTER_BOOLEAN);
EENTER(15, focus, S48_ENTER_BOOLEAN);
EENTER(16, state, scx_enter_state);
EENTER_END();
}
s48_value scx_enter_focus_change_event(XFocusChangeEvent* xe) {
EENTER_START("scx-focus-change-event");
EENTER(4, window, scx_enter_window);
EENTER(5, mode, scx_enter_notify_mode);
EENTER(6, detail, scx_enter_notify_detail);
EENTER_END();
}
s48_value scx_enter_expose_event(XExposeEvent* xe) {
EENTER_START("scx-expose-event");
EENTER(4, window, scx_enter_window);
EENTER(5, x, s48_enter_integer);
EENTER(6, y, s48_enter_integer);
EENTER(7, width, s48_enter_integer);
EENTER(8, height, s48_enter_integer);
EENTER(9, count, s48_enter_integer);
EENTER_END();
}
s48_value scx_enter_graphics_expose_event(XGraphicsExposeEvent* xe) {
EENTER_START("scx-graphics-expose-event");
EENTER(4, drawable, scx_enter_drawable);
EENTER(5, x, s48_enter_integer);
EENTER(6, y, s48_enter_integer);
EENTER(7, width, s48_enter_integer);
EENTER(8, height, s48_enter_integer);
EENTER(9, count, s48_enter_integer);
EENTER(10, major_code, s48_enter_integer);
EENTER(11, minor_code, s48_enter_integer);
EENTER_END();
}
s48_value scx_enter_no_expose_event(XNoExposeEvent* xe) {
EENTER_START("scx-no-expose-event");
EENTER(4, drawable, scx_enter_drawable);
EENTER(5, major_code, s48_enter_integer);
EENTER(6, minor_code, s48_enter_integer);
EENTER_END();
}
s48_value scx_enter_visibility_event(XVisibilityEvent* xe) {
EENTER_START("scx-visibility-event");
EENTER(4, window, scx_enter_window);
EENTER(5, state, scx_enter_visibility_state);
EENTER_END();
}
s48_value scx_enter_create_window_event(XCreateWindowEvent* xe) {
EENTER_START("scx-create-window-event");
EENTER(4, parent, scx_enter_window);
EENTER(5, window, scx_enter_window);
EENTER(6, x, s48_enter_integer);
EENTER(7, y, s48_enter_integer);
EENTER(8, width, s48_enter_integer);
EENTER(9, height, s48_enter_integer);
EENTER(10, border_width, s48_enter_integer);
EENTER(11, override_redirect, S48_ENTER_BOOLEAN);
EENTER_END();
}
s48_value scx_enter_destroy_window_event(XDestroyWindowEvent* xe) {
EENTER_START("scx-destroy-window-event");
EENTER(4, window, scx_enter_window);
EENTER_END();
}
s48_value scx_enter_unmap_event(XUnmapEvent* xe) {
EENTER_START("scx-unmap-event");
EENTER(4, window, scx_enter_window);
EENTER(5, from_configure, S48_ENTER_BOOLEAN);
EENTER_END();
}
s48_value scx_enter_map_event(XMapEvent* xe) {
EENTER_START("scx-map-event");
EENTER(4, window, scx_enter_window);
EENTER(5, override_redirect, S48_ENTER_BOOLEAN);
EENTER_END();
}
s48_value scx_enter_map_request_event(XMapRequestEvent* xe) {
EENTER_START("scx-map-request-event");
EENTER(4, parent, scx_enter_window);
EENTER(5, window, scx_enter_window);
EENTER_END();
}
s48_value scx_enter_reparent_event(XReparentEvent* xe) {
EENTER_START("scx-reparent-event");
EENTER(4, event, scx_enter_window);
EENTER(5, window, scx_enter_window);
EENTER(6, parent, scx_enter_window);
EENTER(7, x, s48_enter_integer);
EENTER(8, y, s48_enter_integer);
EENTER(9, override_redirect, S48_ENTER_BOOLEAN);
EENTER_END();
}
s48_value scx_enter_configure_event(XConfigureEvent* xe) {
EENTER_START("scx-configure-event");
EENTER(4, event, scx_enter_window);
EENTER(5, window, scx_enter_window);
EENTER(6, x, s48_enter_integer);
EENTER(7, y, s48_enter_integer);
EENTER(8, width, s48_enter_integer);
EENTER(9, height, s48_enter_integer);
EENTER(10, border_width, s48_enter_integer);
EENTER(11, above, scx_enter_window);
EENTER(12, override_redirect, S48_ENTER_BOOLEAN);
EENTER_END();
}
s48_value scx_enter_gravity_event(XGravityEvent* xe) {
EENTER_START("scx-gravity-event");
EENTER(4, event, scx_enter_window);
EENTER(5, window, scx_enter_window);
EENTER(6, x, s48_enter_integer);
EENTER(7, y, s48_enter_integer);
EENTER_END();
}
s48_value scx_enter_resize_request_event(XResizeRequestEvent* xe) {
EENTER_START("scx-resize-request-event");
EENTER(4, window, scx_enter_window);
EENTER(5, width, s48_enter_integer);
EENTER(6, height, s48_enter_integer);
EENTER_END();
}
s48_value scx_enter_configure_request_event(XConfigureRequestEvent* xe) {
XWindowChanges WC;
EENTER_START("scx-configure-request-event");
EENTER(4, parent, scx_enter_window);
EENTER(5, window, scx_enter_window);
WC.x = xe->x;
WC.y = xe->y;
WC.width = xe->width;
WC.height = xe->height;
WC.border_width = xe->border_width;
WC.sibling = xe->above;
WC.stack_mode = xe->detail;
S48_RECORD_SET(e, 6, scx_enter_window_changes(&WC, xe->value_mask));
EENTER_END();
}
s48_value scx_enter_circulate_event(XCirculateEvent* xe) {
EENTER_START("scx-circulate-event");
EENTER(4, event, scx_enter_window);
EENTER(5, window, scx_enter_window);
EENTER(6, place, scx_enter_place);
EENTER_END();
}
s48_value scx_enter_circulate_request_event(XCirculateRequestEvent* xe) {
EENTER_START("scx-circulate-request-event");
EENTER(4, parent, scx_enter_window);
EENTER(5, window, scx_enter_window);
EENTER(6, place, scx_enter_place);
EENTER_END();
}
s48_value scx_enter_property_event(XPropertyEvent* xe) {
EENTER_START("scx-property-event");
EENTER(4, window, scx_enter_window);
EENTER(5, atom, scx_enter_atom);
EENTER(6, time, scx_enter_time);
EENTER(7, state, scx_enter_property_state);
EENTER_END();
}
s48_value scx_enter_selection_clear_event(XSelectionClearEvent* xe) {
EENTER_START("scx-selection-clear-event");
EENTER(4, window, scx_enter_window);
EENTER(5, selection, scx_enter_atom);
EENTER(6, time, scx_enter_time);
EENTER_END();
}
s48_value scx_enter_selection_request_event(XSelectionRequestEvent* xe) {
EENTER_START("scx-selection-request-event");
EENTER(4, owner, scx_enter_window);
EENTER(5, requestor, scx_enter_window);
EENTER(6, selection, scx_enter_atom);
EENTER(7, target, scx_enter_atom);
EENTER(8, property, scx_enter_atom);
EENTER(9, time, scx_enter_time);
EENTER_END();
}
s48_value scx_enter_selection_event(XSelectionEvent* xe) {
EENTER_START("scx-selection-event");
EENTER(4, requestor, scx_enter_window);
EENTER(5, selection, scx_enter_atom);
EENTER(6, target, scx_enter_atom);
EENTER(7, property, scx_enter_atom);
EENTER(8, time, scx_enter_time);
EENTER_END();
}
s48_value scx_enter_colormap_event(XColormapEvent* xe) {
EENTER_START("scx-colormap-event");
EENTER(4, window, scx_enter_window);
EENTER(5, colormap, scx_enter_colormap);
EENTER(6, new, S48_ENTER_BOOLEAN);
EENTER(7, state, scx_enter_colormap_state);
EENTER_END();
}
s48_value scx_enter_client_message_event(XClientMessageEvent* xe) {
EENTER_START("scx-client-message-event");
EENTER(4, window, scx_enter_window);
S48_RECORD_SET(e, 5, scx_enter_property(xe->message_type,
xe->format,
xe->data.b,
(20 / (xe->format >> 3))));
EENTER_END();
}
s48_value scx_enter_mapping_event(XMappingEvent* xe) {
EENTER_START("scx-mapping-event");
EENTER(4, window, scx_enter_window);
EENTER(5, request, scx_enter_mapping_request);
EENTER(6, first_keycode, scx_enter_keycode);
EENTER(7, count, s48_enter_integer);
EENTER_END();
}
s48_value scx_enter_keymap_event(XKeymapEvent* xe) {
s48_value temp; int i;
EENTER_START("scx-keymap-event");
temp = s48_make_vector(32*8, s48_enter_fixnum(0));
for (i = 0; i < 32; i++) {
int j; char b = xe->key_vector[i];
for (j = 0; j < 8; j++)
S48_VECTOR_SET(temp, i*8 + j, s48_enter_fixnum((b & (1 << j)) ? 1 : 0));
}
S48_RECORD_SET(e, 4, temp);
EENTER_END();
}
s48_value scx_enter_event(XEvent* e) {
switch (e->type) {
case KeyPress : case KeyRelease :
return scx_enter_key_event((XKeyEvent*)e);
case ButtonPress : case ButtonRelease :
return scx_enter_button_event((XButtonEvent*)e);
case MotionNotify :
return scx_enter_motion_event((XMotionEvent*)e);
case EnterNotify : case LeaveNotify :
return scx_enter_crossing_event((XCrossingEvent*)e);
case FocusIn : case FocusOut :
return scx_enter_focus_change_event((XFocusChangeEvent*)e);
case KeymapNotify :
return scx_enter_keymap_event((XKeymapEvent*)e);
case Expose :
return scx_enter_expose_event((XExposeEvent*)e);
case GraphicsExpose :
return scx_enter_graphics_expose_event((XGraphicsExposeEvent*)e);
case NoExpose :
return scx_enter_no_expose_event((XNoExposeEvent*)e);
case VisibilityNotify :
return scx_enter_visibility_event((XVisibilityEvent*)e);
case CreateNotify :
return scx_enter_create_window_event((XCreateWindowEvent*)e);
case DestroyNotify :
return scx_enter_destroy_window_event((XDestroyWindowEvent*)e);
case UnmapNotify :
return scx_enter_unmap_event((XUnmapEvent*)e);
case MapNotify :
return scx_enter_map_event((XMapEvent*)e);
case MapRequest :
return scx_enter_map_request_event((XMapRequestEvent*)e);
case ReparentNotify :
return scx_enter_reparent_event((XReparentEvent*)e);
case ConfigureNotify :
return scx_enter_configure_event((XConfigureEvent*)e);
case ConfigureRequest :
return scx_enter_configure_request_event((XConfigureRequestEvent*)e);
case GravityNotify :
return scx_enter_gravity_event((XGravityEvent*)e);
case ResizeRequest :
return scx_enter_resize_request_event((XResizeRequestEvent*)e);
case CirculateRequest :
return scx_enter_circulate_request_event((XCirculateRequestEvent*)e);
case PropertyNotify :
return scx_enter_property_event((XPropertyEvent*)e);
case SelectionClear :
return scx_enter_selection_clear_event((XSelectionClearEvent*)e);
case SelectionRequest :
return scx_enter_selection_request_event((XSelectionRequestEvent*)e);
case SelectionNotify :
return scx_enter_selection_event((XSelectionEvent*)e);
case ColormapNotify :
return scx_enter_colormap_event((XColormapEvent*)e);
case ClientMessage :
return scx_enter_client_message_event((XClientMessageEvent*)e);
case MappingNotify :
return scx_enter_mapping_event((XMappingEvent*)e);
default: return S48_FALSE;
} // switch end
}
// *** extraction ****************************************************
#define EEXTRACT(i, name, f) xe->name = f(S48_RECORD_REF(e, i))
#define EEXTRACT_START(stype) \
s48_check_record_type(e, s48_get_imported_binding(stype)); \
EEXTRACT(0, type, scx_extract_event_type); \
EEXTRACT(1, serial, s48_extract_integer); \
EEXTRACT(2, send_event, S48_EXTRACT_BOOLEAN); \
EEXTRACT(3, display, scx_extract_display);
#define EEXTRACT_END()
void scx_extract_key_event(s48_value e, XKeyEvent* xe) {
EEXTRACT_START("scx-key-event");
EEXTRACT(4, window, scx_extract_window);
EEXTRACT(5, root, scx_extract_window);
EEXTRACT(6, subwindow, scx_extract_window);
EEXTRACT(7, time, scx_extract_time);
EEXTRACT(8, x, s48_extract_integer);
EEXTRACT(9, y, s48_extract_integer);
EEXTRACT(10, x_root, s48_extract_integer);
EEXTRACT(11, y_root, s48_extract_integer);
EEXTRACT(12, state, scx_extract_state);
EEXTRACT(13, keycode, scx_extract_keycode);
EEXTRACT(14, same_screen, S48_EXTRACT_BOOLEAN);
EEXTRACT_END();
}
void scx_extract_button_event(s48_value e, XButtonEvent* xe) {
EEXTRACT_START("scx-button-event");
EEXTRACT(4, window, scx_extract_window);
EEXTRACT(5, root, scx_extract_window);
EEXTRACT(6, subwindow, scx_extract_window);
EEXTRACT(7, time, scx_extract_time);
EEXTRACT(8, x, s48_extract_integer);
EEXTRACT(9, y, s48_extract_integer);
EEXTRACT(10, x_root, s48_extract_integer);
EEXTRACT(11, y_root, s48_extract_integer);
EEXTRACT(12, state, scx_extract_state);
EEXTRACT(13, button, scx_extract_button);
EEXTRACT(14, same_screen, S48_EXTRACT_BOOLEAN);
EEXTRACT_END();
}
void scx_extract_motion_event(s48_value e, XMotionEvent* xe) {
EEXTRACT_START("scx-motion-event");
EEXTRACT(4, window, scx_extract_window);
EEXTRACT(5, root, scx_extract_window);
EEXTRACT(6, subwindow, scx_extract_window);
EEXTRACT(7, time, scx_extract_time);
EEXTRACT(8, x, s48_extract_integer);
EEXTRACT(9, y, s48_extract_integer);
EEXTRACT(10, x_root, s48_extract_integer);
EEXTRACT(11, y_root, s48_extract_integer);
EEXTRACT(12, state, scx_extract_state);
EEXTRACT(13, is_hint, S48_EXTRACT_BOOLEAN);
EEXTRACT(14, same_screen, S48_EXTRACT_BOOLEAN);
EEXTRACT_END();
}
void scx_extract_crossing_event(s48_value e, XCrossingEvent* xe) {
EEXTRACT_START("scx-crossing-event");
EEXTRACT(4, window, scx_extract_window);
EEXTRACT(5, root, scx_extract_window);
EEXTRACT(6, subwindow, scx_extract_window);
EEXTRACT(7, time, scx_extract_time);
EEXTRACT(8, x, s48_extract_integer);
EEXTRACT(9, y, s48_extract_integer);
EEXTRACT(10, x_root, s48_extract_integer);
EEXTRACT(11, y_root, s48_extract_integer);
EEXTRACT(12, mode, scx_extract_notify_mode);
EEXTRACT(13, detail, scx_extract_notify_detail);
EEXTRACT(14, same_screen, S48_EXTRACT_BOOLEAN);
EEXTRACT(15, focus, S48_EXTRACT_BOOLEAN);
EEXTRACT(16, state, scx_extract_state);
EEXTRACT_END();
}
void scx_extract_focus_change_event(s48_value e, XFocusChangeEvent* xe) {
EEXTRACT_START("scx-focus-change-event");
EEXTRACT(4, window, scx_extract_window);
EEXTRACT(5, mode, scx_extract_notify_mode);
EEXTRACT(6, detail, scx_extract_notify_detail);
EEXTRACT_END();
}
void scx_extract_expose_event(s48_value e, XExposeEvent* xe) {
EEXTRACT_START("scx-expose-event");
EEXTRACT(4, window, scx_extract_window);
EEXTRACT(5, x, s48_extract_integer);
EEXTRACT(6, y, s48_extract_integer);
EEXTRACT(7, width, s48_extract_integer);
EEXTRACT(8, height, s48_extract_integer);
EEXTRACT(9, count, s48_extract_integer);
EEXTRACT_END();
}
void scx_extract_graphics_expose_event(s48_value e, XGraphicsExposeEvent* xe) {
EEXTRACT_START("scx-graphics-expose-event");
EEXTRACT(4, drawable, scx_extract_drawable);
EEXTRACT(5, x, s48_extract_integer);
EEXTRACT(6, y, s48_extract_integer);
EEXTRACT(7, width, s48_extract_integer);
EEXTRACT(8, height, s48_extract_integer);
EEXTRACT(9, count, s48_extract_integer);
EEXTRACT(10, major_code, s48_extract_integer);
EEXTRACT(11, minor_code, s48_extract_integer);
EEXTRACT_END();
}
void scx_extract_no_expose_event(s48_value e, XNoExposeEvent* xe) {
EEXTRACT_START("scx-no-expose-event");
EEXTRACT(4, drawable, scx_extract_drawable);
EEXTRACT(5, major_code, s48_extract_integer);
EEXTRACT(6, minor_code, s48_extract_integer);
EEXTRACT_END();
}
void scx_extract_visibility_event(s48_value e, XVisibilityEvent* xe) {
EEXTRACT_START("scx-visibility-event");
EEXTRACT(4, window, scx_extract_window);
EEXTRACT(5, state, scx_extract_visibility_state);
EEXTRACT_END();
}
void scx_extract_create_window_event(s48_value e, XCreateWindowEvent* xe) {
EEXTRACT_START("scx-create-window-event");
EEXTRACT(4, parent, scx_extract_window);
EEXTRACT(5, window, scx_extract_window);
EEXTRACT(6, x, s48_extract_integer);
EEXTRACT(7, y, s48_extract_integer);
EEXTRACT(8, width, s48_extract_integer);
EEXTRACT(9, height, s48_extract_integer);
EEXTRACT(10, border_width, s48_extract_integer);
EEXTRACT(11, override_redirect, S48_EXTRACT_BOOLEAN);
EEXTRACT_END();
}
void scx_extract_destroy_window_event(s48_value e, XDestroyWindowEvent* xe) {
EEXTRACT_START("scx-destroy-window-event");
EEXTRACT(4, window, scx_extract_window);
EEXTRACT_END();
}
void scx_extract_unmap_event(s48_value e, XUnmapEvent* xe) {
EEXTRACT_START("scx-unmap-event");
EEXTRACT(4, window, scx_extract_window);
EEXTRACT(5, from_configure, S48_EXTRACT_BOOLEAN);
EEXTRACT_END();
}
void scx_extract_map_event(s48_value e, XMapEvent* xe) {
EEXTRACT_START("scx-map-event");
EEXTRACT(4, window, scx_extract_window);
EEXTRACT(5, override_redirect, S48_EXTRACT_BOOLEAN);
EEXTRACT_END();
}
void scx_extract_map_request_event(s48_value e, XMapRequestEvent* xe) {
EEXTRACT_START("scx-map-request-event");
EEXTRACT(4, parent, scx_extract_window);
EEXTRACT(5, window, scx_extract_window);
EEXTRACT_END();
}
void scx_extract_reparent_event(s48_value e, XReparentEvent* xe) {
EEXTRACT_START("scx-reparent-event");
EEXTRACT(4, event, scx_extract_window);
EEXTRACT(5, window, scx_extract_window);
EEXTRACT(6, parent, scx_extract_window);
EEXTRACT(7, x, s48_extract_integer);
EEXTRACT(8, y, s48_extract_integer);
EEXTRACT(9, override_redirect, S48_EXTRACT_BOOLEAN);
EEXTRACT_END();
}
void scx_extract_configure_event(s48_value e, XConfigureEvent* xe) {
EEXTRACT_START("scx-configure-event");
EEXTRACT(4, event, scx_extract_window);
EEXTRACT(5, window, scx_extract_window);
EEXTRACT(6, x, s48_extract_integer);
EEXTRACT(7, y, s48_extract_integer);
EEXTRACT(8, width, s48_extract_integer);
EEXTRACT(9, height, s48_extract_integer);
EEXTRACT(10, border_width, s48_extract_integer);
EEXTRACT(11, above, scx_extract_window);
EEXTRACT(12, override_redirect, S48_EXTRACT_BOOLEAN);
EEXTRACT_END();
}
void scx_extract_gravity_event(s48_value e, XGravityEvent* xe) {
EEXTRACT_START("scx-gravity-event");
EEXTRACT(4, event, scx_extract_window);
EEXTRACT(5, window, scx_extract_window);
EEXTRACT(6, x, s48_extract_integer);
EEXTRACT(7, y, s48_extract_integer);
EEXTRACT_END();
}
void scx_extract_resize_request_event(s48_value e, XResizeRequestEvent* xe) {
EEXTRACT_START("scx-resize-request-event");
EEXTRACT(4, window, scx_extract_window);
EEXTRACT(5, width, s48_extract_integer);
EEXTRACT(6, height, s48_extract_integer);
EEXTRACT_END();
}
void scx_extract_configure_request_event(s48_value e,
XConfigureRequestEvent* xe) {
XWindowChanges WC;
EEXTRACT_START("scx-configure-request-event");
EEXTRACT(4, parent, scx_extract_window);
EEXTRACT(5, window, scx_extract_window);
xe->value_mask = scx_extract_window_changes(S48_RECORD_REF(e, 6), &WC);
xe->x = WC.x;
xe->y = WC.y;
xe->width = WC.width;
xe->height = WC.height;
xe->border_width = WC.border_width;
xe->above = WC.sibling;
xe->detail = WC.stack_mode;
EEXTRACT_END();
}
void scx_extract_circulate_event(s48_value e, XCirculateEvent* xe) {
EEXTRACT_START("scx-circulate-event");
EEXTRACT(4, event, scx_extract_window);
EEXTRACT(5, window, scx_extract_window);
EEXTRACT(6, place, scx_extract_place);
EEXTRACT_END();
}
void scx_extract_circulate_request_event(s48_value e,
XCirculateRequestEvent* xe) {
EEXTRACT_START("scx-circulate-request-event");
EEXTRACT(4, parent, scx_extract_window);
EEXTRACT(5, window, scx_extract_window);
EEXTRACT(6, place, scx_extract_place);
EEXTRACT_END();
}
void scx_extract_property_event(s48_value e, XPropertyEvent* xe) {
EEXTRACT_START("scx-property-event");
EEXTRACT(4, window, scx_extract_window);
EEXTRACT(5, atom, scx_extract_atom);
EEXTRACT(6, time, scx_extract_time);
EEXTRACT(7, state, scx_extract_property_state);
EEXTRACT_END();
}
void scx_extract_selection_clear_event(s48_value e, XSelectionClearEvent* xe) {
EEXTRACT_START("scx-selection-clear-event");
EEXTRACT(4, window, scx_extract_window);
EEXTRACT(5, selection, scx_extract_atom);
EEXTRACT(6, time, scx_extract_time);
EEXTRACT_END();
}
void scx_extract_selection_request_event(s48_value e,
XSelectionRequestEvent* xe) {
EEXTRACT_START("scx-selection-request-event");
EEXTRACT(4, owner, scx_extract_window);
EEXTRACT(5, requestor, scx_extract_window);
EEXTRACT(6, selection, scx_extract_atom);
EEXTRACT(7, target, scx_extract_atom);
EEXTRACT(8, property, scx_extract_atom);
EEXTRACT(9, time, scx_extract_time);
EEXTRACT_END();
}
void scx_extract_selection_event(s48_value e, XSelectionEvent* xe) {
EEXTRACT_START("scx-selection-event");
EEXTRACT(4, requestor, scx_extract_window);
EEXTRACT(5, selection, scx_extract_atom);
EEXTRACT(6, target, scx_extract_atom);
EEXTRACT(7, property, scx_extract_atom);
EEXTRACT(8, time, scx_extract_time);
EEXTRACT_END();
}
void scx_extract_colormap_event(s48_value e, XColormapEvent* xe) {
EEXTRACT_START("scx-colormap-event");
EEXTRACT(4, window, scx_extract_window);
EEXTRACT(5, colormap, scx_extract_colormap);
EEXTRACT(6, new, S48_EXTRACT_BOOLEAN);
EEXTRACT(7, state, scx_extract_colormap_state);
EEXTRACT_END();
}
void scx_extract_client_message_event(s48_value e, XClientMessageEvent* xe) {
EEXTRACT_START("scx-client-message-event");
EEXTRACT(4, window, scx_extract_window);
int nelements, i;
char* data;
scx_extract_property(S48_RECORD_REF(e, 5), &xe->message_type, &xe->format,
&data, &nelements);
for (i = 0; i < 20; i++)
if (i < nelements)
xe->data.b[i] = data[i];
else
xe->data.b[i] = 0;
free(data);
EEXTRACT_END();
}
void scx_extract_mapping_event(s48_value e, XMappingEvent* xe) {
EEXTRACT_START("scx-mapping-event");
EEXTRACT(4, window, scx_extract_window);
EEXTRACT(5, request, scx_extract_mapping_request);
EEXTRACT(6, first_keycode, scx_extract_keycode);
EEXTRACT(7, count, s48_extract_integer);
EEXTRACT_END();
}
void scx_extract_keymap_event(s48_value e, XKeymapEvent* xe) {
s48_value temp; int i;
EEXTRACT_START("scx-keymap-event");
xe->window = (Window)0; // not used.
temp = S48_RECORD_REF(e, 4);
for (i = 0; i < 32; i++) {
int j; char* b = &xe->key_vector[i];
for (j = 0; j < 8; j++)
*b |= (s48_extract_fixnum(S48_VECTOR_REF(temp, i*8 + j))
== 0 ? 0 : 1) << j;
}
EEXTRACT_END();
}
void scx_extract_event(s48_value se, XEvent* e) {
int t = scx_extract_event_type(S48_RECORD_REF(se, 0));
switch (t) {
case KeyPress : case KeyRelease :
scx_extract_key_event(se, (XKeyEvent*)e); break;
case ButtonPress : case ButtonRelease :
scx_extract_button_event(se, (XButtonEvent*)e); break;
case MotionNotify :
scx_extract_motion_event(se, (XMotionEvent*)e); break;
case EnterNotify : case LeaveNotify :
scx_extract_crossing_event(se, (XCrossingEvent*)e); break;
case FocusIn : case FocusOut :
scx_extract_focus_change_event(se, (XFocusChangeEvent*)e); break;
case KeymapNotify :
scx_extract_keymap_event(se, (XKeymapEvent*)e); break;
case Expose :
scx_extract_expose_event(se, (XExposeEvent*)e); break;
case GraphicsExpose :
scx_extract_graphics_expose_event(se, (XGraphicsExposeEvent*)e); break;
case NoExpose :
scx_extract_no_expose_event(se, (XNoExposeEvent*)e); break;
case VisibilityNotify :
scx_extract_visibility_event(se, (XVisibilityEvent*)e); break;
case CreateNotify :
scx_extract_create_window_event(se, (XCreateWindowEvent*)e); break;
case DestroyNotify :
scx_extract_destroy_window_event(se, (XDestroyWindowEvent*)e); break;
case UnmapNotify :
scx_extract_unmap_event(se, (XUnmapEvent*)e); break;
case MapNotify :
scx_extract_map_event(se, (XMapEvent*)e); break;
case MapRequest :
scx_extract_map_request_event(se, (XMapRequestEvent*)e); break;
case ReparentNotify :
scx_extract_reparent_event(se, (XReparentEvent*)e); break;
case ConfigureNotify :
scx_extract_configure_event(se, (XConfigureEvent*)e); break;
case ConfigureRequest :
scx_extract_configure_request_event(se, (XConfigureRequestEvent*)e); break;
case GravityNotify :
scx_extract_gravity_event(se, (XGravityEvent*)e); break;
case ResizeRequest :
scx_extract_resize_request_event(se, (XResizeRequestEvent*)e); break;
case CirculateRequest :
scx_extract_circulate_request_event(se, (XCirculateRequestEvent*)e); break;
case PropertyNotify :
scx_extract_property_event(se, (XPropertyEvent*)e); break;
case SelectionClear :
scx_extract_selection_clear_event(se, (XSelectionClearEvent*)e); break;
case SelectionRequest :
scx_extract_selection_request_event(se, (XSelectionRequestEvent*)e); break;
case SelectionNotify :
scx_extract_selection_event(se, (XSelectionEvent*)e); break;
case ColormapNotify :
scx_extract_colormap_event(se, (XColormapEvent*)e); break;
case ClientMessage :
scx_extract_client_message_event(se, (XClientMessageEvent*)e); break;
case MappingNotify :
scx_extract_mapping_event(se, (XMappingEvent*)e); break;
}
}

681
c/xlib/event.c
View File

@ -1,645 +1,69 @@
/* Copyright 2001-2003 by Norbert Freudemann, David Frese */
#include "xlib.h"
#include "scheme48.h"
#define ECAST(name, type) type* name = (type*)e
#define sidx 5
#define SET(i, v) S48_VECTOR_SET(r, i, v)
#define SETSIZE(i) r = s48_make_vector(sidx+i, S48_FALSE)
#define scx_extract_queued_mode(x) S48_EXTRACT_ENUM(x, "scx-queued-mode")
s48_value scx_enter_event(XEvent* e) {
s48_value r = S48_FALSE;
s48_value temp = S48_FALSE;
int i;
S48_DECLARE_GC_PROTECT(2);
S48_GC_PROTECT_2(r, temp);
switch (e->type) {
case KeyPress : case KeyRelease :
case ButtonPress : case ButtonRelease :
case MotionNotify : {
ECAST(q, XKeyEvent);
SETSIZE(10);
// all equal in the beginning
SET(sidx+0, SCX_ENTER_WINDOW(q->root));
SET(sidx+1, SCX_ENTER_WINDOW(q->subwindow));
SET(sidx+2, SCX_ENTER_TIME(q->time));
SET(sidx+3, s48_enter_fixnum(q->x));
SET(sidx+4, s48_enter_fixnum(q->y));
SET(sidx+5, s48_enter_fixnum(q->x_root));
SET(sidx+6, s48_enter_fixnum(q->y_root));
SET(sidx+7, s48_enter_fixnum(q->state));
// now they are different
switch (e->type) {
case KeyPress : case KeyRelease : {
SET(sidx+8, s48_enter_fixnum(q->keycode));
SET(sidx+9, S48_ENTER_BOOLEAN(q->same_screen));
} break;
case ButtonPress : case ButtonRelease : {
ECAST(q, XButtonEvent);
SET(sidx+8, s48_enter_integer(q->button));
SET(sidx+9, S48_ENTER_BOOLEAN(q->same_screen));
} break;
case MotionNotify : {
ECAST(q, XMotionEvent);
SET(sidx+8, s48_enter_fixnum(q->is_hint));
SET(sidx+9, S48_ENTER_BOOLEAN(q->same_screen));
} break;
}
} break;
case EnterNotify : case LeaveNotify : {
ECAST(q, XCrossingEvent);
SETSIZE(12);
SET(sidx+0, SCX_ENTER_WINDOW(q->root));
SET(sidx+1, SCX_ENTER_WINDOW(q->subwindow));
SET(sidx+2, SCX_ENTER_TIME(q->time));
SET(sidx+3, s48_enter_fixnum(q->x));
SET(sidx+4, s48_enter_fixnum(q->y));
SET(sidx+5, s48_enter_fixnum(q->x_root));
SET(sidx+6, s48_enter_fixnum(q->y_root));
SET(sidx+7, s48_enter_integer(q->mode));
SET(sidx+8, s48_enter_integer(q->detail));
SET(sidx+9, S48_ENTER_BOOLEAN(q->same_screen));
SET(sidx+10, S48_ENTER_BOOLEAN(q->focus));
// Elk does this; but why not State_Syms??
SET(sidx+11, s48_enter_integer(q->state));
} break;
case FocusIn : case FocusOut : {
ECAST(q, XFocusChangeEvent);
SETSIZE(2);
SET(sidx+0, s48_enter_integer(q->mode));
SET(sidx+1, s48_enter_integer(q->detail));
} break;
case KeymapNotify : {
ECAST(q, XKeymapEvent);
SETSIZE(1);
temp = s48_make_vector(32*8, s48_enter_integer(0));
for (i=0; i < 32; i++) {
int j;
char b = q->key_vector[i];
for (j = 0; j < 8; j++)
S48_VECTOR_SET(temp, i*8 + j, (b & (1 << j)) ? 1 : 0);
}
SET(sidx+0, temp);
} break;
case Expose : {
ECAST(q, XExposeEvent);
SETSIZE(5);
SET(sidx+0, s48_enter_fixnum(q->x));
SET(sidx+1, s48_enter_fixnum(q->y));
SET(sidx+2, s48_enter_fixnum(q->width));
SET(sidx+3, s48_enter_fixnum(q->height));
SET(sidx+4, s48_enter_fixnum(q->count));
} break;
case GraphicsExpose : {
ECAST(q, XGraphicsExposeEvent);
SETSIZE(7);
// the ->window member is only a drawable here! ??
SET(sidx+0, s48_enter_fixnum(q->x));
SET(sidx+1, s48_enter_fixnum(q->y));
SET(sidx+2, s48_enter_fixnum(q->width));
SET(sidx+3, s48_enter_fixnum(q->height));
SET(sidx+4, s48_enter_fixnum(q->count));
SET(sidx+5, s48_enter_integer(q->major_code));
SET(sidx+6, s48_enter_integer(q->minor_code));
} break;
case NoExpose : {
ECAST(q, XNoExposeEvent);
SETSIZE(2);
SET(sidx+0, s48_enter_integer(q->major_code));
SET(sidx+1, s48_enter_integer(q->minor_code));
} break;
case VisibilityNotify : {
ECAST(q, XVisibilityEvent);
SETSIZE(1);
SET(sidx+0, s48_enter_integer(q->state));
} break;
case CreateNotify : {
ECAST(q, XCreateWindowEvent);
SETSIZE(7);
SET(sidx+0, SCX_ENTER_WINDOW(q->window));
SET(sidx+1, s48_enter_fixnum(q->x));
SET(sidx+2, s48_enter_fixnum(q->y));
SET(sidx+3, s48_enter_fixnum(q->width));
SET(sidx+4, s48_enter_fixnum(q->height));
SET(sidx+5, s48_enter_fixnum(q->border_width));
SET(sidx+6, S48_ENTER_BOOLEAN(q->override_redirect));
} break;
case DestroyNotify : {
ECAST(q, XDestroyWindowEvent);
SETSIZE(1);
SET(sidx+0, SCX_ENTER_WINDOW(q->window));
} break;
case UnmapNotify : {
ECAST(q, XUnmapEvent);
SETSIZE(2);
SET(sidx+0, SCX_ENTER_WINDOW(q->window));
SET(sidx+1, S48_ENTER_BOOLEAN(q->from_configure));
} break;
case MapNotify : {
ECAST(q, XMapEvent);
SETSIZE(2);
SET(sidx+0, SCX_ENTER_WINDOW(q->window));
SET(sidx+1, S48_ENTER_BOOLEAN(q->override_redirect));
} break;
case MapRequest : {
ECAST(q, XMapRequestEvent);
SETSIZE(1);
SET(sidx+0, SCX_ENTER_WINDOW(q->window));
} break;
case ReparentNotify : {
ECAST(q, XReparentEvent);
SETSIZE(5);
SET(sidx+0, SCX_ENTER_WINDOW(q->window));
SET(sidx+1, SCX_ENTER_WINDOW(q->parent));
SET(sidx+2, s48_enter_fixnum(q->x));
SET(sidx+3, s48_enter_fixnum(q->y));
SET(sidx+4, S48_ENTER_BOOLEAN(q->override_redirect));
} break;
case ConfigureNotify : {
ECAST(q, XConfigureEvent);
SETSIZE(8);
SET(sidx+0, SCX_ENTER_WINDOW(q->window));
SET(sidx+1, s48_enter_fixnum(q->x));
SET(sidx+2, s48_enter_fixnum(q->y));
SET(sidx+3, s48_enter_fixnum(q->width));
SET(sidx+4, s48_enter_fixnum(q->height));
SET(sidx+5, s48_enter_fixnum(q->border_width));
SET(sidx+6, SCX_ENTER_WINDOW(q->above));
SET(sidx+7, S48_ENTER_BOOLEAN(q->override_redirect));
} break;
case ConfigureRequest : {
ECAST(q, XConfigureRequestEvent);
SETSIZE(9);
SET(sidx+0, SCX_ENTER_WINDOW(q->window));
SET(sidx+1, s48_enter_fixnum(q->x));
SET(sidx+2, s48_enter_fixnum(q->y));
SET(sidx+3, s48_enter_fixnum(q->width));
SET(sidx+4, s48_enter_fixnum(q->height));
SET(sidx+5, s48_enter_fixnum(q->border_width));
SET(sidx+6, SCX_ENTER_WINDOW(q->above));
SET(sidx+7, s48_enter_integer(q->detail));
SET(sidx+8, s48_enter_integer(q->value_mask));
} break;
case GravityNotify : {
ECAST(q, XGravityEvent);
SETSIZE(3);
SET(sidx+0, SCX_ENTER_WINDOW(q->window));
SET(sidx+1, s48_enter_fixnum(q->x));
SET(sidx+2, s48_enter_fixnum(q->y));
} break;
case ResizeRequest : {
ECAST(q, XResizeRequestEvent);
SETSIZE(2);
SET(sidx+0, s48_enter_fixnum(q->width));
SET(sidx+1, s48_enter_fixnum(q->height));
} break;
case CirculateRequest : {
ECAST(q, XCirculateEvent);
SETSIZE(2);
SET(sidx+0, SCX_ENTER_WINDOW(q->window));
SET(sidx+1, s48_enter_integer(q->place));
} break;
case PropertyNotify : {
ECAST(q, XPropertyEvent);
SETSIZE(3);
SET(sidx+0, SCX_ENTER_ATOM(q->atom));
SET(sidx+1, SCX_ENTER_TIME(q->time));
SET(sidx+2, s48_enter_integer(q->state));
} break;
case SelectionClear : {
ECAST(q, XSelectionClearEvent);
SETSIZE(2);
SET(sidx+0, SCX_ENTER_ATOM(q->selection));
SET(sidx+1, SCX_ENTER_TIME(q->time));
} break;
case SelectionRequest : {
ECAST(q, XSelectionRequestEvent);
SETSIZE(5);
SET(sidx+0, SCX_ENTER_WINDOW(q->requestor));
SET(sidx+1, SCX_ENTER_ATOM(q->selection));
SET(sidx+2, SCX_ENTER_ATOM(q->target));
SET(sidx+3, SCX_ENTER_ATOM(q->property));
SET(sidx+4, SCX_ENTER_TIME(q->time));
} break;
case SelectionNotify : {
ECAST(q, XSelectionEvent);
SETSIZE(4);
SET(sidx+0, SCX_ENTER_ATOM(q->selection));
SET(sidx+1, SCX_ENTER_ATOM(q->target));
SET(sidx+2, SCX_ENTER_ATOM(q->property));
SET(sidx+3, SCX_ENTER_TIME(q->time));
} break;
case ColormapNotify : {
ECAST(q, XColormapEvent);
SETSIZE(3);
SET(sidx+0, SCX_ENTER_COLORMAP(q->colormap));
SET(sidx+1, S48_ENTER_BOOLEAN(q->new));
SET(sidx+2, s48_enter_integer(q->state));
} break;
case ClientMessage : {
ECAST(q, XClientMessageEvent);
SETSIZE(3);
SET(sidx+0, SCX_ENTER_ATOM(q->message_type));
SET(sidx+1, s48_enter_integer(q->format));
switch (q->format) {
case 8 : {
temp = s48_make_string(20, (char)0);
for (i=0; i < 20; i++)
S48_STRING_SET(temp, i, q->data.b[i]);
} break;
case 16 : {
temp = s48_make_vector(10, S48_FALSE);
for (i=0; i < 10; i++)
S48_VECTOR_SET(temp, i, s48_enter_fixnum(q->data.s[i]));
} break;
case 32 : {
temp = s48_make_vector(5, S48_FALSE);
for (i=0; i < 5; i++)
S48_VECTOR_SET(temp, i, s48_enter_integer(q->data.l[i]));
} break;
default : temp = s48_enter_integer(q->format); //??
}
SET(sidx+2, temp);
} break;
case MappingNotify : {
ECAST(q, XMappingEvent);
SETSIZE(3);
SET(sidx+0, s48_enter_integer(q->request));
SET(sidx+1, s48_enter_integer(q->first_keycode));
SET(sidx+2, s48_enter_fixnum(q->count));
} break;
default: {
SETSIZE(0);
} break;
} // switch end
// XAnyEvent entries
{
ECAST(q, XAnyEvent);
SET(0, s48_enter_integer(q->type));
SET(1, s48_enter_integer(q->serial));
SET(2, S48_ENTER_BOOLEAN(q->send_event));
SET(3, SCX_ENTER_DISPLAY(q->display));
SET(4, SCX_ENTER_WINDOW(q->window));
}
// more??
S48_GC_UNPROTECT();
return r;
}
#define REF(i) S48_VECTOR_REF(v, i)
XEvent scx_extract_event(s48_value type, s48_value v) {
XEvent e;
e.xany.type = s48_extract_integer(REF(0));
e.xany.serial = s48_extract_integer(REF(1));
e.xany.send_event = S48_EXTRACT_BOOLEAN(REF(2));
e.xany.display = SCX_EXTRACT_DISPLAY(REF(3));
switch (s48_extract_integer(type)) {
case KeyPress: case KeyRelease: {
e.xkey.window = SCX_EXTRACT_WINDOW(REF(4));
e.xkey.root = SCX_EXTRACT_WINDOW(REF(5));
e.xkey.subwindow = SCX_EXTRACT_WINDOW(REF(6));
e.xkey.time = SCX_EXTRACT_TIME(REF(7));
e.xkey.x = s48_extract_integer(REF(8));
e.xkey.y = s48_extract_integer(REF(9));
e.xkey.x_root = s48_extract_integer(REF(10));
e.xkey.y_root = s48_extract_integer(REF(11));
e.xkey.state = s48_extract_integer(REF(12));
e.xkey.keycode = s48_extract_integer(REF(13));
e.xkey.same_screen = S48_EXTRACT_BOOLEAN(REF(14));
} break;
case ButtonPress: case ButtonRelease: {
e.xbutton.window = SCX_EXTRACT_WINDOW(REF(4));
e.xbutton.root = SCX_EXTRACT_WINDOW(REF(5));
e.xbutton.subwindow = SCX_EXTRACT_WINDOW(REF(6));
e.xbutton.time = SCX_EXTRACT_TIME(REF(7));
e.xbutton.x = s48_extract_integer(REF(8));
e.xbutton.y = s48_extract_integer(REF(9));
e.xbutton.x_root = s48_extract_integer(REF(10));
e.xbutton.y_root = s48_extract_integer(REF(11));
e.xbutton.state = s48_extract_integer(REF(12));
e.xbutton.button = s48_extract_integer(REF(13));
e.xbutton.same_screen = S48_EXTRACT_BOOLEAN(REF(14));
} break;
case MotionNotify: {
e.xmotion.window = SCX_EXTRACT_WINDOW(REF(4));
e.xmotion.root = SCX_EXTRACT_WINDOW(REF(5));
e.xmotion.subwindow = SCX_EXTRACT_WINDOW(REF(6));
e.xmotion.time = SCX_EXTRACT_TIME(REF(7));
e.xmotion.x = s48_extract_integer(REF(8));
e.xmotion.y = s48_extract_integer(REF(9));
e.xmotion.x_root = s48_extract_integer(REF(10));
e.xmotion.y_root = s48_extract_integer(REF(11));
e.xmotion.state = s48_extract_integer(REF(12));
e.xmotion.is_hint = s48_extract_integer(REF(13));
e.xmotion.same_screen = S48_EXTRACT_BOOLEAN(REF(14));
} break;
case EnterNotify: case LeaveNotify: {
e.xcrossing.window = SCX_EXTRACT_WINDOW(REF(4));
e.xcrossing.root = SCX_EXTRACT_WINDOW(REF(5));
e.xcrossing.subwindow = SCX_EXTRACT_WINDOW(REF(6));
e.xcrossing.time = SCX_EXTRACT_TIME(REF(7));
e.xcrossing.x = s48_extract_integer(REF(8));
e.xcrossing.y = s48_extract_integer(REF(9));
e.xcrossing.x_root = s48_extract_integer(REF(10));
e.xcrossing.y_root = s48_extract_integer(REF(11));
e.xcrossing.mode = s48_extract_integer(REF(12));
e.xcrossing.detail = s48_extract_integer(REF(13));
e.xcrossing.same_screen = S48_EXTRACT_BOOLEAN(REF(14));
e.xcrossing.focus = S48_EXTRACT_BOOLEAN(REF(15));
e.xcrossing.state = s48_extract_integer(REF(16));
} break;
case Expose: {
e.xexpose.window = SCX_EXTRACT_WINDOW(REF(4));
e.xexpose.x = s48_extract_integer(REF(5));
e.xexpose.y = s48_extract_integer(REF(6));
e.xexpose.width = s48_extract_integer(REF(7));
e.xexpose.height = s48_extract_integer(REF(8));
e.xexpose.count = s48_extract_integer(REF(9));
} break;
case GraphicsExpose: {
e.xgraphicsexpose.drawable = SCX_EXTRACT_WINDOW(REF(4));
e.xgraphicsexpose.x = s48_extract_integer(REF(5));
e.xgraphicsexpose.y = s48_extract_integer(REF(6));
e.xgraphicsexpose.width = s48_extract_integer(REF(7));
e.xgraphicsexpose.height = s48_extract_integer(REF(8));
e.xgraphicsexpose.count = s48_extract_integer(REF(9));
e.xgraphicsexpose.major_code = s48_extract_integer(REF(10));
e.xgraphicsexpose.minor_code = s48_extract_integer(REF(11));
} break;
case NoExpose: {
e.xnoexpose.drawable = SCX_EXTRACT_WINDOW(REF(4));
e.xnoexpose.major_code = s48_extract_integer(REF(5));
e.xnoexpose.minor_code = s48_extract_integer(REF(6));
} break;
case VisibilityNotify: {
e.xvisibility.window = SCX_EXTRACT_WINDOW(REF(4));
e.xvisibility.state = s48_extract_integer(REF(5));
} break;
case CreateNotify: {
e.xcreatewindow.window = SCX_EXTRACT_WINDOW(REF(4));
e.xcreatewindow.x = s48_extract_integer(REF(5));
e.xcreatewindow.y = s48_extract_integer(REF(6));
e.xcreatewindow.width = s48_extract_integer(REF(7));
e.xcreatewindow.height = s48_extract_integer(REF(8));
e.xcreatewindow.border_width = s48_extract_integer(REF(9));
e.xcreatewindow.override_redirect = S48_EXTRACT_BOOLEAN(REF(10));
} break;
case DestroyNotify: {
e.xdestroywindow.event = SCX_EXTRACT_WINDOW(REF(4));
e.xdestroywindow.window = SCX_EXTRACT_WINDOW(REF(5));
} break;
case UnmapNotify: {
e.xunmap.event = SCX_EXTRACT_WINDOW(REF(4));
e.xunmap.window = SCX_EXTRACT_WINDOW(REF(5));
e.xunmap.from_configure = S48_EXTRACT_BOOLEAN(REF(6));
} break;
case MapNotify: {
e.xmap.event = SCX_EXTRACT_WINDOW(REF(4));
e.xmap.window = SCX_EXTRACT_WINDOW(REF(5));
e.xmap.override_redirect = S48_EXTRACT_BOOLEAN(REF(6));
} break;
case MapRequest: {
e.xmaprequest.parent = SCX_EXTRACT_WINDOW(REF(4));
e.xmaprequest.window = SCX_EXTRACT_WINDOW(REF(5));
} break;
case ReparentNotify: {
e.xreparent.event = SCX_EXTRACT_WINDOW(REF(4));
e.xreparent.window = SCX_EXTRACT_WINDOW(REF(5));
e.xreparent.parent = SCX_EXTRACT_WINDOW(REF(6));
e.xreparent.x = s48_extract_integer(REF(7));
e.xreparent.y = s48_extract_integer(REF(8));
e.xreparent.override_redirect = S48_EXTRACT_BOOLEAN(REF(9));
} break;
case ConfigureNotify: {
e.xconfigure.event = SCX_EXTRACT_WINDOW(REF(4));
e.xconfigure.window = SCX_EXTRACT_WINDOW(REF(5));
e.xconfigure.x = s48_extract_integer(REF(6));
e.xconfigure.y = s48_extract_integer(REF(7));
e.xconfigure.width = s48_extract_integer(REF(8));
e.xconfigure.height = s48_extract_integer(REF(9));
e.xconfigure.border_width = s48_extract_integer(REF(10));
e.xconfigure.above = SCX_EXTRACT_WINDOW(REF(11));
e.xconfigure.override_redirect = S48_EXTRACT_BOOLEAN(REF(12));
} break;
case GravityNotify: {
e.xgravity.event = SCX_EXTRACT_WINDOW(REF(4));
e.xgravity.window = SCX_EXTRACT_WINDOW(REF(5));
e.xgravity.x = s48_extract_integer(REF(6));
e.xgravity.y = s48_extract_integer(REF(7));
} break;
case ResizeRequest: {
e.xresizerequest.window = SCX_EXTRACT_WINDOW(REF(4));
e.xresizerequest.width = s48_extract_integer(REF(5));
e.xresizerequest.height = s48_extract_integer(REF(6));
} break;
case ConfigureRequest: {
e.xconfigurerequest.parent = SCX_EXTRACT_WINDOW(REF(4));
e.xconfigurerequest.window = SCX_EXTRACT_WINDOW(REF(5));
{
XWindowChanges WC;
unsigned long mask = Changes_To_XWindowChanges(REF(6), &WC);
e.xconfigurerequest.x = WC.x;
e.xconfigurerequest.y = WC.y;
e.xconfigurerequest.width = WC.width;
e.xconfigurerequest.height = WC.height;
e.xconfigurerequest.border_width = WC.border_width;
e.xconfigurerequest.above = WC.sibling;
e.xconfigurerequest.detail = WC.stack_mode;
e.xconfigurerequest.value_mask = mask;
}
} break;
case CirculateNotify: {
e.xcirculate.event = SCX_EXTRACT_WINDOW(REF(4));
e.xcirculate.window = SCX_EXTRACT_WINDOW(REF(5));
e.xcirculate.place = s48_extract_integer(REF(6));
} break;
case CirculateRequest: {
e.xcirculaterequest.parent = SCX_EXTRACT_WINDOW(REF(4));
e.xcirculaterequest.window = SCX_EXTRACT_WINDOW(REF(5));
e.xcirculaterequest.place = s48_extract_integer(REF(6));
} break;
case PropertyNotify: {
e.xproperty.window = SCX_EXTRACT_WINDOW(REF(4));
e.xproperty.atom = SCX_EXTRACT_ATOM(REF(5));
e.xproperty.time = SCX_EXTRACT_TIME(REF(6));
e.xproperty.state = s48_extract_integer(REF(7));
} break;
case SelectionClear: {
e.xselectionclear.window = SCX_EXTRACT_WINDOW(REF(4));
e.xselectionclear.selection = SCX_EXTRACT_ATOM(REF(5));
e.xselectionclear.time = SCX_EXTRACT_TIME(REF(6));
} break;
case SelectionRequest: {
e.xselectionrequest.owner = SCX_EXTRACT_WINDOW(REF(4));
e.xselectionrequest.requestor = SCX_EXTRACT_WINDOW(REF(5));
e.xselectionrequest.selection = SCX_EXTRACT_ATOM(REF(6));
e.xselectionrequest.target = SCX_EXTRACT_ATOM(REF(7));
e.xselectionrequest.property = SCX_EXTRACT_ATOM(REF(8));
e.xselectionrequest.time = SCX_EXTRACT_TIME(REF(9));
} break;
case SelectionNotify: {
e.xselection.requestor = SCX_EXTRACT_WINDOW(REF(4));
e.xselection.selection = SCX_EXTRACT_ATOM(REF(5));
e.xselection.target = SCX_EXTRACT_ATOM(REF(6));
e.xselection.property = SCX_EXTRACT_ATOM(REF(7));
e.xselection.time = SCX_EXTRACT_TIME(REF(8));
} break;
case ColormapNotify: {
e.xcolormap.window = SCX_EXTRACT_WINDOW(REF(4));
e.xcolormap.colormap = SCX_EXTRACT_COLORMAP(REF(5));
e.xcolormap.new = S48_EXTRACT_BOOLEAN(REF(6));
e.xcolormap.state = s48_extract_integer(REF(7));
} break;
case ClientMessage: {
e.xclient.window = SCX_EXTRACT_WINDOW(REF(4));
e.xclient.message_type = SCX_EXTRACT_ATOM(REF(5));
e.xclient.format = s48_extract_integer(REF(6));
{
s48_value data = REF(7);
int i;
for (i = 0; i < S48_VECTOR_LENGTH(data); i++) {
switch (e.xclient.format) {
case 8:
if (i < 20)
e.xclient.data.b[i] =
(char)s48_extract_integer(S48_VECTOR_REF(data, i));
case 16:
if (i < 10)
e.xclient.data.s[i] =
(short)s48_extract_integer(S48_VECTOR_REF(data, i));
case 32:
if (i < 5)
e.xclient.data.l[i] =
(long)s48_extract_integer(S48_VECTOR_REF(data, i));
}
}
}
} break;
case MappingNotify: {
e.xmapping.window = SCX_EXTRACT_WINDOW(REF(4));
e.xmapping.request = s48_extract_integer(REF(5));
e.xmapping.first_keycode = s48_extract_integer(REF(6));
e.xmapping.count = s48_extract_integer(REF(7));
} break;
// Error Event...
case KeymapNotify: {
e.xkeymap.window = (Window)0; // not used.
{
s48_value bits = REF(4);
int j, bn;
char b;
for (bn = 0; bn < 32; bn++) {
b = 0;
for (j = 0; j < 8; j++)
b = b | ((char)S48_VECTOR_REF(bits, bn*8 + j) << j);
e.xkeymap.key_vector[bn] = b;
}
}
} break;
// default ??
} // switch.
return e;
}
s48_value scx_Send_Event(s48_value Xdisplay, s48_value Xwindow,
s48_value propagate,
s48_value event_mask, s48_value vector,
s48_value type) {
XEvent e = scx_extract_event(type, vector);
Status r = XSendEvent(SCX_EXTRACT_DISPLAY(Xdisplay),
SCX_EXTRACT_WINDOW(Xwindow),
S48_EXTRACT_BOOLEAN(propagate),
s48_extract_integer(event_mask),
&e);
return r ? S48_TRUE : S48_FALSE;
}
s48_value scx_Next_Event(s48_value Xdisplay) {
XEvent e;
XNextEvent(SCX_EXTRACT_DISPLAY(Xdisplay), &e);
return scx_enter_event(&e);
}
s48_value scx_Peek_Event(s48_value Xdisplay) {
XEvent e;
XPeekEvent(SCX_EXTRACT_DISPLAY(Xdisplay), &e);
return scx_enter_event(&e);
}
s48_value scx_Events_Queued(s48_value Xdisplay, s48_value mode) {
int r = XEventsQueued(SCX_EXTRACT_DISPLAY(Xdisplay),
s48_extract_integer(mode));
s48_value scx_Events_Queued(s48_value display, s48_value mode) {
int r = XEventsQueued(scx_extract_display(display),
scx_extract_queued_mode(mode));
return s48_enter_integer(r);
}
s48_value scx_Events_Pending(s48_value Xdisplay) {
return s48_enter_integer(XPending(SCX_EXTRACT_DISPLAY(Xdisplay)));
s48_value scx_Events_Pending(s48_value display) {
return s48_enter_integer(XPending(scx_extract_display(display)));
}
s48_value scx_Get_Motion_Events(s48_value Xdisplay, s48_value Xwindow,
s48_value from, s48_value to) {
s48_value scx_Next_Event(s48_value display) {
XEvent e;
XNextEvent(scx_extract_display(display), &e);
return scx_enter_event(&e);
}
s48_value scx_Peek_Event(s48_value display) {
XEvent e;
XPeekEvent(scx_extract_display(display), &e);
return scx_enter_event(&e);
}
s48_value scx_Get_Motion_Events(s48_value display, s48_value window,
s48_value from, s48_value to) {
int n,i;
XTimeCoord *p = XGetMotionEvents(SCX_EXTRACT_DISPLAY(Xdisplay),
SCX_EXTRACT_WINDOW(Xwindow),
SCX_EXTRACT_TIME(from),
SCX_EXTRACT_TIME(to),
XTimeCoord *p = XGetMotionEvents(scx_extract_display(display),
scx_extract_window(window),
scx_extract_time(from),
scx_extract_time(to),
&n);
s48_value v = s48_make_vector(n, S48_FALSE);
s48_value l = S48_NULL; s48_value t = S48_FALSE;
S48_DECLARE_GC_PROTECT(3);
s48_value l = S48_NULL, t = S48_FALSE;
S48_DECLARE_GC_PROTECT(2);
S48_GC_PROTECT_3(v, l, t);
for (i = 0; i < n; i++) {
t = s48_enter_fixnum(p[i].y); l = s48_cons(t, S48_NULL);
t = s48_enter_fixnum(p[i].x); l = s48_cons(t, l);
t = SCX_ENTER_TIME(p[i].time); l = s48_cons(t, l);
S48_VECTOR_SET(v, i, l);
S48_GC_PROTECT_2(l, t);
for (i = n-1; i >= 0; i--) {
t = s48_cons(s48_enter_fixnum(p[i].x), s48_enter_fixnum(p[i].y));
t = s48_cons(scx_enter_time(p[i].time), t);
l = s48_cons(t, l);
}
XFree((char*)p);
S48_GC_UNPROTECT();
return v;
return l;
}
s48_value scx_add_pending_channel (channel){
s48_value scx_Send_Event(s48_value display, s48_value window,
s48_value propagate,
s48_value event_mask, s48_value event) {
XEvent e;
scx_extract_event(event, &e);
Status r = XSendEvent(scx_extract_display(display),
scx_extract_window(window),
S48_EXTRACT_BOOLEAN(propagate),
scx_extract_event_mask(event_mask),
&e);
return r ? S48_TRUE : S48_FALSE;
}
s48_value scx_add_pending_channel(channel) {
int socket_fd;
S48_CHECK_CHANNEL(channel);
socket_fd = S48_UNSAFE_EXTRACT_FIXNUM(S48_UNSAFE_CHANNEL_OS_INDEX(channel));
@ -649,13 +73,14 @@ s48_value scx_add_pending_channel (channel){
return S48_UNSPECIFIC;
}
void scx_init_event(void) {
S48_EXPORT_FUNCTION(scx_Send_Event);
S48_EXPORT_FUNCTION(scx_Next_Event);
S48_EXPORT_FUNCTION(scx_Peek_Event);
S48_EXPORT_FUNCTION(scx_Events_Queued);
S48_EXPORT_FUNCTION(scx_Events_Pending);
S48_EXPORT_FUNCTION(scx_Next_Event);
S48_EXPORT_FUNCTION(scx_Peek_Event);
S48_EXPORT_FUNCTION(scx_Get_Motion_Events);
S48_EXPORT_FUNCTION(scx_Send_Event);
S48_EXPORT_FUNCTION(scx_add_pending_channel);
}

184
c/xlib/font.c
View File

@ -1,115 +1,118 @@
/* Copyright 2001-2003 by Norbert Freudemann, David Frese */
#include "xlib.h"
#include "scheme48.h"
s48_value scx_Load_Font(s48_value Xdisplay, s48_value font_name) {
return SCX_ENTER_FONTSTRUCT(XLoadQueryFont(SCX_EXTRACT_DISPLAY(Xdisplay),
s48_extract_string(font_name)));
s48_value scx_Load_Font(s48_value display, s48_value font_name) {
return scx_enter_font(XLoadFont(scx_extract_display(display),
s48_extract_string(font_name)));
}
s48_value scx_Free_Font(s48_value Xdisplay, s48_value Xfontstruct) {
XFreeFont(SCX_EXTRACT_DISPLAY(Xdisplay),
SCX_EXTRACT_FONTSTRUCT(Xfontstruct));
s48_value scx_Unload_Font(s48_value display, s48_value font) {
XUnloadFont(scx_extract_display(display),
scx_extract_font(font));
return S48_UNSPECIFIC;
}
s48_value scx_Get_Xfont(s48_value Xfontstruct) {
return SCX_ENTER_FONT((SCX_EXTRACT_FONTSTRUCT(Xfontstruct))->fid);
s48_value scx_Query_Font(s48_value display, s48_value font) {
XFontStruct* fs = XQueryFont(scx_extract_display(display),
scx_extract_font(font));
if (fs == NULL)
return S48_FALSE;
else
return scx_enter_fontstruct(fs);
}
s48_value scx_GContext_Font(s48_value Xdisplay, s48_value Xgcontext) {
GContext gc = XGContextFromGC(SCX_EXTRACT_GCONTEXT(Xgcontext));
Display* dpy = SCX_EXTRACT_DISPLAY(Xdisplay);
return SCX_ENTER_FONTSTRUCT(XQueryFont(dpy, gc));
s48_value scx_Load_Query_Font(s48_value display, s48_value font_name) {
XFontStruct* fs = XLoadQueryFont(scx_extract_display(display),
s48_extract_string(font_name));
if (fs == NULL)
return S48_FALSE;
else
return scx_enter_fontstruct(fs);
}
s48_value scx_Font_ID_To_Font(s48_value Xdisplay, s48_value Xfont) {
return SCX_ENTER_FONTSTRUCT(XQueryFont(SCX_EXTRACT_DISPLAY(Xdisplay),
SCX_EXTRACT_FONT(Xfont)));
s48_value scx_Free_Font(s48_value display, s48_value fontstruct) {
XFreeFont(scx_extract_display(display),
scx_extract_fontstruct(fontstruct));
return S48_UNSPECIFIC;
}
s48_value scx_Font_Path(s48_value Xdisplay) {
int n, i;
char** sa;
s48_value ret = S48_FALSE;
S48_DECLARE_GC_PROTECT(1);
s48_value scx_List_Fonts(s48_value display, s48_value pattern, s48_value max) {
s48_value res = S48_NULL;
int i, count;
char** fonts;
S48_DECLARE_GC_PROTECT(1);
// Enable/Disable Interrupts ??
sa = XGetFontPath(SCX_EXTRACT_DISPLAY(Xdisplay), &n);
ret = s48_make_vector(n, S48_FALSE);
S48_GC_PROTECT_1(ret);
for (i = 0; i < n; i++) {
S48_VECTOR_SET(ret, i, s48_enter_string(sa[i]));
fonts = XListFonts(scx_extract_display(display), s48_extract_string(pattern),
s48_extract_integer(max), &count);
S48_GC_PROTECT_1(res);
for (i = count; i > 0; i--)
res = s48_cons(s48_enter_string(fonts[i-1]), res);
S48_GC_UNPROTECT();
XFreeFontNames(fonts);
return res;
}
s48_value scx_List_Fonts_With_Info(s48_value display, s48_value pattern,
s48_value max) {
s48_value res = S48_NULL, cell = S48_NULL;
int i, count;
char** fonts;
XFontStruct* infos;
S48_DECLARE_GC_PROTECT(2);
fonts = XListFontsWithInfo(scx_extract_display(display),
s48_extract_string(pattern),
s48_extract_integer(max), &count,
&infos);
S48_GC_PROTECT_2(res, cell);
for (i = count; i > 0; i--) {
cell = scx_enter_fontstruct(&infos[i-1]);
cell = s48_cons(s48_enter_string(fonts[i-1]), cell);
res = s48_cons(cell, res);
}
S48_GC_UNPROTECT();
XFreeFontPath(sa);
return ret;
XFreeFontNames(fonts); // FontStructs have to be freed later
return res;
}
s48_value scx_Set_Font_Path(s48_value Xdisplay, s48_value path) {
int i, n = S48_VECTOR_LENGTH(path);
s48_value scx_Set_Font_Path(s48_value display, s48_value dirs) {
int i, n = s48_list_length(dirs);
char* sa[n];
s48_value l = dirs;
for (i = 0; i < n; i++) {
sa[i] = s48_extract_string(S48_VECTOR_REF(path, i));
sa[i] = s48_extract_string(S48_CAR(l));
l = S48_CDR(l);
}
XSetFontPath(SCX_EXTRACT_DISPLAY(Xdisplay), sa, n);
XSetFontPath(scx_extract_display(display), sa, n);
return S48_UNSPECIFIC;
}
s48_value scx_List_Font_Names(s48_value Xdisplay, s48_value pattern) {
s48_value scx_Get_Font_Path(s48_value display) {
int n, i;
char** sa;
int i,n;
s48_value v = S48_FALSE;
S48_DECLARE_GC_PROTECT(1);
s48_value res = S48_NULL;
S48_DECLARE_GC_PROTECT(1);
sa = XListFonts(SCX_EXTRACT_DISPLAY(Xdisplay),
s48_extract_string(pattern),
65535,
&n);
v = s48_make_vector(n, S48_FALSE);
S48_GC_PROTECT_1(v);
for (i = 0; i < n; i++) {
S48_VECTOR_SET(v, i, s48_enter_string(sa[i]));
}
// Enable/Disable Interrupts ??
sa = XGetFontPath(scx_extract_display(display), &n);
S48_GC_PROTECT_1(res);
for (i = n; i > 0; i--)
res = s48_cons(s48_enter_string(sa[i]), res);
S48_GC_UNPROTECT();
XFreeFontNames(sa);
XFreeFontPath(sa);
return v;
return res;
}
s48_value scx_List_Fonts(s48_value Xdisplay, s48_value pattern) {
char** sa;
XFontStruct* fsa;
int i,n;
s48_value v = S48_FALSE;
S48_DECLARE_GC_PROTECT(1);
sa = XListFontsWithInfo(SCX_EXTRACT_DISPLAY(Xdisplay),
s48_extract_string(pattern),
65535,
&n,
&fsa);
v = s48_make_vector(n, S48_FALSE);
S48_GC_PROTECT_1(v);
for (i = 0; i < n; i++) {
S48_VECTOR_SET(v, i, s48_cons(s48_enter_string(sa[i]),
SCX_ENTER_FONTSTRUCT(&fsa[i])));
}
S48_GC_UNPROTECT();
XFreeFontNames(sa);
return v;
}
/* TODO:
s48_value scx_Font_Properties(s48_value Xfontstruct) {
s48_value v, t = S48_FALSE;
int i,n;
XFontStruct* fs = SCX_EXTRACT_FONTSTRUCT(Xfontstruct);
XFontStruct* fs = scx_extract_fontstruct(Xfontstruct);
XFontProp* p;
S48_DECLARE_GC_PROTECT(2);
@ -119,7 +122,7 @@ s48_value scx_Font_Properties(s48_value Xfontstruct) {
for (i = 0; i < n; i++) {
p = fs->properties+i;
t = SCX_ENTER_ATOM(p->name);
t = scx_enter_atom(p->name);
t = s48_cons(t, s48_enter_integer(p->card32));
S48_VECTOR_SET(v, i, t);
}
@ -130,8 +133,8 @@ s48_value scx_Font_Properties(s48_value Xfontstruct) {
s48_value scx_Font_Property(s48_value Xfontstruct, s48_value Xatom) {
unsigned long val;
if (XGetFontProperty(SCX_EXTRACT_FONTSTRUCT(Xfontstruct),
SCX_EXTRACT_ATOM(Xatom),
if (XGetFontProperty(scx_extract_fontstruct(Xfontstruct),
scx_extract_atom(Xatom),
&val))
return s48_enter_integer(val);
else
@ -139,7 +142,7 @@ s48_value scx_Font_Property(s48_value Xfontstruct, s48_value Xatom) {
}
s48_value scx_Font_Info(s48_value Xfontstruct) {
XFontStruct* fs = SCX_EXTRACT_FONTSTRUCT(Xfontstruct);
XFontStruct* fs = scx_extract_fontstruct(Xfontstruct);
s48_value v = s48_make_vector(9, S48_FALSE);
S48_DECLARE_GC_PROTECT(1);
S48_GC_PROTECT_1(v);
@ -161,7 +164,7 @@ s48_value scx_Font_Info(s48_value Xfontstruct) {
s48_value scx_Char_Info(s48_value Xfontstruct, s48_value index) {
// index must be an integer, #f for 'min or #t for 'max
XCharStruct* cp;
XFontStruct* p = SCX_EXTRACT_FONTSTRUCT(Xfontstruct);
XFontStruct* p = scx_extract_fontstruct(Xfontstruct);
s48_value v = S48_FALSE;
S48_DECLARE_GC_PROTECT(1);
@ -185,19 +188,16 @@ s48_value scx_Char_Info(s48_value Xfontstruct, s48_value index) {
S48_GC_UNPROTECT();
return v;
}
*/
void scx_init_font(void) {
S48_EXPORT_FUNCTION(scx_Load_Font);
S48_EXPORT_FUNCTION(scx_Unload_Font);
S48_EXPORT_FUNCTION(scx_Query_Font);
S48_EXPORT_FUNCTION(scx_Load_Query_Font);
S48_EXPORT_FUNCTION(scx_Free_Font);
S48_EXPORT_FUNCTION(scx_Get_Xfont);
S48_EXPORT_FUNCTION(scx_GContext_Font);
S48_EXPORT_FUNCTION(scx_Font_Path);
S48_EXPORT_FUNCTION(scx_Set_Font_Path);
S48_EXPORT_FUNCTION(scx_Font_Property);
S48_EXPORT_FUNCTION(scx_Font_Properties);
S48_EXPORT_FUNCTION(scx_List_Fonts);
S48_EXPORT_FUNCTION(scx_List_Font_Names);
S48_EXPORT_FUNCTION(scx_Font_Info);
S48_EXPORT_FUNCTION(scx_Char_Info);
S48_EXPORT_FUNCTION(scx_Font_ID_To_Font);
S48_EXPORT_FUNCTION(scx_List_Fonts_With_Info);
S48_EXPORT_FUNCTION(scx_Set_Font_Path);
S48_EXPORT_FUNCTION(scx_Get_Font_Path);
}

487
c/xlib/gcontext.c
View File

@ -1,89 +1,244 @@
/* Copyright 2001-2003 by Norbert Freudemann, David Frese */
#include "xlib.h"
unsigned long Values_To_GCValues(s48_value values, XGCValues* GCV) {
unsigned long mask = s48_extract_integer(S48_CAR(values));
s48_value v = S48_CDR(values);
#define scx_extract_gc_function(x) S48_EXTRACT_ENUM(x, "scx-gc-function")
#define scx_extract_line_style(x) S48_EXTRACT_ENUM(x, "scx-line-style")
#define scx_extract_cap_style(x) S48_EXTRACT_ENUM(x, "scx-cap-style")
#define scx_extract_join_style(x) S48_EXTRACT_ENUM(x, "scx-join-style")
#define scx_extract_fill_style(x) S48_EXTRACT_ENUM(x, "scx-fill-style")
#define scx_extract_fill_rule(x) S48_EXTRACT_ENUM(x, "scx-fill-rule")
#define scx_extract_subwindow_mode(x) S48_EXTRACT_ENUM(x, "scx-subwindow-mode")
#define scx_extract_arc_mode(x) S48_EXTRACT_ENUM(x, "scx-arc-mode")
if (mask & GCFunction)
GCV->function = s48_extract_integer(S48_VECTOR_REF(v, 0));
if (mask & GCPlaneMask)
GCV->plane_mask = SCX_EXTRACT_PIXEL(S48_VECTOR_REF(v, 1));
if (mask & GCForeground)
GCV->foreground = SCX_EXTRACT_PIXEL(S48_VECTOR_REF(v, 2));
if (mask & GCBackground)
GCV->background = SCX_EXTRACT_PIXEL(S48_VECTOR_REF(v, 3));
if (mask & GCLineWidth)
GCV->line_width = s48_extract_integer(S48_VECTOR_REF(v, 4));
if (mask & GCLineStyle)
GCV->line_style = s48_extract_integer(S48_VECTOR_REF(v, 5));
if (mask & GCCapStyle)
GCV->cap_style = s48_extract_integer(S48_VECTOR_REF(v, 6));
if (mask & GCJoinStyle)
GCV->join_style = s48_extract_integer(S48_VECTOR_REF(v, 7));
if (mask & GCFillStyle)
GCV->fill_style = s48_extract_integer(S48_VECTOR_REF(v, 8));
if (mask & GCFillRule)
GCV->fill_rule = s48_extract_integer(S48_VECTOR_REF(v, 9));
if (mask & GCTile)
GCV->tile = SCX_EXTRACT_PIXMAP(S48_VECTOR_REF(v, 10));
if (mask & GCStipple)
GCV->stipple = SCX_EXTRACT_PIXMAP(S48_VECTOR_REF(v, 11));
if (mask & GCTileStipXOrigin)
GCV->ts_x_origin = s48_extract_integer(S48_VECTOR_REF(v, 12));
if (mask & GCTileStipYOrigin)
GCV->ts_y_origin = s48_extract_integer(S48_VECTOR_REF(v, 13));
if (mask & GCFont)
GCV->font = SCX_EXTRACT_FONT(S48_VECTOR_REF(v, 14));
if (mask & GCSubwindowMode)
GCV->subwindow_mode = s48_extract_integer(S48_VECTOR_REF(v, 15));
if (mask & GCGraphicsExposures)
GCV->graphics_exposures = S48_ENTER_BOOLEAN(S48_VECTOR_REF(v, 16));
if (mask & GCClipXOrigin)
GCV->clip_x_origin = s48_extract_integer(S48_VECTOR_REF(v, 17));
if (mask & GCClipYOrigin)
GCV->clip_y_origin = s48_extract_integer(S48_VECTOR_REF(v, 18));
if (mask & GCClipMask)
GCV->clip_mask = SCX_EXTRACT_PIXMAP(S48_VECTOR_REF(v, 19));
if (mask & GCDashOffset)
GCV->dash_offset = s48_extract_integer(S48_VECTOR_REF(v, 20));
if (mask & GCDashList)
GCV->dashes = (char)s48_extract_integer(S48_VECTOR_REF(v, 21));
if (mask & GCArcMode)
GCV->arc_mode = s48_extract_integer(S48_VECTOR_REF(v, 22));
#define scx_enter_gc_function(x) S48_ENTER_ENUM(x, "scx-gc-functions")
#define scx_enter_line_style(x) S48_ENTER_ENUM(x, "scx-line-styles")
#define scx_enter_cap_style(x) S48_ENTER_ENUM(x, "scx-cap-styles")
#define scx_enter_join_style(x) S48_ENTER_ENUM(x, "scx-join-styles")
#define scx_enter_fill_style(x) S48_ENTER_ENUM(x, "scx-fill-styles")
#define scx_enter_fill_rule(x) S48_ENTER_ENUM(x, "scx-fill-rules")
#define scx_enter_subwindow_mode(x) S48_ENTER_ENUM(x, "scx-subwindow-modes")
#define scx_enter_arc_mode(x) S48_ENTER_ENUM(x, "scx-arc-modes")
#define scx_extract_gc_value_set(x) S48_EXTRACT_ENUM_SET(x, "scx-gc-value-set")
#define scx_enter_gc_value_set(x) s48_enter_enum_set(x, "scx-gc-value-set")
s48_value scx_enter_charstruct(XCharStruct* cs) {
s48_value res =
s48_make_record(s48_get_imported_binding("scx-char-struct"));
S48_DECLARE_GC_PROTECT(1);
S48_GC_PROTECT_1(res);
S48_RECORD_SET(res, 0, s48_enter_fixnum(cs->lbearing));
S48_RECORD_SET(res, 1, s48_enter_fixnum(cs->rbearing));
S48_RECORD_SET(res, 2, s48_enter_fixnum(cs->width));
S48_RECORD_SET(res, 3, s48_enter_fixnum(cs->ascent));
S48_RECORD_SET(res, 4, s48_enter_fixnum(cs->descent));
S48_RECORD_SET(res, 5, s48_enter_integer(cs->attributes));
S48_GC_UNPROTECT();
return res;
}
s48_value scx_enter_fontstruct(XFontStruct* fs) {
int i;
s48_value plist = S48_NULL, t = S48_NULL;
s48_value res =
s48_make_record(s48_get_imported_binding("scx-font-struct"));
S48_DECLARE_GC_PROTECT(3);
S48_GC_PROTECT_3(res, plist, t);
S48_RECORD_SET(res, 0, S48_ENTER_POINTER(fs));
S48_RECORD_SET(res, 1, scx_enter_font(fs->fid));
S48_RECORD_SET(res, 2, scx_enter_font_direction(fs->direction));
S48_RECORD_SET(res, 3, s48_enter_integer(fs->min_char_or_byte2));
S48_RECORD_SET(res, 4, s48_enter_integer(fs->max_char_or_byte2));
S48_RECORD_SET(res, 5, s48_enter_integer(fs->min_byte1));
S48_RECORD_SET(res, 6, s48_enter_integer(fs->max_byte1));
S48_RECORD_SET(res, 7, S48_ENTER_BOOLEAN(fs->all_chars_exist));
S48_RECORD_SET(res, 8, s48_enter_integer(fs->default_char));
for (i = fs->n_properties-1; i >= 0; i--) {
t = s48_cons(scx_enter_atom(fs->properties[i].name),
s48_enter_integer(fs->properties[i].card32));
plist = s48_cons(t, plist);
}
S48_RECORD_SET(res, 9, plist);
S48_RECORD_SET(res, 10, scx_enter_charstruct(&fs->min_bounds));
S48_RECORD_SET(res, 11, scx_enter_charstruct(&fs->max_bounds));
{
int count;
if ((fs->min_byte1 == 0) && (fs->max_byte1 == 0))
count = (fs->max_char_or_byte2 - fs->min_char_or_byte2);
else
count = (fs->max_char_or_byte2 - fs->min_char_or_byte2) * 256
- fs->min_byte1 + fs->max_byte1;
t = s48_make_vector(count, S48_FALSE);
for (i = 0; i < count; i++)
S48_VECTOR_SET(t, i, scx_enter_charstruct(&fs->per_char[i]));
S48_RECORD_SET(res, 12, t);
}
S48_RECORD_SET(res, 13, s48_enter_integer(fs->ascent));
S48_RECORD_SET(res, 14, s48_enter_integer(fs->descent));
S48_GC_UNPROTECT();
return res;
}
s48_value scx_enter_gc(GC gc) {
s48_value v = s48_make_record(scx_gc);
S48_DECLARE_GC_PROTECT(1);
S48_GC_PROTECT_1(v);
S48_RECORD_SET(v, 0, S48_ENTER_POINTER(gc));
S48_GC_UNPROTECT();
return v;
}
unsigned long scx_extract_gc_value_alist(s48_value values, XGCValues* GCV) {
unsigned long mask = 0;
while (values != S48_NULL) {
int mv = scx_extract_gc_value(S48_CAR(S48_CAR(values)));
s48_value v = S48_CDR(S48_CAR(values));
values = S48_CDR(values);
mask = mask | mv;
switch (mv) {
case GCFunction:
GCV->function = scx_extract_gc_function(v); break;
case GCPlaneMask:
GCV->plane_mask = scx_extract_pixel(v); break;
case GCForeground:
GCV->foreground = scx_extract_pixel(v); break;
case GCBackground:
GCV->background = scx_extract_pixel(v); break;
case GCLineWidth:
GCV->line_width = s48_extract_integer(v); break;
case GCLineStyle:
GCV->line_style = scx_extract_line_style(v); break;
case GCCapStyle:
GCV->cap_style = scx_extract_cap_style(v); break;
case GCJoinStyle:
GCV->join_style = scx_extract_join_style(v); break;
case GCFillStyle:
GCV->fill_style = scx_extract_fill_style(v); break;
case GCFillRule:
GCV->fill_rule = scx_extract_fill_rule(v); break;
case GCTile:
GCV->tile = scx_extract_pixmap(v); break;
case GCStipple:
GCV->stipple = scx_extract_pixmap(v); break;
case GCTileStipXOrigin:
GCV->ts_x_origin = s48_extract_integer(v); break;
case GCTileStipYOrigin:
GCV->ts_y_origin = s48_extract_integer(v); break;
case GCFont:
GCV->font = scx_extract_font(v); break;
case GCSubwindowMode:
GCV->subwindow_mode = scx_extract_subwindow_mode(v); break;
case GCGraphicsExposures:
GCV->graphics_exposures = S48_EXTRACT_BOOLEAN(v); break;
case GCClipXOrigin:
GCV->clip_x_origin = s48_extract_integer(v); break;
case GCClipYOrigin:
GCV->clip_y_origin = s48_extract_integer(v); break;
case GCClipMask:
GCV->clip_mask = scx_extract_pixmap(v); break;
case GCDashOffset:
GCV->dash_offset = s48_extract_integer(v); break;
case GCDashList:
GCV->dashes = (char)s48_extract_integer(v); break;
case GCArcMode:
GCV->arc_mode = scx_extract_arc_mode(v); break;
}
}
return mask;
}
s48_value scx_Create_Gc(s48_value Xdisplay, s48_value Xdrawable,
static s48_value scx_enter_gc_value_alist(s48_value values, XGCValues* GCV) {
S48_DECLARE_GC_PROTECT(1);
s48_value res = S48_NULL;
s48_value v = S48_FALSE;
S48_GC_PROTECT_3(res, v, values);
while (values != S48_NULL) {
int mv = scx_extract_gc_value(S48_CAR(values));
switch (mv) {
case GCFunction:
v = scx_extract_gc_function(GCV->function); break;
case GCPlaneMask:
v = scx_enter_pixel(GCV->plane_mask); break;
case GCForeground:
v = scx_enter_pixel(GCV->foreground); break;
case GCBackground:
v = scx_enter_pixel(GCV->background); break;
case GCLineWidth:
v = s48_enter_integer(GCV->line_width); break;
case GCLineStyle:
v = scx_enter_line_style(GCV->line_style); break;
case GCCapStyle:
v = scx_enter_cap_style(GCV->cap_style); break;
case GCJoinStyle:
v = scx_enter_join_style(GCV->join_style); break;
case GCFillStyle:
v = scx_enter_fill_style(GCV->fill_style); break;
case GCFillRule:
v = scx_enter_fill_rule(GCV->fill_rule); break;
case GCTile:
v = scx_enter_pixmap(GCV->tile); break;
case GCStipple:
v = scx_enter_pixmap(GCV->stipple); break;
case GCTileStipXOrigin:
v = s48_enter_integer(GCV->ts_x_origin); break;
case GCTileStipYOrigin:
v = s48_enter_integer(GCV->ts_y_origin); break;
case GCFont:
v = scx_enter_font(GCV->font); break;
case GCSubwindowMode:
v = scx_enter_subwindow_mode(GCV->subwindow_mode); break;
case GCGraphicsExposures:
v = S48_ENTER_BOOLEAN(GCV->graphics_exposures); break;
case GCClipXOrigin:
v = s48_enter_integer(GCV->clip_x_origin); break;
case GCClipYOrigin:
v = s48_enter_integer(GCV->clip_y_origin); break;
case GCClipMask:
v = scx_enter_pixmap(GCV->clip_mask); break;
case GCDashOffset:
v = s48_enter_integer(GCV->dash_offset); break;
case GCDashList:
v = s48_enter_integer(GCV->dashes); break;
case GCArcMode:
v = scx_enter_arc_mode(GCV->arc_mode); break;
}
v = s48_cons(S48_CAR(values), v);
res = s48_cons(v, res);
values = S48_CDR(values);
}
S48_GC_UNPROTECT();
return res;
}
s48_value scx_Create_Gc(s48_value display, s48_value drawable,
s48_value values) {
XGCValues GCV;
unsigned long mask = Values_To_GCValues(values, &GCV);
GC Xgcontext = XCreateGC(SCX_EXTRACT_DISPLAY(Xdisplay),
SCX_EXTRACT_DRAWABLE(Xdrawable),
mask, &GCV);
return SCX_ENTER_GCONTEXT(Xgcontext);
unsigned long mask = scx_extract_gc_value_alist(values, &GCV);
GC gc = XCreateGC(scx_extract_display(display),
scx_extract_drawable(drawable),
mask, &GCV);
return scx_enter_gc(gc);
}
s48_value scx_Copy_Gc(s48_value Xdisplay, s48_value Xsource, s48_value Xdest) {
XCopyGC(SCX_EXTRACT_DISPLAY(Xdisplay), SCX_EXTRACT_GCONTEXT(Xsource),
~0L, SCX_EXTRACT_GCONTEXT(Xdest));
s48_value scx_Copy_Gc(s48_value display, s48_value source, s48_value mask,
s48_value dest) {
XCopyGC(scx_extract_display(display), scx_extract_gc(source),
scx_extract_gc_value_set(mask), scx_extract_gc(dest));
return S48_UNSPECIFIC;
}
s48_value scx_Copy_Gc_To_Gc(s48_value Xdisplay, s48_value Xfrom, s48_value Xto,
s48_value attrs) {
unsigned long mask = s48_extract_integer(attrs); // -1 for all! ??
XCopyGC(SCX_EXTRACT_DISPLAY(Xdisplay), SCX_EXTRACT_GCONTEXT(Xfrom),
mask, SCX_EXTRACT_GCONTEXT(Xto));
s48_value scx_Change_Gc(s48_value display, s48_value gc, s48_value values) {
XGCValues GCV;
unsigned long mask = scx_extract_gc_value_alist(values, &GCV);
XChangeGC(scx_extract_display(display), scx_extract_gc(gc),
mask, &GCV);
return S48_UNSPECIFIC;
}
s48_value scx_Free_Gc(s48_value Xgcontext, s48_value Xdisplay) {
XFreeGC(SCX_EXTRACT_DISPLAY(Xdisplay), SCX_EXTRACT_GCONTEXT(Xgcontext));
return S48_UNSPECIFIC;
}
#define ValidGCValuesBits \
(GCFunction | GCPlaneMask | GCForeground | GCBackground | GCLineWidth |\
@ -92,134 +247,92 @@ s48_value scx_Free_Gc(s48_value Xgcontext, s48_value Xdisplay) {
GCSubwindowMode | GCGraphicsExposures | GCClipXOrigin | GCClipYOrigin |\
GCDashOffset | GCArcMode)
s48_value scx_Get_Gc_Values (s48_value Xgcontext, s48_value Xdisplay) {
unsigned long mask = ValidGCValuesBits;
s48_value scx_Get_Gc_Values(s48_value display, s48_value gc,
s48_value values) {
unsigned long mask = 0;
XGCValues GCV;
s48_value res = S48_FALSE;
S48_DECLARE_GC_PROTECT(1);
for (; values != S48_NULL; values = S48_CDR(values))
mask |= scx_extract_gc_value(S48_CAR(values));
if (!XGetGCValues (SCX_EXTRACT_DISPLAY(Xdisplay),
SCX_EXTRACT_GCONTEXT(Xgcontext),
mask, &GCV))
res = S48_FALSE;
else {
res = s48_make_vector(23, S48_FALSE);
S48_GC_PROTECT_1(res);
S48_VECTOR_SET(res, 0, s48_enter_integer(GCV.function));
S48_VECTOR_SET(res, 1, SCX_ENTER_PIXEL(GCV.plane_mask));
S48_VECTOR_SET(res, 2, SCX_ENTER_PIXEL(GCV.foreground));
S48_VECTOR_SET(res, 3, SCX_ENTER_PIXEL(GCV.background));
S48_VECTOR_SET(res, 4, s48_enter_fixnum(GCV.line_width));
S48_VECTOR_SET(res, 5, s48_enter_integer(GCV.line_style));
S48_VECTOR_SET(res, 6, s48_enter_integer(GCV.cap_style));
S48_VECTOR_SET(res, 7, s48_enter_integer(GCV.join_style));
S48_VECTOR_SET(res, 8, s48_enter_integer(GCV.fill_style));
S48_VECTOR_SET(res, 9, s48_enter_integer(GCV.fill_rule));
S48_VECTOR_SET(res, 10, SCX_ENTER_PIXMAP(GCV.tile));
S48_VECTOR_SET(res, 11, SCX_ENTER_PIXMAP(GCV.stipple));
S48_VECTOR_SET(res, 12, s48_enter_fixnum(GCV.ts_x_origin));
S48_VECTOR_SET(res, 13, s48_enter_fixnum(GCV.ts_y_origin));
S48_VECTOR_SET(res, 14, SCX_ENTER_FONT(GCV.font));
S48_VECTOR_SET(res, 15, s48_enter_integer(GCV.subwindow_mode));
S48_VECTOR_SET(res, 16, S48_ENTER_BOOLEAN(GCV.graphics_exposures));
S48_VECTOR_SET(res, 17, s48_enter_fixnum(GCV.clip_x_origin));
S48_VECTOR_SET(res, 18, s48_enter_fixnum(GCV.clip_y_origin));
S48_VECTOR_SET(res, 19, SCX_ENTER_PIXMAP(GCV.clip_mask));
S48_VECTOR_SET(res, 20, s48_enter_integer(GCV.dash_offset));
S48_VECTOR_SET(res, 21, s48_enter_integer(GCV.dashes));
S48_VECTOR_SET(res, 22, s48_enter_integer(GCV.arc_mode));
res = s48_cons(s48_enter_integer(mask), res);
S48_GC_UNPROTECT();
}
return res;
}
s48_value scx_Change_Gc (s48_value Xgcontext, s48_value Xdisplay, s48_value args) {
XGCValues GCV;
unsigned long mask = Values_To_GCValues(args, &GCV);
XChangeGC(SCX_EXTRACT_DISPLAY(Xdisplay), SCX_EXTRACT_GCONTEXT(Xgcontext),
mask, &GCV);
return S48_UNSPECIFIC;
}
s48_value scx_Set_Gcontext_Dashlist(s48_value Xgcontext, s48_value Xdisplay,
s48_value dashoffset, s48_value dashlist) {
int n = S48_VECTOR_LENGTH(dashlist);
char v[n];
int i;
for (i=0; i<n; i++) {
v[i] = (char)s48_extract_integer(S48_VECTOR_REF(dashlist, i));
}
XSetDashes( SCX_EXTRACT_DISPLAY(Xdisplay), SCX_EXTRACT_GCONTEXT(Xgcontext),
s48_extract_integer(dashoffset), v, n);
return S48_UNSPECIFIC;
}
s48_value scx_Set_Gcontext_Clip_Rectangles (s48_value Xgcontext,
s48_value Xdisplay, s48_value x,
s48_value y, s48_value v,
s48_value ord) {
int n = S48_VECTOR_LENGTH(v);
XRectangle p[n];
int i;
s48_value rect;
for (i = 0; i < n; i++) {
rect = S48_VECTOR_REF(v, i);
p[i].x = (int)s48_extract_integer (S48_CAR (rect));
rect = S48_CDR (rect);
p[i].y = (int)s48_extract_integer (S48_CAR (rect));
rect = S48_CDR (rect);
p[i].width = (int)s48_extract_integer (S48_CAR (rect));
rect = S48_CDR (rect);
p[i].height = (int)s48_extract_integer (S48_CAR (rect));
}
XSetClipRectangles (SCX_EXTRACT_DISPLAY(Xdisplay),
SCX_EXTRACT_GCONTEXT(Xgcontext),
(int)s48_extract_integer (x),
(int)s48_extract_integer (y), p, n,
s48_extract_integer(ord));
return S48_UNSPECIFIC;
}
s48_value scx_Query_Best_Size (s48_value Xdisplay, s48_value width,
s48_value height, s48_value shape) {
unsigned int rw, rh;
Display* dpy = SCX_EXTRACT_DISPLAY(Xdisplay);
if (!XQueryBestSize (dpy,
s48_extract_integer(shape),
DefaultRootWindow (dpy), //??
(int)s48_extract_integer (width),
(int)s48_extract_integer (height),
&rw, &rh))
if (!XGetGCValues(scx_extract_display(display),
scx_extract_gc(gc),
mask, &GCV))
return S48_FALSE;
else
return s48_cons (s48_enter_fixnum (rw), s48_enter_fixnum (rh));
return scx_enter_gc_value_alist(values, &GCV);
}
s48_value scx_Free_Gc(s48_value display, s48_value gc) {
XFreeGC(scx_extract_display(display), scx_extract_gc(gc));
return S48_UNSPECIFIC;
}
s48_value scx_GContext_From_Gc(s48_value gc) {
return scx_enter_gcontext(XGContextFromGC(scx_extract_gc(gc)));
}
s48_value scx_Set_Dashes(s48_value display, s48_value gc, s48_value dashoffset,
s48_value dashlist) {
int i, n = s48_list_length(dashlist);
char dl[n];
for (i = 0; i < n; i++) {
dl[i] = s48_extract_integer(S48_CAR(dashlist));
dashlist = S48_CDR(dashlist);
}
XSetDashes(scx_extract_display(display), scx_extract_gc(gc),
s48_extract_integer(dashoffset),
dl, n);
return S48_UNSPECIFIC;
}
#define scx_extract_rectangle_ordering(x) \
S48_EXTRACT_ENUM(x, "scx-rectangle-ordering")
s48_value scx_Set_Clip_Rectangles(s48_value display, s48_value gc,
s48_value x_origin, s48_value y_origin,
s48_value rects, s48_value ordering) {
//TODO
int i, n = s48_list_length(rects);
XRectangle crects[n];
for (i = 0; i < n; i++) {
s48_value r = S48_CAR(rects);
crects[i].x = s48_extract_integer(S48_CAR(r)); r = S48_CDR(r);
crects[i].y = s48_extract_integer(S48_CAR(r)); r = S48_CDR(r);
crects[i].width = s48_extract_integer(S48_CAR(r)); r = S48_CDR(r);
crects[i].height = s48_extract_integer(S48_CAR(r)); r = S48_CDR(r);
rects = S48_CDR(rects);
}
XSetClipRectangles(scx_extract_display(display), scx_extract_gc(gc),
s48_extract_integer(x_origin),
s48_extract_integer(y_origin),
crects, n, scx_extract_rectangle_ordering(ordering));
return S48_UNSPECIFIC;
}
s48_value scx_Query_Best_Size(s48_value screen, s48_value class,
s48_value width, s48_value height) {
unsigned int rw, rh;
Screen* s = scx_extract_screen(screen);
if (!XQueryBestSize(s->display,
s48_extract_integer(class),
s->root,
(int)s48_extract_integer(width),
(int)s48_extract_integer(height),
&rw, &rh))
return S48_FALSE;
else
return s48_cons(s48_enter_fixnum(rw), s48_enter_fixnum(rh));
}
void scx_init_gcontext(void) {
S48_EXPORT_FUNCTION(scx_Create_Gc);
S48_EXPORT_FUNCTION(scx_Free_Gc);
S48_EXPORT_FUNCTION(scx_Copy_Gc);
S48_EXPORT_FUNCTION(scx_Copy_Gc_To_Gc);
S48_EXPORT_FUNCTION(scx_Get_Gc_Values);
S48_EXPORT_FUNCTION(scx_Change_Gc);
S48_EXPORT_FUNCTION(scx_Set_Gcontext_Dashlist);
S48_EXPORT_FUNCTION(scx_Set_Gcontext_Clip_Rectangles);
S48_EXPORT_FUNCTION(scx_Get_Gc_Values);
S48_EXPORT_FUNCTION(scx_Free_Gc);
S48_EXPORT_FUNCTION(scx_GContext_From_Gc);
S48_EXPORT_FUNCTION(scx_Set_Dashes);
S48_EXPORT_FUNCTION(scx_Set_Clip_Rectangles);
S48_EXPORT_FUNCTION(scx_Query_Best_Size);
}

186
c/xlib/grab.c
View File

@ -1,136 +1,126 @@
/* Copyright 2001-2003 by Norbert Freudemann, David Frese */
#include "xlib.h"
s48_value scx_Grab_Pointer (s48_value dpy, s48_value win,
s48_value ownerp, s48_value events,
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),
#define scx_extract_grab_mode(x) S48_EXTRACT_ENUM(x, "scx-grab-mode")
#define scx_enter_grab_status(x) S48_ENTER_ENUM(x, "scx-grab-states")
s48_value scx_Grab_Pointer(s48_value dpy, s48_value win,
s48_value ownerp, s48_value events,
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),
s48_extract_integer(pmode),
s48_extract_integer(kmode),
SCX_EXTRACT_WINDOW(confine_to),
SCX_EXTRACT_CURSOR(cursor),
SCX_EXTRACT_TIME(time));
return s48_enter_integer(res);
scx_extract_event_mask(events),
scx_extract_grab_mode(pmode),
scx_extract_grab_mode(kmode),
scx_extract_window(confine_to),
scx_extract_cursor(cursor),
scx_extract_time(time));
return scx_enter_grab_status(res);
}
s48_value scx_Ungrab_Pointer (s48_value dpy, s48_value time) {
XUngrabPointer (SCX_EXTRACT_DISPLAY(dpy), SCX_EXTRACT_TIME(time));
s48_value scx_Ungrab_Pointer(s48_value dpy, s48_value time) {
XUngrabPointer(scx_extract_display(dpy), scx_extract_time(time));
return S48_UNSPECIFIC;
}
s48_value scx_Change_Active_Pointer_Grab(s48_value dpy, s48_value events,
s48_value cursor, s48_value time){
XChangeActivePointerGrab(scx_extract_display(dpy),
scx_extract_event_mask(events),
scx_extract_cursor(cursor),
scx_extract_time(time));
return S48_UNSPECIFIC;
}
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 pmode, s48_value kmode,
s48_value confine_to, s48_value cursor){
XGrabButton(SCX_EXTRACT_DISPLAY(dpy),
s48_extract_integer(button),
s48_extract_integer(mods),
SCX_EXTRACT_WINDOW(win),
s48_value scx_Grab_Button(s48_value dpy, s48_value button, s48_value mods,
s48_value win, s48_value ownerp, s48_value events,
s48_value pmode, s48_value kmode,
s48_value confine_to, s48_value cursor) {
XGrabButton(scx_extract_display(dpy),
scx_extract_button(button),
scx_extract_state_set(mods),
scx_extract_window(win),
S48_EXTRACT_BOOLEAN(ownerp),
s48_extract_integer(events),
s48_extract_integer(pmode),
s48_extract_integer(kmode),
SCX_EXTRACT_WINDOW(confine_to),
SCX_EXTRACT_CURSOR(cursor));
scx_extract_event_mask(events),
scx_extract_grab_mode(pmode),
scx_extract_grab_mode(kmode),
scx_extract_window(confine_to),
scx_extract_cursor(cursor));
return S48_UNSPECIFIC;
}
s48_value scx_Ungrab_Button (s48_value Xdpy, s48_value Xwin,
s48_value button, s48_value mods){
XUngrabButton(SCX_EXTRACT_DISPLAY(Xdpy),
s48_extract_integer(button),
s48_extract_integer(mods),
SCX_EXTRACT_WINDOW(Xwin));
s48_value scx_Ungrab_Button(s48_value dpy, s48_value button,
s48_value mods, s48_value win) {
XUngrabButton(scx_extract_display(dpy),
scx_extract_button(button),
scx_extract_state_set(mods),
scx_extract_window(win));
return S48_UNSPECIFIC;
}
s48_value scx_Change_Active_Pointer_Grab (s48_value Xdpy, s48_value events,
s48_value cursor, s48_value time){
XChangeActivePointerGrab (SCX_EXTRACT_DISPLAY(Xdpy),
s48_extract_integer(events),
SCX_EXTRACT_CURSOR(cursor),
SCX_EXTRACT_TIME(time));
return S48_UNSPECIFIC;
}
s48_value scx_Grab_Keyboard (s48_value Xdpy, s48_value Xwin, s48_value ownerp,
s48_value pmode, s48_value kmode,
s48_value time){
int res = XGrabKeyboard( SCX_EXTRACT_DISPLAY(Xdpy),
SCX_EXTRACT_WINDOW(Xwin),
s48_value scx_Grab_Keyboard(s48_value dpy, s48_value win, s48_value ownerp,
s48_value pmode, s48_value kmode,
s48_value time) {
int res = XGrabKeyboard( scx_extract_display(dpy),
scx_extract_window(win),
S48_EXTRACT_BOOLEAN(ownerp),
s48_extract_integer(pmode),
s48_extract_integer(kmode),
SCX_EXTRACT_TIME(time));
return s48_enter_integer(res);
scx_extract_grab_mode(pmode),
scx_extract_grab_mode(kmode),
scx_extract_time(time));
return scx_enter_grab_status(res);
}
s48_value scx_Ungrab_Keyboard (s48_value Xdpy, s48_value time){
XUngrabKeyboard (SCX_EXTRACT_DISPLAY(Xdpy),
SCX_EXTRACT_TIME(time));
s48_value scx_Ungrab_Keyboard(s48_value dpy, s48_value time){
XUngrabKeyboard(scx_extract_display(dpy),
scx_extract_time(time));
return S48_UNSPECIFIC;
}
s48_value scx_Grab_Key (s48_value Xdpy, s48_value Xwin, s48_value key,
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);
XGrabKey (SCX_EXTRACT_DISPLAY(Xdpy),
keycode,
s48_extract_integer(mods),
SCX_EXTRACT_WINDOW(Xwin),
S48_EXTRACT_BOOLEAN(ownerp),
s48_extract_integer(pmode),
s48_extract_integer(kmode));
s48_value scx_Grab_Key(s48_value dpy, s48_value key, s48_value mods,
s48_value win, s48_value ownerp, s48_value pmode,
s48_value kmode) {
XGrabKey(scx_extract_display(dpy),
s48_extract_integer(key),
scx_extract_state_set(mods),
scx_extract_window(win),
S48_EXTRACT_BOOLEAN(ownerp),
scx_extract_grab_mode(pmode),
scx_extract_grab_mode(kmode));
return S48_UNSPECIFIC;
}
s48_value scx_Ungrab_Key (s48_value Xdpy, s48_value Xwin, s48_value key,
s48_value mods, s48_value flag){
int keycode = AnyKey;
if (!S48_EXTRACT_BOOLEAN(flag))
keycode = (int)s48_extract_integer(key);
XUngrabKey (SCX_EXTRACT_DISPLAY(Xdpy),
keycode,
s48_extract_integer(mods),
SCX_EXTRACT_WINDOW(Xwin));
s48_value scx_Ungrab_Key(s48_value dpy, s48_value key, s48_value mods,
s48_value win) {
XUngrabKey(scx_extract_display(dpy),
s48_extract_integer(key),
scx_extract_state_set(mods),
scx_extract_window(win));
return S48_UNSPECIFIC;
}
#define scx_extract_event_mode(x) S48_EXTRACT_ENUM(x, "scx-event-mode")
s48_value scx_Allow_Events (s48_value Xdpy, s48_value mode, s48_value time){
XAllowEvents (SCX_EXTRACT_DISPLAY(Xdpy),
s48_extract_integer(mode),
SCX_EXTRACT_TIME(time));
return S48_UNSPECIFIC;
}
s48_value scx_Grab_Server (s48_value Xdpy){
XGrabServer(SCX_EXTRACT_DISPLAY(Xdpy));
s48_value scx_Allow_Events(s48_value dpy, s48_value event_mode,
s48_value time) {
XAllowEvents(scx_extract_display(dpy),
scx_extract_event_mode(event_mode),
scx_extract_time(time));
return S48_UNSPECIFIC;
}
s48_value scx_Ungrab_Server (s48_value Xdpy){
XUngrabServer (SCX_EXTRACT_DISPLAY(Xdpy));
s48_value scx_Grab_Server(s48_value dpy) {
XGrabServer(scx_extract_display(dpy));
return S48_UNSPECIFIC;
}
s48_value scx_Ungrab_Server(s48_value dpy){
XUngrabServer(scx_extract_display(dpy));
return S48_UNSPECIFIC;
}
void scx_init_grab(void) {
S48_EXPORT_FUNCTION(scx_Grab_Pointer);

495
c/xlib/graphics.c
View File

@ -1,306 +1,239 @@
/* Copyright 2001-2003 by Norbert Freudemann, David Frese */
#include "xlib.h"
#include "scheme48.h"
/*
extern XDrawPoints(), XDrawLines(), XDrawRectangle(), XFillRectangle();
extern XDrawRectangles(), XFillRectangles(), XDrawArc(), XFillArc();
extern XDrawArcs(), XFillArcs(), XFillPolygon();
*/
s48_value scx_Clear_Area(s48_value Xwindow, s48_value Xdisplay, s48_value x,
s48_value y, s48_value w, s48_value h, s48_value e){
Window win = SCX_EXTRACT_WINDOW(Xwindow);
Display* dpy = SCX_EXTRACT_DISPLAY(Xdisplay);
XClearArea (dpy, win, (int)s48_extract_integer (x),
(int)s48_extract_integer (y), (int)s48_extract_integer (w),
(int)s48_extract_integer (h),
!S48_FALSE_P(e));
#define scx_extract_coord_mode(x) S48_EXTRACT_ENUM(x, "scx-coord-mode")
#define scx_extract_polygon_shape(x) S48_EXTRACT_ENUM(x, "scx-polygon-shape")
s48_value scx_Copy_Area(s48_value display, s48_value src, s48_value dest,
s48_value gc, s48_value srcx, s48_value srcy,
s48_value width, s48_value height, s48_value destx,
s48_value desty) {
XCopyArea(scx_extract_display(display), scx_extract_drawable(src),
scx_extract_drawable(dest), scx_extract_gc(gc),
(int)s48_extract_integer(srcx), (int)s48_extract_integer(srcy),
(int)s48_extract_integer(width), (int)s48_extract_integer(height),
(int)s48_extract_integer(destx), (int)s48_extract_integer(desty));
return S48_UNSPECIFIC;
}
s48_value scx_Copy_Area(s48_value Xdisplay,
s48_value srcXdrawable,s48_value Xgcontext,s48_value srcx,
s48_value srcy, s48_value width, s48_value height,
s48_value destXdrawable, s48_value destx,s48_value desty){
XCopyArea (SCX_EXTRACT_DISPLAY(Xdisplay), SCX_EXTRACT_DRAWABLE(srcXdrawable),
SCX_EXTRACT_DRAWABLE(destXdrawable), SCX_EXTRACT_GCONTEXT(Xgcontext),
(int)s48_extract_integer(srcx), (int)s48_extract_integer(srcy),
(int)s48_extract_integer(width), (int)s48_extract_integer(height),
(int)s48_extract_integer(destx), (int)s48_extract_integer(desty));
return S48_UNSPECIFIC;
}
/** REPLACED by NF in Copy_Plane:
...
p = (unsigned long)s48_extract_integer (plane);
if (p & (p-1))
Primitive_Error ("invalid plane: ~s", plane);
...
*/
s48_value scx_Copy_Plane(s48_value Xdisplay, s48_value srcXdrawable,
s48_value Xgcontext, s48_value plane, s48_value srcx,
s48_value srcy, s48_value width, s48_value height,
s48_value destXdrawable, s48_value destx, s48_value desty){
// Note: plane must have been set exactly one bit to 1.
// For further details, see the man-page.
unsigned long p = (unsigned long)s48_extract_integer(plane);
XCopyPlane(SCX_EXTRACT_DISPLAY(Xdisplay), SCX_EXTRACT_DRAWABLE(srcXdrawable),
SCX_EXTRACT_DRAWABLE(destXdrawable), SCX_EXTRACT_GCONTEXT(Xgcontext),
s48_value scx_Copy_Plane(s48_value display, s48_value src, s48_value dest,
s48_value gc, s48_value srcx, s48_value srcy,
s48_value width, s48_value height,
s48_value destx, s48_value desty, s48_value plane) {
XCopyPlane(scx_extract_display(display), scx_extract_drawable(src),
scx_extract_drawable(dest), scx_extract_gc(gc),
(int)s48_extract_integer(srcx), (int)s48_extract_integer(srcy),
(int)s48_extract_integer(width), (int)s48_extract_integer(height),
(int)s48_extract_integer(destx), (int)s48_extract_integer(desty),
(unsigned long)s48_extract_integer(plane));
return S48_UNSPECIFIC;
}
s48_value scx_Draw_Point(s48_value Xdisplay, s48_value Xdrawable,
s48_value Xgcontext, s48_value x, s48_value y){
XDrawPoint(SCX_EXTRACT_DISPLAY(Xdisplay), SCX_EXTRACT_DRAWABLE(Xdrawable),
SCX_EXTRACT_GCONTEXT(Xgcontext), (int)s48_extract_integer(x),
(int)s48_extract_integer (y));
return S48_UNSPECIFIC;
s48_value scx_Draw_Point(s48_value display, s48_value drawable,
s48_value gc, s48_value x, s48_value y) {
XDrawPoint(scx_extract_display(display), scx_extract_drawable(drawable),
scx_extract_gc(gc), (int)s48_extract_integer(x),
(int)s48_extract_integer(y));
return S48_UNSPECIFIC;
}
/* This Function is for internal use only! */
void Vector_To_XPoints(s48_value vec, XPoint* p, int n){
static void List_To_XPoints(s48_value l, XPoint* p, int n) {
int i;
for(i = 0; i < n; i++){
s48_value point = S48_VECTOR_REF(vec, i);
p[i].x = (int)s48_extract_integer (S48_CAR (point));
p[i].y = (int)s48_extract_integer (S48_CDR (point));
}
}
s48_value scx_Draw_Points (s48_value Xdisplay, s48_value Xdrawable,
s48_value Xgcontext, s48_value vec, s48_value relative){
// First, create a new XPoint from the vector of pairs...
int n = S48_VECTOR_LENGTH(vec);
XPoint p[n];
int mode;
Vector_To_XPoints(vec, p, n);
mode = !S48_FALSE_P(relative) ? CoordModePrevious : CoordModeOrigin;
XDrawPoints(SCX_EXTRACT_DISPLAY(Xdisplay), SCX_EXTRACT_DRAWABLE(Xdrawable),
SCX_EXTRACT_GCONTEXT(Xgcontext), p, n, mode);
return S48_UNSPECIFIC;
}
s48_value scx_Draw_Line (s48_value Xdisplay,s48_value Xdrawable,
s48_value Xgcontext, s48_value x1, s48_value y1,
s48_value x2, s48_value y2){
XDrawLine (SCX_EXTRACT_DISPLAY(Xdisplay),SCX_EXTRACT_DRAWABLE(Xdrawable),
SCX_EXTRACT_GCONTEXT(Xgcontext), (int)s48_extract_integer(x1),
(int)s48_extract_integer (y1), (int)s48_extract_integer (x2),
(int)s48_extract_integer (y2));
return S48_UNSPECIFIC;
}
s48_value scx_Draw_Lines(s48_value Xdisplay, s48_value Xdrawalbe,
s48_value Xgcontext, s48_value vec, s48_value relative){
int n = S48_VECTOR_LENGTH(vec);
XPoint p[n];
int mode;
Vector_To_XPoints(vec, p, n);
mode = !S48_FALSE_P(relative) ? CoordModePrevious : CoordModeOrigin;
XDrawLines(SCX_EXTRACT_DISPLAY(Xdisplay), SCX_EXTRACT_DRAWABLE(Xdrawalbe),
SCX_EXTRACT_GCONTEXT(Xgcontext), p, n, mode);
return S48_UNSPECIFIC;
}
s48_value scx_Draw_Segments (s48_value Xdisplay, s48_value Xdrawable,
s48_value Xgcontext, s48_value vec){
int i;
int n = S48_VECTOR_LENGTH(vec);
XSegment p[n];
for (i = 0; i < n; i++) {
s48_value seg = S48_VECTOR_REF(vec, i);
p[i].x1 = (int)s48_extract_integer (S48_VECTOR_REF(seg, 0));
p[i].y1 = (int)s48_extract_integer (S48_VECTOR_REF(seg, 1));
p[i].x2 = (int)s48_extract_integer (S48_VECTOR_REF(seg, 2));
p[i].y2 = (int)s48_extract_integer (S48_VECTOR_REF(seg, 3));
}
XDrawSegments (SCX_EXTRACT_DISPLAY(Xdisplay), SCX_EXTRACT_DRAWABLE(Xdrawable),
SCX_EXTRACT_GCONTEXT(Xgcontext), p, n);
return S48_UNSPECIFIC;
}
s48_value scx_Draw_Rectangle(s48_value Xdisplay, s48_value Xdrawable,
s48_value Xgcontext, s48_value rect) {
XDrawRectangle (SCX_EXTRACT_DISPLAY(Xdisplay), SCX_EXTRACT_DRAWABLE(Xdrawable),
SCX_EXTRACT_GCONTEXT(Xgcontext),
(int)s48_extract_integer(S48_VECTOR_REF(rect, 0)),
(int)s48_extract_integer(S48_VECTOR_REF(rect, 1)),
(int)s48_extract_integer(S48_VECTOR_REF(rect, 2)),
(int)s48_extract_integer(S48_VECTOR_REF(rect, 3)));
return S48_UNSPECIFIC;
}
s48_value scx_Fill_Rectangle (s48_value Xdisplay, s48_value Xdrawable,
s48_value Xgcontext, s48_value rect) {
XFillRectangle(SCX_EXTRACT_DISPLAY(Xdisplay), SCX_EXTRACT_DRAWABLE(Xdrawable),
SCX_EXTRACT_GCONTEXT(Xgcontext),
(int)s48_extract_integer(S48_VECTOR_REF(rect, 0)),
(int)s48_extract_integer(S48_VECTOR_REF(rect, 1)),
(int)s48_extract_integer(S48_VECTOR_REF(rect, 2)),
(int)s48_extract_integer(S48_VECTOR_REF(rect, 3)));
return S48_UNSPECIFIC;
}
//This Function is for internal use only!
void Vector_To_XRectangle(s48_value vec, XRectangle* p, int n) {
int i;
for (i = 0; i < n; i++){
s48_value rect;
rect = S48_VECTOR_REF(vec, i);
p[i].x = (int)s48_extract_integer(S48_VECTOR_REF(rect, 0));
p[i].y = (int)s48_extract_integer(S48_VECTOR_REF(rect, 1));
p[i].width = (int)s48_extract_integer(S48_VECTOR_REF(rect, 2));
p[i].height = (int)s48_extract_integer(S48_VECTOR_REF(rect, 3));
s48_value point = S48_CAR(l);
p[i].x = (int)s48_extract_integer(S48_CAR(point));
p[i].y = (int)s48_extract_integer(S48_CDR(point));
l = S48_CDR(l);
}
}
s48_value scx_Draw_Rectangles (s48_value Xdisplay, s48_value Xdrawable,
s48_value Xgcontext, s48_value vec){
int n = S48_VECTOR_LENGTH(vec);
XRectangle p[n];
Vector_To_XRectangle(vec, p, n);
XDrawRectangles(SCX_EXTRACT_DISPLAY(Xdisplay), SCX_EXTRACT_DRAWABLE(Xdrawable),
SCX_EXTRACT_GCONTEXT(Xgcontext), p, n);
return S48_UNSPECIFIC;
}
s48_value scx_Fill_Rectangles (s48_value Xdisplay, s48_value Xdrawable,
s48_value Xgcontext, s48_value vec){
int n = S48_VECTOR_LENGTH(vec);
XRectangle p[n];
Vector_To_XRectangle(vec, p, n);
XFillRectangles(SCX_EXTRACT_DISPLAY(Xdisplay), SCX_EXTRACT_DRAWABLE(Xdrawable),
SCX_EXTRACT_GCONTEXT(Xgcontext), p, n);
return S48_UNSPECIFIC;
}
s48_value scx_Draw_Arc (s48_value Xdisplay, s48_value Xdrawable,
s48_value Xgcontext, s48_value x,s48_value y, s48_value w,
s48_value h, s48_value a1, s48_value a2){
XDrawArc(SCX_EXTRACT_DISPLAY(Xdisplay), SCX_EXTRACT_DRAWABLE(Xdrawable),
SCX_EXTRACT_GCONTEXT(Xgcontext), (int)s48_extract_integer(x),
(int)s48_extract_integer(y), (int)s48_extract_integer(w),
(int)s48_extract_integer(h), (int)s48_extract_integer(a1),
(int)s48_extract_integer(a2));
return S48_UNSPECIFIC;
}
s48_value scx_Fill_Arc (s48_value Xdisplay, s48_value Xdrawable,
s48_value Xgcontext, s48_value x,s48_value y, s48_value w,
s48_value h, s48_value a1, s48_value a2){
XFillArc(SCX_EXTRACT_DISPLAY(Xdisplay), SCX_EXTRACT_DRAWABLE(Xdrawable),
SCX_EXTRACT_GCONTEXT(Xgcontext), (int)s48_extract_integer(x),
(int)s48_extract_integer(y), (int)s48_extract_integer(w),
(int)s48_extract_integer(h), (int)s48_extract_integer(a1),
(int)s48_extract_integer(a2));
return S48_UNSPECIFIC;
}
//This Function is for internal use only!
void Vector_To_XArc(s48_value vec, XArc* p, int n){
int i;
for (i = 0; i < n; i++){
s48_value arc = S48_VECTOR_REF(vec, i);
s48_value rect = S48_CAR(arc);
p[i].x = (int)s48_extract_integer (S48_CAR (rect)); rect = S48_CDR (rect);
p[i].y = (int)s48_extract_integer (S48_CAR (rect)); rect = S48_CDR (rect);
p[i].width = (int)s48_extract_integer (S48_CAR (rect));
rect = S48_CDR (rect);
p[i].height = (int)s48_extract_integer (S48_CAR (rect));
arc = S48_CDR (arc);
p[i].angle1 = (int)s48_extract_integer (S48_CAR (arc));
arc = S48_CDR (arc);
p[i].angle2 = (int)s48_extract_integer (S48_CAR (arc));
}
}
s48_value scx_Draw_Arcs (s48_value Xdisplay, s48_value Xdrawable,
s48_value Xgcontext, s48_value vec){
int n = S48_VECTOR_LENGTH(vec);
XArc p[n];
Vector_To_XArc(vec, p, n);
XDrawArcs(SCX_EXTRACT_DISPLAY(Xdisplay), SCX_EXTRACT_DRAWABLE(Xdrawable),
SCX_EXTRACT_GCONTEXT(Xgcontext), p, n);
return S48_UNSPECIFIC;
}
s48_value scx_Fill_Arcs (s48_value Xdisplay, s48_value Xdrawable,
s48_value Xgcontext, s48_value vec){
int n = S48_VECTOR_LENGTH(vec);
XArc p[n];
Vector_To_XArc(vec, p, n);
XFillArcs(SCX_EXTRACT_DISPLAY(Xdisplay), SCX_EXTRACT_DRAWABLE(Xdrawable),
SCX_EXTRACT_GCONTEXT(Xgcontext), p, n);
return S48_UNSPECIFIC;
}
s48_value scx_Fill_Polygon (s48_value Xdisplay, s48_value Xdrawable,
s48_value Xgcontext, s48_value vec,
s48_value relative, s48_value shape){
int n = S48_VECTOR_LENGTH(vec);
int mode;
int sh = s48_extract_integer(shape);
s48_value scx_Draw_Points(s48_value display, s48_value drawable,
s48_value gc, s48_value points, s48_value mode) {
int n = s48_list_length(points);
XPoint p[n];
Vector_To_XPoints(vec, p, n);
mode = !S48_FALSE_P(relative) ? CoordModePrevious : CoordModeOrigin;
XFillPolygon(SCX_EXTRACT_DISPLAY(Xdisplay), SCX_EXTRACT_DRAWABLE(Xdrawable),
SCX_EXTRACT_GCONTEXT(Xgcontext), p, n, sh, mode);
List_To_XPoints(points, p, n);
XDrawPoints(scx_extract_display(display), scx_extract_drawable(drawable),
scx_extract_gc(gc), p, n,
scx_extract_coord_mode(mode));
return S48_UNSPECIFIC;
}
s48_value scx_Draw_Line(s48_value display, s48_value drawable,
s48_value gc, s48_value x1, s48_value y1,
s48_value x2, s48_value y2) {
XDrawLine(scx_extract_display(display),scx_extract_drawable(drawable),
scx_extract_gc(gc), (int)s48_extract_integer(x1),
(int)s48_extract_integer(y1), (int)s48_extract_integer(x2),
(int)s48_extract_integer(y2));
return S48_UNSPECIFIC;
}
s48_value scx_Draw_Lines(s48_value display, s48_value drawable,
s48_value gc, s48_value points, s48_value mode) {
int n = s48_list_length(points);
XPoint p[n];
List_To_XPoints(points, p, n);
XDrawLines(scx_extract_display(display), scx_extract_drawable(drawable),
scx_extract_gc(gc), p, n,
scx_extract_coord_mode(mode));
return S48_UNSPECIFIC;
}
static void List_To_XSegments(s48_value l, XSegment* p, int n) {
int i;
s48_value rectype = s48_get_imported_binding("scx-segment");
for (i = 0; i < n; i++) {
s48_value s = S48_CAR(l);
s48_check_record_type(s, rectype);
p[i].x1 = (int)s48_extract_integer(S48_RECORD_REF(s, 0));
p[i].y1 = (int)s48_extract_integer(S48_RECORD_REF(s, 1));
p[i].x2 = (int)s48_extract_integer(S48_RECORD_REF(s, 2));
p[i].y2 = (int)s48_extract_integer(S48_RECORD_REF(s, 3));
l = S48_CDR(l);
}
}
s48_value scx_Draw_Segments(s48_value display, s48_value drawable,
s48_value gc, s48_value segs) {
int n = s48_list_length(segs);
XSegment p[n];
List_To_XSegments(segs, p, n);
XDrawSegments(scx_extract_display(display), scx_extract_drawable(drawable),
scx_extract_gc(gc), p, n);
return S48_UNSPECIFIC;
}
s48_value scx_Draw_Rectangle(s48_value display, s48_value drawable,
s48_value gc, s48_value x, s48_value y,
s48_value width, s48_value height) {
XDrawRectangle(scx_extract_display(display), scx_extract_drawable(drawable),
scx_extract_gc(gc),
(int)s48_extract_integer(x),
(int)s48_extract_integer(y),
(int)s48_extract_integer(width),
(int)s48_extract_integer(height));
return S48_UNSPECIFIC;
}
static void List_To_XRectangles(s48_value l, XRectangle* p, int n) {
int i;
s48_value rectype = s48_get_imported_binding("scx-rectangle");
for (i = 0; i < n; i++) {
s48_value r = S48_CAR(l);
s48_check_record_type(r, rectype);
p[i].x = (int)s48_extract_integer(S48_RECORD_REF(r, 0));
p[i].y = (int)s48_extract_integer(S48_RECORD_REF(r, 1));
p[i].width = (int)s48_extract_integer(S48_RECORD_REF(r, 2));
p[i].height = (int)s48_extract_integer(S48_RECORD_REF(r, 3));
l = S48_CDR(l);
}
}
s48_value scx_Draw_Rectangles(s48_value display, s48_value drawable,
s48_value gc, s48_value rects) {
int n = s48_list_length(rects);
XRectangle p[n];
List_To_XRectangles(rects, p, n);
XDrawRectangles(scx_extract_display(display), scx_extract_drawable(drawable),
scx_extract_gc(gc), p, n);
return S48_UNSPECIFIC;
}
s48_value scx_Draw_Arc(s48_value display, s48_value drawable,
s48_value gc, s48_value x, s48_value y, s48_value w,
s48_value h, s48_value a1, s48_value a2) {
XDrawArc(scx_extract_display(display), scx_extract_drawable(drawable),
scx_extract_gc(gc), (int)s48_extract_integer(x),
(int)s48_extract_integer(y), (int)s48_extract_integer(w),
(int)s48_extract_integer(h), (int)s48_extract_integer(a1),
(int)s48_extract_integer(a2));
return S48_UNSPECIFIC;
}
static void List_To_XArcs(s48_value l, XArc* p, int n) {
int i;
s48_value rectype = s48_get_imported_binding("scx-arc");
for (i = 0; i < n; i++) {
s48_value r = S48_CAR(l);
s48_check_record_type(r, rectype);
p[i].x = (int)s48_extract_integer(S48_RECORD_REF(r, 0));
p[i].y = (int)s48_extract_integer(S48_RECORD_REF(r, 1));
p[i].width = (int)s48_extract_integer(S48_RECORD_REF(r, 2));
p[i].height = (int)s48_extract_integer(S48_RECORD_REF(r, 3));
p[i].angle1 = (int)s48_extract_integer(S48_RECORD_REF(r, 4));
p[i].angle2 = (int)s48_extract_integer(S48_RECORD_REF(r, 5));
l = S48_CDR(l);
}
}
s48_value scx_Draw_Arcs(s48_value display, s48_value drawable,
s48_value gc, s48_value arcs) {
int n = s48_list_length(arcs);
XArc p[n];
List_To_XArcs(arcs, p, n);
XDrawArcs(scx_extract_display(display), scx_extract_drawable(drawable),
scx_extract_gc(gc), p, n);
return S48_UNSPECIFIC;
}
s48_value scx_Fill_Rectangle(s48_value display, s48_value drawable,
s48_value gc, s48_value x, s48_value y,
s48_value width, s48_value height) {
XFillRectangle(scx_extract_display(display), scx_extract_drawable(drawable),
scx_extract_gc(gc),
(int)s48_extract_integer(x),
(int)s48_extract_integer(y),
(int)s48_extract_integer(width),
(int)s48_extract_integer(height));
return S48_UNSPECIFIC;
}
s48_value scx_Fill_Rectangles(s48_value display, s48_value drawable,
s48_value gc, s48_value rects) {
int n = s48_list_length(rects);
XRectangle p[n];
List_To_XRectangles(rects, p, n);
XFillRectangles(scx_extract_display(display), scx_extract_drawable(drawable),
scx_extract_gc(gc), p, n);
return S48_UNSPECIFIC;
}
s48_value scx_Fill_Polygon(s48_value display, s48_value drawable,
s48_value gc, s48_value points,
s48_value shape, s48_value mode) {
int n = s48_list_length(points);
XPoint p[n];
List_To_XPoints(points, p, n);
XFillPolygon(scx_extract_display(display), scx_extract_drawable(drawable),
scx_extract_gc(gc), p, n,
scx_extract_polygon_shape(shape),
scx_extract_coord_mode(mode));
return S48_UNSPECIFIC;
}
s48_value scx_Fill_Arc(s48_value display, s48_value drawable,
s48_value gc, s48_value x, s48_value y, s48_value w,
s48_value h, s48_value a1, s48_value a2) {
XFillArc(scx_extract_display(display), scx_extract_drawable(drawable),
scx_extract_gc(gc), (int)s48_extract_integer(x),
(int)s48_extract_integer(y), (int)s48_extract_integer(w),
(int)s48_extract_integer(h), (int)s48_extract_integer(a1),
(int)s48_extract_integer(a2));
return S48_UNSPECIFIC;
}
s48_value scx_Fill_Arcs(s48_value display, s48_value drawable,
s48_value gc, s48_value arcs) {
int n = s48_list_length(arcs);
XArc p[n];
List_To_XArcs(arcs, p, n);
XFillArcs(scx_extract_display(display), scx_extract_drawable(drawable),
scx_extract_gc(gc), p, n);
return S48_UNSPECIFIC;
}
void scx_init_graphics(void) {
S48_EXPORT_FUNCTION(scx_Clear_Area);
S48_EXPORT_FUNCTION(scx_Copy_Area);
S48_EXPORT_FUNCTION(scx_Copy_Plane);
S48_EXPORT_FUNCTION(scx_Draw_Point);
@ -309,12 +242,12 @@ void scx_init_graphics(void) {
S48_EXPORT_FUNCTION(scx_Draw_Lines);
S48_EXPORT_FUNCTION(scx_Draw_Segments);
S48_EXPORT_FUNCTION(scx_Draw_Rectangle);
S48_EXPORT_FUNCTION(scx_Fill_Rectangle);
S48_EXPORT_FUNCTION(scx_Draw_Rectangles);
S48_EXPORT_FUNCTION(scx_Fill_Rectangles);
S48_EXPORT_FUNCTION(scx_Draw_Arc);
S48_EXPORT_FUNCTION(scx_Fill_Arc);
S48_EXPORT_FUNCTION(scx_Draw_Arcs);
S48_EXPORT_FUNCTION(scx_Fill_Arcs);
S48_EXPORT_FUNCTION(scx_Fill_Rectangle);
S48_EXPORT_FUNCTION(scx_Fill_Rectangles);
S48_EXPORT_FUNCTION(scx_Fill_Polygon);
S48_EXPORT_FUNCTION(scx_Fill_Arc);
S48_EXPORT_FUNCTION(scx_Fill_Arcs);
}

46
c/xlib/init.c
View File

@ -20,10 +20,54 @@ s48_value scx_Xlib_Release_6_Or_Later () {
#endif
}
void scx_init_init(void) {
extern void scx_init_types();
extern void scx_init_window();
extern void scx_init_display();
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_util();
extern void scx_init_grab();
extern void scx_init_visual();
extern void scx_init_region();
void scx_init_xlib(void) {
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);
scx_init_types();
scx_init_display();
scx_init_visual();
scx_init_colormap();
scx_init_cursor();
scx_init_error();
scx_init_event();
scx_init_font();
scx_init_gcontext();
scx_init_grab();
scx_init_graphics();
scx_init_key();
scx_init_property();
scx_init_text();
scx_init_window();
scx_init_wm();
scx_init_pixmap();
scx_init_client();
scx_init_util();
}

309
c/xlib/key.c
View File

@ -1,127 +1,218 @@
/* Copyright 2001-2003 by Norbert Freudemann, David Frese */
#include "xlib.h"
//#ifdef XLIB_RELEASE_5_OR_LATER
// I don't know if XDisplayKeycodes() was already there in X11R4.
// else: dpy->min_keycode dpy->max_keycode
s48_value scx_Change_Keyboard_Mapping(s48_value display,
s48_value first_keycode,
s48_value keysyms_lists) {
int max = 0, n = s48_list_length(keysyms_lists), i;
s48_value l = keysyms_lists;
for (i = 0; i < n; i++) {
int m = s48_list_length(S48_CAR(l));
if (m > max) max = m;
l = S48_CDR(l);
}
{
KeySym ks[max * n];
l = keysyms_lists;
for (i = 0; i < n; i++) {
s48_value l2 = S48_CAR(l);
int j, n2 = s48_list_length(l2);
for (j = 0; j < n2; j++) {
if (l2 == S48_NULL)
ks[i * max + j] = NoSymbol;
else {
ks[i * max + j] = scx_extract_keysym(S48_CAR(l2));
l2 = S48_CDR(l2);
}
}
l = S48_CDR(l);
}
s48_value scx_Display_Min_Keycode (s48_value d) {
int mink, maxk;
XDisplayKeycodes(SCX_EXTRACT_DISPLAY(d), &mink, &maxk);
return s48_enter_fixnum(mink);
}
s48_value scx_Display_Max_Keycode (s48_value d) {
int mink, maxk;
XDisplayKeycodes(SCX_EXTRACT_DISPLAY(d), &mink, &maxk);
return s48_enter_fixnum(maxk);
}
//#ifdef XLIB_RELEASE_5_OR_LATER
// I'm not sure if this works correctly in X11R4:
s48_value scx_Display_Keysyms_Per_Keycode (s48_value d) {
KeySym *ksyms;
int mink, maxk, ksyms_per_kode;
XDisplayKeycodes(SCX_EXTRACT_DISPLAY(d), &mink, &maxk);
ksyms = XGetKeyboardMapping(SCX_EXTRACT_DISPLAY(d), (KeyCode)mink,
maxk - mink + 1, &ksyms_per_kode);
XFree(ksyms);
return s48_enter_fixnum(ksyms_per_kode);
}
//#else
//static s48_value P_Display_Keysyms_Per_Keycode (d) s48_value d; {
// Check_Type (d, T_Display);
// // Force initialization:
// Disable_Interrupts;
// (void)XKeycodeToKeysym (DISPLAY(d)->dpy, DISPLAY(d)->dpy->min_keycode, 0);
// Enable_Interrupts;
// return s48_enter_fixnum (DISPLAY(d)->dpy->keysyms_per_keycode);
//}
//#endif
s48_value scx_String_To_Keysym (s48_value s) {
KeySym k = XStringToKeysym (s48_extract_string(s));
return k == NoSymbol ? S48_FALSE : s48_enter_integer ((unsigned long)k);
}
s48_value scx_Keysym_To_String (s48_value k) {
char* s = XKeysymToString ((KeySym)s48_extract_integer(k));
return s ? s48_enter_string(s) : S48_FALSE;
}
s48_value scx_Keycode_To_Keysym (s48_value d, s48_value k, s48_value index) {
KeySym ks;
//Disable_Interrupts;
ks = XKeycodeToKeysym(SCX_EXTRACT_DISPLAY(d),
(int)s48_extract_integer (k),
(int)s48_extract_integer (index));
//Enable_Interrupts;
if (ks == NoSymbol) return S48_FALSE;
else return s48_enter_integer((unsigned long)ks);
}
s48_value scx_Keysym_To_Keycode (s48_value d, s48_value k) {
KeyCode kc;
//Disable_Interrupts;
kc = XKeysymToKeycode (SCX_EXTRACT_DISPLAY(d),
(KeySym)s48_extract_integer(k));
//Enable_Interrupts;
return s48_enter_fixnum(kc);
}
s48_value scx_Lookup_String (s48_value d, s48_value k, s48_value mask) {
XKeyEvent e;
char buf[1024];
int len;
KeySym keysym_return;
XComposeStatus status_return;
e.display = SCX_EXTRACT_DISPLAY(d);
e.keycode = (int)s48_extract_integer(k);
e.state = s48_extract_integer(mask);
//Disable_Interrupts;
len = XLookupString (&e, buf, 1024, &keysym_return, &status_return);
//Enable_Interrupts;
return s48_enter_string(buf); //is there a 0 at buf[len] ?
}
s48_value scx_Rebind_Keysym (s48_value d, s48_value k, s48_value mods,
s48_value str) {
int i, n = S48_VECTOR_LENGTH(mods);
KeySym p[n];
for (i = 0; i < n; i++)
p[i] = (KeySym)s48_extract_integer(S48_VECTOR_REF(mods, i));
XRebindKeysym (SCX_EXTRACT_DISPLAY(d),
(KeySym)s48_extract_integer (k), p, n,
(unsigned char *)s48_extract_string(str),
S48_STRING_LENGTH(str));
XChangeKeyboardMapping(scx_extract_display(display),
s48_extract_integer(first_keycode),
max, ks, max * n);
}
return S48_UNSPECIFIC;
}
s48_value scx_Refresh_Keyboard_Mapping (s48_value d, s48_value w,
s48_value event) {
static XMappingEvent fake;
s48_value scx_Get_Keyboard_Mapping(s48_value display, s48_value first_keycode,
s48_value count) {
int kpk, ccount = s48_extract_integer(count);
KeySym* ks = XGetKeyboardMapping(scx_extract_display(display),
s48_extract_integer(first_keycode),
ccount, &kpk);
s48_value l = S48_NULL, l2 = S48_NULL;
int i;
S48_DECLARE_GC_PROTECT(2);
fake.type = MappingNotify;
fake.display = SCX_EXTRACT_DISPLAY(d);
fake.window = SCX_EXTRACT_WINDOW(w);
fake.request = s48_extract_integer(event);
XRefreshKeyboardMapping (&fake);
S48_GC_PROTECT_2(l, l2);
for (i = ccount; i > 0; i--) {
int j;
l2 = S48_NULL;
for (j = kpk; j > 0; j--) {
if (ks[i * kpk + j - 1] != NoSymbol)
l2 = s48_cons(scx_enter_keysym(ks[i * kpk + j - 1]), l2);
}
l = s48_cons(l2, l);
}
S48_GC_UNPROTECT();
XFree(ks);
return l;
}
s48_value scx_Display_Keycodes(s48_value display) {
int min, max;
XDisplayKeycodes(scx_extract_display(display), &min, &max);
return s48_cons(s48_enter_fixnum(min), s48_enter_fixnum(max));
}
s48_value scx_Set_Modifier_Mapping(s48_value display, s48_value modmap) {
int max = 0;
s48_value l = modmap;
for (; l != S48_NULL; l = S48_CDR(l)) {
int m = s48_list_length(S48_CDR(S48_CAR(l)));
if (m > max) max = m;
}
{
KeyCode ks[8*max];
XModifierKeymap cmap;
cmap.max_keypermod = max;
cmap.modifiermap = ks;
for (l = modmap; l != S48_NULL; l = S48_CDR(l)) {
int mod = scx_extract_state(S48_CAR(S48_CAR(l)));
s48_value l2 = S48_CDR(S48_CAR(l));
int j = 0;
for (j = 0; j < max; j++) {
if ((mod < 0) || (mod > 7)) continue; // TODO: error??
if (l2 != S48_NULL) {
ks[mod*max + j] = s48_extract_integer(S48_CAR(l2));
l2 = S48_CDR(l2);
} else
ks[mod*max + j] = 0;
}
}
return s48_enter_integer(XSetModifierMapping(scx_extract_display(display),
&cmap));
}
}
s48_value scx_Get_Modifier_Mapping(s48_value display) {
XModifierKeymap* km = XGetModifierMapping(scx_extract_display(display));
s48_value l = S48_NULL, l2 = S48_NULL;
int i;
S48_DECLARE_GC_PROTECT(2);
S48_GC_PROTECT_2(l, l2);
for (i = 7; i >= 0; i--) {
int j;
l2 = S48_NULL;
for (j = km->max_keypermod - 1; j >= 0; j--) {
KeyCode c = km->modifiermap[i*km->max_keypermod + j];
l2 = s48_cons(s48_enter_integer(c), l2);
}
l2 = s48_cons(scx_enter_state(i), l2);
l = s48_cons(l2, l);
}
S48_GC_UNPROTECT();
XFreeModifiermap(km);
return l;
}
s48_value scx_String_To_Keysym(s48_value string) {
return scx_enter_keysym(XStringToKeysym(s48_extract_string(string)));
}
s48_value scx_Keysym_To_String(s48_value ks) {
char* s = XKeysymToString(scx_extract_keysym(ks));
s48_value res = s48_enter_string(s);
XFree(s);
return res;
}
s48_value scx_Keycode_To_Keysym(s48_value display, s48_value kc, s48_value i) {
KeySym ks = XKeycodeToKeysym(scx_extract_display(display),
s48_extract_integer(kc),
s48_extract_integer(i));
return scx_enter_keysym(ks);
}
s48_value scx_Keysym_To_Keycode(s48_value display, s48_value ks) {
KeyCode kc = XKeysymToKeycode(scx_extract_display(display),
scx_extract_keysym(ks));
return s48_enter_integer(kc);
}
s48_value scx_Convert_Case(s48_value keysym) {
KeySym low, up;
XConvertCase(scx_extract_keysym(keysym), &low, &up);
return s48_cons(scx_enter_keysym(low), scx_enter_keysym(up));
}
s48_value scx_Lookup_Keysym(s48_value key_event, s48_value index) {
XKeyEvent ke;
scx_extract_key_event(key_event, &ke);
return scx_enter_keysym(XLookupKeysym(&ke, s48_extract_integer(index)));
}
s48_value scx_Refresh_Keyboard_Mapping(s48_value mapping_event) {
XMappingEvent e;
scx_extract_mapping_event(mapping_event, &e);
XRefreshKeyboardMapping(&e);
return S48_UNSPECIFIC;
}
s48_value scx_Lookup_String(s48_value key_event) {
XKeyEvent e;
char buf[1024];
int len;
KeySym keysym_return;
s48_value res = S48_FALSE;
S48_DECLARE_GC_PROTECT(1);
scx_extract_key_event(key_event);
len = XLookupString(&e, buf, 1023, &keysym_return, NULL);
buf[len] = 0;
S48_GC_PROTECT_1(res);
res = s48_enter_string(buf);
res = s48_cons(scx_enter_keysym(keysym_return), res);
S48_GC_UNPROTECT();
return res;
}
s48_value scx_Rebind_Keysym(s48_value display, s48_value keysym,
s48_value mod_keysyms, s48_value str) {
int i, n = s48_list_length(mod_keysyms);
KeySym mods[n];
for (i = 0; i < n; i++) {
mods[i] = scx_extract_keysym(S48_CAR(mod_keysyms));
mod_keysyms = S48_CDR(mod_keysyms);
}
XRebindKeysym(scx_extract_display(display),
scx_extract_keysym(keysym),
mods, n,
(unsigned char *)s48_extract_string(str),
S48_STRING_LENGTH(str));
return S48_UNSPECIFIC;
}
scx_init_key () {
S48_EXPORT_FUNCTION(scx_Display_Min_Keycode);
S48_EXPORT_FUNCTION(scx_Display_Max_Keycode);
S48_EXPORT_FUNCTION(scx_Display_Keysyms_Per_Keycode);
S48_EXPORT_FUNCTION(scx_Change_Keyboard_Mapping);
S48_EXPORT_FUNCTION(scx_Get_Keyboard_Mapping);
S48_EXPORT_FUNCTION(scx_Display_Keycodes);
S48_EXPORT_FUNCTION(scx_Set_Modifier_Mapping);
S48_EXPORT_FUNCTION(scx_Get_Modifier_Mapping);
S48_EXPORT_FUNCTION(scx_String_To_Keysym);
S48_EXPORT_FUNCTION(scx_Keysym_To_String);
S48_EXPORT_FUNCTION(scx_Keycode_To_Keysym);
S48_EXPORT_FUNCTION(scx_Keysym_To_Keycode);
S48_EXPORT_FUNCTION(scx_Convert_Case);
S48_EXPORT_FUNCTION(scx_Lookup_Keysym);
S48_EXPORT_FUNCTION(scx_Refresh_Keyboard_Mapping);
S48_EXPORT_FUNCTION(scx_Lookup_String);
S48_EXPORT_FUNCTION(scx_Rebind_Keysym);
S48_EXPORT_FUNCTION(scx_Refresh_Keyboard_Mapping);
}

141
c/xlib/pixmap.c
View File

@ -1,99 +1,96 @@
/* Copyright 2001-2003 by Norbert Freudemann, David Frese */
#include "xlib.h"
#include "scheme48.h"
s48_value scx_Create_Pixmap(s48_value display, s48_value drawable, s48_value w,
s48_value h, s48_value depth) {
Pixmap pm = XCreatePixmap(scx_extract_display(display),
scx_extract_drawable(drawable),
(int)s48_extract_integer(w),
(int)s48_extract_integer(h),
(int)s48_extract_integer(depth));
return scx_enter_pixmap(pm);
}
s48_value scx_Free_Pixmap (s48_value Xdisplay, s48_value Xpixmap){
XFreePixmap (SCX_EXTRACT_DISPLAY(Xdisplay), SCX_EXTRACT_PIXMAP(Xpixmap));
s48_value scx_Free_Pixmap(s48_value display, s48_value pixmap) {
XFreePixmap(scx_extract_display(display), scx_extract_pixmap(pixmap));
return S48_UNSPECIFIC;
}
s48_value scx_Create_Pixmap (s48_value Xdisplay, s48_value Xdrawable, s48_value w,
s48_value h, s48_value depth){
Pixmap pm = XCreatePixmap (SCX_EXTRACT_DISPLAY(Xdisplay),
SCX_EXTRACT_DRAWABLE(Xdrawable),
(int)s48_extract_integer (w),
(int)s48_extract_integer (h),
(int)s48_extract_integer (depth));
return SCX_ENTER_PIXMAP(pm);
}
s48_value scx_Create_Bitmap_From_Data (s48_value Xdisplay, s48_value Xdrawable,
s48_value data, s48_value w, s48_value h){
Pixmap pm = XCreateBitmapFromData (SCX_EXTRACT_DISPLAY(Xdisplay),
SCX_EXTRACT_DRAWABLE(Xdrawable),
s48_extract_string(data),
s48_extract_integer(w),
s48_extract_integer(h));
return SCX_ENTER_PIXMAP(pm);
}
s48_value scx_Create_Pixmap_From_Bitmap_Data (s48_value Xdisplay,
s48_value Xdrawable, s48_value data,
s48_value w,s48_value h, s48_value f,
s48_value b, s48_value d){
Pixmap pm = XCreatePixmapFromBitmapData (SCX_EXTRACT_DISPLAY(Xdisplay),
SCX_EXTRACT_DRAWABLE(Xdrawable),
s48_extract_string(data),
(int)s48_extract_integer(w),
(int)s48_extract_integer(h),
s48_extract_integer(f),
s48_extract_integer(b),
(int)s48_extract_integer(d));
return SCX_ENTER_PIXMAP(pm);
}
s48_value scx_Read_Bitmap_File (s48_value Xdisplay, s48_value Xdrawable,
s48_value file){
s48_value scx_Read_Bitmap_File(s48_value display, s48_value drawable,
s48_value filename) {
unsigned width, height;
int res, xhot, yhot;
Pixmap bitmap;
s48_value ret = S48_FALSE;
S48_DECLARE_GC_PROTECT(1);
// Not used: Disable_Interrupts;
res = XReadBitmapFile (SCX_EXTRACT_DISPLAY(Xdisplay),
SCX_EXTRACT_DRAWABLE(Xdrawable),
s48_extract_string(file), &width, &height, &bitmap,
&xhot, &yhot);
// Not used: Enable_Interrupts;
if (res != BitmapSuccess){
return s48_enter_integer(ret);
}
S48_GC_PROTECT_1 (ret);
ret = s48_cons (s48_enter_fixnum(yhot), S48_NULL);
ret = s48_cons (s48_enter_fixnum(xhot), ret);
ret = s48_cons (s48_enter_fixnum(height), ret);
ret = s48_cons (s48_enter_fixnum(width), ret);
ret = s48_cons (SCX_ENTER_PIXMAP(bitmap), ret);
res = XReadBitmapFile(scx_extract_display(display),
scx_extract_drawable(drawable),
s48_extract_string(filename), &width, &height, &bitmap,
&xhot, &yhot);
if (res != BitmapSuccess)
return s48_enter_integer(res);
S48_GC_PROTECT_1(ret);
ret = s48_cons(s48_enter_integer(yhot), S48_NULL);
ret = s48_cons(s48_enter_integer(xhot), ret);
ret = s48_cons(s48_enter_integer(height), ret);
ret = s48_cons(s48_enter_integer(width), ret);
ret = s48_cons(scx_enter_pixmap(bitmap), ret);
S48_GC_UNPROTECT();
return ret;
}
s48_value scx_Write_Bitmap_File (s48_value Xdisplay, s48_value file,
s48_value Xbitmap, s48_value w, s48_value h,
s48_value x, s48_value y){
s48_value scx_Write_Bitmap_File(s48_value display, s48_value filename,
s48_value bitmap, s48_value w, s48_value h,
s48_value x, s48_value y) {
int ret;
// Not used: Disable_Interrupts;
ret = XWriteBitmapFile (SCX_EXTRACT_DISPLAY(Xdisplay),
s48_extract_string(file),
SCX_EXTRACT_PIXMAP(Xbitmap),
(int)s48_extract_integer(w),
(int)s48_extract_integer(h),
(int)s48_extract_integer(x),
(int)s48_extract_integer(y));
// Enable_Interrupts;
ret = XWriteBitmapFile(scx_extract_display(display),
s48_extract_string(filename),
scx_extract_pixmap(bitmap),
(int)s48_extract_integer(w),
(int)s48_extract_integer(h),
(int)s48_extract_integer(x),
(int)s48_extract_integer(y));
return s48_enter_integer(ret);
}
s48_value scx_Create_Bitmap_From_Data(s48_value display, s48_value drawable,
s48_value data, s48_value w,
s48_value h) {
Pixmap pm = XCreateBitmapFromData(scx_extract_display(display),
scx_extract_drawable(drawable),
s48_extract_string(data),
s48_extract_integer(w),
s48_extract_integer(h));
return scx_enter_pixmap(pm);
}
s48_value scx_Create_Pixmap_From_Bitmap_Data(s48_value display,
s48_value drawable,
s48_value data,
s48_value w,s48_value h,
s48_value f, s48_value b,
s48_value depth) {
Pixmap pm = XCreatePixmapFromBitmapData(scx_extract_display(display),
scx_extract_drawable(drawable),
s48_extract_string(data),
(int)s48_extract_integer(w),
(int)s48_extract_integer(h),
scx_extract_pixel(f),
scx_extract_pixel(b),
(int)s48_extract_integer(depth));
return scx_enter_pixmap(pm);
}
void scx_init_pixmap(void) {
S48_EXPORT_FUNCTION(scx_Free_Pixmap);
S48_EXPORT_FUNCTION(scx_Create_Pixmap);
S48_EXPORT_FUNCTION(scx_Create_Bitmap_From_Data);
S48_EXPORT_FUNCTION(scx_Create_Pixmap_From_Bitmap_Data);
S48_EXPORT_FUNCTION(scx_Read_Bitmap_File);
S48_EXPORT_FUNCTION(scx_Write_Bitmap_File);
S48_EXPORT_FUNCTION(scx_Create_Bitmap_From_Data);
S48_EXPORT_FUNCTION(scx_Create_Pixmap_From_Bitmap_Data);
}

349
c/xlib/property.c
View File

@ -1,191 +1,228 @@
/* Copyright 2001-2003 by Norbert Freudemann, David Frese */
#include "xlib.h"
#include "scheme48.h"
/* Should be used with care */
s48_value scx_Intern_Atom (s48_value Xdisplay, s48_value name){
Atom a = XInternAtom(SCX_EXTRACT_DISPLAY(Xdisplay),
s48_extract_string(name), 0);
return SCX_ENTER_ATOM(a);
s48_value scx_Intern_Atom(s48_value display, s48_value name,
s48_value only_if_exists) {
Atom a = XInternAtom(scx_extract_display(display),
s48_extract_string(name),
S48_EXTRACT_BOOLEAN(only_if_exists));
return scx_enter_atom(a);
}
s48_value scx_Find_Atom (s48_value Xdisplay, s48_value name){
Atom a = XInternAtom (SCX_EXTRACT_DISPLAY(Xdisplay),
s48_extract_string(name), 1);
return SCX_ENTER_ATOM(a);
}
s48_value scx_Atom_Name (s48_value Xdisplay, s48_value a) {
char* s;
// not used: Disalbe_Interrupts
s = XGetAtomName (SCX_EXTRACT_DISPLAY(Xdisplay),
s48_extract_integer(a));
// not used: Enable_Interrupts
return s48_enter_string (s);
}
s48_value scx_List_Properties (s48_value Xwindow, s48_value Xdisplay){
int n, i;
Atom *ap;
s48_value v = S48_FALSE;
s48_value scx_Intern_Atoms(s48_value display, s48_value names,
s48_value only_if_exists) {
int i, n = s48_list_length(names);
char* cnames[n];
Atom atoms[n];
for (i = 0; i < n; i++)
cnames[i] = s48_extract_string(names);
if (!XInternAtoms(scx_extract_display(display),
cnames, n,
S48_EXTRACT_BOOLEAN(only_if_exists),
atoms))
return S48_FALSE;
else {
s48_value l = S48_NULL;
S48_DECLARE_GC_PROTECT(1);
//not used: Disable_Interrupts
ap = XListProperties (SCX_EXTRACT_DISPLAY(Xdisplay),
SCX_EXTRACT_WINDOW(Xwindow), &n);
//not used: Enable_Interrupts
v = s48_make_vector (n, S48_NULL);
S48_GC_PROTECT_1 (v);
for (i = 0; i < n; i++) {
S48_VECTOR_SET(v, i, s48_enter_integer((long) ap[i]));
}
S48_GC_UNPROTECT();
XFree ((char *)ap);
return v;
}
s48_value scx_Get_Property(s48_value Xwindow, s48_value Xdisplay,
s48_value Xatom_prop,
s48_value Xatom_type, s48_value start,
s48_value len, s48_value deletep) {
// Assumes short is 16 bits and int is 32 bits!
Atom req_type = S48_FALSE_P(Xatom_prop) ? AnyPropertyType
: SCX_EXTRACT_ATOM(Xatom_type);
Atom actual_type_ret;
int format_ret, i;
unsigned long nitems_ret, bytes_left_ret;
unsigned char* prop_ret = NULL;
s48_value ret = S48_FALSE, x = S48_FALSE, v = S48_FALSE;
S48_DECLARE_GC_PROTECT(3);
//not used: Disable_Interrupts
if (XGetWindowProperty (SCX_EXTRACT_DISPLAY(Xdisplay),
SCX_EXTRACT_WINDOW(Xwindow),
s48_extract_integer(Xatom_prop),
s48_extract_integer (start),
s48_extract_integer (len),
S48_EXTRACT_BOOLEAN(deletep),
req_type, &actual_type_ret, &format_ret, &nitems_ret,
&bytes_left_ret, &prop_ret) == Success) {
// Create the data as a vector
S48_GC_PROTECT_3 (ret, v, x);
v = s48_make_vector(nitems_ret, S48_FALSE);
for (i = 0; i < nitems_ret; i++) {
switch (format_ret) {
case 8: x = s48_enter_fixnum(((unsigned char*) prop_ret)[i]); break;
case 16: x = s48_enter_fixnum(((short*) prop_ret)[i]); break;
case 32: x = s48_enter_integer(((long*) prop_ret)[i]); break;
}
S48_VECTOR_SET(v, i, x);
}
ret = s48_cons(s48_enter_integer(bytes_left_ret), S48_NULL);
ret = s48_cons(v, ret);
ret = s48_cons(s48_enter_integer(format_ret), ret);
ret = s48_cons(SCX_ENTER_ATOM(actual_type_ret), ret);
S48_GC_UNPROTECT();
} else {
// Property does not exists
ret = S48_FALSE;
S48_GC_PROTECT_1(l);
for (i = n-1; i >= 0; i--)
l = s48_cons(scx_enter_atom(atoms[i]), l);
return l;
}
if (prop_ret != NULL)
XFree(prop_ret);
return ret;
}
s48_value scx_Change_Property(s48_value Xdisplay, s48_value Xwindow,
s48_value Xatom_prop, s48_value Xatom_type,
s48_value format, s48_value mode,
s48_value data) {
long i, x;
int f = (int)s48_extract_integer(format);
int m = s48_extract_integer(mode);
int nitems = S48_VECTOR_LENGTH(data);
unsigned char buf[nitems * f];
for (i = 0; i < nitems; i++) {
x = s48_extract_integer(S48_VECTOR_REF(data, i));
switch (f) {
case 8: ((char*) buf)[i] = (char)x; break;
case 16: ((short*) buf)[i] = (short)x; break;
case 32: ((long*) buf)[i] = (long)x; break;
}
}
XChangeProperty (SCX_EXTRACT_DISPLAY(Xdisplay), SCX_EXTRACT_WINDOW(Xwindow),
SCX_EXTRACT_ATOM(Xatom_prop), SCX_EXTRACT_ATOM(Xatom_type),
f, m, buf, nitems);
return S48_UNSPECIFIC;
s48_value scx_Get_Atom_Name(s48_value display, s48_value a) {
char* s;
s48_value str;
s = XGetAtomName(scx_extract_display(display),
scx_extract_atom(a));
str = s48_enter_string(s);
XFree(s);
return str;
}
s48_value scx_List_Properties(s48_value display, s48_value window) {
int n, i;
Atom *atoms;
s48_value l = S48_NULL;
S48_DECLARE_GC_PROTECT(1);
atoms = XListProperties (scx_extract_display(display),
scx_extract_window(window), &n);
s48_value scx_Delete_Property (s48_value Xdisplay, s48_value Xwindow,
s48_value Xatom_prop){
XDeleteProperty (SCX_EXTRACT_DISPLAY(Xdisplay), SCX_EXTRACT_WINDOW(Xwindow),
SCX_EXTRACT_ATOM(Xatom_prop));
return S48_UNSPECIFIC;
S48_GC_PROTECT_1(l);
for (i = n-1; i >= 0; i--)
l = s48_cons(scx_enter_atom(atoms[i]), l);
S48_GC_UNPROTECT();
XFree ((char*)atoms);
return l;
}
s48_value scx_Rotate_Properties (s48_value Xdisplay, s48_value Xwindow,
s48_value Xatom_vec, s48_value delta){
int n = S48_VECTOR_LENGTH(Xatom_vec), i;
s48_value scx_Rotate_Window_Properties(s48_value display, s48_value window,
s48_value properties, s48_value delta) {
int i, n = s48_list_length(properties);
Atom p[n];
for (i = 0; i < n; i++) {
p[i] = s48_extract_integer(S48_VECTOR_REF(Xatom_vec, i));
p[i] = scx_extract_atom(S48_CAR(properties));
properties = S48_CDR(properties);
}
XRotateWindowProperties(SCX_EXTRACT_DISPLAY(Xdisplay),
SCX_EXTRACT_WINDOW(Xwindow),
p, n, (int)s48_extract_integer(delta));
XRotateWindowProperties(scx_extract_display(display),
scx_extract_window(window),
p, n, s48_extract_integer(delta));
return S48_UNSPECIFIC;
}
s48_value scx_Set_Selection_Owner (s48_value Xdisplay, s48_value Xatom_s,
s48_value Xwindow_owner, s48_value time){
s48_value scx_Delete_Property(s48_value display, s48_value window,
s48_value prop) {
XDeleteProperty(scx_extract_display(display), scx_extract_window(window),
scx_extract_atom(prop));
return S48_UNSPECIFIC;
}
void scx_extract_property(s48_value p, Atom* type, int* format,
char** data, int* nelements) {
int i;
s48_value d = S48_RECORD_REF(p, 2);
s48_check_record_type(p, s48_get_imported_binding("scx-property"));
*type = scx_extract_atom(S48_RECORD_REF(p, 0));
*format = S48_EXTRACT_ENUM(S48_RECORD_REF(p, 1),
"scx-property-format");
switch (*format) {
case 0:
*format = 8;
*nelements = S48_STRING_LENGTH(d);
*data = (char*)malloc(*nelements);
strcpy(*data, s48_extract_string(d));
break;
case 1:
*format = 16;
*nelements = s48_list_length(d);
*data = (char*)malloc(2 * (*nelements));
for (i = 0; i < *nelements; i++) {
(*(short**)data)[i] = s48_extract_integer(S48_CAR(d));
d = S48_CDR(d);
}
break;
case 2:
*format = 32;
*nelements = s48_list_length(d);
*data = (char*)malloc(4 * (*nelements));
for (i = 0; i < *nelements; i++) {
(*(long**)data)[i] = s48_extract_integer(S48_CAR(d));
d = S48_CDR(d);
}
break;
}
}
s48_value scx_enter_property(Atom type, int format, char* data,
int nelements) {
s48_value p = s48_make_record(s48_get_imported_binding("scx-property"));
s48_value l = S48_NULL;
int i;
S48_DECLARE_GC_PROTECT(2);
S48_GC_PROTECT_2(p, l);
S48_RECORD_SET(p, 0, scx_enter_atom(type));
S48_RECORD_SET(p, 1, S48_ENTER_ENUM((format >> 3) - 1,
"scx-property-formats"));
switch (format) {
case 8:
S48_RECORD_SET(p, 2, s48_enter_substring(data, nelements));
case 16:
for (i = nelements-1; i >= 0; i--)
l = s48_cons(s48_enter_integer(((short*)data)[i]), l);
S48_RECORD_SET(p, 2, l);
case 32:
for (i = nelements-1; i >= 0; i--)
l = s48_cons(s48_enter_integer(((long*)data)[i]), l);
S48_RECORD_SET(p, 2, l);
}
S48_GC_UNPROTECT();
return p;
}
s48_value scx_Get_Window_Property(s48_value display, s48_value window,
s48_value atom, s48_value start,
s48_value len, s48_value deletep,
s48_value req_type) {
Atom actual_type;
int format, i;
unsigned long nitems, bytes_left;
unsigned char* data = NULL;
if (XGetWindowProperty (scx_extract_display(display),
scx_extract_window(window),
scx_extract_atom(atom),
s48_extract_integer(start),
s48_extract_integer(len),
S48_EXTRACT_BOOLEAN(deletep),
scx_extract_atom(req_type),
&actual_type, &format, &nitems,
&bytes_left, &data) == Success) {
s48_value p = scx_enter_property(actual_type, format, data, nitems);
s48_value res = S48_NULL;
S48_DECLARE_GC_PROTECT(1);
XFree(data);
S48_GC_PROTECT_1(p);
res = s48_cons(s48_enter_integer(bytes_left), p);
S48_GC_UNPROTECT();
return res;
} else
// Property does not exists
return S48_FALSE;
}
#define scx_extract_change_property_mode(x) \
S48_EXTRACT_ENUM(x, "scx-change-property-mode")
s48_value scx_Change_Property(s48_value display, s48_value window,
s48_value atom, s48_value mode,
s48_value property) {
Atom type;
int format, nelements;
char* data;
XSetSelectionOwner (SCX_EXTRACT_DISPLAY(Xdisplay), SCX_EXTRACT_ATOM(Xatom_s),
SCX_EXTRACT_WINDOW(Xwindow_owner), SCX_EXTRACT_TIME(time));
scx_extract_property(property, &type, &format, &data, &nelements);
XChangeProperty(scx_extract_display(display), scx_extract_window(window),
scx_extract_atom(atom), type, format,
scx_extract_change_property_mode(mode),
data, nelements);
free(data);
return S48_UNSPECIFIC;
}
s48_value scx_Get_Selection_Owner (s48_value Xdisplay, s48_value Xatom_s){
return SCX_ENTER_WINDOW(XGetSelectionOwner(SCX_EXTRACT_DISPLAY(Xdisplay),
SCX_EXTRACT_ATOM(Xatom_s)));
s48_value scx_Set_Selection_Owner(s48_value display, s48_value selection,
s48_value owner, s48_value time) {
XSetSelectionOwner(scx_extract_display(display), scx_extract_atom(selection),
scx_extract_window(owner), scx_extract_time(time));
return S48_UNSPECIFIC;
}
s48_value scx_Get_Selection_Owner(s48_value display, s48_value selection) {
return scx_enter_window(XGetSelectionOwner(scx_extract_display(display),
scx_extract_atom(selection)));
}
s48_value scx_Convert_Selection (s48_value Xdisplay, s48_value Xatom_s,
s48_value Xatom_t, s48_value Xatom_p,
s48_value Xwindow, s48_value time){
XConvertSelection(SCX_EXTRACT_DISPLAY(Xdisplay), SCX_EXTRACT_ATOM(Xatom_s),
SCX_EXTRACT_ATOM(Xatom_t), SCX_EXTRACT_ATOM(Xatom_p),
SCX_EXTRACT_WINDOW(Xwindow), SCX_EXTRACT_TIME(time));
return S48_UNSPECIFIC;
s48_value scx_Convert_Selection(s48_value display, s48_value selection,
s48_value target, s48_value property,
s48_value requestor, s48_value time) {
XConvertSelection(scx_extract_display(display), scx_extract_atom(selection),
scx_extract_atom(target), scx_extract_atom(property),
scx_extract_window(requestor), scx_extract_time(time));
return S48_UNSPECIFIC;
}
void scx_init_property(void) {
S48_EXPORT_FUNCTION(scx_Intern_Atom);
S48_EXPORT_FUNCTION(scx_Find_Atom);
S48_EXPORT_FUNCTION(scx_Atom_Name);
S48_EXPORT_FUNCTION(scx_Intern_Atoms);
S48_EXPORT_FUNCTION(scx_Get_Atom_Name);
S48_EXPORT_FUNCTION(scx_List_Properties);
S48_EXPORT_FUNCTION(scx_Get_Property);
S48_EXPORT_FUNCTION(scx_Change_Property);
S48_EXPORT_FUNCTION(scx_Rotate_Window_Properties);
S48_EXPORT_FUNCTION(scx_Delete_Property);
S48_EXPORT_FUNCTION(scx_Rotate_Properties);
S48_EXPORT_FUNCTION(scx_Get_Window_Property);
S48_EXPORT_FUNCTION(scx_Change_Property);
S48_EXPORT_FUNCTION(scx_Set_Selection_Owner);
S48_EXPORT_FUNCTION(scx_Get_Selection_Owner);
S48_EXPORT_FUNCTION(scx_Convert_Selection);

326
c/xlib/text.c
View File

@ -1,194 +1,152 @@
/* Copyright 2001-2003 by Norbert Freudemann, David Frese */
#include "xlib.h"
#include "scheme48.h"
#include <stdio.h>
extern XDrawText(), XDrawText16();
/* Calculation of text widths and extents should not be done using
* the Xlib functions. For instance, the values returned by
* XTextExtents() are only shorts and can therefore overflow for
* long strings.
*/
s48_value scx_Text_Width(s48_value Xfontstruct, s48_value text,
s48_value format){
int len = (int)S48_VECTOR_LENGTH(text), i, tmp;
char s[len];
XChar2b s2[len];
XFontStruct* font = SCX_EXTRACT_FONTSTRUCT(Xfontstruct);
if (s48_extract_integer(format) == 1){
for (i = 0; i < len; i++){
tmp = (int)s48_extract_integer(S48_VECTOR_REF(text, i));
s2[i].byte1 = (tmp >> 8) & 0xff;
s2[i].byte2 = tmp & 0xff;
}
i = XTextWidth16(font, s2, len);
}
else{
for (i = 0; i < len; i++){
s[i] = (int)s48_extract_integer(S48_VECTOR_REF(text, i));
}
i = XTextWidth(font, s, len);
}
return s48_enter_fixnum((long)i);
}
s48_value scx_Extents_Text (s48_value Xfontstruct, s48_value text,
s48_value format, s48_value which){
int len = (int)S48_VECTOR_LENGTH(text), i, tmp, dir, fasc, fdesc;
char s[len];
XChar2b s2[len];
XFontStruct* font = SCX_EXTRACT_FONTSTRUCT(Xfontstruct);
XCharStruct CI;
if (s48_extract_integer(format) == 1){
for (i = 0; i < len; i++){
tmp = (int)s48_extract_integer(S48_VECTOR_REF(text, i));
s2[i].byte1 = (tmp >> 8) & 0xff;
s2[i].byte2 = tmp & 0xff;
}
XTextExtents16(font, s2, len, &dir, &fasc, &fdesc, &CI);
}else{
for (i = 0; i < len; i++){
s[i] = (int)s48_extract_integer(S48_VECTOR_REF(text, i));
}
XTextExtents(font, s, len, &dir, &fasc, &fdesc, &CI);
}
switch(s48_extract_integer(which)){
case 0:
return s48_enter_fixnum((long) CI.lbearing);
case 1:
return s48_enter_fixnum((long) CI.rbearing);
case 2:
return s48_enter_fixnum((long) CI.width);
case 3:
return s48_enter_fixnum((long) CI.ascent);
case 4:
return s48_enter_fixnum((long) CI.descent);
}
return S48_FALSE;
}
s48_value scx_Draw_Image_Text (s48_value Xdisplay, s48_value Xdrawable,
s48_value Xgcontext, s48_value x, s48_value y,
s48_value text, s48_value is_twobyte){
int i, len, tmp;
len = S48_VECTOR_LENGTH(text);
if (!S48_FALSE_P(is_twobyte)) {
XChar2b s2[len];
for (i = 0; i < len; i++) {
tmp = (int)s48_extract_integer(S48_VECTOR_REF(text, i));
s2[i].byte1 = (tmp >> 8) & 0xff;
s2[i].byte2 = tmp & 0xff;
}
XDrawImageString16 (SCX_EXTRACT_DISPLAY(Xdisplay),
SCX_EXTRACT_DRAWABLE(Xdrawable),
SCX_EXTRACT_GCONTEXT(Xgcontext),
(int)s48_extract_integer(x),
(int)s48_extract_integer(y),
s2, len);
} else {
char s[len];
for (i = 0; i < len; i++) {
s[i] = (int)s48_extract_integer(S48_VECTOR_REF(text, i));
}
XDrawImageString (SCX_EXTRACT_DISPLAY(Xdisplay),
SCX_EXTRACT_DRAWABLE(Xdrawable),
SCX_EXTRACT_GCONTEXT(Xgcontext),
(int)s48_extract_integer(x),
(int)s48_extract_integer(y),
s, len);
}
s48_value scx_Draw_Image_String(s48_value display, s48_value drawable,
s48_value gc, s48_value x, s48_value y,
s48_value string) {
XDrawImageString(scx_extract_display(display),
scx_extract_drawable(drawable),
scx_extract_gc(gc),
s48_extract_integer(x),
s48_extract_integer(y),
s48_extract_string(string),
S48_STRING_LENGTH(string));
return S48_UNSPECIFIC;
}
// Draw_Poly_Text processes a vector like [[24 23 87 67] Xfont [12 0]] and
// passes it to XDrawPolyText or XDrawPolyText16
s48_value scx_Draw_Poly_Text (s48_value Xdisplay, s48_value Xdrawable,
s48_value Xgcontext, s48_value x, s48_value y,
s48_value text, s48_value is_twobyte) {
int i, len, nitems;
s48_value temp_vec = S48_FALSE;
char twobyte = !S48_FALSE_P(is_twobyte);
len = S48_VECTOR_LENGTH(text);
// Nothing to do with an empty vector.
if (len == 0) return S48_UNSPECIFIC;
// count the strings in text:
nitems = 0;
s48_value scx_Draw_Image_String_16(s48_value display, s48_value drawable,
s48_value gc, s48_value x, s48_value y,
s48_value string) {
int i, len = s48_list_length(string);
XChar2b chars[len];
for (i = 0; i < len; i++) {
if (S48_VECTOR_P(S48_VECTOR_REF(text, i)))
nitems++;
}
{
XTextItem item[nitems];
int set = 0, j, k, tmp;
//Maybe no font as first Element of text?
if (S48_VECTOR_P(S48_VECTOR_REF(text, 0))) {
item[0].delta = 0;
item[0].font = None;
}
// Generate the XTextItem{16}
for (i = 0; i < len; i++) {
if (S48_VECTOR_P(S48_VECTOR_REF(text,i))) {
temp_vec = S48_VECTOR_REF(text,i);
k = S48_VECTOR_LENGTH(temp_vec);
item[set].nchars = k;
if (twobyte) {
XChar2b* s2 = (XChar2b*)malloc(sizeof(XChar2b)*k);
for (j = 0; j < k; j++){
tmp = (int)s48_extract_integer(S48_VECTOR_REF(temp_vec, j));
s2[j].byte1 = (tmp >> 8) & 0xff;
s2[j].byte2 = tmp & 0xff;
}
(XTextItem16*)item[set].chars = s2;
} else {
char* s = (char*)malloc(sizeof(char)*k);
for (j = 0; j < k; j++) {
s[j] = (int)s48_extract_integer(S48_VECTOR_REF(temp_vec, j));
}
item[set].chars = s;
}
set++;
} else {
s48_value fontspec = S48_VECTOR_REF(text, i);
s48_value font = S48_CAR(fontspec);
item[set].font = SCX_EXTRACT_FONT(font);
item[set].delta = s48_extract_integer(S48_CDR(fontspec));
}
}
// No pass it all to the Xlib
if (twobyte) {
XDrawText16(SCX_EXTRACT_DISPLAY(Xdisplay),
SCX_EXTRACT_DRAWABLE(Xdrawable),
SCX_EXTRACT_GCONTEXT(Xgcontext),
(int)s48_extract_integer(x), (int)s48_extract_integer(y),
(XTextItem16*) item, nitems);
} else {
XDrawText(SCX_EXTRACT_DISPLAY(Xdisplay), SCX_EXTRACT_DRAWABLE(Xdrawable),
SCX_EXTRACT_GCONTEXT(Xgcontext), (int)s48_extract_integer(x),
(int)s48_extract_integer(y), item, nitems);
}
// No free all character-arrays
for (i = 0; i < nitems; i++)
free(item[i].chars);
chars[i].byte1 = s48_extract_char(S48_CAR(S48_CAR(string)));
chars[i].byte2 = s48_extract_char(S48_CDR(S48_CAR(string)));
string = S48_CDR(string);
}
XDrawImageString16(scx_extract_display(display),
scx_extract_drawable(drawable),
scx_extract_gc(gc),
s48_extract_integer(x),
s48_extract_integer(y),
chars, len);
return S48_UNSPECIFIC;
}
void scx_init_text(void) {
S48_EXPORT_FUNCTION(scx_Text_Width);
S48_EXPORT_FUNCTION(scx_Extents_Text);
S48_EXPORT_FUNCTION(scx_Draw_Image_Text);
S48_EXPORT_FUNCTION(scx_Draw_Poly_Text);
s48_value scx_text_item = S48_FALSE;
void scx_extract_text_item(s48_value v, XTextItem* ti) {
s48_check_record_type(v, scx_text_item);
if (S48_RECORD_REF(v, 0) != S48_FALSE) {
ti->nchars = S48_STRING_LENGTH(S48_RECORD_REF(v, 0));
ti->chars = (char*)malloc(ti->nchars);
strncpy(ti->chars, s48_extract_string(S48_RECORD_REF(v, 0)), ti->nchars);
} else {
ti->chars = NULL;
ti->nchars = 0;
}
ti->delta = s48_extract_integer(S48_RECORD_REF(v, 1));
ti->font = scx_extract_font(S48_RECORD_REF(v, 2));
// Free all chars arrays!
}
void scx_extract_text_item_16(s48_value v, XTextItem16* ti) {
s48_check_record_type(v, scx_text_item);
{
if (S48_RECORD_REF(v, 0) != S48_FALSE) {
s48_value l = S48_RECORD_REF(v, 0);
int i, n = s48_list_length(l);
XChar2b* s = (XChar2b*)malloc(n * sizeof(XChar2b));
for (i = n-1; i >= 0; i--) {
ti->chars[i].byte1 = s48_extract_integer(S48_CAR(S48_CAR(l)));
ti->chars[i].byte2 = s48_extract_integer(S48_CDR(S48_CAR(l)));
}
ti->nchars = n;
} else {
ti->chars = NULL;
ti->nchars = 0;
}
ti->delta = s48_extract_integer(S48_RECORD_REF(v, 1));
ti->font = scx_extract_font(S48_RECORD_REF(v, 2));
}
// Free all chars arrays!
}
s48_value scx_Draw_Text(s48_value display, s48_value drawable,
s48_value gc, s48_value x, s48_value y,
s48_value items) {
int i, len = s48_list_length(items);
XTextItem parts[len];
for (i = 0; i < len; i++) {
scx_extract_text_item(S48_CAR(items), &parts[i]);
items = S48_CDR(items);
}
XDrawText(scx_extract_display(display),
scx_extract_drawable(drawable),
scx_extract_gc(gc),
s48_extract_integer(x),
s48_extract_integer(y),
parts, len);
for (i = 0; i < len; i++)
free(parts[i].chars);
return S48_UNSPECIFIC;
}
s48_value scx_Draw_Text_16(s48_value display, s48_value drawable,
s48_value gc, s48_value x, s48_value y,
s48_value items) {
int i, len = s48_list_length(items);
XTextItem16 parts[len];
for (i = 0; i < len; i++) {
scx_extract_text_item_16(S48_CAR(items), &parts[i]);
items = S48_CDR(items);
}
XDrawText16(scx_extract_display(display),
scx_extract_drawable(drawable),
scx_extract_gc(gc),
s48_extract_integer(x),
s48_extract_integer(y),
parts, len);
for (i = 0; i < len; i++)
free(parts[i].chars);
return S48_UNSPECIFIC;
}
s48_value scx_Text_Extents(s48_value font_struct, s48_value string) {
XCharStruct overall;
XTextExtents(scx_extract_fontstruct(font_struct),
s48_extract_string(string),
S48_STRING_LENGTH(string),
NULL, NULL, NULL,
&overall);
return scx_enter_charstruct(&overall);
}
s48_value scx_Text_Extents_16(s48_value font_struct, s48_value string) {
XCharStruct overall;
int i, len = s48_list_length(string);
XChar2b chars[len];
for (i = 0; i < len; i++) {
chars[i].byte1 = s48_extract_char(S48_CAR(S48_CAR(string)));
chars[i].byte2 = s48_extract_char(S48_CDR(S48_CAR(string)));
string = S48_CDR(string);
}
XTextExtents16(scx_extract_fontstruct(font_struct),
chars, len,
NULL, NULL, NULL,
&overall);
return scx_enter_charstruct(&overall);
}
void scx_init_text(void) {
S48_GC_PROTECT_GLOBAL(scx_text_item);
scx_text_item = s48_get_imported_binding("scx-text-item");
S48_EXPORT_FUNCTION(scx_Draw_Image_String);
S48_EXPORT_FUNCTION(scx_Draw_Image_String_16);
S48_EXPORT_FUNCTION(scx_Draw_Text);
S48_EXPORT_FUNCTION(scx_Draw_Text_16);
S48_EXPORT_FUNCTION(scx_Text_Extents);
S48_EXPORT_FUNCTION(scx_Text_Extents_16);
}

63
c/xlib/types.c Normal file
View File

@ -0,0 +1,63 @@
/* Copyright 2001-2003 by Norbert Freudemann, David Frese */
#include "xlib.h"
s48_value s48_checked_record_ref(s48_value value, int i,
s48_value rectype) {
s48_check_record_type(value, rectype);
return S48_RECORD_REF(value, i);
}
int s48_list_length(s48_value list) {
int res = 0;
while (list != S48_NULL) {
res++;
list = S48_CDR(list);
}
return res;
}
s48_value s48_enter_enum_set(unsigned long v, char* typestr) {
s48_value r = s48_make_record(s48_get_imported_binding("s48-enum-set-type"));
S48_DECLARE_GC_PROTECT(1);
S48_GC_PROTECT_1(r);
S48_RECORD_SET(r, 0,
S48_SHARED_BINDING_REF(s48_get_imported_binding(typestr)));
S48_RECORD_SET(r, 1, s48_enter_integer(v));
S48_GC_UNPROTECT();
return r;
}
s48_value scx_struct_cache_ref(void* cpointer, s48_value list) {
while (list != S48_NULL) {
if (S48_EXTRACT_POINTER(S48_CAR(S48_CAR(list))) == cpointer)
return S48_WEAK_POINTER_REF(S48_CDR(S48_CAR(list)));
list = S48_CDR(list);
}
return S48_FALSE;
}
void scx_struct_cache_set(void* cpointer, s48_value* l, s48_value v) {
s48_value list = *l;
s48_value wp = S48_FALSE;
S48_DECLARE_GC_PROTECT(2);
while (list != S48_NULL) {
if (S48_EXTRACT_POINTER(S48_CAR(S48_CAR(list))) == cpointer) {
S48_GC_PROTECT_1(list);
wp = s48_make_weak_pointer(v);
S48_SET_CDR(S48_CAR(list), wp);
S48_GC_UNPROTECT();
return;
}
list = S48_CDR(list);
}
S48_GC_PROTECT_2(list, wp);
// TODO: if not found, use first free entry to keep list small...
wp = s48_make_weak_pointer(v);
wp = s48_cons(S48_ENTER_POINTER(cpointer), wp);
*l = s48_cons(wp, *l);
S48_GC_UNPROTECT();
}
void scx_init_types(void) {
}

34
c/xlib/util.c
View File

@ -1,27 +1,23 @@
#include "xlib.h"
#include "scheme48.h"
s48_value scx_Get_Default (s48_value Xdpy, s48_value program,
s48_value option) {
s48_value scx_Get_Default(s48_value dpy, s48_value program,
s48_value option) {
char* ret;
if (ret = XGetDefault (SCX_EXTRACT_DISPLAY(Xdpy),
s48_extract_string(program),
s48_extract_string(option)))
if (ret = XGetDefault(scx_extract_display(dpy),
s48_extract_string(program),
s48_extract_string(option)))
return s48_enter_string(ret);
return S48_FALSE;
else return S48_FALSE;
}
s48_value scx_Resource_Manager_String (s48_value Xdpy) {
s48_value scx_Resource_Manager_String(s48_value dpy) {
char* ret;
ret = XResourceManagerString (SCX_EXTRACT_DISPLAY(Xdpy));
return ret ? s48_enter_string(ret) : S48_FALSE;
if (ret = XResourceManagerString (scx_extract_display(dpy)))
return s48_enter_string(ret);
else return S48_FALSE;
}
s48_value scx_Parse_Geometry (s48_value strg) {
s48_value scx_Parse_Geometry(s48_value strg) {
s48_value ret;
int x, y, res;
unsigned int w, h;
@ -34,10 +30,10 @@ s48_value scx_Parse_Geometry (s48_value strg) {
S48_GC_PROTECT_1(ret);
if (res & XNegative) S48_VECTOR_SET(ret, 0, S48_TRUE);
if (res & YNegative) S48_VECTOR_SET(ret, 1, S48_TRUE);
if (res & XValue) S48_VECTOR_SET(ret, 2, s48_enter_fixnum(x));
if (res & YValue) S48_VECTOR_SET(ret, 3, s48_enter_fixnum(y));
if (res & WidthValue) S48_VECTOR_SET(ret, 4, s48_enter_fixnum(w));
if (res & HeightValue) S48_VECTOR_SET(ret, 5, s48_enter_fixnum (h));
if (res & XValue) S48_VECTOR_SET(ret, 2, s48_enter_integer(x));
if (res & YValue) S48_VECTOR_SET(ret, 3, s48_enter_integer(y));
if (res & WidthValue) S48_VECTOR_SET(ret, 4, s48_enter_integer(w));
if (res & HeightValue) S48_VECTOR_SET(ret, 5, s48_enter_integer(h));
S48_GC_UNPROTECT();
return ret;

172
c/xlib/visual.c
View File

@ -1,97 +1,121 @@
/* Copyright 2001-2003 by Norbert Freudemann, David Frese */
#include "xlib.h"
s48_value Enter_Visual_And_Visual_Info(XVisualInfo* vi) {
s48_value t = s48_make_vector(10, S48_FALSE);
#define scx_extract_visual_class(x) S48_EXTRACT_ENUM(x, "scx-visual-class")
#define scx_enter_visual_class(x) S48_ENTER_ENUM(x, "scx-visual-classes")
s48_value scx_enter_visual(Visual* vis) {
s48_value v = s48_make_record(scx_visual);
S48_DECLARE_GC_PROTECT(1);
S48_GC_PROTECT_1(t);
S48_VECTOR_SET(t, 0, s48_enter_integer(vi->visualid));
S48_VECTOR_SET(t, 1, s48_enter_fixnum(vi->screen));
S48_VECTOR_SET(t, 2, s48_enter_fixnum(vi->depth));
S48_VECTOR_SET(t, 3, s48_enter_integer(vi->class));
S48_VECTOR_SET(t, 4, s48_enter_integer(vi->red_mask));
S48_VECTOR_SET(t, 5, s48_enter_integer(vi->green_mask));
S48_VECTOR_SET(t, 6, s48_enter_integer(vi->blue_mask));
S48_VECTOR_SET(t, 7, s48_enter_integer(vi->colormap_size));
S48_VECTOR_SET(t, 8, s48_enter_fixnum(vi->bits_per_rgb));
t = s48_cons(s48_enter_integer(VisualAllMask), t);
t = s48_cons(SCX_ENTER_VISUAL(vi->visual), t);
S48_GC_PROTECT_1(v);
S48_RECORD_SET(v, 0, S48_ENTER_POINTER(vis));
S48_GC_UNPROTECT();
return t;
return v;
}
unsigned long Extract_Visual_Info(s48_value vi, XVisualInfo* VI) {
unsigned long mask = s48_extract_integer(S48_CAR(vi));
s48_value v = S48_CDR(vi);
if (mask & VisualIDMask)
VI->visualid = s48_extract_integer(S48_VECTOR_REF(v, 0));
if (mask & VisualScreenMask)
VI->screen = s48_extract_integer(S48_VECTOR_REF(v, 1));
if (mask & VisualDepthMask)
VI->depth = s48_extract_integer(S48_VECTOR_REF(v, 2));
if (mask & VisualClassMask)
VI->class = s48_extract_integer(S48_VECTOR_REF(v, 3));
if (mask & VisualRedMaskMask)
VI->red_mask = s48_extract_integer(S48_VECTOR_REF(v, 4));
if (mask & VisualGreenMaskMask)
VI->green_mask = s48_extract_integer(S48_VECTOR_REF(v, 5));
if (mask & VisualBlueMaskMask)
VI->blue_mask = s48_extract_integer(S48_VECTOR_REF(v, 6));
if (mask & VisualColormapSizeMask)
VI->colormap_size = s48_extract_integer(S48_VECTOR_REF(v, 7));
if (mask & VisualBitsPerRGBMask)
VI->bits_per_rgb = s48_extract_integer(S48_VECTOR_REF(v, 8));
#define scx_visual_info s48_get_imported_binding("scx-visual-info")
s48_value scx_enter_visual_info(XVisualInfo* vi) {
s48_value v = s48_make_record(scx_visual_info);
S48_DECLARE_GC_PROTECT(1);
S48_GC_PROTECT_1(v);
S48_RECORD_SET(v, 0, scx_enter_visual(vi->visual));
S48_RECORD_SET(v, 1, scx_enter_visualid(vi->visualid));
S48_RECORD_SET(v, 2, s48_enter_integer(vi->screen));
S48_RECORD_SET(v, 3, s48_enter_integer(vi->depth));
S48_RECORD_SET(v, 4, scx_enter_visual_class(vi->class));
S48_RECORD_SET(v, 5, s48_enter_integer(vi->red_mask));
S48_RECORD_SET(v, 6, s48_enter_integer(vi->green_mask));
S48_RECORD_SET(v, 7, s48_enter_integer(vi->blue_mask));
S48_RECORD_SET(v, 8, s48_enter_integer(vi->bits_per_rgb));
S48_RECORD_SET(v, 9, s48_enter_integer(vi->colormap_size));
S48_GC_UNPROTECT();
return v;
}
unsigned int scx_extract_visual_info(s48_value v, XVisualInfo* vi) {
unsigned long mask = 0;
s48_check_record_type(v, scx_visual_info);
if (!S48_FALSE_P(S48_RECORD_REF(v, 0)))
vi->visual = scx_extract_visual(S48_RECORD_REF(v, 0));
if (!S48_FALSE_P(S48_RECORD_REF(v, 1))) {
vi->visualid = scx_extract_visualid(S48_RECORD_REF(v, 1));
mask |= VisualIDMask;
}
if (!S48_FALSE_P(S48_RECORD_REF(v, 2))) {
vi->screen = s48_extract_integer(S48_RECORD_REF(v, 2));
mask |= VisualScreenMask;
}
if (!S48_FALSE_P(S48_RECORD_REF(v, 3))) {
vi->depth = s48_extract_integer(S48_RECORD_REF(v, 4));
mask |= VisualDepthMask;
}
if (!S48_FALSE_P(S48_RECORD_REF(v, 4))) {
vi->class = scx_extract_visual_class(S48_RECORD_REF(v, 5));
mask |= VisualClassMask;
}
if (!S48_FALSE_P(S48_RECORD_REF(v, 5))) {
vi->red_mask = s48_extract_integer(S48_RECORD_REF(v, 6));
mask |= VisualRedMaskMask;
}
if (!S48_FALSE_P(S48_RECORD_REF(v, 6))) {
vi->green_mask = s48_extract_integer(S48_RECORD_REF(v, 7));
mask |= VisualGreenMaskMask;
}
if (!S48_FALSE_P(S48_RECORD_REF(v, 7))) {
vi->blue_mask = s48_extract_integer(S48_RECORD_REF(v, 8));
mask |= VisualBlueMaskMask;
}
if (!S48_FALSE_P(S48_RECORD_REF(v, 8))) {
vi->bits_per_rgb = s48_extract_integer(S48_RECORD_REF(v, 9));
mask |= VisualBitsPerRGBMask;
}
if (!S48_FALSE_P(S48_RECORD_REF(v, 9))) {
vi->colormap_size = s48_extract_integer(S48_RECORD_REF(v, 10));
mask |= VisualColormapSizeMask;
}
return mask;
}
s48_value scx_Get_Visual_Info(s48_value Xdisplay, s48_value v) {
XVisualInfo template;
XVisualInfo* visualList;
int visualsMatch, i;
long mask = VisualNoMask;
s48_value res = S48_FALSE;
s48_value scx_Get_Visual_Info(s48_value display, s48_value template) {
XVisualInfo templ;
unsigned long mask = scx_extract_visual_info(template, &templ);
XVisualInfo* vis;
int n, i;
s48_value l = S48_NULL;
S48_DECLARE_GC_PROTECT(1);
mask = Extract_Visual_Info(v, &template);
visualList = XGetVisualInfo( SCX_EXTRACT_DISPLAY(Xdisplay),
mask, &template, &visualsMatch);
vis = XGetVisualInfo(scx_extract_display(display),
mask, &templ, &n);
res = s48_make_vector(visualsMatch, S48_FALSE);
S48_GC_PROTECT_1(res);
for (i=0; i<visualsMatch; i++)
S48_VECTOR_SET(res, i, Enter_Visual_And_Visual_Info(&visualList[i]));
S48_GC_PROTECT_1(l);
for (i = n-1; i >= 0; i--)
l = s48_cons(scx_enter_visual_info(&vis[i]), l);
S48_GC_UNPROTECT();
return res;
return l;
}
s48_value scx_Visual_ID(s48_value Xvisual) {
return s48_enter_integer(XVisualIDFromVisual(SCX_EXTRACT_VISUAL(Xvisual)));
}
s48_value scx_Match_Visual_Info(s48_value Xdisplay, s48_value scrnum,
s48_value scx_Match_Visual_Info(s48_value display, s48_value scrnum,
s48_value depth, s48_value class) {
XVisualInfo r;
if (XMatchVisualInfo(SCX_EXTRACT_DISPLAY(Xdisplay),
s48_extract_integer(scrnum),
s48_extract_integer(depth),
s48_extract_integer(class),
&r))
return Enter_Visual_And_Visual_Info(&r);
else
XVisualInfo vi;
Status r = XMatchVisualInfo(scx_extract_display(display),
s48_extract_integer(scrnum),
s48_extract_integer(depth),
scx_extract_visual_class(class),
&vi);
if (!r)
return S48_FALSE;
}
else
return scx_enter_visual_info(&vi);
}
s48_value scx_VisualIDFromVisual(s48_value visual) {
return s48_enter_integer(XVisualIDFromVisual(scx_extract_visual(visual)));
}
void scx_init_visual(void) {
S48_EXPORT_FUNCTION(scx_Get_Visual_Info);
S48_EXPORT_FUNCTION(scx_Visual_ID);
S48_EXPORT_FUNCTION(scx_Match_Visual_Info);
S48_EXPORT_FUNCTION(scx_VisualIDFromVisual);
}

642
c/xlib/window.c
View File

@ -1,273 +1,397 @@
/* Copyright 2001-2003 by Norbert Freudemann, David Frese */
#include "xlib.h"
unsigned long Attribs_To_XSetWindowAttributes(s48_value attribs,
XSetWindowAttributes* Xattrs) {
unsigned long mask = s48_extract_integer(S48_CAR(attribs));
s48_value v = S48_CDR(attribs);
if (mask & CWBackPixmap)
Xattrs->background_pixmap = SCX_EXTRACT_PIXMAP(S48_VECTOR_REF(v, 0));
if (mask & CWBackPixel)
Xattrs->background_pixel = s48_extract_integer(S48_VECTOR_REF(v, 1));
if (mask & CWBorderPixmap)
Xattrs->border_pixmap = SCX_EXTRACT_PIXMAP(S48_VECTOR_REF(v, 2));
if (mask & CWBorderPixel)
Xattrs->border_pixel = s48_extract_integer(S48_VECTOR_REF(v, 3));
if (mask & CWBitGravity)
Xattrs->bit_gravity = s48_extract_integer(S48_VECTOR_REF(v, 4));
if (mask & CWWinGravity)
Xattrs->win_gravity = s48_extract_integer(S48_VECTOR_REF(v, 5));
if (mask & CWBackingStore)
Xattrs->backing_store = s48_extract_integer(S48_VECTOR_REF(v, 6));
if (mask & CWBackingPlanes)
Xattrs->backing_planes = s48_extract_integer(S48_VECTOR_REF(v, 7));
if (mask & CWBackingPixel)
Xattrs->backing_pixel = s48_extract_integer(S48_VECTOR_REF(v, 8));
if (mask & CWOverrideRedirect)
Xattrs->override_redirect = s48_extract_integer(S48_VECTOR_REF(v, 9));
if (mask & CWSaveUnder)
Xattrs->save_under = s48_extract_integer(S48_VECTOR_REF(v, 10));
if (mask & CWEventMask)
Xattrs->event_mask = s48_extract_integer(S48_VECTOR_REF(v, 11));
if (mask & CWDontPropagate)
Xattrs->do_not_propagate_mask = s48_extract_integer(S48_VECTOR_REF(v, 12));
if (mask & CWColormap)
Xattrs->colormap = SCX_EXTRACT_COLORMAP(S48_VECTOR_REF(v, 13));
if (mask & CWCursor)
Xattrs->cursor = SCX_EXTRACT_CURSOR(S48_VECTOR_REF(v, 14));
static unsigned long
scx_extract_set_window_attribute_alist(s48_value attribs,
XSetWindowAttributes* Xattrs) {
unsigned long mask = 0;
while (attribs != S48_NULL) {
int mv = scx_extract_gc_value(S48_CAR(S48_CAR(attribs)));
s48_value v = S48_CDR(S48_CAR(attribs));
attribs = S48_CDR(attribs);
mask = mask | mv;
switch (mv) {
case CWBackPixmap:
Xattrs->background_pixmap = scx_extract_pixmap(v); break;
case CWBackPixel:
Xattrs->background_pixel = scx_extract_pixel(v); break;
case CWBorderPixmap:
Xattrs->border_pixmap = scx_extract_pixmap(v); break;
case CWBorderPixel:
Xattrs->border_pixel = scx_extract_pixel(v); break;
case CWBitGravity:
Xattrs->bit_gravity = scx_extract_bit_gravity(v); break;
case CWWinGravity:
Xattrs->win_gravity = scx_extract_win_gravity(v); break;
case CWBackingStore:
Xattrs->backing_store = scx_extract_backing_store(v); break;
case CWBackingPlanes:
Xattrs->backing_planes = s48_extract_integer(v); break;
case CWBackingPixel:
Xattrs->backing_pixel = scx_extract_pixel(v); break;
case CWOverrideRedirect:
Xattrs->override_redirect = S48_EXTRACT_BOOLEAN(v); break;
case CWSaveUnder:
Xattrs->save_under = S48_EXTRACT_BOOLEAN(v); break;
case CWEventMask:
Xattrs->event_mask = scx_extract_event_mask(v); break;
case CWDontPropagate:
Xattrs->do_not_propagate_mask = scx_extract_event_mask(v); break;
case CWColormap:
Xattrs->colormap = scx_extract_colormap(v); break;
case CWCursor:
Xattrs->cursor = scx_extract_cursor(v); break;
}
}
return mask;
}
s48_value scx_Create_Window (s48_value Xdisplay, s48_value Xparent,
s48_value scx_Create_Window (s48_value display, s48_value parent,
s48_value x, s48_value y,
s48_value width, s48_value height,
s48_value border_width, s48_value depth,
s48_value class, s48_value Xvisual,
s48_value class, s48_value visual,
s48_value attribs) {
Window win;
XSetWindowAttributes Xattrs;
unsigned long mask = Attribs_To_XSetWindowAttributes( attribs, &Xattrs );
int dep = S48_FALSE_P(depth) ? CopyFromParent : s48_extract_integer(depth);
int cla = 0;
Visual* vis = S48_FALSE_P(Xvisual) ? CopyFromParent :
SCX_EXTRACT_VISUAL(Xvisual);
switch (s48_extract_integer(class)) {
case 0: cla = InputOutput;
case 1: cla = InputOnly;
case 2: cla = CopyFromParent;
}
unsigned long mask =
scx_extract_set_window_attribute_alist(attribs, &Xattrs);
win = XCreateWindow( SCX_EXTRACT_DISPLAY(Xdisplay),
SCX_EXTRACT_WINDOW(Xparent),
(int)s48_extract_integer(x),
(int)s48_extract_integer(y),
(int)s48_extract_integer (width),
(int)s48_extract_integer (height),
(int)s48_extract_integer (border_width),
dep, cla, vis,
mask,&Xattrs );
return SCX_ENTER_WINDOW(win);
win = XCreateWindow(scx_extract_display(display),
scx_extract_window(parent),
(int)s48_extract_integer(x),
(int)s48_extract_integer(y),
(int)s48_extract_integer(width),
(int)s48_extract_integer(height),
(int)s48_extract_integer(border_width),
s48_extract_integer(depth),
s48_extract_integer(class),
scx_extract_visual(visual), mask, &Xattrs);
return scx_enter_window(win);
}
s48_value scx_Destroy_Window (s48_value Xdisplay, s48_value Xwindow) {
XDestroyWindow (SCX_EXTRACT_DISPLAY(Xdisplay), SCX_EXTRACT_WINDOW(Xwindow));
return S48_UNSPECIFIC;
s48_value scx_Create_Simple_Window(s48_value display, s48_value parent,
s48_value x, s48_value y,
s48_value width, s48_value height,
s48_value border_width, s48_value border,
s48_value background) {
Window win = XCreateSimpleWindow(scx_extract_display(display),
scx_extract_window(parent),
(int)s48_extract_integer(x),
(int)s48_extract_integer(y),
(int)s48_extract_integer(width),
(int)s48_extract_integer(height),
(int)s48_extract_integer(border_width),
scx_extract_pixel(border),
scx_extract_pixel(background));
return scx_enter_window(win);
}
s48_value scx_Change_Window_Attributes(s48_value Xwindow, s48_value Xdisplay,
s48_value attribs) {
s48_value scx_Change_Window_Attributes(s48_value display, s48_value window,
s48_value attribs) {
XSetWindowAttributes Xattrs;
unsigned long mask = Attribs_To_XSetWindowAttributes( attribs, &Xattrs );
XChangeWindowAttributes(SCX_EXTRACT_DISPLAY(Xdisplay),
SCX_EXTRACT_WINDOW(Xwindow),
mask, &Xattrs);
unsigned long mask =
scx_extract_set_window_attribute_alist(attribs, &Xattrs);
XChangeWindowAttributes(scx_extract_display(display),
scx_extract_window(window),
mask, &Xattrs);
return S48_UNSPECIFIC;
}
s48_value scx_Get_Window_Attributes(s48_value Xdisplay, s48_value Xwindow) {
XWindowAttributes WA;
S48_DECLARE_GC_PROTECT(1);
s48_value res = S48_NULL;
if (!XGetWindowAttributes(SCX_EXTRACT_DISPLAY(Xdisplay),
SCX_EXTRACT_WINDOW(Xwindow),
&WA))
res = S48_FALSE;
else {
S48_GC_PROTECT_1(res);
s48_value scx_enter_window_changes(XWindowChanges* WC, unsigned long mask) {
s48_value res = S48_NULL, t = S48_FALSE;
S48_DECLARE_GC_PROTECT(2);
S48_GC_PROTECT_2(res, t);
res = s48_make_vector(23, S48_FALSE);
S48_VECTOR_SET(res, 0, s48_enter_fixnum(WA.x));
S48_VECTOR_SET(res, 1, s48_enter_fixnum(WA.y));
S48_VECTOR_SET(res, 2, s48_enter_fixnum(WA.width));
S48_VECTOR_SET(res, 3, s48_enter_fixnum(WA.height));
S48_VECTOR_SET(res, 4, s48_enter_fixnum(WA.border_width));
S48_VECTOR_SET(res, 5, s48_enter_fixnum(WA.depth));
S48_VECTOR_SET(res, 6, SCX_ENTER_VISUAL(WA.visual));
S48_VECTOR_SET(res, 7, SCX_ENTER_WINDOW(WA.root));
S48_VECTOR_SET(res, 8, s48_enter_integer(WA.class));
S48_VECTOR_SET(res, 9, s48_enter_integer(WA.bit_gravity));
S48_VECTOR_SET(res, 10, s48_enter_integer(WA.win_gravity));
S48_VECTOR_SET(res, 11, s48_enter_integer(WA.backing_store));
S48_VECTOR_SET(res, 12, s48_enter_integer(WA.backing_planes));
S48_VECTOR_SET(res, 13, SCX_ENTER_PIXEL(WA.backing_pixel));
S48_VECTOR_SET(res, 14, s48_enter_fixnum(WA.save_under));
S48_VECTOR_SET(res, 15, SCX_ENTER_COLORMAP(WA.colormap));
S48_VECTOR_SET(res, 16, s48_enter_fixnum(WA.map_installed));
S48_VECTOR_SET(res, 17, s48_enter_integer(WA.map_state));
S48_VECTOR_SET(res, 18, s48_enter_integer(WA.all_event_masks));
S48_VECTOR_SET(res, 19, s48_enter_integer(WA.your_event_mask));
S48_VECTOR_SET(res, 20, s48_enter_integer(WA.do_not_propagate_mask));
S48_VECTOR_SET(res, 21, s48_enter_fixnum(WA.override_redirect));
S48_VECTOR_SET(res, 22, S48_FALSE);
//S48_VECTOR_SET(res, 22, s48_enter_fixnum((long)WA.screen));
// WA.screen not yet supported
res = s48_cons(s48_enter_integer((1L<<23) - 1), res);
S48_GC_UNPROTECT();
if (mask & CWX) {
t = scx_enter_window_change(0);
t = s48_cons(t, s48_enter_integer(WC->x));
res = s48_cons(t, res);
}
if (mask & CWY) {
t = scx_enter_window_change(1);
t = s48_cons(t, s48_enter_integer(WC->y));
res = s48_cons(t, res);
}
if (mask & CWWidth) {
t = scx_enter_window_change(2);
t = s48_cons(t, s48_enter_integer(WC->width));
res = s48_cons(t, res);
}
if (mask & CWHeight) {
t = scx_enter_window_change(3);
t = s48_cons(t, s48_enter_integer(WC->height));
res = s48_cons(t, res);
}
if (mask & CWBorderWidth) {
t = scx_enter_window_change(4);
t = s48_cons(t, s48_enter_integer(WC->border_width));
res = s48_cons(t, res);
}
if (mask & CWSibling) {
t = scx_enter_window_change(5);
t = s48_cons(t, scx_enter_window(WC->sibling));
res = s48_cons(t, res);
}
if (mask & CWStackMode) {
t = scx_enter_window_change(6);
t = s48_cons(t, scx_enter_stack_mode(WC->stack_mode));
res = s48_cons(t, res);
}
S48_GC_UNPROTECT();
return res;
}
s48_value Changes_To_XWindowChanges(s48_value changes, XWindowChanges* WC) {
unsigned long mask = s48_extract_integer(S48_CAR(changes));
s48_value v = S48_CDR(changes);
if (mask & CWX)
WC->x = s48_extract_integer(S48_VECTOR_REF(v, 0));
if (mask & CWY)
WC->y = s48_extract_integer(S48_VECTOR_REF(v, 1));
if (mask & CWWidth)
WC->width = s48_extract_integer(S48_VECTOR_REF(v, 2));
if (mask & CWHeight)
WC->height = s48_extract_integer(S48_VECTOR_REF(v, 3));
if (mask & CWBorderWidth)
WC->border_width = s48_extract_integer(S48_VECTOR_REF(v, 4));
if (mask & CWSibling)
WC->sibling = SCX_EXTRACT_WINDOW(S48_VECTOR_REF(v, 5));
if (mask & CWStackMode)
WC->stack_mode = s48_extract_integer(S48_VECTOR_REF(v, 6));
unsigned long scx_extract_window_changes(s48_value changes,
XWindowChanges* WC) {
unsigned long mask = 0;
while (changes != S48_NULL) {
int mv = scx_extract_window_change(S48_CAR(S48_CAR(changes)));
s48_value v = S48_CDR(S48_CAR(changes));
changes = S48_CDR(changes);
mask = mask | mv;
switch (mv) {
case CWX:
WC->x = s48_extract_integer(v); break;
case CWY:
WC->y = s48_extract_integer(v); break;
case CWWidth:
WC->width = s48_extract_integer(v); break;
case CWHeight:
WC->height = s48_extract_integer(v); break;
case CWBorderWidth:
WC->border_width = s48_extract_integer(v); break;
case CWSibling:
WC->sibling = scx_extract_window(v); break;
case CWStackMode:
WC->stack_mode = scx_extract_stack_mode(v); break;
}
}
return mask;
}
s48_value scx_Configure_Window (s48_value Xwindow, s48_value Xdisplay,
s48_value changes) {
s48_value scx_Configure_Window(s48_value display, s48_value window,
s48_value changes) {
XWindowChanges WC;
unsigned long mask = Changes_To_XWindowChanges(changes, &WC);
unsigned long mask = scx_extract_window_changes(changes, &WC);
XConfigureWindow (SCX_EXTRACT_DISPLAY(Xdisplay), SCX_EXTRACT_WINDOW(Xwindow),
mask, &WC);
XConfigureWindow(scx_extract_display(display), scx_extract_window(window),
mask, &WC);
return S48_UNSPECIFIC;
}
s48_value scx_Map_Window(s48_value Xwindow, s48_value Xdisplay) {
XMapWindow(SCX_EXTRACT_DISPLAY(Xdisplay), SCX_EXTRACT_WINDOW(Xwindow));
return S48_UNSPECIFIC;
}
s48_value scx_Unmap_Window(s48_value Xwindow, s48_value Xdisplay) {
XUnmapWindow(SCX_EXTRACT_DISPLAY(Xdisplay), SCX_EXTRACT_WINDOW(Xwindow));
return S48_UNSPECIFIC;
}
s48_value scx_Destroy_Subwindows (s48_value Xwindow, s48_value Xdisplay) {
XDestroySubwindows(SCX_EXTRACT_DISPLAY(Xdisplay),
SCX_EXTRACT_WINDOW(Xwindow));
return S48_UNSPECIFIC;
}
s48_value scx_Map_Subwindows (s48_value Xwindow, s48_value Xdisplay) {
XMapSubwindows(SCX_EXTRACT_DISPLAY(Xdisplay), SCX_EXTRACT_WINDOW(Xwindow));
return S48_UNSPECIFIC;
}
s48_value scx_Unmap_Subwindows (s48_value Xwindow, s48_value Xdisplay) {
XUnmapSubwindows(SCX_EXTRACT_DISPLAY(Xdisplay), SCX_EXTRACT_WINDOW(Xwindow));
return S48_UNSPECIFIC;
}
s48_value scx_Circulate_Subwindows(s48_value Xwindow, s48_value Xdisplay,
s48_value dir) {
XCirculateSubwindows(SCX_EXTRACT_DISPLAY(Xdisplay),
SCX_EXTRACT_WINDOW(Xwindow),
S48_FALSE_P(dir) ? RaiseLowest : LowerHighest);
return S48_UNSPECIFIC;
}
s48_value scx_Query_Tree (s48_value Xwindow, s48_value Xdisplay) {
Window root, parent, *children;
int i;
unsigned n;
s48_value v = S48_FALSE, ret = S48_FALSE;
S48_DECLARE_GC_PROTECT(2);
if (! XQueryTree (SCX_EXTRACT_DISPLAY(Xdisplay),
SCX_EXTRACT_WINDOW(Xwindow),
&root, &parent, &children, &n))
return S48_FALSE;
ret = s48_make_vector(3, S48_FALSE);
v = S48_FALSE;
S48_GC_PROTECT_2 (v, ret);
// vector of child-windows
v = s48_make_vector (n, S48_FALSE);
for (i = 0; i < n; i++) {
S48_VECTOR_SET(v, i, SCX_ENTER_WINDOW(children[i]));
}
if (children != NULL) XFree(children);
S48_VECTOR_SET(ret, 0, SCX_ENTER_WINDOW(root));
S48_VECTOR_SET(ret, 1, SCX_ENTER_WINDOW(parent));
S48_VECTOR_SET(ret, 2, v);
S48_GC_UNPROTECT();
return ret;
}
s48_value scx_Translate_Coordinates (s48_value Xdisplay, s48_value srcXwindow,
s48_value x, s48_value y,
s48_value dstXwindow) {
int rx, ry;
Window child;
s48_value v = S48_FALSE;
s48_value scx_window_attributes;
s48_value scx_enter_window_attributes(XWindowAttributes* WA) {
s48_value v = s48_make_record(scx_window_attributes);
S48_DECLARE_GC_PROTECT(1);
if (!XTranslateCoordinates (SCX_EXTRACT_DISPLAY(Xdisplay),
SCX_EXTRACT_WINDOW(srcXwindow),
SCX_EXTRACT_WINDOW(dstXwindow),
(int)s48_extract_integer (x),
(int)s48_extract_integer (y),
&rx, &ry, &child))
return S48_FALSE;
S48_GC_PROTECT_1 (v);
v = s48_make_vector(3, S48_FALSE);
S48_VECTOR_SET(v, 0, s48_enter_fixnum(rx));
S48_VECTOR_SET(v, 1, s48_enter_fixnum(ry));
S48_VECTOR_SET(v, 2, SCX_ENTER_WINDOW(child));
S48_GC_PROTECT_1(v);
S48_RECORD_SET(v, 0, s48_enter_integer(WA->x));
S48_RECORD_SET(v, 1, s48_enter_integer(WA->y));
S48_RECORD_SET(v, 2, s48_enter_integer(WA->width));
S48_RECORD_SET(v, 3, s48_enter_integer(WA->height));
S48_RECORD_SET(v, 4, s48_enter_integer(WA->border_width));
S48_RECORD_SET(v, 5, s48_enter_integer(WA->depth));
S48_RECORD_SET(v, 6, scx_enter_visual(WA->visual));
S48_RECORD_SET(v, 7, scx_enter_window(WA->root));
S48_RECORD_SET(v, 8, scx_enter_window_class(WA->class));
S48_RECORD_SET(v, 9, scx_enter_bit_gravity(WA->bit_gravity));
S48_RECORD_SET(v, 10, scx_enter_win_gravity(WA->win_gravity));
S48_RECORD_SET(v, 11, scx_enter_backing_store(WA->backing_store));
S48_RECORD_SET(v, 12, s48_enter_integer(WA->backing_planes));
S48_RECORD_SET(v, 13, scx_enter_pixel(WA->backing_pixel));
S48_RECORD_SET(v, 14, S48_ENTER_BOOLEAN(WA->save_under));
S48_RECORD_SET(v, 15, scx_enter_colormap(WA->colormap));
S48_RECORD_SET(v, 16, S48_ENTER_BOOLEAN(WA->map_installed));
S48_RECORD_SET(v, 17, scx_enter_map_state(WA->map_state));
S48_RECORD_SET(v, 18, scx_enter_event_mask(WA->all_event_masks));
S48_RECORD_SET(v, 19, scx_enter_event_mask(WA->your_event_mask));
S48_RECORD_SET(v, 20, scx_enter_event_mask(WA->do_not_propagate_mask));
S48_RECORD_SET(v, 21, S48_ENTER_BOOLEAN(WA->override_redirect));
S48_RECORD_SET(v, 22, scx_enter_screen(WA->screen));
S48_GC_UNPROTECT();
return v;
}
s48_value scx_Query_Pointer (s48_value Xdisplay, s48_value Xwindow) {
s48_value scx_Get_Window_Attributes(s48_value display, s48_value window) {
XWindowAttributes WA;
if (!XGetWindowAttributes(scx_extract_display(display),
scx_extract_window(window),
&WA))
return S48_FALSE;
else
return scx_enter_window_attributes(&WA);
}
s48_value scx_Get_Geometry(s48_value display, s48_value drawable) {
s48_value v = S48_FALSE;
Window root;
int x, y;
unsigned int width, height, border_width, depth;
S48_DECLARE_GC_PROTECT(1);
if (!XGetGeometry(scx_extract_display(display),
scx_extract_drawable(drawable),
&root, &x, &y, &width, &height, &border_width, &depth))
return S48_FALSE;
else {
v = s48_make_vector(7, S48_FALSE);
S48_GC_PROTECT_1(v);
S48_VECTOR_SET(v, 0, scx_enter_window(root));
S48_VECTOR_SET(v, 1, s48_enter_fixnum(x));
S48_VECTOR_SET(v, 2, s48_enter_fixnum(y));
S48_VECTOR_SET(v, 3, s48_enter_fixnum(width));
S48_VECTOR_SET(v, 4, s48_enter_fixnum(height));
S48_VECTOR_SET(v, 5, s48_enter_fixnum(border_width));
S48_VECTOR_SET(v, 6, s48_enter_fixnum(depth));
S48_GC_UNPROTECT();
return v;
}
}
s48_value scx_Map_Window(s48_value display, s48_value window) {
XMapWindow(scx_extract_display(display), scx_extract_window(window));
return S48_UNSPECIFIC;
}
s48_value scx_Map_Raised(s48_value display, s48_value window) {
XMapRaised(scx_extract_display(display), scx_extract_window(window));
return S48_UNSPECIFIC;
}
s48_value scx_Map_Subwindows(s48_value display, s48_value window) {
XMapSubwindows(scx_extract_display(display), scx_extract_window(window));
return S48_UNSPECIFIC;
}
s48_value scx_Unmap_Window(s48_value display, s48_value window) {
XUnmapWindow(scx_extract_display(display), scx_extract_window(window));
return S48_UNSPECIFIC;
}
s48_value scx_Unmap_Subwindows(s48_value display, s48_value window) {
XUnmapSubwindows(scx_extract_display(display), scx_extract_window(window));
return S48_UNSPECIFIC;
}
s48_value scx_Destroy_Window(s48_value display, s48_value window) {
XDestroyWindow(scx_extract_display(display), scx_extract_window(window));
return S48_UNSPECIFIC;
}
s48_value scx_Destroy_Subwindows(s48_value display, s48_value window) {
XDestroySubwindows(scx_extract_display(display),
scx_extract_window(window));
return S48_UNSPECIFIC;
}
s48_value scx_Raise_Window(s48_value display, s48_value window) {
XRaiseWindow(scx_extract_display(display),
scx_extract_window(window));
return S48_UNSPECIFIC;
}
s48_value scx_Lower_Window(s48_value display, s48_value window) {
XLowerWindow(scx_extract_display(display),
scx_extract_window(window));
return S48_UNSPECIFIC;
}
#define scx_extract_direction(x) S48_EXTRACT_ENUM(x, "scx-circulate-direction")
s48_value scx_Circulate_Subwindows(s48_value display, s48_value window,
s48_value dir) {
XCirculateSubwindows(scx_extract_display(display),
scx_extract_window(window),
scx_extract_direction(dir));
return S48_UNSPECIFIC;
}
s48_value scx_Restack_Windows(s48_value display, s48_value windows) {
int i, n = s48_list_length(windows);
Window wins[n];
for (i = n-1; i >= 0; i--) {
wins[i] = scx_extract_window(S48_CAR(windows));
windows = S48_CDR(windows);
}
XRestackWindows(scx_extract_display(display),
wins, n);
return S48_UNSPECIFIC;
}
s48_value scx_Clear_Area(s48_value display, s48_value window,
s48_value x, s48_value y,
s48_value width, s48_value height,
s48_value exposures) {
XClearArea(scx_extract_display(display), scx_extract_window(window),
s48_extract_integer(x), s48_extract_integer(y),
s48_extract_integer(width), s48_extract_integer(height),
S48_EXTRACT_BOOLEAN(exposures));
return S48_UNSPECIFIC;
}
s48_value scx_Clear_Window(s48_value display, s48_value window) {
XClearWindow(scx_extract_display(display),
scx_extract_window(window));
return S48_UNSPECIFIC;
}
s48_value scx_Query_Tree(s48_value Xwindow, s48_value Xdisplay) {
Window root, parent, *children;
int i;
unsigned n;
s48_value c = S48_NULL, res = S48_NULL;
S48_DECLARE_GC_PROTECT(2);
if (! XQueryTree (scx_extract_display(Xdisplay),
scx_extract_window(Xwindow),
&root, &parent, &children, &n))
return S48_FALSE;
S48_GC_PROTECT_2(c, res);
for (i = 0; i < n; i++)
c = s48_cons(scx_enter_window(children[i]), c);
if (children != NULL) XFree(children);
res = s48_cons(c, res);
res = s48_cons(scx_enter_window(parent), res);
res = s48_cons(scx_enter_window(root), res);
S48_GC_UNPROTECT();
return res;
}
s48_value scx_Translate_Coordinates(s48_value display, s48_value src,
s48_value dest,
s48_value x, s48_value y) {
int rx, ry;
Window child;
s48_value res = S48_NULL;
S48_DECLARE_GC_PROTECT(1);
if (!XTranslateCoordinates(scx_extract_display(display),
scx_extract_window(src),
scx_extract_window(dest),
(int)s48_extract_integer (x),
(int)s48_extract_integer (y),
&rx, &ry, &child))
return S48_FALSE;
S48_GC_PROTECT_1(res);
res = s48_cons(scx_enter_window(child), res);
res = s48_cons(s48_enter_fixnum(ry), res);
res = s48_cons(s48_enter_fixnum(rx), res);
S48_GC_UNPROTECT();
return res;
}
s48_value scx_Query_Pointer(s48_value display, s48_value window) {
s48_value v = S48_FALSE;
Bool ret;
Window root, child;
@ -275,62 +399,46 @@ s48_value scx_Query_Pointer (s48_value Xdisplay, s48_value Xwindow) {
unsigned int mask;
S48_DECLARE_GC_PROTECT(1);
ret = XQueryPointer (SCX_EXTRACT_DISPLAY(Xdisplay), SCX_EXTRACT_WINDOW(Xwindow),
&root, &child, &r_x, &r_y, &x, &y, &mask);
ret = XQueryPointer(scx_extract_display(display), scx_extract_window(window),
&root, &child, &r_x, &r_y, &x, &y, &mask);
v = s48_make_vector(8, S48_FALSE);
S48_GC_PROTECT_1(v);
S48_VECTOR_SET(v, 0, s48_enter_fixnum(x));
S48_VECTOR_SET(v, 1, s48_enter_fixnum(y));
S48_VECTOR_SET(v, 2, ret ? S48_TRUE : S48_FALSE);
S48_VECTOR_SET(v, 3, SCX_ENTER_WINDOW(root));
S48_VECTOR_SET(v, 4, s48_enter_fixnum(r_x));
S48_VECTOR_SET(v, 5, s48_enter_fixnum(r_y));
S48_VECTOR_SET(v, 6, SCX_ENTER_WINDOW(child));
S48_VECTOR_SET(v, 7, s48_enter_integer((unsigned long)mask));
S48_VECTOR_SET(v, 0, scx_enter_window(root));
S48_VECTOR_SET(v, 1, scx_enter_window(child));
S48_VECTOR_SET(v, 2, s48_enter_fixnum(r_x));
S48_VECTOR_SET(v, 3, s48_enter_fixnum(r_y));
S48_VECTOR_SET(v, 4, s48_enter_fixnum(x));
S48_VECTOR_SET(v, 5, s48_enter_fixnum(y));
S48_VECTOR_SET(v, 6, s48_enter_integer((unsigned long)mask));
S48_VECTOR_SET(v, 7, ret ? S48_TRUE : S48_FALSE);
S48_GC_UNPROTECT();
return v;
}
s48_value scx_Get_Geometry(s48_value Xdisplay, s48_value Xdrawable) {
s48_value v = S48_FALSE;
Window root;
int x, y;
unsigned int width, height, border_width, depth;
S48_DECLARE_GC_PROTECT(1);
XGetGeometry(SCX_EXTRACT_DISPLAY(Xdisplay), SCX_EXTRACT_DRAWABLE(Xdrawable),
&root, &x, &y, &width, &height, &border_width, &depth);
v = s48_make_vector(7, S48_FALSE);
S48_GC_PROTECT_1(v);
S48_VECTOR_SET(v, 0, SCX_ENTER_WINDOW(root));
S48_VECTOR_SET(v, 1, s48_enter_fixnum(x));
S48_VECTOR_SET(v, 2, s48_enter_fixnum(y));
S48_VECTOR_SET(v, 3, s48_enter_fixnum(width));
S48_VECTOR_SET(v, 4, s48_enter_fixnum(height));
S48_VECTOR_SET(v, 5, s48_enter_fixnum(border_width));
S48_VECTOR_SET(v, 6, s48_enter_fixnum(depth));
S48_GC_UNPROTECT();
return v;
}
void scx_init_window(void) {
S48_EXPORT_FUNCTION(scx_Create_Window);
S48_EXPORT_FUNCTION(scx_Destroy_Window);
S48_EXPORT_FUNCTION(scx_Create_Simple_Window);
S48_EXPORT_FUNCTION(scx_Change_Window_Attributes);
S48_EXPORT_FUNCTION(scx_Get_Window_Attributes);
S48_EXPORT_FUNCTION(scx_Configure_Window);
S48_EXPORT_FUNCTION(scx_Get_Window_Attributes);
S48_EXPORT_FUNCTION(scx_Get_Geometry);
S48_EXPORT_FUNCTION(scx_Map_Window);
S48_EXPORT_FUNCTION(scx_Unmap_Window);
S48_EXPORT_FUNCTION(scx_Destroy_Subwindows);
S48_EXPORT_FUNCTION(scx_Map_Raised);
S48_EXPORT_FUNCTION(scx_Map_Subwindows);
S48_EXPORT_FUNCTION(scx_Unmap_Window);
S48_EXPORT_FUNCTION(scx_Unmap_Subwindows);
S48_EXPORT_FUNCTION(scx_Destroy_Window);
S48_EXPORT_FUNCTION(scx_Destroy_Subwindows);
S48_EXPORT_FUNCTION(scx_Raise_Window);
S48_EXPORT_FUNCTION(scx_Lower_Window);
S48_EXPORT_FUNCTION(scx_Circulate_Subwindows);
S48_EXPORT_FUNCTION(scx_Restack_Windows);
S48_EXPORT_FUNCTION(scx_Clear_Area);
S48_EXPORT_FUNCTION(scx_Clear_Window);
S48_EXPORT_FUNCTION(scx_Query_Tree);
S48_EXPORT_FUNCTION(scx_Translate_Coordinates);
S48_EXPORT_FUNCTION(scx_Query_Pointer);
S48_EXPORT_FUNCTION(scx_Get_Geometry);
}

164
c/xlib/wm.c
View File

@ -1,124 +1,129 @@
/* Copyright 2001-2003 by Norbert Freudemann, David Frese */
#include "xlib.h"
#include "scheme48.h"
s48_value scx_Reparent_Window(s48_value Xdisplay, s48_value Xwindow,
s48_value Xwindow_parent, s48_value x,
s48_value y) {
XReparentWindow(SCX_EXTRACT_DISPLAY(Xdisplay),
SCX_EXTRACT_WINDOW(Xwindow),
SCX_EXTRACT_WINDOW(Xwindow_parent),
(int)s48_extract_integer (x), (int)s48_extract_integer (y));
s48_value scx_Reparent_Window(s48_value display, s48_value window,
s48_value parent, s48_value x, s48_value y) {
XReparentWindow(scx_extract_display(display),
scx_extract_window(window),
scx_extract_window(parent),
(int)s48_extract_integer(x), (int)s48_extract_integer(y));
return S48_UNSPECIFIC;
}
s48_value scx_Install_Colormap(s48_value Xdisplay, s48_value Xcolormap) {
XInstallColormap(SCX_EXTRACT_DISPLAY(Xdisplay),
SCX_EXTRACT_COLORMAP(Xcolormap));
s48_value scx_Install_Colormap(s48_value display, s48_value colormap) {
XInstallColormap(scx_extract_display(display),
scx_extract_colormap(colormap));
return S48_UNSPECIFIC;
}
s48_value scx_Uninstall_Colormap(s48_value Xdisplay, s48_value Xcolormap) {
XUninstallColormap(SCX_EXTRACT_DISPLAY(Xdisplay),
SCX_EXTRACT_COLORMAP(Xcolormap));
s48_value scx_Uninstall_Colormap(s48_value display, s48_value colormap) {
XUninstallColormap(scx_extract_display(display),
scx_extract_colormap(colormap));
return S48_UNSPECIFIC;
}
s48_value scx_List_Installed_Colormaps(s48_value Xdisplay, s48_value Xwindow) {
s48_value scx_List_Installed_Colormaps(s48_value display, s48_value window) {
int i, n;
Colormap *ret;
s48_value v = S48_FALSE;
s48_value l = S48_NULL;
S48_DECLARE_GC_PROTECT(1);
ret = XListInstalledColormaps(SCX_EXTRACT_DISPLAY(Xdisplay),
SCX_EXTRACT_WINDOW(Xwindow),
ret = XListInstalledColormaps(scx_extract_display(display),
scx_extract_window(window),
&n);
v = s48_make_vector (n, S48_FALSE);
S48_GC_PROTECT_1 (v);
for (i = 0; i < n; i++) {
S48_VECTOR_SET(v, i, SCX_ENTER_COLORMAP(ret[i]));
}
XFree ((char *)ret);
S48_GC_PROTECT_1(l);
for (i = n-1; i >= 0; i--)
l = s48_cons(scx_enter_colormap(ret[i]), l);
XFree((char*)ret);
S48_GC_UNPROTECT();
return l;
}
#define scx_extract_revert_to(x) S48_EXTRACT_ENUM(x, "scx-revert-to")
#define scx_enter_revert_to(x) S48_ENTER_ENUM(x, "scx-revert-tos")
s48_value scx_Set_Input_Focus(s48_value display, s48_value window,
s48_value revert_to, s48_value time) {
XSetInputFocus(scx_extract_display(display), scx_extract_window(window),
scx_extract_revert_to(revert_to),
scx_extract_time(time));
return S48_UNSPECIFIC;
}
s48_value scx_Get_Input_Focus(s48_value display) {
Window win;
int revert_to;
s48_value v = S48_FALSE;
S48_DECLARE_GC_PROTECT(1);
S48_GC_PROTECT_1(v);
XGetInputFocus(scx_extract_display(display), &win, &revert_to);
v = scx_enter_revert_to(revert_to);
v = s48_cons(scx_enter_window(win), v);
S48_GC_UNPROTECT();
return v;
}
s48_value scx_Set_Input_Focus(s48_value Xdisplay, s48_value Xwindow,
s48_value revert_to, s48_value time) {
Window focus = SCX_EXTRACT_WINDOW(Xwindow);
XSetInputFocus (SCX_EXTRACT_DISPLAY(Xdisplay), focus,
s48_extract_integer(revert_to),
SCX_EXTRACT_TIME(time));
s48_value scx_Warp_Pointer(s48_value dpy, s48_value src, s48_value dst,
s48_value srcx, s48_value srcy, s48_value srcw,
s48_value srch, s48_value dstx, s48_value dsty) {
XWarpPointer(scx_extract_display(dpy),
scx_extract_window(src), scx_extract_window(dst),
(int)s48_extract_integer(srcx),
(int)s48_extract_integer(srcy),
(int)s48_extract_integer(srcw),
(int)s48_extract_integer(srch),
(int)s48_extract_integer(dstx),
(int)s48_extract_integer(dsty));
return S48_UNSPECIFIC;
}
s48_value scx_Input_Focus (s48_value Xdisplay) {
Window win;
int revert_to;
s48_value ret = S48_FALSE;
S48_DECLARE_GC_PROTECT(1);
XGetInputFocus (SCX_EXTRACT_DISPLAY(Xdisplay), &win, &revert_to);
ret = s48_cons (S48_NULL, S48_NULL);
S48_GC_PROTECT_1 (ret);
S48_SET_CAR(ret, SCX_ENTER_WINDOW(win));
S48_SET_CDR(ret, s48_enter_integer(revert_to));
S48_GC_UNPROTECT();
return ret;
}
s48_value scx_General_Warp_Pointer(s48_value dpy, s48_value dst, s48_value dstx,
s48_value dsty, s48_value src, s48_value srcx,
s48_value srcy, s48_value srcw, s48_value srch) {
XWarpPointer (SCX_EXTRACT_DISPLAY(dpy),
SCX_EXTRACT_WINDOW(src), SCX_EXTRACT_WINDOW(dst),
(int)s48_extract_integer (srcx),
(int)s48_extract_integer (srcy),
(int)s48_extract_integer (srcw),
(int)s48_extract_integer (srch),
(int)s48_extract_integer (dstx),
(int)s48_extract_integer (dsty));
s48_value scx_Bell(s48_value display, s48_value percent) {
XBell(scx_extract_display(display), s48_extract_integer(percent));
return S48_UNSPECIFIC;
}
s48_value scx_Bell(s48_value Xdisplay, s48_value percent) {
int p = (int)s48_extract_integer(percent);
XBell (SCX_EXTRACT_DISPLAY(Xdisplay), p);
s48_value scx_Set_Access_Control(s48_value display, s48_value on) {
XSetAccessControl(scx_extract_display(display), !S48_FALSE_P(on));
return S48_UNSPECIFIC;
}
s48_value scx_Set_Access_Control(s48_value Xdisplay, s48_value on) {
XSetAccessControl (SCX_EXTRACT_DISPLAY(Xdisplay), !S48_FALSE_P(on));
return S48_UNSPECIFIC;
}
#define scx_extract_save_set(x) S48_EXTRACT_ENUM(x, "scx-save-set")
s48_value scx_Change_Save_Set(s48_value Xdisplay, s48_value win,
s48_value scx_Change_Save_Set(s48_value display, s48_value win,
s48_value mode) {
XChangeSaveSet(SCX_EXTRACT_DISPLAY(Xdisplay), SCX_EXTRACT_WINDOW(win),
s48_extract_integer(mode));
XChangeSaveSet(scx_extract_display(display), scx_extract_window(win),
scx_extract_save_set(mode));
return S48_UNSPECIFIC;
}
s48_value scx_Set_Close_Down_Mode(s48_value Xdisplay, s48_value mode) {
XSetCloseDownMode(SCX_EXTRACT_DISPLAY(Xdisplay),
s48_extract_integer(mode));
#define scx_extract_close_down_mode(x) \
S48_EXTRACT_ENUM(x, "scx-close-down-mode")
s48_value scx_Set_Close_Down_Mode(s48_value display, s48_value mode) {
XSetCloseDownMode(scx_extract_display(display),
scx_extract_close_down_mode(mode));
return S48_UNSPECIFIC;
}
s48_value scx_Get_Pointer_Mapping(s48_value Xdisplay) {
s48_value scx_Kill_Client(s48_value display, s48_value xid) {
XKillClient(scx_extract_display(display), (XID)s48_extract_integer(xid));
return S48_UNSPECIFIC;
}
s48_value scx_Get_Pointer_Mapping(s48_value display) {
unsigned char map[256];
int i, n;
s48_value ret;
n = XGetPointerMapping (SCX_EXTRACT_DISPLAY(Xdisplay), map, 256);
ret = s48_make_vector (n, S48_NULL);
n = XGetPointerMapping (scx_extract_display(display), map, 256);
ret = s48_make_vector(n, S48_NULL);
for (i = 0; i < n; i++)
S48_VECTOR_SET(ret, i, s48_enter_integer (map[i]));
S48_VECTOR_SET(ret, i, s48_enter_integer(map[i]));
return ret;
}
s48_value scx_Set_Pointer_Mapping (s48_value Xdisplay, s48_value map) {
s48_value scx_Set_Pointer_Mapping(s48_value display, s48_value map) {
int i, n = S48_VECTOR_LENGTH(map);
unsigned char p[n];
int ret;
@ -126,7 +131,7 @@ s48_value scx_Set_Pointer_Mapping (s48_value Xdisplay, s48_value map) {
for (i = 0; i < n; i++)
p[i] = (int)s48_extract_integer(S48_VECTOR_REF(map, i));
ret = XSetPointerMapping (SCX_EXTRACT_DISPLAY(Xdisplay), p, n);
ret = XSetPointerMapping(scx_extract_display(display), p, n);
return (ret == MappingSuccess) ? S48_TRUE : S48_FALSE;
}
@ -136,12 +141,13 @@ void scx_init_wm(void) {
S48_EXPORT_FUNCTION(scx_Uninstall_Colormap);
S48_EXPORT_FUNCTION(scx_List_Installed_Colormaps);
S48_EXPORT_FUNCTION(scx_Set_Input_Focus);
S48_EXPORT_FUNCTION(scx_Input_Focus);
S48_EXPORT_FUNCTION(scx_General_Warp_Pointer);
S48_EXPORT_FUNCTION(scx_Get_Input_Focus);
S48_EXPORT_FUNCTION(scx_Warp_Pointer);
S48_EXPORT_FUNCTION(scx_Bell);
S48_EXPORT_FUNCTION(scx_Set_Access_Control);
S48_EXPORT_FUNCTION(scx_Change_Save_Set);
S48_EXPORT_FUNCTION(scx_Set_Close_Down_Mode);
S48_EXPORT_FUNCTION(scx_Kill_Client);
S48_EXPORT_FUNCTION(scx_Get_Pointer_Mapping);
S48_EXPORT_FUNCTION(scx_Set_Pointer_Mapping);
}

235
c/xlib/xlib.h
View File

@ -1,6 +1,12 @@
/* Copyright 2001-2003 by Norbert Freudemann, David Frese */
#ifndef _SCX_XLIB_H
#define _SCX_XLIB_H
#include <X11/X.h>
#include <X11/Xlib.h>
#include <X11/Xutil.h>
#include <X11/Intrinsic.h>
#ifndef NeedFunctionPrototypes /* Kludge */
#error "X11 Release 3 (or earlier) no longer supported"
@ -14,45 +20,202 @@
# define XLIB_RELEASE_6_OR_LATER
#endif
#include "scheme48.h"
#include <scheme48.h>
#define S48_NULL_P(x) S48_EQ(x, S48_NULL)
#define S48_FALSE_P(x) S48_EQ(x, S48_FALSE)
#define S48_TRUE_P(x) S48_EQ(x, S48_TRUE)
/* Extraction-Macros for the new types, from their s48_value wrapping.
*/
#define S48_INTEGER_P(x) (S48_FIXNUM_P(x) || S48_BIGNUM_P(x))
// TODO: S48_x_POINTER already exitst ?!
#define S48_POINTER_P(x) S48_INTEGER_P(x)
#define S48_ENTER_POINTER(x) s48_enter_integer((long)x)
#define S48_EXTRACT_POINTER(x) (void*)s48_extract_integer(x)
#define SCX_EXTRACT_DISPLAY(x) (Display*)s48_extract_integer(x)
#define SCX_ENTER_DISPLAY(x) s48_enter_integer((long)x)
#define SCX_EXTRACT_WINDOW(x) (Window)s48_extract_integer(x)
#define SCX_ENTER_WINDOW(x) s48_enter_integer((long)x)
#define SCX_EXTRACT_COLOR(x) (XColor*)S48_EXTRACT_VALUE_POINTER(x, XColor)
#define SCX_EXTRACT_COLORMAP(x) (Colormap)s48_extract_integer(x)
#define SCX_ENTER_COLORMAP(x) s48_enter_integer((long)x)
#define SCX_EXTRACT_PIXEL(x) (unsigned long)s48_extract_integer(x)
#define SCX_ENTER_PIXEL(x) s48_enter_integer((long)x)
#define SCX_EXTRACT_GCONTEXT(x) (GC)s48_extract_integer(x)
#define SCX_ENTER_GCONTEXT(x) s48_enter_integer((long)x)
#define SCX_ENTER_PIXMAP(x) s48_enter_integer((long)x)
#define SCX_EXTRACT_PIXMAP(x) (Pixmap)s48_extract_integer(x)
#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) 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)
#define SCX_EXTRACT_FONT(x) (Font)s48_extract_integer(x)
#define SCX_ENTER_FONTSTRUCT(x) s48_enter_integer((long)x)
#define SCX_EXTRACT_FONTSTRUCT(x) (XFontStruct*)s48_extract_integer(x)
#define SCX_ENTER_VISUAL(x) s48_enter_integer((long)x)
#define SCX_EXTRACT_VISUAL(x) (Visual*)s48_extract_integer(x)
#define SCX_ENTER_REGION(x) s48_enter_integer((long)x)
#define SCX_EXTRACT_REGION(x) (Region)s48_extract_integer(x)
extern s48_value s48_checked_record_ref(s48_value value, int i,
s48_value rectype);
extern unsigned long AList_To_XWindowChanges(s48_value alist,
XWindowChanges* WC);
extern int s48_list_length(s48_value list);
#define S48_EXTRACT_ENUM(x, typestr) \
s48_extract_integer(s48_checked_record_ref(x, 1, \
S48_SHARED_BINDING_REF(s48_get_imported_binding(typestr))))
#define S48_ENTER_ENUM(index, vvectorstr) \
S48_VECTOR_REF(S48_SHARED_BINDING_REF(s48_get_imported_binding(vvectorstr)),\
index)
#define S48_EXTRACT_ENUM_SET(x, typestr) \
s48_extract_integer(s48_checked_record_ref(x, 1, \
S48_SHARED_BINDING_REF(s48_get_imported_binding(typestr))))
extern s48_value s48_enter_enum_set(unsigned long v, char* typestr);
// *** Extraction-Macros for the XIDs ********************************
#define scx_extract_window(x) (Window)s48_extract_integer(x)
#define scx_enter_window(x) s48_enter_integer((long)x)
#define scx_extract_drawable(x) (Drawable)s48_extract_integer(x)
#define scx_enter_drawable(x) s48_enter_integer((long)x)
#define scx_extract_font(x) (Font)s48_extract_integer(x)
#define scx_enter_font(x) s48_enter_integer((long)x)
#define scx_extract_pixmap(x) (Pixmap)s48_extract_integer(x)
#define scx_enter_pixmap(x) s48_enter_integer((long)x)
#define scx_extract_cursor(x) (Cursor)s48_extract_integer(x)
#define scx_enter_cursor(x) s48_enter_integer((long)x)
#define scx_extract_colormap(x) (Colormap)s48_extract_integer(x)
#define scx_enter_colormap(x) s48_enter_integer((long)x)
#define scx_extract_gcontext(x) (GContext)s48_extract_integer(x)
#define scx_enter_gcontext(x) s48_enter_integer((long)x)
#define scx_extract_keysym(x) (GContext)s48_extract_integer(x)
#define scx_enter_keysym(x) s48_enter_integer((long)x)
// other CARD32
#define scx_enter_atom(x) s48_enter_integer((long)x)
#define scx_extract_atom(x) (Atom)s48_extract_integer(x)
#define scx_enter_visualid(x) s48_enter_integer((long)x)
#define scx_extract_visualid(x) (VisualID)s48_extract_integer(x)
#define scx_enter_time(x) s48_enter_integer(x)
#define scx_extract_time(x) (Time)s48_extract_integer(x)
// other ints
#define scx_enter_keycode(x) s48_enter_fixnum(x)
#define scx_extract_keycode(x) (KeyCode)s48_extract_integer(x)
#define scx_extract_pixel(x) (Pixel)s48_extract_integer(x)
#define scx_enter_pixel(x) s48_enter_integer((long)x)
// records
#define scx_display s48_get_imported_binding("scx-display")
#define scx_extract_display(x) \
(Display*)s48_extract_integer(s48_checked_record_ref(x, 0, scx_display))
extern s48_value scx_enter_display(Display* dpy);
#define SCX_DISPLAY_AFTER_FUNCTION(d) \
s48_checked_record_ref(d, 14, scx_display)
#define scx_color s48_get_imported_binding("scx-color")
extern void scx_extract_color(s48_value v, XColor* c);
extern void scx_copy_color(const XColor* c, s48_value v);
extern s48_value scx_enter_color(const XColor* c);
#define scx_gc s48_get_imported_binding("scx-gc")
#define scx_extract_gc(x) \
(GC)s48_extract_integer(s48_checked_record_ref(x, 0, scx_gc))
extern s48_value scx_enter_gc(GC gc);
#define scx_fontstruct s48_get_imported_binding("scx-fontstruct")
#define scx_extract_fontstruct(x)\
(XFontStruct*)s48_extract_integer(s48_checked_record_ref(x, 0,\
scx_fontstruct))
extern s48_value scx_enter_charstruct(XCharStruct* cs);
extern s48_value scx_enter_fontstruct(XFontStruct* fs);
#define scx_screenformat s48_get_imported_binding("scx-screenformat")
#define scx_extract_screenformat(x)\
(ScreenFormat*)s48_extract_integer(s48_checked_record_ref(x, 0,\
scx_screenformat))
extern s48_value scx_enter_screenformat(ScreenFormat* sf);
#define scx_visual s48_get_imported_binding("scx-visual")
#define scx_extract_visual(x)\
(Visual*)s48_extract_integer(s48_checked_record_ref(x, 0,\
scx_visual))
extern s48_value scx_enter_visual(Visual* vis);
#define scx_screen s48_get_imported_binding("scx-screen")
#define scx_extract_screen(x)\
(Screen*)s48_extract_integer(s48_checked_record_ref(x, 0,\
scx_screen))
extern s48_value scx_enter_screen(Screen* scr);
extern void scx_extract_property(s48_value p, Atom* type, int* format,
char** data, int* nelements);
extern s48_value scx_enter_property(Atom type, int format, char* data,
int nelements);
extern scx_enter_enter_window_changes(XWindowChanges* WC, unsigned long mask);
extern unsigned long scx_extract_window_changes(s48_value changes,
XWindowChanges* WC);
extern s48_value scx_enter_x_error(XErrorEvent* xe);
extern void scx_extract_x_error(s48_value e, XErrorEvent* xe);
//#define scx_enter_REGION(x) s48_enter_integer((long)x)
//#define scx_extract_REGION(x) (Region)s48_extract_integer(x)
// more types
#define scx_extract_state(x) S48_EXTRACT_ENUM(x, "scx-state")
#define scx_enter_state(x) S48_ENTER_ENUM(x, "scx-states")
#define scx_extract_event_mask(x) S48_EXTRACT_ENUM_SET(x, "scx-event-mask")
#define scx_enter_event_mask(x) s48_enter_enum_set(x, "scx-event-mask")
#define scx_extract_gc_value(x) S48_EXTRACT_ENUM(x, "scx-gc-value")
#define scx_enter_gc_value(x) S48_ENTER_ENUM(x, "scx-gc-values")
#define scx_extract_byte_order(x) S48_EXTRACT_ENUM(x, "scx-byte-order")
#define scx_enter_byte_order(x) S48_ENTER_ENUM(x, "scx-byte-orders")
#define scx_extract_bit_order(x) S48_EXTRACT_ENUM(x, "scx-bit-order")
#define scx_enter_bit_order(x) S48_ENTER_ENUM(x, "scx-bit-orders")
#define scx_extract_bit_gravity(x) S48_EXTRACT_ENUM(x, "scx-bit-gravity")
#define scx_enter_bit_gravity(x) S48_ENTER_ENUM(x, "scx-bit-gravities")
#define scx_extract_win_gravity(x) S48_EXTRACT_ENUM(x, "scx-win-gravity")
#define scx_enter_win_gravity(x) S48_ENTER_ENUM(x, "scx-win-gravities")
#define scx_extract_event_type(x) S48_EXTRACT_ENUM(x, "scx-event-type")
#define scx_enter_event_type(x) S48_ENTER_ENUM(x, "scx-event-types")
#define scx_extract_font_direction(x) S48_EXTRACT_ENUM(x, "scx-font-direction")
#define scx_enter_font_direction(x) S48_ENTER_ENUM(x, "scx-font-directions")
#define scx_extract_state(x) S48_EXTRACT_ENUM(x, "scx-state")
#define scx_enter_state(x) S48_ENTER_ENUM(x, "scx-states")
#define scx_extract_state_set(x) S48_EXTRACT_ENUM_SET(x, "scx-state-set")
#define scx_enter_state_set(x) s48_enter_enum_set(x, "scx-state-set")
#define scx_extract_button(x) S48_EXTRACT_ENUM(x, "scx-button")
#define scx_enter_button(x) S48_ENTER_ENUM(x, "scx-buttons")
#define scx_extract_notify_mode(x) S48_EXTRACT_ENUM(x, "scx-notify-mode")
#define scx_enter_notify_mode(x) S48_ENTER_ENUM(x, "scx-notify-modes")
#define scx_extract_notify_detail(x) S48_EXTRACT_ENUM(x, "scx-notify-detail")
#define scx_enter_notify_detail(x) S48_ENTER_ENUM(x, "scx-notify-details")
#define scx_extract_visibility_state(x) \
S48_EXTRACT_ENUM(x, "scx-visibility-state")
#define scx_enter_visibility_state(x) \
S48_ENTER_ENUM(x, "scx-visibility-states")
#define scx_extract_place(x) S48_EXTRACT_ENUM(x, "scx-place")
#define scx_enter_place(x) S48_ENTER_ENUM(x, "scx-places")
#define scx_extract_property_state(x) S48_EXTRACT_ENUM(x, "scx-property-state")
#define scx_enter_property_state(x) S48_ENTER_ENUM(x, "scx-property-states")
#define scx_extract_colormap_state(x) S48_EXTRACT_ENUM(x, "scx-colormap-state")
#define scx_enter_colormap_state(x) S48_ENTER_ENUM(x, "scx-colormap-states")
#define scx_extract_mapping_request(x) \
S48_EXTRACT_ENUM(x, "scx-mapping-request")
#define scx_enter_mapping_request(x) S48_ENTER_ENUM(x, "scx-mapping-requests")
#define scx_extract_backing_store(x) S48_EXTRACT_ENUM(x, "scx-backing-store")
#define scx_enter_backing_store(x) S48_ENTER_ENUM(x, "scx-backing-stores")
#define scx_extract_map_state(x) S48_EXTRACT_ENUM(x, "scx-map-state")
#define scx_enter_map_state(x) S48_ENTER_ENUM(x, "scx-map-states")
#define scx_extract_window_class(x) S48_EXTRACT_ENUM(x, "scx-window-class")
#define scx_enter_window_class(x) S48_ENTER_ENUM(x, "scx-window-classes")
#define scx_extract_stack_mode(x) S48_EXTRACT_ENUM(x, "scx-stack-mode")
#define scx_enter_stack_mode(x) S48_ENTER_ENUM(x, "scx-stack-modes")
#define scx_extract_window_change(x) S48_EXTRACT_ENUM(x, "scx-window-change")
#define scx_enter_window_change(x) S48_ENTER_ENUM(x, "scx-window-changes")
#endif

354
scheme/xlib/client.scm
View File

@ -1,190 +1,94 @@
;; *** manipulate toplevel windows ***********************************
;; iconfiy-window send a WM_CHANGE_STATE message (in an appropiate
;; format), to the root window of the specified screen. See
;; XIconifyWindow.
(define (iconify-window window screen-number)
(check-screen-number (window-display window) screen-number)
(if (not (%iconify-window (display-Xdisplay (window-display window))
(window-Xwindow window)
screen-number))
(error "cannot iconify window"
window)))
(import-lambda-definition %iconify-window (Xdisplay Xwindow scr-num)
;; raises scx-status-error on error.
(import-lambda-definition iconify-window (display window screen-num)
"scx_Iconify_Window")
;; withdraw-window unmaps the specified window and sends a synthetic
;; UnmapNotify event to the root window of the specified screen. See
;; XWithdrawWindow.
(define (withdraw-window window screen-number)
(check-screen-number screen-number)
(if (not (%withdraw-window (display-Xdisplay (window-display window))
(window-Xwindow window)
screen-number))
(error "cannot withdraw window"
window)))
(import-lambda-definition %withdraw-window (Xdisplay Xwindow scr-num)
;; raises scx-status-error on error.
(import-lambda-definition withdraw-window (display window scr-num)
"scx_Withdraw_Window")
;; reconfigure-wm-window change attributes of the specified window
;; reconfigure-wm-window changes attributes of the specified window
;; similar to configure-window, or sends a ConfigureRequestEvent to
;; the root window if that fails. See XReconfigureWMWindow. See
;; configure-window.
(define (reconfigure-wm-window window screen-number window-change-alist)
(check-screen-number screen-number)
(if (not (%reconfigure-wm-window (display-Xdisplay (window-display window))
(window-Xwindow window)
screen-number
(window-change-alist->integer+vector
window-change-alist)))
(error "cannot reconfigure window"
window)))
(import-lambda-definition %reconfigure-wm-window
(Xdisplay Xwindow scrnum changes)
;; raises scx-status-error on error.
(import-lambda-definition reconfigure-wm-window
(display window scr-num changes)
"scx_Reconfigure_Wm_Window")
;; *** set or read a window's WM_* properties ************************
;; get-wm-command reads the WM_COMMAND property from the specified
;; window and returns is as a list of strings. See XGetCommand.
;; window and returns it as a list of strings. See XGetCommand.
(define (get-wm-command window)
(vector->list (%wm-command (display-Xdisplay (window-display window))
(window-Xwindow window))))
(import-lambda-definition %wm-command (Xdisplay Xwindow)
"scx_Wm_Command")
;; raises scx-status-error on error.
(import-lambda-definition get-wm-command (display window)
"scx_Get_Wm_Command")
;; set-wm-command! sets the WM_COMMAND property (the command and
;; arguments used to invoke the application). The command has to be
;; specified as a list of string or symbols. See XSetCommand.
;; specified as a list of strings. See XSetCommand.
(define (set-wm-command! window command)
(%set-wm-command! (display-Xdisplay (window-display window))
(window-Xwindow window)
(list->vector (map (lambda (x)
(if (symbol? x)
(symbol->string x)
x))
command))))
(import-lambda-definition %set-wm-command! (Xdisplay Xwindow command)
(import-lambda-definition set-wm-command! (display window command)
"scx_Set_Wm_Command")
;; get-text-property returns the property specified by atom of the
;; specified window as a list of strings. See XGetTextProperty.
(define (get-text-property window atom)
(let ((res (%get-text-property (display-Xdisplay (window-display window))
(window-Xwindow window)
(atom-Xatom atom))))
(cond
((eq? res #t) #f)
((eq? res #f) (error "cannot create string list from text property"))
(else (vector->list res)))))
(import-lambda-definition %get-text-property (Xdisplay Xwindow Xatom)
"scx_Get_Text_Property")
;; set-text-property! sets the property specified by atom of the
;; specified window to value - a list of strings or symbols.
(define (s->s s)
(if (symbol? s)
(symbol->string s)
s))
(define (set-text-property! window value atom)
(let ((res (%set-text-property! (display-Xdisplay (window-display window))
(window-Xwindow window)
(list->vector (map s->s value))
(atom-Xatom atom))))
(if res
res
(error "cannot create text property from string list" value))))
(import-lambda-definition %set-text-property! (Xdisplay Xwindow value XAtom)
"scx_Set_Text_Property")
;; get-wm-protocols function returns the list of atoms stored in the
;; WM_PROTOCOLS property on the specified window, or #f if this
;; property does not exist or has a bas format. These atoms describe
;; window manager protocols in which the owner of this window is
;; willing to participate. See XGetWMProtocols.
(define (get-wm-protocols window)
(let ((res (%wm-protocols (display-Xdisplay (window-display window))
(window-Xwindow window))))
(if res
(map make-atom
(vector->list res))
#f)))
(import-lambda-definition %wm-protocols (Xdisplay Xwindow)
"scx_Wm_Protocols")
;; raises scx-status-error on error.
(import-lambda-definition get-wm-protocols (display window)
"scx_Get_Wm_Protocols")
;; set-wm-protocols! sets the WM_PROTOCOLS property of the specified
;; window. protocols has to be a list of atoms. See XSetWMProtocols.
(define (set-wm-protocols! window protocols)
(let ((res (%set-wm-protocols! (display-Xdisplay (window-display window))
(window-Xwindow window)
(list->vector (map atom-Xatom protocols)))))
(if res
res
(error "cannot set WM protocols" window protocols))))
(import-lambda-definition %set-wm-protocols! (Xdisplay Xwindow protocols)
;; raises scx-status-error on error.
(import-lambda-definition set-wm-protocols! (display window protocols)
"scx_Set_Wm_Protocols")
;; get-wm-class returns the class hint for the specified window or #f
;; if it does not exists or has a bad format. See XGetClassHint.
;; get-wm-class returns the class hint for the specified window. That
;; is a pair of strings (name . class) See XGetClassHint.
(define (get-wm-class window)
(%wm-class (display-Xdisplay (window-display window))
(window-Xwindow window)))
(import-lambda-definition %wm-class (Xdisplay Xwindow)
"scx_Wm_Class")
;; raises scx-status-error on error.
(import-lambda-definition get-wm-class (display window)
"scx_Get_Wm_Class")
;; set-wm-class! sets the class hint for the specified window. See
;; XSetClassHint.
(define (set-wm-class! window name class)
(%set-wm-class! (display-Xdisplay (window-display window))
(window-Xwindow window)
(if (symbol? name)
(symbol->string name)
name)
(if (symbol? class)
(symbol->string class)
class)))
(import-lambda-definition %set-wm-class! (Xdisplay Xwindow name class)
;; raises scx-status-error on error.
(import-lambda-definition set-wm-class! (display window name class)
"scx_Set_Wm_Class")
;; enumerated type for the XWMHints type. used by set-wm-hints! and
;; get-wm-hints.
;; *** set or read a window's WM_HINTS property **********************
(define-enumerated-type initial-state :initial-state
initial-state? initial-states initial-state-name initial-state-index
(withdrawn normal initial-state-2 iconic initial-state-4))
(define (initial-state->integer v)
(initial-state-index v))
(define (integer->initial-state i)
(vector-ref initial-states i))
(define-exported-binding "scx-initial-state" :initial-state)
(define-exported-binding "scx-initial-states" initial-states)
(define-enumerated-type wm-hint :wm-hint
wm-hint?
wm-hints
wm-hint-name
wm-hint-index
wm-hint? wm-hints wm-hint-name wm-hint-index
(input? initial-state icon-pixmap icon-window icon-position icon-mask
window-group urgency))
window-group wm-hint-7 urgency))
(define-exported-binding "scx-wm-hint" :wm-hint)
(define-exported-binding "scx-wm-hints" wm-hints)
(define-syntax make-wm-hint-alist
(syntax-rules
@ -195,108 +99,62 @@
((make-wm-hint-alist)
'())))
(define wm-hint-alist->integer+vector
(make-enum-alist->integer+vector
wm-hints wm-hint-index
(lambda (v)
(cond
((or (eq? v (wm-hint input?))
(eq? v (wm-hint urgency)))
(lambda (x) x))
((eq? v (wm-hint initial-state))
initial-state->integer)
((or (eq? v (wm-hint icon-pixmap))
(eq? v (wm-hint icon-mask)))
pixmap-Xpixmap)
((or (eq? v (wm-hint icon-window))
(eq? v (wm-hint window-group)))
window-Xwindow)
((eq? v (wm-hint icon-position))
(lambda (x) x))))))
(define (integer+vector->wm-hint-alist display)
(make-integer+vector->enum-alist
wm-hints wm-hint-index
(lambda (v)
(cond
((or (eq? v (wm-hint input?))
(eq? v (wm-hint urgency)))
(lambda (x) x))
((eq? v (wm-hint initial-state))
integer->initial-state)
((or (eq? v (wm-hint icon-pixmap))
(eq? v (wm-hint icon-mask)))
(lambda (Xpixmap)
(make-pixmap Xpixmap display #f)))
((or (eq? v (wm-hint icon-window))
(eq? v (wm-hint window-group)))
(lambda (Xwindow)
(make-window Xwindow display #f)))
((eq? v (wm-hint icon-position))
(lambda (x) x))))))
;; get-wm-hints reads the window manager hints and returns them as an
;; alist mapping wm-hint types to specific values. If a hints is not
;; defined, it is not included in the alist. See wm-hint. See
;; alist mapping wm-hint types to specific values. See wm-hint. See
;; XGetWMHints for a description.
(define (get-wm-hints window)
(let ((res (%wm-hints (display-Xdisplay (window-display window))
(window-Xwindow window))))
(if res
((integer+vector->wm-hint-alist (window-display window)) res)
#f)))
(import-lambda-definition %wm-hints (Xdisplay Xwindow)
"scx_Wm_Hints")
(import-lambda-definition get-wm-hints (display window)
"scx_Get_Wm_Hints")
;; set-wm-hints! sets the specified window manager hints. The hints
;; must be specified as an alist of wm-hint values (see above) mapping
;; to the appropiate values. See XSetWMHints.
(define (set-wm-hints! window wm-hint-alist)
(%set-wm-hints! (display-Xdisplay (window-display window))
(window-Xwindow window)
(wm-hint-alist->integer+vector wm-hint-alist)))
(import-lambda-definition %set-wm-hints! (Xdisplay Xwindow args)
(import-lambda-definition set-wm-hints! (display window wm-hint-alist)
"scx_Set_Wm_Hints")
;; get-transient-for returns the WM_TRANSIENT_FOR property for the
;; specified window. The value of that property is a window. See
;; XGetTransientForHint.
(define (get-transient-for window)
(let ((Xwindow (%transient-for (display-Xdisplay (window-display window))
(window-Xwindow window))))
(if (= 0 Xwindow)
#f
(make-window Xwindow
(window-display window)
#f))))
(import-lambda-definition %transient-for (Xdisplay Xwindow)
"scx_Transient_For")
(import-lambda-definition get-transient-for (display window)
"scx_Get_Transient_For")
;; set-transient-for! sets the WM_TRANSIENT_FOR property of the
;; specified window to the specified property-window. See
;; XSetTransientForHint.
(define (set-transient-for! window property-window)
(%set-transient-for! (display-Xdisplay (window-display window))
(window-Xwindow window)
(window-Xwindow property-window)))
(import-lambda-definition %set-transient-for! (Xdisplay Xwindow
Xpropertywindow)
(import-lambda-definition set-transient-for! (display window prop_window)
"scx_Set_Transient_For")
;; get-text-property returns the property specified by atom of the
;; specified window as a property record. See get-window-property. See
;; XGetTextProperty.
(import-lambda-definition get-text-property (display window atom)
"scx_Get_Text_Property")
;; set-text-property! sets the property specified by atom of the
;; specified window to value - a property record.
(import-lambda-definition set-text-property! (display window value atom)
"scx_Set_Text_Property")
(define (property->string-list property)
(string->string-list (property:data property)))
(define xa-string 31) ;; defined in Xatom.h
(define (string-list->property strings)
(make-property xa-string 8
(string-list->string strings)))
;; The following function a wrappers for the get/set-text-property
;; function.
(define xa-wm-name (make-atom 39))
(define xa-wm-icon-name (make-atom 37))
(define xa-wm-client-machine (make-atom 36))
(define xa-wm-name 39)
(define xa-wm-icon-name 37)
(define xa-wm-client-machine 36)
(define (get-wm-name w)
(get-text-property w xa-wm-name))
@ -331,6 +189,9 @@
(us-position us-size position size min-size max-size resize-inc aspect
base-size win-gravity))
(define-exported-binding "scx-size-hint" :size-hint)
(define-exported-binding "scx-size-hints" size-hints)
(define-syntax make-size-hint-alist
(syntax-rules
()
@ -340,24 +201,6 @@
((make-size-hint-alist)
'())))
(define size-hint-alist->integer+vector
(make-enum-alist->integer+vector
size-hints size-hint-index
(lambda (v)
(cond
((eq? v (size-hint win-gravity))
gravity->integer)
(else (lambda (x) x))))))
(define integer+vector->size-hint-alist
(make-integer+vector->enum-alist
size-hints size-hint-index
(lambda (v)
(cond
((eq? v (size-hint win-gravity))
integer->gravity)
(else (lambda (x) x))))))
;; get-wm-normal-hints/set-wm-normal-hints! get or set the size hints
;; stored in the WM_NORMAL_HINTS property on the specified window. The
;; hints are '(x y width height us-position us-size min-width
@ -365,44 +208,33 @@
;; min-aspect-y max-aspect-x max-aspect-y base-width base-height
;; gravity). See XGetWMNormalHints, XSetWMNormalHints.
(define (get-wm-normal-hints window)
(let* ((v (%wm-normal-hints (display-Xdisplay (window-display window))
(window-Xwindow window))))
(integer+vector->size-hint-alist v)))
(import-lambda-definition get-wm-normal-hints (display window)
"scx_Get_Wm_Normal_Hints")
(import-lambda-definition %wm-normal-hints (Xdisplay Xwindow)
"scx_Wm_Normal_Hints")
(define (set-wm-normal-hints! window size-hint-alist)
(%set-wm-normal-hints! (display-Xdisplay (window-display window))
(window-Xwindow window)
(size-hint-alist->integer+vector size-hint-alist)))
(import-lambda-definition %set-wm-normal-hints! (Xdisplay Xwindow alist)
(import-lambda-definition set-wm-normal-hints! (display window alist)
"scx_Set_Wm_Normal_Hints")
;; get-icon-sizes returns the icon sizes specified by a window manager as
;; a list. If no icon sizes are specified the list is empty. An icon
;; size itself is a list consisting of integers meaning '(min-width
;; min-height max-width max-height width-inc height-inc). See
;; XGetIconSizes.
;; get-icon-sizes returns the icon sizes specified by a window manager
;; as a list. See XGetIconSizes.
(define (get-icon-sizes window)
(let ((r (%icon-sizes (display-Xdisplay (window-display window))
(window-Xwindow window))))
(map vector->list
(vector->list r))))
(define-record-type icon-size :icon-size
(make-icon-size min-width min-height max-width max-height width-inc
height-inc)
icon-size?
(min-width icon-size:min-width set-icon-size:min-width!)
(min-height icon-size:min-height set-icon-size:min-height!)
(max-width icon-size:max-width set-icon-size:max-width!)
(max-height icon-size:max-height set-icon-size:max-height!)
(width-inc icon-size:width-inc set-icon-size:width-inc!)
(height-inc icon-size:height-inc set-icon-size:height-inc!))
(import-lambda-definition %icon-sizes (Xdisplay Xwindow)
"scx_Icon_Sizes")
(define-exported-binding "scx-icon-size" :icon-size)
(import-lambda-definition get-icon-sizes (display window)
"scx_Get_Icon_Sizes")
;; set-icon-sizes! is used only by window managers to set the
;; supported icon sizes. See icon-sizes, XSetIconSizes.
(define (set-icon-sizes! window icon-sizes)
(%set-icon-sizes! (display-Xdisplay (window-display window))
(window-Xwindow window)
(list->vector (map list->vector icon-sizes))))
(import-lambda-definition %set-icon-sizes! (Xdisplay Xwindow sizes)
(import-lambda-definition set-icon-sizes! (display window sizes)
"scx_Set_Icon_Sizes")

275
scheme/xlib/colormap.scm
View File

@ -1,186 +1,113 @@
;; Author: David Frese
;; Copyright (c) 2001-2003 by David Frese
;; special colormaps
(define-record-type color :color
(make-color pixel red green blue)
color?
(pixel color:pixel set-color:pixel!)
(red color:red set-color:red!)
(green color:green set-color:green!)
(blue color:blue set-color:blue!))
(define (special-colormap:none dpy)
(make-colormap 0 dpy #f))
(define-enumerated-type colormap-state :colormap-state
colormap-state? colormap-states colormap-state-name colormap-state-index
(uninstalled installed))
;; alloc-color returns the pixel closest to the specified color
;; supported by the hardware. See XAllocColor. The color parameter is
;; mutated!
(define-exported-binding "scx-colormap-state" :colormap-state)
(define-exported-binding "scx-colormap-states" colormap-states)
(define (alloc-color! colormap color)
(let ((Xpixel (%alloc-color (colormap-Xcolormap colormap)
(color-Xcolor color)
(display-Xdisplay (colormap-display colormap)))))
(if Xpixel
(make-pixel Xpixel colormap #t)
Xpixel)))
(import-lambda-definition %alloc-color (Xcolormap Xcolor Xdisplay)
"scx_Alloc_Color")
;; query/alloc-named-color looks up the named color with respect to
;; the screen that is associated with the specified colormap. It
;; returns the allocated pixel and both the exact database definition
;; and the closest color supported by the screen (as a list). See
;; XAllocNamedColor.
(define (query/alloc-named-color colormap color-name)
(let ((Xres (%alloc-named-color (colormap-Xcolormap colormap)
(if (symbol? color-name)
(symbol->string color-name)
color-name)
(display-Xdisplay
(colormap-display colormap)))))
(if Xres
(list (make-pixel (car Xres) colormap #t)
(apply create-color (cadr Xres))
(apply create-color (caddr Xres)))
Xres)))
(import-lambda-definition %alloc-named-color (Xcolormap name Xdisplay)
"scx_Alloc_Named_Color")
;; alloc-named-color only allocates a named color and returns the
;; allocated pixel (as one might suppose). If the color does not
;; exists it returns #f.
(define (alloc-named-color colormap color-name)
(let ((c (parse-color colormap color-name)))
(if c
(alloc-color! colormap c)
#f)))
;; parse-color looks up the string name of a color and returns the
;; exact color value. See XParseColor. See lookup-color.
(define (parse-color colormap color-name)
(let ((res (%parse-color (display-Xdisplay (colormap-display colormap))
(colormap-Xcolormap colormap)
(if (symbol? color-name)
(symbol->string color-name)
color-name))))
(if res
(create-color (vector-ref res 0)
(vector-ref res 1)
(vector-ref res 2))
#f)))
(import-lambda-definition %parse-color (Xdisplay Xcolormap string)
"scx_Parse_Color")
;; The create-colormap function creates a colormap of the specified
;; visual type for the screen on which the specified window resides.
;; 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)
(colormap-alloc->integer alloc))))
(make-colormap Xcolormap (window-display window) #t)))
(import-lambda-definition %create-colormap (Xdisplay Xwindow Xvisual alloc)
"scx_Create_Colormap")
;; *** create, copy, or destroy colormaps ****************************
(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))
(import-lambda-definition create-colormap (display window visual alloc)
"scx_Create_Colormap")
;; 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.
;; The return value is a pair who's car is the list of the planes
;; (integers), and who's cdr is a list of the pixels.
(define (alloc-color-cells colormap contigous nplanes npixels)
(let ((res (%alloc-color-cells (display-Xdisplay (colormap-display colormap))
(colormap-Xcolormap colormap)
contigous
nplanes npixels)))
(if res
(cons (vector->list (car res))
(map (lambda (Xpixel)
(make-pixel Xpixel colormap #t))
(vector->list (cdr res))))
res)))
(import-lambda-definition %alloc-color-cells (Xdisplay Xcolormap contig
nplanes npixels)
"scx_Alloc_Color_Cells")
;; The store-color function uses XStoreColor(s) to set the content
;; of the color cell specified by pixel (a pixel is an index to a
;; colormap) to color. An optional parameter is a list of the symbols
;; 'do-red 'do-gree and 'do-blue, that specify which components of the
;; color should be used. It defaults to '(do-red do-green
;; do-blue). See XStoreColors.
(define (store-color colormap pixel color . flags)
(%store-color (display-Xdisplay (colormap-display colormap))
(colormap-Xcolormap colormap)
(pixel-Xpixel pixel) (color-Xcolor color)
(color-flags->integer
(if (null? flags)
'(do-red do-green do-blue)
(car flags)))))
(define (color-flags->integer flags)
(fold-right (lambda (s res)
(case s
((do-red) (bitwise-ior res 1))
((do-green) (bitwise-ior res 2))
((do-blue) (bitwise-ior res 4))
(else (error "illegal color-flag" s))))
0 flags))
(import-lambda-definition %store-color (Xdisplay Xcolormap Xpixel Xcolor
flags)
"scx_Store_Color")
;; store-colors does the same as store-color, but for multiple
;; colorcells. The paramter cells must be a list of lists consisting
;; of 2 or 3 elements: a pixel, a color and an optional flags list
;; (see above).
(define (store-colors colormap cells)
(let ((cells (list->vector
(map (lambda (p-c-f)
(list->vector
(list (pixel-Xpixel (car p-c-f))
(color-Xcolor (cadr p-c-f))
(color-flags->integer
(if (null? (cddr p-c-f))
'(do-red do-green do-blue)
(caddr p-c-f))))))
cells))))
(%store-colors (display-Xdisplay (colormap-display colormap))
(colormap-Xcolormap colormap)
cells)))
(import-lambda-definition %store-colors (Xdisplay Xcolormap cells)
"scx_Store_Colors")
;; copy-colormap-and-free function creates a colormap of the same
;; visual type and for the same screen as the specified colormap and
;; returns the new colormap. It also moves all of the client's
;; existing allocation from the specified colormap to the new colormap
;; with their color values intact and their read-only or writable
;; characteristics intact and frees those entries in the specified
;; colormap. See XCopyColormapAndFree
(define (copy-colormap-and-free colormap)
(make-colormap (%copy-colormap-and-free
(display-Xdisplay (colormap-display colormap))
(colormap-Xcolormap colormap))
(colormap-display colormap)
#t))
(import-lambda-definition %copy-colormap-and-free (Xdisplay Xcolormap)
(import-lambda-definition copy-colormap-and-free (display colormap)
"scx_Copy_Colormap_And_Free")
(import-lambda-definition free-colormap (display colormap)
"scx_Free_Colormap")
;; *** allocate and free colors **************************************
(import-lambda-definition alloc-color! (display colormap color)
"scx_Alloc_Color")
;; red, green and blue can be a number between 0 (inclusive) and 1
;; (exclusive), or #f
(define (alloc-color display colormap red green blue)
(let ((color (make-color 0 red green blue)))
(and (alloc-color! display colormap color)
(color:pixel color))))
(import-lambda-definition %alloc-named-color (display colormap color-name)
"scx_Alloc_Named_Color")
;; returns a pair (screen-color exact-color) or #f
(define alloc-named-color/exact %alloc-named-color)
;; returns a color or #f
(define (alloc-named-color display colormap color-name)
(let ((res (alloc-named-color/exact display colormap color-name)))
(and res (car res))))
;; returns a pair of two lists (plane-masks . pixels) or #f
(import-lambda-definition alloc-color-cells/planes
(display colormap contig? nplanes npixels)
"scx_Alloc_Color_Cells")
(define (alloc-color-cells display colormap contig? npixels)
(let ((r (alloc-color-cells/planes display colormap contig? 0 npixels)))
(and r (cdr r))))
;; returns a list of lists (pixels redmask greenmask bluemask) or #f
(import-lambda-definition alloc-color-planes
(display colormap contig? ncolors nreds ngreens nblues)
"scx_Alloc_Color_Planes")
(import-lambda-definition free-colors (display colormap pixels planes)
"scx_Free_Colors")
;; *** obtain color values *******************************************
(import-lambda-definition query-colors! (display colormap colors)
"scx_Query_Colors")
(define (query-colors display colormap pixels)
(let ((colors (map (lambda (pixel) (make-color pixel #f #f #f)) pixels)))
(query-colors! display colormap colors)
colors))
(define (query-color! display colormap color)
(query-colors! display colormap (list color)))
(define (query-color display colormap pixel)
(car (query-colors display colormap (list pixel))))
(import-lambda-definition lookup-color (display colormap color-name)
"scx_Lookup_Color")
(import-lambda-definition parse-color (display colormap spec)
"scx_Parse_Color")
;; *** set colors ****************************************************
(import-lambda-definition store-colors (display colormap colors)
"scx_Store_Colors")
(define (store-color display colormap color)
(store-colors display colormap (list color)))
(import-lambda-definition %store-named-color
(display colormap color-name pixel do-red do-green do-blue)
"scx_Store_Named_Color")
(define (store-named-color display colormap color-name pixel . args)
(let ((flags (cond
((null? args) '(#f #f #f))
((= 3 (length args)) args)
(else (error "invalid optional arguments" args))))) ;;TODO??
(%store-named-color display colormap color-name pixel
(car flags) (cadr flags) (caddr flags))))

162
scheme/xlib/cursor.scm
View File

@ -1,71 +1,113 @@
;; create-pixmap-cursor returns a cursor, that was build using the
;; pixmaps src and mask, and the colors foreground and background. x
;; and y specify the hotspot of the cursor. See XCreatePixmapCursor.
;; Copyright (c) 2001-2003 by David Frese
(define (create-pixmap-cursor src mask x y foreground background)
(let ((display (pixmap-display src)))
(make-cursor (%create-pixmap-cursor (display-Xdisplay display)
(pixmap-Xpixmap src)
(pixmap-Xpixmap mask)
x y
(color-Xcolor foreground)
(color-Xcolor background))
display
#t)))
;; *** create cursors ************************************************
(define create-cursor create-pixmap-cursor) ;; for compatibility with elk
(import-lambda-definition %create-pixmap-cursor (Xdisplay src mask x y f b)
(import-lambda-definition create-pixmap-cursor
(display source mask foreground-color background-color x y)
"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.
(define (create-glyph-cursor src src-char mask mask-char foreground background)
(let ((display (font-display src)))
(make-cursor (%create-glyph-cursor (display-Xdisplay display)
(font-Xfont src)
src-char
(font-Xfont mask)
mask-char
(color-Xcolor foreground)
(color-Xcolor background))
display
#t)))
(import-lambda-definition %create-glyph-cursor
(Xdisplay src srcc mask maskc f b)
;; source-char and mask-char have to be integers.
(import-lambda-definition create-glyph-cursor
(display source-font mask-font source-char mask-char foreground-color
background-color)
"scx_Create_Glyph_Cursor")
;; create-font-cursor returns a cursor, that was build with
;; create-glyph-cursor using a font named "cursor", src-char, the
;; character following src-char as mask-char, and black and as
;; foreground and background.
(import-lambda-definition create-font-cursor (display shape)
"scx_Create_Font_Cursor")
(define (create-font-cursor display src-char)
(let ((font (load-font display "cursor")))
(create-glyph-cursor font src-char
font (+ 1 src-char)
(create-color 0 0 0)
(create-color 65535 65535 65535))
;; elk protects that with unwind-protect, and calls unload-font to free
;; the font, but we free it anyway on garbage-collection...(??)
;;(unload-font font)
))
(define xc-X-cursor 0)
(define xc-arrow 2)
(define xc-based-arrow-down 4)
(define xc-based-arrow-up 6)
(define xc-boat 8)
(define xc-bogosity 10)
(define xc-bottom-left-corner 12)
(define xc-bottom-right-corner 14)
(define xc-bottom-side 16)
(define xc-bottom-tee 18)
(define xc-box-spiral 20)
(define xc-center-ptr 22)
(define xc-circle 24)
(define xc-clock 26)
(define xc-coffee-mug 28)
(define xc-cross 30)
(define xc-cross-reverse 32)
(define xc-crosshair 34)
(define xc-diamond-cross 36)
(define xc-dot 38)
(define xc-dotbox 40)
(define xc-double-arrow 42)
(define xc-draft-large 44)
(define xc-draft-small 46)
(define xc-draped-box 48)
(define xc-exchange 50)
(define xc-fleur 52)
(define xc-gobbler 54)
(define xc-gumby 56)
(define xc-hand1 58)
(define xc-hand2 60)
(define xc-heart 62)
(define xc-icon 64)
(define xc-iron-cross 66)
(define xc-left-ptr 68)
(define xc-left-side 70)
(define xc-left-tee 72)
(define xc-leftbutton 74)
(define xc-ll-angle 76)
(define xc-lr-angle 78)
(define xc-man 80)
(define xc-middlebutton 82)
(define xc-mouse 84)
(define xc-pencil 86)
(define xc-pirate 88)
(define xc-plus 90)
(define xc-question-arrow 92)
(define xc-right-ptr 94)
(define xc-right-side 96)
(define xc-right-tee 98)
(define xc-rightbutton 100)
(define xc-rtl-logo 102)
(define xc-sailboat 104)
(define xc-sb-down-arrow 106)
(define xc-sb-h-double-arrow 108)
(define xc-sb-left-arrow 110)
(define xc-sb-right-arrow 112)
(define xc-sb-up-arrow 114)
(define xc-sb-v-double-arrow 116)
(define xc-shuttle 118)
(define xc-sizing 120)
(define xc-spider 122)
(define xc-spraycan 124)
(define xc-star 126)
(define xc-target 128)
(define xc-tcross 130)
(define xc-top-left-arrow 132)
(define xc-top-left-corner 134)
(define xc-top-right-corner 136)
(define xc-top-side 138)
(define xc-top-tee 140)
(define xc-trek 142)
(define xc-ul-angle 144)
(define xc-umbrella 146)
(define xc-ur-angle 148)
(define xc-watch 150)
(define xc-xterm 152)
;; recolor-cursor resets the colors of an existing cursor. See XRecolorCursor.
;; *** define cursors ************************************************
(define (recolor-cursor cursor foreground background)
(%recolor-cursor (display-Xdisplay (cursor-display cursor))
(cursor-Xcursor cursor)
foreground background))
(import-lambda-definition define-cursor (display window cursor)
"scx_Define_Cursor")
(import-lambda-definition %recolor-cursor (Xdisplay Xcursor f b)
(import-lambda-definition undefine-cursor (display window)
"scx_Undefine_Cursor")
;; *** manipulate cursors ********************************************
(import-lambda-definition recolor-cursor
(display cursor foreground-color background-color)
"scx_Recolor_Cursor")
(import-lambda-definition free-cursor (display cursor)
"scx_Free_Cursor")
;; query-best-cursor defined in gcontext.scm

441
scheme/xlib/display.scm
View File

@ -1,331 +1,168 @@
;; Author: David Frese
;; Copyright (c) 2001-2003 by Norbert Freudemann, David Frese
;; open-display opens the connection to the X Server. It has one optional
;; argument: a string or a symbol specifying the name of the display. If it is
;; not specified, it defaults to the value of the DISPLAY environment variable.
;; See XOpenDisplay.
;; TODO: pixmap-formats (XListPixmapFormats)
(define-record-type display :display
(make-display cpointer connection-number protocol-version protocol-revision
server-vendor image-byte-order bitmap-unit bitmap-pad
bitmap-bit-order vendor-release queue-length name
default-screen screens after-function)
display?
(cpointer display:cpointer)
(connection-number display:connection-number)
(protocol-version display:protocol-version)
(protocol-revision display:protocol-revision)
(server-vendor display:server-vendor)
(image-byte-order display:image-byte-order)
(bitmap-unit display:bitmap-unit)
(bitmap-pad display:bitmap-pad)
(bitmap-bit-order display:bitmap-bit-order)
(vendor-release display:vendor-release)
(queue-length display:queue-length)
(name display:name)
(default-screen display:default-screen)
(screens display:screens)
(after-function display:after-function set-display:after-function!))
(define (open-display . args)
(let ((display-name (if (null? args)
#f
(let ((dpy-name (car args)))
(cond
((symbol? dpy-name) (symbol->string dpy-name))
(else dpy-name))))))
(let ((Xdisplay (%open-display display-name)))
(if (= Xdisplay 0)
(error "cannot open display" display-name)
(make-display Xdisplay #t)))))
(define-exported-binding "scx-display" :display)
(import-lambda-definition %open-display (name)
(define (display-message-inport display)
(fdes->inport (display:connection-number display)))
(define-enumerated-type byte-order :byte-order
byte-order? byte-orders byte-order-name byte-order-index
(lsb-first msb-first))
(define-exported-binding "scx-byte-order" :byte-order)
(define-exported-binding "scx-byte-orders" byte-orders)
(define-enumerated-type bit-order :bit-order
bit-order? bit-orders bit-order-name bit-order-index
(lsb-first msb-first))
(define-exported-binding "scx-bit-order" :bit-order)
(define-exported-binding "scx-bit-orders" bit-orders)
(define-record-type screen-format :screen-format ;; aka pixmap-format
(make-screen-format depth bits-per-pixel scanline-pad)
screen-format?
(depth screen-format:depth)
(bits-per-pixel screen-format:bits-per-pixel)
(scanline-pad screen-format:scanline-pad))
(define-exported-binding "scx-screen-format" :screen-format)
(define-record-type screen :screen
(make-screen cpointer display root-window width height width-mm
height-mm depths root-depth default-visual default-gc
default-colormap white-pixel black-pixel max-maps min-maps
does-backing-store does-save-unders? event-mask)
;; does event-mask change ?? (TODO)
screen?
(cpointer screen:cpointer)
(display screen:display)
(root-window screen:root-window)
(width screen:width)
(height screen:height)
(width-mm screen:width-mm)
(height-mm screen:height-mm)
(depths screen:depths)
(root-depth screen:root-depth)
(default-visual screen:default-visual)
(default-gc screen:default-gc)
(default-colormap screen:default-colormap)
(white-pixel screen:white-pixel)
(black-pixel screen:black-pixel)
(max-maps screen:max-maps)
(min-maps screen:min-maps)
(does-backing-store screen:does-backing-store)
(does-save-unders? screen:does-save-unders?)
(event-mask screen:event-mask))
(define-exported-binding "scx-screen" :screen)
;(define (screen:cells screen)
; (visual:map-entries (screen:default-visual screen)))
;; *** connect or disconnect to X server *****************************
(import-lambda-definition %open-display (display-name)
"scx_Open_Display")
;; for compatibility with elk: is that correct?? see error.c
(define set-after-function! display-set-after-function!)
(define after-function display-after-function)
;; returns a display or #f
(define (open-display . args)
(let ((display-name (if (null? args)
""
(if (null? (cdr args))
(cadr args)
(error "invalid arguments" (cdr args))))));; TODO
(%open-display display-name)))
;; display-default-root-window returns the root window of the default screen.
;; See DefaultRootWindow.
(import-lambda-definition close-display (display)
"scx_Close_Display")
(define (display-default-root-window display)
(let* ((Xdisplay (display-Xdisplay display))
(Xwindow (%default-root-window Xdisplay)))
(make-window Xwindow display #f)))
(define none 0)
(define parent-relative 1)
(define copy-from-parent 0)
(define pointer-window 0)
(define input-focus 1)
(define pointer-root 1)
(define any-property-type 0)
(define any-key 0)
(define all-temporary 0)
(define current-time 0)
(define no-symbol 0)
(define all-planes (- (arithmetic-shift 1 32) 1))
(import-lambda-definition %default-root-window (Xdisplay)
"scx_Display_Default_Root_Window")
;; *** record types **************************************************
;; display-root-window returns the root window of the specified screen.
;; See RootWindow.
(import-lambda-definition display:last-request-read (display)
"scx_Display_Last_Request_Read")
(define (display-root-window display screen-number)
(let* ((Xdisplay (display-Xdisplay display))
(Xwindow (%root-window Xdisplay screen-number)))
(make-window Xwindow display #f)))
;; *** convenience functions *****************************************
(import-lambda-definition %root-window (Xdisplay scr_num)
"scx_Display_Root_Window")
(define (default-root-window display)
(screen:root-window (list-ref (display:screens display)
(display:default-screen display))))
;; display-default-colormap return the default colormap for allocation on the
;; default screen of the specified display. See DefaultColormap.
(import-lambda-definition next-request (display)
"scx_Next_Request")
(define (display-default-colormap display . maybe-screen-number)
(let* ((Xdisplay (display-Xdisplay display))
(scr (get-maybe-screen-number display maybe-screen-number))
(Xcolormap (%default-colormap Xdisplay
scr)))
(make-colormap Xcolormap display #f)))
;; *** enable or disable synchronization *****************************
;; for compatibility with Elk.
(define display-colormap display-default-colormap)
(define (synchronize display on?)
(if on?
(set-after-function! display
(lambda (display) (display-sync display #f)))
(set-after-function! display default-after-function)))
(import-lambda-definition %default-colormap (Xdisplay scr)
"scx_Display_Default_Colormap")
;; returns the previous after-function. An after-function is called
;; with the display object.
;; display-default-gcontext return the default graphics context for the root
;; window of the default screen of the specified display. See DefaultGC.
(define (default-after-function display) ;; TODO: check if this is the real one
(display-flush display))
(define (display-default-gcontext display . maybe-screen-number)
(let* ((Xdisplay (display-Xdisplay display))
(scr (get-maybe-screen-number display maybe-screen-number))
(Xgcontext (%default-gcontext Xdisplay scr)))
(make-gcontext Xgcontext display #f)))
(define-exported-binding "scx-default-after-function" default-after-function)
(import-lambda-definition %default-gcontext (Xdisplay scr)
"scx_Display_Default_Gcontext")
(define (set-after-function! display fun)
(let ((prev (display:after-function display)))
(set-display:after-function! display fun)
prev))
;; display-default-depth returns the depth (number of planes) of the default
;; root window of the default screen of the specified display. See DefaultDepth.
;; *** handle output buffer or event queue ***************************
(define (display-default-depth display . maybe-screen-number)
(let ((Xdisplay (display-Xdisplay display))
(scr (get-maybe-screen-number display maybe-screen-number)))
(%default-depth Xdisplay scr)))
(import-lambda-definition display-flush (display)
"scx_Display_Flush")
(import-lambda-definition %default-depth (Xdisplay scr)
"scx_Display_Default_Depth")
;; display-default-screen-number returns the default screen number of the given
;; display. See DefaultScreen.
(define (display-default-screen-number display)
(let ((Xdisplay (display-Xdisplay display)))
(%default-screen-number Xdisplay)))
(import-lambda-definition %default-screen-number (Xdisplay)
"scx_Display_Default_Screen_Number")
;; display-default-visual returns the default visual of the given
;; display. If no screen-number is specified the default screen is
;; used. See DisplayVisual.
(define (display-default-visual display . screen-number)
(make-visual
(%default-visual (display-Xdisplay display)
(get-maybe-screen-number display screen-number))))
(import-lambda-definition %default-visual (Xdisplay scr-num)
"scx_Display_Default_Visual")
;; internal function
(define (get-maybe-screen-number dpy maybe-screen-number)
(if (null? maybe-screen-number)
(display-default-screen-number dpy)
(begin
(check-screen-number dpy (car maybe-screen-number))
(car maybe-screen-number))))
(define (check-screen-number display screen-number)
(if (or (< screen-number 0)
(>= screen-number (display-screen-count display)))
(error "invalid screen number" screen-number)))
;; display-cells returns the number of entries in the default colormap of the
;; specified screen. See DisplayCells.
(define (display-cells display . maybe-screen-number)
(%display-cells (display-Xdisplay display)
(get-maybe-screen-number display maybe-screen-number)))
(import-lambda-definition %display-cells (Xdisplay screen-number)
"scx_Display_Cells")
;; display-planes returns the depth of the root window of the specified screen.
;; See DisplayPlanes.
(define (display-planes display . maybe-screen-number)
(%display-planes (display-Xdisplay display)
(get-maybe-screen-number display maybe-screen-number)))
(import-lambda-definition %display-planes (Xdisplay screen-number)
"scx_Display_Planes")
;; display-string returns the name of the display as a string - the same that
;; was specified with open-display. See DisplayString.
(define (display-string display)
(%display-string (display-Xdisplay display)))
(import-lambda-definition %display-string (Xdisplay)
"scx_Display_String")
;; Display-Vendor returns a pair, whose car is the vendor identification and
;; whose cdr is the release number. See DisplayVendor.
(define (display-vendor display)
(%display-vendor (display-Xdisplay display)))
(import-lambda-definition %display-vendor (Xdisplay)
"scx_Display_Vendor")
;; Display-protocol-version return a pair of major and minor version numbers of
;; the X protocol.
(define (display-protocol-version display)
(%display-protocol-version (display-Xdisplay display)))
(import-lambda-definition %display-protocol-version (Xdisplay)
"scx_Display_Protocol_Version")
;; display-screen-count returns the number of available screen on this display.
;; See ScreenCount.
(define (display-screen-count display)
(%display-screen-count (display-Xdisplay display)))
(import-lambda-definition %display-screen-count (Xdisplay)
"scx_Display_Screen_Count")
;; display-image-byte-order returns one of the symbols 'lsb-first and
;; 'msb-first.
(define (display-image-byte-order display)
(integer->byte-order (%display-image-byte-order (display-Xdisplay display))))
(import-lambda-definition %display-image-byte-order (Xdisplay)
"scx_Display_Image_Byte_Order")
;; display-bitmap-unit returns the size of a bitmap's scanline unit in bits.
;; See BitmapUnit.
(define (display-bitmap-unit display)
(%display-bitmap-unit (display-Xdisplay display)))
(import-lambda-definition %display-bitmap-unit (Xdisplay)
"scx_Display_Bitmap_Unit")
;; display-bitmap-bit-order return one the symbols 'lbs-first and 'msb-first.
;; See BitmapBitOrder.
(define (display-bitmap-bit-order display)
(integer->bit-order (%display-bitmap-bit-order (display-Xdisplay display))))
(import-lambda-definition %display-bitmap-bit-order (Xdisplay)
"scx_Display_Bitmap_Bit_Order")
;; display-bitmap-pad returns the number of bits that each scanline must be
;; padded. See BitmapPad.
(define (display-bitmap-pad display)
(%display-bitmap-pad (display-Xdisplay display)))
(import-lambda-definition %display-bitmap-pad (Xdisplay)
"scx_Display_Bitmap_Pad")
;; display-width (-height) returns the width (height) of the screen in pixels.
;; See DisplayWidth (DisplayHeight).
(define (display-width display . maybe-screen-number)
(%display-width (display-Xdisplay display)
(get-maybe-screen-number display maybe-screen-number)))
(import-lambda-definition %display-width (Xdisplay scr)
"scx_Display_Width")
(define (display-height display . maybe-screen-number)
(%display-height (display-Xdisplay display)
(get-maybe-screen-number display maybe-screen-number)))
(import-lambda-definition %display-height (Xdisplay scr)
"scx_Display_Height")
;; display-width-mm (-height-mm) returns the width (height) of the screen in
;; millimeters. See DisplayWidthMM (DisplayHeightMM).
(define (display-width-mm display . maybe-screen-number)
(%display-width-mm (display-Xdisplay display)
(get-maybe-screen-number display maybe-screen-number)))
(import-lambda-definition %display-width-mm (Xdisplay scr)
"scx_Display_Width_Mm")
(define (display-height-mm display . maybe-screen-number)
(%display-height-mm (display-Xdisplay display)
(get-maybe-screen-number display maybe-screen-number)))
(import-lambda-definition %display-height-mm (Xdisplay scr)
"scx_Display_Height_Mm")
;; See XDisplayMotionBufferSize.
(define (display-motion-buffer-size display)
(%display-motion-buffer-size (display-Xdisplay display)))
(import-lambda-definition %display-motion-buffer-size (Xdisplay)
"scx_Display_Motion_Buffer_Size")
;; The display-flush-output flushes the output buffer. See XFlush.
(define (display-flush-output display)
(%display-flush-output (display-Xdisplay display)))
(import-lambda-definition %display-flush-output (Xdisplay)
"scx_Display_Flush_Output")
;; display-wait-output flushes the output buffer and then waits until all
;; requests have been received and processed by the X server. discard-events?
;; specifies whether the events in the queue are discarded or nor. See XSync.
(define (display-wait-output display discard-events?)
(%display-wait-output (display-Xdisplay display)
discard-events?))
(import-lambda-definition %display-wait-output (Xdisplay discard)
"scx_Display_Wait_Output")
(import-lambda-definition display-sync (display discard?)
"scx_Display_Sync")
;; display-no-op sends a NoOperation protocol request to the X server, thereby
;; exercising the connection. See XNoOp.
(define (display-no-op display)
(%no-op (display-Xdisplay display)))
(import-lambda-definition %no-op (Xdisplay)
(import-lambda-definition display-no-op (display)
"scx_No_Op")
;; for compatibility with Elk.
(define no-op display-no-op)
;; *** select input events *******************************************
;; display-list-depths returns a vector of depths (integers) that are available
;; on the specified screen. See XListDepths.
(define (display-list-depths display screen-number)
(%display-list-depths (display-Xdisplay display)
(check-screen-number display screen-number)))
(import-lambda-definition %display-list-depths (Xdisplay scr)
"scx_List_Depths")
;; for compatibility with Elk.
(define list-depths display-list-depths)
;; display-list-pixmap-formats returns a vector of lists with 3 integers: depth,
;; bits per pixel and scanline pad (See above). See XListPixmapFormats.
(define (display-list-pixmap-formats display)
(%display-list-pixmap-formats (display-Xdisplay display)))
(define list-pixmap-formats display-list-pixmap-formats) ;; compat./Elk
(import-lambda-definition %display-list-pixmap-formats (Xdisplay)
"scx_List_Pixmap_Formats")
;; synchronize just sets the after-function of the display to
;; display-wait-output (with #f for discard-events?).
(define (synchronize display)
(display-set-after-function!
display
(lambda (display)
(display-wait-output display #f))))
;; display-select-input requests that the X server report the events
;; associated with the specified event mask. See XSelectInput.
(define (display-select-input window event-mask)
(%display-select-input (display-Xdisplay (window-display window))
(window-Xwindow window)
(event-mask->integer event-mask)))
(import-lambda-definition %display-select-input (Xdisplay Xwindow Xevent-mask)
(import-lambda-definition display-select-input (display window event-mask)
"scx_Display_Select_Input")

155
scheme/xlib/error.scm
View File

@ -1,37 +1,19 @@
;; Copyright (c) 2001-2003 by Norbert Freudemann, David Frese
;; *** x errors ******************************************************
(define-record-type x-error :x-error
(really-make-x-error display ser-num code major-opcode minor-opcode res-id text next)
(make-x-error display serial code major-opcode minor-opcode resource-id text)
x-error?
(display x-error-display)
(ser-num x-error-ser-num)
(code x-error-code)
(major-opcode x-error-major-opcode)
(minor-opcode x-error-minor-opcode)
(res-id x-error-res-id)
(text x-error-text)
(next really-next-x-error really-set-next-x-error!))
(display x-error:display)
(serial x-error:serial)
(code x-error:code)
(major-opcode x-error:major-opcode)
(minor-opcode x-error:minor-opcode)
(resource-id x-error:resource-id)
(text x-error:text))
(define (make-x-error display ser-num code major-opcode minor-opcode res-id text)
(really-make-x-error display ser-num code major-opcode
minor-opcode res-id text (make-placeholder)))
(define (next-x-error x-error)
(placeholder-value (really-next-x-error x-error)))
(define (set-next-x-error! x-error next-x-error)
(placeholder-set! (really-next-x-error x-error) next-x-error))
(define empty-x-error (make-x-error #f #f #f #f #f #f #f))
(define (empty-x-error? obj)
(eq? obj empty-x-error))
(define *most-recent-x-error* empty-x-error)
(define (most-recent-x-error)
*most-recent-x-error*)
(define (advance-most-recent-x-error!)
(set! *most-recent-x-error*
(next-x-error *most-recent-x-error*)))
(define-exported-binding "scx-x-error" :x-error)
(define-enumerated-type error-code :error-code
error-code? error-codes error-code-name error-code-index
@ -39,43 +21,88 @@
bad-cursor bad-font bad-match bad-drawable bad-access bad-alloc
bad-color bad-gc bad-id-choice bad-name bad-length bad-implementation))
(define (integer->error-code i)
(if (< i (vector-length error-codes))
(vector-ref error-codes i)
;; there can be larger numbers - extension errors
i))
(define-exported-binding "scx-error-code" :error-code)
(define-exported-binding "scx-error-codes" error-codes)
(define internal-x-error-handler
(lambda (infos)
(let ((display (make-display (vector-ref infos 0) #f))
(ser-num (vector-ref infos 1))
(error-code (integer->error-code (vector-ref infos 2)))
(major-opcode (vector-ref infos 3))
(minor-opcode (vector-ref infos 4))
(res-id (vector-ref infos 5))
(error-string (vector-ref infos 6)))
(set-next-x-error! *most-recent-x-error*
(make-x-error display ser-num error-code major-opcode
minor-opcode res-id error-string))
(advance-most-recent-x-error!))))
;; *** error exceptions **********************************************
(define-exported-binding "internal-x-error-handler" internal-x-error-handler)
;; Call synchronize to have the exceptions signaled where they belong to.
;;; Fatal errors are handled by an ordinary handler
(define *x-fatal-error-handler* #f)
(define (use-x-error-exceptions!)
(set-error-handler! (lambda (display error)
(error "x-exception: " display error)))) ;; TODO
(define internal-x-fatal-error-handler
(lambda (Xdisplay)
(if *x-fatal-error-handler*
(*x-fatal-error-handler* (make-display Xdisplay #f))
#f)))
;; *** error-queue ***************************************************
;; Interface:
;; (use-x-error-queue!) returns a thunk that returns the most recent queue
;; element.
;; (empty-x-error-queue? q) return #t only for the initial queue.
;; (next-x-error-queue q) returns the next queue element, blocks if necessary.
;; (x-error-queue:this q) returns the x-error of that queue.
(define (use-x-error-queue!) ;; exp
(let* ((most-recent-x-error-queue empty-x-error-queue)
(handler (lambda (display error)
(set-next-x-error-queue! most-recent-x-error-queue
(make-x-error-queue error))
(set! most-recent-x-error-queue
(next-x-error-queue most-recent-x-error-queue)))))
(set-error-handler! handler)
(lambda () most-recent-x-error-queue)))
(define-record-type x-error-queue :x-error-queue
(really-make-x-error-queue this next)
x-error-queue?
(this x-error-queue:this)
(next really-next-x-error-queue really-set-next-x-error-queue!))
(define (make-x-error-queue error)
(really-make-x-error-queue error (make-placeholder)))
(define empty-x-error-queue (make-x-error-queue #f))
(define (empty-x-error-queue? obj)
(eq? obj empty-x-error-queue))
(define (next-x-error-queue x-error-queue)
(placeholder-value (really-next-x-error-queue x-error-queue)))
(define (set-next-x-error-queue! x-error-queue next-x-error-queue)
(placeholder-set! (really-next-x-error-queue x-error-queue)
next-x-error-queue))
;; *** default error handlers ****************************************
(import-lambda-definition %set-error-handler (handler)
"scx_Set_Error_Handler")
(import-lambda-definition call-c-error-handler (pointer display event)
"scx_Call_C_Error_Handler")
(define (set-error-handler! handler)
(let ((res (%set-error-handler handler)))
(if (number? res)
(lambda (display event) (call-c-error-handler (res display event)))
res)))
(import-lambda-definition get-error-text (display code)
"scx_Get_Error_Text")
(import-lambda-definition get-error-database-text
(display name message default-string)
"scx_Get_Error_Database_Text")
;(import-lambda-definition %set-io-error-handler (handler)
; "scx_Set_IO_Error_Handler")
(define *x-fatal-error-handler* ;; TODO do it like above??
(lambda (display)
#f))
(define-exported-binding "internal-x-fatal-error-handler"
internal-x-fatal-error-handler)
*x-fatal-error-handler*)
(define (x-fatal-error-handler . args)
(if (null? args)
*x-fatal-error-handler*
(let ((old-hander *x-fatal-error-handler*))
(set! *x-fatal-error-handler* (car args))
old-hander)))
(define (set-io-error-handler handler)
(let ((old-handler *x-fatal-error-handler*))
(set! *x-fatal-error-handler* handler)
old-handler))

829
scheme/xlib/event-types.scm
View File

File diff suppressed because it is too large Load Diff

106
scheme/xlib/event.scm
View File

@ -25,116 +25,38 @@
;; How to find out if there are events available *********************
(define (event-ready? display)
(or (> (events-queued display (queued-mode already)) 0)
(char-ready? (display-message-inport display))))
(define (events-queued display mode)
(%events-queued (display-Xdisplay display)
(queued-mode->integer mode)))
(import-lambda-definition %events-queued (Xdisplay mode)
"scx_Events_Queued")
(define-enumerated-type queued-mode :queued-mode
queued-mode? queued-modes queued-mode-name queued-mode-index
(already after-reading after-flush))
(define (queued-mode->integer mode)
(queued-mode-index mode))
(define-exported-binding "scx-queued-mode" :queued-mode)
(import-lambda-definition events-queued (display mode)
"scx_Events_Queued")
(define (event-ready? display)
(or (> (events-queued display (queued-mode already)) 0)
(char-ready? (display-message-inport display))))
;; events-pending is identical to events-queued with after-flush
;; mode.
(define (events-pending display)
(%events-pending (display-Xdisplay display)))
(import-lambda-definition %events-pending (Xdisplay)
(import-lambda-definition events-pending (display)
"scx_Events_Pending")
;; Other event reading ***********************************************
(define (next-event display)
(let ((r (%next-event (display-Xdisplay display))))
(complete-event r)))
(import-lambda-definition %next-event (Xdisplay)
(import-lambda-definition next-event (display)
"scx_Next_Event")
(define (peek-event display)
(let ((r (%peek-event (display-Xdisplay display))))
(complete-event r)))
(import-lambda-definition %peek-event (Xdisplay)
(import-lambda-definition peek-event (display)
"scx_Peek_Event")
(define (get-motion-events window from-time to-time)
(%get-motion-events (display-Xdisplay (window-display window))
(window-Xwindow window)
from-time to-time))
(import-lambda-definition %get-motion-events (Xdisplay Xwindow from to)
;; returns a list of (time . (x . y)) elements
(import-lambda-definition get-motion-events (display window from to)
"scx_Get_Motion_Events")
;; Sending events ****************************************************
(define (send-event display window propagate? event-mask event)
(let ((Xdisplay (display-Xdisplay display))
(Xwindow (window-Xwindow window))
(mask (event-mask->integer event-mask))
(v (any-event->vector event))
(type (event-type->integer (any-event-type event))))
(%send-event Xdisplay Xwindow propagate? mask v type)))
(import-lambda-definition %send-event (Xdisplay Xwindow propagate mask v type)
(import-lambda-definition send-event (display window propagate mask event)
"scx_Send_Event")
;; Auxiliaries *******************************************************
;; creates an event type
(define (complete-event v)
(vector-set! v 0 (integer->event-type (vector-ref v 0)))
(let ((constructor (event-constructor (vector-ref v 0))))
(apply constructor (vector->list v))))
(define (event-constructor type)
(cond
((or (eq? type (event-type key-press))
(eq? type (event-type key-release))) make-key-event)
((or (eq? type (event-type button-press))
(eq? type (event-type button-release))) make-button-event)
((eq? type (event-type motion-notify)) make-motion-event)
((or (eq? type (event-type enter-notify))
(eq? type (event-type leave-notify))) make-crossing-event)
((or (eq? type (event-type focus-in))
(eq? type (event-type focus-out))) make-focus-change-event)
((eq? type (event-type keymap-notify)) make-keymap-event)
((eq? type (event-type expose)) make-expose-event)
((eq? type (event-type graphics-expose)) make-graphics-expose-event)
((eq? type (event-type no-expose)) make-no-expose-event)
((eq? type (event-type visibility-notify)) make-visibility-event)
((eq? type (event-type create-notify)) make-create-window-event)
((eq? type (event-type destroy-notify)) make-destroy-window-event)
((eq? type (event-type unmap-notify)) make-unmap-event)
((eq? type (event-type map-notify)) make-map-event)
((eq? type (event-type map-request)) make-map-request-event)
((eq? type (event-type reparent-notify)) make-reparent-event)
((eq? type (event-type configure-notify)) make-configure-event)
((eq? type (event-type configure-request)) make-configure-request-event)
((eq? type (event-type gravity-notify)) make-gravity-event)
((eq? type (event-type resize-request)) make-resize-request-event)
((eq? type (event-type circulate-notify)) make-circulate-event)
((eq? type (event-type circulate-request)) make-circulate-request-event)
((eq? type (event-type property-notify)) make-property-event)
((eq? type (event-type selection-clear)) make-selection-clear-event)
((eq? type (event-type selection-request)) make-selection-request-event)
((eq? type (event-type selection-notify)) make-selection-event)
((eq? type (event-type colormap-notify)) make-colormap-event)
((eq? type (event-type client-message)) make-client-message-event)
((eq? type (event-type mapping-notify)) make-mapping-event)
(else (error "message type not supported" type))))
;;event-type-0 event-type-1 ;; those are not defined

289
scheme/xlib/font.scm
View File

@ -1,201 +1,126 @@
;; list-font-names returns the names of all available fonts that match
;; the pattern. pattern has to be a string. See XListFonts.
;; Copyright (c) 2001-2003 by Norbert Freudemann, David Frese
(define (list-font-names display pattern)
(vector->list (%list-font-names (display-Xdisplay display)
(if (symbol? pattern)
(symbol->string pattern)
pattern))))
(define-enumerated-type font-direction :font-direction
font-direction? font-directions font-direction-name font-direction-index
(left-to-right right-to-left))
(import-lambda-definition %list-font-names (Xdisplay pattern)
"scx_List_Font_Names")
(define-exported-binding "scx-font-direction" :font-direction)
(define-exported-binding "scx-font-directions" font-directions)
;; list-fonts returns all fonts that match the pattern. pattern has to
;; be string. See XListFonts.
(define-record-type char-struct :char-struct
(make-char-struct lbearing rbearing width ascent descent attributes)
char-struct?
(lbearing char-struct:lbearing)
(rbearing char-struct:rbearing)
(width char-struct:width)
(ascent char-struct:ascent)
(descent char-struct:descent)
(attributes char-struct:attributes))
(define (list-fonts display pattern)
(let ((v (%list-fonts (display-Xdisplay display)
(if (symbol? pattern)
(symbol->string pattern)
pattern))))
(vector->list (vector-map! (lambda (name-Xfontstruct)
(make-font (car name-Xfontstruct)
#f
(cdr name-Xfontstruct)
display
#t))
v))))
(define-exported-binding "scx-char-struct" :char-struct)
(import-lambda-definition %list-fonts (Xdisplay pattern)
(define-record-type font-struct :font-struct
(make-font-struct cpointer
fid direction min-char-or-byte2 max-char-or-byte2
min-byte1 max-byte1 all-char-exist? default-char
properties min-bounds max-bounds per-char ascent descent)
font-struct?
;; properties is an alist atom -> number
;; per-char is a vector of char-structs
;; min-bounds, max-bounds are a char-struct
(cpointer font-struct:cpointer)
(fid font-struct:fid)
(direction font-struct:direction)
(min-char-or-byte2 font-struct:min-char-or-byte2)
(max-char-or-byte2 font-struct:max-char-or-byte2)
(min-byte1 font-struct:min-byte1)
(max-byte1 font-struct:max-byte1)
(all-char-exist? font-struct:all-char-exist?)
(default-char font-struct:default-char)
(properties font-struct:properties)
(min-bounds font-struct:min-bounds)
(max-bounds font-struct:max-bounds)
(per-char font-struct:per-char)
(ascent font-struct:ascent)
(descent font-struct:descent))
(define-exported-binding "scx-font-struct" :font-struct)
;; *** load or unload fonts ******************************************
(import-lambda-definition load-font (display name)
"scx_Load_Font")
(import-lambda-definition unload-font (display font)
"scx_Unload_Font")
;; returns a font-struct record or #f
(import-lambda-definition query-font (display font-id)
"scx_Query_Font")
;; returns a font-struct record or #f
(import-lambda-definition load-query-font (display name)
"scx_Load_Query_Font")
(import-lambda-definition free-font (display font-struct)
"scx_Free_Font")
(define (get-font-property font-struct atom)
(let ((a (assq atom (font-struct:properties)))) ;; assq ??
(and a (cdr a))))
;; *** obtain or free font names and information *********************
(import-lambda-definition list-fonts (display pattern maxnames)
"scx_List_Fonts")
;; font-properties returns an alist that maps atoms to the
;; corresponding values. See XFontStruct.
;; returns an alist mapping name -> font-struct
(import-lambda-definition list-fonts-with-info (display pattern maxnames)
"scx_List_Fonts_With_Info")
(define (font-properties font)
(let ((v (%font-properties (font-Xfontstruct font))))
(vector->list (vector-map! (lambda (XAtom-Val)
(cons (make-atom (car XAtom-Val))
(cdr XAtom-Val)))
v))))
;; *** set or get the font search path *******************************
(import-lambda-definition %font-properties (Xfontstruct)
"scx_Font_Properties")
;; font-property returns the value of specified
;; property. property-name has to be string or a symbol specifying an
;; atom. See XGetFontProperty.
(define (font-property font property-name)
(let ((atom (intern-atom (font-display font)
property-name)))
(%font-property (font-Xfontstruct font)
(atom-Xatom atom))))
(import-lambda-definition %font-property (Xfontstruct Xatom)
"scx_Font_Property")
;; font-path returns the (implementation and file system dependand)
;; path to the font files. See XGetFontPath, and XSetFontPath.
(define (font-path display)
(vector->list (%font-path (display-Xdisplay display))))
(import-lambda-definition %font-path (Xdisplay)
"scx_Font_Path")
(define (set-font-path! display path)
(%set-font-path! (display-Xdisplay display)
(map (lambda (s)
(if (symbol? s)
(symbol->string s)
s))
(list->vector path))))
(import-lambda-definition %set-font-path! (Xdisplay path)
(import-lambda-definition set-font-path (display directories)
"scx_Set_Font_Path")
;; font-info returns a vector containing all information available for
;; the font. See XFontStruct.
(define (font-info font)
(let ((v (%font-info (font-Xfontstruct font))))
(vector-set! v 0 (integer->font-direction (vector-ref v 0)))
v))
(import-lambda-definition %font-info (Xfontstruct)
"scx_Font_Info")
(define (integer->font-direction i)
(case i
((0) 'left-to-right)
((1) 'right-to-left)
(else i)))
(define (font-info-getter num)
(lambda (font)
(vector-ref (font-info font)
num)))
(define font-direction (font-info-getter 0))
(define font-min-byte2 (font-info-getter 1))
(define font-max-byte2 (font-info-getter 2))
(define font-min-byte1 (font-info-getter 3))
(define font-max-byte1 (font-info-getter 4))
(define font-all-chars-exist? (font-info-getter 5))
(define font-default-char (font-info-getter 6))
(define font-ascent (font-info-getter 7))
(define font-descent (font-info-getter 8))
;; char-info returns a vector containing font-dependand character
;; information. See also min/max/char-* functions below. See XFontStruct.
(define (char-info font index)
(%char-info (font-Xfontstruct font)
(cond
((eq? index 'min) #f)
((eq? index 'max) #t)
(else (let ((i (if (char? index)
(char->integer index)
index)))
(calc-index font i))))))
(import-lambda-definition %char-info (Xfontstruct index)
"scx_Char_Info")
(import-lambda-definition get-font-path (display)
"scx_Get_Font_Path")
;; TODO: ??
;; calc-index calculates the array-position in XFontStruct.per_char by giving
;; the character index which ranges between [font-min-byte2...font-max-byte2]
;; for one-byte fonts or for two-byte fonts the lower 8 bits must be between
;; [font-min-byte1...font-max-byte1] and the higher 8 bits must be between
;; [font-min-byte2...font-max-byte2]. An error is raised if the index does not
;; fit into these boundaries.
(define (calc-index font index)
(let ((min1 (font-min-byte1 font))
(max1 (font-max-byte1 font))
(min2 (font-min-byte2 font))
(max2 (font-max-byte2 font))
(check-bounds
(lambda (min max i s)
(if (or (< i min)
(> i max))
(error (string-append s
(number->string min)
" and "
(number->string max)
"; given")
index)))))
(if (and (= 0 min1) (= 0 max1))
;; two-byte font
(let ((b1 (bitwise-and index 255))
(b2 (bitwise-and (arithmetic-shift index -8) 255)))
(check-bounds min1 max1 b1
"expected an integer with lower 8 bits between ")
(check-bounds min2 max2 b2
"expected an integer with higher 8 bits between ")
(+ (* b1 (+ (- max2 min2) 1))
b2))
;; one-byte font
(begin
(check-bounds min2 max2 index
"expected an integer between ")
index))))
;(define (calc-index font index)
; (let ((min1 (font-min-byte1 font))
; (max1 (font-max-byte1 font))
; (min2 (font-min-byte2 font))
; (max2 (font-max-byte2 font))
; (check-bounds
; (lambda (min max i s)
; (if (or (< i min)
; (> i max))
; (error (string-append s
; (number->string min)
; " and "
; (number->string max)
; "; given")
; index)))))
; (if (and (= 0 min1) (= 0 max1))
; ;; two-byte font
; (let ((b1 (bitwise-and index 255))
; (b2 (bitwise-and (arithmetic-shift index -8) 255)))
; (check-bounds min1 max1 b1
; "expected an integer with lower 8 bits between ")
; (check-bounds min2 max2 b2
; "expected an integer with higher 8 bits between ")
; (+ (* b1 (+ (- max2 min2) 1))
; b2))
; ;; one-byte font
; (begin
; (check-bounds min2 max2 index
; "expected an integer between ")
; index))))
(define (char-info-getter num)
(lambda (font index)
(vector-ref (char-info font index)
num)))
(define char-rbearing (char-info-getter 0))
(define char-lbearing (char-info-getter 1))
(define char-width (char-info-getter 2))
(define char-ascent (char-info-getter 3))
(define char-descent (char-info-getter 4))
(define char-attributes (char-info-getter 5))
(define (max-char-info-getter num)
(lambda (font)
(vector-ref (char-info font 'max)
num)))
(define (max-char-info font)
(char-info font 'max))
(define max-char-rbearing (max-char-info-getter 0))
(define max-char-lbearing (max-char-info-getter 1))
(define max-char-width (max-char-info-getter 2))
(define max-char-ascent (max-char-info-getter 3))
(define max-char-descent (max-char-info-getter 4))
(define max-char-attributes (max-char-info-getter 5))
(define (min-char-info-getter num)
(lambda (font)
(vector-ref (char-info font 'min)
num)))
(define (min-char-info font)
(char-info font 'min))
(define min-char-rbearing (min-char-info-getter 0))
(define min-char-lbearing (min-char-info-getter 1))
(define min-char-width (min-char-info-getter 2))
(define min-char-ascent (min-char-info-getter 3))
(define min-char-descent (min-char-info-getter 4))
(define min-char-attributes (min-char-info-getter 5))

493
scheme/xlib/gcontext.scm
View File

@ -1,107 +1,75 @@
;; create-gcontext returns a newly create graphic context for the
;; specified drawable (a window or a pixmap). The gc-value-alist has
;; to be an alist mapping a gc-value (defined above) to a
;; corresponding value. See XCreateGC.
;; Copyright (c) 2001-2003 by Norbert Freudemann, David Frese
(define (create-gcontext drawable gc-value-alist)
(let ((display (drawable-display drawable))
(Xobject (drawable-Xobject drawable))
(values (gc-value-alist->integer+vector gc-value-alist)))
(let ((Xgcontext (%create-gcontext (display-Xdisplay display)
Xobject
values)))
(make-gcontext Xgcontext display #t))))
;; GC is a pointer to a C structure
;; GContext is the protocol ID
(import-lambda-definition %create-gcontext (Xdisplay Xdrawable values)
"scx_Create_Gc")
;; *** GC type *******************************************************
;; *******************************************************************
(define-record-type gc :gc
(make-gc cpointer)
gc?
(cpointer gc-cpointer))
(define-exported-binding "scx-gc" :gc)
;; *** GC values and types *******************************************
(define-enumerated-type gc-function :gc-function
gc-function? gc-functions gc-function-name gc-function-index
(clear and and-reverse copy and-inverted no-op xor or nor equiv
invert or-reverse copy-inverted or-inverted nand set))
(define (integer->gc-function int)
(vector-ref gc-functions int))
(define (gc-function->integer v)
(gc-function-index v))
;; *******************************************************************
(define-exported-binding "scx-gc-function" :gc-function)
(define-exported-binding "scx-gc-functions" gc-functions)
(define-enumerated-type line-style :line-style
line-style? line-styles line-style-name line-style-index
(solid on-off-dash double-dash))
(define (integer->line-style int)
(vector-ref line-styles int))
(define (line-style->integer v)
(line-style-index v))
;; *******************************************************************
(define-exported-binding "scx-line-style" :line-style)
(define-exported-binding "scx-line-styles" line-styles)
(define-enumerated-type cap-style :cap-style
cap-style? cap-styles cap-style-name cap-style-index
(not-last butt round projecting))
(define (integer->cap-style int)
(vector-ref cap-styles int))
(define (cap-style->integer v)
(cap-style-index v))
;; *******************************************************************
(define-exported-binding "scx-cap-style" :cap-style)
(define-exported-binding "scx-cap-styles" cap-styles)
(define-enumerated-type join-style :join-style
join-style? join-styles join-style-name join-style-index
(miter round bevel))
(define (integer->join-style int)
(vector-ref join-styles int))
(define (join-style->integer v)
(join-style-index v))
;; *******************************************************************
(define-exported-binding "scx-join-style" :join-style)
(define-exported-binding "scx-join-styles" join-styles)
(define-enumerated-type fill-style :fill-style
fill-style? fill-styles fill-style-name fill-style-index
(solid tiled strippled opaque-strippled))
(define (integer->fill-style int)
(vector-ref fill-styles int))
(define-exported-binding "scx-fill-style" :fill-style)
(define-exported-binding "scx-fill-styles" fill-styles)
(define (fill-style->integer v)
(fill-style-index v))
(define-enumerated-type fill-rule :fill-rule
fill-rule? fill-rules fill-rule-name fill-rule-index
(even-odd winding))
;; *******************************************************************
(define-exported-binding "scx-fill-rule" :fill-rule)
(define-exported-binding "scx-fill-rules" fill-rules)
(define-enumerated-type subwindow-mode :subwindow-mode
subwindow-mode? subwindow-modes subwindow-mode-name subwindow-mode-index
(clip-by-children include-inferiors))
(define (integer->subwindow-mode int)
(vector-ref subwindow-modes int))
(define (subwindow-mode->integer v)
(subwindow-mode-index v))
;; *******************************************************************
(define-exported-binding "scx-subwindow-mode" :subwindow-mode)
(define-exported-binding "scx-subwindow-modes" subwindow-modes)
(define-enumerated-type arc-mode :arc-mode
arc-mode? arc-modes arc-mode-name arc-mode-index
(chord pie-slice))
(define (integer->arc-mode int)
(vector-ref arc-modes int))
(define (arc-mode->integer v)
(arc-mode-index v))
;; *******************************************************************
;; an enumerated type corresponding to XGCValues.
(define-exported-binding "scx-arc-mode" :arc-mode)
(define-exported-binding "scx-arc-modes" arc-modes)
(define-enumerated-type gc-value :gc-value
gc-value?
@ -111,7 +79,12 @@
(function plane-mask foreground background line-width line-style cap-style
join-style fill-style fill-rule tile stipple ts-x-origin ts-y-origin
font subwindow-mode graphics-exposures clip-x-origin clip-y-origin
clip-mask dash-offset dash-list arc-mode))
clip-mask dash-offset dashes arc-mode))
(define all-gc-values (vector->list gc-values))
(define-exported-binding "scx-gc-value" :gc-value)
(define-exported-binding "scx-gc-values" gc-values)
(define-syntax make-gc-value-alist
(syntax-rules
@ -126,317 +99,133 @@
gc-value-set? make-gc-value-set
gc-value gc-value? gc-values gc-value-index)
(define integer->gc-value-set
(make-integer->enum-set gc-values gc-value-index make-gc-value-set))
(define-exported-binding "scx-gc-value-set" :gc-value-set)
(define gc-value-set->integer
(make-enum-set->integer gc-value-index))
;; *** create or free graphics contexts ******************************
(define gc-value-alist->integer+vector
(make-enum-alist->integer+vector
gc-values
gc-value-index
(lambda (attr)
(cond
((eq? attr (gc-value function))
gc-function->integer)
((or (eq? attr (gc-value plane-mask))
(eq? attr (gc-value foreground))
(eq? attr (gc-value background)))
pixel-Xpixel)
((eq? attr (gc-value line-width))
(lambda (x) x))
((eq? attr (gc-value line-style))
line-style->integer)
((eq? attr (gc-value cap-style))
cap-style->integer)
((eq? attr (gc-value join-style))
join-style->integer)
((eq? attr (gc-value fill-style))
fill-style->integer)
((eq? attr (gc-value fill-rule))
fill-rule->integer)
((or (eq? attr (gc-value tile))
(eq? attr (gc-value stipple))
(eq? attr (gc-value clip-mask)))
pixmap-Xpixmap)
((or (eq? attr (gc-value ts-x-origin))
(eq? attr (gc-value ts-y-origin)))
(lambda (x) x))
((eq? attr (gc-value font))
font-Xfont)
((eq? attr (gc-value subwindow-mode))
subwindow-mode->integer)
((eq? attr (gc-value graphics-exposures))
(lambda (x) x))
((or (eq? attr (gc-value clip-x-origin))
(eq? attr (gc-value clip-y-origin)))
(lambda (x) x))
((or (eq? attr (gc-value dash-offset))
(eq? attr (gc-value dash-list)))
(lambda (x) x))
((eq? attr (gc-value arc-mode))
arc-mode->integer)))))
(import-lambda-definition create-gc (display drawable gc-value-alist)
"scx_Create_Gc")
(define (integer+vector->gc-value-alist display)
(make-integer+vector->enum-alist
gc-values gc-value-index
(lambda (v)
(cond
((eq? v (gc-value function))
integer->gc-function)
((or (eq? v (gc-value plane-mask))
(eq? v (gc-value foreground))
(eq? v (gc-value background)))
(lambda (Xpixel)
(make-pixel Xpixel #f #f)))
((eq? v (gc-value line-width))
(lambda (x) x))
((eq? v (gc-value line-style))
integer->line-style)
((eq? v (gc-value cap-style))
integer->cap-style)
((eq? v (gc-value join-style))
integer->join-style)
((eq? v (gc-value fill-style))
integer->fill-style)
((eq? v (gc-value fill-rule))
integer->fill-rule)
((or (eq? v (gc-value tile))
(eq? v (gc-value stipple))
(eq? v (gc-value clip-mask)))
(lambda (Xpixmap)
(make-pixmap Xpixmap display #f)))
((or (eq? v (gc-value ts-x-origin))
(eq? v (gc-value ts-y-origin))
(eq? v (gc-value clip-x-origin))
(eq? v (gc-value clip-y-origin)))
(lambda (x) x))
((eq? v (gc-value font))
(lambda (Xfont)
;; -> see Xlib Programming Manual 5.12
(make-font #f Xfont #f display #f)))
((eq? v (gc-value subwindow-mode))
integer->subwindow-mode)
((eq? v (gc-value graphics-exposures))
(lambda (x) x))
((or (eq? v (gc-value dash-offset))
(eq? v (gc-value dash-list)))
(lambda (x) x))
((eq? v (gc-value arc-mode))
integer->arc-mode)))))
;; copy-gcontext returns a newly create duplicate of the given
;; gcontext, and assigns it to the specified drawable. See XCopyGC.
(define (copy-gcontext gcontext drawable)
(let* ((new-gcontext (create-gcontext drawable '()))
(new-Xgcontext (gcontext-Xgcontext new-gcontext))
(Xgcontext (gcontext-Xgcontext gcontext))
(Xdisplay (display-Xdisplay (gcontext-display gcontext))))
(%copy-gcontext Xdisplay Xgcontext new-Xgcontext)
new-gcontext))
(import-lambda-definition %copy-gcontext (Xdisplay Xsource Xdest)
(import-lambda-definition copy-gc! (display srck dest mask)
"scx_Copy_Gc")
;; copy-gcontext! copies the specified attributes from gc-from to
;; gc-to. The attributes have to be a enum-set of gc-value. It can be
;; created with the function make-gc-value-set or the macro
;; gc-value-set. if no gc-value-set is specified, then all attributes
;; are ;; copied. See XCopyGC.
(define (copy-gc display drawable src)
(let ((gc (create-gc display drawable '())))
(copy-gc! display src all-gc-values gc)
gc))
(define (copy-gcontext! gc-from gc-to . maybe-gc-values)
(let ((gc-values (if (null? maybe-gc-values)
-1
(gc-value-set->integer (car maybe-gc-values)))))
(%copy-gcontext! (display-Xdisplay (gcontext-display gc-from))
(gcontext-Xgcontext gc-from)
(gcontext-Xgcontext gc-to)
gc-values)))
(import-lambda-definition %copy-gcontext! (Xdisplay Xfrom Xto attrs)
"scx_Copy_Gc_To_Gc")
;; get-gontext-values returns an alist of all attributes for the
;; specified graphic context. See the gc-value and create-gcontext
;; above. See XGetGCValues.
(define (get-gcontext-values gcontext)
(let* ((Xgcontext (gcontext-Xgcontext gcontext))
(display (gcontext-display gcontext))
(Xdisplay (display-Xdisplay display)))
(let ((vals (%get-gcontext-values Xgcontext Xdisplay)))
(if (not vals)
(error "cannot get gcontext values." gcontext)
((integer+vector->gc-value-alist display) vals)))))
(import-lambda-definition %get-gcontext-values (Xgcontext Xdisplay)
"scx_Get_Gc_Values")
(define (make-gcontext-getter name)
(lambda (gcontext)
(let ((values (get-gcontext-values gcontext)))
(and values (cdr (assq name values))))))
(define gcontext-function (make-gcontext-getter (gc-value function)))
(define gcontext-plane-mask (make-gcontext-getter (gc-value plane-mask)))
(define gcontext-foreground (make-gcontext-getter (gc-value foreground)))
(define gcontext-background (make-gcontext-getter (gc-value background)))
(define gcontext-line-width (make-gcontext-getter (gc-value line-width)))
(define gcontext-line-style (make-gcontext-getter (gc-value line-style)))
(define gcontext-cap-style (make-gcontext-getter (gc-value cap-style)))
(define gcontext-join-style (make-gcontext-getter (gc-value join-style)))
(define gcontext-fill-style (make-gcontext-getter (gc-value fill-style)))
(define gcontext-fill-rule (make-gcontext-getter (gc-value fill-rule)))
(define gcontext-arc-mode (make-gcontext-getter (gc-value arc-mode)))
(define gcontext-tile (make-gcontext-getter (gc-value tile)))
(define gcontext-stipple (make-gcontext-getter (gc-value stipple)))
(define gcontext-ts-x-origin (make-gcontext-getter (gc-value ts-x-origin)))
(define gcontext-ts-y-origin (make-gcontext-getter (gc-value ts-y-origin)))
;(define gcontext-font (make-gcontext-getter (gc-value font)))
(define gcontext-subwindow-mode
(make-gcontext-getter (gc-value subwindow-mode)))
(define gcontext-graphics-exposures
(make-gcontext-getter (gc-value graphics-exposures)))
(define gcontext-clip-x-origin (make-gcontext-getter (gc-value clip-x-origin)))
(define gcontext-clip-y-origin (make-gcontext-getter (gc-value clip-y-origin)))
(define gcontext-clip-mask (make-gcontext-getter (gc-value clip-mask)))
(define gcontext-dash-offset (make-gcontext-getter (gc-value dash-offset)))
(define gcontext-dash-list (make-gcontext-getter (gc-value dash-list)))
;; Alternative definition of gcontext-font. See XGcontextFromGC
;
(define (gcontext-font gcontext)
(let* ((display (gcontext-display gcontext))
(Xfontstruct (%gcontext-font
(display-Xdisplay display)
(gcontext-Xgcontext gcontext))))
(make-font #f #f Xfontstruct display #f)))
(import-lambda-definition %gcontext-font (Xdisplay Xgcontext)
"scx_GContext_Font") ; defined in font.c
;; change-gcontext sets some attributes of the specified graphic
;; context. The format of the arguments is like for
;; create-gcontext. See XChangeGC.
(define (change-gcontext gcontext gc-value-alist)
(%change-gcontext (gcontext-Xgcontext gcontext)
(display-Xdisplay (gcontext-display gcontext))
(gc-value-alist->integer+vector gc-value-alist)))
(import-lambda-definition %change-gcontext (Xgcontext Xdisplay args)
(import-lambda-definition change-gc (display gc values)
"scx_Change_Gc")
(define (make-gcontext-setter name)
(lambda (gcontext value)
(change-gcontext gcontext (list (cons name value)))))
(define (make-gc-setter name)
(lambda (display gc value)
(change-gc display gc (list (cons name value)))))
(define set-gcontext-function!
(make-gcontext-setter (gc-value function)))
(define set-gcontext-plane-mask!
(make-gcontext-setter (gc-value plane-mask)))
(define set-gcontext-foreground!
(make-gcontext-setter (gc-value foreground)))
(define set-gcontext-background!
(make-gcontext-setter (gc-value background)))
(define set-gcontext-line-width!
(make-gcontext-setter (gc-value line-width)))
(define set-gcontext-line-style!
(make-gcontext-setter (gc-value line-style)))
(define set-gcontext-cap-style!
(make-gcontext-setter (gc-value cap-style)))
(define set-gcontext-join-style!
(make-gcontext-setter (gc-value join-style)))
(define set-gcontext-fill-style!
(make-gcontext-setter (gc-value fill-style)))
(define set-gcontext-fill-rule!
(make-gcontext-setter (gc-value fill-rule)))
(define set-gcontext-arc-mode! (make-gcontext-setter (gc-value arc-mode)))
(define set-gcontext-tile! (make-gcontext-setter (gc-value tile)))
(define set-gcontext-stipple! (make-gcontext-setter (gc-value stipple)))
(define set-gcontext-ts-x-origin!
(make-gcontext-setter (gc-value ts-x-origin)))
(define set-gcontext-ts-y-origin!
(make-gcontext-setter (gc-value ts-y-origin)))
(define set-gcontext-font! (make-gcontext-setter (gc-value font)))
(define set-gcontext-subwindow-mode!
(make-gcontext-setter (gc-value subwindow-mode)))
(define set-gcontext-graphics-exposures!
(make-gcontext-setter (gc-value graphics-exposures)))
(define set-gcontext-clip-x-origin!
(make-gcontext-setter (gc-value clip-x-origin)))
(define set-gcontext-clip-y-origin!
(make-gcontext-setter (gc-value clip-y-origin)))
(define set-gcontext-clip-mask!
(make-gcontext-setter (gc-value clip-mask)))
(define set-gcontext-dash-offset!
(make-gcontext-setter (gc-value dash-offset)))
(define set-gcontext-dash-list!
(make-gcontext-setter (gc-value dash-list)))
(define set-gc-function! (make-gc-setter (gc-value function)))
(define set-gc-plane-mask! (make-gc-setter (gc-value plane-mask)))
(define set-gc-foreground! (make-gc-setter (gc-value foreground)))
(define set-gc-background! (make-gc-setter (gc-value background)))
(define set-gc-line-width! (make-gc-setter (gc-value line-width)))
(define set-gc-line-style! (make-gc-setter (gc-value line-style)))
(define set-gc-cap-style! (make-gc-setter (gc-value cap-style)))
(define set-gc-join-style! (make-gc-setter (gc-value join-style)))
(define set-gc-fill-style! (make-gc-setter (gc-value fill-style)))
(define set-gc-fill-rule! (make-gc-setter (gc-value fill-rule)))
(define set-gc-arc-mode! (make-gc-setter (gc-value arc-mode)))
(define set-gc-tile! (make-gc-setter (gc-value tile)))
(define set-gc-stipple! (make-gc-setter (gc-value stipple)))
(define set-gc-ts-x-origin! (make-gc-setter (gc-value ts-x-origin)))
(define set-gc-ts-y-origin! (make-gc-setter (gc-value ts-y-origin)))
(define set-gc-font! (make-gc-setter (gc-value font)))
(define set-gc-subwindow-mode! (make-gc-setter (gc-value subwindow-mode)))
(define set-gc-graphics-exposures!
(make-gc-setter (gc-value graphics-exposures)))
(define set-gc-clip-x-origin! (make-gc-setter (gc-value clip-x-origin)))
(define set-gc-clip-y-origin! (make-gc-setter (gc-value clip-y-origin)))
(define set-gc-clip-mask! (make-gc-setter (gc-value clip-mask)))
(define set-gc-dash-offset! (make-gc-setter (gc-value dash-offset)))
(define set-gc-dashes! (make-gc-setter (gc-value dashes)))
;; set-dashlist! is a more complex form of set-dashes!. (set-dashes! N) is
;; equivalent to (set-dash-list! .. #(N N))
(import-lambda-definition get-gc-values (display gc values)
"scx_Get_Gc_Values")
(define (set-gcontext-dashlist! gcontext dash-offset dash-list)
(%set-dashlist (gcontext-Xgcontext gcontext)
(display-Xdisplay (gcontext-display gcontext))
dash-offset
(list->vector dash-list)))
(define (make-gc-getter name)
(lambda (display gc)
(let ((values (get-gc-values display gc (list name))))
(and values (cdr (assq name values))))))
(import-lambda-definition %set-dashlist (Xgcontext Xdisplay dashoffset dashlist)
"scx_Set_Gcontext_Dashlist")
(define gc-gc-function (make-gc-getter (gc-value function)))
(define gc-plane-mask (make-gc-getter (gc-value plane-mask)))
(define gc-foreground (make-gc-getter (gc-value foreground)))
(define gc-background (make-gc-getter (gc-value background)))
(define gc-line-width (make-gc-getter (gc-value line-width)))
(define gc-line-style (make-gc-getter (gc-value line-style)))
(define gc-cap-style (make-gc-getter (gc-value cap-style)))
(define gc-join-style (make-gc-getter (gc-value join-style)))
(define gc-fill-style (make-gc-getter (gc-value fill-style)))
(define gc-fill-rule (make-gc-getter (gc-value fill-rule)))
(define gc-arc-mode (make-gc-getter (gc-value arc-mode)))
(define gc-tile (make-gc-getter (gc-value tile)))
(define gc-stipple (make-gc-getter (gc-value stipple)))
(define gc-ts-x-origin (make-gc-getter (gc-value ts-x-origin)))
(define gc-ts-y-origin (make-gc-getter (gc-value ts-y-origin)))
(define gc-font (make-gc-getter (gc-value font)))
(define gc-subwindow-mode (make-gc-getter (gc-value subwindow-mode)))
(define gc-graphics-exposures (make-gc-getter (gc-value graphics-exposures)))
(define gc-clip-x-origin (make-gc-getter (gc-value clip-x-origin)))
(define gc-clip-y-origin (make-gc-getter (gc-value clip-y-origin)))
(define gc-clip-mask (make-gc-getter (gc-value clip-mask)))
(define gc-dash-offset (make-gc-getter (gc-value dash-offset)))
(define gc-dashes (make-gc-getter (gc-value dashes)))
;; set-gcontext-clip-rectangles changes the clip-mask in the specified
;; graphic context to the list of rectangles and sets the clip
;; origin. Each rectangle has to be a list (x y height width). The
;; coordinates of the rectangles are interpreted relative to the clip
;; origin specified by x and y. possible values for ordering are
;; defined below. If none is specified (rectangle-ordering unsorted)
;; is used. See XSetClipRectangles.
(import-lambda-definition free-gc (display gc)
"scx_Free_Gc")
(import-lambda-definition gcontext-from-gc (gc)
"scx_GContext_From_Gc")
;; *** GC convenience routines ***************************************
(define (set-line-attributes! display gc line-width line-style cap-style
join-style)
(change-gc display gc
(make-gc-value-alist (line-width line-width)
(line-style line-style)
(cap-style cap-style)
(join-style join-style))))
(import-lambda-definition set-dashes! (display gc dashoffset dashlist)
"scx_Set_Dashes")
(define (set-clip-origin display gc x-origin y-origin)
(change-gc display gc
(make-gc-value-alist (clip-x-origin x-origin)
(clip-y-origin y-origin))))
(define-enumerated-type rectangle-ordering :rectangle-ordering
rectangle-ordering? rectangle-orderings
rectangle-ordering-name rectangle-ordering-index
(unsorted y-sorted xy-sorted xy-banded))
(define (rectangle-ordering->integer v)
(rectangle-ordering-index v))
(define-exported-binding "scx-rectangle-ordering" :rectangle-ordering)
(define-exported-binding "scx-rectangle-orderings" rectangle-orderings)
(define (set-gcontext-clip-rectangles! gcontext x y rectangles . ordering)
(%set-gcontext-clip-rectangles!
(gcontext-Xgcontext gcontext)
(display-Xdisplay (gcontext-display gcontext))
x y
(list->vector rectangles)
(rectangle-ordering->integer (if (null? ordering)
(rectangle-ordering unsorted)
(car ordering)))))
;; rectangles has to be list of (x y width height) lists.
(import-lambda-definition set-clip-rectangles!
(display gc x-origin y-origin rectangles ordering)
"scx_Set_Clip_Rectangles")
(import-lambda-definition %set-gcontext-clip-rectangles! (Xgcontext Xdisplay x
y v ord)
"scx_Set_Gcontext_Clip_Rectangles")
;; *** determine efficient sizes *************************************
;; query-best-size/-cursor/-tile/-stipple function returns the best or
;; closest size to the specified size. For 'cursor, this is the
;; largest size that can be fully displayed on the screen specified by
;; which_screen. For 'tile, this is the size that can be tiled
;; fastest. For 'stipple, this is the size that can be stippled
;; fastest. See XQueryBestSize.
(define (query-best-size display width height shape) ;; not exported
(%query-best-size (display-Xdisplay display)
width height shape))
(import-lambda-definition %query-best-size (Xdisplay width height shape)
;; returns a pair (width . height)
(import-lambda-definition %query-best-size (screen class width height)
"scx_Query_Best_Size")
(define (query-best-cursor display width height)
(query-best-size display width height 0))
(define (query-best-cursor screen width height)
(%query-best-size screen 0 width height))
(define (query-best-tile display width height)
(query-best-size display width height 1))
(define (query-best-tile screen width height)
(%query-best-size screen 1 width height))
(define (query-best-stipple display width height)
(query-best-size display width height 2))
(define (query-best-stipple screen width height)
(%query-best-size screen 2 width height))

226
scheme/xlib/grab.scm
View File

@ -1,203 +1,107 @@
; Norbert Freudemann
;; Copyright (c) 2001-2003 by Norbert Freudemann, David Frese
;; grab-pointer grabs control of a pointer for your client only.
;; It returns on of the symbols:
;; (success not-viewable already-grabbed frozen invalide-time)
;; See XGrabPointer.
(define-enumerated-type grab-status :grab-status
grab-status? grab-states grab-status-name grab-status-index
(success already-grabbed invalid-time not-viewable frozen))
(define (integer->grab-status i)
(vector-ref grab-states i))
(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)
(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-mode kbd-mode
Xconfine-to Xcursor time)
"scx_Grab_Pointer")
;; ungrab-pointer releases the pointer. See XUngrabPointer.
(define (ungrab-pointer display time)
(%ungrab-pointer (display-Xdisplay display)
time))
(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.
;; *** grab the pointer **********************************************
(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-exported-binding "scx-grab-mode" :grab-mode)
(define (interger->grab-mode i)
(vector-ref grab-modes i))
(define-enumerated-type grab-status :grab-status
grab-status? grab-states grab-status-name grab-status-index
(success already-grabbed invalid-time not-viewable frozen))
(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)
(button->integer button) ;; any-button
(state-set->integer mod)
owner?
(event-mask->integer events)
(grab-mode->integer ptr-mode)
(grab-mode->integer kbd-mode)
(window-Xwindow confine-to)
(cursor-Xcursor cursor)))
(define-exported-binding "scx-grab-states" grab-states)
(import-lambda-definition %grab-button (Xdisplay Xwindow button
mods ownerp events
ptr-mode kbd-mode
Xconfine-to Xcursor)
"scx_Grab_Button")
(import-lambda-definition grab-pointer
(display grab-window owner-events? events ptr-mode kbd-mode
confine-to cursor time)
"scx_Grab_Pointer")
;; ungrab-button releases the passive grab, performed by
;; grab-button. See XUngrabButton.
(import-lambda-definition ungrab-pointer (display time)
"scx_Ungrab_Pointer")
(define (ungrab-button window button modifiers)
(%ungrab-button (display-Xdisplay (window-display window))
(window-Xwindow window)
(button->integer button)
(state-set->integer modifiers)))
(import-lambda-definition change-active-pointer-grab
(display events cursor time)
"scx_Change_Active_Pointer_Grab")
(import-lambda-definition %ungrab-button (Xdisplay Xwindow
button modifiers)
;; *** grab pointer buttons ******************************************
(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-exported-binding "scx-state" :state)
(define-exported-binding "scx-states" states)
(define-enum-set-type state-set :state-set
state-set? make-state-set
state state? states state-index)
(define-exported-binding "scx-state-set" :state-set)
(define-enumerated-type button :button
button? buttons button-name button-index
(any-button button1 button2 button3 button4 button5))
(define-exported-binding "scx-button" :button)
(define-exported-binding "scx-buttons" buttons)
(import-lambda-definition grab-button
(display button modifiers grab-window owner-events? events ptr-mode
kbd-mode confine-to cursor)
"scx_Grab_Button")
(import-lambda-definition ungrab-button (display button modifiers grab-window)
"scx_Ungrab_Button")
;; change-active-pointer-grab changes the specified dynamic parameters
;; if the pointer is actively grabbed by the client (by grab-pointer,
;; not by grab-button). See XChangeActivePointerGrab.
;; *** grab the keyboard *********************************************
(define (change-active-pointer-grab display events cursor time)
(%change-active-p-g (display-Xdisplay display)
(event-mask->integer events)
(cursor-Xcursor cursor)
time))
(import-lambda-definition %change-active-p-g (Xdislay events
cursor time)
"scx_Change_Active_Pointer_Grab")
;; grab-keyboard actively grabs control of the keyboard and generates
;; FocusIn and FocusOut events. Further key events are reported only
;; to the grabbing client.
;; ungrab-keyboard releases the keyboard and any queued events if this
;; client has it actively grabbed from either grab-keyboard or
;; grab-Key. See XGrabKeyboard and XUngrabKeyboard.
(define (grab-keyboard window owner? ptr-mode kbd-mode time)
(integer->grab-status
(%grab-keyboard (display-Xdisplay (window-display window))
(window-Xwindow window)
owner?
(grab-mode->integer ptr-mode)
(grab-mode->integer kbd-mode)
time)))
(import-lambda-definition %grab-keyboard (Xdisplay Xwindow
owner? ptr-mode kbd-mode
time)
(import-lambda-definition grab-keyboard
(display grab-window owner-events? ptr-mode kbd-mode time)
"scx_Grab_Keyboard")
(define (ungrab-keyboard display time)
(%ungrab-keyboard (display-Xdisplay display)
time))
(import-lambda-definition %ungrab-keyboard (Xdisplay time)
(import-lambda-definition ungrab-keyboard (display time)
"scx_Ungrab_Keyboard")
;; The grab-key function establishes a passive grab on the
;; keyboard. In the future, the keyboard is actively
;; grabbed.
;; ungrab-key releases this passive grab. See XGrabKey and XUngrabKey.
(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?
(grab-mode->integer ptr-mode)
(grab-mode->integer kbd-mode)
(symbol? key)))
;; *** grab keyboard keys ********************************************
(import-lambda-definition %grab-key (Xdisplay xwindow key mod
owner ptr-mode kbd-mode flag)
(import-lambda-definition grab-key
(display keycode modifiers grab-window owner-events? ptr-mode kbd-mode)
"scx_Grab_Key")
(define (ungrab-key window key mod)
(%ungrab-key (display-Xdisplay (window-display window))
(window-Xwindow window)
key
(state-set->integer mod)
(symbol? key)))
(import-lambda-definition ungrab-key (display keycode modifiers grab-window)
"scx_Ungrab_Key")
(import-lambda-definition %ungrab-key (Xdisplay Xwindow key mod
flag)
"scx_Ungrab_Key")
;; *** release queued events *****************************************
;; allow-events function releases some queued events if the client has
;; caused a device to freeze. See XAllowEvents.
(define-enumerated-type allow-event :allow-event
allow-event? allow-events allow-event-name allow-event-index
(define-enumerated-type event-mode :event-mode
event-mode? event-modes event-mode-name event-mode-index
(async-pointer sync-pointer replay-pointer async-keyboard
sync-keyboard replay-keyboard async-both sync-both))
(define (allow-event->integer v)
(allow-event-index v))
(define-exported-binding "scx-event-mode" :event-mode)
(define (allow-events display mode time)
(%allow-events (display-Xdisplay display)
(allow-event->integer mode)
time))
(import-lambda-definition %allow-events (Xdisplay mode time)
(import-lambda-definition allow-events (display event-mode time)
"scx_Allow_Events")
;; *** grab the server ***********************************************
;; grab-server disables processing of requests and close downs on all
;; other connections than the one this request arrived on. You should
;; not grab the X server any more than is absolutely necessary. See
;; XGrabServer.
(define (grab-server display)
(%grab-server (display-Xdisplay display)))
(import-lambda-definition %grab-server (Xdisplay)
(import-lambda-definition grab-server (display)
"scx_Grab_Server")
;; ungrab-server restarts processing of requests and close downs on
;; other connections. You should avoid grabbing the X server as much
;; as possible. See XUngrabServer.
(define (ungrab-server display)
(%ungrab-server (display-Xdisplay display)))
(import-lambda-definition %ungrab-server (Xdisplay)
(import-lambda-definition ungrab-server (display)
"scx_Ungrab_Server")
;; with-server-grabbed not implemented (yet).
;;(define-syntax (with-server-grabbed display . body-forms))

349
scheme/xlib/graphics.scm
View File

@ -1,308 +1,135 @@
;; author -> Norbert Freudemann
;; creation date : 18/06/2001
;; last change : 04/07/2001
;; Copyright (c) 2001-2003 by Norbert Frese, David Frese
;; clear-area paints a rectangular area in the specified window
;; according to the specified dimensions with the window's background
;; pixel or pixmap. If width/height is zero it is replaced by the
;; window's width/height - x/y. See XClearArea.
;; *** copy areas ****************************************************
(define (clear-area window rect exposures?)
(%clear-area (window-Xwindow window)
(display-Xdisplay (window-display window))
(rect-x rect) (rect-y rect)
(rect-width rect) (rect-height rect)
exposures?))
(import-lambda-definition %clear-area (Xwindow Xdisplay x y width height
exposures?)
"scx_Clear_Area")
;; copy-area combines the specified rectangle of src with the
;; specified rectangle of dest. See XCopyArea.
(define (copy-area src-drawable gcontext src-x.y width height dst-drawable
dst-x.y)
(%copy-area (display-Xdisplay (drawable-display src-drawable))
(drawable-Xobject src-drawable)
(gcontext-Xgcontext gcontext)
(car src-x.y) (cdr src-x.y) width height
(drawable-Xobject dst-drawable)
(car dst-x.y) (cdr dst-x.y)))
(import-lambda-definition %copy-area (Xdisplay srcXdrawable Xgcontext srcx srcy
width height destXdrawable destx desty)
(import-lambda-definition copy-area
(display src dest gc src-x src-y width height dest-x dest-y)
"scx_Copy_Area")
;; copy-plane uses a single bit plane of the specified source
;; rectangle combined with the specified GC to modify the specified
;; rectangle of dest. See XCopyPlane.
(define (copy-plane src-drawable gcontext plane src-x.y width height
dst-drawable dst-x.y)
(%copy-plane (display-Xdisplay (drawable-display src-drawable))
(drawable-Xobject src-drawable)
(gcontext-Xgcontext gcontext)
plane
(car src-x.y) (cdr src-x.y) width height
(drawable-Xobject dst-drawable)
(car dst-x.y) (cdr dst-x.y)))
(import-lambda-definition %copy-plane (Xdisplay srcXdrawable Xgcontext plane
srcx srcy width height destXdrawable
destx desty)
(import-lambda-definition copy-plane
(display src dest gc src-x src-y width height dest-x dest-y plane)
"scx_Copy_Plane")
;; draw-point uses the foreground pixel and function components of the
;; GC to draw a single point into the specified drawable. A point is
;; specified as a pair (x . y). See XDrawPoint.
;; *** draw points ***************************************************
(define (draw-point drawable gcontext x.y)
(%draw-point (display-Xdisplay (drawable-display drawable))
(drawable-Xobject drawable)
(gcontext-Xgcontext gcontext)
(car x.y) (cdr x.y)))
(define-enumerated-type coord-mode :coord-mode
coord-mode? coord-modes coord-mode-name coord-mode-index
(origin previous))
(import-lambda-definition %draw-point (Xdisplay Xdrawable Xgcontext x y)
(define-exported-binding "scx-coord-mode" :coord-mode)
(import-lambda-definition draw-point (display drawable gc x y)
"scx_Draw_Point")
;; draw-points draws multiple points the same way as draw-point
;; does. The points have to be specified as a list of pairs. See
;; XDrawPoints.
;; points has to be a list of (x . y) pairs
(import-lambda-definition draw-points (display drawable gc points mode)
"scx_Draw_Points")
(define (draw-points drawable gcontext points relative?)
(%draw-point (display-Xdisplay (drawable-display drawable))
(drawable-Xobject drawable)
(gcontext-Xgcontext gcontext)
(list->vector points)
relative?))
;; *** draw lines, polygons ******************************************
(import-lambda-definition %draw-points (Xdisplay Xdrawable Xgcontext vec
relative)
"scx_Draw_Points")
;; draw-line uses the components of the specified GC to draw a line
;; between the specified set of points (x1 . y1) and (x2 . y2). See
;; XDrawLine.
(define (draw-line drawable gcontext x-y-1 x-y-2)
(%draw-line (display-Xdisplay (drawable-display drawable))
(drawable-Xobject drawable)
(gcontext-Xgcontext gcontext)
(car x-y-1) (cdr x-y-1)
(car x-y-2) (cdr x-y-2)))
(import-lambda-definition %draw-line (Xdisplay Xdrawable Xgcontext x1 y1 x2 y2)
(import-lambda-definition draw-line (display drawable gc x1 y2 x2 y2)
"scx_Draw_Line")
;; draw-lines uses the components of the specified GC to draw lines
;; between each pair of points (xi . yi) (xi+1 . yi+1) in the list
;; points. It draws the lines in the order given in the list. The
;; lines join correctly at all intermediate points, and if the first
;; and last points coincide, the first and last lines also join
;; correctly. See XDrawLines.
(define (draw-lines drawable gcontext points relative?)
(%draw-lines (display-Xdisplay (drawable-display drawable))
(drawable-Xobject drawable)
(gcontext-Xgcontext gcontext)
(list->vector points)
relative?))
(import-lambda-definition %draw-lines (Xdisplay Xdrawable Xgcontext vec rel)
;; points has to be a list of (x . y) pairs
(import-lambda-definition draw-lines (display drawable gc points mode)
"scx_Draw_Lines")
;; draw-segments function draws multiple, unconnected lines. The
;; points have to be specified as list of lists of 4 integers (x1 y1
;; x2 y2). Use points->segments to convert a list of points into a
;; list of segments. See XDraw Segements.
(import-lambda-definition draw-segments (display drawable gc segments)
"scx_Draw_Segments")
(define (draw-segments drawable gcontext points)
(%draw-segments (display-Xdisplay (drawable-display drawable))
(drawable-Xobject drawable)
(gcontext-Xgcontext gcontext)
(list->vector (map list->vector points))))
(define-record-type segment :segment
(make-segment x1 y1 x2 y2)
segment?
(x1 segment:x1 set-segment:x1!)
(y1 segment:y1 set-segment:y1!)
(x2 segment:x2 set-segment:x2!)
(y2 segment:y2 set-segment:y2!))
(import-lambda-definition %draw-segments (Xdisplay Xdrawable Xgcontext vec)
"scx_Draw_Segments")
(define-exported-binding "scx-segment" :segment)
;; draw-rectangle and draw-rectangles draw the outlines of the
;; specified rectangle or rectangles as if a five-point PolyLine
;; protocol request were specified for each rectangle. The rectangles
;; have to be specified as a list (x y width height). See
;; XDrawRectangle(s).
;; *** draw rectangles ***********************************************
(define (draw-rectangle drawable gcontext rect)
(%draw-rectangle (display-Xdisplay (drawable-display drawable))
(drawable-Xobject drawable)
(gcontext-Xgcontext gcontext)
(list->vector rect)))
(import-lambda-definition draw-rectangle
(display drawable gc x y width height)
"scx_Draw_Rectangle")
(import-lambda-definition %draw-rectangle (Xdisplay Xdrawable Xgcontext rect)
"scx_Draw_Rectangle")
(define-record-type rectangle :rectangle
(make-rectangle x y width height)
rectangle?
(x rectangle:x set-rectangle:x!)
(y rectangle:y set-rectangle:y!)
(width rectangle:width set-rectangle:width!)
(height rectangle:height set-rectangle:height!))
(define (draw-rectangles drawable gcontext rectangles)
(%draw-rectangles (display-Xdisplay (drawable-display drawable))
(drawable-Xobject drawable)
(gcontext-Xgcontext gcontext)
(list->vector (map list->vector rectangles))))
(define-exported-binding "scx-rectangle" :rectangle)
(import-lambda-definition %draw-rectangles (Xdisplay Xdrawable Xgcontext vec)
"scx_Draw_Rectangles")
(import-lambda-definition draw-rectangles (display drawable gc rectangles)
"scx_Draw_Rectangles")
;; fill-rectangle and fill-rectangles fill the rectangle(s) outlined
;; with draw-rectangle(s). See XFillRectangle(s).
;; *** draw arcs *****************************************************
(define (fill-rectangle drawable gcontext rect)
(%fill-rectangle (display-Xdisplay (drawable-display drawable))
(drawable-Xobject drawable)
(gcontext-Xgcontext gcontext)
(list->vector rect)))
(import-lambda-definition draw-arc
(display drawable gc x y width height angle1 angle2)
"scx_Draw_Arc")
(import-lambda-definition %fill-rectangle (Xdisplay Xdrawable Xgcontext rect)
"scx_Fill_Rectangle")
(define-record-type arc :arc
(make-arc x y width height angle1 angle2)
arc?
(x arc:x set-arc:x!)
(y arc:y set-arc:y!)
(width arc:width set-arc:width!)
(height arc:height set-arc:height!)
(angle1 arc:angle1 set-arc:angle1!)
(angle2 arc:angle2 set-arc:angle2!))
(define (fill-rectangles drawable gcontext rectangles)
(%fill-rectangles (display-Xdisplay (drawable-display drawable))
(drawable-Xobject drawable)
(gcontext-Xgcontext gcontext)
(list->vector (map list->vector rectangles))))
(define-exported-binding "scx-arc" :arc)
(import-lambda-definition %fill-rectangles (Xdisplay Xdrawable Xgcontext vec)
"scx_Fill_Rectangles")
;; draw-arc(s) and fill-arc(s) draws a single/multiple circular or
;; elliptical arc(s). Each arc is specified by a rectangle and two
;; angles. The center of the circle or ellipse is the center of the
;; rectangle, and the major and minor axes are specified by the width
;; and height. Positive angles indicate counterclockwise motion, and
;; negative angles indicate clockwise motion.
;; angle1 specifies the start of the arc relative to the three-o'clock
;; position from the center, in units of degrees * 64. angle2
;; specifies the path and extent of the arc relative to the start of
;; the arc, in units of degrees * 64. If the magnitude of angle2 is
;; greater than 360 degrees it is truncated to 360 degrees.
(define (draw-arc drawable gcontext rect angle1 angle2)
(%draw-arc (display-Xdisplay (drawable-display drawable))
(drawable-Xobject drawable)
(gcontext-Xgcontext gcontext)
(rect-x rect) (rect-y rect)
(rect-width rect) (rect-height rect)
angle1 angle2))
(import-lambda-definition %draw-arc (Xdisplay Xdrawable Xgcontext x y
w h a1 a2)
"scx_Draw_Arc")
(define (fill-arc drawable gcontext rect angle1 angle2)
(%fill-arc (display-Xdisplay (drawable-display drawable))
(drawable-Xobject drawable)
(gcontext-Xgcontext gcontext)
(rect-x rect) (rect-y rect)
(rect-width rect) (rect-height rect)
angle1 angle2))
(import-lambda-definition %fill-arc (Xdisplay Xdrawable Xgcontext x y
w h a1 a2)
"scx_Fill_Arc")
;; draw-arcs/fill-arcs: the arcs argument has to be a list of arcs,
;; where an arc is a list (rect angle1 angle2) - and rect a list of (x
;; y width height).
(define (draw-arcs drawable gcontext arcs)
(%draw-arcs (display-Xdisplay (drawable-display drawable))
(drawable-Xobject drawable)
(gcontext-Xgcontext gcontext)
(list->vector arcs)))
(import-lambda-definition %draw-arcs (Xdisplay Xdrawable Xgcontext vec)
(import-lambda-definition draw-arcs (display drawable gc arcs)
"scx_Draw_Arcs")
(define (fill-arcs drawable gcontext arcs)
(%fill-arcs (display-Xdisplay (drawable-display drawable))
(drawable-Xobject drawable)
(gcontext-Xgcontext gcontext)
(list->vector arcs)))
;; *** fill rectangles, polygons, or arcs ****************************
(import-lambda-definition %fill-arcs (Xdisplay Xdrawable Xgcontext vec)
"scx_Fill_Arcs")
(import-lambda-definition fill-rectangle
(display drawable gc x y width height)
"scx_Fill_Rectangle")
;; fill-polygon fills the region closed by the specified path. The
;; path is closed automatically if the last point in the list does not
;; coincide with the first point. See XFillPolygon.
(define (fill-polygon drawable gcontext points relative? shape)
(%fill-polygon (display-Xdisplay (drawable-display drawable))
(drawable-Xobject drawable)
(gcontext-Xgcontext gcontext)
(list->vector points) relative?
(polygon-shape->integer shape)))
(import-lambda-definition fill-rectangles (display drawable gc rectangles)
"scx_Fill_Rectangles")
(define-enumerated-type polygon-shape :polygon-shape
polygon-shape? polygon-shapes polygon-shape-name polygon-shape-index
(complex non-convex convex))
(define (polygon-shape->integer v)
(polygon-shape-index v))
(define-exported-binding "scx-polygon-shape" :polygon-shape)
(import-lambda-definition %fill-polygon (Xdisplay Xdrawable Xgcontext
vec relative shape)
(import-lambda-definition fill-polygon (display drawable gc points shape mode)
"scx_Fill_Polygon")
;; Now some auxiliary functions:
(import-lambda-definition fill-arc
(display drawable gc x y width height angle1 angle2)
"scx_Fill_Arc")
(define (rect x y w h)
(list x y w h))
;; arcs has to be a list of (x y width height angle1 angle2) lists.
(import-lambda-definition fill-arcs (display drawable gc arcs)
"scx_Fill_Arcs")
(define (rect? obj)
(and (list? obj) (= 4 (length obj))))
(define rect-x car)
(define rect-y cadr)
(define rect-width caddr)
(define rect-height cadddr)
(define (set-rect-x! r x) (set-car! r x))
(define (set-rect-y! r y) (set-car! (cdr r) y))
(define (set-rect-width! r width) (set-car! (cddr r) width))
(define (set-rect-height! r height) (set-car! (cdddr r) height))
;; *** auxiliary functions *******************************************
(define (bounds x1 y1 x2 y2)
(rect x1 y1 (- x2 x1) (- y2 y1)))
(make-rectangle x1 y1 (- x2 x1) (- y2 y1)))
(define (grow-rect r dw dh . maybe-centric?)
(define (grow-rectangle r dw dh . maybe-centric?)
(if (or (null? maybe-centric?) (not (car maybe-centric?)))
(rect (rect-x r) (rect-y r)
(+ (rect-width r) dw)
(+ (rect-height r) dh))
(rect (- (rect-x r) (quotient dw 2))
(- (rect-y r) (quotient dh 2))
(+ (rect-width r) dw)
(+ (rect-height r) dh))))
(make-rectangle (rectangle:x r) (rectangle:y r)
(+ (rectangle:width r) dw)
(+ (rectangle:height r) dh))
(make-rectangle (- (rectangle:x r) (quotient dw 2))
(- (rectangle:y r) (quotient dh 2))
(+ (rectangle:width r) dw)
(+ (rectangle:height r) dh))))
(define (move/resize-rect r dx dy dw dh)
(rect (+ (rect-x r) dx)
(+ (rect-y r) dy)
(+ (rect-width r) dw)
(+ (rect-height r) dh)))
;; converts '((x1 . y1) (x2 . y2) (x3 . y3) (x4 . y4)) -> '((x1 y1 x2
;; y2) (x3 y3 x4 y4))
(define (points->segments points)
(cdr (fold-right (lambda (this rest)
(if (null? (car rest))
(cons (list (car this)
(cdr this))
(cdr rest))
(cons '()
(cons (cons (car this)
(cons (cdr this)
(car rest)))
(cdr rest)))))
'(())
points)))
(define (move/resize-rectangle r dx dy dw dh)
(make-rectangle (+ (rectangle:x r) dx)
(+ (rectangle:y r) dy)
(+ (rectangle:width r) dw)
(+ (rectangle:height r) dh)))

130
scheme/xlib/key.scm
View File

@ -1,102 +1,78 @@
;; for display-min/max-keycode see XDisplayKeycodes.
;; Copyright (c) 2001-2003 by David Frese
(define (display-min-keycode display)
(%display-min-keycode (display-Xdisplay display)))
;; a keysym is a 16-bit protocol ID (see X11/keysymdef.h)
(import-lambda-definition %display-min-keycode (Xdisplay)
"scx_Display_Min_Keycode")
;; a keycode is an integer specifying a single key on the keyboard
;; (hardware depended)
(define (display-max-keycode display)
(%display-max-keycode (display-Xdisplay display)))
;; *** manipulate keyboard encoding **********************************
(import-lambda-definition %display-max-keycode (Xdisplay)
"scx_Display_Max_Keycode")
;; a keyboard mapping is a list of lists of keysyms
;; display-keysyms-per-keycode returns the number of keysyms per
;; keycode. See XGetKeyboardMapping.
(import-lambda-definition change-keyboard-mapping
(display first-keycode keysyms-lists)
"scx_Change_Keyboard_Mapping")
(define (display-keysyms-per-keycode display)
(%display-keysyms-per-keycode (display-Xdisplay display)))
;; returns keycode-count lists of keysyms
(import-lambda-definition get-keyboard-mapping
(display first-keycode keycode-count)
"scx_Get_Keyboard_Mapping")
(import-lambda-definition %display-keysyms-per-keycode (Xdisplay)
"scx_Display_Keysyms_Per_Keycode")
;; returns a pair (min-keycodes . max-keycodes)
(import-lambda-definition display-keycodes (display)
"scx_Display_Keycodes")
;; Standard KeySym names are obtained from <X11/keysymdef.h> by
;; removing the XK_ prefix from each name. But there may also be
;; implementation dependand names. See XStringToKeysym or
;; XKeysymToString.
;; a modmap is an alist mapping a modifier to a list of
;; keycodes. Valid modifiers are (state shift) (state lock) (state
;; control) (state mod1) (state mod2) (state mod3) (state mod4)
;; (state mod5)
(define (string->keysym string)
(%string->keysym (if (symbol? string)
(symbol->string string)
string)))
(import-lambda-definition set-modifier-mapping (display modmap)
"scx_Set_Modifier_Mapping")
(import-lambda-definition %string->keysym (s)
(import-lambda-definition get-modifier-mapping (display)
"scx_Get_Modifier_Mapping")
;; *** convert keysyms ***********************************************
(import-lambda-definition string->keysym (string)
"scx_String_To_Keysym")
(define (keysym->string keysym)
(%keysym->string keysym))
(import-lambda-definition %keysym->string (k)
(import-lambda-definition keysym->string (keysym)
"scx_Keysym_To_String")
;; keycode->keysym uses internal Xlib tables to return the KeySym
;; defined for the specified KeyCode. If no symbol is defined false is
;; returned. See XKeycodeToKeysym.
;; TODO include X11/keysymdef.h ??
(define (keycode->keysym display keycode index)
(%keycode->keysym (display-Xdisplay display)
keycode index))
(import-lambda-definition %keycode->keysym (Xdisplay kc i)
(import-lambda-definition keycode->keysym (display keycode index)
"scx_Keycode_To_Keysym")
;; keysym->keycode returns the defined keycode for the specified
;; keysym. If the keysym is not defined then 0 is returned. See
;; XKeysymToKeycode.
(define (keysym->keycode display keysym)
(%keysym->keycode (display-Xdisplay display)
keysym))
(import-lambda-definition %keysym->keycode (Xdisplay ks)
(import-lambda-definition keysym->keycode (display keysym)
"scx_Keysym_To_Keycode")
;; lookup-string translates a keycode and a modifier mask, as obtained
;; from a key event, to a key name (like the ones returned by
;; keysym->string). See XLookupString.
;; returns a pair (lower . upper)
(import-lambda-definition convert-case (keysym)
"scx_Convert_Case")
(define (lookup-string display keycode mask)
(%lookup-string (display-Xdisplay display)
keycode
(state-set->integer mask)))
(define (convert-to-lowercase keysym)
(car (convert-case keysym)))
(import-lambda-definition %lookup-string (Xdisplay kc m)
(define (convert-to-uppercase keysym)
(cdr (convert-case keysym)))
;; *** handle keyboard input events in Latin-1 ***********************
(import-lambda-definition lookup-keysym (key-event index)
"scx_Lookup_Keysym")
(import-lambda-definition refresh-keyboard-mapping (mapping-event)
"scx_Refresh_Keyboard_Mapping")
;; returns a pair (keysym . string)
(import-lambda-definition lookup-string/keysym (key-event)
"scx_Lookup_String")
;; rebind-keysym rebinds the meaning of a keysym/modifier pair for the
;; client. It does not redefine any key in the X server. lookup-string
;; returns this string afterwards. See XRebindKeysym.
(define (lookup-string key-event)
(cdr (lookup-string/keysym key-event)))
(define (rebind-keysym display keysym modifiers string)
(%rebind-keysym (display-Xdisplay display)
keysym
(list->vector modifiers)
string))
(import-lambda-definition %rebind-keysym (Xdisplay ks mods str)
(import-lambda-definition rebind-keysym (display keysym mod-keysyms string)
"scx_Rebind_Keysym")
;; refresh-keyboard-mapping refreshes the stored modifier and keymap
;; information. You usually call this function when a MappingNotify
;; event with a request member of MappingKeyboard or MappingModifier
;; occurs. The result is to update Xlib's knowledge of the
;; keyboard. See XRefreshKeyboardMapping.
(define (refresh-keyboard-mapping window type)
(%refresh-keyboard-mapping (display-Xdisplay (window-display window))
(window-Xwindow window)
(mapping-request->integer type)))
(import-lambda-definition %refresh-keyboard-mapping (Xdisplay Xwindow type)
"scx_Refresh_Keyboard_Mapping")

118
scheme/xlib/pixmap.scm
View File

@ -1,97 +1,53 @@
;; author -> Norbert Freudemann
;; creation date : 16/07/2001
;; last change : 16/07/2001
;; Copyright (c) 2001-2003 by Norbert Frese, David Frese
;; create a new pixmap.
;; *** create or destroy pixmaps *************************************
(define (create-pixmap drawable width height depth)
(let* ((display (drawable-display drawable))
(pixmap (%create-pixmap (display-Xdisplay display)
(drawable-Xobject drawable)
width height depth)))
(make-pixmap pixmap display #t)))
(import-lambda-definition %create-pixmap (Xdisplay Xdrawable w h depth)
(import-lambda-definition create-pixmap (display drawable width height depth)
"scx_Create_Pixmap")
;; Special pixmap values
(import-lambda-definition free-pixmap (display pixmap)
"scx_Free_Pixmap")
(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))
;; *** manipulate bitmaps ********************************************
;; 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.
(define (create-bitmap-from-data window data width height)
(let* ((display (window-display window))
(Xpixmap (%create-bitmap-from-data (display-Xdisplay display)
(window-Xwindow window)
data width height)))
(make-pixmap Xpixmap display #t)))
(import-lambda-definition %create-bitmap-from-data (Xdisplay Xdrawable data w h)
"scx_Create_Bitmap_From_Data")
;; create-pixmap-from-bitmap-data creates a pixmap of the given depth
;; and then does a bitmap-format XPutImage of the data into it. See
;; XCreatePixmapFromBitmapData.
(define (create-pixmap-from-bitmap-data window data width height
foregrnd backgrnd depth)
(let* ((display (window-display window))
(pixmap (create-pixmap-from-bitmap-data (display-Xdisplay display)
(window-Xwindow window)
data width height foregrnd
backgrnd depth)))
(make-pixmap pixmap display #t)))
(import-lambda-definition %create-pixmap-from-bitmap-data
(Xdisplay Xdrawabel data w h f b depth)
"scx_Create_Pixmap_From_Bitmap_Data")
;; read-bitmap-file reads the bitmap data from the file, creates a new
;; pixmap and returns a list of five elements (pixmap width heigth
;; x-hot y-hot). if x-hot and y-hot are not defined in the file then
;; they are set to -1,-1. See XReadBitmapFile;
(define (read-bitmap-file drawable filename)
(let ((res (%read-bitmap-file (display-Xdisplay (drawable-display drawable))
(drawable-Xobject drawable)
filename)))
(if (pair? res)
(set-car! res (make-pixmap (car res) (drawable-display drawable) #t))
(bitmap-error res filename))))
(define (bitmap-error i data)
(define (bitmap-error i data) ;; TODO exceptions ?!
(case i
((0) #t) ;; no error
((1) (error "could not open file" data))
((2) (error "invalid bitmap data in file" data))
((3) (error "not enough memory to create bitmap" data))))
(import-lambda-definition %read-bitmap-file (Xdisplay Xdrawable file)
(import-lambda-definition %read-bitmap-file (display drawable filename)
"scx_Read_Bitmap_File")
;; write-bitmap-file writes a bitmap out to a file in the X Version 11
;; format. The optional argument hotspot specifies the hotspot as a
;; pair (x-hot . y-hot) which defaults to (-1 . -1). See
;; XWriteBitmapFile.
;; returns a list (pixmap width height x-hot y-hot). May raise an error.
(define (read-bitmap-file display drawable filename)
(let ((res (%read-bitmap-file display drawable filename)))
(if (number? res)
(bitmap-error res filename)
res)))
(define (write-bitmap-file filename pixmap width height . hotspot)
(let ((dpy (display-Xdisplay (pixmap-display pixmap)))
(xy-hot (cond
((null? hotspot) (cons -1 -1))
(else (car hotspot)))))
(bitmap-error
(%write-bitmap-file dpy filename (pixmap-Xpixmap pixmap) width height
(car xy-hot) (cdr xy-hot))
filename)))
(import-lambda-definition %write-bitmap-file (Xdisplay file Xpixmap w h x y)
(import-lambda-definition %write-bitmap-file
(display filename bitmap width height x-hot y-hot)
"scx_Write_Bitmap_File")
(define (write-bitmap-file display filename bitmap width height x-hot y-hot)
(bitmap-error (%write-bitmap-file display filename bitmap width height
x-hot y-hot)
filename))
;; 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.
(import-lambda-definition create-bitmap-from-data (display drawable data w h)
"scx_Create_Bitmap_From_Data")
;; create-pixmap-from-bitmap-data creates a pixmap of the given depth
;; and then does a bitmap-format XPutImage of the data into it. See
;; XCreatePixmapFromBitmapData.
(import-lambda-definition create-pixmap-from-bitmap-data
(display drawable data width height foreground background depth)
"scx_Create_Pixmap_From_Bitmap_Data")

274
scheme/xlib/property.scm
View File

@ -1,236 +1,92 @@
;; find-atom returns an atom or #f if no atom of that name exists.
;; Copyright (c) 2001-2003 by David Frese
(define (find-atom display name)
(%find-atom (display-Xdisplay display)
(if (symbol? name)
(symbol->string name)
name)))
(define-record-type property :property
(make-property type format data)
property?
(type property:type set-property:type!) ;; an atom
(format property:format set-property:format!) ;; a property-format
;; a string if format is char, or an integer list otherwise
(data property:data set-property:data!))
(import-lambda-definition %find-atom (Xdisplay name)
"scx_Find_Atom")
(define-exported-binding "scx-property" :property)
;; atom-name returns the name of the atom as a string.
;; *** create or return atom names ***********************************
(define (atom-name display atom)
(%atom-name (display-Xdisplay display)
(atom-Xatom atom)))
(import-lambda-definition intern-atom (display atom-name only-if-exists?)
"scx_Intern_Atom")
(import-lambda-definition %atom-name (Xdisplay atom)
"scx_Atom_Name")
;; returns a list of atoms or #f
(import-lambda-definition intern-atoms (display names only-if-exists?)
"scx_Intern_Atoms")
;; list-properties return the list of atoms that exists for the
;; specified window. See XListProperties.
(import-lambda-definition get-atom-name (display atom)
"scx_Get_Atom_Name")
(define (list-properties window)
(let ((atoms (%list-properties (display-Xdisplay (window-display window))
(window-Xwindow window))))
(vector->list (vector-map! make-atom atoms))))
(define (get-atom-names display atoms)
(map (lambda (atom) (get-atom-name display atom)) atoms))
(import-lambda-definition %list-properties (Xdisplay Xwindow)
;; *** obtain and change window properties****************************
(import-lambda-definition list-properties (display window)
"scx_List_Properties")
;; get-property-extended returns a list of four elements (atom format
;; data bytes-left) on success. format is one of 8, 16 or 32. #f is
;; returned if no such property of the requested type exists.
;; request-type can be #f, which means that the property can be of any
;; type. See XGetWindowProperty for offset, length and delete?.
;; Note: This does not change the list itself.
(import-lambda-definition rotate-window-properties
(display window properties npositions)
"scx_Rotate_Window_Properties")
(define (get-property-extended window atom request-type offset length delete?)
(let ((type.format.data.bytes-left
(%get-property (window-Xwindow window)
(display-Xdisplay (window-display window))
(atom-Xatom atom)
(if request-type
(atom-Xatom request-type)
0) ;; AnyPropertyType
offset length delete?)))
(if type.format.data.bytes-left
(cons (make-atom (car type.format.data.bytes-left))
(cdr type.format.data.bytes-left))
#f)))
(import-lambda-definition delete-property (display window property)
"scx_Delete_Property")
(import-lambda-definition %get-property (Xwindow Xdisplay Xatom_prop Xatom_type
start len deletep)
"scx_Get_Property")
;; get-property is a an easier way to access a property. It uses
;; get-property-extended to read the whole property into a vector. It
;; returns a list of three elements the vector, type-atom and the
;; format.
(define (get-property window atom delete?)
(let loop ((i 5))
(let ((t.f.d.b (get-property-extended window atom #f 0 i delete?)))
(if (not t.f.d.b)
#f
(if (= (cadddr t.f.d.b) 0)
;; if no bytes left, we're done
(list (caddr t.f.d.b)
(car t.f.d.b)
(cadr t.f.d.b))
;; otherwise try to read twice as much
(loop (* i 2)))))))
;; get-string-property reads the specified property and returns the
;; data as a list of strings (0 in the data-vector are taken as
;; separators). The type of the property is ignored and the format has
;; to be 8 bit, otherwise #f is returned.
(define (get-string-property window atom delete?)
(let ((v.t.f (get-property window atom delete?)))
(if (or (not v.t.f) (not (= 8 (caddr v.t.f))))
#f
(let loop ((chars (map ascii->char (vector->list (car v.t.f))))
(str #f)
(rev-res '()))
(cond
((null? chars)
(if str
(reverse (cons str rev-res))
(reverse rev-res)))
((equal? (car chars) (ascii->char 0))
(loop (cdr chars) #f
(cons (or str "") rev-res)))
(else
(loop (cdr chars) (string-append (or str "")
(string (car chars)))
rev-res)))))))
;; get-window-property reads the specified property of type WINDOW.
(define (get-window-property window atom delete?)
(let ((dpy (window-display window))
(v.t.f (get-property window atom delete?)))
(if (or (not v.t.f) (not (eq? (intern-atom dpy "WINDOW")
(cadr v.t.f)))
(not (= 32 (caddr v.t.f))))
#f ;; error message?
(map (lambda (Xwindow)
(make-window Xwindow dpy #f))
(vector->list (car v.t.f))))))
;; change-property alters the property for the specified
;; window. property and type have to atoms, format has to be one of 8,
;; 16, 32, mode has to be a change-property-mode which defaults to
;; (change-property-mode replace) and data a vector of integers.
(define (change-property window property type format data . maybe-mode)
(%change-property (display-Xdisplay (window-display window))
(window-Xwindow window)
(atom-Xatom property)
(atom-Xatom type)
(check-format format)
(change-property-mode->integer
(if (null? maybe-mode)
(change-property-mode replace)
(car maybe-mode)))
data))
;; returns a pair (bytes-after . property) or #f
(import-lambda-definition get-window-property
(display window atom offset length delete? req-type)
"scx_Get_Window_Property")
(define-enumerated-type change-property-mode :change-property-mode
change-property-mode? change-property-modes change-property-mode-name
change-property-mode-index
(replace prepend append))
(define (change-property-mode->integer mode)
(change-property-mode-index mode))
(define-exported-binding "scx-change-property-mode" :change-property-mode)
(import-lambda-definition %change-property (Xdisplay Xwindow Xatom_prop
Xatom_type format mode data)
"scx_Change_Property")
(import-lambda-definition change-property
(display window atom mode property)
"scx_Change_Property")
(define (check-format format)
(if (not (and (number? format)
(or (= format 8) (= format 16) (= format 32))))
(error "property format has to be 8, 16 or 32" format)
format))
(define (get-full-window-property display window atom delete? req-type)
(let ((res1 (get-window-property display window atom 0 0 #f req-type)))
(and res1
(let ((res2 (get-window-property display window atom 0
(car res1) #f req-type)))
(and res2 (cdr res2))))))
;; change-string-property converts the given string or string-list
;; into a vector of 8-bit numbers (with ascii encoding) with 0
;; separating list-items and sets this value with change-property.
;; separates a string at 0 characters and returns the bits in a list.
(define (string->string-list s)
(let ((i (string-index s (ascii->char 0))))
(if i
(cons (substring s 0 i)
(string->string-list (substring s (+ i 1)
(string-length s))))
(list s))))
(define (change-string-property window property type str/str-list
. maybe-mode)
(let ((vec (list->vector (apply append
(map (lambda (s)
(append
(map char->ascii
(string->list s))
(list 0)))
(if (list? str/str-list)
str/str-list
(list str/str-list)))))))
(apply change-property window property type 8 vec maybe-mode)))
(define (string-list->string strings)
(if (null? strings)
""
(fold (lambda (res s)
(string-append res (make-string 1 (ascii->char 0))
s))
(car strings)
(cdr strings))))
;; change-window-property sets
;; *** manipulate window selection ***********************************
;; See XDeleteProperty
(import-lambda-definition set-selection-owner (display selection owner time)
"scx_Set_Selection_Owner")
(define (delete-property window property)
(%delete-property (display-Xdisplay (window-display window))
(window-Xwindow window)
(atom-Xatom property)))
(import-lambda-definition get-selection-owner (display selection)
"scx_Get_Selection_Owner")
(import-lambda-definition %delete-property (Xdisplay Xwindow Xatom_prop)
"scx_Delete_Property")
;; See XRotateProperties. delta defaults to 1
(define (rotate-properties window vector-of-atoms . maybe-delta)
(%rotate-properties (display-Xdisplay (window-display window))
(window-Xwindow window)
(vector-map! atom-Xatom vector-of-atoms)
(if (null? maybe-delta)
1
(car maybe-delta))))
(import-lambda-definition %rotate-properties (Xdisplay Xwindow Xatom_vec delta)
"scx_Rotate_Properties")
;; See XSetSelectionOwner
(define (set-selection-owner! display selection owner . maybe-time)
(%set-selection-owner! (display-Xdisplay display)
(atom-Xatom selection)
(window-Xwindow owner)
(if (null? maybe-time)
special-time:current-time
(car maybe-time))))
(import-lambda-definition %set-selection-owner! (Xdisplay Xatom_s Xwindow_owner
time)
"scx_Set_Selection_Owner")
;; See XGetSelectionOwner
(define (selection-owner display selection)
(make-window (%get-selection-owner (display-Xdisplay display)
(atom-Xatom selection))
display
#f))
(import-lambda-definition %get-selection-owner (Xdisplay Xatom_s)
"scx_Get_Selection_Owner")
;; property can be special-atom:none. See XConvertSelection
(define (convert-selection selection target property
requestor-window . maybe-time)
(%convert-selection (display-Xdisplay (window-display requestor-window))
(atom-Xatom selection)
(atom-Xatom target)
(atom-Xatom property)
(window-Xwindow requestor-window)
(if (null? maybe-time)
special-time:current-time
(car maybe-time))))
(import-lambda-definition %convert-selection (Xdisplay Xatom_s Xatom_t
Xwindow time)
(import-lambda-definition convert-selection
(display selection target property requestor time)
"scx_Convert_Selection")

31
scheme/xlib/sync-event.scm
View File

@ -12,30 +12,21 @@
(if (pred (sync-x-event-event next))
next
(next-sync-x-event next pred))))
(define (set-next-sync-x-event! sync-x-event next-sync-x-event)
(placeholder-set!
(really-next-sync-x-event sync-x-event)
next-sync-x-event))
(define (advance-most-recent-sync-x-event!)
(set! *most-recent-sync-x-event*
(placeholder-value (really-next-sync-x-event *most-recent-sync-x-event*))))
(define *most-recent-sync-x-event* (make-sync-x-event 'no-event))
(define (most-recent-sync-x-event)
*most-recent-sync-x-event*)
(define (init-sync-x-events dpy)
(spawn (lambda ()
(let lp ()
(let ((next (wait-event dpy)))
(set-next-sync-x-event! *most-recent-sync-x-event*
(make-sync-x-event next))
(advance-most-recent-sync-x-event!))
(lp)))))
(let ((most-recent-sync-x-event (make-sync-x-event 'no-event)))
(spawn (lambda ()
(let lp ()
(let ((next (wait-event dpy)))
(set-next-sync-x-event! most-recent-sync-x-event
(make-sync-x-event next))
(set! most-recent-sync-x-event
(placeholder-value (really-next-sync-x-event
most-recent-sync-x-event))))
(lp))))
(lambda () most-recent-sync-x-event)))

210
scheme/xlib/text.scm
View File

@ -1,178 +1,56 @@
;; author -> Norbert Freudemann
;; creation date : 16/07/2001
;; last change : 19/07/2001
;; Copyright (c) 2001-2003 by David Frese, Norbert Freudemann
; --- Dimension-Predicates
;; *** draw image text ***********************************************
(define (1-byte? int)
(and (< 0 int) (> 255 int)))
(import-lambda-definition draw-image-string (display drawable gc x y string)
"scx_Draw_Image_String")
(define (2-byte? int)
(and (< 0 int) (> 65535 int)))
;; string has to be a list of (byte1 . byte2) pairs, where byte1 and
;; byte2 are characters
(import-lambda-definition draw-image-string-16
(display drawable gc x y string)
"scx_Draw_Image_String_16")
; --- verify-format checks wheather the text-vec elements are between correct
; dimensions.
;; *** draw polytext text ********************************************
(define (verify-format text format)
(let ((pred (if (eq? format '1-byte)
1-byte?
2-byte?)))
(let loop ((t text))
(cond
((null? t) #f)
((pred (car t)) (loop (cdr t)))
(else (error "text doesnt' match format" text format))))))
(define-record-type text-item :text-item
(make-text-item string delta font)
text-item?
(string text-item:string)
(delta text-item:delta)
(font text-item:font))
; --- Makes a number (1 or 2) from the format-symbols '1-byte or '2-byte
(define-exported-binding "scx-text-item" :text-item)
(define (get-format-id format)
(cond ((eq? format '1-byte) 0)
((eq? format '2-byte) 1)
(else (error "Unknown format specifier" format))))
(define-syntax make-text-items
(syntax-rules
(change-font with-delta)
((make-text-items (change-font font) rest ...)
(cons (make-text-item #f 0 font)
(make-text-items rest ...)))
((make-text-items (with-delta d text) rest ...)
(cons (make-text-item text d none)
(make-text-items rest ...)))
((make-text-items text rest ...)
(cons (make-text-item text 0 none)
(make-text-items rest ...)))
((make-text-items)
'())))
; --- mixed-text->pure-text converts a list of integers, chars, symbols and
; strings into a long list of integers (= the characters)
(import-lambda-definition draw-text (display drawable gc x y items)
"scx_Draw_Text")
(define (mixed-text->pure-text list)
(if (not (list? list))
(mixed-text->pure-text (cons list '()))
(let loop ((list list)
(rev-list '()))
(if (null? list)
(reverse rev-list)
(loop (cdr list)
(let loop2 ((e (car list)))
(cond
((integer? e) (cons e rev-list))
((char? e) (cons (char->ascii e) rev-list))
((symbol? e) (loop2 (symbol->string e)))
((string? e)
(append (reverse
(mixed-text->pure-text (string->list e)))
rev-list))
(else (error "wrong element in text list" list e)))))))))
(import-lambda-definition draw-text-16 (display drawable gc x y items)
"scx_Draw_Text_16")
; --- separate-fonts converts a list of mixed types (including fonts) like this:
; (13 "abc" font 'abc) -> ((13 "abc") font ('abc)) or
; "abc" -> ("abc")
;; *** compute or query text extents *********************************
(define (separate-fonts lst)
(cond
((null? lst) lst)
;; a single text-spec
((not (list? lst)) (list lst))
;; a font-spec
((or (font? (car lst))
(pair? (car lst)))
(cons (car lst) (separate-fonts (cdr lst))))
(else (let ((r (separate-fonts (cdr lst))))
(cond
;; first element is a font-spec:
((or (null? r) (font? (car r)) (pair? (car r)))
(cons (list (car lst)) r))
;; first element is a text-spec, so add this one
(else
(cons (cons (car lst) (car r))
(cdr r))))))))
;; returns a char-struct record (the direction, font-ascent and
;; font-descent can be obtained from the font-struct directly)
(import-lambda-definition text-extents (font-struct string)
"scx_Text_Extents")
; --- text->internal-text
(define (text->internal-text text format)
(let ((t (mixed-text->pure-text text)))
(verify-format t format)
(list->vector t)))
;; text-width returns the widht of the given 1-byte or 2-byte string,
;; represented by an integer, character, string or symbol, or event a
;; list of those types. the optional argument format is one of '1-byte
;; or '2-byte, which defaults to '1-byte. See XTextWidth.
(define (text-width font text . format)
(let ((format (if (null? format) '1-byte (car format))))
(%text-width (font-Xfontstruct font)
(text->internal-text text format)
(get-format-id format))))
(import-lambda-definition %text-width (Xfontstruct text format)
"scx_Text_Width")
; --- Each extents-...-function returns a number.
(define (extents-intern id)
(lambda (font text . format)
(display "-----------------\n")
(let ((format (if (null? format) '1-byte (car format))))
(%extents-text (font-Xfontstruct font)
(text->internal-text text format)
(get-format-id format)
id))))
(define extents-lbearing (extents-intern 0))
(define extents-rbearing (extents-intern 1))
(define extents-width (extents-intern 2))
(define extents-ascent (extents-intern 3))
(define extents-descent (extents-intern 4))
(import-lambda-definition %extents-text (Xfontstruct text format which)
"scx_Extents_Text")
;; draw-image-text draws a text on the gcontext at the specified
;; position. text is an integer, character, string or symbol, or even
;; a list of these types. format is '1-byte or '2-byte. '1-byte is the
;; default value. See XDrawImageString.
(define (draw-image-text drawable gcontext x y text . format)
(let ((format (if (null? format) '1-byte (car format))))
(%draw-image-text (display-Xdisplay (drawable-display drawable))
(drawable-Xobject drawable)
(gcontext-Xgcontext gcontext)
x y
(text->internal-text text format)
(eq? format '2-byte))))
(import-lambda-definition %draw-image-text (Xdisplay Xdrawable Xgcontext
x y text format)
"scx_Draw_Image_Text")
;; draw-poly-test is a more complex function for text drawing. text
;; has the following format:
;; <text> ::= <text-spec> | ( <text-spec>+ )
;; <text-spec> ::= <integer> | <char> | <string> | <symbol> | <font>
;; | (null . <delta>) | (<font> . <delta>)
;; <delta> ::= <integer>
;; so for example a text argument of
;; (list font-1 "Hello" (cons font-2 5) "World")
;; should draw Hello in font-1 and World in font-2 with a
;; character-spacing of 5.
;; the optional format argument is one of '1-byte or '2-byte and
;; defaults to '1-byte.
(define (draw-poly-text drawable gcontext x y text . format)
(let* ((format (if (null? format) '1-byte (car format)))
(text-spec
(map (lambda (text-or-font)
(cond
((font? text-or-font)
(cons (font-Xfont text-or-font)
0))
((and (pair? text-or-font)
(not (list? text-or-font)))
(cons (if (font? (car text-or-font))
(font-Xfont (car text-or-font))
0)
(cdr text-or-font)))
(else (text->internal-text text-or-font
format))))
(separate-fonts text))))
(%draw-poly-text (display-Xdisplay (drawable-display drawable))
(drawable-Xobject drawable)
(gcontext-Xgcontext gcontext)
x y
(list->vector text-spec)
(eq? format '2-byte))))
(import-lambda-definition %draw-poly-text (Xdisplay Xdrawable Xgcontext
x y text twobyte)
"scx_Draw_Poly_Text")
;; string has to be a list of (byte1 . byte2) pairs, where byte1 and
;; byte2 are characters
(import-lambda-definition text-extents-16 (font-struct string)
"scx_Text_Extents_16")

78
scheme/xlib/utility.scm
View File

@ -1,11 +1,3 @@
; Author: Norbert Freudemann
(define (str-or-sym->str thing)
(if (symbol? thing)
(symbol->string thing)
thing))
; The C-procedures for (xlib-release-X-or-later?) are in the
; file init.c
@ -23,22 +15,14 @@
;; strings. On success a string is returned, otherwise #f. See
;; XGetDefault.
(define (get-default dpy program option)
(%get-default (display-Xdisplay dpy)
(str-or-sym->str program)
(str-or-sym->str option)))
(import-lambda-definition %get-default (Xdisplay program option)
(import-lambda-definition get-default (display program option)
"scx_Get_Default")
;; resource-manager-string returns the RESOURCE_MANAGER property from
;; the server's root window of screen 0, or #f if no such property
;; exists. See XResourceManagerString.
(define (resource-manager-string dpy)
(%resource-manager-string (display-Xdisplay dpy)))
(import-lambda-definition %resource-manager-string (Xdisplay)
(import-lambda-definition resource-manager-string (display)
"scx_Resource_Manager_String")
;; parse-geometry parses a string for the standard X format for x, y,
@ -62,49 +46,41 @@
(define fetch-bytes #f)
(define rotate-buffers #f)
(let ((xa-string (make-atom 31)) ; (31 is XA_STRING)
(xa-cut-buffers
(vector (make-atom 9) (make-atom 10) (make-atom 11)
(make-atom 12) (make-atom 13) (make-atom 14)
(make-atom 15) (make-atom 16))))
(let ((xa-string 31) ;; from Xatom.h
(xa-cut-buffers '(9 10 11 12 13 14 15 16)))
;(9...16 are XA_CUT_BUFFER0...XA_CUT_BUFFER7)
(set! store-buffer (lambda (dpy bytes buf)
(if (<= 0 buf 7)
(change-property
(display-default-root-window dpy)
(vector-ref xa-cut-buffers buf)
xa-string
8
'replace
bytes))))
(set! store-buffer
(lambda (dpy bytes buf)
(if (<= 0 buf 7)
(change-property dpy (default-root-window dpy)
(list-ref xa-cut-buffers buf)
(change-property-mode replace)
(make-property xa-string
8
bytes)))))
(set! store-bytes (lambda (dpy bytes)
(store-buffer dpy bytes 0)))
(set! fetch-buffer (lambda (dpy buf)
(if (<= 0 buf 7)
(receive
(type format data bytes-left)
(apply values
(get-property
(display-root-window dpy)
(vector-ref xa-cut-buffers buf)
xa-string
0
100000
#f))
(if (and (eq? type xa-string)
(< format 32))
data
""))
"")))
(set! fetch-buffer
(lambda (dpy buf)
(if (<= 0 buf 7)
(let ((p (get-full-window-property
dpy (default-root-window dpy)
(list-ref xa-cut-buffers buf)
#f xa-string)))
(if (and p (eq? (property:type p) xa-string)
(string? (property:data p)))
(property:data p)
"")))))
(set! fetch-bytes (lambda (dpy)
(fetch-buffer dpy 0)))
(set! rotate-buffers (lambda (dpy delta)
(rotate-properties (display-default-root-window dpy)
xa-cut-buffers delta))))
(rotate-window-properties dpy
(default-root-window dpy)
xa-cut-buffers delta))))

149
scheme/xlib/visual.scm
View File

@ -1,122 +1,51 @@
;; A visual information is an alist with keys of the type
;; visual-info. The corresponding values have the following meaning:
;; screen-number the screen this visual belongs to
;; depth the depth of the screen
;; class the visual-class (see below)
;; red-mask these masks are used for direct-color and true-color
;; green-mask to specify which bits of the pixel value specify
;; blue-mask red, green or blue values.
;; colormap-size tells how many different pixel value are valid
;; bits-per-rgb specifies how many bits in each of the red, green
;; and blue values in a colorcell are used to drive
;; the rgb gun in the screen.
;; visual this value can be passed to other functions, e.g.
;; create-window.
;; visual-id this value is not normally needed by applications.
;; Copyright (c) 2001-2003 by Norbert Freudemann, David Frese
(define-enumerated-type visual-info :visual-info
visual-info?
visual-infos
visual-info-name
visual-info-index
(visual visual-id screen depth class red-mask green-mask blue-mask
colormap-size bits-per-rgp))
(define-record-type visual :visual
(make-visual cpointer)
visual?
(cpointer visual:cpointer))
(define-syntax make-visual-info-alist
(syntax-rules
()
((make-visual-info-alist (attr arg) rest ...)
(cons (cons (visual-info attr) arg)
(make-visual-info-alist rest ...)))
((make-visual-info-alist)
'())))
(define (get-visual-info display visual-info-alist)
(let ((res (%get-visual-info (display-Xdisplay display)
(visual-info-alist->integer+vector
visual-info-alist))))
(map (lambda (p)
(cons (make-visual (car p))
(integer+vector->visual-info-alist (cdr p))))
(vector->list res))))
(import-lambda-definition %get-visual-info (Xdisplay v)
"scx_Get_Visual_Info")
;; visual-id returns the id of a given visual.
(define (visual-id visual)
(%visual-id (visual-Xvisual visual)))
(import-lambda-definition %visual-id (Xvisual)
"scx_Visual_ID")
;; match-visual-info returns a pair of a visual that matches the given
;; criteria and a visual-info-alist of it.#f is returned if no such
;; visual exists.
(define (match-visual-info display screen-number depth class)
(let ((res (%match-visual-info (display-Xdisplay display)
screen-number
depth
(visual-class->integer class))))
(if res
(cons (make-visual (car res))
(visual-info-alist->integer+vector (cdr res)))
res)))
(import-lambda-definition %match-visual-info (Xdisplay scrnum depth class)
"scx_Match_Visual_Info")
;; *******************************************************************
(define-exported-binding "scx-visual" :visual)
(define-enumerated-type visual-class :visual-class
visual-class? visual-classs visual-class-name visual-class-index
visual-class? visual-classes visual-class-name visual-class-index
(static-gray gray-scale static-color pseudo-color true-color direct-color))
(define (integer->visual-class int)
(vector-ref visual-classs int))
(define-exported-binding "scx-visual-class" :visual-class)
(define-exported-binding "scx-visual-classes" visual-classes)
(define (visual-class->integer v)
(visual-class-index v))
(define-record-type visual-info :visual-info
(make-visual-info visual visualid screen-number depth class red-mask
green-mask blue-mask colormap-size bits-per-rgb)
visual-info?
(visual visual-info:visual)
(visualid visual-info:visualid set-visual-info:visualid!)
(screen-number visual-info:screen-number set-visual-info:screen-number!)
(depth visual-info:depth set-visual-info:depth!)
(class visual-info:class set-visual-info:class!)
(red-mask visual-info:red-mask set-visual-info:red-mask!)
(green-mask visual-info:green-mask set-visual-info:green-mask!)
(blue-mask visual-info:blue-mask set-visual-info:blue-mask!)
(bits-per-rgb visual-info:bits-per-rgb set-visual-info:bits-per-rgb!)
(colormap-size visual-info:colormap-size set-visual-info:colormap-size!))
;; A visual information is an alist with keys of the type
;; visual-info. The corresponding values have the following meaning:
;; screen-number the screen this visual belongs to
;; depth the depth of the screen
;; class one of 'direct-color 'gray-scale 'pseudo-color
;; 'static-color 'static-gray 'true-color
;; red-mask these masks are used for direct-color and true-color
;; green-mask to specify which bits of the pixel value specify
;; blue-mask red, green or blue values.
;; colormap-size tells how many different pixel value are valid
;; bits-per-rgb specifies how many bits in each of the red, green
;; and blue values in a colorcell are used to drive
;; the rgb gun in the screen.
;; visual this value can be passed to other functions, e.g.
;; create-window.
;; visual-id this value is not normally needed by applications.
(define-exported-binding "scx-visual-info" :visual-info)
(define-enumerated-type visual-info :visual-info
visual-info? visual-infos visual-info-name visual-info-index
(visual-id screen depth class red-mask green-mask blue-mask
colormap-size bits-per-rgp))
(define (empty-visual-info)
(make-visual #f #f #f #f #f #f #f #f #f #f))
(define visual-info-alist->integer+vector
(make-enum-alist->integer+vector
visual-infos visual-info-index
(lambda (v)
(cond
((eq? v (visual-info class))
visual-class->integer)
(else (lambda (x) x))))))
;; *** obtain visual information *************************************
(define integer+vector->visual-info-alist
(make-integer+vector->enum-alist
visual-infos visual-info-index
(lambda (v)
(cond
((eq? v (visual-info class))
integer->visual-class)
(else (lambda (x) x))))))
;; returns a list of visual-infos that match the visual-info
;; template. #f entries in the template are ignored. Use
;; (empty-visual-info) to create a visual-info with all entries set to
;; #f.
(import-lambda-definition get-visual-infos (display template)
"scx_Get_Visual_Info")
;; returns a visual-info or #f
(import-lambda-definition match-visual-info (display screen-number depth class)
"scx_Match_Visual_Info")
(import-lambda-definition visualid-from-visual (visual)
"scx_VisualIDFromVisual")

527
scheme/xlib/window.scm
View File

@ -1,107 +1,69 @@
;; Author: David Frese
;; Copyright (c) 2001-2003 by Norbert Freudemann, David Frese
;; create-window creates an unmapped subwindow for a specified parent
;; window. depth can be 'copy-from-parent. class can be one of
;; 'input-output, 'input-only or 'copy-from-parent. visual can be
;; 'copy-from-parent too (see create-simple-window). See
;; change-window-attributes and make-set-window-attribute-alist for
;; the attributes argument.
(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 (create-window parent x y width height border-width depth class
visual set-window-attribute-alist)
(let ((attribs (set-window-attribute-alist->integer+vector
set-window-attribute-alist))
(depth (cond
((eq? depth 'copy-from-parent) #f)
((number? depth) depth)
(else (error "invalid depth" depth))))
(class (case class
((input-output) 0)
((input-only) 1)
((copy-from-parent) 2)
(else (error "invalid class specifier" class))))
(visual (cond
((eq? visual 'copy-from-parent) #f)
((visual? visual) (visual-Xvisual visual))
(else (error "invalid visual") visual)))
(display (window-display parent)))
(let ((Xwindow (%create-window
(display-Xdisplay display)
(window-Xwindow parent)
x y width height border-width
depth class visual
attribs)))
(if (= Xwindow 0)
(error "cannot create window")
(make-window Xwindow display #t)))))
(define-exported-binding "scx-bit-gravity" :bit-gravity)
(define-exported-binding "scx-bit-gravities" bit-gravities)
(import-lambda-definition %create-window
(Xdisplay Xparent x y width height border_width depth class Xvisual attribs)
(define-enumerated-type win-gravity :win-gravity
win-gravity? win-gravities win-gravity-name win-gravity-index
(unmap north-west north north-east west center east south-west
south south-east static))
(define-exported-binding "scx-win-gravity" :win-gravity)
(define-exported-binding "scx-win-gravities" win-gravities)
(define-enumerated-type backing-store :backing-store
backing-store? backing-stores backing-store-name backing-store-index
(not-useful when-mapped always))
(define-exported-binding "scx-backing-store" :backing-store)
(define-exported-binding "scx-backing-stores" backing-stores)
(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)
'())))
;; *** create windows ************************************************
(import-lambda-definition create-window
(display parent x y width height border_width depth class visual attribs)
"scx_Create_Window")
;; create-simple-window calls create-window with the default value 1
;; for border-width, 0 for x and y, and 'copy-from-parent for depth,
;; class and visual.
(import-lambda-definition create-simple-window
(display parent x y width height border_width border background)
"scx_Create_Simple_Window")
(define (create-simple-window parent width height
set-window-attribute-alist)
(create-window parent 0 0 width height 0
'copy-from-parent 'copy-from-parent 'copy-from-parent
set-window-attribute-alist))
;; *** change window attributes **************************************
;; window-exists? returns #t if the windows still exists (makes sense,
;; doesn't it :-)
;; This version is easier and faster, but causes an X Protocol error,
;; if the window does not exist.
(define (window-exists? window)
(and (integer? (window-Xwindow window)) ;; hasn't been destroyed by
;; destroy-window
(if (query-tree window) ;; query-tree returns #f if
#t #f))) ;; the window does not
;; exists.
; (define (window-exists? window)
; (let ((dpy (window-display window)))
; (letrec ((loop (lambda (w)
; (or (eq? w window)
; (any loop (window-children w))))))
; (any loop (map (lambda (i)
; (display-root-window dpy i))
; (iota (display-screen-count dpy)))))))
;; Alternative version, seems to be slower
; (define (window-exists? window)
; (let ((dpy (window-display window)))
; (let loop ((candidates (map (lambda (i)
; (display-root-window dpy i))
; (iota (display-screen-count dpy)))))
; (cond
; ((null? candidates) #f)
; ((eq? (car candidates) window) #t)
; (else (loop (append (cdr candidates)
; (window-children (car candidates)))))))))
;; *** change-window-attributes **************************************
;; change-window-attributes takes an alist of set-window-attributes
;; mapping to specific values. See XChangeWindowAttributes.
(define (change-window-attributes window set-window-attribute-alist)
(%change-window-attributes (window-Xwindow window)
(display-Xdisplay (window-display window))
(set-window-attribute-alist->integer+vector
set-window-attribute-alist)))
(import-lambda-definition %change-window-attributes (Xwindow Xdisplay attribs)
(import-lambda-definition change-window-attributes (display window attribs)
"scx_Change_Window_Attributes")
;; simple functions that use change-window-attributes
;; TODO: a caching system for multiple calls to these functions
(define (make-win-attr-setter attribute)
(lambda (window value)
(change-window-attributes window (list (cons attribute value)))))
(lambda (display window value)
(change-window-attributes display window (list (cons attribute value)))))
(define set-window-background-pixmap!
(make-win-attr-setter (set-window-attribute background-pixmap)))
@ -134,20 +96,36 @@
(define set-window-cursor!
(make-win-attr-setter (set-window-attribute cursor)))
;; *** configure-window **********************************************
;; This set the window-attributes.
;; *** configure windows *********************************************
(define (configure-window window window-change-alist)
(%configure-window (window-Xwindow window)
(display-Xdisplay (window-display window))
(window-change-alist->integer+vector
window-change-alist)))
(define-enumerated-type stack-mode :stack-mode
stack-mode? stack-modes stack-mode-name stack-mode-index
(above below top-if buttom-if opposite))
(import-lambda-definition %configure-window (Xwindow Xdisplay changes)
(define-exported-binding "scx-stack-mode" :stack-mode)
(define-exported-binding "scx-stack-modes" stack-modes)
;; 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-exported-binding "scx-window-change" :window-change)
(define-exported-binding "scx-window-changes" window-changes)
(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)
'())))
(import-lambda-definition configure-window (display window changes)
"scx_Configure_Window")
;; the following mutators are based on configure-window
(define (make-win-configurer change)
(lambda (window value)
(configure-window window (list (cons change value)))))
@ -162,233 +140,196 @@
(define set-window-stack-mode!
(make-win-configurer (window-change stack-mode)))
;; *** get-window-attributes *****************************************
;; get-window-attributes returns attributes of the specified window.
(define (move-window display window x y)
(configure-window display window
(make-window-change-alist (x x) (y y))))
(define (get-window-attributes window)
(let ((Xwindow (window-Xwindow window))
(Xdisplay (display-Xdisplay (window-display window))))
(let ((values (%get-window-attributes Xdisplay Xwindow)))
(if (not values)
#f
((integer+vector->window-attribute-alist (window-display window))
values)))))
(define (resize-window display window width height)
(configure-window display window
(make-window-change-alist (width width)
(height height))))
(import-lambda-definition %get-window-attributes (Xdisplay Xwindow)
(define (move-resize-window display window x y width height)
(configure-window display window
(make-window-change-alist (x x) (y y)
(width width)
(height height))))
;; *** get current window attribute or geometry **********************
(define-enumerated-type map-state :map-state
map-state? map-states map-state-name map-state-index
(is-unmapped is-unviewable is-viewable))
(define-exported-binding "scx-map-state" :map-state)
(define-exported-binding "scx-map-states" map-states)
(define-enumerated-type window-class :window-class
window-class? window-classes window-class-name window-class-index
(copy-from-parent input-output input-only))
(define-exported-binding "scx-window-class" :window-class)
(define-exported-binding "scx-window-classes" window-classes)
(define-record-type window-attributes :window-attributes
(make-window-attributes 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)
window-attributes?
(x window-attribute:x)
(y window-attribute:y)
(width window-attribute:width)
(height window-attribute:height)
(border-width window-attribute:border-width)
(depth window-attribute:depth)
(visual window-attribute:visual)
(root window-attribute:root)
(class window-attribute:class)
(bit-gravity window-attribute:bit-gravity)
(gravity window-attribute:gravity)
(backing-store window-attribute:backing-store)
(backing-planes window-attribute:backing-planes)
(backing-pixel window-attribute:backing-pixel)
(save-under window-attribute:save-under)
(colormap window-attribute:colormap)
(map-installed window-attribute:map-installed)
(map-state window-attribute:map-state)
(all-event-masks window-attribute:all-event-masks)
(your-event-mask window-attribute:your-event-mask)
(do-not-propagate-mask window-attribute:do-not-propagate-mask)
(override-redirect window-attribute:override-redirect)
(screen window-attribute:screen))
(import-lambda-definition get-window-attributes (display window)
"scx_Get_Window_Attributes")
(define (make-win-attr-getter attribute)
(lambda (window)
(let ((attribs (get-window-attributes window)))
(and attribs (cdr (assq attribute attribs))))))
;; returns a vector #(root-window x y width height border-width depth) or #f
(import-lambda-definition get-geometry (display drawable)
"scx_Get_Geometry")
(define window-x (make-win-attr-getter (window-attribute x)))
(define window-y (make-win-attr-getter (window-attribute y)))
(define window-width (make-win-attr-getter (window-attribute width)))
(define window-height (make-win-attr-getter (window-attribute height)))
(define window-border-width
(make-win-attr-getter (window-attribute border-width)))
(define window-depth (make-win-attr-getter (window-attribute depth)))
(define window-visual (make-win-attr-getter (window-attribute visual)))
(define window-root (make-win-attr-getter (window-attribute root)))
(define window-window-class (make-win-attr-getter (window-attribute class)))
(define window-bit-gravity
(make-win-attr-getter (window-attribute bit-gravity)))
(define window-gravity
(make-win-attr-getter (window-attribute gravity)))
(define window-backing-store
(make-win-attr-getter (window-attribute backing-store)))
(define window-backing-planes
(make-win-attr-getter (window-attribute backing-planes)))
(define window-backing-pixel
(make-win-attr-getter (window-attribute backing-pixel)))
(define window-save-under (make-win-attr-getter (window-attribute save-under)))
(define window-colormap (make-win-attr-getter (window-attribute colormap)))
(define window-map-installed
(make-win-attr-getter (window-attribute map-installed)))
(define window-map-state (make-win-attr-getter (window-attribute map-state)))
(define window-all-event-masks
(make-win-attr-getter (window-attribute all-event-masks)))
(define window-your-event-mask
(make-win-attr-getter (window-attribute your-event-mask)))
(define window-do-not-propagate-mask
(make-win-attr-getter (window-attribute do-not-propagate-mask)))
(define window-override-redirect
(make-win-attr-getter (window-attribute override-redirect)))
(define (make-geometry-getter i)
(lambda (display window)
(let ((a (get-geometry display window)))
(and a (vector-ref a i)))))
;; some functions for easier access to the attributes
;;(define window-root (make-geometry-getter 0))
(define window-x (make-geometry-getter 1))
(define window-y (make-geometry-getter 2))
(define window-width (make-geometry-getter 3))
(define window-height (make-geometry-getter 4))
(define window-border-width (make-geometry-getter 5))
(define window-depth (make-geometry-getter 6))
(define (window-mapped? window)
(not (eq? (map-state is-unmapped) (window-map-state window))))
(define (window-viewable? window)
(eq? (map-state is-viewable) (window-map-state window)))
(define (window-unviewable? window)
(eq? (map-state is-unviewable) (window-map-state window)))
;; *** map windows ***************************************************
;; The map-window function maps the window and all of its subwindows
;; that have had map requests. See XMapWindow.
(define (map-window window)
(%map-window (window-Xwindow window)
(display-Xdisplay (window-display window))))
(import-lambda-definition %map-window (Xwindow Xdisplay)
(import-lambda-definition map-window (display window)
"scx_Map_Window")
;; The unmap-window function unmaps the specified window and causes
;; the X server to generate an unmap-notify event. See XUnmapWindow.
(import-lambda-definition map-raised (display window)
"scx_Map_Raised")
(define (unmap-window window)
(%unmap-window (window-Xwindow window)
(display-Xdisplay (window-display window))))
(import-lambda-definition %unmap-window (Xwindow Xdisplay)
"scx_Unmap_Window")
;; The destroy-subwindows function destroys all inferior windows of
;; the specified window, in bottom-to-top stacking order. See
;; XDestroySubWindows.
(define (destroy-subwindows window)
(%destroy-subwindows (window-Xwindow window)
(display-Xdisplay (window-display window))))
(import-lambda-definition %destroy-subwindows (Xwindow Xdisplay)
"scx_Destroy_Subwindows")
;; The map-subwindows function maps all subwindows for a specified
;; window in top-to-bottom stacking order. See XMapSubwindows
(define (map-subwindows window)
(%map-subwindows (window-Xwindow window)
(display-Xdisplay (window-display window))))
(import-lambda-definition %map-subwindows (Xwindow Xdisplay)
(import-lambda-definition map-subwindows (display window)
"scx_Map_Subwindows")
;; The unmap-subwindows function unmaps all subwindows for each
;; subwindow and expose events on formerly obscured windows. See
;; XUnmapSubwindow.
;; *** unmap windows *************************************************
(define (unmap-subwindows window)
(%unmap-subwindows (window-Xwindow window)
(display-Xdisplay (window-display window))))
(import-lambda-definition unmap-window (display window)
"scx_Unmap_Window")
(import-lambda-definition %unmap-subwindows (Xwindow Xdisplay)
(import-lambda-definition unmap-subwindows (display window)
"scx_Unmap_Subwindows")
;; See XCirculateSubwindows.
;; *** destroy windows ***********************************************
(define (circulate-subwindows window direction)
(%destroy-subwindows (window-Xwindow window)
(display-Xdisplay (window-display window))
(eq? direction 'lower-highest)))
; other is: 'raise-lower / exception??
(import-lambda-definition destroy-window (display window)
"scx_Destroy_Window")
(import-lambda-definition %circulate-subwindows (Xwindow Xdisplay dir)
(import-lambda-definition destroy-subwindows (display window)
"scx_Destroy_Subwindows")
;; *** change window stacking order **********************************
(import-lambda-definition raise-window (display window)
"scx_Raise_Window")
(import-lambda-definition lower-window (display window)
"scx_Lower_Window")
(define-enumerated-type circulate-direction :circulate-direction
circulate-direction? circulate-directions circulate-direction-name
circulate-direction-index
(raise-lowest lower-highest))
(define-exported-binding "scx-circulate-direction" :circulate-direction)
(import-lambda-definition circulate-subwindows (display window direction)
"scx_Circulate_Subwindows")
;; The clear-window function clears the entire area in the specified
;; window. See XClearWindow.
(define (circulate-subwindows-up display window)
(circulate-subwindows display window (circulate-direction raise-lowest)))
(define (clear-window window)
(clear-area window 0 0 0 0 #f))
(define (circulate-subwindows-down display window)
(circulate-subwindows display window (circulate-direction lower-highest)))
;; The raise-window (lower-window) function raises (lowers) the
;; specified window to the top (button) of the stack so that no
;; sibling window obscures it (it does not obscure any sibling
;; windows). See XRaiseWindow.
(import-lambda-definition restack-windows (display windows)
"scx_Restack_Windows")
(define (raise-window window)
(set-window-stack-mode! window (stack-mode above)))
;; *** clear area or window ******************************************
(define (lower-window window)
(set-window-stack-mode! window (stack-mode below)))
(import-lambda-definition clear-area
(display window x y width height exposures?)
"scx_Clear_Area")
;; The restack-windows function restacks the windows in the order
;; specified, from top to bottom. The stacking order of the first
;; window in the windows list is unaffected, but the other windows in
;; the array are stacked underneath the first window, in the order of
;; the list. See XRestackWindows.
(import-lambda-definition clear-window (display window)
"scx_Clear_Window")
(define (restack-windows window-list)
(let loop ((w (car window-list))
(t (cdr window-list)))
(if (not (null? t))
(let ((n (car t)))
(set-window-sibling! n w)
(set-window-stack-mode! n 'below)
(loop n (cdr t))))))
;; *** query window tree information *********************************
;; query-tree returns a list of three elements: root window, parent
;; window and child windows of the given window. See XQueryTree.
(define (query-tree window)
(let* ((display (window-display window))
(res (%query-tree (window-Xwindow window)
(display-Xdisplay display))))
(if res
(list
(make-window (vector-ref res 0) display #f)
(make-window (vector-ref res 1) display #f)
(vector->list (vector-map! (lambda (Xwindow)
(make-window Xwindow display #f))
(vector-ref res 2))))
res)))
(import-lambda-definition %query-tree (Xwindow Xdisplay)
;; returns a list (root-window parent-window children) or #f
(import-lambda-definition query-tree (display window)
"scx_Query_Tree")
(define (window-root window)
(let ((t (query-tree window)))
(define (window-root display window)
(let ((t (query-tree display window)))
(and t (car t))))
(define (window-parent window)
(let ((t (query-tree window)))
(define (window-parent display window)
(let ((t (query-tree display window)))
(and t (cadr t))))
(define (window-children window)
(let ((t (query-tree window)))
(define (window-children display window)
(let ((t (query-tree display window)))
(and t (caddr t))))
;; translate-coordinates takes the x and y coordinates relative to the
;; source window's origin and returns a list of three elements: the x
;; and y coordinates relative to the destination window's origin. If
;; the source window and the destination window are on different
;; screens the result is #f. See XTranslateCoordinates.
;; *** translate window coordinates **********************************
(define (translate-coordinates src-window x y dst-window)
(let* ((display (window-display src-window))
(res (%translate-coordinates
(display-Xdisplay display)
(window-Xwindow src-window)
x y
(window-Xwindow dst-window))))
(if res
(begin
(vector-set! res 2 (make-window (vector-ref res 2) display #f))
(vector->list res))
#f)))
(import-lambda-definition %translate-coordinates (Xdisplay srcXwindow x y
dstXwindow)
;; returns a list (dest-x dest-y child) or #f
(import-lambda-definition translate-coordinates
(display src-w dest-w src-x src-y)
"scx_Translate_Coordinates")
;; *** get pointer coordinates ***************************************
;; query-pointer returns a list of eight elements: x and y
;; coordinates, a boolean indicating whether the pointer is on the
;; same screen as the specified window, the root window, the root
;; window's x and y coordinates, the child window and a list of
;; modifier names (see grab-button). See XQueryPointer.
(define (query-pointer window)
(let* ((display (window-display window))
(res (%query-pointer (display-Xdisplay display)
(window-Xwindow window))))
(vector-set! res 3 (make-window (vector-ref res 3) display #f))
(vector-set! res 6 (make-window (vector-ref res 6) display #f))
(vector-set! res 7 (integer->state-set (vector-ref res 7)))
(vector->list res)))
(import-lambda-definition %query-pointer (Xdisplay Xwindow)
(import-lambda-definition %query-pointer (display window)
"scx_Query_Pointer")
(define (query-pointer-root display)
(let ((q (%query-pointer display (default-root-window display))))
(and q (list (vector-ref q 0) ;; the root-window that the pointer is on
(vector-ref q 2) ;; x and
(vector-ref q 3))))) ;; y coordinates on that root-window
(define (query-pointer-state display)
(let ((q (%query-pointer display (default-root-window display))))
(and q (vector-ref q 6))))
(define (query-pointer display window)
(let ((q (%query-pointer display window)))
(and q (vector-ref q 7)
(list (vector-ref q 1) ;; child of window that contains
;; the pointer or None
(vector-ref q 4) ;; x and y coordinates
(vector-ref q 5))))) ;; relative to window

219
scheme/xlib/wm.scm
View File

@ -1,235 +1,192 @@
;; Copyright (c) 2001-2003 by Norbert Freudemann, David Frese
;; *** reparent windows **********************************************
;; If the specified window is mapped, reparent-window automatically
;; performs an UnmapWindow request on it, removes it from its current
;; position in the hierarchy, and inserts it as the child of the
;; specified parent. See XReparentWindow.
(define (reparent-window window parent-window x y)
(%reparent-window (display-Xdisplay (window-display window))
(window-Xwindow window)
(window-Xwindow parent-window)
x y))
(import-lambda-definition %reparent-window (Xdisplay Xwindow Xwindow_parent x y)
(import-lambda-definition reparent-window (display window parent x y)
"scx_Reparent_Window")
;; *** control colormaps *********************************************
;; install-colormap function installs the specified colormap for
;; its associated screen. See XInstallColormap.
(define (install-colormap colormap)
(%install-colormap (display-Xdisplay (colormap-display colormap))
(colormap-Xcolormap colormap)))
(import-lambda-definition %install-colormap (Xdisplay Xcolormap)
(import-lambda-definition install-colormap (display colormap)
"scx_Install_Colormap")
;; uninstall-colormap removes the specified colormap from the required
;; list for its screen. See XUninstallColormap.
(define (uninstall-colormap colormap)
(%uninstall-colormap (display-Xdisplay (colormap-display colormap))
(colormap-Xcolormap colormap)))
(import-lambda-definition %uninstall-colormap (Xdisplay Xcolormap)
(import-lambda-definition uninstall-colormap (display colormap)
"scx_Uninstall_Colormap")
;; list-installed-colormaps function returns a list of the currently
;; installed colormaps for the screen of the specified window. See
;; XListInstalledColormaps.
(define (list-installed-colormaps window)
(let* ((dpy (window-display window))
(ret (%list-installed-colormaps
(display-Xdisplay dpy)
(window-Xwindow window))))
(vector-map! (lambda (Xcolormap)
(make-colormap Xcolormap display #f))
ret)))
(import-lambda-definition %list-installed-colormaps (Xdisplay Xwindow)
(import-lambda-definition list-installed-colormaps (display window)
"scx_List_Installed_Colormaps")
;; *** control input focus *******************************************
;; set-input-focus function changes the input focus and the
;; last-focus-change time. See XSetInputFocus.
(define (set-input-focus display window revert-to time)
(%set-input-focus (display-Xdisplay display)
(window-Xwindow window)
(revert-to->integer revert-to)
time))
(import-lambda-definition %set-input-focus (Xdisplay Xwindow revert-to time)
(import-lambda-definition set-input-focus (display window revert-to time)
"scx_Set_Input_Focus")
(define-enumerated-type revert-to :revert-to
revert-to? revert-tos revert-to-name revert-to-index
(none pointer-root parent))
(define (integer->revert-to i)
(vector-ref revert-tos i))
(define-exported-binding "scx-revert-to" :revert-to)
(define-exported-binding "scx-revert-tos" revert-tos)
(define (revert-to->integer v)
(revert-to-index v))
;; get-input-focus returns the current focus window and the current focus
;; state (revert-to) as a pair. See XGetInputFocus.
;; input-focus returns the current focus window and the current focus
;; state as a pair. See XGetInputFocus.
(import-lambda-definition get-input-focus (display)
"scx_Get_Input_Focus")
(define (input-focus display)
(let ((ret (%input-focus (display-Xdisplay display))))
(cons (make-window (car ret) display #f)
(integer->revert-to (cdr ret)))))
(define (get-input-focus-window display)
(car (get-input-focus display)))
(import-lambda-definition %input-focus (Xdisplay)
"scx_Input_Focus")
;; *** move pointer **************************************************
;; general-warp-pointer moves the pointer in the specified way. See
;; XWarpPointer for a detailed description.
(import-lambda-definition general-warp-pointer
(display src dest src-x src-y src-width src-height
dest-x dest-y)
"scx_Warp_Pointer")
(define (general-warp-pointer display
dst-win dst-x dst-y
src-win src-x src-y src-width src-height)
(%general-warp-pointer (display-Xdisplay display)
(window-Xwindow dst-win) dst-x dst-y
(window-Xwindow src-win)
src-x src-y src-width src-height))
;; warp-pointer calls general-warp-pointer with using None as the
;; source window, and therefor moving the pointer to the destination
;; window unconditionally
(import-lambda-definition %general-warp-pointer
(Xdisplay Xdst-win dst-x dst-y
Xsrc-win src-x src-y src-width src-height)
"scx_General_Warp_Pointer")
;; 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
(special-window:none (window-display dst-window))
0 0 0 0))
(define (warp-pointer display dst-window dst-x dst-y)
(general-warp-pointer display none dst-window
0 0 0 0 dst-x dst-y))
;; 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
(special-window:none display)
(general-warp-pointer display none
x-offset y-offset
(special-window:none display)
none
0 0 0 0))
;; *** manipulate keyboard settings **********************************
;; XChangeKeyboardControl ?? TODO
;; bell rings the bell on the keyboard on the specified display, if
;; possible. The optional percent argument specifies the volume in a
;; range from -100 to 100. 0 is the default value. See XBell.
(import-lambda-definition %bell (display percent)
"scx_Bell")
(define (bell display . percent)
(%bell (display-Xdisplay display)
(%bell display
(if (null? percent)
0
(car percent))))
(import-lambda-definition %bell (Xdisplay percent)
"scx_Bell")
;; *** control host access *******************************************
;; XAddHost etc. ?? TODO
;; set-access-control either enables or disables the use of the access
;; control list at each connection setup. See XSetAccessControl.
(define (set-access-control display enable?)
(%set-access-control (display-Xdisplay display)
enable?))
(import-lambda-definition %set-access-control (Xdisplay on)
(import-lambda-definition set-access-control (display enable?)
"scx_Set_Access_Control")
;; *** change a client's save set ************************************
;; Depending on the specified mode, change-save-set either inserts or
;; deletes the specified window from the client's save-set. The
;; specified window must have been created by some other client, or a
;; BadMatch error results. mode is one of 'insert or 'delete. See
;; XChangeSaveSet.
(define (change-save-set window mode)
(%change-save-set (display-Xdisplay (window-display window))
(window-Xwindow window)
(save-set-mode->integer mode)))
(import-lambda-definition change-save-set (display window mode)
"scx_Change_Save_Set")
(define-enumerated-type save-set :save-set
save-set? save-sets save-set-name save-set-index
(insert delete))
(define (save-set-mode->integer v)
(save-set-index v))
(define-exported-binding "scx-save-set" :save-set)
(import-lambda-definition %change-save-set (Xdisplay Xwindow mode)
"scx_Change_Save_Set")
;; *** control clients ***********************************************
;; set-close-down-mode defines what will happen to the client's
;; resources at connection close. mode is one of 'destroy-all,
;; 'retain-permanent or 'retain-temporary. See XSetCloseDownMode.
(define (set-close-down-mode display mode)
(%set-close-down-mode (display-Xdisplay display)
(close-down-mode->integer mode)))
(define-enumerated-type close-down-mode :close-down-mode
close-down-mode? close-down-modes close-down-mode-name close-down-mode-index
(destroy-all retain-permanent retain-temporary))
(define (close-down-mode->integer v)
(close-down-mode-index v))
(define-exported-binding "scx-close-down-mode" :close-down-mode)
(import-lambda-definition %set-close-down-mode (Xdisplay mode)
(import-lambda-definition set-close-down-mode (display mode)
"scx_Set_Close_Down_Mode")
(import-lambda-definition kill-client (display xid)
"scx_Kill_Client")
;; *** manipulate pointer settings ***********************************
;; get-pointer-mapping returns a vector, that specifies in the i-th
;; element the logical button number for the physical button i+1. See
;; XGetPointerMapping.
(define (get-pointer-mapping display)
(%get-pointer-mapping (display-Xdisplay display)))
(import-lambda-definition %get-pointer-mapping (Xdisplay)
(import-lambda-definition get-pointer-mapping (display)
"scx_Get_Pointer_Mapping")
;; set-pointer-mapping sets the mapping of the pointer. mapping must
;; be a vector of the same length that get-pointer-mapping would
;; return. If any of the buttons to be altered are logically in the
;; down state, then #f is returned. #t otherwise. See
;; XSetPointerMapping.
;; down state, then #f is returned and the mapping is not changed, #t
;; otherwise. See XSetPointerMapping.
(define (set-pointer-mapping display mapping)
(%set-pointer-mapping (display-Xdisplay display)
mapping))
(import-lambda-definition %set-pointer-mapping (Xdisplay map)
(import-lambda-definition set-pointer-mapping (display mapping)
"scx_Set_Pointer_Mapping")
;; TODO: there is a lot more...
;; WM_STATE property
(define (get-wm-state window)
(let* ((dpy (window-display window))
(a (intern-atom dpy "WM_STATE"))
(v.t.f (get-property window a #f)))
(if (and v.t.f
(eq? (cadr v.t.f) a)
(>= (vector-length (car v.t.f)) 2))
(let ((v (car v.t.f)))
(list (integer->wm-state (vector-ref v 0))
(make-window (vector-ref v 1) dpy #f)))
#f)))
;(define (get-wm-state window)
; (let* ((dpy (window-display window))
; (a (intern-atom dpy "WM_STATE"))
; (v.t.f (get-property window a #f)))
; (if (and v.t.f
; (eq? (cadr v.t.f) a)
; (>= (vector-length (car v.t.f)) 2))
; (let ((v (car v.t.f)))
; (list (integer->wm-state (vector-ref v 0))
; (make-window (vector-ref v 1) dpy #f)))
; #f)))
(define (set-wm-state window wm-state icon-window)
(let* ((dpy (window-display window))
(a (intern-atom dpy "WM_STATE")))
(change-property window a a 32
(list->vector (list (wm-state->integer wm-state)
(window-Xwindow icon-window))))))
;(define (set-wm-state window wm-state icon-window)
; (let* ((dpy (window-display window))
; (a (intern-atom dpy "WM_STATE")))
; (change-property window a a 32
; (list->vector (list (wm-state->integer wm-state)
; (window-Xwindow icon-window))))))
(define-enumerated-type wm-state :wm-state
wm-state? wm-states wm-state-name wm-state-index
(withdrawn normal wm-state-2 iconic))
;(define-enumerated-type wm-state :wm-state
; wm-state? wm-states wm-state-name wm-state-index
; (withdrawn normal wm-state-2 iconic))
(define (integer->wm-state i)
(vector-ref wm-states i))
(define (wm-state->integer s)
(wm-state-index s))
;(define (integer->wm-state i)
; (vector-ref wm-states i))
;(define (wm-state->integer s)
; (wm-state-index s))

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

File diff suppressed because it is too large Load Diff

285
scheme/xlib/xlib-packages.scm
View File

@ -1,248 +1,51 @@
(define-structure xlib-display xlib-display-interface
(open scheme
signals ;; for error
external-calls
xlib-internal-types)
(files display))
(define-structure xlib-window xlib-window-interface
(open scheme
signals ;; for error
external-calls
receiving
list-lib ;; for iota
xlib-internal-types
xlib-helper
xlib-graphics ;; for clear-window
xlib-display ;; for root-window, screen-count
finite-types ;; for define-enumerated-type
)
(files window))
(define-structure xlib-drawable xlib-drawable-interface
(open scheme
external-calls
xlib-internal-types
xlib-window
xlib-pixmap)
(files drawable))
(define-structure xlib-color xlib-color-interface
(open scheme
signals ;; for error
external-calls
xlib-internal-types
xlib-helper)
(files color))
(define-structure xlib-colormap xlib-colormap-interface
(open scheme
external-calls
finite-types
bitwise
signals
list-lib
xlib-internal-types)
(files colormap))
(define-structure xlib-pixel xlib-pixel-interface
(open scheme
external-calls
xlib-internal-types)
(files pixel))
(define-structure xlib-gcontext xlib-gcontext-interface
(open scheme
signals ;; for error
external-calls
receiving
(define-structure enum-sets-internal ;; exists but isn't accessible in scsh
(export :enum-set-type)
(open scheme primitives
finite-types enum-sets
xlib-internal-types)
(files gcontext))
external-calls)
(begin
(define-enumerated-type test :test test? tests test-name test-index
(test1))
(define-enum-set-type test-set :test-set test-set? make-test-set
test test? tests test-index)
(define test-value (test-set test1))
(define :enum-set-type (record-ref test-value 0))
(define-exported-binding "s48-enum-set-type" :enum-set-type)))
(define-structure xlib-pixmap xlib-pixmap-interface
(open scheme
signals ;; for error
external-calls
xlib-internal-types)
(files pixmap)) ;;...
(define-structure xlib-graphics xlib-graphics-interface
(open scheme
external-calls
xlib-internal-types
list-lib ;; for fold-right
finite-types)
(files graphics))
(define-structures ((xlib-event xlib-event-interface)
(xlib-event-internal xlib-event-internal-interface))
(open scsh-level-0 ;; for port->channel
(define-structures ((xlib-internal xlib-internal-interface)
(xlib xlib-interface))
(open scsh-level-0
scheme
external-calls
threads ;; for sleep
ports locks ;; for locking the port
channel-i/o ;; for wait-for-channel
interrupts
finite-types define-record-types
xlib-internal-types)
(files event event-types))
(define-structure xlib-sync-x-events xlib-sync-x-events-interface
(open scheme
placeholders
define-record-types
threads
xlib-event)
(files sync-event))
(define-structure xlib-font xlib-font-interface
(open scheme
signals ;; for error
external-calls
xlib-internal-types
xlib-helper
bitwise ;; for bitwise-and, arithmetix-shift
)
(files font))
(define-structure xlib-text xlib-text-interface
(open scheme
signals ;; for error
external-calls
ascii ;; for char->ascii etc.
xlib-internal-types
xlib-helper)
(files text))
(define-structure xlib-property xlib-property-interface
(open scheme
ascii
finite-types
external-calls
list-lib
srfi-13 ;; strings
signals
xlib-internal-types
xlib-helper)
(files property))
(define-structure xlib-cursor xlib-cursor-interface
(open scheme
bitwise
external-calls
xlib-internal-types
xlib-helper)
(files cursor))
(define-structure xlib-wm xlib-wm-interface
(open scheme
external-calls
xlib-internal-types
signals ;; for error
xlib-property ;; get-property and change-property
define-record-types
finite-types
xlib-helper)
(files wm))
(define-structure xlib-client xlib-client-interface
(open scheme
external-calls
xlib-internal-types
xlib-display ;; for check-screen-number
xlib-window ; for window-change-alist->vector
signals ;; for error
finite-types ;; for define-enumerated-type
list-lib ;; for filter
xlib-helper)
(files client))
(define-structure xlib-key xlib-key-interface
(open scheme
external-calls
xlib-internal-types)
(files key))
(define-structure xlib-error xlib-error-interface
(open scheme
external-calls
enum-sets
enum-sets-internal ;; for the enum-set-type
placeholders
define-record-types
finite-types
xlib-internal-types)
(files error))
(define-structure xlib-extension xlib-extension-interface
(open scheme
external-calls
xlib-internal-types)
(files extension))
(define-structure xlib-utility xlib-utility-interface
(open scheme
external-calls
receiving
xlib-internal-types
xlib-display
xlib-property)
(files utility))
(define-structure xlib-grab xlib-grab-interface
(open scheme
external-calls
finite-types
xlib-internal-types)
(files grab))
(define-structure xlib-visual xlib-visual-interface
(open scheme
external-calls
finite-types ;; for enumerated types
xlib-internal-types)
(files visual))
(define-structure xlib-region xlib-region-interface
(open scheme
external-calls
xlib-internal-types)
(files region))
(define-structure xlib-types xlib-types-interface
(open scheme
finite-types
define-record-types
xlib-internal-types))
;; all together
(define-structure xlib xlib-interface
(open xlib-types
xlib-display
xlib-pixmap
xlib-window
xlib-drawable
xlib-color
xlib-colormap
xlib-pixel
xlib-gcontext
xlib-graphics
xlib-event
xlib-font
xlib-text
xlib-property
xlib-cursor
xlib-wm
xlib-client
xlib-key
xlib-error
xlib-extension
xlib-utility
xlib-grab
xlib-visual
xlib-region
xlib-sync-x-events
)
(optimize auto-integrate))
threads
ports locks
channel-i/o
interrupts
ascii)
(files display
visual
colormap
cursor
pixmap
error
event event-types sync-event
font
gcontext
grab
graphics
key
property
text
window
wm
client
utility))