3 ** Description: Creating 'real' UIs from lisp.
5 ** Created by: William M. Perry <wmperry@gnu.org>
6 ** Copyright (c) 2000 William M. Perry <wmperry@gnu.org>
13 #include "console-gtk.h"
14 #include "ui/device.h"
15 #include "ui/window.h"
16 #include "glyphs-gtk.h"
17 #include "objects-gtk.h"
23 #include "events/events.h"
26 /* XEmacs specific GTK types */
29 Lisp_Object Qemacs_ffip;
30 Lisp_Object Qemacs_gtk_objectp;
31 Lisp_Object Qemacs_gtk_boxedp;
33 Lisp_Object Venumeration_info;
35 static GHashTable *dll_cache;
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);
46 #define NIL_OR_VOID_P(x) (NILP (x) || EQ (x, Qvoid))
48 static void initialize_dll_cache(void)
51 dll_cache = g_hash_table_new(g_str_hash, g_str_equal);
53 g_hash_table_insert(dll_cache, "---XEmacs Internal Handle---",
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.
68 initialize_dll_cache();
70 /* If the dll name has a directory component in it, then we should
72 if (!NILP(Fstring_match(build_string("/"), dll, Qnil, Qnil)))
73 dll = Fexpand_file_name(dll, Qnil);
75 /* Check if we have already opened it first */
76 h = g_hash_table_lookup(dll_cache, XSTRING_DATA(dll));
79 h = dll_open((char *)XSTRING_DATA(dll));
82 g_hash_table_insert(dll_cache,
83 g_strdup(XSTRING_DATA(dll)), h);
85 signal_simple_error("dll_open error",
86 build_string(dll_error(NULL)));
89 return (h ? Qt : Qnil);
92 /* Gtk object importing */
93 EXFUN(Fgtk_import_type, 1);
95 static struct hash_table *internal_type_hash;
97 static int type_hash_equal(const void *arg1, const void *arg2)
99 return ((GtkType) arg1 == (GtkType) arg2);
102 static unsigned long type_hash_hash(const void *arg)
104 return ((unsigned long)arg);
107 static int type_already_imported_p(GtkType t)
111 /* These are cases that we don't need to import */
112 switch (GTK_FUNDAMENTAL_TYPE(t)) {
121 case GTK_TYPE_DOUBLE:
122 case GTK_TYPE_STRING:
124 case GTK_TYPE_POINTER:
125 case GTK_TYPE_SIGNAL:
127 case GTK_TYPE_CALLBACK:
128 case GTK_TYPE_C_CALLBACK:
129 case GTK_TYPE_FOREIGN:
133 if (!internal_type_hash) {
135 make_general_hash_table(163, type_hash_hash,
140 if (gethash((void *)t, internal_type_hash, (const void **)&retval)) {
146 static void mark_type_as_imported(GtkType t)
148 if (type_already_imported_p(t))
151 puthash((void *)t, (void *)1, internal_type_hash);
154 static void import_gtk_type(GtkType t);
156 static void import_gtk_object_internal(GtkType the_type)
158 GtkType original_type = the_type;
167 GtkObjectClass *klass;
168 GtkSignalQuery *query;
173 /* Register the type before we do anything else with it... */
175 if (!type_already_imported_p(the_type)) {
176 import_gtk_type(the_type);
179 /* We need to mark the object type as imported here or we
180 run the risk of SERIOUS recursion when we do automatic
181 argument type importing. mark_type_as_imported() is
182 smart enough to be a noop if we attempt to register
185 mark_type_as_imported(the_type);
188 args = gtk_object_query_args(the_type, &flags, &n_args);
190 /* First get the arguments the object can accept */
191 for (i = 0; i < n_args; i++) {
192 if ((args[i].type != original_type)
193 && !type_already_imported_p(args[i].type)) {
194 import_gtk_type(args[i].type);
202 /* Now lets publish the signals */
203 klass = (GtkObjectClass *) gtk_type_class(the_type);
204 signals = klass->signals;
205 n_signals = klass->nsignals;
207 for (i = 0; i < n_signals; i++) {
208 query = gtk_signal_query(signals[i]);
209 /* What do we want to do here? */
214 the_type = gtk_type_parent(the_type);
215 } while (the_type != GTK_TYPE_INVALID);
218 static void import_gtk_enumeration_internal(GtkType the_type)
220 GtkEnumValue *vals = gtk_type_enum_get_values(the_type);
221 Lisp_Object assoc = Qnil;
223 if (NILP(Venumeration_info)) {
225 call2(intern("make-hashtable"), make_int(100), Qequal);
228 while (vals && vals->value_name) {
231 (intern(vals->value_nick), make_int(vals->value)),
235 (intern(vals->value_name), make_int(vals->value)),
240 assoc = Fnreverse(assoc);
242 Fputhash(make_int(the_type), assoc, Venumeration_info);
245 static void import_gtk_type(GtkType t)
247 if (type_already_imported_p(t)) {
251 switch (GTK_FUNDAMENTAL_TYPE(t)) {
254 import_gtk_enumeration_internal(t);
256 case GTK_TYPE_OBJECT:
257 import_gtk_object_internal(t);
263 mark_type_as_imported(t);
266 /* Foreign function calls */
267 static emacs_ffi_data *allocate_ffi_data(void)
269 emacs_ffi_data *data =
270 alloc_lcrecord_type(emacs_ffi_data, &lrecord_emacs_ffi);
272 data->return_type = GTK_TYPE_NONE;
274 data->function_name = Qnil;
275 data->function_ptr = 0;
281 static Lisp_Object mark_ffi_data(Lisp_Object obj)
283 emacs_ffi_data *data = (emacs_ffi_data *) XFFI(obj);
285 mark_object(data->function_name);
290 ffi_object_printer(Lisp_Object obj, Lisp_Object printcharfun, int escapeflag)
295 error("printing unreadable object #<ffi %p",
296 XFFI(obj)->function_ptr);
298 write_c_string("#<ffi ", printcharfun);
299 print_internal(XFFI(obj)->function_name, printcharfun, 1);
300 if (XFFI(obj)->n_args) {
301 sprintf(buf, " %d arguments", XFFI(obj)->n_args);
302 write_c_string(buf, printcharfun);
304 sprintf(buf, " %p>", (void *)XFFI(obj)->function_ptr);
305 write_c_string(buf, printcharfun);
308 DEFINE_LRECORD_IMPLEMENTATION("ffi", emacs_ffi,
309 mark_ffi_data, ffi_object_printer,
310 0, 0, 0, NULL, emacs_ffi_data);
312 typedef GtkObject *(*__OBJECT_fn) ();
313 typedef gint(*__INT_fn) ();
314 typedef void (*__NONE_fn) ();
315 typedef gchar *(*__STRING_fn) ();
316 typedef gboolean(*__BOOL_fn) ();
317 typedef gfloat(*__FLOAT_fn) ();
318 typedef void *(*__POINTER_fn) ();
319 typedef GList *(*__LIST_fn) ();
321 /* An auto-generated file of marshalling functions. */
322 #include "emacs-marshals.c"
324 #define CONVERT_SINGLE_TYPE(var,nam,tp) case GTK_TYPE_##nam: GTK_VALUE_##nam (var) = * (tp *) v; break;
325 #define CONVERT_RETVAL(a,freep) \
327 void *v = GTK_VALUE_POINTER(a); \
328 switch (GTK_FUNDAMENTAL_TYPE (a.type)) \
330 CONVERT_SINGLE_TYPE(a,CHAR,gchar); \
331 CONVERT_SINGLE_TYPE(a,UCHAR,guchar); \
332 CONVERT_SINGLE_TYPE(a,BOOL,gboolean); \
333 CONVERT_SINGLE_TYPE(a,INT,gint); \
334 CONVERT_SINGLE_TYPE(a,UINT,guint); \
335 CONVERT_SINGLE_TYPE(a,LONG,glong); \
336 CONVERT_SINGLE_TYPE(a,ULONG,gulong); \
337 CONVERT_SINGLE_TYPE(a,FLOAT,gfloat); \
338 CONVERT_SINGLE_TYPE(a,DOUBLE,gdouble); \
339 CONVERT_SINGLE_TYPE(a,STRING,gchar *); \
340 CONVERT_SINGLE_TYPE(a,ENUM,gint); \
341 CONVERT_SINGLE_TYPE(a,FLAGS,guint); \
342 CONVERT_SINGLE_TYPE(a,BOXED,void *); \
343 CONVERT_SINGLE_TYPE(a,POINTER,void *); \
344 CONVERT_SINGLE_TYPE(a,OBJECT,GtkObject *); \
346 GTK_VALUE_POINTER (a) = * (void **) v; \
349 if (freep) xfree(v); \
352 gpointer __allocate_object_storage(GtkType t)
357 switch (GTK_FUNDAMENTAL_TYPE(t)) {
363 s = (sizeof(guchar));
366 s = (sizeof(gboolean));
378 s = (sizeof(gulong));
381 s = (sizeof(gfloat));
383 case GTK_TYPE_DOUBLE:
384 s = (sizeof(gdouble));
386 case GTK_TYPE_STRING:
387 s = (sizeof(gchar *));
394 case GTK_TYPE_POINTER:
395 s = (sizeof(void *));
398 /* base type of the object system */
399 case GTK_TYPE_OBJECT:
400 s = (sizeof(GtkObject *));
404 if (GTK_FUNDAMENTAL_TYPE(t) == GTK_TYPE_LISTOF) {
405 s = (sizeof(void *));
413 memset(rval, '\0', s);
419 Lisp_Object type_to_marshaller_type(GtkType t)
421 switch (GTK_FUNDAMENTAL_TYPE(t)) {
423 return (build_string("NONE"));
427 return (build_string("CHAR"));
429 return (build_string("BOOL"));
434 return (build_string("INT"));
437 return (build_string("LONG"));
439 case GTK_TYPE_DOUBLE:
440 return (build_string("FLOAT"));
441 case GTK_TYPE_STRING:
442 return (build_string("STRING"));
444 case GTK_TYPE_POINTER:
445 return (build_string("POINTER"));
446 case GTK_TYPE_OBJECT:
447 return (build_string("OBJECT"));
448 case GTK_TYPE_CALLBACK:
449 return (build_string("CALLBACK"));
451 /* I can't put this in the main switch statement because it is a
452 new fundamental type that is not fixed at compile time.
455 if (GTK_FUNDAMENTAL_TYPE(t) == GTK_TYPE_ARRAY)
456 return (build_string("ARRAY"));
458 if (GTK_FUNDAMENTAL_TYPE(t) == GTK_TYPE_LISTOF)
459 return (build_string("LIST"));
464 struct __dll_mapper_closure {
465 void *(*func) (dll_handle, const char *);
466 const char *obj_name;
470 static void __dll_mapper(gpointer key, gpointer value, gpointer user_data)
472 struct __dll_mapper_closure *closure =
473 (struct __dll_mapper_closure *)user_data;
475 if (*(closure->storage) == NULL) {
476 /* Need to see if it is in this one */
477 *(closure->storage) =
478 closure->func((dll_handle) value, closure->obj_name);
482 DEFUN("gtk-import-variable-internal", Fgtk_import_variable_internal, 2, 2, 0, /*
483 Import a variable into the XEmacs namespace.
491 type = Fsymbol_name(type);
496 initialize_dll_cache();
497 xemacs_init_gtk_classes();
499 arg.type = gtk_type_from_name((char *)XSTRING_DATA(type));
501 if (arg.type == GTK_TYPE_INVALID) {
502 signal_simple_error("Unknown type", type);
505 /* Need to look thru the already-loaded dlls */
507 struct __dll_mapper_closure closure;
509 closure.func = dll_variable;
510 closure.obj_name = XSTRING_DATA(name);
511 closure.storage = &var;
513 g_hash_table_foreach(dll_cache, __dll_mapper, &closure);
517 signal_simple_error("Could not locate variable", name);
520 GTK_VALUE_POINTER(arg) = var;
521 CONVERT_RETVAL(arg, 0);
522 return (gtk_type_to_lisp(&arg));
525 DEFUN("gtk-import-function-internal", Fgtk_import_function_internal, 2, 3, 0, /*
526 Import a function into the XEmacs namespace.
528 (rettype, name, args))
530 Lisp_Object rval = Qnil;
531 Lisp_Object marshaller = Qnil;
532 emacs_ffi_data *data = NULL;
537 ffi_marshalling_function marshaller_func = NULL;
538 ffi_actual_function name_func = NULL;
540 CHECK_SYMBOL(rettype);
544 initialize_dll_cache();
545 xemacs_init_gtk_classes();
547 /* Need to look thru the already-loaded dlls */
549 struct __dll_mapper_closure closure;
551 closure.func = dll_function;
552 closure.obj_name = XSTRING_DATA(name);
553 closure.storage = (void **)&name_func;
555 g_hash_table_foreach(dll_cache, __dll_mapper, &closure);
559 signal_simple_error("Could not locate function", name);
562 data = allocate_ffi_data();
569 Lisp_Object tail = Qnil;
570 Lisp_Object value = args;
571 Lisp_Object type = Qnil;
573 EXTERNAL_LIST_LOOP(tail, value) {
575 Lisp_Object marshaller_type = Qnil;
577 CHECK_SYMBOL(XCAR(tail));
579 type = Fsymbol_name(XCAR(tail));
582 gtk_type_from_name((char *)XSTRING_DATA(type));
584 if (the_type == GTK_TYPE_INVALID) {
585 signal_simple_error("Unknown argument type",
589 /* All things must be reduced to their basest form... */
590 import_gtk_type(the_type);
591 data->args[n_args] = the_type; /* GTK_FUNDAMENTAL_TYPE (the_type); */
593 /* Now lets build up another chunk of our marshaller function name */
595 type_to_marshaller_type(data->args[n_args]);
597 if (NILP(marshaller_type)) {
599 ("Do not know how to marshal", type);
602 concat3(marshaller, build_string("_"),
608 concat3(marshaller, build_string("_"),
609 type_to_marshaller_type(GTK_TYPE_NONE));
612 rettype = Fsymbol_name(rettype);
613 data->return_type = gtk_type_from_name((char *)XSTRING_DATA(rettype));
615 if (data->return_type == GTK_TYPE_INVALID) {
616 signal_simple_error("Unknown return type", rettype);
619 import_gtk_type(data->return_type);
622 concat3(type_to_marshaller_type(data->return_type),
623 build_string("_"), marshaller);
624 marshaller = concat2(build_string("emacs_gtk_marshal_"), marshaller);
627 (ffi_marshalling_function) find_marshaller((char *)
631 if (!marshaller_func) {
632 signal_simple_error("Could not locate marshaller function",
636 data->n_args = n_args;
637 data->function_name = name;
638 data->function_ptr = name_func;
639 data->marshal = marshaller_func;
645 DEFUN("gtk-call-function", Fgtk_call_function, 1, 2, 0, /*
646 Call an external function.
650 GtkArg the_args[MAX_GTK_ARGS];
652 Lisp_Object retval = Qnil;
657 n_args = XINT(Flength(args));
659 #ifdef XEMACS_IS_SMARTER_THAN_THE_PROGRAMMER
660 /* #### I think this is too dangerous to enable by default.
661 ** #### Genuine program bugs would probably be allowed to
662 ** #### slip by, and not be very easy to find.
663 ** #### Bill Perry July 9, 2000
665 if (n_args != XFFI(func)->n_args) {
666 Lisp_Object for_append[3];
668 /* Signal an error if they pass in too many arguments */
669 if (n_args > XFFI(func)->n_args) {
670 return Fsignal(Qwrong_number_of_arguments,
671 list2(func, make_int(n_args)));
674 /* If they did not provide enough arguments, be nice and assume
675 ** they wanted `nil' in there.
677 for_append[0] = args;
679 Fmake_list(make_int(XFFI(func)->n_args - n_args), Qnil);
681 args = Fappend(2, for_append);
684 if (n_args != XFFI(func)->n_args) {
685 /* Signal an error if they do not pass in the correct # of arguments */
686 return Fsignal(Qwrong_number_of_arguments,
687 list2(func, make_int(n_args)));
692 Lisp_Object tail = Qnil;
693 Lisp_Object value = args;
698 /* First we convert all of the arguments from Lisp to GtkArgs */
699 EXTERNAL_LIST_LOOP(tail, value) {
700 the_args[n_args].type = XFFI(func)->args[n_args];
702 if (lisp_to_gtk_type(XCAR(tail), &the_args[n_args])) {
703 /* There was some sort of an error */
705 ("Error converting arguments", args);
711 /* Now we need to tack on space for a return value, if they have
713 if (XFFI(func)->return_type != GTK_TYPE_NONE) {
714 the_args[n_args].type = XFFI(func)->return_type;
715 GTK_VALUE_POINTER(the_args[n_args]) =
716 __allocate_object_storage(the_args[n_args].type);
720 XFFI(func)->marshal((ffi_actual_function) (XFFI(func)->function_ptr),
723 if (XFFI(func)->return_type != GTK_TYPE_NONE) {
724 CONVERT_RETVAL(the_args[n_args - 1], 1);
725 retval = gtk_type_to_lisp(&the_args[n_args - 1]);
728 /* Need to free any array or list pointers */
731 for (i = 0; i < n_args; i++) {
732 if (GTK_FUNDAMENTAL_TYPE(the_args[i].type) ==
734 g_free(GTK_VALUE_POINTER(the_args[i]));
735 } else if (GTK_FUNDAMENTAL_TYPE(the_args[i].type) ==
737 /* g_list_free (GTK_VALUE_POINTER (the_args[i])); */
745 /* GtkObject wrapping for Lisp */
747 emacs_gtk_object_printer(Lisp_Object obj, Lisp_Object printcharfun,
753 error("printing unreadable object #<GtkObject %p>",
754 XGTK_OBJECT(obj)->object);
756 write_c_string("#<GtkObject (", printcharfun);
757 if (XGTK_OBJECT(obj)->alive_p)
758 write_c_string(gtk_type_name
759 (GTK_OBJECT_TYPE(XGTK_OBJECT(obj)->object)),
762 write_c_string("dead", printcharfun);
763 sprintf(buf, ") %p>", (void *)XGTK_OBJECT(obj)->object);
764 write_c_string(buf, printcharfun);
767 static Lisp_Object object_getprop(Lisp_Object obj, Lisp_Object prop)
769 Lisp_Object rval = Qnil;
770 Lisp_Object prop_name = Qnil;
771 GtkArgInfo *info = NULL;
775 CHECK_SYMBOL(prop); /* Shouldn't need to ever do this, but I'm paranoid */
777 prop_name = Fsymbol_name(prop);
779 args[0].name = (char *)XSTRING_DATA(prop_name);
781 err = gtk_object_arg_get_info(GTK_OBJECT_TYPE(XGTK_OBJECT(obj)->object),
782 args[0].name, &info);
785 /* Not a magic symbol, fall back to just looking in our real plist */
788 return (Fplist_get(XGTK_OBJECT(obj)->plist, prop, Qunbound));
791 if (!(info->arg_flags & GTK_ARG_READABLE)) {
792 signal_simple_error("Attempt to get write-only property", prop);
795 gtk_object_getv(XGTK_OBJECT(obj)->object, 1, args);
797 if (args[0].type == GTK_TYPE_INVALID) {
798 /* If we can't get the attribute, then let the code in Fget know
799 so it can use the default value supplied by the caller */
803 rval = gtk_type_to_lisp(&args[0]);
805 /* Free up any memory. According to the documentation and Havoc's
806 book, if the fundamental type of the returned value is
807 GTK_TYPE_STRING, GTK_TYPE_BOXED, or GTK_TYPE_ARGS, you are
808 responsible for freeing it. */
809 switch (GTK_FUNDAMENTAL_TYPE(args[0].type)) {
810 case GTK_TYPE_STRING:
811 g_free(GTK_VALUE_STRING(args[0]));
814 g_free(GTK_VALUE_BOXED(args[0]));
817 g_free(GTK_VALUE_ARGS(args[0]).args);
825 static int object_putprop(Lisp_Object obj, Lisp_Object prop, Lisp_Object value)
827 GtkArgInfo *info = NULL;
828 Lisp_Object prop_name = Qnil;
832 prop_name = Fsymbol_name(prop);
834 args[0].name = (char *)XSTRING_DATA(prop_name);
836 err = gtk_object_arg_get_info(GTK_OBJECT_TYPE(XGTK_OBJECT(obj)->object),
837 args[0].name, &info);
840 /* Not a magic symbol, fall back to just storing in our real plist */
843 XGTK_OBJECT(obj)->plist =
844 Fplist_put(XGTK_OBJECT(obj)->plist, prop, value);
848 args[0].type = info->type;
850 if (lisp_to_gtk_type(value, &args[0])) {
851 signal_simple_error("Error converting to GtkType", value);
854 if (!(info->arg_flags & GTK_ARG_WRITABLE)) {
855 signal_simple_error("Attemp to set read-only argument", prop);
858 gtk_object_setv(XGTK_OBJECT(obj)->object, 1, args);
863 static Lisp_Object mark_gtk_object_data(Lisp_Object obj)
865 return (XGTK_OBJECT(obj)->plist);
868 static void emacs_gtk_object_finalizer(void *header, int for_disksave)
870 emacs_gtk_object_data *data = (emacs_gtk_object_data *) header;
874 XSETGTK_OBJECT(obj, data);
877 ("Can't dump an emacs containing GtkObject objects", obj);
881 gtk_object_unref(data->object);
885 DEFINE_LRECORD_IMPLEMENTATION_WITH_PROPS("GtkObject", emacs_gtk_object, mark_gtk_object_data, /* marker function */
886 emacs_gtk_object_printer, /* print function */
887 emacs_gtk_object_finalizer, /* finalizer */
891 object_getprop, /* get prop */
892 object_putprop, /* put prop */
895 emacs_gtk_object_data);
897 static emacs_gtk_object_data *allocate_emacs_gtk_object_data(void)
899 emacs_gtk_object_data *data = alloc_lcrecord_type(emacs_gtk_object_data,
900 &lrecord_emacs_gtk_object);
903 data->alive_p = FALSE;
909 /* We need to keep track of when the object is destroyed so that we
910 can mark it as dead, otherwise even our print routine (which calls
911 GTK_OBJECT_TYPE) will crap out and die. This is also used in the
912 lisp_to_gtk_type() routine to defend against passing dead objects
914 static void __notice_object_destruction(GtkObject * obj, gpointer user_data)
916 ungcpro_popup_callbacks((GUI_ID) user_data);
919 Lisp_Object build_gtk_object(GtkObject * obj)
921 Lisp_Object retval = Qnil;
922 emacs_gtk_object_data *data = NULL;
925 id = (GUI_ID) gtk_object_get_data(obj, GTK_DATA_GUI_IDENTIFIER);
928 retval = get_gcpro_popup_callbacks(id);
932 data = allocate_emacs_gtk_object_data();
935 data->alive_p = TRUE;
936 XSETGTK_OBJECT(retval, data);
939 gtk_object_set_data(obj, GTK_DATA_GUI_IDENTIFIER,
941 gcpro_popup_callbacks(id, retval);
943 gtk_signal_connect(obj, "destroy",
944 GTK_SIGNAL_FUNC(__notice_object_destruction),
951 static void __internal_callback_destroy(gpointer data)
953 Lisp_Object lisp_data;
955 VOID_TO_LISP(lisp_data, data);
957 ungcpro_popup_callbacks(XINT(XCAR(lisp_data)));
961 __internal_callback_marshal(GtkObject * obj, gpointer data, guint n_args,
964 Lisp_Object arg_list = Qnil;
965 Lisp_Object callback_fn = Qnil;
966 Lisp_Object callback_data = Qnil;
967 Lisp_Object newargs[3];
968 Lisp_Object rval = Qnil;
972 VOID_TO_LISP(callback_fn, data);
974 /* Nuke the GUI_ID off the front */
975 callback_fn = XCDR(callback_fn);
977 callback_data = XCAR(callback_fn);
978 callback_fn = XCDR(callback_fn);
980 /* The callback data goes at the very end of the argument list */
981 arg_list = Fcons(callback_data, Qnil);
983 /* Build up the argument list, lisp style */
984 for (i = n_args - 1; i >= 0; i--) {
985 arg_list = Fcons(gtk_type_to_lisp(&args[i]), arg_list);
988 /* We always pass the widget as the first parameter at the very least */
989 arg_list = Fcons(build_gtk_object(obj), arg_list);
993 newargs[0] = callback_fn;
994 newargs[1] = arg_list;
996 rval = Fapply(2, newargs);
999 if (args[n_args].type != GTK_TYPE_NONE)
1000 lisp_to_gtk_ret_type(rval, &args[n_args]);
1005 DEFUN("gtk-signal-connect", Fgtk_signal_connect, 3, 6, 0, /*
1007 (obj, name, func, cb_data, object_signal, after_p))
1010 int c_object_signal;
1013 CHECK_GTK_OBJECT(obj);
1016 name = Fsymbol_name(name);
1020 if (NILP(object_signal))
1021 c_object_signal = 0;
1023 c_object_signal = 1;
1031 func = Fcons(cb_data, func);
1032 func = Fcons(make_int(id), func);
1034 gcpro_popup_callbacks(id, func);
1036 gtk_signal_connect_full(XGTK_OBJECT(obj)->object,
1037 (char *)XSTRING_DATA(name), NULL,
1038 __internal_callback_marshal, LISP_TO_VOID(func),
1039 __internal_callback_destroy, c_object_signal,
1044 /* GTK_TYPE_BOXED wrapper for Emacs lisp */
1046 emacs_gtk_boxed_printer(Lisp_Object obj, Lisp_Object printcharfun,
1052 error("printing unreadable object #<GtkBoxed %p>",
1053 XGTK_BOXED(obj)->object);
1055 write_c_string("#<GtkBoxed (", printcharfun);
1056 write_c_string(gtk_type_name(XGTK_BOXED(obj)->object_type),
1058 sprintf(buf, ") %p>", (void *)XGTK_BOXED(obj)->object);
1059 write_c_string(buf, printcharfun);
1062 static int emacs_gtk_boxed_equality(Lisp_Object o1, Lisp_Object o2, int depth)
1064 emacs_gtk_boxed_data *data1 = XGTK_BOXED(o1);
1065 emacs_gtk_boxed_data *data2 = XGTK_BOXED(o2);
1067 return ((data1->object == data2->object) &&
1068 (data1->object_type == data2->object_type));
1071 static unsigned long emacs_gtk_boxed_hash(Lisp_Object obj, int depth)
1073 emacs_gtk_boxed_data *data = XGTK_BOXED(obj);
1074 return (HASH2((unsigned long)data->object, data->object_type));
1077 DEFINE_LRECORD_IMPLEMENTATION_WITH_PROPS("GtkBoxed", emacs_gtk_boxed, 0, /* marker function */
1078 emacs_gtk_boxed_printer, /* print function */
1080 emacs_gtk_boxed_equality, /* equality */
1081 emacs_gtk_boxed_hash, /* hash */
1087 emacs_gtk_boxed_data);
1089 /* Currently defined GTK_TYPE_BOXED structures are:
1103 static emacs_gtk_boxed_data *allocate_emacs_gtk_boxed_data(void)
1105 emacs_gtk_boxed_data *data = alloc_lcrecord_type(emacs_gtk_boxed_data,
1106 &lrecord_emacs_gtk_boxed);
1108 data->object = NULL;
1109 data->object_type = GTK_TYPE_INVALID;
1114 Lisp_Object build_gtk_boxed(void *obj, GtkType t)
1116 Lisp_Object retval = Qnil;
1117 emacs_gtk_boxed_data *data = NULL;
1119 if (GTK_FUNDAMENTAL_TYPE(t) != GTK_TYPE_BOXED)
1122 data = allocate_emacs_gtk_boxed_data();
1124 data->object_type = t;
1126 XSETGTK_BOXED(retval, data);
1131 /* The automatically generated structure access routines */
1132 #include "emacs-widget-accessors.c"
1134 /* The hand generated funky functions that we can't just import using the FFI */
1135 #include "ui-byhand.c"
1137 /* The glade support */
1140 /* Type manipulation */
1141 DEFUN("gtk-fundamental-type", Fgtk_fundamental_type, 1, 1, 0, /*
1142 Load a shared library DLL into XEmacs. No initialization routines are required.
1143 This is for loading dependency DLLs into XEmacs.
1150 type = Fsymbol_name(type);
1154 t = gtk_type_from_name((char *)XSTRING_DATA(type));
1156 if (t == GTK_TYPE_INVALID) {
1157 signal_simple_error("Not a GTK type", type);
1159 return (make_int(GTK_FUNDAMENTAL_TYPE(t)));
1162 DEFUN("gtk-object-type", Fgtk_object_type, 1, 1, 0, /*
1163 Return the GtkType of OBJECT.
1167 CHECK_GTK_OBJECT(object);
1168 return (make_int(GTK_OBJECT_TYPE(XGTK_OBJECT(object)->object)));
1171 DEFUN("gtk-describe-type", Fgtk_describe_type, 1, 1, 0, /*
1172 Returns a cons of two lists describing the Gtk object TYPE.
1173 The car is a list of all the signals that it will emit.
1174 The cdr is a list of all the magic properties it has.
1178 Lisp_Object rval, signals, props;
1181 props = signals = rval = Qnil;
1183 if (SYMBOLP(type)) {
1184 type = Fsymbol_name(type);
1187 if (STRINGP(type)) {
1188 t = gtk_type_from_name(XSTRING_DATA(type));
1189 if (t == GTK_TYPE_INVALID) {
1190 signal_simple_error("Not a GTK type", type);
1197 if (GTK_FUNDAMENTAL_TYPE(t) != GTK_TYPE_OBJECT) {
1198 signal_simple_error("Not a GtkObject", type);
1201 /* Need to do stupid shit like this to get the args
1202 ** registered... damn GTK and its lazy loading
1206 GtkObject *obj = gtk_object_newv(t, 0, args);
1208 gtk_object_destroy(obj);
1214 /* Do the magic arguments first */
1220 args = gtk_object_query_args(t, &flags, &n_args);
1222 for (i = 0; i < n_args; i++) {
1225 (intern(gtk_type_name(args[i].type)),
1226 intern(args[i].name)), props);
1233 /* Now the signals */
1235 GtkObjectClass *klass;
1236 GtkSignalQuery *query;
1237 guint32 *gtk_signals;
1240 klass = (GtkObjectClass *) gtk_type_class(t);
1241 gtk_signals = klass->signals;
1242 n_signals = klass->nsignals;
1244 for (i = 0; i < n_signals; i++) {
1245 Lisp_Object params = Qnil;
1247 query = gtk_signal_query(gtk_signals[i]);
1250 if (query->nparams) {
1253 for (j = query->nparams - 1;
1268 (query->return_val)),
1270 (query->signal_name),
1277 t = gtk_type_parent(t);
1278 } while (t != GTK_TYPE_INVALID);
1280 rval = Fcons(signals, props);
1285 void syms_of_ui_gtk(void)
1287 INIT_LRECORD_IMPLEMENTATION(emacs_ffi);
1288 INIT_LRECORD_IMPLEMENTATION(emacs_gtk_object);
1289 INIT_LRECORD_IMPLEMENTATION(emacs_gtk_boxed);
1290 defsymbol(&Qemacs_ffip, "emacs-ffi-p");
1291 defsymbol(&Qemacs_gtk_objectp, "emacs-gtk-object-p");
1292 defsymbol(&Qemacs_gtk_boxedp, "emacs-gtk-boxed-p");
1293 defsymbol(&Qvoid, "void");
1295 DEFSUBR(Fgtk_import_function_internal);
1296 DEFSUBR(Fgtk_import_variable_internal);
1297 DEFSUBR(Fgtk_signal_connect);
1298 DEFSUBR(Fgtk_call_function);
1299 DEFSUBR(Fgtk_fundamental_type);
1300 DEFSUBR(Fgtk_object_type);
1301 DEFSUBR(Fgtk_describe_type);
1302 syms_of_widget_accessors();
1303 syms_of_ui_byhand();
1307 void vars_of_ui_gtk(void)
1309 Fprovide(intern("gtk-ui"));
1310 DEFVAR_LISP("gtk-enumeration-info", &Venumeration_info /*
1311 A hashtable holding type information about GTK enumerations and flags.
1312 Do NOT modify unless you really understand ui-gtk.c.
1315 Venumeration_info = Qnil;
1319 /* Various utility functions */
1320 void describe_gtk_arg(GtkArg * arg)
1324 switch (GTK_FUNDAMENTAL_TYPE(a.type)) {
1327 stderr_out("char: %c\n", GTK_VALUE_CHAR(a));
1329 case GTK_TYPE_UCHAR:
1330 stderr_out("uchar: %c\n", GTK_VALUE_CHAR(a));
1333 stderr_out("uchar: %s\n", GTK_VALUE_BOOL(a) ? "true" : "false");
1336 stderr_out("int: %d\n", GTK_VALUE_INT(a));
1339 stderr_out("uint: %du\n", GTK_VALUE_UINT(a));
1342 stderr_out("long: %ld\n", GTK_VALUE_LONG(a));
1344 case GTK_TYPE_ULONG:
1345 stderr_out("ulong: %lu\n", GTK_VALUE_ULONG(a));
1347 case GTK_TYPE_FLOAT:
1348 stderr_out("float: %g\n", GTK_VALUE_FLOAT(a));
1350 case GTK_TYPE_DOUBLE:
1351 stderr_out("double: %f\n", GTK_VALUE_DOUBLE(a));
1353 case GTK_TYPE_STRING:
1354 stderr_out("string: %s\n", GTK_VALUE_STRING(a));
1357 case GTK_TYPE_FLAGS:
1358 stderr_out("%s: ", (a.type == GTK_TYPE_ENUM) ? "enum" : "flag");
1360 GtkEnumValue *vals = gtk_type_enum_get_values(a.type);
1362 while (vals && vals->value_name
1363 && (vals->value != GTK_VALUE_ENUM(a)))
1368 value_name : "!!! UNKNOWN ENUM VALUE !!!");
1371 case GTK_TYPE_BOXED:
1372 stderr_out("boxed: %p\n", GTK_VALUE_BOXED(a));
1374 case GTK_TYPE_POINTER:
1375 stderr_out("pointer: %p\n", GTK_VALUE_BOXED(a));
1378 /* structured types */
1379 case GTK_TYPE_SIGNAL:
1380 case GTK_TYPE_ARGS: /* This we can do as a list of values */
1382 case GTK_TYPE_CALLBACK:
1383 stderr_out("callback fn: ...\n");
1385 case GTK_TYPE_C_CALLBACK:
1386 case GTK_TYPE_FOREIGN:
1389 /* base type of the object system */
1390 case GTK_TYPE_OBJECT:
1391 if (GTK_VALUE_OBJECT(a))
1392 stderr_out("object: %s\n",
1393 gtk_type_name(GTK_OBJECT_TYPE
1394 (GTK_VALUE_OBJECT(a))));
1396 stderr_out("object: NULL\n");
1404 Lisp_Object gtk_type_to_lisp(GtkArg * arg)
1406 switch (GTK_FUNDAMENTAL_TYPE(arg->type)) {
1410 return (make_char(GTK_VALUE_CHAR(*arg)));
1411 case GTK_TYPE_UCHAR:
1412 return (make_char(GTK_VALUE_UCHAR(*arg)));
1414 return (GTK_VALUE_BOOL(*arg) ? Qt : Qnil);
1416 return (make_int(GTK_VALUE_INT(*arg)));
1418 return (make_int(GTK_VALUE_INT(*arg)));
1419 case GTK_TYPE_LONG: /* I think these are wrong! */
1420 return (make_int(GTK_VALUE_INT(*arg)));
1421 case GTK_TYPE_ULONG: /* I think these are wrong! */
1422 return (make_int(GTK_VALUE_INT(*arg)));
1423 case GTK_TYPE_FLOAT:
1424 return (make_float(GTK_VALUE_FLOAT(*arg)));
1425 case GTK_TYPE_DOUBLE:
1426 return (make_float(GTK_VALUE_DOUBLE(*arg)));
1427 case GTK_TYPE_STRING:
1428 return (build_string(GTK_VALUE_STRING(*arg)));
1429 case GTK_TYPE_FLAGS:
1430 return (flags_to_list(GTK_VALUE_FLAGS(*arg), arg->type));
1432 return (enum_to_symbol(GTK_VALUE_ENUM(*arg), arg->type));
1433 case GTK_TYPE_BOXED:
1434 if (arg->type == GTK_TYPE_GDK_EVENT) {
1435 return (gdk_event_to_emacs_event
1436 ((GdkEvent *) GTK_VALUE_BOXED(*arg)));
1439 if (GTK_VALUE_BOXED(*arg))
1440 return (build_gtk_boxed
1441 (GTK_VALUE_BOXED(*arg), arg->type));
1444 case GTK_TYPE_POINTER:
1445 if (GTK_VALUE_POINTER(*arg)) {
1448 VOID_TO_LISP(rval, GTK_VALUE_POINTER(*arg));
1452 case GTK_TYPE_OBJECT:
1453 if (GTK_VALUE_OBJECT(*arg))
1454 return (build_gtk_object(GTK_VALUE_OBJECT(*arg)));
1458 case GTK_TYPE_CALLBACK:
1462 VOID_TO_LISP(rval, GTK_VALUE_CALLBACK(*arg).data);
1468 if (GTK_FUNDAMENTAL_TYPE(arg->type) == GTK_TYPE_LISTOF) {
1469 if (!GTK_VALUE_POINTER(*arg))
1472 return (xemacs_gtklist_to_list(arg));
1475 stderr_out("Do not know how to convert `%s' to lisp!\n",
1476 gtk_type_name(arg->type));
1479 /* This is chuck reminding GCC to... SHUT UP! */
1483 int lisp_to_gtk_type(Lisp_Object obj, GtkArg * arg)
1485 switch (GTK_FUNDAMENTAL_TYPE(arg->type)) {
1493 CHECK_CHAR_COERCE_INT(obj);
1495 GTK_VALUE_CHAR(*arg) = c;
1498 case GTK_TYPE_UCHAR:
1502 CHECK_CHAR_COERCE_INT(obj);
1504 GTK_VALUE_CHAR(*arg) = c;
1508 GTK_VALUE_BOOL(*arg) = NILP(obj) ? FALSE : TRUE;
1512 if (NILP(obj) || EQ(Qt, obj)) {
1513 /* For we are a kind mistress and allow sending t/nil for
1514 1/0 to stupid GTK functions that say they take guint or
1515 gint in the header files, but actually treat it like a
1518 GTK_VALUE_INT(*arg) = NILP(obj) ? 0 : 1;
1521 GTK_VALUE_INT(*arg) = XINT(obj);
1525 case GTK_TYPE_ULONG:
1527 case GTK_TYPE_FLOAT:
1528 #ifdef WITH_NUMBER_TYPES
1531 CHECK_INT_OR_FLOAT(obj);
1533 GTK_VALUE_FLOAT(*arg) = extract_float(obj);
1535 case GTK_TYPE_DOUBLE:
1536 #ifdef WITH_NUMBER_TYPES
1539 CHECK_INT_OR_FLOAT(obj);
1541 GTK_VALUE_DOUBLE(*arg) = extract_float(obj);
1543 case GTK_TYPE_STRING:
1545 GTK_VALUE_STRING(*arg) = NULL;
1548 GTK_VALUE_STRING(*arg) = (char *)XSTRING_DATA(obj);
1552 case GTK_TYPE_FLAGS:
1553 /* Convert a lisp symbol to a GTK enum */
1554 GTK_VALUE_ENUM(*arg) = lisp_to_flag(obj, arg->type);
1556 case GTK_TYPE_BOXED:
1558 GTK_VALUE_BOXED(*arg) = NULL;
1559 } else if (GTK_BOXEDP(obj)) {
1560 GTK_VALUE_BOXED(*arg) = XGTK_BOXED(obj)->object;
1561 } else if (arg->type == GTK_TYPE_STYLE) {
1562 obj = Ffind_face(obj);
1564 GTK_VALUE_BOXED(*arg) = face_to_style(obj);
1565 } else if (arg->type == GTK_TYPE_GDK_GC) {
1566 obj = Ffind_face(obj);
1568 GTK_VALUE_BOXED(*arg) = face_to_gc(obj);
1569 } else if (arg->type == GTK_TYPE_GDK_WINDOW) {
1571 Lisp_Object window = Fselected_window(Qnil);
1572 Lisp_Object instance =
1573 glyph_image_instance(obj, window,
1575 struct Lisp_Image_Instance *p =
1576 XIMAGE_INSTANCE(instance);
1578 switch (XIMAGE_INSTANCE_TYPE(instance)) {
1581 case IMAGE_SUBWINDOW:
1583 GTK_VALUE_BOXED(*arg) = NULL;
1586 case IMAGE_MONO_PIXMAP:
1587 case IMAGE_COLOR_PIXMAP:
1588 GTK_VALUE_BOXED(*arg) =
1589 IMAGE_INSTANCE_GTK_PIXMAP(p);
1592 } else if (GTK_OBJECTP(obj)
1593 && GTK_IS_WIDGET(XGTK_OBJECT(obj)->object)) {
1594 GTK_VALUE_BOXED(*arg) =
1595 GTK_WIDGET(XGTK_OBJECT(obj))->window;
1598 ("Don't know how to convert object to GDK_WINDOW",
1602 } else if (arg->type == GTK_TYPE_GDK_COLOR) {
1603 if (COLOR_SPECIFIERP(obj)) {
1604 /* If it is a specifier, we just convert it to an
1605 instance, and let the ifs below handle it.
1608 Fspecifier_instance(obj, Qnil, Qnil, Qnil);
1611 if (COLOR_INSTANCEP(obj)) {
1613 GTK_VALUE_BOXED(*arg) =
1614 COLOR_INSTANCE_GTK_COLOR(XCOLOR_INSTANCE
1616 } else if (STRINGP(obj)) {
1618 ("Please use a color specifier or instance, not a string",
1622 ("Don't know hot to convert to GdkColor",
1625 } else if (arg->type == GTK_TYPE_GDK_FONT) {
1627 /* If it is a symbol, we treat that as a face name */
1628 obj = Ffind_face(obj);
1632 /* If it is a face, we just grab the font specifier, and
1633 cascade down until we finally reach a FONT_INSTANCE
1635 obj = Fget(obj, Qfont, Qnil);
1638 if (FONT_SPECIFIERP(obj)) {
1639 /* If it is a specifier, we just convert it to an
1640 instance, and let the ifs below handle it
1643 Fspecifier_instance(obj, Qnil, Qnil, Qnil);
1646 if (FONT_INSTANCEP(obj)) {
1648 GTK_VALUE_BOXED(*arg) =
1649 FONT_INSTANCE_GTK_FONT(XFONT_INSTANCE(obj));
1650 } else if (STRINGP(obj)) {
1652 ("Please use a font specifier or instance, not a string",
1656 ("Don't know hot to convert to GdkColor",
1660 /* Unknown type to convert to boxed */
1661 stderr_out("Don't know how to convert to boxed!\n");
1662 GTK_VALUE_BOXED(*arg) = NULL;
1666 case GTK_TYPE_POINTER:
1668 GTK_VALUE_POINTER(*arg) = NULL;
1670 GTK_VALUE_POINTER(*arg) = LISP_TO_VOID(obj);
1673 /* structured types */
1674 case GTK_TYPE_SIGNAL:
1675 case GTK_TYPE_ARGS: /* This we can do as a list of values */
1676 case GTK_TYPE_C_CALLBACK:
1677 case GTK_TYPE_FOREIGN:
1678 stderr_out("Do not know how to convert `%s' from lisp!\n",
1679 gtk_type_name(arg->type));
1684 /* This is not used, and does not work with union type */
1685 case GTK_TYPE_CALLBACK:
1690 obj = Fcons(Qnil, obj); /* Empty data */
1691 obj = Fcons(make_int(id), obj);
1693 gcpro_popup_callbacks(id, obj);
1695 GTK_VALUE_CALLBACK(*arg).marshal =
1696 __internal_callback_marshal;
1697 GTK_VALUE_CALLBACK(*arg).data = (gpointer) obj;
1698 GTK_VALUE_CALLBACK(*arg).notify =
1699 __internal_callback_destroy;
1704 /* base type of the object system */
1705 case GTK_TYPE_OBJECT:
1707 GTK_VALUE_OBJECT(*arg) = NULL;
1709 CHECK_GTK_OBJECT(obj);
1710 if (XGTK_OBJECT(obj)->alive_p)
1711 GTK_VALUE_OBJECT(*arg) =
1712 XGTK_OBJECT(obj)->object;
1715 ("Attempting to pass dead object to GTK function",
1721 if (GTK_FUNDAMENTAL_TYPE(arg->type) == GTK_TYPE_ARRAY) {
1723 GTK_VALUE_POINTER(*arg) = NULL;
1725 xemacs_list_to_array(obj, arg);
1727 } else if (GTK_FUNDAMENTAL_TYPE(arg->type) == GTK_TYPE_LISTOF) {
1729 GTK_VALUE_POINTER(*arg) = NULL;
1731 xemacs_list_to_gtklist(obj, arg);
1735 ("Do not know how to convert `%s' from lisp!\n",
1736 gtk_type_name(arg->type));
1745 /* Convert lisp types to GTK return types. This is identical to
1746 lisp_to_gtk_type() except that the macro used to set the value is
1749 ### There should be some way of combining these two functions.
1751 int lisp_to_gtk_ret_type(Lisp_Object obj, GtkArg * arg)
1753 switch (GTK_FUNDAMENTAL_TYPE(arg->type)) {
1761 CHECK_CHAR_COERCE_INT(obj);
1763 *(GTK_RETLOC_CHAR(*arg)) = c;
1766 case GTK_TYPE_UCHAR:
1770 CHECK_CHAR_COERCE_INT(obj);
1772 *(GTK_RETLOC_CHAR(*arg)) = c;
1776 *(GTK_RETLOC_BOOL(*arg)) = NILP(obj) ? FALSE : TRUE;
1780 if (NILP(obj) || EQ(Qt, obj)) {
1781 /* For we are a kind mistress and allow sending t/nil for
1782 1/0 to stupid GTK functions that say they take guint or
1783 gint in the header files, but actually treat it like a
1786 *(GTK_RETLOC_INT(*arg)) = NILP(obj) ? 0 : 1;
1789 *(GTK_RETLOC_INT(*arg)) = XINT(obj);
1793 case GTK_TYPE_ULONG:
1795 case GTK_TYPE_FLOAT:
1796 #ifdef WITH_NUMBER_TYPES
1799 CHECK_INT_OR_FLOAT(obj);
1801 *(GTK_RETLOC_FLOAT(*arg)) = extract_float(obj);
1803 case GTK_TYPE_DOUBLE:
1804 #ifdef WITH_NUMBER_TYPES
1807 CHECK_INT_OR_FLOAT(obj);
1809 *(GTK_RETLOC_DOUBLE(*arg)) = extract_float(obj);
1811 case GTK_TYPE_STRING:
1813 *(GTK_RETLOC_STRING(*arg)) = NULL;
1816 *(GTK_RETLOC_STRING(*arg)) = (char *)XSTRING_DATA(obj);
1820 case GTK_TYPE_FLAGS:
1821 /* Convert a lisp symbol to a GTK enum */
1822 *(GTK_RETLOC_ENUM(*arg)) = lisp_to_flag(obj, arg->type);
1824 case GTK_TYPE_BOXED:
1826 *(GTK_RETLOC_BOXED(*arg)) = NULL;
1827 } else if (GTK_BOXEDP(obj)) {
1828 *(GTK_RETLOC_BOXED(*arg)) = XGTK_BOXED(obj)->object;
1829 } else if (arg->type == GTK_TYPE_STYLE) {
1830 obj = Ffind_face(obj);
1832 *(GTK_RETLOC_BOXED(*arg)) = face_to_style(obj);
1833 } else if (arg->type == GTK_TYPE_GDK_GC) {
1834 obj = Ffind_face(obj);
1836 *(GTK_RETLOC_BOXED(*arg)) = face_to_gc(obj);
1837 } else if (arg->type == GTK_TYPE_GDK_WINDOW) {
1839 Lisp_Object window = Fselected_window(Qnil);
1840 Lisp_Object instance =
1841 glyph_image_instance(obj, window,
1843 struct Lisp_Image_Instance *p =
1844 XIMAGE_INSTANCE(instance);
1846 switch (XIMAGE_INSTANCE_TYPE(instance)) {
1849 case IMAGE_SUBWINDOW:
1851 *(GTK_RETLOC_BOXED(*arg)) = NULL;
1854 case IMAGE_MONO_PIXMAP:
1855 case IMAGE_COLOR_PIXMAP:
1856 *(GTK_RETLOC_BOXED(*arg)) =
1857 IMAGE_INSTANCE_GTK_PIXMAP(p);
1860 } else if (GTK_OBJECTP(obj)
1861 && GTK_IS_WIDGET(XGTK_OBJECT(obj)->object)) {
1862 *(GTK_RETLOC_BOXED(*arg)) =
1863 GTK_WIDGET(XGTK_OBJECT(obj))->window;
1866 ("Don't know how to convert object to GDK_WINDOW",
1870 } else if (arg->type == GTK_TYPE_GDK_COLOR) {
1871 if (COLOR_SPECIFIERP(obj)) {
1872 /* If it is a specifier, we just convert it to an
1873 instance, and let the ifs below handle it.
1876 Fspecifier_instance(obj, Qnil, Qnil, Qnil);
1879 if (COLOR_INSTANCEP(obj)) {
1881 *(GTK_RETLOC_BOXED(*arg)) =
1882 COLOR_INSTANCE_GTK_COLOR(XCOLOR_INSTANCE
1884 } else if (STRINGP(obj)) {
1886 ("Please use a color specifier or instance, not a string",
1890 ("Don't know hot to convert to GdkColor",
1893 } else if (arg->type == GTK_TYPE_GDK_FONT) {
1895 /* If it is a symbol, we treat that as a face name */
1896 obj = Ffind_face(obj);
1900 /* If it is a face, we just grab the font specifier, and
1901 cascade down until we finally reach a FONT_INSTANCE
1903 obj = Fget(obj, Qfont, Qnil);
1906 if (FONT_SPECIFIERP(obj)) {
1907 /* If it is a specifier, we just convert it to an
1908 instance, and let the ifs below handle it
1911 Fspecifier_instance(obj, Qnil, Qnil, Qnil);
1914 if (FONT_INSTANCEP(obj)) {
1916 *(GTK_RETLOC_BOXED(*arg)) =
1917 FONT_INSTANCE_GTK_FONT(XFONT_INSTANCE(obj));
1918 } else if (STRINGP(obj)) {
1920 ("Please use a font specifier or instance, not a string",
1924 ("Don't know hot to convert to GdkColor",
1928 /* Unknown type to convert to boxed */
1929 stderr_out("Don't know how to convert to boxed!\n");
1930 *(GTK_RETLOC_BOXED(*arg)) = NULL;
1934 case GTK_TYPE_POINTER:
1936 *(GTK_RETLOC_POINTER(*arg)) = NULL;
1938 *(GTK_RETLOC_POINTER(*arg)) = LISP_TO_VOID(obj);
1941 /* structured types */
1942 case GTK_TYPE_SIGNAL:
1943 case GTK_TYPE_ARGS: /* This we can do as a list of values */
1944 case GTK_TYPE_C_CALLBACK:
1945 case GTK_TYPE_FOREIGN:
1946 stderr_out("Do not know how to convert `%s' from lisp!\n",
1947 gtk_type_name(arg->type));
1952 /* This is not used, and does not work with union type */
1953 case GTK_TYPE_CALLBACK:
1958 obj = Fcons(Qnil, obj); /* Empty data */
1959 obj = Fcons(make_int(id), obj);
1961 gcpro_popup_callbacks(id, obj);
1963 *(GTK_RETLOC_CALLBACK(*arg)).marshal =
1964 __internal_callback_marshal;
1965 *(GTK_RETLOC_CALLBACK(*arg)).data = (gpointer) obj;
1966 *(GTK_RETLOC_CALLBACK(*arg)).notify =
1967 __internal_callback_destroy;
1972 /* base type of the object system */
1973 case GTK_TYPE_OBJECT:
1975 *(GTK_RETLOC_OBJECT(*arg)) = NULL;
1977 CHECK_GTK_OBJECT(obj);
1978 if (XGTK_OBJECT(obj)->alive_p)
1979 *(GTK_RETLOC_OBJECT(*arg)) =
1980 XGTK_OBJECT(obj)->object;
1983 ("Attempting to pass dead object to GTK function",
1989 if (GTK_FUNDAMENTAL_TYPE(arg->type) == GTK_TYPE_ARRAY) {
1991 *(GTK_RETLOC_POINTER(*arg)) = NULL;
1993 xemacs_list_to_array(obj, arg);
1995 } else if (GTK_FUNDAMENTAL_TYPE(arg->type) == GTK_TYPE_LISTOF) {
1997 *(GTK_RETLOC_POINTER(*arg)) = NULL;
1999 xemacs_list_to_gtklist(obj, arg);
2003 ("Do not know how to convert `%s' from lisp!\n",
2004 gtk_type_name(arg->type));
2013 /* This is used in glyphs-gtk.c as well */
2014 static Lisp_Object get_enumeration(GtkType t)
2018 if (NILP(Venumeration_info)) {
2020 call2(intern("make-hashtable"), make_int(100), Qequal);
2023 alist = Fgethash(make_int(t), Venumeration_info, Qnil);
2026 import_gtk_enumeration_internal(t);
2027 alist = Fgethash(make_int(t), Venumeration_info, Qnil);
2032 guint symbol_to_enum(Lisp_Object obj, GtkType t)
2034 Lisp_Object alist = get_enumeration(t);
2035 Lisp_Object value = Qnil;
2038 signal_simple_error("Unkown enumeration",
2039 build_string(gtk_type_name(t)));
2042 value = Fassq(obj, alist);
2045 signal_simple_error("Unknown value", obj);
2048 CHECK_INT(XCDR(value));
2050 return (XINT(XCDR(value)));
2053 static guint lisp_to_flag(Lisp_Object obj, GtkType t)
2059 } else if (SYMBOLP(obj)) {
2060 val = symbol_to_enum(obj, t);
2061 } else if (LISTP(obj)) {
2062 while (!NILP(obj)) {
2063 val |= symbol_to_enum(XCAR(obj), t);
2072 static Lisp_Object flags_to_list(guint value, GtkType t)
2074 Lisp_Object rval = Qnil;
2075 Lisp_Object alist = get_enumeration(t);
2077 while (!NILP(alist)) {
2078 if (value & XINT(XCDR(XCAR(alist)))) {
2079 rval = Fcons(XCAR(XCAR(alist)), rval);
2080 value &= ~(XINT(XCDR(XCAR(alist))));
2082 alist = XCDR(alist);
2087 static Lisp_Object enum_to_symbol(guint value, GtkType t)
2089 Lisp_Object alist = get_enumeration(t);
2090 Lisp_Object cell = Qnil;
2093 signal_simple_error("Unkown enumeration",
2094 build_string(gtk_type_name(t)));
2097 cell = Frassq(make_int(value), alist);
2099 return (NILP(cell) ? Qnil : XCAR(cell));