1 /* Copyright (C) 1996,1997,1998,1999,2000,2001, 2003, 2004, 2006, 2007, 2008 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"
42 #include "libguile/boehm-gc.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
);
67 const char * field_desc
;
71 len
= scm_i_string_length (fields
);
73 SCM_MISC_ERROR ("odd length field specification: ~S",
76 field_desc
= scm_i_string_chars (fields
);
78 for (x
= 0; x
< len
; x
+= 2)
80 switch (field_desc
[x
])
91 SCM_MISC_ERROR ("unrecognized field type: ~S",
92 scm_list_1 (SCM_MAKE_CHAR (field_desc
[x
])));
95 switch (field_desc
[x
+ 1])
98 if (field_desc
[x
] == 's')
99 SCM_MISC_ERROR ("self fields not writable", SCM_EOL
);
106 if (field_desc
[x
] == 's')
107 SCM_MISC_ERROR ("self fields not allowed in tail array",
110 SCM_MISC_ERROR ("tail array field must be last field in layout",
114 SCM_MISC_ERROR ("unrecognized ref specification: ~S",
115 scm_list_1 (SCM_MAKE_CHAR (field_desc
[x
+ 1])));
118 if (field_desc
[x
] == 'd')
120 if (field_desc
[x
+ 2] != '-')
121 SCM_MISC_ERROR ("missing dash field at position ~A",
122 scm_list_1 (scm_from_int (x
/ 2)));
128 new_sym
= scm_string_to_symbol (fields
);
130 scm_remember_upto_here_1 (fields
);
140 scm_struct_init (SCM handle
, SCM layout
, scm_t_bits
* mem
, int tail_elts
, SCM inits
)
142 unsigned const char *fields_desc
=
143 (unsigned const char *) scm_i_symbol_chars (layout
) - 2;
144 unsigned char prot
= 0;
145 int n_fields
= scm_i_symbol_length (layout
) / 2;
153 prot
= fields_desc
[1];
154 if (SCM_LAYOUT_TAILP (prot
))
157 prot
= prot
== 'R' ? 'r' : prot
== 'W' ? 'w' : 'o';
159 n_fields
+= tail_elts
- 1;
165 switch (*fields_desc
)
169 if ((prot
!= 'r' && prot
!= 'w') || inits
== SCM_EOL
)
173 *mem
= scm_to_long (SCM_CAR (inits
));
174 inits
= SCM_CDR (inits
);
180 if ((prot
!= 'r' && prot
!= 'w') || scm_is_null (inits
))
184 *mem
= scm_to_ulong (SCM_CAR (inits
));
185 inits
= SCM_CDR (inits
);
190 if ((prot
!= 'r' && prot
!= 'w') || scm_is_null (inits
))
191 *mem
= SCM_UNPACK (SCM_BOOL_F
);
194 *mem
= SCM_UNPACK (SCM_CAR (inits
));
195 inits
= SCM_CDR (inits
);
202 if ((prot
!= 'r' && prot
!= 'w') || inits
== SCM_EOL
)
203 *((double *)mem
) = 0.0;
206 *mem
= scm_num2dbl (SCM_CAR (inits
), "scm_struct_init");
207 inits
= SCM_CDR (inits
);
214 *mem
= SCM_UNPACK (handle
);
224 SCM_DEFINE (scm_struct_p
, "struct?", 1, 0, 0,
226 "Return @code{#t} iff @var{x} is a structure object, else\n"
228 #define FUNC_NAME s_scm_struct_p
230 return scm_from_bool(SCM_STRUCTP (x
));
234 SCM_DEFINE (scm_struct_vtable_p
, "struct-vtable?", 1, 0, 0,
236 "Return @code{#t} iff @var{x} is a vtable structure.")
237 #define FUNC_NAME s_scm_struct_vtable_p
243 if (!SCM_STRUCTP (x
))
246 layout
= SCM_STRUCT_LAYOUT (x
);
248 if (scm_i_symbol_length (layout
)
249 < scm_i_string_length (required_vtable_fields
))
252 tmp
= strncmp (scm_i_symbol_chars (layout
),
253 scm_i_string_chars (required_vtable_fields
),
254 scm_i_string_length (required_vtable_fields
));
255 scm_remember_upto_here_1 (required_vtable_fields
);
259 mem
= SCM_STRUCT_DATA (x
);
261 return scm_from_bool (scm_is_symbol (SCM_PACK (mem
[scm_vtable_index_layout
])));
266 /* All struct data must be allocated at an address whose bottom three
267 bits are zero. This is because the tag for a struct lives in the
268 bottom three bits of the struct's car, and the upper bits point to
269 the data of its vtable, which is a struct itself. Thus, if the
270 address of that data doesn't end in three zeros, tagging it will
273 This function allocates a block of memory, and returns a pointer at
274 least scm_struct_n_extra_words words into the block. Furthermore,
275 it guarantees that that pointer's least three significant bits are
278 The argument n_words should be the number of words that should
279 appear after the returned address. (That is, it shouldn't include
280 scm_struct_n_extra_words.)
282 This function initializes the following fields of the struct:
284 scm_struct_i_ptr --- the actual start of the block of memory; the
285 address you should pass to 'free' to dispose of the block.
286 This field allows us to both guarantee that the returned
287 address is divisible by eight, and allow the GC to free the
290 scm_struct_i_n_words --- the number of words allocated to the
291 block, including the extra fields. This is used by the GC.
297 scm_alloc_struct (int n_words
, int n_extra
, const char *what
)
299 int size
= sizeof (scm_t_bits
) * (n_words
+ n_extra
) + 7;
300 void * block
= scm_gc_malloc (size
, what
);
302 /* Adjust the pointer to hide the extra words. */
303 scm_t_bits
* p
= (scm_t_bits
*) block
+ n_extra
;
305 /* Adjust it even further so it's aligned on an eight-byte boundary. */
306 p
= (scm_t_bits
*) (((scm_t_bits
) p
+ 7) & ~7);
308 /* Initialize a few fields as described above. */
309 p
[scm_struct_i_free
] = (scm_t_bits
) 0;
310 p
[scm_struct_i_ptr
] = (scm_t_bits
) block
;
311 p
[scm_struct_i_n_words
] = n_words
;
312 p
[scm_struct_i_flags
] = 0;
314 /* Since `SCM' objects will record either P or P + SCM_TC3_STRUCT, we need
315 to register them as valid displacements. Fortunately, only a handful of
316 N_EXTRA values are used in core Guile. */
317 GC_REGISTER_DISPLACEMENT ((char *)p
- (char *)block
);
318 GC_REGISTER_DISPLACEMENT ((char *)p
- (char *)block
+ scm_tc3_struct
);
327 /* Invoke the finalizer of the struct pointed to by PTR. */
329 struct_finalizer_trampoline (GC_PTR ptr
, GC_PTR unused_data
)
331 SCM obj
= PTR2SCM (ptr
);
333 /* XXX - use less explicit code. */
334 scm_t_bits word0
= SCM_CELL_WORD_0 (obj
) - scm_tc3_struct
;
335 scm_t_bits
*vtable_data
= (scm_t_bits
*) word0
;
336 scm_t_bits
*data
= SCM_STRUCT_DATA (obj
);
337 scm_t_struct_free free_struct_data
338 = ((scm_t_struct_free
) vtable_data
[scm_struct_i_free
]);
340 SCM_SET_CELL_TYPE (obj
, scm_tc_free_cell
);
343 /* A sanity check. However, this check can fail if the free function
344 changed between the `make-struct' time and now. */
345 if (free_struct_data
!= (scm_t_struct_free
)unused_data
)
349 if (free_struct_data
)
350 free_struct_data (vtable_data
, data
);
356 SCM_DEFINE (scm_make_struct
, "make-struct", 2, 0, 1,
357 (SCM vtable
, SCM tail_array_size
, SCM init
),
358 "Create a new structure.\n\n"
359 "@var{type} must be a vtable structure (@pxref{Vtables}).\n\n"
360 "@var{tail-elts} must be a non-negative integer. If the layout\n"
361 "specification indicated by @var{type} includes a tail-array,\n"
362 "this is the number of elements allocated to that array.\n\n"
363 "The @var{init1}, @dots{} are optional arguments describing how\n"
364 "successive fields of the structure should be initialized. Only fields\n"
365 "with protection 'r' or 'w' can be initialized, except for fields of\n"
366 "type 's', which are automatically initialized to point to the new\n"
367 "structure itself; fields with protection 'o' can not be initialized by\n"
368 "Scheme programs.\n\n"
369 "If fewer optional arguments than initializable fields are supplied,\n"
370 "fields of type 'p' get default value #f while fields of type 'u' are\n"
371 "initialized to 0.\n\n"
372 "Structs are currently the basic representation for record-like data\n"
373 "structures in Guile. The plan is to eventually replace them with a\n"
374 "new representation which will at the same time be easier to use and\n"
376 "For more information, see the documentation for @code{make-vtable-vtable}.")
377 #define FUNC_NAME s_scm_make_struct
382 scm_t_bits
*data
, *c_vtable
;
385 SCM_VALIDATE_VTABLE (1, vtable
);
386 SCM_VALIDATE_REST_ARGUMENT (init
);
388 c_vtable
= SCM_STRUCT_DATA (vtable
);
390 layout
= SCM_PACK (c_vtable
[scm_vtable_index_layout
]);
391 basic_size
= scm_i_symbol_length (layout
) / 2;
392 tail_elts
= scm_to_size_t (tail_array_size
);
394 /* A tail array is only allowed if the layout fields string ends in "R",
398 SCM layout_str
, last_char
;
403 SCM_MISC_ERROR ("tail array not allowed unless layout ends R, W, or O", SCM_EOL
);
406 layout_str
= scm_symbol_to_string (layout
);
407 last_char
= scm_string_ref (layout_str
,
408 scm_from_size_t (2 * basic_size
- 1));
409 if (! SCM_LAYOUT_TAILP (SCM_CHAR (last_char
)))
413 SCM_CRITICAL_SECTION_START
;
414 if (c_vtable
[scm_struct_i_flags
] & SCM_STRUCTF_ENTITY
)
416 data
= scm_alloc_struct (basic_size
+ tail_elts
,
417 scm_struct_entity_n_extra_words
,
419 data
[scm_struct_i_procedure
] = SCM_UNPACK (SCM_BOOL_F
);
420 data
[scm_struct_i_setter
] = SCM_UNPACK (SCM_BOOL_F
);
423 data
= scm_alloc_struct (basic_size
+ tail_elts
,
424 scm_struct_n_extra_words
,
426 handle
= scm_double_cell ((((scm_t_bits
) c_vtable
)
428 (scm_t_bits
) data
, 0, 0);
430 if (c_vtable
[scm_struct_i_free
])
432 /* Register a finalizer for the newly created instance. */
433 GC_finalization_proc prev_finalizer
;
434 GC_PTR prev_finalizer_data
;
435 scm_t_struct_free free_struct
=
436 (scm_t_struct_free
)c_vtable
[scm_struct_i_free
];
438 GC_REGISTER_FINALIZER_NO_ORDER (SCM2PTR (handle
),
439 struct_finalizer_trampoline
,
442 &prev_finalizer_data
);
445 SCM_CRITICAL_SECTION_END
;
447 /* In guile 1.8.1 and earlier, the SCM_CRITICAL_SECTION_END above covered
448 also the following scm_struct_init. But that meant if scm_struct_init
449 finds an invalid type for a "u" field then there's an error throw in a
450 critical section, which results in an abort(). Not sure if we need any
451 protection across scm_struct_init. The data array contains garbage at
452 this point, but until we return it's not visible to anyone except
454 scm_struct_init (handle
, layout
, data
, tail_elts
, init
);
462 SCM_DEFINE (scm_make_vtable_vtable
, "make-vtable-vtable", 2, 0, 1,
463 (SCM user_fields
, SCM tail_array_size
, SCM init
),
464 "Return a new, self-describing vtable structure.\n\n"
465 "@var{user-fields} is a string describing user defined fields of the\n"
466 "vtable beginning at index @code{vtable-offset-user}\n"
467 "(see @code{make-struct-layout}).\n\n"
468 "@var{tail-size} specifies the size of the tail-array (if any) of\n"
470 "@var{init1}, @dots{} are the optional initializers for the fields of\n"
472 "Vtables have one initializable system field---the struct printer.\n"
473 "This field comes before the user fields in the initializers passed\n"
474 "to @code{make-vtable-vtable} and @code{make-struct}, and thus works as\n"
475 "a third optional argument to @code{make-vtable-vtable} and a fourth to\n"
476 "@code{make-struct} when creating vtables:\n\n"
477 "If the value is a procedure, it will be called instead of the standard\n"
478 "printer whenever a struct described by this vtable is printed.\n"
479 "The procedure will be called with arguments STRUCT and PORT.\n\n"
480 "The structure of a struct is described by a vtable, so the vtable is\n"
481 "in essence the type of the struct. The vtable is itself a struct with\n"
482 "a vtable. This could go on forever if it weren't for the\n"
483 "vtable-vtables which are self-describing vtables, and thus terminate\n"
485 "There are several potential ways of using structs, but the standard\n"
486 "one is to use three kinds of structs, together building up a type\n"
487 "sub-system: one vtable-vtable working as the root and one or several\n"
488 "\"types\", each with a set of \"instances\". (The vtable-vtable should be\n"
489 "compared to the class <class> which is the class of itself.)\n\n"
491 "(define ball-root (make-vtable-vtable \"pr\" 0))\n\n"
492 "(define (make-ball-type ball-color)\n"
493 " (make-struct ball-root 0\n"
494 " (make-struct-layout \"pw\")\n"
495 " (lambda (ball port)\n"
496 " (format port \"#<a ~A ball owned by ~A>\"\n"
500 "(define (color ball) (struct-ref (struct-vtable ball) vtable-offset-user))\n"
501 "(define (owner ball) (struct-ref ball 0))\n\n"
502 "(define red (make-ball-type 'red))\n"
503 "(define green (make-ball-type 'green))\n\n"
504 "(define (make-ball type owner) (make-struct type 0 owner))\n\n"
505 "(define ball (make-ball green 'Nisse))\n"
506 "ball @result{} #<a green ball owned by Nisse>\n"
508 #define FUNC_NAME s_scm_make_vtable_vtable
517 SCM_VALIDATE_STRING (1, user_fields
);
518 SCM_VALIDATE_REST_ARGUMENT (init
);
520 fields
= scm_string_append (scm_list_2 (required_vtable_fields
,
522 layout
= scm_make_struct_layout (fields
);
523 basic_size
= scm_i_symbol_length (layout
) / 2;
524 tail_elts
= scm_to_size_t (tail_array_size
);
525 SCM_CRITICAL_SECTION_START
;
526 data
= scm_alloc_struct (basic_size
+ tail_elts
,
527 scm_struct_n_extra_words
,
529 handle
= scm_double_cell ((scm_t_bits
) data
+ scm_tc3_struct
,
530 (scm_t_bits
) data
, 0, 0);
531 data
[scm_vtable_index_layout
] = SCM_UNPACK (layout
);
532 scm_struct_init (handle
, layout
, data
, tail_elts
, scm_cons (layout
, init
));
533 SCM_CRITICAL_SECTION_END
;
539 static SCM scm_i_vtable_vtable_no_extra_fields
;
541 SCM_DEFINE (scm_make_vtable
, "make-vtable", 1, 1, 0,
542 (SCM fields
, SCM printer
),
543 "Create a vtable, for creating structures with the given\n"
546 "The optional @var{printer} argument is a function to be called\n"
547 "@code{(@var{printer} struct port)} on the structures created.\n"
548 "It should look at @var{struct} and write to @var{port}.")
549 #define FUNC_NAME s_scm_make_vtable
551 if (SCM_UNBNDP (printer
))
552 printer
= SCM_BOOL_F
;
554 return scm_make_struct (scm_i_vtable_vtable_no_extra_fields
, SCM_INUM0
,
555 scm_list_2 (scm_make_struct_layout (fields
),
561 /* Return true if S1 and S2 are equal structures, i.e., if their vtable and
562 contents are the same. Field protections are honored. Thus, it is an
563 error to test the equality of structures that contain opaque fields. */
565 scm_i_struct_equalp (SCM s1
, SCM s2
)
566 #define FUNC_NAME "scm_i_struct_equalp"
568 SCM vtable1
, vtable2
, layout
;
569 size_t struct_size
, field_num
;
571 SCM_VALIDATE_STRUCT (1, s1
);
572 SCM_VALIDATE_STRUCT (2, s2
);
574 vtable1
= SCM_STRUCT_VTABLE (s1
);
575 vtable2
= SCM_STRUCT_VTABLE (s2
);
577 if (!scm_is_eq (vtable1
, vtable2
))
580 layout
= SCM_STRUCT_LAYOUT (s1
);
581 struct_size
= scm_i_symbol_length (layout
) / 2;
583 for (field_num
= 0; field_num
< struct_size
; field_num
++)
588 /* We have to use `scm_struct_ref ()' here so that fields are accessed
589 consistently, notably wrt. field types and access rights. */
590 s_field_num
= scm_from_size_t (field_num
);
591 field1
= scm_struct_ref (s1
, s_field_num
);
592 field2
= scm_struct_ref (s2
, s_field_num
);
594 /* Self-referencing fields (type `s') must be skipped to avoid infinite
596 if (!(scm_is_eq (field1
, s1
) && (scm_is_eq (field2
, s2
))))
597 if (scm_is_false (scm_equal_p (field1
, field2
)))
601 /* FIXME: Tail elements should be tested for equality. */
611 SCM_DEFINE (scm_struct_ref
, "struct-ref", 2, 0, 0,
612 (SCM handle
, SCM pos
),
613 "@deffnx {Scheme Procedure} struct-set! struct n value\n"
614 "Access (or modify) the @var{n}th field of @var{struct}.\n\n"
615 "If the field is of type 'p', then it can be set to an arbitrary value.\n\n"
616 "If the field is of type 'u', then it can only be set to a non-negative\n"
617 "integer value small enough to fit in one machine word.")
618 #define FUNC_NAME s_scm_struct_ref
620 SCM answer
= SCM_UNDEFINED
;
626 const char *fields_desc
;
630 SCM_VALIDATE_STRUCT (1, handle
);
632 layout
= SCM_STRUCT_LAYOUT (handle
);
633 data
= SCM_STRUCT_DATA (handle
);
634 p
= scm_to_size_t (pos
);
636 fields_desc
= scm_i_symbol_chars (layout
);
637 layout_len
= scm_i_symbol_length (layout
);
638 if (SCM_STRUCT_VTABLE_FLAGS (handle
) & SCM_STRUCTF_LIGHT
)
640 n_fields
= layout_len
/ 2;
642 n_fields
= data
[scm_struct_i_n_words
];
644 SCM_ASSERT_RANGE(1, pos
, p
< n_fields
);
646 if (p
* 2 < layout_len
)
649 field_type
= fields_desc
[p
* 2];
650 ref
= fields_desc
[p
* 2 + 1];
651 if ((ref
!= 'r') && (ref
!= 'w'))
653 if ((ref
== 'R') || (ref
== 'W'))
656 SCM_MISC_ERROR ("ref denied for field ~A", scm_list_1 (pos
));
659 else if (fields_desc
[layout_len
- 1] != 'O')
660 field_type
= fields_desc
[layout_len
- 2];
662 SCM_MISC_ERROR ("ref denied for field ~A", scm_list_1 (pos
));
667 answer
= scm_from_ulong (data
[p
]);
672 answer
= scm_from_long (data
[p
]);
676 answer
= scm_make_real (*((double *)&(data
[p
])));
682 answer
= SCM_PACK (data
[p
]);
687 SCM_MISC_ERROR ("unrecognized field type: ~S",
688 scm_list_1 (SCM_MAKE_CHAR (field_type
)));
696 SCM_DEFINE (scm_struct_set_x
, "struct-set!", 3, 0, 0,
697 (SCM handle
, SCM pos
, SCM val
),
698 "Set the slot of the structure @var{handle} with index @var{pos}\n"
699 "to @var{val}. Signal an error if the slot can not be written\n"
701 #define FUNC_NAME s_scm_struct_set_x
708 const char *fields_desc
;
711 SCM_VALIDATE_STRUCT (1, handle
);
713 layout
= SCM_STRUCT_LAYOUT (handle
);
714 data
= SCM_STRUCT_DATA (handle
);
715 p
= scm_to_size_t (pos
);
717 fields_desc
= scm_i_symbol_chars (layout
);
718 layout_len
= scm_i_symbol_length (layout
);
719 if (SCM_STRUCT_VTABLE_FLAGS (handle
) & SCM_STRUCTF_LIGHT
)
721 n_fields
= layout_len
/ 2;
723 n_fields
= data
[scm_struct_i_n_words
];
725 SCM_ASSERT_RANGE (1, pos
, p
< n_fields
);
727 if (p
* 2 < layout_len
)
730 field_type
= fields_desc
[p
* 2];
731 set_x
= fields_desc
[p
* 2 + 1];
733 SCM_MISC_ERROR ("set! denied for field ~A", scm_list_1 (pos
));
735 else if (fields_desc
[layout_len
- 1] == 'W')
736 field_type
= fields_desc
[layout_len
- 2];
738 SCM_MISC_ERROR ("set! denied for field ~A", scm_list_1 (pos
));
743 data
[p
] = SCM_NUM2ULONG (3, val
);
748 data
[p
] = SCM_NUM2LONG (3, val
);
752 *((double *)&(data
[p
])) = scm_num2dbl (val
, (char *)SCM_ARG3
);
757 data
[p
] = SCM_UNPACK (val
);
761 SCM_MISC_ERROR ("self fields immutable", SCM_EOL
);
764 SCM_MISC_ERROR ("unrecognized field type: ~S",
765 scm_list_1 (SCM_MAKE_CHAR (field_type
)));
773 SCM_DEFINE (scm_struct_vtable
, "struct-vtable", 1, 0, 0,
775 "Return the vtable structure that describes the type of @var{struct}.")
776 #define FUNC_NAME s_scm_struct_vtable
778 SCM_VALIDATE_STRUCT (1, handle
);
779 return SCM_STRUCT_VTABLE (handle
);
784 SCM_DEFINE (scm_struct_vtable_tag
, "struct-vtable-tag", 1, 0, 0,
786 "Return the vtable tag of the structure @var{handle}.")
787 #define FUNC_NAME s_scm_struct_vtable_tag
789 SCM_VALIDATE_VTABLE (1, handle
);
790 return scm_from_ulong (((unsigned long)SCM_STRUCT_DATA (handle
)) >> 3);
794 /* {Associating names and classes with vtables}
796 * The name of a vtable should probably be stored as a slot. This is
797 * a backward compatible solution until agreement has been achieved on
798 * how to associate names with vtables.
802 scm_struct_ihashq (SCM obj
, unsigned long n
)
804 /* The length of the hash table should be a relative prime it's not
805 necessary to shift down the address. */
806 return SCM_UNPACK (obj
) % n
;
810 scm_struct_create_handle (SCM obj
)
812 SCM handle
= scm_hash_fn_create_handle_x (scm_struct_table
,
818 if (scm_is_false (SCM_CDR (handle
)))
819 SCM_SETCDR (handle
, scm_cons (SCM_BOOL_F
, SCM_BOOL_F
));
823 SCM_DEFINE (scm_struct_vtable_name
, "struct-vtable-name", 1, 0, 0,
825 "Return the name of the vtable @var{vtable}.")
826 #define FUNC_NAME s_scm_struct_vtable_name
828 SCM_VALIDATE_VTABLE (1, vtable
);
829 return SCM_STRUCT_TABLE_NAME (SCM_CDR (scm_struct_create_handle (vtable
)));
833 SCM_DEFINE (scm_set_struct_vtable_name_x
, "set-struct-vtable-name!", 2, 0, 0,
834 (SCM vtable
, SCM name
),
835 "Set the name of the vtable @var{vtable} to @var{name}.")
836 #define FUNC_NAME s_scm_set_struct_vtable_name_x
838 SCM_VALIDATE_VTABLE (1, vtable
);
839 SCM_VALIDATE_SYMBOL (2, name
);
840 SCM_SET_STRUCT_TABLE_NAME (SCM_CDR (scm_struct_create_handle (vtable
)),
842 return SCM_UNSPECIFIED
;
850 scm_print_struct (SCM exp
, SCM port
, scm_print_state
*pstate
)
852 if (scm_is_true (scm_procedure_p (SCM_STRUCT_PRINTER (exp
))))
853 scm_printer_apply (SCM_STRUCT_PRINTER (exp
), exp
, port
, pstate
);
856 SCM vtable
= SCM_STRUCT_VTABLE (exp
);
857 SCM name
= scm_struct_vtable_name (vtable
);
858 scm_puts ("#<", port
);
859 if (scm_is_true (name
))
860 scm_display (name
, port
);
862 scm_puts ("struct", port
);
863 scm_putc (' ', port
);
864 scm_uintprint (SCM_UNPACK (vtable
), 16, port
);
865 scm_putc (':', port
);
866 scm_uintprint (SCM_UNPACK (exp
), 16, port
);
867 scm_putc ('>', port
);
872 scm_struct_prehistory ()
881 = scm_permanent_object (scm_make_weak_key_hash_table (scm_from_int (31)));
882 required_vtable_fields
= scm_from_locale_string ("prsrpw");
883 scm_permanent_object (required_vtable_fields
);
885 scm_i_vtable_vtable_no_extra_fields
=
887 (scm_make_vtable_vtable (scm_nullstr
, SCM_INUM0
, SCM_EOL
));
889 scm_c_define ("vtable-index-layout", scm_from_int (scm_vtable_index_layout
));
890 scm_c_define ("vtable-index-vtable", scm_from_int (scm_vtable_index_vtable
));
891 scm_c_define ("vtable-index-printer",
892 scm_from_int (scm_vtable_index_printer
));
893 scm_c_define ("vtable-offset-user", scm_from_int (scm_vtable_offset_user
));
894 #include "libguile/struct.x"