commit f4b9866a6b7bf66980739e934f1b51c7121a7444 Author: frese Date: Tue May 8 14:21:00 2001 +0000 Unmodified C files from elk. diff --git a/.gitignore b/.gitignore new file mode 100644 index 0000000..da8168b --- /dev/null +++ b/.gitignore @@ -0,0 +1,28 @@ +# CVS default ignores begin +tags +TAGS +.make.state +.nse_depinfo +*~ +\#* +.#* +,* +_$* +*$ +*.old +*.bak +*.BAK +*.orig +*.rej +.del-* +*.a +*.olb +*.o +*.obj +*.so +*.exe +*.Z +*.elc +*.ln +core +# CVS default ignores end diff --git a/c/xlib/client.c b/c/xlib/client.c new file mode 100644 index 0000000..e110b14 --- /dev/null +++ b/c/xlib/client.c @@ -0,0 +1,390 @@ +#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); +} diff --git a/c/xlib/color.c b/c/xlib/color.c new file mode 100644 index 0000000..634aaa5 --- /dev/null +++ b/c/xlib/color.c @@ -0,0 +1,129 @@ +#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); +} diff --git a/c/xlib/colormap.c b/c/xlib/colormap.c new file mode 100644 index 0000000..c1b75da --- /dev/null +++ b/c/xlib/colormap.c @@ -0,0 +1,88 @@ +#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); +} diff --git a/c/xlib/cursor.c b/c/xlib/cursor.c new file mode 100644 index 0000000..e5066a8 --- /dev/null +++ b/c/xlib/cursor.c @@ -0,0 +1,91 @@ +#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); +} diff --git a/c/xlib/display.c b/c/xlib/display.c new file mode 100644 index 0000000..885a3a6 --- /dev/null +++ b/c/xlib/display.c @@ -0,0 +1,308 @@ +#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); +} diff --git a/c/xlib/error.c b/c/xlib/error.c new file mode 100644 index 0000000..4bc4084 --- /dev/null +++ b/c/xlib/error.c @@ -0,0 +1,92 @@ +#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); +} diff --git a/c/xlib/event.c b/c/xlib/event.c new file mode 100644 index 0000000..4aa721b --- /dev/null +++ b/c/xlib/event.c @@ -0,0 +1,514 @@ +#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); +} diff --git a/c/xlib/extension.c b/c/xlib/extension.c new file mode 100644 index 0000000..1013a44 --- /dev/null +++ b/c/xlib/extension.c @@ -0,0 +1,48 @@ +#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); +} diff --git a/c/xlib/font.c b/c/xlib/font.c new file mode 100644 index 0000000..f28d4f3 --- /dev/null +++ b/c/xlib/font.c @@ -0,0 +1,299 @@ +#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); +} diff --git a/c/xlib/gcontext.c b/c/xlib/gcontext.c new file mode 100644 index 0000000..e1ffbc5 --- /dev/null +++ b/c/xlib/gcontext.c @@ -0,0 +1,162 @@ +#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); +} diff --git a/c/xlib/grab.c b/c/xlib/grab.c new file mode 100644 index 0000000..4d9c8cb --- /dev/null +++ b/c/xlib/grab.c @@ -0,0 +1,138 @@ +#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"); +} diff --git a/c/xlib/graphics.c b/c/xlib/graphics.c new file mode 100644 index 0000000..648b0e0 --- /dev/null +++ b/c/xlib/graphics.c @@ -0,0 +1,267 @@ +#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); +} diff --git a/c/xlib/init.c b/c/xlib/init.c new file mode 100644 index 0000000..a259842 --- /dev/null +++ b/c/xlib/init.c @@ -0,0 +1,50 @@ +#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 diff --git a/c/xlib/key.c b/c/xlib/key.c new file mode 100644 index 0000000..9f269c2 --- /dev/null +++ b/c/xlib/key.c @@ -0,0 +1,159 @@ +#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); +} diff --git a/c/xlib/objects.c b/c/xlib/objects.c new file mode 100644 index 0000000..b70b869 --- /dev/null +++ b/c/xlib/objects.c @@ -0,0 +1,38 @@ +#include + +#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"); +} diff --git a/c/xlib/pixel.c b/c/xlib/pixel.c new file mode 100644 index 0000000..d004995 --- /dev/null +++ b/c/xlib/pixel.c @@ -0,0 +1,48 @@ +#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); +} diff --git a/c/xlib/pixmap.c b/c/xlib/pixmap.c new file mode 100644 index 0000000..4d1aaa0 --- /dev/null +++ b/c/xlib/pixmap.c @@ -0,0 +1,148 @@ +#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); +} diff --git a/c/xlib/property.c b/c/xlib/property.c new file mode 100644 index 0000000..9bf5c47 --- /dev/null +++ b/c/xlib/property.c @@ -0,0 +1,250 @@ +#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); +} diff --git a/c/xlib/text.c b/c/xlib/text.c new file mode 100644 index 0000000..cc3c2b9 --- /dev/null +++ b/c/xlib/text.c @@ -0,0 +1,180 @@ +#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"); +} diff --git a/c/xlib/type.c b/c/xlib/type.c new file mode 100644 index 0000000..06d3832 --- /dev/null +++ b/c/xlib/type.c @@ -0,0 +1,803 @@ +#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"); +} diff --git a/c/xlib/util.c b/c/xlib/util.c new file mode 100644 index 0000000..4107cad --- /dev/null +++ b/c/xlib/util.c @@ -0,0 +1,54 @@ +#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); +} diff --git a/c/xlib/window.c b/c/xlib/window.c new file mode 100644 index 0000000..de02e8d --- /dev/null +++ b/c/xlib/window.c @@ -0,0 +1,262 @@ +#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); +} diff --git a/c/xlib/wm.c b/c/xlib/wm.c new file mode 100644 index 0000000..e26e963 --- /dev/null +++ b/c/xlib/wm.c @@ -0,0 +1,172 @@ +#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"); +} diff --git a/c/xlib/xlib.h b/c/xlib/xlib.h new file mode 100644 index 0000000..41b5958 --- /dev/null +++ b/c/xlib/xlib.h @@ -0,0 +1,287 @@ +#include +#include +#include + +#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);\ +}