1 /* Copyright (C) 1996,1997,1998,1999,2000,2001 Free Software Foundation, Inc.
3 * This program is free software; you can redistribute it and/or modify
4 * it under the terms of the GNU General Public License as published by
5 * the Free Software Foundation; either version 2, or (at your option)
8 * This program 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
11 * GNU General Public License for more details.
13 * You should have received a copy of the GNU General Public License
14 * along with this software; see the file COPYING. If not, write to
15 * the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
16 * Boston, MA 02111-1307 USA
18 * As a special exception, the Free Software Foundation gives permission
19 * for additional uses of the text contained in its release of GUILE.
21 * The exception is that, if you link the GUILE library with other files
22 * to produce an executable, this does not by itself cause the
23 * resulting executable to be covered by the GNU General Public License.
24 * Your use of that executable is in no way restricted on account of
25 * linking the GUILE library code into it.
27 * This exception does not however invalidate any other reasons why
28 * the executable file might be covered by the GNU General Public License.
30 * This exception applies only to the code released by the
31 * Free Software Foundation under the name GUILE. If you copy
32 * code from other Free Software Foundation releases into a copy of
33 * GUILE, as the General Public License permits, the exception does
34 * not apply to the code that you add in this way. To avoid misleading
35 * anyone as to the status of such modified files, you must delete
36 * this exception notice from them.
38 * If you write modifications of your own for GUILE, it is your choice
39 * whether to permit this exception to apply to your modifications.
40 * If you do not wish that, delete this exception notice. */
45 #include "libguile/_scm.h"
46 #include "libguile/chars.h"
47 #include "libguile/eval.h"
48 #include "libguile/alist.h"
49 #include "libguile/weaks.h"
50 #include "libguile/hashtab.h"
51 #include "libguile/ports.h"
52 #include "libguile/strings.h"
54 #include "libguile/validate.h"
55 #include "libguile/struct.h"
63 static SCM required_vtable_fields
= SCM_BOOL_F
;
67 SCM_DEFINE (scm_make_struct_layout
, "make-struct-layout", 1, 0, 0,
69 "Return a new structure layout object.\n\n"
70 "@var{fields} must be a string made up of pairs of characters\n"
71 "strung together. The first character of each pair describes a field\n"
72 "type, the second a field protection. Allowed types are 'p' for\n"
73 "GC-protected Scheme data, 'u' for unprotected binary data, and 's' for\n"
74 "a field that points to the structure itself. Allowed protections\n"
75 "are 'w' for mutable fields, 'r' for read-only fields, and 'o' for opaque\n"
76 "fields. The last field protection specification may be capitalized to\n"
77 "indicate that the field is a tail-array.")
78 #define FUNC_NAME s_scm_make_struct_layout
81 SCM_VALIDATE_STRING (1, fields
);
88 len
= SCM_STRING_LENGTH (fields
);
90 SCM_MISC_ERROR ("odd length field specification: ~S",
93 field_desc
= SCM_STRING_CHARS (fields
);
95 for (x
= 0; x
< len
; x
+= 2)
97 switch (field_desc
[x
])
108 SCM_MISC_ERROR ("unrecognized field type: ~S",
109 scm_list_1 (SCM_MAKE_CHAR (field_desc
[x
])));
112 switch (field_desc
[x
+ 1])
115 if (field_desc
[x
] == 's')
116 SCM_MISC_ERROR ("self fields not writable", SCM_EOL
);
123 if (field_desc
[x
] == 's')
124 SCM_MISC_ERROR ("self fields not allowed in tail array",
127 SCM_MISC_ERROR ("tail array field must be last field in layout",
131 SCM_MISC_ERROR ("unrecognized ref specification: ~S",
132 scm_list_1 (SCM_MAKE_CHAR (field_desc
[x
+ 1])));
135 if (field_desc
[x
] == 'd')
137 if (field_desc
[x
+ 2] != '-')
138 SCM_MISC_ERROR ("missing dash field at position ~A",
139 scm_list_1 (SCM_MAKINUM (x
/ 2)));
145 new_sym
= scm_mem2symbol (field_desc
, len
);
147 return scm_return_first (new_sym
, fields
);
156 scm_struct_init (SCM handle
, SCM layout
, scm_t_bits
* mem
, int tail_elts
, SCM inits
)
158 unsigned char * fields_desc
= (unsigned char *) SCM_SYMBOL_CHARS (layout
) - 2;
159 unsigned char prot
= 0;
160 int n_fields
= SCM_SYMBOL_LENGTH (layout
) / 2;
168 prot
= fields_desc
[1];
169 if (SCM_LAYOUT_TAILP (prot
))
172 prot
= prot
== 'R' ? 'r' : prot
== 'W' ? 'w' : 'o';
174 n_fields
+= tail_elts
- 1;
180 switch (*fields_desc
)
184 if ((prot
!= 'r' && prot
!= 'w') || inits
== SCM_EOL
)
188 *mem
= scm_num2long (SCM_CAR (inits
), SCM_ARGn
, "scm_struct_init");
189 inits
= SCM_CDR (inits
);
195 if ((prot
!= 'r' && prot
!= 'w') || SCM_NULLP (inits
))
199 *mem
= scm_num2ulong (SCM_CAR (inits
),
202 inits
= SCM_CDR (inits
);
207 if ((prot
!= 'r' && prot
!= 'w') || SCM_NULLP (inits
))
208 *mem
= SCM_UNPACK (SCM_BOOL_F
);
211 *mem
= SCM_UNPACK (SCM_CAR (inits
));
212 inits
= SCM_CDR (inits
);
219 if ((prot
!= 'r' && prot
!= 'w') || inits
== SCM_EOL
)
220 *((double *)mem
) = 0.0;
223 *mem
= scm_num2dbl (SCM_CAR (inits
), "scm_struct_init");
224 inits
= SCM_CDR (inits
);
231 *mem
= SCM_UNPACK (handle
);
241 SCM_DEFINE (scm_struct_p
, "struct?", 1, 0, 0,
243 "Return @code{#t} iff @var{x} is a structure object, else\n"
245 #define FUNC_NAME s_scm_struct_p
247 return SCM_BOOL(SCM_STRUCTP (x
));
251 SCM_DEFINE (scm_struct_vtable_p
, "struct-vtable?", 1, 0, 0,
253 "Return @code{#t} iff @var{x} is a vtable structure.")
254 #define FUNC_NAME s_scm_struct_vtable_p
259 if (!SCM_STRUCTP (x
))
262 layout
= SCM_STRUCT_LAYOUT (x
);
264 if (SCM_SYMBOL_LENGTH (layout
) < SCM_STRING_LENGTH (required_vtable_fields
))
267 if (strncmp (SCM_SYMBOL_CHARS (layout
), SCM_STRING_CHARS (required_vtable_fields
),
268 SCM_STRING_LENGTH (required_vtable_fields
)))
271 mem
= SCM_STRUCT_DATA (x
);
273 return SCM_BOOL (SCM_SYMBOLP (SCM_PACK (mem
[scm_vtable_index_layout
])));
278 /* All struct data must be allocated at an address whose bottom three
279 bits are zero. This is because the tag for a struct lives in the
280 bottom three bits of the struct's car, and the upper bits point to
281 the data of its vtable, which is a struct itself. Thus, if the
282 address of that data doesn't end in three zeros, tagging it will
285 This function allocates a block of memory, and returns a pointer at
286 least scm_struct_n_extra_words words into the block. Furthermore,
287 it guarantees that that pointer's least three significant bits are
290 The argument n_words should be the number of words that should
291 appear after the returned address. (That is, it shouldn't include
292 scm_struct_n_extra_words.)
294 This function initializes the following fields of the struct:
296 scm_struct_i_ptr --- the actual start of the block of memory; the
297 address you should pass to 'free' to dispose of the block.
298 This field allows us to both guarantee that the returned
299 address is divisible by eight, and allow the GC to free the
302 scm_struct_i_n_words --- the number of words allocated to the
303 block, including the extra fields. This is used by the GC.
309 scm_alloc_struct (int n_words
, int n_extra
, const char *what
)
311 int size
= sizeof (scm_t_bits
) * (n_words
+ n_extra
) + 7;
312 void * block
= scm_gc_malloc (size
, what
);
314 /* Adjust the pointer to hide the extra words. */
315 scm_t_bits
* p
= (scm_t_bits
*) block
+ n_extra
;
317 /* Adjust it even further so it's aligned on an eight-byte boundary. */
318 p
= (scm_t_bits
*) (((scm_t_bits
) p
+ 7) & ~7);
320 /* Initialize a few fields as described above. */
321 p
[scm_struct_i_free
] = (scm_t_bits
) scm_struct_free_standard
;
322 p
[scm_struct_i_ptr
] = (scm_t_bits
) block
;
323 p
[scm_struct_i_n_words
] = n_words
;
324 p
[scm_struct_i_flags
] = 0;
330 scm_struct_free_0 (scm_t_bits
* vtable SCM_UNUSED
,
331 scm_t_bits
* data SCM_UNUSED
)
336 scm_struct_free_light (scm_t_bits
* vtable
, scm_t_bits
* data
)
338 size_t n
= vtable
[scm_struct_i_size
] & ~SCM_STRUCTF_MASK
;
339 scm_gc_free (data
, n
, "struct");
343 scm_struct_free_standard (scm_t_bits
* vtable SCM_UNUSED
, scm_t_bits
* data
)
345 size_t n
= (data
[scm_struct_i_n_words
] + scm_struct_n_extra_words
)
346 * sizeof (scm_t_bits
) + 7;
347 scm_gc_free ((void *) data
[scm_struct_i_ptr
], n
, "heavy struct");
351 scm_struct_free_entity (scm_t_bits
* vtable SCM_UNUSED
, scm_t_bits
* data
)
353 size_t n
= (data
[scm_struct_i_n_words
] + scm_struct_entity_n_extra_words
)
354 * sizeof (scm_t_bits
) + 7;
355 scm_gc_free ((void *) data
[scm_struct_i_ptr
], n
, "entity struct");
359 scm_struct_gc_init (void *dummy1 SCM_UNUSED
,
360 void *dummy2 SCM_UNUSED
,
361 void *dummy3 SCM_UNUSED
)
363 scm_structs_to_free
= SCM_EOL
;
368 scm_free_structs (void *dummy1 SCM_UNUSED
,
369 void *dummy2 SCM_UNUSED
,
370 void *dummy3 SCM_UNUSED
)
372 SCM newchain
= scm_structs_to_free
;
375 /* Mark vtables in GC chain. GC mark set means delay freeing. */
376 SCM chain
= newchain
;
377 while (!SCM_NULLP (chain
))
379 SCM vtable
= SCM_STRUCT_VTABLE (chain
);
380 if (SCM_STRUCT_GC_CHAIN (vtable
) != 0 && vtable
!= chain
)
381 SCM_SETGCMARK (vtable
);
382 chain
= SCM_STRUCT_GC_CHAIN (chain
);
384 /* Free unmarked structs. */
387 while (!SCM_NULLP (chain
))
390 chain
= SCM_STRUCT_GC_CHAIN (chain
);
391 if (SCM_GCMARKP (obj
))
394 SCM_SET_STRUCT_GC_CHAIN (obj
, newchain
);
399 /* XXX - use less explicit code. */
400 scm_t_bits word0
= SCM_CELL_WORD_0 (obj
) - scm_tc3_struct
;
401 scm_t_bits
* vtable_data
= (scm_t_bits
*) word0
;
402 scm_t_bits
* data
= SCM_STRUCT_DATA (obj
);
403 scm_t_struct_free free_struct_data
404 = ((scm_t_struct_free
) vtable_data
[scm_struct_i_free
]);
405 SCM_SET_CELL_TYPE (obj
, scm_tc_free_cell
);
406 free_struct_data (vtable_data
, data
);
410 while (!SCM_NULLP (newchain
));
414 SCM_DEFINE (scm_make_struct
, "make-struct", 2, 0, 1,
415 (SCM vtable
, SCM tail_array_size
, SCM init
),
416 "Create a new structure.\n\n"
417 "@var{type} must be a vtable structure (@pxref{Vtables}).\n\n"
418 "@var{tail-elts} must be a non-negative integer. If the layout\n"
419 "specification indicated by @var{type} includes a tail-array,\n"
420 "this is the number of elements allocated to that array.\n\n"
421 "The @var{init1}, @dots{} are optional arguments describing how\n"
422 "successive fields of the structure should be initialized. Only fields\n"
423 "with protection 'r' or 'w' can be initialized, except for fields of\n"
424 "type 's', which are automatically initialized to point to the new\n"
425 "structure itself; fields with protection 'o' can not be initialized by\n"
426 "Scheme programs.\n\n"
427 "If fewer optional arguments than initializable fields are supplied,\n"
428 "fields of type 'p' get default value #f while fields of type 'u' are\n"
429 "initialized to 0.\n\n"
430 "Structs are currently the basic representation for record-like data\n"
431 "structures in Guile. The plan is to eventually replace them with a\n"
432 "new representation which will at the same time be easier to use and\n"
434 "For more information, see the documentation for @code{make-vtable-vtable}.")
435 #define FUNC_NAME s_scm_make_struct
443 SCM_VALIDATE_VTABLE (1,vtable
);
444 SCM_VALIDATE_INUM (2,tail_array_size
);
445 SCM_VALIDATE_REST_ARGUMENT (init
);
447 layout
= SCM_PACK (SCM_STRUCT_DATA (vtable
) [scm_vtable_index_layout
]);
448 basic_size
= SCM_SYMBOL_LENGTH (layout
) / 2;
449 tail_elts
= SCM_INUM (tail_array_size
);
451 if (SCM_STRUCT_DATA (vtable
)[scm_struct_i_flags
] & SCM_STRUCTF_ENTITY
)
453 data
= scm_alloc_struct (basic_size
+ tail_elts
,
454 scm_struct_entity_n_extra_words
,
456 data
[scm_struct_i_procedure
] = SCM_UNPACK (SCM_BOOL_F
);
457 data
[scm_struct_i_setter
] = SCM_UNPACK (SCM_BOOL_F
);
460 data
= scm_alloc_struct (basic_size
+ tail_elts
,
461 scm_struct_n_extra_words
,
463 handle
= scm_alloc_double_cell ((((scm_t_bits
) SCM_STRUCT_DATA (vtable
))
465 (scm_t_bits
) data
, 0, 0);
466 scm_struct_init (handle
, layout
, data
, tail_elts
, init
);
474 SCM_DEFINE (scm_make_vtable_vtable
, "make-vtable-vtable", 2, 0, 1,
475 (SCM user_fields
, SCM tail_array_size
, SCM init
),
476 "Return a new, self-describing vtable structure.\n\n"
477 "@var{user-fields} is a string describing user defined fields of the\n"
478 "vtable beginning at index @code{vtable-offset-user}\n"
479 "(see @code{make-struct-layout}).\n\n"
480 "@var{tail-size} specifies the size of the tail-array (if any) of\n"
482 "@var{init1}, @dots{} are the optional initializers for the fields of\n"
484 "Vtables have one initializable system field---the struct printer.\n"
485 "This field comes before the user fields in the initializers passed\n"
486 "to @code{make-vtable-vtable} and @code{make-struct}, and thus works as\n"
487 "a third optional argument to @code{make-vtable-vtable} and a fourth to\n"
488 "@code{make-struct} when creating vtables:\n\n"
489 "If the value is a procedure, it will be called instead of the standard\n"
490 "printer whenever a struct described by this vtable is printed.\n"
491 "The procedure will be called with arguments STRUCT and PORT.\n\n"
492 "The structure of a struct is described by a vtable, so the vtable is\n"
493 "in essence the type of the struct. The vtable is itself a struct with\n"
494 "a vtable. This could go on forever if it weren't for the\n"
495 "vtable-vtables which are self-describing vtables, and thus terminate\n"
497 "There are several potential ways of using structs, but the standard\n"
498 "one is to use three kinds of structs, together building up a type\n"
499 "sub-system: one vtable-vtable working as the root and one or several\n"
500 "\"types\", each with a set of \"instances\". (The vtable-vtable should be\n"
501 "compared to the class <class> which is the class of itself.)\n\n"
503 "(define ball-root (make-vtable-vtable \"pr\" 0))\n\n"
504 "(define (make-ball-type ball-color)\n"
505 " (make-struct ball-root 0\n"
506 " (make-struct-layout \"pw\")\n"
507 " (lambda (ball port)\n"
508 " (format port \"#<a ~A ball owned by ~A>\"\n"
512 "(define (color ball) (struct-ref (struct-vtable ball) vtable-offset-user))\n"
513 "(define (owner ball) (struct-ref ball 0))\n\n"
514 "(define red (make-ball-type 'red))\n"
515 "(define green (make-ball-type 'green))\n\n"
516 "(define (make-ball type owner) (make-struct type 0 owner))\n\n"
517 "(define ball (make-ball green 'Nisse))\n"
518 "ball @result{} #<a green ball owned by Nisse>\n"
520 #define FUNC_NAME s_scm_make_vtable_vtable
529 SCM_VALIDATE_STRING (1, user_fields
);
530 SCM_VALIDATE_INUM (2, tail_array_size
);
531 SCM_VALIDATE_REST_ARGUMENT (init
);
533 fields
= scm_string_append (scm_list_2 (required_vtable_fields
,
535 layout
= scm_make_struct_layout (fields
);
536 basic_size
= SCM_SYMBOL_LENGTH (layout
) / 2;
537 tail_elts
= SCM_INUM (tail_array_size
);
539 data
= scm_alloc_struct (basic_size
+ tail_elts
,
540 scm_struct_n_extra_words
,
542 handle
= scm_alloc_double_cell ((scm_t_bits
) data
+ scm_tc3_struct
,
543 (scm_t_bits
) data
, 0, 0);
544 data
[scm_vtable_index_layout
] = SCM_UNPACK (layout
);
545 scm_struct_init (handle
, layout
, data
, tail_elts
, scm_cons (layout
, init
));
554 SCM_DEFINE (scm_struct_ref
, "struct-ref", 2, 0, 0,
555 (SCM handle
, SCM pos
),
556 "@deffnx {Scheme Procedure} struct-set! struct n value\n"
557 "Access (or modify) the @var{n}th field of @var{struct}.\n\n"
558 "If the field is of type 'p', then it can be set to an arbitrary value.\n\n"
559 "If the field is of type 'u', then it can only be set to a non-negative\n"
560 "integer value small enough to fit in one machine word.")
561 #define FUNC_NAME s_scm_struct_ref
563 SCM answer
= SCM_UNDEFINED
;
572 SCM_VALIDATE_STRUCT (1,handle
);
573 SCM_VALIDATE_INUM (2,pos
);
575 layout
= SCM_STRUCT_LAYOUT (handle
);
576 data
= SCM_STRUCT_DATA (handle
);
579 fields_desc
= SCM_SYMBOL_CHARS (layout
);
580 n_fields
= data
[scm_struct_i_n_words
];
582 SCM_ASSERT_RANGE(1,pos
, p
< n_fields
);
584 if (p
* 2 < SCM_SYMBOL_LENGTH (layout
))
587 field_type
= fields_desc
[p
* 2];
588 ref
= fields_desc
[p
* 2 + 1];
589 if ((ref
!= 'r') && (ref
!= 'w'))
591 if ((ref
== 'R') || (ref
== 'W'))
594 SCM_MISC_ERROR ("ref denied for field ~A", scm_list_1 (pos
));
597 else if (fields_desc
[SCM_SYMBOL_LENGTH (layout
) - 1] != 'O')
598 field_type
= fields_desc
[SCM_SYMBOL_LENGTH (layout
) - 2];
600 SCM_MISC_ERROR ("ref denied for field ~A", scm_list_1 (pos
));
605 answer
= scm_ulong2num (data
[p
]);
610 answer
= scm_long2num (data
[p
]);
614 answer
= scm_make_real (*((double *)&(data
[p
])));
620 answer
= SCM_PACK (data
[p
]);
625 SCM_MISC_ERROR ("unrecognized field type: ~S",
626 scm_list_1 (SCM_MAKE_CHAR (field_type
)));
634 SCM_DEFINE (scm_struct_set_x
, "struct-set!", 3, 0, 0,
635 (SCM handle
, SCM pos
, SCM val
),
636 "Set the slot of the structure @var{handle} with index @var{pos}\n"
637 "to @var{val}. Signal an error if the slot can not be written\n"
639 #define FUNC_NAME s_scm_struct_set_x
648 SCM_VALIDATE_STRUCT (1,handle
);
649 SCM_VALIDATE_INUM (2,pos
);
651 layout
= SCM_STRUCT_LAYOUT (handle
);
652 data
= SCM_STRUCT_DATA (handle
);
655 fields_desc
= SCM_SYMBOL_CHARS (layout
);
656 n_fields
= data
[scm_struct_i_n_words
];
658 SCM_ASSERT_RANGE (1,pos
, p
< n_fields
);
660 if (p
* 2 < SCM_SYMBOL_LENGTH (layout
))
663 field_type
= fields_desc
[p
* 2];
664 set_x
= fields_desc
[p
* 2 + 1];
666 SCM_MISC_ERROR ("set! denied for field ~A", scm_list_1 (pos
));
668 else if (fields_desc
[SCM_SYMBOL_LENGTH (layout
) - 1] == 'W')
669 field_type
= fields_desc
[SCM_SYMBOL_LENGTH (layout
) - 2];
671 SCM_MISC_ERROR ("set! denied for field ~A", scm_list_1 (pos
));
676 data
[p
] = SCM_NUM2ULONG (3, val
);
681 data
[p
] = SCM_NUM2LONG (3, val
);
685 *((double *)&(data
[p
])) = scm_num2dbl (val
, (char *)SCM_ARG3
);
690 data
[p
] = SCM_UNPACK (val
);
694 SCM_MISC_ERROR ("self fields immutable", SCM_EOL
);
697 SCM_MISC_ERROR ("unrecognized field type: ~S",
698 scm_list_1 (SCM_MAKE_CHAR (field_type
)));
706 SCM_DEFINE (scm_struct_vtable
, "struct-vtable", 1, 0, 0,
708 "Return the vtable structure that describes the type of @var{struct}.")
709 #define FUNC_NAME s_scm_struct_vtable
711 SCM_VALIDATE_STRUCT (1,handle
);
712 return SCM_STRUCT_VTABLE (handle
);
717 SCM_DEFINE (scm_struct_vtable_tag
, "struct-vtable-tag", 1, 0, 0,
719 "Return the vtable tag of the structure @var{handle}.")
720 #define FUNC_NAME s_scm_struct_vtable_tag
722 SCM_VALIDATE_VTABLE (1,handle
);
723 return scm_long2num ((long) SCM_STRUCT_DATA (handle
) >> 3);
727 /* {Associating names and classes with vtables}
729 * The name of a vtable should probably be stored as a slot. This is
730 * a backward compatible solution until agreement has been achieved on
731 * how to associate names with vtables.
735 scm_struct_ihashq (SCM obj
, unsigned long n
)
737 /* The length of the hash table should be a relative prime it's not
738 necessary to shift down the address. */
739 return SCM_UNPACK (obj
) % n
;
743 scm_struct_create_handle (SCM obj
)
745 SCM handle
= scm_hash_fn_create_handle_x (scm_struct_table
,
751 if (SCM_FALSEP (SCM_CDR (handle
)))
752 SCM_SETCDR (handle
, scm_cons (SCM_BOOL_F
, SCM_BOOL_F
));
756 SCM_DEFINE (scm_struct_vtable_name
, "struct-vtable-name", 1, 0, 0,
758 "Return the name of the vtable @var{vtable}.")
759 #define FUNC_NAME s_scm_struct_vtable_name
761 SCM_VALIDATE_VTABLE (1,vtable
);
762 return SCM_STRUCT_TABLE_NAME (SCM_CDR (scm_struct_create_handle (vtable
)));
766 SCM_DEFINE (scm_set_struct_vtable_name_x
, "set-struct-vtable-name!", 2, 0, 0,
767 (SCM vtable
, SCM name
),
768 "Set the name of the vtable @var{vtable} to @var{name}.")
769 #define FUNC_NAME s_scm_set_struct_vtable_name_x
771 SCM_VALIDATE_VTABLE (1,vtable
);
772 SCM_VALIDATE_SYMBOL (2,name
);
773 SCM_SET_STRUCT_TABLE_NAME (SCM_CDR (scm_struct_create_handle (vtable
)),
775 return SCM_UNSPECIFIED
;
783 scm_print_struct (SCM exp
, SCM port
, scm_print_state
*pstate
)
785 if (SCM_NFALSEP (scm_procedure_p (SCM_STRUCT_PRINTER (exp
))))
786 scm_printer_apply (SCM_STRUCT_PRINTER (exp
), exp
, port
, pstate
);
789 SCM vtable
= SCM_STRUCT_VTABLE (exp
);
790 SCM name
= scm_struct_vtable_name (vtable
);
791 scm_puts ("#<", port
);
792 if (SCM_NFALSEP (name
))
793 scm_display (name
, port
);
795 scm_puts ("struct", port
);
796 scm_putc (' ', port
);
797 scm_intprint (SCM_UNPACK (vtable
), 16, port
);
798 scm_putc (':', port
);
799 scm_intprint (SCM_UNPACK (exp
), 16, port
);
800 scm_putc ('>', port
);
805 scm_struct_prehistory ()
807 scm_c_hook_add (&scm_before_mark_c_hook
, scm_struct_gc_init
, 0, 0);
808 scm_c_hook_add (&scm_after_sweep_c_hook
, scm_free_structs
, 0, 0);
815 = scm_permanent_object (scm_make_weak_key_hash_table (SCM_MAKINUM (31)));
816 required_vtable_fields
= scm_makfrom0str ("prsrpw");
817 scm_permanent_object (required_vtable_fields
);
818 scm_c_define ("vtable-index-layout", SCM_MAKINUM (scm_vtable_index_layout
));
819 scm_c_define ("vtable-index-vtable", SCM_MAKINUM (scm_vtable_index_vtable
));
820 scm_c_define ("vtable-index-printer",
821 SCM_MAKINUM (scm_vtable_index_printer
));
822 scm_c_define ("vtable-offset-user", SCM_MAKINUM (scm_vtable_offset_user
));
823 #ifndef SCM_MAGIC_SNARFER
824 #include "libguile/struct.x"