Skip to content


Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Fetching contributors…

Cannot retrieve contributors at this time

367 lines (322 sloc) 13.384 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}]
[ :refer [ctx maybe-var]]
[ :refer [walk prewalk postwalk cycling]]
[ :refer :all :exclude [box]]
[ :refer [source-info]]
[ :refer [cleanup1 cleanup2]]
[ :refer [elide-meta]]
[ :refer [constant-lift]]
[ :refer [warn-earmuff]]
[ :refer [collect]]
[ :refer [add-binding-atom]]
[ :refer [uniquify-locals]]
[ :refer [box]]
[ :refer [annotate-branch]]
[ :refer [annotate-methods]]
[ :refer [fix-case-test]]
[ :refer [clear-locals]]
[ :refer [classify-invoke]]
[ :refer [validate]]
[ :refer [infer-tag]]
[ :refer [annotate-literal-tag annotate-binding-tag]]
[ :refer [validate-loop-locals]]
[ :refer [analyze-host-expr]]))
(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 (namespace form) target)
(with-meta (list '. target field)
(merge (meta form)
{:field true})) ;; should use this
(seq? form)
(let [[op & expr] form]
(if (symbol? op)
(let [opname (name op)]
(= (first 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 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 (namespace op)
(maybe-class (namespace op))) ; (class/field ..)
(let [target (maybe-class (namespace op))]
(with-meta (list '. target (list* (symbol opname) expr)) ;; static access in call position however are always method calls
(meta form)))
(= (last 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 (first form)]
(if (specials op)
(let [v (maybe-var op env)
m (meta v)
local? (-> env :locals (get op))
macro? (and (not local?) (:macro m))
inline-arities-f (:inline-arities m)
args (rest form)
inline? (and (not local?)
(or (not inline-arities-f)
(inline-arities-f (count args)))
(:inline m))]
(apply v form env (rest form)) ; (m &form &env & args)
(vary-meta (apply inline? args) merge m)
(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]}]
(intern ns sym))
(defmethod parse 'var
[[_ var :as form] env]
(if-let [var (maybe-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]
{:op :monitor-enter
:env env
:form form
:target (-analyze target (ctx env :expr))
:children [:target]})
(defmethod parse 'monitor-exit
[[_ target :as 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]
{:op :import
:env env
:form form
:class class})
(defn analyze-method-impls
[[name [this & params :as args] & body :as form] env]
{:pre [(symbol? name)
(vector? args)
(let [meth (cons params body)
this-expr {:name this
:env env
:form this
:op :binding
:tag (:this env)
:local :this}
env (assoc-in (dissoc env :this) [:locals this] this-expr)
method (analyze-fn-method meth env)]
(assoc (dissoc method :variadic?)
:op :method
:form form
:this this-expr
:name (symbol (clojure.core/name name))
:children (into [:this] (:children method)))))
(defn -deftype [name class-name args interfaces]
(let [interfaces (mapv #(symbol (.getName ^Class %)) interfaces)]
(eval (list 'do (list 'deftype* name class-name args :implements interfaces)
(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)
{: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))
test-expr (-analyze expr (ctx env :expr))
[tests thens] (reduce (fn [[te th] [min-hash [test then]]]
(let [test-expr (-analyze (list 'quote 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) ;; transform back in a sorted-map + hash-map when emitting
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)]
(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
* constant-lifter
* warn-earmuff
* collect
* jvm.annotate-branch
* 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 cleanup1)
(walk (fn [ast]
(-> ast
((fn analyze [ast]
(-> ast
(comp (cycling infer-tag analyze-host-expr annotate-binding-tag
validate classify-invoke)
annotate-literal-tag)) ;; not necesary, select on v-l-l
(comp box
(validate-loop-locals analyze)))))) ;; empty binding atom
(prewalk cleanup2)
(collect :constants
(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]
(binding [ana/macroexpand-1 macroexpand-1
ana/create-var create-var
ana/parse parse]
(run-passes (-analyze form env))))
Jump to Line
Something went wrong with that request. Please try again.