Mercurial > hg > xemacs-beta
annotate src/ui-gtk.c @ 5142:f965e31a35f0
reduce lcrecord headers to 2 words, rename printing_unreadable_object
-------------------- ChangeLog entries follow: --------------------
man/ChangeLog addition:
2010-03-13 Ben Wing <ben@xemacs.org>
* internals/internals.texi (Working with Lisp Objects):
* internals/internals.texi (Writing Macros):
* internals/internals.texi (lrecords):
More rewriting to correspond with changes from
*LRECORD* to *LISP_OBJECT*.
modules/ChangeLog addition:
2010-03-13 Ben Wing <ben@xemacs.org>
* postgresql/postgresql.c (print_pgconn):
* postgresql/postgresql.c (print_pgresult):
printing_unreadable_object -> printing_unreadable_object_fmt.
2010-03-13 Ben Wing <ben@xemacs.org>
* ldap/eldap.c (print_ldap):
printing_unreadable_object -> printing_unreadable_object_fmt.
src/ChangeLog addition:
2010-03-13 Ben Wing <ben@xemacs.org>
* alloc.c (alloc_sized_lrecord_1):
* alloc.c (alloc_sized_lrecord_array):
* alloc.c (old_alloc_sized_lcrecord):
* alloc.c (disksave_object_finalization_1):
* alloc.c (mark_lcrecord_list):
* alloc.c (alloc_managed_lcrecord):
* alloc.c (free_managed_lcrecord):
* alloc.c (tick_lcrecord_stats):
* alloc.c (sweep_lcrecords_1):
* buffer.c (print_buffer):
* buffer.c (DEFVAR_BUFFER_LOCAL_1):
* casetab.c:
* casetab.c (print_case_table):
* console.c (print_console):
* console.c (DEFVAR_CONSOLE_LOCAL_1):
* data.c (print_weak_list):
* data.c (print_weak_box):
* data.c (print_ephemeron):
* data.c (ephemeron_equal):
* database.c (print_database):
* database.c (finalize_database):
* device-msw.c (sync_printer_with_devmode):
* device-msw.c (print_devmode):
* device-msw.c (finalize_devmode):
* device.c:
* device.c (print_device):
* elhash.c:
* elhash.c (print_hash_table):
* eval.c (print_subr):
* eval.c (print_multiple_value):
* event-stream.c (event_stream_resignal_wakeup):
* events.c (clear_event_resource):
* events.c (zero_event):
* events.c (print_event):
* extents.c:
* extents.c (print_extent):
* file-coding.c (print_coding_system):
* font-mgr.c:
* font-mgr.c (Ffc_init):
* frame.c:
* frame.c (print_frame):
* gc.c:
* gc.c (GC_CHECK_NOT_FREE):
* glyphs.c:
* glyphs.c (print_image_instance):
* glyphs.c (print_glyph):
* gui.c (print_gui_item):
* gui.c (copy_gui_item):
* keymap.c (print_keymap):
* keymap.c (MARKED_SLOT):
* lisp.h:
* lisp.h (struct Lisp_String):
* lisp.h (DEFUN):
* lisp.h (DEFUN_NORETURN):
* lrecord.h:
* lrecord.h (NORMAL_LISP_OBJECT_UID):
* lrecord.h (struct lrecord_header):
* lrecord.h (set_lheader_implementation):
* lrecord.h (struct old_lcrecord_header):
* lrecord.h (struct free_lcrecord_header):
* marker.c (print_marker):
* mule-charset.c:
* mule-charset.c (print_charset):
* objects.c (print_color_instance):
* objects.c (print_font_instance):
* objects.c (finalize_font_instance):
* print.c (print_cons):
* print.c (printing_unreadable_object_fmt):
* print.c (printing_unreadable_lisp_object):
* print.c (external_object_printer):
* print.c (internal_object_printer):
* print.c (debug_p4):
* print.c (ext_print_begin):
* process.c (print_process):
* rangetab.c (print_range_table):
* rangetab.c (range_table_equal):
* scrollbar.c (free_scrollbar_instance):
* specifier.c (print_specifier):
* specifier.c (finalize_specifier):
* symbols.c (guts_of_unbound_marker):
* symeval.h:
* symeval.h (DEFVAR_SYMVAL_FWD):
* tooltalk.c:
* tooltalk.c (print_tooltalk_message):
* tooltalk.c (print_tooltalk_pattern):
* ui-gtk.c (ffi_object_printer):
* ui-gtk.c (emacs_gtk_object_printer):
* ui-gtk.c (emacs_gtk_boxed_printer):
* window.c (print_window):
* window.c (free_window_mirror):
* window.c (debug_print_window):
* xemacs.def.in.in:
(1) printing_unreadable_object -> printing_unreadable_object_fmt.
(2) printing_unreadable_lcrecord -> printing_unreadable_lisp_object
and fix up so it no longer requires an lcrecord.
These previous changes eliminate most of the remaining places where
the terms `lcrecord' and `lrecord' occurred outside of specialized
code.
(3) Fairly major change: Reduce the number of words in an lcrecord
from 3 to 2. The third word consisted of a uid that duplicated the
lrecord uid, and a single free bit, which was moved into the lrecord
structure. This reduces the size of the `uid' slot from 21 bits to
20 bits. Arguably this isn't enough -- we could easily have more than
1,000,000 or so objects created in a session. The answer is
(a) It doesn't really matter if we overflow the uid field because
it's only used for debugging, to identify an object uniquely
(or pretty much so).
(b) If we cared about it overflowing and wanted to reduce this,
we could make it so that cons, string, float and certain other
frob-block types that never print out the uid simply don't
store a uid in them and don't increment the lrecord_uid_counter.
(4) In conjunction with (3), create new macro NORMAL_LISP_OBJECT_UID()
and use it to abstract out the differences between NEWGC and old-GC
in accessing the `uid' value from a "normal Lisp Object pointer".
(5) In events.c, use zero_nonsized_lisp_object() in place of custom-
written equivalent. In font-mgr.c use external_object_printer()
in place of custom-written equivalents.
| author | Ben Wing <ben@xemacs.org> |
|---|---|
| date | Sat, 13 Mar 2010 05:38:08 -0600 |
| parents | a9c41067dd88 |
| children | 1fae11d56ad2 |
| 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 | |
| 810 object_getprop (Lisp_Object obj, Lisp_Object prop) | |
| 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 | |
| 874 object_putprop (Lisp_Object obj, Lisp_Object prop, Lisp_Object value) | |
| 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 | |
|
5124
623d57b7fbe8
separate regular and disksave finalization, print method fixes.
Ben Wing <ben@xemacs.org>
parents:
5118
diff
changeset
|
935 DEFINE_NODUMP_GENERAL_LISP_OBJECT ("GtkObject", emacs_gtk_object, |
|
623d57b7fbe8
separate regular and disksave finalization, print method fixes.
Ben Wing <ben@xemacs.org>
parents:
5118
diff
changeset
|
936 mark_gtk_object_data, |
|
623d57b7fbe8
separate regular and disksave finalization, print method fixes.
Ben Wing <ben@xemacs.org>
parents:
5118
diff
changeset
|
937 emacs_gtk_object_printer, |
|
623d57b7fbe8
separate regular and disksave finalization, print method fixes.
Ben Wing <ben@xemacs.org>
parents:
5118
diff
changeset
|
938 emacs_gtk_object_finalizer, |
|
623d57b7fbe8
separate regular and disksave finalization, print method fixes.
Ben Wing <ben@xemacs.org>
parents:
5118
diff
changeset
|
939 0, /* equality */ |
|
623d57b7fbe8
separate regular and disksave finalization, print method fixes.
Ben Wing <ben@xemacs.org>
parents:
5118
diff
changeset
|
940 0, /* hash */ |
|
623d57b7fbe8
separate regular and disksave finalization, print method fixes.
Ben Wing <ben@xemacs.org>
parents:
5118
diff
changeset
|
941 gtk_object_data_description, |
|
623d57b7fbe8
separate regular and disksave finalization, print method fixes.
Ben Wing <ben@xemacs.org>
parents:
5118
diff
changeset
|
942 object_getprop, |
|
623d57b7fbe8
separate regular and disksave finalization, print method fixes.
Ben Wing <ben@xemacs.org>
parents:
5118
diff
changeset
|
943 object_putprop, |
|
623d57b7fbe8
separate regular and disksave finalization, print method fixes.
Ben Wing <ben@xemacs.org>
parents:
5118
diff
changeset
|
944 0, /* rem prop */ |
|
623d57b7fbe8
separate regular and disksave finalization, print method fixes.
Ben Wing <ben@xemacs.org>
parents:
5118
diff
changeset
|
945 0, /* plist */ |
|
623d57b7fbe8
separate regular and disksave finalization, print method fixes.
Ben Wing <ben@xemacs.org>
parents:
5118
diff
changeset
|
946 0, /* disksaver */ |
|
623d57b7fbe8
separate regular and disksave finalization, print method fixes.
Ben Wing <ben@xemacs.org>
parents:
5118
diff
changeset
|
947 emacs_gtk_object_data); |
| 462 | 948 |
| 949 static emacs_gtk_object_data * | |
| 950 allocate_emacs_gtk_object_data (void) | |
| 951 { | |
|
5127
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5125
diff
changeset
|
952 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
|
953 emacs_gtk_object_data *data = XGTK_OBJECT (obj); |
| 462 | 954 |
| 955 data->object = NULL; | |
| 956 data->alive_p = FALSE; | |
| 957 data->plist = Qnil; | |
| 958 | |
| 959 return (data); | |
| 960 } | |
| 961 | |
| 962 /* We need to keep track of when the object is destroyed so that we | |
| 963 can mark it as dead, otherwise even our print routine (which calls | |
| 964 GTK_OBJECT_TYPE) will crap out and die. This is also used in the | |
| 965 lisp_to_gtk_type() routine to defend against passing dead objects | |
| 966 to GTK routines. */ | |
| 967 static void | |
| 2286 | 968 __notice_object_destruction (GtkObject *UNUSED (obj), gpointer user_data) |
| 462 | 969 { |
| 970 ungcpro_popup_callbacks ((GUI_ID) user_data); | |
| 971 } | |
| 972 | |
| 973 Lisp_Object build_gtk_object (GtkObject *obj) | |
| 974 { | |
| 975 Lisp_Object retval = Qnil; | |
| 976 emacs_gtk_object_data *data = NULL; | |
| 977 GUI_ID id = 0; | |
| 978 | |
| 2168 | 979 id = (GUI_ID) gtk_object_get_data (obj, GTK_DATA_GUI_IDENTIFIER); |
| 462 | 980 |
| 981 if (id) | |
| 982 { | |
| 983 retval = get_gcpro_popup_callbacks (id); | |
| 984 } | |
| 985 | |
| 986 if (NILP (retval)) | |
| 987 { | |
| 988 data = allocate_emacs_gtk_object_data (); | |
| 989 | |
| 990 data->object = obj; | |
| 991 data->alive_p = TRUE; | |
| 797 | 992 retval = wrap_emacs_gtk_object (data); |
| 462 | 993 |
| 994 id = new_gui_id (); | |
| 2168 | 995 gtk_object_set_data (obj, GTK_DATA_GUI_IDENTIFIER, (gpointer) id); |
| 462 | 996 gcpro_popup_callbacks (id, retval); |
| 997 gtk_object_ref (obj); | |
| 998 gtk_signal_connect (obj, "destroy", GTK_SIGNAL_FUNC (__notice_object_destruction), (gpointer)id); | |
| 999 } | |
| 1000 | |
| 1001 return (retval); | |
| 1002 } | |
| 1003 | |
| 1004 static void | |
| 1005 __internal_callback_destroy (gpointer data) | |
| 1006 { | |
| 1007 Lisp_Object lisp_data; | |
| 1008 | |
| 5013 | 1009 lisp_data = GET_LISP_FROM_VOID (data); |
| 462 | 1010 |
| 1011 ungcpro_popup_callbacks (XINT (XCAR (lisp_data))); | |
| 1012 } | |
| 1013 | |
| 1014 static void | |
| 1015 __internal_callback_marshal (GtkObject *obj, gpointer data, guint n_args, GtkArg *args) | |
| 1016 { | |
| 1017 Lisp_Object arg_list = Qnil; | |
| 1018 Lisp_Object callback_fn = Qnil; | |
| 1019 Lisp_Object callback_data = Qnil; | |
| 1020 Lisp_Object newargs[3]; | |
| 1021 Lisp_Object rval = Qnil; | |
| 1022 struct gcpro gcpro1; | |
| 1023 int i; | |
| 1024 | |
| 5013 | 1025 callback_fn = GET_LISP_FROM_VOID (data); |
| 462 | 1026 |
| 1027 /* Nuke the GUI_ID off the front */ | |
| 1028 callback_fn = XCDR (callback_fn); | |
| 1029 | |
| 1030 callback_data = XCAR (callback_fn); | |
| 1031 callback_fn = XCDR (callback_fn); | |
| 1032 | |
| 1033 /* The callback data goes at the very end of the argument list */ | |
| 1034 arg_list = Fcons (callback_data, Qnil); | |
| 1035 | |
| 1036 /* Build up the argument list, lisp style */ | |
| 1037 for (i = n_args - 1; i >= 0; i--) | |
| 1038 { | |
| 1039 arg_list = Fcons (gtk_type_to_lisp (&args[i]), arg_list); | |
| 1040 } | |
| 1041 | |
| 1042 /* We always pass the widget as the first parameter at the very least */ | |
| 1043 arg_list = Fcons (build_gtk_object (obj), arg_list); | |
| 1044 | |
| 1045 GCPRO1 ((arg_list)); | |
| 1046 | |
| 1047 newargs[0] = callback_fn; | |
| 1048 newargs[1] = arg_list; | |
| 1049 | |
| 1050 rval = Fapply (2, newargs); | |
| 1051 signal_fake_event (); | |
| 1052 | |
| 1053 if (args[n_args].type != GTK_TYPE_NONE) | |
| 1883 | 1054 lisp_to_gtk_ret_type (rval, &args[n_args]); |
| 462 | 1055 |
| 1056 UNGCPRO; | |
| 1057 } | |
| 1058 | |
| 1059 DEFUN ("gtk-signal-connect", Fgtk_signal_connect, 3, 6, 0, /* | |
| 1060 */ | |
| 1061 (obj, name, func, cb_data, object_signal, after_p)) | |
| 1062 { | |
| 1063 int c_after; | |
| 1064 int c_object_signal; | |
| 1065 GUI_ID id = 0; | |
| 1066 | |
| 1067 CHECK_GTK_OBJECT (obj); | |
| 1068 | |
| 1069 if (SYMBOLP (name)) | |
| 1070 name = Fsymbol_name (name); | |
| 1071 | |
| 1072 CHECK_STRING (name); | |
| 1073 | |
| 1074 if (NILP (object_signal)) | |
| 1075 c_object_signal = 0; | |
| 1076 else | |
| 1077 c_object_signal = 1; | |
| 1078 | |
| 1079 if (NILP (after_p)) | |
| 1080 c_after = 0; | |
| 1081 else | |
| 1082 c_after = 1; | |
| 1083 | |
| 1084 id = new_gui_id (); | |
| 1085 func = Fcons (cb_data, func); | |
| 1086 func = Fcons (make_int (id), func); | |
| 1087 | |
| 1088 gcpro_popup_callbacks (id, func); | |
| 1089 | |
| 1090 gtk_signal_connect_full (XGTK_OBJECT (obj)->object, (char *) XSTRING_DATA (name), | |
| 5013 | 1091 NULL, __internal_callback_marshal, STORE_LISP_IN_VOID (func), |
| 462 | 1092 __internal_callback_destroy, c_object_signal, c_after); |
| 1093 return (Qt); | |
| 1094 } | |
| 1095 | |
| 1096 | |
| 1097 /* GTK_TYPE_BOXED wrapper for Emacs lisp */ | |
| 1204 | 1098 static const struct memory_description emacs_gtk_boxed_description [] = { |
| 960 | 1099 { XD_END } |
| 1100 }; | |
| 1101 | |
| 462 | 1102 static void |
| 2286 | 1103 emacs_gtk_boxed_printer (Lisp_Object obj, Lisp_Object printcharfun, |
| 1104 int UNUSED (escapeflag)) | |
| 462 | 1105 { |
| 1106 if (print_readably) | |
|
5142
f965e31a35f0
reduce lcrecord headers to 2 words, rename printing_unreadable_object
Ben Wing <ben@xemacs.org>
parents:
5127
diff
changeset
|
1107 printing_unreadable_lisp_object (obj, 0); |
| 462 | 1108 |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
1109 write_ascstring (printcharfun, "#<GtkBoxed ("); |
|
4953
304aebb79cd3
function renamings to track names of char typedefs
Ben Wing <ben@xemacs.org>
parents:
4952
diff
changeset
|
1110 write_cistring (printcharfun, gtk_type_name (XGTK_BOXED (obj)->object_type)); |
| 800 | 1111 write_fmt_string (printcharfun, ") %p>", (void *) XGTK_BOXED (obj)->object); |
| 462 | 1112 } |
| 1113 | |
| 1114 static int | |
| 2286 | 1115 emacs_gtk_boxed_equality (Lisp_Object o1, Lisp_Object o2, int UNUSED (depth)) |
| 462 | 1116 { |
| 1117 emacs_gtk_boxed_data *data1 = XGTK_BOXED(o1); | |
| 1118 emacs_gtk_boxed_data *data2 = XGTK_BOXED(o2); | |
| 1119 | |
| 1120 return ((data1->object == data2->object) && | |
| 1121 (data1->object_type == data2->object_type)); | |
| 1122 } | |
| 1123 | |
| 2515 | 1124 static Hashcode |
| 2286 | 1125 emacs_gtk_boxed_hash (Lisp_Object obj, int UNUSED (depth)) |
| 462 | 1126 { |
| 1127 emacs_gtk_boxed_data *data = XGTK_BOXED(obj); | |
| 2515 | 1128 return (HASH2 ((Hashcode) data->object, data->object_type)); |
| 462 | 1129 } |
| 1130 | |
|
5124
623d57b7fbe8
separate regular and disksave finalization, print method fixes.
Ben Wing <ben@xemacs.org>
parents:
5118
diff
changeset
|
1131 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
|
1132 0, /* marker function */ |
|
623d57b7fbe8
separate regular and disksave finalization, print method fixes.
Ben Wing <ben@xemacs.org>
parents:
5118
diff
changeset
|
1133 emacs_gtk_boxed_printer, |
|
623d57b7fbe8
separate regular and disksave finalization, print method fixes.
Ben Wing <ben@xemacs.org>
parents:
5118
diff
changeset
|
1134 0, /* nuker */ |
|
623d57b7fbe8
separate regular and disksave finalization, print method fixes.
Ben Wing <ben@xemacs.org>
parents:
5118
diff
changeset
|
1135 emacs_gtk_boxed_equality, |
|
623d57b7fbe8
separate regular and disksave finalization, print method fixes.
Ben Wing <ben@xemacs.org>
parents:
5118
diff
changeset
|
1136 emacs_gtk_boxed_hash, |
|
623d57b7fbe8
separate regular and disksave finalization, print method fixes.
Ben Wing <ben@xemacs.org>
parents:
5118
diff
changeset
|
1137 emacs_gtk_boxed_description, |
|
623d57b7fbe8
separate regular and disksave finalization, print method fixes.
Ben Wing <ben@xemacs.org>
parents:
5118
diff
changeset
|
1138 emacs_gtk_boxed_data); |
| 462 | 1139 /* Currently defined GTK_TYPE_BOXED structures are: |
| 1140 | |
| 1141 GtkAccelGroup - | |
| 1142 GtkSelectionData - | |
| 1143 GtkStyle - | |
| 1144 GtkCTreeNode - | |
| 1145 GdkColormap - | |
| 1146 GdkVisual - | |
| 1147 GdkFont - | |
| 1148 GdkWindow - | |
| 1149 GdkDragContext - | |
| 1150 GdkEvent - | |
| 1151 GdkColor - | |
| 1152 */ | |
| 1153 static emacs_gtk_boxed_data * | |
| 1154 allocate_emacs_gtk_boxed_data (void) | |
| 1155 { | |
|
5127
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5125
diff
changeset
|
1156 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
|
1157 emacs_gtk_boxed_data *data = XGTK_BOXED (obj); |
| 462 | 1158 |
| 1159 data->object = NULL; | |
| 1160 data->object_type = GTK_TYPE_INVALID; | |
| 1161 | |
| 1162 return (data); | |
| 1163 } | |
| 1164 | |
| 1165 Lisp_Object build_gtk_boxed (void *obj, GtkType t) | |
| 1166 { | |
| 1167 Lisp_Object retval = Qnil; | |
| 1168 emacs_gtk_boxed_data *data = NULL; | |
| 1169 | |
| 1170 if (GTK_FUNDAMENTAL_TYPE (t) != GTK_TYPE_BOXED) | |
| 2500 | 1171 ABORT(); |
| 462 | 1172 |
| 1173 data = allocate_emacs_gtk_boxed_data (); | |
| 1174 data->object = obj; | |
| 1175 data->object_type = t; | |
| 1176 | |
| 797 | 1177 retval = wrap_emacs_gtk_boxed (data); |
| 462 | 1178 |
| 1179 return (retval); | |
| 1180 } | |
| 1181 | |
| 1182 | |
| 1183 /* The automatically generated structure access routines */ | |
| 1184 #include "emacs-widget-accessors.c" | |
| 1185 | |
| 1186 /* The hand generated funky functions that we can't just import using the FFI */ | |
| 1187 #include "ui-byhand.c" | |
| 1188 | |
| 1189 /* The glade support */ | |
| 1190 #include "glade.c" | |
| 1191 | |
| 1192 | |
| 1193 /* Type manipulation */ | |
| 1194 DEFUN ("gtk-fundamental-type", Fgtk_fundamental_type, 1, 1, 0, /* | |
| 1195 Load a shared library DLL into XEmacs. No initialization routines are required. | |
| 1196 This is for loading dependency DLLs into XEmacs. | |
| 1197 */ | |
| 1198 (type)) | |
| 1199 { | |
| 1200 GtkType t; | |
| 1201 | |
| 1202 if (SYMBOLP (type)) | |
| 1203 type = Fsymbol_name (type); | |
| 1204 | |
| 1205 CHECK_STRING (type); | |
| 1206 | |
| 1207 t = gtk_type_from_name ((char *) XSTRING_DATA (type)); | |
| 1208 | |
| 1209 if (t == GTK_TYPE_INVALID) | |
| 1210 { | |
| 563 | 1211 invalid_argument ("Not a GTK type", type); |
| 462 | 1212 } |
| 1213 return (make_int (GTK_FUNDAMENTAL_TYPE (t))); | |
| 1214 } | |
| 1215 | |
| 1216 DEFUN ("gtk-object-type", Fgtk_object_type, 1, 1, 0, /* | |
| 1217 Return the GtkType of OBJECT. | |
| 1218 */ | |
| 1219 (object)) | |
| 1220 { | |
| 1221 CHECK_GTK_OBJECT (object); | |
| 1222 return (make_int (GTK_OBJECT_TYPE (XGTK_OBJECT (object)->object))); | |
| 1223 } | |
| 1224 | |
| 1225 DEFUN ("gtk-describe-type", Fgtk_describe_type, 1, 1, 0, /* | |
| 1226 Returns a cons of two lists describing the Gtk object TYPE. | |
| 1227 The car is a list of all the signals that it will emit. | |
| 1228 The cdr is a list of all the magic properties it has. | |
| 1229 */ | |
| 1230 (type)) | |
| 1231 { | |
| 1232 Lisp_Object rval, signals, props; | |
| 1233 GtkType t; | |
| 1234 | |
| 1235 props = signals = rval = Qnil; | |
| 1236 | |
| 1237 if (SYMBOLP (type)) | |
| 1238 { | |
| 1239 type = Fsymbol_name (type); | |
| 1240 } | |
| 1241 | |
| 1242 if (STRINGP (type)) | |
| 1243 { | |
| 2054 | 1244 t = gtk_type_from_name ((gchar*) XSTRING_DATA (type)); |
| 462 | 1245 if (t == GTK_TYPE_INVALID) |
| 1246 { | |
| 563 | 1247 invalid_argument ("Not a GTK type", type); |
| 462 | 1248 } |
| 1249 } | |
| 1250 else | |
| 1251 { | |
| 1252 CHECK_INT (type); | |
| 1253 t = XINT (type); | |
| 1254 } | |
| 1255 | |
| 1256 if (GTK_FUNDAMENTAL_TYPE (t) != GTK_TYPE_OBJECT) | |
| 1257 { | |
| 563 | 1258 invalid_argument ("Not a GtkObject", type); |
| 462 | 1259 } |
| 1260 | |
| 1261 /* Need to do stupid shit like this to get the args | |
| 1262 ** registered... damn GTK and its lazy loading | |
| 1263 */ | |
| 1264 { | |
| 1265 GtkArg args[3]; | |
| 1266 GtkObject *obj = gtk_object_newv (t, 0, args); | |
| 1267 | |
| 1268 gtk_object_destroy(obj); | |
| 1269 } | |
| 1270 | |
| 1271 do | |
| 1272 { | |
| 1273 guint i; | |
| 1274 | |
| 1275 /* Do the magic arguments first */ | |
| 1276 { | |
| 1277 GtkArg *args; | |
| 1278 guint32 *flags; | |
| 1279 guint n_args; | |
| 1280 | |
| 1281 args = gtk_object_query_args(t,&flags,&n_args); | |
| 1282 | |
| 1283 for (i = 0; i < n_args; i++) | |
| 1284 { | |
| 1285 props = Fcons (Fcons (intern (gtk_type_name(args[i].type)), | |
| 1286 intern (args[i].name)), props); | |
| 1287 } | |
| 1288 | |
| 1289 g_free (args); | |
| 1290 g_free (flags); | |
| 1291 } | |
| 1292 | |
| 1293 /* Now the signals */ | |
| 1294 { | |
| 1295 GtkObjectClass *klass; | |
| 1296 GtkSignalQuery *query; | |
| 1297 guint32 *gtk_signals; | |
| 1298 guint n_signals; | |
| 1299 | |
| 1300 klass = (GtkObjectClass *) gtk_type_class (t); | |
| 1301 gtk_signals = klass->signals; | |
| 1302 n_signals = klass->nsignals; | |
| 1303 | |
| 1304 for (i = 0; i < n_signals; i++) | |
| 1305 { | |
| 1306 Lisp_Object params = Qnil; | |
| 1307 | |
| 1308 query = gtk_signal_query (gtk_signals[i]); | |
| 1309 | |
| 1310 if (query) | |
| 1311 { | |
| 1312 if (query->nparams) | |
| 1313 { | |
| 1314 int j; | |
| 1315 | |
| 1316 for (j = query->nparams - 1; j >= 0; j--) | |
| 1317 { | |
| 1318 params = Fcons (intern (gtk_type_name (query->params[j])), params); | |
| 1319 } | |
| 1320 } | |
| 1321 | |
| 1322 signals = Fcons (Fcons (intern (gtk_type_name (query->return_val)), | |
| 1323 Fcons (intern (query->signal_name), | |
| 1324 params)), | |
| 1325 signals); | |
| 1326 | |
| 1327 g_free (query); | |
| 1328 } | |
| 1329 } | |
| 1330 } | |
| 1331 t = gtk_type_parent(t); | |
| 1332 } while (t != GTK_TYPE_INVALID); | |
| 1333 | |
| 1334 rval = Fcons (signals, props); | |
| 1335 | |
| 1336 return (rval); | |
| 1337 } | |
| 1338 | |
| 1339 | |
| 1340 void | |
| 1341 syms_of_ui_gtk (void) | |
| 1342 { | |
|
5117
3742ea8250b5
Checking in final CVS version of workspace 'ben-lisp-object'
Ben Wing <ben@xemacs.org>
parents:
3017
diff
changeset
|
1343 INIT_LISP_OBJECT (emacs_ffi); |
|
3742ea8250b5
Checking in final CVS version of workspace 'ben-lisp-object'
Ben Wing <ben@xemacs.org>
parents:
3017
diff
changeset
|
1344 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
|
1345 INIT_LISP_OBJECT (emacs_gtk_boxed); |
| 563 | 1346 DEFSYMBOL_MULTIWORD_PREDICATE (Qemacs_ffip); |
| 1347 DEFSYMBOL_MULTIWORD_PREDICATE (Qemacs_gtk_objectp); | |
| 1348 DEFSYMBOL_MULTIWORD_PREDICATE (Qemacs_gtk_boxedp); | |
| 1349 DEFSYMBOL (Qvoid); | |
| 462 | 1350 DEFSUBR (Fdll_load); |
| 1351 DEFSUBR (Fgtk_import_function_internal); | |
| 1352 DEFSUBR (Fgtk_import_variable_internal); | |
| 1353 DEFSUBR (Fgtk_signal_connect); | |
| 1354 DEFSUBR (Fgtk_call_function); | |
| 1355 DEFSUBR (Fgtk_fundamental_type); | |
| 1356 DEFSUBR (Fgtk_object_type); | |
| 1357 DEFSUBR (Fgtk_describe_type); | |
| 1358 syms_of_widget_accessors (); | |
| 1359 syms_of_ui_byhand (); | |
| 1360 syms_of_glade (); | |
| 1361 } | |
| 1362 | |
| 1363 void | |
| 1364 vars_of_ui_gtk (void) | |
| 1365 { | |
| 1366 Fprovide (intern ("gtk-ui")); | |
| 1367 DEFVAR_LISP ("gtk-enumeration-info", &Venumeration_info /* | |
| 1368 A hashtable holding type information about GTK enumerations and flags. | |
| 1369 Do NOT modify unless you really understand ui-gtk.c. | |
| 1370 */); | |
| 1371 | |
| 1372 Venumeration_info = Qnil; | |
| 1373 vars_of_glade (); | |
| 1374 } | |
| 1375 | |
| 1376 | |
| 1377 /* Various utility functions */ | |
| 778 | 1378 #if 0 |
| 462 | 1379 void describe_gtk_arg (GtkArg *arg) |
| 1380 { | |
| 1381 GtkArg a = *arg; | |
| 1382 | |
| 1383 switch (GTK_FUNDAMENTAL_TYPE (a.type)) | |
| 1384 { | |
| 1385 /* flag types */ | |
| 1386 case GTK_TYPE_CHAR: | |
| 1387 stderr_out ("char: %c\n", GTK_VALUE_CHAR (a)); | |
| 1388 break; | |
| 1389 case GTK_TYPE_UCHAR: | |
| 1390 stderr_out ("uchar: %c\n", GTK_VALUE_CHAR (a)); | |
| 1391 break; | |
| 1392 case GTK_TYPE_BOOL: | |
| 1393 stderr_out ("uchar: %s\n", GTK_VALUE_BOOL (a) ? "true" : "false"); | |
| 1394 break; | |
| 1395 case GTK_TYPE_INT: | |
| 1396 stderr_out ("int: %d\n", GTK_VALUE_INT (a)); | |
| 1397 break; | |
| 1398 case GTK_TYPE_UINT: | |
| 1399 stderr_out ("uint: %du\n", GTK_VALUE_UINT (a)); | |
| 1400 break; | |
| 1401 case GTK_TYPE_LONG: | |
| 1402 stderr_out ("long: %ld\n", GTK_VALUE_LONG (a)); | |
| 1403 break; | |
| 1404 case GTK_TYPE_ULONG: | |
| 1405 stderr_out ("ulong: %lu\n", GTK_VALUE_ULONG (a)); | |
| 1406 break; | |
| 1407 case GTK_TYPE_FLOAT: | |
| 1408 stderr_out ("float: %g\n", GTK_VALUE_FLOAT (a)); | |
| 1409 break; | |
| 1410 case GTK_TYPE_DOUBLE: | |
| 1411 stderr_out ("double: %f\n", GTK_VALUE_DOUBLE (a)); | |
| 1412 break; | |
| 1413 case GTK_TYPE_STRING: | |
| 1414 stderr_out ("string: %s\n", GTK_VALUE_STRING (a)); | |
| 1415 break; | |
| 1416 case GTK_TYPE_ENUM: | |
| 1417 case GTK_TYPE_FLAGS: | |
| 1418 stderr_out ("%s: ", (a.type == GTK_TYPE_ENUM) ? "enum" : "flag"); | |
| 1419 { | |
| 1420 GtkEnumValue *vals = gtk_type_enum_get_values (a.type); | |
| 1421 | |
| 1422 while (vals && vals->value_name && (vals->value != GTK_VALUE_ENUM(a))) vals++; | |
| 1423 | |
| 1424 stderr_out ("%s\n", vals ? vals->value_name : "!!! UNKNOWN ENUM VALUE !!!"); | |
| 1425 } | |
| 1426 break; | |
| 1427 case GTK_TYPE_BOXED: | |
| 1428 stderr_out ("boxed: %p\n", GTK_VALUE_BOXED (a)); | |
| 1429 break; | |
| 1430 case GTK_TYPE_POINTER: | |
| 1431 stderr_out ("pointer: %p\n", GTK_VALUE_BOXED (a)); | |
| 1432 break; | |
| 1433 | |
| 1434 /* structured types */ | |
| 1435 case GTK_TYPE_SIGNAL: | |
| 1436 case GTK_TYPE_ARGS: /* This we can do as a list of values */ | |
| 2500 | 1437 ABORT(); |
| 462 | 1438 case GTK_TYPE_CALLBACK: |
| 1439 stderr_out ("callback fn: ...\n"); | |
| 1440 break; | |
| 1441 case GTK_TYPE_C_CALLBACK: | |
| 1442 case GTK_TYPE_FOREIGN: | |
| 2500 | 1443 ABORT(); |
| 462 | 1444 |
| 1445 /* base type of the object system */ | |
| 1446 case GTK_TYPE_OBJECT: | |
| 1447 if (GTK_VALUE_OBJECT (a)) | |
| 1448 stderr_out ("object: %s\n", gtk_type_name (GTK_OBJECT_TYPE (GTK_VALUE_OBJECT (a)))); | |
| 1449 else | |
| 1450 stderr_out ("object: NULL\n"); | |
| 1451 break; | |
| 1452 | |
| 1453 default: | |
| 2500 | 1454 ABORT(); |
| 462 | 1455 } |
| 1456 } | |
| 778 | 1457 #endif |
| 462 | 1458 |
| 1459 Lisp_Object gtk_type_to_lisp (GtkArg *arg) | |
| 1460 { | |
| 1461 switch (GTK_FUNDAMENTAL_TYPE (arg->type)) | |
| 1462 { | |
| 1463 case GTK_TYPE_NONE: | |
| 1464 return (Qnil); | |
| 1465 case GTK_TYPE_CHAR: | |
| 1466 return (make_char (GTK_VALUE_CHAR (*arg))); | |
| 1467 case GTK_TYPE_UCHAR: | |
| 1468 return (make_char (GTK_VALUE_UCHAR (*arg))); | |
| 1469 case GTK_TYPE_BOOL: | |
| 1470 return (GTK_VALUE_BOOL (*arg) ? Qt : Qnil); | |
| 1471 case GTK_TYPE_INT: | |
| 1472 return (make_int (GTK_VALUE_INT (*arg))); | |
| 1473 case GTK_TYPE_UINT: | |
| 1474 return (make_int (GTK_VALUE_INT (*arg))); | |
| 1475 case GTK_TYPE_LONG: /* I think these are wrong! */ | |
| 1476 return (make_int (GTK_VALUE_INT (*arg))); | |
| 1477 case GTK_TYPE_ULONG: /* I think these are wrong! */ | |
| 1478 return (make_int (GTK_VALUE_INT (*arg))); | |
| 1479 case GTK_TYPE_FLOAT: | |
| 1480 return (make_float (GTK_VALUE_FLOAT (*arg))); | |
| 1481 case GTK_TYPE_DOUBLE: | |
| 1482 return (make_float (GTK_VALUE_DOUBLE (*arg))); | |
| 1483 case GTK_TYPE_STRING: | |
|
4953
304aebb79cd3
function renamings to track names of char typedefs
Ben Wing <ben@xemacs.org>
parents:
4952
diff
changeset
|
1484 return (build_cistring (GTK_VALUE_STRING (*arg))); |
| 462 | 1485 case GTK_TYPE_FLAGS: |
| 1486 return (flags_to_list (GTK_VALUE_FLAGS (*arg), arg->type)); | |
| 1487 case GTK_TYPE_ENUM: | |
| 1488 return (enum_to_symbol (GTK_VALUE_ENUM (*arg), arg->type)); | |
| 1489 case GTK_TYPE_BOXED: | |
| 1490 if (arg->type == GTK_TYPE_GDK_EVENT) | |
| 1491 { | |
| 1492 return (gdk_event_to_emacs_event((GdkEvent *) GTK_VALUE_BOXED (*arg))); | |
| 1493 } | |
| 1494 | |
| 1495 if (GTK_VALUE_BOXED (*arg)) | |
| 1496 return (build_gtk_boxed (GTK_VALUE_BOXED (*arg), arg->type)); | |
| 1497 else | |
| 1498 return (Qnil); | |
| 1499 case GTK_TYPE_POINTER: | |
| 1500 if (GTK_VALUE_POINTER (*arg)) | |
| 1501 { | |
| 1502 Lisp_Object rval; | |
| 1503 | |
| 5013 | 1504 rval = GET_LISP_FROM_VOID (GTK_VALUE_POINTER (*arg)); |
| 462 | 1505 return (rval); |
| 1506 } | |
| 1507 else | |
| 1508 return (Qnil); | |
| 1509 case GTK_TYPE_OBJECT: | |
| 1510 if (GTK_VALUE_OBJECT (*arg)) | |
| 1511 return (build_gtk_object (GTK_VALUE_OBJECT (*arg))); | |
| 1512 else | |
| 1513 return (Qnil); | |
| 1514 | |
| 1515 case GTK_TYPE_CALLBACK: | |
| 1516 { | |
| 1517 Lisp_Object rval; | |
| 1518 | |
| 5013 | 1519 rval = GET_LISP_FROM_VOID (GTK_VALUE_CALLBACK (*arg).data); |
| 462 | 1520 |
| 1521 return (rval); | |
| 1522 } | |
| 1523 | |
| 1524 default: | |
| 2054 | 1525 if (IS_XEMACS_GTK_FUNDAMENTAL_TYPE(arg->type, GTK_TYPE_LISTOF)) |
| 462 | 1526 { |
| 1527 if (!GTK_VALUE_POINTER (*arg)) | |
| 1528 return (Qnil); | |
| 1529 else | |
| 1530 { | |
| 1531 return (xemacs_gtklist_to_list (arg)); | |
| 1532 } | |
| 1533 } | |
| 1534 stderr_out ("Do not know how to convert `%s' to lisp!\n", gtk_type_name (arg->type)); | |
| 2500 | 1535 ABORT (); |
| 462 | 1536 } |
| 1537 /* This is chuck reminding GCC to... SHUT UP! */ | |
| 1538 return (Qnil); | |
| 1539 } | |
| 1540 | |
| 1541 int lisp_to_gtk_type (Lisp_Object obj, GtkArg *arg) | |
| 1542 { | |
| 1543 switch (GTK_FUNDAMENTAL_TYPE (arg->type)) | |
| 1544 { | |
| 1545 /* flag types */ | |
| 1546 case GTK_TYPE_NONE: | |
| 1547 return (0); | |
| 1548 case GTK_TYPE_CHAR: | |
| 1549 { | |
| 867 | 1550 Ichar c; |
| 462 | 1551 |
| 1552 CHECK_CHAR_COERCE_INT (obj); | |
| 1553 c = XCHAR (obj); | |
| 1554 GTK_VALUE_CHAR (*arg) = c; | |
| 1555 } | |
| 1556 break; | |
| 1557 case GTK_TYPE_UCHAR: | |
| 1558 { | |
| 867 | 1559 Ichar c; |
| 462 | 1560 |
| 1561 CHECK_CHAR_COERCE_INT (obj); | |
| 1562 c = XCHAR (obj); | |
| 1563 GTK_VALUE_CHAR (*arg) = c; | |
| 1564 } | |
| 1565 break; | |
| 1566 case GTK_TYPE_BOOL: | |
| 1567 GTK_VALUE_BOOL (*arg) = NILP (obj) ? FALSE : TRUE; | |
| 1568 break; | |
| 1569 case GTK_TYPE_INT: | |
| 1570 case GTK_TYPE_UINT: | |
| 1571 if (NILP (obj) || EQ (Qt, obj)) | |
| 1572 { | |
| 1573 /* For we are a kind mistress and allow sending t/nil for | |
| 1574 1/0 to stupid GTK functions that say they take guint or | |
| 1575 gint in the header files, but actually treat it like a | |
| 1576 bool. *sigh* | |
| 1577 */ | |
| 1578 GTK_VALUE_INT(*arg) = NILP (obj) ? 0 : 1; | |
| 1579 } | |
| 1580 else | |
| 1581 { | |
| 1582 CHECK_INT (obj); | |
| 1583 GTK_VALUE_INT(*arg) = XINT (obj); | |
| 1584 } | |
| 1585 break; | |
| 1586 case GTK_TYPE_LONG: | |
| 1587 case GTK_TYPE_ULONG: | |
| 2500 | 1588 ABORT(); |
| 462 | 1589 case GTK_TYPE_FLOAT: |
| 1590 CHECK_INT_OR_FLOAT (obj); | |
| 1591 GTK_VALUE_FLOAT(*arg) = extract_float (obj); | |
| 1592 break; | |
| 1593 case GTK_TYPE_DOUBLE: | |
| 1594 CHECK_INT_OR_FLOAT (obj); | |
| 1595 GTK_VALUE_DOUBLE(*arg) = extract_float (obj); | |
| 1596 break; | |
| 1597 case GTK_TYPE_STRING: | |
| 1598 if (NILP (obj)) | |
| 1599 GTK_VALUE_STRING (*arg) = NULL; | |
| 1600 else | |
| 1601 { | |
| 1602 CHECK_STRING (obj); | |
| 1603 GTK_VALUE_STRING (*arg) = (char *) XSTRING_DATA (obj); | |
| 1604 } | |
| 1605 break; | |
| 1606 case GTK_TYPE_ENUM: | |
| 1607 case GTK_TYPE_FLAGS: | |
| 1608 /* Convert a lisp symbol to a GTK enum */ | |
| 1609 GTK_VALUE_ENUM(*arg) = lisp_to_flag (obj, arg->type); | |
| 1610 break; | |
| 1611 case GTK_TYPE_BOXED: | |
| 1612 if (NILP (obj)) | |
| 1613 { | |
| 1614 GTK_VALUE_BOXED(*arg) = NULL; | |
| 1615 } | |
| 1616 else if (GTK_BOXEDP (obj)) | |
| 1617 { | |
| 1618 GTK_VALUE_BOXED(*arg) = XGTK_BOXED (obj)->object; | |
| 1619 } | |
| 1620 else if (arg->type == GTK_TYPE_STYLE) | |
| 1621 { | |
| 1622 obj = Ffind_face (obj); | |
| 1623 CHECK_FACE (obj); | |
| 1624 GTK_VALUE_BOXED(*arg) = face_to_style (obj); | |
| 1625 } | |
| 1626 else if (arg->type == GTK_TYPE_GDK_GC) | |
| 1627 { | |
| 1628 obj = Ffind_face (obj); | |
| 1629 CHECK_FACE (obj); | |
| 1630 GTK_VALUE_BOXED(*arg) = face_to_gc (obj); | |
| 1631 } | |
| 1632 else if (arg->type == GTK_TYPE_GDK_WINDOW) | |
| 1633 { | |
| 1634 if (GLYPHP (obj)) | |
| 1635 { | |
| 1636 Lisp_Object window = Fselected_window (Qnil); | |
| 793 | 1637 Lisp_Object instance = |
| 1638 glyph_image_instance (obj, window, ERROR_ME_DEBUG_WARN, 1); | |
| 462 | 1639 struct Lisp_Image_Instance *p = XIMAGE_INSTANCE (instance); |
| 1640 | |
| 1641 switch (XIMAGE_INSTANCE_TYPE (instance)) | |
| 1642 { | |
| 1643 case IMAGE_TEXT: | |
| 1644 case IMAGE_POINTER: | |
| 1645 case IMAGE_SUBWINDOW: | |
| 1646 case IMAGE_NOTHING: | |
| 1647 GTK_VALUE_BOXED(*arg) = NULL; | |
| 1648 break; | |
| 1649 | |
| 1650 case IMAGE_MONO_PIXMAP: | |
| 1651 case IMAGE_COLOR_PIXMAP: | |
| 1652 GTK_VALUE_BOXED(*arg) = IMAGE_INSTANCE_GTK_PIXMAP (p); | |
| 1653 break; | |
| 1654 } | |
| 1655 } | |
| 1656 else if (GTK_OBJECTP (obj) && GTK_IS_WIDGET (XGTK_OBJECT (obj)->object)) | |
| 1657 { | |
| 1658 GTK_VALUE_BOXED(*arg) = GTK_WIDGET (XGTK_OBJECT (obj))->window; | |
| 1659 } | |
| 1660 else | |
| 1661 { | |
| 563 | 1662 invalid_argument ("Don't know how to convert object to GDK_WINDOW", obj); |
| 462 | 1663 } |
| 1664 break; | |
| 1665 } | |
| 1666 else if (arg->type == GTK_TYPE_GDK_COLOR) | |
| 1667 { | |
| 1668 if (COLOR_SPECIFIERP (obj)) | |
| 1669 { | |
| 1670 /* If it is a specifier, we just convert it to an | |
| 1671 instance, and let the ifs below handle it. | |
| 1672 */ | |
| 1673 obj = Fspecifier_instance (obj, Qnil, Qnil, Qnil); | |
| 1674 } | |
| 1675 | |
| 1676 if (COLOR_INSTANCEP (obj)) | |
| 1677 { | |
| 1678 /* Easiest one */ | |
| 1679 GTK_VALUE_BOXED(*arg) = COLOR_INSTANCE_GTK_COLOR (XCOLOR_INSTANCE (obj)); | |
| 1680 } | |
| 1681 else if (STRINGP (obj)) | |
| 1682 { | |
| 563 | 1683 invalid_argument ("Please use a color specifier or instance, not a string", obj); |
| 462 | 1684 } |
| 1685 else | |
| 1686 { | |
| 563 | 1687 invalid_argument ("Don't know how to convert to GdkColor", obj); |
| 462 | 1688 } |
| 1689 } | |
| 1690 else if (arg->type == GTK_TYPE_GDK_FONT) | |
| 1691 { | |
| 1692 if (SYMBOLP (obj)) | |
| 1693 { | |
| 1694 /* If it is a symbol, we treat that as a face name */ | |
| 1695 obj = Ffind_face (obj); | |
| 1696 } | |
| 1697 | |
| 1698 if (FACEP (obj)) | |
| 1699 { | |
| 1700 /* If it is a face, we just grab the font specifier, and | |
| 1701 cascade down until we finally reach a FONT_INSTANCE | |
| 1702 */ | |
| 1703 obj = Fget (obj, Qfont, Qnil); | |
| 1704 } | |
| 1705 | |
| 1706 if (FONT_SPECIFIERP (obj)) | |
| 1707 { | |
| 1708 /* If it is a specifier, we just convert it to an | |
| 1709 instance, and let the ifs below handle it | |
| 1710 */ | |
| 1711 obj = Fspecifier_instance (obj, Qnil, Qnil, Qnil); | |
| 1712 } | |
| 1713 | |
| 1714 if (FONT_INSTANCEP (obj)) | |
| 1715 { | |
| 1716 /* Easiest one */ | |
| 1717 GTK_VALUE_BOXED(*arg) = FONT_INSTANCE_GTK_FONT (XFONT_INSTANCE (obj)); | |
| 1718 } | |
| 1719 else if (STRINGP (obj)) | |
| 1720 { | |
| 563 | 1721 invalid_argument ("Please use a font specifier or instance, not a string", obj); |
| 462 | 1722 } |
| 1723 else | |
| 1724 { | |
| 563 | 1725 invalid_argument ("Don't know how to convert to GdkColor", obj); |
| 462 | 1726 } |
| 1727 } | |
| 1728 else | |
| 1729 { | |
| 1730 /* Unknown type to convert to boxed */ | |
| 1731 stderr_out ("Don't know how to convert to boxed!\n"); | |
| 1732 GTK_VALUE_BOXED(*arg) = NULL; | |
| 1733 } | |
| 1734 break; | |
| 1735 | |
| 1736 case GTK_TYPE_POINTER: | |
| 1737 if (NILP (obj)) | |
| 1738 GTK_VALUE_POINTER(*arg) = NULL; | |
| 1739 else | |
| 5013 | 1740 GTK_VALUE_POINTER(*arg) = STORE_LISP_IN_VOID (obj); |
| 462 | 1741 break; |
| 1742 | |
| 1743 /* structured types */ | |
| 1744 case GTK_TYPE_SIGNAL: | |
| 1745 case GTK_TYPE_ARGS: /* This we can do as a list of values */ | |
| 1746 case GTK_TYPE_C_CALLBACK: | |
| 1747 case GTK_TYPE_FOREIGN: | |
| 1748 stderr_out ("Do not know how to convert `%s' from lisp!\n", gtk_type_name (arg->type)); | |
| 1749 return (-1); | |
| 1750 | |
| 1751 #if 0 | |
| 1752 /* #### BILL! */ | |
| 1753 /* This is not used, and does not work with union type */ | |
| 1754 case GTK_TYPE_CALLBACK: | |
| 1755 { | |
| 1756 GUI_ID id; | |
| 1757 | |
| 1758 id = new_gui_id (); | |
| 1759 obj = Fcons (Qnil, obj); /* Empty data */ | |
| 1760 obj = Fcons (make_int (id), obj); | |
| 1761 | |
| 1762 gcpro_popup_callbacks (id, obj); | |
| 1763 | |
| 1764 GTK_VALUE_CALLBACK(*arg).marshal = __internal_callback_marshal; | |
| 1765 GTK_VALUE_CALLBACK(*arg).data = (gpointer) obj; | |
| 1766 GTK_VALUE_CALLBACK(*arg).notify = __internal_callback_destroy; | |
| 1767 } | |
| 1768 break; | |
| 1769 #endif | |
| 1770 | |
| 1771 /* base type of the object system */ | |
| 1772 case GTK_TYPE_OBJECT: | |
| 1773 if (NILP (obj)) | |
| 1774 GTK_VALUE_OBJECT (*arg) = NULL; | |
| 1775 else | |
| 1776 { | |
| 1777 CHECK_GTK_OBJECT (obj); | |
| 1778 if (XGTK_OBJECT (obj)->alive_p) | |
| 1779 GTK_VALUE_OBJECT (*arg) = XGTK_OBJECT (obj)->object; | |
| 1780 else | |
| 563 | 1781 invalid_argument ("Attempting to pass dead object to GTK function", obj); |
| 462 | 1782 } |
| 1783 break; | |
| 1784 | |
| 1785 default: | |
| 2054 | 1786 if (IS_XEMACS_GTK_FUNDAMENTAL_TYPE(arg->type, GTK_TYPE_ARRAY)) |
| 462 | 1787 { |
| 1788 if (NILP (obj)) | |
| 1789 GTK_VALUE_POINTER(*arg) = NULL; | |
| 1790 else | |
| 1791 { | |
| 1792 xemacs_list_to_array (obj, arg); | |
| 1793 } | |
| 1794 } | |
| 2054 | 1795 else if (IS_XEMACS_GTK_FUNDAMENTAL_TYPE(arg->type, GTK_TYPE_LISTOF)) |
| 462 | 1796 { |
| 1797 if (NILP (obj)) | |
| 1798 GTK_VALUE_POINTER(*arg) = NULL; | |
| 1799 else | |
| 1800 { | |
| 1801 xemacs_list_to_gtklist (obj, arg); | |
| 1802 } | |
| 1803 } | |
| 1804 else | |
| 1805 { | |
| 1806 stderr_out ("Do not know how to convert `%s' from lisp!\n", gtk_type_name (arg->type)); | |
| 2500 | 1807 ABORT(); |
| 462 | 1808 } |
| 1809 break; | |
| 1810 } | |
| 1811 | |
| 1812 return (0); | |
| 1813 } | |
| 1814 | |
| 1883 | 1815 /* Convert lisp types to GTK return types. This is identical to |
| 1816 lisp_to_gtk_type() except that the macro used to set the value is | |
| 1817 different. | |
| 1818 | |
| 1819 ### There should be some way of combining these two functions. | |
| 1820 */ | |
| 1821 int lisp_to_gtk_ret_type (Lisp_Object obj, GtkArg *arg) | |
| 1822 { | |
| 1823 switch (GTK_FUNDAMENTAL_TYPE (arg->type)) | |
| 1824 { | |
| 1825 /* flag types */ | |
| 1826 case GTK_TYPE_NONE: | |
| 1827 return (0); | |
| 1828 case GTK_TYPE_CHAR: | |
| 1829 { | |
| 1830 Ichar c; | |
| 1831 | |
| 1832 CHECK_CHAR_COERCE_INT (obj); | |
| 1833 c = XCHAR (obj); | |
| 1834 *(GTK_RETLOC_CHAR (*arg)) = c; | |
| 1835 } | |
| 1836 break; | |
| 1837 case GTK_TYPE_UCHAR: | |
| 1838 { | |
| 1839 Ichar c; | |
| 1840 | |
| 1841 CHECK_CHAR_COERCE_INT (obj); | |
| 1842 c = XCHAR (obj); | |
| 1843 *(GTK_RETLOC_CHAR (*arg)) = c; | |
| 1844 } | |
| 1845 break; | |
| 1846 case GTK_TYPE_BOOL: | |
| 1847 *(GTK_RETLOC_BOOL (*arg)) = NILP (obj) ? FALSE : TRUE; | |
| 1848 break; | |
| 1849 case GTK_TYPE_INT: | |
| 1850 case GTK_TYPE_UINT: | |
| 1851 if (NILP (obj) || EQ (Qt, obj)) | |
| 1852 { | |
| 1853 /* For we are a kind mistress and allow sending t/nil for | |
| 1854 1/0 to stupid GTK functions that say they take guint or | |
| 1855 gint in the header files, but actually treat it like a | |
| 1856 bool. *sigh* | |
| 1857 */ | |
| 1858 *(GTK_RETLOC_INT(*arg)) = NILP (obj) ? 0 : 1; | |
| 1859 } | |
| 1860 else | |
| 1861 { | |
| 1862 CHECK_INT (obj); | |
| 1863 *(GTK_RETLOC_INT(*arg)) = XINT (obj); | |
| 1864 } | |
| 1865 break; | |
| 1866 case GTK_TYPE_LONG: | |
| 1867 case GTK_TYPE_ULONG: | |
| 2500 | 1868 ABORT(); |
| 1883 | 1869 case GTK_TYPE_FLOAT: |
| 1870 CHECK_INT_OR_FLOAT (obj); | |
| 1871 *(GTK_RETLOC_FLOAT(*arg)) = extract_float (obj); | |
| 1872 break; | |
| 1873 case GTK_TYPE_DOUBLE: | |
| 1874 CHECK_INT_OR_FLOAT (obj); | |
| 1875 *(GTK_RETLOC_DOUBLE(*arg)) = extract_float (obj); | |
| 1876 break; | |
| 1877 case GTK_TYPE_STRING: | |
| 1878 if (NILP (obj)) | |
| 1879 *(GTK_RETLOC_STRING (*arg)) = NULL; | |
| 1880 else | |
| 1881 { | |
| 1882 CHECK_STRING (obj); | |
| 1883 *(GTK_RETLOC_STRING (*arg)) = (char *) XSTRING_DATA (obj); | |
| 1884 } | |
| 1885 break; | |
| 1886 case GTK_TYPE_ENUM: | |
| 1887 case GTK_TYPE_FLAGS: | |
| 1888 /* Convert a lisp symbol to a GTK enum */ | |
| 1889 *(GTK_RETLOC_ENUM(*arg)) = lisp_to_flag (obj, arg->type); | |
| 1890 break; | |
| 1891 case GTK_TYPE_BOXED: | |
| 1892 if (NILP (obj)) | |
| 1893 { | |
| 1894 *(GTK_RETLOC_BOXED(*arg)) = NULL; | |
| 1895 } | |
| 1896 else if (GTK_BOXEDP (obj)) | |
| 1897 { | |
| 1898 *(GTK_RETLOC_BOXED(*arg)) = XGTK_BOXED (obj)->object; | |
| 1899 } | |
| 1900 else if (arg->type == GTK_TYPE_STYLE) | |
| 1901 { | |
| 1902 obj = Ffind_face (obj); | |
| 1903 CHECK_FACE (obj); | |
| 1904 *(GTK_RETLOC_BOXED(*arg)) = face_to_style (obj); | |
| 1905 } | |
| 1906 else if (arg->type == GTK_TYPE_GDK_GC) | |
| 1907 { | |
| 1908 obj = Ffind_face (obj); | |
| 1909 CHECK_FACE (obj); | |
| 1910 *(GTK_RETLOC_BOXED(*arg)) = face_to_gc (obj); | |
| 1911 } | |
| 1912 else if (arg->type == GTK_TYPE_GDK_WINDOW) | |
| 1913 { | |
| 1914 if (GLYPHP (obj)) | |
| 1915 { | |
| 1916 Lisp_Object window = Fselected_window (Qnil); | |
| 1917 Lisp_Object instance = | |
| 1918 glyph_image_instance (obj, window, ERROR_ME_DEBUG_WARN, 1); | |
| 1919 struct Lisp_Image_Instance *p = XIMAGE_INSTANCE (instance); | |
| 1920 | |
| 1921 switch (XIMAGE_INSTANCE_TYPE (instance)) | |
| 1922 { | |
| 1923 case IMAGE_TEXT: | |
| 1924 case IMAGE_POINTER: | |
| 1925 case IMAGE_SUBWINDOW: | |
| 1926 case IMAGE_NOTHING: | |
| 1927 *(GTK_RETLOC_BOXED(*arg)) = NULL; | |
| 1928 break; | |
| 1929 | |
| 1930 case IMAGE_MONO_PIXMAP: | |
| 1931 case IMAGE_COLOR_PIXMAP: | |
| 1932 *(GTK_RETLOC_BOXED(*arg)) = IMAGE_INSTANCE_GTK_PIXMAP (p); | |
| 1933 break; | |
| 1934 } | |
| 1935 } | |
| 1936 else if (GTK_OBJECTP (obj) && GTK_IS_WIDGET (XGTK_OBJECT (obj)->object)) | |
| 1937 { | |
| 1938 *(GTK_RETLOC_BOXED(*arg)) = GTK_WIDGET (XGTK_OBJECT (obj))->window; | |
| 1939 } | |
| 1940 else | |
| 1941 { | |
| 1942 invalid_argument ("Don't know how to convert object to GDK_WINDOW", obj); | |
| 1943 } | |
| 1944 break; | |
| 1945 } | |
| 1946 else if (arg->type == GTK_TYPE_GDK_COLOR) | |
| 1947 { | |
| 1948 if (COLOR_SPECIFIERP (obj)) | |
| 1949 { | |
| 1950 /* If it is a specifier, we just convert it to an | |
| 1951 instance, and let the ifs below handle it. | |
| 1952 */ | |
| 1953 obj = Fspecifier_instance (obj, Qnil, Qnil, Qnil); | |
| 1954 } | |
| 1955 | |
| 1956 if (COLOR_INSTANCEP (obj)) | |
| 1957 { | |
| 1958 /* Easiest one */ | |
| 1959 *(GTK_RETLOC_BOXED(*arg)) = COLOR_INSTANCE_GTK_COLOR (XCOLOR_INSTANCE (obj)); | |
| 1960 } | |
| 1961 else if (STRINGP (obj)) | |
| 1962 { | |
| 1963 invalid_argument ("Please use a color specifier or instance, not a string", obj); | |
| 1964 } | |
| 1965 else | |
| 1966 { | |
| 1967 invalid_argument ("Don't know how to convert to GdkColor", obj); | |
| 1968 } | |
| 1969 } | |
| 1970 else if (arg->type == GTK_TYPE_GDK_FONT) | |
| 1971 { | |
| 1972 if (SYMBOLP (obj)) | |
| 1973 { | |
| 1974 /* If it is a symbol, we treat that as a face name */ | |
| 1975 obj = Ffind_face (obj); | |
| 1976 } | |
| 1977 | |
| 1978 if (FACEP (obj)) | |
| 1979 { | |
| 1980 /* If it is a face, we just grab the font specifier, and | |
| 1981 cascade down until we finally reach a FONT_INSTANCE | |
| 1982 */ | |
| 1983 obj = Fget (obj, Qfont, Qnil); | |
| 1984 } | |
| 1985 | |
| 1986 if (FONT_SPECIFIERP (obj)) | |
| 1987 { | |
| 1988 /* If it is a specifier, we just convert it to an | |
| 1989 instance, and let the ifs below handle it | |
| 1990 */ | |
| 1991 obj = Fspecifier_instance (obj, Qnil, Qnil, Qnil); | |
| 1992 } | |
| 1993 | |
| 1994 if (FONT_INSTANCEP (obj)) | |
| 1995 { | |
| 1996 /* Easiest one */ | |
| 1997 *(GTK_RETLOC_BOXED(*arg)) = FONT_INSTANCE_GTK_FONT (XFONT_INSTANCE (obj)); | |
| 1998 } | |
| 1999 else if (STRINGP (obj)) | |
| 2000 { | |
| 2001 invalid_argument ("Please use a font specifier or instance, not a string", obj); | |
| 2002 } | |
| 2003 else | |
| 2004 { | |
| 2005 invalid_argument ("Don't know how to convert to GdkColor", obj); | |
| 2006 } | |
| 2007 } | |
| 2008 else | |
| 2009 { | |
| 2010 /* Unknown type to convert to boxed */ | |
| 2011 stderr_out ("Don't know how to convert to boxed!\n"); | |
| 2012 *(GTK_RETLOC_BOXED(*arg)) = NULL; | |
| 2013 } | |
| 2014 break; | |
| 2015 | |
| 2016 case GTK_TYPE_POINTER: | |
| 2017 if (NILP (obj)) | |
| 2018 *(GTK_RETLOC_POINTER(*arg)) = NULL; | |
| 2019 else | |
| 5013 | 2020 *(GTK_RETLOC_POINTER(*arg)) = STORE_LISP_IN_VOID (obj); |
| 1883 | 2021 break; |
| 2022 | |
| 2023 /* structured types */ | |
| 2024 case GTK_TYPE_SIGNAL: | |
| 2025 case GTK_TYPE_ARGS: /* This we can do as a list of values */ | |
| 2026 case GTK_TYPE_C_CALLBACK: | |
| 2027 case GTK_TYPE_FOREIGN: | |
| 2028 stderr_out ("Do not know how to convert `%s' from lisp!\n", gtk_type_name (arg->type)); | |
| 2029 return (-1); | |
| 2030 | |
| 2031 #if 0 | |
| 2032 /* #### BILL! */ | |
| 2033 /* This is not used, and does not work with union type */ | |
| 2034 case GTK_TYPE_CALLBACK: | |
| 2035 { | |
| 2036 GUI_ID id; | |
| 2037 | |
| 2038 id = new_gui_id (); | |
| 2039 obj = Fcons (Qnil, obj); /* Empty data */ | |
| 2040 obj = Fcons (make_int (id), obj); | |
| 2041 | |
| 2042 gcpro_popup_callbacks (id, obj); | |
| 2043 | |
| 2044 *(GTK_RETLOC_CALLBACK(*arg)).marshal = __internal_callback_marshal; | |
| 2045 *(GTK_RETLOC_CALLBACK(*arg)).data = (gpointer) obj; | |
| 2046 *(GTK_RETLOC_CALLBACK(*arg)).notify = __internal_callback_destroy; | |
| 2047 } | |
| 2048 break; | |
| 2049 #endif | |
| 2050 | |
| 2051 /* base type of the object system */ | |
| 2052 case GTK_TYPE_OBJECT: | |
| 2053 if (NILP (obj)) | |
| 2054 *(GTK_RETLOC_OBJECT (*arg)) = NULL; | |
| 2055 else | |
| 2056 { | |
| 2057 CHECK_GTK_OBJECT (obj); | |
| 2058 if (XGTK_OBJECT (obj)->alive_p) | |
| 2059 *(GTK_RETLOC_OBJECT (*arg)) = XGTK_OBJECT (obj)->object; | |
| 2060 else | |
| 2061 invalid_argument ("Attempting to pass dead object to GTK function", obj); | |
| 2062 } | |
| 2063 break; | |
| 2064 | |
| 2065 default: | |
| 2054 | 2066 if (IS_XEMACS_GTK_FUNDAMENTAL_TYPE(arg->type, GTK_TYPE_ARRAY)) |
| 1883 | 2067 { |
| 2068 if (NILP (obj)) | |
| 2069 *(GTK_RETLOC_POINTER(*arg)) = NULL; | |
| 2070 else | |
| 2071 { | |
| 2072 xemacs_list_to_array (obj, arg); | |
| 2073 } | |
| 2074 } | |
| 2054 | 2075 else if (IS_XEMACS_GTK_FUNDAMENTAL_TYPE(arg->type, GTK_TYPE_LISTOF)) |
| 1883 | 2076 { |
| 2077 if (NILP (obj)) | |
| 2078 *(GTK_RETLOC_POINTER(*arg)) = NULL; | |
| 2079 else | |
| 2080 { | |
| 2081 xemacs_list_to_gtklist (obj, arg); | |
| 2082 } | |
| 2083 } | |
| 2084 else | |
| 2085 { | |
| 2086 stderr_out ("Do not know how to convert `%s' from lisp!\n", gtk_type_name (arg->type)); | |
| 2500 | 2087 ABORT(); |
| 1883 | 2088 } |
| 2089 break; | |
| 2090 } | |
| 2091 | |
| 2092 return (0); | |
| 2093 } | |
| 2094 | |
| 462 | 2095 /* This is used in glyphs-gtk.c as well */ |
| 2096 static Lisp_Object | |
| 2097 get_enumeration (GtkType t) | |
| 2098 { | |
| 2099 Lisp_Object alist; | |
| 2100 | |
| 2101 if (NILP (Venumeration_info)) | |
| 2102 { | |
| 2103 Venumeration_info = call2 (intern ("make-hashtable"), make_int (100), Qequal); | |
| 2104 } | |
| 2105 | |
| 2106 alist = Fgethash (make_int (t), Venumeration_info, Qnil); | |
| 2107 | |
| 2108 if (NILP (alist)) | |
| 2109 { | |
| 2110 import_gtk_enumeration_internal (t); | |
| 2111 alist = Fgethash (make_int (t), Venumeration_info, Qnil); | |
| 2112 } | |
| 2113 return (alist); | |
| 2114 } | |
| 2115 | |
| 2116 guint | |
| 2117 symbol_to_enum (Lisp_Object obj, GtkType t) | |
| 2118 { | |
| 2119 Lisp_Object alist = get_enumeration (t); | |
| 2120 Lisp_Object value = Qnil; | |
| 2121 | |
| 2122 if (NILP (alist)) | |
| 2123 { | |
|
4953
304aebb79cd3
function renamings to track names of char typedefs
Ben Wing <ben@xemacs.org>
parents:
4952
diff
changeset
|
2124 invalid_argument ("Unknown enumeration", build_cistring (gtk_type_name (t))); |
| 462 | 2125 } |
| 2126 | |
| 2127 value = Fassq (obj, alist); | |
| 2128 | |
| 2129 if (NILP (value)) | |
| 2130 { | |
| 563 | 2131 invalid_argument ("Unknown value", obj); |
| 462 | 2132 } |
| 2133 | |
| 2134 CHECK_INT (XCDR (value)); | |
| 2135 | |
| 2136 return (XINT (XCDR (value))); | |
| 2137 } | |
| 2138 | |
| 2139 static guint | |
| 2140 lisp_to_flag (Lisp_Object obj, GtkType t) | |
| 2141 { | |
| 2142 guint val = 0; | |
| 2143 | |
| 2144 if (NILP (obj)) | |
| 2145 { | |
| 2146 /* Do nothing */ | |
| 2147 } | |
| 2148 else if (SYMBOLP (obj)) | |
| 2149 { | |
| 2150 val = symbol_to_enum (obj, t); | |
| 2151 } | |
| 2152 else if (LISTP (obj)) | |
| 2153 { | |
| 2154 while (!NILP (obj)) | |
| 2155 { | |
| 2156 val |= symbol_to_enum (XCAR (obj), t); | |
| 2157 obj = XCDR (obj); | |
| 2158 } | |
| 2159 } | |
| 2160 else | |
| 2161 { | |
| 2500 | 2162 /* ABORT ()? */ |
| 462 | 2163 } |
| 2164 return (val); | |
| 2165 } | |
| 2166 | |
| 2167 static Lisp_Object | |
| 2168 flags_to_list (guint value, GtkType t) | |
| 2169 { | |
| 2170 Lisp_Object rval = Qnil; | |
| 2171 Lisp_Object alist = get_enumeration (t); | |
| 2172 | |
| 2173 while (!NILP (alist)) | |
| 2174 { | |
| 2175 if (value & XINT (XCDR (XCAR (alist)))) | |
| 2176 { | |
| 2177 rval = Fcons (XCAR (XCAR (alist)), rval); | |
| 2178 value &= ~(XINT (XCDR (XCAR (alist)))); | |
| 2179 } | |
| 2180 alist = XCDR (alist); | |
| 2181 } | |
| 2182 return (rval); | |
| 2183 } | |
| 2184 | |
| 2185 static Lisp_Object | |
| 2186 enum_to_symbol (guint value, GtkType t) | |
| 2187 { | |
| 2188 Lisp_Object alist = get_enumeration (t); | |
| 2189 Lisp_Object cell = Qnil; | |
| 2190 | |
| 2191 if (NILP (alist)) | |
| 2192 { | |
|
4953
304aebb79cd3
function renamings to track names of char typedefs
Ben Wing <ben@xemacs.org>
parents:
4952
diff
changeset
|
2193 invalid_argument ("Unknown enumeration", build_cistring (gtk_type_name (t))); |
| 462 | 2194 } |
| 2195 | |
| 2196 cell = Frassq (make_int (value), alist); | |
| 2197 | |
| 2198 return (NILP (cell) ? Qnil : XCAR (cell)); | |
| 2199 } |