From 9aef3bceb1b284a0ff55146d651a76cb64685d29 Mon Sep 17 00:00:00 2001
From: pfdietz <pfdietz@localhost>
Date: Wed, 21 Apr 2004 13:59:29 +0000
Subject: [PATCH] Modify vector printing tests so that specialized vectors
 don't necessarily have to print readably.

---
 ansi-tests/print-vector.lsp | 10 +++++++---
 ansi-tests/printer-aux.lsp  | 12 ++++++++++--
 2 files changed, 17 insertions(+), 5 deletions(-)

diff --git a/ansi-tests/print-vector.lsp b/ansi-tests/print-vector.lsp
index 0b15cafe..f2b4f340 100644
--- a/ansi-tests/print-vector.lsp
+++ b/ansi-tests/print-vector.lsp
@@ -252,7 +252,9 @@
 	when (vectorp v)
 	nconc
 	(loop repeat 10
-	      nconc (randomly-check-readability v :test #'equalp)))
+	      nconc (randomly-check-readability
+		     v :test #'equalp
+		     :can-fail (not (subtypep t (array-element-type v))))))
   nil)
 
 (deftest print.vector.random.2
@@ -262,7 +264,8 @@
 			    :initial-contents '(1 3 2 0))
 	nconc
 	(loop repeat 10
-	      nconc (randomly-check-readability v :test #'equalp)))
+	      nconc (randomly-check-readability v :test #'equalp
+						:can-fail t)))
   nil)
 
 (deftest print.vector.random.3
@@ -272,7 +275,8 @@
 			    :initial-contents '(-1 1 0 -2))
 	nconc
 	(loop repeat 10
-	      nconc (randomly-check-readability v :test #'equalp)))
+	      nconc (randomly-check-readability v :test #'equalp
+						:can-fail t)))
   nil)
 
 ;;; *print-length* checks
diff --git a/ansi-tests/printer-aux.lsp b/ansi-tests/printer-aux.lsp
index f2f0b7b2..b813bd40 100644
--- a/ansi-tests/printer-aux.lsp
+++ b/ansi-tests/printer-aux.lsp
@@ -23,6 +23,7 @@
 ;;; argument TEST is used to compared the reread object and obj.
 
 (defun randomly-check-readability (obj &key
+				       (can-fail nil)
 				       (test #'equal)
 				       (readable t)
 				       (escape nil escape-p)
@@ -51,10 +52,17 @@
 	 (readcase (random-from-seq #(:upcase :downcase :preserve :invert)))
 	 )
      (setf (readtable-case *readtable*) readcase)
-     (let* ((str (with-output-to-string (s) (write obj :stream s)))
+     (let* ((str (handler-case
+		  (with-output-to-string (s) (write obj :stream s))
+		  (print-not-readable
+		   ()
+		   (if can-fail
+		       (return-from randomly-check-readability nil)
+		     ":print-not-readable-error"))))
 	    (obj2 (let ((*read-base* *print-base*))
 		    (handler-case
-		     (let ((*readtable* (if *print-readably* (copy-readtable nil)
+		     (let ((*readtable* (if *print-readably*
+					    (copy-readtable nil)
 					  *readtable*)))
 		       (read-from-string str))
 		     (reader-error () :error)))))
-- 
GitLab