1 /* Copyright (C) 1996,1997,1998,1999,2000,2001, 2003, 2004, 2006, 2007, 2008, 2009, 2010 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
27 #include "libguile/_scm.h"
28 #include "libguile/async.h"
29 #include "libguile/chars.h"
30 #include "libguile/eval.h"
31 #include "libguile/alist.h"
32 #include "libguile/weaks.h"
33 #include "libguile/hashtab.h"
34 #include "libguile/ports.h"
35 #include "libguile/strings.h"
36 #include "libguile/srfi-13.h"
38 #include "libguile/validate.h"
39 #include "libguile/struct.h"
41 #include "libguile/eq.h"
47 #include "libguile/bdw-gc.h"
51 /* A needlessly obscure test. */
52 #define SCM_LAYOUT_TAILP(X) (((X) & 32) == 0) /* R, W or O */
54 static SCM required_vtable_fields
= SCM_BOOL_F
;
55 static SCM required_applicable_fields
= SCM_BOOL_F
;
56 static SCM required_applicable_with_setter_fields
= SCM_BOOL_F
;
57 SCM scm_struct_table
= SCM_BOOL_F
;
58 SCM scm_applicable_struct_vtable_vtable
;
59 SCM scm_applicable_struct_with_setter_vtable_vtable
;
60 SCM scm_standard_vtable_vtable
;
64 SCM_DEFINE (scm_make_struct_layout
, "make-struct-layout", 1, 0, 0,
66 "Return a new structure layout object.\n\n"
67 "@var{fields} must be a string made up of pairs of characters\n"
68 "strung together. The first character of each pair describes a field\n"
69 "type, the second a field protection. Allowed types are 'p' for\n"
70 "GC-protected Scheme data, 'u' for unprotected binary data, and 's' for\n"
71 "a field that points to the structure itself. Allowed protections\n"
72 "are 'w' for mutable fields, 'h' for hidden fields, 'r' for read-only\n"
73 "fields, and 'o' for opaque fields.\n\n"
74 "Hidden fields are writable, but they will not consume an initializer arg\n"
75 "passed to @code{make-struct}. They are useful to add slots to a struct\n"
76 "in a way that preserves backward-compatibility with existing calls to\n"
77 "@code{make-struct}, especially for derived vtables.\n\n"
78 "The last field protection specification may be capitalized to indicate\n"
79 "that the field is a tail-array.")
80 #define FUNC_NAME s_scm_make_struct_layout
85 SCM_VALIDATE_STRING (1, fields
);
91 len
= scm_i_string_length (fields
);
93 SCM_MISC_ERROR ("odd length field specification: ~S",
96 for (x
= 0; x
< len
; x
+= 2)
98 switch (c
= scm_i_string_ref (fields
, x
))
109 SCM_MISC_ERROR ("unrecognized field type: ~S",
110 scm_list_1 (SCM_MAKE_CHAR (c
)));
113 switch (c
= scm_i_string_ref (fields
, x
+ 1))
117 if (scm_i_string_ref (fields
, x
) == 's')
118 SCM_MISC_ERROR ("self fields not writable", SCM_EOL
);
125 if (scm_i_string_ref (fields
, x
) == 's')
126 SCM_MISC_ERROR ("self fields not allowed in tail array",
129 SCM_MISC_ERROR ("tail array field must be last field in layout",
133 SCM_MISC_ERROR ("unrecognized ref specification: ~S",
134 scm_list_1 (SCM_MAKE_CHAR (c
)));
137 if (scm_i_string_ref (fields
, x
, 'd'))
139 if (!scm_i_string_ref (fields
, x
+2, '-'))
140 SCM_MISC_ERROR ("missing dash field at position ~A",
141 scm_list_1 (scm_from_int (x
/ 2)));
147 new_sym
= scm_string_to_symbol (fields
);
149 scm_remember_upto_here_1 (fields
);
155 /* Check whether VTABLE instances have a simple layout (i.e., either only "pr"
156 or only "pw" fields) and update its flags accordingly. */
158 set_vtable_layout_flags (SCM vtable
)
162 const char *c_layout
;
163 scm_t_bits flags
= SCM_VTABLE_FLAG_SIMPLE
;
165 layout
= SCM_VTABLE_LAYOUT (vtable
);
166 c_layout
= scm_i_symbol_chars (layout
);
167 len
= scm_i_symbol_length (layout
);
169 assert (len
% 2 == 0);
171 /* Update FLAGS according to LAYOUT. */
173 field
< len
&& flags
& SCM_VTABLE_FLAG_SIMPLE
;
176 if (c_layout
[field
] != 'p')
179 switch (c_layout
[field
+ 1])
183 if (!(flags
& SCM_VTABLE_FLAG_SIMPLE_RW
) && field
> 0)
184 /* There's a mixture of `w' and `r' flags. */
187 flags
|= SCM_VTABLE_FLAG_SIMPLE_RW
;
192 if (flags
& SCM_VTABLE_FLAG_SIMPLE_RW
)
193 /* There's a mixture of `w' and `r' flags. */
202 if (flags
& SCM_VTABLE_FLAG_SIMPLE
)
204 /* VTABLE is simple so update its flags and record the size of its
206 SCM_SET_VTABLE_FLAGS (vtable
, flags
);
207 SCM_STRUCT_DATA_SET (vtable
, scm_vtable_index_size
, len
/ 2);
211 /* Have OBJ, a newly created vtable, inherit flags from VTABLE. VTABLE is a
212 vtable-vtable and OBJ is an instance of VTABLE. */
214 scm_i_struct_inherit_vtable_magic (SCM vtable
, SCM obj
)
215 #define FUNC_NAME "%inherit-vtable-magic"
217 /* Verily, what is the deal here, you ask? Basically, we need to know a couple
218 of properties of structures at runtime. For example, "is this structure a
219 vtable of vtables (a metaclass)?"; also, "is this structure applicable?".
220 Both of these questions also imply a certain layout of the structure. So
221 instead of checking the layout at runtime, what we do is pre-verify the
222 layout -- so that at runtime we can just check the applicable flag and
223 dispatch directly to the Scheme procedure in slot 0. */
226 /* Verify that OBJ is a valid vtable. */
227 if (scm_is_false (scm_symbol_p (SCM_VTABLE_LAYOUT (obj
))))
228 scm_misc_error (FUNC_NAME
, "invalid layout for new vtable",
229 scm_list_1 (SCM_VTABLE_LAYOUT (obj
)));
231 set_vtable_layout_flags (obj
);
233 /* If OBJ's vtable is compatible with the required vtable (class) layout, it
235 olayout
= scm_symbol_to_string (SCM_VTABLE_LAYOUT (obj
));
236 if (scm_is_true (scm_leq_p (scm_string_length (required_vtable_fields
),
237 scm_string_length (olayout
)))
238 && scm_is_true (scm_string_eq (olayout
, required_vtable_fields
,
240 scm_string_length (required_vtable_fields
),
242 scm_string_length (required_vtable_fields
))))
243 SCM_SET_VTABLE_FLAGS (obj
, SCM_VTABLE_FLAG_VTABLE
);
245 /* Finally, if OBJ is an applicable class, verify that its vtable is
246 compatible with the required applicable layout. */
247 if (SCM_VTABLE_FLAG_IS_SET (vtable
, SCM_VTABLE_FLAG_SETTER_VTABLE
))
249 if (scm_is_false (scm_string_eq (olayout
, required_applicable_with_setter_fields
,
253 scm_from_size_t (4))))
254 scm_misc_error (FUNC_NAME
, "invalid applicable-with-setter struct layout",
255 scm_list_1 (olayout
));
256 SCM_SET_VTABLE_FLAGS (obj
, SCM_VTABLE_FLAG_APPLICABLE
| SCM_VTABLE_FLAG_SETTER
);
258 else if (SCM_VTABLE_FLAG_IS_SET (vtable
, SCM_VTABLE_FLAG_APPLICABLE_VTABLE
))
260 if (scm_is_false (scm_string_eq (olayout
, required_applicable_fields
,
264 scm_from_size_t (2))))
265 scm_misc_error (FUNC_NAME
, "invalid applicable struct layout",
266 scm_list_1 (olayout
));
267 SCM_SET_VTABLE_FLAGS (obj
, SCM_VTABLE_FLAG_APPLICABLE
);
274 scm_struct_init (SCM handle
, SCM layout
, size_t n_tail
,
275 size_t n_inits
, scm_t_bits
*inits
)
280 vtable
= SCM_STRUCT_VTABLE (handle
);
281 mem
= SCM_STRUCT_DATA (handle
);
283 if (SCM_UNPACK (vtable
) != 0
284 && SCM_VTABLE_FLAG_IS_SET (vtable
, SCM_VTABLE_FLAG_SIMPLE
)
286 && n_inits
== SCM_STRUCT_DATA_REF (vtable
, scm_vtable_index_size
))
287 /* The fast path: HANDLE has N_INITS "p" fields. */
288 memcpy (mem
, inits
, n_inits
* sizeof (SCM
));
291 scm_t_wchar prot
= 0;
292 int n_fields
= scm_i_symbol_length (layout
) / 2;
295 size_t inits_idx
= 0;
303 prot
= scm_i_symbol_ref (layout
, i
+1);
304 if (SCM_LAYOUT_TAILP (prot
))
307 prot
= prot
== 'R' ? 'r' : prot
== 'W' ? 'w' : 'o';
308 *mem
++ = (scm_t_bits
)n_tail
;
309 n_fields
+= n_tail
- 1;
314 switch (scm_i_symbol_ref (layout
, i
))
317 if ((prot
!= 'r' && prot
!= 'w') || inits_idx
== n_inits
)
321 *mem
= scm_to_ulong (SCM_PACK (inits
[inits_idx
]));
327 if ((prot
!= 'r' && prot
!= 'w') || inits_idx
== n_inits
)
328 *mem
= SCM_UNPACK (SCM_BOOL_F
);
331 *mem
= inits
[inits_idx
];
338 *mem
= SCM_UNPACK (handle
);
349 SCM_DEFINE (scm_struct_p
, "struct?", 1, 0, 0,
351 "Return @code{#t} iff @var{x} is a structure object, else\n"
353 #define FUNC_NAME s_scm_struct_p
355 return scm_from_bool(SCM_STRUCTP (x
));
359 SCM_DEFINE (scm_struct_vtable_p
, "struct-vtable?", 1, 0, 0,
361 "Return @code{#t} iff @var{x} is a vtable structure.")
362 #define FUNC_NAME s_scm_struct_vtable_p
366 && SCM_STRUCT_VTABLE_FLAG_IS_SET (x
, SCM_VTABLE_FLAG_VTABLE
));
371 /* Finalization: invoke the finalizer of the struct pointed to by PTR. */
373 struct_finalizer_trampoline (GC_PTR ptr
, GC_PTR unused_data
)
375 SCM obj
= PTR2SCM (ptr
);
376 scm_t_struct_finalize finalize
= SCM_STRUCT_FINALIZER (obj
);
382 /* All struct data must be allocated at an address whose bottom three
383 bits are zero. This is because the tag for a struct lives in the
384 bottom three bits of the struct's car, and the upper bits point to
385 the data of its vtable, which is a struct itself. Thus, if the
386 address of that data doesn't end in three zeros, tagging it will
389 I suppose we should make it clear here that, the data must be 8-byte aligned,
390 *within* the struct, and the struct itself should be 8-byte aligned. In
391 practice we ensure this because the data starts two words into a struct.
393 This function allocates an 8-byte aligned block of memory, whose first word
394 points to the given vtable data, then a data pointer, then n_words of data.
397 scm_i_alloc_struct (scm_t_bits
*vtable_data
, int n_words
)
400 ret
= (scm_t_bits
)scm_gc_malloc (sizeof (scm_t_bits
) * (n_words
+ 2), "struct");
401 SCM_SET_CELL_WORD_0 (SCM_PACK (ret
), (scm_t_bits
)vtable_data
| scm_tc3_struct
);
402 SCM_SET_CELL_WORD_1 (SCM_PACK (ret
),
403 (scm_t_bits
)SCM_CELL_OBJECT_LOC (SCM_PACK (ret
), 2));
405 /* vtable_data can be null when making a vtable vtable */
406 if (vtable_data
&& vtable_data
[scm_vtable_index_instance_finalize
])
408 /* Register a finalizer for the newly created instance. */
409 GC_finalization_proc prev_finalizer
;
410 GC_PTR prev_finalizer_data
;
411 GC_REGISTER_FINALIZER_NO_ORDER ((void*)ret
,
412 struct_finalizer_trampoline
,
415 &prev_finalizer_data
);
418 return SCM_PACK (ret
);
423 scm_c_make_structv (SCM vtable
, size_t n_tail
, size_t n_init
, scm_t_bits
*init
)
424 #define FUNC_NAME "make-struct"
430 SCM_VALIDATE_VTABLE (1, vtable
);
432 layout
= SCM_VTABLE_LAYOUT (vtable
);
433 basic_size
= scm_i_symbol_length (layout
) / 2;
437 SCM layout_str
, last_char
;
442 SCM_MISC_ERROR ("tail array not allowed unless layout ends R, W, or O", SCM_EOL
);
445 layout_str
= scm_symbol_to_string (layout
);
446 last_char
= scm_string_ref (layout_str
,
447 scm_from_size_t (2 * basic_size
- 1));
448 if (! SCM_LAYOUT_TAILP (SCM_CHAR (last_char
)))
452 obj
= scm_i_alloc_struct (SCM_STRUCT_DATA (vtable
), basic_size
+ n_tail
);
454 scm_struct_init (obj
, layout
, n_tail
, n_init
, init
);
456 /* only check things and inherit magic if the layout was passed as an initarg.
457 something of a hack, but it's for back-compatibility. */
458 if (SCM_VTABLE_FLAG_IS_SET (vtable
, SCM_VTABLE_FLAG_VTABLE
)
459 && scm_is_true (SCM_VTABLE_LAYOUT (obj
)))
460 scm_i_struct_inherit_vtable_magic (vtable
, obj
);
467 scm_c_make_struct (SCM vtable
, size_t n_tail
, size_t n_init
, scm_t_bits init
, ...)
473 v
= alloca (sizeof (scm_t_bits
) * n_init
);
475 va_start (foo
, init
);
476 for (i
= 0; i
< n_init
; i
++)
479 init
= va_arg (foo
, scm_t_bits
);
483 return scm_c_make_structv (vtable
, n_tail
, n_init
, v
);
486 SCM_DEFINE (scm_make_struct
, "make-struct", 2, 0, 1,
487 (SCM vtable
, SCM tail_array_size
, SCM init
),
488 "Create a new structure.\n\n"
489 "@var{type} must be a vtable structure (@pxref{Vtables}).\n\n"
490 "@var{tail-elts} must be a non-negative integer. If the layout\n"
491 "specification indicated by @var{type} includes a tail-array,\n"
492 "this is the number of elements allocated to that array.\n\n"
493 "The @var{init1}, @dots{} are optional arguments describing how\n"
494 "successive fields of the structure should be initialized. Only fields\n"
495 "with protection 'r' or 'w' can be initialized, except for fields of\n"
496 "type 's', which are automatically initialized to point to the new\n"
497 "structure itself. Fields with protection 'o' can not be initialized by\n"
498 "Scheme programs.\n\n"
499 "If fewer optional arguments than initializable fields are supplied,\n"
500 "fields of type 'p' get default value #f while fields of type 'u' are\n"
501 "initialized to 0.\n\n"
502 "For more information, see the documentation for @code{make-vtable-vtable}.")
503 #define FUNC_NAME s_scm_make_struct
509 SCM_VALIDATE_VTABLE (1, vtable
);
510 ilen
= scm_ilength (init
);
512 SCM_MISC_ERROR ("Rest arguments do not form a proper list.", SCM_EOL
);
514 n_init
= (size_t)ilen
;
516 /* best to use alloca, but init could be big, so hack to avoid a possible
519 v
= alloca (n_init
* sizeof(scm_t_bits
));
521 v
= scm_gc_malloc (n_init
* sizeof(scm_t_bits
), "struct");
523 for (i
= 0; i
< n_init
; i
++, init
= SCM_CDR (init
))
524 v
[i
] = SCM_UNPACK (SCM_CAR (init
));
526 return scm_c_make_structv (vtable
, scm_to_size_t (tail_array_size
), n_init
, v
);
532 SCM_DEFINE (scm_make_vtable_vtable
, "make-vtable-vtable", 2, 0, 1,
533 (SCM user_fields
, SCM tail_array_size
, SCM init
),
534 "Return a new, self-describing vtable structure.\n\n"
535 "@var{user-fields} is a string describing user defined fields of the\n"
536 "vtable beginning at index @code{vtable-offset-user}\n"
537 "(see @code{make-struct-layout}).\n\n"
538 "@var{tail-size} specifies the size of the tail-array (if any) of\n"
540 "@var{init1}, @dots{} are the optional initializers for the fields of\n"
542 "Vtables have one initializable system field---the struct printer.\n"
543 "This field comes before the user fields in the initializers passed\n"
544 "to @code{make-vtable-vtable} and @code{make-struct}, and thus works as\n"
545 "a third optional argument to @code{make-vtable-vtable} and a fourth to\n"
546 "@code{make-struct} when creating vtables:\n\n"
547 "If the value is a procedure, it will be called instead of the standard\n"
548 "printer whenever a struct described by this vtable is printed.\n"
549 "The procedure will be called with arguments STRUCT and PORT.\n\n"
550 "The structure of a struct is described by a vtable, so the vtable is\n"
551 "in essence the type of the struct. The vtable is itself a struct with\n"
552 "a vtable. This could go on forever if it weren't for the\n"
553 "vtable-vtables which are self-describing vtables, and thus terminate\n"
555 "There are several potential ways of using structs, but the standard\n"
556 "one is to use three kinds of structs, together building up a type\n"
557 "sub-system: one vtable-vtable working as the root and one or several\n"
558 "\"types\", each with a set of \"instances\". (The vtable-vtable should be\n"
559 "compared to the class <class> which is the class of itself.)\n\n"
561 "(define ball-root (make-vtable-vtable \"pr\" 0))\n\n"
562 "(define (make-ball-type ball-color)\n"
563 " (make-struct ball-root 0\n"
564 " (make-struct-layout \"pw\")\n"
565 " (lambda (ball port)\n"
566 " (format port \"#<a ~A ball owned by ~A>\"\n"
570 "(define (color ball) (struct-ref (struct-vtable ball) vtable-offset-user))\n"
571 "(define (owner ball) (struct-ref ball 0))\n\n"
572 "(define red (make-ball-type 'red))\n"
573 "(define green (make-ball-type 'green))\n\n"
574 "(define (make-ball type owner) (make-struct type 0 owner))\n\n"
575 "(define ball (make-ball green 'Nisse))\n"
576 "ball @result{} #<a green ball owned by Nisse>\n"
578 #define FUNC_NAME s_scm_make_vtable_vtable
580 SCM fields
, layout
, obj
;
581 size_t basic_size
, n_tail
, i
, n_init
;
585 SCM_VALIDATE_STRING (1, user_fields
);
586 ilen
= scm_ilength (init
);
588 SCM_MISC_ERROR ("Rest arguments do not form a proper list.", SCM_EOL
);
590 n_init
= (size_t)ilen
+ 1; /* + 1 for the layout */
592 /* best to use alloca, but init could be big, so hack to avoid a possible
595 v
= alloca (n_init
* sizeof(scm_t_bits
));
597 v
= scm_gc_malloc (n_init
* sizeof(scm_t_bits
), "struct");
599 fields
= scm_string_append (scm_list_2 (required_vtable_fields
,
601 layout
= scm_make_struct_layout (fields
);
602 basic_size
= scm_i_symbol_length (layout
) / 2;
603 n_tail
= scm_to_size_t (tail_array_size
);
606 v
[i
++] = SCM_UNPACK (layout
);
607 for (; i
< n_init
; i
++, init
= SCM_CDR (init
))
608 v
[i
] = SCM_UNPACK (SCM_CAR (init
));
610 SCM_CRITICAL_SECTION_START
;
611 obj
= scm_i_alloc_struct (NULL
, basic_size
+ n_tail
);
612 /* Make it so that the vtable of OBJ is itself. */
613 SCM_SET_CELL_WORD_0 (obj
, (scm_t_bits
) SCM_STRUCT_DATA (obj
) | scm_tc3_struct
);
614 SCM_CRITICAL_SECTION_END
;
616 scm_struct_init (obj
, layout
, n_tail
, n_init
, v
);
617 SCM_SET_VTABLE_FLAGS (obj
, SCM_VTABLE_FLAG_VTABLE
);
624 SCM_DEFINE (scm_make_vtable
, "make-vtable", 1, 1, 0,
625 (SCM fields
, SCM printer
),
626 "Create a vtable, for creating structures with the given\n"
629 "The optional @var{printer} argument is a function to be called\n"
630 "@code{(@var{printer} struct port)} on the structures created.\n"
631 "It should look at @var{struct} and write to @var{port}.")
632 #define FUNC_NAME s_scm_make_vtable
634 if (SCM_UNBNDP (printer
))
635 printer
= SCM_BOOL_F
;
637 return scm_make_struct (scm_standard_vtable_vtable
, SCM_INUM0
,
638 scm_list_2 (scm_make_struct_layout (fields
),
644 /* Return true if S1 and S2 are equal structures, i.e., if their vtable and
645 contents are the same. Field protections are honored. Thus, it is an
646 error to test the equality of structures that contain opaque fields. */
648 scm_i_struct_equalp (SCM s1
, SCM s2
)
649 #define FUNC_NAME "scm_i_struct_equalp"
651 SCM vtable1
, vtable2
, layout
;
652 size_t struct_size
, field_num
;
654 SCM_VALIDATE_STRUCT (1, s1
);
655 SCM_VALIDATE_STRUCT (2, s2
);
657 vtable1
= SCM_STRUCT_VTABLE (s1
);
658 vtable2
= SCM_STRUCT_VTABLE (s2
);
660 if (!scm_is_eq (vtable1
, vtable2
))
663 layout
= SCM_STRUCT_LAYOUT (s1
);
664 struct_size
= scm_i_symbol_length (layout
) / 2;
666 for (field_num
= 0; field_num
< struct_size
; field_num
++)
671 /* We have to use `scm_struct_ref ()' here so that fields are accessed
672 consistently, notably wrt. field types and access rights. */
673 s_field_num
= scm_from_size_t (field_num
);
674 field1
= scm_struct_ref (s1
, s_field_num
);
675 field2
= scm_struct_ref (s2
, s_field_num
);
677 /* Self-referencing fields (type `s') must be skipped to avoid infinite
679 if (!(scm_is_eq (field1
, s1
) && (scm_is_eq (field2
, s2
))))
680 if (scm_is_false (scm_equal_p (field1
, field2
)))
684 /* FIXME: Tail elements should be tested for equality. */
694 SCM_DEFINE (scm_struct_ref
, "struct-ref", 2, 0, 0,
695 (SCM handle
, SCM pos
),
696 "Access the @var{n}th field of @var{struct}.\n\n"
697 "If the field is of type 'p', then it can be set to an arbitrary value.\n\n"
698 "If the field is of type 'u', then it can only be set to a non-negative\n"
699 "integer value small enough to fit in one machine word.")
700 #define FUNC_NAME s_scm_struct_ref
702 SCM vtable
, answer
= SCM_UNDEFINED
;
706 SCM_VALIDATE_STRUCT (1, handle
);
708 vtable
= SCM_STRUCT_VTABLE (handle
);
709 data
= SCM_STRUCT_DATA (handle
);
710 p
= scm_to_size_t (pos
);
712 if (SCM_LIKELY (SCM_VTABLE_FLAG_IS_SET (vtable
, SCM_VTABLE_FLAG_SIMPLE
)
713 && p
< SCM_STRUCT_DATA_REF (vtable
, scm_vtable_index_size
)))
715 /* The fast path: HANDLE is a struct with only "p" fields. */
716 answer
= SCM_PACK (data
[p
]);
721 size_t layout_len
, n_fields
;
722 scm_t_wchar field_type
= 0;
724 layout
= SCM_STRUCT_LAYOUT (handle
);
725 layout_len
= scm_i_symbol_length (layout
);
726 n_fields
= layout_len
/ 2;
728 if (SCM_LAYOUT_TAILP (scm_i_symbol_ref (layout
, layout_len
- 1)))
729 n_fields
+= data
[n_fields
- 1];
731 SCM_ASSERT_RANGE (1, pos
, p
< n_fields
);
733 if (p
* 2 < layout_len
)
736 field_type
= scm_i_symbol_ref (layout
, p
* 2);
737 ref
= scm_i_symbol_ref (layout
, p
* 2 + 1);
738 if ((ref
!= 'r') && (ref
!= 'w') && (ref
!= 'h'))
740 if ((ref
== 'R') || (ref
== 'W'))
743 SCM_MISC_ERROR ("ref denied for field ~A", scm_list_1 (pos
));
746 else if (scm_i_symbol_ref (layout
, layout_len
- 1) != 'O')
747 field_type
= scm_i_symbol_ref(layout
, layout_len
- 2);
749 SCM_MISC_ERROR ("ref denied for field ~A", scm_list_1 (pos
));
754 answer
= scm_from_ulong (data
[p
]);
759 answer
= scm_from_long (data
[p
]);
763 answer
= scm_make_real (*((double *)&(data
[p
])));
769 answer
= SCM_PACK (data
[p
]);
774 SCM_MISC_ERROR ("unrecognized field type: ~S",
775 scm_list_1 (SCM_MAKE_CHAR (field_type
)));
784 SCM_DEFINE (scm_struct_set_x
, "struct-set!", 3, 0, 0,
785 (SCM handle
, SCM pos
, SCM val
),
786 "Set the slot of the structure @var{handle} with index @var{pos}\n"
787 "to @var{val}. Signal an error if the slot can not be written\n"
789 #define FUNC_NAME s_scm_struct_set_x
795 SCM_VALIDATE_STRUCT (1, handle
);
797 vtable
= SCM_STRUCT_VTABLE (handle
);
798 data
= SCM_STRUCT_DATA (handle
);
799 p
= scm_to_size_t (pos
);
801 if (SCM_LIKELY (SCM_VTABLE_FLAG_IS_SET (vtable
, SCM_VTABLE_FLAG_SIMPLE
)
802 && SCM_VTABLE_FLAG_IS_SET (vtable
, SCM_VTABLE_FLAG_SIMPLE_RW
)
803 && p
< SCM_STRUCT_DATA_REF (vtable
, scm_vtable_index_size
)))
804 /* The fast path: HANDLE is a struct with only "p" fields. */
805 data
[p
] = SCM_UNPACK (val
);
809 size_t layout_len
, n_fields
;
810 scm_t_wchar field_type
= 0;
812 layout
= SCM_STRUCT_LAYOUT (handle
);
813 layout_len
= scm_i_symbol_length (layout
);
814 n_fields
= layout_len
/ 2;
816 if (SCM_LAYOUT_TAILP (scm_i_symbol_ref (layout
, layout_len
- 1)))
817 n_fields
+= data
[n_fields
- 1];
819 SCM_ASSERT_RANGE (1, pos
, p
< n_fields
);
821 if (p
* 2 < layout_len
)
824 field_type
= scm_i_symbol_ref (layout
, p
* 2);
825 set_x
= scm_i_symbol_ref (layout
, p
* 2 + 1);
826 if (set_x
!= 'w' && set_x
!= 'h')
827 SCM_MISC_ERROR ("set! denied for field ~A", scm_list_1 (pos
));
829 else if (scm_i_symbol_ref (layout
, layout_len
- 1) == 'W')
830 field_type
= scm_i_symbol_ref (layout
, layout_len
- 2);
832 SCM_MISC_ERROR ("set! denied for field ~A", scm_list_1 (pos
));
837 data
[p
] = SCM_NUM2ULONG (3, val
);
842 data
[p
] = SCM_NUM2LONG (3, val
);
846 *((double *)&(data
[p
])) = scm_num2dbl (val
, (char *)SCM_ARG3
);
851 data
[p
] = SCM_UNPACK (val
);
855 SCM_MISC_ERROR ("self fields immutable", SCM_EOL
);
858 SCM_MISC_ERROR ("unrecognized field type: ~S",
859 scm_list_1 (SCM_MAKE_CHAR (field_type
)));
868 SCM_DEFINE (scm_struct_vtable
, "struct-vtable", 1, 0, 0,
870 "Return the vtable structure that describes the type of @var{struct}.")
871 #define FUNC_NAME s_scm_struct_vtable
873 SCM_VALIDATE_STRUCT (1, handle
);
874 return SCM_STRUCT_VTABLE (handle
);
879 SCM_DEFINE (scm_struct_vtable_tag
, "struct-vtable-tag", 1, 0, 0,
881 "Return the vtable tag of the structure @var{handle}.")
882 #define FUNC_NAME s_scm_struct_vtable_tag
884 SCM_VALIDATE_VTABLE (1, handle
);
885 return scm_from_ulong (((unsigned long)SCM_STRUCT_DATA (handle
)) >> 3);
889 /* {Associating names and classes with vtables}
891 * The name of a vtable should probably be stored as a slot. This is
892 * a backward compatible solution until agreement has been achieved on
893 * how to associate names with vtables.
897 scm_struct_ihashq (SCM obj
, unsigned long n
, void *closure
)
899 /* The length of the hash table should be a relative prime it's not
900 necessary to shift down the address. */
901 return SCM_UNPACK (obj
) % n
;
905 scm_struct_create_handle (SCM obj
)
907 SCM handle
= scm_hash_fn_create_handle_x (scm_struct_table
,
911 (scm_t_assoc_fn
) scm_sloppy_assq
,
913 if (scm_is_false (SCM_CDR (handle
)))
914 SCM_SETCDR (handle
, scm_cons (SCM_BOOL_F
, SCM_BOOL_F
));
918 SCM_DEFINE (scm_struct_vtable_name
, "struct-vtable-name", 1, 0, 0,
920 "Return the name of the vtable @var{vtable}.")
921 #define FUNC_NAME s_scm_struct_vtable_name
923 SCM_VALIDATE_VTABLE (1, vtable
);
924 return SCM_STRUCT_TABLE_NAME (SCM_CDR (scm_struct_create_handle (vtable
)));
928 SCM_DEFINE (scm_set_struct_vtable_name_x
, "set-struct-vtable-name!", 2, 0, 0,
929 (SCM vtable
, SCM name
),
930 "Set the name of the vtable @var{vtable} to @var{name}.")
931 #define FUNC_NAME s_scm_set_struct_vtable_name_x
933 SCM_VALIDATE_VTABLE (1, vtable
);
934 SCM_VALIDATE_SYMBOL (2, name
);
935 SCM_SET_STRUCT_TABLE_NAME (SCM_CDR (scm_struct_create_handle (vtable
)),
937 return SCM_UNSPECIFIED
;
945 scm_print_struct (SCM exp
, SCM port
, scm_print_state
*pstate
)
947 if (scm_is_true (scm_procedure_p (SCM_STRUCT_PRINTER (exp
))))
948 scm_printer_apply (SCM_STRUCT_PRINTER (exp
), exp
, port
, pstate
);
951 SCM vtable
= SCM_STRUCT_VTABLE (exp
);
952 SCM name
= scm_struct_vtable_name (vtable
);
953 scm_puts ("#<", port
);
954 if (scm_is_true (name
))
956 scm_display (name
, port
);
957 scm_putc (' ', port
);
961 if (SCM_VTABLE_FLAG_IS_SET (vtable
, SCM_VTABLE_FLAG_VTABLE
))
962 scm_puts ("vtable:", port
);
964 scm_puts ("struct:", port
);
965 scm_uintprint (SCM_UNPACK (vtable
), 16, port
);
966 scm_putc (' ', port
);
967 scm_write (SCM_VTABLE_LAYOUT (vtable
), port
);
968 scm_putc (' ', port
);
970 scm_uintprint (SCM_UNPACK (exp
), 16, port
);
972 if (SCM_STRUCT_APPLICABLE_P (exp
))
974 if (scm_is_true (SCM_STRUCT_PROCEDURE (exp
)))
976 scm_puts (" proc: ", port
);
977 if (scm_is_true (scm_procedure_p (SCM_STRUCT_PROCEDURE (exp
))))
978 scm_write (SCM_STRUCT_PROCEDURE (exp
), port
);
980 scm_puts ("(not a procedure?)", port
);
982 if (SCM_STRUCT_SETTER_P (exp
))
984 scm_puts (" setter: ", port
);
985 scm_write (SCM_STRUCT_SETTER (exp
), port
);
988 scm_putc ('>', port
);
995 /* The first word of a struct is equal to `SCM_STRUCT_DATA (vtable) +
996 scm_tc3_struct', and `SCM_STRUCT_DATA (vtable)' is 2 words after VTABLE by
998 GC_REGISTER_DISPLACEMENT (2 * sizeof (scm_t_bits
) + scm_tc3_struct
);
1000 /* In the general case, `SCM_STRUCT_DATA (obj)' points 2 words after the
1001 beginning of a GC-allocated region; that region is different from that of
1002 OBJ once OBJ has undergone class redefinition. */
1003 GC_REGISTER_DISPLACEMENT (2 * sizeof (scm_t_bits
));
1005 scm_struct_table
= scm_make_weak_key_hash_table (scm_from_int (31));
1006 required_vtable_fields
= scm_from_locale_string (SCM_VTABLE_BASE_LAYOUT
);
1007 required_applicable_fields
= scm_from_locale_string (SCM_APPLICABLE_BASE_LAYOUT
);
1008 required_applicable_with_setter_fields
= scm_from_locale_string (SCM_APPLICABLE_WITH_SETTER_BASE_LAYOUT
);
1010 scm_standard_vtable_vtable
=
1011 scm_make_vtable_vtable (scm_nullstr
, SCM_INUM0
, SCM_EOL
);
1013 scm_applicable_struct_vtable_vtable
=
1014 scm_make_struct (scm_standard_vtable_vtable
, SCM_INUM0
,
1015 scm_list_1 (scm_make_struct_layout (required_vtable_fields
)));
1016 SCM_SET_VTABLE_FLAGS (scm_applicable_struct_vtable_vtable
,
1017 SCM_VTABLE_FLAG_APPLICABLE_VTABLE
);
1018 scm_c_define ("<applicable-struct-vtable>", scm_applicable_struct_vtable_vtable
);
1020 scm_applicable_struct_with_setter_vtable_vtable
=
1021 scm_make_struct (scm_standard_vtable_vtable
, SCM_INUM0
,
1022 scm_list_1 (scm_make_struct_layout (required_vtable_fields
)));
1023 SCM_SET_VTABLE_FLAGS (scm_applicable_struct_with_setter_vtable_vtable
,
1024 SCM_VTABLE_FLAG_APPLICABLE_VTABLE
| SCM_VTABLE_FLAG_SETTER_VTABLE
);
1025 scm_c_define ("<applicable-struct-with-setter-vtable>", scm_applicable_struct_with_setter_vtable_vtable
);
1027 scm_c_define ("vtable-index-layout", scm_from_int (scm_vtable_index_layout
));
1028 scm_c_define ("vtable-index-printer",
1029 scm_from_int (scm_vtable_index_instance_printer
));
1030 scm_c_define ("vtable-offset-user", scm_from_int (scm_vtable_offset_user
));
1031 #include "libguile/struct.x"