1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
|
(in-package :contextl)
#-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))))
|
