home *** CD-ROM | disk | FTP | other *** search
/ Usenet 1994 October / usenetsourcesnewsgroupsinfomagicoctober1994disk2.iso / misc / volume8 / elk / part12 < prev    next >
Text File  |  1989-09-23  |  62KB  |  1,893 lines
  1. Newsgroups: comp.sources.misc
  2. From: allbery@uunet.UU.NET (Brandon S. Allbery - comp.sources.misc)
  3. Subject: v08i060: Elk (Extension Language Toolkit) part 12 of 14
  4. Reply-To: net@tub.UUCP (Oliver Laumann)
  5.  
  6. Posting-number: Volume 8, Issue 60
  7. Submitted-by: net@tub.UUCP (Oliver Laumann)
  8. Archive-name: elk/part12
  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 12 (of 14)."
  21. # Contents:  lib/xlib/property.c lib/xlib/pointer.c lib/xlib/wm.c
  22. #   lib/xaw/Makefile lib/xaw/grip.d lib/xaw/list.d lib/xaw/scroll.d
  23. #   lib/xaw/box.d lib/xaw/shell.d lib/xaw/clock.d lib/xaw/dialog.d
  24. #   lib/xaw/vpaned.d lib/xaw/ascii.d lib/xaw/viewport.d lib/xt
  25. #   lib/xt/examples lib/xt/examples/dialog lib/xt/examples/scrollbar
  26. #   lib/xt/examples/scrollbox lib/xt/examples/list
  27. #   lib/xt/examples/grip lib/xt/examples/viewport lib/xt/examples/text
  28. #   lib/xt/examples/hp-misc lib/xt/examples/hp-arrow
  29. #   lib/xt/examples/hp-list lib/xt/examples/hp-menu lib/xt/Makefile
  30. #   lib/xt/objects.c lib/xt/error.c
  31. # Wrapped by net@tub on Sun Sep 17 17:32:38 1989
  32. PATH=/bin:/usr/bin:/usr/ucb ; export PATH
  33. if test -f lib/xlib/property.c -a "${1}" != "-c" ; then 
  34.   echo shar: Will not over-write existing file \"lib/xlib/property.c\"
  35. else
  36. echo shar: Extracting \"lib/xlib/property.c\" \(7184 characters\)
  37. sed "s/^X//" >lib/xlib/property.c <<'END_OF_lib/xlib/property.c'
  38. X#include "xlib.h"
  39. X
  40. XObject Sym_Now;
  41. X
  42. XGeneric_Predicate (Atom);
  43. X
  44. XGeneric_Simple_Equal (Atom, ATOM, atom);
  45. X
  46. XGeneric_Print (Atom, "#[atom %u]", ATOM(x)->atom);
  47. X
  48. XObject Make_Atom (a) Atom a; {
  49. X    register char *p;
  50. X    Object atom;
  51. X
  52. X    if (a == None)
  53. X    return Sym_None;
  54. X    atom = Find_Object (T_Atom, (GENERIC)0, Match_X_Obj, a);
  55. X    if (Nullp (atom)) {
  56. X    p = Get_Bytes (sizeof (struct S_Atom));
  57. X    SET (atom, T_Atom, (struct S_Atom *)p);
  58. X    ATOM(atom)->tag = Null;
  59. X    ATOM(atom)->atom = a;
  60. X    Register_Object (atom, (GENERIC)0, (PFO)0, 0);
  61. X    }
  62. X    return atom;
  63. X}
  64. X
  65. Xstatic Object P_Make_Atom (n) Object n; {         /* For debugging */
  66. X    return Make_Atom ((Atom)Get_Integer (n));
  67. X}
  68. X
  69. Xstatic Object Internal_Intern_Atom (d, name, flag) Object d, name; {
  70. X    register char *s;
  71. X
  72. X    Check_Type (d, T_Display);
  73. X    Make_C_String (name, s);
  74. X    return Make_Atom (XInternAtom (DISPLAY(d)->dpy, s, flag));
  75. X}
  76. X
  77. Xstatic Object P_Intern_Atom (d, name) Object d, name; {
  78. X    return Internal_Intern_Atom (d, name, 0);
  79. X}
  80. X
  81. Xstatic Object P_Find_Atom (d, name) Object d, name; {
  82. X    return Internal_Intern_Atom (d, name, 1);
  83. X}
  84. X
  85. Xstatic Object P_Atom_Name (d, a) Object d, a; {
  86. X    register char *s;
  87. X
  88. X    Check_Type (d, T_Display);
  89. X    Check_Type (a, T_Atom);
  90. X    Disable_Interrupts;
  91. X    s = XGetAtomName (DISPLAY(d)->dpy, ATOM(a)->atom);
  92. X    Enable_Interrupts;
  93. X    return Make_String (s, strlen (s));
  94. X}
  95. X
  96. Xstatic Object P_List_Properties (w) Object w; {
  97. X    register i;
  98. X    int n;
  99. X    register Atom *ap;
  100. X    Object v;
  101. X    GC_Node;
  102. X
  103. X    Check_Type (w, T_Window);
  104. X    Disable_Interrupts;
  105. X    ap = XListProperties (WINDOW(w)->dpy, WINDOW(w)->win, &n);
  106. X    Enable_Interrupts;
  107. X    v = Make_Vector (n, Null);
  108. X    GC_Link (v);
  109. X    for (i = 0; i < n; i++) {
  110. X    Object x = Make_Atom (ap[i]);
  111. X    VECTOR(v)->data[i] = x;
  112. X    }
  113. X    GC_Unlink;
  114. X    XFree ((char *)ap);
  115. X    return v;
  116. X}
  117. X
  118. Xstatic Object P_Get_Property (w, prop, type, start, len, deletep)
  119. X    Object w, prop, type, start, len, deletep; {
  120. X    Atom req_type = AnyPropertyType, actual_type;
  121. X    int format;
  122. X    unsigned long nitems, bytes_left;
  123. X    unsigned char *data;
  124. X    Object ret, t, x;
  125. X    register i;
  126. X    GC_Node2;
  127. X
  128. X    Check_Type (w, T_Window);
  129. X    Check_Type (prop, T_Atom);
  130. X    if (!EQ(type, False)) {
  131. X    Check_Type (type, T_Atom);
  132. X    req_type = ATOM(type)->atom;
  133. X    }
  134. X    Check_Type (deletep, T_Boolean);
  135. X    Disable_Interrupts;
  136. X    if (XGetWindowProperty (WINDOW(w)->dpy, WINDOW(w)->win, ATOM(prop)->atom,
  137. X        (long)Get_Integer (start), (long)Get_Integer (len),
  138. X        EQ(deletep, True), req_type, &actual_type, &format,
  139. X        &nitems, &bytes_left, &data) != Success)
  140. X    Primitive_Error ("cannot get property");
  141. X    Enable_Interrupts;
  142. X    ret = t = P_Make_List (Make_Fixnum (4), Null);
  143. X    GC_Link2 (ret, t);
  144. X    x = Make_Atom (actual_type);
  145. X    Car (t) = x; t = Cdr (t);
  146. X    x = Make_Integer (format);
  147. X    Car (t) = x; t = Cdr (t);
  148. X    if (nitems) {
  149. X    if (format == 8) {
  150. X        Object s;
  151. X        x = Make_String ((char *)0, (int)nitems);
  152. X        s = Car (t) = x;
  153. X        bcopy (data, STRING(s)->data, (int)nitems);
  154. X    } else {
  155. X        Object v = Make_Vector ((int)nitems, Null);
  156. X        GC_Node;
  157. X        /* Assumes short is 16 bits and int is 32 bits.
  158. X         */
  159. X        GC_Link (v);
  160. X        for (i = 0; i < nitems; i++) {
  161. X        x = Make_Integer (format == 16 ?
  162. X            *((short *)data + i) : *((int *)data + i));
  163. X        VECTOR(v)->data[i] = x;
  164. X        }
  165. X        Car (t) = v;
  166. X        GC_Unlink;
  167. X    }
  168. X    }
  169. X    t = Cdr (t); 
  170. X    x = Make_Unsigned ((unsigned)bytes_left);
  171. X    Car (t) = x;
  172. X    GC_Unlink;
  173. X    return ret;
  174. X}
  175. X
  176. Xstatic Object P_Change_Property (w, prop, type, format, mode, data)
  177. X    Object w, prop, type, format, mode, data; {
  178. X    register i, m, x, nitems, f;
  179. X    char *buf;
  180. X
  181. X    Check_Type (w, T_Window);
  182. X    Check_Type (prop, T_Atom);
  183. X    Check_Type (type, T_Atom);
  184. X    m = Symbols_To_Bits (mode, 0, Propmode_Syms);
  185. X    switch (f = Get_Integer (format)) {
  186. X    case 8:
  187. X    Check_Type (data, T_String);
  188. X    buf = STRING(data)->data;
  189. X    nitems = STRING(data)->size;
  190. X    break;
  191. X    case 16: case 32:
  192. X    Check_Type (data, T_Vector);
  193. X    nitems = VECTOR(data)->size;
  194. X    buf = alloca (nitems * (f / sizeof (char)));
  195. X    for (i = 0; i < nitems; i++) {
  196. X        x = Get_Integer (VECTOR(data)->data[i]);
  197. X        if (f == 16) {
  198. X        if (x > 65535)
  199. X            Primitive_Error ("format mismatch");
  200. X        *((short *)buf + i) = x;     /* Assumes short is 16 bits */
  201. X        } else *((int *)buf + i) = x;    /*   and int is 32 bits. */
  202. X    }
  203. X    break;
  204. X    default:
  205. X    Primitive_Error ("invalid format: ~s", format);
  206. X    }
  207. X    XChangeProperty (WINDOW(w)->dpy, WINDOW(w)->win, ATOM(prop)->atom,
  208. X    ATOM(type)->atom, f, m, buf, nitems);
  209. X    return Void;
  210. X}
  211. X
  212. Xstatic Object P_Delete_Property (w, prop) Object w, prop; {
  213. X    Check_Type (w, T_Window);
  214. X    Check_Type (prop, T_Atom);
  215. X    XDeleteProperty (WINDOW(w)->dpy, WINDOW(w)->win, ATOM(prop)->atom);
  216. X    return Void;
  217. X}
  218. X
  219. Xstatic Object P_Rotate_Properties (w, v, delta) Object w, v, delta; {
  220. X    Atom *p;
  221. X    register i, n;
  222. X
  223. X    Check_Type (w, T_Window);
  224. X    Check_Type (v, T_Vector);
  225. X    n = VECTOR(v)->size;
  226. X    p = (Atom *)alloca (n * sizeof (Atom));
  227. X    for (i = 0; i < n; i++) {
  228. X    Object a = VECTOR(v)->data[i];
  229. X    Check_Type (a, T_Atom);
  230. X    p[i] = ATOM(a)->atom;
  231. X    }
  232. X    XRotateWindowProperties (WINDOW(w)->dpy, WINDOW(w)->win, p, n,
  233. X    Get_Integer (delta));
  234. X    return Void;
  235. X}
  236. X
  237. Xstatic Object P_Set_Selection_Owner (d, s, owner, time) Object d, s, owner,
  238. X    time; {
  239. X    Check_Type (d, T_Display);
  240. X    Check_Type (s, T_Atom);
  241. X    XSetSelectionOwner (DISPLAY(d)->dpy, ATOM(s)->atom, Get_Window (owner),
  242. X    Get_Time (time));
  243. X    return Void;
  244. X}
  245. X
  246. Xstatic Object P_Selection_Owner (d, s) Object d, s; {
  247. X    Check_Type (d, T_Display);
  248. X    Check_Type (s, T_Atom);
  249. X    return Make_Window (0, DISPLAY(d)->dpy,
  250. X    XGetSelectionOwner (DISPLAY(d)->dpy, ATOM(s)->atom));
  251. X}
  252. X
  253. Xstatic Object P_Convert_Selection (s, target, prop, w, time)
  254. X    Object s, target, prop, w, time; {
  255. X    Atom p = None;
  256. X
  257. X    Check_Type (s, T_Atom);
  258. X    Check_Type (target, T_Atom);
  259. X    if (!EQ(prop, Sym_None)) {
  260. X    Check_Type (prop, T_Atom);
  261. X    p = ATOM(prop)->atom;
  262. X    }
  263. X    Check_Type (w, T_Window);
  264. X    XConvertSelection (WINDOW(w)->dpy, ATOM(s)->atom, ATOM(target)->atom,
  265. X    p, WINDOW(w)->win, Get_Time (time));
  266. X    return Void;
  267. X}
  268. X
  269. Xinit_xlib_property () {
  270. X    Define_Symbol (&Sym_Now, "now");
  271. X    Generic_Define (Atom, "atom", "atom?");
  272. X    Define_Primitive (P_Make_Atom,         "make-atom",          1, 1, EVAL);
  273. X    Define_Primitive (P_Intern_Atom,       "intern-atom",        2, 2, EVAL);
  274. X    Define_Primitive (P_Find_Atom,         "find-atom",          2, 2, EVAL);
  275. X    Define_Primitive (P_Atom_Name,         "atom-name",          2, 2, EVAL);
  276. X    Define_Primitive (P_List_Properties,   "list-properties",    1, 1, EVAL);
  277. X    Define_Primitive (P_Get_Property,      "get-property",       6, 6, EVAL);
  278. X    Define_Primitive (P_Change_Property,   "change-property",    6, 6, EVAL);
  279. X    Define_Primitive (P_Delete_Property,   "delete-property",    2, 2, EVAL);
  280. X    Define_Primitive (P_Rotate_Properties, "rotate-properties",  3, 3, EVAL);
  281. X    Define_Primitive (P_Set_Selection_Owner, "set-selection-owner!",
  282. X                                 4, 4, EVAL);
  283. X    Define_Primitive (P_Selection_Owner,   "selection-owner",    2, 2, EVAL);
  284. X    Define_Primitive (P_Convert_Selection, "convert-selection",  5, 5, EVAL);
  285. X}
  286. END_OF_lib/xlib/property.c
  287. if test 7184 -ne `wc -c <lib/xlib/property.c`; then
  288.     echo shar: \"lib/xlib/property.c\" unpacked with wrong size!
  289. fi
  290. # end of overwriting check
  291. fi
  292. if test -f lib/xlib/pointer.c -a "${1}" != "-c" ; then 
  293.   echo shar: Will not over-write existing file \"lib/xlib/pointer.c\"
  294. else
  295. echo shar: Extracting \"lib/xlib/pointer.c\" \(6645 characters\)
  296. sed "s/^X//" >lib/xlib/pointer.c <<'END_OF_lib/xlib/pointer.c'
  297. X#include "xlib.h"
  298. X
  299. Xstatic Object Sym_Any;
  300. X
  301. XTime Get_Time (time) Object time; {
  302. X    if (EQ(time, Sym_Now))
  303. X    return CurrentTime;
  304. X    return (Time)Get_Integer (time);
  305. X}
  306. X
  307. Xstatic Get_Mode (m) Object m; {
  308. X    Check_Type (m, T_Boolean);
  309. X    return EQ(m, True) ? GrabModeSync : GrabModeAsync;
  310. X}
  311. X
  312. Xstatic Object P_Grab_Pointer (win, ownerp, events, psyncp, ksyncp, confine_to,
  313. X    cursor, time) Object win, ownerp, events, psyncp, ksyncp, confine_to,
  314. X    cursor, time; {
  315. X    Check_Type (win, T_Window);
  316. X    Check_Type (ownerp, T_Boolean);
  317. X    return Bits_To_Symbols ((unsigned long)XGrabPointer (WINDOW(win)->dpy,
  318. X        WINDOW(win)->win,
  319. X        EQ(ownerp, True), Symbols_To_Bits (events, 1, Event_Syms),
  320. X        Get_Mode (psyncp), Get_Mode (ksyncp),
  321. X        Get_Window (confine_to), Get_Cursor (cursor), Get_Time (time)),
  322. X    0, Grabstatus_Syms);
  323. X}
  324. X
  325. Xstatic Object P_Ungrab_Pointer (d, time) Object d, time; {
  326. X    Check_Type (d, T_Display);
  327. X    XUngrabPointer (DISPLAY(d)->dpy, Get_Time (time));
  328. X    return Void;
  329. X}
  330. X
  331. Xstatic Object P_Grab_Button (win, button, mods, ownerp, events, psyncp, ksyncp,
  332. X    confine_to, cursor) Object win, button, mods, ownerp, events,
  333. X    psyncp, ksyncp, confine_to, cursor; {
  334. X    Check_Type (win, T_Window);
  335. X    Check_Type (ownerp, T_Boolean);
  336. X    XGrabButton (WINDOW(win)->dpy, Symbols_To_Bits (button, 0, Button_Syms),
  337. X    Symbols_To_Bits (mods, 1, State_Syms), WINDOW(win)->win,
  338. X    EQ(ownerp, True), Symbols_To_Bits (events, 1, Event_Syms),
  339. X    Get_Mode (psyncp), Get_Mode (ksyncp),
  340. X    Get_Window (confine_to), Get_Cursor (cursor));
  341. X    return Void;
  342. X}
  343. X
  344. Xstatic Object P_Ungrab_Button (win, button, mods) {
  345. X    Check_Type (win, T_Window);
  346. X    XUngrabButton (WINDOW(win)->dpy, Symbols_To_Bits (button, 0, Button_Syms),
  347. X    Symbols_To_Bits (mods, 1, State_Syms), WINDOW(win)->win);
  348. X    return Void;
  349. X}
  350. X
  351. Xstatic Object P_Change_Active_Pointer_Grab (d, events, cursor, time)
  352. X    Object d, events, cursor, time; {
  353. X    Check_Type (d, T_Display);
  354. X    XChangeActivePointerGrab (DISPLAY(d)->dpy, Symbols_To_Bits (events, 1,
  355. X    Event_Syms), Get_Cursor (cursor), Get_Time (time));
  356. X    return Void;
  357. X}
  358. X
  359. Xstatic Object P_Grab_Keyboard (win, ownerp, psyncp, ksyncp, time) Object win,
  360. X    ownerp, psyncp, ksyncp, time; {
  361. X    Check_Type (win, T_Window);
  362. X    Check_Type (ownerp, T_Boolean);
  363. X    return Bits_To_Symbols ((unsigned long)XGrabKeyboard (WINDOW(win)->dpy,
  364. X        WINDOW(win)->win, EQ(ownerp, True), Get_Mode (psyncp),
  365. X        Get_Mode (ksyncp), Get_Time (time)),
  366. X    0, Grabstatus_Syms);
  367. X}
  368. X
  369. Xstatic Object P_Ungrab_Keyboard (d, time) Object d, time; {
  370. X    Check_Type (d, T_Display);
  371. X    XUngrabKeyboard (DISPLAY(d)->dpy, Get_Time (time));
  372. X    return Void;
  373. X}
  374. X
  375. Xstatic Object P_Grab_Key (win, key, mods, ownerp, psyncp, ksyncp) Object win,
  376. X    key, mods, ownerp, psyncp, ksyncp; {
  377. X    int keycode = AnyKey;
  378. X
  379. X    Check_Type (win, T_Window);
  380. X    if (!EQ(key, Sym_Any))
  381. X    keycode = Get_Integer (key);
  382. X    Check_Type (ownerp, T_Boolean);
  383. X    XGrabKey (WINDOW(win)->dpy, keycode, Symbols_To_Bits (mods, 1, State_Syms),
  384. X    WINDOW(win)->win, EQ(ownerp, True), Get_Mode (psyncp),
  385. X    Get_Mode (ksyncp));
  386. X    return Void;
  387. X}
  388. X
  389. Xstatic Object P_Ungrab_Key (win, key, mods) Object win, key, mods; {
  390. X    int keycode = AnyKey;
  391. X
  392. X    Check_Type (win, T_Window);
  393. X    if (!EQ(key, Sym_Any))
  394. X    keycode = Get_Integer (key);
  395. X    XUngrabKey (WINDOW(win)->dpy, keycode,
  396. X    Symbols_To_Bits (mods, 1, State_Syms), WINDOW(win)->win);
  397. X    return Void;
  398. X}
  399. X
  400. Xstatic Object P_Allow_Events (d, mode, time) Object d, mode, time; {
  401. X    Check_Type (d, T_Display);
  402. X    XAllowEvents (DISPLAY(d)->dpy, Symbols_To_Bits (mode, 0, 
  403. X    Allow_Events_Syms), Get_Time (time));
  404. X    return Void;
  405. X}
  406. X
  407. Xstatic Object P_Grab_Server (d) Object d; {
  408. X    Check_Type (d, T_Display);
  409. X    XGrabServer (DISPLAY(d)->dpy);
  410. X    return Void;
  411. X}
  412. X
  413. Xstatic Object P_Ungrab_Server (d) Object d; {
  414. X    Check_Type (d, T_Display);
  415. X    XUngrabServer (DISPLAY(d)->dpy);
  416. X    return Void;
  417. X}
  418. X
  419. Xstatic Object P_Query_Pointer (win) Object win; {
  420. X    Object l, t, z;
  421. X    Bool ret;
  422. X    Window root, child;
  423. X    int r_x, r_y, x, y;
  424. X    unsigned int mask;
  425. X    GC_Node3;
  426. X
  427. X    Check_Type (win, T_Window);
  428. X    ret = XQueryPointer (WINDOW(win)->dpy, WINDOW(win)->win, &root, &child,
  429. X    &r_x, &r_y, &x, &y, &mask);
  430. X    t = l = P_Make_List (Make_Fixnum (8), Null);
  431. X    GC_Link3 (l, t, win);
  432. X    Car (t) = Make_Fixnum (x); t = Cdr (t);
  433. X    Car (t) = Make_Fixnum (y); t = Cdr (t);
  434. X    Car (t) = ret ? True : False; t = Cdr (t);
  435. X    z = Make_Window (0, WINDOW(win)->dpy, root);
  436. X    Car (t) = z; t = Cdr (t);
  437. X    Car (t) = Make_Fixnum (r_x); t = Cdr (t);
  438. X    Car (t) = Make_Fixnum (r_y); t = Cdr (t);
  439. X    z = Make_Window (0, WINDOW(win)->dpy, child);
  440. X    Car (t) = z; t = Cdr (t);
  441. X    z = Bits_To_Symbols ((unsigned long)mask, 1, State_Syms);
  442. X    Car (t) = z;
  443. X    GC_Unlink;
  444. X    return l;
  445. X}
  446. X
  447. Xstatic Object P_General_Warp_Pointer (dpy, dst, dstx, dsty, src, srcx, srcy,
  448. X    srcw, srch) Object dpy, dst, dstx, dsty, src, srcx, srcy, srcw, srch; {
  449. X    Check_Type (dpy, T_Display);
  450. X    XWarpPointer (DISPLAY(dpy)->dpy, Get_Window (src), Get_Window (dst),
  451. X    Get_Integer (srcx), Get_Integer (srcy), Get_Integer (srcw),
  452. X    Get_Integer (srch), Get_Integer (dstx), Get_Integer (dsty));
  453. X    return Void;
  454. X}
  455. X
  456. Xstatic Object P_Bell (argc, argv) Object *argv; {
  457. X    register percent = 0;
  458. X
  459. X    Check_Type (argv[0], T_Display);
  460. X    if (argc == 2) {
  461. X    percent = Get_Integer (argv[1]);
  462. X    if (percent < -100 || percent > 100)
  463. X        Range_Error (argv[1]);
  464. X    }
  465. X    XBell (DISPLAY(argv[0])->dpy, percent);
  466. X    return Void;
  467. X}
  468. X
  469. Xinit_xlib_pointer () {
  470. X    Define_Symbol (&Sym_Any, "any");
  471. X    Define_Primitive (P_Grab_Pointer,    "grab-pointer",    8, 8, EVAL);
  472. X    Define_Primitive (P_Ungrab_Pointer,  "ungrab-pointer",  2, 2, EVAL);
  473. X    Define_Primitive (P_Grab_Button,     "grab-button",     9, 9, EVAL);
  474. X    Define_Primitive (P_Ungrab_Button,   "ungrab-button",   3, 3, EVAL);
  475. X    Define_Primitive (P_Change_Active_Pointer_Grab,
  476. X                 "change-active-pointer-grab",  4, 4, EVAL);
  477. X    Define_Primitive (P_Grab_Keyboard,   "grab-keyboard",   5, 5, EVAL);
  478. X    Define_Primitive (P_Ungrab_Keyboard, "ungrab-keyboard", 2, 2, EVAL);
  479. X    Define_Primitive (P_Grab_Key,        "grab-key",        6, 6, EVAL);
  480. X    Define_Primitive (P_Ungrab_Key,      "ungrab-key",      3, 3, EVAL);
  481. X    Define_Primitive (P_Allow_Events,    "allow-events",    3, 3, EVAL);
  482. X    Define_Primitive (P_Grab_Server,     "grab-server",     1, 1, EVAL);
  483. X    Define_Primitive (P_Ungrab_Server,   "ungrab-server",   1, 1, EVAL);
  484. X    Define_Primitive (P_Query_Pointer,   "query-pointer",   1, 1, EVAL);
  485. X    Define_Primitive (P_General_Warp_Pointer, "general-warp-pointer",
  486. X                                9, 9, EVAL);
  487. X    Define_Primitive (P_Bell,            "bell",            1, 2, VARARGS);
  488. X}
  489. END_OF_lib/xlib/pointer.c
  490. if test 6645 -ne `wc -c <lib/xlib/pointer.c`; then
  491.     echo shar: \"lib/xlib/pointer.c\" unpacked with wrong size!
  492. fi
  493. # end of overwriting check
  494. fi
  495. if test -f lib/xlib/wm.c -a "${1}" != "-c" ; then 
  496.   echo shar: Will not over-write existing file \"lib/xlib/wm.c\"
  497. else
  498. echo shar: Extracting \"lib/xlib/wm.c\" \(7029 characters\)
  499. sed "s/^X//" >lib/xlib/wm.c <<'END_OF_lib/xlib/wm.c'
  500. X#include "xlib.h"
  501. X
  502. Xextern XFetchName(), XStoreName(), XGetIconName(), XSetIconName();
  503. X
  504. Xstatic Object Sym_Wm_Hints, Sym_Size_Hints, Sym_Icon_Size;
  505. X
  506. Xstatic Object Get_Name (w, f) Object w; int (*f)(); {
  507. X    char *ret;
  508. X    Object s;
  509. X
  510. X    Check_Type (w, T_Window);
  511. X    Disable_Interrupts;
  512. X    if (!(*f) (WINDOW(w)->dpy, WINDOW(w)->win, &ret) || ret == 0) {
  513. X    Enable_Interrupts;
  514. X    return False;
  515. X    }
  516. X    Enable_Interrupts;
  517. X    s = Make_String (ret, strlen (ret));
  518. X    XFree (ret);
  519. X    return s;
  520. X}
  521. X
  522. Xstatic Object P_Wm_Name (w) Object w; {
  523. X    return Get_Name (w, XFetchName);
  524. X}
  525. X
  526. Xstatic Object P_Wm_Icon_Name (w) Object w; {
  527. X    return Get_Name (w, XGetIconName);
  528. X}
  529. X
  530. Xstatic Object Set_Name (w, name, f) Object w, name; int (*f)(); {
  531. X    register char *s;
  532. X
  533. X    Check_Type (w, T_Window);
  534. X    Make_C_String (name, s);
  535. X    (*f) (WINDOW(w)->dpy, WINDOW(w)->win, s);
  536. X    return Void;
  537. X}
  538. X
  539. Xstatic Object P_Set_Wm_Name (w, name) Object w, name; {
  540. X    return Set_Name (w, name, XStoreName);
  541. X}
  542. X
  543. Xstatic Object P_Set_Wm_Icon_Name (w, name) Object w, name; {
  544. X    return Set_Name (w, name, XSetIconName);
  545. X}
  546. X
  547. Xstatic Object P_Wm_Class (w) Object w; {
  548. X    Object ret, x;
  549. X    XClassHint c;
  550. X    GC_Node;
  551. X
  552. X    Check_Type (w, T_Window);
  553. X    /*
  554. X     * In X11.2 XGetClassHint() returns either 0 or Success, which happens
  555. X     * to be defined as 0.  So until this bug is fixed, we must
  556. X     * explicitly check whether the XClassHint structure has been filled.
  557. X     */
  558. X     c.res_name = c.res_class = 0;
  559. X    Disable_Interrupts;
  560. X    (void)XGetClassHint (WINDOW(w)->dpy, WINDOW(w)->win, &c);
  561. X    Enable_Interrupts;
  562. X    ret = Cons (False, False);
  563. X    GC_Link (ret);
  564. X    if (c.res_name) {
  565. X    x = Make_String (c.res_name, strlen (c.res_name));
  566. X    Car (ret) = x;
  567. X    }
  568. X    if (c.res_class) {
  569. X    x = Make_String (c.res_class, strlen (c.res_class));
  570. X    Cdr (ret) = x;
  571. X    }
  572. X    GC_Unlink;
  573. X    return ret;
  574. X}
  575. X
  576. Xstatic Object P_Set_Wm_Class (w, name, class) Object w, name, class; {
  577. X    XClassHint c;
  578. X
  579. X    Check_Type (w, T_Window);
  580. X    Make_C_String (name, c.res_name);
  581. X    Make_C_String (class, c.res_class);
  582. X    XSetClassHint (WINDOW(w)->dpy, WINDOW(w)->win, &c);
  583. X    return Void;
  584. X}
  585. X
  586. Xstatic Object P_Set_Wm_Command (w, cmd) Object w, cmd; {
  587. X    register i, n;
  588. X    register char **argv;
  589. X    Object c;
  590. X
  591. X    Check_Type (w, T_Window);
  592. X    Check_List (cmd);
  593. X    n = Internal_Length (cmd);
  594. X    argv = (char **)alloca (n * sizeof (char *));
  595. X    for (i = 0; i < n; i++, cmd = Cdr (cmd)) {
  596. X    c = Car (cmd);
  597. X    Make_C_String (c, argv[i]);
  598. X    }
  599. X    XSetCommand (WINDOW(w)->dpy, WINDOW(w)->win, argv, n);
  600. X    return Void;
  601. X}
  602. X
  603. Xstatic Object P_Wm_Hints (w) Object w; {
  604. X    XWMHints *p;
  605. X
  606. X    Check_Type (w, T_Window);
  607. X    Disable_Interrupts;
  608. X    p = XGetWMHints (WINDOW(w)->dpy, WINDOW(w)->win);
  609. X    Enable_Interrupts;
  610. X    if (p)
  611. X    WMH = *p;
  612. X    else
  613. X    WMH.flags = 0;
  614. X    return Record_To_Vector (Wm_Hints_Rec, Wm_Hints_Size, Sym_Wm_Hints,
  615. X    WINDOW(w)->dpy, (unsigned long)WMH.flags);
  616. X}
  617. X
  618. Xstatic Object P_Set_Wm_Hints (w, h) Object w, h; {
  619. X    register unsigned long mask;
  620. X
  621. X    Check_Type (w, T_Window);
  622. X    mask = Vector_To_Record (h, Wm_Hints_Size, Sym_Wm_Hints, Wm_Hints_Rec);
  623. X    WMH.flags = mask;
  624. X    XSetWMHints (WINDOW(w)->dpy, WINDOW(w)->win, &WMH);
  625. X    return Void;
  626. X}
  627. X
  628. Xstatic Object P_Size_Hints (w, a) Object w, a; {
  629. X    Check_Type (w, T_Window);
  630. X    Check_Type (a, T_Atom);
  631. X    Disable_Interrupts;
  632. X    if (!XGetSizeHints (WINDOW(w)->dpy, WINDOW(w)->win, &SZH, ATOM(a)->atom))
  633. X    SZH.flags = 0;
  634. X    Enable_Interrupts;
  635. X    if ((SZH.flags & (PPosition|USPosition)) == (PPosition|USPosition))
  636. X    SZH.flags &= ~PPosition;
  637. X    if ((SZH.flags & (PSize|USSize)) == (PSize|USSize))
  638. X    SZH.flags &= ~PSize;
  639. X    return Record_To_Vector (Size_Hints_Rec, Size_Hints_Size, Sym_Size_Hints,
  640. X    WINDOW(w)->dpy, (unsigned long)SZH.flags);
  641. X}
  642. X
  643. Xstatic Object P_Set_Size_Hints (w, a, h) Object w, a, h; {
  644. X    register unsigned long mask;
  645. X
  646. X    Check_Type (w, T_Window);
  647. X    Check_Type (a, T_Atom);
  648. X    bzero ((char *)&SZH, sizeof (SZH));        /* Not portable? */
  649. X    mask = Vector_To_Record (h, Size_Hints_Size, Sym_Size_Hints,
  650. X    Size_Hints_Rec);
  651. X    if ((mask & (PPosition|USPosition)) == (PPosition|USPosition))
  652. X    mask &= ~PPosition;
  653. X    if ((mask & (PSize|USSize)) == (PSize|USSize))
  654. X    mask &= ~PSize;
  655. X    SZH.flags = mask;
  656. X    XSetSizeHints (WINDOW(w)->dpy, WINDOW(w)->win, &SZH, ATOM(a)->atom);
  657. X    return Void;
  658. X}
  659. X
  660. Xstatic Object P_Icon_Sizes (w) Object w; {
  661. X    XIconSize *p;
  662. X    int i, n;
  663. X    Object v, x;
  664. X    GC_Node2;
  665. X    
  666. X    Check_Type (w, T_Window);
  667. X    Disable_Interrupts;
  668. X    if (!XGetIconSizes (WINDOW(w)->dpy, WINDOW(w)->win, &p, &n))
  669. X    n = 0;
  670. X    Enable_Interrupts;
  671. X    v = Make_Vector (n, Null);
  672. X    GC_Link2 (v, w);
  673. X    for (i = 0; i < n; i++) {
  674. X    ISZ = p[i];
  675. X    x = Record_To_Vector (Icon_Size_Rec, Icon_Size_Size, Sym_Icon_Size,
  676. X        WINDOW(w)->dpy, ~0L);
  677. X    VECTOR(v)->data[i] = x;
  678. X    }
  679. X    GC_Unlink;
  680. X    return v;
  681. X}
  682. X
  683. Xstatic Object P_Set_Icon_Sizes (w, v) Object w, v; {
  684. X    register i, n;
  685. X    XIconSize *p;
  686. X
  687. X    Check_Type (w, T_Window);
  688. X    Check_Type (v, T_Vector);
  689. X    n = VECTOR(v)->size;
  690. X    p = (XIconSize *)alloca (n * sizeof (XIconSize));
  691. X    for (i = 0; i < n; i++) {
  692. X    (void)Vector_To_Record (VECTOR(v)->data[i], Icon_Size_Size,
  693. X        Sym_Icon_Size, Icon_Size_Rec);
  694. X    p[i] = ISZ;
  695. X    }
  696. X    XSetIconSizes (WINDOW(w)->dpy, WINDOW(w)->win, p, n);
  697. X    return Void;
  698. X}
  699. X
  700. Xstatic Object P_Transient_For (w) Object w; {
  701. X    Window win;
  702. X
  703. X    Disable_Interrupts;
  704. X    if (!XGetTransientForHint (WINDOW(w)->dpy, WINDOW(w)->win, &win))
  705. X    win = None;
  706. X    Enable_Interrupts;
  707. X    return Make_Window (0, WINDOW(w)->dpy, win);
  708. X}
  709. X
  710. Xstatic Object P_Set_Transient_For (w, pw) Object w, pw; {
  711. X    Check_Type (w, T_Window);
  712. X    XSetTransientForHint (WINDOW(w)->dpy, WINDOW(w)->win, Get_Window (pw));
  713. X    return Void;
  714. X}
  715. X
  716. Xinit_xlib_wm () {
  717. X    Define_Symbol (&Sym_Wm_Hints, "wm-hints");
  718. X    Define_Symbol (&Sym_Size_Hints, "size-hints");
  719. X    Define_Symbol (&Sym_Icon_Size, "icon-size");
  720. X    Define_Primitive (P_Wm_Name,          "wm-name",           1, 1, EVAL);
  721. X    Define_Primitive (P_Wm_Icon_Name,     "wm-icon-name",      1, 1, EVAL);
  722. X    Define_Primitive (P_Set_Wm_Name,      "set-wm-name!",      2, 2, EVAL);
  723. X    Define_Primitive (P_Set_Wm_Icon_Name, "set-wm-icon-name!", 2, 2, EVAL);
  724. X    Define_Primitive (P_Wm_Class,         "wm-class",          1, 1, EVAL);
  725. X    Define_Primitive (P_Set_Wm_Class,     "set-wm-class!",     3, 3, EVAL);
  726. X    Define_Primitive (P_Set_Wm_Command,   "set-wm-command!",   2, 2, EVAL);
  727. X    Define_Primitive (P_Wm_Hints,         "wm-hints",          1, 1, EVAL);
  728. X    Define_Primitive (P_Set_Wm_Hints,     "set-wm-hints!",     2, 2, EVAL);
  729. X    Define_Primitive (P_Size_Hints,       "size-hints",        2, 2, EVAL);
  730. X    Define_Primitive (P_Set_Size_Hints,   "set-size-hints!",   3, 3, EVAL);
  731. X    Define_Primitive (P_Icon_Sizes,       "icon-sizes",        1, 1, EVAL);
  732. X    Define_Primitive (P_Set_Icon_Sizes,   "set-icon-sizes!",   2, 2, EVAL);
  733. X    Define_Primitive (P_Transient_For,    "transient-for",     1, 1, EVAL);
  734. X    Define_Primitive (P_Set_Transient_For,"set-transient-for!",2, 2, EVAL);
  735. X}
  736. END_OF_lib/xlib/wm.c
  737. if test 7029 -ne `wc -c <lib/xlib/wm.c`; then
  738.     echo shar: \"lib/xlib/wm.c\" unpacked with wrong size!
  739. fi
  740. # end of overwriting check
  741. fi
  742. if test -f lib/xaw/Makefile -a "${1}" != "-c" ; then 
  743.   echo shar: Will not over-write existing file \"lib/xaw/Makefile\"
  744. else
  745. echo shar: Extracting \"lib/xaw/Makefile\" \(445 characters\)
  746. sed "s/^X//" >lib/xaw/Makefile <<'END_OF_lib/xaw/Makefile'
  747. XWIDGET_SET= xaw
  748. X
  749. XO= ascii.o\
  750. X   box.o\
  751. X   clock.o\
  752. X   command.o\
  753. X   dialog.o\
  754. X   form.o\
  755. X   grip.o\
  756. X   label.o\
  757. X   list.o\
  758. X   scroll.o\
  759. X   shell.o\
  760. X   viewport.o\
  761. X   vpaned.o
  762. X
  763. X.SUFFIXES: .d .c .o
  764. X
  765. X.d.c:
  766. X    ../../src/scheme -l ../xt/make-widget $< $@ $(WIDGET_SET)
  767. X
  768. X.d.o:
  769. X    ../../src/scheme -l ../xt/make-widget $< $*.c $(WIDGET_SET)
  770. X    $(CC) $(CFLAGS) -c $*.c
  771. X
  772. Xall: $(O)
  773. X
  774. Xlint:
  775. X    lint $(LINTFLAGS) -abxh *.c | egrep -v '\?\?\?'
  776. X
  777. Xclean:
  778. X    rm -f *.o *.c
  779. END_OF_lib/xaw/Makefile
  780. if test 445 -ne `wc -c <lib/xaw/Makefile`; then
  781.     echo shar: \"lib/xaw/Makefile\" unpacked with wrong size!
  782. fi
  783. # end of overwriting check
  784. fi
  785. if test -f lib/xaw/grip.d -a "${1}" != "-c" ; then 
  786.   echo shar: Will not over-write existing file \"lib/xaw/grip.d\"
  787. else
  788. echo shar: Extracting \"lib/xaw/grip.d\" \(642 characters\)
  789. sed "s/^X//" >lib/xaw/grip.d <<'END_OF_lib/xaw/grip.d'
  790. X;;; -*-Scheme-*-
  791. X
  792. X(define-widget-type 'grip "Grip.h")
  793. X
  794. X(define-widget-class 'grip 'gripWidgetClass)
  795. X
  796. X(define-callback 'grip 'callback #t)
  797. X
  798. X(c->scheme 'grip-callback
  799. X"   Object args, ret, t = Null;
  800. X    register i;
  801. X    GripCallData p = (GripCallData)x;
  802. X    GC_Node2;
  803. X
  804. X    args = Get_Event_Args (p->event);
  805. X    ret = Cons (Copy_List (args), Null);
  806. X    Destroy_Event_Args (args);
  807. X    GC_Link2 (ret, t);
  808. X    t = P_Make_List (Make_Fixnum (p->num_params), Null);
  809. X    for (i = 0, Cdr (ret) = t; i < p->num_params; i++, t = Cdr (t)) {
  810. X    Object s = Make_String (p->params[i], strlen (p->params[i]));
  811. X    Car (t) = s;
  812. X    }
  813. X    GC_Unlink;
  814. X    return ret;")
  815. END_OF_lib/xaw/grip.d
  816. if test 642 -ne `wc -c <lib/xaw/grip.d`; then
  817.     echo shar: \"lib/xaw/grip.d\" unpacked with wrong size!
  818. fi
  819. # end of overwriting check
  820. fi
  821. if test -f lib/xaw/list.d -a "${1}" != "-c" ; then 
  822.   echo shar: Will not over-write existing file \"lib/xaw/list.d\"
  823. else
  824. echo shar: Extracting \"lib/xaw/list.d\" \(1526 characters\)
  825. sed "s/^X//" >lib/xaw/list.d <<'END_OF_lib/xaw/list.d'
  826. X;;; -*-Scheme-*-
  827. X
  828. X(define-widget-type 'list "List.h"
  829. X
  830. X"static char **Get_List (x) Object x; {
  831. X    register i, n;
  832. X    register char *s, **l;
  833. X
  834. X    Check_List (x);
  835. X    n = Internal_Length (x);
  836. X    l = (char **)XtMalloc ((n+1) * sizeof (char *));
  837. X    for (i = 0; i < n; i++, x = Cdr (x)) {
  838. X    Make_C_String (Car (x), s);
  839. X    l[i] = XtNewString (s);
  840. X    }
  841. X    l[i] = 0;
  842. X    return l;
  843. X}")
  844. X
  845. X(define-widget-class 'list 'listWidgetClass)
  846. X
  847. X(define-callback 'list 'callback #t)
  848. X
  849. X(c->scheme 'list-callback
  850. X"   XtListReturnStruct *p = (XtListReturnStruct *)x;
  851. X    return Cons (Make_String (p->string, strlen (p->string)),
  852. X    Make_Fixnum (p->index));")
  853. X
  854. X(scheme->c 'list-list
  855. X"   return (XtArgVal)Get_List (x);")
  856. X
  857. X(define-primitive 'list-change! '(w x resize)
  858. X"   Check_Widget_Class (w, listWidgetClass);
  859. X    Check_Type (resize, T_Boolean);
  860. X    XtListChange (WIDGET(w)->widget, Get_List (x), 0, 0, EQ (resize, True));
  861. X    return Void;")
  862. X
  863. X(define-primitive 'list-highlight '(w i)
  864. X"   Check_Widget_Class (w, listWidgetClass);
  865. X    XtListHighlight (WIDGET(w)->widget, Get_Integer (i));
  866. X    return Void;")
  867. X
  868. X(define-primitive 'list-unhighlight '(w)
  869. X"   Check_Widget_Class (w, listWidgetClass);
  870. X    XtListUnhighlight (WIDGET(w)->widget);
  871. X    return Void;")
  872. X
  873. X(define-primitive 'list-current '(w)
  874. X"   XtListReturnStruct *p;
  875. X
  876. X    Check_Widget_Class (w, listWidgetClass);
  877. X    p = XtListShowCurrent (WIDGET(w)->widget);
  878. X    if (p->index == XT_LIST_NONE)
  879. X    return False;
  880. X    return Cons (Make_String (p->string, strlen (p->string)),
  881. X    Make_Fixnum (p->index));")
  882. END_OF_lib/xaw/list.d
  883. if test 1526 -ne `wc -c <lib/xaw/list.d`; then
  884.     echo shar: \"lib/xaw/list.d\" unpacked with wrong size!
  885. fi
  886. # end of overwriting check
  887. fi
  888. if test -f lib/xaw/scroll.d -a "${1}" != "-c" ; then 
  889.   echo shar: Will not over-write existing file \"lib/xaw/scroll.d\"
  890. else
  891. echo shar: Extracting \"lib/xaw/scroll.d\" \(560 characters\)
  892. sed "s/^X//" >lib/xaw/scroll.d <<'END_OF_lib/xaw/scroll.d'
  893. X;;; -*-Scheme-*-
  894. X
  895. X(define-widget-type 'scrollbar "Scroll.h")
  896. X
  897. X(define-widget-class 'scrollbar 'scrollbarWidgetClass)
  898. X
  899. X(define-callback 'scrollbar 'scrollProc #t)
  900. X(define-callback 'scrollbar 'jumpProc #t)
  901. X
  902. X(c->scheme 'scrollbar-scrollProc
  903. X"    return Make_Integer ((int)x);")
  904. X
  905. X(c->scheme 'scrollbar-jumpProc
  906. X"    return Make_Reduced_Flonum ((double)*(float *)x);")
  907. X
  908. X(define-primitive 'scrollbar-set-thumb! '(w t s)
  909. X"   Check_Widget_Class (w, scrollbarWidgetClass);
  910. X    XtScrollBarSetThumb (WIDGET(w)->widget, Get_Double (t), Get_Double (s));
  911. X    return Void;")
  912. END_OF_lib/xaw/scroll.d
  913. if test 560 -ne `wc -c <lib/xaw/scroll.d`; then
  914.     echo shar: \"lib/xaw/scroll.d\" unpacked with wrong size!
  915. fi
  916. # end of overwriting check
  917. fi
  918. if test -f lib/xaw/box.d -a "${1}" != "-c" ; then 
  919.   echo shar: Will not over-write existing file \"lib/xaw/box.d\"
  920. else
  921. echo shar: Extracting \"lib/xaw/box.d\" \(96 characters\)
  922. sed "s/^X//" >lib/xaw/box.d <<'END_OF_lib/xaw/box.d'
  923. X;;; -*-Scheme-*-
  924. X
  925. X(define-widget-type 'box "Box.h")
  926. X
  927. X(define-widget-class 'box 'boxWidgetClass)
  928. END_OF_lib/xaw/box.d
  929. if test 96 -ne `wc -c <lib/xaw/box.d`; then
  930.     echo shar: \"lib/xaw/box.d\" unpacked with wrong size!
  931. fi
  932. # end of overwriting check
  933. fi
  934. if test -f lib/xaw/shell.d -a "${1}" != "-c" ; then 
  935.   echo shar: Will not over-write existing file \"lib/xaw/shell.d\"
  936. else
  937. echo shar: Extracting \"lib/xaw/shell.d\" \(420 characters\)
  938. sed "s/^X//" >lib/xaw/shell.d <<'END_OF_lib/xaw/shell.d'
  939. X;;; -*-Scheme-*-
  940. X
  941. X(define-widget-type 'shell "Shell.h")
  942. X
  943. X(define-widget-class 'shell 'shellWidgetClass)
  944. X(define-widget-class 'override-shell 'overrideShellWidgetClass)
  945. X(define-widget-class 'wm-shell 'wmShellWidgetClass)
  946. X(define-widget-class 'transient-shell 'transientShellWidgetClass)
  947. X(define-widget-class 'toplevel-shell 'topLevelShellWidgetClass)
  948. X(define-widget-class 'application-shell 'applicationShellWidgetClass)
  949. END_OF_lib/xaw/shell.d
  950. if test 420 -ne `wc -c <lib/xaw/shell.d`; then
  951.     echo shar: \"lib/xaw/shell.d\" unpacked with wrong size!
  952. fi
  953. # end of overwriting check
  954. fi
  955. if test -f lib/xaw/clock.d -a "${1}" != "-c" ; then 
  956.   echo shar: Will not over-write existing file \"lib/xaw/clock.d\"
  957. else
  958. echo shar: Extracting \"lib/xaw/clock.d\" \(104 characters\)
  959. sed "s/^X//" >lib/xaw/clock.d <<'END_OF_lib/xaw/clock.d'
  960. X;;; -*-Scheme-*-
  961. X
  962. X(define-widget-type 'clock "Clock.h")
  963. X
  964. X(define-widget-class 'clock 'clockWidgetClass)
  965. END_OF_lib/xaw/clock.d
  966. if test 104 -ne `wc -c <lib/xaw/clock.d`; then
  967.     echo shar: \"lib/xaw/clock.d\" unpacked with wrong size!
  968. fi
  969. # end of overwriting check
  970. fi
  971. if test -f lib/xaw/dialog.d -a "${1}" != "-c" ; then 
  972.   echo shar: Will not over-write existing file \"lib/xaw/dialog.d\"
  973. else
  974. echo shar: Extracting \"lib/xaw/dialog.d\" \(108 characters\)
  975. sed "s/^X//" >lib/xaw/dialog.d <<'END_OF_lib/xaw/dialog.d'
  976. X;;; -*-Scheme-*-
  977. X
  978. X(define-widget-type 'dialog "Dialog.h")
  979. X
  980. X(define-widget-class 'dialog 'dialogWidgetClass)
  981. END_OF_lib/xaw/dialog.d
  982. if test 108 -ne `wc -c <lib/xaw/dialog.d`; then
  983.     echo shar: \"lib/xaw/dialog.d\" unpacked with wrong size!
  984. fi
  985. # end of overwriting check
  986. fi
  987. if test -f lib/xaw/vpaned.d -a "${1}" != "-c" ; then 
  988.   echo shar: Will not over-write existing file \"lib/xaw/vpaned.d\"
  989. else
  990. echo shar: Extracting \"lib/xaw/vpaned.d\" \(108 characters\)
  991. sed "s/^X//" >lib/xaw/vpaned.d <<'END_OF_lib/xaw/vpaned.d'
  992. X;;; -*-Scheme-*-
  993. X
  994. X(define-widget-type 'vpaned "VPaned.h")
  995. X
  996. X(define-widget-class 'vpaned 'vPanedWidgetClass)
  997. END_OF_lib/xaw/vpaned.d
  998. if test 108 -ne `wc -c <lib/xaw/vpaned.d`; then
  999.     echo shar: \"lib/xaw/vpaned.d\" unpacked with wrong size!
  1000. fi
  1001. # end of overwriting check
  1002. fi
  1003. if test -f lib/xaw/ascii.d -a "${1}" != "-c" ; then 
  1004.   echo shar: Will not over-write existing file \"lib/xaw/ascii.d\"
  1005. else
  1006. echo shar: Extracting \"lib/xaw/ascii.d\" \(1916 characters\)
  1007. sed "s/^X//" >lib/xaw/ascii.d <<'END_OF_lib/xaw/ascii.d'
  1008. X;;; -*-Scheme-*-
  1009. X
  1010. X(define-widget-type 'ascii "AsciiText.h"
  1011. X
  1012. X"static SYMDESCR Edittype_Syms[] = {
  1013. X    { \"text-read\",     XttextRead },
  1014. X    { \"text-append\",   XttextAppend },
  1015. X    { \"text-edit\",     XttextEdit },
  1016. X    { 0, 0 }
  1017. X};
  1018. Xstatic SYMDESCR Options_Syms[] = {
  1019. X    { \"word-break\",         wordBreak },
  1020. X    { \"scroll-vertical\",    scrollVertical },
  1021. X    { \"scroll-horizontal\",  scrollHorizontal },
  1022. X    { \"scroll-on-overflow\", scrollOnOverflow },
  1023. X    { \"resize-width\",       resizeWidth },
  1024. X    { \"resize-height\",      resizeHeight },
  1025. X    { \"editable\",           editable },
  1026. X    { 0, 0 }
  1027. X};")
  1028. X
  1029. X(define-widget-class 'ascii-string 'asciiStringWidgetClass
  1030. X  '(font Font FontStruct)
  1031. X  '(foreground Foreground Pixel)
  1032. X  '(editType EditType EditMode)
  1033. X  '(length Length Int))
  1034. X
  1035. X(define-widget-class 'ascii-disk 'asciiDiskWidgetClass
  1036. X  '(font Font FontStruct)
  1037. X  '(foreground Foreground Pixel)
  1038. X  '(editType EditType EditMode))
  1039. X
  1040. X(define scheme->edit-type
  1041. X"   return (XtArgVal)Symbols_To_Bits (x, 0, Edittype_Syms);")
  1042. X
  1043. X(scheme->c 'ascii-string-editType scheme->edit-type)
  1044. X(scheme->c 'ascii-disk-editType   scheme->edit-type)
  1045. X
  1046. X(define scheme->text-options
  1047. X"   return (XtArgVal)Symbols_To_Bits (x, 1, Options_Syms);")
  1048. X
  1049. X(scheme->c 'ascii-string-textOptions scheme->text-options)
  1050. X(scheme->c 'ascii-disk-textOptions   scheme->text-options)
  1051. X
  1052. X(define text-options->scheme
  1053. X"   return Bits_To_Symbols ((unsigned long)x, 1, Options_Syms);")
  1054. X
  1055. X(c->scheme 'ascii-string-textOptions text-options->scheme)
  1056. X(c->scheme 'ascii-disk-textOptions   text-options->scheme)
  1057. X
  1058. X(scheme->c 'ascii-string-string
  1059. X"   char *s, *t;
  1060. X    Make_C_String (x, t);
  1061. X    if ((s = XtMalloc (1024)) == 0)
  1062. X    Primitive_Error (\"out of memory\");
  1063. X    strncpy (s, t, 1024);
  1064. X    return (XtArgVal)s;")
  1065. X
  1066. X(scheme->c 'ascii-string-length
  1067. X"   if (Get_Integer (x) > 1024)
  1068. X    Primitive_Error (\"invalid length for ascii-string\");
  1069. X    return (XtArgVal)Get_Integer (x);")
  1070. END_OF_lib/xaw/ascii.d
  1071. if test 1916 -ne `wc -c <lib/xaw/ascii.d`; then
  1072.     echo shar: \"lib/xaw/ascii.d\" unpacked with wrong size!
  1073. fi
  1074. # end of overwriting check
  1075. fi
  1076. if test -f lib/xaw/viewport.d -a "${1}" != "-c" ; then 
  1077.   echo shar: Will not over-write existing file \"lib/xaw/viewport.d\"
  1078. else
  1079. echo shar: Extracting \"lib/xaw/viewport.d\" \(116 characters\)
  1080. sed "s/^X//" >lib/xaw/viewport.d <<'END_OF_lib/xaw/viewport.d'
  1081. X;;; -*-Scheme-*-
  1082. X
  1083. X(define-widget-type 'viewport "Viewport.h")
  1084. X
  1085. X(define-widget-class 'viewport 'viewportWidgetClass)
  1086. END_OF_lib/xaw/viewport.d
  1087. if test 116 -ne `wc -c <lib/xaw/viewport.d`; then
  1088.     echo shar: \"lib/xaw/viewport.d\" unpacked with wrong size!
  1089. fi
  1090. # end of overwriting check
  1091. fi
  1092. if test ! -d lib/xt ; then
  1093.     echo shar: Creating directory \"lib/xt\"
  1094.     mkdir lib/xt
  1095. fi
  1096. if test ! -d lib/xt/examples ; then
  1097.     echo shar: Creating directory \"lib/xt/examples\"
  1098.     mkdir lib/xt/examples
  1099. fi
  1100. if test -f lib/xt/examples/dialog -a "${1}" != "-c" ; then 
  1101.   echo shar: Will not over-write existing file \"lib/xt/examples/dialog\"
  1102. else
  1103. echo shar: Extracting \"lib/xt/examples/dialog\" \(2235 characters\)
  1104. sed "s/^X//" >lib/xt/examples/dialog <<'END_OF_lib/xt/examples/dialog'
  1105. X;;; -*-Scheme-*-
  1106. X;;;
  1107. X;;; (Stupid) dialog box demo
  1108. X
  1109. X(require 'xwidgets)
  1110. X(load-widgets shell dialog command box label)
  1111. X
  1112. X(define con (create-context))
  1113. X(define dpy (initialize-display con #f 'dialog 'demo))
  1114. X(define top (create-shell 'dialog 'demo (find-class 'application-shell) dpy))
  1115. X
  1116. X(define f (open-font dpy "*courier-bold-r-normal--14*"))
  1117. X(define g (open-font dpy "*courier-bold-r-normal--18*"))
  1118. X
  1119. X(define gray-bits "\10\2\10\2")
  1120. X(define gray (create-bitmap-from-data (display-root-window dpy) gray-bits 4 4))
  1121. X
  1122. X(define box (create-managed-widget (find-class 'box) top))
  1123. X(set-values! box 'h-space 14 'v-space 14 'background-pixmap gray)
  1124. X
  1125. X(define dialog (create-managed-widget (find-class 'dialog) box
  1126. X        'value "/tmp/test" 'label "FILENAME:"))
  1127. X(set-values! dialog 'width 80)
  1128. X(set-values! (name->widget dialog 'label) 'font f)
  1129. X
  1130. X(define button (create-managed-widget (find-class 'command) dialog))
  1131. X(set-values! button 'label "cancel" 'font f)
  1132. X
  1133. X(define button2 (create-managed-widget (find-class 'command) dialog))
  1134. X(set-values! button2 'label "write" 'font f)
  1135. X(add-callback button2 'callback
  1136. X  (lambda (w)
  1137. X    (format #t "Filename is ~s~%"
  1138. X        (car (get-values (widget-parent w) 'value)))))
  1139. X
  1140. X(define bbox (create-managed-widget (find-class 'box) box))
  1141. X
  1142. X(define l (create-managed-widget (find-class 'label) bbox 'border-width 0
  1143. X                             'font f 'label "TYPEFACE:"))
  1144. X(define b1 (create-managed-widget (find-class 'command) bbox))
  1145. X(set-values! b1 'label "normal" 'font f)
  1146. X(define b2 (create-managed-widget (find-class 'command) bbox))
  1147. X(set-values! b2 'label "bold" 'font f)
  1148. X(define b3 (create-managed-widget (find-class 'command) bbox))
  1149. X(set-values! b3 'label "italic" 'font f)
  1150. X(define b4 (create-managed-widget (find-class 'command) bbox))
  1151. X(set-values! b4 'label "faint" 'font f 'sensitive #f)
  1152. X
  1153. X(define q (create-managed-widget (find-class 'command) box))
  1154. X(set-values! q 'label "quit" 'border-width 3 'font g)
  1155. X(add-callback q 'callback (lambda (w) (exit)))
  1156. X
  1157. X(define q2 (create-managed-widget (find-class 'command) box))
  1158. X(set-values! q2 'label "apply" 'border-width 3 'font g)
  1159. X(add-callback q2 'callback (lambda (w) (set! done #t)))
  1160. X
  1161. X(define done #f)
  1162. X
  1163. X(realize-widget top)
  1164. X(while (not done) (context-process-event con))
  1165. END_OF_lib/xt/examples/dialog
  1166. if test 2235 -ne `wc -c <lib/xt/examples/dialog`; then
  1167.     echo shar: \"lib/xt/examples/dialog\" unpacked with wrong size!
  1168. fi
  1169. # end of overwriting check
  1170. fi
  1171. if test -f lib/xt/examples/scrollbar -a "${1}" != "-c" ; then 
  1172.   echo shar: Will not over-write existing file \"lib/xt/examples/scrollbar\"
  1173. else
  1174. echo shar: Extracting \"lib/xt/examples/scrollbar\" \(658 characters\)
  1175. sed "s/^X//" >lib/xt/examples/scrollbar <<'END_OF_lib/xt/examples/scrollbar'
  1176. X;;; -*-Scheme-*-
  1177. X;;;
  1178. X;;; Scroll bar demo
  1179. X
  1180. X(require 'xwidgets)
  1181. X(load-widgets shell scroll)
  1182. X
  1183. X(define con (create-context))
  1184. X(define dpy (initialize-display con #f 'scroll 'demo))
  1185. X(define top (create-shell 'scroll 'demo (find-class 'application-shell) dpy))
  1186. X
  1187. X(define scroll (create-managed-widget (find-class 'scrollbar) top
  1188. X                                      'thickness 35 'length 400))
  1189. X
  1190. X(define (sp w x) (format #t "(scroll-proc ~s)~%" x))
  1191. X(define (jp w x) (format #t "(jump-proc ~s)~%" x))
  1192. X
  1193. X(add-callback scroll 'scroll-proc sp)
  1194. X(set-values! scroll 'jump-proc (list jp))
  1195. X
  1196. X(scrollbar-set-thumb! scroll 0.3 0.2)
  1197. X
  1198. X(realize-widget top)
  1199. X(context-main-loop con)
  1200. END_OF_lib/xt/examples/scrollbar
  1201. if test 658 -ne `wc -c <lib/xt/examples/scrollbar`; then
  1202.     echo shar: \"lib/xt/examples/scrollbar\" unpacked with wrong size!
  1203. fi
  1204. # end of overwriting check
  1205. fi
  1206. if test -f lib/xt/examples/scrollbox -a "${1}" != "-c" ; then 
  1207.   echo shar: Will not over-write existing file \"lib/xt/examples/scrollbox\"
  1208. else
  1209. echo shar: Extracting \"lib/xt/examples/scrollbox\" \(1118 characters\)
  1210. sed "s/^X//" >lib/xt/examples/scrollbox <<'END_OF_lib/xt/examples/scrollbox'
  1211. X;;; -*-Scheme-*-
  1212. X;;;
  1213. X;;; Scroll box demo
  1214. X
  1215. X(require 'xwidgets)
  1216. X(load-widgets shell command box label)
  1217. X
  1218. X(define items '(Helvetica Courier Times Palatino Zapf\ Chancery Zapf\ Dingbats))
  1219. X(set-cdr! (last-pair items) items)
  1220. X
  1221. X(define con (create-context))
  1222. X(define dpy (initialize-display con #f 'box 'demo))
  1223. X(define top (create-shell 'box 'demo (find-class 'application-shell) dpy))
  1224. X
  1225. X(define dia-bits "\0\0\100\0\340\0\360\1\370\3\374\7\376\17\374\7\370\3\360\1\340\0\100\0\0\0")
  1226. X(define dia (create-bitmap-from-data (display-root-window dpy) dia-bits 13 13))
  1227. X
  1228. X(define box (create-managed-widget (find-class 'box) top))
  1229. X(set-values! box 'width 200)
  1230. X
  1231. X(define button (create-managed-widget (find-class 'command) box))
  1232. X(set-values! button 'bitmap dia)
  1233. X
  1234. X(define label (create-managed-widget (find-class 'label) box))
  1235. X(set-values! label 'width 130 'label (car items) 'resize #f 'justify 'left
  1236. X                   'font (open-font dpy "*courier-bold-r-normal--14*"))
  1237. X(add-callback button 'callback
  1238. X  (lambda (w)
  1239. X    (set! items (cdr items))
  1240. X    (set-values! label 'label (car items))))
  1241. X
  1242. X(realize-widget top)
  1243. X(context-main-loop con)
  1244. END_OF_lib/xt/examples/scrollbox
  1245. if test 1118 -ne `wc -c <lib/xt/examples/scrollbox`; then
  1246.     echo shar: \"lib/xt/examples/scrollbox\" unpacked with wrong size!
  1247. fi
  1248. # end of overwriting check
  1249. fi
  1250. if test -f lib/xt/examples/list -a "${1}" != "-c" ; then 
  1251.   echo shar: Will not over-write existing file \"lib/xt/examples/list\"
  1252. else
  1253. echo shar: Extracting \"lib/xt/examples/list\" \(2163 characters\)
  1254. sed "s/^X//" >lib/xt/examples/list <<'END_OF_lib/xt/examples/list'
  1255. X;;; -*-Scheme-*-
  1256. X;;;
  1257. X;;; List widget demo (directory browser)
  1258. X
  1259. X(require 'xwidgets)
  1260. X(load-widgets shell form label command list)
  1261. X(require 'unix 'unix.o)
  1262. X(require 'sort 'qsort)
  1263. X
  1264. X(define con (create-context))
  1265. X(define dpy (initialize-display con #f 'list 'demo))
  1266. X(define top (create-shell 'list 'demo (find-class 'application-shell) dpy))
  1267. X(set-values! top 'allow-shell-resize #t)
  1268. X
  1269. X(define form (create-managed-widget (find-class 'form) top))
  1270. X
  1271. X(define quit (create-managed-widget (find-class 'command) form))
  1272. X(set-values! quit 'label "quit")
  1273. X(add-callback quit 'callback (lambda x (exit)))
  1274. X
  1275. X(define back (create-managed-widget (find-class 'command) form))
  1276. X(set-values! back 'label "back" 'from-horiz quit)
  1277. X(add-callback back 'callback (lambda x (goto "..")))
  1278. X
  1279. X(define lab (create-managed-widget (find-class 'label) form))
  1280. X(set-values! lab 'border-width 0 'from-horiz back 'resizable #t)
  1281. X
  1282. X;; List widget is broken; ``list'' resource *must* be initialized:
  1283. X(define lst (create-managed-widget (find-class 'list) form 'list ()))
  1284. X(set-values! lst 'from-vert lab 'resizable #t 'vertical-list #t)
  1285. X
  1286. X(add-callback lst 'callback
  1287. X  (lambda (w i)
  1288. X    (let ((stat (file-status (string-append where "/" (car i)))))
  1289. X      (set-values! lab 'label stat)
  1290. X      (if (eq? stat 'directory)
  1291. X      (goto (car i))))))
  1292. X
  1293. X(define (goto dir)
  1294. X  (if (string=? dir "..")
  1295. X      (begin
  1296. X    (if (not (string=? where "/"))
  1297. X        (begin
  1298. X              (set! where
  1299. X            (substring where 0
  1300. X                   (do ((i (- (string-length where) 2) (1- i)))
  1301. X                   ((char=? (string-ref where i) #\/) i))))
  1302. X              (if (eqv? where "")
  1303. X              (set! where "/")))))
  1304. X      (if (not (or (string=? dir "/") (string=? where "/")))
  1305. X      (set! where (string-append where "/")))
  1306. X      (set! where (string-append where dir)))
  1307. X  (set-values! lab 'label where)
  1308. X  (define l ())
  1309. X  (for-each (lambda (d) (if (not (member d '("." "..")))
  1310. X                (set! l (cons d l))))
  1311. X        (read-directory where))
  1312. X  (set-values! lst 'default-columns
  1313. X    (max 2 (ceiling (/ (length l) 40))))
  1314. X  (list-change! lst (sort l string<?) #t))
  1315. X
  1316. X(define where "")
  1317. X(goto "/")
  1318. X(set-values! lab 'label "Select directory:")
  1319. X(realize-widget top)
  1320. X(context-main-loop con)
  1321. END_OF_lib/xt/examples/list
  1322. if test 2163 -ne `wc -c <lib/xt/examples/list`; then
  1323.     echo shar: \"lib/xt/examples/list\" unpacked with wrong size!
  1324. fi
  1325. # end of overwriting check
  1326. fi
  1327. if test -f lib/xt/examples/grip -a "${1}" != "-c" ; then 
  1328.   echo shar: Will not over-write existing file \"lib/xt/examples/grip\"
  1329. else
  1330. echo shar: Extracting \"lib/xt/examples/grip\" \(649 characters\)
  1331. sed "s/^X//" >lib/xt/examples/grip <<'END_OF_lib/xt/examples/grip'
  1332. X;;; -*-Scheme-*-
  1333. X;;;
  1334. X;;; Grip widget demo
  1335. X
  1336. X(require 'xwidgets)
  1337. X(load-widgets shell grip)
  1338. X
  1339. X(define con (create-context))
  1340. X(define dpy (initialize-display con #f 'grip 'demo))
  1341. X(define top (create-shell 'grip 'demo (find-class 'application-shell) dpy))
  1342. X(set-values! top 'width 50 'height 50)
  1343. X
  1344. X(define g (create-managed-widget (find-class 'grip) top))
  1345. X
  1346. X(augment-translations g
  1347. X"   <Btn1Down>:      GripAction(press)
  1348. X    <Btn1Motion>:    GripAction(move)
  1349. X    <Btn1Up>:        GripAction(release,done)")
  1350. X
  1351. X(add-callback g 'callback
  1352. X  (lambda (w x)
  1353. X    (format #t "Action: ~s    Event: ~s~%" (cdr x) (caar x))))
  1354. X
  1355. X(realize-widget top)
  1356. X(context-main-loop con)
  1357. END_OF_lib/xt/examples/grip
  1358. if test 649 -ne `wc -c <lib/xt/examples/grip`; then
  1359.     echo shar: \"lib/xt/examples/grip\" unpacked with wrong size!
  1360. fi
  1361. # end of overwriting check
  1362. fi
  1363. if test -f lib/xt/examples/viewport -a "${1}" != "-c" ; then 
  1364.   echo shar: Will not over-write existing file \"lib/xt/examples/viewport\"
  1365. else
  1366. echo shar: Extracting \"lib/xt/examples/viewport\" \(535 characters\)
  1367. sed "s/^X//" >lib/xt/examples/viewport <<'END_OF_lib/xt/examples/viewport'
  1368. X;;; -*-Scheme-*-
  1369. X
  1370. X(require 'xwidgets)
  1371. X(load-widgets shell clock viewport)
  1372. X
  1373. X(define con (create-context))
  1374. X(define dpy (initialize-display con #f 'viewport 'demo))
  1375. X(define top (create-shell 'viewport 'demo (find-class 'application-shell) dpy))
  1376. X
  1377. X(define v (create-managed-widget (find-class 'viewport) top
  1378. X  'force-bars #t 'allow-horiz #t 'allow-vert #t))
  1379. X(set-values! v 'width 120 'height 120)
  1380. X
  1381. X(define c (create-managed-widget (find-class 'clock) v))
  1382. X(set-values! c 'width 200 'height 200)
  1383. X
  1384. X(realize-widget top)
  1385. X(context-main-loop con)
  1386. END_OF_lib/xt/examples/viewport
  1387. if test 535 -ne `wc -c <lib/xt/examples/viewport`; then
  1388.     echo shar: \"lib/xt/examples/viewport\" unpacked with wrong size!
  1389. fi
  1390. # end of overwriting check
  1391. fi
  1392. if test -f lib/xt/examples/text -a "${1}" != "-c" ; then 
  1393.   echo shar: Will not over-write existing file \"lib/xt/examples/text\"
  1394. else
  1395. echo shar: Extracting \"lib/xt/examples/text\" \(1220 characters\)
  1396. sed "s/^X//" >lib/xt/examples/text <<'END_OF_lib/xt/examples/text'
  1397. X;;; -*-Scheme-*-
  1398. X
  1399. X(require 'xwidgets)
  1400. X(load-widgets shell ascii box command label)
  1401. X
  1402. X(define con (create-context))
  1403. X(define dpy (initialize-display con #f 'text 'demo))
  1404. X(define top (create-shell 'text 'demo (find-class 'application-shell) dpy))
  1405. X
  1406. X(define box (create-managed-widget (find-class 'box) top))
  1407. X
  1408. X(define lab (create-managed-widget (find-class 'label) box))
  1409. X(set-values! lab 'border-width 0 'label "Enter a number:")
  1410. X
  1411. X;;; string resource *must* be specified (bug in Xaw):
  1412. X(define txt (create-managed-widget (find-class 'ascii-string) box
  1413. X  'string "" 'length 100 'edit-type 'text-edit))
  1414. X
  1415. X(define can (create-managed-widget (find-class 'command) box))
  1416. X(set-values! can 'label "CANCEL")
  1417. X(add-callback can 'callback (lambda foo (exit)))
  1418. X
  1419. X(define acc (create-managed-widget (find-class 'command) box))
  1420. X(set-values! acc 'label "ACCEPT")
  1421. X(add-callback acc 'callback
  1422. X          (lambda foo
  1423. X        (let ((s (car (get-values txt 'string))))
  1424. X          (if (not (number-string? s))
  1425. X              (format #t "~s is not a number!~%" s)
  1426. X              (format #t "Result is ~a~%" s)
  1427. X              (exit)))))
  1428. X      
  1429. X(define (number-string? s)
  1430. X  (not (or (eqv? s "") (memq #f (map char-numeric? (string->list s))))))
  1431. X
  1432. X(realize-widget top)
  1433. X(context-main-loop con)
  1434. END_OF_lib/xt/examples/text
  1435. if test 1220 -ne `wc -c <lib/xt/examples/text`; then
  1436.     echo shar: \"lib/xt/examples/text\" unpacked with wrong size!
  1437. fi
  1438. # end of overwriting check
  1439. fi
  1440. if test -f lib/xt/examples/hp-misc -a "${1}" != "-c" ; then 
  1441.   echo shar: Will not over-write existing file \"lib/xt/examples/hp-misc\"
  1442. else
  1443. echo shar: Extracting \"lib/xt/examples/hp-misc\" \(1993 characters\)
  1444. sed "s/^X//" >lib/xt/examples/hp-misc <<'END_OF_lib/xt/examples/hp-misc'
  1445. X;;; -*-Scheme-*-
  1446. X;;;
  1447. X;;; HP widgets demo
  1448. X
  1449. X(require 'xwidgets)
  1450. X(set! widget-load-path '(xhp xaw))
  1451. X(load-widgets arrow bboard box pbutton sash scroll shell stext toggle)
  1452. X(load-widgets valuator vpw)
  1453. X
  1454. X(define con (create-context))
  1455. X(define dpy (initialize-display con #f 'widgets 'demo))
  1456. X(define top (create-shell 'widgets 'demo (find-class 'application-shell) dpy))
  1457. X
  1458. X(define box (create-managed-widget (find-class 'box) top))
  1459. X
  1460. X(define t1 (create-managed-widget (find-class 'toggle) box))
  1461. X(set-values! t1 'traversal-type "highlight_enter" 'highlight-thickness 3)
  1462. X(define t2 (create-managed-widget (find-class 'toggle) box 'square #f))
  1463. X(set-values! t2 'traversal-type "highlight_enter" 'highlight-thickness 3)
  1464. X
  1465. X(define vpw (create-managed-widget (find-class 'vpw) box))
  1466. X
  1467. X(define a1 (create-managed-widget (find-class 'arrow) vpw))
  1468. X(set-values! a1 'width 75 'height 75)
  1469. X(set-values! (name->widget vpw 'sash) 'background "black")
  1470. X(define a2 (create-managed-widget (find-class 'arrow) vpw))
  1471. X(set-values! a2 'height 75 'arrow-direction "arrow_down")
  1472. X
  1473. X(define val (create-managed-widget (find-class 'valuator) box))
  1474. X(set-values! val 'slider-origin 20 'cursor "sb_right_arrow")
  1475. X(add-callback val 'slider-moved (lambda (w x)
  1476. X  (set-values! s 'string (format #f "~s" x))))
  1477. X
  1478. X(define s (create-managed-widget (find-class 'static-text) box 'string "20"))
  1479. X(set-values! s 'recompute-size #f)
  1480. X
  1481. X(define sb (create-managed-widget (find-class 'scrollbar) box))
  1482. X(set-values! sb 'width 20 'height 150)
  1483. X
  1484. X(realize-widget top)
  1485. X
  1486. X(define bb (create-managed-widget (find-class 'bboard) box))
  1487. X(set-values! bb 'background-tile "50_foreground")
  1488. X(do ((x '(0 40 0 40) (cdr x)) (y '(0 0 40 40) (cdr y))) ((null? x))
  1489. X  (define s (create-managed-widget (find-class 'static-text) bb 
  1490. X    'string (format #f "~s,~s" (car x) (car y)) 'x (car x) 'y (car y))))
  1491. X
  1492. X(define p1 (create-managed-widget (find-class 'push-button) box))
  1493. X(set-values! p1 'label "Quit Button")
  1494. X(add-callback p1 'select (lambda (w) (exit)))
  1495. X
  1496. X(context-main-loop con)
  1497. END_OF_lib/xt/examples/hp-misc
  1498. if test 1993 -ne `wc -c <lib/xt/examples/hp-misc`; then
  1499.     echo shar: \"lib/xt/examples/hp-misc\" unpacked with wrong size!
  1500. fi
  1501. # end of overwriting check
  1502. fi
  1503. if test -f lib/xt/examples/hp-arrow -a "${1}" != "-c" ; then 
  1504.   echo shar: Will not over-write existing file \"lib/xt/examples/hp-arrow\"
  1505. else
  1506. echo shar: Extracting \"lib/xt/examples/hp-arrow\" \(1156 characters\)
  1507. sed "s/^X//" >lib/xt/examples/hp-arrow <<'END_OF_lib/xt/examples/hp-arrow'
  1508. X;;; -*-Scheme-*-
  1509. X;;;
  1510. X;;; Demo with arrow, vpw, and push button
  1511. X
  1512. X(require 'xwidgets)
  1513. X(load-widgets arrow sash shell pbutton vpw)
  1514. X
  1515. X(define con (create-context))
  1516. X(define dpy (initialize-display con #f 'arrow 'demo))
  1517. X(define top (create-shell 'arrow 'demo (find-class 'application-shell) dpy))
  1518. X(set-values! top 'allow-shell-resize #t)
  1519. X
  1520. X(define pane (create-managed-widget (find-class 'vpw) top))
  1521. X
  1522. X(define button (create-managed-widget (find-class 'push-button) pane))
  1523. X(set-values! button 'width 150 'label "Rotate Arrow")
  1524. X
  1525. X(set-values! (name->widget pane 'sash) 'background "black")
  1526. X
  1527. X(define arrow (create-managed-widget (find-class 'arrow) pane))
  1528. X(set-values! arrow 'height 150 'traversal-type "highlight_enter"
  1529. X               'highlight-thickness 3)
  1530. X
  1531. X(add-callback arrow 'select (lambda (w) (print '[select])))
  1532. X(add-callback arrow 'release (lambda (w) (print '[release])))
  1533. X
  1534. X(define curr '(arrow_up arrow_right arrow_down arrow_left))
  1535. X(set-cdr! (last-pair curr) curr)
  1536. X(set! curr (cdr curr))
  1537. X
  1538. X(add-callback button 'select
  1539. X  (lambda (w)
  1540. X    (set-values! arrow 'arrow-direction (car curr))
  1541. X    (set! curr (cdr curr))))
  1542. X
  1543. X(realize-widget top)
  1544. X(context-main-loop con)
  1545. END_OF_lib/xt/examples/hp-arrow
  1546. if test 1156 -ne `wc -c <lib/xt/examples/hp-arrow`; then
  1547.     echo shar: \"lib/xt/examples/hp-arrow\" unpacked with wrong size!
  1548. fi
  1549. # end of overwriting check
  1550. fi
  1551. if test -f lib/xt/examples/hp-list -a "${1}" != "-c" ; then 
  1552.   echo shar: Will not over-write existing file \"lib/xt/examples/hp-list\"
  1553. else
  1554. echo shar: Extracting \"lib/xt/examples/hp-list\" \(2637 characters\)
  1555. sed "s/^X//" >lib/xt/examples/hp-list <<'END_OF_lib/xt/examples/hp-list'
  1556. X;;; -*-Scheme-*-
  1557. X;;;
  1558. X;;; List widget demo
  1559. X
  1560. X(require 'xwidgets)
  1561. X(set! widget-load-path '(xhp xaw))
  1562. X(load-widgets bboard list pbutton shell stext)
  1563. X
  1564. X(define con (create-context))
  1565. X(define dpy (initialize-display con #f 'list 'demo))
  1566. X(define top (create-shell 'list 'demo (find-class 'application-shell) dpy))
  1567. X
  1568. X(define bb (create-managed-widget (find-class 'bboard) top))
  1569. X
  1570. X(define lst (create-managed-widget (find-class 'list) bb 'num-columns 3))
  1571. X(set-values! lst 'x 0 'y 130 'column-width 60 'element-highlight "invert"
  1572. X             'element-height 21)
  1573. X
  1574. X(define instant #t)
  1575. X(define p1 (create-managed-widget (find-class 'push-button) bb))
  1576. X(set-values! p1 'x 10 'y 10 'label "selection-style: instant")
  1577. X(add-callback p1 'release
  1578. X  (lambda r
  1579. X    (set-values! p1 'label
  1580. X      (if instant "selection-style: sticky" "selection-style: instant"))
  1581. X    (set! instant (not instant))
  1582. X    (set-values! lst 'selection-style (if instant "instant" "sticky"))))
  1583. X
  1584. X(define single #t)
  1585. X(define p2 (create-managed-widget (find-class 'push-button) bb))
  1586. X(set-values! p2 'x 10 'y 40 'label "selection-method: single")
  1587. X(add-callback p2 'release
  1588. X  (lambda r
  1589. X    (set-values! p2 'label
  1590. X      (if single "selection-method: multiple" "selection-method: single"))
  1591. X    (set! single (not single))
  1592. X    (set-values! lst 'selection-method (if single "single" "multiple"))))
  1593. X
  1594. X(define biases '(no_bias row_bias col_bias))
  1595. X(define bias 0)
  1596. X(define p3 (create-managed-widget (find-class 'push-button) bb))
  1597. X(set-values! p3 'x 10 'y 70 'label "selection-bias: none")
  1598. X(add-callback p3 'release
  1599. X  (lambda r
  1600. X    (set! bias (1+ bias)) (set! bias (modulo bias 3))
  1601. X    (set-values! p3 'label
  1602. X      (format #f "selection-bias: ~s" (list-ref biases bias)))
  1603. X    (set-values! lst 'selection-bias (list-ref biases bias))))
  1604. X
  1605. X(define invert #t)
  1606. X(define p4 (create-managed-widget (find-class 'push-button) bb))
  1607. X(set-values! p4 'x 10 'y 100 'label "element-highlight: invert")
  1608. X(add-callback p4 'release
  1609. X  (lambda r
  1610. X    (set-values! p4 'label
  1611. X      (if invert "element-highlight: border" "element-highlight: invert"))
  1612. X    (set! invert (not invert))
  1613. X    (set-values! lst 'element-highlight (if invert "invert" "border"))))
  1614. X
  1615. X(define p5 (create-managed-widget (find-class 'push-button) bb))
  1616. X(set-values! p5 'x 250 'y 10 'label 'QUIT)
  1617. X(add-callback p5 'release (lambda r (exit)))
  1618. X
  1619. X(do ((i 0 (1+ i))) ((= i 80))
  1620. X  (define w (create-managed-widget (find-class 'static-text) lst
  1621. X                   'string (format #f "item ~s" i)))
  1622. X  (set-values! w 'highlight-thickness 2)
  1623. X  (add-callback w 'select
  1624. X    (lambda (w) (format #t "selected ~s~%" (car (get-values w 'string))))))
  1625. X
  1626. X(realize-widget top)
  1627. X(context-main-loop con)
  1628. END_OF_lib/xt/examples/hp-list
  1629. if test 2637 -ne `wc -c <lib/xt/examples/hp-list`; then
  1630.     echo shar: \"lib/xt/examples/hp-list\" unpacked with wrong size!
  1631. fi
  1632. # end of overwriting check
  1633. fi
  1634. if test -f lib/xt/examples/hp-menu -a "${1}" != "-c" ; then 
  1635.   echo shar: Will not over-write existing file \"lib/xt/examples/hp-menu\"
  1636. else
  1637. echo shar: Extracting \"lib/xt/examples/hp-menu\" \(3228 characters\)
  1638. sed "s/^X//" >lib/xt/examples/hp-menu <<'END_OF_lib/xt/examples/hp-menu'
  1639. X;;; -*-Scheme-*-
  1640. X;;;
  1641. X;;; HP menu demo
  1642. X
  1643. X(require 'xwidgets)
  1644. X(load-widgets bboard cascade menubutton menusep popupmgr shell toggle)
  1645. X
  1646. X(define (make-menu name attach-to)
  1647. X  (let* ((sh (create-popup-shell (find-class 'shell) attach-to))
  1648. X     (menu (create-managed-widget name (find-class 'popup-manager) sh)))
  1649. X    menu))
  1650. X
  1651. X(define (add-pane where title attach-to)
  1652. X  (let* ((sh (create-popup-shell (find-class 'shell) where))
  1653. X     (pane (create-managed-widget (find-class 'cascade) sh)))
  1654. X    (set-values! pane 'title-string title 'attach-to attach-to)
  1655. X    pane))
  1656. X
  1657. X(define (add-button where label)
  1658. X  (let ((b (create-managed-widget label (find-class 'menu-button) where)))
  1659. X    (set-values! b 'label label)
  1660. X    b))
  1661. X
  1662. X(define (add-separator where style)
  1663. X  (let ((s (create-managed-widget (find-class 'menu-separator) where)))
  1664. X    (set-values! s 'separator-type style)
  1665. X    s))
  1666. X
  1667. X(define con (create-context))
  1668. X(define dpy (initialize-display con #f 'menu 'demo))
  1669. X(define top (create-shell 'menu 'demo (find-class 'application-shell) dpy))
  1670. X
  1671. X(define bb (create-managed-widget (find-class 'bboard) top))
  1672. X(define bb1 (create-managed-widget (find-class 'bboard) bb))
  1673. X(set-values! bb1 'width 300 'height 30 'layout "ignore")
  1674. X(define bb2 (create-managed-widget (find-class 'bboard) bb))
  1675. X(set-values! bb2 'y 30 'width 300 'height 150)
  1676. X
  1677. X(define menu (make-menu 'menu bb2))
  1678. X
  1679. X(define pane1 (add-pane menu "main menu" 'menu))
  1680. X
  1681. X(add-button pane1 'search)
  1682. X(add-button pane1 'change)
  1683. X(add-button pane1 'create)
  1684. X(add-button pane1 'destroy)
  1685. X(define sep (add-separator pane1 "single_line"))
  1686. X(add-button pane1 'help)
  1687. X(add-button pane1 'quit)
  1688. X
  1689. X(define pane2 (add-pane menu "change menu" 'change))
  1690. X
  1691. X(add-button pane2 'typeface)
  1692. X(add-button pane2 'font)
  1693. X(add-button pane2 'help)
  1694. X
  1695. X(define pane3 (add-pane menu "typeface menu" 'typeface))
  1696. X
  1697. X(add-button pane3 'bold)
  1698. X(add-button pane3 'italic)
  1699. X(add-button pane3 'underlined)
  1700. X(add-button pane3 'double\ underlined)
  1701. X(add-button pane3 'crossed\ out)
  1702. X(add-button pane3 'negative)
  1703. X(add-button pane3 'faint)
  1704. X
  1705. X(define pane4 (add-pane menu "font menu" 'font))
  1706. X
  1707. X(do ((i 0 (1+ i))) ((= i 10))
  1708. X  (add-button pane4 (format #f "font #~s" i)))
  1709. X
  1710. X(add-callback (name->widget pane1 'quit) 'select (lambda (w) (exit)))
  1711. X
  1712. X(define (change-separator-style _)
  1713. X  (set-values! sep 'separator-type
  1714. X    (if (car (get-values t2 'set))
  1715. X        (if (car (get-values t3 'set))
  1716. X        "double_dashed_line"
  1717. X        "double_line")
  1718. X        (if (car (get-values t3 'set))
  1719. X        "single_dashed_line"
  1720. X        "single_line"))))
  1721. X
  1722. X(define (change-sticky _)
  1723. X  (set-values! menu 'sticky-menus (car (get-values t1 'set))))
  1724. X
  1725. X(define t1 (create-managed-widget (find-class 'toggle) bb1))
  1726. X(set-values! t1 'x 10 'y 10 'label "sticky")
  1727. X(add-callback t1 'select change-sticky)
  1728. X(add-callback t1 'release change-sticky)
  1729. X
  1730. X(define t2 (create-managed-widget (find-class 'toggle) bb1))
  1731. X(set-values! t2 'x 90 'y 10 'label 'double-line)
  1732. X(add-callback t2 'select change-separator-style)
  1733. X(add-callback t2 'release change-separator-style)
  1734. X
  1735. X(define t3 (create-managed-widget (find-class 'toggle) bb1))
  1736. X(set-values! t3 'x 190 'y 10 'label 'dashed-line)
  1737. X(add-callback t3 'select change-separator-style)
  1738. X(add-callback t3 'release change-separator-style)
  1739. X
  1740. X(realize-widget top)
  1741. X(context-main-loop con)
  1742. END_OF_lib/xt/examples/hp-menu
  1743. if test 3228 -ne `wc -c <lib/xt/examples/hp-menu`; then
  1744.     echo shar: \"lib/xt/examples/hp-menu\" unpacked with wrong size!
  1745. fi
  1746. # end of overwriting check
  1747. fi
  1748. if test -f lib/xt/Makefile -a "${1}" != "-c" ; then 
  1749.   echo shar: Will not over-write existing file \"lib/xt/Makefile\"
  1750. else
  1751. echo shar: Extracting \"lib/xt/Makefile\" \(901 characters\)
  1752. sed "s/^X//" >lib/xt/Makefile <<'END_OF_lib/xt/Makefile'
  1753. XH=    ../../src/config.h\
  1754. X    ../../src/object.h\
  1755. X    ../../src/extern.h\
  1756. X    ../../src/macros.h\
  1757. X    ../util/objects.h\
  1758. X    ../xlib/xlib.h\
  1759. X    xt.h
  1760. X
  1761. XC=    callback.c\
  1762. X    class.c\
  1763. X    context.c\
  1764. X    converter.c\
  1765. X    error.c\
  1766. X    identifier.c\
  1767. X    objects.c\
  1768. X    popup.c\
  1769. X    resource.c\
  1770. X    translation.c\
  1771. X    widget.c
  1772. X
  1773. XO=    callback.o\
  1774. X    class.o\
  1775. X    context.o\
  1776. X    converter.o\
  1777. X    error.o\
  1778. X    identifier.o\
  1779. X    objects.o\
  1780. X    popup.o\
  1781. X    resource.o\
  1782. X    translation.o\
  1783. X    widget.o
  1784. X
  1785. Xall: ../xt.o ../xt-only.o
  1786. X
  1787. X../xt.o:    $(O) ../xlib.o
  1788. X    ld -r -x $(O) -lXt ../xlib.o -lX11; mv a.out ../xt.o; chmod 644 ../xt.o
  1789. X
  1790. X../xt-only.o:    $(O)
  1791. X    ld -r -x $(O); mv a.out ../xt-only.o; chmod 644 ../xt-only.o
  1792. X
  1793. Xcallback.o:    $(H)
  1794. Xclass.o:    $(H)
  1795. Xcontext.o:    $(H)
  1796. Xconverter.o:    $(H)
  1797. Xerror.o:    $(H)
  1798. Xidentifier.o:    $(H)
  1799. Xobjects.o:    $(H)
  1800. Xpopup.o:    $(H)
  1801. Xresource.o:    $(H)
  1802. Xtranslation.o:    $(H)
  1803. Xwidget.o:    $(H)
  1804. X
  1805. Xlint:
  1806. X    lint $(LINTFLAGS) -abxh $(C) | egrep -v '\?\?\?'
  1807. X
  1808. Xclean:
  1809. X    rm -f *.o core a.out ../xt.o ../xt-only.o
  1810. END_OF_lib/xt/Makefile
  1811. if test 901 -ne `wc -c <lib/xt/Makefile`; then
  1812.     echo shar: \"lib/xt/Makefile\" unpacked with wrong size!
  1813. fi
  1814. # end of overwriting check
  1815. fi
  1816. if test -f lib/xt/objects.c -a "${1}" != "-c" ; then 
  1817.   echo shar: Will not over-write existing file \"lib/xt/objects.c\"
  1818. else
  1819. echo shar: Extracting \"lib/xt/objects.c\" \(556 characters\)
  1820. sed "s/^X//" >lib/xt/objects.c <<'END_OF_lib/xt/objects.c'
  1821. X#include <varargs.h>
  1822. X
  1823. X#include "xt.h"
  1824. X
  1825. XMatch_Xt_Obj (x, v) Object x; va_list v; {
  1826. X    register type = TYPE(x);
  1827. X
  1828. X    if (type == T_Context) {
  1829. X    return va_arg (v, XtAppContext) == CONTEXT(x)->context;
  1830. X    } else if (type == T_Class) {
  1831. X    return va_arg (v, WidgetClass) == CLASS(x)->class;
  1832. X    } else if (type == T_Widget) {
  1833. X    return va_arg (v, Widget) == WIDGET(x)->widget;
  1834. X    } else if (type == T_Identifier) {
  1835. X    return va_arg (v, int) == IDENTIFIER(x)->type
  1836. X        && va_arg (v, caddr_t) == IDENTIFIER(x)->val;
  1837. X    } else Panic ("Match_Xt_Obj");
  1838. X    return 0;
  1839. X}
  1840. END_OF_lib/xt/objects.c
  1841. if test 556 -ne `wc -c <lib/xt/objects.c`; then
  1842.     echo shar: \"lib/xt/objects.c\" unpacked with wrong size!
  1843. fi
  1844. # end of overwriting check
  1845. fi
  1846. if test -f lib/xt/error.c -a "${1}" != "-c" ; then 
  1847.   echo shar: Will not over-write existing file \"lib/xt/error.c\"
  1848. else
  1849. echo shar: Extracting \"lib/xt/error.c\" \(486 characters\)
  1850. sed "s/^X//" >lib/xt/error.c <<'END_OF_lib/xt/error.c'
  1851. X#include "xt.h"
  1852. X
  1853. Xstatic Object V_Xt_Warning_Handler;
  1854. X
  1855. XXt_Warning (msg) char *msg; {
  1856. X    Object args, fun;
  1857. X
  1858. X    args = Cons (Make_String (msg, strlen (msg)), Null);
  1859. X    fun = Val (V_Xt_Warning_Handler);
  1860. X    if (TYPE(fun) == T_Compound)
  1861. X    (void)Funcall (fun, args, 0);
  1862. X    Format (Curr_Output_Port, msg, strlen (msg), 0, (Object *)0);
  1863. X    P_Newline (0);
  1864. X}
  1865. X
  1866. Xinit_xt_error () {
  1867. X    Define_Variable (&V_Xt_Warning_Handler, "xt-warning-handler", Null);
  1868. X    XtSetWarningHandler (Xt_Warning);
  1869. X}
  1870. END_OF_lib/xt/error.c
  1871. if test 486 -ne `wc -c <lib/xt/error.c`; then
  1872.     echo shar: \"lib/xt/error.c\" unpacked with wrong size!
  1873. fi
  1874. # end of overwriting check
  1875. fi
  1876. echo shar: End of archive 12 \(of 14\).
  1877. cp /dev/null ark12isdone
  1878. MISSING=""
  1879. for I in 1 2 3 4 5 6 7 8 9 10 11 12 13 14 ; do
  1880.     if test ! -f ark${I}isdone ; then
  1881.     MISSING="${MISSING} ${I}"
  1882.     fi
  1883. done
  1884. if test "${MISSING}" = "" ; then
  1885.     echo You have unpacked all 14 archives.
  1886.     rm -f ark[1-9]isdone ark[1-9][0-9]isdone
  1887. else
  1888.     echo You still need to unpack the following archives:
  1889.     echo "        " ${MISSING}
  1890. fi
  1891. ##  End of shell archive.
  1892. exit 0
  1893.