1 /* Copyright (C) 1996,1997,1998,1999,2000,2001, 2003, 2004, 2006, 2007 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
5 * License as published by the Free Software Foundation; either
6 * version 2.1 of the License, or (at your option) any later version.
8 * This library is distributed in the hope that it will be useful,
9 * but 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 02110-1301 USA
23 #include "libguile/_scm.h"
24 #include "libguile/async.h"
25 #include "libguile/chars.h"
26 #include "libguile/eval.h"
27 #include "libguile/alist.h"
28 #include "libguile/weaks.h"
29 #include "libguile/hashtab.h"
30 #include "libguile/ports.h"
31 #include "libguile/strings.h"
33 #include "libguile/validate.h"
34 #include "libguile/struct.h"
36 #include "libguile/eq.h"
44 static SCM required_vtable_fields
= SCM_BOOL_F
;
48 SCM_DEFINE (scm_make_struct_layout
, "make-struct-layout", 1, 0, 0,
50 "Return a new structure layout object.\n\n"
51 "@var{fields} must be a string made up of pairs of characters\n"
52 "strung together. The first character of each pair describes a field\n"
53 "type, the second a field protection. Allowed types are 'p' for\n"
54 "GC-protected Scheme data, 'u' for unprotected binary data, and 's' for\n"
55 "a field that points to the structure itself. Allowed protections\n"
56 "are 'w' for mutable fields, 'r' for read-only fields, and 'o' for opaque\n"
57 "fields. The last field protection specification may be capitalized to\n"
58 "indicate that the field is a tail-array.")
59 #define FUNC_NAME s_scm_make_struct_layout
62 SCM_VALIDATE_STRING (1, fields
);
65 const char * field_desc
;
69 len
= scm_i_string_length (fields
);
71 SCM_MISC_ERROR ("odd length field specification: ~S",
74 field_desc
= scm_i_string_chars (fields
);
76 for (x
= 0; x
< len
; x
+= 2)
78 switch (field_desc
[x
])
89 SCM_MISC_ERROR ("unrecognized field type: ~S",
90 scm_list_1 (SCM_MAKE_CHAR (field_desc
[x
])));
93 switch (field_desc
[x
+ 1])
96 if (field_desc
[x
] == 's')
97 SCM_MISC_ERROR ("self fields not writable", SCM_EOL
);
104 if (field_desc
[x
] == 's')
105 SCM_MISC_ERROR ("self fields not allowed in tail array",
108 SCM_MISC_ERROR ("tail array field must be last field in layout",
112 SCM_MISC_ERROR ("unrecognized ref specification: ~S",
113 scm_list_1 (SCM_MAKE_CHAR (field_desc
[x
+ 1])));
116 if (field_desc
[x
] == 'd')
118 if (field_desc
[x
+ 2] != '-')
119 SCM_MISC_ERROR ("missing dash field at position ~A",
120 scm_list_1 (scm_from_int (x
/ 2)));
126 new_sym
= scm_string_to_symbol (fields
);
128 scm_remember_upto_here_1 (fields
);
138 scm_struct_init (SCM handle
, SCM layout
, scm_t_bits
* mem
, int tail_elts
, SCM inits
)
140 unsigned const char *fields_desc
=
141 (unsigned const char *) scm_i_symbol_chars (layout
) - 2;
142 unsigned char prot
= 0;
143 int n_fields
= scm_i_symbol_length (layout
) / 2;
151 prot
= fields_desc
[1];
152 if (SCM_LAYOUT_TAILP (prot
))
155 prot
= prot
== 'R' ? 'r' : prot
== 'W' ? 'w' : 'o';
157 n_fields
+= tail_elts
- 1;
163 switch (*fields_desc
)
167 if ((prot
!= 'r' && prot
!= 'w') || inits
== SCM_EOL
)
171 *mem
= scm_to_long (SCM_CAR (inits
));
172 inits
= SCM_CDR (inits
);
178 if ((prot
!= 'r' && prot
!= 'w') || scm_is_null (inits
))
182 *mem
= scm_to_ulong (SCM_CAR (inits
));
183 inits
= SCM_CDR (inits
);
188 if ((prot
!= 'r' && prot
!= 'w') || scm_is_null (inits
))
189 *mem
= SCM_UNPACK (SCM_BOOL_F
);
192 *mem
= SCM_UNPACK (SCM_CAR (inits
));
193 inits
= SCM_CDR (inits
);
200 if ((prot
!= 'r' && prot
!= 'w') || inits
== SCM_EOL
)
201 *((double *)mem
) = 0.0;
204 *mem
= scm_num2dbl (SCM_CAR (inits
), "scm_struct_init");
205 inits
= SCM_CDR (inits
);
212 *mem
= SCM_UNPACK (handle
);
222 SCM_DEFINE (scm_struct_p
, "struct?", 1, 0, 0,
224 "Return @code{#t} iff @var{x} is a structure object, else\n"
226 #define FUNC_NAME s_scm_struct_p
228 return scm_from_bool(SCM_STRUCTP (x
));
232 SCM_DEFINE (scm_struct_vtable_p
, "struct-vtable?", 1, 0, 0,
234 "Return @code{#t} iff @var{x} is a vtable structure.")
235 #define FUNC_NAME s_scm_struct_vtable_p
241 if (!SCM_STRUCTP (x
))
244 layout
= SCM_STRUCT_LAYOUT (x
);
246 if (scm_i_symbol_length (layout
)
247 < scm_i_string_length (required_vtable_fields
))
250 tmp
= strncmp (scm_i_symbol_chars (layout
),
251 scm_i_string_chars (required_vtable_fields
),
252 scm_i_string_length (required_vtable_fields
));
253 scm_remember_upto_here_1 (required_vtable_fields
);
257 mem
= SCM_STRUCT_DATA (x
);
259 return scm_from_bool (scm_is_symbol (SCM_PACK (mem
[scm_vtable_index_layout
])));
264 /* All struct data must be allocated at an address whose bottom three
265 bits are zero. This is because the tag for a struct lives in the
266 bottom three bits of the struct's car, and the upper bits point to
267 the data of its vtable, which is a struct itself. Thus, if the
268 address of that data doesn't end in three zeros, tagging it will
271 This function allocates a block of memory, and returns a pointer at
272 least scm_struct_n_extra_words words into the block. Furthermore,
273 it guarantees that that pointer's least three significant bits are
276 The argument n_words should be the number of words that should
277 appear after the returned address. (That is, it shouldn't include
278 scm_struct_n_extra_words.)
280 This function initializes the following fields of the struct:
282 scm_struct_i_ptr --- the actual start of the block of memory; the
283 address you should pass to 'free' to dispose of the block.
284 This field allows us to both guarantee that the returned
285 address is divisible by eight, and allow the GC to free the
288 scm_struct_i_n_words --- the number of words allocated to the
289 block, including the extra fields. This is used by the GC.
295 scm_alloc_struct (int n_words
, int n_extra
, const char *what
)
297 int size
= sizeof (scm_t_bits
) * (n_words
+ n_extra
) + 7;
298 void * block
= scm_gc_malloc (size
, what
);
300 /* Adjust the pointer to hide the extra words. */
301 scm_t_bits
* p
= (scm_t_bits
*) block
+ n_extra
;
303 /* Adjust it even further so it's aligned on an eight-byte boundary. */
304 p
= (scm_t_bits
*) (((scm_t_bits
) p
+ 7) & ~7);
306 /* Initialize a few fields as described above. */
307 p
[scm_struct_i_free
] = (scm_t_bits
) scm_struct_free_standard
;
308 p
[scm_struct_i_ptr
] = (scm_t_bits
) block
;
309 p
[scm_struct_i_n_words
] = n_words
;
310 p
[scm_struct_i_flags
] = 0;
316 scm_struct_free_0 (scm_t_bits
* vtable SCM_UNUSED
,
317 scm_t_bits
* data SCM_UNUSED
)
322 scm_struct_free_light (scm_t_bits
* vtable
, scm_t_bits
* data
)
324 size_t n
= vtable
[scm_struct_i_size
] & ~SCM_STRUCTF_MASK
;
325 scm_gc_free (data
, n
, "struct");
329 scm_struct_free_standard (scm_t_bits
* vtable SCM_UNUSED
, scm_t_bits
* data
)
331 size_t n
= (data
[scm_struct_i_n_words
] + scm_struct_n_extra_words
)
332 * sizeof (scm_t_bits
) + 7;
333 scm_gc_free ((void *) data
[scm_struct_i_ptr
], n
, "heavy struct");
337 scm_struct_free_entity (scm_t_bits
* vtable SCM_UNUSED
, scm_t_bits
* data
)
339 size_t n
= (data
[scm_struct_i_n_words
] + scm_struct_entity_n_extra_words
)
340 * sizeof (scm_t_bits
) + 7;
341 scm_gc_free ((void *) data
[scm_struct_i_ptr
], n
, "entity struct");
345 scm_struct_gc_init (void *dummy1 SCM_UNUSED
,
346 void *dummy2 SCM_UNUSED
,
347 void *dummy3 SCM_UNUSED
)
349 scm_i_structs_to_free
= SCM_EOL
;
354 scm_free_structs (void *dummy1 SCM_UNUSED
,
355 void *dummy2 SCM_UNUSED
,
356 void *dummy3 SCM_UNUSED
)
358 SCM newchain
= scm_i_structs_to_free
;
361 /* Mark vtables in GC chain. GC mark set means delay freeing. */
362 SCM chain
= newchain
;
363 while (!scm_is_null (chain
))
365 SCM vtable
= SCM_STRUCT_VTABLE (chain
);
366 if (SCM_STRUCT_GC_CHAIN (vtable
) != 0 && vtable
!= chain
)
367 SCM_SET_STRUCT_MARK (vtable
);
368 chain
= SCM_STRUCT_GC_CHAIN (chain
);
370 /* Free unmarked structs. */
373 while (!scm_is_null (chain
))
376 chain
= SCM_STRUCT_GC_CHAIN (chain
);
377 if (SCM_STRUCT_MARK_P (obj
))
379 SCM_CLEAR_STRUCT_MARK (obj
);
380 SCM_SET_STRUCT_GC_CHAIN (obj
, newchain
);
385 scm_t_bits
* vtable_data
= SCM_STRUCT_VTABLE_DATA (obj
);
386 scm_t_bits
* data
= SCM_STRUCT_DATA (obj
);
387 scm_t_struct_free free_struct_data
388 = ((scm_t_struct_free
) vtable_data
[scm_struct_i_free
]);
389 SCM_SET_CELL_TYPE (obj
, scm_tc_free_cell
);
390 free_struct_data (vtable_data
, data
);
394 while (!scm_is_null (newchain
));
398 SCM_DEFINE (scm_make_struct
, "make-struct", 2, 0, 1,
399 (SCM vtable
, SCM tail_array_size
, SCM init
),
400 "Create a new structure.\n\n"
401 "@var{type} must be a vtable structure (@pxref{Vtables}).\n\n"
402 "@var{tail-elts} must be a non-negative integer. If the layout\n"
403 "specification indicated by @var{type} includes a tail-array,\n"
404 "this is the number of elements allocated to that array.\n\n"
405 "The @var{init1}, @dots{} are optional arguments describing how\n"
406 "successive fields of the structure should be initialized. Only fields\n"
407 "with protection 'r' or 'w' can be initialized, except for fields of\n"
408 "type 's', which are automatically initialized to point to the new\n"
409 "structure itself; fields with protection 'o' can not be initialized by\n"
410 "Scheme programs.\n\n"
411 "If fewer optional arguments than initializable fields are supplied,\n"
412 "fields of type 'p' get default value #f while fields of type 'u' are\n"
413 "initialized to 0.\n\n"
414 "Structs are currently the basic representation for record-like data\n"
415 "structures in Guile. The plan is to eventually replace them with a\n"
416 "new representation which will at the same time be easier to use and\n"
418 "For more information, see the documentation for @code{make-vtable-vtable}.")
419 #define FUNC_NAME s_scm_make_struct
427 SCM_VALIDATE_VTABLE (1, vtable
);
428 SCM_VALIDATE_REST_ARGUMENT (init
);
430 layout
= SCM_PACK (SCM_STRUCT_DATA (vtable
) [scm_vtable_index_layout
]);
431 basic_size
= scm_i_symbol_length (layout
) / 2;
432 tail_elts
= scm_to_size_t (tail_array_size
);
434 /* A tail array is only allowed if the layout fields string ends in "R",
438 SCM layout_str
, last_char
;
443 SCM_MISC_ERROR ("tail array not allowed unless layout ends R, W, or O", SCM_EOL
);
446 layout_str
= scm_symbol_to_string (layout
);
447 last_char
= scm_string_ref (layout_str
,
448 scm_from_size_t (2 * basic_size
- 1));
449 if (! SCM_LAYOUT_TAILP (SCM_CHAR (last_char
)))
453 SCM_CRITICAL_SECTION_START
;
454 if (SCM_STRUCT_DATA (vtable
)[scm_struct_i_flags
] & SCM_STRUCTF_ENTITY
)
456 data
= scm_alloc_struct (basic_size
+ tail_elts
,
457 scm_struct_entity_n_extra_words
,
459 data
[scm_struct_i_procedure
] = SCM_UNPACK (SCM_BOOL_F
);
460 data
[scm_struct_i_setter
] = SCM_UNPACK (SCM_BOOL_F
);
463 data
= scm_alloc_struct (basic_size
+ tail_elts
,
464 scm_struct_n_extra_words
,
466 handle
= scm_double_cell ((((scm_t_bits
) SCM_STRUCT_DATA (vtable
))
468 (scm_t_bits
) data
, 0, 0);
469 SCM_CRITICAL_SECTION_END
;
471 /* In guile 1.8.1 and earlier, the SCM_CRITICAL_SECTION_END above covered
472 also the following scm_struct_init. But that meant if scm_struct_init
473 finds an invalid type for a "u" field then there's an error throw in a
474 critical section, which results in an abort(). Not sure if we need any
475 protection across scm_struct_init. The data array contains garbage at
476 this point, but until we return it's not visible to anyone except
478 scm_struct_init (handle
, layout
, data
, tail_elts
, init
);
486 SCM_DEFINE (scm_make_vtable_vtable
, "make-vtable-vtable", 2, 0, 1,
487 (SCM user_fields
, SCM tail_array_size
, SCM init
),
488 "Return a new, self-describing vtable structure.\n\n"
489 "@var{user-fields} is a string describing user defined fields of the\n"
490 "vtable beginning at index @code{vtable-offset-user}\n"
491 "(see @code{make-struct-layout}).\n\n"
492 "@var{tail-size} specifies the size of the tail-array (if any) of\n"
494 "@var{init1}, @dots{} are the optional initializers for the fields of\n"
496 "Vtables have one initializable system field---the struct printer.\n"
497 "This field comes before the user fields in the initializers passed\n"
498 "to @code{make-vtable-vtable} and @code{make-struct}, and thus works as\n"
499 "a third optional argument to @code{make-vtable-vtable} and a fourth to\n"
500 "@code{make-struct} when creating vtables:\n\n"
501 "If the value is a procedure, it will be called instead of the standard\n"
502 "printer whenever a struct described by this vtable is printed.\n"
503 "The procedure will be called with arguments STRUCT and PORT.\n\n"
504 "The structure of a struct is described by a vtable, so the vtable is\n"
505 "in essence the type of the struct. The vtable is itself a struct with\n"
506 "a vtable. This could go on forever if it weren't for the\n"
507 "vtable-vtables which are self-describing vtables, and thus terminate\n"
509 "There are several potential ways of using structs, but the standard\n"
510 "one is to use three kinds of structs, together building up a type\n"
511 "sub-system: one vtable-vtable working as the root and one or several\n"
512 "\"types\", each with a set of \"instances\". (The vtable-vtable should be\n"
513 "compared to the class <class> which is the class of itself.)\n\n"
515 "(define ball-root (make-vtable-vtable \"pr\" 0))\n\n"
516 "(define (make-ball-type ball-color)\n"
517 " (make-struct ball-root 0\n"
518 " (make-struct-layout \"pw\")\n"
519 " (lambda (ball port)\n"
520 " (format port \"#<a ~A ball owned by ~A>\"\n"
524 "(define (color ball) (struct-ref (struct-vtable ball) vtable-offset-user))\n"
525 "(define (owner ball) (struct-ref ball 0))\n\n"
526 "(define red (make-ball-type 'red))\n"
527 "(define green (make-ball-type 'green))\n\n"
528 "(define (make-ball type owner) (make-struct type 0 owner))\n\n"
529 "(define ball (make-ball green 'Nisse))\n"
530 "ball @result{} #<a green ball owned by Nisse>\n"
532 #define FUNC_NAME s_scm_make_vtable_vtable
541 SCM_VALIDATE_STRING (1, user_fields
);
542 SCM_VALIDATE_REST_ARGUMENT (init
);
544 fields
= scm_string_append (scm_list_2 (required_vtable_fields
,
546 layout
= scm_make_struct_layout (fields
);
547 basic_size
= scm_i_symbol_length (layout
) / 2;
548 tail_elts
= scm_to_size_t (tail_array_size
);
549 SCM_CRITICAL_SECTION_START
;
550 data
= scm_alloc_struct (basic_size
+ tail_elts
,
551 scm_struct_n_extra_words
,
553 handle
= scm_double_cell ((scm_t_bits
) data
+ scm_tc3_struct
,
554 (scm_t_bits
) data
, 0, 0);
555 data
[scm_vtable_index_layout
] = SCM_UNPACK (layout
);
556 scm_struct_init (handle
, layout
, data
, tail_elts
, scm_cons (layout
, init
));
557 SCM_CRITICAL_SECTION_END
;
563 static SCM scm_i_vtable_vtable_no_extra_fields
;
565 SCM_DEFINE (scm_make_vtable
, "make-vtable", 1, 1, 0,
566 (SCM fields
, SCM printer
),
567 "Create a vtable, for creating structures with the given\n"
570 "The optional @var{printer} argument is a function to be called\n"
571 "@code{(@var{printer} struct port)} on the structures created.\n"
572 "It should look at @var{struct} and write to @var{port}.")
573 #define FUNC_NAME s_scm_make_vtable
575 if (SCM_UNBNDP (printer
))
576 printer
= SCM_BOOL_F
;
578 return scm_make_struct (scm_i_vtable_vtable_no_extra_fields
, SCM_INUM0
,
579 scm_list_2 (scm_make_struct_layout (fields
),
585 /* Return true if S1 and S2 are equal structures, i.e., if their vtable and
586 contents are the same. Field protections are honored. Thus, it is an
587 error to test the equality of structures that contain opaque fields. */
589 scm_i_struct_equalp (SCM s1
, SCM s2
)
590 #define FUNC_NAME "scm_i_struct_equalp"
592 SCM vtable1
, vtable2
, layout
;
593 size_t struct_size
, field_num
;
595 SCM_VALIDATE_STRUCT (1, s1
);
596 SCM_VALIDATE_STRUCT (2, s2
);
598 vtable1
= SCM_STRUCT_VTABLE (s1
);
599 vtable2
= SCM_STRUCT_VTABLE (s2
);
601 if (!scm_is_eq (vtable1
, vtable2
))
604 layout
= SCM_STRUCT_LAYOUT (s1
);
605 struct_size
= scm_i_symbol_length (layout
) / 2;
607 for (field_num
= 0; field_num
< struct_size
; field_num
++)
612 /* We have to use `scm_struct_ref ()' here so that fields are accessed
613 consistently, notably wrt. field types and access rights. */
614 s_field_num
= scm_from_size_t (field_num
);
615 field1
= scm_struct_ref (s1
, s_field_num
);
616 field2
= scm_struct_ref (s2
, s_field_num
);
618 /* Self-referencing fields (type `s') must be skipped to avoid infinite
620 if (!(scm_is_eq (field1
, s1
) && (scm_is_eq (field2
, s2
))))
621 if (scm_is_false (scm_equal_p (field1
, field2
)))
625 /* FIXME: Tail elements should be tested for equality. */
635 SCM_DEFINE (scm_struct_ref
, "struct-ref", 2, 0, 0,
636 (SCM handle
, SCM pos
),
637 "@deffnx {Scheme Procedure} struct-set! struct n value\n"
638 "Access (or modify) the @var{n}th field of @var{struct}.\n\n"
639 "If the field is of type 'p', then it can be set to an arbitrary value.\n\n"
640 "If the field is of type 'u', then it can only be set to a non-negative\n"
641 "integer value small enough to fit in one machine word.")
642 #define FUNC_NAME s_scm_struct_ref
644 SCM answer
= SCM_UNDEFINED
;
650 const char *fields_desc
;
654 SCM_VALIDATE_STRUCT (1, handle
);
656 layout
= SCM_STRUCT_LAYOUT (handle
);
657 data
= SCM_STRUCT_DATA (handle
);
658 p
= scm_to_size_t (pos
);
660 fields_desc
= scm_i_symbol_chars (layout
);
661 layout_len
= scm_i_symbol_length (layout
);
662 if (SCM_STRUCT_VTABLE_FLAGS (handle
) & SCM_STRUCTF_LIGHT
)
664 n_fields
= layout_len
/ 2;
666 n_fields
= data
[scm_struct_i_n_words
];
668 SCM_ASSERT_RANGE(1, pos
, p
< n_fields
);
670 if (p
* 2 < layout_len
)
673 field_type
= fields_desc
[p
* 2];
674 ref
= fields_desc
[p
* 2 + 1];
675 if ((ref
!= 'r') && (ref
!= 'w'))
677 if ((ref
== 'R') || (ref
== 'W'))
680 SCM_MISC_ERROR ("ref denied for field ~A", scm_list_1 (pos
));
683 else if (fields_desc
[layout_len
- 1] != 'O')
684 field_type
= fields_desc
[layout_len
- 2];
686 SCM_MISC_ERROR ("ref denied for field ~A", scm_list_1 (pos
));
691 answer
= scm_from_ulong (data
[p
]);
696 answer
= scm_from_long (data
[p
]);
700 answer
= scm_make_real (*((double *)&(data
[p
])));
706 answer
= SCM_PACK (data
[p
]);
711 SCM_MISC_ERROR ("unrecognized field type: ~S",
712 scm_list_1 (SCM_MAKE_CHAR (field_type
)));
720 SCM_DEFINE (scm_struct_set_x
, "struct-set!", 3, 0, 0,
721 (SCM handle
, SCM pos
, SCM val
),
722 "Set the slot of the structure @var{handle} with index @var{pos}\n"
723 "to @var{val}. Signal an error if the slot can not be written\n"
725 #define FUNC_NAME s_scm_struct_set_x
732 const char *fields_desc
;
735 SCM_VALIDATE_STRUCT (1, handle
);
737 layout
= SCM_STRUCT_LAYOUT (handle
);
738 data
= SCM_STRUCT_DATA (handle
);
739 p
= scm_to_size_t (pos
);
741 fields_desc
= scm_i_symbol_chars (layout
);
742 layout_len
= scm_i_symbol_length (layout
);
743 if (SCM_STRUCT_VTABLE_FLAGS (handle
) & SCM_STRUCTF_LIGHT
)
745 n_fields
= layout_len
/ 2;
747 n_fields
= data
[scm_struct_i_n_words
];
749 SCM_ASSERT_RANGE (1, pos
, p
< n_fields
);
751 if (p
* 2 < layout_len
)
754 field_type
= fields_desc
[p
* 2];
755 set_x
= fields_desc
[p
* 2 + 1];
757 SCM_MISC_ERROR ("set! denied for field ~A", scm_list_1 (pos
));
759 else if (fields_desc
[layout_len
- 1] == 'W')
760 field_type
= fields_desc
[layout_len
- 2];
762 SCM_MISC_ERROR ("set! denied for field ~A", scm_list_1 (pos
));
767 data
[p
] = SCM_NUM2ULONG (3, val
);
772 data
[p
] = SCM_NUM2LONG (3, val
);
776 *((double *)&(data
[p
])) = scm_num2dbl (val
, (char *)SCM_ARG3
);
781 data
[p
] = SCM_UNPACK (val
);
785 SCM_MISC_ERROR ("self fields immutable", SCM_EOL
);
788 SCM_MISC_ERROR ("unrecognized field type: ~S",
789 scm_list_1 (SCM_MAKE_CHAR (field_type
)));
797 SCM_DEFINE (scm_struct_vtable
, "struct-vtable", 1, 0, 0,
799 "Return the vtable structure that describes the type of @var{struct}.")
800 #define FUNC_NAME s_scm_struct_vtable
802 SCM_VALIDATE_STRUCT (1, handle
);
803 return SCM_STRUCT_VTABLE (handle
);
808 SCM_DEFINE (scm_struct_vtable_tag
, "struct-vtable-tag", 1, 0, 0,
810 "Return the vtable tag of the structure @var{handle}.")
811 #define FUNC_NAME s_scm_struct_vtable_tag
813 SCM_VALIDATE_VTABLE (1, handle
);
814 return scm_from_ulong (((unsigned long)SCM_STRUCT_DATA (handle
)) >> 3);
818 /* {Associating names and classes with vtables}
820 * The name of a vtable should probably be stored as a slot. This is
821 * a backward compatible solution until agreement has been achieved on
822 * how to associate names with vtables.
826 scm_struct_ihashq (SCM obj
, unsigned long n
)
828 /* The length of the hash table should be a relative prime it's not
829 necessary to shift down the address. */
830 return SCM_UNPACK (obj
) % n
;
834 scm_struct_create_handle (SCM obj
)
836 SCM handle
= scm_hash_fn_create_handle_x (scm_struct_table
,
842 if (scm_is_false (SCM_CDR (handle
)))
843 SCM_SETCDR (handle
, scm_cons (SCM_BOOL_F
, SCM_BOOL_F
));
847 SCM_DEFINE (scm_struct_vtable_name
, "struct-vtable-name", 1, 0, 0,
849 "Return the name of the vtable @var{vtable}.")
850 #define FUNC_NAME s_scm_struct_vtable_name
852 SCM_VALIDATE_VTABLE (1, vtable
);
853 return SCM_STRUCT_TABLE_NAME (SCM_CDR (scm_struct_create_handle (vtable
)));
857 SCM_DEFINE (scm_set_struct_vtable_name_x
, "set-struct-vtable-name!", 2, 0, 0,
858 (SCM vtable
, SCM name
),
859 "Set the name of the vtable @var{vtable} to @var{name}.")
860 #define FUNC_NAME s_scm_set_struct_vtable_name_x
862 SCM_VALIDATE_VTABLE (1, vtable
);
863 SCM_VALIDATE_SYMBOL (2, name
);
864 SCM_SET_STRUCT_TABLE_NAME (SCM_CDR (scm_struct_create_handle (vtable
)),
866 return SCM_UNSPECIFIED
;
874 scm_print_struct (SCM exp
, SCM port
, scm_print_state
*pstate
)
876 if (scm_is_true (scm_procedure_p (SCM_STRUCT_PRINTER (exp
))))
877 scm_printer_apply (SCM_STRUCT_PRINTER (exp
), exp
, port
, pstate
);
880 SCM vtable
= SCM_STRUCT_VTABLE (exp
);
881 SCM name
= scm_struct_vtable_name (vtable
);
882 scm_puts ("#<", port
);
883 if (scm_is_true (name
))
884 scm_display (name
, port
);
886 scm_puts ("struct", port
);
887 scm_putc (' ', port
);
888 scm_uintprint (SCM_UNPACK (vtable
), 16, port
);
889 scm_putc (':', port
);
890 scm_uintprint (SCM_UNPACK (exp
), 16, port
);
891 scm_putc ('>', port
);
896 scm_struct_prehistory ()
898 scm_i_structs_to_free
= SCM_EOL
;
899 scm_c_hook_add (&scm_before_sweep_c_hook
, scm_struct_gc_init
, 0, 0);
900 /* With lazy sweep GC, the point at which the entire heap is swept
901 is just before the mark phase. */
902 scm_c_hook_add (&scm_before_mark_c_hook
, scm_free_structs
, 0, 0);
909 = scm_permanent_object (scm_make_weak_key_hash_table (scm_from_int (31)));
910 required_vtable_fields
= scm_from_locale_string ("prsrpw");
911 scm_permanent_object (required_vtable_fields
);
913 scm_i_vtable_vtable_no_extra_fields
=
915 (scm_make_vtable_vtable (scm_nullstr
, SCM_INUM0
, SCM_EOL
));
917 scm_c_define ("vtable-index-layout", scm_from_int (scm_vtable_index_layout
));
918 scm_c_define ("vtable-index-vtable", scm_from_int (scm_vtable_index_vtable
));
919 scm_c_define ("vtable-index-printer",
920 scm_from_int (scm_vtable_index_printer
));
921 scm_c_define ("vtable-offset-user", scm_from_int (scm_vtable_offset_user
));
922 #include "libguile/struct.x"