| author | Alan Dipert
<alan@dipert.org> 2026-11-06 21:32:57 UTC |
| committer | Alan Dipert
<alan@dipert.org> 2026-11-06 21:32:57 UTC |
| parent | 45a514210cf79eeddbd3894c6ed42dff9683a8b8 |
| src/com/tailrecursion/nanopass.clj | +21 | -7 |
| test/com/tailrecursion/nanopass/passes.clj | +5 | -3 |
diff --git a/src/com/tailrecursion/nanopass.clj b/src/com/tailrecursion/nanopass.clj index 1c609db..051be79 100644 --- a/src/com/tailrecursion/nanopass.clj +++ b/src/com/tailrecursion/nanopass.clj @@ -62,11 +62,12 @@ result-type (if target (language/type-name target (second to)) (language/qualify *ns* #{} to))] (with-meta (pass/definition - {:name (if (locals name) name (symbol (str (ns-name *ns*)) (str name))) + {:name (symbol (str (ns-name *ns*)) (str name)) :source source :target target :from (second from) :to (when target (second to)) :params (mapv #(language/qualify *ns* #{} %) args) :arguments arguments :result-type result-type - :processors (into {} (map (fn [[nt processor]] [nt (if (locals processor) processor (language/qualify *ns* #{} processor))])) processors) + :processors (into (if-let [self (locals name)] {(second from) self} {}) + (map (fn [[nt processor]] [nt (or (locals processor) (language/qualify *ns* #{} processor))])) processors) :body? body} clauses) (meta form)))) @@ -89,17 +90,30 @@ (language/fail :invalid-pass &form "Expected distinct processor names")) ;; Typed Clojure 1.3 collects letfn bindings in a map before matching its ;; positional annotations. Emit that same order, including groups over eight. - (let [functions (vals (into {} (map (fn [[name options arguments & clauses :as form]] - [name (pass-definition locals form name options arguments clauses)])) definitions)) + (let [functions + (vals + (into {} + (for [[name options arguments & clauses :as form] definitions + :let [captures (into {} (for [arg arguments :when (locals arg)] [arg (gensym "processor__")])) + processors (merge (zipmap names names) captures) + [_ id attributes args body] (pass-definition processors form name options arguments clauses) + parameters (mapv #(if (captures %) (with-meta (gensym "argument__") (meta %)) %) args) + ;; Save shadowed processors before restoring source parameter names. + body (if (seq captures) + `(let [~@(mapcat (fn [[name saved]] [saved name]) captures) + ~@(mapcat (fn [arg parameter] + (when (not= arg parameter) [(with-meta arg nil) parameter])) args parameters)] + ~body) body)]] + [name (with-meta (list 'defn id (assoc attributes :arglists (list 'quote (list args))) parameters body) + (meta form))]))) signatures (mapv #(second (::signature (nth % 2))) functions)] `(letfn [~@(map (fn [[_ name _ args body :as form]] (with-meta (list name args body) (meta form))) functions)] ;; Typed Clojure's letfn annotation is an inert quoted vector, in ;; binding order. It imposes no checker dependency at runtime. '~signatures - ~@(map (fn [[_ name attributes args :as form]] - `(def ~(with-meta name (assoc (merge (meta form) attributes) - :arglists (list 'quote (list args)))) ~name)) functions))))) + ~@(map (fn [[_ name attributes :as form]] + `(def ~(with-meta name (merge (meta form) attributes)) ~name)) functions))))) (defmacro ann-passes "Emit checker signatures stored by defpass. The generated function bodies diff --git a/test/com/tailrecursion/nanopass/passes.clj b/test/com/tailrecursion/nanopass/passes.clj index 9272bcb..92c4dcb 100644 --- a/test/com/tailrecursion/nanopass/passes.clj +++ b/test/com/tailrecursion/nanopass/passes.clj @@ -5,14 +5,16 @@ [typed.clojure :as-alias t])) (np/defpasses + ;; Parameters deliberately shadow processor names. Generated traversal must + ;; still call the processors, while explicit clauses see the parameters. (lower {:from [f/Source Expr] :to [f/Core Expr] :processors {Binding lower-binding}} - [node] - :assign {:op :write :name (:name (:binding node)) :value (lower (:value node))}) + [lower-binding] + :assign {:op :write :name (:name (:binding lower-binding)) :value (lower (:value lower-binding))}) (lower-binding {:from [f/Source Binding] :to [f/Core Binding] :processors {Expr lower}} - [node])) + [lower])) (np/defpasses (rename