git.chise.org Git - chise/xemacs-chise.git-/blob - src/ui-gtk.c

   1 /* ui-gtk.c
   2 **
   3 ** Description: Creating 'real' UIs from lisp.
   4 **
   5 ** Created by: William M. Perry <wmperry@gnu.org>
   6 ** Copyright (c) 2000 William M. Perry <wmperry@gnu.org>
   7 **
   8 */
   9
  10 #include <config.h>
  11 #include "lisp.h"
  12 #include "buffer.h"
  13 #include "console-gtk.h"
  14 #include "device.h"
  15 #include "window.h"
  16 #include "glyphs-gtk.h"
  17 #include "objects-gtk.h"
  18 #include "ui-gtk.h"
  19 #include "faces.h"
  20 #include "gui-gtk.h"
  21 #include "sysdll.h"
  22 #include "hash.h"
  23 #include "events.h"
  24 #include "elhash.h"
  25
  26 /* XEmacs specific GTK types */
  27 #include "gtk-glue.c"
  28
  29 Lisp_Object Qemacs_ffip;
  30 Lisp_Object Qemacs_gtk_objectp;
  31 Lisp_Object Qemacs_gtk_boxedp;
  32 Lisp_Object Qvoid;
  33 Lisp_Object Venumeration_info;
  34
  35 static GHashTable *dll_cache;
  36
  37 Lisp_Object gtk_type_to_lisp (GtkArg *arg);
  38 int lisp_to_gtk_type (Lisp_Object obj, GtkArg *arg);
  39 int lisp_to_gtk_ret_type (Lisp_Object obj, GtkArg *arg);
  40 void describe_gtk_arg (GtkArg *arg);
  41 guint symbol_to_enum (Lisp_Object obj, GtkType t);
  42 static guint lisp_to_flag (Lisp_Object obj, GtkType t);
  43 static Lisp_Object flags_to_list (guint value, GtkType t);
  44 static Lisp_Object enum_to_symbol (guint value, GtkType t);
  45
  46 #define NIL_OR_VOID_P(x) (NILP (x) || EQ (x, Qvoid))
  47
  48 static void
  49 initialize_dll_cache (void)
  50 {
  51   if (!dll_cache)
  52     {
  53       dll_cache = g_hash_table_new (g_str_hash, g_str_equal);
  54
  55       g_hash_table_insert (dll_cache, "---XEmacs Internal Handle---", dll_open (NULL));
  56     }
  57 }
  58
  59 DEFUN ("dll-load", Fdll_load, 1, 1, 0, /*
  60 Load a shared library DLL into XEmacs.  No initialization routines are required.
  61 This is for loading dependency DLLs into XEmacs.
  62 */
  63        (dll))
  64 {
  65   dll_handle h;
  66
  67   CHECK_STRING (dll);
  68
  69   initialize_dll_cache ();
  70
  71   /* If the dll name has a directory component in it, then we should
  72      expand it. */
  73   if (!NILP (Fstring_match (build_string ("/"), dll, Qnil, Qnil)))
  74     dll = Fexpand_file_name (dll, Qnil);
  75
  76   /* Check if we have already opened it first */
  77   h = g_hash_table_lookup (dll_cache, XSTRING_DATA (dll));
  78
  79   if (!h)
  80     {
  81       h = dll_open ((char *) XSTRING_DATA (dll));
  82
  83       if (h)
  84         {
  85           g_hash_table_insert (dll_cache, g_strdup (XSTRING_DATA (dll)), h);
  86         }
  87       else
  88         {
  89           signal_simple_error ("dll_open error", build_string (dll_error (NULL)));
  90         }
  91     }
  92   return (h ? Qt : Qnil);
  93 }
  94
  95 \f
  96 /* Gtk object importing */
  97 EXFUN (Fgtk_import_type, 1);
  98
  99 static struct hash_table *internal_type_hash;
 100
 101 static int
 102 type_hash_equal(const void *arg1, const void *arg2)
 103 {
 104   return ((GtkType) arg1 == (GtkType) arg2);
 105 }
 106
 107 static unsigned long
 108 type_hash_hash(const void *arg)
 109 {
 110   return ((unsigned long) arg);
 111 }
 112
 113 static int
 114 type_already_imported_p (GtkType t)
 115 {
 116   void *retval = NULL;
 117
 118   /* These are cases that we don't need to import */
 119   switch (GTK_FUNDAMENTAL_TYPE (t))
 120     {
 121     case GTK_TYPE_CHAR:
 122     case GTK_TYPE_UCHAR:
 123     case GTK_TYPE_BOOL:
 124     case GTK_TYPE_INT:
 125     case GTK_TYPE_UINT:
 126     case GTK_TYPE_LONG:
 127     case GTK_TYPE_ULONG:
 128     case GTK_TYPE_FLOAT:
 129     case GTK_TYPE_DOUBLE:
 130     case GTK_TYPE_STRING:
 131     case GTK_TYPE_BOXED:
 132     case GTK_TYPE_POINTER:
 133     case GTK_TYPE_SIGNAL:
 134     case GTK_TYPE_ARGS:
 135     case GTK_TYPE_CALLBACK:
 136     case GTK_TYPE_C_CALLBACK:
 137     case GTK_TYPE_FOREIGN:
 138         return (1);
 139     }
 140
 141   if (!internal_type_hash)
 142     {
 143       internal_type_hash = make_general_hash_table (163, type_hash_hash, type_hash_equal);
 144       return (0);
 145     }
 146
 147   if (gethash ((void *)t, internal_type_hash, (const void **)&retval))
 148     {
 149       return (1);
 150     }
 151   return (0);
 152 }
 153
 154 static void
 155 mark_type_as_imported (GtkType t)
 156 {
 157   if (type_already_imported_p (t))
 158     return;
 159
 160   puthash ((void *) t, (void *) 1, internal_type_hash);
 161 }
 162
 163 static void import_gtk_type (GtkType t);
 164
 165 static void
 166 import_gtk_object_internal (GtkType the_type)
 167 {
 168   GtkType original_type = the_type;
 169   int first_time = 1;
 170
 171   do
 172     {
 173       GtkArg *args;
 174       guint32 *flags;
 175       guint n_args;
 176       guint i;
 177 #if 0
 178       GtkObjectClass *klass;
 179       GtkSignalQuery *query;
 180       guint32 *signals;
 181       guint n_signals;
 182 #endif
 183
 184       /* Register the type before we do anything else with it... */
 185       if (!first_time)
 186         {
 187           if (!type_already_imported_p (the_type))
 188             {
 189               import_gtk_type (the_type);
 190             }
 191         }
 192       else
 193         {
 194           /* We need to mark the object type as imported here or we
 195              run the risk of SERIOUS recursion when we do automatic
 196              argument type importing.  mark_type_as_imported() is
 197              smart enough to be a noop if we attempt to register
 198              things twice.  */
 199           first_time = 0;
 200           mark_type_as_imported (the_type);
 201         }
 202
 203       args = gtk_object_query_args(the_type,&flags,&n_args);
 204
 205       /* First get the arguments the object can accept */
 206       for (i = 0; i < n_args; i++)
 207         {
 208           if ((args[i].type != original_type) && !type_already_imported_p (args[i].type))
 209             {
 210               import_gtk_type (args[i].type);
 211             }
 212         }
 213
 214       g_free(args);
 215       g_free(flags);
 216
 217 #if 0
 218       /* Now lets publish the signals */
 219       klass = (GtkObjectClass *) gtk_type_class (the_type);
 220       signals = klass->signals;
 221       n_signals = klass->nsignals;
 222
 223       for (i = 0; i < n_signals; i++)
 224         {
 225           query = gtk_signal_query (signals[i]);
 226           /* What do we want to do here? */
 227           g_free (query);
 228         }
 229 #endif
 230
 231       the_type = gtk_type_parent(the_type);
 232     } while (the_type != GTK_TYPE_INVALID);
 233 }
 234
 235 static void
 236 import_gtk_enumeration_internal (GtkType the_type)
 237 {
 238   GtkEnumValue *vals = gtk_type_enum_get_values (the_type);
 239   Lisp_Object assoc = Qnil;
 240
 241   if (NILP (Venumeration_info))
 242     {
 243       Venumeration_info = call2 (intern ("make-hashtable"), make_int (100), Qequal);
 244     }
 245
 246   while (vals && vals->value_name)
 247     {
 248       assoc = Fcons (Fcons (intern (vals->value_nick), make_int (vals->value)), assoc);
 249       assoc = Fcons (Fcons (intern (vals->value_name), make_int (vals->value)), assoc);
 250       vals++;
 251     }
 252
 253   assoc = Fnreverse (assoc);
 254
 255   Fputhash (make_int (the_type), assoc, Venumeration_info);
 256 }
 257
 258 static void
 259 import_gtk_type (GtkType t)
 260 {
 261   if (type_already_imported_p (t))
 262     {
 263       return;
 264     }
 265
 266   switch (GTK_FUNDAMENTAL_TYPE (t))
 267     {
 268     case GTK_TYPE_ENUM:
 269     case GTK_TYPE_FLAGS:
 270       import_gtk_enumeration_internal (t);
 271       break;
 272     case GTK_TYPE_OBJECT:
 273       import_gtk_object_internal (t);
 274       break;
 275     default:
 276       break;
 277     }
 278
 279   mark_type_as_imported (t);
 280 }
 281
 282 \f
 283 /* Foreign function calls */
 284 static emacs_ffi_data *
 285 allocate_ffi_data (void)
 286 {
 287   emacs_ffi_data *data = alloc_lcrecord_type (emacs_ffi_data, &lrecord_emacs_ffi);
 288
 289   data->return_type = GTK_TYPE_NONE;
 290   data->n_args = 0;
 291   data->function_name = Qnil;
 292   data->function_ptr = 0;
 293   data->marshal = 0;
 294
 295   return (data);
 296 }
 297
 298 static Lisp_Object
 299 mark_ffi_data (Lisp_Object obj)
 300 {
 301   emacs_ffi_data *data = (emacs_ffi_data *) XFFI (obj);
 302
 303   mark_object (data->function_name);
 304   return (Qnil);
 305 }
 306
 307 static void
 308 ffi_object_printer (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag)
 309 {
 310   char buf[200];
 311
 312   if (print_readably)
 313     error ("printing unreadable object #<ffi %p", XFFI (obj)->function_ptr);
 314
 315   write_c_string ("#<ffi ", printcharfun);
 316   print_internal (XFFI (obj)->function_name, printcharfun, 1);
 317   if (XFFI (obj)->n_args)
 318     {
 319       sprintf (buf, " %d arguments", XFFI (obj)->n_args);
 320       write_c_string (buf, printcharfun);
 321     }
 322   sprintf (buf, " %p>", (void *)XFFI (obj)->function_ptr);
 323   write_c_string (buf, printcharfun);
 324 }
 325
 326 DEFINE_LRECORD_IMPLEMENTATION ("ffi", emacs_ffi,
 327                                mark_ffi_data, ffi_object_printer,
 328                                0, 0, 0, NULL, emacs_ffi_data);
 329
 330 typedef GtkObject * (*__OBJECT_fn) ();
 331 typedef gint (*__INT_fn) ();
 332 typedef void (*__NONE_fn) ();
 333 typedef gchar * (*__STRING_fn) ();
 334 typedef gboolean (*__BOOL_fn) ();
 335 typedef gfloat (*__FLOAT_fn) ();
 336 typedef void * (*__POINTER_fn) ();
 337 typedef GList * (*__LIST_fn) ();
 338
 339 /* An auto-generated file of marshalling functions. */
 340 #include "emacs-marshals.c"
 341
 342 #define CONVERT_SINGLE_TYPE(var,nam,tp) case GTK_TYPE_##nam: GTK_VALUE_##nam (var) = * (tp *) v; break;
 343 #define CONVERT_RETVAL(a,freep)                         \
 344   do {                                                  \
 345     void *v = GTK_VALUE_POINTER(a);                     \
 346     switch (GTK_FUNDAMENTAL_TYPE (a.type))              \
 347     {                                                   \
 348         CONVERT_SINGLE_TYPE(a,CHAR,gchar);              \
 349         CONVERT_SINGLE_TYPE(a,UCHAR,guchar);            \
 350         CONVERT_SINGLE_TYPE(a,BOOL,gboolean);           \
 351         CONVERT_SINGLE_TYPE(a,INT,gint);                \
 352         CONVERT_SINGLE_TYPE(a,UINT,guint);              \
 353         CONVERT_SINGLE_TYPE(a,LONG,glong);              \
 354         CONVERT_SINGLE_TYPE(a,ULONG,gulong);            \
 355         CONVERT_SINGLE_TYPE(a,FLOAT,gfloat);            \
 356         CONVERT_SINGLE_TYPE(a,DOUBLE,gdouble);          \
 357         CONVERT_SINGLE_TYPE(a,STRING,gchar *);          \
 358         CONVERT_SINGLE_TYPE(a,ENUM,gint);               \
 359         CONVERT_SINGLE_TYPE(a,FLAGS,guint);             \
 360         CONVERT_SINGLE_TYPE(a,BOXED,void *);            \
 361         CONVERT_SINGLE_TYPE(a,POINTER,void *);          \
 362         CONVERT_SINGLE_TYPE(a,OBJECT,GtkObject *);      \
 363         default:                                        \
 364         GTK_VALUE_POINTER (a) = * (void **) v;  \
 365         break;                                          \
 366     }                                                   \
 367     if (freep) xfree(v);                                \
 368   } while (0)
 369
 370 gpointer __allocate_object_storage (GtkType t)
 371 {
 372   size_t s = 0;
 373   void *rval = NULL;
 374
 375   switch (GTK_FUNDAMENTAL_TYPE (t))
 376     {
 377       /* flag types */
 378     case GTK_TYPE_CHAR:
 379       s = (sizeof (gchar));
 380       break;
 381     case GTK_TYPE_UCHAR:
 382       s = (sizeof (guchar));
 383       break;
 384     case GTK_TYPE_BOOL:
 385       s = (sizeof (gboolean));
 386       break;
 387     case GTK_TYPE_INT:
 388       s = (sizeof (gint));
 389       break;
 390     case GTK_TYPE_UINT:
 391       s = (sizeof (guint));
 392       break;
 393     case GTK_TYPE_LONG:
 394       s = (sizeof (glong));
 395       break;
 396     case GTK_TYPE_ULONG:
 397       s = (sizeof (gulong));
 398       break;
 399     case GTK_TYPE_FLOAT:
 400       s = (sizeof (gfloat));
 401       break;
 402     case GTK_TYPE_DOUBLE:
 403       s = (sizeof (gdouble));
 404       break;
 405     case GTK_TYPE_STRING:
 406       s = (sizeof (gchar *));
 407       break;
 408     case GTK_TYPE_ENUM:
 409     case GTK_TYPE_FLAGS:
 410       s = (sizeof (guint));
 411       break;
 412     case GTK_TYPE_BOXED:
 413     case GTK_TYPE_POINTER:
 414       s = (sizeof (void *));
 415       break;
 416
 417       /* base type of the object system */
 418     case GTK_TYPE_OBJECT:
 419       s = (sizeof (GtkObject *));
 420       break;
 421
 422     default:
 423       if (GTK_FUNDAMENTAL_TYPE (t) == GTK_TYPE_LISTOF)
 424         {
 425           s = (sizeof (void *));
 426         }
 427       rval = NULL;
 428       break;
 429     }
 430
 431   if (s)
 432     {
 433       rval = xmalloc (s);
 434       memset (rval, '\0', s);
 435     }
 436
 437   return (rval);
 438 }
 439
 440 Lisp_Object type_to_marshaller_type (GtkType t)
 441 {
 442   switch (GTK_FUNDAMENTAL_TYPE (t))
 443     {
 444     case GTK_TYPE_NONE:
 445       return (build_string ("NONE"));
 446       /* flag types */
 447     case GTK_TYPE_CHAR:
 448     case GTK_TYPE_UCHAR:
 449       return (build_string ("CHAR"));
 450     case GTK_TYPE_BOOL:
 451       return (build_string ("BOOL"));
 452     case GTK_TYPE_ENUM:
 453     case GTK_TYPE_FLAGS:
 454     case GTK_TYPE_INT:
 455     case GTK_TYPE_UINT:
 456       return (build_string ("INT"));
 457     case GTK_TYPE_LONG:
 458     case GTK_TYPE_ULONG:
 459       return (build_string ("LONG"));
 460     case GTK_TYPE_FLOAT:
 461     case GTK_TYPE_DOUBLE:
 462       return (build_string ("FLOAT"));
 463     case GTK_TYPE_STRING:
 464       return (build_string ("STRING"));
 465     case GTK_TYPE_BOXED:
 466     case GTK_TYPE_POINTER:
 467       return (build_string ("POINTER"));
 468     case GTK_TYPE_OBJECT:
 469       return (build_string ("OBJECT"));
 470     case GTK_TYPE_CALLBACK:
 471       return (build_string ("CALLBACK"));
 472     default:
 473       /* I can't put this in the main switch statement because it is a
 474          new fundamental type that is not fixed at compile time.
 475          *sigh*
 476          */
 477       if (GTK_FUNDAMENTAL_TYPE (t) == GTK_TYPE_ARRAY)
 478         return (build_string ("ARRAY"));
 479
 480       if (GTK_FUNDAMENTAL_TYPE (t) == GTK_TYPE_LISTOF)
 481         return (build_string ("LIST"));
 482       return (Qnil);
 483     }
 484 }
 485
 486 struct __dll_mapper_closure {
 487   void * (*func) (dll_handle, const char *);
 488   const char *obj_name;
 489   void **storage;
 490 };
 491
 492 static void __dll_mapper (gpointer key, gpointer value, gpointer user_data)
 493 {
 494   struct __dll_mapper_closure *closure = (struct __dll_mapper_closure *) user_data;
 495
 496   if (*(closure->storage) == NULL)
 497     {
 498       /* Need to see if it is in this one */
 499       *(closure->storage) = closure->func ((dll_handle) value, closure->obj_name);
 500     }
 501 }
 502
 503 DEFUN ("gtk-import-variable-internal", Fgtk_import_variable_internal, 2, 2, 0, /*
 504 Import a variable into the XEmacs namespace.
 505 */
 506        (type, name))
 507 {
 508   void *var = NULL;
 509   GtkArg arg;
 510
 511   if (SYMBOLP (type)) type = Fsymbol_name (type);
 512
 513   CHECK_STRING (type);
 514   CHECK_STRING (name);
 515
 516   initialize_dll_cache ();
 517   xemacs_init_gtk_classes ();
 518
 519   arg.type = gtk_type_from_name ((char *) XSTRING_DATA (type));
 520
 521   if (arg.type == GTK_TYPE_INVALID)
 522     {
 523       signal_simple_error ("Unknown type", type);
 524     }
 525
 526   /* Need to look thru the already-loaded dlls */
 527   {
 528     struct __dll_mapper_closure closure;
 529
 530     closure.func = dll_variable;
 531     closure.obj_name = XSTRING_DATA (name);
 532     closure.storage = &var;
 533
 534     g_hash_table_foreach (dll_cache, __dll_mapper, &closure);
 535   }
 536
 537   if (!var)
 538     {
 539       signal_simple_error ("Could not locate variable", name);
 540     }
 541
 542   GTK_VALUE_POINTER(arg) = var;
 543   CONVERT_RETVAL (arg, 0);
 544   return (gtk_type_to_lisp (&arg));
 545 }
 546
 547 DEFUN ("gtk-import-function-internal", Fgtk_import_function_internal, 2, 3, 0, /*
 548 Import a function into the XEmacs namespace.
 549 */
 550        (rettype, name, args))
 551 {
 552   Lisp_Object rval = Qnil;
 553   Lisp_Object marshaller = Qnil;
 554   emacs_ffi_data *data = NULL;
 555   gint n_args = 0;
 556 #if 0
 557   dll_handle h = NULL;
 558 #endif
 559   ffi_marshalling_function marshaller_func = NULL;
 560   ffi_actual_function name_func = NULL;
 561
 562   CHECK_SYMBOL (rettype);
 563   CHECK_STRING (name);
 564   CHECK_LIST (args);
 565
 566   initialize_dll_cache ();
 567   xemacs_init_gtk_classes ();
 568
 569   /* Need to look thru the already-loaded dlls */
 570   {
 571     struct __dll_mapper_closure closure;
 572
 573     closure.func = dll_function;
 574     closure.obj_name = XSTRING_DATA (name);
 575     closure.storage = (void **) &name_func;
 576
 577     g_hash_table_foreach (dll_cache, __dll_mapper, &closure);
 578   }
 579
 580   if (!name_func)
 581     {
 582       signal_simple_error ("Could not locate function", name);
 583     }
 584
 585   data = allocate_ffi_data ();
 586
 587   if (NILP (rettype))
 588     {
 589       rettype = Qvoid;
 590     }
 591
 592   if (!NILP (args))
 593     {
 594       Lisp_Object tail = Qnil;
 595       Lisp_Object value = args;
 596       Lisp_Object type = Qnil;
 597
 598       EXTERNAL_LIST_LOOP (tail, value)
 599         {
 600           GtkType the_type;
 601           Lisp_Object marshaller_type = Qnil;
 602
 603           CHECK_SYMBOL (XCAR (tail));
 604
 605           type = Fsymbol_name (XCAR (tail));
 606
 607           the_type = gtk_type_from_name ((char *) XSTRING_DATA (type));
 608
 609           if (the_type == GTK_TYPE_INVALID)
 610             {
 611               signal_simple_error ("Unknown argument type", type);
 612             }
 613
 614           /* All things must be reduced to their basest form... */
 615           import_gtk_type (the_type);
 616           data->args[n_args] = the_type; /* GTK_FUNDAMENTAL_TYPE (the_type); */
 617
 618           /* Now lets build up another chunk of our marshaller function name */
 619           marshaller_type = type_to_marshaller_type (data->args[n_args]);
 620
 621           if (NILP (marshaller_type))
 622             {
 623               signal_simple_error ("Do not know how to marshal", type);
 624             }
 625           marshaller = concat3 (marshaller, build_string ("_"), marshaller_type);
 626           n_args++;
 627         }
 628     }
 629   else
 630     {
 631       marshaller = concat3 (marshaller, build_string ("_"), type_to_marshaller_type (GTK_TYPE_NONE));
 632     }
 633
 634   rettype = Fsymbol_name (rettype);
 635   data->return_type = gtk_type_from_name ((char *) XSTRING_DATA (rettype));
 636
 637   if (data->return_type == GTK_TYPE_INVALID)
 638     {
 639       signal_simple_error ("Unknown return type", rettype);
 640     }
 641
 642   import_gtk_type (data->return_type);
 643
 644   marshaller = concat3 (type_to_marshaller_type (data->return_type), build_string ("_"), marshaller);
 645   marshaller = concat2 (build_string ("emacs_gtk_marshal_"), marshaller);
 646
 647   marshaller_func = (ffi_marshalling_function) find_marshaller ((char *) XSTRING_DATA (marshaller));
 648
 649   if (!marshaller_func)
 650     {
 651       signal_simple_error ("Could not locate marshaller function", marshaller);
 652     }
 653
 654   data->n_args = n_args;
 655   data->function_name = name;
 656   data->function_ptr = name_func;
 657   data->marshal = marshaller_func;
 658
 659   XSETFFI (rval, data);
 660   return (rval);
 661 }
 662
 663 DEFUN ("gtk-call-function", Fgtk_call_function, 1, 2, 0, /*
 664 Call an external function.
 665 */
 666        (func, args))
 667 {
 668   GtkArg the_args[MAX_GTK_ARGS];
 669   gint n_args = 0;
 670   Lisp_Object retval = Qnil;
 671
 672   CHECK_FFI (func);
 673   CHECK_LIST (args);
 674
 675   n_args = XINT (Flength (args));
 676
 677 #ifdef XEMACS_IS_SMARTER_THAN_THE_PROGRAMMER
 678   /* #### I think this is too dangerous to enable by default.
 679   ** #### Genuine program bugs would probably be allowed to
 680   ** #### slip by, and not be very easy to find.
 681   ** #### Bill Perry July 9, 2000
 682   */
 683   if (n_args != XFFI(func)->n_args)
 684     {
 685       Lisp_Object for_append[3];
 686
 687       /* Signal an error if they pass in too many arguments */
 688       if (n_args > XFFI(func)->n_args)
 689         {
 690           return Fsignal (Qwrong_number_of_arguments,
 691                           list2 (func, make_int (n_args)));
 692         }
 693
 694       /* If they did not provide enough arguments, be nice and assume
 695       ** they wanted `nil' in there.
 696       */
 697       for_append[0] = args;
 698       for_append[1] = Fmake_list (make_int (XFFI(func)->n_args - n_args), Qnil);
 699
 700       args = Fappend (2, for_append);
 701     }
 702 #else
 703   if (n_args != XFFI(func)->n_args)
 704     {
 705       /* Signal an error if they do not pass in the correct # of arguments */
 706       return Fsignal (Qwrong_number_of_arguments,
 707                       list2 (func, make_int (n_args)));
 708     }
 709 #endif
 710
 711   if (!NILP (args))
 712     {
 713       Lisp_Object tail = Qnil;
 714       Lisp_Object value = args;
 715
 716       CHECK_LIST (args);
 717       n_args = 0;
 718
 719       /* First we convert all of the arguments from Lisp to GtkArgs */
 720       EXTERNAL_LIST_LOOP (tail, value)
 721         {
 722           the_args[n_args].type = XFFI (func)->args[n_args];
 723
 724           if (lisp_to_gtk_type (XCAR (tail), &the_args[n_args]))
 725             {
 726               /* There was some sort of an error */
 727               signal_simple_error ("Error converting arguments", args);
 728             }
 729           n_args++;
 730         }
 731     }
 732
 733   /* Now we need to tack on space for a return value, if they have
 734      asked for one */
 735   if (XFFI (func)->return_type != GTK_TYPE_NONE)
 736     {
 737       the_args[n_args].type = XFFI (func)->return_type;
 738       GTK_VALUE_POINTER (the_args[n_args]) = __allocate_object_storage (the_args[n_args].type);
 739       n_args++;
 740     }
 741
 742   XFFI (func)->marshal ((ffi_actual_function) (XFFI (func)->function_ptr), the_args);
 743
 744   if (XFFI (func)->return_type != GTK_TYPE_NONE)
 745     {
 746       CONVERT_RETVAL (the_args[n_args - 1], 1);
 747       retval = gtk_type_to_lisp (&the_args[n_args - 1]);
 748     }
 749
 750   /* Need to free any array or list pointers */
 751   {
 752     int i;
 753     for (i = 0; i < n_args; i++)
 754       {
 755         if (GTK_FUNDAMENTAL_TYPE (the_args[i].type) == GTK_TYPE_ARRAY)
 756           {
 757             g_free (GTK_VALUE_POINTER (the_args[i]));
 758           }
 759         else if (GTK_FUNDAMENTAL_TYPE (the_args[i].type) == GTK_TYPE_LISTOF)
 760           {
 761             /* g_list_free (GTK_VALUE_POINTER (the_args[i])); */
 762           }
 763       }
 764   }
 765
 766   return (retval);
 767 }
 768
 769 \f
 770
 771 /* GtkObject wrapping for Lisp */
 772 static void
 773 emacs_gtk_object_printer (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag)
 774 {
 775   char buf[200];
 776
 777   if (print_readably)
 778     error ("printing unreadable object #<GtkObject %p>", XGTK_OBJECT (obj)->object);
 779
 780   write_c_string ("#<GtkObject (", printcharfun);
 781   if (XGTK_OBJECT (obj)->alive_p)
 782     write_c_string (gtk_type_name (GTK_OBJECT_TYPE (XGTK_OBJECT (obj)->object)), printcharfun);
 783   else
 784     write_c_string ("dead", printcharfun);
 785   sprintf (buf, ") %p>", (void *) XGTK_OBJECT (obj)->object);
 786   write_c_string (buf, printcharfun);
 787 }
 788
 789 static Lisp_Object
 790 object_getprop (Lisp_Object obj, Lisp_Object prop)
 791 {
 792   Lisp_Object rval = Qnil;
 793   Lisp_Object prop_name = Qnil;
 794   GtkArgInfo *info = NULL;
 795   char *err;
 796   GtkArg args[2];
 797
 798   CHECK_SYMBOL (prop);          /* Shouldn't need to ever do this, but I'm paranoid */
 799
 800   prop_name = Fsymbol_name (prop);
 801
 802   args[0].name = (char *) XSTRING_DATA (prop_name);
 803
 804   err = gtk_object_arg_get_info (GTK_OBJECT_TYPE (XGTK_OBJECT (obj)->object),
 805                                  args[0].name,
 806                                  &info);
 807
 808   if (err)
 809     {
 810       /* Not a magic symbol, fall back to just looking in our real plist */
 811       g_free (err);
 812
 813       return (Fplist_get (XGTK_OBJECT (obj)->plist, prop, Qunbound));
 814     }
 815
 816   if (!(info->arg_flags & GTK_ARG_READABLE))
 817     {
 818       signal_simple_error ("Attempt to get write-only property", prop);
 819     }
 820
 821   gtk_object_getv (XGTK_OBJECT (obj)->object, 1, args);
 822
 823   if (args[0].type == GTK_TYPE_INVALID)
 824     {
 825       /* If we can't get the attribute, then let the code in Fget know
 826          so it can use the default value supplied by the caller */
 827       return (Qunbound);
 828     }
 829
 830   rval = gtk_type_to_lisp (&args[0]);
 831
 832   /* Free up any memory.  According to the documentation and Havoc's
 833      book, if the fundamental type of the returned value is
 834      GTK_TYPE_STRING, GTK_TYPE_BOXED, or GTK_TYPE_ARGS, you are
 835      responsible for freeing it. */
 836   switch (GTK_FUNDAMENTAL_TYPE (args[0].type))
 837     {
 838     case GTK_TYPE_STRING:
 839       g_free (GTK_VALUE_STRING (args[0]));
 840       break;
 841     case GTK_TYPE_BOXED:
 842       g_free (GTK_VALUE_BOXED (args[0]));
 843       break;
 844     case GTK_TYPE_ARGS:
 845       g_free (GTK_VALUE_ARGS (args[0]).args);
 846     default:
 847       break;
 848     }
 849
 850   return (rval);
 851 }
 852
 853 static int
 854 object_putprop (Lisp_Object obj, Lisp_Object prop, Lisp_Object value)
 855 {
 856   GtkArgInfo *info = NULL;
 857   Lisp_Object prop_name = Qnil;
 858   GtkArg args[2];
 859   char *err = NULL;
 860
 861   prop_name = Fsymbol_name (prop);
 862
 863   args[0].name = (char *) XSTRING_DATA (prop_name);
 864
 865   err = gtk_object_arg_get_info (GTK_OBJECT_TYPE (XGTK_OBJECT (obj)->object),
 866                                  args[0].name,
 867                                  &info);
 868
 869   if (err)
 870     {
 871       /* Not a magic symbol, fall back to just storing in our real plist */
 872       g_free (err);
 873
 874       XGTK_OBJECT (obj)->plist = Fplist_put (XGTK_OBJECT (obj)->plist, prop, value);
 875       return (1);
 876     }
 877
 878   args[0].type = info->type;
 879
 880   if (lisp_to_gtk_type (value, &args[0]))
 881     {
 882       signal_simple_error ("Error converting to GtkType", value);
 883     }
 884
 885   if (!(info->arg_flags & GTK_ARG_WRITABLE))
 886     {
 887       signal_simple_error ("Attemp to set read-only argument", prop);
 888     }
 889
 890   gtk_object_setv (XGTK_OBJECT (obj)->object, 1, args);
 891
 892   return (1);
 893 }
 894
 895 static Lisp_Object
 896 mark_gtk_object_data (Lisp_Object obj)
 897 {
 898   return (XGTK_OBJECT (obj)->plist);
 899 }
 900
 901 static void
 902 emacs_gtk_object_finalizer (void *header, int for_disksave)
 903 {
 904   emacs_gtk_object_data *data = (emacs_gtk_object_data *) header;
 905
 906   if (for_disksave)
 907     {
 908       Lisp_Object obj;
 909       XSETGTK_OBJECT (obj, data);
 910
 911       signal_simple_error
 912         ("Can't dump an emacs containing GtkObject objects", obj);
 913     }
 914
 915   if (data->alive_p)
 916     {
 917       gtk_object_unref (data->object);
 918     }
 919 }
 920
 921 DEFINE_LRECORD_IMPLEMENTATION_WITH_PROPS ("GtkObject", emacs_gtk_object,
 922                                           mark_gtk_object_data, /* marker function */
 923                                           emacs_gtk_object_printer, /* print function */
 924                                           emacs_gtk_object_finalizer, /* finalizer */
 925                                           0, /* equality */
 926                                           0, /* hash */
 927                                           NULL, /* desc */
 928                                           object_getprop, /* get prop */
 929                                           object_putprop, /* put prop */
 930                                           0, /* rem prop */
 931                                           0, /* plist */
 932                                           emacs_gtk_object_data);
 933
 934 static emacs_gtk_object_data *
 935 allocate_emacs_gtk_object_data (void)
 936 {
 937   emacs_gtk_object_data *data = alloc_lcrecord_type (emacs_gtk_object_data,
 938                                                      &lrecord_emacs_gtk_object);
 939
 940   data->object = NULL;
 941   data->alive_p = FALSE;
 942   data->plist = Qnil;
 943
 944   return (data);
 945 }
 946
 947 /* We need to keep track of when the object is destroyed so that we
 948    can mark it as dead, otherwise even our print routine (which calls
 949    GTK_OBJECT_TYPE) will crap out and die.  This is also used in the
 950    lisp_to_gtk_type() routine to defend against passing dead objects
 951    to GTK routines. */
 952 static void
 953 __notice_object_destruction (GtkObject *obj, gpointer user_data)
 954 {
 955   ungcpro_popup_callbacks ((GUI_ID) user_data);
 956 }
 957
 958 Lisp_Object build_gtk_object (GtkObject *obj)
 959 {
 960   Lisp_Object retval = Qnil;
 961   emacs_gtk_object_data *data = NULL;
 962   GUI_ID id = 0;
 963
 964   id = (GUI_ID) gtk_object_get_data (obj, GTK_DATA_GUI_IDENTIFIER);
 965
 966   if (id)
 967     {
 968       retval = get_gcpro_popup_callbacks (id);
 969     }
 970
 971   if (NILP (retval))
 972     {
 973       data = allocate_emacs_gtk_object_data ();
 974
 975       data->object = obj;
 976       data->alive_p = TRUE;
 977       XSETGTK_OBJECT (retval, data);
 978
 979       id = new_gui_id ();
 980       gtk_object_set_data (obj, GTK_DATA_GUI_IDENTIFIER, (gpointer) id);
 981       gcpro_popup_callbacks (id, retval);
 982       gtk_object_ref (obj);
 983       gtk_signal_connect (obj, "destroy", GTK_SIGNAL_FUNC (__notice_object_destruction), (gpointer)id);
 984     }
 985
 986   return (retval);
 987 }
 988
 989 static void
 990 __internal_callback_destroy (gpointer data)
 991 {
 992   Lisp_Object lisp_data;
 993
 994   VOID_TO_LISP (lisp_data, data);
 995
 996   ungcpro_popup_callbacks (XINT (XCAR (lisp_data)));
 997 }
 998
 999 static void
