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