Changes from arch/CVS synchronization

diff --git a/libguile/ChangeLog b/libguile/ChangeLog
index a317e60..536e3cf 100644 (file)
--- a/libguile/ChangeLog
+++ b/libguile/ChangeLog
@@ -1,3 +1,14 @@
+2006-06-13  Ludovic Courtès <ludovic.courtes@laas.fr>
+
+       * eq.c: Include "struct.h", "goops.h" and "objects.h".
+       (scm_equal_p): Invoke `scm_i_struct_equalp ()' on structures that
+       are not GOOPS instances.
+       * struct.c: Include "eq.h".
+       (scm_free_structs): Use `SCM_STRUCT_VTABLE_DATA ()' instead of
+       hand-written code.
+       (scm_i_struct_equalp): New.
+       * struct.h (scm_i_struct_equalp): New declaration.
+
 2006-05-30  Marius Vollmer  <mvo@zagadka.de>
 
        * eq.c (scm_equal_p): Use scm_array_equal_p explicitely when one

diff --git a/libguile/eq.c b/libguile/eq.c
index 71d1acf..7c7e76d 100644 (file)
--- a/libguile/eq.c
+++ b/libguile/eq.c
@@ -30,6 +30,10 @@
 #include "libguile/unif.h"
 #include "libguile/vectors.h"
 
+#include "libguile/struct.h"
+#include "libguile/goops.h"
+#include "libguile/objects.h"
+
 #include "libguile/validate.h"
 #include "libguile/eq.h"
 \f
@@ -284,6 +288,13 @@ SCM_PRIMITIVE_GENERIC_1 (scm_equal_p, "equal?", scm_tc7_rpsubr,
     case scm_tc7_wvect:
       return scm_i_vector_equal_p (x, y);
     }
+
+  /* Check equality between structs of equal type (see cell-type test above)
+     that are not GOOPS instances.  GOOPS instances are treated via the
+     generic function.  */
+  if ((SCM_STRUCTP (x)) && (!SCM_INSTANCEP (x)))
+    return scm_i_struct_equalp (x, y);
+
  generic_equal:
   if (SCM_UNPACK (g_scm_equal_p))
     return scm_call_generic_2 (g_scm_equal_p, x, y);

diff --git a/libguile/struct.c b/libguile/struct.c
index 033e1d0..de8667d 100644 (file)
--- a/libguile/struct.c
+++ b/libguile/struct.c
@@ -33,6 +33,8 @@
 #include "libguile/validate.h"
 #include "libguile/struct.h"
 
+#include "libguile/eq.h"
+
 #ifdef HAVE_STRING_H
 #include <string.h>
 #endif
