Commit 4ef6d8ef authored by pfdietz's avatar pfdietz
Browse files

Check that format logical block errors are signalled even in unsafe code.

parent e583bd07
...@@ -264,7 +264,7 @@ the condition to go uncaught if it cannot be classified." ...@@ -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 ;;; The above is badly designed, since it fails when some signals
;;; may be in more than one class/ ;;; may be in more than one class/
(defmacro signals-error (form error-name) (defmacro signals-error (form error-name &key (safety 3))
`(handler-bind `(handler-bind
((warning #'(lambda (c) (declare (ignore c)) ((warning #'(lambda (c) (declare (ignore c))
(muffle-warning)))) (muffle-warning))))
...@@ -275,11 +275,16 @@ the condition to go uncaught if it cannot be classified." ...@@ -275,11 +275,16 @@ the condition to go uncaught if it cannot be classified."
(multiple-value-list (multiple-value-list
(if regression-test::*compile-tests* (if regression-test::*compile-tests*
(funcall (compile nil '(lambda () (funcall (compile nil '(lambda ()
(declare (optimize safety)) (declare (optimize (safety ,safety)))
,form))) ,form)))
(eval ',form)))) (eval ',form))))
(,error-name (c) (printable-p c))))) (,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) (defun printable-p (obj)
"Returns T iff obj can be printed to a string." "Returns T iff obj can be printed to a string."
(with-standard-io-syntax (with-standard-io-syntax
......
...@@ -12,100 +12,100 @@ ...@@ -12,100 +12,100 @@
;;; Prefix and suffix cannot contain format directives ;;; Prefix and suffix cannot contain format directives
(deftest format.logical-block.error.1 (deftest format.logical-block.error.1
(signals-error (format nil "~<foo~A~;~A~;bar~:>" '(X) '(Y)) error) (signals-error-always (format nil "~<foo~A~;~A~;bar~:>" '(X) '(Y)) error)
t) t t)
(deftest format.logical-block.error.2 (deftest format.logical-block.error.2
(signals-error (format nil "~<foo~A~@;~A~;bar~:>" '(X) '(Y)) error) (signals-error-always (format nil "~<foo~A~@;~A~;bar~:>" '(X) '(Y)) error)
t) t t)
(deftest format.logical-block.error.3 (deftest format.logical-block.error.3
(signals-error (format nil "~<foo~;~A~;bar~A~:>" '(X) '(Y)) error) (signals-error-always (format nil "~<foo~;~A~;bar~A~:>" '(X) '(Y)) error)
t) t t)
(deftest format.logical-block.error.4 (deftest format.logical-block.error.4
(signals-error (format nil "~<foo~@;~A~;bar~A~:>" '(X) '(Y)) error) (signals-error-always (format nil "~<foo~@;~A~;bar~A~:>" '(X) '(Y)) error)
t) t t)
(deftest format.logical-block.error.5 (deftest format.logical-block.error.5
(signals-error (format nil "~<foo~A~;~A~:>" '(X) '(Y)) error) (signals-error-always (format nil "~<foo~A~;~A~:>" '(X) '(Y)) error)
t) t t)
(deftest format.logical-block.error.6 (deftest format.logical-block.error.6
(signals-error (format nil "~<foo~A~@;~A~:>" '(X) '(Y)) error) (signals-error-always (format nil "~<foo~A~@;~A~:>" '(X) '(Y)) error)
t) t t)
(deftest format.logical-block.error.7 (deftest format.logical-block.error.7
(signals-error (format nil "~<~;~A~;bar~A~:>" '(X) '(Y)) error) (signals-error-always (format nil "~<~;~A~;bar~A~:>" '(X) '(Y)) error)
t) t t)
(deftest format.logical-block.error.8 (deftest format.logical-block.error.8
(signals-error (format nil "~<~@;~A~;bar~A~:>" '(X) '(Y)) error) (signals-error-always (format nil "~<~@;~A~;bar~A~:>" '(X) '(Y)) error)
t) t t)
(deftest format.logical-block.error.9 (deftest format.logical-block.error.9
(signals-error (format nil "~:<foo~A~;~A~;bar~:>" '(X) '(Y)) error) (signals-error-always (format nil "~:<foo~A~;~A~;bar~:>" '(X) '(Y)) error)
t) t t)
(deftest format.logical-block.error.10 (deftest format.logical-block.error.10
(signals-error (format nil "~:<foo~A~@;~A~;bar~:>" '(X) '(Y)) error) (signals-error-always (format nil "~:<foo~A~@;~A~;bar~:>" '(X) '(Y)) error)
t) t t)
(deftest format.logical-block.error.11 (deftest format.logical-block.error.11
(signals-error (format nil "~:<foo~;~A~;bar~A~:>" '(X) '(Y)) error) (signals-error-always (format nil "~:<foo~;~A~;bar~A~:>" '(X) '(Y)) error)
t) t t)
(deftest format.logical-block.error.12 (deftest format.logical-block.error.12
(signals-error (format nil "~:<foo~@;~A~;bar~A~:>" '(X) '(Y)) error) (signals-error-always (format nil "~:<foo~@;~A~;bar~A~:>" '(X) '(Y)) error)
t) t t)
(deftest format.logical-block.error.13 (deftest format.logical-block.error.13
(signals-error (format nil "~:<foo~A~;~A~:>" '(X) '(Y)) error) (signals-error-always (format nil "~:<foo~A~;~A~:>" '(X) '(Y)) error)
t) t t)
(deftest format.logical-block.error.14 (deftest format.logical-block.error.14
(signals-error (format nil "~:<foo~A~@;~A~:>" '(X) '(Y)) error) (signals-error-always (format nil "~:<foo~A~@;~A~:>" '(X) '(Y)) error)
t) t t)
(deftest format.logical-block.error.15 (deftest format.logical-block.error.15
(signals-error (format nil "~:<~;~A~;bar~A~:>" '(X) '(Y)) error) (signals-error-always (format nil "~:<~;~A~;bar~A~:>" '(X) '(Y)) error)
t) t t)
(deftest format.logical-block.error.16 (deftest format.logical-block.error.16
(signals-error (format nil "~:<~@;~A~;bar~A~:>" '(X) '(Y)) error) (signals-error-always (format nil "~:<~@;~A~;bar~A~:>" '(X) '(Y)) error)
t) t t)
(deftest format.logical-block.error.17 (deftest format.logical-block.error.17
(signals-error (format nil "~@<foo~A~;~A~;bar~:>" '(X) '(Y)) error) (signals-error-always (format nil "~@<foo~A~;~A~;bar~:>" '(X) '(Y)) error)
t) t t)
(deftest format.logical-block.error.18 (deftest format.logical-block.error.18
(signals-error (format nil "~@<foo~A~@;~A~;bar~:>" '(X) '(Y)) error) (signals-error-always (format nil "~@<foo~A~@;~A~;bar~:>" '(X) '(Y)) error)
t) t t)
(deftest format.logical-block.error.19 (deftest format.logical-block.error.19
(signals-error (format nil "~@<foo~;~A~;bar~A~:>" '(X) '(Y)) error) (signals-error-always (format nil "~@<foo~;~A~;bar~A~:>" '(X) '(Y)) error)
t) t t)
(deftest format.logical-block.error.20 (deftest format.logical-block.error.20
(signals-error (format nil "~@<foo~@;~A~;bar~A~:>" '(X) '(Y)) error) (signals-error-always (format nil "~@<foo~@;~A~;bar~A~:>" '(X) '(Y)) error)
t) t t)
(deftest format.logical-block.error.21 (deftest format.logical-block.error.21
(signals-error (format nil "~@<foo~A~;~A~:>" '(X) '(Y)) error) (signals-error-always (format nil "~@<foo~A~;~A~:>" '(X) '(Y)) error)
t) t t)
(deftest format.logical-block.error.22 (deftest format.logical-block.error.22
(signals-error (format nil "~@<foo~A~@;~A~:>" '(X) '(Y)) error) (signals-error-always (format nil "~@<foo~A~@;~A~:>" '(X) '(Y)) error)
t) t t)
(deftest format.logical-block.error.23 (deftest format.logical-block.error.23
(signals-error (format nil "~@<~;~A~;bar~A~:>" '(X) '(Y)) error) (signals-error-always (format nil "~@<~;~A~;bar~A~:>" '(X) '(Y)) error)
t) t t)
(deftest format.logical-block.error.24 (deftest format.logical-block.error.24
(signals-error (format nil "~@<~@;~A~;bar~A~:>" '(X) '(Y)) error) (signals-error-always (format nil "~@<~@;~A~;bar~A~:>" '(X) '(Y)) error)
t) t t)
;;; Non-error tests ;;; Non-error tests
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment