From d15ad007c9065255bc0c7b305dc8c75707e9daa8 Mon Sep 17 00:00:00 2001 From: =?utf8?q?Ludovic=20Court=C3=A8s?= Date: Tue, 13 Jun 2006 07:48:42 +0000 Subject: [PATCH] Changes from arch/CVS synchronization --- libguile/ChangeLog | 11 ++++++++++ libguile/eq.c | 11 ++++++++++ libguile/struct.c | 49 +++++++++++++++++++++++++++++++++++++++--- libguile/struct.h | 1 + test-suite/ChangeLog | 7 ++++++ test-suite/Makefile.am | 1 + test-suite/lib.scm | 6 ++++++ 7 files changed, 83 insertions(+), 3 deletions(-) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index a317e6015..536e3cf92 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-05-30 Marius Vollmer * eq.c (scm_equal_p): Use scm_array_equal_p explicitely when one 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 53b0662b5..16cf87876 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) -- 2.20.1