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 Csar 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 */ 44 typedef struct { 45 XrmQuark qname; 46 XrmQuark qtype; 47 Cardinal size; 48 } ResourceInfo; 49 50 typedef struct { 51 WidgetClass widget_class; 52 ResourceInfo **resources; 53 Cardinal num_resources; 54 Cardinal num_cons_resources; 55 } ResourceList; 56 57 typedef struct { 58 Arg *args; 59 Cardinal num_args; 60 } Resources; 61 62 typedef struct { 63 LispObj *data; 64 /* data is => (list* widget callback argument) */ 65 } CallbackArgs; 66 67 /* 68 * Prototypes 69 */ 70 int xtLoadModule(void); 71 void LispXtCleanupCallback(Widget, XtPointer, XtPointer); 72 73 void LispXtCallback(Widget, XtPointer, XtPointer); 74 void LispXtInputCallback(XtPointer, int*, XtInputId*); 75 76 /* a hack... */ 77 LispObj *Lisp_XtCoerceToWidgetList(LispBuiltin*); 78 79 LispObj *Lisp_XtAddCallback(LispBuiltin*); 80 LispObj *Lisp_XtAppInitialize(LispBuiltin*); 81 LispObj *Lisp_XtAppMainLoop(LispBuiltin*); 82 LispObj *Lisp_XtAppAddInput(LispBuiltin*); 83 LispObj *Lisp_XtAppPending(LispBuiltin*); 84 LispObj *Lisp_XtAppProcessEvent(LispBuiltin*); 85 LispObj *Lisp_XtCreateWidget(LispBuiltin*); 86 LispObj *Lisp_XtCreateManagedWidget(LispBuiltin*); 87 LispObj *Lisp_XtCreatePopupShell(LispBuiltin*); 88 LispObj *Lisp_XtDestroyWidget(LispBuiltin*); 89 LispObj *Lisp_XtGetKeyboardFocusWidget(LispBuiltin*); 90 LispObj *Lisp_XtGetValues(LispBuiltin*); 91 LispObj *Lisp_XtManageChild(LispBuiltin*); 92 LispObj *Lisp_XtUnmanageChild(LispBuiltin*); 93 LispObj *Lisp_XtSetMappedWhenManaged(LispBuiltin*); 94 LispObj *Lisp_XtMapWidget(LispBuiltin*); 95 LispObj *Lisp_XtName(LispBuiltin*); 96 LispObj *Lisp_XtParent(LispBuiltin*); 97 LispObj *Lisp_XtUnmapWidget(LispBuiltin*); 98 LispObj *Lisp_XtPopup(LispBuiltin*); 99 LispObj *Lisp_XtPopdown(LispBuiltin*); 100 LispObj *Lisp_XtIsRealized(LispBuiltin*); 101 LispObj *Lisp_XtRealizeWidget(LispBuiltin*); 102 LispObj *Lisp_XtUnrealizeWidget(LispBuiltin*); 103 LispObj *Lisp_XtRemoveInput(LispBuiltin*); 104 LispObj *Lisp_XtSetSensitive(LispBuiltin*); 105 LispObj *Lisp_XtSetValues(LispBuiltin*); 106 LispObj *Lisp_XtWidgetToApplicationContext(LispBuiltin*); 107 LispObj *Lisp_XtDisplay(LispBuiltin*); 108 LispObj *Lisp_XtDisplayOfObject(LispBuiltin*); 109 LispObj *Lisp_XtScreen(LispBuiltin*); 110 LispObj *Lisp_XtScreenOfObject(LispBuiltin*); 111 LispObj *Lisp_XtSetKeyboardFocus(LispBuiltin*); 112 LispObj *Lisp_XtWindow(LispBuiltin*); 113 LispObj *Lisp_XtWindowOfObject(LispBuiltin*); 114 LispObj *Lisp_XtAddGrab(LispBuiltin*); 115 LispObj *Lisp_XtRemoveGrab(LispBuiltin*); 116 LispObj *Lisp_XtAppGetExitFlag(LispBuiltin*); 117 LispObj *Lisp_XtAppSetExitFlag(LispBuiltin*); 118 119 LispObj *LispXtCreateWidget(LispBuiltin*, int); 120 121 static Resources *LispConvertResources(LispObj*, Widget, 122 ResourceList*, ResourceList*); 123 static void LispFreeResources(Resources*); 124 125 static int bcmp_action_resource(_Xconst void*, _Xconst void*); 126 static ResourceInfo *GetResourceInfo(char*, ResourceList*, ResourceList*); 127 static ResourceList *GetResourceList(WidgetClass); 128 static int bcmp_action_resource_list(_Xconst void*, _Xconst void*); 129 static ResourceList *FindResourceList(WidgetClass); 130 static int qcmp_action_resource_list(_Xconst void*, _Xconst void*); 131 static ResourceList *CreateResourceList(WidgetClass); 132 static int qcmp_action_resource(_Xconst void*, _Xconst void*); 133 static void BindResourceList(ResourceList*); 134 135 static void PopdownAction(Widget, XEvent*, String*, Cardinal*); 136 static void QuitAction(Widget, XEvent*, String*, Cardinal*); 137 138 /* 139 * Initialization 140 */ 141 static 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 185 LispModuleData xtLispModuleData = { 186 LISP_MODULE_VERSION, 187 xtLoadModule, 188 }; 189 190 static ResourceList **resource_list; 191 static Cardinal num_resource_list; 192 193 static Atom delete_window; 194 static int xtAppContext_t, xtWidget_t, xtWidgetClass_t, xtWidgetList_t, 195 xtInputId_t, xtDisplay_t, xtScreen_t, xtWindow_t; 196 197 static XtActionsRec actions[] = { 198 {"xt-popdown", PopdownAction}, 199 {"xt-quit", QuitAction}, 200 }; 201 202 static XrmQuark qCardinal, qInt, qString, qWidget, qFloat; 203 204 static CallbackArgs **input_list; 205 static Cardinal num_input_list, size_input_list; 206 207 /* 208 * Implementation 209 */ 210 int 211 xtLoadModule(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 282 void 283 LispXtCallback(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 301 void 302 LispXtCleanupCallback(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 310 void 311 LispXtInputCallback(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 328 LispObj * 329 Lisp_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 374 LispObj * 375 Lisp_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 416 LispObj * 417 Lisp_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 479 LispObj * 480 Lisp_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 518 LispObj * 519 Lisp_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 583 LispObj * 584 Lisp_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 602 LispObj * 603 Lisp_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 620 LispObj * 621 Lisp_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 656 LispObj * 657 Lisp_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 685 LispObj * 686 Lisp_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 704 LispObj * 705 Lisp_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 721 LispObj * 722 Lisp_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 743 LispObj * 744 Lisp_XtCreateWidget(LispBuiltin *builtin) 745 /* 746 xt-create-widget name widget-class parent &optional arguments 747 */ 748 { 749 return (LispXtCreateWidget(builtin, UNMANAGED)); 750 } 751 752 LispObj * 753 Lisp_XtCreateManagedWidget(LispBuiltin *builtin) 754 /* 755 xt-create-managed-widget name widget-class parent &optional arguments 756 */ 757 { 758 return (LispXtCreateWidget(builtin, MANAGED)); 759 } 760 761 LispObj * 762 Lisp_XtCreatePopupShell(LispBuiltin *builtin) 763 /* 764 xt-create-popup-shell name widget-class parent &optional arguments 765 */ 766 { 767 return (LispXtCreateWidget(builtin, SHELL)); 768 } 769 770 LispObj * 771 LispXtCreateWidget(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 828 LispObj * 829 Lisp_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 845 LispObj * 846 Lisp_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 977 LispObj * 978 Lisp_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 995 LispObj * 996 Lisp_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 1013 LispObj * 1014 Lisp_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 1031 LispObj * 1032 Lisp_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 1049 LispObj * 1050 Lisp_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 1070 LispObj * 1071 Lisp_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 1097 LispObj * 1098 Lisp_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 1115 LispObj * 1116 Lisp_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 1138 LispObj * 1139 Lisp_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 1157 LispObj * 1158 Lisp_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 1190 LispObj * 1191 Lisp_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 1212 LispObj * 1213 Lisp_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 1234 LispObj * 1235 Lisp_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 1256 LispObj * 1257 Lisp_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 1278 LispObj * 1279 Lisp_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 1300 LispObj * 1301 Lisp_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 1322 LispObj * 1323 Lisp_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 1344 LispObj * 1345 Lisp_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 1371 LispObj * 1372 Lisp_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 1390 LispObj * 1391 Lisp_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 1407 LispObj * 1408 Lisp_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 1424 LispObj * 1425 Lisp_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 1442 LispObj * 1443 Lisp_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 1461 static Resources * 1462 LispConvertResources(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 1641 static void 1642 LispFreeResources(Resources *resources) 1643 { 1644 if (resources) { 1645 XtFree((XtPointer)resources->args); 1646 XtFree((XtPointer)resources); 1647 } 1648 } 1649 1650 static int 1651 bcmp_action_resource(_Xconst void *string, _Xconst void *resource) 1652 { 1653 return (strcmp((String)string, 1654 XrmQuarkToString((*(ResourceInfo**)resource)->qname))); 1655 } 1656 1657 static ResourceInfo * 1658 GetResourceInfo(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 1677 static ResourceList * 1678 GetResourceList(WidgetClass wc) 1679 { 1680 ResourceList *list; 1681 1682 if ((list = FindResourceList(wc)) == NULL) 1683 list = CreateResourceList(wc); 1684 1685 return (list); 1686 } 1687 1688 static int 1689 bcmp_action_resource_list(_Xconst void *wc, _Xconst void *list) 1690 { 1691 return ((char*)wc - (char*)((*(ResourceList**)list)->widget_class)); 1692 } 1693 1694 static ResourceList * 1695 FindResourceList(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 1709 static int 1710 qcmp_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 1716 static ResourceList * 1717 CreateResourceList(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 1737 static int 1738 qcmp_action_resource(_Xconst void *left, _Xconst void *right) 1739 { 1740 return (strcmp(XrmQuarkToString((*(ResourceInfo**)left)->qname), 1741 XrmQuarkToString((*(ResourceInfo**)right)->qname))); 1742 } 1743 1744 static void 1745 BindResourceList(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*/ 1788 static void 1789 PopdownAction(Widget w, XEvent *event, String *params, Cardinal *num_params) 1790 { 1791 XtPopdown(w); 1792 } 1793 1794 /*ARGSUSED*/ 1795 static void 1796 QuitAction(Widget w, XEvent *event, String *params, Cardinal *num_params) 1797 { 1798 XtAppSetExitFlag(XtWidgetToApplicationContext(w)); 1799 } 1800
Indexes created Thu Jul 02 00:25:40 UTC 2026