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