@@ -380,9 +382,7 @@ scm_free_structs (void *dummy1 SCM_UNUSED,
            }
          else
            {
-             /* XXX - use less explicit code. */
-             scm_t_bits word0 = SCM_CELL_WORD_0 (obj) - scm_tc3_struct;
-             scm_t_bits * vtable_data = (scm_t_bits *) word0;
+             scm_t_bits * vtable_data = SCM_STRUCT_VTABLE_DATA (obj);
              scm_t_bits * data = SCM_STRUCT_DATA (obj);
              scm_t_struct_free free_struct_data
                = ((scm_t_struct_free) vtable_data[scm_struct_i_free]);
@@ -530,6 +530,49 @@ SCM_DEFINE (scm_make_vtable_vtable, "make-vtable-vtable", 2, 0, 1,
 }
 #undef FUNC_NAME
 
+
+/* Return true if S1 and S2 are equal structures, i.e., if their vtable and
+   contents are the same.  Field protections are honored.  Thus, it is an
+   error to test the equality of structures that contain opaque fields.  */
+SCM
+scm_i_struct_equalp (SCM s1, SCM s2)
+#define FUNC_NAME "scm_i_struct_equalp"
+{
+  SCM vtable1, vtable2, layout;
+  size_t struct_size, field_num;
+
+  SCM_VALIDATE_STRUCT (1, s1);
+  SCM_VALIDATE_STRUCT (2, s2);
+
+  vtable1 = SCM_STRUCT_VTABLE (s1);
+  vtable2 = SCM_STRUCT_VTABLE (s2);
+
+  if (!scm_is_eq (vtable1, vtable2))
+    return SCM_BOOL_F;
+
+  layout = SCM_STRUCT_LAYOUT (s1);
+  struct_size = scm_i_symbol_length (layout) / 2;
+
+  for (field_num = 0; field_num < struct_size; field_num++)
+    {
+      SCM s_field_num;
+      SCM field1, field2;
+
+      /* We have to use `scm_struct_ref ()' here so that fields are accessed
+        consistently, notably wrt. field types and access rights.  */
+      s_field_num = scm_from_size_t (field_num);
+      field1 = scm_struct_ref (s1, s_field_num);
+      field2 = scm_struct_ref (s2, s_field_num);
+
+      if (scm_is_false (scm_equal_p (field1, field2)))
+       return SCM_BOOL_F;
+    }
+
+  return SCM_BOOL_T;
+}
+#undef FUNC_NAME
+
+
 \f
 
 

diff --git a/libguile/struct.h b/libguile/struct.h
index a7c7782..fcd8ec8 100644 (file)
--- a/libguile/struct.h
+++ b/libguile/struct.h
@@ -94,6 +94,7 @@ SCM_API SCM scm_struct_p (SCM x);
 SCM_API SCM scm_struct_vtable_p (SCM x);
 SCM_API SCM scm_make_struct (SCM vtable, SCM tail_array_size, SCM init);
 SCM_API SCM scm_make_vtable_vtable (SCM extra_fields, SCM tail_array_size, SCM init);
+SCM_API SCM scm_i_struct_equalp (SCM s1, SCM s2);
 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);

diff --git a/test-suite/ChangeLog b/test-suite/ChangeLog
index 53b0662..16cf878 100644 (file)
--- a/test-suite/ChangeLog
+++ b/test-suite/ChangeLog
@@ -1,3 +1,10 @@
+2006-06-13  Ludovic Courtès  <ludovic.courtes@laas.fr>
+
+       * Makefile.am (SCM_TESTS): Added `tests/structs.test'.
+       * tests/structs.test: New file.
+       * lib.scm (exception:struct-set!-denied): New.
+       (exception:miscellaneous-error): New.
+
 2006-05-30  Marius Vollmer  <mvo@zagadka.de>
 
        * tests/unif.test ("vector equal? one-dimensional array"): New.

diff --git a/test-suite/Makefile.am b/test-suite/Makefile.am
index 7f0e72b..c0efc78 100644 (file)
--- a/test-suite/Makefile.am
+++ b/test-suite/Makefile.am
@@ -79,6 +79,7 @@ SCM_TESTS = tests/alist.test                  \
            tests/srfi-4.test                   \
            tests/srfi-9.test                   \
            tests/strings.test                  \
+           tests/structs.test                  \
            tests/symbols.test                  \
            tests/syncase.test                  \
            tests/syntax.test                   \

diff --git a/test-suite/lib.scm b/test-suite/lib.scm
index f67018e..818a9b0 100644 (file)
--- a/test-suite/lib.scm
+++ b/test-suite/lib.scm
@@ -28,6 +28,8 @@
  exception:used-before-defined
  exception:wrong-num-args exception:wrong-type-arg
  exception:numerical-overflow
+ exception:struct-set!-denied
+ exception:miscellaneous-error
 
  ;; Reporting passes and failures.
  run-test
@@ -252,6 +254,10 @@
   (cons 'wrong-type-arg "^Wrong type"))
 (define exception:numerical-overflow
   (cons 'numerical-overflow "^Numerical overflow"))
+(define exception:struct-set!-denied
+  (cons 'misc-error "^set! denied for field"))
+(define exception:miscellaneous-error
+  (cons 'misc-error "^.*"))
 
 ;;; Display all parameters to the default output port, followed by a newline.
 (define (display-line . objs)