1 /* Copyright (C) 1996,1997,1998,1999,2000,2001, 2003, 2004, 2006, 2007, 2008, 2009 Free Software Foundation, Inc.
3 * This library is free software; you can redistribute it and/or
4 * modify it under the terms of the GNU Lesser General Public License
5 * as published by the Free Software Foundation; either version 3 of
6 * the License, or (at your option) any later version.
8 * This library is distributed in the hope that it will be useful, but
9 * WITHOUT ANY WARRANTY; without even the implied warranty of
10 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
11 * Lesser General Public License for more details.
13 * You should have received a copy of the GNU Lesser General Public
14 * License along with this library; if not, write to the Free Software
15 * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
26 #include "libguile/_scm.h"
27 #include "libguile/async.h"
28 #include "libguile/chars.h"
29 #include "libguile/eval.h"
30 #include "libguile/alist.h"
31 #include "libguile/weaks.h"
32 #include "libguile/hashtab.h"
33 #include "libguile/ports.h"
34 #include "libguile/strings.h"
35 #include "libguile/srfi-13.h"
37 #include "libguile/validate.h"
38 #include "libguile/struct.h"
40 #include "libguile/eq.h"
46 #include "libguile/bdw-gc.h"
50 /* A needlessly obscure test. */
51 #define SCM_LAYOUT_TAILP(X) (((X) & 32) == 0) /* R, W or O */
53 static SCM required_vtable_fields
= SCM_BOOL_F
;
54 static SCM required_applicable_fields
= SCM_BOOL_F
;
55 static SCM required_applicable_with_setter_fields
= SCM_BOOL_F
;
56 SCM scm_struct_table
= SCM_BOOL_F
;
59 SCM_DEFINE (scm_make_struct_layout
, "make-struct-layout", 1, 0, 0,
61 "Return a new structure layout object.\n\n"
62 "@var{fields} must be a string made up of pairs of characters\n"
63 "strung together. The first character of each pair describes a field\n"
64 "type, the second a field protection. Allowed types are 'p' for\n"
65 "GC-protected Scheme data, 'u' for unprotected binary data, and 's' for\n"
66 "a field that points to the structure itself. Allowed protections\n"
67 "are 'w' for mutable fields, 'h' for hidden fields, 'r' for read-only\n"
68 "fields, and 'o' for opaque fields.\n\n"
69 "Hidden fields are writable, but they will not consume an initializer arg\n"
70 "passed to @code{make-struct}. They are useful to add slots to a struct\n"
71 "in a way that preserves backward-compatibility with existing calls to\n"
72 "@code{make-struct}, especially for derived vtables.\n\n"
73 "The last field protection specification may be capitalized to indicate\n"
74 "that the field is a tail-array.")
75 #define FUNC_NAME s_scm_make_struct_layout
80 SCM_VALIDATE_STRING (1, fields
);
86 len
= scm_i_string_length (fields
);
88 SCM_MISC_ERROR ("odd length field specification: ~S",
91 for (x
= 0; x
< len
; x
+= 2)
93 switch (c
= scm_i_string_ref (fields
, x
))
104 SCM_MISC_ERROR ("unrecognized field type: ~S",
105 scm_list_1 (SCM_MAKE_CHAR (c
)));
108 switch (c
= scm_i_string_ref (fields
, x
+ 1))
112 if (scm_i_string_ref (fields
, x
) == 's')
113 SCM_MISC_ERROR ("self fields not writable", SCM_EOL
);
120 if (scm_i_string_ref (fields
, x
) == 's')
121 SCM_MISC_ERROR ("self fields not allowed in tail array",
124 SCM_MISC_ERROR ("tail array field must be last field in layout",
128 SCM_MISC_ERROR ("unrecognized ref specification: ~S",
129 scm_list_1 (SCM_MAKE_CHAR (c
)));
132 if (scm_i_string_ref (fields
, x
, 'd'))
134 if (!scm_i_string_ref (fields
, x
+2, '-'))
135 SCM_MISC_ERROR ("missing dash field at position ~A",
136 scm_list_1 (scm_from_int (x
/ 2)));
142 new_sym
= scm_string_to_symbol (fields
);
144 scm_remember_upto_here_1 (fields
);
152 scm_i_struct_inherit_vtable_magic (SCM vtable
, SCM obj
)
153 #define FUNC_NAME "%inherit-vtable-magic"
155 /* Verily, what is the deal here, you ask? Basically, we need to know a couple
156 of properties of structures at runtime. For example, "is this structure a
157 vtable of vtables (a metaclass)?"; also, "is this structure applicable?".
158 Both of these questions also imply a certain layout of the structure. So
159 instead of checking the layout at runtime, what we do is pre-verify the
160 layout -- so that at runtime we can just check the applicable flag and
161 dispatch directly to the Scheme procedure in slot 0.
165 /* verify that obj is a valid vtable */
166 if (scm_is_false (scm_symbol_p (SCM_VTABLE_LAYOUT (obj
))))
167 scm_misc_error (FUNC_NAME
, "invalid layout for new vtable",
168 scm_list_1 (SCM_VTABLE_LAYOUT (obj
)));
170 /* if obj's vtable is compatible with the required vtable (class) layout, it
172 olayout
= scm_symbol_to_string (SCM_VTABLE_LAYOUT (obj
));
173 if (scm_is_true (scm_leq_p (scm_string_length (required_vtable_fields
),
174 scm_string_length (olayout
)))
175 && scm_is_true (scm_string_eq (olayout
, required_vtable_fields
,
177 scm_string_length (required_vtable_fields
),
179 scm_string_length (required_vtable_fields
))))
180 SCM_SET_VTABLE_FLAGS (obj
, SCM_VTABLE_FLAG_VTABLE
);
182 /* finally if obj is an applicable class, verify that its vtable is
183 compatible with the required applicable layout */
184 if (SCM_VTABLE_FLAG_IS_SET (vtable
, SCM_VTABLE_FLAG_SETTER_VTABLE
))
186 if (scm_is_false (scm_string_eq (olayout
, required_applicable_with_setter_fields
,
190 scm_from_size_t (4))))
191 scm_misc_error (FUNC_NAME
, "invalid applicable-with-setter struct layout",
192 scm_list_1 (olayout
));
193 SCM_SET_VTABLE_FLAGS (obj
, SCM_VTABLE_FLAG_APPLICABLE
| SCM_VTABLE_FLAG_SETTER
);
195 else if (SCM_VTABLE_FLAG_IS_SET (vtable
, SCM_VTABLE_FLAG_APPLICABLE_VTABLE
))
197 if (scm_is_false (scm_string_eq (olayout
, required_applicable_fields
,
201 scm_from_size_t (2))))
202 scm_misc_error (FUNC_NAME
, "invalid applicable struct layout",
203 scm_list_1 (olayout
));
204 SCM_SET_VTABLE_FLAGS (obj
, SCM_VTABLE_FLAG_APPLICABLE
);
211 scm_struct_init (SCM handle
, SCM layout
, size_t n_tail
,
212 size_t n_inits
, scm_t_bits
*inits
)
214 scm_t_wchar prot
= 0;
215 int n_fields
= scm_i_symbol_length (layout
) / 2;
218 size_t inits_idx
= 0;
219 scm_t_bits
*mem
= SCM_STRUCT_DATA (handle
);
227 prot
= scm_i_symbol_ref (layout
, i
+1);
228 if (SCM_LAYOUT_TAILP (prot
))
231 prot
= prot
== 'R' ? 'r' : prot
== 'W' ? 'w' : 'o';
232 *mem
++ = (scm_t_bits
)n_tail
;
233 n_fields
+= n_tail
- 1;
238 switch (scm_i_symbol_ref (layout
, i
))
241 if ((prot
!= 'r' && prot
!= 'w') || inits_idx
== n_inits
)
245 *mem
= scm_to_ulong (SCM_PACK (inits
[inits_idx
]));
251 if ((prot
!= 'r' && prot
!= 'w') || inits_idx
== n_inits
)
252 *mem
= SCM_UNPACK (SCM_BOOL_F
);
255 *mem
= inits
[inits_idx
];
262 *mem
= SCM_UNPACK (handle
);
272 SCM_DEFINE (scm_struct_p
, "struct?", 1, 0, 0,
274 "Return @code{#t} iff @var{x} is a structure object, else\n"
276 #define FUNC_NAME s_scm_struct_p
278 return scm_from_bool(SCM_STRUCTP (x
));
282 SCM_DEFINE (scm_struct_vtable_p
, "struct-vtable?", 1, 0, 0,
284 "Return @code{#t} iff @var{x} is a vtable structure.")
285 #define FUNC_NAME s_scm_struct_vtable_p
289 && SCM_STRUCT_VTABLE_FLAG_IS_SET (x
, SCM_VTABLE_FLAG_VTABLE
));
294 /* Finalization: invoke the finalizer of the struct pointed to by PTR. */
296 struct_finalizer_trampoline (GC_PTR ptr
, GC_PTR unused_data
)
298 SCM obj
= PTR2SCM (ptr
);
299 scm_t_struct_finalize finalize
= SCM_STRUCT_FINALIZER (obj
);
305 /* All struct data must be allocated at an address whose bottom three
306 bits are zero. This is because the tag for a struct lives in the
307 bottom three bits of the struct's car, and the upper bits point to
308 the data of its vtable, which is a struct itself. Thus, if the
309 address of that data doesn't end in three zeros, tagging it will
312 I suppose we should make it clear here that, the data must be 8-byte aligned,
313 *within* the struct, and the struct itself should be 8-byte aligned. In
314 practice we ensure this because the data starts two words into a struct.
316 This function allocates an 8-byte aligned block of memory, whose first word
317 points to the given vtable data, then a data pointer, then n_words of data.
320 scm_i_alloc_struct (scm_t_bits
*vtable_data
, int n_words
, const char *what
)
323 ret
= (scm_t_bits
)scm_gc_malloc (sizeof (scm_t_bits
) * (n_words
+ 2), "struct");
324 SCM_SET_CELL_WORD_0 (SCM_PACK (ret
), (scm_t_bits
)vtable_data
| scm_tc3_struct
);
325 SCM_SET_CELL_WORD_1 (SCM_PACK (ret
),
326 (scm_t_bits
)SCM_CELL_OBJECT_LOC (SCM_PACK (ret
), 2));
328 /* vtable_data can be null when making a vtable vtable */
329 if (vtable_data
&& vtable_data
[scm_vtable_index_instance_finalize
])
331 /* Register a finalizer for the newly created instance. */
332 GC_finalization_proc prev_finalizer
;
333 GC_PTR prev_finalizer_data
;
334 GC_REGISTER_FINALIZER_NO_ORDER ((void*)ret
,
335 struct_finalizer_trampoline
,
338 &prev_finalizer_data
);
341 return SCM_PACK (ret
);
346 scm_c_make_structv (SCM vtable
, size_t n_tail
, size_t n_init
, scm_t_bits
*init
)
347 #define FUNC_NAME "make-struct"
353 SCM_VALIDATE_VTABLE (1, vtable
);
355 layout
= SCM_VTABLE_LAYOUT (vtable
);
356 basic_size
= scm_i_symbol_length (layout
) / 2;
360 SCM layout_str
, last_char
;
365 SCM_MISC_ERROR ("tail array not allowed unless layout ends R, W, or O", SCM_EOL
);
368 layout_str
= scm_symbol_to_string (layout
);
369 last_char
= scm_string_ref (layout_str
,
370 scm_from_size_t (2 * basic_size
- 1));
371 if (! SCM_LAYOUT_TAILP (SCM_CHAR (last_char
)))
375 obj
= scm_i_alloc_struct (SCM_STRUCT_DATA (vtable
), basic_size
+ n_tail
,
378 scm_struct_init (obj
, layout
, n_tail
, n_init
, init
);
380 /* only check things and inherit magic if the layout was passed as an initarg.
381 something of a hack, but it's for back-compatibility. */
382 if (SCM_VTABLE_FLAG_IS_SET (vtable
, SCM_VTABLE_FLAG_VTABLE
)
383 && scm_is_true (SCM_VTABLE_LAYOUT (obj
)))
384 scm_i_struct_inherit_vtable_magic (vtable
, obj
);
391 scm_c_make_struct (SCM vtable
, size_t n_tail
, size_t n_init
, scm_t_bits init
, ...)
397 v
= alloca (sizeof (scm_t_bits
) * n_init
);
399 va_start (foo
, init
);
400 for (i
= 0; i
< n_init
; i
++)
403 init
= va_arg (foo
, scm_t_bits
);
407 return scm_c_make_structv (vtable
, n_tail
, n_init
, v
);
410 SCM_DEFINE (scm_make_struct
, "make-struct", 2, 0, 1,
411 (SCM vtable
, SCM tail_array_size
, SCM init
),
412 "Create a new structure.\n\n"
413 "@var{type} must be a vtable structure (@pxref{Vtables}).\n\n"
414 "@var{tail-elts} must be a non-negative integer. If the layout\n"
415 "specification indicated by @var{type} includes a tail-array,\n"
416 "this is the number of elements allocated to that array.\n\n"
417 "The @var{init1}, @dots{} are optional arguments describing how\n"
418 "successive fields of the structure should be initialized. Only fields\n"
419 "with protection 'r' or 'w' can be initialized, except for fields of\n"
420 "type 's', which are automatically initialized to point to the new\n"
421 "structure itself. Fields with protection 'o' can not be initialized by\n"
422 "Scheme programs.\n\n"
423 "If fewer optional arguments than initializable fields are supplied,\n"
424 "fields of type 'p' get default value #f while fields of type 'u' are\n"
425 "initialized to 0.\n\n"
426 "For more information, see the documentation for @code{make-vtable-vtable}.")
427 #define FUNC_NAME s_scm_make_struct
433 SCM_VALIDATE_VTABLE (1, vtable
);
434 ilen
= scm_ilength (init
);
436 SCM_MISC_ERROR ("Rest arguments do not form a proper list.", SCM_EOL
);
438 n_init
= (size_t)ilen
;
440 /* best to use alloca, but init could be big, so hack to avoid a possible
443 v
= alloca (n_init
* sizeof(scm_t_bits
));
445 v
= scm_gc_malloc (n_init
* sizeof(scm_t_bits
), "struct");
447 for (i
= 0; i
< n_init
; i
++, init
= SCM_CDR (init
))
448 v
[i
] = SCM_UNPACK (SCM_CAR (init
));
450 return scm_c_make_structv (vtable
, scm_to_size_t (tail_array_size
), n_init
, v
);
456 SCM_DEFINE (scm_make_vtable_vtable
, "make-vtable-vtable", 2, 0, 1,
457 (SCM user_fields
, SCM tail_array_size
, SCM init
),
458 "Return a new, self-describing vtable structure.\n\n"
459 "@var{user-fields} is a string describing user defined fields of the\n"
460 "vtable beginning at index @code{vtable-offset-user}\n"
461 "(see @code{make-struct-layout}).\n\n"
462 "@var{tail-size} specifies the size of the tail-array (if any) of\n"
464 "@var{init1}, @dots{} are the optional initializers for the fields of\n"
466 "Vtables have one initializable system field---the struct printer.\n"
467 "This field comes before the user fields in the initializers passed\n"
468 "to @code{make-vtable-vtable} and @code{make-struct}, and thus works as\n"
469 "a third optional argument to @code{make-vtable-vtable} and a fourth to\n"
470 "@code{make-struct} when creating vtables:\n\n"
471 "If the value is a procedure, it will be called instead of the standard\n"
472 "printer whenever a struct described by this vtable is printed.\n"
473 "The procedure will be called with arguments STRUCT and PORT.\n\n"
474 "The structure of a struct is described by a vtable, so the vtable is\n"
475 "in essence the type of the struct. The vtable is itself a struct with\n"
476 "a vtable. This could go on forever if it weren't for the\n"
477 "vtable-vtables which are self-describing vtables, and thus terminate\n"
479 "There are several potential ways of using structs, but the standard\n"
480 "one is to use three kinds of structs, together building up a type\n"
481 "sub-system: one vtable-vtable working as the root and one or several\n"
482 "\"types\", each with a set of \"instances\". (The vtable-vtable should be\n"
483 "compared to the class <class> which is the class of itself.)\n\n"
485 "(define ball-root (make-vtable-vtable \"pr\" 0))\n\n"
486 "(define (make-ball-type ball-color)\n"
487 " (make-struct ball-root 0\n"
488 " (make-struct-layout \"pw\")\n"
489 " (lambda (ball port)\n"
490 " (format port \"#<a ~A ball owned by ~A>\"\n"
494 "(define (color ball) (struct-ref (struct-vtable ball) vtable-offset-user))\n"
495 "(define (owner ball) (struct-ref ball 0))\n\n"
496 "(define red (make-ball-type 'red))\n"
497 "(define green (make-ball-type 'green))\n\n"
498 "(define (make-ball type owner) (make-struct type 0 owner))\n\n"
499 "(define ball (make-ball green 'Nisse))\n"
500 "ball @result{} #<a green ball owned by Nisse>\n"
502 #define FUNC_NAME s_scm_make_vtable_vtable
507 size_t n_tail
, i
, n_init
;
512 SCM_VALIDATE_STRING (1, user_fields
);
513 ilen
= scm_ilength (init
);
515 SCM_MISC_ERROR ("Rest arguments do not form a proper list.", SCM_EOL
);
517 n_init
= (size_t)ilen
+ 1; /* + 1 for the layout */
519 /* best to use alloca, but init could be big, so hack to avoid a possible
522 v
= alloca (n_init
* sizeof(scm_t_bits
));
524 v
= scm_gc_malloc (n_init
* sizeof(scm_t_bits
), "struct");
526 fields
= scm_string_append (scm_list_2 (required_vtable_fields
,
528 layout
= scm_make_struct_layout (fields
);
529 basic_size
= scm_i_symbol_length (layout
) / 2;
530 n_tail
= scm_to_size_t (tail_array_size
);
533 v
[i
++] = SCM_UNPACK (layout
);
534 for (; i
< n_init
; i
++, init
= SCM_CDR (init
))
535 v
[i
] = SCM_UNPACK (SCM_CAR (init
));
537 SCM_CRITICAL_SECTION_START
;
538 obj
= scm_i_alloc_struct (NULL
, basic_size
+ n_tail
, "struct");
539 /* magic magic magic */
540 SCM_SET_CELL_WORD_0 (obj
, (scm_t_bits
)SCM_STRUCT_DATA (obj
) | scm_tc3_struct
);
541 SCM_CRITICAL_SECTION_END
;
542 scm_struct_init (obj
, layout
, n_tail
, n_init
, v
);
543 SCM_SET_VTABLE_FLAGS (obj
, SCM_VTABLE_FLAG_VTABLE
);
549 static SCM scm_i_vtable_vtable_no_extra_fields
;
551 SCM_DEFINE (scm_make_vtable
, "make-vtable", 1, 1, 0,
552 (SCM fields
, SCM printer
),
553 "Create a vtable, for creating structures with the given\n"
556 "The optional @var{printer} argument is a function to be called\n"
557 "@code{(@var{printer} struct port)} on the structures created.\n"
558 "It should look at @var{struct} and write to @var{port}.")
559 #define FUNC_NAME s_scm_make_vtable
561 if (SCM_UNBNDP (printer
))
562 printer
= SCM_BOOL_F
;
564 return scm_make_struct (scm_i_vtable_vtable_no_extra_fields
, SCM_INUM0
,
565 scm_list_2 (scm_make_struct_layout (fields
),
571 /* Return true if S1 and S2 are equal structures, i.e., if their vtable and
572 contents are the same. Field protections are honored. Thus, it is an
573 error to test the equality of structures that contain opaque fields. */
575 scm_i_struct_equalp (SCM s1
, SCM s2
)
576 #define FUNC_NAME "scm_i_struct_equalp"
578 SCM vtable1
, vtable2
, layout
;
579 size_t struct_size
, field_num
;
581 SCM_VALIDATE_STRUCT (1, s1
);
582 SCM_VALIDATE_STRUCT (2, s2
);
584 vtable1
= SCM_STRUCT_VTABLE (s1
);
585 vtable2
= SCM_STRUCT_VTABLE (s2
);
587 if (!scm_is_eq (vtable1
, vtable2
))
590 layout
= SCM_STRUCT_LAYOUT (s1
);
591 struct_size
= scm_i_symbol_length (layout
) / 2;
593 for (field_num
= 0; field_num
< struct_size
; field_num
++)
598 /* We have to use `scm_struct_ref ()' here so that fields are accessed
599 consistently, notably wrt. field types and access rights. */
600 s_field_num
= scm_from_size_t (field_num
);
601 field1
= scm_struct_ref (s1
, s_field_num
);
602 field2
= scm_struct_ref (s2
, s_field_num
);
604 /* Self-referencing fields (type `s') must be skipped to avoid infinite
606 if (!(scm_is_eq (field1
, s1
) && (scm_is_eq (field2
, s2
))))
607 if (scm_is_false (scm_equal_p (field1
, field2
)))
611 /* FIXME: Tail elements should be tested for equality. */
621 SCM_DEFINE (scm_struct_ref
, "struct-ref", 2, 0, 0,
622 (SCM handle
, SCM pos
),
623 "Access the @var{n}th field of @var{struct}.\n\n"
624 "If the field is of type 'p', then it can be set to an arbitrary value.\n\n"
625 "If the field is of type 'u', then it can only be set to a non-negative\n"
626 "integer value small enough to fit in one machine word.")
627 #define FUNC_NAME s_scm_struct_ref
629 SCM answer
= SCM_UNDEFINED
;
635 scm_t_wchar field_type
= 0;
638 SCM_VALIDATE_STRUCT (1, handle
);
640 layout
= SCM_STRUCT_LAYOUT (handle
);
641 data
= SCM_STRUCT_DATA (handle
);
642 p
= scm_to_size_t (pos
);
644 layout_len
= scm_i_symbol_length (layout
);
645 n_fields
= layout_len
/ 2;
646 if (SCM_LAYOUT_TAILP (scm_i_symbol_ref (layout
, layout_len
- 1)))
647 n_fields
+= data
[n_fields
- 1];
649 SCM_ASSERT_RANGE(1, pos
, p
< n_fields
);
651 if (p
* 2 < layout_len
)
654 field_type
= scm_i_symbol_ref (layout
, p
* 2);
655 ref
= scm_i_symbol_ref (layout
, p
* 2 + 1);
656 if ((ref
!= 'r') && (ref
!= 'w') && (ref
!= 'h'))
658 if ((ref
== 'R') || (ref
== 'W'))
661 SCM_MISC_ERROR ("ref denied for field ~A", scm_list_1 (pos
));
664 else if (scm_i_symbol_ref (layout
, layout_len
- 1) != 'O')
665 field_type
= scm_i_symbol_ref(layout
, layout_len
- 2);
667 SCM_MISC_ERROR ("ref denied for field ~A", scm_list_1 (pos
));
672 answer
= scm_from_ulong (data
[p
]);
677 answer
= scm_from_long (data
[p
]);
681 answer
= scm_make_real (*((double *)&(data
[p
])));
687 answer
= SCM_PACK (data
[p
]);
692 SCM_MISC_ERROR ("unrecognized field type: ~S",
693 scm_list_1 (SCM_MAKE_CHAR (field_type
)));
701 SCM_DEFINE (scm_struct_set_x
, "struct-set!", 3, 0, 0,
702 (SCM handle
, SCM pos
, SCM val
),
703 "Set the slot of the structure @var{handle} with index @var{pos}\n"
704 "to @var{val}. Signal an error if the slot can not be written\n"
706 #define FUNC_NAME s_scm_struct_set_x
713 scm_t_wchar field_type
= 0;
715 SCM_VALIDATE_STRUCT (1, handle
);
717 layout
= SCM_STRUCT_LAYOUT (handle
);
718 data
= SCM_STRUCT_DATA (handle
);
719 p
= scm_to_size_t (pos
);
721 layout_len
= scm_i_symbol_length (layout
);
722 n_fields
= layout_len
/ 2;
723 if (SCM_LAYOUT_TAILP (scm_i_symbol_ref (layout
, layout_len
- 1)))
724 n_fields
+= data
[n_fields
- 1];
726 SCM_ASSERT_RANGE (1, pos
, p
< n_fields
);
728 if (p
* 2 < layout_len
)
731 field_type
= scm_i_symbol_ref (layout
, p
* 2);
732 set_x
= scm_i_symbol_ref (layout
, p
* 2 + 1);
733 if (set_x
!= 'w' && set_x
!= 'h')
734 SCM_MISC_ERROR ("set! denied for field ~A", scm_list_1 (pos
));
736 else if (scm_i_symbol_ref (layout
, layout_len
- 1) == 'W')
737 field_type
= scm_i_symbol_ref (layout
, layout_len
- 2);
739 SCM_MISC_ERROR ("set! denied for field ~A", scm_list_1 (pos
));
744 data
[p
] = SCM_NUM2ULONG (3, val
);
749 data
[p
] = SCM_NUM2LONG (3, val
);
753 *((double *)&(data
[p
])) = scm_num2dbl (val
, (char *)SCM_ARG3
);
758 data
[p
] = SCM_UNPACK (val
);
762 SCM_MISC_ERROR ("self fields immutable", SCM_EOL
);
765 SCM_MISC_ERROR ("unrecognized field type: ~S",
766 scm_list_1 (SCM_MAKE_CHAR (field_type
)));
774 SCM_DEFINE (scm_struct_vtable
, "struct-vtable", 1, 0, 0,
776 "Return the vtable structure that describes the type of @var{struct}.")
777 #define FUNC_NAME s_scm_struct_vtable
779 SCM_VALIDATE_STRUCT (1, handle
);
780 return SCM_STRUCT_VTABLE (handle
);
785 SCM_DEFINE (scm_struct_vtable_tag
, "struct-vtable-tag", 1, 0, 0,
787 "Return the vtable tag of the structure @var{handle}.")
788 #define FUNC_NAME s_scm_struct_vtable_tag
790 SCM_VALIDATE_VTABLE (1, handle
);
791 return scm_from_ulong (((unsigned long)SCM_STRUCT_DATA (handle
)) >> 3);
795 /* {Associating names and classes with vtables}
797 * The name of a vtable should probably be stored as a slot. This is
798 * a backward compatible solution until agreement has been achieved on
799 * how to associate names with vtables.
803 scm_struct_ihashq (SCM obj
, unsigned long n
, void *closure
)
805 /* The length of the hash table should be a relative prime it's not
806 necessary to shift down the address. */
807 return SCM_UNPACK (obj
) % n
;
811 scm_struct_create_handle (SCM obj
)
813 SCM handle
= scm_hash_fn_create_handle_x (scm_struct_table
,
817 (scm_t_assoc_fn
) scm_sloppy_assq
,
819 if (scm_is_false (SCM_CDR (handle
)))
820 SCM_SETCDR (handle
, scm_cons (SCM_BOOL_F
, SCM_BOOL_F
));
824 SCM_DEFINE (scm_struct_vtable_name
, "struct-vtable-name", 1, 0, 0,
826 "Return the name of the vtable @var{vtable}.")
827 #define FUNC_NAME s_scm_struct_vtable_name
829 SCM_VALIDATE_VTABLE (1, vtable
);
830 return SCM_STRUCT_TABLE_NAME (SCM_CDR (scm_struct_create_handle (vtable
)));
834 SCM_DEFINE (scm_set_struct_vtable_name_x
, "set-struct-vtable-name!", 2, 0, 0,
835 (SCM vtable
, SCM name
),
836 "Set the name of the vtable @var{vtable} to @var{name}.")
837 #define FUNC_NAME s_scm_set_struct_vtable_name_x
839 SCM_VALIDATE_VTABLE (1, vtable
);
840 SCM_VALIDATE_SYMBOL (2, name
);
841 SCM_SET_STRUCT_TABLE_NAME (SCM_CDR (scm_struct_create_handle (vtable
)),
843 return SCM_UNSPECIFIED
;
851 scm_print_struct (SCM exp
, SCM port
, scm_print_state
*pstate
)
853 if (scm_is_true (scm_procedure_p (SCM_STRUCT_PRINTER (exp
))))
854 scm_printer_apply (SCM_STRUCT_PRINTER (exp
), exp
, port
, pstate
);
857 SCM vtable
= SCM_STRUCT_VTABLE (exp
);
858 SCM name
= scm_struct_vtable_name (vtable
);
859 scm_puts ("#<", port
);
860 if (scm_is_true (name
))
862 scm_display (name
, port
);
863 scm_putc (' ', port
);
867 if (SCM_VTABLE_FLAG_IS_SET (vtable
, SCM_VTABLE_FLAG_VTABLE
))
868 scm_puts ("vtable:", port
);
870 scm_puts ("struct:", port
);
871 scm_uintprint (SCM_UNPACK (vtable
), 16, port
);
872 scm_putc (' ', port
);
873 scm_write (SCM_VTABLE_LAYOUT (vtable
), port
);
874 scm_putc (' ', port
);
876 scm_uintprint (SCM_UNPACK (exp
), 16, port
);
878 if (SCM_STRUCT_APPLICABLE_P (exp
))
880 if (scm_is_true (SCM_STRUCT_PROCEDURE (exp
)))
882 scm_puts (" proc: ", port
);
883 if (scm_is_true (scm_procedure_p (SCM_STRUCT_PROCEDURE (exp
))))
884 scm_write (SCM_STRUCT_PROCEDURE (exp
), port
);
886 scm_puts ("(not a procedure?)", port
);
888 if (SCM_STRUCT_SETTER_P (exp
))
890 scm_puts (" setter: ", port
);
891 scm_write (SCM_STRUCT_SETTER (exp
), port
);
894 scm_putc ('>', port
);
901 SCM scm_applicable_struct_vtable_vtable
;
902 SCM scm_applicable_struct_with_setter_vtable_vtable
;
904 GC_REGISTER_DISPLACEMENT (2*sizeof(scm_t_bits
)); /* for the self data pointer */
905 GC_REGISTER_DISPLACEMENT (2*sizeof(scm_t_bits
)
906 + scm_tc3_struct
); /* for the vtable data pointer */
908 scm_struct_table
= scm_make_weak_key_hash_table (scm_from_int (31));
909 required_vtable_fields
= scm_from_locale_string (SCM_VTABLE_BASE_LAYOUT
);
910 required_applicable_fields
= scm_from_locale_string (SCM_APPLICABLE_BASE_LAYOUT
);
911 required_applicable_with_setter_fields
= scm_from_locale_string (SCM_APPLICABLE_WITH_SETTER_BASE_LAYOUT
);
913 scm_i_vtable_vtable_no_extra_fields
=
914 scm_make_vtable_vtable (scm_nullstr
, SCM_INUM0
, SCM_EOL
);
916 scm_applicable_struct_vtable_vtable
=
917 scm_make_struct (scm_i_vtable_vtable_no_extra_fields
, SCM_INUM0
,
918 scm_list_1 (scm_make_struct_layout (required_vtable_fields
)));
919 SCM_SET_VTABLE_FLAGS (scm_applicable_struct_vtable_vtable
,
920 SCM_VTABLE_FLAG_APPLICABLE_VTABLE
);
921 scm_c_define ("<applicable-struct-vtable>", scm_applicable_struct_vtable_vtable
);
923 scm_applicable_struct_with_setter_vtable_vtable
=
924 scm_make_struct (scm_i_vtable_vtable_no_extra_fields
, SCM_INUM0
,
925 scm_list_1 (scm_make_struct_layout (required_vtable_fields
)));
926 SCM_SET_VTABLE_FLAGS (scm_applicable_struct_with_setter_vtable_vtable
,
927 SCM_VTABLE_FLAG_APPLICABLE_VTABLE
| SCM_VTABLE_FLAG_SETTER_VTABLE
);
928 scm_c_define ("<applicable-struct-with-setter-vtable>", scm_applicable_struct_with_setter_vtable_vtable
);
930 scm_c_define ("vtable-index-layout", scm_from_int (scm_vtable_index_layout
));
931 scm_c_define ("vtable-index-printer",
932 scm_from_int (scm_vtable_index_instance_printer
));
933 scm_c_define ("vtable-offset-user", scm_from_int (scm_vtable_offset_user
));
934 #include "libguile/struct.x"