Changes from arch/CVS synchronization

libguile/ChangeLog

@@ -1,3 +1,10 @@
+2007-01-19  Ludovic Courtès  <ludovic.courtes@laas.fr>
+
+	* struct.c (scm_i_struct_equalp): Skip comparison if both FIELD1
+	is equal to S1 and FIELD2 is equal to S2.  This avoids infinite
+	recursion when comparing `s' fields, as the REQUIRED_VTABLE_FIELDS
+	added by `make-vtable-vtable'.  Reported by Marco Maggi.
+	
 2007-01-18  Han-Wen Nienhuys  <hanwen@lilypond.org>
 
 	* throw.c (scm_ithrow): more refined error message: print symbols
@@ -128,10 +135,10 @@
 2006-12-12  Ludovic Courtès  <ludovic.courtes@laas.fr>
 
 	* libguile/unif.c (read_decimal_integer): Let RESP be SIGN * RES
-	instead of RES (reported by Gyula Szavai).  This allows the use of
+	instead of RES (reported by Szavai Gyula).  This allows the use of
 	negative lower bounds.
 	(scm_i_read_array): Make sure LEN is non-negative (reported by
-	Gyula Szavai).
+	Szavai Gyula).
 
 	(scm_array_in_bounds_p): Iterate over S instead of always
 	comparing indices with the bounds of S[0].  This fixes

libguile/struct.c

@@ -564,10 +564,15 @@ scm_i_struct_equalp (SCM s1, SCM s2)
       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;
+      /* Self-referencing fields (type `s') must be skipped to avoid infinite
+	 recursion.  */
+      if (!(scm_is_eq (field1, s1) && (scm_is_eq (field2, s2))))
+	if (scm_is_false (scm_equal_p (field1, field2)))
+	  return SCM_BOOL_F;
     }
 
+  /* FIXME: Tail elements should be tested for equality.  */
+
   return SCM_BOOL_T;
 }
 #undef FUNC_NAME

test-suite/ChangeLog

@@ -1,3 +1,11 @@
+2007-01-19  Ludovic Courtès  <ludovic.courtes@laas.fr>
+
+	* tests/eval.test (values): New test prefix.  Values are structs,
+	and `equal?' on structs with `s' fields used to yield infinite
+	recursion.
+	* tests/structs.test (equal?): New test prefix.  Added tests that
+	used to show the infinite recursion problem.
+
 2007-01-16  Kevin Ryde  <user42@zip.com.au>
 
 	* tests/regexp.test (regexp-exec): Further tests, in particular #\nul

test-suite/tests/eval.test

@@ -1,5 +1,5 @@
 ;;;; eval.test --- tests guile's evaluator     -*- scheme -*-
-;;;; Copyright (C) 2000, 2001, 2006 Free Software Foundation, Inc.
+;;;; Copyright (C) 2000, 2001, 2006, 2007 Free Software Foundation, Inc.
 ;;;;
 ;;;; This library is free software; you can redistribute it and/or
 ;;;; modify it under the terms of the GNU Lesser General Public
@@ -315,5 +315,20 @@
 	    '(a b c d e f g h i j k l m
 	      n o p q r s t u v w x y z))))
 
+;;;
+;;; values
+;;;
+
+(with-test-prefix "values"
+
+  (pass-if "single value"
+    (equal? 1 (values 1)))
+
+  (pass-if "call-with-values"
+    (equal? (call-with-values (lambda () (values 1 2 3 4)) list)
+            '(1 2 3 4)))
+
+  (pass-if "equal?"
+    (equal? (values 1 2 3 4) (values 1 2 3 4))))
 
 ;;; eval.test ends here

test-suite/tests/structs.test

@@ -1,7 +1,7 @@
 ;;;; 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.
+;;;; Copyright (C) 2006, 2007 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
@@ -18,7 +18,8 @@
 ;;;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
 ;;;; Boston, MA 02110-1301 USA
 
-(use-modules (test-suite lib))
+(define-module (test-suite test-structs)
+  :use-module (test-suite lib))
 
 
 
@@ -80,15 +81,27 @@
   (pass-if "struct-set!"
      (let ((ball (make-ball green "Bob")))
        (set-owner! ball "Bill")
-       (string=? (owner ball) "Bill")))
+       (string=? (owner ball) "Bill"))))
 
-  (pass-if "equal?"
+
+(with-test-prefix "equal?"
+
+  (pass-if "simple structs"
+     (let* ((vtable (make-vtable-vtable "pr" 0))
+            (s1     (make-struct vtable 0 "hello"))
+            (s2     (make-struct vtable 0 "hello")))
+       (equal? s1 s2)))
+
+  (pass-if "more complex structs"
      (let ((first (make-ball red (string-copy "Bob")))
-	   (second (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"))
+     (not (or (equal? (make-ball red "Bob") (make-ball green "Bob"))
 	      (equal? (make-ball red "Bob") (make-ball red "Bill"))))))
 
 
+;;; Local Variables:
+;;; coding: latin-1
+;;; End: