1 /* Copyright (C) 1996,1997,1998,1999,2000,2001, 2003, 2004, 2006, 2007, 2008, 2009, 2010, 2011, 2012 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/weaks.h"
35 #include "libguile/hashtab.h"
36 #include "libguile/ports.h"
37 #include "libguile/strings.h"
38 #include "libguile/srfi-13.h"
40 #include "libguile/validate.h"
41 #include "libguile/struct.h"
43 #include "libguile/eq.h"
49 #include "libguile/bdw-gc.h"
53 /* A needlessly obscure test. */
54 #define SCM_LAYOUT_TAILP(X) (((X) & 32) == 0) /* R, W or O */
56 static SCM required_vtable_fields
= SCM_BOOL_F
;
57 static SCM required_applicable_fields
= SCM_BOOL_F
;
58 static SCM required_applicable_with_setter_fields
= SCM_BOOL_F
;
59 SCM scm_applicable_struct_vtable_vtable
;
60 SCM scm_applicable_struct_with_setter_vtable_vtable
;
61 SCM scm_standard_vtable_vtable
;
65 SCM_DEFINE (scm_make_struct_layout
, "make-struct-layout", 1, 0, 0,
67 "Return a new structure layout object.\n\n"
68 "@var{fields} must be a string made up of pairs of characters\n"
69 "strung together. The first character of each pair describes a field\n"
70 "type, the second a field protection. Allowed types are 'p' for\n"
71 "GC-protected Scheme data, 'u' for unprotected binary data, and 's' for\n"
72 "a field that points to the structure itself. Allowed protections\n"
73 "are 'w' for mutable fields, 'h' for hidden fields, 'r' for read-only\n"
74 "fields, and 'o' for opaque fields.\n\n"
75 "Hidden fields are writable, but they will not consume an initializer arg\n"
76 "passed to @code{make-struct}. They are useful to add slots to a struct\n"
77 "in a way that preserves backward-compatibility with existing calls to\n"
78 "@code{make-struct}, especially for derived vtables.\n\n"
79 "The last field protection specification may be capitalized to indicate\n"
80 "that the field is a tail-array.")
81 #define FUNC_NAME s_scm_make_struct_layout
86 SCM_VALIDATE_STRING (1, fields
);
92 len
= scm_i_string_length (fields
);
94 SCM_MISC_ERROR ("odd length field specification: ~S",
97 for (x
= 0; x
< len
; x
+= 2)
99 switch (c
= scm_i_string_ref (fields
, x
))
110 SCM_MISC_ERROR ("unrecognized field type: ~S",
111 scm_list_1 (SCM_MAKE_CHAR (c
)));
114 switch (c
= scm_i_string_ref (fields
, x
+ 1))
118 if (scm_i_string_ref (fields
, x
) == 's')
119 SCM_MISC_ERROR ("self fields not writable", SCM_EOL
);
126 if (scm_i_string_ref (fields
, x
) == 's')
127 SCM_MISC_ERROR ("self fields not allowed in tail array",
130 SCM_MISC_ERROR ("tail array field must be last field in layout",
134 SCM_MISC_ERROR ("unrecognized ref specification: ~S",
135 scm_list_1 (SCM_MAKE_CHAR (c
)));
138 if (scm_i_string_ref (fields
, x
, 'd'))
140 if (!scm_i_string_ref (fields
, x
+2, '-'))
141 SCM_MISC_ERROR ("missing dash field at position ~A",
142 scm_list_1 (scm_from_int (x
/ 2)));
148 new_sym
= scm_string_to_symbol (fields
);
150 scm_remember_upto_here_1 (fields
);
156 /* Check whether VTABLE instances have a simple layout (i.e., either only "pr"
157 or only "pw" fields) and update its flags accordingly. */
159 set_vtable_layout_flags (SCM vtable
)
163 const char *c_layout
;
164 scm_t_bits flags
= SCM_VTABLE_FLAG_SIMPLE
;
166 layout
= SCM_VTABLE_LAYOUT (vtable
);
167 c_layout
= scm_i_symbol_chars (layout
);
168 len
= scm_i_symbol_length (layout
);
170 assert (len
% 2 == 0);
172 /* Update FLAGS according to LAYOUT. */
174 field
< len
&& flags
& SCM_VTABLE_FLAG_SIMPLE
;
177 if (c_layout
[field
] != 'p')
180 switch (c_layout
[field
+ 1])
185 flags
|= SCM_VTABLE_FLAG_SIMPLE_RW
;
190 flags
&= ~SCM_VTABLE_FLAG_SIMPLE_RW
;
198 if (flags
& SCM_VTABLE_FLAG_SIMPLE
)
200 /* VTABLE is simple so update its flags and record the size of its
202 SCM_SET_VTABLE_FLAGS (vtable
, flags
);
203 SCM_STRUCT_DATA_SET (vtable
, scm_vtable_index_size
, len
/ 2);
208 scm_is_valid_vtable_layout (SCM layout
)
211 const char *c_layout
;
213 c_layout
= scm_i_symbol_chars (layout
);
214 len
= scm_i_symbol_length (layout
);
219 for (n
= 0; n
< len
; n
+= 2)
225 switch (c_layout
[n
+1])
247 /* Have OBJ, a newly created vtable, inherit flags from VTABLE. VTABLE is a
248 vtable-vtable and OBJ is an instance of VTABLE. */
250 scm_i_struct_inherit_vtable_magic (SCM vtable
, SCM obj
)
251 #define FUNC_NAME "%inherit-vtable-magic"
253 /* Verily, what is the deal here, you ask? Basically, we need to know a couple
254 of properties of structures at runtime. For example, "is this structure a
255 vtable of vtables (a metaclass)?"; also, "is this structure applicable?".
256 Both of these questions also imply a certain layout of the structure. So
257 instead of checking the layout at runtime, what we do is pre-verify the
258 layout -- so that at runtime we can just check the applicable flag and
259 dispatch directly to the Scheme procedure in slot 0. */
262 /* Verify that OBJ is a valid vtable. */
263 if (! scm_is_valid_vtable_layout (SCM_VTABLE_LAYOUT (obj
)))
264 SCM_MISC_ERROR ("invalid layout for new vtable: ~a",
265 scm_list_1 (SCM_VTABLE_LAYOUT (obj
)));
267 set_vtable_layout_flags (obj
);
269 /* If OBJ's vtable is compatible with the required vtable (class) layout, it
271 olayout
= scm_symbol_to_string (SCM_VTABLE_LAYOUT (obj
));
272 if (scm_is_true (scm_leq_p (scm_string_length (required_vtable_fields
),
273 scm_string_length (olayout
)))
274 && scm_is_true (scm_string_eq (olayout
, required_vtable_fields
,
276 scm_string_length (required_vtable_fields
),
278 scm_string_length (required_vtable_fields
))))
279 SCM_SET_VTABLE_FLAGS (obj
, SCM_VTABLE_FLAG_VTABLE
);
281 /* Finally, if OBJ is an applicable class, verify that its vtable is
282 compatible with the required applicable layout. */
283 if (SCM_VTABLE_FLAG_IS_SET (vtable
, SCM_VTABLE_FLAG_SETTER_VTABLE
))
285 if (scm_is_false (scm_string_eq (olayout
, required_applicable_with_setter_fields
,
289 scm_from_size_t (4))))
290 SCM_MISC_ERROR ("invalid applicable-with-setter struct layout",
291 scm_list_1 (olayout
));
292 SCM_SET_VTABLE_FLAGS (obj
, SCM_VTABLE_FLAG_APPLICABLE
| SCM_VTABLE_FLAG_SETTER
);
294 else if (SCM_VTABLE_FLAG_IS_SET (vtable
, SCM_VTABLE_FLAG_APPLICABLE_VTABLE
))
296 if (scm_is_false (scm_string_eq (olayout
, required_applicable_fields
,
300 scm_from_size_t (2))))
301 SCM_MISC_ERROR ("invalid applicable struct layout",
302 scm_list_1 (olayout
));
303 SCM_SET_VTABLE_FLAGS (obj
, SCM_VTABLE_FLAG_APPLICABLE
);
306 SCM_SET_VTABLE_FLAGS (obj
, SCM_VTABLE_FLAG_VALIDATED
);
312 scm_struct_init (SCM handle
, SCM layout
, size_t n_tail
,
313 size_t n_inits
, scm_t_bits
*inits
)
318 vtable
= SCM_STRUCT_VTABLE (handle
);
319 mem
= SCM_STRUCT_DATA (handle
);
321 if (SCM_UNPACK (vtable
) != 0
322 && SCM_VTABLE_FLAG_IS_SET (vtable
, SCM_VTABLE_FLAG_SIMPLE
)
324 && n_inits
== SCM_STRUCT_DATA_REF (vtable
, scm_vtable_index_size
))
325 /* The fast path: HANDLE has N_INITS "p" fields. */
326 memcpy (mem
, inits
, n_inits
* sizeof (SCM
));
329 scm_t_wchar prot
= 0;
330 int n_fields
= scm_i_symbol_length (layout
) / 2;
333 size_t inits_idx
= 0;
341 prot
= scm_i_symbol_ref (layout
, i
+1);
342 if (SCM_LAYOUT_TAILP (prot
))
345 prot
= prot
== 'R' ? 'r' : prot
== 'W' ? 'w' : 'o';
346 *mem
++ = (scm_t_bits
)n_tail
;
347 n_fields
+= n_tail
- 1;
352 switch (scm_i_symbol_ref (layout
, i
))
355 if ((prot
!= 'r' && prot
!= 'w') || inits_idx
== n_inits
)
359 *mem
= scm_to_ulong (SCM_PACK (inits
[inits_idx
]));
365 if ((prot
!= 'r' && prot
!= 'w') || inits_idx
== n_inits
)
366 *mem
= SCM_UNPACK (SCM_BOOL_F
);
369 *mem
= inits
[inits_idx
];
376 *mem
= SCM_UNPACK (handle
);
387 SCM_DEFINE (scm_struct_p
, "struct?", 1, 0, 0,
389 "Return @code{#t} iff @var{x} is a structure object, else\n"
391 #define FUNC_NAME s_scm_struct_p
393 return scm_from_bool(SCM_STRUCTP (x
));
397 SCM_DEFINE (scm_struct_vtable_p
, "struct-vtable?", 1, 0, 0,
399 "Return @code{#t} iff @var{x} is a vtable structure.")
400 #define FUNC_NAME s_scm_struct_vtable_p
403 || !SCM_STRUCT_VTABLE_FLAG_IS_SET (x
, SCM_VTABLE_FLAG_VTABLE
))
405 if (!SCM_VTABLE_FLAG_IS_SET (x
, SCM_VTABLE_FLAG_VALIDATED
))
406 SCM_MISC_ERROR ("vtable has invalid layout: ~A",
407 scm_list_1 (SCM_VTABLE_LAYOUT (x
)));
413 /* Finalization: invoke the finalizer of the struct pointed to by PTR. */
415 struct_finalizer_trampoline (void *ptr
, void *unused_data
)
417 SCM obj
= PTR2SCM (ptr
);
418 scm_t_struct_finalize finalize
= SCM_STRUCT_FINALIZER (obj
);
424 /* All struct data must be allocated at an address whose bottom three
425 bits are zero. This is because the tag for a struct lives in the
426 bottom three bits of the struct's car, and the upper bits point to
427 the data of its vtable, which is a struct itself. Thus, if the
428 address of that data doesn't end in three zeros, tagging it will
431 I suppose we should make it clear here that, the data must be 8-byte aligned,
432 *within* the struct, and the struct itself should be 8-byte aligned. In
433 practice we ensure this because the data starts two words into a struct.
435 This function allocates an 8-byte aligned block of memory, whose first word
436 points to the given vtable data, then a data pointer, then n_words of data.
439 scm_i_alloc_struct (scm_t_bits
*vtable_data
, int n_words
)
443 ret
= scm_words ((scm_t_bits
)vtable_data
| scm_tc3_struct
, n_words
+ 2);
444 SCM_SET_CELL_WORD_1 (ret
, (scm_t_bits
)SCM_CELL_OBJECT_LOC (ret
, 2));
446 /* vtable_data can be null when making a vtable vtable */
447 if (vtable_data
&& vtable_data
[scm_vtable_index_instance_finalize
])
448 /* Register a finalizer for the newly created instance. */
449 scm_i_set_finalizer (SCM2PTR (ret
), struct_finalizer_trampoline
, NULL
);
456 scm_c_make_structv (SCM vtable
, size_t n_tail
, size_t n_init
, scm_t_bits
*init
)
457 #define FUNC_NAME "make-struct"
463 SCM_VALIDATE_VTABLE (1, vtable
);
465 layout
= SCM_VTABLE_LAYOUT (vtable
);
466 basic_size
= scm_i_symbol_length (layout
) / 2;
470 SCM layout_str
, last_char
;
475 SCM_MISC_ERROR ("tail array not allowed unless layout ends R, W, or O", SCM_EOL
);
478 layout_str
= scm_symbol_to_string (layout
);
479 last_char
= scm_string_ref (layout_str
,
480 scm_from_size_t (2 * basic_size
- 1));
481 if (! SCM_LAYOUT_TAILP (SCM_CHAR (last_char
)))
485 obj
= scm_i_alloc_struct (SCM_STRUCT_DATA (vtable
), basic_size
+ n_tail
);
487 scm_struct_init (obj
, layout
, n_tail
, n_init
, init
);
489 /* If we're making a vtable, validate its layout and inherit
490 flags. However we allow for separation of allocation and
491 initialization, to humor GOOPS, so only validate if the layout was
492 passed as an initarg. */
493 if (SCM_VTABLE_FLAG_IS_SET (vtable
, SCM_VTABLE_FLAG_VTABLE
)
494 && scm_is_true (SCM_VTABLE_LAYOUT (obj
)))
495 scm_i_struct_inherit_vtable_magic (vtable
, obj
);
502 scm_c_make_struct (SCM vtable
, size_t n_tail
, size_t n_init
, scm_t_bits init
, ...)
508 v
= alloca (sizeof (scm_t_bits
) * n_init
);
510 va_start (foo
, init
);
511 for (i
= 0; i
< n_init
; i
++)
514 init
= va_arg (foo
, scm_t_bits
);
518 return scm_c_make_structv (vtable
, n_tail
, n_init
, v
);
521 SCM_DEFINE (scm_make_struct
, "make-struct", 2, 0, 1,
522 (SCM vtable
, SCM tail_array_size
, SCM init
),
523 "Create a new structure.\n\n"
524 "@var{vtable} must be a vtable structure (@pxref{Vtables}).\n\n"
525 "@var{tail_array_size} must be a non-negative integer. If the layout\n"
526 "specification indicated by @var{vtable} includes a tail-array,\n"
527 "this is the number of elements allocated to that array.\n\n"
528 "The @var{init1}, @dots{} are optional arguments describing how\n"
529 "successive fields of the structure should be initialized. Only fields\n"
530 "with protection 'r' or 'w' can be initialized, except for fields of\n"
531 "type 's', which are automatically initialized to point to the new\n"
532 "structure itself. Fields with protection 'o' can not be initialized by\n"
533 "Scheme programs.\n\n"
534 "If fewer optional arguments than initializable fields are supplied,\n"
535 "fields of type 'p' get default value #f while fields of type 'u' are\n"
536 "initialized to 0.\n\n"
537 "For more information, see the documentation for @code{make-vtable-vtable}.")
538 #define FUNC_NAME s_scm_make_struct
544 SCM_VALIDATE_VTABLE (1, vtable
);
545 ilen
= scm_ilength (init
);
547 SCM_MISC_ERROR ("Rest arguments do not form a proper list.", SCM_EOL
);
549 n_init
= (size_t)ilen
;
551 /* best to use alloca, but init could be big, so hack to avoid a possible
554 v
= alloca (n_init
* sizeof(scm_t_bits
));
556 v
= scm_gc_malloc (n_init
* sizeof(scm_t_bits
), "struct");
558 for (i
= 0; i
< n_init
; i
++, init
= SCM_CDR (init
))
559 v
[i
] = SCM_UNPACK (SCM_CAR (init
));
561 return scm_c_make_structv (vtable
, scm_to_size_t (tail_array_size
), n_init
, v
);
567 #if SCM_ENABLE_DEPRECATED == 1
569 scm_make_vtable_vtable (SCM user_fields
, SCM tail_array_size
, SCM init
)
570 #define FUNC_NAME "make-vtable-vtable"
572 SCM fields
, layout
, obj
;
573 size_t basic_size
, n_tail
, i
, n_init
;
577 SCM_VALIDATE_STRING (1, user_fields
);
578 ilen
= scm_ilength (init
);
580 SCM_MISC_ERROR ("Rest arguments do not form a proper list.", SCM_EOL
);
582 n_init
= (size_t)ilen
+ 1; /* + 1 for the layout */
584 /* best to use alloca, but init could be big, so hack to avoid a possible
587 v
= alloca (n_init
* sizeof(scm_t_bits
));
589 v
= scm_gc_malloc (n_init
* sizeof(scm_t_bits
), "struct");
591 fields
= scm_string_append (scm_list_2 (required_vtable_fields
,
593 layout
= scm_make_struct_layout (fields
);
594 if (!scm_is_valid_vtable_layout (layout
))
595 SCM_MISC_ERROR ("invalid user fields", scm_list_1 (user_fields
));
597 basic_size
= scm_i_symbol_length (layout
) / 2;
598 n_tail
= scm_to_size_t (tail_array_size
);
601 v
[i
++] = SCM_UNPACK (layout
);
602 for (; i
< n_init
; i
++, init
= SCM_CDR (init
))
603 v
[i
] = SCM_UNPACK (SCM_CAR (init
));
605 SCM_CRITICAL_SECTION_START
;
606 obj
= scm_i_alloc_struct (NULL
, basic_size
+ n_tail
);
607 /* Make it so that the vtable of OBJ is itself. */
608 SCM_SET_CELL_WORD_0 (obj
, (scm_t_bits
) SCM_STRUCT_DATA (obj
) | scm_tc3_struct
);
609 SCM_CRITICAL_SECTION_END
;
611 scm_struct_init (obj
, layout
, n_tail
, n_init
, v
);
612 SCM_SET_VTABLE_FLAGS (obj
,
613 SCM_VTABLE_FLAG_VTABLE
| SCM_VTABLE_FLAG_VALIDATED
);
621 scm_i_make_vtable_vtable (SCM user_fields
)
622 #define FUNC_NAME "make-vtable-vtable"
624 SCM fields
, layout
, obj
;
628 SCM_VALIDATE_STRING (1, user_fields
);
630 fields
= scm_string_append (scm_list_2 (required_vtable_fields
,
632 layout
= scm_make_struct_layout (fields
);
633 if (!scm_is_valid_vtable_layout (layout
))
634 SCM_MISC_ERROR ("invalid user fields", scm_list_1 (user_fields
));
636 basic_size
= scm_i_symbol_length (layout
) / 2;
638 obj
= scm_i_alloc_struct (NULL
, basic_size
);
639 /* Make it so that the vtable of OBJ is itself. */
640 SCM_SET_CELL_WORD_0 (obj
, (scm_t_bits
) SCM_STRUCT_DATA (obj
) | scm_tc3_struct
);
642 v
= SCM_UNPACK (layout
);
643 scm_struct_init (obj
, layout
, 0, 1, &v
);
644 SCM_SET_VTABLE_FLAGS (obj
,
645 SCM_VTABLE_FLAG_VTABLE
| SCM_VTABLE_FLAG_VALIDATED
);
651 SCM_DEFINE (scm_make_vtable
, "make-vtable", 1, 1, 0,
652 (SCM fields
, SCM printer
),
653 "Create a vtable, for creating structures with the given\n"
656 "The optional @var{printer} argument is a function to be called\n"
657 "@code{(@var{printer} struct port)} on the structures created.\n"
658 "It should look at @var{struct} and write to @var{port}.")
659 #define FUNC_NAME s_scm_make_vtable
661 if (SCM_UNBNDP (printer
))
662 printer
= SCM_BOOL_F
;
664 return scm_make_struct (scm_standard_vtable_vtable
, SCM_INUM0
,
665 scm_list_2 (scm_make_struct_layout (fields
),
671 /* Return true if S1 and S2 are equal structures, i.e., if their vtable and
672 contents are the same. Field protections are honored. Thus, it is an
673 error to test the equality of structures that contain opaque fields. */
675 scm_i_struct_equalp (SCM s1
, SCM s2
)
676 #define FUNC_NAME "scm_i_struct_equalp"
678 SCM vtable1
, vtable2
, layout
;
679 size_t struct_size
, field_num
;
681 SCM_VALIDATE_STRUCT (1, s1
);
682 SCM_VALIDATE_STRUCT (2, s2
);
684 vtable1
= SCM_STRUCT_VTABLE (s1
);
685 vtable2
= SCM_STRUCT_VTABLE (s2
);
687 if (!scm_is_eq (vtable1
, vtable2
))
690 layout
= SCM_STRUCT_LAYOUT (s1
);
691 struct_size
= scm_i_symbol_length (layout
) / 2;
693 for (field_num
= 0; field_num
< struct_size
; field_num
++)
698 /* We have to use `scm_struct_ref ()' here so that fields are accessed
699 consistently, notably wrt. field types and access rights. */
700 s_field_num
= scm_from_size_t (field_num
);
701 field1
= scm_struct_ref (s1
, s_field_num
);
702 field2
= scm_struct_ref (s2
, s_field_num
);
704 /* Self-referencing fields (type `s') must be skipped to avoid infinite
706 if (!(scm_is_eq (field1
, s1
) && (scm_is_eq (field2
, s2
))))
707 if (scm_is_false (scm_equal_p (field1
, field2
)))
711 /* FIXME: Tail elements should be tested for equality. */
721 SCM_DEFINE (scm_struct_ref
, "struct-ref", 2, 0, 0,
722 (SCM handle
, SCM pos
),
723 "Access the @var{pos}th field of struct associated with\n"
726 "If the field is of type 'p', then it can be set to an arbitrary\n"
729 "If the field is of type 'u', then it can only be set to a\n"
730 "non-negative integer value small enough to fit in one machine\n"
732 #define FUNC_NAME s_scm_struct_ref
734 SCM vtable
, answer
= SCM_UNDEFINED
;
738 SCM_VALIDATE_STRUCT (1, handle
);
740 vtable
= SCM_STRUCT_VTABLE (handle
);
741 data
= SCM_STRUCT_DATA (handle
);
742 p
= scm_to_size_t (pos
);
744 if (SCM_LIKELY (SCM_VTABLE_FLAG_IS_SET (vtable
, SCM_VTABLE_FLAG_SIMPLE
)
745 && p
< SCM_STRUCT_DATA_REF (vtable
, scm_vtable_index_size
)))
746 /* The fast path: HANDLE is a struct with only "p" fields. */
747 answer
= SCM_PACK (data
[p
]);
751 size_t layout_len
, n_fields
;
752 scm_t_wchar field_type
= 0;
754 layout
= SCM_STRUCT_LAYOUT (handle
);
755 layout_len
= scm_i_symbol_length (layout
);
756 n_fields
= layout_len
/ 2;
758 if (SCM_LAYOUT_TAILP (scm_i_symbol_ref (layout
, layout_len
- 1)))
759 n_fields
+= data
[n_fields
- 1];
761 SCM_ASSERT_RANGE (1, pos
, p
< n_fields
);
763 if (p
* 2 < layout_len
)
766 field_type
= scm_i_symbol_ref (layout
, p
* 2);
767 ref
= scm_i_symbol_ref (layout
, p
* 2 + 1);
768 if ((ref
!= 'r') && (ref
!= 'w') && (ref
!= 'h'))
770 if ((ref
== 'R') || (ref
== 'W'))
773 SCM_MISC_ERROR ("ref denied for field ~A", scm_list_1 (pos
));
776 else if (scm_i_symbol_ref (layout
, layout_len
- 1) != 'O')
777 field_type
= scm_i_symbol_ref(layout
, layout_len
- 2);
779 SCM_MISC_ERROR ("ref denied for field ~A", scm_list_1 (pos
));
784 answer
= scm_from_ulong (data
[p
]);
789 answer
= scm_from_long (data
[p
]);
793 answer
= scm_make_real (*((double *)&(data
[p
])));
799 answer
= SCM_PACK (data
[p
]);
804 SCM_MISC_ERROR ("unrecognized field type: ~S",
805 scm_list_1 (SCM_MAKE_CHAR (field_type
)));
814 SCM_DEFINE (scm_struct_set_x
, "struct-set!", 3, 0, 0,
815 (SCM handle
, SCM pos
, SCM val
),
816 "Set the slot of the structure @var{handle} with index @var{pos}\n"
817 "to @var{val}. Signal an error if the slot can not be written\n"
819 #define FUNC_NAME s_scm_struct_set_x
825 SCM_VALIDATE_STRUCT (1, handle
);
827 vtable
= SCM_STRUCT_VTABLE (handle
);
828 data
= SCM_STRUCT_DATA (handle
);
829 p
= scm_to_size_t (pos
);
831 if (SCM_LIKELY (SCM_VTABLE_FLAG_IS_SET (vtable
, SCM_VTABLE_FLAG_SIMPLE
)
832 && SCM_VTABLE_FLAG_IS_SET (vtable
, SCM_VTABLE_FLAG_SIMPLE_RW
)
833 && p
< SCM_STRUCT_DATA_REF (vtable
, scm_vtable_index_size
)))
834 /* The fast path: HANDLE is a struct with only "pw" fields. */
835 data
[p
] = SCM_UNPACK (val
);
839 size_t layout_len
, n_fields
;
840 scm_t_wchar field_type
= 0;
842 layout
= SCM_STRUCT_LAYOUT (handle
);
843 layout_len
= scm_i_symbol_length (layout
);
844 n_fields
= layout_len
/ 2;
846 if (SCM_LAYOUT_TAILP (scm_i_symbol_ref (layout
, layout_len
- 1)))
847 n_fields
+= data
[n_fields
- 1];
849 SCM_ASSERT_RANGE (1, pos
, p
< n_fields
);
851 if (p
* 2 < layout_len
)
854 field_type
= scm_i_symbol_ref (layout
, p
* 2);
855 set_x
= scm_i_symbol_ref (layout
, p
* 2 + 1);
856 if (set_x
!= 'w' && set_x
!= 'h')
857 SCM_MISC_ERROR ("set! denied for field ~A", scm_list_1 (pos
));
859 else if (scm_i_symbol_ref (layout
, layout_len
- 1) == 'W')
860 field_type
= scm_i_symbol_ref (layout
, layout_len
- 2);
862 SCM_MISC_ERROR ("set! denied for field ~A", scm_list_1 (pos
));
867 data
[p
] = SCM_NUM2ULONG (3, val
);
872 data
[p
] = SCM_NUM2LONG (3, val
);
876 *((double *)&(data
[p
])) = scm_num2dbl (val
, (char *)SCM_ARG3
);
881 data
[p
] = SCM_UNPACK (val
);
885 SCM_MISC_ERROR ("self fields immutable", SCM_EOL
);
888 SCM_MISC_ERROR ("unrecognized field type: ~S",
889 scm_list_1 (SCM_MAKE_CHAR (field_type
)));
898 SCM_DEFINE (scm_struct_vtable
, "struct-vtable", 1, 0, 0,
900 "Return the vtable structure that describes the type of struct\n"
901 "associated with @var{handle}.")
902 #define FUNC_NAME s_scm_struct_vtable
904 SCM_VALIDATE_STRUCT (1, handle
);
905 return SCM_STRUCT_VTABLE (handle
);
910 /* {Associating names and classes with vtables}
912 * The name of a vtable should probably be stored as a slot. This is
913 * a backward compatible solution until agreement has been achieved on
914 * how to associate names with vtables.
918 scm_struct_ihashq (SCM obj
, unsigned long n
, void *closure
)
920 /* The length of the hash table should be a relative prime it's not
921 necessary to shift down the address. */
922 return SCM_UNPACK (obj
) % n
;
925 SCM_DEFINE (scm_struct_vtable_name
, "struct-vtable-name", 1, 0, 0,
927 "Return the name of the vtable @var{vtable}.")
928 #define FUNC_NAME s_scm_struct_vtable_name
930 SCM_VALIDATE_VTABLE (1, vtable
);
931 return SCM_VTABLE_NAME (vtable
);
935 SCM_DEFINE (scm_set_struct_vtable_name_x
, "set-struct-vtable-name!", 2, 0, 0,
936 (SCM vtable
, SCM name
),
937 "Set the name of the vtable @var{vtable} to @var{name}.")
938 #define FUNC_NAME s_scm_set_struct_vtable_name_x
940 SCM_VALIDATE_VTABLE (1, vtable
);
941 SCM_VALIDATE_SYMBOL (2, name
);
942 SCM_SET_VTABLE_NAME (vtable
, name
);
943 /* FIXME: remove this, and implement proper struct classes instead.
944 (Vtables *are* classes.) */
945 scm_i_define_class_for_vtable (vtable
);
946 return SCM_UNSPECIFIED
;
954 scm_print_struct (SCM exp
, SCM port
, scm_print_state
*pstate
)
956 if (scm_is_true (scm_procedure_p (SCM_STRUCT_PRINTER (exp
))))
957 scm_printer_apply (SCM_STRUCT_PRINTER (exp
), exp
, port
, pstate
);
960 SCM vtable
= SCM_STRUCT_VTABLE (exp
);
961 SCM name
= scm_struct_vtable_name (vtable
);
962 scm_puts ("#<", port
);
963 if (scm_is_true (name
))
965 scm_display (name
, port
);
966 scm_putc (' ', port
);
970 if (SCM_VTABLE_FLAG_IS_SET (vtable
, SCM_VTABLE_FLAG_VTABLE
))
971 scm_puts ("vtable:", port
);
973 scm_puts ("struct:", port
);
974 scm_uintprint (SCM_UNPACK (vtable
), 16, port
);
975 scm_putc (' ', port
);
976 scm_write (SCM_VTABLE_LAYOUT (vtable
), port
);
977 scm_putc (' ', port
);
979 scm_uintprint (SCM_UNPACK (exp
), 16, port
);
981 if (SCM_STRUCT_APPLICABLE_P (exp
))
983 if (scm_is_true (SCM_STRUCT_PROCEDURE (exp
)))
985 scm_puts (" proc: ", port
);
986 if (scm_is_true (scm_procedure_p (SCM_STRUCT_PROCEDURE (exp
))))
987 scm_write (SCM_STRUCT_PROCEDURE (exp
), port
);
989 scm_puts ("(not a procedure?)", port
);
991 if (SCM_STRUCT_SETTER_P (exp
))
993 scm_puts (" setter: ", port
);
994 scm_write (SCM_STRUCT_SETTER (exp
), port
);
997 scm_putc ('>', port
);
1006 /* The first word of a struct is equal to `SCM_STRUCT_DATA (vtable) +
1007 scm_tc3_struct', and `SCM_STRUCT_DATA (vtable)' is 2 words after VTABLE by
1009 GC_REGISTER_DISPLACEMENT (2 * sizeof (scm_t_bits
) + scm_tc3_struct
);
1011 /* In the general case, `SCM_STRUCT_DATA (obj)' points 2 words after the
1012 beginning of a GC-allocated region; that region is different from that of
1013 OBJ once OBJ has undergone class redefinition. */
1014 GC_REGISTER_DISPLACEMENT (2 * sizeof (scm_t_bits
));
1016 required_vtable_fields
= scm_from_locale_string (SCM_VTABLE_BASE_LAYOUT
);
1017 scm_c_define ("standard-vtable-fields", required_vtable_fields
);
1018 required_applicable_fields
= scm_from_locale_string (SCM_APPLICABLE_BASE_LAYOUT
);
1019 required_applicable_with_setter_fields
= scm_from_locale_string (SCM_APPLICABLE_WITH_SETTER_BASE_LAYOUT
);
1021 scm_standard_vtable_vtable
= scm_i_make_vtable_vtable (scm_nullstr
);
1022 name
= scm_from_utf8_symbol ("<standard-vtable>");
1023 scm_set_struct_vtable_name_x (scm_standard_vtable_vtable
, name
);
1024 scm_define (name
, scm_standard_vtable_vtable
);
1026 scm_applicable_struct_vtable_vtable
=
1027 scm_make_struct (scm_standard_vtable_vtable
, SCM_INUM0
,
1028 scm_list_1 (scm_make_struct_layout (required_vtable_fields
)));
1029 name
= scm_from_utf8_symbol ("<applicable-struct-vtable>");
1030 SCM_SET_VTABLE_FLAGS (scm_applicable_struct_vtable_vtable
,
1031 SCM_VTABLE_FLAG_APPLICABLE_VTABLE
);
1032 scm_set_struct_vtable_name_x (scm_applicable_struct_vtable_vtable
, name
);
1033 scm_define (name
, scm_applicable_struct_vtable_vtable
);
1035 scm_applicable_struct_with_setter_vtable_vtable
=
1036 scm_make_struct (scm_standard_vtable_vtable
, SCM_INUM0
,
1037 scm_list_1 (scm_make_struct_layout (required_vtable_fields
)));
1038 name
= scm_from_utf8_symbol ("<applicable-struct-with-setter-vtable>");
1039 scm_set_struct_vtable_name_x (scm_applicable_struct_with_setter_vtable_vtable
, name
);
1040 SCM_SET_VTABLE_FLAGS (scm_applicable_struct_with_setter_vtable_vtable
,
1041 SCM_VTABLE_FLAG_APPLICABLE_VTABLE
| SCM_VTABLE_FLAG_SETTER_VTABLE
);
1042 scm_define (name
, scm_applicable_struct_with_setter_vtable_vtable
);
1044 scm_c_define ("vtable-index-layout", scm_from_int (scm_vtable_index_layout
));
1045 scm_c_define ("vtable-index-printer",
1046 scm_from_int (scm_vtable_index_instance_printer
));
1047 scm_c_define ("vtable-offset-user", scm_from_int (scm_vtable_offset_user
));
1048 #include "libguile/struct.x"
1049 #if SCM_ENABLE_DEPRECATED
1050 scm_c_define_gsubr ("make-vtable-vtable", 2, 0, 1, scm_make_vtable_vtable
);