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