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                              (declare (ignore c))
  55                              (let ((restarts (remove 'res (compute-restarts foo1)
  56                                                      :key #'restart-name
  57                                                      :test-not #'eql)))
  58                                (assert (= (length restarts) 1))
  59                                (invoke-restart (first restarts))))))
  60                  (restart-case
  61                      (with-condition-restarts foo1 (list (find-restart 'res))
  62                        (restart-case
  63                            (opaque-error foo2)
  64                          (res () 'int1)
  65                          (res () 'int2)))
  66                    (res () 'ext))))))
  67          'ext))
  68
  69 (assert (eq
  70          'ext
  71          (block nil
  72            (let ((visible nil)
  73                  (c1 (make-condition 'error))
  74                  (c2 (make-condition 'error)))
  75              (handler-bind
  76                  ((error
  77                    (lambda (c)
  78                      (declare (ignore c))
  79                      (flet ((check-restarts (length)
  80                               (assert (= length
  81                                          (length (remove 'foo (compute-restarts c1)
  82                                                          :key #'restart-name
  83                                                          :test-not #'eql))))))
  84                        (check-restarts 1)
  85                        (setq visible t)
  86                        (check-restarts 1)
  87                        (invoke-restart (find-restart 'foo c1))))))
  88                (restart-case
  89                    (restart-case
  90                        (error c2)
  91                      (foo () 'in1)
  92                      (foo () :test (lambda (c) (declare (ignore c)) visible)
  93                           'in2))
  94                  (foo () 'ext)))))))
  95
  96 ;;; First argument of CERROR is a format control
  97 (assert
  98  (eq (block nil
  99        (handler-bind
 100            ((type-error (lambda (c)
 101                           (declare (ignore c))
 102                           (return :failed)))
 103             (simple-error (lambda (c)
 104                             (declare (ignore c))
 105                             (return (if (find-restart 'continue)
 106                                         :passed
 107                                         :failed)))))
 108          (cerror (formatter "Continue from ~A") "bug ~A" :bug)))
 109      :passed))
 110
 111 ;;; clauses in HANDLER-CASE are allowed to have declarations (and
 112 ;;; indeed, only declarations)
 113 (assert
 114  (null (handler-case (error "foo") (error () (declare (optimize speed))))))
 115
 116 (handler-case
 117     (handler-bind ((warning #'muffle-warning))
 118       (signal 'warning))
 119   ;; if it's a control error, it had better be printable
 120   (control-error (c) (format nil "~A" c))
 121   ;; there had better be an error
 122   (:no-error (&rest args) (error "No error: ~S" args)))
 123
 124 (handler-case
 125     (funcall (lambda (x) (check-type x fixnum) x) t)
 126   (type-error (c)
 127     (assert (and (subtypep (type-error-expected-type c) 'fixnum)
 128                  (subtypep 'fixnum (type-error-expected-type c))))
 129     (assert (eq (type-error-datum c) t)))
 130   (:no-error (&rest rest) (error "no error: ~S" rest)))
 131
 132 ;;; ANSI specifies TYPE-ERROR if datum and arguments of ERROR are not
 133 ;;; designators for a condition. Reported by Bruno Haible on cmucl-imp
 134 ;;; 2004-10-12.
 135 (flet ((test (&rest args)
 136          (multiple-value-bind (res err)
 137              (ignore-errors (apply #'error args))
 138            (assert (not res))
 139            (assert (typep err 'type-error))
 140            (assert (not (nth-value 1 (ignore-errors
 141                                        (type-error-datum err)))))
 142            (assert (not (nth-value 1 (ignore-errors
 143                                        (type-error-expected-type err))))))))
 144   (test '#:no-such-condition)
 145   (test nil)
 146   (test t)
 147   (test 42)
 148   (test (make-instance 'standard-object)))
 149
 150 ;;; If CERROR is given a condition, any remaining arguments are only
 151 ;;; used for the continue format control.
 152 (with-test (:name (cerror :condition-object-and-format-arguments))
 153   (let ((x 0))
 154     (handler-bind
 155         ((simple-error (lambda (c) (incf x) (continue c))))
 156       (cerror "Continue from ~A at ~A"
 157               (make-condition 'simple-error :format-control "foo"
 158                                             :format-arguments nil)
 159               'cerror (get-universal-time))
 160       (assert (= x 1)))))
 161
 162 ;; Test some of the variations permitted by the RESTART-CASE syntax.
 163 (with-test (:name (restart-case :smoke))
 164   (macrolet
 165       ((test (clause &optional (expected ''(:ok)) (args '(:ok)))
 166          `(assert (equal ,expected
 167                          (multiple-value-list
 168                           (restart-case
 169                               (handler-bind
 170                                   ((error (lambda (c)
 171                                             (invoke-restart ',(first clause) ,@args))))
 172                                 (error "foo"))
 173                             ,clause))))))
 174
 175     (test (foo (quux) quux))
 176     (test (foo (&optional quux) quux))
 177     ;; Multiple values should work.
 178     (test (foo (a b) (values a b)) '(1 2) (1 2))
 179     ;; Although somewhat unlikely, these should be legal and return
 180     ;; the respective keyword when the restart is invoked.
 181     (test (foo () :report) '(:report) ())
 182     (test (foo () :interactive) '(:interactive) ())
 183     (test (foo () :test) '(:test) ())
 184     ;; Declarations should work normally as part of the restart body.
 185     (test (foo (quux) :declare ()) '(nil))
 186     (test (foo () :declare () :report "quux") '("quux") ())))
 187
 188 (with-test (:name (restart-case :malformed-clauses))
 189   (macrolet
 190       ((test (clause &optional (expected clause))
 191          `(assert (eq :ok
 192                       (handler-case
 193                           (macroexpand
 194                            `(restart-case (error "foo") ,',clause))
 195                         (simple-error (e)
 196                           (assert (equal '(restart-case ,expected)
 197                                          (simple-condition-format-arguments e)))
 198                           :ok))))))
 199
 200     (test :report)                     ; not even a list
 201     (test ())                          ; empty
 202     (test (foo))                       ; no lambda-list
 203     (test (foo :report))               ; no lambda-list
 204     (test (foo :report "quux"))        ; no lambda-list
 205     (test (foo :report "quux" (quux))) ; confused report and lambda list
 206     ))
 207
 208 (with-test (:name :simple-condition-without-args)
 209   (let ((sc (make-condition 'simple-condition)))
 210     (assert (not (simple-condition-format-control sc)))
 211     (assert (not (simple-condition-format-arguments sc)))
 212     (assert (stringp (prin1-to-string sc)))
 213     (assert
 214      (eq :ok
 215          (handler-case
 216              (princ-to-string sc)
 217            (simple-error (c)
 218              (when (and (equal "No format-control for ~S"
 219                                (simple-condition-format-control c))
 220                         (eq sc (car
 221                                 (simple-condition-format-arguments c))))
 222                :ok)))))))
 223
 224 (with-test (:name :malformed-simple-condition-printing-type-error)
 225   (assert (eq :type-error
 226               (handler-case
 227                   (princ-to-string
 228                    (make-condition 'simple-error :format-control "" :format-arguments 8))
 229                 (type-error (e)
 230                   (when (and (eq 'list (type-error-expected-type e))
 231                              (eql 8 (type-error-datum e)))
 232                     :type-error))))))
 233
 234 (with-test (:name (:printing-unintitialized-condition :bug-1184586))
 235   (prin1-to-string (make-condition 'simple-type-error)))
 236
 237 (with-test (:name (:print-undefined-function-condition))
 238   (handler-case (funcall '#:foo)
 239     (undefined-function (c) (princ c))))