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