1000 __internal_callback_marshal (GtkObject *obj, gpointer data, guint n_args, GtkArg *args)
1001 {
1002   Lisp_Object arg_list = Qnil;
1003   Lisp_Object callback_fn = Qnil;
1004   Lisp_Object callback_data = Qnil;
1005   Lisp_Object newargs[3];
1006   Lisp_Object rval = Qnil;
1007   struct gcpro gcpro1;
1008   int i;
1009
1010   VOID_TO_LISP (callback_fn, data);
1011
1012   /* Nuke the GUI_ID off the front */
1013   callback_fn = XCDR (callback_fn);
1014
1015   callback_data = XCAR (callback_fn);
1016   callback_fn = XCDR (callback_fn);
1017
1018   /* The callback data goes at the very end of the argument list */
1019   arg_list = Fcons (callback_data, Qnil);
1020
1021   /* Build up the argument list, lisp style */
1022   for (i = n_args - 1; i >= 0; i--)
1023     {
1024       arg_list = Fcons (gtk_type_to_lisp (&args[i]), arg_list);
1025     }
1026
1027   /* We always pass the widget as the first parameter at the very least */
1028   arg_list = Fcons (build_gtk_object (obj), arg_list);
1029
1030   GCPRO1 ((arg_list));
1031
1032   newargs[0] = callback_fn;
1033   newargs[1] = arg_list;
1034
1035   rval = Fapply (2, newargs);
1036   signal_fake_event ();
1037
1038   if (args[n_args].type != GTK_TYPE_NONE)
1039     lisp_to_gtk_ret_type (rval, &args[n_args]);
1040
1041   UNGCPRO;
1042 }
1043
1044 DEFUN ("gtk-signal-connect", Fgtk_signal_connect, 3, 6, 0, /*
1045 */
1046        (obj, name, func, cb_data, object_signal, after_p))
1047 {
1048   int c_after;
1049   int c_object_signal;
1050   GUI_ID id = 0;
1051
1052   CHECK_GTK_OBJECT (obj);
1053
1054   if (SYMBOLP (name))
1055     name = Fsymbol_name (name);
1056
1057   CHECK_STRING (name);
1058
1059   if (NILP (object_signal))
1060     c_object_signal = 0;
1061   else
1062     c_object_signal = 1;
1063
1064   if (NILP (after_p))
1065     c_after = 0;
1066   else
1067     c_after = 1;
1068
1069   id = new_gui_id ();
1070   func = Fcons (cb_data, func);
1071   func = Fcons (make_int (id), func);
1072
1073   gcpro_popup_callbacks (id, func);
1074
1075   gtk_signal_connect_full (XGTK_OBJECT (obj)->object, (char *) XSTRING_DATA (name),
1076                            NULL, __internal_callback_marshal, LISP_TO_VOID (func),
1077                            __internal_callback_destroy, c_object_signal, c_after);
1078   return (Qt);
1079 }
1080
1081 \f
1082 /* GTK_TYPE_BOXED wrapper for Emacs lisp */
1083 static void
1084 emacs_gtk_boxed_printer (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag)
1085 {
1086   char buf[200];
1087
1088   if (print_readably)
1089     error ("printing unreadable object #<GtkBoxed %p>", XGTK_BOXED (obj)->object);
1090
1091   write_c_string ("#<GtkBoxed (", printcharfun);
1092   write_c_string (gtk_type_name (XGTK_BOXED (obj)->object_type), printcharfun);
1093   sprintf (buf, ") %p>", (void *) XGTK_BOXED (obj)->object);
1094   write_c_string (buf, printcharfun);
1095 }
1096
1097 static int
1098 emacs_gtk_boxed_equality (Lisp_Object o1, Lisp_Object o2, int depth)
1099 {
1100   emacs_gtk_boxed_data *data1 = XGTK_BOXED(o1);
1101   emacs_gtk_boxed_data *data2 = XGTK_BOXED(o2);
1102
1103   return ((data1->object == data2->object) &&
1104           (data1->object_type == data2->object_type));
1105 }
1106
1107 static unsigned long
1108 emacs_gtk_boxed_hash (Lisp_Object obj, int depth)
1109 {
1110   emacs_gtk_boxed_data *data = XGTK_BOXED(obj);
1111   return (HASH2 ((unsigned long)data->object, data->object_type));
1112 }
1113
1114 DEFINE_LRECORD_IMPLEMENTATION_WITH_PROPS ("GtkBoxed", emacs_gtk_boxed,
1115                                           0, /* marker function */
1116                                           emacs_gtk_boxed_printer, /* print function */
1117                                           0, /* nuker */
1118                                           emacs_gtk_boxed_equality, /* equality */
1119                                           emacs_gtk_boxed_hash, /* hash */
1120                                           NULL, /* desc */
1121                                           0, /* get prop */
1122                                           0, /* put prop */
1123                                           0, /* rem prop */
1124                                           0, /* plist */
1125                                           emacs_gtk_boxed_data);
1126
1127 /* Currently defined GTK_TYPE_BOXED structures are:
1128
1129    GtkAccelGroup -
1130    GtkSelectionData -
1131    GtkStyle -
1132    GtkCTreeNode -
1133    GdkColormap -
1134    GdkVisual -
1135    GdkFont -
1136    GdkWindow -
1137    GdkDragContext -
1138    GdkEvent -
1139    GdkColor -
1140 */
1141 static emacs_gtk_boxed_data *
1142 allocate_emacs_gtk_boxed_data (void)
1143 {
1144   emacs_gtk_boxed_data *data = alloc_lcrecord_type (emacs_gtk_boxed_data,
1145                                                     &lrecord_emacs_gtk_boxed);
1146
1147   data->object = NULL;
1148   data->object_type = GTK_TYPE_INVALID;
1149
1150   return (data);
1151 }
1152
1153 Lisp_Object build_gtk_boxed (void *obj, GtkType t)
1154 {
1155   Lisp_Object retval = Qnil;
1156   emacs_gtk_boxed_data *data = NULL;
1157
1158   if (GTK_FUNDAMENTAL_TYPE (t) != GTK_TYPE_BOXED)
1159     ABORT();
1160
1161   data = allocate_emacs_gtk_boxed_data ();
1162   data->object = obj;
1163   data->object_type = t;
1164
1165   XSETGTK_BOXED (retval, data);
1166
1167   return (retval);
1168 }
1169
1170 \f
1171 /* The automatically generated structure access routines */
1172 #include "emacs-widget-accessors.c"
1173
1174 /* The hand generated funky functions that we can't just import using the FFI */
1175 #include "ui-byhand.c"
1176
1177 /* The glade support */
1178 #include "glade.c"
1179
1180 \f
1181 /* Type manipulation */
1182 DEFUN ("gtk-fundamental-type", Fgtk_fundamental_type, 1, 1, 0, /*
1183 Load a shared library DLL into XEmacs.  No initialization routines are required.
1184 This is for loading dependency DLLs into XEmacs.
1185 */
1186        (type))
1187 {
1188   GtkType t;
1189
1190   if (SYMBOLP (type))
1191     type = Fsymbol_name (type);
1192
1193   CHECK_STRING (type);
1194
1195   t = gtk_type_from_name ((char *) XSTRING_DATA (type));
1196
1197   if (t == GTK_TYPE_INVALID)
1198     {
1199       signal_simple_error ("Not a GTK type", type);
1200     }
1201   return (make_int (GTK_FUNDAMENTAL_TYPE (t)));
1202 }
1203
1204 DEFUN ("gtk-object-type", Fgtk_object_type, 1, 1, 0, /*
1205 Return the GtkType of OBJECT.
1206 */
1207        (object))
1208 {
1209   CHECK_GTK_OBJECT (object);
1210   return (make_int (GTK_OBJECT_TYPE (XGTK_OBJECT (object)->object)));
1211 }
1212
1213 DEFUN ("gtk-describe-type", Fgtk_describe_type, 1, 1, 0, /*
1214 Returns a cons of two lists describing the Gtk object TYPE.
1215 The car is a list of all the signals that it will emit.
1216 The cdr is a list of all the magic properties it has.
1217 */
1218        (type))
1219 {
1220   Lisp_Object rval, signals, props;
1221   GtkType t;
1222
1223   props = signals = rval = Qnil;
1224
1225   if (SYMBOLP (type))
1226     {
1227       type = Fsymbol_name (type);
1228     }
1229
1230   if (STRINGP (type))
1231     {
1232       t = gtk_type_from_name (XSTRING_DATA (type));
1233       if (t == GTK_TYPE_INVALID)
1234         {
1235           signal_simple_error ("Not a GTK type", type);
1236         }
1237     }
1238   else
1239     {
1240       CHECK_INT (type);
1241       t = XINT (type);
1242     }
1243
1244   if (GTK_FUNDAMENTAL_TYPE (t) != GTK_TYPE_OBJECT)
1245     {
1246       signal_simple_error ("Not a GtkObject", type);
1247     }
1248
1249   /* Need to do stupid shit like this to get the args
1250   ** registered... damn GTK and its lazy loading
1251   */
1252   {
1253     GtkArg args[3];
1254     GtkObject *obj = gtk_object_newv (t, 0, args);
1255
1256     gtk_object_destroy(obj);
1257   }
1258
1259   do
1260     {
1261       guint i;
1262
1263       /* Do the magic arguments first */
1264       {
1265         GtkArg *args;
1266         guint32 *flags;
1267         guint n_args;
1268
1269         args = gtk_object_query_args(t,&flags,&n_args);
1270
1271         for (i = 0; i < n_args; i++)
1272           {
1273             props = Fcons (Fcons (intern (gtk_type_name(args[i].type)),
1274                                   intern (args[i].name)), props);
1275           }
1276
1277         g_free (args);
1278         g_free (flags);
1279       }
1280
1281       /* Now the signals */
1282       {
1283         GtkObjectClass *klass;
1284         GtkSignalQuery *query;
1285         guint32 *gtk_signals;
1286         guint n_signals;
1287
1288         klass = (GtkObjectClass *) gtk_type_class (t);
1289         gtk_signals = klass->signals;
1290         n_signals = klass->nsignals;
1291
1292         for (i = 0; i < n_signals; i++)
1293           {
1294             Lisp_Object params = Qnil;
1295
1296             query = gtk_signal_query (gtk_signals[i]);
1297
1298             if (query)
1299               {
1300                 if (query->nparams)
1301                   {
1302                     int j;
1303
1304                     for (j = query->nparams - 1; j >= 0; j--)
1305                       {
1306                         params = Fcons (intern (gtk_type_name (query->params[j])), params);
1307                       }
1308                   }
1309
1310                 signals = Fcons (Fcons (intern (gtk_type_name (query->return_val)),
1311                                         Fcons (intern (query->signal_name),
1312                                                params)),
1313                                  signals);
1314
1315                 g_free (query);
1316               }
1317           }
1318       }
1319       t = gtk_type_parent(t);
1320     } while (t != GTK_TYPE_INVALID);
1321
1322   rval = Fcons (signals, props);
1323
1324   return (rval);
1325 }
1326
1327 \f
1328 void
1329 syms_of_ui_gtk (void)
1330 {
1331   INIT_LRECORD_IMPLEMENTATION (emacs_ffi);
1332   INIT_LRECORD_IMPLEMENTATION (emacs_gtk_object);
1333   INIT_LRECORD_IMPLEMENTATION (emacs_gtk_boxed);
1334   defsymbol (&Qemacs_ffip, "emacs-ffi-p");
1335   defsymbol (&Qemacs_gtk_objectp, "emacs-gtk-object-p");
1336   defsymbol (&Qemacs_gtk_boxedp, "emacs-gtk-boxed-p");
1337   defsymbol (&Qvoid, "void");
1338   DEFSUBR (Fdll_load);
1339   DEFSUBR (Fgtk_import_function_internal);
1340   DEFSUBR (Fgtk_import_variable_internal);
1341   DEFSUBR (Fgtk_signal_connect);
1342   DEFSUBR (Fgtk_call_function);
1343   DEFSUBR (Fgtk_fundamental_type);
1344   DEFSUBR (Fgtk_object_type);
1345   DEFSUBR (Fgtk_describe_type);
1346   syms_of_widget_accessors ();
1347   syms_of_ui_byhand ();
1348   syms_of_glade ();
1349 }
1350
1351 void
1352 vars_of_ui_gtk (void)
1353 {
1354   Fprovide (intern ("gtk-ui"));
1355   DEFVAR_LISP ("gtk-enumeration-info", &Venumeration_info /*
1356 A hashtable holding type information about GTK enumerations and flags.
1357 Do NOT modify unless you really understand ui-gtk.c.
1358 */);
1359
1360   Venumeration_info = Qnil;
1361   vars_of_glade ();
1362 }
1363
1364 \f
1365 /* Various utility functions */
1366 void describe_gtk_arg (GtkArg *arg)
1367 {
1368   GtkArg a = *arg;
1369
1370   switch (GTK_FUNDAMENTAL_TYPE (a.type))
1371     {
1372       /* flag types */
1373     case GTK_TYPE_CHAR:
1374       stderr_out ("char: %c\n", GTK_VALUE_CHAR (a));
1375       break;
1376     case GTK_TYPE_UCHAR:
1377       stderr_out ("uchar: %c\n", GTK_VALUE_CHAR (a));
1378       break;
1379     case GTK_TYPE_BOOL:
1380       stderr_out ("uchar: %s\n", GTK_VALUE_BOOL (a) ? "true" : "false");
1381       break;
1382     case GTK_TYPE_INT:
1383       stderr_out ("int: %d\n", GTK_VALUE_INT (a));
1384       break;
1385     case GTK_TYPE_UINT:
1386       stderr_out ("uint: %du\n", GTK_VALUE_UINT (a));
1387       break;
1388     case GTK_TYPE_LONG:
1389       stderr_out ("long: %ld\n", GTK_VALUE_LONG (a));
1390       break;
1391     case GTK_TYPE_ULONG:
1392       stderr_out ("ulong: %lu\n", GTK_VALUE_ULONG (a));
1393       break;
1394     case GTK_TYPE_FLOAT:
1395       stderr_out ("float: %g\n", GTK_VALUE_FLOAT (a));
1396       break;
1397     case GTK_TYPE_DOUBLE:
1398       stderr_out ("double: %f\n", GTK_VALUE_DOUBLE (a));
1399       break;
1400     case GTK_TYPE_STRING:
1401       stderr_out ("string: %s\n", GTK_VALUE_STRING (a));
1402       break;
1403     case GTK_TYPE_ENUM:
1404     case GTK_TYPE_FLAGS:
1405       stderr_out ("%s: ", (a.type == GTK_TYPE_ENUM) ? "enum" : "flag");
1406       {
1407         GtkEnumValue *vals = gtk_type_enum_get_values (a.type);
1408
1409         while (vals && vals->value_name && (vals->value != GTK_VALUE_ENUM(a))) vals++;
1410
1411         stderr_out ("%s\n", vals ? vals->value_name : "!!! UNKNOWN ENUM VALUE !!!");
1412       }
1413       break;
1414     case GTK_TYPE_BOXED:
1415       stderr_out ("boxed: %p\n", GTK_VALUE_BOXED (a));
1416       break;
1417     case GTK_TYPE_POINTER:
1418       stderr_out ("pointer: %p\n", GTK_VALUE_BOXED (a));
1419       break;
1420
1421       /* structured types */
1422     case GTK_TYPE_SIGNAL:
1423     case GTK_TYPE_ARGS: /* This we can do as a list of values */
1424       ABORT();
1425     case GTK_TYPE_CALLBACK:
1426       stderr_out ("callback fn: ...\n");
1427       break;
1428     case GTK_TYPE_C_CALLBACK:
1429     case GTK_TYPE_FOREIGN:
1430       ABORT();
1431
1432       /* base type of the object system */
1433     case GTK_TYPE_OBJECT:
1434       if (GTK_VALUE_OBJECT (a))
1435         stderr_out ("object: %s\n", gtk_type_name (GTK_OBJECT_TYPE (GTK_VALUE_OBJECT (a))));
1436       else
1437         stderr_out ("object: NULL\n");
1438       break;
1439
1440     default:
1441       ABORT();
1442     }
1443 }
1444
1445 Lisp_Object gtk_type_to_lisp (GtkArg *arg)
1446 {
1447   switch (GTK_FUNDAMENTAL_TYPE (arg->type))
1448     {
1449     case GTK_TYPE_NONE:
1450       return (Qnil);
1451     case GTK_TYPE_CHAR:
1452       return (make_char (GTK_VALUE_CHAR (*arg)));
1453     case GTK_TYPE_UCHAR:
1454       return (make_char (GTK_VALUE_UCHAR (*arg)));
1455     case GTK_TYPE_BOOL:
1456       return (GTK_VALUE_BOOL (*arg) ? Qt : Qnil);
1457     case GTK_TYPE_INT:
1458       return (make_int (GTK_VALUE_INT (*arg)));
1459     case GTK_TYPE_UINT:
1460       return (make_int (GTK_VALUE_INT (*arg)));
1461     case GTK_TYPE_LONG:         /* I think these are wrong! */
1462       return (make_int (GTK_VALUE_INT (*arg)));
1463     case GTK_TYPE_ULONG:        /* I think these are wrong! */
1464       return (make_int (GTK_VALUE_INT (*arg)));
1465     case GTK_TYPE_FLOAT:
1466       return (make_float (GTK_VALUE_FLOAT (*arg)));
1467     case GTK_TYPE_DOUBLE:
1468       return (make_float (GTK_VALUE_DOUBLE (*arg)));
1469     case GTK_TYPE_STRING:
1470       return (build_string (GTK_VALUE_STRING (*arg)));
1471     case GTK_TYPE_FLAGS:
1472       return (flags_to_list (GTK_VALUE_FLAGS (*arg), arg->type));
1473     case GTK_TYPE_ENUM:
1474       return (enum_to_symbol (GTK_VALUE_ENUM (*arg), arg->type));
1475     case GTK_TYPE_BOXED:
1476       if (arg->type == GTK_TYPE_GDK_EVENT)
1477         {
1478           return (gdk_event_to_emacs_event((GdkEvent *) GTK_VALUE_BOXED (*arg)));
1479         }
1480
1481       if (GTK_VALUE_BOXED (*arg))
1482         return (build_gtk_boxed (GTK_VALUE_BOXED (*arg), arg->type));
1483       else
1484         return (Qnil);
1485     case GTK_TYPE_POINTER:
1486       if (GTK_VALUE_POINTER (*arg))
1487         {
1488           Lisp_Object rval;
1489
1490           VOID_TO_LISP (rval, GTK_VALUE_POINTER (*arg));
1491           return (rval);
1492         }
1493       else
1494         return (Qnil);
1495     case GTK_TYPE_OBJECT:
1496       if (GTK_VALUE_OBJECT (*arg))
1497         return (build_gtk_object (GTK_VALUE_OBJECT (*arg)));
1498       else
1499         return (Qnil);
1500
1501     case GTK_TYPE_CALLBACK:
1502       {
1503         Lisp_Object rval;
1504
1505         VOID_TO_LISP (rval, GTK_VALUE_CALLBACK (*arg).data);
1506
1507         return (rval);
1508       }
1509
1510     default:
1511       if (GTK_FUNDAMENTAL_TYPE (arg->type) == GTK_TYPE_LISTOF)
1512         {
1513           if (!GTK_VALUE_POINTER (*arg))
1514             return (Qnil);
1515           else
1516             {
1517               return (xemacs_gtklist_to_list (arg));
1518             }
1519         }
1520       stderr_out ("Do not know how to convert `%s' to lisp!\n", gtk_type_name (arg->type));
1521       ABORT ();
1522     }
1523   /* This is chuck reminding GCC to... SHUT UP! */
1524   return (Qnil);
1525 }
1526
1527 int lisp_to_gtk_type (Lisp_Object obj, GtkArg *arg)
1528 {
1529   switch (GTK_FUNDAMENTAL_TYPE (arg->type))
1530     {
1531       /* flag types */
1532     case GTK_TYPE_NONE:
1533       return (0);
1534     case GTK_TYPE_CHAR:
1535       {
1536         Emchar c;
1537
1538         CHECK_CHAR_COERCE_INT (obj);
1539         c = XCHAR (obj);
1540         GTK_VALUE_CHAR (*arg) = c;
1541       }
1542       break;
1543     case GTK_TYPE_UCHAR:
1544       {
1545         Emchar c;
1546
1547         CHECK_CHAR_COERCE_INT (obj);
1548         c = XCHAR (obj);
1549         GTK_VALUE_CHAR (*arg) = c;
1550       }
1551       break;
1552     case GTK_TYPE_BOOL:
1553       GTK_VALUE_BOOL (*arg) = NILP (obj) ? FALSE : TRUE;
1554       break;
1555     case GTK_TYPE_INT:
1556     case GTK_TYPE_UINT:
1557       if (NILP (obj) || EQ (Qt, obj))
1558         {
1559           /* For we are a kind mistress and allow sending t/nil for
1560              1/0 to stupid GTK functions that say they take guint or
1561              gint in the header files, but actually treat it like a
1562              bool.  *sigh*
1563           */
1564           GTK_VALUE_INT(*arg) = NILP (obj) ? 0 : 1;
1565         }
1566       else
1567         {
1568           CHECK_INT (obj);
1569           GTK_VALUE_INT(*arg) = XINT (obj);
1570         }
1571       break;
1572     case GTK_TYPE_LONG:
1573     case GTK_TYPE_ULONG:
1574       ABORT();
1575     case GTK_TYPE_FLOAT:
1576       CHECK_INT_OR_FLOAT (obj);
1577       GTK_VALUE_FLOAT(*arg) = extract_float (obj);
1578       break;
1579     case GTK_TYPE_DOUBLE:
1580       CHECK_INT_OR_FLOAT (obj);
1581       GTK_VALUE_DOUBLE(*arg) = extract_float (obj);
1582       break;
1583     case GTK_TYPE_STRING:
1584       if (NILP (obj))
1585         GTK_VALUE_STRING (*arg) = NULL;
1586       else
1587         {
1588           CHECK_STRING (obj);
1589           GTK_VALUE_STRING (*arg) = (char *) XSTRING_DATA (obj);
1590         }
1591       break;
1592     case GTK_TYPE_ENUM:
1593     case GTK_TYPE_FLAGS:
1594       /* Convert a lisp symbol to a GTK enum */
1595       GTK_VALUE_ENUM(*arg) = lisp_to_flag (obj, arg->type);
1596       break;
1597     case GTK_TYPE_BOXED:
1598       if (NILP (obj))
1599         {
1600           GTK_VALUE_BOXED(*arg) = NULL;
1601         }
1602       else if (GTK_BOXEDP (obj))
1603         {
1604           GTK_VALUE_BOXED(*arg) = XGTK_BOXED (obj)->object;
1605         }
1606       else if (arg->type == GTK_TYPE_STYLE)
1607         {
1608           obj = Ffind_face (obj);
1609           CHECK_FACE (obj);
1610           GTK_VALUE_BOXED(*arg) = face_to_style (obj);
1611         }
1612       else if (arg->type == GTK_TYPE_GDK_GC)
1613         {
1614           obj = Ffind_face (obj);
1615           CHECK_FACE (obj);
1616           GTK_VALUE_BOXED(*arg) = face_to_gc (obj);
1617         }
1618       else if (arg->type == GTK_TYPE_GDK_WINDOW)
1619         {
1620           if (GLYPHP (obj))
1621             {
1622               Lisp_Object window = Fselected_window (Qnil);
1623               Lisp_Object instance = glyph_image_instance (obj, window, ERROR_ME_NOT, 1);
1624               struct Lisp_Image_Instance *p = XIMAGE_INSTANCE (instance);
1625
1626               switch (XIMAGE_INSTANCE_TYPE (instance))
1627                 {
1628                 case IMAGE_TEXT:
1629                 case IMAGE_POINTER:
1630                 case IMAGE_SUBWINDOW:
1631                 case IMAGE_NOTHING:
1632                   GTK_VALUE_BOXED(*arg) = NULL;
1633                   break;
1634
1635                 case IMAGE_MONO_PIXMAP:
1636                 case IMAGE_COLOR_PIXMAP:
1637                   GTK_VALUE_BOXED(*arg) = IMAGE_INSTANCE_GTK_PIXMAP (p);
1638                   break;
1639                 }
1640             }
1641           else if (GTK_OBJECTP (obj) && GTK_IS_WIDGET (XGTK_OBJECT (obj)->object))
1642             {
1643               GTK_VALUE_BOXED(*arg) = GTK_WIDGET (XGTK_OBJECT (obj))->window;
1644             }
1645           else
1646             {
1647               signal_simple_error ("Don't know how to convert object to GDK_WINDOW", obj);
1648             }
1649           break;
1650         }
1651       else if (arg->type == GTK_TYPE_GDK_COLOR)
1652         {
1653           if (COLOR_SPECIFIERP (obj))
1654             {
1655               /* If it is a specifier, we just convert it to an
1656                  instance, and let the ifs below handle it.
1657               */
1658               obj = Fspecifier_instance (obj, Qnil, Qnil, Qnil);
1659             }
1660
1661           if (COLOR_INSTANCEP (obj))
1662             {
1663               /* Easiest one */
1664               GTK_VALUE_BOXED(*arg) = COLOR_INSTANCE_GTK_COLOR (XCOLOR_INSTANCE (obj));
1665             }
1666           else if (STRINGP (obj))
1667             {
1668               signal_simple_error ("Please use a color specifier or instance, not a string", obj);
1669             }
1670           else
1671             {
1672               signal_simple_error ("Don't know hot to convert to GdkColor", obj);
1673             }
1674         }
1675       else if (arg->type == GTK_TYPE_GDK_FONT)
1676         {
1677           if (SYMBOLP (obj))
1678             {
1679               /* If it is a symbol, we treat that as a face name */
1680               obj = Ffind_face (obj);
1681             }
1682
1683           if (FACEP (obj))
1684             {
1685               /* If it is a face, we just grab the font specifier, and
1686                  cascade down until we finally reach a FONT_INSTANCE
1687               */
1688               obj = Fget (obj, Qfont, Qnil);
1689             }
1690
1691           if (FONT_SPECIFIERP (obj))
1692             {
1693               /* If it is a specifier, we just convert it to an
1694                  instance, and let the ifs below handle it
1695               */
1696               obj = Fspecifier_instance (obj, Qnil, Qnil, Qnil);
1697             }
1698
1699           if (FONT_INSTANCEP (obj))
1700             {
1701               /* Easiest one */
1702               GTK_VALUE_BOXED(*arg) = FONT_INSTANCE_GTK_FONT (XFONT_INSTANCE (obj));
1703             }
1704           else if (STRINGP (obj))
1705             {
1706               signal_simple_error ("Please use a font specifier or instance, not a string", obj);
1707             }
1708           else
1709             {
1710               signal_simple_error ("Don't know hot to convert to GdkColor", obj);
1711             }
1712         }
1713       else
1714         {
1715           /* Unknown type to convert to boxed */
1716           stderr_out ("Don't know how to convert to boxed!\n");
1717           GTK_VALUE_BOXED(*arg) = NULL;
1718         }
1719       break;
1720
1721     case GTK_TYPE_POINTER:
1722       if (NILP (obj))
1723         GTK_VALUE_POINTER(*arg) = NULL;
1724       else
1725         GTK_VALUE_POINTER(*arg) = LISP_TO_VOID (obj);
1726       break;
1727
1728       /* structured types */
1729     case GTK_TYPE_SIGNAL:
1730     case GTK_TYPE_ARGS: /* This we can do as a list of values */
1731     case GTK_TYPE_C_CALLBACK:
1732     case GTK_TYPE_FOREIGN:
1733       stderr_out ("Do not know how to convert `%s' from lisp!\n", gtk_type_name (arg->type));
1734       return (-1);
1735
1736 #if 0
1737       /* #### BILL! */
1738       /* This is not used, and does not work with union type */
1739     case GTK_TYPE_CALLBACK:
1740       {
1741         GUI_ID id;
1742
1743         id = new_gui_id ();
1744         obj = Fcons (Qnil, obj); /* Empty data */
1745         obj = Fcons (make_int (id), obj);
1746
1747         gcpro_popup_callbacks (id, obj);
1748
1749         GTK_VALUE_CALLBACK(*arg).marshal = __internal_callback_marshal;
1750         GTK_VALUE_CALLBACK(*arg).data = (gpointer) obj;
1751         GTK_VALUE_CALLBACK(*arg).notify = __internal_callback_destroy;
1752       }
1753       break;
1754 #endif
1755
1756       /* base type of the object system */
1757     case GTK_TYPE_OBJECT:
1758       if (NILP (obj))
1759         GTK_VALUE_OBJECT (*arg) = NULL;
1760       else
1761         {
1762           CHECK_GTK_OBJECT (obj);
1763           if (XGTK_OBJECT (obj)->alive_p)
1764             GTK_VALUE_OBJECT (*arg) = XGTK_OBJECT (obj)->object;
1765           else
1766             signal_simple_error ("Attempting to pass dead object to GTK function", obj);
1767         }
1768       break;
1769
1770     default:
1771       if (GTK_FUNDAMENTAL_TYPE (arg->type) == GTK_TYPE_ARRAY)
1772         {
1773           if (NILP (obj))
1774             GTK_VALUE_POINTER(*arg) = NULL;
1775           else
1776             {
1777               xemacs_list_to_array (obj, arg);
1778             }
1779         }
1780       else if (GTK_FUNDAMENTAL_TYPE (arg->type) == GTK_TYPE_LISTOF)
1781         {
1782           if (NILP (obj))
1783             GTK_VALUE_POINTER(*arg) = NULL;
1784           else
1785             {
1786               xemacs_list_to_gtklist (obj, arg);
1787             }
1788         }
1789       else
1790         {
1791           stderr_out ("Do not know how to convert `%s' from lisp!\n", gtk_type_name (arg->type));
1792           ABORT();
1793         }
1794       break;
1795     }
1796
1797   return (0);
1798 }
1799
1800 /* Convert lisp types to GTK return types.  This is identical to
1801    lisp_to_gtk_type() except that the macro used to set the value is
1802    different.
1803
1804    ### There should be some way of combining these two functions.
1805 */
1806 int lisp_to_gtk_ret_type (Lisp_Object obj, GtkArg *arg)
1807 {
1808   switch (GTK_FUNDAMENTAL_TYPE (arg->type))
1809     {
1810       /* flag types */
1811     case GTK_TYPE_NONE:
1812       return (0);
1813     case GTK_TYPE_CHAR:
1814       {
1815         Emchar c;
1816
1817         CHECK_CHAR_COERCE_INT (obj);
1818         c = XCHAR (obj);
1819         *(GTK_RETLOC_CHAR (*arg)) = c;
1820       }
1821       break;
1822     case GTK_TYPE_UCHAR:
1823       {
1824         Emchar c;
1825
1826         CHECK_CHAR_COERCE_INT (obj);
1827         c = XCHAR (obj);
1828         *(GTK_RETLOC_CHAR (*arg)) = c;
1829       }
1830       break;
1831     case GTK_TYPE_BOOL:
1832       *(GTK_RETLOC_BOOL (*arg)) = NILP (obj) ? FALSE : TRUE;
1833       break;
1834     case GTK_TYPE_INT:
1835     case GTK_TYPE_UINT:
1836       if (NILP (obj) || EQ (Qt, obj))
1837         {
1838           /* For we are a kind mistress and allow sending t/nil for
1839              1/0 to stupid GTK functions that say they take guint or
1840              gint in the header files, but actually treat it like a
1841              bool.  *sigh*
1842           */
1843           *(GTK_RETLOC_INT(*arg)) = NILP (obj) ? 0 : 1;
1844         }
1845       else
1846         {
1847           CHECK_INT (obj);
1848           *(GTK_RETLOC_INT(*arg)) = XINT (obj);
1849         }
1850       break;
1851     case GTK_TYPE_LONG:
1852     case GTK_TYPE_ULONG:
1853       ABORT();
1854     case GTK_TYPE_FLOAT:
1855       CHECK_INT_OR_FLOAT (obj);
1856       *(GTK_RETLOC_FLOAT(*arg)) = extract_float (obj);
1857       break;
1858     case GTK_TYPE_DOUBLE:
1859       CHECK_INT_OR_FLOAT (obj);
1860       *(GTK_RETLOC_DOUBLE(*arg)) = extract_float (obj);
1861       break;
1862     case GTK_TYPE_STRING:
1863       if (NILP (obj))
1864         *(GTK_RETLOC_STRING (*arg)) = NULL;
1865       else
1866         {
1867           CHECK_STRING (obj);
1868           *(GTK_RETLOC_STRING (*arg)) = (char *) XSTRING_DATA (obj);
1869         }
1870       break;
1871     case GTK_TYPE_ENUM:
1872     case GTK_TYPE_FLAGS:
1873       /* Convert a lisp symbol to a GTK enum */
1874       *(GTK_RETLOC_ENUM(*arg)) = lisp_to_flag (obj, arg->type);
1875       break;
1876     case GTK_TYPE_BOXED:
1877       if (NILP (obj))
1878         {
1879           *(GTK_RETLOC_BOXED(*arg)) = NULL;
1880         }
1881       else if (GTK_BOXEDP (obj))
1882         {
1883           *(GTK_RETLOC_BOXED(*arg)) = XGTK_BOXED (obj)->object;
1884         }
1885       else if (arg->type == GTK_TYPE_STYLE)
1886         {
1887           obj = Ffind_face (obj);
1888           CHECK_FACE (obj);
1889           *(GTK_RETLOC_BOXED(*arg)) = face_to_style (obj);
1890         }
1891       else if (arg->type == GTK_TYPE_GDK_GC)
1892         {
1893           obj = Ffind_face (obj);
1894           CHECK_FACE (obj);
1895           *(GTK_RETLOC_BOXED(*arg)) = face_to_gc (obj);
1896         }
1897       else if (arg->type == GTK_TYPE_GDK_WINDOW)
1898         {
1899           if (GLYPHP (obj))
1900             {
1901               Lisp_Object window = Fselected_window (Qnil);
1902               Lisp_Object instance = glyph_image_instance (obj, window, ERROR_ME_NOT, 1);
1903               struct Lisp_Image_Instance *p = XIMAGE_INSTANCE (instance);
1904
1905               switch (XIMAGE_INSTANCE_TYPE (instance))
1906                 {
1907                 case IMAGE_TEXT:
1908                 case IMAGE_POINTER:
1909                 case IMAGE_SUBWINDOW:
1910                 case IMAGE_NOTHING:
1911                   *(GTK_RETLOC_BOXED(*arg)) = NULL;
1912                   break;
1913
1914                 case IMAGE_MONO_PIXMAP:
1915                 case IMAGE_COLOR_PIXMAP:
1916                   *(GTK_RETLOC_BOXED(*arg)) = IMAGE_INSTANCE_GTK_PIXMAP (p);
1917                   break;
1918                 }
1919             }
1920           else if (GTK_OBJECTP (obj) && GTK_IS_WIDGET (XGTK_OBJECT (obj)->object))
1921             {
1922               *(GTK_RETLOC_BOXED(*arg)) = GTK_WIDGET (XGTK_OBJECT (obj))->window;
1923             }
1924           else
1925             {
1926               signal_simple_error ("Don't know how to convert object to GDK_WINDOW", obj);
1927             }
1928           break;
1929         }
1930       else if (arg->type == GTK_TYPE_GDK_COLOR)
1931         {
1932           if (COLOR_SPECIFIERP (obj))
1933             {
1934               /* If it is a specifier, we just convert it to an
1935                  instance, and let the ifs below handle it.
1936               */
1937               obj = Fspecifier_instance (obj, Qnil, Qnil, Qnil);
1938             }
1939
1940           if (COLOR_INSTANCEP (obj))
1941             {
1942               /* Easiest one */
1943               *(GTK_RETLOC_BOXED(*arg)) = COLOR_INSTANCE_GTK_COLOR (XCOLOR_INSTANCE (obj));
1944             }
1945           else if (STRINGP (obj))
1946             {
1947               signal_simple_error ("Please use a color specifier or instance, not a string", obj);
1948             }
1949           else
1950             {
1951               signal_simple_error ("Don't know hot to convert to GdkColor", obj);
1952             }
1953         }
1954       else if (arg->type == GTK_TYPE_GDK_FONT)
1955         {
1956           if (SYMBOLP (obj))
1957             {
1958               /* If it is a symbol, we treat that as a face name */
1959               obj = Ffind_face (obj);
1960             }
1961
1962           if (FACEP (obj))
1963             {
1964               /* If it is a face, we just grab the font specifier, and
1965                  cascade down until we finally reach a FONT_INSTANCE
1966               */
1967               obj = Fget (obj, Qfont, Qnil);
1968             }
1969
1970           if (FONT_SPECIFIERP (obj))
1971             {
1972               /* If it is a specifier, we just convert it to an
1973                  instance, and let the ifs below handle it
1974               */
1975               obj = Fspecifier_instance (obj, Qnil, Qnil, Qnil);
1976             }
1977
1978           if (FONT_INSTANCEP (obj))
1979             {
1980               /* Easiest one */
1981               *(GTK_RETLOC_BOXED(*arg)) = FONT_INSTANCE_GTK_FONT (XFONT_INSTANCE (obj));
1982             }
1983           else if (STRINGP (obj))
1984             {
1985               signal_simple_error ("Please use a font specifier or instance, not a string", obj);
1986             }
1987           else
1988             {
1989               signal_simple_error ("Don't know hot to convert to GdkColor", obj);
1990             }
1991         }
1992       else
1993         {
1994           /* Unknown type to convert to boxed */
1995           stderr_out ("Don't know how to convert to boxed!\n");
1996           *(GTK_RETLOC_BOXED(*arg)) = NULL;
1997         }
1998       break;
1999
2000     case GTK_TYPE_POINTER:
2001       if (NILP (obj))
2002         *(GTK_RETLOC_POINTER(*arg)) = NULL;
2003       else
2004         *(GTK_RETLOC_POINTER(*arg)) = LISP_TO_VOID (obj);
2005       break;
2006
2007       /* structured types */
2008     case GTK_TYPE_SIGNAL:
2009     case GTK_TYPE_ARGS: /* This we can do as a list of values */
2010     case GTK_TYPE_C_CALLBACK:
2011     case GTK_TYPE_FOREIGN:
2012       stderr_out ("Do not know how to convert `%s' from lisp!\n", gtk_type_name (arg->type));
2013       return (-1);
2014
2015 #if 0
2016       /* #### BILL! */
2017       /* This is not used, and does not work with union type */
2018     case GTK_TYPE_CALLBACK:
2019       {
2020         GUI_ID id;
2021
2022         id = new_gui_id ();
2023         obj = Fcons (Qnil, obj); /* Empty data */
2024         obj = Fcons (make_int (id), obj);
2025
2026         gcpro_popup_callbacks (id, obj);
2027
2028         *(GTK_RETLOC_CALLBACK(*arg)).marshal = __internal_callback_marshal;
2029         *(GTK_RETLOC_CALLBACK(*arg)).data = (gpointer) obj;
2030         *(GTK_RETLOC_CALLBACK(*arg)).notify = __internal_callback_destroy;
2031       }
2032       break;
2033 #endif
2034
2035       /* base type of the object system */
2036     case GTK_TYPE_OBJECT:
2037       if (NILP (obj))
2038         *(GTK_RETLOC_OBJECT (*arg)) = NULL;
2039       else
2040         {
2041           CHECK_GTK_OBJECT (obj);
2042           if (XGTK_OBJECT (obj)->alive_p)
2043             *(GTK_RETLOC_OBJECT (*arg)) = XGTK_OBJECT (obj)->object;
2044           else
2045             signal_simple_error ("Attempting to pass dead object to GTK function", obj);
2046         }
2047       break;
2048
2049     default:
2050       if (GTK_FUNDAMENTAL_TYPE (arg->type) == GTK_TYPE_ARRAY)
2051         {
2052           if (NILP (obj))
2053             *(GTK_RETLOC_POINTER(*arg)) = NULL;
2054           else
2055             {
2056               xemacs_list_to_array (obj, arg);
2057             }
2058         }
2059       else if (GTK_FUNDAMENTAL_TYPE (arg->type) == GTK_TYPE_LISTOF)
2060         {
2061           if (NILP (obj))
2062             *(GTK_RETLOC_POINTER(*arg)) = NULL;
2063           else
2064             {
2065               xemacs_list_to_gtklist (obj, arg);
2066             }
2067         }
2068       else
2069         {
2070           stderr_out ("Do not know how to convert `%s' from lisp!\n", gtk_type_name (arg->type));
2071           ABORT();
2072         }
2073       break;
2074     }
2075
2076   return (0);
2077 }
2078
2079 /* This is used in glyphs-gtk.c as well */
2080 static Lisp_Object
2081 get_enumeration (GtkType t)
2082 {
2083   Lisp_Object alist;
2084
2085   if (NILP (Venumeration_info))
2086     {
2087       Venumeration_info = call2 (intern ("make-hashtable"), make_int (100), Qequal);
2088     }
2089
2090   alist = Fgethash (make_int (t), Venumeration_info, Qnil);
2091
2092   if (NILP (alist))
2093     {
2094       import_gtk_enumeration_internal (t);
2095       alist = Fgethash (make_int (t), Venumeration_info, Qnil);
2096     }
2097   return (alist);
2098 }
2099
2100 guint
2101 symbol_to_enum (Lisp_Object obj, GtkType t)
2102 {
2103   Lisp_Object alist = get_enumeration (t);
2104   Lisp_Object value = Qnil;
2105
2106   if (NILP (alist))
2107     {
2108       signal_simple_error ("Unkown enumeration", build_string (gtk_type_name (t)));
2109     }
2110
2111   value = Fassq (obj, alist);
2112
2113   if (NILP (value))
2114     {
2115       signal_simple_error ("Unknown value", obj);
2116     }
2117
2118   CHECK_INT (XCDR (value));
2119
2120   return (XINT (XCDR (value)));
2121 }
2122
2123 static guint
2124 lisp_to_flag (Lisp_Object obj, GtkType t)
2125 {
2126   guint val = 0;
2127
2128   if (NILP (obj))
2129     {
2130       /* Do nothing */
2131     }
2132   else if (SYMBOLP (obj))
2133     {
2134       val = symbol_to_enum (obj, t);
2135     }
2136   else if (LISTP (obj))
2137     {
2138       while (!NILP (obj))
2139         {
2140           val |= symbol_to_enum (XCAR (obj), t);
2141           obj = XCDR (obj);
2142         }
2143     }
2144   else
2145     {
2146       /* ABORT ()? */
2147     }
2148   return (val);
2149 }
2150
2151 static Lisp_Object
2152 flags_to_list (guint value, GtkType t)
2153 {
2154   Lisp_Object rval = Qnil;
2155   Lisp_Object alist = get_enumeration (t);
2156
2157   while (!NILP (alist))
2158     {
2159       if (value & XINT (XCDR (XCAR (alist))))
2160         {
2161           rval = Fcons (XCAR (XCAR (alist)), rval);
2162           value &= ~(XINT (XCDR (XCAR (alist))));
2163         }
2164       alist = XCDR (alist);
2165     }
2166   return (rval);
2167 }
2168
2169 static Lisp_Object
2170 enum_to_symbol (guint value, GtkType t)
2171 {
2172   Lisp_Object alist = get_enumeration (t);
2173   Lisp_Object cell = Qnil;
2174
2175   if (NILP (alist))
2176     {
2177       signal_simple_error ("Unkown enumeration", build_string (gtk_type_name (t)));
2178     }
2179
2180   cell = Frassq (make_int (value), alist);
2181
2182   return (NILP (cell) ? Qnil : XCAR (cell));
2183 }