Hi,
Neil Jerram <[EMAIL PROTECTED]> writes:
> [EMAIL PROTECTED] (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))))
+
_______________________________________________
Guile-user mailing list
Guile-user@gnu.org
http://lists.gnu.org/mailman/listinfo/guile-user
