make-instance.lsp 6.73 KB
Newer Older
1 2 3 4 5 6 7 8 9 10
;-*- Mode:     Lisp -*-
;;;; Author:   Paul Dietz
;;;; Created:  Mon May 12 21:19:36 2003
;;;; Contains: Tests of MAKE-INSTANCE

(in-package :cl-test)

;;; MAKE-INSTANCE is used in many other tests as well

(deftest make-instance.error.1
11 12
  (signals-error (make-instance) program-error)
  t)
13 14 15 16 17

(defclass make-instance-class-01 ()
  ((a :initarg :a) (b :initarg :b)))

(deftest make-instance.error.2
18
  (signals-error (make-instance 'make-instance-class-01 :a)
sds's avatar
sds committed
19
                 program-error)
20
  t)
21 22 23

(deftest make-instance.error.3
  (handler-case (progn (eval '(make-instance 'make-instance-class-01 :z 1))
sds's avatar
sds committed
24 25
                       t)
                (error () :good))
26 27 28 29
  :good)

(deftest make-instance.error.4
  (handler-case (progn (eval '(make-instance
sds's avatar
sds committed
30 31 32 33
                               (find-class 'make-instance-class-01)
                               :z 1))
                       t)
                (error () :good))
34 35
  :good)

36
(deftest make-instance.error.5
37
  (signals-error (let () (make-instance) nil)
sds's avatar
sds committed
38
                 program-error)
39
  t)
40

