/usr/share/common-lisp/source/contextl/cx-dynamic-environments.lisp is in cl-contextl 1:0.61-1.
This file is owned by root:root, with mode 0o644.
The actual contents of the file can be viewed below.
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))))
|