fix constant-list-related initargs in CTOR optimization

lp#1099708, reported by Derek Baldwin; also test for _3b's #sbcl irc insight
that this would break non-EQLity of distinct but EQUAL list constants

Also deal with pathnames, bit-vectors and strings, which are precisely the
types EQUAL descends into.

(The general problem of function names being looked up using EQUAL remains
a problem, though with fewer observable consequences: for example, methods
with EQUAL eql-specializers will have their function names collide with
each other, though since in CLOS the functions are looked up through the
method objects this is less serious than with CTORs.

diff --git a/NEWS b/NEWS
index bd77788..220dbd3 100644 (file)
--- a/NEWS
+++ b/NEWS
@@ -5,6 +5,9 @@ changes relative to sbcl-1.1.3:
   * bug fix: `#3(1) is read as #(1 1 1), not as #(1). (lp#1095918)
   * bug fix: adjust-array ignored :initial-element for simple-vectors.
     (lp#1096359)
+  * bug fix: optimizations to MAKE-INSTANCE with literal list initargs no
+    longer cause infinite loops (on circular data) or violate eqlity
+    constraints.  (lp#1099708)
 
 changes in sbcl-1.1.3 relative to sbcl-1.1.2:
   * enhancement: warnings about bad locale settings, LANG, LC_CTYPE, etc.

diff --git a/src/pcl/ctor.lisp b/src/pcl/ctor.lisp
index f73b658..872447b 100644 (file)
--- a/src/pcl/ctor.lisp
+++ b/src/pcl/ctor.lisp
@@ -152,7 +152,21 @@
           (ctor-function-name ctor))))
 
 (defun make-ctor-function-name (class-name initargs safe-code-p)
-  (list* 'ctor class-name safe-code-p initargs))
+  (labels ((arg-name (x)
+             (typecase x
+               ;; this list of types might look arbitrary but it is
+               ;; exactly the set of types descended into by EQUAL,
+               ;; which is the predicate used by globaldb to test for
+               ;; name equality.
+               (list (gensym "LIST-INITARG-"))
+               (string (gensym "STRING-INITARG-"))
+               (bit-vector (gensym "BIT-VECTOR-INITARG-"))
+               (pathname (gensym "PATHNAME-INITARG-"))
+               (t x)))
+           (munge (list)
+             (let ((*gensym-counter* 0))
+               (mapcar #'arg-name list))))
+    (list* 'ctor class-name safe-code-p (munge initargs))))
 
 ;;; Keep this a separate function for testing.
 (defun ensure-ctor (function-name class-name initargs safe-code-p)

diff --git a/tests/clos.impure.lisp b/tests/clos.impure.lisp
index 4184438..11c6323 100644 (file)
--- a/tests/clos.impure.lisp
+++ b/tests/clos.impure.lisp
@@ -1939,4 +1939,97 @@
         (defmethod ,frob ((pnr ,pnr))
           (slot-value pnr ',pax))))))
 
+(with-test (:name :bug-1099708)
+  (defclass bug-1099708 ()
+    ((slot-1099708 :initarg :slot-1099708)))
+  ;; caused infinite equal testing in function name lookup
+  (eval
+   '(progn
+     (defun make-1099708-1 ()
+       (make-instance 'bug-1099708 :slot-1099708 '#1= (1 2 . #1#)))
+     (defun make-1099708-2 ()
+       (make-instance 'bug-1099708 :slot-1099708 '#2= (1 2 . #2#)))))
+  (assert (not (eql (slot-value (make-1099708-1) 'slot-1099708)
+                    (slot-value (make-1099708-2) 'slot-1099708)))))
+
+(with-test (:name :bug-1099708b-list)
+  (defclass bug-1099708b-list ()
+    ((slot-1099708b-list :initarg :slot-1099708b-list)))
+  (eval
+   '(progn
+     (defun make-1099708b-list-1 ()
+       (make-instance 'bug-1099708b-list :slot-1099708b-list '(some value)))
+     (defun make-1099708b-list-2 ()
+       (make-instance 'bug-1099708b-list :slot-1099708b-list '(some value)))))
+  (assert (eql (slot-value (make-1099708b-list-1) 'slot-1099708b-list)
+               (slot-value (make-1099708b-list-1) 'slot-1099708b-list)))
+  (assert (eql (slot-value (make-1099708b-list-2) 'slot-1099708b-list)
+               (slot-value (make-1099708b-list-2) 'slot-1099708b-list)))
+  (assert (not (eql (slot-value (make-1099708b-list-1) 'slot-1099708b-list)
+                    (slot-value (make-1099708b-list-2) 'slot-1099708b-list)))))
+
+(with-test (:name :bug-1099708b-string)
+  (defclass bug-1099708b-string ()
+    ((slot-1099708b-string :initarg :slot-1099708b-string)))
+  (eval
+   '(progn
+     (defun make-1099708b-string-1 ()
+       (make-instance 'bug-1099708b-string :slot-1099708b-string "string"))
+     (defun make-1099708b-string-2 ()
+       (make-instance 'bug-1099708b-string :slot-1099708b-string "string"))))
+  (assert (eql (slot-value (make-1099708b-string-1) 'slot-1099708b-string)
+               (slot-value (make-1099708b-string-1) 'slot-1099708b-string)))
+  (assert (eql (slot-value (make-1099708b-string-2) 'slot-1099708b-string)
+               (slot-value (make-1099708b-string-2) 'slot-1099708b-string)))
+  (assert (not (eql (slot-value (make-1099708b-string-1) 'slot-1099708b-string)
+                    (slot-value (make-1099708b-string-2) 'slot-1099708b-string)))))
+
+(with-test (:name :bug-1099708b-bitvector)
+  (defclass bug-1099708b-bitvector ()
+    ((slot-1099708b-bitvector :initarg :slot-1099708b-bitvector)))
+  (eval
+   '(progn
+     (defun make-1099708b-bitvector-1 ()
+       (make-instance 'bug-1099708b-bitvector :slot-1099708b-bitvector #*1011))
+     (defun make-1099708b-bitvector-2 ()
+       (make-instance 'bug-1099708b-bitvector :slot-1099708b-bitvector #*1011))))
+  (assert (eql (slot-value (make-1099708b-bitvector-1) 'slot-1099708b-bitvector)
+               (slot-value (make-1099708b-bitvector-1) 'slot-1099708b-bitvector)))
+  (assert (eql (slot-value (make-1099708b-bitvector-2) 'slot-1099708b-bitvector)
+               (slot-value (make-1099708b-bitvector-2) 'slot-1099708b-bitvector)))
+  (assert (not (eql (slot-value (make-1099708b-bitvector-1) 'slot-1099708b-bitvector)
+                    (slot-value (make-1099708b-bitvector-2) 'slot-1099708b-bitvector)))))
+
+(with-test (:name :bug-1099708b-pathname)
+  (defclass bug-1099708b-pathname ()
+    ((slot-1099708b-pathname :initarg :slot-1099708b-pathname)))
+  (eval
+   '(progn
+     (defun make-1099708b-pathname-1 ()
+       (make-instance 'bug-1099708b-pathname :slot-1099708b-pathname #p"pn"))
+     (defun make-1099708b-pathname-2 ()
+       (make-instance 'bug-1099708b-pathname :slot-1099708b-pathname #p"pn"))))
+  (assert (eql (slot-value (make-1099708b-pathname-1) 'slot-1099708b-pathname)
+               (slot-value (make-1099708b-pathname-1) 'slot-1099708b-pathname)))
+  (assert (eql (slot-value (make-1099708b-pathname-2) 'slot-1099708b-pathname)
+               (slot-value (make-1099708b-pathname-2) 'slot-1099708b-pathname)))
+  (assert (not (eql (slot-value (make-1099708b-pathname-1) 'slot-1099708b-pathname)
+                    (slot-value (make-1099708b-pathname-2) 'slot-1099708b-pathname)))))
+
+(with-test (:name :bug-1099708c-list)
+  (defclass bug-1099708c-list ()
+    ((slot-1099708c-list :initarg :slot-1099708c-list)))
+  (eval
+   '(progn
+     (defun make-1099708c-list-1 ()
+       (make-instance 'bug-1099708c-list :slot-1099708c-list #1='(some value)))
+     (defun make-1099708c-list-2 ()
+       (make-instance 'bug-1099708c-list :slot-1099708c-list #1#))))
+  (assert (eql (slot-value (make-1099708c-list-1) 'slot-1099708c-list)
+               (slot-value (make-1099708c-list-1) 'slot-1099708c-list)))
+  (assert (eql (slot-value (make-1099708c-list-2) 'slot-1099708c-list)
+               (slot-value (make-1099708c-list-2) 'slot-1099708c-list)))
+  (assert (eql (slot-value (make-1099708c-list-1) 'slot-1099708c-list)
+               (slot-value (make-1099708c-list-2) 'slot-1099708c-list))))
+
 ;;;; success