Commit b63df871 authored by Tobias C. Rittweiler's avatar Tobias C. Rittweiler


	* conditions.lisp (unwind-protect-case): New macro. Similiar to
	CL:UNWIND-PROTECT except that it's possible to explicitly specify
	under which circumstances cleanup operations are run.

	* tests.lisp (unwind-protect-case.1-5): New test cases.
parent 91f8acbd
......@@ -19,3 +19,34 @@ list determines which specific conditions are to be ignored."
(progn ,@body)
,@(loop for condition in conditions collect
`(,condition (c) (values nil c)))))
(defmacro unwind-protect-case ((&optional abort-flag) protected-form &body clauses)
"Like CL:UNWIND-PROTECT, but you can specify the circumstances that
the cleanup CLAUSES are run.
ABORT-FLAG is the name of a variable that will be bound to T in
CLAUSES if the PROTECTED-FORM aborted preemptively, and to NIL
(unwind-protect-case ()
(:normal (format t \"This is only evaluated if PROTECTED-FORM executed normally.~%\"))
(:abort (format t \"This is only evaluated if PROTECTED-FORM aborted preemptively.~%\"))
(:always (format t \"This is evaluated in either case.~%\")))
(unwind-protect-case (aborted-p)
(:always (perform-cleanup-if aborted-p)))
(check-type abort-flag (or null symbol))
(let ((gflag (gensym "FLAG+")))
`(let ((,gflag t))
(unwind-protect (multiple-value-prog1 ,protected-form (setf ,gflag nil))
(let ,(and abort-flag `((,abort-flag ,gflag)))
,@(loop for (cleanup-kind . forms) in clauses
collect (ecase cleanup-kind
(:normal `(when (not ,gflag) ,@forms))
(:abort `(when ,gflag ,@forms))
(:always `(progn ,@forms)))))))))
\ No newline at end of file
......@@ -33,6 +33,70 @@
(typep 0 'array-index)
;;;; Conditions
(deftest unwind-protect-case.1
(let (result)
(unwind-protect-case ()
(random 10)
(:normal (push :normal result))
(:abort (push :abort result))
(:always (push :always result)))
(:always :normal))
(deftest unwind-protect-case.2
(let (result)
(unwind-protect-case ()
(random 10)
(:always (push :always result))
(:normal (push :normal result))
(:abort (push :abort result)))
(:normal :always))
(deftest unwind-protect-case.3
(let (result1 result2 result3)
(unwind-protect-case ()
(error "FOOF!")
(:normal (push :normal result1))
(:abort (push :abort result1))
(:always (push :always result1))))
(catch 'foof
(unwind-protect-case ()
(throw 'foof 42)
(:normal (push :normal result2))
(:abort (push :abort result2))
(:always (push :always result2))))
(block foof
(unwind-protect-case ()
(return-from foof 42)
(:normal (push :normal result3))
(:abort (push :abort result3))
(:always (push :always result3))))
(values result1 result2 result3))
(:always :abort)
(:always :abort)
(:always :abort))
(deftest unwind-protect-case.4
(let (result)
(unwind-protect-case (aborted-p)
(random 42)
(:always (setq result aborted-p)))
(deftest unwind-protect-case.5
(let (result)
(block foof
(unwind-protect-case (aborted-p)
(return-from foof)
(:always (setq result aborted-p))))
;;;; Control flow
(deftest switch.1
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment