* Re: SRFI-9 and `equal?'
[not found] ` <87u06v5hoz.fsf@zip.com.au>
@ 2006-06-12 12:25 ` Ludovic Courtès
2006-06-12 22:44 ` Neil Jerram
2006-06-13 0:23 ` Kevin Ryde
0 siblings, 2 replies; 6+ messages in thread
From: Ludovic Courtès @ 2006-06-12 12:25 UTC (permalink / raw)
Cc: Guile-Devel
Hi,
(Moved to `guile-devel'.)
Kevin Ryde <user42@zip.com.au> 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"
\f
@@ -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
+
+
\f
--- 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 <ludovic.courtes@laas.fr>, 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))
\f
;;;
;;; 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))
\f
;;;
;;; 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"))))))
_______________________________________________
Guile-devel mailing list
Guile-devel@gnu.org
http://lists.gnu.org/mailman/listinfo/guile-devel
^ permalink raw reply [flat|nested] 6+ messages in thread