with-slots.lsp 4.78 KB
Newer Older
pfdietz's avatar
pfdietz committed
1 2 3 4 5
;-*- Mode:     Lisp -*-
;;;; Author:   Paul Dietz
;;;; Created:  Sat May 17 18:04:10 2003
;;;; Contains: Tests of WITH-SLOTS

6

pfdietz's avatar
pfdietz committed
7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34

(deftest with-slots.1
  (with-slots () nil)
  nil)

(deftest with-slots.2
  (with-slots () nil (values)))

(deftest with-slots.3
  (with-slots () nil (values 'a 'b 'c 'd 'e 'f))
  a b c d e f)

(deftest with-slots.4
  (let ((x 0) (y 10) (z 20))
    (values
     x y z
     (with-slots () (incf x) (incf y 3) (incf z 100))
     x y z))
  0 10 20
  120
  1 13 120)

;;; with-slots is an implicit progn, not a tagbody

(deftest with-slots.5
  (block done
    (tagbody
     (with-slots () nil
sds's avatar
sds committed
35 36 37
                 (go 10)
                 10
                 (return-from done :bad))
pfdietz's avatar
pfdietz committed
38 39 40 41 42 43 44 45 46 47 48 49 50 51 52
     10
     (return-from done :good)))
  :good)

;;; with-slots has no implicit block
(deftest with-slots.6
  (block nil
    (with-slots () nil (return :good))
    (return :bad))
  :good)


;;; Tests on standard objects

(defclass with-slots-class-01 () ((a :initarg :a)
sds's avatar
sds committed
53 54
                                  (b :initarg :b)
                                  (c :initarg :c)))
pfdietz's avatar
pfdietz committed
55 56 57 58 59 60 61 62 63 64 65

(deftest with-slots.7
  (let ((obj (make-instance 'with-slots-class-01 :a 'x :b 'y :c 'z)))
    (with-slots (a b c) obj (values a b c)))
  x y z)

