home *** CD-ROM | disk | FTP | other *** search
/ Usenet 1994 October / usenetsourcesnewsgroupsinfomagicoctober1994disk2.iso / misc / volume8 / elk / part13 < prev    next >
Text File  |  1989-09-23  |  60KB  |  1,917 lines
  1. Newsgroups: comp.sources.misc
  2. From: allbery@uunet.UU.NET (Brandon S. Allbery - comp.sources.misc)
  3. Subject: v08i061: Elk (Extension Language Toolkit) part 13 of 14
  4. Reply-To: net@tub.UUCP (Oliver Laumann)
  5.  
  6. Posting-number: Volume 8, Issue 61
  7. Submitted-by: net@tub.UUCP (Oliver Laumann)
  8. Archive-name: elk/part13
  9.  
  10. [Let this be a lesson to submitters:  this was submitted as uuencoded,
  11. compressed files.  I lost the source information while unpacking it; this
  12. is the best approximation I could come up with.  ++bsa]
  13.  
  14. #! /bin/sh
  15. # This is a shell archive.  Remove anything before this line, then unpack
  16. # it by saving it into a file and typing "sh file".  To overwrite existing
  17. # files, type "sh file -c".  You can also feed this as standard input via
  18. # unshar, or by typing "sh <file", e.g..  If this archive is complete, you
  19. # will see the following message at the end:
  20. #        "End of archive 13 (of 14)."
  21. # Contents:  lib/xt/class.c lib/xt/xt.h lib/xt/callback.c
  22. #   lib/xt/context.c lib/xt/translation.c lib/xt/widget.c
  23. #   lib/xt/make-widget lib/xt/converter.c lib/xt/popup.c
  24. #   lib/xt/resource.c lib/xt/BUGS lib/xt/identifier.c lib/util
  25. #   lib/util/symbol.h lib/util/objects.h lib/xhp
  26. # Wrapped by net@tub on Sun Sep 17 17:32:42 1989
  27. PATH=/bin:/usr/bin:/usr/ucb ; export PATH
  28. if test -f lib/xt/class.c -a "${1}" != "-c" ; then 
  29.   echo shar: Will not over-write existing file \"lib/xt/class.c\"
  30. else
  31. echo shar: Extracting \"lib/xt/class.c\" \(4967 characters\)
  32. sed "s/^X//" >lib/xt/class.c <<'END_OF_lib/xt/class.c'
  33. X#include "xt.h"
  34. X
  35. X#define MAX_CLASS            128
  36. X#define MAX_CALLBACK_PER_CLASS    5
  37. X
  38. Xtypedef struct {
  39. X    char *name;
  40. X    int has_arg;
  41. X} CALLBACK_INFO;
  42. X
  43. Xtypedef struct {
  44. X    WidgetClass class;
  45. X    char *name;
  46. X    CALLBACK_INFO cb[MAX_CALLBACK_PER_CLASS], *cblast;
  47. X    XtResourceList sub_resources;
  48. X    int num_resources;
  49. X} CLASS_INFO;
  50. X
  51. Xstatic CLASS_INFO ctab[MAX_CLASS], *clast = ctab;
  52. X
  53. XGeneric_Predicate (Class);
  54. X
  55. XGeneric_Simple_Equal (Class, CLASS, class);
  56. X
  57. XGeneric_Print (Class, "#[class %s]", CLASS(x)->name);
  58. X
  59. XObject Make_Class (class, name) WidgetClass class; char *name; {
  60. X    register char *p;
  61. X    Object c;
  62. X
  63. X    c = Find_Object (T_Class, (GENERIC)0, Match_Xt_Obj, class);
  64. X    if (Nullp (c)) {
  65. X    p = Get_Bytes (sizeof (struct S_Class));
  66. X    SET (c, T_Class, (struct S_Class *)p);
  67. X    CLASS(c)->tag = Null;
  68. X    CLASS(c)->class = class;
  69. X    CLASS(c)->name = name;
  70. X    Register_Object (c, (GENERIC)0, (PFO)0, 0);
  71. X    }
  72. X    return c;
  73. X}
  74. X
  75. XObject Make_Widget_Class (class) WidgetClass class; {
  76. X    register CLASS_INFO *p;
  77. X
  78. X    for (p = ctab; p < clast; p++)
  79. X    if (p->class == class)
  80. X        return Make_Class (class, p->name);
  81. X    Primitive_Error ("undefined widget class");
  82. X    /*NOTREACHED*/
  83. X}
  84. X
  85. Xstatic Object P_Find_Class (name) Object name; {
  86. X    register char *s;
  87. X    register CLASS_INFO *p;
  88. X
  89. X    Make_C_String (name, s);
  90. X    for (p = ctab; p < clast; p++)
  91. X    if (streq (p->name, s))
  92. X        return Make_Class (p->class, p->name);
  93. X    Primitive_Error ("no such widget class: ~s", name);
  94. X    /*NOTREACHED*/
  95. X}
  96. X
  97. Xstatic Object P_Class_Existsp (name) Object name; {
  98. X    register char *s;
  99. X    register CLASS_INFO *p;
  100. X
  101. X    Make_C_String (name, s);
  102. X    for (p = ctab; p < clast; p++)
  103. X    if (streq (p->name, s))
  104. X        return True;
  105. X    return False;
  106. X}
  107. X
  108. Xchar *Class_Name (class) WidgetClass class; {
  109. X    register CLASS_INFO *p;
  110. X
  111. X    for (p = ctab; p < clast && p->class != class; p++)
  112. X    ;
  113. X    if (p == clast)
  114. X    return "unknown";
  115. X    return p->name;
  116. X}
  117. X
  118. Xvoid Get_Sub_Resource_List (class, rp, np) WidgetClass class;
  119. X    XtResourceList *rp; int *np; {
  120. X    register CLASS_INFO *p;
  121. X
  122. X    for (p = ctab; p < clast && p->class != class; p++)
  123. X    ;
  124. X    if (p == clast)
  125. X    Panic ("Get_Sub_Resource_List");
  126. X    *np = p->num_resources;
  127. X    *rp = p->sub_resources;
  128. X}
  129. X
  130. Xstatic Object P_Class_Resources (c) Object c; {
  131. X    Check_Type (c, T_Class);
  132. X    return Get_Resources (CLASS(c)->class, XtGetResourceList, 1);
  133. X}
  134. X
  135. Xstatic Object P_Class_Constraint_Resources (c) Object c; {
  136. X    Check_Type (c, T_Class);
  137. X    return Get_Resources (CLASS(c)->class, XtGetConstraintResourceList, 1);
  138. X}
  139. X
  140. Xstatic Object P_Class_Sub_Resources (c) Object c; {
  141. X    Check_Type (c, T_Class);
  142. X    return Get_Resources (CLASS(c)->class, Get_Sub_Resource_List, 0);
  143. X}
  144. X
  145. XDefine_Class (name, class, r, nr) char *name; WidgetClass class;
  146. X    XtResourceList r; {
  147. X    Error_Tag = "define-class";
  148. X    if (clast == ctab+MAX_CLASS)
  149. X    Primitive_Error ("too many widget classes");
  150. X    clast->name = name;
  151. X    clast->class = class;
  152. X    clast->cb[0].name = XtNdestroyCallback;
  153. X    clast->cb[0].has_arg = 0;
  154. X    clast->cblast = clast->cb+1;
  155. X    clast->sub_resources = r;
  156. X    clast->num_resources = nr;
  157. X    clast++;
  158. X}
  159. X
  160. XDefine_Callback (cl, s, has_arg) char *cl, *s; {
  161. X    register CLASS_INFO *p;
  162. X
  163. X    Error_Tag = "define-callback";
  164. X    for (p = ctab; p < clast; p++)
  165. X    if (streq (p->name, cl)) {
  166. X        if (p->cblast == p->cb+MAX_CALLBACK_PER_CLASS)
  167. X        Primitive_Error ("too many callbacks for this class");
  168. X        p->cblast->name = s;
  169. X        p->cblast->has_arg = has_arg;
  170. X        p->cblast++;
  171. X        return;
  172. X    }
  173. X    Primitive_Error ("undefined class");
  174. X}
  175. X
  176. XPFO Find_Callback_Converter (c, name, sname) WidgetClass c; char *name;
  177. X    Object sname; {
  178. X    register CLASS_INFO *p;
  179. X    register CALLBACK_INFO *q;
  180. X    PFO conv;
  181. X
  182. X    for (p = ctab; p < clast; p++)
  183. X    if (p->class == c) {
  184. X        for (q = p->cb; q < p->cblast; q++)
  185. X        if (streq (q->name, name)) {
  186. X            if (q->has_arg) {
  187. X            char s[128];
  188. X            sprintf (s, "%s-%s", p->name, name);
  189. X            conv = Find_Converter_To_Scheme (s);
  190. X            if (conv == 0) {
  191. X                sprintf (s, "no callback converter for %s", name);
  192. X                Primitive_Error (s);
  193. X            }
  194. X            return conv;
  195. X            } else return (PFO)0;
  196. X        }
  197. X        Primitive_Error ("no such callback: ~s", sname);
  198. X    }
  199. X    Panic ("Find_Callback_Converter");
  200. X    /*NOTREACHED*/
  201. X}
  202. X
  203. Xinit_xt_class () {
  204. X    Generic_Define (Class, "class", "class?");
  205. X    Define_Primitive (P_Find_Class,        "find-class",        1, 1, EVAL);
  206. X    Define_Primitive (P_Class_Resources,   "class-resources",   1, 1, EVAL);
  207. X    Define_Primitive (P_Class_Constraint_Resources, 
  208. X                               "class-constraint-resources",    1, 1, EVAL);
  209. X    Define_Primitive (P_Class_Sub_Resources,
  210. X                   "class-sub-resources",           1, 1, EVAL);
  211. X    Define_Primitive (P_Class_Existsp,     "class-exists?",     1, 1, EVAL);
  212. X    Define_Class ("core", widgetClass, (XtResourceList)0, 0);
  213. X    Define_Class ("constraint", constraintWidgetClass, (XtResourceList)0, 0);
  214. X    Define_Class ("composite", compositeWidgetClass, (XtResourceList)0, 0);
  215. X}
  216. END_OF_lib/xt/class.c
  217. if test 4967 -ne `wc -c <lib/xt/class.c`; then
  218.     echo shar: \"lib/xt/class.c\" unpacked with wrong size!
  219. fi
  220. # end of overwriting check
  221. fi
  222. if test -f lib/xt/xt.h -a "${1}" != "-c" ; then 
  223.   echo shar: Will not over-write existing file \"lib/xt/xt.h\"
  224. else
  225. echo shar: Extracting \"lib/xt/xt.h\" \(1570 characters\)
  226. sed "s/^X//" >lib/xt/xt.h <<'END_OF_lib/xt/xt.h'
  227. X#include "../xlib/xlib.h"
  228. X
  229. X#include <X11/Intrinsic.h>
  230. X#include <X11/Core.h>
  231. X#include <X11/Cardinals.h>
  232. X#include <X11/StringDefs.h>
  233. X
  234. Xtypedef XtArgVal (*PFX)();
  235. X
  236. Xint T_Context;
  237. Xint T_Class;
  238. Xint T_Widget;
  239. Xint T_Identifier;
  240. X
  241. X#define CONTEXT(x)    ((struct S_Context *)POINTER(x))
  242. X#define CLASS(x)    ((struct S_Class *)POINTER(x))
  243. X#define WIDGET(x)    ((struct S_Widget *)POINTER(x))
  244. X#define IDENTIFIER(x)   ((struct S_Identifier *)POINTER(x))
  245. X
  246. Xstruct S_Context {
  247. X    Object tag;
  248. X    XtAppContext context;
  249. X    char free;
  250. X};
  251. X
  252. Xstruct S_Class {
  253. X    Object tag;
  254. X    WidgetClass class;
  255. X    char *name;
  256. X};
  257. X
  258. Xstruct S_Widget {
  259. X    Object tag;
  260. X    Widget widget;
  261. X    char free;
  262. X};
  263. X
  264. Xstruct S_Identifier {
  265. X    Object tag;
  266. X    char type;
  267. X    caddr_t val;
  268. X    int num;
  269. X    char free;
  270. X};
  271. X
  272. Xextern Match_Xt_Obj();
  273. Xextern Object Make_Widget_Class(), Make_Context(), Make_Widget();
  274. Xextern Object Get_Values(), Get_Resources(), Get_Callbackfun();
  275. Xextern WidgetClass widgetClass;    /* The `core' class */
  276. Xextern WidgetClass constraintWidgetClass;
  277. Xextern WidgetClass compositeWidgetClass;
  278. Xextern caddr_t Use_Id();
  279. Xextern Xt_Warning();
  280. Xextern void XtGetResourceList(), XtGetConstraintResourceList();
  281. Xextern void Destroy_Callback_Proc();
  282. Xextern PFO Find_Callback_Converter(), Find_Converter_To_Scheme();
  283. Xextern PFX Find_Converter_To_C();
  284. Xextern char *Class_Name();
  285. Xextern XtTranslations Get_Translations();
  286. X
  287. X
  288. X#define Encode_Arglist(ac,av,to,widget,class) {\
  289. X    to = (Arg *)alloca (((ac)+1)/2 * sizeof (Arg));\
  290. X    Convert_Args (ac, av, to, widget, class);\
  291. X}
  292. X
  293. X#define streq(a,b) (strcmp ((a), (b)) == 0)
  294. END_OF_lib/xt/xt.h
  295. if test 1570 -ne `wc -c <lib/xt/xt.h`; then
  296.     echo shar: \"lib/xt/xt.h\" unpacked with wrong size!
  297. fi
  298. # end of overwriting check
  299. fi
  300. if test -f lib/xt/callback.c -a "${1}" != "-c" ; then 
  301.   echo shar: Will not over-write existing file \"lib/xt/callback.c\"
  302. else
  303. echo shar: Extracting \"lib/xt/callback.c\" \(3938 characters\)
  304. sed "s/^X//" >lib/xt/callback.c <<'END_OF_lib/xt/callback.c'
  305. X#include "xt.h"
  306. X
  307. X#define MAX_CALLBACKS   512
  308. X
  309. Xstatic Object Callbacks;
  310. X
  311. Xtypedef struct {
  312. X    PFO converter;
  313. X    int num;
  314. X} CLIENT_DATA;
  315. X
  316. XObject Get_Callbackfun (c) caddr_t c; {
  317. X    register CLIENT_DATA *cd = (CLIENT_DATA *)c;
  318. X    return cd ? VECTOR(Callbacks)->data[cd->num] : False;
  319. X}
  320. X
  321. Xstatic void Callback_Proc (w, client_data, call_data) Widget w;
  322. X    caddr_t client_data, call_data; {
  323. X    register CLIENT_DATA *cd = (CLIENT_DATA *)client_data;
  324. X    Object args;
  325. X
  326. X    args = Null;
  327. X    if (cd->converter)
  328. X    args = Cons ((cd->converter)((XtArgVal)call_data), args);
  329. X    args = Cons (Make_Widget (w), args);
  330. X    (void)Funcall (Get_Callbackfun (client_data), args, 0);
  331. X}
  332. X
  333. X/*ARGSUSED*/
  334. Xvoid Destroy_Callback_Proc (w, client_data, call_data) Widget w;
  335. X    caddr_t client_data, call_data; {
  336. X    Object x;
  337. X
  338. X    x = Find_Object (T_Widget, (GENERIC)0, Match_Xt_Obj, w);
  339. X    if (Nullp (x) || WIDGET(x)->free)
  340. X    return;
  341. X    WIDGET(x)->free = 1;
  342. X    Remove_All_Callbacks (w);
  343. X    Deregister_Object (x);
  344. X}
  345. X
  346. X/* The code assumes that callbacks are called in the order they
  347. X * have been added.  The Destroy_Callback_Proc() must always be
  348. X * the last callback in the destroy callback list of each widget.
  349. X *
  350. X * When the destroy callback list of a widget is modified
  351. X * (via P_Add_Callbacks or P_Set_Values), Fiddle_Destroy_Callback()
  352. X * must be called to remove the Destroy_Callback_Proc() and put
  353. X * it back to the end of the callback list.
  354. X */
  355. XFiddle_Destroy_Callback (w) Widget w; {
  356. X    XtRemoveCallback (w, XtNdestroyCallback, Destroy_Callback_Proc, (caddr_t)0);
  357. X    XtAddCallback (w, XtNdestroyCallback, Destroy_Callback_Proc, (caddr_t)0);
  358. X}
  359. X
  360. XCheck_Callback_List (x) Object x; {
  361. X    Object tail;
  362. X
  363. X    Check_List (x);
  364. X    for (tail = x; !Nullp (tail); tail = Cdr (tail))
  365. X    Check_Procedure (Car (tail));
  366. X}
  367. X
  368. Xstatic Object P_Add_Callbacks (w, name, cbl) Object w, name, cbl; {
  369. X    register char *s;
  370. X    register n;
  371. X    XtCallbackList callbacks;
  372. X
  373. X    Check_Widget (w);
  374. X    Check_Callback_List (cbl);
  375. X    Make_C_String (name, s);
  376. X    Make_Resource_Name (s);
  377. X    n = Internal_Length (cbl);
  378. X    callbacks = (XtCallbackRec *)alloca ((n+1) * sizeof (XtCallbackRec));
  379. X    callbacks[n].callback = 0;
  380. X    callbacks[n].closure = 0;
  381. X    Fill_Callbacks (cbl, callbacks, n,
  382. X    Find_Callback_Converter (XtClass (WIDGET(w)->widget), s, name));
  383. X    XtAddCallbacks (WIDGET(w)->widget, s, callbacks);
  384. X    if (streq (s, XtNdestroyCallback))
  385. X    Fiddle_Destroy_Callback (WIDGET(w)->widget);
  386. X    return Void;
  387. X}
  388. X
  389. XFill_Callbacks (src, dst, n, conv) Object src; XtCallbackList dst;
  390. X    register n; PFO conv; {
  391. X    register CLIENT_DATA *cd;
  392. X    register i, j;
  393. X    Object tail;
  394. X    GC_Node2;
  395. X
  396. X    GC_Link2 (src, tail);
  397. X    for (i = 0, tail = src; i < n; i++, tail = Cdr (tail)) {
  398. X    Object fun = Car (tail);
  399. X    for (j = 0; j < MAX_CALLBACKS; j++)
  400. X        if (Nullp (VECTOR(Callbacks)->data[j])) break;
  401. X    if (j == MAX_CALLBACKS)
  402. X        Primitive_Error ("too many callbacks");
  403. X    VECTOR(Callbacks)->data[j] = fun;
  404. X    cd = (CLIENT_DATA *)XtMalloc (sizeof (CLIENT_DATA));
  405. X    cd->converter = conv;
  406. X    cd->num = j;
  407. X    dst[i].callback = (XtCallbackProc)Callback_Proc;
  408. X    dst[i].closure = (caddr_t)cd;
  409. X    }
  410. X    GC_Unlink;
  411. X}
  412. X
  413. Xstatic Remove_All_Callbacks (w) Widget w; {
  414. X    Arg a[1];
  415. X    XtCallbackList c;
  416. X    XtResource *r;
  417. X    int nr, nc;
  418. X    register i, j;
  419. X
  420. X    Get_All_Resources (w, XtClass (w), &r, &nr, &nc);
  421. X    for (j = 0; j < nr; j++) {
  422. X    if (streq (r[j].resource_type, XtRCallback)) {
  423. X        XtSetArg (a[0], r[j].resource_name, &c);
  424. X        XtGetValues (w, a, ONE);
  425. X        for (i = 0; c[i].callback; i++) {
  426. X        register CLIENT_DATA *cd = (CLIENT_DATA *)c[i].closure;
  427. X        if (c[i].callback == (XtCallbackProc)Callback_Proc && cd) {
  428. X            VECTOR(Callbacks)->data[cd->num] = Null;
  429. X            XtFree ((char *)cd);
  430. X        }
  431. X        }
  432. X    }
  433. X    }
  434. X    XtFree ((char *)r);
  435. X}
  436. X
  437. Xinit_xt_callback () {
  438. X    Callbacks = Make_Vector (MAX_CALLBACKS, Null);
  439. X    Global_GC_Link (Callbacks);
  440. X    Define_Primitive (P_Add_Callbacks, "add-callbacks", 3, 3, EVAL);
  441. X}
  442. END_OF_lib/xt/callback.c
  443. if test 3938 -ne `wc -c <lib/xt/callback.c`; then
  444.     echo shar: \"lib/xt/callback.c\" unpacked with wrong size!
  445. fi
  446. # end of overwriting check
  447. fi
  448. if test -f lib/xt/context.c -a "${1}" != "-c" ; then 
  449.   echo shar: Will not over-write existing file \"lib/xt/context.c\"
  450. else
  451. echo shar: Extracting \"lib/xt/context.c\" \(6094 characters\)
  452. sed "s/^X//" >lib/xt/context.c <<'END_OF_lib/xt/context.c'
  453. X#include "xt.h"
  454. X
  455. X#define MAX_WORKPROCS            512
  456. X#define MAX_TIMEOUTS             512
  457. X
  458. Xstatic Object Workprocs, Timeouts;
  459. X
  460. Xstatic SYMDESCR XtIM_Syms[] = {
  461. X    { "x-event",         XtIMXEvent },
  462. X    { "timer",           XtIMTimer },
  463. X    { "alternate-input", XtIMAlternateInput },
  464. X    { 0, 0 }
  465. X};
  466. X
  467. Xstatic Object P_Destroy_Context();
  468. X
  469. XGeneric_Predicate (Context);
  470. X
  471. XGeneric_Equal (Context, CONTEXT, context);
  472. X
  473. XGeneric_Print (Context, "#[context %u]", POINTER(x));
  474. X
  475. XObject Make_Context (context) XtAppContext context; {
  476. X    register char *p;
  477. X    Object c;
  478. X
  479. X    c = Find_Object (T_Context, (GENERIC)0, Match_Xt_Obj, context);
  480. X    if (Nullp (c)) {
  481. X    p = Get_Bytes (sizeof (struct S_Context));
  482. X    SET (c, T_Context, (struct S_Context *)p);
  483. X    CONTEXT(c)->tag = Null;
  484. X    CONTEXT(c)->context = context;
  485. X    CONTEXT(c)->free = 0;
  486. X    Register_Object (c, (GENERIC)0, P_Destroy_Context, 0);
  487. X    XtAppSetWarningHandler (context, Xt_Warning);
  488. X    }
  489. X    return c;
  490. X}
  491. X
  492. Xstatic Check_Context (c) Object c; {
  493. X    Check_Type (c, T_Context);
  494. X    if (CONTEXT(c)->free)
  495. X    Primitive_Error ("invalid context: ~s", c);
  496. X}
  497. X
  498. Xstatic Object P_Create_Context () {
  499. X    /*  Should read:
  500. X    return Make_Context (XtCreateApplicationContext ());
  501. X     *  but Xt is broken (timers are added to the wrong context).
  502. X     */
  503. X    extern XtAppContext _XtDefaultAppContext();
  504. X    return Make_Context (_XtDefaultAppContext ());
  505. X}
  506. X
  507. Xstatic Object P_Destroy_Context (c) Object c; {
  508. X    Check_Context (c);
  509. X    XtDestroyApplicationContext (CONTEXT(c)->context);
  510. X    CONTEXT(c)->free = 1;
  511. X    Deregister_Object (c);
  512. X    return Void;
  513. X}
  514. X
  515. Xstatic Object P_Initialize_Display (c, d, name, class)
  516. X    Object c, d, name, class; {
  517. X    register char *sn, *sc, *sd = 0;
  518. X    register t = TYPE(d);
  519. X    Display *dpy;
  520. X    extern char **Argv;
  521. X    extern First_Arg, Argc;
  522. X    int argc = Argc - First_Arg + 1;
  523. X
  524. X    Argv[First_Arg-1] = "bogus";  /* Not actually used by Xt.  Or is it? */
  525. X    Check_Context (c);
  526. X    Make_C_String (name, sn);
  527. X    Make_C_String (class, sc);
  528. X    if (t == T_Display) {
  529. X    XtDisplayInitialize (CONTEXT(c)->context, DISPLAY(d)->dpy,
  530. X        sn, sc, (XrmOptionDescRec *)0, 0, &argc, &Argv[First_Arg-1]);
  531. X    Argc = First_Arg + argc;
  532. X    return Void;
  533. X    }
  534. X    if (Truep (d))
  535. X    Make_C_String (d, sd);
  536. X    dpy = XtOpenDisplay (CONTEXT(c)->context, sd, sn, sc,
  537. X    (XrmOptionDescRec *)0, 0, &argc, &Argv[First_Arg-1]);
  538. X    Argc = First_Arg + argc - 1;
  539. X    if (dpy == 0)
  540. X    if (sd)
  541. X        Primitive_Error ("cannot open display ~s", d);
  542. X    else
  543. X        Primitive_Error ("cannot open display");
  544. X    return Make_Display (0, dpy);
  545. X}
  546. X
  547. Xstatic Object P_Context_Main_Loop (c) Object c; {
  548. X    Check_Context (c);
  549. X    XtAppMainLoop (CONTEXT(c)->context);
  550. X    /*NOTREACHED*/
  551. X}
  552. X
  553. Xstatic Object P_Context_Pending (c) Object c; {
  554. X    Check_Context (c);
  555. X    return Bits_To_Symbols ((unsigned long)XtAppPending (CONTEXT(c)->context),
  556. X    1, XtIM_Syms);
  557. X}
  558. X
  559. Xstatic Object P_Context_Process_Event (argc, argv) Object *argv; {
  560. X    XtInputMask mask = XtIMAll;
  561. X
  562. X    Check_Context (argv[0]);
  563. X    if (argc == 2)
  564. X    mask = (XtInputMask)Symbols_To_Bits (argv[1], 1, XtIM_Syms);
  565. X    XtAppProcessEvent (CONTEXT(argv[0])->context, mask);
  566. X    return Void;
  567. X}
  568. X
  569. Xstatic Work_Proc (client_data) caddr_t client_data; {
  570. X    Object ret = Funcall (VECTOR(Workprocs)->data[(int)client_data], Null, 0);
  571. X    if (Truep (ret))
  572. X    VECTOR(Workprocs)->data[(int)client_data] = Null;
  573. X    return Truep (ret);
  574. X}
  575. X
  576. Xstatic Object P_Context_Add_Work_Proc (c, p) Object c, p; {
  577. X    XtWorkProcId id;
  578. X    register i;
  579. X
  580. X    Check_Context (c);
  581. X    Check_Procedure (p);
  582. X    for (i = 0; i < MAX_WORKPROCS; i++)
  583. X    if (Nullp (VECTOR(Workprocs)->data[i])) break;
  584. X    if (i == MAX_WORKPROCS)
  585. X    Primitive_Error ("too many work procs");
  586. X    VECTOR(Workprocs)->data[i] = p;
  587. X    id = XtAppAddWorkProc (CONTEXT(c)->context, Work_Proc, (caddr_t)i);
  588. X    return Make_Id ('w', (caddr_t)id, i);
  589. X}
  590. X
  591. Xstatic Object P_Remove_Work_Proc (id) Object id; {
  592. X    XtRemoveWorkProc ((XtWorkProcId)Use_Id (id, 'w'));
  593. X    VECTOR(Workprocs)->data[IDENTIFIER(id)->num] = Null;
  594. X    return Void;
  595. X}
  596. X
  597. Xstatic Timeout_Proc (client_data, id) caddr_t client_data; XtIntervalId *id; {
  598. X    Object proc, args;
  599. X
  600. X    args = Cons (Make_Id ('t', (caddr_t)*id, 0), Null);
  601. X    proc = VECTOR(Timeouts)->data[(int)client_data];
  602. X    VECTOR(Timeouts)->data[(int)client_data] = Null;
  603. X    (void)Funcall (proc, args, 0);
  604. X}
  605. X
  606. Xstatic Object P_Context_Add_Timeout (c, n, p) Object c, n, p; {
  607. X    XtIntervalId id;
  608. X    register i;
  609. X
  610. X    Check_Context (c);
  611. X    Check_Procedure (p);
  612. X    for (i = 0; i < MAX_TIMEOUTS; i++)
  613. X    if (Nullp (VECTOR(Timeouts)->data[i])) break;
  614. X    if (i == MAX_TIMEOUTS)
  615. X    Primitive_Error ("too many timeouts");
  616. X    VECTOR(Timeouts)->data[i] = p;
  617. X    id = XtAppAddTimeOut (CONTEXT(c)->context, Get_Integer (n), Timeout_Proc,
  618. X    (caddr_t)i);
  619. X    return Make_Id ('t', (caddr_t)id, i);
  620. X}
  621. X
  622. Xstatic Object P_Remove_Timeout (id) Object id; {
  623. X    XtRemoveTimeOut ((XtIntervalId)Use_Id (id, 't'));
  624. X    VECTOR(Timeouts)->data[IDENTIFIER(id)->num] = Null;
  625. X    return Void;
  626. X}
  627. X
  628. Xinit_xt_context () {
  629. X    Workprocs = Make_Vector (MAX_WORKPROCS, Null);
  630. X    Global_GC_Link (Workprocs);
  631. X    Timeouts = Make_Vector (MAX_TIMEOUTS, Null);
  632. X    Global_GC_Link (Timeouts);
  633. X    Generic_Define (Context, "context", "context?");
  634. X    Define_Primitive (P_Create_Context,     "create-context",     0, 0, EVAL);
  635. X    Define_Primitive (P_Destroy_Context,    "destroy-context",    1, 1, EVAL);
  636. X    Define_Primitive (P_Initialize_Display, "initialize-display", 4, 4, EVAL);
  637. X    Define_Primitive (P_Context_Main_Loop,  "context-main-loop",  1, 1, EVAL);
  638. X    Define_Primitive (P_Context_Pending,    "context-pending",    1, 1, EVAL);
  639. X    Define_Primitive (P_Context_Process_Event, "context-process-event",
  640. X                                  1, 2, VARARGS);
  641. X    Define_Primitive (P_Context_Add_Work_Proc, "context-add-work-proc",
  642. X                                  2, 2, EVAL);
  643. X    Define_Primitive (P_Remove_Work_Proc,   "remove-work-proc",   1, 1, EVAL);
  644. X    Define_Primitive (P_Context_Add_Timeout,"context-add-timeout",3, 3, EVAL);
  645. X    Define_Primitive (P_Remove_Timeout,     "remove-timeout",     1, 1, EVAL);
  646. X    XtToolkitInitialize ();
  647. X    P_Provide (Intern ("xt.o"));
  648. X}
  649. END_OF_lib/xt/context.c
  650. if test 6094 -ne `wc -c <lib/xt/context.c`; then
  651.     echo shar: \"lib/xt/context.c\" unpacked with wrong size!
  652. fi
  653. # end of overwriting check
  654. fi
  655. if test -f lib/xt/translation.c -a "${1}" != "-c" ; then 
  656.   echo shar: Will not over-write existing file \"lib/xt/translation.c\"
  657. else
  658. echo shar: Extracting \"lib/xt/translation.c\" \(1039 characters\)
  659. sed "s/^X//" >lib/xt/translation.c <<'END_OF_lib/xt/translation.c'
  660. X#include "xt.h"
  661. X
  662. XXtTranslations Get_Translations (t) Object t; {
  663. X    register char *s;
  664. X    XtTranslations ret;
  665. X
  666. X    Make_C_String (t, s);
  667. X    if ((ret = XtParseTranslationTable (s)) == 0)
  668. X    Primitive_Error ("bad translation table: ~s", t);
  669. X    return ret;
  670. X}
  671. X
  672. Xstatic Object P_Augment_Translations (w, t) Object w, t; {
  673. X    Check_Widget (w);
  674. X    XtAugmentTranslations (WIDGET(w)->widget, Get_Translations (t));
  675. X    return Void;
  676. X}
  677. X    
  678. Xstatic Object P_Override_Translations (w, t) Object w, t; {
  679. X    Check_Widget (w);
  680. X    XtOverrideTranslations (WIDGET(w)->widget, Get_Translations (t));
  681. X    return Void;
  682. X}
  683. X
  684. Xstatic Object P_Uninstall_Translations (w) Object w; {
  685. X    Check_Widget (w);
  686. X    XtUninstallTranslations (WIDGET(w)->widget);
  687. X    return Void;
  688. X}
  689. X
  690. Xinit_xt_translation () {
  691. X    Define_Primitive (P_Augment_Translations,   "augment-translations",
  692. X    2, 2, EVAL);
  693. X    Define_Primitive (P_Override_Translations,  "override-translations",
  694. X    2, 2, EVAL);
  695. X    Define_Primitive (P_Uninstall_Translations, "uninstall-translations", 
  696. X    1, 1, EVAL);
  697. X}
  698. END_OF_lib/xt/translation.c
  699. if test 1039 -ne `wc -c <lib/xt/translation.c`; then
  700.     echo shar: \"lib/xt/translation.c\" unpacked with wrong size!
  701. fi
  702. # end of overwriting check
  703. fi
  704. if test -f lib/xt/widget.c -a "${1}" != "-c" ; then 
  705.   echo shar: Will not over-write existing file \"lib/xt/widget.c\"
  706. else
  707. echo shar: Extracting \"lib/xt/widget.c\" \(8487 characters\)
  708. sed "s/^X//" >lib/xt/widget.c <<'END_OF_lib/xt/widget.c'
  709. X#include "xt.h"
  710. X
  711. Xextern void XtManageChildren(), XtUnmanageChildren();
  712. X
  713. Xstatic Object P_Destroy_Widget();
  714. X
  715. XGeneric_Predicate (Widget);
  716. X
  717. XGeneric_Equal (Widget, WIDGET, widget);
  718. X
  719. XGeneric_Print (Widget, "#[widget %u]", POINTER(x));
  720. X
  721. XObject Make_Widget (widget) Widget widget; {
  722. X    register char *p;
  723. X    Object w;
  724. X
  725. X    if (widget == 0)
  726. X    return Sym_None;
  727. X    w = Find_Object (T_Widget, (GENERIC)0, Match_Xt_Obj, widget);
  728. X    if (Nullp (w)) {
  729. X    p = Get_Bytes (sizeof (struct S_Widget));
  730. X    SET (w, T_Widget, (struct S_Widget *)p);
  731. X    WIDGET(w)->tag = Null;
  732. X    WIDGET(w)->widget = widget;
  733. X    WIDGET(w)->free = 0;
  734. X    XtAddCallback (widget, XtNdestroyCallback, Destroy_Callback_Proc,
  735. X        (caddr_t)0);
  736. X    Register_Object (w, (GENERIC)0, P_Destroy_Widget, 0);
  737. X    }
  738. X    return w;
  739. X}
  740. X
  741. XCheck_Widget (w) Object w; {
  742. X    Check_Type (w, T_Widget);
  743. X    if (WIDGET(w)->free)
  744. X    Primitive_Error ("invalid widget: ~s", w);
  745. X}
  746. X
  747. XCheck_Widget_Class (w, class) Object w; WidgetClass class; {
  748. X    Check_Widget (w);
  749. X    if (XtClass (WIDGET(w)->widget) != class)
  750. X    Primitive_Error ("widget not of expected class: ~s", w);
  751. X}
  752. X
  753. Xstatic Object P_Destroy_Widget (w) Object w; {
  754. X    Check_Widget (w);
  755. X    XtDestroyWidget (WIDGET(w)->widget);
  756. X    return Void;
  757. X}
  758. X
  759. Xstatic Object P_Create_Shell (argc, argv) Object *argv; {
  760. X    register char *sn, *sc;
  761. X    ArgList a;
  762. X    Object name = argv[0], class = argv[1], w = argv[2], d = argv[3];
  763. X
  764. X    Make_C_String (name, sn);
  765. X    Make_C_String (class, sc);
  766. X    Check_Type (w, T_Class);
  767. X    Check_Type (d, T_Display);
  768. X    Encode_Arglist (argc-4, argv+4, a, (Widget)0, CLASS(w)->class);
  769. X    return Make_Widget (XtAppCreateShell (sn, sc, CLASS(w)->class,
  770. X    DISPLAY(d)->dpy, a, (Cardinal)(argc-4)/2));
  771. X}
  772. X
  773. Xstatic Object P_Create_Widget (argc, argv) Object *argv; {
  774. X    ArgList a;
  775. X    char *name = 0;
  776. X    Object x = argv[0], class, parent;
  777. X
  778. X    if (TYPE(x) != T_Class) {
  779. X    Make_C_String (x, name);
  780. X    argv++; argc--;
  781. X    }
  782. X    class = argv[0];
  783. X    parent = argv[1];
  784. X    Check_Type (class, T_Class);
  785. X    Check_Widget (parent);
  786. X    if (name == 0)
  787. X    name = CLASS(class)->name;
  788. X    Encode_Arglist (argc-2, argv+2, a, (Widget)0, CLASS(class)->class);
  789. X    return Make_Widget (XtCreateWidget ((String)name, CLASS(class)->class,
  790. X    WIDGET(parent)->widget, a, (Cardinal)(argc-2)/2));
  791. X}
  792. X
  793. Xstatic Object P_Realize_Widget (w) Object w; {
  794. X    Check_Widget (w);
  795. X    XtRealizeWidget (WIDGET(w)->widget);
  796. X    return Void;
  797. X}
  798. X
  799. Xstatic Object P_Unrealize_Widget (w) Object w; {
  800. X    Check_Widget (w);
  801. X    XtUnrealizeWidget (WIDGET(w)->widget);
  802. X    return Void;
  803. X}
  804. X
  805. Xstatic Object P_Widget_Realizedp (w) Object w; {
  806. X    Check_Widget (w);
  807. X    return XtIsRealized (WIDGET(w)->widget) ? True : False;
  808. X}
  809. X
  810. Xstatic Object P_Widget_Display (w) Object w; {
  811. X    Check_Widget (w);
  812. X    return Make_Display (0, XtDisplay (WIDGET(w)->widget));
  813. X}
  814. X
  815. Xstatic Object P_Widget_Parent (w) Object w; {
  816. X    Check_Widget (w);
  817. X    return Make_Widget (XtParent (WIDGET(w)->widget));
  818. X}
  819. X
  820. Xstatic Object P_Widget_Window (w) Object w; {
  821. X    Check_Widget (w);
  822. X    return Make_Window (0, XtDisplay (WIDGET(w)->widget),
  823. X    XtWindow (WIDGET(w)->widget));
  824. X}
  825. X
  826. Xstatic Object P_Widget_Compositep (w) Object w; {
  827. X    Check_Widget (w);
  828. X    return XtIsComposite (WIDGET(w)->widget) ? True : False;
  829. X}
  830. X
  831. Xstatic Object Manage_Unmanage (children, f) Object children; void (*f)(); {
  832. X    register i, n;
  833. X    Widget *buf;
  834. X    Object tail;
  835. X
  836. X    Check_List (children);
  837. X    n = Internal_Length (children);
  838. X    buf = (Widget *)alloca (n * sizeof (Widget));
  839. X    for (i = 0, tail = children; i < n; i++, tail = Cdr (tail)) {
  840. X    Object w = Car (tail);
  841. X    Check_Widget (w);
  842. X    buf[i] = WIDGET(w)->widget;
  843. X    }
  844. X    f (buf, n);
  845. X    return Void;
  846. X}
  847. X
  848. Xstatic Object P_Manage_Children (children) Object children; {
  849. X    return Manage_Unmanage (children, XtManageChildren);
  850. X}
  851. X
  852. Xstatic Object P_Unmanage_Children (children) Object children; {
  853. X    return Manage_Unmanage (children, XtUnmanageChildren);
  854. X}
  855. X
  856. Xstatic Object P_Widget_Managedp (w) Object w; {
  857. X    Check_Widget (w);
  858. X    return XtIsManaged (WIDGET(w)->widget) ? True : False;
  859. X}
  860. X
  861. Xstatic Object P_Widget_Class (w) Object w; {
  862. X    Check_Widget (w);
  863. X    return Make_Widget_Class (XtClass (WIDGET(w)->widget));
  864. X}
  865. X
  866. Xstatic Object P_Widget_Superclass (w) Object w; {
  867. X    Check_Widget (w);
  868. X    if (XtClass (WIDGET(w)->widget) == widgetClass)
  869. X    return Sym_None;
  870. X    return Make_Widget_Class (XtSuperclass (WIDGET(w)->widget));
  871. X}
  872. X
  873. Xstatic Object P_Widget_Subclassp (w, c) Object w, c; {
  874. X    Check_Widget (w);
  875. X    Check_Type (c, T_Class);
  876. X    return XtIsSubclass (WIDGET(w)->widget, CLASS(c)->class) ? True : False;
  877. X}
  878. X
  879. Xstatic Object P_Set_Mapped_When_Managed (w, m) Object w, m; {
  880. X    Check_Widget (w);
  881. X    Check_Type (m, T_Boolean);
  882. X    XtSetMappedWhenManaged (WIDGET(w)->widget, EQ(m, True));
  883. X    return Void;
  884. X}
  885. X
  886. Xstatic Object P_Map_Widget (w) Object w; {
  887. X    Check_Widget (w);
  888. X    XtMapWidget (WIDGET(w)->widget);
  889. X    return Void;
  890. X}
  891. X
  892. Xstatic Object P_Unmap_Widget (w) Object w; {
  893. X    Check_Widget (w);
  894. X    XtUnmapWidget (WIDGET(w)->widget);
  895. X    return Void;
  896. X}
  897. X
  898. Xstatic Object P_Set_Values (argc, argv) Object *argv; {
  899. X    ArgList a;
  900. X    Widget w;
  901. X    register i, n = (argc-1)/2;
  902. X
  903. X    Check_Widget (argv[0]);
  904. X    w = WIDGET(argv[0])->widget;
  905. X    Encode_Arglist (argc-1, argv+1, a, w, XtClass (w));
  906. X    XtSetValues (w, a, (Cardinal)n);
  907. X    for (i = 0; i < n; i++)
  908. X    if (streq (a[i].name, XtNdestroyCallback))
  909. X        Fiddle_Destroy_Callback (w);
  910. X    return Void;
  911. X}
  912. X
  913. Xstatic Object P_Get_Values (argc, argv) Object *argv; {
  914. X    Widget w;
  915. X
  916. X    Check_Widget (argv[0]);
  917. X    w = WIDGET(argv[0])->widget;
  918. X    return Get_Values (w, argc-1, argv+1);
  919. X}
  920. X
  921. Xstatic Object P_Widget_Context (w) Object w; {
  922. X    Check_Widget (w);
  923. X    return Make_Context (XtWidgetToApplicationContext (WIDGET(w)->widget));
  924. X}
  925. X
  926. Xstatic Object P_Set_Sensitive (w, s) Object w, s; {
  927. X    Check_Widget (w);
  928. X    Check_Type (s, T_Boolean);
  929. X    XtSetSensitive (WIDGET(w)->widget, EQ(s, True));
  930. X    return Void;
  931. X}
  932. X
  933. Xstatic Object P_Sensitivep (w) Object w; {
  934. X    Check_Widget (w);
  935. X    return XtIsSensitive (WIDGET(w)->widget) ? True : False;
  936. X}
  937. X
  938. Xstatic Object P_Window_To_Widget (w) Object w; {
  939. X    Check_Type (w, T_Window);
  940. X    return Make_Widget (XtWindowToWidget (WINDOW(w)->dpy,
  941. X    WIDGET(w)->widget));
  942. X}
  943. X
  944. Xstatic Object P_Name_To_Widget (root, name) Object root, name; {
  945. X    register char *s;
  946. X
  947. X    Check_Widget (root);
  948. X    Make_C_String (name, s);
  949. X    return Make_Widget (XtNameToWidget (WIDGET(root)->widget, s));
  950. X}
  951. X
  952. Xinit_xt_widget () {
  953. X    Generic_Define (Widget, "widget", "widget?");
  954. X    Define_Primitive (P_Destroy_Widget,    "destroy-widget",    1, 1, EVAL);
  955. X    Define_Primitive (P_Create_Shell,      "create-shell",  4, MANY, VARARGS);
  956. X    Define_Primitive (P_Create_Widget,     "create-widget", 2, MANY, VARARGS);
  957. X    Define_Primitive (P_Realize_Widget,    "realize-widget",    1, 1, EVAL);
  958. X    Define_Primitive (P_Unrealize_Widget,  "unrealize-widget",  1, 1, EVAL);
  959. X    Define_Primitive (P_Widget_Realizedp,  "widget-realized?",  1, 1, EVAL);
  960. X    Define_Primitive (P_Widget_Display,    "widget-display",    1, 1, EVAL);
  961. X    Define_Primitive (P_Widget_Parent,     "widget-parent",     1, 1, EVAL);
  962. X    Define_Primitive (P_Widget_Window,     "widget-window",     1, 1, EVAL);
  963. X    Define_Primitive (P_Widget_Compositep, "widget-composite?", 1, 1, EVAL);
  964. X    Define_Primitive (P_Manage_Children,   "manage-children",   1, 1, EVAL);
  965. X    Define_Primitive (P_Unmanage_Children, "unmanage-children", 1, 1, EVAL);
  966. X    Define_Primitive (P_Widget_Managedp,   "widget-managed?",   1, 1, EVAL);
  967. X    Define_Primitive (P_Widget_Class,      "widget-class",      1, 1, EVAL);
  968. X    Define_Primitive (P_Widget_Superclass, "widget-superclass", 1, 1, EVAL);
  969. X    Define_Primitive (P_Widget_Subclassp,  "widget-subclass?",  2, 2, EVAL);
  970. X    Define_Primitive (P_Set_Mapped_When_Managed,
  971. X                  "set-mapped-when-managed!",   2, 2, EVAL);
  972. X    Define_Primitive (P_Map_Widget,        "map-widget",        1, 1, EVAL);
  973. X    Define_Primitive (P_Unmap_Widget,      "unmap-widget",      1, 1, EVAL);
  974. X    Define_Primitive (P_Set_Values,        "set-values!",   1, MANY, VARARGS);
  975. X    Define_Primitive (P_Get_Values,        "get-values",    1, MANY, VARARGS);
  976. X    Define_Primitive (P_Widget_Context,    "widget-context",    1, 1, EVAL);
  977. X    Define_Primitive (P_Set_Sensitive,     "set-sensitive!",    2, 2, EVAL);
  978. X    Define_Primitive (P_Sensitivep,        "widget-sensitive?", 1, 1, EVAL);
  979. X    Define_Primitive (P_Window_To_Widget,  "window->widget",    1, 1, EVAL);
  980. X    Define_Primitive (P_Name_To_Widget,    "name->widget",      2, 2, EVAL);
  981. X}
  982. END_OF_lib/xt/widget.c
  983. if test 8487 -ne `wc -c <lib/xt/widget.c`; then
  984.     echo shar: \"lib/xt/widget.c\" unpacked with wrong size!
  985. fi
  986. # end of overwriting check
  987. fi
  988. if test -f lib/xt/make-widget -a "${1}" != "-c" ; then 
  989.   echo shar: Will not over-write existing file \"lib/xt/make-widget\"
  990. else
  991. echo shar: Extracting \"lib/xt/make-widget\" \(5113 characters\)
  992. sed "s/^X//" >lib/xt/make-widget <<'END_OF_lib/xt/make-widget'
  993. X;;; -*-Scheme-*-
  994. X
  995. X(define type-name #f)
  996. X
  997. X(define classes ())
  998. X(define callbacks ())
  999. X(define primitives ())
  1000. X(define converters ())
  1001. X
  1002. X(define f)
  1003. X
  1004. X(define (check-string proc x name)
  1005. X  (if (not (memq (type x) '(symbol string)))
  1006. X      (error proc (format #f "~s must be string or symbol" name))))
  1007. X
  1008. X(define (define-widget-type name include . prolog)
  1009. X    (if type-name
  1010. X    (error 'define-widget-type "must be called once"))
  1011. X    (check-string 'define-widget-type name 'name)
  1012. X    (check-string 'define-widget-type include 'include)
  1013. X    (set! type-name name)
  1014. X    (format f "#include \"../xt/xt.h\"~%")
  1015. X    (case widget-set
  1016. X      (xhp
  1017. X       (format f "#include <X11/Xw/Xw.h>~%")))
  1018. X    (case widget-set
  1019. X      (xaw
  1020. X       (format f "#include <X11/~a>~%~%" include))
  1021. X      (xhp
  1022. X       (format f "#include <X11/Xw/~a>~%~%" include)))
  1023. X    (if prolog
  1024. X    (begin
  1025. X      (check-string 'define-widget-type (car prolog) 'prolog)
  1026. X      (display (car prolog) f)
  1027. X      (format f "~%~%"))))
  1028. X
  1029. X(define (define-callback class name has-arg?)
  1030. X  (check-string 'define-callback class 'class)
  1031. X  (check-string 'define-callback name 'name)
  1032. X  (if (not (boolean? has-arg?))
  1033. X      (error 'define-callback "has-arg? must be boolean"))
  1034. X  (set! callbacks (cons (list class name has-arg?) callbacks)))
  1035. X
  1036. X(define (c->scheme name body)
  1037. X  (check-string 'c->scheme name 'name)
  1038. X  (define c-name (scheme-to-c-name name))
  1039. X  (string-set! c-name 0 #\S)
  1040. X  (format f "static Object ~a (x) XtArgVal x; {~%" c-name)
  1041. X  (display body f)
  1042. X  (format f "~%}~%~%")
  1043. X  (define s
  1044. X    (format #f "    Define_Converter_To_Scheme (\"~a\", ~a);~%"
  1045. X        name c-name))
  1046. X  (set! converters (cons s converters)))
  1047. X
  1048. X(define (scheme->c name body)
  1049. X  (check-string 'scheme->c name 'name)
  1050. X  (define c-name (scheme-to-c-name name))
  1051. X  (string-set! c-name 0 #\C)
  1052. X  (format f "static XtArgVal ~a (x) Object x; {~%" c-name)
  1053. X  (display body f)
  1054. X  (format f "~%}~%~%")
  1055. X  (define s
  1056. X    (format #f "    Define_Converter_To_C (\"~a\", ~a);~%"
  1057. X        name c-name))
  1058. X  (set! converters (cons s converters)))
  1059. X
  1060. X(define (define-primitive scheme-name args body)
  1061. X  (check-string 'define-primitive scheme-name 'scheme-name)
  1062. X  (if (not (pair? args))
  1063. X      (error 'define-primitive "args must be a list"))
  1064. X  (define c-name (scheme-to-c-name scheme-name))
  1065. X  (format f "static Object ~a (" c-name)
  1066. X  (do ((a args a)) ((null? a))
  1067. X    (display (car a) f)
  1068. X    (set! a (cdr a))
  1069. X    (if a (display ", " f)))
  1070. X  (display ") " f)
  1071. X  (if args
  1072. X      (begin
  1073. X    (display "Object " f)
  1074. X    (do ((a args a)) ((null? a))
  1075. X      (display (car a) f)
  1076. X      (set! a (cdr a))
  1077. X      (if a (display ", " f)))
  1078. X    (display "; {" f)))
  1079. X  (newline f)
  1080. X  (display body f)
  1081. X  (format f "~%}~%~%")
  1082. X  (define s
  1083. X    (format #f "    Define_Primitive (~a, \"~a\", ~a, ~a, EVAL);~%"
  1084. X        c-name scheme-name (length args) (length args)))
  1085. X  (set! primitives (cons s primitives)))
  1086. X
  1087. X;;; [missing conversion from -> to "to"]
  1088. X(define (scheme-to-c-name s)
  1089. X  (if (symbol? s)
  1090. X      (set! s (symbol->string s)))
  1091. X  (define len (string-length s))
  1092. X  (if (char=? (string-ref s (1- len)) #\?)
  1093. X      (string-set! s (1- len) #\p))
  1094. X  (if (char=? (string-ref s (1- len)) #\!)
  1095. X      (set! len (1- len)))
  1096. X  (let loop ((ret "P") (i 0))
  1097. X    (if (>= i len)
  1098. X    ret
  1099. X    (define next
  1100. X      (do ((j i (1+ j))) ((or (= j len) (char=? (string-ref s j) #\-)) j)))
  1101. X    (loop (format #f "~a_~a~a" ret (char-upcase (string-ref s i))
  1102. X              (substring s (1+ i) next)) (1+ next)))))
  1103. X
  1104. X(define (define-widget-class name class . sub-resources)
  1105. X  (check-string 'define-widget-class name 'name)
  1106. X  (check-string 'define-widget-class class 'class)
  1107. X  (set! classes (cons (list name class sub-resources) classes)))
  1108. X
  1109. X(define args (command-line-args))
  1110. X(if (not (= (length args) 3))
  1111. X    (error 'make-widget "expected three arguments"))
  1112. X(define widget-set (string->symbol (caddr args)))
  1113. X(set! f (open-output-file (cadr args)))
  1114. X(load (car args))
  1115. X(if (not type-name)
  1116. X    (error 'make-widget "no widget type defined"))
  1117. X(if (null? classes)
  1118. X    (error 'make-widget "no class definitions"))
  1119. X(format f "init_~a () {~%" type-name)
  1120. X(format f "    XtResourceList r = 0;~%")
  1121. X(do ((c classes (cdr c))) ((null? c))
  1122. X  (define cl (car c))
  1123. X  (define res (caddr cl))
  1124. X  (if res
  1125. X      (begin
  1126. X    (format f
  1127. X      "    r = (XtResourceList)XtMalloc (~a * sizeof (XtResource));~%"
  1128. X      (length res))
  1129. X    (do ((r res (cdr r)) (num 0 (1+ num))) ((null? r))
  1130. X      (define x (car r))
  1131. X      (if (not (= (length x) 3))
  1132. X          (error 'make-widget "bad sub-resource declaration"))
  1133. X      (for-each
  1134. X       (lambda (r)
  1135. X         (if (not (memq (type r) '(symbol string)))
  1136. X         (error 'make-widget "bad type in sub-resource declaration")))
  1137. X       x)
  1138. X      (format f "    r[~a].resource_name = \"~a\";~%" num (car x))
  1139. X      (format f "    r[~a].resource_class = \"~a\";~%" num (cadr x))
  1140. X      (format f "    r[~a].resource_type = \"~a\";~%" num (caddr x)))))
  1141. X  (format f "    Define_Class (\"~a\", ~a, r, ~a);~%" (car cl) (cadr cl)
  1142. X      (length res)))
  1143. X(do ((c callbacks (cdr c))) ((null? c))
  1144. X  (define cb (car c))
  1145. X  (format f "    Define_Callback (\"~a\", \"~a\", ~a);~%" (car cb) (cadr cb)
  1146. X      (if (caddr cb) 1 0)))
  1147. X(for-each (lambda (x) (display x f)) primitives)
  1148. X(for-each (lambda (x) (display x f)) converters)
  1149. X(format f "}~%")
  1150. END_OF_lib/xt/make-widget
  1151. if test 5113 -ne `wc -c <lib/xt/make-widget`; then
  1152.     echo shar: \"lib/xt/make-widget\" unpacked with wrong size!
  1153. fi
  1154. # end of overwriting check
  1155. fi
  1156. if test -f lib/xt/converter.c -a "${1}" != "-c" ; then 
  1157.   echo shar: Will not over-write existing file \"lib/xt/converter.c\"
  1158. else
  1159. echo shar: Extracting \"lib/xt/converter.c\" \(1104 characters\)
  1160. sed "s/^X//" >lib/xt/converter.c <<'END_OF_lib/xt/converter.c'
  1161. X#include "xt.h"
  1162. X
  1163. X#define MAX_CONVERTER   32
  1164. X
  1165. Xtypedef struct {
  1166. X    char *name;
  1167. X    int scheme_to_c;
  1168. X    PFO to_scheme;
  1169. X    PFX to_c;
  1170. X} CONVERTER;
  1171. X
  1172. Xstatic CONVERTER ctab[MAX_CONVERTER], *clast = ctab;
  1173. X
  1174. XDefine_Converter_To_Scheme (name, c) char *name; PFO c; {
  1175. X    Error_Tag = "c->scheme";
  1176. X    if (clast == ctab+MAX_CONVERTER)
  1177. X    Primitive_Error ("too many converters");
  1178. X    clast->name = name;
  1179. X    clast->scheme_to_c = 0;
  1180. X    clast->to_scheme = c;
  1181. X    clast++;
  1182. X}
  1183. X
  1184. XDefine_Converter_To_C (name, c) char *name; PFX c; {
  1185. X    Error_Tag = "scheme->c";
  1186. X    if (clast == ctab+MAX_CONVERTER)
  1187. X    Primitive_Error ("too many converters");
  1188. X    clast->name = name;
  1189. X    clast->scheme_to_c = 1;
  1190. X    clast->to_c = c;
  1191. X    clast++;
  1192. X}
  1193. X
  1194. XPFO Find_Converter_To_Scheme (name) char *name; {
  1195. X    register CONVERTER *p;
  1196. X
  1197. X    for (p = ctab; p < clast; p++)
  1198. X    if (!p->scheme_to_c && streq (p->name, name))
  1199. X        return p->to_scheme;
  1200. X    return 0;
  1201. X}
  1202. X
  1203. XPFX Find_Converter_To_C (name) char *name; {
  1204. X    register CONVERTER *p;
  1205. X
  1206. X    for (p = ctab; p < clast; p++)
  1207. X    if (p->scheme_to_c && streq (p->name, name))
  1208. X        return p->to_c;
  1209. X    return 0;
  1210. X}
  1211. END_OF_lib/xt/converter.c
  1212. if test 1104 -ne `wc -c <lib/xt/converter.c`; then
  1213.     echo shar: \"lib/xt/converter.c\" unpacked with wrong size!
  1214. fi
  1215. # end of overwriting check
  1216. fi
  1217. if test -f lib/xt/popup.c -a "${1}" != "-c" ; then 
  1218.   echo shar: Will not over-write existing file \"lib/xt/popup.c\"
  1219. else
  1220. echo shar: Extracting \"lib/xt/popup.c\" \(1335 characters\)
  1221. sed "s/^X//" >lib/xt/popup.c <<'END_OF_lib/xt/popup.c'
  1222. X#include "xt.h"
  1223. X
  1224. Xstatic SYMDESCR Grab_Kind_Syms[] = {
  1225. X    { "grab-none",         XtGrabNone },
  1226. X    { "grab-nonexclusive", XtGrabNonexclusive },
  1227. X    { "grab-exclusive",    XtGrabExclusive },
  1228. X    { 0, 0 }
  1229. X};
  1230. X
  1231. Xstatic Object P_Create_Popup_Shell (argc, argv) Object *argv; {
  1232. X    ArgList a;
  1233. X    char *name = 0;
  1234. X    Object x = argv[0], class, parent;
  1235. X
  1236. X    if (TYPE(x) != T_Class) {
  1237. X    Make_C_String (x, name);
  1238. X    argv++; argc--;
  1239. X    }
  1240. X    class = argv[0];
  1241. X    parent = argv[1];
  1242. X    Check_Type (class, T_Class);
  1243. X    Check_Widget (parent);
  1244. X    if (name == 0)
  1245. X    name = CLASS(class)->name;
  1246. X    Encode_Arglist (argc-2, argv+2, a, (Widget)0, CLASS(class)->class);
  1247. X    return Make_Widget (XtCreatePopupShell (name, CLASS(class)->class,
  1248. X    WIDGET(parent)->widget, a, (Cardinal)(argc-2)/2));
  1249. X}
  1250. X
  1251. Xstatic Object P_Popup (shell, grab_kind) Object shell, grab_kind; {
  1252. X    Check_Widget (shell);
  1253. X    XtPopup (WIDGET(shell)->widget, Symbols_To_Bits (grab_kind, 0,
  1254. X    Grab_Kind_Syms));
  1255. X    return Void;
  1256. X}
  1257. X
  1258. Xstatic Object P_Popdown (shell) Object shell; {
  1259. X    Check_Widget (shell);
  1260. X    XtPopdown (WIDGET(shell)->widget);
  1261. X    return Void;
  1262. X}
  1263. X
  1264. Xinit_xt_popup () {
  1265. X    Define_Primitive (P_Create_Popup_Shell, "create-popup-shell",
  1266. X                        2, MANY, VARARGS);
  1267. X    Define_Primitive (P_Popup,   "popup",   2, 2, EVAL);
  1268. X    Define_Primitive (P_Popdown, "popdown", 1, 1, EVAL);
  1269. X}
  1270. END_OF_lib/xt/popup.c
  1271. if test 1335 -ne `wc -c <lib/xt/popup.c`; then
  1272.     echo shar: \"lib/xt/popup.c\" unpacked with wrong size!
  1273. fi
  1274. # end of overwriting check
  1275. fi
  1276. if test -f lib/xt/resource.c -a "${1}" != "-c" ; then 
  1277.   echo shar: Will not over-write existing file \"lib/xt/resource.c\"
  1278. else
  1279. echo shar: Extracting \"lib/xt/resource.c\" \(14293 characters\)
  1280. sed "s/^X//" >lib/xt/resource.c <<'END_OF_lib/xt/resource.c'
  1281. X#include "xt.h"
  1282. X#include <X11/Xmu.h>
  1283. X
  1284. X#include <ctype.h>
  1285. X
  1286. Xstatic SYMDESCR Orientation_Syms[] = {
  1287. X    { "horizontal",         XtorientHorizontal },
  1288. X    { "vertical",           XtorientVertical },
  1289. X    { 0, 0 }
  1290. X};
  1291. X
  1292. Xstatic SYMDESCR Justify_Syms[] = {
  1293. X    { "left",              XtJustifyLeft },
  1294. X    { "center",            XtJustifyCenter },
  1295. X    { "right",             XtJustifyRight },
  1296. X    { 0, 0 }
  1297. X};
  1298. X
  1299. X#define XtRFloat             "Float"
  1300. X#define XtRWidget            "Widget"
  1301. X
  1302. X#define T_Unknown            -1
  1303. X#define T_String_Or_Symbol   -2
  1304. X#define T_Callbacklist       -3
  1305. X#define T_Float              -4
  1306. X#define T_Backing_Store      -5
  1307. X#define T_Orientation        -6
  1308. X#define T_Justify            -7
  1309. X#define T_Translations       -8
  1310. X
  1311. Xstatic Resource_To_Scheme_Type (t) register char *t; {
  1312. X    if (streq (XtRBackingStore, t))
  1313. X    return T_Backing_Store;
  1314. X    else if (streq (XtRBoolean, t))
  1315. X    return T_Boolean;
  1316. X    else if (streq (XtRCallback, t))
  1317. X    return T_Callbacklist;
  1318. X    else if (streq (XtRCursor, t))
  1319. X    return T_Cursor;
  1320. X    else if (streq (XtRDimension, t))
  1321. X    return T_Fixnum;
  1322. X    else if (streq (XtRDisplay, t))
  1323. X    return T_Display;
  1324. X    else if (streq (XtRFloat, t))
  1325. X    return T_Float;
  1326. X    else if (streq (XtRFont, t))
  1327. X    return T_Font;
  1328. X    else if (streq (XtRFontStruct, t))
  1329. X    return T_Font;
  1330. X    else if (streq (XtRInt, t))
  1331. X    return T_Fixnum;
  1332. X    else if (streq (XtRJustify, t))
  1333. X    return T_Justify;
  1334. X    else if (streq (XtROrientation, t))
  1335. X    return T_Orientation;
  1336. X    else if (streq (XtRPixel, t))
  1337. X    return T_Pixel;
  1338. X    else if (streq (XtRPixmap, t))
  1339. X    return T_Pixmap;
  1340. X    else if (streq (XtRPosition, t))
  1341. X    return T_Fixnum;
  1342. X    else if (streq (XtRShort, t))
  1343. X    return T_Fixnum;
  1344. X    else if (streq (XtRString, t))
  1345. X    return T_String_Or_Symbol;
  1346. X    else if (streq (XtRTranslationTable, t))
  1347. X    return T_Translations;
  1348. X    else if (streq (XtRUnsignedChar, t))
  1349. X    return T_Character;
  1350. X    else if (streq (XtRWidget, t))
  1351. X    return T_Widget;
  1352. X    else if (streq (XtRWindow, t))
  1353. X    return T_Window;
  1354. X    return T_Unknown;
  1355. X}
  1356. X
  1357. XGet_All_Resources (w, c, rp, np, cp) Widget w; WidgetClass c;
  1358. X    XtResource **rp; int *np, *cp; {
  1359. X    XtResource *r, *sr, *cr;
  1360. X    int nr, snr = 0, cnr = 0;
  1361. X
  1362. X    XtGetResourceList (c, &r, &nr);
  1363. X    if (w == 0) /* Not allowed with get-values and set-values! */
  1364. X    Get_Sub_Resource_List (c, &sr, &snr);
  1365. X    if (w && XtParent (w))
  1366. X    XtGetConstraintResourceList (XtClass (XtParent (w)), &cr, &cnr);
  1367. X    *np = nr + snr + cnr;
  1368. X    *cp = cnr;
  1369. X    *rp = (XtResource *)XtMalloc (*np * sizeof (XtResource));
  1370. X    bcopy ((char *)r, (char *)*rp, nr * sizeof (XtResource));
  1371. X    XtFree ((char *)r);
  1372. X    if (snr)
  1373. X    bcopy ((char *)sr, (char *)(*rp + nr), snr * sizeof (XtResource));
  1374. X    if (cnr) {
  1375. X    bcopy ((char *)cr, (char *)(*rp + nr+snr), cnr * sizeof (XtResource));
  1376. X    XtFree ((char *)cr);
  1377. X    }
  1378. X}
  1379. X
  1380. XConvert_Args (ac, av, to, widget, class) Object *av; ArgList to;
  1381. X    Widget widget; WidgetClass class; {
  1382. X    register char *name, *res;
  1383. X    register i, j, k;
  1384. X    Object arg, val;
  1385. X    XtResource *r;
  1386. X    int nr, nc;
  1387. X    int st, dt;
  1388. X    char key[128];
  1389. X    PFX converter;
  1390. X
  1391. X    if (ac & 1)
  1392. X    Primitive_Error ("missing argument value");
  1393. X    Get_All_Resources (widget, class, &r, &nr, &nc);
  1394. X    /* Note:
  1395. X     * `r' is not freed in case of error.
  1396. X     */
  1397. X    for (i = k = 0; k < ac; i++, k++) {
  1398. X    arg = av[k];
  1399. X    Make_C_String (arg, name);
  1400. X    Make_Resource_Name (name);
  1401. X    for (j = 0; j < nr && !streq (name, r[j].resource_name); j++)
  1402. X        ;
  1403. X    if (j == nr)
  1404. X        Primitive_Error ("no such resource: ~s", arg);
  1405. X    res = r[j].resource_name;
  1406. X    val = av[++k];
  1407. X    st = TYPE(val);
  1408. X    dt = Resource_To_Scheme_Type (r[j].resource_type);
  1409. X
  1410. X    if (widget && j >= nr-nc)
  1411. X        class = XtClass (XtParent (widget));
  1412. X    sprintf (key, "%s-%s", Class_Name (class), name);
  1413. X    converter = Find_Converter_To_C (key);
  1414. X
  1415. X    if (converter) {
  1416. X        XtArgVal ret = converter (val);
  1417. X        XtSetArg (to[i], res, ret);
  1418. X    } else if (dt == T_String_Or_Symbol) {
  1419. X        char *s;
  1420. X
  1421. X        Make_C_String (val, s);
  1422. X        XtSetArg (to[i], res, XtNewString (s));  /* Never freed! */
  1423. X    } else if (dt == T_Callbacklist) {
  1424. X        int n;
  1425. X        XtCallbackList callbacks;
  1426. X
  1427. X        Check_Callback_List (val);
  1428. X        n = Internal_Length (val);
  1429. X        callbacks = (XtCallbackRec *)  /* Never freed! */
  1430. X            XtMalloc ((n+1) * sizeof (XtCallbackRec));
  1431. X        callbacks[n].callback = 0;
  1432. X        callbacks[n].closure = 0;
  1433. X        Fill_Callbacks (val, callbacks, n,
  1434. X        Find_Callback_Converter (class, name, arg));
  1435. X        XtSetArg (to[i], res, callbacks);
  1436. X    } else if (dt == T_Float) {
  1437. X        float f = (float)Get_Double (val);
  1438. X        to[i].name = res;
  1439. X        bcopy ((char *)&f, (char *)&to[i].value, sizeof f);
  1440. X    } else if (dt == T_Backing_Store) {
  1441. X        XtSetArg (to[i], res, Symbols_To_Bits (val, 0,
  1442. X        Backing_Store_Syms));
  1443. X    } else if (dt == T_Orientation) {
  1444. X        XtSetArg (to[i], res, Symbols_To_Bits (val, 0, Orientation_Syms));
  1445. X    } else if (dt == T_Justify) {
  1446. X        XtSetArg (to[i], res, Symbols_To_Bits (val, 0, Justify_Syms));
  1447. X    } else if (dt == T_Translations) {
  1448. X        XtSetArg (to[i], res, Get_Translations (val));
  1449. X    } else {
  1450. X        if (st != dt) {
  1451. X        char msg[128];
  1452. X        if (widget && (st == T_String || st == T_Symbol)) {
  1453. X            char *s;
  1454. X            XrmValue src, dst;
  1455. X
  1456. X            Make_C_String (val, s);
  1457. X            src.size = strlen (s);
  1458. X            src.addr = (caddr_t)s;
  1459. X            XtConvert (widget, (String)XtRString, &src,
  1460. X            r[j].resource_type, &dst);
  1461. X            if (dst.addr) {
  1462. X            XtSetArg (to[i], res, *(XtArgVal *)dst.addr);
  1463. X            goto done;
  1464. X            }
  1465. X        }
  1466. X        sprintf (msg, "%s: can't convert %s ~s to %s", name,
  1467. X            Types[st].name, r[j].resource_type);
  1468. X        Primitive_Error (msg, val);
  1469. X        }
  1470. X        if (dt == T_Boolean) {
  1471. X        XtSetArg (to[i], res, EQ(val, True));
  1472. X        } else if (dt == T_Cursor) {
  1473. X        XtSetArg (to[i], res, CURSOR(val)->cursor);
  1474. X        } else if (dt == T_Fixnum) {
  1475. X        XtSetArg (to[i], res, FIXNUM(val));
  1476. X        } else if (dt == T_Display) {
  1477. X        XtSetArg (to[i], res, DISPLAY(val)->dpy);
  1478. X        } else if (dt == T_Font) {
  1479. X        Open_Font_Maybe (val);
  1480. X        if (streq (r[j].resource_type, XtRFontStruct))
  1481. X            XtSetArg (to[i], res, FONT(val)->info);
  1482. X        else
  1483. X            XtSetArg (to[i], res, FONT(val)->id);
  1484. X        } else if (dt == T_Pixel) {
  1485. X        XtSetArg (to[i], res, PIXEL(val)->pix);
  1486. X        } else if (dt == T_Pixmap) {
  1487. X        XtSetArg (to[i], res, PIXMAP(val)->pm);
  1488. X        } else if (dt == T_Character) {
  1489. X        XtSetArg (to[i], res, CHAR(val));
  1490. X        } else if (dt == T_Widget) {
  1491. X        XtSetArg (to[i], res, WIDGET(val)->widget);
  1492. X        } else if (dt == T_Window) {
  1493. X        XtSetArg (to[i], res, WINDOW(val)->win);
  1494. X        } else Panic ("bad conversion type");
  1495. X    } 
  1496. Xdone: ;
  1497. X    }
  1498. X    XtFree ((char *)r);
  1499. X}
  1500. X
  1501. XObject Get_Values (w, ac, av) Widget w; Object *av; {
  1502. X    register char *name;
  1503. X    register i, j;
  1504. X    Object arg;
  1505. X    XtResource *r;
  1506. X    int nr, nc;
  1507. X    int t;
  1508. X    ArgList argl;
  1509. X    Object ret, tail;
  1510. X    Display *dpy;
  1511. X    char key[128];
  1512. X    PFO converter;
  1513. X    Widget w2;
  1514. X    GC_Node2;
  1515. X
  1516. X    argl = (Arg *)alloca (ac * sizeof (Arg));
  1517. X    Get_All_Resources (w, XtClass (w), &r, &nr, &nc);
  1518. X    /* Note:
  1519. X     * `r' is not freed in case of error.
  1520. X     */
  1521. X    for (i = 0; i < ac; i++) {
  1522. X    arg = av[i];
  1523. X    Check_Type (arg, T_Symbol);
  1524. X    Make_C_String (arg, name);
  1525. X    Make_Resource_Name (name);
  1526. X    for (j = 0; j < nr && !streq (name, r[j].resource_name); j++)
  1527. X        ;
  1528. X    if (j == nr)
  1529. X        Primitive_Error ("no such resource: ~s", arg);
  1530. X    argl[i].name = name;
  1531. X    argl[i].value = (XtArgVal)alloca (r[j].resource_size);
  1532. X    }
  1533. X    XtGetValues (w, argl, (Cardinal)ac);
  1534. X    ret = tail = P_Make_List (Make_Fixnum (ac), Null);
  1535. X    GC_Link2 (ret, tail);
  1536. X    /*
  1537. X     * Display is needed for resources like cursor and pixmap.
  1538. X     * XtDisplay(w) is not necessarily the right one!
  1539. X     */
  1540. X    dpy = XtDisplay (w);
  1541. X    for (i = 0; i < ac; i++, tail = Cdr (tail)) {
  1542. X    Object o;
  1543. X    XtArgVal val = argl[i].value;
  1544. X    for (j = 0; j < nr && !streq (argl[i].name, r[j].resource_name); j++)
  1545. X        ;
  1546. X    t = Resource_To_Scheme_Type (r[j].resource_type);
  1547. X
  1548. X    w2 = (j >= nr-nc) ? XtParent (w) : w;
  1549. X    sprintf (key, "%s-%s", Class_Name (XtClass (w2)), argl[i].name);
  1550. X    converter = Find_Converter_To_Scheme (key);
  1551. X
  1552. X    if (converter) {
  1553. X        o = converter (*(XtArgVal **)val);
  1554. X    } else if (t == T_String_Or_Symbol) {
  1555. X        char *s = *(char **)val;
  1556. X
  1557. X        if (s == 0) s = "";
  1558. X        o = Make_String (s, strlen (s));
  1559. X    } else if (t == T_Callbacklist) {
  1560. X        register i, n;
  1561. X        Object ret, tail;
  1562. X        XtCallbackList callbacks = *(XtCallbackList *)val;
  1563. X        GC_Node;
  1564. X
  1565. X        for (n = 0; callbacks[n].callback; n++)
  1566. X        ;
  1567. X        ret = tail = P_Make_List (Make_Fixnum (n), Null);
  1568. X        GC_Link2 (ret, tail);
  1569. X        for (i = 0; i < n; i++, tail = Cdr (tail))
  1570. X        Car (tail) = Get_Callbackfun (callbacks[i].closure);
  1571. X        GC_Unlink;
  1572. X        o = ret;
  1573. X    } else if (t == T_Float) {
  1574. X        o = Make_Reduced_Flonum ((double)*(float *)val);
  1575. X    } else if (t == T_Backing_Store) {
  1576. X        o = Bits_To_Symbols ((unsigned long)*(int *)val, 0,
  1577. X        Backing_Store_Syms);
  1578. X        if (Nullp (o))
  1579. X        Primitive_Error ("invalid backing-store (Xt bug)");
  1580. X    } else if (t == T_Orientation) {
  1581. X        o = Bits_To_Symbols ((unsigned long)*(int *)val, 0,
  1582. X        Orientation_Syms);
  1583. X    } else if (t == T_Justify) {
  1584. X        o = Bits_To_Symbols ((unsigned long)*(int *)val, 0, Justify_Syms);
  1585. X    } else if (t == T_Boolean) {
  1586. X        o = (Boolean)*(Boolean *)val ? True : False;
  1587. X    } else if (t == T_Cursor) {
  1588. X        o = Make_Cursor (dpy, *(Cursor *)val);
  1589. X    } else if (t == T_Fixnum) {
  1590. X        /*
  1591. X         * Assumption: Dimension and Position are short!
  1592. X         */
  1593. X        if (streq (r[j].resource_type, XtRInt))
  1594. X        o = Make_Integer (*(int *)val);
  1595. X        else
  1596. X        o = Make_Integer (*(short *)val);
  1597. X    } else if (t == T_Display) {
  1598. X        o = Make_Display (0, dpy);
  1599. X    } else if (t == T_Font) {
  1600. X        if (streq (r[j].resource_type, XtRFontStruct)) {
  1601. X        o = Make_Font (dpy, False, (Font)0, *(XFontStruct **)val);
  1602. X        } else {
  1603. X        XFontStruct *info;
  1604. X        Disable_Interrupts;
  1605. X        info = XQueryFont (dpy, *(Font *)val);
  1606. X        Enable_Interrupts;
  1607. X        o = Make_Font (dpy, False, *(Font *)val, info);
  1608. X        }
  1609. X    } else if (t == T_Pixel) {
  1610. X        o = Make_Pixel (*(unsigned long *)val);
  1611. X    } else if (t == T_Pixmap) {
  1612. X        o = Make_Pixmap (dpy, *(Pixmap *)val);
  1613. X    } else if (t == T_Character) {
  1614. X        o = Make_Char (*(unsigned char *)val);
  1615. X    } else if (t == T_Widget) {
  1616. X        o = Make_Widget (*(Widget *)val);
  1617. X    } else if (t == T_Window) {
  1618. X        o = Make_Window (0, dpy, *(Window *)val);
  1619. X    } else {
  1620. X        char s[128];
  1621. X        sprintf (s, "%s: no converter for %s", argl[i].name,
  1622. X        r[j].resource_type);
  1623. X        Primitive_Error (s);
  1624. X    }
  1625. X    Car (tail) = o;
  1626. X    }
  1627. X    XtFree ((char *)r);
  1628. X    GC_Unlink;
  1629. X    return ret;
  1630. X}
  1631. X
  1632. X/* Convert `mapped-when-managed' to `mappedWhenManaged'.
  1633. X */
  1634. XMake_Resource_Name (s) register char *s; {
  1635. X    register char *p;
  1636. X
  1637. X    for (p = s; *s; ) {
  1638. X    if (*s == '-') {
  1639. X        if (*++s) {
  1640. X        if (islower (*s))
  1641. X            *s = toupper (*s);
  1642. X        *p++ = *s++;
  1643. X        }
  1644. X    } else *p++ = *s++;
  1645. X    }
  1646. X    *p = '\0';
  1647. X}
  1648. X
  1649. XObject Get_Resources (c, fun, freeit) WidgetClass c; void (*fun)(); {
  1650. X    XtResource *r;
  1651. X    register XtResource *p;
  1652. X    int nr;
  1653. X    Object ret, tail, tail2, x;
  1654. X    GC_Node3;
  1655. X    
  1656. X    fun (c, &r, &nr);
  1657. X    /* Note:
  1658. X     * `r' is not freed in case of error.
  1659. X     */
  1660. X    ret = tail = tail2 = P_Make_List (Make_Fixnum (nr), Null);
  1661. X    GC_Link3 (ret, tail, tail2);
  1662. X    for (p = r; p < r+nr; p++, tail = Cdr (tail)) {
  1663. X    x = tail2 = P_Make_List (Make_Fixnum (3), Null);
  1664. X    Car (tail) = tail2 = x;
  1665. X    x = Intern (p->resource_name);
  1666. X    Car (tail2) = x; tail2 = Cdr (tail2);
  1667. X    x = Intern (p->resource_class);
  1668. X    Car (tail2) = x; tail2 = Cdr (tail2);
  1669. X    x = Intern (p->resource_type);
  1670. X    Car (tail2) = x;
  1671. X    }
  1672. X    GC_Unlink;
  1673. X    if (freeit) XtFree ((char *)r);
  1674. X    return ret;
  1675. X}
  1676. X
  1677. X/* --------------------------------------------------------------------
  1678. X *
  1679. X * Delete this when XtGetConstraintResourceList() is provided by
  1680. X * the Xt intrinsics.
  1681. X *
  1682. X * This code has been written by Paul Asente <asente@wsl.dec.com>.
  1683. X *
  1684. X * Copyright 1985, 1986, 1987, 1988 by the Massachusetts Institute
  1685. X * of Technology
  1686. X * 
  1687. X * Permission to use, copy, modify, and distribute this
  1688. X * software and its documentation for any purpose and without
  1689. X * fee is hereby granted, provided that the above copyright
  1690. X * notice appear in all copies and that both that copyright
  1691. X * notice and this permission notice appear in supporting
  1692. X * documentation, and that the name of M.I.T. not be used in
  1693. X * advertising or publicity pertaining to distribution of the
  1694. X * software without specific, written prior permission.
  1695. X * M.I.T. makes no representations about the suitability of
  1696. X * this software for any purpose.  It is provided "as is"
  1697. X * without express or implied warranty.
  1698. X *
  1699. X */
  1700. X
  1701. X#include <X11/Intrinsic.h>
  1702. X#include <X11/IntrinsicP.h>
  1703. X#include <X11/CoreP.h>
  1704. X
  1705. Xvoid XtGetConstraintResourceList(widget_class, resources, num_resources)
  1706. X    WidgetClass widget_class;
  1707. X    XtResourceList *resources;
  1708. X    Cardinal *num_resources;
  1709. X{
  1710. X    if (_XtClassIsSubclass(widget_class, constraintWidgetClass)) {
  1711. X        ConstraintWidgetClass cwc = (ConstraintWidgetClass) widget_class;
  1712. X
  1713. X        GetResourceList(widget_class, resources, num_resources,
  1714. X            cwc->constraint_class.num_resources,
  1715. X            cwc->constraint_class.resources);
  1716. X    } else {
  1717. X        *resources = NULL;
  1718. X        *num_resources = 0;
  1719. X    }
  1720. X}
  1721. X
  1722. Xstatic GetResourceList(widget_class, resources, num_resources, count, r_source)
  1723. X    WidgetClass widget_class;
  1724. X    XtResourceList *resources;
  1725. X    Cardinal *num_resources;
  1726. X    Cardinal count;
  1727. X    XtResourceList r_source;
  1728. X{
  1729. X    int size = count * sizeof(XtResource);
  1730. X    register int i, dest = 0;
  1731. X    register XtResourceList dlist;
  1732. X    register XtResourceList *source;
  1733. X
  1734. X    *resources = (XtResourceList) XtMalloc((unsigned) size);
  1735. X
  1736. X    if (!widget_class->core_class.class_inited) {
  1737. X        /* Easy case */
  1738. X
  1739. X        bcopy((char *) r_source, (char *) *resources, size);
  1740. X        *num_resources = count;
  1741. X        return;
  1742. X    }
  1743. X
  1744. X    /* Nope, it's the hard case */
  1745. X
  1746. X    dlist = *resources;
  1747. X    source = (XtResourceList *) r_source;
  1748. X    for (i = 0; i < count; i++) {
  1749. X        if (source[i] != NULL) {
  1750. X        dlist[dest].resource_name = (String)
  1751. X            XrmQuarkToString((XrmQuark) source[i]->resource_name);
  1752. X        dlist[dest].resource_class = (String) 
  1753. X            XrmQuarkToString((XrmQuark) source[i]->resource_class);
  1754. X        dlist[dest].resource_type = (String)
  1755. X            XrmQuarkToString((XrmQuark) source[i]->resource_type);
  1756. X        dlist[dest].resource_size = source[i]->resource_size;
  1757. X        dlist[dest].resource_offset = -(source[i]->resource_offset + 1);
  1758. X        dlist[dest].default_type = (String)
  1759. X            XrmQuarkToString((XrmQuark) source[i]->default_type);
  1760. X        dlist[dest].default_addr = source[i]->default_addr;
  1761. X        dest++;
  1762. X        }
  1763. X    }
  1764. X    *num_resources = dest;
  1765. X}
  1766. END_OF_lib/xt/resource.c
  1767. if test 14293 -ne `wc -c <lib/xt/resource.c`; then
  1768.     echo shar: \"lib/xt/resource.c\" unpacked with wrong size!
  1769. fi
  1770. # end of overwriting check
  1771. fi
  1772. if test -f lib/xt/BUGS -a "${1}" != "-c" ; then 
  1773.   echo shar: Will not over-write existing file \"lib/xt/BUGS\"
  1774. else
  1775. echo shar: Extracting \"lib/xt/BUGS\" \(960 characters\)
  1776. sed "s/^X//" >lib/xt/BUGS <<'END_OF_lib/xt/BUGS'
  1777. XResources that are inherited from a superclass cannot be set
  1778. Xby functions like create-widget; they must be set after the
  1779. Xwidget has been created by a call to set-values!.
  1780. XThis restriction is only there for the first widget of each class.
  1781. X
  1782. XThe reason for this is that the complete resource list is
  1783. Xnot available (through XtGetResourceList) before the class
  1784. Xhas been initialized.
  1785. X
  1786. XConstraint resources also can only be set by means of set-values!.
  1787. X
  1788. XSubresources, on the other hand, can only be set by functions like
  1789. Xcreate-widget (this is a restriction imposed by Xt).  Subresources
  1790. Xcannot be read with get-values.  In addition, converters do not
  1791. Xwork for subresources (since XtConvert needs a widget instance).
  1792. X
  1793. X
  1794. XCallbacks *must* return; e.g. a (reset) from within a callback is
  1795. Xnot allowed.  This is a bug in Xt.
  1796. X
  1797. X
  1798. XMissing: context-add-input, context-remove-input, accelerators
  1799. Xresource converters, keycode translators, case converters,
  1800. Xshared GCs, selections
  1801. END_OF_lib/xt/BUGS
  1802. if test 960 -ne `wc -c <lib/xt/BUGS`; then
  1803.     echo shar: \"lib/xt/BUGS\" unpacked with wrong size!
  1804. fi
  1805. # end of overwriting check
  1806. fi
  1807. if test -f lib/xt/identifier.c -a "${1}" != "-c" ; then 
  1808.   echo shar: Will not over-write existing file \"lib/xt/identifier.c\"
  1809. else
  1810. echo shar: Extracting \"lib/xt/identifier.c\" \(1146 characters\)
  1811. sed "s/^X//" >lib/xt/identifier.c <<'END_OF_lib/xt/identifier.c'
  1812. X
  1813. X#include "xt.h"
  1814. X
  1815. XGeneric_Predicate (Identifier);
  1816. X
  1817. Xstatic Object Identifier_Equal (x, y) Object x, y; {
  1818. X    register struct S_Identifier *p = IDENTIFIER(x), *q = IDENTIFIER(y);
  1819. X    return p->type == q->type && p->val == q->val && !p->free && !q->free;
  1820. X}
  1821. X
  1822. XGeneric_Print (Identifier, "#[identifier %u]", POINTER(x));
  1823. X
  1824. XObject Make_Id (type, val, num) caddr_t val; {
  1825. X    register char *p;
  1826. X    Object i;
  1827. X
  1828. X    i = Find_Object (T_Identifier, (GENERIC)0, Match_Xt_Obj, type, val);
  1829. X    if (Nullp (i)) {
  1830. X    p = Get_Bytes (sizeof (struct S_Identifier));
  1831. X    SET (i, T_Identifier, (struct S_Identifier *)p);
  1832. X    IDENTIFIER(i)->tag = Null;
  1833. X    IDENTIFIER(i)->type = type;
  1834. X    IDENTIFIER(i)->val = val;
  1835. X    IDENTIFIER(i)->num = num;
  1836. X    IDENTIFIER(i)->free = 0;
  1837. X    Register_Object (i, (GENERIC)0, (PFO)0, 0);
  1838. X    }
  1839. X    return i;
  1840. X}
  1841. X
  1842. Xcaddr_t Use_Id (x, type) Object x; {
  1843. X    Check_Type (x, T_Identifier);
  1844. X    if (IDENTIFIER(x)->type != type || IDENTIFIER(x)->free)
  1845. X    Primitive_Error ("invalid identifier");
  1846. X    IDENTIFIER(x)->free = 1;
  1847. X    Deregister_Object (x);
  1848. X    return IDENTIFIER(x)->val;
  1849. X}
  1850. X
  1851. Xinit_xt_identifier () {
  1852. X    Generic_Define (Identifier, "identifier", "identifier?");
  1853. X}
  1854. END_OF_lib/xt/identifier.c
  1855. if test 1146 -ne `wc -c <lib/xt/identifier.c`; then
  1856.     echo shar: \"lib/xt/identifier.c\" unpacked with wrong size!
  1857. fi
  1858. # end of overwriting check
  1859. fi
  1860. if test ! -d lib/util ; then
  1861.     echo shar: Creating directory \"lib/util\"
  1862.     mkdir lib/util
  1863. fi
  1864. if test -f lib/util/symbol.h -a "${1}" != "-c" ; then 
  1865.   echo shar: Will not over-write existing file \"lib/util/symbol.h\"
  1866. else
  1867. echo shar: Extracting \"lib/util/symbol.h\" \(142 characters\)
  1868. sed "s/^X//" >lib/util/symbol.h <<'END_OF_lib/util/symbol.h'
  1869. Xtypedef struct {
  1870. X    char *name;
  1871. X    unsigned long val;
  1872. X} SYMDESCR;
  1873. X
  1874. Xextern unsigned long Symbols_To_Bits();
  1875. Xextern Object Bits_To_Symbols();
  1876. END_OF_lib/util/symbol.h
  1877. if test 142 -ne `wc -c <lib/util/symbol.h`; then
  1878.     echo shar: \"lib/util/symbol.h\" unpacked with wrong size!
  1879. fi
  1880. # end of overwriting check
  1881. fi
  1882. if test -f lib/util/objects.h -a "${1}" != "-c" ; then 
  1883.   echo shar: Will not over-write existing file \"lib/util/objects.h\"
  1884. else
  1885. echo shar: Extracting \"lib/util/objects.h\" \(56 characters\)
  1886. sed "s/^X//" >lib/util/objects.h <<'END_OF_lib/util/objects.h'
  1887. Xtypedef Object (*PFO)();
  1888. X
  1889. Xextern Object Find_Object ();
  1890. END_OF_lib/util/objects.h
  1891. if test 56 -ne `wc -c <lib/util/objects.h`; then
  1892.     echo shar: \"lib/util/objects.h\" unpacked with wrong size!
  1893. fi
  1894. # end of overwriting check
  1895. fi
  1896. if test ! -d lib/xhp ; then
  1897.     echo shar: Creating directory \"lib/xhp\"
  1898.     mkdir lib/xhp
  1899. fi
  1900. echo shar: End of archive 13 \(of 14\).
  1901. cp /dev/null ark13isdone
  1902. MISSING=""
  1903. for I in 1 2 3 4 5 6 7 8 9 10 11 12 13 14 ; do
  1904.     if test ! -f ark${I}isdone ; then
  1905.     MISSING="${MISSING} ${I}"
  1906.     fi
  1907. done
  1908. if test "${MISSING}" = "" ; then
  1909.     echo You have unpacked all 14 archives.
  1910.     rm -f ark[1-9]isdone ark[1-9][0-9]isdone
  1911. else
  1912.     echo You still need to unpack the following archives:
  1913.     echo "        " ${MISSING}
  1914. fi
  1915. ##  End of shell archive.
  1916. exit 0
  1917.