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 (with-test (:name (handler-case declare))
 148   (assert (null (handler-case (error "foo")
 149                   (error ()
 150                     (declare (optimize speed)))))))
 151
 152 (with-test (:name (signal warning muffle-warning control-error))
 153   (handler-case
 154       (handler-bind ((warning #'muffle-warning))
 155         (signal 'warning))
 156     ;; if it's a control error, it had better be printable
 157     (control-error (c) (format nil "~A" c))
 158     ;; there had better be an error
 159     (:no-error (&rest args) (error "No error: ~S" args))))
 160
 161 (with-test (:name (check-type type-error))
 162   (handler-case
 163       (funcall (lambda (x) (check-type x fixnum) x) t)
 164     (type-error (c)
 165       (assert (and (subtypep (type-error-expected-type c) 'fixnum)
 166                    (subtypep 'fixnum (type-error-expected-type c))))
 167       (assert (eq (type-error-datum c) t)))
 168     (:no-error (&rest rest) (error "no error: ~S" rest))))
 169
 170 ;;; ANSI specifies TYPE-ERROR if datum and arguments of ERROR are not
 171 ;;; designators for a condition. Reported by Bruno Haible on cmucl-imp
 172 ;;; 2004-10-12.
 173 (with-test (:name (error :invalid-arguments type-error))
 174   (flet ((test (&rest args)
 175            (multiple-value-bind (res err)
 176                (ignore-errors (apply #'error args))
 177              (assert (not res))
 178              (assert (typep err 'type-error))
 179              (assert-no-signal (type-error-datum err))
 180              (assert-no-signal (type-error-expected-type err)))))
 181     (test '#:no-such-condition)
 182     (test nil)
 183     (test t)
 184     (test 42)
 185     (test (make-instance 'standard-object))))
 186
 187 ;;; If CERROR is given a condition, any remaining arguments are only
 188 ;;; used for the continue format control.
 189 (with-test (:name (cerror :condition-object-and-format-arguments))
 190   (let ((x 0))
 191     (handler-bind
 192         ((simple-error (lambda (c) (incf x) (continue c))))
 193       (cerror "Continue from ~A at ~A"
 194               (make-condition 'simple-error :format-control "foo"
 195                                             :format-arguments nil)
 196               'cerror (get-universal-time))
 197       (assert (= x 1)))))
 198
 199 ;; Test some of the variations permitted by the RESTART-CASE syntax.
 200 (with-test (:name (restart-case :smoke))
 201   (macrolet
 202       ((test (clause &optional (expected ''(:ok)) (args '(:ok)))
 203          `(assert (equal ,expected
 204                          (multiple-value-list
 205                           (restart-case
 206                               (handler-bind
 207                                   ((error (lambda (c)
 208                                             (declare (ignore c))
 209                                             (invoke-restart ',(first clause) ,@args))))
 210                                 (error "foo"))
 211                             ,clause))))))
 212
 213     (test (foo (quux) quux))
 214     (test (foo (&optional quux) quux))
 215     ;; Multiple values should work.
 216     (test (foo (a b) (values a b)) '(1 2) (1 2))
 217     ;; Although somewhat unlikely, these should be legal and return
 218     ;; the respective keyword when the restart is invoked.
 219     (test (foo () :report) '(:report) ())
 220     (test (foo () :interactive) '(:interactive) ())
 221     (test (foo () :test) '(:test) ())
 222     ;; Declarations should work normally as part of the restart body.
 223     (test (foo (quux) :declare ()) '(nil))
 224     (test (foo () :declare () :report "quux") '("quux") ())))
 225
 226 (with-test (:name (restart-case :malformed-clauses))
 227   (macrolet
 228       ((test (clause &optional (expected clause))
 229          `(assert (eq :ok
 230                       (handler-case
 231                           (macroexpand
 232                            `(restart-case (error "foo") ,',clause))
 233                         (simple-error (e)
 234                           (assert (equal '(restart-case ,expected)
 235                                          (simple-condition-format-arguments e)))
 236                           :ok))))))
 237
 238     (test :report)                     ; not even a list
 239     (test ())                          ; empty
 240     (test (foo))                       ; no lambda-list
 241     (test (foo :report))               ; no lambda-list
 242     (test (foo :report "quux"))        ; no lambda-list
 243     (test (foo :report "quux" (quux))) ; confused report and lambda list
 244     ))
 245
 246 (with-test (:name :simple-condition-without-args)
 247   (let ((sc (make-condition 'simple-condition)))
 248     (assert (not (simple-condition-format-control sc)))
 249     (assert (not (simple-condition-format-arguments sc)))
 250     (assert (stringp (prin1-to-string sc)))
 251     (assert
 252      (eq :ok
 253          (handler-case
 254              (princ-to-string sc)
 255            (simple-error (c)
 256              (when (and (equal "No format-control for ~S"
 257                                (simple-condition-format-control c))
 258                         (eq sc (car
 259                                 (simple-condition-format-arguments c))))
 260                :ok)))))))
 261
 262 (with-test (:name :malformed-simple-condition-printing-type-error)
 263   (assert (eq :type-error
 264               (handler-case
 265                   (princ-to-string
 266                    (make-condition 'simple-error :format-control "" :format-arguments 8))
 267                 (type-error (e)
 268                   (when (and (eq 'list (type-error-expected-type e))
 269                              (eql 8 (type-error-datum e)))
 270                     :type-error))))))
 271
 272 (with-test (:name (:printing-unintitialized-condition :bug-1184586))
 273   (prin1-to-string (make-condition 'simple-type-error)))
 274
 275 (with-test (:name (:print-undefined-function-condition))
 276   (handler-case (funcall '#:foo)
 277     (undefined-function (c) (princ-to-string c))))
 278
 279 ;; Printing a READER-ERROR while the underlying stream is still open
 280 ;; should print the stream position information.
 281 (with-test (:name (reader-error :stream-error-position-info :open-stream
 282                                 :bug-1264902))
 283   (assert
 284    (search
 285     "Line: 1, Column: 22, File-Position: 22"
 286     (with-input-from-string (stream "no-such-package::symbol")
 287       (handler-case
 288           (read stream)
 289         (reader-error (condition) (princ-to-string condition)))))))
 290
 291 ;; Printing a READER-ERROR when the underlying stream has been closed
 292 ;; should still work, but the stream information will not be printed.
 293 (with-test (:name (reader-error :stream-error-position-info :closed-stream
 294                                 :bug-1264902))
 295   (assert
 296    (search
 297     "Package NO-SUCH-PACKAGE does not exist"
 298     (handler-case
 299         (with-input-from-string (stream "no-such-package::symbol")
 300           (read stream))
 301       (reader-error (condition) (princ-to-string condition))))))
 302
 303 (with-test (:name (make-condition :non-condition-class))
 304   (assert (search "does not designate a condition class"
 305                   (handler-case
 306                       (make-condition 'standard-class)
 307                     (type-error (condition)
 308                       (princ-to-string condition))))))
 309
 310 ;; When called with a symbol not designating a condition class,
 311 ;; MAKE-CONDITION used to signal an error which printed as "NIL does
 312 ;; not designate a condition class.".
 313 (with-test (:name (make-condition :correct-error-for-undefined-condition
 314                                   :bug-1199223))
 315   (assert (search (string 'no-such-condition)
 316                   (handler-case
 317                       (make-condition 'no-such-condition)
 318                     (type-error (condition)
 319                       (princ-to-string condition))))))
 320
 321 ;; Using an undefined condition type in a HANDLER-BIND clause should
 322 ;; signal an ERROR at runtime. Bug 1378939 was about landing in LDB
 323 ;; because of infinite recursion in SIGNAL instead.
 324 ;;
 325 ;; We suppress the compile-time WARNING to avoid noise when running
 326 ;; tests.
 327 (locally (declare (muffle-conditions warning))
 328   (with-test (:name (handler-bind :undefined-condition-type
 329                      :bug-1378939))
 330     (assert-error
 331      (handler-bind ((no-such-condition-class #'print))
 332        (error "does not matter"))
 333      simple-error)))
 334
 335 ;; Using an undefined condition type in a HANDLER-BIND clause should
 336 ;; signal a [STYLE-]WARNING at compile time.
 337 (with-test (:name (handler-bind :undefined-condition-type
 338                    :compile-time-warning))
 339   (assert-signal
 340    (compile nil '(lambda () (handler-bind
 341                                 ((no-such-condition-class #'print)))))
 342    warning))
 343
 344 ;; Empty bindings in HANDLER-BIND pushed an empty cluster onto
 345 ;; *HANDLER-CLUSTERS* which was not expected by SIGNAL (and wasteful).
 346 (with-test (:name (handler-bind :empty-bindings :bug-1388707))
 347   (assert-error (handler-bind () (error "Foo")) simple-error))
 348
 349 ;; Parsing of #'FUNCTION in %HANDLER-BIND was too liberal.
 350 ;; This code should not compile.
 351 (with-test (:name (handler-bind :no-sloppy-semantics))
 352   (assert
 353    (nth-value 2 ; errorp
 354     (let ((*error-output* (make-broadcast-stream)))
 355       (compile nil '(lambda (x)
 356                       (sb-impl::%handler-bind
 357                          ((condition (function (lambda (c) (print c)) garb)))
 358                        (print x)))))))
 359   (assert
 360    (nth-value 2 ; errorp
 361     (let ((*error-output* (make-broadcast-stream)))
 362       (compile nil '(lambda (x)
 363                       (handler-bind ((warning "woot")) (print x))))))))
 364
 365 (with-test (:name :handler-bind-satisfies-pred-style-warn)
 366   (multiple-value-bind (f warnp errorp)
 367       (let ((*error-output* (make-broadcast-stream)))
 368         (compile nil
 369                  '(lambda ()
 370                     ;; Just in case we ever change the meaning of #'F in
 371                     ;; high safety so that it evals #'F, this test will break,
 372                     ;; indicating that HANDLER-BIND will have to be changed.
 373                     (declare (optimize (safety 3)))
 374                     (declare (notinline +))
 375                     (handler-bind (((satisfies snorky) #'abort)) (+ 2 2)))))
 376     (assert (and f warnp (not errorp)))
 377     (assert (= (funcall f) 4)))) ; there is no runtime error either
 378
 379 (with-test (:name :with-condition-restarts-evaluation-order)
 380   (let (result)
 381     (with-condition-restarts (progn
 382                                (push 1 result)
 383                                (make-condition 'error))
 384         (progn (push 2 result) nil)
 385       (push 3 result))
 386     (assert (equal result '(3 2 1)))))