Skip to content
Snippets Groups Projects
Forked from cmucl / cmucl
2144 commits behind the upstream repository.
pcl.lisp 50.48 KiB

(defpackage "PCL-TESTS"
  (:use "COMMON-LISP" "PCL" "LISP-UNIT"))

(in-package "PCL-TESTS")

(defmacro deftest (name form &rest values)
  (let ((results (gensym "RESULTS-")))
    `(define-test ,name
	 (:tag :pcl)
	 (let ((,results (multiple-value-list ,form)))
	   (assert-equalp ,results
			  ',values)))))

(defmacro define-compiled-test (name form &rest values)
  `(progn
     (defun ,name () ,form)
     (deftest ,name (,name) ,@values)))

;; ctor.lisp
(deftest plist-keys.0
    (pcl::plist-keys '())
  nil)

(deftest plist-keys.1
    (pcl::plist-keys '(:a 1 :b 2))
  (:a :b))

(deftest plist-keys.2
    (multiple-value-bind (result condition)
	(ignore-errors (pcl::plist-keys '(:a)))
      (values result (typep condition 'condition)))
  nil
  t)
      
(deftest make-instance->constructor-call.0
    (pcl::make-instance->constructor-call '(make-instance 'foo a x))
  nil)

(deftest make-instance->constructor-call.1
    (pcl::make-instance->constructor-call '(make-instance foo :a x))
  nil)

(deftest make-instance->constructor-call.2
    (pcl::make-instance->constructor-call '(make-instance 'foo x))
  nil)

(deftest make-instance->constructor-call.4
    (pcl::make-instance->constructor-call '(make-instance 1))
  nil)

(deftest make-instance->constructor-call.5
    (let* ((form (pcl::make-instance->constructor-call
		  '(make-instance 'foo)))
	   (call (car (last form))))
      (values (eq (first call) 'funcall)
	      (cddr call)))
  t ())

(deftest make-instance->constructor-call.6
    (let* ((form (pcl::make-instance->constructor-call
		  '(make-instance 'foo :x 1 :y 2)))
	   (call (car (last form))))
      (values (eq (first call) 'funcall)
	      (cddr call)))
  t ())

(deftest make-instance->constructor-call.7
    (let* ((form (pcl::make-instance->constructor-call
		  '(make-instance 'foo :x x :y 2)))
	   (call (car (last form))))
      (values (eq (first call) 'funcall)
	      (cddr call)))
  t (x))

(deftest make-instance->constructor-call.8
    (let* ((form (pcl::make-instance->constructor-call
		  '(make-instance 'foo :x x :y y)))
	   (call (car (last form))))
      (values (eq (first call) 'funcall)
	      (cddr call)))
  t (x y))

(deftest make-instance->constructor-call.9
    (let* ((form (pcl::make-instance->constructor-call
		  '(make-instance 'foo :x x :y 1)))
	   (call (car (last form))))
      (values (eq (first call) 'funcall)
	      (cddr call)))
  t (x))

(deftest make-instance->constructor-call.10
    (let* ((form (pcl::make-instance->constructor-call
		  '(make-instance 'foo :x x :y 1 :z z)))
	   (call (car (last form))))
      (values (eq (first call) 'funcall)
	      (cddr call)))
  t (x z))

(deftest make-ctor.0
    (let ((ctor (pcl::make-ctor '(pcl::ctor bar) 'bar '(:x 1 :y 2))))
      (values (pcl::ctor-function-name ctor)
	      (pcl::ctor-class-name ctor)
	      (pcl::ctor-initargs ctor)))
  (pcl::ctor bar)
  bar
  (:x 1 :y 2))

(defclass foo ()
  ((a :initarg :a :initform 1)
   (b :initarg :b :initform 2)))

(defun call-generator (generator function-name class-name args)
  (declare (ignore function-name))
  (let* ((ctor
	   (pcl::make-ctor (list 'pcl::ctor class-name) class-name args))
	 (class (find-class class-name))
	 (proto (pcl::class-prototype class))
	 (ii (pcl::compute-applicable-methods
	      #'initialize-instance (list proto)))
	 (si (pcl::compute-applicable-methods
	      #'shared-initialize (list proto t))))
    (setf (pcl::ctor-class ctor) class)
    (if (eq generator #'pcl::fallback-generator)
	(funcall generator ctor)
	(funcall generator ctor ii si))))
     
(deftest fallback-generator.0
    (let ((fn (call-generator #'pcl::fallback-generator
			      'make-foo 'foo '(:a 0 :b 1))))
      (values (second fn)
	      (type-of (second (third fn)))
	      (nthcdr 2 (third fn))))
  ()
  pcl::standard-class
  (:a 0 :b 1))

(deftest fallback-generator.1
    (let ((fn (call-generator #'pcl::fallback-generator
			      'make-foo 'foo '(:a 0))))
      (values (second fn)
	      (first (third fn))
	      (type-of (second (third fn)))
	      (nthcdr 2 (third fn))))
  ()
  make-instance
  pcl::standard-class
  (:a 0))

(deftest fallback-generator.2
    (let ((fn (call-generator #'pcl::fallback-generator
			      'make-foo 'foo '())))
      (values (second fn)
	      (type-of (second (third fn)))
	      (nthcdr 2 (third fn))))
  ()
  pcl::standard-class
  ())

(deftest fallback-generator.3
    (let ((fn (call-generator #'pcl::fallback-generator
			      'make-foo 'foo '(:a .p0.))))
      (values (second fn)
	      (type-of (second (third fn)))
	      (nthcdr 2 (third fn))))
  (.p0.)
  pcl::standard-class
  (:a .p0.))

(deftest fallback-generator.4
    (let ((fn (call-generator #'pcl::fallback-generator
			      'make-foo 'foo '(:a a :b b))))
      (values (second fn)
	      (type-of (second (third fn)))
	      (nthcdr 2 (third fn))))
  (a b)
  pcl::standard-class
  (:a a :b b))

;;; These depend on the actual slot definition location computation,
;;; which may be different in my PCL than in the CVS PCL.

(deftest compute-initarg-locations.0
    (let ((class (find-class 'foo)))
      (pcl::compute-initarg-locations class '(:a :b)))
  ((:a (0 . t)) (:b (1 . t))))

(defclass foo2 (foo)
  ((c :initarg :a)))

(deftest compute-initarg-locations.1
    (let ((class (find-class 'foo2)))
      (pcl::compute-initarg-locations class '(:a :b)))
  ((:a (0 . t) (2 . t)) (:b (1 . t))))

(defclass foo3 (foo)
  ((c :initarg :a :allocation :class)))

;;;
;;; This test must be compiled for the case that PCL::+SLOT-UNBOUND+
;;; is a symbol macro calling PCL::MAKE-UNBOUND-MARKER, otherwise
;;; we'll get a complaint that C::%%PRIMITIVE is not defined.
;;;
(define-compiled-test compute-initarg-locations.2
    (let ((class (find-class 'foo3)))
      (subst 'unbound pcl::+slot-unbound+
	     (pcl::compute-initarg-locations class '(:a :b))))
  ((:a (0 . t) ((c . unbound) . t)) (:b (1 . t))))

(defclass foo4 ()
  ((a :initarg :a :initarg :both)
   (b :initarg :b :initarg :both)))

(deftest compute-initarg-locations.3
    (let ((class (find-class 'foo4)))
      (pcl::compute-initarg-locations class '(:both :a :b)))
  ((:both (0 . t) (1 . t)) (:a) (:b)))

(deftest compute-initarg-locations.4
    (let ((class (find-class 'foo4)))
      (pcl::compute-initarg-locations class '(:a :both)))
  ((:a (0 . t)) (:both (1 . t))))

(deftest slot-init-forms.0
    (let ((ctor (pcl::make-ctor
		 (list 'pcl::ctor 'make-foo)
		 'foo '(:a a :b b))))
      (setf (pcl::ctor-class ctor) (find-class 'foo))
      (pcl::slot-init-forms ctor nil))
  (let ()
      (declare (ignorable) (optimize (safety 3)))
      (setf (svref pcl::.slots. 0) (the t a))
      (setf (svref pcl::.slots. 1) (the t b)))
   nil)

(deftest slot-init-forms.1
    (let ((ctor (pcl::make-ctor
		 (list 'pcl::ctor 'make-foo)
		 'foo '(:a a))))
      (setf (pcl::ctor-class ctor) (find-class 'foo))
      (pcl::slot-init-forms ctor nil))
  (let ()
    (declare (ignorable) (optimize (safety 3)))
    (setf (svref pcl::.slots. 0) (the t a))
    (setf (svref pcl::.slots. 1) (the t '2)))
  nil)

(defclass foo5 ()
  ((a :initarg :a :initform 0)
   (b :initarg :b)))

(deftest slot-init-forms.2
    (let ((ctor (pcl::make-ctor
		 (list 'pcl::ctor 'make-foo)
		 'foo5 '(:a a))))
      (setf (pcl::ctor-class ctor) (find-class 'foo5))
      (pcl::slot-init-forms ctor nil))
  (let ()
    (declare (ignorable) (optimize (safety 3)))
    (setf (svref pcl::.slots. 0) (the t a))
    (setf (svref pcl::.slots. 1) pcl::+slot-unbound+))
  nil)

(defclass foo5a ()
  ((a :initarg :a :initform 0)
   (b :initarg :b :initform 0)))

(deftest slot-init-forms.2a
    (let ((ctor (pcl::make-ctor
		 (list 'pcl::ctor 'make-foo)
		 'foo5a '())))
      (setf (pcl::ctor-class ctor) (find-class 'foo5a))
      (pcl::slot-init-forms ctor nil))
  (let ()
    (declare (ignorable) (optimize (safety 3)))
    (setf (svref pcl::.slots. 0) (the t '0))
    (setf (svref pcl::.slots. 1) (the t '0)))
  nil)

(defclass foo6 ()
  ((a :initarg :a :initform 0 :allocation :class)
   (b :initarg :b)))

(deftest slot-init-forms.3
    (let ((ctor (pcl::make-ctor
		 (list 'pcl::ctor 'make-foo)
		 'foo6 '(:a a))))
      (setf (pcl::ctor-class ctor) (find-class 'foo6))
      (pcl::slot-init-forms ctor nil))
  (let ()
    (declare (ignorable) (optimize (safety 3)))
    (setf (svref pcl::.slots. 0) pcl::+slot-unbound+)
    (setf (cdr '(a . 0)) (the t a)))
  nil)

(defun foo ()
  (error "should never be called"))

(defclass foo7 ()
  ((a :initarg :a :initform (foo))
   (b :initarg :b)))

(deftest slot-init-forms.4
    (let* ((ctor (pcl::make-ctor
		 (list 'pcl::ctor 'make-foo)
		 'foo7 '())))
      (setf (pcl::ctor-class ctor) (find-class 'foo7))
      (let ((form (pcl::slot-init-forms ctor nil)))
	(destructuring-bind (let vars declare setf1 setf2) form
	  (declare (ignore let vars declare))
	  (values setf2 (second setf1) (first (third (third setf1)))
		  (functionp (second (third (third setf1))))))))
  (setf (svref pcl::.slots. 1) pcl::+slot-unbound+)
  (svref pcl::.slots. 0)
  funcall
  t)

(deftest slot-init-forms.5
    (let ((ctor (pcl::make-ctor
		 (list 'pcl::ctor 'make-foo)
		 'foo '(:a '(foo)))))
      (setf (pcl::ctor-class ctor) (find-class 'foo))
      (pcl::slot-init-forms ctor nil))
  (let ()
    (declare (ignorable) (optimize (safety 3)))
    (setf (svref pcl::.slots. 0) (the t '(foo)))
    (setf (svref pcl::.slots. 1) (the t '2)))
  nil)

(deftest slot-init-forms.6
    (let ((ctor (pcl::make-ctor
		 (list 'pcl::ctor 'make-foo)
		 'foo '(:a 'x))))
      (setf (pcl::ctor-class ctor) (find-class 'foo))
      (pcl::slot-init-forms ctor nil))
  (let ()
    (declare (ignorable) (optimize (safety 3)))
    (setf (svref pcl::.slots. 0) (the t 'x))
    (setf (svref pcl::.slots. 1) (the t '2)))
  nil)

(defmethod bar1 ((x integer))
  (* x 2))

(defmethod bar2 ((x integer)) x)
(defmethod bar2 :around ((x integer)) x)

(deftest around-or-nonstandard-primary-method-p.0
    (pcl::around-or-nonstandard-primary-method-p
     (pcl::compute-applicable-methods #'bar2 (list 1)))
  t)

(defmethod bar3 ((x integer)) x)
(defmethod bar3 :after ((x integer)) x)

(deftest around-or-nonstandard-primary-method-p.1
    (pcl::around-or-nonstandard-primary-method-p
     (pcl::compute-applicable-methods #'bar3 (list 1)))
  nil)

(deftest optimizing-generator.0
    (let ((fn (call-generator #'pcl::optimizing-generator
			      'make-foo 'foo '(:a 0 :b 1))))
      (second fn))
  ())

(defun construct (class-name initargs &rest args)
  (let* ((form (call-generator #'pcl::optimizing-generator
			       'some-function-name
			       class-name
			       initargs))
	 (fn (pcl::compile-lambda form)))
    (apply fn args)))

(deftest optimizing-generator.1
    (with-slots (a b) (construct 'foo '(:a 0 :b 1))
      (values a b))
  0 1)

(deftest optimizing-generator.2
    (with-slots (a b) (construct 'foo '())
      (values a b))
  1 2)

(defclass g1 ()
  ((a :initform 0)
   (b)))

(deftest optimizing-generator.3
    (let ((instance (construct 'g1 '())))
      (values (slot-value instance 'a)
	      (slot-boundp instance 'b)))
  0 nil)

;; Test for default-initargs bug.
(defclass g2 ()
  ((a :initarg :aa)))

(defmethod initialize-instance :after ((f g2) &key aa)
  (princ aa))

(defclass g3 (g2)
  ((b :initarg :b))
  (:default-initargs :aa 5))

(deftest defaulting-initargs.1
    (with-output-to-string (*standard-output*)
      (make-instance 'g3))
  "5")

;; defclass.lisp
(deftest defclass-subtypep.0
    (progn
      (defclass st0 () ())
      (defclass st1 () ())
      (subtypep 'st1 'st0))
  nil t)

(deftest defclass-subtypep.1
    (progn
      (defclass st1 (st0) ())
      (subtypep 'st1 'st0))
  t t)

(deftest defclass-subtypep.2
    (progn
      (defclass st1 () ())
      (subtypep 'st1 'st0))
  nil t)
     
(defvar *instance* nil)
(defvar *update-instance-result* nil)

(defclass st2 ()
  ((a :initform 0 :accessor a)))

(defclass st3 ()
  ((b :initform 0 :accessor b)))

(deftest update-instance-for-redefined-class.0
    (progn
      (setq *instance* (make-instance 'st3))
      t)
  t)

(defmethod update-instance-for-redefined-class :after
    ((instance st3) added-slots discarded-slots property-list &rest initargs)
  (setq *update-instance-result*
	(list instance added-slots discarded-slots property-list initargs)))

(deftest update-instance-for-redefined-class.1
    (progn
      (defclass st3 (st2)
	((b :initform 0 :accessor b)))
      (values (slot-value *instance* 'b)
	      (eq *instance* (first *update-instance-result*))
	      (rest *update-instance-result*)))
  0 t ((a) nil nil nil))

(deftest update-instance-for-redefined-class.2
    (progn
      (defclass st3 ()
	((b :initform 0 :accessor b)))
      (values (slot-value *instance* 'b)
	      (eq *instance* (first *update-instance-result*))
	      (rest *update-instance-result*)))
  0 t (nil (a) (a 0) nil))

(deftest defclass-sxhash.0
    (let ((i1 (make-instance 'st2))
	  (i2 (make-instance 'st2)))
      (/= (sxhash i1) (sxhash i2)))
  t)

(deftest generic-function-sxhash.0
    (/= (sxhash #'allocate-instance)
	(sxhash #'make-instance))
  t)

(deftest defclass-redefinition.0
    (multiple-value-bind (r c)
	(ignore-errors
	  (defclass rd0 () ())
	  (defclass rd1 (rd0) ())
	  (defclass rd2 () ())
	  (defclass rd0 (rd2) ())
	  (make-instance 'rd1))
      (values (not (null r)) (null c)))
  t t)
;;; This failed to compile in an old version, that's why it's here.

(deftest defclass-inherited-class-slots.0
    (multiple-value-bind (r c)
	(ignore-errors
	  (defclass ics0 ()
	    ((a :allocation :class :accessor ics0-a)))
	  (defclass ics1 (ics0)
	    ())
	  (make-instance 'ics1))
      (values (not (null r)) (null c)))
  t t)

(defmacro define-defclass-syntax-test (name class-body &rest options)
  `(deftest ,name
       (multiple-value-bind (r c)
	   (ignore-errors
	     (defclass dc0 ()
	       ,class-body ,@options))
	 (declare (ignore r))
	 (typep c 'error))
     t))

;; CLHS: allocation should be :class or :instance
(define-defclass-syntax-test defclass.0 ((a :allocation :foo)))

;; Reader names should be symbols.
(define-defclass-syntax-test defclass.1 ((a :reader (setf a))))

;;; initarg names must be symbols.
(define-defclass-syntax-test defclass.2 ((a :initarg 1)))

;; Duplicate :default-initargs is an error.
(define-defclass-syntax-test defclass.3 ()
  (:default-initargs :a 1)
  (:default-initargs :b 2))

;; Duplicate :metaclass.
(define-defclass-syntax-test defclass.4 ()
  (:metaclass pcl::funcallable-standard-class)
  (:metaclass 1))

;; class option that is not implemented locally -> error
(define-defclass-syntax-test defclass.5 ()
  (:foo t))

(deftest defclass-structure-class.0
  (multiple-value-bind (r c)
      (ignore-errors
	(defclass dscl.0 ()
	  (a b)
	  (:metaclass pcl::structure-class))
	t)
    (values r (null c)))
  t t)

(deftest defclass-structure-class.1
  (multiple-value-bind (r c)
      (ignore-errors
	(make-instance 'dscl.0)
	t)
    (values r (null c)))
  t t)

;;;
;;; The change of DFR1 from forward-referenced to standard class
;;; caused problems at some point, which were fixed by passing
;;; initargs to CHANGE-CLASS in ENSURE-CLASS-USING-CLASS.
;;;
(deftest defclass-forward-referenced-class.0
    (multiple-value-bind (r c)
	(ignore-errors
	  (defclass dfr0 (dfr1 dfr2) ())
	  (defclass dfr1 (dfr3 dfr4) ())
	  t)
      (values r (null c)))
  t t)

(deftest defclass-forward-referenced-class.1
    (multiple-value-bind (r c)
	(ignore-errors
	  (defclass dfr.c1 (dfr.c2) ())
	  (defclass dfr.c2 (dfr.c3) ())
	  (defclass dfr.c3 () ())
	  (make-instance 'dfr.c1)
	  t)
      (values r (null c)))
  t t)

;;;
;;; TYPEP and SUBTYPEP used to fail with forward-referenced/unfinalized
;;; classes.
;;;
(deftest defclass-types.0
    (multiple-value-bind (r c)
	(ignore-errors
	  (defclass dfr5 (dfr6) ())
	  (typep t (find-class 'dfr6)))
      (values r (null c)))
  nil t)

(deftest defclass-types.2
    (multiple-value-bind (r c)
	(ignore-errors
	  (defclass dfr7 (dfr8) ())
	  (multiple-value-list
	   (subtypep (find-class 'dfr7) (find-class 'dfr8))))
      (values r (null c)))
  (t t) t)

(deftest defclass-types.3
    (multiple-value-bind (r c)
	(ignore-errors
	  (defclass dfr7 (dfr8) ())
	  (multiple-value-list
	   (subtypep (find-class 'dfr8) (find-class 'dfr7))))
      (values r (null c)))
  (nil t) t)

(deftest defclass-types.4
    (multiple-value-bind (r c)
	(ignore-errors
	  (defclass dfr9 (dfr10) ())
	  (defclass dfr11 (dfr9 dfr12) ())
	  (append
	   (multiple-value-list
	    (subtypep (find-class 'dfr9) (find-class 'dfr10)))
	   (multiple-value-list
	    (subtypep (find-class 'dfr11) (find-class 'dfr10)))
	   (multiple-value-list
	    (subtypep (find-class 'dfr11) (find-class 'dfr9)))
	   (multiple-value-list
	    (subtypep (find-class 'dfr11) (find-class 'dfr12)))))
      (values r (null c)))
  (t t t t t t t t) t)

(deftest defclass-types.5
    (multiple-value-bind (r c)
	(ignore-errors
	  (defclass dfr13 () ())
	  (defclass dfr14 (dfr15 dfr13) ())
	  (defclass dfr16 (dfr14 dfr17) ())
	  (append
	   (multiple-value-list
	    (subtypep (find-class 'dfr16) (find-class 'dfr14)))
	   (multiple-value-list
	    (subtypep (find-class 'dfr16) (find-class 'dfr17)))
	   (multiple-value-list
	    (subtypep (find-class 'dfr16) (find-class 'dfr15)))
	   (multiple-value-list
	    (subtypep (find-class 'dfr16) (find-class 'dfr13)))))
      (values r (null c)))
  (t t t t t t t t) t)

(deftest defclass-types.6
    (multiple-value-bind (r c)
	(ignore-errors
	  (defclass dfr20 (dfr21) ())
	  (defclass dfr21 (dfr22) ())
	  (append 
	   (multiple-value-list
	    (subtypep (find-class 'dfr20) (find-class 'dfr21)))
	   (multiple-value-list
	    (subtypep (find-class 'dfr21) (find-class 'dfr22)))
	   (multiple-value-list
	    (subtypep (find-class 'dfr20) (find-class 'dfr22)))))
      (values r (null c)))
  (t t t t t t) t)

;; defmethod.lisp
(defmethod dm0 (x)
  x)

(defmethod dm1 (x &rest y)
  (list x y))

(defmethod dm2 (x &optional y)
  (list x y))

(defmacro define-defmethod-test (name method qual lambda-list
				 &rest values)
  `(deftest ,name
     (multiple-value-bind (r c)
	 (ignore-errors
	   (defmethod ,method ,@(when qual `(,qual)) ,lambda-list
	     #+cmu (declare (optimize (ext:inhibit-warnings 3)))
	     nil))
       (values (typep r 'method)
	       (typep c 'error)
	       (length (pcl:generic-function-methods #',method))))
     ,@values))

(defmacro define-defmethod-test-1 (name method qual lambda-list)
  `(define-defmethod-test ,name ,method ,qual ,lambda-list nil t 1))

(define-defmethod-test-1 defmethod.0 dm0 nil (x y))
(define-defmethod-test-1 defmethod.1 dm0 nil (x &rest y))
(define-defmethod-test-1 defmethod.2 dm0 nil (x &key y))
(define-defmethod-test-1 defmethod.4 dm0 :before (x y))
(define-defmethod-test-1 defmethod.5 dm0 :before (x &rest y))
(define-defmethod-test-1 defmethod.6 dm0 :before (x &key y))
(define-defmethod-test defmethod.7 dm0 nil (x) t nil 1)
    
(define-defmethod-test-1 defmethod.10 dm1 nil (x y))
(define-defmethod-test-1 defmethod.11 dm1 nil (x))
(define-defmethod-test defmethod.12 dm1 nil (x &key y) t nil 1)
(define-defmethod-test defmethod.13 dm1 nil (x &key y z) t nil 1)
(define-defmethod-test defmethod.14 dm1 nil (x &rest y) t nil 1)

(define-defmethod-test-1 defmethod.20 dm2 nil (x))
(define-defmethod-test-1 defmethod.21 dm2 nil (x &optional y z))
(define-defmethod-test-1 defmethod.22 dm2 nil (x &key y))

;;;
;;; A forward-referenced class used as specializer signaled an
;;; error at some point.
;;;
(deftest defmethod-forwared-referenced.0
    (multiple-value-bind (r c)
	(ignore-errors
	  (defclass dm.3 () ())
	  (defclass dm.4 (dm.forward) ())
	  (defmethod dm.5 ((x dm.3)) x)
	  (defmethod dm.5 ((x dm.4)) x)
	  t)
      (values r (null c)))
  t t)
      
(deftest defmethod-forwared-referenced.1
    (multiple-value-bind (r c)
	(ignore-errors
	  (defclass dm.3 () ())
	  (defclass dm.4 (dm.forward) ())
	  (defmethod dm.5 ((x dm.3)) x)
	  (defmethod dm.5 ((x dm.4)) x)
	  (dm.5 (make-instance 'dm.3))
	  t)
      (values r (null c)))
  t t)

(deftest defmethod-metacircle.0
    (multiple-value-bind (r c)
	(ignore-errors
	  (defclass dmm.0 () ())
	  (defclass dmm.1 () ())
	  (defclass dmm.0+1 (dmm.0 dmm.1) ())
	  (defmethod dmm.0 ((x dmm.0) (y dmm.1)) 1)
	  (defmethod dmm.0 ((x dmm.1) (y dmm.0)) 2)
	  (dmm.0 (make-instance 'dmm.0+1) (make-instance 'dmm.0+1))
	  (defmethod dmm.0 ((x dmm.0+1) (y dmm.0+1)) 3)
	  (dmm.0 (make-instance 'dmm.0+1) (make-instance 'dmm.0+1)))
      (values r (null c)))
  3 t)

(deftest defmethod-setf-fdefinition.0
    (multiple-value-bind (r c)
	(ignore-errors
	  (defgeneric dsf.0 (x))
	  (defmethod dsf.0 ((x integer)) x)
	  (setf (fdefinition 'dsf.1) #'dsf.0)
	  (defmethod dsf.1 ((x string)) x)
	  (list (length (mop:generic-function-methods #'dsf.0))
		(equal (mop:generic-function-methods #'dsf.1)
		       (mop:generic-function-methods #'dsf.0))))
      (values r (null c)))
  (2 t) t)

(deftest defmethod-setf-fdefinition.1
    (multiple-value-bind (r c)
	(ignore-errors
	  (defgeneric dsf.2 (x))
	  (defmethod dsf.2 ((x integer)) x)
	  (setf (fdefinition 'dsf.3) #'dsf.2)
	  (defmethod dsf.3 ((x integer)) x)
	  (list (length (mop:generic-function-methods #'dsf.2))
		(equal (mop:generic-function-methods #'dsf.3)
		       (mop:generic-function-methods #'dsf.2))))
      (values r (null c)))
  (1 t) t)

;; find-method.lisp
(defmethod fm0 (x y)
  (list x y))

(deftest find-method.0
    (multiple-value-bind (r c)
	(ignore-errors
	  (find-method #'fm0 nil (list t)))
      (values r (typep c 'error)))
  nil t)

(deftest find-method.1
    (multiple-value-bind (r c)
	(ignore-errors
	  (find-method #'fm0 nil (list t t)))
      (values (typep r 'method) (typep c 'error)))
  t nil)


;; inline-access.lisp
(defun test-walk (form test-function &optional env)
  (let ((result nil))
    (flet ((walk-function (form context env)
	     (declare (ignore context))
	     (when (and (consp form) (eq (car form) 'test))
	       (push (funcall test-function env) result))
	     form))
      (walker:walk-form form env #'walk-function)
      (nreverse result))))

(defmacro define-declaration-test (name declaration test &key values)
  `(deftest ,name
       (test-walk '(defun dummy () ,declaration (test))
		  (lambda (env) ,test))
     ,@values))

(define-declaration-test slot-declaration.0
    (declare (ext:slots (slot-boundp xx)))
  (pcl::slot-declaration env 'slot-boundp 'xx)
  :values ((t)))

(define-declaration-test slot-declaration.1
    (declare (ext:slots (inline xx)))
  (pcl::slot-declaration env 'inline 'xx)
  :values ((t)))

(define-declaration-test slot-declaration.2
    (declare (ext:slots (inline (xx))))
  (pcl::slot-declaration env 'inline 'xx)
  :values ((t)))

(define-declaration-test slot-declaration.3
    (declare (ext:slots (inline (xx a))))
  (pcl::slot-declaration env 'inline 'xx 'a)
  :values ((t)))

(define-declaration-test slot-declaration.4
    (declare (ext:slots (inline (xx a))))
  (pcl::slot-declaration env 'inline 'xx 'b)
  :values ((nil)))

(define-declaration-test slot-declaration.5
    (declare (ext:slots (inline (xx a) yy)))
  (pcl::slot-declaration env 'inline 'yy)
  :values ((t)))

(define-declaration-test slot-declaration.6
    (declare (ext:slots (inline (xx a) (yy a))))
  (pcl::slot-declaration env 'inline 'yy 'a)
  :values ((t)))

(define-declaration-test slot-declaration.7
    (declare (ext:slots (inline (xx a) (yy a))))
  (pcl::slot-declaration env 'inline 'yy 'b)
  :values ((nil)))

(deftest global-slot-declaration.0
    (progn
      (proclaim '(ext:slots (slot-boundp gsd)))
      (not (null (pcl::slot-declaration nil 'slot-boundp 'gsd))))
  t)

(deftest global-slot-declaration.1
    (progn
      (proclaim '(ext:slots (inline (gsd gsd-a))))
      (not (null (pcl::slot-declaration nil 'inline 'gsd 'gsd-a))))
  t)

(deftest auto-compile-declaration.0
    (progn
      (proclaim '(ext:auto-compile acd))
      (pcl::auto-compile-p 'acd nil nil))
  t)

(deftest auto-compile-declaration.1
    (progn
      (proclaim '(ext:auto-compile acd))
      (pcl::auto-compile-p 'acd '(:around) '(t t)))
  t)

(deftest auto-compile-declaration.2
    (progn
      (proclaim '(ext:not-auto-compile acd))
      (proclaim '(ext:auto-compile (acd :around (t t))))
      (values (pcl::auto-compile-p 'acd nil nil)
	      (pcl::auto-compile-p 'acd nil '(t t))
	      (pcl::auto-compile-p 'acd '(:around) '(t t))))
  nil nil t)

(deftest auto-compile-declaration.3
    (progn
      (proclaim '(ext:auto-compile acd))
      (proclaim '(ext:not-auto-compile (acd :around (t t))))
      (values (pcl::auto-compile-p 'acd nil nil)
	      (pcl::auto-compile-p 'acd nil '(t t))
	      (pcl::auto-compile-p 'acd '(:around) '(t t))))
  t t nil)

(deftest auto-compile-declaration.4
    (progn
      (proclaim '(ext:auto-compile))
      (proclaim '(ext:not-auto-compile acd))
      (values (pcl::auto-compile-p 'foo nil nil)
	      (pcl::auto-compile-p 'acd nil '(t t))
	      (pcl::auto-compile-p 'acd '(:around) '(t t))))
  t nil nil)

(deftest auto-compile-declaration.5
    (progn
      (proclaim '(ext:auto-compile (setf acd)))
      (pcl::auto-compile-p '(setf acd) '(:around) '(t t)))
  t)


(declaim (ext:slots (inline sacc.0)))

(defclass sacc.0 ()
  ((a :initform 0 :initarg :a :accessor sacc.0-a)))

(defclass sacc.1 (sacc.0)
  ((b :initform 0 :initarg :b :accessor sacc.1-b)
   (a :initform 0 :initarg :a :accessor sacc.0-a)))

(defmethod sacc.0.0 ((x sacc.0))
  (slot-value x 'a))

(defmethod sacc.0.1 ((x sacc.0))
  (sacc.0-a x))

(defmethod sacc.0.2 ((x sacc.0) nv)
  (setf (slot-value x 'a) nv))

(defmethod sacc.0.3 ((x sacc.0) nv)
  (setf (sacc.0-a x) nv))

(defun method-using-inline-access-p (class-name method-name qualifiers
				     specializers)
  (let ((method (find-method (fdefinition method-name) qualifiers
			     specializers)))
    (car (member class-name (pcl::plist-value method 'pcl::inline-access)
		 :test #'eq))))

(deftest inline-access-p.0
    (and (method-using-inline-access-p 'sacc.0 'sacc.0.0 nil '(sacc.0))
	 (method-using-inline-access-p 'sacc.0 'sacc.0.1 nil '(sacc.0))
	 (method-using-inline-access-p 'sacc.0 'sacc.0.2 nil '(sacc.0 t))
	 (method-using-inline-access-p 'sacc.0 'sacc.0.3 nil '(sacc.0 t)))
  sacc.0)

(deftest inline-access-p.1
    (let ((methods (pcl::methods-using-inline-slot-access
		    (pcl::find-class 'sacc.0))))
      (length methods))
  4)

(deftest inline-access.0
    (sacc.0.0 (make-instance 'sacc.0))
  0)

(deftest inline-access.1
    (let ((instance (make-instance 'sacc.0 :a 11)))
      (values (sacc.0.0 instance)
	      (sacc.0.1 instance)))
  11 11)

(deftest inline-access.2
    (let ((instance (make-instance 'sacc.0 :a 11)))
      (sacc.0.2 instance 10)
      (slot-value instance 'a))
  10)

(deftest inline-access.3
    (let ((instance (make-instance 'sacc.0 :a 11)))
      (sacc.0.3 instance 10)
      (slot-value instance 'a))
  10)

(defmacro define-warning-test (name (value) &body body)
  `(deftest ,name
       (let (warning)
	 (flet ((note-warning (c)
		  (declare (ignore c))
		  (setq warning t)
		  (muffle-warning)))
	   (handler-bind ((warning #'note-warning))
	     ,@body)
	   warning))
     ,value))

(define-warning-test warn.0 (t) (warn "Test the test"))  
(define-warning-test warn.1 (nil) nil)

(define-warning-test inline-warn.0 (nil)
  (defclass sacc.0 ()
    ((a :initform 0 :initarg :a :accessor sacc.0-a))))

(define-warning-test inline-warn.1 (t)
  (defclass sacc.0 ()
    ((a :initform 0 :initarg :a :accessor sacc.0-a)
     (b :initform 0))))

(define-warning-test inline-warn.2 (t)
  (progn
    (defmethod inline-warn.2.method ((x sacc.1))
      (declare (pcl::slots (inline sacc.1)))
      (slot-value x 'b))
    (defclass sacc.0 ()
      ((a :initform 0 :initarg :a :accessor sacc.0-a)))))
      

;; make-instance.lisp
;;; *********************
;;; MAKE-INSTANCE  ******
;;; *********************

;;; Test forms in DEFTEST are not compiled, that is, a compiler
;;; macro won't be used in them.  Also, we want tests using
;;; both the optimized constructor functions, and the default.

(eval-when (:top-level :compile :execute)
(defmacro define-mi-test (name form &key values opt-values)
  (let ((optimized-name
	 (let ((*print-case* :upcase)
	       (*print-pretty* nil)
	       (*print-gensym* t))
	   (intern (format nil "~S.OPT" name))))
	(optimized-values (or opt-values values)))
    `(progn
       (defun ,name ()
	 (macrolet ((mi (&rest args)
		      `(funcall #'make-instance ,@args)))
	   ,form))
       (defun ,optimized-name ()
	 (macrolet ((mi (&rest args)
		      `(make-instance ,@args)))
	   ,form))
       (deftest ,name (,name) ,@values)
       (deftest ,optimized-name (,optimized-name)
	 ,@optimized-values))))
)
    

(defclass m1 ()
  ((a :initarg :a :initarg :both :initform 1)
   (b :initarg :b :initarg :both :initform 2)))

(define-mi-test make-instance.0
    (with-slots (a b) (mi 'm1)
      (values a b))
  :values (1 2))
    
(define-mi-test make-instance.1
    (with-slots (a b) (mi 'm1 :a 3)
      (values a b))
  :values (3 2))
    
(define-mi-test make-instance.2
    (with-slots (a b) (mi 'm1 :b 3)
      (values a b))
  :values (1 3))

(define-mi-test make-instance.3
    (with-slots (a b) (mi 'm1 :b 3 :a 4)
      (values a b))
  :values (4 3))
    
(define-mi-test make-instance.4
    (with-slots (a b) (mi 'm1 :both (list nil))
      (eq a b))
  :values (t))

(defclass m2 (m1)
  ((a :initarg :a :initform 3)))

;;; Overriding slot in subclass -> new initform should be used.

(define-mi-test make-instance.5
    (with-slots (a b) (mi 'm2)
      (values a b))
  :values (3 2))

;;; :BOTH should be inherited by slot A.

(define-mi-test make-instance.6
    (with-slots (a b) (mi 'm2 :both 11)
      (values a b))
  :values (11 11))

(defclass m3 (m2)
  ((a :allocation :class :initform nil)))

;;; Class slot should not be overwritten when there's no initarg for it.
;;; Note that slot A overrides an instance slot A in M2 which itself
;;; overrides an instance slot in M1.

(define-mi-test make-instance.7
    (progn
      (setf (slot-value (pcl:class-prototype (pcl:find-class 'm3)) 'a) 1)
      (with-slots (a b) (mi 'm3)
	(values a b)))
  :values (1 2))

;;; Class slot should be written when there is an initarg for it.

(define-mi-test make-instance.8
    (with-slots (a) (mi 'm3 :a 11)
      a)
  :values (11))

;;; Class slot should be written when there is an initarg for it.

(define-mi-test make-instance.9
    (with-slots (a b) (mi 'm3 :both 12)
      (values a b))
  :values (12 12))

(define-mi-test make-instance.10
    (with-slots (a b) (mi 'm3 :both 13)
      (values a b))
  :values (13 13))

;;; Invalid initialization arguments

(define-mi-test make-instance.11
    (multiple-value-bind (r c)
	(ignore-errors (mi 'm3 :hansi t))
      (values r (typep c 'condition)))
  :values (nil t))

(define-mi-test make-instance.12
    (multiple-value-bind (r c)
	(ignore-errors (mi 'm3 :hansi t :allow-other-keys t))
      (values (slot-value r 'b) (typep c 'condition)))
  :values (2 nil))

;;; Default initargs

(defclass m5 (m1)
  ()
  (:default-initargs :a 'a :b 'b))

(define-mi-test make-instance.13
    (with-slots (a b) (mi 'm5)
      (values a b))
  :values (a b))

(defclass m6 (m5)
  ()
  (:default-initargs :a 'c))

(define-mi-test make-instance.14
    (with-slots (a b) (mi 'm6)
      (values a b))
  :values (c b))

(defclass m7 (m6)
  ((a :allocation :class :initform nil)))

(define-mi-test make-instance.15
    (with-slots (a b) (mi 'm7)
      (values a b))
  :values (c b))

;;; Lexical environment.

(let ((x 0))
  (defclass m8 ()
    ((a :initform (incf x))))
  (defun reset-counter ()
    (setq x 0)))

(define-mi-test make-instance.16
    (progn
      (reset-counter)
      (loop for i below 5
	    collect (slot-value (mi 'm8) 'a)))
  :values ((1 2 3 4 5)))

(defclass m9 ()
  ((a :initarg :a)
   (b :initarg :b)
   (c :initarg :c)
   (d :initarg :d)))

(define-mi-test make-instance.17
    (let* ((x 'x)
	   (instance (mi 'm9 :a () :b x :c '(baz bar foo)
			 :d (lambda () ()))))
      (with-slots (a b c) instance
	(values a b c)))
  :values (nil x (baz bar foo)))

;; After and before methods.

(defclass m10 ()
  ((a :initform 0 :initarg :a)
   (b :initarg :b)
   (c :initform 2 :initarg :c))
  (:default-initargs :c 1))
(defvar *result* ())

(defmethod initialize-instance :before ((x m10) &rest args)
  (declare (ignore args))
  (push (list 'm10 :before (slot-boundp x 'a)
	      (slot-boundp x 'b) (slot-boundp x 'c))
	*result*))

(define-mi-test make-instance.18
    (progn
      (setq *result* ())
      (with-slots (a b c) (mi 'm10 :b 42)
	(values *result* a b c)))
  :values (((m10 :before nil nil nil)) 0 42 1))

(defclass m11 (m10)
  ()
  (:default-initargs :c 11))

(defmethod initialize-instance :before ((x m11) &rest args)
  (declare (ignore args))
  (push (list 'm11 :before (slot-boundp x 'a)
	      (slot-boundp x 'b)
	      (slot-boundp x 'c))
	*result*))

(defmethod initialize-instance :after ((x m11) &rest args)
  (declare (ignore args))
  (push (list 'm11 :after (slot-boundp x 'a)
	      (slot-boundp x 'b)
	      (slot-boundp x 'c))
	*result*))

(define-mi-test make-instance.19
    (progn
      (setq *result* ())
      (with-slots (a b c) (mi 'm11 :b 42)
	(values *result* a b c)))
  :values (((m11 :after t t t)
	    (m10 :before nil nil nil)
	    (m11 :before nil nil nil))
	   0 42 11))

(defclass m12 (m10)
  ()
  (:default-initargs :c 13))

(defmethod initialize-instance :before ((x m12) &rest args)
  (declare (ignore args))
  (setf (slot-value x 'a) 77))

(define-mi-test make-instance.20
    (progn
      (setq *result* ())
      (with-slots (a b c) (mi 'm12 :b 42)
	(values *result* a b c)))
  :values (((m10 :before t nil nil))
	   77 42 13))

(define-mi-test make-instance.21
    (progn
      (setq *result* ())
      (with-slots (a b c) (mi 'm12 :b 41 :c 67)
	(values *result* a b c)))
  :values (((m10 :before t nil nil))
	   77 41 67))

;;; :ALLOW-OTHER-KEYS

(define-mi-test make-instance.22
    (let ((obj (ignore-errors (mi 'm12 :b 41 :allow-other-keys t))))
      (when obj
	(with-slots (a b c) obj
	  (values a b c))))
  :values (77 41 13))


(define-mi-test make-instance.23
    (let ((obj (ignore-errors (mi 'm12 :b 41 :x 11 :allow-other-keys t))))
      (when obj
	(with-slots (a b c) obj
	  (values a b c))))
  :values (77 41 13))

(define-mi-test make-instance.24
    (multiple-value-bind (r c)
	(ignore-errors (mi 'm12 :b 41 :x 11))
      (values r (typep c 'condition)))
  :values (nil t))

(define-mi-test make-instance.25
    (multiple-value-bind (r c)
	(ignore-errors (mi 'm12 :b 41 :x 11 :allow-other-keys nil))
      (values r (typep c 'condition)))
  :values (nil t))

;; Create a constructor, than rename the package of the class it was
;; defined for.

(defpackage "%CTOR"
  (:use "COMMON-LISP"))

(in-package "%CTOR")

(defclass p1 ()
  ((a :initform 0)))

(defun f1 ()
  (make-instance 'p1))

(in-package "PCL-TESTS")

(define-mi-test make-instance.26
    (progn
      (rename-package "%CTOR" "%CTOR2")
      (let* ((f (find-symbol "F1" "%CTOR2"))
	     (a (find-symbol "A" "%CTOR2"))
	     (i (funcall f)))
	(prog1
	    (slot-value i a)
	  (rename-package "%CTOR2" "%CTOR"))))
  :values (0))

(defclass stru.0 ()
  ((a :initarg :a :accessor a-accessor)
   (b :initform 2 :reader b-reader))
  (:metaclass structure-class))

(defclass stru.1 (stru.0)
  ((c :initarg :c :writer c-writer :accessor c-accessor))
  (:metaclass structure-class))

(define-mi-test make-instance.27
    (with-slots (a b) (mi 'stru.0)
      (values a b))
  :values (nil 2))

(define-mi-test make-instance.28
    (with-slots (a b) (mi 'stru.0 :a 1)
      (values a b))
  :values (1 2))

(define-mi-test make-instance.29
    (with-slots (a b c) (mi 'stru.1)
      (values a b c))
  :values (nil 2 nil))

(define-mi-test make-instance.30
    (with-slots (a b c) (mi 'stru.1 :a 1 :c 3)
      (values a b c))
  :values (1 2 3))

(deftest make-instance.31
    (let ((*m30* nil))
      (declare (special *m30*))
      (defclass m30 () ())
      (defclass m31 (m30) ())
      (defun f () (make-instance 'm31))
      (compile 'f)
      (f)
      (defmethod initialize-instance :before ((x m30) &rest args)
	(declare (ignore args))
	(declare (special *m30*))
	(setq *m30* t))
      (f)
      *m30*)
  t)

(defclass mi13 ()
  ((s1 :initarg :s1a :initarg :s1b :reader s1)
   (s2 :initarg :s2 :reader s2)))

(define-mi-test make-instance.32
    (with-slots (s1 s2) 
	(make-instance 'mi13 :s2 'a :s1a 'b :s2 'x :s1a 'y :s1b 'z)
      (values s1 s2))
  :values (b a))

;; (setf find-class), class redefinitions

;; method-combination.lisp
;;; ********************************
;;; Method Group Specifiers ********
;;; ********************************

(define-method-combination mgs0 (x)
  ((primary () :required t))
  (progn
    x
    `(call-method ,(first primary))))

;;; This should simply not signal an error as it did in 18d.

(deftest method-group-specifiers.0
    (multiple-value-bind (r c)
	(ignore-errors
	  (defgeneric mgs0 (obj)
	    (:method-combination mgs0 1))
	  (defmethod mgs0 (obj)
	    obj)
	  (mgs0 1))
      (values r c))
  1 nil)


;;; **************************
;;; :generic-function  *******
;;; **************************


;;; *******************
;;; :arguments  *******
;;; *******************

(defvar *result* nil)

(defvar *mca0-value*
  (define-method-combination mca0 ()
    ((methods *))
    (:arguments x y &optional opt)
    (:generic-function gf)
    `(progn
       (setq *result* (list (pcl:generic-function-name ,gf) ,x ,y ,opt))
       (call-method ,(first methods)))))

(defgeneric mca0 (a)
  (:method-combination mca0)
  (:method (a) a))

(defgeneric mca1 (a b)
  (:method-combination mca0)
  (:method (a b) (list a b)))

(defgeneric mca2 (a &optional b)
  (:method-combination mca0)
  (:method (a &optional b) (list a b)))

(defgeneric mca3 (&optional b)
  (:method-combination mca0)
  (:method (&optional b) b))

(deftest method-combination.0
    *mca0-value*
  mca0)

(deftest method-combination-arguments.0
    (multiple-value-bind (r c)
	(ignore-errors (mca0 1) *result*)
      (values r (null c)))
  (mca0 1 nil nil) t)

(deftest method-combination-arguments.1
    (multiple-value-bind (r c)
	(ignore-errors (mca1 1 2) *result*)
      (values r (null c)))
  (mca1 1 2 nil) t)

(deftest method-combination-arguments.2
    (multiple-value-bind (r c)
	(ignore-errors (mca2 1) *result*)
      (values r (null c)))
  (mca2 1 nil nil) t)

(deftest method-combination-arguments.3
    (multiple-value-bind (r c)
	(ignore-errors (mca2 1 2) *result*)
      (values r (null c)))
  (mca2 1 nil 2) t)

(deftest method-combination-arguments.4
    (multiple-value-bind (r c)
	(ignore-errors (mca3) *result*)
      (values r (null c)))
  (mca3 nil nil nil) t)

(deftest method-combination-arguments.5
    (multiple-value-bind (r c)
	(ignore-errors (mca3 1) *result*)
      (values r (null c)))
  (mca3 nil nil 1) t)

(define-method-combination mca1 ()
  ((methods *))
  (:arguments x y &rest r)
  (:generic-function gf)
  `(progn
     (setq *result* (list (pcl:generic-function-name ,gf) ,x ,y ,r))
     (call-method ,(first methods))))

(defgeneric mca1.0 (&rest b)
  (:method-combination mca1)
  (:method (&rest b) b))

(deftest method-combination-arguments.6
    (multiple-value-bind (r c)
	(ignore-errors (mca1.0) *result*)
      (values r (null c)))
  (mca1.0 nil nil nil) t)

(deftest method-combination-arguments.7
    (multiple-value-bind (r c)
	(ignore-errors (mca1.0 1) *result*)
      (values r (null c)))
  (mca1.0 nil nil (1)) t)

(define-method-combination mca2 ()
  ((methods *))
  (:arguments &key a b)
  (:generic-function gf)
  `(progn
     (setq *result* (list (pcl:generic-function-name ,gf) ,a ,b))
     (call-method ,(first methods))))

(defgeneric mca2.0 (&key a b)
  (:method-combination mca2)
  (:method (&key (a 0) (b 1)) (list a b)))

(deftest method-combination-arguments.8
    (multiple-value-bind (r c)
	(ignore-errors (mca2.0) *result*)
      (values r (null c)))
  (mca2.0 nil nil) t)

(deftest method-combination-arguments.9
    (multiple-value-bind (r c)
	(ignore-errors (mca2.0 :a 1) *result*)
      (values r (null c)))
  (mca2.0 1 nil) t)

(deftest method-combination-arguments.10
    (multiple-value-bind (r c)
	(ignore-errors (mca2.0 :b 1) *result*)
      (values r (null c)))
  (mca2.0 nil 1) t)

(deftest method-combination-arguments.11
    (multiple-value-bind (r c)
	(ignore-errors (mca2.0 :b 1 :a 0) *result*)
      (values r (null c)))
  (mca2.0 0 1) t)

(define-method-combination mca3 ()
   ((methods *))
   (:arguments &whole w x &key k)
   (:generic-function gf)
   `(progn
      (setq *result* (list (pcl:generic-function-name ,gf) ,w ,x ,k))
      (call-method ,(first methods))))

(defgeneric mca3.0 (x &key k)
  (:method-combination mca3)
  (:method (x &key k) (list x k)))

(deftest method-combination-arguments.12
    (multiple-value-bind (r c)
	(ignore-errors (mca3.0 1) *result*)
      (values r (null c)))
  (mca3.0 (1) 1 nil) t)

(deftest method-combination-arguments.13
    (multiple-value-bind (r c)
	(ignore-errors (mca3.0 1 :k 2) *result*)
      (values r (null c)))
  (mca3.0 (1 :k 2) 1 2) t)

;; methods.lisp
;;; Old PCL has a bug wrt rebinding a parameter around
;;; CALL-NEXT-METHOD.

(deftest methods.0
    (progn
      (defclass mt0 ()
	())
      (defmethod mt0 ((m mt0) x)
	x)
      (defmethod mt0 :around ((m mt0) x)
	(let ((x (1+ x)))
	  #+cmu (declare (optimize (ext:inhibit-warnings 3)))
	  (call-next-method)))
      (mt0 (make-instance 'mt0) 42))
  42)

;; pv.lisp
;;;**************************
;;; With Optimization  ******
;;; *************************

#+gerds-pcl
(eval-when (:compile-toplevel :load-toplevel :execute)
  (setq pcl::*optimize-gf-calls-p* t))

(defclass pv0 ()
  ((a :accessor pv0-a :initform 0)))

(defmethod pv0.0 ((x pv0))
  1)

(defmethod pv0.1 ((x pv0) &rest r)
  (car r))

(defmethod pv0.2 ((x pv0) &key k)
  k)

(defmethod pv0.3 ((x pv0) &optional o)
  o)

(defmethod pv0.4 ((x pv0) (y pv0))
  1)

(defmethod call-pv0 ((x pv0))
  (list (pv0.0 x)
	(pv0.1 x 2)
	(pv0.2 x :k 3) (pv0.2 x)
	(pv0.3 x 1) (pv0.3 x)
	(pv0.4 x x)))

(deftest pv-gf-call-optimized.0
    (ignore-errors (call-pv0 (make-instance 'pv0)))
  (1 2 3 nil 1 nil 1))
(defclass pv0.1 (pv0) ())

(defmethod pv0.0 ((x pv0.1))
  (call-next-method))

(defmethod pv0.1 ((x pv0.1) &rest r)
  (declare (ignorable r))
  (call-next-method))

(defmethod pv0.2 ((x pv0.1) &key k)
  (declare (ignorable k))
  (call-next-method))

(defmethod pv0.3 ((x pv0.1) &optional o)
  (declare (ignorable o))
  (call-next-method))

(defmethod pv0.4 ((x pv0.1) (y pv0.1))
  (call-next-method))

(defmethod call-pv0 ((x pv0.1))
  (call-next-method))

(deftest pv-gf-call-optimized.1
    (ignore-errors (call-pv0 (make-instance 'pv0.1)))
  (1 2 3 nil 1 nil 1))

(deftest pv-gf-call-optimized.2
    (ignore-errors (call-pv0 (make-instance 'pv0)))
  (1 2 3 nil 1 nil 1))


;;;*****************************
;;; Without Optimization  ******
;;; ****************************

#+gerds-pcl
(eval-when (:compile-toplevel :load-toplevel :execute)
  (setq pcl::*optimize-gf-calls-p* nil))

(defclass pv1 ()
  ((a :accessor pv1-a :initform 0)))

(defmethod pv1.0 ((x pv1))
  1)

(defmethod pv1.1 ((x pv1) &rest r)
  (car r))

(defmethod pv1.2 ((x pv1) &key k)
  k)

(defmethod pv1.3 ((x pv1) &optional o)
  o)

(defmethod call-pv1 ((x pv1))
  (list (pv1.0 x)
	(pv1.1 x 2)
	(pv1.2 x :k 3) (pv1.2 x)
	(pv1.3 x 1) (pv1.3 x)))

(deftest pv-gf-call.1
    (call-pv1 (make-instance 'pv1))
  (1 2 3 nil 1 nil))


;; reinitialize-instance.lisp
(deftest reinitialize-instance.0
    (multiple-value-bind (r c)
	(ignore-errors
	  (defclass ri0 () ((a :initarg :a)))
	  (reinitialize-instance (make-instance 'ri0) :a 1))
      (values (null r) (typep c 'error)))
  nil nil)

(deftest reinitialize-instance.1
    (multiple-value-bind (r c)
	(ignore-errors
	  (defclass ri1 () ())
	  (reinitialize-instance (make-instance 'ri1) :a 1))
      (values (null r) (typep c 'error)))
  t t)

(deftest reinitialize-instance.2
    (multiple-value-bind (r c)
	(ignore-errors
	  (defclass ri2 () ())
	  (defmethod shared-initialize ((x ri2) slots &rest initargs &key a)
	    (declare (ignore slots initargs a)))
	  (reinitialize-instance (make-instance 'ri2) :a 1))
      (values (null r) (typep c 'error)))
  nil nil)

(deftest reinitialize-instance.3
    (multiple-value-bind (r c)
	(ignore-errors
	  (defclass ri3 () ())
	  (defmethod reinitialize-instance :after ((x ri3) &rest initargs
						   &key a)
	    (declare (ignore initargs a)))
	  (reinitialize-instance (make-instance 'ri3) :a 1))
      (values (null r) (typep c 'error)))
  nil nil)

(deftest reinitialize-instance.4
    (multiple-value-bind (r c)
	(ignore-errors
	  (defclass ri4 () ())
	  (defmethod reinitialize-instance :after ((x ri4) &rest initargs
						   &key a &allow-other-keys)
	    (declare (ignore initargs a)))
	  (reinitialize-instance (make-instance 'ri4) :a 1 :b 2))
      (values (null r) (typep c 'error)))
  nil nil)

(deftest reinitialize-instance.5
    (multiple-value-bind (r c)
	(ignore-errors
	  (defclass ri5 () ())
	  (reinitialize-instance (make-instance 'ri4)
				 :a 1 :b 2 :allow-other-keys t))
      (values (null r) (typep c 'error)))
  nil nil)

;; slot-accessors.lisp
(defclass sa0 ()
  ((a :accessor a-of :initarg :a)))

(deftest slot-accessor.0
    (let ((instance (make-instance 'sa0 :a 0)))
      (a-of instance))
  0)

(deftest slot-accessor.1
    (let ((instance (make-instance 'sa0)))
      (setf (a-of instance) 1)
      (a-of instance))
  1)

(defmethod sa0.0 ((x sa0))
  (a-of x))

(deftest slot-accessor.2
    (let ((instance (make-instance 'sa0)))
      (setf (a-of instance) 2)
      (sa0.0 instance))
  2)

;;; Redefining the class should update the PV table cache of
;;; method SA0.0 so that is reads the right slot.

(deftest slot-accessor.3
    (progn
      (defclass sa0 ()
	((c :accessor c-of)
	 (a :accessor a-of :initarg :a)
	 (b :accessor b-of)))
      (sa0.0 (make-instance 'sa0 :a 42)))
  42)

(defclass sa1 (sa0)
  ((b :accessor a-of :initarg :b)))
      
(deftest slot-accessor.4
    (let ((instance (make-instance 'sa1 :b 0)))
      (sa0.0 instance))
  0)

(defclass sa2 (sa0)
  ())

(defmethod (setf a-of) (new-value (obj sa2))
  (setf (slot-value obj 'a) (* 2 new-value)))

(defmethod sa2.0 ((obj sa2))
  (setf (a-of obj) 42))

(deftest slot-accessor.5
    (let ((instance (make-instance 'sa2)))
      (sa2.0 instance))
  84)

(defclass sa3 ()
  ())

(defmethod (setf foo-of) (n (obj sa3))
  n)

(defmethod sa3.0 ((obj sa3))
  (setf (foo-of obj) 11))

(deftest slot-accessor.6
    (let ((instance (make-instance 'sa3)))
      (sa3.0 instance))
  11)

(eval-when (:compile-toplevel :load-toplevel :execute)
  (defclass sa4 ()
    ((a :initform 0 :accessor sa4-a))))

(defmethod sa4.0 ((x sa4))
  (sa4-a x))

(deftest slot-accessor.7
    (sa4.0 (make-instance 'sa4))
  0)

(deftest slot-accessor.8
    (progn
      (defun sa4-a (x)
	(declare (ignore x))
	11)
      (prog1
	  (sa4.0 (make-instance 'sa4))
	(fmakunbound 'sa4-a)))
  11)

;; slot-boundp.lisp
(defclass sbp0 ()
  ((a :initarg :a :initform 0)
   (b :initarg :b)
   (c :allocation :class)))

(defmethod sbp0.0 ((x sbp0) slot)
  (null (slot-boundp x slot)))

(deftest slot-boundp.0
    (null (slot-boundp (make-instance 'sbp0) 'a))
  nil)

(define-compiled-test slot-boundp.1
    (null (slot-boundp (make-instance 'sbp0) 'a))
  nil)

(deftest slot-boundp.2
    (null (slot-boundp (make-instance 'sbp0) 'b))
  t)

(define-compiled-test slot-boundp.3
    (multiple-value-bind (r c)
	(ignore-errors (slot-boundp (make-instance 'sbp0) 'b))
      (values (null r) c))
  t nil)

(deftest slot-boundp.4
    (null (slot-boundp (make-instance 'sbp0) 'c))
  t)

(define-compiled-test slot-boundp.5
    (null (slot-boundp (make-instance 'sbp0) 'c))
  t)

(deftest slot-boundp.6
    (sbp0.0 (make-instance 'sbp0) 'b)
  t)

(deftest slot-boundp.7
    (sbp0.0 (make-instance 'sbp0 :a 2) 'a)
  nil)

;; slot-missing.lisp
;;; in method (pv table optimization)
;;; in compiled defun
;;; uncompiled.

(defmacro define-sm-test (name (instance class) access &rest values)
  (let* ((*print-case* :upcase)
	 (*print-pretty* nil)
	 (*print-gensym* t)
	 (method-name (intern (format nil "~S.METHOD" name)))
	 (method-test (intern (format nil "~S.METHOD-TEST" name)))
	 (compiled-test (intern (format nil "~S.COMPILED" name))))
    `(progn
       (defmethod ,method-name ((,instance ,class))
	 ,access)
       (deftest ,name
	   (multiple-value-bind (r c)
	       (let ((,instance (make-instance ',class)))
		 (ignore-errors ,access))
	     (values r (typep c 'condition)))
	 ,@values)
       (deftest ,method-test
	   (multiple-value-bind (r c)
	       (let ((,instance (make-instance ',class)))
		 (ignore-errors (,method-name ,instance)))
	     (values r (typep c 'condition)))
	 ,@values)
       (define-compiled-test ,compiled-test
	   (multiple-value-bind (r c)
	       (let ((,instance (make-instance ',class)))
		 (ignore-errors ,access))
	     (values r (typep c 'condition)))
	 ,@values))))

(defclass sm0 () ())

(define-sm-test slot-missing.0 (instance sm0)
  (slot-value instance 'a)
  nil t)

(define-sm-test slot-missing.1 (instance sm0)
  (setf (slot-value instance 'a) 1)
  nil t)

(define-sm-test slot-missing.2 (instance sm0)
  (slot-boundp instance 'a)
  nil t)

(defclass sm1 () ())

(defvar *sm-result* nil)

(defmethod slot-missing (class (obj sm1) slot-name operation
			 &optional new-value)
  (setq *sm-result* (list slot-name operation new-value)))

(define-sm-test slot-missing.3 (instance sm1)
  (progn
    (slot-value instance 'a)
    *sm-result*)
  (a slot-value nil) nil)

(define-sm-test slot-missing.4 (instance sm1)
  (progn
    (setf (slot-value instance 'a) 1)
    *sm-result*)
  (a setf 1) nil)

(define-sm-test slot-missing.5 (instance sm1)
  (progn
    (slot-boundp instance 'a)
    *sm-result*)
  (a slot-boundp nil) nil)

;; slot-type.lisp
#+gerds-pcl
(eval-when (:compile-toplevel :load-toplevel :execute)
  (setq pcl::*use-slot-types-p* t))

;;; Check that we check slot types, at least sometimes.

(defclass stype ()
  ((a :type fixnum :initform 0 :initarg :a)))

(defmethod stype.0 ((obj stype))
  (slot-value obj 'a))

(defmethod stype.1 ((obj stype) value)
  (setf (slot-value obj 'a) value))
(deftest slot-type.0
    (multiple-value-bind (r c)
	(ignore-errors
	  (stype.0 (make-instance 'stype :a 1)))
      (values r (null c)))
  1 t)

(deftest slot-type.1
    (multiple-value-bind (r c)
	(ignore-errors
	  (stype.0 (make-instance 'stype :a 1.0)))
      (values r (typep c 'error)))
  nil t)

(deftest slot-type.2
    (multiple-value-bind (r c)
	(ignore-errors
	  (stype.1 (make-instance 'stype) 1))
      (values r (typep c 'error)))
  1 nil)

(deftest slot-type.3
    (multiple-value-bind (r c)
	(ignore-errors
	  (stype.1 (make-instance 'stype) 1.0))
      (values r (typep c 'error)))
  nil t)

(deftest slot-type.4
    (multiple-value-bind (r c)
	(ignore-errors
	  (setf (slot-value (make-instance 'stype) 'a) "string"))
      (values r (typep c 'error)))
  nil t)

;; slot-value.lisp
(defclass sv0 ()
  ((a :allocation :class :initarg :a :initform 0)))

(defun sv0.0 ()
  (let* ((x (random 10))
	 (obj (make-instance 'sv0 :a x)))
    (eql x (slot-value obj (identity 'a)))))

;;; In previous versions of PCL (18d for example), the above
;;; slot-value fails when the class is redefined.
	      
(deftest slot-value.0
    (sv0.0)
  t)

(deftest slot-value.1
    (progn
      (defclass sv0 ()
	((a :allocation :class :initarg :a :initform 0)))
      t)
  t)

(deftest slot-value.2
    (sv0.0)
  t)