X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=tests%2Fclos.impure.lisp;h=2113f59fc33eeaa18066a1587402f03b78319cc9;hb=1fa1730414b6c914e502d339945d0ad7a4a7f5d9;hp=4184438b5290f7f68a9c89f85658c4658c277c94;hpb=522a3c95b9b7a044ff0ab8df1ca29460ef2ad3a7;p=sbcl.git diff --git a/tests/clos.impure.lisp b/tests/clos.impure.lisp index 4184438..2113f59 100644 --- a/tests/clos.impure.lisp +++ b/tests/clos.impure.lisp @@ -1226,8 +1226,7 @@ ;;; test case from Gerd Moellmann (define-method-combination r-c/c-m-1 () ((primary () :required t)) - `(restart-case (call-method ,(first primary)) - ())) + `(restart-case (call-method ,(first primary)))) (defgeneric r-c/c-m-1-gf () (:method-combination r-c/c-m-1) @@ -1939,4 +1938,141 @@ (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)))) + +;;; bug-1179858 + +;;; Define a class and force the "fallback" constructor generator to be +;;; used by having a HAIRY-AROUND-OR-NONSTANDARD-PRIMARY-METHOD-P on +;;; SHARED-INITIALIZE. +(defclass bug-1179858 () + ((foo :initarg :foo :reader bug-1179858-foo)) + (:default-initargs :foo (error "Should not be evaluated"))) +(defmethod shared-initialize :around ((instance bug-1179858) (slot-names t) &key) + (call-next-method)) + +(with-test (:name (:make-instance :fallback-generator-initarg-handling :bug-1179858)) + ;; Now compile a lambda containing MAKE-INSTANCE to exercise the + ;; fallback constructor generator. Call the resulting compiled + ;; function to trigger the bug. + (funcall (compile nil '(lambda () (make-instance 'bug-1179858 :foo t))))) + +;;; Other brokenness, found while investigating: fallback-generator +;;; handling of non-keyword initialization arguments +(defclass bug-1179858b () + ((foo :initarg foo :reader bug-1179858b-foo)) + (:default-initargs foo 14)) +(defmethod shared-initialize :around ((instance bug-1179858b) (slot-names t) &key) + (call-next-method)) + +(with-test (:name (:make-instance :fallback-generator-non-keyword-initarg :bug-1179858)) + (flet ((foo= (n i) (= (bug-1179858b-foo i) n))) + (assert + (foo= 14 (funcall (compile nil '(lambda () (make-instance 'bug-1179858b)))))) + (assert + (foo= 15 (funcall (compile nil '(lambda () (make-instance 'bug-1179858b 'foo 15)))))))) + +(with-test (:name (:cpl-violation-setup :bug-309076)) + (assert (raises-error? + (progn + (defclass bug-309076-broken-class (standard-class) () + (:metaclass sb-mop:funcallable-standard-class)) + (sb-mop:finalize-inheritance (find-class 'bug-309076-broken-class)))))) + +(with-test (:name (:cpl-violation-irrelevant-class :bug-309076)) + (defclass bug-309076-class (standard-class) ()) + (defmethod sb-mop:validate-superclass ((x bug-309076-class) (y standard-class)) t) + (assert (typep (make-instance 'bug-309076-class) 'bug-309076-class))) + ;;;; success