From 83231787bceca6ffcbb8d06cd25b508fddfc317a Mon Sep 17 00:00:00 2001
From: Raymond Toy <toy.raymond@gmail.com>
Date: Fri, 14 Mar 2014 22:02:53 -0700
Subject: [PATCH] Remove the tests and just use mk-defsystem to load the
 separate PCL test files.

---
 tests/pcl.lisp | 2072 ++----------------------------------------------
 1 file changed, 66 insertions(+), 2006 deletions(-)

diff --git a/tests/pcl.lisp b/tests/pcl.lisp
index c49e279d7..dc5944503 100644
--- a/tests/pcl.lisp
+++ b/tests/pcl.lisp
@@ -1,13 +1,11 @@
 ;;; Tests for PCL, taken from src/pcl/rt.
-;;;
-;;; It's clear that the tests used mk defsystem to load the tests, but
-;;; it's not clear if the tests were compiled or not before running.
 
 (defpackage "PCL-TESTS"
   (:use "COMMON-LISP" "PCL" "LISP-UNIT"))
 
 (in-package "PCL-TESTS")
 
+;; Simple macro converting RT's DEFTEST to lisp-unit's DEFINE-TEST.
 (defmacro deftest (name form &rest values)
   (let ((results (gensym "RESULTS-")))
     `(define-test ,name
@@ -21,2006 +19,68 @@
      (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 (:load-toplevel :compile-toplevel :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)
-      
+(require :defsystem)
+
+(setf (logical-pathname-translations "pcl-test")
+      (list (list "*.*.*"
+		  (merge-pathnames #p"pcl/*.*"
+				   *load-truename*))))
+
+(mk:defsystem :pcl-test
+    :initially-do (progn )
+    :source-pathname "pcl-test:"
+    :binary-pathname "pcl-test:"
+    :components
+    ((:file "pkg"
+	    :source-extension "lisp")
+     #+gerds-pcl
+     (:file "ctor"
+	    :source-extension "lisp"
+	    :depends-on ("pkg"))
+     (:file "defclass"
+	    :source-extension "lisp"
+	    :depends-on ("pkg"))
+     (:file "make-instance"
+	    :source-extension "lisp"
+	    :depends-on ("pkg" #+gerds-pcl "ctor"))
+     (:file "reinitialize-instance"
+	    :source-extension "lisp"
+	    :depends-on ("pkg" "make-instance"))
+     (:file "slot-value"
+	    :source-extension "lisp"
+	    :depends-on ("pkg" "make-instance"))
+     (:file "slot-boundp"
+	    :source-extension "lisp"
+	    :depends-on ("pkg" "make-instance"))
+     (:file "slot-missing"
+	    :source-extension "lisp"
+	    :depends-on ("pkg" "make-instance"))
+     (:file "slot-accessors"
+	    :source-extension "lisp"
+	    :depends-on ("pkg" "make-instance"))
+     (:file "slot-type"
+	    :source-extension "lisp"
+	    :depends-on ("pkg" "slot-value"))
+     (:file "inline-access"
+	    :source-extension "lisp"
+	    :depends-on ("pkg" "slot-type"))
+     (:file "method-combination"
+	    :source-extension "lisp"
+	    :depends-on ("pkg"))
+     (:file "pv"
+	    :source-extension "lisp"
+	    :depends-on ("pkg"))
+     (:file "defgeneric"
+	    :source-extension "lisp"
+	    :depends-on ("pkg"))
+     (:file "defmethod"
+	    :source-extension "lisp"
+	    :depends-on ("pkg"))
+     (:file "find-method"
+	    :source-extension "lisp"
+	    :depends-on ("pkg"))
+     (:file "methods"
+	    :source-extension "lisp"
+	    :depends-on ("pkg"))))
+
+(mk:oos :pcl-test :compile)
-- 
GitLab