1 /* guile-gnome
2 * Copyright (C) 2001, 2015 Martin Baulig <martin@gnome.org>
3 * Copyright (C) 2003,2004 Andy Wingo <wingo at pobox dot com>
4 *
5 * gobject.c: Support for GObject (and GInterface)
6 *
7 * This program is free software; you can redistribute it and/or
8 * modify it under the terms of the GNU General Public License as
9 * published by the Free Software Foundation; either version 2 of
10 * the License, or (at your option) any later version.
11 *
12 * This program is distributed in the hope that it will be useful,
13 * but WITHOUT ANY WARRANTY; without even the implied warranty of
14 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15 * GNU General Public License for more details.
16 *
17 * You should have received a copy of the GNU General Public License
18 * along with this program; if not, contact:
19 *
20 * Free Software Foundation Voice: +1-617-542-5942
21 * 59 Temple Place - Suite 330 Fax: +1-617-542-2652
22 * Boston, MA 02111-1307, USA gnu@gnu.org
23 */
24
25 #include <string.h>
26 #include <stdio.h>
27 #include "gc.h"
28 #include "gobject.h"
29 #include "private.h"
30 #include "guile-support.h"
31
32
33
34 SCM scm_class_gobject;
35 static SCM _initialize;
36 static SCM _gobject_set_property;
37 static SCM _gobject_get_property;
38 static SCM _in_construction_from_scheme;
39 static SCM _slot_definition_options;
40
41 static GQuark quark_guile_gtype_class = 0;
42
43 SCM_SYMBOL (sym_gruntime_error,"gruntime-error");
44 SCM_KEYWORD (kw_init_keyword, "init-keyword");
45
46 /* #define DEBUG_PRINT */
47
48 #ifdef DEBUG_PRINT
49 #define DEBUG_ALLOC(str, args...) g_print ("I: " str "\n", ##args)
50 #else
51 #define DEBUG_ALLOC(str, args...)
52 #endif
53
54 #define DEBUG_REFCOUNTING
55
56 static gpointer scm_c_gobject_construct (SCM instance, SCM initargs);
57 //static void scm_c_gobject_initialize_scm (SCM instance, SCM initargs);
58
59 static const scm_t_gtype_instance_funcs gobject_funcs = {
60 G_TYPE_OBJECT,
61 (scm_t_gtype_instance_ref)g_object_ref,
62 (scm_t_gtype_instance_unref)g_object_unref,
63 (scm_t_gtype_instance_get_qdata)g_object_get_qdata,
64 (scm_t_gtype_instance_set_qdata)g_object_set_qdata,
65 (scm_t_gtype_instance_construct)scm_c_gobject_construct,
66 NULL
67 // (scm_t_gtype_instance_initialize_scm)scm_c_gobject_initialize_scm
68 };
69
70 // FIXME
71 static inline void post_make_object (GObject *obj);
72
73
74
75 static void
scm_with_c_gobject_get_property(GObject * gobject,guint param_id,GValue * dest_gvalue,GParamSpec * pspec)76 scm_with_c_gobject_get_property (GObject *gobject, guint param_id,
77 GValue *dest_gvalue, GParamSpec *pspec)
78 {
79 scm_c_gvalue_set (dest_gvalue,
80 scm_call_2 (_gobject_get_property,
81 scm_c_gtype_instance_to_scm (gobject),
82 scm_from_locale_symbol (pspec->name)));
83 }
84
85 static void
scm_c_gobject_get_property(GObject * gobject,guint param_id,GValue * dest_gvalue,GParamSpec * pspec)86 scm_c_gobject_get_property (GObject *gobject, guint param_id, GValue *dest_gvalue, GParamSpec *pspec)
87 {
88 return scm_dynwind_guile_v__p_u_p_p (scm_with_guile,
89 scm_with_c_gobject_get_property,
90 gobject, param_id, dest_gvalue, pspec);
91 }
92
93 static void
scm_with_c_gobject_set_property(GObject * gobject,guint param_id,const GValue * src_value,GParamSpec * pspec)94 scm_with_c_gobject_set_property (GObject *gobject, guint param_id, const GValue *src_value, GParamSpec *pspec)
95 {
96 scm_call_3 (_gobject_set_property,
97 scm_c_gtype_instance_to_scm (gobject),
98 scm_from_locale_symbol (pspec->name),
99 scm_c_gvalue_to_scm (src_value));
100 }
101
102 static void
scm_c_gobject_set_property(GObject * gobject,guint param_id,const GValue * src_value,GParamSpec * pspec)103 scm_c_gobject_set_property (GObject *gobject, guint param_id, const GValue *src_value, GParamSpec *pspec)
104 {
105 return scm_dynwind_guile_v__p_u_c_p (scm_with_guile,
106 scm_with_c_gobject_set_property,
107 gobject, param_id, src_value, pspec);
108 }
109
110
111
112 static gboolean
is_init_keyword(SCM slots,SCM kw)113 is_init_keyword (SCM slots, SCM kw)
114 {
115 SCM defs;
116
117 for (; scm_is_pair (slots); slots = scm_cdr (slots))
118 for (defs = scm_call_1 (_slot_definition_options, scm_car (slots));
119 scm_is_pair (defs);
120 defs = scm_cddr (defs))
121 if (scm_is_eq (scm_car (defs), kw_init_keyword)
122 && scm_is_eq (scm_cadr (defs), kw))
123 return TRUE;
124
125 return FALSE;
126 }
127
128 static void
push_in_construction_from_scheme(SCM instance)129 push_in_construction_from_scheme (SCM instance)
130 {
131 SCM stack = scm_fluid_ref (_in_construction_from_scheme);
132 scm_fluid_set_x (_in_construction_from_scheme, scm_cons (instance, stack));
133 }
134
135 static void
pop_in_construction_from_scheme(void)136 pop_in_construction_from_scheme (void)
137 {
138 SCM stack = scm_fluid_ref (_in_construction_from_scheme);
139 scm_fluid_set_x (_in_construction_from_scheme, scm_cdr (stack));
140 }
141
142 static SCM
in_construction_from_scheme(void)143 in_construction_from_scheme (void)
144 {
145 SCM stack = scm_fluid_ref (_in_construction_from_scheme);
146 return scm_is_null (stack) ? SCM_BOOL_F : scm_car (stack);
147 }
148
149 static gpointer
scm_c_gobject_construct(SCM instance,SCM initargs)150 scm_c_gobject_construct (SCM instance, SCM initargs)
151 #define FUNC_NAME "%gobject-construct"
152 {
153 GObject *gobject;
154 GObjectClass *propclass;
155 GType gtype;
156 GParameter *params, *current;
157 GParamSpec *pspec;
158 long nparams, i;
159 SCM class, slots, kw, propname, val;
160
161 SCM_VALIDATE_INSTANCE (1, instance);
162
163 scm_dynwind_begin (0);
164
165 class = scm_class_of (instance);
166 gtype = scm_c_gtype_class_to_gtype (class);
167 slots = scm_class_slots (class);
168 nparams = scm_ilength (initargs) / 2; /* a maximum length */
169 params = g_new0 (GParameter, nparams);
170 scm_dynwind_unwind_handler ((gpointer)g_free, params,
171 SCM_F_WIND_EXPLICITLY);
172
173 for (i = 0; SCM_CONSP (initargs); initargs = scm_cddr (initargs)) {
174 kw = scm_car (initargs);
175 SCM_ASSERT (scm_is_keyword (kw), kw, 2, FUNC_NAME);
176 SCM_ASSERT (SCM_CONSP (scm_cdr (initargs)), initargs, 2, FUNC_NAME);
177 propname = scm_keyword_to_symbol (kw);
178 val = scm_cadr (initargs);
179
180 if (is_init_keyword (slots, kw))
181 continue;
182
183 current = ¶ms [i];
184
185 current->name = scm_keyword_chars_dynwind (kw);
186 propclass = g_type_class_ref (gtype);
187 pspec = g_object_class_find_property (propclass, current->name);
188 g_type_class_unref (propclass);
189
190 if (!pspec)
191 scm_c_gruntime_error (FUNC_NAME,
192 "No property named ~S in object ~A",
193 SCM_LIST2 (propname, instance));
194
195 g_value_init (¤t->value, G_PARAM_SPEC_VALUE_TYPE (pspec));
196 scm_c_gvalue_set (¤t->value, val);
197
198 i++;
199 }
200
201 push_in_construction_from_scheme (instance);
202 gobject = g_object_newv (gtype, i, params);
203 pop_in_construction_from_scheme ();
204
205 /* GtkWindow's first ref is owned by GTK. */
206 post_make_object (gobject);
207
208 for (i--; i>=0; i--)
209 g_value_unset (¶ms[i].value);
210
211 scm_dynwind_end ();
212
213 return gobject;
214 }
215 #undef FUNC_NAME
216
217 static void
scm_with_c_gtype_instance_instance_init(GTypeInstance * g_instance,gpointer g_class)218 scm_with_c_gtype_instance_instance_init (GTypeInstance *g_instance,
219 gpointer g_class)
220 {
221 GType type;
222 SCM class;
223
224 type = G_TYPE_FROM_CLASS (g_class);
225
226 /* make sure we know about the class */
227 class = scm_c_gtype_lookup_class (type);
228 g_assert (SCM_NFALSEP (class));
229
230 /* It seems that as an object is initialized, the g_class argument to the
231 * init function is the same for each level of inherited classes. However --
232 * and this shit tripped me up for a while -- _the class of the instance
233 * changes for each level of the init process_. Thus if you want to know the
234 * real type of the object, use G_TYPE_FROM_CLASS (g_class). If you want to
235 * know which derived class is being initialized (as in a gobject class
236 * doubly-specialized on the scheme side), use G_TYPE_FROM_INSTANCE
237 * (g_instance). Fucked up! */
238
239 switch (G_TYPE_FUNDAMENTAL (type)) {
240 case G_TYPE_OBJECT: {
241 GuileGTypeClass *guile_class;
242 SCM under_construction = in_construction_from_scheme ();
243
244 guile_class = g_type_get_qdata (type, quark_guile_gtype_class);
245 guile_class->first_instance_created = TRUE;
246
247 if (scm_is_false (under_construction))
248 /* not strictly necessary from the pov of c code, but we want to
249 make sure that g_object_new () causes `initialize' to be called
250 on a new scheme object -- hence this call that just serves to
251 associate a scheme object with the instance as long as the
252 instance is alive */
253 scm_c_gtype_instance_to_scm_typed (g_instance, type);
254 else
255 scm_c_gtype_instance_bind_to_object (g_instance, under_construction);
256
257 break;
258 }
259
260 default:
261 break;
262 }
263 }
264
265 static void
scm_c_gtype_instance_instance_init(GTypeInstance * g_instance,gpointer g_class)266 scm_c_gtype_instance_instance_init (GTypeInstance *g_instance,
267 gpointer g_class)
268 {
269 scm_dynwind_guile_v__p_p (scm_with_guile,
270 scm_with_c_gtype_instance_instance_init,
271 g_instance, g_class);
272 }
273
274 static void
scm_with_c_gtype_instance_class_init(gpointer g_class,gpointer class_data)275 scm_with_c_gtype_instance_class_init (gpointer g_class, gpointer class_data)
276 {
277 GuileGTypeClass *guile_class;
278 SCM class;
279
280 class = scm_c_gtype_lookup_class (G_TYPE_FROM_CLASS (g_class));
281 if (SCM_FALSEP (class)) {
282 /* this can happen for scheme-defined classes */
283 class = scm_c_gtype_to_class (G_TYPE_FROM_CLASS (g_class));
284 }
285 g_assert (SCM_NFALSEP (class));
286
287 guile_class = g_type_get_qdata (G_TYPE_FROM_CLASS (g_class), quark_guile_gtype_class);
288 g_assert (guile_class != NULL);
289
290 DEBUG_ALLOC (" protecting class %p of %s gclass %p", class,
291 g_type_name (G_TYPE_FROM_CLASS (g_class)), class);
292
293 scm_glib_gc_protect_object (class);
294 guile_class->class = class;
295
296 /* Not calling a class-init generic will prevent GOOPS classes that are
297 * subclassed on the scheme side from being initialized, but that's a corner
298 * case. Perhaps we should support it, but I'm removing it for now. */
299 /* NOTE: The proper way for supporting class-init is to override initialize
300 * for gtype-instance-class. */
301
302 if (G_TYPE_IS_OBJECT (G_TYPE_FROM_CLASS (g_class))) {
303 ((GObjectClass *) g_class)->get_property = scm_c_gobject_get_property;
304 ((GObjectClass *) g_class)->set_property = scm_c_gobject_set_property;
305 }
306 }
307
308 static void
scm_c_gtype_instance_class_init(gpointer g_class,gpointer class_data)309 scm_c_gtype_instance_class_init (gpointer g_class, gpointer class_data)
310 {
311 scm_dynwind_guile_v__p_p (scm_with_guile,
312 scm_with_c_gtype_instance_class_init,
313 g_class, class_data);
314 }
315
316 SCM_DEFINE (scm_scheme_gclass_p, "scheme-gclass?", 1, 0, 0,
317 (SCM class),
318 "")
319 #define FUNC_NAME s_scm_scheme_gclass_p
320 {
321 GType gtype;
322 GObjectClass *gclass;
323
324 SCM_VALIDATE_GOBJECT_CLASS_COPY (1, class, gtype);
325
326 gclass = g_type_class_ref (gtype);
327 return SCM_BOOL (gclass->get_property == scm_c_gobject_get_property);
328 }
329 #undef FUNC_NAME
330
331 // FIXME: remove?
332 SCM_DEFINE (scm_gtype_register_static, "gtype-register-static", 2, 0, 0,
333 (SCM name, SCM parent_class),
334 "Derive a new type named @var{name} from @var{parent_class}. "
335 "Returns the new @code{<gtype-class>}. This function is called "
336 "when deriving from @code{<gobject>}; users do not normally "
337 "call this function directly.")
338 #define FUNC_NAME s_scm_gtype_register_static
339 {
340 GType gtype_parent, gtype;
341 GTypeInfo gtype_info;
342 GTypeQuery gtype_query;
343 GuileGTypeClass *guile_class;
344 char *utf8;
345
346 SCM_VALIDATE_STRING (1, name);
347 SCM_VALIDATE_GTYPE_CLASS_COPY (2, parent_class, gtype_parent);
348
349 scm_dynwind_begin (0);
350
351 utf8 = scm_to_locale_string_dynwind (name);
352 gtype = g_type_from_name (utf8);
353
354 if (gtype)
355 scm_c_gruntime_error (FUNC_NAME,
356 "There is already a type with this name: ~S",
357 SCM_LIST1 (name));
358
359 if (!G_TYPE_IS_DERIVABLE (gtype_parent))
360 scm_c_gruntime_error (FUNC_NAME,
361 "Cannot derive ~S from non-derivable parent type: ~S",
362 SCM_LIST2 (name, parent_class));
363
364 if (!G_TYPE_IS_FUNDAMENTAL (gtype_parent) && !G_TYPE_IS_DEEP_DERIVABLE (gtype_parent))
365 scm_c_gruntime_error (FUNC_NAME,
366 "Cannot derive ~S from non-fundamental parent type: ~S",
367 SCM_LIST2 (name, parent_class));
368
369 g_type_query (gtype_parent, >ype_query);
370
371 memset (>ype_info, 0, sizeof (gtype_info));
372 gtype_info.class_size = gtype_query.class_size;
373 gtype_info.instance_size = gtype_query.instance_size;
374 gtype_info.class_init = scm_c_gtype_instance_class_init;
375 gtype_info.instance_init = scm_c_gtype_instance_instance_init;
376
377 gtype = g_type_register_static (gtype_parent, utf8, >ype_info, 0);
378
379 guile_class = g_new0 (GuileGTypeClass, 1);
380 guile_class->properties_hash = g_hash_table_new (NULL, NULL);
381
382 g_type_set_qdata (gtype, quark_guile_gtype_class, guile_class);
383
384 scm_dynwind_end ();
385
386 return scm_from_locale_string (g_type_name (gtype));
387 }
388 #undef FUNC_NAME
389
390 SCM_DEFINE (scm_gobject_class_get_properties, "gobject-class-get-properties", 1, 0, 0,
391 (SCM class),
392 "")
393 #define FUNC_NAME s_scm_gobject_class_get_properties
394 {
395 gpointer gclass = 0;
396 GParamSpec **properties;
397 guint n_properties, i;
398 GType gtype;
399 SCM ret = SCM_EOL;
400
401 SCM_VALIDATE_GTYPE_CLASS_COPY (1, class, gtype);
402
403 if (G_TYPE_FUNDAMENTAL (gtype) == G_TYPE_OBJECT) {
404 gclass = G_OBJECT_CLASS (g_type_class_ref (gtype));
405 properties = g_object_class_list_properties (gclass, &n_properties);
406 } else if (G_TYPE_FUNDAMENTAL (gtype) == G_TYPE_INTERFACE) {
407 if (G_TYPE_IS_FUNDAMENTAL (gtype)) {
408 properties = NULL;
409 n_properties = 0;
410 } else {
411 gclass = g_type_default_interface_ref (gtype);
412 properties = g_object_interface_list_properties (gclass, &n_properties);
413 }
414 } else {
415 scm_wrong_type_arg (FUNC_NAME, 1, class);
416 }
417
418 for (i = n_properties; i > 0; i--)
419 ret = scm_cons (scm_c_gtype_instance_to_scm (properties[i-1]),
420 ret);
421
422 if (G_TYPE_FUNDAMENTAL (gtype) == G_TYPE_OBJECT)
423 g_type_class_unref (gclass);
424 else if (G_TYPE_FUNDAMENTAL (gtype) == G_TYPE_INTERFACE
425 && !G_TYPE_IS_FUNDAMENTAL (gtype))
426 g_type_default_interface_unref (gclass);
427
428 g_free (properties);
429
430 return ret;
431 }
432 #undef FUNC_NAME
433
434 SCM_DEFINE (scm_gobject_class_get_property_names, "gobject-class-get-property-names", 1, 0, 0,
435 (SCM class),
436 "")
437 #define FUNC_NAME s_scm_gobject_class_get_property_names
438 {
439 gpointer gclass = 0;
440 GParamSpec **properties;
441 guint n_properties, i;
442 GType gtype;
443 SCM ret = SCM_EOL;
444
445 SCM_VALIDATE_GTYPE_CLASS_COPY (1, class, gtype);
446
447 if (G_TYPE_FUNDAMENTAL (gtype) == G_TYPE_OBJECT) {
448 gclass = G_OBJECT_CLASS (g_type_class_ref (gtype));
449 properties = g_object_class_list_properties (gclass, &n_properties);
450 } else if (G_TYPE_FUNDAMENTAL (gtype) == G_TYPE_INTERFACE) {
451 if (G_TYPE_IS_FUNDAMENTAL (gtype)) {
452 properties = NULL;
453 n_properties = 0;
454 } else {
455 gclass = g_type_default_interface_ref (gtype);
456 properties = g_object_interface_list_properties (gclass, &n_properties);
457 }
458 } else {
459 scm_wrong_type_arg (FUNC_NAME, 1, class);
460 }
461
462 for (i = n_properties; i > 0; i--)
463 ret = scm_cons (scm_from_locale_symbol (properties[i-1]->name), ret);
464
465 if (G_TYPE_FUNDAMENTAL (gtype) == G_TYPE_OBJECT)
466 g_type_class_unref (gclass);
467 else if (G_TYPE_FUNDAMENTAL (gtype) == G_TYPE_INTERFACE
468 && !G_TYPE_IS_FUNDAMENTAL (gtype))
469 g_type_default_interface_unref (gclass);
470
471 g_free (properties);
472
473 return ret;
474 }
475 #undef FUNC_NAME
476
477 SCM_DEFINE (scm_gobject_class_install_property, "gobject-class-install-property", 2, 0, 0,
478 (SCM class, SCM param),
479 "")
480 #define FUNC_NAME s_scm_gobject_class_install_property
481 {
482 GType gtype;
483 GParamSpec *gparam;
484 GObjectClass *gclass;
485 GuileGTypeClass *guile_class;
486 guint id;
487
488 SCM_VALIDATE_GOBJECT_CLASS_COPY (1, class, gtype);
489 SCM_VALIDATE_GPARAM_COPY (2, param, gparam);
490
491 gclass = g_type_class_ref (gtype);
492 if (g_object_class_find_property (gclass, gparam->name))
493 scm_error (sym_gruntime_error, FUNC_NAME,
494 "There is already a property with this name in class ~S: ~S",
495 SCM_LIST2 (class, scm_from_locale_string (gparam->name)),
496 SCM_EOL);
497
498 guile_class = g_type_get_qdata (gtype, quark_guile_gtype_class);
499 if (!guile_class)
500 scm_error (sym_gruntime_error, FUNC_NAME,
501 "Can't add properties to non-derived type: ~S",
502 SCM_LIST1 (class), SCM_EOL);
503
504 if (guile_class->first_instance_created)
505 scm_error (sym_gruntime_error, FUNC_NAME,
506 "Can't add properties after intances have been created: ~S",
507 SCM_LIST1 (class), SCM_EOL);
508
509 id = ++guile_class->last_property_id;
510 g_object_class_install_property (gclass, id, gparam);
511
512 DEBUG_ALLOC (" protecting param %p of %s gparam %p", param,
513 g_type_name (G_TYPE_FROM_INSTANCE (gparam)), gparam);
514 g_hash_table_insert (guile_class->properties_hash, GINT_TO_POINTER (id),
515 scm_glib_gc_protect_object (param));
516
517 return SCM_UNSPECIFIED;
518 }
519 #undef FUNC_NAME
520
521 SCM_DEFINE (scm_gobject_get_property, "gobject-get-property", 2, 0, 0,
522 (SCM object, SCM name),
523 "Gets a the property named @var{name} (a symbol) from @var{object}.")
524 #define FUNC_NAME s_scm_gobject_get_property
525 {
526 GObject *gobject;
527 GParamSpec *pspec;
528 SCM retval;
529 GValue value = { 0, };
530
531 SCM_VALIDATE_GOBJECT_COPY (1, object, gobject);
532 SCM_VALIDATE_SYMBOL (2, name);
533
534 scm_dynwind_begin (0);
535
536 pspec = g_object_class_find_property (G_OBJECT_GET_CLASS (gobject),
537 scm_symbol_chars_dynwind (name));
538
539 if (!pspec)
540 scm_error (sym_gruntime_error, FUNC_NAME,
541 "No such property ~S in class ~S",
542 SCM_LIST2 (name, scm_class_of (object)), SCM_EOL);
543
544 g_value_init (&value, pspec->value_type);
545 g_object_get_property (gobject, pspec->name, &value);
546 retval = scm_c_gvalue_ref (&value);
547 g_value_unset (&value);
548
549 scm_dynwind_end ();
550
551 return retval;
552 }
553 #undef FUNC_NAME
554
555
556
557 SCM_DEFINE (scm_gobject_set_property, "gobject-set-property", 3, 0, 0,
558 (SCM object, SCM name, SCM value),
559 "Sets the property named @var{name} (a symbol) on @var{object} to "
560 "@var{init-value}.")
561 #define FUNC_NAME s_scm_gobject_set_property
562 {
563 GObject *gobject;
564 GParamSpec *pspec;
565 GValue *gvalue;
566
567 SCM_VALIDATE_GOBJECT_COPY (1, object, gobject);
568 SCM_VALIDATE_SYMBOL (2, name);
569
570 scm_dynwind_begin (0);
571
572 pspec = g_object_class_find_property (G_OBJECT_GET_CLASS (gobject),
573 scm_symbol_chars_dynwind (name));
574 if (!pspec)
575 scm_error (sym_gruntime_error, FUNC_NAME,
576 "No such property ~S in class ~S",
577 SCM_LIST2 (name, scm_class_of (object)), SCM_EOL);
578
579 gvalue = scm_c_scm_to_gvalue (pspec->value_type, value);
580 g_object_set_property (gobject, pspec->name, gvalue);
581 g_value_unset (gvalue);
582
583 scm_dynwind_end ();
584
585 return SCM_UNSPECIFIED;
586 }
587 #undef FUNC_NAME
588
589
590
591 typedef struct {
592 GType type;
593 gpointer (* postmakefunc)(gpointer object);
594 } PostMakeFunc;
595
596 static GArray *post_make_funcs = NULL;
597
598 static inline void
post_make_object(GObject * obj)599 post_make_object (GObject *obj)
600 {
601 if (post_make_funcs) {
602 gint i;
603
604 for (i = 0; i < post_make_funcs->len; i++) {
605 if (g_type_is_a (G_OBJECT_TYPE (obj),
606 g_array_index (post_make_funcs, PostMakeFunc, i).type)) {
607 g_array_index (post_make_funcs, PostMakeFunc, i).postmakefunc (obj);
608 DEBUG_ALLOC ("post-made gobject (%p) of type %s, ->%u",
609 obj, g_type_name (G_TYPE_FROM_INSTANCE (obj)),
610 obj->ref_count);
611 break;
612 }
613 }
614 }
615 }
616
617 /**
618 * guile_gobject_register_postmakefunc:
619 * type: the GType the sink function applies to.
620 * postmakefunc: a function to remove the floating reference on an object.
621 *
622 * The lengths we go to to deal with broken APIs... This function is here to
623 * deal with the case where the ref you get from g_object_new is not actually
624 * your own, eg GtkWindow and GtkInvisible.
625 *
626 * The postmakefunc should be able to remove the floating reference on
627 * instances of the given type, or any subclasses.
628 */
629 void
scm_register_gobject_postmakefunc(GType type,gpointer (* postmakefunc)(gpointer))630 scm_register_gobject_postmakefunc (GType type, gpointer (*postmakefunc) (gpointer))
631 {
632 PostMakeFunc pmf;
633
634 if (!post_make_funcs)
635 post_make_funcs = g_array_new (FALSE, FALSE, sizeof(PostMakeFunc));
636
637 pmf.type = type;
638 pmf.postmakefunc = postmakefunc;
639 g_array_append_val (post_make_funcs, pmf);
640 }
641
642 #ifdef DEBUG_REFCOUNTING
643 SCM_DEFINE (scm_sys_gobject_get_refcount, "%gobject-get-refcount", 1, 0, 0,
644 (SCM object),
645 "Get the refcount of an object (for debugging purposes)")
646 #define FUNC_NAME s_scm_sys_gobject_get_refcount
647 {
648 GObject *gobject;
649
650 SCM_VALIDATE_GOBJECT_COPY (1, object, gobject);
651
652 return scm_from_uint (gobject->ref_count);
653 }
654 #undef FUNC_NAME
655 #endif
656
657 SCM_DEFINE (scm_sys_gnome_gobject_object_post_init,
658 "%gnome-gobject-object-post-init", 0, 0, 0,
659 (),
660 "")
661 #define FUNC_NAME s_scm_sys_gnome_gobject_object_post_init
662 {
663 _initialize = scm_permanent_object (SCM_VARIABLE_REF (scm_c_lookup ("initialize")));
664 _gobject_get_property = scm_permanent_object (SCM_VARIABLE_REF (scm_c_lookup ("gobject:get-property")));
665 _gobject_set_property = scm_permanent_object (SCM_VARIABLE_REF (scm_c_lookup ("gobject:set-property")));
666 scm_class_gobject = scm_permanent_object (SCM_VARIABLE_REF (scm_c_lookup ("<gobject>")));
667 return SCM_UNSPECIFIED;
668 }
669 #undef FUNC_NAME
670
671 static void
sink_initially_unowned(gpointer i)672 sink_initially_unowned (gpointer i)
673 {
674 GObject *object = i;
675 if (g_object_is_floating (object))
676 g_object_ref_sink (object);
677 }
678
679 void
scm_init_gnome_gobject(void)680 scm_init_gnome_gobject (void)
681 {
682 #ifndef SCM_MAGIC_SNARFER
683 #include "gobject.x"
684 #endif
685 scm_register_gtype_instance_funcs (&gobject_funcs);
686 scm_c_register_gtype_instance_gvalue_wrappers
687 (G_TYPE_OBJECT,
688 (SCMGValueGetTypeInstanceFunc)g_value_get_object,
689 (SCMGValueSetTypeInstanceFunc)g_value_set_object);
690 scm_c_register_gtype_instance_gvalue_wrappers
691 (G_TYPE_INTERFACE,
692 (SCMGValueGetTypeInstanceFunc)g_value_get_object,
693 (SCMGValueSetTypeInstanceFunc)g_value_set_object);
694
695 _in_construction_from_scheme = scm_permanent_object (scm_make_fluid ());
696 scm_fluid_set_x (_in_construction_from_scheme, SCM_EOL);
697
698 scm_register_gtype_instance_sinkfunc (G_TYPE_INITIALLY_UNOWNED,
699 sink_initially_unowned);
700
701 _slot_definition_options =
702 scm_variable_ref (scm_c_lookup ("slot-definition-options"));
703
704 quark_guile_gtype_class = g_quark_from_static_string ("%scm-guile-gtype-class");
705 }
706