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