diff options
Diffstat (limited to 'libguile/struct.c')
-rw-r--r-- | libguile/struct.c | 62 |
1 files changed, 48 insertions, 14 deletions
diff --git a/libguile/struct.c b/libguile/struct.c index 4a2a9d750..d022cce78 100644 --- a/libguile/struct.c +++ b/libguile/struct.c @@ -24,12 +24,13 @@ #include <alloca.h> #include <assert.h> +#define SCM_BUILDING_DEPRECATED_CODE + #include "libguile/_scm.h" #include "libguile/async.h" #include "libguile/chars.h" #include "libguile/eval.h" #include "libguile/alist.h" -#include "libguile/weaks.h" #include "libguile/hashtab.h" #include "libguile/ports.h" #include "libguile/strings.h" @@ -447,7 +448,7 @@ scm_i_alloc_struct (scm_t_bits *vtable_data, int n_words) /* Register a finalizer for the newly created instance. */ GC_finalization_proc prev_finalizer; GC_PTR prev_finalizer_data; - GC_REGISTER_FINALIZER_NO_ORDER (SCM2PTR (ret), + GC_REGISTER_FINALIZER_NO_ORDER (SCM_HEAP_OBJECT_BASE (ret), struct_finalizer_trampoline, NULL, &prev_finalizer, @@ -570,6 +571,7 @@ SCM_DEFINE (scm_make_struct, "make-struct", 2, 0, 1, +#if SCM_ENABLE_DEPRECATED == 1 SCM_DEFINE (scm_make_vtable_vtable, "make-vtable-vtable", 2, 0, 1, (SCM user_fields, SCM tail_array_size, SCM init), "Return a new, self-describing vtable structure.\n\n" @@ -664,7 +666,38 @@ SCM_DEFINE (scm_make_vtable_vtable, "make-vtable-vtable", 2, 0, 1, return obj; } #undef FUNC_NAME +#endif + +SCM +scm_i_make_vtable_vtable (SCM user_fields) +#define FUNC_NAME s_scm_make_vtable_vtable +{ + SCM fields, layout, obj; + size_t basic_size; + scm_t_bits v; + + SCM_VALIDATE_STRING (1, user_fields); + fields = scm_string_append (scm_list_2 (required_vtable_fields, + user_fields)); + layout = scm_make_struct_layout (fields); + if (!scm_is_valid_vtable_layout (layout)) + SCM_MISC_ERROR ("invalid user fields", scm_list_1 (user_fields)); + + basic_size = scm_i_symbol_length (layout) / 2; + + obj = scm_i_alloc_struct (NULL, basic_size); + /* Make it so that the vtable of OBJ is itself. */ + SCM_SET_CELL_WORD_0 (obj, (scm_t_bits) SCM_STRUCT_DATA (obj) | scm_tc3_struct); + + v = SCM_UNPACK (layout); + scm_struct_init (obj, layout, 0, 1, &v); + SCM_SET_VTABLE_FLAGS (obj, + SCM_VTABLE_FLAG_VTABLE | SCM_VTABLE_FLAG_VALIDATED); + + return obj; +} +#undef FUNC_NAME SCM_DEFINE (scm_make_vtable, "make-vtable", 1, 1, 0, (SCM fields, SCM printer), @@ -982,22 +1015,22 @@ scm_print_struct (SCM exp, SCM port, scm_print_state *pstate) { SCM vtable = SCM_STRUCT_VTABLE (exp); SCM name = scm_struct_vtable_name (vtable); - scm_puts ("#<", port); + scm_puts_unlocked ("#<", port); if (scm_is_true (name)) { scm_display (name, port); - scm_putc (' ', port); + scm_putc_unlocked (' ', port); } else { if (SCM_VTABLE_FLAG_IS_SET (vtable, SCM_VTABLE_FLAG_VTABLE)) - scm_puts ("vtable:", port); + scm_puts_unlocked ("vtable:", port); else - scm_puts ("struct:", port); + scm_puts_unlocked ("struct:", port); scm_uintprint (SCM_UNPACK (vtable), 16, port); - scm_putc (' ', port); + scm_putc_unlocked (' ', port); scm_write (SCM_VTABLE_LAYOUT (vtable), port); - scm_putc (' ', port); + scm_putc_unlocked (' ', port); } scm_uintprint (SCM_UNPACK (exp), 16, port); /* hackety hack */ @@ -1005,19 +1038,19 @@ scm_print_struct (SCM exp, SCM port, scm_print_state *pstate) { if (scm_is_true (SCM_STRUCT_PROCEDURE (exp))) { - scm_puts (" proc: ", port); + scm_puts_unlocked (" proc: ", port); if (scm_is_true (scm_procedure_p (SCM_STRUCT_PROCEDURE (exp)))) scm_write (SCM_STRUCT_PROCEDURE (exp), port); else - scm_puts ("(not a procedure?)", port); + scm_puts_unlocked ("(not a procedure?)", port); } if (SCM_STRUCT_SETTER_P (exp)) { - scm_puts (" setter: ", port); + scm_puts_unlocked (" setter: ", port); scm_write (SCM_STRUCT_SETTER (exp), port); } } - scm_putc ('>', port); + scm_putc_unlocked ('>', port); } } @@ -1035,11 +1068,12 @@ scm_init_struct () GC_REGISTER_DISPLACEMENT (2 * sizeof (scm_t_bits)); required_vtable_fields = scm_from_locale_string (SCM_VTABLE_BASE_LAYOUT); + scm_c_define ("standard-vtable-fields", required_vtable_fields); required_applicable_fields = scm_from_locale_string (SCM_APPLICABLE_BASE_LAYOUT); required_applicable_with_setter_fields = scm_from_locale_string (SCM_APPLICABLE_WITH_SETTER_BASE_LAYOUT); - scm_standard_vtable_vtable = - scm_make_vtable_vtable (scm_nullstr, SCM_INUM0, SCM_EOL); + scm_standard_vtable_vtable = scm_i_make_vtable_vtable (scm_nullstr); + scm_c_define ("<standard-vtable>", scm_standard_vtable_vtable); scm_applicable_struct_vtable_vtable = scm_make_struct (scm_standard_vtable_vtable, SCM_INUM0, |