5 |
|
|
6 |
(in-package :cl-test) |
(in-package :cl-test) |
7 |
|
|
8 |
(defun make-array-check-upgrading (type) |
;;; See array-aux.lsp for auxiliary functions |
|
(subtypep* type (array-element-type (make-array 0 :element-type type)))) |
|
|
|
|
|
(defun make-array-with-checks (dimensions |
|
|
&rest options |
|
|
&key |
|
|
(element-type t element-type-p) |
|
|
(initial-contents nil intial-contents-p) |
|
|
(initial-element nil initial-element-p) |
|
|
(adjustable nil) |
|
|
(fill-pointer nil) |
|
|
(displaced-to nil) |
|
|
(displaced-index-offset 0 dio-p) |
|
|
&aux |
|
|
(dimensions-list (if (listp dimensions) |
|
|
dimensions |
|
|
(list dimensions)))) |
|
|
"Call MAKE-ARRAY and do sanity tests on the output." |
|
|
(let ((a (apply #'make-array dimensions options))) |
|
|
(cond |
|
|
((not (typep a 'array)) :fail-not-array) |
|
|
((and (eq t element-type) |
|
|
(not adjustable) |
|
|
(not fill-pointer) |
|
|
(not displaced-to) |
|
|
(not (typep a 'simple-array))) |
|
|
:fail-not-simple-array) |
|
|
((and (eq (length dimensions-list) 1) |
|
|
(cond |
|
|
((not (typep a 'vector)) |
|
|
:fail-not-vector) |
|
|
((and (subtypep 'bit element-type) |
|
|
(subtypep element-type 'bit) |
|
|
(or (not (bit-vector-p a)) |
|
|
(not (typep a 'bit-vector)))) |
|
|
:fail-not-bit-vector) |
|
|
((and (not adjustable) |
|
|
(not fill-pointer) |
|
|
(not displaced-to) |
|
|
(cond |
|
|
((and (eq t element-type) |
|
|
(or (not (simple-vector-p a)) |
|
|
(not (typep a 'simple-vector)))) |
|
|
:fail-not-simple-vector) |
|
|
((and (subtypep 'bit element-type) |
|
|
(subtypep element-type 'bit) |
|
|
(or (not (simple-bit-vector-p a)) |
|
|
(not (typep a 'simple-bit-vector)))) |
|
|
:fail-not-simple-bit-vector) ))) ))) |
|
|
((not (equal (array-dimensions a) dimensions-list)) |
|
|
:fail-array-dimensions) |
|
|
((not (equal (array-rank a) (length dimensions-list))) |
|
|
:fail-array-rank) |
|
|
((multiple-value-bind (sub good) |
|
|
(subtypep element-type (array-element-type a)) |
|
|
(and good |
|
|
(not sub) |
|
|
:failed-array-element-type))) |
|
|
((and adjustable |
|
|
(not (adjustable-array-p a)) |
|
|
:fail-adjustable)) |
|
|
((and fill-pointer |
|
|
(not (array-has-fill-pointer-p a)) |
|
|
:fail-has-fill-pointer)) |
|
|
((and (integerp fill-pointer) |
|
|
(not (eql fill-pointer (fill-pointer a))) |
|
|
:fail-fill-pointer-1)) |
|
|
((and (eq fill-pointer t) |
|
|
(not (eql (first dimensions-list) (fill-pointer a))) |
|
|
:fail-fill-pointer-2)) |
|
|
(t a)))) |
|
9 |
|
|
10 |
(deftest make-array.1 |
(deftest make-array.1 |
11 |
(let ((a (make-array-with-checks 10))) |
(let ((a (make-array-with-checks 10))) |
213 |
:nonsense-argument t) |
:nonsense-argument t) |
214 |
#(x x x x)) |
#(x x x x)) |
215 |
|
|
216 |
|
(deftest make-array.28 |
217 |
|
(let ((*package* (find-package :cl-test))) |
218 |
|
(let ((len (1- (min 10000 array-rank-limit)))) |
219 |
|
(equalpt (make-array (make-list len :initial-element 1) :initial-element 'x) |
220 |
|
(read-from-string (concatenate |
221 |
|
'string |
222 |
|
(format nil "#~dA" len) |
223 |
|
(make-string len :initial-element #\() |
224 |
|
"x" |
225 |
|
(make-string len :initial-element #\))))))) |
226 |
|
t) |
227 |
|
|
228 |
;;; Adjustable arrays |
;;; Adjustable arrays |
229 |
|
|
502 |
:adjustable t)) |
:adjustable t)) |
503 |
#(f g h i j k l m)) |
#(f g h i j k l m)) |
504 |
|
|
505 |
|
(deftest make-array.displaced.27 |
506 |
|
(let ((a (make-array '(10) |
507 |
|
:initial-contents '(1 2 3 4 5 6 7 8 9 10) |
508 |
|
:fill-pointer t))) |
509 |
|
(make-array-with-checks '(2 4) :displaced-to a)) |
510 |
|
#2a((1 2 3 4) (5 6 7 8))) |
511 |
|
|
512 |
|
(deftest make-array.displaced.28 |
513 |
|
(let ((a (make-array '(10) |
514 |
|
:initial-contents '(1 2 3 4 5 6 7 8 9 10) |
515 |
|
:fill-pointer 4))) |
516 |
|
(make-array-with-checks '(2 4) :displaced-to a)) |
517 |
|
#2a((1 2 3 4) (5 6 7 8))) |
518 |
|
|
519 |
|
(deftest make-array.displaced.29 |
520 |
|
(let ((a (make-array '(10) :initial-element 0))) |
521 |
|
(prog1 |
522 |
|
(make-array-with-checks '(2 4) :displaced-to a) |
523 |
|
(loop for i below 10 do (setf (aref a i) (1+ i))))) |
524 |
|
#2a((1 2 3 4) (5 6 7 8))) |
525 |
|
|
526 |
|
(deftest make-array.displaced.30 |
527 |
|
(let* ((a1 (make-array '(10) :initial-element 0)) |
528 |
|
(a2 (make-array '(10) :displaced-to a1))) |
529 |
|
(prog1 |
530 |
|
(make-array-with-checks '(2 4) :displaced-to a2) |
531 |
|
(loop for i below 10 do (setf (aref a2 i) (1+ i))))) |
532 |
|
#2a((1 2 3 4) (5 6 7 8))) |
533 |
|
|
534 |
|
(deftest make-array.displaced.31 |
535 |
|
(let* ((a1 (make-array '(10) :initial-element 0)) |
536 |
|
(a2 (make-array '(10) :displaced-to a1))) |
537 |
|
(prog1 |
538 |
|
(make-array-with-checks '(2 4) :displaced-to a2) |
539 |
|
(loop for i below 10 do (setf (aref a1 i) (1+ i))))) |
540 |
|
#2a((1 2 3 4) (5 6 7 8))) |
541 |
|
|
542 |
|
|
543 |
;;; Keywords tests |
;;; Keywords tests |
544 |
|
|
545 |
(deftest make-array.allow-other-keys.1 |
(deftest make-array.allow-other-keys.1 |