psetf.lsp 9.49 KB
Newer Older
1 2 3 4 5 6 7 8 9
;-*- Mode:     Lisp -*-
;;;; Author:   Paul Dietz
;;;; Created:  Sun Apr 20 15:38:30 2003
;;;; Contains: Tests of PSETF

(in-package :cl-test)

(deftest psetf.order.1
  (let ((x (vector nil nil nil nil))
sds's avatar
sds committed
10
        (i 0))
11 12 13 14 15 16
    (psetf (aref x (incf i)) (incf i))
    (values x i))
  #(nil 2 nil nil) 2)

(deftest psetf.order.2
  (let ((x (vector nil nil nil nil))
sds's avatar
sds committed
17
        (i 0))
18
    (psetf (aref x (incf i)) (incf i)
sds's avatar
sds committed
19
           (aref x (incf i)) (incf i 10))
20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41
    (values x i))
  #(nil 2 nil 13) 13)

(deftest psetf.1
  (psetf)
  nil)

(deftest psetf.2
  (let ((x 0))
    (values (psetf x 1) x))
  nil 1)

(deftest psetf.3
  (let ((x 0) (y 1))
    (values (psetf x y y x) x y))
  nil 1 0)

(deftest psetf.4
  (let ((x 0))
    (values
     (symbol-macrolet ((x y))
       (let ((y 1))
sds's avatar
sds committed
42 43
         (psetf x 2)
         y))
44 45 46 47 48 49 50 51 52 53 54 55 56 57
     x))
  2 0)

(deftest psetf.5
  (let ((w (list nil)))
    (values
     (symbol-macrolet ((x (car w)))
       (psetf x 2))
     w))
  nil (2))

(deftest psetf.6
  (let ((c 0) x y)
    (psetf x (incf c)
sds's avatar
sds committed
58
           y (incf c))
59 60 61 62 63 64 65 66 67 68 69
    (values c x y))
  2 1 2)

;;; According to the standard, the forms to be assigned and
;;; the subforms in the places to be assigned to are evaluated
;;; from left to right.  Therefore, PSETF.7 and PSETF.8 should
;;; do the same thing to A as PSETF.9 does.
;;; (See the page for PSETF)

(deftest psetf.7
  (symbol-macrolet ((x (aref a (incf i)))
sds's avatar
sds committed
70
                    (y (aref a (incf i))))
71
    (let ((a (copy-seq #(0 1 2 3 4 5 6 7 8 9)))
sds's avatar
sds committed
72
          (i 0))
73
      (psetf x (aref a (incf i))
sds's avatar
sds committed
74
             y (aref a (incf i)))
75 76 77 78 79 80
      (values a i)))
  #(0 2 2 4 4 5 6 7 8 9)
  4)

(deftest psetf.8
  (let ((a (copy-seq #(0 1 2 3 4 5 6 7 8 9)))
sds's avatar
sds committed
81
        (i 0))
82
    (psetf (aref a (incf i)) (aref a (incf i))
sds's avatar
sds committed
83
           (aref a (incf i)) (aref a (incf i)))
84 85 86 87 88 89 90
    (values a i))
  #(0 2 2 4 4 5 6 7 8 9)
  4)

(deftest psetf.9
  (let ((a (copy-seq #(0 1 2 3 4 5 6 7 8 9))))
    (psetf (aref a 1) (aref a 2)
sds's avatar
sds committed
91
           (aref a 3) (aref a 4))
92 93 94
    a)
  #(0 2 2 4 4 5 6 7 8 9))

95 96 97 98 99 100
(deftest psetf.10
  (let ((*x* 0) (*y* 10))
    (declare (special *x* *y*))
    (values
     *x* *y*
     (psetf *x* 6
sds's avatar
sds committed
101
            *y* 15)
102 103 104 105 106 107 108 109 110
     *x* *y*))
  0 10 nil 6 15)

(deftest psetf.11
  (let ((*x* 0) (*y* 10))
    (declare (special *x* *y*))
    (values
     *x* *y*
     (psetf *x* *y*
sds's avatar
sds committed
111
            *y* *x*)
112 113 114
     *x* *y*))
  0 10 nil 10 0)

115
(def-macro-test psetf.error.1 (psetf))
116 117 118 119 120 121

;;; PSETF is a good testbed for finding conflicts in setf expansions
;;; These tests apply psetf to various accessors

(deftest psetf.12
  (let* ((x (list 'a 'b))
sds's avatar
sds committed
122
         (y (list 'c 'd)))
123 124 125 126 127 128
    (psetf (car x) 1 (car y) 2)
    (values x y))
  (1 b) (2 d))

(deftest psetf.12a
  (let* ((x (list 'a 'b))
sds's avatar
sds committed
129
         (y (list 'c 'd)))
130 131 132 133 134 135
    (psetf (first x) 1 (first y) 2)
    (values x y))
  (1 b) (2 d))

(deftest psetf.13
  (let* ((x (list 'a 'b))
sds's avatar
sds committed
136
         (y (list 'c 'd)))
137 138 139 140 141 142
    (psetf (cdr x) 1 (cdr y) 2)
    (values x y))
  (a . 1) (c . 2))

(deftest psetf.13a
  (let* ((x (list 'a 'b))
sds's avatar
sds committed
143
         (y (list 'c 'd)))
144 145 146 147 148 149
    (psetf (rest x) 1 (rest y) 2)
    (values x y))
  (a . 1) (c . 2))

(deftest psetf.14
  (let* ((x (list 'a 'b))
sds's avatar
sds committed
150
         (y (list 'c 'd)))
151 152 153 154 155 156
    (psetf (cadr x) 1 (cadr y) 2)
    (values x y))
  (a 1) (c 2))

(deftest psetf.15
  (let* ((x (list 'a 'b))
sds's avatar
sds committed
157
         (y (list 'c 'd)))
158 159 160 161 162 163
    (psetf (cddr x) 1 (cddr y) 2)
    (values x y))
  (a b . 1) (c d . 2))

(deftest psetf.16
  (let* ((x (list (list 'a)))
sds's avatar
sds committed
164
         (y (list (list 'c))))
165 166 167 168 169 170
    (psetf (caar x) 1 (caar y) 2)
    (values x y))
  ((1)) ((2)))

(deftest psetf.17
  (let* ((x (list (list 'a)))
sds's avatar
sds committed
171
         (y (list (list 'c))))
172 173 174 175 176
    (psetf (cdar x) 1 (cdar y) 2)
    (values x y))
  ((a . 1)) ((c . 2)))

;;; TODO: c*r accessors with > 2 a/d
pfdietz's avatar
pfdietz committed
177
;;; TODO: third,...,tenth
178 179 180

(deftest psetf.18
  (let* ((x (vector 'a 'b))
sds's avatar
sds committed
181
         (y (vector 'c 'd)))
182 183 184 185 186 187
    (psetf (aref x 0) 1 (aref y 0) 2)
    (values x y))
  #(1 b) #(2 d))

(deftest psetf.18a
  (let* ((x (vector 'a 'b))
sds's avatar
sds committed
188
         (y (vector 'c 'd)))
189 190 191 192 193 194
    (psetf (svref x 0) 1 (svref y 0) 2)
    (values x y))
  #(1 b) #(2 d))

(deftest psetf.19
  (let* ((x (copy-seq #*11000))
sds's avatar
sds committed
195
         (y (copy-seq #*11100)))
196 197 198 199 200 201
    (psetf (bit x 1) 0 (bit x 2) 1 (bit y 4) 1 (bit y 0) 0)
    (values x y))
  #*10100 #*01101)

(deftest psetf.20
  (let* ((x (copy-seq "abcde"))
sds's avatar
sds committed
202
         (y (copy-seq "fghij")))
203 204 205 206 207 208
    (psetf (char x 1) #\X (char y 2) #\Y)
    (values x y))
  "aXcde" "fgYij")

(deftest psetf.21
  (let* ((x (copy-seq #*11000))
sds's avatar
sds committed
209
         (y (copy-seq #*11100)))
210 211 212 213 214 215
    (psetf (sbit x 1) 0 (sbit x 2) 1 (sbit y 4) 1 (sbit y 0) 0)
    (values x y))
  #*10100 #*01101)

(deftest psetf.22
  (let* ((x (copy-seq "abcde"))
sds's avatar
sds committed
216
         (y (copy-seq "fghij")))
217 218 219 220 221 222
    (psetf (schar x 1) #\X (schar y 2) #\Y)
    (values x y))
  "aXcde" "fgYij")

(deftest psetf.23
  (let* ((x (copy-seq '(a b c d e)))
sds's avatar
sds committed
223
         (y (copy-seq '(f g h i j))))
224 225 226 227 228 229
    (psetf (elt x 1) 'u (elt y 2) 'v)
    (values x y))
  (a u c d e) (f g v i j))

(deftest psetf.24
  (let ((x #b110110001)
sds's avatar
sds committed
230
        (y #b101001100))
231
    (psetf (ldb (byte 5 1) x) #b10110
sds's avatar
sds committed
232
           (ldb (byte 3 6) y) #b10)
233 234 235 236 237 238
    (values x y))
  #b110101101
  #b010001100)

(deftest psetf.25
  (let* ((f1 (gensym))
sds's avatar
sds committed
239 240 241
         (f2 (gensym))
         (fn1 (constantly :foo))
         (fn2 (constantly :bar)))
242
    (psetf (fdefinition f1) fn1
sds's avatar
sds committed
243
           (fdefinition f2) fn2)
244 245 246 247 248
    (values (funcall f1) (funcall f2)))
  :foo :bar)

(deftest psetf.26
  (let* ((a1 (make-array '(10) :fill-pointer 5))
sds's avatar
sds committed
249
         (a2 (make-array '(20) :fill-pointer 7)))
250
    (psetf (fill-pointer a1) (1+ (fill-pointer a2))
sds's avatar
sds committed
251
           (fill-pointer a2) (1- (fill-pointer a1)))
252 253 254 255 256
    (values (fill-pointer a1) (fill-pointer a2)))
  8 4)

(deftest psetf.27
  (let* ((x (list 'a 'b 'c 'd))
sds's avatar
sds committed
257 258 259
         (y (list 'd 'e 'f 'g))
         (n1 1) (n2 2)
         (v1 :foo) (v2 :bar))
260
    (psetf (nth n1 x) v1
sds's avatar
sds committed
261
           (nth n2 y) v2)
262 263 264 265 266 267
    (values x y))
  (a :foo c d)
  (d e :bar g))

(deftest psetf.28
  (let* ((f1 (gensym))
sds's avatar
sds committed
268 269 270
         (f2 (gensym))
         (fn1 (constantly :foo))
         (fn2 (constantly :bar)))
271
    (psetf (symbol-function f1) fn1
sds's avatar
sds committed
272
           (symbol-function f2) fn2)
273 274 275 276 277
    (values (funcall f1) (funcall f2)))
  :foo :bar)

(deftest psetf.29
  (let* ((s1 (gensym))
sds's avatar
sds committed
278 279 280
         (s2 (gensym))
         (v1 :foo)
         (v2 :bar))
281
    (psetf (symbol-value s1) v1
sds's avatar
sds committed
282
           (symbol-value s2) v2)
283 284 285 286 287
    (values (symbol-value s1) (symbol-value s2)))
  :foo :bar)

(deftest psetf.30
  (let* ((s1 (gensym))
sds's avatar
sds committed
288 289 290
         (s2 (gensym))
         (v1 (list :foo 1))
         (v2 (list :bar 2)))
291
    (psetf (symbol-plist s1) v1
sds's avatar
sds committed
292
           (symbol-plist s2) v2)
293 294 295 296 297
    (values (symbol-plist s1) (symbol-plist s2)))
  (:foo 1) (:bar 2))

(deftest psetf.31
  (let* ((x (list 'a 'b 'c 'd 'e))
sds's avatar
sds committed
298 299 300 301 302 303
         (y (list 'f 'g 'h 'i 'j))
         (v1 (list 1 2))
         (v2 (list 3 4 5))
         (p1 1) (p2 2)
         (l1 (length v1))
         (l2 (length v2)))
304
    (psetf (subseq x p1 (+ p1 l1)) v1
sds's avatar
sds committed
305
           (subseq y p2 (+ p2 l2)) v2)
306 307 308 309 310 311
    (values x y))
  (a 1 2 d e)
  (f g 3 4 5))

(deftest psetf.32
  (let* ((x (gensym))
sds's avatar
sds committed
312 313 314 315 316
         (y (gensym))
         (k1 :foo)
         (k2 :bar)
         (v1 1)
         (v2 2))
317 318 319 320 321 322
    (psetf (get x k1) v1 (get y k2) v2)
    (values (symbol-plist x) (symbol-plist y)))
  (:foo 1) (:bar 2))

(deftest psetf.33
  (let* ((x nil)
sds's avatar
sds committed
323 324 325 326 327
         (y nil)
         (k1 :foo)
         (k2 :bar)
         (v1 1)
         (v2 2))
328 329 330 331 332 333
    (psetf (getf x k1) v1 (getf y k2) v2)
    (values x y))
  (:foo 1) (:bar 2))

(deftest psetf.34
  (let* ((ht1 (make-hash-table))
sds's avatar
sds committed
334 335 336
         (ht2 (make-hash-table))
         (k1 :foo) (v1 1)
         (k2 :bar) (v2 2))
337
    (psetf (gethash k1 ht1) v1
sds's avatar
sds committed
338
           (gethash k2 ht2) v2)
339 340 341 342 343
    (values (gethash k1 ht1) (gethash k2 ht2)))
  1 2)

(deftest psetf.35
  (let ((n1 (gensym))
sds's avatar
sds committed
344 345 346
        (n2 (gensym))
        (n3 (gensym))
        (n4 (gensym)))
347 348 349
    (eval `(defclass ,n1 () ()))
    (eval `(defclass ,n2 () ()))
    (psetf (find-class n3) (find-class n1)
sds's avatar
sds committed
350
           (find-class n4) (find-class n2))
351
    (values (eqlt (find-class n1) (find-class n3))
sds's avatar
sds committed
352
            (eqlt (find-class n2) (find-class n4))))
353 354 355 356
  t t)

(deftest psetf.36
  (let ((fn1 (constantly :foo))
sds's avatar
sds committed
357 358 359
        (fn2 (constantly :bar))
        (n1 (gensym))
        (n2 (gensym)))
360
    (psetf (macro-function n1) fn1
sds's avatar
sds committed
361
           (macro-function n2) fn2)
362 363 364 365 366
    (values (eval `(,n1)) (eval `(,n2))))
  :foo :bar)

(deftest psetf.37
  (let ((b1 (byte 3 1))
sds's avatar
sds committed
367 368 369 370 371
        (b2 (byte 4 2))
        (x #b1100101011010101)
        (y #b11010101000110)
        (m1 #b101010101101101)
        (m2 #b11110010110101))
372
    (psetf (mask-field b1 x) m1
sds's avatar
sds committed
373
           (mask-field b2 y) m2)
374 375 376 377 378 379
    (values x y))
  #b1100101011011101
  #b11010101110110)

(deftest psetf.38
  (let* ((a1 (make-array '(2 3) :initial-contents '((a b c)(d e f))))
sds's avatar
sds committed
380 381 382 383
         (a2 (make-array '(3 4) :initial-contents
                         '((1 2 3 4) (5 6 7 8) (9 10 11 12))))
         (i1 2) (i2 5)
         (v1 'u) (v2 'v))
384
    (psetf (row-major-aref a1 i1) v1
sds's avatar
sds committed
385
           (row-major-aref a2 i2) v2)
386 387 388 389
    (values a1 a2))
  #2a((a b u)(d e f))
  #2a((1 2 3 4)(5 v 7 8)(9 10 11 12)))

390 391 392 393 394 395 396 397 398
;;; Test that explicit calls to macroexpand in subforms
;;; are done in the correct environment

(deftest psetf.39
  (macrolet
   ((%m (z) z))
   (let ((x 1) (y 2))
     (values
      (psetf (expand-in-current-env (%m x)) y
sds's avatar
sds committed
399
             y x)
400 401 402 403 404 405 406 407 408
      x y)))
  nil 2 1)

(deftest psetf.40
  (macrolet
   ((%m (z) z))
   (let ((x 1) (y 2))
     (values
      (psetf x (expand-in-current-env (%m y))
sds's avatar
sds committed
409
             y x)
410 411 412
      x y)))
  nil 2 1)

413 414 415 416 417 418 419 420 421
;; Test, if psetf handles correctly multiple values.
(deftest psetf.41
    (let ((y 2) (z 3) u x a b c)
      (psetf (values a b c) (values 1 2 3)
             (values u x)   (values y z))
      (values a b c u x))
  1 2 3 2 3)


422
;;; TODO: logical-pathname-translations, readtable-case