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 (with-test (:name (handler-bind :undefined-condition-type
 325                    :bug-1378939))
 326   (multiple-value-bind (fun failure-p warnings style-warnings)
 327       (checked-compile '(lambda ()
 328                          (handler-bind ((no-such-condition-class #'print))
 329                            (error "does not matter")))
 330                        :allow-style-warnings t)
 331     (declare (ignore failure-p warnings))
 332     (assert (= (length style-warnings) 1))
 333     (assert-error (funcall fun) 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   (multiple-value-bind (fun failure-p warnings style-warnings)
 340       (checked-compile '(lambda ()
 341                          (handler-bind ((no-such-condition-class #'print))))
 342                        :allow-style-warnings t)
 343     (declare (ignore fun failure-p warnings))
 344     (assert (= (length style-warnings) 1))))
 345
 346 ;; Empty bindings in HANDLER-BIND pushed an empty cluster onto
 347 ;; *HANDLER-CLUSTERS* which was not expected by SIGNAL (and wasteful).
 348 (with-test (:name (handler-bind :empty-bindings :bug-1388707))
 349   (assert-error (handler-bind () (error "Foo")) simple-error))
 350
 351 ;; Parsing of #'FUNCTION in %HANDLER-BIND was too liberal.
 352 ;; This code should not compile.
 353 (with-test (:name (handler-bind :no-sloppy-semantics))
 354   (multiple-value-bind (fun failure-p)
 355       (checked-compile '(lambda (x)
 356                          (sb-impl::%handler-bind
 357                           ((condition (function (lambda (c) (print c)) garb)))
 358                           (print x)))
 359                        :allow-failure t)
 360     (declare (ignore fun))
 361     (assert failure-p))
 362
 363   (multiple-value-bind (fun failure-p)
 364       (checked-compile '(lambda (x)
 365                          (handler-bind ((warning "woot")) (print x)))
 366                        :allow-failure t :allow-warnings t)
 367     (declare (ignore fun))
 368     (assert failure-p)))
 369
 370 (with-test (:name (handler-bind satisfies :predicate style-warning))
 371   (multiple-value-bind (fun failure-p warnings style-warnings)
 372       (checked-compile
 373        '(lambda ()
 374          ;; Just in case we ever change the meaning of #'F in high
 375          ;; safety so that it evals #'F, this test will break,
 376          ;; indicating that HANDLER-BIND will have to be changed.
 377          (declare (optimize (safety 3)))
 378          (declare (notinline +))
 379          (handler-bind (((satisfies snorky) #'abort)) (+ 2 2)))
 380        :allow-style-warnings t)
 381     (declare (ignore failure-p warnings))
 382     (assert (= (length style-warnings) 1))
 383     (assert (= (funcall fun) 4)))) ; there is no runtime error either
 384
 385 (with-test (:name :with-condition-restarts-evaluation-order)
 386   (let (result)
 387     (with-condition-restarts (progn
 388                                (push 1 result)
 389                                (make-condition 'error))
 390         (progn (push 2 result) nil)
 391       (push 3 result))
 392     (assert (equal result '(3 2 1)))))
 393
 394 (with-test (:name (type-error print *print-pretty*))
 395   (let ((error (make-condition 'type-error :datum 1 :expected-type 'string)))
 396     (assert (string= (let ((*print-pretty* nil))
 397                        (princ-to-string error))
 398                      "The value 1 is not of type STRING"))
 399     (assert (string= (let ((*print-pretty* t))
 400                        (princ-to-string error))
 401                      "The value
 402   1
 403 is not of type
 404   STRING"))))
 405
 406 ;;; Instances of LAYOUT for condition classoids created by genesis
 407 ;;; should resemble ones created normally. Due to a bug, they did not.
 408 (with-test (:name :condition-layout-lengths)
 409   (loop for layout being each hash-value of (sb-kernel:classoid-subclasses
 410                                              (sb-kernel:find-classoid 'condition))
 411         for len = (sb-kernel:layout-length layout)
 412         minimize len into min
 413         maximize len into max
 414         finally (assert (= min max))))