;;;-*- Mode:LISP; Package: CLOS; Base:10; Syntax:Common-lisp -*-
;;;
;;; *************************************************************************
;;; Copyright (c) 1991 Venue
;;; All rights reserved.
;;; *************************************************************************
;;; 
;;; Testing code.
;;;

(in-package :clos)

;;; Because CommonLoops runs in itself so much, the notion of a test file for
;;; it is kind of weird.
;;;
;;; If all of CLOS loads then many of the tests in this file (particularly
;;; those at the beginning) are sure to work.  Those tests exists primarily
;;; to help debug things when low-level changes are made to CLOS, or when a
;;; particular port customizes low-level code.
;;;
;;; Some of the other tests are "real" in the sense that they test things
;;; that CLOS itself does not use, so might be broken.
;;; 
;;; NOTE:
;;;   The tests in this file do not appear in random order!  They
;;;   depend on state  which has already been set up in order to run.
;;;

(defmacro do-test (name cleanups &body body)
  `(let ((do-test-failed nil))
     (catch 'do-test
       (format t "~&Testing ~A..." ,name)
;       (cleanup-do-test ',cleanups)
       (block do-test ,@body)
       (if do-test-failed
           (format t "~&FAILED!")
           (format t "OK")))))
  
(defmacro do-test-error (fatal string &rest args)
  `(progn (terpri)
          (setq do-test-failed t)
          (format t ,string ,@args)
          (when ,fatal (return-from do-test nil))))

