tests/condition.pure.lisp

   1 ;;;; side-effect-free tests of the condition system
   2
   3 ;;;; This software is part of the SBCL system. See the README file for
   4 ;;;; more information.
   5 ;;;;
   6 ;;;; While most of SBCL is derived from the CMU CL system, the test
   7 ;;;; files (like this one) were written from scratch after the fork
   8 ;;;; from CMU CL.
   9 ;;;;
  10 ;;;; This software is in the public domain and is provided with
  11 ;;;; absolutely no warranty. See the COPYING and CREDITS files for
  12 ;;;; more information.
  13
  14 (cl:in-package :cl-user)
  15
  16 (load "test-util.lisp")
  17
  18 ;;; Until 0.7.7.21, (MAKE-CONDITION 'FILE-ERROR :PATHNAME "FOO")
  19 ;;; wasn't printable, because the REPORT function for FILE-ERROR
  20 ;;; referred to unbound slots. This was reported and fixed by Antonio
  21 ;;; Martinez (sbcl-devel 2002-09-10).
  22 (format t
  23         "~&printable now: ~A~%"
  24         (make-condition 'file-error :pathname "foo"))
  25
  26 (assert (eq
  27          (block nil
  28            (macrolet ((opaque-error (arg) `(error ,arg)))
  29              (handler-bind
  30                  ((error (lambda (c)
  31                            (let ((restarts (remove 'res (compute-restarts c)
  32                                                    :key #'restart-name
  33                                                    :test-not #'eql)))
  34                              (assert (= (length restarts) 2))
  35                              (invoke-restart (second restarts))))))
  36                (let ((foo1 (make-condition 'error))
  37                      (foo2 (make-condition 'error)))
  38                  (restart-case
  39                      (with-condition-restarts foo1 (list (find-restart 'res))
  40                        (restart-case
  41                            (opaque-error foo2)
  42                          (res () 'int1)
  43                          (res () 'int2)))
  44                    (res () 'ext))))))
  45          'int2))
  46
  47 (assert (eq
  48          (block nil
  49            (macrolet ((opaque-error (arg) `(error ,arg)))
  50              (let ((foo1 (make-condition 'error))
  51                    (foo2 (make-condition 'error)))
  52                (handler-bind
  53                    ((error (lambda (c)
  54                              (let ((restarts (remove 'res (compute-restarts foo1)
  55                                                      :key #'restart-name
  56                                                      :test-not #'eql)))
  57                                (assert (= (length restarts) 1))
  58                                (invoke-restart (first restarts))))))
  59                  (restart-case
  60                      (with-condition-restarts foo1 (list (find-restart 'res))
  61                        (restart-case
  62                            (opaque-error foo2)
  63                          (res () 'int1)
  64                          (res () 'int2)))
  65                    (res () 'ext))))))
  66          'ext))
  67
  68 (assert (eq
  69          'ext
  70          (block nil
  71            (let ((visible nil)
  72                  (c1 (make-condition 'error))
  73                  (c2 (make-condition 'error)))
  74              (handler-bind
  75                  ((error
  76                    (lambda (c)
  77                      (declare (ignore c))
  78                      (flet ((check-restarts (length)
  79                               (assert (= length
  80                                          (length (remove 'foo (compute-restarts c1)
  81                                                          :key #'restart-name
  82                                                          :test-not #'eql))))))
  83                        (check-restarts 1)
  84                        (setq visible t)
  85                        (check-restarts 1)
  86                        (invoke-restart (find-restart 'foo c1))))))
  87                (restart-case
  88                    (restart-case
  89                        (error c2)
  90                      (foo () 'in1)
  91                      (foo () :test (lambda (c) (declare (ignore c)) visible)
  92                           'in2))
  93                  (foo () 'ext)))))))
  94
  95 ;;; First argument of CERROR is a format control
  96 (assert
  97  (eq (block nil
  98        (handler-bind
  99            ((type-error (lambda (c) (return :failed)))
 100             (simple-error (lambda (c)
 101                             (return (if (find-restart 'continue)
 102                                         :passed
 103                                         :failed)))))
 104          (cerror (formatter "Continue from ~A") "bug ~A" :bug)))
 105      :passed))
 106
 107 ;;; clauses in HANDLER-CASE are allowed to have declarations (and
 108 ;;; indeed, only declarations)
 109 (assert
 110  (null (handler-case (error "foo") (error () (declare (optimize speed))))))
 111
 112 (handler-case
 113     (handler-bind ((warning #'muffle-warning))
 114       (signal 'warning))
 115   ;; if it's a control error, it had better be printable
 116   (control-error (c) (format nil "~A" c))
 117   ;; there had better be an error
 118   (:no-error (&rest args) (error "No error: ~S" args)))
 119
 120 (handler-case
 121     (funcall (lambda (x) (check-type x fixnum) x) t)
 122   (type-error (c)
 123     (assert (and (subtypep (type-error-expected-type c) 'fixnum)
 124                  (subtypep 'fixnum (type-error-expected-type c))))
 125     (assert (eq (type-error-datum c) t)))
 126   (:no-error (&rest rest) (error "no error: ~S" rest)))
 127
 128 ;;; ANSI specifies TYPE-ERROR if datum and arguments of ERROR are not
 129 ;;; designators for a condition. Reported by Bruno Haible on cmucl-imp
 130 ;;; 2004-10-12.
 131 (flet ((test (&rest args)
 132          (multiple-value-bind (res err)
 133              (ignore-errors (apply #'error args))
 134            (assert (not res))
 135            (assert (typep err 'type-error))
 136            (assert (not (nth-value 1 (ignore-errors
 137                                        (type-error-datum err)))))
 138            (assert (not (nth-value 1 (ignore-errors
 139                                        (type-error-expected-type err))))))))
 140   (test '#:no-such-condition)
 141   (test nil)
 142   (test t)
 143   (test 42)
 144   (test (make-instance 'standard-object)))
 145
 146 ;;; If CERROR is given a condition, any remaining arguments are only
 147 ;;; used for the continue format control.
 148 (let ((x 0))
 149   (handler-bind
 150       ((simple-error (lambda (c) (incf x) (continue c))))
 151     (cerror "Continue from ~A at ~A"
 152             (make-condition 'simple-error :format-control "foo"
 153                             :format-arguments nil)
 154             'cerror (get-universal-time))
 155     (assert (= x 1))))
 156
 157 (with-test (:name :malformed-restart-case-clause)
 158   (assert (eq :ok
 159               (handler-case
 160                   (macroexpand `(restart-case (error "foo")
 161                                   (foo :report "quux" (quux))))
 162                 (simple-error (e)
 163                   (assert (equal '(restart-case (foo :report "quux" (quux)))
 164                                  (simple-condition-format-arguments e)))
 165                   :ok)))))
 166
 167 (with-test (:name :simple-condition-without-args)
 168   (let ((sc (make-condition 'simple-condition)))
 169     (assert (not (simple-condition-format-control sc)))
 170     (assert (not (simple-condition-format-arguments sc)))
 171     (assert (stringp (prin1-to-string sc)))
 172     (assert
 173      (eq :ok
 174          (handler-case
 175              (princ-to-string sc)
 176            (simple-error (c)
 177              (when (and (equal "No format-control for ~S"
 178                                (simple-condition-format-control c))
 179                         (eq sc (car
 180                                 (simple-condition-format-arguments c))))
 181                :ok)))))))
 182
 183 (with-test (:name :malformed-simple-condition-printing-type-error)
 184   (assert (eq :type-error
 185               (handler-case
 186                   (princ-to-string
 187                    (make-condition 'simple-error :format-control "" :format-arguments 8))
 188                 (type-error (e)
 189                   (when (and (eq 'list (type-error-expected-type e))
 190                              (eql 8 (type-error-datum e)))
 191                     :type-error))))))