1 /* -*- Mode: C; c-basic-offset: 4 -*- */
2 /* guile-gnome
3 * Copyright (C) 2001, 2009, 2010 Martin Baulig <martin@gnome.org>
4 * Copyright (C) 2003,2004 Andy Wingo <wingo at pobox dot com>
5 *
6 * gvalue.c: Support for GValue-based types
7 *
8 * This program is free software; you can redistribute it and/or
9 * modify it under the terms of the GNU General Public License as
10 * published by the Free Software Foundation; either version 2 of
11 * the License, or (at your option) any later version.
12 *
13 * This program is distributed in the hope that it will be useful,
14 * but WITHOUT ANY WARRANTY; without even the implied warranty of
15 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
16 * GNU General Public License for more details.
17 *
18 * You should have received a copy of the GNU General Public License
19 * along with this program; if not, contact:
20 *
21 * Free Software Foundation Voice: +1-617-542-5942
22 * 59 Temple Place - Suite 330 Fax: +1-617-542-2652
23 * Boston, MA 02111-1307, USA gnu@gnu.org
24 */
25
26
27 #include <stdio.h>
28 #include <string.h>
29 #include "gc.h"
30 #include "gvalue.h"
31 #include "gobject.h"
32 #include "guile-support.h"
33
34
35
36
37 typedef struct {
38 SCM (*wrap) (const GValue*);
39 void (*unwrap) (SCM, GValue*);
40 } wrap_funcs;
41
42 typedef struct {
43 SCMGValueGetTypeInstanceFunc getter;
44 SCMGValueSetTypeInstanceFunc setter;
45 } gtype_instance_wrap_funcs;
46
47 static guint scm_c_scm_to_flags_value (GFlagsClass *flags_class, SCM value);
48 static gint scm_c_scm_to_enum_value (GEnumClass *enum_class, SCM value);
49
50 SCM scm_class_gvalue;
51 static SCM _allocate_instance;
52
53 SCM_SYMBOL (sym_primitive_value, "primitive-value");
54 SCM_SYMBOL (sym_closure, "closure");
55 SCM_KEYWORD (k_value, "value");
56
57 static GHashTable *gvalue_wrappers = NULL;
58 static GHashTable *gtype_instance_wrappers = NULL;
59
60
61
62 /* #define DEBUG_PRINT */
63
64 #ifdef DEBUG_PRINT
65 #define DEBUG_ALLOC(str, args...) g_print ("I: " str "\n", ##args)
66 #else
67 #define DEBUG_ALLOC(str, args...)
68 #endif
69
70
71
72 /**********************************************************************
73 * SCM representation of GValue*
74 **********************************************************************/
75
76 #if SCM_MAJOR_VERSION == 1 && SCM_MINOR_VERSION < 9
77 #define scm_vtable_index_instance_finalize scm_struct_i_free
78 static size_t
scm_gvalue_struct_free(scm_t_bits * vtable,scm_t_bits * data)79 scm_gvalue_struct_free (scm_t_bits * vtable, scm_t_bits * data)
80 {
81 GValue *value = (GValue *) data[0];
82
83 if (value) {
84 DEBUG_ALLOC ("freeing GValue %p", value);
85 g_value_unset (value);
86 scm_gc_free (value, sizeof (GValue), "%gvalue");
87 }
88 scm_struct_free_light (vtable, data);
89 return 0;
90 }
91 #else
92 static void
scm_gvalue_struct_free(SCM object)93 scm_gvalue_struct_free (SCM object)
94 {
95 GValue *value = (GValue *) SCM_STRUCT_DATA_REF (object, 0);
96
97 if (value) {
98 DEBUG_ALLOC ("freeing GValue %p", value);
99 g_value_unset (value);
100 scm_gc_free (value, sizeof (GValue), "%gvalue");
101 }
102 }
103 #endif
104
105 SCM_DEFINE (scm_sys_bless_gvalue_class, "%bless-gvalue-class", 1, 0, 0,
106 (SCM class), "")
107 {
108 scm_t_bits *slots = SCM_STRUCT_DATA (class);
109 scm_class_gvalue = scm_permanent_object (class);
110 slots[scm_vtable_index_instance_finalize] = (scm_t_bits)scm_gvalue_struct_free;
111 return SCM_UNSPECIFIED;
112 }
113
114 SCM_DEFINE (scm_sys_allocate_gvalue, "%allocate-gvalue", 2, 0, 0,
115 (SCM class, SCM instance), "")
116 {
117 GValue *value;
118
119 value = scm_gc_malloc (sizeof (GValue), "%gvalue");
120 value->g_type = 0;
121 SCM_STRUCT_DATA (instance)[0] = (scm_t_bits)value;
122 if (class != scm_class_gvalue) {
123 GType type = scm_c_gtype_class_to_gtype (class);
124 g_value_init (value, type);
125 DEBUG_ALLOC ("Bound SCM %p to GValue %p (%s)", instance, value, g_type_name (type));
126 } else {
127 DEBUG_ALLOC ("Bound SCM %p to generic GValue %p", instance, value);
128 }
129
130 return SCM_UNSPECIFIED;
131 }
132
133 SCM
scm_c_make_gvalue(GType gtype)134 scm_c_make_gvalue (GType gtype)
135 {
136 SCM ret, class;
137
138 class = scm_c_gtype_to_class (gtype);
139 if (scm_is_false (scm_memq (scm_class_gvalue,
140 scm_class_precedence_list (class))))
141 /* it's not a <gvalue> class; use the generic code */
142 class = scm_class_gvalue;
143
144 ret = scm_call_2 (_allocate_instance, class, SCM_EOL);
145
146 if (class == scm_class_gvalue)
147 /* generic code needs a bit of help.. */
148 g_value_init (scm_c_gvalue_peek_value (ret), gtype);
149
150 /* no need to `initialize' */
151 return ret;
152 }
153
154 /* assume that something on the stack will reference scm */
155 GValue*
scm_c_gvalue_peek_value(SCM scm)156 scm_c_gvalue_peek_value (SCM scm)
157 #define FUNC_NAME "%gvalue-peek-value"
158 {
159 SCM_VALIDATE_GVALUE (1, scm);
160 return (GValue*)SCM_STRUCT_DATA (scm)[0];
161 }
162 #undef FUNC_NAME
163
164
165
166 /**********************************************************************
167 * get/set primitives
168 **********************************************************************/
169
170 /* not threadsafe */
171 void
scm_c_register_gvalue_wrappers(GType type,SCM (* wrap)(const GValue *),void (* unwrap)(SCM,GValue *))172 scm_c_register_gvalue_wrappers (GType type,
173 SCM (*wrap) (const GValue*),
174 void (*unwrap) (SCM, GValue*))
175 {
176 wrap_funcs* w = g_new (wrap_funcs, 1);
177
178 if (!gvalue_wrappers)
179 gvalue_wrappers = g_hash_table_new (NULL, NULL);
180
181 w->wrap = wrap;
182 w->unwrap = unwrap;
183
184 g_hash_table_insert (gvalue_wrappers, (gpointer)type, w);
185 }
186
187 void
scm_c_register_gtype_instance_gvalue_wrappers(GType type,SCMGValueGetTypeInstanceFunc getter,SCMGValueSetTypeInstanceFunc setter)188 scm_c_register_gtype_instance_gvalue_wrappers (GType type,
189 SCMGValueGetTypeInstanceFunc getter, SCMGValueSetTypeInstanceFunc setter)
190 {
191 gtype_instance_wrap_funcs* w = g_new (gtype_instance_wrap_funcs, 1);
192
193 if (!gtype_instance_wrappers)
194 gtype_instance_wrappers = g_hash_table_new (NULL, NULL);
195
196 w->getter = getter;
197 w->setter = setter;
198
199 g_hash_table_insert (gtype_instance_wrappers, (gpointer)type, w);
200 }
201
202 SCM
scm_c_gvalue_ref(const GValue * gvalue)203 scm_c_gvalue_ref (const GValue *gvalue)
204 #define FUNC_NAME "%gvalue-ref"
205 {
206 GType type, fundamental;
207
208 type = G_VALUE_TYPE (gvalue);
209 fundamental = G_TYPE_FUNDAMENTAL (type);
210
211 switch (fundamental) {
212 case G_TYPE_CHAR:
213 return SCM_MAKE_CHAR (g_value_get_char (gvalue));
214
215 case G_TYPE_UCHAR:
216 return SCM_MAKE_CHAR (g_value_get_uchar (gvalue));
217
218 case G_TYPE_BOOLEAN:
219 return SCM_BOOL (g_value_get_boolean (gvalue));
220
221 case G_TYPE_INT:
222 return scm_from_int (g_value_get_int (gvalue));
223
224 case G_TYPE_UINT:
225 return scm_from_uint (g_value_get_uint (gvalue));
226
227 case G_TYPE_LONG:
228 return scm_from_long (g_value_get_long (gvalue));
229
230 case G_TYPE_ULONG:
231 return scm_from_ulong (g_value_get_ulong (gvalue));
232
233 case G_TYPE_INT64:
234 return scm_from_long_long (g_value_get_int64 (gvalue));
235
236 case G_TYPE_UINT64:
237 return scm_from_ulong_long (g_value_get_uint64 (gvalue));
238
239 case G_TYPE_FLOAT:
240 return scm_from_double ((double) g_value_get_float (gvalue));
241
242 case G_TYPE_DOUBLE:
243 return scm_from_double (g_value_get_double (gvalue));
244
245 case G_TYPE_STRING:
246 {
247 const char *s = g_value_get_string (gvalue);
248 return s ? scm_from_locale_string (s) : SCM_BOOL_F;
249 }
250
251 default:
252 {
253 gtype_instance_wrap_funcs* w1;
254 wrap_funcs* w2;
255 if ((w1 = g_hash_table_lookup (gtype_instance_wrappers,
256 (gpointer)fundamental))) {
257 return scm_c_gtype_instance_to_scm (w1->getter (gvalue));
258 } else if ((w2 = g_hash_table_lookup (gvalue_wrappers,
259 (gpointer)type))) {
260 return w2->wrap (gvalue);
261 } else {
262 SCM ret = scm_c_make_gvalue (type);
263
264 /* Enums and flags are natively represented as GValues. Boxed
265 * and pointer values also fall through here, unless there is a
266 * custom wrapper registered. */
267 g_value_copy (gvalue, scm_c_gvalue_peek_value (ret));
268 return ret;
269 }
270 }
271 }
272 }
273 #undef FUNC_NAME
274
275 void
scm_c_gvalue_set(GValue * gvalue,SCM value)276 scm_c_gvalue_set (GValue *gvalue, SCM value)
277 #define FUNC_NAME "%gvalue-set!"
278 {
279 GType gtype, fundamental;
280
281 gtype = G_VALUE_TYPE (gvalue);
282 fundamental = G_TYPE_FUNDAMENTAL (gtype);
283
284 if (SCM_GVALUEP (value)) {
285 if (g_type_is_a (scm_c_gtype_class_to_gtype (scm_class_of (value)),
286 gtype)) {
287 GValue *v = scm_c_gvalue_peek_value (value);
288 g_value_copy (v, gvalue);
289 return;
290 } else {
291 scm_c_gruntime_error (FUNC_NAME, "Can't make ~a into ~a",
292 SCM_LIST2 (value, scm_c_gtype_to_class (gtype)));
293 return;
294 }
295 }
296
297 switch (fundamental) {
298 case G_TYPE_CHAR:
299 if (SCM_CHARP (value))
300 g_value_set_char (gvalue, SCM_CHAR (value));
301 else
302 g_value_set_char (gvalue, scm_to_int8 (value));
303 break;
304
305 case G_TYPE_UCHAR:
306 if (SCM_CHARP (value))
307 g_value_set_uchar (gvalue, SCM_CHAR (value));
308 else
309 g_value_set_uchar (gvalue, scm_to_uint8 (value));
310 break;
311
312 case G_TYPE_BOOLEAN:
313 SCM_VALIDATE_BOOL (2, value);
314 g_value_set_boolean (gvalue, SCM_NFALSEP (value));
315 break;
316
317 case G_TYPE_INT:
318 g_value_set_int (gvalue, scm_to_int (value));
319 break;
320
321 case G_TYPE_UINT:
322 g_value_set_uint (gvalue, scm_to_uint (value));
323 break;
324
325 case G_TYPE_LONG:
326 g_value_set_long (gvalue, scm_to_long (value));
327 break;
328
329 case G_TYPE_ULONG:
330 g_value_set_ulong (gvalue, scm_to_ulong (value));
331 break;
332
333 case G_TYPE_INT64:
334 g_value_set_int64 (gvalue, scm_to_int64 (value));
335 break;
336
337 case G_TYPE_UINT64:
338 g_value_set_uint64 (gvalue, scm_to_uint64 (value));
339 break;
340
341 case G_TYPE_FLOAT: {
342 double x = scm_to_double (value);
343 SCM_ASSERT_RANGE (2, value, (- G_MAXFLOAT < x) && (x < G_MAXFLOAT));
344 g_value_set_float (gvalue, (float) x);
345 break;
346 }
347
348 case G_TYPE_DOUBLE:
349 g_value_set_double (gvalue, scm_to_double (value));
350 break;
351
352 case G_TYPE_STRING:
353 SCM_ASSERT (scm_is_string (value) || SCM_FALSEP (value),
354 value, SCM_ARG2, FUNC_NAME);
355 if (SCM_FALSEP (value))
356 g_value_set_string (gvalue, NULL);
357 else
358 g_value_take_string (gvalue, scm_to_locale_string (value));
359 break;
360
361 case G_TYPE_ENUM: {
362 GEnumClass *enum_class = g_type_class_ref (G_VALUE_TYPE (gvalue));
363 g_value_set_enum (gvalue, scm_c_scm_to_enum_value (enum_class, value));
364 g_type_class_unref (enum_class);
365 break;
366 }
367
368 case G_TYPE_FLAGS: {
369 GFlagsClass *flags_class = g_type_class_ref (G_VALUE_TYPE (gvalue));
370 g_value_set_flags (gvalue, scm_c_scm_to_flags_value (flags_class, value));
371 g_type_class_unref (flags_class);
372 break;
373 }
374
375 default:
376 {
377 gtype_instance_wrap_funcs *w;
378 w = g_hash_table_lookup (gtype_instance_wrappers,
379 (gpointer)fundamental);
380
381 if (w) {
382 if (SCM_FALSEP (value)) {
383 w->setter (gvalue, NULL);
384 } else {
385 gpointer ginstance;
386
387 SCM_VALIDATE_GTYPE_INSTANCE_TYPE_COPY (2, value,
388 G_VALUE_TYPE (gvalue),
389 ginstance);
390
391 w->setter (gvalue, ginstance);
392 }
393 break;
394 }
395 }
396 {
397 wrap_funcs *w;
398 w = g_hash_table_lookup (gvalue_wrappers, (gpointer)gtype);
399
400 if (w) {
401 w->unwrap (value, gvalue);
402 break;
403 }
404 }
405
406 scm_c_gruntime_error (FUNC_NAME,
407 "Don't know how to make values of type ~A",
408 SCM_LIST1 (scm_c_gtype_to_class (gtype)));
409 }
410 }
411 #undef FUNC_NAME
412
413 static gint
scm_c_scm_to_enum_value(GEnumClass * enum_class,SCM value)414 scm_c_scm_to_enum_value (GEnumClass *enum_class, SCM value)
415 #define FUNC_NAME "%scm->enum-value"
416 {
417 guint i;
418
419 #define ERROR(x) \
420 scm_c_gruntime_error \
421 (FUNC_NAME, "Bad enum value for enumerated type `~a': ~a", \
422 SCM_LIST2 (scm_from_locale_string \
423 (g_type_name (G_TYPE_FROM_CLASS (enum_class))), x))
424
425 if (scm_is_signed_integer (value, SCM_T_INT32_MIN, SCM_T_INT32_MAX)) {
426 gint v = scm_to_int (value);
427 for (i = 0; i < enum_class->n_values; i++)
428 if (enum_class->values[i].value == v)
429 return v;
430 ERROR (value);
431 } else if (scm_is_symbol (value)) {
432 char *v = scm_symbol_chars (value);
433 for (i = 0; i < enum_class->n_values; i++)
434 if (strcmp (enum_class->values[i].value_nick, v) == 0) {
435 free (v);
436 return enum_class->values[i].value;
437 }
438 free (v);
439 ERROR (value);
440 } else if (scm_is_string (value)) {
441 char *v = scm_to_locale_string (value);
442 for (i = 0; i < enum_class->n_values; i++)
443 if (strcmp (enum_class->values[i].value_name, v) == 0) {
444 free (v);
445 return enum_class->values[i].value;
446 }
447 free (v);
448 ERROR (value);
449 }
450 ERROR (value);
451 return 0; /* not reached */
452 #undef ERROR
453 }
454 #undef FUNC_NAME
455
456 SCM_DEFINE (scm_genum_to_value, "genum->value", 1, 0, 0,
457 (SCM value),
458 "Convert the enumerated value @var{obj} from a @code{<gvalue>} to "
459 "its representation as an integer.")
460 #define FUNC_NAME s_scm_genum_to_value
461 {
462 SCM_ASSERT (scm_c_gvalue_holds (value, G_TYPE_ENUM), value, SCM_ARG1,
463 FUNC_NAME);
464
465 return scm_from_int (g_value_get_enum (scm_c_gvalue_peek_value (value)));
466 }
467 #undef FUNC_NAME
468
469 static guint
scm_c_scm_to_flags_value(GFlagsClass * flags_class,SCM value)470 scm_c_scm_to_flags_value (GFlagsClass *flags_class, SCM value)
471 #define FUNC_NAME "%scm->flags-value"
472 {
473 #define ERROR(x) \
474 scm_c_gruntime_error \
475 (FUNC_NAME, "Bad value for flags type `~a': ~a", \
476 SCM_LIST2 (scm_from_locale_string \
477 (g_type_name (G_TYPE_FROM_CLASS (flags_class))), x))
478
479 if (scm_is_unsigned_integer (value, 0, SCM_T_UINT32_MAX)) {
480 guint v = scm_to_uint (value);
481 if ((v & flags_class->mask) == v)
482 return v;
483 ERROR (value);
484 return 0; /* not reached */
485 } else {
486 guint ret = 0;
487 guint i;
488 SCM s;
489
490 if (!scm_is_true (scm_list_p (value))) {
491 if (scm_is_symbol (value) || scm_is_string (value))
492 value = scm_list_1 (value);
493 else
494 ERROR (value);
495 }
496
497 for (; !scm_is_null (value); value = scm_cdr (value)) {
498 s = scm_car (value);
499 if (scm_is_unsigned_integer (s, 0, SCM_T_UINT32_MAX)) {
500 guint v = scm_to_uint (s);
501 for (i = 0; i < flags_class->n_values; i++)
502 if (flags_class->values[i].value == v) {
503 ret |= v;
504 break;
505 }
506 if (i == flags_class->n_values)
507 ERROR (s);
508 } else if (scm_is_symbol (s)) {
509 char *v = scm_symbol_chars (s);
510 for (i = 0; i < flags_class->n_values; i++)
511 if (strcmp (flags_class->values[i].value_nick, v) == 0) {
512 ret |= flags_class->values[i].value;
513 break;
514 }
515 free (v);
516 if (i == flags_class->n_values)
517 ERROR (s);
518 } else if (scm_is_string (s)) {
519 char *v = scm_to_locale_string (s);
520 for (i = 0; i < flags_class->n_values; i++)
521 if (strcmp (flags_class->values[i].value_name, v) == 0) {
522 ret |= flags_class->values[i].value;
523 break;
524 }
525 free (v);
526 if (i == flags_class->n_values)
527 ERROR (s);
528 } else {
529 ERROR (s);
530 }
531 }
532 return ret;
533 }
534 #undef ERROR
535 }
536 #undef FUNC_NAME
537
538 SCM_DEFINE (scm_gflags_to_value, "gflags->value", 1, 0, 0,
539 (SCM value),
540 "Convert the flags value @var{obj} from a @code{<gvalue>} to "
541 "its representation as an integer.")
542 #define FUNC_NAME s_scm_gflags_to_value
543 {
544 SCM_ASSERT (scm_c_gvalue_holds (value, G_TYPE_FLAGS), value, SCM_ARG1,
545 FUNC_NAME);
546
547 return scm_from_int (g_value_get_flags (scm_c_gvalue_peek_value (value)));
548 }
549 #undef FUNC_NAME
550
551 SCM_DEFINE (scm_sys_gvalue_set_x, "%gvalue-set!", 2, 0, 0,
552 (SCM instance, SCM value), "")
553 {
554 scm_c_gvalue_set (scm_c_gvalue_peek_value (instance),
555 value);
556 return SCM_UNSPECIFIED;
557 }
558
559
560
561 /**********************************************************************
562 * SCM <-> GValue*
563 **********************************************************************/
564
565 SCM
scm_c_gvalue_to_scm(const GValue * gvalue)566 scm_c_gvalue_to_scm (const GValue *gvalue)
567 {
568 return scm_c_gvalue_ref (gvalue);
569 }
570
571 GValue*
scm_c_scm_to_gvalue(GType gtype,SCM scm)572 scm_c_scm_to_gvalue (GType gtype, SCM scm)
573 {
574 GValue *new = g_new0 (GValue, 1);
575
576 g_value_init (new, gtype);
577 scm_c_gvalue_set (new, scm);
578 return new;
579 }
580
581 SCM_DEFINE (scm_gvalue_to_scm, "gvalue->scm", 1, 0, 0,
582 (SCM value),
583 "Convert a @code{<gvalue>} into it normal scheme representation, "
584 "for example unboxing characters into Scheme characters. Note "
585 "that the Scheme form for some values is the @code{<gvalue>} "
586 "form, for example with boxed or enumerated values.")
587 {
588 /* FIXME: needlessly creates a new value in the e.g. boxed case */
589 GValue *v = scm_c_gvalue_peek_value (value);
590 return scm_c_gvalue_ref (v);
591 }
592
593 SCM_DEFINE (scm_scm_to_gvalue, "scm->gvalue", 2, 0, 0,
594 (SCM class, SCM scm),
595 "Convert a Scheme value into a @code{<gvalue>} of type "
596 "@var{class}. If the conversion is not possible, raise a "
597 "@code{gruntime-error}.")
598 {
599 SCM ret;
600 GValue *gvalue;
601
602 /* fixme the noop case */
603 ret = scm_c_make_gvalue (scm_c_gtype_class_to_gtype (class));
604 gvalue = scm_c_gvalue_peek_value (ret);
605 scm_c_gvalue_set (gvalue, scm);
606
607 return ret;
608 }
609
610
611
612 /**********************************************************************
613 * custom SCM wrappers for some boxed types
614 **********************************************************************/
615
616 static gpointer
copy_gboxed_scm(gpointer boxed)617 copy_gboxed_scm (gpointer boxed)
618 {
619 DEBUG_ALLOC (G_STRLOC ": copying gboxed %p", boxed);
620 scm_glib_gc_protect_object ((SCM) boxed);
621 return boxed;
622 }
623
624 static void
free_gboxed_scm(gpointer boxed)625 free_gboxed_scm (gpointer boxed)
626 {
627 DEBUG_ALLOC (G_STRLOC ": freeing gboxed %p", boxed);
628 scm_glib_gc_unprotect_object (boxed);
629 }
630
631 GType
gboxed_scm_get_type(void)632 gboxed_scm_get_type (void)
633 {
634 static GType boxed_type = 0;
635
636 if (!boxed_type)
637 boxed_type = g_boxed_type_register_static
638 ("GBoxedSCM", copy_gboxed_scm, free_gboxed_scm);
639
640 return boxed_type;
641 }
642
643 SCM
wrap_boxed_scm(const GValue * value)644 wrap_boxed_scm (const GValue *value)
645 {
646 gpointer val = g_value_get_boxed (value);
647 return val ? GPOINTER_TO_SCM (g_value_get_boxed (value)) : SCM_UNSPECIFIED;
648 }
649
650 void
unwrap_boxed_scm(SCM scm,GValue * value)651 unwrap_boxed_scm (SCM scm, GValue *value)
652 {
653 g_value_set_boxed (value, SCM_TO_GPOINTER (scm));
654 }
655
656 SCM
wrap_gvalue_array(const GValue * value)657 wrap_gvalue_array (const GValue *value)
658 {
659 GValueArray *arr = g_value_get_boxed (value);
660 gint i = arr ? arr->n_values : 0;
661 SCM l = SCM_EOL;
662
663 while (i--)
664 l = scm_cons (scm_c_gvalue_ref (&arr->values[i]), l);
665 return l;
666 }
667
668 void
unwrap_gvalue_array(SCM scm,GValue * value)669 unwrap_gvalue_array (SCM scm, GValue *value)
670 #define FUNC_NAME "%unwrap-gvalue-array"
671 {
672 GValueArray *arr;
673 gint len;
674
675 SCM_ASSERT (SCM_BOOL (scm_list_p (scm)), scm, SCM_ARG2, FUNC_NAME);
676
677 len = scm_ilength (scm);
678 arr = g_value_array_new (len);
679 while (len--) {
680 GType value_type;
681 SCM v;
682
683 v = SCM_CAR (scm);
684
685 if (SCM_GVALUEP (v))
686 value_type = G_VALUE_TYPE (scm_c_gvalue_peek_value (v));
687 if (scm_is_string (v))
688 value_type = G_TYPE_STRING;
689 else if (SCM_BOOLP (v))
690 value_type = G_TYPE_BOOLEAN;
691 else if (scm_is_signed_integer (v, SCM_T_INT32_MIN, SCM_T_INT32_MAX))
692 value_type = G_TYPE_INT;
693 else if (SCM_REALP (v))
694 value_type = G_TYPE_DOUBLE;
695 else if (SCM_CHARP (v))
696 value_type = G_TYPE_CHAR;
697 else if (SCM_GOBJECTP (v)) {
698 GObject *gobject;
699 SCM_VALIDATE_GOBJECT_COPY (1, v, gobject);
700 value_type = G_OBJECT_TYPE (gobject);
701 }
702 else if (SCM_BOOL (scm_list_p (v)))
703 value_type = G_TYPE_VALUE_ARRAY;
704 else
705 scm_wrong_type_arg (FUNC_NAME, SCM_ARG2, v);
706
707 {
708 GValue tmp = { 0, };
709 g_value_init (&tmp, value_type);
710 scm_c_gvalue_set (&tmp, v);
711 /* copies the val */
712 g_value_array_append (arr, &tmp);
713 g_value_unset (&tmp);
714 }
715 scm = SCM_CDR (scm);
716 }
717
718 g_value_take_boxed (value, arr);
719 }
720 #undef FUNC_NAME
721
722
723
724 /**********************************************************************
725 * Defining new enum and flags types
726 **********************************************************************/
727
728 SCM_DEFINE (scm_genum_register_static, "genum-register-static", 2, 0, 0,
729 (SCM name, SCM vtable),
730 "Creates and registers a new enumerated type with name @var{name} with the C runtime. "
731 "There must be no type with name @var{name} when this function is called.\n\n"
732 "The new type can be accessed by using @code{gtype-name->class}.\n\n"
733 "@var{vtable} is a vector describing the new enum type. Each vector element describes "
734 "one enum element and must be a list of 3 elements: the element's nick name as a symbol, "
735 "its name as a string, and its integer value.\n\n"
736 "@lisp\n"
737 "(genum-register-static \"Test\"\n"
738 " #((foo \"Foo\" 1) (bar \"Bar\" 2) (baz \"Long name of baz\" 4)))\n"
739 "@end lisp\n")
740 #define FUNC_NAME s_scm_genum_register_static
741 {
742 size_t length, i;
743 GEnumValue *values;
744 GType type;
745
746 SCM_VALIDATE_STRING (1, name);
747 SCM_VALIDATE_VECTOR (2, vtable);
748
749 scm_dynwind_begin (0);
750
751 type = g_type_from_name (scm_to_locale_string_dynwind (name));
752
753 if (type)
754 scm_c_gruntime_error (FUNC_NAME,
755 "There is already a type with this name: ~S",
756 SCM_LIST1 (name));
757
758 length = scm_c_vector_length (vtable);
759
760 for (i = 0; i < length; i++) {
761 SCM this = scm_c_vector_ref (vtable, i);
762
763 SCM_ASSERT ((scm_ilength (this) == 3) &&
764 SCM_SYMBOLP (scm_car (this)) &&
765 scm_is_string (scm_cadr (this)) &&
766 scm_is_signed_integer (scm_caddr (this),
767 SCM_T_INT32_MIN, SCM_T_INT32_MAX),
768 vtable, SCM_ARG2, FUNC_NAME);
769 }
770
771 values = g_new0 (GEnumValue, length + 1);
772
773 for (i = 0; i < length; i++) {
774 SCM this = scm_c_vector_ref (vtable, i);
775
776 values [i].value_nick = scm_symbol_chars (scm_car (this));
777 values [i].value_name = scm_to_locale_string (scm_cadr (this));
778 values [i].value = scm_to_int (scm_caddr (this));
779 }
780
781 type = g_enum_register_static (scm_to_locale_string_dynwind (name), values);
782
783 scm_dynwind_end ();
784
785 return SCM_UNSPECIFIED;
786 }
787 #undef FUNC_NAME
788
789 SCM_DEFINE (scm_gflags_register_static, "gflags-register-static", 2, 0, 0,
790 (SCM name, SCM vtable),
791 "Creates and registers a new flags @code{<gtype-class>} with name "
792 "@var{name} with the C runtime.\n\n"
793 "The @var{vtable} should be in the format described in the "
794 "documentation for @code{genum-register-static}.")
795 #define FUNC_NAME s_scm_gflags_register_static
796 {
797 size_t length, i;
798 GFlagsValue *values;
799 GType type;
800
801 SCM_VALIDATE_STRING (1, name);
802 SCM_VALIDATE_VECTOR (2, vtable);
803
804 scm_dynwind_begin (0);
805
806 type = g_type_from_name (scm_to_locale_string_dynwind (name));
807 if (type)
808 scm_c_gruntime_error (FUNC_NAME,
809 "There is already a type with this name: ~S",
810 SCM_LIST1 (name));
811
812 length = scm_c_vector_length (vtable);
813
814 for (i = 0; i < length; i++) {
815 SCM this = scm_c_vector_ref (vtable, i);
816
817 SCM_ASSERT ((scm_ilength (this) == 3) &&
818 SCM_SYMBOLP (scm_car (this)) &&
819 scm_is_string (scm_cadr (this)) &&
820 scm_is_unsigned_integer (scm_caddr (this),
821 0, SCM_T_UINT32_MAX),
822 vtable, SCM_ARG2, FUNC_NAME);
823 }
824
825 values = g_new0 (GFlagsValue, length + 1);
826
827 for (i = 0; i < length; i++) {
828 SCM this = scm_c_vector_ref (vtable, i);
829
830 values [i].value_nick = scm_symbol_chars (scm_car (this));
831 values [i].value_name = scm_to_locale_string (scm_cadr (this));
832 values [i].value = scm_to_uint (scm_caddr (this));
833 }
834
835 type = g_flags_register_static (scm_to_locale_string_dynwind (name), values);
836
837 scm_dynwind_end ();
838
839 return SCM_UNSPECIFIED;
840 }
841 #undef FUNC_NAME
842
843
844
845 /**********************************************************************
846 * GEnum and GFlags class support
847 **********************************************************************/
848
849 SCM_DEFINE (scm_genum_class_to_value_table, "genum-class->value-table", 1, 0, 0,
850 (SCM class),
851 "Return a table of the values supported by the enumerated "
852 "@code{<gtype-class>} @var{class}. The return value will be in the "
853 "format described in @code{genum-register-static}.")
854 #define FUNC_NAME s_scm_genum_class_to_value_table
855 {
856 GType gtype;
857 GEnumClass *enum_class;
858 SCM vector;
859 guint i;
860
861 SCM_VALIDATE_GTYPE_CLASS_IS_A (1, class, G_TYPE_ENUM, gtype);
862
863 enum_class = g_type_class_ref (gtype);
864
865 vector = scm_c_make_vector (enum_class->n_values, SCM_UNDEFINED);
866
867 for (i = 0; i < enum_class->n_values; i++) {
868 GEnumValue *current = &enum_class->values [i];
869 SCM this;
870
871 this = scm_list_3 (scm_from_locale_symbol (current->value_nick),
872 scm_from_locale_string (current->value_name),
873 scm_from_int (current->value));
874
875 scm_c_vector_set_x (vector, i, this);
876 }
877
878 g_type_class_unref (enum_class);
879
880 return vector;
881 }
882 #undef FUNC_NAME
883
884 SCM_DEFINE (scm_gflags_class_to_value_table, "gflags-class->value-table", 1, 0, 0,
885 (SCM class),
886 "Return a table of the values supported by the flag "
887 "@code{<gtype-class>} @var{class}. The return value will be in the "
888 "format described in @code{gflags-register-static}.")
889 #define FUNC_NAME s_scm_gflags_class_to_value_table
890 {
891 GType gtype;
892 GFlagsClass *flags_class;
893 SCM vector;
894 guint i;
895
896 SCM_VALIDATE_GTYPE_CLASS_IS_A (1, class, G_TYPE_FLAGS, gtype);
897
898 flags_class = g_type_class_ref (gtype);
899
900 vector = scm_c_make_vector (flags_class->n_values, SCM_UNDEFINED);
901
902 for (i = 0; i < flags_class->n_values; i++) {
903 GFlagsValue *current = &flags_class->values [i];
904 SCM this;
905
906 this = scm_list_3 (scm_from_locale_symbol (current->value_nick),
907 scm_from_locale_string (current->value_name),
908 scm_from_uint (current->value));
909
910 scm_c_vector_set_x (vector, i, this);
911 }
912
913 g_type_class_unref (flags_class);
914
915 return vector;
916 }
917 #undef FUNC_NAME
918
919 gboolean
scm_c_gvalue_holds(SCM maybe_gvalue,GType type)920 scm_c_gvalue_holds (SCM maybe_gvalue, GType type)
921 {
922 return (SCM_GVALUEP (maybe_gvalue)
923 && G_TYPE_CHECK_VALUE_TYPE (scm_c_gvalue_peek_value (maybe_gvalue),
924 type));
925 }
926
927 SCM
scm_c_gvalue_new_from_boxed(GType type,const gpointer boxed)928 scm_c_gvalue_new_from_boxed (GType type, const gpointer boxed)
929 {
930 SCM ret = scm_c_make_gvalue (type);
931 g_value_set_boxed (scm_c_gvalue_peek_value (ret), boxed);
932 return ret;
933 }
934
935 SCM
scm_c_gvalue_new_take_boxed(GType type,gpointer boxed)936 scm_c_gvalue_new_take_boxed (GType type, gpointer boxed)
937 {
938 SCM ret = scm_c_make_gvalue (type);
939 g_value_take_boxed (scm_c_gvalue_peek_value (ret), boxed);
940 return ret;
941 }
942
943 gpointer
scm_c_gvalue_peek_boxed(SCM value)944 scm_c_gvalue_peek_boxed (SCM value)
945 {
946 return g_value_get_boxed (scm_c_gvalue_peek_value (value));
947 }
948
949 gpointer
scm_c_gvalue_dup_boxed(SCM value)950 scm_c_gvalue_dup_boxed (SCM value)
951 {
952 return g_value_dup_boxed (scm_c_gvalue_peek_value (value));
953 }
954
955 GValue*
scm_c_gvalue_dup_value(SCM scm)956 scm_c_gvalue_dup_value (SCM scm)
957 {
958 GValue *ret = g_new0 (GValue, 1);
959 g_value_init (ret, G_VALUE_TYPE (scm_c_gvalue_peek_value (scm)));
960 g_value_copy (scm_c_gvalue_peek_value (scm), ret);
961 return ret;
962 }
963
964 SCM
scm_c_gvalue_from_value(const GValue * value)965 scm_c_gvalue_from_value (const GValue *value)
966 {
967 SCM ret = scm_c_make_gvalue (G_VALUE_TYPE (value));
968 g_value_copy (value, scm_c_gvalue_peek_value (ret));
969 return ret;
970 }
971
972 SCM
scm_c_gvalue_take_value(GValue * value)973 scm_c_gvalue_take_value (GValue *value)
974 {
975 /* erm... suboptimal :) */
976 SCM ret;
977 GValue *trash;
978 ret = scm_c_make_gvalue (G_VALUE_TYPE (value));
979 g_return_val_if_fail (value != NULL, ret);
980 trash = (GValue*)SCM_STRUCT_DATA (ret)[0];
981 SCM_STRUCT_DATA (ret)[0] = (scm_t_bits)value;
982 g_free (trash);
983 return ret;
984 }
985
986
987
988 void
scm_init_gnome_gobject_values(void)989 scm_init_gnome_gobject_values (void)
990 {
991 #ifndef SCM_MAGIC_SNARFER
992 #include "gvalue.x"
993 #endif
994 _allocate_instance =
995 scm_permanent_object (SCM_VARIABLE_REF (scm_c_lookup ("allocate-instance")));
996
997 scm_c_register_gvalue_wrappers (G_TYPE_BOXED_SCM,
998 wrap_boxed_scm, unwrap_boxed_scm);
999 scm_c_register_gvalue_wrappers (G_TYPE_VALUE_ARRAY,
1000 wrap_gvalue_array, unwrap_gvalue_array);
1001 }
1002