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 ;;; Until 0.7.7.21, (MAKE-CONDITION 'FILE-ERROR :PATHNAME "FOO")
  15 ;;; wasn't printable, because the REPORT function for FILE-ERROR
  16 ;;; referred to unbound slots. This was reported and fixed by Antonio
  17 ;;; Martinez (sbcl-devel 2002-09-10).
  18 (format t
  19         "~&printable now: ~A~%"
  20         (make-condition 'file-error :pathname "foo"))
  21
  22 (assert (eq
  23          (block nil
  24            (macrolet ((opaque-error (arg) `(error ,arg)))
  25              (handler-bind
  26                  ((error (lambda (c)
  27                            (let ((restarts (remove 'res (compute-restarts c)
  28                                                    :key #'restart-name
  29                                                    :test-not #'eql)))
  30                              (assert (= (length restarts) 2))
  31                              (invoke-restart (second restarts))))))
  32                (let ((foo1 (make-condition 'error))
  33                      (foo2 (make-condition 'error)))
  34                  (restart-case
  35                      (with-condition-restarts foo1 (list (find-restart 'res))
  36                        (restart-case
  37                            (opaque-error foo2)
  38                          (res () 'int1)
  39                          (res () 'int2)))
  40                    (res () 'ext))))))
  41          'int2))
  42
  43 (assert (eq
  44          (block nil
  45            (macrolet ((opaque-error (arg) `(error ,arg)))
  46              (let ((foo1 (make-condition 'error))
  47                    (foo2 (make-condition 'error)))
  48                (handler-bind
  49                    ((error (lambda (c)
  50                              (declare (ignore c))
  51                              (let ((restarts (remove 'res (compute-restarts foo1)
  52                                                      :key #'restart-name
  53                                                      :test-not #'eql)))
  54                                (assert (= (length restarts) 1))
  55                                (invoke-restart (first restarts))))))
  56                  (restart-case
  57                      (with-condition-restarts foo1 (list (find-restart 'res))
  58                        (restart-case
  59                            (opaque-error foo2)
  60                          (res () 'int1)
  61                          (res () 'int2)))
  62                    (res () 'ext))))))
  63          'ext))
  64
  65 (assert (eq
  66          'ext
  67          (block nil
  68            (let ((visible nil)
  69                  (c1 (make-condition 'error))
  70                  (c2 (make-condition 'error)))
  71              (handler-bind
  72                  ((error
  73                    (lambda (c)
  74                      (declare (ignore c))
  75                      (flet ((check-restarts (length)
  76                               (assert (= length
  77                                          (length (remove 'foo (compute-restarts c1)
  78                                                          :key #'restart-name
  79                                                          :test-not #'eql))))))
  80                        (check-restarts 1)
  81                        (setq visible t)
  82                        (check-restarts 1)
  83                        (invoke-restart (find-restart 'foo c1))))))
  84                (restart-case
  85                    (restart-case
  86                        (error c2)
  87                      (foo () 'in1)
  88                      (foo () :test (lambda (c) (declare (ignore c)) visible)
  89                           'in2))
  90                  (foo () 'ext)))))))
  91
  92 ;;; First argument of CERROR is a format control
  93 (assert
  94  (eq (block nil
  95        (handler-bind
  96            ((type-error (lambda (c)
  97                           (declare (ignore c))
  98                           (return :failed)))
  99             (simple-error (lambda (c)
 100                             (declare (ignore c))
 101                             (return (if (find-restart 'continue)
 102                                         :passed
 103                                         :failed)))))
 104          (cerror (formatter "Continue from ~A") "bug ~A" :bug)))
 105      :passed))
 106
 107 (with-test (:name :disallow-bogus-coerce-to-condition)
 108   ;; COERCE-TO-CONDITION has an ftype which precludes passing junk
 109   ;; if caught at compile-time.
 110   ;; A non-constant non-condition-designator was able to sneak through.
 111   (multiple-value-bind (c err)
 112       (ignore-errors (sb-kernel::coerce-to-condition
 113                       (opaque-identity #p"foo")
 114                       'condition 'feep))
 115     (declare (ignore c))
 116     (assert (search "does not designate a condition"
 117                     (write-to-string err :escape nil)))))
 118
 119 (with-test (:name (handler-bind :smoke))
 120   (let ((called?))
 121     (flet ((handler (condition)
 122              (declare (ignore condition))
 123              (setf called? t)))
 124       (macrolet ((test (handler)
 125                    `(progn
 126                       (setf called? nil)
 127                       (handler-bind ((condition ,handler))
 128                         (signal 'condition))
 129                       (assert called?))))
 130         ;; Test optimized special cases.
 131         (test (lambda (condition) (handler condition)))
 132         (test #'(lambda (condition) (handler condition)))
 133         ;; Test default behavior.
 134         ;; (test 'handler) would require function definition => not pure
 135         (test #'handler)))))
 136
 137 (with-test (:name (handler-bind :malformed-bindings))
 138   (flet ((test (binding)
 139            (assert (eq :ok
 140                        (handler-case
 141                            (macroexpand `(handler-bind (,binding)))
 142                          (simple-error (e)
 143                            (assert (equal (list binding)
 144                                           (simple-condition-format-arguments e)))
 145                            :ok))))))
 146
 147     (test 1)                     ; not even a list
 148     (test '())                   ; missing condition type and handler
 149     (test '(error))              ; missing handler
 150     (test '(error #'print :foo)) ; too many elements
 151     ))
 152
 153 ;;; clauses in HANDLER-CASE are allowed to have declarations (and
 154 ;;; indeed, only declarations)
 155 (with-test (:name (handler-case declare))
 156   (assert (null (handler-case (error "foo")
 157                   (error ()
 158                     (declare (optimize speed)))))))
 159
 160 (with-test (:name (signal warning muffle-warning control-error))
 161   (handler-case
 162       (handler-bind ((warning #'muffle-warning))
 163         (signal 'warning))
 164     ;; if it's a control error, it had better be printable
 165     (control-error (c) (format nil "~A" c))
 166     ;; there had better be an error
 167     (:no-error (&rest args) (error "No error: ~S" args))))
 168
 169 (with-test (:name (check-type type-error))
 170   (handler-case
 171       (funcall (lambda (x) (check-type x fixnum) x) t)
 172     (type-error (c)
 173       (assert (and (subtypep (type-error-expected-type c) 'fixnum)
 174                    (subtypep 'fixnum (type-error-expected-type c))))
 175       (assert (eq (type-error-datum c) t)))
 176     (:no-error (&rest rest) (error "no error: ~S" rest))))
 177
 178 ;;; ANSI specifies TYPE-ERROR if datum and arguments of ERROR are not
 179 ;;; designators for a condition. Reported by Bruno Haible on cmucl-imp
 180 ;;; 2004-10-12.
 181 (with-test (:name (error :invalid-arguments type-error))
 182   (flet ((test (&rest args)
 183            (multiple-value-bind (res err)
 184                (ignore-errors (apply #'error args))
 185              (assert (not res))
 186              (assert (typep err 'type-error))
 187              (assert-no-signal (type-error-datum err))
 188              (assert-no-signal (type-error-expected-type err)))))
 189     (test '#:no-such-condition)
 190     (test nil)
 191     (test t)
 192     (test 42)
 193     (test (make-instance 'standard-object))))
 194
 195 ;;; If CERROR is given a condition, any remaining arguments are only
 196 ;;; used for the continue format control.
 197 (with-test (:name (cerror :condition-object-and-format-arguments))
 198   (let ((x 0))
 199     (handler-bind
 200         ((simple-error (lambda (c) (incf x) (continue c))))
 201       (cerror "Continue from ~A at ~A"
 202               (make-condition 'simple-error :format-control "foo"
 203                                             :format-arguments nil)
 204               'cerror (get-universal-time))
 205       (assert (= x 1)))))
 206
 207 ;; Test some of the variations permitted by the RESTART-CASE syntax.
 208 (with-test (:name (restart-case :smoke))
 209   (macrolet
 210       ((test (clause &optional (expected ''(:ok)) (args '(:ok)))
 211          `(assert (equal ,expected
 212                          (multiple-value-list
 213                           (restart-case
 214                               (handler-bind
 215                                   ((error (lambda (c)
 216                                             (declare (ignore c))
 217                                             (invoke-restart ',(first clause) ,@args))))
 218                                 (error "foo"))
 219                             ,clause))))))
 220
 221     (test (foo (quux) quux))
 222     (test (foo (&optional quux) quux))
 223     ;; Multiple values should work.
 224     (test (foo (a b) (values a b)) '(1 2) (1 2))
 225     ;; Although somewhat unlikely, these should be legal and return
 226     ;; the respective keyword when the restart is invoked.
 227     (test (foo () :report) '(:report) ())
 228     (test (foo () :interactive) '(:interactive) ())
 229     (test (foo () :test) '(:test) ())
 230     ;; Declarations should work normally as part of the restart body.
 231     (test (foo () :declare ()) '(nil) ())
 232     (test (foo () :declare () :report "quux") '("quux") ())))
 233
 234 (with-test (:name (restart-case :malformed-clauses))
 235   (macrolet
 236       ((test (clause &optional (expected clause))
 237          `(assert (eq :ok
 238                       (handler-case
 239                           (macroexpand
 240                            `(restart-case (error "foo") ,',clause))
 241                         (simple-error (e)
 242                           (assert (equal '(restart-case ,expected)
 243                                          (simple-condition-format-arguments e)))
 244                           :ok))))))
 245
 246     (test :report)                     ; not even a list
 247     (test ())                          ; empty
 248     (test (foo))                       ; no lambda-list
 249     (test (foo :report))               ; no lambda-list
 250     (test (foo :report "quux"))        ; no lambda-list
 251     (test (foo :report "quux" (quux))) ; confused report and lambda list
 252     ))
 253
 254 (with-test (:name :simple-condition-without-args)
 255   (let ((sc (make-condition 'simple-condition)))
 256     (assert (not (simple-condition-format-control sc)))
 257     (assert (not (simple-condition-format-arguments sc)))
 258     (assert (stringp (prin1-to-string sc)))
 259     (assert
 260      (eq :ok
 261          (handler-case
 262              (princ-to-string sc)
 263            (simple-error (c)
 264              (when (and (equal "No format-control for ~S"
 265                                (simple-condition-format-control c))
 266                         (eq sc (car
 267                                 (simple-condition-format-arguments c))))
 268                :ok)))))))
 269
 270 (with-test (:name :malformed-simple-condition-printing-type-error)
 271   (assert (eq :type-error
 272               (handler-case
 273                   (princ-to-string
 274                    (make-condition 'simple-error :format-control "" :format-arguments 8))
 275                 (type-error (e)
 276                   (when (and (eq 'list (type-error-expected-type e))
 277                              (eql 8 (type-error-datum e)))
 278                     :type-error))))))
 279
 280 (with-test (:name (:printing-unintitialized-condition :bug-1184586))
 281   (prin1-to-string (make-condition 'simple-type-error)))
 282
 283 (with-test (:name (:print-undefined-function-condition)
 284             :fails-on :ppc64)
 285   (handler-case (funcall '#:foo)
 286     (undefined-function (c) (princ-to-string c))))
 287
 288 ;; Printing a READER-ERROR while the underlying stream is still open
 289 ;; should print the stream position information.
 290 (with-test (:name (reader-error :stream-error-position-info :open-stream
 291                                 :bug-1264902))
 292   (locally
 293    ;; High debug avoids stack-allocating the stream.
 294    ;; It would be fine to stack-allocate it, because the handler-case does not
 295    ;; use the stream outside of its extent, however, because ALLOCATE-CONDITION
 296    ;; doesn't know when you will use the stream, it always replaces a DX stream
 297    ;; with a dummy. The dummy stream would not have position information.
 298    (declare (optimize debug))
 299    (assert
 300     (search
 301     "Line: 1, Column: 22, File-Position: 22"
 302     (with-input-from-string (stream "no-such-package::symbol")
 303       (handler-case
 304           (read stream)
 305         (reader-error (condition) (princ-to-string condition))))))))
 306
 307 ;; Printing a READER-ERROR when the underlying stream has been closed
 308 ;; should still work, but the stream information will not be printed.
 309 (with-test (:name (reader-error :stream-error-position-info :closed-stream
 310                                 :bug-1264902))
 311   ;; This test operates on a closed stream that has dynamic extent (theoretically).
 312   ;; SAFETY 3 prevents a memory fault by not actually stack-allocating it.
 313   (declare (optimize (safety 3)))
 314   (assert
 315    (search
 316     "Package NO-SUCH-PACKAGE does not exist"
 317     (handler-case
 318         (with-input-from-string (stream "no-such-package::symbol")
 319           (read stream))
 320       (reader-error (condition) (princ-to-string condition))))))
 321
 322 (with-test (:name (make-condition :non-condition-class))
 323   (assert (search "does not designate a condition class"
 324                   (handler-case
 325                       (make-condition 'standard-class)
 326                     (type-error (condition)
 327                       (princ-to-string condition))))))
 328
 329 ;; When called with a symbol not designating a condition class,
 330 ;; MAKE-CONDITION used to signal an error which printed as "NIL does
 331 ;; not designate a condition class.".
 332 (with-test (:name (make-condition :correct-error-for-undefined-condition
 333                                   :bug-1199223))
 334   (assert (search (string 'no-such-condition)
 335                   (handler-case
 336                       (make-condition 'no-such-condition)
 337                     (type-error (condition)
 338                       (princ-to-string condition))))))
 339
 340 ;; Using an undefined condition type in a HANDLER-BIND clause should
 341 ;; signal an ERROR at runtime. Bug 1378939 was about landing in LDB
 342 ;; because of infinite recursion in SIGNAL instead.
 343 (with-test (:name (handler-bind :undefined-condition-type
 344                    :bug-1378939))
 345   (multiple-value-bind (fun failure-p warnings style-warnings)
 346       (checked-compile '(lambda ()
 347                          (handler-bind ((no-such-condition-class #'print))
 348                            (error "does not matter")))
 349                        :allow-style-warnings t)
 350     (declare (ignore failure-p warnings))
 351     (assert (= (length style-warnings) 1))
 352     (assert-error (funcall fun) simple-error)))
 353
 354 ;; Using an undefined condition type in a HANDLER-BIND clause should
 355 ;; signal a [STYLE-]WARNING at compile time.
 356 (with-test (:name (handler-bind :undefined-condition-type
 357                    :compile-time-warning))
 358   (multiple-value-bind (fun failure-p warnings style-warnings)
 359       (checked-compile '(lambda ()
 360                          (handler-bind ((no-such-condition-class #'print))))
 361                        :allow-style-warnings t)
 362     (declare (ignore fun failure-p warnings))
 363     (assert (= (length style-warnings) 1))))
 364
 365 ;; Empty bindings in HANDLER-BIND pushed an empty cluster onto
 366 ;; *HANDLER-CLUSTERS* which was not expected by SIGNAL (and wasteful).
 367 (with-test (:name (handler-bind :empty-bindings :bug-1388707))
 368   (assert-error (handler-bind () (error "Foo")) simple-error))
 369
 370 ;; Parsing of #'FUNCTION in %HANDLER-BIND was too liberal.
 371 ;; This code should not compile.
 372 (with-test (:name (handler-bind :no-sloppy-semantics))
 373   (multiple-value-bind (fun failure-p)
 374       (checked-compile '(lambda (x)
 375                          (sb-kernel::%handler-bind
 376                           ((condition (function (lambda (c) (print c)) garb)))
 377                           (print x)))
 378                        :allow-failure t)
 379     (declare (ignore fun))
 380     (assert failure-p))
 381
 382   (multiple-value-bind (fun failure-p)
 383       (checked-compile '(lambda (x)
 384                          (handler-bind ((warning "woot")) (print x)))
 385                        :allow-failure t :allow-warnings t)
 386     (declare (ignore fun))
 387     (assert failure-p)))
 388
 389 (with-test (:name (handler-bind satisfies :predicate style-warning))
 390   (multiple-value-bind (fun failure-p warnings style-warnings)
 391       (checked-compile
 392        '(lambda ()
 393          ;; Just in case we ever change the meaning of #'F in high
 394          ;; safety so that it evals #'F, this test will break,
 395          ;; indicating that HANDLER-BIND will have to be changed.
 396          (declare (optimize (safety 3)))
 397          (declare (notinline +))
 398          (handler-bind (((satisfies snorky) #'abort)) (+ 2 2)))
 399        :allow-style-warnings t)
 400     (declare (ignore failure-p warnings))
 401     (assert (= (length style-warnings) 1))
 402     (assert (= (funcall fun) 4)))) ; there is no runtime error either
 403
 404 (with-test (:name :with-condition-restarts-evaluation-order)
 405   (let (result)
 406     (with-condition-restarts (progn
 407                                (push 1 result)
 408                                (make-condition 'error))
 409         (progn (push 2 result) nil)
 410       (push 3 result))
 411     (assert (equal result '(3 2 1)))))
 412
 413 (with-test (:name (type-error print *print-pretty*))
 414   (let ((error (make-condition 'type-error :datum 1 :expected-type 'string)))
 415     (assert (string= (let ((*print-pretty* nil))
 416                        (princ-to-string error))
 417                      "The value 1 is not of type STRING"))
 418     (assert (string= (let ((*print-pretty* t))
 419                        (princ-to-string error))
 420                      "The value
 421   1
 422 is not of type
 423   STRING"))))
 424
 425 ;;; Instances of LAYOUT for condition classoids created by genesis
 426 ;;; should resemble ones created normally. Due to a bug, they did not.
 427 ;;; (The LENGTH slot had the wrong value)
 428 (with-test (:name :condition-layout-lengths)
 429   (loop for layout being each hash-value of (sb-kernel:classoid-subclasses
 430                                               (sb-kernel:find-classoid 'condition))
 431         for len = (sb-kernel:layout-length layout)
 432         minimize len into min
 433         maximize len into max
 434         finally (assert (= min max))))
 435
 436 (with-test (:name :allocate-condition-odd-length-keys)
 437   (multiple-value-bind (newcond error)
 438       (ignore-errors (make-condition 'warning :a 1 :b))
 439     (declare (ignore newcond))
 440     (assert (string= (write-to-string error :escape nil)
 441                      "odd-length initializer list: (:A 1 :B)."))))
 442
 443 (with-test (:name :type-error-on-dx-object
 444             :skipped-on :interpreter)
 445   (handler-case
 446     (sb-int:dx-let ((a (make-array 3)))
 447       (setf (aref a 0) a)
 448       (print (1+ (aref a 0))))
 449     (error (e)
 450       (assert (equal (sb-kernel:type-error-datum-stored-type e)
 451                      '(simple-vector 3))))))
 452
 453 (with-test (:name (:handler-bind-evaluation-count :lp1916302))
 454   (let (list)
 455     (handler-bind ((condition (let ((x 0))
 456                                 (lambda (c)
 457                                   (declare (ignore c))
 458                                   (push (incf x) list)))))
 459       (signal 'condition)
 460       (signal 'condition))
 461     (assert (equalp '(2 1) list))))
 462
 463 (with-test (:name (:handler-bind-evaluation-count :separate-establishment))
 464   (let (list)
 465     (dotimes (i 2)
 466       (handler-bind ((condition (let ((x 0))
 467                                   (lambda (c)
 468                                     (declare (ignore c))
 469                                     (push (incf x) list)))))
 470         (signal 'condition)))
 471     (assert (equalp '(1 1) list))))