temporarily disable elisp exception tests

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

diff --git a/libguile/struct.c b/libguile/struct.c
index db79e79..8bfbcf4 100644 (file)
--- a/libguile/struct.c
+++ b/libguile/struct.c
@@ -1,4 +1,5 @@
-/* Copyright (C) 1996,1997,1998,1999,2000,2001, 2003, 2004, 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013 Free Software Foundation, Inc.
+/* Copyright (C) 1996,1997,1998,1999,2000,2001, 2003, 2004, 2006, 2007,
+ *   2008, 2009, 2010, 2011, 2012, 2013, 2015 Free Software Foundation, Inc.
  * 
  * This library is free software; you can redistribute it and/or
  * modify it under the terms of the GNU Lesser General Public License
@@ -152,8 +153,9 @@ SCM_DEFINE (scm_make_struct_layout, "make-struct-layout", 1, 0, 0,
 #undef FUNC_NAME
 
 \f
-/* Check whether VTABLE instances have a simple layout (i.e., either only "pr"
-   or only "pw" fields) and update its flags accordingly.  */
+/* Check whether VTABLE instances have a simple layout (i.e., either
+   only "pr" or only "pw" fields and no tail array) and update its flags
+   accordingly.  */
 static void
 set_vtable_layout_flags (SCM vtable)
 {
@@ -179,13 +181,11 @@ set_vtable_layout_flags (SCM vtable)
        switch (c_layout[field + 1])
          {
          case 'w':
-         case 'W':
            if (field == 0)
              flags |= SCM_VTABLE_FLAG_SIMPLE_RW;
            break;
 
          case 'r':
-         case 'R':
            flags &= ~SCM_VTABLE_FLAG_SIMPLE_RW;
            break;
 
@@ -517,6 +517,42 @@ scm_c_make_struct (SCM vtable, size_t n_tail, size_t n_init, scm_t_bits init, ..
   return scm_c_make_structv (vtable, n_tail, n_init, v);
 }
 
+SCM_DEFINE (scm_allocate_struct, "allocate-struct", 2, 0, 0,
+            (SCM vtable, SCM nfields),
+           "Allocate a new structure with space for @var{nfields} fields.\n\n"
+           "@var{vtable} must be a vtable structure (@pxref{Vtables}).\n\n"
+           "@var{nfields} must be a non-negative integer.  Strictly speaking\n"
+           "@var{nfields} is redundant, as the vtable carries the size\n"
+            "for its instances.  However passing it is useful as a sanity\n"
+            "check, given that one module can inline a constructor in\n"
+            "another.\n\n"
+           "Fields will be initialized with their default values.")
+#define FUNC_NAME s_scm_allocate_struct
+{
+  SCM ret;
+  size_t c_nfields;
+
+  SCM_VALIDATE_VTABLE (1, vtable);
+  c_nfields = scm_to_size_t (nfields);
+
+  SCM_ASSERT (SCM_STRUCT_DATA_REF (vtable, scm_vtable_index_size) == c_nfields,
+              nfields, 2, FUNC_NAME);
+
+  ret = scm_i_alloc_struct (SCM_STRUCT_DATA (vtable), c_nfields);
+
+  if (SCM_LIKELY (SCM_VTABLE_FLAG_IS_SET (vtable, SCM_VTABLE_FLAG_SIMPLE)))
+    {
+      size_t n;
+      for (n = 0; n < c_nfields; n++)
+        SCM_STRUCT_DATA_SET (ret, n, SCM_UNPACK (SCM_BOOL_F));
+    }
+  else
+    scm_struct_init (ret, SCM_VTABLE_LAYOUT (vtable), 0, 0, NULL);
+
+  return ret;
+}
+#undef FUNC_NAME
+
 SCM_DEFINE (scm_make_struct, "make-struct", 2, 0, 1, 
             (SCM vtable, SCM tail_array_size, SCM init),
            "Create a new structure.\n\n"
@@ -561,20 +597,18 @@ SCM_DEFINE (scm_make_struct, "make-struct", 2, 0, 1,
 #undef FUNC_NAME
 
 SCM
-scm_i_make_vtable_vtable (SCM user_fields)
+scm_i_make_vtable_vtable (SCM fields)
 #define FUNC_NAME "make-vtable-vtable"
 {
-  SCM fields, layout, obj;
+  SCM layout, obj;
   size_t basic_size;
   scm_t_bits v;
 
-  SCM_VALIDATE_STRING (1, user_fields);
+  SCM_VALIDATE_STRING (1, 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));
+    SCM_MISC_ERROR ("invalid user fields", scm_list_1 (fields));
 
   basic_size = scm_i_symbol_length (layout) / 2;
 
@@ -961,7 +995,8 @@ 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_i_make_vtable_vtable (scm_nullstr);
+  scm_standard_vtable_vtable =
+    scm_i_make_vtable_vtable (required_vtable_fields);
   name = scm_from_utf8_symbol ("<standard-vtable>");
   scm_set_struct_vtable_name_x (scm_standard_vtable_vtable, name);
   scm_define (name, scm_standard_vtable_vtable);