v08i061: Elk (Extension Language Toolkit) part 13 of 14
Brandon S. Allbery - comp.sources.misc
allbery at uunet.UU.NET
Sun Sep 24 07:44:40 AEST 1989
Posting-number: Volume 8, Issue 61
Submitted-by: net at 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 <file", e.g.. If this archive is complete, you
# will see the following message at the end:
# "End of archive 13 (of 14)."
# Contents: lib/xt/class.c lib/xt/xt.h lib/xt/callback.c
# lib/xt/context.c lib/xt/translation.c lib/xt/widget.c
# lib/xt/make-widget lib/xt/converter.c lib/xt/popup.c
# lib/xt/resource.c lib/xt/BUGS lib/xt/identifier.c lib/util
# lib/util/symbol.h lib/util/objects.h lib/xhp
# Wrapped by net at tub on Sun Sep 17 17:32:42 1989
PATH=/bin:/usr/bin:/usr/ucb ; export PATH
if test -f lib/xt/class.c -a "${1}" != "-c" ; then
echo shar: Will not over-write existing file \"lib/xt/class.c\"
else
echo shar: Extracting \"lib/xt/class.c\" \(4967 characters\)
sed "s/^X//" >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/class.c`; then
echo shar: \"lib/xt/class.c\" unpacked with wrong size!
fi
# end of overwriting check
fi
if test -f lib/xt/xt.h -a "${1}" != "-c" ; then
echo shar: Will not over-write existing file \"lib/xt/xt.h\"
else
echo shar: Extracting \"lib/xt/xt.h\" \(1570 characters\)
sed "s/^X//" >lib/xt/xt.h <<'END_OF_lib/xt/xt.h'
X#include "../xlib/xlib.h"
X
X#include <X11/Intrinsic.h>
X#include <X11/Core.h>
X#include <X11/Cardinals.h>
X#include <X11/StringDefs.h>
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/xt.h`; then
echo shar: \"lib/xt/xt.h\" unpacked with wrong size!
fi
# end of overwriting check
fi
if test -f lib/xt/callback.c -a "${1}" != "-c" ; then
echo shar: Will not over-write existing file \"lib/xt/callback.c\"
else
echo shar: Extracting \"lib/xt/callback.c\" \(3938 characters\)
sed "s/^X//" >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/callback.c`; then
echo shar: \"lib/xt/callback.c\" unpacked with wrong size!
fi
# end of overwriting check
fi
if test -f lib/xt/context.c -a "${1}" != "-c" ; then
echo shar: Will not over-write existing file \"lib/xt/context.c\"
else
echo shar: Extracting \"lib/xt/context.c\" \(6094 characters\)
sed "s/^X//" >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/context.c`; then
echo shar: \"lib/xt/context.c\" unpacked with wrong size!
fi
# end of overwriting check
fi
if test -f lib/xt/translation.c -a "${1}" != "-c" ; then
echo shar: Will not over-write existing file \"lib/xt/translation.c\"
else
echo shar: Extracting \"lib/xt/translation.c\" \(1039 characters\)
sed "s/^X//" >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/translation.c`; then
echo shar: \"lib/xt/translation.c\" unpacked with wrong size!
fi
# end of overwriting check
fi
if test -f lib/xt/widget.c -a "${1}" != "-c" ; then
echo shar: Will not over-write existing file \"lib/xt/widget.c\"
else
echo shar: Extracting \"lib/xt/widget.c\" \(8487 characters\)
sed "s/^X//" >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/widget.c`; then
echo shar: \"lib/xt/widget.c\" unpacked with wrong size!
fi
# end of overwriting check
fi
if test -f lib/xt/make-widget -a "${1}" != "-c" ; then
echo shar: Will not over-write existing file \"lib/xt/make-widget\"
else
echo shar: Extracting \"lib/xt/make-widget\" \(5113 characters\)
sed "s/^X//" >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 <X11/Xw/Xw.h>~%")))
X (case widget-set
X (xaw
X (format f "#include <X11/~a>~%~%" include))
X (xhp
X (format f "#include <X11/Xw/~a>~%~%" 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/make-widget`; then
echo shar: \"lib/xt/make-widget\" unpacked with wrong size!
fi
# end of overwriting check
fi
if test -f lib/xt/converter.c -a "${1}" != "-c" ; then
echo shar: Will not over-write existing file \"lib/xt/converter.c\"
else
echo shar: Extracting \"lib/xt/converter.c\" \(1104 characters\)
sed "s/^X//" >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/converter.c`; then
echo shar: \"lib/xt/converter.c\" unpacked with wrong size!
fi
# end of overwriting check
fi
if test -f lib/xt/popup.c -a "${1}" != "-c" ; then
echo shar: Will not over-write existing file \"lib/xt/popup.c\"
else
echo shar: Extracting \"lib/xt/popup.c\" \(1335 characters\)
sed "s/^X//" >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/popup.c`; then
echo shar: \"lib/xt/popup.c\" unpacked with wrong size!
fi
# end of overwriting check
fi
if test -f lib/xt/resource.c -a "${1}" != "-c" ; then
echo shar: Will not over-write existing file \"lib/xt/resource.c\"
else
echo shar: Extracting \"lib/xt/resource.c\" \(14293 characters\)
sed "s/^X//" >lib/xt/resource.c <<'END_OF_lib/xt/resource.c'
X#include "xt.h"
X#include <X11/Xmu.h>
X
X#include <ctype.h>
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 <asente at wsl.dec.com>.
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 <X11/Intrinsic.h>
X#include <X11/IntrinsicP.h>
X#include <X11/CoreP.h>
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/resource.c`; then
echo shar: \"lib/xt/resource.c\" unpacked with wrong size!
fi
# end of overwriting check
fi
if test -f lib/xt/BUGS -a "${1}" != "-c" ; then
echo shar: Will not over-write existing file \"lib/xt/BUGS\"
else
echo shar: Extracting \"lib/xt/BUGS\" \(960 characters\)
sed "s/^X//" >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/BUGS`; then
echo shar: \"lib/xt/BUGS\" unpacked with wrong size!
fi
# end of overwriting check
fi
if test -f lib/xt/identifier.c -a "${1}" != "-c" ; then
echo shar: Will not over-write existing file \"lib/xt/identifier.c\"
else
echo shar: Extracting \"lib/xt/identifier.c\" \(1146 characters\)
sed "s/^X//" >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/xt/identifier.c`; then
echo shar: \"lib/xt/identifier.c\" unpacked with wrong size!
fi
# end of overwriting check
fi
if test ! -d lib/util ; then
echo shar: Creating directory \"lib/util\"
mkdir lib/util
fi
if test -f lib/util/symbol.h -a "${1}" != "-c" ; then
echo shar: Will not over-write existing file \"lib/util/symbol.h\"
else
echo shar: Extracting \"lib/util/symbol.h\" \(142 characters\)
sed "s/^X//" >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/symbol.h`; then
echo shar: \"lib/util/symbol.h\" unpacked with wrong size!
fi
# end of overwriting check
fi
if test -f lib/util/objects.h -a "${1}" != "-c" ; then
echo shar: Will not over-write existing file \"lib/util/objects.h\"
else
echo shar: Extracting \"lib/util/objects.h\" \(56 characters\)
sed "s/^X//" >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 <lib/util/objects.h`; then
echo shar: \"lib/util/objects.h\" unpacked with wrong size!
fi
# end of overwriting check
fi
if test ! -d lib/xhp ; then
echo shar: Creating directory \"lib/xhp\"
mkdir lib/xhp
fi
echo shar: End of archive 13 \(of 14\).
cp /dev/null ark13isdone
MISSING=""
for I in 1 2 3 4 5 6 7 8 9 10 11 12 13 14 ; do
if test ! -f ark${I}isdone ; then
MISSING="${MISSING} ${I}"
fi
done
if test "${MISSING}" = "" ; then
echo You have unpacked all 14 archives.
rm -f ark[1-9]isdone ark[1-9][0-9]isdone
else
echo You still need to unpack the following archives:
echo " " ${MISSING}
fi
## End of shell archive.
exit 0
More information about the Comp.sources.misc
mailing list