diff --git a/ansi-tests/adjustable-array-p.lsp b/ansi-tests/adjustable-array-p.lsp new file mode 100644 index 0000000000000000000000000000000000000000..e5873a3c764755908e0735083ed2b838a1dc5f04 --- /dev/null +++ b/ansi-tests/adjustable-array-p.lsp @@ -0,0 +1,47 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Mon Jan 20 21:25:22 2003 +;;;; Contains: Tests for ADJUSTABLE-ARRAY-P + +(in-package :cl-test) + +(deftest adjustable-array-p.1 + (notnot (adjustable-array-p (make-array '(5) :adjustable t))) + t) + +(deftest adjustable-array-p.2 + (notnot (adjustable-array-p (make-array nil :adjustable t))) + t) + +(deftest adjustable-array-p.3 + (notnot (adjustable-array-p (make-array '(2 3) :adjustable t))) + t) + +(deftest adjustable-array-p.4 + (notnot (adjustable-array-p (make-array '(2 2 2) :adjustable t))) + t) + +(deftest adjustable-array-p.5 + (notnot (adjustable-array-p (make-array '(2 2 2 2) :adjustable t))) + t) + +;;; Error tests + +(deftest adjustable-array-p.error.1 + (classify-error (adjustable-array-p)) + program-error) + +(deftest adjustable-array-p.error.2 + (classify-error (adjustable-array-p "aaa" nil)) + program-error) + +(deftest adjustable-array-p.error.3 + (classify-error (adjustable-array-p 10)) + type-error) + +(deftest adjustable-array-p.error.4 + (loop for e in *mini-universe* + unless (or (typep e 'array) + (eq 'type-error (classify-error** `(adjustable-array-p ',e)))) + collect e) + nil) diff --git a/ansi-tests/ansi-aux.lsp b/ansi-tests/ansi-aux.lsp index f3df359b488406b2d8f7ef12b1ad54c797492a51..ae47be70e98a9fa7d16ed6f58306cc80da50fc52 100644 --- a/ansi-tests/ansi-aux.lsp +++ b/ansi-tests/ansi-aux.lsp @@ -144,6 +144,11 @@ the condition to go uncaught if it cannot be classified." (package-error () 'package-error) (type-error () 'type-error) (control-error () 'control-error) + (stream-error () 'stream-error) + (reader-error () 'reader-error) + (file-error () 'file-error) + (control-error () 'control-error) + (cell-error () 'cell-error) ))) (defun classify-error** (form) diff --git a/ansi-tests/array-aux.lsp b/ansi-tests/array-aux.lsp new file mode 100644 index 0000000000000000000000000000000000000000..8db9839ae99b49655a9c09fa6b941f45e7284bf8 --- /dev/null +++ b/ansi-tests/array-aux.lsp @@ -0,0 +1,126 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Tue Jan 21 05:11:31 2003 +;;;; Contains: Auxiliary functions for array tests + +(in-package :cl-test) + +(defun make-array-check-upgrading (type) + (subtypep* type (array-element-type (make-array 0 :element-type type)))) + +(defun subtypep-or-unknown (subtype supertype) + (multiple-value-bind (is-subtype is-known) + (subtypep subtype supertype) + (or (not is-known) (notnot is-subtype)))) + +(defun make-array-with-checks (dimensions + &rest options + &key + (element-type t element-type-p) + (initial-contents nil initial-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." + (declare (ignore element-type-p initial-contents initial-contents-p + initial-element initial-element-p)) + (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) + + ;; If the array is a vector, check that... + ((and (eq (length dimensions-list) 1) + (cond + ;; It's in type vector + ((not (typep a 'vector)) + :fail-not-vector) + ;; If the element type is a subtype of BIT, then it's a + ;; bit 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) + ;; If not adjustable, fill pointered, or displaced, + ;; then it's a simple vector or simple bit vector + ;; (if the element-type is appropriate) + ((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) ))) ))) + + ;; The dimensions of the array must be initialized properly + ((not (equal (array-dimensions a) dimensions-list)) + :fail-array-dimensions) + + ;; The rank of the array must equal the number of dimensions + ((not (equal (array-rank a) (length dimensions-list))) + :fail-array-rank) + + ;; Arrays other than vectors cannot have fill pointers + ((and (not (equal (array-rank a) 1)) + (array-has-fill-pointer-p a)) + :fail-non-vector-fill-pointer) + + ;; The actual element type must be a supertype of the element-type + ;; argument + ((not (subtypep-or-unknown element-type (array-element-type a))) + :failed-array-element-type) + + ;; If :adjustable is given, the array must be adjustable. + ((and adjustable + (not (adjustable-array-p a)) + :fail-adjustable)) + + ;; If :fill-pointer is given, the array must have a fill pointer + ((and fill-pointer + (not (array-has-fill-pointer-p a)) + :fail-has-fill-pointer)) + + ;; If the fill pointer is given as an integer, it must be the value + ;; of the fill pointer of the new array + ((and (integerp fill-pointer) + (not (eql fill-pointer (fill-pointer a))) + :fail-fill-pointer-1)) + + ;; If the fill-pointer argument is t, the fill pointer must be + ;; set to the vector size. + ((and (eq fill-pointer t) + (not (eql (first dimensions-list) (fill-pointer a))) + :fail-fill-pointer-2)) + + ;; If displaced-to another array, check that this is proper + ((and + displaced-to + (multiple-value-bind (actual-dt actual-dio) + (array-displacement a) + (cond + ((not (eq actual-dt displaced-to)) + :fail-displacement-1) + ((not (eql actual-dio displaced-index-offset)) + :fail-displaced-index-offset))))) + + ;; No problems -- return the array + (t a)))) \ No newline at end of file diff --git a/ansi-tests/array-dimension.lsp b/ansi-tests/array-dimension.lsp new file mode 100644 index 0000000000000000000000000000000000000000..8831372a00e729ed3e03b535917b468b655fbe9c --- /dev/null +++ b/ansi-tests/array-dimension.lsp @@ -0,0 +1,55 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Tue Jan 21 06:55:14 2003 +;;;; Contains: Tests of ARRAY-DIMENSION + +(in-package :cl-test) + +;;; array-dimension is also tested by the tests in make-array.lsp + +(deftest array-dimension.1 + (array-dimension #(0 1 2 3) 0) + 4) + +(deftest array-dimension.2 + (array-dimension "abcdef" 0) + 6) + +(deftest array-dimension.3 + (array-dimension #2a((1 2 3 4)(5 6 7 8)) 0) + 2) + +(deftest array-dimension.4 + (array-dimension #2a((1 2 3 4)(5 6 7 8)) 1) + 4) + +(deftest array-dimension.5 + (let ((a (make-array '(10) :fill-pointer 5))) + (array-dimension a 0)) + 10) + +(deftest array-dimension.6 + (let ((a (make-array '(10) :adjustable t))) + (values + (array-dimension a 0) + (progn + (adjust-array a '(20)) + (array-dimension a 0)))) + 10 20) + +;;; Error tests + +(deftest array-dimension.error.1 + (classify-error (array-dimension)) + program-error) + +(deftest array-dimension.error.2 + (classify-error (array-dimension #(a b c))) + program-error) + +(deftest array-dimension.error.3 + (classify-error (array-dimension #(a b c) 0 nil)) + program-error) + + + diff --git a/ansi-tests/array-dimensions.lsp b/ansi-tests/array-dimensions.lsp new file mode 100644 index 0000000000000000000000000000000000000000..9ae1d8746bd5c023af9d1dd97dd4846e87c0a585 --- /dev/null +++ b/ansi-tests/array-dimensions.lsp @@ -0,0 +1,58 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Tue Jan 21 06:59:37 2003 +;;;; Contains: Tests of ARRAY-DIMENSIONS + +(in-package :cl-test) + +;;; The tests in make-array.lsp also test this function + +(deftest array-dimensions.1 + (array-dimensions #0aX) + nil) + +(deftest array-dimensions.2 + (array-dimensions #(a b c d)) + (4)) + +(deftest array-dimensions.3 + (array-dimensions #*0011011011) + (10)) + +(deftest array-dimensions.4 + (array-dimensions "abcdef") + (6)) + +(deftest array-dimensions.5 + (array-dimensions #2a((1 2 3)(4 5 6)(7 8 9)(10 11 12))) + (4 3)) + +(deftest array-dimensions.6 + (let ((a (make-array '(2 3 4) :adjustable t))) + (values (array-dimension a 0) + (array-dimension a 1) + (array-dimension a 2))) + 2 3 4) + +(deftest array-dimensions.7 + (let ((a (make-array '(10) :fill-pointer 5))) + (array-dimension a 0)) + 10) + +;;; Error tests + +(deftest array-dimensions.error.1 + (classify-error (array-dimensions)) + program-error) + +(deftest array-dimensions.error.2 + (classify-error (array-dimensions #(a b c) nil)) + program-error) + +(deftest array-dimension.error.3 + (loop for e in *mini-universe* + unless (or (typep e 'array) + (eq 'type-error + (classify-error** `(array-dimensions ',e)))) + collect e) + nil) diff --git a/ansi-tests/array-displacement.lsp b/ansi-tests/array-displacement.lsp new file mode 100644 index 0000000000000000000000000000000000000000..fb08b331908650c410197fe555cabf2edc0bc403 --- /dev/null +++ b/ansi-tests/array-displacement.lsp @@ -0,0 +1,113 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Tue Jan 21 06:20:51 2003 +;;;; Contains: Tests for ARRAY-DISPLACEMENT + +(in-package :cl-test) + +;;; The tests in make-array.lsp also test array-displacement + +;;; The standard is contradictory about whether arrays created with +;;; :displaced-to NIL should return NIL as their primary value or +;;; not. I will assume (as per Kent Pitman's comment on comp.lang.lisp) +;;; that an implementation is free to implement all arrays as actually +;;; displaced. Therefore, I've omitted all the tests of not-expressly +;;; displaced arrays. + +;;; Behavior on expressly displaced arrays + +(deftest array-displacement.7 + (let* ((a (make-array '(10))) + (b (make-array '(10) :displaced-to a))) + (multiple-value-bind (dt disp) + (array-displacement b) + (and (eqt a dt) + (eqlt disp 0)))) + t) + +(deftest array-displacement.8 + (let* ((a (make-array '(10))) + (b (make-array '(5) :displaced-to a :displaced-index-offset 2))) + (multiple-value-bind (dt disp) + (array-displacement b) + (and (eqt a dt) + (eqlt disp 2)))) + t) + +(deftest array-displacement.9 + (let* ((a (make-array '(10) :element-type 'base-char)) + (b (make-array '(5) :displaced-to a :displaced-index-offset 2 + :element-type 'base-char))) + (multiple-value-bind (dt disp) + (array-displacement b) + (and (eqt a dt) + (eqlt disp 2)))) + t) + +(deftest array-displacement.10 + (let* ((a (make-array '(10) :element-type 'base-char)) + (b (make-array '(5) :displaced-to a + :element-type 'base-char))) + (multiple-value-bind (dt disp) + (array-displacement b) + (and (eqt a dt) + (eqlt disp 0)))) + t) + +(deftest array-displacement.11 + (let* ((a (make-array '(10) :element-type 'bit)) + (b (make-array '(5) :displaced-to a :displaced-index-offset 2 + :element-type 'bit))) + (multiple-value-bind (dt disp) + (array-displacement b) + (and (eqt a dt) + (eqlt disp 2)))) + t) + +(deftest array-displacement.12 + (let* ((a (make-array '(10) :element-type 'bit)) + (b (make-array '(5) :displaced-to a + :element-type 'bit))) + (multiple-value-bind (dt disp) + (array-displacement b) + (and (eqt a dt) + (eqlt disp 0)))) + t) + +(deftest array-displacement.13 + (let* ((a (make-array '(10) :element-type '(integer 0 255))) + (b (make-array '(5) :displaced-to a :displaced-index-offset 2 + :element-type '(integer 0 255)))) + (multiple-value-bind (dt disp) + (array-displacement b) + (and (eqt a dt) + (eqlt disp 2)))) + t) + +(deftest array-displacement.14 + (let* ((a (make-array '(10) :element-type '(integer 0 255))) + (b (make-array '(5) :displaced-to a + :element-type '(integer 0 255)))) + (multiple-value-bind (dt disp) + (array-displacement b) + (and (eqt a dt) + (eqlt disp 0)))) + t) + +;;; Error tests + +(deftest array-displacement.error.1 + (classify-error (array-displacement)) + program-error) + +(deftest array-displacement.error.2 + (classify-error (array-displacement #(a b c) nil)) + program-error) + +(deftest array-displacement.error.3 + (loop for e in *mini-universe* + unless (or (typep e 'array) + (eq 'type-error + (classify-error** `(array-displacement ',e)))) + collect e) + nil) diff --git a/ansi-tests/array-in-bounds-p.lsp b/ansi-tests/array-in-bounds-p.lsp new file mode 100644 index 0000000000000000000000000000000000000000..51e9a156052752d0306a8ba2d688a73124049d76 --- /dev/null +++ b/ansi-tests/array-in-bounds-p.lsp @@ -0,0 +1,140 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Tue Jan 21 19:57:29 2003 +;;;; Contains: Tests for ARRAY-IN-BOUNDS-P + +(in-package :cl-test) + +(deftest array-in-bounds-p.1 + (array-in-bounds-p #() 0) + nil) + +(deftest array-in-bounds-p.2 + (array-in-bounds-p #() -1) + nil) + +(deftest array-in-bounds-p.3 + (let ((a #(a b c d))) + (loop for i from 0 to 4 collect (notnot (array-in-bounds-p a i)))) + (t t t t nil)) + +(deftest array-in-bounds-p.4 + (notnot (array-in-bounds-p #0aNIL)) + t) + +(deftest array-in-bounds-p.5 + (array-in-bounds-p "" 0) + nil) + +(deftest array-in-bounds-p.6 + (array-in-bounds-p "" -1) + nil) + +(deftest array-in-bounds-p.7 + (let ((a "abcd")) + (loop for i from 0 to 4 collect (notnot (array-in-bounds-p a i)))) + (t t t t nil)) + +(deftest array-in-bounds-p.8 + (array-in-bounds-p #* 0) + nil) + +(deftest array-in-bounds-p.9 + (array-in-bounds-p #* -1) + nil) + +(deftest array-in-bounds-p.10 + (let ((a #*0110)) + (loop for i from 0 to 4 collect (notnot (array-in-bounds-p a i)))) + (t t t t nil)) + +;; Fill pointer tests + +(deftest array-in-bounds-p.11 + (let ((a (make-array '(10) :fill-pointer 5))) + (loop for i from -1 to 10 collect (notnot (array-in-bounds-p a i)))) + (nil t t t t t t t t t t nil)) + +(deftest array-in-bounds-p.12 + (let ((a (make-array '(10) :fill-pointer 5 :element-type 'bit :initial-element 0))) + (loop for i from -1 to 10 collect (notnot (array-in-bounds-p a i)))) + (nil t t t t t t t t t t nil)) + +(deftest array-in-bounds-p.13 + (let ((a (make-array '(10) :fill-pointer 5 :element-type 'base-char :initial-element #\x))) + (loop for i from -1 to 10 collect (notnot (array-in-bounds-p a i)))) + (nil t t t t t t t t t t nil)) + +(deftest array-in-bounds-p.14 + (let ((a (make-array '(10) :fill-pointer 5 :element-type 'character :initial-element #\x))) + (loop for i from -1 to 10 collect (notnot (array-in-bounds-p a i)))) + (nil t t t t t t t t t t nil)) + +;;; Displaced arrays + +(deftest array-in-bounds-p.15 + (let* ((a1 (make-array '(20))) + (a2 (make-array '(10) :displaced-to a1))) + (loop for i from -1 to 10 collect (notnot (array-in-bounds-p a2 i)))) + (nil t t t t t t t t t t nil)) + +(deftest array-in-bounds-p.16 + (let* ((a1 (make-array '(20) :element-type 'bit :initial-element 0)) + (a2 (make-array '(10) :displaced-to a1 :element-type 'bit))) + (loop for i from -1 to 10 collect (notnot (array-in-bounds-p a2 i)))) + (nil t t t t t t t t t t nil)) + +(deftest array-in-bounds-p.17 + (let* ((a1 (make-array '(20) :element-type 'character :initial-element #\x)) + (a2 (make-array '(10) :displaced-to a1 :element-type 'character))) + (loop for i from -1 to 10 collect (notnot (array-in-bounds-p a2 i)))) + (nil t t t t t t t t t t nil)) + +;;; Multidimensional arrays + +(deftest array-in-bounds-p.18 + (let ((a (make-array '(3 4)))) + (loop for i from -1 to 3 collect + (loop for j from -1 to 4 collect + (notnot (array-in-bounds-p a i j))))) + ((nil nil nil nil nil nil) + (nil t t t t nil) + (nil t t t t nil) + (nil t t t t nil) + (nil nil nil nil nil nil))) + +(deftest array-in-bounds-p.19 + (let ((a (make-array '(1 3 4) :adjustable t))) + (loop for i from -1 to 3 collect + (loop for j from -1 to 4 collect + (notnot (array-in-bounds-p a 0 i j))))) + ((nil nil nil nil nil nil) + (nil t t t t nil) + (nil t t t t nil) + (nil t t t t nil) + (nil nil nil nil nil nil))) + +;;; Very large indices + +(deftest array-in-bounds-p.20 + (array-in-bounds-p #(a b c) (1+ most-positive-fixnum)) + nil) + +(deftest array-in-bounds-p.21 + (array-in-bounds-p #(a b c) (1- most-negative-fixnum)) + nil) + +(deftest array-in-bounds-p.22 + (array-in-bounds-p #(a b c) 1000000000000000000) + nil) + +(deftest array-in-bounds-p.23 + (array-in-bounds-p #(a b c) -1000000000000000000) + nil) + +;;; Error tests + +(deftest array-in-bounds-p.error.1 + (classify-error (array-in-bounds-p)) + program-error) + diff --git a/ansi-tests/array-rank.lsp b/ansi-tests/array-rank.lsp new file mode 100644 index 0000000000000000000000000000000000000000..78af7b952d4271f2be6ff2c016950daded133406 --- /dev/null +++ b/ansi-tests/array-rank.lsp @@ -0,0 +1,37 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Tue Jan 21 20:32:57 2003 +;;;; Contains: Tests for ARRAY-RANK + +(in-package :cl-test) + +;;; Most tests for ARRAY-RANK are in make-array.lsp + +(deftest array-rank.1 + (array-rank #0aNIL) + 0) + +(deftest array-rank.2 + (loop for e in *universe* + when (and (typep e 'vector) + (not (eql (array-rank e) 1))) + collect e) + nil) + +;;; Error tests + +(deftest array-rank.error.1 + (classify-error (array-rank)) + program-error) + +(deftest array-rank.error.2 + (classify-error (array-rank #(a b c) nil)) + program-error) + +(deftest array-rank.error.3 + (loop for e in *mini-universe* + when (and (not (typep e 'array)) + (not (eq (classify-error** `(array-rank ',e)) + 'type-error))) + collect e) + nil) diff --git a/ansi-tests/gclload2.lsp b/ansi-tests/gclload2.lsp index 8291c42b19acd8bdc1813a732ee28181d92b07ca..811ac99b23b6e763d33a5db9a1a124f2e89d3bb5 100644 --- a/ansi-tests/gclload2.lsp +++ b/ansi-tests/gclload2.lsp @@ -133,7 +133,15 @@ (load "cons-test-25.lsp") ;;; Tests on arrays +(compile-and-load "array-aux.lsp") (load "make-array.lsp") +(load "adjustable-array-p.lsp") +(load "array-displacement.lsp") +(load "adjustable-array-p.lsp") +(load "array-dimension.lsp") +(load "array-dimensions.lsp") +(load "array-in-bounds-p.lsp") +(load "array-rank.lsp") ;;; Tests of packages diff --git a/ansi-tests/make-array.lsp b/ansi-tests/make-array.lsp index ef130bc1eddfcaa119eeb2aefe103d77b0aa0633..4c238063fd331acc17fdec0c4b0c95074dbb7ffb 100644 --- a/ansi-tests/make-array.lsp +++ b/ansi-tests/make-array.lsp @@ -5,77 +5,7 @@ (in-package :cl-test) -(defun make-array-check-upgrading (type) - (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)))) +;;; See array-aux.lsp for auxiliary functions (deftest make-array.1 (let ((a (make-array-with-checks 10))) @@ -283,6 +213,17 @@ :nonsense-argument t) #(x x x x)) +(deftest make-array.28 + (let ((*package* (find-package :cl-test))) + (let ((len (1- (min 10000 array-rank-limit)))) + (equalpt (make-array (make-list len :initial-element 1) :initial-element 'x) + (read-from-string (concatenate + 'string + (format nil "#~dA" len) + (make-string len :initial-element #\() + "x" + (make-string len :initial-element #\))))))) + t) ;;; Adjustable arrays @@ -561,6 +502,44 @@ :adjustable t)) #(f g h i j k l m)) +(deftest make-array.displaced.27 + (let ((a (make-array '(10) + :initial-contents '(1 2 3 4 5 6 7 8 9 10) + :fill-pointer t))) + (make-array-with-checks '(2 4) :displaced-to a)) + #2a((1 2 3 4) (5 6 7 8))) + +(deftest make-array.displaced.28 + (let ((a (make-array '(10) + :initial-contents '(1 2 3 4 5 6 7 8 9 10) + :fill-pointer 4))) + (make-array-with-checks '(2 4) :displaced-to a)) + #2a((1 2 3 4) (5 6 7 8))) + +(deftest make-array.displaced.29 + (let ((a (make-array '(10) :initial-element 0))) + (prog1 + (make-array-with-checks '(2 4) :displaced-to a) + (loop for i below 10 do (setf (aref a i) (1+ i))))) + #2a((1 2 3 4) (5 6 7 8))) + +(deftest make-array.displaced.30 + (let* ((a1 (make-array '(10) :initial-element 0)) + (a2 (make-array '(10) :displaced-to a1))) + (prog1 + (make-array-with-checks '(2 4) :displaced-to a2) + (loop for i below 10 do (setf (aref a2 i) (1+ i))))) + #2a((1 2 3 4) (5 6 7 8))) + +(deftest make-array.displaced.31 + (let* ((a1 (make-array '(10) :initial-element 0)) + (a2 (make-array '(10) :displaced-to a1))) + (prog1 + (make-array-with-checks '(2 4) :displaced-to a2) + (loop for i below 10 do (setf (aref a1 i) (1+ i))))) + #2a((1 2 3 4) (5 6 7 8))) + + ;;; Keywords tests (deftest make-array.allow-other-keys.1 diff --git a/ansi-tests/universe.lsp b/ansi-tests/universe.lsp index 93eac3503941b4b37e7803d154b3eda531ca9a1f..f80e5417b13c761e72072350416031fe90815180 100644 --- a/ansi-tests/universe.lsp +++ b/ansi-tests/universe.lsp @@ -314,3 +314,23 @@ *random-states* nil))) +(defvar *mini-universe* + (remove-duplicates + (mapcar #'first + (list *symbols* + *numbers* + *characters* + (mapcar #'copy-seq *strings*) + *conses* + *condition-objects* + *package-objects* + *arrays* + *hash-tables* + *pathnames* + *streams* + *readtables* + *structures* + *functions* + *random-states*)))) + +