Merge remote-tracking branch 'origin/stable-2.0'

[bpt/guile.git] / libguile / struct.c

diff --git a/libguile/struct.c b/libguile/struct.c
index e5d95fc..12a8842 100644 (file)
--- 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"
@@ -562,6 +563,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"
@@ -656,7 +658,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),
@@ -980,22 +1013,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 */
@@ -1003,19 +1036,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);
     }
 }
 
@@ -1033,11 +1066,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,