reinitialize-instance.lsp 3.63 KB
Newer Older
1 2 3 4 5 6 7 8 9 10 11
;-*- Mode:     Lisp -*-
;;;; Author:   Paul Dietz
;;;; Created:  Mon Apr 28 21:56:47 2003
;;;; Contains: Tests for REINITIALIZE-INSTANCE

(in-package :cl-test)

;;; Many of the classes used here are defined in defclass-??.lsp

(deftest reinitialize-instance.1
  (let* ((obj (make-instance 'class-01))
sds's avatar
sds committed
12
         (obj2 (reinitialize-instance obj)))
13 14 15 16 17 18 19 20
    (values
     (eqt obj obj2)
     (map-slot-boundp* obj '(s1 s2 s3))))
  t (nil nil nil))


(deftest reinitialize-instance.2
  (let* ((obj (make-instance 'class-01))
sds's avatar
sds committed
21
         (obj2 (reinitialize-instance obj :allow-other-keys nil)))
22 23 24 25 26 27 28
    (values
     (eqt obj obj2)
     (map-slot-boundp* obj '(s1 s2 s3))))
  t (nil nil nil))

(deftest reinitialize-instance.3
  (let* ((obj (make-instance 'class-01))
sds's avatar
sds committed
29
         (obj2 (reinitialize-instance obj :allow-other-keys t)))
30 31 32 33 34 35 36
    (values
     (eqt obj obj2)
     (map-slot-boundp* obj '(s1 s2 s3))))
  t (nil nil nil))

(deftest reinitialize-instance.4
  (let* ((obj (make-instance 'class-01))
sds's avatar
sds committed
37 38
         (obj2 (reinitialize-instance obj :allow-other-keys t
                                      :allow-other-keys nil)))
39 40 41 42 43 44 45
    (values
     (eqt obj obj2)
     (map-slot-boundp* obj '(s1 s2 s3))))
  t (nil nil nil))

(deftest reinitialize-instance.5
  (let* ((obj (make-instance 'class-07))
sds's avatar
sds committed
46 47
         (obj2 (reinitialize-instance obj :s1a 'a :s2 'b :s1a 'bad
                                      :s2 'bad2  :s1b 'bad3)))
48 49 50 51 52
    (values
     (eqt obj obj2)
     (map-slot-value obj '(s1 s2))))
  t (a b))

pfdietz's avatar
pfdietz committed
53 54
(deftest reinitialize-instance.6
  (let* ((obj (make-instance 'class-07 :s1a 'a))
sds's avatar
sds committed
55
         (obj2 (reinitialize-instance obj :s1b 'b)))
pfdietz's avatar
pfdietz committed
56 57 58 59 60 61 62 63
    (values
     (eqt obj obj2)
     (slot-value obj 's1)
     (slot-boundp* obj 's2)))
  t b nil)

(deftest reinitialize-instance.7
  (let* ((obj (make-instance 'class-07 :s1a 'a))
sds's avatar
sds committed
64
         (obj2 (reinitialize-instance obj :s2 'b)))
pfdietz's avatar
pfdietz committed
65 66 67 68 69 70 71
    (values
     (eqt obj obj2)
     (slot-value obj 's1)
     (slot-value obj 's2)))
  t a b)


72
;;; Tests of user-defined methods
pfdietz's avatar
pfdietz committed
73

74 75
(defclass reinit-class-01 ()
  ((a :initarg :a) (b :initarg :b)))
pfdietz's avatar
pfdietz committed
76

77
(defmethod reinitialize-instance :after ((instance reinit-class-01)
sds's avatar
sds committed
78 79
                                         &rest initargs
                                         &key (x nil x-p))
80 81 82 83 84 85
  (declare (ignore initargs))
  (when x-p (setf (slot-value instance 'a) x))
  instance)

(deftest reinitialize-instance.8
  (let* ((obj (make-instance 'reinit-class-01))
sds's avatar
sds committed
86
         (obj2 (reinitialize-instance obj :a 1 :b 3)))
87 88 89 90 91 92 93
    (values
     (eqt obj obj2)
     (map-slot-value obj2 '(a b))))
  t (1 3))

(deftest reinitialize-instance.9
  (let* ((obj (make-instance 'reinit-class-01 :a 10 :b 20))
sds's avatar
sds committed
94
         (obj2 (reinitialize-instance obj :x 3)))
95 96 97 98 99 100 101
    (values
     (eqt obj obj2)
     (map-slot-value obj2 '(a b))))
  t (3 20))

(deftest reinitialize-instance.10
  (let* ((obj (make-instance 'reinit-class-01 :a 10 :b 20))
sds's avatar
sds committed
102
         (obj2 (reinitialize-instance obj :x 3 :x 100)))
103 104 105 106 107
    (values
     (eqt obj obj2)
     (map-slot-value obj2 '(a b))))
  t (3 20))

108 109 110 111
;;; Order of evaluation tests

(deftest reinitialize-instance.order.1
  (let* ((obj (make-instance 'reinit-class-01))
sds's avatar
sds committed
112 113 114 115 116 117
         (i 0) x y z w
         (obj2 (reinitialize-instance
                (progn (setf x (incf i)) obj)
                :b (setf y (incf i))
                :a (setf z (incf i))
                :b (setf w (incf i)))))
118 119 120 121 122 123
    (values
     (eqt obj obj2)
     (map-slot-value obj2 '(a b))
     i x y z w))
  t (3 2) 4 1 2 3 4)

124 125 126 127 128 129 130 131 132
;;; Error cases

(deftest reinitialize-instance.error.1
  (handler-case
   (eval '(reinitialize-instance (make-instance 'class-01) :garbage t))
   (error () :good))
  :good)

(deftest reinitialize-instance.error.2
133 134
  (signals-error (reinitialize-instance) program-error)
  t)