41
(deftest make-instance.error.6
pfdietz's avatar
pfdietz committed
42
  (loop for cl in *built-in-classes*
sds's avatar
sds committed
43 44
        unless (eval `(signals-error (make-instance ',cl) error))
        collect cl)
45 46
  nil)

47 48
;; Definitions of methods

49
(defmethod make-instance ((x make-instance-class-01)
sds's avatar
sds committed
50
                          &rest initargs &key &allow-other-keys)
51
  initargs)
52 53

(deftest make-instance.1
54
  (make-instance (make-instance 'make-instance-class-01))
55 56
  nil)

57 58 59 60 61 62
(deftest make-instance.2
  (make-instance (make-instance 'make-instance-class-01) :a 1 :b 2)
  (:a 1 :b 2))

#|
(when *can-define-metaclasses*
sds's avatar
sds committed
63

64 65 66
  (defclass make-instance-class-02 ()
    (a b c)
    (:metaclass substandard-class))
sds's avatar
sds committed
67

68
  (defmethod make-instance ((class (eql (find-class 'make-instance-class-02)))
sds's avatar
sds committed
69 70
                            &rest initargs &key (x nil) (y nil) (z nil)
                            &allow-other-keys)
71 72 73
    (declare (ignore initargs))
    (let ((obj (allocate-instance class)))
      (setf (slot-value obj 'a) x
sds's avatar
sds committed
74 75
            (slot-value obj 'b) y
            (slot-value obj 'c) z)
76
      obj))
sds's avatar
sds committed
77

78 79 80 81 82 83 84 85
  (deftest make-instance.3
    (let ((obj (make-instance 'make-instance-class-02)))
      (values
       (eqt (class-of obj) (find-class 'make-instance-class-02))
       (slot-value obj 'a)
       (slot-value obj 'b)
       (slot-value obj 'c)))
    t nil nil nil)
sds's avatar
sds committed
86

87 88 89 90 91 92 93 94
  (deftest make-instance.4
    (let ((obj (make-instance 'make-instance-class-02 :z 10 :y 45 :x 'd)))
      (values
       (eqt (class-of obj) (find-class 'make-instance-class-02))
       (slot-value obj 'a)
       (slot-value obj 'b)
       (slot-value obj 'c)))
    t d 45 10)
sds's avatar
sds committed
95 96


97 98 99 100 101 102 103 104
  (deftest make-instance.5
    (let ((obj (make-instance (find-class 'make-instance-class-02) :y 'g)))
      (values
       (eqt (class-of obj) (find-class 'make-instance-class-02))
       (slot-value obj 'a)
       (slot-value obj 'b)
       (slot-value obj 'c)))
    t nil g nil)
sds's avatar
sds committed
105

106 107
  (deftest make-instance.6
    (eq (make-instance 'make-instance-class-02)
sds's avatar
sds committed
108
        (make-instance 'make-instance-class-02))
109 110 111
    nil)

  ;; Customization of make-instance
sds's avatar
sds committed
112

113 114 115 116 117
  (defclass make-instance-class-03 ()
    ((a :initform 1) (b :initarg :b) c)
    (:metaclass substandard-class))

  (defmethod make-instance ((class (eql (find-class 'make-instance-class-03)))
sds's avatar
sds committed
118 119 120
                            &rest initargs
                            &key (x nil x-p) (y nil y-p) (z nil z-p)
                            &allow-other-keys)
121 122 123 124 125 126
    (declare (ignore initargs))
    (let ((obj (allocate-instance (find-class 'make-instance-class-03))))
      (when x-p (setf (slot-value obj 'a) x))
      (when y-p (setf (slot-value obj 'b) y))
      (when z-p (setf (slot-value obj 'c) z))
      obj))
sds's avatar
sds committed
127

128 129 130 131
  (deftest make-instance.7
    (let ((obj (make-instance 'make-instance-class-03)))
      (values
       (eqt (class-of obj)
sds's avatar
sds committed
132
            (find-class 'make-instance-class-03))
133 134
       (map-slot-boundp* obj '(a b c))))
    t (nil nil nil))
sds's avatar
sds committed
135

136 137
  (deftest make-instance.8
    (let* ((class (find-class 'make-instance-class-03))
sds's avatar
sds committed
138
           (obj (make-instance class :b 10)))
139 140 141 142
      (values
       (eqt (class-of obj) class)
       (map-slot-boundp* obj '(a b c))))
    t (nil nil nil))
sds's avatar
sds committed
143

144 145
  (deftest make-instance.9
    (let* ((class (find-class 'make-instance-class-03))
sds's avatar
sds committed
146
           (obj (make-instance class :x 'g :z 'i :y 'k :foo t :x 'bad)))
147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165
      (values
       (eqt (class-of obj) class)
       (map-slot-boundp* obj '(a b c))
       (map-slot-value obj '(a b c))))
    t (t t t) (g k i))

  ;; After method combination

  (defparameter *make-instance-class-04-var* 0)

  (defclass make-instance-class-04 ()
    ((a :initform *make-instance-class-04-var*))
    (:metaclass substandard-class))

  (defmethod make-instance :after
    ((class (eql (find-class 'make-instance-class-04)))
     &rest initargs &key &allow-other-keys)
    (declare (ignore initargs))
    (incf *make-instance-class-04-var* 10))
sds's avatar
sds committed
166

167 168
  (deftest make-instance.10
    (let* ((*make-instance-class-04-var* 0)
sds's avatar
sds committed
169
           (obj (make-instance 'make-instance-class-04)))
170 171 172 173
      (values
       (slot-value obj 'a)
       *make-instance-class-04-var*))
    0 10)
sds's avatar
sds committed
174

175 176 177 178 179 180 181 182 183 184 185 186 187
  ;; Around method combination

  (defclass make-instance-class-05 ()
    ((a :initarg :a) (b :initarg :b :initform 'foo) c)
    (:metaclass substandard-class))

  (defmethod make-instance :around
    ((class (eql (find-class 'make-instance-class-05)))
     &rest initargs &key &allow-other-keys)
    (declare (ignore initargs))
    (let ((obj (call-next-method)))
      (setf (slot-value obj 'c) 'bar)
      obj))
sds's avatar
sds committed
188

189 190 191 192 193 194 195 196 197
  (deftest make-instance.11
    (let ((obj (make-instance 'make-instance-class-05)))
      (values
       (map-slot-boundp* obj '(a b c))
       (map-slot-value obj '(b c))))
    (nil t t)
    (foo bar))
  )
|#
198

199 200 201 202
;;; Order of argument evaluation

(deftest make-instance.order.1
  (let* ((i 0) x y
sds's avatar
sds committed
203 204 205
         (obj (make-instance 'make-instance-class-01
                             :a (setf x (incf i))
                             :b (setf y (incf i)))))
206 207 208 209 210 211 212
    (values
     (map-slot-value obj '(a b))
     i x y))
  (1 2) 2 1 2)

(deftest make-instance.order.2
  (let* ((i 0) x y z w
sds's avatar
sds committed
213 214 215 216 217
         (obj (make-instance 'make-instance-class-01
                             :a (setf x (incf i))
                             :b (setf y (incf i))
                             :b (setf z (incf i))
                             :a (setf w (incf i)))))
218 219 220 221 222 223 224
    (values
     (map-slot-value obj '(a b))
     i x y z w))
  (1 2) 4 1 2 3 4)

(deftest make-instance.order.3
  (let* ((i 0) u x y z w
sds's avatar
sds committed
225 226 227 228 229 230
         (obj (make-instance (prog1 'make-instance-class-01
                                    (setf u (incf i)))
                             :a (setf x (incf i))
                             :b (setf y (incf i))
                             :b (setf z (incf i))
                             :a (setf w (incf i)))))
231 232 233 234
    (values
     (map-slot-value obj '(a b))
     i u x y z w))
  (2 3) 5 1 2 3 4 5)