(U-0002011D): Use `ideographic-radical@{ucs|cns}' and
[chise/xemacs-chise.git.1] / 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 }