├── .gitignore ├── .travis.yml ├── README.md ├── macrodynamics.asd ├── src ├── macrodynamics.lisp ├── package.lisp └── util.lisp └── test ├── macrodynamics-test.lisp ├── macros.lisp └── package.lisp /.gitignore: -------------------------------------------------------------------------------- 1 | *.fasl 2 | *~ 3 | \#*\# 4 | .\#* 5 | -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | language: common-lisp 2 | 3 | sudo: required 4 | env: 5 | matrix: 6 | - LISP=abcl 7 | - LISP=allegro 8 | - LISP=sbcl 9 | - LISP=sbcl32 10 | - LISP=ccl 11 | - LISP=ccl32 12 | - LISP=clisp 13 | - LISP=clisp32 14 | # - LISP=cmucl # /home/travis/.cim/bin/cl: 4: .: Can't open /home/travis/.cim/config/current.3271 15 | - LISP=ecl 16 | 17 | install: 18 | - if [ -x ./install.sh ] && head -2 ./install.sh | grep '^# cl-travis' > /dev/null; 19 | then 20 | ./install.sh; 21 | else 22 | curl https://raw.githubusercontent.com/luismbo/cl-travis/master/install.sh | sh; 23 | fi 24 | 25 | script: 26 | - cl -e '(in-package :cl-user)' 27 | -e '(ql:quickload :macrodynamics)' 28 | -e '(ql:quickload :macrodynamics/test)' 29 | -e '(let ((*debugger-hook* 30 | (lambda (c h) 31 | (declare (ignore h)) 32 | (print c t) 33 | (uiop:quit -1)))) 34 | (fiasco:run-package-tests :package :macrodynamics/test))' 35 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # Macrodynamics 2 | 3 | [![Build Status](https://travis-ci.org/DalekBaldwin/macrodynamics.svg?branch=master)](https://travis-ci.org/DalekBaldwin/macrodynamics) 4 | [![Quicklisp](http://quickdocs.org/badge/macrodynamics.svg)](http://quickdocs.org/macrodynamics/) 5 | 6 | Macrodynamics is a language extension that broadens the notion of dynamic scope inside macroexpansion code. Macrodynamic bindings are scoped not just to the code called during an individual expansion, but also to subsequent expansions of the code returned within the dynamic scope of those bindings. 7 | 8 | This goes a long way toward rectifying a major limitation of Common Lisp, described in detail [here](http://qiita.com/guicho271828/items/07ba4ff11bff494dc03f). In short, you can write macros that behave as if they were expanded recursively instead of iteratively. However, macrodynamics only lets data flow downstream from where it is bound; it does not provide analogues of conditions or continuations to transmit information back up the expansion stack. 9 | 10 | ## Usage 11 | 12 | You can declare macrodynamic variables with `def-dynenv-var`, a cognate of `defvar`. These variables can be left unbound or given a top-level, global value. 13 | 14 | ```lisp 15 | (def-dynenv-var **my-macrodynamic-var** value) 16 | (def-dynenv-var **my-unbound-macrodynamic-var**) 17 | ``` 18 | 19 | (You may want to use a special notational convention for macrodynamic variables and functions. I prefer `**double-earmuffs**` myself.) 20 | 21 | For macrodynamic functions, `def-dynenv-fun` works like `defun`, while `def-unbound-dynenv-fun` only takes a name which remains unbound at the top-level. (There's just no way to sensibly combine both syntaxes within one macro.) 22 | 23 | ```lisp 24 | (def-dynenv-fun **my-macrodynamic-fun** (&rest stuff) (do-stuff-with stuff)) 25 | (def-unbound-dynenv-fun **my-unbound-macrodynamic-fun**) 26 | ``` 27 | 28 | Macrodynamic variables and functions live in a separate namespace from regular Lisp variables (whether lexical or dynamic) and functions. To establish bindings for them, you must use one of a few dynamic-only compile-time variants of familiar operators. `ct-let` and `ct-let*` bind variables, and `ct-flet` binds functions. 29 | 30 | Within the body of any function definition created with `ct-flet`, the function name `call-next-dynenv-fun` is bound (lexically, not dynamically!) to the previously dynamically-bound function with the same name. But any recursive invocation of the function by name, even within a call to `call-next-dynenv-fun`, will always invoke the most recently dynamically-bound function. You can also retrieve dynamically-bound functions as values using `dynenv-function` instead of `function` or `#'`. `function`/`#'` simply retrieves a wrapper for calling the dynamically-bound function, which may be rebound between the time you retrieve the wrapper and the time you invoke it. For more details, see Pascal Costanza's [paper](http://www.p-cos.net/documents/dynfun.pdf) on dynamically-scoped functions. 31 | 32 | To define macros that need to read or bind macrodynamic entities within the dynamic scope of their expander code, you can use `def-dynenv-macro`: 33 | 34 | ```lisp 35 | (def-dynenv-var **a-macrodynamic-var** nil) 36 | 37 | (def-dynenv-macro some-macro (&body body) 38 | `(do-stuff 39 | ,(do-something) 40 | ,(ct-let ((**a-macrodynamic-var** 41 | (non-destructively-augment **a-macrodynamic-var**))) 42 | `(progn ,@body)))) 43 | 44 | ;; this function will signal an error if not called within the dynamic scope 45 | ;; of a macrodynamic macro's expansion 46 | (defun do-something () 47 | (generate-code-with **a-macrodynamic-var**)) 48 | 49 | (defmacro dummy-wrapper-for-some-macro (&body body) 50 | `(some-macro ,@body)) 51 | ``` 52 | 53 | Then if you write a form like this: 54 | 55 | ```lisp 56 | (some-macro 57 | (dummy-wrapper-for-some-macro 58 | (some-macro 59 | (some-other-code)))) 60 | ``` 61 | 62 | `do-something` will see the global binding `nil` for `**a-macrodynamic-var**` during the expansion of the top-level `some-macro` form, then it will see a new binding equivalent to `(non-destructively-augment nil)` in the expansion of the `some-macro` form that `dummy-wrapper-for-some-macro`'s expansion returns, then another new binding equivalent to `(non-destructively-augment (non-destructively-augment nil))` in the innermost `some-macro` expansion. 63 | 64 | `def-dynenv-macro` is just a convenience macro that can extract the macrodynamic context from the lexical environment regardless of whether you include an `&environment` parameter. (An analogous `dynenv-macrolet` macro is also provided.) Alternatively, you can explicitly pass an environment to `with-dynenv` at the top of a macro's body (or at least surrounding any forms that need to bind or reference macrodynamic entities). This makes it easier to integrate macrodynamics with any other special macro-defining-macros you might want to use. 65 | 66 | ```lisp 67 | (def-macro-using-some-other-macro-library some-macro 68 | (&body body &environment env) 69 | (with-dynenv env 70 | `(do-stuff 71 | ,(do-something) 72 | ,(ct-let ((**a-macrodynamic-var** 73 | (non-destructively-augment **a-macrodynamic-var**))) 74 | (remember-that-you-can-also-see-the-new-value-of **a-macrodynamic-var** 75 | immediately-right-here-in-the-same-expansion-step! 76 | `(progn ,@body)))))) 77 | ``` 78 | 79 | This library is meant to be used in a purely functional manner, and it will signal an error if you attempt to set, rather than rebind, a macrodynamic binding. That's right, dynamic scope is compatible with functional programming; it just admits a slightly looser definition of referential transparency. You can think of dynamic variables as an implicit set of additional arguments passed to every function. When dynamic bindings are in play, a function called with the same arguments may not always return the same results, but a function called at the top-level with the same arguments always will. What this means for macrodynamics is that an entire top-level form will always have the same macroexpansion. Normally, this is all you really care about, since you spend most of your time reasoning about top-level forms that you can see in their entirety. 80 | 81 | One drawback is that you won't always be able to use SLIME's `C-c C-m` to verify what a non-top-level expression will expand into, but this is no different from any other situation in which you might use `macrolet` or `symbol-macrolet`. Macrodynamics are no more dangerous than lexically-bound macros; in fact, they're just an abstraction layer built on top of `symbol-macrolet`. 82 | 83 | ## But Why? 84 | 85 | What is dynamic from the perspective of expander code is lexical from the perspective of expanded code. When you take full advantage of this semantic duality, it's easy to lexically scope, and thus make more composable, certain implementation concerns that do not easily map onto lexical runtime variables. In the most common case, you can bind compile-time metadata about how a given variable is meant to be interpreted by another macro that may or may not be used further down the syntax tree. 86 | 87 | Instead of placing your trust in a code walker like macroexpand-dammit, macrodynamics piggybacks on your implementation's built-in macroexpansion facility. When you use a code walker, you introduce a potential point of failure that can screw up the expansion of code in between the macro that establishes a compile-time dynamic context and the macro that uses it. With macrodynamics, you can trust your Lisp implementation to correctly process any in-between special operators, function calls, and macros that were written without any knowledge of this language extension. 88 | -------------------------------------------------------------------------------- /macrodynamics.asd: -------------------------------------------------------------------------------- 1 | ;;;; macrodynamics.asd 2 | 3 | (defsystem "macrodynamics" 4 | :serial t 5 | :author "Kyle Littler" 6 | :license "LLGPL" 7 | :version "0.1.1" 8 | :description "A language extension for creating bindings scoped to the entire expansion process of a region of code." 9 | :homepage "https://github.com/DalekBaldwin/macrodynamics" 10 | :components 11 | ((:static-file "macrodynamics.asd") 12 | (:module :src 13 | :components ((:file "package") 14 | (:file "util") 15 | (:file "macrodynamics")) 16 | :serial t)) 17 | :depends-on ("alexandria") 18 | :in-order-to ((test-op (test-op "macrodynamics/test")))) 19 | 20 | (defsystem "macrodynamics/test" 21 | :serial t 22 | :author "Kyle Littler" 23 | :license "LLGPL" 24 | :version "0.1.1" 25 | :description "Tests for macrodynamics." 26 | :components 27 | ((:module :test 28 | :components ((:file "package") 29 | (:file "macros") 30 | (:file "macrodynamics-test")))) 31 | :depends-on ("macrodynamics" 32 | "fiasco" 33 | "check-it") 34 | :perform (test-op (op c) (symbol-call :macrodynamics/test :test-all))) 35 | -------------------------------------------------------------------------------- /src/macrodynamics.lisp: -------------------------------------------------------------------------------- 1 | (in-package :macrodynamics) 2 | 3 | (defparameter *var-space* nil) 4 | (defparameter *fun-space* nil) 5 | (defparameter *within-captured-dynenv* nil) 6 | 7 | (eval-when (:compile-toplevel :load-toplevel :execute) 8 | (define-symbol-macro -unbound- (load-time-value *unbound*))) 9 | (defvar *unbound* (make-symbol "UNBOUND")) 10 | 11 | (defvar *eval-phases* 12 | #+(or clisp ecl) '(:compile-toplevel :execute) 13 | #-(or clisp ecl) '(:compile-toplevel :load-toplevel :execute)) 14 | 15 | (defun get-dynenv-var (var) 16 | (let ((dynenv-var (get var 'dynenv-var))) 17 | (cond 18 | (*within-captured-dynenv* 19 | (multiple-value-bind (dvalue foundp) 20 | (get-assoc var *var-space*) 21 | (cond 22 | (foundp 23 | dvalue) 24 | ((boundp dynenv-var) 25 | (symbol-value dynenv-var)) 26 | (t 27 | (error 'unbound-dynenv-macro-var :var var))))) 28 | (t 29 | (error 30 | "No macrodynamic environment has been captured to look up variable ~A" 31 | var))))) 32 | 33 | (defun (setf get-dynenv-var) (val var) 34 | (declare (ignore val)) 35 | (error 36 | "Illegal attempt to assign to macrodynamic variable ~A" 37 | var)) 38 | 39 | (defmacro def-dynenv-var (var &optional (val nil val-supplied)) 40 | (let ((gvar (gensym (symbol-name var)))) 41 | `(eval-when ,*eval-phases* 42 | (defvar ,gvar ,@(when val-supplied (list `(load-time-value ,val)))) 43 | (setf (get ',var 'dynenv-var) ',gvar) 44 | (define-symbol-macro ,var (get-dynenv-var ',var))))) 45 | 46 | (defun dynenv-function% (symbol) 47 | (let ((dynenv-fun (get symbol 'dynenv-fun))) 48 | (cond 49 | ((null dynenv-fun) 50 | (error "The macrodynamic function ~A is undefined." symbol)) 51 | ;;UNDEFINED-FUNCTION 52 | (*within-captured-dynenv* 53 | (multiple-value-bind (dvalue foundp) 54 | (get-assoc symbol *fun-space*) 55 | (cond 56 | (foundp 57 | dvalue) 58 | ((boundp dynenv-fun) 59 | (symbol-value dynenv-fun)) 60 | (t 61 | (error 'unbound-dynenv-macro-fun :fun symbol))))) 62 | (t 63 | (error 64 | "No macrodynamic environment has been captured to look up function ~A" 65 | symbol))))) 66 | 67 | (defmacro dynenv-function (name) 68 | `(dynenv-function% ',name)) 69 | 70 | (defmacro def-unbound-dynenv-fun (name) 71 | (let ((call-args (make-symbol "ARGS")) 72 | (gname (gensym (symbol-name name)))) 73 | `(eval-when ,*eval-phases* 74 | (defun ,name (&rest ,call-args) 75 | (apply (dynenv-function ,name) ,call-args)) 76 | (defvar ,gname) 77 | (setf (get ',name 'dynenv-fun) ',gname)))) 78 | 79 | (defmacro def-dynenv-fun (name args &body body) 80 | (let ((call-args (make-symbol "ARGS")) 81 | (gname (gensym (symbol-name name)))) 82 | `(eval-when ,*eval-phases* 83 | (defun ,name (&rest ,call-args) 84 | (apply (dynenv-function ,name) ,call-args)) 85 | (defvar ,gname (lambda (,@args) ,@body)) 86 | (setf (get ',name 'dynenv-fun) ',gname)))) 87 | 88 | (defmacro ct-let (bindings &body body) 89 | (with-gensyms (new-var-space accum item name value) 90 | (let ((gnames (loop for binding in bindings 91 | collect (gensym (symbol-name (first binding)))))) 92 | `(cond 93 | (*within-captured-dynenv* 94 | (let (,@(loop for binding in bindings 95 | for gname in gnames 96 | collect `(,gname ,(second binding)))) 97 | (let ((,new-var-space 98 | (reduce (lambda (,accum ,item) 99 | (destructuring-bind (,name . ,value) ,item 100 | (update-alist ,name ,value ,accum))) 101 | (list 102 | ,@(mapcar (lambda (binding gname) 103 | `(cons ',(first binding) ,gname)) 104 | bindings 105 | gnames)) 106 | :initial-value *var-space*))) 107 | `(symbol-macrolet ((var-space ,,new-var-space)) 108 | ,(let ((*var-space* ,new-var-space)) 109 | ,@body))))) 110 | (t 111 | (error 112 | "No macrodynamic environment has been captured to establish CT-LET bindings.")))))) 113 | 114 | (defmacro ct-let* (bindings &body body) 115 | (with-gensyms (new-var-space) 116 | `(cond 117 | (*within-captured-dynenv* 118 | ,(cond 119 | ((endp bindings) 120 | `(progn ,@body)) 121 | (t 122 | (destructuring-bind (name value) (first bindings) 123 | `(let ((,new-var-space 124 | (update-alist ',name ,value) *var-space*)) 125 | `(symbol-macrolet ((var-space ,,new-var-space)) 126 | ,(let ((*var-space* ,new-var-space)) 127 | (ct-let* (,@(rest bindings)) 128 | ,@body)))))))) 129 | (t 130 | (error 131 | "No macrodynamic environment has been captured to establish CT-LET* bindings."))))) 132 | 133 | (defmacro ct-flet (definitions &body body) 134 | (with-gensyms (new-fun-space new-args next-fun orig-args) 135 | `(cond 136 | (*within-captured-dynenv* 137 | ,(cond 138 | ((endp definitions) 139 | `(progn ,@body)) 140 | (t 141 | (destructuring-bind (name args &body fun-body) (first definitions) 142 | `(let ((,new-fun-space 143 | (update-alist 144 | ',name 145 | (let ((,next-fun 146 | (handler-case 147 | (dynenv-function ,name) 148 | (unbound-dynenv-macro-fun () 149 | -unbound-)))) 150 | (lambda (&rest ,orig-args) 151 | (flet ((call-next-dynenv-fun (&rest ,new-args) 152 | (case ,next-fun 153 | (-unbound- 154 | (error 155 | "No next dynenv function named: ~A" 156 | ',name)) 157 | (otherwise 158 | (apply ,next-fun 159 | (if ,new-args ,new-args ,orig-args)))))) 160 | (destructuring-bind ,args ,orig-args 161 | ,@fun-body)))) 162 | *fun-space*))) 163 | `(symbol-macrolet ((fun-space ,,new-fun-space)) 164 | ,(let ((*fun-space* ,new-fun-space)) 165 | (ct-flet (,@(rest definitions)) 166 | ,@body)))))))) 167 | (t 168 | (error 169 | "No macrodynamic environment has been captured to establish CT-FLET bindings."))))) 170 | 171 | (defmacro with-dynenv (environment &body body) 172 | "Macro for capturing a dynenv within another macro's body." 173 | (with-gensyms (var-expansion var-expanded-p fun-expansion fun-expanded-p) 174 | `(multiple-value-bind (,var-expansion ,var-expanded-p) 175 | (macroexpand-1 'var-space ,environment) 176 | (multiple-value-bind (,fun-expansion ,fun-expanded-p) 177 | (macroexpand-1 'fun-space ,environment) 178 | (let ((*var-space* (when ,var-expanded-p ,var-expansion)) 179 | (*fun-space* (when ,fun-expanded-p ,fun-expansion)) 180 | (*within-captured-dynenv* t)) 181 | ,@body))))) 182 | 183 | (defmacro def-dynenv-macro (name lambda-list &body body) 184 | (let* ((env-param (cadr (member '&environment lambda-list))) 185 | (actual-env-param (or env-param (gensym "ENV")))) 186 | (multiple-value-bind (remaining-forms declarations docstring) 187 | (parse-body body :documentation t :whole t) 188 | `(defmacro ,name (,@lambda-list 189 | ,@(unless env-param `(&environment ,actual-env-param))) 190 | ,@declarations 191 | ,@(ensure-list docstring) 192 | (with-dynenv ,actual-env-param 193 | ,@remaining-forms))))) 194 | 195 | (defmacro dynenv-macrolet (definitions &body body) 196 | `(macrolet 197 | (,@(loop for definition in definitions 198 | collect 199 | (destructuring-bind (name lambda-list &rest body) definition 200 | (let* ((env-param (cadr (member '&environment lambda-list))) 201 | (actual-env-param (or env-param (gensym "ENV")))) 202 | (multiple-value-bind (remaining-forms declarations docstring) 203 | (parse-body body :documentation t :whole t) 204 | `(,name (,@lambda-list 205 | ,@(unless env-param `(&environment ,actual-env-param))) 206 | ,@declarations 207 | ,@(ensure-list docstring) 208 | (with-dynenv ,actual-env-param 209 | ,@remaining-forms))))))) 210 | ,@body)) 211 | 212 | (define-condition unbound-dynenv-macro-var () 213 | ((var 214 | :initarg :var 215 | :accessor var))) 216 | 217 | (define-condition unbound-dynenv-macro-fun () 218 | ((fun 219 | :initarg :fun 220 | :accessor fun))) 221 | -------------------------------------------------------------------------------- /src/package.lisp: -------------------------------------------------------------------------------- 1 | (in-package :cl-user) 2 | 3 | (defpackage :macrodynamics 4 | (:use :cl :alexandria) 5 | (:export #:ct-let 6 | #:ct-let* 7 | #:ct-flet 8 | #:call-next-dynenv-fun 9 | #:def-dynenv-macro 10 | #:dynenv-macrolet 11 | #:with-dynenv 12 | #:def-dynenv-var 13 | #:def-dynenv-fun 14 | #:def-unbound-dynenv-fun 15 | #:dynenv-function 16 | #:unbound-dynenv-macro-var 17 | #:unbound-dynenv-macro-fun)) 18 | 19 | (in-package :macrodynamics) 20 | 21 | (defparameter *system-directory* (asdf:system-source-directory "macrodynamics")) 22 | -------------------------------------------------------------------------------- /src/util.lisp: -------------------------------------------------------------------------------- 1 | (in-package :macrodynamics) 2 | 3 | (defun get-assoc (item alist &rest keys &key key test test-not) 4 | "Like ASSOC but returns the cdr instead of the whole matching cons and 5 | a second value indicating success or failure." 6 | (declare (ignore key test test-not)) 7 | (let ((result (apply #'assoc item alist keys))) 8 | (cond 9 | ((null result) 10 | (values nil nil)) 11 | (t 12 | (values (cdr result) t))))) 13 | 14 | (defun update-alist (item value alist) 15 | "Non-destructively replace cdr of the cons whose car matches ITEM in ALIST 16 | with VALUE, or insert a new cons if no car matches ITEM." 17 | (destructuring-bind (replacedp new-alist) 18 | (reduce (lambda (accum item) 19 | (destructuring-bind (replacedp new-alist) accum 20 | (cond 21 | (replacedp 22 | (list replacedp (list* item new-alist))) 23 | ((eql item (car item)) 24 | (list t (list* (cons item value) new-alist))) 25 | (t 26 | (list replacedp (list* item new-alist)))))) 27 | alist 28 | :initial-value (list nil nil)) 29 | (cond 30 | (replacedp 31 | (reverse new-alist)) 32 | (t 33 | (list* (cons item value) alist))))) 34 | -------------------------------------------------------------------------------- /test/macrodynamics-test.lisp: -------------------------------------------------------------------------------- 1 | (in-package :macrodynamics/test) 2 | 3 | (defmacro wrap-let-map (bindings &body body) 4 | `(let-map ,bindings ,@body)) 5 | 6 | (deftest test-contextual-dsl () 7 | (with-generators ((x (generator (integer))) 8 | (y (generator (integer)))) 9 | (let-map ((a (+ x x))) 10 | (let ((z 3)) 11 | (declare (ignore z)) 12 | (wrap-let-map ((b (+ a a))) 13 | (let ((check-it:*num-trials* 10)) 14 | (is 15 | (check-that (progn 16 | (format t "~&~A ~A ~A ~A~%" x y a b) 17 | (= a a)))))))))) 18 | 19 | (def-dynenv-var **test-var-same-file** 0) 20 | 21 | (deftest test-dynenv-macrolet-same-file () 22 | (is 23 | (equal 24 | (dynenv-macrolet ((herp (&body body) 25 | (ct-let ((**test-var-same-file** 26 | (1+ **test-var-same-file**))) 27 | `(progn ,@body))) 28 | (derp (thing) 29 | `(list* ,**test-var-same-file** ,thing))) 30 | (derp (herp (derp (herp (derp (herp (derp (herp (derp nil)))))))))) 31 | (list 0 1 2 3 4)))) 32 | 33 | (deftest test-dynenv-macrolet-different-file () 34 | (is 35 | (equal 36 | (dynenv-macrolet ((herp (&body body) 37 | (ct-let ((**test-var-different-file** 38 | (1+ **test-var-different-file**))) 39 | `(progn ,@body))) 40 | (derp (thing) 41 | `(list* ,**test-var-different-file** ,thing))) 42 | (derp (herp (derp (herp (derp (herp (derp (herp (derp nil)))))))))) 43 | (list 0 1 2 3 4)))) 44 | -------------------------------------------------------------------------------- /test/macros.lisp: -------------------------------------------------------------------------------- 1 | (in-package :macrodynamics/test) 2 | 3 | (def-dynenv-var **generator-symbols** nil) 4 | (def-dynenv-var **mappings** nil) 5 | 6 | (def-dynenv-fun **blurf** (&rest x) (apply #'union x)) 7 | 8 | (def-dynenv-var **test-var-different-file** 0) 9 | 10 | #+nil 11 | (def-dynenv-macro with-generators (bindings &body body) 12 | (let ((symbols (mapcar #'first bindings))) 13 | `(let (,@bindings) 14 | ,(ct-let ((**generator-symbols** 15 | (**blurf** symbols **generator-symbols**))) 16 | (ct-flet ((**blurf** (&rest x) (apply #'gensym x))) 17 | `(progn ,@body)))))) 18 | 19 | (defmacro with-generators (bindings &body body &environment env) 20 | (with-dynenv env 21 | (let ((symbols (mapcar #'first bindings))) 22 | `(let (,@bindings) 23 | ,(ct-let ((**generator-symbols** 24 | (**blurf** symbols **generator-symbols**))) 25 | (ct-flet ((**blurf** (&rest x) (apply #'gensym x))) 26 | `(progn ,@body))))))) 27 | 28 | #+nil 29 | (def-dynenv-macro let-map (bindings &body body) 30 | (let ((binding-symbols 31 | (loop for (sym form) in bindings collect sym)) 32 | (binding-gensyms 33 | (loop for (sym form) in bindings collect (**blurf** (symbol-name sym))))) 34 | (let* ((mapping-symbols (mapcar #'first **mappings**)) 35 | (new-mappings 36 | (loop for symbol in binding-symbols 37 | for gensym in binding-gensyms 38 | collect 39 | (list symbol gensym 40 | ;; a mapping can depend on any generator or mapping bound above 41 | (append **generator-symbols** mapping-symbols))))) 42 | `(flet (,@(loop for (name . map-body) in bindings 43 | for gensym in binding-gensyms 44 | collect `(,gensym (,@**generator-symbols** 45 | ,@mapping-symbols) 46 | (declare (ignorable ,@**generator-symbols** 47 | ,@mapping-symbols)) 48 | ,@map-body))) 49 | ,(ct-let ((**mappings** 50 | (union new-mappings **mappings** :key #'first))) 51 | `(progn ,@body)))))) 52 | 53 | (defmacro let-map (bindings &body body &environment env) 54 | (with-dynenv env 55 | (let ((binding-symbols 56 | (loop for (sym form) in bindings collect sym)) 57 | (binding-gensyms 58 | (loop for (sym form) in bindings collect (**blurf** (symbol-name sym))))) 59 | (let* ((mapping-symbols (mapcar #'first **mappings**)) 60 | (new-mappings 61 | (loop for symbol in binding-symbols 62 | for gensym in binding-gensyms 63 | collect 64 | (list symbol gensym 65 | ;; a mapping can depend on any generator or mapping bound above 66 | (append **generator-symbols** mapping-symbols))))) 67 | `(flet (,@(loop for (name . map-body) in bindings 68 | for gensym in binding-gensyms 69 | collect `(,gensym (,@**generator-symbols** 70 | ,@mapping-symbols) 71 | (declare (ignorable ,@**generator-symbols** 72 | ,@mapping-symbols)) 73 | ,@map-body))) 74 | ,(ct-let ((**mappings** 75 | (reduce (lambda (accum item) 76 | (destructuring-bind (symbol . data) item 77 | (macrodynamics::update-alist symbol data accum))) 78 | new-mappings 79 | :initial-value **mappings**))) 80 | `(progn ,@body))))))) 81 | 82 | #+nil 83 | (def-dynenv-macro check-that 84 | (expr 85 | &rest keys 86 | &key 87 | examples 88 | (shrink-failures t) 89 | (random-state t random-state-supplied) 90 | (regression-id nil regression-id-supplied) 91 | (regression-file nil regression-file-supplied)) 92 | (declare (ignore examples shrink-failures random-state 93 | random-state-supplied regression-id regression-id-supplied 94 | regression-file regression-file-supplied)) 95 | (with-gensyms (agg) 96 | `(check-it::check-it% 97 | ',expr 98 | (generator (tuple ,@**generator-symbols**)) 99 | (lambda (,agg) 100 | ;; here the generator vars are rebound from generators to generated values 101 | (destructuring-bind (,@**generator-symbols**) ,agg 102 | (declare (ignorable ,@**generator-symbols**)) 103 | ;; bind mappings from innermost to outermost 104 | (let* (,@(loop for (sym fun args) in (reverse **mappings**) 105 | collect 106 | ;; generated values and previously-bound mappings 107 | ;; are passed to mapping funs 108 | `(,sym (,fun ,@args)))) 109 | (declare (ignorable ,@(mapcar #'first **mappings**))) 110 | ,expr))) 111 | ,@keys))) 112 | 113 | (defmacro check-that 114 | (expr 115 | &rest keys 116 | &key 117 | examples 118 | (shrink-failures t) 119 | (random-state t random-state-supplied) 120 | (regression-id nil regression-id-supplied) 121 | (regression-file nil regression-file-supplied) 122 | &environment env) 123 | (declare (ignore examples shrink-failures random-state 124 | random-state-supplied regression-id regression-id-supplied 125 | regression-file regression-file-supplied)) 126 | (with-dynenv env 127 | (with-gensyms (agg) 128 | `(check-it::check-it% 129 | ',expr 130 | (generator (tuple ,@**generator-symbols**)) 131 | (lambda (,agg) 132 | ;; here the generator vars are rebound from generators to generated values 133 | (destructuring-bind (,@**generator-symbols**) ,agg 134 | (declare (ignorable ,@**generator-symbols**)) 135 | ;; bind mappings from innermost to outermost 136 | (let* (,@(loop for (sym fun args) in (reverse **mappings**) 137 | collect 138 | ;; generated values and previously-bound mappings 139 | ;; are passed to mapping funs 140 | `(,sym (,fun ,@args)))) 141 | (declare (ignorable ,@(mapcar #'first **mappings**))) 142 | ,expr))) 143 | ,@keys)))) 144 | -------------------------------------------------------------------------------- /test/package.lisp: -------------------------------------------------------------------------------- 1 | (in-package :cl-user) 2 | 3 | (defpackage :macrodynamics/test 4 | (:use :cl 5 | :macrodynamics 6 | :fiasco 7 | :alexandria 8 | :check-it)) 9 | 10 | (fiasco:defsuite 11 | (fiasco-suites::macrodynamics/test :bind-to-package :macrodynamics/test 12 | :in fiasco-suites::all-tests)) 13 | 14 | (in-package :macrodynamics/test) 15 | 16 | (defparameter *system-directory* (asdf:system-source-directory "macrodynamics/test")) 17 | --------------------------------------------------------------------------------