(defun cleanup-do-test (cleanups)
  (dolist (cleanup cleanups)
    (ecase (car cleanup)
      (:classes
        (dolist (c (cdr cleanup))
          (let ((class (find-class c 'nil)))
            (when class
              (dolist (super (slot-value class 'direct-superclasses))
                (setf (slot-value class 'direct-subclasses)
                      (remove class (slot-value class 'direct-subclasses))))
              (setf (find-class c) nil)))))
      (:functions
        (dolist (f (cdr cleanup))
          (fmakunbound f)))
      (:setf-generic-functions
        (dolist (f (cdr cleanup))
          (fmakunbound (get-setf-function-name f))))
      (:variables
        (dolist (v (cdr cleanup))
          (makunbound v))))))

#-(or KCL IBCL :Coral GCLisp)
(eval-when (eval)
  (compile 'do-test)
  (compile 'do-test-error)
  (compile 'cleanup-do-test))

  ;;   
;;;;;; 
  ;;   

(do-test "types for early classes"
         ()
  (dolist (x '(standard-object standard-class standard-slot-definition))
    (or (typep (make-instance x) x)
        (do-test-error () "instance of ~S not of type ~S??" x x))))


(do-test "types for late classes"
         ()
  (dolist (x '(standard-method standard-generic-function))
    (or (typep (make-instance x) x)
        (do-test-error () "~&instance of ~S not of type ~S??" x x))))

(defvar *built-in-class-tests*
        '((ARRAY (MAKE-ARRAY '(10 10)))
          (BIT-VECTOR (MAKE-ARRAY 10 :ELEMENT-TYPE 'BIT))
          (CHARACTER #\a)
          (COMPLEX #C(1 2))
          (CONS (LIST 1 2 3))
          (FLOAT 1.3)
          (INTEGER 1)
         ;LIST                   abstract super of cons, null
          (NULL NIL)
         ;NUMBER                 abstract super of complex, float, rational
          (RATIO 1/2)
         ;RATIONAL               abstract super of ratio, integer
         ;SEQUENCE               abstract super of list, vector
          (STRING "foo")
          (SYMBOL 'FOO)
          (VECTOR (VECTOR 1 2 3))))

(do-test "built-in-class-of"
         ()
  (let ((lostp nil))
    (dolist (tst *built-in-class-tests*)
      (unless (eq (find-class (car tst) 't)
                  (class-of (eval (cadr tst))))
        (do-test-error ()
                       "~&class-of ~S was ~A not ~A~%"
                       (cadr tst)
                       (class-name (class-of (eval (cadr tst))))
                       (car tst))
        (setq lostp t)))
    (not lostp)))

(do-test "existence of generic-functions for accessors of early classes"
         ()
  ;; Because accessors are done with add-method, and this has to be done
  ;; specially for early classes it is worth testing to make sure that
  ;; the generic-functions got created for the accessor of early classes.
  ;;
  ;; Of course CLOS wouldn't have loaded if most of these didn't exist,
  ;; but what the hell.
  (dolist (class '(standard-class
                   standard-slot-definition
                   standard-generic-function
                   standard-method))
    (dolist (slotd (class-slots (find-class class)))
      (dolist (rea (slotd-readers slotd))
        (unless (and (gboundp rea)
                     (generic-function-p (gdefinition rea)))
          (do-test-error () "~S isn't a generic function" rea)))
      (dolist (wri (slotd-writers slotd))
        (unless (and (gboundp wri)
                     (generic-function-p (gdefinition wri)))
          (do-test-error () "~S isn't a generic function" wri))))))

(do-test "early reader/writer methods are appropriate class"
         ()
  ;; Because accessors are done with add-method, and this has to be done
  ;; specially for early classes it is worth testing to make sure that
  ;; the generic-functions got created for the accessor of early classes.
  ;;
  ;; Of course CLOS wouldn't have loaded if most of these didn't exist,
  ;; but what the hell.
  (dolist (class '(standard-class
                   standard-slot-definition
                   standard-generic-function
                   standard-method))
    (let ((class (find-class 'standard-class)))
      (flet ((check-reader (gf)
               (let ((reader (get-method (gdefinition gf)
                                         ()
                                         (list class))))
                 (unless (typep reader 'standard-reader-method)
                   (do-test-error () "~S isn't a READER method" reader))))
             (check-writer (gf)
               (let ((writer (get-method (gdefinition gf)
                                         ()
                                         (list (find-class 't) class))))
                 (unless (typep writer 'standard-writer-method)
                   (do-test-error () "~S isn't a WRITER method" writer)))))
        (dolist (slotd (class-direct-slots class))
          (dolist (rea (slotd-readers slotd))
            (check-reader rea))   
          (dolist (wri (slotd-writers slotd))
            (check-writer wri)))))))

(do-test "typep works for standard-classes"
         ((:classes foo1 foo2 bar))

  (defclass foo1 () ())
  (defclass foo2 (foo1) ())
  (defclass bar () ())

  (let ((f1 (make-instance 'foo1))
        (f2 (make-instance 'foo2)))
    (or (typep f1 'foo1)
        (do-test-error
          () "an instance of foo1 isn't subtypep of foo1"))
    (or (not (typep f1 'foo2))
        (do-test-error
          () "an instance of foo1 is suptypep of a subclass of foo1"))
    (or (not (typep f1 'bar))
        (do-test-error
          () "an instance of foo1 is subtypep of an unrelated class"))
    (or (typep f2 'foo1)
        (do-test-error
          () "an instance of foo2 is not subtypep of a super-class of foo2"))
    ))

(do-test "accessors and readers should NOT be inherited"
         ((:classes foo bar)
          (:functions foo-x foo-y))

  (defclass foo ()
       ((x :accessor foo-x)
        (y :reader foo-y)))

  (fmakunbound 'foo-x)
  (fmakunbound 'foo-y)

  (defclass bar (foo)
       (x y))

  (and (fboundp 'foo-x) (do-test-error () "foo-x got inherited?"))
  (and (fboundp 'foo-y) (do-test-error () "foo-x got inherited?")))

(do-test ":accessor and :reader methods go away"
         ((:classes foo)
          (:functions foo-x foo-y)
          (:setf-generic-functions foo-x foo-y))  

  (defclass foo () ((x :accessor foo-x) (y :reader foo-y)))

  (unless (and (fboundp 'foo-x)
               (fboundp 'foo-y))
    (do-test-error t "accessors didn't even get generated?"))

  (defclass foo () (x y))

  (flet ((methods (x)
           (generic-function-methods (symbol-function 'foo-y))))
    
    (and (methods 'foo-x)
         (do-test-error () "~&reader method for foo-x not removed"))
    (and (methods 'foo-y)
         (do-test-error () "~&reader method for foo-y not removed"))
    (and (methods (get-setf-function-name 'foo-y))
         (do-test-error () "~&writer method for foo-y not removed"))
    t))


(defclass test-class-1 ()
     ((x :initform nil :accessor test-class-1-x :initarg :x)
      (y :initform nil :accessor test-class-1-y :initarg :y)))

(do-test "Simple with-accessors test -- does not really exercise the walker."
         ((:functions foo bar))

  (defmethod foo ((obj test-class-1))
    (with-accessors ((x test-class-1-x)
                     (y test-class-1-y))
                    obj
      (list x y)))

  (defmethod bar ((obj test-class-1))
    (with-accessors ((x test-class-1-x)
                     (y test-class-1-y))
                obj
      (setq x 1
            y 2)))

  (or (and (equal '(nil nil) (foo (make-instance 'test-class-1)))
           (equal '(1 2) (foo (make-instance 'test-class-1 :x 1 :y 2))))
      (do-test-error () "FOO (the one that reads) failed"))

  (or (let ((foo (make-instance 'test-class-1)))
        (bar foo)
        (or (and (equal (slot-value foo 'x) 1)
                 (equal (slot-value foo 'y) 2))
            (do-test-error () "BAR (the one that writes) failed")))))

(do-test "Simple with-slots test -- does not really exercise the walker."
         ((:functions foo bar))
  
  (defmethod foo ((obj test-class-1))
    (with-slots (x y)
                obj
      (list x y)))

  (defmethod bar ((obj test-class-1))
    (with-slots ((obj-x x)
                 (obj-y y))
                obj
      (setq obj-x 1
            obj-y 2)))

  (or (and (equal '(nil nil) (foo (make-instance 'test-class-1)))
           (equal '(1 2) (foo (make-instance 'test-class-1 :x 1 :y 2))))
      (do-test-error () "FOO (the one that reads) failed"))

  (or (let ((foo (make-instance 'test-class-1)))
        (bar foo)
        (or (and (equal (slot-value foo 'x) 1)
                 (equal (slot-value foo 'y) 2))
            (do-test-error () "BAR (the one that writes) failed")))))

  ;;   
;;;;;; things that bug fixes prompted.
  ;;   


(do-test "with-slots inside of lexical closures"
         ((:functions frog barg))
  ;; 6/20/86
  ;; The walker was confused about what (FUNCTION (LAMBDA ..)) meant.  It
  ;; didn't walk inside there.  Its sort of surprising this didn't get
  ;; caught sooner.

  (defun frog (fn foos)
    (and foos (cons (funcall fn (car foos)) (frog fn (cdr foos)))))

  (defun barg ()
    (let ((the-test-class (make-instance 'test-class-1 :x 0 :y 3)))
      (with-slots (x y)
                  the-test-class
        (frog #'(lambda (foo) (incf x) (decf y))
             (make-list 3)))))

  (or (equal (barg) '(2 1 0))
      (do-test-error t "lost")))

(do-test "redefinition of default method has proper effect"
         ((:functions foo))
  ;; 5/26/86
  ;; This was caused because the hair for trying to avoid making a
  ;; new discriminating function didn't know that changing the default
  ;; method was a reason to make a new discriminating function.  Fixed
  ;; by always making a new discriminating function when a method is
  ;; added or removed.  The template stuff should keep this from being
  ;; expensive.

  (defmethod foo ((x standard-class)) 'standard-class)
  (defmethod foo (x) 'default)
  (defmethod foo (x) 'new-default)

  (or (eq (foo nil) 'new-default)
      (do-test-error t "lost")))



(defvar *call-next-method-test-object* (make-instance 'standard-object))

(do-test "call-next-method passes original arguments"
         ((:functions foo))
  ;; 2/4/88
  ;; The spec says that call-next-method must pass the original arguments
  ;; to call-next-method when none are supplied.  This tests that.

  (defmethod foo ((x t))
    (unless (eq x *call-next-method-test-object*)
      (do-test-error t "got wrong value")))

  (defmethod foo ((x standard-object))
    (setq x nil)
    (call-next-method))

  (foo *call-next-method-test-object*)

  )

(do-test "call-next-method closures pass original arguments - 1"
         ((:functions foo))
  ;; 2/4/88
  ;; call-next-method must pass the original arguments even when it is
  ;; returned as a lexical closure with indefinite extent

  (defmethod foo ((x t))
    (unless (eq x *call-next-method-test-object*)
      (do-test-error t "got wrong value")))

  (defmethod foo ((x standard-object))
    (setq x nil)
    #'call-next-method)

  (funcall (foo *call-next-method-test-object*))

  )

(do-test "call-next-method closures pass original arguments - 2"
         ((:functions foo))
  ;; 2/4/88
  ;; call-next-method must pass the original arguments even when it is
  ;; returned as a lexical closure with indefinite extent

  (defmethod foo ((x t))
    (unless (eq x *call-next-method-test-object*)
      (do-test-error t "got wrong value")))

  (defmethod foo ((x standard-object))
    #'(lambda ()
        (setq x nil)
        (call-next-method)))

  (funcall (foo *call-next-method-test-object*))

  )

(do-test "call-next-method passes supplied arguments"
         ((:functions foo))
  ;; 2/4/88
  ;; The spec says that call-next-method must pass the original arguments
  ;; to call-next-method when none are supplied.  This tests that.

  (defmethod foo ((x t))
    (unless (eq x *call-next-method-test-object*)
      (do-test-error t "got wrong value")))

  (defmethod foo ((x standard-object))
    (call-next-method *call-next-method-test-object*))

  (foo (make-instance 'standard-object))

  )

(do-test "call-next-method closures pass supplied arguments - 1"
         ((:functions foo))
  ;; 2/4/88
  ;; call-next-method must pass the original arguments even when it is
  ;; returned as a lexical closure with indefinite extent

  (defmethod foo ((x t))
    (unless (eq x *call-next-method-test-object*)
      (do-test-error t "got wrong value")))

  (defmethod foo ((x standard-object))
    #'call-next-method)

  (funcall (foo (make-instance 'standard-object)) *call-next-method-test-object*)

  )

(do-test "call-next-method closures pass supplied arguments - 2"
         ((:functions foo))
  ;; 2/4/88
  ;; call-next-method must pass the original arguments even when it is
  ;; returned as a lexical closure with indefinite extent

  (defmethod foo ((x t))
    (unless (eq x *call-next-method-test-object*)
      (do-test-error t "got wrong value")))

  (defmethod foo ((x standard-object))
    #'(lambda (x)
        (call-next-method x)))

  (funcall (foo (make-instance 'standard-object)) 
	   *call-next-method-test-object*))


(do-test "call-next-method inside of default value form of &optional"
         ((:functions foo))
  ;; 5/3/88
  ;; call-next-method must work inside the default value forms of the
  ;; method's &mumble arguments.

  (defmethod foo1 ((x t) &optional y)
    (declare (ignore y))
    *call-next-method-test-object*)

  (defmethod foo1 ((x standard-object) &optional (y (call-next-method)))
    (list x y))

  (let ((object (make-instance 'standard-object)))
    (unless (equal (foo1 object) (list object *call-next-method-test-object*))
      (do-test-error t "Got wrong value"))))

(do-test "specifying :type when superclass doesn't"
         ((:classes foo bar))
  ;; 3/23/88
  ;; if a suclass specifies the :type slot option for a slot for which no
  ;; superclass specifies a type then the inheritance rule is just to take
  ;; the type specified by the subclass
  
  (defclass foo ()
       ((x)))

  (defclass bar (foo)
       ((x :type number))))


(do-test "Leaky next methods"
         ((:functions foo bar))
  ;; 6/23/88
  ;; Since I use special variables to communicate the next methods info,
  ;; there can be bugs which cause them to leak to the wrong method.

  (defmethod foo ((x standard-class))
    (bar x))

  (defmethod foo ((x class))
    (call-next-method))

  (defmethod foo ((x t))
    t)

  (defmethod bar ((x standard-class))
    (next-method-p))

  (unless (foo (find-class 't))
    (do-test-error nil "Method leaked.")))


;;;
;;; some simple tests for initialization protocols
;;; 8/5/88
;;; 
(proclaim '(special x-initform-fired y-initform-fired z-initform-fired))

(defclass initialization-test-1 ()
     ((x :initform (setq x-initform-fired 'x-initform))
      (y :initform (setq y-initform-fired 'y-initform))
      (z :initform (setq z-initform-fired 'z-initform))))

(defclass initialization-test-2 ()
     ((x :initform (setq x-initform-fired 'x-initform) :initarg :x)
      (y :initform (setq y-initform-fired 'y-initform) :initarg :y)
      (z :initform (setq z-initform-fired 'z-initform) :initarg :z)))

(defclass initialization-test-3 ()
     ((x :initform (setq x-initform-fired 'x-initform) :initarg :x)
      (y :initform (setq y-initform-fired 'y-initform) :initarg :y)
      (z :initform (setq z-initform-fired 'z-initform) :initarg :z))
  (:default-initargs :x 'x-default))

(defclass initalization-test-4 (initialization-test-3)
     ()
  (:default-initargs :z 'z-default))

(defclass initialization-test-5 (initialization-test-4)
     ()
  (:default-initargs :x 'x-default-from-5))
      
(do-test "shared-initialize with T argument and no initargs"
         ()

  (let (x-initform-fired y-initform-fired z-initform-fired)
    (let* ((class (find-class 'initialization-test-1))
           (instance (allocate-instance class)))

      (shared-initialize instance 't)

      (unless x-initform-fired (do-test-error nil "x initform not evaluated"))
      (unless y-initform-fired (do-test-error nil "y initform not evaluated"))
      (unless z-initform-fired (do-test-error nil "z initform not evaluated"))
      
      (unless (eq (slot-value instance 'x) 'x-initform)
        (do-test-error nil "Value of X doesn't match initform"))
      (unless (eq (slot-value instance 'y) 'y-initform)
        (do-test-error nil "Value of X doesn't match initform"))
      (unless (eq (slot-value instance 'z) 'z-initform)
        (do-test-error nil "Value of X doesn't match initform"))

      )))

(do-test "shared-initialize with T argument and initargs"
         ()

  (let (x-initform-fired y-initform-fired z-initform-fired)
    (let* ((class (find-class 'initialization-test-2))
           (instance (allocate-instance class)))

      (shared-initialize instance 't :y 'y-initarg)

      (unless x-initform-fired
        (do-test-error nil "x initform not evaluated"))
      (unless (not y-initform-fired)
        (do-test-error nil "y initform was evaluated"))
      (unless z-initform-fired
        (do-test-error nil "z initform not evaluated"))
      
      (unless (eq (slot-value instance 'x) 'x-initform)
        (do-test-error nil "Value of X doesn't match initform"))
      (unless (eq (slot-value instance 'y) 'y-initarg)
        (do-test-error nil "Value of X doesn't match initform"))
      (unless (eq (slot-value instance 'z) 'z-initform)
        (do-test-error nil "Value of X doesn't match initform"))

      )))

(do-test "initialization arguments rules test"
         ((:classes foo bar))

  (defclass foo ()
       ((x :initarg a)))

  (defclass bar (foo)
       ((x :initarg b))
    (:default-initargs a 1 b 2))

  (unless (and (equal (default-initargs (find-class 'bar) '())
                      '(b 2 a 1))
               (equal (default-initargs (find-class 'bar) '(a 3))
                      '(a 3 b 2))
               (equal (default-initargs (find-class 'bar) '(b 4))
                      '(b 4 a 1))
               (equal (default-initargs (find-class 'bar) '(a 1 a 2))
                      '(a 1 a 2 b 2)))
    (do-test-error nil "default-initargs got wrong value"))

  (unless (and (eq (slot-value (make-instance 'bar) 'x) 1)
               (eq (slot-value (make-instance 'bar 'a 3) 'x) 3)
               (eq (slot-value (make-instance 'bar 'b 4) 'x) 4)
               (eq (slot-value (make-instance 'bar 'a 1 'a 2) 'x) 1))
    (do-test-error nil "initialization in make-instance failed"))

  )


#| testing a pair of lists for equality bogus, '(a b c) <> '(b c a)

(do-test "more tests for initialization arguments rules"
         ((:classes foo fie bar baz))

  (defclass foo ()
       ((a :initform 'initform-foo-a)
        (b :initarg :foo-b)
        (c :initform 'initform-foo-c)
        (d :initarg :foo-d))
    (:default-initargs :foo-b 'initarg-foo-b
                       :foo-d 'initarg-foo-d))
  (defclass fie (foo)
       ((a :initform 'initform-fie-a)
        (b :initarg :fie-b)
        (c :initform 'initform-fie-c :allocation :class)
        (d :initarg :fie-d :allocation :class))
    (:default-initargs :fie-b 'initarg-fie-b
                       :fie-d 'initarg-fie-d))
  (defclass bar (foo)
       ((a :initform 'initform-bar-a)
        (b :initarg :bar-b)
        (c :initform 'initform-bar-c)
        (d :initarg :bar-d))
    (:default-initargs :bar-b 'initarg-bar-b
                       :bar-d 'initarg-bar-d))
  (defclass baz (fie bar)
       ((a :initform 'initform-baz-a)
        (b :initarg :baz-b)
        (c :initform 'initform-baz-c)
        (d :initarg :baz-d))
    (:default-initargs :baz-b 'initarg-baz-b
                       :baz-d 'initarg-baz-d))

  (unless (and (equal (default-initargs (find-class 'foo) ())
                      '(:foo-d initarg-foo-d 
			:foo-b initarg-foo-b))
               (equal (default-initargs (find-class 'fie) ())
                      '(:fie-b initarg-fie-b
                        :fie-d initarg-fie-d
                        :foo-b initarg-foo-b
                        :foo-d initarg-foo-d))
               (equal (default-initargs (find-class 'bar) ())
                      '(:bar-b initarg-bar-b
                        :bar-d initarg-bar-d
                        :foo-b initarg-foo-b
                        :foo-d initarg-foo-d))
               (equal (default-initargs (find-class 'baz) ())
                      '(:baz-b initarg-baz-b
                        :baz-d initarg-baz-d
                        :fie-b initarg-fie-b
                        :fie-d initarg-fie-d
                        :bar-b initarg-bar-b
                        :bar-d initarg-bar-d
                        :foo-b initarg-foo-b
                        :foo-d initarg-foo-d)))
    (do-test-error nil "default-initargs got wrong value"))
  )
|#
(do-test "initialization protocols"
         ((:classes foo))

  (let ((initform-for-x 'initform-x)
        (initform-for-y 'initform-y)
        (initform-for-z 'initform-z)
        (default-initarg-for-x 'default-initarg-x)
        (initarg-supplied-for-z 'initarg-z)
        instance-of-foo)
    
    (defclass foo ()
         ((x :initform initform-for-x :initarg :x)
          (y :initform initform-for-y :initarg :y)
          (z :initform initform-for-z :initarg :z))
      (:default-initargs :x default-initarg-for-x))

    (setq instance-of-foo (make-instance 'foo :z initarg-supplied-for-z))

    (unless (and (eq (slot-value instance-of-foo 'x)
                     default-initarg-for-x)
                 (eq (slot-value instance-of-foo 'y)
                     initform-for-y)
                 (eq (slot-value instance-of-foo 'z)
                     initarg-supplied-for-z))
      (do-test-error nil "initialization failed"))

    (setq instance-of-foo
          (reinitialize-instance (allocate-instance (find-class 'foo))
                                 :z initarg-supplied-for-z))

    (unless (and (not (slot-boundp instance-of-foo 'x))
                 (not (slot-boundp instance-of-foo 'y))
                 (eq (slot-value instance-of-foo 'z)
                     initarg-supplied-for-z))
      (do-test-error nil "initialization failed")))

  )

(do-test "update-instance-for-different-class"
         ((:classes foo bar))

  (let ((initform-for-x 'initform-x)
        (initform-for-y 'initform-y)
        (default-initarg-for-x 'default-initarg-x)
        (initform-for-z 'initform-z)
        (initform-for-u 'initform-u)
        (initform-for-v 'initform-v)
        (default-initarg-for-z 'default-intiarg-z)
        (initarg-supplied-for-v 'initarg-v)
        instance-of-foo
        instance-of-bar)

    (defclass foo ()
         ((x :initform initform-for-x :initarg :x)
          (y :initform initform-for-y :initarg :y))
      (:default-initargs :x default-initarg-for-x))

    (defclass bar ()
         ((x :initform initform-for-x :initarg :x)
          (y :initform initform-for-y :initarg :y)
          (z :initform initform-for-z :initarg :z)
          (u :initform initform-for-u :initarg :u)
          (v :initform initform-for-v :initarg :v))
      (:default-initargs :z default-initarg-for-z))

    (setq instance-of-foo (make-instance 'foo))
    (setq instance-of-bar (allocate-instance (find-class 'bar)))
    (update-instance-for-different-class instance-of-foo instance-of-bar
                                         :v initarg-supplied-for-v)
    (unless (and (not (slot-boundp instance-of-bar 'x))
                 (not (slot-boundp instance-of-bar 'y))
                 (eq (slot-value instance-of-bar 'z) initform-for-z)
                 (eq (slot-value instance-of-bar 'u) initform-for-u)
                 (eq (slot-value instance-of-bar 'v) initarg-supplied-for-v))
      (do-test-error nil "initialization failed"))))

(do-test "only needed forms should be evaluated in initializing instances"
         ((:classes foo))

  (defclass foo ()
    ((x :initform (do-test-error nil "x initform was evaluated")
        :initarg :x)
     (y :initform (do-test-error nil "y initform was evaluated")
        :initarg :y)
     (z :initform (do-test-error nil "z initform was evaluated")
        :initarg :z))
    (:default-initargs :y 1
                       :z (do-test-error nil "z default initarg was evaluated")))

  (make-instance 'foo :x 1 :z 1))


;;;
;;; We need to put these class defenitions in top level.
;;;

(defclass class-for-testing-change-class-1 ()
  ((x :initform 'x :accessor class-1-x)
   (y :initform 'y :accessor class-1-y)))

(defclass class-for-testing-change-class-2 ()
  ((a :initform 'a :accessor class-2-a)
   (b :initform 'b :accessor class-2-b)))

(do-test "update-instance-for-different-class/change-class"
         ()

  (defmethod update-instance-for-different-class
             ((previous class-for-testing-change-class-1)
              (current class-for-testing-change-class-2)
              &rest initargs)
    (declare (ignore initargs))
    (setf (class-2-a current) (class-1-x previous))
    (setf (class-2-b current) (class-1-y previous)))

  (let ((f1 (make-instance 'class-for-testing-change-class-1))
        (f2 (make-instance 'class-for-testing-change-class-1)))
    (change-class f1 (find-class 'class-for-testing-change-class-2))
    (unless (and (eq (class-2-a f1) (class-1-x f2))
                 (eq (class-2-b f1) (class-1-y f2)))
      (do-test-error nil "change class failed")))
  )

(cleanup-do-test '((:classes class-for-testing-redefined-class)
                   (:functions test-x test-y test-a)
                   (:setf-generic-functions class-x class-y)))
                    
(let (foo)
  (defclass class-for-testing-redefined-class ()
    ((x :initform 'x :accessor test-x)
     (y :initform 'y :accessor test-y)))

  (setq foo (make-instance 'class-for-testing-redefined-class))

  (defclass class-for-testing-redefined-class ()
    ((a :initform 0 :accessor test-a)
     (y :initform 1 :accessor test-y)))

  (do-test "update-instance-for-redefined-class/make-instances-obsolete(1)"
        ()
    (unless (and (eq (test-a foo) 0)
                 (eq (test-y foo) 'y))
      (do-test-error nil "default behavior failed"))))

(cleanup-do-test '((:classes x-y-pos)
                   (:functions pos-x pos-y pos-rho pos-theta)
                   (:setf-generic-functions pos-x pos-y pos-rho pos-theta)))

(let (old-pos new-pos)

  (defclass x-y-pos ()
    ((x :initform 3 :accessor pos-x)
     (y :initform 4 :accessor pos-y)))
  
  (setq old-pos (make-instance 'x-y-pos))
  
  (defclass x-y-pos ()
    ((rho :initform 0 :accessor pos-rho)
     (theta :initform 0 :accessor pos-theta)))
  
  (do-test "update-instance-for-redefined-class/make-instances-obsolete(2)"
        ()

    (defmethod update-instance-for-redefined-class :before
               ((pos x-y-pos) added deleted plist &key)
      ;; Transform the x-y coordinates to polar coordinates
      ;; and store into the new slots
      (let ((x (getf plist 'x))
            (y (getf plist 'y)))
        (setf (pos-rho pos) (sqrt (+ (* x x) (* y y)))
              (pos-theta pos) (atan y x))))

    (defmethod pos-x ((pos x-y-pos))
      (with-slots (rho theta) pos (* rho (cos theta))))

    (defmethod (setf pos-x) (new-x (pos x-y-pos))
      (with-slots (rho theta) pos
        (let ((y (pos-y pos)))
          (setq rho (sqrt (+ (* new-x new-x) (* y y)))
                theta (atan y new-x))
          new-x)))
    
    (defmethod pos-y ((pos x-y-pos))
      (with-slots (rho theta) pos (* rho (sin theta))))
  
    (defmethod (setf pos-y) (new-y (pos x-y-pos))
      (with-slots (rho theta)
        (let ((x (pos-x pos)))
          (setq rho (sqrt (+ (* x x) (* new-y new-y)))
                theta (atan new-y x))
          new-y)))

    (unless (and (equalp 5 (pos-rho old-pos))
                 (equalp (* 5 (cos (atan 4 3))) (pos-x old-pos))
                 (equalp (* 5 (sin (atan 4 3))) (pos-y old-pos)))
      (do-test-error nil "specialized behaivior failed"))
    ))

(cleanup-do-test '((:classes class-for-testing-redefined-class
                             test-obsolete-class)
                   (:functions test-x test-y test-a)
                   (:setf-generic-functions class-x class-y)))

(defclass test-obsolete-class (standard-class) ())

(defmethod check-super-metaclass-compatibility ((x test-obsolete-class)
                                                (y standard-class))
  't)
                    
(let ((foo 'nil)
      bar)
  (defmethod make-instances-obsolete ((x test-obsolete-class))
    (setq foo 'called)
    (call-next-method))

  (defclass class-for-testing-redefined-class ()
    ((x :initform 'x :accessor test-x)
     (y :initform 'y :accessor test-y))
    (:metaclass test-obsolete-class))

  (setq bar (make-instance 'class-for-testing-redefined-class))

  (defclass class-for-testing-redefined-class ()
    ((a :initform 0 :accessor test-a)
     (y :initform 1 :accessor test-y)))

  (do-test "update-instance-for-redefined-class/make-instances-obsolete(3)"
        ()
    (unless (and (eq (test-a bar) 0)
                 (eq (test-y bar) '1)
                 (eq foo 'called))
      (do-test-error nil "imcompatible class change failed"))))

(cleanup-do-test '((:classes class-for-testing-redefined-class)
                   (:functions test-x test-y test-a)
                   (:setf-generic-functions class-x class-y)))
                    
(let (foo)
  (defclass class-for-testing-redefined-class ()
    ((x :initform 'x :accessor test-x)
     (y :initform 'y :accessor test-y)))

  (setq foo (make-instance 'class-for-testing-redefined-class))

  (make-instances-obsolete 'class-for-testing-redefined-class)
  
  (do-test "update-instance-for-redefined-class/make-instances-obsolete(4)"
        ()
    (unless (and (eq (test-x foo) 'x)
                 (eq (test-y foo) 'y))
      (do-test-error nil "call make-instances-obsolete by hand failed"))))

(do-test "slot-mumble functions"
         ((:variables foo1 bar1)
          (:classes foo bar))

  (defclass foo-sm ()
    ((x :initform 'x :allocation :class)
     (y :initform 'y)
     (z :allocation :class)
     (u)))

  (defclass bar-sm ()
    ((x :initform 'x :allocation :class)
     (y :initform 'y)
     (z :allocation :class)
     (u))
    (:metaclass funcallable-standard-class))

  (defmethod slot-missing ((class standard-class)
                           (instance foo-sm)
                           slot-name operation &optional new-value)
    (list* class instance slot-name operation new-value))
  
  (defmethod slot-missing ((class standard-class)
                           (instance bar-sm)
                           slot-name operation &optional new-value)
    (list* class instance slot-name operation new-value))

  (defmethod slot-unbound ((class standard-class)
                           (instance foo-sm)
                           slot-name)
    (list class instance slot-name))
  
  (defmethod slot-unbound ((class funcallable-standard-class)
                           (instance bar-sm)
                           slot-name)
    (list class instance slot-name))
  
  (setq foo1 (make-instance 'foo-sm))
  (setq bar1 (make-instance 'bar-sm))

  (flet ((test1 (instance)
           (and (eq (slot-value instance 'x) 'x)
                (eq (slot-value instance 'y) 'y)
                (equal (slot-value instance 'z)
                       (list (class-of instance) instance 'z))
                (equal (slot-value instance 'u)
                       (list (class-of instance) instance 'u))
                (slot-boundp instance 'x)
                (slot-boundp instance 'y)
                (not (slot-boundp instance 'z))
                (not (slot-boundp instance 'u))))
         (test2 (instance)
           (and (not (slot-boundp instance 'x))
                (not (slot-boundp instance 'y))
                (slot-boundp instance 'z)
                (slot-boundp instance 'u)
                (equal (slot-value instance 'x)
                       (list (class-of instance) instance 'x))
                (equal (slot-value instance 'y)
                       (list (class-of instance) instance 'y))
                (eq (slot-value instance 'z) 'z)
                (eq (slot-value instance 'u) 'u)))
         (test3 (instance)
           (and (slot-exists-p instance 'x)
                (slot-exists-p instance 'y)))
         (test4 (instance)
           (and (equal (slot-value instance 'a)
                       (list (class-of instance)
                             instance
                             'a
                             'slot-value))
                (equal (setf (slot-value instance 'a) 'b)
                       (list* (class-of instance)
                              instance
                              'a
                              'setf
                              'b))
                (equal (slot-boundp instance 'a)
                       (list (class-of instance)
                             instance
                             'a
                             'slot-boundp))

                (equal (slot-makunbound instance 'a)
                       (list (class-of instance)
                             instance
                             'a
                             'slot-makunbound)))))

        (unless (and (test1 foo1)
                     (test1 bar1))
          (do-test-error nil "slot functions test1 failed"))

        (slot-makunbound foo1 'x)
        (slot-makunbound foo1 'y)
        (setf (slot-value foo1 'z) 'z)
        (setf (slot-value foo1 'u) 'u)
        (slot-makunbound bar1 'x)
        (slot-makunbound bar1 'y)
        (setf (slot-value bar1 'z) 'z)
        (setf (slot-value bar1 'u) 'u)

        (unless (and (test2 foo1)
                     (test2 bar1))
          (do-test-error nil "slot functions test2 failed"))

        (unless (and (test3 foo1)
                     (test3 bar1))
          (do-test-error nil "slot functions test3 failed"))
        
        (unless (and (test4 foo1)
                     (test4 bar1))
          (do-test-error nil "slot function test4 failed"))
        ))


(cleanup-do-test '((:classes foo-sm bar-sm)
                   (:functions foo-x foo-y bar-x bar-y)))

(defclass foo ()
  ((x :initform 'x :allocation :class :reader foo-x)
   (y :initform 'y :reader foo-y)))

(defclass bar ()
  ((x :allocation :class :reader bar-x)
   (y :reader bar-y)))

(do-test "slot-value/slot-unbound for pv optimization case and :reader method"
         ((:functions get-foo-x get-foo-y get-x-1 get-y-1
                      get-bar-x get-bar-y get-x-2 get-y-2)
          (:variables foo1 bar1))

  (defmethod get-foo-x ((foo1 foo))
    (slot-value foo1 'x))
  (defmethod get-foo-y ((foo1 foo))
    (slot-value foo1 'y))

  (defun get-x-1 (foo1)
    (slot-value foo1 'x))
  (defun get-y-1 (foo1)
    (slot-value foo1 'y))

  (defmethod slot-unbound ((class standard-class) (instance foo) slot-name)
    (list class instance slot-name))
  
  (setq foo1 (make-instance 'foo))
  
  (unless (and (eq (get-foo-x foo1) 'x)
               (eq (get-foo-y foo1) 'y)
               (eq (get-x-1 foo1) 'x)
               (eq (get-y-1 foo1) 'y)
               (eq (foo-x foo1) 'x)
               (eq (foo-y foo1) 'y))
    (do-test-error nil "slot-value failed"))

  (unless (and (eq (slot-makunbound foo1 'x) foo1)
               (eq (slot-makunbound foo1 'y) foo1))
    (do-test-error nil "slot-makunbound returns wrong value"))

  (unless (and (equal (get-foo-x foo1)
                      (list (find-class 'foo) foo1 'x))
               (equal (get-foo-y foo1)
                      (list (find-class 'foo) foo1 'y))
               (equal (get-x-1 foo1)
                      (list (find-class 'foo) foo1 'x))
               (equal (get-y-1 foo1)
                      (list (find-class 'foo) foo1 'y))
               (equal (foo-x foo1)
                      (list (find-class 'foo) foo1 'x))
               (equal (foo-y foo1)
                      (list (find-class 'foo) foo1 'y)))
    (do-test-error nil "slot-value/slot-unbound failed"))

  (defmethod get-bar-x ((bar1 bar))
    (slot-value bar1 'x))
  (defmethod get-bar-y ((bar1 bar))
    (slot-value bar1 'y))

  (defun get-x-2 (bar1)
    (slot-value bar1 'x))
  (defun get-y-2 (bar1)
    (slot-value bar1 'y))

  (defmethod slot-unbound ((class standard-class) (instance bar) slot-name)
    (list class instance slot-name))

  (setq bar1 (make-instance 'bar))

  (unless (and (equal (get-bar-x bar1)
                      (list (find-class 'bar) bar1 'x))
               (equal (get-bar-y bar1)
                      (list (find-class 'bar) bar1 'y))
               (equal (get-x-2 bar1)
                      (list (find-class 'bar) bar1 'x))
               (equal (get-y-2 bar1)
                      (list (find-class 'bar) bar1 'y))
               (equal (bar-x bar1)
                      (list (find-class 'bar) bar1 'x))
               (equal (bar-y bar1)
                      (list (find-class 'bar) bar1 'y)))
    (do-test-error nil "slot-value/slot-unbound failed")))

  
(do-test "defmethod/call-next-method/&aux variable"
         ((:variables foo1 bar1)
          (:classes foo bar)
          (:functions test1 test2 test3))

  (defclass foo ()
    ((x :initform 0)
     (y :initform 1)))

  (defclass bar (foo) ())

  (defmethod test1 ((foo1 foo) &aux aux-arg)
    (setq aux-arg (list foo1)))

  (defmethod test1 ((bar1 bar) &aux aux-arg)
    (setq aux-arg (list (list bar1)))
    (call-next-method)
    aux-arg)

  (setq foo1 (make-instance 'foo))
  (setq bar1 (make-instance 'bar))
  (unless (and (equal (test1 foo1) (list foo1))
               (equal (test1 bar1) (list (list bar1))))
    (do-test-error nil "defmethod with call-next-method and &aux failed")))

;;;
;;; defconstructor tests
;;;
(format t
        "~%Testing defconstructor [methods, default/initform, slot-filling]")

(defun check-slots (object &rest names-and-values)
  (doplist (name value) names-and-values
    (unless (if (eq value :unbound)
                (not (slot-boundp object name))
                (and (slot-boundp object name)
                     (eq (slot-value object name) value)))
      (return-from check-slots nil)))
  't)

;;;
;;; [methods, default/initform, slot-filling]
;;; methods:           [nil, :after, t]
;;; default/initform:  [nil, :constant, t]
;;; slot-filling:      [:instance, :class]
;;;
;;; supplied:          [nil, :constant, t]


(cleanup-do-test '((:classes foo1 foo2 foo3 foo4
                             foo5 foo6 foo7 foo8
                             foo9 foo10 foo11 foo12)
                   (:variables *a-initform* *b-initform* *c-initform*
                               *a-default* *b-default* *c-default*
                               *a-supplied* *b-supplied* *c-supplied*)
                   (:functions foo1-test1 foo1-test2 foo1-test3
                               foo2-test1 foo2-test2 foo2-test3
                               foo3-test1 foo3-test2 foo3-test3
                               foo4-test1 foo4-test2 foo4-test3
                               foo5-test1 foo5-test2 foo5-test3
                               foo6-test1 foo6-test2 foo6-test3
                               foo7-test1 foo7-test2 foo7-test3
                               foo8-test1 foo8-test2 foo8-test3
                               foo9-test1 foo9-test2 foo9-test3
                               foo10-test1 foo10-test2 foo10-test3
                               foo11-test1 foo11-test2 foo11-test3
                               foo12-test1 foo12-test2 foo12-test3)))

(defvar *a-initform* 'a-initform)
(defvar *b-initform* 'b-initform)
(defvar *c-initform* 'c-initform)
(defvar *a-default* 'a-default)
(defvar *b-default* 'b-default)
(defvar *c-default* 'c-default)
(defvar *a-supplied* 'a-supplied)
(defvar *b-supplied* 'b-supplied)
(defvar *c-supplied* 'c-supplied)

;;;
;;; foo1
;;; [methods, default/initform, slot-filing]
;;; (t,       t,                :class)

(defclass foo1 ()
    ((a :initarg :a :initform *a-initform*)
     (b :initarg :b :initform *b-initform*)
     (c :initarg :c :allocation :class :initform *c-initform*))
  (:default-initargs :b *b-default* :c *c-default*))

(defmethod *initialize-instance :before ((instance foo1) &rest ignore)
  (declare (ignore ignore))
  ())

(do-test "defconstructor (t,       t,                :class) (1)"
         ((:functions foo1-test1 foo1-test2 foo1-test3))

  (defconstructor foo1-test1 foo1 ())
  (defconstructor foo1-test2 foo1 () :a 1 :b 2 :c 3)
  (defconstructor foo1-test3 foo1 (a b c) :a a :b b :c c)

  (dotimes (i 2)                                ;Do it twice to be sure that
                                                ;the constructor works more
                                                ;than just the first time.
    (unless (check-slots (foo1-test1)
                         'a *a-initform*
                         'b *b-default*
                         'c *c-default*)
      (do-test-error nil "no initargs failed (~D time)" i)))

  (dotimes (i 2)
    (unless (check-slots (foo1-test2) 'a '1 'b '2 'c '3)
      (do-test-error nil "constant initargs failed (~D time)" i)))

  (dotimes (i 2)
    (unless (check-slots (foo1-test3 *a-supplied* *b-supplied* *c-supplied*)
                         'a *a-supplied*
                         'b *b-supplied*
                         'c *c-supplied*)
      (do-test-error nil "non constant initargs failed (~D time)" i))))
;;;
;;; foo2
;;; [methods, default/initform, slot-filling]
;;; (t,       t,                :class)

(defclass foo2 ()
    ((a :initform *a-initform* :initarg :a)
     (b :initform *b-initform* :initarg :b)
     (c :allocation :class :initform *c-initform* :initarg :c))
  (:default-initargs :b *b-default*))

(defmethod *initialize-instance :before ((instance foo2) &rest ignore)
  (declare (ignore ignore))
  ())

(do-test "defconstructor (t,       t,                :class) (2)"
         ((:functions foo2-test1 foo2-test2 foo2-test3))

  (defconstructor foo2-test1 foo2 ())
  (defconstructor foo2-test2 foo2 () :a 1 :b 2 :c 3)
  (defconstructor foo2-test3 foo2 (a b c) :a a
                                          :b b
                                          :c c)
  
  (dotimes (i 2)
    (unless (check-slots (foo2-test1) 'a *a-initform*
                                      'b *b-default*
                                      'c *c-initform*)
      (do-test-error nil "no initargs failed (~D time)" i)))

  (dotimes (i 2)
    (unless (check-slots (foo2-test2) 'a '1 'b '2 'c '3)
      (do-test-error nil "constant initargs failed (~D time)" i)))

  (dotimes (i 2)
    (unless (check-slots (foo2-test3 *a-supplied* *b-supplied* *c-supplied*)
                         'a *a-supplied*
                         'b *b-supplied*
                         'c *c-supplied*)
      (do-test-error nil "non constant initargs failed (~D time)" i))))

;;;
;;; foo3
;;; [methods, default/initform, slot-filling]
;;; (t,       t,                :instance)

(defclass foo3 ()
    ((a :initform *a-initform* :initarg :a)
     (b :initform *b-initform* :initarg :b)
     (c :allocation :class :initform *c-initform*))
  (:default-initargs :b *b-default*))

(defmethod *initialize-instance :before ((instance foo3) &rest ignore)
  (declare (ignore ignore))
  ())

(do-test "defconstructor (t,       t,                :instance) (1)"
         ((:functions foo3-test1 foo3-test2 foo3-test3))

  (defconstructor foo3-test1 foo3 ())
  (defconstructor foo3-test2 foo3 () :a 1 :b 2)
  (defconstructor foo3-test3 foo3 (a b) :a a :b b)
  
  
  (dotimes (i 2)
    (unless (check-slots (foo3-test1) 'a *a-initform*
                                      'b *b-default*
                                      'c *c-initform*)
      (do-test-error nil "no initargs failed (~D time)" i)))

  (dotimes (i 2)
    (unless (check-slots (foo3-test2) 'a '1 'b '2 'c *c-initform*)
      (do-test-error nil "constant initargs failed (~D time)" i)))

  (dotimes (i 2)
    (unless (check-slots (foo3-test3 *a-supplied* *b-supplied*)
                         'a *a-supplied*
                         'b *b-supplied*
                         'c *c-initform*)
      (do-test-error nil "non constant initargs failed (~D time)" i))))

;;;
;;; foo4
;;; [methods, default/initform, slot-filling]
;;; (t,       t,                :instance)

(defclass foo4 ()
    ((a :initform *a-initform* :initarg :a)
     (b :initform *b-initform* :initarg :b)
     (c :allocation :class))
  (:default-initargs :b *b-default*))

(defmethod *initialize-instance :before ((instance foo4) &rest ignore)
  (declare (ignore ignore))
  ())

(do-test "defconstructor (t,       t,                :instance) (2)"
         ((:functions foo4-test1 foo4-test2 foo4-test3))

  (defconstructor foo4-test1 foo4 ())
  (defconstructor foo4-test2 foo4 () :a 1 :b 2)
  (defconstructor foo4-test3 foo4 (a b) :a a :b b)

  (dotimes (i 2)
    (unless (check-slots (foo4-test1) 'a *a-initform*
                                      'b *b-default*
                                      'c :unbound)
      (do-test-error nil "no initargs failed (~D time)" i)))

  (dotimes (i 2)
    (unless (check-slots (foo4-test2) 'a '1 'b '2 'c :unbound)
      (do-test-error nil "constant initargs failed (~D time)" i)))

  (dotimes (i 2)
    (unless (check-slots (foo4-test3 *a-supplied* *b-supplied*)
                         'a *a-supplied*
                         'b *b-supplied*
                         'c :unbound)
      (do-test-error nil "non constant initargs failed (~D time)" i))))

;;;
;;; foo5
;;; [methods, default/initform, slot-filling]
;;; (:after,  t,                :class)

(defclass foo5 ()
    ((a :initarg :a :initform *a-initform*)
     (b :initarg :b :initform *b-initform*)
     (c :initarg :c :allocation :class :initform *c-initform*))
  (:default-initargs :b *b-default* :c *c-default*))

(defmethod *initialize-instance :after ((instance foo5) &rest ignore)
  (declare (ignore ignore))
  ())

(do-test "defconstructor (:after,  t,                :class) (1)"
         ((:functions foo5-test1 foo5-test2 foo5-test3))

  (defconstructor foo5-test1 foo5 ())
  (defconstructor foo5-test2 foo5 () :a 1 :b 2 :c 3)
  (defconstructor foo5-test3 foo5 (a b c) :a a
                                          :b b
                                          :c c)

  (dotimes (i 2)
    (unless (check-slots (foo5-test1) 'a *a-initform*
                                      'b *b-default*
                                      'c *c-default*)
      (do-test-error nil "no initargs failed (~D time)" i)))

  (dotimes (i 2)
    (unless (check-slots (foo5-test2) 'a '1 'b '2 'c '3)
      (do-test-error nil "constant initargs failed (~D time)" i)))

  (dotimes (i 2)
    (unless (check-slots (foo5-test3 *a-supplied* *b-supplied* *c-supplied*)
                         'a *a-supplied*
                         'b *b-supplied*
                         'c *c-supplied*)
      (do-test-error nil "non constant initargs failed (~D time)" i))))

;;;
;;; foo6
;;; [methods, default/initform, slot-filling]
;;; (:after,  t,                :class)

(defclass foo6 ()
    ((a :initform *a-initform* :initarg :a)
     (b :initform *b-initform* :initarg :b)
     (c :allocation :class :initform *c-initform* :initarg :c))
  (:default-initargs :b *b-default*))

(defmethod *initialize-instance :after ((instance foo6) &rest ignore)
  (declare (ignore ignore))
  ())

(do-test "defconstructor (:after,  t,                :class) (2)"
         ((:functions foo6-test1 foo6-test2 foo6-test3))

  (defconstructor foo6-test1 foo6 ())
  (defconstructor foo6-test2 foo6 () :a 1 :b 2 :c 3)
  (defconstructor foo6-test3 foo6 (a b c) :a a
                                          :b b
                                          :c c)
  
  (dotimes (i 2)
    (unless (check-slots (foo6-test1) 'a *a-initform*
                                      'b *b-default*
                                      'c *c-initform*)
      (do-test-error nil "no initargs failed (~D time)" i)))

  (dotimes (i 2)
    (unless (check-slots (foo6-test2) 'a '1 'b '2 'c '3)
      (do-test-error nil "constant initargs failed (~D time)" i)))

  (dotimes (i 2)
    (unless (check-slots (foo6-test3 *a-supplied* *b-supplied* *c-supplied*)
                         'a *a-supplied*
                         'b *b-supplied*
                         'c *c-supplied*)
      (do-test-error nil "non constant initargs failed (~D time)" i))))

;;;
;;; foo7
;;; [methods, default/initform, slot-filling]
;;; (:after,  t,                :instance)

(defclass foo7 ()
    ((a :initform *a-initform* :initarg :a)
     (b :initform *b-initform* :initarg :b)
     (c :allocation :class :initform *c-initform*))
  (:default-initargs :b *b-default*))

(defmethod *initialize-instance :after ((instance foo7) &rest ignore)
  (declare (ignore ignore))
  ())

(do-test "defconstructor (:after,  t,                :instance) (1)"
         ((:functions foo7-test1 foo7-test2 foo7-test3))

  (defconstructor foo7-test1 foo7 ())
  (defconstructor foo7-test2 foo7 () :a 1 :b 2)
  (defconstructor foo7-test3 foo7 (a b) :a a :b b)
  
  (dotimes (i 2)
    (unless (check-slots (foo7-test1) 'a *a-initform*
                                      'b *b-default*
                                      'c *c-initform*)
      (do-test-error nil "no initargs failed (~D time)" i)))

  (dotimes (i 2)
    (unless (check-slots (foo7-test2) 'a '1 'b '2 'c *c-initform*)
      (do-test-error nil "constant initargs failed (~D time)" i)))

  (dotimes (i 2)
    (unless (check-slots (foo7-test3 *a-supplied* *b-supplied*)
                         'a *a-supplied*
                         'b *b-supplied*
                         'c *c-initform*)
      (do-test-error nil "non constant initargs failed (~D time)" i))))

;;;
;;; foo8
;;; [methods, default/initform, slot-filling]
;;; (:after,  t,                :instance)

(defclass foo8 ()
    ((a :initform *a-initform* :initarg :a)
     (b :initform *b-initform* :initarg :b)
     (c :allocation :class))
  (:default-initargs :b *b-default*))

(defmethod *initialize-instance :after ((instance foo8) &rest ignore)
  (declare (ignore ignore))
  ())

(do-test "defconstructor (:after,  t,                :instance) (2)"
         ((:functions foo8-test1 foo8-test2 foo8-test3))

  (defconstructor foo8-test1 foo8 ())
  (defconstructor foo8-test2 foo8 () :a 1 :b 2)
  (defconstructor foo8-test3 foo8 (a b) :a a :b b)

  (dotimes (i 2)
    (unless (check-slots (foo8-test1) 'a *a-initform*
                                      'b *b-default*
                                      'c :unbound)
      (do-test-error nil "no initargs failed (~D time)" i)))

  (dotimes (i 2)
    (unless (check-slots (foo8-test2) 'a '1 'b '2 'c :unbound)
      (do-test-error nil "constant initargs failed (~D time)" i)))

  (dotimes (i 2)
    (unless (check-slots (foo8-test3 *a-supplied* *b-supplied*)
                         'a *a-supplied*
                         'b *b-supplied*
                         'c :unbound)
      (do-test-error nil "non constant initargs failed (~D time)" i))))

;;;
;;; foo9
;;; [methods, default/initform, slot-filling]
;;; (nil,     t,                :class)

(defclass foo9 ()
    ((a :initarg :a :initform *a-initform*)
     (b :initarg :b :initform *b-initform*)
     (c :initarg :c :allocation :class :initform *c-initform*))
  (:default-initargs :b *b-default* :c *c-default*))

(do-test "defconstructor (nil,     t,                :class) (1)"
         ((:functions foo9-test1 foo9-test2 foo9-test3))

  (defconstructor foo9-test1 foo9 ())
  (defconstructor foo9-test2 foo9 () :a 1 :b 2 :c 3)
  (defconstructor foo9-test3 foo9 (a b c) :a a
                                          :b b
                                          :c c)
  
  (dotimes (i 2)
    (unless (check-slots (foo9-test1) 'a *a-initform*
                                      'b *b-default*
                                      'c *c-default*)
      (do-test-error nil "no initargs failed (~D time)" i)))

  (dotimes (i 2)
    (unless (check-slots (foo9-test2) 'a '1 'b '2 'c '3)
      (do-test-error nil "constant initargs failed (~D time)" i)))

  (dotimes (i 2)
    (unless (check-slots (foo9-test3 *a-supplied* *b-supplied* *c-supplied*)
                         'a *a-supplied*
                         'b *b-supplied*
                         'c *c-supplied*)
      (do-test-error nil "non constant initargs failed (~D time)" i))))
    
;;;
;;; foo10
;;; [methods, default/initform, slot-filling]
;;; (nil,     t,                :class)

(defclass foo10 ()
    ((a :initform *a-initform* :initarg :a)
     (b :initform *b-initform* :initarg :b)
     (c :allocation :class :initform *c-initform* :initarg :c))
  (:default-initargs :b *b-default*))

(do-test "defconstructor (nil,     t,                :class) (2)"
         ((:functions foo10-test1 foo10-test2 foo10-test3))

  (defconstructor foo10-test1 foo10 ())
  (defconstructor foo10-test2 foo10 () :a 1 :b 2 :c 3)
  (defconstructor foo10-test3 foo10 (a b c) :a a
                                            :b b
                                            :c c)
  (dotimes (i 2)
    (unless (check-slots (foo10-test1) 'a *a-initform*
                                       'b *b-default*
                                       'c *c-initform*)
      (do-test-error nil "no initargs failed (~D time)" i)))

  (dotimes (i 2)
    (unless (check-slots (foo10-test2) 'a '1 'b '2 'c '3)
      (do-test-error nil "constant initargs failed (~D time)" i)))

  (dotimes (i 2)
    (unless (check-slots (foo10-test3 *a-supplied* *b-supplied* *c-supplied*)
                         'a *a-supplied*
                         'b *b-supplied*
                         'c *c-supplied*)
      (do-test-error nil "non constant initargs failed (~D time)" i))))

;;;
;;; foo11
;;; [methods, default/initform, slot-filling]
;;; (nil,     t,                :instance)

(defclass foo11 ()
    ((a :initform *a-initform* :initarg :a)
     (b :initform *b-initform* :initarg :b)
     (c :allocation :class :initform *c-initform*))
  (:default-initargs :b *b-default*))

(do-test "defconstructor (nil,     t,                :instance) (1)"
         ((:functions foo11-test1 foo11-test2 foo11-test3))

  (defconstructor foo11-test1 foo11 ())
  (defconstructor foo11-test2 foo11 () :a 1 :b 2)
  (defconstructor foo11-test3 foo11 (a b) :a a :b b)
  
  (dotimes (i 2)
    (unless (check-slots (foo11-test1) 'a *a-initform*
                                       'b *b-default*
                                       'c *c-initform*)
      (do-test-error nil "no initargs failed (~D time)" i)))

  (dotimes (i 2)
    (unless (check-slots (foo11-test2) 'a '1 'b '2 'c *c-initform*)
      (do-test-error nil "constant initargs failed (~D time)" i)))

  (dotimes (i 2)
    (unless (check-slots (foo11-test3 *a-supplied* *b-supplied*)
                         'a *a-supplied*
                         'b *b-supplied*
                         'c *c-initform*)
      (do-test-error nil "non constant initargs failed (~D time)" i))))

;;;
;;; foo12
;;; [methods, default/initform, slot-filling]
;;; (nil,     t,                :instance)

(defclass foo12 ()
    ((a :initform *a-initform* :initarg :a)
     (b :initform *b-initform* :initarg :b)
     (c :allocation :class))
  (:default-initargs :b *b-default*))

(defmethod *initialize-instance :after ((instance foo12) &rest ignore)
  (declare (ignore ignore))
  ())

(do-test "defconstructor (nil,     t,                :instance) (2)"
         ((:functions foo12-test1 foo12-test2 foo12-test3))

  (defconstructor foo12-test1 foo12 ())
  (defconstructor foo12-test2 foo12 () :a 1 :b 2)
  (defconstructor foo12-test3 foo12 (a b) :a a :b b)

  (dotimes (i 2)
    (unless (check-slots (foo12-test1) 'a *a-initform*
                                       'b *b-default*
                                       'c :unbound)
      (do-test-error nil "no initargs failed (~D time)" i)))

  (dotimes (i 2)
    (unless (check-slots (foo12-test2) 'a '1 'b '2 'c :unbound)
      (do-test-error nil "constant initargs failed (~D time)" i)))

  (dotimes (i 2)
    (unless (check-slots (foo12-test3 *a-supplied* *b-supplied*)
                         'a *a-supplied*
                         'b *b-supplied*
                         'c :unbound)
      (do-test-error nil "non constant initargs failed (~D time)" i))))


(cleanup-do-test '((:classes bar1 bar2 bar3 bar4
                             bar5 bar6 bar7 bar8
                             bar9 bar10 bar11 bar12)
                   (:functions bar1-test1 bar1-test2 bar1-test3
                               bar2-test1 bar2-test2 bar2-test3
                               bar3-test1 bar3-test2 bar3-test3
                               bar4-test1 bar4-test2 bar4-test3
                               bar5-test1 bar5-test2 bar5-test3
                               bar6-test1 bar6-test2 bar6-test3
                               bar7-test1 bar7-test2 bar7-test3
                               bar8-test1 bar8-test2 bar8-test3
                               bar9-test1 bar9-test2 bar9-test3
                               bar10-test1 bar10-test2 bar10-test3
                               bar11-test1 bar11-test2 bar11-test3
                               bar12-test1 bar12-test2 bar12-test3)))

;;;
;;; bar1
;;; [methods, default/initform, slot-filling]
;;; (t,       :constant,        :class)

(defclass bar1 ()
    ((a :initarg :a :initform 1)
     (b :initarg :b :initform 2)
     (c :initarg :c :allocation :class :initform 3))
  (:default-initargs :b 5 :c 6))

(defmethod *initialize-instance :before ((instance bar1) &rest ignore)
  (declare (ignore ignore))
  ())

(do-test "defconstructor (t,       :constant,        :class) (1)"
         ((:functions bar1-test1 bar1-test2 bar1-test3))

  (defconstructor bar1-test1 bar1 ())
  (defconstructor bar1-test2 bar1 () :a 1 :b 2 :c 3)
  (defconstructor bar1-test3 bar1 (a b c) :a a
                                          :b b
                                          :c c)
  
  (dotimes (i 2)
    (unless (check-slots (bar1-test1) 'a '1 'b '5 'c '6)
      (do-test-error nil "no initargs failed (~D time)" i)))

  (dotimes (i 2)
    (unless (check-slots (bar1-test2) 'a '1 'b '2 'c '3)
      (do-test-error nil "constant initargs failed (~D time)" i)))

  (dotimes (i 2)
    (unless (check-slots (bar1-test3 7 8 9) 'a '7 'b '8 'c '9)
      (do-test-error nil "non constant initargs failed (~D time)" i))))

;;;
;;; bar2
;;; [methods, default/initform, slot-filling]
;;; (t,       :constant,        :class)

(defclass bar2 ()
    ((a :initform 1 :initarg :a)
     (b :initform 2 :initarg :b)
     (c :allocation :class :initform 3 :initarg :c))
  (:default-initargs :b 5))

(defmethod *initialize-instance :before ((instance bar2) &rest ignore)
  (declare (ignore ignore))
  ())

(do-test "defconstructor (t,       :constant,        :class) (2)"
         ((:functions bar2-test1 bar2-test2 bar2-test3))

  (defconstructor bar2-test1 bar2 ())
  (defconstructor bar2-test2 bar2 () :a 1 :b 2 :c 3)
  (defconstructor bar2-test3 bar2 (a b c) :a a
                                          :b b
                                          :c c)
  
  (dotimes (i 2)
    (unless (check-slots (bar2-test1) 'a '1 'b '5 'c '3)
      (do-test-error nil "no initargs failed (~D time)" i)))

  (dotimes (i 2)
    (unless (check-slots (bar2-test2) 'a '1 'b '2 'c '3)
      (do-test-error nil "constant initargs failed (~D time)" i)))

  (dotimes (i 2)
    (unless (check-slots (bar2-test3 7 8 9) 'a '7 'b '8 'c '9)
      (do-test-error nil "non constant initargs failed (~D time)" i))))

;;;
;;; bar3
;;; [methods, default/initform, slot-filling]
;;; (t,       :constant,        :instance)

(defclass bar3 ()
    ((a :initform 1 :initarg :a)
     (b :initform 2 :initarg :b)
     (c :allocation :class :initform 3))
  (:default-initargs :b 5))

(defmethod *initialize-instance :before ((instance bar3) &rest ignore)
  (declare (ignore ignore))
  ())

(do-test "defconstructor (t,       :constant,        :instance) (1)"
         ((:functions bar3-test1 bar3-test2 bar3-test3))

  (defconstructor bar3-test1 bar3 ())
  (defconstructor bar3-test2 bar3 () :a 1 :b 2)
  (defconstructor bar3-test3 bar3 (a b) :a a :b b)
  
  (dotimes (i 2)
    (unless (check-slots (bar3-test1) 'a '1 'b '5 'c '3)
      (do-test-error nil "no initargs failed (~D time)" i)))

  (dotimes (i 2)
    (unless (check-slots (bar3-test2) 'a '1 'b '2 'c '3)
      (do-test-error nil "constant initargs failed (~D time)" i)))

  (dotimes (i 2)
    (unless (check-slots (bar3-test3 7 8) 'a '7 'b '8 'c '3)
      (do-test-error nil "non constant initargs failed (~D time)" i))))

;;;
;;; bar4
;;; [methods, default/initform, slot-filling]
;;; (t,       :constant,        :instance)

(defclass bar4 ()
    ((a :initform 1 :initarg :a)
     (b :initform 2 :initarg :b)
     (c :allocation :class))
  (:default-initargs :b 5))

(defmethod *initialize-instance :before ((instance bar4) &rest ignore)
  (declare (ignore ignore))
  ())

(do-test "defconstructor (t,       :constant,        :instance) (2)"
         ((:functions bar4-test1 bar4-test2 bar4-test3))

  (defconstructor bar4-test1 bar4 ())
  (defconstructor bar4-test2 bar4 () :a 1 :b 2)
  (defconstructor bar4-test3 bar4 (a b) :a a :b b)

  (dotimes (i 2)
    (unless (check-slots (bar4-test1) 'a '1 'b '5 'c :unbound)
      (do-test-error nil "no initargs failed (~D time)" i)))

  (dotimes (i 2)
    (unless (check-slots (bar4-test2) 'a '1 'b '2 'c :unbound)
      (do-test-error nil "constant initargs failed (~D time)" i)))

  (dotimes (i 2)
    (unless (check-slots (bar4-test3 7 8) 'a '7 'b '8 'c :unbound)
      (do-test-error nil "non constant initargs failed (~D time)" i))))

;;;
;;; bar5
;;; [methods, default/initform, slot-filling]
;;; (:after,  :constant,        :class)

(defclass bar5 ()
    ((a :initarg :a :initform 1)
     (b :initarg :b :initform 2)
     (c :initarg :c :allocation :class :initform 3))
  (:default-initargs :b 5 :c 6))

(defmethod *initialize-instance :after ((instance bar5) &rest ignore)
  (declare (ignore ignore))
  ())

(do-test "defconstructor (:after,  :constant,        :class) (1)"
         ((:functions bar5-test1 bar5-test2 bar5-test3))

  (defconstructor bar5-test1 bar5 ())
  (defconstructor bar5-test2 bar5 () :a 1 :b 2 :c 3)
  (defconstructor bar5-test3 bar5 (a b c) :a a
                                          :b b
                                          :c c)
  
  (dotimes (i 2)
    (unless (check-slots (bar5-test1) 'a '1 'b '5 'c '6)
      (do-test-error nil "no initargs failed (~D time)" i)))

  (dotimes (i 2)
    (unless (check-slots (bar5-test2) 'a '1 'b '2 'c '3)
      (do-test-error nil "constant initargs failed (~D time)" i)))

  (dotimes (i 2)
    (unless (check-slots (bar5-test3 7 8 9) 'a '7 'b '8 'c '9)
      (do-test-error nil "non constant initargs failed (~D time)" i))))

;;;
;;; bar6
;;; [methods, default/initform, slot-filling]
;;; (:after,  :constant,        :class)

(defclass bar6 ()
    ((a :initform 1 :initarg :a)
     (b :initform 2 :initarg :b)
     (c :allocation :class :initform 3 :initarg :c))
  (:default-initargs :b 5))

(defmethod *initialize-instance :after ((instance bar6) &rest ignore)
  (declare (ignore ignore))
  ())

(do-test "defconstructor (:after,  :constant,        :class) (2)"
         ((:functions bar6-test1 bar6-test2 bar6-test3))

  (defconstructor bar6-test1 bar6 ())
  (defconstructor bar6-test2 bar6 () :a 1 :b 2 :c 3)
  (defconstructor bar6-test3 bar6 (a b c) :a a
                                          :b b
                                          :c c)
  
  (dotimes (i 2)
    (unless (check-slots (bar6-test1) 'a '1 'b '5 'c '3)
      (do-test-error nil "no initargs failed (~D time)" i)))

  (dotimes (i 2)
    (unless (check-slots (bar6-test2) 'a '1 'b '2 'c '3)
      (do-test-error nil "constant initargs failed (~D time)" i)))

  (dotimes (i 2)
    (unless (check-slots (bar6-test3 7 8 9) 'a '7 'b '8 'c '9)
      (do-test-error nil "non constant initargs failed (~D time)" i))))

;;;
;;; bar7
;;; [methods, default/initform, slot-filling]
;;; (:after,  :constant,        :instance)

(defclass bar7 ()
    ((a :initform 1 :initarg :a)
     (b :initform 2 :initarg :b)
     (c :allocation :class :initform 3))
  (:default-initargs :b 5))

(defmethod *initialize-instance :after ((instance bar7) &rest ignore)
  (declare (ignore ignore))
  ())

(do-test "defconstructor (:after,  :constant,        :instance) (1)"
         ((:functions bar7-test1 bar7-test2 bar7-test3))

  (defconstructor bar7-test1 bar7 ())
  (defconstructor bar7-test2 bar7 () :a 1 :b 2)
  (defconstructor bar7-test3 bar7 (a b) :a a :b b)
  
  (dotimes (i 2)
    (unless (check-slots (bar7-test1) 'a '1 'b '5 'c '3)
      (do-test-error nil "no initargs failed (~D time)" i)))

  (dotimes (i 2)
    (unless (check-slots (bar7-test2) 'a '1 'b '2 'c '3)
      (do-test-error nil "constant initargs failed (~D time)" i)))

  (dotimes (i 2)
    (unless (check-slots (bar7-test3 7 8) 'a '7 'b '8 'c '3)
      (do-test-error nil "non constant initargs failed (~D time)" i))))

;;;
;;; bar8
;;; [methods, default/initform, slot-filling]
;;; (:after,  :constant,        :instance)

(defclass bar8 ()
    ((a :initform 1 :initarg :a)
     (b :initform 2 :initarg :b)
     (c :allocation :class))
  (:default-initargs :b 5))

(defmethod *initialize-instance :after ((instance bar8) &rest ignore)
  (declare (ignore ignore))
  ())

(do-test "defconstructor (:after,  :constant,        :instance) (2)"
         ((:functions bar8-test1 bar8-test2 bar8-test3))

  (defconstructor bar8-test1 bar8 ())
  (defconstructor bar8-test2 bar8 () :a 1 :b 2)
  (defconstructor bar8-test3 bar8 (a b) :a a :b b)

  (dotimes (i 2)
    (unless (check-slots (bar8-test1) 'a '1 'b '5 'c :unbound)
      (do-test-error nil "no initargs failed (~D time)" i)))

  (dotimes (i 2)
    (unless (check-slots (bar8-test2) 'a '1 'b '2 'c :unbound)
      (do-test-error nil "constant initargs failed (~D time)" i)))

  (dotimes (i 2)
    (unless (check-slots (bar8-test3 7 8) 'a '7 'b '8 'c :unbound)
      (do-test-error nil "non constant initargs failed (~D time)" i))))

;;;
;;; bar9
;;; [methods, default/initform, slot-filling]
;;; (nil,     :constant,        :class)

(defclass bar9 ()
    ((a :initarg :a :initform 1)
     (b :initarg :b :initform 2)
     (c :initarg :c :allocation :class :initform 3))
  (:default-initargs :b 5 :c 6))

(do-test "defconstructor (nil,     :constant,        :class) (1)"
         ((:functions bar9-test1 bar9-test2 bar9-test3))

  (defconstructor bar9-test1 bar9 ())
  (defconstructor bar9-test2 bar9 () :a 1 :b 2 :c 3)
  (defconstructor bar9-test3 bar9 (a b c) :a a
                                          :b b
                                          :c c)
  
  (dotimes (i 2)
    (unless (check-slots (bar9-test1) 'a '1 'b '5 'c '6)
      (do-test-error nil "no initargs failed (~D time)" i)))

  (dotimes (i 2)
    (unless (check-slots (bar9-test2) 'a '1 'b '2 'c '3)
      (do-test-error nil "constant initargs failed (~D time)" i)))

  (dotimes (i 2)
    (unless (check-slots (bar9-test3 7 8 9) 'a '7 'b '8 'c '9)
      (do-test-error nil "non constant initargs failed (~D time)" i))))

;;;
;;; bar10
;;; [methods, default/initform, slot-filling]
;;; (nil,     :constant,        :class)

(defclass bar10 ()
    ((a :initform 1 :initarg :a)
     (b :initform 2 :initarg :b)
     (c :allocation :class :initform 3 :initarg :c))
  (:default-initargs :b 5))

(do-test "defconstructor (nil,     :constant,        :class) (2)"
         ((:functions bar10-test1 bar10-test2 bar10-test3))

  (defconstructor bar10-test1 bar10 ())
  (defconstructor bar10-test2 bar10 () :a 1 :b 2 :c 3)
  (defconstructor bar10-test3 bar10 (a b c) :a a
                                          :b b
                                          :c c)
  
  (dotimes (i 2)
    (unless (check-slots (bar10-test1) 'a '1 'b '5 'c '3)
      (do-test-error nil "no initargs failed (~D time)" i)))

  (dotimes (i 2)
    (unless (check-slots (bar10-test2) 'a '1 'b '2 'c '3)
      (do-test-error nil "constant initargs failed (~D time)" i)))

  (dotimes (i 2)
    (unless (check-slots (bar10-test3 7 8 9) 'a '7 'b '8 'c '9)
      (do-test-error nil "non constant initargs failed (~D time)" i))))

;;;
;;; bar11
;;; [methods, default/initform, slot-filling]
;;; (nil,     :constant,        :instance)

(defclass bar11 ()
    ((a :initform 1 :initarg :a)
     (b :initform 2 :initarg :b)
     (c :allocation :class :initform 3))
  (:default-initargs :b 5))

(do-test "defconstructor (nil,     :constant,        :instance) (1)"
         ((:functions bar11-test1 bar11-test2 bar11-test3))

  (defconstructor bar11-test1 bar11 ())
  (defconstructor bar11-test2 bar11 () :a 1 :b 2)
  (defconstructor bar11-test3 bar11 (a b) :a a :b b)
  
  (dotimes (i 2)
    (unless (check-slots (bar11-test1) 'a '1 'b '5 'c '3)
      (do-test-error nil "no initargs failed (~D time)" i)))

  (dotimes (i 2)
    (unless (check-slots (bar11-test2) 'a '1 'b '2 'c '3)
      (do-test-error nil "constant initargs failed (~D time)" i)))

  (dotimes (i 2)
    (unless (check-slots (bar11-test3 7 8) 'a '7 'b '8 'c '3)
      (do-test-error nil "non constant initargs failed (~D time)" i))))

;;;
;;; bar12
;;; [methods, default/initform, slot-filling]
;;; (nil,     :constant,        :instance)

(defclass bar12 ()
    ((a :initform 1 :initarg :a)
     (b :initform 2 :initarg :b)
     (c :allocation :class))
  (:default-initargs :b 5))

(defmethod *initialize-instance :after ((instance bar12) &rest ignore)
  (declare (ignore ignore))
  ())

(do-test "defconstructor (nil,     :constant,        :instance) (2)"
         ((:functions bar12-test1 bar12-test2 bar12-test3))

  (defconstructor bar12-test1 bar12 ())
  (defconstructor bar12-test2 bar12 () :a 1 :b 2)
  (defconstructor bar12-test3 bar12 (a b) :a a :b b)

  (dotimes (i 2)
    (unless (check-slots (bar12-test1) 'a '1 'b '5 'c :unbound)
      (do-test-error nil "no initargs failed (~D time)" i)))

  (dotimes (i 2)
    (unless (check-slots (bar12-test2) 'a '1 'b '2 'c :unbound)
      (do-test-error nil "constant initargs failed (~D time)" i)))

  (dotimes (i 2)
    (unless (check-slots (bar12-test3 7 8) 'a '7 'b '8 'c :unbound)
      (do-test-error nil "non constant initargs failed (~D time)" i))))


(cleanup-do-test '((:classes baz1 baz2 baz3)
                   (:functions baz1-test1 baz1-test2 baz1-test3
                               baz2-test1 baz2-test2 baz2-test3
                               baz3-test1 baz3-test2 baz3-test3)))

;;;
;;; baz1
;;; [methods, default/initform, slot-filling]
;;; (t,       nil,              :class)

(defclass baz1 ()
    ((a :initarg :a)
     (b :initarg :b)
     (c :initarg :c :allocation :class)))

(defmethod *initialize-instance :before ((instance baz1) &rest ignore)
  (declare (ignore ignore))
  ())

(do-test "defconstructor (t,       nil,              :class) (1)"
         ((:functions baz1-test1 baz1-test2 baz1-test3))

  (defconstructor baz1-test1 baz1 ())
  (defconstructor baz1-test2 baz1 () :a 1 :b 2 :c 3)
  (defconstructor baz1-test3 baz1 (a b c) :a a
                                          :b b
                                          :c c)
  
  (dotimes (i 2)
    (unless (check-slots (baz1-test1) 'a :unbound 'b :unbound 'c :unbound)
      (do-test-error nil "no initargs failed (~D time)" i)))

  (dotimes (i 2)
    (unless (check-slots (baz1-test2) 'a '1 'b '2 'c '3)
      (do-test-error nil "constant initargs failed (~D time)" i)))

  (dotimes (i 2)
    (unless (check-slots (baz1-test3 7 8 9) 'a '7 'b '8 'c '9)
      (do-test-error nil "non constant initargs failed (~D time)" i))))

;;;
;;; baz2
;;; [methods, default/initform, slot-filling]
;;; (:after,  nil,              :class)

(defclass baz2 ()
    ((a :initarg :a)
     (b :initarg :b)
     (c :initarg :c :allocation :class)))

(defmethod *initialize-instance :after ((instance baz2) &rest ignore)
  (declare (ignore ignore))
  ())

(do-test "defconstructor (:after,  nil,              :class) (1)"
         ((:functions baz2-test1 baz2-test2 baz2-test3))

  (defconstructor baz2-test1 baz2 ())
  (defconstructor baz2-test2 baz2 () :a 1 :b 2 :c 3)
  (defconstructor baz2-test3 baz2 (a b c) :a a
                                          :b b
                                          :c c)
  
  (dotimes (i 2)
    (unless (check-slots (baz2-test1) 'a :unbound 'b :unbound 'c :unbound)
      (do-test-error nil "no initargs failed (~D time)" i)))

  (dotimes (i 2)
    (unless (check-slots (baz2-test2) 'a '1 'b '2 'c '3)
      (do-test-error nil "constant initargs failed (~D time)" i)))

  (dotimes (i 2)
    (unless (check-slots (baz2-test3 7 8 9) 'a '7 'b '8 'c '9)
      (do-test-error nil "non constant initargs failed (~D time)" i))))

;;;
;;; baz3
;;; [methods, default/initform, slot-filling]
;;; (nil,     nil,              :class)

(defclass baz3 ()
    ((a :initarg :a)
     (b :initarg :b)
     (c :initarg :c :allocation :class)))

(do-test "defconstructor (nil,     nil,              :class) (1)"
         ((:functions baz3-test1 baz3-test2 baz3-test3))

  (defconstructor baz3-test1 baz3 ())
  (defconstructor baz3-test2 baz3 () :a 1 :b 2 :c 3)
  (defconstructor baz3-test3 baz3 (a b c) :a a
                                          :b b
                                          :c c)
  
  (dotimes (i 2)
    (unless (check-slots (baz3-test1) 'a :unbound 'b :unbound 'c :unbound)
      (do-test-error nil "no initargs failed (~D time)" i)))

  (dotimes (i 2)
    (unless (check-slots (baz3-test2) 'a '1 'b '2 'c '3)
      (do-test-error nil "constant initargs failed (~D time)" i)))

  (dotimes (i 2)
    (unless (check-slots (baz3-test3 7 8 9) 'a '7 'b '8 'c '9)
      (do-test-error nil "non constant initargs failed (~D time)" i))))


(cleanup-do-test '((:classes foo bar)
                   (:functions make-bar-1 make-bar-2 make-bar-3)))

(setq *foo-a* 'foo-a
      *foo-b* 'foo-b
      *foo-c* 'foo-c
      *bar-a* 'bar-a
      *bar-b* 'bar-b
      *bar-c* 'bar-c
      *supplied-a* 'a
      *supplied-b* 'b
      *supplied-c* 'c)

(defclass foo ()
    ((a :initarg :a)
     (b :initarg :b)
     (c :initarg :c))
  (:default-initargs :a *foo-a* :b *foo-b* :c *foo-c*))

(defclass bar (foo)
    ((c :initarg :a))
  (:default-initargs :a *bar-a* :c *bar-c*))

(defconstructor make-bar-1 bar ())
(defconstructor make-bar-2 bar () :a 1 :b 2 :c 3)
(defconstructor make-bar-3 bar (a b c) :a a :b b :c c)

(do-test "defconstructor/shadowing"
         ()

  (dotimes (i 2)
    (unless (check-slots (make-bar-1) 'a *bar-a* 'b *foo-b* 'c *bar-a*)
      (do-test-error nil "no initargs failed (~D time)" i)))

  (dotimes (i 2)
    (unless (check-slots (make-bar-2) 'a '1 'b '2 'c '1)
      (do-test-error nil "constant initargs failed (~D time)" i)))

  (dotimes (i 2)
    (unless (check-slots (make-bar-3 *supplied-a* *supplied-b* *supplied-c*)
                         'a  *supplied-a* 'b *supplied-b* 'c *supplied-a*)
      (do-test-error nil "non constant initargs failed (~D time)" i))))


(do-test "defconstructor/only needed forms should be evaluated"
         ((:classes foo)
          (:functions make-foo-1 make-foo-2))

  (defclass foo ()
      ((x :initform (do-test-error nil "foo x initform was evaluated")
          :initarg :x)
       (y :initform (do-test-error nil "foo y initform was evaluated")
          :initarg :y)
       (z :initform (do-test-error nil "foo z initform was evaluated")
          :initarg :z))
    (:default-initargs :y 2
                       :z (do-test-error
                            nil
                            "z default was evaluated")))

  (defconstructor make-foo-1 foo () :x 1 :z 3)
  (defconstructor make-foo-2 foo (x z) :x x :z z)

  (make-foo-1)
  (make-foo-1)
  (make-foo-2 'x 'z)
  (make-foo-2 'x 'z))

(do-test "defconstructor/shadowing/only needed forms should be evaluated"
         ((:classes foo bar)
          (:functions make-bar-4 make-bar-5))

  (defclass foo ()
      ((x :initform (do-test-error nil "foo x initform was evaluated")
          :initarg :x)
       (y :initform (do-test-error nil "foo y initform was evaluated")
          :initarg :y)
       (z :initform (do-test-error nil "foo z initform was evaluated")
          :initarg :z))
    (:default-initargs :x (do-test-error
                            nil
                            "foo z default was evaluated")
                       :y (do-test-error
                            nil
                            "foo y default was evaluated")
                       :z (do-test-error
                            nil
                            "foo z default was evaluated")))
  (defclass bar (foo)
      ((x :initform (do-test-error nil "bar x initform was evaluated"))
       (y :initform (do-test-error nil "bar y initform was evaluated"))
       (z :initform (do-test-error nil "bar z initform was evaluated")))
    (:default-initargs :y 2
                       :z (do-test-error
                            nil
                            "bar z default was evaluated")))

  (defconstructor make-bar-4 bar () :x 1 :z 3)
  (defconstructor make-bar-5 bar (x z) :x x :z z)

  (make-bar-4)
  (make-bar-4)
  (make-bar-5 'x 'z)
  (make-bar-5 'x 'z))

;;;
;;; 11/1 test to make sure reader/writer call slot-value-using-class
;;;
;;; **********************************************************************
;;; This test codes will have to change in each of the next releases
;;; **********************************************************************
;;;
(cleanup-do-test '((:classes test-deoptimized-slot-access-class
                             test-deoptimized-slot-access)
                   (:functions test-a test-b test-c)
                   (:setf-generic-functions test-a test-b)))

(defclass test-deoptimized-slot-access-class (standard-class) ())

(defmethod check-super-metaclass-compatibility
    ((x test-deoptimized-slot-access-class) (y standard-class))
  't)

(defmethod all-std-class-reader-miss-1
    ((class test-deoptimized-slot-access-class) wrapper slot-name)
  (declare (ignore wrapper slot-name))
  ())

(defmethod lookup-pv-miss-1
    ((class test-deoptimized-slot-access-class) slots pv)
  (let ((pv (call-next-method)))
    (make-list (length pv) :initial-element nil)))


(defclass test-deoptimized-slot-access ()
    ((a :initform 'a :accessor test-a)
     (b :initform 'b :accessor test-b))
  (:metaclass test-deoptimized-slot-access-class))

(defmethod test-c ((o test-deoptimized-slot-access))
  (list (slot-value o 'a) (slot-value o 'b)))

(let ((called-p 'nil)
      instance)
  (defmethod slot-value-using-class ((class test-deoptimized-slot-access-class)
                                     object
                                     slot-name)
    (setq called-p 'read)
    (call-next-method))

  (defmethod (setf slot-value-using-class)
      (nv (class test-deoptimized-slot-access-class) object slot-name)
    (setq called-p 'written)
    (call-next-method))

  (setq instance (make-instance 'test-deoptimized-slot-access))
  
  (do-test "deoptimized slot access should call slot-value-using-class"
        ()
    (unless (and (eq (test-a instance) 'a)
                 (eq called-p 'read))
      (do-test-error nil "reader doesn't call slot-value-using-class"))

    (setq called-p 'nil)
    (setf (test-b instance) 'c)
    (unless (eq called-p 'written)
      (do-test-error nil "writer doesn't call slot-value-using-class"))

    (setq called-p 'nil)
    (unless (and (equal (test-c instance) '(a c))
                 (eq called-p 'read))
      (do-test-error nil "slot-value doesn't call slot-value-using-class"))))

;;;
;;; 5/3/89 eql specializers tests
;;; 

(cleanup-do-test '((:classes foo bar)))
(defclass foo () ())
(defclass bar (foo) ())

(do-test "eql specializers(eql and other methods/symbol only)"
         ((:functions test)
          (:variables i))

  (defmethod test ((self foo) x) 'foo)
  (defmethod test ((self bar) (x (eql 'a))) 'a)
  (defmethod test ((self bar) (x (eql 'b))) 'b)
  (setq i (make-instance 'bar))

  (unless (eq (test i 'a) 'a)
    (do-test-error () "for (bar (eql a)) wrong method was called"))
  (unless (eq (test i 'b) 'b)
    (do-test-error () "for (bar (eql b)) wrong method was called"))
  (unless (eq (test i 'c) 'foo)
    (do-test-error () "for (bar (eql c)) wrong method was called"))
  )

(do-test "eql specializers(only eql methods/symbol only)"
         ((:functions test2)
          (:variables i))

  (defmethod test2 ((self bar) (x (eql 'a))) 'a)
  (defmethod test2 ((self bar) (x (eql 'b))) 'b)
  (setq i (make-instance 'bar))

  (unless (eq (test2 i 'a) 'a)
    (do-test-error () "for (bar (eql a)) wrong method was called"))
  (unless (eq (test2 i 'b) 'b)
    (do-test-error () "for (bar (eql b)) wrong method was called"))
  )

(do-test "eql specializers(only eql methods/symbol and integer)"
         ((:functions test3))

  (defmethod test3 ((x (eql 'a)) (y (eql '1))) 'a-1)
  (defmethod test3 ((x (eql 'b)) (y (eql '1))) 'b-1)
  (defmethod test3 ((x (eql 'c)) (y (eql '1))) 'c-1)
  (defmethod test3 ((x (eql 'a)) (y (eql '2))) 'a-2)
  (defmethod test3 ((x (eql 'b)) (y (eql '2))) 'b-2)
  (defmethod test3 ((x (eql 'c)) (y (eql '2))) 'c-2)
  (defmethod test3 ((x (eql 'a)) (y (eql '3))) 'a-3)
  (defmethod test3 ((x (eql 'b)) (y (eql '3))) 'b-3)
  (defmethod test3 ((x (eql 'c)) (y (eql '3))) 'c-3)
  
  (unless (eq (test3 'a '1) 'a-1)
    (do-test-error () "for (a 1) wrong method was called"))
  (unless (eq (test3 'a '2) 'a-2)
    (do-test-error () "for (a 2) wrong method was called"))
  (unless (eq (test3 'a '3) 'a-3)
    (do-test-error () "for (a 3) wrong method was called"))
  (unless (eq (test3 'b '1) 'b-1)
    (do-test-error () "for (b 1) wrong method was called"))
  (unless (eq (test3 'b '2) 'b-2)
    (do-test-error () "for (b 2) wrong method was called"))
  (unless (eq (test3 'b '3) 'b-3)
    (do-test-error () "for (b 3) wrong method was called"))
  (unless (eq (test3 'c '1) 'c-1)
    (do-test-error () "for (c 1) wrong method was called"))
  (unless (eq (test3 'c '2) 'c-2)
    (do-test-error () "for (c 2) wrong method was called"))
  (unless (eq (test3 'c '3) 'c-3)
    (do-test-error () "for (c 3) wrong method was called"))

  )

(do-test "eql specializers(eql and other methods/symbol and integer)"
         ((:functions test4))

  (defmethod test4 ((x (eql 'a)) (y (eql '1))) 'a-1)
  (defmethod test4 ((x (eql 'b)) (y (eql '1))) 'b-1)
  (defmethod test4 ((x (eql 'c)) (y (eql '2))) 'c-2)
  (defmethod test4 ((x (eql 'b)) (y (eql '3))) 'b-3)
  (defmethod test4 (x y) 'other)
  
  (unless (eq (test4 'a '1) 'a-1)
    (do-test-error () "for (a 1) wrong method was called"))
  (unless (eq (test4 'a '2) 'other)
    (do-test-error () "for (a 2) wrong method was called"))
  (unless (eq (test4 'a '3) 'other)
    (do-test-error () "for (a 3) wrong method was called"))
  (unless (eq (test4 'b '1) 'b-1)
    (do-test-error () "for (b 1) wrong method was called"))
  (unless (eq (test4 'b '2) 'other)
    (do-test-error () "for (b 2) wrong method was called"))
  (unless (eq (test4 'b '3) 'b-3)
    (do-test-error () "for (b 3) wrong method was called"))
  (unless (eq (test4 'c '1) 'other)
    (do-test-error () "for (c 1) wrong method was called"))
  (unless (eq (test4 'c '2) 'c-2)
    (do-test-error () "for (c 2) wrong method was called"))
  (unless (eq (test4 'c '3) 'other)
    (do-test-error () "for (c 3) wrong method was called"))

  )

(do-test "eql specializers(call-next-method)"
         ((:functions test5))

  (defmethod test5 (x) ())
  (defmethod test5 ((x (eql 'a))) (cons 'a (call-next-method)))
  (defmethod test5 ((x (eql 'b))) (cons 'b (call-next-method)))

  (unless (equal (test5 'a) '(a))
    (do-test-error () "for (a) wrong method was called"))
  (unless (equal (test5 'b) '(b))
    (do-test-error () "for (b) wrong method was called"))
  (unless (eq (test5 'c) '())
    (do-test-error () "for (c) wrong method was called"))
  )

(do-test "eql specializers(for random types)"
         ((:functions test6))

  (defmethod test6 (x) ())
  (defmethod test6 ((x symbol))  (cons 'the-class-symbol  (call-next-method)))
  (defmethod test6 ((x null))    (cons 'the-class-null    (call-next-method)))
  (defmethod test6 ((x number))  (cons 'the-class-number  (call-next-method)))
  (defmethod test6 ((x integer)) (cons 'the-class-integer (call-next-method)))
  (defmethod test6 ((x (eql 'foo))) (cons 'foo (call-next-method)))
  (defmethod test6 ((x (eql 'bar))) (cons 'bar (call-next-method)))
  (defmethod test6 ((x (eql 'nil))) (cons 'nil (call-next-method)))
  (defmethod test6 ((x (eql '1.7))) (cons '1.7 (call-next-method)))
  (defmethod test6 ((x (eql '321))) (cons '321 (call-next-method)))

  (unless (eq (test6 '(other)) ())
    (do-test-error () "for ((other)) wrong method was called"))
  (unless (equal (test6 'symbol) '(the-class-symbol))
    (do-test-error () "for (symbol) wrong method was called"))
  (unless (equal (test6 '5.5) '(the-class-number))
    (do-test-error () "for (number) wrong method was called"))
  (unless (equal (test6 '123) '(the-class-integer the-class-number))
    (do-test-error () "for (integer) wrong method was called"))
  (unless (equal (test6 'foo) '(foo the-class-symbol))
    (do-test-error () "for ((eql foo)) wrong method was called"))
  (unless (equal (test6 'bar) '(bar the-class-symbol))
    (do-test-error () "for ((eql bar)) wrong method was called"))
  (unless (equal (test6 'nil) '(nil the-class-null the-class-symbol))
    (do-test-error () "for ((eql nil)) wrong method was called"))
  (unless (equal (test6 '1.7) '(1.7 the-class-number))
    (do-test-error () "for ((eql 1.7)) wrong method was called"))
  (unless (equal (test6 '321) '(321 the-class-integer the-class-number))
    (do-test-error () "for ((eql 321)) wrong method was called"))
  )

;;;
;;; (5/3/89)Testing :allocation :class for funcallable-instance
;;;

(format t "~%Testing :allocation :class test(for standard-instance)~%")
         
(cleanup-do-test '((:classes foo bar)
                   (:variables foo1 bar1)))

(defclass foo ()
    ((a :initform (list 'foo-a) :allocation :class)
     (b :initform (list 'foo-b) :allocation :class)
     (c :initform (list 'foo-c) :allocation :class)
     (d :allocation :class)
     (e :allocation :class)
     (f :allocation :class)))

(defclass bar (foo)
    ((b :initform (list 'bar-b) :allocation :class)
     (c :allocation :class)
     (e :initform (list 'bar-e) :allocation :class)
     (f :allocation :class)))

(defmethod slot-missing ((class standard-class)
                         (instance foo)
                         slot-name operation &optional new-value)
  (list* class instance slot-name operation new-value))

(defmethod slot-missing ((class standard-class)
                         (instance bar)
                         slot-name operation &optional new-value)
  (list* class instance slot-name operation new-value))

(defmethod slot-unbound ((class standard-class)
                         (instance foo)
                         slot-name)
  (list class instance slot-name))

(defmethod slot-unbound ((class standard-class)
                         (instance bar)
                         slot-name)
  (list class instance slot-name))

(setq foo1 (make-instance 'foo)
      bar1 (make-instance 'bar))

(do-test ":allocation :class(:initform/slot-value)"
  ()
  (unless (and (equal (slot-value foo1 'a) '(foo-a))
               (equal (slot-value foo1 'b) '(foo-b))
               (equal (slot-value foo1 'c) '(foo-c))
               (equal (slot-value bar1 'a) '(foo-a))
               (equal (slot-value bar1 'b) '(bar-b))
               (equal (slot-value bar1 'c) '(foo-c))
               (equal (slot-value bar1 'e) '(bar-e)))
    (do-test-error () ":initform/slot-value failed")))

(do-test ":allocation :class(shared by instances of super and sub case)"
  ()
  (unless (eq (slot-value foo1 'a)
              (slot-value bar1 'a))
    (do-test-error () ":class slot should be shared by instances")))

(do-test ":allocation :class(not shared by instances of super and sub case)"
  ()
  (unless (not (eq (slot-value foo1 'c)
                   (slot-value bar1 'c)))
    (do-test-error () ":class slot should not be shared by instances")))

(do-test ":allocation :class(slot-boundp)"
  ()
  (unless (and (slot-boundp foo1 'a)
               (slot-boundp foo1 'b)
               (slot-boundp foo1 'c)
               (not (slot-boundp foo1 'd))
               (not (slot-boundp foo1 'e))
               (not (slot-boundp foo1 'f))
               (slot-boundp bar1 'a)
               (slot-boundp bar1 'b)
               (slot-boundp bar1 'c)
               (not (slot-boundp bar1 'd))
               (slot-boundp bar1 'e)
               (not (slot-boundp bar1 'f)))
    (do-test-error () "slot-boundp failed")))

(slot-makunbound foo1 'a)
(slot-makunbound foo1 'b)

(do-test ":allocation :class(slot-makunbound)"
  ()
  (unless (and (not (slot-boundp foo1 'a))
               (not (slot-boundp foo1 'b))
               (not (slot-boundp bar1 'a))
               (slot-boundp bar1 'b))
    (do-test-error () "slot-makunbound failed")))

(setf (slot-value foo1 'a) '(new-foo-a)
      (slot-value foo1 'b) '(new-foo-b)
      (slot-value foo1 'c) '(new-foo-c)
      (slot-value bar1 'b) '(new-bar-b)
      (slot-value bar1 'e) '(new-bar-e))

(do-test ":allocation :class(slot-value/(setf slot-value))"
  ()
  (unless (and (equal (slot-value foo1 'a) '(new-foo-a))
               (equal (slot-value foo1 'b) '(new-foo-b))
               (equal (slot-value foo1 'c) '(new-foo-c))
               (equal (slot-value bar1 'a) '(new-foo-a))
               (equal (slot-value bar1 'b) '(new-bar-b))
               (equal (slot-value bar1 'e) '(new-bar-e)))
    (do-test-error () "slot-value/(setf slot-value failed")))

(do-test ":allocation :class(slot-exists-p)"
  ()
  (unless (and (slot-exists-p foo1 'a)
               (slot-exists-p foo1 'b)
               (slot-exists-p foo1 'c)
               (slot-exists-p foo1 'd)
               (slot-exists-p foo1 'e)
               (slot-exists-p foo1 'f)
               (slot-exists-p bar1 'a)
               (slot-exists-p bar1 'b)
               (slot-exists-p bar1 'c)
               (slot-exists-p bar1 'd)
               (slot-exists-p bar1 'e)
               (slot-exists-p bar1 'f))
    (do-test-error () "slot-exist-p failed")))

(do-test ":allocation :class(slot-missing)"
  ()
  (unless (and (equal (slot-value foo1 'x)
                      (list (class-of foo1)
                            foo1
                            'x
                            'slot-value))
               (equal (setf (slot-value foo1 'x) 'dummy)
                      (list* (class-of foo1)
                             foo1
                             'x
                             'setf
                             'dummy))
               (equal (slot-boundp foo1 'x)
                      (list (class-of foo1)
                            foo1
                            'x
                            'slot-boundp))
               
               (equal (slot-makunbound foo1 'x)
                      (list (class-of foo1)
                            foo1
                            'x
                            'slot-makunbound))
               (equal (slot-value bar1 'x)
                      (list (class-of bar1)
                            bar1
                            'x
                            'slot-value))
               (equal (setf (slot-value bar1 'x) 'dummy)
                      (list* (class-of bar1)
                             bar1
                             'x
                             'setf
                             'dummy))
               (equal (slot-boundp bar1 'x)
                      (list (class-of bar1)
                            bar1
                            'x
                            'slot-boundp))
               
               (equal (slot-makunbound bar1 'x)
                      (list (class-of bar1)
                            bar1
                            'x
                            'slot-makunbound)))
    (do-test-error () "slot-missing failed")))

;;;
;;; (5/4/89)Testing :allocation :class for funcallable-instance
;;;

(format t "~%Testing :allocation :class test~
           (for funcallable-standard-instance)~%")
         
(cleanup-do-test '((:classes foo bar)
                   (:variables foo2 bar2)))

(defclass foo ()
    ((a :initform (list 'foo-a) :allocation :class)
     (b :initform (list 'foo-b) :allocation :class)
     (c :initform (list 'foo-c) :allocation :class)
     (d :allocation :class)
     (e :allocation :class)
     (f :allocation :class))
  (:metaclass funcallable-standard-class))

(defclass bar (foo)
    ((b :initform (list 'bar-b) :allocation :class)
     (c :allocation :class)
     (e :initform (list 'bar-e) :allocation :class)
     (f :allocation :class))
  (:metaclass funcallable-standard-class))

(defmethod slot-missing ((class standard-class)
                         (instance foo)
                         slot-name operation &optional new-value)
  (list* class instance slot-name operation new-value))

(defmethod slot-missing ((class standard-class)
                         (instance bar)
                         slot-name operation &optional new-value)
  (list* class instance slot-name operation new-value))

(defmethod slot-unbound ((class standard-class)
                         (instance foo)
                         slot-name)
  (list class instance slot-name))

(defmethod slot-unbound ((class standard-class)
                         (instance bar)
                         slot-name)
  (list class instance slot-name))

(setq foo2 (make-instance 'foo)
      bar2 (make-instance 'bar))

(do-test ":allocation :class(:initform/slot-value)"
  ()
  (unless (and (equal (slot-value foo2 'a) '(foo-a))
               (equal (slot-value foo2 'b) '(foo-b))
               (equal (slot-value foo2 'c) '(foo-c))
               (equal (slot-value bar2 'a) '(foo-a))
               (equal (slot-value bar2 'b) '(bar-b))
               (equal (slot-value bar2 'c) '(foo-c))
               (equal (slot-value bar2 'e) '(bar-e)))
    (do-test-error () ":initform/slot-value failed")))

(do-test ":allocation :class(shared by instances of super and sub case)"
  ()
  (unless (eq (slot-value foo2 'a)
              (slot-value bar2 'a))
    (do-test-error () ":class slot should be shared by instances")))

(do-test ":allocation :class(not shared by instances of super and sub case)"
  ()
  (unless (not (eq (slot-value foo2 'c)
                   (slot-value bar2 'c)))
    (do-test-error () ":class slot should not be shared by instances")))

(do-test ":allocation :class(slot-boundp)"
  ()
  (unless (and (slot-boundp foo2 'a)
               (slot-boundp foo2 'b)
               (slot-boundp foo2 'c)
               (not (slot-boundp foo2 'd))
               (not (slot-boundp foo2 'e))
               (not (slot-boundp foo2 'f))
               (slot-boundp bar2 'a)
               (slot-boundp bar2 'b)
               (slot-boundp bar2 'c)
               (not (slot-boundp bar2 'd))
               (slot-boundp bar2 'e)
               (not (slot-boundp bar2 'f)))
    (do-test-error () "slot-boundp failed")))

(slot-makunbound foo2 'a)
(slot-makunbound foo2 'b)

(do-test ":allocation :class(slot-makunbound)"
  ()
  (unless (and (not (slot-boundp foo2 'a))
               (not (slot-boundp foo2 'b))
               (not (slot-boundp bar2 'a))
               (slot-boundp bar2 'b))
    (do-test-error () "slot-makunbound failed")))

(setf (slot-value foo2 'a) '(new-foo-a)
      (slot-value foo2 'b) '(new-foo-b)
      (slot-value foo2 'c) '(new-foo-c)
      (slot-value bar2 'b) '(new-bar-b)
      (slot-value bar2 'e) '(new-bar-e))

(do-test ":allocation :class(slot-value/(setf slot-value))"
  ()
  (unless (and (equal (slot-value foo2 'a) '(new-foo-a))
               (equal (slot-value foo2 'b) '(new-foo-b))
               (equal (slot-value foo2 'c) '(new-foo-c))
               (equal (slot-value bar2 'a) '(new-foo-a))
               (equal (slot-value bar2 'b) '(new-bar-b))
               (equal (slot-value bar2 'e) '(new-bar-e)))
    (do-test-error () "slot-value/(setf slot-value failed")))

(do-test ":allocation :class(slot-exists-p)"
  ()
  (unless (and (slot-exists-p foo2 'a)
               (slot-exists-p foo2 'b)
               (slot-exists-p foo2 'c)
               (slot-exists-p foo2 'd)
               (slot-exists-p foo2 'e)
               (slot-exists-p foo2 'f)
               (slot-exists-p bar2 'a)
               (slot-exists-p bar2 'b)
               (slot-exists-p bar2 'c)
               (slot-exists-p bar2 'd)
               (slot-exists-p bar2 'e)
               (slot-exists-p bar2 'f))
    (do-test-error () "slot-exist-p failed")))

;(do-test ":allocation :class(slot-missing)"
;  ()
;  (unless (and (equal (slot-value foo2 'x)
;                      (list (class-of foo2)
;                            foo2
;                              'x
;                            'slot-value))
;               (equal (setf (slot-value foo2 'x) 'dummy)
;                      (list* (class-of foo2)
;                             foo2
;                             'x
 ;                            'setf
;                             'dummy))
;               (equal (slot-boundp foo2 'x)
;                      (list (class-of foo2)
;                            foo2
;                            'x
;                            'slot-boundp))
;               
;               (equal (slot-makunbound foo2 'x)
;                      (list (class-of foo2)
;                            foo2
;                            'x
;                            'slot-makunbound))
;               (equal (slot-value bar2 'x)
;                      (list (class-of bar2)
;                            bar2
;                            'x
;                            'slot-value))
;               (equal (setf (slot-value bar2 'x) 'dummy)
;                      (list* (class-of bar2)
;                             bar2
;                             'x
;                             'setf
;                             'dummy))
;               (equal (slot-boundp bar2 'x)
;                      (list (class-of bar2)
;                            bar2
;                            'x
;                            'slot-boundp))
;               
;               (equal (slot-makunbound bar2 'x)
;                      (list (class-of bar2)
;                            bar2
;                            'x
;                            'slot-makunbound)))
;    (do-test-error () "slot-missing failed")))