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