diff --git a/ChangeLog b/ChangeLog index 73da24308..f78f76402 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,7 @@ +2006-06-13 Ludovic Courtès + + * NEWS: Mentioned the new behavior of `equal?' for structures. + 2006-06-06 Neil Jerram * acinclude.m4 (ACX_PTHREAD): Update to latest definition from diff --git a/NEWS b/NEWS index 219388831..c89301d67 100644 --- a/NEWS +++ b/NEWS @@ -21,6 +21,7 @@ Changes in 1.8.1 (since 1.8.0): * 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?'. * Changes to the C interface diff --git a/doc/ref/ChangeLog b/doc/ref/ChangeLog index e1ae7d1e3..7ed1eb778 100644 --- a/doc/ref/ChangeLog +++ b/doc/ref/ChangeLog @@ -1,3 +1,13 @@ +2006-06-16 Ludovic Courtès + + * api-utility.texi (Equality): Mentioned the behavior of `equal?' + for structures (as suggested by Kevin Ryde). + +2006-06-13 Ludovic Courtès + + * api-compound.texi (Structure Concepts): Mentioned the behavior + of `equal?' for structures. + 2006-05-28 Kevin Ryde * srfi-modules.texi (SRFI-1 Length Append etc): Add an append-reverse diff --git a/doc/ref/api-compound.texi b/doc/ref/api-compound.texi index 4e60a6468..3e1699aa0 100644 --- a/doc/ref/api-compound.texi +++ b/doc/ref/api-compound.texi @@ -2719,6 +2719,10 @@ memory, private to the structure, divided up into typed fields. A 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{} diff --git a/doc/ref/api-utility.texi b/doc/ref/api-utility.texi index 9f6766c71..4a902123e 100644 --- a/doc/ref/api-utility.texi +++ b/doc/ref/api-utility.texi @@ -137,7 +137,7 @@ inexact number (even if their value is the same). Return @code{#t} if @var{x} and @var{y} are the same type, and their contents or value are equal. -For a pair, string, vector or array, @code{equal?} compares the +For a pair, string, vector, array or structure, @code{equal?} compares the contents, and does so using using the same @code{equal?} recursively, so a deep structure can be traversed. diff --git a/libguile/ChangeLog b/libguile/ChangeLog index b8c86339e..00534f35d 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,14 @@ +2006-06-13 Ludovic Courtès + + * eq.c: Include "struct.h", "goops.h" and "objects.h". + (scm_equal_p): Invoke `scm_i_struct_equalp ()' on structures that + are not GOOPS instances. + * struct.c: Include "eq.h". + (scm_free_structs): Use `SCM_STRUCT_VTABLE_DATA ()' instead of + hand-written code. + (scm_i_struct_equalp): New. + * struct.h (scm_i_struct_equalp): New declaration. + 2006-06-06 Kevin Ryde * Makefile.am (BUILT_SOURCES): Remove guile.texi, only used by diff --git a/libguile/eq.c b/libguile/eq.c index 71d1acfa1..7c7e76d0e 100644 --- a/libguile/eq.c +++ b/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 @@ SCM_PRIMITIVE_GENERIC_1 (scm_equal_p, "equal?", scm_tc7_rpsubr, 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); diff --git a/libguile/struct.c b/libguile/struct.c index 033e1d037..de8667d45 100644 --- a/libguile/struct.c +++ b/libguile/struct.c @@ -33,6 +33,8 @@ #include "libguile/validate.h" #include "libguile/struct.h" +#include "libguile/eq.h" + #ifdef HAVE_STRING_H #include #endif @@ -380,9 +382,7 @@ scm_free_structs (void *dummy1 SCM_UNUSED, } 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 @@ SCM_DEFINE (scm_make_vtable_vtable, "make-vtable-vtable", 2, 0, 1, } #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 + + diff --git a/libguile/struct.h b/libguile/struct.h index a7c778275..fcd8ec858 100644 --- a/libguile/struct.h +++ b/libguile/struct.h @@ -94,6 +94,7 @@ SCM_API SCM scm_struct_p (SCM x); 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); diff --git a/test-suite/ChangeLog b/test-suite/ChangeLog index d6987bbe4..ed36d30c7 100644 --- a/test-suite/ChangeLog +++ b/test-suite/ChangeLog @@ -1,3 +1,10 @@ +2006-06-13 Ludovic Courtès + + * Makefile.am (SCM_TESTS): Added `tests/structs.test'. + * tests/structs.test: New file. + * lib.scm (exception:struct-set!-denied): New. + (exception:miscellaneous-error): New. + 2006-05-30 Marius Vollmer * tests/unif.test ("vector equal? one-dimensional array"): New. diff --git a/test-suite/Makefile.am b/test-suite/Makefile.am index 7f0e72bc5..c0efc78a9 100644 --- a/test-suite/Makefile.am +++ b/test-suite/Makefile.am @@ -79,6 +79,7 @@ SCM_TESTS = tests/alist.test \ tests/srfi-4.test \ tests/srfi-9.test \ tests/strings.test \ + tests/structs.test \ tests/symbols.test \ tests/syncase.test \ tests/syntax.test \ diff --git a/test-suite/lib.scm b/test-suite/lib.scm index f67018ee7..818a9b06d 100644 --- a/test-suite/lib.scm +++ b/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)