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/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_applicable_struct_vtable_vtable
;
57 SCM scm_applicable_struct_with_setter_vtable_vtable
;
58 SCM scm_standard_vtable_vtable
;
62 SCM_DEFINE (scm_make_struct_layout
, "make-struct-layout", 1, 0, 0,
64 "Return a new structure layout object.\n\n"
65 "@var{fields} must be a string made up of pairs of characters\n"
66 "strung together. The first character of each pair describes a field\n"
67 "type, the second a field protection. Allowed types are 'p' for\n"
68 "GC-protected Scheme data, 'u' for unprotected binary data, and 's' for\n"
69 "a field that points to the structure itself. Allowed protections\n"
70 "are 'w' for mutable fields, 'h' for hidden fields, 'r' for read-only\n"
71 "fields, and 'o' for opaque fields.\n\n"
72 "Hidden fields are writable, but they will not consume an initializer arg\n"
73 "passed to @code{make-struct}. They are useful to add slots to a struct\n"
74 "in a way that preserves backward-compatibility with existing calls to\n"
75 "@code{make-struct}, especially for derived vtables.\n\n"
76 "The last field protection specification may be capitalized to indicate\n"
77 "that the field is a tail-array.")
78 #define FUNC_NAME s_scm_make_struct_layout
83 SCM_VALIDATE_STRING (1, fields
);
89 len
= scm_i_string_length (fields
);
91 SCM_MISC_ERROR ("odd length field specification: ~S",
94 for (x
= 0; x
< len
; x
+= 2)
96 switch (c
= scm_i_string_ref (fields
, x
))
107 SCM_MISC_ERROR ("unrecognized field type: ~S",
108 scm_list_1 (SCM_MAKE_CHAR (c
)));
111 switch (c
= scm_i_string_ref (fields
, x
+ 1))
115 if (scm_i_string_ref (fields
, x
) == 's')
116 SCM_MISC_ERROR ("self fields not writable", SCM_EOL
);
123 if (scm_i_string_ref (fields
, x
) == 's')
124 SCM_MISC_ERROR ("self fields not allowed in tail array",
127 SCM_MISC_ERROR ("tail array field must be last field in layout",
131 SCM_MISC_ERROR ("unrecognized ref specification: ~S",
132 scm_list_1 (SCM_MAKE_CHAR (c
)));
135 if (scm_i_string_ref (fields
, x
, 'd'))
137 if (!scm_i_string_ref (fields
, x
+2, '-'))
138 SCM_MISC_ERROR ("missing dash field at position ~A",
139 scm_list_1 (scm_from_int (x
/ 2)));
145 new_sym
= scm_string_to_symbol (fields
);
147 scm_remember_upto_here_1 (fields
);
153 /* Check whether VTABLE instances have a simple layout (i.e., either only "pr"
154 or only "pw" fields) and update its flags accordingly. */
156 set_vtable_layout_flags (SCM vtable
)
160 const char *c_layout
;
161 scm_t_bits flags
= SCM_VTABLE_FLAG_SIMPLE
;
163 layout
= SCM_VTABLE_LAYOUT (vtable
);
164 c_layout
= scm_i_symbol_chars (layout
);
165 len
= scm_i_symbol_length (layout
);
167 assert (len
% 2 == 0);
169 /* Update FLAGS according to LAYOUT. */
171 field
< len
&& flags
& SCM_VTABLE_FLAG_SIMPLE
;
174 if (c_layout
[field
] != 'p')
177 switch (c_layout
[field
+ 1])
182 flags
|= SCM_VTABLE_FLAG_SIMPLE_RW
;
187 flags
&= ~SCM_VTABLE_FLAG_SIMPLE_RW
;
195 if (flags
& SCM_VTABLE_FLAG_SIMPLE
)
197 /* VTABLE is simple so update its flags and record the size of its
199 SCM_SET_VTABLE_FLAGS (vtable
, flags
);
200 SCM_STRUCT_DATA_SET (vtable
, scm_vtable_index_size
, len
/ 2);
205 scm_is_valid_vtable_layout (SCM layout
)
208 const char *c_layout
;
210 c_layout
= scm_i_symbol_chars (layout
);
211 len
= scm_i_symbol_length (layout
);
216 for (n
= 0; n
< len
; n
+= 2)
222 switch (c_layout
[n
+1])
244 /* Have OBJ, a newly created vtable, inherit flags from VTABLE. VTABLE is a
245 vtable-vtable and OBJ is an instance of VTABLE. */
247 scm_i_struct_inherit_vtable_magic (SCM vtable
, SCM obj
)
248 #define FUNC_NAME "%inherit-vtable-magic"
250 /* Verily, what is the deal here, you ask? Basically, we need to know a couple
251 of properties of structures at runtime. For example, "is this structure a
252 vtable of vtables (a metaclass)?"; also, "is this structure applicable?".
253 Both of these questions also imply a certain layout of the structure. So
254 instead of checking the layout at runtime, what we do is pre-verify the
255 layout -- so that at runtime we can just check the applicable flag and
256 dispatch directly to the Scheme procedure in slot 0. */
259 /* Verify that OBJ is a valid vtable. */
260 if (! scm_is_valid_vtable_layout (SCM_VTABLE_LAYOUT (obj
)))
261 SCM_MISC_ERROR ("invalid layout for new vtable: ~a",
262 scm_list_1 (SCM_VTABLE_LAYOUT (obj
)));
264 set_vtable_layout_flags (obj
);
266 /* If OBJ's vtable is compatible with the required vtable (class) layout, it
268 olayout
= scm_symbol_to_string (SCM_VTABLE_LAYOUT (obj
));
269 if (scm_is_true (scm_leq_p (scm_string_length (required_vtable_fields
),
270 scm_string_length (olayout
)))
271 && scm_is_true (scm_string_eq (olayout
, required_vtable_fields
,
273 scm_string_length (required_vtable_fields
),
275 scm_string_length (required_vtable_fields
))))
276 SCM_SET_VTABLE_FLAGS (obj
, SCM_VTABLE_FLAG_VTABLE
);
278 /* Finally, if OBJ is an applicable class, verify that its vtable is
279 compatible with the required applicable layout. */
280 if (SCM_VTABLE_FLAG_IS_SET (vtable
, SCM_VTABLE_FLAG_SETTER_VTABLE
))
282 if (scm_is_false (scm_string_eq (olayout
, required_applicable_with_setter_fields
,
286 scm_from_size_t (4))))
287 SCM_MISC_ERROR ("invalid applicable-with-setter struct layout",
288 scm_list_1 (olayout
));
289 SCM_SET_VTABLE_FLAGS (obj
, SCM_VTABLE_FLAG_APPLICABLE
| SCM_VTABLE_FLAG_SETTER
);
291 else if (SCM_VTABLE_FLAG_IS_SET (vtable
, SCM_VTABLE_FLAG_APPLICABLE_VTABLE
))
293 if (scm_is_false (scm_string_eq (olayout
, required_applicable_fields
,
297 scm_from_size_t (2))))
298 SCM_MISC_ERROR ("invalid applicable struct layout",
299 scm_list_1 (olayout
));
300 SCM_SET_VTABLE_FLAGS (obj
, SCM_VTABLE_FLAG_APPLICABLE
);
303 SCM_SET_VTABLE_FLAGS (obj
, SCM_VTABLE_FLAG_VALIDATED
);
309 scm_struct_init (SCM handle
, SCM layout
, size_t n_tail
,
310 size_t n_inits
, scm_t_bits
*inits
)
315 vtable
= SCM_STRUCT_VTABLE (handle
);
316 mem
= SCM_STRUCT_DATA (handle
);
318 if (SCM_UNPACK (vtable
) != 0
319 && SCM_VTABLE_FLAG_IS_SET (vtable
, SCM_VTABLE_FLAG_SIMPLE
)
321 && n_inits
== SCM_STRUCT_DATA_REF (vtable
, scm_vtable_index_size
))
322 /* The fast path: HANDLE has N_INITS "p" fields. */
323 memcpy (mem
, inits
, n_inits
* sizeof (SCM
));
326 scm_t_wchar prot
= 0;
327 int n_fields
= scm_i_symbol_length (layout
) / 2;
330 size_t inits_idx
= 0;
338 prot
= scm_i_symbol_ref (layout
, i
+1);
339 if (SCM_LAYOUT_TAILP (prot
))
342 prot
= prot
== 'R' ? 'r' : prot
== 'W' ? 'w' : 'o';
343 *mem
++ = (scm_t_bits
)n_tail
;
344 n_fields
+= n_tail
- 1;
349 switch (scm_i_symbol_ref (layout
, i
))
352 if ((prot
!= 'r' && prot
!= 'w') || inits_idx
== n_inits
)
356 *mem
= scm_to_ulong (SCM_PACK (inits
[inits_idx
]));
362 if ((prot
!= 'r' && prot
!= 'w') || inits_idx
== n_inits
)
363 *mem
= SCM_UNPACK (SCM_BOOL_F
);
366 *mem
= inits
[inits_idx
];
373 *mem
= SCM_UNPACK (handle
);
384 SCM_DEFINE (scm_struct_p
, "struct?", 1, 0, 0,
386 "Return @code{#t} iff @var{x} is a structure object, else\n"
388 #define FUNC_NAME s_scm_struct_p
390 return scm_from_bool(SCM_STRUCTP (x
));
394 SCM_DEFINE (scm_struct_vtable_p
, "struct-vtable?", 1, 0, 0,
396 "Return @code{#t} iff @var{x} is a vtable structure.")
397 #define FUNC_NAME s_scm_struct_vtable_p
400 || !SCM_STRUCT_VTABLE_FLAG_IS_SET (x
, SCM_VTABLE_FLAG_VTABLE
))
402 if (!SCM_VTABLE_FLAG_IS_SET (x
, SCM_VTABLE_FLAG_VALIDATED
))
403 SCM_MISC_ERROR ("vtable has invalid layout: ~A",
404 scm_list_1 (SCM_VTABLE_LAYOUT (x
)));
410 /* Finalization: invoke the finalizer of the struct pointed to by PTR. */
412 struct_finalizer_trampoline (GC_PTR ptr
, GC_PTR unused_data
)
414 SCM obj
= PTR2SCM (ptr
);
415 scm_t_struct_finalize finalize
= SCM_STRUCT_FINALIZER (obj
);
421 /* All struct data must be allocated at an address whose bottom three
422 bits are zero. This is because the tag for a struct lives in the
423 bottom three bits of the struct's car, and the upper bits point to
424 the data of its vtable, which is a struct itself. Thus, if the
425 address of that data doesn't end in three zeros, tagging it will
428 I suppose we should make it clear here that, the data must be 8-byte aligned,
429 *within* the struct, and the struct itself should be 8-byte aligned. In
430 practice we ensure this because the data starts two words into a struct.
432 This function allocates an 8-byte aligned block of memory, whose first word
433 points to the given vtable data, then a data pointer, then n_words of data.
436 scm_i_alloc_struct (scm_t_bits
*vtable_data
, int n_words
)
440 ret
= scm_words ((scm_t_bits
)vtable_data
| scm_tc3_struct
, n_words
+ 2);
441 SCM_SET_CELL_WORD_1 (ret
, (scm_t_bits
)SCM_CELL_OBJECT_LOC (ret
, 2));
443 /* vtable_data can be null when making a vtable vtable */
444 if (vtable_data
&& vtable_data
[scm_vtable_index_instance_finalize
])
446 /* Register a finalizer for the newly created instance. */
447 GC_finalization_proc prev_finalizer
;
448 GC_PTR prev_finalizer_data
;
449 GC_REGISTER_FINALIZER_NO_ORDER (SCM_HEAP_OBJECT_BASE (ret
),
450 struct_finalizer_trampoline
,
453 &prev_finalizer_data
);
461 scm_c_make_structv (SCM vtable
, size_t n_tail
, size_t n_init
, scm_t_bits
*init
)
462 #define FUNC_NAME "make-struct"
468 SCM_VALIDATE_VTABLE (1, vtable
);
470 layout
= SCM_VTABLE_LAYOUT (vtable
);
471 basic_size
= scm_i_symbol_length (layout
) / 2;
475 SCM layout_str
, last_char
;
480 SCM_MISC_ERROR ("tail array not allowed unless layout ends R, W, or O", SCM_EOL
);
483 layout_str
= scm_symbol_to_string (layout
);
484 last_char
= scm_string_ref (layout_str
,
485 scm_from_size_t (2 * basic_size
- 1));
486 if (! SCM_LAYOUT_TAILP (SCM_CHAR (last_char
)))
490 obj
= scm_i_alloc_struct (SCM_STRUCT_DATA (vtable
), basic_size
+ n_tail
);
492 scm_struct_init (obj
, layout
, n_tail
, n_init
, init
);
494 /* If we're making a vtable, validate its layout and inherit
495 flags. However we allow for separation of allocation and
496 initialization, to humor GOOPS, so only validate if the layout was
497 passed as an initarg. */
498 if (SCM_VTABLE_FLAG_IS_SET (vtable
, SCM_VTABLE_FLAG_VTABLE
)
499 && scm_is_true (SCM_VTABLE_LAYOUT (obj
)))
500 scm_i_struct_inherit_vtable_magic (vtable
, obj
);
507 scm_c_make_struct (SCM vtable
, size_t n_tail
, size_t n_init
, scm_t_bits init
, ...)
513 v
= alloca (sizeof (scm_t_bits
) * n_init
);
515 va_start (foo
, init
);
516 for (i
= 0; i
< n_init
; i
++)
519 init
= va_arg (foo
, scm_t_bits
);
523 return scm_c_make_structv (vtable
, n_tail
, n_init
, v
);
526 SCM_DEFINE (scm_make_struct
, "make-struct", 2, 0, 1,
527 (SCM vtable
, SCM tail_array_size
, SCM init
),
528 "Create a new structure.\n\n"
529 "@var{type} must be a vtable structure (@pxref{Vtables}).\n\n"
530 "@var{tail-elts} must be a non-negative integer. If the layout\n"
531 "specification indicated by @var{type} includes a tail-array,\n"
532 "this is the number of elements allocated to that array.\n\n"
533 "The @var{init1}, @dots{} are optional arguments describing how\n"
534 "successive fields of the structure should be initialized. Only fields\n"
535 "with protection 'r' or 'w' can be initialized, except for fields of\n"
536 "type 's', which are automatically initialized to point to the new\n"
537 "structure itself. Fields with protection 'o' can not be initialized by\n"
538 "Scheme programs.\n\n"
539 "If fewer optional arguments than initializable fields are supplied,\n"
540 "fields of type 'p' get default value #f while fields of type 'u' are\n"
541 "initialized to 0.\n\n"
542 "For more information, see the documentation for @code{make-vtable-vtable}.")
543 #define FUNC_NAME s_scm_make_struct
549 SCM_VALIDATE_VTABLE (1, vtable
);
550 ilen
= scm_ilength (init
);
552 SCM_MISC_ERROR ("Rest arguments do not form a proper list.", SCM_EOL
);
554 n_init
= (size_t)ilen
;
556 /* best to use alloca, but init could be big, so hack to avoid a possible
559 v
= alloca (n_init
* sizeof(scm_t_bits
));
561 v
= scm_gc_malloc (n_init
* sizeof(scm_t_bits
), "struct");
563 for (i
= 0; i
< n_init
; i
++, init
= SCM_CDR (init
))
564 v
[i
] = SCM_UNPACK (SCM_CAR (init
));
566 return scm_c_make_structv (vtable
, scm_to_size_t (tail_array_size
), n_init
, v
);
572 SCM_DEFINE (scm_make_vtable_vtable
, "make-vtable-vtable", 2, 0, 1,
573 (SCM user_fields
, SCM tail_array_size
, SCM init
),
574 "Return a new, self-describing vtable structure.\n\n"
575 "@var{user-fields} is a string describing user defined fields of the\n"
576 "vtable beginning at index @code{vtable-offset-user}\n"
577 "(see @code{make-struct-layout}).\n\n"
578 "@var{tail-size} specifies the size of the tail-array (if any) of\n"
580 "@var{init1}, @dots{} are the optional initializers for the fields of\n"
582 "Vtables have one initializable system field---the struct printer.\n"
583 "This field comes before the user fields in the initializers passed\n"
584 "to @code{make-vtable-vtable} and @code{make-struct}, and thus works as\n"
585 "a third optional argument to @code{make-vtable-vtable} and a fourth to\n"
586 "@code{make-struct} when creating vtables:\n\n"
587 "If the value is a procedure, it will be called instead of the standard\n"
588 "printer whenever a struct described by this vtable is printed.\n"
589 "The procedure will be called with arguments STRUCT and PORT.\n\n"
590 "The structure of a struct is described by a vtable, so the vtable is\n"
591 "in essence the type of the struct. The vtable is itself a struct with\n"
592 "a vtable. This could go on forever if it weren't for the\n"
593 "vtable-vtables which are self-describing vtables, and thus terminate\n"
595 "There are several potential ways of using structs, but the standard\n"
596 "one is to use three kinds of structs, together building up a type\n"
597 "sub-system: one vtable-vtable working as the root and one or several\n"
598 "\"types\", each with a set of \"instances\". (The vtable-vtable should be\n"
599 "compared to the class <class> which is the class of itself.)\n\n"
601 "(define ball-root (make-vtable-vtable \"pr\" 0))\n\n"
602 "(define (make-ball-type ball-color)\n"
603 " (make-struct ball-root 0\n"
604 " (make-struct-layout \"pw\")\n"
605 " (lambda (ball port)\n"
606 " (format port \"#<a ~A ball owned by ~A>\"\n"
610 "(define (color ball) (struct-ref (struct-vtable ball) vtable-offset-user))\n"
611 "(define (owner ball) (struct-ref ball 0))\n\n"
612 "(define red (make-ball-type 'red))\n"
613 "(define green (make-ball-type 'green))\n\n"
614 "(define (make-ball type owner) (make-struct type 0 owner))\n\n"
615 "(define ball (make-ball green 'Nisse))\n"
616 "ball @result{} #<a green ball owned by Nisse>\n"
618 #define FUNC_NAME s_scm_make_vtable_vtable
620 SCM fields
, layout
, obj
;
621 size_t basic_size
, n_tail
, i
, n_init
;
625 SCM_VALIDATE_STRING (1, user_fields
);
626 ilen
= scm_ilength (init
);
628 SCM_MISC_ERROR ("Rest arguments do not form a proper list.", SCM_EOL
);
630 n_init
= (size_t)ilen
+ 1; /* + 1 for the layout */
632 /* best to use alloca, but init could be big, so hack to avoid a possible
635 v
= alloca (n_init
* sizeof(scm_t_bits
));
637 v
= scm_gc_malloc (n_init
* sizeof(scm_t_bits
), "struct");
639 fields
= scm_string_append (scm_list_2 (required_vtable_fields
,
641 layout
= scm_make_struct_layout (fields
);
642 if (!scm_is_valid_vtable_layout (layout
))
643 SCM_MISC_ERROR ("invalid user fields", scm_list_1 (user_fields
));
645 basic_size
= scm_i_symbol_length (layout
) / 2;
646 n_tail
= scm_to_size_t (tail_array_size
);
649 v
[i
++] = SCM_UNPACK (layout
);
650 for (; i
< n_init
; i
++, init
= SCM_CDR (init
))
651 v
[i
] = SCM_UNPACK (SCM_CAR (init
));
653 SCM_CRITICAL_SECTION_START
;
654 obj
= scm_i_alloc_struct (NULL
, basic_size
+ n_tail
);
655 /* Make it so that the vtable of OBJ is itself. */
656 SCM_SET_CELL_WORD_0 (obj
, (scm_t_bits
) SCM_STRUCT_DATA (obj
) | scm_tc3_struct
);
657 SCM_CRITICAL_SECTION_END
;
659 scm_struct_init (obj
, layout
, n_tail
, n_init
, v
);
660 SCM_SET_VTABLE_FLAGS (obj
,
661 SCM_VTABLE_FLAG_VTABLE
| SCM_VTABLE_FLAG_VALIDATED
);
668 SCM_DEFINE (scm_make_vtable
, "make-vtable", 1, 1, 0,
669 (SCM fields
, SCM printer
),
670 "Create a vtable, for creating structures with the given\n"
673 "The optional @var{printer} argument is a function to be called\n"
674 "@code{(@var{printer} struct port)} on the structures created.\n"
675 "It should look at @var{struct} and write to @var{port}.")
676 #define FUNC_NAME s_scm_make_vtable
678 if (SCM_UNBNDP (printer
))
679 printer
= SCM_BOOL_F
;
681 return scm_make_struct (scm_standard_vtable_vtable
, SCM_INUM0
,
682 scm_list_2 (scm_make_struct_layout (fields
),
688 /* Return true if S1 and S2 are equal structures, i.e., if their vtable and
689 contents are the same. Field protections are honored. Thus, it is an
690 error to test the equality of structures that contain opaque fields. */
692 scm_i_struct_equalp (SCM s1
, SCM s2
)
693 #define FUNC_NAME "scm_i_struct_equalp"
695 SCM vtable1
, vtable2
, layout
;
696 size_t struct_size
, field_num
;
698 SCM_VALIDATE_STRUCT (1, s1
);
699 SCM_VALIDATE_STRUCT (2, s2
);
701 vtable1
= SCM_STRUCT_VTABLE (s1
);
702 vtable2
= SCM_STRUCT_VTABLE (s2
);
704 if (!scm_is_eq (vtable1
, vtable2
))
707 layout
= SCM_STRUCT_LAYOUT (s1
);
708 struct_size
= scm_i_symbol_length (layout
) / 2;
710 for (field_num
= 0; field_num
< struct_size
; field_num
++)
715 /* We have to use `scm_struct_ref ()' here so that fields are accessed
716 consistently, notably wrt. field types and access rights. */
717 s_field_num
= scm_from_size_t (field_num
);
718 field1
= scm_struct_ref (s1
, s_field_num
);
719 field2
= scm_struct_ref (s2
, s_field_num
);
721 /* Self-referencing fields (type `s') must be skipped to avoid infinite
723 if (!(scm_is_eq (field1
, s1
) && (scm_is_eq (field2
, s2
))))
724 if (scm_is_false (scm_equal_p (field1
, field2
)))
728 /* FIXME: Tail elements should be tested for equality. */
738 SCM_DEFINE (scm_struct_ref
, "struct-ref", 2, 0, 0,
739 (SCM handle
, SCM pos
),
740 "Access the @var{n}th field of @var{struct}.\n\n"
741 "If the field is of type 'p', then it can be set to an arbitrary value.\n\n"
742 "If the field is of type 'u', then it can only be set to a non-negative\n"
743 "integer value small enough to fit in one machine word.")
744 #define FUNC_NAME s_scm_struct_ref
746 SCM vtable
, answer
= SCM_UNDEFINED
;
750 SCM_VALIDATE_STRUCT (1, handle
);
752 vtable
= SCM_STRUCT_VTABLE (handle
);
753 data
= SCM_STRUCT_DATA (handle
);
754 p
= scm_to_size_t (pos
);
756 if (SCM_LIKELY (SCM_VTABLE_FLAG_IS_SET (vtable
, SCM_VTABLE_FLAG_SIMPLE
)
757 && p
< SCM_STRUCT_DATA_REF (vtable
, scm_vtable_index_size
)))
758 /* The fast path: HANDLE is a struct with only "p" fields. */
759 answer
= SCM_PACK (data
[p
]);
763 size_t layout_len
, n_fields
;
764 scm_t_wchar field_type
= 0;
766 layout
= SCM_STRUCT_LAYOUT (handle
);
767 layout_len
= scm_i_symbol_length (layout
);
768 n_fields
= layout_len
/ 2;
770 if (SCM_LAYOUT_TAILP (scm_i_symbol_ref (layout
, layout_len
- 1)))
771 n_fields
+= data
[n_fields
- 1];
773 SCM_ASSERT_RANGE (1, pos
, p
< n_fields
);
775 if (p
* 2 < layout_len
)
778 field_type
= scm_i_symbol_ref (layout
, p
* 2);
779 ref
= scm_i_symbol_ref (layout
, p
* 2 + 1);
780 if ((ref
!= 'r') && (ref
!= 'w') && (ref
!= 'h'))
782 if ((ref
== 'R') || (ref
== 'W'))
785 SCM_MISC_ERROR ("ref denied for field ~A", scm_list_1 (pos
));
788 else if (scm_i_symbol_ref (layout
, layout_len
- 1) != 'O')
789 field_type
= scm_i_symbol_ref(layout
, layout_len
- 2);
791 SCM_MISC_ERROR ("ref denied for field ~A", scm_list_1 (pos
));
796 answer
= scm_from_ulong (data
[p
]);
801 answer
= scm_from_long (data
[p
]);
805 answer
= scm_make_real (*((double *)&(data
[p
])));
811 answer
= SCM_PACK (data
[p
]);
816 SCM_MISC_ERROR ("unrecognized field type: ~S",
817 scm_list_1 (SCM_MAKE_CHAR (field_type
)));
826 SCM_DEFINE (scm_struct_set_x
, "struct-set!", 3, 0, 0,
827 (SCM handle
, SCM pos
, SCM val
),
828 "Set the slot of the structure @var{handle} with index @var{pos}\n"
829 "to @var{val}. Signal an error if the slot can not be written\n"
831 #define FUNC_NAME s_scm_struct_set_x
837 SCM_VALIDATE_STRUCT (1, handle
);
839 vtable
= SCM_STRUCT_VTABLE (handle
);
840 data
= SCM_STRUCT_DATA (handle
);
841 p
= scm_to_size_t (pos
);
843 if (SCM_LIKELY (SCM_VTABLE_FLAG_IS_SET (vtable
, SCM_VTABLE_FLAG_SIMPLE
)
844 && SCM_VTABLE_FLAG_IS_SET (vtable
, SCM_VTABLE_FLAG_SIMPLE_RW
)
845 && p
< SCM_STRUCT_DATA_REF (vtable
, scm_vtable_index_size
)))
846 /* The fast path: HANDLE is a struct with only "pw" fields. */
847 data
[p
] = SCM_UNPACK (val
);
851 size_t layout_len
, n_fields
;
852 scm_t_wchar field_type
= 0;
854 layout
= SCM_STRUCT_LAYOUT (handle
);
855 layout_len
= scm_i_symbol_length (layout
);
856 n_fields
= layout_len
/ 2;
858 if (SCM_LAYOUT_TAILP (scm_i_symbol_ref (layout
, layout_len
- 1)))
859 n_fields
+= data
[n_fields
- 1];
861 SCM_ASSERT_RANGE (1, pos
, p
< n_fields
);
863 if (p
* 2 < layout_len
)
866 field_type
= scm_i_symbol_ref (layout
, p
* 2);
867 set_x
= scm_i_symbol_ref (layout
, p
* 2 + 1);
868 if (set_x
!= 'w' && set_x
!= 'h')
869 SCM_MISC_ERROR ("set! denied for field ~A", scm_list_1 (pos
));
871 else if (scm_i_symbol_ref (layout
, layout_len
- 1) == 'W')
872 field_type
= scm_i_symbol_ref (layout
, layout_len
- 2);
874 SCM_MISC_ERROR ("set! denied for field ~A", scm_list_1 (pos
));
879 data
[p
] = SCM_NUM2ULONG (3, val
);
884 data
[p
] = SCM_NUM2LONG (3, val
);
888 *((double *)&(data
[p
])) = scm_num2dbl (val
, (char *)SCM_ARG3
);
893 data
[p
] = SCM_UNPACK (val
);
897 SCM_MISC_ERROR ("self fields immutable", SCM_EOL
);
900 SCM_MISC_ERROR ("unrecognized field type: ~S",
901 scm_list_1 (SCM_MAKE_CHAR (field_type
)));
910 SCM_DEFINE (scm_struct_vtable
, "struct-vtable", 1, 0, 0,
912 "Return the vtable structure that describes the type of @var{struct}.")
913 #define FUNC_NAME s_scm_struct_vtable
915 SCM_VALIDATE_STRUCT (1, handle
);
916 return SCM_STRUCT_VTABLE (handle
);
921 SCM_DEFINE (scm_struct_vtable_tag
, "struct-vtable-tag", 1, 0, 0,
923 "Return the vtable tag of the structure @var{handle}.")
924 #define FUNC_NAME s_scm_struct_vtable_tag
926 SCM_VALIDATE_VTABLE (1, handle
);
927 return scm_from_unsigned_integer
928 (((scm_t_bits
)SCM_STRUCT_DATA (handle
)) >> 3);
932 /* {Associating names and classes with vtables}
934 * The name of a vtable should probably be stored as a slot. This is
935 * a backward compatible solution until agreement has been achieved on
936 * how to associate names with vtables.
940 scm_struct_ihashq (SCM obj
, unsigned long n
, void *closure
)
942 /* The length of the hash table should be a relative prime it's not
943 necessary to shift down the address. */
944 return SCM_UNPACK (obj
) % n
;
947 SCM_DEFINE (scm_struct_vtable_name
, "struct-vtable-name", 1, 0, 0,
949 "Return the name of the vtable @var{vtable}.")
950 #define FUNC_NAME s_scm_struct_vtable_name
952 SCM_VALIDATE_VTABLE (1, vtable
);
953 return SCM_VTABLE_NAME (vtable
);
957 SCM_DEFINE (scm_set_struct_vtable_name_x
, "set-struct-vtable-name!", 2, 0, 0,
958 (SCM vtable
, SCM name
),
959 "Set the name of the vtable @var{vtable} to @var{name}.")
960 #define FUNC_NAME s_scm_set_struct_vtable_name_x
962 SCM_VALIDATE_VTABLE (1, vtable
);
963 SCM_VALIDATE_SYMBOL (2, name
);
964 SCM_SET_VTABLE_NAME (vtable
, name
);
965 /* FIXME: remove this, and implement proper struct classes instead.
966 (Vtables *are* classes.) */
967 scm_i_define_class_for_vtable (vtable
);
968 return SCM_UNSPECIFIED
;
976 scm_print_struct (SCM exp
, SCM port
, scm_print_state
*pstate
)
978 if (scm_is_true (scm_procedure_p (SCM_STRUCT_PRINTER (exp
))))
979 scm_printer_apply (SCM_STRUCT_PRINTER (exp
), exp
, port
, pstate
);
982 SCM vtable
= SCM_STRUCT_VTABLE (exp
);
983 SCM name
= scm_struct_vtable_name (vtable
);
984 scm_puts_unlocked ("#<", port
);
985 if (scm_is_true (name
))
987 scm_display (name
, port
);
988 scm_putc_unlocked (' ', port
);
992 if (SCM_VTABLE_FLAG_IS_SET (vtable
, SCM_VTABLE_FLAG_VTABLE
))
993 scm_puts_unlocked ("vtable:", port
);
995 scm_puts_unlocked ("struct:", port
);
996 scm_uintprint (SCM_UNPACK (vtable
), 16, port
);
997 scm_putc_unlocked (' ', port
);
998 scm_write (SCM_VTABLE_LAYOUT (vtable
), port
);
999 scm_putc_unlocked (' ', port
);
1001 scm_uintprint (SCM_UNPACK (exp
), 16, port
);
1003 if (SCM_STRUCT_APPLICABLE_P (exp
))
1005 if (scm_is_true (SCM_STRUCT_PROCEDURE (exp
)))
1007 scm_puts_unlocked (" proc: ", port
);
1008 if (scm_is_true (scm_procedure_p (SCM_STRUCT_PROCEDURE (exp
))))
1009 scm_write (SCM_STRUCT_PROCEDURE (exp
), port
);
1011 scm_puts_unlocked ("(not a procedure?)", port
);
1013 if (SCM_STRUCT_SETTER_P (exp
))
1015 scm_puts_unlocked (" setter: ", port
);
1016 scm_write (SCM_STRUCT_SETTER (exp
), port
);
1019 scm_putc_unlocked ('>', port
);
1026 /* The first word of a struct is equal to `SCM_STRUCT_DATA (vtable) +
1027 scm_tc3_struct', and `SCM_STRUCT_DATA (vtable)' is 2 words after VTABLE by
1029 GC_REGISTER_DISPLACEMENT (2 * sizeof (scm_t_bits
) + scm_tc3_struct
);
1031 /* In the general case, `SCM_STRUCT_DATA (obj)' points 2 words after the
1032 beginning of a GC-allocated region; that region is different from that of
1033 OBJ once OBJ has undergone class redefinition. */
1034 GC_REGISTER_DISPLACEMENT (2 * sizeof (scm_t_bits
));
1036 required_vtable_fields
= scm_from_locale_string (SCM_VTABLE_BASE_LAYOUT
);
1037 required_applicable_fields
= scm_from_locale_string (SCM_APPLICABLE_BASE_LAYOUT
);
1038 required_applicable_with_setter_fields
= scm_from_locale_string (SCM_APPLICABLE_WITH_SETTER_BASE_LAYOUT
);
1040 scm_standard_vtable_vtable
=
1041 scm_make_vtable_vtable (scm_nullstr
, SCM_INUM0
, SCM_EOL
);
1043 scm_applicable_struct_vtable_vtable
=
1044 scm_make_struct (scm_standard_vtable_vtable
, SCM_INUM0
,
1045 scm_list_1 (scm_make_struct_layout (required_vtable_fields
)));
1046 SCM_SET_VTABLE_FLAGS (scm_applicable_struct_vtable_vtable
,
1047 SCM_VTABLE_FLAG_APPLICABLE_VTABLE
);
1048 scm_c_define ("<applicable-struct-vtable>", scm_applicable_struct_vtable_vtable
);
1050 scm_applicable_struct_with_setter_vtable_vtable
=
1051 scm_make_struct (scm_standard_vtable_vtable
, SCM_INUM0
,
1052 scm_list_1 (scm_make_struct_layout (required_vtable_fields
)));
1053 SCM_SET_VTABLE_FLAGS (scm_applicable_struct_with_setter_vtable_vtable
,
1054 SCM_VTABLE_FLAG_APPLICABLE_VTABLE
| SCM_VTABLE_FLAG_SETTER_VTABLE
);
1055 scm_c_define ("<applicable-struct-with-setter-vtable>", scm_applicable_struct_with_setter_vtable_vtable
);
1057 scm_c_define ("vtable-index-layout", scm_from_int (scm_vtable_index_layout
));
1058 scm_c_define ("vtable-index-printer",
1059 scm_from_int (scm_vtable_index_instance_printer
));
1060 scm_c_define ("vtable-offset-user", scm_from_int (scm_vtable_offset_user
));
1061 #include "libguile/struct.x"