summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--libguile/goops.c2
-rw-r--r--libguile/struct.c37
-rw-r--r--libguile/struct.h5
3 files changed, 40 insertions, 4 deletions
diff --git a/libguile/goops.c b/libguile/goops.c
index d82a42f27..957a4e886 100644
--- a/libguile/goops.c
+++ b/libguile/goops.c
@@ -963,7 +963,7 @@ create_basic_classes (void)
/**** <class> ****/
SCM cs = scm_from_locale_string (SCM_CLASS_CLASS_LAYOUT);
SCM name = scm_from_latin1_symbol ("<class>");
- scm_class_class = scm_make_vtable_vtable (cs, SCM_INUM0, SCM_EOL);
+ scm_class_class = scm_i_make_vtable_vtable (cs);
SCM_SET_CLASS_FLAGS (scm_class_class, (SCM_CLASSF_GOOPS_OR_VALID
| SCM_CLASSF_METACLASS));
diff --git a/libguile/struct.c b/libguile/struct.c
index e66d6bc89..d022cce78 100644
--- a/libguile/struct.c
+++ b/libguile/struct.c
@@ -24,6 +24,8 @@
#include <alloca.h>
#include <assert.h>
+#define SCM_BUILDING_DEPRECATED_CODE
+
#include "libguile/_scm.h"
#include "libguile/async.h"
#include "libguile/chars.h"
@@ -569,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"
@@ -663,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),
@@ -1038,8 +1072,7 @@ scm_init_struct ()
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 =
diff --git a/libguile/struct.h b/libguile/struct.h
index c3c7d8f12..3e2bc5353 100644
--- a/libguile/struct.h
+++ b/libguile/struct.h
@@ -180,7 +180,10 @@ SCM_API SCM scm_c_make_struct (SCM vtable, size_t n_tail, size_t n_inits,
SCM_API SCM scm_c_make_structv (SCM vtable, size_t n_tail, size_t n_inits,
scm_t_bits init[]);
SCM_API SCM scm_make_vtable (SCM fields, SCM printer);
-SCM_API SCM scm_make_vtable_vtable (SCM extra_fields, SCM tail_array_size, SCM init);
+SCM_INTERNAL SCM scm_i_make_vtable_vtable (SCM extra_fields);
+#if SCM_ENABLE_DEPRECATED == 1
+SCM_DEPRECATED SCM scm_make_vtable_vtable (SCM extra_fields, SCM tail_array_size, SCM init);
+#endif
SCM_API SCM scm_struct_ref (SCM handle, SCM pos);
SCM_API SCM scm_struct_set_x (SCM handle, SCM pos, SCM val);
SCM_API SCM scm_struct_vtable (SCM handle);