elt.lsp 10.7 KB
Newer Older
1 2 3 4 5 6 7 8 9 10 11
;-*- Mode:     Lisp -*-
;;;; Author:   Paul Dietz
;;;; Created:  Sat Oct 12 19:38:29 2002
;;;; Contains: Tests of ELT

(in-package :cl-test)

(declaim (optimize (safety 3)))

;; elt on lists

12
(deftest elt.1
pfdietz's avatar
pfdietz committed
13
  (signals-error (elt nil  0) type-error)
14
  t)
15

16
(deftest elt.1a
17 18
  (signals-error (elt nil -10) type-error)
  t)
19

20
(deftest elt.1b
21 22
  (signals-error (locally (elt nil 0) t) type-error)
  t)
23

24
(deftest elt.2
25 26
  (signals-error (elt nil 1000000) type-error)
  t)
27

28 29 30
(deftest elt.3 (elt '(a b c d e) 0) a)
(deftest elt.4 (elt '(a b c d e) 2) c)
(deftest elt.5 (elt '(a b c d e) 4) e)
sds's avatar
sds committed
31
(deftest elt.5a
32 33
  (signals-error (elt '(a b c d e) -4) type-error)
  t)
34

35
(deftest elt.6
36
  (let ((x (make-int-list 1000)))
37
    (notnot-mv
38
     (every
39
      #'(lambda (i) (eql i (elt x i)))
40
      x)))
41 42
  t)

43
(deftest elt.7
44
  (let* ((x (list 'a 'b 'c 'd))
sds's avatar
sds committed
45
         (y (setf (elt x 0) 'e)))
46 47 48
    (list x y))
  ((e b c d) e))

49
(deftest elt.8
50
  (let* ((x (list 'a 'b 'c 'd))
sds's avatar
sds committed
51
         (y (setf (elt x 1) 'e)))
52 53 54
    (list x y))
  ((a e c d) e))

55
(deftest elt.9
56
  (let* ((x (list 'a 'b 'c 'd))
sds's avatar
sds committed
57
         (y (setf (elt x 3) 'e)))
58 59 60
    (list x y))
  ((a b c e) e))

61
(deftest elt.10
62
  (signals-error
63
   (let ((x (list 'a 'b 'c)))
64 65 66
     (setf (elt x 4) 'd))
   type-error)
  t)
67

68
(deftest elt.11
69 70 71
  (let ((x (list 'a 'b 'c 'd 'e)))
    (let ((y (loop for c on x collect c)))
      (setf (elt x 2) 'f)
72
      (notnot-mv
73
       (every #'eq
sds's avatar
sds committed
74 75
              y
              (loop for c on x collect c)))))
76 77
  t)

78
(deftest elt.12
79
  (let ((x (make-int-list 100000)))
80
    (elt x 90000))
81 82
  90000)

83
(deftest elt.13
84 85
  (let ((x (make-int-list 100000)))
    (setf (elt x 80000) 'foo)
86
    (list (elt x 79999)
sds's avatar
sds committed
87 88
          (elt x 80000)
          (elt x 80001)))
89 90
  (79999 foo 80001))

91
(deftest elt.14
92
  (signals-error
93
   (let ((x (list 'a 'b 'c)))
94 95 96
     (elt x 10))
   type-error)
  t)
97

98
(deftest elt.15
99
  (signals-error
100
   (let ((x (list 'a 'b 'c)))
101 102 103
     (elt x 'a))
   type-error)
  t)
104

105
(deftest elt.16
106
  (signals-error
107
   (let ((x (list 'a 'b 'c)))
108 109 110
     (elt x 10.0))
   type-error)
  t)
111

112
(deftest elt.17
113
  (signals-error
114
   (let ((x (list 'a 'b 'c)))
115 116 117
     (elt x -1))
   type-error)
  t)
118

119
(deftest elt.18
120
  (signals-error
121
   (let ((x (list 'a 'b 'c)))
122 123 124
     (elt x -100000000000000000))
   type-error)
  t)
125

126
(deftest elt.19
127
  (signals-error
128
   (let ((x (list 'a 'b 'c)))
129 130 131
     (elt x #\w))
   type-error)
  t)
132

133
(deftest elt.order.1
134 135 136
  (let ((i 0) x y)
    (values
     (elt (progn (setf x (incf i)) '(a b c d e))
sds's avatar
sds committed
137
          (progn (setf y (incf i)) 3))
138 139 140
     i x y))
  d 2 1 2)

141
(deftest elt.order.2
142 143 144 145
  (let ((i 0) x y z)
    (let ((a (make-array 1 :initial-element (list 'a 'b 'c 'd 'e))))
      (values
       (setf (elt (aref a (progn (setf x (incf i)) 0))
sds's avatar
sds committed
146 147
                  (progn (setf y (incf i)) 3))
             (progn (setf z (incf i)) 'k))
148 149 150 151
       (aref a 0)
       i x y z)))
  k (a b c k e) 3 1 2 3)

152
(deftest elt-v.1
153 154
  (signals-error (elt (make-array '(0)) 0) type-error)
  t)
155

156 157
;; (deftest elt-v.2 (elt (make-array '(1)) 0) nil)  ;; actually undefined
(deftest elt-v.3
158
  (elt (make-array '(5) :initial-contents '(a b c d e)) 0)
159
  a)
160

161
(deftest elt-v.4
162
  (elt (make-array '(5) :initial-contents '(a b c d e)) 2)
163
  c)
164

165
(deftest elt-v.5
166
  (elt (make-array '(5) :initial-contents '(a b c d e)) 4)
167 168
  e)

169
(deftest elt-v.6
170 171 172
    (elt-v-6-body)
  t)

173
(deftest elt-v.7
174
  (let* ((x (make-array '(4) :initial-contents (list 'a 'b 'c 'd)))
sds's avatar
sds committed
175
         (y (setf (elt x 0) 'e)))
176 177 178
    (list (elt x 0) (elt x 1) (elt x 2) (elt x 3) y))
  (e b c d e))

179
(deftest elt-v.8
180
  (let* ((x (make-array '(4) :initial-contents (list 'a 'b 'c 'd)))
sds's avatar
sds committed
181
         (y (setf (elt x 1) 'e)))
182 183 184
    (list (elt x 0) (elt x 1) (elt x 2) (elt x 3) y))
  (a e c d e))

185
(deftest elt-v.9
186
  (let* ((x (make-array '(4) :initial-contents (list 'a 'b 'c 'd)))
sds's avatar
sds committed
187
         (y (setf (elt x 3) 'e)))
188 189 190
    (list (elt x 0) (elt x 1) (elt x 2) (elt x 3) y))
  (a b c e e))

191
(deftest elt-v.10
192
  (signals-error
193
   (let ((x (make-array '(3) :initial-contents (list 'a 'b 'c))))
194 195 196
     (setf (elt x 4) 'd))
   type-error)
  t)
197

198
(deftest elt-v.11
199
  (signals-error
200
   (let ((x (make-array '(3) :initial-contents (list 'a 'b 'c))))
201 202 203
     (setf (elt x -100) 'd))
   type-error)
  t)
204

205
(deftest elt-v.12
206 207 208 209
    (let ((x (make-int-array 100000)))
      (elt x 90000))
  90000)

210
(deftest elt-v.13
211 212 213
  (let ((x (make-int-array 100000)))
    (setf (elt x 80000) 'foo)
    (list (elt x 79999)
sds's avatar
sds committed
214 215
          (elt x 80000)
          (elt x 80001)))
216 217 218 219
  (79999 foo 80001))

;;;  Adjustable arrays

220
(deftest elt-adj-array.1
221 222
  (signals-error (elt (make-adj-array '(0)) 0) type-error)
  t)
223

sds's avatar
sds committed
224
;;; (deftest elt-adj-array.2 (elt (make-adj-array '(1)) 0) nil) ;; actually undefined
225

226
(deftest elt-adj-array.3
227 228 229
 (elt (make-adj-array '(5) :initial-contents '(a b c d e)) 0)
  a)

230
(deftest elt-adj-array.4
231 232 233
 (elt (make-adj-array '(5) :initial-contents '(a b c d e)) 2)
  c)

234
(deftest elt-adj-array.5
235 236 237
 (elt (make-adj-array '(5) :initial-contents '(a b c d e)) 4)
  e)

238
(deftest elt-adj-array.6
239 240 241
    (elt-adj-array-6-body)
  t)

242
(deftest elt-adj-array.7
243
  (let* ((x (make-adj-array '(4) :initial-contents (list 'a 'b 'c 'd)))
sds's avatar
sds committed
244
         (y (setf (elt x 0) 'e)))
245 246 247
    (list (elt x 0) (elt x 1) (elt x 2) (elt x 3) y))
  (e b c d e))

248
(deftest elt-adj-array.8
249
  (let* ((x (make-adj-array '(4) :initial-contents (list 'a 'b 'c 'd)))
sds's avatar
sds committed
250
         (y (setf (elt x 1) 'e)))
251 252 253
    (list (elt x 0) (elt x 1) (elt x 2) (elt x 3) y))
  (a e c d e))

254
(deftest elt-adj-array.9
255
  (let* ((x (make-adj-array '(4) :initial-contents (list 'a 'b 'c 'd)))
sds's avatar
sds committed
256
         (y (setf (elt x 3) 'e)))
257 258 259
    (list (elt x 0) (elt x 1) (elt x 2) (elt x 3) y))
  (a b c e e))

260
(deftest elt-adj-array.10
261
  (signals-error
262
   (let ((x (make-adj-array '(3) :initial-contents (list 'a 'b 'c))))
263 264 265
     (setf (elt x 4) 'd))
   type-error)
  t)
266

267
(deftest elt-adj-array.11
268
  (signals-error
269
   (let ((x (make-adj-array '(3) :initial-contents (list 'a 'b 'c))))
270 271 272
     (setf (elt x -100) 'd))
   type-error)
  t)
273

274
(deftest elt-adj-array.12
275 276 277 278
    (let ((x (make-int-array 100000 #'make-adj-array)))
      (elt x 90000))
  90000)

279
(deftest elt-adj-array.13
280 281 282
    (let ((x (make-int-array 100000 #'make-adj-array)))
    (setf (elt x 80000) 'foo)
    (list (elt x 79999)
sds's avatar
sds committed
283 284
          (elt x 80000)
          (elt x 80001)))
285 286 287 288
  (79999 foo 80001))

;; displaced arrays

sds's avatar
sds committed
289
(deftest elt-displaced-array.1
290 291
  (signals-error (elt (make-displaced-array '(0) 100) 0) type-error)
  t)
292

293
(deftest elt-displaced-array.2
294 295 296
  (elt (make-displaced-array '(1) 100) 0)
  100)

297
(deftest elt-displaced-array.3
298 299
  (elt (make-displaced-array '(5) 100) 4)
  104)
300 301 302

;;; Arrays with fill points

303
(deftest elt-fill-pointer.1
304
  (let ((a (make-array '(5) :initial-contents '(a b c d e)
sds's avatar
sds committed
305
                       :fill-pointer 3)))
306 307 308
    (values (elt a 0) (elt a 1) (elt a 2)))
  a b c)

309
(deftest elt-fill-pointer.2
310
  (let ((a (make-array '(5)
sds's avatar
sds committed
311 312 313
                       :initial-contents '(0 0 1 0 0)
                       :element-type 'bit
                       :fill-pointer 3)))
314 315 316
    (values (elt a 0) (elt a 1) (elt a 2)))
  0 0 1)

317
(deftest elt-fill-pointer.3
318
  (signals-error
319
   (let ((a (make-array '(5)
sds's avatar
sds committed
320 321
                        :initial-contents '(0 0 1 0 0)
                        :fill-pointer 3)))
322 323 324
     (elt a 4))
   type-error)
  t)
325

326
(deftest elt-fill-pointer.4
327
  (signals-error
328
   (let ((a (make-array '(5)
sds's avatar
sds committed
329 330 331
                        :initial-contents '(0 0 1 0 0)
                        :element-type 'bit
                        :fill-pointer 3)))
332 333 334
     (elt a 4))
   type-error)
  t)
335

336
(deftest elt-fill-pointer.5
337
   (let ((a (make-array '(5)
sds's avatar
sds committed
338 339 340
                        :initial-contents '(#\a #\b #\c #\d #\e)
                        :element-type 'character
                        :fill-pointer 3)))
341 342 343
     (values (elt a 0) (elt a 1) (elt a 2)))
   #\a #\b #\c)

344
(deftest elt-fill-pointer.6
345
  (signals-error
346
   (let ((a (make-array '(5)
sds's avatar
sds committed
347 348 349
                        :initial-contents '(#\a #\b #\c #\d #\e)
                        :element-type 'character
                        :fill-pointer 3)))
350 351 352
     (elt a 4))
   type-error)
  t)
353

354
(deftest elt-fill-pointer.7
355
   (let ((a (make-array '(5)
sds's avatar
sds committed
356 357 358
                        :initial-contents '(#\a #\b #\c #\d #\e)
                        :element-type 'base-char
                        :fill-pointer 3)))
359 360 361
     (values (elt a 0) (elt a 1) (elt a 2)))
   #\a #\b #\c)

362
(deftest elt-fill-pointer.8
363
  (signals-error
364
   (let ((a (make-array '(5)
sds's avatar
sds committed
365 366 367
                        :initial-contents '(#\a #\b #\c #\d #\e)
                        :element-type 'base-char
                        :fill-pointer 3)))
368 369 370
     (elt a 4))
   type-error)
  t)
371

372 373 374 375 376 377 378 379 380 381
;;; Specialized strings

(deftest elt.special-strings.1
  (do-special-strings
   (s "abcde" nil)
   (assert (char= (elt s 0) #\a))
   (assert (char= (elt s 3) #\d))
   (assert (char= (elt s 4) #\e)))
  nil)

382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407
;;; Specialized integer vectors

(deftest elt.special-vectors.1
  (do-special-integer-vectors
   (v #(1 1 0 1 0 1) nil)
   (assert (= (elt v 0) 1))
   (assert (= (elt v 1) 1))
   (assert (= (elt v 2) 0))
   (assert (= (elt v 3) 1))
   (assert (= (elt v 4) 0))
   (assert (= (elt v 5) 1)))
  nil)

(deftest elt.special-vectors.2
  (do-special-integer-vectors
   (v #(1 2 0 -1 0 3) nil)
   (assert (= (elt v 0) 1))
   (assert (= (elt v 1) 2))
   (assert (= (elt v 2) 0))
   (assert (= (elt v 3) -1))
   (assert (= (elt v 4) 0))
   (assert (= (elt v 5) 3)))
  nil)

(deftest elt.special-vectors.3
  (loop for type in '(short-float single-float long-float double-float)
sds's avatar
sds committed
408 409 410 411 412 413
        for len = 10
        for vals = (loop for i from 1 to len collect (coerce i type))
        for vec = (make-array len :element-type type :initial-contents vals)
        unless (loop for i below len always (eql (elt vec i)
                                                 (coerce (1+ i) type)))
        collect (list type vals vec))
414 415 416 417
  nil)

(deftest elt.special-vectors.4
  (loop for etype in '(short-float single-float long-float double-float
sds's avatar
sds committed
418 419 420 421 422 423 424 425 426
                                   integer rational)
        for type = `(complex ,etype)
        for len = 10
        for vals = (loop for i from 1 to len collect (complex (coerce i etype)
                                                              (coerce (- i) etype)))
        for vec = (make-array len :element-type type :initial-contents vals)
        unless (loop for i below len always (eql (elt vec i)
                                                 (elt vals i)))
        collect (list type vals vec))
427 428 429 430
  nil)



431 432
;;; Error tests

433
(deftest elt.error.1
434 435
  (signals-error (elt) program-error)
  t)
436 437

(deftest elt.error.2
438 439
  (signals-error (elt nil) program-error)
  t)
440 441

(deftest elt.error.3
442 443
  (signals-error (elt nil 0 nil) program-error)
  t)
444 445 446 447 448 449 450 451 452 453 454 455 456 457

(deftest elt.error.4
  (do-special-integer-vectors
   (v #(1 1 0 1 0 1) nil)
   (assert (eql t (eval `(signals-error (elt ,v -1) type-error))))
   (assert (eql t (eval `(signals-error (elt ,v 6) type-error)))))
  nil)

(deftest elt.error.5
  (do-special-strings
   (s "ABCDEFGH" nil)
   (assert (eql t (eval `(signals-error (elt ,s -1) type-error))))
   (assert (eql t (eval `(signals-error (elt ,s 8) type-error)))))
  nil)