From decwrl!sun-barr!cs.utexas.edu!uunet!allbery Fri Sep 29 09:58:08 PDT 1989 Article 1102 of comp.sources.misc: Path: decwrl!sun-barr!cs.utexas.edu!uunet!allbery From: allbery@uunet.UU.NET (Brandon S. Allbery - comp.sources.misc) Newsgroups: comp.sources.misc Subject: v08i060: Elk (Extension Language Toolkit) part 12 of 14 Message-ID: <68228@uunet.UU.NET> Date: 23 Sep 89 21:43:46 GMT Sender: allbery@uunet.UU.NET Reply-To: net@tub.UUCP (Oliver Laumann) Lines: 1887 Approved: allbery@uunet.UU.NET (Brandon S. Allbery - comp.sources.misc) Posting-number: Volume 8, Issue 60 Submitted-by: net@tub.UUCP (Oliver Laumann) Archive-name: elk/part12 [Let this be a lesson to submitters: this was submitted as uuencoded, compressed files. I lost the source information while unpacking it; this is the best approximation I could come up with. ++bsa] #! /bin/sh # This is a shell archive. Remove anything before this line, then unpack # it by saving it into a file and typing "sh file". To overwrite existing # files, type "sh file -c". You can also feed this as standard input via # unshar, or by typing "sh lib/xlib/property.c <<'END_OF_lib/xlib/property.c' X#include "xlib.h" X XObject Sym_Now; X XGeneric_Predicate (Atom); X XGeneric_Simple_Equal (Atom, ATOM, atom); X XGeneric_Print (Atom, "#[atom %u]", ATOM(x)->atom); X XObject Make_Atom (a) Atom a; { X register char *p; X Object atom; X X if (a == None) X return Sym_None; X atom = Find_Object (T_Atom, (GENERIC)0, Match_X_Obj, a); X if (Nullp (atom)) { X p = Get_Bytes (sizeof (struct S_Atom)); X SET (atom, T_Atom, (struct S_Atom *)p); X ATOM(atom)->tag = Null; X ATOM(atom)->atom = a; X Register_Object (atom, (GENERIC)0, (PFO)0, 0); X } X return atom; X} X Xstatic Object P_Make_Atom (n) Object n; { /* For debugging */ X return Make_Atom ((Atom)Get_Integer (n)); X} X Xstatic Object Internal_Intern_Atom (d, name, flag) Object d, name; { X register char *s; X X Check_Type (d, T_Display); X Make_C_String (name, s); X return Make_Atom (XInternAtom (DISPLAY(d)->dpy, s, flag)); X} X Xstatic Object P_Intern_Atom (d, name) Object d, name; { X return Internal_Intern_Atom (d, name, 0); X} X Xstatic Object P_Find_Atom (d, name) Object d, name; { X return Internal_Intern_Atom (d, name, 1); X} X Xstatic Object P_Atom_Name (d, a) Object d, a; { X register char *s; X X Check_Type (d, T_Display); X Check_Type (a, T_Atom); X Disable_Interrupts; X s = XGetAtomName (DISPLAY(d)->dpy, ATOM(a)->atom); X Enable_Interrupts; X return Make_String (s, strlen (s)); X} X Xstatic Object P_List_Properties (w) Object w; { X register i; X int n; X register Atom *ap; X Object v; X GC_Node; X X Check_Type (w, T_Window); X Disable_Interrupts; X ap = XListProperties (WINDOW(w)->dpy, WINDOW(w)->win, &n); X Enable_Interrupts; X v = Make_Vector (n, Null); X GC_Link (v); X for (i = 0; i < n; i++) { X Object x = Make_Atom (ap[i]); X VECTOR(v)->data[i] = x; X } X GC_Unlink; X XFree ((char *)ap); X return v; X} X Xstatic Object P_Get_Property (w, prop, type, start, len, deletep) X Object w, prop, type, start, len, deletep; { X Atom req_type = AnyPropertyType, actual_type; X int format; X unsigned long nitems, bytes_left; X unsigned char *data; X Object ret, t, x; X register i; X GC_Node2; X X Check_Type (w, T_Window); X Check_Type (prop, T_Atom); X if (!EQ(type, False)) { X Check_Type (type, T_Atom); X req_type = ATOM(type)->atom; X } X Check_Type (deletep, T_Boolean); X Disable_Interrupts; X if (XGetWindowProperty (WINDOW(w)->dpy, WINDOW(w)->win, ATOM(prop)->atom, X (long)Get_Integer (start), (long)Get_Integer (len), X EQ(deletep, True), req_type, &actual_type, &format, X &nitems, &bytes_left, &data) != Success) X Primitive_Error ("cannot get property"); X Enable_Interrupts; X ret = t = P_Make_List (Make_Fixnum (4), Null); X GC_Link2 (ret, t); X x = Make_Atom (actual_type); X Car (t) = x; t = Cdr (t); X x = Make_Integer (format); X Car (t) = x; t = Cdr (t); X if (nitems) { X if (format == 8) { X Object s; X x = Make_String ((char *)0, (int)nitems); X s = Car (t) = x; X bcopy (data, STRING(s)->data, (int)nitems); X } else { X Object v = Make_Vector ((int)nitems, Null); X GC_Node; X /* Assumes short is 16 bits and int is 32 bits. X */ X GC_Link (v); X for (i = 0; i < nitems; i++) { X x = Make_Integer (format == 16 ? X *((short *)data + i) : *((int *)data + i)); X VECTOR(v)->data[i] = x; X } X Car (t) = v; X GC_Unlink; X } X } X t = Cdr (t); X x = Make_Unsigned ((unsigned)bytes_left); X Car (t) = x; X GC_Unlink; X return ret; X} X Xstatic Object P_Change_Property (w, prop, type, format, mode, data) X Object w, prop, type, format, mode, data; { X register i, m, x, nitems, f; X char *buf; X X Check_Type (w, T_Window); X Check_Type (prop, T_Atom); X Check_Type (type, T_Atom); X m = Symbols_To_Bits (mode, 0, Propmode_Syms); X switch (f = Get_Integer (format)) { X case 8: X Check_Type (data, T_String); X buf = STRING(data)->data; X nitems = STRING(data)->size; X break; X case 16: case 32: X Check_Type (data, T_Vector); X nitems = VECTOR(data)->size; X buf = alloca (nitems * (f / sizeof (char))); X for (i = 0; i < nitems; i++) { X x = Get_Integer (VECTOR(data)->data[i]); X if (f == 16) { X if (x > 65535) X Primitive_Error ("format mismatch"); X *((short *)buf + i) = x; /* Assumes short is 16 bits */ X } else *((int *)buf + i) = x; /* and int is 32 bits. */ X } X break; X default: X Primitive_Error ("invalid format: ~s", format); X } X XChangeProperty (WINDOW(w)->dpy, WINDOW(w)->win, ATOM(prop)->atom, X ATOM(type)->atom, f, m, buf, nitems); X return Void; X} X Xstatic Object P_Delete_Property (w, prop) Object w, prop; { X Check_Type (w, T_Window); X Check_Type (prop, T_Atom); X XDeleteProperty (WINDOW(w)->dpy, WINDOW(w)->win, ATOM(prop)->atom); X return Void; X} X Xstatic Object P_Rotate_Properties (w, v, delta) Object w, v, delta; { X Atom *p; X register i, n; X X Check_Type (w, T_Window); X Check_Type (v, T_Vector); X n = VECTOR(v)->size; X p = (Atom *)alloca (n * sizeof (Atom)); X for (i = 0; i < n; i++) { X Object a = VECTOR(v)->data[i]; X Check_Type (a, T_Atom); X p[i] = ATOM(a)->atom; X } X XRotateWindowProperties (WINDOW(w)->dpy, WINDOW(w)->win, p, n, X Get_Integer (delta)); X return Void; X} X Xstatic Object P_Set_Selection_Owner (d, s, owner, time) Object d, s, owner, X time; { X Check_Type (d, T_Display); X Check_Type (s, T_Atom); X XSetSelectionOwner (DISPLAY(d)->dpy, ATOM(s)->atom, Get_Window (owner), X Get_Time (time)); X return Void; X} X Xstatic Object P_Selection_Owner (d, s) Object d, s; { X Check_Type (d, T_Display); X Check_Type (s, T_Atom); X return Make_Window (0, DISPLAY(d)->dpy, X XGetSelectionOwner (DISPLAY(d)->dpy, ATOM(s)->atom)); X} X Xstatic Object P_Convert_Selection (s, target, prop, w, time) X Object s, target, prop, w, time; { X Atom p = None; X X Check_Type (s, T_Atom); X Check_Type (target, T_Atom); X if (!EQ(prop, Sym_None)) { X Check_Type (prop, T_Atom); X p = ATOM(prop)->atom; X } X Check_Type (w, T_Window); X XConvertSelection (WINDOW(w)->dpy, ATOM(s)->atom, ATOM(target)->atom, X p, WINDOW(w)->win, Get_Time (time)); X return Void; X} X Xinit_xlib_property () { X Define_Symbol (&Sym_Now, "now"); X Generic_Define (Atom, "atom", "atom?"); X Define_Primitive (P_Make_Atom, "make-atom", 1, 1, EVAL); X Define_Primitive (P_Intern_Atom, "intern-atom", 2, 2, EVAL); X Define_Primitive (P_Find_Atom, "find-atom", 2, 2, EVAL); X Define_Primitive (P_Atom_Name, "atom-name", 2, 2, EVAL); X Define_Primitive (P_List_Properties, "list-properties", 1, 1, EVAL); X Define_Primitive (P_Get_Property, "get-property", 6, 6, EVAL); X Define_Primitive (P_Change_Property, "change-property", 6, 6, EVAL); X Define_Primitive (P_Delete_Property, "delete-property", 2, 2, EVAL); X Define_Primitive (P_Rotate_Properties, "rotate-properties", 3, 3, EVAL); X Define_Primitive (P_Set_Selection_Owner, "set-selection-owner!", X 4, 4, EVAL); X Define_Primitive (P_Selection_Owner, "selection-owner", 2, 2, EVAL); X Define_Primitive (P_Convert_Selection, "convert-selection", 5, 5, EVAL); X} END_OF_lib/xlib/property.c if test 7184 -ne `wc -c lib/xlib/pointer.c <<'END_OF_lib/xlib/pointer.c' X#include "xlib.h" X Xstatic Object Sym_Any; X XTime Get_Time (time) Object time; { X if (EQ(time, Sym_Now)) X return CurrentTime; X return (Time)Get_Integer (time); X} X Xstatic Get_Mode (m) Object m; { X Check_Type (m, T_Boolean); X return EQ(m, True) ? GrabModeSync : GrabModeAsync; X} X Xstatic Object P_Grab_Pointer (win, ownerp, events, psyncp, ksyncp, confine_to, X cursor, time) Object win, ownerp, events, psyncp, ksyncp, confine_to, X cursor, time; { X Check_Type (win, T_Window); X Check_Type (ownerp, T_Boolean); X return Bits_To_Symbols ((unsigned long)XGrabPointer (WINDOW(win)->dpy, X WINDOW(win)->win, X EQ(ownerp, True), Symbols_To_Bits (events, 1, Event_Syms), X Get_Mode (psyncp), Get_Mode (ksyncp), X Get_Window (confine_to), Get_Cursor (cursor), Get_Time (time)), X 0, Grabstatus_Syms); X} X Xstatic Object P_Ungrab_Pointer (d, time) Object d, time; { X Check_Type (d, T_Display); X XUngrabPointer (DISPLAY(d)->dpy, Get_Time (time)); X return Void; X} X Xstatic Object P_Grab_Button (win, button, mods, ownerp, events, psyncp, ksyncp, X confine_to, cursor) Object win, button, mods, ownerp, events, X psyncp, ksyncp, confine_to, cursor; { X Check_Type (win, T_Window); X Check_Type (ownerp, T_Boolean); X XGrabButton (WINDOW(win)->dpy, Symbols_To_Bits (button, 0, Button_Syms), X Symbols_To_Bits (mods, 1, State_Syms), WINDOW(win)->win, X EQ(ownerp, True), Symbols_To_Bits (events, 1, Event_Syms), X Get_Mode (psyncp), Get_Mode (ksyncp), X Get_Window (confine_to), Get_Cursor (cursor)); X return Void; X} X Xstatic Object P_Ungrab_Button (win, button, mods) { X Check_Type (win, T_Window); X XUngrabButton (WINDOW(win)->dpy, Symbols_To_Bits (button, 0, Button_Syms), X Symbols_To_Bits (mods, 1, State_Syms), WINDOW(win)->win); X return Void; X} X Xstatic Object P_Change_Active_Pointer_Grab (d, events, cursor, time) X Object d, events, cursor, time; { X Check_Type (d, T_Display); X XChangeActivePointerGrab (DISPLAY(d)->dpy, Symbols_To_Bits (events, 1, X Event_Syms), Get_Cursor (cursor), Get_Time (time)); X return Void; X} X Xstatic Object P_Grab_Keyboard (win, ownerp, psyncp, ksyncp, time) Object win, X ownerp, psyncp, ksyncp, time; { X Check_Type (win, T_Window); X Check_Type (ownerp, T_Boolean); X return Bits_To_Symbols ((unsigned long)XGrabKeyboard (WINDOW(win)->dpy, X WINDOW(win)->win, EQ(ownerp, True), Get_Mode (psyncp), X Get_Mode (ksyncp), Get_Time (time)), X 0, Grabstatus_Syms); X} X Xstatic Object P_Ungrab_Keyboard (d, time) Object d, time; { X Check_Type (d, T_Display); X XUngrabKeyboard (DISPLAY(d)->dpy, Get_Time (time)); X return Void; X} X Xstatic Object P_Grab_Key (win, key, mods, ownerp, psyncp, ksyncp) Object win, X key, mods, ownerp, psyncp, ksyncp; { X int keycode = AnyKey; X X Check_Type (win, T_Window); X if (!EQ(key, Sym_Any)) X keycode = Get_Integer (key); X Check_Type (ownerp, T_Boolean); X XGrabKey (WINDOW(win)->dpy, keycode, Symbols_To_Bits (mods, 1, State_Syms), X WINDOW(win)->win, EQ(ownerp, True), Get_Mode (psyncp), X Get_Mode (ksyncp)); X return Void; X} X Xstatic Object P_Ungrab_Key (win, key, mods) Object win, key, mods; { X int keycode = AnyKey; X X Check_Type (win, T_Window); X if (!EQ(key, Sym_Any)) X keycode = Get_Integer (key); X XUngrabKey (WINDOW(win)->dpy, keycode, X Symbols_To_Bits (mods, 1, State_Syms), WINDOW(win)->win); X return Void; X} X Xstatic Object P_Allow_Events (d, mode, time) Object d, mode, time; { X Check_Type (d, T_Display); X XAllowEvents (DISPLAY(d)->dpy, Symbols_To_Bits (mode, 0, X Allow_Events_Syms), Get_Time (time)); X return Void; X} X Xstatic Object P_Grab_Server (d) Object d; { X Check_Type (d, T_Display); X XGrabServer (DISPLAY(d)->dpy); X return Void; X} X Xstatic Object P_Ungrab_Server (d) Object d; { X Check_Type (d, T_Display); X XUngrabServer (DISPLAY(d)->dpy); X return Void; X} X Xstatic Object P_Query_Pointer (win) Object win; { X Object l, t, z; X Bool ret; X Window root, child; X int r_x, r_y, x, y; X unsigned int mask; X GC_Node3; X X Check_Type (win, T_Window); X ret = XQueryPointer (WINDOW(win)->dpy, WINDOW(win)->win, &root, &child, X &r_x, &r_y, &x, &y, &mask); X t = l = P_Make_List (Make_Fixnum (8), Null); X GC_Link3 (l, t, win); X Car (t) = Make_Fixnum (x); t = Cdr (t); X Car (t) = Make_Fixnum (y); t = Cdr (t); X Car (t) = ret ? True : False; t = Cdr (t); X z = Make_Window (0, WINDOW(win)->dpy, root); X Car (t) = z; t = Cdr (t); X Car (t) = Make_Fixnum (r_x); t = Cdr (t); X Car (t) = Make_Fixnum (r_y); t = Cdr (t); X z = Make_Window (0, WINDOW(win)->dpy, child); X Car (t) = z; t = Cdr (t); X z = Bits_To_Symbols ((unsigned long)mask, 1, State_Syms); X Car (t) = z; X GC_Unlink; X return l; X} X Xstatic Object P_General_Warp_Pointer (dpy, dst, dstx, dsty, src, srcx, srcy, X srcw, srch) Object dpy, dst, dstx, dsty, src, srcx, srcy, srcw, srch; { X Check_Type (dpy, T_Display); X XWarpPointer (DISPLAY(dpy)->dpy, Get_Window (src), Get_Window (dst), X Get_Integer (srcx), Get_Integer (srcy), Get_Integer (srcw), X Get_Integer (srch), Get_Integer (dstx), Get_Integer (dsty)); X return Void; X} X Xstatic Object P_Bell (argc, argv) Object *argv; { X register percent = 0; X X Check_Type (argv[0], T_Display); X if (argc == 2) { X percent = Get_Integer (argv[1]); X if (percent < -100 || percent > 100) X Range_Error (argv[1]); X } X XBell (DISPLAY(argv[0])->dpy, percent); X return Void; X} X Xinit_xlib_pointer () { X Define_Symbol (&Sym_Any, "any"); X Define_Primitive (P_Grab_Pointer, "grab-pointer", 8, 8, EVAL); X Define_Primitive (P_Ungrab_Pointer, "ungrab-pointer", 2, 2, EVAL); X Define_Primitive (P_Grab_Button, "grab-button", 9, 9, EVAL); X Define_Primitive (P_Ungrab_Button, "ungrab-button", 3, 3, EVAL); X Define_Primitive (P_Change_Active_Pointer_Grab, X "change-active-pointer-grab", 4, 4, EVAL); X Define_Primitive (P_Grab_Keyboard, "grab-keyboard", 5, 5, EVAL); X Define_Primitive (P_Ungrab_Keyboard, "ungrab-keyboard", 2, 2, EVAL); X Define_Primitive (P_Grab_Key, "grab-key", 6, 6, EVAL); X Define_Primitive (P_Ungrab_Key, "ungrab-key", 3, 3, EVAL); X Define_Primitive (P_Allow_Events, "allow-events", 3, 3, EVAL); X Define_Primitive (P_Grab_Server, "grab-server", 1, 1, EVAL); X Define_Primitive (P_Ungrab_Server, "ungrab-server", 1, 1, EVAL); X Define_Primitive (P_Query_Pointer, "query-pointer", 1, 1, EVAL); X Define_Primitive (P_General_Warp_Pointer, "general-warp-pointer", X 9, 9, EVAL); X Define_Primitive (P_Bell, "bell", 1, 2, VARARGS); X} END_OF_lib/xlib/pointer.c if test 6645 -ne `wc -c lib/xlib/wm.c <<'END_OF_lib/xlib/wm.c' X#include "xlib.h" X Xextern XFetchName(), XStoreName(), XGetIconName(), XSetIconName(); X Xstatic Object Sym_Wm_Hints, Sym_Size_Hints, Sym_Icon_Size; X Xstatic Object Get_Name (w, f) Object w; int (*f)(); { X char *ret; X Object s; X X Check_Type (w, T_Window); X Disable_Interrupts; X if (!(*f) (WINDOW(w)->dpy, WINDOW(w)->win, &ret) || ret == 0) { X Enable_Interrupts; X return False; X } X Enable_Interrupts; X s = Make_String (ret, strlen (ret)); X XFree (ret); X return s; X} X Xstatic Object P_Wm_Name (w) Object w; { X return Get_Name (w, XFetchName); X} X Xstatic Object P_Wm_Icon_Name (w) Object w; { X return Get_Name (w, XGetIconName); X} X Xstatic Object Set_Name (w, name, f) Object w, name; int (*f)(); { X register char *s; X X Check_Type (w, T_Window); X Make_C_String (name, s); X (*f) (WINDOW(w)->dpy, WINDOW(w)->win, s); X return Void; X} X Xstatic Object P_Set_Wm_Name (w, name) Object w, name; { X return Set_Name (w, name, XStoreName); X} X Xstatic Object P_Set_Wm_Icon_Name (w, name) Object w, name; { X return Set_Name (w, name, XSetIconName); X} X Xstatic Object P_Wm_Class (w) Object w; { X Object ret, x; X XClassHint c; X GC_Node; X X Check_Type (w, T_Window); X /* X * In X11.2 XGetClassHint() returns either 0 or Success, which happens X * to be defined as 0. So until this bug is fixed, we must X * explicitly check whether the XClassHint structure has been filled. X */ X c.res_name = c.res_class = 0; X Disable_Interrupts; X (void)XGetClassHint (WINDOW(w)->dpy, WINDOW(w)->win, &c); X Enable_Interrupts; X ret = Cons (False, False); X GC_Link (ret); X if (c.res_name) { X x = Make_String (c.res_name, strlen (c.res_name)); X Car (ret) = x; X } X if (c.res_class) { X x = Make_String (c.res_class, strlen (c.res_class)); X Cdr (ret) = x; X } X GC_Unlink; X return ret; X} X Xstatic Object P_Set_Wm_Class (w, name, class) Object w, name, class; { X XClassHint c; X X Check_Type (w, T_Window); X Make_C_String (name, c.res_name); X Make_C_String (class, c.res_class); X XSetClassHint (WINDOW(w)->dpy, WINDOW(w)->win, &c); X return Void; X} X Xstatic Object P_Set_Wm_Command (w, cmd) Object w, cmd; { X register i, n; X register char **argv; X Object c; X X Check_Type (w, T_Window); X Check_List (cmd); X n = Internal_Length (cmd); X argv = (char **)alloca (n * sizeof (char *)); X for (i = 0; i < n; i++, cmd = Cdr (cmd)) { X c = Car (cmd); X Make_C_String (c, argv[i]); X } X XSetCommand (WINDOW(w)->dpy, WINDOW(w)->win, argv, n); X return Void; X} X Xstatic Object P_Wm_Hints (w) Object w; { X XWMHints *p; X X Check_Type (w, T_Window); X Disable_Interrupts; X p = XGetWMHints (WINDOW(w)->dpy, WINDOW(w)->win); X Enable_Interrupts; X if (p) X WMH = *p; X else X WMH.flags = 0; X return Record_To_Vector (Wm_Hints_Rec, Wm_Hints_Size, Sym_Wm_Hints, X WINDOW(w)->dpy, (unsigned long)WMH.flags); X} X Xstatic Object P_Set_Wm_Hints (w, h) Object w, h; { X register unsigned long mask; X X Check_Type (w, T_Window); X mask = Vector_To_Record (h, Wm_Hints_Size, Sym_Wm_Hints, Wm_Hints_Rec); X WMH.flags = mask; X XSetWMHints (WINDOW(w)->dpy, WINDOW(w)->win, &WMH); X return Void; X} X Xstatic Object P_Size_Hints (w, a) Object w, a; { X Check_Type (w, T_Window); X Check_Type (a, T_Atom); X Disable_Interrupts; X if (!XGetSizeHints (WINDOW(w)->dpy, WINDOW(w)->win, &SZH, ATOM(a)->atom)) X SZH.flags = 0; X Enable_Interrupts; X if ((SZH.flags & (PPosition|USPosition)) == (PPosition|USPosition)) X SZH.flags &= ~PPosition; X if ((SZH.flags & (PSize|USSize)) == (PSize|USSize)) X SZH.flags &= ~PSize; X return Record_To_Vector (Size_Hints_Rec, Size_Hints_Size, Sym_Size_Hints, X WINDOW(w)->dpy, (unsigned long)SZH.flags); X} X Xstatic Object P_Set_Size_Hints (w, a, h) Object w, a, h; { X register unsigned long mask; X X Check_Type (w, T_Window); X Check_Type (a, T_Atom); X bzero ((char *)&SZH, sizeof (SZH)); /* Not portable? */ X mask = Vector_To_Record (h, Size_Hints_Size, Sym_Size_Hints, X Size_Hints_Rec); X if ((mask & (PPosition|USPosition)) == (PPosition|USPosition)) X mask &= ~PPosition; X if ((mask & (PSize|USSize)) == (PSize|USSize)) X mask &= ~PSize; X SZH.flags = mask; X XSetSizeHints (WINDOW(w)->dpy, WINDOW(w)->win, &SZH, ATOM(a)->atom); X return Void; X} X Xstatic Object P_Icon_Sizes (w) Object w; { X XIconSize *p; X int i, n; X Object v, x; X GC_Node2; X X Check_Type (w, T_Window); X Disable_Interrupts; X if (!XGetIconSizes (WINDOW(w)->dpy, WINDOW(w)->win, &p, &n)) X n = 0; X Enable_Interrupts; X v = Make_Vector (n, Null); X GC_Link2 (v, w); X for (i = 0; i < n; i++) { X ISZ = p[i]; X x = Record_To_Vector (Icon_Size_Rec, Icon_Size_Size, Sym_Icon_Size, X WINDOW(w)->dpy, ~0L); X VECTOR(v)->data[i] = x; X } X GC_Unlink; X return v; X} X Xstatic Object P_Set_Icon_Sizes (w, v) Object w, v; { X register i, n; X XIconSize *p; X X Check_Type (w, T_Window); X Check_Type (v, T_Vector); X n = VECTOR(v)->size; X p = (XIconSize *)alloca (n * sizeof (XIconSize)); X for (i = 0; i < n; i++) { X (void)Vector_To_Record (VECTOR(v)->data[i], Icon_Size_Size, X Sym_Icon_Size, Icon_Size_Rec); X p[i] = ISZ; X } X XSetIconSizes (WINDOW(w)->dpy, WINDOW(w)->win, p, n); X return Void; X} X Xstatic Object P_Transient_For (w) Object w; { X Window win; X X Disable_Interrupts; X if (!XGetTransientForHint (WINDOW(w)->dpy, WINDOW(w)->win, &win)) X win = None; X Enable_Interrupts; X return Make_Window (0, WINDOW(w)->dpy, win); X} X Xstatic Object P_Set_Transient_For (w, pw) Object w, pw; { X Check_Type (w, T_Window); X XSetTransientForHint (WINDOW(w)->dpy, WINDOW(w)->win, Get_Window (pw)); X return Void; X} X Xinit_xlib_wm () { X Define_Symbol (&Sym_Wm_Hints, "wm-hints"); X Define_Symbol (&Sym_Size_Hints, "size-hints"); X Define_Symbol (&Sym_Icon_Size, "icon-size"); X Define_Primitive (P_Wm_Name, "wm-name", 1, 1, EVAL); X Define_Primitive (P_Wm_Icon_Name, "wm-icon-name", 1, 1, EVAL); X Define_Primitive (P_Set_Wm_Name, "set-wm-name!", 2, 2, EVAL); X Define_Primitive (P_Set_Wm_Icon_Name, "set-wm-icon-name!", 2, 2, EVAL); X Define_Primitive (P_Wm_Class, "wm-class", 1, 1, EVAL); X Define_Primitive (P_Set_Wm_Class, "set-wm-class!", 3, 3, EVAL); X Define_Primitive (P_Set_Wm_Command, "set-wm-command!", 2, 2, EVAL); X Define_Primitive (P_Wm_Hints, "wm-hints", 1, 1, EVAL); X Define_Primitive (P_Set_Wm_Hints, "set-wm-hints!", 2, 2, EVAL); X Define_Primitive (P_Size_Hints, "size-hints", 2, 2, EVAL); X Define_Primitive (P_Set_Size_Hints, "set-size-hints!", 3, 3, EVAL); X Define_Primitive (P_Icon_Sizes, "icon-sizes", 1, 1, EVAL); X Define_Primitive (P_Set_Icon_Sizes, "set-icon-sizes!", 2, 2, EVAL); X Define_Primitive (P_Transient_For, "transient-for", 1, 1, EVAL); X Define_Primitive (P_Set_Transient_For,"set-transient-for!",2, 2, EVAL); X} END_OF_lib/xlib/wm.c if test 7029 -ne `wc -c lib/xaw/Makefile <<'END_OF_lib/xaw/Makefile' XWIDGET_SET= xaw X XO= ascii.o\ X box.o\ X clock.o\ X command.o\ X dialog.o\ X form.o\ X grip.o\ X label.o\ X list.o\ X scroll.o\ X shell.o\ X viewport.o\ X vpaned.o X X.SUFFIXES: .d .c .o X X.d.c: X ../../src/scheme -l ../xt/make-widget $< $@ $(WIDGET_SET) X X.d.o: X ../../src/scheme -l ../xt/make-widget $< $*.c $(WIDGET_SET) X $(CC) $(CFLAGS) -c $*.c X Xall: $(O) X Xlint: X lint $(LINTFLAGS) -abxh *.c | egrep -v '\?\?\?' X Xclean: X rm -f *.o *.c END_OF_lib/xaw/Makefile if test 445 -ne `wc -c lib/xaw/grip.d <<'END_OF_lib/xaw/grip.d' X;;; -*-Scheme-*- X X(define-widget-type 'grip "Grip.h") X X(define-widget-class 'grip 'gripWidgetClass) X X(define-callback 'grip 'callback #t) X X(c->scheme 'grip-callback X" Object args, ret, t = Null; X register i; X GripCallData p = (GripCallData)x; X GC_Node2; X X args = Get_Event_Args (p->event); X ret = Cons (Copy_List (args), Null); X Destroy_Event_Args (args); X GC_Link2 (ret, t); X t = P_Make_List (Make_Fixnum (p->num_params), Null); X for (i = 0, Cdr (ret) = t; i < p->num_params; i++, t = Cdr (t)) { X Object s = Make_String (p->params[i], strlen (p->params[i])); X Car (t) = s; X } X GC_Unlink; X return ret;") END_OF_lib/xaw/grip.d if test 642 -ne `wc -c lib/xaw/list.d <<'END_OF_lib/xaw/list.d' X;;; -*-Scheme-*- X X(define-widget-type 'list "List.h" X X"static char **Get_List (x) Object x; { X register i, n; X register char *s, **l; X X Check_List (x); X n = Internal_Length (x); X l = (char **)XtMalloc ((n+1) * sizeof (char *)); X for (i = 0; i < n; i++, x = Cdr (x)) { X Make_C_String (Car (x), s); X l[i] = XtNewString (s); X } X l[i] = 0; X return l; X}") X X(define-widget-class 'list 'listWidgetClass) X X(define-callback 'list 'callback #t) X X(c->scheme 'list-callback X" XtListReturnStruct *p = (XtListReturnStruct *)x; X return Cons (Make_String (p->string, strlen (p->string)), X Make_Fixnum (p->index));") X X(scheme->c 'list-list X" return (XtArgVal)Get_List (x);") X X(define-primitive 'list-change! '(w x resize) X" Check_Widget_Class (w, listWidgetClass); X Check_Type (resize, T_Boolean); X XtListChange (WIDGET(w)->widget, Get_List (x), 0, 0, EQ (resize, True)); X return Void;") X X(define-primitive 'list-highlight '(w i) X" Check_Widget_Class (w, listWidgetClass); X XtListHighlight (WIDGET(w)->widget, Get_Integer (i)); X return Void;") X X(define-primitive 'list-unhighlight '(w) X" Check_Widget_Class (w, listWidgetClass); X XtListUnhighlight (WIDGET(w)->widget); X return Void;") X X(define-primitive 'list-current '(w) X" XtListReturnStruct *p; X X Check_Widget_Class (w, listWidgetClass); X p = XtListShowCurrent (WIDGET(w)->widget); X if (p->index == XT_LIST_NONE) X return False; X return Cons (Make_String (p->string, strlen (p->string)), X Make_Fixnum (p->index));") END_OF_lib/xaw/list.d if test 1526 -ne `wc -c lib/xaw/scroll.d <<'END_OF_lib/xaw/scroll.d' X;;; -*-Scheme-*- X X(define-widget-type 'scrollbar "Scroll.h") X X(define-widget-class 'scrollbar 'scrollbarWidgetClass) X X(define-callback 'scrollbar 'scrollProc #t) X(define-callback 'scrollbar 'jumpProc #t) X X(c->scheme 'scrollbar-scrollProc X" return Make_Integer ((int)x);") X X(c->scheme 'scrollbar-jumpProc X" return Make_Reduced_Flonum ((double)*(float *)x);") X X(define-primitive 'scrollbar-set-thumb! '(w t s) X" Check_Widget_Class (w, scrollbarWidgetClass); X XtScrollBarSetThumb (WIDGET(w)->widget, Get_Double (t), Get_Double (s)); X return Void;") END_OF_lib/xaw/scroll.d if test 560 -ne `wc -c lib/xaw/box.d <<'END_OF_lib/xaw/box.d' X;;; -*-Scheme-*- X X(define-widget-type 'box "Box.h") X X(define-widget-class 'box 'boxWidgetClass) END_OF_lib/xaw/box.d if test 96 -ne `wc -c lib/xaw/shell.d <<'END_OF_lib/xaw/shell.d' X;;; -*-Scheme-*- X X(define-widget-type 'shell "Shell.h") X X(define-widget-class 'shell 'shellWidgetClass) X(define-widget-class 'override-shell 'overrideShellWidgetClass) X(define-widget-class 'wm-shell 'wmShellWidgetClass) X(define-widget-class 'transient-shell 'transientShellWidgetClass) X(define-widget-class 'toplevel-shell 'topLevelShellWidgetClass) X(define-widget-class 'application-shell 'applicationShellWidgetClass) END_OF_lib/xaw/shell.d if test 420 -ne `wc -c lib/xaw/clock.d <<'END_OF_lib/xaw/clock.d' X;;; -*-Scheme-*- X X(define-widget-type 'clock "Clock.h") X X(define-widget-class 'clock 'clockWidgetClass) END_OF_lib/xaw/clock.d if test 104 -ne `wc -c lib/xaw/dialog.d <<'END_OF_lib/xaw/dialog.d' X;;; -*-Scheme-*- X X(define-widget-type 'dialog "Dialog.h") X X(define-widget-class 'dialog 'dialogWidgetClass) END_OF_lib/xaw/dialog.d if test 108 -ne `wc -c lib/xaw/vpaned.d <<'END_OF_lib/xaw/vpaned.d' X;;; -*-Scheme-*- X X(define-widget-type 'vpaned "VPaned.h") X X(define-widget-class 'vpaned 'vPanedWidgetClass) END_OF_lib/xaw/vpaned.d if test 108 -ne `wc -c lib/xaw/ascii.d <<'END_OF_lib/xaw/ascii.d' X;;; -*-Scheme-*- X X(define-widget-type 'ascii "AsciiText.h" X X"static SYMDESCR Edittype_Syms[] = { X { \"text-read\", XttextRead }, X { \"text-append\", XttextAppend }, X { \"text-edit\", XttextEdit }, X { 0, 0 } X}; Xstatic SYMDESCR Options_Syms[] = { X { \"word-break\", wordBreak }, X { \"scroll-vertical\", scrollVertical }, X { \"scroll-horizontal\", scrollHorizontal }, X { \"scroll-on-overflow\", scrollOnOverflow }, X { \"resize-width\", resizeWidth }, X { \"resize-height\", resizeHeight }, X { \"editable\", editable }, X { 0, 0 } X};") X X(define-widget-class 'ascii-string 'asciiStringWidgetClass X '(font Font FontStruct) X '(foreground Foreground Pixel) X '(editType EditType EditMode) X '(length Length Int)) X X(define-widget-class 'ascii-disk 'asciiDiskWidgetClass X '(font Font FontStruct) X '(foreground Foreground Pixel) X '(editType EditType EditMode)) X X(define scheme->edit-type X" return (XtArgVal)Symbols_To_Bits (x, 0, Edittype_Syms);") X X(scheme->c 'ascii-string-editType scheme->edit-type) X(scheme->c 'ascii-disk-editType scheme->edit-type) X X(define scheme->text-options X" return (XtArgVal)Symbols_To_Bits (x, 1, Options_Syms);") X X(scheme->c 'ascii-string-textOptions scheme->text-options) X(scheme->c 'ascii-disk-textOptions scheme->text-options) X X(define text-options->scheme X" return Bits_To_Symbols ((unsigned long)x, 1, Options_Syms);") X X(c->scheme 'ascii-string-textOptions text-options->scheme) X(c->scheme 'ascii-disk-textOptions text-options->scheme) X X(scheme->c 'ascii-string-string X" char *s, *t; X Make_C_String (x, t); X if ((s = XtMalloc (1024)) == 0) X Primitive_Error (\"out of memory\"); X strncpy (s, t, 1024); X return (XtArgVal)s;") X X(scheme->c 'ascii-string-length X" if (Get_Integer (x) > 1024) X Primitive_Error (\"invalid length for ascii-string\"); X return (XtArgVal)Get_Integer (x);") END_OF_lib/xaw/ascii.d if test 1916 -ne `wc -c lib/xaw/viewport.d <<'END_OF_lib/xaw/viewport.d' X;;; -*-Scheme-*- X X(define-widget-type 'viewport "Viewport.h") X X(define-widget-class 'viewport 'viewportWidgetClass) END_OF_lib/xaw/viewport.d if test 116 -ne `wc -c lib/xt/examples/dialog <<'END_OF_lib/xt/examples/dialog' X;;; -*-Scheme-*- X;;; X;;; (Stupid) dialog box demo X X(require 'xwidgets) X(load-widgets shell dialog command box label) X X(define con (create-context)) X(define dpy (initialize-display con #f 'dialog 'demo)) X(define top (create-shell 'dialog 'demo (find-class 'application-shell) dpy)) X X(define f (open-font dpy "*courier-bold-r-normal--14*")) X(define g (open-font dpy "*courier-bold-r-normal--18*")) X X(define gray-bits "\10\2\10\2") X(define gray (create-bitmap-from-data (display-root-window dpy) gray-bits 4 4)) X X(define box (create-managed-widget (find-class 'box) top)) X(set-values! box 'h-space 14 'v-space 14 'background-pixmap gray) X X(define dialog (create-managed-widget (find-class 'dialog) box X 'value "/tmp/test" 'label "FILENAME:")) X(set-values! dialog 'width 80) X(set-values! (name->widget dialog 'label) 'font f) X X(define button (create-managed-widget (find-class 'command) dialog)) X(set-values! button 'label "cancel" 'font f) X X(define button2 (create-managed-widget (find-class 'command) dialog)) X(set-values! button2 'label "write" 'font f) X(add-callback button2 'callback X (lambda (w) X (format #t "Filename is ~s~%" X (car (get-values (widget-parent w) 'value))))) X X(define bbox (create-managed-widget (find-class 'box) box)) X X(define l (create-managed-widget (find-class 'label) bbox 'border-width 0 X 'font f 'label "TYPEFACE:")) X(define b1 (create-managed-widget (find-class 'command) bbox)) X(set-values! b1 'label "normal" 'font f) X(define b2 (create-managed-widget (find-class 'command) bbox)) X(set-values! b2 'label "bold" 'font f) X(define b3 (create-managed-widget (find-class 'command) bbox)) X(set-values! b3 'label "italic" 'font f) X(define b4 (create-managed-widget (find-class 'command) bbox)) X(set-values! b4 'label "faint" 'font f 'sensitive #f) X X(define q (create-managed-widget (find-class 'command) box)) X(set-values! q 'label "quit" 'border-width 3 'font g) X(add-callback q 'callback (lambda (w) (exit))) X X(define q2 (create-managed-widget (find-class 'command) box)) X(set-values! q2 'label "apply" 'border-width 3 'font g) X(add-callback q2 'callback (lambda (w) (set! done #t))) X X(define done #f) X X(realize-widget top) X(while (not done) (context-process-event con)) END_OF_lib/xt/examples/dialog if test 2235 -ne `wc -c lib/xt/examples/scrollbar <<'END_OF_lib/xt/examples/scrollbar' X;;; -*-Scheme-*- X;;; X;;; Scroll bar demo X X(require 'xwidgets) X(load-widgets shell scroll) X X(define con (create-context)) X(define dpy (initialize-display con #f 'scroll 'demo)) X(define top (create-shell 'scroll 'demo (find-class 'application-shell) dpy)) X X(define scroll (create-managed-widget (find-class 'scrollbar) top X 'thickness 35 'length 400)) X X(define (sp w x) (format #t "(scroll-proc ~s)~%" x)) X(define (jp w x) (format #t "(jump-proc ~s)~%" x)) X X(add-callback scroll 'scroll-proc sp) X(set-values! scroll 'jump-proc (list jp)) X X(scrollbar-set-thumb! scroll 0.3 0.2) X X(realize-widget top) X(context-main-loop con) END_OF_lib/xt/examples/scrollbar if test 658 -ne `wc -c lib/xt/examples/scrollbox <<'END_OF_lib/xt/examples/scrollbox' X;;; -*-Scheme-*- X;;; X;;; Scroll box demo X X(require 'xwidgets) X(load-widgets shell command box label) X X(define items '(Helvetica Courier Times Palatino Zapf\ Chancery Zapf\ Dingbats)) X(set-cdr! (last-pair items) items) X X(define con (create-context)) X(define dpy (initialize-display con #f 'box 'demo)) X(define top (create-shell 'box 'demo (find-class 'application-shell) dpy)) X X(define dia-bits "\0\0\100\0\340\0\360\1\370\3\374\7\376\17\374\7\370\3\360\1\340\0\100\0\0\0") X(define dia (create-bitmap-from-data (display-root-window dpy) dia-bits 13 13)) X X(define box (create-managed-widget (find-class 'box) top)) X(set-values! box 'width 200) X X(define button (create-managed-widget (find-class 'command) box)) X(set-values! button 'bitmap dia) X X(define label (create-managed-widget (find-class 'label) box)) X(set-values! label 'width 130 'label (car items) 'resize #f 'justify 'left X 'font (open-font dpy "*courier-bold-r-normal--14*")) X(add-callback button 'callback X (lambda (w) X (set! items (cdr items)) X (set-values! label 'label (car items)))) X X(realize-widget top) X(context-main-loop con) END_OF_lib/xt/examples/scrollbox if test 1118 -ne `wc -c lib/xt/examples/list <<'END_OF_lib/xt/examples/list' X;;; -*-Scheme-*- X;;; X;;; List widget demo (directory browser) X X(require 'xwidgets) X(load-widgets shell form label command list) X(require 'unix 'unix.o) X(require 'sort 'qsort) X X(define con (create-context)) X(define dpy (initialize-display con #f 'list 'demo)) X(define top (create-shell 'list 'demo (find-class 'application-shell) dpy)) X(set-values! top 'allow-shell-resize #t) X X(define form (create-managed-widget (find-class 'form) top)) X X(define quit (create-managed-widget (find-class 'command) form)) X(set-values! quit 'label "quit") X(add-callback quit 'callback (lambda x (exit))) X X(define back (create-managed-widget (find-class 'command) form)) X(set-values! back 'label "back" 'from-horiz quit) X(add-callback back 'callback (lambda x (goto ".."))) X X(define lab (create-managed-widget (find-class 'label) form)) X(set-values! lab 'border-width 0 'from-horiz back 'resizable #t) X X;; List widget is broken; ``list'' resource *must* be initialized: X(define lst (create-managed-widget (find-class 'list) form 'list ())) X(set-values! lst 'from-vert lab 'resizable #t 'vertical-list #t) X X(add-callback lst 'callback X (lambda (w i) X (let ((stat (file-status (string-append where "/" (car i))))) X (set-values! lab 'label stat) X (if (eq? stat 'directory) X (goto (car i)))))) X X(define (goto dir) X (if (string=? dir "..") X (begin X (if (not (string=? where "/")) X (begin X (set! where X (substring where 0 X (do ((i (- (string-length where) 2) (1- i))) X ((char=? (string-ref where i) #\/) i)))) X (if (eqv? where "") X (set! where "/"))))) X (if (not (or (string=? dir "/") (string=? where "/"))) X (set! where (string-append where "/"))) X (set! where (string-append where dir))) X (set-values! lab 'label where) X (define l ()) X (for-each (lambda (d) (if (not (member d '("." ".."))) X (set! l (cons d l)))) X (read-directory where)) X (set-values! lst 'default-columns X (max 2 (ceiling (/ (length l) 40)))) X (list-change! lst (sort l stringlib/xt/examples/grip <<'END_OF_lib/xt/examples/grip' X;;; -*-Scheme-*- X;;; X;;; Grip widget demo X X(require 'xwidgets) X(load-widgets shell grip) X X(define con (create-context)) X(define dpy (initialize-display con #f 'grip 'demo)) X(define top (create-shell 'grip 'demo (find-class 'application-shell) dpy)) X(set-values! top 'width 50 'height 50) X X(define g (create-managed-widget (find-class 'grip) top)) X X(augment-translations g X" : GripAction(press) X : GripAction(move) X : GripAction(release,done)") X X(add-callback g 'callback X (lambda (w x) X (format #t "Action: ~s Event: ~s~%" (cdr x) (caar x)))) X X(realize-widget top) X(context-main-loop con) END_OF_lib/xt/examples/grip if test 649 -ne `wc -c lib/xt/examples/viewport <<'END_OF_lib/xt/examples/viewport' X;;; -*-Scheme-*- X X(require 'xwidgets) X(load-widgets shell clock viewport) X X(define con (create-context)) X(define dpy (initialize-display con #f 'viewport 'demo)) X(define top (create-shell 'viewport 'demo (find-class 'application-shell) dpy)) X X(define v (create-managed-widget (find-class 'viewport) top X 'force-bars #t 'allow-horiz #t 'allow-vert #t)) X(set-values! v 'width 120 'height 120) X X(define c (create-managed-widget (find-class 'clock) v)) X(set-values! c 'width 200 'height 200) X X(realize-widget top) X(context-main-loop con) END_OF_lib/xt/examples/viewport if test 535 -ne `wc -c lib/xt/examples/text <<'END_OF_lib/xt/examples/text' X;;; -*-Scheme-*- X X(require 'xwidgets) X(load-widgets shell ascii box command label) X X(define con (create-context)) X(define dpy (initialize-display con #f 'text 'demo)) X(define top (create-shell 'text 'demo (find-class 'application-shell) dpy)) X X(define box (create-managed-widget (find-class 'box) top)) X X(define lab (create-managed-widget (find-class 'label) box)) X(set-values! lab 'border-width 0 'label "Enter a number:") X X;;; string resource *must* be specified (bug in Xaw): X(define txt (create-managed-widget (find-class 'ascii-string) box X 'string "" 'length 100 'edit-type 'text-edit)) X X(define can (create-managed-widget (find-class 'command) box)) X(set-values! can 'label "CANCEL") X(add-callback can 'callback (lambda foo (exit))) X X(define acc (create-managed-widget (find-class 'command) box)) X(set-values! acc 'label "ACCEPT") X(add-callback acc 'callback X (lambda foo X (let ((s (car (get-values txt 'string)))) X (if (not (number-string? s)) X (format #t "~s is not a number!~%" s) X (format #t "Result is ~a~%" s) X (exit))))) X X(define (number-string? s) X (not (or (eqv? s "") (memq #f (map char-numeric? (string->list s)))))) X X(realize-widget top) X(context-main-loop con) END_OF_lib/xt/examples/text if test 1220 -ne `wc -c lib/xt/examples/hp-misc <<'END_OF_lib/xt/examples/hp-misc' X;;; -*-Scheme-*- X;;; X;;; HP widgets demo X X(require 'xwidgets) X(set! widget-load-path '(xhp xaw)) X(load-widgets arrow bboard box pbutton sash scroll shell stext toggle) X(load-widgets valuator vpw) X X(define con (create-context)) X(define dpy (initialize-display con #f 'widgets 'demo)) X(define top (create-shell 'widgets 'demo (find-class 'application-shell) dpy)) X X(define box (create-managed-widget (find-class 'box) top)) X X(define t1 (create-managed-widget (find-class 'toggle) box)) X(set-values! t1 'traversal-type "highlight_enter" 'highlight-thickness 3) X(define t2 (create-managed-widget (find-class 'toggle) box 'square #f)) X(set-values! t2 'traversal-type "highlight_enter" 'highlight-thickness 3) X X(define vpw (create-managed-widget (find-class 'vpw) box)) X X(define a1 (create-managed-widget (find-class 'arrow) vpw)) X(set-values! a1 'width 75 'height 75) X(set-values! (name->widget vpw 'sash) 'background "black") X(define a2 (create-managed-widget (find-class 'arrow) vpw)) X(set-values! a2 'height 75 'arrow-direction "arrow_down") X X(define val (create-managed-widget (find-class 'valuator) box)) X(set-values! val 'slider-origin 20 'cursor "sb_right_arrow") X(add-callback val 'slider-moved (lambda (w x) X (set-values! s 'string (format #f "~s" x)))) X X(define s (create-managed-widget (find-class 'static-text) box 'string "20")) X(set-values! s 'recompute-size #f) X X(define sb (create-managed-widget (find-class 'scrollbar) box)) X(set-values! sb 'width 20 'height 150) X X(realize-widget top) X X(define bb (create-managed-widget (find-class 'bboard) box)) X(set-values! bb 'background-tile "50_foreground") X(do ((x '(0 40 0 40) (cdr x)) (y '(0 0 40 40) (cdr y))) ((null? x)) X (define s (create-managed-widget (find-class 'static-text) bb X 'string (format #f "~s,~s" (car x) (car y)) 'x (car x) 'y (car y)))) X X(define p1 (create-managed-widget (find-class 'push-button) box)) X(set-values! p1 'label "Quit Button") X(add-callback p1 'select (lambda (w) (exit))) X X(context-main-loop con) END_OF_lib/xt/examples/hp-misc if test 1993 -ne `wc -c lib/xt/examples/hp-arrow <<'END_OF_lib/xt/examples/hp-arrow' X;;; -*-Scheme-*- X;;; X;;; Demo with arrow, vpw, and push button X X(require 'xwidgets) X(load-widgets arrow sash shell pbutton vpw) X X(define con (create-context)) X(define dpy (initialize-display con #f 'arrow 'demo)) X(define top (create-shell 'arrow 'demo (find-class 'application-shell) dpy)) X(set-values! top 'allow-shell-resize #t) X X(define pane (create-managed-widget (find-class 'vpw) top)) X X(define button (create-managed-widget (find-class 'push-button) pane)) X(set-values! button 'width 150 'label "Rotate Arrow") X X(set-values! (name->widget pane 'sash) 'background "black") X X(define arrow (create-managed-widget (find-class 'arrow) pane)) X(set-values! arrow 'height 150 'traversal-type "highlight_enter" X 'highlight-thickness 3) X X(add-callback arrow 'select (lambda (w) (print '[select]))) X(add-callback arrow 'release (lambda (w) (print '[release]))) X X(define curr '(arrow_up arrow_right arrow_down arrow_left)) X(set-cdr! (last-pair curr) curr) X(set! curr (cdr curr)) X X(add-callback button 'select X (lambda (w) X (set-values! arrow 'arrow-direction (car curr)) X (set! curr (cdr curr)))) X X(realize-widget top) X(context-main-loop con) END_OF_lib/xt/examples/hp-arrow if test 1156 -ne `wc -c lib/xt/examples/hp-list <<'END_OF_lib/xt/examples/hp-list' X;;; -*-Scheme-*- X;;; X;;; List widget demo X X(require 'xwidgets) X(set! widget-load-path '(xhp xaw)) X(load-widgets bboard list pbutton shell stext) X X(define con (create-context)) X(define dpy (initialize-display con #f 'list 'demo)) X(define top (create-shell 'list 'demo (find-class 'application-shell) dpy)) X X(define bb (create-managed-widget (find-class 'bboard) top)) X X(define lst (create-managed-widget (find-class 'list) bb 'num-columns 3)) X(set-values! lst 'x 0 'y 130 'column-width 60 'element-highlight "invert" X 'element-height 21) X X(define instant #t) X(define p1 (create-managed-widget (find-class 'push-button) bb)) X(set-values! p1 'x 10 'y 10 'label "selection-style: instant") X(add-callback p1 'release X (lambda r X (set-values! p1 'label X (if instant "selection-style: sticky" "selection-style: instant")) X (set! instant (not instant)) X (set-values! lst 'selection-style (if instant "instant" "sticky")))) X X(define single #t) X(define p2 (create-managed-widget (find-class 'push-button) bb)) X(set-values! p2 'x 10 'y 40 'label "selection-method: single") X(add-callback p2 'release X (lambda r X (set-values! p2 'label X (if single "selection-method: multiple" "selection-method: single")) X (set! single (not single)) X (set-values! lst 'selection-method (if single "single" "multiple")))) X X(define biases '(no_bias row_bias col_bias)) X(define bias 0) X(define p3 (create-managed-widget (find-class 'push-button) bb)) X(set-values! p3 'x 10 'y 70 'label "selection-bias: none") X(add-callback p3 'release X (lambda r X (set! bias (1+ bias)) (set! bias (modulo bias 3)) X (set-values! p3 'label X (format #f "selection-bias: ~s" (list-ref biases bias))) X (set-values! lst 'selection-bias (list-ref biases bias)))) X X(define invert #t) X(define p4 (create-managed-widget (find-class 'push-button) bb)) X(set-values! p4 'x 10 'y 100 'label "element-highlight: invert") X(add-callback p4 'release X (lambda r X (set-values! p4 'label X (if invert "element-highlight: border" "element-highlight: invert")) X (set! invert (not invert)) X (set-values! lst 'element-highlight (if invert "invert" "border")))) X X(define p5 (create-managed-widget (find-class 'push-button) bb)) X(set-values! p5 'x 250 'y 10 'label 'QUIT) X(add-callback p5 'release (lambda r (exit))) X X(do ((i 0 (1+ i))) ((= i 80)) X (define w (create-managed-widget (find-class 'static-text) lst X 'string (format #f "item ~s" i))) X (set-values! w 'highlight-thickness 2) X (add-callback w 'select X (lambda (w) (format #t "selected ~s~%" (car (get-values w 'string)))))) X X(realize-widget top) X(context-main-loop con) END_OF_lib/xt/examples/hp-list if test 2637 -ne `wc -c lib/xt/examples/hp-menu <<'END_OF_lib/xt/examples/hp-menu' X;;; -*-Scheme-*- X;;; X;;; HP menu demo X X(require 'xwidgets) X(load-widgets bboard cascade menubutton menusep popupmgr shell toggle) X X(define (make-menu name attach-to) X (let* ((sh (create-popup-shell (find-class 'shell) attach-to)) X (menu (create-managed-widget name (find-class 'popup-manager) sh))) X menu)) X X(define (add-pane where title attach-to) X (let* ((sh (create-popup-shell (find-class 'shell) where)) X (pane (create-managed-widget (find-class 'cascade) sh))) X (set-values! pane 'title-string title 'attach-to attach-to) X pane)) X X(define (add-button where label) X (let ((b (create-managed-widget label (find-class 'menu-button) where))) X (set-values! b 'label label) X b)) X X(define (add-separator where style) X (let ((s (create-managed-widget (find-class 'menu-separator) where))) X (set-values! s 'separator-type style) X s)) X X(define con (create-context)) X(define dpy (initialize-display con #f 'menu 'demo)) X(define top (create-shell 'menu 'demo (find-class 'application-shell) dpy)) X X(define bb (create-managed-widget (find-class 'bboard) top)) X(define bb1 (create-managed-widget (find-class 'bboard) bb)) X(set-values! bb1 'width 300 'height 30 'layout "ignore") X(define bb2 (create-managed-widget (find-class 'bboard) bb)) X(set-values! bb2 'y 30 'width 300 'height 150) X X(define menu (make-menu 'menu bb2)) X X(define pane1 (add-pane menu "main menu" 'menu)) X X(add-button pane1 'search) X(add-button pane1 'change) X(add-button pane1 'create) X(add-button pane1 'destroy) X(define sep (add-separator pane1 "single_line")) X(add-button pane1 'help) X(add-button pane1 'quit) X X(define pane2 (add-pane menu "change menu" 'change)) X X(add-button pane2 'typeface) X(add-button pane2 'font) X(add-button pane2 'help) X X(define pane3 (add-pane menu "typeface menu" 'typeface)) X X(add-button pane3 'bold) X(add-button pane3 'italic) X(add-button pane3 'underlined) X(add-button pane3 'double\ underlined) X(add-button pane3 'crossed\ out) X(add-button pane3 'negative) X(add-button pane3 'faint) X X(define pane4 (add-pane menu "font menu" 'font)) X X(do ((i 0 (1+ i))) ((= i 10)) X (add-button pane4 (format #f "font #~s" i))) X X(add-callback (name->widget pane1 'quit) 'select (lambda (w) (exit))) X X(define (change-separator-style _) X (set-values! sep 'separator-type X (if (car (get-values t2 'set)) X (if (car (get-values t3 'set)) X "double_dashed_line" X "double_line") X (if (car (get-values t3 'set)) X "single_dashed_line" X "single_line")))) X X(define (change-sticky _) X (set-values! menu 'sticky-menus (car (get-values t1 'set)))) X X(define t1 (create-managed-widget (find-class 'toggle) bb1)) X(set-values! t1 'x 10 'y 10 'label "sticky") X(add-callback t1 'select change-sticky) X(add-callback t1 'release change-sticky) X X(define t2 (create-managed-widget (find-class 'toggle) bb1)) X(set-values! t2 'x 90 'y 10 'label 'double-line) X(add-callback t2 'select change-separator-style) X(add-callback t2 'release change-separator-style) X X(define t3 (create-managed-widget (find-class 'toggle) bb1)) X(set-values! t3 'x 190 'y 10 'label 'dashed-line) X(add-callback t3 'select change-separator-style) X(add-callback t3 'release change-separator-style) X X(realize-widget top) X(context-main-loop con) END_OF_lib/xt/examples/hp-menu if test 3228 -ne `wc -c lib/xt/Makefile <<'END_OF_lib/xt/Makefile' XH= ../../src/config.h\ X ../../src/object.h\ X ../../src/extern.h\ X ../../src/macros.h\ X ../util/objects.h\ X ../xlib/xlib.h\ X xt.h X XC= callback.c\ X class.c\ X context.c\ X converter.c\ X error.c\ X identifier.c\ X objects.c\ X popup.c\ X resource.c\ X translation.c\ X widget.c X XO= callback.o\ X class.o\ X context.o\ X converter.o\ X error.o\ X identifier.o\ X objects.o\ X popup.o\ X resource.o\ X translation.o\ X widget.o X Xall: ../xt.o ../xt-only.o X X../xt.o: $(O) ../xlib.o X ld -r -x $(O) -lXt ../xlib.o -lX11; mv a.out ../xt.o; chmod 644 ../xt.o X X../xt-only.o: $(O) X ld -r -x $(O); mv a.out ../xt-only.o; chmod 644 ../xt-only.o X Xcallback.o: $(H) Xclass.o: $(H) Xcontext.o: $(H) Xconverter.o: $(H) Xerror.o: $(H) Xidentifier.o: $(H) Xobjects.o: $(H) Xpopup.o: $(H) Xresource.o: $(H) Xtranslation.o: $(H) Xwidget.o: $(H) X Xlint: X lint $(LINTFLAGS) -abxh $(C) | egrep -v '\?\?\?' X Xclean: X rm -f *.o core a.out ../xt.o ../xt-only.o END_OF_lib/xt/Makefile if test 901 -ne `wc -c lib/xt/objects.c <<'END_OF_lib/xt/objects.c' X#include X X#include "xt.h" X XMatch_Xt_Obj (x, v) Object x; va_list v; { X register type = TYPE(x); X X if (type == T_Context) { X return va_arg (v, XtAppContext) == CONTEXT(x)->context; X } else if (type == T_Class) { X return va_arg (v, WidgetClass) == CLASS(x)->class; X } else if (type == T_Widget) { X return va_arg (v, Widget) == WIDGET(x)->widget; X } else if (type == T_Identifier) { X return va_arg (v, int) == IDENTIFIER(x)->type X && va_arg (v, caddr_t) == IDENTIFIER(x)->val; X } else Panic ("Match_Xt_Obj"); X return 0; X} END_OF_lib/xt/objects.c if test 556 -ne `wc -c lib/xt/error.c <<'END_OF_lib/xt/error.c' X#include "xt.h" X Xstatic Object V_Xt_Warning_Handler; X XXt_Warning (msg) char *msg; { X Object args, fun; X X args = Cons (Make_String (msg, strlen (msg)), Null); X fun = Val (V_Xt_Warning_Handler); X if (TYPE(fun) == T_Compound) X (void)Funcall (fun, args, 0); X Format (Curr_Output_Port, msg, strlen (msg), 0, (Object *)0); X P_Newline (0); X} X Xinit_xt_error () { X Define_Variable (&V_Xt_Warning_Handler, "xt-warning-handler", Null); X XtSetWarningHandler (Xt_Warning); X} END_OF_lib/xt/error.c if test 486 -ne `wc -c