Mercurial > hg > xemacs-beta

comparison src/ui-gtk.c @ 5125:b5df3737028a ben-lisp-object

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
merge
author Ben Wing <ben@xemacs.org>
date Wed, 24 Feb 2010 01:58:04 -0600
parents 623d57b7fbe8 ae48681c47fa
children a9c41067dd88
comparison
equal deleted inserted replaced
5124:623d57b7fbe8 5125:b5df3737028a
19 ** 19 **
20 ** You should have received a copy of the GNU General Public License 20 ** You should have received a copy of the GNU General Public License
21 ** along with XEmacs; see the file COPYING. If not, write to 21 ** along with XEmacs; see the file COPYING. If not, write to
22 ** the Free Software Foundation, Inc., 51 Franklin Street - Fifth Floor, 22 ** the Free Software Foundation, Inc., 51 Franklin Street - Fifth Floor,
23 ** Boston, MA 02111-1301, USA. */ 23 ** Boston, MA 02111-1301, USA. */
24 */
25 24
26 #include <config.h> 25 #include <config.h>
27 #include "lisp.h" 26 #include "lisp.h"
28 27
29 #include "buffer.h" 28 #include "buffer.h"
30 #include "console-gtk-impl.h"
31 #include "device.h" 29 #include "device.h"
32 #include "elhash.h" 30 #include "elhash.h"
33 #include "event-gtk.h"
34 #include "events.h" 31 #include "events.h"
35 #include "faces.h" 32 #include "faces.h"
33 #include "hash.h"
34 #include "sysdll.h"
35 #include "window.h"
36
37 #include "console-gtk-impl.h"
36 #include "glyphs-gtk.h" 38 #include "glyphs-gtk.h"
37 #include "hash.h"
38 #include "objects-gtk.h" 39 #include "objects-gtk.h"
39 #include "sysdll.h"
40 #include "ui-gtk.h" 40 #include "ui-gtk.h"
41 #include "window.h"
42 41
43 /* XEmacs specific GTK types */ 42 /* XEmacs specific GTK types */
44 #include "gtk-glue.c" 43 #include "gtk-glue.c"
45 44
46 /* Is the fundamental type of 't' the xemacs defined fundamental type 'type'? */ 45 /* Is the fundamental type of 't' the xemacs defined fundamental type 'type'? */
92 91
93 initialize_dll_cache (); 92 initialize_dll_cache ();
94 93
95 /* If the dll name has a directory component in it, then we should 94 /* If the dll name has a directory component in it, then we should
96 expand it. */ 95 expand it. */
97 if (!NILP (Fstring_match (build_string ("/"), dll, Qnil, Qnil))) 96 if (!NILP (Fstring_match (build_ascstring ("/"), dll, Qnil, Qnil)))
98 dll = Fexpand_file_name (dll, Qnil); 97 dll = Fexpand_file_name (dll, Qnil);
99 98
100 /* Check if we have already opened it first */ 99 /* Check if we have already opened it first */
101 h = g_hash_table_lookup (dll_cache, XSTRING_DATA (dll)); 100 h = g_hash_table_lookup (dll_cache, XSTRING_DATA (dll));
102 101
325 static void 324 static void
326 ffi_object_printer (Lisp_Object obj, Lisp_Object printcharfun, 325 ffi_object_printer (Lisp_Object obj, Lisp_Object printcharfun,
327 int UNUSED (escapeflag)) 326 int UNUSED (escapeflag))
328 { 327 {
329 if (print_readably) 328 if (print_readably)
330 printing_unreadable_object ("#<ffi %p>", XFFI (obj)->function_ptr); 329 printing_unreadable_lcrecord (obj, 0);
331 330
332 write_fmt_string_lisp (printcharfun, "#<ffi %S", 1, XFFI (obj)->function_name); 331 write_fmt_string_lisp (printcharfun, "#<ffi %S", 1, XFFI (obj)->function_name);
333 if (XFFI (obj)->n_args) 332 if (XFFI (obj)->n_args)
334 write_fmt_string (printcharfun, " %d arguments", XFFI (obj)->n_args); 333 write_fmt_string (printcharfun, " %d arguments", XFFI (obj)->n_args);
335 write_fmt_string (printcharfun, " %p>", (void *)XFFI (obj)->function_ptr); 334 write_fmt_string (printcharfun, " %p>", (void *)XFFI (obj)->function_ptr);
383 CONVERT_SINGLE_TYPE(a,OBJECT,GtkObject *); \ 382 CONVERT_SINGLE_TYPE(a,OBJECT,GtkObject *); \
384 default: \ 383 default: \
385 GTK_VALUE_POINTER (a) = * (void **) v; \ 384 GTK_VALUE_POINTER (a) = * (void **) v; \
386 break; \ 385 break; \
387 } \ 386 } \
388 if (freep) xfree(v, void *); \ 387 if (freep) xfree (v); \
389 } while (0) 388 } while (0)
390 389
391 static gpointer __allocate_object_storage (GtkType t) 390 static gpointer __allocate_object_storage (GtkType t)
392 { 391 {
393 size_t s = 0; 392 size_t s = 0;
461 static Lisp_Object type_to_marshaller_type (GtkType t) 460 static Lisp_Object type_to_marshaller_type (GtkType t)
462 { 461 {
463 switch (GTK_FUNDAMENTAL_TYPE (t)) 462 switch (GTK_FUNDAMENTAL_TYPE (t))
464 { 463 {
465 case GTK_TYPE_NONE: 464 case GTK_TYPE_NONE:
466 return (build_string ("NONE")); 465 return (build_ascstring ("NONE"));
467 /* flag types */ 466 /* flag types */
468 case GTK_TYPE_CHAR: 467 case GTK_TYPE_CHAR:
469 case GTK_TYPE_UCHAR: 468 case GTK_TYPE_UCHAR:
470 return (build_string ("CHAR")); 469 return (build_ascstring ("CHAR"));
471 case GTK_TYPE_BOOL: 470 case GTK_TYPE_BOOL:
472 return (build_string ("BOOL")); 471 return (build_ascstring ("BOOL"));
473 case GTK_TYPE_ENUM: 472 case GTK_TYPE_ENUM:
474 case GTK_TYPE_FLAGS: 473 case GTK_TYPE_FLAGS:
475 case GTK_TYPE_INT: 474 case GTK_TYPE_INT:
476 case GTK_TYPE_UINT: 475 case GTK_TYPE_UINT:
477 return (build_string ("INT")); 476 return (build_ascstring ("INT"));
478 case GTK_TYPE_LONG: 477 case GTK_TYPE_LONG:
479 case GTK_TYPE_ULONG: 478 case GTK_TYPE_ULONG:
480 return (build_string ("LONG")); 479 return (build_ascstring ("LONG"));
481 case GTK_TYPE_FLOAT: 480 case GTK_TYPE_FLOAT:
482 case GTK_TYPE_DOUBLE: 481 case GTK_TYPE_DOUBLE:
483 return (build_string ("FLOAT")); 482 return (build_ascstring ("FLOAT"));
484 case GTK_TYPE_STRING: 483 case GTK_TYPE_STRING:
485 return (build_string ("STRING")); 484 return (build_ascstring ("STRING"));
486 case GTK_TYPE_BOXED: 485 case GTK_TYPE_BOXED:
487 case GTK_TYPE_POINTER: 486 case GTK_TYPE_POINTER:
488 return (build_string ("POINTER")); 487 return (build_ascstring ("POINTER"));
489 case GTK_TYPE_OBJECT: 488 case GTK_TYPE_OBJECT:
490 return (build_string ("OBJECT")); 489 return (build_ascstring ("OBJECT"));
491 case GTK_TYPE_CALLBACK: 490 case GTK_TYPE_CALLBACK:
492 return (build_string ("CALLBACK")); 491 return (build_ascstring ("CALLBACK"));
493 default: 492 default:
494 /* I can't put this in the main switch statement because it is a 493 /* I can't put this in the main switch statement because it is a
495 new fundamental type that is not fixed at compile time. 494 new fundamental type that is not fixed at compile time.
496 *sigh* 495 *sigh*
497 */ 496 */
498 if (IS_XEMACS_GTK_FUNDAMENTAL_TYPE(t, GTK_TYPE_ARRAY)) 497 if (IS_XEMACS_GTK_FUNDAMENTAL_TYPE(t, GTK_TYPE_ARRAY))
499 return (build_string ("ARRAY")); 498 return (build_ascstring ("ARRAY"));
500 499
501 if (IS_XEMACS_GTK_FUNDAMENTAL_TYPE(t, GTK_TYPE_LISTOF)) 500 if (IS_XEMACS_GTK_FUNDAMENTAL_TYPE(t, GTK_TYPE_LISTOF))
502 return (build_string ("LIST")); 501 return (build_ascstring ("LIST"));
503 return (Qnil); 502 return (Qnil);
504 } 503 }
505 } 504 }
506 505
507 struct __dll_mapper_closure { 506 struct __dll_mapper_closure {
641 640
642 if (NILP (marshaller_type)) 641 if (NILP (marshaller_type))
643 { 642 {
644 invalid_argument ("Do not know how to marshal", type); 643 invalid_argument ("Do not know how to marshal", type);
645 } 644 }
646 marshaller = concat3 (marshaller, build_string ("_"), marshaller_type); 645 marshaller = concat3 (marshaller, build_ascstring ("_"), marshaller_type);
647 n_args++; 646 n_args++;
648 } 647 }
649 } 648 }
650 else 649 else
651 { 650 {
652 marshaller = concat3 (marshaller, build_string ("_"), type_to_marshaller_type (GTK_TYPE_NONE)); 651 marshaller = concat3 (marshaller, build_ascstring ("_"), type_to_marshaller_type (GTK_TYPE_NONE));
653 } 652 }
654 653
655 rettype = Fsymbol_name (rettype); 654 rettype = Fsymbol_name (rettype);
656 data->return_type = gtk_type_from_name ((char *) XSTRING_DATA (rettype)); 655 data->return_type = gtk_type_from_name ((char *) XSTRING_DATA (rettype));
657 656
660 invalid_argument ("Unknown return type", rettype); 659 invalid_argument ("Unknown return type", rettype);
661 } 660 }
662 661
663 import_gtk_type (data->return_type); 662 import_gtk_type (data->return_type);
664 663
665 marshaller = concat3 (type_to_marshaller_type (data->return_type), build_string ("_"), marshaller); 664 marshaller = concat3 (type_to_marshaller_type (data->return_type), build_ascstring ("_"), marshaller);
666 marshaller = concat2 (build_string ("emacs_gtk_marshal_"), marshaller); 665 marshaller = concat2 (build_ascstring ("emacs_gtk_marshal_"), marshaller);
667 666
668 marshaller_func = (ffi_marshalling_function) find_marshaller ((char *) XSTRING_DATA (marshaller)); 667 marshaller_func = (ffi_marshalling_function) find_marshaller ((char *) XSTRING_DATA (marshaller));
669 668
670 if (!marshaller_func) 669 if (!marshaller_func)
671 { 670 {
794 static void 793 static void
795 emacs_gtk_object_printer (Lisp_Object obj, Lisp_Object printcharfun, 794 emacs_gtk_object_printer (Lisp_Object obj, Lisp_Object printcharfun,
796 int UNUSED (escapeflag)) 795 int UNUSED (escapeflag))
797 { 796 {
798 if (print_readably) 797 if (print_readably)
799 printing_unreadable_object ("#<GtkObject %p>", XGTK_OBJECT (obj)->object); 798 printing_unreadable_lcrecord (obj, 0);
800 799
801 write_c_string (printcharfun, "#<GtkObject ("); 800 write_ascstring (printcharfun, "#<GtkObject (");
802 if (XGTK_OBJECT (obj)->alive_p) 801 if (XGTK_OBJECT (obj)->alive_p)
803 write_c_string (printcharfun, gtk_type_name (GTK_OBJECT_TYPE (XGTK_OBJECT (obj)->object))); 802 write_cistring (printcharfun, gtk_type_name (GTK_OBJECT_TYPE (XGTK_OBJECT (obj)->object)));
804 else 803 else
805 write_c_string (printcharfun, "dead"); 804 write_ascstring (printcharfun, "dead");
806 write_fmt_string (printcharfun, ") %p>", (void *) XGTK_OBJECT (obj)->object); 805 write_fmt_string (printcharfun, ") %p>", (void *) XGTK_OBJECT (obj)->object);
807 } 806 }
808 807
809 static Lisp_Object 808 static Lisp_Object
810 object_getprop (Lisp_Object obj, Lisp_Object prop) 809 object_getprop (Lisp_Object obj, Lisp_Object prop)
1004 static void 1003 static void
1005 __internal_callback_destroy (gpointer data) 1004 __internal_callback_destroy (gpointer data)
1006 { 1005 {
1007 Lisp_Object lisp_data; 1006 Lisp_Object lisp_data;
1008 1007
1009 lisp_data = VOID_TO_LISP (data); 1008 lisp_data = GET_LISP_FROM_VOID (data);
1010 1009
1011 ungcpro_popup_callbacks (XINT (XCAR (lisp_data))); 1010 ungcpro_popup_callbacks (XINT (XCAR (lisp_data)));
1012 } 1011 }
1013 1012
1014 static void 1013 static void
1020 Lisp_Object newargs[3]; 1019 Lisp_Object newargs[3];
1021 Lisp_Object rval = Qnil; 1020 Lisp_Object rval = Qnil;
1022 struct gcpro gcpro1; 1021 struct gcpro gcpro1;
1023 int i; 1022 int i;
1024 1023
1025 callback_fn = VOID_TO_LISP (data); 1024 callback_fn = GET_LISP_FROM_VOID (data);
1026 1025
1027 /* Nuke the GUI_ID off the front */ 1026 /* Nuke the GUI_ID off the front */
1028 callback_fn = XCDR (callback_fn); 1027 callback_fn = XCDR (callback_fn);
1029 1028
1030 callback_data = XCAR (callback_fn); 1029 callback_data = XCAR (callback_fn);
1086 func = Fcons (make_int (id), func); 1085 func = Fcons (make_int (id), func);
1087 1086
1088 gcpro_popup_callbacks (id, func); 1087 gcpro_popup_callbacks (id, func);
1089 1088
1090 gtk_signal_connect_full (XGTK_OBJECT (obj)->object, (char *) XSTRING_DATA (name), 1089 gtk_signal_connect_full (XGTK_OBJECT (obj)->object, (char *) XSTRING_DATA (name),
1091 NULL, __internal_callback_marshal, LISP_TO_VOID (func), 1090 NULL, __internal_callback_marshal, STORE_LISP_IN_VOID (func),
1092 __internal_callback_destroy, c_object_signal, c_after); 1091 __internal_callback_destroy, c_object_signal, c_after);
1093 return (Qt); 1092 return (Qt);
1094 } 1093 }
1095 1094
1096 1095
1102 static void 1101 static void
1103 emacs_gtk_boxed_printer (Lisp_Object obj, Lisp_Object printcharfun, 1102 emacs_gtk_boxed_printer (Lisp_Object obj, Lisp_Object printcharfun,
1104 int UNUSED (escapeflag)) 1103 int UNUSED (escapeflag))
1105 { 1104 {
1106 if (print_readably) 1105 if (print_readably)
1107 printing_unreadable_object ("#<GtkBoxed %p>", XGTK_BOXED (obj)->object); 1106 printing_unreadable_lcrecord (obj, 0);
1108 1107
1109 write_c_string (printcharfun, "#<GtkBoxed ("); 1108 write_ascstring (printcharfun, "#<GtkBoxed (");
1110 write_c_string (printcharfun, gtk_type_name (XGTK_BOXED (obj)->object_type)); 1109 write_cistring (printcharfun, gtk_type_name (XGTK_BOXED (obj)->object_type));
1111 write_fmt_string (printcharfun, ") %p>", (void *) XGTK_BOXED (obj)->object); 1110 write_fmt_string (printcharfun, ") %p>", (void *) XGTK_BOXED (obj)->object);
1112 } 1111 }
1113 1112
1114 static int 1113 static int
1115 emacs_gtk_boxed_equality (Lisp_Object o1, Lisp_Object o2, int UNUSED (depth)) 1114 emacs_gtk_boxed_equality (Lisp_Object o1, Lisp_Object o2, int UNUSED (depth))
1479 case GTK_TYPE_FLOAT: 1478 case GTK_TYPE_FLOAT:
1480 return (make_float (GTK_VALUE_FLOAT (*arg))); 1479 return (make_float (GTK_VALUE_FLOAT (*arg)));
1481 case GTK_TYPE_DOUBLE: 1480 case GTK_TYPE_DOUBLE:
1482 return (make_float (GTK_VALUE_DOUBLE (*arg))); 1481 return (make_float (GTK_VALUE_DOUBLE (*arg)));
1483 case GTK_TYPE_STRING: 1482 case GTK_TYPE_STRING:
1484 return (build_string (GTK_VALUE_STRING (*arg))); 1483 return (build_cistring (GTK_VALUE_STRING (*arg)));
1485 case GTK_TYPE_FLAGS: 1484 case GTK_TYPE_FLAGS:
1486 return (flags_to_list (GTK_VALUE_FLAGS (*arg), arg->type)); 1485 return (flags_to_list (GTK_VALUE_FLAGS (*arg), arg->type));
1487 case GTK_TYPE_ENUM: 1486 case GTK_TYPE_ENUM:
1488 return (enum_to_symbol (GTK_VALUE_ENUM (*arg), arg->type)); 1487 return (enum_to_symbol (GTK_VALUE_ENUM (*arg), arg->type));
1489 case GTK_TYPE_BOXED: 1488 case GTK_TYPE_BOXED:
1499 case GTK_TYPE_POINTER: 1498 case GTK_TYPE_POINTER:
1500 if (GTK_VALUE_POINTER (*arg)) 1499 if (GTK_VALUE_POINTER (*arg))
1501 { 1500 {
1502 Lisp_Object rval; 1501 Lisp_Object rval;
1503 1502
1504 rval = VOID_TO_LISP (GTK_VALUE_POINTER (*arg)); 1503 rval = GET_LISP_FROM_VOID (GTK_VALUE_POINTER (*arg));
1505 return (rval); 1504 return (rval);
1506 } 1505 }
1507 else 1506 else
1508 return (Qnil); 1507 return (Qnil);
1509 case GTK_TYPE_OBJECT: 1508 case GTK_TYPE_OBJECT:
1514 1513
1515 case GTK_TYPE_CALLBACK: 1514 case GTK_TYPE_CALLBACK:
1516 { 1515 {
1517 Lisp_Object rval; 1516 Lisp_Object rval;
1518 1517
1519 rval = VOID_TO_LISP (GTK_VALUE_CALLBACK (*arg).data); 1518 rval = GET_LISP_FROM_VOID (GTK_VALUE_CALLBACK (*arg).data);
1520 1519
1521 return (rval); 1520 return (rval);
1522 } 1521 }
1523 1522
1524 default: 1523 default:
1735 1734
1736 case GTK_TYPE_POINTER: 1735 case GTK_TYPE_POINTER:
1737 if (NILP (obj)) 1736 if (NILP (obj))
1738 GTK_VALUE_POINTER(*arg) = NULL; 1737 GTK_VALUE_POINTER(*arg) = NULL;
1739 else 1738 else
1740 GTK_VALUE_POINTER(*arg) = LISP_TO_VOID (obj); 1739 GTK_VALUE_POINTER(*arg) = STORE_LISP_IN_VOID (obj);
1741 break; 1740 break;
1742 1741
1743 /* structured types */ 1742 /* structured types */
1744 case GTK_TYPE_SIGNAL: 1743 case GTK_TYPE_SIGNAL:
1745 case GTK_TYPE_ARGS: /* This we can do as a list of values */ 1744 case GTK_TYPE_ARGS: /* This we can do as a list of values */
2015 2014
2016 case GTK_TYPE_POINTER: 2015 case GTK_TYPE_POINTER:
2017 if (NILP (obj)) 2016 if (NILP (obj))
2018 *(GTK_RETLOC_POINTER(*arg)) = NULL; 2017 *(GTK_RETLOC_POINTER(*arg)) = NULL;
2019 else 2018 else
2020 *(GTK_RETLOC_POINTER(*arg)) = LISP_TO_VOID (obj); 2019 *(GTK_RETLOC_POINTER(*arg)) = STORE_LISP_IN_VOID (obj);
2021 break; 2020 break;
2022 2021
2023 /* structured types */ 2022 /* structured types */
2024 case GTK_TYPE_SIGNAL: 2023 case GTK_TYPE_SIGNAL:
2025 case GTK_TYPE_ARGS: /* This we can do as a list of values */ 2024 case GTK_TYPE_ARGS: /* This we can do as a list of values */
2119 Lisp_Object alist = get_enumeration (t); 2118 Lisp_Object alist = get_enumeration (t);
2120 Lisp_Object value = Qnil; 2119 Lisp_Object value = Qnil;
2121 2120
2122 if (NILP (alist)) 2121 if (NILP (alist))
2123 { 2122 {
2124 invalid_argument ("Unknown enumeration", build_string (gtk_type_name (t))); 2123 invalid_argument ("Unknown enumeration", build_cistring (gtk_type_name (t)));
2125 } 2124 }
2126 2125
2127 value = Fassq (obj, alist); 2126 value = Fassq (obj, alist);
2128 2127
2129 if (NILP (value)) 2128 if (NILP (value))
2188 Lisp_Object alist = get_enumeration (t); 2187 Lisp_Object alist = get_enumeration (t);
2189 Lisp_Object cell = Qnil; 2188 Lisp_Object cell = Qnil;
2190 2189
2191 if (NILP (alist)) 2190 if (NILP (alist))
2192 { 2191 {
2193 invalid_argument ("Unknown enumeration", build_string (gtk_type_name (t))); 2192 invalid_argument ("Unknown enumeration", build_cistring (gtk_type_name (t)));
2194 } 2193 }
2195 2194
2196 cell = Frassq (make_int (value), alist); 2195 cell = Frassq (make_int (value), alist);
2197 2196
2198 return (NILP (cell) ? Qnil : XCAR (cell)); 2197 return (NILP (cell) ? Qnil : XCAR (cell));