From 8ea11d00521eafe874e6fb8791ae1de13dca009c Mon Sep 17 00:00:00 2001
From: pfdietz <pfdietz@localhost>
Date: Wed, 22 Jan 2003 12:59:55 +0000
Subject: [PATCH] More changes to array tests.

---
 ansi-tests/adjustable-array-p.lsp | 11 ++++++----
 ansi-tests/array-dimensions.lsp   | 12 ++++++-----
 ansi-tests/array-displacement.lsp | 12 ++++++-----
 ansi-tests/array-total-size.lsp   | 22 ++++++-------------
 ansi-tests/fill-pointer.lsp       | 36 +++++++++++++++++++++++++++----
 5 files changed, 60 insertions(+), 33 deletions(-)

diff --git a/ansi-tests/adjustable-array-p.lsp b/ansi-tests/adjustable-array-p.lsp
index e5873a3c..dfc31859 100644
--- a/ansi-tests/adjustable-array-p.lsp
+++ b/ansi-tests/adjustable-array-p.lsp
@@ -40,8 +40,11 @@
   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)
+  (let (why)
+    (loop for e in *mini-universe*
+	  unless (or (typep e 'array)
+		     (eq 'type-error 
+			 (setq why (classify-error**
+				    `(adjustable-array-p ',e)))))
+	  collect (list e why)))
   nil)
diff --git a/ansi-tests/array-dimensions.lsp b/ansi-tests/array-dimensions.lsp
index 8ceb58e6..73ceddaa 100644
--- a/ansi-tests/array-dimensions.lsp
+++ b/ansi-tests/array-dimensions.lsp
@@ -50,9 +50,11 @@
   program-error)
 
 (deftest array-dimensions.error.3
-  (loop for e in *mini-universe*
-	unless (or (typep e 'array)
-		   (eq 'type-error
-		       (classify-error** `(array-dimensions ',e))))
-	collect e)
+  (let (why)
+    (loop for e in *mini-universe*
+	  unless (or (typep e 'array)
+		     (eq 'type-error
+			 (setq why (classify-error**
+				    `(array-dimensions ',e)))))
+	  collect (list e why)))
   nil)
diff --git a/ansi-tests/array-displacement.lsp b/ansi-tests/array-displacement.lsp
index fb08b331..02723d32 100644
--- a/ansi-tests/array-displacement.lsp
+++ b/ansi-tests/array-displacement.lsp
@@ -105,9 +105,11 @@
   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)
+  (let (why)
+    (loop for e in *mini-universe*
+	  unless (or (typep e 'array)
+		     (eq 'type-error
+			 (setq why (classify-error**
+				    `(array-displacement ',e)))))
+	collect (list e why)))
   nil)
diff --git a/ansi-tests/array-total-size.lsp b/ansi-tests/array-total-size.lsp
index 0830ed98..cf55b392 100644
--- a/ansi-tests/array-total-size.lsp
+++ b/ansi-tests/array-total-size.lsp
@@ -38,23 +38,15 @@
   program-error)
 
 (deftest array-total-size.error.3
-  (loop for e in *mini-universe*
-	when (and (not (typep e 'array))
-		  (not (eql (classify-error** `(array-total-size ',e))
-			    'type-error)))
-	collect e)
+  (let (why)
+    (loop for e in *mini-universe*
+	  when (and (not (typep e 'array))
+		    (not (eql (setq why 
+				    (classify-error** `(array-total-size ',e)))
+			      'type-error)))
+	collect (list e why)))
   nil)
 
 (deftest array-total-size.error.4
   (classify-error (array-total-size 0))
   type-error)
-
-
-
-
-
-
-
-
-
-
diff --git a/ansi-tests/fill-pointer.lsp b/ansi-tests/fill-pointer.lsp
index 0fdfe7a5..aa91c42f 100644
--- a/ansi-tests/fill-pointer.lsp
+++ b/ansi-tests/fill-pointer.lsp
@@ -24,7 +24,35 @@
      a))
   5 6 #(1 2 3 4 5 6))
 
-
-
-
-
+;;; Error tests
+
+(deftest fill-pointer.error.1
+  (classify-error (fill-pointer))
+  program-error)
+
+(deftest fill-pointer.error.2
+  (classify-error (fill-pointer (make-array '(10) :fill-pointer 4)
+				nil))
+  program-error)
+
+(deftest fill-pointer.error.3
+  (classify-error (fill-pointer (make-array '(10) :fill-pointer nil)))
+  type-error)
+
+(deftest fill-pointer.error.4
+  (classify-error (fill-pointer #0aNIL))
+  type-error)
+
+(deftest fill-pointer.error.5
+  (classify-error (fill-pointer #2a((a b c)(d e f))))
+  type-error)
+
+(deftest fill-pointer.error.6
+  (let (why)
+    (loop for e in *mini-universe*
+	  when (and (or (not (typep e 'vector))
+			(not (array-has-fill-pointer-p e)))
+		    (not (eql (setq why (classify-error** `(fill-pointer ',e)))
+			      'type-error)))
+	  collect (list e why)))
+  nil)
-- 
GitLab