Update of /cvsroot/scsh/scx/c/xlib
In directory usw-pr-cvs1:/tmp/cvs-serv26932
Added Files:
client.c color.c colormap.c cursor.c display.c error.c event.c
extension.c font.c gcontext.c grab.c graphics.c init.c key.c
objects.c pixel.c pixmap.c property.c text.c type.c util.c
window.c wm.c xlib.h
Log Message:
Unmodified C files from elk.
--- NEW FILE ---
#include "xlib.h"
static Object Sym_Wm_Hints, Sym_Size_Hints;
static Object P_Iconify_Window (w, scr) Object w, scr; {
Check_Type (w, T_Window);
if (!XIconifyWindow (WINDOW(w)->dpy, WINDOW(w)->win,
Get_Screen_Number (WINDOW(w)->dpy, scr)))
Primitive_Error ("cannot iconify window");
return Void;
}
static Object P_Withdraw_Window (w, scr) Object w, scr; {
Check_Type (w, T_Window);
if (!XWithdrawWindow (WINDOW(w)->dpy, WINDOW(w)->win,
Get_Screen_Number (WINDOW(w)->dpy, scr)))
Primitive_Error ("cannot withdraw window");
return Void;
}
static Object P_Reconfigure_Wm_Window (w, scr, conf) Object w, scr, conf; {
unsigned long mask;
Check_Type (w, T_Window);
mask = Vector_To_Record (conf, Conf_Size, Sym_Conf, Conf_Rec);
if (!XReconfigureWMWindow (WINDOW(w)->dpy, WINDOW(w)->win,
Get_Screen_Number (WINDOW(w)->dpy, scr), mask, &WC))
Primitive_Error ("cannot reconfigure window");
return Void;
}
static Object P_Wm_Command (w) Object w; {
int i, ac;
char **av;
Object s, ret, t;
GC_Node2;
Check_Type (w, T_Window);
Disable_Interrupts;
if (!XGetCommand (WINDOW(w)->dpy, WINDOW(w)->win, &av, &ac))
ac = 0;
Enable_Interrupts;
ret = t = P_Make_List (Make_Integer (ac), Null);
GC_Link2 (ret, t);
for (i = 0; i < ac; i++, t = Cdr (t)) {
s = Make_String (av[i], strlen (av[i]));
Car (t) = s;
}
GC_Unlink;
if (ac) XFreeStringList (av);
return ret;
}
static String_List_To_Text_Property (x, ret) Object x; XTextProperty *ret; {
register i, n;
register char **s;
Object t;
Alloca_Begin;
Check_List (x);
n = Fast_Length (x);
Alloca (s, char**, n * sizeof (char *));
for (i = 0; i < n; i++, x = Cdr (x)) {
t = Car (x);
Get_Strsym_Stack (t, s[i]);
}
if (!XStringListToTextProperty (s, n, ret))
Primitive_Error ("cannot create text property");
Alloca_End;
}
static Object Text_Property_To_String_List (p) XTextProperty *p; {
int n;
register i;
char **s;
Object x, ret, t;
GC_Node2;
if (!XTextPropertyToStringList (p, &s, &n))
Primitive_Error ("cannot convert from text property");
ret = t = P_Make_List (Make_Integer (n), Null);
GC_Link2 (ret, t);
for (i = 0; i < n; i++, t = Cdr (t)) {
x = Make_String (s[i], strlen (s[i]));
Car (t) = x;
}
GC_Unlink;
XFreeStringList (s);
return ret;
}
static Object P_Get_Text_Property (w, a) Object w, a; {
XTextProperty ret;
Check_Type (w, T_Window);
Check_Type (a, T_Atom);
Disable_Interrupts;
if (!XGetTextProperty (WINDOW(w)->dpy, WINDOW(w)->win, &ret,
ATOM(a)->atom)) {
Enable_Interrupts;
return False;
}
Enable_Interrupts;
return Text_Property_To_String_List (&ret);
}
static Object P_Set_Text_Property (w, prop, a) Object w, prop, a; {
XTextProperty p;
Check_Type (w, T_Window);
Check_Type (a, T_Atom);
String_List_To_Text_Property (prop, &p);
XSetTextProperty (WINDOW(w)->dpy, WINDOW(w)->win, &p, ATOM(a)->atom);
XFree ((char *)p.value);
return Void;
}
static Object P_Wm_Protocols (w) Object w; {
Atom *p;
int i, n;
Object ret;
GC_Node;
Check_Type (w, T_Window);
Disable_Interrupts;
if (!XGetWMProtocols (WINDOW(w)->dpy, WINDOW(w)->win, &p, &n))
Primitive_Error ("cannot get WM protocols");
Enable_Interrupts;
ret = Make_Vector (n, Null);
GC_Link (ret);
for (i = 0; i < n; i++) {
Object a;
a = Make_Atom (p[i]);
VECTOR(ret)->data[i] = a;
}
XFree ((char *)p);
GC_Unlink;
return ret;
}
static Object P_Set_Wm_Protocols (w, v) Object w, v; {
Atom *p;
int i, n;
Alloca_Begin;
Check_Type (w, T_Window);
Check_Type (v, T_Vector);
n = VECTOR(v)->size;
Alloca (p, Atom*, n * sizeof (Atom));
for (i = 0; i < n; i++) {
Object a;
a = VECTOR(v)->data[i];
Check_Type (a, T_Atom);
p[i] = ATOM(a)->atom;
}
if (!XSetWMProtocols (WINDOW(w)->dpy, WINDOW(w)->win, p, n))
Primitive_Error ("cannot set WM protocols");
Alloca_End;
return Void;
}
static Object P_Wm_Class (w) Object w; {
Object ret, x;
XClassHint c;
GC_Node;
Check_Type (w, T_Window);
/*
* 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.
*/
c.res_name = c.res_class = 0;
Disable_Interrupts;
(void)XGetClassHint (WINDOW(w)->dpy, WINDOW(w)->win, &c);
Enable_Interrupts;
ret = Cons (False, False);
GC_Link (ret);
if (c.res_name) {
x = Make_String (c.res_name, strlen (c.res_name));
Car (ret) = x;
XFree (c.res_name);
}
if (c.res_class) {
x = Make_String (c.res_class, strlen (c.res_class));
Cdr (ret) = x;
XFree (c.res_class);
}
GC_Unlink;
return ret;
}
static Object P_Set_Wm_Class (w, name, class) Object w, name, class; {
XClassHint c;
Check_Type (w, T_Window);
c.res_name = Get_Strsym (name);
c.res_class = Get_Strsym (class);
XSetClassHint (WINDOW(w)->dpy, WINDOW(w)->win, &c);
return Void;
}
static Object P_Set_Wm_Command (w, cmd) Object w, cmd; {
register i, n;
register char **argv;
Object c;
Alloca_Begin;
Check_Type (w, T_Window);
Check_List (cmd);
n = Fast_Length (cmd);
Alloca (argv, char**, n * sizeof (char *));
for (i = 0; i < n; i++, cmd = Cdr (cmd)) {
c = Car (cmd);
Get_Strsym_Stack (c, argv[i]);
}
XSetCommand (WINDOW(w)->dpy, WINDOW(w)->win, argv, n);
Alloca_End;
return Void;
}
static Object P_Wm_Hints (w) Object w; {
XWMHints *p;
Check_Type (w, T_Window);
Disable_Interrupts;
p = XGetWMHints (WINDOW(w)->dpy, WINDOW(w)->win);
Enable_Interrupts;
if (p) {
WMH = *p;
XFree ((char *)p);
} else {
WMH.flags = 0;
}
return Record_To_Vector (Wm_Hints_Rec, Wm_Hints_Size, Sym_Wm_Hints,
WINDOW(w)->dpy, (unsigned long)WMH.flags);
}
static Object P_Set_Wm_Hints (w, h) Object w, h; {
unsigned long mask;
Check_Type (w, T_Window);
mask = Vector_To_Record (h, Wm_Hints_Size, Sym_Wm_Hints, Wm_Hints_Rec);
WMH.flags = mask;
XSetWMHints (WINDOW(w)->dpy, WINDOW(w)->win, &WMH);
return Void;
}
static Object P_Size_Hints (w, a) Object w, a; {
long supplied;
Check_Type (w, T_Window);
Check_Type (a, T_Atom);
Disable_Interrupts;
if (!XGetWMSizeHints (WINDOW(w)->dpy, WINDOW(w)->win, &SZH, &supplied,
ATOM(a)->atom))
SZH.flags = 0;
if (!(supplied & PBaseSize))
SZH.flags &= ~PBaseSize;
if (!(supplied & PWinGravity))
SZH.flags &= ~PWinGravity;
Enable_Interrupts;
if ((SZH.flags & (PPosition|USPosition)) == (PPosition|USPosition))
SZH.flags &= ~PPosition;
if ((SZH.flags & (PSize|USSize)) == (PSize|USSize))
SZH.flags &= ~PSize;
return Record_To_Vector (Size_Hints_Rec, Size_Hints_Size, Sym_Size_Hints,
WINDOW(w)->dpy, (unsigned long)SZH.flags);
}
static Object P_Set_Size_Hints (w, a, h) Object w, a, h; {
unsigned long mask;
Check_Type (w, T_Window);
Check_Type (a, T_Atom);
bzero ((char *)&SZH, sizeof (SZH)); /* Not portable? */
mask = Vector_To_Record (h, Size_Hints_Size, Sym_Size_Hints,
Size_Hints_Rec);
if ((mask & (PPosition|USPosition)) == (PPosition|USPosition))
mask &= ~PPosition;
if ((mask & (PSize|USSize)) == (PSize|USSize))
mask &= ~PSize;
SZH.flags = mask;
XSetWMSizeHints (WINDOW(w)->dpy, WINDOW(w)->win, &SZH, ATOM(a)->atom);
return Void;
}
static Object P_Icon_Sizes (w) Object w; {
XIconSize *p;
int i, n;
Object v;
GC_Node;
Check_Type (w, T_Window);
Disable_Interrupts;
if (!XGetIconSizes (WINDOW(w)->dpy, WINDOW(w)->win, &p, &n))
n = 0;
Enable_Interrupts;
v = Make_Vector (n, Null);
GC_Link (v);
for (i = 0; i < n; i++) {
register XIconSize *q = &p[i];
Object t;
t = P_Make_List (Make_Integer (6), Null);
VECTOR(v)->data[i] = t;
Car (t) = Make_Integer (q->min_width); t = Cdr (t);
Car (t) = Make_Integer (q->min_height); t = Cdr (t);
Car (t) = Make_Integer (q->max_width); t = Cdr (t);
Car (t) = Make_Integer (q->max_height); t = Cdr (t);
Car (t) = Make_Integer (q->width_inc); t = Cdr (t);
Car (t) = Make_Integer (q->height_inc);
}
GC_Unlink;
if (n > 0)
XFree ((char *)p);
return v;
}
static Object P_Set_Icon_Sizes (w, v) Object w, v; {
register i, n;
XIconSize *p;
Alloca_Begin;
Check_Type (w, T_Window);
Check_Type (v, T_Vector);
n = VECTOR(v)->size;
Alloca (p, XIconSize*, n * sizeof (XIconSize));
for (i = 0; i < n; i++) {
register XIconSize *q = &p[i];
Object t;
t = VECTOR(v)->data[i];
Check_List (t);
if (Fast_Length (t) != 6)
Primitive_Error ("invalid argument: ~s", t);
q->min_width = Get_Integer (Car (t)); t = Cdr (t);
q->min_height = Get_Integer (Car (t)); t = Cdr (t);
q->max_width = Get_Integer (Car (t)); t = Cdr (t);
q->max_height = Get_Integer (Car (t)); t = Cdr (t);
q->width_inc = Get_Integer (Car (t)); t = Cdr (t);
q->height_inc = Get_Integer (Car (t));
}
XSetIconSizes (WINDOW(w)->dpy, WINDOW(w)->win, p, n);
Alloca_End;
return Void;
}
static Object P_Transient_For (w) Object w; {
Window win;
Disable_Interrupts;
if (!XGetTransientForHint (WINDOW(w)->dpy, WINDOW(w)->win, &win))
win = None;
Enable_Interrupts;
return Make_Window (0, WINDOW(w)->dpy, win);
}
static Object P_Set_Transient_For (w, pw) Object w, pw; {
Check_Type (w, T_Window);
XSetTransientForHint (WINDOW(w)->dpy, WINDOW(w)->win, Get_Window (pw));
return Void;
}
elk_init_xlib_client () {
Define_Symbol (&Sym_Wm_Hints, "wm-hints");
Define_Symbol (&Sym_Size_Hints, "size-hints");
Define_Primitive (P_Iconify_Window, "iconify-window", 2, 2, EVAL);
Define_Primitive (P_Withdraw_Window, "withdraw-window", 2, 2, EVAL);
Define_Primitive (P_Reconfigure_Wm_Window,
"xlib-reconfigure-wm-window", 3, 3, EVAL);
Define_Primitive (P_Wm_Command, "wm-command", 1, 1, EVAL);
Define_Primitive (P_Get_Text_Property,"get-text-property", 2, 2, EVAL);
Define_Primitive (P_Set_Text_Property,"set-text-property!",3, 3, EVAL);
Define_Primitive (P_Wm_Protocols, "wm-protocols", 1, 1, EVAL);
Define_Primitive (P_Set_Wm_Protocols, "set-wm-protocols!", 2, 2, EVAL);
Define_Primitive (P_Wm_Class, "wm-class", 1, 1, EVAL);
Define_Primitive (P_Set_Wm_Class, "set-wm-class!", 3, 3, EVAL);
Define_Primitive (P_Set_Wm_Command, "set-wm-command!", 2, 2, EVAL);
Define_Primitive (P_Wm_Hints, "xlib-wm-hints", 1, 1, EVAL);
Define_Primitive (P_Set_Wm_Hints, "xlib-set-wm-hints!",2, 2, EVAL);
Define_Primitive (P_Size_Hints, "xlib-wm-size-hints",2, 2, EVAL);
Define_Primitive (P_Set_Size_Hints,
"xlib-set-wm-size-hints!", 3, 3, EVAL);
Define_Primitive (P_Icon_Sizes, "icon-sizes", 1, 1, EVAL);
Define_Primitive (P_Set_Icon_Sizes, "set-icon-sizes!", 2, 2, EVAL);
Define_Primitive (P_Transient_For, "transient-for", 1, 1, EVAL);
Define_Primitive (P_Set_Transient_For,"set-transient-for!",2, 2, EVAL);
}
--- NEW FILE ---
#include "xlib.h"
Generic_Predicate (Color)
static Color_Equal (x, y) Object x, y; {
register XColor *p = &COLOR(x)->c, *q = &COLOR(y)->c;
return p->red == q->red && p->green == q->green && p->blue == q->blue;
}
Generic_Print (Color, "#[color %lu]", POINTER(x))
Object Make_Color (r, g, b) unsigned int r, g, b; {
Object c;
c = Find_Object (T_Color, (GENERIC)0, Match_X_Obj, r, g, b);
if (Nullp (c)) {
c = Alloc_Object (sizeof (struct S_Color), T_Color, 0);
COLOR(c)->tag = Null;
COLOR(c)->c.red = r;
COLOR(c)->c.green = g;
COLOR(c)->c.blue = b;
Register_Object (c, (GENERIC)0, (PFO)0, 0);
}
return c;
}
XColor *Get_Color (c) Object c; {
Check_Type (c, T_Color);
return &COLOR(c)->c;
}
static unsigned short Get_RGB_Value (x) Object x; {
double d;
d = Get_Double (x);
if (d < 0.0 || d > 1.0)
Primitive_Error ("bad RGB value: ~s", x);
return (unsigned short)(d * 65535);
}
static Object P_Make_Color (r, g, b) Object r, g, b; {
return Make_Color (Get_RGB_Value (r), Get_RGB_Value (g), Get_RGB_Value (b));
}
static Object P_Color_Rgb_Values (c) Object c; {
Object ret, t, x;
GC_Node3;
Check_Type (c, T_Color);
ret = t = Null;
GC_Link3 (c, ret, t);
t = ret = P_Make_List (Make_Integer (3), Null);
GC_Unlink;
x = Make_Reduced_Flonum ((double)COLOR(c)->c.red / 65535.0);
Car (t) = x; t = Cdr (t);
x = Make_Reduced_Flonum ((double)COLOR(c)->c.green / 65535.0);
Car (t) = x; t = Cdr (t);
x = Make_Reduced_Flonum ((double)COLOR(c)->c.blue / 65535.0);
Car (t) = x;
return ret;
}
static Object P_Query_Color (cmap, p) Object cmap, p; {
XColor c;
Colormap cm = Get_Colormap (cmap);
c.pixel = Get_Pixel (p);
Disable_Interrupts;
XQueryColor (COLORMAP(cmap)->dpy, cm, &c);
Enable_Interrupts;
return Make_Color (c.red, c.green, c.blue);
}
static Object P_Query_Colors (cmap, v) Object cmap, v; {
Colormap cm = Get_Colormap (cmap);
register i, n;
Object ret;
register XColor *p;
GC_Node;
Alloca_Begin;
Check_Type (v, T_Vector);
n = VECTOR(v)->size;
Alloca (p, XColor*, n * sizeof (XColor));
for (i = 0; i < n; i++)
p[i].pixel = Get_Pixel (VECTOR(v)->data[i]);
Disable_Interrupts;
XQueryColors (COLORMAP(cmap)->dpy, cm, p, n);
Enable_Interrupts;
ret = Make_Vector (n, Null);
GC_Link (ret);
for (i = 0; i < n; i++, p++) {
Object x;
x = Make_Color (p->red, p->green, p->blue);
VECTOR(ret)->data[i] = x;
}
GC_Unlink;
Alloca_End;
return ret;
}
static Object P_Lookup_Color (cmap, name) Object cmap, name; {
XColor visual, exact;
Colormap cm = Get_Colormap (cmap);
Object ret, x;
GC_Node;
if (!XLookupColor (COLORMAP(cmap)->dpy, cm, Get_Strsym (name),
&visual, &exact))
Primitive_Error ("no such color: ~s", name);
ret = Cons (Null, Null);
GC_Link (ret);
x = Make_Color (visual.red, visual.green, visual.blue);
Car (ret) = x;
x = Make_Color (exact.red, exact.green, exact.blue);
Cdr (ret) = x;
GC_Unlink;
return ret;
}
elk_init_xlib_color () {
Generic_Define (Color, "color", "color?");
Define_Primitive (P_Make_Color, "make-color", 3, 3, EVAL);
Define_Primitive (P_Color_Rgb_Values, "color-rgb-values", 1, 1, EVAL);
Define_Primitive (P_Query_Color, "query-color", 2, 2, EVAL);
Define_Primitive (P_Query_Colors, "query-colors", 2, 2, EVAL);
Define_Primitive (P_Lookup_Color, "lookup-color", 2, 2, EVAL);
}
--- NEW FILE ---
#include "xlib.h"
Generic_Predicate (Colormap)
Generic_Equal_Dpy (Colormap, COLORMAP, cm)
Generic_Print (Colormap, "#[colormap %lu]", COLORMAP(x)->cm)
Generic_Get_Display (Colormap, COLORMAP)
Object Make_Colormap (finalize, dpy, cmap) Display *dpy; Colormap cmap; {
Object cm;
if (cmap == None)
return Sym_None;
cm = Find_Object (T_Colormap, (GENERIC)dpy, Match_X_Obj, cmap);
if (Nullp (cm)) {
cm = Alloc_Object (sizeof (struct S_Colormap), T_Colormap, 0);
COLORMAP(cm)->tag = Null;
COLORMAP(cm)->cm = cmap;
COLORMAP(cm)->dpy = dpy;
COLORMAP(cm)->free = 0;
Register_Object (cm, (GENERIC)dpy, finalize ? P_Free_Colormap :
(PFO)0, 0);
}
return cm;
}
Colormap Get_Colormap (c) Object c; {
Check_Type (c, T_Colormap);
return COLORMAP(c)->cm;
}
Object P_Free_Colormap (c) Object c; {
Check_Type (c, T_Colormap);
if (!COLORMAP(c)->free)
XFreeColormap (COLORMAP(c)->dpy, COLORMAP(c)->cm);
Deregister_Object (c);
COLORMAP(c)->free = 1;
return Void;
}
static Object P_Alloc_Color (cmap, color) Object cmap, color; {
XColor c;
Colormap cm = Get_Colormap (cmap);
int r;
c = *Get_Color (color);
Disable_Interrupts;
r = XAllocColor (COLORMAP(cmap)->dpy, cm, &c);
Enable_Interrupts;
if (!r)
return False;
return Make_Pixel (c.pixel);
}
static Object P_Alloc_Named_Color (cmap, name) Object cmap, name; {
Colormap cm = Get_Colormap (cmap);
XColor screen, exact;
int r;
Object ret, t, x;
GC_Node2;
Disable_Interrupts;
r = XAllocNamedColor (COLORMAP(cmap)->dpy, cm, Get_Strsym (name),
&screen, &exact);
Enable_Interrupts;
if (!r)
return False;
t = ret = P_Make_List (Make_Integer (3), Null);
GC_Link2 (t, ret);
x = Make_Pixel (screen.pixel);
Car (t) = x; t = Cdr (t);
x = Make_Color (screen.red, screen.green, screen.blue);
Car (t) = x; t = Cdr (t);
x = Make_Color (exact.red, exact.green, exact.blue);
Car (t) = x;
GC_Unlink;
return ret;
}
elk_init_xlib_colormap () {
Generic_Define (Colormap, "colormap", "colormap?");
Define_Primitive (P_Colormap_Display, "colormap-display", 1, 1, EVAL);
Define_Primitive (P_Free_Colormap, "free-colormap", 1, 1, EVAL);
Define_Primitive (P_Alloc_Color, "alloc-color", 2, 2, EVAL);
Define_Primitive (P_Alloc_Named_Color,"alloc-named-color",2, 2, EVAL);
}
--- NEW FILE ---
#include "xlib.h"
Generic_Predicate (Cursor)
Generic_Equal_Dpy (Cursor, CURSOR, cursor)
Generic_Print (Cursor, "#[cursor %lu]", CURSOR(x)->cursor)
Generic_Get_Display (Cursor, CURSOR)
static Object Internal_Make_Cursor (finalize, dpy, cursor)
Display *dpy; Cursor cursor; {
Object c;
if (cursor == None)
return Sym_None;
c = Find_Object (T_Cursor, (GENERIC)dpy, Match_X_Obj, cursor);
if (Nullp (c)) {
c = Alloc_Object (sizeof (struct S_Cursor), T_Cursor, 0);
CURSOR(c)->tag = Null;
CURSOR(c)->cursor = cursor;
CURSOR(c)->dpy = dpy;
CURSOR(c)->free = 0;
Register_Object (c, (GENERIC)dpy,
finalize ? P_Free_Cursor : (PFO)0, 0);
}
return c;
}
/* Backwards compatibility: */
Object Make_Cursor (dpy, cursor) Display *dpy; Cursor cursor; {
return Internal_Make_Cursor (1, dpy, cursor);
}
Object Make_Cursor_Foreign (dpy, cursor) Display *dpy; Cursor cursor; {
return Internal_Make_Cursor (0, dpy, cursor);
}
Cursor Get_Cursor (c) Object c; {
if (EQ(c, Sym_None))
return None;
Check_Type (c, T_Cursor);
return CURSOR(c)->cursor;
}
Object P_Free_Cursor (c) Object c; {
Check_Type (c, T_Cursor);
if (!CURSOR(c)->free)
XFreeCursor (CURSOR(c)->dpy, CURSOR(c)->cursor);
Deregister_Object (c);
CURSOR(c)->free = 1;
return Void;
}
static Object P_Create_Cursor (srcp, maskp, x, y, f, b)
Object srcp, maskp, x, y, f, b; {
Pixmap sp = Get_Pixmap (srcp), mp;
Display *d = PIXMAP(srcp)->dpy;
mp = EQ(maskp, Sym_None) ? None : Get_Pixmap (maskp);
return Make_Cursor (d, XCreatePixmapCursor (d, sp, mp,
Get_Color (f), Get_Color (b), Get_Integer (x), Get_Integer (y)));
}
static Object P_Create_Glyph_Cursor (srcf, srcc, maskf, maskc, f, b)
Object srcf, srcc, maskf, maskc, f, b; {
Font sf = Get_Font (srcf), mf;
Display *d = FONT(srcf)->dpy;
mf = EQ(maskf, Sym_None) ? None : Get_Font (maskf);
return Make_Cursor (d, XCreateGlyphCursor (d, sf, mf,
Get_Integer (srcc), mf == None ? 0 : Get_Integer (maskc),
Get_Color (f), Get_Color (b)));
}
static Object P_Recolor_Cursor (c, f, b) Object c, f, b; {
Check_Type (c, T_Cursor);
XRecolorCursor (CURSOR(c)->dpy, CURSOR(c)->cursor, Get_Color (f),
Get_Color (b));
return Void;
}
elk_init_xlib_cursor () {
Generic_Define (Cursor, "cursor", "cursor?");
Define_Primitive (P_Cursor_Display, "cursor-display", 1, 1, EVAL);
Define_Primitive (P_Free_Cursor, "free-cursor", 1, 1, EVAL);
Define_Primitive (P_Create_Cursor, "create-cursor", 6, 6, EVAL);
Define_Primitive (P_Create_Glyph_Cursor, "create-glyph-cursor",
6, 6, EVAL);
Define_Primitive (P_Recolor_Cursor, "recolor-cursor", 3, 3, EVAL);
}
--- NEW FILE ---
#include "xlib.h"
static Display_Visit (dp, f) Object *dp; int (*f)(); {
(*f)(&DISPLAY(*dp)->after);
}
Generic_Predicate (Display)
Generic_Equal (Display, DISPLAY, dpy)
static Display_Print (d, port, raw, depth, length) Object d, port; {
Printf (port, "#[display %lu %s]", (unsigned)DISPLAY(d)->dpy,
DisplayString (DISPLAY(d)->dpy));
}
Object Make_Display (finalize, dpy) Display *dpy; {
Object d;
d = Find_Object (T_Display, (GENERIC)dpy, Match_X_Obj);
if (Nullp (d)) {
d = Alloc_Object (sizeof (struct S_Display), T_Display, 0);
DISPLAY(d)->dpy = dpy;
DISPLAY(d)->free = 0;
DISPLAY(d)->after = False;
Register_Object (d, (GENERIC)dpy, finalize ? P_Close_Display :
(PFO)0, 1);
}
return d;
}
static Object P_Open_Display (argc, argv) Object *argv; {
register char *s;
Display *dpy;
if (argc == 1) {
if ((dpy = XOpenDisplay (Get_Strsym (argv[0]))) == 0)
Primitive_Error ("cannot open display ~s", argv[0]);
} else if ((dpy = XOpenDisplay ((char *)0)) == 0) {
s = XDisplayName ((char *)0);
Primitive_Error ("cannot open display ~s",
Make_String (s, strlen (s)));
}
return Make_Display (1, dpy);
}
Object P_Close_Display (d) Object d; {
register struct S_Display *p;
Check_Type (d, T_Display);
p = DISPLAY(d);
if (!p->free) {
Terminate_Group ((GENERIC)p->dpy);
XCloseDisplay (p->dpy);
}
Deregister_Object (d);
p->free = 1;
return Void;
}
static Object P_Display_Default_Root_Window (d) Object d; {
Check_Type (d, T_Display);
return Make_Window (0, DISPLAY(d)->dpy,
DefaultRootWindow (DISPLAY(d)->dpy));
}
static Object P_Display_Default_Colormap (d) Object d; {
register Display *dpy;
Check_Type (d, T_Display);
dpy = DISPLAY(d)->dpy;
return Make_Colormap (0, dpy, DefaultColormap (dpy, DefaultScreen (dpy)));
}
static Object P_Display_Default_Gcontext (d) Object d; {
register Display *dpy;
Check_Type (d, T_Display);
dpy = DISPLAY(d)->dpy;
return Make_Gc (0, dpy, DefaultGC (dpy, DefaultScreen (dpy)));
}
static Object P_Display_Default_Depth (d) Object d; {
register Display *dpy;
Check_Type (d, T_Display);
dpy = DISPLAY(d)->dpy;
return Make_Integer (DefaultDepth (dpy, DefaultScreen (dpy)));
}
static Object P_Display_Default_Screen_Number (d) Object d; {
Check_Type (d, T_Display);
return Make_Integer (DefaultScreen (DISPLAY(d)->dpy));
}
int Get_Screen_Number (dpy, scr) Display *dpy; Object scr; {
register s;
if ((s = Get_Integer (scr)) < 0 || s > ScreenCount (dpy)-1)
Primitive_Error ("invalid screen number");
return s;
}
static Object P_Display_Cells (d, scr) Object d, scr; {
Check_Type (d, T_Display);
return Make_Integer (DisplayCells (DISPLAY(d)->dpy,
Get_Screen_Number (DISPLAY(d)->dpy, scr)));
}
static Object P_Display_Planes (d, scr) Object d, scr; {
Check_Type (d, T_Display);
return Make_Integer (DisplayPlanes (DISPLAY(d)->dpy,
Get_Screen_Number (DISPLAY(d)->dpy, scr)));
}
static Object P_Display_String (d) Object d; {
register char *s;
Check_Type (d, T_Display);
s = DisplayString (DISPLAY(d)->dpy);
return Make_String (s, strlen (s));
}
static Object P_Display_Vendor (d) Object d; {
register char *s;
Object ret, name;
GC_Node;
Check_Type (d, T_Display);
s = ServerVendor (DISPLAY(d)->dpy);
name = Make_String (s, strlen (s));
GC_Link (name);
ret = Cons (Null, Make_Integer (VendorRelease (DISPLAY(d)->dpy)));
Car (ret) = name;
GC_Unlink;
return ret;
}
static Object P_Display_Protocol_Version (d) Object d; {
Check_Type (d, T_Display);
return Cons (Make_Integer (ProtocolVersion (DISPLAY(d)->dpy)),
Make_Integer (ProtocolRevision (DISPLAY(d)->dpy)));
}
static Object P_Display_Screen_Count (d) Object d; {
Check_Type (d, T_Display);
return Make_Integer (ScreenCount (DISPLAY(d)->dpy));
}
static Object P_Display_Image_Byte_Order (d) Object d; {
Check_Type (d, T_Display);
return Bits_To_Symbols ((unsigned long)ImageByteOrder (DISPLAY(d)->dpy),
0, Byte_Order_Syms);
}
static Object P_Display_Bitmap_Unit (d) Object d; {
Check_Type (d, T_Display);
return Make_Integer (BitmapUnit (DISPLAY(d)->dpy));
}
static Object P_Display_Bitmap_Bit_Order (d) Object d; {
Check_Type (d, T_Display);
return Bits_To_Symbols ((unsigned long)BitmapBitOrder (DISPLAY(d)->dpy),
0, Byte_Order_Syms);
}
static Object P_Display_Bitmap_Pad (d) Object d; {
Check_Type (d, T_Display);
return Make_Integer (BitmapPad (DISPLAY(d)->dpy));
}
static Object P_Display_Width (d) Object d; {
Check_Type (d, T_Display);
return Make_Integer (DisplayWidth (DISPLAY(d)->dpy,
DefaultScreen (DISPLAY(d)->dpy)));
}
static Object P_Display_Height (d) Object d; {
Check_Type (d, T_Display);
return Make_Integer (DisplayHeight (DISPLAY(d)->dpy,
DefaultScreen (DISPLAY(d)->dpy)));
}
static Object P_Display_Width_Mm (d) Object d; {
Check_Type (d, T_Display);
return Make_Integer (DisplayWidthMM (DISPLAY(d)->dpy,
DefaultScreen (DISPLAY(d)->dpy)));
}
static Object P_Display_Height_Mm (d) Object d; {
Check_Type (d, T_Display);
return Make_Integer (DisplayHeightMM (DISPLAY(d)->dpy,
DefaultScreen (DISPLAY(d)->dpy)));
}
static Object P_Display_Motion_Buffer_Size (d) Object d; {
Check_Type (d, T_Display);
return Make_Unsigned_Long (XDisplayMotionBufferSize (DISPLAY(d)->dpy));
}
static Object P_Display_Flush_Output (d) Object d; {
Check_Type (d, T_Display);
XFlush (DISPLAY(d)->dpy);
return Void;
}
static Object P_Display_Wait_Output (d, discard) Object d, discard; {
Check_Type (d, T_Display);
Check_Type (discard, T_Boolean);
XSync (DISPLAY(d)->dpy, EQ(discard, True));
return Void;
}
static Object P_No_Op (d) Object d; {
Check_Type (d, T_Display);
XNoOp (DISPLAY(d)->dpy);
return Void;
}
static Object P_List_Depths (d, scr) Object d, scr; {
int num;
register *p, i;
Object ret;
Check_Type (d, T_Display);
if (!(p = XListDepths (DISPLAY(d)->dpy,
Get_Screen_Number (DISPLAY(d)->dpy, scr), &num)))
return False;
ret = Make_Vector (num, Null);
for (i = 0; i < num; i++)
VECTOR(ret)->data[i] = Make_Integer (p[i]);
XFree ((char *)p);
return ret;
}
static Object P_List_Pixmap_Formats (d) Object d; {
register XPixmapFormatValues *p;
int num;
register i;
Object ret;
GC_Node;
Check_Type (d, T_Display);
if (!(p = XListPixmapFormats (DISPLAY(d)->dpy, &num)))
return False;
ret = Make_Vector (num, Null);
GC_Link (ret);
for (i = 0; i < num; i++) {
Object t;
t = P_Make_List (Make_Integer (3), Null);
VECTOR(ret)->data[i] = t;
Car (t) = Make_Integer (p[i].depth); t = Cdr (t);
Car (t) = Make_Integer (p[i].bits_per_pixel); t = Cdr (t);
Car (t) = Make_Integer (p[i].scanline_pad);
}
GC_Unlink;
XFree ((char *)p);
return ret;
}
elk_init_xlib_display () {
T_Display = Define_Type (0, "display", NOFUNC, sizeof (struct S_Display),
Display_Equal, Display_Equal, Display_Print, Display_Visit);
Define_Primitive (P_Displayp, "display?", 1, 1, EVAL);
Define_Primitive (P_Open_Display, "open-display", 0, 1, VARARGS);
Define_Primitive (P_Close_Display, "close-display", 1, 1, EVAL);
Define_Primitive (P_Display_Default_Root_Window,
"display-default-root-window", 1, 1, EVAL);
Define_Primitive (P_Display_Default_Colormap,
"display-default-colormap", 1, 1, EVAL);
Define_Primitive (P_Display_Default_Gcontext,
"display-default-gcontext", 1, 1, EVAL);
Define_Primitive (P_Display_Default_Depth,
"display-default-depth", 1, 1, EVAL);
Define_Primitive (P_Display_Default_Screen_Number,
"display-default-screen-number", 1, 1, EVAL);
Define_Primitive (P_Display_Cells, "display-cells", 2, 2, EVAL);
Define_Primitive (P_Display_Planes, "display-planes", 2, 2, EVAL);
Define_Primitive (P_Display_String, "display-string", 1, 1, EVAL);
Define_Primitive (P_Display_Vendor, "display-vendor", 1, 1, EVAL);
Define_Primitive (P_Display_Protocol_Version,
"display-protocol-version", 1, 1, EVAL);
Define_Primitive (P_Display_Screen_Count,
"display-screen-count", 1, 1, EVAL);
Define_Primitive (P_Display_Image_Byte_Order,
"display-image-byte-order", 1, 1, EVAL);
Define_Primitive (P_Display_Bitmap_Unit,
"display-bitmap-unit", 1, 1, EVAL);
Define_Primitive (P_Display_Bitmap_Bit_Order,
"display-bitmap-bit-order", 1, 1, EVAL);
Define_Primitive (P_Display_Bitmap_Pad,
"display-bitmap-pad", 1, 1, EVAL);
Define_Primitive (P_Display_Width, "display-width", 1, 1, EVAL);
Define_Primitive (P_Display_Height, "display-height", 1, 1, EVAL);
Define_Primitive (P_Display_Width_Mm,"display-width-mm", 1, 1, EVAL);
Define_Primitive (P_Display_Height_Mm,
"display-height-mm", 1, 1, EVAL);
Define_Primitive (P_Display_Motion_Buffer_Size,
"display-motion-buffer-size", 1, 1, EVAL);
Define_Primitive (P_Display_Flush_Output,
"display-flush-output", 1, 1, EVAL);
Define_Primitive (P_Display_Wait_Output,
"display-wait-output", 2, 2, EVAL);
Define_Primitive (P_No_Op, "no-op", 1, 1, EVAL);
Define_Primitive (P_List_Depths, "list-depths", 2, 2, EVAL);
Define_Primitive (P_List_Pixmap_Formats,
"list-pixmap-formats", 1, 1, EVAL);
}
--- NEW FILE ---
#include "xlib.h"
static Object V_X_Error_Handler, V_X_Fatal_Error_Handler;
/* Default error handlers of the Xlib */
extern int _XDefaultIOError();
extern int _XDefaultError();
static X_Fatal_Error (d) Display *d; {
Object args, fun;
GC_Node;
Reset_IO (0);
args = Make_Display (0, d);
GC_Link (args);
args = Cons (args, Null);
GC_Unlink;
fun = Var_Get (V_X_Fatal_Error_Handler);
if (TYPE(fun) == T_Compound)
(void)Funcall (fun, args, 0);
_XDefaultIOError (d);
exit (1); /* In case the default handler doesn't exit() */
/*NOTREACHED*/
}
static X_Error (d, ep) Display *d; XErrorEvent *ep; {
Object args, a, fun;
GC_Node;
Reset_IO (0);
args = Make_Unsigned_Long ((unsigned long)ep->resourceid);
GC_Link (args);
args = Cons (args, Null);
a = Make_Unsigned (ep->minor_code);
args = Cons (a, args);
a = Make_Unsigned (ep->request_code);
args = Cons (a, args);
a = Bits_To_Symbols ((unsigned long)ep->error_code, 0, Error_Syms);
if (Nullp (a))
a = Make_Unsigned (ep->error_code);
args = Cons (a, args);
a = Make_Unsigned_Long (ep->serial);
args = Cons (a, args);
a = Make_Display (0, ep->display);
args = Cons (a, args);
GC_Unlink;
fun = Var_Get (V_X_Error_Handler);
if (TYPE(fun) == T_Compound)
(void)Funcall (fun, args, 0);
else
_XDefaultError (d, ep);
}
static X_After_Function (d) Display *d; {
Object args;
GC_Node;
args = Make_Display (0, d);
GC_Link (args);
args = Cons (args, Null);
GC_Unlink;
(void)Funcall (DISPLAY(Car (args))->after, args, 0);
}
static Object P_Set_After_Function (d, f) Object d, f; {
Object old;
Check_Type (d, T_Display);
if (EQ(f, False)) {
(void)XSetAfterFunction (DISPLAY(d)->dpy, (int (*)())0);
} else {
Check_Procedure (f);
(void)XSetAfterFunction (DISPLAY(d)->dpy, X_After_Function);
}
old = DISPLAY(d)->after;
DISPLAY(d)->after = f;
return old;
}
static Object P_After_Function (d) Object d; {
Check_Type (d, T_Display);
return DISPLAY(d)->after;
}
elk_init_xlib_error () {
Define_Variable (&V_X_Fatal_Error_Handler, "x-fatal-error-handler", Null);
Define_Variable (&V_X_Error_Handler, "x-error-handler", Null);
(void)XSetIOErrorHandler (X_Fatal_Error);
(void)XSetErrorHandler (X_Error);
Define_Primitive (P_Set_After_Function, "set-after-function!", 2, 2, EVAL);
Define_Primitive (P_After_Function, "after-function", 1, 1, EVAL);
}
--- NEW FILE ---
#include "xlib.h"
#define MAX_ARGS 14
static Object Argl, Argv;
static struct event_desc {
char *name;
int argc;
} Event_Table[] = {
{ "event-0", 1 },
{ "event-1", 1 },
{ "key-press", 12 },
{ "key-release", 12 },
{ "button-press", 12 },
{ "button-release", 12 },
{ "motion-notify", 12 },
{ "enter-notify", 14 },
{ "leave-notify", 14 },
{ "focus-in", 4 },
{ "focus-out", 4 },
{ "keymap-notify", 3 },
{ "expose", 7 },
{ "graphics-expose", 9 },
{ "no-expose", 4 },
{ "visibility-notify", 3 },
{ "create-notify", 9 },
{ "destroy-notify", 3 },
{ "unmap-notify", 4 },
{ "map-notify", 4 },
{ "map-request", 3 },
{ "reparent-notify", 7 },
{ "configure-notify", 10 },
{ "configure-request", 11 },
{ "gravity-notify", 5 },
{ "resize-request", 4 },
{ "circulate-notify", 4 },
{ "circulate-request", 4 },
{ "property-notify", 5 },
{ "selection-clear", 4 },
{ "selection-request", 7 },
{ "selection-notify", 6 },
{ "colormap-notify", 5 },
{ "client-message", 4 },
{ "mapping-notify", 4 },
{ 0, 0 }
};
struct predicate_arg {
Object *funcs;
Object *ret;
};
/*ARGSUSED*/
static Event_Predicate (dpy, ep, ptr) Display *dpy; XEvent *ep;
#ifdef XLIB_RELEASE_5_OR_LATER
XPointer ptr; {
#else
char *ptr; {
#endif
struct predicate_arg *ap = (struct predicate_arg *)ptr;
register i;
Object args;
GC_Node;
if ((i = ep->type) < LASTEvent && !Nullp (ap->funcs[i])) {
args = Get_Event_Args (ep);
GC_Link (args);
*ap->ret = Funcall (ap->funcs[i], args, 0);
Destroy_Event_Args (args);
GC_Unlink;
}
return Truep (*ap->ret);
}
/* (handle-events display discard? peek? clause...)
* clause = (event function) or ((event...) function) or (else function)
* loops/blocks until a function returns x != #f, then returns x.
* discard?: discard unprocessed events.
* peek?: don't discard processed events.
*/
static Object P_Handle_Events (argl) Object argl; {
Object next, clause, func, ret, funcs[LASTEvent], args;
register i, discard, peek;
Display *dpy;
char *errmsg = "event occurs more than once";
GC_Node3; struct gcnode gcv;
TC_Prolog;
TC_Disable;
clause = args = Null;
GC_Link3 (argl, clause, args);
next = Eval (Car (argl));
Check_Type (next, T_Display);
dpy = DISPLAY(next)->dpy;
argl = Cdr (argl);
next = Eval (Car (argl));
Check_Type (next, T_Boolean);
discard = Truep (next);
argl = Cdr (argl);
next = Eval (Car (argl));
Check_Type (next, T_Boolean);
peek = Truep (next);
for (i = 0; i < LASTEvent; i++)
funcs[i] = Null;
gcv.gclen = 1+LASTEvent; gcv.gcobj = funcs; gcv.next = &gc3; GC_List = &gcv;
for (argl = Cdr (argl); !Nullp (argl); argl = Cdr (argl)) {
clause = Car (argl);
Check_List (clause);
if (Fast_Length (clause) != 2)
Primitive_Error ("badly formed event clause");
func = Eval (Car (Cdr (clause)));
Check_Procedure (func);
clause = Car (clause);
if (EQ(clause, Sym_Else)) {
for (i = 0; i < LASTEvent; i++)
if (Nullp (funcs[i])) funcs[i] = func;
} else {
if (TYPE(clause) == T_Pair) {
for (; !Nullp (clause); clause = Cdr (clause)) {
i = Encode_Event (Car (clause));
if (!Nullp (funcs[i]))
Primitive_Error (errmsg);
funcs[i] = func;
}
} else {
i = Encode_Event (clause);
if (!Nullp (funcs[i]))
Primitive_Error (errmsg);
funcs[i] = func;
}
}
}
ret = False;
while (!Truep (ret)) {
XEvent e;
if (discard) {
(peek ? XPeekEvent : XNextEvent) (dpy, &e);
if ((i = e.type) < LASTEvent && !Nullp (funcs[i])) {
args = Get_Event_Args (&e);
ret = Funcall (funcs[i], args, 0);
Destroy_Event_Args (args);
} else {
if (peek)
XNextEvent (dpy, &e); /* discard it */
}
} else {
struct predicate_arg a;
a.funcs = funcs;
a.ret = &ret;
(peek ? XPeekIfEvent : XIfEvent) (dpy, &e, Event_Predicate,
#ifdef XLIB_RELEASE_5_OR_LATER
(XPointer)&a);
#else
(char *)&a);
#endif
}
}
GC_Unlink;
TC_Enable;
return ret;
}
static Object Get_Time_Arg (t) Time t; {
return t == CurrentTime ? Sym_Now : Make_Unsigned_Long ((unsigned long)t);
}
Object Get_Event_Args (ep) XEvent *ep; {
Object tmpargs[MAX_ARGS];
register e, i;
register Object *a, *vp;
struct gcnode gcv;
Object dummy;
GC_Node;
e = ep->type;
dummy = Null;
a = tmpargs;
for (i = 0; i < MAX_ARGS; i++)
a[i] = Null;
GC_Link (dummy);
gcv.gclen = 1 + MAX_ARGS; gcv.gcobj = a; gcv.next = &gc1; GC_List = &gcv;
switch (e) {
case KeyPress: case KeyRelease:
case ButtonPress: case ButtonRelease:
case MotionNotify:
case EnterNotify: case LeaveNotify: {
register XKeyEvent *p = (XKeyEvent *)ep;
a[1] = Make_Window (0, p->display, p->window);
a[2] = Make_Window (0, p->display, p->root);
a[3] = Make_Window (0, p->display, p->subwindow);
a[4] = Get_Time_Arg (p->time);
a[5] = Make_Integer (p->x);
a[6] = Make_Integer (p->y);
a[7] = Make_Integer (p->x_root);
a[8] = Make_Integer (p->y_root);
if (e == KeyPress || e == KeyRelease) {
a[9] = Bits_To_Symbols ((unsigned long)p->state, 1, State_Syms);
a[10] = Make_Integer (p->keycode);
a[11] = p->same_screen ? True : False;
} else if (e == ButtonPress || e == ButtonRelease) {
register XButtonEvent *q = (XButtonEvent *)ep;
a[9] = Bits_To_Symbols ((unsigned long)q->state, 1, State_Syms);
a[10] = Bits_To_Symbols ((unsigned long)q->button, 0, Button_Syms);
a[11] = q->same_screen ? True : False;
} else if (e == MotionNotify) {
register XMotionEvent *q = (XMotionEvent *)ep;
a[9] = Bits_To_Symbols ((unsigned long)q->state, 1, State_Syms);
a[10] = q->is_hint ? True : False;
a[11] = q->same_screen ? True : False;
} else {
register XCrossingEvent *q = (XCrossingEvent *)ep;
a[9] = Bits_To_Symbols ((unsigned long)q->mode, 0, Cross_Mode_Syms);
a[10] = Bits_To_Symbols ((unsigned long)q->detail, 0,
Cross_Detail_Syms);
a[11] = q->same_screen ? True : False;
a[12] = q->focus ? True : False;
a[13] = Bits_To_Symbols ((unsigned long)q->state, 1, Button_Syms);
}
} break;
case FocusIn: case FocusOut: {
register XFocusChangeEvent *p = (XFocusChangeEvent *)ep;
a[1] = Make_Window (0, p->display, p->window);
a[2] = Bits_To_Symbols ((unsigned long)p->mode, 0, Cross_Mode_Syms);
a[3] = Bits_To_Symbols ((unsigned long)p->detail, 0, Focus_Detail_Syms);
} break;
case KeymapNotify: {
register XKeymapEvent *p = (XKeymapEvent *)ep;
a[1] = Make_Window (0, p->display, p->window);
a[2] = Make_String (p->key_vector, 32);
} break;
case Expose: {
register XExposeEvent *p = (XExposeEvent *)ep;
a[1] = Make_Window (0, p->display, p->window);
a[2] = Make_Integer (p->x);
a[3] = Make_Integer (p->y);
a[4] = Make_Integer (p->width);
a[5] = Make_Integer (p->height);
a[6] = Make_Integer (p->count);
} break;
case GraphicsExpose: {
register XGraphicsExposeEvent *p = (XGraphicsExposeEvent *)ep;
a[1] = Make_Window (0, p->display, p->drawable);
a[2] = Make_Integer (p->x);
a[3] = Make_Integer (p->y);
a[4] = Make_Integer (p->width);
a[5] = Make_Integer (p->height);
a[6] = Make_Integer (p->count);
a[7] = Make_Integer (p->major_code);
a[8] = Make_Integer (p->minor_code);
} break;
case NoExpose: {
register XNoExposeEvent *p = (XNoExposeEvent *)ep;
a[1] = Make_Window (0, p->display, p->drawable);
a[2] = Make_Integer (p->major_code);
a[3] = Make_Integer (p->minor_code);
} break;
case VisibilityNotify: {
register XVisibilityEvent *p = (XVisibilityEvent *)ep;
a[1] = Make_Window (0, p->display, p->window);
a[2] = Bits_To_Symbols ((unsigned long)p->state, 0, Visibility_Syms);
} break;
case CreateNotify: {
register XCreateWindowEvent *p = (XCreateWindowEvent *)ep;
a[1] = Make_Window (0, p->display, p->parent);
a[2] = Make_Window (0, p->display, p->window);
a[3] = Make_Integer (p->x);
a[4] = Make_Integer (p->y);
a[5] = Make_Integer (p->width);
a[6] = Make_Integer (p->height);
a[7] = Make_Integer (p->border_width);
a[8] = p->override_redirect ? True : False;
} break;
case DestroyNotify: {
register XDestroyWindowEvent *p = (XDestroyWindowEvent *)ep;
a[1] = Make_Window (0, p->display, p->event);
a[2] = Make_Window (0, p->display, p->window);
} break;
case UnmapNotify: {
register XUnmapEvent *p = (XUnmapEvent *)ep;
a[1] = Make_Window (0, p->display, p->event);
a[2] = Make_Window (0, p->display, p->window);
a[3] = p->from_configure ? True : False;
} break;
case MapNotify: {
register XMapEvent *p = (XMapEvent *)ep;
a[1] = Make_Window (0, p->display, p->event);
a[2] = Make_Window (0, p->display, p->window);
a[3] = p->override_redirect ? True : False;
} break;
case MapRequest: {
register XMapRequestEvent *p = (XMapRequestEvent *)ep;
a[1] = Make_Window (0, p->display, p->parent);
a[2] = Make_Window (0, p->display, p->window);
} break;
case ReparentNotify: {
register XReparentEvent *p = (XReparentEvent *)ep;
a[1] = Make_Window (0, p->display, p->event);
a[2] = Make_Window (0, p->display, p->window);
a[3] = Make_Window (0, p->display, p->parent);
a[4] = Make_Integer (p->x);
a[5] = Make_Integer (p->y);
a[6] = p->override_redirect ? True : False;
} break;
case ConfigureNotify: {
register XConfigureEvent *p = (XConfigureEvent *)ep;
a[1] = Make_Window (0, p->display, p->event);
a[2] = Make_Window (0, p->display, p->window);
a[3] = Make_Integer (p->x);
a[4] = Make_Integer (p->y);
a[5] = Make_Integer (p->width);
a[6] = Make_Integer (p->height);
a[7] = Make_Integer (p->border_width);
a[8] = Make_Window (0, p->display, p->above);
a[9] = p->override_redirect ? True : False;
} break;
case ConfigureRequest: {
register XConfigureRequestEvent *p = (XConfigureRequestEvent *)ep;
a[1] = Make_Window (0, p->display, p->parent);
a[2] = Make_Window (0, p->display, p->window);
a[3] = Make_Integer (p->x);
a[4] = Make_Integer (p->y);
a[5] = Make_Integer (p->width);
a[6] = Make_Integer (p->height);
a[7] = Make_Integer (p->border_width);
a[8] = Make_Window (0, p->display, p->above);
a[9] = Bits_To_Symbols ((unsigned long)p->detail, 0, Stack_Mode_Syms);
a[10] = Make_Unsigned_Long (p->value_mask);
} break;
case GravityNotify: {
register XGravityEvent *p = (XGravityEvent *)ep;
a[1] = Make_Window (0, p->display, p->event);
a[2] = Make_Window (0, p->display, p->window);
a[3] = Make_Integer (p->x);
a[4] = Make_Integer (p->y);
} break;
case ResizeRequest: {
register XResizeRequestEvent *p = (XResizeRequestEvent *)ep;
a[1] = Make_Window (0, p->display, p->window);
a[2] = Make_Integer (p->width);
a[3] = Make_Integer (p->height);
} break;
case CirculateNotify: {
register XCirculateEvent *p = (XCirculateEvent *)ep;
a[1] = Make_Window (0, p->display, p->event);
a[2] = Make_Window (0, p->display, p->window);
a[3] = Bits_To_Symbols ((unsigned long)p->place, 0, Place_Syms);
} break;
case CirculateRequest: {
register XCirculateRequestEvent *p = (XCirculateRequestEvent *)ep;
a[1] = Make_Window (0, p->display, p->parent);
a[2] = Make_Window (0, p->display, p->window);
a[3] = Bits_To_Symbols ((unsigned long)p->place, 0, Place_Syms);
} break;
case PropertyNotify: {
register XPropertyEvent *p = (XPropertyEvent *)ep;
a[1] = Make_Window (0, p->display, p->window);
a[2] = Make_Atom (p->atom);
a[3] = Get_Time_Arg (p->time);
a[4] = Bits_To_Symbols ((unsigned long)p->state, 0, Prop_Syms);
} break;
case SelectionClear: {
register XSelectionClearEvent *p = (XSelectionClearEvent *)ep;
a[1] = Make_Window (0, p->display, p->window);
a[2] = Make_Atom (p->selection);
a[3] = Get_Time_Arg (p->time);
} break;
case SelectionRequest: {
register XSelectionRequestEvent *p = (XSelectionRequestEvent *)ep;
a[1] = Make_Window (0, p->display, p->owner);
a[2] = Make_Window (0, p->display, p->requestor);
a[3] = Make_Atom (p->selection);
a[4] = Make_Atom (p->target);
a[5] = Make_Atom (p->property);
a[6] = Get_Time_Arg (p->time);
} break;
case SelectionNotify: {
register XSelectionEvent *p = (XSelectionEvent *)ep;
a[1] = Make_Window (0, p->display, p->requestor);
a[2] = Make_Atom (p->selection);
a[3] = Make_Atom (p->target);
a[4] = Make_Atom (p->property);
a[5] = Get_Time_Arg (p->time);
} break;
case ColormapNotify: {
register XColormapEvent *p = (XColormapEvent *)ep;
a[1] = Make_Window (0, p->display, p->window);
a[2] = Make_Colormap (0, p->display, p->colormap);
a[3] = p->new ? True : False;
a[4] = p->state == ColormapInstalled ? True : False;
} break;
case ClientMessage: {
register XClientMessageEvent *p = (XClientMessageEvent *)ep;
register i;
a[1] = Make_Window (0, p->display, p->window);
a[2] = Make_Atom (p->message_type);
switch (p->format) {
case 8:
a[3] = Make_String (p->data.b, 20);
break;
case 16:
a[3] = Make_Vector (10, Null);
for (i = 0; i < 10; i++)
VECTOR(a[3])->data[i] = Make_Integer (p->data.s[i]);
break;
case 32:
a[3] = Make_Vector (5, Null);
for (i = 0; i < 5; i++)
VECTOR(a[3])->data[i] = Make_Long (p->data.l[i]);
break;
default:
a[3] = Make_Integer (p->format); /* ??? */
}
} break;
case MappingNotify: {
register XMappingEvent *p = (XMappingEvent *)ep;
a[1] = Make_Window (0, p->display, p->window);
a[2] = Bits_To_Symbols ((unsigned long)p->request, 0, Mapping_Syms);
a[3] = Make_Integer (p->first_keycode);
a[4] = Make_Integer (p->count);
} break;
}
a[0] = Intern (Event_Table[e].name);
for (vp = VECTOR(Argv)->data, i = 0; i < Event_Table[e].argc; i++) {
if (i) vp++;
Car (*vp) = a[i];
Cdr (*vp) = vp[1];
}
Cdr (*vp) = Null;
GC_Unlink;
return Argl;
}
void Destroy_Event_Args (args) Object args; {
Object t;
for (t = args; !Nullp (t); t = Cdr (t))
Car (t) = Null;
}
Encode_Event (e) Object e; {
Object s;
register char *p;
register struct event_desc *ep;
register n;
Check_Type (e, T_Symbol);
s = SYMBOL(e)->name;
p = STRING(s)->data;
n = STRING(s)->size;
for (ep = Event_Table; ep->name; ep++)
if (n && strncmp (ep->name, p, n) == 0) break;
if (ep->name == 0)
Primitive_Error ("no such event: ~s", e);
return ep-Event_Table;
}
static Object P_Get_Motion_Events (w, from, to) Object w, from, to; {
XTimeCoord *p;
int n;
register i;
Object e, ret;
GC_Node2;
Check_Type (w, T_Window);
p = XGetMotionEvents (WINDOW(w)->dpy, WINDOW(w)->win, Get_Time (from),
Get_Time (to), &n);
e = ret = Make_Vector (n, Null);
GC_Link2 (ret, e);
for (i = 0; i < n; i++) {
e = P_Make_List (Make_Integer (3), Null);
VECTOR(ret)->data[i] = e;
Car (e) = Get_Time_Arg (p[i].time); e = Cdr (e);
Car (e) = Make_Integer (p[i].x); e = Cdr (e);
Car (e) = Make_Integer (p[i].y);
}
GC_Unlink;
XFree ((char *)p);
return ret;
}
static Object P_Event_Listen (d, wait_flag) Object d, wait_flag; {
Display *dpy;
register n;
XEvent e;
Check_Type (d, T_Display);
Check_Type (wait_flag, T_Boolean);
dpy = DISPLAY(d)->dpy;
n = XPending (dpy);
if (n == 0 && EQ(wait_flag, True)) {
XPeekEvent (dpy, &e);
n = XPending (dpy);
}
return Make_Integer (n);
}
elk_init_xlib_event () {
Object t;
register i;
Argl = P_Make_List (Make_Integer (MAX_ARGS), Null);
Global_GC_Link (Argl);
Argv = Make_Vector (MAX_ARGS, Null);
Global_GC_Link (Argv);
for (i = 0, t = Argl; i < MAX_ARGS; i++, t = Cdr (t))
VECTOR(Argv)->data[i] = t;
Define_Primitive (P_Handle_Events, "handle-events", 3, MANY, NOEVAL);
Define_Primitive (P_Get_Motion_Events,
"get-motion-events", 3, 3, EVAL);
Define_Primitive (P_Event_Listen, "event-listen", 2, 2, EVAL);
}
--- NEW FILE ---
#include "xlib.h"
static Object P_List_Extensions (d) Object d; {
Object ret;
int n;
register i;
register char **p;
GC_Node;
Check_Type (d, T_Display);
Disable_Interrupts;
p = XListExtensions (DISPLAY(d)->dpy, &n);
Enable_Interrupts;
ret = Make_Vector (n, Null);
GC_Link (ret);
for (i = 0; i < n; i++) {
Object e;
e = Make_String (p[i], strlen (p[i]));
VECTOR(ret)->data[i] = e;
}
GC_Unlink;
XFreeExtensionList (p);
return ret;
}
static Object P_Query_Extension (d, name) Object d, name; {
int opcode, event, error;
Object ret, t;
GC_Node2;
Check_Type (d, T_Display);
if (!XQueryExtension (DISPLAY(d)->dpy, Get_Strsym (name), &opcode,
&event, &error))
return False;
t = ret = P_Make_List (Make_Integer (3), Null);
GC_Link2 (ret, t);
Car (t) = (opcode ? Make_Integer (opcode) : False); t = Cdr (t);
Car (t) = (event ? Make_Integer (event) : False); t = Cdr (t);
Car (t) = (error ? Make_Integer (error) : False);
GC_Unlink;
return ret;
}
elk_init_xlib_extension () {
Define_Primitive (P_List_Extensions, "list-extensions", 1, 1, EVAL);
Define_Primitive (P_Query_Extension, "query-extension", 2, 2, EVAL);
}
--- NEW FILE ---
#include "xlib.h"
Object Sym_Char_Info;
static Object Sym_Font_Info, Sym_Min, Sym_Max;
Generic_Predicate (Font)
static Font_Equal (x, y) Object x, y; {
Font id1 = FONT(x)->id, id2 = FONT(y)->id;
if (id1 && id2)
return id1 == id2 && FONT(x)->dpy == FONT(y)->dpy;
else
return 0;
}
Generic_Print (Font, "#[font %lu]", FONT(x)->id ? FONT(x)->id : POINTER(x))
static Font_Visit (fp, f) Object *fp; int (*f)(); {
(*f)(&FONT(*fp)->name);
}
Generic_Get_Display (Font, FONT)
static Object Internal_Make_Font (finalize, dpy, name, id, info)
Display *dpy; Object name; Font id; XFontStruct *info; {
Object f;
GC_Node;
GC_Link (name);
f = Alloc_Object (sizeof (struct S_Font), T_Font, 0);
FONT(f)->dpy = dpy;
if (TYPE(name) == T_Symbol)
name = SYMBOL(name)->name;
FONT(f)->name = name;
FONT(f)->id = id;
FONT(f)->info = info;
if (id)
Register_Object (f, (GENERIC)dpy, finalize ? P_Close_Font : (PFO)0, 0);
GC_Unlink;
return f;
}
/* Backwards compatibility: */
Object Make_Font (dpy, name, id, info)
Display *dpy; Object name; Font id; XFontStruct *info; {
return Internal_Make_Font (1, dpy, name, id, info);
}
Object Make_Font_Foreign (dpy, name, id, info)
Display *dpy; Object name; Font id; XFontStruct *info; {
return Internal_Make_Font (0, dpy, name, id, info);
}
Font Get_Font (f) Object f; {
Check_Type (f, T_Font);
Open_Font_Maybe (f);
return FONT(f)->id;
}
static XFontStruct *Internal_Open_Font (d, name) Display *d; Object name; {
register char *s;
XFontStruct *p;
Alloca_Begin;
Get_Strsym_Stack (name, s);
Disable_Interrupts;
if ((p = XLoadQueryFont (d, s)) == 0)
Primitive_Error ("cannot open font: ~s", name);
Enable_Interrupts;
Alloca_End;
return p;
}
static Object P_Open_Font (d, name) Object d, name; {
XFontStruct *p;
Check_Type (d, T_Display)
p = Internal_Open_Font (DISPLAY(d)->dpy, name);
return Make_Font (DISPLAY(d)->dpy, name, p->fid, p);
}
void Open_Font_Maybe (f) Object f; {
Object name;
XFontStruct *p;
name = FONT(f)->name;
if (!Truep (name))
Primitive_Error ("invalid font");
if (FONT(f)->id == 0) {
p = Internal_Open_Font (FONT(f)->dpy, name);
FONT(f)->id = p->fid;
FONT(f)->info = p;
Register_Object (f, (GENERIC)(FONT(f)->dpy), P_Close_Font, 0);
}
}
Object P_Close_Font (f) Object f; {
Check_Type (f, T_Font);
if (FONT(f)->id)
XUnloadFont (FONT(f)->dpy, FONT(f)->id);
FONT(f)->id = 0;
Deregister_Object (f);
return Void;
}
static Object P_Font_Name (f) Object f; {
Check_Type (f, T_Font);
return FONT(f)->name;
}
static Object P_Gcontext_Font (g) Object g; {
register struct S_Gc *p;
register XFontStruct *info;
Check_Type (g, T_Gc);
p = GCONTEXT(g);
Disable_Interrupts;
info = XQueryFont (p->dpy, XGContextFromGC (p->gc));
Enable_Interrupts;
return Make_Font_Foreign (p->dpy, False, (Font)0, info);
}
static Object Internal_List_Fonts (d, pat, with_info) Object d, pat; {
char **ret;
int n;
XFontStruct *iret;
register i;
Object f, v;
Display *dpy;
GC_Node2;
Check_Type (d, T_Display);
dpy = DISPLAY(d)->dpy;
Disable_Interrupts;
if (with_info)
ret = XListFontsWithInfo (dpy, Get_Strsym (pat), 65535, &n, &iret);
else
ret = XListFonts (dpy, Get_Strsym (pat), 65535, &n);
Enable_Interrupts;
v = Make_Vector (n, Null);
f = Null;
GC_Link2 (f, v);
for (i = 0; i < n; i++) {
f = Make_String (ret[i], strlen (ret[i]));
if (with_info)
f = Make_Font (dpy, f, (Font)0, &iret[i]);
VECTOR(v)->data[i] = f;
}
GC_Unlink;
if (with_info)
XFreeFontInfo (ret, (XFontStruct *)0, 0);
else
XFreeFontNames (ret);
return v;
}
static Object P_List_Font_Names (d, pat) Object d, pat; {
return Internal_List_Fonts (d, pat, 0);
}
static Object P_List_Fonts (d, pat) Object d, pat; {
return Internal_List_Fonts (d, pat, 1);
}
static Object P_Font_Info (f) Object f; {
Check_Type (f, T_Font);
FI = *FONT(f)->info;
return Record_To_Vector (Font_Info_Rec, Font_Info_Size,
Sym_Font_Info, FONT(f)->dpy, ~0L);
}
static Object P_Char_Info (f, index) Object f, index; {
register t = TYPE(index);
register unsigned i;
register XCharStruct *cp;
register XFontStruct *p;
char *msg = "argument must be integer, character, 'min, or 'max";
Check_Type (f, T_Font);
Open_Font_Maybe (f);
p = FONT(f)->info;
cp = &p->max_bounds;
if (t == T_Symbol) {
if (EQ(index, Sym_Min))
cp = &p->min_bounds;
else if (!EQ(index, Sym_Max))
Primitive_Error (msg);
} else {
if (t == T_Character)
i = CHAR(index);
else if (t == T_Fixnum || t == T_Bignum)
i = (unsigned)Get_Integer (index);
else
Primitive_Error (msg);
if (!p->min_byte1 && !p->max_byte1) {
if (i < p->min_char_or_byte2 || i > p->max_char_or_byte2)
Range_Error (index);
i -= p->min_char_or_byte2;
} else {
register unsigned b1 = i & 0xff, b2 = (i >> 8) & 0xff;
if (b1 < p->min_byte1 || b1 > p->max_byte1 ||
b2 < p->min_char_or_byte2 || b2 > p->max_char_or_byte2)
Range_Error (index);
b1 -= p->min_byte1;
b2 -= p->min_char_or_byte2;
i = b1 * (p->max_char_or_byte2 - p->min_char_or_byte2 + 1) + b2;
}
if (p->per_char)
cp = p->per_char + i;
}
CI = *cp;
return Record_To_Vector (Char_Info_Rec, Char_Info_Size,
Sym_Char_Info, FONT(f)->dpy, ~0L);
}
static Object P_Font_Properties (f) Object f; {
register i, n;
Object v, a, val, x;
GC_Node4;
Check_Type (f, T_Font);
n = FONT(f)->info->n_properties;
v = Make_Vector (n, Null);
a = val = Null;
GC_Link4 (v, a, val, f);
for (i = 0; i < n; i++) {
register XFontProp *p = FONT(f)->info->properties+i;
a = Make_Atom (p->name);
val = Make_Unsigned_Long ((unsigned long)p->card32);
x = Cons (a, val);
VECTOR(v)->data[i] = x;
}
GC_Unlink;
return v;
}
static Object P_Font_Path (d) Object d; {
Object v;
int i, n;
char **ret;
GC_Node;
Check_Type (d, T_Display);
Disable_Interrupts;
ret = XGetFontPath (DISPLAY(d)->dpy, &n);
Enable_Interrupts;
v = Make_Vector (n, Null);
GC_Link (v);
for (i = 0; i < n; i++) {
Object x;
x = Make_String (ret[i], strlen (ret[i]));
VECTOR(v)->data[i] = x;
}
GC_Unlink;
XFreeFontPath (ret);
return P_Vector_To_List (v);
}
static Object P_Set_Font_Path (d, p) Object d, p; {
register char **path;
register i, n;
Object c;
Alloca_Begin;
Check_Type (d, T_Display);
Check_List (p);
n = Fast_Length (p);
Alloca (path, char**, n * sizeof (char *));
for (i = 0; i < n; i++, p = Cdr (p)) {
c = Car (p);
Get_Strsym_Stack (c, path[i]);
}
XSetFontPath (DISPLAY(d)->dpy, path, n);
Alloca_End;
return Void;
}
elk_init_xlib_font () {
Define_Symbol (&Sym_Font_Info, "font-info");
Define_Symbol (&Sym_Char_Info, "char-info");
Define_Symbol (&Sym_Min, "min");
Define_Symbol (&Sym_Max, "max");
T_Font = Define_Type (0, "font", NOFUNC, sizeof (struct S_Font),
Font_Equal, Font_Equal, Font_Print, Font_Visit);
Define_Primitive (P_Fontp, "font?", 1, 1, EVAL);
Define_Primitive (P_Font_Display, "font-display", 1, 1, EVAL);
Define_Primitive (P_Open_Font, "open-font", 2, 2, EVAL);
Define_Primitive (P_Close_Font, "close-font", 1, 1, EVAL);
Define_Primitive (P_Font_Name, "font-name", 1, 1, EVAL);
Define_Primitive (P_Gcontext_Font, "gcontext-font", 1, 1, EVAL);
Define_Primitive (P_List_Font_Names, "list-font-names", 2, 2, EVAL);
Define_Primitive (P_List_Fonts, "list-fonts", 2, 2, EVAL);
Define_Primitive (P_Font_Info, "xlib-font-info", 1, 1, EVAL);
Define_Primitive (P_Char_Info, "xlib-char-info", 2, 2, EVAL);
Define_Primitive (P_Font_Properties, "font-properties", 1, 1, EVAL);
Define_Primitive (P_Font_Path, "font-path", 1, 1, EVAL);
Define_Primitive (P_Set_Font_Path, "set-font-path!", 2, 2, EVAL);
}
--- NEW FILE ---
#include "xlib.h"
static Object Sym_Gc;
Generic_Predicate (Gc)
Generic_Equal_Dpy (Gc, GCONTEXT, gc)
Generic_Print (Gc, "#[gcontext %lu]", GCONTEXT(x)->gc)
Generic_Get_Display (Gc, GCONTEXT)
Object Make_Gc (finalize, dpy, g) Display *dpy; GC g; {
Object gc;
if (g == None)
return Sym_None;
gc = Find_Object (T_Gc, (GENERIC)dpy, Match_X_Obj, g);
if (Nullp (gc)) {
gc = Alloc_Object (sizeof (struct S_Gc), T_Gc, 0);
GCONTEXT(gc)->tag = Null;
GCONTEXT(gc)->gc = g;
GCONTEXT(gc)->dpy = dpy;
GCONTEXT(gc)->free = 0;
Register_Object (gc, (GENERIC)dpy, finalize ? P_Free_Gc :
(PFO)0, 0);
}
return gc;
}
static Object P_Create_Gc (w, g) Object w, g; {
unsigned long mask;
Display *dpy;
Drawable dr;
dr = Get_Drawable (w, &dpy);
mask = Vector_To_Record (g, GC_Size, Sym_Gc, GC_Rec);
return Make_Gc (1, dpy, XCreateGC (dpy, dr, mask, &GCV));
}
static Object P_Copy_Gc (gc, w) Object gc, w; {
GC dst;
Display *dpy;
Drawable dr;
Check_Type (gc, T_Gc);
dr = Get_Drawable (w, &dpy);
dst = XCreateGC (dpy, dr, 0L, &GCV);
XCopyGC (dpy, GCONTEXT(gc)->gc, ~0L, dst);
return Make_Gc (1, dpy, dst);
}
static Object P_Change_Gc (gc, g) Object gc, g; {
unsigned long mask;
Check_Type (gc, T_Gc);
mask = Vector_To_Record (g, GC_Size, Sym_Gc, GC_Rec);
XChangeGC (GCONTEXT(gc)->dpy, GCONTEXT(gc)->gc, mask, &GCV);
return Void;
}
Object P_Free_Gc (g) Object g; {
Check_Type (g, T_Gc);
if (!GCONTEXT(g)->free)
XFreeGC (GCONTEXT(g)->dpy, GCONTEXT(g)->gc);
Deregister_Object (g);
GCONTEXT(g)->free = 1;
return Void;
}
static Object P_Query_Best_Size (d, w, h, shape) Object d, w, h, shape; {
unsigned int rw, rh;
Check_Type (d, T_Display);
if (!XQueryBestSize (DISPLAY(d)->dpy, Symbols_To_Bits (shape, 0,
Shape_Syms), DefaultRootWindow (DISPLAY(d)->dpy),
Get_Integer (w), Get_Integer (h), &rw, &rh))
Primitive_Error ("cannot query best shape");
return Cons (Make_Integer (rw), Make_Integer (rh));
}
static Object P_Set_Gcontext_Clip_Rectangles (gc, x, y, v, ord)
Object gc, x, y, v, ord; {
register XRectangle *p;
register i, n;
Alloca_Begin;
Check_Type (gc, T_Gc);
Check_Type (v, T_Vector);
n = VECTOR(v)->size;
Alloca (p, XRectangle*, n * sizeof (XRectangle));
for (i = 0; i < n; i++) {
Object rect;
rect = VECTOR(v)->data[i];
Check_Type (rect, T_Pair);
if (Fast_Length (rect) != 4)
Primitive_Error ("invalid rectangle: ~s", rect);
p[i].x = Get_Integer (Car (rect)); rect = Cdr (rect);
p[i].y = Get_Integer (Car (rect)); rect = Cdr (rect);
p[i].width = Get_Integer (Car (rect)); rect = Cdr (rect);
p[i].height = Get_Integer (Car (rect));
}
XSetClipRectangles (GCONTEXT(gc)->dpy, GCONTEXT(gc)->gc, Get_Integer (x),
Get_Integer (y), p, n, Symbols_To_Bits (ord, 0, Ordering_Syms));
Alloca_End;
return Void;
}
static Object P_Set_Gcontext_Dashlist (gc, off, v) Object gc, off, v; {
register char *p;
register i, n, d;
Alloca_Begin;
Check_Type (gc, T_Gc);
Check_Type (v, T_Vector);
n = VECTOR(v)->size;
Alloca (p, char*, n);
for (i = 0; i < n; i++) {
d = Get_Integer (VECTOR(v)->data[i]);
if (d < 0 || d > 255)
Range_Error (VECTOR(v)->data[i]);
p[i] = d;
}
XSetDashes (GCONTEXT(gc)->dpy, GCONTEXT(gc)->gc, Get_Integer (off), p, n);
Alloca_End;
return Void;
}
#define ValidGCValuesBits \
(GCFunction | GCPlaneMask | GCForeground | GCBackground | GCLineWidth |\
GCLineStyle | GCCapStyle | GCJoinStyle | GCFillStyle | GCFillRule |\
GCTile | GCStipple | GCTileStipXOrigin | GCTileStipYOrigin | GCFont |\
GCSubwindowMode | GCGraphicsExposures | GCClipXOrigin | GCClipYOrigin |\
GCDashOffset | GCArcMode)
static Object P_Get_Gc_Values (gc) Object gc; {
unsigned long mask = ValidGCValuesBits;
Check_Type (gc, T_Gc);
if (!XGetGCValues (GCONTEXT(gc)->dpy, GCONTEXT(gc)->gc, mask, &GCV))
Primitive_Error ("cannot get gcontext values");
return Record_To_Vector (GC_Rec, GC_Size, Sym_Gc, GCONTEXT(gc)->dpy,
mask);
}
elk_init_xlib_gcontext () {
Define_Symbol (&Sym_Gc, "gcontext");
Generic_Define (Gc, "gcontext", "gcontext?");
Define_Primitive (P_Gc_Display, "gcontext-display", 1, 1, EVAL);
Define_Primitive (P_Create_Gc, "xlib-create-gcontext",2, 2, EVAL);
Define_Primitive (P_Copy_Gc, "copy-gcontext", 2, 2, EVAL);
Define_Primitive (P_Change_Gc, "xlib-change-gcontext",2, 2, EVAL);
Define_Primitive (P_Free_Gc, "free-gcontext", 1, 1, EVAL);
Define_Primitive (P_Query_Best_Size, "query-best-size", 4, 4, EVAL);
Define_Primitive (P_Set_Gcontext_Clip_Rectangles,
"set-gcontext-clip-rectangles!", 5, 5, EVAL);
Define_Primitive (P_Set_Gcontext_Dashlist,
"set-gcontext-dashlist!", 3, 3, EVAL);
Define_Primitive (P_Get_Gc_Values,
"xlib-get-gcontext-values", 1, 1, EVAL);
}
--- NEW FILE ---
#include "xlib.h"
static Object Sym_Any;
Time Get_Time (time) Object time; {
if (EQ(time, Sym_Now))
return CurrentTime;
return (Time)Get_Long (time);
}
static Get_Mode (m) Object m; {
Check_Type (m, T_Boolean);
return EQ(m, True) ? GrabModeSync : GrabModeAsync;
}
static Object P_Grab_Pointer (win, ownerp, events, psyncp, ksyncp, confine_to,
cursor, time) Object win, ownerp, events, psyncp, ksyncp, confine_to,
cursor, time; {
Check_Type (win, T_Window);
Check_Type (ownerp, T_Boolean);
return Bits_To_Symbols ((unsigned long)XGrabPointer (WINDOW(win)->dpy,
WINDOW(win)->win,
EQ(ownerp, True), Symbols_To_Bits (events, 1, Event_Syms),
Get_Mode (psyncp), Get_Mode (ksyncp),
Get_Window (confine_to), Get_Cursor (cursor), Get_Time (time)),
0, Grabstatus_Syms);
}
static Object P_Ungrab_Pointer (d, time) Object d, time; {
Check_Type (d, T_Display);
XUngrabPointer (DISPLAY(d)->dpy, Get_Time (time));
return Void;
}
static Object P_Grab_Button (win, button, mods, ownerp, events, psyncp, ksyncp,
confine_to, cursor) Object win, button, mods, ownerp, events,
psyncp, ksyncp, confine_to, cursor; {
Check_Type (win, T_Window);
Check_Type (ownerp, T_Boolean);
XGrabButton (WINDOW(win)->dpy, Symbols_To_Bits (button, 0, Button_Syms),
Symbols_To_Bits (mods, 1, State_Syms), WINDOW(win)->win,
EQ(ownerp, True), Symbols_To_Bits (events, 1, Event_Syms),
Get_Mode (psyncp), Get_Mode (ksyncp),
Get_Window (confine_to), Get_Cursor (cursor));
return Void;
}
static Object P_Ungrab_Button (win, button, mods) Object win, button, mods; {
Check_Type (win, T_Window);
XUngrabButton (WINDOW(win)->dpy, Symbols_To_Bits (button, 0, Button_Syms),
Symbols_To_Bits (mods, 1, State_Syms), WINDOW(win)->win);
return Void;
}
static Object P_Change_Active_Pointer_Grab (d, events, cursor, time)
Object d, events, cursor, time; {
Check_Type (d, T_Display);
XChangeActivePointerGrab (DISPLAY(d)->dpy, Symbols_To_Bits (events, 1,
Event_Syms), Get_Cursor (cursor), Get_Time (time));
return Void;
}
static Object P_Grab_Keyboard (win, ownerp, psyncp, ksyncp, time) Object win,
ownerp, psyncp, ksyncp, time; {
Check_Type (win, T_Window);
Check_Type (ownerp, T_Boolean);
return Bits_To_Symbols ((unsigned long)XGrabKeyboard (WINDOW(win)->dpy,
WINDOW(win)->win, EQ(ownerp, True), Get_Mode (psyncp),
Get_Mode (ksyncp), Get_Time (time)),
0, Grabstatus_Syms);
}
static Object P_Ungrab_Keyboard (d, time) Object d, time; {
Check_Type (d, T_Display);
XUngrabKeyboard (DISPLAY(d)->dpy, Get_Time (time));
return Void;
}
static Object P_Grab_Key (win, key, mods, ownerp, psyncp, ksyncp) Object win,
key, mods, ownerp, psyncp, ksyncp; {
int keycode = AnyKey;
Check_Type (win, T_Window);
if (!EQ(key, Sym_Any))
keycode = Get_Integer (key);
Check_Type (ownerp, T_Boolean);
XGrabKey (WINDOW(win)->dpy, keycode, Symbols_To_Bits (mods, 1, State_Syms),
WINDOW(win)->win, EQ(ownerp, True), Get_Mode (psyncp),
Get_Mode (ksyncp));
return Void;
}
static Object P_Ungrab_Key (win, key, mods) Object win, key, mods; {
int keycode = AnyKey;
Check_Type (win, T_Window);
if (!EQ(key, Sym_Any))
keycode = Get_Integer (key);
XUngrabKey (WINDOW(win)->dpy, keycode,
Symbols_To_Bits (mods, 1, State_Syms), WINDOW(win)->win);
return Void;
}
static Object P_Allow_Events (d, mode, time) Object d, mode, time; {
Check_Type (d, T_Display);
XAllowEvents (DISPLAY(d)->dpy, Symbols_To_Bits (mode, 0,
Allow_Events_Syms), Get_Time (time));
return Void;
}
static Object P_Grab_Server (d) Object d; {
Check_Type (d, T_Display);
XGrabServer (DISPLAY(d)->dpy);
return Void;
}
static Object P_Ungrab_Server (d) Object d; {
Check_Type (d, T_Display);
XUngrabServer (DISPLAY(d)->dpy);
return Void;
}
elk_init_xlib_grab () {
Define_Primitive (P_Grab_Pointer, "grab-pointer", 8, 8, EVAL);
Define_Primitive (P_Ungrab_Pointer, "ungrab-pointer", 2, 2, EVAL);
Define_Primitive (P_Grab_Button, "grab-button", 9, 9, EVAL);
Define_Primitive (P_Ungrab_Button, "ungrab-button", 3, 3, EVAL);
Define_Primitive (P_Change_Active_Pointer_Grab,
"change-active-pointer-grab", 4, 4, EVAL);
Define_Primitive (P_Grab_Keyboard, "grab-keyboard", 5, 5, EVAL);
Define_Primitive (P_Ungrab_Keyboard, "ungrab-keyboard", 2, 2, EVAL);
Define_Primitive (P_Grab_Key, "grab-key", 6, 6, EVAL);
Define_Primitive (P_Ungrab_Key, "ungrab-key", 3, 3, EVAL);
Define_Primitive (P_Allow_Events, "allow-events", 3, 3, EVAL);
Define_Primitive (P_Grab_Server, "grab-server", 1, 1, EVAL);
Define_Primitive (P_Ungrab_Server, "ungrab-server", 1, 1, EVAL);
Define_Symbol (&Sym_Any, "any");
}
--- NEW FILE ---
#include "xlib.h"
extern XDrawPoints(), XDrawLines(), XDrawRectangle(), XFillRectangle();
extern XDrawRectangles(), XFillRectangles(), XDrawArc(), XFillArc();
extern XDrawArcs(), XFillArcs(), XFillPolygon();
static Object P_Clear_Area (win, x, y, w, h, e) Object win, x, y, w, h, e; {
Check_Type (win, T_Window);
Check_Type (e, T_Boolean);
XClearArea (WINDOW(win)->dpy, WINDOW(win)->win, Get_Integer (x),
Get_Integer (y), Get_Integer (w), Get_Integer (h), EQ(e, True));
return Void;
}
static Object P_Copy_Area (src, gc, sx, sy, w, h, dst, dx, dy) Object src, gc,
sx, sy, w, h, dst, dx, dy; {
Display *dpy;
Drawable ddst = Get_Drawable (dst, &dpy), dsrc = Get_Drawable (src, &dpy);
Check_Type (gc, T_Gc);
XCopyArea (dpy, dsrc, ddst, GCONTEXT(gc)->gc, Get_Integer (sx),
Get_Integer (sy), Get_Integer (w), Get_Integer (h),
Get_Integer (dx), Get_Integer (dy));
return Void;
}
static Object P_Copy_Plane (src, gc, plane, sx, sy, w, h, dst, dx, dy)
Object src, gc, plane, sx, sy, w, h, dst, dx, dy; {
Display *dpy;
Drawable ddst = Get_Drawable (dst, &dpy), dsrc = Get_Drawable (src, &dpy);
register unsigned long p;
Check_Type (gc, T_Gc);
p = (unsigned long)Get_Long (plane);
if (p & (p-1))
Primitive_Error ("invalid plane: ~s", plane);
XCopyPlane (dpy, dsrc, ddst, GCONTEXT(gc)->gc, Get_Integer (sx),
Get_Integer (sy), Get_Integer (w), Get_Integer (h),
Get_Integer (dx), Get_Integer (dy), p);
return Void;
}
static Object P_Draw_Point (d, gc, x, y) Object d, gc, x, y; {
Display *dpy;
Drawable dr = Get_Drawable (d, &dpy);
Check_Type (gc, T_Gc);
XDrawPoint (dpy, dr, GCONTEXT(gc)->gc, Get_Integer (x), Get_Integer (y));
return Void;
}
static Object Internal_Draw_Points (d, gc, v, relative, func, shape)
Object d, gc, v, relative, shape; int (*func)(); {
Display *dpy;
Drawable dr = Get_Drawable (d, &dpy);
register XPoint *p;
register i, n;
int rel, sh;
Alloca_Begin;
Check_Type (gc, T_Gc);
Check_Type (relative, T_Boolean);
rel = EQ(relative, True) ? CoordModePrevious : CoordModeOrigin;
if (func == XFillPolygon)
sh = Symbols_To_Bits (shape, 0, Polyshape_Syms);
n = VECTOR(v)->size;
Alloca (p, XPoint*, n * sizeof (XPoint));
for (i = 0; i < n; i++) {
Object point;
point = VECTOR(v)->data[i];
Check_Type (point, T_Pair);
p[i].x = Get_Integer (Car (point));
p[i].y = Get_Integer (Cdr (point));
}
if (func == XFillPolygon)
XFillPolygon (dpy, dr, GCONTEXT(gc)->gc, p, n, sh, rel);
else
(*func)(dpy, dr, GCONTEXT(gc)->gc, p, n, rel);
Alloca_End;
return Void;
}
static Object P_Draw_Points (d, gc, v, relative) Object d, gc, v, relative; {
return Internal_Draw_Points (d, gc, v, relative, XDrawPoints, Null);
}
static Object P_Draw_Line (d, gc, x1, y1, x2, y2)
Object d, gc, x1, y1, x2, y2; {
Display *dpy;
Drawable dr = Get_Drawable (d, &dpy);
Check_Type (gc, T_Gc);
XDrawLine (dpy, dr, GCONTEXT(gc)->gc, Get_Integer (x1), Get_Integer (y1),
Get_Integer (x2), Get_Integer (y2));
return Void;
}
static Object P_Draw_Lines (d, gc, v, relative) Object d, gc, v, relative; {
return Internal_Draw_Points (d, gc, v, relative, XDrawLines, Null);
}
static Object P_Draw_Segments (d, gc, v) Object d, gc, v; {
Display *dpy;
Drawable dr = Get_Drawable (d, &dpy);
register XSegment *p;
register i, n;
Alloca_Begin;
Check_Type (gc, T_Gc);
n = VECTOR(v)->size;
Alloca (p, XSegment*, n * sizeof (XSegment));
for (i = 0; i < n; i++) {
Object seg;
seg = VECTOR(v)->data[i];
Check_Type (seg, T_Pair);
if (Fast_Length (seg) != 4)
Primitive_Error ("invalid segment: ~s", seg);
p[i].x1 = Get_Integer (Car (seg)); seg = Cdr (seg);
p[i].y1 = Get_Integer (Car (seg)); seg = Cdr (seg);
p[i].x2 = Get_Integer (Car (seg)); seg = Cdr (seg);
p[i].y2 = Get_Integer (Car (seg));
}
XDrawSegments (dpy, dr, GCONTEXT(gc)->gc, p, n);
Alloca_End;
return Void;
}
static Object Internal_Draw_Rectangle (d, gc, x, y, w, h, func)
Object d, gc, x, y, w, h; int (*func)(); {
Display *dpy;
Drawable dr = Get_Drawable (d, &dpy);
Check_Type (gc, T_Gc);
(*func)(dpy, dr, GCONTEXT(gc)->gc, Get_Integer (x),
Get_Integer (y), Get_Integer (w), Get_Integer (h));
return Void;
}
static Object P_Draw_Rectangle (d, gc, x, y, w, h) Object d, gc, x, y, w, h; {
return Internal_Draw_Rectangle (d, gc, x, y, w, h, XDrawRectangle);
}
static Object P_Fill_Rectangle (d, gc, x, y, w, h) Object d, gc, x, y, w, h; {
return Internal_Draw_Rectangle (d, gc, x, y, w, h, XFillRectangle);
}
static Object Internal_Draw_Rectangles (d, gc, v, func)
Object d, gc, v; int (*func)(); {
Display *dpy;
Drawable dr = Get_Drawable (d, &dpy);
register XRectangle *p;
register i, n;
Alloca_Begin;
Check_Type (gc, T_Gc);
n = VECTOR(v)->size;
Alloca (p, XRectangle*, n * sizeof (XRectangle));
for (i = 0; i < n; i++) {
Object rect;
rect = VECTOR(v)->data[i];
Check_Type (rect, T_Pair);
if (Fast_Length (rect) != 4)
Primitive_Error ("invalid rectangle: ~s", rect);
p[i].x = Get_Integer (Car (rect)); rect = Cdr (rect);
p[i].y = Get_Integer (Car (rect)); rect = Cdr (rect);
p[i].width = Get_Integer (Car (rect)); rect = Cdr (rect);
p[i].height = Get_Integer (Car (rect));
}
(*func)(dpy, dr, GCONTEXT(gc)->gc, p, n);
Alloca_End;
return Void;
}
static Object P_Draw_Rectangles (d, gc, v) Object d, gc, v; {
return Internal_Draw_Rectangles (d, gc, v, XDrawRectangles);
}
static Object P_Fill_Rectangles (d, gc, v) Object d, gc, v; {
return Internal_Draw_Rectangles (d, gc, v, XFillRectangles);
}
static Object Internal_Draw_Arc (d, gc, x, y, w, h, a1, a2, func)
Object d, gc, x, y, w, h, a1, a2; int (*func)(); {
Display *dpy;
Drawable dr = Get_Drawable (d, &dpy);
Check_Type (gc, T_Gc);
(*func)(dpy, dr, GCONTEXT(gc)->gc, Get_Integer (x), Get_Integer (y),
Get_Integer (w), Get_Integer (h), Get_Integer (a1), Get_Integer (a2));
return Void;
}
static Object P_Draw_Arc (d, gc, x, y, w, h, a1, a2)
Object d, gc, x, y, w, h, a1, a2; {
return Internal_Draw_Arc (d, gc, x, y, w, h, a1, a2, XDrawArc);
}
static Object P_Fill_Arc (d, gc, x, y, w, h, a1, a2)
Object d, gc, x, y, w, h, a1, a2; {
return Internal_Draw_Arc (d, gc, x, y, w, h, a1, a2, XFillArc);
}
static Object Internal_Draw_Arcs (d, gc, v, func) Object d, gc, v;
int (*func)(); {
Display *dpy;
Drawable dr = Get_Drawable (d, &dpy);
register XArc *p;
register i, n;
Alloca_Begin;
Check_Type (gc, T_Gc);
n = VECTOR(v)->size;
Alloca (p, XArc*, n * sizeof (XArc));
for (i = 0; i < n; i++) {
Object arc;
arc = VECTOR(v)->data[i];
Check_Type (arc, T_Pair);
if (Fast_Length (arc) != 6)
Primitive_Error ("invalid arc: ~s", arc);
p[i].x = Get_Integer (Car (arc)); arc = Cdr (arc);
p[i].y = Get_Integer (Car (arc)); arc = Cdr (arc);
p[i].width = Get_Integer (Car (arc)); arc = Cdr (arc);
p[i].height = Get_Integer (Car (arc)); arc = Cdr (arc);
p[i].angle1 = Get_Integer (Car (arc)); arc = Cdr (arc);
p[i].angle2 = Get_Integer (Car (arc));
}
(*func)(dpy, dr, GCONTEXT(gc)->gc, p, n);
Alloca_End;
return Void;
}
static Object P_Draw_Arcs (d, gc, v) Object d, gc, v; {
return Internal_Draw_Arcs (d, gc, v, XDrawArcs);
}
static Object P_Fill_Arcs (d, gc, v) Object d, gc, v; {
return Internal_Draw_Arcs (d, gc, v, XFillArcs);
}
static Object P_Fill_Polygon (d, gc, v, relative, shape)
Object d, gc, v, relative, shape; {
return Internal_Draw_Points (d, gc, v, relative, XFillPolygon, shape);
}
elk_init_xlib_graphics () {
Define_Primitive (P_Clear_Area, "clear-area", 6, 6, EVAL);
Define_Primitive (P_Copy_Area, "copy-area", 9, 9, EVAL);
Define_Primitive (P_Copy_Plane, "copy-plane", 10,10, EVAL);
Define_Primitive (P_Draw_Point, "draw-point", 4, 4, EVAL);
Define_Primitive (P_Draw_Points, "draw-points", 4, 4, EVAL);
Define_Primitive (P_Draw_Line, "draw-line", 6, 6, EVAL);
Define_Primitive (P_Draw_Lines, "draw-lines", 4, 4, EVAL);
Define_Primitive (P_Draw_Segments, "draw-segments", 3, 3, EVAL);
Define_Primitive (P_Draw_Rectangle, "draw-rectangle", 6, 6, EVAL);
Define_Primitive (P_Fill_Rectangle, "fill-rectangle", 6, 6, EVAL);
Define_Primitive (P_Draw_Rectangles, "draw-rectangles", 3, 3, EVAL);
Define_Primitive (P_Fill_Rectangles, "fill-rectangles", 3, 3, EVAL);
Define_Primitive (P_Draw_Arc, "draw-arc", 8, 8, EVAL);
Define_Primitive (P_Fill_Arc, "fill-arc", 8, 8, EVAL);
Define_Primitive (P_Draw_Arcs, "draw-arcs", 3, 3, EVAL);
Define_Primitive (P_Fill_Arcs, "fill-arcs", 3, 3, EVAL);
Define_Primitive (P_Fill_Polygon, "fill-polygon", 5, 5, EVAL);
}
--- NEW FILE ---
#include "xlib.h"
static Object P_Xlib_Release_4_Or_Laterp () {
return True;
}
static Object P_Xlib_Release_5_Or_Laterp () {
#ifdef XLIB_RELEASE_5_OR_LATER
return True;
#else
return False;
#endif
}
static Object P_Xlib_Release_6_Or_Laterp () {
#ifdef XLIB_RELEASE_6_OR_LATER
return True;
#else
return False;
#endif
}
elk_init_xlib_init () {
Define_Primitive (P_Xlib_Release_4_Or_Laterp,
"xlib-release-4-or-later?", 0, 0, EVAL);
Define_Primitive (P_Xlib_Release_5_Or_Laterp,
"xlib-release-5-or-later?", 0, 0, EVAL);
Define_Primitive (P_Xlib_Release_6_Or_Laterp,
"xlib-release-6-or-later?", 0, 0, EVAL);
P_Provide (Intern ("xlib.o"));
}
#if defined(XLIB_RELEASE_5_OR_LATER) && (defined(sun) || defined(__sun__)) &&\
defined(__svr4__)
/*
* Stub interface to dynamic linker routines
* that SunOS uses but didn't ship with 4.1.
*
* The C library routine wcstombs in SunOS 4.1 tries to dynamically
* load some routines using the dlsym interface, described in dlsym(3x).
* Unfortunately SunOS 4.1 does not include the necessary library, libdl.
*/
void *dlopen() { return 0; }
void *dlsym() { return 0; }
int dlclose() { return -1; }
#endif
--- NEW FILE ---
#include "xlib.h"
#ifdef XLIB_RELEASE_5_OR_LATER
/* I don't know if XDisplayKeycodes() was already there in X11R4.
*/
static Object P_Display_Min_Keycode (d) Object d; {
int mink, maxk;
Check_Type (d, T_Display);
XDisplayKeycodes(DISPLAY(d)->dpy, &mink, &maxk);
return Make_Integer (mink);
}
static Object P_Display_Max_Keycode (d) Object d; {
int mink, maxk;
Check_Type (d, T_Display);
XDisplayKeycodes(DISPLAY(d)->dpy, &mink, &maxk);
return Make_Integer (maxk);
}
#else
static Object P_Display_Min_Keycode (d) Object d; {
Check_Type (d, T_Display);
return Make_Integer (DISPLAY(d)->dpy->min_keycode);
}
static Object P_Display_Max_Keycode (d) Object d; {
Check_Type (d, T_Display);
return Make_Integer (DISPLAY(d)->dpy->max_keycode);
}
#endif
#ifdef XLIB_RELEASE_5_OR_LATER
/* I'm not sure if this works correctly in X11R4:
*/
static Object P_Display_Keysyms_Per_Keycode (d) Object d; {
KeySym *ksyms;
int mink, maxk, ksyms_per_kode;
Check_Type (d, T_Display);
XDisplayKeycodes(DISPLAY(d)->dpy, &mink, &maxk);
ksyms = XGetKeyboardMapping(DISPLAY(d)->dpy, (KeyCode)mink,
maxk - mink + 1, &ksyms_per_kode);
return Make_Integer (ksyms_per_kode);
}
#else
static Object P_Display_Keysyms_Per_Keycode (d) Object d; {
Check_Type (d, T_Display);
/* Force initialization: */
Disable_Interrupts;
(void)XKeycodeToKeysym (DISPLAY(d)->dpy, DISPLAY(d)->dpy->min_keycode, 0);
Enable_Interrupts;
return Make_Integer (DISPLAY(d)->dpy->keysyms_per_keycode);
}
#endif
static Object P_String_To_Keysym (s) Object s; {
KeySym k;
k = XStringToKeysym (Get_Strsym (s));
return k == NoSymbol ? False : Make_Unsigned_Long ((unsigned long)k);
}
static Object P_Keysym_To_String (k) Object k; {
register char *s;
s = XKeysymToString ((KeySym)Get_Long (k));
return s ? Make_String (s, strlen (s)) : False;
}
static Object P_Keycode_To_Keysym (d, k, index) Object d, k, index; {
Object ret;
Check_Type (d, T_Display);
Disable_Interrupts;
ret = Make_Unsigned_Long ((unsigned long)XKeycodeToKeysym (DISPLAY(d)->dpy,
Get_Integer (k), Get_Integer (index)));
Enable_Interrupts;
return ret;
}
static Object P_Keysym_To_Keycode (d, k) Object d, k; {
Object ret;
Check_Type (d, T_Display);
Disable_Interrupts;
ret = Make_Unsigned (XKeysymToKeycode (DISPLAY(d)->dpy,
(KeySym)Get_Long (k)));
Enable_Interrupts;
return ret;
}
static Object P_Lookup_String (d, k, mask) Object d, k, mask; {
XKeyEvent e;
char buf[1024];
register len;
KeySym keysym_return;
XComposeStatus status_return;
Check_Type (d, T_Display);
e.display = DISPLAY(d)->dpy;
e.keycode = Get_Integer (k);
e.state = Symbols_To_Bits (mask, 1, State_Syms);
Disable_Interrupts;
len = XLookupString (&e, buf, 1024, &keysym_return, &status_return);
Enable_Interrupts;
return Make_String (buf, len);
}
static Object P_Rebind_Keysym (d, k, mods, str) Object d, k, mods, str; {
KeySym *p;
register i, n;
Alloca_Begin;
Check_Type (d, T_Display);
Check_Type (str, T_String);
Check_Type (mods, T_Vector);
n = VECTOR(mods)->size;
Alloca (p, KeySym*, n * sizeof (KeySym));
for (i = 0; i < n; i++)
p[i] = (KeySym)Get_Long (VECTOR(mods)->data[i]);
XRebindKeysym (DISPLAY(d)->dpy, (KeySym)Get_Long (k), p, n,
(unsigned char *)STRING(str)->data, STRING(str)->size);
Alloca_End;
return Void;
}
static Object P_Refresh_Keyboard_Mapping (w, event) Object w, event; {
static XMappingEvent fake;
Check_Type (w, T_Window);
fake.type = MappingNotify;
fake.display = WINDOW(w)->dpy;
fake.window = WINDOW(w)->win;
fake.request = Symbols_To_Bits (event, 0, Mapping_Syms);
XRefreshKeyboardMapping (&fake);
return Void;
}
elk_init_xlib_key () {
Define_Primitive (P_Display_Min_Keycode, "display-min-keycode",
1, 1, EVAL);
Define_Primitive (P_Display_Max_Keycode, "display-max-keycode",
1, 1, EVAL);
Define_Primitive (P_Display_Keysyms_Per_Keycode,
"display-keysyms-per-keycode", 1, 1, EVAL);
Define_Primitive (P_String_To_Keysym, "string->keysym", 1, 1, EVAL);
Define_Primitive (P_Keysym_To_String, "keysym->string", 1, 1, EVAL);
Define_Primitive (P_Keycode_To_Keysym, "keycode->keysym", 3, 3, EVAL);
Define_Primitive (P_Keysym_To_Keycode, "keysym->keycode", 2, 2, EVAL);
Define_Primitive (P_Lookup_String, "lookup-string", 3, 3, EVAL);
Define_Primitive (P_Rebind_Keysym, "rebind-keysym", 4, 4, EVAL);
Define_Primitive (P_Refresh_Keyboard_Mapping,
"refresh-keyboard-mapping", 2, 2, EVAL);
}
--- NEW FILE ---
#include <varargs.h>
#include "xlib.h"
Object Sym_None;
int Match_X_Obj (x, v) Object x; va_list v; {
register type = TYPE(x);
if (type == T_Display) {
return 1;
} else if (type == T_Gc) {
return va_arg (v, GC) == GCONTEXT(x)->gc;
} else if (type == T_Pixel) {
return va_arg (v, unsigned long) == PIXEL(x)->pix;
} else if (type == T_Pixmap) {
return va_arg (v, Pixmap) == PIXMAP(x)->pm;
} else if (type == T_Window) {
return va_arg (v, Window) == WINDOW(x)->win;
} else if (type == T_Font) {
return va_arg (v, Font) == FONT(x)->id;
} else if (type == T_Colormap) {
return va_arg (v, Colormap) == COLORMAP(x)->cm;
} else if (type == T_Color) {
return va_arg (v, unsigned int) == COLOR(x)->c.red
&& va_arg (v, unsigned int) == COLOR(x)->c.green
&& va_arg (v, unsigned int) == COLOR(x)->c.blue;
} else if (type == T_Cursor) {
return va_arg (v, Cursor) == CURSOR(x)->cursor;
} else if (type == T_Atom) {
return va_arg (v, Atom) == ATOM(x)->atom;
} else Panic ("Match_X_Obj");
return 0;
}
elk_init_xlib_objects () {
Define_Symbol (&Sym_None, "none");
}
--- NEW FILE ---
#include "xlib.h"
Generic_Predicate (Pixel)
Generic_Simple_Equal (Pixel, PIXEL, pix)
Generic_Print (Pixel, "#[pixel 0x%lx]", PIXEL(x)->pix)
Object Make_Pixel (val) unsigned long val; {
Object pix;
pix = Find_Object (T_Pixel, (GENERIC)0, Match_X_Obj, val);
if (Nullp (pix)) {
pix = Alloc_Object (sizeof (struct S_Pixel), T_Pixel, 0);
PIXEL(pix)->tag = Null;
PIXEL(pix)->pix = val;
Register_Object (pix, (GENERIC)0, (PFO)0, 0);
}
return pix;
}
unsigned long Get_Pixel (p) Object p; {
Check_Type (p, T_Pixel);
return PIXEL(p)->pix;
}
static Object P_Pixel_Value (p) Object p; {
return Make_Unsigned_Long (Get_Pixel (p));
}
static Object P_Black_Pixel (d) Object d; {
Check_Type (d, T_Display);
return Make_Pixel (BlackPixel (DISPLAY(d)->dpy,
DefaultScreen (DISPLAY(d)->dpy)));
}
static Object P_White_Pixel (d) Object d; {
Check_Type (d, T_Display);
return Make_Pixel (WhitePixel (DISPLAY(d)->dpy,
DefaultScreen (DISPLAY(d)->dpy)));
}
elk_init_xlib_pixel () {
Generic_Define (Pixel, "pixel", "pixel?");
Define_Primitive (P_Pixel_Value, "pixel-value", 1, 1, EVAL);
Define_Primitive (P_Black_Pixel, "black-pixel", 1, 1, EVAL);
Define_Primitive (P_White_Pixel, "white-pixel", 1, 1, EVAL);
}
--- NEW FILE ---
#include "xlib.h"
Generic_Predicate (Pixmap)
Generic_Equal_Dpy (Pixmap, PIXMAP, pm)
Generic_Print (Pixmap, "#[pixmap %lu]", PIXMAP(x)->pm)
Generic_Get_Display (Pixmap, PIXMAP)
static Object Internal_Make_Pixmap (finalize, dpy, pix)
Display *dpy; Pixmap pix; {
Object pm;
if (pix == None)
return Sym_None;
pm = Find_Object (T_Pixmap, (GENERIC)dpy, Match_X_Obj, pix);
if (Nullp (pm)) {
pm = Alloc_Object (sizeof (struct S_Pixmap), T_Pixmap, 0);
PIXMAP(pm)->tag = Null;
PIXMAP(pm)->pm = pix;
PIXMAP(pm)->dpy = dpy;
PIXMAP(pm)->free = 0;
Register_Object (pm, (GENERIC)dpy,
finalize ? P_Free_Pixmap : (PFO)0, 0);
}
return pm;
}
/* Backwards compatibility: */
Object Make_Pixmap (dpy, pix) Display *dpy; Pixmap pix; {
return Internal_Make_Pixmap (1, dpy, pix);
}
Object Make_Pixmap_Foreign (dpy, pix) Display *dpy; Pixmap pix; {
return Internal_Make_Pixmap (0, dpy, pix);
}
Pixmap Get_Pixmap (p) Object p; {
Check_Type (p, T_Pixmap);
return PIXMAP(p)->pm;
}
Object P_Free_Pixmap (p) Object p; {
Check_Type (p, T_Pixmap);
if (!PIXMAP(p)->free)
XFreePixmap (PIXMAP(p)->dpy, PIXMAP(p)->pm);
Deregister_Object (p);
PIXMAP(p)->free = 1;
return Void;
}
static Object P_Create_Pixmap (d, w, h, depth) Object d, w, h, depth; {
Display *dpy;
Drawable dr = Get_Drawable (d, &dpy);
return Make_Pixmap (dpy, XCreatePixmap (dpy, dr, Get_Integer (w),
Get_Integer (h), Get_Integer (depth)));
}
static Object P_Create_Bitmap_From_Data (win, data, pw, ph)
Object win, data, pw, ph; {
register w, h;
Check_Type (win, T_Window);
Check_Type (data, T_String);
w = Get_Integer (pw);
h = Get_Integer (ph);
if (w * h > 8 * STRING(data)->size)
Primitive_Error ("bitmap too small");
return Make_Pixmap (WINDOW(win)->dpy,
XCreateBitmapFromData (WINDOW(win)->dpy, WINDOW(win)->win,
STRING(data)->data, w, h));
}
static Object P_Create_Pixmap_From_Bitmap_Data (win, data, pw, ph, fg, bg,
depth) Object win, data, pw, ph, fg, bg, depth; {
register w, h;
Check_Type (win, T_Window);
Check_Type (data, T_String);
w = Get_Integer (pw);
h = Get_Integer (ph);
if (w * h > 8 * STRING(data)->size)
Primitive_Error ("bitmap too small");
return Make_Pixmap (WINDOW(win)->dpy,
XCreatePixmapFromBitmapData (WINDOW(win)->dpy, WINDOW(win)->win,
STRING(data)->data, w, h, Get_Pixel (fg), Get_Pixel (bg),
Get_Integer (depth)));
}
static Object P_Read_Bitmap_File (d, fn) Object d, fn; {
Display *dpy;
Drawable dr = Get_Drawable (d, &dpy);
unsigned width, height;
int r, xhot, yhot;
Pixmap bitmap;
Object t, ret, x;
GC_Node2;
Disable_Interrupts;
r = XReadBitmapFile (dpy, dr, Get_Strsym (fn), &width, &height, &bitmap,
&xhot, &yhot);
Enable_Interrupts;
if (r != BitmapSuccess)
return Bits_To_Symbols ((unsigned long)r, 0, Bitmapstatus_Syms);
t = ret = P_Make_List (Make_Integer (5), Null);
GC_Link2 (ret, t);
x = Make_Pixmap (dpy, bitmap);
Car (t) = x; t = Cdr (t);
Car (t) = Make_Integer (width); t = Cdr (t);
Car (t) = Make_Integer (height); t = Cdr (t);
Car (t) = Make_Integer (xhot); t = Cdr (t);
Car (t) = Make_Integer (yhot);
GC_Unlink;
return ret;
}
static Object P_Write_Bitmap_File (argc, argv) Object *argv; {
Pixmap pm;
int ret, xhot = -1, yhot = -1;
pm = Get_Pixmap (argv[1]);
if (argc == 5)
Primitive_Error ("both x-hot and y-hot must be specified");
if (argc == 6) {
xhot = Get_Integer (argv[4]);
yhot = Get_Integer (argv[5]);
}
Disable_Interrupts;
ret = XWriteBitmapFile (PIXMAP(argv[1])->dpy, Get_Strsym (argv[0]), pm,
Get_Integer (argv[2]), Get_Integer (argv[3]), xhot, yhot);
Enable_Interrupts;
return Bits_To_Symbols ((unsigned long)ret, 0, Bitmapstatus_Syms);
}
elk_init_xlib_pixmap () {
Generic_Define (Pixmap, "pixmap", "pixmap?");
Define_Primitive (P_Pixmap_Display, "pixmap-display", 1, 1, EVAL);
Define_Primitive (P_Free_Pixmap, "free-pixmap", 1, 1, EVAL);
Define_Primitive (P_Create_Pixmap, "create-pixmap", 4, 4, EVAL);
Define_Primitive (P_Create_Bitmap_From_Data,
"create-bitmap-from-data", 4, 4, EVAL);
Define_Primitive (P_Create_Pixmap_From_Bitmap_Data,
"create-pixmap-from-bitmap-data", 7, 7, EVAL);
Define_Primitive (P_Read_Bitmap_File, "read-bitmap-file", 2, 2, EVAL);
Define_Primitive (P_Write_Bitmap_File, "write-bitmap-file", 4, 6, VARARGS);
}
--- NEW FILE ---
#include "xlib.h"
Object Sym_Now;
Generic_Predicate (Atom)
Generic_Simple_Equal (Atom, ATOM, atom)
Generic_Print (Atom, "#[atom %lu]", ATOM(x)->atom)
Object Make_Atom (a) Atom a; {
Object atom;
if (a == None)
return Sym_None;
atom = Find_Object (T_Atom, (GENERIC)0, Match_X_Obj, a);
if (Nullp (atom)) {
atom = Alloc_Object (sizeof (struct S_Atom), T_Atom, 0);
ATOM(atom)->tag = Null;
ATOM(atom)->atom = a;
Register_Object (atom, (GENERIC)0, (PFO)0, 0);
}
return atom;
}
/* Should be used with care */
static Object P_Make_Atom (n) Object n; {
return Make_Atom ((Atom)Get_Long (n));
}
static Object P_Intern_Atom (d, name) Object d, name; {
Check_Type (d, T_Display);
return Make_Atom (XInternAtom (DISPLAY(d)->dpy, Get_Strsym (name), 0));
}
static Object P_Find_Atom (d, name) Object d, name; {
Check_Type (d, T_Display);
return Make_Atom (XInternAtom (DISPLAY(d)->dpy, Get_Strsym (name), 1));
}
static Object P_Atom_Name (d, a) Object d, a; {
register char *s;
Check_Type (d, T_Display);
Check_Type (a, T_Atom);
Disable_Interrupts;
s = XGetAtomName (DISPLAY(d)->dpy, ATOM(a)->atom);
Enable_Interrupts;
return Make_String (s, strlen (s));
}
static Object P_List_Properties (w) Object w; {
register i;
int n;
register Atom *ap;
Object v;
GC_Node;
Check_Type (w, T_Window);
Disable_Interrupts;
ap = XListProperties (WINDOW(w)->dpy, WINDOW(w)->win, &n);
Enable_Interrupts;
v = Make_Vector (n, Null);
GC_Link (v);
for (i = 0; i < n; i++) {
Object x;
x = Make_Atom (ap[i]);
VECTOR(v)->data[i] = x;
}
GC_Unlink;
XFree ((char *)ap);
return v;
}
static Object P_Get_Property (w, prop, type, start, len, deletep)
Object w, prop, type, start, len, deletep; {
Atom req_type = AnyPropertyType, actual_type;
int format;
unsigned long nitems, bytes_left;
unsigned char *data;
Object ret, t, x;
register i;
GC_Node2;
Check_Type (w, T_Window);
Check_Type (prop, T_Atom);
if (!EQ(type, False)) {
Check_Type (type, T_Atom);
req_type = ATOM(type)->atom;
}
Check_Type (deletep, T_Boolean);
Disable_Interrupts;
if (XGetWindowProperty (WINDOW(w)->dpy, WINDOW(w)->win, ATOM(prop)->atom,
Get_Long (start), Get_Long (len),
EQ(deletep, True), req_type, &actual_type, &format,
&nitems, &bytes_left, &data) != Success)
Primitive_Error ("cannot get property");
Enable_Interrupts;
ret = t = P_Make_List (Make_Integer (4), Null);
GC_Link2 (ret, t);
x = Make_Atom (actual_type);
Car (t) = x; t = Cdr (t);
x = Make_Integer (format);
Car (t) = x; t = Cdr (t);
if (nitems) {
if (format == 8) {
Object s;
x = Make_String ((char *)0, (int)nitems);
s = Car (t) = x;
bcopy ((char *)data, STRING(s)->data, (int)nitems);
} else {
Object v;
GC_Node;
/* Assumes short is 16 bits and int is 32 bits.
*/
v = Make_Vector ((int)nitems, Null);
GC_Link (v);
for (i = 0; i < nitems; i++) {
x = Make_Unsigned (format == 16 ?
*((short *)data + i) : *((int *)data + i));
VECTOR(v)->data[i] = x;
}
Car (t) = v;
GC_Unlink;
}
}
t = Cdr (t);
x = Make_Unsigned_Long (bytes_left);
Car (t) = x;
GC_Unlink;
return ret;
}
static Object P_Change_Property (w, prop, type, format, mode, data)
Object w, prop, type, format, mode, data; {
register i, m, x, nitems, f;
char *buf;
Alloca_Begin;
Check_Type (w, T_Window);
Check_Type (prop, T_Atom);
Check_Type (type, T_Atom);
m = Symbols_To_Bits (mode, 0, Propmode_Syms);
switch (f = Get_Integer (format)) {
case 8:
Check_Type (data, T_String);
buf = STRING(data)->data;
nitems = STRING(data)->size;
break;
case 16: case 32:
Check_Type (data, T_Vector);
nitems = VECTOR(data)->size;
Alloca (buf, char*, nitems * (f / sizeof (char)));
for (i = 0; i < nitems; i++) {
x = Get_Integer (VECTOR(data)->data[i]);
if (f == 16) {
if (x > 65535)
Primitive_Error ("format mismatch");
*((short *)buf + i) = x; /* Assumes short is 16 bits */
} else *((int *)buf + i) = x; /* and int is 32 bits. */
}
break;
default:
Primitive_Error ("invalid format: ~s", format);
}
XChangeProperty (WINDOW(w)->dpy, WINDOW(w)->win, ATOM(prop)->atom,
ATOM(type)->atom, f, m, (unsigned char *)buf, nitems);
Alloca_End;
return Void;
}
static Object P_Delete_Property (w, prop) Object w, prop; {
Check_Type (w, T_Window);
Check_Type (prop, T_Atom);
XDeleteProperty (WINDOW(w)->dpy, WINDOW(w)->win, ATOM(prop)->atom);
return Void;
}
static Object P_Rotate_Properties (w, v, delta) Object w, v, delta; {
Atom *p;
register i, n;
Alloca_Begin;
Check_Type (w, T_Window);
Check_Type (v, T_Vector);
n = VECTOR(v)->size;
Alloca (p, Atom*, n * sizeof (Atom));
for (i = 0; i < n; i++) {
Object a;
a = VECTOR(v)->data[i];
Check_Type (a, T_Atom);
p[i] = ATOM(a)->atom;
}
XRotateWindowProperties (WINDOW(w)->dpy, WINDOW(w)->win, p, n,
Get_Integer (delta));
Alloca_End;
return Void;
}
static Object P_Set_Selection_Owner (d, s, owner, time) Object d, s, owner,
time; {
Check_Type (d, T_Display);
Check_Type (s, T_Atom);
XSetSelectionOwner (DISPLAY(d)->dpy, ATOM(s)->atom, Get_Window (owner),
Get_Time (time));
return Void;
}
static Object P_Selection_Owner (d, s) Object d, s; {
Check_Type (d, T_Display);
Check_Type (s, T_Atom);
return Make_Window (0, DISPLAY(d)->dpy,
XGetSelectionOwner (DISPLAY(d)->dpy, ATOM(s)->atom));
}
static Object P_Convert_Selection (s, target, prop, w, time)
Object s, target, prop, w, time; {
Atom p = None;
Check_Type (s, T_Atom);
Check_Type (target, T_Atom);
if (!EQ(prop, Sym_None)) {
Check_Type (prop, T_Atom);
p = ATOM(prop)->atom;
}
Check_Type (w, T_Window);
XConvertSelection (WINDOW(w)->dpy, ATOM(s)->atom, ATOM(target)->atom,
p, WINDOW(w)->win, Get_Time (time));
return Void;
}
elk_init_xlib_property () {
Define_Symbol (&Sym_Now, "now");
Generic_Define (Atom, "atom", "atom?");
Define_Primitive (P_Make_Atom, "make-atom", 1, 1, EVAL);
Define_Primitive (P_Intern_Atom, "intern-atom", 2, 2, EVAL);
Define_Primitive (P_Find_Atom, "find-atom", 2, 2, EVAL);
Define_Primitive (P_Atom_Name, "atom-name", 2, 2, EVAL);
Define_Primitive (P_List_Properties, "list-properties", 1, 1, EVAL);
Define_Primitive (P_Get_Property, "get-property", 6, 6, EVAL);
Define_Primitive (P_Change_Property, "change-property", 6, 6, EVAL);
Define_Primitive (P_Delete_Property, "delete-property", 2, 2, EVAL);
Define_Primitive (P_Rotate_Properties, "rotate-properties", 3, 3, EVAL);
Define_Primitive (P_Set_Selection_Owner, "set-selection-owner!",
4, 4, EVAL);
Define_Primitive (P_Selection_Owner, "selection-owner", 2, 2, EVAL);
Define_Primitive (P_Convert_Selection, "convert-selection", 5, 5, EVAL);
}
--- NEW FILE ---
#include "xlib.h"
extern XDrawText(), XDrawText16();
static Object Sym_1byte, Sym_2byte;
static Two_Byte (format) Object format; {
Check_Type (format, T_Symbol);
if (EQ(format, Sym_1byte))
return 0;
else if (EQ(format, Sym_2byte))
return 1;
Primitive_Error ("index format must be '1-byte or '2-byte");
/*NOTREACHED*/
}
static Get_1_Byte_Char (x) Object x; {
register c = Get_Integer (x);
if (c < 0 || c > 255)
Range_Error (x);
return c;
}
static Get_2_Byte_Char (x) Object x; {
register c = Get_Integer (x);
if (c < 0 || c > 65535)
Range_Error (x);
return c;
}
/* 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.
*/
static Object Internal_Text_Metrics (font, t, f, width) Object font, t, f; {
char *s;
XChar2b *s2;
XFontStruct *info;
Object *data;
register i, n;
int dir, fasc, fdesc;
Alloca_Begin;
Check_Type (font, T_Font);
info = FONT(font)->info;
Check_Type (t, T_Vector);
n = VECTOR(t)->size;
data = VECTOR(t)->data;
if (Two_Byte (f)) {
Alloca (s2, XChar2b*, n * sizeof (XChar2b));
for (i = 0; i < n; i++) {
register c = Get_2_Byte_Char (data[i]);
s2[i].byte1 = (c >> 8) & 0xff;
s2[i].byte2 = c & 0xff;
}
if (width)
i = XTextWidth16 (info, s2, n);
else
XTextExtents16 (info, s2, n, &dir, &fasc, &fdesc, &CI);
} else {
Alloca (s, char*, n);
for (i = 0; i < n; i++)
s[i] = Get_1_Byte_Char (data[i]);
if (width)
i = XTextWidth (info, s, n);
else
XTextExtents (info, s, n, &dir, &fasc, &fdesc, &CI);
}
Alloca_End;
return width ? Make_Integer (i) : Record_To_Vector (Char_Info_Rec,
Char_Info_Size, Sym_Char_Info, FONT(font)->dpy, ~0L);
}
static Object P_Text_Width (font, t, f) Object font, t, f; {
return Internal_Text_Metrics (font, t, f, 1);
}
static Object P_Text_Extents (font, t, f) Object font, t, f; {
return Internal_Text_Metrics (font, t, f, 0);
}
static Object P_Draw_Image_Text (d, gc, x, y, t, f) Object d, gc, x, y, t, f; {
Display *dpy;
Drawable dr = Get_Drawable (d, &dpy);
Object *data;
register i, n;
char *s;
XChar2b *s2;
Alloca_Begin;
Check_Type (gc, T_Gc);
Check_Type (t, T_Vector);
n = VECTOR(t)->size;
data = VECTOR(t)->data;
if (Two_Byte (f)) {
Alloca (s2, XChar2b*, n * sizeof (XChar2b));
for (i = 0; i < n; i++) {
register c = Get_2_Byte_Char (data[i]);
s2[i].byte1 = (c >> 8) & 0xff;
s2[i].byte2 = c & 0xff;
}
XDrawImageString16 (dpy, dr, GCONTEXT(gc)->gc, Get_Integer (x),
Get_Integer (y), s2, n);
} else {
Alloca (s, char*, n);
for (i = 0; i < n; i++)
s[i] = Get_1_Byte_Char (data[i]);
XDrawImageString (dpy, dr, GCONTEXT(gc)->gc, Get_Integer (x),
Get_Integer (y), s, n);
}
Alloca_End;
return Void;
}
static Object P_Draw_Poly_Text (d, gc, x, y, t, f) Object d, gc, x, y, t, f; {
Display *dpy;
Drawable dr = Get_Drawable (d, &dpy);
Object *data;
register i, n, j, k;
int twobyte, nitems;
XTextItem *items;
int (*func)();
Alloca_Begin;
Check_Type (gc, T_Gc);
twobyte = Two_Byte (f);
func = twobyte ? (int(*)())XDrawText16 : (int(*)())XDrawText;
Check_Type (t, T_Vector);
if ((n = VECTOR(t)->size) == 0)
return Void;
for (data = VECTOR(t)->data, i = 0, nitems = 1; i < n; i++)
if (TYPE(data[i]) == T_Font) nitems++;
Alloca (items, XTextItem*, nitems * sizeof (XTextItem));
items[0].delta = 0;
items[0].font = None;
for (j = k = i = 0; i <= n; i++) {
if (i == n || TYPE(data[i]) == T_Font) {
items[j].nchars = i-k;
if (twobyte) {
register XChar2b *p;
Alloca (p, XChar2b*, (i-k) * sizeof (XChar2b));
((XTextItem16 *)items)[j].chars = p;
for ( ; k < i; k++, p++) {
register c = Get_2_Byte_Char (data[k]);
p->byte1 = (c >> 8) & 0xff;
p->byte2 = c & 0xff;
}
} else {
register char *p;
Alloca (p, char*, i-k);
items[j].chars = p;
for ( ; k < i; k++)
*p++ = Get_1_Byte_Char (data[k]);
}
k++;
j++;
if (i < n) {
items[j].delta = 0;
Open_Font_Maybe (data[i]);
items[j].font = FONT(data[i])->id;
}
}
}
(*func)(dpy, dr, GCONTEXT(gc)->gc, Get_Integer (x), Get_Integer (y),
items, nitems);
Alloca_End;
return Void;
}
elk_init_xlib_text () {
Define_Primitive (P_Text_Width, "text-width", 3, 3, EVAL);
Define_Primitive (P_Text_Extents, "xlib-text-extents", 3, 3, EVAL);
Define_Primitive (P_Draw_Image_Text, "draw-image-text", 6, 6, EVAL);
Define_Primitive (P_Draw_Poly_Text, "draw-poly-text", 6, 6, EVAL);
Define_Symbol (&Sym_1byte, "1-byte");
Define_Symbol (&Sym_2byte, "2-byte");
}
--- NEW FILE ---
#include "xlib.h"
static Object Set_Attr_Slots;
static Object Conf_Slots;
static Object GC_Slots;
static Object Geometry_Slots;
static Object Win_Attr_Slots;
static Object Font_Info_Slots;
static Object Char_Info_Slots;
static Object Wm_Hints_Slots;
static Object Size_Hints_Slots;
static Object Sym_Parent_Relative, Sym_Copy_From_Parent;
XSetWindowAttributes SWA;
RECORD Set_Attr_Rec[] = {
{ (char *)&SWA.background_pixmap, "background-pixmap", T_BACKGROUND,
0, CWBackPixmap },
{ (char *)&SWA.background_pixel, "background-pixel", T_PIXEL,
0, CWBackPixel },
{ (char *)&SWA.border_pixmap, "border-pixmap", T_BORDER,
0, CWBorderPixmap },
{ (char *)&SWA.border_pixel, "border-pixel", T_PIXEL,
0, CWBorderPixel },
{ (char *)&SWA.bit_gravity, "bit-gravity", T_SYM,
Bit_Grav_Syms, CWBitGravity },
{ (char *)&SWA.win_gravity, "gravity", T_SYM,
Grav_Syms, CWWinGravity },
{ (char *)&SWA.backing_store, "backing-store", T_SYM,
Backing_Store_Syms, CWBackingStore },
{ (char *)&SWA.backing_planes, "backing-planes", T_PIXEL,
0, CWBackingPlanes },
{ (char *)&SWA.backing_pixel, "backing-pixel", T_PIXEL,
0, CWBackingPixel },
{ (char *)&SWA.save_under, "save-under", T_BOOL,
0, CWSaveUnder },
{ (char *)&SWA.event_mask, "event-mask", T_MASK,
Event_Syms, CWEventMask },
{ (char *)&SWA.do_not_propagate_mask, "do-not-propagate-mask", T_MASK,
Event_Syms, CWDontPropagate },
{ (char *)&SWA.override_redirect, "override-redirect", T_BOOL,
0, CWOverrideRedirect },
{ (char *)&SWA.colormap, "colormap", T_COLORMAP,
0, CWColormap },
{ (char *)&SWA.cursor, "cursor", T_CURSOR,
0, CWCursor },
{ 0, 0, T_NONE, 0, 0 }
};
int Set_Attr_Size = sizeof Set_Attr_Rec / sizeof (RECORD);
XWindowChanges WC;
RECORD Conf_Rec[] = {
{ (char *)&WC.x, "x", T_INT, 0, CWX },
{ (char *)&WC.y, "y", T_INT, 0, CWY },
{ (char *)&WC.width, "width", T_INT, 0, CWWidth },
{ (char *)&WC.height, "height", T_INT, 0, CWHeight },
{ (char *)&WC.border_width, "border-width", T_INT, 0, CWBorderWidth },
{ (char *)&WC.sibling, "sibling", T_WINDOW, 0, CWSibling },
{ (char *)&WC.stack_mode, "stack-mode", T_SYM, Stack_Mode_Syms,
CWStackMode },
{ 0, 0, T_NONE, 0, 0 }
};
int Conf_Size = sizeof Conf_Rec / sizeof (RECORD);
XGCValues GCV;
RECORD GC_Rec[] = {
{ (char *)&GCV.function, "function", T_SYM,
Func_Syms, GCFunction },
{ (char *)&GCV.plane_mask, "plane-mask", T_PIXEL,
0, GCPlaneMask },
{ (char *)&GCV.foreground, "foreground", T_PIXEL,
0, GCForeground },
{ (char *)&GCV.background, "background", T_PIXEL,
0, GCBackground },
{ (char *)&GCV.line_width, "line-width", T_INT,
0, GCLineWidth },
{ (char *)&GCV.line_style, "line-style", T_SYM,
Line_Style_Syms, GCLineStyle },
{ (char *)&GCV.cap_style, "cap-style", T_SYM,
Cap_Style_Syms, GCCapStyle },
{ (char *)&GCV.join_style, "join-style", T_SYM,
Join_Style_Syms, GCJoinStyle },
{ (char *)&GCV.fill_style, "fill-style", T_SYM,
Fill_Style_Syms, GCFillStyle },
{ (char *)&GCV.fill_rule, "fill-rule", T_SYM,
Fill_Rule_Syms, GCFillRule },
{ (char *)&GCV.arc_mode, "arc-mode", T_SYM,
Arc_Mode_Syms, GCArcMode },
{ (char *)&GCV.tile, "tile", T_PIXMAP,
0, GCTile },
{ (char *)&GCV.stipple, "stipple", T_PIXMAP,
0, GCStipple },
{ (char *)&GCV.ts_x_origin, "ts-x", T_INT,
0, GCTileStipXOrigin },
{ (char *)&GCV.ts_y_origin, "ts-y", T_INT,
0, GCTileStipYOrigin },
{ (char *)&GCV.font, "font", T_FONT,
0, GCFont },
{ (char *)&GCV.subwindow_mode, "subwindow-mode", T_SYM,
Subwin_Mode_Syms, GCSubwindowMode },
{ (char *)&GCV.graphics_exposures, "exposures", T_BOOL,
0, GCGraphicsExposures },
{ (char *)&GCV.clip_x_origin, "clip-x", T_INT,
0, GCClipXOrigin },
{ (char *)&GCV.clip_y_origin, "clip-y", T_INT,
0, GCClipYOrigin },
{ (char *)&GCV.clip_mask, "clip-mask", T_PIXMAP,
0, GCClipMask },
{ (char *)&GCV.dash_offset, "dash-offset", T_INT,
0, GCDashOffset },
{ (char *)&GCV.dashes, "dashes", T_CHAR,
0, GCDashList },
{0, 0, T_NONE, 0, 0 }
};
int GC_Size = sizeof GC_Rec / sizeof (RECORD);
GEOMETRY GEO;
RECORD Geometry_Rec[] = {
{ (char *)&GEO.root, "root", T_WINDOW, 0, 0 },
{ (char *)&GEO.x, "x", T_INT, 0, 0 },
{ (char *)&GEO.y, "y", T_INT, 0, 0 },
{ (char *)&GEO.width, "width", T_INT, 0, 0 },
{ (char *)&GEO.height, "height", T_INT, 0, 0 },
{ (char *)&GEO.border_width, "border-width", T_INT, 0, 0 },
{ (char *)&GEO.depth, "depth", T_INT, 0, 0 },
{0, 0, T_NONE, 0, 0 }
};
int Geometry_Size = sizeof Geometry_Rec / sizeof (RECORD);
XWindowAttributes WA;
RECORD Win_Attr_Rec[] = {
{ (char *)&WA.x, "x", T_INT,
0, 0 },
{ (char *)&WA.y, "y", T_INT,
0, 0 },
{ (char *)&WA.width, "width", T_INT,
0, 0 },
{ (char *)&WA.height, "height", T_INT,
0, 0 },
{ (char *)&WA.border_width, "border-width", T_INT,
0, 0 },
{ (char *)&WA.depth, "depth", T_INT,
0, 0 },
{ (char *)&WA.visual, "visual", T_NONE,
0, 0 },
{ (char *)&WA.root, "root", T_WINDOW,
0, 0 },
#if defined(__cplusplus) || defined(c_plusplus)
{ (char *)&WA.c_class, "class", T_SYM,
#else
{ (char *)&WA.class, "class", T_SYM,
#endif
Class_Syms, 0 },
{ (char *)&WA.bit_gravity, "bit-gravity", T_SYM,
Bit_Grav_Syms, 0 },
{ (char *)&WA.win_gravity, "gravity", T_SYM,
Grav_Syms, 0 },
{ (char *)&WA.backing_store, "backing-store", T_SYM,
Backing_Store_Syms, 0 },
{ (char *)&WA.backing_planes, "backing-planes", T_PIXEL,
0, 0 },
{ (char *)&WA.backing_pixel, "backing-pixel", T_PIXEL,
0, 0 },
{ (char *)&WA.save_under, "save-under", T_BOOL,
0, 0 },
{ (char *)&WA.colormap , "colormap", T_COLORMAP,
0, 0 },
{ (char *)&WA.map_installed, "map-installed", T_BOOL,
0, 0 },
{ (char *)&WA.map_state, "map-state", T_SYM,
Map_State_Syms, 0 },
{ (char *)&WA.all_event_masks, "all-event-masks", T_MASK,
Event_Syms, 0 },
{ (char *)&WA.your_event_mask, "your-event-mask", T_MASK,
Event_Syms, 0 },
{ (char *)&WA.do_not_propagate_mask, "do-not-propagate-mask", T_MASK,
Event_Syms, 0 },
{ (char *)&WA.override_redirect, "override-redirect", T_BOOL,
0, 0 },
{ (char *)&WA.screen, "screen", T_NONE,
0, 0 },
{0, 0, T_NONE, 0, 0 }
};
int Win_Attr_Size = sizeof Win_Attr_Rec / sizeof (RECORD);
XFontStruct FI;
RECORD Font_Info_Rec[] = {
{ (char *)&FI.direction, "direction", T_SYM,
Direction_Syms, 0 },
{ (char *)&FI.min_char_or_byte2, "min-byte2", T_INT,
0, 0 },
{ (char *)&FI.max_char_or_byte2, "max-byte2", T_INT,
0, 0 },
{ (char *)&FI.min_byte1, "min-byte1", T_INT,
0, 0 },
{ (char *)&FI.max_byte1, "max-byte1", T_INT,
0, 0 },
{ (char *)&FI.all_chars_exist, "all-chars-exist?", T_BOOL,
0, 0 },
{ (char *)&FI.default_char, "default-char", T_INT,
0, 0 },
{ (char *)&FI.ascent, "ascent", T_INT,
0, 0 },
{ (char *)&FI.descent, "descent", T_INT,
0, 0 },
{0, 0, T_NONE, 0, 0 }
};
int Font_Info_Size = sizeof Font_Info_Rec / sizeof (RECORD);
XCharStruct CI;
RECORD Char_Info_Rec[] = {
{ (char *)&CI.lbearing, "lbearing", T_SHORT, 0, 0 },
{ (char *)&CI.rbearing, "rbearing", T_SHORT, 0, 0 },
{ (char *)&CI.width, "width", T_SHORT, 0, 0 },
{ (char *)&CI.ascent, "ascent", T_SHORT, 0, 0 },
{ (char *)&CI.descent, "descent", T_SHORT, 0, 0 },
{ (char *)&CI.attributes, "attributes", T_SHORT, 0, 0 },
{0, 0, T_NONE, 0, 0 }
};
int Char_Info_Size = sizeof Char_Info_Rec / sizeof (RECORD);
XWMHints WMH;
RECORD Wm_Hints_Rec[] = {
{ (char *)&WMH.input, "input?", T_BOOL,
0, InputHint },
{ (char *)&WMH.initial_state, "initial-state", T_SYM,
Initial_State_Syms, StateHint },
{ (char *)&WMH.icon_pixmap, "icon-pixmap", T_PIXMAP,
0, IconPixmapHint },
{ (char *)&WMH.icon_window, "icon-window", T_WINDOW,
0, IconWindowHint },
{ (char *)&WMH.icon_x, "icon-x", T_INT,
0, IconPositionHint },
{ (char *)&WMH.icon_y, "icon-y", T_INT,
0, IconPositionHint },
{ (char *)&WMH.icon_mask, "icon-mask", T_PIXMAP,
0, IconMaskHint },
{ (char *)&WMH.window_group, "window-group", T_WINDOW,
0, WindowGroupHint },
{0, 0, T_NONE, 0, 0 }
};
int Wm_Hints_Size = sizeof Wm_Hints_Rec / sizeof (RECORD);
XSizeHints SZH;
RECORD Size_Hints_Rec[] = {
{ (char *)&SZH.x, "x", T_INT, 0, PPosition },
{ (char *)&SZH.y, "y", T_INT, 0, PPosition },
{ (char *)&SZH.width, "width", T_INT, 0, PSize },
{ (char *)&SZH.height, "height", T_INT, 0, PSize },
{ (char *)&SZH.x, "x", T_INT, 0, USPosition },
{ (char *)&SZH.y, "y", T_INT, 0, USPosition },
{ (char *)&SZH.width, "width", T_INT, 0, USSize },
{ (char *)&SZH.height, "height", T_INT, 0, USSize },
{ (char *)&SZH.min_width, "min-width", T_INT, 0, PMinSize },
{ (char *)&SZH.min_height, "min-height", T_INT, 0, PMinSize },
{ (char *)&SZH.max_width, "max-width", T_INT, 0, PMaxSize },
{ (char *)&SZH.max_height, "max-height", T_INT, 0, PMaxSize },
{ (char *)&SZH.width_inc, "width-inc", T_INT, 0, PResizeInc },
{ (char *)&SZH.height_inc, "height-inc", T_INT, 0, PResizeInc },
{ (char *)&SZH.min_aspect.x, "min-aspect-x", T_INT, 0, PAspect },
{ (char *)&SZH.min_aspect.y, "min-aspect-y", T_INT, 0, PAspect },
{ (char *)&SZH.max_aspect.x, "max-aspect-x", T_INT, 0, PAspect },
{ (char *)&SZH.max_aspect.y, "max-aspect-y", T_INT, 0, PAspect },
{ (char *)&SZH.base_width, "base-width", T_INT, 0, PBaseSize },
{ (char *)&SZH.base_height, "base-height", T_INT, 0, PBaseSize },
{ (char *)&SZH.win_gravity, "gravity", T_SYM, Grav_Syms,
PWinGravity },
{0, 0, T_NONE, 0, 0 }
};
int Size_Hints_Size = sizeof Size_Hints_Rec / sizeof (RECORD);
unsigned long Vector_To_Record (v, len, sym, rp) Object v, sym;
register RECORD *rp; {
register Object *p;
unsigned long mask = 0;
Check_Type (v, T_Vector);
p = VECTOR(v)->data;
if (VECTOR(v)->size != len && !EQ(p[0], sym))
Primitive_Error ("invalid argument");
for ( ; rp->slot; rp++) {
++p;
if (rp->type == T_NONE || Nullp (*p))
continue;
switch (rp->type) {
case T_INT:
*(int *)rp->slot = Get_Integer (*p); break;
case T_SHORT:
*(short *)rp->slot = Get_Integer (*p); break;
case T_CHAR:
*(char *)rp->slot = Get_Integer (*p); break;
case T_PIXEL:
*(unsigned long *)rp->slot = Get_Pixel (*p); break;
case T_BACKGROUND:
if (EQ(*p, Sym_None))
*(Pixmap *)rp->slot = None;
else if (EQ(*p, Sym_Parent_Relative))
*(Pixmap *)rp->slot = ParentRelative;
else
*(Pixmap *)rp->slot = Get_Pixmap (*p);
break;
case T_BORDER:
if (EQ(*p, Sym_Copy_From_Parent)) {
*(Pixmap *)rp->slot = CopyFromParent;
break;
}
/* fall through */
case T_PIXMAP:
*(Pixmap *)rp->slot = Get_Pixmap (*p); break;
case T_BOOL:
Check_Type (*p, T_Boolean);
*(Bool *)rp->slot = (Bool)(FIXNUM(*p));
break;
case T_FONT:
*(Font *)rp->slot = Get_Font (*p);
break;
case T_COLORMAP:
*(Colormap *)rp->slot = Get_Colormap (*p); break;
case T_CURSOR:
*(Cursor *)rp->slot = Get_Cursor (*p);
break;
case T_WINDOW:
break;
case T_MASK:
*(long *)rp->slot = Symbols_To_Bits (*p, 1, rp->syms);
break;
case T_SYM:
*(int *)rp->slot = (int)Symbols_To_Bits (*p, 0, rp->syms);
break;
default:
Panic ("vector->record");
}
mask |= rp->mask;
}
return mask;
}
Object Record_To_Vector (rp, len, sym, dpy, flags) Object sym;
register RECORD *rp; Display *dpy; unsigned long flags; {
register i;
Object v, x;
GC_Node2;
v = Null;
GC_Link2 (sym, v);
v = Make_Vector (len, Null);
VECTOR(v)->data[0] = sym;
for (i = 1; rp->slot; i++, rp++) {
if (rp->type == T_NONE)
continue;
if (rp->mask && !(flags & rp->mask))
continue;
x = Null;
switch (rp->type) {
case T_INT:
x = Make_Integer (*(int *)rp->slot); break;
case T_SHORT:
x = Make_Integer (*(short *)rp->slot); break;
case T_CHAR:
x = Make_Integer (*(char *)rp->slot); break;
case T_PIXEL:
x = Make_Pixel (*(unsigned long *)rp->slot); break;
case T_PIXMAP:
if (*(unsigned long *)rp->slot == ~0L)
x = Sym_None;
else
x = Make_Pixmap_Foreign (dpy, *(Pixmap *)rp->slot);
break;
case T_FONT:
if (*(unsigned long *)rp->slot == ~0L)
x = Sym_None;
else {
register XFontStruct *info;
Disable_Interrupts;
info = XQueryFont (dpy, *(Font *)rp->slot);
Enable_Interrupts;
x = Make_Font_Foreign (dpy, False, *(Font *)rp->slot, info);
}
break;
case T_BOOL:
x = *(Bool *)rp->slot ? True : False; break;
case T_COLORMAP:
x = Make_Colormap (0, dpy, *(Colormap *)rp->slot); break;
case T_WINDOW:
x = Make_Window (0, dpy, *(Window *)rp->slot); break;
case T_MASK:
x = Bits_To_Symbols (*(long *)rp->slot, 1, rp->syms);
break;
case T_SYM:
x = Bits_To_Symbols ((unsigned long)*(int *)rp->slot, 0, rp->syms);
break;
default:
Panic ("record->vector");
}
VECTOR(v)->data[i] = x;
}
GC_Unlink;
return v;
}
SYMDESCR Func_Syms[] = {
{ "clear", GXclear },
{ "and", GXand },
{ "and-reverse", GXandReverse },
{ "copy", GXcopy },
{ "and-inverted", GXandInverted },
{ "no-op", GXnoop },
{ "xor", GXxor },
{ "or", GXor },
{ "nor", GXnor },
{ "equiv", GXequiv },
{ "invert", GXinvert },
{ "or-reverse", GXorReverse },
{ "copy-inverted", GXcopyInverted },
{ "or-inverted", GXorInverted },
{ "nand", GXnand },
{ "set", GXset },
{ 0, 0 }
};
SYMDESCR Bit_Grav_Syms[] = {
{ "forget", ForgetGravity },
{ "north-west", NorthWestGravity },
{ "north", NorthGravity },
{ "north-east", NorthEastGravity },
{ "west", WestGravity },
{ "center", CenterGravity },
{ "east", EastGravity },
{ "south-west", SouthWestGravity },
{ "south", SouthGravity },
{ "south-east", SouthEastGravity },
{ "static", StaticGravity },
{ 0, 0 }
};
SYMDESCR Grav_Syms[] = {
{ "unmap", UnmapGravity },
{ "north-west", NorthWestGravity },
{ "north", NorthGravity },
{ "north-east", NorthEastGravity },
{ "west", WestGravity },
{ "center", CenterGravity },
{ "east", EastGravity },
{ "south-west", SouthWestGravity },
{ "south", SouthGravity },
{ "south-east", SouthEastGravity },
{ "static", StaticGravity },
{ 0, 0 }
};
SYMDESCR Backing_Store_Syms[] = {
{ "not-useful", NotUseful },
{ "when-mapped", WhenMapped },
{ "always", Always },
{ 0, 0 }
};
SYMDESCR Stack_Mode_Syms[] = {
{ "above", Above },
{ "below", Below },
{ "top-if", TopIf },
{ "bottom-if", BottomIf },
{ "opposite", Opposite },
{ 0, 0 }
};
SYMDESCR Line_Style_Syms[] = {
{ "solid", LineSolid },
{ "dash", LineOnOffDash },
{ "double-dash", LineDoubleDash },
{ 0, 0 }
};
SYMDESCR Cap_Style_Syms[] = {
{ "not-last", CapNotLast },
{ "butt", CapButt },
{ "round", CapRound },
{ "projecting", CapProjecting },
{ 0, 0 }
};
SYMDESCR Join_Style_Syms[] = {
{ "miter", JoinMiter },
{ "round", JoinRound },
{ "bevel", JoinBevel },
{ 0, 0 }
};
SYMDESCR Fill_Style_Syms[] = {
{ "solid", FillSolid },
{ "tiled", FillTiled },
{ "stippled", FillStippled },
{ "opaque-stippled", FillOpaqueStippled },
{ 0, 0 }
};
SYMDESCR Fill_Rule_Syms[] = {
{ "even-odd", EvenOddRule },
{ "winding", WindingRule },
{ 0, 0 }
};
SYMDESCR Arc_Mode_Syms[] = {
{ "chord", ArcChord },
{ "pie-slice", ArcPieSlice },
{ 0, 0 }
};
SYMDESCR Subwin_Mode_Syms[] = {
{ "clip-by-children", ClipByChildren },
{ "include-inferiors", IncludeInferiors },
{ 0, 0 }
};
SYMDESCR Class_Syms[] = {
{ "input-output", InputOutput },
{ "input-only", InputOnly },
{ 0, 0 }
};
SYMDESCR Map_State_Syms[] = {
{ "unmapped", IsUnmapped },
{ "unviewable", IsUnviewable },
{ "viewable", IsViewable },
{ 0, 0 }
};
SYMDESCR State_Syms[] = {
{ "shift", ShiftMask },
{ "lock", LockMask },
{ "control", ControlMask },
{ "mod1", Mod1Mask },
{ "mod2", Mod2Mask },
{ "mod3", Mod3Mask },
{ "mod4", Mod4Mask },
{ "mod5", Mod5Mask },
{ "button1", Button1Mask },
{ "button2", Button2Mask },
{ "button3", Button3Mask },
{ "button4", Button4Mask },
{ "button5", Button5Mask },
{ "any-modifier", AnyModifier },
{ 0, 0 }
};
SYMDESCR Button_Syms[] = {
{ "any-button", AnyButton },
{ "button1", Button1 },
{ "button2", Button2 },
{ "button3", Button3 },
{ "button4", Button4 },
{ "button5", Button5 },
{ 0, 0 }
};
SYMDESCR Cross_Mode_Syms[] = {
{ "normal", NotifyNormal },
{ "grab", NotifyGrab },
{ "ungrab", NotifyUngrab },
{ 0, 0 }
};
SYMDESCR Cross_Detail_Syms[] = {
{ "ancestor", NotifyAncestor },
{ "virtual", NotifyVirtual },
{ "inferior", NotifyInferior },
{ "nonlinear", NotifyNonlinear },
{ "nonlinear-virtual", NotifyNonlinearVirtual },
{ 0, 0 }
};
SYMDESCR Focus_Detail_Syms[] = {
{ "ancestor", NotifyAncestor },
{ "virtual", NotifyVirtual },
{ "inferior", NotifyInferior },
{ "nonlinear", NotifyNonlinear },
{ "nonlinear-virtual", NotifyNonlinearVirtual },
{ "pointer", NotifyPointer },
{ "pointer-root", NotifyPointerRoot },
{ "none", NotifyDetailNone },
{ 0, 0 }
};
SYMDESCR Visibility_Syms[] = {
{ "unobscured", VisibilityUnobscured },
{ "partially-obscured", VisibilityPartiallyObscured },
{ "fully-obscured", VisibilityFullyObscured },
{ 0, 0 }
};
SYMDESCR Place_Syms[] = {
{ "top", PlaceOnTop },
{ "bottom", PlaceOnBottom },
{ 0, 0 }
};
SYMDESCR Prop_Syms[] = {
{ "new-value", PropertyNewValue },
{ "deleted", PropertyDelete },
{ 0, 0 }
};
SYMDESCR Mapping_Syms[] = {
{ "modifier", MappingModifier },
{ "keyboard", MappingKeyboard },
{ "pointer", MappingPointer },
{ 0, 0 }
};
SYMDESCR Direction_Syms[] = {
{ "left-to-right", FontLeftToRight },
{ "right-to-left", FontRightToLeft },
{ 0, 0 }
};
SYMDESCR Polyshape_Syms[] = {
{ "complex", Complex },
{ "non-convex", Nonconvex },
{ "convex", Convex },
{ 0, 0 }
};
SYMDESCR Propmode_Syms[] = {
{ "replace", PropModeReplace },
{ "prepend", PropModePrepend },
{ "append", PropModeAppend },
{ 0, 0 }
};
SYMDESCR Grabstatus_Syms[] = {
{ "success", Success },
{ "not-viewable", GrabNotViewable },
{ "already-grabbed", AlreadyGrabbed },
{ "frozen", GrabFrozen },
{ "invalid-time", GrabInvalidTime },
{ 0, 0 }
};
SYMDESCR Bitmapstatus_Syms[] = {
{ "success", BitmapSuccess },
{ "open-failed", BitmapOpenFailed },
{ "file-invalid", BitmapFileInvalid },
{ "no-memory", BitmapNoMemory },
{ 0, 0 }
};
SYMDESCR Circulate_Syms[] = {
{ "raise-lowest", RaiseLowest },
{ "lower-highest", LowerHighest },
{ 0, 0 }
};
SYMDESCR Allow_Events_Syms[] = {
{ "async-pointer", AsyncPointer },
{ "sync-pointer", SyncPointer },
{ "replay-pointer", ReplayPointer },
{ "async-keyboard", AsyncKeyboard },
{ "sync-keyboard", SyncKeyboard },
{ "replay-keyboard", ReplayKeyboard },
{ "async-both", AsyncBoth },
{ "sync-both", SyncBoth },
{ 0, 0 }
};
SYMDESCR Revert_Syms[] = {
{ "none", RevertToNone },
{ "pointer-root", RevertToPointerRoot },
{ "parent", RevertToParent },
{ 0, 0 }
};
SYMDESCR Shape_Syms[] = {
{ "cursor", CursorShape },
{ "tile", TileShape },
{ "stipple", StippleShape },
{ 0, 0 }
};
SYMDESCR Initial_State_Syms[] = {
{ "dont-care", DontCareState },
{ "normal", NormalState },
{ "zoom", ZoomState },
{ "iconic", IconicState },
{ "inactive", InactiveState },
{ 0, 0 }
};
SYMDESCR Ordering_Syms[] = {
{ "unsorted", Unsorted },
{ "y-sorted", YSorted },
{ "yx-sorted", YXSorted },
{ "yx-banded", YXBanded },
{ 0, 0 }
};
SYMDESCR Byte_Order_Syms[] = {
{ "lsb-first", LSBFirst },
{ "msb-first", MSBFirst },
{ 0, 0 }
};
SYMDESCR Saveset_Syms[] = {
{ "insert", SetModeInsert },
{ "delete", SetModeDelete },
{ 0, 0 }
};
SYMDESCR Closemode_Syms[] = {
{ "destroy-all", DestroyAll },
{ "retain-permanent", RetainPermanent },
{ "retain-temporary", RetainTemporary },
{ 0, 0 }
};
SYMDESCR Event_Syms[] = {
{ "key-press", KeyPressMask },
{ "key-release", KeyReleaseMask },
{ "button-press", ButtonPressMask },
{ "button-release", ButtonReleaseMask },
{ "enter-window", EnterWindowMask },
{ "leave-window", LeaveWindowMask },
{ "pointer-motion", PointerMotionMask },
{ "pointer-motion-hint", PointerMotionHintMask },
{ "button-1-motion", Button1MotionMask },
{ "button-2-motion", Button2MotionMask },
{ "button-3-motion", Button3MotionMask },
{ "button-4-motion", Button4MotionMask },
{ "button-5-motion", Button5MotionMask },
{ "button-motion", ButtonMotionMask },
{ "keymap-state", KeymapStateMask },
{ "exposure", ExposureMask },
{ "visibility-change", VisibilityChangeMask },
{ "structure-notify", StructureNotifyMask },
{ "resize-redirect", ResizeRedirectMask },
{ "substructure-notify", SubstructureNotifyMask },
{ "substructure-redirect", SubstructureRedirectMask },
{ "focus-change", FocusChangeMask },
{ "property-change", PropertyChangeMask },
{ "colormap-change", ColormapChangeMask },
{ "owner-grab-button", OwnerGrabButtonMask },
{ "all-events", ~(unsigned long)0 },
{ 0, 0 }
};
SYMDESCR Error_Syms[] = {
{ "bad-request", BadRequest },
{ "bad-value", BadValue },
{ "bad-window", BadWindow },
{ "bad-pixmap", BadPixmap },
{ "bad-atom", BadAtom },
{ "bad-cursor", BadCursor },
{ "bad-font", BadFont },
{ "bad-match", BadMatch },
{ "bad-drawable", BadDrawable },
{ "bad-access", BadAccess },
{ "bad-alloc", BadAlloc },
{ "bad-color", BadColor },
{ "bad-gcontext", BadGC },
{ "bad-id-choice", BadIDChoice },
{ "bad-name", BadName },
{ "bad-length", BadLength },
{ "bad-implementation", BadImplementation },
{ 0, 0 }
};
static Init_Record (rec, size, name, var) RECORD *rec; char *name;
Object *var; {
Object list, tail, cell;
register i;
char buf[128];
GC_Node2;
GC_Link2 (list, tail);
for (list = tail = Null, i = 1; i < size; tail = cell, i++, rec++) {
cell = Intern (rec->name);
cell = Cons (cell, Make_Integer (i));
cell = Cons (cell, Null);
if (Nullp (list))
list = cell;
else
P_Set_Cdr (tail, cell);
}
sprintf (buf, "%s-slots", name);
Define_Variable (var, buf, list);
GC_Unlink;
}
elk_init_xlib_type () {
Init_Record (Set_Attr_Rec, Set_Attr_Size, "set-window-attributes",
&Set_Attr_Slots);
Init_Record (Conf_Rec, Conf_Size, "window-configuration", &Conf_Slots);
Init_Record (GC_Rec, GC_Size, "gcontext", &GC_Slots);
Init_Record (Geometry_Rec, Geometry_Size, "geometry", &Geometry_Slots);
Init_Record (Win_Attr_Rec, Win_Attr_Size, "get-window-attributes",
&Win_Attr_Slots);
Init_Record (Font_Info_Rec, Font_Info_Size, "font-info", &Font_Info_Slots);
Init_Record (Char_Info_Rec, Char_Info_Size, "char-info", &Char_Info_Slots);
Init_Record (Wm_Hints_Rec, Wm_Hints_Size, "wm-hints", &Wm_Hints_Slots);
Init_Record (Size_Hints_Rec, Size_Hints_Size, "size-hints",
&Size_Hints_Slots);
Define_Symbol (&Sym_Parent_Relative, "parent-relative");
Define_Symbol (&Sym_Copy_From_Parent, "copy-from-parent");
}
--- NEW FILE ---
#include "xlib.h"
static Object P_Get_Default (d, program, option) Object d, program, option; {
register char *ret;
Check_Type (d, T_Display);
if (ret = XGetDefault (DISPLAY(d)->dpy, Get_Strsym (program),
Get_Strsym (option)))
return Make_String (ret, strlen (ret));
return False;
}
static Object P_Resource_Manager_String (d) Object d; {
register char *ret;
Check_Type (d, T_Display);
ret = XResourceManagerString (DISPLAY(d)->dpy);
return ret ? Make_String (ret, strlen (ret)) : False;
}
static Object P_Parse_Geometry (string) Object string; {
Object ret, t;
register mask;
int x, y;
unsigned w, h;
mask = XParseGeometry (Get_Strsym (string), &x, &y, &w, &h);
t = ret = P_Make_List (Make_Integer (6), False);
if (mask & XNegative) Car (t) = True; t = Cdr (t);
if (mask & YNegative) Car (t) = True; t = Cdr (t);
if (mask & XValue) Car (t) = Make_Integer (x); t = Cdr (t);
if (mask & YValue) Car (t) = Make_Integer (y); t = Cdr (t);
if (mask & WidthValue) Car (t) = Make_Unsigned (w); t = Cdr (t);
if (mask & HeightValue) Car (t) = Make_Unsigned (h);
return ret;
}
static Object P_Parse_Color (d, cmap, spec) Object d, cmap, spec; {
XColor ret;
Check_Type (d, T_Display);
if (XParseColor (DISPLAY(d)->dpy, Get_Colormap (cmap), Get_Strsym (spec),
&ret))
return Make_Color (ret.red, ret.green, ret.blue);
return False;
}
elk_init_xlib_util () {
Define_Primitive (P_Get_Default, "get-default", 3, 3, EVAL);
Define_Primitive (P_Resource_Manager_String,
"resource-manager-string", 1, 1, EVAL);
Define_Primitive (P_Parse_Geometry, "parse-geometry", 1, 1, EVAL);
Define_Primitive (P_Parse_Color, "parse-color", 3, 3, EVAL);
}
--- NEW FILE ---
#include "xlib.h"
static Object Sym_Set_Attr, Sym_Get_Attr, Sym_Geo;
Object Sym_Conf;
Generic_Predicate (Window)
Generic_Equal_Dpy (Window, WINDOW, win)
Generic_Print (Window, "#[window %lu]", WINDOW(x)->win)
Generic_Get_Display (Window, WINDOW)
Object Make_Window (finalize, dpy, win) Display *dpy; Window win; {
Object w;
if (win == None)
return Sym_None;
if (win == PointerRoot)
return Intern ("pointer-root");
w = Find_Object (T_Window, (GENERIC)dpy, Match_X_Obj, win);
if (Nullp (w)) {
w = Alloc_Object (sizeof (struct S_Window), T_Window, 0);
WINDOW(w)->tag = Null;
WINDOW(w)->win = win;
WINDOW(w)->dpy = dpy;
WINDOW(w)->free = 0;
WINDOW(w)->finalize = finalize;
Register_Object (w, (GENERIC)dpy, finalize ? P_Destroy_Window :
(PFO)0, 0);
}
return w;
}
Window Get_Window (w) Object w; {
if (EQ(w, Sym_None))
return None;
Check_Type (w, T_Window);
return WINDOW(w)->win;
}
Drawable Get_Drawable (d, dpyp) Object d; Display **dpyp; {
if (TYPE(d) == T_Window) {
*dpyp = WINDOW(d)->dpy;
return (Drawable)WINDOW(d)->win;
} else if (TYPE(d) == T_Pixmap) {
*dpyp = PIXMAP(d)->dpy;
return (Drawable)PIXMAP(d)->pm;
}
Wrong_Type_Combination (d, "drawable");
/*NOTREACHED*/
}
static Object P_Create_Window (parent, x, y, width, height, border_width, attr)
Object parent, x, y, width, height, border_width, attr; {
unsigned long mask;
Window win;
Check_Type (parent, T_Window);
mask = Vector_To_Record (attr, Set_Attr_Size, Sym_Set_Attr, Set_Attr_Rec);
if ((win = XCreateWindow (WINDOW(parent)->dpy, WINDOW(parent)->win,
Get_Integer (x), Get_Integer (y), Get_Integer (width),
Get_Integer (height), Get_Integer (border_width),
CopyFromParent, CopyFromParent, CopyFromParent, mask, &SWA)) == 0)
Primitive_Error ("cannot create window");
return Make_Window (1, WINDOW(parent)->dpy, win);
}
static Object P_Configure_Window (w, conf) Object w, conf; {
unsigned long mask;
Check_Type (w, T_Window);
mask = Vector_To_Record (conf, Conf_Size, Sym_Conf, Conf_Rec);
XConfigureWindow (WINDOW(w)->dpy, WINDOW(w)->win, mask, &WC);
return Void;
}
static Object P_Change_Window_Attributes (w, attr) Object w, attr; {
unsigned long mask;
Check_Type (w, T_Window);
mask = Vector_To_Record (attr, Set_Attr_Size, Sym_Set_Attr, Set_Attr_Rec);
XChangeWindowAttributes (WINDOW(w)->dpy, WINDOW(w)->win, mask, &SWA);
return Void;
}
static Object P_Get_Window_Attributes (w) Object w; {
Check_Type (w, T_Window);
XGetWindowAttributes (WINDOW(w)->dpy, WINDOW(w)->win, &WA);
return Record_To_Vector (Win_Attr_Rec, Win_Attr_Size, Sym_Get_Attr,
WINDOW(w)->dpy, ~0L);
}
static Object P_Get_Geometry (d) Object d; {
Display *dpy;
Drawable dr = Get_Drawable (d, &dpy);
/* GEO.width, GEO.height, etc. should really be unsigned, not int.
*/
XGetGeometry (dpy, dr, &GEO.root, &GEO.x, &GEO.y, (unsigned *)&GEO.width,
(unsigned *)&GEO.height, (unsigned *)&GEO.border_width,
(unsigned *)&GEO.depth);
return Record_To_Vector (Geometry_Rec, Geometry_Size, Sym_Geo, dpy, ~0L);
}
static Object P_Map_Window (w) Object w; {
Check_Type (w, T_Window);
XMapWindow (WINDOW(w)->dpy, WINDOW(w)->win);
return Void;
}
static Object P_Unmap_Window (w) Object w; {
Check_Type (w, T_Window);
XUnmapWindow (WINDOW(w)->dpy, WINDOW(w)->win);
return Void;
}
Object P_Destroy_Window (w) Object w; {
Check_Type (w, T_Window);
if (!WINDOW(w)->free)
XDestroyWindow (WINDOW(w)->dpy, WINDOW(w)->win);
Deregister_Object (w);
WINDOW(w)->free = 1;
return Void;
}
static Object P_Destroy_Subwindows (w) Object w; {
Check_Type (w, T_Window);
XDestroySubwindows (WINDOW(w)->dpy, WINDOW(w)->win);
return Void;
}
static Object P_Map_Subwindows (w) Object w; {
Check_Type (w, T_Window);
XMapSubwindows (WINDOW(w)->dpy, WINDOW(w)->win);
return Void;
}
static Object P_Unmap_Subwindows (w) Object w; {
Check_Type (w, T_Window);
XUnmapSubwindows (WINDOW(w)->dpy, WINDOW(w)->win);
return Void;
}
static Object P_Circulate_Subwindows (w, dir) Object w, dir; {
Check_Type (w, T_Window);
XCirculateSubwindows (WINDOW(w)->dpy, WINDOW(w)->win,
Symbols_To_Bits (dir, 0, Circulate_Syms));
return Void;
}
static Object P_Query_Tree (w) Object w; {
Window root, parent, *children;
Display *dpy;
int i;
unsigned n;
Object v, ret;
GC_Node2;
Check_Type (w, T_Window);
dpy = WINDOW(w)->dpy;
Disable_Interrupts;
XQueryTree (dpy, WINDOW(w)->win, &root, &parent, &children, &n);
Enable_Interrupts;
v = ret = Null;
GC_Link2 (v, ret);
v = Make_Window (0, dpy, root);
ret = Cons (v, Null);
v = Make_Window (0, dpy, parent);
ret = Cons (v, ret);
v = Make_Vector (n, Null);
for (i = 0; i < n; i++) {
Object x;
x = Make_Window (0, dpy, children[i]);
VECTOR(v)->data[i] = x;
}
ret = Cons (v, ret);
GC_Unlink;
return ret;
}
static Object P_Translate_Coordinates (src, x, y, dst) Object src, x, y, dst; {
int rx, ry;
Window child;
Object l, t, z;
GC_Node3;
Check_Type (src, T_Window);
Check_Type (dst, T_Window);
if (!XTranslateCoordinates (WINDOW(src)->dpy, WINDOW(src)->win,
WINDOW(dst)->win, Get_Integer (x), Get_Integer (y), &rx, &ry,
&child))
return False;
l = t = P_Make_List (Make_Integer (3), Null);
GC_Link3 (l, t, dst);
Car (t) = Make_Integer (rx); t = Cdr (t);
Car (t) = Make_Integer (ry), t = Cdr (t);
z = Make_Window (0, WINDOW(dst)->dpy, child);
Car (t) = z;
GC_Unlink;
return l;
}
static Object P_Query_Pointer (win) Object win; {
Object l, t, z;
Bool ret;
Window root, child;
int r_x, r_y, x, y;
unsigned int mask;
GC_Node3;
Check_Type (win, T_Window);
ret = XQueryPointer (WINDOW(win)->dpy, WINDOW(win)->win, &root, &child,
&r_x, &r_y, &x, &y, &mask);
t = l = P_Make_List (Make_Integer (8), Null);
GC_Link3 (l, t, win);
Car (t) = Make_Integer (x); t = Cdr (t);
Car (t) = Make_Integer (y); t = Cdr (t);
Car (t) = ret ? True : False; t = Cdr (t);
z = Make_Window (0, WINDOW(win)->dpy, root);
Car (t) = z; t = Cdr (t);
Car (t) = Make_Integer (r_x); t = Cdr (t);
Car (t) = Make_Integer (r_y); t = Cdr (t);
z = Make_Window (0, WINDOW(win)->dpy, child);
Car (t) = z; t = Cdr (t);
z = Bits_To_Symbols ((unsigned long)mask, 1, State_Syms);
Car (t) = z;
GC_Unlink;
return l;
}
elk_init_xlib_window () {
Define_Symbol (&Sym_Set_Attr, "set-window-attributes");
Define_Symbol (&Sym_Get_Attr, "get-window-attributes");
Define_Symbol (&Sym_Conf, "window-configuration");
Define_Symbol (&Sym_Geo, "geometry");
Generic_Define (Window, "window", "window?");
Define_Primitive (P_Window_Display, "window-display", 1, 1, EVAL);
Define_Primitive (P_Create_Window,
"xlib-create-window", 7, 7, EVAL);
Define_Primitive (P_Configure_Window,
"xlib-configure-window", 2, 2, EVAL);
Define_Primitive (P_Change_Window_Attributes,
"xlib-change-window-attributes", 2, 2, EVAL);
Define_Primitive (P_Get_Window_Attributes,
"xlib-get-window-attributes", 1, 1, EVAL);
Define_Primitive (P_Get_Geometry, "xlib-get-geometry",1, 1, EVAL);
Define_Primitive (P_Map_Window, "map-window", 1, 1, EVAL);
Define_Primitive (P_Unmap_Window, "unmap-window", 1, 1, EVAL);
Define_Primitive (P_Circulate_Subwindows,
"circulate-subwindows", 2, 2, EVAL);
Define_Primitive (P_Destroy_Window, "destroy-window", 1, 1, EVAL);
Define_Primitive (P_Destroy_Subwindows,
"destroy-subwindows", 1, 1, EVAL);
Define_Primitive (P_Map_Subwindows, "map-subwindows", 1, 1, EVAL);
Define_Primitive (P_Unmap_Subwindows, "unmap-subwindows", 1, 1, EVAL);
Define_Primitive (P_Query_Tree, "query-tree", 1, 1, EVAL);
Define_Primitive (P_Translate_Coordinates,
"translate-coordinates", 4, 4, EVAL);
Define_Primitive (P_Query_Pointer, "query-pointer", 1, 1, EVAL);
}
--- NEW FILE ---
#include "xlib.h"
static Object Sym_Pointer_Root;
static Object P_Reparent_Window (w, parent, x, y) Object w, parent, x, y; {
Check_Type (w, T_Window);
Check_Type (parent, T_Window);
XReparentWindow (WINDOW(w)->dpy, WINDOW(w)->win, WINDOW(parent)->win,
Get_Integer (x), Get_Integer (y));
return Void;
}
static Object P_Install_Colormap (c) Object c; {
Check_Type (c, T_Colormap);
XInstallColormap (COLORMAP(c)->dpy, COLORMAP(c)->cm);
return Void;
}
static Object P_Uninstall_Colormap (c) Object c; {
Check_Type (c, T_Colormap);
XUninstallColormap (COLORMAP(c)->dpy, COLORMAP(c)->cm);
return Void;
}
static Object P_List_Installed_Colormaps (w) Object w; {
int i, n;
Colormap *ret;
Object v;
GC_Node;
Check_Type (w, T_Window);
ret = XListInstalledColormaps (WINDOW(w)->dpy, WINDOW(w)->win, &n);
v = Make_Vector (n, Null);
GC_Link (v);
for (i = 0; i < n; i++) {
Object c;
c = Make_Colormap (0, WINDOW(w)->dpy, ret[i]);
VECTOR(v)->data[i] = c;
}
XFree ((char *)ret);
GC_Unlink;
return v;
}
static Object P_Set_Input_Focus (d, win, revert_to, time) Object d, win,
revert_to, time; {
Window focus = PointerRoot;
Check_Type (d, T_Display);
if (!EQ(win, Sym_Pointer_Root))
focus = Get_Window (win);
XSetInputFocus (DISPLAY(d)->dpy, focus, Symbols_To_Bits (revert_to, 0,
Revert_Syms), Get_Time (time));
return Void;
}
static Object P_Input_Focus (d) Object d; {
Window win;
int revert_to;
Object ret, x;
GC_Node;
Check_Type (d, T_Display);
XGetInputFocus (DISPLAY(d)->dpy, &win, &revert_to);
ret = Cons (Null, Null);
GC_Link (ret);
x = Make_Window (0, DISPLAY(d)->dpy, win);
Car (ret) = x;
x = Bits_To_Symbols ((unsigned long)revert_to, 0, Revert_Syms);
Cdr (ret) = x;
GC_Unlink;
return ret;
}
static Object P_General_Warp_Pointer (dpy, dst, dstx, dsty, src, srcx, srcy,
srcw, srch) Object dpy, dst, dstx, dsty, src, srcx, srcy, srcw, srch; {
Check_Type (dpy, T_Display);
XWarpPointer (DISPLAY(dpy)->dpy, Get_Window (src), Get_Window (dst),
Get_Integer (srcx), Get_Integer (srcy), Get_Integer (srcw),
Get_Integer (srch), Get_Integer (dstx), Get_Integer (dsty));
return Void;
}
static Object P_Bell (argc, argv) Object *argv; {
register percent = 0;
Check_Type (argv[0], T_Display);
if (argc == 2) {
percent = Get_Integer (argv[1]);
if (percent < -100 || percent > 100)
Range_Error (argv[1]);
}
XBell (DISPLAY(argv[0])->dpy, percent);
return Void;
}
static Object P_Set_Access_Control (dpy, on) Object dpy, on; {
Check_Type (dpy, T_Display);
Check_Type (on, T_Boolean);
XSetAccessControl (DISPLAY(dpy)->dpy, EQ(on, True));
return Void;
}
static Object P_Change_Save_Set (win, mode) Object win, mode; {
Check_Type (win, T_Window);
XChangeSaveSet (WINDOW(win)->dpy, WINDOW(win)->win,
Symbols_To_Bits (mode, 0, Saveset_Syms));
return Void;
}
static Object P_Set_Close_Down_Mode (dpy, mode) Object dpy, mode; {
Check_Type (dpy, T_Display);
XSetCloseDownMode (DISPLAY(dpy)->dpy,
Symbols_To_Bits (mode, 0, Closemode_Syms));
return Void;
}
static Object P_Get_Pointer_Mapping (dpy) Object dpy; {
unsigned char map[256];
register i, n;
Object ret;
Check_Type (dpy, T_Display);
n = XGetPointerMapping (DISPLAY(dpy)->dpy, map, 256);
ret = Make_Vector (n, Null);
for (i = 0; i < n; i++)
VECTOR(ret)->data[i] = Make_Integer (map[i]);
return ret;
}
static Object P_Set_Pointer_Mapping (dpy, map) Object dpy, map; {
register i, n;
register unsigned char *p;
Object ret;
Alloca_Begin;
Check_Type (dpy, T_Display);
Check_Type (map, T_Vector);
n = VECTOR(map)->size;
Alloca (p, unsigned char*, n);
for (i = 0; i < n; i++)
p[i] = Get_Integer (VECTOR(map)->data[i]);
ret = XSetPointerMapping (DISPLAY(dpy)->dpy, p, n) == MappingSuccess ?
True : False;
Alloca_End;
return ret;
}
elk_init_xlib_wm () {
Define_Primitive (P_Reparent_Window, "reparent-window", 4, 4, EVAL);
Define_Primitive (P_Install_Colormap, "install-colormap", 1, 1, EVAL);
Define_Primitive (P_Uninstall_Colormap,
"uninstall-colormap", 1, 1, EVAL);
Define_Primitive (P_List_Installed_Colormaps,
"list-installed-colormaps", 1, 1, EVAL);
Define_Primitive (P_Set_Input_Focus, "set-input-focus", 4, 4, EVAL);
Define_Primitive (P_Input_Focus, "input-focus", 1, 1, EVAL);
Define_Primitive (P_General_Warp_Pointer,
"general-warp-pointer", 9, 9, EVAL);
Define_Primitive (P_Bell, "bell", 1, 2, VARARGS);
Define_Primitive (P_Set_Access_Control,
"set-access-control", 2, 2, EVAL);
Define_Primitive (P_Change_Save_Set, "change-save-set", 2, 2, EVAL);
Define_Primitive (P_Set_Close_Down_Mode,
"set-close-down-mode", 2, 2, EVAL);
Define_Primitive (P_Get_Pointer_Mapping,
"get-pointer-mapping", 1, 1, EVAL);
Define_Primitive (P_Set_Pointer_Mapping,
"set-pointer-mapping", 2, 2, EVAL);
Define_Symbol(&Sym_Pointer_Root, "pointer-root");
}
--- NEW FILE ---
#include <X11/X.h>
#include <X11/Xlib.h>
#include <X11/Xutil.h>
#undef True
#undef False
#ifndef NeedFunctionPrototypes /* Kludge */
#error "X11 Release 3 (or earlier) no longer supported"
#endif
#if XlibSpecificationRelease >= 5
# define XLIB_RELEASE_5_OR_LATER
#endif
#if XlibSpecificationRelease >= 6
# define XLIB_RELEASE_6_OR_LATER
#endif
#include "scheme.h"
extern int T_Display;
extern int T_Gc;
extern int T_Pixel;
extern int T_Pixmap;
extern int T_Window;
extern int T_Font;
extern int T_Colormap;
extern int T_Color;
extern int T_Cursor;
extern int T_Atom;
#define DISPLAY(x) ((struct S_Display *)POINTER(x))
#define GCONTEXT(x) ((struct S_Gc *)POINTER(x))
#define PIXEL(x) ((struct S_Pixel *)POINTER(x))
#define PIXMAP(x) ((struct S_Pixmap *)POINTER(x))
#define WINDOW(x) ((struct S_Window *)POINTER(x))
#define FONT(x) ((struct S_Font *)POINTER(x))
#define COLORMAP(x) ((struct S_Colormap *)POINTER(x))
#define COLOR(x) ((struct S_Color *)POINTER(x))
#define CURSOR(x) ((struct S_Cursor *)POINTER(x))
#define ATOM(x) ((struct S_Atom *)POINTER(x))
struct S_Display {
Object after;
Display *dpy;
char free;
};
struct S_Gc {
Object tag;
GC gc;
Display *dpy;
char free;
};
struct S_Pixel {
Object tag;
unsigned long pix;
};
struct S_Pixmap {
Object tag;
Pixmap pm;
Display *dpy;
char free;
};
struct S_Window {
Object tag;
Window win;
Display *dpy;
char free;
char finalize;
};
struct S_Font {
Object name;
Font id;
XFontStruct *info;
Display *dpy;
};
struct S_Colormap {
Object tag;
Colormap cm;
Display *dpy;
char free;
};
struct S_Color {
Object tag;
XColor c;
};
struct S_Cursor {
Object tag;
Cursor cursor;
Display *dpy;
char free;
};
struct S_Atom {
Object tag;
Atom atom;
};
enum Type {
T_NONE,
T_INT, T_CHAR, T_PIXEL, T_PIXMAP, T_BOOL, T_FONT, T_COLORMAP, T_CURSOR,
T_WINDOW, T_MASK, T_SYM, T_SHORT, T_BACKGROUND, T_BORDER
};
typedef struct {
char *slot;
char *name;
enum Type type;
SYMDESCR *syms;
int mask;
} RECORD;
typedef struct {
Window root;
int x, y, width, height, border_width, depth;
} GEOMETRY;
C_LINKAGE_BEGIN
extern Colormap Get_Colormap P_((Object));
extern Cursor Get_Cursor P_((Object));
extern Drawable Get_Drawable P_((Object, Display**));
extern Font Get_Font P_((Object));
extern int Get_Screen_Number P_((Display*, Object));
extern Object Get_Event_Args P_((XEvent*));
extern Pixmap Get_Pixmap P_((Object));
extern Time Get_Time P_((Object));
extern Window Get_Window P_((Object));
extern XColor *Get_Color P_((Object));
extern unsigned long Get_Pixel P_((Object));
extern void Destroy_Event_Args P_((Object));
extern int Encode_Event P_((Object));
extern int Match_X_Obj P_((ELLIPSIS));
extern void Open_Font_Maybe P_((Object));
extern Object Make_Atom P_((Atom));
extern Object Make_Color P_((unsigned int, unsigned int, unsigned int));
extern Object Make_Colormap P_((int, Display*, Colormap));
extern Object Make_Cursor P_((Display*, Cursor));
extern Object Make_Cursor_Foreign P_((Display*, Cursor));
extern Object Make_Display P_((int, Display*));
extern Object Make_Font P_((Display*, Object, Font, XFontStruct*));
extern Object Make_Font_Foreign P_((Display*, Object, Font, XFontStruct*));
extern Object Make_Gc P_((int, Display*, GC));
extern Object Make_Pixel P_((unsigned long));
extern Object Make_Pixmap P_((Display*, Pixmap));
extern Object Make_Pixmap_Foreign P_((Display*, Pixmap));
extern Object Make_Window P_((int, Display*, Window));
extern Object P_Close_Display P_((Object));
extern Object P_Close_Font P_((Object));
extern Object P_Destroy_Window P_((Object));
extern Object P_Free_Colormap P_((Object));
extern Object P_Free_Cursor P_((Object));
extern Object P_Free_Gc P_((Object));
extern Object P_Free_Pixmap P_((Object));
extern Object P_Window_Unique_Id P_((Object));
extern Object Record_To_Vector
P_((RECORD*, int, Object, Display*, unsigned long));
extern unsigned long Vector_To_Record P_((Object, int, Object, RECORD*));
C_LINKAGE_END
extern XSetWindowAttributes SWA;
extern XWindowChanges WC;
extern XGCValues GCV;
extern GEOMETRY GEO;
extern XWindowAttributes WA;
extern XFontStruct FI;
extern XCharStruct CI;
extern XWMHints WMH;
extern XSizeHints SZH;
extern Set_Attr_Size, Conf_Size, GC_Size, Geometry_Size, Win_Attr_Size,
Font_Info_Size, Char_Info_Size, Wm_Hints_Size, Size_Hints_Size;
extern RECORD Set_Attr_Rec[], Conf_Rec[], GC_Rec[], Geometry_Rec[],
Win_Attr_Rec[], Font_Info_Rec[], Char_Info_Rec[], Wm_Hints_Rec[],
Size_Hints_Rec[];
extern SYMDESCR Func_Syms[], Bit_Grav_Syms[], Event_Syms[], Error_Syms[],
Grav_Syms[], Backing_Store_Syms[], Class_Syms[], Stack_Mode_Syms[],
Line_Style_Syms[], State_Syms[], Cap_Style_Syms[], Join_Style_Syms[],
Map_State_Syms[], Fill_Style_Syms[], Fill_Rule_Syms[], Arc_Mode_Syms[],
Subwin_Mode_Syms[], Button_Syms[], Cross_Mode_Syms[], Cross_Detail_Syms[],
Focus_Detail_Syms[], Place_Syms[], Visibility_Syms[], Prop_Syms[],
Mapping_Syms[], Direction_Syms[], Shape_Syms[], Propmode_Syms[],
Grabstatus_Syms[], Allow_Events_Syms[], Revert_Syms[], Polyshape_Syms[],
Initial_State_Syms[], Bitmapstatus_Syms[], Circulate_Syms[],
Ordering_Syms[], Byte_Order_Syms[], Saveset_Syms[], Closemode_Syms[];
extern Object Sym_None, Sym_Now, Sym_Char_Info, Sym_Conf;
#if __STDC__ || defined(ANSI_CPP)
# define conc(a,b) a##b
# define conc3(a,b,c) a##b##c
#else
# define _identity(x) x
# define conc(a,b) _identity(a)b
# define conc3(a,b,c) conc(conc(a,b),c)
#endif
/* Generic_Predicate (Pixmap) generates:
*
* int T_Pixmap;
*
* static Object P_Pixmapp (x) Object x; {
* return TYPE(x) == T_Pixmap ? True : False;
* }
*/
#define Generic_Predicate(type) int conc(T_,type);\
\
static Object conc3(P_,type,p) (x) Object x; {\
return TYPE(x) == conc(T_,type) ? True : False;\
}
/* Generic_Equal (Pixmap, PIXMAP, pm) generates:
*
* static Pixmap_Equal (x, y) Object x, y; {
* return PIXMAP(x)->pm == PIXMAP(y)->field
* && !PIXMAP(x)->free && !PIXMAP(y)->free;
* }
*/
#define Generic_Equal(type,cast,field) static conc(type,_Equal) (x, y)\
Object x, y; {\
return cast(x)->field == cast(y)->field\
&& !cast(x)->free && !cast(y)->free;\
}
/* Same as above, but doesn't check for ->free:
*/
#define Generic_Simple_Equal(type,cast,field) static conc(type,_Equal) (x, y)\
Object x, y; {\
return cast(x)->field == cast(y)->field;\
}
/* Same as above, but also checks ->dpy
*/
#define Generic_Equal_Dpy(type,cast,field) static conc(type,_Equal)\
(x, y)\
Object x, y; {\
return cast(x)->field == cast(y)->field && cast(x)->dpy == cast(y)->dpy\
&& !cast(x)->free && !cast(y)->free;\
}
/* Generic_Print (Pixmap, "#[pixmap %u]", PIXMAP(x)->pm) generates:
*
* static Pixmap_Print (x, port, raw, depth, len) Object x, port; {
* Printf (port, "#[pixmap %u]", PIXMAP(x)->pm);
* }
*/
#define Generic_Print(type,fmt,how) static conc(type,_Print)\
(x, port, raw, depth, len) Object x, port; {\
Printf (port, fmt, (unsigned)how);\
}
/* Generic_Define (Pixmap, "pixmap", "pixmap?") generates:
*
* T_Pixmap = Define_Type (0, "pixmap", NOFUNC, sizeof (struct S_Pixmap),
* Pixmap_Equal, Pixmap_Equal, Pixmap_Print, NOFUNC);
* Define_Primitive (P_Pixmapp, "pixmap?", 1, 1, EVAL);
*/
#define Generic_Define(type,name,pred) conc(T_,type) =\
Define_Type (0, name, NOFUNC, sizeof (struct conc(S_,type)),\
conc(type,_Equal), conc(type,_Equal), conc(type,_Print), NOFUNC);\
Define_Primitive (conc3(P_,type,p), pred, 1, 1, EVAL);
/* Generic_Get_Display (Pixmap, PIXMAP) generates:
*
* static Object P_Pixmap_Display (x) Object x; {
* Check_Type (x, T_Pixmap);
* return Make_Display (PIXMAP(x)->dpy);
* }
*/
#define Generic_Get_Display(type,cast) static Object conc3(P_,type,_Display)\
(x) Object x; {\
Check_Type (x, conc(T_,type));\
return Make_Display (0, cast(x)->dpy);\
}
|