REPL Server: Don't establish a SIGINT handler.

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

diff --git a/libguile/struct.c b/libguile/struct.c
index 8426e92..3906a42 100644 (file)
--- a/libguile/struct.c
+++ b/libguile/struct.c
@@ -1,4 +1,4 @@
-/* Copyright (C) 1996,1997,1998,1999,2000,2001, 2003, 2004, 2006, 2007, 2008, 2009, 2010, 2011, 2012 Free Software Foundation, Inc.
+/* Copyright (C) 1996,1997,1998,1999,2000,2001, 2003, 2004, 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013 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
@@ -153,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)
 {
@@ -180,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;
 
@@ -922,6 +921,55 @@ scm_struct_ihashq (SCM obj, unsigned long n, void *closure)
   return SCM_UNPACK (obj) % n;
 }
 
+/* Return the hash of struct OBJ, modulo N.  Traverse OBJ's fields to
+   compute the result, unless DEPTH is zero.  */
+unsigned long
+scm_i_struct_hash (SCM obj, unsigned long n, size_t depth)
+#define FUNC_NAME "hash"
+{
+  SCM layout;
+  scm_t_bits *data;
+  size_t struct_size, field_num;
+  unsigned long hash;
+
+  SCM_VALIDATE_STRUCT (1, obj);
+
+  layout = SCM_STRUCT_LAYOUT (obj);
+  struct_size = scm_i_symbol_length (layout) / 2;
+  data = SCM_STRUCT_DATA (obj);
+
+  hash = SCM_UNPACK (SCM_STRUCT_VTABLE (obj)) % n;
+  if (depth > 0)
+    for (field_num = 0; field_num < struct_size; field_num++)
+      {
+       int protection;
+
+       protection = scm_i_symbol_ref (layout, field_num * 2 + 1);
+       if (protection != 'h' && protection != 'o')
+         {
+           int type;
+           type = scm_i_symbol_ref (layout, field_num * 2);
+           switch (type)
+             {
+             case 'p':
+               hash ^= scm_hasher (SCM_PACK (data[field_num]), n,
+                                   depth / 2);
+               break;
+             case 'u':
+               hash ^= data[field_num] % n;
+               break;
+             default:
+               /* Ignore 's' fields.  */;
+             }
+         }
+      }
+
+  /* FIXME: Tail elements should be taken into account.  */
+
+  return hash % n;
+}
+#undef FUNC_NAME
+
 SCM_DEFINE (scm_struct_vtable_name, "struct-vtable-name", 1, 0, 0, 
             (SCM vtable),
            "Return the name of the vtable @var{vtable}.")
@@ -1001,6 +1049,8 @@ scm_print_struct (SCM exp, SCM port, scm_print_state *pstate)
 void
 scm_init_struct ()
 {
+  SCM name;
+
   /* The first word of a struct is equal to `SCM_STRUCT_DATA (vtable) +
      scm_tc3_struct', and `SCM_STRUCT_DATA (vtable)' is 2 words after VTABLE by
      default.  */
@@ -1017,21 +1067,27 @@ scm_init_struct ()
   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_c_define ("<standard-vtable>", scm_standard_vtable_vtable);
+  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);
 
   scm_applicable_struct_vtable_vtable =
     scm_make_struct (scm_standard_vtable_vtable, SCM_INUM0,
                      scm_list_1 (scm_make_struct_layout (required_vtable_fields)));
+  name = scm_from_utf8_symbol ("<applicable-struct-vtable>");
   SCM_SET_VTABLE_FLAGS (scm_applicable_struct_vtable_vtable,
                         SCM_VTABLE_FLAG_APPLICABLE_VTABLE);
-  scm_c_define ("<applicable-struct-vtable>", scm_applicable_struct_vtable_vtable);
+  scm_set_struct_vtable_name_x (scm_applicable_struct_vtable_vtable, name);
+  scm_define (name, scm_applicable_struct_vtable_vtable);
 
   scm_applicable_struct_with_setter_vtable_vtable =
     scm_make_struct (scm_standard_vtable_vtable, SCM_INUM0,
                      scm_list_1 (scm_make_struct_layout (required_vtable_fields)));
+  name = scm_from_utf8_symbol ("<applicable-struct-with-setter-vtable>");
+  scm_set_struct_vtable_name_x (scm_applicable_struct_with_setter_vtable_vtable, name);
   SCM_SET_VTABLE_FLAGS (scm_applicable_struct_with_setter_vtable_vtable,
                         SCM_VTABLE_FLAG_APPLICABLE_VTABLE | SCM_VTABLE_FLAG_SETTER_VTABLE);
-  scm_c_define ("<applicable-struct-with-setter-vtable>", scm_applicable_struct_with_setter_vtable_vtable);
+  scm_define (name, scm_applicable_struct_with_setter_vtable_vtable);
 
   scm_c_define ("vtable-index-layout", scm_from_int (scm_vtable_index_layout));
   scm_c_define ("vtable-index-printer",