Re: SRFI-9 and `equal?'

[Ludovic Courtès]

Hi,

Neil Jerram <address@hidden> writes:

> address@hidden (Ludovic Courtès) writes:
>
>> To me, it looks like having `equal?' behave "as one may expect" (i.e.,
>> as in the Chicken case) would be very valuable and look more consistent
>> wrt. R5RS --- although, admittedly, relying on it would be Bad.
>>
>> What do you think?
>
> I agree.  Do you know yet what would be needed to "make it so"?

SRFI-9 is implemented using Guile's records, which in turn are
implemented (in `boot-9.scm') using structs.  It turns out that `equal?'
is currently not honored for structs, and this is the cause of this
SRFI-9 equality issue.

The patch below fixes this at the lowest level (i.e., structs) and adds
a test to `srfi-9.test' (admittedly, the best thing would be to have a
`structs.test'...).

If it looks acceptable to you, then perhaps we can add a bit of
documentation and commit it?

Thanks,
Ludovic.


--- orig/libguile/eq.c
+++ mod/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"
 
@@ -279,6 +283,13 @@
     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_struct_equalp (x, y);
+
  generic_equal:
   if (SCM_UNPACK (g_scm_equal_p))
     return scm_call_generic_2 (g_scm_equal_p, x, y);


--- orig/libguile/struct.c
+++ mod/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 @@
            }
          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 @@
 }
 #undef FUNC_NAME
 
+SCM_DEFINE (scm_struct_equalp, "struct-equal?", 2, 0, 0,
+           (SCM s1, SCM s2),
+           "Return true if @var{s1} and @var{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.")
+#define FUNC_NAME s_scm_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_equal_p (field1, field2))
+       return SCM_BOOL_F;
+    }
+
+  return SCM_BOOL_T;
+}
+#undef FUNC_NAME
+
+
 
 
 


--- orig/libguile/struct.h
+++ mod/libguile/struct.h
@@ -94,6 +94,7 @@
 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_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);


--- orig/test-suite/tests/srfi-9.test
+++ mod/test-suite/tests/srfi-9.test
@@ -39,4 +39,14 @@
 
   (pass-if "modifier"
      (set-y! f #t)
-     (eq? #t (get-y f))))
+     (eq? #t (get-y f)))
+
+  (pass-if "equal?"
+     ;; Although SRFI-9 does not require that two record instances be
+     ;; `equal?' in such cases, it is a highly desirable feature.
+     (let ((first (make-foo (string-copy "hello")))
+          (second (make-foo (string-copy "hello"))))
+       (set-y! first (string-copy "world"))
+       (set-y! second (string-copy "world"))
+       (equal? first second))))
+