From decwrl!sun-barr!cs.utexas.edu!uunet!allbery Fri Sep 29 09:58:13 PDT 1989 Article 1103 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: v08i061: Elk (Extension Language Toolkit) part 13 of 14 Message-ID: <68229@uunet.UU.NET> Date: 23 Sep 89 21:44:40 GMT Sender: allbery@uunet.UU.NET Reply-To: net@tub.UUCP (Oliver Laumann) Lines: 1911 Approved: allbery@uunet.UU.NET (Brandon S. Allbery - comp.sources.misc) Posting-number: Volume 8, Issue 61 Submitted-by: net@tub.UUCP (Oliver Laumann) Archive-name: elk/part13 [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/xt/class.c <<'END_OF_lib/xt/class.c' X#include "xt.h" X X#define MAX_CLASS 128 X#define MAX_CALLBACK_PER_CLASS 5 X Xtypedef struct { X char *name; X int has_arg; X} CALLBACK_INFO; X Xtypedef struct { X WidgetClass class; X char *name; X CALLBACK_INFO cb[MAX_CALLBACK_PER_CLASS], *cblast; X XtResourceList sub_resources; X int num_resources; X} CLASS_INFO; X Xstatic CLASS_INFO ctab[MAX_CLASS], *clast = ctab; X XGeneric_Predicate (Class); X XGeneric_Simple_Equal (Class, CLASS, class); X XGeneric_Print (Class, "#[class %s]", CLASS(x)->name); X XObject Make_Class (class, name) WidgetClass class; char *name; { X register char *p; X Object c; X X c = Find_Object (T_Class, (GENERIC)0, Match_Xt_Obj, class); X if (Nullp (c)) { X p = Get_Bytes (sizeof (struct S_Class)); X SET (c, T_Class, (struct S_Class *)p); X CLASS(c)->tag = Null; X CLASS(c)->class = class; X CLASS(c)->name = name; X Register_Object (c, (GENERIC)0, (PFO)0, 0); X } X return c; X} X XObject Make_Widget_Class (class) WidgetClass class; { X register CLASS_INFO *p; X X for (p = ctab; p < clast; p++) X if (p->class == class) X return Make_Class (class, p->name); X Primitive_Error ("undefined widget class"); X /*NOTREACHED*/ X} X Xstatic Object P_Find_Class (name) Object name; { X register char *s; X register CLASS_INFO *p; X X Make_C_String (name, s); X for (p = ctab; p < clast; p++) X if (streq (p->name, s)) X return Make_Class (p->class, p->name); X Primitive_Error ("no such widget class: ~s", name); X /*NOTREACHED*/ X} X Xstatic Object P_Class_Existsp (name) Object name; { X register char *s; X register CLASS_INFO *p; X X Make_C_String (name, s); X for (p = ctab; p < clast; p++) X if (streq (p->name, s)) X return True; X return False; X} X Xchar *Class_Name (class) WidgetClass class; { X register CLASS_INFO *p; X X for (p = ctab; p < clast && p->class != class; p++) X ; X if (p == clast) X return "unknown"; X return p->name; X} X Xvoid Get_Sub_Resource_List (class, rp, np) WidgetClass class; X XtResourceList *rp; int *np; { X register CLASS_INFO *p; X X for (p = ctab; p < clast && p->class != class; p++) X ; X if (p == clast) X Panic ("Get_Sub_Resource_List"); X *np = p->num_resources; X *rp = p->sub_resources; X} X Xstatic Object P_Class_Resources (c) Object c; { X Check_Type (c, T_Class); X return Get_Resources (CLASS(c)->class, XtGetResourceList, 1); X} X Xstatic Object P_Class_Constraint_Resources (c) Object c; { X Check_Type (c, T_Class); X return Get_Resources (CLASS(c)->class, XtGetConstraintResourceList, 1); X} X Xstatic Object P_Class_Sub_Resources (c) Object c; { X Check_Type (c, T_Class); X return Get_Resources (CLASS(c)->class, Get_Sub_Resource_List, 0); X} X XDefine_Class (name, class, r, nr) char *name; WidgetClass class; X XtResourceList r; { X Error_Tag = "define-class"; X if (clast == ctab+MAX_CLASS) X Primitive_Error ("too many widget classes"); X clast->name = name; X clast->class = class; X clast->cb[0].name = XtNdestroyCallback; X clast->cb[0].has_arg = 0; X clast->cblast = clast->cb+1; X clast->sub_resources = r; X clast->num_resources = nr; X clast++; X} X XDefine_Callback (cl, s, has_arg) char *cl, *s; { X register CLASS_INFO *p; X X Error_Tag = "define-callback"; X for (p = ctab; p < clast; p++) X if (streq (p->name, cl)) { X if (p->cblast == p->cb+MAX_CALLBACK_PER_CLASS) X Primitive_Error ("too many callbacks for this class"); X p->cblast->name = s; X p->cblast->has_arg = has_arg; X p->cblast++; X return; X } X Primitive_Error ("undefined class"); X} X XPFO Find_Callback_Converter (c, name, sname) WidgetClass c; char *name; X Object sname; { X register CLASS_INFO *p; X register CALLBACK_INFO *q; X PFO conv; X X for (p = ctab; p < clast; p++) X if (p->class == c) { X for (q = p->cb; q < p->cblast; q++) X if (streq (q->name, name)) { X if (q->has_arg) { X char s[128]; X sprintf (s, "%s-%s", p->name, name); X conv = Find_Converter_To_Scheme (s); X if (conv == 0) { X sprintf (s, "no callback converter for %s", name); X Primitive_Error (s); X } X return conv; X } else return (PFO)0; X } X Primitive_Error ("no such callback: ~s", sname); X } X Panic ("Find_Callback_Converter"); X /*NOTREACHED*/ X} X Xinit_xt_class () { X Generic_Define (Class, "class", "class?"); X Define_Primitive (P_Find_Class, "find-class", 1, 1, EVAL); X Define_Primitive (P_Class_Resources, "class-resources", 1, 1, EVAL); X Define_Primitive (P_Class_Constraint_Resources, X "class-constraint-resources", 1, 1, EVAL); X Define_Primitive (P_Class_Sub_Resources, X "class-sub-resources", 1, 1, EVAL); X Define_Primitive (P_Class_Existsp, "class-exists?", 1, 1, EVAL); X Define_Class ("core", widgetClass, (XtResourceList)0, 0); X Define_Class ("constraint", constraintWidgetClass, (XtResourceList)0, 0); X Define_Class ("composite", compositeWidgetClass, (XtResourceList)0, 0); X} END_OF_lib/xt/class.c if test 4967 -ne `wc -c lib/xt/xt.h <<'END_OF_lib/xt/xt.h' X#include "../xlib/xlib.h" X X#include X#include X#include X#include X Xtypedef XtArgVal (*PFX)(); X Xint T_Context; Xint T_Class; Xint T_Widget; Xint T_Identifier; X X#define CONTEXT(x) ((struct S_Context *)POINTER(x)) X#define CLASS(x) ((struct S_Class *)POINTER(x)) X#define WIDGET(x) ((struct S_Widget *)POINTER(x)) X#define IDENTIFIER(x) ((struct S_Identifier *)POINTER(x)) X Xstruct S_Context { X Object tag; X XtAppContext context; X char free; X}; X Xstruct S_Class { X Object tag; X WidgetClass class; X char *name; X}; X Xstruct S_Widget { X Object tag; X Widget widget; X char free; X}; X Xstruct S_Identifier { X Object tag; X char type; X caddr_t val; X int num; X char free; X}; X Xextern Match_Xt_Obj(); Xextern Object Make_Widget_Class(), Make_Context(), Make_Widget(); Xextern Object Get_Values(), Get_Resources(), Get_Callbackfun(); Xextern WidgetClass widgetClass; /* The `core' class */ Xextern WidgetClass constraintWidgetClass; Xextern WidgetClass compositeWidgetClass; Xextern caddr_t Use_Id(); Xextern Xt_Warning(); Xextern void XtGetResourceList(), XtGetConstraintResourceList(); Xextern void Destroy_Callback_Proc(); Xextern PFO Find_Callback_Converter(), Find_Converter_To_Scheme(); Xextern PFX Find_Converter_To_C(); Xextern char *Class_Name(); Xextern XtTranslations Get_Translations(); X X X#define Encode_Arglist(ac,av,to,widget,class) {\ X to = (Arg *)alloca (((ac)+1)/2 * sizeof (Arg));\ X Convert_Args (ac, av, to, widget, class);\ X} X X#define streq(a,b) (strcmp ((a), (b)) == 0) END_OF_lib/xt/xt.h if test 1570 -ne `wc -c lib/xt/callback.c <<'END_OF_lib/xt/callback.c' X#include "xt.h" X X#define MAX_CALLBACKS 512 X Xstatic Object Callbacks; X Xtypedef struct { X PFO converter; X int num; X} CLIENT_DATA; X XObject Get_Callbackfun (c) caddr_t c; { X register CLIENT_DATA *cd = (CLIENT_DATA *)c; X return cd ? VECTOR(Callbacks)->data[cd->num] : False; X} X Xstatic void Callback_Proc (w, client_data, call_data) Widget w; X caddr_t client_data, call_data; { X register CLIENT_DATA *cd = (CLIENT_DATA *)client_data; X Object args; X X args = Null; X if (cd->converter) X args = Cons ((cd->converter)((XtArgVal)call_data), args); X args = Cons (Make_Widget (w), args); X (void)Funcall (Get_Callbackfun (client_data), args, 0); X} X X/*ARGSUSED*/ Xvoid Destroy_Callback_Proc (w, client_data, call_data) Widget w; X caddr_t client_data, call_data; { X Object x; X X x = Find_Object (T_Widget, (GENERIC)0, Match_Xt_Obj, w); X if (Nullp (x) || WIDGET(x)->free) X return; X WIDGET(x)->free = 1; X Remove_All_Callbacks (w); X Deregister_Object (x); X} X X/* The code assumes that callbacks are called in the order they X * have been added. The Destroy_Callback_Proc() must always be X * the last callback in the destroy callback list of each widget. X * X * When the destroy callback list of a widget is modified X * (via P_Add_Callbacks or P_Set_Values), Fiddle_Destroy_Callback() X * must be called to remove the Destroy_Callback_Proc() and put X * it back to the end of the callback list. X */ XFiddle_Destroy_Callback (w) Widget w; { X XtRemoveCallback (w, XtNdestroyCallback, Destroy_Callback_Proc, (caddr_t)0); X XtAddCallback (w, XtNdestroyCallback, Destroy_Callback_Proc, (caddr_t)0); X} X XCheck_Callback_List (x) Object x; { X Object tail; X X Check_List (x); X for (tail = x; !Nullp (tail); tail = Cdr (tail)) X Check_Procedure (Car (tail)); X} X Xstatic Object P_Add_Callbacks (w, name, cbl) Object w, name, cbl; { X register char *s; X register n; X XtCallbackList callbacks; X X Check_Widget (w); X Check_Callback_List (cbl); X Make_C_String (name, s); X Make_Resource_Name (s); X n = Internal_Length (cbl); X callbacks = (XtCallbackRec *)alloca ((n+1) * sizeof (XtCallbackRec)); X callbacks[n].callback = 0; X callbacks[n].closure = 0; X Fill_Callbacks (cbl, callbacks, n, X Find_Callback_Converter (XtClass (WIDGET(w)->widget), s, name)); X XtAddCallbacks (WIDGET(w)->widget, s, callbacks); X if (streq (s, XtNdestroyCallback)) X Fiddle_Destroy_Callback (WIDGET(w)->widget); X return Void; X} X XFill_Callbacks (src, dst, n, conv) Object src; XtCallbackList dst; X register n; PFO conv; { X register CLIENT_DATA *cd; X register i, j; X Object tail; X GC_Node2; X X GC_Link2 (src, tail); X for (i = 0, tail = src; i < n; i++, tail = Cdr (tail)) { X Object fun = Car (tail); X for (j = 0; j < MAX_CALLBACKS; j++) X if (Nullp (VECTOR(Callbacks)->data[j])) break; X if (j == MAX_CALLBACKS) X Primitive_Error ("too many callbacks"); X VECTOR(Callbacks)->data[j] = fun; X cd = (CLIENT_DATA *)XtMalloc (sizeof (CLIENT_DATA)); X cd->converter = conv; X cd->num = j; X dst[i].callback = (XtCallbackProc)Callback_Proc; X dst[i].closure = (caddr_t)cd; X } X GC_Unlink; X} X Xstatic Remove_All_Callbacks (w) Widget w; { X Arg a[1]; X XtCallbackList c; X XtResource *r; X int nr, nc; X register i, j; X X Get_All_Resources (w, XtClass (w), &r, &nr, &nc); X for (j = 0; j < nr; j++) { X if (streq (r[j].resource_type, XtRCallback)) { X XtSetArg (a[0], r[j].resource_name, &c); X XtGetValues (w, a, ONE); X for (i = 0; c[i].callback; i++) { X register CLIENT_DATA *cd = (CLIENT_DATA *)c[i].closure; X if (c[i].callback == (XtCallbackProc)Callback_Proc && cd) { X VECTOR(Callbacks)->data[cd->num] = Null; X XtFree ((char *)cd); X } X } X } X } X XtFree ((char *)r); X} X Xinit_xt_callback () { X Callbacks = Make_Vector (MAX_CALLBACKS, Null); X Global_GC_Link (Callbacks); X Define_Primitive (P_Add_Callbacks, "add-callbacks", 3, 3, EVAL); X} END_OF_lib/xt/callback.c if test 3938 -ne `wc -c lib/xt/context.c <<'END_OF_lib/xt/context.c' X#include "xt.h" X X#define MAX_WORKPROCS 512 X#define MAX_TIMEOUTS 512 X Xstatic Object Workprocs, Timeouts; X Xstatic SYMDESCR XtIM_Syms[] = { X { "x-event", XtIMXEvent }, X { "timer", XtIMTimer }, X { "alternate-input", XtIMAlternateInput }, X { 0, 0 } X}; X Xstatic Object P_Destroy_Context(); X XGeneric_Predicate (Context); X XGeneric_Equal (Context, CONTEXT, context); X XGeneric_Print (Context, "#[context %u]", POINTER(x)); X XObject Make_Context (context) XtAppContext context; { X register char *p; X Object c; X X c = Find_Object (T_Context, (GENERIC)0, Match_Xt_Obj, context); X if (Nullp (c)) { X p = Get_Bytes (sizeof (struct S_Context)); X SET (c, T_Context, (struct S_Context *)p); X CONTEXT(c)->tag = Null; X CONTEXT(c)->context = context; X CONTEXT(c)->free = 0; X Register_Object (c, (GENERIC)0, P_Destroy_Context, 0); X XtAppSetWarningHandler (context, Xt_Warning); X } X return c; X} X Xstatic Check_Context (c) Object c; { X Check_Type (c, T_Context); X if (CONTEXT(c)->free) X Primitive_Error ("invalid context: ~s", c); X} X Xstatic Object P_Create_Context () { X /* Should read: X return Make_Context (XtCreateApplicationContext ()); X * but Xt is broken (timers are added to the wrong context). X */ X extern XtAppContext _XtDefaultAppContext(); X return Make_Context (_XtDefaultAppContext ()); X} X Xstatic Object P_Destroy_Context (c) Object c; { X Check_Context (c); X XtDestroyApplicationContext (CONTEXT(c)->context); X CONTEXT(c)->free = 1; X Deregister_Object (c); X return Void; X} X Xstatic Object P_Initialize_Display (c, d, name, class) X Object c, d, name, class; { X register char *sn, *sc, *sd = 0; X register t = TYPE(d); X Display *dpy; X extern char **Argv; X extern First_Arg, Argc; X int argc = Argc - First_Arg + 1; X X Argv[First_Arg-1] = "bogus"; /* Not actually used by Xt. Or is it? */ X Check_Context (c); X Make_C_String (name, sn); X Make_C_String (class, sc); X if (t == T_Display) { X XtDisplayInitialize (CONTEXT(c)->context, DISPLAY(d)->dpy, X sn, sc, (XrmOptionDescRec *)0, 0, &argc, &Argv[First_Arg-1]); X Argc = First_Arg + argc; X return Void; X } X if (Truep (d)) X Make_C_String (d, sd); X dpy = XtOpenDisplay (CONTEXT(c)->context, sd, sn, sc, X (XrmOptionDescRec *)0, 0, &argc, &Argv[First_Arg-1]); X Argc = First_Arg + argc - 1; X if (dpy == 0) X if (sd) X Primitive_Error ("cannot open display ~s", d); X else X Primitive_Error ("cannot open display"); X return Make_Display (0, dpy); X} X Xstatic Object P_Context_Main_Loop (c) Object c; { X Check_Context (c); X XtAppMainLoop (CONTEXT(c)->context); X /*NOTREACHED*/ X} X Xstatic Object P_Context_Pending (c) Object c; { X Check_Context (c); X return Bits_To_Symbols ((unsigned long)XtAppPending (CONTEXT(c)->context), X 1, XtIM_Syms); X} X Xstatic Object P_Context_Process_Event (argc, argv) Object *argv; { X XtInputMask mask = XtIMAll; X X Check_Context (argv[0]); X if (argc == 2) X mask = (XtInputMask)Symbols_To_Bits (argv[1], 1, XtIM_Syms); X XtAppProcessEvent (CONTEXT(argv[0])->context, mask); X return Void; X} X Xstatic Work_Proc (client_data) caddr_t client_data; { X Object ret = Funcall (VECTOR(Workprocs)->data[(int)client_data], Null, 0); X if (Truep (ret)) X VECTOR(Workprocs)->data[(int)client_data] = Null; X return Truep (ret); X} X Xstatic Object P_Context_Add_Work_Proc (c, p) Object c, p; { X XtWorkProcId id; X register i; X X Check_Context (c); X Check_Procedure (p); X for (i = 0; i < MAX_WORKPROCS; i++) X if (Nullp (VECTOR(Workprocs)->data[i])) break; X if (i == MAX_WORKPROCS) X Primitive_Error ("too many work procs"); X VECTOR(Workprocs)->data[i] = p; X id = XtAppAddWorkProc (CONTEXT(c)->context, Work_Proc, (caddr_t)i); X return Make_Id ('w', (caddr_t)id, i); X} X Xstatic Object P_Remove_Work_Proc (id) Object id; { X XtRemoveWorkProc ((XtWorkProcId)Use_Id (id, 'w')); X VECTOR(Workprocs)->data[IDENTIFIER(id)->num] = Null; X return Void; X} X Xstatic Timeout_Proc (client_data, id) caddr_t client_data; XtIntervalId *id; { X Object proc, args; X X args = Cons (Make_Id ('t', (caddr_t)*id, 0), Null); X proc = VECTOR(Timeouts)->data[(int)client_data]; X VECTOR(Timeouts)->data[(int)client_data] = Null; X (void)Funcall (proc, args, 0); X} X Xstatic Object P_Context_Add_Timeout (c, n, p) Object c, n, p; { X XtIntervalId id; X register i; X X Check_Context (c); X Check_Procedure (p); X for (i = 0; i < MAX_TIMEOUTS; i++) X if (Nullp (VECTOR(Timeouts)->data[i])) break; X if (i == MAX_TIMEOUTS) X Primitive_Error ("too many timeouts"); X VECTOR(Timeouts)->data[i] = p; X id = XtAppAddTimeOut (CONTEXT(c)->context, Get_Integer (n), Timeout_Proc, X (caddr_t)i); X return Make_Id ('t', (caddr_t)id, i); X} X Xstatic Object P_Remove_Timeout (id) Object id; { X XtRemoveTimeOut ((XtIntervalId)Use_Id (id, 't')); X VECTOR(Timeouts)->data[IDENTIFIER(id)->num] = Null; X return Void; X} X Xinit_xt_context () { X Workprocs = Make_Vector (MAX_WORKPROCS, Null); X Global_GC_Link (Workprocs); X Timeouts = Make_Vector (MAX_TIMEOUTS, Null); X Global_GC_Link (Timeouts); X Generic_Define (Context, "context", "context?"); X Define_Primitive (P_Create_Context, "create-context", 0, 0, EVAL); X Define_Primitive (P_Destroy_Context, "destroy-context", 1, 1, EVAL); X Define_Primitive (P_Initialize_Display, "initialize-display", 4, 4, EVAL); X Define_Primitive (P_Context_Main_Loop, "context-main-loop", 1, 1, EVAL); X Define_Primitive (P_Context_Pending, "context-pending", 1, 1, EVAL); X Define_Primitive (P_Context_Process_Event, "context-process-event", X 1, 2, VARARGS); X Define_Primitive (P_Context_Add_Work_Proc, "context-add-work-proc", X 2, 2, EVAL); X Define_Primitive (P_Remove_Work_Proc, "remove-work-proc", 1, 1, EVAL); X Define_Primitive (P_Context_Add_Timeout,"context-add-timeout",3, 3, EVAL); X Define_Primitive (P_Remove_Timeout, "remove-timeout", 1, 1, EVAL); X XtToolkitInitialize (); X P_Provide (Intern ("xt.o")); X} END_OF_lib/xt/context.c if test 6094 -ne `wc -c lib/xt/translation.c <<'END_OF_lib/xt/translation.c' X#include "xt.h" X XXtTranslations Get_Translations (t) Object t; { X register char *s; X XtTranslations ret; X X Make_C_String (t, s); X if ((ret = XtParseTranslationTable (s)) == 0) X Primitive_Error ("bad translation table: ~s", t); X return ret; X} X Xstatic Object P_Augment_Translations (w, t) Object w, t; { X Check_Widget (w); X XtAugmentTranslations (WIDGET(w)->widget, Get_Translations (t)); X return Void; X} X Xstatic Object P_Override_Translations (w, t) Object w, t; { X Check_Widget (w); X XtOverrideTranslations (WIDGET(w)->widget, Get_Translations (t)); X return Void; X} X Xstatic Object P_Uninstall_Translations (w) Object w; { X Check_Widget (w); X XtUninstallTranslations (WIDGET(w)->widget); X return Void; X} X Xinit_xt_translation () { X Define_Primitive (P_Augment_Translations, "augment-translations", X 2, 2, EVAL); X Define_Primitive (P_Override_Translations, "override-translations", X 2, 2, EVAL); X Define_Primitive (P_Uninstall_Translations, "uninstall-translations", X 1, 1, EVAL); X} END_OF_lib/xt/translation.c if test 1039 -ne `wc -c lib/xt/widget.c <<'END_OF_lib/xt/widget.c' X#include "xt.h" X Xextern void XtManageChildren(), XtUnmanageChildren(); X Xstatic Object P_Destroy_Widget(); X XGeneric_Predicate (Widget); X XGeneric_Equal (Widget, WIDGET, widget); X XGeneric_Print (Widget, "#[widget %u]", POINTER(x)); X XObject Make_Widget (widget) Widget widget; { X register char *p; X Object w; X X if (widget == 0) X return Sym_None; X w = Find_Object (T_Widget, (GENERIC)0, Match_Xt_Obj, widget); X if (Nullp (w)) { X p = Get_Bytes (sizeof (struct S_Widget)); X SET (w, T_Widget, (struct S_Widget *)p); X WIDGET(w)->tag = Null; X WIDGET(w)->widget = widget; X WIDGET(w)->free = 0; X XtAddCallback (widget, XtNdestroyCallback, Destroy_Callback_Proc, X (caddr_t)0); X Register_Object (w, (GENERIC)0, P_Destroy_Widget, 0); X } X return w; X} X XCheck_Widget (w) Object w; { X Check_Type (w, T_Widget); X if (WIDGET(w)->free) X Primitive_Error ("invalid widget: ~s", w); X} X XCheck_Widget_Class (w, class) Object w; WidgetClass class; { X Check_Widget (w); X if (XtClass (WIDGET(w)->widget) != class) X Primitive_Error ("widget not of expected class: ~s", w); X} X Xstatic Object P_Destroy_Widget (w) Object w; { X Check_Widget (w); X XtDestroyWidget (WIDGET(w)->widget); X return Void; X} X Xstatic Object P_Create_Shell (argc, argv) Object *argv; { X register char *sn, *sc; X ArgList a; X Object name = argv[0], class = argv[1], w = argv[2], d = argv[3]; X X Make_C_String (name, sn); X Make_C_String (class, sc); X Check_Type (w, T_Class); X Check_Type (d, T_Display); X Encode_Arglist (argc-4, argv+4, a, (Widget)0, CLASS(w)->class); X return Make_Widget (XtAppCreateShell (sn, sc, CLASS(w)->class, X DISPLAY(d)->dpy, a, (Cardinal)(argc-4)/2)); X} X Xstatic Object P_Create_Widget (argc, argv) Object *argv; { X ArgList a; X char *name = 0; X Object x = argv[0], class, parent; X X if (TYPE(x) != T_Class) { X Make_C_String (x, name); X argv++; argc--; X } X class = argv[0]; X parent = argv[1]; X Check_Type (class, T_Class); X Check_Widget (parent); X if (name == 0) X name = CLASS(class)->name; X Encode_Arglist (argc-2, argv+2, a, (Widget)0, CLASS(class)->class); X return Make_Widget (XtCreateWidget ((String)name, CLASS(class)->class, X WIDGET(parent)->widget, a, (Cardinal)(argc-2)/2)); X} X Xstatic Object P_Realize_Widget (w) Object w; { X Check_Widget (w); X XtRealizeWidget (WIDGET(w)->widget); X return Void; X} X Xstatic Object P_Unrealize_Widget (w) Object w; { X Check_Widget (w); X XtUnrealizeWidget (WIDGET(w)->widget); X return Void; X} X Xstatic Object P_Widget_Realizedp (w) Object w; { X Check_Widget (w); X return XtIsRealized (WIDGET(w)->widget) ? True : False; X} X Xstatic Object P_Widget_Display (w) Object w; { X Check_Widget (w); X return Make_Display (0, XtDisplay (WIDGET(w)->widget)); X} X Xstatic Object P_Widget_Parent (w) Object w; { X Check_Widget (w); X return Make_Widget (XtParent (WIDGET(w)->widget)); X} X Xstatic Object P_Widget_Window (w) Object w; { X Check_Widget (w); X return Make_Window (0, XtDisplay (WIDGET(w)->widget), X XtWindow (WIDGET(w)->widget)); X} X Xstatic Object P_Widget_Compositep (w) Object w; { X Check_Widget (w); X return XtIsComposite (WIDGET(w)->widget) ? True : False; X} X Xstatic Object Manage_Unmanage (children, f) Object children; void (*f)(); { X register i, n; X Widget *buf; X Object tail; X X Check_List (children); X n = Internal_Length (children); X buf = (Widget *)alloca (n * sizeof (Widget)); X for (i = 0, tail = children; i < n; i++, tail = Cdr (tail)) { X Object w = Car (tail); X Check_Widget (w); X buf[i] = WIDGET(w)->widget; X } X f (buf, n); X return Void; X} X Xstatic Object P_Manage_Children (children) Object children; { X return Manage_Unmanage (children, XtManageChildren); X} X Xstatic Object P_Unmanage_Children (children) Object children; { X return Manage_Unmanage (children, XtUnmanageChildren); X} X Xstatic Object P_Widget_Managedp (w) Object w; { X Check_Widget (w); X return XtIsManaged (WIDGET(w)->widget) ? True : False; X} X Xstatic Object P_Widget_Class (w) Object w; { X Check_Widget (w); X return Make_Widget_Class (XtClass (WIDGET(w)->widget)); X} X Xstatic Object P_Widget_Superclass (w) Object w; { X Check_Widget (w); X if (XtClass (WIDGET(w)->widget) == widgetClass) X return Sym_None; X return Make_Widget_Class (XtSuperclass (WIDGET(w)->widget)); X} X Xstatic Object P_Widget_Subclassp (w, c) Object w, c; { X Check_Widget (w); X Check_Type (c, T_Class); X return XtIsSubclass (WIDGET(w)->widget, CLASS(c)->class) ? True : False; X} X Xstatic Object P_Set_Mapped_When_Managed (w, m) Object w, m; { X Check_Widget (w); X Check_Type (m, T_Boolean); X XtSetMappedWhenManaged (WIDGET(w)->widget, EQ(m, True)); X return Void; X} X Xstatic Object P_Map_Widget (w) Object w; { X Check_Widget (w); X XtMapWidget (WIDGET(w)->widget); X return Void; X} X Xstatic Object P_Unmap_Widget (w) Object w; { X Check_Widget (w); X XtUnmapWidget (WIDGET(w)->widget); X return Void; X} X Xstatic Object P_Set_Values (argc, argv) Object *argv; { X ArgList a; X Widget w; X register i, n = (argc-1)/2; X X Check_Widget (argv[0]); X w = WIDGET(argv[0])->widget; X Encode_Arglist (argc-1, argv+1, a, w, XtClass (w)); X XtSetValues (w, a, (Cardinal)n); X for (i = 0; i < n; i++) X if (streq (a[i].name, XtNdestroyCallback)) X Fiddle_Destroy_Callback (w); X return Void; X} X Xstatic Object P_Get_Values (argc, argv) Object *argv; { X Widget w; X X Check_Widget (argv[0]); X w = WIDGET(argv[0])->widget; X return Get_Values (w, argc-1, argv+1); X} X Xstatic Object P_Widget_Context (w) Object w; { X Check_Widget (w); X return Make_Context (XtWidgetToApplicationContext (WIDGET(w)->widget)); X} X Xstatic Object P_Set_Sensitive (w, s) Object w, s; { X Check_Widget (w); X Check_Type (s, T_Boolean); X XtSetSensitive (WIDGET(w)->widget, EQ(s, True)); X return Void; X} X Xstatic Object P_Sensitivep (w) Object w; { X Check_Widget (w); X return XtIsSensitive (WIDGET(w)->widget) ? True : False; X} X Xstatic Object P_Window_To_Widget (w) Object w; { X Check_Type (w, T_Window); X return Make_Widget (XtWindowToWidget (WINDOW(w)->dpy, X WIDGET(w)->widget)); X} X Xstatic Object P_Name_To_Widget (root, name) Object root, name; { X register char *s; X X Check_Widget (root); X Make_C_String (name, s); X return Make_Widget (XtNameToWidget (WIDGET(root)->widget, s)); X} X Xinit_xt_widget () { X Generic_Define (Widget, "widget", "widget?"); X Define_Primitive (P_Destroy_Widget, "destroy-widget", 1, 1, EVAL); X Define_Primitive (P_Create_Shell, "create-shell", 4, MANY, VARARGS); X Define_Primitive (P_Create_Widget, "create-widget", 2, MANY, VARARGS); X Define_Primitive (P_Realize_Widget, "realize-widget", 1, 1, EVAL); X Define_Primitive (P_Unrealize_Widget, "unrealize-widget", 1, 1, EVAL); X Define_Primitive (P_Widget_Realizedp, "widget-realized?", 1, 1, EVAL); X Define_Primitive (P_Widget_Display, "widget-display", 1, 1, EVAL); X Define_Primitive (P_Widget_Parent, "widget-parent", 1, 1, EVAL); X Define_Primitive (P_Widget_Window, "widget-window", 1, 1, EVAL); X Define_Primitive (P_Widget_Compositep, "widget-composite?", 1, 1, EVAL); X Define_Primitive (P_Manage_Children, "manage-children", 1, 1, EVAL); X Define_Primitive (P_Unmanage_Children, "unmanage-children", 1, 1, EVAL); X Define_Primitive (P_Widget_Managedp, "widget-managed?", 1, 1, EVAL); X Define_Primitive (P_Widget_Class, "widget-class", 1, 1, EVAL); X Define_Primitive (P_Widget_Superclass, "widget-superclass", 1, 1, EVAL); X Define_Primitive (P_Widget_Subclassp, "widget-subclass?", 2, 2, EVAL); X Define_Primitive (P_Set_Mapped_When_Managed, X "set-mapped-when-managed!", 2, 2, EVAL); X Define_Primitive (P_Map_Widget, "map-widget", 1, 1, EVAL); X Define_Primitive (P_Unmap_Widget, "unmap-widget", 1, 1, EVAL); X Define_Primitive (P_Set_Values, "set-values!", 1, MANY, VARARGS); X Define_Primitive (P_Get_Values, "get-values", 1, MANY, VARARGS); X Define_Primitive (P_Widget_Context, "widget-context", 1, 1, EVAL); X Define_Primitive (P_Set_Sensitive, "set-sensitive!", 2, 2, EVAL); X Define_Primitive (P_Sensitivep, "widget-sensitive?", 1, 1, EVAL); X Define_Primitive (P_Window_To_Widget, "window->widget", 1, 1, EVAL); X Define_Primitive (P_Name_To_Widget, "name->widget", 2, 2, EVAL); X} END_OF_lib/xt/widget.c if test 8487 -ne `wc -c lib/xt/make-widget <<'END_OF_lib/xt/make-widget' X;;; -*-Scheme-*- X X(define type-name #f) X X(define classes ()) X(define callbacks ()) X(define primitives ()) X(define converters ()) X X(define f) X X(define (check-string proc x name) X (if (not (memq (type x) '(symbol string))) X (error proc (format #f "~s must be string or symbol" name)))) X X(define (define-widget-type name include . prolog) X (if type-name X (error 'define-widget-type "must be called once")) X (check-string 'define-widget-type name 'name) X (check-string 'define-widget-type include 'include) X (set! type-name name) X (format f "#include \"../xt/xt.h\"~%") X (case widget-set X (xhp X (format f "#include ~%"))) X (case widget-set X (xaw X (format f "#include ~%~%" include)) X (xhp X (format f "#include ~%~%" include))) X (if prolog X (begin X (check-string 'define-widget-type (car prolog) 'prolog) X (display (car prolog) f) X (format f "~%~%")))) X X(define (define-callback class name has-arg?) X (check-string 'define-callback class 'class) X (check-string 'define-callback name 'name) X (if (not (boolean? has-arg?)) X (error 'define-callback "has-arg? must be boolean")) X (set! callbacks (cons (list class name has-arg?) callbacks))) X X(define (c->scheme name body) X (check-string 'c->scheme name 'name) X (define c-name (scheme-to-c-name name)) X (string-set! c-name 0 #\S) X (format f "static Object ~a (x) XtArgVal x; {~%" c-name) X (display body f) X (format f "~%}~%~%") X (define s X (format #f " Define_Converter_To_Scheme (\"~a\", ~a);~%" X name c-name)) X (set! converters (cons s converters))) X X(define (scheme->c name body) X (check-string 'scheme->c name 'name) X (define c-name (scheme-to-c-name name)) X (string-set! c-name 0 #\C) X (format f "static XtArgVal ~a (x) Object x; {~%" c-name) X (display body f) X (format f "~%}~%~%") X (define s X (format #f " Define_Converter_To_C (\"~a\", ~a);~%" X name c-name)) X (set! converters (cons s converters))) X X(define (define-primitive scheme-name args body) X (check-string 'define-primitive scheme-name 'scheme-name) X (if (not (pair? args)) X (error 'define-primitive "args must be a list")) X (define c-name (scheme-to-c-name scheme-name)) X (format f "static Object ~a (" c-name) X (do ((a args a)) ((null? a)) X (display (car a) f) X (set! a (cdr a)) X (if a (display ", " f))) X (display ") " f) X (if args X (begin X (display "Object " f) X (do ((a args a)) ((null? a)) X (display (car a) f) X (set! a (cdr a)) X (if a (display ", " f))) X (display "; {" f))) X (newline f) X (display body f) X (format f "~%}~%~%") X (define s X (format #f " Define_Primitive (~a, \"~a\", ~a, ~a, EVAL);~%" X c-name scheme-name (length args) (length args))) X (set! primitives (cons s primitives))) X X;;; [missing conversion from -> to "to"] X(define (scheme-to-c-name s) X (if (symbol? s) X (set! s (symbol->string s))) X (define len (string-length s)) X (if (char=? (string-ref s (1- len)) #\?) X (string-set! s (1- len) #\p)) X (if (char=? (string-ref s (1- len)) #\!) X (set! len (1- len))) X (let loop ((ret "P") (i 0)) X (if (>= i len) X ret X (define next X (do ((j i (1+ j))) ((or (= j len) (char=? (string-ref s j) #\-)) j))) X (loop (format #f "~a_~a~a" ret (char-upcase (string-ref s i)) X (substring s (1+ i) next)) (1+ next))))) X X(define (define-widget-class name class . sub-resources) X (check-string 'define-widget-class name 'name) X (check-string 'define-widget-class class 'class) X (set! classes (cons (list name class sub-resources) classes))) X X(define args (command-line-args)) X(if (not (= (length args) 3)) X (error 'make-widget "expected three arguments")) X(define widget-set (string->symbol (caddr args))) X(set! f (open-output-file (cadr args))) X(load (car args)) X(if (not type-name) X (error 'make-widget "no widget type defined")) X(if (null? classes) X (error 'make-widget "no class definitions")) X(format f "init_~a () {~%" type-name) X(format f " XtResourceList r = 0;~%") X(do ((c classes (cdr c))) ((null? c)) X (define cl (car c)) X (define res (caddr cl)) X (if res X (begin X (format f X " r = (XtResourceList)XtMalloc (~a * sizeof (XtResource));~%" X (length res)) X (do ((r res (cdr r)) (num 0 (1+ num))) ((null? r)) X (define x (car r)) X (if (not (= (length x) 3)) X (error 'make-widget "bad sub-resource declaration")) X (for-each X (lambda (r) X (if (not (memq (type r) '(symbol string))) X (error 'make-widget "bad type in sub-resource declaration"))) X x) X (format f " r[~a].resource_name = \"~a\";~%" num (car x)) X (format f " r[~a].resource_class = \"~a\";~%" num (cadr x)) X (format f " r[~a].resource_type = \"~a\";~%" num (caddr x))))) X (format f " Define_Class (\"~a\", ~a, r, ~a);~%" (car cl) (cadr cl) X (length res))) X(do ((c callbacks (cdr c))) ((null? c)) X (define cb (car c)) X (format f " Define_Callback (\"~a\", \"~a\", ~a);~%" (car cb) (cadr cb) X (if (caddr cb) 1 0))) X(for-each (lambda (x) (display x f)) primitives) X(for-each (lambda (x) (display x f)) converters) X(format f "}~%") END_OF_lib/xt/make-widget if test 5113 -ne `wc -c lib/xt/converter.c <<'END_OF_lib/xt/converter.c' X#include "xt.h" X X#define MAX_CONVERTER 32 X Xtypedef struct { X char *name; X int scheme_to_c; X PFO to_scheme; X PFX to_c; X} CONVERTER; X Xstatic CONVERTER ctab[MAX_CONVERTER], *clast = ctab; X XDefine_Converter_To_Scheme (name, c) char *name; PFO c; { X Error_Tag = "c->scheme"; X if (clast == ctab+MAX_CONVERTER) X Primitive_Error ("too many converters"); X clast->name = name; X clast->scheme_to_c = 0; X clast->to_scheme = c; X clast++; X} X XDefine_Converter_To_C (name, c) char *name; PFX c; { X Error_Tag = "scheme->c"; X if (clast == ctab+MAX_CONVERTER) X Primitive_Error ("too many converters"); X clast->name = name; X clast->scheme_to_c = 1; X clast->to_c = c; X clast++; X} X XPFO Find_Converter_To_Scheme (name) char *name; { X register CONVERTER *p; X X for (p = ctab; p < clast; p++) X if (!p->scheme_to_c && streq (p->name, name)) X return p->to_scheme; X return 0; X} X XPFX Find_Converter_To_C (name) char *name; { X register CONVERTER *p; X X for (p = ctab; p < clast; p++) X if (p->scheme_to_c && streq (p->name, name)) X return p->to_c; X return 0; X} END_OF_lib/xt/converter.c if test 1104 -ne `wc -c lib/xt/popup.c <<'END_OF_lib/xt/popup.c' X#include "xt.h" X Xstatic SYMDESCR Grab_Kind_Syms[] = { X { "grab-none", XtGrabNone }, X { "grab-nonexclusive", XtGrabNonexclusive }, X { "grab-exclusive", XtGrabExclusive }, X { 0, 0 } X}; X Xstatic Object P_Create_Popup_Shell (argc, argv) Object *argv; { X ArgList a; X char *name = 0; X Object x = argv[0], class, parent; X X if (TYPE(x) != T_Class) { X Make_C_String (x, name); X argv++; argc--; X } X class = argv[0]; X parent = argv[1]; X Check_Type (class, T_Class); X Check_Widget (parent); X if (name == 0) X name = CLASS(class)->name; X Encode_Arglist (argc-2, argv+2, a, (Widget)0, CLASS(class)->class); X return Make_Widget (XtCreatePopupShell (name, CLASS(class)->class, X WIDGET(parent)->widget, a, (Cardinal)(argc-2)/2)); X} X Xstatic Object P_Popup (shell, grab_kind) Object shell, grab_kind; { X Check_Widget (shell); X XtPopup (WIDGET(shell)->widget, Symbols_To_Bits (grab_kind, 0, X Grab_Kind_Syms)); X return Void; X} X Xstatic Object P_Popdown (shell) Object shell; { X Check_Widget (shell); X XtPopdown (WIDGET(shell)->widget); X return Void; X} X Xinit_xt_popup () { X Define_Primitive (P_Create_Popup_Shell, "create-popup-shell", X 2, MANY, VARARGS); X Define_Primitive (P_Popup, "popup", 2, 2, EVAL); X Define_Primitive (P_Popdown, "popdown", 1, 1, EVAL); X} END_OF_lib/xt/popup.c if test 1335 -ne `wc -c lib/xt/resource.c <<'END_OF_lib/xt/resource.c' X#include "xt.h" X#include X X#include X Xstatic SYMDESCR Orientation_Syms[] = { X { "horizontal", XtorientHorizontal }, X { "vertical", XtorientVertical }, X { 0, 0 } X}; X Xstatic SYMDESCR Justify_Syms[] = { X { "left", XtJustifyLeft }, X { "center", XtJustifyCenter }, X { "right", XtJustifyRight }, X { 0, 0 } X}; X X#define XtRFloat "Float" X#define XtRWidget "Widget" X X#define T_Unknown -1 X#define T_String_Or_Symbol -2 X#define T_Callbacklist -3 X#define T_Float -4 X#define T_Backing_Store -5 X#define T_Orientation -6 X#define T_Justify -7 X#define T_Translations -8 X Xstatic Resource_To_Scheme_Type (t) register char *t; { X if (streq (XtRBackingStore, t)) X return T_Backing_Store; X else if (streq (XtRBoolean, t)) X return T_Boolean; X else if (streq (XtRCallback, t)) X return T_Callbacklist; X else if (streq (XtRCursor, t)) X return T_Cursor; X else if (streq (XtRDimension, t)) X return T_Fixnum; X else if (streq (XtRDisplay, t)) X return T_Display; X else if (streq (XtRFloat, t)) X return T_Float; X else if (streq (XtRFont, t)) X return T_Font; X else if (streq (XtRFontStruct, t)) X return T_Font; X else if (streq (XtRInt, t)) X return T_Fixnum; X else if (streq (XtRJustify, t)) X return T_Justify; X else if (streq (XtROrientation, t)) X return T_Orientation; X else if (streq (XtRPixel, t)) X return T_Pixel; X else if (streq (XtRPixmap, t)) X return T_Pixmap; X else if (streq (XtRPosition, t)) X return T_Fixnum; X else if (streq (XtRShort, t)) X return T_Fixnum; X else if (streq (XtRString, t)) X return T_String_Or_Symbol; X else if (streq (XtRTranslationTable, t)) X return T_Translations; X else if (streq (XtRUnsignedChar, t)) X return T_Character; X else if (streq (XtRWidget, t)) X return T_Widget; X else if (streq (XtRWindow, t)) X return T_Window; X return T_Unknown; X} X XGet_All_Resources (w, c, rp, np, cp) Widget w; WidgetClass c; X XtResource **rp; int *np, *cp; { X XtResource *r, *sr, *cr; X int nr, snr = 0, cnr = 0; X X XtGetResourceList (c, &r, &nr); X if (w == 0) /* Not allowed with get-values and set-values! */ X Get_Sub_Resource_List (c, &sr, &snr); X if (w && XtParent (w)) X XtGetConstraintResourceList (XtClass (XtParent (w)), &cr, &cnr); X *np = nr + snr + cnr; X *cp = cnr; X *rp = (XtResource *)XtMalloc (*np * sizeof (XtResource)); X bcopy ((char *)r, (char *)*rp, nr * sizeof (XtResource)); X XtFree ((char *)r); X if (snr) X bcopy ((char *)sr, (char *)(*rp + nr), snr * sizeof (XtResource)); X if (cnr) { X bcopy ((char *)cr, (char *)(*rp + nr+snr), cnr * sizeof (XtResource)); X XtFree ((char *)cr); X } X} X XConvert_Args (ac, av, to, widget, class) Object *av; ArgList to; X Widget widget; WidgetClass class; { X register char *name, *res; X register i, j, k; X Object arg, val; X XtResource *r; X int nr, nc; X int st, dt; X char key[128]; X PFX converter; X X if (ac & 1) X Primitive_Error ("missing argument value"); X Get_All_Resources (widget, class, &r, &nr, &nc); X /* Note: X * `r' is not freed in case of error. X */ X for (i = k = 0; k < ac; i++, k++) { X arg = av[k]; X Make_C_String (arg, name); X Make_Resource_Name (name); X for (j = 0; j < nr && !streq (name, r[j].resource_name); j++) X ; X if (j == nr) X Primitive_Error ("no such resource: ~s", arg); X res = r[j].resource_name; X val = av[++k]; X st = TYPE(val); X dt = Resource_To_Scheme_Type (r[j].resource_type); X X if (widget && j >= nr-nc) X class = XtClass (XtParent (widget)); X sprintf (key, "%s-%s", Class_Name (class), name); X converter = Find_Converter_To_C (key); X X if (converter) { X XtArgVal ret = converter (val); X XtSetArg (to[i], res, ret); X } else if (dt == T_String_Or_Symbol) { X char *s; X X Make_C_String (val, s); X XtSetArg (to[i], res, XtNewString (s)); /* Never freed! */ X } else if (dt == T_Callbacklist) { X int n; X XtCallbackList callbacks; X X Check_Callback_List (val); X n = Internal_Length (val); X callbacks = (XtCallbackRec *) /* Never freed! */ X XtMalloc ((n+1) * sizeof (XtCallbackRec)); X callbacks[n].callback = 0; X callbacks[n].closure = 0; X Fill_Callbacks (val, callbacks, n, X Find_Callback_Converter (class, name, arg)); X XtSetArg (to[i], res, callbacks); X } else if (dt == T_Float) { X float f = (float)Get_Double (val); X to[i].name = res; X bcopy ((char *)&f, (char *)&to[i].value, sizeof f); X } else if (dt == T_Backing_Store) { X XtSetArg (to[i], res, Symbols_To_Bits (val, 0, X Backing_Store_Syms)); X } else if (dt == T_Orientation) { X XtSetArg (to[i], res, Symbols_To_Bits (val, 0, Orientation_Syms)); X } else if (dt == T_Justify) { X XtSetArg (to[i], res, Symbols_To_Bits (val, 0, Justify_Syms)); X } else if (dt == T_Translations) { X XtSetArg (to[i], res, Get_Translations (val)); X } else { X if (st != dt) { X char msg[128]; X if (widget && (st == T_String || st == T_Symbol)) { X char *s; X XrmValue src, dst; X X Make_C_String (val, s); X src.size = strlen (s); X src.addr = (caddr_t)s; X XtConvert (widget, (String)XtRString, &src, X r[j].resource_type, &dst); X if (dst.addr) { X XtSetArg (to[i], res, *(XtArgVal *)dst.addr); X goto done; X } X } X sprintf (msg, "%s: can't convert %s ~s to %s", name, X Types[st].name, r[j].resource_type); X Primitive_Error (msg, val); X } X if (dt == T_Boolean) { X XtSetArg (to[i], res, EQ(val, True)); X } else if (dt == T_Cursor) { X XtSetArg (to[i], res, CURSOR(val)->cursor); X } else if (dt == T_Fixnum) { X XtSetArg (to[i], res, FIXNUM(val)); X } else if (dt == T_Display) { X XtSetArg (to[i], res, DISPLAY(val)->dpy); X } else if (dt == T_Font) { X Open_Font_Maybe (val); X if (streq (r[j].resource_type, XtRFontStruct)) X XtSetArg (to[i], res, FONT(val)->info); X else X XtSetArg (to[i], res, FONT(val)->id); X } else if (dt == T_Pixel) { X XtSetArg (to[i], res, PIXEL(val)->pix); X } else if (dt == T_Pixmap) { X XtSetArg (to[i], res, PIXMAP(val)->pm); X } else if (dt == T_Character) { X XtSetArg (to[i], res, CHAR(val)); X } else if (dt == T_Widget) { X XtSetArg (to[i], res, WIDGET(val)->widget); X } else if (dt == T_Window) { X XtSetArg (to[i], res, WINDOW(val)->win); X } else Panic ("bad conversion type"); X } Xdone: ; X } X XtFree ((char *)r); X} X XObject Get_Values (w, ac, av) Widget w; Object *av; { X register char *name; X register i, j; X Object arg; X XtResource *r; X int nr, nc; X int t; X ArgList argl; X Object ret, tail; X Display *dpy; X char key[128]; X PFO converter; X Widget w2; X GC_Node2; X X argl = (Arg *)alloca (ac * sizeof (Arg)); X Get_All_Resources (w, XtClass (w), &r, &nr, &nc); X /* Note: X * `r' is not freed in case of error. X */ X for (i = 0; i < ac; i++) { X arg = av[i]; X Check_Type (arg, T_Symbol); X Make_C_String (arg, name); X Make_Resource_Name (name); X for (j = 0; j < nr && !streq (name, r[j].resource_name); j++) X ; X if (j == nr) X Primitive_Error ("no such resource: ~s", arg); X argl[i].name = name; X argl[i].value = (XtArgVal)alloca (r[j].resource_size); X } X XtGetValues (w, argl, (Cardinal)ac); X ret = tail = P_Make_List (Make_Fixnum (ac), Null); X GC_Link2 (ret, tail); X /* X * Display is needed for resources like cursor and pixmap. X * XtDisplay(w) is not necessarily the right one! X */ X dpy = XtDisplay (w); X for (i = 0; i < ac; i++, tail = Cdr (tail)) { X Object o; X XtArgVal val = argl[i].value; X for (j = 0; j < nr && !streq (argl[i].name, r[j].resource_name); j++) X ; X t = Resource_To_Scheme_Type (r[j].resource_type); X X w2 = (j >= nr-nc) ? XtParent (w) : w; X sprintf (key, "%s-%s", Class_Name (XtClass (w2)), argl[i].name); X converter = Find_Converter_To_Scheme (key); X X if (converter) { X o = converter (*(XtArgVal **)val); X } else if (t == T_String_Or_Symbol) { X char *s = *(char **)val; X X if (s == 0) s = ""; X o = Make_String (s, strlen (s)); X } else if (t == T_Callbacklist) { X register i, n; X Object ret, tail; X XtCallbackList callbacks = *(XtCallbackList *)val; X GC_Node; X X for (n = 0; callbacks[n].callback; n++) X ; X ret = tail = P_Make_List (Make_Fixnum (n), Null); X GC_Link2 (ret, tail); X for (i = 0; i < n; i++, tail = Cdr (tail)) X Car (tail) = Get_Callbackfun (callbacks[i].closure); X GC_Unlink; X o = ret; X } else if (t == T_Float) { X o = Make_Reduced_Flonum ((double)*(float *)val); X } else if (t == T_Backing_Store) { X o = Bits_To_Symbols ((unsigned long)*(int *)val, 0, X Backing_Store_Syms); X if (Nullp (o)) X Primitive_Error ("invalid backing-store (Xt bug)"); X } else if (t == T_Orientation) { X o = Bits_To_Symbols ((unsigned long)*(int *)val, 0, X Orientation_Syms); X } else if (t == T_Justify) { X o = Bits_To_Symbols ((unsigned long)*(int *)val, 0, Justify_Syms); X } else if (t == T_Boolean) { X o = (Boolean)*(Boolean *)val ? True : False; X } else if (t == T_Cursor) { X o = Make_Cursor (dpy, *(Cursor *)val); X } else if (t == T_Fixnum) { X /* X * Assumption: Dimension and Position are short! X */ X if (streq (r[j].resource_type, XtRInt)) X o = Make_Integer (*(int *)val); X else X o = Make_Integer (*(short *)val); X } else if (t == T_Display) { X o = Make_Display (0, dpy); X } else if (t == T_Font) { X if (streq (r[j].resource_type, XtRFontStruct)) { X o = Make_Font (dpy, False, (Font)0, *(XFontStruct **)val); X } else { X XFontStruct *info; X Disable_Interrupts; X info = XQueryFont (dpy, *(Font *)val); X Enable_Interrupts; X o = Make_Font (dpy, False, *(Font *)val, info); X } X } else if (t == T_Pixel) { X o = Make_Pixel (*(unsigned long *)val); X } else if (t == T_Pixmap) { X o = Make_Pixmap (dpy, *(Pixmap *)val); X } else if (t == T_Character) { X o = Make_Char (*(unsigned char *)val); X } else if (t == T_Widget) { X o = Make_Widget (*(Widget *)val); X } else if (t == T_Window) { X o = Make_Window (0, dpy, *(Window *)val); X } else { X char s[128]; X sprintf (s, "%s: no converter for %s", argl[i].name, X r[j].resource_type); X Primitive_Error (s); X } X Car (tail) = o; X } X XtFree ((char *)r); X GC_Unlink; X return ret; X} X X/* Convert `mapped-when-managed' to `mappedWhenManaged'. X */ XMake_Resource_Name (s) register char *s; { X register char *p; X X for (p = s; *s; ) { X if (*s == '-') { X if (*++s) { X if (islower (*s)) X *s = toupper (*s); X *p++ = *s++; X } X } else *p++ = *s++; X } X *p = '\0'; X} X XObject Get_Resources (c, fun, freeit) WidgetClass c; void (*fun)(); { X XtResource *r; X register XtResource *p; X int nr; X Object ret, tail, tail2, x; X GC_Node3; X X fun (c, &r, &nr); X /* Note: X * `r' is not freed in case of error. X */ X ret = tail = tail2 = P_Make_List (Make_Fixnum (nr), Null); X GC_Link3 (ret, tail, tail2); X for (p = r; p < r+nr; p++, tail = Cdr (tail)) { X x = tail2 = P_Make_List (Make_Fixnum (3), Null); X Car (tail) = tail2 = x; X x = Intern (p->resource_name); X Car (tail2) = x; tail2 = Cdr (tail2); X x = Intern (p->resource_class); X Car (tail2) = x; tail2 = Cdr (tail2); X x = Intern (p->resource_type); X Car (tail2) = x; X } X GC_Unlink; X if (freeit) XtFree ((char *)r); X return ret; X} X X/* -------------------------------------------------------------------- X * X * Delete this when XtGetConstraintResourceList() is provided by X * the Xt intrinsics. X * X * This code has been written by Paul Asente . X * X * Copyright 1985, 1986, 1987, 1988 by the Massachusetts Institute X * of Technology X * X * Permission to use, copy, modify, and distribute this X * software and its documentation for any purpose and without X * fee is hereby granted, provided that the above copyright X * notice appear in all copies and that both that copyright X * notice and this permission notice appear in supporting X * documentation, and that the name of M.I.T. not be used in X * advertising or publicity pertaining to distribution of the X * software without specific, written prior permission. X * M.I.T. makes no representations about the suitability of X * this software for any purpose. It is provided "as is" X * without express or implied warranty. X * X */ X X#include X#include X#include X Xvoid XtGetConstraintResourceList(widget_class, resources, num_resources) X WidgetClass widget_class; X XtResourceList *resources; X Cardinal *num_resources; X{ X if (_XtClassIsSubclass(widget_class, constraintWidgetClass)) { X ConstraintWidgetClass cwc = (ConstraintWidgetClass) widget_class; X X GetResourceList(widget_class, resources, num_resources, X cwc->constraint_class.num_resources, X cwc->constraint_class.resources); X } else { X *resources = NULL; X *num_resources = 0; X } X} X Xstatic GetResourceList(widget_class, resources, num_resources, count, r_source) X WidgetClass widget_class; X XtResourceList *resources; X Cardinal *num_resources; X Cardinal count; X XtResourceList r_source; X{ X int size = count * sizeof(XtResource); X register int i, dest = 0; X register XtResourceList dlist; X register XtResourceList *source; X X *resources = (XtResourceList) XtMalloc((unsigned) size); X X if (!widget_class->core_class.class_inited) { X /* Easy case */ X X bcopy((char *) r_source, (char *) *resources, size); X *num_resources = count; X return; X } X X /* Nope, it's the hard case */ X X dlist = *resources; X source = (XtResourceList *) r_source; X for (i = 0; i < count; i++) { X if (source[i] != NULL) { X dlist[dest].resource_name = (String) X XrmQuarkToString((XrmQuark) source[i]->resource_name); X dlist[dest].resource_class = (String) X XrmQuarkToString((XrmQuark) source[i]->resource_class); X dlist[dest].resource_type = (String) X XrmQuarkToString((XrmQuark) source[i]->resource_type); X dlist[dest].resource_size = source[i]->resource_size; X dlist[dest].resource_offset = -(source[i]->resource_offset + 1); X dlist[dest].default_type = (String) X XrmQuarkToString((XrmQuark) source[i]->default_type); X dlist[dest].default_addr = source[i]->default_addr; X dest++; X } X } X *num_resources = dest; X} END_OF_lib/xt/resource.c if test 14293 -ne `wc -c lib/xt/BUGS <<'END_OF_lib/xt/BUGS' XResources that are inherited from a superclass cannot be set Xby functions like create-widget; they must be set after the Xwidget has been created by a call to set-values!. XThis restriction is only there for the first widget of each class. X XThe reason for this is that the complete resource list is Xnot available (through XtGetResourceList) before the class Xhas been initialized. X XConstraint resources also can only be set by means of set-values!. X XSubresources, on the other hand, can only be set by functions like Xcreate-widget (this is a restriction imposed by Xt). Subresources Xcannot be read with get-values. In addition, converters do not Xwork for subresources (since XtConvert needs a widget instance). X X XCallbacks *must* return; e.g. a (reset) from within a callback is Xnot allowed. This is a bug in Xt. X X XMissing: context-add-input, context-remove-input, accelerators Xresource converters, keycode translators, case converters, Xshared GCs, selections END_OF_lib/xt/BUGS if test 960 -ne `wc -c lib/xt/identifier.c <<'END_OF_lib/xt/identifier.c' X X#include "xt.h" X XGeneric_Predicate (Identifier); X Xstatic Object Identifier_Equal (x, y) Object x, y; { X register struct S_Identifier *p = IDENTIFIER(x), *q = IDENTIFIER(y); X return p->type == q->type && p->val == q->val && !p->free && !q->free; X} X XGeneric_Print (Identifier, "#[identifier %u]", POINTER(x)); X XObject Make_Id (type, val, num) caddr_t val; { X register char *p; X Object i; X X i = Find_Object (T_Identifier, (GENERIC)0, Match_Xt_Obj, type, val); X if (Nullp (i)) { X p = Get_Bytes (sizeof (struct S_Identifier)); X SET (i, T_Identifier, (struct S_Identifier *)p); X IDENTIFIER(i)->tag = Null; X IDENTIFIER(i)->type = type; X IDENTIFIER(i)->val = val; X IDENTIFIER(i)->num = num; X IDENTIFIER(i)->free = 0; X Register_Object (i, (GENERIC)0, (PFO)0, 0); X } X return i; X} X Xcaddr_t Use_Id (x, type) Object x; { X Check_Type (x, T_Identifier); X if (IDENTIFIER(x)->type != type || IDENTIFIER(x)->free) X Primitive_Error ("invalid identifier"); X IDENTIFIER(x)->free = 1; X Deregister_Object (x); X return IDENTIFIER(x)->val; X} X Xinit_xt_identifier () { X Generic_Define (Identifier, "identifier", "identifier?"); X} END_OF_lib/xt/identifier.c if test 1146 -ne `wc -c lib/util/symbol.h <<'END_OF_lib/util/symbol.h' Xtypedef struct { X char *name; X unsigned long val; X} SYMDESCR; X Xextern unsigned long Symbols_To_Bits(); Xextern Object Bits_To_Symbols(); END_OF_lib/util/symbol.h if test 142 -ne `wc -c lib/util/objects.h <<'END_OF_lib/util/objects.h' Xtypedef Object (*PFO)(); X Xextern Object Find_Object (); END_OF_lib/util/objects.h if test 56 -ne `wc -c