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 ;;; Until 0.7.7.21, (MAKE-CONDITION 'FILE-ERROR :PATHNAME "FOO")
  17 ;;; wasn't printable, because the REPORT function for FILE-ERROR
  18 ;;; referred to unbound slots. This was reported and fixed by Antonio
  19 ;;; Martinez (sbcl-devel 2002-09-10).
  20 (format t
  21         "~&printable now: ~A~%"
  22         (make-condition 'file-error :pathname "foo"))
  23
  24 (assert (eq
  25          (block nil
  26            (macrolet ((opaque-error (arg) `(error ,arg)))
  27              (handler-bind
  28                  ((error (lambda (c)
  29                            (let ((restarts (remove 'res (compute-restarts c)
  30                                                    :key #'restart-name
  31                                                    :test-not #'eql)))
  32                              (assert (= (length restarts) 2))
  33                              (invoke-restart (second restarts))))))
  34                (let ((foo1 (make-condition 'error))
  35                      (foo2 (make-condition 'error)))
  36                  (restart-case
  37                      (with-condition-restarts foo1 (list (find-restart 'res))
  38                        (restart-case
  39                            (opaque-error foo2)
  40                          (res () 'int1)
  41                          (res () 'int2)))
  42                    (res () 'ext))))))
  43          'int2))
  44
  45 (assert (eq
  46          (block nil
  47            (macrolet ((opaque-error (arg) `(error ,arg)))
  48              (let ((foo1 (make-condition 'error))
  49                    (foo2 (make-condition 'error)))
  50                (handler-bind
  51                    ((error (lambda (c)
  52                              (let ((restarts (remove 'res (compute-restarts foo1)
  53                                                      :key #'restart-name
  54                                                      :test-not #'eql)))
  55                                (assert (= (length restarts) 1))
  56                                (invoke-restart (first restarts))))))
  57                  (restart-case
  58                      (with-condition-restarts foo1 (list (find-restart 'res))
  59                        (restart-case
  60                            (opaque-error foo2)
  61                          (res () 'int1)
  62                          (res () 'int2)))
  63                    (res () 'ext))))))
  64          'ext))
  65
  66 (assert (eq
  67          'ext
  68          (block nil
  69            (let ((visible nil)
  70                  (c1 (make-condition 'error))
  71                  (c2 (make-condition 'error)))
  72              (handler-bind
  73                  ((error
  74                    (lambda (c)
  75                      (declare (ignore c))
  76                      (flet ((check-restarts (length)
  77                               (assert (= length
  78                                          (length (remove 'foo (compute-restarts c1)
  79                                                          :key #'restart-name
  80                                                          :test-not #'eql))))))
  81                        (check-restarts 1)
  82                        (setq visible t)
  83                        (check-restarts 1)
  84                        (invoke-restart (find-restart 'foo c1))))))
  85                (restart-case
  86                    (restart-case
  87                        (error c2)
  88                      (foo () 'in1)
  89                      (foo () :test (lambda (c) (declare (ignore c)) visible)
  90                           'in2))
  91                  (foo () 'ext)))))))
  92
  93 ;;; First argument of CERROR is a format control
  94 (assert
  95  (eq (block nil
  96        (handler-bind
  97            ((type-error (lambda (c) (return :failed)))
  98             (simple-error (lambda (c)
  99                             (return (if (find-restart 'continue)
 100                                         :passed
 101                                         :failed)))))
 102          (cerror (formatter "Continue from ~A") "bug ~A" :bug)))
 103      :passed))
 104
 105 ;;; clauses in HANDLER-CASE are allowed to have declarations (and
 106 ;;; indeed, only declarations)
 107 (assert
 108  (null (handler-case (error "foo") (error () (declare (optimize speed))))))
 109
 110 (handler-case
 111     (handler-bind ((warning #'muffle-warning))
 112       (signal 'warning))
 113   ;; if it's a control error, it had better be printable
 114   (control-error (c) (format nil "~A" c))
 115   ;; there had better be an error
 116   (:no-error (&rest args) (error "No error: ~S" args)))
 117
 118 (handler-case
 119     (funcall (lambda (x) (check-type x fixnum) x) t)
 120   (type-error (c)
 121     (assert (and (subtypep (type-error-expected-type c) 'fixnum)
 122                  (subtypep 'fixnum (type-error-expected-type c))))
 123     (assert (eq (type-error-datum c) t)))
 124   (:no-error (&rest rest) (error "no error: ~S" rest)))
 125
 126 ;;; ANSI specifies TYPE-ERROR if datum and arguments of ERROR are not
 127 ;;; designators for a condition. Reported by Bruno Haible on cmucl-imp
 128 ;;; 2004-10-12.
 129 (flet ((test (&rest args)
 130          (multiple-value-bind (res err)
 131              (ignore-errors (apply #'error args))
 132            (assert (not res))
 133            (assert (typep err 'type-error))
 134            (assert (not (nth-value 1 (ignore-errors
 135                                        (type-error-datum err)))))
 136            (assert (not (nth-value 1 (ignore-errors
 137                                        (type-error-expected-type err))))))))
 138   (test '#:no-such-condition)
 139   (test nil)
 140   (test t)
 141   (test 42)
 142   (test (make-instance 'standard-object)))
 143
 144 ;;; If CERROR is given a condition, any remaining arguments are only
 145 ;;; used for the continue format control.
 146 (let ((x 0))
 147   (handler-bind
 148       ((simple-error (lambda (c) (incf x) (continue c))))
 149     (cerror "Continue from ~A at ~A"
 150             (make-condition 'simple-error :format-control "foo"
 151                             :format-arguments nil)
 152             'cerror (get-universal-time))
 153     (assert (= x 1))))