;;; -*- Mode:LISP; Package:USER; Readtable:CL; Base:10 -*-

;;; How to do unwind protect in LISP.  This is how MACLISP used to do it.

(defvar *current-dynamic-state* '())

(defun translate-to-older-state (target-state)
  (do ((dynamic-states *current-dynamic-state* (rest dynamic-states)))
      ((eq target-state dynamic-states) (setq *current-dynamic-state* dynamic-states))
    (funcall (car dynamic-states))))

(defun jrm-unwind-protect-procedure (execute-form cleanup-form)
  (let ((return-dynamic-state *current-dynamic-state*))
    (push cleanup-form *current-dynamic-state*)
    (multiple-value-prog1
      (funcall execute-form)
      (translate-to-older-state return-dynamic-state))))

(defmacro jrm-unwind-protect (execute-form cleanup-form)
  `(jrm-unwind-protect-procedure
     #'(lambda () ,execute-form)
     #'(lambda () ,cleanup-form)))

(defun jrm-catch-procedure (tag form)
  (let ((state-at-catch *current-dynamic-state*))
    (multiple-value-prog1
      (catch tag (funcall form))
      (translate-to-older-state state-at-catch))))

(defmacro jrm-catch (tag form)
  `(jrm-catch-procedure ,tag #'(lambda () ,form)))

(defun testit (throw?)
  (jrm-catch 'foo
    (jrm-unwind-protect
        (foo throw?)
      (foo nil))))

(defun foo (throw?)
  (if throw?
      (throw 'foo (values 'i 'threw))
      (values 'i 'didnt 'throw)))

(defun testit-old (throw?)
  (catch 'foo
    (unwind-protect
	(foo throw?)
      (foo nil))))

(defun testem (which-one how-many)
  (do ((count 0 (1+ count))
       (throw? t (not throw?)))
      ((= count how-many) 'done)
    (multiple-value-call #'list (funcall which-one throw?))))