diff --git a/ansi-tests/ansi-aux.lsp b/ansi-tests/ansi-aux.lsp index fc86b3784ae61f8ff50fe180ff12f689abb53139..4c1478284bcec8c0464af63cae0081217d36f2f5 100644 --- a/ansi-tests/ansi-aux.lsp +++ b/ansi-tests/ansi-aux.lsp @@ -51,19 +51,21 @@ (and (typep a1 'array) (typep a2 'array) (= (array-rank a1) (array-rank a2)) - (let ((ad (array-dimensions a1))) - (and (equal ad (array-dimensions a2)) - (if (= (array-rank a1) 1) - (let ((as (first ad))) - (loop - for i from 0 below as - always (equal (aref a1 i) (aref a2 i)))) - (let ((as (array-total-size a1))) - (and (= as (array-total-size a2)) - (loop - for i from 0 below as - always (equal (row-major-aref a1 i) - (row-major-aref a2 i)))))))))) + (if (= (array-rank a1) 0) + (equal (aref a1) (aref a2)) + (let ((ad (array-dimensions a1))) + (and (equal ad (array-dimensions a2)) + (if (= (array-rank a1) 1) + (let ((as (first ad))) + (loop + for i from 0 below as + always (equal (aref a1 i) (aref a2 i)))) + (let ((as (array-total-size a1))) + (and (= as (array-total-size a2)) + (loop + for i from 0 below as + always (equal (row-major-aref a1 i) + (row-major-aref a2 i))))))))))) ;;; *universe* is defined elsewhere -- it is a list of various ;;; lisp objects used when stimulating things in various tests. diff --git a/ansi-tests/gclload2.lsp b/ansi-tests/gclload2.lsp index abd0c770c1770bdb111fb49ae1d465d7c0d0f583..4888dd66d16e9f301c6e5a79d323b9daf149b845 100644 --- a/ansi-tests/gclload2.lsp +++ b/ansi-tests/gclload2.lsp @@ -123,6 +123,9 @@ (load "cons-test-24.lsp") (load "cons-test-25.lsp") +;;; Tests on arrays +(load "make-array.lsp") + ;;; Tests of packages (load "packages.lsp") diff --git a/ansi-tests/make-array.lsp b/ansi-tests/make-array.lsp index b47f39cb53490a78ae6b4538559e59ea9f274a9d..974b2eab26c8b5588bf94172da9e5a4c6aa51b4e 100644 --- a/ansi-tests/make-array.lsp +++ b/ansi-tests/make-array.lsp @@ -8,3 +8,208 @@ (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)))) + +(deftest make-array.1 + (let ((a (make-array-with-checks 10))) + (and (symbolp a) a)) + nil) + +(deftest make-array.1a + (let ((a (make-array-with-checks '(10)))) + (and (symbolp a) a)) + nil) + +(deftest make-array.2 + (make-array-with-checks 3 :initial-element 'z) + #(z z z)) + +(deftest make-array.2a + (make-array-with-checks 3 :initial-contents '(a b c)) + #(a b c)) + +(deftest make-array.2b + (make-array-with-checks 3 :initial-contents #(a b c)) + #(a b c)) + +(deftest make-array.2c + (make-array-with-checks 3 :initial-contents "abc") + #(#\a #\b #\c)) + +(deftest make-array.2d + (make-array-with-checks 3 :initial-contents #*010) + #(0 1 0)) + +(deftest make-array.3 + (let ((a (make-array-with-checks 5 :element-type 'bit))) + (and (symbolp a) a)) + nil) + +(deftest make-array.4 + (make-array-with-checks 5 :element-type 'bit :initial-element 1) + #*11111) + +(deftest make-array.4a + (make-array-with-checks 5 :element-type 'bit :initial-contents '(1 0 0 1 0)) + #*10010) + +(deftest make-array.4b + (make-array-with-checks 5 :element-type 'bit :initial-contents #(1 0 0 1 0)) + #*10010) + +(deftest make-array.4c + (make-array-with-checks 5 :element-type 'bit :initial-contents #*10010) + #*10010) + +(deftest make-array.5 + (let ((a (make-array-with-checks 4 :element-type 'character))) + (and (symbolp a) a)) + nil) + +(deftest make-array.5a + (let ((a (make-array-with-checks '(4) :element-type 'character))) + (and (symbolp a) a)) + nil) + +(deftest make-array.6 + (make-array-with-checks 4 :element-type 'character + :initial-element #\x) + "xxxx") + +(deftest make-array.6a + (make-array-with-checks 4 :element-type 'character + :initial-contents '(#\a #\b #\c #\d)) + "abcd") + +(deftest make-array.6b + (make-array-with-checks 4 :element-type 'character + :initial-contents "abcd") + "abcd") + +(deftest make-array.7 + (make-array-with-checks 5 :element-type 'symbol + :initial-element 'a) + #(a a a a a)) + +(deftest make-array.7a + (make-array-with-checks 5 :element-type 'symbol + :initial-contents '(a b c d e)) + #(a b c d e)) + +(deftest make-array.7b + (make-array-with-checks '(5) :element-type 'symbol + :initial-contents '(a b c d e)) + #(a b c d e)) + +(deftest make-array.8 + (let ((a (make-array-with-checks 8 :element-type '(integer 0 (256))))) + (and (symbolp a) a)) + nil) + +(deftest make-array.8a + (make-array-with-checks 8 :element-type '(integer 0 (256)) + :initial-element 9) + #(9 9 9 9 9 9 9 9)) + +(deftest make-array.8b + (make-array-with-checks '(8) :element-type '(integer 0 (256)) + :initial-contents '(4 3 2 1 9 8 7 6)) + #(4 3 2 1 9 8 7 6)) + +;;; Zero dimensional arrays + +(deftest make-array.9 + (let ((a (make-array-with-checks nil))) + (and (symbolp a) a)) + nil) + +(deftest make-array.10 + (make-array-with-checks nil :initial-element 1) + #0A1) + +(deftest make-array.11 + (make-array-with-checks nil :initial-contents 2) + #0A2) + +(deftest make-array.12 + (make-array-with-checks nil :element-type 'bit :initial-contents 1) + #0A1) + +(deftest make-array.13 + (make-array-with-checks nil :element-type t :initial-contents 'a) + #0Aa) + + + + + + + + diff --git a/ansi-tests/rt/rt.lsp b/ansi-tests/rt/rt.lsp index 7c9c3fce885b28e4b69ee40d9aa36dc1cb2de646..b2d3038f24504e6873a12e6d5adaa993a040f58f 100644 --- a/ansi-tests/rt/rt.lsp +++ b/ansi-tests/rt/rt.lsp @@ -104,11 +104,17 @@ (do-entry (get-entry name))) (defun equalp-with-case (x y) + "Like EQUALP, but doesn't do case conversion of characters. + Currently doesn't work on arrays of dimension > 1." (cond ((consp x) (and (consp y) (equalp-with-case (car x) (car y)) (equalp-with-case (cdr x) (cdr y)))) + ((and (typep x 'array) + (typep y 'array) + (not (eql (array-rank x) (array-rank y)))) + nil) ((typep x 'vector) (and (typep y 'vector) (let ((x-len (length x)) @@ -118,6 +124,9 @@ for e1 across x for e2 across y always (equalp-with-case e1 e2)))))) + ((and (typep x 'array) + (= (array-rank x) 0)) + (equalp-with-case (aref x) (aref y))) (t (eql x y)))) (defun do-entry (entry &optional