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