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. */
42 /* Software engineering face-lift by Greg J. Badros, 11-Dec-1999,
43 gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */
48 #include "libguile/_scm.h"
49 #include "libguile/chars.h"
50 #include "libguile/eval.h"
51 #include "libguile/alist.h"
52 #include "libguile/weaks.h"
53 #include "libguile/hashtab.h"
54 #include "libguile/ports.h"
55 #include "libguile/strings.h"
57 #include "libguile/validate.h"
58 #include "libguile/struct.h"
66 static SCM required_vtable_fields
= SCM_BOOL_F
;
70 SCM_DEFINE (scm_make_struct_layout
, "make-struct-layout", 1, 0, 0,
72 "Return a new structure layout object.\n\n"
73 "@var{fields} must be a string made up of pairs of characters\n"
74 "strung together. The first character of each pair describes a field\n"
75 "type, the second a field protection. Allowed types are 'p' for\n"
76 "GC-protected Scheme data, 'u' for unprotected binary data, and 's' for\n"
77 "a field that points to the structure itself. Allowed protections\n"
78 "are 'w' for mutable fields, 'r' for read-only fields, and 'o' for opaque \n"
79 "fields. The last field protection specification may be capitalized to\n"
80 "indicate that the field is a tail-array.")
81 #define FUNC_NAME s_scm_make_struct_layout
84 SCM_VALIDATE_STRING (1, fields
);
91 len
= SCM_STRING_LENGTH (fields
);
93 SCM_MISC_ERROR ("odd length field specification: ~S",
96 field_desc
= SCM_STRING_CHARS (fields
);
98 for (x
= 0; x
< len
; x
+= 2)
100 switch (field_desc
[x
])
111 SCM_MISC_ERROR ("unrecognized field type: ~S",
112 SCM_LIST1 (SCM_MAKE_CHAR (field_desc
[x
])));
115 switch (field_desc
[x
+ 1])
118 if (field_desc
[x
] == 's')
119 SCM_MISC_ERROR ("self fields not writable", SCM_EOL
);
126 if (field_desc
[x
] == 's')
127 SCM_MISC_ERROR ("self fields not allowed in tail array",
130 SCM_MISC_ERROR ("tail array field must be last field in layout",
134 SCM_MISC_ERROR ("unrecognized ref specification: ~S",
135 SCM_LIST1 (SCM_MAKE_CHAR (field_desc
[x
+ 1])));
138 if (field_desc
[x
] == 'd')
140 if (field_desc
[x
+ 2] != '-')
141 SCM_MISC_ERROR ("missing dash field at position ~A",
142 SCM_LIST1 (SCM_MAKINUM (x
/ 2)));
148 new_sym
= scm_mem2symbol (field_desc
, len
);
150 return scm_return_first (new_sym
, fields
);
159 scm_struct_init (SCM handle
, SCM layout
, scm_bits_t
* mem
, int tail_elts
, SCM inits
)
161 unsigned char * fields_desc
= (unsigned char *) SCM_SYMBOL_CHARS (layout
) - 2;
162 unsigned char prot
= 0;
163 int n_fields
= SCM_SYMBOL_LENGTH (layout
) / 2;
171 prot
= fields_desc
[1];
172 if (SCM_LAYOUT_TAILP (prot
))
175 prot
= prot
== 'R' ? 'r' : prot
== 'W' ? 'w' : 'o';
177 n_fields
+= tail_elts
- 1;
183 switch (*fields_desc
)
187 if ((prot
!= 'r' && prot
!= 'w') || inits
== SCM_EOL
)
191 *mem
= scm_num2long (SCM_CAR (inits
), SCM_ARGn
, "scm_struct_init");
192 inits
= SCM_CDR (inits
);
198 if ((prot
!= 'r' && prot
!= 'w') || SCM_NULLP (inits
))
202 *mem
= scm_num2ulong (SCM_CAR (inits
),
205 inits
= SCM_CDR (inits
);
210 if ((prot
!= 'r' && prot
!= 'w') || SCM_NULLP (inits
))
211 *mem
= SCM_UNPACK (SCM_BOOL_F
);
214 *mem
= SCM_UNPACK (SCM_CAR (inits
));
215 inits
= SCM_CDR (inits
);
222 if ((prot
!= 'r' && prot
!= 'w') || inits
== SCM_EOL
)
223 *((double *)mem
) = 0.0;
226 *mem
= scm_num2dbl (SCM_CAR (inits
), "scm_struct_init");
227 inits
= SCM_CDR (inits
);
234 *mem
= SCM_UNPACK (handle
);
244 SCM_DEFINE (scm_struct_p
, "struct?", 1, 0, 0,
246 "Return @code{#t} iff @var{obj} is a structure object, else\n"
248 #define FUNC_NAME s_scm_struct_p
250 return SCM_BOOL(SCM_STRUCTP (x
));
254 SCM_DEFINE (scm_struct_vtable_p
, "struct-vtable?", 1, 0, 0,
256 "Return @code{#t} iff obj is a vtable structure.")
257 #define FUNC_NAME s_scm_struct_vtable_p
262 if (!SCM_STRUCTP (x
))
265 layout
= SCM_STRUCT_LAYOUT (x
);
267 if (SCM_SYMBOL_LENGTH (layout
) < SCM_STRING_LENGTH (required_vtable_fields
))
270 if (strncmp (SCM_SYMBOL_CHARS (layout
), SCM_STRING_CHARS (required_vtable_fields
),
271 SCM_STRING_LENGTH (required_vtable_fields
)))
274 mem
= SCM_STRUCT_DATA (x
);
279 return SCM_BOOL (SCM_SYMBOLP (SCM_PACK (mem
[0])));
284 /* All struct data must be allocated at an address whose bottom three
285 bits are zero. This is because the tag for a struct lives in the
286 bottom three bits of the struct's car, and the upper bits point to
287 the data of its vtable, which is a struct itself. Thus, if the
288 address of that data doesn't end in three zeros, tagging it will
291 This function allocates a block of memory, and returns a pointer at
292 least scm_struct_n_extra_words words into the block. Furthermore,
293 it guarantees that that pointer's least three significant bits are
296 The argument n_words should be the number of words that should
297 appear after the returned address. (That is, it shouldn't include
298 scm_struct_n_extra_words.)
300 This function initializes the following fields of the struct:
302 scm_struct_i_ptr --- the actual start of the block of memory; the
303 address you should pass to 'free' to dispose of the block.
304 This field allows us to both guarantee that the returned
305 address is divisible by eight, and allow the GC to free the
308 scm_struct_i_n_words --- the number of words allocated to the
309 block, including the extra fields. This is used by the GC.
315 scm_alloc_struct (int n_words
, int n_extra
, char *who
)
317 int size
= sizeof (scm_bits_t
) * (n_words
+ n_extra
) + 7;
318 void * block
= scm_must_malloc (size
, who
);
320 /* Adjust the pointer to hide the extra words. */
321 scm_bits_t
* p
= (scm_bits_t
*) block
+ n_extra
;
323 /* Adjust it even further so it's aligned on an eight-byte boundary. */
324 p
= (scm_bits_t
*) (((scm_bits_t
) p
+ 7) & ~7);
326 /* Initialize a few fields as described above. */
327 p
[scm_struct_i_free
] = (scm_bits_t
) scm_struct_free_standard
;
328 p
[scm_struct_i_ptr
] = (scm_bits_t
) block
;
329 p
[scm_struct_i_n_words
] = n_words
;
330 p
[scm_struct_i_flags
] = 0;
336 scm_struct_free_0 (scm_bits_t
* vtable
, scm_bits_t
* data
)
342 scm_struct_free_light (scm_bits_t
* vtable
, scm_bits_t
* data
)
344 scm_must_free (data
);
345 return vtable
[scm_struct_i_size
] & ~SCM_STRUCTF_MASK
;
349 scm_struct_free_standard (scm_bits_t
* vtable
, scm_bits_t
* data
)
351 size_t n
= (data
[scm_struct_i_n_words
] + scm_struct_n_extra_words
)
352 * sizeof (scm_bits_t
) + 7;
353 scm_must_free ((void *) data
[scm_struct_i_ptr
]);
358 scm_struct_free_entity (scm_bits_t
* vtable
, scm_bits_t
* data
)
360 size_t n
= (data
[scm_struct_i_n_words
] + scm_struct_entity_n_extra_words
)
361 * sizeof (scm_bits_t
) + 7;
362 scm_must_free ((void *) data
[scm_struct_i_ptr
]);
367 scm_struct_gc_init (void *dummy1
, void *dummy2
, void *dummy3
)
369 scm_structs_to_free
= SCM_EOL
;
374 scm_free_structs (void *dummy1
, void *dummy2
, void *dummy3
)
376 SCM newchain
= scm_structs_to_free
;
379 /* Mark vtables in GC chain. GC mark set means delay freeing. */
380 SCM chain
= newchain
;
381 while (SCM_NNULLP (chain
))
383 SCM vtable
= SCM_STRUCT_VTABLE (chain
);
384 if (SCM_STRUCT_GC_CHAIN (vtable
) != 0 && vtable
!= chain
)
385 SCM_SETGCMARK (vtable
);
386 chain
= SCM_STRUCT_GC_CHAIN (chain
);
388 /* Free unmarked structs. */
391 while (SCM_NNULLP (chain
))
394 chain
= SCM_STRUCT_GC_CHAIN (chain
);
395 if (SCM_GCMARKP (obj
))
398 SCM_SET_STRUCT_GC_CHAIN (obj
, newchain
);
403 scm_bits_t word0
= SCM_CELL_WORD_0 (obj
) - scm_tc3_cons_gloc
;
404 /* access as struct */
405 scm_bits_t
* vtable_data
= (scm_bits_t
*) word0
;
406 scm_bits_t
* data
= (scm_bits_t
*) SCM_UNPACK (SCM_CDR (obj
));
407 scm_struct_free_t free_struct_data
408 = ((scm_struct_free_t
) vtable_data
[scm_struct_i_free
]);
409 SCM_SET_CELL_TYPE (obj
, scm_tc_free_cell
);
410 free_struct_data (vtable_data
, data
);
414 while (SCM_NNULLP (newchain
));
418 SCM_DEFINE (scm_make_struct
, "make-struct", 2, 0, 1,
419 (SCM vtable
, SCM tail_array_size
, SCM init
),
420 "Create a new structure.\n\n"
421 "@var{type} must be a vtable structure (@pxref{Vtables}).\n\n"
422 "@var{tail-elts} must be a non-negative integer. If the layout\n"
423 "specification indicated by @var{type} includes a tail-array,\n"
424 "this is the number of elements allocated to that array.\n\n"
425 "The @var{init1}, @dots{} are optional arguments describing how\n"
426 "successive fields of the structure should be initialized. Only fields\n"
427 "with protection 'r' or 'w' can be initialized, except for fields of\n"
428 "type 's', which are automatically initialized to point to the new\n"
429 "structure itself; fields with protection 'o' can not be initialized by\n"
430 "Scheme programs.\n\n"
431 "If fewer optional arguments than initializable fields are supplied,\n"
432 "fields of type 'p' get default value #f while fields of type 'u' are\n"
433 "initialized to 0.\n\n"
434 "Structs are currently the basic representation for record-like data\n"
435 "structures in Guile. The plan is to eventually replace them with a\n"
436 "new representation which will at the same time be easier to use and\n"
438 "For more information, see the documentation for @code{make-vtable-vtable}.")
439 #define FUNC_NAME s_scm_make_struct
447 SCM_VALIDATE_VTABLE (1,vtable
);
448 SCM_VALIDATE_INUM (2,tail_array_size
);
449 SCM_VALIDATE_REST_ARGUMENT (init
);
451 layout
= SCM_PACK (SCM_STRUCT_DATA (vtable
) [scm_vtable_index_layout
]);
452 basic_size
= SCM_SYMBOL_LENGTH (layout
) / 2;
453 tail_elts
= SCM_INUM (tail_array_size
);
454 SCM_NEWCELL2 (handle
);
456 if (SCM_STRUCT_DATA (vtable
)[scm_struct_i_flags
] & SCM_STRUCTF_ENTITY
)
458 data
= scm_alloc_struct (basic_size
+ tail_elts
,
459 scm_struct_entity_n_extra_words
,
461 data
[scm_struct_i_procedure
] = SCM_UNPACK (SCM_BOOL_F
);
462 data
[scm_struct_i_setter
] = SCM_UNPACK (SCM_BOOL_F
);
465 data
= scm_alloc_struct (basic_size
+ tail_elts
,
466 scm_struct_n_extra_words
,
468 SCM_SET_CELL_WORD_1 (handle
, data
);
469 SCM_SET_STRUCT_GC_CHAIN (handle
, 0);
470 scm_struct_init (handle
, layout
, data
, tail_elts
, init
);
471 SCM_SET_CELL_WORD_0 (handle
, (scm_bits_t
) SCM_STRUCT_DATA (vtable
) + scm_tc3_cons_gloc
);
479 SCM_DEFINE (scm_make_vtable_vtable
, "make-vtable-vtable", 2, 0, 1,
480 (SCM user_fields
, SCM tail_array_size
, SCM init
),
481 "Return a new, self-describing vtable structure.\n\n"
482 "@var{user-fields} is a string describing user defined fields of the\n"
483 "vtable beginning at index @code{vtable-offset-user}\n"
484 "(see @code{make-struct-layout}).\n\n"
485 "@var{tail-size} specifies the size of the tail-array (if any) of\n"
487 "@var{init1}, @dots{} are the optional initializers for the fields of\n"
489 "Vtables have one initializable system field---the struct printer.\n"
490 "This field comes before the user fields in the initializers passed\n"
491 "to @code{make-vtable-vtable} and @code{make-struct}, and thus works as\n"
492 "a third optional argument to @code{make-vtable-vtable} and a fourth to\n"
493 "@code{make-struct} when creating vtables:\n\n"
494 "If the value is a procedure, it will be called instead of the standard\n"
495 "printer whenever a struct described by this vtable is printed.\n"
496 "The procedure will be called with arguments STRUCT and PORT.\n\n"
497 "The structure of a struct is described by a vtable, so the vtable is\n"
498 "in essence the type of the struct. The vtable is itself a struct with\n"
499 "a vtable. This could go on forever if it weren't for the\n"
500 "vtable-vtables which are self-describing vtables, and thus terminate\n"
502 "There are several potential ways of using structs, but the standard\n"
503 "one is to use three kinds of structs, together building up a type\n"
504 "sub-system: one vtable-vtable working as the root and one or several\n"
505 "\"types\", each with a set of \"instances\". (The vtable-vtable should be\n"
506 "compared to the class <class> which is the class of itself.)\n\n"
508 "(define ball-root (make-vtable-vtable \"pr\" 0))\n\n"
509 "(define (make-ball-type ball-color)\n"
510 " (make-struct ball-root 0\n"
511 " (make-struct-layout \"pw\")\n"
512 " (lambda (ball port)\n"
513 " (format port \"#<a ~A ball owned by ~A>\"\n"
517 "(define (color ball) (struct-ref (struct-vtable ball) vtable-offset-user))\n"
518 "(define (owner ball) (struct-ref ball 0))\n\n"
519 "(define red (make-ball-type 'red))\n"
520 "(define green (make-ball-type 'green))\n\n"
521 "(define (make-ball type owner) (make-struct type 0 owner))\n\n"
522 "(define ball (make-ball green 'Nisse))\n"
523 "ball @result{} #<a green ball owned by Nisse>\n"
525 #define FUNC_NAME s_scm_make_vtable_vtable
534 SCM_VALIDATE_STRING (1, user_fields
);
535 SCM_VALIDATE_INUM (2, tail_array_size
);
536 SCM_VALIDATE_REST_ARGUMENT (init
);
538 fields
= scm_string_append (scm_listify (required_vtable_fields
,
541 layout
= scm_make_struct_layout (fields
);
542 basic_size
= SCM_SYMBOL_LENGTH (layout
) / 2;
543 tail_elts
= SCM_INUM (tail_array_size
);
544 SCM_NEWCELL2 (handle
);
546 data
= scm_alloc_struct (basic_size
+ tail_elts
,
547 scm_struct_n_extra_words
,
548 "make-vtable-vtable");
549 SCM_SET_CELL_WORD_1 (handle
, data
);
550 SCM_SET_STRUCT_GC_CHAIN (handle
, 0);
551 data
[scm_vtable_index_layout
] = SCM_UNPACK (layout
);
552 scm_struct_init (handle
, layout
, data
, tail_elts
, scm_cons (layout
, init
));
553 SCM_SET_CELL_WORD_0 (handle
, (scm_bits_t
) data
+ scm_tc3_cons_gloc
);
562 SCM_DEFINE (scm_struct_ref
, "struct-ref", 2, 0, 0,
563 (SCM handle
, SCM pos
),
564 "@deffnx primitive struct-set! struct n value\n"
565 "Access (or modify) the @var{n}th field of @var{struct}.\n\n"
566 "If the field is of type 'p', then it can be set to an arbitrary value.\n\n"
567 "If the field is of type 'u', then it can only be set to a non-negative\n"
568 "integer value small enough to fit in one machine word.")
569 #define FUNC_NAME s_scm_struct_ref
571 SCM answer
= SCM_UNDEFINED
;
580 SCM_VALIDATE_STRUCT (1,handle
);
581 SCM_VALIDATE_INUM (2,pos
);
583 layout
= SCM_STRUCT_LAYOUT (handle
);
584 data
= SCM_STRUCT_DATA (handle
);
587 fields_desc
= SCM_SYMBOL_CHARS (layout
);
588 n_fields
= data
[scm_struct_i_n_words
];
590 SCM_ASSERT_RANGE(1,pos
, p
< n_fields
);
592 if (p
* 2 < SCM_SYMBOL_LENGTH (layout
))
595 field_type
= fields_desc
[p
* 2];
596 ref
= fields_desc
[p
* 2 + 1];
597 if ((ref
!= 'r') && (ref
!= 'w'))
599 if ((ref
== 'R') || (ref
== 'W'))
602 SCM_MISC_ERROR ("ref denied for field ~A", SCM_LIST1 (pos
));
605 else if (fields_desc
[SCM_SYMBOL_LENGTH (layout
) - 1] != 'O')
606 field_type
= fields_desc
[SCM_SYMBOL_LENGTH (layout
) - 2];
608 SCM_MISC_ERROR ("ref denied for field ~A", SCM_LIST1 (pos
));
613 answer
= scm_ulong2num (data
[p
]);
618 answer
= scm_long2num (data
[p
]);
622 answer
= scm_make_real (*((double *)&(data
[p
])));
628 answer
= SCM_PACK (data
[p
]);
633 SCM_MISC_ERROR ("unrecognized field type: ~S",
634 SCM_LIST1 (SCM_MAKE_CHAR (field_type
)));
642 SCM_DEFINE (scm_struct_set_x
, "struct-set!", 3, 0, 0,
643 (SCM handle
, SCM pos
, SCM val
),
644 "Set the slot of the structure @var{handle} with index @var{pos}\n"
645 "to @var{val}. Signal an error if the slot can not be written\n"
647 #define FUNC_NAME s_scm_struct_set_x
656 SCM_VALIDATE_STRUCT (1,handle
);
657 SCM_VALIDATE_INUM (2,pos
);
659 layout
= SCM_STRUCT_LAYOUT (handle
);
660 data
= SCM_STRUCT_DATA (handle
);
663 fields_desc
= SCM_SYMBOL_CHARS (layout
);
664 n_fields
= data
[scm_struct_i_n_words
];
666 SCM_ASSERT_RANGE (1,pos
, p
< n_fields
);
668 if (p
* 2 < SCM_SYMBOL_LENGTH (layout
))
671 field_type
= fields_desc
[p
* 2];
672 set_x
= fields_desc
[p
* 2 + 1];
674 SCM_MISC_ERROR ("set! denied for field ~A", SCM_LIST1 (pos
));
676 else if (fields_desc
[SCM_SYMBOL_LENGTH (layout
) - 1] == 'W')
677 field_type
= fields_desc
[SCM_SYMBOL_LENGTH (layout
) - 2];
679 SCM_MISC_ERROR ("set! denied for field ~A", SCM_LIST1 (pos
));
684 data
[p
] = SCM_NUM2ULONG (3, val
);
689 data
[p
] = SCM_NUM2LONG (3,val
);
693 *((double *)&(data
[p
])) = scm_num2dbl (val
, (char *)SCM_ARG3
);
698 data
[p
] = SCM_UNPACK (val
);
702 SCM_MISC_ERROR ("self fields immutable", SCM_EOL
);
705 SCM_MISC_ERROR ("unrecognized field type: ~S",
706 SCM_LIST1 (SCM_MAKE_CHAR (field_type
)));
714 SCM_DEFINE (scm_struct_vtable
, "struct-vtable", 1, 0, 0,
716 "Return the vtable structure that describes the type of @var{struct}.")
717 #define FUNC_NAME s_scm_struct_vtable
719 SCM_VALIDATE_STRUCT (1,handle
);
720 return SCM_STRUCT_VTABLE (handle
);
725 SCM_DEFINE (scm_struct_vtable_tag
, "struct-vtable-tag", 1, 0, 0,
727 "Return the vtable tag of the structure @var{handle}.")
728 #define FUNC_NAME s_scm_struct_vtable_tag
730 SCM_VALIDATE_VTABLE (1,handle
);
731 return scm_long2num ((long) SCM_STRUCT_DATA (handle
) >> 3);
735 /* {Associating names and classes with vtables}
737 * The name of a vtable should probably be stored as a slot. This is
738 * a backward compatible solution until agreement has been achieved on
739 * how to associate names with vtables.
743 scm_struct_ihashq (SCM obj
, unsigned int n
)
745 /* The length of the hash table should be a relative prime it's not
746 necessary to shift down the address. */
747 return SCM_UNPACK (obj
) % n
;
751 scm_struct_create_handle (SCM obj
)
753 SCM handle
= scm_hash_fn_create_handle_x (scm_struct_table
,
759 if (SCM_FALSEP (SCM_CDR (handle
)))
760 SCM_SETCDR (handle
, scm_cons (SCM_BOOL_F
, SCM_BOOL_F
));
764 SCM_DEFINE (scm_struct_vtable_name
, "struct-vtable-name", 1, 0, 0,
766 "Return the name of the vtable @var{vtable}.")
767 #define FUNC_NAME s_scm_struct_vtable_name
769 SCM_VALIDATE_VTABLE (1,vtable
);
770 return SCM_STRUCT_TABLE_NAME (SCM_CDR (scm_struct_create_handle (vtable
)));
774 SCM_DEFINE (scm_set_struct_vtable_name_x
, "set-struct-vtable-name!", 2, 0, 0,
775 (SCM vtable
, SCM name
),
776 "Set the name of the vtable @var{vtable} to @var{name}.")
777 #define FUNC_NAME s_scm_set_struct_vtable_name_x
779 SCM_VALIDATE_VTABLE (1,vtable
);
780 SCM_VALIDATE_SYMBOL (2,name
);
781 SCM_SET_STRUCT_TABLE_NAME (SCM_CDR (scm_struct_create_handle (vtable
)),
783 return SCM_UNSPECIFIED
;
791 scm_print_struct (SCM exp
, SCM port
, scm_print_state
*pstate
)
793 if (SCM_NFALSEP (scm_procedure_p (SCM_STRUCT_PRINTER (exp
))))
794 scm_printer_apply (SCM_STRUCT_PRINTER (exp
), exp
, port
, pstate
);
797 SCM vtable
= SCM_STRUCT_VTABLE (exp
);
798 SCM name
= scm_struct_vtable_name (vtable
);
799 scm_puts ("#<", port
);
800 if (SCM_NFALSEP (name
))
801 scm_display (name
, port
);
803 scm_puts ("struct", port
);
804 scm_putc (' ', port
);
805 scm_intprint (SCM_UNPACK (vtable
), 16, port
);
806 scm_putc (':', port
);
807 scm_intprint (SCM_UNPACK (exp
), 16, port
);
808 scm_putc ('>', port
);
813 scm_struct_prehistory ()
815 scm_c_hook_add (&scm_before_mark_c_hook
, scm_struct_gc_init
, 0, 0);
816 scm_c_hook_add (&scm_after_sweep_c_hook
, scm_free_structs
, 0, 0);
823 = scm_permanent_object (scm_make_weak_key_hash_table (SCM_MAKINUM (31)));
824 required_vtable_fields
= scm_makfrom0str ("pruosrpw");
825 scm_permanent_object (required_vtable_fields
);
826 scm_sysintern ("vtable-index-layout", SCM_MAKINUM (scm_vtable_index_layout
));
827 scm_sysintern ("vtable-index-vtable", SCM_MAKINUM (scm_vtable_index_vtable
));
828 scm_sysintern ("vtable-index-printer", SCM_MAKINUM (scm_vtable_index_printer
));
829 scm_sysintern ("vtable-offset-user", SCM_MAKINUM (scm_vtable_offset_user
));
830 #ifndef SCM_MAGIC_SNARFER
831 #include "libguile/struct.x"