From: Christophe Rhodes Date: Wed, 16 Jan 2013 13:51:19 +0000 (+0000) Subject: fix constant-list-related initargs in CTOR optimization X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=3eed77547e03a57c9be57db74081ee0f39ed0fa6;p=sbcl.git 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 --- 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 --- 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 --- 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