From bdcbeb7379378fbbc8ed8cd9218855c44196573b Mon Sep 17 00:00:00 2001 From: pfdietz <pfdietz@localhost> Date: Thu, 23 Jan 2003 04:11:59 +0000 Subject: [PATCH] More array tests. --- ansi-tests/ansi-aux.lsp | 20 ++++- ansi-tests/array-misc.lsp | 30 +++++++ ansi-tests/gclload2.lsp | 5 ++ ansi-tests/row-major-aref.lsp | 92 ++++++++++++++++++++++ ansi-tests/simple-vector-p.lsp | 71 +++++++++++++++++ ansi-tests/svref.lsp | 30 +++++++ ansi-tests/upgraded-array-element-type.lsp | 78 ++++++++++++++++++ 7 files changed, 324 insertions(+), 2 deletions(-) create mode 100644 ansi-tests/array-misc.lsp create mode 100644 ansi-tests/row-major-aref.lsp create mode 100644 ansi-tests/simple-vector-p.lsp create mode 100644 ansi-tests/svref.lsp create mode 100644 ansi-tests/upgraded-array-element-type.lsp diff --git a/ansi-tests/ansi-aux.lsp b/ansi-tests/ansi-aux.lsp index 723b8794..272fbaa7 100644 --- a/ansi-tests/ansi-aux.lsp +++ b/ansi-tests/ansi-aux.lsp @@ -71,6 +71,22 @@ ;;; lisp objects used when stimulating things in various tests. (declaim (special *universe*)) +;;; The function EMPIRICAL-SUBTYPEP checks two types +;;; for subtypeness, first using SUBTYPEP*, then (if that +;;; fails) empirically against all the elements of *universe*, +;;; checking if all that are in the first are also in the second. +;;; Return T if this is the case, NIL otherwise. This will +;;; always return T if type1 is truly a subtype of type2, +;;; but may return T even if this is not the case. + +(defun empirical-subtypep (type1 type2) + (multiple-value-bind (sub good) + (subtypep* type1 type2) + (if good + sub + (loop for e in *universe* + always (or (not (typep e type1)) (typep e type2)))))) + (defun check-type-predicate (P TYPE) "Check that a predicate P is the same as #'(lambda (x) (typep x TYPE)) by applying both to all elements of *UNIVERSE*. Print message @@ -973,14 +989,14 @@ the condition to go uncaught if it cannot be classified." (let ((num 0)) (declare (fixnum num)) (do-symbols (s p num) - (declare (ignore s)) + s (incf num)))) (defun num-external-symbols-in-package (p) (let ((num 0)) (declare (fixnum num)) (do-external-symbols (s p num) - (declare (ignore s)) + s (incf num)))) (defun safely-delete-package (package-designator) diff --git a/ansi-tests/array-misc.lsp b/ansi-tests/array-misc.lsp new file mode 100644 index 00000000..361b0a40 --- /dev/null +++ b/ansi-tests/array-misc.lsp @@ -0,0 +1,30 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Wed Jan 22 21:17:25 2003 +;;;; Contains: Misc. tests of array features + +(in-package :cl-test) + +(deftest array-dimension-limit.1 + (and (<= 1024 array-dimension-limit) t) + t) + +(deftest array-dimension-limit.2 + (and (typep array-dimension-limit 'fixnum) t) + t) + +(deftest array-total-size-limit.1 + (and (<= 1024 array-total-size-limit) t) + t) + +(deftest array-total-size-limit.2 + (and (typep array-total-size-limit 'fixnum) t) + t) + +(deftest array-rank-limit.1 + (and (<= 8 array-rank-limit) t) + t) + +(deftest array-rank-limit.2 + (and (typep array-rank-limit 'fixnum) t) + t) diff --git a/ansi-tests/gclload2.lsp b/ansi-tests/gclload2.lsp index 176cc768..03cb1d1d 100644 --- a/ansi-tests/gclload2.lsp +++ b/ansi-tests/gclload2.lsp @@ -140,11 +140,16 @@ (load "array-dimension.lsp") (load "array-dimensions.lsp") (load "array-in-bounds-p.lsp") +(load "array-misc.lsp") (load "array-rank.lsp") (load "array-row-major-index.lsp") (load "array-total-size.lsp") (load "arrayp.lsp") (load "fill-pointer.lsp") +(load "row-major-aref.lsp") +(load "simple-vector-p.lsp") +(load "svref.lsp") +(load "upgraded-array-element-type.lsp") ;;; Tests of packages diff --git a/ansi-tests/row-major-aref.lsp b/ansi-tests/row-major-aref.lsp new file mode 100644 index 00000000..fa685721 --- /dev/null +++ b/ansi-tests/row-major-aref.lsp @@ -0,0 +1,92 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Wed Jan 22 20:16:38 2003 +;;;; Contains: Tests of ROW-MAJOR-AREF + +(in-package :cl-test) + +;;; ROW-MAJOR-AREF is also used by equalp-with-case (see rt/rt.lsp) + +(deftest row-major-aref.1 + (loop for i from 0 to 5 collect (row-major-aref #(a b c d e f) i)) + (a b c d e f)) + +(deftest row-major-aref.2 + (loop for i from 0 to 5 collect (row-major-aref #2a((a b c d)(e f g h)) i)) + (a b c d e f)) + +(deftest row-major-aref.3 + (row-major-aref #0a100 0) + 100) + +(deftest row-major-aref.4 + (loop for i from 0 to 5 collect (row-major-aref #*011100 i)) + (0 1 1 1 0 0)) + +(deftest row-major-aref.5 + (loop for i from 0 to 5 collect (row-major-aref "abcdef" i)) + (#\a #\b #\c #\d #\e #\f)) + +(deftest row-major-aref.6 + (let ((a (make-array nil :initial-element 'x))) + (values + (aref a) + (setf (row-major-aref a 0) 'y) + (aref a) + a)) + x y y #0ay) + +(deftest row-major-aref.7 + (let ((a (make-array '(4) :initial-element 'x))) + (values + (aref a 0) + (aref a 1) + (aref a 2) + (aref a 3) + (setf (row-major-aref a 0) 'a) + (setf (row-major-aref a 1) 'b) + (setf (row-major-aref a 2) 'c) + a)) + x x x x a b c #(a b c x)) + +(deftest row-major-aref.8 + (let ((a (make-array '(4) :element-type 'base-char + :initial-element #\x))) + (values + (aref a 0) + (aref a 1) + (aref a 2) + (aref a 3) + (setf (row-major-aref a 0) #\a) + (setf (row-major-aref a 1) #\b) + (setf (row-major-aref a 2) #\c) + a)) + #\x #\x #\x #\x #\a #\b #\c "abcx") + +(deftest row-major-aref.9 + (let ((a (make-array '(4) :initial-element 0 + :element-type 'bit))) + (values + (aref a 0) + (aref a 1) + (aref a 2) + (aref a 3) + (setf (row-major-aref a 0) 1) + (setf (row-major-aref a 1) 1) + (setf (row-major-aref a 3) 1) + a)) + 0 0 0 0 1 1 1 #*1101) + +(deftest row-major-aref.10 + (let ((a (make-array '(2 3 4) + :initial-contents '(((a b c d)(e f g h)(i j k l)) + ((m n o p)(q r s t)(u v w x)))))) + (loop for i from 0 to 23 collect (row-major-aref a i))) + (a b c d e f g h i j k l m n o p q r s t u v w x)) + + +;;; Error tests + +(deftest row-major-aref.error.1 + (classify-error (row-major-aref)) + program-error) diff --git a/ansi-tests/simple-vector-p.lsp b/ansi-tests/simple-vector-p.lsp new file mode 100644 index 00000000..76efc340 --- /dev/null +++ b/ansi-tests/simple-vector-p.lsp @@ -0,0 +1,71 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Wed Jan 22 21:23:45 2003 +;;;; Contains: Tests for SIMPLE-VECTOR-P + +(in-package :cl-test) + +;;; More tests for this are in make-array.lsp + +(deftest simple-vector-p.1 + (loop for e in *universe* + unless (if (typep e 'simple-vector) + (simple-vector-p e) + (not (simple-vector-p e))) + collect e) + nil) + +(deftest simple-vector-p.2 + (notnot (simple-vector-p (make-array '(10)))) + t) + +(deftest simple-vector-p.3 + (simple-vector-p (make-array '(5) :fill-pointer t)) + nil) + +(deftest simple-vector-p.4 + (notnot (simple-vector-p (vector 'a 'b 'c))) + t) + +(deftest simple-vector-p.5 + (simple-vector-p (make-array '(5) :adjustable t)) + nil) + +(deftest simple-vector-p.6 + (let ((a #(a b c d e g h))) + (simple-vector-p (make-array '(5) :displaced-to a))) + nil) + +(deftest simple-vector-p.7 + (simple-vector-p #*001101) + nil) + +(deftest simple-vector-p.8 + (simple-vector-p "abcdef") + nil) + +(deftest simple-vector-p.9 + (simple-vector-p (make-array nil)) + nil) + +(deftest simple-vector-p.10 + (simple-vector-p (make-array '(10) :element-type 'base-char)) + nil) + +(deftest simple-vector-p.11 + (simple-vector-p (make-array '(10) :element-type 'character)) + nil) + +(deftest simple-vector-p.12 + (simple-vector-p (make-array '(10) :element-type 'bit)) + nil) + +;;; Error tests + +(deftest simple-vector-p.error.1 + (classify-error (simple-vector-p)) + program-error) + +(deftest simple-vector-p.error.2 + (classify-error (simple-vector-p #(a b) nil)) + program-error) diff --git a/ansi-tests/svref.lsp b/ansi-tests/svref.lsp new file mode 100644 index 00000000..73411936 --- /dev/null +++ b/ansi-tests/svref.lsp @@ -0,0 +1,30 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Wed Jan 22 21:39:30 2003 +;;;; Contains: Tests of SVREF + +(in-package :cl-test) + +(deftest svref.1 + (let ((a (vector 1 2 3 4))) + (loop for i below 4 collect (svref a i))) + (1 2 3 4)) + +(deftest svref.2 + (let ((a (vector 1 2 3 4))) + (values + (loop for i below 4 + collect (setf (svref a i) (+ i 10))) + a)) + (10 11 12 13) + #(10 11 12 13)) + +;;; Error tests + +(deftest svref.error.1 + (classify-error (svref)) + program-error) + +(deftest svref.error.2 + (classify-error (svref (vector 1))) + program-error) diff --git a/ansi-tests/upgraded-array-element-type.lsp b/ansi-tests/upgraded-array-element-type.lsp new file mode 100644 index 00000000..359ab201 --- /dev/null +++ b/ansi-tests/upgraded-array-element-type.lsp @@ -0,0 +1,78 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Wed Jan 22 20:43:55 2003 +;;;; Contains: Tests of UPGRADED-ARRAY-ELEMENT-TYPE + +(in-package :cl-test) + +(deftest upgraded-array-element-type.1 + (let ((upgraded-bit (upgraded-array-element-type 'bit))) + (and (empirical-subtypep 'bit upgraded-bit) + (empirical-subtypep upgraded-bit 'bit))) + t) + +(deftest upgraded-array-element-type.2 + (let ((upgraded-base-char (upgraded-array-element-type 'base-char))) + (and (empirical-subtypep 'base-char upgraded-base-char) + (empirical-subtypep upgraded-base-char 'base-char))) + t) + +(deftest upgraded-array-element-type.3 + (let ((upgraded-character (upgraded-array-element-type 'character))) + (and (empirical-subtypep 'character upgraded-character) + (empirical-subtypep upgraded-character 'character))) + t) + +(defparameter *upgraded-array-types-to-check* + `(boolean + base-char + character + t + ,@(loop for i from 0 to 32 + collect `(integer 0 (,(ash 1 i)))) + symbol + ,@(loop for i from 0 to 32 + collect `(integer ,(- (ash 1 i)) (,(ash 1 i)))) + (integer -10000000000000000000000000000000000 + 10000000000000000000000000000000000) + float + single-float + double-float + complex + rational + fixnum + function + sequence + list + cons + atom + symbol)) + +(deftest upgraded-array-element-type.4 + (loop for type in *upgraded-array-types-to-check* + for upgraded-type = (upgraded-array-element-type type) + always (empirical-subtypep type upgraded-type)) + t) + +;; Include an environment (NIL, denoting the default null lexical +;; environment) + +(deftest upgraded-array-element-type.5 + (loop for type in *upgraded-array-types-to-check* + for upgraded-type = (upgraded-array-element-type type nil) + always (empirical-subtypep type upgraded-type)) + t) + +;;; Error tests + +(deftest upgraded-array-element-type.error.1 + (classify-error (upgraded-array-element-type)) + program-error) + +(deftest upgraded-array-element-type.error.2 + (classify-error (upgraded-array-element-type 'bit nil nil)) + program-error) + + + + -- GitLab