X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=tests%2Fclos.impure.lisp;h=11c6323f4c1ea306c7d8917fe22913b1593233b5;hb=6e8fe793a4f3e8a3c8b67755101ee15df85d73c4;hp=cf876d9249dccffee1de3fa7a0b0e9affa9cc8c6;hpb=44947befbbe3cef262484c265903599109c4dad6;p=sbcl.git diff --git a/tests/clos.impure.lisp b/tests/clos.impure.lisp index cf876d9..11c6323 100644 --- a/tests/clos.impure.lisp +++ b/tests/clos.impure.lisp @@ -1901,4 +1901,135 @@ (sb-pcl::generic-function-pretty-arglist #'generic-function-pretty-arglist-optional-and-key))))) +(with-test (:name :bug-894202) + (assert (eq :good + (handler-case + (let ((name (gensym "FOO")) + (decl (gensym "BAR"))) + (eval `(defgeneric ,name () + (declare (,decl))))) + (warning () + :good))))) + +(with-test (:name :bug-898331) + (handler-bind ((warning #'error)) + (eval `(defgeneric bug-898331 (request type remaining-segment-requests all-requests))) + (eval `(defmethod bug-898331 ((request cons) (type (eql :cancel)) + remaining-segment-requests + all-segment-requests) + (declare (ignore all-segment-requests)) + (check-type request t))))) + +(with-test (:name :bug-1001799) + ;; compilation of the defmethod used to cause infinite recursion + (let ((pax (gensym "PAX")) + (pnr (gensym "PNR")) + (sup (gensym "SUP")) + (frob (gensym "FROB")) + (sb-ext:*evaluator-mode* :compile)) + (eval + `(progn + (declaim (optimize (speed 1) (space 1) (safety 3) (debug 3) (compilation-speed 1))) + (defclass ,pax (,sup) + ((,pnr :type (or null ,pnr)))) + (defclass ,pnr (,sup) + ((,pax :type (or null ,pax)))) + (defclass ,sup () + ()) + (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