From 0f383318a079bd0c7bb23c909f30771b1c20b29c Mon Sep 17 00:00:00 2001 From: Matthias Andreas Benkard Date: Thu, 31 Jul 2008 09:33:25 +0200 Subject: Add Sacla to the repository. --- Sacla/tests/must-condition.lisp | 898 ++++++++++++++++++++++++++++++++++++++++ 1 file changed, 898 insertions(+) create mode 100644 Sacla/tests/must-condition.lisp (limited to 'Sacla/tests/must-condition.lisp') diff --git a/Sacla/tests/must-condition.lisp b/Sacla/tests/must-condition.lisp new file mode 100644 index 0000000..08e7080 --- /dev/null +++ b/Sacla/tests/must-condition.lisp @@ -0,0 +1,898 @@ +;; Copyright (C) 2002-2004, Yuji Minejima +;; ALL RIGHTS RESERVED. +;; +;; $Id: must-condition.lisp,v 1.7 2004/02/20 07:23:42 yuji Exp $ +;; +;; Redistribution and use in source and binary forms, with or without +;; modification, are permitted provided that the following conditions +;; are met: +;; +;; * Redistributions of source code must retain the above copyright +;; notice, this list of conditions and the following disclaimer. +;; * Redistributions in binary form must reproduce the above copyright +;; notice, this list of conditions and the following disclaimer in +;; the documentation and/or other materials provided with the +;; distribution. +;; +;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +;; signal +(eq (signal "test signal") nil) +(eq (signal 'simple-error :format-control "simple-error" :format-arguments nil) + nil) +(eq (signal 'simple-warning + :format-control "simple-warning" :format-arguments nil) + nil) +(handler-case (signal "test simple-condition") + (simple-condition () t) + (condition () nil) + (:no-error (&rest rest) (declare (ignore rest)) nil)) +(handler-case (signal 'simple-warning :format-control "simple warning" + :format-arguments nil) + (simple-warning () t) + (warning () nil) + (condition () nil) + (:no-error (&rest rest) (declare (ignore rest)) nil)) +(handler-case (signal 'type-error :datum nil :expected-type 'vector) + (type-error () t) + (error () nil) + (:no-error (&rest rest) (declare (ignore rest)) nil)) +(let ((*break-on-signals* 'arithmetic-error)) + (handler-case (signal 'type-error :datum nil :expected-type 'vector) + (type-error () t) + (error () nil) + (:no-error (&rest rest) (declare (ignore rest)) nil))) + + +;; error +(handler-case (error "simple-error test") + (simple-error () t) + (error () nil) + (:no-error (&rest rest) (declare (ignore rest)) nil)) +(handler-case (error 'type-error :datum nil :expected-type 'vector) + (type-error () t) + (error () nil) + (:no-error (&rest rest) (declare (ignore rest)) nil)) +(handler-case (error 'no-such-error!!) + (type-error () t) + (error () nil) + (:no-error (&rest rest) (declare (ignore rest)) nil)) +(handler-case (error 'simple-condition :format-control "simple-condition test") + (simple-condition () t) + (error () nil) + (:no-error (&rest rest) (declare (ignore rest)) nil)) +(handler-case (error 'simple-warning :format-control "simple-warning test") + (simple-warning () t) + (error () nil) + (:no-error (&rest rest) (declare (ignore rest)) nil)) + + + +;; cerror +(handler-case (cerror "Continue." "error test") + (simple-error () t) + (error () nil) + (:no-error (&rest rest) (declare (ignore rest)) nil)) +(handler-case (cerror "Continue." 'type-error :datum nil :expected-type 'vector) + (type-error () t) + (error () nil) + (:no-error (&rest rest) (declare (ignore rest)) nil)) +(handler-bind ((simple-error #'(lambda (condition) + (declare (ignore condition)) + (invoke-restart 'continue)))) + (eq (cerror "Continue." "error test") nil)) +(handler-bind ((type-error #'(lambda (condition) + (declare (ignore condition)) + (invoke-restart 'continue)))) + (eq (cerror "Continue." 'type-error :datum nil :expected-type 'vector) nil)) + + + +;; warn +(let ((*error-output* (make-string-output-stream))) + (and (eq (warn "I warn you!") nil) + (get-output-stream-string *error-output*))) +(handler-bind ((warning #'(lambda (condition) + (declare (ignore condition)) + (invoke-restart 'muffle-warning)))) + (eq (warn "I warn you!") nil)) +(let ((*error-output* (make-string-output-stream))) + (handler-bind ((warning #'(lambda (condition) + (declare (ignore condition)) + (invoke-restart 'muffle-warning)))) + (and (eq (warn "I warn you!") nil) + (string= (get-output-stream-string *error-output*) "")))) +(block tag + (handler-case (warn 'simple-error + :format-control "boom!" :format-arguments nil) + (type-error () t) + (simple-error () nil) + (error () nil) + (:no-error (&rest rest) (declare (ignore rest)) nil))) +(block tag + (handler-case (warn 'simple-condition + :format-control "boom!" :format-arguments nil) + (type-error () t) + (simple-condition () nil) + (error () nil) + (:no-error (&rest rest) (declare (ignore rest)) nil))) +(block tag + (let ((condition (make-condition 'simple-condition + :format-control "boom!" + :format-arguments nil))) + (handler-case (warn condition) + (type-error () t) + (simple-condition () nil) + (error () nil) + (:no-error (&rest rest) (declare (ignore rest)) nil)))) +(block tag + (let ((condition (make-condition 'simple-error + :format-control "boom!" + :format-arguments nil))) + (handler-case (warn condition) + (type-error () t) + (simple-error () nil) + (error () nil) + (:no-error (&rest rest) (declare (ignore rest)) nil)))) +(block tag + (let ((condition (make-condition 'simple-warning + :format-control "boom!" + :format-arguments nil))) + (handler-case (warn condition) + (type-error () nil) + (simple-warning () t) + (error () nil) + (:no-error (&rest rest) (declare (ignore rest)) nil)))) +(block tag + (let ((condition (make-condition 'simple-warning + :format-control "boom!" + :format-arguments nil))) + (handler-case (warn condition :format-control "boom!" :format-arguments nil) + (type-error () t) + (simple-warning () nil) + (error () nil) + (:no-error (&rest rest) (declare (ignore rest)) nil)))) + + + +;; handler-bind +(null (handler-bind ())) +(handler-bind () t) +(equal (multiple-value-list (handler-bind () 1 2 3 (values 4 5 6))) '(4 5 6)) +(eq 'handled + (block tag (handler-bind ((type-error #'(lambda (c) + (declare (ignore c)) + (return-from tag 'handled)))) + (error 'type-error :datum nil :expected-type 'vector)))) +(eq 'handled + (block tag (handler-bind ((error #'(lambda (c) + (declare (ignore c)) + (return-from tag 'handled)))) + (error 'type-error :datum nil :expected-type 'vector)))) +(eq 'handled + (block tag (handler-bind ((condition #'(lambda (c) + (declare (ignore c)) + (return-from tag 'handled)))) + (error 'type-error :datum nil :expected-type 'vector)))) +(eq 'outer-handler + (block tag + (handler-bind ((type-error #'(lambda (c) + (declare (ignore c)) + (return-from tag 'outer-handler)))) + (handler-bind ((type-error #'(lambda (c) (error c))) + (type-error #'(lambda (c) + (declare (ignore c)) + (return-from tag 'inner-handler)))) + (error 'type-error :datum nil :expected-type 'vector))))) +(eq 'outer-handler + (block tag + (handler-bind ((error #'(lambda (c) + (declare (ignore c)) + (return-from tag 'outer-handler)))) + (handler-bind ((type-error #'(lambda (c) (error c))) + (type-error #'(lambda (c) + (declare (ignore c)) + (return-from tag 'inner-handler)))) + (error 'type-error :datum nil :expected-type 'vector))))) +(eq 'left-handler + (block tag + (handler-bind ((type-error #'(lambda (c) + (declare (ignore c)) + (return-from tag 'left-handler))) + (type-error #'(lambda (c) + (declare (ignore c)) + (return-from tag 'right-handler)))) + (error 'type-error :datum nil :expected-type 'vector)))) +(eq 'left-handler + (block tag + (handler-bind ((error #'(lambda (c) + (declare (ignore c)) + (return-from tag 'left-handler))) + (type-error #'(lambda (c) + (declare (ignore c)) + (return-from tag 'right-handler)))) + (error 'type-error :datum nil :expected-type 'vector)))) +(eq 'left-handler + (block tag + (handler-bind ((type-error #'(lambda (c) + (declare (ignore c)) + (return-from tag 'left-handler))) + (error #'(lambda (c) + (declare (ignore c)) + (return-from tag 'right-handler)))) + (error 'type-error :datum nil :expected-type 'vector)))) +(let ((handler-declined nil)) + (and (eq (handler-bind ((type-error #'(lambda (c) + (declare (ignore c)) + (setq handler-declined t)))) + (signal 'type-error :datum nil :expected-type 'vector)) + nil) + handler-declined)) +(let ((handler-declined nil)) + (and (eq (handler-bind ((type-error #'(lambda (c) + (declare (ignore c)) + (push 'outer handler-declined)))) + (handler-bind ((type-error #'(lambda (c) + (declare (ignore c)) + (push 'inner handler-declined)))) + (signal 'type-error :datum nil :expected-type 'vector))) + nil) + (equal handler-declined '(outer inner)))) +(let ((handler-declined nil)) + (and (eq (handler-bind + ((type-error #'(lambda (c) + (declare (ignore c)) + (push 'outer-left-handler handler-declined))) + (type-error #'(lambda (c) + (declare (ignore c)) + (push 'outer-right-handler handler-declined)))) + (handler-bind + ((type-error #'(lambda (c) + (declare (ignore c)) + (push 'inner-left-handler handler-declined))) + (type-error #'(lambda (c) + (declare (ignore c)) + (push 'inner-right-handler handler-declined)))) + (signal 'type-error :datum nil :expected-type 'vector))) + nil) + (equal handler-declined '(outer-right-handler outer-left-handler + inner-right-handler inner-left-handler)))) +(let ((handler-declined nil)) + (and (eq (handler-bind + ((type-error #'(lambda (c) + (declare (ignore c)) + (push 'outer-left-handler handler-declined))) + (type-error #'(lambda (c) + (declare (ignore c)) + (push 'outer-right-handler handler-declined)))) + (handler-bind + ((type-error #'(lambda (c) + (declare (ignore c)) + (push 'inner-left-handler handler-declined))) + (type-error #'(lambda (c) + (signal c) + (push 'inner-right-handler handler-declined)))) + (signal 'type-error :datum nil :expected-type 'vector))) + nil) + (equal handler-declined '(outer-right-handler + outer-left-handler + inner-right-handler + + outer-right-handler + outer-left-handler + + inner-left-handler)))) +(let ((*dynamic-var* nil)) + (declare (special *dynamic-var*)) + (block tag + (handler-bind ((type-error #'(lambda (c) + (declare (ignore c)) + (return-from tag *dynamic-var*)))) + (let ((*dynamic-var* t)) + (declare (special *dynamic-var*)) + (signal 'type-error :datum nil :expected-type 'vector))))) +(let ((declined nil)) + (and (eq nil + (handler-bind ((simple-condition #'(lambda (c) + (declare (ignore c)) + (push 'specific declined)))) + (handler-bind ((condition #'(lambda (c) + (declare (ignore c)) + (push 'general declined)))) + (signal "error")))) + (equal declined '(specific general)))) +(block tag + (handler-bind ((error #'(lambda (c) (return-from tag (typep c 'error))))) + (error "error"))) +(eq 'ok + (block tag + (handler-bind ((error #'(lambda (c) + (declare (ignore c)) + (return-from tag 'ok)))) + (handler-bind ((error #'(lambda (c) + (declare (ignore c)) + (error "error3")))) + (handler-bind ((error #'(lambda (c) + (declare (ignore c)) + (error "error2")))) + (error "error")))))) +(eq 'ok + (block tag + (handler-bind + ((error + #'(lambda (c) + (declare (ignore c)) + (handler-bind + ((error #'(lambda (c) + (declare (ignore c)) + (handler-bind + ((error #'(lambda (c) + (declare (ignore c)) + (return-from tag 'ok)))) + (error "error2"))))) + (error "error1"))))) + (error "error0")))) + + +;; handler-case +(handler-case t) +(handler-case nil + (:no-error (&rest rest) (declare (ignore rest)) t)) +(equal (multiple-value-list (handler-case (values 0 1 2 3 4))) + '(0 1 2 3 4)) +(equal (handler-case (values 0 1 2 3 4) + (:no-error (&rest rest) rest)) + '(0 1 2 3 4)) +(equal (multiple-value-list (handler-case (values 0 1 2 3 4) + (:no-error (&rest rest) (values rest 5 6 7 8)))) + '((0 1 2 3 4) 5 6 7 8)) +(eq t (handler-case t + (type-error () 'type-error) + (error () 'error))) +(eq 'simple-error + (handler-case (error "error!") + (simple-error () 'simple-error) + (error () 'error))) +(eq 'error + (handler-case (error "error!") + (error () 'error) + (simple-error () 'simple-error))) +(eq 'error + (handler-case (error "error!") + (error () 'error) + (condition () 'condition) + (simple-error () 'simple-error))) +(eq 'condition + (handler-case (error "error!") + (condition () 'condition) + (error () 'error) + (simple-error () 'simple-error))) +(eq 'simple-error + (handler-case (signal 'simple-error + :format-control "error!" :format-arguments nil) + (simple-error () 'simple-error) + (error () 'error))) +(eq 'simple-error-left + (handler-case (signal 'simple-error + :format-control "error!" :format-arguments nil) + (simple-error () 'simple-error-left) + (simple-error () 'simple-error-right))) +(eq 'no-one-handled + (handler-case (progn + (signal 'simple-warning + :format-control "warning!" :format-arguments nil) + 'no-one-handled) + (simple-error () 'simple-error) + (error () 'error))) +(equal (handler-case (progn + (signal 'simple-warning + :format-control "warning!" :format-arguments nil) + 'no-one-handled) + (:no-error (&rest rest) (cons 'no-error rest)) + (simple-error () 'simple-error) + (error () 'error)) + '(no-error no-one-handled)) +(let ((where 'out)) + (eq (handler-case (let ((where 'in)) + (declare (ignorable where)) + (error "error!")) + (error () where)) + 'out)) +(let ((where 'out)) + (declare (special where)) + (eq (handler-case (let ((where 'in)) + (declare (special where)) + (error "~S" where)) + (error () where)) + 'out)) +(typep (handler-case (error "error!") + (error (c) c)) + 'simple-error) +(typep (handler-case (error "error!") + (condition (c) c)) + 'simple-error) +(typep (handler-case (signal "condition") + (condition (c) c)) + 'simple-condition) +(typep (handler-case (warn "warning") + (condition (c) c)) + 'simple-warning) + + + +;; restart-bind +(null (restart-bind ())) +(restart-bind () t) +(= (restart-bind () 0 1 2) 2) +(equal (multiple-value-list (restart-bind () 0 1 2 (values 3 4 5))) '(3 4 5)) +(block tag + (restart-bind ((continue #'(lambda (&rest rest) + (declare (ignore rest)) + (return-from tag t)))) + (handler-case (signal "testing simple-signal") + (simple-condition () (invoke-restart 'continue))))) +(block tag + (handler-bind ((simple-condition #'(lambda (condition) + (declare (ignore condition)) + (invoke-restart 'continue)))) + (restart-bind ((continue #'(lambda (&rest rest) + (declare (ignore rest)) + (return-from tag t)))) + (signal "testing simple-condition")))) +(block tag + (restart-bind ((continue #'(lambda (&rest rest) + (declare (ignore rest)) + (return-from tag nil)))) + (handler-bind ((simple-condition #'(lambda (condition) + (declare (ignore condition)) + (invoke-restart 'continue)))) + (restart-bind ((continue #'(lambda (&rest rest) + (declare (ignore rest)) + (return-from tag t)))) + (signal "testing simple-condition"))))) +(block tag + (restart-bind ((continue #'(lambda (&rest rest) + (declare (ignore rest)) + (return-from tag t))) + (continue #'(lambda (&rest rest) + (declare (ignore rest)) + (return-from tag nil)))) + (handler-case (signal "testing simple-signal") + (simple-condition () (invoke-restart 'continue))))) +(block tag + (restart-bind ((continue #'(lambda (&rest rest) + (declare (ignore rest)) + (return-from tag t)) + :report-function #'(lambda (stream) + (format stream "Continue")))) + (handler-case (signal "testing simple-signal") + (simple-condition () (invoke-restart 'continue))))) +(block tag + (restart-bind ((continue #'(lambda (x) (return-from tag x)) + :report-function + #'(lambda (stream) (format stream "Continue")) + :interactive-function #'(lambda () (list t)))) + (handler-case (signal "testing simple-signal") + (simple-condition () (invoke-restart-interactively 'continue))))) +(eq 'ok + (block tag + (restart-bind ((continue #'(lambda (x) (return-from tag x)))) + (handler-case (signal "testing simple-signal") + (simple-condition () (invoke-restart 'continue 'ok)))))) +(block tag + (restart-bind ((continue #'(lambda (x) (return-from tag x)) + :report-function + #'(lambda (stream) (format stream "Continue")) + :interactive-function #'(lambda () (list t)) + :test-function (constantly t))) + (handler-case (signal "testing simple-signal") + (simple-condition () (invoke-restart-interactively 'continue))))) +(block tag + (restart-bind ((continue #'(lambda (x) (return-from tag x)) + :report-function + #'(lambda (stream) (format stream "Continue")) + :interactive-function #'(lambda () (list t)) + :test-function + #'(lambda (c) (or (null c) (typep c 'simple-condition))))) + (handler-case (signal "testing simple-signal") + (simple-condition () (invoke-restart-interactively 'continue))))) +(block tag + (restart-bind ((tb-continue #'(lambda (x) (return-from tag x)) + :interactive-function #'(lambda () (list t)) + :test-function (constantly nil) + :report-function + #'(lambda (stream) (format stream "Continue")))) + (not (find-restart 'tb-continue)))) +(block tag + (restart-bind ((tb-continue #'(lambda (x) (return-from tag x)) + :interactive-function #'(lambda () (list t)) + :test-function (constantly t) + :report-function #'(lambda (stream) (format stream "cont.")))) + (handler-case (signal "testing simple-signal") + (simple-condition () (invoke-restart-interactively 'tb-continue))))) +(null (let ((*dynamic-var* nil)) + (declare (special *dynamic-var*)) + (block tag + (restart-bind ((continue #'(lambda (x) + (declare (ignore x)) + (return-from tag *dynamic-var*)) + :interactive-function #'(lambda () (list t)) + :test-function (constantly t) + :report-function + #'(lambda (stream) (format stream "cont.")))) + (handler-case (let ((*dynamic-var* t)) + (declare (special *dynamic-var*)) + (signal "testing simple-signal")) + (simple-condition () (invoke-restart-interactively 'continue))))))) +(let ((*dynamic-var* nil)) + (declare (special *dynamic-var*)) + (block tag + (restart-bind ((continue #'(lambda (x) + (declare (ignore x)) + (return-from tag *dynamic-var*)) + :interactive-function #'(lambda () (list t)) + :test-function (constantly t) + :report-function + #'(lambda (stream) (format stream "cont.")))) + (handler-bind ((simple-condition + #'(lambda (c) + (declare (ignore c)) + (invoke-restart-interactively 'continue)))) + (let ((*dynamic-var* t)) + (declare (special *dynamic-var*)) + (signal "testing simple-signal")))))) +(block tag + (restart-bind ((nil #'(lambda (&rest rest) + (declare (ignore rest)) + (return-from tag t)))) + (handler-case (signal "testing simple-signal") + (simple-condition () (invoke-restart 'nil))))) + + + +;; restart-case +(restart-case t) +(restart-case t + (continue (&rest rest) (declare (ignore rest)) nil)) +(equal (multiple-value-list (restart-case (values 0 1 2 3 4))) '(0 1 2 3 4)) +(eq 'continued + (restart-case (continue) + (continue (&rest rest) (declare (ignore rest)) 'continued))) +(eq nil + (restart-case (continue) + (continue (&rest rest) (declare (ignore rest))))) +(eq 'continue-left + (restart-case (continue) + (continue (&rest rest) (declare (ignore rest)) 'continue-left) + (continue (&rest rest) (declare (ignore rest)) 'continue-right))) +(null (restart-case (invoke-restart 'continue) + (continue (&rest rest) + :interactive (lambda () (list 0 1 2 3)) + rest))) +(equal (restart-case (invoke-restart-interactively 'continue) + (continue (&rest rest) + :interactive (lambda () (list 0 1 2 3)) + rest)) + '(0 1 2 3)) +(equal (restart-case (invoke-restart-interactively 'continue) + (continue (&rest rest) + :interactive (lambda () (list 0 1 2 3)) + :report "continue" + rest)) + '(0 1 2 3)) +(equal (restart-case (invoke-restart-interactively 'continue) + (continue (&rest rest) + :interactive (lambda () (list 0 1 2 3)) + :report "continue" + :test (lambda (c) (declare (ignore c)) t) + rest)) + '(0 1 2 3)) +(= (restart-case + (handler-bind ((error #'(lambda (c) + (declare (ignore c)) + (invoke-restart 'my-restart 7)))) + (error "Foo.")) + (my-restart (&optional v) v)) + 7) +(eq (handler-bind ((error #'(lambda (c) + (declare (ignore c)) + (invoke-restart 'my-restart 'restarted)))) + (restart-case (error "Boo.") + (my-restart (&optional v) v))) + 'restarted) +(eq (handler-bind ((error #'(lambda (c) + (invoke-restart (find-restart 'my-restart c) + 'restarted)))) + (restart-case (error "Boo.") + (my-restart (&optional v) v))) + 'restarted) + +(> (length + (block tag + (handler-bind ((error #'(lambda (c) + (return-from tag (compute-restarts c))))) + (restart-case (error "Boo.") + (my-restart (&optional v) v) + (my-restart (&optional v) v))))) + 1) +(eq 'ok + (restart-case (invoke-restart 'nil) + (nil (&rest rest) (declare (ignore rest)) 'ok))) + + + + + + +;; compute-restarts +(listp (mapcar #'restart-name (compute-restarts))) +(listp (mapcar #'restart-name + (compute-restarts (make-condition 'simple-error + :format-control "error" + :format-arguments nil)))) +(restart-case (let ((list (compute-restarts))) + (and (member 'my-restart list + :test #'string= :key #'restart-name) + (member 'your-restart list + :test #'string= :key #'restart-name))) + (my-restart ()) + (your-restart ())) +(restart-case (let ((list (compute-restarts))) + (member 'my-restart + (cdr (member 'my-restart list + :test #'string= :key #'restart-name)) + :test #'string= :key #'restart-name)) + (my-restart ()) + (my-restart ())) + + +;; find-restart +(or (find-restart 'continue) t) +(restart-case (find-restart 'my-restart) + (my-restart ())) +(restart-case (find-restart (find-restart 'my-restart)) + (my-restart ())) +(let ((condition (make-condition 'simple-error + :format-control "error" :format-arguments nil))) + (block tag + (handler-bind ((error + #'(lambda (c) + (return-from tag (and (eq c condition) + (find-restart 'my-restart c)))))) + (restart-case (error condition) + (my-restart ()))))) + + +;; restart-name +(string= "MY-RESTART" + (block tag + (handler-bind + ((error + #'(lambda (c) + (return-from tag (restart-name + (find-restart 'my-restart c)))))) + (restart-case (error "error!") + (my-restart ()))))) +(null (block tag + (handler-bind + ((error + #'(lambda (c) + (return-from tag (restart-name + (find-restart 'nil c)))))) + (restart-case (error "error!") + (nil ()))))) + + +;; with-condition-restarts +(null (with-condition-restarts + (make-condition 'simple-error + :format-control "error" :format-arguments nil) + ())) +(with-condition-restarts + (make-condition 'simple-error + :format-control "error" :format-arguments nil) + () t) +(equal + (multiple-value-list + (with-condition-restarts + (make-condition 'simple-error + :format-control "error" :format-arguments nil) + () 0 1 2 (values 3 4 5))) + '(3 4 5)) +(let ((condition (make-condition 'simple-error + :format-control "error" :format-arguments nil)) + (other (make-condition 'simple-error + :format-control "error" :format-arguments nil))) + (block tag + (handler-bind + ((error + #'(lambda (c) + (return-from tag (and (find-restart 'my-restart c) + (null (with-condition-restarts other + (compute-restarts) + (find-restart 'my-restart c)))))))) + (restart-case (progn 3 2 1 'go (error condition)) + (my-restart ()))))) + + +;; with-simple-restart +(null (with-simple-restart (continue "continue"))) +(with-simple-restart (continue "continue") t) +(equal (multiple-value-list + (with-simple-restart (continue "continue") 0 1 (values 2 3 4))) + '(2 3 4)) +(equal (multiple-value-list + (with-simple-restart (continue "continue") + (continue))) + '(nil t)) +(equal (multiple-value-list + (with-simple-restart (continue "continue") + (handler-case (error "boo") + (error (c) (declare (ignore c)) (invoke-restart 'continue))))) + '(nil t)) + + +;; abort +(eq 'ok + (restart-case (abort) + (abort () 'ok))) +(let ((condition (make-condition 'simple-error + :format-control "error" :format-arguments nil))) + (or (find-restart 'abort condition) + (eq 'handled + (handler-case (abort condition) + (control-error () 'handled) + (condition () nil))))) + +;; muffle-warning +(eq 'ok + (restart-case (muffle-warning) + (muffle-warning () 'ok))) +(let ((condition (make-condition 'simple-warning + :format-control "warning" + :format-arguments nil))) + (or (find-restart 'muffle-warning condition) + (eq 'handled + (handler-case (muffle-warning condition) + (control-error () 'handled) + (condition () nil))))) + +;; continue +(eq 'ok + (restart-case (continue) + (continue () 'ok))) +(let ((condition (make-condition 'simple-error + :format-control "error" + :format-arguments nil))) + (or (find-restart 'continue condition) + (null (continue condition)))) + +;; store-value +(eq 'ok + (restart-case (store-value 'ok) + (store-value (value) value))) +(let ((condition (make-condition 'simple-error + :format-control "error" + :format-arguments nil))) + (or (find-restart 'store-value condition) + (null (store-value t condition)))) + +;; use-value +(eq 'ok + (restart-case (use-value 'ok) + (use-value (value) value))) +(let ((condition (make-condition 'simple-error + :format-control "error" + :format-arguments nil))) + (or (find-restart 'use-value condition) + (null (use-value t condition)))) + + + + + +;; assert +(eq (assert t) nil) +(handler-case (assert nil) + (error () t) + (:no-error (&rest rest) (declare (ignore rest)) nil)) +(let ((count 0)) + (and (eq (assert (incf count)) nil) + (= count 1))) +(handler-case (let ((var nil)) (assert var (var) "VAR should be true.")) + (simple-error () t) + (error () nil) + (:no-error (&rest rest) (declare (ignore rest)) nil)) +(let ((str (copy-seq "ABC")) + (count 0)) + (and (eq (assert (char= (aref str 0) #\A) ((aref (progn (incf count) str) 0))) + nil) + (zerop count))) +(let ((str (copy-seq "ABC")) + (count 0)) + (and (eq (assert (and (char= (aref str 0) #\A) + (char= (aref str 1) #\B)) + ((aref (progn (incf count) str) 0) + (aref (progn (incf count) str) 1))) + nil) + (zerop count))) +(handler-case (let ((var nil)) + (assert var (var) 'type-error :expected-type 'array)) + (type-error () t) + (error () nil) + (:no-error (&rest rest) (declare (ignore rest)) nil)) + + +;; check-type +(null (let ((var nil)) (check-type var null))) +(null (let ((var '(a b c))) (check-type var cons))) +(handler-case (let ((var '(a b c))) (check-type var vector)) + (type-error () t) + (error () nil) + (:no-error (&rest rest) (declare (ignore rest)) nil)) +(eq 'handled + (block tag + (handler-bind ((type-error + #'(lambda (c) + (declare (ignore c)) + (return-from tag 'handled))) + (error #'(lambda (c) + (declare (ignore c)) + (return-from tag nil)))) + (let ((var '(a b c))) + (check-type var vector) + var)))) +(string= (block tag + (handler-bind ((type-error + #'(lambda (c) + (declare (ignore c)) + (invoke-restart 'store-value "eat this"))) + (error #'(lambda (c) + (declare (ignore c)) + (return-from tag nil)))) + (let ((var '(a b c))) + (check-type var vector) + var))) + "eat this") + + +;; ignore-errors +(null (ignore-errors)) +(ignore-errors t) +(let ((result (multiple-value-list (ignore-errors (error "error"))))) + (and (null (first result)) + (typep (second result) 'simple-error))) +(equal (multiple-value-list (ignore-errors 'a 'b 'c (values 'd 'e))) + '(d e)) +(let ((result (multiple-value-list + (ignore-errors (signal 'simple-error + :format-control "error" + :format-arguments nil))))) + (and (null (first result)) + (typep (second result) 'simple-error))) +(eq (ignore-errors (signal "only signal") 'ok) 'ok) +(eq (block tag + (handler-bind ((condition #'(lambda (c) + (declare (ignore c)) + (return-from tag 'handled)))) + (ignore-errors (error 'simple-condition + :format-control "only condition" + :format-arguments nil)))) + 'handled) +(let ((result (multiple-value-list + (ignore-errors (warn 'simple-error + :format-control "an error, not a warning" + :format-arguments nil))))) + (and (null (first result)) + (typep (second result) 'type-error))) + -- cgit v1.2.3