File: cx-dynascope.lisp

package info (click to toggle)
cl-contextl 0.40-2
  • links: PTS
  • area: main
  • in suites: lenny
  • size: 248 kB
  • ctags: 298
  • sloc: lisp: 2,271; makefile: 29
file content (88 lines) | stat: -rw-r--r-- 3,693 bytes parent folder | download
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
(in-package :contextl)

(defun make-special-symbol ()
  "creates a fresh unique special symbol"
  (let ((symbol (gensym "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 (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 t)
;; 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 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)))
         (progv ,symbol-list ,values ,@body)))
    `(progv ,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 `(let (,binding)
                                                     (declare (special ,(car 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 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))
                    `',(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)))))