1.0.8.44: Fix EQUALP on structures with raw slots

         * Old version was basically accessing raw slots with %INSTANCE-REF,
           and doing EQUALP on the results. This was most obviously wrong
           for raw slots that were larger than a word (double-floats on 32-bit
           platforms). Less obviously this is also wrong for some float
           corner-cases, like negative zeroes.
         * Add RAW-INSTANCE-SLOTS-EQUALP which instead grovels the layout for
           the slot definitions and determines the proper accessor functions
           for each slot from that.
         * Reported by Vjacheslav Fyodorov.

diff --git a/NEWS b/NEWS
index 90a6eb7..cf05800 100644 (file)
--- a/NEWS
+++ b/NEWS
@@ -31,6 +31,11 @@ changes in sbcl-1.0.9 relative to sbcl-1.0.8:
     command was used.
   * bug fix: Branch forms are again annotated as branches in the sb-cover
     annotations.
+  * bug fix: GCD on MOST-NEGATIVE-FIXNUM no longer causes an infinite loop
+    on x86-64. (reported by Gregory Vanuxem)
+  * bug fix: EQUALP could return wrong results for structures with raw
+    slots (slots with a :TYPE of SINGLE-FLOAT, DOUBLE-FLOAT, or a machine
+    word). (reported by Vjacheslav Fyodorov)
 
 changes in sbcl-1.0.8 relative to sbcl-1.0.7:
   * enhancement: experimental macro SB-EXT:COMPARE-AND-SWAP provides

diff --git a/package-data-list.lisp-expr b/package-data-list.lisp-expr
index bebbbf1..5797c73 100644 (file)
--- a/package-data-list.lisp-expr
+++ b/package-data-list.lisp-expr
@@ -1442,7 +1442,9 @@ is a good idea, but see SB-SYS re. blurring of boundaries."
                "PARSE-DEFMACRO" "PARSE-UNKNOWN-TYPE"
                "PARSE-UNKNOWN-TYPE-SPECIFIER" "PATHNAME-DESIGNATOR"
                #!+(or x86 x86-64) "*PSEUDO-ATOMIC-BITS*"
-               "PUNT-PRINT-IF-TOO-LONG" "READER-IMPOSSIBLE-NUMBER-ERROR"
+               "PUNT-PRINT-IF-TOO-LONG"
+               "RAW-INSTANCE-SLOTS-EQUALP"
+               "READER-IMPOSSIBLE-NUMBER-ERROR"
                "READER-PACKAGE-ERROR" "READER-EOF-ERROR"
                "RESTART-DESIGNATOR"
                "RUN-PENDING-FINALIZERS"

diff --git a/src/code/pred.lisp b/src/code/pred.lisp
index 7d006cc..ee5c9e8 100644 (file)
--- a/src/code/pred.lisp
+++ b/src/code/pred.lisp
@@ -317,18 +317,21 @@ length and have identical components. Other arrays must be EQ to be EQUAL."
               (hash-table-equalp x y)))
         ((%instancep x)
          (let* ((layout-x (%instance-layout x))
-                (len (layout-length layout-x)))
+                (raw-len (layout-n-untagged-slots layout-x))
+                (total-len (layout-length layout-x))
+                (normal-len (- total-len raw-len)))
            (and (%instancep y)
                 (eq layout-x (%instance-layout y))
                 (structure-classoid-p (layout-classoid layout-x))
-                (do ((i 1 (1+ i)))
-                    ((= i len) t)
-                  (declare (fixnum i))
+                (dotimes (i normal-len t)
                   (let ((x-el (%instance-ref x i))
                         (y-el (%instance-ref y i)))
                     (unless (or (eq x-el y-el)
                                 (equalp x-el y-el))
-                      (return nil)))))))
+                      (return nil))))
+                (if (zerop raw-len)
+                    t
+                    (raw-instance-slots-equalp layout-x x y)))))
         ((vectorp x)
          (let ((length (length x)))
            (and (vectorp y)

diff --git a/src/code/target-defstruct.lisp b/src/code/target-defstruct.lisp
index 176c4f5..f179459 100644 (file)
--- a/src/code/target-defstruct.lisp
+++ b/src/code/target-defstruct.lisp
@@ -417,6 +417,31 @@
             (%raw-instance-ref/word structure i)))
 
     res))
+
+\f
+
+;; Do an EQUALP comparison on the raw slots (only, not the normal slots) of a
+;; structure.
+(defun raw-instance-slots-equalp (layout x y)
+  ;; This implementation sucks, but hopefully EQUALP on raw structures
+  ;; won't be a major bottleneck for anyone. It'd be tempting to do
+  ;; 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
+        for dsd in (dd-slots (layout-info layout))
+        for raw-type = (dsd-raw-type dsd)
+        for rsd = (when raw-type
+                    (find raw-type
+                          *raw-slot-data-list*
+                          :key 'raw-slot-data-raw-type))
+        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))))))
 \f
 ;;; default PRINT-OBJECT method
 

diff --git a/tests/defstruct.impure.lisp b/tests/defstruct.impure.lisp
index 7e5fad9..b80e723 100644 (file)
--- a/tests/defstruct.impure.lisp
+++ b/tests/defstruct.impure.lisp
@@ -699,5 +699,19 @@
                     (sb-kernel:layout-invalid ()
                       :error2))))))
 
-;;; success
-(format t "~&/returning success~%")
+;; EQUALP didn't work for structures with float slots (reported by
+;; Vjacheslav Fyodorov).
+(defstruct raw-slot-equalp-bug
+  (b 0s0 :type single-float)
+  c
+  (a 0d0 :type double-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)))
+  (assert (equalp (make-raw-slot-equalp-bug :a 1d0 :b 0s0)
+                  (make-raw-slot-equalp-bug :a 1d0 :b -0s0)))
+  (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)))))

diff --git a/version.lisp-expr b/version.lisp-expr
index f774a42..f92ff4b 100644 (file)
--- a/version.lisp-expr
+++ b/version.lisp-expr
@@ -17,4 +17,4 @@
 ;;; checkins which aren't released. (And occasionally for internal
 ;;; versions, especially for internal versions off the main CVS
 ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
-"1.0.8.43"
+"1.0.8.44"