1 /* Copyright (C) 1996, 97, 98, 99, 2000 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 read-only 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_ROSTRING (1,fields
);
90 len
= SCM_ROLENGTH (fields
);
91 field_desc
= SCM_ROCHARS (fields
);
92 SCM_ASSERT (!(len
& 1), fields
, "odd length field specification", FUNC_NAME
);
94 for (x
= 0; x
< len
; x
+= 2)
96 switch (field_desc
[x
])
107 SCM_ASSERT (0, SCM_MAKE_CHAR (field_desc
[x
]) , "unrecognized field type", FUNC_NAME
);
110 switch (field_desc
[x
+ 1])
113 SCM_ASSERT (field_desc
[x
] != 's', SCM_MAKE_CHAR (field_desc
[x
+ 1]),
114 "self fields not writable", FUNC_NAME
);
122 SCM_ASSERT (field_desc
[x
] != 's', SCM_MAKE_CHAR (field_desc
[x
+ 1]),
123 "self fields not allowed in tail array",
125 SCM_ASSERT (x
== len
- 2, SCM_MAKE_CHAR (field_desc
[x
+ 1]),
126 "tail array field must be last field in layout",
130 SCM_ASSERT (0, SCM_MAKE_CHAR (field_desc
[x
]) , "unrecognized ref specification", FUNC_NAME
);
133 if (field_desc
[x
] == 'd')
135 SCM_ASSERT (field_desc
[x
+ 2] == '-', SCM_MAKINUM (x
/ 2), "missing dash field", FUNC_NAME
);
141 new_sym
= SCM_CAR (scm_intern_obarray (field_desc
, len
, SCM_BOOL_F
));
143 return scm_return_first (new_sym
, fields
);
152 scm_struct_init (SCM handle
, SCM layout
, scm_bits_t
* mem
, int tail_elts
, SCM inits
)
154 unsigned char * fields_desc
= (unsigned char *) SCM_CHARS (layout
) - 2;
155 unsigned char prot
= 0;
156 int n_fields
= SCM_LENGTH (layout
) / 2;
164 prot
= fields_desc
[1];
165 if (SCM_LAYOUT_TAILP (prot
))
168 prot
= prot
== 'R' ? 'r' : prot
== 'W' ? 'w' : 'o';
170 n_fields
+= tail_elts
- 1;
176 switch (*fields_desc
)
180 if ((prot
!= 'r' && prot
!= 'w') || inits
== SCM_EOL
)
184 *mem
= scm_num2long (SCM_CAR (inits
), SCM_ARGn
, "scm_struct_init");
185 inits
= SCM_CDR (inits
);
191 if ((prot
!= 'r' && prot
!= 'w') || SCM_NULLP (inits
))
195 *mem
= scm_num2ulong (SCM_CAR (inits
),
198 inits
= SCM_CDR (inits
);
203 if ((prot
!= 'r' && prot
!= 'w') || SCM_NULLP (inits
))
204 *mem
= SCM_UNPACK (SCM_BOOL_F
);
207 *mem
= SCM_UNPACK (SCM_CAR (inits
));
208 inits
= SCM_CDR (inits
);
215 if ((prot
!= 'r' && prot
!= 'w') || inits
== SCM_EOL
)
216 *((double *)mem
) = 0.0;
219 *mem
= scm_num2dbl (SCM_CAR (inits
), "scm_struct_init");
220 inits
= SCM_CDR (inits
);
227 *mem
= SCM_UNPACK (handle
);
237 SCM_DEFINE (scm_struct_p
, "struct?", 1, 0, 0,
239 "Return #t iff @var{obj} is a structure object, else #f.")
240 #define FUNC_NAME s_scm_struct_p
242 return SCM_BOOL(SCM_STRUCTP (x
));
246 SCM_DEFINE (scm_struct_vtable_p
, "struct-vtable?", 1, 0, 0,
248 "Return #t iff obj is a vtable structure.")
249 #define FUNC_NAME s_scm_struct_vtable_p
254 if (!SCM_STRUCTP (x
))
257 layout
= SCM_STRUCT_LAYOUT (x
);
259 if (SCM_LENGTH (layout
) < SCM_LENGTH (required_vtable_fields
))
262 if (strncmp (SCM_CHARS (layout
), SCM_CHARS (required_vtable_fields
),
263 SCM_LENGTH (required_vtable_fields
)))
266 mem
= SCM_STRUCT_DATA (x
);
271 return SCM_BOOL (SCM_SYMBOLP (SCM_PACK (mem
[0])));
276 /* All struct data must be allocated at an address whose bottom three
277 bits are zero. This is because the tag for a struct lives in the
278 bottom three bits of the struct's car, and the upper bits point to
279 the data of its vtable, which is a struct itself. Thus, if the
280 address of that data doesn't end in three zeros, tagging it will
283 This function allocates a block of memory, and returns a pointer at
284 least scm_struct_n_extra_words words into the block. Furthermore,
285 it guarantees that that pointer's least three significant bits are
288 The argument n_words should be the number of words that should
289 appear after the returned address. (That is, it shouldn't include
290 scm_struct_n_extra_words.)
292 This function initializes the following fields of the struct:
294 scm_struct_i_ptr --- the actual start of the block of memory; the
295 address you should pass to 'free' to dispose of the block.
296 This field allows us to both guarantee that the returned
297 address is divisible by eight, and allow the GC to free the
300 scm_struct_i_n_words --- the number of words allocated to the
301 block, including the extra fields. This is used by the GC.
307 scm_alloc_struct (int n_words
, int n_extra
, char *who
)
309 int size
= sizeof (scm_bits_t
) * (n_words
+ n_extra
) + 7;
310 void * block
= scm_must_malloc (size
, who
);
312 /* Adjust the pointer to hide the extra words. */
313 scm_bits_t
* p
= (scm_bits_t
*) block
+ n_extra
;
315 /* Adjust it even further so it's aligned on an eight-byte boundary. */
316 p
= (scm_bits_t
*) (((scm_bits_t
) p
+ 7) & ~7);
318 /* Initialize a few fields as described above. */
319 p
[scm_struct_i_free
] = (scm_bits_t
) scm_struct_free_standard
;
320 p
[scm_struct_i_ptr
] = (scm_bits_t
) block
;
321 p
[scm_struct_i_n_words
] = n_words
;
322 p
[scm_struct_i_flags
] = 0;
328 scm_struct_free_0 (scm_bits_t
* vtable
, scm_bits_t
* data
)
334 scm_struct_free_light (scm_bits_t
* vtable
, scm_bits_t
* data
)
336 scm_must_free (data
);
337 return vtable
[scm_struct_i_size
] & ~SCM_STRUCTF_MASK
;
341 scm_struct_free_standard (scm_bits_t
* vtable
, scm_bits_t
* data
)
343 size_t n
= (data
[scm_struct_i_n_words
] + scm_struct_n_extra_words
)
344 * sizeof (scm_bits_t
) + 7;
345 scm_must_free ((void *) data
[scm_struct_i_ptr
]);
350 scm_struct_free_entity (scm_bits_t
* vtable
, scm_bits_t
* data
)
352 size_t n
= (data
[scm_struct_i_n_words
] + scm_struct_entity_n_extra_words
)
353 * sizeof (scm_bits_t
) + 7;
354 scm_must_free ((void *) data
[scm_struct_i_ptr
]);
359 scm_struct_gc_init (void *dummy1
, void *dummy2
, void *dummy3
)
361 scm_structs_to_free
= SCM_EOL
;
366 scm_free_structs (void *dummy1
, void *dummy2
, void *dummy3
)
368 SCM newchain
= scm_structs_to_free
;
371 /* Mark vtables in GC chain. GC mark set means delay freeing. */
372 SCM chain
= newchain
;
373 while (SCM_NNULLP (chain
))
375 SCM vtable
= SCM_STRUCT_VTABLE (chain
);
376 if (SCM_STRUCT_GC_CHAIN (vtable
) != 0 && vtable
!= chain
)
377 SCM_SETGCMARK (vtable
);
378 chain
= SCM_STRUCT_GC_CHAIN (chain
);
380 /* Free unmarked structs. */
383 while (SCM_NNULLP (chain
))
386 chain
= SCM_STRUCT_GC_CHAIN (chain
);
387 if (SCM_GCMARKP (obj
))
390 SCM_SET_STRUCT_GC_CHAIN (obj
, newchain
);
395 scm_bits_t word0
= SCM_CELL_WORD_0 (obj
) - scm_tc3_cons_gloc
;
396 /* access as struct */
397 scm_bits_t
* vtable_data
= (scm_bits_t
*) word0
;
398 scm_bits_t
* data
= (scm_bits_t
*) SCM_UNPACK (SCM_CDR (obj
));
399 scm_struct_free_t free_struct_data
400 = ((scm_struct_free_t
) vtable_data
[scm_struct_i_free
]);
401 SCM_SET_CELL_TYPE (obj
, scm_tc_free_cell
);
402 free_struct_data (vtable_data
, data
);
406 while (SCM_NNULLP (newchain
));
410 SCM_DEFINE (scm_make_struct
, "make-struct", 2, 0, 1,
411 (SCM vtable
, SCM tail_array_size
, SCM init
),
412 "Create a new structure.\n\n"
413 "@var{type} must be a vtable structure (@xref{Vtables}).\n\n"
414 "@var{tail-elts} must be a non-negative integer. If the layout\n"
415 "specification indicated by @var{type} includes a tail-array,\n"
416 "this is the number of elements allocated to that array.\n\n"
417 "The @var{init1}, @dots are optional arguments describing how\n"
418 "successive fields of the structure should be initialized. Only fields\n"
419 "with protection 'r' or 'w' can be initialized, except for fields of\n"
420 "type 's', which are automatically initialized to point to the new\n"
421 "structure itself; fields with protection 'o' can not be initialized by\n"
422 "Scheme programs.\n\n"
423 "If fewer optional arguments than initializable fields are supplied,\n"
424 "fields of type 'p' get default value #f while fields of type 'u' are\n"
425 "initialized to 0.\n\n"
426 "Structs are currently the basic representation for record-like data\n"
427 "structures in Guile. The plan is to eventually replace them with a\n"
428 "new representation which will at the same time be easier to use and\n"
430 "For more information, see the documentation for @code{make-vtable-vtable}.\n"
432 #define FUNC_NAME s_scm_make_struct
440 SCM_VALIDATE_VTABLE (1,vtable
);
441 SCM_VALIDATE_INUM (2,tail_array_size
);
442 SCM_VALIDATE_REST_ARGUMENT (init
);
444 layout
= SCM_PACK (SCM_STRUCT_DATA (vtable
) [scm_vtable_index_layout
]);
445 basic_size
= SCM_LENGTH (layout
) / 2;
446 tail_elts
= SCM_INUM (tail_array_size
);
447 SCM_NEWCELL2 (handle
);
449 if (SCM_STRUCT_DATA (vtable
)[scm_struct_i_flags
] & SCM_STRUCTF_ENTITY
)
451 data
= scm_alloc_struct (basic_size
+ tail_elts
,
452 scm_struct_entity_n_extra_words
,
454 data
[scm_struct_i_procedure
] = SCM_UNPACK (SCM_BOOL_F
);
455 data
[scm_struct_i_setter
] = SCM_UNPACK (SCM_BOOL_F
);
458 data
= scm_alloc_struct (basic_size
+ tail_elts
,
459 scm_struct_n_extra_words
,
461 SCM_SET_CELL_WORD_1 (handle
, data
);
462 SCM_SET_STRUCT_GC_CHAIN (handle
, 0);
463 scm_struct_init (handle
, layout
, data
, tail_elts
, init
);
464 SCM_SET_CELL_WORD_0 (handle
, (scm_bits_t
) SCM_STRUCT_DATA (vtable
) + scm_tc3_cons_gloc
);
472 SCM_DEFINE (scm_make_vtable_vtable
, "make-vtable-vtable", 2, 0, 1,
473 (SCM user_fields
, SCM tail_array_size
, SCM init
),
474 "Return a new, self-describing vtable structure.\n\n"
475 "@var{user-fields} is a string describing user defined fields of the\n"
476 "vtable beginning at index @code{vtable-offset-user}\n"
477 "(see @code{make-struct-layout}).\n\n"
478 "@var{tail-size} specifies the size of the tail-array (if any) of\n"
480 "@var{init1}, @dots are the optional initializers for the fields of\n"
482 "Vtables have one initializable system field---the struct printer.\n"
483 "This field comes before the user fields in the initializers passed\n"
484 "to @code{make-vtable-vtable} and @code{make-struct}, and thus works as\n"
485 "a third optional argument to @code{make-vtable-vtable} and a fourth to\n"
486 "@code{make-struct} when creating vtables:\n\n"
487 "If the value is a procedure, it will be called instead of the standard\n"
488 "printer whenever a struct described by this vtable is printed.\n"
489 "The procedure will be called with arguments STRUCT and PORT.\n\n"
490 "The structure of a struct is described by a vtable, so the vtable is\n"
491 "in essence the type of the struct. The vtable is itself a struct with\n"
492 "a vtable. This could go on forever if it weren't for the\n"
493 "vtable-vtables which are self-describing vtables, and thus terminate\n"
495 "There are several potential ways of using structs, but the standard\n"
496 "one is to use three kinds of structs, together building up a type\n"
497 "sub-system: one vtable-vtable working as the root and one or several\n"
498 "\"types\", each with a set of \"instances\". (The vtable-vtable should be\n"
499 "compared to the class <class> which is the class of itself.)\n\n"
501 "(define ball-root (make-vtable-vtable \"pr\" 0))\n\n"
502 "(define (make-ball-type ball-color)\n"
503 " (make-struct ball-root 0\n"
504 " (make-struct-layout \"pw\")\n"
505 " (lambda (ball port)\n"
506 " (format port \"#<a ~A ball owned by ~A>\"\n"
510 "(define (color ball) (struct-ref (struct-vtable ball) vtable-offset-user))\n"
511 "(define (owner ball) (struct-ref ball 0))\n\n"
512 "(define red (make-ball-type 'red))\n"
513 "(define green (make-ball-type 'green))\n\n"
514 "(define (make-ball type owner) (make-struct type 0 owner))\n\n"
515 "(define ball (make-ball green 'Nisse))\n"
516 "ball @result{} #<a green ball owned by Nisse>\n"
519 #define FUNC_NAME s_scm_make_vtable_vtable
528 SCM_VALIDATE_ROSTRING (1, user_fields
);
529 SCM_VALIDATE_INUM (2, tail_array_size
);
530 SCM_VALIDATE_REST_ARGUMENT (init
);
532 fields
= scm_string_append (scm_listify (required_vtable_fields
,
535 layout
= scm_make_struct_layout (fields
);
536 basic_size
= SCM_LENGTH (layout
) / 2;
537 tail_elts
= SCM_INUM (tail_array_size
);
538 SCM_NEWCELL2 (handle
);
540 data
= scm_alloc_struct (basic_size
+ tail_elts
,
541 scm_struct_n_extra_words
,
542 "make-vtable-vtable");
543 SCM_SET_CELL_WORD_1 (handle
, data
);
544 SCM_SET_STRUCT_GC_CHAIN (handle
, 0);
545 data
[scm_vtable_index_layout
] = SCM_UNPACK (layout
);
546 scm_struct_init (handle
, layout
, data
, tail_elts
, scm_cons (layout
, init
));
547 SCM_SET_CELL_WORD_0 (handle
, (scm_bits_t
) data
+ scm_tc3_cons_gloc
);
556 SCM_DEFINE (scm_struct_ref
, "struct-ref", 2, 0, 0,
557 (SCM handle
, SCM pos
),
558 "@deffnx primitive struct-set! struct n value\n"
559 "Access (or modify) the @var{n}th field of @var{struct}.\n\n"
560 "If the field is of type 'p', then it can be set to an arbitrary value.\n\n"
561 "If the field is of type 'u', then it can only be set to a non-negative\n"
562 "integer value small enough to fit in one machine word.")
563 #define FUNC_NAME s_scm_struct_ref
565 SCM answer
= SCM_UNDEFINED
;
570 unsigned char * fields_desc
;
571 unsigned char field_type
= 0;
574 SCM_VALIDATE_STRUCT (1,handle
);
575 SCM_VALIDATE_INUM (2,pos
);
577 layout
= SCM_STRUCT_LAYOUT (handle
);
578 data
= SCM_STRUCT_DATA (handle
);
581 fields_desc
= (unsigned char *) SCM_CHARS (layout
);
582 n_fields
= data
[scm_struct_i_n_words
];
584 SCM_ASSERT_RANGE(1,pos
, p
< n_fields
);
586 if (p
* 2 < SCM_LENGTH (layout
))
589 field_type
= fields_desc
[p
* 2];
590 ref
= fields_desc
[p
* 2 + 1];
591 if ((ref
!= 'r') && (ref
!= 'w'))
593 if ((ref
== 'R') || (ref
== 'W'))
596 SCM_ASSERT (0, pos
, "ref denied", FUNC_NAME
);
599 else if (fields_desc
[SCM_LENGTH (layout
) - 1] != 'O')
600 field_type
= fields_desc
[SCM_LENGTH (layout
) - 2];
603 SCM_ASSERT (0, pos
, "ref denied", FUNC_NAME
);
610 answer
= scm_ulong2num (data
[p
]);
615 answer
= scm_long2num (data
[p
]);
619 answer
= scm_make_real (*((double *)&(data
[p
])));
625 answer
= SCM_PACK (data
[p
]);
630 SCM_ASSERT (0, SCM_MAKE_CHAR (field_type
), "unrecognized field type", FUNC_NAME
);
639 SCM_DEFINE (scm_struct_set_x
, "struct-set!", 3, 0, 0,
640 (SCM handle
, SCM pos
, SCM val
),
642 #define FUNC_NAME s_scm_struct_set_x
648 unsigned char * fields_desc
;
649 unsigned char field_type
= 0;
651 SCM_VALIDATE_STRUCT (1,handle
);
652 SCM_VALIDATE_INUM (2,pos
);
654 layout
= SCM_STRUCT_LAYOUT (handle
);
655 data
= SCM_STRUCT_DATA (handle
);
658 fields_desc
= (unsigned char *)SCM_CHARS (layout
);
659 n_fields
= data
[scm_struct_i_n_words
];
661 SCM_ASSERT_RANGE (1,pos
, p
< n_fields
);
663 if (p
* 2 < SCM_LENGTH (layout
))
666 field_type
= fields_desc
[p
* 2];
667 set_x
= fields_desc
[p
* 2 + 1];
669 SCM_ASSERT (0, pos
, "set_x denied", FUNC_NAME
);
671 else if (fields_desc
[SCM_LENGTH (layout
) - 1] == 'W')
672 field_type
= fields_desc
[SCM_LENGTH (layout
) - 2];
675 SCM_ASSERT (0, pos
, "set_x denied", FUNC_NAME
);
682 data
[p
] = SCM_NUM2ULONG (3, val
);
687 data
[p
] = SCM_NUM2LONG (3,val
);
691 *((double *)&(data
[p
])) = scm_num2dbl (val
, (char *)SCM_ARG3
);
696 data
[p
] = SCM_UNPACK (val
);
700 SCM_ASSERT (0, SCM_MAKE_CHAR (field_type
), "self fields immutable", FUNC_NAME
);
704 SCM_ASSERT (0, SCM_MAKE_CHAR (field_type
), "unrecognized field type", FUNC_NAME
);
713 SCM_DEFINE (scm_struct_vtable
, "struct-vtable", 1, 0, 0,
715 "Return the vtable structure that describes the type of @var{struct}.")
716 #define FUNC_NAME s_scm_struct_vtable
718 SCM_VALIDATE_STRUCT (1,handle
);
719 return SCM_STRUCT_VTABLE (handle
);
724 SCM_DEFINE (scm_struct_vtable_tag
, "struct-vtable-tag", 1, 0, 0,
727 #define FUNC_NAME s_scm_struct_vtable_tag
729 SCM_VALIDATE_VTABLE (1,handle
);
730 return scm_long2num ((long) SCM_STRUCT_DATA (handle
) >> 3);
734 /* {Associating names and classes with vtables}
736 * The name of a vtable should probably be stored as a slot. This is
737 * a backward compatible solution until agreement has been achieved on
738 * how to associate names with vtables.
742 scm_struct_ihashq (SCM obj
, unsigned int n
)
744 /* The length of the hash table should be a relative prime it's not
745 necessary to shift down the address. */
746 return SCM_UNPACK (obj
) % n
;
750 scm_struct_create_handle (SCM obj
)
752 SCM handle
= scm_hash_fn_create_handle_x (scm_struct_table
,
758 if (SCM_FALSEP (SCM_CDR (handle
)))
759 SCM_SETCDR (handle
, scm_cons (SCM_BOOL_F
, SCM_BOOL_F
));
763 SCM_DEFINE (scm_struct_vtable_name
, "struct-vtable-name", 1, 0, 0,
766 #define FUNC_NAME s_scm_struct_vtable_name
768 SCM_VALIDATE_VTABLE (1,vtable
);
769 return SCM_STRUCT_TABLE_NAME (SCM_CDR (scm_struct_create_handle (vtable
)));
773 SCM_DEFINE (scm_set_struct_vtable_name_x
, "set-struct-vtable-name!", 2, 0, 0,
774 (SCM vtable
, SCM name
),
776 #define FUNC_NAME s_scm_set_struct_vtable_name_x
778 SCM_VALIDATE_VTABLE (1,vtable
);
779 SCM_VALIDATE_SYMBOL (2,name
);
780 SCM_SET_STRUCT_TABLE_NAME (SCM_CDR (scm_struct_create_handle (vtable
)),
782 return SCM_UNSPECIFIED
;
790 scm_print_struct (SCM exp
, SCM port
, scm_print_state
*pstate
)
792 if (SCM_NFALSEP (scm_procedure_p (SCM_STRUCT_PRINTER (exp
))))
793 scm_printer_apply (SCM_STRUCT_PRINTER (exp
), exp
, port
, pstate
);
796 SCM vtable
= SCM_STRUCT_VTABLE (exp
);
797 SCM name
= scm_struct_vtable_name (vtable
);
798 scm_puts ("#<", port
);
799 if (SCM_NFALSEP (name
))
800 scm_display (name
, port
);
802 scm_puts ("struct", port
);
803 scm_putc (' ', port
);
804 scm_intprint (SCM_UNPACK (vtable
), 16, port
);
805 scm_putc (':', port
);
806 scm_intprint (SCM_UNPACK (exp
), 16, port
);
807 scm_putc ('>', port
);
812 scm_struct_prehistory ()
814 scm_c_hook_add (&scm_before_mark_c_hook
, scm_struct_gc_init
, 0, 0);
815 scm_c_hook_add (&scm_after_sweep_c_hook
, scm_free_structs
, 0, 0);
822 = scm_permanent_object (scm_make_weak_key_hash_table (SCM_MAKINUM (31)));
823 required_vtable_fields
= SCM_CAR (scm_intern_obarray ("pruosrpw", sizeof ("pruosrpw") - 1, SCM_BOOL_F
));
824 scm_permanent_object (required_vtable_fields
);
825 scm_sysintern ("vtable-index-layout", SCM_MAKINUM (scm_vtable_index_layout
));
826 scm_sysintern ("vtable-index-vtable", SCM_MAKINUM (scm_vtable_index_vtable
));
827 scm_sysintern ("vtable-index-printer", SCM_MAKINUM (scm_vtable_index_printer
));
828 scm_sysintern ("vtable-offset-user", SCM_MAKINUM (scm_vtable_offset_user
));
829 #include "libguile/struct.x"