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 (with-test (:name (cerror :condition-object-and-format-arguments))
 149   (let ((x 0))
 150     (handler-bind
 151         ((simple-error (lambda (c) (incf x) (continue c))))
 152       (cerror "Continue from ~A at ~A"
 153               (make-condition 'simple-error :format-control "foo"
 154                                             :format-arguments nil)
 155               'cerror (get-universal-time))
 156       (assert (= x 1)))))
 157
 158 ;; Test some of the variations permitted by the RESTART-CASE syntax.
 159 (with-test (:name (restart-case :smoke))
 160   (macrolet
 161       ((test (clause &optional (expected ''(:ok)) (args '(:ok)))
 162          `(assert (equal ,expected
 163                          (multiple-value-list
 164                           (restart-case
 165                               (handler-bind
 166                                   ((error (lambda (c)
 167                                             (invoke-restart ',(first clause) ,@args))))
 168                                 (error "foo"))
 169                             ,clause))))))
 170
 171     (test (foo (quux) quux))
 172     (test (foo (&optional quux) quux))
 173     ;; Multiple values should work.
 174     (test (foo (a b) (values a b)) '(1 2) (1 2))
 175     ;; Although somewhat unlikely, these should be legal and return
 176     ;; the respective keyword when the restart is invoked.
 177     (test (foo () :report) '(:report) ())
 178     (test (foo () :interactive) '(:interactive) ())
 179     (test (foo () :test) '(:test) ())
 180     ;; Declarations should work normally as part of the restart body.
 181     (test (foo (quux) :declare ()) '(nil))
 182     (test (foo () :declare () :report "quux") '("quux") ())))
 183
 184 (with-test (:name (restart-case :malformed-clauses))
 185   (macrolet
 186       ((test (clause &optional (expected clause))
 187          `(assert (eq :ok
 188                       (handler-case
 189                           (macroexpand
 190                            `(restart-case (error "foo") ,',clause))
 191                         (simple-error (e)
 192                           (assert (equal '(restart-case ,expected)
 193                                          (simple-condition-format-arguments e)))
 194                           :ok))))))
 195
 196     (test :report)                     ; not even a list
 197     (test ())                          ; empty
 198     (test (foo))                       ; no lambda-list
 199     (test (foo :report))               ; no lambda-list
 200     (test (foo :report "quux"))        ; no lambda-list
 201     (test (foo :report "quux" (quux))) ; confused report and lambda list
 202     ))
 203
 204 (with-test (:name :simple-condition-without-args)
 205   (let ((sc (make-condition 'simple-condition)))
 206     (assert (not (simple-condition-format-control sc)))
 207     (assert (not (simple-condition-format-arguments sc)))
 208     (assert (stringp (prin1-to-string sc)))
 209     (assert
 210      (eq :ok
 211          (handler-case
 212              (princ-to-string sc)
 213            (simple-error (c)
 214              (when (and (equal "No format-control for ~S"
 215                                (simple-condition-format-control c))
 216                         (eq sc (car
 217                                 (simple-condition-format-arguments c))))
 218                :ok)))))))
 219
 220 (with-test (:name :malformed-simple-condition-printing-type-error)
 221   (assert (eq :type-error
 222               (handler-case
 223                   (princ-to-string
 224                    (make-condition 'simple-error :format-control "" :format-arguments 8))
 225                 (type-error (e)
 226                   (when (and (eq 'list (type-error-expected-type e))
 227                              (eql 8 (type-error-datum e)))
 228                     :type-error))))))
 229
 230 (with-test (:name (:printing-unintitialized-condition :bug-1184586))
 231   (prin1-to-string (make-condition 'simple-type-error)))
 232
 233 (with-test (:name (:print-undefined-function-condition))
 234   (handler-case (funcall '#:foo)
 235     (undefined-function (c) (princ c))))