1 /* Copyright (C) 1996,1997,1998,1999,2000,2001, 2003, 2004, 2006, 2007,
2 * 2008, 2009, 2010, 2011, 2012, 2013 Free Software Foundation, Inc.
4 * This library is free software; you can redistribute it and/or
5 * modify it under the terms of the GNU Lesser General Public License
6 * as published by the Free Software Foundation; either version 3 of
7 * the License, or (at your option) any later version.
9 * This library is distributed in the hope that it will be useful, but
10 * WITHOUT ANY WARRANTY; without even the implied warranty of
11 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
12 * Lesser General Public License for more details.
14 * You should have received a copy of the GNU Lesser General Public
15 * License along with this library; if not, write to the Free Software
16 * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
28 #define SCM_BUILDING_DEPRECATED_CODE
30 #include "libguile/_scm.h"
31 #include "libguile/async.h"
32 #include "libguile/chars.h"
33 #include "libguile/eval.h"
34 #include "libguile/alist.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
157 only "pr" or only "pw" fields and no tail array) and update its flags
160 set_vtable_layout_flags (SCM vtable
)
164 const char *c_layout
;
165 scm_t_bits flags
= SCM_VTABLE_FLAG_SIMPLE
;
167 layout
= SCM_VTABLE_LAYOUT (vtable
);
168 c_layout
= scm_i_symbol_chars (layout
);
169 len
= scm_i_symbol_length (layout
);
171 assert (len
% 2 == 0);
173 /* Update FLAGS according to LAYOUT. */
175 field
< len
&& flags
& SCM_VTABLE_FLAG_SIMPLE
;
178 if (c_layout
[field
] != 'p')
181 switch (c_layout
[field
+ 1])
185 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 (void *ptr
, void *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
])
447 /* Register a finalizer for the newly created instance. */
448 scm_i_set_finalizer (SCM2PTR (ret
), struct_finalizer_trampoline
, NULL
);
455 scm_c_make_structv (SCM vtable
, size_t n_tail
, size_t n_init
, scm_t_bits
*init
)
456 #define FUNC_NAME "make-struct"
462 SCM_VALIDATE_VTABLE (1, vtable
);
464 layout
= SCM_VTABLE_LAYOUT (vtable
);
465 basic_size
= scm_i_symbol_length (layout
) / 2;
469 SCM layout_str
, last_char
;
474 SCM_MISC_ERROR ("tail array not allowed unless layout ends R, W, or O", SCM_EOL
);
477 layout_str
= scm_symbol_to_string (layout
);
478 last_char
= scm_string_ref (layout_str
,
479 scm_from_size_t (2 * basic_size
- 1));
480 if (! SCM_LAYOUT_TAILP (SCM_CHAR (last_char
)))
484 obj
= scm_i_alloc_struct (SCM_STRUCT_DATA (vtable
), basic_size
+ n_tail
);
486 scm_struct_init (obj
, layout
, n_tail
, n_init
, init
);
488 /* If we're making a vtable, validate its layout and inherit
489 flags. However we allow for separation of allocation and
490 initialization, to humor GOOPS, so only validate if the layout was
491 passed as an initarg. */
492 if (SCM_VTABLE_FLAG_IS_SET (vtable
, SCM_VTABLE_FLAG_VTABLE
)
493 && scm_is_true (SCM_VTABLE_LAYOUT (obj
)))
494 scm_i_struct_inherit_vtable_magic (vtable
, obj
);
501 scm_c_make_struct (SCM vtable
, size_t n_tail
, size_t n_init
, scm_t_bits init
, ...)
507 v
= alloca (sizeof (scm_t_bits
) * n_init
);
509 va_start (foo
, init
);
510 for (i
= 0; i
< n_init
; i
++)
513 init
= va_arg (foo
, scm_t_bits
);
517 return scm_c_make_structv (vtable
, n_tail
, n_init
, v
);
520 SCM_DEFINE (scm_allocate_struct
, "allocate-struct", 2, 0, 0,
521 (SCM vtable
, SCM nfields
),
522 "Allocate a new structure with space for @var{nfields} fields.\n\n"
523 "@var{vtable} must be a vtable structure (@pxref{Vtables}).\n\n"
524 "@var{nfields} must be a non-negative integer. Strictly speaking\n"
525 "@var{nfields} is redundant, as the vtable carries the size\n"
526 "for its instances. However passing it is useful as a sanity\n"
527 "check, given that one module can inline a constructor in\n"
529 "Fields will be initialized with their default values.")
530 #define FUNC_NAME s_scm_allocate_struct
535 SCM_VALIDATE_VTABLE (1, vtable
);
536 c_nfields
= scm_to_size_t (nfields
);
538 SCM_ASSERT (SCM_STRUCT_DATA_REF (vtable
, scm_vtable_index_size
) == c_nfields
,
539 nfields
, 2, FUNC_NAME
);
541 ret
= scm_i_alloc_struct (SCM_STRUCT_DATA (vtable
), c_nfields
);
543 if (SCM_LIKELY (SCM_VTABLE_FLAG_IS_SET (vtable
, SCM_VTABLE_FLAG_SIMPLE
)))
546 for (n
= 0; n
< c_nfields
; n
++)
547 SCM_STRUCT_DATA_SET (ret
, n
, SCM_UNPACK (SCM_BOOL_F
));
550 scm_struct_init (ret
, SCM_VTABLE_LAYOUT (vtable
), 0, 0, NULL
);
556 SCM_DEFINE (scm_make_struct
, "make-struct", 2, 0, 1,
557 (SCM vtable
, SCM tail_array_size
, SCM init
),
558 "Create a new structure.\n\n"
559 "@var{vtable} must be a vtable structure (@pxref{Vtables}).\n\n"
560 "@var{tail_array_size} must be a non-negative integer. If the layout\n"
561 "specification indicated by @var{vtable} includes a tail-array,\n"
562 "this is the number of elements allocated to that array.\n\n"
563 "The @var{init1}, @dots{} are optional arguments describing how\n"
564 "successive fields of the structure should be initialized. Only fields\n"
565 "with protection 'r' or 'w' can be initialized, except for fields of\n"
566 "type 's', which are automatically initialized to point to the new\n"
567 "structure itself. Fields with protection 'o' can not be initialized by\n"
568 "Scheme programs.\n\n"
569 "If fewer optional arguments than initializable fields are supplied,\n"
570 "fields of type 'p' get default value #f while fields of type 'u' are\n"
572 #define FUNC_NAME s_scm_make_struct
578 SCM_VALIDATE_VTABLE (1, vtable
);
579 ilen
= scm_ilength (init
);
581 SCM_MISC_ERROR ("Rest arguments do not form a proper list.", SCM_EOL
);
583 n_init
= (size_t)ilen
;
585 /* best to use alloca, but init could be big, so hack to avoid a possible
588 v
= alloca (n_init
* sizeof(scm_t_bits
));
590 v
= scm_gc_malloc (n_init
* sizeof(scm_t_bits
), "struct");
592 for (i
= 0; i
< n_init
; i
++, init
= SCM_CDR (init
))
593 v
[i
] = SCM_UNPACK (SCM_CAR (init
));
595 return scm_c_make_structv (vtable
, scm_to_size_t (tail_array_size
), n_init
, v
);
600 scm_i_make_vtable_vtable (SCM user_fields
)
601 #define FUNC_NAME "make-vtable-vtable"
603 SCM fields
, layout
, obj
;
607 SCM_VALIDATE_STRING (1, user_fields
);
609 fields
= scm_string_append (scm_list_2 (required_vtable_fields
,
611 layout
= scm_make_struct_layout (fields
);
612 if (!scm_is_valid_vtable_layout (layout
))
613 SCM_MISC_ERROR ("invalid user fields", scm_list_1 (user_fields
));
615 basic_size
= scm_i_symbol_length (layout
) / 2;
617 obj
= scm_i_alloc_struct (NULL
, basic_size
);
618 /* Make it so that the vtable of OBJ is itself. */
619 SCM_SET_CELL_WORD_0 (obj
, (scm_t_bits
) SCM_STRUCT_DATA (obj
) | scm_tc3_struct
);
621 v
= SCM_UNPACK (layout
);
622 scm_struct_init (obj
, layout
, 0, 1, &v
);
623 SCM_SET_VTABLE_FLAGS (obj
,
624 SCM_VTABLE_FLAG_VTABLE
| SCM_VTABLE_FLAG_VALIDATED
);
630 SCM_DEFINE (scm_make_vtable
, "make-vtable", 1, 1, 0,
631 (SCM fields
, SCM printer
),
632 "Create a vtable, for creating structures with the given\n"
635 "The optional @var{printer} argument is a function to be called\n"
636 "@code{(@var{printer} struct port)} on the structures created.\n"
637 "It should look at @var{struct} and write to @var{port}.")
638 #define FUNC_NAME s_scm_make_vtable
640 if (SCM_UNBNDP (printer
))
641 printer
= SCM_BOOL_F
;
643 return scm_make_struct (scm_standard_vtable_vtable
, SCM_INUM0
,
644 scm_list_2 (scm_make_struct_layout (fields
),
650 /* Return true if S1 and S2 are equal structures, i.e., if their vtable and
651 contents are the same. Field protections are honored. Thus, it is an
652 error to test the equality of structures that contain opaque fields. */
654 scm_i_struct_equalp (SCM s1
, SCM s2
)
655 #define FUNC_NAME "scm_i_struct_equalp"
657 SCM vtable1
, vtable2
, layout
;
658 size_t struct_size
, field_num
;
660 SCM_VALIDATE_STRUCT (1, s1
);
661 SCM_VALIDATE_STRUCT (2, s2
);
663 vtable1
= SCM_STRUCT_VTABLE (s1
);
664 vtable2
= SCM_STRUCT_VTABLE (s2
);
666 if (!scm_is_eq (vtable1
, vtable2
))
669 layout
= SCM_STRUCT_LAYOUT (s1
);
670 struct_size
= scm_i_symbol_length (layout
) / 2;
672 for (field_num
= 0; field_num
< struct_size
; field_num
++)
677 /* We have to use `scm_struct_ref ()' here so that fields are accessed
678 consistently, notably wrt. field types and access rights. */
679 s_field_num
= scm_from_size_t (field_num
);
680 field1
= scm_struct_ref (s1
, s_field_num
);
681 field2
= scm_struct_ref (s2
, s_field_num
);
683 /* Self-referencing fields (type `s') must be skipped to avoid infinite
685 if (!(scm_is_eq (field1
, s1
) && (scm_is_eq (field2
, s2
))))
686 if (scm_is_false (scm_equal_p (field1
, field2
)))
690 /* FIXME: Tail elements should be tested for equality. */
700 SCM_DEFINE (scm_struct_ref
, "struct-ref", 2, 0, 0,
701 (SCM handle
, SCM pos
),
702 "Access the @var{pos}th field of struct associated with\n"
705 "If the field is of type 'p', then it can be set to an arbitrary\n"
708 "If the field is of type 'u', then it can only be set to a\n"
709 "non-negative integer value small enough to fit in one machine\n"
711 #define FUNC_NAME s_scm_struct_ref
713 SCM vtable
, answer
= SCM_UNDEFINED
;
717 SCM_VALIDATE_STRUCT (1, handle
);
719 vtable
= SCM_STRUCT_VTABLE (handle
);
720 data
= SCM_STRUCT_DATA (handle
);
721 p
= scm_to_size_t (pos
);
723 if (SCM_LIKELY (SCM_VTABLE_FLAG_IS_SET (vtable
, SCM_VTABLE_FLAG_SIMPLE
)
724 && p
< SCM_STRUCT_DATA_REF (vtable
, scm_vtable_index_size
)))
725 /* The fast path: HANDLE is a struct with only "p" fields. */
726 answer
= SCM_PACK (data
[p
]);
730 size_t layout_len
, n_fields
;
731 scm_t_wchar field_type
= 0;
733 layout
= SCM_STRUCT_LAYOUT (handle
);
734 layout_len
= scm_i_symbol_length (layout
);
735 n_fields
= layout_len
/ 2;
737 if (SCM_LAYOUT_TAILP (scm_i_symbol_ref (layout
, layout_len
- 1)))
738 n_fields
+= data
[n_fields
- 1];
740 SCM_ASSERT_RANGE (1, pos
, p
< n_fields
);
742 if (p
* 2 < layout_len
)
745 field_type
= scm_i_symbol_ref (layout
, p
* 2);
746 ref
= scm_i_symbol_ref (layout
, p
* 2 + 1);
747 if ((ref
!= 'r') && (ref
!= 'w') && (ref
!= 'h'))
749 if ((ref
== 'R') || (ref
== 'W'))
752 SCM_MISC_ERROR ("ref denied for field ~A", scm_list_1 (pos
));
755 else if (scm_i_symbol_ref (layout
, layout_len
- 1) != 'O')
756 field_type
= scm_i_symbol_ref(layout
, layout_len
- 2);
758 SCM_MISC_ERROR ("ref denied for field ~A", scm_list_1 (pos
));
763 answer
= scm_from_ulong (data
[p
]);
768 answer
= scm_from_long (data
[p
]);
772 answer
= scm_make_real (*((double *)&(data
[p
])));
778 answer
= SCM_PACK (data
[p
]);
783 SCM_MISC_ERROR ("unrecognized field type: ~S",
784 scm_list_1 (SCM_MAKE_CHAR (field_type
)));
793 SCM_DEFINE (scm_struct_set_x
, "struct-set!", 3, 0, 0,
794 (SCM handle
, SCM pos
, SCM val
),
795 "Set the slot of the structure @var{handle} with index @var{pos}\n"
796 "to @var{val}. Signal an error if the slot can not be written\n"
798 #define FUNC_NAME s_scm_struct_set_x
804 SCM_VALIDATE_STRUCT (1, handle
);
806 vtable
= SCM_STRUCT_VTABLE (handle
);
807 data
= SCM_STRUCT_DATA (handle
);
808 p
= scm_to_size_t (pos
);
810 if (SCM_LIKELY (SCM_VTABLE_FLAG_IS_SET (vtable
, SCM_VTABLE_FLAG_SIMPLE
)
811 && SCM_VTABLE_FLAG_IS_SET (vtable
, SCM_VTABLE_FLAG_SIMPLE_RW
)
812 && p
< SCM_STRUCT_DATA_REF (vtable
, scm_vtable_index_size
)))
813 /* The fast path: HANDLE is a struct with only "pw" fields. */
814 data
[p
] = SCM_UNPACK (val
);
818 size_t layout_len
, n_fields
;
819 scm_t_wchar field_type
= 0;
821 layout
= SCM_STRUCT_LAYOUT (handle
);
822 layout_len
= scm_i_symbol_length (layout
);
823 n_fields
= layout_len
/ 2;
825 if (SCM_LAYOUT_TAILP (scm_i_symbol_ref (layout
, layout_len
- 1)))
826 n_fields
+= data
[n_fields
- 1];
828 SCM_ASSERT_RANGE (1, pos
, p
< n_fields
);
830 if (p
* 2 < layout_len
)
833 field_type
= scm_i_symbol_ref (layout
, p
* 2);
834 set_x
= scm_i_symbol_ref (layout
, p
* 2 + 1);
835 if (set_x
!= 'w' && set_x
!= 'h')
836 SCM_MISC_ERROR ("set! denied for field ~A", scm_list_1 (pos
));
838 else if (scm_i_symbol_ref (layout
, layout_len
- 1) == 'W')
839 field_type
= scm_i_symbol_ref (layout
, layout_len
- 2);
841 SCM_MISC_ERROR ("set! denied for field ~A", scm_list_1 (pos
));
846 data
[p
] = SCM_NUM2ULONG (3, val
);
851 data
[p
] = SCM_NUM2LONG (3, val
);
855 *((double *)&(data
[p
])) = scm_num2dbl (val
, (char *)SCM_ARG3
);
860 data
[p
] = SCM_UNPACK (val
);
864 SCM_MISC_ERROR ("self fields immutable", SCM_EOL
);
867 SCM_MISC_ERROR ("unrecognized field type: ~S",
868 scm_list_1 (SCM_MAKE_CHAR (field_type
)));
877 SCM_DEFINE (scm_struct_vtable
, "struct-vtable", 1, 0, 0,
879 "Return the vtable structure that describes the type of struct\n"
880 "associated with @var{handle}.")
881 #define FUNC_NAME s_scm_struct_vtable
883 SCM_VALIDATE_STRUCT (1, handle
);
884 return SCM_STRUCT_VTABLE (handle
);
889 /* {Associating names and classes with vtables}
891 * The name of a vtable should probably be stored as a slot. This is
892 * a backward compatible solution until agreement has been achieved on
893 * how to associate names with vtables.
897 scm_struct_ihashq (SCM obj
, unsigned long n
, void *closure
)
899 /* The length of the hash table should be a relative prime it's not
900 necessary to shift down the address. */
901 return SCM_UNPACK (obj
) % n
;
904 SCM_DEFINE (scm_struct_vtable_name
, "struct-vtable-name", 1, 0, 0,
906 "Return the name of the vtable @var{vtable}.")
907 #define FUNC_NAME s_scm_struct_vtable_name
909 SCM_VALIDATE_VTABLE (1, vtable
);
910 return SCM_VTABLE_NAME (vtable
);
914 SCM_DEFINE (scm_set_struct_vtable_name_x
, "set-struct-vtable-name!", 2, 0, 0,
915 (SCM vtable
, SCM name
),
916 "Set the name of the vtable @var{vtable} to @var{name}.")
917 #define FUNC_NAME s_scm_set_struct_vtable_name_x
919 SCM_VALIDATE_VTABLE (1, vtable
);
920 SCM_VALIDATE_SYMBOL (2, name
);
921 SCM_SET_VTABLE_NAME (vtable
, name
);
922 /* FIXME: remove this, and implement proper struct classes instead.
923 (Vtables *are* classes.) */
924 scm_i_define_class_for_vtable (vtable
);
925 return SCM_UNSPECIFIED
;
933 scm_print_struct (SCM exp
, SCM port
, scm_print_state
*pstate
)
935 if (scm_is_true (scm_procedure_p (SCM_STRUCT_PRINTER (exp
))))
936 scm_printer_apply (SCM_STRUCT_PRINTER (exp
), exp
, port
, pstate
);
939 SCM vtable
= SCM_STRUCT_VTABLE (exp
);
940 SCM name
= scm_struct_vtable_name (vtable
);
941 scm_puts_unlocked ("#<", port
);
942 if (scm_is_true (name
))
944 scm_display (name
, port
);
945 scm_putc_unlocked (' ', port
);
949 if (SCM_VTABLE_FLAG_IS_SET (vtable
, SCM_VTABLE_FLAG_VTABLE
))
950 scm_puts_unlocked ("vtable:", port
);
952 scm_puts_unlocked ("struct:", port
);
953 scm_uintprint (SCM_UNPACK (vtable
), 16, port
);
954 scm_putc_unlocked (' ', port
);
955 scm_write (SCM_VTABLE_LAYOUT (vtable
), port
);
956 scm_putc_unlocked (' ', port
);
958 scm_uintprint (SCM_UNPACK (exp
), 16, port
);
960 if (SCM_STRUCT_APPLICABLE_P (exp
))
962 if (scm_is_true (SCM_STRUCT_PROCEDURE (exp
)))
964 scm_puts_unlocked (" proc: ", port
);
965 if (scm_is_true (scm_procedure_p (SCM_STRUCT_PROCEDURE (exp
))))
966 scm_write (SCM_STRUCT_PROCEDURE (exp
), port
);
968 scm_puts_unlocked ("(not a procedure?)", port
);
970 if (SCM_STRUCT_SETTER_P (exp
))
972 scm_puts_unlocked (" setter: ", port
);
973 scm_write (SCM_STRUCT_SETTER (exp
), port
);
976 scm_putc_unlocked ('>', port
);
985 /* The first word of a struct is equal to `SCM_STRUCT_DATA (vtable) +
986 scm_tc3_struct', and `SCM_STRUCT_DATA (vtable)' is 2 words after VTABLE by
988 GC_REGISTER_DISPLACEMENT (2 * sizeof (scm_t_bits
) + scm_tc3_struct
);
990 /* In the general case, `SCM_STRUCT_DATA (obj)' points 2 words after the
991 beginning of a GC-allocated region; that region is different from that of
992 OBJ once OBJ has undergone class redefinition. */
993 GC_REGISTER_DISPLACEMENT (2 * sizeof (scm_t_bits
));
995 required_vtable_fields
= scm_from_locale_string (SCM_VTABLE_BASE_LAYOUT
);
996 scm_c_define ("standard-vtable-fields", required_vtable_fields
);
997 required_applicable_fields
= scm_from_locale_string (SCM_APPLICABLE_BASE_LAYOUT
);
998 required_applicable_with_setter_fields
= scm_from_locale_string (SCM_APPLICABLE_WITH_SETTER_BASE_LAYOUT
);
1000 scm_standard_vtable_vtable
= scm_i_make_vtable_vtable (scm_nullstr
);
1001 name
= scm_from_utf8_symbol ("<standard-vtable>");
1002 scm_set_struct_vtable_name_x (scm_standard_vtable_vtable
, name
);
1003 scm_define (name
, scm_standard_vtable_vtable
);
1005 scm_applicable_struct_vtable_vtable
=
1006 scm_make_struct (scm_standard_vtable_vtable
, SCM_INUM0
,
1007 scm_list_1 (scm_make_struct_layout (required_vtable_fields
)));
1008 name
= scm_from_utf8_symbol ("<applicable-struct-vtable>");
1009 SCM_SET_VTABLE_FLAGS (scm_applicable_struct_vtable_vtable
,
1010 SCM_VTABLE_FLAG_APPLICABLE_VTABLE
);
1011 scm_set_struct_vtable_name_x (scm_applicable_struct_vtable_vtable
, name
);
1012 scm_define (name
, scm_applicable_struct_vtable_vtable
);
1014 scm_applicable_struct_with_setter_vtable_vtable
=
1015 scm_make_struct (scm_standard_vtable_vtable
, SCM_INUM0
,
1016 scm_list_1 (scm_make_struct_layout (required_vtable_fields
)));
1017 name
= scm_from_utf8_symbol ("<applicable-struct-with-setter-vtable>");
1018 scm_set_struct_vtable_name_x (scm_applicable_struct_with_setter_vtable_vtable
, name
);
1019 SCM_SET_VTABLE_FLAGS (scm_applicable_struct_with_setter_vtable_vtable
,
1020 SCM_VTABLE_FLAG_APPLICABLE_VTABLE
| SCM_VTABLE_FLAG_SETTER_VTABLE
);
1021 scm_define (name
, scm_applicable_struct_with_setter_vtable_vtable
);
1023 scm_c_define ("vtable-index-layout", scm_from_int (scm_vtable_index_layout
));
1024 scm_c_define ("vtable-index-printer",
1025 scm_from_int (scm_vtable_index_instance_printer
));
1026 scm_c_define ("vtable-offset-user", scm_from_int (scm_vtable_offset_user
));
1027 #include "libguile/struct.x"