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 (with-test (:name (handler-bind :smoke))
 112   (let ((called?))
 113     (flet ((handler (condition)
 114              (declare (ignore condition))
 115              (setf called? t)))
 116       (macrolet ((test (handler)
 117                    `(progn
 118                       (setf called? nil)
 119                       (handler-bind ((condition ,handler))
 120                         (signal 'condition))
 121                       (assert called?))))
 122         ;; Test optimized special cases.
 123         (test (lambda (condition) (handler condition)))
 124         (test #'(lambda (condition) (handler condition)))
 125         ;; Test default behavior.
 126         ;; (test 'handler) would require function definition => not pure
 127         (test #'handler)))))
 128
 129 (with-test (:name (handler-bind :malformed-bindings))
 130   (flet ((test (binding)
 131            (assert (eq :ok
 132                        (handler-case
 133                            (macroexpand `(handler-bind (,binding)))
 134                          (simple-error (e)
 135                            (assert (equal (list binding)
 136                                           (simple-condition-format-arguments e)))
 137                            :ok))))))
 138
 139     (test 1)                     ; not even a list
 140     (test '())                   ; missing condition type and handler
 141     (test '(error))              ; missing handler
 142     (test '(error #'print :foo)) ; too many elements
 143     ))
 144
 145 ;;; clauses in HANDLER-CASE are allowed to have declarations (and
 146 ;;; indeed, only declarations)
 147 (assert
 148  (null (handler-case (error "foo") (error () (declare (optimize speed))))))
 149
 150 (handler-case
 151     (handler-bind ((warning #'muffle-warning))
 152       (signal 'warning))
 153   ;; if it's a control error, it had better be printable
 154   (control-error (c) (format nil "~A" c))
 155   ;; there had better be an error
 156   (:no-error (&rest args) (error "No error: ~S" args)))
 157
 158 (handler-case
 159     (funcall (lambda (x) (check-type x fixnum) x) t)
 160   (type-error (c)
 161     (assert (and (subtypep (type-error-expected-type c) 'fixnum)
 162                  (subtypep 'fixnum (type-error-expected-type c))))
 163     (assert (eq (type-error-datum c) t)))
 164   (:no-error (&rest rest) (error "no error: ~S" rest)))
 165
 166 ;;; ANSI specifies TYPE-ERROR if datum and arguments of ERROR are not
 167 ;;; designators for a condition. Reported by Bruno Haible on cmucl-imp
 168 ;;; 2004-10-12.
 169 (flet ((test (&rest args)
 170          (multiple-value-bind (res err)
 171              (ignore-errors (apply #'error args))
 172            (assert (not res))
 173            (assert (typep err 'type-error))
 174            (assert (not (nth-value 1 (ignore-errors
 175                                        (type-error-datum err)))))
 176            (assert (not (nth-value 1 (ignore-errors
 177                                        (type-error-expected-type err))))))))
 178   (test '#:no-such-condition)
 179   (test nil)
 180   (test t)
 181   (test 42)
 182   (test (make-instance 'standard-object)))
 183
 184 ;;; If CERROR is given a condition, any remaining arguments are only
 185 ;;; used for the continue format control.
 186 (with-test (:name (cerror :condition-object-and-format-arguments))
 187   (let ((x 0))
 188     (handler-bind
 189         ((simple-error (lambda (c) (incf x) (continue c))))
 190       (cerror "Continue from ~A at ~A"
 191               (make-condition 'simple-error :format-control "foo"
 192                                             :format-arguments nil)
 193               'cerror (get-universal-time))
 194       (assert (= x 1)))))
 195
 196 ;; Test some of the variations permitted by the RESTART-CASE syntax.
 197 (with-test (:name (restart-case :smoke))
 198   (macrolet
 199       ((test (clause &optional (expected ''(:ok)) (args '(:ok)))
 200          `(assert (equal ,expected
 201                          (multiple-value-list
 202                           (restart-case
 203                               (handler-bind
 204                                   ((error (lambda (c)
 205                                             (invoke-restart ',(first clause) ,@args))))
 206                                 (error "foo"))
 207                             ,clause))))))
 208
 209     (test (foo (quux) quux))
 210     (test (foo (&optional quux) quux))
 211     ;; Multiple values should work.
 212     (test (foo (a b) (values a b)) '(1 2) (1 2))
 213     ;; Although somewhat unlikely, these should be legal and return
 214     ;; the respective keyword when the restart is invoked.
 215     (test (foo () :report) '(:report) ())
 216     (test (foo () :interactive) '(:interactive) ())
 217     (test (foo () :test) '(:test) ())
 218     ;; Declarations should work normally as part of the restart body.
 219     (test (foo (quux) :declare ()) '(nil))
 220     (test (foo () :declare () :report "quux") '("quux") ())))
 221
 222 (with-test (:name (restart-case :malformed-clauses))
 223   (macrolet
 224       ((test (clause &optional (expected clause))
 225          `(assert (eq :ok
 226                       (handler-case
 227                           (macroexpand
 228                            `(restart-case (error "foo") ,',clause))
 229                         (simple-error (e)
 230                           (assert (equal '(restart-case ,expected)
 231                                          (simple-condition-format-arguments e)))
 232                           :ok))))))
 233
 234     (test :report)                     ; not even a list
 235     (test ())                          ; empty
 236     (test (foo))                       ; no lambda-list
 237     (test (foo :report))               ; no lambda-list
 238     (test (foo :report "quux"))        ; no lambda-list
 239     (test (foo :report "quux" (quux))) ; confused report and lambda list
 240     ))
 241
 242 (with-test (:name :simple-condition-without-args)
 243   (let ((sc (make-condition 'simple-condition)))
 244     (assert (not (simple-condition-format-control sc)))
 245     (assert (not (simple-condition-format-arguments sc)))
 246     (assert (stringp (prin1-to-string sc)))
 247     (assert
 248      (eq :ok
 249          (handler-case
 250              (princ-to-string sc)
 251            (simple-error (c)
 252              (when (and (equal "No format-control for ~S"
 253                                (simple-condition-format-control c))
 254                         (eq sc (car
 255                                 (simple-condition-format-arguments c))))
 256                :ok)))))))
 257
 258 (with-test (:name :malformed-simple-condition-printing-type-error)
 259   (assert (eq :type-error
 260               (handler-case
 261                   (princ-to-string
 262                    (make-condition 'simple-error :format-control "" :format-arguments 8))
 263                 (type-error (e)
 264                   (when (and (eq 'list (type-error-expected-type e))
 265                              (eql 8 (type-error-datum e)))
 266                     :type-error))))))
 267
 268 (with-test (:name (:printing-unintitialized-condition :bug-1184586))
 269   (prin1-to-string (make-condition 'simple-type-error)))
 270
 271 (with-test (:name (:print-undefined-function-condition))
 272   (handler-case (funcall '#:foo)
 273     (undefined-function (c) (princ-to-string c))))
 274
 275 ;; Printing a READER-ERROR while the underlying stream is still open
 276 ;; should print the stream position information.
 277 (with-test (:name (reader-error :stream-error-position-info :open-stream :bug-1264902))
 278   (assert
 279    (search
 280     "Line: 1, Column: 22, File-Position: 22"
 281     (with-input-from-string (stream "no-such-package::symbol")
 282       (handler-case
 283           (read stream)
 284         (reader-error (condition) (princ-to-string condition)))))))
 285
 286 ;; Printing a READER-ERROR when the underlying stream has been closed
 287 ;; should still work, but the stream information will not be printed.
 288 (with-test (:name (reader-error :stream-error-position-info :closed-stream :bug-1264902))
 289   (assert
 290    (search
 291     "Package NO-SUCH-PACKAGE does not exist"
 292     (handler-case
 293         (with-input-from-string (stream "no-such-package::symbol")
 294           (read stream))
 295       (reader-error (condition) (princ-to-string condition))))))
 296
 297 (with-test (:name (make-condition :non-condition-class))
 298   (handler-case
 299       (make-condition 'standard-class)
 300     (type-error (condition)
 301       (assert (search "not a condition class"
 302                       (princ-to-string condition))))))
 303
 304 ;; When called with a symbol not designating a condition class,
 305 ;; MAKE-CONDITION used to signal an error which printed as "NIL does
 306 ;; not designate a condition class.".
 307 (with-test (:name (make-condition :correct-error-for-undefined-condition
 308                    :bug-1199223))
 309   (handler-case
 310       (make-condition 'no-such-condition)
 311     (type-error (condition)
 312       (assert (search (string 'no-such-condition)
 313                       (princ-to-string condition))))))
 314
 315 ;; Using an undefined condition type in a HANDLER-BIND clause should
 316 ;; signal an ERROR at runtime. Bug 1378939 was about landing in LDB
 317 ;; because of infinite recursion in SIGNAL instead.
 318 ;;
 319 ;; We suppress the compile-time WARNING to avoid noise when running
 320 ;; tests.
 321 (locally (declare (muffle-conditions warning))
 322   (with-test (:name (handler-bind :undefined-condition-type
 323                      :bug-1378939))
 324     (assert-error
 325      (handler-bind ((no-such-condition-class #'print))
 326        (error "does not matter")))))
 327
 328 ;; Using an undefined condition type in a HANDLER-BIND clause should
 329 ;; signal a [STYLE-]WARNING at compile time.
 330 (with-test (:name (handler-bind :undefined-condition-type
 331                    :compile-time-warning))
 332   (handler-bind ((warning #'muffle-warning))
 333     (assert-signal
 334      (compile nil '(lambda () (handler-bind
 335                                   ((no-such-condition-class #'print)))))
 336      warning)))
 337
 338 ;; Empty bindings in HANDLER-BIND pushed an empty cluster onto
 339 ;; *HANDLER-CLUSTERS* which was not expected by SIGNAL (and wasteful).
 340 (with-test (:name (handler-bind :empty-bindings :bug-1388707))
 341   (multiple-value-bind (value condition)
 342       (ignore-errors (handler-bind () (error "Foo")))
 343     (assert (null value))
 344     (assert (typep condition 'simple-error))))