Re: SRFI-9 and `equal?'

[Ludovic Courtès]

Hi,

(Moved to `guile-devel'.)

Kevin Ryde <address@hidden> writes:

> You should hide it please.  I think different equality test funcs are
> generally exposed only when they do something different from plain
> `equal?'.  Like `list=' from srfi-1 that lets you do a shallow list
> compare.

This is untrue: consider for instance `string=?' and `char=?'.

Anyway, I reworked the patch so as to not expose `struct-equal?', plus I
added a struct-specific test case (see below).  Regarding the
documentation, I was considering something like this:


--- orig/NEWS
+++ mod/NEWS
@@ -17,6 +17,7 @@
 * Changes to Scheme functions and syntax
 
 ** A one-dimenisonal array can now be 'equal?' to a vector.
+** Structures, records, and SRFI-9 records can now be compared with `equal?'.
 
 * Bug fixes.
 ** array-set! with bit vector.


--- orig/doc/ref/api-compound.texi
+++ mod/doc/ref/api-compound.texi
@@ -2705,6 +2705,10 @@
 vtable is another structure used to hold type-specific data.  Multiple
 structures can share a common vtable.
 
+When applied to structures, the @code{equal?} predicate
+(@pxref{Equality}) returns @code{#t} if the two structures share a
+common vtable @emph{and} all their fields satisfy @code{equal?}.
+
 Three concepts are key to understanding structures.
 
 @itemize @bullet{}


Let me know if I can go ahead with this.

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"
 
@@ -284,6 +288,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_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);


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

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


--- orig/test-suite/Makefile.am
+++ mod/test-suite/Makefile.am
@@ -79,6 +79,7 @@
            tests/srfi-4.test                   \
            tests/srfi-9.test                   \
            tests/strings.test                  \
+           tests/structs.test                  \
            tests/symbols.test                  \
            tests/syncase.test                  \
            tests/syntax.test                   \

--- orig/test-suite/lib.scm
+++ mod/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)



The `structs.test' file:

;;;; structs.test --- Test suite for Guile's structures.   -*- Scheme -*-
;;;; Ludovic Courtès <address@hidden>, 2006-06-12.
;;;;
;;;; Copyright (C) 2006 Free Software Foundation, Inc.
;;;;
;;;; This program is free software; you can redistribute it and/or modify
;;;; it under the terms of the GNU General Public License as published by
;;;; the Free Software Foundation; either version 2, or (at your option)
;;;; any later version.
;;;;
;;;; This program is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;;; GNU General Public License for more details.
;;;;
;;;; You should have received a copy of the GNU General Public License
;;;; along with this software; see the file COPYING.  If not, write to
;;;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
;;;; Boston, MA 02110-1301 USA

(use-modules (test-suite lib))



;;;
;;; Struct example taken from the reference manual (by Tom Lord).
;;;

(define ball-root (make-vtable-vtable "pr" 0))

(define (make-ball-type ball-color)
  (make-struct ball-root 0
               (make-struct-layout "pw")
               (lambda (ball port)
                 (format port "#<a ~A ball owned by ~A>"
                         (color ball)
                         (owner ball)))
               ball-color))

(define (color ball) (struct-ref (struct-vtable ball) vtable-offset-user))
(define (owner ball) (struct-ref ball 0))
(define (set-owner! ball owner) (struct-set! ball 0 owner))

(define red (make-ball-type 'red))
(define green (make-ball-type 'green))

(define (make-ball type owner) (make-struct type 0 owner))



;;;
;;; Test suite.
;;;

(with-test-prefix "low-level struct procedures"

  (pass-if "constructors"
     (and (struct-vtable? ball-root)
          (struct-vtable? red)
          (struct-vtable? green)))

  (pass-if "vtables"
     (and (eq? (struct-vtable red) ball-root)
          (eq? (struct-vtable green) ball-root)
          (eq? (struct-vtable (make-ball red "Bob")) red)

          ;; end of the vtable tower
          (eq? (struct-vtable ball-root) ball-root)))

  (pass-if-exception "write-access denied"
     exception:struct-set!-denied

     ;; The first field of instances of BALL-ROOT is read-only.
     (struct-set! red vtable-offset-user "blue"))

  (pass-if "write-access granted"
     (set-owner! (make-ball red "Bob") "Fred")
     #t)

  (pass-if "struct-set!"
     (let ((ball (make-ball green "Bob")))
       (set-owner! ball "Bill")
       (string=? (owner ball) "Bill")))

  (pass-if "equal?"
     (let ((first (make-ball red (string-copy "Bob")))
           (second (make-ball red (string-copy "Bob"))))
       (equal? first second)))

  (pass-if "not-equal?"
     (not (or (equal? (make-ball red "Bob") (make-ball green "Bill"))
              (equal? (make-ball red "Bob") (make-ball red "Bill"))))))