(deftest with-slots.8
  (let ((obj (make-instance 'with-slots-class-01 :a 'x :b 'y :c 'z)))
    (with-slots
     (a b c) obj
     (values (setf a 'p) (setf b 'q) (setf c 'r)
sds's avatar
sds committed
66
             (map-slot-value obj '(a b c)))))
pfdietz's avatar
pfdietz committed
67 68 69 70 71 72 73
  p q r (p q r))

(deftest with-slots.9
  (let ((obj (make-instance 'with-slots-class-01 :a 'x :b 'y :c 'z)))
    (with-slots
     (a b c) obj
     (values (setq a 'p) (setq b 'q) (setq c 'r)
sds's avatar
sds committed
74
             (map-slot-value obj '(a b c)))))
pfdietz's avatar
pfdietz committed
75 76 77 78 79 80 81 82 83 84 85 86
  p q r (p q r))

(deftest with-slots.10
  (let ((obj (make-instance 'with-slots-class-01 :a 'x :b 'y :c 'z)))
    (with-slots ((a2 a) (b2 b) (c2 c)) obj (values a2 b2 c2)))
  x y z)

(deftest with-slots.11
  (let ((obj (make-instance 'with-slots-class-01 :a 'x :b 'y :c 'z)))
    (with-slots
     ((a2 a) (b2 b) (c2 c)) obj
     (values (setf a2 'p) (setf b2 'q) (setf c2 'r)
sds's avatar
sds committed
87
             (map-slot-value obj '(a b c)))))
pfdietz's avatar
pfdietz committed
88 89 90 91 92 93 94
  p q r (p q r))

(deftest with-slots.12
  (let ((obj (make-instance 'with-slots-class-01 :a 'x :b 'y :c 'z)))
    (with-slots
     ((a2 a) (b2 b) (c2 c)) obj
     (values (setq a2 'p) (setq b2 'q) (setq c2 'r)
sds's avatar
sds committed
95
             (map-slot-value obj '(a b c)))))
pfdietz's avatar
pfdietz committed
96 97 98 99 100 101 102
  p q r (p q r))

(deftest with-slots.13
  (let ((obj (make-instance 'with-slots-class-01)))
    (with-slots
     (a b c) obj
     (values (setf a 'p) (setf b 'q) (setf c 'r)
sds's avatar
sds committed
103
             (map-slot-value obj '(a b c)))))
pfdietz's avatar
pfdietz committed
104 105 106 107 108
  p q r (p q r))

(deftest with-slots.14
  (let ((obj (make-instance 'with-slots-class-01 :a 1 :b 2 :c 3)))
    (with-slots (a b c) obj
sds's avatar
sds committed
109 110 111
                (let ((obj (make-instance 'with-slots-class-01
                                          :a 'bad :b 'bad :c 'bad)))
                  (values a b c))))
pfdietz's avatar
pfdietz committed
112 113 114 115 116 117
  1 2 3)


(deftest with-slots.15
  (let ((obj (make-instance 'with-slots-class-01 :a 1 :b 2 :c 3)))
    (with-slots (a b c) obj
sds's avatar
sds committed
118 119 120 121 122
                (with-slots
                 ((a2 a) (b2 b) (c2 c))
                 (make-instance 'with-slots-class-01
                                :a 'bad :b 'bad :c 'bad)
                 (values a b c))))
pfdietz's avatar
pfdietz committed
123 124 125 126 127
  1 2 3)

(deftest with-slots.16
  (let ((obj (make-instance 'with-slots-class-01 :a 'bad :b 'bad :c 'bad)))
    (with-slots (a b c) obj
sds's avatar
sds committed
128 129 130 131
                (with-slots
                 (a b c)
                 (make-instance 'with-slots-class-01 :a 1 :b 2 :c 3)
                 (values a b c))))
pfdietz's avatar
pfdietz committed
132 133 134 135 136 137
  1 2 3)


(deftest with-slots.17
  (let ((obj (make-instance 'with-slots-class-01 :a 1 :b 2 :c 'bad)))
    (with-slots (a b) obj
sds's avatar
sds committed
138 139 140 141
                (with-slots
                 (c)
                 (make-instance 'with-slots-class-01 :a 'bad :b 'bad :c 3)
                 (values a b c))))
pfdietz's avatar
pfdietz committed
142 143 144 145
  1 2 3)

;;; If slot is unbound, act as if slot-value had been called

146
(defmethod slot-unbound ((class t)
sds's avatar
sds committed
147 148
                         (instance with-slots-class-01)
                         slot-name)
pfdietz's avatar
pfdietz committed
149 150 151 152 153 154 155
  'missing)

(deftest with-slots.18
  (let ((obj (make-instance 'with-slots-class-01)))
    (with-slots (a b c) obj (values a b c)))
  missing missing missing)

156 157 158
(deftest with-slots.19
  (let ((obj (make-instance 'with-slots-class-01 :a 'x :b 'y :c 'z)))
    (with-slots (a b c) obj
sds's avatar
sds committed
159 160
                (declare (optimize (speed 3) (safety 3)))
                (values a b c)))
161
  x y z)
pfdietz's avatar
pfdietz committed
162

163 164 165
(deftest with-slots.20
  (let ((obj (make-instance 'with-slots-class-01 :a 'x :b 'y :c 'z)))
    (with-slots (a b c) obj
sds's avatar
sds committed
166 167 168
                (declare (optimize (speed 3) (safety 3)))
                (declare (special *x*))
                (values a b c)))
169
  x y z)
170 171 172 173 174 175 176 177

;;; Free declaration scope test

(deftest with-slots.21
  (block done
    (let ((x :bad))
      (declare (special x))
      (let ((x :good))
sds's avatar
sds committed
178 179 180
        (with-slots nil (return-from done x)
                    (declare (special x))))))
  :good)