1/*
2 * Copyright (c) 2001 by The XFree86 Project, Inc.
3 *
4 * Permission is hereby granted, free of charge, to any person obtaining a
5 * copy of this software and associated documentation files (the "Software"),
6 * to deal in the Software without restriction, including without limitation
7 * the rights to use, copy, modify, merge, publish, distribute, sublicense,
8 * and/or sell copies of the Software, and to permit persons to whom the
9 * Software is furnished to do so, subject to the following conditions:
10 *
11 * The above copyright notice and this permission notice shall be included in
12 * all copies or substantial portions of the Software.
13 *
14 * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
15 * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
16 * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.  IN NO EVENT SHALL
17 * THE XFREE86 PROJECT BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
18 * WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF
19 * OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
20 * SOFTWARE.
21 *
22 * Except as contained in this notice, the name of the XFree86 Project shall
23 * not be used in advertising or otherwise to promote the sale, use or other
24 * dealings in this Software without prior written authorization from the
25 * XFree86 Project.
26 *
27 * Author: Paulo César Pereira de Andrade
28 */
29
30/* $XFree86: xc/programs/xedit/lisp/modules/xt.c,v 1.20tsi Exp $ */
31
32#include <stdlib.h>
33#include <stdio.h>
34#include <string.h>
35#include <X11/Intrinsic.h>
36#include <X11/StringDefs.h>
37#include <X11/Shell.h>
38#include "lisp/internal.h"
39#include "lisp/private.h"
40
41/*
42 * Types
43 */
44typedef struct {
45    XrmQuark qname;
46    XrmQuark qtype;
47    Cardinal size;
48} ResourceInfo;
49
50typedef struct {
51    WidgetClass widget_class;
52    ResourceInfo **resources;
53    Cardinal num_resources;
54    Cardinal num_cons_resources;
55} ResourceList;
56
57typedef struct {
58    Arg *args;
59    Cardinal num_args;
60} Resources;
61
62typedef struct {
63    LispObj *data;
64    /* data is => (list* widget callback argument) */
65} CallbackArgs;
66
67/*
68 * Prototypes
69 */
70int xtLoadModule(void);
71void LispXtCleanupCallback(Widget, XtPointer, XtPointer);
72
73void LispXtCallback(Widget, XtPointer, XtPointer);
74void LispXtInputCallback(XtPointer, int*, XtInputId*);
75
76/* a hack... */
77LispObj *Lisp_XtCoerceToWidgetList(LispBuiltin*);
78
79LispObj *Lisp_XtAddCallback(LispBuiltin*);
80LispObj *Lisp_XtAppInitialize(LispBuiltin*);
81LispObj *Lisp_XtAppMainLoop(LispBuiltin*);
82LispObj *Lisp_XtAppAddInput(LispBuiltin*);
83LispObj *Lisp_XtAppPending(LispBuiltin*);
84LispObj *Lisp_XtAppProcessEvent(LispBuiltin*);
85LispObj *Lisp_XtCreateWidget(LispBuiltin*);
86LispObj *Lisp_XtCreateManagedWidget(LispBuiltin*);
87LispObj *Lisp_XtCreatePopupShell(LispBuiltin*);
88LispObj *Lisp_XtDestroyWidget(LispBuiltin*);
89LispObj *Lisp_XtGetKeyboardFocusWidget(LispBuiltin*);
90LispObj *Lisp_XtGetValues(LispBuiltin*);
91LispObj *Lisp_XtManageChild(LispBuiltin*);
92LispObj *Lisp_XtUnmanageChild(LispBuiltin*);
93LispObj *Lisp_XtSetMappedWhenManaged(LispBuiltin*);
94LispObj *Lisp_XtMapWidget(LispBuiltin*);
95LispObj *Lisp_XtName(LispBuiltin*);
96LispObj *Lisp_XtParent(LispBuiltin*);
97LispObj *Lisp_XtUnmapWidget(LispBuiltin*);
98LispObj *Lisp_XtPopup(LispBuiltin*);
99LispObj *Lisp_XtPopdown(LispBuiltin*);
100LispObj *Lisp_XtIsRealized(LispBuiltin*);
101LispObj *Lisp_XtRealizeWidget(LispBuiltin*);
102LispObj *Lisp_XtUnrealizeWidget(LispBuiltin*);
103LispObj *Lisp_XtRemoveInput(LispBuiltin*);
104LispObj *Lisp_XtSetSensitive(LispBuiltin*);
105LispObj *Lisp_XtSetValues(LispBuiltin*);
106LispObj *Lisp_XtWidgetToApplicationContext(LispBuiltin*);
107LispObj *Lisp_XtDisplay(LispBuiltin*);
108LispObj *Lisp_XtDisplayOfObject(LispBuiltin*);
109LispObj *Lisp_XtScreen(LispBuiltin*);
110LispObj *Lisp_XtScreenOfObject(LispBuiltin*);
111LispObj *Lisp_XtSetKeyboardFocus(LispBuiltin*);
112LispObj *Lisp_XtWindow(LispBuiltin*);
113LispObj *Lisp_XtWindowOfObject(LispBuiltin*);
114LispObj *Lisp_XtAddGrab(LispBuiltin*);
115LispObj *Lisp_XtRemoveGrab(LispBuiltin*);
116LispObj *Lisp_XtAppGetExitFlag(LispBuiltin*);
117LispObj *Lisp_XtAppSetExitFlag(LispBuiltin*);
118
119LispObj *LispXtCreateWidget(LispBuiltin*, int);
120
121static Resources *LispConvertResources(LispObj*, Widget,
122				       ResourceList*, ResourceList*);
123static void LispFreeResources(Resources*);
124
125static int bcmp_action_resource(_Xconst void*, _Xconst void*);
126static ResourceInfo *GetResourceInfo(char*, ResourceList*, ResourceList*);
127static ResourceList *GetResourceList(WidgetClass);
128static int bcmp_action_resource_list(_Xconst void*, _Xconst void*);
129static ResourceList *FindResourceList(WidgetClass);
130static int qcmp_action_resource_list(_Xconst void*, _Xconst void*);
131static ResourceList *CreateResourceList(WidgetClass);
132static int qcmp_action_resource(_Xconst void*, _Xconst void*);
133static void BindResourceList(ResourceList*);
134
135static void PopdownAction(Widget, XEvent*, String*, Cardinal*);
136static void QuitAction(Widget, XEvent*, String*, Cardinal*);
137
138/*
139 * Initialization
140 */
141static LispBuiltin lispbuiltins[] = {
142    {LispFunction, Lisp_XtCoerceToWidgetList, "xt-coerce-to-widget-list number opaque"},
143
144    {LispFunction, Lisp_XtAddGrab, "xt-add-grab widget exclusive spring-loaded"},
145    {LispFunction, Lisp_XtAddCallback, "xt-add-callback widget callback-name callback &optional client-data"},
146    {LispFunction, Lisp_XtAppAddInput, "xt-app-add-input app-context fileno condition function &optional client-data"},
147    {LispFunction, Lisp_XtAppInitialize, "xt-app-initialize app-context-return application-class &optional options fallback-resources"},
148    {LispFunction, Lisp_XtAppPending, "xt-app-pending app-context"},
149    {LispFunction, Lisp_XtAppMainLoop, "xt-app-main-loop app-context"},
150    {LispFunction, Lisp_XtAppProcessEvent, "xt-app-process-event app-context &optional mask"},
151    {LispFunction, Lisp_XtAppGetExitFlag, "xt-app-get-exit-flag app-context"},
152    {LispFunction, Lisp_XtAppSetExitFlag, "xt-app-set-exit-flag app-context"},
153    {LispFunction, Lisp_XtCreateManagedWidget, "xt-create-managed-widget name widget-class parent &optional arguments"},
154    {LispFunction, Lisp_XtCreateWidget, "xt-create-widget name widget-class parent &optional arguments"},
155    {LispFunction, Lisp_XtCreatePopupShell, "xt-create-popup-shell name widget-class parent &optional arguments"},
156    {LispFunction, Lisp_XtDestroyWidget, "xt-destroy-widget widget"},
157    {LispFunction, Lisp_XtGetKeyboardFocusWidget, "xt-get-keyboard-focus-widget widget"},
158    {LispFunction, Lisp_XtGetValues, "xt-get-values widget arguments"},
159    {LispFunction, Lisp_XtManageChild, "xt-manage-child widget"},
160    {LispFunction, Lisp_XtName, "xt-name widget"},
161    {LispFunction, Lisp_XtUnmanageChild, "xt-unmanage-child widget"},
162    {LispFunction, Lisp_XtMapWidget, "xt-map-widget widget"},
163    {LispFunction, Lisp_XtUnmapWidget, "xt-unmap-widget widget"},
164    {LispFunction, Lisp_XtSetMappedWhenManaged, "xt-set-mapped-when-managed widget map-when-managed"},
165    {LispFunction, Lisp_XtParent, "xt-parent widget"},
166    {LispFunction, Lisp_XtPopup, "xt-popup widget grab-kind"},
167    {LispFunction, Lisp_XtPopdown, "xt-popdown widget"},
168    {LispFunction, Lisp_XtIsRealized, "xt-is-realized widget"},
169    {LispFunction, Lisp_XtRealizeWidget, "xt-realize-widget widget"},
170    {LispFunction, Lisp_XtUnrealizeWidget, "xt-unrealize-widget widget"},
171    {LispFunction, Lisp_XtRemoveInput, "xt-remove-input input"},
172    {LispFunction, Lisp_XtRemoveGrab, "xt-remove-grab widget"},
173    {LispFunction, Lisp_XtSetKeyboardFocus, "xt-set-keyboard-focus widget descendant"},
174    {LispFunction, Lisp_XtSetSensitive, "xt-set-sensitive widget sensitive"},
175    {LispFunction, Lisp_XtSetValues, "xt-set-values widget arguments"},
176    {LispFunction, Lisp_XtWidgetToApplicationContext, "xt-widget-to-application-context widget"},
177    {LispFunction, Lisp_XtDisplay, "xt-display widget"},
178    {LispFunction, Lisp_XtDisplayOfObject, "xt-display-of-object object"},
179    {LispFunction, Lisp_XtScreen, "xt-screen widget"},
180    {LispFunction, Lisp_XtScreenOfObject, "xt-screen-of-object object"},
181    {LispFunction, Lisp_XtWindow, "xt-window widget"},
182    {LispFunction, Lisp_XtWindowOfObject, "xt-window-of-object object"},
183};
184
185LispModuleData xtLispModuleData = {
186    LISP_MODULE_VERSION,
187    xtLoadModule,
188};
189
190static ResourceList **resource_list;
191static Cardinal num_resource_list;
192
193static Atom delete_window;
194static int xtAppContext_t, xtWidget_t, xtWidgetClass_t, xtWidgetList_t,
195	   xtInputId_t, xtDisplay_t, xtScreen_t, xtWindow_t;
196
197static XtActionsRec actions[] = {
198    {"xt-popdown",	PopdownAction},
199    {"xt-quit",		QuitAction},
200};
201
202static XrmQuark qCardinal, qInt, qString, qWidget, qFloat;
203
204static CallbackArgs **input_list;
205static Cardinal num_input_list, size_input_list;
206
207/*
208 * Implementation
209 */
210int
211xtLoadModule(void)
212{
213    int i;
214    char *fname = "XT-LOAD-MODULE";
215
216    xtAppContext_t = LispRegisterOpaqueType("XtAppContext");
217    xtWidget_t = LispRegisterOpaqueType("Widget");
218    xtWidgetClass_t = LispRegisterOpaqueType("WidgetClass");
219    xtWidgetList_t = LispRegisterOpaqueType("WidgetList");
220    xtInputId_t = LispRegisterOpaqueType("XtInputId");
221    xtDisplay_t = LispRegisterOpaqueType("Display*");
222    xtScreen_t = LispRegisterOpaqueType("Screen*");
223    xtWindow_t = LispRegisterOpaqueType("Window");
224
225    LispExecute("(DEFSTRUCT XT-WIDGET-LIST NUM-CHILDREN CHILDREN)\n");
226
227    GCDisable();
228    (void)LispSetVariable(ATOM2("CORE-WIDGET-CLASS"),
229			  OPAQUE(coreWidgetClass, xtWidgetClass_t),
230			  fname, 0);
231    (void)LispSetVariable(ATOM2("COMPOSITE-WIDGET-CLASS"),
232			  OPAQUE(compositeWidgetClass, xtWidgetClass_t),
233			  fname, 0);
234    (void)LispSetVariable(ATOM2("CONSTRAINT-WIDGET-CLASS"),
235			  OPAQUE(constraintWidgetClass, xtWidgetClass_t),
236			  fname, 0);
237    (void)LispSetVariable(ATOM2("TRANSIENT-SHELL-WIDGET-CLASS"),
238			  OPAQUE(transientShellWidgetClass, xtWidgetClass_t),
239			  fname, 0);
240
241    /* parameters for XtPopup */
242    (void)LispSetVariable(ATOM2("XT-GRAB-EXCLUSIVE"),
243			  INTEGER(XtGrabExclusive), fname, 0);
244    (void)LispSetVariable(ATOM2("XT-GRAB-NONE"),
245			  INTEGER(XtGrabNone), fname, 0);
246    (void)LispSetVariable(ATOM2("XT-GRAB-NONE-EXCLUSIVE"),
247			  INTEGER(XtGrabNonexclusive), fname, 0);
248
249    /* parameters for XtAppProcessEvent */
250    (void)LispSetVariable(ATOM2("XT-IM-XEVENT"),
251			  INTEGER(XtIMXEvent), fname, 0);
252    (void)LispSetVariable(ATOM2("XT-IM-TIMER"),
253			  INTEGER(XtIMTimer), fname, 0);
254    (void)LispSetVariable(ATOM2("XT-IM-ALTERNATE-INPUT"),
255			  INTEGER(XtIMAlternateInput), fname, 0);
256    (void)LispSetVariable(ATOM2("XT-IM-SIGNAL"),
257			  INTEGER(XtIMSignal), fname, 0);
258    (void)LispSetVariable(ATOM2("XT-IM-ALL"),
259			  INTEGER(XtIMAll), fname, 0);
260
261    /* parameters for XtAppAddInput */
262    (void)LispSetVariable(ATOM2("XT-INPUT-READ-MASK"),
263			  INTEGER(XtInputReadMask), fname, 0);
264    (void)LispSetVariable(ATOM2("XT-INPUT-WRITE-MASK"),
265			  INTEGER(XtInputWriteMask), fname, 0);
266    (void)LispSetVariable(ATOM2("XT-INPUT-EXCEPT-MASK"),
267			  INTEGER(XtInputExceptMask), fname, 0);
268    GCEnable();
269
270    qCardinal = XrmPermStringToQuark(XtRCardinal);
271    qInt = XrmPermStringToQuark(XtRInt);
272    qString = XrmPermStringToQuark(XtRString);
273    qWidget = XrmPermStringToQuark(XtRWidget);
274    qFloat = XrmPermStringToQuark(XtRFloat);
275
276    for (i = 0; i < sizeof(lispbuiltins) / sizeof(lispbuiltins[0]); i++)
277	LispAddBuiltinFunction(&lispbuiltins[i]);
278
279    return (1);
280}
281
282void
283LispXtCallback(Widget w, XtPointer user_data, XtPointer call_data)
284{
285    CallbackArgs *args = (CallbackArgs*)user_data;
286    LispObj *code, *ocod = COD;
287
288    GCDisable();
289		/* callback name */	   /* reall caller */
290    code = CONS(CDR(CDR(args->data)), CONS(OPAQUE(w, xtWidget_t),
291		CONS(CAR(CDR(args->data)), CONS(OPAQUE(call_data, 0), NIL))));
292		     /* user arguments */
293    COD = CONS(code, COD);
294    GCEnable();
295
296    (void)EVAL(code);
297    COD = ocod;
298}
299
300
301void
302LispXtCleanupCallback(Widget w, XtPointer user_data, XtPointer call_data)
303{
304    CallbackArgs *args = (CallbackArgs*)user_data;
305
306    UPROTECT(CAR(args->data), args->data);
307    XtFree((XtPointer)args);
308}
309
310void
311LispXtInputCallback(XtPointer closure, int *source, XtInputId *id)
312{
313    CallbackArgs *args = (CallbackArgs*)closure;
314    LispObj *code, *ocod = COD;
315
316    GCDisable();
317		/* callback name */	  /* user arguments */
318    code = CONS(CDR(CDR(args->data)), CONS(CAR(CDR(args->data)),
319		CONS(INTEGER(*source), CONS(CAR(args->data), NIL))));
320		     /* input source */	   /* input id */
321    COD = CONS(code, COD);
322    GCEnable();
323
324    (void)EVAL(code);
325    COD = ocod;
326}
327
328LispObj *
329Lisp_XtCoerceToWidgetList(LispBuiltin *builtin)
330/*
331 xt-coerce-to-widget-list number opaque
332 */
333{
334    int i;
335    WidgetList children;
336    Cardinal num_children;
337    LispObj *cons, *widget_list, *result;
338
339    LispObj *onumber, *opaque;
340
341    opaque = ARGUMENT(1);
342    onumber = ARGUMENT(0);
343
344    CHECK_INDEX(onumber);
345    num_children = FIXNUM_VALUE(onumber);
346
347    if (!CHECKO(opaque, xtWidgetList_t))
348	LispDestroy("%s: cannot convert %s to WidgetList",
349		    STRFUN(builtin), STROBJ(opaque));
350    children = (WidgetList)(opaque->data.opaque.data);
351
352    GCDisable();
353    widget_list = cons = NIL;
354    for (i = 0; i < num_children; i++) {
355	result = CONS(OPAQUE(children[i], xtWidget_t), NIL);
356	if (widget_list == NIL)
357	    widget_list = cons = result;
358	else {
359	    RPLACD(cons, result);
360	    cons = CDR(cons);
361	}
362    }
363
364    result = APPLY(ATOM("MAKE-XT-WIDGET-LIST"),
365		   CONS(KEYWORD("NUM-CHILDREN"),
366			CONS(INTEGER(num_children),
367			     CONS(KEYWORD("CHILDREN"),
368				  CONS(widget_list, NIL)))));
369    GCEnable();
370
371    return (result);
372}
373
374LispObj *
375Lisp_XtAddCallback(LispBuiltin *builtin)
376/*
377 xt-add-callback widget callback-name callback &optional client-data
378 */
379{
380    CallbackArgs *arguments;
381    LispObj *data;
382
383    LispObj *widget, *callback_name, *callback, *client_data;
384
385    client_data = ARGUMENT(3);
386    callback = ARGUMENT(2);
387    callback_name = ARGUMENT(1);
388    widget = ARGUMENT(0);
389
390    if (!CHECKO(widget, xtWidget_t))
391	LispDestroy("%s: cannot convert %s to Widget",
392		    STRFUN(builtin), STROBJ(widget));
393
394    CHECK_STRING(callback_name);
395    if (!SYMBOLP(callback) && callback->type != LispLambda_t)
396	LispDestroy("%s: %s cannot be used as a callback",
397		    STRFUN(builtin), STROBJ(callback));
398
399    if (client_data == UNSPEC)
400	client_data = NIL;
401
402    data = CONS(widget, CONS(client_data, callback));
403    PROTECT(widget, data);
404
405    arguments = XtNew(CallbackArgs);
406    arguments->data = data;
407
408    XtAddCallback((Widget)(widget->data.opaque.data), THESTR(callback_name),
409		  LispXtCallback, (XtPointer)arguments);
410    XtAddCallback((Widget)(widget->data.opaque.data), XtNdestroyCallback,
411		  LispXtCleanupCallback, (XtPointer)arguments);
412
413    return (client_data);
414}
415
416LispObj *
417Lisp_XtAppAddInput(LispBuiltin *builtin)
418/*
419  xt-app-add-input app-context fileno condition function &optional client-data
420 */
421{
422    LispObj *data, *input;
423    XtAppContext appcon;
424    int source, condition;
425    CallbackArgs *arguments;
426    XtInputId id;
427
428    LispObj *app_context, *fileno, *ocondition, *function, *client_data;
429
430    client_data = ARGUMENT(4);
431    function = ARGUMENT(3);
432    ocondition = ARGUMENT(2);
433    fileno = ARGUMENT(1);
434    app_context = ARGUMENT(0);
435
436    if (!CHECKO(app_context, xtAppContext_t))
437	LispDestroy("%s: cannot convert %s to XtAppContext",
438		    STRFUN(builtin), STROBJ(app_context));
439    appcon = (XtAppContext)(app_context->data.opaque.data);
440
441    CHECK_LONGINT(fileno);
442    source = LONGINT_VALUE(fileno);
443
444    CHECK_FIXNUM(ocondition);
445    condition = FIXNUM_VALUE(ocondition);
446
447    if (!SYMBOLP(function) && function->type != LispLambda_t)
448	LispDestroy("%s: %s cannot be used as a callback",
449		    STRFUN(builtin), STROBJ(function));
450
451    /* client data optional */
452    if (client_data == UNSPEC)
453	client_data = NIL;
454
455    data = CONS(NIL, CONS(client_data, function));
456
457    arguments = XtNew(CallbackArgs);
458    arguments->data = data;
459
460    id = XtAppAddInput(appcon, source, (XtPointer)condition,
461		       LispXtInputCallback, (XtPointer)arguments);
462    GCDisable();
463    input = OPAQUE(id, xtInputId_t);
464    GCEnable();
465    RPLACA(data, input);
466    PROTECT(input, data);
467
468    if (num_input_list + 1 >= size_input_list) {
469	++size_input_list;
470	input_list = (CallbackArgs**)
471	    XtRealloc((XtPointer)input_list,
472		      sizeof(CallbackArgs*) * size_input_list);
473    }
474    input_list[num_input_list++] = arguments;
475
476    return (input);
477}
478
479LispObj *
480Lisp_XtRemoveInput(LispBuiltin *builtin)
481/*
482 xt-remove-input input
483 */
484{
485    int i;
486    XtInputId id;
487    CallbackArgs *args;
488
489    LispObj *input;
490
491    input = ARGUMENT(0);
492
493    if (!CHECKO(input, xtInputId_t))
494	LispDestroy("%s: cannot convert %s to XtInputId",
495		    STRFUN(builtin), STROBJ(input));
496
497    id = (XtInputId)(input->data.opaque.data);
498    for (i = 0; i < num_input_list; i++) {
499	args = input_list[i];
500	if (id == (XtInputId)(CAR(args->data)->data.opaque.data)) {
501	    UPROTECT(CAR(args->data), args->data);
502	    XtFree((XtPointer)args);
503
504	    if (i + 1 < num_input_list)
505		memmove(input_list + i, input_list + i + 1,
506			sizeof(CallbackArgs*) * (num_input_list - i - 1));
507	    --num_input_list;
508
509	    XtRemoveInput(id);
510
511	    return (T);
512	}
513    }
514
515    return (NIL);
516}
517
518LispObj *
519Lisp_XtAppInitialize(LispBuiltin *builtin)
520/*
521 xt-app-initialize app-context-return application-class &optional options fallback-resources
522 */
523{
524    XtAppContext appcon;
525    Widget shell;
526    int zero = 0;
527    Resources *resources = NULL;
528    String *fallback = NULL;
529
530    LispObj *app_context_return, *application_class,
531	    *options, *fallback_resources;
532
533    fallback_resources = ARGUMENT(3);
534    options = ARGUMENT(2);
535    application_class = ARGUMENT(1);
536    app_context_return = ARGUMENT(0);
537
538    CHECK_SYMBOL(app_context_return);
539    CHECK_STRING(application_class);
540    CHECK_LIST(options);
541
542    /* check fallback resources, if given */
543    if (fallback_resources != UNSPEC) {
544	LispObj *string;
545	int count;
546
547	CHECK_CONS(fallback_resources);
548	for (string = fallback_resources, count = 0; CONSP(string);
549	     string = CDR(string), count++)
550	    CHECK_STRING(CAR(string));
551
552	/* fallback resources was correctly specified */
553	fallback = LispMalloc(sizeof(String) * (count + 1));
554	for (string = fallback_resources, count = 0; CONSP(string);
555	     string = CDR(string), count++)
556	    fallback[count] = THESTR(CAR(string));
557	fallback[count] = NULL;
558    }
559
560    shell = XtAppInitialize(&appcon, THESTR(application_class), NULL,
561			    0, &zero, NULL, fallback, NULL, 0);
562    if (fallback)
563	LispFree(fallback);
564    (void)LispSetVariable(app_context_return,
565			  OPAQUE(appcon, xtAppContext_t),
566			  STRFUN(builtin), 0);
567
568    XtAppAddActions(appcon, actions, XtNumber(actions));
569
570    if (options != UNSPEC) {
571	resources = LispConvertResources(options, shell,
572					 GetResourceList(XtClass(shell)),
573					 NULL);
574	if (resources) {
575	    XtSetValues(shell, resources->args, resources->num_args);
576	    LispFreeResources(resources);
577	}
578    }
579
580    return (OPAQUE(shell, xtWidget_t));
581}
582
583LispObj *
584Lisp_XtAppMainLoop(LispBuiltin *builtin)
585/*
586 xt-app-main-loop app-context
587 */
588{
589    LispObj *app_context;
590
591    app_context = ARGUMENT(0);
592
593    if (!CHECKO(app_context, xtAppContext_t))
594	LispDestroy("%s: cannot convert %s to XtAppContext",
595		    STRFUN(builtin), STROBJ(app_context));
596
597    XtAppMainLoop((XtAppContext)(app_context->data.opaque.data));
598
599    return (NIL);
600}
601
602LispObj *
603Lisp_XtAppPending(LispBuiltin *builtin)
604/*
605 xt-app-pending app-context
606 */
607{
608    LispObj *app_context;
609
610    app_context = ARGUMENT(0);
611
612    if (!CHECKO(app_context, xtAppContext_t))
613	LispDestroy("%s: cannot convert %s to XtAppContext",
614		    STRFUN(builtin), STROBJ(app_context));
615
616    return (INTEGER(
617	    XtAppPending((XtAppContext)(app_context->data.opaque.data))));
618}
619
620LispObj *
621Lisp_XtAppProcessEvent(LispBuiltin *builtin)
622/*
623 xt-app-process-event app-context &optional mask
624 */
625{
626    XtInputMask mask;
627    XtAppContext appcon;
628
629    LispObj *app_context, *omask;
630
631    omask = ARGUMENT(1);
632    app_context = ARGUMENT(0);
633
634    if (!CHECKO(app_context, xtAppContext_t))
635	LispDestroy("%s: cannot convert %s to XtAppContext",
636		    STRFUN(builtin), STROBJ(app_context));
637
638    appcon = (XtAppContext)(app_context->data.opaque.data);
639    if (omask == UNSPEC)
640	mask = XtIMAll;
641    else {
642	CHECK_FIXNUM(omask);
643	mask = FIXNUM_VALUE(omask);
644    }
645
646    if (mask != (mask & XtIMAll))
647	LispDestroy("%s: %ld does not fit in XtInputMask %ld",
648		    STRFUN(builtin), (long)mask, (long)XtIMAll);
649
650    if (mask)
651	XtAppProcessEvent(appcon, mask);
652
653    return (omask == NIL ? FIXNUM(mask) : omask);
654}
655
656LispObj *
657Lisp_XtRealizeWidget(LispBuiltin *builtin)
658/*
659 xt-realize-widget widget
660 */
661{
662    Widget widget;
663
664    LispObj *owidget;
665
666    owidget = ARGUMENT(0);
667
668    if (!CHECKO(owidget, xtWidget_t))
669	LispDestroy("%s: cannot convert %s to Widget",
670		    STRFUN(builtin), STROBJ(owidget));
671    widget = (Widget)(owidget->data.opaque.data);
672    XtRealizeWidget(widget);
673
674    if (XtIsSubclass(widget, shellWidgetClass)) {
675	if (!delete_window)
676	    delete_window = XInternAtom(XtDisplay(widget),
677					"WM_DELETE_WINDOW", False);
678	(void)XSetWMProtocols(XtDisplay(widget), XtWindow(widget),
679			      &delete_window, 1);
680    }
681
682    return (owidget);
683}
684
685LispObj *
686Lisp_XtUnrealizeWidget(LispBuiltin *builtin)
687/*
688 xt-unrealize-widget widget
689 */
690{
691    LispObj *widget;
692
693    widget = ARGUMENT(0);
694
695    if (!CHECKO(widget, xtWidget_t))
696	LispDestroy("%s: cannot convert %s to Widget",
697		    STRFUN(builtin), STROBJ(widget));
698
699    XtUnrealizeWidget((Widget)(widget->data.opaque.data));
700
701    return (widget);
702}
703
704LispObj *
705Lisp_XtIsRealized(LispBuiltin *builtin)
706/*
707 xt-is-realized widget
708 */
709{
710    LispObj *widget;
711
712    widget = ARGUMENT(0);
713
714    if (!CHECKO(widget, xtWidget_t))
715	LispDestroy("%s: cannot convert %s to Widget",
716		    STRFUN(builtin), STROBJ(widget));
717
718    return (XtIsRealized((Widget)(widget->data.opaque.data)) ? T : NIL);
719}
720
721LispObj *
722Lisp_XtDestroyWidget(LispBuiltin *builtin)
723/*
724 xt-destroy-widget widget
725 */
726{
727    LispObj *widget;
728
729    widget = ARGUMENT(0);
730
731    if (!CHECKO(widget, xtWidget_t))
732	LispDestroy("%s: cannot convert %s to Widget",
733		    STRFUN(builtin), STROBJ(widget));
734
735    XtDestroyWidget((Widget)(widget->data.opaque.data));
736
737    return (NIL);
738}
739
740#define UNMANAGED	0
741#define MANAGED		1
742#define SHELL		2
743LispObj *
744Lisp_XtCreateWidget(LispBuiltin *builtin)
745/*
746 xt-create-widget name widget-class parent &optional arguments
747 */
748{
749    return (LispXtCreateWidget(builtin, UNMANAGED));
750}
751
752LispObj *
753Lisp_XtCreateManagedWidget(LispBuiltin *builtin)
754/*
755 xt-create-managed-widget name widget-class parent &optional arguments
756 */
757{
758    return (LispXtCreateWidget(builtin, MANAGED));
759}
760
761LispObj *
762Lisp_XtCreatePopupShell(LispBuiltin *builtin)
763/*
764 xt-create-popup-shell name widget-class parent &optional arguments
765 */
766{
767    return (LispXtCreateWidget(builtin, SHELL));
768}
769
770LispObj *
771LispXtCreateWidget(LispBuiltin *builtin, int options)
772/*
773 xt-create-widget name widget-class parent &optional arguments
774 xt-create-managed-widget name widget-class parent &optional arguments
775 xt-create-popup-shell name widget-class parent &optional arguments
776 */
777{
778    char *name;
779    WidgetClass widget_class;
780    Widget widget, parent;
781    Resources *resources = NULL;
782
783    LispObj *oname, *owidget_class, *oparent, *arguments;
784
785    arguments = ARGUMENT(3);
786    oparent = ARGUMENT(2);
787    owidget_class = ARGUMENT(1);
788    oname = ARGUMENT(0);
789
790    CHECK_STRING(oname);
791    name = THESTR(oname);
792
793    if (!CHECKO(owidget_class, xtWidgetClass_t))
794	LispDestroy("%s: cannot convert %s to WidgetClass",
795		    STRFUN(builtin), STROBJ(owidget_class));
796    widget_class = (WidgetClass)(owidget_class->data.opaque.data);
797
798    if (!CHECKO(oparent, xtWidget_t))
799	LispDestroy("%s: cannot convert %s to Widget",
800		    STRFUN(builtin), STROBJ(oparent));
801    parent = (Widget)(oparent->data.opaque.data);
802
803    if (arguments == UNSPEC)
804	arguments = NIL;
805    CHECK_LIST(arguments);
806
807    if (options == SHELL)
808	widget = XtCreatePopupShell(name, widget_class, parent, NULL, 0);
809    else
810	widget = XtCreateWidget(name, widget_class, parent, NULL, 0);
811
812    if (arguments == NIL)
813	resources = NULL;
814    else {
815	resources = LispConvertResources(arguments, widget,
816					 GetResourceList(widget_class),
817					 GetResourceList(XtClass(parent)));
818	XtSetValues(widget, resources->args, resources->num_args);
819    }
820    if (options == MANAGED)
821	XtManageChild(widget);
822    if (resources)
823	LispFreeResources(resources);
824
825    return (OPAQUE(widget, xtWidget_t));
826}
827
828LispObj *
829Lisp_XtGetKeyboardFocusWidget(LispBuiltin *builtin)
830/*
831 xt-get-keyboard-focus-widget widget
832 */
833{
834    LispObj *widget;
835
836    widget = ARGUMENT(0);
837
838    if (!CHECKO(widget, xtWidget_t))
839	LispDestroy("%s: cannot convert %s to Widget",
840		    STRFUN(builtin), STROBJ(widget));
841    return (OPAQUE(XtGetKeyboardFocusWidget((Widget)(widget->data.opaque.data)),
842		   xtWidget_t));
843}
844
845LispObj *
846Lisp_XtGetValues(LispBuiltin *builtin)
847/*
848 xt-get-values widget arguments
849 */
850{
851    Arg args[1];
852    Widget widget;
853    ResourceList *rlist, *plist;
854    ResourceInfo *resource;
855    LispObj *list, *object = NIL, *result, *cons = NIL;
856    char c1;
857    short c2;
858    int c4;
859#ifdef LONG64
860    long c8;
861#endif
862
863    LispObj *owidget, *arguments;
864
865    arguments = ARGUMENT(1);
866    owidget = ARGUMENT(0);
867
868    if (arguments == NIL)
869	return (NIL);
870
871    if (!CHECKO(owidget, xtWidget_t))
872	LispDestroy("%s: cannot convert %s to Widget",
873		    STRFUN(builtin), STROBJ(owidget));
874    widget = (Widget)(owidget->data.opaque.data);
875    CHECK_CONS(arguments);
876
877    rlist = GetResourceList(XtClass(widget));
878    plist =  XtParent(widget) ?
879	     GetResourceList(XtClass(XtParent(widget))) : NULL;
880
881    GCDisable();
882    result = NIL;
883    for (list = arguments; CONSP(list); list = CDR(list)) {
884	CHECK_STRING(CAR(list));
885	if ((resource = GetResourceInfo(THESTR(CAR(list)), rlist, plist))
886	     == NULL) {
887	    int i;
888	    Widget child;
889
890	    for (i = 0; i < rlist->num_resources; i++) {
891		if (rlist->resources[i]->qtype == qWidget) {
892		    XtSetArg(args[0],
893			     XrmQuarkToString(rlist->resources[i]->qname),
894			     &child);
895		    XtGetValues(widget, args, 1);
896		    if (child && XtParent(child) == widget) {
897			resource =
898			    GetResourceInfo(THESTR(CAR(list)),
899					    GetResourceList(XtClass(child)),
900					    NULL);
901			if (resource)
902			    break;
903		    }
904		}
905	    }
906	    if (resource == NULL) {
907		LispMessage("%s: resource %s not available",
908			    STRFUN(builtin), THESTR(CAR(list)));
909		continue;
910	    }
911	}
912	switch (resource->size) {
913	    case 1:
914		XtSetArg(args[0], THESTR(CAR(list)), &c1);
915		break;
916	    case 2:
917		XtSetArg(args[0], THESTR(CAR(list)), &c2);
918		break;
919	    case 4:
920		XtSetArg(args[0], THESTR(CAR(list)), &c4);
921		break;
922#ifdef LONG64
923	    case 1:
924		XtSetArg(args[0], THESTR(CAR(list)), &c8);
925		break;
926#endif
927	}
928	XtGetValues(widget, args, 1);
929
930	/* special resources */
931	if (resource->qtype == qString) {
932#ifdef LONG64
933	    object = CONS(CAR(list), STRING((char*)c8));
934#else
935	    object = CONS(CAR(list), STRING((char*)c4));
936#endif
937	}
938	else if (resource->qtype == qCardinal || resource->qtype == qInt) {
939#ifdef LONG64
940	    if (sizeof(int) == 8)
941		object = CONS(CAR(list), INTEGER(c8));
942	    else
943#endif
944	    object = CONS(CAR(list), INTEGER(c4));
945	}
946	else {
947	    switch (resource->size) {
948		case 1:
949		    object = CONS(CAR(list), OPAQUE(c1, 0));
950		    break;
951		case 2:
952		    object = CONS(CAR(list), OPAQUE(c2, 0));
953		    break;
954		case 4:
955		    object = CONS(CAR(list), OPAQUE(c4, 0));
956		    break;
957#ifdef LONG64
958		case 8:
959		    object = CONS(CAR(list), OPAQUE(c8, 0));
960		    break;
961#endif
962	    }
963	}
964
965	if (result == NIL)
966	    result = cons = CONS(object, NIL);
967	else {
968	    RPLACD(cons, CONS(object, NIL));
969	    cons = CDR(cons);
970	}
971    }
972    GCEnable();
973
974    return (result);
975}
976
977LispObj *
978Lisp_XtManageChild(LispBuiltin *builtin)
979/*
980 xt-manage-child widget
981 */
982{
983    LispObj *widget;
984
985    widget = ARGUMENT(0);
986
987    if (!CHECKO(widget, xtWidget_t))
988	LispDestroy("%s: cannot convert %s to Widget",
989		    STRFUN(builtin), STROBJ(widget));
990    XtManageChild((Widget)(widget->data.opaque.data));
991
992    return (widget);
993}
994
995LispObj *
996Lisp_XtUnmanageChild(LispBuiltin *builtin)
997/*
998 xt-unmanage-child widget
999 */
1000{
1001    LispObj *widget;
1002
1003    widget = ARGUMENT(0);
1004
1005    if (!CHECKO(widget, xtWidget_t))
1006	LispDestroy("%s: cannot convert %s to Widget",
1007		    STRFUN(builtin), STROBJ(widget));
1008    XtUnmanageChild((Widget)(widget->data.opaque.data));
1009
1010    return (widget);
1011}
1012
1013LispObj *
1014Lisp_XtMapWidget(LispBuiltin *builtin)
1015/*
1016 xt-map-widget widget
1017 */
1018{
1019    LispObj *widget;
1020
1021    widget = ARGUMENT(0);
1022
1023    if (!CHECKO(widget, xtWidget_t))
1024	LispDestroy("%s: cannot convert %s to Widget",
1025		    STRFUN(builtin), STROBJ(widget));
1026    XtMapWidget((Widget)(widget->data.opaque.data));
1027
1028    return (widget);
1029}
1030
1031LispObj *
1032Lisp_XtUnmapWidget(LispBuiltin *builtin)
1033/*
1034 xt-unmap-widget widget
1035 */
1036{
1037    LispObj *widget;
1038
1039    widget = ARGUMENT(0);
1040
1041    if (!CHECKO(widget, xtWidget_t))
1042	LispDestroy("%s: cannot convert %s to Widget",
1043		    STRFUN(builtin), STROBJ(widget));
1044    XtUnmapWidget((Widget)(widget->data.opaque.data));
1045
1046    return (widget);
1047}
1048
1049LispObj *
1050Lisp_XtSetMappedWhenManaged(LispBuiltin *builtin)
1051/*
1052 xt-set-mapped-when-managed widget map-when-managed
1053 */
1054{
1055    LispObj *widget, *map_when_managed;
1056
1057    map_when_managed = ARGUMENT(1);
1058    widget = ARGUMENT(0);
1059
1060    if (!CHECKO(widget, xtWidget_t))
1061	LispDestroy("%s: cannot convert %s to Widget",
1062		    STRFUN(builtin), STROBJ(widget));
1063
1064    XtSetMappedWhenManaged((Widget)(widget->data.opaque.data),
1065			   map_when_managed != NIL);
1066
1067    return (map_when_managed);
1068}
1069
1070LispObj *
1071Lisp_XtPopup(LispBuiltin *builtin)
1072/*
1073 xt-popup widget grab-kind
1074 */
1075{
1076    XtGrabKind kind;
1077
1078    LispObj *widget, *grab_kind;
1079
1080    grab_kind = ARGUMENT(1);
1081    widget = ARGUMENT(0);
1082
1083    if (!CHECKO(widget, xtWidget_t))
1084	LispDestroy("%s: cannot convert %s to Widget",
1085		    STRFUN(builtin), STROBJ(widget));
1086    CHECK_INDEX(grab_kind);
1087    kind = (XtGrabKind)FIXNUM_VALUE(grab_kind);
1088    if (kind != XtGrabExclusive && kind != XtGrabNone &&
1089	kind != XtGrabNonexclusive)
1090	LispDestroy("%s: %d does not fit in XtGrabKind",
1091		    STRFUN(builtin), kind);
1092    XtPopup((Widget)(widget->data.opaque.data), kind);
1093
1094    return (grab_kind);
1095}
1096
1097LispObj *
1098Lisp_XtPopdown(LispBuiltin *builtin)
1099/*
1100 xt-popdown widget
1101 */
1102{
1103    LispObj *widget;
1104
1105    widget = ARGUMENT(0);
1106
1107    if (!CHECKO(widget, xtWidget_t))
1108	LispDestroy("%s: cannot convert %s to Widget",
1109		    STRFUN(builtin), STROBJ(widget));
1110    XtPopdown((Widget)(widget->data.opaque.data));
1111
1112    return (widget);
1113}
1114
1115LispObj *
1116Lisp_XtSetKeyboardFocus(LispBuiltin *builtin)
1117/*
1118 xt-set-keyboard-focus widget descendant
1119 */
1120{
1121    LispObj *widget, *descendant;
1122
1123    descendant = ARGUMENT(1);
1124    widget = ARGUMENT(0);
1125
1126    if (!CHECKO(widget, xtWidget_t))
1127	LispDestroy("%s: cannot convert %s to Widget",
1128		    STRFUN(builtin), STROBJ(widget));
1129    if (!CHECKO(descendant, xtWidget_t))
1130	LispDestroy("%s: cannot convert %s to Widget",
1131		    STRFUN(builtin), STROBJ(descendant));
1132    XtSetKeyboardFocus((Widget)(widget->data.opaque.data),
1133		       (Widget)(descendant->data.opaque.data));
1134
1135    return (widget);
1136}
1137
1138LispObj *
1139Lisp_XtSetSensitive(LispBuiltin *builtin)
1140/*
1141 xt-set-sensitive widget sensitive
1142 */
1143{
1144    LispObj *widget, *sensitive;
1145
1146    sensitive = ARGUMENT(1);
1147    widget = ARGUMENT(0);
1148
1149    if (!CHECKO(widget, xtWidget_t))
1150	LispDestroy("%s: cannot convert %s to Widget",
1151		    STRFUN(builtin), STROBJ(widget));
1152    XtSetSensitive((Widget)(widget->data.opaque.data), sensitive != NIL);
1153
1154    return (sensitive);
1155}
1156
1157LispObj *
1158Lisp_XtSetValues(LispBuiltin *builtin)
1159/*
1160 xt-set-values widget arguments
1161 */
1162{
1163    Widget widget;
1164    Resources *resources;
1165
1166    LispObj *owidget, *arguments;
1167
1168    arguments = ARGUMENT(1);
1169    owidget = ARGUMENT(0);
1170
1171    if (arguments == NIL)
1172	return (owidget);
1173
1174    if (!CHECKO(owidget, xtWidget_t))
1175	LispDestroy("%s: cannot convert %s to Widget",
1176		    STRFUN(builtin), STROBJ(owidget));
1177    widget = (Widget)(owidget->data.opaque.data);
1178    CHECK_CONS(arguments);
1179    resources = LispConvertResources(arguments, widget,
1180				     GetResourceList(XtClass(widget)),
1181				     XtParent(widget) ?
1182					GetResourceList(XtClass(XtParent(widget))) :
1183					NULL);
1184    XtSetValues(widget, resources->args, resources->num_args);
1185    LispFreeResources(resources);
1186
1187    return (owidget);
1188}
1189
1190LispObj *
1191Lisp_XtWidgetToApplicationContext(LispBuiltin *builtin)
1192/*
1193 xt-widget-to-application-context widget
1194 */
1195{
1196    Widget widget;
1197    XtAppContext appcon;
1198
1199    LispObj *owidget;
1200
1201    owidget = ARGUMENT(0);
1202
1203    if (!CHECKO(owidget, xtWidget_t))
1204	LispDestroy("%s: cannot convert %s to Widget",
1205		    STRFUN(builtin), STROBJ(owidget));
1206    widget = (Widget)(owidget->data.opaque.data);
1207    appcon = XtWidgetToApplicationContext(widget);
1208
1209    return (OPAQUE(appcon, xtAppContext_t));
1210}
1211
1212LispObj *
1213Lisp_XtDisplay(LispBuiltin *builtin)
1214/*
1215 xt-display widget
1216 */
1217{
1218    Widget widget;
1219    Display *display;
1220
1221    LispObj *owidget;
1222
1223    owidget = ARGUMENT(0);
1224
1225    if (!CHECKO(owidget, xtWidget_t))
1226	LispDestroy("%s: cannot convert %s to Widget",
1227		    STRFUN(builtin), STROBJ(owidget));
1228    widget = (Widget)(owidget->data.opaque.data);
1229    display = XtDisplay(widget);
1230
1231    return (OPAQUE(display, xtDisplay_t));
1232}
1233
1234LispObj *
1235Lisp_XtDisplayOfObject(LispBuiltin *builtin)
1236/*
1237 xt-display-of-object object
1238 */
1239{
1240    Widget widget;
1241    Display *display;
1242
1243    LispObj *object;
1244
1245    object = ARGUMENT(0);
1246
1247    if (!CHECKO(object, xtWidget_t))
1248	LispDestroy("%s: cannot convert %s to Widget",
1249		    STRFUN(builtin), STROBJ(object));
1250    widget = (Widget)(object->data.opaque.data);
1251    display = XtDisplayOfObject(widget);
1252
1253    return (OPAQUE(display, xtDisplay_t));
1254}
1255
1256LispObj *
1257Lisp_XtScreen(LispBuiltin *builtin)
1258/*
1259 xt-screen widget
1260 */
1261{
1262    Widget widget;
1263    Screen *screen;
1264
1265    LispObj *owidget;
1266
1267    owidget = ARGUMENT(0);
1268
1269    if (!CHECKO(owidget, xtWidget_t))
1270	LispDestroy("%s: cannot convert %s to Widget",
1271		    STRFUN(builtin), STROBJ(owidget));
1272    widget = (Widget)(owidget->data.opaque.data);
1273    screen = XtScreen(widget);
1274
1275    return (OPAQUE(screen, xtScreen_t));
1276}
1277
1278LispObj *
1279Lisp_XtScreenOfObject(LispBuiltin *builtin)
1280/*
1281 xt-screen-of-object object
1282 */
1283{
1284    Widget widget;
1285    Screen *screen;
1286
1287    LispObj *object;
1288
1289    object = ARGUMENT(0);
1290
1291    if (!CHECKO(object, xtWidget_t))
1292	LispDestroy("%s: cannot convert %s to Widget",
1293		    STRFUN(builtin), STROBJ(object));
1294    widget = (Widget)(object->data.opaque.data);
1295    screen = XtScreenOfObject(widget);
1296
1297    return (OPAQUE(screen, xtScreen_t));
1298}
1299
1300LispObj *
1301Lisp_XtWindow(LispBuiltin *builtin)
1302/*
1303 xt-window widget
1304 */
1305{
1306    Widget widget;
1307    Window window;
1308
1309    LispObj *owidget;
1310
1311    owidget = ARGUMENT(0);
1312
1313    if (!CHECKO(owidget, xtWidget_t))
1314	LispDestroy("%s: cannot convert %s to Widget",
1315		    STRFUN(builtin), STROBJ(owidget));
1316    widget = (Widget)(owidget->data.opaque.data);
1317    window = XtWindow(widget);
1318
1319    return (OPAQUE(window, xtWindow_t));
1320}
1321
1322LispObj *
1323Lisp_XtWindowOfObject(LispBuiltin *builtin)
1324/*
1325 xt-window-of-object widget
1326 */
1327{
1328    Widget widget;
1329    Window window;
1330
1331    LispObj *object;
1332
1333    object = ARGUMENT(0);
1334
1335    if (!CHECKO(object, xtWidget_t))
1336	LispDestroy("%s: cannot convert %s to Widget",
1337		    STRFUN(builtin), STROBJ(object));
1338    widget = (Widget)(object->data.opaque.data);
1339    window = XtWindowOfObject(widget);
1340
1341    return (OPAQUE(window, xtWindow_t));
1342}
1343
1344LispObj *
1345Lisp_XtAddGrab(LispBuiltin *builtin)
1346/*
1347 xt-add-grab widget exclusive spring-loaded
1348 */
1349{
1350    Widget widget;
1351    Bool exclusive, spring_loaded;
1352
1353    LispObj *owidget, *oexclusive, *ospring_loaded;
1354
1355    ospring_loaded = ARGUMENT(2);
1356    oexclusive = ARGUMENT(1);
1357    owidget = ARGUMENT(0);
1358
1359    if (!CHECKO(owidget, xtWidget_t))
1360	LispDestroy("%s: cannot convert %s to Widget",
1361		    STRFUN(builtin), STROBJ(owidget));
1362    widget = (Widget)(owidget->data.opaque.data);
1363    exclusive = oexclusive != NIL;
1364    spring_loaded = ospring_loaded != NIL;
1365
1366    XtAddGrab(widget, exclusive, spring_loaded);
1367
1368    return (T);
1369}
1370
1371LispObj *
1372Lisp_XtRemoveGrab(LispBuiltin *builtin)
1373/*
1374 xt-remove-grab widget
1375 */
1376{
1377    LispObj *widget;
1378
1379    widget = ARGUMENT(0);
1380
1381    if (!CHECKO(widget, xtWidget_t))
1382	LispDestroy("%s: cannot convert %s to Widget",
1383		    STRFUN(builtin), STROBJ(widget));
1384
1385    XtRemoveGrab((Widget)(widget->data.opaque.data));
1386
1387    return (NIL);
1388}
1389
1390LispObj *
1391Lisp_XtName(LispBuiltin *builtin)
1392/*
1393 xt-name widget
1394 */
1395{
1396    LispObj *widget;
1397
1398    widget = ARGUMENT(0);
1399
1400    if (!CHECKO(widget, xtWidget_t))
1401	LispDestroy("%s: cannot convert %s to Widget",
1402		    STRFUN(builtin), STROBJ(widget));
1403
1404    return (STRING(XtName((Widget)(widget->data.opaque.data))));
1405}
1406
1407LispObj *
1408Lisp_XtParent(LispBuiltin *builtin)
1409/*
1410 xt-parent widget
1411 */
1412{
1413    LispObj *widget;
1414
1415    widget = ARGUMENT(0);
1416
1417    if (!CHECKO(widget, xtWidget_t))
1418	LispDestroy("%s: cannot convert %s to Widget",
1419		    STRFUN(builtin), STROBJ(widget));
1420
1421    return (OPAQUE(XtParent((Widget)widget->data.opaque.data), xtWidget_t));
1422}
1423
1424LispObj *
1425Lisp_XtAppGetExitFlag(LispBuiltin *builtin)
1426/*
1427 xt-app-get-exit-flag app-context
1428 */
1429{
1430    LispObj *app_context;
1431
1432    app_context = ARGUMENT(0);
1433
1434    if (!CHECKO(app_context, xtAppContext_t))
1435	LispDestroy("%s: cannot convert %s to XtAppContext",
1436		    STRFUN(builtin), STROBJ(app_context));
1437
1438    return (XtAppGetExitFlag((XtAppContext)(app_context->data.opaque.data)) ?
1439	    T : NIL);
1440}
1441
1442LispObj *
1443Lisp_XtAppSetExitFlag(LispBuiltin *builtin)
1444/*
1445 xt-app-get-exit-flag app-context
1446 */
1447{
1448    LispObj *app_context;
1449
1450    app_context = ARGUMENT(0);
1451
1452    if (!CHECKO(app_context, xtAppContext_t))
1453	LispDestroy("%s: cannot convert %s to XtAppContext",
1454		    STRFUN(builtin), STROBJ(app_context));
1455
1456    XtAppSetExitFlag((XtAppContext)(app_context->data.opaque.data));
1457
1458    return (T);
1459}
1460
1461static Resources *
1462LispConvertResources(LispObj *list, Widget widget,
1463		     ResourceList *rlist, ResourceList *plist)
1464{
1465    char c1;
1466    short c2;
1467    int c4;
1468#ifdef LONG64
1469    long c8;
1470#endif
1471    XrmValue from, to;
1472    LispObj *arg, *val;
1473    ResourceInfo *resource;
1474    char *fname = "XT-CONVERT-RESOURCES";
1475    Resources *resources = (Resources*)XtCalloc(1, sizeof(Resources));
1476
1477    for (; CONSP(list); list = CDR(list)) {
1478	if (!CONSP(CAR(list))) {
1479	    XtFree((XtPointer)resources);
1480	    LispDestroy("%s: %s is not a cons", fname, STROBJ(CAR(list)));
1481	}
1482	arg = CAR(CAR(list));
1483	val = CDR(CAR(list));
1484
1485	if (!STRINGP(arg)) {
1486	    XtFree((XtPointer)resources);
1487	    LispDestroy("%s: %s is not a string", fname, STROBJ(arg));
1488	}
1489
1490	if ((resource = GetResourceInfo(THESTR(arg), rlist, plist)) == NULL) {
1491	    int i;
1492	    Arg args[1];
1493	    Widget child;
1494
1495	    for (i = 0; i < rlist->num_resources; i++) {
1496		if (rlist->resources[i]->qtype == qWidget) {
1497		    XtSetArg(args[0],
1498			     XrmQuarkToString(rlist->resources[i]->qname),
1499			     &child);
1500		    XtGetValues(widget, args, 1);
1501		    if (child && XtParent(child) == widget) {
1502			resource =
1503			    GetResourceInfo(THESTR(arg),
1504					    GetResourceList(XtClass(child)),
1505					    NULL);
1506			if (resource)
1507			    break;
1508		    }
1509		}
1510	    }
1511	    if (resource == NULL) {
1512		LispMessage("%s: resource %s not available",
1513			    fname, THESTR(arg));
1514		continue;
1515	    }
1516	}
1517
1518	if (LONGINTP(val) || DFLOATP(val) || OPAQUEP(val)) {
1519	    resources->args = (Arg*)
1520		XtRealloc((XtPointer)resources->args,
1521			  sizeof(Arg) * (resources->num_args + 1));
1522	    if (!OPAQUEP(val)) {
1523		float fvalue;
1524
1525		if (DFLOATP(val))
1526		    fvalue = DFLOAT_VALUE(val);
1527		else
1528		    fvalue = LONGINT_VALUE(val);
1529		if (resource->qtype == qFloat) {
1530		    XtSetArg(resources->args[resources->num_args],
1531			     XrmQuarkToString(resource->qname), fvalue);
1532		}
1533		else
1534		    XtSetArg(resources->args[resources->num_args],
1535			     XrmQuarkToString(resource->qname),
1536			     (int)fvalue);
1537	    }
1538	    else
1539		XtSetArg(resources->args[resources->num_args],
1540			 XrmQuarkToString(resource->qname), val->data.opaque.data);
1541	    ++resources->num_args;
1542	    continue;
1543	}
1544	else if (val == NIL) {
1545	    /* XXX assume it is a pointer or a boolean */
1546#ifdef DEBUG
1547	    LispWarning("%s: assuming %s is a pointer or boolean",
1548			fname, XrmQuarkToString(resource->qname));
1549#endif
1550	    resources->args = (Arg*)
1551		XtRealloc((XtPointer)resources->args,
1552			  sizeof(Arg) * (resources->num_args + 1));
1553	    XtSetArg(resources->args[resources->num_args],
1554		     XrmQuarkToString(resource->qname), NULL);
1555	    ++resources->num_args;
1556	    continue;
1557	}
1558	else if (val == T) {
1559	    /* XXX assume it is a boolean */
1560#ifdef DEBUG
1561	    LispWarning("%s: assuming %s is a boolean",
1562			fname, XrmQuarkToString(resource->qname));
1563#endif
1564	    resources->args = (Arg*)
1565		XtRealloc((XtPointer)resources->args,
1566			  sizeof(Arg) * (resources->num_args + 1));
1567	    XtSetArg(resources->args[resources->num_args],
1568		     XrmQuarkToString(resource->qname), True);
1569	    ++resources->num_args;
1570	    continue;
1571	}
1572	else if (!STRINGP(val)) {
1573	    XtFree((XtPointer)resources);
1574	    LispDestroy("%s: resource value must be string, number or opaque, not %s",
1575			fname, STROBJ(val));
1576	}
1577
1578	from.size = val == NIL ? 1 : strlen(THESTR(val)) + 1;
1579	from.addr = val == NIL ? "" : THESTR(val);
1580	switch (to.size = resource->size) {
1581	    case 1:
1582		to.addr = (XtPointer)&c1;
1583		break;
1584	    case 2:
1585		to.addr = (XtPointer)&c2;
1586		break;
1587	    case 4:
1588		to.addr = (XtPointer)&c4;
1589		break;
1590#ifdef LONG64
1591	    case 8:
1592		to.addr = (XtPointer)&c8;
1593		break;
1594#endif
1595	    default:
1596		LispWarning("%s: bad resource size %d for %s",
1597			    fname, to.size, THESTR(arg));
1598		continue;
1599	}
1600
1601	if (qString == resource->qtype)
1602#ifdef LONG64
1603	    c8 = (long)from.addr;
1604#else
1605	    c4 = (long)from.addr;
1606#endif
1607	else if (!XtConvertAndStore(widget, XtRString, &from,
1608				    XrmQuarkToString(resource->qtype), &to))
1609	    /* The type converter already have printed an error message */
1610	    continue;
1611
1612	resources->args = (Arg*)
1613	    XtRealloc((XtPointer)resources->args,
1614		      sizeof(Arg) * (resources->num_args + 1));
1615	switch (to.size) {
1616	    case 1:
1617		XtSetArg(resources->args[resources->num_args],
1618			 XrmQuarkToString(resource->qname), c1);
1619		break;
1620	    case 2:
1621		XtSetArg(resources->args[resources->num_args],
1622			 XrmQuarkToString(resource->qname), c2);
1623		break;
1624	    case 4:
1625		XtSetArg(resources->args[resources->num_args],
1626			 XrmQuarkToString(resource->qname), c4);
1627		break;
1628#ifdef LONG64
1629	    case 8:
1630		XtSetArg(resources->args[resources->num_args],
1631			 XrmQuarkToString(resource->qname), c8);
1632		break;
1633#endif
1634	}
1635	++resources->num_args;
1636    }
1637
1638    return (resources);
1639}
1640
1641static void
1642LispFreeResources(Resources *resources)
1643{
1644    if (resources) {
1645	XtFree((XtPointer)resources->args);
1646	XtFree((XtPointer)resources);
1647    }
1648}
1649
1650static int
1651bcmp_action_resource(_Xconst void *string, _Xconst void *resource)
1652{
1653    return (strcmp((String)string,
1654		   XrmQuarkToString((*(ResourceInfo**)resource)->qname)));
1655}
1656
1657static ResourceInfo *
1658GetResourceInfo(char *name, ResourceList *rlist, ResourceList *plist)
1659{
1660    ResourceInfo **resource = NULL;
1661
1662    if (rlist->resources)
1663	resource = (ResourceInfo**)
1664	    bsearch(name, rlist->resources, rlist->num_resources,
1665		    sizeof(ResourceInfo*), bcmp_action_resource);
1666
1667    if (resource == NULL && plist) {
1668	resource = (ResourceInfo**)
1669	  bsearch(name, &plist->resources[plist->num_resources],
1670		  plist->num_cons_resources, sizeof(ResourceInfo*),
1671		  bcmp_action_resource);
1672    }
1673
1674    return (resource ? *resource : NULL);
1675}
1676
1677static ResourceList *
1678GetResourceList(WidgetClass wc)
1679{
1680    ResourceList *list;
1681
1682    if ((list = FindResourceList(wc)) == NULL)
1683	list = CreateResourceList(wc);
1684
1685    return (list);
1686}
1687
1688static int
1689bcmp_action_resource_list(_Xconst void *wc, _Xconst void *list)
1690{
1691    return ((char*)wc - (char*)((*(ResourceList**)list)->widget_class));
1692}
1693
1694static ResourceList *
1695FindResourceList(WidgetClass wc)
1696{
1697    ResourceList **list;
1698
1699    if (!resource_list)
1700	return (NULL);
1701
1702    list = (ResourceList**)
1703	bsearch(wc, resource_list, num_resource_list,
1704		sizeof(ResourceList*),  bcmp_action_resource_list);
1705
1706    return (list ? *list : NULL);
1707}
1708
1709static int
1710qcmp_action_resource_list(_Xconst void *left, _Xconst void *right)
1711{
1712    return ((char*)((*(ResourceList**)left)->widget_class) -
1713	    (char*)((*(ResourceList**)right)->widget_class));
1714}
1715
1716static ResourceList *
1717CreateResourceList(WidgetClass wc)
1718{
1719    ResourceList *list;
1720
1721    list = (ResourceList*)XtMalloc(sizeof(ResourceList));
1722    list->widget_class = wc;
1723    list->num_resources = list->num_cons_resources = 0;
1724    list->resources = NULL;
1725
1726    resource_list = (ResourceList**)
1727	XtRealloc((XtPointer)resource_list, sizeof(ResourceList*) *
1728		  (num_resource_list + 1));
1729    resource_list[num_resource_list++] = list;
1730    qsort(resource_list, num_resource_list, sizeof(ResourceList*),
1731	  qcmp_action_resource_list);
1732    BindResourceList(list);
1733
1734    return (list);
1735}
1736
1737static int
1738qcmp_action_resource(_Xconst void *left, _Xconst void *right)
1739{
1740    return (strcmp(XrmQuarkToString((*(ResourceInfo**)left)->qname),
1741		   XrmQuarkToString((*(ResourceInfo**)right)->qname)));
1742}
1743
1744static void
1745BindResourceList(ResourceList *list)
1746{
1747    XtResourceList xt_list, cons_list;
1748    Cardinal i, num_xt, num_cons;
1749
1750    XtGetResourceList(list->widget_class, &xt_list, &num_xt);
1751    XtGetConstraintResourceList(list->widget_class, &cons_list, &num_cons);
1752    list->num_resources = num_xt;
1753    list->num_cons_resources = num_cons;
1754
1755    list->resources = (ResourceInfo**)
1756	XtMalloc(sizeof(ResourceInfo*) * (num_xt + num_cons));
1757
1758    for (i = 0; i < num_xt; i++) {
1759	list->resources[i] = (ResourceInfo*)XtMalloc(sizeof(ResourceInfo));
1760	list->resources[i]->qname =
1761	    XrmPermStringToQuark(xt_list[i].resource_name);
1762	list->resources[i]->qtype =
1763	    XrmPermStringToQuark(xt_list[i].resource_type);
1764	list->resources[i]->size = xt_list[i].resource_size;
1765    }
1766
1767    for (; i < num_xt + num_cons; i++) {
1768	list->resources[i] = (ResourceInfo*)XtMalloc(sizeof(ResourceInfo));
1769	list->resources[i]->qname =
1770	    XrmPermStringToQuark(cons_list[i - num_xt].resource_name);
1771	list->resources[i]->qtype =
1772	    XrmPermStringToQuark(cons_list[i - num_xt].resource_type);
1773	list->resources[i]->size = cons_list[i - num_xt].resource_size;
1774    }
1775
1776    XtFree((XtPointer)xt_list);
1777    if (cons_list)
1778	XtFree((XtPointer)cons_list);
1779
1780    qsort(list->resources, list->num_resources, sizeof(ResourceInfo*),
1781	  qcmp_action_resource);
1782    if (num_cons)
1783	qsort(&list->resources[num_xt], list->num_cons_resources,
1784	      sizeof(ResourceInfo*), qcmp_action_resource);
1785}
1786
1787/*ARGSUSED*/
1788static void
1789PopdownAction(Widget w, XEvent *event, String *params, Cardinal *num_params)
1790{
1791    XtPopdown(w);
1792}
1793
1794/*ARGSUSED*/
1795static void
1796QuitAction(Widget w, XEvent *event, String *params, Cardinal *num_params)
1797{
1798    XtAppSetExitFlag(XtWidgetToApplicationContext(w));
1799}
1800