1 /* -*- Mode: C; c-basic-offset: 4 -*- */
2 /* guile-gnome
3 * Copyright (C) 2001 Martin Baulig <martin@gnome.org>
4 *
5 * gtype.c: Base support for the GLib type system
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
26 #include <stdio.h>
27 #include <string.h>
28 #include "guile-support.h"
29 #include "gc.h"
30 #include "gutil.h"
31 #include "gtype.h"
32 #include "private.h"
33
34
35
36 SCM_GLOBAL_SYMBOL (scm_sym_gtype, "gtype");
37 SCM_GLOBAL_SYMBOL (scm_sym_gtype_instance, "gtype-instance");
38
39 SCM scm_class_gtype_class;
40 SCM scm_class_gtype_instance;
41 SCM scm_sys_gtype_to_class;
42
43 /* bummer */
44 extern SCM scm_class_gvalue;
45
46
47
48 SCM_SYMBOL (sym_gruntime_error,"gruntime-error");
49 SCM_SYMBOL (sym_name, "name");
50
51 SCM_KEYWORD (k_name, "name");
52 SCM_KEYWORD (k_class, "class");
53 SCM_KEYWORD (k_metaclass, "metaclass");
54 SCM_KEYWORD (k_gtype_name, "gtype-name");
55
56
57 static SCM _make_class;
58 static SCM _class_redefinition;
59 static SCM _allocate_instance;
60 static SCM _initialize;
61
62 static SCM _gtype_name_to_scheme_name;
63 static SCM _gtype_name_to_class_name;
64
65 static GQuark quark_class = 0;
66 static GQuark quark_type = 0;
67 static GQuark quark_guile_gtype_class = 0;
68 static GQuark guile_gobject_quark_wrapper;
69
70
71
72 /* #define DEBUG_PRINT */
73
74 #ifdef DEBUG_PRINT
75 #define DEBUG_ALLOC(str, args...) g_print ("I: " str "\n", ##args)
76 #else
77 #define DEBUG_ALLOC(str, args...)
78 #endif
79
80
81
82 static void scm_gtype_instance_unbind (scm_t_bits *slots);
83
84 /* would be nice to assume everything uses InitiallyUnowned, but that's not the
85 * case... */
86 typedef struct {
87 GType type;
88 void (* sinkfunc)(gpointer instance);
89 } SinkFunc;
90
91 static GSList *gtype_instance_funcs = NULL;
92 static GArray *sink_funcs = NULL;
93
94
95
96 /**********************************************************************
97 * GTypeClass
98 **********************************************************************/
99
100 SCM
scm_c_gtype_lookup_class(GType gtype)101 scm_c_gtype_lookup_class (GType gtype)
102 {
103 SCM class;
104
105 class = g_type_get_qdata (gtype, quark_class);
106
107 return class ? class : SCM_BOOL_F;
108 }
109
110 static SCM
scm_c_gtype_get_direct_supers(GType type)111 scm_c_gtype_get_direct_supers (GType type)
112 {
113 GType parent = g_type_parent (type);
114 SCM ret = SCM_EOL;
115
116 if (!parent) {
117 if (G_TYPE_IS_INSTANTIATABLE (type))
118 ret = scm_cons (scm_class_gtype_instance, ret);
119 else
120 ret = scm_cons (scm_class_gvalue, ret);
121 } else {
122 SCM direct_super, cpl;
123 GType *interfaces;
124 guint n_interfaces, i;
125
126 direct_super = scm_c_gtype_to_class (parent);
127 cpl = scm_class_precedence_list (direct_super);
128 ret = scm_cons (direct_super, ret);
129
130 interfaces = g_type_interfaces (type, &n_interfaces);
131 if (interfaces) {
132 for (i=0; i<n_interfaces; i++) {
133 SCM iclass = scm_c_gtype_to_class (interfaces[i]);
134 if (scm_is_false (scm_c_memq (iclass, cpl)))
135 ret = scm_cons (iclass, ret);
136 }
137 g_free (interfaces);
138 }
139 }
140
141 return ret;
142 }
143
144 SCM
scm_c_gtype_to_class(GType gtype)145 scm_c_gtype_to_class (GType gtype)
146 {
147 SCM ret, supers, gtype_name, name;
148
149 ret = scm_c_gtype_lookup_class (gtype);
150 if (SCM_NFALSEP (ret))
151 return ret;
152
153 supers = scm_c_gtype_get_direct_supers (gtype);
154 gtype_name = scm_from_locale_string (g_type_name (gtype));
155 name = scm_call_1 (_gtype_name_to_class_name, gtype_name);
156
157 ret = scm_apply_0 (_make_class,
158 scm_list_n (supers, SCM_EOL,
159 k_gtype_name, gtype_name,
160 k_name, name, SCM_UNDEFINED));
161
162 /* assert (scm_c_gtype_lookup_class (gtype) == ret); */
163
164 return ret;
165 }
166
167 SCM_DEFINE_STATIC (_gtype_to_class, "%gtype->class", 1, 0, 0,
168 (SCM ulong))
169 {
170 return scm_c_gtype_to_class (scm_to_ulong (ulong));
171 }
172
173 SCM_DEFINE (scm_gtype_name_to_class, "gtype-name->class", 1, 0, 0,
174 (SCM name),
175 "Return the @code{<gtype-class>} associated with the GType, @var{name}.")
176 #define FUNC_NAME s_scm_gtype_name_to_class
177 {
178 GType type;
179 gchar *chars;
180
181 SCM_VALIDATE_STRING (1, name);
182
183 scm_dynwind_begin (0);
184 chars = scm_to_locale_string (name);
185 scm_dynwind_free (chars);
186
187 type = g_type_from_name (chars);
188 if (!type)
189 scm_c_gruntime_error (FUNC_NAME,
190 "No GType registered with name ~A",
191 SCM_LIST1 (name));
192
193 scm_dynwind_end ();
194
195 return scm_c_gtype_to_class (type);
196 }
197 #undef FUNC_NAME
198
199 SCM_DEFINE_STATIC (scm_sys_gtype_class_bind, "%gtype-class-bind", 2, 0, 0,
200 (SCM class, SCM type_name))
201 #define FUNC_NAME s_scm_sys_gtype_class_bind
202 {
203 GType gtype;
204 char *c_type_name;
205
206 SCM_VALIDATE_GTYPE_CLASS (1, class);
207 SCM_VALIDATE_STRING (2, type_name);
208
209 if (scm_c_gtype_class_to_gtype (class))
210 scm_c_gruntime_error (FUNC_NAME,
211 "Class ~A already has a GType",
212 SCM_LIST1 (type_name));
213
214 scm_dynwind_begin (0);
215 c_type_name = scm_to_locale_string (type_name);
216 scm_dynwind_free (c_type_name);
217
218 gtype = g_type_from_name (c_type_name);
219 if (!gtype)
220 scm_c_gruntime_error (FUNC_NAME,
221 "No GType registered with name ~A",
222 SCM_LIST1 (type_name));
223
224
225 if (SCM_NFALSEP (scm_c_gtype_lookup_class (gtype)))
226 scm_c_gruntime_error (FUNC_NAME,
227 "~A already has a GOOPS class, use gtype-name->class",
228 SCM_LIST1 (type_name));
229
230 g_type_set_qdata (gtype, quark_class, scm_permanent_object (class));
231 scm_slot_set_x (class, scm_sym_gtype, scm_from_ulong (gtype));
232
233 scm_dynwind_end ();
234
235 return SCM_UNSPECIFIED;
236 }
237 #undef FUNC_NAME
238
239 #if SCM_MAJOR_VERSION == 1 && SCM_MINOR_VERSION < 9
240 # define scm_vtable_index_instance_finalize scm_struct_i_free
241 static size_t
scm_gtype_instance_struct_free(scm_t_bits * vtable,scm_t_bits * data)242 scm_gtype_instance_struct_free (scm_t_bits * vtable, scm_t_bits * data)
243 {
244 scm_gtype_instance_unbind (data);
245 scm_struct_free_light (vtable, data);
246 return 0;
247 }
248 #else
249 static void
scm_gtype_instance_struct_free(SCM object)250 scm_gtype_instance_struct_free (SCM object)
251 {
252 scm_gtype_instance_unbind (SCM_STRUCT_DATA (object));
253 }
254 #endif
255
256 SCM_DEFINE_STATIC (scm_sys_gtype_class_inherit_magic, "%gtype-class-inherit-magic", 1, 0, 0,
257 (SCM class))
258 #define FUNC_NAME s_scm_sys_gtype_class_inherit_magic
259 {
260 GType gtype;
261 scm_t_bits *slots;
262
263 SCM_VALIDATE_GTYPE_CLASS_COPY (1, class, gtype);
264
265 slots = SCM_STRUCT_DATA (class);
266 /* inherit class free function */
267 if (g_type_parent (gtype)) {
268 SCM parent = scm_c_gtype_to_class (g_type_parent (gtype));
269 slots[scm_vtable_index_instance_finalize] =
270 SCM_STRUCT_DATA (parent)[scm_vtable_index_instance_finalize];
271 } else if (G_TYPE_IS_INSTANTIATABLE (gtype)) {
272 slots[scm_vtable_index_instance_finalize] =
273 (scm_t_bits)scm_gtype_instance_struct_free;
274 #if SCM_MAJOR_VERSION == 1 && SCM_MINOR_VERSION < 9
275 } else if (slots[scm_vtable_index_instance_finalize] == (scm_t_bits)scm_struct_free_light) {
276 SCM parent = scm_cadr (scm_class_precedence_list (class));
277 slots[scm_vtable_index_instance_finalize] =
278 SCM_STRUCT_DATA (parent)[scm_vtable_index_instance_finalize];
279 } else {
280 scm_c_gruntime_error (FUNC_NAME, "No free function for SCM class %s!",
281 SCM_LIST1 (class));
282 #else
283 } else {
284 SCM parent = scm_cadr (scm_class_precedence_list (class));
285 /* is this right? layout might not be the same. */
286 slots[scm_vtable_index_instance_finalize] =
287 SCM_STRUCT_DATA (parent)[scm_vtable_index_instance_finalize];
288 #endif
289 }
290
291 return SCM_UNSPECIFIED;
292 }
293 #undef FUNC_NAME
294
295 GType
scm_c_gtype_class_to_gtype(SCM klass)296 scm_c_gtype_class_to_gtype (SCM klass)
297 #define FUNC_NAME "%gtype-class->gtype"
298 {
299 SCM_VALIDATE_GTYPE_CLASS (1, klass);
300
301 return scm_to_ulong (scm_slot_ref (klass, scm_sym_gtype));
302 }
303 #undef FUNC_NAME
304
305 gboolean
scm_c_gtype_class_is_a_p(SCM instance,GType gtype)306 scm_c_gtype_class_is_a_p (SCM instance, GType gtype)
307 {
308 return g_type_is_a (scm_c_gtype_class_to_gtype (instance), gtype);
309 }
310
311
312
313 /**********************************************************************
314 * GTypeInstance
315 **********************************************************************/
316
317 static scm_t_gtype_instance_funcs*
get_gtype_instance_instance_funcs(GType type)318 get_gtype_instance_instance_funcs (GType type)
319 {
320 GSList *l;
321 GType fundamental;
322 fundamental = G_TYPE_FUNDAMENTAL (type);
323 for (l = gtype_instance_funcs; l; l = l->next) {
324 scm_t_gtype_instance_funcs *ret = l->data;
325 if (fundamental == ret->type)
326 return ret;
327 }
328 return NULL;
329 }
330
331 void
scm_register_gtype_instance_funcs(const scm_t_gtype_instance_funcs * funcs)332 scm_register_gtype_instance_funcs (const scm_t_gtype_instance_funcs *funcs)
333 {
334 gtype_instance_funcs = g_slist_append (gtype_instance_funcs,
335 (gpointer)funcs);
336 }
337
338 gpointer
scm_c_gtype_instance_ref(gpointer instance)339 scm_c_gtype_instance_ref (gpointer instance)
340 {
341 scm_t_gtype_instance_funcs *funcs;
342 funcs = get_gtype_instance_instance_funcs (G_TYPE_FROM_INSTANCE (instance));
343 if (funcs && funcs->ref) {
344 funcs->ref (instance);
345 #ifdef DEBUG_PRINT
346 {
347 /* ugly. */
348 glong refcount;
349 if (G_IS_OBJECT (instance))
350 refcount = ((GObject*)instance)->ref_count;
351 else if (G_IS_PARAM_SPEC (instance))
352 refcount = ((GParamSpec*)instance)->ref_count;
353 else
354 refcount = -99;
355 DEBUG_ALLOC ("reffed instance (%p) of type %s, ->%ld",
356 instance, g_type_name (G_TYPE_FROM_INSTANCE (instance)),
357 refcount);
358 }
359 #endif
360 }
361
362 return instance;
363 }
364
365 void
scm_c_gtype_instance_unref(gpointer instance)366 scm_c_gtype_instance_unref (gpointer instance)
367 {
368 scm_t_gtype_instance_funcs *funcs;
369 funcs = get_gtype_instance_instance_funcs (G_TYPE_FROM_INSTANCE (instance));
370 #ifdef DEBUG_PRINT
371 {
372 /* ugly. */
373 glong refcount;
374 if (G_IS_OBJECT (instance))
375 refcount = ((GObject*)instance)->ref_count;
376 else if (G_IS_PARAM_SPEC (instance))
377 refcount = ((GParamSpec*)instance)->ref_count;
378 else
379 refcount = -99;
380 DEBUG_ALLOC ("unreffing instance (%p) of type %s, %ld->",
381 instance, g_type_name (G_TYPE_FROM_INSTANCE (instance)),
382 refcount);
383 }
384 #endif
385 if (funcs && funcs->unref)
386 funcs->unref (instance);
387 /* else */
388 /* g_type_free_instance (instance); */
389 }
390
391 static SCM
scm_c_gtype_instance_get_cached(gpointer instance)392 scm_c_gtype_instance_get_cached (gpointer instance)
393 {
394 SCM ret;
395 scm_t_gtype_instance_funcs *funcs;
396 funcs = get_gtype_instance_instance_funcs (G_TYPE_FROM_INSTANCE (instance));
397 if (funcs && funcs->get_qdata) {
398 gpointer data = funcs->get_qdata ((GObject*)instance,
399 guile_gobject_quark_wrapper);
400 if (data) {
401 ret = GPOINTER_TO_SCM (data);
402 #if SCM_MAJOR_VERSION == 1 && SCM_MINOR_VERSION < 9
403 scm_gc_mark (ret);
404 #endif
405 return ret;
406 }
407 }
408 return SCM_BOOL_F;
409 }
410
411 static void
scm_c_gtype_instance_set_cached(gpointer instance,SCM scm)412 scm_c_gtype_instance_set_cached (gpointer instance, SCM scm)
413 {
414 scm_t_gtype_instance_funcs *funcs;
415 funcs = get_gtype_instance_instance_funcs (G_TYPE_FROM_INSTANCE (instance));
416 if (funcs && funcs->set_qdata)
417 funcs->set_qdata ((GObject*)instance,
418 guile_gobject_quark_wrapper,
419 scm == SCM_BOOL_F ? NULL : SCM_TO_GPOINTER (scm));
420 }
421
422 static gpointer
scm_c_gtype_instance_construct(SCM object,SCM initargs)423 scm_c_gtype_instance_construct (SCM object, SCM initargs)
424 {
425 GType type;
426 scm_t_gtype_instance_funcs *funcs;
427 type = scm_c_gtype_class_to_gtype (scm_class_of (object));
428 funcs = get_gtype_instance_instance_funcs (type);
429 if (funcs && funcs->construct)
430 return funcs->construct (object, initargs);
431 else
432 scm_c_gruntime_error ("%gtype-instance-construct",
433 "Don't know how to construct instances of class ~A",
434 SCM_LIST1 (scm_c_gtype_to_class (type)));
435 return NULL;
436 }
437
438 static void
scm_c_gtype_instance_initialize_scm(SCM object,gpointer instance)439 scm_c_gtype_instance_initialize_scm (SCM object, gpointer instance)
440 {
441 GType type;
442 scm_t_gtype_instance_funcs *funcs;
443 type = scm_c_gtype_class_to_gtype (scm_class_of (object));
444 funcs = get_gtype_instance_instance_funcs (type);
445 if (funcs && funcs->initialize_scm)
446 funcs->initialize_scm (object, instance);
447 }
448
449 /* idea, code, and comments stolen from pygtk -- thanks, James :-) */
450 static inline void
sink_type_instance(gpointer instance)451 sink_type_instance (gpointer instance)
452 {
453 if (sink_funcs) {
454 gint i;
455
456 for (i = 0; i < sink_funcs->len; i++) {
457 if (g_type_is_a (G_TYPE_FROM_INSTANCE (instance),
458 g_array_index (sink_funcs, SinkFunc, i).type)) {
459 g_array_index (sink_funcs, SinkFunc, i).sinkfunc (instance);
460
461 #ifdef DEBUG_PRINT
462 if (G_IS_OBJECT (instance)) {
463 DEBUG_ALLOC ("sunk gobject (%p) of type %s, ->%u",
464 instance, g_type_name (G_TYPE_FROM_INSTANCE (instance)),
465 ((GObject*)instance)->ref_count);
466 }
467 #endif
468 break;
469 }
470 }
471 }
472 }
473
474 /**
475 * As Guile handles memory management for us, the "floating reference" code in
476 * GTK actually causes memory leaks for objects that are never parented. For
477 * this reason, guile-gobject removes the floating references on objects on
478 * construction.
479 *
480 * The sinkfunc should be able to remove the floating reference on
481 * instances of the given type, or any subclasses.
482 */
483 void
scm_register_gtype_instance_sinkfunc(GType type,void (* sinkfunc)(gpointer))484 scm_register_gtype_instance_sinkfunc (GType type, void (*sinkfunc) (gpointer))
485 {
486 SinkFunc sf;
487
488 if (!sink_funcs)
489 sink_funcs = g_array_new (FALSE, FALSE, sizeof(SinkFunc));
490
491 sf.type = type;
492 sf.sinkfunc = sinkfunc;
493 g_array_append_val (sink_funcs, sf);
494 }
495
496 static void
scm_gtype_instance_unbind(scm_t_bits * slots)497 scm_gtype_instance_unbind (scm_t_bits *slots)
498 {
499 gpointer instance = (gpointer)slots[0];
500
501 if (instance && instance != SCM_UNBOUND) {
502 DEBUG_ALLOC ("unbind c object 0x%p", instance);
503
504 slots[0] = 0;
505 scm_c_gtype_instance_set_cached (instance, SCM_BOOL_F);
506 scm_c_gtype_instance_unref (instance);
507 }
508 }
509
510 void
scm_c_gtype_instance_bind_to_object(gpointer ginstance,SCM object)511 scm_c_gtype_instance_bind_to_object (gpointer ginstance, SCM object)
512 {
513 scm_t_bits *slots = SCM_STRUCT_DATA (object);
514
515 scm_c_gtype_instance_ref (ginstance);
516 /* sink the floating ref, if any */
517 sink_type_instance (ginstance);
518 slots[0] = (scm_t_bits)ginstance;
519
520 /* Cache the return value, so that if a callback or another function returns
521 * this ginstance while the ginstance is visible elsewhere, the same wrapper
522 * will be used. Released in unbind(). */
523 scm_c_gtype_instance_set_cached (ginstance, object);
524
525 DEBUG_ALLOC ("bound SCM 0x%p to 0x%p", (void*)object, ginstance);
526 }
527
528 SCM_DEFINE_STATIC (scm_sys_gtype_instance_construct, "%gtype-instance-construct", 2, 0, 0,
529 (SCM instance, SCM initargs))
530 {
531 gpointer ginstance = (gpointer)SCM_STRUCT_DATA (instance)[0];
532
533 if (ginstance && ginstance != (gpointer)SCM_UNBOUND) {
534 scm_c_gtype_instance_initialize_scm (instance, ginstance);
535 } else {
536 gpointer new_ginstance;
537 new_ginstance = scm_c_gtype_instance_construct (instance, initargs);
538 ginstance = (gpointer)SCM_STRUCT_DATA (instance)[0];
539
540 /* it's possible the construct function bound the object already, as is
541 * the case for scheme-defined gobjects */
542 if (new_ginstance != ginstance)
543 scm_c_gtype_instance_bind_to_object (new_ginstance, instance);
544
545 scm_c_gtype_instance_unref (new_ginstance);
546 }
547
548 return SCM_UNSPECIFIED;
549 }
550
551 SCM_DEFINE (scm_gtype_instance_destroy_x, "gtype-instance-destroy!", 1, 0, 0,
552 (SCM instance),
553 "Release all references that the Scheme wrapper @var{instance} "
554 "has on the underlying C value, and release pointers associated "
555 "with the C value that point back to Scheme.\n\n"
556 "Normally, you don't need to call this function, because garbage "
557 "collection will take care of resource management. "
558 "However some @code{<gtype-class>} instances have semantics that "
559 "require this function. The canonical example is that when a "
560 "@code{<gtk-object>} emits the @code{destroy} signal, all "
561 "code should drop their references to the object. This is, "
562 "of course, handled internally in the @code{(gnome gtk)} "
563 "module.")
564 #define FUNC_NAME s_scm_gtype_instance_destroy_x
565 {
566 SCM_VALIDATE_GTYPE_INSTANCE (1, instance);
567
568 scm_gtype_instance_unbind (SCM_STRUCT_DATA (instance));
569
570 return SCM_UNSPECIFIED;
571 }
572 #undef FUNC_NAME
573
574 gpointer
scm_c_scm_to_gtype_instance(SCM instance)575 scm_c_scm_to_gtype_instance (SCM instance)
576 {
577 SCM ulong;
578 gpointer ginstance;
579
580 if (!SCM_IS_A_P (instance, scm_class_gtype_instance))
581 return NULL;
582
583 /* FIXME: the following code should work, but slot-ref on 'u' slots was
584 busted until guile 1.8.5
585 ulong = scm_slot_ref (instance, scm_sym_gtype_instance);
586 */
587 ulong = scm_from_ulong (SCM_STRUCT_DATA (instance)[0]);
588
589 if (ulong == SCM_UNBOUND)
590 scm_c_gruntime_error ("%scm->gtype-instance",
591 "Object ~A is uninitialized.",
592 SCM_LIST1 (instance));
593
594 ginstance = (gpointer)scm_to_ulong (ulong);
595
596 if (!ginstance)
597 scm_c_gruntime_error ("%scm->gtype-instance",
598 "Object ~A has been destroyed.",
599 SCM_LIST1 (instance));
600
601 return ginstance;
602 }
603
604 gboolean
scm_c_gtype_instance_is_a_p(SCM instance,GType gtype)605 scm_c_gtype_instance_is_a_p (SCM instance, GType gtype)
606 {
607 return scm_c_scm_to_gtype_instance_typed (instance, gtype) != NULL;
608 }
609
610 gpointer
scm_c_scm_to_gtype_instance_typed(SCM instance,GType gtype)611 scm_c_scm_to_gtype_instance_typed (SCM instance, GType gtype)
612 {
613 gpointer ginstance = scm_c_scm_to_gtype_instance (instance);
614
615 if (!G_TYPE_CHECK_INSTANCE_TYPE (ginstance, gtype))
616 return NULL;
617
618 return ginstance;
619 }
620
621 /* returns a goops object of class (gtype->class type). this function exists for
622 * gobject.c:scm_c_gtype_instance_instance_init. all other callers should use
623 * scm_c_gtype_instance_to_scm. */
624 SCM
scm_c_gtype_instance_to_scm_typed(gpointer ginstance,GType type)625 scm_c_gtype_instance_to_scm_typed (gpointer ginstance, GType type)
626 {
627 SCM class, object;
628
629 object = scm_c_gtype_instance_get_cached (ginstance);
630 if (!scm_is_false (object))
631 return object;
632
633 class = scm_c_gtype_lookup_class (type);
634 if (SCM_FALSEP (class))
635 class = scm_c_gtype_to_class (type);
636 g_assert (SCM_NFALSEP (class));
637
638 /* FIXME more comments on why we do it this way */
639 object = scm_call_2 (_allocate_instance, class, SCM_EOL);
640 scm_c_gtype_instance_bind_to_object (ginstance, object);
641 scm_call_2 (_initialize, object, SCM_EOL);
642
643 return object;
644 }
645
646 SCM
scm_c_gtype_instance_to_scm(gpointer ginstance)647 scm_c_gtype_instance_to_scm (gpointer ginstance)
648 {
649 if (!ginstance)
650 return SCM_BOOL_F;
651
652 return scm_c_gtype_instance_to_scm_typed
653 (ginstance, G_TYPE_FROM_INSTANCE (ginstance));
654 }
655
656
657
658 /**********************************************************************
659 * Miscellaneous
660 **********************************************************************/
661
scm_c_gruntime_error(const char * subr,const char * message,SCM args)662 void scm_c_gruntime_error (const char *subr, const char *message,
663 SCM args)
664 {
665 scm_error (sym_gruntime_error, subr, message,
666 args, SCM_EOL);
667 }
668
669
670
671 /**********************************************************************
672 * Initialization
673 **********************************************************************/
674
675 void
scm_init_gnome_gobject_types(void)676 scm_init_gnome_gobject_types (void)
677 {
678 g_type_init ();
679
680 #ifndef SCM_MAGIC_SNARFER
681 #include "gtype.x"
682 #endif
683
684 quark_type = g_quark_from_static_string ("%scm-gtype->type");
685 quark_class = g_quark_from_static_string ("%scm-gtype->class");
686 quark_guile_gtype_class = g_quark_from_static_string ("%scm-guile-gtype-class");
687 guile_gobject_quark_wrapper = g_quark_from_static_string ("%guile-gobject-wrapper");
688
689 scm_sys_gtype_to_class =
690 scm_permanent_object (SCM_VARIABLE_REF (scm_c_lookup ("%gtype->class")));
691
692 _gtype_name_to_scheme_name =
693 scm_permanent_object (SCM_VARIABLE_REF (scm_c_lookup ("gtype-name->scheme-name")));
694 _gtype_name_to_class_name =
695 scm_permanent_object (SCM_VARIABLE_REF (scm_c_lookup ("gtype-name->class-name")));
696
697 _make_class = scm_permanent_object (SCM_VARIABLE_REF (scm_c_lookup ("make-class")));
698 _class_redefinition =
699 scm_permanent_object (SCM_VARIABLE_REF (scm_c_lookup ("class-redefinition")));
700 _allocate_instance =
701 scm_permanent_object (SCM_VARIABLE_REF (scm_c_lookup ("allocate-instance")));
702 _initialize =
703 scm_permanent_object (SCM_VARIABLE_REF (scm_c_lookup ("initialize")));
704 }
705
706 void
scm_init_gnome_gobject_types_gtype_class(void)707 scm_init_gnome_gobject_types_gtype_class (void)
708 {
709 scm_class_gtype_class = scm_permanent_object
710 (SCM_VARIABLE_REF (scm_c_lookup ("<gtype-class>")));
711 }
712
713 void
scm_init_gnome_gobject_types_gtype_instance(void)714 scm_init_gnome_gobject_types_gtype_instance (void)
715 {
716 scm_class_gtype_instance = scm_permanent_object
717 (SCM_VARIABLE_REF (scm_c_lookup ("<gtype-instance>")));
718 }
719