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 #define SCM_BUILDING_DEPRECATED_CODE
29 #include "libguile/_scm.h"
30 #include "libguile/async.h"
31 #include "libguile/chars.h"
32 #include "libguile/eval.h"
33 #include "libguile/alist.h"
34 #include "libguile/hashtab.h"
35 #include "libguile/ports.h"
36 #include "libguile/strings.h"
37 #include "libguile/srfi-13.h"
39 #include "libguile/validate.h"
40 #include "libguile/struct.h"
42 #include "libguile/eq.h"
48 #include "libguile/bdw-gc.h"
52 /* A needlessly obscure test. */
53 #define SCM_LAYOUT_TAILP(X) (((X) & 32) == 0) /* R, W or O */
55 static SCM required_vtable_fields
= SCM_BOOL_F
;
56 static SCM required_applicable_fields
= SCM_BOOL_F
;
57 static SCM required_applicable_with_setter_fields
= 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])
184 flags
|= SCM_VTABLE_FLAG_SIMPLE_RW
;
189 flags
&= ~SCM_VTABLE_FLAG_SIMPLE_RW
;
197 if (flags
& SCM_VTABLE_FLAG_SIMPLE
)
199 /* VTABLE is simple so update its flags and record the size of its
201 SCM_SET_VTABLE_FLAGS (vtable
, flags
);
202 SCM_STRUCT_DATA_SET (vtable
, scm_vtable_index_size
, len
/ 2);
207 scm_is_valid_vtable_layout (SCM layout
)
210 const char *c_layout
;
212 c_layout
= scm_i_symbol_chars (layout
);
213 len
= scm_i_symbol_length (layout
);
218 for (n
= 0; n
< len
; n
+= 2)
224 switch (c_layout
[n
+1])
246 /* Have OBJ, a newly created vtable, inherit flags from VTABLE. VTABLE is a
247 vtable-vtable and OBJ is an instance of VTABLE. */
249 scm_i_struct_inherit_vtable_magic (SCM vtable
, SCM obj
)
250 #define FUNC_NAME "%inherit-vtable-magic"
252 /* Verily, what is the deal here, you ask? Basically, we need to know a couple
253 of properties of structures at runtime. For example, "is this structure a
254 vtable of vtables (a metaclass)?"; also, "is this structure applicable?".
255 Both of these questions also imply a certain layout of the structure. So
256 instead of checking the layout at runtime, what we do is pre-verify the
257 layout -- so that at runtime we can just check the applicable flag and
258 dispatch directly to the Scheme procedure in slot 0. */
261 /* Verify that OBJ is a valid vtable. */
262 if (! scm_is_valid_vtable_layout (SCM_VTABLE_LAYOUT (obj
)))
263 SCM_MISC_ERROR ("invalid layout for new vtable: ~a",
264 scm_list_1 (SCM_VTABLE_LAYOUT (obj
)));
266 set_vtable_layout_flags (obj
);
268 /* If OBJ's vtable is compatible with the required vtable (class) layout, it
270 olayout
= scm_symbol_to_string (SCM_VTABLE_LAYOUT (obj
));
271 if (scm_is_true (scm_leq_p (scm_string_length (required_vtable_fields
),
272 scm_string_length (olayout
)))
273 && scm_is_true (scm_string_eq (olayout
, required_vtable_fields
,
275 scm_string_length (required_vtable_fields
),
277 scm_string_length (required_vtable_fields
))))
278 SCM_SET_VTABLE_FLAGS (obj
, SCM_VTABLE_FLAG_VTABLE
);
280 /* Finally, if OBJ is an applicable class, verify that its vtable is
281 compatible with the required applicable layout. */
282 if (SCM_VTABLE_FLAG_IS_SET (vtable
, SCM_VTABLE_FLAG_SETTER_VTABLE
))
284 if (scm_is_false (scm_string_eq (olayout
, required_applicable_with_setter_fields
,
288 scm_from_size_t (4))))
289 SCM_MISC_ERROR ("invalid applicable-with-setter struct layout",
290 scm_list_1 (olayout
));
291 SCM_SET_VTABLE_FLAGS (obj
, SCM_VTABLE_FLAG_APPLICABLE
| SCM_VTABLE_FLAG_SETTER
);
293 else if (SCM_VTABLE_FLAG_IS_SET (vtable
, SCM_VTABLE_FLAG_APPLICABLE_VTABLE
))
295 if (scm_is_false (scm_string_eq (olayout
, required_applicable_fields
,
299 scm_from_size_t (2))))
300 SCM_MISC_ERROR ("invalid applicable struct layout",
301 scm_list_1 (olayout
));
302 SCM_SET_VTABLE_FLAGS (obj
, SCM_VTABLE_FLAG_APPLICABLE
);
305 SCM_SET_VTABLE_FLAGS (obj
, SCM_VTABLE_FLAG_VALIDATED
);
311 scm_struct_init (SCM handle
, SCM layout
, size_t n_tail
,
312 size_t n_inits
, scm_t_bits
*inits
)
317 vtable
= SCM_STRUCT_VTABLE (handle
);
318 mem
= SCM_STRUCT_DATA (handle
);
320 if (SCM_UNPACK (vtable
) != 0
321 && SCM_VTABLE_FLAG_IS_SET (vtable
, SCM_VTABLE_FLAG_SIMPLE
)
323 && n_inits
== SCM_STRUCT_DATA_REF (vtable
, scm_vtable_index_size
))
324 /* The fast path: HANDLE has N_INITS "p" fields. */
325 memcpy (mem
, inits
, n_inits
* sizeof (SCM
));
328 scm_t_wchar prot
= 0;
329 int n_fields
= scm_i_symbol_length (layout
) / 2;
332 size_t inits_idx
= 0;
340 prot
= scm_i_symbol_ref (layout
, i
+1);
341 if (SCM_LAYOUT_TAILP (prot
))
344 prot
= prot
== 'R' ? 'r' : prot
== 'W' ? 'w' : 'o';
345 *mem
++ = (scm_t_bits
)n_tail
;
346 n_fields
+= n_tail
- 1;
351 switch (scm_i_symbol_ref (layout
, i
))
354 if ((prot
!= 'r' && prot
!= 'w') || inits_idx
== n_inits
)
358 *mem
= scm_to_ulong (SCM_PACK (inits
[inits_idx
]));
364 if ((prot
!= 'r' && prot
!= 'w') || inits_idx
== n_inits
)
365 *mem
= SCM_UNPACK (SCM_BOOL_F
);
368 *mem
= inits
[inits_idx
];
375 *mem
= SCM_UNPACK (handle
);
386 SCM_DEFINE (scm_struct_p
, "struct?", 1, 0, 0,
388 "Return @code{#t} iff @var{x} is a structure object, else\n"
390 #define FUNC_NAME s_scm_struct_p
392 return scm_from_bool(SCM_STRUCTP (x
));
396 SCM_DEFINE (scm_struct_vtable_p
, "struct-vtable?", 1, 0, 0,
398 "Return @code{#t} iff @var{x} is a vtable structure.")
399 #define FUNC_NAME s_scm_struct_vtable_p
402 || !SCM_STRUCT_VTABLE_FLAG_IS_SET (x
, SCM_VTABLE_FLAG_VTABLE
))
404 if (!SCM_VTABLE_FLAG_IS_SET (x
, SCM_VTABLE_FLAG_VALIDATED
))
405 SCM_MISC_ERROR ("vtable has invalid layout: ~A",
406 scm_list_1 (SCM_VTABLE_LAYOUT (x
)));
412 /* Finalization: invoke the finalizer of the struct pointed to by PTR. */
414 struct_finalizer_trampoline (GC_PTR ptr
, GC_PTR unused_data
)
416 SCM obj
= PTR2SCM (ptr
);
417 scm_t_struct_finalize finalize
= SCM_STRUCT_FINALIZER (obj
);
423 /* All struct data must be allocated at an address whose bottom three
424 bits are zero. This is because the tag for a struct lives in the
425 bottom three bits of the struct's car, and the upper bits point to
426 the data of its vtable, which is a struct itself. Thus, if the
427 address of that data doesn't end in three zeros, tagging it will
430 I suppose we should make it clear here that, the data must be 8-byte aligned,
431 *within* the struct, and the struct itself should be 8-byte aligned. In
432 practice we ensure this because the data starts two words into a struct.
434 This function allocates an 8-byte aligned block of memory, whose first word
435 points to the given vtable data, then a data pointer, then n_words of data.
438 scm_i_alloc_struct (scm_t_bits
*vtable_data
, int n_words
)
442 ret
= scm_words ((scm_t_bits
)vtable_data
| scm_tc3_struct
, n_words
+ 2);
443 SCM_SET_CELL_WORD_1 (ret
, (scm_t_bits
)SCM_CELL_OBJECT_LOC (ret
, 2));
445 /* vtable_data can be null when making a vtable vtable */
446 if (vtable_data
&& vtable_data
[scm_vtable_index_instance_finalize
])
448 /* Register a finalizer for the newly created instance. */
449 GC_finalization_proc prev_finalizer
;
450 GC_PTR prev_finalizer_data
;
451 GC_REGISTER_FINALIZER_NO_ORDER (SCM2PTR (ret
),
452 struct_finalizer_trampoline
,
455 &prev_finalizer_data
);
463 scm_c_make_structv (SCM vtable
, size_t n_tail
, size_t n_init
, scm_t_bits
*init
)
464 #define FUNC_NAME "make-struct"
470 SCM_VALIDATE_VTABLE (1, vtable
);
472 layout
= SCM_VTABLE_LAYOUT (vtable
);
473 basic_size
= scm_i_symbol_length (layout
) / 2;
477 SCM layout_str
, last_char
;
482 SCM_MISC_ERROR ("tail array not allowed unless layout ends R, W, or O", SCM_EOL
);
485 layout_str
= scm_symbol_to_string (layout
);
486 last_char
= scm_string_ref (layout_str
,
487 scm_from_size_t (2 * basic_size
- 1));
488 if (! SCM_LAYOUT_TAILP (SCM_CHAR (last_char
)))
492 obj
= scm_i_alloc_struct (SCM_STRUCT_DATA (vtable
), basic_size
+ n_tail
);
494 scm_struct_init (obj
, layout
, n_tail
, n_init
, init
);
496 /* If we're making a vtable, validate its layout and inherit
497 flags. However we allow for separation of allocation and
498 initialization, to humor GOOPS, so only validate if the layout was
499 passed as an initarg. */
500 if (SCM_VTABLE_FLAG_IS_SET (vtable
, SCM_VTABLE_FLAG_VTABLE
)
501 && scm_is_true (SCM_VTABLE_LAYOUT (obj
)))
502 scm_i_struct_inherit_vtable_magic (vtable
, obj
);
509 scm_c_make_struct (SCM vtable
, size_t n_tail
, size_t n_init
, scm_t_bits init
, ...)
515 v
= alloca (sizeof (scm_t_bits
) * n_init
);
517 va_start (foo
, init
);
518 for (i
= 0; i
< n_init
; i
++)
521 init
= va_arg (foo
, scm_t_bits
);
525 return scm_c_make_structv (vtable
, n_tail
, n_init
, v
);
528 SCM_DEFINE (scm_make_struct
, "make-struct", 2, 0, 1,
529 (SCM vtable
, SCM tail_array_size
, SCM init
),
530 "Create a new structure.\n\n"
531 "@var{vtable} must be a vtable structure (@pxref{Vtables}).\n\n"
532 "@var{tail_array_size} must be a non-negative integer. If the layout\n"
533 "specification indicated by @var{vtable} includes a tail-array,\n"
534 "this is the number of elements allocated to that array.\n\n"
535 "The @var{init1}, @dots{} are optional arguments describing how\n"
536 "successive fields of the structure should be initialized. Only fields\n"
537 "with protection 'r' or 'w' can be initialized, except for fields of\n"
538 "type 's', which are automatically initialized to point to the new\n"
539 "structure itself. Fields with protection 'o' can not be initialized by\n"
540 "Scheme programs.\n\n"
541 "If fewer optional arguments than initializable fields are supplied,\n"
542 "fields of type 'p' get default value #f while fields of type 'u' are\n"
543 "initialized to 0.\n\n"
544 "For more information, see the documentation for @code{make-vtable-vtable}.")
545 #define FUNC_NAME s_scm_make_struct
551 SCM_VALIDATE_VTABLE (1, vtable
);
552 ilen
= scm_ilength (init
);
554 SCM_MISC_ERROR ("Rest arguments do not form a proper list.", SCM_EOL
);
556 n_init
= (size_t)ilen
;
558 /* best to use alloca, but init could be big, so hack to avoid a possible
561 v
= alloca (n_init
* sizeof(scm_t_bits
));
563 v
= scm_gc_malloc (n_init
* sizeof(scm_t_bits
), "struct");
565 for (i
= 0; i
< n_init
; i
++, init
= SCM_CDR (init
))
566 v
[i
] = SCM_UNPACK (SCM_CAR (init
));
568 return scm_c_make_structv (vtable
, scm_to_size_t (tail_array_size
), n_init
, v
);
574 #if SCM_ENABLE_DEPRECATED == 1
575 SCM_DEFINE (scm_make_vtable_vtable
, "make-vtable-vtable", 2, 0, 1,
576 (SCM user_fields
, SCM tail_array_size
, SCM init
),
577 "Return a new, self-describing vtable structure.\n\n"
578 "@var{user-fields} is a string describing user defined fields of the\n"
579 "vtable beginning at index @code{vtable-offset-user}\n"
580 "(see @code{make-struct-layout}).\n\n"
581 "@var{tail_array_size} specifies the size of the tail-array (if any) of\n"
583 "@var{init1}, @dots{} are the optional initializers for the fields of\n"
585 "Vtables have one initializable system field---the struct printer.\n"
586 "This field comes before the user fields in the initializers passed\n"
587 "to @code{make-vtable-vtable} and @code{make-struct}, and thus works as\n"
588 "a third optional argument to @code{make-vtable-vtable} and a fourth to\n"
589 "@code{make-struct} when creating vtables:\n\n"
590 "If the value is a procedure, it will be called instead of the standard\n"
591 "printer whenever a struct described by this vtable is printed.\n"
592 "The procedure will be called with arguments STRUCT and PORT.\n\n"
593 "The structure of a struct is described by a vtable, so the vtable is\n"
594 "in essence the type of the struct. The vtable is itself a struct with\n"
595 "a vtable. This could go on forever if it weren't for the\n"
596 "vtable-vtables which are self-describing vtables, and thus terminate\n"
598 "There are several potential ways of using structs, but the standard\n"
599 "one is to use three kinds of structs, together building up a type\n"
600 "sub-system: one vtable-vtable working as the root and one or several\n"
601 "\"types\", each with a set of \"instances\". (The vtable-vtable should be\n"
602 "compared to the class <class> which is the class of itself.)\n\n"
604 "(define ball-root (make-vtable-vtable \"pr\" 0))\n\n"
605 "(define (make-ball-type ball-color)\n"
606 " (make-struct ball-root 0\n"
607 " (make-struct-layout \"pw\")\n"
608 " (lambda (ball port)\n"
609 " (format port \"#<a ~A ball owned by ~A>\"\n"
613 "(define (color ball) (struct-ref (struct-vtable ball) vtable-offset-user))\n"
614 "(define (owner ball) (struct-ref ball 0))\n\n"
615 "(define red (make-ball-type 'red))\n"
616 "(define green (make-ball-type 'green))\n\n"
617 "(define (make-ball type owner) (make-struct type 0 owner))\n\n"
618 "(define ball (make-ball green 'Nisse))\n"
619 "ball @result{} #<a green ball owned by Nisse>\n"
621 #define FUNC_NAME s_scm_make_vtable_vtable
623 SCM fields
, layout
, obj
;
624 size_t basic_size
, n_tail
, i
, n_init
;
628 SCM_VALIDATE_STRING (1, user_fields
);
629 ilen
= scm_ilength (init
);
631 SCM_MISC_ERROR ("Rest arguments do not form a proper list.", SCM_EOL
);
633 n_init
= (size_t)ilen
+ 1; /* + 1 for the layout */
635 /* best to use alloca, but init could be big, so hack to avoid a possible
638 v
= alloca (n_init
* sizeof(scm_t_bits
));
640 v
= scm_gc_malloc (n_init
* sizeof(scm_t_bits
), "struct");
642 fields
= scm_string_append (scm_list_2 (required_vtable_fields
,
644 layout
= scm_make_struct_layout (fields
);
645 if (!scm_is_valid_vtable_layout (layout
))
646 SCM_MISC_ERROR ("invalid user fields", scm_list_1 (user_fields
));
648 basic_size
= scm_i_symbol_length (layout
) / 2;
649 n_tail
= scm_to_size_t (tail_array_size
);
652 v
[i
++] = SCM_UNPACK (layout
);
653 for (; i
< n_init
; i
++, init
= SCM_CDR (init
))
654 v
[i
] = SCM_UNPACK (SCM_CAR (init
));
656 SCM_CRITICAL_SECTION_START
;
657 obj
= scm_i_alloc_struct (NULL
, basic_size
+ n_tail
);
658 /* Make it so that the vtable of OBJ is itself. */
659 SCM_SET_CELL_WORD_0 (obj
, (scm_t_bits
) SCM_STRUCT_DATA (obj
) | scm_tc3_struct
);
660 SCM_CRITICAL_SECTION_END
;
662 scm_struct_init (obj
, layout
, n_tail
, n_init
, v
);
663 SCM_SET_VTABLE_FLAGS (obj
,
664 SCM_VTABLE_FLAG_VTABLE
| SCM_VTABLE_FLAG_VALIDATED
);
672 scm_i_make_vtable_vtable (SCM user_fields
)
673 #define FUNC_NAME s_scm_make_vtable_vtable
675 SCM fields
, layout
, obj
;
679 SCM_VALIDATE_STRING (1, user_fields
);
681 fields
= scm_string_append (scm_list_2 (required_vtable_fields
,
683 layout
= scm_make_struct_layout (fields
);
684 if (!scm_is_valid_vtable_layout (layout
))
685 SCM_MISC_ERROR ("invalid user fields", scm_list_1 (user_fields
));
687 basic_size
= scm_i_symbol_length (layout
) / 2;
689 obj
= scm_i_alloc_struct (NULL
, basic_size
);
690 /* Make it so that the vtable of OBJ is itself. */
691 SCM_SET_CELL_WORD_0 (obj
, (scm_t_bits
) SCM_STRUCT_DATA (obj
) | scm_tc3_struct
);
693 v
= SCM_UNPACK (layout
);
694 scm_struct_init (obj
, layout
, 0, 1, &v
);
695 SCM_SET_VTABLE_FLAGS (obj
,
696 SCM_VTABLE_FLAG_VTABLE
| SCM_VTABLE_FLAG_VALIDATED
);
702 SCM_DEFINE (scm_make_vtable
, "make-vtable", 1, 1, 0,
703 (SCM fields
, SCM printer
),
704 "Create a vtable, for creating structures with the given\n"
707 "The optional @var{printer} argument is a function to be called\n"
708 "@code{(@var{printer} struct port)} on the structures created.\n"
709 "It should look at @var{struct} and write to @var{port}.")
710 #define FUNC_NAME s_scm_make_vtable
712 if (SCM_UNBNDP (printer
))
713 printer
= SCM_BOOL_F
;
715 return scm_make_struct (scm_standard_vtable_vtable
, SCM_INUM0
,
716 scm_list_2 (scm_make_struct_layout (fields
),
722 /* Return true if S1 and S2 are equal structures, i.e., if their vtable and
723 contents are the same. Field protections are honored. Thus, it is an
724 error to test the equality of structures that contain opaque fields. */
726 scm_i_struct_equalp (SCM s1
, SCM s2
)
727 #define FUNC_NAME "scm_i_struct_equalp"
729 SCM vtable1
, vtable2
, layout
;
730 size_t struct_size
, field_num
;
732 SCM_VALIDATE_STRUCT (1, s1
);
733 SCM_VALIDATE_STRUCT (2, s2
);
735 vtable1
= SCM_STRUCT_VTABLE (s1
);
736 vtable2
= SCM_STRUCT_VTABLE (s2
);
738 if (!scm_is_eq (vtable1
, vtable2
))
741 layout
= SCM_STRUCT_LAYOUT (s1
);
742 struct_size
= scm_i_symbol_length (layout
) / 2;
744 for (field_num
= 0; field_num
< struct_size
; field_num
++)
749 /* We have to use `scm_struct_ref ()' here so that fields are accessed
750 consistently, notably wrt. field types and access rights. */
751 s_field_num
= scm_from_size_t (field_num
);
752 field1
= scm_struct_ref (s1
, s_field_num
);
753 field2
= scm_struct_ref (s2
, s_field_num
);
755 /* Self-referencing fields (type `s') must be skipped to avoid infinite
757 if (!(scm_is_eq (field1
, s1
) && (scm_is_eq (field2
, s2
))))
758 if (scm_is_false (scm_equal_p (field1
, field2
)))
762 /* FIXME: Tail elements should be tested for equality. */
772 SCM_DEFINE (scm_struct_ref
, "struct-ref", 2, 0, 0,
773 (SCM handle
, SCM pos
),
774 "Access the @var{pos}th field of struct associated with\n"
777 "If the field is of type 'p', then it can be set to an arbitrary\n"
780 "If the field is of type 'u', then it can only be set to a\n"
781 "non-negative integer value small enough to fit in one machine\n"
783 #define FUNC_NAME s_scm_struct_ref
785 SCM vtable
, answer
= SCM_UNDEFINED
;
789 SCM_VALIDATE_STRUCT (1, handle
);
791 vtable
= SCM_STRUCT_VTABLE (handle
);
792 data
= SCM_STRUCT_DATA (handle
);
793 p
= scm_to_size_t (pos
);
795 if (SCM_LIKELY (SCM_VTABLE_FLAG_IS_SET (vtable
, SCM_VTABLE_FLAG_SIMPLE
)
796 && p
< SCM_STRUCT_DATA_REF (vtable
, scm_vtable_index_size
)))
797 /* The fast path: HANDLE is a struct with only "p" fields. */
798 answer
= SCM_PACK (data
[p
]);
802 size_t layout_len
, n_fields
;
803 scm_t_wchar field_type
= 0;
805 layout
= SCM_STRUCT_LAYOUT (handle
);
806 layout_len
= scm_i_symbol_length (layout
);
807 n_fields
= layout_len
/ 2;
809 if (SCM_LAYOUT_TAILP (scm_i_symbol_ref (layout
, layout_len
- 1)))
810 n_fields
+= data
[n_fields
- 1];
812 SCM_ASSERT_RANGE (1, pos
, p
< n_fields
);
814 if (p
* 2 < layout_len
)
817 field_type
= scm_i_symbol_ref (layout
, p
* 2);
818 ref
= scm_i_symbol_ref (layout
, p
* 2 + 1);
819 if ((ref
!= 'r') && (ref
!= 'w') && (ref
!= 'h'))
821 if ((ref
== 'R') || (ref
== 'W'))
824 SCM_MISC_ERROR ("ref denied for field ~A", scm_list_1 (pos
));
827 else if (scm_i_symbol_ref (layout
, layout_len
- 1) != 'O')
828 field_type
= scm_i_symbol_ref(layout
, layout_len
- 2);
830 SCM_MISC_ERROR ("ref denied for field ~A", scm_list_1 (pos
));
835 answer
= scm_from_ulong (data
[p
]);
840 answer
= scm_from_long (data
[p
]);
844 answer
= scm_make_real (*((double *)&(data
[p
])));
850 answer
= SCM_PACK (data
[p
]);
855 SCM_MISC_ERROR ("unrecognized field type: ~S",
856 scm_list_1 (SCM_MAKE_CHAR (field_type
)));
865 SCM_DEFINE (scm_struct_set_x
, "struct-set!", 3, 0, 0,
866 (SCM handle
, SCM pos
, SCM val
),
867 "Set the slot of the structure @var{handle} with index @var{pos}\n"
868 "to @var{val}. Signal an error if the slot can not be written\n"
870 #define FUNC_NAME s_scm_struct_set_x
876 SCM_VALIDATE_STRUCT (1, handle
);
878 vtable
= SCM_STRUCT_VTABLE (handle
);
879 data
= SCM_STRUCT_DATA (handle
);
880 p
= scm_to_size_t (pos
);
882 if (SCM_LIKELY (SCM_VTABLE_FLAG_IS_SET (vtable
, SCM_VTABLE_FLAG_SIMPLE
)
883 && SCM_VTABLE_FLAG_IS_SET (vtable
, SCM_VTABLE_FLAG_SIMPLE_RW
)
884 && p
< SCM_STRUCT_DATA_REF (vtable
, scm_vtable_index_size
)))
885 /* The fast path: HANDLE is a struct with only "pw" fields. */
886 data
[p
] = SCM_UNPACK (val
);
890 size_t layout_len
, n_fields
;
891 scm_t_wchar field_type
= 0;
893 layout
= SCM_STRUCT_LAYOUT (handle
);
894 layout_len
= scm_i_symbol_length (layout
);
895 n_fields
= layout_len
/ 2;
897 if (SCM_LAYOUT_TAILP (scm_i_symbol_ref (layout
, layout_len
- 1)))
898 n_fields
+= data
[n_fields
- 1];
900 SCM_ASSERT_RANGE (1, pos
, p
< n_fields
);
902 if (p
* 2 < layout_len
)
905 field_type
= scm_i_symbol_ref (layout
, p
* 2);
906 set_x
= scm_i_symbol_ref (layout
, p
* 2 + 1);
907 if (set_x
!= 'w' && set_x
!= 'h')
908 SCM_MISC_ERROR ("set! denied for field ~A", scm_list_1 (pos
));
910 else if (scm_i_symbol_ref (layout
, layout_len
- 1) == 'W')
911 field_type
= scm_i_symbol_ref (layout
, layout_len
- 2);
913 SCM_MISC_ERROR ("set! denied for field ~A", scm_list_1 (pos
));
918 data
[p
] = SCM_NUM2ULONG (3, val
);
923 data
[p
] = SCM_NUM2LONG (3, val
);
927 *((double *)&(data
[p
])) = scm_num2dbl (val
, (char *)SCM_ARG3
);
932 data
[p
] = SCM_UNPACK (val
);
936 SCM_MISC_ERROR ("self fields immutable", SCM_EOL
);
939 SCM_MISC_ERROR ("unrecognized field type: ~S",
940 scm_list_1 (SCM_MAKE_CHAR (field_type
)));
949 SCM_DEFINE (scm_struct_vtable
, "struct-vtable", 1, 0, 0,
951 "Return the vtable structure that describes the type of struct\n"
952 "associated with @var{handle}.")
953 #define FUNC_NAME s_scm_struct_vtable
955 SCM_VALIDATE_STRUCT (1, handle
);
956 return SCM_STRUCT_VTABLE (handle
);
961 SCM_DEFINE (scm_struct_vtable_tag
, "struct-vtable-tag", 1, 0, 0,
963 "Return the vtable tag of the structure @var{handle}.")
964 #define FUNC_NAME s_scm_struct_vtable_tag
966 SCM_VALIDATE_VTABLE (1, handle
);
967 return scm_from_unsigned_integer
968 (((scm_t_bits
)SCM_STRUCT_DATA (handle
)) >> 3);
972 /* {Associating names and classes with vtables}
974 * The name of a vtable should probably be stored as a slot. This is
975 * a backward compatible solution until agreement has been achieved on
976 * how to associate names with vtables.
980 scm_struct_ihashq (SCM obj
, unsigned long n
, void *closure
)
982 /* The length of the hash table should be a relative prime it's not
983 necessary to shift down the address. */
984 return SCM_UNPACK (obj
) % n
;
987 SCM_DEFINE (scm_struct_vtable_name
, "struct-vtable-name", 1, 0, 0,
989 "Return the name of the vtable @var{vtable}.")
990 #define FUNC_NAME s_scm_struct_vtable_name
992 SCM_VALIDATE_VTABLE (1, vtable
);
993 return SCM_VTABLE_NAME (vtable
);
997 SCM_DEFINE (scm_set_struct_vtable_name_x
, "set-struct-vtable-name!", 2, 0, 0,
998 (SCM vtable
, SCM name
),
999 "Set the name of the vtable @var{vtable} to @var{name}.")
1000 #define FUNC_NAME s_scm_set_struct_vtable_name_x
1002 SCM_VALIDATE_VTABLE (1, vtable
);
1003 SCM_VALIDATE_SYMBOL (2, name
);
1004 SCM_SET_VTABLE_NAME (vtable
, name
);
1005 /* FIXME: remove this, and implement proper struct classes instead.
1006 (Vtables *are* classes.) */
1007 scm_i_define_class_for_vtable (vtable
);
1008 return SCM_UNSPECIFIED
;
1016 scm_print_struct (SCM exp
, SCM port
, scm_print_state
*pstate
)
1018 if (scm_is_true (scm_procedure_p (SCM_STRUCT_PRINTER (exp
))))
1019 scm_printer_apply (SCM_STRUCT_PRINTER (exp
), exp
, port
, pstate
);
1022 SCM vtable
= SCM_STRUCT_VTABLE (exp
);
1023 SCM name
= scm_struct_vtable_name (vtable
);
1024 scm_puts_unlocked ("#<", port
);
1025 if (scm_is_true (name
))
1027 scm_display (name
, port
);
1028 scm_putc_unlocked (' ', port
);
1032 if (SCM_VTABLE_FLAG_IS_SET (vtable
, SCM_VTABLE_FLAG_VTABLE
))
1033 scm_puts_unlocked ("vtable:", port
);
1035 scm_puts_unlocked ("struct:", port
);
1036 scm_uintprint (SCM_UNPACK (vtable
), 16, port
);
1037 scm_putc_unlocked (' ', port
);
1038 scm_write (SCM_VTABLE_LAYOUT (vtable
), port
);
1039 scm_putc_unlocked (' ', port
);
1041 scm_uintprint (SCM_UNPACK (exp
), 16, port
);
1043 if (SCM_STRUCT_APPLICABLE_P (exp
))
1045 if (scm_is_true (SCM_STRUCT_PROCEDURE (exp
)))
1047 scm_puts_unlocked (" proc: ", port
);
1048 if (scm_is_true (scm_procedure_p (SCM_STRUCT_PROCEDURE (exp
))))
1049 scm_write (SCM_STRUCT_PROCEDURE (exp
), port
);
1051 scm_puts_unlocked ("(not a procedure?)", port
);
1053 if (SCM_STRUCT_SETTER_P (exp
))
1055 scm_puts_unlocked (" setter: ", port
);
1056 scm_write (SCM_STRUCT_SETTER (exp
), port
);
1059 scm_putc_unlocked ('>', port
);
1066 /* The first word of a struct is equal to `SCM_STRUCT_DATA (vtable) +
1067 scm_tc3_struct', and `SCM_STRUCT_DATA (vtable)' is 2 words after VTABLE by
1069 GC_REGISTER_DISPLACEMENT (2 * sizeof (scm_t_bits
) + scm_tc3_struct
);
1071 /* In the general case, `SCM_STRUCT_DATA (obj)' points 2 words after the
1072 beginning of a GC-allocated region; that region is different from that of
1073 OBJ once OBJ has undergone class redefinition. */
1074 GC_REGISTER_DISPLACEMENT (2 * sizeof (scm_t_bits
));
1076 required_vtable_fields
= scm_from_locale_string (SCM_VTABLE_BASE_LAYOUT
);
1077 scm_c_define ("standard-vtable-fields", required_vtable_fields
);
1078 required_applicable_fields
= scm_from_locale_string (SCM_APPLICABLE_BASE_LAYOUT
);
1079 required_applicable_with_setter_fields
= scm_from_locale_string (SCM_APPLICABLE_WITH_SETTER_BASE_LAYOUT
);
1081 scm_standard_vtable_vtable
= scm_i_make_vtable_vtable (scm_nullstr
);
1082 scm_c_define ("<standard-vtable>", scm_standard_vtable_vtable
);
1084 scm_applicable_struct_vtable_vtable
=
1085 scm_make_struct (scm_standard_vtable_vtable
, SCM_INUM0
,
1086 scm_list_1 (scm_make_struct_layout (required_vtable_fields
)));
1087 SCM_SET_VTABLE_FLAGS (scm_applicable_struct_vtable_vtable
,
1088 SCM_VTABLE_FLAG_APPLICABLE_VTABLE
);
1089 scm_c_define ("<applicable-struct-vtable>", scm_applicable_struct_vtable_vtable
);
1091 scm_applicable_struct_with_setter_vtable_vtable
=
1092 scm_make_struct (scm_standard_vtable_vtable
, SCM_INUM0
,
1093 scm_list_1 (scm_make_struct_layout (required_vtable_fields
)));
1094 SCM_SET_VTABLE_FLAGS (scm_applicable_struct_with_setter_vtable_vtable
,
1095 SCM_VTABLE_FLAG_APPLICABLE_VTABLE
| SCM_VTABLE_FLAG_SETTER_VTABLE
);
1096 scm_c_define ("<applicable-struct-with-setter-vtable>", scm_applicable_struct_with_setter_vtable_vtable
);
1098 scm_c_define ("vtable-index-layout", scm_from_int (scm_vtable_index_layout
));
1099 scm_c_define ("vtable-index-printer",
1100 scm_from_int (scm_vtable_index_instance_printer
));
1101 scm_c_define ("vtable-offset-user", scm_from_int (scm_vtable_offset_user
));
1102 #include "libguile/struct.x"