├── doc └── intro.md ├── .gitignore ├── test └── clojure │ └── tools │ └── analyzer │ └── test.clj ├── src └── clojure │ └── tools │ ├── analyzer │ ├── util.clj │ ├── examples │ │ ├── dynvars.clj │ │ ├── nsforms.clj │ │ ├── privatevars.clj │ │ ├── docstring.clj │ │ ├── side_effect.clj │ │ ├── reflection.clj │ │ ├── load_core.clj │ │ └── tail_recursion.clj │ ├── fold.clj │ ├── emit_form.clj │ └── hygienic.clj │ └── analyzer.clj ├── project.clj └── README.md /doc/intro.md: -------------------------------------------------------------------------------- 1 | # Introduction to clr.tools.analyzer 2 | 3 | TODO: write [great documentation](http://jacobian.org/writing/great-documentation/what-to-write/) -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | /target 2 | /lib 3 | /classes 4 | /checkouts 5 | pom.xml 6 | *.jar 7 | *.class 8 | *.dll 9 | *.pdb 10 | *.exe 11 | .lein-deps-sum 12 | .lein-failures 13 | .lein-plugins -------------------------------------------------------------------------------- /test/clojure/tools/analyzer/test.clj: -------------------------------------------------------------------------------- 1 | (ns clojure.tools.analyzer.test 2 | (:require [clojure.test :refer :all] 3 | [clojure.tools.analyzer :refer :all])) 4 | 5 | (deftest a-test 6 | (testing "FIXME, I fail." 7 | (is (= 0 1)))) 8 | -------------------------------------------------------------------------------- /src/clojure/tools/analyzer/util.clj: -------------------------------------------------------------------------------- 1 | (ns clojure.tools.analyzer.util 2 | (:require [clojure.pprint :as pp])) 3 | 4 | (defn- dissoc-rec 5 | "Return expr with the keys dissociated" 6 | [obj & keys] 7 | (cond 8 | (map? obj) (into {} (for [[key val] (apply dissoc obj keys)] 9 | [key (apply dissoc-rec val keys)])) 10 | (sequential? obj) (map #(apply dissoc-rec % keys) obj) 11 | :else obj)) 12 | 13 | (defn print-expr 14 | "Pretty-prints expr, excluding supplied keys. 15 | Example: (print-expr expr :children :env)" 16 | [expr & exclusions] 17 | (pp/pprint (apply dissoc-rec expr exclusions))) 18 | 19 | (defn expr-seq 20 | "Given an expression, returns a lazy sequence of the expressions 21 | followed by its children (in a depth first manner)" 22 | [expr] 23 | (tree-seq :children 24 | :children 25 | expr)) 26 | 27 | (comment 28 | (use 'analyze.core) 29 | (print-expr 30 | (analyze-one {:ns {:name 'clojure.core} :context :eval} 31 | '(defn a 32 | ([^bytes b] ^Integer b) 33 | ([b c] c))) 34 | :children :Expr-obj :ObjMethod-obj :LocalBinding-obj :env :BindingInit-obj) 35 | ) 36 | -------------------------------------------------------------------------------- /src/clojure/tools/analyzer/examples/dynvars.clj: -------------------------------------------------------------------------------- 1 | (ns clojure.tools.analyzer.examples.dynvars 2 | (:require [clojure.tools.analyzer :as analyze])) 3 | 4 | (defn earmuffed? [sym] 5 | (let [s (name sym)] 6 | (and (< 2 (count s)) 7 | (.startsWith s "*") 8 | (.endsWith s "*")))) 9 | 10 | (defn check-def [expr] 11 | (let [v (:var expr) 12 | s (.sym v)] 13 | (when (and (earmuffed? s) 14 | (not (:is-dynamic expr))) 15 | (println "WARNING: Should" v "be marked dynamic?")))) 16 | 17 | (defn find-and-check-defs [expr] 18 | (when (= :def (:op expr)) 19 | (check-def expr)) 20 | (doseq [child-expr (:children expr)] 21 | (find-and-check-defs child-expr))) 22 | 23 | (comment 24 | 25 | (do 26 | (reset! analyze/CHILDREN true) 27 | 28 | (find-and-check-defs 29 | (analyze/analyze-one {:ns {:name 'user} :context :eval} 30 | '(def *a* 1)))) 31 | 32 | (def analyzed 33 | (doall (map analyze/analyze-ns 34 | '[clojure.test 35 | clojure.set 36 | clojure.java.io 37 | clojure.stacktrace 38 | clojure.pprint 39 | clojure.walk 40 | clojure.string 41 | clojure.repl 42 | clojure.core.protocols 43 | clojure.template]))) 44 | 45 | (doseq [exprs analyzed 46 | exp exprs] 47 | (find-and-check-defs exp)) 48 | ) 49 | -------------------------------------------------------------------------------- /src/clojure/tools/analyzer/examples/nsforms.clj: -------------------------------------------------------------------------------- 1 | (ns clojure.tools.analyzer.examples.nsforms 2 | (:require [clojure.tools.analyzer :as analyze])) 3 | 4 | (defn warn-on-naked-use [use-expr] 5 | (doseq [s (map :val (:args use-expr)) 6 | :when (symbol? s)] 7 | (println "Warning: Naked use of" (name s) "in" (-> use-expr :env :ns :name)))) 8 | 9 | (defn use? [expr] 10 | (and (= :invoke (:op expr)) 11 | (= :var (-> expr :fexpr :op)) 12 | (= 'use (-> expr :fexpr :var meta :name)))) 13 | 14 | (defn find-and-analyze-use-forms [expr] 15 | (when (use? expr) 16 | (warn-on-naked-use expr)) 17 | (doseq [child-expr (:children expr)] 18 | (find-and-analyze-use-forms child-expr))) 19 | 20 | (comment 21 | 22 | (reset! analyze/CHILDREN true) 23 | 24 | (find-and-analyze-use-forms 25 | (analyze/ast 26 | (ns sjfis (:use [clojure.set :only [union]] 27 | clojure.repl)))) 28 | 29 | 30 | (def analyzed 31 | (doall (map analyze/analyze-ns 32 | '[clojure.test 33 | clojure.set 34 | clojure.java.io 35 | clojure.stacktrace 36 | clojure.pprint 37 | clojure.walk 38 | clojure.string 39 | clojure.repl 40 | clojure.core.protocols 41 | clojure.template]))) 42 | 43 | (doseq [exprs analyzed 44 | exp exprs] 45 | (find-and-analyze-use-forms exp)) 46 | ) 47 | -------------------------------------------------------------------------------- /src/clojure/tools/analyzer/examples/privatevars.clj: -------------------------------------------------------------------------------- 1 | (ns clojure.tools.analyzer.examples.privatevars 2 | (:require [clojure.tools.analyzer :as analyze] 3 | [clojure.set :as set] 4 | [clojure.pprint :as pp])) 5 | 6 | (defn- unused-fn [] nil) 7 | (def ^:private unused-var 0) 8 | 9 | (defn defs [expr] 10 | (apply concat 11 | (when (= :def (:op expr)) [(:var expr)]) 12 | (map defs (:children expr)))) 13 | 14 | (defn private-defs [expr] 15 | (filter #(:private (meta %)) 16 | (defs expr))) 17 | 18 | (defn var-count [expr] 19 | (if (= :var (:op expr)) 20 | {(:var expr) 1} 21 | (apply merge-with + 22 | (map var-count (:children expr))))) 23 | 24 | (defn check-usage-of-private-vars [exprs] 25 | (let [v-count (apply merge-with + (map var-count exprs))] 26 | (doseq [pvar (mapcat private-defs exprs)] 27 | (when-not (get v-count pvar) 28 | (println "Private variable" pvar "is never used"))))) 29 | 30 | (comment 31 | (def analyzed 32 | (doall 33 | (map analyze/analyze-ns 34 | '[clojure.test 35 | clojure.set 36 | clojure.java.io 37 | clojure.stacktrace 38 | clojure.pprint 39 | clojure.walk 40 | clojure.string 41 | clojure.repl 42 | clojure.core.protocols 43 | clojure.template 44 | clojure.clr.tools.analyzer.examples.privatevars]))) 45 | 46 | (doseq [exprs analyzed] 47 | (check-usage-of-private-vars exprs)) 48 | ) 49 | -------------------------------------------------------------------------------- /project.clj: -------------------------------------------------------------------------------- 1 | (defproject clr.tools.analyzer "0.1.0-SNAPSHOT" 2 | :description "FIXME: write description" 3 | :url "http://example.com/FIXME" 4 | :license {:name "Eclipse Public License" 5 | :url "http://www.eclipse.org/legal/epl-v10.html"} 6 | :dependencies [] 7 | :min-lein-version "2.0.0" 8 | :plugins [[lein-clr "0.2.0"]] 9 | :clr {:cmd-templates {:clj-exe [#_"mono" [CLJCLR14_40 %1]] 10 | :clj-dep ["mono" ["target/clr/clj/Debug 4.0" %1]] 11 | :clj-url "https://github.com/downloads/clojure/clojure-clr/clojure-clr-1.4.1-Debug-4.0.zip" 12 | :clj-zip "clojure-clr-1.4.1-Debug-4.0.zip" 13 | :curl ["curl" "--insecure" "-f" "-L" "-o" %1 %2] 14 | :nuget-ver [#_"mono" [*PATH "nuget.exe"] "install" %1 "-Version" %2] 15 | :nuget-any [#_"mono" [*PATH "nuget.exe"] "install" %1] 16 | :unzip ["unzip" "-d" %1 %2] 17 | :wget ["wget" "--no-check-certificate" "--no-clobber" "-O" %1 %2]} 18 | ;; for automatic download/unzip of ClojureCLR, 19 | ;; 1. make sure you have curl or wget installed and on PATH, 20 | ;; 2. uncomment deps in :deps-cmds, and 21 | ;; 3. use :clj-dep instead of :clj-exe in :main-cmd and :compile-cmd 22 | :deps-cmds [ [:wget :clj-zip :clj-url] ; edit to use :curl instead of :wget 23 | [:unzip "../clj" :clj-zip] 24 | ] 25 | :main-cmd [:clj-dep "Clojure.Main.exe"] 26 | :compile-cmd [:clj-dep "Clojure.Compile.exe"]}) 27 | -------------------------------------------------------------------------------- /src/clojure/tools/analyzer/examples/docstring.clj: -------------------------------------------------------------------------------- 1 | (ns clojure.tools.analyzer.examples.docstring 2 | "Warns on suspected misplaced docstrings in function definitions. 3 | Entry point `find-and-check-defs`" 4 | (:require [clojure.tools.analyzer :as analyze])) 5 | 6 | (defn check-def [exp] 7 | (when (= :fn-expr (-> exp :init :op)) 8 | (doseq [method (-> exp :init :methods)] 9 | (let [body (:body method)] 10 | (when (and (= :do (:op body)) 11 | (< 1 (count (-> body :exprs)))) 12 | (let [first-exp (-> body :exprs first)] 13 | (when (= :string (:op first-exp)) 14 | (binding [*out* *err*] 15 | (println "WARNING: Suspicious string, possibly misplaced docstring," (-> exp :var)))))))))) 16 | 17 | (defn find-and-check-defs [exp] 18 | (when (= :def (:op exp)) 19 | (check-def exp)) 20 | (doseq [child-exp (:children exp)] 21 | (find-and-check-defs child-exp))) 22 | 23 | ;; Examples 24 | 25 | ;; Check a good chunk of the core library 26 | 27 | (comment 28 | (def analyzed 29 | (doall (map analyze/analyze-ns 30 | '[clojure.test 31 | clojure.set 32 | clojure.java.io 33 | clojure.stacktrace 34 | clojure.pprint 35 | clojure.walk 36 | clojure.string 37 | clojure.repl 38 | clojure.core.protocols 39 | clojure.template]))) 40 | 41 | (doseq [exprs analyzed 42 | exp exprs] 43 | (find-and-check-defs exp)) 44 | 45 | ;; One form at a time 46 | 47 | (do 48 | (reset! analyze/CHILDREN true) 49 | (find-and-check-defs 50 | (analyze/analyze-one {:ns {:name 'clojure.repl} :context :eval} 51 | '(defn a [] 52 | "asdf" 53 | (+ 1 1))))) 54 | ) 55 | -------------------------------------------------------------------------------- /src/clojure/tools/analyzer/examples/side_effect.clj: -------------------------------------------------------------------------------- 1 | (ns clojure.tools.analyzer.examples.side-effect 2 | "Warns on invocations of `set!` inside transactions. 3 | Entry point `forbid-side-effects-in-transaction`" 4 | (:require [clojure.tools.analyzer :as analyze] 5 | [clojure.reflect :as reflect])) 6 | 7 | (def transaction-method 8 | "dosync reduces to a call to this method" 9 | (let [membrs (-> (reflect/reflect clojure.lang.LockingTransaction) :members)] 10 | (first (filter #(= 'runInTransaction (:name %)) membrs)))) 11 | 12 | (defn warn-on-side-effect [exp] 13 | (when (= :set! (:op exp)) 14 | (binding [*out* *err*] 15 | (println "WARNING: Side effect in transaction"))) 16 | (doseq [child-exp (:children exp)] 17 | (warn-on-side-effect child-exp))) 18 | 19 | (defn forbid-side-effects-in-transaction [exp] 20 | (when (and (= :static-method (:op exp)) 21 | (= transaction-method (:method exp))) 22 | (warn-on-side-effect (first (:args exp)))) 23 | (doseq [child-exp (:children exp)] 24 | (forbid-side-effects-in-transaction child-exp))) 25 | 26 | ;; Examples 27 | 28 | ;; Check a chunk of the core library 29 | 30 | (comment 31 | (def analyzed 32 | (doall (map analyze/analyze-ns 33 | '[clojure.test 34 | clojure.set 35 | clojure.java.io 36 | clojure.stacktrace 37 | clojure.pprint 38 | clojure.walk 39 | clojure.string 40 | clojure.repl 41 | clojure.core.protocols 42 | clojure.template]))) 43 | 44 | (doseq [exprs analyzed 45 | exp exprs] 46 | (forbid-side-effects-in-transaction exp)) 47 | 48 | ;; Check individual form 49 | 50 | (do 51 | (reset! analyze/CHILDREN true) 52 | (forbid-side-effects-in-transaction 53 | (analyze/analyze-one '{:ns {:name clojure.core} :context :eval} 54 | '(dosync 55 | (do 56 | (fn [] (set! *ns* 'ww)) ; TODO need context information from compiler, or to find it 57 | (set! *ns* 'ss) 58 | (set! *ns* 'blah)))))) 59 | ) 60 | -------------------------------------------------------------------------------- /src/clojure/tools/analyzer/examples/reflection.clj: -------------------------------------------------------------------------------- 1 | (set! *warn-on-reflection* false) 2 | 3 | (ns clojure.tools.analyzer.examples.reflection 4 | "Same as *warn-on-reflection*" 5 | (:require [clojure.tools.analyzer :as analyze])) 6 | 7 | (defn check-new [exp] 8 | (when (not (:ctor exp)) 9 | (println "WARNING: Unresolved constructor" (:class exp) (-> exp :env :ns :name)))) 10 | 11 | (defn check-static-method [exp] 12 | (when (not (:method exp)) 13 | (println "WARNING: Unresolved static method" (:method-name exp) (:class exp) (-> exp :env :ns :name)))) 14 | 15 | (defn check-instance-method [exp] 16 | (when (not (:method exp)) 17 | (println "WARNING: Unresolved instance method" (:method-name exp) (:class exp) (-> exp :env :ns :name)))) 18 | 19 | (defn check-static-field [exp] 20 | (when (not (:field exp)) 21 | (println "WARNING: Unresolved static field" (:field-name exp) (:class exp) (-> exp :env :ns :name)))) 22 | 23 | (defn check-instance-field [exp] 24 | (when (not (:field exp)) 25 | (println "WARNING: Unresolved instance field" (:field-name exp) (:class exp) (-> exp :env :ns :name)))) 26 | 27 | 28 | (defn check-for-reflection [exp] 29 | (condp = (:op exp) 30 | :new (check-new exp) 31 | :static-method (check-static-method exp) 32 | :instance-method (check-instance-method exp) 33 | :static-field (check-static-field exp) 34 | :instance-field (check-instance-field exp) 35 | nil) 36 | 37 | (doseq [c (:children exp)] 38 | (check-for-reflection c))) 39 | 40 | (comment 41 | 42 | (reset! analyze/CHILDREN true) 43 | 44 | (def analyzed 45 | (doall (map analyze/analyze-ns 46 | '[clojure.test 47 | clojure.set 48 | clojure.java.io 49 | clojure.stacktrace 50 | clojure.pprint 51 | clojure.walk 52 | clojure.string 53 | clojure.repl 54 | clojure.core.protocols 55 | clojure.template]))) 56 | 57 | (doseq [exprs analyzed 58 | exp exprs] 59 | (check-for-reflection exp)) 60 | 61 | (analyze/analyze-one {:ns {:name 'clojure.core} :context :eval} '(Integer. (+ 1 1))) 62 | (analyze/analyze-one {:ns {:name 'clojure.core} :context :eval} '(Integer. (+ 1 1))) 63 | (analyze/analyze-one {:ns {:name 'clojure.core} :context :eval} '(Integer. (+ 1 (even? 1)))) 64 | ) 65 | -------------------------------------------------------------------------------- /src/clojure/tools/analyzer/examples/load_core.clj: -------------------------------------------------------------------------------- 1 | (ns clojure.tools.analyzer.examples.load-core 2 | (:import [clojure.lang Compiler RT DynamicClassLoader]) 3 | (:require [clojure.tools.analyzer :as analyze])) 4 | 5 | (comment 6 | 7 | ;; Reproducible problem, similar to the one we're having loading clojure.core 8 | 9 | (defmacro deftesteval 10 | [name args expr] 11 | `(do 12 | (fn ~name ~args ~expr) ;; not sure the minimum reproducible case, but having both these lines trigger it 13 | (fn ~name ~args ~expr))) 14 | 15 | ;; .. and evaling this first .. 16 | (deftesteval myfn [x] `(+ ~x)) 17 | 18 | ;; .. followed by analyzing the same form again, in this namespace .. 19 | (analyze/analyze-one '{:ns {:name analyze.examples.load-core} :context :eval} 20 | '(deftesteval myfn [x] `(+ ~x))) 21 | 22 | ;; results in ... 23 | 24 | ;CompilerException java.lang.LinkageError: loader (instance of clojure/lang/DynamicClassLoader): attempted duplicate class definition for name: "analyze/examples/load_core$myfn", compiling:(REPL:5) 25 | ; clojure.lang.Compiler.analyzeSeq (Compiler.java:6416) 26 | ; clojure.lang.Compiler.analyze (Compiler.java:6216) 27 | ; clojure.lang.Compiler.analyzeSeq (Compiler.java:6397) 28 | ; clojure.lang.Compiler.analyze (Compiler.java:6216) 29 | ; clojure.lang.Compiler.analyze (Compiler.java:6177) 30 | ; clojure.lang.Compiler$BodyExpr$Parser.parse (Compiler.java:5572) 31 | ; clojure.lang.Compiler.analyzeSeq (Compiler.java:6409) 32 | ; clojure.lang.Compiler.analyze (Compiler.java:6216) 33 | ; clojure.lang.Compiler.analyzeSeq (Compiler.java:6397) 34 | ; clojure.lang.Compiler.analyze (Compiler.java:6216) 35 | ; clojure.lang.Compiler.analyze (Compiler.java:6177) 36 | ; analyze.core/analyze*/invoke-analyze--770 (core.clj:565) 37 | ;Caused by: 38 | ;LinkageError loader (instance of clojure/lang/DynamicClassLoader): attempted duplicate class definition for name: "analyze/examples/load_core$myfn" 39 | ; java.lang.ClassLoader.defineClass1 (ClassLoader.java:-2) 40 | ; java.lang.ClassLoader.defineClassCond (ClassLoader.java:631) 41 | ; java.lang.ClassLoader.defineClass (ClassLoader.java:615) 42 | ; java.lang.ClassLoader.defineClass (ClassLoader.java:465) 43 | ; clojure.lang.DynamicClassLoader.defineClass (DynamicClassLoader.java:46) 44 | ; clojure.lang.Compiler$ObjExpr.getCompiledClass (Compiler.java:4533) 45 | ; clojure.lang.Compiler$FnExpr.parse (Compiler.java:3697) 46 | ; clojure.lang.Compiler.analyzeSeq (Compiler.java:6407) 47 | ; clojure.lang.Compiler.analyze (Compiler.java:6216) 48 | 49 | ;(def a (analyze/analyze-path "clojure/core.clj" 'clojure.core)) 50 | ) 51 | -------------------------------------------------------------------------------- /src/clojure/tools/analyzer/examples/tail_recursion.clj: -------------------------------------------------------------------------------- 1 | (ns clojure.tools.analyzer.examples.tail-recursion 2 | (:require [clojure.tools.analyzer :as analyze])) 3 | 4 | ;; ## Utility functions 5 | 6 | (defn- safe-mapcat 7 | "Like `mapcat`, but works if the returned values aren't sequences." 8 | [f & colls] 9 | (apply concat (map #(if (seq? %) % [%]) (apply map f colls)))) 10 | 11 | ;; ## Test for tail recursion 12 | 13 | (defn find-tail-ops 14 | "Returns a list of the function calls that are in tail position." 15 | [tree] 16 | (case (:op tree) 17 | :def (safe-mapcat find-tail-ops (rest (:children tree))) 18 | :do (recur (last (:children tree))) 19 | :fn-expr (safe-mapcat find-tail-ops (:methods tree)) 20 | :fn-method (recur (:body tree)) 21 | 22 | :invoke 23 | (or (-> tree :fexpr :local-binding :sym) 24 | (-> tree :fexpr :var)) 25 | 26 | :let (recur (:body tree)) 27 | :if (map find-tail-ops [(:then tree) (:else tree)]) 28 | nil)) 29 | 30 | (defn tail-recursive? 31 | "Returns `true` if there is a call to the function being defined 32 | in a tail position. This does not necessarily mean that the tail call 33 | can be replaced with `recur`, since that does not work with functions of 34 | different arity, or across `try`." 35 | [fn-tree] 36 | (let [fn-name (or (-> fn-tree :name) (-> fn-tree :var)) 37 | tail-ops (find-tail-ops fn-tree)] 38 | (boolean (when fn-name (some (partial = fn-name) tail-ops))))) 39 | 40 | (comment 41 | (reset! analyze/CHILDREN true) 42 | 43 | (def analyzed 44 | (doall (map analyze/analyze-ns 45 | '[clojure.test 46 | clojure.set 47 | clojure.java.io 48 | clojure.stacktrace 49 | clojure.pprint 50 | clojure.walk 51 | clojure.string 52 | clojure.repl 53 | clojure.core.protocols 54 | clojure.template]))) 55 | 56 | (doseq [exprs analyzed 57 | exp (filter (comp #{:def :fn-expr} :op) exprs)] 58 | (if (tail-recursive? exp) 59 | (println "WARNING: possible tail recursive function not using recur" 60 | (or (-> exp :name) 61 | (-> exp :var))))) 62 | 63 | (require 'clojure.pprint) 64 | (tail-recursive? 65 | (analyze/analyze-one {:ns {:name 'clojure.repl} :context :eval} 66 | '(def foo (list)))) 67 | (tail-recursive? 68 | (analyze/analyze-one {:ns {:name 'clojure.repl} :context :eval} 69 | '(defn foo [x] 70 | (if (< x 10) 71 | (foo (inc x)) 72 | x)))) 73 | 74 | (tail-recursive? 75 | (analyze/analyze-one {:ns {:name 'clojure.test} :context :eval} 76 | '(defn testing-vars-str 77 | "Returns a string representation of the current test. Renders names 78 | in *testing-vars* as a list, then the source file and line of 79 | current assertion." 80 | {:added "1.1"} 81 | [m] 82 | (let [{:keys [file line]} m] 83 | (str 84 | ;; Uncomment to include namespace in failure report: 85 | ;;(ns-name (:ns (meta (first *testing-vars*)))) "/ " 86 | (reverse (map #(:name (meta %)) *testing-vars*)) 87 | " (" file ":" line ")")))) 88 | ) 89 | 90 | 91 | ) 92 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # Interface to ClojureCLR's Analyzer 2 | 3 | ClojureCLR's analysis compilation phase holds rich information about Clojure forms, like type/reflection information. 4 | 5 | _analyze_ provides an interface to this phase, callable a la carte. The output is similar to ClojureScript's analyzer. 6 | 7 | Supports ClojureCLR 1.4.1 or later. 8 | 9 | # Contributing 10 | 11 | Pull requests accepted from registered Clojure contributers 12 | 13 | http://clojure.org/contributing 14 | 15 | # Usage 16 | 17 | ## Generating AST from syntax 18 | 19 | ```clojure 20 | 21 | clojure.clr.tools.analyzer=> (ast [1]) 22 | {:op :constant, :env {:locals {}, :ns {:name clojure.clr.tools.analyzer}}, :val [1]} 23 | 24 | clojure.clr.tools.analyzer=> (-> (ast (if true 1 2)) clojure.pprint/pprint) 25 | {:op :if, 26 | :env {:locals {}, :ns {:name clojure.clr.tools.analyzer}}, 27 | :test 28 | {:op :boolean, 29 | :env {:locals {}, :ns {:name clojure.clr.tools.analyzer}}, 30 | :val true}, 31 | :then 32 | {:op :number, 33 | :env {:locals {}, :ns {:name clojure.clr.tools.analyzer}}, 34 | :val 1}, 35 | :else 36 | {:op :number, 37 | :env {:locals {}, :ns {:name clojure.clr.tools.analyzer}}, 38 | :val 2}} 39 | nil 40 | 41 | clojure.clr.tools.analyzer=> (-> (ast (fn [x] (+ x 1))) clojure.pprint/pprint) 42 | {:op :meta, 43 | :env {:locals {}, :ns {:name clojure.clr.tools.analyzer}}, 44 | :meta 45 | {:op :map, 46 | :env {:locals {}, :ns {:name clojure.clr.tools.analyzer}}, 47 | :keyvals 48 | ({:op :keyword, 49 | :env {:locals {}, :ns {:name clojure.clr.tools.analyzer}}, 50 | :val :source-span} 51 | {:op :map, 52 | :env {:locals {}, :ns {:name clojure.clr.tools.analyzer}}, 53 | :keyvals 54 | ({:op :keyword, 55 | :env {:locals {}, :ns {:name clojure.clr.tools.analyzer}}, 56 | :val :start-line} 57 | {:op :number, 58 | :env {:locals {}, :ns {:name clojure.clr.tools.analyzer}}, 59 | :val 12} 60 | {:op :keyword, 61 | :env {:locals {}, :ns {:name clojure.clr.tools.analyzer}}, 62 | :val :start-column} 63 | {:op :number, 64 | :env {:locals {}, :ns {:name clojure.clr.tools.analyzer}}, 65 | :val 10} 66 | {:op :keyword, 67 | :env {:locals {}, :ns {:name clojure.clr.tools.analyzer}}, 68 | :val :end-line} 69 | {:op :number, 70 | :env {:locals {}, :ns {:name clojure.clr.tools.analyzer}}, 71 | :val 12} 72 | {:op :keyword, 73 | :env {:locals {}, :ns {:name clojure.clr.tools.analyzer}}, 74 | :val :end-column} 75 | {:op :number, 76 | :env {:locals {}, :ns {:name clojure.clr.tools.analyzer}}, 77 | :val 25})})}, 78 | :expr 79 | {:name clojure.clr.tools.analyzer$fn__3171, 80 | :op :fn-expr, 81 | :env {:locals {}, :ns {:name clojure.clr.tools.analyzer}}, 82 | :methods 83 | ({:op :fn-method, 84 | :env {:locals {}, :ns {:name clojure.clr.tools.analyzer}}, 85 | :body 86 | {:op :do, 87 | :env {:locals {}, :ns {:name clojure.clr.tools.analyzer}}, 88 | :exprs 89 | ({:op :static-method, 90 | :env {:locals {}, :ns {:name clojure.clr.tools.analyzer}}, 91 | :class clojure.lang.Numbers, 92 | :method 93 | {:name add, 94 | :return-type System.Object, 95 | :declaring-class clojure.lang.Numbers, 96 | :parameter-types [System.Object System.Int64], 97 | :flags #{:hide-by-sig :reuse-slot :static :public}}, 98 | :args 99 | ({:op :host-arg, 100 | :env {:locals {}, :ns {:name clojure.clr.tools.analyzer}}, 101 | :expr 102 | {:op :local-binding-expr, 103 | :env {:locals {}, :ns {:name clojure.clr.tools.analyzer}}, 104 | :local-binding 105 | {:op :local-binding, 106 | :env {:locals {}, :ns {:name clojure.clr.tools.analyzer}}, 107 | :sym x, 108 | :tag nil, 109 | :init nil}, 110 | :tag nil}} 111 | {:op :host-arg, 112 | :env {:locals {}, :ns {:name clojure.clr.tools.analyzer}}, 113 | :expr 114 | {:op :number, 115 | :env {:locals {}, :ns {:name clojure.clr.tools.analyzer}}, 116 | :val 1}}), 117 | :tag nil})}, 118 | :required-params 119 | ({:op :local-binding, 120 | :env {:locals {}, :ns {:name clojure.clr.tools.analyzer}}, 121 | :sym x, 122 | :tag nil, 123 | :init nil}), 124 | :rest-param nil}), 125 | :variadic-method nil, 126 | :tag nil}} 127 | nil 128 | ``` 129 | 130 | ## Syntax from AST 131 | 132 | 133 | ```clojure 134 | clojure.jvm.tools.analyzer=> (require '[clojure.jvm.tools.analyzer.emit-form :as e]) 135 | nil 136 | clojure.jvm.tools.analyzer=> (-> (ast 1) e/emit-form) 137 | 1 138 | clojure.jvm.tools.analyzer=> (-> (ast [(+ 1 2)]) e/emit-form) 139 | [(clojure.lang.Numbers/add 1 2)] 140 | ``` 141 | 142 | # Known Issues 143 | 144 | ## Evaluating forms 145 | 146 | Currently the analyzer evaluates each form after it is analyzed. 147 | 148 | ## Incorrect handling of Var mappings within the same form 149 | 150 | `analyze` is a thin wrapper over `clojure.lang.Compiler`, so to get our 151 | hands on analysis results some compromises are made. 152 | 153 | The following form normally evaluates to the Var `clojure.set/intersection`, but 154 | analyses to `clojure.core/require`. 155 | 156 | 157 | ```clojure 158 | ;normal evaluation 159 | (eval 160 | '(do 161 | (require '[clojure.set]) 162 | (refer 'clojure.set 163 | :only '[intersection] 164 | :rename '{intersection require}) 165 | require)) 166 | ;=> #'clojure.set/intersection 167 | 168 | ;analysis result 169 | (-> (ast 170 | (do (require '[clojure.set]) 171 | (refer 'clojure.set 172 | :only '[intersection] 173 | :rename '{intersection require}) 174 | require)) 175 | :exprs last :var) 176 | ;=> #'clojure.core/require 177 | ``` 178 | 179 | # Todo 180 | 181 | - analyze a leiningen `project.clj` file 182 | - analyze `clojure.core` 183 | - use :locals if necessary 184 | 185 | # Examples 186 | 187 | See `clojure.jvm.tools.analyzer.examples.*` namespaces. 188 | 189 | # Contributors 190 | 191 | - Jonas Enlund (jonase) 192 | - Nicola Mometto (Bronsa) 193 | - Chris Gray (chrismgray) 194 | -------------------------------------------------------------------------------- /src/clojure/tools/analyzer/fold.clj: -------------------------------------------------------------------------------- 1 | (ns clojure.tools.analyzer.fold) 2 | 3 | (def fold-expr-default ::fold-expr) 4 | 5 | (defn derive-default-fold [tag] 6 | (derive tag fold-expr-default)) 7 | 8 | (defmulti fold-expr (fn [mode options expr] 9 | [mode (:op expr)])) 10 | 11 | (defmacro add-fold-case [mode op fld-fn] 12 | `(defmethod fold-expr [~mode ~op] 13 | [mode# options# expr#] 14 | (let [~'[expr-rec] 15 | (map #(or (% options#) 16 | (partial fold-expr mode# options#)) 17 | [:expr-rec]) 18 | ~'map-expr-rec #(if % (map ~'expr-rec %) %) 19 | ~'if-expr-rec #(if % (~'expr-rec %) %) 20 | fld-fn# ~fld-fn] 21 | (fld-fn# expr# options#)))) 22 | 23 | (defmacro add-default-fold-case [ty fld-fn] 24 | `(add-fold-case fold-expr-default ~ty ~fld-fn)) 25 | 26 | (defn return-first [a & _] a) 27 | 28 | (add-default-fold-case :keyword return-first) 29 | (add-default-fold-case :constant return-first) 30 | (add-default-fold-case :number return-first) 31 | (add-default-fold-case :string return-first) 32 | (add-default-fold-case :nil return-first) 33 | (add-default-fold-case :boolean return-first) 34 | 35 | (add-default-fold-case :def 36 | (fn [expr _] 37 | (-> expr 38 | (update-in [:init] if-expr-rec)))) 39 | 40 | (add-default-fold-case :local-binding 41 | (fn [expr _] 42 | (-> expr 43 | (update-in [:init] if-expr-rec)))) 44 | 45 | (add-default-fold-case :binding-init 46 | (fn [expr _] 47 | (-> expr 48 | (update-in [:init] expr-rec)))) 49 | 50 | (add-default-fold-case :let 51 | (fn [expr _] 52 | (-> expr 53 | (update-in [:binding-inits] map-expr-rec) 54 | (update-in [:body] expr-rec)))) 55 | 56 | (add-default-fold-case :letfn 57 | (fn [expr _] 58 | (-> expr 59 | (update-in [:binding-inits] map-expr-rec) 60 | (update-in [:body] expr-rec)))) 61 | 62 | (add-default-fold-case :local-binding-expr 63 | (fn [expr _] 64 | (-> expr 65 | (update-in [:local-binding] expr-rec)))) 66 | 67 | (add-default-fold-case :static-method 68 | (fn [expr _] 69 | (-> expr 70 | (update-in [:args] map-expr-rec)))) 71 | 72 | (add-default-fold-case :instance-method 73 | (fn [expr _] 74 | (-> expr 75 | (update-in [:target] expr-rec) 76 | (update-in [:args] map-expr-rec)))) 77 | 78 | (add-default-fold-case :static-field return-first) 79 | 80 | (add-default-fold-case :instance-field 81 | (fn [expr _] 82 | (-> expr 83 | (update-in [:target] expr-rec)))) 84 | 85 | (add-default-fold-case :new 86 | (fn [expr _] 87 | (-> expr 88 | (update-in [:args] map-expr-rec)))) 89 | 90 | (add-default-fold-case :empty-expr return-first) 91 | 92 | (add-default-fold-case :set 93 | (fn [expr _] 94 | (-> expr 95 | (update-in [:keys] map-expr-rec)))) 96 | 97 | (add-default-fold-case :vector 98 | (fn [expr _] 99 | (-> expr 100 | (update-in [:args] map-expr-rec)))) 101 | 102 | (add-default-fold-case :map 103 | (fn [expr _] 104 | (-> expr 105 | (update-in [:keyvals] map-expr-rec)))) 106 | 107 | (add-default-fold-case :monitor-enter 108 | (fn [expr _] 109 | (-> expr 110 | (update-in [:target] expr-rec)))) 111 | 112 | (add-default-fold-case :monitor-exit 113 | (fn [expr _] 114 | (-> expr 115 | (update-in [:target] expr-rec)))) 116 | 117 | (add-default-fold-case :throw 118 | (fn [expr _] 119 | (-> expr 120 | (update-in [:exception] expr-rec)))) 121 | 122 | (add-default-fold-case :invoke 123 | (fn [expr _] 124 | (-> expr 125 | (update-in [:fexpr] expr-rec) 126 | (update-in [:args] map-expr-rec)))) 127 | 128 | (add-default-fold-case :keyword-invoke 129 | (fn [expr _] 130 | (-> expr 131 | (update-in [:kw] expr-rec) 132 | (update-in [:target] expr-rec)))) 133 | 134 | (add-default-fold-case :the-var return-first) 135 | (add-default-fold-case :var return-first) 136 | (add-default-fold-case :unresolved-var return-first) 137 | (add-default-fold-case :obj-expr return-first) 138 | 139 | (add-default-fold-case :new-instance-method 140 | (fn [expr _] 141 | (-> expr 142 | (update-in [:body] expr-rec) 143 | (update-in [:required-params] map-expr-rec)))) 144 | 145 | (add-default-fold-case :fn-method 146 | (fn [expr _] 147 | (-> expr 148 | (update-in [:body] expr-rec) 149 | (update-in [:required-params] map-expr-rec) 150 | (update-in [:rest-param] if-expr-rec)))) 151 | 152 | (add-default-fold-case :fn-expr 153 | (fn [expr _] 154 | (-> expr 155 | (update-in [:methods] map-expr-rec) 156 | (update-in [:variadic-method] if-expr-rec)))) 157 | 158 | (add-default-fold-case :deftype* 159 | (fn [expr _] 160 | (-> expr 161 | (update-in [:methods] map-expr-rec)))) 162 | 163 | (add-default-fold-case :instance-of 164 | (fn [expr _] 165 | (-> expr 166 | (update-in [:the-expr] expr-rec)))) 167 | 168 | (add-default-fold-case :meta 169 | (fn [expr _] 170 | (-> expr 171 | (update-in [:meta] expr-rec) 172 | (update-in [:expr] expr-rec)))) 173 | 174 | (add-default-fold-case :do 175 | (fn [expr _] 176 | (-> expr 177 | (update-in [:exprs] map-expr-rec)))) 178 | 179 | (add-default-fold-case :if 180 | (fn [expr _] 181 | (-> expr 182 | (update-in [:test] expr-rec) 183 | (update-in [:then] expr-rec) 184 | (update-in [:else] expr-rec)))) 185 | 186 | (add-default-fold-case :case* 187 | (fn [expr _] 188 | (-> expr 189 | (update-in [:the-expr] expr-rec) 190 | (update-in [:tests] map-expr-rec) 191 | (update-in [:thens] map-expr-rec) 192 | (update-in [:default] expr-rec)))) 193 | 194 | (add-default-fold-case :import* return-first) 195 | 196 | (add-default-fold-case :set! 197 | (fn [expr _] 198 | (-> expr 199 | (update-in [:target] expr-rec) 200 | (update-in [:val] expr-rec)))) 201 | 202 | (add-default-fold-case :catch 203 | (fn [expr _] 204 | (-> expr 205 | (update-in [:local-binding] expr-rec) 206 | (update-in [:handler] expr-rec)))) 207 | 208 | (add-default-fold-case :try 209 | (fn [expr _] 210 | (-> expr 211 | (update-in [:try-expr] expr-rec) 212 | (update-in [:finally-expr] if-expr-rec) 213 | (update-in [:catch-exprs] map-expr-rec)))) 214 | 215 | (add-default-fold-case :recur 216 | (fn [expr _] 217 | (-> expr 218 | (update-in [:loop-locals] map-expr-rec) 219 | (update-in [:args] map-expr-rec)))) 220 | 221 | (add-default-fold-case :method-param return-first) 222 | -------------------------------------------------------------------------------- /src/clojure/tools/analyzer/emit_form.clj: -------------------------------------------------------------------------------- 1 | (ns clojure.tools.analyzer.emit-form 2 | (:require [clojure.tools.analyzer :refer [ast]])) 3 | 4 | (def emit-default ::emit-default) 5 | 6 | (defn derive-emit-default [tag] 7 | (derive tag emit-default)) 8 | 9 | (declare map->form) 10 | 11 | (defn emit-form 12 | "Return the form represented by the given AST." 13 | [expr] 14 | (map->form expr ::emit-default)) 15 | 16 | (defmulti map->form (fn [expr mode] 17 | [(:op expr) mode])) 18 | 19 | (defmethod map->form [:nil emit-default] [{:keys [val]} _] val) 20 | (defmethod map->form [:number emit-default] [{:keys [val]} _] val) 21 | (defmethod map->form [:constant emit-default] [{:keys [val]} _] (list 'quote val)) 22 | (defmethod map->form [:string emit-default] [{:keys [val]} _] val) 23 | (defmethod map->form [:boolean emit-default] [{:keys [val]} _] val) 24 | (defmethod map->form [:keyword emit-default] [{:keys [val]} _] val) 25 | 26 | (defmethod map->form [:static-method emit-default] 27 | [{:keys [^Type class method-name args]} mode] 28 | `(~(symbol (.Name class) (str method-name)) 29 | ~@(map #(map->form % mode) args))) 30 | 31 | (defmethod map->form [:static-field emit-default] 32 | [{:keys [^Type class field-name]} _] 33 | (symbol (.Name class) (str field-name))) 34 | 35 | (defmethod map->form [:invoke emit-default] 36 | [{:keys [fexpr args]} mode] 37 | `(~(map->form fexpr mode) 38 | ~@(map #(map->form % mode) args))) 39 | 40 | (defn- var->symbol [var] 41 | (symbol (str (ns-name (.ns var))) (str (.sym var)))) 42 | 43 | (defmethod map->form [:the-var emit-default] 44 | [{:keys [var]} _] 45 | (list 'var (var->symbol var))) 46 | 47 | (defmethod map->form [:var emit-default] 48 | [{:keys [var]} _] 49 | (var->symbol var)) 50 | 51 | (defmethod map->form [:instance-method emit-default] 52 | [{:keys [target method-name args]} mode] 53 | `(~(symbol (str "." method-name)) 54 | ~(map->form target mode) 55 | ~@(map #(map->form % mode) args))) 56 | 57 | (defmethod map->form [:new emit-default] 58 | [{:keys [^Type class args]} mode] 59 | `(new ~(symbol (.Name class)) 60 | ~@(map #(map->form % mode) args))) 61 | 62 | (defmethod map->form [:empty-expr emit-default] [{:keys [coll]} _] coll) 63 | (defmethod map->form [:vector emit-default] [{:keys [args]} mode] (vec (map #(map->form % mode) args))) 64 | (defmethod map->form [:map emit-default] [{:keys [keyvals]} mode] (apply hash-map (map #(map->form % mode) keyvals))) 65 | (defmethod map->form [:set emit-default] [{:keys [keys]} mode] (set (map #(map->form % mode) keys))) 66 | 67 | (defmethod map->form [:fn-expr emit-default] 68 | [{:keys [name methods]} mode] 69 | (list* 'fn* 70 | (concat 71 | (when name 72 | [name]) 73 | (map #(map->form % mode) methods)))) 74 | 75 | (defmethod map->form [:fn-method emit-default] 76 | [{:keys [body required-params rest-param]} mode] 77 | `(~(vec (concat (map #(map->form % mode) required-params) 78 | (when rest-param 79 | ['& (map->form rest-param mode)]))) 80 | ~(map->form body mode))) 81 | 82 | (defmethod map->form [:do emit-default] 83 | [{:keys [exprs]} mode] 84 | (cond 85 | (empty? exprs) nil 86 | (= 1 (count exprs)) (map->form (first exprs) mode) 87 | :else `(do ~@(map #(map->form % mode) exprs)))) 88 | 89 | (defmethod map->form [:let emit-default] 90 | [{:keys [is-loop binding-inits body]} mode] 91 | `(~(if is-loop 92 | 'loop* 93 | 'let*) 94 | ~(vec (apply concat (map #(map->form % mode) binding-inits))) 95 | ~(map->form body mode))) 96 | 97 | (defmethod map->form [:letfn emit-default] 98 | [{:keys [binding-inits body]} mode] 99 | `(~'letfn* 100 | ~(vec (apply concat (map #(map->form % mode) binding-inits))) 101 | ~(map->form body mode))) 102 | 103 | (defmethod map->form [:recur emit-default] 104 | [{:keys [args]} mode] 105 | `(recur ~@(map #(map->form % mode) args))) 106 | 107 | ;to be spliced 108 | (defmethod map->form [:binding-init emit-default] 109 | [{:keys [local-binding init]} mode] 110 | (map #(map->form % mode) [local-binding init])) 111 | 112 | (defmethod map->form [:local-binding emit-default] [{:keys [sym]} _] sym) 113 | (defmethod map->form [:local-binding-expr emit-default] [{:keys [local-binding]} mode] (map->form local-binding mode)) 114 | 115 | (defmethod map->form [:if emit-default] 116 | [{:keys [test then else]} mode] 117 | `(if ~@(map #(map->form % mode) [test then else]))) 118 | 119 | (defmethod map->form [:instance-of emit-default] 120 | [{:keys [^Type class the-expr]} mode] 121 | `(clojure.core/instance? ~(symbol (.Name class)) 122 | ~(map->form the-expr mode))) 123 | 124 | (defmethod map->form [:def emit-default] 125 | [{:keys [var init init-provided]} mode] 126 | `(def ~(.sym var) ~(when init-provided 127 | (map->form init mode)))) 128 | 129 | ;FIXME: methods don't print protocol/interface name 130 | (defmethod map->form [:deftype* emit-default] 131 | [{:keys [name methods fields covariants ^Class compiled-class]} mode] 132 | (list* 'deftype* 133 | (symbol (apply str (last (partition-by #{\.} (str name))))) 134 | name 135 | ;FIXME these should be hinted fields 136 | (vec (map #(map->form % mode) fields)) 137 | :implements 138 | ;FIXME interfaces implemented 139 | [] 140 | (map #(map->form % mode) methods))) 141 | 142 | (defmethod map->form [:new-instance-method emit-default] 143 | [{:keys [name required-params body]} mode] 144 | (list name (vec (map #(map->form % mode) required-params)) 145 | (map->form body mode))) 146 | 147 | (defmethod map->form [:import* emit-default] 148 | [{:keys [class-str]} _] 149 | (list 'import* class-str)) 150 | 151 | (defmethod map->form [:keyword-invoke emit-default] 152 | [{:keys [kw target]} mode] 153 | (list (map->form kw mode) (map->form target mode))) 154 | 155 | (defmethod map->form [:throw emit-default] 156 | [{:keys [exception]} mode] 157 | (list 'throw (map->form exception mode))) 158 | 159 | (defmethod map->form [:try emit-default] 160 | [{:keys [try-expr catch-exprs finally-expr]} mode] 161 | (list* 'try (map->form try-expr mode) 162 | (concat 163 | (map #(map->form % mode) catch-exprs) 164 | (when finally-expr [(list 'finally (map->form finally-expr mode))])))) 165 | 166 | (defmethod map->form [:catch emit-default] 167 | [{:keys [^Type class local-binding handler]} mode] 168 | (list 'catch (symbol (.Name class)) 169 | (map->form local-binding mode) 170 | (map->form handler mode))) 171 | 172 | ;; (from Compiler.java) 173 | ;; //(case* expr shift mask default map table-type test-type skip-check?) 174 | (defmethod map->form [:case* emit-default] 175 | [{:keys [the-expr tests thens default tests-hashes shift mask low high switch-type test-type skip-check]} mode] 176 | (list 'case* 177 | (map->form the-expr mode) 178 | shift 179 | mask 180 | (map->form default mode) 181 | (zipmap tests-hashes 182 | (map vector 183 | (map #(map->form % mode) tests) 184 | (map #(map->form % mode) thens))) 185 | switch-type 186 | test-type 187 | skip-check)) 188 | 189 | (defmethod map->form [:host-arg emit-default] 190 | [{:keys [expr]} mode] 191 | (map->form expr)) 192 | 193 | (comment 194 | (defmacro frm [f] 195 | `(-> (ast ~f) emit-form)) 196 | 197 | (frm 1) 198 | (frm :a) 199 | 200 | (frm (+ 1 2)) 201 | (frm (- 1 2)) 202 | 203 | (frm (apply - 1 2)) 204 | 205 | (frm (.var - 1 2)) 206 | 207 | (frm (Integer. 1)) 208 | 209 | (frm ()) 210 | 211 | (frm [1]) 212 | (frm [(- 1)]) 213 | (frm {(- 1) 1}) 214 | (frm #{(- 1) 1}) 215 | 216 | (frm (let [a '(1 2)] 217 | (first 1))) 218 | (frm (loop [a '(1 2)] 219 | (first 1))) 220 | 221 | (frm (fn [{:keys [a]} b] 1)) 222 | (frm (instance? Class 1)) 223 | 224 | (frm nil) 225 | (frm (def a 1)) 226 | (frm (defn ab [a] a)) 227 | 228 | (frm (loop [a 1] (recur 1))) 229 | 230 | ; FIXME 231 | (frm (deftype A [] 232 | clojure.lang.ISeq 233 | (first [this] this))) 234 | 235 | (frm (:a {})) 236 | (frm (throw (Exception. "a"))) 237 | (frm (try 1 2 238 | (catch Exception e 239 | 4) 240 | (catch Error e 241 | 5) 242 | (finally 3.2))) 243 | (frm (Integer/toHexString 1)) 244 | (frm (Integer/TYPE)) 245 | (frm #'conj) 246 | 247 | (frm 'a) 248 | (frm (let [b 1] 249 | [b 'a 1])) 250 | 251 | (frm #{1 2 3}) 252 | (frm (case 1 2 3 4)) 253 | (frm (case 1 :a 3 4)) 254 | 255 | (frm (deftype A [a b] 256 | Object 257 | (toString [this]))) 258 | (macroexpand 259 | '(deftype A [a b] 260 | Object 261 | (toString [this]))) 262 | 263 | (frm (letfn [(a [b] b) 264 | (b [a] a) 265 | (c [c] a)] 266 | (a b c))) 267 | ) 268 | -------------------------------------------------------------------------------- /src/clojure/tools/analyzer/hygienic.clj: -------------------------------------------------------------------------------- 1 | (ns clojure.tools.analyzer.hygienic 2 | (:require [clojure.tools.analyzer 3 | [fold :refer [derive-default-fold add-fold-case fold-expr]] 4 | [emit-form :refer [map->form derive-emit-default]]] 5 | [clojure.tools.analyzer :refer [ast]])) 6 | 7 | (declare hygienic-emit hygienic-ast) 8 | 9 | (defn ast-hy 10 | "Perform hygienic transformation on an AST 11 | 12 | eg. (-> (ast ...) ast-hy)" 13 | [expr] 14 | (hygienic-ast expr {})) 15 | 16 | (defn emit-hy 17 | "Emit an already-hygienic AST as a form. 18 | 19 | eg. (-> (ast ...) ast-hy emit-hy)" 20 | [expr] 21 | (map->form expr hygienic-emit)) 22 | 23 | (def hsym-key ::hygienic-sym) 24 | (def hname-key ::hygienic-name) 25 | 26 | ;; emit 27 | 28 | (def hygienic-emit ::hygienic-emit) 29 | 30 | (derive-emit-default hygienic-emit) 31 | 32 | (defmethod map->form [:local-binding hygienic-emit] 33 | [expr _] 34 | (hsym-key expr)) 35 | 36 | (defmethod map->form [:fn-expr hygienic-emit] 37 | [{:keys [methods] :as expr} mode] 38 | (list* 'fn* 39 | (concat 40 | (when-let [name (hname-key expr)] 41 | [name]) 42 | (map #(map->form % mode) methods)))) 43 | 44 | ;; fold 45 | 46 | (derive-default-fold ::hygienic) 47 | 48 | (declare hygienic-ast) 49 | 50 | (defn hygienic-ast [expr scope] 51 | (assert expr) 52 | (assert scope) 53 | (fold-expr ::hygienic 54 | {:expr-rec #(hygienic-ast % scope) 55 | :locals {::scope scope}} 56 | expr)) 57 | 58 | (defn hygienic-sym [scope sym] 59 | ;only generate unique when shadowing 60 | (if (scope sym) 61 | (gensym sym) 62 | sym)) 63 | 64 | (defn hygienic-local-binding [{:keys [op init sym] :as local-binding} scope new-sym?] 65 | {:pre [(= :local-binding op)]} 66 | (let [hy-init (when init 67 | (hygienic-ast init scope)) 68 | hy-sym (if new-sym? 69 | (hygienic-sym scope sym) 70 | (scope sym)) 71 | _ (assert hy-sym (str "Local " sym " not in scope."))] 72 | (assoc local-binding 73 | :init hy-init 74 | hsym-key hy-sym))) 75 | 76 | ;[(IPersistentMap Symbol HSymbol) Symbol HSymbol -> (IPersistentMap Symbol HSymbol)] 77 | (defn add-scope [scope sym hy-sym] 78 | {:pre [sym hy-sym scope]} 79 | (assoc scope sym hy-sym)) 80 | 81 | ;let 82 | (add-fold-case ::hygienic 83 | :let 84 | (fn [{:keys [binding-inits body] :as expr} 85 | {{scope ::scope} :locals :as locals}] 86 | (assert scope locals) 87 | (let [[hy-binding-inits scope] 88 | (reduce (fn [[hy-binding-inits scope] binding-init] 89 | {:pre [(vector? hy-binding-inits)]} 90 | (let [sym (-> binding-init :local-binding :sym) 91 | update-init #(when % (hygienic-ast % scope)) 92 | hy-sym (hygienic-sym scope sym) 93 | hy-binding-init (-> binding-init 94 | (update-in [:init] update-init) 95 | (update-in [:local-binding :init] update-init) 96 | (assoc-in [:local-binding hsym-key] hy-sym)) 97 | new-scope (add-scope scope sym hy-sym)] 98 | [(conj hy-binding-inits hy-binding-init) new-scope])) 99 | [[] scope] binding-inits) 100 | 101 | ;with new scope 102 | hy-body (hygienic-ast body scope)] 103 | (assoc expr 104 | :binding-inits hy-binding-inits 105 | :body hy-body)))) 106 | 107 | (defn hygienic-name [name scope] 108 | (let [hy-name (when name 109 | (hygienic-sym scope name)) 110 | new-scope (if hy-name 111 | (add-scope scope name hy-name) 112 | scope)] 113 | [hy-name new-scope])) 114 | 115 | ;fn-expr 116 | (add-fold-case ::hygienic 117 | :fn-expr 118 | (fn [{:keys [name methods] :as expr} 119 | {{scope ::scope} :locals}] 120 | (let [[hy-name scope] (hygienic-name name scope) 121 | hy-methods (map #(hygienic-ast % scope) methods)] 122 | (assoc expr 123 | hname-key hy-name 124 | :methods hy-methods)))) 125 | 126 | (defn hygienic-lbs [lbs scope] 127 | (reduce (fn [[hy-lbs scope] {:keys [sym] :as local-binding}] 128 | {:pre [(vector? hy-lbs)]} 129 | (let [hy-local-binding (hygienic-local-binding local-binding scope true) 130 | hy-sym (hsym-key hy-local-binding) 131 | new-scope (add-scope scope sym hy-sym)] 132 | [(conj hy-lbs hy-local-binding) new-scope])) 133 | [[] scope] lbs)) 134 | 135 | ;fn-method 136 | (add-fold-case ::hygienic 137 | :fn-method 138 | (fn [{:keys [required-params rest-param body] :as expr} 139 | {{scope ::scope} :locals}] 140 | (let [[hy-required-params scope] (hygienic-lbs required-params scope) 141 | [[hy-rest-param] scope] (if rest-param 142 | (hygienic-lbs [rest-param] scope) 143 | [[rest-param] scope]) 144 | ; use new scope 145 | hy-body (hygienic-ast body scope)] 146 | (assoc expr 147 | :required-params hy-required-params 148 | :rest-param hy-rest-param 149 | :body hy-body)))) 150 | 151 | ;local-binding-expr 152 | (add-fold-case ::hygienic 153 | :local-binding 154 | (fn [{:keys [sym init] :as expr} 155 | {{scope ::scope} :locals}] 156 | (hygienic-local-binding expr scope false))) 157 | 158 | (add-fold-case ::hygienic 159 | :catch 160 | (fn [{:keys [local-binding handler] :as expr} 161 | {{scope ::scope} :locals}] 162 | (let [hy-local-binding (hygienic-local-binding local-binding scope true) 163 | scope (add-scope scope (:sym hy-local-binding) (hsym-key hy-local-binding)) 164 | hy-handler (hygienic-ast handler scope)] 165 | (assoc expr 166 | :local-binding hy-local-binding 167 | :handler hy-handler)))) 168 | 169 | (add-fold-case ::hygienic 170 | :deftype* 171 | (fn [{:keys [fields methods] :as expr} 172 | {{scope ::scope} :locals}] 173 | (let [[hy-fields scope] 174 | (reduce (fn [[hy-lbs scope] lb] 175 | (let [hy-lb (hygienic-local-binding lb scope true) 176 | scope (add-scope scope (:sym hy-lb) (hsym-key hy-lb))] 177 | [(conj hy-lbs hy-lb) scope])) 178 | [#{} scope] fields) 179 | hy-methods (map #(hygienic-ast % scope) methods)] 180 | (assoc expr 181 | :fields hy-fields 182 | :methods hy-methods)))) 183 | 184 | (add-fold-case ::hygienic 185 | :new-instance-method 186 | (fn [{:keys [name required-params body] :as expr} 187 | {{scope ::scope} :locals}] 188 | (let [[hy-name scope] (hygienic-name name scope) 189 | [hy-required-params scope] (hygienic-lbs required-params scope) 190 | ; use new scope 191 | hy-body (hygienic-ast body scope)] 192 | (assoc expr 193 | :name hy-name 194 | :required-params hy-required-params 195 | :body hy-body)))) 196 | 197 | (add-fold-case ::hygienic 198 | :letfn 199 | (fn [{:keys [binding-inits body] :as expr} 200 | {{scope ::scope} :locals}] 201 | (let [;find scope of each binding init and body 202 | ;binit-hsyms is a vector of symbols, corresponding to the hsym for each binit 203 | [binit-hsyms scope] 204 | (reduce (fn [[hsyms scope] sym] 205 | (let [hsym (hygienic-sym scope sym)] 206 | [(conj hsyms hsym) (add-scope scope sym hsym)])) 207 | [[] scope] 208 | (map #(-> % :local-binding :sym) binding-inits)) 209 | hy-binding-inits 210 | (reduce (fn [hy-binding-inits [hy-sym binding-init]] 211 | (let [hy-binding-init (-> binding-init 212 | (update-in [:init] hygienic-ast scope) 213 | (update-in [:local-binding :init] hygienic-ast scope) 214 | (assoc-in [:local-binding hsym-key] hy-sym))] 215 | (conj hy-binding-inits hy-binding-init))) 216 | [] (map vector binit-hsyms binding-inits)) 217 | hy-body (hygienic-ast body scope)] 218 | (assoc expr 219 | :binding-inits hy-binding-inits 220 | :body hy-body)))) 221 | 222 | (comment 223 | (-> (ast (let [a 1 a a b a a a] a)) ast-hy emit-hy) 224 | 225 | (-> (ast (fn a [a a] a)) ast-hy emit-hy) 226 | (-> (ast (fn [a a & a] a)) ast-hy emit-hy) 227 | (-> (ast (let [a 1] (fn a [] a))) ast-hy emit-hy) 228 | (-> (ast (let [a 1] (try a (catch Exception a a)))) ast-hy emit-hy) 229 | 230 | (-> (ast (deftype A [a] Object (toString [_] a))) ast-hy emit-hy) 231 | (-> (ast (deftype A [a] Object (toString [a] a))) ast-hy emit-hy) 232 | 233 | (-> 234 | (ast 235 | (deftype Pair [lhs rhs] 236 | clojure.lang.Counted 237 | (count [_] 2) 238 | clojure.lang.Indexed 239 | (nth [_ i] (case i 240 | 0 lhs 241 | 1 rhs 242 | (throw (IndexOutOfBoundsException.)))) 243 | (nth [_ i not-found] (case i 244 | 0 lhs 245 | 1 rhs 246 | not-found)) 247 | java.util.Map$Entry 248 | (getKey [_] lhs) 249 | (getValue [_] rhs) 250 | Object 251 | (toString [_] 252 | (str "(" lhs " . " rhs ")"))) 253 | ) 254 | ast-hy emit-hy) 255 | 256 | (-> (ast (letfn [(a [b] b) 257 | (b [a] a) 258 | (c [c] a) 259 | (a [])] 260 | (a b c))) 261 | ast-hy emit-hy) 262 | ) 263 | -------------------------------------------------------------------------------- /src/clojure/tools/analyzer.clj: -------------------------------------------------------------------------------- 1 | (set! *warn-on-reflection* true) 2 | 3 | (ns clojure.tools.analyzer 4 | "Interface to Compiler's analyze. 5 | Entry point `analyze-path` and `analyze-one`" 6 | (:require [clojure.reflect :as reflect] 7 | [clojure.clr.io :as io] 8 | [clojure.repl :as repl] 9 | [clojure.string :as string] 10 | [clojure.set :as set] 11 | [clojure.tools.analyzer.util]) 12 | (:import (System.IO TextReader) 13 | (System.Reflection BindingFlags) 14 | (clojure.lang RT Compiler LineNumberingTextReader) 15 | (clojure.lang.CljCompiler.Ast 16 | DefExpr LocalBinding BindingInit LetExpr 17 | LetFnExpr MethodExpr StaticMethodExpr InstanceMethodExpr StaticFieldExpr 18 | NewExpr EmptyExpr VectorExpr MonitorEnterExpr 19 | MonitorExitExpr ThrowExpr InvokeExpr TheVarExpr VarExpr 20 | UnresolvedVarExpr ObjExpr NewInstanceMethod FnMethod FnExpr 21 | NewInstanceExpr MetaExpr BodyExpr ImportExpr AssignExpr 22 | TryExpr+CatchClause TryExpr LocalBindingExpr RecurExpr 23 | MapExpr IfExpr KeywordInvokeExpr InstanceFieldExpr InstanceOfExpr 24 | CaseExpr Expr SetExpr MethodParamExpr KeywordExpr 25 | ConstantExpr NumberExpr NilExpr BooleanExpr StringExpr 26 | ObjMethod ParserContext RHC HostArg) 27 | (clojure.reflect Field))) 28 | 29 | (def CHILDREN (atom false)) 30 | (def JAVA-OBJ (atom false)) 31 | 32 | ;;;;;;;;;;;;;;;;;;;;;;;; 33 | ;; Interface 34 | 35 | (declare analyze-one) 36 | 37 | (defn analyze-form-in-ns [nsym form] 38 | (analyze-one {:ns {:name nsym} :context :eval} 39 | form)) 40 | 41 | (defn analyze-form [form] 42 | (analyze-form-in-ns (ns-name *ns*) form)) 43 | 44 | (defmacro ast-in-ns 45 | "Returns the abstract syntax tree representation of the given form, 46 | evaluated in the given namespace" 47 | [nsym form] 48 | `(analyze-form-in-ns '~nsym '~form)) 49 | 50 | (defmacro ast 51 | "Returns the abstract syntax tree representation of the given form, 52 | evaluated in the current namespace" 53 | [form] 54 | `(analyze-form '~form)) 55 | 56 | ;;;;;;;;;;;;;;;;;;;;;;; 57 | ;; Utils 58 | 59 | (defmacro field 60 | "Call a private field, must be known at compile time. Throws an error 61 | if field is already publicly accessible." 62 | ([class-obj field] `(field ~class-obj ~field nil)) 63 | ([class-obj field obj] 64 | (assert (symbol? class-obj)) 65 | (assert (resolve class-obj) (str "Class " class-obj " cannot be resolved")) 66 | (let [{class-flags :flags :keys [members]} (reflect/reflect (resolve class-obj)) 67 | field-flags (when-let [^Field f (some #(and (when (instance? Field %) (= (.name ^Field %) field)) %) members)] 68 | ;FIXME it doesn't seem like ClojureCLR lets me use :flags here. Needs investigation. 69 | (.flags f))] 70 | (assert field-flags 71 | (str "Class " (resolve class-obj) " does not have field " field)) 72 | (assert (not (and (:public class-flags) 73 | (:public field-flags))) 74 | (str "Class " (resolve class-obj) " and field " field " is already public"))) 75 | `(field-accessor ~class-obj '~field ~obj))) 76 | 77 | (def reflect-flag->BindingFlags 78 | {:private BindingFlags/NonPublic 79 | :public BindingFlags/Public 80 | :static BindingFlags/Static}) 81 | 82 | (defn- field-accessor [^Type class-obj field-sym obj] 83 | (let [^Field 84 | clj-field (->> (reflect/reflect class-obj) 85 | :members 86 | (filter #(when (instance? Field %) (= (.name ^Field %) field-sym))) 87 | first) 88 | _ (assert clj-field) 89 | reflect-flags (.flags clj-field) 90 | binding-flags (set/union (set (->> reflect-flags 91 | (map reflect-flag->BindingFlags) 92 | (remove nil?))) 93 | #{BindingFlags/NonPublic BindingFlags/Public}) 94 | binding-flags (if (:static reflect-flags) 95 | binding-flags 96 | (conj binding-flags BindingFlags/Instance)) 97 | 98 | bfs-bit-or (apply enum-or binding-flags) 99 | 100 | ^System.Reflection.FieldInfo 101 | field (.GetField class-obj (name field-sym) bfs-bit-or)] 102 | (if field 103 | (.GetValue field obj) 104 | (throw (Exception. (str "Class " class-obj " does not contain field " field-sym)))))) 105 | 106 | #_(defn- method-accessor [^Class class-obj method obj types & args] 107 | (let [^java.lang.reflect.Method 108 | method (.getDeclaredMethod class-obj (name method) (into-array Class types))] 109 | (.setAccessible method true) 110 | (.invoke method obj (object-array args)))) 111 | 112 | (defn- when-column-map [expr] 113 | (let [field (try (field-accessor (class expr) '_column expr) 114 | (catch Exception e))] 115 | (when field 116 | {:column (field-accessor (class expr) '_column expr)}))) 117 | 118 | (defn- when-line-map [expr] 119 | (let [field (try (field-accessor (class expr) '_line expr) 120 | (catch Exception e))] 121 | (when field 122 | {:line (field-accessor (class expr) '_line expr)}))) 123 | 124 | (defn- when-source-map [expr] 125 | (let [field (try (field-accessor (class expr) '_source expr) 126 | (catch Exception e))] 127 | (when field 128 | {:source (field-accessor (class expr) '_source expr)}))) 129 | 130 | (defn- env-location [env expr] 131 | (merge env 132 | (when-line-map expr) 133 | (when-column-map expr) 134 | (when-source-map expr))) 135 | 136 | (defn- inherit-env [expr env] 137 | (merge env 138 | (when-let [line (-> expr :env :line)] 139 | {:line line}) 140 | (when-let [column (-> expr :env :column)] 141 | {:column column}) 142 | (when-let [source (-> expr :env :source)] 143 | {:source source}))) 144 | 145 | (defprotocol AnalysisToMap 146 | (analysis->map [aobj env] 147 | "Recursively converts the output of the Compiler's analysis to a map")) 148 | 149 | ;; Literals extending abstract class LiteralExpr and have public value fields 150 | 151 | (defmacro literal-dispatch [disp-class op-keyword] 152 | `(extend-protocol AnalysisToMap 153 | ~disp-class 154 | (~'analysis->map 155 | [expr# env#] 156 | (let [] 157 | (merge 158 | {:op ~op-keyword 159 | :env env# 160 | :val (.Eval expr#)} 161 | (when @JAVA-OBJ 162 | {:Expr-obj expr#})))))) 163 | 164 | (literal-dispatch KeywordExpr :keyword) 165 | (literal-dispatch ConstantExpr :constant) 166 | (literal-dispatch NumberExpr :number) 167 | (literal-dispatch StringExpr :string) 168 | (literal-dispatch NilExpr :nil) 169 | (literal-dispatch BooleanExpr :boolean) 170 | 171 | (extend-protocol AnalysisToMap 172 | 173 | ;; def 174 | DefExpr 175 | (analysis->map 176 | [expr env] 177 | (let [init (analysis->map (field DefExpr _init expr) env) 178 | meta (when-let [meta (field DefExpr _meta expr)] 179 | (analysis->map meta env))] 180 | (merge 181 | {:op :def 182 | :env (env-location env expr) 183 | :var (field DefExpr _var expr) 184 | :meta meta 185 | :init init 186 | :init-provided (field DefExpr _initProvided expr) 187 | :is-dynamic (field DefExpr _isDynamic expr)} 188 | (when @CHILDREN 189 | {:children [meta init]}) 190 | (when @JAVA-OBJ 191 | {:Expr-obj expr})))) 192 | 193 | ;; let 194 | LocalBinding 195 | (analysis->map 196 | [lb env] 197 | (let [init (when-let [init (.Init lb)] 198 | (analysis->map init env))] 199 | (merge 200 | {:op :local-binding 201 | :env (inherit-env init env) 202 | :sym (.Symbol lb) 203 | :tag (.Tag lb) 204 | :init init} 205 | (when @CHILDREN 206 | {:children (when init [init])}) 207 | (when @JAVA-OBJ 208 | {:LocalBinding-obj lb})))) 209 | 210 | BindingInit 211 | (analysis->map 212 | [bi env] 213 | (let [local-binding (analysis->map (.Binding bi) env) 214 | init (analysis->map (.Init bi) env)] 215 | (merge 216 | {:op :binding-init 217 | :env (inherit-env init env) 218 | :local-binding local-binding 219 | :init init} 220 | (when @CHILDREN 221 | {:children [local-binding init]}) 222 | (when @JAVA-OBJ 223 | {:BindingInit-obj bi})))) 224 | 225 | LetExpr 226 | (analysis->map 227 | [expr env] 228 | (let [body (analysis->map (field LetExpr _body expr) env) 229 | binding-inits (map analysis->map (field LetExpr _bindingInits expr) (repeat env))] 230 | (merge 231 | {:op :let 232 | :env (inherit-env body env) 233 | :binding-inits binding-inits 234 | :body body 235 | :is-loop (field LetExpr _isLoop expr)} 236 | (when @CHILDREN 237 | {:children (conj (vec binding-inits) body)}) 238 | (when @JAVA-OBJ 239 | {:Expr-obj expr})))) 240 | 241 | ;; letfn 242 | LetFnExpr 243 | (analysis->map 244 | [expr env] 245 | (let [body (analysis->map (field LetFnExpr _body expr) env) 246 | binding-inits (map analysis->map (field LetFnExpr _bindingInits expr) (repeat env))] 247 | (merge 248 | {:op :letfn 249 | :env (inherit-env body env) 250 | :body body 251 | :binding-inits binding-inits} 252 | (when @CHILDREN 253 | {:children (conj (vec binding-inits) body)}) 254 | (when @JAVA-OBJ 255 | {:Expr-obj expr})))) 256 | 257 | ;; LocalBindingExpr 258 | LocalBindingExpr 259 | (analysis->map 260 | [expr env] 261 | (let [local-binding (analysis->map (field LocalBindingExpr _b expr) env)] 262 | (merge 263 | {:op :local-binding-expr 264 | :env (inherit-env local-binding env) 265 | :local-binding local-binding 266 | :tag (field LocalBindingExpr _tag expr)} 267 | (when @CHILDREN 268 | {:children [local-binding]}) 269 | (when @JAVA-OBJ 270 | {:Expr-obj expr})))) 271 | 272 | ;; Methods 273 | StaticMethodExpr 274 | (analysis->map 275 | [expr env] 276 | (let [args (map analysis->map (field MethodExpr _args expr) (repeat env))] 277 | (merge 278 | {:op :static-method 279 | :env (env-location env expr) 280 | :class (field StaticMethodExpr _type expr) 281 | ;:method-name (field StaticMethodExpr methodName expr) 282 | :method (when-let [method (field MethodExpr _method expr)] 283 | (@#'reflect/method->map method)) 284 | :args args 285 | :tag (field MethodExpr _tag expr)} 286 | (when @CHILDREN 287 | {:children args}) 288 | (when @JAVA-OBJ 289 | {:Expr-obj expr})))) 290 | 291 | InstanceMethodExpr 292 | (analysis->map 293 | [expr env] 294 | (let [target (analysis->map (field InstanceMethodExpr _target expr) env) 295 | args (map analysis->map (field MethodExpr _args expr) (repeat env))] 296 | (merge 297 | {:op :instance-method 298 | :env (env-location env expr) 299 | :target target 300 | :method-name (field MethodExpr _methodName expr) 301 | :method (when-let [method (field MethodExpr _method expr)] 302 | (@#'reflect/method->map method)) 303 | :args args 304 | :tag (field MethodExpr _tag expr)} 305 | (when @CHILDREN 306 | {:children (cons target args)}) 307 | (when @JAVA-OBJ 308 | {:Expr-obj expr})))) 309 | 310 | ;; Fields 311 | StaticFieldExpr 312 | (analysis->map 313 | [expr env] 314 | (let [] 315 | (merge 316 | {:op :static-field 317 | :env (env-location env expr) 318 | ;:class (field clojure.lang.CljCompiler.Ast.StaticFieldOrPropertyExpr _type expr) 319 | ;:field-name (field StaticFieldExpr _fieldName expr) 320 | ;:field (when-let [field (field StaticFieldExpr _tinfo expr)] 321 | ; (@#'reflect/field->map field)) 322 | ;:tag (field StaticFieldExpr tag expr) 323 | } 324 | (when @JAVA-OBJ 325 | {:Expr-obj expr})))) 326 | 327 | InstanceFieldExpr 328 | (analysis->map 329 | [expr env] 330 | (let [#_target #_(analysis->map (field InstanceFieldOrPropertyExpr _target expr) env)] 331 | (merge 332 | {:op :instance-field 333 | :env (env-location env expr) 334 | ; :target target 335 | ; :target-class (field InstanceFieldExpr _targetType expr) 336 | ; :field (when-let [field (field InstanceFieldExpr field expr)] 337 | ; (@#'reflect/field->map field)) 338 | ; :field-name (field InstanceFieldExpr fieldName expr) 339 | ; :tag (field InstanceFieldExpr tag expr) 340 | } 341 | (when @CHILDREN 342 | {:children [#_target]}) 343 | (when @JAVA-OBJ 344 | {:Expr-obj expr})))) 345 | 346 | NewExpr 347 | (analysis->map 348 | [expr env] 349 | (let [args (map analysis->map (field NewExpr _args expr) (repeat env))] 350 | (merge 351 | {:op :new 352 | :env env 353 | ; should be there but isn't 354 | ;(assoc env 355 | ; :line (.line expr) 356 | ; ) 357 | :ctor (when-let [ctor (field NewExpr _ctor expr)] 358 | (@#'reflect/constructor->map ctor)) 359 | :class (.ClrType expr) 360 | :args args} 361 | (when @CHILDREN 362 | {:children args}) 363 | (when @JAVA-OBJ 364 | {:Expr-obj expr})))) 365 | 366 | EmptyExpr 367 | (analysis->map 368 | [expr env] 369 | (merge 370 | {:op :empty-expr 371 | :env env 372 | :coll (field EmptyExpr _coll expr)} 373 | (when @JAVA-OBJ 374 | {:Expr-obj expr}))) 375 | 376 | ;; set literal 377 | SetExpr 378 | (analysis->map 379 | [expr env] 380 | (let [keys (map analysis->map (field SetExpr _keys expr) (repeat env))] 381 | (merge 382 | {:op :set 383 | :env env 384 | :keys keys} 385 | (when @CHILDREN 386 | {:children keys}) 387 | (when @JAVA-OBJ 388 | {:Expr-obj expr})))) 389 | 390 | ;; vector literal 391 | VectorExpr 392 | (analysis->map 393 | [expr env] 394 | (let [args (map analysis->map (field VectorExpr _args expr) (repeat env))] 395 | (merge 396 | {:op :vector 397 | :env env 398 | :args args} 399 | (when @CHILDREN 400 | {:children args}) 401 | (when @JAVA-OBJ 402 | {:Expr-obj expr})))) 403 | 404 | ;; map literal 405 | MapExpr 406 | (analysis->map 407 | [expr env] 408 | (let [keyvals (map analysis->map (.KeyVals expr) (repeat env))] 409 | (merge 410 | {:op :map 411 | :env env 412 | :keyvals keyvals} 413 | (when @CHILDREN 414 | {:children keyvals}) 415 | (when @JAVA-OBJ 416 | {:Expr-obj expr})))) 417 | 418 | ;; Untyped 419 | MonitorEnterExpr 420 | (analysis->map 421 | [expr env] 422 | (let [target (analysis->map (field MonitorEnterExpr _target expr) env)] 423 | (merge 424 | {:op :monitor-enter 425 | :env env 426 | :target target} 427 | (when @CHILDREN 428 | {:children [target]}) 429 | (when @JAVA-OBJ 430 | {:Expr-obj expr})))) 431 | 432 | MonitorExitExpr 433 | (analysis->map 434 | [expr env] 435 | (let [target (analysis->map (field MonitorExitExpr _target expr) env)] 436 | (merge 437 | {:op :monitor-exit 438 | :env env 439 | :target target} 440 | (when @CHILDREN 441 | {:children [target]}) 442 | (when @JAVA-OBJ 443 | {:Expr-obj expr})))) 444 | 445 | ThrowExpr 446 | (analysis->map 447 | [expr env] 448 | (let [exception (analysis->map (field ThrowExpr _excExpr expr) env)] 449 | (merge 450 | {:op :throw 451 | :env env 452 | :exception exception} 453 | (when @CHILDREN 454 | {:children [exception]}) 455 | (when @JAVA-OBJ 456 | {:Expr-obj expr})))) 457 | 458 | ;; Invokes 459 | InvokeExpr 460 | (analysis->map 461 | [expr env] 462 | (let [fexpr (analysis->map (field InvokeExpr _fexpr expr) env) 463 | args (map analysis->map (field InvokeExpr _args expr) (repeat env))] 464 | (merge 465 | {:op :invoke 466 | :env (env-location env expr) 467 | :fexpr fexpr 468 | :tag (field InvokeExpr _tag expr) 469 | :args args 470 | :is-protocol (field InvokeExpr _isProtocol expr) 471 | ;:is-direct (field InvokeExpr isDirect expr) 472 | :site-index (field InvokeExpr _siteIndex expr) 473 | :protocol-on (field InvokeExpr _protocolOn expr)} 474 | (when-let [m (field InvokeExpr _onMethod expr)] 475 | {:method (@#'reflect/method->map m)}) 476 | (when @CHILDREN 477 | {:children (cons fexpr args)}) 478 | (when @JAVA-OBJ 479 | {:Expr-obj expr})))) 480 | 481 | KeywordInvokeExpr 482 | (analysis->map 483 | [expr env] 484 | (let [target (analysis->map (field KeywordInvokeExpr _target expr) env) 485 | kw (analysis->map (field KeywordInvokeExpr _kw expr) env)] 486 | (merge 487 | {:op :keyword-invoke 488 | :env (env-location env expr) 489 | :kw kw 490 | :tag (field KeywordInvokeExpr _tag expr) 491 | :target target} 492 | (when @CHILDREN 493 | {:children [target]}) 494 | (when @JAVA-OBJ 495 | {:Expr-obj expr})))) 496 | 497 | ;; TheVarExpr 498 | TheVarExpr 499 | (analysis->map 500 | [expr env] 501 | (merge 502 | {:op :the-var 503 | :env env 504 | :var (field TheVarExpr _var expr)} 505 | (when @JAVA-OBJ 506 | {:Expr-obj expr}))) 507 | 508 | ;; VarExpr 509 | VarExpr 510 | (analysis->map 511 | [expr env] 512 | (merge 513 | {:op :var 514 | :env env 515 | :var (.Var expr) 516 | :tag (.Tag expr)} 517 | (when @JAVA-OBJ 518 | {:Expr-obj expr}))) 519 | 520 | ;; UnresolvedVarExpr 521 | UnresolvedVarExpr 522 | (analysis->map 523 | [expr env] 524 | (let [] 525 | (merge 526 | {:op :unresolved-var 527 | :env env 528 | :sym (field UnresolvedVarExpr _symbol expr)} 529 | (when @JAVA-OBJ 530 | {:Expr-obj expr})))) 531 | 532 | ;; ObjExprs 533 | ObjExpr 534 | (analysis->map 535 | [expr env] 536 | (merge 537 | {:op :obj-expr 538 | :env env 539 | :tag (field ObjExpr _tag expr)} 540 | (when @JAVA-OBJ 541 | {:Expr-obj expr}))) 542 | 543 | ;; FnExpr (extends ObjExpr) 544 | NewInstanceMethod 545 | (analysis->map 546 | [obm env] 547 | (let [body (analysis->map (field ObjMethod _body obm) env)] 548 | (merge 549 | {:op :new-instance-method 550 | :env (env-location env obm) 551 | :name (symbol (field NewInstanceMethod _name obm)) 552 | ; :required-params (map analysis->map 553 | ; (concat [((field ObjMethod indexlocals obm) 0)] 554 | ; (field ObjMethod argLocals obm)) 555 | ; (repeat env)) 556 | :body body} 557 | (when @CHILDREN 558 | {:children [body]}) 559 | (when @JAVA-OBJ 560 | {:ObjMethod-obj obm})))) 561 | 562 | FnMethod 563 | (analysis->map 564 | [obm env] 565 | (let [body (analysis->map (field ObjMethod _body obm) env) 566 | required-params (map analysis->map (field FnMethod _reqParms obm) (repeat env))] 567 | (merge 568 | {:op :fn-method 569 | :env env 570 | :body body 571 | ;; Map LocalExpr@xx -> LocalExpr@xx 572 | ;;:locals (map analysis->map (keys (.locals obm)) (repeat env)) 573 | :required-params required-params 574 | :rest-param (let [rest-param (field FnMethod _restParm obm)] 575 | (if rest-param 576 | (analysis->map rest-param env) 577 | rest-param))} 578 | (when @CHILDREN 579 | {:children [body]}) 580 | (when @JAVA-OBJ 581 | {:ObjMethod-obj obm})))) 582 | 583 | FnExpr 584 | (analysis->map 585 | [expr env] 586 | (let [methods (map analysis->map (field ObjExpr _methods expr) (repeat env))] 587 | (merge 588 | {:op :fn-expr 589 | :env (env-location env expr) 590 | :methods methods 591 | :variadic-method (when-let [variadic-method (field FnExpr _variadicMethod expr)] 592 | (analysis->map variadic-method env)) 593 | :tag (field ObjExpr _tag expr)} 594 | (when-let [nme (.Name expr)] 595 | {:name (symbol nme)}) 596 | (when @CHILDREN 597 | {:children methods}) 598 | (when @JAVA-OBJ 599 | {:Expr-obj expr})))) 600 | 601 | ;; NewInstanceExpr 602 | ;FIXME find vector of interfaces this implements (I think it's in mmap + IType) 603 | NewInstanceExpr 604 | (analysis->map 605 | [expr env] 606 | (let [methods (map analysis->map (field ObjExpr _methods expr) (repeat env))] 607 | (merge 608 | {:op :deftype* 609 | :name (symbol (.Name expr)) 610 | :env (env-location env expr) 611 | :methods methods 612 | ;:mmap (field NewInstanceExpr mmap expr) 613 | 614 | ;:compiled-class (.compiledClass expr) 615 | ;:internal-name (.internalName expr) 616 | ;:this-name (.thisName expr) 617 | 618 | ;(IPersistentSet LocalBinding) 619 | ;:fields (set (for [[k v] (field ObjExpr fields expr)] 620 | ; (analysis->map v env))) 621 | 622 | ;:covariants (field NewInstanceExpr covariants expr) 623 | 624 | :tag (field ObjExpr _tag expr)} 625 | (when @CHILDREN 626 | {:children methods}) 627 | (when @JAVA-OBJ 628 | {:Expr-obj expr})))) 629 | 630 | ;; InstanceOfExpr 631 | InstanceOfExpr 632 | (analysis->map 633 | [expr env] 634 | (let [exp (analysis->map (field InstanceOfExpr _expr expr) env)] 635 | (merge 636 | {:op :instance-of 637 | :env env 638 | :class (field InstanceOfExpr _t expr) 639 | :the-expr exp} 640 | (when @CHILDREN 641 | {:children [exp]}) 642 | (when @JAVA-OBJ 643 | {:Expr-obj expr})))) 644 | 645 | ;; MetaExpr 646 | MetaExpr 647 | (analysis->map 648 | [expr env] 649 | (let [meta (analysis->map (field MetaExpr _meta expr) env) 650 | the-expr (analysis->map (field MetaExpr _expr expr) env)] 651 | (merge 652 | {:op :meta 653 | :env env 654 | :meta meta 655 | :expr the-expr} 656 | (when @CHILDREN 657 | {:children [meta the-expr]}) 658 | (when @JAVA-OBJ 659 | {:Expr-obj expr})))) 660 | 661 | ;; do 662 | BodyExpr 663 | (analysis->map 664 | [expr env] 665 | (let [exprs (map analysis->map (field BodyExpr _exprs expr) (repeat env))] 666 | (merge 667 | {:op :do 668 | :env (inherit-env (last exprs) env) 669 | :exprs exprs} 670 | (when @CHILDREN 671 | {:children exprs}) 672 | (when @JAVA-OBJ 673 | {:Expr-obj expr})))) 674 | 675 | ;; if 676 | IfExpr 677 | (analysis->map 678 | [expr env] 679 | (let [test (analysis->map (field IfExpr _testExpr expr) env) 680 | then (analysis->map (field IfExpr _thenExpr expr) env) 681 | else (analysis->map (field IfExpr _elseExpr expr) env)] 682 | (merge 683 | {:op :if 684 | :env (env-location env expr) 685 | :test test 686 | :then then 687 | :else else} 688 | (when @CHILDREN 689 | {:children [test then else]}) 690 | (when @JAVA-OBJ 691 | {:Expr-obj expr})))) 692 | 693 | ;; case 694 | ;; (from Compiler.java) 695 | ;; //(case* expr shift mask default map table-type test-type skip-check?) 696 | CaseExpr 697 | (analysis->map 698 | [expr env] 699 | (let [the-expr (analysis->map (field CaseExpr _expr expr) env) 700 | tests (map analysis->map (vals (field CaseExpr _tests expr)) (repeat env)) 701 | thens (map analysis->map (vals (field CaseExpr _thens expr)) (repeat env)) 702 | default (analysis->map (field CaseExpr _defaultExpr expr) env)] 703 | (merge 704 | {:op :case* 705 | :env (env-location env expr) 706 | :the-expr the-expr 707 | :tests tests 708 | :thens thens 709 | :default default 710 | :tests-hashes (keys (field CaseExpr _tests expr)) 711 | :shift (field CaseExpr _shift expr) 712 | :mask (field CaseExpr _mask expr) 713 | :test-type (field CaseExpr _testType expr) 714 | :switch-type (field CaseExpr _switchType expr) 715 | :skip-check (field CaseExpr _skipCheck expr)} 716 | (when @CHILDREN 717 | {:children (concat [the-expr] tests thens [default])}) 718 | (when @JAVA-OBJ 719 | {:Expr-obj expr})))) 720 | 721 | 722 | ;; ImportExpr 723 | ImportExpr 724 | (analysis->map 725 | [expr env] 726 | (merge 727 | {:op :import* 728 | :env env 729 | :class-str (field ImportExpr _c expr)} 730 | (when @JAVA-OBJ 731 | {:Expr-obj expr}))) 732 | 733 | ;; AssignExpr (set!) 734 | AssignExpr 735 | (analysis->map 736 | [expr env] 737 | (let [target (analysis->map (field AssignExpr _target expr) env) 738 | val (analysis->map (field AssignExpr _val expr) env)] 739 | (merge 740 | {:op :set! 741 | :env env 742 | :target target 743 | :val val} 744 | (when @CHILDREN 745 | {:children [target val]}) 746 | (when @JAVA-OBJ 747 | {:Expr-obj expr})))) 748 | 749 | ;;TryExpr 750 | TryExpr+CatchClause 751 | (analysis->map 752 | [ctch env] 753 | (let [local-binding (analysis->map (field TryExpr+CatchClause _lb ctch) env) 754 | handler (analysis->map (field TryExpr+CatchClause _handler ctch) env)] 755 | (merge 756 | {:op :catch 757 | :env env 758 | :class (.Type ctch) 759 | :local-binding local-binding 760 | :handler handler} 761 | (when @CHILDREN 762 | {:children [local-binding handler]}) 763 | (when @JAVA-OBJ 764 | {:CatchClause-obj ctch})))) 765 | 766 | TryExpr 767 | (analysis->map 768 | [expr env] 769 | (let [try-expr (analysis->map (field TryExpr _tryExpr expr) env) 770 | finally-expr (when-let [finally-expr (field TryExpr _finallyExpr expr)] 771 | (analysis->map finally-expr env)) 772 | catch-exprs (map analysis->map (field TryExpr _catchExprs expr) (repeat env))] 773 | (merge 774 | {:op :try 775 | :env env 776 | :try-expr try-expr 777 | :finally-expr finally-expr 778 | :catch-exprs catch-exprs 779 | ;:ret-local (.retLocal expr) 780 | ;:finally-local (.finallyLocal expr) 781 | } 782 | (when @CHILDREN 783 | {:children (concat [try-expr] (when finally-expr [finally-expr]) catch-exprs)}) 784 | (when @JAVA-OBJ 785 | {:Expr-obj expr})))) 786 | 787 | ;; RecurExpr 788 | RecurExpr 789 | (analysis->map 790 | [expr env] 791 | (let [loop-locals (map analysis->map (field RecurExpr _loopLocals expr) (repeat env)) 792 | args (map analysis->map (field RecurExpr _args expr) (repeat env))] 793 | (merge 794 | {:op :recur 795 | :env (env-location env expr) 796 | :loop-locals loop-locals 797 | :args args} 798 | (when @CHILDREN 799 | {:children (concat loop-locals args)}) 800 | (when @JAVA-OBJ 801 | {:Expr-obj expr})))) 802 | 803 | MethodParamExpr 804 | (analysis->map 805 | [expr env] 806 | (let [] 807 | (merge 808 | {:op :method-param 809 | :env env 810 | :class (.ClrType expr) 811 | :can-emit-primitive (.CanEmitPrimitive expr)} 812 | (when @JAVA-OBJ 813 | {:Expr-obj expr})))) 814 | 815 | HostArg 816 | (analysis->map 817 | [expr env] 818 | (let [] 819 | (merge 820 | {:op :host-arg 821 | :env env 822 | :expr (analysis->map (.ArgExpr expr) env)} 823 | (when @JAVA-OBJ 824 | {:Expr-obj expr}))))) 825 | 826 | (defn- analyze* 827 | "Must be called after binding the appropriate Compiler and RT dynamic Vars." 828 | [env form] 829 | (letfn [(invoke-analyze [context form] 830 | (Compiler/Analyze context form))] 831 | (let [context (-> 832 | (case (:context env) 833 | :statement RHC/Statement 834 | :expression RHC/Expression 835 | :return RHC/Return 836 | :eval RHC/Eval) 837 | ParserContext.) 838 | expr-ast (try 839 | (invoke-analyze context form) 840 | (catch Exception e 841 | (throw (repl/root-cause e))))] 842 | (analysis->map expr-ast (merge-with conj (dissoc env :context) {:locals {}}))))) 843 | 844 | (defn analyze-one 845 | "Analyze a single form" 846 | [env form] 847 | (analyze* env #_(find-ns (-> env :ns :name)) form)) 848 | 849 | #_(defn forms-seq 850 | "Lazy seq of forms in a Clojure or ClojureScript file." 851 | [^java.io.PushbackReader rdr] 852 | (let [eof (reify)] 853 | (lazy-seq 854 | (let [form (read rdr nil eof)] 855 | (when-not (identical? form eof) 856 | (lazy-seq (cons form (forms-seq rdr)))))))) 857 | 858 | (defn file-name-for-ns 859 | "Returns a file name representing the namespace" 860 | [ns-sym] 861 | (-> (@#'clojure.core/root-resource ns-sym) 862 | (str ".clj"))) 863 | 864 | (defn ^LineNumberingTextReader 865 | make-text-reader-for-ns 866 | "Returns a LineNumberingTextReader for namespace ns-sym" 867 | [ns-sym] 868 | (let [file-name (file-name-for-ns ns-sym)] 869 | (LineNumberingTextReader. (io/text-reader file-name)))) 870 | 871 | (defonce ^:private Compiler-members (set (map :name (:members (reflect/type-reflect RT))))) 872 | (defonce ^:private RT-members (set (map :name (:members (reflect/type-reflect RT))))) 873 | 874 | ;FIXME this is probably missing some things 875 | (defmacro ^:private thrd-bindings [source-path source-nsym pushback-reader] 876 | `(merge 877 | {;Compiler/LOADER (RT/makeClassLoader) 878 | 879 | ;FIXME can't access these? 880 | (field Compiler ~'SourcePathVar) (str ~source-path) 881 | (field Compiler ~'SourceVar) (str ~source-nsym) 882 | 883 | ;Compiler/METHOD nil 884 | ;Compiler/LOCAL_ENV nil 885 | ;Compiler/LOOP_LOCALS nil 886 | ;Compiler/NEXT_LOCAL_NUM 0 887 | RT/CurrentNSVar @RT/CurrentNSVar 888 | ; Compiler/LINE_BEFORE (.getLineNumber ~pushback-reader) 889 | ; Compiler/LINE_AFTER (.getLineNumber ~pushback-reader) 890 | RT/UncheckedMathVar @RT/UncheckedMathVar} 891 | ~(when (RT-members 'WarnOnReflection) 892 | `{(field RT ~'WarnOnReflection) @(field RT ~'WarnOnReflection)}) 893 | ; ~(when (Compiler-members 'COLUMN_BEFORE) 894 | ; `{Compiler/COLUMN_BEFORE (.getColumnNumber ~pushback-reader)}) 895 | ; ~(when (Compiler-members 'COLUMN_AFTER) 896 | ; `{Compiler/COLUMN_AFTER (.getColumnNumber ~pushback-reader)}) 897 | ~(when (RT-members 'DataReadersVar) 898 | `{RT/DataReadersVar @RT/DataReadersVar}) 899 | )) 900 | 901 | (defn analyze-ns 902 | "Takes a LineNumberingTextReader and a namespace symbol. 903 | Returns a vector of maps, with keys :op, :env. If expressions 904 | have children, will have :children entry. 905 | Optionally can use 906 | 907 | eg. (analyze-path 'my-ns)" 908 | ([source-nsym] (analyze-ns (make-text-reader-for-ns source-nsym) source-nsym source-nsym)) 909 | ([rdr source-path source-nsym] 910 | (let [eof (reify) 911 | ^LineNumberingTextReader 912 | pushback-reader (if (instance? LineNumberingTextReader rdr) 913 | rdr 914 | (LineNumberingTextReader. rdr))] 915 | (do 916 | (push-thread-bindings (thrd-bindings source-path source-nsym pushback-reader)) 917 | (try 918 | (let [eof (reify)] 919 | (loop [form (read pushback-reader nil eof) 920 | out []] 921 | (if (identical? form eof) 922 | out 923 | ;; FIXME shouldn't be source-nsym here 924 | (let [env {:ns {:name source-nsym} :context :eval :locals {}} 925 | m (analyze* env form) 926 | _ (eval form)] 927 | (recur (read pushback-reader nil eof) (conj out m)))))) 928 | (finally 929 | (pop-thread-bindings))))))) 930 | 931 | (comment 932 | (ast 933 | (try (throw (Exception.)) 934 | (catch Exception e (throw e)) 935 | (finally 33))) 936 | 937 | (ast 938 | (let [b 1] 939 | (fn [& a] 1))) 940 | 941 | (ast (Integer. (+ 1 1))) 942 | 943 | (ast (map io/file [1 2])) 944 | 945 | (ast (do 946 | (require '[clojure.repl :refer [pst]]) 947 | (pst))) 948 | (ast (deftype A [a b] 949 | Object 950 | (toString [this])))) 951 | --------------------------------------------------------------------------------