1 /* Copyright (C) 1996,1997,1998,1999,2000,2001, 2003, 2004, 2006, 2007, 2008, 2009 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"
34 #include "libguile/validate.h"
35 #include "libguile/struct.h"
37 #include "libguile/eq.h"
43 #include "libguile/boehm-gc.h"
47 static SCM required_vtable_fields
= SCM_BOOL_F
;
51 SCM_DEFINE (scm_make_struct_layout
, "make-struct-layout", 1, 0, 0,
53 "Return a new structure layout object.\n\n"
54 "@var{fields} must be a string made up of pairs of characters\n"
55 "strung together. The first character of each pair describes a field\n"
56 "type, the second a field protection. Allowed types are 'p' for\n"
57 "GC-protected Scheme data, 'u' for unprotected binary data, and 's' for\n"
58 "a field that points to the structure itself. Allowed protections\n"
59 "are 'w' for mutable fields, 'r' for read-only fields, and 'o' for opaque\n"
60 "fields. The last field protection specification may be capitalized to\n"
61 "indicate that the field is a tail-array.")
62 #define FUNC_NAME s_scm_make_struct_layout
65 SCM_VALIDATE_STRING (1, fields
);
68 const char * field_desc
;
72 len
= scm_i_string_length (fields
);
74 SCM_MISC_ERROR ("odd length field specification: ~S",
77 field_desc
= scm_i_string_chars (fields
);
79 for (x
= 0; x
< len
; x
+= 2)
81 switch (field_desc
[x
])
92 SCM_MISC_ERROR ("unrecognized field type: ~S",
93 scm_list_1 (SCM_MAKE_CHAR (field_desc
[x
])));
96 switch (field_desc
[x
+ 1])
99 if (field_desc
[x
] == 's')
100 SCM_MISC_ERROR ("self fields not writable", SCM_EOL
);
107 if (field_desc
[x
] == 's')
108 SCM_MISC_ERROR ("self fields not allowed in tail array",
111 SCM_MISC_ERROR ("tail array field must be last field in layout",
115 SCM_MISC_ERROR ("unrecognized ref specification: ~S",
116 scm_list_1 (SCM_MAKE_CHAR (field_desc
[x
+ 1])));
119 if (field_desc
[x
] == 'd')
121 if (field_desc
[x
+ 2] != '-')
122 SCM_MISC_ERROR ("missing dash field at position ~A",
123 scm_list_1 (scm_from_int (x
/ 2)));
129 new_sym
= scm_string_to_symbol (fields
);
131 scm_remember_upto_here_1 (fields
);
141 scm_struct_init (SCM handle
, SCM layout
, scm_t_bits
* mem
, int tail_elts
, SCM inits
)
143 unsigned const char *fields_desc
=
144 (unsigned const char *) scm_i_symbol_chars (layout
) - 2;
145 unsigned char prot
= 0;
146 int n_fields
= scm_i_symbol_length (layout
) / 2;
154 prot
= fields_desc
[1];
155 if (SCM_LAYOUT_TAILP (prot
))
158 prot
= prot
== 'R' ? 'r' : prot
== 'W' ? 'w' : 'o';
160 n_fields
+= tail_elts
- 1;
166 switch (*fields_desc
)
170 if ((prot
!= 'r' && prot
!= 'w') || inits
== SCM_EOL
)
174 *mem
= scm_to_long (SCM_CAR (inits
));
175 inits
= SCM_CDR (inits
);
181 if ((prot
!= 'r' && prot
!= 'w') || scm_is_null (inits
))
185 *mem
= scm_to_ulong (SCM_CAR (inits
));
186 inits
= SCM_CDR (inits
);
191 if ((prot
!= 'r' && prot
!= 'w') || scm_is_null (inits
))
192 *mem
= SCM_UNPACK (SCM_BOOL_F
);
195 *mem
= SCM_UNPACK (SCM_CAR (inits
));
196 inits
= SCM_CDR (inits
);
203 if ((prot
!= 'r' && prot
!= 'w') || inits
== SCM_EOL
)
204 *((double *)mem
) = 0.0;
207 *mem
= scm_num2dbl (SCM_CAR (inits
), "scm_struct_init");
208 inits
= SCM_CDR (inits
);
215 *mem
= SCM_UNPACK (handle
);
225 SCM_DEFINE (scm_struct_p
, "struct?", 1, 0, 0,
227 "Return @code{#t} iff @var{x} is a structure object, else\n"
229 #define FUNC_NAME s_scm_struct_p
231 return scm_from_bool(SCM_STRUCTP (x
));
235 SCM_DEFINE (scm_struct_vtable_p
, "struct-vtable?", 1, 0, 0,
237 "Return @code{#t} iff @var{x} is a vtable structure.")
238 #define FUNC_NAME s_scm_struct_vtable_p
244 if (!SCM_STRUCTP (x
))
247 layout
= SCM_STRUCT_LAYOUT (x
);
249 if (scm_i_symbol_length (layout
)
250 < scm_i_string_length (required_vtable_fields
))
253 tmp
= strncmp (scm_i_symbol_chars (layout
),
254 scm_i_string_chars (required_vtable_fields
),
255 scm_i_string_length (required_vtable_fields
));
256 scm_remember_upto_here_1 (required_vtable_fields
);
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
) 0;
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;
315 /* Since `SCM' objects will record either P or P + SCM_TC3_STRUCT, we need
316 to register them as valid displacements. Fortunately, only a handful of
317 N_EXTRA values are used in core Guile. */
318 GC_REGISTER_DISPLACEMENT ((char *)p
- (char *)block
);
319 GC_REGISTER_DISPLACEMENT ((char *)p
- (char *)block
+ scm_tc3_struct
);
328 /* Invoke the finalizer of the struct pointed to by PTR. */
330 struct_finalizer_trampoline (GC_PTR ptr
, GC_PTR unused_data
)
332 SCM obj
= PTR2SCM (ptr
);
334 /* XXX - use less explicit code. */
335 scm_t_bits word0
= SCM_CELL_WORD_0 (obj
) - scm_tc3_struct
;
336 scm_t_bits
*vtable_data
= (scm_t_bits
*) word0
;
337 scm_t_bits
*data
= SCM_STRUCT_DATA (obj
);
338 scm_t_struct_free free_struct_data
339 = ((scm_t_struct_free
) vtable_data
[scm_struct_i_free
]);
341 SCM_SET_CELL_TYPE (obj
, scm_tc3_struct
);
344 /* A sanity check. However, this check can fail if the free function
345 changed between the `make-struct' time and now. */
346 if (free_struct_data
!= (scm_t_struct_free
)unused_data
)
350 if (free_struct_data
)
351 free_struct_data (vtable_data
, data
);
357 SCM_DEFINE (scm_make_struct
, "make-struct", 2, 0, 1,
358 (SCM vtable
, SCM tail_array_size
, SCM init
),
359 "Create a new structure.\n\n"
360 "@var{type} must be a vtable structure (@pxref{Vtables}).\n\n"
361 "@var{tail-elts} must be a non-negative integer. If the layout\n"
362 "specification indicated by @var{type} includes a tail-array,\n"
363 "this is the number of elements allocated to that array.\n\n"
364 "The @var{init1}, @dots{} are optional arguments describing how\n"
365 "successive fields of the structure should be initialized. Only fields\n"
366 "with protection 'r' or 'w' can be initialized, except for fields of\n"
367 "type 's', which are automatically initialized to point to the new\n"
368 "structure itself; fields with protection 'o' can not be initialized by\n"
369 "Scheme programs.\n\n"
370 "If fewer optional arguments than initializable fields are supplied,\n"
371 "fields of type 'p' get default value #f while fields of type 'u' are\n"
372 "initialized to 0.\n\n"
373 "Structs are currently the basic representation for record-like data\n"
374 "structures in Guile. The plan is to eventually replace them with a\n"
375 "new representation which will at the same time be easier to use and\n"
377 "For more information, see the documentation for @code{make-vtable-vtable}.")
378 #define FUNC_NAME s_scm_make_struct
383 scm_t_bits
*data
, *c_vtable
;
386 SCM_VALIDATE_VTABLE (1, vtable
);
387 SCM_VALIDATE_REST_ARGUMENT (init
);
389 c_vtable
= SCM_STRUCT_DATA (vtable
);
391 layout
= SCM_PACK (c_vtable
[scm_vtable_index_layout
]);
392 basic_size
= scm_i_symbol_length (layout
) / 2;
393 tail_elts
= scm_to_size_t (tail_array_size
);
395 /* A tail array is only allowed if the layout fields string ends in "R",
399 SCM layout_str
, last_char
;
404 SCM_MISC_ERROR ("tail array not allowed unless layout ends R, W, or O", SCM_EOL
);
407 layout_str
= scm_symbol_to_string (layout
);
408 last_char
= scm_string_ref (layout_str
,
409 scm_from_size_t (2 * basic_size
- 1));
410 if (! SCM_LAYOUT_TAILP (SCM_CHAR (last_char
)))
414 /* In guile 1.8.5 and earlier, everything below was covered by a
415 CRITICAL_SECTION lock. This can lead to deadlocks in garbage
416 collection, since other threads might be holding the heap_mutex, while
417 sleeping on the CRITICAL_SECTION lock. There does not seem to be any
418 need for a lock on the section below, as it does not access or update
419 any globals, so the critical section has been removed. */
421 if (c_vtable
[scm_struct_i_flags
] & SCM_STRUCTF_ENTITY
)
423 data
= scm_alloc_struct (basic_size
+ tail_elts
,
424 scm_struct_entity_n_extra_words
,
426 data
[scm_struct_i_procedure
] = SCM_UNPACK (SCM_BOOL_F
);
427 data
[scm_struct_i_setter
] = SCM_UNPACK (SCM_BOOL_F
);
430 data
= scm_alloc_struct (basic_size
+ tail_elts
,
431 scm_struct_n_extra_words
,
433 handle
= scm_double_cell ((((scm_t_bits
) c_vtable
)
435 (scm_t_bits
) data
, 0, 0);
437 if (c_vtable
[scm_struct_i_free
])
439 /* Register a finalizer for the newly created instance. */
440 GC_finalization_proc prev_finalizer
;
441 GC_PTR prev_finalizer_data
;
442 scm_t_struct_free free_struct
=
443 (scm_t_struct_free
)c_vtable
[scm_struct_i_free
];
445 GC_REGISTER_FINALIZER_NO_ORDER (SCM2PTR (handle
),
446 struct_finalizer_trampoline
,
449 &prev_finalizer_data
);
452 scm_struct_init (handle
, layout
, data
, tail_elts
, init
);
460 SCM_DEFINE (scm_make_vtable_vtable
, "make-vtable-vtable", 2, 0, 1,
461 (SCM user_fields
, SCM tail_array_size
, SCM init
),
462 "Return a new, self-describing vtable structure.\n\n"
463 "@var{user-fields} is a string describing user defined fields of the\n"
464 "vtable beginning at index @code{vtable-offset-user}\n"
465 "(see @code{make-struct-layout}).\n\n"
466 "@var{tail-size} specifies the size of the tail-array (if any) of\n"
468 "@var{init1}, @dots{} are the optional initializers for the fields of\n"
470 "Vtables have one initializable system field---the struct printer.\n"
471 "This field comes before the user fields in the initializers passed\n"
472 "to @code{make-vtable-vtable} and @code{make-struct}, and thus works as\n"
473 "a third optional argument to @code{make-vtable-vtable} and a fourth to\n"
474 "@code{make-struct} when creating vtables:\n\n"
475 "If the value is a procedure, it will be called instead of the standard\n"
476 "printer whenever a struct described by this vtable is printed.\n"
477 "The procedure will be called with arguments STRUCT and PORT.\n\n"
478 "The structure of a struct is described by a vtable, so the vtable is\n"
479 "in essence the type of the struct. The vtable is itself a struct with\n"
480 "a vtable. This could go on forever if it weren't for the\n"
481 "vtable-vtables which are self-describing vtables, and thus terminate\n"
483 "There are several potential ways of using structs, but the standard\n"
484 "one is to use three kinds of structs, together building up a type\n"
485 "sub-system: one vtable-vtable working as the root and one or several\n"
486 "\"types\", each with a set of \"instances\". (The vtable-vtable should be\n"
487 "compared to the class <class> which is the class of itself.)\n\n"
489 "(define ball-root (make-vtable-vtable \"pr\" 0))\n\n"
490 "(define (make-ball-type ball-color)\n"
491 " (make-struct ball-root 0\n"
492 " (make-struct-layout \"pw\")\n"
493 " (lambda (ball port)\n"
494 " (format port \"#<a ~A ball owned by ~A>\"\n"
498 "(define (color ball) (struct-ref (struct-vtable ball) vtable-offset-user))\n"
499 "(define (owner ball) (struct-ref ball 0))\n\n"
500 "(define red (make-ball-type 'red))\n"
501 "(define green (make-ball-type 'green))\n\n"
502 "(define (make-ball type owner) (make-struct type 0 owner))\n\n"
503 "(define ball (make-ball green 'Nisse))\n"
504 "ball @result{} #<a green ball owned by Nisse>\n"
506 #define FUNC_NAME s_scm_make_vtable_vtable
515 SCM_VALIDATE_STRING (1, user_fields
);
516 SCM_VALIDATE_REST_ARGUMENT (init
);
518 fields
= scm_string_append (scm_list_2 (required_vtable_fields
,
520 layout
= scm_make_struct_layout (fields
);
521 basic_size
= scm_i_symbol_length (layout
) / 2;
522 tail_elts
= scm_to_size_t (tail_array_size
);
523 SCM_CRITICAL_SECTION_START
;
524 data
= scm_alloc_struct (basic_size
+ tail_elts
,
525 scm_struct_n_extra_words
,
527 handle
= scm_double_cell ((scm_t_bits
) data
+ scm_tc3_struct
,
528 (scm_t_bits
) data
, 0, 0);
529 data
[scm_vtable_index_layout
] = SCM_UNPACK (layout
);
530 scm_struct_init (handle
, layout
, data
, tail_elts
, scm_cons (layout
, init
));
531 SCM_CRITICAL_SECTION_END
;
537 static SCM scm_i_vtable_vtable_no_extra_fields
;
539 SCM_DEFINE (scm_make_vtable
, "make-vtable", 1, 1, 0,
540 (SCM fields
, SCM printer
),
541 "Create a vtable, for creating structures with the given\n"
544 "The optional @var{printer} argument is a function to be called\n"
545 "@code{(@var{printer} struct port)} on the structures created.\n"
546 "It should look at @var{struct} and write to @var{port}.")
547 #define FUNC_NAME s_scm_make_vtable
549 if (SCM_UNBNDP (printer
))
550 printer
= SCM_BOOL_F
;
552 return scm_make_struct (scm_i_vtable_vtable_no_extra_fields
, SCM_INUM0
,
553 scm_list_2 (scm_make_struct_layout (fields
),
559 /* Return true if S1 and S2 are equal structures, i.e., if their vtable and
560 contents are the same. Field protections are honored. Thus, it is an
561 error to test the equality of structures that contain opaque fields. */
563 scm_i_struct_equalp (SCM s1
, SCM s2
)
564 #define FUNC_NAME "scm_i_struct_equalp"
566 SCM vtable1
, vtable2
, layout
;
567 size_t struct_size
, field_num
;
569 SCM_VALIDATE_STRUCT (1, s1
);
570 SCM_VALIDATE_STRUCT (2, s2
);
572 vtable1
= SCM_STRUCT_VTABLE (s1
);
573 vtable2
= SCM_STRUCT_VTABLE (s2
);
575 if (!scm_is_eq (vtable1
, vtable2
))
578 layout
= SCM_STRUCT_LAYOUT (s1
);
579 struct_size
= scm_i_symbol_length (layout
) / 2;
581 for (field_num
= 0; field_num
< struct_size
; field_num
++)
586 /* We have to use `scm_struct_ref ()' here so that fields are accessed
587 consistently, notably wrt. field types and access rights. */
588 s_field_num
= scm_from_size_t (field_num
);
589 field1
= scm_struct_ref (s1
, s_field_num
);
590 field2
= scm_struct_ref (s2
, s_field_num
);
592 /* Self-referencing fields (type `s') must be skipped to avoid infinite
594 if (!(scm_is_eq (field1
, s1
) && (scm_is_eq (field2
, s2
))))
595 if (scm_is_false (scm_equal_p (field1
, field2
)))
599 /* FIXME: Tail elements should be tested for equality. */
609 SCM_DEFINE (scm_struct_ref
, "struct-ref", 2, 0, 0,
610 (SCM handle
, SCM pos
),
611 "@deffnx {Scheme Procedure} struct-set! struct n value\n"
612 "Access (or modify) the @var{n}th field of @var{struct}.\n\n"
613 "If the field is of type 'p', then it can be set to an arbitrary value.\n\n"
614 "If the field is of type 'u', then it can only be set to a non-negative\n"
615 "integer value small enough to fit in one machine word.")
616 #define FUNC_NAME s_scm_struct_ref
618 SCM answer
= SCM_UNDEFINED
;
624 const char *fields_desc
;
628 SCM_VALIDATE_STRUCT (1, handle
);
630 layout
= SCM_STRUCT_LAYOUT (handle
);
631 data
= SCM_STRUCT_DATA (handle
);
632 p
= scm_to_size_t (pos
);
634 fields_desc
= scm_i_symbol_chars (layout
);
635 layout_len
= scm_i_symbol_length (layout
);
636 if (SCM_STRUCT_VTABLE_FLAGS (handle
) & SCM_STRUCTF_LIGHT
)
638 n_fields
= layout_len
/ 2;
640 n_fields
= data
[scm_struct_i_n_words
];
642 SCM_ASSERT_RANGE(1, pos
, p
< n_fields
);
644 if (p
* 2 < layout_len
)
647 field_type
= fields_desc
[p
* 2];
648 ref
= fields_desc
[p
* 2 + 1];
649 if ((ref
!= 'r') && (ref
!= 'w'))
651 if ((ref
== 'R') || (ref
== 'W'))
654 SCM_MISC_ERROR ("ref denied for field ~A", scm_list_1 (pos
));
657 else if (fields_desc
[layout_len
- 1] != 'O')
658 field_type
= fields_desc
[layout_len
- 2];
660 SCM_MISC_ERROR ("ref denied for field ~A", scm_list_1 (pos
));
665 answer
= scm_from_ulong (data
[p
]);
670 answer
= scm_from_long (data
[p
]);
674 answer
= scm_make_real (*((double *)&(data
[p
])));
680 answer
= SCM_PACK (data
[p
]);
685 SCM_MISC_ERROR ("unrecognized field type: ~S",
686 scm_list_1 (SCM_MAKE_CHAR (field_type
)));
694 SCM_DEFINE (scm_struct_set_x
, "struct-set!", 3, 0, 0,
695 (SCM handle
, SCM pos
, SCM val
),
696 "Set the slot of the structure @var{handle} with index @var{pos}\n"
697 "to @var{val}. Signal an error if the slot can not be written\n"
699 #define FUNC_NAME s_scm_struct_set_x
706 const char *fields_desc
;
709 SCM_VALIDATE_STRUCT (1, handle
);
711 layout
= SCM_STRUCT_LAYOUT (handle
);
712 data
= SCM_STRUCT_DATA (handle
);
713 p
= scm_to_size_t (pos
);
715 fields_desc
= scm_i_symbol_chars (layout
);
716 layout_len
= scm_i_symbol_length (layout
);
717 if (SCM_STRUCT_VTABLE_FLAGS (handle
) & SCM_STRUCTF_LIGHT
)
719 n_fields
= layout_len
/ 2;
721 n_fields
= data
[scm_struct_i_n_words
];
723 SCM_ASSERT_RANGE (1, pos
, p
< n_fields
);
725 if (p
* 2 < layout_len
)
728 field_type
= fields_desc
[p
* 2];
729 set_x
= fields_desc
[p
* 2 + 1];
731 SCM_MISC_ERROR ("set! denied for field ~A", scm_list_1 (pos
));
733 else if (fields_desc
[layout_len
- 1] == 'W')
734 field_type
= fields_desc
[layout_len
- 2];
736 SCM_MISC_ERROR ("set! denied for field ~A", scm_list_1 (pos
));
741 data
[p
] = SCM_NUM2ULONG (3, val
);
746 data
[p
] = SCM_NUM2LONG (3, val
);
750 *((double *)&(data
[p
])) = scm_num2dbl (val
, (char *)SCM_ARG3
);
755 data
[p
] = SCM_UNPACK (val
);
759 SCM_MISC_ERROR ("self fields immutable", SCM_EOL
);
762 SCM_MISC_ERROR ("unrecognized field type: ~S",
763 scm_list_1 (SCM_MAKE_CHAR (field_type
)));
771 SCM_DEFINE (scm_struct_vtable
, "struct-vtable", 1, 0, 0,
773 "Return the vtable structure that describes the type of @var{struct}.")
774 #define FUNC_NAME s_scm_struct_vtable
776 SCM_VALIDATE_STRUCT (1, handle
);
777 return SCM_STRUCT_VTABLE (handle
);
782 SCM_DEFINE (scm_struct_vtable_tag
, "struct-vtable-tag", 1, 0, 0,
784 "Return the vtable tag of the structure @var{handle}.")
785 #define FUNC_NAME s_scm_struct_vtable_tag
787 SCM_VALIDATE_VTABLE (1, handle
);
788 return scm_from_ulong (((unsigned long)SCM_STRUCT_DATA (handle
)) >> 3);
792 /* {Associating names and classes with vtables}
794 * The name of a vtable should probably be stored as a slot. This is
795 * a backward compatible solution until agreement has been achieved on
796 * how to associate names with vtables.
800 scm_struct_ihashq (SCM obj
, unsigned long n
)
802 /* The length of the hash table should be a relative prime it's not
803 necessary to shift down the address. */
804 return SCM_UNPACK (obj
) % n
;
808 scm_struct_create_handle (SCM obj
)
810 SCM handle
= scm_hash_fn_create_handle_x (scm_struct_table
,
816 if (scm_is_false (SCM_CDR (handle
)))
817 SCM_SETCDR (handle
, scm_cons (SCM_BOOL_F
, SCM_BOOL_F
));
821 SCM_DEFINE (scm_struct_vtable_name
, "struct-vtable-name", 1, 0, 0,
823 "Return the name of the vtable @var{vtable}.")
824 #define FUNC_NAME s_scm_struct_vtable_name
826 SCM_VALIDATE_VTABLE (1, vtable
);
827 return SCM_STRUCT_TABLE_NAME (SCM_CDR (scm_struct_create_handle (vtable
)));
831 SCM_DEFINE (scm_set_struct_vtable_name_x
, "set-struct-vtable-name!", 2, 0, 0,
832 (SCM vtable
, SCM name
),
833 "Set the name of the vtable @var{vtable} to @var{name}.")
834 #define FUNC_NAME s_scm_set_struct_vtable_name_x
836 SCM_VALIDATE_VTABLE (1, vtable
);
837 SCM_VALIDATE_SYMBOL (2, name
);
838 SCM_SET_STRUCT_TABLE_NAME (SCM_CDR (scm_struct_create_handle (vtable
)),
840 return SCM_UNSPECIFIED
;
848 scm_print_struct (SCM exp
, SCM port
, scm_print_state
*pstate
)
850 if (scm_is_true (scm_procedure_p (SCM_STRUCT_PRINTER (exp
))))
851 scm_printer_apply (SCM_STRUCT_PRINTER (exp
), exp
, port
, pstate
);
854 SCM vtable
= SCM_STRUCT_VTABLE (exp
);
855 SCM name
= scm_struct_vtable_name (vtable
);
856 scm_puts ("#<", port
);
857 if (scm_is_true (name
))
858 scm_display (name
, port
);
860 scm_puts ("struct", port
);
861 scm_putc (' ', port
);
862 scm_uintprint (SCM_UNPACK (vtable
), 16, port
);
863 scm_putc (':', port
);
864 scm_uintprint (SCM_UNPACK (exp
), 16, port
);
865 scm_putc ('>', port
);
870 scm_struct_prehistory ()
879 = scm_permanent_object (scm_make_weak_key_hash_table (scm_from_int (31)));
880 required_vtable_fields
= scm_from_locale_string ("prsrpw");
881 scm_permanent_object (required_vtable_fields
);
883 scm_i_vtable_vtable_no_extra_fields
=
885 (scm_make_vtable_vtable (scm_nullstr
, SCM_INUM0
, SCM_EOL
));
887 scm_c_define ("vtable-index-layout", scm_from_int (scm_vtable_index_layout
));
888 scm_c_define ("vtable-index-vtable", scm_from_int (scm_vtable_index_vtable
));
889 scm_c_define ("vtable-index-printer",
890 scm_from_int (scm_vtable_index_printer
));
891 scm_c_define ("vtable-offset-user", scm_from_int (scm_vtable_offset_user
));
892 #include "libguile/struct.x"