Changes from arch/CVS synchronization

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

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"
 
@@ -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);

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
+
+
 
 
 

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);

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.

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			\

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)