Emacs lisp scope guard

scope-guard.el

(eval-when-compile
  (require 'cl))

(defmacro* scope (&rest args)
  "Partial implementation of scope the statement from D2.
A series of :key val arguments are accepted after which there is
a body of forms. The body is executed within an unwind-protect,
with the :exit form being unconditionally executed, and :success
and :failure conditionalised. A :failure-return argument will be
evaluated and its value returned in place of any condition raised.
All the keywords can occur multiple times and will appear in the
cleaup-forms of the unwind-protect in the same order the forms
appear in the keyword list.
see http://dlang.org/statement.html#ScopeGuardStatement
"
  (let (cleanup-actions success-or-failure failure-return)
    ;; parse the lambda list
    (loop for (k v) on args by 'cddr
          for i = 0 then (+ 1 i)
          do (cond
              ;; known keyword, act on the parameter
              ((member k '(:exit :success :failure :failure-return))
               (push (cons k v) cleanup-actions)
               (when (member k '(:success :failure :failure-return))
		 (setf success-or-failure t)
		 (when (eq k :failure-return)
		   (setf failure-return t))))

              ;; not a known keyword, the rest is the body
              (t
               (setf args (nthcdr (* 2 i) args))
               (return))))

    (let* ((success-sym (if success-or-failure (gensym "SCOPE-SUCCESS-G")))
	   (return-sym (if failure-return (gensym "SCOPE-RETURN-G")))
           resulting-form)
      (setf resulting-form
            `(unwind-protect
                 (progn
                   ,@args
                   ,@(if success-or-failure `((setf ,success-sym t))))
               ,@(reverse
                  (loop for (k . v) in cleanup-actions
                        if (eq k :exit)
                        collect v
                        else if (eq k :success)
                        collect `(when ,success-sym
                                   ,v)
                        else if (eq k :failure)
                        collect `(when (not ,success-sym)
                                   ,v)
			else if (eq k :failure-return)
			collect `(when (not ,success-sym)
				   (return-from ,return-sym ,v))))))
      (when success-or-failure
        (setf resulting-form
              `(let (,success-sym)
                 ,resulting-form)))
      (when failure-return
	(setf resulting-form
	      `(block ,return-sym
		 ,resulting-form)))
      resulting-form)))

;; ELISP> (macroexpand '(scope :exit (release-on-exit)
;;                             (stuff)
;;                             (and other stuff)))
;; (unwind-protect
;;     (progn
;;       (stuff)
;;       (and other stuff))
;;   (release-on-exit))

;; ELISP> (macroexpand '(scope :failure (print "Woe!")
;;                             :exit (print "Mop up 1")
;;                             :exit (print "Mop up 2")
;;                             :success (print "Yay!")
;;                             (print "This is the body")))
;; (let
;;     (SCOPE-SUCCESS-G126522)
;;   (unwind-protect
;;       (progn
;;         (print "This is the body")
;;         (setf SCOPE-SUCCESS-G126522 t))
;;     (when
;;         (not SCOPE-SUCCESS-G126522)
;;       (print "Woe!"))
;;     (print "Mop up 1")
;;     (print "Mop up 2")
;;     (when SCOPE-SUCCESS-G126522
;;       (print "Yay!"))))

;; ELISP> (macroexpand '(scope :exit (release-on-exit)
;; 			    :failure-return 'fail!
;; 			    (stuff)
;; 			    (and other stuff)))
;; (cl--block-wrapper
;;  (catch '--cl-block-SCOPE-RETURN-G52309--
;;    (let
;;        (SCOPE-SUCCESS-G52308)
;;      (unwind-protect
;; 	 (progn
;; 	   (stuff)
;; 	   (and other stuff)
;; 	   (setf SCOPE-SUCCESS-G52308 t))
;;        (release-on-exit)
;;        (when
;; 	   (not SCOPE-SUCCESS-G52308)
;; 	 (return-from SCOPE-RETURN-G52309 'fail!))))))