;;; Copyright (c) 2005 - 2009 Pascal Costanza
;;; 
;;; Permission is hereby granted, free of charge, to any person
;;; obtaining a copy of this software and associated documentation
;;; files (the \"Software\"), to deal in the Software without
;;; restriction, including without limitation the rights to use,
;;; copy, modify, merge, publish, distribute, sublicense, and/or
;;; sell copies of the Software, and to permit persons to whom the
;;; Software is furnished to do so, subject to the following
;;; conditions:
;;; 
;;; The above copyright notice and this permission notice shall be
;;; included in all copies or substantial portions of the Software.
;;; 
;;; THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND,
;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES
;;; OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR
;;; OTHER DEALINGS IN THE SOFTWARE.

;;;Alessio Stalla: This is taken from Pascal Costanza's ContextL library.
;;;It implements the low-level bits of dynamic environments support.

(in-package :snow)

#-cx-disable-dynamic-environments
(defvar *dynamic-wind-stack* '())

(defstruct (dynamic-mark (:constructor make-dynamic-mark (name)))
  (name nil :read-only t))

(defmacro with-dynamic-mark ((mark-variable) &body body)
  (let ((mark (gensym)))
    `(let* ((,mark (make-dynamic-mark ',mark-variable))
            #-cx-disable-dynamic-environments
            (*dynamic-wind-stack* (cons ,mark *dynamic-wind-stack*))
            (,mark-variable ,mark))
       ,@body)))

(defmacro dynamic-wind (&body body)
  (let ((proceed-name (cond ((eq (first body) :proceed)
                             (pop body) (pop body))
                            (t 'proceed))))
    (assert (symbolp proceed-name) (proceed-name))
    #-cx-disable-dynamic-environments
    (with-unique-names (dynamic-wind-thunk proceed-thunk proceed-body)
      `(flet ((,dynamic-wind-thunk (,proceed-thunk)
                (macrolet ((,proceed-name (&body ,proceed-body)
                             `(if ,',proceed-thunk
                                (funcall (the function ,',proceed-thunk))
                                (progn ,@,proceed-body))))
                  ,@body)))
         (declare (inline ,dynamic-wind-thunk))
         (let ((*dynamic-wind-stack* (cons #',dynamic-wind-thunk *dynamic-wind-stack*)))
           (,dynamic-wind-thunk nil))))
    #+cx-disable-dynamic-environments
    (with-unique-names (proceed-body)
      `(macrolet ((,proceed-name (&body ,proceed-body)
                    `(progn ,@,proceed-body)))
         ,@body))))

#-cx-disable-dynamic-environments
(progn
  (defclass dynamic-environment ()
    ((dynamic-winds :initarg :dynamic-winds :reader dynamic-winds)))

  (defun capture-dynamic-environment (&optional mark)
    (make-instance 'dynamic-environment
                   :dynamic-winds
                   (loop with dynamic-winds = '()
                         for entry in *dynamic-wind-stack*
                         if (functionp entry) do (push entry dynamic-winds)
                         else if (eq entry mark) return dynamic-winds
                         finally (return dynamic-winds))))

  (defgeneric call-with-dynamic-environment (environment thunk)
    (:method ((environment dynamic-environment) (thunk function))
     (declare (optimize (speed 3) (space 3) (debug 0) (safety 0)
                        (compilation-speed 0)))
     (labels ((perform-calls (environment thunk)
                (cond (environment
                       (assert (consp environment))
                       (let ((function (first environment)))
                         (assert (functionp function))
                         (let ((*dynamic-wind-stack* (cons function *dynamic-wind-stack*)))
                           (funcall function (lambda () (perform-calls (rest environment) thunk))))))
                      (t (funcall thunk)))))
       (perform-calls (dynamic-winds environment) thunk))))

  (defmacro with-dynamic-environment ((environment) &body body)
    `(call-with-dynamic-environment ,environment (lambda () ,@body))))
