Fix EQUALP on structures with raw slots.

It always incremented the index by 1, even if slot takes up more than
one word. Increment by raw-slot-data-n-words.

diff --git a/NEWS b/NEWS
index 4e427c5..3cb5e54 100644 (file)
--- a/NEWS
+++ b/NEWS
@@ -2,6 +2,8 @@
 changes relative to sbcl-1.1.13:
   * enhancement: Top-level defmethod without defgeneric no longer causes
     undefined-function warnings in subsequent forms. (lp#503095)
+  * bug fix: EQUALP now compares correctly structures with raw slots larger
+    than a single word.
 
 changes in sbcl-1.1.13 relative to sbcl-1.1.12:
   * optimization: better distribution of SXHASH over small conses of related

diff --git a/src/code/target-defstruct.lisp b/src/code/target-defstruct.lisp
index 89ced39..f397731 100644 (file)
--- a/src/code/target-defstruct.lisp
+++ b/src/code/target-defstruct.lisp
@@ -394,7 +394,7 @@
   ;; all this with %RAW-INSTANCE-REF/WORD and bitwise comparisons, but
   ;; that'll fail in some cases. For example -0.0 and 0.0 are EQUALP
   ;; but have different bit patterns. -- JES, 2007-08-21
-  (loop with i = -1
+  (loop with i = 0
         for dsd in (dd-slots (layout-info layout))
         for raw-type = (dsd-raw-type dsd)
         for rsd = (when raw-type
@@ -404,10 +404,10 @@
         for accessor = (when rsd
                          (raw-slot-data-accessor-name rsd))
         always (or (not accessor)
-                   (progn
-                     (incf i)
-                     (equalp (funcall accessor x i)
-                             (funcall accessor y i))))))
+                   (prog1
+                       (equalp (funcall accessor x i)
+                               (funcall accessor y i))
+                     (incf i (raw-slot-data-n-words rsd))))))
 \f
 ;;; default PRINT-OBJECT method
 

diff --git a/tests/defstruct.impure.lisp b/tests/defstruct.impure.lisp
index 00aa376..9bfc78c 100644 (file)
--- a/tests/defstruct.impure.lisp
+++ b/tests/defstruct.impure.lisp
@@ -710,6 +710,12 @@
   c
   (a 0d0 :type double-float))
 
+(defstruct raw-slot-equalp-bug-2
+  (b (complex 1d0) :type (complex double-float))
+  (x (complex 1d0) :type (complex double-float))
+  c
+  (a 1s0 :type single-float))
+
 (with-test (:name :raw-slot-equalp)
   (assert (equalp (make-raw-slot-equalp-bug :a 1d0 :b 2s0)
                   (make-raw-slot-equalp-bug :a 1d0 :b 2s0)))
@@ -718,7 +724,15 @@
   (assert (not (equalp (make-raw-slot-equalp-bug :a 1d0 :b 2s0)
                        (make-raw-slot-equalp-bug :a 1d0 :b 3s0))))
   (assert (not (equalp (make-raw-slot-equalp-bug :a 1d0 :b 2s0)
-                       (make-raw-slot-equalp-bug :a 2d0 :b 2s0)))))
+                       (make-raw-slot-equalp-bug :a 2d0 :b 2s0))))
+  (assert (equalp (make-raw-slot-equalp-bug-2 :b (complex 1d0) :a 2s0)
+                  (make-raw-slot-equalp-bug-2 :b (complex 1d0) :a 2s0)))
+  (assert (equalp (make-raw-slot-equalp-bug-2 :b (complex 1d0) :a 0s0)
+                  (make-raw-slot-equalp-bug-2 :b (complex 1d0) :a -0s0)))
+  (assert (not (equalp (make-raw-slot-equalp-bug-2 :b (complex 1d0) :a 2s0)
+                       (make-raw-slot-equalp-bug-2 :b (complex 1d0) :a 3s0))))
+  (assert (not (equalp (make-raw-slot-equalp-bug-2 :b (complex 1d0) :a 2s0)
+                       (make-raw-slot-equalp-bug-2 :b (complex 2d0) :a 2s0)))))
 
 ;;; Check that all slot types (non-raw and raw) can be initialized with
 ;;; constant arguments.