Significantly refactored and expanded to deal with various special
forms, including case, reify, and deftype. Some edge cases fixed, all
the ones I could find -- notably, the first test below the code
confirms the fixing of one of these. Let me know of any more edge
cases you find that need handling differently.
There's one major limitation: macrolet macros are invisible inside
macrolet macros. That is, this won't work:
(let [x 2]
(macrolet [(foo [x] `(list 'quote ~x))
(bar [y] `(println ~x ~(foo y)))]
(bar sym)))
to give this:
2 sym
nil
Code:
(defn quo [expr] `(quote ~expr))
(def sfrms-ignoreall '#{quote var})
(def sfrms-ignore2 '#{new set! def})
(def sfrms-ignore1 '#{if do recur throw monitor-enter
monitor-exit .})
(defn union [s1 s2]
(if (empty? s2)
s1
(apply conj s1 s2)))
(declare proc)
(defn proch [form fnmap locals newlocals skip]
(let [fnmap (apply dissoc fnmap newlocals)
locals (union locals newlocals)]
(if skip
(let [[skipped procd] (split-at skip form)]
(concat
skipped
(map #(proc % fnmap locals) procd)))
(proc form fnmap locals))))
(declare macrolet-v)
(defn proc [form fnmap locals]
(if (or (not (coll? form)) (empty? form))
form
(if-not (seq? form)
(map-ps #(proc % fnmap locals) form)
(let [op (first form)]
(cond
(= op 'fn*) (if (vector? (second form))
(let [nls (second form)]
(proch form fnmap locals nls 2))
(let [fname (nth form 1 nil)
[nls skip] (if (symbol? fname)
[[fname] 2]
[nil 1])
[skipped procd] (split-at skip form)]
(concat
skipped
(map
(fn [[argl & rst]]
(cons argl
(proch rst fnmap locals
(concat argl nls) 0)))
procd))))
(or
(= op 'let*)
(= op 'letfn*)
(= op 'loop*)) (let [nls (take-nth 2 (second form))]
(conj
(proch (rest (rest form)) fnmap
locals nls 0)
(loop [nls #{}
out []
in (seq (partition 2
(second form)))]
(if in
(let [[nm expr] (first in)]
(recur
(conj nls nm)
(conj out
nm
(proch expr fnmap
locals nls nil))
(next in)))
out))
op))
(= op 'try) (map
(fn [subf]
(if (or
(not (seq? subf))
(empty? subf))
(proc subf fnmap locals)
(condp = (first subf)
'finally (proch subf fnmap
locals nil 1)
'catch (let [nl (nth subf 2 nil)
nls (if nl [nl])]
(proch subf fnmap
locals nl 3))
(proc subf fnmap locals))))
form)
('#{deftype* reify*} op) (let [nls (if (= op 'deftype*)
(nth form 3 nil))
spos (if (= op 'deftype*)
6
2)
[skipped procd] (split-at
spos
form)]
(concat
skipped
(map
(fn [subf]
(if-not (seq? subf)
subf
(let [[fnm as] subf
nls (conj
(concat
nls as)
fnm)]
(proch subf fnmap
locals nls 2))))
procd)))
(= op 'case*) (let [[skipd procd] (split-at 6 form)
[d m skip] procd]
(concat
skipd
[(proc d fnmap locals)]
[(into {}
(map
(fn [[k [cl expr]]]
[k (first {cl (proc expr
fnmap locals)})])
m))]
[skip]))
(sfrms-ignoreall op) form
(sfrms-ignore2 op) (if (>= (count form) 2)
(conj
(map #(proc % fnmap locals)
(rest (rest form)))
(second form)
(first form)))
(sfrms-ignore1 op) (conj
(map #(proc % fnmap locals)
(rest form))
(first form))
(fnmap op) (proc
(apply (fnmap op)
(rest form))
fnmap locals)
(locals op) (map-ps
#(proc % fnmap 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 (keys fnmap))
~@(rest form)))
fnmap locals)
(let [f (macroexpand-1 form)]
(if-not (= f form)
(recur f fnmap locals)
(map-ps #(proc % fnmap locals)
form))))))))))
(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)]
`(let ~(vec (interleave gensyms locals))
~@(map
#(proc % fnmap (union (set shadowlist) locals))
body))))
(defmacro macrolet [fnspecs & body]
`(macrolet* #{} ~fnspecs ~@body))
(def macrolet-v @(ns-resolve *ns* 'macrolet))
New tests (let binding expressions, function locals, case, reify, deftype):
Let/loop variables shadow macro for later expressions in binding
vector, except own, but not earlier ones:
user=> (macrolet [(x [y]
`(do (println ~y)
(fn [a#] (inc a#))))]
(let [x (x 3) x (x 3)] x))
3
4
Function locals shadow macro:
user=> (macrolet [(x [a] `(println ~a))]
((fn
([x]
(x 42))
([y z]
(x "boo!")
(+ y z)))
inc))
43
Function locals in one arity do not shadow macro in another:
user=> (macrolet [(x [a] `(println ~a))]
((fn
([x]
(+ 3 x))
([y z]
(x "boo!")
(+ y z)))
3 4))
boo!
7
Function name shadows macro in named fn:
user=> (macrolet [(x [a] `(println ~a))]
((fn x
([x]
(+ 3 x))
([y z]
(println (x 12))
(+ y z)))
3 4))
15
7
Case still works despite case* expecting naked MapEntry objects (as
map vals), and case labels that are unquoted local macro names are
handled correctly:
user=> (macrolet [(foo [x] (println "macro expanded") `(* 3 ~x))]
(case 'foo
foo "case foo"
"default"))
"case foo"
Local macros are expanded in cases, including default case:
user=> (macrolet [(foo [x] (println "macro expanded") `(* 3 ~x))]
(case 'bar
foo "case foo"
(foo 3)))
macro expanded
9
user=> (macrolet [(foo [x] (println "macro expanded") `(* 3 ~x))]
(case 'foo
foo (foo 3)
"bar"))
macro expanded
9
Instance variables shadow macro in deftype:
user=> (defprotocol IFoo (foo [this]) (bar [this that]))
user.IFoo
user=> (macrolet [(x [a] `(println ~a))]
(deftype Foo [x]
IFoo
(foo [this]
(x 42))
(bar [this y]
(+ (.foo this) y))))
user.Foo
user=> (.bar (Foo. (constantly 42)) 8)
50
Local variables shadow macro in deftype and reify methods; also the
fn* form #() expands into is handled correctly:
user=> (defprotocol IFoo (foo [this]) (bar [this y]))
user.IFoo
user=> (macrolet [(x [a] `(println ~a))]
(deftype Foo [y]
IFoo
(foo [this]
y)
(bar [this x]
(x this))))
user.Foo
user=> (.bar (Foo. 42) #(inc (.foo %)))
43
user=> (macrolet [(x [a] `(println ~a))]
(.bar
(reify
IFoo
(foo [this]
42)
(bar [this x]
(x this))) #(inc (.foo %))))
43
Macro does not clobber deftype or reify method of same name:
user=> (defprotocol IFoo (foo [this]) (bar [this y]))
user.IFoo
user=> (macrolet [(foo [a b] `(println ~a ~b))]
(deftype Foo [y]
IFoo
(foo [this]
y)
(bar [this x]
(x this))))
user.Foo
user=> (.bar (Foo. 42) #(inc (.foo %)))
43
user=> (macrolet [(foo [a b] `(println ~a ~b))]
(.bar
(reify
IFoo
(foo [this]
42)
(bar [this x]
(x this))) #(inc (.foo %))))
43
Older tests (basic locals shadowing, nesting, etc. behavior):
Local variables in let/loop body shadow macro; macro body closes over
local bindings correctly:
user=> (defmacro foo [x] 3)
#'user/foo
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"
Outer macrolet shadows global macro within inner macrolet:
user=> (defmacro foo [x] 3)
#'user/foo
user=> (macrolet [(foo [] 1)]
(macrolet [(bar [] 2)]
(foo)))
1
Inner macrolet shadows outer macrolet and global macro with
intervening macrolet:
user=> (defmacro foo [x] 3)
#'user/foo
user=> (macrolet [(foo [] 1)]
(macrolet [(bar [] 2)]
(macrolet [(foo [] 42)]
(foo))))
42
Macrolet itself is shadowed by locals named "macrolet" within a macrolet:
user=> (macrolet [(foo [] 1)]
(let [bar (fn [x y] 17)
macrolet (fn [x y] y)]
(macrolet [(bar [+ *] 42)]
(bar 1 2))))
17
--
You received this message because you are subscribed to the Google
Groups "Clojure" group.
To post to this group, send email to [email protected]
Note that posts from new members are moderated - please be patient with your
first post.
To unsubscribe from this group, send email to
[email protected]
For more options, visit this group at
http://groups.google.com/group/clojure?hl=en
