From mboxrd@z Thu Jan 1 00:00:00 1970 Path: news.gmane.org!not-for-mail From: ludovic.courtes@laas.fr (Ludovic =?iso-8859-1?Q?Court=E8s?=) Newsgroups: gmane.lisp.guile.devel Subject: Re: SRFI-9 and `equal?' Date: Mon, 12 Jun 2006 14:25:18 +0200 Organization: LAAS-CNRS Message-ID: <874pyqa7dd.fsf@laas.fr> References: <874pyy8ibf.fsf@laas.fr> <87slmighkv.fsf@ossau.uklinux.net> <874pyxvsfh.fsf@laas.fr> <87wtbsfwo4.fsf@ossau.uklinux.net> <87mzcoqff0.fsf@laas.fr> <87u06v5hoz.fsf@zip.com.au> NNTP-Posting-Host: main.gmane.org Mime-Version: 1.0 Content-Type: text/plain; charset=iso-8859-1 Content-Transfer-Encoding: quoted-printable X-Trace: sea.gmane.org 1150115151 19477 80.91.229.2 (12 Jun 2006 12:25:51 GMT) X-Complaints-To: usenet@sea.gmane.org NNTP-Posting-Date: Mon, 12 Jun 2006 12:25:51 +0000 (UTC) Cc: Guile-Devel Original-X-From: guile-devel-bounces+guile-devel=m.gmane.org@gnu.org Mon Jun 12 14:25:50 2006 Return-path: Envelope-to: guile-devel@m.gmane.org Original-Received: from lists.gnu.org ([199.232.76.165]) by ciao.gmane.org with esmtp (Exim 4.43) id 1FplUC-0008CA-6I for guile-devel@m.gmane.org; Mon, 12 Jun 2006 14:25:41 +0200 Original-Received: from localhost ([127.0.0.1] helo=lists.gnu.org) by lists.gnu.org with esmtp (Exim 4.43) id 1FplU9-00062g-Hi for guile-devel@m.gmane.org; Mon, 12 Jun 2006 08:25:37 -0400 Original-Received: from mailman by lists.gnu.org with tmda-scanned (Exim 4.43) id 1FplU2-00061W-QL for guile-devel@gnu.org; Mon, 12 Jun 2006 08:25:30 -0400 Original-Received: from exim by lists.gnu.org with spam-scanned (Exim 4.43) id 1FplU1-00060b-Tv for guile-devel@gnu.org; Mon, 12 Jun 2006 08:25:30 -0400 Original-Received: from [199.232.76.173] (helo=monty-python.gnu.org) by lists.gnu.org with esmtp (Exim 4.43) id 1FplU1-00060N-Kh for guile-devel@gnu.org; Mon, 12 Jun 2006 08:25:29 -0400 Original-Received: from [140.93.0.15] (helo=laas.laas.fr) by monty-python.gnu.org with esmtps (TLS-1.0:DHE_RSA_AES_256_CBC_SHA:32) (Exim 4.52) id 1Fplcj-0003k7-UP for guile-devel@gnu.org; Mon, 12 Jun 2006 08:34:30 -0400 Original-Received: by laas.laas.fr (8.13.6/8.13.4) with SMTP id k5CCPL9i028048; Mon, 12 Jun 2006 14:25:27 +0200 (CEST) Original-To: Kevin Ryde X-URL: http://www.laas.fr/~lcourtes/ X-Revolutionary-Date: 24 Prairial an 214 de la =?iso-8859-1?Q?R=E9volution?= X-PGP-Key-ID: 0xEB1F5364 X-PGP-Key: http://www.laas.fr/~lcourtes/ludovic.asc X-PGP-Fingerprint: 821D 815D 902A 7EAB 5CEE D120 7FBA 3D4F EB1F 5364 X-OS: powerpc-unknown-linux-gnu Mail-Followup-To: Kevin Ryde , Guile-Devel In-Reply-To: <87u06v5hoz.fsf@zip.com.au> (Kevin Ryde's message of "Fri, 09 Jun 2006 09:52:12 +1000") User-Agent: Gnus/5.110004 (No Gnus v0.4) Emacs/21.4 (gnu/linux) X-Spam-Score: 0.656 () HTML_MESSAGE,MAILTO_TO_SPAM_ADDR X-Scanned-By: MIMEDefang at CNRS-LAAS X-MIME-Autoconverted: from 8bit to quoted-printable by laas.laas.fr id k5CCPL9i028048 X-BeenThere: guile-devel@gnu.org X-Mailman-Version: 2.1.5 Precedence: list List-Id: "Developers list for Guile, the GNU extensibility library" List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Original-Sender: guile-devel-bounces+guile-devel=m.gmane.org@gnu.org Errors-To: guile-devel-bounces+guile-devel=m.gmane.org@gnu.org Xref: news.gmane.org gmane.lisp.guile.devel:5974 Archived-At: Hi, (Moved to `guile-devel'.) Kevin Ryde 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=3D' from srfi-1 that lets you do a shallow list > compare. This is untrue: consider for instance `string=3D?' and `char=3D?'. 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 =20 ** A one-dimenisonal array can now be 'equal?' to a vector. +** Structures, records, and SRFI-9 records can now be compared with `equ= al?'. =20 * 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. =20 +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. =20 @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" =20 +#include "libguile/struct.h" +#include "libguile/goops.h" +#include "libguile/objects.h" + #include "libguile/validate.h" #include "libguile/eq.h" =0C @@ -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 ab= ove) + 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" =20 +#include "libguile/eq.h" + #ifdef HAVE_STRING_H #include #endif @@ -380,9 +382,7 @@ } else { - /* XXX - use less explicit code. */ - scm_t_bits word0 =3D SCM_CELL_WORD_0 (obj) - scm_tc3_struct; - scm_t_bits * vtable_data =3D (scm_t_bits *) word0; + scm_t_bits * vtable_data =3D SCM_STRUCT_VTABLE_DATA (obj); scm_t_bits * data =3D SCM_STRUCT_DATA (obj); scm_t_struct_free free_struct_data =3D ((scm_t_struct_free) vtable_data[scm_struct_i_free]); @@ -530,6 +530,49 @@ } #undef FUNC_NAME =20 + +/* 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 a= n + 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 =3D SCM_STRUCT_VTABLE (s1); + vtable2 =3D SCM_STRUCT_VTABLE (s2); + + if (!scm_is_eq (vtable1, vtable2)) + return SCM_BOOL_F; + + layout =3D SCM_STRUCT_LAYOUT (s1); + struct_size =3D scm_i_symbol_length (layout) / 2; + + for (field_num =3D 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 acce= ssed + consistently, notably wrt. field types and access rights. */ + s_field_num =3D scm_from_size_t (field_num); + field1 =3D scm_struct_ref (s1, s_field_num); + field2 =3D 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 + + =0C =20 --- 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_siz= e, 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 =20 ;; 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 "^.*")) =20 ;;; Display all parameters to the default output port, followed by a new= line. (define (display-line . objs) The `structs.test' file: ;;;; structs.test --- Test suite for Guile's structures. -*- Scheme -*- ;;;; Ludovic Court=E8s , 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)) =0C ;;; ;;; 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 "#" (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)) =0C ;;; ;;; 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=3D? (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