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))