;;;; absolutely no warranty. See the COPYING and CREDITS files for
;;;; more information.
-(load "assertoid.lisp")
-
+(load "compiler-test-util.lisp")
(defpackage "CLOS-IMPURE"
- (:use "CL" "ASSERTOID" "TEST-UTIL"))
+ (:use "CL" "ASSERTOID" "TEST-UTIL" "COMPILER-TEST-UTIL"))
(in-package "CLOS-IMPURE")
\f
;;; It should be possible to do DEFGENERIC and DEFMETHOD referring to
(ignore-errors (progn ,@body))
(declare (ignore res))
(typep condition 'error))))
-(assert (expect-error
- (macroexpand-1
- '(defmethod foo0 ((x t) &rest) nil))))
+(assert (expect-error (defmethod foo0 ((x t) &rest) nil)))
(assert (expect-error (defgeneric foo1 (x &rest))))
(assert (expect-error (defgeneric foo2 (x a &rest))))
(defgeneric foo3 (x &rest y))
(defmethod foo4 ((x t) &rest z &key y) nil)
(defgeneric foo4 (x &rest z &key y))
(assert (expect-error (defgeneric foo5 (x &rest))))
-(assert (expect-error (macroexpand-1 '(defmethod foo6 (x &rest)))))
+(assert (expect-error (defmethod foo6 (x &rest))))
+
+;;; legal method specializers
+(defclass bug-525916-1 () ())
+(defclass bug-525916-2 () ())
+(with-test (:name :bug-525916)
+(assert (expect-error (defmethod invalid ((arg)) arg)))
+(assert (expect-error (defmethod invalid (nil) 1)))
+(assert (expect-error (defmethod invalid ((arg . bug-525916-1)) arg)))
+(assert (expect-error (defmethod invalid ((arg bug-525916-1 bug-525916-2)) arg))))
;;; more lambda-list checking
;;;
;;; DOCUMENTATION's argument-precedence-order wasn't being faithfully
;;; preserved through the bootstrap process until sbcl-0.7.8.39.
;;; (thanks to Gerd Moellmann)
-(let ((answer (documentation '+ 'function)))
- (assert (stringp answer))
- (defmethod documentation ((x (eql '+)) y) "WRONG")
- (assert (string= (documentation '+ 'function) answer)))
+(with-test (:name :documentation-argument-precedence-order)
+ (defun foo022 ()
+ "Documentation"
+ t)
+ (let ((answer (documentation 'foo022 'function)))
+ (assert (stringp answer))
+ (defmethod documentation ((x (eql 'foo022)) y) "WRONG")
+ (assert (string= (documentation 'foo022 'function) answer))))
\f
;;; only certain declarations are permitted in DEFGENERIC
(macrolet ((assert-program-error (form)
(assert (= (bug222 t) 1))
;;; also, a test case to guard against bogus environment hacking:
+
(eval-when (:compile-toplevel :load-toplevel :execute)
(setq bug222-b 3))
;;; this should at the least compile:
;;; and it would be nice (though not specified by ANSI) if the answer
;;; were as follows:
(let ((x (make-string-output-stream)))
- ;; not specified by ANSI
- (assert (= (bug222-b t x) 3))
+ (let ((value (bug222-b t x)))
+ ;; not specified by ANSI
+ #+#.(cl:if (cl:eq sb-ext:*evaluator-mode* :compile) '(and) '(or))
+ (assert (= value 3)))
;; specified.
(assert (char= (char (get-output-stream-string x) 0) #\1)))
\f
(assert (= (slot-value *yao-super* 'obs) 3))
(assert (= (slot-value *yao-sub* 'obs) 3))
+;;; one more MIO test: variable slot names
+(defclass mio () ((x :initform 42)))
+(defvar *mio-slot* 'x)
+(defparameter *mio-counter* 0)
+(defmethod update-instance-for-redefined-class ((instance mio) new old plist &key)
+ (incf *mio-counter*))
+
+(let ((x (make-instance 'mio)))
+ (make-instances-obsolete 'mio)
+ (slot-value x *mio-slot*))
+
+(let ((x (make-instance 'mio)))
+ (make-instances-obsolete 'mio)
+ (setf (slot-value x *mio-slot*) 13))
+
+(let ((x (make-instance 'mio)))
+ (make-instances-obsolete 'mio)
+ (slot-boundp x *mio-slot*))
+
+(let ((x (make-instance 'mio)))
+ (make-instances-obsolete 'mio)
+ (slot-makunbound x *mio-slot*))
+
+(assert (= 4 *mio-counter*))
+
;;; shared -> local slot transfers of inherited slots, reported by
;;; Bruno Haible
(let (i)
(load "package-ctor-bug.lisp")
(assert (= (package-ctor-bug:test) 3))
-(deftype defined-type () 'integer)
-(assert (raises-error?
- (defmethod method-on-defined-type ((x defined-type)) x)))
-(deftype defined-type-and-class () 'integer)
-(setf (find-class 'defined-type-and-class) (find-class 'integer))
-(defmethod method-on-defined-type-and-class ((x defined-type-and-class))
- (1+ x))
-(assert (= (method-on-defined-type-and-class 3) 4))
+(with-test (:name (:defmethod (setf find-class) integer))
+ (mapcar #'eval
+ '(
+ (deftype defined-type () 'integer)
+ (assert (raises-error?
+ (defmethod method-on-defined-type ((x defined-type)) x)))
+ (deftype defined-type-and-class () 'integer)
+ (setf (find-class 'defined-type-and-class) (find-class 'integer))
+ (defmethod method-on-defined-type-and-class
+ ((x defined-type-and-class))
+ (1+ x))
+ (assert (= (method-on-defined-type-and-class 3) 4)))))
;; bug 281
-(let ((sb-pcl::*max-emf-precomputation-methods* 0))
+(let (#+nil ; no more sb-pcl::*max-emf-precomputation-methods* as of
+ ; sbcl-1.0.41.x
+ (sb-pcl::*max-emf-precomputation-methods* 0))
(eval '(defgeneric bug-281 (x)
(:method-combination +)
(:method ((x symbol)) 1)
;;; 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)
(defmethod class-as-specializer-test2 ((x ,(find-class 'class-as-specializer-test)))
'bar))))
(assert (eq 'bar (class-as-specializer-test2 (make-instance 'class-as-specializer-test))))
+\f
+;;; CHANGE-CLASS and tricky allocation.
+(defclass foo-to-be-changed ()
+ ((a :allocation :class :initform 1)))
+(defclass bar-to-be-changed (foo-to-be-changed) ())
+(defvar *bar-to-be-changed* (make-instance 'bar-to-be-changed))
+(defclass baz-to-be-changed ()
+ ((a :allocation :instance :initform 2)))
+(change-class *bar-to-be-changed* 'baz-to-be-changed)
+(assert (= (slot-value *bar-to-be-changed* 'a) 1))
+\f
+;;; proper name and class redefinition
+(defvar *to-be-renamed1* (defclass to-be-renamed1 () ()))
+(defvar *to-be-renamed2* (defclass to-be-renamed2 () ()))
+(setf (find-class 'to-be-renamed1) (find-class 'to-be-renamed2))
+(defvar *renamed1* (defclass to-be-renamed1 () ()))
+(assert (not (eq *to-be-renamed1* *to-be-renamed2*)))
+(assert (not (eq *to-be-renamed1* *renamed1*)))
+(assert (not (eq *to-be-renamed2* *renamed1*)))
+\f
+;;; CLASS-NAME (and various other standardized generic functions) have
+;;; their effective methods precomputed; in the process of rearranging
+;;; (SETF FIND-CLASS) and FINALIZE-INHERITANCE, this broke.
+(defclass class-with-odd-class-name-method ()
+ ((a :accessor class-name)))
+\f
+;;; another case where precomputing (this time on PRINT-OBJECT) and
+;;; lazily-finalized classes caused problems. (report from James Y
+;;; Knight sbcl-devel 20-07-2006)
+
+(defclass base-print-object () ())
+;;; this has the side-effect of finalizing BASE-PRINT-OBJECT, and
+;;; additionally the second specializer (STREAM) changes the cache
+;;; structure to require two keys, not just one.
+(defmethod print-object ((o base-print-object) (s stream))
+ nil)
+
+;;; unfinalized as yet
+(defclass sub-print-object (base-print-object) ())
+;;; the accessor causes an eager finalization
+(defclass subsub-print-object (sub-print-object)
+ ((a :accessor a)))
+
+;;; triggers a discriminating function (and so cache) recomputation.
+;;; The method on BASE-PRINT-OBJECT will cause the system to attempt
+;;; to fill the cache for all subclasses of BASE-PRINT-OBJECT which
+;;; have valid wrappers; however, in the course of doing so, the
+;;; SUB-PRINT-OBJECT class gets finalized, which invalidates the
+;;; SUBSUB-PRINT-OBJECT wrapper; if an invalid wrapper gets into a
+;;; cache with more than one key, then failure ensues.
+(reinitialize-instance #'print-object)
+\f
+;;; bug in long-form method combination: if there's an applicable
+;;; method not part of any method group, we need to call
+;;; INVALID-METHOD-ERROR. (MC27 test case from Bruno Haible)
+(define-method-combination mc27 ()
+ ((normal ())
+ (ignored (:ignore :unused)))
+ `(list 'result
+ ,@(mapcar #'(lambda (method) `(call-method ,method)) normal)))
+(defgeneric test-mc27 (x)
+ (:method-combination mc27)
+ (:method :ignore ((x number)) (/ 0)))
+(assert (raises-error? (test-mc27 7)))
+
+(define-method-combination mc27prime ()
+ ((normal ())
+ (ignored (:ignore)))
+ `(list 'result ,@(mapcar (lambda (m) `(call-method ,m)) normal)))
+(defgeneric test-mc27prime (x)
+ (:method-combination mc27prime)
+ (:method :ignore ((x number)) (/ 0)))
+(assert (equal '(result) (test-mc27prime 3)))
+(assert (raises-error? (test-mc27 t))) ; still no-applicable-method
+\f
+;;; more invalid wrappers. This time for a long-standing bug in the
+;;; compiler's expansion for TYPEP on various class-like things, with
+;;; user-visible consequences.
+(defclass obsolete-again () ())
+(defvar *obsolete-again* (make-instance 'obsolete-again))
+(defvar *obsolete-again-hash* (sxhash *obsolete-again*))
+(make-instances-obsolete (find-class 'obsolete-again))
+(assert (not (streamp *obsolete-again*)))
+(make-instances-obsolete (find-class 'obsolete-again))
+(assert (= (sxhash *obsolete-again*) *obsolete-again-hash*))
+(compile (defun is-a-structure-object-p (x) (typep x 'structure-object)))
+(make-instances-obsolete (find-class 'obsolete-again))
+(assert (not (is-a-structure-object-p *obsolete-again*)))
+\f
+;;; overeager optimization of slot-valuish things
+(defclass listoid ()
+ ((caroid :initarg :caroid)
+ (cdroid :initarg :cdroid :initform nil)))
+(defmethod lengthoid ((x listoid))
+ (let ((result 0))
+ (loop until (null x)
+ do (incf result) (setq x (slot-value x 'cdroid)))
+ result))
+(with-test (:name ((:setq :method-parameter) slot-value))
+ (assert (= (lengthoid (make-instance 'listoid)) 1))
+ (assert (= (lengthoid
+ (make-instance 'listoid :cdroid
+ (make-instance 'listoid :cdroid
+ (make-instance 'listoid))))
+ 3)))
+
+\f
+
+;;;; Tests for argument parsing in fast-method-functions.
+
+(defvar *foo* 0)
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (setf (symbol-value 'a) 'invalid))
+
+(defmacro test1 (lambda-list values args &key declarations cnm)
+ `(progn
+ (fmakunbound 'll-method)
+ (fmakunbound 'll-function)
+ (defmethod ll-method ,lambda-list
+ ,@declarations
+ ,@(when cnm
+ `((when nil (call-next-method))))
+ (list ,@values))
+ (defun ll-function ,lambda-list
+ ,@declarations
+ (list ,@values))
+ (dotimes (i 2)
+ (assert (equal (ll-method ,@args)
+ (ll-function ,@args))))))
+
+(defmacro test (&rest args)
+ `(progn
+ (test1 ,@args :cnm nil)
+ (test1 ,@args :cnm t)))
+
+;; Just plain arguments
+
+(test (a) (a) (1))
+(test (a b c d e f g h i) (a b c d e f g h i) (1 2 3 4 5 6 7 8 9))
+
+(test (*foo*) (*foo* (symbol-value '*foo*)) (1))
+
+(test (a) (a (symbol-value 'a)) (1)
+ :declarations ((declare (special a))))
+
+;; Optionals
+
+(test (a &optional b c) (a b c) (1))
+(test (a &optional b c) (a b c) (1 2))
+(test (a &optional b c) (a b c) (1 2 3))
+
+(test (a &optional (b 'b b-p) (c 'c c-p)) (a b c b-p c-p) (1))
+(test (a &optional (b 'b b-p) (c 'c c-p)) (a b c b-p c-p) (1 2))
+(test (a &optional (b 'b b-p) (c 'c c-p)) (a b c b-p c-p) (1 2 3))
+
+(test (&optional *foo*) (*foo* (symbol-value '*foo*)) ())
+(test (&optional *foo*) (*foo* (symbol-value '*foo*)) (1))
+
+(test (&optional (*foo* 'z foo-p)) (*foo* (symbol-value '*foo*) foo-p) ())
+(test (&optional (*foo* 'z foo-p)) (*foo* (symbol-value '*foo*) foo-p) (1))
+
+(test (&optional a) (a (symbol-value 'a)) ()
+ :declarations ((declare (special a))))
+(test (&optional a) (a (symbol-value 'a)) (1)
+ :declarations ((declare (special a))))
+
+(test (&optional (a 'z a-p)) (a (symbol-value 'a) a-p) ()
+ :declarations ((declare (special a))))
+(test (&optional (a 'z a-p)) (a (symbol-value 'a) a-p) (1)
+ :declarations ((declare (special a))))
+
+(defparameter *count* 0)
+
+(test (&optional (a (incf *count*)) (b (incf *count*)))
+ (a b *count* (setf *count* 0))
+ ())
+
+;; Keywords with some &RESTs thrown in
+
+(dolist (args '((1)
+ (1 :b 2)
+ (1 :c 3)
+ (1 :b 2 :c 3)
+ (1 :c 3 :b 2)
+ (1 :c 3 :c 1 :b 2 :b 4)))
+ (eval `(test (a &key b c) (a b c) ,args))
+ (eval `(test (a &key (b 'b b-p) (c 'c c-p))
+ (a b c b-p c-p)
+ ,args))
+ (eval `(test (a &rest rest &key (b 'b b-p) (c 'c c-p))
+ (a b c b-p c-p rest)
+ ,args))
+ (eval `(test (a &rest *foo* &key (b 'b b-p) (c 'c c-p))
+ (a b c b-p c-p *foo* (symbol-value '*foo*))
+ ,args))
+ (eval `(test (a &rest *foo* &key (b 'b b-p) (c 'c c-p))
+ (a b c b-p c-p *foo* (symbol-value '*foo*))
+ ,args
+ :declarations ((declare (special b-p))))))
+
+(dolist (args '(()
+ (:*foo* 1)
+ (:*foo* 1 :*foo* 2)))
+ (eval `(test (&key *foo*) (*foo* (symbol-value '*foo*)) ,args))
+ (eval `(test (&key (*foo* 'z foo-p)) (*foo* (symbol-value '*foo*) foo-p)
+ ,args))
+ (eval `(test (&key ((:*foo* a) 'z foo-p)) (a (symbol-value 'a) foo-p)
+ ,args))
+ (eval `(test (&key ((:*foo* a) 'z foo-p)) (a (symbol-value 'a) foo-p)
+ ,args
+ :declarations ((declare (special a))))))
+
+(defparameter *count* 0)
+
+(test (&key (a (incf *count*)) (b (incf *count*)))
+ (a b *count* (setf *count* 0))
+ ())
+
+(test (&key a b &allow-other-keys) (a b) (:a 1 :b 2 :c 3))
+
+(defmethod clim-style-lambda-list-test (a b &optional c d &key x y)
+ (list a b c d x y))
+
+(clim-style-lambda-list-test 1 2)
+
+(setf *count* 0)
+
+(test (&aux (a (incf *count*)) (b (incf *count*)))
+ (a b *count* (setf *count* 0))
+ ())
+
+;;;; long-form method combination with &rest in :arguments
+;;;; (this had a bug what with fixed in 1.0.4.something)
+(define-method-combination long-form-with-&rest ()
+ ((methods *))
+ (:arguments x &rest others)
+ `(progn
+ ,@(mapcar (lambda (method)
+ `(call-method ,method))
+ methods)
+ (list ,x (length ,others))))
+
+(defgeneric test-long-form-with-&rest (x &rest others)
+ (:method-combination long-form-with-&rest))
+
+(defmethod test-long-form-with-&rest (x &rest others)
+ nil)
+
+(assert (equal '(:foo 13)
+ (apply #'test-long-form-with-&rest :foo (make-list 13))))
+
+;;;; slot-missing for non-standard classes on SLOT-VALUE
+;;;;
+;;;; FIXME: This is arguably not right, actually: CLHS seems to say
+;;;; we should just signal an error at least for built-in classes, but
+;;;; for a while we were hitting NO-APPLICABLE-METHOD, which is definitely
+;;;; wrong -- so test this for now at least.
+
+(defvar *magic-symbol* (gensym "MAGIC"))
+
+(set *magic-symbol* 42)
+
+(defmethod slot-missing (class instance (slot-name (eql *magic-symbol*)) op
+ &optional new)
+ (if (eq 'setf op)
+ (setf (symbol-value *magic-symbol*) new)
+ (symbol-value *magic-symbol*)))
+
+(assert (eql 42 (slot-value (cons t t) *magic-symbol*)))
+(assert (eql 13 (setf (slot-value 123 *magic-symbol*) 13)))
+(assert (eql 13 (slot-value 'foobar *magic-symbol*)))
+
+;;;; Built-in structure and condition layouts should have NIL in
+;;;; LAYOUT-FOR-STD-CLASS-P, and classes should have T.
+
+(assert (not (sb-pcl::layout-for-std-class-p (sb-pcl::find-layout 'warning))))
+(assert (not (sb-pcl::layout-for-std-class-p (sb-pcl::find-layout 'hash-table))))
+(assert (eq t (sb-pcl::layout-for-std-class-p (sb-pcl::find-layout 'standard-object))))
+
+;;;; bug 402: PCL used to warn about non-standard declarations
+(declaim (declaration bug-402-d))
+(defgeneric bug-402-gf (x))
+(with-test (:name :bug-402)
+ (handler-bind ((warning #'error))
+ (eval '(defmethod bug-402-gf (x)
+ (declare (bug-402-d x))
+ x))))
+
+;;;; non-keyword :default-initargs + :before method on shared initialize
+;;;; interacted badly with CTOR optimizations
+(defclass ctor-default-initarg-problem ()
+ ((slot :initarg slotto))
+ (:default-initargs slotto 123))
+(defmethod shared-initialize :before ((instance ctor-default-initarg-problem) slot-names &rest initargs)
+ (format t "~&Rock on: ~A~%" initargs))
+(defun provoke-ctor-default-initarg-problem ()
+ (make-instance 'ctor-default-initarg-problem))
+(handler-bind ((warning #'error))
+ (assert (= 123 (slot-value (provoke-ctor-default-initarg-problem) 'slot))))
+
+;;;; discriminating net on streams used to generate code deletion notes on
+;;;; first call
+(defgeneric stream-fd (stream direction))
+(defmethod stream-fd ((stream sb-sys:fd-stream) direction)
+ (declare (ignore direction))
+ (sb-sys:fd-stream-fd stream))
+(defmethod stream-fd ((stream synonym-stream) direction)
+ (stream-fd (symbol-value (synonym-stream-symbol stream)) direction))
+(defmethod stream-fd ((stream two-way-stream) direction)
+ (ecase direction
+ (:input
+ (stream-fd
+ (two-way-stream-input-stream stream) direction))
+ (:output
+ (stream-fd
+ (two-way-stream-output-stream stream) direction))))
+(with-test (:name (:discriminating-name :code-deletion-note))
+ (handler-bind ((compiler-note #'error))
+ (stream-fd sb-sys:*stdin* :output)
+ (stream-fd sb-sys:*stdin* :output)))
+
+(with-test (:name :bug-380)
+ (defclass bug-380 ()
+ ((slot :accessor bug380-slot)))
+ (fmakunbound 'foo-slot)
+ (defgeneric foo-slot (x y z))
+ (defclass foo ()
+ ((slot :accessor foo-slot-value))))
+
+;;; SET and (SETF SYMBOL-VALUE) used to confuse permuation vector
+;;; optimizations
+(defclass fih ()
+ ((x :initform :fih)))
+(defclass fah ()
+ ((x :initform :fah)))
+(declaim (special *fih*))
+(defmethod fihfah ((*fih* fih))
+ (set '*fih* (make-instance 'fah))
+ (list (slot-value *fih* 'x)
+ (eval '(slot-value *fih* 'x))))
+(defmethod fihfah ((fah fah))
+ (declare (special fah))
+ (set 'fah (make-instance 'fih))
+ (list (slot-value fah 'x)
+ (eval '(slot-value fah 'x))))
+(with-test (:name :set-of-a-method-specializer)
+ (assert (equal '(:fah :fah) (fihfah (make-instance 'fih))))
+ (assert (equal '(:fih :fih) (fihfah (make-instance 'fah)))))
+
+(defmethod no-implicit-declarations-for-local-specials ((faax double-float))
+ (declare (special faax))
+ (set 'faax (when (< faax 0) (- faax)))
+ faax)
+(with-test (:name :no-implicit-declarations-for-local-specials)
+ (assert (not (no-implicit-declarations-for-local-specials 1.0d0))))
+
+(defstruct bug-357-a
+ slot1
+ (slot2 t)
+ (slot3 (coerce pi 'single-float) :type single-float))
+(defclass bug-357-b (bug-357-a)
+ ((slot2 :initform 't2)
+ (slot4 :initform -44)
+ (slot5)
+ (slot6 :initform t)
+ (slot7 :initform (floor (* pi pi)))
+ (slot8 :initform 88))
+ (:metaclass structure-class))
+(defstruct (bug-357-c (:include bug-357-b (slot8 -88) (slot5 :ok)))
+ slot9
+ (slot10 t)
+ (slot11 (floor (exp 3))))
+(with-test (:name :bug-357)
+ (flet ((slots (x)
+ (list (bug-357-c-slot1 x)
+ (bug-357-c-slot2 x)
+ (bug-357-c-slot3 x)
+ (bug-357-c-slot4 x)
+ (bug-357-c-slot5 x)
+ (bug-357-c-slot6 x)
+ (bug-357-c-slot7 x)
+ (bug-357-c-slot8 x)
+ (bug-357-c-slot9 x)
+ (bug-357-c-slot10 x)
+ (bug-357-c-slot11 x))))
+ (let ((base (slots (make-bug-357-c))))
+ (assert (equal base (slots (make-instance 'bug-357-c))))
+ (assert (equal base '(nil t2 3.1415927 -44 :ok t 9 -88 nil t 20))))))
+
+(defclass class-slot-shared-initialize ()
+ ((a :allocation :class :initform :ok)))
+(with-test (:name :class-slot-shared-initialize)
+ (let ((x (make-instance 'class-slot-shared-initialize)))
+ (assert (eq :ok (slot-value x 'a)))
+ (slot-makunbound x 'a)
+ (assert (not (slot-boundp x 'a)))
+ (shared-initialize x '(a))
+ (assert (slot-boundp x 'a))
+ (assert (eq :ok (slot-value x 'a)))))
+
+(declaim (ftype (function (t t t) (values single-float &optional))
+ i-dont-want-to-be-clobbered-1
+ i-dont-want-to-be-clobbered-2))
+(defgeneric i-dont-want-to-be-clobbered-1 (t t t))
+(defmethod i-dont-want-to-be-clobbered-2 ((x cons) y z)
+ y)
+(defun i-cause-an-gf-info-update ()
+ (i-dont-want-to-be-clobbered-2 t t t))
+(with-test (:name :defgeneric-should-clobber-ftype)
+ ;; (because it doesn't check the argument or result types)
+ (assert (equal '(function (t t t) *)
+ (sb-kernel:type-specifier
+ (sb-int:info :function
+ :type 'i-dont-want-to-be-clobbered-1))))
+ (assert (equal '(function (t t t) *)
+ (sb-kernel:type-specifier
+ (sb-int:info :function
+ :type 'i-dont-want-to-be-clobbered-2))))
+ (assert (eq :defined-method
+ (sb-int:info :function
+ :where-from 'i-dont-want-to-be-clobbered-1)))
+ (assert (eq :defined-method
+ (sb-int:info :function
+ :where-from 'i-dont-want-to-be-clobbered-2))))
+
+(with-test (:name :bogus-parameter-specializer-name-error)
+ (assert (eq :ok
+ (handler-case
+ (eval `(defmethod #:fii ((x "a string")) 'string))
+ (sb-int:reference-condition (c)
+ (when (member '(:ansi-cl :macro defmethod)
+ (sb-int:reference-condition-references c)
+ :test #'equal)
+ :ok))))))
+
+(defclass remove-default-initargs-test ()
+ ((x :initarg :x :initform 42)))
+(defclass remove-default-initatgs-test ()
+ ((x :initarg :x :initform 42))
+ (:default-initargs :x 0))
+(defclass remove-default-initargs-test ()
+ ((x :initarg :x :initform 42)))
+(with-test (:name :remove-default-initargs)
+ (assert (= 42 (slot-value (make-instance 'remove-default-initargs-test)
+ 'x))))
\f
+(with-test (:name :bug-485019)
+ ;; there was a bug in WALK-SETQ, used in method body walking, in the
+ ;; presence of declarations on symbol macros.
+ (defclass bug-485019 ()
+ ((array :initarg :array)))
+ (defmethod bug-485019 ((bug-485019 bug-485019))
+ (with-slots (array) bug-485019
+ (declare (type (or null simple-array) array))
+ (setf array (make-array 4)))
+ bug-485019)
+ (bug-485019 (make-instance 'bug-485019)))
+
+;;; The compiler didn't propagate the declarared type before applying
+;;; the transform for (SETF SLOT-VALUE), so the generic accessor was used.
+(defstruct foo-520366
+ slot)
+(defun quux-520366 (cont)
+ (funcall cont))
+(defun bar-520366 (foo-struct)
+ (declare (type foo-520366 foo-struct))
+ (with-slots (slot) foo-struct
+ (tagbody
+ (quux-520366 #'(lambda ()
+ (setf slot :value)
+ (go TAG)))
+ TAG)))
+(with-test (:name :bug-520366)
+ (let ((callees (find-named-callees #'bar-520366)))
+ (assert (equal (list #'quux-520366) callees))))
+
+(defgeneric no-applicable-method/retry (x))
+(defmethod no-applicable-method/retry ((x string))
+ "string")
+(with-test (:name :no-applicable-method/retry)
+ (assert (equal "cons"
+ (handler-bind ((error
+ (lambda (c)
+ (declare (ignore c))
+ (let ((r (find-restart 'sb-pcl::retry)))
+ (when r
+ (eval `(defmethod no-applicable-method/retry ((x cons))
+ "cons"))
+ (invoke-restart r))))))
+ (no-applicable-method/retry (cons t t))))))
+
+(defgeneric no-primary-method/retry (x))
+(defmethod no-primary-method/retry :before (x) (assert x))
+(with-test (:name :no-primary-method/retry)
+ (assert (equal "ok!"
+ (handler-bind ((error
+ (lambda (c)
+ (declare (ignore c))
+ (let ((r (find-restart 'sb-pcl::retry)))
+ (when r
+ (eval `(defmethod no-primary-method/retry (x)
+ "ok!"))
+ (invoke-restart r))))))
+ (no-primary-method/retry (cons t t))))))
+\f
+;;; test that a cacheing strategy for make-instance initargs checking
+;;; can handle class redefinitions
+(defclass cacheing-initargs-redefinitions-check ()
+ ((slot :initarg :slot)))
+(defun cacheing-initargs-redefinitions-check-fun (&optional (initarg :slot))
+ (declare (notinline make-instance))
+ (make-instance 'cacheing-initargs-redefinitions-check)
+ (make-instance 'cacheing-initargs-redefinitions-check initarg 3))
+(with-test (:name :make-instance-initargs)
+ (make-instance 'cacheing-initargs-redefinitions-check)
+ (make-instance 'cacheing-initargs-redefinitions-check :slot 3)
+ (cacheing-initargs-redefinitions-check-fun :slot)
+ (assert (raises-error? (cacheing-initargs-redefinitions-check-fun :slot2))))
+(defclass cacheing-initargs-redefinitions-check ()
+ ((slot :initarg :slot2)))
+(with-test (:name :make-instance-redefined-initargs)
+ (make-instance 'cacheing-initargs-redefinitions-check)
+ (make-instance 'cacheing-initargs-redefinitions-check :slot2 3)
+ (cacheing-initargs-redefinitions-check-fun :slot2)
+ (assert (raises-error? (cacheing-initargs-redefinitions-check-fun :slot))))
+(defmethod initialize-instance :after ((class cacheing-initargs-redefinitions-check) &key slot)
+ nil)
+(with-test (:name :make-instance-new-method-initargs)
+ (make-instance 'cacheing-initargs-redefinitions-check)
+ (make-instance 'cacheing-initargs-redefinitions-check :slot2 3)
+ (cacheing-initargs-redefinitions-check-fun :slot2)
+ (let ((thing (cacheing-initargs-redefinitions-check-fun :slot)))
+ (assert (not (slot-boundp thing 'slot)))))
+
+(with-test (:name :defmethod-specializer-builtin-class-alias)
+ (let ((alias (gensym)))
+ (setf (find-class alias) (find-class 'symbol))
+ (eval `(defmethod lp-618387 ((s ,alias))
+ (symbol-name s)))
+ (assert (equal "FOO" (funcall 'lp-618387 :foo)))))
+
+(with-test (:name :pcl-spurious-ignore-warnings)
+ (defgeneric no-spurious-ignore-warnings (req &key key))
+ (handler-bind ((warning (lambda (x) (error "~A" x))))
+ (eval
+ '(defmethod no-spurious-ignore-warnings ((req number) &key key)
+ (declare (ignore key))
+ (check-type req integer))))
+ (defgeneric should-get-an-ignore-warning (req &key key))
+ (let ((warnings 0))
+ (handler-bind ((warning (lambda (c) (setq warnings 1) (muffle-warning c))))
+ (eval '(defmethod should-get-an-ignore-warning ((req integer) &key key)
+ (check-type req integer))))
+ (assert (= warnings 1))))
+
+(defgeneric generic-function-pretty-arglist-optional-and-key (req &optional opt &key key)
+ (:method (req &optional opt &key key)
+ (list req opt key)))
+
+(with-test (:name :generic-function-pretty-arglist-optional-and-key)
+ (handler-bind ((warning #'error))
+ ;; Used to signal a style-warning
+ (assert (equal '(req &optional opt &key key)
+ (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))))
+
+;;; 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)))
+
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (require 'sb-cltl2)
+ (defmethod b ()))
+
+(defmacro macro ()
+ (let ((a 20))
+ (declare (special a))
+ (assert
+ (=
+ (funcall
+ (compile nil
+ (sb-mop:make-method-lambda
+ #'b
+ (find-method #'b () ())
+ '(lambda () (declare (special a)) a)
+ nil))
+ '(1) ())
+ 20))))
+
+(with-test (:name :make-method-lambda-leakage)
+ ;; lambda list of X leaks into the invocation of make-method-lambda
+ ;; during code-walking performed by make-method-lambda invoked by
+ ;; DEFMETHOD
+ (sb-cltl2:macroexpand-all '(defmethod x (a) (macro))))
+
+(with-test (:name (:defmethod-undefined-function :bug-503095))
+ (flet ((test-load (file)
+ (let (implicit-gf-warning)
+ (handler-bind
+ ((sb-ext:implicit-generic-function-warning
+ (lambda (x)
+ (setf implicit-gf-warning x)
+ (muffle-warning x)))
+ ((or warning error) #'error))
+ (load file))
+ (assert implicit-gf-warning))))
+ (multiple-value-bind (fasl warnings errorsp) (compile-file "bug-503095.lisp")
+ (unwind-protect
+ (progn (assert (and fasl (not warnings) (not errorsp)))
+ (test-load fasl))
+ (and fasl (delete-file fasl))))
+ (test-load "bug-503095-2.lisp")))
+
;;;; success
projects / sbcl.git / blobdiff