diff --git a/tests/pcl.lisp b/tests/pcl.lisp
new file mode 100644
index 0000000000000000000000000000000000000000..fe4402b9ba6815b96ee20a1b48e7d4fa2715bebc
--- /dev/null
+++ b/tests/pcl.lisp
@@ -0,0 +1,2022 @@
+
+(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)
+