(defn quo [expr] `(quote ~expr))
(defn union [s1 s2]
(if (empty? s2)
s1
(apply conj s1 s2)))
(def sfrms '#{def if do quote var recur throw monitor-enter monitor-exit . new
set!})
(defn map-ps [f coll]
(if (map? coll)
(into (empty coll)
(map (fn [[k v]] [(f k) (f v)]) coll))
(if (or (vector? coll) (set? coll))
(into (empty coll) (map f coll))
(map f coll))))
(declare macrolet-v)
(defmacro macrolet* [shadowlist fnspecs & body]
(let [locals (keys &env)
gensyms (for [_ locals] (gensym))
qlocals (map quo (for [_ locals] (gensym)))
lqmap (zipmap locals qlocals)
qgensyms (map quo gensyms)
fnmap (reduce
(fn [fnm [name argl & body]]
(assoc fnm name
(eval
`(fn ~name ~argl
(let ~(vec
(mapcat identity
(apply dissoc lqmap (flatten argl))))
`(let ~~(vec (interleave qlocals qgensyms))
~~@body))))))
{}
fnspecs)
fnames (set (keys fnmap))
proc (fn proc [form fnames locals]
(if (or (not (coll? form)) (empty? form))
form
(if-not (seq? form)
(map-ps #(proc % fnames locals) form)
(let [op (first form)]
(cond
(= op 'fn*) (let [nls (mapcat
(fn [f]
(if (symbol? f)
f
(first f)))
(rest form))]
(map
#(proc %
(apply disj fnames nls)
(union locals nls))
form))
(or
(= op 'let*)
(= op 'loop*)) (let [nls (take-nth 2 (second form))]
(map
#(proc %
(apply disj fnames nls)
(union locals nls))
form))
(= op 'try) (map-ps
(fn [subf]
(if (or
(not (seq? subf))
(empty? subf))
(proc subf fnames locals)
(condp = (first subf)
'finally
(cons 'finally
(map #(proc % fnames locals)
(rest subf)))
'catch
(if (>= (count subf) 3)
(conj
(map
#(proc %
(disj fnames
(nth subf 2))
(conj locals
(nth subf 2)))
(drop 3 subf))
(nth subf 2)
(second subf)
(first subf))
(proc subf fnames locals))
(proc subf fnames locals))))
form)
(contains? fnames op) (proc
(apply (fnmap op)
(rest form))
fnames locals)
(contains? locals op) (map-ps
#(proc % fnames locals)
form)
:else (let [nested (if (symbol? op)
(if-let [v (ns-resolve *ns* op)]
(if (.isBound v)
(= @v macrolet-v))))]
(if nested
(proc
(macroexpand-1
`(macrolet*
~(union locals fnames)
~@(rest form)))
fnames locals)
(let [f (macroexpand-1 form)]
(if-not (= f form)
(recur f fnames locals)
(map-ps #(proc % fnames locals)
form))))))))))]
`(let ~(vec (interleave gensyms locals))
~@(map #(proc % fnames (union shadowlist locals)) body))))
(defmacro macrolet [fnspecs & body]
`(macrolet* #{} ~fnspecs ~@body))
(def macrolet-v @(ns-resolve *ns* 'macrolet))
user=> (let [x 2]
(macrolet [(foo [y] `(println ~x ~y)) (bar [x] `(println
"macro bar" ~x))]
(println "bar-1")
(bar 42)
(let [x 3 bar (fn [x] (str "fn bar " x))]
(println "foo-1")
(foo x)
(println "bar-2")
(bar 42))))
bar-1
macro bar 42
foo-1
2 3
bar-2
"fn bar 42"
user=>
As you can see:
* The ~x in foo correctly expands to 3, capturing the local lexical
binding of x at foo. The macro bodies are lexical closures.
* The [x 3] binding local where foo is expanded does not screw
that up.
* The [x] argument to the bar macro correctly shadows the
outer binding to 2.
* The binding of bar to a local function in the inner let correctly
shadows the macro bar.
Since there's no compiler support for local macros, this works by
actually parsing the code body and finding occurrences of the macro
names (in the example foo and bar) and expanding those forms using the
supplied bodies, which are converted at macroexpansion time into
runnable functions using eval. The proc function does this manual
macroexpansion. It checks operators for being special forms, ensuring
that e.g. (macrolet [(def [x] x)]) cannot incorrectly shadow a special
form. Also, when it recurses into let*, loop*, fn*, and a catch in a
try, it lets their local bindings shadow the macros (by dissocing them
from a local copy of a set of local macro names) -- let*s and loop*s
odd-numbered binding-vector positions, the argument name vectors
inside fn*, the local fn name inside the (fn* name ([args] body) ...)
version of fn*, and the exception name inside catch. It also prevents
macrolets from shadowing catch and finally inside try while correctly
letting catch and finally refer to a macrolet elsewhere (as they can
refer to vars and the like elsewhere normally). In the process it also
expands all normal macros in the body.
It's worth noting that if you nest macrolets, the outer macrolet will
cause the inner macrolet to be fully macroexpanded (unless "macrolet"
itself is shadowed!) and will then grovel over the expansion applying
the outer set of local macros. This causes the need to do some tricks
(involving macrolet*, shadowlist, macrolet-v, and the "nested" case)
to handle
nested macrolets correctly:
user=> (defmacro foo [] 3)
#'user/foo
user=> (macrolet [(foo [] 1)] (macrolet [(bar [] 2)] (foo)))
1
The outer macrolet works on the foo call in the inner one.
user=> (macrolet [(foo [] 1)] (macrolet [(bar [] 2)] (macrolet [(foo
[] 42)] (foo))))
42
The inner foo macrolet correctly shadows the outer.
user=> (macrolet [(foo [] 1)] (let [bar (fn [x y] 17) macrolet (fn [x
y] y)] (macrolet [(bar [+ *] 42)] (bar 1 2))))
17
This one is complicated. It shadows macrolet itself, and the innermost
macrolet form actually just calls a two-argument function with a
vector containing 17 and the number 17, which function returns the
latter number. If macrolet had not been shadowed, it would have
shadowed bar and the subsequent bar call would have expanded to 42
which would have been the output instead of 17.
This implementation may have a few unhandled edge cases. If you find
any, let me know.
--
You received this message because you are subscribed to the Google
Groups "Clojure" group.
To post to this group, send email to clojure@googlegroups.com
Note that posts from new members are moderated - please be patient with your
first post.
To unsubscribe from this group, send email to
clojure+unsubscr...@googlegroups.com
For more options, visit this group at
http://groups.google.com/group/clojure?hl=en
