Skip to content


Subversion checkout URL

You can clone with
Download ZIP
Fetching contributors…

Cannot retrieve contributors at this time

445 lines (393 sloc) 16.528 kb
;; Copyright (c) Nicola Mometto, Rich Hickey & contributors.
;; The use and distribution terms for this software are covered by the
;; Eclipse Public License 1.0 (
;; which can be found in the file epl-v10.html at the root of this distribution.
;; By using this software in any fashion, you are agreeing to be bound by
;; the terms of this license.
;; You must not remove this notice, or any other, from this software.
"Analyzer for clojure code, extends tools.analyzer with JVM specific passes/forms"
(:refer-clojure :exclude [macroexpand-1 macroexpand])
(:require [
:as ana
:refer [analyze analyze-in-env wrapping-meta analyze-fn-method]
:rename {analyze -analyze}]
[utils :refer [ctx resolve-var -source-info resolve-ns]]
[ast :refer [walk prewalk postwalk cycling]]]
[ :refer :all :exclude [box]]
[source-info :refer [source-info]]
[cleanup :refer [cleanup]]
[elide-meta :refer [elide-meta]]
[warn-earmuff :refer [warn-earmuff]]
[collect :refer [collect collect-closed-overs]]
[add-binding-atom :refer [add-binding-atom]]
[uniquify :refer [uniquify-locals]]]
[box :refer [box]]
[constant-lifter :refer [constant-lift]]
[annotate-branch :refer [annotate-branch]]
[annotate-loops :refer [annotate-loops]]
[annotate-methods :refer [annotate-methods]]
[annotate-class-id :refer [annotate-class-id]]
[annotate-internal-name :refer [annotate-internal-name]]
[fix-case-test :refer [fix-case-test]]
[clear-locals :refer [clear-locals]]
[classify-invoke :refer [classify-invoke]]
[validate :refer [validate]]
[infer-tag :refer [infer-tag ensure-tag]]
[annotate-tag :refer [annotate-tag]]
[validate-loop-locals :refer [validate-loop-locals]]
[analyze-host-expr :refer [analyze-host-expr]]
[warn-on-reflection :refer [warn-on-reflection]]]
[clojure.core.memoize :refer [memo-clear!]])
(:import clojure.lang.IObj))
(def specials
"Set of the special forms for clojure in the JVM"
(into ana/specials
'#{var monitor-enter monitor-exit clojure.core/import* reify* deftype* case*}))
(defmulti parse
"Extension to tools.analyzer/-parse for JVM special forms"
(fn [[op & rest] env] op))
(defmethod parse :default
[form env]
(ana/-parse form env))
(defn empty-env
"Returns an empty env map"
{:context :expr :locals {} :ns (ns-name *ns*)
:namespaces (atom
(into {} (mapv #(vector (ns-name %)
{:mappings (ns-map %)
:aliases (reduce-kv (fn [a k v] (assoc a k (ns-name v)))
{} (ns-aliases %))
:ns (ns-name %)})
(defn desugar-host-expr [form env]
(symbol? form)
(let [target (maybe-class (namespace form))
field (symbol (name form))]
(if (and target (not (resolve-ns (symbol (namespace form)) env))) ;; Class/field
(with-meta (list '. target (symbol (str "-" field))) ;; transform to (. Class -field)
(meta form))
(seq? form)
(let [[op & expr] form]
(if (symbol? op)
(let [opname (name op)
opns (namespace op)]
(.startsWith opname ".") ; (.foo bar ..)
(let [[target & args] expr
target (if-let [target (and (not (get (:locals env) target))
(maybe-class target))]
(with-meta (list 'clojure.core/identity target)
{:tag 'java.lang.Class})
args (list* (symbol (subs opname 1)) args)]
(with-meta (list '. target (if (= 1 (count args)) ;; we don't know if (.foo bar) is
(first args) args)) ;; a method call or a field access
(meta form)))
(and (maybe-class opns)
(not (resolve-ns (symbol opns) env))) ; (class/field ..)
(let [target (maybe-class opns)
op (symbol opname)]
(with-meta (list '. target (if (zero? (count expr))
(list* op expr)))
(meta form)))
(.endsWith opname ".") ;; (class. ..)
(with-meta (list* 'new (symbol (subs opname 0 (dec (count opname)))) expr)
(meta form))
:else form))
:else form))
(defn macroexpand-1
"If form represents a macro form or an inlineable function,
returns its expansion, else returns form."
[form env]
(if (seq? form)
(let [[op & args] form]
(if (specials op)
(let [v (resolve-var op env)
m (meta v)
local? (-> env :locals (get op))
macro? (and (not local?) (:macro m)) ;; locals shadow macros
inline-arities-f (:inline-arities m)
inline? (and (not local?)
(or (not inline-arities-f)
(inline-arities-f (count args)))
(:inline m))
t (:tag m)]
(apply v form env (rest form)) ; (m &form &env & args)
(let [res (apply inline? args)]
(if (and t (instance? IObj res))
(vary-meta res assoc :tag t)
(desugar-host-expr form env)))))
(desugar-host-expr form env)))
(defn create-var
"Creates a Var for sym and returns it.
The Var gets interned in the env namespace."
[sym {:keys [ns]}]
(let [v (or (find-var (symbol (str ns) (name sym)))
(intern ns (with-meta sym {})))]
(doto v
(reset-meta! (or (meta sym) {})))))
(defmethod parse 'var
[[_ var :as form] env]
(when-not (= 2 (count form))
(throw (ex-info (str "Wrong number of args to var, had: " (dec (count form)))
(merge {:form form}
(-source-info form env)))))
(if-let [var (resolve-var var env)]
{:op :the-var
:env env
:form form
:var var}
(throw (ex-info (str "var not found: " var) {:var var}))))
(defmethod parse 'monitor-enter
[[_ target :as form] env]
(when-not (= 2 (count form))
(throw (ex-info (str "Wrong number of args to monitor-enter, had: " (dec (count form)))
(merge {:form form}
(-source-info form env)))))
{:op :monitor-enter
:env env
:form form
:target (-analyze target (ctx env :expr))
:children [:target]})
(defmethod parse 'monitor-exit
[[_ target :as form] env]
(when-not (= 2 (count form))
(throw (ex-info (str "Wrong number of args to monitor-exit, had: " (dec (count form)))
(merge {:form form}
(-source-info form env)))))
{:op :monitor-exit
:env env
:form form
:target (-analyze target (ctx env :expr))
:children [:target]})
(defmethod parse 'clojure.core/import*
[[_ class :as form] env]
(when-not (= 2 (count form))
(throw (ex-info (str "Wrong number of args to import*, had: " (dec (count form)))
(merge {:form form}
(-source-info form env)))))
{:op :import
:env env
:form form
:class class})
(defn analyze-method-impls
[[method [this & params :as args] & body :as form] env]
(when-let [error-msg (cond
(not (symbol? method))
(str "Method method must be a symbol, had: " (class method))
(not (vector? args))
(str "Parameter listing should be a vector, had: " (class args))
(not (first args))
(str"Must supply at least one argument for 'this' in: " method))]
(throw (ex-info error-msg
(merge {:form form
:in (:this env)
:method method
:args args}
(-source-info form env)))))
(let [meth (cons (vec params) body) ;; this is an implicit arg
this-expr {:name this
:env env
:form this
:op :binding
:o-tag (:this env)
:tag (:this env)
:local :this}
env (assoc-in (dissoc env :this) [:locals this] this-expr)
method-expr (analyze-fn-method meth env)]
(assoc (dissoc method-expr :variadic?)
:op :method
:form form
:this this-expr
:name (symbol (name method))
:children (into [:this] (:children method-expr)))))
(defn -deftype [name class-name args interfaces & [methods]]
(doseq [arg [class-name (str class-name) name (str name)]
f [maybe-class members*]]
(memo-clear! f [arg]))
(let [interfaces (mapv #(symbol (.getName ^Class %)) interfaces)]
(eval (list 'let []
(list* 'deftype* name class-name args :implements interfaces methods)
(list 'import class-name)))))
(defmethod parse 'reify*
[[_ interfaces & methods :as form] env]
(let [interfaces (conj (disj (set (mapv maybe-class interfaces)) Object)
name (gensym "reify__")
class-name (symbol (str (namespace-munge *ns*) "$" name))
menv (assoc env :this class-name)
methods (mapv #(assoc (analyze-method-impls % menv) :interfaces interfaces)
(-deftype name class-name [] interfaces)
{:op :reify
:env env
:form form
:class-name class-name
:methods methods
:interfaces interfaces
:children [:methods]})))
(defmethod parse 'deftype*
[[_ name class-name fields _ interfaces & methods :as form] env]
(let [interfaces (disj (set (mapv maybe-class interfaces)) Object)
fields-expr (mapv (fn [name]
{:env env
:form name
:name name
:mutable (let [m (meta name)]
(or (and (:unsynchronized-mutable m)
(and (:volatile-mutable m)
:local :field
:op :binding})
menv (assoc env
:context :expr
:locals (zipmap fields fields-expr)
:this class-name)
methods* (mapv #(assoc (analyze-method-impls % menv) :interfaces interfaces)
(-deftype name class-name fields interfaces methods)
{:op :deftype
:env env
:form form
:name name
:class-name class-name
:fields fields-expr
:methods methods*
:interfaces interfaces
:children [:fields :methods]}))
(defmethod parse 'case*
[[_ expr shift mask default case-map switch-type test-type & [skip-check?] :as form] env]
(let [[low high] ((juxt first last) (keys case-map)) ;;case-map is a sorted-map
test-expr (-analyze expr (ctx env :expr))
[tests thens] (reduce (fn [[te th] [min-hash [test then]]]
(let [test-expr (ana/-analyze :const test env)
then-expr (-analyze then env)]
[(conj te {:op :case-test
:hash min-hash
:test test-expr
:children [:test]})
(conj th {:op :case-then
:hash min-hash
:then then-expr
:children [:then]})]))
[[] []] case-map)
default-expr (-analyze default env)]
{:op :case
:form form
:env env
:test (assoc test-expr :case-test true)
:default default-expr
:tests tests
:thens thens
:shift shift
:mask mask
:low low
:high high
:switch-type switch-type
:test-type test-type
:skip-check? skip-check?
:children [:test :tests :thens :default]}))
(defmethod parse 'catch
[[_ etype ename & body :as form] env]
(let [etype (if (= etype :default) Throwable etype)] ;; catch-all
(ana/-parse `(catch ~etype ~ename ~@body) env)))
(defn run-passes
"Applies the following passes in the correct order to the AST:
* uniquify
* add-binding-atom
* cleanup
* source-info
* elide-meta
* warn-earmuff
* collect
* jvm.constant-lifter
* jvm.annotate-branch
* jvm.annotate-loops
* jvm.annotate-class-id
* jvm.annotate-internal-name
* jvm.annotate-methods
* jvm.fix-case-test
* jvm.clear-locals
* jvm.classify-invoke
* jvm.validate
* jvm.infer-tag
* jvm.annotate-tag
* jvm.validate-loop-locals
* jvm.analyze-host-expr"
(-> ast
(prewalk (fn [ast]
(-> ast
((fn analyze [ast]
(-> ast
(postwalk (fn [ast]
(-> ast
constant-lift))) ;; needs to be run after validate so that
;; :maybe-class is turned into a :const
(prewalk (validate-loop-locals analyze)))))
(prewalk (fn [ast]
(-> ast
annotate-loops ;; needed for clear-locals to safely clear locals in a loop
annotate-branch ;; needed for clear-locals
((collect {:what #{:constants
:where #{:deftype :reify :fn}
:top-level? false}))
;; needs to be run in a separate pass to avoid collecting
;; constants/callsites in :loop
(collect-closed-overs {:what #{:closed-overs}
:where #{:deftype :reify :fn :loop}
:top-level? false})
;; needs to be run after collect-closed-overs
(prewalk cleanup)))
(defn analyze
"Returns an AST for the form that's compatible with what tools.emitter.jvm requires.
Binds tools.analyzer/{macroexpand-1,create-var,parse} to
tools.analyzer.jvm/{macroexpand-1,create-var,parse} and calls
tools.analyzer/analyzer on form.
Calls `run-passes` on the AST."
[form env]
(with-bindings {clojure.lang.Compiler/LOADER (clojure.lang.RT/makeClassLoader)
#'ana/macroexpand-1 macroexpand-1
#'ana/create-var create-var
#'ana/parse parse
#'ana/var? var?}
(run-passes (-analyze form env))))
Jump to Line
Something went wrong with that request. Please try again.