├── README.md ├── .gitignore ├── CONTRIBUTING.md ├── deps-clr.edn ├── src ├── main │ ├── clojure │ │ └── clojure │ │ │ └── tools │ │ │ └── analyzer │ │ │ ├── passes │ │ │ └── clr │ │ │ │ ├── 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 │ │ │ │ ├── emit_form.clj │ │ │ │ ├── box.clj │ │ │ │ ├── validate_loop_locals.clj │ │ │ │ ├── annotate_host_info.clj │ │ │ │ ├── analyze_host_expr.clj │ │ │ │ ├── infer_tag.clj │ │ │ │ └── validate.clj │ │ │ ├── clr │ │ │ └── utils.clj │ │ │ └── clr.clj │ └── dotnet │ │ └── packager │ │ ├── clojure.tools.analyzer.clr.sln │ │ └── clojure.tools.analyzer.clr.csproj └── test │ └── clojure │ └── clojure │ └── tools │ └── analyzer │ └── clr │ ├── core_test.clj │ └── passes_test.clj ├── project.clj ├── LICENSE ├── LICENSE.txt └── epl.html /README.md: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/clojure/tools.analyzer.clr/main/README.md -------------------------------------------------------------------------------- /.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 14 | 15 | 16 | 17 | #Visual Studio artifacts 18 | bin/ 19 | obj/ 20 | .vs/ 21 | *.user 22 | *.suo 23 | *.nupkg 24 | 25 | .cpcache/ -------------------------------------------------------------------------------- /CONTRIBUTING.md: -------------------------------------------------------------------------------- 1 | This is a [Clojure contrib] project. 2 | 3 | Under the Clojure contrib [guidelines], this project cannot accept 4 | pull requests. All patches must be submitted via [JIRA]. 5 | 6 | See [Contributing] on the Clojure website for 7 | more information on how to contribute. 8 | 9 | [Clojure contrib]: https://clojure.org/community/contrib_libs 10 | [Contributing]: https://clojure.org/community/contributing 11 | [JIRA]: https://clojure.atlassian.net/browse/TNS 12 | [guidelines]: https://clojure.org/community/contrib_howto -------------------------------------------------------------------------------- /deps-clr.edn: -------------------------------------------------------------------------------- 1 | {:paths ["src/main/clojure"] 2 | :deps 3 | { 4 | io.github.clojure/clr.tools.reader {:git/tag "v1.5.2" :git/sha "1a7a8e9"} 5 | io.github.clojure/clr.core.memoize {:git/tag "v1.1.266" :git/sha "a1a7f68"} 6 | io.github.clojure/tools.analyzer {:git/sha "4512ef15cea0559a507d0113be99072c9ce3f2f8"} 7 | } 8 | 9 | :aliases 10 | {:test 11 | {:extra-paths ["src/test/clojure"] 12 | :extra-deps {io.github.dmiller/test-runner {:git/sha "c055ea13d19c6a9b9632aa2370fcc2215c8043c3"}} 13 | :exec-fn cognitect.test-runner.api/test 14 | :exec-args {:dirs ["src/test/clojure"]}}}} 15 | 16 | 17 | -------------------------------------------------------------------------------- /src/main/clojure/clojure/tools/analyzer/passes/clr/fix_case_test.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.clr.fix-case-test 10 | (:require [clojure.tools.analyzer.passes.add-binding-atom :refer [add-binding-atom]])) 11 | 12 | (defn fix-case-test 13 | "If the node is a :case-test, annotates in the atom shared 14 | by the binding and the local node with :case-test" 15 | {:pass-info {:walk :pre :depends #{#'add-binding-atom}}} 16 | [ast] 17 | (when (:case-test ast) 18 | (swap! (:atom ast) assoc :case-test true)) 19 | ast) -------------------------------------------------------------------------------- /src/main/clojure/clojure/tools/analyzer/passes/clr/constant_lifter.clj: -------------------------------------------------------------------------------- 1 | (ns clojure.tools.analyzer.passes.clr.constant-lifter 2 | (:require [clojure.tools.analyzer.passes.constant-lifter :as orig] 3 | [clojure.tools.analyzer :refer [analyze-const]] 4 | [clojure.tools.analyzer.utils :refer [constant? classify]] 5 | [clojure.tools.analyzer.passes.clr.analyze-host-expr :refer [analyze-host-expr]] 6 | [clojure.tools.analyzer.passes.elide-meta :refer [elide-meta]])) 7 | 8 | (defn constant-lift* 9 | [ast] 10 | (if (= :var (:op ast)) 11 | (let [{:keys [var env form meta]} ast] 12 | (if (constant? var meta) 13 | (let [val @var] 14 | (assoc (analyze-const val env (classify val)) 15 | :form form)) 16 | ast)) 17 | (orig/constant-lift ast))) 18 | 19 | (defn constant-lift 20 | "Like clojure.tools.analyzer.passes.constant-lifter/constant-lift but 21 | transforms also :var nodes where the var has :const in the metadata 22 | into :const nodes and preserves tag info" 23 | {:pass-info {:walk :post :depends #{} :after #{#'elide-meta #'analyze-host-expr}}} 24 | [ast] 25 | (merge (constant-lift* ast) 26 | (select-keys ast [:tag :o-tag :return-tag :arglists]))) -------------------------------------------------------------------------------- /src/main/dotnet/packager/clojure.tools.analyzer.clr.sln: -------------------------------------------------------------------------------- 1 | 2 | Microsoft Visual Studio Solution File, Format Version 12.00 3 | # Visual Studio Version 17 4 | VisualStudioVersion = 17.4.33103.184 5 | MinimumVisualStudioVersion = 10.0.40219.1 6 | Project("{9A19103F-16F7-4668-BE54-9A1E7A4F7556}") = "clojure.tools.analyzer.clr", "clojure.tools.analyzer.clr.csproj", "{179EE132-B8E0-4890-950D-BC15E9B9DEC1}" 7 | EndProject 8 | Global 9 | GlobalSection(SolutionConfigurationPlatforms) = preSolution 10 | Debug|Any CPU = Debug|Any CPU 11 | Release|Any CPU = Release|Any CPU 12 | EndGlobalSection 13 | GlobalSection(ProjectConfigurationPlatforms) = postSolution 14 | {179EE132-B8E0-4890-950D-BC15E9B9DEC1}.Debug|Any CPU.ActiveCfg = Debug|Any CPU 15 | {179EE132-B8E0-4890-950D-BC15E9B9DEC1}.Debug|Any CPU.Build.0 = Debug|Any CPU 16 | {179EE132-B8E0-4890-950D-BC15E9B9DEC1}.Release|Any CPU.ActiveCfg = Release|Any CPU 17 | {179EE132-B8E0-4890-950D-BC15E9B9DEC1}.Release|Any CPU.Build.0 = Release|Any CPU 18 | EndGlobalSection 19 | GlobalSection(SolutionProperties) = preSolution 20 | HideSolutionNode = FALSE 21 | EndGlobalSection 22 | GlobalSection(ExtensibilityGlobals) = postSolution 23 | SolutionGuid = {BF859108-C401-4F9D-A4F0-4448B2C6021E} 24 | EndGlobalSection 25 | EndGlobal 26 | -------------------------------------------------------------------------------- /src/main/dotnet/packager/clojure.tools.analyzer.clr.csproj: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | netstandard2.0;netstandard2.1 5 | 6 | 7 | 8 | clojure.tools.analyzer.clr 9 | clojure.tools 10 | clojure.tools.analyzer.clr 11 | clojure.tools.analyzer.clr 12 | clojure.tools.analyzer.clr 13 | ClojureCLR Contributors 14 | A port of tools.analyzer.jvm to ClojureCLR. 15 | Copyright © Rich Hickey, ClojureCLR contributors 2025 16 | EPL-1.0 17 | https://github.com/clojure/clojure.tools.namesapce 18 | ClojureCLR contributors 19 | Clojure;ClojureCLR 20 | 1.3.2 21 | 22 | 23 | 24 | 25 | 26 | 27 | 28 | 29 | 30 | 31 | 32 | 33 | 34 | -------------------------------------------------------------------------------- /src/main/clojure/clojure/tools/analyzer/passes/clr/annotate_branch.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.clr.annotate-branch) 10 | 11 | (defmulti annotate-branch 12 | "Adds :branch? to branch AST nodes (if/case), :test? to the test children 13 | node of the branching op and :path? to the branching paths. 14 | 15 | Example: {:op if :branch? true :test {:test? true ..} :then {:path? true ..} ..}" 16 | {:pass-info {:walk :any :depends #{}}} 17 | :op) 18 | 19 | (defmethod annotate-branch :if 20 | [ast] 21 | (-> 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) -------------------------------------------------------------------------------- /src/main/clojure/clojure/tools/analyzer/passes/clr/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.clr.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) -------------------------------------------------------------------------------- /project.clj: -------------------------------------------------------------------------------- 1 | (defproject org.clojure.clr/tools.analyzer.clr "1.3.2" 2 | :description "Port of clojure.org/tools.analyzer.clr to ClojureCLR" 3 | :url "https://github.com/clojure/tools.analyzer.clr" 4 | :license {:name "Eclipse Public License" 5 | :url "http://www.eclipse.org/legal/epl-v10.html"} 6 | :source-paths ["src/main/clojure" "src/main/lib"] 7 | :test-paths ["src/test/clojure"] 8 | :dependencies [[org.clojure/tools.analyzer "1.1.1"] 9 | [org.clojure.clr/core.memoize "1.1.266"] 10 | [org.clojure.clr/tools.reader "1.5.2"]] 11 | :deploy-repositories [["clojars" {:url "https://clojars.org/repo/" 12 | :sign-releases false}]] 13 | :min-lein-version "2.0.0" 14 | :plugins [[lein-clr "0.2.0"]] 15 | :clr {:cmd-templates {:clj-exe [#_"mono" [CLJCLR15_40 %1]] 16 | :clj-dep [#_"mono" ["target/clr/clj/Debug 4.0" %1]] 17 | :clj-url "https://github.com/downloads/clojure/clojure-clr/clojure-clr-1.4.1-Debug-4.0.zip" 18 | :clj-zip "clojure-clr-1.4.1-Debug-4.0.zip" 19 | :curl ["curl" "--insecure" "-f" "-L" "-o" %1 %2] 20 | :nuget-ver [#_"mono" [*PATH "nuget.exe"] "install" %1 "-Version" %2] 21 | :nuget-any [#_"mono" [*PATH "nuget.exe"] "install" %1] 22 | :unzip ["unzip" "-d" %1 %2] 23 | :wget ["wget" "--no-check-certificate" "--no-clobber" "-O" %1 %2]} 24 | ;; for automatic download/unzip of ClojureCLR, 25 | ;; 1. make sure you have curl or wget installed and on PATH, 26 | ;; 2. uncomment deps in :deps-cmds, and 27 | ;; 3. use :clj-dep instead of :clj-exe in :main-cmd and :compile-cmd 28 | :deps-cmds [ ;[:wget :clj-zip :clj-url] ; edit to use :curl instead of :wget 29 | ;[:unzip "../clj" :clj-zip] 30 | ] 31 | :main-cmd [:clj-exe "Clojure.Main.exe"] 32 | :compile-cmd [:clj-exe "Clojure.Compile.exe"]}) -------------------------------------------------------------------------------- /src/main/clojure/clojure/tools/analyzer/passes/clr/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.clr.warn-on-reflection 10 | (:require [clojure.tools.analyzer.passes.clr 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 " (.FullName ^Type class))) ;;; .getName ^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 | (.FullName ^Type (:class ast)) " cannot be resolved") ;;; .getName ^Class 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 " (.FullName ^Type (:val (:class ast))) " ctor cannot be resolved") ;;; .getName ^Class 59 | (:env ast))) 60 | ast) 61 | 62 | (defmethod warn-on-reflection :default [ast] ast) -------------------------------------------------------------------------------- /src/main/clojure/clojure/tools/analyzer/passes/clr/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.clr.annotate-tag 10 | (:require [clojure.tools.analyzer.clr.utils :refer [unbox maybe-class]] 11 | [clojure.tools.analyzer.passes.clr.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 Char :tag Char) ;;; Character/TYPE 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 (#{System.Void} o-tag) ;;; Void/TYPE removed 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)) -------------------------------------------------------------------------------- /src/main/clojure/clojure/tools/analyzer/passes/clr/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.clr.classify-invoke 10 | (:require [clojure.tools.analyzer.utils :refer [arglist-for-arity protocol-node? source-info]] 11 | [clojure.tools.analyzer.clr.utils 12 | :refer [specials prim-interface]] 13 | [clojure.tools.analyzer.passes.clr.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 ;;; Boolean/TYPE 64 | :tag (or tag Boolean) ;;; 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)))))) -------------------------------------------------------------------------------- /src/main/clojure/clojure/tools/analyzer/passes/clr/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.clr.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)) -------------------------------------------------------------------------------- /src/test/clojure/clojure/tools/analyzer/clr/core_test.clj: -------------------------------------------------------------------------------- 1 | (ns clojure.tools.analyzer.clr.core-test 2 | (:refer-clojure :exclude [macroexpand-1]) 3 | (:require [clojure.tools.analyzer :as ana] 4 | [clojure.tools.analyzer.clr :as ana.clr] 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 | (assembly-load-from (str clojure.lang.RT/SystemRuntimeDirectory "System.ComponentModel.dll")) 12 | 13 | (defprotocol p (f [_])) 14 | (defn f1 [^long x]) 15 | (def e (ana.clr/empty-env)) 16 | 17 | (defmacro ast [form] 18 | `(binding [ana/macroexpand-1 ana.clr/macroexpand-1 19 | ana/create-var ana.clr/create-var 20 | ana/parse ana.clr/parse 21 | ana/var? var? 22 | elides {:all #{:line :column :file}}] 23 | (env/with-env (ana.clr/global-env) 24 | (postwalk (ana/analyze '~form e) elide-meta)))) 25 | 26 | (defn ana [form] 27 | (binding [ana/macroexpand-1 ana.clr/macroexpand-1 28 | ana/create-var ana.clr/create-var 29 | ana/parse ana.clr/parse 30 | ana/var? var? 31 | elides {:all #{:line :column :file}}] 32 | (ana.clr/analyze form e))) 33 | 34 | (defmacro ast1 [form] 35 | `(ana '~form)) 36 | 37 | (defmacro mexpand [form] 38 | `(ana.clr/macroexpand-1 '~form e)) 39 | 40 | (deftest macroexpander-test 41 | (is (= (list '. (list 'do System.Object) 'ToString) ;;; java.lang.Object toString 42 | (mexpand (.ToString Object)))) ;;; .toString 43 | (is (= (list '. System.Int32 '(Parse "2")) (mexpand (Int32/Parse "2"))))) ;;; java.lang.Integer parseInt Integer/parseInt 44 | 45 | (deftest analyzer-test 46 | 47 | (let [v-ast (ast #'+)] 48 | (is (= :the-var (:op v-ast))) 49 | (is (= #'+ (:var v-ast)))) 50 | 51 | (let [mn-ast (ast (monitor-enter 1))] 52 | (is (= :monitor-enter (:op mn-ast))) 53 | (is (= 1 (-> mn-ast :target :form)))) 54 | 55 | (let [mx-ast (ast (monitor-exit 1))] 56 | (is (= :monitor-exit (:op mx-ast))) 57 | (is (= 1 (-> mx-ast :target :form)))) 58 | 59 | (let [i-ast (ast (clojure.core/import* "System.String"))] ;;; "java.lang.String" 60 | (is (= :import (:op i-ast))) 61 | (is (= "System.String" (:class i-ast)))) ;;; "java.lang.String" 62 | 63 | (let [r-ast (ast ^:foo (reify 64 | Object (ToString [this] "") ;;; toString 65 | System.IServiceProvider (GetService [this ^Type serviceType] this)))] ;;; Appendable (^Appendable append [this ^char x] this) 66 | (is (= :with-meta (-> r-ast :op))) ;; line/column info 67 | (is (= :reify (-> r-ast :expr :op))) 68 | (is (= #{System.IServiceProvider clojure.lang.IObj} (-> r-ast :expr :interfaces))) ;;; #{Appendable clojure.lang.IObj} 69 | (is (= '#{ToString GetService} (->> r-ast :expr :methods (mapv :name) set)))) ;;; #{toString append} 70 | 71 | (let [dt-ast (ast (deftype* x user.x [a b] 72 | :implements [System.IServiceProvider] ;;; Appendable 73 | (GetService [this ^Type serviceType] this)))] ;;; (^Appendable append [this ^char x] this) 74 | (is (= :deftype (-> dt-ast :op))) 75 | (is (= '[a b] (->> dt-ast :fields (mapv :name)))) 76 | (is (= '[GetService] (->> dt-ast :methods (mapv :name)))) ;;; append 77 | (is (= 'user.x (-> dt-ast :class-name)))) 78 | 79 | (let [c-ast (ast (case* 1 0 0 :number {2 [2 :two] 3 [3 :three]} :compact :int))] 80 | (is (= :number (-> c-ast :default :form))) 81 | (is (= #{2 3} (->> c-ast :tests (mapv (comp :form :test)) set))) 82 | (is (= #{:three :two} (->> c-ast :thens (mapv (comp :form :then)) set))) 83 | (is (= 3 (-> c-ast :high))) 84 | (is (= :int (-> c-ast :test-type))) 85 | (is (= :compact (-> c-ast :switch-type))) 86 | (is (= 2 (-> c-ast :low))) 87 | (is (= 0 (-> c-ast :shift))) 88 | (is (= 0 (-> c-ast :mask)))) 89 | 90 | (is (= Exception (-> (ast1 (try (catch :default e))) :catches first :class :val))) ;;; Throwable 91 | (is (= Exception (-> (ast1 (try (catch Exception e e))) :catches first :body :tag)))) 92 | 93 | (deftest doseq-chunk-hint 94 | (let [tree (ast1 (doseq [item (range 10)] 95 | (println item))) 96 | {[_ chunk] :bindings} tree] 97 | (is (= :loop (:op tree))) 98 | (is (.StartsWith (name (:name chunk)) "chunk")) ;;; .StartsWith 99 | (is (= clojure.lang.IChunk (:tag chunk))))) 100 | 101 | (def ^:dynamic x) 102 | (deftest set!-dynamic-var 103 | (is (ast1 (set! x 1)))) 104 | 105 | (deftest analyze-proxy 106 | (is (ast1 (proxy [Object] [])))) 107 | 108 | (deftest analyze-record 109 | (is (ast1 (defrecord TestRecord [x y])))) 110 | 111 | (deftest eq-no-reflection 112 | (is (:validated? (-> (ast1 (fn [s] (= s \f))) :expr :methods first :body)))) ;;; I had to add the :expr to get this to work. 113 | 114 | (deftest analyze+eval-context-test 115 | (let [do-ast (ana.clr/analyze+eval '(do 1 2 3))] 116 | (is (= :ctx/statement (-> do-ast :statements first :env :context))))) 117 | 118 | (deftest array_class 119 | (is (ana (r/read-string "(fn [^{:tag int/2} x] (instance? int/2 x))")))) -------------------------------------------------------------------------------- /src/main/clojure/clojure/tools/analyzer/passes/clr/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.clr.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 (.FullName ^Type val)) ;;; .getName ^Class 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 | (.FullName ^Type class))) ;;; .getName ^Class 83 | 84 | (defn class->sym [class] 85 | (if (symbol? class) 86 | class 87 | (symbol (.FullName ^Type class)))) ;;; .getName ^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))) -------------------------------------------------------------------------------- /src/main/clojure/clojure/tools/analyzer/passes/clr/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.clr.box 10 | (:require [clojure.tools.analyzer.clr.utils :as u] 11 | [clojure.tools.analyzer.utils :refer [protocol-node? arglist-for-arity]] 12 | [clojure.tools.analyzer.passes.clr 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 (#{System.Void} tag)) ;;; Void/TYPE removed 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 (#{System.Void} tag)) ;;; Void/TYPE removed 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 test-tag)) ;;; Boolean/TYPE 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) -------------------------------------------------------------------------------- /src/main/clojure/clojure/tools/analyzer/passes/clr/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.clr.validate-loop-locals 10 | (:require [clojure.tools.analyzer.ast :refer [postwalk children update-children]] 11 | [clojure.tools.analyzer.clr.utils :refer [wider-tag maybe-class primitive?]] 12 | [clojure.tools.analyzer.passes.clr 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))) -------------------------------------------------------------------------------- /src/main/clojure/clojure/tools/analyzer/passes/clr/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.clr.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.clr.utils 17 | :refer [members name-matches? try-best-match maybe-class] ;;; Added maybe-class 18 | :as u])) 19 | 20 | ;;; Added this deal with explicit interface implementation. 21 | (defn explicit-implementation-name-matches 22 | [impl-method-name interface-method-name] 23 | (let [member-name (str impl-method-name ) 24 | i (.LastIndexOf member-name ".")] 25 | (and (pos? i) (= (subs member-name (inc i)) (str interface-method-name))))) 26 | 27 | 28 | (defn annotate-host-info 29 | "Adds a :methods key to reify/deftype :methods info representing 30 | the reflected informations for the required methods, replaces 31 | (catch :default ..) forms with (catch Throwable ..)" 32 | {:pass-info {:walk :pre :depends #{} :after #{#'elide-meta}}} 33 | [{:keys [op methods interfaces class env] :as ast}] 34 | (case op 35 | (:reify :deftype) 36 | (let [all-methods 37 | (into #{} 38 | (mapcat (fn [class] 39 | (mapv (fn [method] 40 | (dissoc method :exception-types)) 41 | (filter (fn [{:keys [flags return-type]}] 42 | (and return-type (not-any? #{:final :static} flags))) 43 | (members class)))) 44 | (conj interfaces Object)))] 45 | (assoc ast :methods (mapv (fn [ast] 46 | (let [name (:name ast) 47 | argc (count (:params ast))] 48 | (assoc ast :methods 49 | (filter #(and (or ((name-matches? name) (:name %)) 50 | (explicit-implementation-name-matches name (:name %))) 51 | (= argc (count (:parameter-types %)))) 52 | all-methods)))) methods))) 53 | 54 | 55 | :catch 56 | (let [the-class (cond 57 | 58 | (and (= :const (:op class)) 59 | (= :default (:form class))) 60 | Exception ;;; Throwable 61 | 62 | (= :maybe-class (:op class)) 63 | (u/maybe-class-literal (:class class))) 64 | 65 | ast (if the-class 66 | (-> ast 67 | (assoc :class (assoc (ana/analyze-const the-class env :class) 68 | :form (:form class) 69 | :tag Type ;;; Class 70 | :o-tag Type))) ;;; Class 71 | ast)] 72 | (assoc-in ast [:local :tag] (-> ast :class :val))) 73 | 74 | 75 | :method 76 | ;; this should actually be in validate but it's here since it needs to be prewalked 77 | ;; for infer-tag purposes 78 | (let [{:keys [name class tag form params fixed-arity env]} ast] 79 | (if interfaces 80 | (let [tags (mapv (comp u/maybe-class :tag meta :form) params) 81 | methods-set (set (mapv (fn [x] (dissoc x :declaring-class :flags)) methods)) 82 | methods-to-test 83 | (let [method-name (str name) 84 | i (.LastIndexOf method-name ".") 85 | explicit? (pos? i)] 86 | (if explicit? 87 | (let [name (subs method-name (inc i)) 88 | i-name (subs method-name 0 i) 89 | i-class (maybe-class i-name)] 90 | (filter #(and (= name (str (:name %))) (= i-class (maybe-class (str (:declaring-class %))))) 91 | methods)) 92 | methods))] 93 | (let [[m & rest :as matches] (try-best-match tags methods-to-test)] 94 | (if m 95 | (let [ret-tag (u/maybe-class (:return-type m)) 96 | i-tag (u/maybe-class (:declaring-class m)) 97 | arg-tags (mapv u/maybe-class (:parameter-types m)) 98 | params (mapv (fn [{:keys [atom] :as arg} tag] 99 | (assoc arg :tag tag :o-tag tag)) params arg-tags)] 100 | (if (or (empty? rest) 101 | (every? (fn [{:keys [return-type parameter-types]}] 102 | (and (= (u/maybe-class return-type) ret-tag) 103 | (= arg-tags (mapv u/maybe-class parameter-types)))) rest)) 104 | (assoc (dissoc ast :interfaces :methods) 105 | :bridges (filter #(and (= arg-tags (mapv u/maybe-class (:parameter-types %))) 106 | (.IsAssignableFrom (u/maybe-class (:return-type %)) ret-tag)) ;;; .isAssignableFrom 107 | (disj methods-set (dissoc m :declaring-class :flags))) 108 | :methods methods 109 | :interface i-tag 110 | :tag ret-tag 111 | :o-tag ret-tag 112 | :params params) 113 | (throw (ex-info (str "Ambiguous method signature for method: " name) 114 | (merge {:method name 115 | :interfaces interfaces 116 | :form form 117 | :params (mapv (fn [x] (prewalk x cleanup)) params) 118 | :matches matches} 119 | (source-info env)))))) 120 | (throw (ex-info (str "No such method found: " name " with given signature in any of the" 121 | " provided interfaces: " interfaces) 122 | (merge {:method name 123 | :methods methods 124 | :interfaces interfaces 125 | :form form 126 | :params params} 127 | (source-info env))))))) 128 | ast)) 129 | ast)) -------------------------------------------------------------------------------- /src/main/clojure/clojure/tools/analyzer/passes/clr/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.clr.analyze-host-expr 10 | (:require [clojure.tools.analyzer :as ana] 11 | [clojure.tools.analyzer.utils :refer [ctx source-info merge']] 12 | [clojure.tools.analyzer.clr.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 Type ;;; Class 158 | :o-tag Type)) ;;; 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) ".")) ;;; .indexOf 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)) -------------------------------------------------------------------------------- /src/test/clojure/clojure/tools/analyzer/clr/passes_test.clj: -------------------------------------------------------------------------------- 1 | (ns clojure.tools.analyzer.clr.passes-test 2 | (:refer-clojure :exclude [macroexpand-1]) 3 | (:require [clojure.tools.analyzer.ast :refer :all] 4 | [clojure.tools.analyzer.clr :as ana.clr] 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.clr.core-test :refer [ast ast1 e f f1]] 12 | [clojure.tools.analyzer.passes.clr.emit-form 13 | :refer [emit-form emit-hygienic-form]] 14 | [clojure.tools.analyzer.passes.clr.validate :as v] 15 | [clojure.tools.analyzer.passes.clr.annotate-tag :refer [annotate-tag]] 16 | [clojure.tools.analyzer.passes.clr.infer-tag :refer [infer-tag]] 17 | [clojure.tools.analyzer.passes.clr.annotate-branch :refer [annotate-branch]] 18 | [clojure.tools.analyzer.passes.clr.annotate-host-info :refer [annotate-host-info]] 19 | [clojure.tools.analyzer.passes.clr.annotate-loops :refer [annotate-loops]] 20 | [clojure.tools.analyzer.passes.clr.fix-case-test :refer [fix-case-test]] 21 | [clojure.tools.analyzer.passes.clr.analyze-host-expr :refer [analyze-host-expr]] 22 | [clojure.tools.analyzer.passes.clr.classify-invoke :refer [classify-invoke]]) 23 | (:import (clojure.lang Keyword Var Symbol AFunction 24 | PersistentVector PersistentArrayMap PersistentHashSet ISeq) 25 | System.Text.RegularExpressions.Regex)) ;;; 26 | 27 | (defn validate [ast] 28 | (env/with-env (ana.clr/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* "System.String") ;;; "java.lang.String" 35 | (emit-form (validate (ast (clojure.core/import* "System.String")))))) ;;; "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.clr/analyze '(try 1 (catch Exception e)))))) 40 | (is (= '(try 1 (catch Exception e nil)) 41 | (emit-form (ana.clr/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 (= System.RuntimeType (-> {:op :const :type :class :form Object :val Object} ;;; Class 74 | annotate-tag :tag))) 75 | (is (= String (-> (ast "foo") annotate-tag :tag))) 76 | (is (= Keyword (-> (ast :foo) annotate-tag :tag))) 77 | (is (= Char (-> (ast \f) annotate-tag :tag))) ;;; Character/TYPE 78 | (is (= Int64 (-> (ast 1) annotate-tag :tag))) ;;; Long/TYPE 79 | (is (= Regex (-> (ast #"foo") annotate-tag :tag))) ;;; Pattern 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 (= Int64 (-> b-ast :body :ret :tag))))) ;;; Long/TYPE 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)))) ;;; FAIL -- Why do we get :invoke instead of :prim-invoke? 93 | 94 | (deftest annotate-host-info-test 95 | (let [r-ast (-> (ast ^:foo (reify Object (ToString [_] ""))) (prewalk annotate-host-info))] ;;; toString 96 | (is (= 'ToString (-> r-ast :expr :methods first :name))) ;;; toString 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. \a (int 5))) (postwalk (comp validate annotate-tag analyze-host-expr)) ;;; 106 | :validated?))) 107 | 108 | (let [s-ast (-> (ast (Int32/Parse "7")) (prewalk annotate-tag) analyze-host-expr validate)] ;;;Integer/parseInt 109 | (is (:validated? s-ast)) 110 | (is (= Int32 (:tag s-ast))) ;;; Integer/TYPE 111 | (is (= [String] (mapv :tag (:args s-ast))))) 112 | 113 | (let [i-ast (-> (ast (.GetHashCode "7")) (prewalk annotate-tag) analyze-host-expr validate)] ;;; .hashCode 114 | (is (:validated? i-ast)) 115 | (is (= Int32 (:tag i-ast))) ;;; Integer/TYPE 116 | (is (= [] (mapv :tag (:args i-ast)))) 117 | (is (= String (:class i-ast)))) 118 | 119 | (is (= true (-> (ast (import System.String)) (prewalk validate) :ret :validated?)))) ;;; java.lang.String 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 (Int32/Parse c b)] ;;; Integer/parseInt 127 | (Int32/Parse c b)))] ;;; (Integer/getInteger c d) - no direct equivalent. Need to adjust. 128 | (is (= Int32 (-> t-ast :body :tag))) ;;; Integer 129 | (is (= Int32 (-> t-ast :tag))) ;;; Integer 130 | (is (= Int64 (->> t-ast :bindings (filter #(= 'a (:form %))) first :tag))) ;;; Long/TYPE 131 | (is (= String (->> t-ast :bindings (filter #(= 'c (:form %))) first :tag))) 132 | (is (= Int32 (->> t-ast :bindings (filter #(= 'd (:form %))) first :tag)))) ;;; Integer/TYPE 133 | (is (= Void (:tag (ast1 (.Write System.Console/Out "foo"))))) ;;; Void/TYPE .println System/out 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/IsInfinity 2))] ;;; Double/isInfinite 141 | (is (= Boolean (-> d-ast :tag))) ;;; Boolean/TYPE 142 | (is (= Double (->> d-ast :args first :tag))))) ;;; Double/TYPE 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.clr/analyze '(def a "foo") 150 | (ana.clr/empty-env) 151 | {:passes-opts (merge ana.clr/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.clr/analyze '(defn ^long a [] 1) 160 | (ana.clr/empty-env) 161 | {:passes-opts (merge ana.clr/default-passes-opts 162 | {:validate/wrong-tag-handler (fn [t ast] 163 | {t nil})})}))) -------------------------------------------------------------------------------- /src/main/clojure/clojure/tools/analyzer/passes/clr/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.clr.infer-tag 10 | (:require [clojure.tools.analyzer.utils :refer [arglist-for-arity]] 11 | [clojure.tools.analyzer.clr.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.clr 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 (#{System.Void} tag) ;;; Void Void/TYPE 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 (#{System.Void} tag) ;;; Void Void/TYPE 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})))) -------------------------------------------------------------------------------- /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 | -------------------------------------------------------------------------------- /LICENSE.txt: -------------------------------------------------------------------------------- 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 | -------------------------------------------------------------------------------- /epl.html: -------------------------------------------------------------------------------- 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 | -------------------------------------------------------------------------------- /src/main/clojure/clojure/tools/analyzer/passes/clr/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.clr.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.clr 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.clr.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) ".")) ;;; .contains 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 [^Type class (-> ast :class :val) ;;; Class 68 | c-name '.ctor ;;; (symbol (.getName class)) -- ctors are named .ctor, not with the class name 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) ;;; .lastIndexOf 161 | sym-val (resolve-sym class-sym env)] 162 | (if (and (class? sym-val) (not= (.FullName ^Type sym-val) class)) ;; allow deftype redef ;;; .getName ^Class 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 | (.FullName ^Type (:var ast))) ;;; .getName ^Class 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 ^Type %) (disj interfaces Object)) ;;; .isInterface ^Class 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))))) -------------------------------------------------------------------------------- /src/main/clojure/clojure/tools/analyzer/clr/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.clr.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.clr.io :as io]) ;;; [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/->ClrReflector nil) ;;; (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 ;;; Byte/TYPE 44 | "boolean" Boolean ;;; Boolean/TYPE 45 | "char" Char ;;; Character/TYPE 46 | "int" Int32 ;;; Integer/TYPE 47 | "long" Int64 ;;; Long/TYPE 48 | "float" Single ;;; Float/TYPE 49 | "double" Double ;;; Double/TYPE 50 | "short" Int16 ;;; Short/TYPE 51 | "void" System.Void ;;; Void/TYPE 52 | "object" Object ;;; DM: Added 53 | "decimal" Decimal ;;; DM: Added 54 | "sbyte" SByte ;;; DM: Added 55 | "ushort" UInt16 ;;; DM: Added 56 | "uint" UInt32 ;;; DM: Added 57 | "ulong" UInt64 ;;; DM: Added 58 | nil)) 59 | 60 | (defn special-arrays [c] 61 | (case c 62 | "bytes" |System.Byte[]| ;;; (Class/forName "[B") 63 | "booleans" |System.Boolean[]| ;;; (Class/forName "[Z") 64 | "chars" |System.Char[]| ;;; (Class/forName "[C") 65 | "ints" |System.Int32[]| ;;; (Class/forName "[I") 66 | "longs" |System.Int64[]| ;;; (Class/forName "[J") 67 | "floats" |System.Single[]| ;;; (Class/forName "[F") 68 | "doubles" |System.Double[]| ;;; (Class/forName "[D") 69 | "shorts" |System.Int16[]| ;;; (Class/forName "[S") 70 | "objects" |System.Object[]| ;;; (Class/forName "[Ljava.lang.Object;") 71 | "sbytes" |System.SByte[]| ;;; DM: Added 72 | "ushorts" |System.Int16[]| ;;; DM: Added 73 | "uints" |System.Int32[]| ;;; DM: Added 74 | "ulongs" |System.Int64[]| ;;; DM: Added 75 | "decimals" |System.Decimal[]| ;;; DM: Added 76 | nil)) 77 | 78 | (defmulti ^Type maybe-class ;;; ^Class 79 | "Takes a Symbol, String or Class and tires to resolve to a matching Class" 80 | class) 81 | 82 | ;;;(defn array-class 83 | ;;; ([element-type] (array-class 1 element-type)) 84 | ;;; ([n element-type] 85 | ;;; (RT/classForName 86 | ;;; (str (apply str (repeat n"[")) 87 | ;;; (-> element-type 88 | ;;; maybe-class 89 | ;;; Type/getType 90 | ;;; .getDescriptor 91 | ;;; (.replace \/ \.)))))) 92 | 93 | (defn array-class 94 | ([element-type] (array-class 1 element-type)) 95 | ([n element-type] 96 | (RT/classForName 97 | (str (-> element-type 98 | maybe-class 99 | .FullName 100 | (.Replace \/ \.)) 101 | (apply str (repeat n "[]")))))) 102 | 103 | (defn maybe-class-from-string [^String s] 104 | (or (when-let [maybe-class (and (neg? (.IndexOf s ".")) ;;; .indexOf 105 | (not= \] (last s)) ;;; (not= \[ (first s)) 106 | (if env/*env* 107 | (u/resolve-sym (symbol s) {:ns (ns-name *ns*)}) 108 | ((ns-map *ns*) (symbol s))))] 109 | (when (class? maybe-class) maybe-class)) 110 | (try (RT/classForName s) 111 | (catch Exception _)))) ;;; ClassNotFoundException 112 | 113 | (defmethod maybe-class :default [_] nil) 114 | (defmethod maybe-class Type [c] c) ;;; Class 115 | (defmethod maybe-class String [s] 116 | (maybe-class (symbol s))) 117 | 118 | (defn maybe-array-class-sym [x] 119 | (let [sname (name x)] 120 | (if-let [c (and (= (count sname) 1) 121 | (Char/IsDigit (char (first sname))) ;;; Character/isDigit 122 | (namespace x))] 123 | (when-let [c (or (specials c) 124 | (maybe-class-from-string c))] 125 | (array-class (Int32/Parse sname) c))))) ;;; Integer/parseInt 126 | 127 | (defmethod maybe-class Symbol [sym] 128 | (let [sname (name sym) 129 | snamec (count sname)] 130 | (or (maybe-array-class-sym sym) 131 | (when-not (namespace sym) 132 | (if-let [base-type (and (.EndsWith sname "<>") ;;; .endsWith 133 | (maybe-class (subs sname 0 (- snamec 2))))] 134 | ;; TODO: we're leaking into the syntax 135 | (array-class base-type) 136 | (if-let [ret (or (specials sname) 137 | (special-arrays sname))] 138 | ret 139 | (maybe-class-from-string sname))))))) 140 | 141 | (defn maybe-class-literal [x] 142 | (cond 143 | (class? x) x 144 | (symbol? x) (or (maybe-array-class-sym x) 145 | (and (not (namespace x)) 146 | (maybe-class-from-string (name x)))) 147 | (string? x) (maybe-class-from-string x))) 148 | 149 | (def primitive? 150 | "Returns non-nil if the argument represents a primitive Class other than Void" 151 | #{Double Char Byte Boolean SByte Decimal ;;; Double/TYPE Character/TYPE Byte/TYPE Boolean/TYPE 152 | Int16 Single Int64 Int32 UInt16 UInt64 UInt32}) ;;; Short/TYPE Float/TYPE Long/TYPE Integer/TYPE}) 153 | 154 | (def ^:private convertible-primitives ;;; TODO: DM: Really need to see where this is used and fix it 155 | "If the argument is a primitive Class, returns a set of Classes 156 | to which the primitive Class can be casted" 157 | {Int32 #{Int32 Int64 Int16 Byte SByte} ;;; Integer/TYPE #{Integer Long/TYPE Long Short/TYPE Byte/TYPE} 158 | Single #{Single Double} ;;; Float/TYPE #{Float Double/TYPE} 159 | Double #{Double Single} ;;; Double/TYPE #{Double Float/TYPE} 160 | Int64 #{Int64 Int32 Int16 Byte} ;;; Long/TYPE #{Long Integer/TYPE Short/TYPE Byte/TYPE} 161 | Char #{Char} ;;; Character/TYPE #{Character} 162 | Int16 #{Int16} ;;; Short/TYPE #{Short} 163 | Byte #{Byte} ;;; Byte/TYPE #{Byte} 164 | Boolean #{Boolean} ;;; Boolean/TYPE #{Boolean} 165 | UInt32 #{Int32 Int64 Int16 Byte SByte} ;;; DM: Added 166 | UInt64 #{Int64 Int32 Int16 Byte} ;;; DM: Added 167 | UInt16 #{Int16} ;;; DM: Added 168 | SByte #{SByte} ;;; DM: Added 169 | Decimal #{Decimal} ;;; DM: Added 170 | System.Void #{System.Void}}) ;;; Void/TYPE #{Void} 171 | 172 | (defn ^Type box ;;; ^Class 173 | "If the argument is a primitive Class, returns its boxed equivalent, 174 | otherwise returns the argument" 175 | [c] 176 | #_({Integer/TYPE Integer 177 | Float/TYPE Float 178 | Double/TYPE Double 179 | Long/TYPE Long 180 | Character/TYPE Character 181 | Short/TYPE Short 182 | Byte/TYPE Byte 183 | Boolean/TYPE Boolean 184 | Void/TYPE Void} 185 | c c) 186 | c) 187 | 188 | (defn ^Type unbox ;;; ^Class 189 | "If the argument is a Class with a primitive equivalent, returns that, 190 | otherwise returns the argument" 191 | [c] 192 | #_({Integer Integer/TYPE, 193 | Long Long/TYPE, 194 | Float Float/TYPE, 195 | Short Short/TYPE, 196 | Boolean Boolean/TYPE, 197 | Byte Byte/TYPE, 198 | Character Character/TYPE, 199 | Double Double/TYPE, 200 | Void Void/TYPE} 201 | c c) 202 | c) 203 | 204 | (defn numeric? 205 | "Returns true if the given class is numeric" 206 | [c] 207 | (when c 208 | (clojure.lang.Util/IsNumeric ^Type c))) ;;; (.isAssignableFrom Number (box c)) 209 | 210 | (defn subsumes? 211 | "Returns true if c2 is subsumed by c1" 212 | [c1 c2] 213 | (let [c1 (maybe-class c1) 214 | c2 (maybe-class c2)] 215 | (and (not= c1 c2) 216 | (or (and (not (primitive? c1)) 217 | (primitive? c2)) 218 | (.IsAssignableFrom c2 c1))))) ;;; .isAssignableFrom 219 | 220 | (defn convertible? 221 | "Returns true if it's possible to convert from c1 to c2" 222 | [c1 c2] 223 | (let [c1 (maybe-class c1) 224 | c2 (maybe-class c2)] 225 | (if (nil? c1) 226 | (not (primitive? c2)) 227 | (or 228 | (= c1 c2) 229 | (.IsAssignableFrom c2 c1) ;;; .isAssignableFrom 230 | (and (primitive? c2) 231 | ((convertible-primitives c2) c1)) 232 | (and (primitive? c1) 233 | (.IsAssignableFrom (box c1) c2)))))) ;;; .isAssignableFrom 234 | 235 | (def wider-than 236 | "If the argument is a numeric primitive Class, returns a set of primitive Classes 237 | that are narrower than the given one" 238 | {Int64 #{Int32 UInt32 Int16 UInt16 Byte SByte} ;;; Long/TYPE #{Integer/TYPE Short/TYPE Byte/TYPE} 239 | Int32 #{Int16 UInt16 Byte SByte} ;;; Integer/TYPE #{Short/TYPE Byte/TYPE} 240 | Single #{Int32 UInt32 Int16 UInt16 Byte SByte} ;;; Float/TYPE #{Integer/TYPE Short/TYPE Byte/TYPE Long/TYPE} 241 | Double #{Int32 UInt32 Int16 UInt16 Byte SByte Single} ;;; Double/TYPE #{Integer/TYPE Short/TYPE Byte/TYPE Long/TYPE Float/TYPE} 242 | Int16 #{Byte SByte} ;;; Short/TYPE #{Byte/TYPE} 243 | UInt64 #{Int32 UInt32 Int16 UInt16 Byte SByte} ;;; DM: Added 244 | UInt32 #{Int16 UInt16 Byte SByte} ;;; DM: Added 245 | UInt16 #{Byte SByte} ;;; DM: Added 246 | Decimal #{} ;;; DM: Added 247 | Byte #{}}) ;;; Byte/TYPE #{} 248 | 249 | (defn wider-primitive 250 | "Given two numeric primitive Classes, returns the wider one" 251 | [from to] 252 | (if ((wider-than from) to) 253 | from 254 | to)) 255 | 256 | (defn wider-tag* 257 | "Given two Classes returns the wider one" 258 | [from to] 259 | (if (not= from to) 260 | (if (primitive? from) 261 | (if (primitive? to) 262 | (wider-primitive from to) 263 | (or (and (numeric? from) 264 | (numeric? to) 265 | to) 266 | ((convertible-primitives from) to))) 267 | (if (primitive? to) 268 | (or (and (numeric? from) 269 | (numeric? to) 270 | from) 271 | ((convertible-primitives to) from)) 272 | (if (convertible? from to) 273 | to 274 | (when (convertible? to from) 275 | from)))) 276 | from)) 277 | 278 | (defn wider-tag 279 | "Given a collection of Classes returns the wider one" 280 | [tags] 281 | (let [tags* (filter identity tags) 282 | wider (loop [wider (first tags*) tags* (rest tags*)] 283 | (if (seq tags*) 284 | (if-let [t (wider-tag* wider (first tags*))] 285 | (recur t (rest tags*))) 286 | wider))] 287 | (when (or (= tags* tags) 288 | (not (primitive? wider))) 289 | wider))) 290 | 291 | (defn name-matches? 292 | [member] 293 | (let [member-name (str member) 294 | i (.LastIndexOf member-name ".") ;;; .lastIndexOf 295 | member-name* (when (pos? i) 296 | (str (s/replace (subs member-name 0 i) "-" "_") (subs member-name i))) 297 | member-name** (s/replace member-name "-" "_") 298 | member-name*** (munge member-name)] 299 | (fn [name] 300 | (let [name (str name)] 301 | (or (= member-name name) 302 | (= member-name* name) 303 | (= member-name** name) 304 | (= member-name*** name)))))) 305 | 306 | (def object-members 307 | (:members (type-reflect Object))) 308 | 309 | (def members* 310 | (lru (fn members* 311 | ([class] 312 | (into object-members 313 | (remove (fn [{:keys [flags]}] 314 | (not-any? #{:public :protected} flags)) 315 | (-> class 316 | maybe-class 317 | ^Type (box) ;;; Class 318 | .FullName ;;; .getName 319 | symbol 320 | (type-reflect :ancestors true) 321 | :members))))))) 322 | 323 | (defn members 324 | ([class] (members* class)) 325 | ([class member] 326 | (when-let [members (filter #((name-matches? member) (:name %)) 327 | (members* class))] 328 | members))) 329 | 330 | (defn static-members [class f] 331 | (when-let [members (members class f)] 332 | (when-let [statics (filter (comp :static :flags) members)] 333 | statics))) 334 | 335 | (defn instance-members [class f] 336 | (when-let [members (members class f)] 337 | (when-let [i-members (remove (comp :static :flags) members)] 338 | i-members))) 339 | 340 | (defn static-methods [class method argc] 341 | (filter #(= argc (count (:parameter-types %))) 342 | (filter :return-type (static-members class method)))) 343 | 344 | (defn instance-methods [class method argc] 345 | (filter #(= argc (count (:parameter-types %))) 346 | (filter :return-type (instance-members class method)))) 347 | 348 | (defn static-field [class f] 349 | (when-let [statics (static-members class f)] 350 | (when-let [[member] (filter (every-pred (comp nil? seq :parameter-types) 351 | (comp nil? :return-type)) 352 | statics)] 353 | member))) 354 | 355 | (defn instance-field [class f] 356 | (when-let [i-members (instance-members class f)] 357 | (when-let [[member] (filter (every-pred (comp nil? seq :parameter-types) 358 | (comp nil? :return-type)) 359 | i-members)] 360 | member))) 361 | 362 | (defn static-method [class method] 363 | (first (static-methods class method 0))) 364 | 365 | (defn instance-method [class method] 366 | (first (instance-methods class method 0))) 367 | 368 | (defn prim-or-obj 369 | "If the given Class is a primitive, returns that Class, otherwise returns Object" 370 | [tag] 371 | (if (and tag (primitive? tag)) 372 | tag 373 | System.Object)) ;;; java.lang.Object 374 | 375 | ;;; We have to work a lot harder on this one. 376 | ;;; 377 | ;;;(defn prim-interface [tags] 378 | ;;; (when (some primitive? tags) 379 | ;;; (let [sig (apply str (mapv #(.toUpperCase (subs (.getSimpleName ^Class %) 0 1)) tags))] 380 | ;;; (maybe-class (str "clojure.lang.IFn$" sig))))) 381 | ;;; The idea is that if (in Java) tags is Long Object Double Object, then you extract LODO and look up "clojure.lang.IFn$LODO" to see if it is a class. 382 | ;;; This would be one of the primitive interface types. 383 | ;;; Our problem is that we have Int64 instead of Long, so we get "I" instead of "L". Double and Object are okay. 384 | ;;; We'll create a map mapping Int64, Double, Object to the correct character, and default every other type to something bogus. 385 | ;;; Then do the class lookup. However, our classes are named clojure.lang.primifs.LODO, e.g. 386 | 387 | (defn prim-interface [tags] 388 | (when (some primitive? tags) 389 | (let [sig (apply str (mapv #(get {Object "O" Int64 "L" Double "D"} % "x") tags))] 390 | (maybe-class (str "clojure.lang.primifs." sig))))) 391 | 392 | 393 | (defn tag-match? [arg-tags meth] 394 | (every? identity (map convertible? arg-tags (:parameter-types meth)))) 395 | 396 | (defn try-best-match 397 | "Given a vector of arg tags and a collection of methods, tries to return the 398 | subset of methods that match best the given tags" 399 | [tags methods] 400 | (let [o-tags (mapv #(or (maybe-class %) Object) tags)] 401 | (if-let [methods (or (seq (filter 402 | #(= o-tags (mapv maybe-class (:parameter-types %))) methods)) 403 | (seq (filter #(tag-match? tags %) methods)))] 404 | (reduce (fn [[prev & _ :as p] next] 405 | (let [prev-params (mapv maybe-class (:parameter-types prev)) 406 | next-params (mapv maybe-class (:parameter-types next)) 407 | prev-ret (maybe-class (:return-type prev)) 408 | next-ret (maybe-class (:return-type next)) 409 | prev-decl (maybe-class (:declaring-class prev)) 410 | next-decl (maybe-class (:declaring-class next))] 411 | (cond 412 | (not prev) 413 | [next] 414 | (= prev-params next-params) 415 | (cond 416 | (= prev-ret next-ret) 417 | (cond 418 | (.IsAssignableFrom prev-decl next-decl) ;;; .isAssignableFrom 419 | [next] 420 | (.IsAssignableFrom next-decl prev-decl) ;;; .isAssignableFrom 421 | p 422 | :else 423 | (conj p next)) 424 | (.IsAssignableFrom prev-ret next-ret) ;;; .isAssignableFrom 425 | [next] 426 | (.IsAssignableFrom next-ret prev-ret) ;;; .isAssignableFrom 427 | p 428 | :else 429 | (conj p next)) 430 | (and (some true? (map subsumes? next-params prev-params)) 431 | (not-any? true? (map subsumes? prev-params next-params))) 432 | [next] 433 | :else 434 | (conj p next)))) [] methods) 435 | methods))) 436 | 437 | (defn ns->relpath [s] 438 | (-> s str (s/replace \. \/) (s/replace \- \_) (str ".clj"))) 439 | 440 | (defn ns-url [ns] ;;; No equivalent 441 | nil) ;;; (let [f (ns->relpath ns)] 442 | ;;; (or (io/resource f) 443 | ;;; (io/resource (str f "c")))) -------------------------------------------------------------------------------- /src/main/clojure/clojure/tools/analyzer/clr.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.clr 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.clr.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.clr 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.clr.io :as io] ;;; [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 | (Char/IsDigit (char (first opname)))) ;;; Character/isDigit 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 ..) ;;; .startsWith 156 | (let [[target & args] expr 157 | target (if-let [target (maybe-class-literal target)] 158 | (with-meta (list 'do target) 159 | {:tag 'System.Type}) ;;; 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. ..) ;;; .endsWith 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 .FullName symbol)] ;;; .getName 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 (.FullName ^Type %)) interfaces)] ;;; .getName ^Class 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 { ;;; DELETED: clojure.lang.Compiler/LOADER (clojure.lang.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 | (throw (NotImplementedException.)))) ;;; not sure how to encode this in our environment. 598 | ;;;(env/ensure (global-env) 599 | ;;; (let [res ^URL (ns-url ns)] ;;; ******* Need to figure out what type for URL 600 | ;;; (assert res (str "Can't find " ns " in classpath")) 601 | ;;; (let [filename (str res) 602 | ;;; path (.getPath res)] ;;; ;;; ******* Need to figure out what type for URL so we know what is replacement for .getPath 603 | ;;; (when-not (get-in (env/deref-env) [::analyzed-clj path]) 604 | ;;; (binding [*ns* *ns* 605 | ;;; *file* filename] 606 | ;;; (with-open [rdr (io/text-reader res)] ;;; io/reader 607 | ;;; (let [pbr (clojure.lang.LineNumberingTextReader. rdr) ;;; (readers/indexing-push-back-reader 608 | ;;; ;;; (java.io.PushbackReader. rdr) 1 filename) 609 | ;;; eof (Object.) 610 | ;;; read-opts {:eof eof :features #{:clj :t.a.jvm}} 611 | ;;; read-opts (if (.endsWith filename "cljc") ;;; .EndsWith 612 | ;;; (assoc read-opts :read-cond :allow) 613 | ;;; read-opts)] 614 | ;;; (loop [] 615 | ;;; (let [form (reader/read read-opts pbr)] 616 | ;;; (when-not (identical? form eof) 617 | ;;; (swap! *env* update-in [::analyzed-clj path] 618 | ;;; (fnil conj []) 619 | ;;; (analyze+eval form (assoc env :ns (ns-name *ns*)) opts)) 620 | ;;; (recur)))))))) 621 | ;;; (get-in @*env* [::analyzed-clj path])))))) 622 | 623 | (defn macroexpand-all 624 | "Like clojure.walk/macroexpand-all but correctly handles lexical scope" 625 | ([form] (macroexpand-all form (empty-env) {})) 626 | ([form env] (macroexpand-all form env {})) 627 | ([form env opts] 628 | (binding [run-passes emit-form] 629 | (analyze form env opts)))) --------------------------------------------------------------------------------