;;;; side-effect-free tests of the condition system ;;;; This software is part of the SBCL system. See the README file for ;;;; more information. ;;;; ;;;; While most of SBCL is derived from the CMU CL system, the test ;;;; files (like this one) were written from scratch after the fork ;;;; from CMU CL. ;;;; ;;;; This software is in the public domain and is provided with ;;;; absolutely no warranty. See the COPYING and CREDITS files for ;;;; more information. (cl:in-package :cl-user) ;;; Until 0.7.7.21, (MAKE-CONDITION 'FILE-ERROR :PATHNAME "FOO") ;;; wasn't printable, because the REPORT function for FILE-ERROR ;;; referred to unbound slots. This was reported and fixed by Antonio ;;; Martinez (sbcl-devel 2002-09-10). (format t "~&printable now: ~A~%" (make-condition 'file-error :pathname "foo")) (assert (eq (block nil (macrolet ((opaque-error (arg) `(error ,arg))) (handler-bind ((error (lambda (c) (let ((restarts (remove 'res (compute-restarts c) :key #'restart-name :test-not #'eql))) (assert (= (length restarts) 2)) (invoke-restart (second restarts)))))) (let ((foo1 (make-condition 'error)) (foo2 (make-condition 'error))) (restart-case (with-condition-restarts foo1 (list (find-restart 'res)) (restart-case (opaque-error foo2) (res () 'int1) (res () 'int2))) (res () 'ext)))))) 'int2)) (assert (eq (block nil (macrolet ((opaque-error (arg) `(error ,arg))) (let ((foo1 (make-condition 'error)) (foo2 (make-condition 'error))) (handler-bind ((error (lambda (c) (let ((restarts (remove 'res (compute-restarts foo1) :key #'restart-name :test-not #'eql))) (assert (= (length restarts) 1)) (invoke-restart (first restarts)))))) (restart-case (with-condition-restarts foo1 (list (find-restart 'res)) (restart-case (opaque-error foo2) (res () 'int1) (res () 'int2))) (res () 'ext)))))) 'ext)) (assert (eq 'ext (block nil (let ((visible nil) (c1 (make-condition 'error)) (c2 (make-condition 'error))) (handler-bind ((error (lambda (c) (declare (ignore c)) (flet ((check-restarts (length) (assert (= length (length (remove 'foo (compute-restarts c1) :key #'restart-name :test-not #'eql)))))) (check-restarts 1) (setq visible t) (check-restarts 1) (invoke-restart (find-restart 'foo c1)))))) (restart-case (restart-case (error c2) (foo () 'in1) (foo () :test (lambda (c) (declare (ignore c)) visible) 'in2)) (foo () 'ext))))))) ;;; First argument of CERROR is a format control (assert (eq (block nil (handler-bind ((type-error (lambda (c) (return :failed))) (simple-error (lambda (c) (return (if (find-restart 'continue) :passed :failed))))) (cerror (formatter "Continue from ~A") "bug ~A" :bug))) :passed)) ;;; clauses in HANDLER-CASE are allowed to have declarations (and ;;; indeed, only declarations) (assert (null (handler-case (error "foo") (error () (declare (optimize speed))))))