adjust-array.lsp 35.4 KB
Newer Older
pfdietz's avatar
pfdietz committed
1 2 3 4 5 6 7
;-*- Mode:     Lisp -*-
;;;; Author:   Paul Dietz
;;;; Created:  Sun Feb 15 07:27:22 2004
;;;; Contains: Tests of ADJUST-ARRAY

(in-package :cl-test)

8 9 10 11 12
(defun listify-form (form)
  (cond
   ((integerp form) `'(,form))
   ((null form) nil)
   ((and (consp form)
sds's avatar
sds committed
13 14
         (eq (car form) 'quote)
         (consp (cadr form)))
15 16
    form)
   (t `(let ((x ,form)) (if (listp x) x (list x))))))
sds's avatar
sds committed
17

18

19
(defmacro def-adjust-array-test (name args1 args2 expected-result)
20 21
  `(deftest ,name
     (let* ((a1 (make-array ,@args1))
sds's avatar
sds committed
22
            (a2 (adjust-array a1 ,@args2)))
23 24
       (assert (or (not (adjustable-array-p a1)) (eq a1 a2)))
       (assert (or (adjustable-array-p a1)
sds's avatar
sds committed
25
                   (equal (array-dimensions a1) ,(listify-form (first args1)))))
26 27
       (assert (equal (array-dimensions a2) ,(listify-form (first args2))))
       ,@(unless (or (member :displaced-to args1)
sds's avatar
sds committed
28 29
                     (member :displaced-to args2))
           (list '(assert (not (array-displacement a2)))))
30 31 32 33 34 35
       a2)
     ,expected-result))

(defmacro def-adjust-array-fp-test (name args1 args2 misc &rest expected-results)
   `(deftest ,name
     (let* ((a1 (make-array ,@args1))
sds's avatar
sds committed
36
            (a2 (adjust-array a1 ,@args2)))
37 38
       (assert (or (not (adjustable-array-p a1)) (eq a1 a2)))
       (assert (or (adjustable-array-p a1)
sds's avatar
sds committed
39
                   (equal (array-dimensions a1) ,(listify-form (first args1)))))
40 41
       (assert (equal (array-dimensions a2) ,(listify-form (first args2))))
       ,@(unless (or (member :displaced-to args1)
sds's avatar
sds committed
42 43
                     (member :displaced-to args2))
           (list '(assert (not (array-displacement a2)))))
44 45
       ,@(when misc (list misc))
       (values
sds's avatar
sds committed
46 47
        (fill-pointer a2)
        a2))
48
     ,@expected-results))
49 50 51 52

(def-adjust-array-test adjust-array.1
  (5 :initial-contents '(a b c d e))
  (4)
pfdietz's avatar
pfdietz committed
53 54
  #(a b c d))

55 56 57
(def-adjust-array-test adjust-array.2
  (5 :initial-contents '(a b c d e))
  (8 :initial-element 'x)
pfdietz's avatar
pfdietz committed
58 59
  #(a b c d e x x x))

60 61 62 63

(def-adjust-array-test adjust-array.3
  (5 :initial-contents '(a b c d e))
  (4 :initial-contents '(w x y z))
pfdietz's avatar
pfdietz committed
64 65
  #(w x y z))

66 67 68
(def-adjust-array-test adjust-array.4
  (5 :initial-contents '(a b c d e))
  (8 :initial-contents '(8 7 6 5 4 3 2 1))
pfdietz's avatar
pfdietz committed
69 70
  #(8 7 6 5 4 3 2 1))

71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92
(def-adjust-array-fp-test adjust-array.5
  (5 :initial-contents '(a b c d e) :fill-pointer 3)
  (4)
  (assert (eq (aref a2 3) 'd))
  3 #(a b c))

(def-adjust-array-fp-test adjust-array.6
  (5 :initial-contents '(a b c d e) :fill-pointer 3)
  (4 :fill-pointer nil)
  (assert (eq (aref a2 3) 'd))
  3 #(a b c))

(def-adjust-array-fp-test adjust-array.7
  (5 :initial-contents '(a b c d e) :fill-pointer 3)
  (4 :fill-pointer t)
  nil
  4 #(a b c d))

(def-adjust-array-fp-test adjust-array.8
  (5 :initial-contents '(a b c d e) :fill-pointer 3)
  (4 :fill-pointer 2)
  (progn (assert (eq (aref a2 2) 'c))
sds's avatar
sds committed
93
         (assert (eq (aref a2 3) 'd)))
94 95 96 97 98 99 100
  2 #(a b))

(def-adjust-array-fp-test adjust-array.9
  (5 :initial-contents '(a b c d e) :fill-pointer 3)
  (8 :fill-pointer 5 :initial-element 'x)
  (assert (equal (list (aref a2 5) (aref a2 6) (aref a2 7)) '(x x x)))
  5 #(a b c d e))
pfdietz's avatar
pfdietz committed
101 102 103

(deftest adjust-array.10
  (let* ((a1 (make-array 5 :initial-contents '(a b c d e)))
sds's avatar
sds committed
104
         (a2 (adjust-array a1 4 :displaced-to nil)))
pfdietz's avatar
pfdietz committed
105
    (assert (if (adjustable-array-p a1)
sds's avatar
sds committed
106 107
                (eq a1 a2)
              (equal (array-dimensions a1) '(5))))
pfdietz's avatar
pfdietz committed
108 109 110 111 112 113
    (assert (not (array-displacement a2)))
    a2)
  #(a b c d))

(deftest adjust-array.11
  (let* ((a0 (make-array 7 :initial-contents '(x a b c d e y)))
sds's avatar
sds committed
114 115
         (a1 (make-array 5 :displaced-to a0 :displaced-index-offset 1))
         (a2 (adjust-array a1 4)))
pfdietz's avatar
pfdietz committed
116
    (assert (if (adjustable-array-p a1)
sds's avatar
sds committed
117 118
                (eq a1 a2)
              (equal (array-dimensions a1) '(5))))
pfdietz's avatar
pfdietz committed
119 120 121 122 123 124
    (assert (not (array-displacement a2)))
    a2)
  #(a b c d))

(deftest adjust-array.12
  (let* ((a0 (make-array 7 :initial-contents '(1 2 3 4 5 6 7)))
sds's avatar
sds committed
125 126
         (a1 (make-array 5 :initial-contents '(a b c d e)))
         (a2 (adjust-array a1 4 :displaced-to a0)))
pfdietz's avatar
pfdietz committed
127
    (assert (if (adjustable-array-p a1)
sds's avatar
sds committed
128 129
                (eq a1 a2)
              (equal (array-dimensions a1) '(5))))
pfdietz's avatar
pfdietz committed
130
    (assert (equal (multiple-value-list (array-displacement a2))
sds's avatar
sds committed
131
                   (list a0 0)))
pfdietz's avatar
pfdietz committed
132 133 134 135 136
    a2)
  #(1 2 3 4))

(deftest adjust-array.13
  (let* ((a0 (make-array 7 :initial-contents '(1 2 3 4 5 6 7)))
sds's avatar
sds committed
137 138 139
         (a1 (make-array 5 :initial-contents '(a b c d e)))
         (a2 (adjust-array a1 4 :displaced-to a0
                           :displaced-index-offset 2)))
pfdietz's avatar
pfdietz committed
140
    (assert (if (adjustable-array-p a1)
sds's avatar
sds committed
141 142
                (eq a1 a2)
              (equal (array-dimensions a1) '(5))))
pfdietz's avatar
pfdietz committed
143
    (assert (equal (multiple-value-list (array-displacement a2))
sds's avatar
sds committed
144
                   (list a0 2)))
pfdietz's avatar
pfdietz committed
145 146 147
    a2)
  #(3 4 5 6))

pfdietz's avatar
pfdietz committed
148 149
(deftest adjust-array.14
  (let* ((a0 (make-array 7 :initial-contents '(1 2 3 4 5 6 7)))
sds's avatar
sds committed
150 151
         (a1 (make-array 5 :displaced-to a0 :displaced-index-offset 1))
         (a2 (adjust-array a1 4 :displaced-to a0)))
pfdietz's avatar
pfdietz committed
152
    (assert (if (adjustable-array-p a1)
sds's avatar
sds committed
153 154
                (eq a1 a2)
              (equal (array-dimensions a1) '(5))))
pfdietz's avatar
pfdietz committed
155
    (assert (equal (multiple-value-list (array-displacement a2))
sds's avatar
sds committed
156
                   (list a0 0)))
pfdietz's avatar
pfdietz committed
157 158 159 160 161
    a2)
  #(1 2 3 4))

(deftest adjust-array.15
  (let* ((a0 (make-array 7 :initial-contents '(1 2 3 4 5 6 7)))
sds's avatar
sds committed
162 163 164
         (a1 (make-array 5 :displaced-to a0 :displaced-index-offset 1))
         (a2 (make-array 4 :displaced-to a1 :displaced-index-offset 1))
         (a3 (adjust-array a2 4 :displaced-to a1)))
pfdietz's avatar
pfdietz committed
165 166
    a3)
  #(2 3 4 5))
pfdietz's avatar
pfdietz committed
167

pfdietz's avatar
pfdietz committed
168 169
(deftest adjust-array.16
  (let* ((a0 (make-array 7 :initial-contents '(1 2 3 4 5 6 7)))
sds's avatar
sds committed
170 171
         (a1 (make-array 5 :displaced-to a0 :displaced-index-offset 1))
         (a2 (adjust-array a1 5 :displaced-to a0)))
pfdietz's avatar
pfdietz committed
172 173 174
    a2)
  #(1 2 3 4 5))

175 176 177 178
(def-adjust-array-test adjust-array.17
  (nil :initial-element 'x)
  (nil)
  #0ax)
pfdietz's avatar
pfdietz committed
179

180 181 182
(def-adjust-array-test adjust-array.18
  (nil :initial-element 'x)
  (nil :initial-contents 'y)
pfdietz's avatar
pfdietz committed
183 184
  #0ay)

185 186 187 188
(def-adjust-array-test adjust-array.19
  (nil :initial-element 'x)
  (nil :initial-element 'y)
  #0ax)
pfdietz's avatar
pfdietz committed
189

190 191
(deftest adjust-array.20
  (let* ((a0 (make-array nil :initial-element 'x))
sds's avatar
sds committed
192 193
         (a1 (make-array nil :displaced-to a0))
         (a2 (adjust-array a1 nil)))
194 195 196 197 198
    a2)
  #0ax)

;; 2-d arrays

199 200
(def-adjust-array-test adjust-array.21
  ('(4 5) :initial-contents '((1 2 3 4 5)
sds's avatar
sds committed
201 202 203
                              (3 4 5 6 7)
                              (5 6 7 8 9)
                              (7 8 9 1 2)))
204
  ('(2 3))
205 206
  #2a((1 2 3)(3 4 5)))

207 208
(def-adjust-array-test adjust-array.22
  ('(4 5) :initial-contents '((1 2 3 4 5)
sds's avatar
sds committed
209 210 211
                              (3 4 5 6 7)
                              (5 6 7 8 9)
                              (7 8 9 1 2)))
212
  ('(6 8) :initial-element 0)
213 214 215 216 217 218 219 220 221
  #2a((1 2 3 4 5 0 0 0)
      (3 4 5 6 7 0 0 0)
      (5 6 7 8 9 0 0 0)
      (7 8 9 1 2 0 0 0)
      (0 0 0 0 0 0 0 0)
      (0 0 0 0 0 0 0 0)))

(deftest adjust-array.23
  (let* ((a1 (make-array '(4 5) :initial-contents '((#\1 #\2 #\3 #\4 #\5)
sds's avatar
sds committed
222 223 224 225 226
                                                    (#\3 #\4 #\5 #\6 #\7)
                                                    (#\5 #\6 #\7 #\8 #\9)
                                                    (#\7 #\8 #\9 #\1 #\2))
                         :element-type 'character))
         (a2 (adjust-array a1 '(2 3) :element-type 'character)))
227
    (assert (if (adjustable-array-p a1)
sds's avatar
sds committed
228 229
                (eq a1 a2)
              (equal (array-dimensions a2) '(2 3))))
230 231 232 233
    (assert (not (typep 0 (array-element-type a2))))
    a2)
  #2a((#\1 #\2 #\3)(#\3 #\4 #\5)))

234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261
;;; Macro expansion tests

(deftest adjust-array.24
  (macrolet
   ((%m (z) z))
   (let ((a (make-array '(4) :initial-contents '(a b c d))))
     (adjust-array (expand-in-current-env (%m a)) '(4))))
  #(a b c d))

(deftest adjust-array.25
  (macrolet
   ((%m (z) z))
   (let ((a (make-array '(4) :initial-contents '(a b c d))))
     (adjust-array a (expand-in-current-env (%m '(4))))))
  #(a b c d))

(deftest adjust-array.26
  (macrolet
   ((%m (z) z))
   (let ((a (make-array '(4) :initial-contents '(a b c d))))
     (adjust-array a '(4) (expand-in-current-env (%m :element-type)) t)))
  #(a b c d))

(deftest adjust-array.27
  (macrolet
   ((%m (z) z))
   (let ((a (make-array '(4) :initial-contents '(a b c d))))
     (adjust-array a '(4) :element-type
sds's avatar
sds committed
262
                   (expand-in-current-env (%m t)))))
263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283
  #(a b c d))

(deftest adjust-array.28
  (macrolet
   ((%m (z) z))
   (let ((a (make-array '(4) :initial-contents '(a b c d))))
     (adjust-array a '(6) (expand-in-current-env (%m :initial-element)) 17)))
  #(a b c d 17 17))

(deftest adjust-array.29
  (macrolet
   ((%m (z) z))
   (let ((a (make-array '(4) :initial-contents '(a b c d))))
     (adjust-array a '(7) :initial-element (expand-in-current-env (%m 5)))))
  #(a b c d 5 5 5))

(deftest adjust-array.30
  (macrolet
   ((%m (z) z))
   (let ((a (make-array '(4) :initial-contents '(a b c d))))
     (adjust-array a '(6) (expand-in-current-env (%m :initial-contents))
sds's avatar
sds committed
284
                   '(1 2 3 4 5 6))))
285 286 287 288 289 290 291
  #(1 2 3 4 5 6))

(deftest adjust-array.31
  (macrolet
   ((%m (z) z))
   (let ((a (make-array '(4) :initial-contents '(a b c d))))
     (adjust-array a '(3) :initial-contents
sds's avatar
sds committed
292
                   (expand-in-current-env (%m "ABC")))))
293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320
  #(#\A #\B #\C))

(deftest adjust-array.32
  (macrolet
   ((%m (z) z))
   (let ((a (make-array '(4) :initial-contents '(a b c d))))
     (adjust-array a '(4) (expand-in-current-env (%m :fill-pointer)) nil)))
  #(a b c d))

(deftest adjust-array.33
  (macrolet
   ((%m (z) z))
   (let ((a (make-array '(4) :initial-contents '(a b c d))))
     (adjust-array a '(4) :fill-pointer (expand-in-current-env (%m nil)))))
  #(a b c d))

(deftest adjust-array.34
  (macrolet
   ((%m (z) z))
   (let ((a (make-array '(4) :initial-contents '(a b c d))))
     (adjust-array a '(4) (expand-in-current-env (%m :displaced-to)) nil)))
  #(a b c d))

(deftest adjust-array.35
  (macrolet
   ((%m (z) z))
   (let ((a (make-array '(4) :initial-contents '(a b c d))))
     (adjust-array a '(4) :displaced-to
sds's avatar
sds committed
321
                   (expand-in-current-env (%m nil)))))
322 323 324 325 326 327
  #(a b c d))

(deftest adjust-array.36
  (macrolet
   ((%m (z) z))
   (let ((a (make-array '(4) :initial-contents '(a b c d)))
sds's avatar
sds committed
328
         (c (make-array '(8) :initial-contents '(1 2 3 4 5 6 7 8))))
329
     (adjust-array a '(3) :displaced-to c
sds's avatar
sds committed
330 331
                   (expand-in-current-env (%m :displaced-index-offset))
                   2)))
332 333 334 335 336 337
  #(3 4 5))

(deftest adjust-array.37
  (macrolet
   ((%m (z) z))
   (let ((a (make-array '(4) :initial-contents '(a b c d)))
sds's avatar
sds committed
338
         (c (make-array '(8) :initial-contents '(1 2 3 4 5 6 7 8))))
339
     (adjust-array a '(5) :displaced-to c
sds's avatar
sds committed
340 341
                   :displaced-index-offset
                   (expand-in-current-env (%m 1)))))
342 343
  #(2 3 4 5 6))

pfdietz's avatar
pfdietz committed
344 345
;;; Adjust an adjustable array

346 347 348
(def-adjust-array-test adjust-array.adjustable.1
  (5 :initial-contents '(a b c d e) :adjustable t)
  (4)
pfdietz's avatar
pfdietz committed
349 350
  #(a b c d))

351 352 353
(def-adjust-array-test adjust-array.adjustable.2
  (5 :initial-contents '(a b c d e) :adjustable t)
  (8 :initial-element 'x)
pfdietz's avatar
pfdietz committed
354 355
  #(a b c d e x x x))

356 357 358
(def-adjust-array-test adjust-array.adjustable.3
  (5 :initial-contents '(a b c d e) :adjustable t)
  (4 :initial-contents '(w x y z))
pfdietz's avatar
pfdietz committed
359 360
  #(w x y z))

361 362 363
(def-adjust-array-test adjust-array.adjustable.4
  (5 :initial-contents '(a b c d e) :adjustable t)
  (8 :initial-contents '(8 7 6 5 4 3 2 1))
pfdietz's avatar
pfdietz committed
364 365
  #(8 7 6 5 4 3 2 1))

366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394
(def-adjust-array-fp-test adjust-array.adjustable.5
  (5 :initial-contents '(a b c d e) :fill-pointer 3 :adjustable t)
  (4)
  (assert (eq (aref a2 3) 'd))
  3 #(a b c))

(def-adjust-array-fp-test adjust-array.adjustable.6
  (5 :initial-contents '(a b c d e) :fill-pointer 3 :adjustable t)
  (4 :fill-pointer nil)
  (assert (eq (aref a2 3) 'd))
  3 #(a b c))

(def-adjust-array-fp-test adjust-array.adjustable.7
  (5 :initial-contents '(a b c d e) :fill-pointer 3 :adjustable t)
  (4 :fill-pointer t)
  nil
  4 #(a b c d))

(def-adjust-array-fp-test adjust-array.adjustable.8
  (5 :initial-contents '(a b c d e) :fill-pointer 3 :adjustable t)
  (4 :fill-pointer 2)
  (assert (equal (list (aref a2 2) (aref a2 3)) '(c d)))
  2 #(a b))

(def-adjust-array-fp-test adjust-array.adjustable.9
  (5 :initial-contents '(a b c d e) :fill-pointer 3 :adjustable t)
  (8 :fill-pointer 5 :initial-element 'x)
  (assert (equal (list (aref a2 5) (aref a2 6) (aref a2 7)) '(x x x)))
  5 #(a b c d e))
pfdietz's avatar
pfdietz committed
395 396 397

(deftest adjust-array.adjustable.10
  (let* ((a1 (make-array 5 :initial-contents '(a b c d e)
sds's avatar
sds committed
398 399
                         :adjustable t))
         (a2 (adjust-array a1 4 :displaced-to nil)))
pfdietz's avatar
pfdietz committed
400 401 402 403 404 405 406
    (assert (eq a1 a2))
    (assert (not (array-displacement a2)))
    a2)
  #(a b c d))

(deftest adjust-array.adjustable.11
  (let* ((a0 (make-array 7 :initial-contents '(x a b c d e y)))
sds's avatar
sds committed
407 408 409
         (a1 (make-array 5 :displaced-to a0 :displaced-index-offset 1
                         :adjustable t))
         (a2 (adjust-array a1 4)))
pfdietz's avatar
pfdietz committed
410 411 412 413 414
    (assert (eq a1 a2))
    (assert (not (array-displacement a2)))
    a2)
  #(a b c d))

pfdietz's avatar
pfdietz committed
415 416
(deftest adjust-array.adjustable.12
  (let* ((a0 (make-array 7 :initial-contents '(x a b c d e y)))
sds's avatar
sds committed
417 418 419
         (a1 (make-array 5 :displaced-to a0 :displaced-index-offset 1
                         :adjustable t))
         (a2 (adjust-array a1 4 :displaced-to a0)))
pfdietz's avatar
pfdietz committed
420 421 422
    (assert (eq a1 a2))
    a2)
  #(x a b c))
pfdietz's avatar
pfdietz committed
423

pfdietz's avatar
pfdietz committed
424 425
(deftest adjust-array.adjustable.13
  (let* ((a0 (make-array 7 :initial-contents '(x a b c d e y)))
sds's avatar
sds committed
426 427 428
         (a1 (make-array 5 :displaced-to a0 :displaced-index-offset 1
                         :adjustable t))
         (a2 (make-array 4 :displaced-to a1 :displaced-index-offset 1)))
pfdietz's avatar
pfdietz committed
429
    (assert (eq a1 (adjust-array a1 5 :displaced-to a0
sds's avatar
sds committed
430
                                 :displaced-index-offset 2)))
pfdietz's avatar
pfdietz committed
431 432
    a2)
  #(c d e y))
pfdietz's avatar
pfdietz committed
433 434


435 436
;;;; Strings

pfdietz's avatar
pfdietz committed
437 438
(loop for element-type in '(character base-char)
      for forms = `(
439 440 441 442 443 444 445 446 447 448 449 450 451 452 453
(def-adjust-array-test adjust-array.string.1
  (5 :element-type 'character :initial-contents "abcde")
  (4 :element-type 'character)
  "abcd")

(def-adjust-array-test adjust-array.string.2
  (5 :element-type 'character :initial-contents "abcde")
  (8 :element-type 'character :initial-element #\x)
  "abcdexxx")

(def-adjust-array-test adjust-array.string.3
  (5 :element-type 'character :initial-contents "abcde")
  (4 :element-type 'character :initial-contents "wxyz")
  "wxyz")

pfdietz's avatar
pfdietz committed
454
(def-adjust-array-test adjust-array.string.4
455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480
  (5 :element-type 'character :initial-contents "abcde")
  (8 :element-type 'character :initial-contents "87654321")
  "87654321")

(def-adjust-array-fp-test adjust-array.string.5
  (5 :element-type 'character :initial-contents "abcde" :fill-pointer 3)
  (4 :element-type 'character)
  (assert (eql (aref a2 3) #\d))
  3 "abc")

(def-adjust-array-fp-test adjust-array.string.6
  (5 :element-type 'character :initial-contents "abcde" :fill-pointer 3)
  (4 :element-type 'character :fill-pointer nil)
  (assert (eql (aref a2 3) #\d))
  3 "abc")

(def-adjust-array-fp-test adjust-array.string.7
  (5 :element-type 'character :initial-contents "abcde" :fill-pointer 3)
  (4 :element-type 'character :fill-pointer t)
  nil
  4 "abcd")

(def-adjust-array-fp-test adjust-array.string.8
  (5 :element-type 'character :initial-contents "abcde" :fill-pointer 3)
  (4 :element-type 'character :fill-pointer 2)
  (progn (assert (eql (aref a2 2) #\c))
sds's avatar
sds committed
481
         (assert (eql (aref a2 3) #\d)))
482 483 484 485 486 487
  2 "ab")

(def-adjust-array-fp-test adjust-array.string.9
  (5 :element-type 'character :initial-contents "abcde" :fill-pointer 3)
  (8 :element-type 'character :fill-pointer 5 :initial-element #\x)
  (assert (equal (list (aref a2 5) (aref a2 6) (aref a2 7))
sds's avatar
sds committed
488
                 '(#\x #\x #\x)))
489 490
  5 "abcde")

pfdietz's avatar
pfdietz committed
491 492
(deftest adjust-array.string.10
  (let* ((a1 (make-array 5 :element-type 'character :initial-contents "abcde"))
sds's avatar
sds committed
493
         (a2 (adjust-array a1 4 :displaced-to nil :element-type 'character)))
pfdietz's avatar
pfdietz committed
494
    (assert (if (adjustable-array-p a1)
sds's avatar
sds committed
495 496
                (eq a1 a2)
              (equal (array-dimensions a1) '(5))))
pfdietz's avatar
pfdietz committed
497 498 499 500 501 502
    (assert (not (array-displacement a2)))
    a2)
  "abcd")

(deftest adjust-array.string.11
  (let* ((a0 (make-array 7 :initial-contents "xabcdey" :element-type 'character))
sds's avatar
sds committed
503 504 505
         (a1 (make-array 5 :displaced-to a0 :displaced-index-offset 1
                         :element-type 'character))
         (a2 (adjust-array a1 4 :element-type 'character)))
pfdietz's avatar
pfdietz committed
506
    (assert (if (adjustable-array-p a1)
sds's avatar
sds committed
507 508
                (eq a1 a2)
              (equal (array-dimensions a1) '(5))))
pfdietz's avatar
pfdietz committed
509 510 511 512 513 514
    (assert (not (array-displacement a2)))
    a2)
  "abcd")

(deftest adjust-array.string.12
  (let* ((a0 (make-array 7 :initial-contents "1234567" :element-type 'character))
sds's avatar
sds committed
515 516
         (a1 (make-array 5 :initial-contents "abcde" :element-type 'character))
         (a2 (adjust-array a1 4 :displaced-to a0 :element-type 'character)))
pfdietz's avatar
pfdietz committed
517
    (assert (if (adjustable-array-p a1)
sds's avatar
sds committed
518 519
                (eq a1 a2)
              (equal (array-dimensions a1) '(5))))
pfdietz's avatar
pfdietz committed
520
    (assert (equal (multiple-value-list (array-displacement a2))
sds's avatar
sds committed
521
                   (list a0 0)))
pfdietz's avatar
pfdietz committed
522 523 524 525 526
    a2)
  "1234")

(deftest adjust-array.string.13
  (let* ((a0 (make-array 7 :initial-contents "1234567" :element-type 'character))
sds's avatar
sds committed
527 528 529 530
         (a1 (make-array 5 :initial-contents "abcde" :element-type 'character))
         (a2 (adjust-array a1 4 :displaced-to a0
                           :displaced-index-offset 2
                           :element-type 'character)))
pfdietz's avatar
pfdietz committed
531
    (assert (if (adjustable-array-p a1)
sds's avatar
sds committed
532 533
                (eq a1 a2)
              (equal (array-dimensions a1) '(5))))
pfdietz's avatar
pfdietz committed
534
    (assert (equal (multiple-value-list (array-displacement a2))
sds's avatar
sds committed
535
                   (list a0 2)))
pfdietz's avatar
pfdietz committed
536 537 538 539 540
    a2)
  "3456")

(deftest adjust-array.string.14
  (let* ((a0 (make-array 7 :initial-contents "1234567" :element-type 'character))
sds's avatar
sds committed
541 542 543
         (a1 (make-array 5 :displaced-to a0 :displaced-index-offset 1
                         :element-type 'character))
         (a2 (adjust-array a1 4 :displaced-to a0 :element-type 'character)))
pfdietz's avatar
pfdietz committed
544
    (assert (if (adjustable-array-p a1)
sds's avatar
sds committed
545 546
                (eq a1 a2)
              (equal (array-dimensions a1) '(5))))
pfdietz's avatar
pfdietz committed
547
    (assert (equal (multiple-value-list (array-displacement a2))
sds's avatar
sds committed
548
                   (list a0 0)))
pfdietz's avatar
pfdietz committed
549 550 551 552 553
    a2)
  "1234")

(deftest adjust-array.string.15
  (let* ((a0 (make-array 7 :initial-contents "1234567" :element-type 'character))
sds's avatar
sds committed
554 555 556 557 558
         (a1 (make-array 5 :displaced-to a0 :displaced-index-offset 1
                         :element-type 'character))
         (a2 (make-array 4 :displaced-to a1 :displaced-index-offset 1
                         :element-type 'character))
         (a3 (adjust-array a2 4 :displaced-to a1 :element-type 'character)))
pfdietz's avatar
pfdietz committed
559 560 561 562 563
    a3)
  "2345")

(deftest adjust-array.string.16
  (let* ((a0 (make-array 7 :initial-contents "1234567" :element-type 'character))
sds's avatar
sds committed
564 565 566
         (a1 (make-array 5 :displaced-to a0 :displaced-index-offset 1
                         :element-type 'character))
         (a2 (adjust-array a1 5 :displaced-to a0 :element-type 'character)))
pfdietz's avatar
pfdietz committed
567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587
    a2)
  "12345")

(def-adjust-array-test adjust-array.string.17
  (nil :initial-element #\x :element-type 'character)
  (nil)
  #.(make-array nil :initial-element #\x :element-type 'character))

(def-adjust-array-test adjust-array.string.18
  (nil :initial-element #\x :element-type 'character)
  (nil :initial-contents #\y :element-type 'character)
  #.(make-array nil :initial-element #\y :element-type 'character))

(def-adjust-array-test adjust-array.string.19
  (nil :initial-element #\x :element-type 'character)
  (nil :initial-element #\y :element-type 'character)
  #.(make-array nil :initial-element #\x :element-type 'character))


(deftest adjust-array.string.20
  (let* ((a0 (make-array nil :initial-element #\x :element-type 'character))
sds's avatar
sds committed
588 589
         (a1 (make-array nil :displaced-to a0 :element-type 'character))
         (a2 (adjust-array a1 nil :element-type 'character)))
pfdietz's avatar
pfdietz committed
590 591 592
    a2)
   #.(make-array nil :initial-element #\x :element-type 'character))

pfdietz's avatar
pfdietz committed
593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615
(def-adjust-array-test adjust-array.string.adjustable.1
  (5 :initial-contents "abcde" :adjustable t :element-type 'character)
  (4 :element-type 'character)
  "abcd")

(def-adjust-array-test adjust-array.string.adjustable.2
  (5 :initial-contents "abcde" :adjustable t :element-type 'character)
  (8 :initial-element #\x :element-type 'character)
  "abcdexxx")

(def-adjust-array-test adjust-array.string.adjustable.3
  (5 :initial-contents "abcde" :adjustable t :element-type 'character)
  (4 :initial-contents "wxyz" :element-type 'character)
  "wxyz")

(def-adjust-array-test adjust-array.string.adjustable.4
  (5 :initial-contents "abcde" :adjustable t :element-type 'character)
  (8 :initial-contents "87654321" :element-type 'character)
  "87654321")

(def-adjust-array-fp-test adjust-array.string.adjustable.5
  (5 :initial-contents "abcde" :fill-pointer 3 :adjustable t :element-type 'character)
  (4 :element-type 'character :initial-element #\Space)
616
  (assert (eql (aref a2 3) #\d))
pfdietz's avatar
pfdietz committed
617 618 619 620 621
  3 "abc")

(def-adjust-array-fp-test adjust-array.string.adjustable.6
  (5 :initial-contents "abcde" :fill-pointer 3 :adjustable t :element-type 'character)
  (4 :fill-pointer nil :element-type 'character :initial-element #\?)
622
  (assert (eql (aref a2 3) #\d))
pfdietz's avatar
pfdietz committed
623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644
  3 "abc")

(def-adjust-array-fp-test adjust-array.string.adjustable.7
  (5 :initial-contents "abcde" :fill-pointer 3 :adjustable t :element-type 'character)
  (4 :fill-pointer t :element-type 'character :initial-element #\!)
  nil
  4 "abcd")

(def-adjust-array-fp-test adjust-array.string.adjustable.8
  (5 :initial-contents "abcde" :fill-pointer 3 :adjustable t :element-type 'character)
  (4 :fill-pointer 2 :element-type 'character :initial-element #\X)
  (assert (equal (list (aref a2 2) (aref a2 3)) '(#\c #\d)))
  2 "ab")

(def-adjust-array-fp-test adjust-array.string.adjustable.9
  (5 :initial-contents "abcde" :fill-pointer 3 :adjustable t :element-type 'character)
  (8 :fill-pointer 5 :initial-element #\x :element-type 'character)
  (assert (equal (list (aref a2 5) (aref a2 6) (aref a2 7)) '(#\x #\x #\x)))
  5 "abcde")

(deftest adjust-array.string.adjustable.10
  (let* ((a1 (make-array 5 :initial-contents "abcde"
sds's avatar
sds committed
645 646
                         :adjustable t :element-type 'character))
         (a2 (adjust-array a1 4 :displaced-to nil :element-type 'character)))
pfdietz's avatar
pfdietz committed
647 648 649 650 651 652 653
    (assert (eq a1 a2))
    (assert (not (array-displacement a2)))
    a2)
  "abcd")

(deftest adjust-array.string.adjustable.11
  (let* ((a0 (make-array 7 :initial-contents "xabcdey" :element-type 'character))
sds's avatar
sds committed
654 655 656
         (a1 (make-array 5 :displaced-to a0 :displaced-index-offset 1
                         :adjustable t :element-type 'character))
         (a2 (adjust-array a1 4 :element-type 'character)))
pfdietz's avatar
pfdietz committed
657 658 659 660 661 662 663
    (assert (eq a1 a2))
    (assert (not (array-displacement a2)))
    a2)
  "abcd")

(deftest adjust-array.string.adjustable.12
  (let* ((a0 (make-array 7 :initial-contents "xabcdey" :element-type 'character))
sds's avatar
sds committed
664 665 666
         (a1 (make-array 5 :displaced-to a0 :displaced-index-offset 1
                         :adjustable t :element-type 'character))
         (a2 (adjust-array a1 4 :displaced-to a0 :element-type 'character)))
pfdietz's avatar
pfdietz committed
667 668 669 670 671 672
    (assert (eq a1 a2))
    a2)
  "xabc")

(deftest adjust-array.string.adjustable.13
  (let* ((a0 (make-array 7 :initial-contents "xabcdey" :element-type 'character))
sds's avatar
sds committed
673 674 675 676
         (a1 (make-array 5 :displaced-to a0 :displaced-index-offset 1
                         :adjustable t :element-type 'character))
         (a2 (make-array 4 :displaced-to a1 :displaced-index-offset 1
                         :element-type 'character)))
pfdietz's avatar
pfdietz committed
677
    (assert (eq a1 (adjust-array a1 5 :displaced-to a0
sds's avatar
sds committed
678 679
                                 :displaced-index-offset 2
                                 :element-type 'character)))
pfdietz's avatar
pfdietz committed
680 681 682 683 684
    a2)
  "cdey")
)
  for forms2 = (subst element-type 'character forms)
  for forms3 = (mapcar #'(lambda (form)
sds's avatar
sds committed
685 686 687 688 689 690 691 692
                           (destructuring-bind (dt name . body) form
                             `(,dt ,(if (eql element-type 'character) name
                                      (intern (replace (copy-seq (symbol-name name))
                                                       "BASEST"
                                                       :start1 13 :end1 19)
                                              (symbol-package name)))
                                   ,@ body)))
                       forms2)
pfdietz's avatar
pfdietz committed
693 694
  do (eval `(progn ,@forms3)))

pfdietz's avatar
pfdietz committed
695 696 697 698 699 700 701
;; 2-d arrays

(def-adjust-array-test adjust-array.string.21
  ('(4 5) :initial-contents '("12345" "34567" "56789" "78912")
   :element-type 'character)
  ('(2 3))
  #.(make-array '(2 3) :initial-contents '("123" "345")
sds's avatar
sds committed
702
                :element-type 'character))
pfdietz's avatar
pfdietz committed
703 704 705 706 707 708

(def-adjust-array-test adjust-array.string.22
  ('(4 5) :initial-contents  '("12345" "34567" "56789" "78912")
   :element-type 'character)
  ('(6 8) :initial-element #\0 :element-type 'character)
  #.(make-array '(6 8)
sds's avatar
sds committed
709
                :initial-contents '("12345000" "34567000" "56789000"
pfdietz's avatar
pfdietz committed
710
                                    "78912000" "00000000" "00000000")
sds's avatar
sds committed
711
                :element-type 'character))
pfdietz's avatar
pfdietz committed
712

713 714 715 716 717 718 719 720 721 722 723 724 725 726 727
(def-adjust-array-test adjust-array.bit-vector.1
  (5 :element-type 'bit :initial-contents #*01100)
  (4 :element-type 'bit)
  #*0110)

(def-adjust-array-test adjust-array.bit-vector.2
  (5 :element-type 'bit :initial-contents #*01100)
  (8 :element-type 'bit :initial-element 1)
  #*01100111)

(def-adjust-array-test adjust-array.bit-vector.3
  (5 :element-type 'bit :initial-contents #*01100)
  (4 :element-type 'bit :initial-contents #*1011)
  #*1011)

pfdietz's avatar
pfdietz committed
728
(def-adjust-array-test adjust-array.bit-vector.4
729 730 731 732 733 734 735 736 737 738 739 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754
  (5 :element-type 'bit :initial-contents #*01100)
  (8 :element-type 'bit :initial-contents #*11110000)
  #*11110000)

(def-adjust-array-fp-test adjust-array.bit-vector.5
  (5 :element-type 'bit :initial-contents #*01100 :fill-pointer 3)
  (4 :element-type 'bit)
  (assert (eql (aref a2 3) 0))
  3 #*011)

(def-adjust-array-fp-test adjust-array.bit-vector.6
  (5 :element-type 'bit :initial-contents #*01100 :fill-pointer 3)
  (4 :element-type 'bit :fill-pointer nil)
  (assert (eql (aref a2 3) 0))
  3 #*011)

(def-adjust-array-fp-test adjust-array.bit-vector.7
  (5 :element-type 'bit :initial-contents #*01100 :fill-pointer 3)
  (4 :element-type 'bit :fill-pointer t)
  nil
  4 #*0110)

(def-adjust-array-fp-test adjust-array.bit-vector.8
  (5 :element-type 'bit :initial-contents #*01100 :fill-pointer 3)
  (4 :element-type 'bit :fill-pointer 2)
  (progn (assert (eql (aref a2 2) 1))
sds's avatar
sds committed
755
         (assert (eql (aref a2 3) 0)))
756 757 758 759 760 761
  2 #*01)

(def-adjust-array-fp-test adjust-array.bit-vector.9
  (5 :element-type 'bit :initial-contents #*01100 :fill-pointer 3)
  (8 :element-type 'bit :fill-pointer 5 :initial-element 1)
  (assert (equal (list (aref a2 5) (aref a2 6) (aref a2 7))
sds's avatar
sds committed
762
                 '(1 1 1)))
763 764 765 766
  5 #*01100)

(deftest adjust-array.bit-vector.10
  (let* ((a1 (make-array 5 :element-type 'bit :initial-contents #*01100))
sds's avatar
sds committed
767
         (a2 (adjust-array a1 4 :displaced-to nil :element-type 'bit)))
768
    (assert (if (adjustable-array-p a1)
sds's avatar
sds committed
769 770
                (eq a1 a2)
              (equal (array-dimensions a1) '(5))))
771 772 773
    (assert (not (array-displacement a2)))
    a2)
  #*0110)
774

775 776
(deftest adjust-array.bit-vector.11
  (let* ((a0 (make-array 7 :initial-contents #*0011001 :element-type 'bit))
sds's avatar
sds committed
777 778 779
         (a1 (make-array 5 :displaced-to a0 :displaced-index-offset 1
                         :element-type 'bit))
         (a2 (adjust-array a1 4 :element-type 'bit)))
780
    (assert (if (adjustable-array-p a1)
sds's avatar
sds committed
781 782
                (eq a1 a2)
              (equal (array-dimensions a1) '(5))))
783 784 785
    (assert (not (array-displacement a2)))
    a2)
  #*0110)
pfdietz's avatar
pfdietz committed
786

787 788
(deftest adjust-array.bit-vector.12
  (let* ((a0 (make-array 7 :initial-contents #*1010101 :element-type 'bit))
sds's avatar
sds committed
789 790
         (a1 (make-array 5 :initial-contents #*01100 :element-type 'bit))
         (a2 (adjust-array a1 4 :displaced-to a0 :element-type 'bit)))
791
    (assert (if (adjustable-array-p a1)
sds's avatar
sds committed
792 793
                (eq a1 a2)
              (equal (array-dimensions a1) '(5))))
794
    (assert (equal (multiple-value-list (array-displacement a2))
sds's avatar
sds committed
795
                   (list a0 0)))
796 797 798 799 800
    a2)
  #*1010)

(deftest adjust-array.bit-vector.13
  (let* ((a0 (make-array 7 :initial-contents #*1011101 :element-type 'bit))
sds's avatar
sds committed
801 802 803 804
         (a1 (make-array 5 :initial-contents #*01100 :element-type 'bit))
         (a2 (adjust-array a1 4 :displaced-to a0
                           :displaced-index-offset 2
                           :element-type 'bit)))
805
    (assert (if (adjustable-array-p a1)
sds's avatar
sds committed
806 807
                (eq a1 a2)
              (equal (array-dimensions a1) '(5))))
808
    (assert (equal (multiple-value-list (array-displacement a2))
sds's avatar
sds committed
809
                   (list a0 2)))
810 811 812 813 814
    a2)
  #*1110)

(deftest adjust-array.bit-vector.14
  (let* ((a0 (make-array 7 :initial-contents #*1011001 :element-type 'bit))
sds's avatar
sds committed
815 816 817
         (a1 (make-array 5 :displaced-to a0 :displaced-index-offset 1
                         :element-type 'bit))
         (a2 (adjust-array a1 4 :displaced-to a0 :element-type 'bit)))
818
    (assert (if (adjustable-array-p a1)
sds's avatar
sds committed
819 820
                (eq a1 a2)
              (equal (array-dimensions a1) '(5))))
821
    (assert (equal (multiple-value-list (array-displacement a2))
sds's avatar
sds committed
822
                   (list a0 0)))
823 824 825 826 827
    a2)
  #*1011)

(deftest adjust-array.bit-vector.15
  (let* ((a0 (make-array 7 :initial-contents #*1100010 :element-type 'bit))
sds's avatar
sds committed
828 829 830 831 832
         (a1 (make-array 5 :displaced-to a0 :displaced-index-offset 1
                         :element-type 'bit))
         (a2 (make-array 4 :displaced-to a1 :displaced-index-offset 1
                         :element-type 'bit))
         (a3 (adjust-array a2 4 :displaced-to a1 :element-type 'bit)))
833 834 835 836 837
    a3)
  #*1000)

(deftest adjust-array.bit-vector.16
  (let* ((a0 (make-array 7 :initial-contents #*1011011 :element-type 'bit))
sds's avatar
sds committed
838 839 840
         (a1 (make-array 5 :displaced-to a0 :displaced-index-offset 1
                         :element-type 'bit))
         (a2 (adjust-array a1 5 :displaced-to a0 :element-type 'bit)))
841 842 843 844 845 846 847 848 849 850 851 852 853 854 855 856 857 858 859 860
    a2)
  #*10110)

(def-adjust-array-test adjust-array.bit-vector.17
  (nil :initial-element 0 :element-type 'bit)
  (nil)
  #.(make-array nil :initial-element 0 :element-type 'bit))

(def-adjust-array-test adjust-array.bit-vector.18
  (nil :initial-element 0 :element-type 'bit)
  (nil :initial-contents 1 :element-type 'bit)
  #.(make-array nil :initial-element 1 :element-type 'bit))

(def-adjust-array-test adjust-array.bit-vector.19
  (nil :initial-element 1 :element-type 'bit)
  (nil :initial-element 0 :element-type 'bit)
  #.(make-array nil :initial-element 1 :element-type 'bit))

(deftest adjust-array.bit-vector.20
  (let* ((a0 (make-array nil :initial-element 1 :element-type 'bit))
sds's avatar
sds committed
861 862
         (a1 (make-array nil :displaced-to a0 :element-type 'bit))
         (a2 (adjust-array a1 nil :element-type 'bit)))
863 864 865 866 867 868 869 870 871 872
    a2)
   #.(make-array nil :initial-element 1 :element-type 'bit))

;; 2-d arrays

(def-adjust-array-test adjust-array.bit-vector.21
  ('(4 5) :initial-contents '(#*11100 #*00110 #*00001 #*11111)
   :element-type 'bit)
  ('(2 3))
  #.(make-array '(2 3) :initial-contents '(#*111 #*001)
sds's avatar
sds committed
873
                :element-type 'bit))
874 875 876 877 878 879

(def-adjust-array-test adjust-array.bit-vector.22
  ('(4 5) :initial-contents  '(#*11100 #*00110 #*00001 #*11111)
   :element-type 'bit)
  ('(6 8) :initial-element 0 :element-type 'bit)
  #.(make-array '(6 8)
sds's avatar
sds committed
880
                :initial-contents '(#*11100000 #*00110000 #*00001000
881
                                    #*11111000 #*00000000 #*00000000)
sds's avatar
sds committed
882
                :element-type 'bit))
pfdietz's avatar
pfdietz committed
883

pfdietz's avatar
pfdietz committed
884 885 886 887 888 889 890 891 892 893 894 895 896 897 898 899 900 901 902 903 904 905
;;; Adjustable bit vector tests

(def-adjust-array-test adjust-array.bit-vector.adjustable.1
  (5 :initial-contents '(1 0 1 1 0) :adjustable t :element-type 'bit)
  (4 :element-type 'bit)
  #*1011)

(def-adjust-array-test adjust-array.bit-vector.adjustable.2
  (5 :initial-contents '(1 0 1 0 1) :adjustable t :element-type 'bit)
  (8 :initial-element '1 :element-type 'bit)
  #*10101111)

(def-adjust-array-test adjust-array.bit-vector.adjustable.3
  (5 :initial-contents '(0 1 0 1 0) :adjustable t :element-type 'bit)
  (4 :initial-contents '(1 1 1 0) :element-type 'bit)
  #*1110)

(def-adjust-array-test adjust-array.bit-vector.adjustable.4
  (5 :initial-contents '(1 0 0 1 0) :adjustable t :element-type 'bit)
  (8 :initial-contents '(0 1 0 1 1 0 1 0) :element-type 'bit)
  #*01011010)

pfdietz's avatar
pfdietz committed
906
(def-adjust-array-fp-test adjust-array.bit-vector.adjustable.5
pfdietz's avatar
pfdietz committed
907 908
  (5 :initial-contents '(1 1 1 0 0) :fill-pointer 3 :adjustable t :element-type 'bit)
  (4 :element-type 'bit :initial-element 0)
909
  (assert (eql (aref a2 3) 0))
pfdietz's avatar
pfdietz committed
910 911 912 913 914
  3 #*111)

(def-adjust-array-fp-test adjust-array.bit-vector.adjustable.6
  (5 :initial-contents '(0 0 0 1 1) :fill-pointer 3 :adjustable t :element-type 'bit)
  (4 :fill-pointer nil :element-type 'bit :initial-element 1)
915
  (assert (eql (aref a2 3) 1))
pfdietz's avatar
pfdietz committed
916 917 918 919 920 921 922 923 924 925 926 927 928 929 930 931 932 933 934 935 936 937
  3 #*000)

(def-adjust-array-fp-test adjust-array.bit-vector.adjustable.7
  (5 :initial-contents '(1 1 0 1 1) :fill-pointer 3 :adjustable t :element-type 'bit)
  (4 :fill-pointer t :element-type 'bit :initial-element 1)
  nil
  4 #*1101)

(def-adjust-array-fp-test adjust-array.bit-vector.adjustable.8
  (5 :initial-contents '(0 1 1 1 0) :fill-pointer 3 :adjustable t :element-type 'bit)
  (4 :fill-pointer 2 :element-type 'bit :initial-element 0)
  (assert (equal (list (aref a2 2) (aref a2 3)) '(1 1)))
  2 #*01)

(def-adjust-array-fp-test adjust-array.bit-vector.adjustable.9
  (5 :initial-contents '(1 0 0 0 1) :fill-pointer 3 :adjustable t :element-type 'bit)
  (8 :fill-pointer 5 :initial-element 1 :element-type 'bit)
  (assert (equal (list (aref a2 5) (aref a2 6) (aref a2 7)) '(1 1 1)))
  5 #*10001)

(deftest adjust-array.bit-vector.adjustable.10
  (let* ((a1 (make-array 5 :initial-contents '(0 1 1 0 1)
sds's avatar
sds committed
938 939
                         :adjustable t :element-type 'bit))
         (a2 (adjust-array a1 4 :displaced-to nil :element-type 'bit)))
pfdietz's avatar
pfdietz committed
940 941 942 943 944 945 946
    (assert (eq a1 a2))
    (assert (not (array-displacement a2)))
    a2)
  #*0110)

(deftest adjust-array.bit-vector.adjustable.11
  (let* ((a0 (make-array 7 :initial-contents '(0 1 0 1 1 1 0)
sds's avatar
sds committed
947 948 949 950
                         :element-type 'bit))
         (a1 (make-array 5 :displaced-to a0 :displaced-index-offset 1
                         :adjustable t :element-type 'bit))
         (a2 (adjust-array a1 4 :element-type 'bit)))
pfdietz's avatar
pfdietz committed
951 952 953 954 955 956 957
    (assert (eq a1 a2))
    (assert (not (array-displacement a2)))
    a2)
  #*1011)

(deftest adjust-array.bit-vector.adjustable.12
  (let* ((a0 (make-array 7 :initial-contents '(0 0 1 1 1 1 1)
sds's avatar
sds committed
958 959 960 961
                         :element-type 'bit))
         (a1 (make-array 5 :displaced-to a0 :displaced-index-offset 1
                         :adjustable t :element-type 'bit))
         (a2 (adjust-array a1 4 :displaced-to a0 :element-type 'bit)))
pfdietz's avatar
pfdietz committed
962 963 964 965 966 967
    (assert (eq a1 a2))
    a2)
  #*0011)

(deftest adjust-array.bit-vector.adjustable.13
  (let* ((a0 (make-array 7 :initial-contents '(1 0 0 0 0 0 1) :element-type 'bit))
sds's avatar
sds committed
968 969 970 971
         (a1 (make-array 5 :displaced-to a0 :displaced-index-offset 1
                         :adjustable t :element-type 'bit))
         (a2 (make-array 4 :displaced-to a1 :displaced-index-offset 1
                         :element-type 'bit)))
pfdietz's avatar
pfdietz committed
972
    (assert (eq a1 (adjust-array a1 5 :displaced-to a0
sds's avatar
sds committed
973 974
                                 :displaced-index-offset 2
                                 :element-type 'bit)))
pfdietz's avatar
pfdietz committed
975 976 977
    a2)
  #*0001)

978
;;; FIXME. specialized integer array tests
pfdietz's avatar
pfdietz committed
979

980
;;; FIXNME float array tests
981 982 983 984 985 986 987 988 989

;;; Error cases

(deftest adjust-array.error.1
  (signals-error (adjust-array) program-error)
  t)

(deftest adjust-array.error.2
  (signals-error (adjust-array (make-array 10 :initial-element nil))
sds's avatar
sds committed
990
                 program-error)
991 992 993 994
  t)

(deftest adjust-array.error.3
  (signals-error (adjust-array (make-array 10 :initial-element nil)
sds's avatar
sds committed
995 996
                               8 :bad t)
                 program-error)
997 998 999 1000
  t)

(deftest adjust-array.error.4
  (signals-error (adjust-array (make-array 10 :initial-element nil)
sds's avatar
sds committed
1001 1002
                               8 :initial-element)
                 program-error)
1003 1004 1005 1006
  t)

(deftest adjust-array.error.5
  (signals-error (adjust-array (make-array 10 :initial-element nil)
sds's avatar
sds committed
1007 1008 1009 1010 1011
                               8
                               :allow-other-keys nil
                               :allow-other-keys t
                               :bad t)
                 program-error)
1012 1013 1014 1015 1016 1017 1018 1019
  t)

(deftest adjust-array.error.6
  (signals-error
   (let ((a (make-array 5 :initial-element 'x)))
     (adjust-array a :fill-pointer 4))
   error)
  t)