From 4ef6d8eff3d934bd0a4a8973b2d6f84df9153ded Mon Sep 17 00:00:00 2001
From: pfdietz <pfdietz@localhost>
Date: Fri, 13 Aug 2004 13:38:06 +0000
Subject: [PATCH] Check that format logical block errors are signalled even in
 unsafe code.

---
 ansi-tests/ansi-aux.lsp             |  9 ++-
 ansi-tests/format-logical-block.lsp | 96 ++++++++++++++---------------
 2 files changed, 55 insertions(+), 50 deletions(-)

diff --git a/ansi-tests/ansi-aux.lsp b/ansi-tests/ansi-aux.lsp
index 4b702a6e..e24df14c 100644
--- a/ansi-tests/ansi-aux.lsp
+++ b/ansi-tests/ansi-aux.lsp
@@ -264,7 +264,7 @@ the condition to go uncaught if it cannot be classified."
 ;;; The above is badly designed, since it fails when some signals
 ;;; may be in more than one class/
 
-(defmacro signals-error (form error-name)
+(defmacro signals-error (form error-name &key (safety 3))
   `(handler-bind
     ((warning #'(lambda (c) (declare (ignore c))
 			      (muffle-warning))))
@@ -275,11 +275,16 @@ the condition to go uncaught if it cannot be classified."
 	    (multiple-value-list
 	     (if regression-test::*compile-tests*
 		 (funcall (compile nil '(lambda ()
-					  (declare (optimize safety))
+					  (declare (optimize (safety ,safety)))
 					  ,form)))
 	       (eval ',form))))
      (,error-name (c) (printable-p c)))))
 
+(defmacro signals-error-always (form error-name)
+  `(values
+    (signals-error ,form ,error-name)
+    (signals-error ,form ,error-name :safety 0)))
+
 (defun printable-p (obj)
   "Returns T iff obj can be printed to a string."
   (with-standard-io-syntax
diff --git a/ansi-tests/format-logical-block.lsp b/ansi-tests/format-logical-block.lsp
index 20ad6707..e358b049 100644
--- a/ansi-tests/format-logical-block.lsp
+++ b/ansi-tests/format-logical-block.lsp
@@ -12,100 +12,100 @@
 ;;; Prefix and suffix cannot contain format directives
 
 (deftest format.logical-block.error.1
-  (signals-error (format nil "~<foo~A~;~A~;bar~:>" '(X) '(Y)) error)
-  t)
+  (signals-error-always (format nil "~<foo~A~;~A~;bar~:>" '(X) '(Y)) error)
+  t t)
 
 (deftest format.logical-block.error.2
-  (signals-error (format nil "~<foo~A~@;~A~;bar~:>" '(X) '(Y)) error)
-  t)
+  (signals-error-always (format nil "~<foo~A~@;~A~;bar~:>" '(X) '(Y)) error)
+  t t)
 
 (deftest format.logical-block.error.3
-  (signals-error (format nil "~<foo~;~A~;bar~A~:>" '(X) '(Y)) error)
-  t)
+  (signals-error-always (format nil "~<foo~;~A~;bar~A~:>" '(X) '(Y)) error)
+  t t)
 
 (deftest format.logical-block.error.4
-  (signals-error (format nil "~<foo~@;~A~;bar~A~:>" '(X) '(Y)) error)
-  t)
+  (signals-error-always (format nil "~<foo~@;~A~;bar~A~:>" '(X) '(Y)) error)
+  t t)
 
 (deftest format.logical-block.error.5
-  (signals-error (format nil "~<foo~A~;~A~:>" '(X) '(Y)) error)
-  t)
+  (signals-error-always (format nil "~<foo~A~;~A~:>" '(X) '(Y)) error)
+  t t)
 
 (deftest format.logical-block.error.6
-  (signals-error (format nil "~<foo~A~@;~A~:>" '(X) '(Y)) error)
-  t)
+  (signals-error-always (format nil "~<foo~A~@;~A~:>" '(X) '(Y)) error)
+  t t)
 
 (deftest format.logical-block.error.7
-  (signals-error (format nil "~<~;~A~;bar~A~:>" '(X) '(Y)) error)
-  t)
+  (signals-error-always (format nil "~<~;~A~;bar~A~:>" '(X) '(Y)) error)
+  t t)
 
 (deftest format.logical-block.error.8
-  (signals-error (format nil "~<~@;~A~;bar~A~:>" '(X) '(Y)) error)
-  t)
+  (signals-error-always (format nil "~<~@;~A~;bar~A~:>" '(X) '(Y)) error)
+  t t)
 
 (deftest format.logical-block.error.9
-  (signals-error (format nil "~:<foo~A~;~A~;bar~:>" '(X) '(Y)) error)
-  t)
+  (signals-error-always (format nil "~:<foo~A~;~A~;bar~:>" '(X) '(Y)) error)
+  t t)
 
 (deftest format.logical-block.error.10
-  (signals-error (format nil "~:<foo~A~@;~A~;bar~:>" '(X) '(Y)) error)
-  t)
+  (signals-error-always (format nil "~:<foo~A~@;~A~;bar~:>" '(X) '(Y)) error)
+  t t)
 
 (deftest format.logical-block.error.11
-  (signals-error (format nil "~:<foo~;~A~;bar~A~:>" '(X) '(Y)) error)
-  t)
+  (signals-error-always (format nil "~:<foo~;~A~;bar~A~:>" '(X) '(Y)) error)
+  t t)
 
 (deftest format.logical-block.error.12
-  (signals-error (format nil "~:<foo~@;~A~;bar~A~:>" '(X) '(Y)) error)
-  t)
+  (signals-error-always (format nil "~:<foo~@;~A~;bar~A~:>" '(X) '(Y)) error)
+  t t)
 
 (deftest format.logical-block.error.13
-  (signals-error (format nil "~:<foo~A~;~A~:>" '(X) '(Y)) error)
-  t)
+  (signals-error-always (format nil "~:<foo~A~;~A~:>" '(X) '(Y)) error)
+  t t)
 
 (deftest format.logical-block.error.14
-  (signals-error (format nil "~:<foo~A~@;~A~:>" '(X) '(Y)) error)
-  t)
+  (signals-error-always (format nil "~:<foo~A~@;~A~:>" '(X) '(Y)) error)
+  t t)
 
 (deftest format.logical-block.error.15
-  (signals-error (format nil "~:<~;~A~;bar~A~:>" '(X) '(Y)) error)
-  t)
+  (signals-error-always (format nil "~:<~;~A~;bar~A~:>" '(X) '(Y)) error)
+  t t)
 
 (deftest format.logical-block.error.16
-  (signals-error (format nil "~:<~@;~A~;bar~A~:>" '(X) '(Y)) error)
-  t)
+  (signals-error-always (format nil "~:<~@;~A~;bar~A~:>" '(X) '(Y)) error)
+  t t)
 
 (deftest format.logical-block.error.17
-  (signals-error (format nil "~@<foo~A~;~A~;bar~:>" '(X) '(Y)) error)
-  t)
+  (signals-error-always (format nil "~@<foo~A~;~A~;bar~:>" '(X) '(Y)) error)
+  t t)
 
 (deftest format.logical-block.error.18
-  (signals-error (format nil "~@<foo~A~@;~A~;bar~:>" '(X) '(Y)) error)
-  t)
+  (signals-error-always (format nil "~@<foo~A~@;~A~;bar~:>" '(X) '(Y)) error)
+  t t)
 
 (deftest format.logical-block.error.19
-  (signals-error (format nil "~@<foo~;~A~;bar~A~:>" '(X) '(Y)) error)
-  t)
+  (signals-error-always (format nil "~@<foo~;~A~;bar~A~:>" '(X) '(Y)) error)
+  t t)
 
 (deftest format.logical-block.error.20
-  (signals-error (format nil "~@<foo~@;~A~;bar~A~:>" '(X) '(Y)) error)
-  t)
+  (signals-error-always (format nil "~@<foo~@;~A~;bar~A~:>" '(X) '(Y)) error)
+  t t)
 
 (deftest format.logical-block.error.21
-  (signals-error (format nil "~@<foo~A~;~A~:>" '(X) '(Y)) error)
-  t)
+  (signals-error-always (format nil "~@<foo~A~;~A~:>" '(X) '(Y)) error)
+  t t)
 
 (deftest format.logical-block.error.22
-  (signals-error (format nil "~@<foo~A~@;~A~:>" '(X) '(Y)) error)
-  t)
+  (signals-error-always (format nil "~@<foo~A~@;~A~:>" '(X) '(Y)) error)
+  t t)
 
 (deftest format.logical-block.error.23
-  (signals-error (format nil "~@<~;~A~;bar~A~:>" '(X) '(Y)) error)
-  t)
+  (signals-error-always (format nil "~@<~;~A~;bar~A~:>" '(X) '(Y)) error)
+  t t)
 
 (deftest format.logical-block.error.24
-  (signals-error (format nil "~@<~@;~A~;bar~A~:>" '(X) '(Y)) error)
-  t)
+  (signals-error-always (format nil "~@<~@;~A~;bar~A~:>" '(X) '(Y)) error)
+  t t)
 
 ;;; Non-error tests
 
-- 
GitLab