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 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
24 #include "libguile/_scm.h"
25 #include "libguile/async.h"
26 #include "libguile/chars.h"
27 #include "libguile/eval.h"
28 #include "libguile/alist.h"
29 #include "libguile/weaks.h"
30 #include "libguile/hashtab.h"
31 #include "libguile/ports.h"
32 #include "libguile/strings.h"
33 #include "libguile/srfi-13.h"
35 #include "libguile/validate.h"
36 #include "libguile/struct.h"
38 #include "libguile/eq.h"
46 static SCM required_vtable_fields
= SCM_BOOL_F
;
50 SCM_DEFINE (scm_make_struct_layout
, "make-struct-layout", 1, 0, 0,
52 "Return a new structure layout object.\n\n"
53 "@var{fields} must be a string made up of pairs of characters\n"
54 "strung together. The first character of each pair describes a field\n"
55 "type, the second a field protection. Allowed types are 'p' for\n"
56 "GC-protected Scheme data, 'u' for unprotected binary data, and 's' for\n"
57 "a field that points to the structure itself. Allowed protections\n"
58 "are 'w' for mutable fields, 'r' for read-only fields, and 'o' for opaque\n"
59 "fields. The last field protection specification may be capitalized to\n"
60 "indicate that the field is a tail-array.")
61 #define FUNC_NAME s_scm_make_struct_layout
64 SCM_VALIDATE_STRING (1, fields
);
71 len
= scm_i_string_length (fields
);
73 SCM_MISC_ERROR ("odd length field specification: ~S",
76 for (x
= 0; x
< len
; x
+= 2)
78 switch (c
= scm_i_string_ref (fields
, x
))
89 SCM_MISC_ERROR ("unrecognized field type: ~S",
90 scm_list_1 (SCM_MAKE_CHAR (c
)));
93 switch (c
= scm_i_string_ref (fields
, x
+ 1))
96 if (scm_i_string_ref (fields
, x
) == 's')
97 SCM_MISC_ERROR ("self fields not writable", SCM_EOL
);
104 if (scm_i_string_ref (fields
, 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 (c
)));
116 if (scm_i_string_ref (fields
, x
, 'd'))
118 if (!scm_i_string_ref (fields
, 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 scm_t_wchar prot
= 0;
141 int n_fields
= scm_i_symbol_length (layout
) / 2;
151 prot
= scm_i_symbol_ref (layout
, i
+1);
152 if (SCM_LAYOUT_TAILP (prot
))
155 prot
= prot
== 'R' ? 'r' : prot
== 'W' ? 'w' : 'o';
157 n_fields
+= tail_elts
- 1;
162 switch (scm_i_symbol_ref (layout
, i
))
166 if ((prot
!= 'r' && prot
!= 'w') || inits
== SCM_EOL
)
170 *mem
= scm_to_long (SCM_CAR (inits
));
171 inits
= SCM_CDR (inits
);
177 if ((prot
!= 'r' && prot
!= 'w') || scm_is_null (inits
))
181 *mem
= scm_to_ulong (SCM_CAR (inits
));
182 inits
= SCM_CDR (inits
);
187 if ((prot
!= 'r' && prot
!= 'w') || scm_is_null (inits
))
188 *mem
= SCM_UNPACK (SCM_BOOL_F
);
191 *mem
= SCM_UNPACK (SCM_CAR (inits
));
192 inits
= SCM_CDR (inits
);
199 if ((prot
!= 'r' && prot
!= 'w') || inits
== SCM_EOL
)
200 *((double *)mem
) = 0.0;
203 *mem
= scm_num2dbl (SCM_CAR (inits
), "scm_struct_init");
204 inits
= SCM_CDR (inits
);
211 *mem
= SCM_UNPACK (handle
);
221 SCM_DEFINE (scm_struct_p
, "struct?", 1, 0, 0,
223 "Return @code{#t} iff @var{x} is a structure object, else\n"
225 #define FUNC_NAME s_scm_struct_p
227 return scm_from_bool(SCM_STRUCTP (x
));
231 SCM_DEFINE (scm_struct_vtable_p
, "struct-vtable?", 1, 0, 0,
233 "Return @code{#t} iff @var{x} is a vtable structure.")
234 #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 len
= scm_i_string_length (required_vtable_fields
);
251 tmp
= scm_string_eq (scm_symbol_to_string (layout
),
252 required_vtable_fields
,
254 scm_from_size_t (len
),
256 scm_from_size_t (len
));
257 if (scm_is_false (tmp
))
260 mem
= SCM_STRUCT_DATA (x
);
262 return scm_from_bool (scm_is_symbol (SCM_PACK (mem
[scm_vtable_index_layout
])));
267 /* All struct data must be allocated at an address whose bottom three
268 bits are zero. This is because the tag for a struct lives in the
269 bottom three bits of the struct's car, and the upper bits point to
270 the data of its vtable, which is a struct itself. Thus, if the
271 address of that data doesn't end in three zeros, tagging it will
274 This function allocates a block of memory, and returns a pointer at
275 least scm_struct_n_extra_words words into the block. Furthermore,
276 it guarantees that that pointer's least three significant bits are
279 The argument n_words should be the number of words that should
280 appear after the returned address. (That is, it shouldn't include
281 scm_struct_n_extra_words.)
283 This function initializes the following fields of the struct:
285 scm_struct_i_ptr --- the actual start of the block of memory; the
286 address you should pass to 'free' to dispose of the block.
287 This field allows us to both guarantee that the returned
288 address is divisible by eight, and allow the GC to free the
291 scm_struct_i_n_words --- the number of words allocated to the
292 block, including the extra fields. This is used by the GC.
298 scm_alloc_struct (int n_words
, int n_extra
, const char *what
)
300 int size
= sizeof (scm_t_bits
) * (n_words
+ n_extra
) + 7;
301 void * block
= scm_gc_malloc (size
, what
);
303 /* Adjust the pointer to hide the extra words. */
304 scm_t_bits
* p
= (scm_t_bits
*) block
+ n_extra
;
306 /* Adjust it even further so it's aligned on an eight-byte boundary. */
307 p
= (scm_t_bits
*) (((scm_t_bits
) p
+ 7) & ~7);
309 /* Initialize a few fields as described above. */
310 p
[scm_struct_i_free
] = (scm_t_bits
) scm_struct_free_standard
;
311 p
[scm_struct_i_ptr
] = (scm_t_bits
) block
;
312 p
[scm_struct_i_n_words
] = n_words
;
313 p
[scm_struct_i_flags
] = 0;
319 scm_struct_free_0 (scm_t_bits
* vtable SCM_UNUSED
,
320 scm_t_bits
* data SCM_UNUSED
)
325 scm_struct_free_light (scm_t_bits
* vtable
, scm_t_bits
* data
)
327 size_t n
= vtable
[scm_struct_i_size
] & ~SCM_STRUCTF_MASK
;
328 scm_gc_free (data
, n
, "struct");
332 scm_struct_free_standard (scm_t_bits
* vtable SCM_UNUSED
, scm_t_bits
* data
)
334 size_t n
= (data
[scm_struct_i_n_words
] + scm_struct_n_extra_words
)
335 * sizeof (scm_t_bits
) + 7;
336 scm_gc_free ((void *) data
[scm_struct_i_ptr
], n
, "heavy struct");
340 scm_struct_free_entity (scm_t_bits
* vtable SCM_UNUSED
, scm_t_bits
* data
)
342 size_t n
= (data
[scm_struct_i_n_words
] + scm_struct_entity_n_extra_words
)
343 * sizeof (scm_t_bits
) + 7;
344 scm_gc_free ((void *) data
[scm_struct_i_ptr
], n
, "entity struct");
348 scm_struct_gc_init (void *dummy1 SCM_UNUSED
,
349 void *dummy2 SCM_UNUSED
,
350 void *dummy3 SCM_UNUSED
)
352 scm_i_structs_to_free
= SCM_EOL
;
357 scm_free_structs (void *dummy1 SCM_UNUSED
,
358 void *dummy2 SCM_UNUSED
,
359 void *dummy3 SCM_UNUSED
)
361 SCM newchain
= scm_i_structs_to_free
;
364 /* Mark vtables in GC chain. GC mark set means delay freeing. */
365 SCM chain
= newchain
;
366 while (!scm_is_null (chain
))
368 SCM vtable
= SCM_STRUCT_VTABLE (chain
);
369 if (SCM_STRUCT_GC_CHAIN (vtable
) != 0 && vtable
!= chain
)
370 SCM_SET_STRUCT_MARK (vtable
);
371 chain
= SCM_STRUCT_GC_CHAIN (chain
);
373 /* Free unmarked structs. */
376 while (!scm_is_null (chain
))
379 chain
= SCM_STRUCT_GC_CHAIN (chain
);
380 if (SCM_STRUCT_MARK_P (obj
))
382 SCM_CLEAR_STRUCT_MARK (obj
);
383 SCM_SET_STRUCT_GC_CHAIN (obj
, newchain
);
388 scm_t_bits
* vtable_data
= SCM_STRUCT_VTABLE_DATA (obj
);
389 scm_t_bits
* data
= SCM_STRUCT_DATA (obj
);
390 scm_t_struct_free free_struct_data
391 = ((scm_t_struct_free
) vtable_data
[scm_struct_i_free
]);
392 SCM_SET_CELL_TYPE (obj
, scm_tc_free_cell
);
393 free_struct_data (vtable_data
, data
);
397 while (!scm_is_null (newchain
));
401 SCM_DEFINE (scm_make_struct
, "make-struct", 2, 0, 1,
402 (SCM vtable
, SCM tail_array_size
, SCM init
),
403 "Create a new structure.\n\n"
404 "@var{type} must be a vtable structure (@pxref{Vtables}).\n\n"
405 "@var{tail-elts} must be a non-negative integer. If the layout\n"
406 "specification indicated by @var{type} includes a tail-array,\n"
407 "this is the number of elements allocated to that array.\n\n"
408 "The @var{init1}, @dots{} are optional arguments describing how\n"
409 "successive fields of the structure should be initialized. Only fields\n"
410 "with protection 'r' or 'w' can be initialized, except for fields of\n"
411 "type 's', which are automatically initialized to point to the new\n"
412 "structure itself; fields with protection 'o' can not be initialized by\n"
413 "Scheme programs.\n\n"
414 "If fewer optional arguments than initializable fields are supplied,\n"
415 "fields of type 'p' get default value #f while fields of type 'u' are\n"
416 "initialized to 0.\n\n"
417 "Structs are currently the basic representation for record-like data\n"
418 "structures in Guile. The plan is to eventually replace them with a\n"
419 "new representation which will at the same time be easier to use and\n"
421 "For more information, see the documentation for @code{make-vtable-vtable}.")
422 #define FUNC_NAME s_scm_make_struct
430 SCM_VALIDATE_VTABLE (1, vtable
);
431 SCM_VALIDATE_REST_ARGUMENT (init
);
433 layout
= SCM_PACK (SCM_STRUCT_DATA (vtable
) [scm_vtable_index_layout
]);
434 basic_size
= scm_i_symbol_length (layout
) / 2;
435 tail_elts
= scm_to_size_t (tail_array_size
);
437 /* A tail array is only allowed if the layout fields string ends in "R",
441 SCM layout_str
, last_char
;
446 SCM_MISC_ERROR ("tail array not allowed unless layout ends R, W, or O", SCM_EOL
);
449 layout_str
= scm_symbol_to_string (layout
);
450 last_char
= scm_string_ref (layout_str
,
451 scm_from_size_t (2 * basic_size
- 1));
452 if (! SCM_LAYOUT_TAILP (SCM_CHAR (last_char
)))
456 /* In guile 1.8.5 and earlier, everything below was covered by a
457 CRITICAL_SECTION lock. This can lead to deadlocks in garbage
458 collection, since other threads might be holding the heap_mutex, while
459 sleeping on the CRITICAL_SECTION lock. There does not seem to be any
460 need for a lock on the section below, as it does not access or update
461 any globals, so the critical section has been removed. */
463 if (SCM_STRUCT_DATA (vtable
)[scm_struct_i_flags
] & SCM_STRUCTF_ENTITY
)
465 data
= scm_alloc_struct (basic_size
+ tail_elts
,
466 scm_struct_entity_n_extra_words
,
468 data
[scm_struct_i_procedure
] = SCM_UNPACK (SCM_BOOL_F
);
469 data
[scm_struct_i_setter
] = SCM_UNPACK (SCM_BOOL_F
);
472 data
= scm_alloc_struct (basic_size
+ tail_elts
,
473 scm_struct_n_extra_words
,
475 handle
= scm_double_cell ((((scm_t_bits
) SCM_STRUCT_DATA (vtable
))
477 (scm_t_bits
) data
, 0, 0);
479 scm_struct_init (handle
, layout
, data
, tail_elts
, init
);
487 SCM_DEFINE (scm_make_vtable_vtable
, "make-vtable-vtable", 2, 0, 1,
488 (SCM user_fields
, SCM tail_array_size
, SCM init
),
489 "Return a new, self-describing vtable structure.\n\n"
490 "@var{user-fields} is a string describing user defined fields of the\n"
491 "vtable beginning at index @code{vtable-offset-user}\n"
492 "(see @code{make-struct-layout}).\n\n"
493 "@var{tail-size} specifies the size of the tail-array (if any) of\n"
495 "@var{init1}, @dots{} are the optional initializers for the fields of\n"
497 "Vtables have one initializable system field---the struct printer.\n"
498 "This field comes before the user fields in the initializers passed\n"
499 "to @code{make-vtable-vtable} and @code{make-struct}, and thus works as\n"
500 "a third optional argument to @code{make-vtable-vtable} and a fourth to\n"
501 "@code{make-struct} when creating vtables:\n\n"
502 "If the value is a procedure, it will be called instead of the standard\n"
503 "printer whenever a struct described by this vtable is printed.\n"
504 "The procedure will be called with arguments STRUCT and PORT.\n\n"
505 "The structure of a struct is described by a vtable, so the vtable is\n"
506 "in essence the type of the struct. The vtable is itself a struct with\n"
507 "a vtable. This could go on forever if it weren't for the\n"
508 "vtable-vtables which are self-describing vtables, and thus terminate\n"
510 "There are several potential ways of using structs, but the standard\n"
511 "one is to use three kinds of structs, together building up a type\n"
512 "sub-system: one vtable-vtable working as the root and one or several\n"
513 "\"types\", each with a set of \"instances\". (The vtable-vtable should be\n"
514 "compared to the class <class> which is the class of itself.)\n\n"
516 "(define ball-root (make-vtable-vtable \"pr\" 0))\n\n"
517 "(define (make-ball-type ball-color)\n"
518 " (make-struct ball-root 0\n"
519 " (make-struct-layout \"pw\")\n"
520 " (lambda (ball port)\n"
521 " (format port \"#<a ~A ball owned by ~A>\"\n"
525 "(define (color ball) (struct-ref (struct-vtable ball) vtable-offset-user))\n"
526 "(define (owner ball) (struct-ref ball 0))\n\n"
527 "(define red (make-ball-type 'red))\n"
528 "(define green (make-ball-type 'green))\n\n"
529 "(define (make-ball type owner) (make-struct type 0 owner))\n\n"
530 "(define ball (make-ball green 'Nisse))\n"
531 "ball @result{} #<a green ball owned by Nisse>\n"
533 #define FUNC_NAME s_scm_make_vtable_vtable
542 SCM_VALIDATE_STRING (1, user_fields
);
543 SCM_VALIDATE_REST_ARGUMENT (init
);
545 fields
= scm_string_append (scm_list_2 (required_vtable_fields
,
547 layout
= scm_make_struct_layout (fields
);
548 basic_size
= scm_i_symbol_length (layout
) / 2;
549 tail_elts
= scm_to_size_t (tail_array_size
);
550 SCM_CRITICAL_SECTION_START
;
551 data
= scm_alloc_struct (basic_size
+ tail_elts
,
552 scm_struct_n_extra_words
,
554 handle
= scm_double_cell ((scm_t_bits
) data
+ scm_tc3_struct
,
555 (scm_t_bits
) data
, 0, 0);
556 data
[scm_vtable_index_layout
] = SCM_UNPACK (layout
);
557 scm_struct_init (handle
, layout
, data
, tail_elts
, scm_cons (layout
, init
));
558 SCM_CRITICAL_SECTION_END
;
564 static SCM scm_i_vtable_vtable_no_extra_fields
;
566 SCM_DEFINE (scm_make_vtable
, "make-vtable", 1, 1, 0,
567 (SCM fields
, SCM printer
),
568 "Create a vtable, for creating structures with the given\n"
571 "The optional @var{printer} argument is a function to be called\n"
572 "@code{(@var{printer} struct port)} on the structures created.\n"
573 "It should look at @var{struct} and write to @var{port}.")
574 #define FUNC_NAME s_scm_make_vtable
576 if (SCM_UNBNDP (printer
))
577 printer
= SCM_BOOL_F
;
579 return scm_make_struct (scm_i_vtable_vtable_no_extra_fields
, SCM_INUM0
,
580 scm_list_2 (scm_make_struct_layout (fields
),
586 /* Return true if S1 and S2 are equal structures, i.e., if their vtable and
587 contents are the same. Field protections are honored. Thus, it is an
588 error to test the equality of structures that contain opaque fields. */
590 scm_i_struct_equalp (SCM s1
, SCM s2
)
591 #define FUNC_NAME "scm_i_struct_equalp"
593 SCM vtable1
, vtable2
, layout
;
594 size_t struct_size
, field_num
;
596 SCM_VALIDATE_STRUCT (1, s1
);
597 SCM_VALIDATE_STRUCT (2, s2
);
599 vtable1
= SCM_STRUCT_VTABLE (s1
);
600 vtable2
= SCM_STRUCT_VTABLE (s2
);
602 if (!scm_is_eq (vtable1
, vtable2
))
605 layout
= SCM_STRUCT_LAYOUT (s1
);
606 struct_size
= scm_i_symbol_length (layout
) / 2;
608 for (field_num
= 0; field_num
< struct_size
; field_num
++)
613 /* We have to use `scm_struct_ref ()' here so that fields are accessed
614 consistently, notably wrt. field types and access rights. */
615 s_field_num
= scm_from_size_t (field_num
);
616 field1
= scm_struct_ref (s1
, s_field_num
);
617 field2
= scm_struct_ref (s2
, s_field_num
);
619 /* Self-referencing fields (type `s') must be skipped to avoid infinite
621 if (!(scm_is_eq (field1
, s1
) && (scm_is_eq (field2
, s2
))))
622 if (scm_is_false (scm_equal_p (field1
, field2
)))
626 /* FIXME: Tail elements should be tested for equality. */
636 SCM_DEFINE (scm_struct_ref
, "struct-ref", 2, 0, 0,
637 (SCM handle
, SCM pos
),
638 "@deffnx {Scheme Procedure} struct-set! struct n value\n"
639 "Access (or modify) the @var{n}th field of @var{struct}.\n\n"
640 "If the field is of type 'p', then it can be set to an arbitrary value.\n\n"
641 "If the field is of type 'u', then it can only be set to a non-negative\n"
642 "integer value small enough to fit in one machine word.")
643 #define FUNC_NAME s_scm_struct_ref
645 SCM answer
= SCM_UNDEFINED
;
651 scm_t_wchar field_type
= 0;
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 layout_len
= scm_i_symbol_length (layout
);
661 if (SCM_STRUCT_VTABLE_FLAGS (handle
) & SCM_STRUCTF_LIGHT
)
663 n_fields
= layout_len
/ 2;
665 n_fields
= data
[scm_struct_i_n_words
];
667 SCM_ASSERT_RANGE(1, pos
, p
< n_fields
);
669 if (p
* 2 < layout_len
)
672 field_type
= scm_i_symbol_ref (layout
, p
* 2);
673 ref
= scm_i_symbol_ref (layout
, p
* 2 + 1);
674 if ((ref
!= 'r') && (ref
!= 'w'))
676 if ((ref
== 'R') || (ref
== 'W'))
679 SCM_MISC_ERROR ("ref denied for field ~A", scm_list_1 (pos
));
682 else if (scm_i_symbol_ref (layout
, layout_len
- 1) != 'O')
683 field_type
= scm_i_symbol_ref(layout
, layout_len
- 2);
685 SCM_MISC_ERROR ("ref denied for field ~A", scm_list_1 (pos
));
690 answer
= scm_from_ulong (data
[p
]);
695 answer
= scm_from_long (data
[p
]);
699 answer
= scm_make_real (*((double *)&(data
[p
])));
705 answer
= SCM_PACK (data
[p
]);
710 SCM_MISC_ERROR ("unrecognized field type: ~S",
711 scm_list_1 (SCM_MAKE_CHAR (field_type
)));
719 SCM_DEFINE (scm_struct_set_x
, "struct-set!", 3, 0, 0,
720 (SCM handle
, SCM pos
, SCM val
),
721 "Set the slot of the structure @var{handle} with index @var{pos}\n"
722 "to @var{val}. Signal an error if the slot can not be written\n"
724 #define FUNC_NAME s_scm_struct_set_x
731 scm_t_wchar field_type
= 0;
733 SCM_VALIDATE_STRUCT (1, handle
);
735 layout
= SCM_STRUCT_LAYOUT (handle
);
736 data
= SCM_STRUCT_DATA (handle
);
737 p
= scm_to_size_t (pos
);
739 layout_len
= scm_i_symbol_length (layout
);
740 if (SCM_STRUCT_VTABLE_FLAGS (handle
) & SCM_STRUCTF_LIGHT
)
742 n_fields
= layout_len
/ 2;
744 n_fields
= data
[scm_struct_i_n_words
];
746 SCM_ASSERT_RANGE (1, pos
, p
< n_fields
);
748 if (p
* 2 < layout_len
)
751 field_type
= scm_i_symbol_ref (layout
, p
* 2);
752 set_x
= scm_i_symbol_ref (layout
, p
* 2 + 1);
754 SCM_MISC_ERROR ("set! denied for field ~A", scm_list_1 (pos
));
756 else if (scm_i_symbol_ref (layout
, layout_len
- 1) == 'W')
757 field_type
= scm_i_symbol_ref (layout
, layout_len
- 2);
759 SCM_MISC_ERROR ("set! denied for field ~A", scm_list_1 (pos
));
764 data
[p
] = SCM_NUM2ULONG (3, val
);
769 data
[p
] = SCM_NUM2LONG (3, val
);
773 *((double *)&(data
[p
])) = scm_num2dbl (val
, (char *)SCM_ARG3
);
778 data
[p
] = SCM_UNPACK (val
);
782 SCM_MISC_ERROR ("self fields immutable", SCM_EOL
);
785 SCM_MISC_ERROR ("unrecognized field type: ~S",
786 scm_list_1 (SCM_MAKE_CHAR (field_type
)));
794 SCM_DEFINE (scm_struct_vtable
, "struct-vtable", 1, 0, 0,
796 "Return the vtable structure that describes the type of @var{struct}.")
797 #define FUNC_NAME s_scm_struct_vtable
799 SCM_VALIDATE_STRUCT (1, handle
);
800 return SCM_STRUCT_VTABLE (handle
);
805 SCM_DEFINE (scm_struct_vtable_tag
, "struct-vtable-tag", 1, 0, 0,
807 "Return the vtable tag of the structure @var{handle}.")
808 #define FUNC_NAME s_scm_struct_vtable_tag
810 SCM_VALIDATE_VTABLE (1, handle
);
811 return scm_from_ulong (((unsigned long)SCM_STRUCT_DATA (handle
)) >> 3);
815 /* {Associating names and classes with vtables}
817 * The name of a vtable should probably be stored as a slot. This is
818 * a backward compatible solution until agreement has been achieved on
819 * how to associate names with vtables.
823 scm_struct_ihashq (SCM obj
, unsigned long n
)
825 /* The length of the hash table should be a relative prime it's not
826 necessary to shift down the address. */
827 return SCM_UNPACK (obj
) % n
;
831 scm_struct_create_handle (SCM obj
)
833 SCM handle
= scm_hash_fn_create_handle_x (scm_struct_table
,
839 if (scm_is_false (SCM_CDR (handle
)))
840 SCM_SETCDR (handle
, scm_cons (SCM_BOOL_F
, SCM_BOOL_F
));
844 SCM_DEFINE (scm_struct_vtable_name
, "struct-vtable-name", 1, 0, 0,
846 "Return the name of the vtable @var{vtable}.")
847 #define FUNC_NAME s_scm_struct_vtable_name
849 SCM_VALIDATE_VTABLE (1, vtable
);
850 return SCM_STRUCT_TABLE_NAME (SCM_CDR (scm_struct_create_handle (vtable
)));
854 SCM_DEFINE (scm_set_struct_vtable_name_x
, "set-struct-vtable-name!", 2, 0, 0,
855 (SCM vtable
, SCM name
),
856 "Set the name of the vtable @var{vtable} to @var{name}.")
857 #define FUNC_NAME s_scm_set_struct_vtable_name_x
859 SCM_VALIDATE_VTABLE (1, vtable
);
860 SCM_VALIDATE_SYMBOL (2, name
);
861 SCM_SET_STRUCT_TABLE_NAME (SCM_CDR (scm_struct_create_handle (vtable
)),
863 return SCM_UNSPECIFIED
;
871 scm_print_struct (SCM exp
, SCM port
, scm_print_state
*pstate
)
873 if (scm_is_true (scm_procedure_p (SCM_STRUCT_PRINTER (exp
))))
874 scm_printer_apply (SCM_STRUCT_PRINTER (exp
), exp
, port
, pstate
);
877 SCM vtable
= SCM_STRUCT_VTABLE (exp
);
878 SCM name
= scm_struct_vtable_name (vtable
);
879 scm_puts ("#<", port
);
880 if (scm_is_true (name
))
881 scm_display (name
, port
);
883 scm_puts ("struct", port
);
884 scm_putc (' ', port
);
885 scm_uintprint (SCM_UNPACK (vtable
), 16, port
);
886 scm_putc (':', port
);
887 scm_uintprint (SCM_UNPACK (exp
), 16, port
);
888 scm_putc ('>', port
);
893 scm_struct_prehistory ()
895 scm_i_structs_to_free
= SCM_EOL
;
896 scm_c_hook_add (&scm_before_sweep_c_hook
, scm_struct_gc_init
, 0, 0);
897 /* With lazy sweep GC, the point at which the entire heap is swept
898 is just before the mark phase. */
899 scm_c_hook_add (&scm_before_mark_c_hook
, scm_free_structs
, 0, 0);
906 = scm_permanent_object (scm_make_weak_key_hash_table (scm_from_int (31)));
907 required_vtable_fields
= scm_from_locale_string ("prsrpw");
908 scm_permanent_object (required_vtable_fields
);
910 scm_i_vtable_vtable_no_extra_fields
=
912 (scm_make_vtable_vtable (scm_nullstr
, SCM_INUM0
, SCM_EOL
));
914 scm_c_define ("vtable-index-layout", scm_from_int (scm_vtable_index_layout
));
915 scm_c_define ("vtable-index-vtable", scm_from_int (scm_vtable_index_vtable
));
916 scm_c_define ("vtable-index-printer",
917 scm_from_int (scm_vtable_index_printer
));
918 scm_c_define ("vtable-offset-user", scm_from_int (scm_vtable_offset_user
));
919 #include "libguile/struct.x"