1 /* Copyright (C) 1996,1997,1998,1999,2000,2001, 2003, 2004, 2006, 2007, 2008, 2009, 2010, 2011 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_applicable_struct_vtable_vtable
;
58 SCM scm_applicable_struct_with_setter_vtable_vtable
;
59 SCM scm_standard_vtable_vtable
;
63 SCM_DEFINE (scm_make_struct_layout
, "make-struct-layout", 1, 0, 0,
65 "Return a new structure layout object.\n\n"
66 "@var{fields} must be a string made up of pairs of characters\n"
67 "strung together. The first character of each pair describes a field\n"
68 "type, the second a field protection. Allowed types are 'p' for\n"
69 "GC-protected Scheme data, 'u' for unprotected binary data, and 's' for\n"
70 "a field that points to the structure itself. Allowed protections\n"
71 "are 'w' for mutable fields, 'h' for hidden fields, 'r' for read-only\n"
72 "fields, and 'o' for opaque fields.\n\n"
73 "Hidden fields are writable, but they will not consume an initializer arg\n"
74 "passed to @code{make-struct}. They are useful to add slots to a struct\n"
75 "in a way that preserves backward-compatibility with existing calls to\n"
76 "@code{make-struct}, especially for derived vtables.\n\n"
77 "The last field protection specification may be capitalized to indicate\n"
78 "that the field is a tail-array.")
79 #define FUNC_NAME s_scm_make_struct_layout
84 SCM_VALIDATE_STRING (1, fields
);
90 len
= scm_i_string_length (fields
);
92 SCM_MISC_ERROR ("odd length field specification: ~S",
95 for (x
= 0; x
< len
; x
+= 2)
97 switch (c
= scm_i_string_ref (fields
, x
))
108 SCM_MISC_ERROR ("unrecognized field type: ~S",
109 scm_list_1 (SCM_MAKE_CHAR (c
)));
112 switch (c
= scm_i_string_ref (fields
, x
+ 1))
116 if (scm_i_string_ref (fields
, x
) == 's')
117 SCM_MISC_ERROR ("self fields not writable", SCM_EOL
);
124 if (scm_i_string_ref (fields
, x
) == 's')
125 SCM_MISC_ERROR ("self fields not allowed in tail array",
128 SCM_MISC_ERROR ("tail array field must be last field in layout",
132 SCM_MISC_ERROR ("unrecognized ref specification: ~S",
133 scm_list_1 (SCM_MAKE_CHAR (c
)));
136 if (scm_i_string_ref (fields
, x
, 'd'))
138 if (!scm_i_string_ref (fields
, x
+2, '-'))
139 SCM_MISC_ERROR ("missing dash field at position ~A",
140 scm_list_1 (scm_from_int (x
/ 2)));
146 new_sym
= scm_string_to_symbol (fields
);
148 scm_remember_upto_here_1 (fields
);
154 /* Check whether VTABLE instances have a simple layout (i.e., either only "pr"
155 or only "pw" fields) and update its flags accordingly. */
157 set_vtable_layout_flags (SCM vtable
)
161 const char *c_layout
;
162 scm_t_bits flags
= SCM_VTABLE_FLAG_SIMPLE
;
164 layout
= SCM_VTABLE_LAYOUT (vtable
);
165 c_layout
= scm_i_symbol_chars (layout
);
166 len
= scm_i_symbol_length (layout
);
168 assert (len
% 2 == 0);
170 /* Update FLAGS according to LAYOUT. */
172 field
< len
&& flags
& SCM_VTABLE_FLAG_SIMPLE
;
175 if (c_layout
[field
] != 'p')
178 switch (c_layout
[field
+ 1])
183 flags
|= SCM_VTABLE_FLAG_SIMPLE_RW
;
188 flags
&= ~SCM_VTABLE_FLAG_SIMPLE_RW
;
196 if (flags
& SCM_VTABLE_FLAG_SIMPLE
)
198 /* VTABLE is simple so update its flags and record the size of its
200 SCM_SET_VTABLE_FLAGS (vtable
, flags
);
201 SCM_STRUCT_DATA_SET (vtable
, scm_vtable_index_size
, len
/ 2);
206 scm_is_valid_vtable_layout (SCM layout
)
209 const char *c_layout
;
211 c_layout
= scm_i_symbol_chars (layout
);
212 len
= scm_i_symbol_length (layout
);
217 for (n
= 0; n
< len
; n
+= 2)
223 switch (c_layout
[n
+1])
245 /* Have OBJ, a newly created vtable, inherit flags from VTABLE. VTABLE is a
246 vtable-vtable and OBJ is an instance of VTABLE. */
248 scm_i_struct_inherit_vtable_magic (SCM vtable
, SCM obj
)
249 #define FUNC_NAME "%inherit-vtable-magic"
251 /* Verily, what is the deal here, you ask? Basically, we need to know a couple
252 of properties of structures at runtime. For example, "is this structure a
253 vtable of vtables (a metaclass)?"; also, "is this structure applicable?".
254 Both of these questions also imply a certain layout of the structure. So
255 instead of checking the layout at runtime, what we do is pre-verify the
256 layout -- so that at runtime we can just check the applicable flag and
257 dispatch directly to the Scheme procedure in slot 0. */
260 /* Verify that OBJ is a valid vtable. */
261 if (! scm_is_valid_vtable_layout (SCM_VTABLE_LAYOUT (obj
)))
262 SCM_MISC_ERROR ("invalid layout for new vtable: ~a",
263 scm_list_1 (SCM_VTABLE_LAYOUT (obj
)));
265 set_vtable_layout_flags (obj
);
267 /* If OBJ's vtable is compatible with the required vtable (class) layout, it
269 olayout
= scm_symbol_to_string (SCM_VTABLE_LAYOUT (obj
));
270 if (scm_is_true (scm_leq_p (scm_string_length (required_vtable_fields
),
271 scm_string_length (olayout
)))
272 && scm_is_true (scm_string_eq (olayout
, required_vtable_fields
,
274 scm_string_length (required_vtable_fields
),
276 scm_string_length (required_vtable_fields
))))
277 SCM_SET_VTABLE_FLAGS (obj
, SCM_VTABLE_FLAG_VTABLE
);
279 /* Finally, if OBJ is an applicable class, verify that its vtable is
280 compatible with the required applicable layout. */
281 if (SCM_VTABLE_FLAG_IS_SET (vtable
, SCM_VTABLE_FLAG_SETTER_VTABLE
))
283 if (scm_is_false (scm_string_eq (olayout
, required_applicable_with_setter_fields
,
287 scm_from_size_t (4))))
288 SCM_MISC_ERROR ("invalid applicable-with-setter struct layout",
289 scm_list_1 (olayout
));
290 SCM_SET_VTABLE_FLAGS (obj
, SCM_VTABLE_FLAG_APPLICABLE
| SCM_VTABLE_FLAG_SETTER
);
292 else if (SCM_VTABLE_FLAG_IS_SET (vtable
, SCM_VTABLE_FLAG_APPLICABLE_VTABLE
))
294 if (scm_is_false (scm_string_eq (olayout
, required_applicable_fields
,
298 scm_from_size_t (2))))
299 SCM_MISC_ERROR ("invalid applicable struct layout",
300 scm_list_1 (olayout
));
301 SCM_SET_VTABLE_FLAGS (obj
, SCM_VTABLE_FLAG_APPLICABLE
);
304 SCM_SET_VTABLE_FLAGS (obj
, SCM_VTABLE_FLAG_VALIDATED
);
310 scm_struct_init (SCM handle
, SCM layout
, size_t n_tail
,
311 size_t n_inits
, scm_t_bits
*inits
)
316 vtable
= SCM_STRUCT_VTABLE (handle
);
317 mem
= SCM_STRUCT_DATA (handle
);
319 if (SCM_UNPACK (vtable
) != 0
320 && SCM_VTABLE_FLAG_IS_SET (vtable
, SCM_VTABLE_FLAG_SIMPLE
)
322 && n_inits
== SCM_STRUCT_DATA_REF (vtable
, scm_vtable_index_size
))
323 /* The fast path: HANDLE has N_INITS "p" fields. */
324 memcpy (mem
, inits
, n_inits
* sizeof (SCM
));
327 scm_t_wchar prot
= 0;
328 int n_fields
= scm_i_symbol_length (layout
) / 2;
331 size_t inits_idx
= 0;
339 prot
= scm_i_symbol_ref (layout
, i
+1);
340 if (SCM_LAYOUT_TAILP (prot
))
343 prot
= prot
== 'R' ? 'r' : prot
== 'W' ? 'w' : 'o';
344 *mem
++ = (scm_t_bits
)n_tail
;
345 n_fields
+= n_tail
- 1;
350 switch (scm_i_symbol_ref (layout
, i
))
353 if ((prot
!= 'r' && prot
!= 'w') || inits_idx
== n_inits
)
357 *mem
= scm_to_ulong (SCM_PACK (inits
[inits_idx
]));
363 if ((prot
!= 'r' && prot
!= 'w') || inits_idx
== n_inits
)
364 *mem
= SCM_UNPACK (SCM_BOOL_F
);
367 *mem
= inits
[inits_idx
];
374 *mem
= SCM_UNPACK (handle
);
385 SCM_DEFINE (scm_struct_p
, "struct?", 1, 0, 0,
387 "Return @code{#t} iff @var{x} is a structure object, else\n"
389 #define FUNC_NAME s_scm_struct_p
391 return scm_from_bool(SCM_STRUCTP (x
));
395 SCM_DEFINE (scm_struct_vtable_p
, "struct-vtable?", 1, 0, 0,
397 "Return @code{#t} iff @var{x} is a vtable structure.")
398 #define FUNC_NAME s_scm_struct_vtable_p
401 || !SCM_STRUCT_VTABLE_FLAG_IS_SET (x
, SCM_VTABLE_FLAG_VTABLE
))
403 if (!SCM_VTABLE_FLAG_IS_SET (x
, SCM_VTABLE_FLAG_VALIDATED
))
404 SCM_MISC_ERROR ("vtable has invalid layout: ~A",
405 scm_list_1 (SCM_VTABLE_LAYOUT (x
)));
411 /* Finalization: invoke the finalizer of the struct pointed to by PTR. */
413 struct_finalizer_trampoline (GC_PTR ptr
, GC_PTR unused_data
)
415 SCM obj
= PTR2SCM (ptr
);
416 scm_t_struct_finalize finalize
= SCM_STRUCT_FINALIZER (obj
);
422 /* All struct data must be allocated at an address whose bottom three
423 bits are zero. This is because the tag for a struct lives in the
424 bottom three bits of the struct's car, and the upper bits point to
425 the data of its vtable, which is a struct itself. Thus, if the
426 address of that data doesn't end in three zeros, tagging it will
429 I suppose we should make it clear here that, the data must be 8-byte aligned,
430 *within* the struct, and the struct itself should be 8-byte aligned. In
431 practice we ensure this because the data starts two words into a struct.
433 This function allocates an 8-byte aligned block of memory, whose first word
434 points to the given vtable data, then a data pointer, then n_words of data.
437 scm_i_alloc_struct (scm_t_bits
*vtable_data
, int n_words
)
441 ret
= scm_words ((scm_t_bits
)vtable_data
| scm_tc3_struct
, n_words
+ 2);
442 SCM_SET_CELL_WORD_1 (ret
, (scm_t_bits
)SCM_CELL_OBJECT_LOC (ret
, 2));
444 /* vtable_data can be null when making a vtable vtable */
445 if (vtable_data
&& vtable_data
[scm_vtable_index_instance_finalize
])
447 /* Register a finalizer for the newly created instance. */
448 GC_finalization_proc prev_finalizer
;
449 GC_PTR prev_finalizer_data
;
450 GC_REGISTER_FINALIZER_NO_ORDER (SCM2PTR (ret
),
451 struct_finalizer_trampoline
,
454 &prev_finalizer_data
);
462 scm_c_make_structv (SCM vtable
, size_t n_tail
, size_t n_init
, scm_t_bits
*init
)
463 #define FUNC_NAME "make-struct"
469 SCM_VALIDATE_VTABLE (1, vtable
);
471 layout
= SCM_VTABLE_LAYOUT (vtable
);
472 basic_size
= scm_i_symbol_length (layout
) / 2;
476 SCM layout_str
, last_char
;
481 SCM_MISC_ERROR ("tail array not allowed unless layout ends R, W, or O", SCM_EOL
);
484 layout_str
= scm_symbol_to_string (layout
);
485 last_char
= scm_string_ref (layout_str
,
486 scm_from_size_t (2 * basic_size
- 1));
487 if (! SCM_LAYOUT_TAILP (SCM_CHAR (last_char
)))
491 obj
= scm_i_alloc_struct (SCM_STRUCT_DATA (vtable
), basic_size
+ n_tail
);
493 scm_struct_init (obj
, layout
, n_tail
, n_init
, init
);
495 /* If we're making a vtable, validate its layout and inherit
496 flags. However we allow for separation of allocation and
497 initialization, to humor GOOPS, so only validate if the layout was
498 passed as an initarg. */
499 if (SCM_VTABLE_FLAG_IS_SET (vtable
, SCM_VTABLE_FLAG_VTABLE
)
500 && scm_is_true (SCM_VTABLE_LAYOUT (obj
)))
501 scm_i_struct_inherit_vtable_magic (vtable
, obj
);
508 scm_c_make_struct (SCM vtable
, size_t n_tail
, size_t n_init
, scm_t_bits init
, ...)
514 v
= alloca (sizeof (scm_t_bits
) * n_init
);
516 va_start (foo
, init
);
517 for (i
= 0; i
< n_init
; i
++)
520 init
= va_arg (foo
, scm_t_bits
);
524 return scm_c_make_structv (vtable
, n_tail
, n_init
, v
);
527 SCM_DEFINE (scm_make_struct
, "make-struct", 2, 0, 1,
528 (SCM vtable
, SCM tail_array_size
, SCM init
),
529 "Create a new structure.\n\n"
530 "@var{type} must be a vtable structure (@pxref{Vtables}).\n\n"
531 "@var{tail-elts} must be a non-negative integer. If the layout\n"
532 "specification indicated by @var{type} includes a tail-array,\n"
533 "this is the number of elements allocated to that array.\n\n"
534 "The @var{init1}, @dots{} are optional arguments describing how\n"
535 "successive fields of the structure should be initialized. Only fields\n"
536 "with protection 'r' or 'w' can be initialized, except for fields of\n"
537 "type 's', which are automatically initialized to point to the new\n"
538 "structure itself. Fields with protection 'o' can not be initialized by\n"
539 "Scheme programs.\n\n"
540 "If fewer optional arguments than initializable fields are supplied,\n"
541 "fields of type 'p' get default value #f while fields of type 'u' are\n"
542 "initialized to 0.\n\n"
543 "For more information, see the documentation for @code{make-vtable-vtable}.")
544 #define FUNC_NAME s_scm_make_struct
550 SCM_VALIDATE_VTABLE (1, vtable
);
551 ilen
= scm_ilength (init
);
553 SCM_MISC_ERROR ("Rest arguments do not form a proper list.", SCM_EOL
);
555 n_init
= (size_t)ilen
;
557 /* best to use alloca, but init could be big, so hack to avoid a possible
560 v
= alloca (n_init
* sizeof(scm_t_bits
));
562 v
= scm_gc_malloc (n_init
* sizeof(scm_t_bits
), "struct");
564 for (i
= 0; i
< n_init
; i
++, init
= SCM_CDR (init
))
565 v
[i
] = SCM_UNPACK (SCM_CAR (init
));
567 return scm_c_make_structv (vtable
, scm_to_size_t (tail_array_size
), n_init
, v
);
573 SCM_DEFINE (scm_make_vtable_vtable
, "make-vtable-vtable", 2, 0, 1,
574 (SCM user_fields
, SCM tail_array_size
, SCM init
),
575 "Return a new, self-describing vtable structure.\n\n"
576 "@var{user-fields} is a string describing user defined fields of the\n"
577 "vtable beginning at index @code{vtable-offset-user}\n"
578 "(see @code{make-struct-layout}).\n\n"
579 "@var{tail-size} specifies the size of the tail-array (if any) of\n"
581 "@var{init1}, @dots{} are the optional initializers for the fields of\n"
583 "Vtables have one initializable system field---the struct printer.\n"
584 "This field comes before the user fields in the initializers passed\n"
585 "to @code{make-vtable-vtable} and @code{make-struct}, and thus works as\n"
586 "a third optional argument to @code{make-vtable-vtable} and a fourth to\n"
587 "@code{make-struct} when creating vtables:\n\n"
588 "If the value is a procedure, it will be called instead of the standard\n"
589 "printer whenever a struct described by this vtable is printed.\n"
590 "The procedure will be called with arguments STRUCT and PORT.\n\n"
591 "The structure of a struct is described by a vtable, so the vtable is\n"
592 "in essence the type of the struct. The vtable is itself a struct with\n"
593 "a vtable. This could go on forever if it weren't for the\n"
594 "vtable-vtables which are self-describing vtables, and thus terminate\n"
596 "There are several potential ways of using structs, but the standard\n"
597 "one is to use three kinds of structs, together building up a type\n"
598 "sub-system: one vtable-vtable working as the root and one or several\n"
599 "\"types\", each with a set of \"instances\". (The vtable-vtable should be\n"
600 "compared to the class <class> which is the class of itself.)\n\n"
602 "(define ball-root (make-vtable-vtable \"pr\" 0))\n\n"
603 "(define (make-ball-type ball-color)\n"
604 " (make-struct ball-root 0\n"
605 " (make-struct-layout \"pw\")\n"
606 " (lambda (ball port)\n"
607 " (format port \"#<a ~A ball owned by ~A>\"\n"
611 "(define (color ball) (struct-ref (struct-vtable ball) vtable-offset-user))\n"
612 "(define (owner ball) (struct-ref ball 0))\n\n"
613 "(define red (make-ball-type 'red))\n"
614 "(define green (make-ball-type 'green))\n\n"
615 "(define (make-ball type owner) (make-struct type 0 owner))\n\n"
616 "(define ball (make-ball green 'Nisse))\n"
617 "ball @result{} #<a green ball owned by Nisse>\n"
619 #define FUNC_NAME s_scm_make_vtable_vtable
621 SCM fields
, layout
, obj
;
622 size_t basic_size
, n_tail
, i
, n_init
;
626 SCM_VALIDATE_STRING (1, user_fields
);
627 ilen
= scm_ilength (init
);
629 SCM_MISC_ERROR ("Rest arguments do not form a proper list.", SCM_EOL
);
631 n_init
= (size_t)ilen
+ 1; /* + 1 for the layout */
633 /* best to use alloca, but init could be big, so hack to avoid a possible
636 v
= alloca (n_init
* sizeof(scm_t_bits
));
638 v
= scm_gc_malloc (n_init
* sizeof(scm_t_bits
), "struct");
640 fields
= scm_string_append (scm_list_2 (required_vtable_fields
,
642 layout
= scm_make_struct_layout (fields
);
643 if (!scm_is_valid_vtable_layout (layout
))
644 SCM_MISC_ERROR ("invalid user fields", scm_list_1 (user_fields
));
646 basic_size
= scm_i_symbol_length (layout
) / 2;
647 n_tail
= scm_to_size_t (tail_array_size
);
650 v
[i
++] = SCM_UNPACK (layout
);
651 for (; i
< n_init
; i
++, init
= SCM_CDR (init
))
652 v
[i
] = SCM_UNPACK (SCM_CAR (init
));
654 SCM_CRITICAL_SECTION_START
;
655 obj
= scm_i_alloc_struct (NULL
, basic_size
+ n_tail
);
656 /* Make it so that the vtable of OBJ is itself. */
657 SCM_SET_CELL_WORD_0 (obj
, (scm_t_bits
) SCM_STRUCT_DATA (obj
) | scm_tc3_struct
);
658 SCM_CRITICAL_SECTION_END
;
660 scm_struct_init (obj
, layout
, n_tail
, n_init
, v
);
661 SCM_SET_VTABLE_FLAGS (obj
,
662 SCM_VTABLE_FLAG_VTABLE
| SCM_VTABLE_FLAG_VALIDATED
);
669 SCM_DEFINE (scm_make_vtable
, "make-vtable", 1, 1, 0,
670 (SCM fields
, SCM printer
),
671 "Create a vtable, for creating structures with the given\n"
674 "The optional @var{printer} argument is a function to be called\n"
675 "@code{(@var{printer} struct port)} on the structures created.\n"
676 "It should look at @var{struct} and write to @var{port}.")
677 #define FUNC_NAME s_scm_make_vtable
679 if (SCM_UNBNDP (printer
))
680 printer
= SCM_BOOL_F
;
682 return scm_make_struct (scm_standard_vtable_vtable
, SCM_INUM0
,
683 scm_list_2 (scm_make_struct_layout (fields
),
689 /* Return true if S1 and S2 are equal structures, i.e., if their vtable and
690 contents are the same. Field protections are honored. Thus, it is an
691 error to test the equality of structures that contain opaque fields. */
693 scm_i_struct_equalp (SCM s1
, SCM s2
)
694 #define FUNC_NAME "scm_i_struct_equalp"
696 SCM vtable1
, vtable2
, layout
;
697 size_t struct_size
, field_num
;
699 SCM_VALIDATE_STRUCT (1, s1
);
700 SCM_VALIDATE_STRUCT (2, s2
);
702 vtable1
= SCM_STRUCT_VTABLE (s1
);
703 vtable2
= SCM_STRUCT_VTABLE (s2
);
705 if (!scm_is_eq (vtable1
, vtable2
))
708 layout
= SCM_STRUCT_LAYOUT (s1
);
709 struct_size
= scm_i_symbol_length (layout
) / 2;
711 for (field_num
= 0; field_num
< struct_size
; field_num
++)
716 /* We have to use `scm_struct_ref ()' here so that fields are accessed
717 consistently, notably wrt. field types and access rights. */
718 s_field_num
= scm_from_size_t (field_num
);
719 field1
= scm_struct_ref (s1
, s_field_num
);
720 field2
= scm_struct_ref (s2
, s_field_num
);
722 /* Self-referencing fields (type `s') must be skipped to avoid infinite
724 if (!(scm_is_eq (field1
, s1
) && (scm_is_eq (field2
, s2
))))
725 if (scm_is_false (scm_equal_p (field1
, field2
)))
729 /* FIXME: Tail elements should be tested for equality. */
739 SCM_DEFINE (scm_struct_ref
, "struct-ref", 2, 0, 0,
740 (SCM handle
, SCM pos
),
741 "Access the @var{n}th field of @var{struct}.\n\n"
742 "If the field is of type 'p', then it can be set to an arbitrary value.\n\n"
743 "If the field is of type 'u', then it can only be set to a non-negative\n"
744 "integer value small enough to fit in one machine word.")
745 #define FUNC_NAME s_scm_struct_ref
747 SCM vtable
, answer
= SCM_UNDEFINED
;
751 SCM_VALIDATE_STRUCT (1, handle
);
753 vtable
= SCM_STRUCT_VTABLE (handle
);
754 data
= SCM_STRUCT_DATA (handle
);
755 p
= scm_to_size_t (pos
);
757 if (SCM_LIKELY (SCM_VTABLE_FLAG_IS_SET (vtable
, SCM_VTABLE_FLAG_SIMPLE
)
758 && p
< SCM_STRUCT_DATA_REF (vtable
, scm_vtable_index_size
)))
759 /* The fast path: HANDLE is a struct with only "p" fields. */
760 answer
= SCM_PACK (data
[p
]);
764 size_t layout_len
, n_fields
;
765 scm_t_wchar field_type
= 0;
767 layout
= SCM_STRUCT_LAYOUT (handle
);
768 layout_len
= scm_i_symbol_length (layout
);
769 n_fields
= layout_len
/ 2;
771 if (SCM_LAYOUT_TAILP (scm_i_symbol_ref (layout
, layout_len
- 1)))
772 n_fields
+= data
[n_fields
- 1];
774 SCM_ASSERT_RANGE (1, pos
, p
< n_fields
);
776 if (p
* 2 < layout_len
)
779 field_type
= scm_i_symbol_ref (layout
, p
* 2);
780 ref
= scm_i_symbol_ref (layout
, p
* 2 + 1);
781 if ((ref
!= 'r') && (ref
!= 'w') && (ref
!= 'h'))
783 if ((ref
== 'R') || (ref
== 'W'))
786 SCM_MISC_ERROR ("ref denied for field ~A", scm_list_1 (pos
));
789 else if (scm_i_symbol_ref (layout
, layout_len
- 1) != 'O')
790 field_type
= scm_i_symbol_ref(layout
, layout_len
- 2);
792 SCM_MISC_ERROR ("ref denied for field ~A", scm_list_1 (pos
));
797 answer
= scm_from_ulong (data
[p
]);
802 answer
= scm_from_long (data
[p
]);
806 answer
= scm_make_real (*((double *)&(data
[p
])));
812 answer
= SCM_PACK (data
[p
]);
817 SCM_MISC_ERROR ("unrecognized field type: ~S",
818 scm_list_1 (SCM_MAKE_CHAR (field_type
)));
827 SCM_DEFINE (scm_struct_set_x
, "struct-set!", 3, 0, 0,
828 (SCM handle
, SCM pos
, SCM val
),
829 "Set the slot of the structure @var{handle} with index @var{pos}\n"
830 "to @var{val}. Signal an error if the slot can not be written\n"
832 #define FUNC_NAME s_scm_struct_set_x
838 SCM_VALIDATE_STRUCT (1, handle
);
840 vtable
= SCM_STRUCT_VTABLE (handle
);
841 data
= SCM_STRUCT_DATA (handle
);
842 p
= scm_to_size_t (pos
);
844 if (SCM_LIKELY (SCM_VTABLE_FLAG_IS_SET (vtable
, SCM_VTABLE_FLAG_SIMPLE
)
845 && SCM_VTABLE_FLAG_IS_SET (vtable
, SCM_VTABLE_FLAG_SIMPLE_RW
)
846 && p
< SCM_STRUCT_DATA_REF (vtable
, scm_vtable_index_size
)))
847 /* The fast path: HANDLE is a struct with only "pw" fields. */
848 data
[p
] = SCM_UNPACK (val
);
852 size_t layout_len
, n_fields
;
853 scm_t_wchar field_type
= 0;
855 layout
= SCM_STRUCT_LAYOUT (handle
);
856 layout_len
= scm_i_symbol_length (layout
);
857 n_fields
= layout_len
/ 2;
859 if (SCM_LAYOUT_TAILP (scm_i_symbol_ref (layout
, layout_len
- 1)))
860 n_fields
+= data
[n_fields
- 1];
862 SCM_ASSERT_RANGE (1, pos
, p
< n_fields
);
864 if (p
* 2 < layout_len
)
867 field_type
= scm_i_symbol_ref (layout
, p
* 2);
868 set_x
= scm_i_symbol_ref (layout
, p
* 2 + 1);
869 if (set_x
!= 'w' && set_x
!= 'h')
870 SCM_MISC_ERROR ("set! denied for field ~A", scm_list_1 (pos
));
872 else if (scm_i_symbol_ref (layout
, layout_len
- 1) == 'W')
873 field_type
= scm_i_symbol_ref (layout
, layout_len
- 2);
875 SCM_MISC_ERROR ("set! denied for field ~A", scm_list_1 (pos
));
880 data
[p
] = SCM_NUM2ULONG (3, val
);
885 data
[p
] = SCM_NUM2LONG (3, val
);
889 *((double *)&(data
[p
])) = scm_num2dbl (val
, (char *)SCM_ARG3
);
894 data
[p
] = SCM_UNPACK (val
);
898 SCM_MISC_ERROR ("self fields immutable", SCM_EOL
);
901 SCM_MISC_ERROR ("unrecognized field type: ~S",
902 scm_list_1 (SCM_MAKE_CHAR (field_type
)));
911 SCM_DEFINE (scm_struct_vtable
, "struct-vtable", 1, 0, 0,
913 "Return the vtable structure that describes the type of @var{struct}.")
914 #define FUNC_NAME s_scm_struct_vtable
916 SCM_VALIDATE_STRUCT (1, handle
);
917 return SCM_STRUCT_VTABLE (handle
);
922 SCM_DEFINE (scm_struct_vtable_tag
, "struct-vtable-tag", 1, 0, 0,
924 "Return the vtable tag of the structure @var{handle}.")
925 #define FUNC_NAME s_scm_struct_vtable_tag
927 SCM_VALIDATE_VTABLE (1, handle
);
928 return scm_from_unsigned_integer
929 (((scm_t_bits
)SCM_STRUCT_DATA (handle
)) >> 3);
933 /* {Associating names and classes with vtables}
935 * The name of a vtable should probably be stored as a slot. This is
936 * a backward compatible solution until agreement has been achieved on
937 * how to associate names with vtables.
941 scm_struct_ihashq (SCM obj
, unsigned long n
, void *closure
)
943 /* The length of the hash table should be a relative prime it's not
944 necessary to shift down the address. */
945 return SCM_UNPACK (obj
) % n
;
948 SCM_DEFINE (scm_struct_vtable_name
, "struct-vtable-name", 1, 0, 0,
950 "Return the name of the vtable @var{vtable}.")
951 #define FUNC_NAME s_scm_struct_vtable_name
953 SCM_VALIDATE_VTABLE (1, vtable
);
954 return SCM_VTABLE_NAME (vtable
);
958 SCM_DEFINE (scm_set_struct_vtable_name_x
, "set-struct-vtable-name!", 2, 0, 0,
959 (SCM vtable
, SCM name
),
960 "Set the name of the vtable @var{vtable} to @var{name}.")
961 #define FUNC_NAME s_scm_set_struct_vtable_name_x
963 SCM_VALIDATE_VTABLE (1, vtable
);
964 SCM_VALIDATE_SYMBOL (2, name
);
965 SCM_SET_VTABLE_NAME (vtable
, name
);
966 /* FIXME: remove this, and implement proper struct classes instead.
967 (Vtables *are* classes.) */
968 scm_i_define_class_for_vtable (vtable
);
969 return SCM_UNSPECIFIED
;
977 scm_print_struct (SCM exp
, SCM port
, scm_print_state
*pstate
)
979 if (scm_is_true (scm_procedure_p (SCM_STRUCT_PRINTER (exp
))))
980 scm_printer_apply (SCM_STRUCT_PRINTER (exp
), exp
, port
, pstate
);
983 SCM vtable
= SCM_STRUCT_VTABLE (exp
);
984 SCM name
= scm_struct_vtable_name (vtable
);
985 scm_puts ("#<", port
);
986 if (scm_is_true (name
))
988 scm_display (name
, port
);
989 scm_putc (' ', port
);
993 if (SCM_VTABLE_FLAG_IS_SET (vtable
, SCM_VTABLE_FLAG_VTABLE
))
994 scm_puts ("vtable:", port
);
996 scm_puts ("struct:", port
);
997 scm_uintprint (SCM_UNPACK (vtable
), 16, port
);
998 scm_putc (' ', port
);
999 scm_write (SCM_VTABLE_LAYOUT (vtable
), port
);
1000 scm_putc (' ', port
);
1002 scm_uintprint (SCM_UNPACK (exp
), 16, port
);
1004 if (SCM_STRUCT_APPLICABLE_P (exp
))
1006 if (scm_is_true (SCM_STRUCT_PROCEDURE (exp
)))
1008 scm_puts (" proc: ", port
);
1009 if (scm_is_true (scm_procedure_p (SCM_STRUCT_PROCEDURE (exp
))))
1010 scm_write (SCM_STRUCT_PROCEDURE (exp
), port
);
1012 scm_puts ("(not a procedure?)", port
);
1014 if (SCM_STRUCT_SETTER_P (exp
))
1016 scm_puts (" setter: ", port
);
1017 scm_write (SCM_STRUCT_SETTER (exp
), port
);
1020 scm_putc ('>', port
);
1027 /* The first word of a struct is equal to `SCM_STRUCT_DATA (vtable) +
1028 scm_tc3_struct', and `SCM_STRUCT_DATA (vtable)' is 2 words after VTABLE by
1030 GC_REGISTER_DISPLACEMENT (2 * sizeof (scm_t_bits
) + scm_tc3_struct
);
1032 /* In the general case, `SCM_STRUCT_DATA (obj)' points 2 words after the
1033 beginning of a GC-allocated region; that region is different from that of
1034 OBJ once OBJ has undergone class redefinition. */
1035 GC_REGISTER_DISPLACEMENT (2 * sizeof (scm_t_bits
));
1037 required_vtable_fields
= scm_from_locale_string (SCM_VTABLE_BASE_LAYOUT
);
1038 required_applicable_fields
= scm_from_locale_string (SCM_APPLICABLE_BASE_LAYOUT
);
1039 required_applicable_with_setter_fields
= scm_from_locale_string (SCM_APPLICABLE_WITH_SETTER_BASE_LAYOUT
);
1041 scm_standard_vtable_vtable
=
1042 scm_make_vtable_vtable (scm_nullstr
, SCM_INUM0
, SCM_EOL
);
1044 scm_applicable_struct_vtable_vtable
=
1045 scm_make_struct (scm_standard_vtable_vtable
, SCM_INUM0
,
1046 scm_list_1 (scm_make_struct_layout (required_vtable_fields
)));
1047 SCM_SET_VTABLE_FLAGS (scm_applicable_struct_vtable_vtable
,
1048 SCM_VTABLE_FLAG_APPLICABLE_VTABLE
);
1049 scm_c_define ("<applicable-struct-vtable>", scm_applicable_struct_vtable_vtable
);
1051 scm_applicable_struct_with_setter_vtable_vtable
=
1052 scm_make_struct (scm_standard_vtable_vtable
, SCM_INUM0
,
1053 scm_list_1 (scm_make_struct_layout (required_vtable_fields
)));
1054 SCM_SET_VTABLE_FLAGS (scm_applicable_struct_with_setter_vtable_vtable
,
1055 SCM_VTABLE_FLAG_APPLICABLE_VTABLE
| SCM_VTABLE_FLAG_SETTER_VTABLE
);
1056 scm_c_define ("<applicable-struct-with-setter-vtable>", scm_applicable_struct_with_setter_vtable_vtable
);
1058 scm_c_define ("vtable-index-layout", scm_from_int (scm_vtable_index_layout
));
1059 scm_c_define ("vtable-index-printer",
1060 scm_from_int (scm_vtable_index_instance_printer
));
1061 scm_c_define ("vtable-offset-user", scm_from_int (scm_vtable_offset_user
));
1062 #include "libguile/struct.x"