/usr/share/common-lisp/source/contextl/cx-dynascope.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 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 | (in-package :contextl)
(defun make-special-symbol ()
"creates a fresh unique special symbol"
(let ((symbol (make-dynamic-symbol "SPECIAL-SYMBOL-")))
(setf (get symbol 'specialp) t)
symbol))
(declaim (inline special-symbol-p))
(defun special-symbol-p (symbol)
"checks whether a symbol is special, as created by make-special-symbol"
(and #-cx-fast-special-symbol-progv
(dynamic-symbol-p symbol)
#+cx-fast-special-symbol-progv
(symbolp symbol)
(get symbol 'specialp)))
(defvar *symbol-access* nil
"set/get a place's special symbol instead of its symbol value
when this is set to a non-nil value")
(defmacro with-symbol-access (&body body)
"executes body in an environment with *symbol-access* set to t"
`(let ((*symbol-access* t))
,@body))
(defmacro without-symbol-access (&body body)
"executes body in an environment with *symbol-access* set to nil"
`(let ((*symbol-access* nil))
,@body))
(defun prepare-binding (binding env)
"ensure that a binding form is 'well-formed' to ease further processing"
(when (symbolp binding)
(setf binding (list binding nil)))
(assert (null (cddr binding)) ()
"Bad initialization form: ~S." binding)
`(,(macroexpand (car binding) env) ,@(cdr binding)))
(define-symbol-macro safe-special-symbol-progv
#-cx-fast-special-symbol-progv t
#+cx-fast-special-symbol-progv nil)
;; redefine this to nil to get more efficient code,
;; either globally via define-symbol-macro,
;; or locally via symbol-macrolet
(defmacro special-symbol-progv (symbols values &body body &environment env)
"like dynamic-progv, only that symbols must all be special symbols"
(if (macroexpand 'safe-special-symbol-progv env)
(with-unique-names (symbol-list retry)
`(let (,symbol-list)
(tagbody
,retry (setq ,symbol-list ,symbols)
(unless (every #'special-symbol-p ,symbol-list)
(cerror "Retry to rebind the place(s)."
"Attempt at rebinding one or more non-special places: ~S"
',symbols)
(go ,retry)))
(dynamic-progv ,symbol-list ,values ,@body)))
`(dynamic-progv ,symbols ,values ,@body)))
(defmacro special-symbol-reprogv (symbols values &body body &environment env)
"like dynamic-reprogv, only that symbols must all be special symbols"
(if (macroexpand 'safe-special-symbol-progv env)
(with-unique-names (symbol-list retry)
`(let (,symbol-list)
(tagbody
,retry (setq ,symbol-list ,symbols)
(unless (every #'special-symbol-p ,symbol-list)
(cerror "Retry to rebind the place(s)."
"Attempt at rebinding one or more non-special places: ~S"
',symbols)
(go ,retry)))
(dynamic-reprogv ,symbol-list ,values ,@body)))
`(dynamic-reprogv ,symbols ,values ,@body)))
(defmacro dletf* (bindings &body body &environment env)
"sequentially bind places to new values with dynamic scope,
and execute body in that new dynamic environment"
(loop for form = `(progn ,@body) then (etypecase (car binding)
(symbol `(dlet (,binding) ,form))
(cons `(special-symbol-progv
(list (with-symbol-access ,(car binding)))
(list ,(cadr binding))
,form)))
for binding in (reverse bindings)
do (setf binding (prepare-binding binding env))
finally (return form)))
(defmacro dreletf* (bindings &body body &environment env)
"sequentially bind places to new values with dynamic scope,
and execute body in that new dynamic environment"
(loop for form = `(progn ,@body) then (etypecase (car binding)
(symbol `(dreletf (,binding) ,form))
(cons (with-unique-names (symbol-store)
`(let ((,symbol-store (list (with-symbol-access ,(car binding)))))
(special-symbol-reprogv
,symbol-store
(list ,(cadr binding))
,form)))))
for binding in (reverse bindings)
do (setf binding (prepare-binding binding env))
finally (return form)))
(defmacro dletf (bindings &body body &environment env)
"bind places to new values with dynamic scope in parallel,
and execute body in that new dynamic environment"
(loop for binding in bindings
do (setf binding (prepare-binding binding env))
collect (if (symbolp (car binding))
`',(%dynamic-symbol (car binding))
(car binding)) into symbol-forms
when (symbolp (car binding)) collect (car binding) into variables
collect (cadr binding) into value-forms
finally (return `(special-symbol-progv
(with-symbol-access
(list ,@symbol-forms))
(list ,@value-forms)
(locally (declare (special ,@variables))
,@body)))))
(defmacro dreletf (bindings &body body &environment env)
"bind places to new values with dynamic scope in parallel,
and execute body in that new dynamic environment"
(loop for binding in bindings
do (setf binding (prepare-binding binding env))
collect (if (symbolp (car binding))
`',(%dynamic-symbol (car binding))
(car binding)) into symbol-forms
when (symbolp (car binding)) collect (car binding) into variables
collect (cadr binding) into value-forms
finally (return (with-unique-names (symbol-store)
`(let ((,symbol-store (with-symbol-access
(list ,@symbol-forms))))
(special-symbol-reprogv
,symbol-store
(list ,@value-forms)
(locally (declare (special ,@variables))
,@body)))))))
|