├── docs └── ClojureX_slides.pdf ├── .github ├── workflows │ ├── test.yml │ ├── snapshot.yml │ ├── doc-build.yml │ └── release.yml └── PULL_REQUEST_TEMPLATE ├── .gitignore ├── deps.edn ├── spec ├── buildref.sh ├── gen-ref.clj ├── quickref.html.tpl └── ast-ref.edn ├── CONTRIBUTING.md ├── project.clj ├── src ├── main │ └── clojure │ │ └── clojure │ │ └── tools │ │ └── analyzer │ │ ├── passes │ │ └── jvm │ │ │ ├── fix_case_test.clj │ │ │ ├── constant_lifter.clj │ │ │ ├── annotate_branch.clj │ │ │ ├── validate_recur.clj │ │ │ ├── warn_on_reflection.clj │ │ │ ├── annotate_tag.clj │ │ │ ├── classify_invoke.clj │ │ │ ├── annotate_loops.clj │ │ │ ├── annotate_host_info.clj │ │ │ ├── emit_form.clj │ │ │ ├── box.clj │ │ │ ├── validate_loop_locals.clj │ │ │ ├── analyze_host_expr.clj │ │ │ ├── infer_tag.clj │ │ │ └── validate.clj │ │ ├── jvm │ │ └── utils.clj │ │ └── jvm.clj └── test │ └── clojure │ └── clojure │ └── tools │ └── analyzer │ └── jvm │ ├── core_test.clj │ └── passes_test.clj ├── pom.xml ├── README.md ├── CHANGELOG.md ├── LICENSE └── epl.html /docs/ClojureX_slides.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/clojure/tools.analyzer.jvm/master/docs/ClojureX_slides.pdf -------------------------------------------------------------------------------- /.github/workflows/test.yml: -------------------------------------------------------------------------------- 1 | name: Test 2 | 3 | on: [push] 4 | 5 | jobs: 6 | call-test: 7 | uses: clojure/build.ci/.github/workflows/test.yml@master 8 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | /target 2 | /lib 3 | /classes 4 | /checkouts 5 | *.jar 6 | *.class 7 | .idea 8 | .lein-deps-sum 9 | .lein-failures 10 | .lein-plugins 11 | .lein-repl-history 12 | .nrepl-port 13 | -------------------------------------------------------------------------------- /.github/workflows/snapshot.yml: -------------------------------------------------------------------------------- 1 | name: Snapshot on demand 2 | 3 | on: [workflow_dispatch] 4 | 5 | jobs: 6 | call-snapshot: 7 | uses: clojure/build.ci/.github/workflows/snapshot.yml@master 8 | secrets: inherit 9 | -------------------------------------------------------------------------------- /.github/workflows/doc-build.yml: -------------------------------------------------------------------------------- 1 | name: Build API Docs 2 | 3 | on: 4 | workflow_dispatch: 5 | 6 | jobs: 7 | call-doc-build-workflow: 8 | uses: clojure/build.ci/.github/workflows/doc-build.yml@master 9 | with: 10 | project: clojure/tools.analyzer.jvm 11 | -------------------------------------------------------------------------------- /deps.edn: -------------------------------------------------------------------------------- 1 | {:deps {org.clojure/clojure {:mvn/version "1.12.0"} 2 | org.clojure/tools.analyzer {:mvn/version "1.2.0"} 3 | org.clojure/tools.reader {:mvn/version "1.5.0"} 4 | org.clojure/core.memoize {:mvn/version "1.1.266"} 5 | org.ow2.asm/asm {:mvn/version "9.2"}} 6 | :paths ["src/main/clojure"]} 7 | -------------------------------------------------------------------------------- /spec/buildref.sh: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | 3 | java -cp .:`lein cp` clojure.main < ast 22 | (assoc :branch? true) 23 | (assoc-in [:test :test?] true) 24 | (assoc-in [:then :path?] true) 25 | (assoc-in [:else :path?] true))) 26 | 27 | (defmethod annotate-branch :fn-method 28 | [ast] 29 | (assoc ast :path? true)) 30 | 31 | (defmethod annotate-branch :method 32 | [ast] 33 | (assoc ast :path? true)) 34 | 35 | (defmethod annotate-branch :case 36 | [ast] 37 | (-> ast 38 | (assoc :branch? true) 39 | (assoc-in [:test :test?] true) 40 | (assoc-in [:default :path?] true))) 41 | 42 | (defmethod annotate-branch :case-then 43 | [ast] 44 | (assoc ast :path? true)) 45 | 46 | (defmethod annotate-branch :default [ast] ast) 47 | -------------------------------------------------------------------------------- /src/main/clojure/clojure/tools/analyzer/passes/jvm/validate_recur.clj: -------------------------------------------------------------------------------- 1 | ;; Copyright (c) Nicola Mometto, Rich Hickey & contributors. 2 | ;; The use and distribution terms for this software are covered by the 3 | ;; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) 4 | ;; which can be found in the file epl-v10.html at the root of this distribution. 5 | ;; By using this software in any fashion, you are agreeing to be bound by 6 | ;; the terms of this license. 7 | ;; You must not remove this notice, or any other, from this software. 8 | 9 | (ns clojure.tools.analyzer.passes.jvm.validate-recur 10 | (:require [clojure.tools.analyzer.ast :refer [update-children]] 11 | [clojure.tools.analyzer.utils :refer [-source-info]])) 12 | 13 | (defmulti validate-recur 14 | "Ensures recurs don't cross try boundaries" 15 | {:pass-info {:walk :pre :depends #{}}} 16 | :op) 17 | 18 | (defmethod validate-recur :default [ast] 19 | (if (-> ast :env :no-recur) 20 | (update-children ast (fn [ast] (update-in ast [:env] assoc :no-recur true))) 21 | ast)) 22 | 23 | (defmethod validate-recur :try [ast] 24 | (update-children ast (fn [ast] (update-in ast [:env] assoc :no-recur true)))) 25 | 26 | (defmethod validate-recur :fn-method [ast] 27 | (update-in ast [:env] dissoc :no-recur)) 28 | 29 | (defmethod validate-recur :method [ast] 30 | (update-in ast [:env] dissoc :no-recur)) 31 | 32 | (defmethod validate-recur :loop [ast] 33 | (update-in ast [:env] dissoc :no-recur)) 34 | 35 | (defmethod validate-recur :recur [ast] 36 | (when (-> ast :env :no-recur) 37 | (throw (ex-info "Cannot recur across try" 38 | (merge {:form (:form ast)} 39 | (-source-info (:form ast) (:env ast)))))) 40 | ast) 41 | -------------------------------------------------------------------------------- /pom.xml: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4.0.0 4 | tools.analyzer.jvm 5 | 1.3.3-SNAPSHOT 6 | tools.analyzer.jvm 7 | Additional jvm-specific passes for tools.analyzer 8 | 9 | 10 | org.clojure 11 | pom.contrib 12 | 1.3.0 13 | 14 | 15 | 16 | 1.9.0 17 | 18 | 19 | 20 | 21 | bronsa 22 | Nicola Mometto 23 | 24 | 25 | 26 | 27 | 28 | org.clojure 29 | tools.analyzer 30 | 1.2.0 31 | 32 | 33 | org.clojure 34 | core.memoize 35 | 1.1.266 36 | 37 | 38 | org.ow2.asm 39 | asm 40 | 9.2 41 | 42 | 43 | org.clojure 44 | tools.reader 45 | 1.5.0 46 | 47 | 48 | 49 | 50 | scm:git:git://github.com/clojure/tools.analyzer.jvm.git 51 | scm:git:git://github.com/clojure/tools.analyzer.jvm.git 52 | https://github.com/clojure/tools.analyzer.jvm 53 | HEAD 54 | 55 | 56 | -------------------------------------------------------------------------------- /spec/gen-ref.clj: -------------------------------------------------------------------------------- 1 | (use 'clojure.string) 2 | 3 | (def tej-ref (read-string (slurp "ast-ref.edn"))) 4 | (def html (slurp "quickref.html.tpl")) 5 | 6 | (defn fix [x] 7 | (-> (str x) 8 | (replace #"`(.*?)`" "$1") 9 | (replace #":([a-zA-Z\?!\-]*)" ":$1"))) 10 | 11 | (defn build-children [children] 12 | (if (some #(:optional (meta %)) children) 13 | (let [[c & rest] children] 14 | (let [k (build-children rest) 15 | kc (mapv (fn [x] (cons c x)) k)] 16 | (if (:optional (meta c)) 17 | (into k kc) 18 | kc))) 19 | (if (seq children) 20 | [children] 21 | [[]]))) 22 | 23 | (defn children [keys] 24 | (when-let [children (seq (filter #(:children (meta %)) keys))] 25 | (mapv #(mapv first %) (build-children children)))) 26 | 27 | (def nodes 28 | (apply str (for [{:keys [op doc keys]} (:node-keys tej-ref) :let [op (name op)]] 29 | (str "
" 30 | "

" "#" op "

" 31 | "

" doc "

" 32 | "
" 33 | "
:op
:" op "
" 34 | (apply str (for [[k d :as f] keys] 35 | (str "
" k "
" 36 | "
" (if (:optional (meta f)) 37 | "optional ") (fix d) "
"))) 38 | (if-let [c (children keys)] 39 | (str "
:children
" 40 | (join ", " (mapv (fn [c] (str "" c "")) c)) "
")) 41 | "
" 42 | "
\n")))) 43 | 44 | (def nav 45 | (apply str (for [{op :op} (:node-keys tej-ref) :let [op (name op)]] 46 | (str "
  • " op "
    • \n")))) 47 | 48 | (def common 49 | (apply str (str "
    " 50 | "
    " 51 | (apply str (for [[k d :as f] (:all-keys tej-ref)] 52 | (str "
    " k "
    " 53 | "
    " (if (:optional (meta f)) 54 | "optional ") (fix d) "
    "))) 55 | "
    " 56 | "
    \n"))) 57 | 58 | (spit "quickref.html" 59 | (-> html 60 | (replace "{nav}" nav) 61 | (replace "{common}" common) 62 | (replace "{nodes}" nodes))) 63 | -------------------------------------------------------------------------------- /src/main/clojure/clojure/tools/analyzer/passes/jvm/warn_on_reflection.clj: -------------------------------------------------------------------------------- 1 | ;; Copyright (c) Nicola Mometto, Rich Hickey & contributors. 2 | ;; The use and distribution terms for this software are covered by the 3 | ;; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) 4 | ;; which can be found in the file epl-v10.html at the root of this distribution. 5 | ;; By using this software in any fashion, you are agreeing to be bound by 6 | ;; the terms of this license. 7 | ;; You must not remove this notice, or any other, from this software. 8 | 9 | (ns clojure.tools.analyzer.passes.jvm.warn-on-reflection 10 | (:require [clojure.tools.analyzer.passes.jvm 11 | [validate-loop-locals :refer [validate-loop-locals]] 12 | [validate :refer [validate]]])) 13 | 14 | (defn warn [what {:keys [file line column]}] 15 | (when *warn-on-reflection* 16 | (binding [*err* *out*] 17 | (println (str "Reflection warning: " 18 | (when file 19 | (str file ":")) 20 | (when line 21 | (str line ":")) 22 | (when column 23 | (str column " ")) 24 | "- " what))))) 25 | 26 | (defmulti warn-on-reflection 27 | "Prints a warning to *err* when *warn-on-reflection* is true 28 | and a node requires runtime reflection" 29 | {:pass-info {:walk :pre :depends #{#'validate} :after #{#'validate-loop-locals}}} 30 | :op) 31 | 32 | (defmethod warn-on-reflection :instance-call 33 | [ast] 34 | (when-not (:validated? ast) 35 | (warn (str "call to method " (:method ast) (when-let [class (:class ast)] 36 | (str " on " (.getName ^Class class))) 37 | " cannot be resolved") (:env ast))) 38 | ast) 39 | 40 | (defmethod warn-on-reflection :static-call 41 | [ast] 42 | (when-not (:validated? ast) 43 | (warn (str "call to static method " (:method ast) " on " 44 | (.getName ^Class (:class ast)) " cannot be resolved") 45 | (:env ast))) 46 | ast) 47 | 48 | (defmethod warn-on-reflection :host-interop 49 | [ast] 50 | (warn (str "reference to field or no args method call " (:m-or-f ast) 51 | " cannot be resolved") 52 | (:env ast)) 53 | ast) 54 | 55 | (defmethod warn-on-reflection :new 56 | [ast] 57 | (when-not (:validated? ast) 58 | (warn (str "call to " (.getName ^Class (:val (:class ast))) " ctor cannot be resolved") 59 | (:env ast))) 60 | ast) 61 | 62 | (defmethod warn-on-reflection :default [ast] ast) 63 | -------------------------------------------------------------------------------- /spec/quickref.html.tpl: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | tools.analyzer.jvm AST Quickref 6 | 94 | 95 | 96 | 102 |
    103 |

    tools.analyzer.jvm AST Quickref

    104 |

    Common AST fields

    105 | {common} 106 |

    Nodes reference

    107 | {nodes} 108 |
    109 | 110 | 111 | -------------------------------------------------------------------------------- /src/main/clojure/clojure/tools/analyzer/passes/jvm/annotate_tag.clj: -------------------------------------------------------------------------------- 1 | ;; Copyright (c) Nicola Mometto, Rich Hickey & contributors. 2 | ;; The use and distribution terms for this software are covered by the 3 | ;; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) 4 | ;; which can be found in the file epl-v10.html at the root of this distribution. 5 | ;; By using this software in any fashion, you are agreeing to be bound by 6 | ;; the terms of this license. 7 | ;; You must not remove this notice, or any other, from this software. 8 | 9 | (ns clojure.tools.analyzer.passes.jvm.annotate-tag 10 | (:require [clojure.tools.analyzer.jvm.utils :refer [unbox maybe-class]] 11 | [clojure.tools.analyzer.passes.jvm.constant-lifter :refer [constant-lift]]) 12 | (:import (clojure.lang ISeq Var AFunction))) 13 | 14 | (defmulti -annotate-tag :op) 15 | 16 | (defmethod -annotate-tag :default [ast] ast) 17 | 18 | (defmethod -annotate-tag :map 19 | [{:keys [val form] :as ast}] 20 | (let [t (class (or val form))] 21 | (assoc ast :o-tag t :tag t))) 22 | 23 | (defmethod -annotate-tag :set 24 | [{:keys [val form] :as ast}] 25 | (let [t (class (or val form))] 26 | (assoc ast :o-tag t :tag t))) 27 | 28 | (defmethod -annotate-tag :vector 29 | [{:keys [val form] :as ast}] 30 | (let [t (class (or val form))] 31 | (assoc ast :o-tag t :tag t))) 32 | 33 | (defmethod -annotate-tag :the-var 34 | [ast] 35 | (assoc ast :o-tag Var :tag Var)) 36 | 37 | (defmethod -annotate-tag :const 38 | [ast] 39 | (case (:type ast) 40 | 41 | ;; char and numbers are unboxed by default 42 | :number 43 | (let [t (unbox (class (:val ast)))] 44 | (assoc ast :o-tag t :tag t)) 45 | 46 | :char 47 | (assoc ast :o-tag Character/TYPE :tag Character/TYPE) 48 | 49 | :seq 50 | (assoc ast :o-tag ISeq :tag ISeq) 51 | 52 | (let [t (class (:val ast))] 53 | (assoc ast :o-tag t :tag t)))) 54 | 55 | (defmethod -annotate-tag :binding 56 | [{:keys [form tag atom o-tag init local name variadic?] :as ast}] 57 | (let [o-tag (or (:tag init) ;; should defer to infer-tag? 58 | (and (= :fn local) AFunction) 59 | (and (= :arg local) variadic? ISeq) 60 | o-tag 61 | Object) 62 | o-tag (if (#{Void Void/TYPE} o-tag) 63 | Object 64 | o-tag)] 65 | (if-let [tag (or (:tag (meta form)) tag)] 66 | (let [ast (assoc ast :tag tag :o-tag tag)] 67 | (if init 68 | (assoc-in ast [:init :tag] (maybe-class tag)) 69 | ast)) 70 | (assoc ast :tag o-tag :o-tag o-tag)))) 71 | 72 | (defmethod -annotate-tag :local 73 | [{:keys [name form tag atom case-test] :as ast}] 74 | (let [o-tag (@atom :tag)] 75 | (assoc ast :o-tag o-tag :tag o-tag))) 76 | 77 | ;; TODO: move binding/local logic to infer-tag 78 | (defn annotate-tag 79 | "If the AST node type is a constant object or contains :tag metadata, 80 | attach the appropriate :tag and :o-tag to the node." 81 | {:pass-info {:walk :post :depends #{} :after #{#'constant-lift}}} 82 | [{:keys [op tag o-tag atom] :as ast}] 83 | (let [ast (if (and atom (:case-test @atom)) 84 | (update-in ast [:form] vary-meta dissoc :tag) 85 | ast) 86 | ast 87 | (if (and o-tag tag) 88 | ast 89 | (if-let [tag (or tag 90 | (-> ast :val meta :tag) 91 | (-> ast :form meta :tag))] 92 | (assoc (-annotate-tag ast) :tag tag) 93 | (-annotate-tag ast)))] 94 | (when (= op :binding) 95 | (swap! atom assoc :tag (:tag ast))) 96 | ast)) 97 | -------------------------------------------------------------------------------- /src/main/clojure/clojure/tools/analyzer/passes/jvm/classify_invoke.clj: -------------------------------------------------------------------------------- 1 | ;; Copyright (c) Nicola Mometto, Rich Hickey & contributors. 2 | ;; The use and distribution terms for this software are covered by the 3 | ;; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) 4 | ;; which can be found in the file epl-v10.html at the root of this distribution. 5 | ;; By using this software in any fashion, you are agreeing to be bound by 6 | ;; the terms of this license. 7 | ;; You must not remove this notice, or any other, from this software. 8 | 9 | (ns clojure.tools.analyzer.passes.jvm.classify-invoke 10 | (:require [clojure.tools.analyzer.utils :refer [arglist-for-arity protocol-node? source-info]] 11 | [clojure.tools.analyzer.jvm.utils 12 | :refer [specials prim-interface]] 13 | [clojure.tools.analyzer.passes.jvm.validate :refer [validate]])) 14 | 15 | (defn classify-invoke 16 | "If the AST node is an :invoke, check the node in function position, 17 | * if it is a keyword, transform the node in a :keyword-invoke node; 18 | * if it is the clojure.core/instance? var and the first argument is a 19 | literal class, transform the node in a :instance? node to be inlined by 20 | the emitter 21 | * if it is a protocol function var, transform the node in a :protocol-invoke 22 | node 23 | * if it is a regular function with primitive type hints that match a 24 | clojure.lang.IFn$[primitive interface], transform the node in a :prim-invoke 25 | node" 26 | {:pass-info {:walk :post :depends #{#'validate}}} 27 | [{:keys [op args tag env form] :as ast}] 28 | (if-not (= op :invoke) 29 | ast 30 | (let [argc (count args) 31 | the-fn (:fn ast) 32 | op (:op the-fn) 33 | var? (= :var op) 34 | the-var (:var the-fn)] 35 | 36 | (cond 37 | 38 | (and (= :const op) 39 | (= :keyword (:type the-fn))) 40 | (if (<= 1 argc 2) 41 | (if (and (not (namespace (:val the-fn))) 42 | (= 1 argc)) 43 | (merge (dissoc ast :fn :args) 44 | {:op :keyword-invoke 45 | :target (first args) 46 | :keyword the-fn 47 | :children [:keyword :target]}) 48 | ast) 49 | (throw (ex-info (str "Cannot invoke keyword with " argc " arguments") 50 | (merge {:form form} 51 | (source-info env))))) 52 | (and (= 2 argc) 53 | var? 54 | (= #'clojure.core/instance? the-var) 55 | (= :const (:op (first args))) 56 | (= :class (:type (first args)))) 57 | (merge (dissoc ast :fn :args) 58 | {:op :instance? 59 | :class (:val (first args)) 60 | :target (second args) 61 | :form form 62 | :env env 63 | :o-tag Boolean/TYPE 64 | :tag (or tag Boolean/TYPE) 65 | :children [:target]}) 66 | 67 | (and var? (protocol-node? the-var (:meta the-fn))) 68 | (if (>= argc 1) 69 | (merge (dissoc ast :fn) 70 | {:op :protocol-invoke 71 | :protocol-fn the-fn 72 | :target (first args) 73 | :args (vec (rest args)) 74 | :children [:protocol-fn :target :args]}) 75 | (throw (ex-info "Cannot invoke protocol method with no args" 76 | (merge {:form form} 77 | (source-info env))))) 78 | 79 | :else 80 | (let [arglist (arglist-for-arity the-fn argc) 81 | arg-tags (mapv (comp specials str :tag meta) arglist) 82 | ret-tag (-> arglist meta :tag str specials) 83 | tags (conj arg-tags ret-tag)] 84 | (if-let [prim-interface (prim-interface (mapv #(if (nil? %) Object %) tags))] 85 | (merge ast 86 | {:op :prim-invoke 87 | :prim-interface prim-interface 88 | :args (mapv (fn [arg tag] (assoc arg :tag tag)) args arg-tags) 89 | :o-tag ret-tag 90 | :tag (or tag ret-tag)}) 91 | ast)))))) 92 | -------------------------------------------------------------------------------- /src/main/clojure/clojure/tools/analyzer/passes/jvm/annotate_loops.clj: -------------------------------------------------------------------------------- 1 | ;; Copyright (c) Nicola Mometto, Rich Hickey & contributors. 2 | ;; The use and distribution terms for this software are covered by the 3 | ;; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) 4 | ;; which can be found in the file epl-v10.html at the root of this distribution. 5 | ;; By using this software in any fashion, you are agreeing to be bound by 6 | ;; the terms of this license. 7 | ;; You must not remove this notice, or any other, from this software. 8 | 9 | (ns clojure.tools.analyzer.passes.jvm.annotate-loops 10 | (:require [clojure.tools.analyzer.ast :refer [update-children]])) 11 | 12 | (defmulti annotate-loops 13 | "Adds a :loops field to nodes that represent a code path that 14 | might be visited more than once because of a recur. 15 | 16 | The field is a set of loop-ids representing the loops that might 17 | recur into that path 18 | 19 | Note that because (recur expr) is equivalent to (let [e expr] (recur e)) 20 | the node corresponting to expr will have the same :loops field 21 | as the nodes in the same code path of the recur" 22 | {:pass-info {:walk :pre :depends #{}}} 23 | :op) 24 | 25 | (defmulti check-recur :op) 26 | 27 | (defn -check-recur [ast k] 28 | (let [ast (update-in ast [k] check-recur)] 29 | (if (:recurs (k ast)) 30 | (assoc ast :recurs true) 31 | ast))) 32 | 33 | (defmethod check-recur :do 34 | [ast] 35 | (let [ast (-check-recur ast :ret)] 36 | (if (:recurs ast) 37 | (assoc ast :statements (mapv (fn [s] (assoc s :recurs true)) (:statements ast))) 38 | ast))) 39 | 40 | (defmethod check-recur :let 41 | [ast] 42 | (-check-recur ast :body)) 43 | 44 | (defmethod check-recur :letfn 45 | [ast] 46 | (-check-recur ast :body)) 47 | 48 | (defmethod check-recur :if 49 | [ast] 50 | (-> ast 51 | (-check-recur :then) 52 | (-check-recur :else))) 53 | 54 | (defmethod check-recur :case 55 | [ast] 56 | (let [ast (-> ast 57 | (-check-recur :default) 58 | (update-in [:thens] #(mapv check-recur %)))] 59 | (if (some :recurs (:thens ast)) 60 | (assoc ast :recurs true) 61 | ast))) 62 | 63 | (defmethod check-recur :case-then 64 | [ast] 65 | (-check-recur ast :then)) 66 | 67 | (defmethod check-recur :recur 68 | [ast] 69 | (assoc ast :recurs true)) 70 | 71 | (defmethod check-recur :default 72 | [ast] 73 | ast) 74 | 75 | (defn -loops [ast loop-id] 76 | (update-in ast [:loops] (fnil conj #{}) loop-id)) 77 | 78 | (defmethod annotate-loops :loop 79 | [{:keys [loops loop-id] :as ast}] 80 | (let [ast (if loops 81 | (update-children ast #(assoc % :loops loops)) 82 | ast) 83 | ast (update-in ast [:body] check-recur)] 84 | (if (-> ast :body :recurs) 85 | (update-in ast [:body] -loops loop-id) 86 | ast))) 87 | 88 | (defmethod annotate-loops :default 89 | [{:keys [loops] :as ast}] 90 | (if loops 91 | (update-children ast #(assoc % :loops loops)) 92 | ast)) 93 | 94 | (defmethod annotate-loops :if 95 | [{:keys [loops test then else env] :as ast}] 96 | (if loops 97 | (let [loop-id (:loop-id env) 98 | loops-no-recur (disj loops loop-id) 99 | branch-recurs? (or (:recurs then) (:recurs else)) 100 | then (if (or (:recurs then) ;; the recur is inside the then branch 101 | ;; the recur is in the same code path of the if expression 102 | (not branch-recurs?)) 103 | (assoc then :loops loops) 104 | (assoc then :loops loops-no-recur)) 105 | else (if (or (:recurs else) (not branch-recurs?)) 106 | (assoc else :loops loops) 107 | (assoc else :loops loops-no-recur))] 108 | (assoc ast 109 | :then then 110 | :else else 111 | :test (assoc test :loops loops))) 112 | ast)) 113 | 114 | (defmethod annotate-loops :case 115 | [{:keys [loops test default thens env] :as ast}] 116 | (if loops 117 | (let [loop-id (:loop-id env) 118 | loops-no-recur (disj loops loop-id) 119 | branch-recurs? (some :recurs (conj thens default)) 120 | 121 | default (if (or (:recurs default) (not branch-recurs?)) 122 | (assoc default :loops loops) 123 | (assoc default :loops loops-no-recur)) 124 | 125 | thens (mapv #(if (or (:recurs %) (not branch-recurs?)) 126 | (assoc % :loops loops) 127 | (assoc % :loops loops-no-recur)) thens)] 128 | (assoc ast 129 | :thens thens 130 | :default default 131 | :test (assoc test :loops loops))) 132 | ast)) 133 | -------------------------------------------------------------------------------- /src/test/clojure/clojure/tools/analyzer/jvm/core_test.clj: -------------------------------------------------------------------------------- 1 | (ns clojure.tools.analyzer.jvm.core-test 2 | (:refer-clojure :exclude [macroexpand-1]) 3 | (:require [clojure.tools.analyzer :as ana] 4 | [clojure.tools.analyzer.jvm :as ana.jvm] 5 | [clojure.tools.analyzer.env :as env] 6 | [clojure.tools.analyzer.passes.elide-meta :refer [elides elide-meta]] 7 | [clojure.tools.analyzer.ast :refer [postwalk]] 8 | [clojure.tools.reader :as r] 9 | [clojure.test :refer [deftest is]])) 10 | 11 | (defprotocol p (f [_])) 12 | (defn f1 [^long x]) 13 | (def e (ana.jvm/empty-env)) 14 | 15 | (defmacro ast [form] 16 | `(binding [ana/macroexpand-1 ana.jvm/macroexpand-1 17 | ana/create-var ana.jvm/create-var 18 | ana/parse ana.jvm/parse 19 | ana/var? var? 20 | elides {:all #{:line :column :file}}] 21 | (env/with-env (ana.jvm/global-env) 22 | (postwalk (ana/analyze '~form e) elide-meta)))) 23 | 24 | (defn ana [form] 25 | (binding [ana/macroexpand-1 ana.jvm/macroexpand-1 26 | ana/create-var ana.jvm/create-var 27 | ana/parse ana.jvm/parse 28 | ana/var? var? 29 | elides {:all #{:line :column :file}}] 30 | (ana.jvm/analyze form e))) 31 | 32 | (defmacro ast1 [form] 33 | `(ana '~form)) 34 | 35 | (defmacro mexpand [form] 36 | `(ana.jvm/macroexpand-1 '~form e)) 37 | 38 | (deftest macroexpander-test 39 | (is (= (list '. (list 'do java.lang.Object) 'toString) 40 | (mexpand (.toString Object)))) 41 | (is (= (list '. java.lang.Integer '(parseInt "2")) (mexpand (Integer/parseInt "2"))))) 42 | 43 | (deftest analyzer-test 44 | 45 | (let [v-ast (ast #'+)] 46 | (is (= :the-var (:op v-ast))) 47 | (is (= #'+ (:var v-ast)))) 48 | 49 | (let [mn-ast (ast (monitor-enter 1))] 50 | (is (= :monitor-enter (:op mn-ast))) 51 | (is (= 1 (-> mn-ast :target :form)))) 52 | 53 | (let [mx-ast (ast (monitor-exit 1))] 54 | (is (= :monitor-exit (:op mx-ast))) 55 | (is (= 1 (-> mx-ast :target :form)))) 56 | 57 | (let [i-ast (ast (clojure.core/import* "java.lang.String"))] 58 | (is (= :import (:op i-ast))) 59 | (is (= "java.lang.String" (:class i-ast)))) 60 | 61 | (let [r-ast (ast ^:foo (reify 62 | Object (toString [this] "") 63 | Appendable (^Appendable append [this ^char x] this)))] 64 | (is (= :with-meta (-> r-ast :op))) ;; line/column info 65 | (is (= :reify (-> r-ast :expr :op))) 66 | (is (= #{Appendable clojure.lang.IObj} (-> r-ast :expr :interfaces))) 67 | (is (= '#{toString append} (->> r-ast :expr :methods (mapv :name) set)))) 68 | 69 | (let [dt-ast (ast (deftype* x user.x [a b] 70 | :implements [Appendable] 71 | (^Appendable append [this ^char x] this)))] 72 | (is (= :deftype (-> dt-ast :op))) 73 | (is (= '[a b] (->> dt-ast :fields (mapv :name)))) 74 | (is (= '[append] (->> dt-ast :methods (mapv :name)))) 75 | (is (= 'user.x (-> dt-ast :class-name)))) 76 | 77 | (let [c-ast (ast (case* 1 0 0 :number {2 [2 :two] 3 [3 :three]} :compact :int))] 78 | (is (= :number (-> c-ast :default :form))) 79 | (is (= #{2 3} (->> c-ast :tests (mapv (comp :form :test)) set))) 80 | (is (= #{:three :two} (->> c-ast :thens (mapv (comp :form :then)) set))) 81 | (is (= 3 (-> c-ast :high))) 82 | (is (= :int (-> c-ast :test-type))) 83 | (is (= :compact (-> c-ast :switch-type))) 84 | (is (= 2 (-> c-ast :low))) 85 | (is (= 0 (-> c-ast :shift))) 86 | (is (= 0 (-> c-ast :mask)))) 87 | 88 | (is (= Throwable (-> (ast1 (try (catch :default e))) :catches first :class :val))) 89 | (is (= Exception (-> (ast1 (try (catch Exception e e))) :catches first :body :tag)))) 90 | 91 | (deftest doseq-chunk-hint 92 | (let [tree (ast1 (doseq [item (range 10)] 93 | (println item))) 94 | {[_ chunk] :bindings} tree] 95 | (is (= :loop (:op tree))) 96 | (is (.startsWith (name (:name chunk)) "chunk")) 97 | (is (= clojure.lang.IChunk (:tag chunk))))) 98 | 99 | (def ^:dynamic x) 100 | (deftest set!-dynamic-var 101 | (is (ast1 (set! x 1)))) 102 | 103 | (deftest analyze-proxy 104 | (is (ast1 (proxy [Object] [])))) 105 | 106 | (deftest analyze-record 107 | (is (ast1 (defrecord TestRecord [x y])))) 108 | 109 | (deftest eq-no-reflection 110 | (is (:validated? (-> (ast1 (fn [s] (= s \f))) :methods first :body)))) 111 | 112 | (deftest analyze+eval-context-test 113 | (let [do-ast (ana.jvm/analyze+eval '(do 1 2 3))] 114 | (is (= :ctx/statement (-> do-ast :statements first :env :context))))) 115 | 116 | (deftest array_class 117 | (is (ana (r/read-string "(fn [^{:tag int/2} x] (instance? int/2 x))")))) 118 | -------------------------------------------------------------------------------- /src/main/clojure/clojure/tools/analyzer/passes/jvm/annotate_host_info.clj: -------------------------------------------------------------------------------- 1 | ;; Copyright (c) Nicola Mometto, Rich Hickey & contributors. 2 | ;; The use and distribution terms for this software are covered by the 3 | ;; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) 4 | ;; which can be found in the file epl-v10.html at the root of this distribution. 5 | ;; By using this software in any fashion, you are agreeing to be bound by 6 | ;; the terms of this license. 7 | ;; You must not remove this notice, or any other, from this software. 8 | 9 | (ns clojure.tools.analyzer.passes.jvm.annotate-host-info 10 | (:require [clojure.tools.analyzer :as ana] 11 | [clojure.tools.analyzer.ast :refer [prewalk]] 12 | [clojure.tools.analyzer.passes 13 | [cleanup :refer [cleanup]] 14 | [elide-meta :refer [elide-meta]]] 15 | [clojure.tools.analyzer.utils :refer [source-info]] 16 | [clojure.tools.analyzer.jvm.utils 17 | :refer [members name-matches? try-best-match] 18 | :as u])) 19 | 20 | (defn annotate-host-info 21 | "Adds a :methods key to reify/deftype :methods info representing 22 | the reflected informations for the required methods, replaces 23 | (catch :default ..) forms with (catch Throwable ..)" 24 | {:pass-info {:walk :pre :depends #{} :after #{#'elide-meta}}} 25 | [{:keys [op methods interfaces class env] :as ast}] 26 | (case op 27 | (:reify :deftype) 28 | (let [all-methods 29 | (into #{} 30 | (mapcat (fn [class] 31 | (mapv (fn [method] 32 | (dissoc method :exception-types)) 33 | (filter (fn [{:keys [flags return-type]}] 34 | (and return-type (not-any? #{:final :static} flags))) 35 | (members class)))) 36 | (conj interfaces Object)))] 37 | (assoc ast :methods (mapv (fn [ast] 38 | (let [name (:name ast) 39 | argc (count (:params ast))] 40 | (assoc ast :methods 41 | (filter #(and ((name-matches? name) (:name %)) 42 | (= argc (count (:parameter-types %)))) 43 | all-methods)))) methods))) 44 | 45 | 46 | :catch 47 | (let [the-class (cond 48 | 49 | (and (= :const (:op class)) 50 | (= :default (:form class))) 51 | Throwable 52 | 53 | (= :maybe-class (:op class)) 54 | (u/maybe-class-literal (:class class))) 55 | 56 | ast (if the-class 57 | (-> ast 58 | (assoc :class (assoc (ana/analyze-const the-class env :class) 59 | :form (:form class) 60 | :tag Class 61 | :o-tag Class))) 62 | ast)] 63 | (assoc-in ast [:local :tag] (-> ast :class :val))) 64 | 65 | 66 | :method 67 | ;; this should actually be in validate but it's here since it needs to be prewalked 68 | ;; for infer-tag purposes 69 | (let [{:keys [name class tag form params fixed-arity env]} ast] 70 | (if interfaces 71 | (let [tags (mapv (comp u/maybe-class :tag meta :form) params) 72 | methods-set (set (mapv (fn [x] (dissoc x :declaring-class :flags)) methods))] 73 | (let [[m & rest :as matches] (try-best-match tags methods)] 74 | (if m 75 | (let [ret-tag (u/maybe-class (:return-type m)) 76 | i-tag (u/maybe-class (:declaring-class m)) 77 | arg-tags (mapv u/maybe-class (:parameter-types m)) 78 | params (mapv (fn [{:keys [atom] :as arg} tag] 79 | (assoc arg :tag tag :o-tag tag)) params arg-tags)] 80 | (if (or (empty? rest) 81 | (every? (fn [{:keys [return-type parameter-types]}] 82 | (and (= (u/maybe-class return-type) ret-tag) 83 | (= arg-tags (mapv u/maybe-class parameter-types)))) rest)) 84 | (assoc (dissoc ast :interfaces :methods) 85 | :bridges (filter #(and (= arg-tags (mapv u/maybe-class (:parameter-types %))) 86 | (.isAssignableFrom (u/maybe-class (:return-type %)) ret-tag)) 87 | (disj methods-set (dissoc m :declaring-class :flags))) 88 | :methods methods 89 | :interface i-tag 90 | :tag ret-tag 91 | :o-tag ret-tag 92 | :params params) 93 | (throw (ex-info (str "Ambiguous method signature for method: " name) 94 | (merge {:method name 95 | :interfaces interfaces 96 | :form form 97 | :params (mapv (fn [x] (prewalk x cleanup)) params) 98 | :matches matches} 99 | (source-info env)))))) 100 | (throw (ex-info (str "No such method found: " name " with given signature in any of the" 101 | " provided interfaces: " interfaces) 102 | (merge {:method name 103 | :methods methods 104 | :interfaces interfaces 105 | :form form 106 | :params params} 107 | (source-info env))))))) 108 | ast)) 109 | ast)) 110 | -------------------------------------------------------------------------------- /src/main/clojure/clojure/tools/analyzer/passes/jvm/emit_form.clj: -------------------------------------------------------------------------------- 1 | ;; Copyright (c) Nicola Mometto, Rich Hickey & contributors. 2 | ;; The use and distribution terms for this software are covered by the 3 | ;; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) 4 | ;; which can be found in the file epl-v10.html at the root of this distribution. 5 | ;; By using this software in any fashion, you are agreeing to be bound by 6 | ;; the terms of this license. 7 | ;; You must not remove this notice, or any other, from this software. 8 | 9 | (ns clojure.tools.analyzer.passes.jvm.emit-form 10 | (:require [clojure.tools.analyzer.passes 11 | [emit-form :as default] 12 | [uniquify :refer [uniquify-locals]]])) 13 | 14 | (defmulti -emit-form (fn [{:keys [op]} _] op)) 15 | 16 | (defn -emit-form* 17 | [{:keys [form] :as ast} opts] 18 | (let [expr (-emit-form ast opts)] 19 | (if-let [m (and (instance? clojure.lang.IObj expr) 20 | (meta form))] 21 | (with-meta expr (merge m (meta expr))) 22 | expr))) 23 | 24 | ;; TODO: use pass opts infr 25 | (defn emit-form 26 | "Return the form represented by the given AST 27 | Opts is a set of options, valid options are: 28 | * :hygienic 29 | * :qualified-vars (DEPRECATED, use :qualified-symbols instead) 30 | * :qualified-symbols" 31 | {:pass-info {:walk :none :depends #{#'uniquify-locals} :compiler true}} 32 | ([ast] (emit-form ast #{})) 33 | ([ast opts] 34 | (binding [default/-emit-form* -emit-form*] 35 | (-emit-form* ast opts)))) 36 | 37 | (defn emit-hygienic-form 38 | "Return an hygienic form represented by the given AST" 39 | {:pass-info {:walk :none :depends #{#'uniquify-locals} :compiler true}} 40 | [ast] 41 | (binding [default/-emit-form* -emit-form*] 42 | (-emit-form* ast #{:hygienic}))) 43 | 44 | (defmethod -emit-form :default 45 | [ast opts] 46 | (default/-emit-form ast opts)) 47 | 48 | (defmethod -emit-form :const 49 | [{:keys [type val] :as ast} opts] 50 | (if (and (= type :class) 51 | (:qualified-symbols opts)) 52 | (symbol (.getName ^Class val)) 53 | (default/-emit-form ast opts))) 54 | 55 | (defmethod -emit-form :monitor-enter 56 | [{:keys [target]} opts] 57 | `(monitor-enter ~(-emit-form* target opts))) 58 | 59 | (defmethod -emit-form :monitor-exit 60 | [{:keys [target]} opts] 61 | `(monitor-exit ~(-emit-form* target opts))) 62 | 63 | (defmethod -emit-form :import 64 | [{:keys [class]} opts] 65 | `(clojure.core/import* ~class)) 66 | 67 | (defmethod -emit-form :the-var 68 | [{:keys [^clojure.lang.Var var]} opts] 69 | `(var ~(symbol (name (ns-name (.ns var))) (name (.sym var))))) 70 | 71 | (defmethod -emit-form :method 72 | [{:keys [params body this name form]} opts] 73 | (let [params (into [this] params)] 74 | `(~(with-meta name (meta (first form))) 75 | ~(with-meta (mapv #(-emit-form* % opts) params) 76 | (meta (second form))) 77 | ~(-emit-form* body opts)))) 78 | 79 | (defn class->str [class] 80 | (if (symbol? class) 81 | (name class) 82 | (.getName ^Class class))) 83 | 84 | (defn class->sym [class] 85 | (if (symbol? class) 86 | class 87 | (symbol (.getName ^Class class)))) 88 | 89 | (defmethod -emit-form :catch 90 | [{:keys [class local body]} opts] 91 | `(catch ~(-emit-form* class opts) ~(-emit-form* local opts) 92 | ~(-emit-form* body opts))) 93 | 94 | (defmethod -emit-form :deftype 95 | [{:keys [name class-name fields interfaces methods]} opts] 96 | `(deftype* ~name ~(class->sym class-name) ~(mapv #(-emit-form* % opts) fields) 97 | :implements ~(mapv class->sym interfaces) 98 | ~@(mapv #(-emit-form* % opts) methods))) 99 | 100 | (defmethod -emit-form :reify 101 | [{:keys [interfaces methods]} opts] 102 | `(reify* ~(mapv class->sym (disj interfaces clojure.lang.IObj)) 103 | ~@(mapv #(-emit-form* % opts) methods))) 104 | 105 | (defmethod -emit-form :case 106 | [{:keys [test default tests thens shift mask low high switch-type test-type skip-check?]} opts] 107 | `(case* ~(-emit-form* test opts) 108 | ~shift ~mask 109 | ~(-emit-form* default opts) 110 | ~(apply sorted-map 111 | (mapcat (fn [{:keys [hash test]} {:keys [then]}] 112 | [hash [(-emit-form* test opts) (-emit-form* then opts)]]) 113 | tests thens)) 114 | ~switch-type ~test-type ~skip-check?)) 115 | 116 | (defmethod -emit-form :static-field 117 | [{:keys [class field]} opts] 118 | (symbol (class->str class) (name field))) 119 | 120 | (defmethod -emit-form :static-call 121 | [{:keys [class method args]} opts] 122 | `(~(symbol (class->str class) (name method)) 123 | ~@(mapv #(-emit-form* % opts) args))) 124 | 125 | (defmethod -emit-form :instance-field 126 | [{:keys [instance field]} opts] 127 | `(~(symbol (str ".-" (name field))) ~(-emit-form* instance opts))) 128 | 129 | (defmethod -emit-form :instance-call 130 | [{:keys [instance method args]} opts] 131 | `(~(symbol (str "." (name method))) ~(-emit-form* instance opts) 132 | ~@(mapv #(-emit-form* % opts) args))) 133 | 134 | (defmethod -emit-form :prim-invoke 135 | [{:keys [fn args]} opts] 136 | `(~(-emit-form* fn opts) 137 | ~@(mapv #(-emit-form* % opts) args))) 138 | 139 | (defmethod -emit-form :protocol-invoke 140 | [{:keys [protocol-fn target args]} opts] 141 | `(~(-emit-form* protocol-fn opts) 142 | ~(-emit-form* target opts) 143 | ~@(mapv #(-emit-form* % opts) args))) 144 | 145 | (defmethod -emit-form :keyword-invoke 146 | [{:keys [target keyword]} opts] 147 | (list (-emit-form* keyword opts) 148 | (-emit-form* target opts))) 149 | 150 | (defmethod -emit-form :instance? 151 | [{:keys [class target]} opts] 152 | `(instance? ~class ~(-emit-form* target opts))) 153 | 154 | (defmethod -emit-form :var 155 | [{:keys [form ^clojure.lang.Var var]} opts] 156 | (if (or (:qualified-symbols opts) 157 | (:qualified-vars opts)) 158 | (with-meta (symbol (-> var .ns ns-name name) (-> var .sym name)) 159 | (meta form)) 160 | form)) 161 | 162 | (defmethod -emit-form :def 163 | [ast opts] 164 | (let [f (default/-emit-form ast opts)] 165 | (if (:qualified-symbols opts) 166 | `(def ~(with-meta (symbol (-> ast :env :ns name) (str (second f))) 167 | (meta (second f))) 168 | ~@(nthrest f 2)) 169 | f))) 170 | -------------------------------------------------------------------------------- /src/main/clojure/clojure/tools/analyzer/passes/jvm/box.clj: -------------------------------------------------------------------------------- 1 | ;; Copyright (c) Nicola Mometto, Rich Hickey & contributors. 2 | ;; The use and distribution terms for this software are covered by the 3 | ;; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) 4 | ;; which can be found in the file epl-v10.html at the root of this distribution. 5 | ;; By using this software in any fashion, you are agreeing to be bound by 6 | ;; the terms of this license. 7 | ;; You must not remove this notice, or any other, from this software. 8 | 9 | (ns clojure.tools.analyzer.passes.jvm.box 10 | (:require [clojure.tools.analyzer.jvm.utils :as u] 11 | [clojure.tools.analyzer.utils :refer [protocol-node? arglist-for-arity]] 12 | [clojure.tools.analyzer.passes.jvm 13 | [validate :refer [validate]] 14 | [infer-tag :refer [infer-tag]]])) 15 | 16 | (defmulti box 17 | "Box the AST node tag where necessary" 18 | {:pass-info {:walk :pre :depends #{#'infer-tag} :after #{#'validate}}} 19 | :op) 20 | 21 | (defmacro if-let-box [class then else] 22 | `(let [c# ~class 23 | ~class (u/box c#)] 24 | (if (u/primitive? c#) 25 | ~then 26 | ~else))) 27 | 28 | (defn -box [ast] 29 | (let [tag (:tag ast)] 30 | (if (u/primitive? tag) 31 | (assoc ast :tag (u/box tag)) 32 | ast))) 33 | 34 | (defn boxed? [tag expr] 35 | (and (or (nil? tag) (not (u/primitive? tag))) 36 | (u/primitive? (:tag expr)))) 37 | 38 | (defmethod box :instance-call 39 | [{:keys [args class validated? tag] :as ast}] 40 | (let [ast (if-let-box class 41 | (assoc (update-in ast [:instance :tag] u/box) :class class) 42 | ast)] 43 | (if validated? 44 | ast 45 | (assoc ast :args (mapv -box args) 46 | :o-tag Object :tag (if (not (#{Void Void/TYPE} tag)) 47 | tag 48 | Object))))) 49 | 50 | (defmethod box :static-call 51 | [{:keys [args validated? tag] :as ast}] 52 | (if validated? 53 | ast 54 | (assoc ast :args (mapv -box args) 55 | :o-tag Object :tag (if (not (#{Void Void/TYPE} tag)) 56 | tag 57 | Object)))) 58 | 59 | (defmethod box :new 60 | [{:keys [args validated?] :as ast}] 61 | (if validated? 62 | ast 63 | (assoc ast :args (mapv -box args) 64 | :o-tag Object))) 65 | 66 | (defmethod box :instance-field 67 | [{:keys [class] :as ast}] 68 | (if-let-box class 69 | (assoc (update-in ast [:instance :tag] u/box) :class class) 70 | ast)) 71 | 72 | (defmethod box :def 73 | [{:keys [init] :as ast}] 74 | (if (and init (u/primitive? (:tag init))) 75 | (update-in ast [:init] -box) 76 | ast)) 77 | 78 | (defmethod box :vector 79 | [ast] 80 | (assoc ast :items (mapv -box (:items ast)))) 81 | 82 | (defmethod box :set 83 | [ast] 84 | (assoc ast :items (mapv -box (:items ast)))) 85 | 86 | (defmethod box :map 87 | [ast] 88 | (let [keys (mapv -box (:keys ast)) 89 | vals (mapv -box (:vals ast))] 90 | (assoc ast 91 | :keys keys 92 | :vals vals))) 93 | 94 | (defmethod box :do 95 | [ast] 96 | (if (boxed? (:tag ast) (:ret ast)) 97 | (-> ast 98 | (update-in [:ret] -box) 99 | (update-in [:o-tag] u/box)) 100 | ast)) 101 | 102 | (defmethod box :quote 103 | [ast] 104 | (if (boxed? (:tag ast) (:ret ast)) 105 | (-> ast 106 | (update-in [:expr] -box) 107 | (update-in [:o-tag] u/box)) 108 | ast)) 109 | 110 | (defmethod box :protocol-invoke 111 | [ast] 112 | (assoc ast :args (mapv -box (:args ast)))) 113 | 114 | (defmethod box :let 115 | [{:keys [tag body] :as ast}] 116 | (if (boxed? tag body) 117 | (-> ast 118 | (update-in [:body] -box) 119 | (update-in [:o-tag] u/box)) 120 | ast)) 121 | 122 | (defmethod box :letfn 123 | [ast] 124 | (if (boxed? (:tag ast) (:body ast)) 125 | (-> ast 126 | (update-in [:body] -box) 127 | (update-in [:o-tag] u/box)) 128 | ast)) 129 | 130 | (defmethod box :loop 131 | [ast] 132 | (if (boxed? (:tag ast) (:body ast)) 133 | (-> ast 134 | (update-in [:body] -box) 135 | (update-in [:o-tag] u/box)) 136 | ast)) 137 | 138 | (defmethod box :fn-method 139 | [{:keys [params tag] :as ast}] 140 | (let [ast (if (u/primitive? tag) 141 | ast 142 | (-> ast 143 | (update-in [:body] -box) 144 | (update-in [:o-tag] u/box)))] 145 | (assoc ast 146 | :params (mapv (fn [{:keys [o-tag] :as p}] 147 | (assoc p :o-tag (u/prim-or-obj o-tag))) params) 148 | :tag (u/prim-or-obj tag) 149 | :o-tag (u/prim-or-obj tag)))) 150 | 151 | (defmethod box :if 152 | [{:keys [test then else tag o-tag] :as ast}] 153 | (let [test-tag (:tag test) 154 | test (if (and (u/primitive? test-tag) 155 | (not= Boolean/TYPE test-tag)) 156 | (assoc test :tag (u/box test-tag)) 157 | test) 158 | [then else o-tag] (if (or (boxed? tag then) 159 | (boxed? tag else) 160 | (not o-tag)) 161 | (conj (mapv -box [then else]) (u/box o-tag)) 162 | [then else o-tag])] 163 | (merge ast 164 | {:test test 165 | :o-tag o-tag 166 | :then then 167 | :else else}))) 168 | 169 | (defmethod box :case 170 | [{:keys [tag default tests thens test-type] :as ast}] 171 | (let [ast (if (and tag (u/primitive? tag)) 172 | ast 173 | (-> ast 174 | (assoc-in [:thens] (mapv (fn [t] (update-in t [:then] -box)) thens)) 175 | (update-in [:default] -box) 176 | (update-in [:o-tag] u/box)))] 177 | (if (= :hash-equiv test-type) 178 | (-> ast 179 | (update-in [:test] -box) 180 | (assoc-in [:tests] (mapv (fn [t] (update-in t [:test] -box)) tests))) 181 | ast))) 182 | 183 | (defmethod box :try 184 | [{:keys [tag] :as ast}] 185 | (let [ast (if (and tag (u/primitive? tag)) 186 | ast 187 | (-> ast 188 | (update-in [:catches] #(mapv -box %)) 189 | (update-in [:body] -box) 190 | (update-in [:o-tag] u/box)))] 191 | (-> ast 192 | (update-in [:finally] -box)))) 193 | 194 | (defmethod box :invoke 195 | [ast] 196 | (assoc ast 197 | :args (mapv -box (:args ast)) 198 | :o-tag Object)) 199 | 200 | (defmethod box :default [ast] ast) 201 | -------------------------------------------------------------------------------- /src/main/clojure/clojure/tools/analyzer/passes/jvm/validate_loop_locals.clj: -------------------------------------------------------------------------------- 1 | ;; Copyright (c) Nicola Mometto, Rich Hickey & contributors. 2 | ;; The use and distribution terms for this software are covered by the 3 | ;; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) 4 | ;; which can be found in the file epl-v10.html at the root of this distribution. 5 | ;; By using this software in any fashion, you are agreeing to be bound by 6 | ;; the terms of this license. 7 | ;; You must not remove this notice, or any other, from this software. 8 | 9 | (ns clojure.tools.analyzer.passes.jvm.validate-loop-locals 10 | (:require [clojure.tools.analyzer.ast :refer [postwalk children update-children]] 11 | [clojure.tools.analyzer.jvm.utils :refer [wider-tag maybe-class primitive?]] 12 | [clojure.tools.analyzer.passes.jvm 13 | [validate :refer [validate]] 14 | [classify-invoke :refer [classify-invoke]] 15 | [infer-tag :refer [infer-tag]] 16 | [analyze-host-expr :refer [analyze-host-expr]]])) 17 | 18 | (def ^:dynamic ^:private validating nil) 19 | (def ^:dynamic ^:private mismatch?) 20 | (def ^:dynamic ^:private *loop-locals* []) 21 | 22 | (defn find-mismatches [{:keys [op exprs] :as ast} bindings] 23 | (case op 24 | :recur 25 | (when (some true? (mapv (fn [e {:keys [tag init form]}] 26 | (and (or (primitive? tag) 27 | (not (or (:tag (meta form)) 28 | (:tag (meta (:form init)))))) 29 | (not= (:tag e) tag))) exprs bindings)) 30 | (swap! mismatch? conj (mapv :tag exprs))) 31 | :do 32 | (doseq [child (children ast)] 33 | (find-mismatches child bindings)) 34 | (:let :letfn) 35 | (find-mismatches (:body ast) bindings) 36 | :if 37 | (do (find-mismatches (:then ast) bindings) 38 | (find-mismatches (:else ast) bindings)) 39 | :case 40 | (do (find-mismatches (:default ast) bindings) 41 | (doseq [child (:thens ast)] 42 | (find-mismatches child bindings))) 43 | nil) 44 | ast) 45 | 46 | (defmulti -validate-loop-locals (fn [_ {:keys [op]}] op)) 47 | (defmulti -cleanup-dirty-nodes :op) 48 | 49 | (defmethod -cleanup-dirty-nodes :local 50 | [{:keys [form name atom env] :as ast}] 51 | (if-let [cast ((:loop-locals-casts env) name)] 52 | (assoc ast 53 | :dirty? true 54 | :o-tag cast 55 | :tag (or (:tag (meta form)) cast)) 56 | (if (and (:dirty? @atom) 57 | (not (:tag (meta form)))) 58 | (dissoc (assoc ast :dirty? true) :o-tag :tag) 59 | ast))) 60 | 61 | (defn dirty [ast] 62 | (when-let [atom (:atom ast)] 63 | (swap! atom assoc :dirty? true)) 64 | (assoc (update-children ast (fn [ast] (dissoc ast :dirty?))) 65 | :dirty? true)) 66 | 67 | (defmethod -cleanup-dirty-nodes :do 68 | [{:keys [op ret] :as ast}] 69 | (if (:dirty? ret) 70 | (dissoc (dirty ast) :tag) 71 | ast)) 72 | 73 | ;; should check for :tag meta form 74 | (defmethod -cleanup-dirty-nodes :default 75 | [{:keys [op] :as ast}] 76 | (if (some :dirty? (children ast)) 77 | (dissoc (dirty ast) 78 | :tag :validated? (when (= :instance-call op) :class)) 79 | ast)) 80 | 81 | (defn -validate-loop-locals* 82 | [analyze {:keys [body env loop-id] :as ast} key] 83 | (if validating 84 | ast 85 | (binding [mismatch? (atom #{})] 86 | (let [bindings (key ast)] 87 | (find-mismatches body bindings) 88 | (if-let [mismatches (seq @mismatch?)] 89 | (let [bindings-form (apply mapv 90 | (fn [{:keys [form tag]} & mismatches] 91 | (when-not (every? #{tag} mismatches) 92 | (let [tags (conj mismatches tag)] 93 | (with-meta form {:tag (or (and (some primitive? tags) 94 | (wider-tag tags)) 95 | Object)})))) 96 | bindings mismatches) 97 | loop-locals (mapv :name bindings) 98 | binds (zipmap loop-locals (mapv (comp maybe-class :tag meta) bindings-form)) 99 | analyze* (fn [ast] 100 | (analyze (postwalk ast 101 | (fn [ast] 102 | (when-let [atom (:atom ast)] 103 | (swap! atom dissoc :dirty?)) 104 | ast))))] 105 | (binding [validating loop-id 106 | *loop-locals* loop-locals] 107 | (analyze* (dissoc (postwalk (assoc ast key 108 | (mapv (fn [{:keys [atom] :as bind} f] 109 | (if f 110 | (do 111 | (swap! atom assoc :dirty? true) 112 | (assoc (dissoc bind :tag) :form f)) 113 | bind)) 114 | (key ast) bindings-form)) 115 | (comp -cleanup-dirty-nodes 116 | (fn [ast] (assoc-in ast [:env :loop-locals-casts] binds)))) 117 | :dirty?)))) 118 | ast))))) 119 | 120 | (defmethod -validate-loop-locals :loop 121 | [analyze ast] 122 | (-validate-loop-locals* analyze ast :bindings)) 123 | 124 | (defmethod -validate-loop-locals :fn-method 125 | [analyze ast] 126 | (-validate-loop-locals* analyze ast :params)) 127 | 128 | (defmethod -validate-loop-locals :method 129 | [analyze ast] 130 | (-validate-loop-locals* analyze ast :params)) 131 | 132 | (defmethod -validate-loop-locals :recur 133 | [_ {:keys [exprs env loop-id] :as ast}] 134 | (if (= validating loop-id) 135 | (let [casts (:loop-locals-casts env)] 136 | (assoc ast 137 | :exprs (mapv (fn [{:keys [env form] :as e} n] 138 | (if-let [c (casts n)] 139 | (assoc e :tag c) 140 | e)) exprs *loop-locals*))) 141 | ast)) 142 | 143 | (defmethod -validate-loop-locals :default 144 | [_ ast] 145 | ast) 146 | 147 | (defn validate-loop-locals 148 | "Returns a pass that validates the loop locals, calling analyze on the loop AST when 149 | a mismatched loop-local is found" 150 | {:pass-info {:walk :post :depends #{#'validate} :affects #{#'analyze-host-expr #'infer-tag #'validate} :after #{#'classify-invoke}}} 151 | [analyze] 152 | (fn [ast] (-validate-loop-locals analyze ast))) 153 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # tools.analyzer.jvm 2 | 3 | An analyzer for Clojure code, written on top of [tools.analyzer](https://github.com/clojure/tools.analyzer), providing additional jvm-specific passes. 4 | 5 | * [Example Usage](#example-usage) 6 | * [AST Quickref](#ast-quickref) 7 | * [Releases and Dependency Information](#releases-and-dependency-information) 8 | * [Changelog](#changelog) 9 | * [API Index](#api-index) 10 | * [Developer Information](#developer-information) 11 | * [License](#license) 12 | 13 | ## Note for REPL usage 14 | 15 | The AST `tools.analyzer.jvm` produces contains *a lot* of redundant information and while having this structure in memory will not require an excessive amount of memory thanks to structural sharing, attempting to print the AST of even a relatively small clojure expression can easily produce a several thousand lines output which might make your REPL irresponsive for several seconds or even crash it. 16 | For this reason, when exploring `tools.analyzer.jvm` ASTs on the REPL, I encourage you to: 17 | * set `*print-length*` and `*print-level*` to a small value, like 10 18 | * interactively explore the AST structure, inspecting the `:children` and `:op` fields of a node and the `keys` function rather than printing it to see its content 19 | 20 | ## Example Usage 21 | 22 | Calling `analyze` on the form is all it takes to get its AST (the output has been pretty printed for clarity): 23 | ```clojure 24 | user> (require '[clojure.tools.analyzer.jvm :as ana.jvm]) 25 | nil 26 | user> (ana.jvm/analyze 1) 27 | {:op :const, 28 | :env {:context :ctx/expr, :locals {}, :ns user}, 29 | :form 1, 30 | :top-level true, 31 | :val 1, 32 | :type :number, 33 | :literal? true, 34 | :id 0, 35 | :tag long, 36 | :o-tag long} 37 | ``` 38 | 39 | To get a clojure form out of an AST, use the `emit-form` pass: 40 | ```clojure 41 | user> (require '[clojure.tools.analyzer.passes.jvm.emit-form :as e]) 42 | nil 43 | user> (e/emit-form (ana.jvm/analyze '(let [a 1] a))) 44 | (let* [a 1] a) 45 | ``` 46 | Note that the output will be fully macroexpanded. 47 | You can also get an hygienic form back, using the `emit-hygienic-form` pass: 48 | ```clojure 49 | user> (e/emit-hygienic-form (ana.jvm/analyze '(let [a 1 a a] a))) 50 | (let* [a__#0 1 a__#1 a__#0] a__#1) 51 | ``` 52 | As you can see the local names are renamed to resolve shadowing. 53 | 54 | The `analyze` function can take an environment arg (when not provided it uses the default empty-env) which allows for more advanced usages, like injecting locals from an outer scope: 55 | ```clojure 56 | user> (-> '(let [a a] a) 57 | (ana.jvm/analyze (assoc (ana.jvm/empty-env) 58 | :locals '{a {:op :binding 59 | :name a 60 | :form a 61 | :local :let}})) 62 | e/emit-hygienic-form) 63 | (let* [a__#0 a] a__#0) 64 | ``` 65 | 66 | There's also an `analyze+eval` function that, as the name suggests, evaluates the form after its analysis and stores the resulting value in the `:result` field of the AST, this function should be used when analyzing multiple forms, as the analysis of a clojure form might require the evaluation of a previous one to make sense. 67 | 68 | This would not work using `analyze` but works fine when using `analyze+eval`: 69 | ```clojure 70 | user> (ana.jvm/analyze+eval '(defmacro x [])) 71 | {:op :do, 72 | :top-level true, 73 | :form (do (clojure.core/defn x ([&form &env])) (. (var x) (setMacro)) (var x)), 74 | ... , 75 | :result #'user/x} 76 | user> (ana.jvm/analyze+eval '(x)) 77 | {:op :const, 78 | :env {:context :ctx/expr, :locals {}, :ns user}, 79 | :form nil, 80 | :top-level true, 81 | :val nil, 82 | :type :nil, 83 | :literal? true, 84 | :tag java.lang.Object, 85 | :o-tag java.lang.Object, 86 | :result nil} 87 | ``` 88 | 89 | To analyze a whole namespace, use `analyze-ns` which behaves like `analyze+eval` and puts the ASTs for each analyzed form in a vector, in order. 90 | ```clojure 91 | user> (ana.jvm/analyze-ns 'clojure.string) 92 | [{:op :do, 93 | :result nil, 94 | :top-level true, 95 | :form (do (clojure.core/in-ns (quote clojure.string)) ..), 96 | ...} 97 | ..] 98 | ``` 99 | 100 | [AST Quickref](https://clojure.github.io/tools.analyzer.jvm/spec/quickref.html) 101 | ======================================== 102 | Note that the quickref refers to the last stable release of t.a.jvm and might not be valid for the current SNAPSHOT version or for previous ones. 103 | Note also that the documented node fields refer to the output of t.a.jvm/analyze running the default passes and using the default configuration. 104 | 105 | ## SPONSORSHIP 106 | 107 | * Cognitect (https://cognitect.com/) has sponsored tools.analyzer.jvm development (https://groups.google.com/d/msg/clojure/iaP16MHpX0E/EMtnGmOz-rgJ) 108 | * Ambrose BS (https://twitter.com/ambrosebs) has sponsored tools.analyzer.jvm development in his typed clojure campaign (http://www.indiegogo.com/projects/typed-clojure). 109 | 110 | ## YourKit 111 | 112 | YourKit has given an open source license for their profiler, greatly simplifying the profiling of tools.analyzer.jvm performance. 113 | 114 | YourKit is kindly supporting open source projects with its full-featured Java Profiler. YourKit, LLC is the creator of innovative and intelligent tools for profiling Java and .NET applications. Take a look at YourKit's leading software products: 115 | 116 | * YourKit Java Profiler and 117 | * YourKit .NET Profiler. 118 | 119 | Releases and Dependency Information 120 | ======================================== 121 | 122 | Latest stable release: 1.3.2 123 | 124 | * [All Released Versions](https://search.maven.org/#search%7Cgav%7C1%7Cg%3A%22org.clojure%22%20AND%20a%3A%22tools.analyzer.jvm%22) 125 | * [Development Snapshot Versions](https://oss.sonatype.org/index.html#nexus-search;gav%7Eorg.clojure%7Etools.analyzer.jvm%7E%7E%7E) 126 | 127 | [Leiningen](https://github.com/technomancy/leiningen) dependency information: 128 | 129 | ```clojure 130 | [org.clojure/tools.analyzer.jvm "1.3.2"] 131 | ``` 132 | 133 | [Maven](https://maven.apache.org/) dependency information: 134 | 135 | ```xml 136 | 137 | org.clojure 138 | tools.analyzer.jvm 139 | 1.3.2 140 | 141 | ``` 142 | 143 | [Changelog](CHANGELOG.md) 144 | ======================================== 145 | 146 | API Index 147 | ======================================== 148 | 149 | * [API index](https://clojure.github.io/tools.analyzer.jvm) 150 | 151 | Developer Information 152 | ======================================== 153 | 154 | * [GitHub project](https://github.com/clojure/tools.analyzer.jvm) 155 | * [Bug Tracker](https://clojure.atlassian.net/browse/TANAL) 156 | * [Continuous Integration](https://github.com/clojure/tools.analyzer.jvm/actions/workflows/test.yml) 157 | 158 | ## License 159 | 160 | Copyright © Nicola Mometto, Rich Hickey & contributors. 161 | 162 | Distributed under the Eclipse Public License, the same as Clojure. 163 | -------------------------------------------------------------------------------- /src/main/clojure/clojure/tools/analyzer/passes/jvm/analyze_host_expr.clj: -------------------------------------------------------------------------------- 1 | ;; Copyright (c) Nicola Mometto, Rich Hickey & contributors. 2 | ;; The use and distribution terms for this software are covered by the 3 | ;; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) 4 | ;; which can be found in the file epl-v10.html at the root of this distribution. 5 | ;; By using this software in any fashion, you are agreeing to be bound by 6 | ;; the terms of this license. 7 | ;; You must not remove this notice, or any other, from this software. 8 | 9 | (ns clojure.tools.analyzer.passes.jvm.analyze-host-expr 10 | (:require [clojure.tools.analyzer :as ana] 11 | [clojure.tools.analyzer.utils :refer [ctx source-info merge']] 12 | [clojure.tools.analyzer.jvm.utils :refer :all])) 13 | 14 | (defn maybe-static-field [[_ class sym]] 15 | (when-let [{:keys [flags type name]} (static-field class sym)] 16 | {:op :static-field 17 | :assignable? (not (:final flags)) 18 | :class class 19 | :field name 20 | :o-tag type 21 | :tag type})) 22 | 23 | (defn maybe-static-method [[_ class sym]] 24 | (when-let [{:keys [name return-type]} (static-method class sym)] 25 | {:op :static-call 26 | :tag return-type 27 | :o-tag return-type 28 | :class class 29 | :method name})) 30 | 31 | (defn maybe-instance-method [target-expr class sym] 32 | (when-let [{:keys [return-type]} (instance-method class sym)] 33 | {:op :instance-call 34 | :tag return-type 35 | :o-tag return-type 36 | :instance target-expr 37 | :class class 38 | :method sym 39 | :children [:instance]})) 40 | 41 | (defn maybe-instance-field [target-expr class sym] 42 | (when-let [{:keys [flags name type]} (instance-field class sym)] 43 | {:op :instance-field 44 | :assignable? (not (:final flags)) 45 | :class class 46 | :instance target-expr 47 | :field name 48 | :tag type 49 | :o-tag type 50 | :children [:instance]})) 51 | 52 | (defn analyze-host-call 53 | [target-type method args target-expr class env] 54 | (let [op (case target-type 55 | :static :static-call 56 | :instance :instance-call)] 57 | (merge 58 | {:op op 59 | :method method 60 | :args args} 61 | (case target-type 62 | :static {:class class 63 | :children [:args]} 64 | :instance {:instance target-expr 65 | :class (maybe-class (:tag target-expr)) 66 | :children [:instance :args]})))) 67 | 68 | (defn analyze-host-field 69 | [target-type field target-expr class env] 70 | (if class 71 | (case target-type 72 | :static (or (maybe-static-field (list '. class field)) 73 | (throw (ex-info (str "Cannot find field " 74 | field " for class " class) 75 | (merge {:class class 76 | :field field} 77 | (source-info env))))) 78 | :instance (or (maybe-instance-field target-expr class field) 79 | {:op :host-interop 80 | :target (dissoc target-expr :tag :validated?) 81 | :m-or-f field 82 | :assignable? true 83 | :children [:target]} 84 | (when (:literal? target-expr) 85 | (throw (ex-info (str "Cannot find field " 86 | field " for class " class) 87 | (merge {:instance (dissoc target-expr :env) 88 | :field field} 89 | (source-info env))))))) 90 | {:op :host-interop 91 | :target target-expr 92 | :m-or-f field 93 | :assignable? true 94 | :children [:target]})) 95 | 96 | (defn -analyze-host-expr 97 | [target-type m-or-f target-expr class env] 98 | (let [target-class (-> target-expr :tag) 99 | [field method] (if class 100 | [(maybe-static-field (list '. class m-or-f)) 101 | (maybe-static-method (list '. class m-or-f))] 102 | (when target-class 103 | [(maybe-instance-field target-expr target-class m-or-f) 104 | (maybe-instance-method target-expr target-class m-or-f)]))] 105 | (cond 106 | 107 | (not (or class target-class)) 108 | {:op :host-interop 109 | :target target-expr 110 | :m-or-f m-or-f 111 | :assignable? true 112 | :children [:target]} 113 | 114 | method 115 | method 116 | 117 | field 118 | field 119 | 120 | class 121 | (throw (ex-info (str "Cannot find field or no-arg method call " 122 | m-or-f " for class " class) 123 | (merge {:class class 124 | :m-or-f m-or-f} 125 | (source-info env)))) 126 | 127 | target-class 128 | {:op :host-interop 129 | :target (dissoc target-expr :tag :validated?) 130 | :m-or-f m-or-f 131 | :assignable? true 132 | :children [:target]} 133 | 134 | :else 135 | (when (:literal? target-expr) 136 | (throw (ex-info (str "Cannot find field or no-arg method call " 137 | m-or-f " for class " target-class) 138 | (merge {:instance (dissoc target-expr :env) 139 | :m-or-f m-or-f} 140 | (source-info env)))))))) 141 | 142 | (defn analyze-host-expr 143 | "Performing some reflection, transforms :host-interop/:host-call/:host-field 144 | nodes in either: :static-field, :static-call, :instance-call, :instance-field 145 | or :host-interop nodes, and a :var/:maybe-class/:maybe-host-form node in a 146 | :const :class node, if necessary (class literals shadow Vars). 147 | 148 | A :host-interop node represents either an instance-field or a no-arg instance-method. " 149 | {:pass-info {:walk :post :depends #{}}} 150 | [{:keys [op target form tag env class] :as ast}] 151 | (case op 152 | (:host-interop :host-call :host-field) 153 | (let [target (if-let [the-class (and (= :local (:op target)) 154 | (maybe-class-literal (:form target)))] 155 | (merge target 156 | (assoc (ana/analyze-const the-class env :class) 157 | :tag Class 158 | :o-tag Class)) 159 | target) 160 | class? (and (= :const (:op target)) 161 | (= :class (:type target)) 162 | (:form target)) 163 | target-type (if class? :static :instance)] 164 | (merge' (dissoc ast :assignable? :target :args :children) 165 | (case op 166 | 167 | :host-call 168 | (analyze-host-call target-type (:method ast) 169 | (:args ast) target class? env) 170 | 171 | :host-field 172 | (analyze-host-field target-type (:field ast) 173 | target (or class? (:tag target)) env) 174 | 175 | :host-interop 176 | (-analyze-host-expr target-type (:m-or-f ast) 177 | target class? env)) 178 | (when tag 179 | {:tag tag}))) 180 | :var 181 | (if-let [the-class (and (not (namespace form)) 182 | (pos? (.indexOf (str form) ".")) 183 | (maybe-class-literal form))] 184 | (assoc (ana/analyze-const the-class env :class) :form form) 185 | ast) 186 | 187 | :maybe-class 188 | (if-let [the-class (maybe-class-literal class)] 189 | (assoc (ana/analyze-const the-class env :class) :form form) 190 | ast) 191 | 192 | :maybe-host-form 193 | (if-let [the-class (maybe-array-class-sym (symbol (str (:class ast)) 194 | (str (:field ast))))] 195 | (assoc (ana/analyze-const the-class env :class) :form form) 196 | ast) 197 | 198 | ast)) 199 | -------------------------------------------------------------------------------- /src/test/clojure/clojure/tools/analyzer/jvm/passes_test.clj: -------------------------------------------------------------------------------- 1 | (ns clojure.tools.analyzer.jvm.passes-test 2 | (:refer-clojure :exclude [macroexpand-1]) 3 | (:require [clojure.tools.analyzer.ast :refer :all] 4 | [clojure.tools.analyzer.jvm :as ana.jvm] 5 | [clojure.tools.analyzer.env :as env] 6 | [clojure.tools.analyzer.passes :refer [schedule]] 7 | [clojure.test :refer [deftest is]] 8 | [clojure.set :as set] 9 | [clojure.tools.analyzer.passes.add-binding-atom :refer [add-binding-atom]] 10 | [clojure.tools.analyzer.passes.collect-closed-overs :refer [collect-closed-overs]] 11 | [clojure.tools.analyzer.jvm.core-test :refer [ast ast1 e f f1]] 12 | [clojure.tools.analyzer.passes.jvm.emit-form 13 | :refer [emit-form emit-hygienic-form]] 14 | [clojure.tools.analyzer.passes.jvm.validate :as v] 15 | [clojure.tools.analyzer.passes.jvm.annotate-tag :refer [annotate-tag]] 16 | [clojure.tools.analyzer.passes.jvm.infer-tag :refer [infer-tag]] 17 | [clojure.tools.analyzer.passes.jvm.annotate-branch :refer [annotate-branch]] 18 | [clojure.tools.analyzer.passes.jvm.annotate-host-info :refer [annotate-host-info]] 19 | [clojure.tools.analyzer.passes.jvm.annotate-loops :refer [annotate-loops]] 20 | [clojure.tools.analyzer.passes.jvm.fix-case-test :refer [fix-case-test]] 21 | [clojure.tools.analyzer.passes.jvm.analyze-host-expr :refer [analyze-host-expr]] 22 | [clojure.tools.analyzer.passes.jvm.classify-invoke :refer [classify-invoke]]) 23 | (:import (clojure.lang Keyword Var Symbol AFunction 24 | PersistentVector PersistentArrayMap PersistentHashSet ISeq) 25 | java.util.regex.Pattern)) 26 | 27 | (defn validate [ast] 28 | (env/with-env (ana.jvm/global-env) 29 | (v/validate ast))) 30 | 31 | (deftest emit-form-test 32 | (is (= '(monitor-enter 1) (emit-form (ast (monitor-enter 1))))) 33 | (is (= '(monitor-exit 1) (emit-form (ast (monitor-exit 1))))) 34 | (is (= '(clojure.core/import* "java.lang.String") 35 | (emit-form (validate (ast (clojure.core/import* "java.lang.String")))))) 36 | (is (= '(var clojure.core/+) (emit-form (ast #'+)))) 37 | (is (= '(:foo {}) (emit-form (ast (:foo {}))))) 38 | (is (= '(try 1 (catch Exception e nil)) 39 | (emit-form (ana.jvm/analyze '(try 1 (catch Exception e)))))) 40 | (is (= '(try 1 (catch Exception e nil)) 41 | (emit-form (ana.jvm/analyze '(try 1 (catch Exception e))) 42 | {:qualifed-symbols true}))) 43 | (is (= '(f [] 1) (emit-form (ast (f [] 1)))))) 44 | 45 | (deftest annotate-branch-test 46 | (let [i-ast (annotate-branch (ast (if 1 2 3)))] 47 | (is (:branch? i-ast)) 48 | (is (= true (-> i-ast :test :test?))) 49 | (is (= true (-> i-ast :then :path?))) 50 | (is (= true (-> i-ast :else :path?)))) 51 | 52 | (let [fn-ast (prewalk (ast (fn ([]) ([x]))) annotate-branch)] 53 | (is (every? :path? (-> fn-ast :methods)))) 54 | 55 | (let [r-ast (prewalk (ast (reify Object (toString [this] x))) annotate-branch)] 56 | (is (every? :path? (-> r-ast :methods)))) 57 | 58 | (let [c-ast (-> (ast (case 1 0 0 2 2 1)) :body :ret (prewalk annotate-branch))] 59 | (is (:branch? c-ast)) 60 | (is (= true (-> c-ast :test :test?))) 61 | (is (= true (-> c-ast :default :path?))) 62 | (is (every? :path? (-> c-ast :thens))))) 63 | 64 | (deftest fix-case-test-test 65 | (let [c-ast (-> (ast (case 1 1 1)) add-binding-atom (prewalk fix-case-test))] 66 | (is (= true (-> c-ast :body :ret :test :atom deref :case-test))))) 67 | 68 | (deftest annotate-tag-test 69 | (is (= PersistentVector (-> {:op :const :form [] :val []} annotate-tag :tag))) 70 | (is (= PersistentVector (-> (ast []) annotate-tag :tag))) 71 | (is (= PersistentArrayMap(-> (ast {}) annotate-tag :tag))) 72 | (is (= PersistentHashSet (-> (ast #{}) annotate-tag :tag))) 73 | (is (= Class (-> {:op :const :type :class :form Object :val Object} 74 | annotate-tag :tag))) 75 | (is (= String (-> (ast "foo") annotate-tag :tag))) 76 | (is (= Keyword (-> (ast :foo) annotate-tag :tag))) 77 | (is (= Character/TYPE (-> (ast \f) annotate-tag :tag))) 78 | (is (= Long/TYPE (-> (ast 1) annotate-tag :tag))) 79 | (is (= Pattern (-> (ast #"foo") annotate-tag :tag))) 80 | (is (= Var (-> (ast #'+) annotate-tag :tag))) 81 | (is (= Boolean (-> (ast true) annotate-tag :tag))) 82 | (let [b-ast (-> (ast (let [a 1] a)) add-binding-atom 83 | (postwalk annotate-tag))] 84 | (is (= Long/TYPE (-> b-ast :body :ret :tag))))) 85 | 86 | (deftest classify-invoke-test 87 | (is (= :keyword-invoke (-> (ast (:foo {})) classify-invoke :op))) 88 | (is (= :invoke (-> (ast (:foo {} 1)) classify-invoke :op))) 89 | (is (= :protocol-invoke (-> (ast (f nil)) classify-invoke :op))) 90 | (is (= :instance? (-> (ast (instance? String "")) 91 | (prewalk analyze-host-expr) classify-invoke :op))) 92 | (is (= :prim-invoke (-> (ast (f1 1)) (prewalk infer-tag) classify-invoke :op)))) 93 | 94 | (deftest annotate-host-info-test 95 | (let [r-ast (-> (ast ^:foo (reify Object (toString [_] ""))) (prewalk annotate-host-info))] 96 | (is (= 'toString (-> r-ast :expr :methods first :name))) 97 | (is (= [] (-> r-ast :expr :methods first :params))) 98 | (is (= '_ (-> r-ast :expr :methods first :this :name))))) 99 | 100 | ;; TODO: test primitives, tag matching, throwing validation, method validation 101 | (deftest validate-test 102 | (is (= Exception (-> (ast (try (catch Exception e))) 103 | (prewalk (comp validate analyze-host-expr)) :catches first :class :val))) 104 | (is (-> (ast (set! *warn-on-reflection* true)) validate)) 105 | (is (= true (-> (ast (String. "foo")) (postwalk (comp validate annotate-tag analyze-host-expr)) 106 | :validated?))) 107 | 108 | (let [s-ast (-> (ast (Integer/parseInt "7")) (prewalk annotate-tag) analyze-host-expr validate)] 109 | (is (:validated? s-ast)) 110 | (is (= Integer/TYPE (:tag s-ast))) 111 | (is (= [String] (mapv :tag (:args s-ast))))) 112 | 113 | (let [i-ast (-> (ast (.hashCode "7")) (prewalk annotate-tag) analyze-host-expr validate)] 114 | (is (:validated? i-ast)) 115 | (is (= Integer/TYPE (:tag i-ast))) 116 | (is (= [] (mapv :tag (:args i-ast)))) 117 | (is (= String (:class i-ast)))) 118 | 119 | (is (= true (-> (ast (import java.lang.String)) (prewalk validate) :ret :validated?)))) 120 | 121 | ;; we need all or most those passes to perform those tests 122 | (deftest all-passes-test 123 | (let [t-ast (ast1 (let [a 1 124 | b 2 125 | c (str a) 126 | d (Integer/parseInt c b)] 127 | (Integer/getInteger c d)))] 128 | (is (= Integer (-> t-ast :body :tag))) 129 | (is (= Integer (-> t-ast :tag))) 130 | (is (= Long/TYPE (->> t-ast :bindings (filter #(= 'a (:form %))) first :tag))) 131 | (is (= String (->> t-ast :bindings (filter #(= 'c (:form %))) first :tag))) 132 | (is (= Integer/TYPE (->> t-ast :bindings (filter #(= 'd (:form %))) first :tag)))) 133 | (is (= Void/TYPE (:tag (ast1 (.println System/out "foo"))))) 134 | 135 | (is (= String (-> (ast1 String) :val))) 136 | (is (= 'String (-> (ast1 String) :form))) 137 | (is (= PersistentVector (-> (ast1 '[]) :tag))) 138 | (is (= ISeq (-> (ast1 '()) :tag))) 139 | 140 | (let [d-ast (ast1 (Double/isInfinite 2))] 141 | (is (= Boolean/TYPE (-> d-ast :tag))) 142 | (is (= Double/TYPE (->> d-ast :args first :tag))))) 143 | 144 | ;; checks for specific bugs that have surfaced 145 | (deftest annotate-case-loop 146 | (is (ast1 (loop [] (case 1 :a (recur) :b 42))))) 147 | 148 | (deftest var-tag-inference 149 | (let [ast (ana.jvm/analyze '(def a "foo") 150 | (ana.jvm/empty-env) 151 | {:passes-opts (merge ana.jvm/default-passes-opts 152 | {:infer-tag/level :global})})] 153 | (is (= String (-> ast :var meta :tag))))) 154 | 155 | (deftest validate-handlers 156 | ;; test for tanal-24, without the handler analysis would throw 157 | ;; with an handler that ignores the tag, we can simulate the current behaviour 158 | ;; of the clojure compiler 159 | (is (ana.jvm/analyze '(defn ^long a [] 1) 160 | (ana.jvm/empty-env) 161 | {:passes-opts (merge ana.jvm/default-passes-opts 162 | {:validate/wrong-tag-handler (fn [t ast] 163 | {t nil})})}))) 164 | -------------------------------------------------------------------------------- /CHANGELOG.md: -------------------------------------------------------------------------------- 1 | Changelog 2 | ======================================== 3 | Since tools.analyzer.jvm version are usually cut simultaneously with a tools.analyzer version, check also the tools.analyzer [CHANGELOG](https://github.com/clojure/tools.analyzer/blob/master/CHANGELOG.md) for changes on the corresponding version, since changes in that library will reflect on this one. 4 | - - - 5 | * Release 1.3.2 on 17 Jan 2025 6 | * Removed reflection warnings on internal use of Character/isDigit 7 | * Release 1.3.1 on 2 Dec 2024 8 | * Added support for Clojure 1.12 array class syntax 9 | * Release 1.3.0 on 19 Feb 2024 10 | * Bumped deps on parent pom, tools.analyzer, core.memoize, tools.reader 11 | * Release 1.2.3 on 26 Nov 2022 12 | * Bumped dep on tools.analyzer to 1.1.1 13 | * Release 1.2.2 on 13 Dec 2021 14 | * Bumped dep on asm to 9.2 15 | * Release 1.2.1 on 6 Dec 2021 16 | * Bumped dep on core.memoize to 1.0.253 17 | * Bumped dep on tools.reader to 1.3.6 18 | * Release 1.2.0 on 14 Sep 2021 19 | * Bumped dep on tools.analyzer to 1.1.0 20 | * Release 1.1.0 on 24 Jul 2020 21 | * Bumped dep on core.memoize to 1.0.236 22 | * Release 1.0.0 on 18 Feb 2020 23 | * Avoid calling `update-ns-map` on known pure vars 24 | * Release 0.7.3 on 2 Dec 2019 25 | * Bumped deps 26 | * Release 0.7.2 on 16 Jan 2018 27 | * Correctly handle deftype analysis when `let` is excluded 28 | * Release 0.7.1 on 21 Jun 2017 29 | * Correctly handle array classes 30 | * Release 0.7.0 on 14 Feb 2017 31 | * Release 0.7.0-alpha1 on 26 Jan 2017 32 | * Added handle-evaluation-exception opts to `analyze+eval` 33 | * Changed `analyze+eval`'s default behaviour on eval exception 34 | * Stop caching maybe-class-from-string as it implicitely relies on dynamic state 35 | * Make analyze work from nested invocations -- remove state mutation 36 | * Release 0.6.10 on 17 Jun 2016 37 | * Fix ns munging 38 | * Release 0.6.9 on 10 Nov 2015 39 | * Correctly check for recur on case :then branches 40 | * Release 0.6.8 on 3 Nov 2015 41 | * Fixed eof check in tools.reader usage 42 | * Avoid reflection on catch local 43 | * Fix context in analyze+eval statement 44 | * Release 0.6.7 on 23 Apr 2015 45 | * Add support for reader conditionals 46 | * Ensure *file* is correctly bound in analyze-ns 47 | * Fixed emit-form for :host-interop 48 | * Release 0.6.6 on 23 Feb 2015 49 | * Small performance enhancements 50 | * Added validate-recur pass 51 | * Renamed annotate-methods to annotate-host-info 52 | * Fixed class resolution 53 | * Added macroexpand-all 54 | * Fixed ::resolved-op handling in analyze+eval 55 | * Release 0.6.5 on 20 Nov 2014 56 | * Ensure *ns* is correctly bound during analysis 57 | * Removed analyze' and analyze+eval' 58 | * Improvements in class resolution 59 | * Release 0.6.4 on 03 Nov 2014 60 | * Disallow def of a symbol that maps to a Class 61 | * Made the target of a host interop expression privilege classnames over the lexical scope, as in clojure 62 | * Preserve correct meta on emit-form 63 | * Validate the target of a new expression 64 | * Fixed bug that caused the symbols used as primitive type hints to be interpreted as classes in host interop expressions 65 | * Made update-ns-map! an optional global-env field 66 | * Enhanced source-info support on analyze+eval 67 | * Release 0.6.3 on 27 Oct 2014 68 | * Better interop method matcher 69 | * Fixed a bug when using analyze+eval and lein uberjar caused by Compiler/LOADER being unbound during macroexpansion 70 | * Faster maybe-class impl 71 | * Release 0.6.1 on 13 Oct 2014 72 | * Significant performance enhancements 73 | * Made Class literals shadow Vars 74 | * Fixed a bug in :arglists automatic tag qualification 75 | * :env :locals are no longer uniquified by default, can be changed via pass-opts 76 | * Fixed tag validation 77 | * Removed annotate-class-id, annotate-internal-name, ensure-tag, collect, collect-closed-overs and clear-locals, moved to tools.emiter.jvm 78 | * Fixed a bug in the method resolution code, caused some unnecessary reflection 79 | * Added opts and env args to analyze-ns, consistent with the other analyze functions 80 | * Made emit-form with :qualified-symbols qualify def symbol 81 | * Release 0.6.0 on 18 Sep 2014 82 | * Started using clojure.tools.analyzer.passes/schedule to schedule the default passes and configured all the passes 83 | * Reduced the set of default passes, removed: annotate-class-id, annotate-internal-name, ensure-tag 84 | * Changed the interface of the collect pass 85 | * Added default-passes and default-passes-opts to the clojure.tools.analyzer.jvm namespace 86 | * Release 0.5.6 on 02 Sep 2014 87 | * Fixed a bug in classify-invoke that caused default-exprs in keyword invoke expressions to be lost 88 | * Release 0.5.5 on 31 Aug 2014 89 | * Fixed analyze-ns analysis caching 90 | * Qualify :arglists class names 91 | * Release 0.5.4 on 21 Aug 2014 92 | * Added optional unresolved symbol handler, configurable via :passes-opts 93 | * Release 0.5.3 on 14 Aug 2014 94 | * Compare contexts with isa? rather than = 95 | * Fixed a reflection warning 96 | * Fixed a bug in the :protocol-invoke nodes that caused ast/children to crash 97 | * Release 0.5.2 on 09 Aug 2014 98 | * Fixed emit-form 99 | * Imported collect pass from tools.analyzer 100 | * Fixed infer-tag for :def 101 | * Release 0.5.1 on 09 Aug 2014 102 | * Allow ^:const values to be unboxed 103 | * Made :keyword a children in :keyword-invoke 104 | * Added optional Var tag inference, configurable via :passes-opts 105 | * Added optional wrong tag handler, configurable via :passes-opts 106 | * Added optional mismatched arity handler, configurable via :passes-opts 107 | * Release 0.5.0 on 29 Jul 2014 108 | * BREAKING CHANGE: changed :protocol-invoke and :keyword-invoke fields 109 | * Made :host-interop :assignable? 110 | * Release 0.4.0 on 26 Jul 2014 111 | * BREAKING CHANGE: update to new :class field for :new and :catch nodes 112 | * Elide source info metadata on :reify, :fn 113 | * Fixed performance regression 114 | * Added :qualified-symbols option to emit-form, deprecate :qualified-vars 115 | * Don't promote :invoke to :keyword-invoke when the keyword is namespaced 116 | * Added analyze-ns 117 | * Fixed some wrong contexts 118 | * Fixed and enhanced :tag/:arglists inference for :try nodes 119 | * Fixed handling of void bodies in loops 120 | * Collect closed-overs on :try 121 | * Release 0.3.0 on 21 Jun 2014 122 | * BREAKING API CHANGE: Updated to new :context 123 | * Fixed 1-arity macroexpand-1 124 | * validate throws on Var not found 125 | * Release 0.2.2 on 13 Jun 2014 126 | * Added 1-arity version of macroexpand-1 127 | * Made analyze+eval handle exceptions via ExceptionThrown 128 | * Fixed a bug in the validate pass that caused some instance-methods to stay unresolved 129 | * Keep :raw-forms on analyze+eval 130 | * Update \*ns\* in each call to analyze+eval 131 | * Release 0.2.1 on 08 Jun 2014 132 | * Made run-passes dynamic 133 | * Made analyze-host-expr and classify-invoke preserve the original AST fields 134 | * Release 0.2.0 on 05 Jun 2014 135 | * BREAKING API CHANGE: Updated to new global env interface 136 | * Made analyze+eval attach the result of evaluating the form to the AST 137 | * Release 0.1.0-beta13 on 11 Mar 2014 138 | * Don't run cleanup on analyze, added analyze' and analyze+eval' that run it 139 | * Added :top-level true to constructed :do nodes 140 | * Added 3-arity to analyze taking an optional map of options 141 | * Fixes regarding :fn-method :o-tag/:tag handling 142 | * Release 0.1.0-beta12 on 25 Apr 2014 143 | * Default to (empty-env) if env not provided 144 | * Fix a bug in check-recur with case 145 | * Release 0.1.0-beta11 on 18 Apr 2014 146 | * Performance enhancements on reflection utils 147 | * Workaround for a weird behaviour of clojure.reflect on interfaces 148 | * Fix for annotate-tag and validate-loop-locals interaction 149 | * Improve logic of try-best-match 150 | * Improve handling of Void tag 151 | * Fix handling of tag on constructor that defer to runtime reflection 152 | * Fix validate-loop-locals when the return type of the loop changed after the invalidation 153 | * Added :qualified-vars option to emit-form 154 | * Release 0.1.0-beta10 on 1 Apr 2014 155 | * Fix validate-loop-locals handling of tag 156 | * merge &form meta into mfrom meta to preserve source info during macroexpansion 157 | * Release 0.1.0-beta9 on 29 Mar 2014 158 | * Macroexpand evaluates :inline/:inline-arities to allow using the inlined version 159 | in the fn body 160 | * Fix fn name munging 161 | * Fix annotate-loops handling of statements 162 | * Update the ns map in the env after macroexpansion as some interning might 163 | happen at macroexpansion time 164 | * Added analyze+eval 165 | * Pass (:locals env) as &env instead of env, macros that use (keys &env) now work 166 | * Fix binding init tag 167 | * Fix create-var handling of meta 168 | * Release 0.1.0-beta8 on 11 Mar 2014 169 | * Removed :name in env for the :fn name, moved in a tools.analyzer.jvm pass 170 | * Added docstrings 171 | * Add annotate-internal-name pass 172 | * Add warn-on-reflection pass 173 | * clear-locals is *compiler-options* aware 174 | * Release 0.1.0-beta7 on 28 Feb 2014 175 | * Moved :should-not-clear annotation from annotate-branch to clear-locals 176 | * Release 0.1.0-beta6 on 27 Feb 2014 177 | * Bind Compiler/LOADER to a new DynamicClassLoader on every analyze call to avoid 178 | problems regarding deftype redefinitions 179 | * Fix handling of meta by create-var 180 | * Release 0.1.0-beta5 on 26 Feb 2014 181 | * Clear :catch locals 182 | * Added "this" clearing where possible (CLJ-1250) 183 | * Clear unused bindings 184 | * Attach the correct :tag on instance call/field instances 185 | * Fixes to clear-locals pass regarding nested loops 186 | * Release 0.1.0-beta4 on 17 Feb 2014 187 | * Fix validate-loop-locals to short-circuit on nested loops 188 | * Added docstrings 189 | * Correctly clear closed-overs on :once fns 190 | * Correctly clear closed-overs used in closure creation 191 | * Release 0.1.0-beta3 on 15 Feb 2014 192 | * Added annotate-class-id 193 | * clear-locals clears loop locals when possible 194 | * Release 0.1.0-beta2 on 14 Feb 2014 195 | * Memoize only maybe-class and member*, a new deftype invalidates the cache 196 | * Release 0.1.0-beta1 on 11 Feb 2014 197 | * First beta release 198 | -------------------------------------------------------------------------------- /src/main/clojure/clojure/tools/analyzer/passes/jvm/infer_tag.clj: -------------------------------------------------------------------------------- 1 | ;; Copyright (c) Nicola Mometto, Rich Hickey & contributors. 2 | ;; The use and distribution terms for this software are covered by the 3 | ;; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) 4 | ;; which can be found in the file epl-v10.html at the root of this distribution. 5 | ;; By using this software in any fashion, you are agreeing to be bound by 6 | ;; the terms of this license. 7 | ;; You must not remove this notice, or any other, from this software. 8 | 9 | (ns clojure.tools.analyzer.passes.jvm.infer-tag 10 | (:require [clojure.tools.analyzer.utils :refer [arglist-for-arity]] 11 | [clojure.tools.analyzer.jvm.utils :as u] 12 | [clojure.tools.analyzer.env :as env] 13 | [clojure.set :refer [rename-keys]] 14 | [clojure.tools.analyzer.passes.trim :refer [trim]] 15 | [clojure.tools.analyzer.passes.jvm 16 | [annotate-tag :refer [annotate-tag]] 17 | [annotate-host-info :refer [annotate-host-info]] 18 | [analyze-host-expr :refer [analyze-host-expr]] 19 | [fix-case-test :refer [fix-case-test]]])) 20 | 21 | (defmulti -infer-tag :op) 22 | (defmethod -infer-tag :default [ast] ast) 23 | 24 | (defmethod -infer-tag :binding 25 | [{:keys [init atom] :as ast}] 26 | (if init 27 | (let [info (select-keys init [:return-tag :arglists])] 28 | (swap! atom merge info) 29 | (merge ast info)) 30 | ast)) 31 | 32 | (defmethod -infer-tag :local 33 | [ast] 34 | (let [atom @(:atom ast)] 35 | (merge atom 36 | ast 37 | {:o-tag (:tag atom)}))) 38 | 39 | (defmethod -infer-tag :var 40 | [{:keys [var form] :as ast}] 41 | (let [{:keys [tag arglists]} (:meta ast) 42 | arglists (if (= 'quote (first arglists)) 43 | (second arglists) 44 | arglists) 45 | form-tag (:tag (meta form))] 46 | ;;if (not dynamic) 47 | (merge ast 48 | {:o-tag Object} 49 | (when-let [tag (or form-tag tag)] 50 | (if (fn? @var) 51 | {:tag clojure.lang.AFunction :return-tag tag} 52 | {:tag tag})) 53 | (when arglists 54 | {:arglists arglists})))) 55 | 56 | (defmethod -infer-tag :def 57 | [{:keys [var init name] :as ast}] 58 | (let [info (merge (select-keys init [:return-tag :arglists :tag]) 59 | (select-keys (meta name) [:tag :arglists]))] 60 | (when (and (seq info) 61 | (not (:dynamic (meta name))) 62 | (= :global (-> (env/deref-env) :passes-opts :infer-tag/level))) 63 | (alter-meta! var merge (rename-keys info {:return-tag :tag}))) 64 | (merge ast info {:tag clojure.lang.Var :o-tag clojure.lang.Var}))) 65 | 66 | (defmethod -infer-tag :quote 67 | [ast] 68 | (let [tag (-> ast :expr :tag)] 69 | (assoc ast :tag tag :o-tag tag))) 70 | 71 | (defmethod -infer-tag :new 72 | [ast] 73 | (let [t (-> ast :class :val)] 74 | (assoc ast :o-tag t :tag t))) 75 | 76 | (defmethod -infer-tag :with-meta 77 | [{:keys [expr] :as ast}] 78 | (merge ast (select-keys expr [:return-tag :arglists]) 79 | {:tag (or (:tag expr) Object) :o-tag Object})) ;;trying to be smart here 80 | 81 | (defmethod -infer-tag :recur 82 | [ast] 83 | (assoc ast :ignore-tag true)) 84 | 85 | (defmethod -infer-tag :do 86 | [{:keys [ret] :as ast}] 87 | (merge ast (select-keys ret [:return-tag :arglists :ignore-tag :tag]) 88 | {:o-tag (:tag ret)})) 89 | 90 | (defmethod -infer-tag :let 91 | [{:keys [body] :as ast}] 92 | (merge ast (select-keys body [:return-tag :arglists :ignore-tag :tag]) 93 | {:o-tag (:tag body)})) 94 | 95 | (defmethod -infer-tag :letfn 96 | [{:keys [body] :as ast}] 97 | (merge ast (select-keys body [:return-tag :arglists :ignore-tag :tag]) 98 | {:o-tag (:tag body)})) 99 | 100 | (defmethod -infer-tag :loop 101 | [{:keys [body] :as ast}] 102 | (merge ast (select-keys body [:return-tag :arglists]) 103 | {:o-tag (:tag body)} 104 | (let [tag (:tag body)] 105 | (if (#{Void Void/TYPE} tag) 106 | (assoc ast :tag Object) 107 | (assoc ast :tag tag))))) 108 | 109 | (defn =-arglists? [a1 a2] 110 | (let [tag (fn [x] (-> x meta :tag u/maybe-class))] 111 | (and (= a1 a2) 112 | (every? true? (mapv (fn [a1 a2] 113 | (and (= (tag a1) (tag a2)) 114 | (= (mapv tag a1) 115 | (mapv tag a2)))) 116 | a1 a2))))) 117 | 118 | (defmethod -infer-tag :if 119 | [{:keys [then else] :as ast}] 120 | (let [then-tag (:tag then) 121 | else-tag (:tag else) 122 | ignore-then? (:ignore-tag then) 123 | ignore-else? (:ignore-tag else)] 124 | (cond 125 | (and then-tag 126 | (or ignore-else? (= then-tag else-tag))) 127 | (merge ast 128 | {:tag then-tag :o-tag then-tag} 129 | (when-let [return-tag (:return-tag then)] 130 | (when (or ignore-else? 131 | (= return-tag (:return-tag else))) 132 | {:return-tag return-tag})) 133 | (when-let [arglists (:arglists then)] 134 | (when (or ignore-else? 135 | (=-arglists? arglists (:arglists else))) 136 | {:arglists arglists}))) 137 | 138 | (and else-tag ignore-then?) 139 | (merge ast 140 | {:tag else-tag :o-tag else-tag} 141 | (when-let [return-tag (:return-tag else)] 142 | {:return-tag return-tag}) 143 | (when-let [arglists (:arglists else)] 144 | {:arglists arglists})) 145 | 146 | (and (:ignore-tag then) (:ignore-tag else)) 147 | (assoc ast :ignore-tag true) 148 | 149 | :else 150 | ast))) 151 | 152 | (defmethod -infer-tag :throw 153 | [ast] 154 | (assoc ast :ignore-tag true)) 155 | 156 | (defmethod -infer-tag :case 157 | [{:keys [thens default] :as ast}] 158 | (let [thens (conj (mapv :then thens) default) 159 | exprs (seq (remove :ignore-tag thens)) 160 | tag (:tag (first exprs))] 161 | (cond 162 | (and tag 163 | (every? #(= (:tag %) tag) exprs)) 164 | (merge ast 165 | {:tag tag :o-tag tag} 166 | (when-let [return-tag (:return-tag (first exprs))] 167 | (when (every? #(= (:return-tag %) return-tag) exprs) 168 | {:return-tag return-tag})) 169 | (when-let [arglists (:arglists (first exprs))] 170 | (when (every? #(=-arglists? (:arglists %) arglists) exprs) 171 | {:arglists arglists}))) 172 | 173 | (every? :ignore-tag thens) 174 | (assoc ast :ignore-tag true) 175 | 176 | :else 177 | ast))) 178 | 179 | (defmethod -infer-tag :try 180 | [{:keys [body catches] :as ast}] 181 | (let [{:keys [tag return-tag arglists]} body 182 | catches (remove :ignore-tag (mapv :body catches))] 183 | (merge ast 184 | (when (and tag (every? #(= % tag) (mapv :tag catches))) 185 | {:tag tag :o-tag tag}) 186 | (when (and return-tag (every? #(= % return-tag) (mapv :return-tag catches))) 187 | {:return-tag return-tag}) 188 | (when (and arglists (every? #(=-arglists? % arglists) (mapv :arglists catches))) 189 | {:arglists arglists})))) 190 | 191 | (defmethod -infer-tag :fn-method 192 | [{:keys [form body params local] :as ast}] 193 | (let [annotated-tag (or (:tag (meta (first form))) 194 | (:tag (meta (:form local)))) 195 | body-tag (:tag body) 196 | tag (or annotated-tag body-tag) 197 | tag (if (#{Void Void/TYPE} tag) 198 | Object 199 | tag)] 200 | (merge (if (not= tag body-tag) 201 | (assoc-in ast [:body :tag] (u/maybe-class tag)) 202 | ast) 203 | (when tag 204 | {:tag tag 205 | :o-tag tag}) 206 | {:arglist (with-meta (vec (mapcat (fn [{:keys [form variadic?]}] 207 | (if variadic? ['& form] [form])) 208 | params)) 209 | (when tag {:tag tag}))}))) 210 | 211 | (defmethod -infer-tag :fn 212 | [{:keys [local methods] :as ast}] 213 | (merge ast 214 | {:arglists (seq (mapv :arglist methods)) 215 | :tag clojure.lang.AFunction 216 | :o-tag clojure.lang.AFunction} 217 | (when-let [tag (or (:tag (meta (:form local))) 218 | (and (apply = (mapv :tag methods)) 219 | (:tag (first methods))))] 220 | {:return-tag tag}))) 221 | 222 | (defmethod -infer-tag :invoke 223 | [{:keys [fn args] :as ast}] 224 | (if (:arglists fn) 225 | (let [argc (count args) 226 | arglist (arglist-for-arity fn argc) 227 | tag (or (:tag (meta arglist)) 228 | (:return-tag fn) 229 | (and (= :var (:op fn)) 230 | (:tag (:meta fn))))] 231 | (merge ast 232 | (when tag 233 | {:tag tag 234 | :o-tag tag}))) 235 | (if-let [tag (:return-tag fn)] 236 | (assoc ast :tag tag :o-tag tag) 237 | ast))) 238 | 239 | (defmethod -infer-tag :method 240 | [{:keys [form body params] :as ast}] 241 | (let [tag (or (:tag (meta (first form))) 242 | (:tag (meta (second form)))) 243 | body-tag (:tag body)] 244 | (assoc ast :tag (or tag body-tag) :o-tag body-tag))) 245 | 246 | (defmethod -infer-tag :reify 247 | [{:keys [class-name] :as ast}] 248 | (assoc ast :tag class-name :o-tag class-name)) 249 | 250 | (defmethod -infer-tag :set! 251 | [ast] 252 | (let [t (:tag (:target ast))] 253 | (assoc ast :tag t :o-tag t))) 254 | 255 | (defn infer-tag 256 | "Performs local type inference on the AST adds, when possible, 257 | one or more of the following keys to the AST: 258 | * :o-tag represents the current type of the 259 | expression represented by the node 260 | * :tag represents the type the expression represented by the 261 | node is required to have, possibly the same as :o-tag 262 | * :return-tag implies that the node will return a function whose 263 | invocation will result in a object of this type 264 | * :arglists implies that the node will return a function with 265 | this arglists 266 | * :ignore-tag true when the node is untyped, does not imply that 267 | all untyped node will have this 268 | 269 | Passes opts: 270 | * :infer-tag/level If :global, infer-tag will perform Var tag 271 | inference" 272 | {:pass-info {:walk :post :depends #{#'annotate-tag #'annotate-host-info #'fix-case-test #'analyze-host-expr} :after #{#'trim}}} 273 | [{:keys [tag form] :as ast}] 274 | (let [tag (or tag (:tag (meta form))) 275 | ast (-infer-tag ast)] 276 | (merge ast 277 | (when tag 278 | {:tag tag}) 279 | (when-let [o-tag (:o-tag ast)] 280 | {:o-tag o-tag})))) 281 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Eclipse Public License - v 1.0 2 | 3 | THE ACCOMPANYING PROGRAM IS PROVIDED UNDER THE TERMS OF THIS ECLIPSE PUBLIC 4 | LICENSE ("AGREEMENT"). ANY USE, REPRODUCTION OR DISTRIBUTION OF THE PROGRAM 5 | CONSTITUTES RECIPIENT'S ACCEPTANCE OF THIS AGREEMENT. 6 | 7 | 1. DEFINITIONS 8 | 9 | "Contribution" means: 10 | 11 | a) in the case of the initial Contributor, the initial code and documentation 12 | distributed under this Agreement, and 13 | b) in the case of each subsequent Contributor: 14 | i) changes to the Program, and 15 | ii) additions to the Program; 16 | 17 | where such changes and/or additions to the Program originate from and are 18 | distributed by that particular Contributor. A Contribution 'originates' 19 | from a Contributor if it was added to the Program by such Contributor 20 | itself or anyone acting on such Contributor's behalf. Contributions do not 21 | include additions to the Program which: (i) are separate modules of 22 | software distributed in conjunction with the Program under their own 23 | license agreement, and (ii) are not derivative works of the Program. 24 | 25 | "Contributor" means any person or entity that distributes the Program. 26 | 27 | "Licensed Patents" mean patent claims licensable by a Contributor which are 28 | necessarily infringed by the use or sale of its Contribution alone or when 29 | combined with the Program. 30 | 31 | "Program" means the Contributions distributed in accordance with this 32 | Agreement. 33 | 34 | "Recipient" means anyone who receives the Program under this Agreement, 35 | including all Contributors. 36 | 37 | 2. GRANT OF RIGHTS 38 | a) Subject to the terms of this Agreement, each Contributor hereby grants 39 | Recipient a non-exclusive, worldwide, royalty-free copyright license to 40 | reproduce, prepare derivative works of, publicly display, publicly 41 | perform, distribute and sublicense the Contribution of such Contributor, 42 | if any, and such derivative works, in source code and object code form. 43 | b) Subject to the terms of this Agreement, each Contributor hereby grants 44 | Recipient a non-exclusive, worldwide, royalty-free patent license under 45 | Licensed Patents to make, use, sell, offer to sell, import and otherwise 46 | transfer the Contribution of such Contributor, if any, in source code and 47 | object code form. This patent license shall apply to the combination of 48 | the Contribution and the Program if, at the time the Contribution is 49 | added by the Contributor, such addition of the Contribution causes such 50 | combination to be covered by the Licensed Patents. The patent license 51 | shall not apply to any other combinations which include the Contribution. 52 | No hardware per se is licensed hereunder. 53 | c) Recipient understands that although each Contributor grants the licenses 54 | to its Contributions set forth herein, no assurances are provided by any 55 | Contributor that the Program does not infringe the patent or other 56 | intellectual property rights of any other entity. Each Contributor 57 | disclaims any liability to Recipient for claims brought by any other 58 | entity based on infringement of intellectual property rights or 59 | otherwise. As a condition to exercising the rights and licenses granted 60 | hereunder, each Recipient hereby assumes sole responsibility to secure 61 | any other intellectual property rights needed, if any. For example, if a 62 | third party patent license is required to allow Recipient to distribute 63 | the Program, it is Recipient's responsibility to acquire that license 64 | before distributing the Program. 65 | d) Each Contributor represents that to its knowledge it has sufficient 66 | copyright rights in its Contribution, if any, to grant the copyright 67 | license set forth in this Agreement. 68 | 69 | 3. REQUIREMENTS 70 | 71 | A Contributor may choose to distribute the Program in object code form under 72 | its own license agreement, provided that: 73 | 74 | a) it complies with the terms and conditions of this Agreement; and 75 | b) its license agreement: 76 | i) effectively disclaims on behalf of all Contributors all warranties 77 | and conditions, express and implied, including warranties or 78 | conditions of title and non-infringement, and implied warranties or 79 | conditions of merchantability and fitness for a particular purpose; 80 | ii) effectively excludes on behalf of all Contributors all liability for 81 | damages, including direct, indirect, special, incidental and 82 | consequential damages, such as lost profits; 83 | iii) states that any provisions which differ from this Agreement are 84 | offered by that Contributor alone and not by any other party; and 85 | iv) states that source code for the Program is available from such 86 | Contributor, and informs licensees how to obtain it in a reasonable 87 | manner on or through a medium customarily used for software exchange. 88 | 89 | When the Program is made available in source code form: 90 | 91 | a) it must be made available under this Agreement; and 92 | b) a copy of this Agreement must be included with each copy of the Program. 93 | Contributors may not remove or alter any copyright notices contained 94 | within the Program. 95 | 96 | Each Contributor must identify itself as the originator of its Contribution, 97 | if 98 | any, in a manner that reasonably allows subsequent Recipients to identify the 99 | originator of the Contribution. 100 | 101 | 4. COMMERCIAL DISTRIBUTION 102 | 103 | Commercial distributors of software may accept certain responsibilities with 104 | respect to end users, business partners and the like. While this license is 105 | intended to facilitate the commercial use of the Program, the Contributor who 106 | includes the Program in a commercial product offering should do so in a manner 107 | which does not create potential liability for other Contributors. Therefore, 108 | if a Contributor includes the Program in a commercial product offering, such 109 | Contributor ("Commercial Contributor") hereby agrees to defend and indemnify 110 | every other Contributor ("Indemnified Contributor") against any losses, 111 | damages and costs (collectively "Losses") arising from claims, lawsuits and 112 | other legal actions brought by a third party against the Indemnified 113 | Contributor to the extent caused by the acts or omissions of such Commercial 114 | Contributor in connection with its distribution of the Program in a commercial 115 | product offering. The obligations in this section do not apply to any claims 116 | or Losses relating to any actual or alleged intellectual property 117 | infringement. In order to qualify, an Indemnified Contributor must: 118 | a) promptly notify the Commercial Contributor in writing of such claim, and 119 | b) allow the Commercial Contributor to control, and cooperate with the 120 | Commercial Contributor in, the defense and any related settlement 121 | negotiations. The Indemnified Contributor may participate in any such claim at 122 | its own expense. 123 | 124 | For example, a Contributor might include the Program in a commercial product 125 | offering, Product X. That Contributor is then a Commercial Contributor. If 126 | that Commercial Contributor then makes performance claims, or offers 127 | warranties related to Product X, those performance claims and warranties are 128 | such Commercial Contributor's responsibility alone. Under this section, the 129 | Commercial Contributor would have to defend claims against the other 130 | Contributors related to those performance claims and warranties, and if a 131 | court requires any other Contributor to pay any damages as a result, the 132 | Commercial Contributor must pay those damages. 133 | 134 | 5. NO WARRANTY 135 | 136 | EXCEPT AS EXPRESSLY SET FORTH IN THIS AGREEMENT, THE PROGRAM IS PROVIDED ON AN 137 | "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, EITHER EXPRESS OR 138 | IMPLIED INCLUDING, WITHOUT LIMITATION, ANY WARRANTIES OR CONDITIONS OF TITLE, 139 | NON-INFRINGEMENT, MERCHANTABILITY OR FITNESS FOR A PARTICULAR PURPOSE. Each 140 | Recipient is solely responsible for determining the appropriateness of using 141 | and distributing the Program and assumes all risks associated with its 142 | exercise of rights under this Agreement , including but not limited to the 143 | risks and costs of program errors, compliance with applicable laws, damage to 144 | or loss of data, programs or equipment, and unavailability or interruption of 145 | operations. 146 | 147 | 6. DISCLAIMER OF LIABILITY 148 | 149 | EXCEPT AS EXPRESSLY SET FORTH IN THIS AGREEMENT, NEITHER RECIPIENT NOR ANY 150 | CONTRIBUTORS SHALL HAVE ANY LIABILITY FOR ANY DIRECT, INDIRECT, INCIDENTAL, 151 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING WITHOUT LIMITATION 152 | LOST PROFITS), HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN 153 | CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) 154 | ARISING IN ANY WAY OUT OF THE USE OR DISTRIBUTION OF THE PROGRAM OR THE 155 | EXERCISE OF ANY RIGHTS GRANTED HEREUNDER, EVEN IF ADVISED OF THE POSSIBILITY 156 | OF SUCH DAMAGES. 157 | 158 | 7. GENERAL 159 | 160 | If any provision of this Agreement is invalid or unenforceable under 161 | applicable law, it shall not affect the validity or enforceability of the 162 | remainder of the terms of this Agreement, and without further action by the 163 | parties hereto, such provision shall be reformed to the minimum extent 164 | necessary to make such provision valid and enforceable. 165 | 166 | If Recipient institutes patent litigation against any entity (including a 167 | cross-claim or counterclaim in a lawsuit) alleging that the Program itself 168 | (excluding combinations of the Program with other software or hardware) 169 | infringes such Recipient's patent(s), then such Recipient's rights granted 170 | under Section 2(b) shall terminate as of the date such litigation is filed. 171 | 172 | All Recipient's rights under this Agreement shall terminate if it fails to 173 | comply with any of the material terms or conditions of this Agreement and does 174 | not cure such failure in a reasonable period of time after becoming aware of 175 | such noncompliance. If all Recipient's rights under this Agreement terminate, 176 | Recipient agrees to cease use and distribution of the Program as soon as 177 | reasonably practicable. However, Recipient's obligations under this Agreement 178 | and any licenses granted by Recipient relating to the Program shall continue 179 | and survive. 180 | 181 | Everyone is permitted to copy and distribute copies of this Agreement, but in 182 | order to avoid inconsistency the Agreement is copyrighted and may only be 183 | modified in the following manner. The Agreement Steward reserves the right to 184 | publish new versions (including revisions) of this Agreement from time to 185 | time. No one other than the Agreement Steward has the right to modify this 186 | Agreement. The Eclipse Foundation is the initial Agreement Steward. The 187 | Eclipse Foundation may assign the responsibility to serve as the Agreement 188 | Steward to a suitable separate entity. Each new version of the Agreement will 189 | be given a distinguishing version number. The Program (including 190 | Contributions) may always be distributed subject to the version of the 191 | Agreement under which it was received. In addition, after a new version of the 192 | Agreement is published, Contributor may elect to distribute the Program 193 | (including its Contributions) under the new version. Except as expressly 194 | stated in Sections 2(a) and 2(b) above, Recipient receives no rights or 195 | licenses to the intellectual property of any Contributor under this Agreement, 196 | whether expressly, by implication, estoppel or otherwise. All rights in the 197 | Program not expressly granted under this Agreement are reserved. 198 | 199 | This Agreement is governed by the laws of the State of New York and the 200 | intellectual property laws of the United States of America. No party to this 201 | Agreement will bring a legal action under this Agreement more than one year 202 | after the cause of action arose. Each party waives its rights to a jury trial in 203 | any resulting litigation. 204 | 205 | 206 | -------------------------------------------------------------------------------- /src/main/clojure/clojure/tools/analyzer/passes/jvm/validate.clj: -------------------------------------------------------------------------------- 1 | ;; Copyright (c) Nicola Mometto, Rich Hickey & contributors. 2 | ;; The use and distribution terms for this software are covered by the 3 | ;; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) 4 | ;; which can be found in the file epl-v10.html at the root of this distribution. 5 | ;; By using this software in any fashion, you are agreeing to be bound by 6 | ;; the terms of this license. 7 | ;; You must not remove this notice, or any other, from this software. 8 | 9 | (ns clojure.tools.analyzer.passes.jvm.validate 10 | (:require [clojure.tools.analyzer.ast :refer [prewalk]] 11 | [clojure.tools.analyzer.env :as env] 12 | [clojure.tools.analyzer.passes.cleanup :refer [cleanup]] 13 | [clojure.tools.analyzer.passes.jvm 14 | [validate-recur :refer [validate-recur]] 15 | [infer-tag :refer [infer-tag]] 16 | [analyze-host-expr :refer [analyze-host-expr]]] 17 | [clojure.tools.analyzer.utils :refer [arglist-for-arity source-info resolve-sym resolve-ns merge']] 18 | [clojure.tools.analyzer.jvm.utils :as u :refer [tag-match? try-best-match]]) 19 | (:import (clojure.lang IFn ExceptionInfo))) 20 | 21 | (defmulti -validate :op) 22 | 23 | (defmethod -validate :maybe-class 24 | [{:keys [class env] :as ast}] 25 | (if-let [handle (-> (env/deref-env) :passes-opts :validate/unresolvable-symbol-handler)] 26 | (handle nil class ast) 27 | (if (not (.contains (str class) ".")) 28 | (throw (ex-info (str "Could not resolve var: " class) 29 | (merge {:var class} 30 | (source-info env)))) 31 | 32 | (throw (ex-info (str "Class not found: " class) 33 | (merge {:class class} 34 | (source-info env))))))) 35 | 36 | (defmethod -validate :maybe-host-form 37 | [{:keys [class field form env] :as ast}] 38 | (if-let [handle (-> (env/deref-env) :passes-opts :validate/unresolvable-symbol-handler)] 39 | (handle class field ast) 40 | (if (resolve-ns class env) 41 | (throw (ex-info (str "No such var: " class) 42 | (merge {:form form} 43 | (source-info env)))) 44 | (throw (ex-info (str "No such namespace: " class) 45 | (merge {:ns class 46 | :form form} 47 | (source-info env))))))) 48 | 49 | (defmethod -validate :set! 50 | [{:keys [target form env] :as ast}] 51 | (when (not (:assignable? target)) 52 | (throw (ex-info "Cannot set! non-assignable target" 53 | (merge {:target (prewalk target cleanup) 54 | :form form} 55 | (source-info env))))) 56 | ast) 57 | 58 | (defmethod -validate :new 59 | [{:keys [args] :as ast}] 60 | (if (:validated? ast) 61 | ast 62 | (if-not (= :class (-> ast :class :type)) 63 | (throw (ex-info (str "Unable to resolve classname: " (:form (:class ast))) 64 | (merge {:class (:form (:class ast)) 65 | :ast ast} 66 | (source-info (:env ast))))) 67 | (let [^Class class (-> ast :class :val) 68 | c-name (symbol (.getName class)) 69 | argc (count args) 70 | tags (mapv :tag args)] 71 | (let [[ctor & rest] (->> (filter #(= (count (:parameter-types %)) argc) 72 | (u/members class c-name)) 73 | (try-best-match tags))] 74 | (if ctor 75 | (if (empty? rest) 76 | (let [arg-tags (mapv u/maybe-class (:parameter-types ctor)) 77 | args (mapv (fn [arg tag] (assoc arg :tag tag)) args arg-tags)] 78 | (assoc ast 79 | :args args 80 | :validated? true)) 81 | ast) 82 | (throw (ex-info (str "no ctor found for ctor of class: " class " and given signature") 83 | (merge {:class class 84 | :args (mapv (fn [a] (prewalk a cleanup)) args)} 85 | (source-info (:env ast))))))))))) 86 | 87 | (defn validate-call [{:keys [class instance method args tag env op] :as ast}] 88 | (let [argc (count args) 89 | instance? (= :instance-call op) 90 | f (if instance? u/instance-methods u/static-methods) 91 | tags (mapv :tag args)] 92 | (if-let [matching-methods (seq (f class method argc))] 93 | (let [[m & rest :as matching] (try-best-match tags matching-methods)] 94 | (if m 95 | (let [all-ret-equals? (apply = (mapv :return-type matching))] 96 | (if (or (empty? rest) 97 | (and all-ret-equals? ;; if the method signature is the same just pick the first one 98 | (apply = (mapv #(mapv u/maybe-class (:parameter-types %)) matching)))) 99 | (let [ret-tag (:return-type m) 100 | arg-tags (mapv u/maybe-class (:parameter-types m)) 101 | args (mapv (fn [arg tag] (assoc arg :tag tag)) args arg-tags) 102 | class (u/maybe-class (:declaring-class m))] 103 | (merge' ast 104 | {:method (:name m) 105 | :validated? true 106 | :class class 107 | :o-tag ret-tag 108 | :tag (or tag ret-tag) 109 | :args args} 110 | (if instance? 111 | {:instance (assoc instance :tag class)}))) 112 | (if all-ret-equals? 113 | (let [ret-tag (:return-type m)] 114 | (assoc ast 115 | :o-tag Object 116 | :tag (or tag ret-tag))) 117 | ast))) 118 | (if instance? 119 | (assoc (dissoc ast :class) :tag Object :o-tag Object) 120 | (throw (ex-info (str "No matching method: " method " for class: " class " and given signature") 121 | (merge {:method method 122 | :class class 123 | :args (mapv (fn [a] (prewalk a cleanup)) args)} 124 | (source-info env))))))) 125 | (if instance? 126 | (assoc (dissoc ast :class) :tag Object :o-tag Object) 127 | (throw (ex-info (str "No matching method: " method " for class: " class " and arity: " argc) 128 | (merge {:method method 129 | :class class 130 | :argc argc} 131 | (source-info env)))))))) 132 | 133 | (defmethod -validate :static-call 134 | [ast] 135 | (if (:validated? ast) 136 | ast 137 | (validate-call (assoc ast :class (u/maybe-class (:class ast)))))) 138 | 139 | (defmethod -validate :static-field 140 | [ast] 141 | (if (:validated? ast) 142 | ast 143 | (assoc ast :class (u/maybe-class (:class ast))))) 144 | 145 | (defmethod -validate :instance-call 146 | [{:keys [class validated? instance] :as ast}] 147 | (let [class (or class (:tag instance))] 148 | (if (and class (not validated?)) 149 | (validate-call (assoc ast :class (u/maybe-class class))) 150 | ast))) 151 | 152 | (defmethod -validate :instance-field 153 | [{:keys [instance class] :as ast}] 154 | (let [class (u/maybe-class class)] 155 | (assoc ast :class class :instance (assoc instance :tag class)))) 156 | 157 | (defmethod -validate :import 158 | [{:keys [^String class validated? env form] :as ast}] 159 | (if-not validated? 160 | (let [class-sym (-> class (subs (inc (.lastIndexOf class "."))) symbol) 161 | sym-val (resolve-sym class-sym env)] 162 | (if (and (class? sym-val) (not= (.getName ^Class sym-val) class)) ;; allow deftype redef 163 | (throw (ex-info (str class-sym " already refers to: " sym-val 164 | " in namespace: " (:ns env)) 165 | (merge {:class class 166 | :class-sym class-sym 167 | :sym-val sym-val 168 | :form form} 169 | (source-info env)))) 170 | (assoc ast :validated? true))) 171 | ast)) 172 | 173 | (defmethod -validate :def 174 | [ast] 175 | (when-not (var? (:var ast)) 176 | (throw (ex-info (str "Cannot def " (:name ast) " as it refers to the class " 177 | (.getName ^Class (:var ast))) 178 | (merge {:ast (prewalk ast cleanup)} 179 | (source-info (:env ast)))))) 180 | (merge 181 | ast 182 | (when-let [tag (-> ast :name meta :tag)] 183 | (when (and (symbol? tag) (or (u/specials (str tag)) (u/special-arrays (str tag)))) 184 | ;; we cannot validate all tags since :tag might contain a function call that returns 185 | ;; a valid tag at runtime, however if tag is one of u/specials or u/special-arrays 186 | ;; we know that it's a wrong tag as it's going to be evaluated as a clojure.core function 187 | (if-let [handle (-> (env/deref-env) :passes-opts :validate/wrong-tag-handler)] 188 | (handle :name/tag ast) 189 | (throw (ex-info (str "Wrong tag: " (eval tag) " in def: " (:name ast)) 190 | (merge {:ast (prewalk ast cleanup)} 191 | (source-info (:env ast)))))))))) 192 | 193 | (defmethod -validate :invoke 194 | [{:keys [args env fn form] :as ast}] 195 | (let [argc (count args)] 196 | (when (and (= :const (:op fn)) 197 | (not (instance? IFn (:form fn)))) 198 | (throw (ex-info (str (class (:form fn)) " is not a function, but it's used as such") 199 | (merge {:form form} 200 | (source-info env))))) 201 | (if (and (:arglists fn) 202 | (not (arglist-for-arity fn argc))) 203 | (if (-> (env/deref-env) :passes-opts :validate/throw-on-arity-mismatch) 204 | (throw (ex-info (str "No matching arity found for function: " (:name fn)) 205 | {:arity (count args) 206 | :fn fn})) 207 | (assoc ast :maybe-arity-mismatch true)) 208 | ast))) 209 | 210 | (defn validate-interfaces [{:keys [env form interfaces]}] 211 | (when-not (every? #(.isInterface ^Class %) (disj interfaces Object)) 212 | (throw (ex-info "only interfaces or Object can be implemented by deftype/reify" 213 | (merge {:interfaces interfaces 214 | :form form} 215 | (source-info env)))))) 216 | 217 | (defmethod -validate :deftype 218 | [{:keys [class-name] :as ast}] 219 | (validate-interfaces ast) 220 | (assoc ast :class-name (u/maybe-class class-name))) 221 | 222 | (defmethod -validate :reify 223 | [{:keys [class-name] :as ast}] 224 | (validate-interfaces ast) 225 | (assoc ast :class-name (u/maybe-class class-name))) 226 | 227 | (defmethod -validate :default [ast] ast) 228 | 229 | (defn validate-tag [t {:keys [env] :as ast}] 230 | (let [tag (ast t)] 231 | (if-let [the-class (u/maybe-class tag)] 232 | {t the-class} 233 | (if-let [handle (-> (env/deref-env) :passes-opts :validate/wrong-tag-handler)] 234 | (handle t ast) 235 | (throw (ex-info (str "Class not found: " tag) 236 | (merge {:class tag 237 | :ast (prewalk ast cleanup)} 238 | (source-info env)))))))) 239 | 240 | (defn validate 241 | "Validate tags, classes, method calls. 242 | Throws exceptions when invalid forms are encountered, replaces 243 | class symbols with class objects. 244 | 245 | Passes opts: 246 | * :validate/throw-on-arity-mismatch 247 | If true, validate will throw on potential arity mismatch 248 | * :validate/wrong-tag-handler 249 | If bound to a function, will invoke that function instead of 250 | throwing on invalid tag. 251 | The function takes the tag key (or :name/tag if the node is :def and 252 | the wrong tag is the one on the :name field meta) and the originating 253 | AST node and must return a map (or nil) that will be merged into the AST, 254 | possibly shadowing the wrong tag with Object or nil. 255 | * :validate/unresolvable-symbol-handler 256 | If bound to a function, will invoke that function instead of 257 | throwing on unresolvable symbol. 258 | The function takes three arguments: the namespace (possibly nil) 259 | and name part of the symbol, as symbols and the originating 260 | AST node which can be either a :maybe-class or a :maybe-host-form, 261 | those nodes are documented in the tools.analyzer quickref. 262 | The function must return a valid tools.analyzer.jvm AST node." 263 | {:pass-info {:walk :post :depends #{#'infer-tag #'analyze-host-expr #'validate-recur}}} 264 | [{:keys [tag form env] :as ast}] 265 | (let [ast (merge (-validate ast) 266 | (when tag 267 | {:tag tag}))] 268 | (merge ast 269 | (when (:tag ast) 270 | (validate-tag :tag ast)) 271 | (when (:o-tag ast) 272 | (validate-tag :o-tag ast)) 273 | (when (:return-tag ast) 274 | (validate-tag :return-tag ast))))) 275 | -------------------------------------------------------------------------------- /epl.html: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | 6 | 7 | Eclipse Public License - Version 1.0 8 | 25 | 26 | 27 | 28 | 29 | 30 |

    Eclipse Public License - v 1.0

    31 | 32 |

    THE ACCOMPANYING PROGRAM IS PROVIDED UNDER THE TERMS OF THIS ECLIPSE 33 | PUBLIC LICENSE ("AGREEMENT"). ANY USE, REPRODUCTION OR 34 | DISTRIBUTION OF THE PROGRAM CONSTITUTES RECIPIENT'S ACCEPTANCE OF THIS 35 | AGREEMENT.

    36 | 37 |

    1. DEFINITIONS

    38 | 39 |

    "Contribution" means:

    40 | 41 |

    a) in the case of the initial Contributor, the initial 42 | code and documentation distributed under this Agreement, and

    43 |

    b) in the case of each subsequent Contributor:

    44 |

    i) changes to the Program, and

    45 |

    ii) additions to the Program;

    46 |

    where such changes and/or additions to the Program 47 | originate from and are distributed by that particular Contributor. A 48 | Contribution 'originates' from a Contributor if it was added to the 49 | Program by such Contributor itself or anyone acting on such 50 | Contributor's behalf. Contributions do not include additions to the 51 | Program which: (i) are separate modules of software distributed in 52 | conjunction with the Program under their own license agreement, and (ii) 53 | are not derivative works of the Program.

    54 | 55 |

    "Contributor" means any person or entity that distributes 56 | the Program.

    57 | 58 |

    "Licensed Patents" mean patent claims licensable by a 59 | Contributor which are necessarily infringed by the use or sale of its 60 | Contribution alone or when combined with the Program.

    61 | 62 |

    "Program" means the Contributions distributed in accordance 63 | with this Agreement.

    64 | 65 |

    "Recipient" means anyone who receives the Program under 66 | this Agreement, including all Contributors.

    67 | 68 |

    2. GRANT OF RIGHTS

    69 | 70 |

    a) Subject to the terms of this Agreement, each 71 | Contributor hereby grants Recipient a non-exclusive, worldwide, 72 | royalty-free copyright license to reproduce, prepare derivative works 73 | of, publicly display, publicly perform, distribute and sublicense the 74 | Contribution of such Contributor, if any, and such derivative works, in 75 | source code and object code form.

    76 | 77 |

    b) Subject to the terms of this Agreement, each 78 | Contributor hereby grants Recipient a non-exclusive, worldwide, 79 | royalty-free patent license under Licensed Patents to make, use, sell, 80 | offer to sell, import and otherwise transfer the Contribution of such 81 | Contributor, if any, in source code and object code form. This patent 82 | license shall apply to the combination of the Contribution and the 83 | Program if, at the time the Contribution is added by the Contributor, 84 | such addition of the Contribution causes such combination to be covered 85 | by the Licensed Patents. The patent license shall not apply to any other 86 | combinations which include the Contribution. No hardware per se is 87 | licensed hereunder.

    88 | 89 |

    c) Recipient understands that although each Contributor 90 | grants the licenses to its Contributions set forth herein, no assurances 91 | are provided by any Contributor that the Program does not infringe the 92 | patent or other intellectual property rights of any other entity. Each 93 | Contributor disclaims any liability to Recipient for claims brought by 94 | any other entity based on infringement of intellectual property rights 95 | or otherwise. As a condition to exercising the rights and licenses 96 | granted hereunder, each Recipient hereby assumes sole responsibility to 97 | secure any other intellectual property rights needed, if any. For 98 | example, if a third party patent license is required to allow Recipient 99 | to distribute the Program, it is Recipient's responsibility to acquire 100 | that license before distributing the Program.

    101 | 102 |

    d) Each Contributor represents that to its knowledge it 103 | has sufficient copyright rights in its Contribution, if any, to grant 104 | the copyright license set forth in this Agreement.

    105 | 106 |

    3. REQUIREMENTS

    107 | 108 |

    A Contributor may choose to distribute the Program in object code 109 | form under its own license agreement, provided that:

    110 | 111 |

    a) it complies with the terms and conditions of this 112 | Agreement; and

    113 | 114 |

    b) its license agreement:

    115 | 116 |

    i) effectively disclaims on behalf of all Contributors 117 | all warranties and conditions, express and implied, including warranties 118 | or conditions of title and non-infringement, and implied warranties or 119 | conditions of merchantability and fitness for a particular purpose;

    120 | 121 |

    ii) effectively excludes on behalf of all Contributors 122 | all liability for damages, including direct, indirect, special, 123 | incidental and consequential damages, such as lost profits;

    124 | 125 |

    iii) states that any provisions which differ from this 126 | Agreement are offered by that Contributor alone and not by any other 127 | party; and

    128 | 129 |

    iv) states that source code for the Program is available 130 | from such Contributor, and informs licensees how to obtain it in a 131 | reasonable manner on or through a medium customarily used for software 132 | exchange.

    133 | 134 |

    When the Program is made available in source code form:

    135 | 136 |

    a) it must be made available under this Agreement; and

    137 | 138 |

    b) a copy of this Agreement must be included with each 139 | copy of the Program.

    140 | 141 |

    Contributors may not remove or alter any copyright notices contained 142 | within the Program.

    143 | 144 |

    Each Contributor must identify itself as the originator of its 145 | Contribution, if any, in a manner that reasonably allows subsequent 146 | Recipients to identify the originator of the Contribution.

    147 | 148 |

    4. COMMERCIAL DISTRIBUTION

    149 | 150 |

    Commercial distributors of software may accept certain 151 | responsibilities with respect to end users, business partners and the 152 | like. While this license is intended to facilitate the commercial use of 153 | the Program, the Contributor who includes the Program in a commercial 154 | product offering should do so in a manner which does not create 155 | potential liability for other Contributors. Therefore, if a Contributor 156 | includes the Program in a commercial product offering, such Contributor 157 | ("Commercial Contributor") hereby agrees to defend and 158 | indemnify every other Contributor ("Indemnified Contributor") 159 | against any losses, damages and costs (collectively "Losses") 160 | arising from claims, lawsuits and other legal actions brought by a third 161 | party against the Indemnified Contributor to the extent caused by the 162 | acts or omissions of such Commercial Contributor in connection with its 163 | distribution of the Program in a commercial product offering. The 164 | obligations in this section do not apply to any claims or Losses 165 | relating to any actual or alleged intellectual property infringement. In 166 | order to qualify, an Indemnified Contributor must: a) promptly notify 167 | the Commercial Contributor in writing of such claim, and b) allow the 168 | Commercial Contributor to control, and cooperate with the Commercial 169 | Contributor in, the defense and any related settlement negotiations. The 170 | Indemnified Contributor may participate in any such claim at its own 171 | expense.

    172 | 173 |

    For example, a Contributor might include the Program in a commercial 174 | product offering, Product X. That Contributor is then a Commercial 175 | Contributor. If that Commercial Contributor then makes performance 176 | claims, or offers warranties related to Product X, those performance 177 | claims and warranties are such Commercial Contributor's responsibility 178 | alone. Under this section, the Commercial Contributor would have to 179 | defend claims against the other Contributors related to those 180 | performance claims and warranties, and if a court requires any other 181 | Contributor to pay any damages as a result, the Commercial Contributor 182 | must pay those damages.

    183 | 184 |

    5. NO WARRANTY

    185 | 186 |

    EXCEPT AS EXPRESSLY SET FORTH IN THIS AGREEMENT, THE PROGRAM IS 187 | PROVIDED ON AN "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS 188 | OF ANY KIND, EITHER EXPRESS OR IMPLIED INCLUDING, WITHOUT LIMITATION, 189 | ANY WARRANTIES OR CONDITIONS OF TITLE, NON-INFRINGEMENT, MERCHANTABILITY 190 | OR FITNESS FOR A PARTICULAR PURPOSE. Each Recipient is solely 191 | responsible for determining the appropriateness of using and 192 | distributing the Program and assumes all risks associated with its 193 | exercise of rights under this Agreement , including but not limited to 194 | the risks and costs of program errors, compliance with applicable laws, 195 | damage to or loss of data, programs or equipment, and unavailability or 196 | interruption of operations.

    197 | 198 |

    6. DISCLAIMER OF LIABILITY

    199 | 200 |

    EXCEPT AS EXPRESSLY SET FORTH IN THIS AGREEMENT, NEITHER RECIPIENT 201 | NOR ANY CONTRIBUTORS SHALL HAVE ANY LIABILITY FOR ANY DIRECT, INDIRECT, 202 | INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING 203 | WITHOUT LIMITATION LOST PROFITS), HOWEVER CAUSED AND ON ANY THEORY OF 204 | LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING 205 | NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OR 206 | DISTRIBUTION OF THE PROGRAM OR THE EXERCISE OF ANY RIGHTS GRANTED 207 | HEREUNDER, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGES.

    208 | 209 |

    7. GENERAL

    210 | 211 |

    If any provision of this Agreement is invalid or unenforceable under 212 | applicable law, it shall not affect the validity or enforceability of 213 | the remainder of the terms of this Agreement, and without further action 214 | by the parties hereto, such provision shall be reformed to the minimum 215 | extent necessary to make such provision valid and enforceable.

    216 | 217 |

    If Recipient institutes patent litigation against any entity 218 | (including a cross-claim or counterclaim in a lawsuit) alleging that the 219 | Program itself (excluding combinations of the Program with other 220 | software or hardware) infringes such Recipient's patent(s), then such 221 | Recipient's rights granted under Section 2(b) shall terminate as of the 222 | date such litigation is filed.

    223 | 224 |

    All Recipient's rights under this Agreement shall terminate if it 225 | fails to comply with any of the material terms or conditions of this 226 | Agreement and does not cure such failure in a reasonable period of time 227 | after becoming aware of such noncompliance. If all Recipient's rights 228 | under this Agreement terminate, Recipient agrees to cease use and 229 | distribution of the Program as soon as reasonably practicable. However, 230 | Recipient's obligations under this Agreement and any licenses granted by 231 | Recipient relating to the Program shall continue and survive.

    232 | 233 |

    Everyone is permitted to copy and distribute copies of this 234 | Agreement, but in order to avoid inconsistency the Agreement is 235 | copyrighted and may only be modified in the following manner. The 236 | Agreement Steward reserves the right to publish new versions (including 237 | revisions) of this Agreement from time to time. No one other than the 238 | Agreement Steward has the right to modify this Agreement. The Eclipse 239 | Foundation is the initial Agreement Steward. The Eclipse Foundation may 240 | assign the responsibility to serve as the Agreement Steward to a 241 | suitable separate entity. Each new version of the Agreement will be 242 | given a distinguishing version number. The Program (including 243 | Contributions) may always be distributed subject to the version of the 244 | Agreement under which it was received. In addition, after a new version 245 | of the Agreement is published, Contributor may elect to distribute the 246 | Program (including its Contributions) under the new version. Except as 247 | expressly stated in Sections 2(a) and 2(b) above, Recipient receives no 248 | rights or licenses to the intellectual property of any Contributor under 249 | this Agreement, whether expressly, by implication, estoppel or 250 | otherwise. All rights in the Program not expressly granted under this 251 | Agreement are reserved.

    252 | 253 |

    This Agreement is governed by the laws of the State of New York and 254 | the intellectual property laws of the United States of America. No party 255 | to this Agreement will bring a legal action under this Agreement more 256 | than one year after the cause of action arose. Each party waives its 257 | rights to a jury trial in any resulting litigation.

    258 | 259 | 260 | 261 | 262 | -------------------------------------------------------------------------------- /src/main/clojure/clojure/tools/analyzer/jvm/utils.clj: -------------------------------------------------------------------------------- 1 | ;; Copyright (c) Nicola Mometto, Rich Hickey & contributors. 2 | ;; The use and distribution terms for this software are covered by the 3 | ;; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) 4 | ;; which can be found in the file epl-v10.html at the root of this distribution. 5 | ;; By using this software in any fashion, you are agreeing to be bound by 6 | ;; the terms of this license. 7 | ;; You must not remove this notice, or any other, from this software. 8 | 9 | (ns clojure.tools.analyzer.jvm.utils 10 | (:require [clojure.tools.analyzer.utils :as u] 11 | [clojure.tools.analyzer.env :as env] 12 | [clojure.reflect :as reflect] 13 | [clojure.string :as s] 14 | [clojure.core.memoize :refer [lru]] 15 | [clojure.java.io :as io]) 16 | (:import (clojure.lang RT Symbol Var) 17 | org.objectweb.asm.Type)) 18 | 19 | (set! *warn-on-reflection* true) 20 | 21 | (defn ^:private type-reflect 22 | [typeref & options] 23 | (apply reflect/type-reflect typeref 24 | :reflector (reflect/->JavaReflector (RT/baseLoader)) 25 | options)) 26 | 27 | (defn macro? [sym env] 28 | (when-let [v (u/resolve-sym sym env)] 29 | (and (not (-> env :locals (get sym))) 30 | (u/macro? v) 31 | v))) 32 | 33 | (defn inline? [sym args env] 34 | (when-let [v (u/resolve-sym sym env)] 35 | (let [inline-arities-f (:inline-arities (meta v))] 36 | (and (not (-> env :locals (get sym))) 37 | (or (not inline-arities-f) 38 | (inline-arities-f (count args))) 39 | (:inline (meta v)))))) 40 | 41 | (defn specials [c] 42 | (case c 43 | "byte" Byte/TYPE 44 | "boolean" Boolean/TYPE 45 | "char" Character/TYPE 46 | "int" Integer/TYPE 47 | "long" Long/TYPE 48 | "float" Float/TYPE 49 | "double" Double/TYPE 50 | "short" Short/TYPE 51 | "void" Void/TYPE 52 | "object" Object 53 | nil)) 54 | 55 | (defn special-arrays [c] 56 | (case c 57 | "bytes" (Class/forName "[B") 58 | "booleans" (Class/forName "[Z") 59 | "chars" (Class/forName "[C") 60 | "ints" (Class/forName "[I") 61 | "longs" (Class/forName "[J") 62 | "floats" (Class/forName "[F") 63 | "doubles" (Class/forName "[D") 64 | "shorts" (Class/forName "[S") 65 | "objects" (Class/forName "[Ljava.lang.Object;") 66 | nil)) 67 | 68 | (defmulti ^Class maybe-class 69 | "Takes a Symbol, String or Class and tires to resolve to a matching Class" 70 | class) 71 | 72 | (defn array-class 73 | ([element-type] (array-class 1 element-type)) 74 | ([n element-type] 75 | (RT/classForName 76 | (str (apply str (repeat n"[")) 77 | (-> element-type 78 | maybe-class 79 | Type/getType 80 | .getDescriptor 81 | (.replace \/ \.)))))) 82 | 83 | (defn maybe-class-from-string [^String s] 84 | (or (when-let [maybe-class (and (neg? (.indexOf s ".")) 85 | (not= \[ (first s)) 86 | (if env/*env* 87 | (u/resolve-sym (symbol s) {:ns (ns-name *ns*)}) 88 | ((ns-map *ns*) (symbol s))))] 89 | (when (class? maybe-class) maybe-class)) 90 | (try (RT/classForName s) 91 | (catch ClassNotFoundException _)))) 92 | 93 | (defmethod maybe-class :default [_] nil) 94 | (defmethod maybe-class Class [c] c) 95 | (defmethod maybe-class String [s] 96 | (maybe-class (symbol s))) 97 | 98 | (defn maybe-array-class-sym [x] 99 | (let [sname (name x)] 100 | (if-let [c (and (= (count sname) 1) 101 | (Character/isDigit (char (first sname))) 102 | (namespace x))] 103 | (when-let [c (or (specials c) 104 | (maybe-class-from-string c))] 105 | (array-class (Integer/parseInt sname) c))))) 106 | 107 | (defmethod maybe-class Symbol [sym] 108 | (let [sname (name sym) 109 | snamec (count sname)] 110 | (or (maybe-array-class-sym sym) 111 | (when-not (namespace sym) 112 | (if-let [base-type (and (.endsWith sname "<>") 113 | (maybe-class (subs sname 0 (- snamec 2))))] 114 | ;; TODO: we're leaking into the syntax 115 | (array-class base-type) 116 | (if-let [ret (or (specials sname) 117 | (special-arrays sname))] 118 | ret 119 | (maybe-class-from-string sname))))))) 120 | 121 | (defn maybe-class-literal [x] 122 | (cond 123 | (class? x) x 124 | (symbol? x) (or (maybe-array-class-sym x) 125 | (and (not (namespace x)) 126 | (maybe-class-from-string (name x)))) 127 | (string? x) (maybe-class-from-string x))) 128 | 129 | (def primitive? 130 | "Returns non-nil if the argument represents a primitive Class other than Void" 131 | #{Double/TYPE Character/TYPE Byte/TYPE Boolean/TYPE 132 | Short/TYPE Float/TYPE Long/TYPE Integer/TYPE}) 133 | 134 | (def ^:private convertible-primitives 135 | "If the argument is a primitive Class, returns a set of Classes 136 | to which the primitive Class can be casted" 137 | {Integer/TYPE #{Integer Long/TYPE Long Short/TYPE Byte/TYPE Object Number} 138 | Float/TYPE #{Float Double/TYPE Object Number} 139 | Double/TYPE #{Double Float/TYPE Object Number} 140 | Long/TYPE #{Long Integer/TYPE Short/TYPE Byte/TYPE Object Number} 141 | Character/TYPE #{Character Object} 142 | Short/TYPE #{Short Object Number} 143 | Byte/TYPE #{Byte Object Number} 144 | Boolean/TYPE #{Boolean Object} 145 | Void/TYPE #{Void}}) 146 | 147 | (defn ^Class box 148 | "If the argument is a primitive Class, returns its boxed equivalent, 149 | otherwise returns the argument" 150 | [c] 151 | ({Integer/TYPE Integer 152 | Float/TYPE Float 153 | Double/TYPE Double 154 | Long/TYPE Long 155 | Character/TYPE Character 156 | Short/TYPE Short 157 | Byte/TYPE Byte 158 | Boolean/TYPE Boolean 159 | Void/TYPE Void} 160 | c c)) 161 | 162 | (defn ^Class unbox 163 | "If the argument is a Class with a primitive equivalent, returns that, 164 | otherwise returns the argument" 165 | [c] 166 | ({Integer Integer/TYPE, 167 | Long Long/TYPE, 168 | Float Float/TYPE, 169 | Short Short/TYPE, 170 | Boolean Boolean/TYPE, 171 | Byte Byte/TYPE, 172 | Character Character/TYPE, 173 | Double Double/TYPE, 174 | Void Void/TYPE} 175 | c c)) 176 | 177 | (defn numeric? 178 | "Returns true if the given class is numeric" 179 | [c] 180 | (when c 181 | (.isAssignableFrom Number (box c)))) 182 | 183 | (defn subsumes? 184 | "Returns true if c2 is subsumed by c1" 185 | [c1 c2] 186 | (let [c1 (maybe-class c1) 187 | c2 (maybe-class c2)] 188 | (and (not= c1 c2) 189 | (or (and (not (primitive? c1)) 190 | (primitive? c2)) 191 | (.isAssignableFrom c2 c1))))) 192 | 193 | (defn convertible? 194 | "Returns true if it's possible to convert from c1 to c2" 195 | [c1 c2] 196 | (let [c1 (maybe-class c1) 197 | c2 (maybe-class c2)] 198 | (if (nil? c1) 199 | (not (primitive? c2)) 200 | (or 201 | (= c1 c2) 202 | (.isAssignableFrom c2 c1) 203 | (and (primitive? c2) 204 | ((convertible-primitives c2) c1)) 205 | (and (primitive? c1) 206 | (.isAssignableFrom (box c1) c2)))))) 207 | 208 | (def wider-than 209 | "If the argument is a numeric primitive Class, returns a set of primitive Classes 210 | that are narrower than the given one" 211 | {Long/TYPE #{Integer/TYPE Short/TYPE Byte/TYPE} 212 | Integer/TYPE #{Short/TYPE Byte/TYPE} 213 | Float/TYPE #{Integer/TYPE Short/TYPE Byte/TYPE Long/TYPE} 214 | Double/TYPE #{Integer/TYPE Short/TYPE Byte/TYPE Long/TYPE Float/TYPE} 215 | Short/TYPE #{Byte/TYPE} 216 | Byte/TYPE #{}}) 217 | 218 | (defn wider-primitive 219 | "Given two numeric primitive Classes, returns the wider one" 220 | [from to] 221 | (if ((wider-than from) to) 222 | from 223 | to)) 224 | 225 | (defn wider-tag* 226 | "Given two Classes returns the wider one" 227 | [from to] 228 | (if (not= from to) 229 | (if (primitive? from) 230 | (if (primitive? to) 231 | (wider-primitive from to) 232 | (or (and (numeric? from) 233 | (numeric? to) 234 | to) 235 | ((convertible-primitives from) to))) 236 | (if (primitive? to) 237 | (or (and (numeric? from) 238 | (numeric? to) 239 | from) 240 | ((convertible-primitives to) from)) 241 | (if (convertible? from to) 242 | to 243 | (when (convertible? to from) 244 | from)))) 245 | from)) 246 | 247 | (defn wider-tag 248 | "Given a collection of Classes returns the wider one" 249 | [tags] 250 | (let [tags* (filter identity tags) 251 | wider (loop [wider (first tags*) tags* (rest tags*)] 252 | (if (seq tags*) 253 | (if-let [t (wider-tag* wider (first tags*))] 254 | (recur t (rest tags*))) 255 | wider))] 256 | (when (or (= tags* tags) 257 | (not (primitive? wider))) 258 | wider))) 259 | 260 | (defn name-matches? 261 | [member] 262 | (let [member-name (str member) 263 | i (.lastIndexOf member-name ".") 264 | member-name* (when (pos? i) 265 | (str (s/replace (subs member-name 0 i) "-" "_") (subs member-name i))) 266 | member-name** (s/replace member-name "-" "_") 267 | member-name*** (munge member-name)] 268 | (fn [name] 269 | (let [name (str name)] 270 | (or (= member-name name) 271 | (= member-name* name) 272 | (= member-name** name) 273 | (= member-name*** name)))))) 274 | 275 | (def object-members 276 | (:members (type-reflect Object))) 277 | 278 | (def members* 279 | (lru (fn members* 280 | ([class] 281 | (into object-members 282 | (remove (fn [{:keys [flags]}] 283 | (not-any? #{:public :protected} flags)) 284 | (-> class 285 | maybe-class 286 | ^Class (box) 287 | .getName 288 | symbol 289 | (type-reflect :ancestors true) 290 | :members))))))) 291 | 292 | (defn members 293 | ([class] (members* class)) 294 | ([class member] 295 | (when-let [members (filter #((name-matches? member) (:name %)) 296 | (members* class))] 297 | members))) 298 | 299 | (defn static-members [class f] 300 | (when-let [members (members class f)] 301 | (when-let [statics (filter (comp :static :flags) members)] 302 | statics))) 303 | 304 | (defn instance-members [class f] 305 | (when-let [members (members class f)] 306 | (when-let [i-members (remove (comp :static :flags) members)] 307 | i-members))) 308 | 309 | (defn static-methods [class method argc] 310 | (filter #(= argc (count (:parameter-types %))) 311 | (filter :return-type (static-members class method)))) 312 | 313 | (defn instance-methods [class method argc] 314 | (filter #(= argc (count (:parameter-types %))) 315 | (filter :return-type (instance-members class method)))) 316 | 317 | (defn static-field [class f] 318 | (when-let [statics (static-members class f)] 319 | (when-let [[member] (filter (every-pred (comp nil? seq :parameter-types) 320 | (comp nil? :return-type)) 321 | statics)] 322 | member))) 323 | 324 | (defn instance-field [class f] 325 | (when-let [i-members (instance-members class f)] 326 | (when-let [[member] (filter (every-pred (comp nil? seq :parameter-types) 327 | (comp nil? :return-type)) 328 | i-members)] 329 | member))) 330 | 331 | (defn static-method [class method] 332 | (first (static-methods class method 0))) 333 | 334 | (defn instance-method [class method] 335 | (first (instance-methods class method 0))) 336 | 337 | (defn prim-or-obj 338 | "If the given Class is a primitive, returns that Class, otherwise returns Object" 339 | [tag] 340 | (if (and tag (primitive? tag)) 341 | tag 342 | java.lang.Object)) 343 | 344 | (defn prim-interface [tags] 345 | (when (some primitive? tags) 346 | (let [sig (apply str (mapv #(.toUpperCase (subs (.getSimpleName ^Class %) 0 1)) tags))] 347 | (maybe-class (str "clojure.lang.IFn$" sig))))) 348 | 349 | (defn tag-match? [arg-tags meth] 350 | (every? identity (map convertible? arg-tags (:parameter-types meth)))) 351 | 352 | (defn try-best-match 353 | "Given a vector of arg tags and a collection of methods, tries to return the 354 | subset of methods that match best the given tags" 355 | [tags methods] 356 | (let [o-tags (mapv #(or (maybe-class %) Object) tags)] 357 | (if-let [methods (or (seq (filter 358 | #(= o-tags (mapv maybe-class (:parameter-types %))) methods)) 359 | (seq (filter #(tag-match? tags %) methods)))] 360 | (reduce (fn [[prev & _ :as p] next] 361 | (let [prev-params (mapv maybe-class (:parameter-types prev)) 362 | next-params (mapv maybe-class (:parameter-types next)) 363 | prev-ret (maybe-class (:return-type prev)) 364 | next-ret (maybe-class (:return-type next)) 365 | prev-decl (maybe-class (:declaring-class prev)) 366 | next-decl (maybe-class (:declaring-class next))] 367 | (cond 368 | (not prev) 369 | [next] 370 | (= prev-params next-params) 371 | (cond 372 | (= prev-ret next-ret) 373 | (cond 374 | (.isAssignableFrom prev-decl next-decl) 375 | [next] 376 | (.isAssignableFrom next-decl prev-decl) 377 | p 378 | :else 379 | (conj p next)) 380 | (.isAssignableFrom prev-ret next-ret) 381 | [next] 382 | (.isAssignableFrom next-ret prev-ret) 383 | p 384 | :else 385 | (conj p next)) 386 | (and (some true? (map subsumes? next-params prev-params)) 387 | (not-any? true? (map subsumes? prev-params next-params))) 388 | [next] 389 | :else 390 | (conj p next)))) [] methods) 391 | methods))) 392 | 393 | (defn ns->relpath [s] 394 | (-> s str (s/replace \. \/) (s/replace \- \_) (str ".clj"))) 395 | 396 | (defn ns-url [ns] 397 | (let [f (ns->relpath ns)] 398 | (or (io/resource f) 399 | (io/resource (str f "c"))))) 400 | -------------------------------------------------------------------------------- /spec/ast-ref.edn: -------------------------------------------------------------------------------- 1 | {:all-keys 2 | 3 | [[:op "The node op"] 4 | [:form "The clojure form from which the node originated"] 5 | [:env "The environment map"] 6 | ^:optional 7 | [:children "A vector of keywords, representing the children nodes of this node, in order of evaluation"] 8 | ^:optional 9 | [:raw-forms "If this node's :form has been macroexpanded, a sequence of all the intermediate forms from the original form to the macroexpanded form"] 10 | ^:optional 11 | [:top-level "`true` if this is the root node"] 12 | [:tag "The tag this expression is required to have"] 13 | [:o-tag "The tag of this expression, based on the node's children"] 14 | ^:optional 15 | [:ignore-tag "`true` if this node returns a statement rather than an expression"] 16 | ^:optional 17 | [:loops "A set of the loop-ids that might cause this node to recur"]] 18 | 19 | :node-keys 20 | [{:op :binding 21 | :doc "Node for a binding symbol" 22 | :keys [[:form "The binding symbol"] 23 | [:name "The uniquified binding symbol"] 24 | [:local "One of :arg, :catch, :fn, :let, :letfn, :loop, :field or :this"] 25 | ^:optional 26 | [:arg-id "When :local is :arg, the parameter index"] 27 | ^:optional 28 | [:variadic? "When :local is :arg, a boolean indicating whether this parameter binds to a variable number of arguments"] 29 | ^:optional ^:children 30 | [:init "When :local is :let, :letfn or :loop, an AST node representing the bound value"] 31 | [:atom "An atom shared by this :binding node and all the :local nodes that refer to this binding"] 32 | #_ 33 | ^:optional 34 | [:to-clear? "When :local is :let, :loop, :catch or :arg, a boolean indicating whether this binding is never used and this is immediately eligible for clearing"]]} 35 | {:op :case 36 | :doc "Node for a case* special-form expression" 37 | :keys [[:form "`(case* expr shift maks default case-map switch-type test-type skip-check?)`"] 38 | ^:children 39 | [:test "The AST node for the expression to test against"] 40 | ^:children 41 | [:tests "A vector of :case-test AST nodes, each node has a corresponding :case-then node in the :thens field"] 42 | ^:children 43 | [:thens "A vector of :case-then AST nodes, each node has a corresponding :case-test node in the :tests field"] 44 | ^:children 45 | [:default "An AST node representing the default value of the case expression"] 46 | [:shift] 47 | [:mask] 48 | [:low] 49 | [:high] 50 | [:switch-type "One of :sparse or :compact"] 51 | [:test-type "One of :int, :hash-equiv or :hash-identity"] 52 | [:skip-check? "A set of case ints for which equivalence checking should not be done"]]} 53 | {:op :case-test 54 | :doc "Node for a test value in a case* expression" 55 | :keys [^:children 56 | [:test "A :const AST node representing the test value"] 57 | [:hash]]} 58 | {:op :case-then 59 | :doc "Node for a then expression in a case* expression" 60 | :keys [^:children 61 | [:then "An AST node representing the expression the case will evaluate to when the :test expression matches this node's corresponding :case-test value"] 62 | [:hash]]} 63 | {:op :catch 64 | :doc "Node for a catch expression" 65 | :keys [[:form "`(catch class local body*)`"] 66 | ^:children 67 | [:class "A :const AST node with :type :class representing the type of exception to catch"] 68 | ^:children 69 | [:local "The :binding AST node for the caught exception"] 70 | ^:children 71 | [:body "Synthetic :do AST node (with :body? `true`) representing the body of the catch clause"]]} 72 | {:op :const 73 | :doc "Node for a constant literal or a quoted collection literal" 74 | :keys [[:form "A constant literal or a quoted collection literal"] 75 | [:literal? "`true`"] 76 | [:type "one of :nil, :bool, :keyword, :symbol, :string, :number, :type, :record, :map, :vector, :set, :seq, :char, :regex, :class, :var, or :unknown"] 77 | [:val "The value of the constant node"] 78 | ^:optional ^:children 79 | [:meta "An AST node representing the metadata of the constant value, if present. The node will be either a :map node or a :const node with :type :map"] 80 | #_ 81 | ^:optional 82 | [:id "A numeric id for the constant value, will be the same for every instance of this constant inside the same compilation unit, not present if :type is :nil or :bool"]]} 83 | {:op :def 84 | :doc "Node for a def special-form expression" 85 | :keys [[:form "`(def name docstring? init?)`"] 86 | [:name "The var symbol to define in the current namespace"] 87 | [:var "The Var object created (or found, if it already existed) named by the symbol :name in the current namespace"] 88 | ^:optional ^:children 89 | [:meta "An AST node representing the metadata attached to :name, if present. The node will be either a :map node or a :const node with :type :map"] 90 | ^:optional ^:children 91 | [:init "An AST node representing the initial value of the var"] 92 | ^:optional 93 | [:doc "The docstring for this var"] 94 | #_ 95 | [:id "A numeric id for this var, will be the same for every instance of this var inside the same compilation unit"]]} 96 | {:op :deftype 97 | :doc "Node for a deftype* special-form expression" 98 | :keys [[:form "`(deftype* name class.name [arg*] :implements [interface*] method*)`"] 99 | [:interfaces "A set of the interfaces implemented by the type"] 100 | [:name "The symbol name of the deftype"] 101 | [:class-name "A class for the deftype, should *never* be instantiated or used on instance? checks as this will not be the same class the deftype will evaluate to after compilation"] 102 | ^:children 103 | [:fields "A vector of :binding AST nodes with :local :field representing the deftype fields"] 104 | ^:children 105 | [:methods "A vector :method AST nodes representing the deftype methods"] 106 | #_#_#_#_ 107 | [:closed-overs "A map of field name -> :binding AST node of the field"] 108 | [:protocol-callsites "A map of protocol Vars that appear in the bodies of the deftype methods"] 109 | [:keyword-callsites "A map of keywords that appear in keyword-invoke position in the bodies of the deftype methods"] 110 | [:constants "A map of the constants that appear in the bodies of the deftype methods. The mapping is from a map with :form, :meta and :tag fields to a map with :id, :tag :val and :type fields, the :id will be the same for all every instance of this constant inside the same compilation unit."]]} 111 | {:op :do 112 | :doc "Node for a do special-form expression or for another special-form's body" 113 | :keys [[:form "`(do statement* ret)`"] 114 | ^:children 115 | [:statements "A vector of AST nodes representing all but the last expression in the do body"] 116 | ^:children 117 | [:ret "An AST node representing the last expression in the do body (the block's return value)"] 118 | ^:optional 119 | [:body? "`true` if this node is a synthetic body"]]} 120 | {:op :fn 121 | :doc "Node for a fn* special-form expression" 122 | :keys [[:form "`(fn* name? [arg*] body*)` or `(fn* name? method*)`"] 123 | [:variadic? "`true` if this function contains a variadic arity method"] 124 | [:max-fixed-arity "The number of arguments taken by the fixed-arity method taking the most arguments"] 125 | #_#_ 126 | [:internal-name "The internal name symbol used for the fn"] 127 | [:class-id "A unique id representing this function"] 128 | ^:optional ^:children 129 | [:local "A :binding AST node with :local :fn representing the function's local name, if one is supplied"] 130 | ^:children 131 | [:methods "A vector of :fn-method AST nodes representing the fn method arities"] 132 | [:once "`true` if the fn is marked as `^:once fn*`, meaning it will only be executed once and thus allowing for the clearing of closed-over locals"] 133 | #_#_#_#_ 134 | [:closed-overs "A map of uniquified local name -> :binding AST node of the local, containing all the locals closed-over by this fn"] 135 | [:protocol-callsites "A map of protocol Vars that appear in the bodies of the fn methods"] 136 | [:keyword-callsites "A map of keywords that appear in keyword-invoke position in the bodies of the fn methods"] 137 | [:constants "A map of the constants that appear in the bodies of the fn methods. The mapping is from a map with :form, :meta and :tag fields to a map with :id, :tag :val and :type fields, the :id will be the same for all every instance of this constant inside the same compilation unit."]]} 138 | {:op :fn-method 139 | :doc "Node for an arity method in a fn* expression" 140 | :keys [[:form "`([arg*] body*)`"] 141 | [:loop-id "Unique symbol identifying this method as a target for recursion"] 142 | [:variadic? "`true` if this fn-method takes a variable number of arguments"] 143 | ^:children 144 | [:params "A vector of :binding AST nodes with :local :arg representing this fn-method args"] 145 | [:fixed-arity "The number of non-variadic args this fn-method takes"] 146 | ^:children 147 | [:body "Synthetic :do node (with :body? `true`) representing the body of this fn-method"]]} 148 | {:op :host-interop 149 | :doc "Node for a no-arg instance-call or for an instance-field that couldn't be resolved at compile time" 150 | :keys [[:form "`(. target m-or-f)`"] 151 | ^:children 152 | [:target "An AST node representing the target object"] 153 | [:m-or-f "Symbol naming the no-arg method or field to lookup in the target"] 154 | [:assignable? "`true`"]]} 155 | {:op :if 156 | :doc "Node for an if special-form expression" 157 | :keys [[:form "`(if test then else?)`"] 158 | ^:children 159 | [:test "An AST node representing the test expression"] 160 | ^:children 161 | [:then "An AST node representing the expression's return value if :test evaluated to a truthy value"] 162 | ^:children 163 | [:else "An AST node representing the expression's return value if :test evaluated to a falsey value, if not supplied it will default to a :const node representing nil"]]} 164 | {:op :import 165 | :doc "Node for a clojure.core/import* special-form expression" 166 | :keys [[:form "`(clojure.core/import* \"qualified.class\")`"] 167 | [:class "String representing the qualified class to import"]]} 168 | {:op :instance-call 169 | :doc "Node for an instance method call" 170 | :keys [[:form "`(.method instance arg*)`"] 171 | [:method "Symbol naming the invoked method"] 172 | ^:children 173 | [:instance "An AST node representing the instance to call the method on"] 174 | ^:children 175 | [:args "A vector of AST nodes representing the args passed to the method call"] 176 | ^:optional 177 | [:validated? "`true` if the method call could be resolved at compile time"] 178 | ^:optional 179 | [:class "If :validated? the class or interface the method belongs to"]]} 180 | {:op :instance-field 181 | :doc "Node for an instance field access" 182 | :keys [[:form "`(.-field instance)`"] 183 | [:field "Symbol naming the field to access"] 184 | ^:children 185 | [:instance "An AST node representing the instance to lookup the symbol on"] 186 | [:assignable? "`true` if the field is set!able"] 187 | [:class "The class the field belongs to"]]} 188 | {:op :instance? 189 | :doc "Node for a clojure.core/instance? call where the Class is known at compile time" 190 | :keys [[:form "`(clojure.core/instance? Class x)`"] 191 | [:class "The Class to test the :target for instanceability"] 192 | ^:children 193 | [:target "An AST node representing the object to test for instanceability"]]} 194 | {:op :invoke 195 | :doc "Node for an invoke expression" 196 | :keys [[:form "`(f arg*)`"] 197 | ^:children 198 | [:fn "An AST node representing the function to invoke"] 199 | ^:children 200 | [:args "A vector of AST nodes representing the args to the function"] 201 | ^:optional 202 | [:meta "Map of metadata attached to the invoke :form"]]} 203 | {:op :keyword-invoke 204 | :doc "Node for an invoke expression where the fn is a not-namespaced keyword and thus a keyword callsite can be emitted" 205 | :keys [[:form "`(:k instance)`"] 206 | ^:children 207 | [:keyword "An AST node representing the keyword to lookup in the instance"] 208 | ^:children 209 | [:target "An AST node representing the instance to lookup the keyword in"]]} 210 | {:op :let 211 | :doc "Node for a let* special-form expression" 212 | :keys [[:form "`(let* [binding*] body*)`"] 213 | ^:children 214 | [:bindings "A vector of :binding AST nodes with :local :let"] 215 | ^:children 216 | [:body "Synthetic :do node (with :body? `true`) representing the body of the let expression"]]} 217 | {:op :letfn 218 | :doc "Node for a letfn* special-form expression" 219 | :keys [[:form "`(letfn* [binding*] body*)`"] 220 | ^:children 221 | [:bindings "A vector of :binding AST nodes with :local :letfn"] 222 | ^:children 223 | [:body "Synthetic :do node (with :body? `true`) representing the body of the letfn expression"]]} 224 | {:op :local 225 | :doc "Node for a local symbol" 226 | :keys [[:form "The local symbol"] 227 | [:assignable? "`true` if the corresponding :binding AST node is :local :field and is declared either ^:volatile-mutable or ^:unsynchronized-mutable"] 228 | [:name "The uniquified local symbol"] 229 | [:local "One of :arg, :catch, :fn, :let, :letfn, :loop, :field or :this"] 230 | ^:optional 231 | [:arg-id "When :local is :arg, the parameter index"] 232 | ^:optional 233 | [:variadic? "When :local is :arg, a boolean indicating whether this parameter binds to a variable number of arguments"] 234 | [:atom "An atom shared by this :local node, the :binding node this local refers to and all the other :local nodes that refer to this same local"] 235 | #_ 236 | ^:optional 237 | [:to-clear? "When :local is :let, :loop, :catch or :arg, a boolean indicating whether this local is eligible for locals clearing"]]} 238 | {:op :loop 239 | :doc "Node a loop* special-form expression" 240 | :keys [[:form "`(loop* [binding*] body*)`"] 241 | ^:children 242 | [:bindings "A vector of :binding AST nodes with :local :loop"] 243 | ^:children 244 | [:body "Synthetic :do node (with :body? `true`) representing the body of the loop expression"] 245 | [:loop-id "Unique symbol identifying this loop as a target for recursion"] 246 | #_ 247 | [:closed-overs "A map of uniquified local name -> :binding AST node of the local, containing all the locals closed-over by this loop"]]} 248 | {:op :map 249 | :doc "Node for a map literal with attached metadata and/or non literal elements" 250 | :keys [[:form "`{[key val]*}`"] 251 | ^:children 252 | [:keys "A vector of AST nodes representing the keys of the map"] 253 | ^:children 254 | [:vals "A vector of AST nodes representing the vals of the map"]]} 255 | {:op :method 256 | :doc "Node for a method in a deftype* or reify* special-form expression" 257 | :keys [[:form "`(method [this arg*] body*)`"] 258 | [:bridges "A list of signature for bridge methods to emit"] 259 | [:interface "The interface (or Object) this method belongs to"] 260 | ^:children 261 | [:this "A :binding AST node with :local :this representing the \"this\" local"] 262 | [:loop-id "Unique symbol identifying this method as a target for recursion"] 263 | [:name "The symbol name of this method"] 264 | ^:children 265 | [:params "A vector of AST :binding nodes with :local :arg representing the arguments of the method"] 266 | [:fixed-arity "The number of args this method takes"] 267 | ^:children 268 | [:body "Synthetic :do node (with :body? `true`) representing the body of this method"]]} 269 | {:op :monitor-enter 270 | :doc "Node for a monitor-enter special-form statement" 271 | :keys [[:form "`(monitor-enter target)`"] 272 | ^:children 273 | [:target "An AST node representing the monitor-enter sentinel"]]} 274 | {:op :monitor-exit 275 | :doc "Node for a monitor-exit special-form statement" 276 | :keys [[:form "`(monitor-exit target)`"] 277 | ^:children 278 | [:target "An AST node representing the monitor-exit sentinel"]]} 279 | {:op :new 280 | :doc "Node for a new special-form expression" 281 | :keys [[:form "`(new Class arg*)`"] 282 | ^:children 283 | [:class "A :const AST node with :type :class representing the Class to instantiate"] 284 | ^:children 285 | [:args "A vector of AST nodes representing the arguments passed to the Class constructor"] 286 | ^:optional 287 | [:validated? "`true` if the constructor call could be resolved at compile time"]]} 288 | {:op :prim-invoke 289 | :doc "Node for an invoke expression that can be optimized using one of the primitive interfaces in IFn" 290 | :keys [[:form "`(prim-f arg*)`"] 291 | ^:children 292 | [:fn "An AST node representing the function to invoke"] 293 | ^:children 294 | [:args "A vector of AST nodes representing the args to the function"] 295 | [:prim-interface "The primitive interface in IFn that will be used"] 296 | ^:optional 297 | [:meta "Map of metadata attached to the invoke :form"]]} 298 | {:op :protocol-invoke 299 | :doc "Node for an invoke expression where the function is a protocol function var" 300 | :keys [[:form "`(proto-fn target arg*)`"] 301 | ^:children 302 | [:protocol-fn "An AST node representing the protocol function var to invoke"] 303 | ^:children 304 | [:target "An AST node representing the target of the protocol function call"] 305 | ^:children 306 | [:args "A vector of AST nodes representing the args to the protocol function"]]} 307 | {:op :quote 308 | :doc "Node for a quote special-form expression" 309 | :keys [[:form "`(quote expr)`"] 310 | ^:children 311 | [:expr "A :const AST node representing the quoted value"] 312 | [:literal? "`true`"]]} 313 | {:op :recur 314 | :doc "Node for a recur special-form expression" 315 | :keys [[:form "`(recur expr*)`"] 316 | ^:children 317 | [:exprs "A vector of AST nodes representing the new bound values for the loop binding on the next loop iteration"] 318 | [:loop-id "Unique symbol identifying the enclosing loop target"]]} 319 | {:op :reify 320 | :doc "Node for a reify* special-form expression" 321 | :keys [[:form "`(reify* [interface*] method*)`"] 322 | [:interfaces "A set of the interfaces implemented by the generated type"] 323 | [:class-name "The generated class for the reify, should *never* be instantiated or used on instance? checks"] 324 | ^:children 325 | [:methods "A vector :method AST nodes representing the reify methods"] 326 | #_#_#_#_#_ 327 | [:class-id "A unique id representing this reify"] 328 | [:closed-overs "A map of uniquified local name -> :binding AST node of the local, containing all the locals closed-over by this reify"] 329 | [:protocol-callsites "A map of protocol Vars that appear in the bodies of the reify methods"] 330 | [:keyword-callsites "A map of keywords that appear in keyword-invoke position in the bodies of the reify methods"] 331 | [:constants "A map of the constants that appear in the bodies of the reify methods. The mapping is from a map with :form, :meta and :tag fields to a map with :id, :tag :val and :type fields, the :id will be the same for all every instance of this constant inside the same compilation unit."]]} 332 | {:op :set 333 | :doc "Node for a set literal with attached metadata and/or non literal elements" 334 | :keys [[:form "`#{item*}`"] 335 | ^:children 336 | [:items "A vector of AST nodes representing the items of the set"]]} 337 | {:op :set! 338 | :doc "Node for a set! special-form expression" 339 | :keys [[:form "`(set! target val)`"] 340 | ^:children 341 | [:target "An AST node representing the target of the set! expression, must be :assignable?"] 342 | ^:children 343 | [:val "An AST node representing the new value for the target"]]} 344 | {:op :static-call 345 | :doc "Node for a static method call" 346 | :keys [[:form "`(Class/method arg*)`"] 347 | [:class "The Class the static method belongs to"] 348 | [:method "The symbol name of the static method"] 349 | ^:children 350 | [:args "A vector of AST nodes representing the args to the method call"] 351 | ^:optional 352 | [:validated? "`true` if the static method could be resolved at compile time"]]} 353 | {:op :static-field 354 | :doc "Node for a static field access" 355 | :keys [[:form "`Class/field`"] 356 | [:class "The Class the static field belongs to"] 357 | [:field "The symbol name of the static field"] 358 | ^:optional 359 | [:assignable? "`true` if the static field is set!able"]]} 360 | {:op :the-var 361 | :doc "Node for a var special-form expression" 362 | :keys [[:form "`(var var-name)`"] 363 | [:var "The Var object this expression refers to"] 364 | #_ 365 | [:id "A numeric id for this var, will be the same for every instance of this var inside the same compilation unit"]]} 366 | {:op :throw 367 | :doc "Node for a throw special-form statement" 368 | :keys [[:form "`(throw exception)`"] 369 | ^:children 370 | [:exception "An AST node representing the exception to throw"]]} 371 | {:op :try 372 | :doc "Node for a try special-form expression" 373 | :keys [[:form "`(try body* catch* finally?)`"] 374 | ^:children 375 | [:body "Synthetic :do AST node (with :body? `true`) representing the body of this try expression"] 376 | ^:children 377 | [:catches "A vector of :catch AST nodes representing the catch clauses of this try expression"] 378 | ^:optional ^:children 379 | [:finally "Synthetic :do AST node (with :body? `true`) representing the final clause of this try expression"]]} 380 | {:op :var 381 | :doc "Node for a var symbol" 382 | :keys [[:form "A symbol naming the var"] 383 | [:var "The Var object this symbol refers to"] 384 | ^:optional 385 | [:assignable? "`true` if the Var is :dynamic"] 386 | #_ 387 | [:id "A numeric id for this var, will be the same for every instance of this var inside the same compilation unit"]]} 388 | {:op :vector 389 | :doc "Node for a vector literal with attached metadata and/or non literal elements" 390 | :keys [[:form "`[item*]`"] 391 | ^:children 392 | [:items "A vector of AST nodes representing the items of the vector"]]} 393 | {:op :with-meta 394 | :doc "Node for a non quoted collection literal or fn/reify expression with attached metadata" 395 | :keys [[:form "Non quoted collection literal or fn/reify expression with attached metadata"] 396 | ^:children 397 | [:meta "An AST node representing the metadata of expression. The node will be either a :map node or a :const node with :type :map"] 398 | ^:children 399 | [:expr "The expression this metadata is attached to, :op is one of :vector, :map, :set, :fn or :reify"]]}]} 400 | -------------------------------------------------------------------------------- /src/main/clojure/clojure/tools/analyzer/jvm.clj: -------------------------------------------------------------------------------- 1 | ;; Copyright (c) Nicola Mometto, Rich Hickey & contributors. 2 | ;; The use and distribution terms for this software are covered by the 3 | ;; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) 4 | ;; which can be found in the file epl-v10.html at the root of this distribution. 5 | ;; By using this software in any fashion, you are agreeing to be bound by 6 | ;; the terms of this license. 7 | ;; You must not remove this notice, or any other, from this software. 8 | 9 | (ns clojure.tools.analyzer.jvm 10 | "Analyzer for clojure code, extends tools.analyzer with JVM specific passes/forms" 11 | (:refer-clojure :exclude [macroexpand-1 macroexpand]) 12 | (:require [clojure.tools.analyzer 13 | :as ana 14 | :refer [analyze analyze-in-env wrapping-meta analyze-fn-method] 15 | :rename {analyze -analyze}] 16 | 17 | [clojure.tools.analyzer 18 | [utils :refer [ctx resolve-sym -source-info resolve-ns obj? dissoc-env butlast+last mmerge]] 19 | [ast :refer [walk prewalk postwalk] :as ast] 20 | [env :as env :refer [*env*]] 21 | [passes :refer [schedule]]] 22 | 23 | [clojure.tools.analyzer.jvm.utils :refer :all :as u :exclude [box specials]] 24 | 25 | [clojure.tools.analyzer.passes 26 | [source-info :refer [source-info]] 27 | [trim :refer [trim]] 28 | [elide-meta :refer [elide-meta elides]] 29 | [warn-earmuff :refer [warn-earmuff]] 30 | [uniquify :refer [uniquify-locals]]] 31 | 32 | [clojure.tools.analyzer.passes.jvm 33 | [analyze-host-expr :refer [analyze-host-expr]] 34 | [box :refer [box]] 35 | [constant-lifter :refer [constant-lift]] 36 | [classify-invoke :refer [classify-invoke]] 37 | [validate :refer [validate]] 38 | [infer-tag :refer [infer-tag]] 39 | [validate-loop-locals :refer [validate-loop-locals]] 40 | [warn-on-reflection :refer [warn-on-reflection]] 41 | [emit-form :refer [emit-form]]] 42 | 43 | [clojure.java.io :as io] 44 | [clojure.tools.reader :as reader] 45 | [clojure.tools.reader.reader-types :as readers] 46 | 47 | [clojure.core.memoize :refer [memo-clear!]]) 48 | (:import (clojure.lang IObj RT Compiler Var) 49 | java.net.URL)) 50 | 51 | (set! *warn-on-reflection* true) 52 | 53 | (def ns-safe-macro 54 | "Clojure macros that are known to not alter namespaces" 55 | #{#'clojure.core/-> 56 | #'clojure.core/->> 57 | #'clojure.core/.. 58 | #'clojure.core/and 59 | #'clojure.core/as-> 60 | #'clojure.core/assert 61 | #'clojure.core/case 62 | #'clojure.core/cond 63 | #'clojure.core/cond-> 64 | #'clojure.core/cond->> 65 | #'clojure.core/condp 66 | #'clojure.core/defn 67 | #'clojure.core/defn- 68 | #'clojure.core/delay 69 | #'clojure.core/doseq 70 | #'clojure.core/dosync 71 | #'clojure.core/dotimes 72 | #'clojure.core/doto 73 | #'clojure.core/fn 74 | #'clojure.core/for 75 | #'clojure.core/future 76 | #'clojure.core/if-let 77 | #'clojure.core/if-not 78 | #'clojure.core/lazy-seq 79 | #'clojure.core/let 80 | #'clojure.core/letfn 81 | #'clojure.core/loop 82 | #'clojure.core/or 83 | #'clojure.core/reify 84 | #'clojure.core/some-> 85 | #'clojure.core/some->> 86 | #'clojure.core/sync 87 | #'clojure.core/time 88 | #'clojure.core/when 89 | #'clojure.core/when-let 90 | #'clojure.core/when-not 91 | #'clojure.core/while 92 | #'clojure.core/with-open 93 | #'clojure.core/with-out-str 94 | }) 95 | 96 | (def specials 97 | "Set of the special forms for clojure in the JVM" 98 | (into ana/specials 99 | '#{monitor-enter monitor-exit clojure.core/import* reify* deftype* case*})) 100 | 101 | (defn build-ns-map [] 102 | (into {} (mapv #(vector (ns-name %) 103 | {:mappings (merge (ns-map %) {'in-ns #'clojure.core/in-ns 104 | 'ns #'clojure.core/ns}) 105 | :aliases (reduce-kv (fn [a k v] (assoc a k (ns-name v))) 106 | {} (ns-aliases %)) 107 | :ns (ns-name %)}) 108 | (all-ns)))) 109 | 110 | (defn update-ns-map! [] 111 | ((get (env/deref-env) :update-ns-map! #()))) 112 | 113 | (defn global-env [] 114 | (atom {:namespaces (build-ns-map) 115 | 116 | :update-ns-map! (fn update-ns-map! [] 117 | (swap! *env* assoc-in [:namespaces] (build-ns-map)))})) 118 | 119 | (defn empty-env 120 | "Returns an empty env map" 121 | [] 122 | {:context :ctx/expr 123 | :locals {} 124 | :ns (ns-name *ns*)}) 125 | 126 | (defn desugar-symbol [form env] 127 | (let [sym-ns (namespace form)] 128 | (if-let [target (and sym-ns 129 | (not (resolve-ns (symbol sym-ns) env)) 130 | (maybe-class-literal sym-ns))] ;; Class/field 131 | (let [opname (name form)] 132 | (if (and (= (count opname) 1) 133 | (Character/isDigit (char (first opname)))) 134 | form ;; Array/ 135 | (with-meta (list '. target (symbol (str "-" opname))) ;; transform to (. Class -field) 136 | (meta form)))) 137 | form))) 138 | 139 | (defn desugar-host-expr [form env] 140 | (let [[op & expr] form] 141 | (if (symbol? op) 142 | (let [opname (name op) 143 | opns (namespace op)] 144 | (if-let [target (and opns 145 | (not (resolve-ns (symbol opns) env)) 146 | (maybe-class-literal opns))] ; (class/field ..) 147 | 148 | (let [op (symbol opname)] 149 | (with-meta (list '. target (if (zero? (count expr)) 150 | op 151 | (list* op expr))) 152 | (meta form))) 153 | 154 | (cond 155 | (.startsWith opname ".") ; (.foo bar ..) 156 | (let [[target & args] expr 157 | target (if-let [target (maybe-class-literal target)] 158 | (with-meta (list 'do target) 159 | {:tag 'java.lang.Class}) 160 | target) 161 | args (list* (symbol (subs opname 1)) args)] 162 | (with-meta (list '. target (if (= 1 (count args)) ;; we don't know if (.foo bar) is 163 | (first args) args)) ;; a method call or a field access 164 | (meta form))) 165 | 166 | (.endsWith opname ".") ;; (class. ..) 167 | (with-meta (list* 'new (symbol (subs opname 0 (dec (count opname)))) expr) 168 | (meta form)) 169 | 170 | :else form))) 171 | form))) 172 | 173 | (defn macroexpand-1 174 | "If form represents a macro form or an inlineable function,returns its expansion, 175 | else returns form." 176 | ([form] (macroexpand-1 form (empty-env))) 177 | ([form env] 178 | (env/ensure (global-env) 179 | (cond 180 | 181 | (seq? form) 182 | (let [[op & args] form] 183 | (if (specials op) 184 | form 185 | (let [v (resolve-sym op env) 186 | m (meta v) 187 | local? (-> env :locals (get op)) 188 | macro? (and (not local?) (:macro m)) ;; locals shadow macros 189 | inline-arities-f (:inline-arities m) 190 | inline? (and (not local?) 191 | (or (not inline-arities-f) 192 | (inline-arities-f (count args))) 193 | (:inline m)) 194 | t (:tag m)] 195 | (cond 196 | 197 | macro? 198 | (let [res (apply v form (:locals env) (rest form))] ; (m &form &env & args) 199 | (when-not (ns-safe-macro v) 200 | (update-ns-map!)) 201 | (if (obj? res) 202 | (vary-meta res merge (meta form)) 203 | res)) 204 | 205 | inline? 206 | (let [res (apply inline? args)] 207 | (update-ns-map!) 208 | (if (obj? res) 209 | (vary-meta res merge 210 | (and t {:tag t}) 211 | (meta form)) 212 | res)) 213 | 214 | :else 215 | (desugar-host-expr form env))))) 216 | 217 | (symbol? form) 218 | (desugar-symbol form env) 219 | 220 | :else 221 | form)))) 222 | 223 | (defn qualify-arglists [arglists] 224 | (vary-meta arglists merge 225 | (when-let [t (:tag (meta arglists))] 226 | {:tag (if (or (string? t) 227 | (u/specials (str t)) 228 | (u/special-arrays (str t))) 229 | t 230 | (if-let [c (maybe-class t)] 231 | (let [new-t (-> c .getName symbol)] 232 | (if (= new-t t) 233 | t 234 | (with-meta new-t {::qualified? true}))) 235 | t))}))) 236 | 237 | (defn create-var 238 | "Creates a Var for sym and returns it. 239 | The Var gets interned in the env namespace." 240 | [sym {:keys [ns]}] 241 | (let [v (get-in (env/deref-env) [:namespaces ns :mappings (symbol (name sym))])] 242 | (if (and v (or (class? v) 243 | (= ns (ns-name (.ns ^Var v) )))) 244 | v 245 | (let [meta (dissoc (meta sym) :inline :inline-arities :macro) 246 | meta (if-let [arglists (:arglists meta)] 247 | (assoc meta :arglists (qualify-arglists arglists)) 248 | meta)] 249 | (intern ns (with-meta sym meta)))))) 250 | 251 | (defn parse-monitor-enter 252 | [[_ target :as form] env] 253 | (when-not (= 2 (count form)) 254 | (throw (ex-info (str "Wrong number of args to monitor-enter, had: " (dec (count form))) 255 | (merge {:form form} 256 | (-source-info form env))))) 257 | {:op :monitor-enter 258 | :env env 259 | :form form 260 | :target (-analyze target (ctx env :ctx/expr)) 261 | :children [:target]}) 262 | 263 | (defn parse-monitor-exit 264 | [[_ target :as form] env] 265 | (when-not (= 2 (count form)) 266 | (throw (ex-info (str "Wrong number of args to monitor-exit, had: " (dec (count form))) 267 | (merge {:form form} 268 | (-source-info form env))))) 269 | {:op :monitor-exit 270 | :env env 271 | :form form 272 | :target (-analyze target (ctx env :ctx/expr)) 273 | :children [:target]}) 274 | 275 | (defn parse-import* 276 | [[_ class :as form] env] 277 | (when-not (= 2 (count form)) 278 | (throw (ex-info (str "Wrong number of args to import*, had: " (dec (count form))) 279 | (merge {:form form} 280 | (-source-info form env))))) 281 | {:op :import 282 | :env env 283 | :form form 284 | :class class}) 285 | 286 | (defn analyze-method-impls 287 | [[method [this & params :as args] & body :as form] env] 288 | (when-let [error-msg (cond 289 | (not (symbol? method)) 290 | (str "Method method must be a symbol, had: " (class method)) 291 | (not (vector? args)) 292 | (str "Parameter listing should be a vector, had: " (class args)) 293 | (not (first args)) 294 | (str "Must supply at least one argument for 'this' in: " method))] 295 | (throw (ex-info error-msg 296 | (merge {:form form 297 | :in (:this env) 298 | :method method 299 | :args args} 300 | (-source-info form env))))) 301 | (let [meth (cons (vec params) body) ;; this is an implicit arg 302 | this-expr {:name this 303 | :env env 304 | :form this 305 | :op :binding 306 | :o-tag (:this env) 307 | :tag (:this env) 308 | :local :this} 309 | env (assoc-in (dissoc env :this) [:locals this] (dissoc-env this-expr)) 310 | method-expr (analyze-fn-method meth env)] 311 | (assoc (dissoc method-expr :variadic?) 312 | :op :method 313 | :form form 314 | :this this-expr 315 | :name (symbol (name method)) 316 | :children (into [:this] (:children method-expr))))) 317 | 318 | ;; HACK 319 | (defn -deftype [name class-name args interfaces] 320 | 321 | (doseq [arg [class-name name]] 322 | (memo-clear! members* [arg]) 323 | (memo-clear! members* [(str arg)])) 324 | 325 | (let [interfaces (mapv #(symbol (.getName ^Class %)) interfaces)] 326 | (eval (list `let [] 327 | (list 'deftype* name class-name args :implements interfaces) 328 | (list `import class-name))))) 329 | 330 | (defn parse-reify* 331 | [[_ interfaces & methods :as form] env] 332 | (let [interfaces (conj (disj (set (mapv maybe-class interfaces)) Object) 333 | IObj) 334 | name (gensym "reify__") 335 | class-name (symbol (str (namespace-munge *ns*) "$" name)) 336 | menv (assoc env :this class-name) 337 | methods (mapv #(assoc (analyze-method-impls % menv) :interfaces interfaces) 338 | methods)] 339 | 340 | (-deftype name class-name [] interfaces) 341 | 342 | (wrapping-meta 343 | {:op :reify 344 | :env env 345 | :form form 346 | :class-name class-name 347 | :methods methods 348 | :interfaces interfaces 349 | :children [:methods]}))) 350 | 351 | (defn parse-opts+methods [methods] 352 | (loop [opts {} methods methods] 353 | (if (keyword? (first methods)) 354 | (recur (assoc opts (first methods) (second methods)) (nnext methods)) 355 | [opts methods]))) 356 | 357 | (defn parse-deftype* 358 | [[_ name class-name fields _ interfaces & methods :as form] env] 359 | (let [interfaces (disj (set (mapv maybe-class interfaces)) Object) 360 | fields-expr (mapv (fn [name] 361 | {:env env 362 | :form name 363 | :name name 364 | :mutable (let [m (meta name)] 365 | (or (and (:unsynchronized-mutable m) 366 | :unsynchronized-mutable) 367 | (and (:volatile-mutable m) 368 | :volatile-mutable))) 369 | :local :field 370 | :op :binding}) 371 | fields) 372 | menv (assoc env 373 | :context :ctx/expr 374 | :locals (zipmap fields (map dissoc-env fields-expr)) 375 | :this class-name) 376 | [opts methods] (parse-opts+methods methods) 377 | methods (mapv #(assoc (analyze-method-impls % menv) :interfaces interfaces) 378 | methods)] 379 | 380 | (-deftype name class-name fields interfaces) 381 | 382 | {:op :deftype 383 | :env env 384 | :form form 385 | :name name 386 | :class-name class-name ;; internal, don't use as a Class 387 | :fields fields-expr 388 | :methods methods 389 | :interfaces interfaces 390 | :children [:fields :methods]})) 391 | 392 | (defn parse-case* 393 | [[_ expr shift mask default case-map switch-type test-type & [skip-check?] :as form] env] 394 | (let [[low high] ((juxt first last) (keys case-map)) ;;case-map is a sorted-map 395 | e (ctx env :ctx/expr) 396 | test-expr (-analyze expr e) 397 | [tests thens] (reduce (fn [[te th] [min-hash [test then]]] 398 | (let [test-expr (ana/analyze-const test e) 399 | then-expr (-analyze then env)] 400 | [(conj te {:op :case-test 401 | :form test 402 | :env e 403 | :hash min-hash 404 | :test test-expr 405 | :children [:test]}) 406 | (conj th {:op :case-then 407 | :form then 408 | :env env 409 | :hash min-hash 410 | :then then-expr 411 | :children [:then]})])) 412 | [[] []] case-map) 413 | default-expr (-analyze default env)] 414 | {:op :case 415 | :form form 416 | :env env 417 | :test (assoc test-expr :case-test true) 418 | :default default-expr 419 | :tests tests 420 | :thens thens 421 | :shift shift 422 | :mask mask 423 | :low low 424 | :high high 425 | :switch-type switch-type 426 | :test-type test-type 427 | :skip-check? skip-check? 428 | :children [:test :tests :thens :default]})) 429 | 430 | (defn parse 431 | "Extension to tools.analyzer/-parse for JVM special forms" 432 | [form env] 433 | ((case (first form) 434 | monitor-enter parse-monitor-enter 435 | monitor-exit parse-monitor-exit 436 | clojure.core/import* parse-import* 437 | reify* parse-reify* 438 | deftype* parse-deftype* 439 | case* parse-case* 440 | #_:else ana/-parse) 441 | form env)) 442 | 443 | (def default-passes 444 | "Set of passes that will be run by default on the AST by #'run-passes" 445 | #{#'warn-on-reflection 446 | #'warn-earmuff 447 | 448 | #'uniquify-locals 449 | 450 | #'source-info 451 | #'elide-meta 452 | #'constant-lift 453 | 454 | #'trim 455 | 456 | #'box 457 | 458 | #'analyze-host-expr 459 | #'validate-loop-locals 460 | #'validate 461 | #'infer-tag 462 | 463 | #'classify-invoke}) 464 | 465 | (def scheduled-default-passes 466 | (schedule default-passes)) 467 | 468 | (defn ^:dynamic run-passes 469 | "Function that will be invoked on the AST tree immediately after it has been constructed, 470 | by default runs the passes declared in #'default-passes, should be rebound if a different 471 | set of passes is required. 472 | 473 | Use #'clojure.tools.analyzer.passes/schedule to get a function from a set of passes that 474 | run-passes can be bound to." 475 | [ast] 476 | (scheduled-default-passes ast)) 477 | 478 | (def default-passes-opts 479 | "Default :passes-opts for `analyze`" 480 | {:collect/what #{:constants :callsites} 481 | :collect/where #{:deftype :reify :fn} 482 | :collect/top-level? false 483 | :collect-closed-overs/where #{:deftype :reify :fn :loop :try} 484 | :collect-closed-overs/top-level? false}) 485 | 486 | (defn analyze 487 | "Analyzes a clojure form using tools.analyzer augmented with the JVM specific special ops 488 | and returns its AST, after running #'run-passes on it. 489 | 490 | If no configuration option is provides, analyze will setup tools.analyzer using the extension 491 | points declared in this namespace. 492 | 493 | If provided, opts should be a map of options to analyze, currently the only valid 494 | options are :bindings and :passes-opts (if not provided, :passes-opts defaults to the 495 | value of `default-passes-opts`). 496 | If provided, :bindings should be a map of Var->value pairs that will be merged into the 497 | default bindings for tools.analyzer, useful to provide custom extension points. 498 | If provided, :passes-opts should be a map of pass-name-kw->pass-config-map pairs that 499 | can be used to configure the behaviour of each pass. 500 | 501 | E.g. 502 | (analyze form env {:bindings {#'ana/macroexpand-1 my-mexpand-1}})" 503 | ([form] (analyze form (empty-env) {})) 504 | ([form env] (analyze form env {})) 505 | ([form env opts] 506 | (with-bindings (merge {Compiler/LOADER (RT/makeClassLoader) 507 | #'ana/macroexpand-1 macroexpand-1 508 | #'ana/create-var create-var 509 | #'ana/parse parse 510 | #'ana/var? var? 511 | #'elides (merge {:fn #{:line :column :end-line :end-column :file :source} 512 | :reify #{:line :column :end-line :end-column :file :source}} 513 | elides) 514 | #'*ns* (the-ns (:ns env))} 515 | (:bindings opts)) 516 | (env/ensure (global-env) 517 | (doto (env/with-env (mmerge (env/deref-env) 518 | {:passes-opts (get opts :passes-opts default-passes-opts)}) 519 | (run-passes (-analyze form env))) 520 | (do (update-ns-map!))))))) 521 | 522 | (deftype ExceptionThrown [e ast]) 523 | 524 | (defn ^:private throw! [e] 525 | (throw (.e ^ExceptionThrown e))) 526 | 527 | (defn analyze+eval 528 | "Like analyze but evals the form after the analysis and attaches the 529 | returned value in the :result field of the AST node. 530 | 531 | If evaluating the form will cause an exception to be thrown, the exception 532 | will be caught and wrapped in an ExceptionThrown object, containing the 533 | exception in the `e` field and the AST in the `ast` field. 534 | 535 | The ExceptionThrown object is then passed to `handle-evaluation-exception`, 536 | which by defaults throws the original exception, but can be used to provide 537 | a replacement return value for the evaluation of the AST. 538 | 539 | Unrolls `do` forms to handle the Gilardi scenario. 540 | 541 | Useful when analyzing whole files/namespaces." 542 | ([form] (analyze+eval form (empty-env) {})) 543 | ([form env] (analyze+eval form env {})) 544 | ([form env {:keys [handle-evaluation-exception] 545 | :or {handle-evaluation-exception throw!} 546 | :as opts}] 547 | (env/ensure (global-env) 548 | (update-ns-map!) 549 | (let [env (merge env (-source-info form env)) 550 | [mform raw-forms] (with-bindings {Compiler/LOADER (RT/makeClassLoader) 551 | #'*ns* (the-ns (:ns env)) 552 | #'ana/macroexpand-1 (get-in opts [:bindings #'ana/macroexpand-1] macroexpand-1)} 553 | (loop [form form raw-forms []] 554 | (let [mform (ana/macroexpand-1 form env)] 555 | (if (= mform form) 556 | [mform (seq raw-forms)] 557 | (recur mform (conj raw-forms 558 | (if-let [[op & r] (and (seq? form) form)] 559 | (if (or (u/macro? op env) 560 | (u/inline? op r env)) 561 | (vary-meta form assoc ::ana/resolved-op (resolve-sym op env)) 562 | form) 563 | form)))))))] 564 | (if (and (seq? mform) (= 'do (first mform)) (next mform)) 565 | ;; handle the Gilardi scenario 566 | (let [[statements ret] (butlast+last (rest mform)) 567 | statements-expr (mapv (fn [s] (analyze+eval s (-> env 568 | (ctx :ctx/statement) 569 | (assoc :ns (ns-name *ns*))) 570 | opts)) 571 | statements) 572 | ret-expr (analyze+eval ret (assoc env :ns (ns-name *ns*)) opts)] 573 | {:op :do 574 | :top-level true 575 | :form mform 576 | :statements statements-expr 577 | :ret ret-expr 578 | :children [:statements :ret] 579 | :env env 580 | :result (:result ret-expr) 581 | :raw-forms raw-forms}) 582 | (let [a (analyze mform env opts) 583 | frm (emit-form a) 584 | result (try (eval frm) ;; eval the emitted form rather than directly the form to avoid double macroexpansion 585 | (catch Exception e 586 | (handle-evaluation-exception (ExceptionThrown. e a))))] 587 | (merge a {:result result 588 | :raw-forms raw-forms}))))))) 589 | 590 | (defn analyze-ns 591 | "Analyzes a whole namespace, returns a vector of the ASTs for all the 592 | top-level ASTs of that namespace. 593 | Evaluates all the forms." 594 | ([ns] (analyze-ns ns (empty-env))) 595 | ([ns env] (analyze-ns ns env {})) 596 | ([ns env opts] 597 | (env/ensure (global-env) 598 | (let [res ^URL (ns-url ns)] 599 | (assert res (str "Can't find " ns " in classpath")) 600 | (let [filename (str res) 601 | path (.getPath res)] 602 | (when-not (get-in (env/deref-env) [::analyzed-clj path]) 603 | (binding [*ns* *ns* 604 | *file* filename] 605 | (with-open [rdr (io/reader res)] 606 | (let [pbr (readers/indexing-push-back-reader 607 | (java.io.PushbackReader. rdr) 1 filename) 608 | eof (Object.) 609 | read-opts {:eof eof :features #{:clj :t.a.jvm}} 610 | read-opts (if (.endsWith filename "cljc") 611 | (assoc read-opts :read-cond :allow) 612 | read-opts)] 613 | (loop [] 614 | (let [form (reader/read read-opts pbr)] 615 | (when-not (identical? form eof) 616 | (swap! *env* update-in [::analyzed-clj path] 617 | (fnil conj []) 618 | (analyze+eval form (assoc env :ns (ns-name *ns*)) opts)) 619 | (recur)))))))) 620 | (get-in @*env* [::analyzed-clj path])))))) 621 | 622 | (defn macroexpand-all 623 | "Like clojure.walk/macroexpand-all but correctly handles lexical scope" 624 | ([form] (macroexpand-all form (empty-env) {})) 625 | ([form env] (macroexpand-all form env {})) 626 | ([form env opts] 627 | (binding [run-passes emit-form] 628 | (analyze form env opts)))) 629 | --------------------------------------------------------------------------------