4 |
5 | Analyzer for JVM Clojure, tuned for consumption by an optional type checker.
6 |
7 | ## DEPRECATION NOTICE
8 |
9 | This repository is DEPRECATED and development has been moved
10 | to the [core.typed](https://github.com/clojure/core.typed) monorepo.
11 | Please follow [these](https://github.com/clojure/core.typed/blob/master/UPGRADING.md#upgrading-from-07x-to-monorepo)
12 | instructions to upgrade.
13 |
14 | ## Releases and Dependency Information
15 |
16 | Latest stable release is 0.7.1.
17 |
18 | * [All Released Versions](https://search.maven.org/search?q=g:org.clojure%20AND%20a:core.typed.analyzer.jvm)
19 |
20 | [deps.edn](https://clojure.org/reference/deps_and_cli) dependency information:
21 |
22 | ```clj
23 | org.clojure/core.typed.analyzer.jvm {:mvn/version "0.7.1"}
24 | ```
25 |
26 | [Leiningen](https://github.com/technomancy/leiningen) dependency information:
27 |
28 | ```clojure
29 | [org.clojure/core.typed.analyzer.jvm "0.7.1"]
30 | ```
31 |
32 | [Maven](https://maven.apache.org/) dependency information:
33 |
34 | ```XML
35 | THE ACCOMPANYING PROGRAM IS PROVIDED UNDER THE TERMS OF THIS ECLIPSE 33 | PUBLIC LICENSE ("AGREEMENT"). ANY USE, REPRODUCTION OR 34 | DISTRIBUTION OF THE PROGRAM CONSTITUTES RECIPIENT'S ACCEPTANCE OF THIS 35 | AGREEMENT.
36 | 37 |1. DEFINITIONS
38 | 39 |"Contribution" means:
40 | 41 |a) in the case of the initial Contributor, the initial 42 | code and documentation distributed under this Agreement, and
43 |b) in the case of each subsequent Contributor:
44 |i) changes to the Program, and
45 |ii) additions to the Program;
46 |where such changes and/or additions to the Program 47 | originate from and are distributed by that particular Contributor. A 48 | Contribution 'originates' from a Contributor if it was added to the 49 | Program by such Contributor itself or anyone acting on such 50 | Contributor's behalf. Contributions do not include additions to the 51 | Program which: (i) are separate modules of software distributed in 52 | conjunction with the Program under their own license agreement, and (ii) 53 | are not derivative works of the Program.
54 | 55 |"Contributor" means any person or entity that distributes 56 | the Program.
57 | 58 |"Licensed Patents" mean patent claims licensable by a 59 | Contributor which are necessarily infringed by the use or sale of its 60 | Contribution alone or when combined with the Program.
61 | 62 |"Program" means the Contributions distributed in accordance 63 | with this Agreement.
64 | 65 |"Recipient" means anyone who receives the Program under 66 | this Agreement, including all Contributors.
67 | 68 |2. GRANT OF RIGHTS
69 | 70 |a) Subject to the terms of this Agreement, each 71 | Contributor hereby grants Recipient a non-exclusive, worldwide, 72 | royalty-free copyright license to reproduce, prepare derivative works 73 | of, publicly display, publicly perform, distribute and sublicense the 74 | Contribution of such Contributor, if any, and such derivative works, in 75 | source code and object code form.
76 | 77 |b) Subject to the terms of this Agreement, each 78 | Contributor hereby grants Recipient a non-exclusive, worldwide, 79 | royalty-free patent license under Licensed Patents to make, use, sell, 80 | offer to sell, import and otherwise transfer the Contribution of such 81 | Contributor, if any, in source code and object code form. This patent 82 | license shall apply to the combination of the Contribution and the 83 | Program if, at the time the Contribution is added by the Contributor, 84 | such addition of the Contribution causes such combination to be covered 85 | by the Licensed Patents. The patent license shall not apply to any other 86 | combinations which include the Contribution. No hardware per se is 87 | licensed hereunder.
88 | 89 |c) Recipient understands that although each Contributor 90 | grants the licenses to its Contributions set forth herein, no assurances 91 | are provided by any Contributor that the Program does not infringe the 92 | patent or other intellectual property rights of any other entity. Each 93 | Contributor disclaims any liability to Recipient for claims brought by 94 | any other entity based on infringement of intellectual property rights 95 | or otherwise. As a condition to exercising the rights and licenses 96 | granted hereunder, each Recipient hereby assumes sole responsibility to 97 | secure any other intellectual property rights needed, if any. For 98 | example, if a third party patent license is required to allow Recipient 99 | to distribute the Program, it is Recipient's responsibility to acquire 100 | that license before distributing the Program.
101 | 102 |d) Each Contributor represents that to its knowledge it 103 | has sufficient copyright rights in its Contribution, if any, to grant 104 | the copyright license set forth in this Agreement.
105 | 106 |3. REQUIREMENTS
107 | 108 |A Contributor may choose to distribute the Program in object code 109 | form under its own license agreement, provided that:
110 | 111 |a) it complies with the terms and conditions of this 112 | Agreement; and
113 | 114 |b) its license agreement:
115 | 116 |i) effectively disclaims on behalf of all Contributors 117 | all warranties and conditions, express and implied, including warranties 118 | or conditions of title and non-infringement, and implied warranties or 119 | conditions of merchantability and fitness for a particular purpose;
120 | 121 |ii) effectively excludes on behalf of all Contributors 122 | all liability for damages, including direct, indirect, special, 123 | incidental and consequential damages, such as lost profits;
124 | 125 |iii) states that any provisions which differ from this 126 | Agreement are offered by that Contributor alone and not by any other 127 | party; and
128 | 129 |iv) states that source code for the Program is available 130 | from such Contributor, and informs licensees how to obtain it in a 131 | reasonable manner on or through a medium customarily used for software 132 | exchange.
133 | 134 |When the Program is made available in source code form:
135 | 136 |a) it must be made available under this Agreement; and
137 | 138 |b) a copy of this Agreement must be included with each 139 | copy of the Program.
140 | 141 |Contributors may not remove or alter any copyright notices contained 142 | within the Program.
143 | 144 |Each Contributor must identify itself as the originator of its 145 | Contribution, if any, in a manner that reasonably allows subsequent 146 | Recipients to identify the originator of the Contribution.
147 | 148 |4. COMMERCIAL DISTRIBUTION
149 | 150 |Commercial distributors of software may accept certain 151 | responsibilities with respect to end users, business partners and the 152 | like. While this license is intended to facilitate the commercial use of 153 | the Program, the Contributor who includes the Program in a commercial 154 | product offering should do so in a manner which does not create 155 | potential liability for other Contributors. Therefore, if a Contributor 156 | includes the Program in a commercial product offering, such Contributor 157 | ("Commercial Contributor") hereby agrees to defend and 158 | indemnify every other Contributor ("Indemnified Contributor") 159 | against any losses, damages and costs (collectively "Losses") 160 | arising from claims, lawsuits and other legal actions brought by a third 161 | party against the Indemnified Contributor to the extent caused by the 162 | acts or omissions of such Commercial Contributor in connection with its 163 | distribution of the Program in a commercial product offering. The 164 | obligations in this section do not apply to any claims or Losses 165 | relating to any actual or alleged intellectual property infringement. In 166 | order to qualify, an Indemnified Contributor must: a) promptly notify 167 | the Commercial Contributor in writing of such claim, and b) allow the 168 | Commercial Contributor to control, and cooperate with the Commercial 169 | Contributor in, the defense and any related settlement negotiations. The 170 | Indemnified Contributor may participate in any such claim at its own 171 | expense.
172 | 173 |For example, a Contributor might include the Program in a commercial 174 | product offering, Product X. That Contributor is then a Commercial 175 | Contributor. If that Commercial Contributor then makes performance 176 | claims, or offers warranties related to Product X, those performance 177 | claims and warranties are such Commercial Contributor's responsibility 178 | alone. Under this section, the Commercial Contributor would have to 179 | defend claims against the other Contributors related to those 180 | performance claims and warranties, and if a court requires any other 181 | Contributor to pay any damages as a result, the Commercial Contributor 182 | must pay those damages.
183 | 184 |5. NO WARRANTY
185 | 186 |EXCEPT AS EXPRESSLY SET FORTH IN THIS AGREEMENT, THE PROGRAM IS 187 | PROVIDED ON AN "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS 188 | OF ANY KIND, EITHER EXPRESS OR IMPLIED INCLUDING, WITHOUT LIMITATION, 189 | ANY WARRANTIES OR CONDITIONS OF TITLE, NON-INFRINGEMENT, MERCHANTABILITY 190 | OR FITNESS FOR A PARTICULAR PURPOSE. Each Recipient is solely 191 | responsible for determining the appropriateness of using and 192 | distributing the Program and assumes all risks associated with its 193 | exercise of rights under this Agreement , including but not limited to 194 | the risks and costs of program errors, compliance with applicable laws, 195 | damage to or loss of data, programs or equipment, and unavailability or 196 | interruption of operations.
197 | 198 |6. DISCLAIMER OF LIABILITY
199 | 200 |EXCEPT AS EXPRESSLY SET FORTH IN THIS AGREEMENT, NEITHER RECIPIENT 201 | NOR ANY CONTRIBUTORS SHALL HAVE ANY LIABILITY FOR ANY DIRECT, INDIRECT, 202 | INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING 203 | WITHOUT LIMITATION LOST PROFITS), HOWEVER CAUSED AND ON ANY THEORY OF 204 | LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING 205 | NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OR 206 | DISTRIBUTION OF THE PROGRAM OR THE EXERCISE OF ANY RIGHTS GRANTED 207 | HEREUNDER, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGES.
208 | 209 |7. GENERAL
210 | 211 |If any provision of this Agreement is invalid or unenforceable under 212 | applicable law, it shall not affect the validity or enforceability of 213 | the remainder of the terms of this Agreement, and without further action 214 | by the parties hereto, such provision shall be reformed to the minimum 215 | extent necessary to make such provision valid and enforceable.
216 | 217 |If Recipient institutes patent litigation against any entity 218 | (including a cross-claim or counterclaim in a lawsuit) alleging that the 219 | Program itself (excluding combinations of the Program with other 220 | software or hardware) infringes such Recipient's patent(s), then such 221 | Recipient's rights granted under Section 2(b) shall terminate as of the 222 | date such litigation is filed.
223 | 224 |All Recipient's rights under this Agreement shall terminate if it 225 | fails to comply with any of the material terms or conditions of this 226 | Agreement and does not cure such failure in a reasonable period of time 227 | after becoming aware of such noncompliance. If all Recipient's rights 228 | under this Agreement terminate, Recipient agrees to cease use and 229 | distribution of the Program as soon as reasonably practicable. However, 230 | Recipient's obligations under this Agreement and any licenses granted by 231 | Recipient relating to the Program shall continue and survive.
232 | 233 |Everyone is permitted to copy and distribute copies of this 234 | Agreement, but in order to avoid inconsistency the Agreement is 235 | copyrighted and may only be modified in the following manner. The 236 | Agreement Steward reserves the right to publish new versions (including 237 | revisions) of this Agreement from time to time. No one other than the 238 | Agreement Steward has the right to modify this Agreement. The Eclipse 239 | Foundation is the initial Agreement Steward. The Eclipse Foundation may 240 | assign the responsibility to serve as the Agreement Steward to a 241 | suitable separate entity. Each new version of the Agreement will be 242 | given a distinguishing version number. The Program (including 243 | Contributions) may always be distributed subject to the version of the 244 | Agreement under which it was received. In addition, after a new version 245 | of the Agreement is published, Contributor may elect to distribute the 246 | Program (including its Contributions) under the new version. Except as 247 | expressly stated in Sections 2(a) and 2(b) above, Recipient receives no 248 | rights or licenses to the intellectual property of any Contributor under 249 | this Agreement, whether expressly, by implication, estoppel or 250 | otherwise. All rights in the Program not expressly granted under this 251 | Agreement are reserved.
252 | 253 |This Agreement is governed by the laws of the State of New York and 254 | the intellectual property laws of the United States of America. No party 255 | to this Agreement will bring a legal action under this Agreement more 256 | than one year after the cause of action arose. Each party waives its 257 | rights to a jury trial in any resulting litigation.
258 | 259 | 260 | 261 | 262 | -------------------------------------------------------------------------------- /src/main/clojure/clojure/core/typed/analyzer/passes/jvm/validate.clj: -------------------------------------------------------------------------------- 1 | ;; Copyright (c) Ambrose Bonnaire-Sergeant, 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 | ; copied from tools.analyzer.jvm 10 | ; - changed :pass-info for `validate` 11 | ; - use ana2/resolve-{sym,ns} instead of u/resolve-{sym,ns} 12 | ; - use clojure.core.typed.analyzer.passes.jvm.infer-tag 13 | ; - use clojure.core.typed.analyzer.passes.jvm.analyze-host-expr 14 | ; - remove clojure.tools.analyzer.passes.jvm.validate-recur 15 | (ns clojure.core.typed.analyzer.passes.jvm.validate 16 | (:require [clojure.tools.analyzer.ast :refer [prewalk]] 17 | [clojure.core.typed.analyzer.env :as env] 18 | [clojure.tools.analyzer.passes.cleanup :refer [cleanup]] 19 | [clojure.core.typed.analyzer.passes.jvm.analyze-host-expr :as analyze-host-expr] 20 | [clojure.core.typed.analyzer.passes.jvm.infer-tag :as infer-tag] 21 | [clojure.core.typed.analyzer :refer [resolve-sym resolve-ns]] 22 | [clojure.tools.analyzer.utils :refer [arglist-for-arity source-info merge']] 23 | [clojure.tools.analyzer.jvm.utils :as u :refer [tag-match? try-best-match]]) 24 | (:import (clojure.lang IFn))) 25 | 26 | (defmulti -validate :op) 27 | 28 | (defmethod -validate :maybe-class 29 | [{:keys [class env] :as ast}] 30 | (if-let [handle (-> (env/deref-env) :passes-opts :validate/unresolvable-symbol-handler)] 31 | (handle nil class ast) 32 | (if (not (.contains (str class) ".")) 33 | (throw (ex-info (str "Could not resolve var: " class) 34 | (merge {:var class} 35 | (source-info env)))) 36 | 37 | (throw (ex-info (str "Class not found: " class) 38 | (merge {:class class} 39 | (source-info env))))))) 40 | 41 | (defmethod -validate :maybe-host-form 42 | [{:keys [class field form env] :as ast}] 43 | (if-let [handle (-> (env/deref-env) :passes-opts :validate/unresolvable-symbol-handler)] 44 | (handle class field ast) 45 | (if (resolve-ns class env) 46 | (throw (ex-info (str "No such var: " class) 47 | (merge {:form form} 48 | (source-info env)))) 49 | (throw (ex-info (str "No such namespace: " class) 50 | (merge {:ns class 51 | :form form} 52 | (source-info env))))))) 53 | 54 | (defmethod -validate :set! 55 | [{:keys [target form env] :as ast}] 56 | (when (not (:assignable? target)) 57 | (throw (ex-info "Cannot set! non-assignable target" 58 | (merge {:target (prewalk target cleanup) 59 | :form form} 60 | (source-info env))))) 61 | ast) 62 | 63 | (defmethod -validate :new 64 | [{:keys [args] :as ast}] 65 | (if (:validated? ast) 66 | ast 67 | (if-not (= :class (-> ast :class :type)) 68 | (throw (ex-info (str "Unable to resolve classname: " (:form (:class ast))) 69 | (merge {:class (:form (:class ast)) 70 | :ast ast} 71 | (source-info (:env ast))))) 72 | (let [^Class class (-> ast :class :val) 73 | c-name (symbol (.getName class)) 74 | argc (count args) 75 | tags (mapv :tag args)] 76 | (let [[ctor & rest] (->> (filter #(= (count (:parameter-types %)) argc) 77 | (u/members class c-name)) 78 | (try-best-match tags))] 79 | (if ctor 80 | (if (empty? rest) 81 | (let [arg-tags (mapv u/maybe-class (:parameter-types ctor)) 82 | args (mapv (fn [arg tag] (assoc arg :tag tag)) args arg-tags)] 83 | (assoc ast 84 | :args args 85 | :validated? true)) 86 | ast) 87 | (throw (ex-info (str "no ctor found for ctor of class: " class " and given signature") 88 | (merge {:class class 89 | :args (mapv (fn [a] (prewalk a cleanup)) args)} 90 | (source-info (:env ast))))))))))) 91 | 92 | (defn validate-call [{:keys [class instance method args tag env op] :as ast}] 93 | (let [argc (count args) 94 | instance? (= :instance-call op) 95 | f (if instance? u/instance-methods u/static-methods) 96 | tags (mapv :tag args)] 97 | (if-let [matching-methods (seq (f class method argc))] 98 | (let [[m & rest :as matching] (try-best-match tags matching-methods)] 99 | (if m 100 | (let [all-ret-equals? (apply = (mapv :return-type matching))] 101 | (if (or (empty? rest) 102 | (and all-ret-equals? ;; if the method signature is the same just pick the first one 103 | (apply = (mapv #(mapv u/maybe-class (:parameter-types %)) matching)))) 104 | (let [ret-tag (:return-type m) 105 | arg-tags (mapv u/maybe-class (:parameter-types m)) 106 | args (mapv (fn [arg tag] (assoc arg :tag tag)) args arg-tags) 107 | class (u/maybe-class (:declaring-class m))] 108 | (merge' ast 109 | {:method (:name m) 110 | :validated? true 111 | :class class 112 | :o-tag ret-tag 113 | :tag (or tag ret-tag) 114 | :args args} 115 | (if instance? 116 | {:instance (assoc instance :tag class)}))) 117 | (if all-ret-equals? 118 | (let [ret-tag (:return-type m)] 119 | (assoc ast 120 | :o-tag Object 121 | :tag (or tag ret-tag))) 122 | ast))) 123 | (if instance? 124 | (assoc (dissoc ast :class) :tag Object :o-tag Object) 125 | (throw (ex-info (str "No matching method: " method " for class: " class " and given signature") 126 | (merge {:method method 127 | :class class 128 | :args (mapv (fn [a] (prewalk a cleanup)) args)} 129 | (source-info env))))))) 130 | (if instance? 131 | (assoc (dissoc ast :class) :tag Object :o-tag Object) 132 | (throw (ex-info (str "No matching method: " method " for class: " class " and arity: " argc) 133 | (merge {:method method 134 | :class class 135 | :argc argc} 136 | (source-info env)))))))) 137 | 138 | (defmethod -validate :static-call 139 | [ast] 140 | (if (:validated? ast) 141 | ast 142 | (validate-call (assoc ast :class (u/maybe-class (:class ast)))))) 143 | 144 | (defmethod -validate :static-field 145 | [ast] 146 | (if (:validated? ast) 147 | ast 148 | (assoc ast :class (u/maybe-class (:class ast))))) 149 | 150 | (defmethod -validate :instance-call 151 | [{:keys [class validated? instance] :as ast}] 152 | (let [class (or class (:tag instance))] 153 | (if (and class (not validated?)) 154 | (validate-call (assoc ast :class (u/maybe-class class))) 155 | ast))) 156 | 157 | (defmethod -validate :instance-field 158 | [{:keys [instance class] :as ast}] 159 | (let [class (u/maybe-class class)] 160 | (assoc ast :class class :instance (assoc instance :tag class)))) 161 | 162 | (defmethod -validate :import 163 | [{:keys [^String class validated? env form] :as ast}] 164 | (if-not validated? 165 | (let [class-sym (-> class (subs (inc (.lastIndexOf class "."))) symbol) 166 | sym-val (resolve-sym class-sym env)] 167 | (if (and (class? sym-val) (not= (.getName ^Class sym-val) class)) ;; allow deftype redef 168 | (throw (ex-info (str class-sym " already refers to: " sym-val 169 | " in namespace: " (:ns env)) 170 | (merge {:class class 171 | :class-sym class-sym 172 | :sym-val sym-val 173 | :form form} 174 | (source-info env)))) 175 | (assoc ast :validated? true))) 176 | ast)) 177 | 178 | (defmethod -validate :def 179 | [ast] 180 | (when-not (var? (:var ast)) 181 | (throw (ex-info (str "Cannot def " (:name ast) " as it refers to the class " 182 | (.getName ^Class (:var ast))) 183 | (merge {:ast (prewalk ast cleanup)} 184 | (source-info (:env ast)))))) 185 | (merge 186 | ast 187 | (when-let [tag (-> ast :name meta :tag)] 188 | (when (and (symbol? tag) (or (u/specials (str tag)) (u/special-arrays (str tag)))) 189 | ;; we cannot validate all tags since :tag might contain a function call that returns 190 | ;; a valid tag at runtime, however if tag is one of u/specials or u/special-arrays 191 | ;; we know that it's a wrong tag as it's going to be evaluated as a clojure.core function 192 | (if-let [handle (-> (env/deref-env) :passes-opts :validate/wrong-tag-handler)] 193 | (handle :name/tag ast) 194 | (throw (ex-info (str "Wrong tag: " (eval tag) " in def: " (:name ast)) 195 | (merge {:ast (prewalk ast cleanup)} 196 | (source-info (:env ast)))))))))) 197 | 198 | (defmethod -validate :invoke 199 | [{:keys [args env fn form] :as ast}] 200 | (let [argc (count args)] 201 | (when (and (= :const (:op fn)) 202 | (not (instance? IFn (:form fn)))) 203 | (throw (ex-info (str (class (:form fn)) " is not a function, but it's used as such") 204 | (merge {:form form} 205 | (source-info env))))) 206 | (if (and (:arglists fn) 207 | (not (arglist-for-arity fn argc))) 208 | (if (-> (env/deref-env) :passes-opts :validate/throw-on-arity-mismatch) 209 | (throw (ex-info (str "No matching arity found for function: " (:name fn)) 210 | {:arity (count args) 211 | :fn fn})) 212 | (assoc ast :maybe-arity-mismatch true)) 213 | ast))) 214 | 215 | (defn validate-interfaces [{:keys [env form interfaces]}] 216 | (when-not (every? #(.isInterface ^Class %) (disj interfaces Object)) 217 | (throw (ex-info "only interfaces or Object can be implemented by deftype/reify" 218 | (merge {:interfaces interfaces 219 | :form form} 220 | (source-info env)))))) 221 | 222 | (defmethod -validate :deftype 223 | [{:keys [class-name] :as ast}] 224 | (validate-interfaces ast) 225 | (assoc ast :class-name (u/maybe-class class-name))) 226 | 227 | (defmethod -validate :reify 228 | [{:keys [class-name] :as ast}] 229 | (validate-interfaces ast) 230 | (assoc ast :class-name (u/maybe-class class-name))) 231 | 232 | (defmethod -validate :default [ast] ast) 233 | 234 | (defn validate-tag [t {:keys [env] :as ast}] 235 | (let [tag (ast t)] 236 | (if-let [the-class (u/maybe-class tag)] 237 | {t the-class} 238 | (if-let [handle (-> (env/deref-env) :passes-opts :validate/wrong-tag-handler)] 239 | (handle t ast) 240 | (throw (ex-info (str "Class not found: " tag) 241 | (merge {:class tag 242 | :ast (prewalk ast cleanup)} 243 | (source-info env)))))))) 244 | 245 | ;;redefine passes mainly to move dependency on `uniquify-locals` 246 | ;; to `uniquify2/uniquify-locals` 247 | ;; - remove validate-recur 248 | ;; - replace infer-tag 249 | ;; - replace analyze-host-expr 250 | (defn validate 251 | "Validate tags, classes, method calls. 252 | Throws exceptions when invalid forms are encountered, replaces 253 | class symbols with class objects. 254 | 255 | Passes opts: 256 | * :validate/throw-on-arity-mismatch 257 | If true, validate will throw on potential arity mismatch 258 | * :validate/wrong-tag-handler 259 | If bound to a function, will invoke that function instead of 260 | throwing on invalid tag. 261 | The function takes the tag key (or :name/tag if the node is :def and 262 | the wrong tag is the one on the :name field meta) and the originating 263 | AST node and must return a map (or nil) that will be merged into the AST, 264 | possibly shadowing the wrong tag with Object or nil. 265 | * :validate/unresolvable-symbol-handler 266 | If bound to a function, will invoke that function instead of 267 | throwing on unresolvable symbol. 268 | The function takes three arguments: the namespace (possibly nil) 269 | and name part of the symbol, as symbols and the originating 270 | AST node which can be either a :maybe-class or a :maybe-host-form, 271 | those nodes are documented in the tools.analyzer quickref. 272 | The function must return a valid tools.analyzer.jvm AST node." 273 | {:pass-info {:walk :post :depends #{;; replace 274 | #'infer-tag/infer-tag 275 | ;; replace 276 | #'analyze-host-expr/analyze-host-expr 277 | ;; validate-recur doesn't seem to play nicely with core.async/go 278 | #_#'validate-recur/validate-recur}}} 279 | [{:keys [tag form env] :as ast}] 280 | (let [ast (merge (-validate ast) 281 | (when tag 282 | {:tag tag}))] 283 | (merge ast 284 | (when (:tag ast) 285 | (validate-tag :tag ast)) 286 | (when (:o-tag ast) 287 | (validate-tag :o-tag ast)) 288 | (when (:return-tag ast) 289 | (validate-tag :return-tag ast))))) 290 | 291 | -------------------------------------------------------------------------------- /src/main/clojure/clojure/core/typed/analyzer/passes/beta_reduce.clj: -------------------------------------------------------------------------------- 1 | ;; Copyright (c) Ambrose Bonnaire-Sergeant, 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 | ;; should be a JVM pass since it calls `run-passes` 10 | (ns clojure.core.typed.analyzer.passes.beta-reduce 11 | (:require [clojure.core.typed.analyzer.passes.jvm.classify-invoke :as classify-invoke] 12 | [clojure.core.typed.analyzer.passes.jvm.analyze-host-expr :as analyze-host-expr] 13 | [clojure.tools.analyzer.passes.jvm.annotate-tag :as annotate-tag] 14 | [clojure.tools.analyzer.passes.jvm.emit-form :refer [emit-form]] 15 | [clojure.tools.analyzer.passes.source-info :as source-info] 16 | [clojure.tools.analyzer.ast :as ast] 17 | [clojure.core.typed.analyzer.jvm :as jana2] 18 | [clojure.pprint :as pprint] 19 | [clojure.core.typed.analyzer :as ana] 20 | [clojure.tools.analyzer.utils :as u] 21 | [clojure.core.typed.analyzer.passes.uniquify :as uniquify])) 22 | 23 | (def beta-limit 500) 24 | 25 | (defn find-matching-method [ast nargs] 26 | {:pre [(= :fn (:op ast)) 27 | (nat-int? nargs)] 28 | :post [((some-fn nil? (comp #{:fn-method} :op)) %)]} 29 | (let [{fixed-arities false variadic-arities true} (group-by (comp boolean :variadic?) (:methods ast)) 30 | matching-method (->> fixed-arities 31 | (filter (fn [a] 32 | (= (:fixed-arity a) nargs))) 33 | first) 34 | matching-method (or matching-method 35 | (when-let [[variadic-arity] variadic-arities] 36 | (when (<= (:fixed-arity variadic-arity) nargs) 37 | variadic-arity)))] 38 | matching-method)) 39 | 40 | ; Ast [TailAst -> Ast] -> Ast 41 | (defn visit-tail-pos [ast f] 42 | (let [rec #(visit-tail-pos % f)] 43 | (case (:op ast) 44 | :do (update ast :ret rec) 45 | :if (-> ast 46 | (update :then rec) 47 | (update :else rec)) 48 | (:let :letfn) (update ast :body rec) 49 | (f ast)))) 50 | 51 | (defn unwrap-with-meta [ast] 52 | (case (:op ast) 53 | :with-meta (recur (:expr ast)) 54 | :unanalyzed (recur (-> (ana/analyze-outer ast) 55 | ana/run-passes)) 56 | ast)) 57 | 58 | ;; assumption: none of (keys subst) occur in (vals subst) 59 | (defn subst-locals [ast subst] 60 | (ast/postwalk ast 61 | (fn [ast] 62 | (case (:op ast) 63 | :local (if-let [sast (subst (:name ast))] 64 | sast 65 | ast) 66 | ast)))) 67 | 68 | (defn var->vsym [^clojure.lang.Var v] 69 | (symbol (some-> (.ns v) ns-name str) (str (.sym v)))) 70 | 71 | (defn splice-seqable-expr 72 | "If ast is a seqable, returns a vector describing its members. Otherwise nil. 73 | 74 | :ordered entry is true if calling `first` on this expr is ordered 75 | 76 | eg. (vector 1 2 3) 77 | [{:op :sequential :expr (vector 1 2 3) :min-count 3 :max-count 3}] 78 | 79 | eg. (cons 4 (vector 1 2 3)) 80 | [{:op :single :expr 4} 81 | {:op :sequential :expr (vector 1 2 3) :min-count 3 :max-count}] 82 | 83 | eg. (concat (vector 1 2 3) (range 0)) 84 | [{:op :sequential :expr (vector 1 2 3) :min-count 3 :max-count 3} 85 | {:op :sequential :expr (range 0) :min-count ##Inf :max-count ##Inf}] 86 | 87 | eg. (concat (vector 1 2 3) (range 0) (vector 1 2 3)) 88 | [{:op :sequential :expr (vector 1 2 3) :min-count 3 :max-count 3} 89 | {:op :sequential :expr (range 0) :min-count ##Inf :max-count ##Inf} 90 | {:op :sequential :expr (vector 1 2 3) :min-count 3 :max-count 3}] 91 | 92 | eg. (range 0) 93 | [{:op :sequential :expr (range 0) :min-count ##Inf :max-count ##Inf}] 94 | 95 | eg. (range 0 39) 96 | [{:op :sequential :expr (range 0 39) :min-count 39 :max-count 39}] 97 | 98 | eg. nil 99 | [{:op :sequential :expr nil :min-count 0 :max-count 0}] 100 | 101 | eg. (take-while symbol? (read-string)) 102 | [{:op :sequential :expr (take-while symbol? (read)) :min-count 0 :max-count ##Inf}] 103 | 104 | eg. {:a 1 :b 2} 105 | [{:op :unordered :expr {:a 1 :b 2} :min-count 2 :max-count 2}] 106 | 107 | eg. #{:a :b} 108 | [{:op :unordered :expr #{:a :b} :min-count 2 :max-count 2}] 109 | " 110 | [{:keys [op env] :as ast}] 111 | {:post [((some-fn nil? vector?) %)]} 112 | ;(prn "splice-seqable-expr" op (emit-form ast)) 113 | (case op 114 | :unanalyzed (splice-seqable-expr (-> (ana/analyze-outer ast) 115 | ana/run-passes)) 116 | :local (when (#{:let} (:local ast)) 117 | (some-> (:init ast) splice-seqable-expr)) 118 | :vector [{:op :sequential 119 | :ordered true 120 | :expr ast 121 | :min-count (count (:items ast)) 122 | :max-count (count (:items ast))}] 123 | :const (when (seqable? (:val ast)) 124 | [{:op (if (sequential? (:val ast)) :sequential :unordered) 125 | :ordered (sequential? (:val ast)) 126 | :expr (ana/analyze-const (:val ast) env) 127 | :min-count (count (:val ast)) 128 | :max-count (count (:val ast))}]) 129 | :do (splice-seqable-expr (:ret ast)) 130 | (:let :let-fn) (splice-seqable-expr (:body ast)) 131 | :new (let [cls ^Class (:class ast) 132 | csym (symbol (.getName cls))] 133 | (case csym 134 | ;; TODO needs testing 135 | ;clojure.lang.LazySeq (let [body (-> ast :args first :methods first :body)] 136 | ; (assert (map? body)) 137 | ; (splice-seqable-expr body)) 138 | nil)) 139 | ;TODO lift `if` statements around invoke nodes so they are 140 | ; automatically handled (if performant) 141 | :invoke (let [{:keys [args]} ast 142 | cargs (count args) 143 | ufn (unwrap-with-meta (:fn ast))] 144 | (case (:op ufn) 145 | :var (let [vsym (var->vsym (:var ufn))] 146 | (case vsym 147 | clojure.core/concat 148 | (loop [c [] 149 | args args] 150 | (if (empty? args) 151 | c 152 | (let [[arg] args] 153 | (when-let [spliced (splice-seqable-expr arg)] 154 | (recur (into c spliced) (next args)))))) 155 | clojure.core/list* 156 | (when (<= 1 cargs) 157 | (let [lspliced (splice-seqable-expr (peek args))] 158 | (when lspliced 159 | (into (mapv (fn [e] 160 | {:op :single 161 | :ordered true 162 | :expr e 163 | :min-count 1 164 | :max-count 1}) 165 | (pop args)) 166 | lspliced)))) 167 | (clojure.core/list clojure.core/vector) 168 | [{:op :sequential 169 | :ordered true 170 | :expr ast 171 | :min-count cargs 172 | :max-count cargs}] 173 | (clojure.core/vec clojure.core/seq clojure.core/sequence) 174 | (when (= 1 cargs) 175 | (splice-seqable-expr (first args))) 176 | clojure.core/cons 177 | (when (= 1 cargs) 178 | (let [other (splice-seqable-expr (second args))] 179 | (some->> other 180 | (into [{:op :single :expr (first args) 181 | :ordered true 182 | :min-count 1 :max-count 1}])))) 183 | (clojure.core/rest clojure.core/next) 184 | (when (= 1 cargs) 185 | (when-let [spliced (splice-seqable-expr (first args))] 186 | (let [dec-nat #(max 0 (dec %)) 187 | consumed-from (atom nil) 188 | consumed-one (reduce (fn [spliced e] 189 | ;; TODO deal with this case 190 | (if-not (= (:min-count e) 191 | (:max-count e)) 192 | (reduced nil) 193 | (conj spliced 194 | (if (or @consumed-from 195 | (zero? (:max-count e))) 196 | e 197 | (reset! consumed-from 198 | (-> e 199 | (update :consumed (fnil inc 0)) 200 | (update :min-count dec-nat) 201 | (update :max-count dec-nat))))))) 202 | [] 203 | spliced)] 204 | (when consumed-one 205 | [{:op :rest 206 | :expr ast 207 | :ordered (if @consumed-from 208 | (:ordered @consumed-from) 209 | ;; must be empty here, so, ordered 210 | true) 211 | :min-count (apply + (map :min-count consumed-one)) 212 | :max-count (apply + (map :max-count consumed-one))}])))) 213 | nil)) 214 | nil)) 215 | nil)) 216 | 217 | (defn make-invoke-expr [the-fn args env] 218 | {:op :invoke 219 | :fn the-fn 220 | :env env 221 | :args args 222 | :form (list* (:form the-fn) 223 | (map :form args)) 224 | :children [:fn :args]}) 225 | 226 | (defn make-var-expr [var env] 227 | {:op :var 228 | :var var 229 | :env env 230 | :form (var->vsym var)}) 231 | 232 | (defn fake-seq-invoke [seq-args env] 233 | (let [the-fn (make-var-expr #'seq env) 234 | args [{:op :vector 235 | :env env 236 | :items (vec seq-args) 237 | :form (mapv :form seq-args) 238 | :children [:items]}] 239 | invoke-expr (make-invoke-expr the-fn args env)] 240 | invoke-expr)) 241 | 242 | ; ((fn* ([params*] body)) args*) 243 | ; ;=> body[args*/params*] 244 | (defn maybe-beta-reduce-fn [ufn args & [{:keys [before-reduce] :as opts}]] 245 | {:pre [(= :fn (:op ufn)) 246 | (vector? args)]} 247 | (when-not (:local ufn) ;;TODO 248 | (when-let [{:keys [params body variadic? fixed-arity env]} (find-matching-method ufn (count args))] 249 | ;; update before any recursive calls (ie. run-passes) 250 | (when before-reduce (before-reduce)) 251 | (let [[fixed-params variadic-param] (if variadic? 252 | [(pop params) (peek params)] 253 | [params nil]) 254 | [fixed-args variadic-args] (split-at fixed-arity args) 255 | subst (merge (zipmap (map :name fixed-params) fixed-args) 256 | (when variadic-param 257 | {(:name variadic-param) (fake-seq-invoke variadic-args env)}))] 258 | (-> body 259 | (subst-locals subst) 260 | ana/run-passes))))) 261 | 262 | (defn record-beta-reduction [state] 263 | (swap! state update ::expansions inc)) 264 | 265 | (defn reached-beta-limit? [state] 266 | (or (::reached-beta-limit @state) 267 | (< beta-limit (::expansions @state)))) 268 | 269 | (defn ensure-within-beta-limit [state & [err-f]] 270 | (when (reached-beta-limit? state) 271 | (do (swap! state assoc ::reached-beta-limit true) 272 | (when err-f 273 | (err-f (::expansions @state)))))) 274 | 275 | ; (apply f args* collarg) 276 | ; ;=> (f args* ~@collarg) 277 | (defn maybe-beta-reduce-apply [{:keys [env] :as ufn} args & [{:keys [before-reduce] :as opts}]] 278 | {:pre [(= 'clojure.core/apply (var->vsym (:var ufn))) 279 | (vector? args)]} 280 | (when (<= 1 (count args)) 281 | (let [[single-args collarg] ((juxt pop peek) args)] 282 | (let [{:keys [fixed rest-form] :as spliced} (splice-seqable-expr collarg)] 283 | (when (and spliced (seq fixed)) 284 | (let [;; move as many fixed arguments out of the collection argument as possible 285 | form (if (contains? spliced :rest-form) 286 | (cons (emit-form ufn) 287 | (concat (map emit-form (concat single-args fixed)) [rest-form])) 288 | (map emit-form (concat single-args fixed)))] 289 | (when before-reduce (before-reduce)) 290 | (ana/run-passes (ana/analyze-form form env)))))))) 291 | 292 | (defn push-invoke 293 | "Push arguments into the function position of an :invoke 294 | so the function and arguments are both in the 295 | same :invoke node, then reanalyze the resulting :invoke node. 296 | 297 | eg. ((let [a 1] identity) 2) 298 | ;=> (let [a 1] (identity 2)) 299 | eg. ((if c identity first) [1]) 300 | ;=> (if c (identity [1]) (first [1])) 301 | " 302 | {:pass-info {:walk :post 303 | :before #{#'annotate-tag/annotate-tag 304 | #'analyze-host-expr/analyze-host-expr 305 | #'classify-invoke/classify-invoke} 306 | :state (fn [] (atom {::expansions 0}))}} 307 | [state {:keys [op] :as ast}] 308 | {:post [(:op %)]} 309 | ;(prn "expansions" (::expansions @state)) 310 | (if (reached-beta-limit? state) 311 | (do 312 | (when-not (::reached-beta-limit @state) 313 | (prn "beta limit reached") 314 | (swap! state assoc ::reached-beta-limit true)) 315 | ast) 316 | (case op 317 | :invoke (let [{the-fn :fn :keys [args]} ast] 318 | (visit-tail-pos 319 | the-fn 320 | (fn [tail-ast] 321 | (let [fn-form (emit-form tail-ast) 322 | form (with-meta 323 | (list* fn-form (map emit-form args)) 324 | (meta fn-form)) 325 | ;_ (prn "form" form) 326 | env (:env tail-ast) 327 | mform (ana/macroexpand-1 form env)] 328 | ;(prn "mform" mform) 329 | (if (= mform form) 330 | (let [ufn (unwrap-with-meta tail-ast) 331 | special-case 332 | (case (:op ufn) 333 | ;manually called by core.typed 334 | ;:fn (maybe-beta-reduce-fn ufn args {:before-reduce #(swap! state update ::expansions inc)}) 335 | :var (case (var->vsym (:var ufn)) 336 | clojure.core/apply (maybe-beta-reduce-apply ufn args) 337 | nil) 338 | ;;TODO 339 | :const (case (:type ast) 340 | #_:keyword #_(when (= 1 (count args)) 341 | (let [[map-arg] args] 342 | )) 343 | #_:symbol 344 | #_:map 345 | #_:vector 346 | #_:set 347 | nil) 348 | nil)] 349 | (or special-case 350 | (cond 351 | ;; return original :invoke where possible 352 | (= the-fn tail-ast) ast 353 | :else {:op :invoke 354 | :form form 355 | :fn tail-ast 356 | :args args 357 | :env env 358 | :children [:fn :args]}))) 359 | (do (swap! state update ::expansions inc) 360 | ;(prn "reparsing invoke" (first mform)) 361 | ;; TODO like analyze-seq, perhaps we can reuse the implemenation 362 | (ana/run-passes 363 | (-> (ana/analyze-form mform env) 364 | (update-in [:raw-forms] (fnil conj ()) 365 | (vary-meta form assoc ::ana/resolved-op (ana/resolve-sym (first form) env))))))))))) 366 | ast))) 367 | 368 | -------------------------------------------------------------------------------- /src/main/clojure/clojure/core/typed/analyzer/js.clj: -------------------------------------------------------------------------------- 1 | ;; Copyright (c) Ambrose Bonnaire-Sergeant, 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 | ;; adapted from tools.analyzer.js 10 | (ns clojure.core.typed.analyzer.js 11 | "Analyzer for clojurescript code, extends tools.analyzer with JS specific passes/forms" 12 | (:refer-clojure :exclude [macroexpand-1 var? ns-resolve]) 13 | (:require [clojure.core.typed.analyzer :as ana] 14 | [clojure.tools.analyzer.utils :refer [ctx -source-info dissoc-env mmerge update-vals] :as u] 15 | [clojure.tools.analyzer.ast :refer [prewalk postwalk]] 16 | [clojure.tools.analyzer.env :as env] 17 | [clojure.core.typed.analyzer.passes :as passes] 18 | [clojure.tools.analyzer.passes.source-info :refer [source-info]] 19 | [clojure.tools.analyzer.passes.elide-meta :refer [elide-meta elides]] 20 | [clojure.core.typed.analyzer.passes.uniquify :as uniquify2] 21 | [clojure.core.typed.analyzer.passes.js.infer-tag :refer [infer-tag]] 22 | [clojure.core.typed.analyzer.passes.js.validate :refer [validate]] 23 | [clojure.core.typed.analyzer.js.utils 24 | :refer [desugar-ns-specs validate-ns-specs ns-resource ns->relpath res-path]] 25 | [cljs.env :as cljs-env] 26 | [cljs.js-deps :as deps] 27 | [clojure.core :as core] 28 | cljs.tagged-literals) 29 | (:import cljs.tagged_literals.JSValue)) 30 | 31 | (def specials 32 | "Set of the special forms for ClojureScript" 33 | (into ana/specials '#{ns deftype* defrecord* js* case*})) 34 | 35 | (def ^:dynamic *cljs-ns* 'cljs.user) 36 | 37 | (defonce core-env (atom {})) 38 | 39 | (defn global-env [] 40 | (atom (merge (and cljs-env/*compiler* @cljs-env/*compiler*) 41 | {:namespaces (merge '{goog {:mappings {}, :js-namespace true, :ns goog} 42 | Math {:mappings {}, :js-namespace true, :ns Math}} 43 | @core-env) 44 | :js-dependency-index (deps/js-dependency-index {})}))) 45 | 46 | (defn empty-env 47 | "Returns an empty env map" 48 | [] 49 | {:context :ctx/statement 50 | :locals {} 51 | :ns *cljs-ns*}) 52 | 53 | (defn ns-resolve [ns sym] 54 | (let [ns (if (string? ns) 55 | (symbol ns) 56 | ns) 57 | sym (if (string? sym) 58 | (symbol sym) 59 | sym)] 60 | (and (find-ns ns) 61 | (core/ns-resolve ns sym)))) 62 | 63 | (defn maybe-macro [sym {:keys [ns]}] 64 | (let [var (if-let [sym-ns (namespace sym)] 65 | (if-let [full-ns (get-in (env/deref-env) 66 | [:namespaces ns :macro-aliases (symbol sym-ns)])] 67 | (ns-resolve full-ns (name sym)) 68 | (ns-resolve sym-ns (name sym))) 69 | (get-in (env/deref-env) [:namespaces ns :macro-mappings sym]))] 70 | (when (:macro (meta var)) 71 | var))) 72 | 73 | (defn resolve-sym [sym env] 74 | (or (u/resolve-sym sym env) 75 | (get-in env [:locals sym]))) 76 | 77 | (defn dotted-symbol? [form env] 78 | (let [n (name form) 79 | ns (namespace form) 80 | idx (.indexOf n ".") 81 | sym (and (pos? idx) 82 | (symbol ns (.substring n 0 idx)))] 83 | (and (not= idx -1) 84 | (not (resolve-sym form env)) 85 | (not= sym form) 86 | (resolve-sym sym env)))) 87 | 88 | (defn desugar-symbol [form env] 89 | (let [ns (namespace form) 90 | n (name form) 91 | form (symbol ns n)] 92 | (if (dotted-symbol? form env) 93 | (let [idx (.indexOf n ".") 94 | sym (symbol ns (.substring n 0 idx))] 95 | (list '. sym (symbol (str "-" (.substring n (inc idx) (count n)))))) 96 | 97 | form))) 98 | 99 | (defn desugar-host-expr [form env] 100 | (if (symbol? (first form)) 101 | (let [[op & expr] form 102 | opname (name op) 103 | opns (namespace op)] 104 | (cond 105 | 106 | ;; (.foo bar ..) -> (. bar foo ..) 107 | (= (first opname) \.) 108 | (let [[target & args] expr 109 | args (list* (symbol (subs opname 1)) args)] 110 | (list '. target (if (= 1 (count args)) 111 | (first args) args))) 112 | 113 | ;; (foo. ..) -> (new foo ..) 114 | (= (last opname) \.) 115 | (let [op-s (str op)] 116 | (list* 'new (symbol (subs op-s 0 (dec (count op-s)))) expr)) 117 | 118 | ;; (var.foo ..) -> (. var foo ..) 119 | (dotted-symbol? op env) 120 | (let [idx (.indexOf opname ".") 121 | sym (symbol opns (.substring opname 0 idx))] 122 | (list '. sym (list* (symbol (.substring opname (inc idx) (count opname))) expr))) 123 | 124 | :else (list* op expr))) 125 | form)) 126 | 127 | (defn macroexpand-1 [form env] 128 | "If form represents a macro form returns its expansion, else returns form." 129 | (env/ensure (global-env) 130 | (if (seq? form) 131 | (let [op (first form)] 132 | (if (or (not (symbol? op)) 133 | (specials op)) 134 | form 135 | (if-let [clj-macro (and (not (-> env :locals (get op))) 136 | (maybe-macro op env))] 137 | (with-bindings (merge {#'*ns* (create-ns *cljs-ns*)} 138 | (when-not (thread-bound? #'*cljs-ns*) 139 | {#'*cljs-ns* *cljs-ns*})) 140 | (let [ret (apply clj-macro form env (rest form))] ; (m &form &env & args) 141 | (if (and (seq? ret) 142 | (= 'js* (first ret))) 143 | (vary-meta ret merge 144 | (when (-> clj-macro meta :cljs.analyzer/numeric) 145 | {:tag 'number})) 146 | ret))) 147 | (with-meta (desugar-host-expr form env) (meta form))))) 148 | (with-meta (desugar-symbol form env) (meta form))))) 149 | 150 | (defn create-var 151 | "Creates a var map for sym and returns it." 152 | [sym {:keys [ns]}] 153 | (with-meta {:op :var 154 | :name sym 155 | :ns ns} 156 | (meta sym))) 157 | 158 | (defn var? [x] 159 | (= :var (:op x))) 160 | 161 | (def ^:private ^:dynamic *deps-map* {:path [] :deps #{}}) 162 | (declare analyze-ns) 163 | 164 | (defn ensure-loaded [ns {:keys [refer]}] 165 | (assert (not (contains? (:deps *deps-map*) ns)) 166 | (str "Circular dependency detected :" (conj (:path *deps-map*) ns))) 167 | (binding [*deps-map* (-> *deps-map* 168 | (update-in [:path] conj ns) 169 | (update-in [:deps] conj ns))] 170 | (let [namespaces (-> (env/deref-env) :namespaces)] 171 | (or (and (get namespaces ns) 172 | (not (get-in namespaces [ns :js-namespace]))) 173 | (and (get-in (env/deref-env) [:js-dependency-index (name ns)]) 174 | (swap! env/*env* update-in [:namespaces ns] merge 175 | {:ns ns 176 | :js-namespace true}) 177 | (swap! env/*env* update-in [:namespaces ns :mappings] merge 178 | (reduce (fn [m k] (assoc m k {:op :js-var 179 | :name k 180 | :ns ns})) 181 | {} refer))) 182 | (analyze-ns ns))))) 183 | 184 | (defn core-macros [] 185 | (reduce-kv (fn [m k v] 186 | (if (:macro (meta v)) 187 | (assoc m k v) 188 | m)) 189 | {} (ns-interns 'clojure.tools.analyzer.js.cljs.core))) 190 | 191 | (defn populate-env 192 | [{:keys [import require require-macros refer-clojure]} ns-name env] 193 | (let [imports (reduce-kv (fn [m prefix suffixes] 194 | (merge m (into {} (mapv (fn [s] [s {:op :js-var 195 | :ns prefix 196 | :name s}]) suffixes)))) {} import) 197 | require-aliases (reduce (fn [m [ns {:keys [as]}]] 198 | (if as 199 | (assoc m as ns) 200 | m)) {} require) 201 | require-mappings (reduce (fn [m [ns {:keys [refer] :as spec}]] 202 | (ensure-loaded ns spec) 203 | (reduce #(assoc %1 %2 (get-in (env/deref-env) 204 | [:namespaces ns :mappings %2])) m refer)) 205 | {} require) 206 | core-mappings (apply dissoc (get-in (env/deref-env) [:namespaces 'cljs.core :mappings]) (:exclude refer-clojure)) 207 | macro-aliases (reduce (fn [m [ns {:keys [as]}]] 208 | (if as 209 | (assoc m as ns) 210 | m)) {} require-macros) 211 | core-macro-mappings (apply dissoc (core-macros) (:exclude refer-clojure)) 212 | macro-mappings (reduce (fn [m [ns {:keys [refer]}]] 213 | (core/require ns) 214 | (reduce #(let [m (ns-resolve ns (name %2))] 215 | (if (:macro (meta m)) 216 | (assoc %1 %2 m) 217 | %1)) m refer)) 218 | {} require-macros)] 219 | 220 | (swap! env/*env* assoc-in [:namespaces ns-name] 221 | {:ns ns-name 222 | :mappings (merge core-mappings require-mappings imports) 223 | :aliases require-aliases 224 | :macro-mappings (merge core-macro-mappings macro-mappings) 225 | :macro-aliases macro-aliases}))) 226 | 227 | (def default-passes 228 | "Set of passes that will be run by default on the AST by #'run-passes" 229 | #{#'uniquify2/uniquify-locals 230 | 231 | #'source-info 232 | #'elide-meta 233 | 234 | #'validate 235 | #'infer-tag}) 236 | 237 | (def scheduled-default-passes 238 | (delay 239 | (passes/schedule default-passes))) 240 | 241 | (comment 242 | (clojure.pprint/pprint 243 | (passes/schedule default-passes 244 | {:debug? true})) 245 | ) 246 | 247 | (declare parse) 248 | 249 | (defn analyze 250 | "Returns an AST for the form. 251 | 252 | Binds tools.analyzer/{macroexpand-1,create-var,parse} to 253 | tools.analyzer.js/{macroexpand-1,create-var,parse} and analyzes the form. 254 | 255 | If provided, opts should be a map of options to analyze, currently the only valid 256 | options are :bindings and :passes-opts. 257 | If provided, :bindings should be a map of Var->value pairs that will be merged into the 258 | default bindings for tools.analyzer, useful to provide custom extension points. 259 | If provided, :passes-opts should be a map of pass-name-kw->pass-config-map pairs that 260 | can be used to configure the behaviour of each pass. 261 | 262 | E.g. 263 | (analyze form env {:bindings {#'ana/macroexpand-1 my-mexpand-1}}) 264 | 265 | Calls `run-passes` on the AST." 266 | ([form] (analyze form (empty-env) {})) 267 | ([form env] (analyze form env {})) 268 | ([form env opts] 269 | (with-bindings (merge {#'ana/macroexpand-1 macroexpand-1 270 | #'ana/create-var create-var 271 | #'ana/scheduled-passes @scheduled-default-passes 272 | #'ana/parse parse 273 | #'ana/var? var? 274 | #'elides (-> elides 275 | (update-in [:all] into #{:line :column :end-line :end-column :file :source}) 276 | (assoc-in [:fn] #{:cljs.analyzer/type :cljs.analyzer/protocol-impl :cljs.analyzer/protocol-inline}))} 277 | (when-not (thread-bound? #'*cljs-ns*) 278 | {#'*cljs-ns* *cljs-ns*}) 279 | (:bindings opts)) 280 | (env/ensure (global-env) 281 | (swap! env/*env* mmerge {:passes-opts (:passes-opts opts)}) 282 | (ana/run-passes (ana/unanalyzed form env)))))) 283 | 284 | ; (U ':deftype ':defrecord) Any Config -> AST 285 | (defn parse-type 286 | [op [_ name fields pmasks body :as form] {:keys [ns] :as env}] 287 | (let [fields-expr (mapv (fn [name] 288 | {:env env 289 | :form name 290 | :name name 291 | :mutable (:mutable (meta name)) 292 | :local :field 293 | :op :binding}) 294 | fields) 295 | protocols (-> name meta :protocols) 296 | 297 | _ (swap! env/*env* assoc-in [:namespaces ns :mappings name] 298 | {:op :var 299 | :type true 300 | :name name 301 | :ns ns 302 | :fields fields 303 | :protocols protocols}) 304 | 305 | body-expr (ana/unanalyzed 306 | body 307 | (assoc env :locals (zipmap fields (map dissoc-env fields-expr))))] 308 | 309 | {:op op 310 | :env env 311 | :form form 312 | :name name 313 | :fields fields-expr 314 | :body body-expr 315 | :pmasks pmasks 316 | :protocols protocols 317 | :children [:fields :body]})) 318 | 319 | ;; no ~{foo} support since cljs itself doesn't use it anywhere 320 | (defn parse-js* 321 | [[_ jsform & args :as form] env] 322 | (when-not (string? jsform) 323 | (throw (ex-info "Invalid js* form" 324 | (merge {:form form} 325 | (-source-info form env))))) 326 | (let [segs (loop [segs [] ^String s jsform] 327 | (let [idx (.indexOf s "~{")] 328 | (if (= -1 idx) 329 | (conj segs s) 330 | (recur (conj segs (subs s 0 idx)) 331 | (subs s (inc (.indexOf s "}" idx))))))) 332 | exprs (mapv #(ana/unanalyzed % (ctx env :ctx/expr)) args)] 333 | (merge 334 | {:op :js 335 | :env env 336 | :form form 337 | :segs segs} 338 | (when args 339 | {:args exprs 340 | :children [:args]})))) 341 | 342 | (defn parse-case* 343 | [[_ test tests thens default :as form] env] 344 | (assert (symbol? test) "case* must switch on symbol") 345 | (assert (every? vector? tests) "case* tests must be grouped in vectors") 346 | (let [expr-env (ctx env :expr) 347 | test-expr (ana/unanalyzed test expr-env) 348 | nodes (mapv (fn [tests then] 349 | {:op :case-node 350 | ;; no :form, this is a synthetic grouping node 351 | :env env 352 | :tests (mapv (fn [test] 353 | {:op :case-test 354 | :form test 355 | :env expr-env 356 | :test (ana/unanalyzed test expr-env) 357 | :children [:test]}) 358 | tests) 359 | :then {:op :case-then 360 | :form test 361 | :env env 362 | :then (ana/unanalyzed then env) 363 | :children [:then]} 364 | :children [:tests :then]}) 365 | tests thens) 366 | default-expr (ana/unanalyzed default env)] 367 | (assert (every? (fn [t] (and (= :const (-> t :test :op)) 368 | ((some-fn number? string?) (:form t)))) 369 | (mapcat :tests nodes)) 370 | "case* tests must be numbers or strings") 371 | {:op :case 372 | :form form 373 | :env env 374 | :test (assoc test-expr :case-test true) 375 | :nodes nodes 376 | :default default-expr 377 | :children [:test :nodes :default]})) 378 | 379 | (defn parse-ns 380 | [[_ name & args :as form] env] 381 | (when-not (symbol? name) 382 | (throw (ex-info (str "Namespaces must be named by a symbol, had: " 383 | (.getName ^Class (class name))) 384 | (merge {:form form} 385 | (-source-info form env))))) 386 | (let [[docstring & args] (if (string? (first args)) 387 | args 388 | (cons nil args)) 389 | [metadata & args] (if (map? (first args)) 390 | args 391 | (cons {} args)) 392 | name (vary-meta name merge metadata) 393 | ns-opts (doto (desugar-ns-specs args form env) 394 | (validate-ns-specs form env) 395 | (populate-env name env))] 396 | (set! *cljs-ns* name) 397 | (merge 398 | {:op :ns 399 | :env env 400 | :form form 401 | :name name 402 | :depends (set (keys (:require ns-opts)))} 403 | (when docstring 404 | {:doc docstring}) 405 | (when metadata 406 | {:meta metadata})))) 407 | 408 | (defn parse-def 409 | [[_ sym & rest :as form] env] 410 | (let [ks #{:ns :name :doc :arglists :file :line :column} 411 | meta (meta sym) 412 | m (merge {} 413 | (update-vals (select-keys meta ks) (fn [x] (list 'quote x))) 414 | (when (:test meta) 415 | {:test `(.-cljs$lang$test ~sym)}))] 416 | (ana/analyze-form (with-meta `(def ~(with-meta sym m) ~@rest) (meta form)) env))) 417 | 418 | ;; can it be :literal ? 419 | (defn parse-js-value 420 | [form env] 421 | (let [val (.val ^JSValue form) 422 | items-env (ctx env :expr)] 423 | (if (map? val) 424 | ;; keys should always be symbols/kewords, do we really need to analyze them? 425 | {:op :js-object 426 | :env env 427 | :keys (mapv (ana/unanalyzed-in-env items-env) (keys val)) 428 | :vals (mapv (ana/unanalyzed-in-env items-env) (vals val)) 429 | :form form 430 | :children [:keys :vals]} 431 | {:op :js-array 432 | :env env 433 | :items (mapv (ana/unanalyzed-in-env items-env) val) 434 | :form form 435 | :children [:items]}))) 436 | 437 | (defn parse 438 | "Extension to clojure.core.typed.analyzer/-parse for JS special forms" 439 | [form env] 440 | (cond 441 | (instance? JSValue form) (parse-js-value form env) 442 | :else 443 | ((case (first form) 444 | deftype* #(parse-type :deftype %1 %2) 445 | defrecord* #(parse-type :defrecord %1 %2) 446 | case* parse-case* 447 | ns parse-ns 448 | def parse-def 449 | js* parse-js* 450 | #_:else ana/-parse) 451 | form env))) 452 | -------------------------------------------------------------------------------- /src/main/clojure/clojure/core/typed/analyzer/jvm.clj: -------------------------------------------------------------------------------- 1 | ;; Copyright (c) Ambrose Bonnaire-Sergeant, 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 | ;; adapted from tools.analyzer.jvm 10 | (ns clojure.core.typed.analyzer.jvm 11 | (:refer-clojure :exclude [macroexpand-1]) 12 | (:require [clojure.tools.analyzer.utils :as u] 13 | [clojure.tools.analyzer.jvm.utils :as ju] 14 | [clojure.core.typed.analyzer.jvm.utils :as jana2-utils] 15 | [clojure.core.typed.analyzer.env :as env] 16 | [clojure.tools.analyzer :as ta] 17 | [clojure.tools.analyzer.ast :as ast] 18 | [clojure.tools.analyzer.jvm :as taj] 19 | [clojure.tools.analyzer.passes.jvm.emit-form :as emit-form] 20 | [clojure.core.typed.analyzer.passes :as passes] 21 | [clojure.core.typed.analyzer.passes.jvm.infer-tag :as infer-tag] 22 | [clojure.tools.analyzer.passes.elide-meta :as elide-meta] 23 | [clojure.tools.analyzer.passes.source-info :as source-info] 24 | [clojure.tools.analyzer.passes.jvm.constant-lifter :as constant-lift] 25 | [clojure.core.typed.analyzer.passes.jvm.analyze-host-expr :as analyze-host-expr] 26 | [clojure.core.typed.analyzer.passes.jvm.classify-invoke :as classify-invoke] 27 | [clojure.core.typed.analyzer.passes.uniquify :as uniquify2] 28 | [clojure.core.typed.analyzer.passes.jvm.validate :as validate] 29 | [clojure.core.typed.analyzer :as ana] 30 | [clojure.core.memoize :as memo]) 31 | (:import (clojure.lang RT Var IObj))) 32 | 33 | (def specials 34 | "Set of the special forms for clojure in the JVM" 35 | (into ana/specials 36 | '#{monitor-enter monitor-exit clojure.core/import* reify* deftype* case*})) 37 | 38 | (declare resolve-ns) 39 | 40 | ;; copied from tools.analyzer.jvm to replace `resolve-ns` and `taj-utils/maybe-class-literal` 41 | (defn desugar-symbol [form env] 42 | (let [sym-ns (namespace form)] 43 | (if-let [target (and sym-ns 44 | (not (resolve-ns (symbol sym-ns) env)) 45 | (jana2-utils/maybe-class-literal sym-ns))] ;; Class/field 46 | (with-meta (list '. target (symbol (str "-" (name form)))) ;; transform to (. Class -field) 47 | (meta form)) 48 | form))) 49 | 50 | ;; copied from tools.analyzer.jvm to replace `resolve-ns` and `taj-utils/maybe-class-literal` 51 | (defn desugar-host-expr [form env] 52 | (let [[op & expr] form] 53 | (if (symbol? op) 54 | (let [opname (name op) 55 | opns (namespace op)] 56 | (if-let [target (and opns 57 | (not (resolve-ns (symbol opns) env)) 58 | (jana2-utils/maybe-class-literal opns))] ; (class/field ..) 59 | 60 | (let [op (symbol opname)] 61 | (with-meta (list '. target (if (zero? (count expr)) 62 | op 63 | (list* op expr))) 64 | (meta form))) 65 | 66 | (cond 67 | (.startsWith opname ".") ; (.foo bar ..) 68 | (let [[target & args] expr 69 | target (if-let [target (jana2-utils/maybe-class-literal target)] 70 | (with-meta (list 'do target) 71 | {:tag 'java.lang.Class}) 72 | target) 73 | args (list* (symbol (subs opname 1)) args)] 74 | (with-meta (list '. target (if (= 1 (count args)) ;; we don't know if (.foo bar) is 75 | (first args) args)) ;; a method call or a field access 76 | (meta form))) 77 | 78 | (.endsWith opname ".") ;; (class. ..) 79 | (with-meta (list* 'new (symbol (subs opname 0 (dec (count opname)))) expr) 80 | (meta form)) 81 | 82 | :else form))) 83 | form))) 84 | 85 | (defn macroexpand-1 86 | "If form represents a macro form or an inlineable function, returns its expansion, 87 | else returns form." 88 | ([form] (macroexpand-1 form (taj/empty-env))) 89 | ([form env] 90 | (cond 91 | 92 | (seq? form) 93 | (let [[op & args] form] 94 | (if (specials op) 95 | form 96 | (let [v (ana/resolve-sym op env) 97 | m (meta v) 98 | local? (-> env :locals (get op)) 99 | macro? (and (not local?) (:macro m)) ;; locals shadow macros 100 | inline-arities-f (:inline-arities m) 101 | inline? (and (not local?) 102 | (or (not inline-arities-f) 103 | (inline-arities-f (count args))) 104 | (:inline m)) 105 | t (:tag m)] 106 | (cond 107 | 108 | macro? 109 | (let [res (apply v form (:locals env) (rest form))] ; (m &form &env & args) 110 | (if (u/obj? res) 111 | (vary-meta res merge (meta form)) 112 | res)) 113 | 114 | inline? 115 | (let [res (apply inline? args)] 116 | (if (u/obj? res) 117 | (vary-meta res merge 118 | (and t {:tag t}) 119 | (meta form)) 120 | res)) 121 | 122 | :else 123 | (desugar-host-expr form env))))) 124 | 125 | (symbol? form) 126 | (desugar-symbol form env) 127 | 128 | :else 129 | form))) 130 | 131 | ;;redefine passes mainly to move dependency on `uniquify-locals` 132 | ;; to `uniquify2/uniquify-locals` 133 | 134 | (def default-passes 135 | "Set of passes that will be run by default on the AST by #'run-passes" 136 | ;taj/default-passes 137 | #{;#'warn-on-reflection 138 | ;#'warn-earmuff 139 | 140 | #'uniquify2/uniquify-locals 141 | 142 | ;KEEP 143 | #'source-info/source-info 144 | #'elide-meta/elide-meta 145 | #'constant-lift/constant-lift ; might cause troubles, treat suspiciously 146 | ;KEEP 147 | 148 | ; not compatible with core.typed 149 | ;#'trim/trim 150 | 151 | ; FIXME is this needed? introduces another pass 152 | ; TODO does this still introduce another pass with `uniquify2/uniquify-locals`? 153 | ;#'box 154 | ;#'box/box 155 | 156 | ;KEEP 157 | #'analyze-host-expr/analyze-host-expr 158 | ;#'validate-loop-locals 159 | #'validate/validate 160 | #'infer-tag/infer-tag 161 | ;KEEP 162 | 163 | ;KEEP 164 | #'classify-invoke/classify-invoke 165 | ;KEEP 166 | }) 167 | 168 | (def scheduled-default-passes 169 | (delay 170 | (passes/schedule default-passes))) 171 | 172 | (comment 173 | (clojure.pprint/pprint 174 | (passes/schedule default-passes 175 | {:debug? true})) 176 | ) 177 | 178 | (def default-passes-opts 179 | "Default :passes-opts for `analyze`" 180 | {:collect/what #{:constants :callsites} 181 | :collect/where #{:deftype :reify :fn} 182 | :collect/top-level? false 183 | :collect-closed-overs/where #{:deftype :reify :fn :loop :try} 184 | :collect-closed-overs/top-level? false}) 185 | 186 | ; (U Sym nil) -> (U Sym nil) 187 | (defn resolve-ns 188 | "Resolves the ns mapped by the given sym in the global env" 189 | [ns-sym {:keys [ns]}] 190 | {:pre [((some-fn symbol? nil?) ns-sym)] 191 | :post [(or (and (symbol? %) 192 | (not (namespace %))) 193 | (nil? %))]} 194 | (when ns-sym 195 | (some-> (or (get (ns-aliases ns) ns-sym) 196 | (find-ns ns-sym)) 197 | ns-name))) 198 | 199 | ;Any -> Any 200 | (defn resolve-sym 201 | "Resolves the value mapped by the given sym in the global env" 202 | [sym {:keys [ns locals] :as env}] 203 | (when (symbol? sym) 204 | (ns-resolve ns locals sym))) 205 | 206 | (defn current-ns-name 207 | "Returns the current namespace symbol." 208 | [env] 209 | (ns-name *ns*)) 210 | 211 | (defn var->sym 212 | "If given a var, returns the fully qualified symbol for that var, otherwise nil." 213 | [^clojure.lang.Var v] 214 | (when (var? v) 215 | (symbol (when (.ns v) 216 | (str (ns-name (.ns v)))) 217 | (str (.sym v))))) 218 | 219 | ; copied from tools.analyzer.jvm 220 | ; - remove usage of *env* 221 | (defn create-var 222 | "Creates a Var for sym and returns it. 223 | The Var gets interned in the env namespace." 224 | [sym {:keys [ns]}] 225 | (let [v (get (ns-interns ns) (symbol (name sym)))] 226 | (if (and v (or (class? v) 227 | (= ns (ns-name (.ns ^Var v) )))) 228 | v 229 | (let [meta (dissoc (meta sym) :inline :inline-arities :macro) 230 | meta (if-let [arglists (:arglists meta)] 231 | (assoc meta :arglists (taj/qualify-arglists arglists)) 232 | meta)] 233 | (intern ns (with-meta sym meta)))))) 234 | 235 | ; no global namespaces tracking (since resolve-{sym,ns} is now platform dependent), 236 | ; mostly used for passes configuration. 237 | (defn global-env [] 238 | (atom {})) 239 | 240 | (defn parse-monitor-enter 241 | [[_ target :as form] env] 242 | (when-not (= 2 (count form)) 243 | (throw (ex-info (str "Wrong number of args to monitor-enter, had: " (dec (count form))) 244 | (merge {:form form} 245 | (u/-source-info form env))))) 246 | {:op :monitor-enter 247 | :env env 248 | :form form 249 | :target (ana/unanalyzed target (u/ctx env :ctx/expr)) 250 | :children [:target]}) 251 | 252 | (defn parse-monitor-exit 253 | [[_ target :as form] env] 254 | (when-not (= 2 (count form)) 255 | (throw (ex-info (str "Wrong number of args to monitor-exit, had: " (dec (count form))) 256 | (merge {:form form} 257 | (u/-source-info form env))))) 258 | {:op :monitor-exit 259 | :env env 260 | :form form 261 | :target (ana/unanalyzed target (u/ctx env :ctx/expr)) 262 | :children [:target]}) 263 | 264 | (defn parse-import* 265 | [[_ class :as form] env] 266 | (when-not (= 2 (count form)) 267 | (throw (ex-info (str "Wrong number of args to import*, had: " (dec (count form))) 268 | (merge {:form form} 269 | (u/-source-info form env))))) 270 | {:op :import 271 | :env env 272 | :form form 273 | :class class}) 274 | 275 | (defn analyze-method-impls 276 | [[method [this & params :as args] & body :as form] env] 277 | (when-let [error-msg (cond 278 | (not (symbol? method)) 279 | (str "Method method must be a symbol, had: " (class method)) 280 | (not (vector? args)) 281 | (str "Parameter listing should be a vector, had: " (class args)) 282 | (not (first args)) 283 | (str "Must supply at least one argument for 'this' in: " method))] 284 | (throw (ex-info error-msg 285 | (merge {:form form 286 | :in (:this env) 287 | :method method 288 | :args args} 289 | (u/-source-info form env))))) 290 | (let [meth (cons (vec params) body) ;; this is an implicit arg 291 | this-expr {:name this 292 | :env env 293 | :form this 294 | :op :binding 295 | :o-tag (:this env) 296 | :tag (:this env) 297 | :local :this} 298 | env (assoc-in (dissoc env :this) [:locals this] (u/dissoc-env this-expr)) 299 | method-expr (ana/analyze-fn-method meth env)] 300 | (assoc (dissoc method-expr :variadic?) 301 | :op :method 302 | :form form 303 | :this this-expr 304 | :name (symbol (name method)) 305 | :children (into [:this] (:children method-expr))))) 306 | 307 | ; copied from tools.analyzer.jvm 308 | ; - removed *env* update 309 | ;; HACK 310 | (defn -deftype [cname class-name args interfaces] 311 | 312 | (doseq [arg [class-name cname]] 313 | (memo/memo-clear! ju/members* [arg]) 314 | (memo/memo-clear! ju/members* [(str arg)])) 315 | 316 | (let [interfaces (mapv #(symbol (.getName ^Class %)) interfaces)] 317 | (eval (list 'let [] 318 | (list 'deftype* cname class-name args :implements interfaces) 319 | (list 'import class-name))))) 320 | 321 | (defn parse-reify* 322 | [[_ interfaces & methods :as form] env] 323 | (let [interfaces (conj (disj (set (mapv ju/maybe-class interfaces)) Object) 324 | IObj) 325 | name (gensym "reify__") 326 | class-name (symbol (str (namespace-munge *ns*) "$" name)) 327 | menv (assoc env :this class-name) 328 | methods (mapv #(assoc (analyze-method-impls % menv) :interfaces interfaces) 329 | methods)] 330 | 331 | (-deftype name class-name [] interfaces) 332 | 333 | (ana/wrapping-meta 334 | {:op :reify 335 | :env env 336 | :form form 337 | :class-name class-name 338 | :methods methods 339 | :interfaces interfaces 340 | :children [:methods]}))) 341 | 342 | (defn parse-opts+methods [methods] 343 | (loop [opts {} methods methods] 344 | (if (keyword? (first methods)) 345 | (recur (assoc opts (first methods) (second methods)) (nnext methods)) 346 | [opts methods]))) 347 | 348 | (defn parse-deftype* 349 | [[_ name class-name fields _ interfaces & methods :as form] env] 350 | (let [interfaces (disj (set (mapv ju/maybe-class interfaces)) Object) 351 | fields-expr (mapv (fn [name] 352 | {:env env 353 | :form name 354 | :name name 355 | :mutable (let [m (meta name)] 356 | (or (and (:unsynchronized-mutable m) 357 | :unsynchronized-mutable) 358 | (and (:volatile-mutable m) 359 | :volatile-mutable))) 360 | :local :field 361 | :op :binding}) 362 | fields) 363 | menv (assoc env 364 | :context :ctx/expr 365 | :locals (zipmap fields (map u/dissoc-env fields-expr)) 366 | :this class-name) 367 | [opts methods] (parse-opts+methods methods) 368 | methods (mapv #(assoc (analyze-method-impls % menv) :interfaces interfaces) 369 | methods)] 370 | 371 | (-deftype name class-name fields interfaces) 372 | 373 | {:op :deftype 374 | :env env 375 | :form form 376 | :name name 377 | :class-name class-name ;; internal, don't use as a Class 378 | :fields fields-expr 379 | :methods methods 380 | :interfaces interfaces 381 | :children [:fields :methods]})) 382 | 383 | (defn parse-case* 384 | [[_ expr shift mask default case-map switch-type test-type & [skip-check?] :as form] env] 385 | (let [[low high] ((juxt first last) (keys case-map)) ;;case-map is a sorted-map 386 | e (u/ctx env :ctx/expr) 387 | test-expr (ana/unanalyzed expr e) 388 | [tests thens] (reduce (fn [[te th] [min-hash [test then]]] 389 | (let [test-expr (ana/analyze-const test e) 390 | then-expr (ana/unanalyzed then env)] 391 | [(conj te {:op :case-test 392 | :form test 393 | :env e 394 | :hash min-hash 395 | :test test-expr 396 | :children [:test]}) 397 | (conj th {:op :case-then 398 | :form then 399 | :env env 400 | :hash min-hash 401 | :then then-expr 402 | :children [:then]})])) 403 | [[] []] case-map) 404 | default-expr (ana/unanalyzed default env)] 405 | {:op :case 406 | :form form 407 | :env env 408 | :test (assoc test-expr :case-test true) 409 | :default default-expr 410 | :tests tests 411 | :thens thens 412 | :shift shift 413 | :mask mask 414 | :low low 415 | :high high 416 | :switch-type switch-type 417 | :test-type test-type 418 | :skip-check? skip-check? 419 | :children [:test :tests :thens :default]})) 420 | 421 | (defn parse 422 | "Extension to clojure.core.typed.analyzer/-parse for JVM special forms" 423 | [form env] 424 | ((case (first form) 425 | monitor-enter parse-monitor-enter 426 | monitor-exit parse-monitor-exit 427 | clojure.core/import* parse-import* 428 | reify* parse-reify* 429 | deftype* parse-deftype* 430 | case* parse-case* 431 | #_:else ana/-parse) 432 | form env)) 433 | 434 | (declare parse) 435 | 436 | (defn analyze 437 | "Analyzes a clojure form using tools.analyzer augmented with the JVM specific special ops 438 | and returns its AST, after running #'run-passes on it. 439 | 440 | If no configuration option is provides, analyze will setup tools.analyzer using the extension 441 | points declared in this namespace. 442 | 443 | If provided, opts should be a map of options to analyze, currently the only valid 444 | options are :bindings and :passes-opts (if not provided, :passes-opts defaults to the 445 | value of `default-passes-opts`). 446 | If provided, :bindings should be a map of Var->value pairs that will be merged into the 447 | default bindings for tools.analyzer, useful to provide custom extension points. 448 | If provided, :passes-opts should be a map of pass-name-kw->pass-config-map pairs that 449 | can be used to configure the behaviour of each pass. 450 | 451 | E.g. 452 | (analyze form env {:bindings {#'ana/macroexpand-1 my-mexpand-1}})" 453 | ([form] (analyze form (taj/empty-env) {})) 454 | ([form env] (analyze form env {})) 455 | ([form env opts] 456 | (with-bindings (merge {Compiler/LOADER (RT/makeClassLoader) 457 | #'ana/macroexpand-1 macroexpand-1 458 | #'ana/create-var create-var 459 | #'ana/scheduled-passes @scheduled-default-passes 460 | #'ana/parse parse 461 | #'ana/var? var? 462 | #'ana/resolve-ns resolve-ns 463 | #'ana/resolve-sym resolve-sym 464 | #'ana/current-ns-name current-ns-name 465 | ;#'*ns* (the-ns (:ns env)) 466 | } 467 | (:bindings opts)) 468 | (env/ensure (global-env) 469 | (env/with-env (u/mmerge (env/deref-env) {:passes-opts (get opts :passes-opts default-passes-opts)}) 470 | (ana/run-passes (ana/unanalyzed form env))))))) 471 | 472 | (deftype ExceptionThrown [e ast]) 473 | 474 | (defn ^:private throw! [e] 475 | (throw (.e ^ExceptionThrown e))) 476 | 477 | (defn eval-ast2 478 | "Evaluate an AST node, attaching result to :result." 479 | [ast] 480 | (let [form (emit-form/emit-form ast) 481 | result (clojure.lang.Compiler/eval form)] 482 | (assoc ast :result result))) 483 | 484 | (defn default-thread-bindings [env] 485 | {Compiler/LOADER (RT/makeClassLoader) 486 | #'ana/macroexpand-1 macroexpand-1 487 | #'ana/create-var create-var 488 | #'ana/scheduled-passes @scheduled-default-passes 489 | #'ana/parse parse 490 | #'ana/var? var? 491 | #'ana/resolve-ns resolve-ns 492 | #'ana/resolve-sym resolve-sym 493 | #'ana/var->sym var->sym 494 | #'ana/eval-ast eval-ast2 495 | #'ana/current-ns-name current-ns-name 496 | ;#'*ns* (the-ns (:ns env)) 497 | }) 498 | 499 | (defmethod emit-form/-emit-form :unanalyzed 500 | [{:keys [form] :as ast} opts] 501 | (assert (not (#{:hygienic :qualified-symbols} opts)) 502 | "Cannot support emit-form options on unanalyzed form") 503 | #_(throw (Exception. "Cannot emit :unanalyzed form")) 504 | #_(prn (str "WARNING: emit-form: did not analyze: " form)) 505 | form) 506 | 507 | (defn eval-ast [a {:keys [handle-evaluation-exception] 508 | :or {handle-evaluation-exception throw!} 509 | :as opts}] 510 | (let [frm (emit-form/emit-form a) 511 | ;_ (prn "frm" frm) 512 | result (try (eval frm) ;; eval the emitted form rather than directly the form to avoid double macroexpansion 513 | (catch Exception e 514 | (handle-evaluation-exception (ExceptionThrown. e a))))] 515 | (merge a {:result result}))) 516 | 517 | (defn analyze+eval 518 | "Like analyze but evals the form after the analysis and attaches the 519 | returned value in the :result field of the AST node. 520 | 521 | If evaluating the form will cause an exception to be thrown, the exception 522 | will be caught and wrapped in an ExceptionThrown object, containing the 523 | exception in the `e` field and the AST in the `ast` field. 524 | 525 | The ExceptionThrown object is then passed to `handle-evaluation-exception`, 526 | which by defaults throws the original exception, but can be used to provide 527 | a replacement return value for the evaluation of the AST. 528 | 529 | Unrolls `do` forms to handle the Gilardi scenario. 530 | 531 | Useful when analyzing whole files/namespaces." 532 | ([form] (analyze+eval form (taj/empty-env) {})) 533 | ([form env] (analyze+eval form env {})) 534 | ([form env {:keys [additional-gilardi-condition 535 | eval-fn 536 | annotate-do 537 | statement-opts-fn 538 | stop-gildardi-check 539 | analyze-fn] 540 | :or {additional-gilardi-condition (fn [form env] true) 541 | eval-fn eval-ast 542 | annotate-do (fn [a _ _] a) 543 | statement-opts-fn identity 544 | stop-gildardi-check (fn [form env] false) 545 | analyze-fn analyze} 546 | :as opts}] 547 | (env/ensure (global-env) 548 | (let [env (merge env (u/-source-info form env)) 549 | [mform raw-forms] (with-bindings {Compiler/LOADER (RT/makeClassLoader) 550 | ;#'*ns* (the-ns (:ns env)) 551 | #'ana/resolve-ns resolve-ns 552 | #'ana/resolve-sym resolve-sym 553 | #'ana/current-ns-name current-ns-name 554 | #'ana/macroexpand-1 (get-in opts [:bindings #'ana/macroexpand-1] 555 | macroexpand-1)} 556 | (loop [form form raw-forms []] 557 | (let [mform (if (stop-gildardi-check form env) 558 | form 559 | (ana/macroexpand-1 form env))] 560 | (if (= mform form) 561 | [mform (seq raw-forms)] 562 | (recur mform (conj raw-forms 563 | (if-let [[op & r] (and (seq? form) form)] 564 | (if (or (jana2-utils/macro? op env) 565 | (jana2-utils/inline? op r env)) 566 | (vary-meta form assoc ::ana/resolved-op (ana/resolve-sym op env)) 567 | form) 568 | form)))))))] 569 | (if (and (seq? mform) (= 'do (first mform)) (next mform) 570 | (additional-gilardi-condition mform env)) 571 | ;; handle the Gilardi scenario 572 | (let [[statements ret] (u/butlast+last (rest mform)) 573 | statements-expr (mapv (fn [s] (analyze+eval s (-> env 574 | (u/ctx :ctx/statement) 575 | (assoc :ns (ns-name *ns*))) 576 | (statement-opts-fn opts))) 577 | statements) 578 | ret-expr (analyze+eval ret (assoc env :ns (ns-name *ns*)) opts)] 579 | (annotate-do 580 | {:op :do 581 | :top-level true 582 | :form mform 583 | :statements statements-expr 584 | :ret ret-expr 585 | :children [:statements :ret] 586 | :env env 587 | :result (:result ret-expr) 588 | :raw-forms raw-forms} 589 | statements-expr 590 | ret-expr)) 591 | (let [a (analyze-fn mform env opts) 592 | e (eval-fn a (assoc opts :original-form mform))] 593 | (merge e {:raw-forms raw-forms}))))))) 594 | -------------------------------------------------------------------------------- /src/main/clojure/clojure/core/typed/analyzer.clj: -------------------------------------------------------------------------------- 1 | ;; Copyright (c) Ambrose Bonnaire-Sergeant, 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 | ;; adapted from tools.analyzer 10 | (ns clojure.core.typed.analyzer 11 | (:refer-clojure :exclude [macroexpand-1 var?]) 12 | (:require [clojure.tools.analyzer.ast :as ast] 13 | [clojure.tools.analyzer.utils :as u]) 14 | (:import (clojure.lang Symbol IPersistentVector IPersistentMap IPersistentSet ISeq IType IRecord))) 15 | 16 | (def ^{:dynamic true 17 | :arglists '([form env]) 18 | :doc "If form represents a macro form, returns its expansion, 19 | else returns form."} 20 | macroexpand-1) 21 | 22 | (def ^{:dynamic true 23 | :arglists '([[op & args] env]) 24 | :doc "Multimethod that dispatches on op, should default to -parse"} 25 | parse) 26 | 27 | (def ^{:dynamic true 28 | :arglists '([sym env]) 29 | :doc "Creates a var for sym and returns it"} 30 | create-var) 31 | 32 | (def ^{:dynamic true 33 | :arglists '([obj]) 34 | :doc "Returns true if obj represent a var form as returned by create-var"} 35 | var?) 36 | 37 | (def ^{:dynamic true 38 | :doc "A map of functions such that 39 | 40 | (ast/walk ast (:pre scheduled-passes) (:post scheduled-passes)) 41 | 42 | runs the passes currently scheduled, and 43 | 44 | ((:init-ast scheduled-passes) ast) 45 | 46 | initializes the AST for traversal."} 47 | scheduled-passes) 48 | 49 | (def ^{:dynamic true 50 | :doc "Resolves the value mapped by the given sym in the global env"} 51 | resolve-sym) 52 | 53 | (def ^{:dynamic true 54 | :doc "Resolves the ns mapped by the given sym in the global env"} 55 | resolve-ns) 56 | 57 | (def ^{:dynamic true 58 | :doc "Returns the name symbol of the current namespace."} 59 | current-ns-name) 60 | 61 | (def ^{:dynamic true 62 | :doc "Evaluates an AST node, attaching result to :result."} 63 | eval-ast) 64 | 65 | (def ^{:dynamic true 66 | :doc "If given a var, returns the fully qualified symbol for that var, otherwise nil."} 67 | var->sym) 68 | 69 | (declare analyze-outer-root) 70 | 71 | (defn run-pre-passes 72 | [ast] 73 | ((:pre scheduled-passes) ast)) 74 | 75 | (defn run-post-passes 76 | [ast] 77 | ((:post scheduled-passes) ast)) 78 | 79 | (declare eval-top-level) 80 | 81 | (defn run-passes 82 | "Function that will be invoked on the AST tree immediately after it has been constructed, 83 | by default runs the passes declared in #'default-passes, should be rebound if a different 84 | set of passes is required (via analyze2/run-passes). 85 | 86 | Use #'clojure.tools.analyzer.passes/schedule to get a function from a set of passes that 87 | run-passes can be bound to." 88 | [ast] 89 | {:pre [(map? scheduled-passes)]} 90 | (ast/walk ast 91 | (comp run-pre-passes analyze-outer-root) 92 | (comp eval-top-level run-post-passes))) 93 | 94 | (def specials 95 | '#{do if new quote set! try var 96 | catch throw finally def . 97 | let* letfn* loop* recur fn*}) 98 | 99 | (defmulti -analyze-form (fn [form _] (class form))) 100 | 101 | (declare analyze-symbol 102 | analyze-vector 103 | analyze-map 104 | analyze-set 105 | analyze-seq 106 | analyze-const) 107 | 108 | (def analyze-form 109 | "Like analyze, but does not mark the form with :top-level true" 110 | -analyze-form) 111 | 112 | (defmethod -analyze-form Symbol 113 | [form env] 114 | (analyze-symbol form env)) 115 | 116 | (defmethod -analyze-form IPersistentVector 117 | [form env] 118 | (analyze-vector form env)) 119 | 120 | (defmethod -analyze-form IPersistentMap 121 | [form env] 122 | (analyze-map form env)) 123 | 124 | (defmethod -analyze-form IPersistentSet 125 | [form env] 126 | (analyze-set form env)) 127 | 128 | (defmethod -analyze-form ISeq 129 | [form env] 130 | (if-let [form (seq form)] 131 | (analyze-seq form env) 132 | (analyze-const form env))) 133 | 134 | (defmethod -analyze-form IType 135 | [form env] 136 | (analyze-const form env :type)) 137 | 138 | (prefer-method -analyze-form IType IPersistentMap) 139 | (prefer-method -analyze-form IType IPersistentVector) 140 | (prefer-method -analyze-form IType IPersistentSet) 141 | (prefer-method -analyze-form IType ISeq) 142 | 143 | (defmethod -analyze-form IRecord 144 | [form env] 145 | (analyze-const form env :record)) 146 | 147 | (prefer-method -analyze-form IRecord IPersistentMap) 148 | (prefer-method -analyze-form IRecord IPersistentVector) 149 | (prefer-method -analyze-form IRecord IPersistentSet) 150 | (prefer-method -analyze-form IRecord ISeq) 151 | 152 | (defmethod -analyze-form :default 153 | [form env] 154 | (analyze-const form env)) 155 | 156 | (defn analyze 157 | "Given a top-level form to analyze and an environment, a map containing: 158 | * :locals a map from binding symbol to AST of the binding value 159 | * :context a keyword describing the form's context from the :ctx/* hierarchy. 160 | ** :ctx/expr the form is an expression: its value is used 161 | ** :ctx/return the form is an expression in return position, derives :ctx/expr 162 | ** :ctx/statement the value of the form is not used 163 | * :ns a symbol representing the current namespace of the form to be 164 | analyzed 165 | 166 | returns one level of the AST for that form, with all children 167 | stubbed out with :unanalyzed nodes." 168 | [form env] 169 | (assoc (analyze-form form env) :top-level true)) 170 | 171 | (defn unanalyzed 172 | [form env] 173 | (let [init-ast (:init-ast scheduled-passes) 174 | _ (assert init-ast "scheduled-passes must bind :init-ast")] 175 | (init-ast 176 | {:op :unanalyzed 177 | :form form 178 | :env env 179 | ;; ::config will be inherited by whatever node 180 | ;; this :unanalyzed node becomes when analyzed 181 | ::config {}}))) 182 | 183 | (defn mark-top-level 184 | [ast] 185 | ; in ::config because an :unanalyzed node is still top-level 186 | ; once analyzed 187 | (assoc-in ast [::config :top-level] true)) 188 | 189 | (defn unmark-top-level 190 | [ast] 191 | (update ast ::config dissoc :top-level)) 192 | 193 | (defn top-level? 194 | [ast] 195 | (boolean (get-in ast [::config :top-level]))) 196 | 197 | (defn mark-eval-top-level 198 | [ast] 199 | (assoc ast ::eval-gilardi? true)) 200 | 201 | (defn unmark-eval-top-level 202 | [ast] 203 | (dissoc ast ::eval-gilardi?)) 204 | 205 | (defn eval-top-level? 206 | [ast] 207 | (boolean (get ast ::eval-gilardi?))) 208 | 209 | (defn unanalyzed-top-level 210 | [form env] 211 | (mark-top-level (unanalyzed form env))) 212 | 213 | (defn propagate-top-level 214 | "Propagate :top-level down :do nodes. Attach ::ana2/eval-gilardi? to 215 | root nodes that should be evaluated." 216 | [{:keys [op] :as ast}] 217 | (if (and (not= :unanalyzed op) 218 | (get-in ast [::config :top-level])) 219 | ; we know this root node is fully analyzed, so we can reliably predict 220 | ; whether to evaluate it under the Gilardi scenario. 221 | (case (:op ast) 222 | :do (ast/update-children ast mark-top-level) 223 | (mark-eval-top-level ast)) 224 | ast)) 225 | 226 | (defn propagate-result 227 | "Propagate :result from :top-level :do nodes." 228 | [ast] 229 | {:pre [(:op ast)]} 230 | (cond-> ast 231 | (and (= :do (:op ast)) 232 | (get-in ast [::config :top-level]) 233 | (contains? (:ret ast) :result)) 234 | (assoc :result (:result (:ret ast))))) 235 | 236 | (defn eval-top-level 237 | "Evaluate `eval-top-level?` nodes and unanalyzed `top-level?` nodes. 238 | Otherwise, propagate result from children." 239 | [ast] 240 | {:pre [(:op ast)]} 241 | (if (or (eval-top-level? ast) 242 | (and (top-level? ast) 243 | (= :unanalyzed (:op ast)))) 244 | (eval-ast ast) 245 | (propagate-result ast))) 246 | 247 | (defn analyze-outer 248 | "If ast is :unanalyzed, then call analyze-form on it, otherwise returns ast." 249 | [ast] 250 | (case (:op ast) 251 | :unanalyzed (let [{:keys [form env ::config]} ast 252 | ast (-> form 253 | (analyze-form env) 254 | ;TODO rename to ::inherited 255 | (assoc ::config config) 256 | propagate-top-level 257 | (assoc-in [:env :ns] (current-ns-name env)))] 258 | ast) 259 | ast)) 260 | 261 | (defn analyze-outer-root 262 | "Repeatedly call analyze-outer to a fixed point." 263 | [ast] 264 | (let [ast' (analyze-outer ast)] 265 | (if (identical? ast ast') 266 | ast' 267 | (recur ast')))) 268 | 269 | (defn unanalyzed-in-env 270 | "Takes an env map and returns a function that analyzes a form in that env" 271 | [env] 272 | (fn [form] (unanalyzed form env))) 273 | 274 | (def ^{:dynamic true 275 | :arglists '([[op & args] env]) 276 | :doc "Function that dispatches on op, should default to -parse"} 277 | parse) 278 | 279 | ;; this node wraps non-quoted collections literals with metadata attached 280 | ;; to them, the metadata will be evaluated at run-time, not treated like a constant 281 | (defn wrapping-meta 282 | [{:keys [form env] :as expr}] 283 | (let [meta (meta form)] 284 | (if (and (u/obj? form) 285 | (seq meta)) 286 | {:op :with-meta 287 | :env env 288 | :form form 289 | :meta (unanalyzed meta (u/ctx env :ctx/expr)) 290 | :expr (assoc-in expr [:env :context] :ctx/expr) 291 | :children [:meta :expr]} 292 | expr))) 293 | 294 | (defn analyze-const 295 | [form env & [type]] 296 | (let [type (or type (u/classify form))] 297 | (merge 298 | {:op :const 299 | :env env 300 | :type type 301 | :literal? true 302 | :val form 303 | :form form} 304 | (when-let [m (and (u/obj? form) 305 | (not-empty (meta form)))] 306 | {:meta (analyze-const m (u/ctx env :ctx/expr) :map) ;; metadata on a constant literal will not be evaluated at 307 | :children [:meta]})))) ;; runtime, this is also true for metadata on quoted collection literals 308 | 309 | (defn analyze-vector 310 | [form env] 311 | (let [items-env (u/ctx env :ctx/expr) 312 | items (mapv (unanalyzed-in-env items-env) form)] 313 | (wrapping-meta 314 | {:op :vector 315 | :env env 316 | :items items 317 | :form form 318 | :children [:items]}))) 319 | 320 | (defn analyze-map 321 | [form env] 322 | (let [kv-env (u/ctx env :ctx/expr) 323 | [keys vals] (reduce-kv (fn [[keys vals] k v] 324 | [(conj keys k) (conj vals v)]) 325 | [[] []] form) 326 | ks (mapv (unanalyzed-in-env kv-env) keys) 327 | vs (mapv (unanalyzed-in-env kv-env) vals)] 328 | (wrapping-meta 329 | {:op :map 330 | :env env 331 | :keys ks 332 | :vals vs 333 | :form form 334 | :children [:keys :vals]}))) 335 | 336 | (defn analyze-set 337 | [form env] 338 | (let [items-env (u/ctx env :ctx/expr) 339 | items (mapv (unanalyzed-in-env items-env) form)] 340 | (wrapping-meta 341 | {:op :set 342 | :env env 343 | :items items 344 | :form form 345 | :children [:items]}))) 346 | 347 | (defn analyze-symbol 348 | [sym env] 349 | (let [mform (macroexpand-1 sym env)] ;; t.a.j/macroexpand-1 macroexpands Class/Field into (. Class Field) 350 | (if (= mform sym) 351 | (merge (if-let [{:keys [mutable children] :as local-binding} (-> env :locals sym)] ;; locals shadow globals 352 | (merge local-binding 353 | {:op :local 354 | :assignable? (boolean mutable) 355 | ;; don't walk :init, but keep in AST 356 | :children (vec (remove #{:init} children))}) 357 | (if-let [var (let [v (resolve-sym sym env)] 358 | (and (var? v) v))] 359 | (let [m (meta var)] 360 | {:op :var 361 | :assignable? (u/dynamic? var m) ;; we cannot statically determine if a Var is in a thread-local context 362 | :var var ;; so checking whether it's dynamic or not is the most we can do 363 | :meta m}) 364 | (if-let [maybe-class (namespace sym)] ;; e.g. js/foo.bar or Long/MAX_VALUE 365 | (let [maybe-class (symbol maybe-class)] 366 | {:op :maybe-host-form 367 | :class maybe-class 368 | :field (symbol (name sym))}) 369 | {:op :maybe-class ;; e.g. java.lang.Integer or Long 370 | :class mform}))) 371 | {:env env 372 | :form mform}) 373 | (-> (unanalyzed mform env) 374 | (update-in [:raw-forms] (fnil conj ()) sym))))) 375 | 376 | (defn analyze-seq 377 | [form env] 378 | ;(prn "analyze-seq" form) 379 | (let [op (first form)] 380 | (when (nil? op) 381 | (throw (ex-info "Can't call nil" 382 | (merge {:form form} 383 | (u/-source-info form env))))) 384 | (let [mform (macroexpand-1 form env)] 385 | (if (= form mform) ;; function/special-form invocation 386 | (parse mform env) 387 | (-> (unanalyzed mform env) 388 | (update-in [:raw-forms] (fnil conj ()) 389 | (vary-meta form assoc ::resolved-op (resolve-sym op env)))))))) 390 | 391 | (defn parse-do 392 | [[_ & exprs :as form] env] 393 | (let [statements-env (u/ctx env :ctx/statement) 394 | [statements ret] (loop [statements [] [e & exprs] exprs] 395 | (if (seq exprs) 396 | (recur (conj statements e) exprs) 397 | [statements e])) 398 | statements (mapv (unanalyzed-in-env statements-env) statements) 399 | ret (unanalyzed ret env)] 400 | {:op :do 401 | :env env 402 | :form form 403 | :statements statements 404 | :ret ret 405 | :children [:statements :ret]})) 406 | 407 | (defn parse-if 408 | [[_ test then else :as form] env] 409 | (let [formc (count form)] 410 | (when-not (or (= formc 3) (= formc 4)) 411 | (throw (ex-info (str "Wrong number of args to if, had: " (dec (count form))) 412 | (merge {:form form} 413 | (u/-source-info form env)))))) 414 | (let [test-expr (unanalyzed test (u/ctx env :ctx/expr)) 415 | then-expr (unanalyzed then env) 416 | else-expr (unanalyzed else env)] 417 | {:op :if 418 | :form form 419 | :env env 420 | :test test-expr 421 | :then then-expr 422 | :else else-expr 423 | :children [:test :then :else]})) 424 | 425 | (defn parse-new 426 | [[_ class & args :as form] env] 427 | (when-not (>= (count form) 2) 428 | (throw (ex-info (str "Wrong number of args to new, had: " (dec (count form))) 429 | (merge {:form form} 430 | (u/-source-info form env))))) 431 | (let [args-env (u/ctx env :ctx/expr) 432 | args (mapv (unanalyzed-in-env args-env) args)] 433 | {:op :new 434 | :env env 435 | :form form 436 | :class (analyze-form class (assoc env :locals {})) ;; avoid shadowing 437 | :args args 438 | :children [:class :args]})) 439 | 440 | (defn parse-quote 441 | [[_ expr :as form] env] 442 | (when-not (= 2 (count form)) 443 | (throw (ex-info (str "Wrong number of args to quote, had: " (dec (count form))) 444 | (merge {:form form} 445 | (u/-source-info form env))))) 446 | (let [const (analyze-const expr env)] 447 | {:op :quote 448 | :expr const 449 | :form form 450 | :env env 451 | :literal? true 452 | :children [:expr]})) 453 | 454 | (defn parse-set! 455 | [[_ target val :as form] env] 456 | (when-not (= 3 (count form)) 457 | (throw (ex-info (str "Wrong number of args to set!, had: " (dec (count form))) 458 | (merge {:form form} 459 | (u/-source-info form env))))) 460 | (let [target (unanalyzed target (u/ctx env :ctx/expr)) 461 | val (unanalyzed val (u/ctx env :ctx/expr))] 462 | {:op :set! 463 | :env env 464 | :form form 465 | :target target 466 | :val val 467 | :children [:target :val]})) 468 | 469 | (defn analyze-body [body env] 470 | ;; :body is used by emit-form to remove the artificial 'do 471 | (assoc (parse (cons 'do body) env) :body? true)) 472 | 473 | (defn valid-binding-symbol? [s] 474 | (and (symbol? s) 475 | (not (namespace s)) 476 | (not (re-find #"\." (name s))))) 477 | 478 | (defn ^:private split-with' [pred coll] 479 | (loop [take [] drop coll] 480 | (if (seq drop) 481 | (let [[el & r] drop] 482 | (if (pred el) 483 | (recur (conj take el) r) 484 | [(seq take) drop])) 485 | [(seq take) ()]))) 486 | 487 | (declare parse-catch) 488 | (defn parse-try 489 | [[_ & body :as form] env] 490 | (let [catch? (every-pred seq? #(= (first %) 'catch)) 491 | finally? (every-pred seq? #(= (first %) 'finally)) 492 | [body tail'] (split-with' (complement (some-fn catch? finally?)) body) 493 | [cblocks tail] (split-with' catch? tail') 494 | [[fblock & fbs :as fblocks] tail] (split-with' finally? tail)] 495 | (when-not (empty? tail) 496 | (throw (ex-info "Only catch or finally clause can follow catch in try expression" 497 | (merge {:expr tail 498 | :form form} 499 | (u/-source-info form env))))) 500 | (when-not (empty? fbs) 501 | (throw (ex-info "Only one finally clause allowed in try expression" 502 | (merge {:expr fblocks 503 | :form form} 504 | (u/-source-info form env))))) 505 | (let [env' (assoc env :in-try true) 506 | body (analyze-body body env') 507 | cenv (u/ctx env' :ctx/expr) 508 | cblocks (mapv #(parse-catch % cenv) cblocks) 509 | fblock (when-not (empty? fblock) 510 | (analyze-body (rest fblock) (u/ctx env :ctx/statement)))] 511 | (merge {:op :try 512 | :env env 513 | :form form 514 | :body body 515 | :catches cblocks} 516 | (when fblock 517 | {:finally fblock}) 518 | {:children (into [:body :catches] 519 | (when fblock [:finally]))})))) 520 | 521 | (defn parse-catch 522 | [[_ etype ename & body :as form] env] 523 | (when-not (valid-binding-symbol? ename) 524 | (throw (ex-info (str "Bad binding form: " ename) 525 | (merge {:sym ename 526 | :form form} 527 | (u/-source-info form env))))) 528 | (let [env (dissoc env :in-try) 529 | local {:op :binding 530 | :env env 531 | :form ename 532 | :name ename 533 | :local :catch}] 534 | {:op :catch 535 | :class (unanalyzed etype (assoc env :locals {})) 536 | :local local 537 | :env env 538 | :form form 539 | :body (analyze-body body (assoc-in env [:locals ename] (u/dissoc-env local))) 540 | :children [:class :local :body]})) 541 | 542 | (defn parse-throw 543 | [[_ throw :as form] env] 544 | (when-not (= 2 (count form)) 545 | (throw (ex-info (str "Wrong number of args to throw, had: " (dec (count form))) 546 | (merge {:form form} 547 | (u/-source-info form env))))) 548 | {:op :throw 549 | :env env 550 | :form form 551 | :exception (unanalyzed throw (u/ctx env :ctx/expr)) 552 | :children [:exception]}) 553 | 554 | (defn validate-bindings 555 | [[op bindings & _ :as form] env] 556 | (when-let [error-msg 557 | (cond 558 | (not (vector? bindings)) 559 | (str op " requires a vector for its bindings, had: " 560 | (class bindings)) 561 | 562 | (not (even? (count bindings))) 563 | (str op " requires an even number of forms in binding vector, had: " 564 | (count bindings)))] 565 | (throw (ex-info error-msg 566 | (merge {:form form 567 | :bindings bindings} 568 | (u/-source-info form env)))))) 569 | 570 | (defn parse-letfn* 571 | [[_ bindings & body :as form] env] 572 | (validate-bindings form env) 573 | (let [bindings (apply array-map bindings) ;; pick only one local with the same name, if more are present. 574 | fns (keys bindings)] 575 | (when-let [[sym] (seq (remove valid-binding-symbol? fns))] 576 | (throw (ex-info (str "Bad binding form: " sym) 577 | (merge {:form form 578 | :sym sym} 579 | (u/-source-info form env))))) 580 | (let [binds (reduce (fn [binds name] 581 | (assoc binds name 582 | {:op :binding 583 | :env env 584 | :name name 585 | :form name 586 | :local :letfn})) 587 | {} fns) 588 | e (update-in env [:locals] merge binds) ;; pre-seed locals 589 | binds (reduce-kv (fn [binds name bind] 590 | (assoc binds name 591 | (merge bind 592 | {:init (unanalyzed (bindings name) 593 | (u/ctx e :ctx/expr)) 594 | :children [:init]}))) 595 | {} binds) 596 | e (update-in env [:locals] merge (u/update-vals binds u/dissoc-env)) 597 | body (analyze-body body e)] 598 | {:op :letfn 599 | :env env 600 | :form form 601 | :bindings (vec (vals binds)) ;; order is irrelevant 602 | :body body 603 | :children [:bindings :body]}))) 604 | 605 | (defn analyze-let 606 | [[op bindings & body :as form] {:keys [context loop-id] :as env}] 607 | (validate-bindings form env) 608 | (let [loop? (= 'loop* op)] 609 | (loop [bindings bindings 610 | env (u/ctx env :ctx/expr) 611 | binds []] 612 | (if-let [[name init & bindings] (seq bindings)] 613 | (if (not (valid-binding-symbol? name)) 614 | (throw (ex-info (str "Bad binding form: " name) 615 | (merge {:form form 616 | :sym name} 617 | (u/-source-info form env)))) 618 | (let [init-expr (unanalyzed init env) 619 | bind-expr {:op :binding 620 | :env env 621 | :name name 622 | :init init-expr 623 | :form name 624 | :local (if loop? :loop :let) 625 | :children [:init]}] 626 | (recur bindings 627 | (assoc-in env [:locals name] (u/dissoc-env bind-expr)) 628 | (conj binds bind-expr)))) 629 | (let [body-env (assoc env :context (if loop? :ctx/return context)) 630 | body (analyze-body body (merge body-env 631 | (when loop? 632 | {:loop-id loop-id 633 | :loop-locals (count binds)})))] 634 | {:body body 635 | :bindings binds 636 | :children [:bindings :body]}))))) 637 | 638 | (defn parse-let* 639 | [form env] 640 | (into {:op :let 641 | :form form 642 | :env env} 643 | (analyze-let form env))) 644 | 645 | (defn parse-loop* 646 | [form env] 647 | (let [loop-id (gensym "loop_") ;; can be used to find matching recur 648 | env (assoc env :loop-id loop-id)] 649 | (into {:op :loop 650 | :form form 651 | :env env 652 | :loop-id loop-id} 653 | (analyze-let form env)))) 654 | 655 | (defn parse-recur 656 | [[_ & exprs :as form] {:keys [context loop-locals loop-id] 657 | :as env}] 658 | (when-let [error-msg 659 | (cond 660 | (not (isa? context :ctx/return)) 661 | "Can only recur from tail position" 662 | 663 | (not (= (count exprs) loop-locals)) 664 | (str "Mismatched argument count to recur, expected: " loop-locals 665 | " args, had: " (count exprs)))] 666 | (throw (ex-info error-msg 667 | (merge {:exprs exprs 668 | :form form} 669 | (u/-source-info form env))))) 670 | 671 | (let [exprs (mapv (unanalyzed-in-env (u/ctx env :ctx/expr)) exprs)] 672 | {:op :recur 673 | :env env 674 | :form form 675 | :exprs exprs 676 | :loop-id loop-id 677 | :children [:exprs]})) 678 | 679 | (defn analyze-fn-method [[params & body :as form] {:keys [locals local] :as env}] 680 | (when-not (vector? params) 681 | (throw (ex-info "Parameter declaration should be a vector" 682 | (merge {:params params 683 | :form form} 684 | (u/-source-info form env) 685 | (u/-source-info params env))))) 686 | (when (not-every? valid-binding-symbol? params) 687 | (throw (ex-info (str "Params must be valid binding symbols, had: " 688 | (mapv class params)) 689 | (merge {:params params 690 | :form form} 691 | (u/-source-info form env) 692 | (u/-source-info params env))))) ;; more specific 693 | (let [variadic? (boolean (some '#{&} params)) 694 | params-names (if variadic? (conj (pop (pop params)) (peek params)) params) 695 | env (dissoc env :local) 696 | arity (count params-names) 697 | params-expr (mapv (fn [name id] 698 | {:env env 699 | :form name 700 | :name name 701 | :variadic? (and variadic? 702 | (= id (dec arity))) 703 | :op :binding 704 | :arg-id id 705 | :local :arg}) 706 | params-names (range)) 707 | fixed-arity (if variadic? 708 | (dec arity) 709 | arity) 710 | loop-id (gensym "loop_") 711 | body-env (into (update-in env [:locals] 712 | merge (zipmap params-names (map u/dissoc-env params-expr))) 713 | {:context :ctx/return 714 | :loop-id loop-id 715 | :loop-locals (count params-expr)}) 716 | body (analyze-body body body-env)] 717 | (when variadic? 718 | (let [x (drop-while #(not= % '&) params)] 719 | (when (contains? #{nil '&} (second x)) 720 | (throw (ex-info "Invalid parameter list" 721 | (merge {:params params 722 | :form form} 723 | (u/-source-info form env) 724 | (u/-source-info params env))))) 725 | (when (not= 2 (count x)) 726 | (throw (ex-info (str "Unexpected parameter: " (first (drop 2 x)) 727 | " after variadic parameter: " (second x)) 728 | (merge {:params params 729 | :form form} 730 | (u/-source-info form env) 731 | (u/-source-info params env))))))) 732 | (merge 733 | {:op :fn-method 734 | :form form 735 | :loop-id loop-id 736 | :env env 737 | :variadic? variadic? 738 | :params params-expr 739 | :fixed-arity fixed-arity 740 | :body body 741 | :children [:params :body]} 742 | (when local 743 | {:local (u/dissoc-env local)})))) 744 | 745 | (defn parse-fn* 746 | [[op & args :as form] env] 747 | (wrapping-meta 748 | (let [[n meths] (if (symbol? (first args)) 749 | [(first args) (next args)] 750 | [nil (seq args)]) 751 | name-expr {:op :binding 752 | :env env 753 | :form n 754 | :local :fn 755 | :name n} 756 | e (if n (assoc (assoc-in env [:locals n] (u/dissoc-env name-expr)) :local name-expr) env) 757 | once? (-> op meta :once boolean) 758 | menv (assoc (dissoc e :in-try) :once once?) 759 | meths (if (vector? (first meths)) (list meths) meths) ;;turn (fn [] ...) into (fn ([]...)) 760 | methods-exprs (mapv #(analyze-fn-method % menv) meths) 761 | variadic (seq (filter :variadic? methods-exprs)) 762 | variadic? (boolean variadic) 763 | fixed-arities (seq (map :fixed-arity (remove :variadic? methods-exprs))) 764 | max-fixed-arity (when fixed-arities (apply max fixed-arities))] 765 | (when (>= (count variadic) 2) 766 | (throw (ex-info "Can't have more than 1 variadic overload" 767 | (merge {:variadics (mapv :form variadic) 768 | :form form} 769 | (u/-source-info form env))))) 770 | (when (not= (seq (distinct fixed-arities)) fixed-arities) 771 | (throw (ex-info "Can't have 2 or more overloads with the same arity" 772 | (merge {:form form} 773 | (u/-source-info form env))))) 774 | (when (and variadic? 775 | (not-every? #(<= (:fixed-arity %) 776 | (:fixed-arity (first variadic))) 777 | (remove :variadic? methods-exprs))) 778 | (throw (ex-info "Can't have fixed arity overload with more params than variadic overload" 779 | (merge {:form form} 780 | (u/-source-info form env))))) 781 | (merge {:op :fn 782 | :env env 783 | :form form 784 | :variadic? variadic? 785 | :max-fixed-arity max-fixed-arity 786 | :methods methods-exprs 787 | :once once?} 788 | (when n 789 | {:local name-expr}) 790 | {:children (conj (if n [:local] []) :methods)})))) 791 | 792 | (defn parse-def 793 | [[_ sym & expr :as form] {:keys [ns] :as env}] 794 | (when (not (symbol? sym)) 795 | (throw (ex-info (str "First argument to def must be a symbol, had: " (class sym)) 796 | (merge {:form form} 797 | (u/-source-info form env))))) 798 | (when (and (namespace sym) 799 | (not= *ns* (the-ns (symbol (namespace sym))))) 800 | (throw (ex-info "Cannot def namespace qualified symbol" 801 | (merge {:form form 802 | :sym sym} 803 | (u/-source-info form env))))) 804 | (let [pfn (fn 805 | ([]) 806 | ([init] 807 | {:init init}) 808 | ([doc init] 809 | {:pre [(string? doc)]} 810 | {:init init :doc doc})) 811 | args (apply pfn expr) 812 | 813 | doc (or (:doc args) (-> sym meta :doc)) 814 | arglists (when-let [arglists (:arglists (meta sym))] 815 | (second arglists)) ;; drop quote 816 | 817 | sym (with-meta (symbol (name sym)) 818 | (merge (meta sym) 819 | (when arglists 820 | {:arglists arglists}) 821 | (when doc 822 | {:doc doc}) 823 | (u/-source-info form env))) 824 | 825 | var (create-var sym env) ;; interned var will have quoted arglists, replaced on evaluation 826 | 827 | meta (merge (meta sym) 828 | (when arglists 829 | {:arglists (list 'quote arglists)})) 830 | 831 | meta-expr (when meta (unanalyzed meta (u/ctx env :ctx/expr))) ;; meta on def sym will be evaluated 832 | 833 | args (when-let [[_ init] (find args :init)] 834 | (assoc args :init (unanalyzed init (u/ctx env :ctx/expr)))) 835 | init? (:init args) 836 | children (into (into [] (when meta [:meta])) 837 | (when init? [:init]))] 838 | 839 | (merge {:op :def 840 | :env env 841 | :form form 842 | :name sym 843 | :var var} 844 | (when meta 845 | {:meta meta-expr}) 846 | args 847 | (when-not (empty? children) 848 | {:children children})))) 849 | 850 | (defn parse-dot 851 | [[_ target & [m-or-f & args] :as form] env] 852 | (when-not (>= (count form) 3) 853 | (throw (ex-info (str "Wrong number of args to ., had: " (dec (count form))) 854 | (merge {:form form} 855 | (u/-source-info form env))))) 856 | (let [[m-or-f field?] (if (and (symbol? m-or-f) 857 | (= \- (first (name m-or-f)))) 858 | [(-> m-or-f name (subs 1) symbol) true] 859 | [(if args (cons m-or-f args) m-or-f) false]) 860 | target-expr (unanalyzed target (u/ctx env :ctx/expr)) 861 | call? (and (not field?) (seq? m-or-f))] 862 | 863 | (when (and call? (not (symbol? (first m-or-f)))) 864 | (throw (ex-info (str "Method name must be a symbol, had: " (class (first m-or-f))) 865 | (merge {:form form 866 | :method m-or-f} 867 | (u/-source-info form env))))) 868 | (merge {:form form 869 | :env env 870 | :target target-expr} 871 | (cond 872 | call? 873 | {:op :host-call 874 | :method (symbol (name (first m-or-f))) 875 | :args (mapv (unanalyzed-in-env (u/ctx env :ctx/expr)) (next m-or-f)) 876 | :children [:target :args]} 877 | 878 | field? 879 | {:op :host-field 880 | :assignable? true 881 | :field (symbol (name m-or-f)) 882 | :children [:target]} 883 | 884 | :else 885 | {:op :host-interop ;; either field access or no-args method call 886 | :assignable? true 887 | :m-or-f (symbol (name m-or-f)) 888 | :children [:target]})))) 889 | 890 | (defn parse-invoke 891 | [[f & args :as form] env] 892 | (let [fenv (u/ctx env :ctx/expr) 893 | fn-expr (unanalyzed f fenv) 894 | args-expr (mapv (unanalyzed-in-env fenv) args) 895 | m (meta form)] 896 | (merge {:op :invoke 897 | :form form 898 | :env env 899 | :fn fn-expr 900 | :args args-expr} 901 | (when (seq m) 902 | {:meta m}) ;; meta on invoke form will not be evaluated 903 | {:children [:fn :args]}))) 904 | 905 | (defn parse-var 906 | [[_ var :as form] env] 907 | (when-not (= 2 (count form)) 908 | (throw (ex-info (str "Wrong number of args to var, had: " (dec (count form))) 909 | (merge {:form form} 910 | (u/-source-info form env))))) 911 | (if-let [var (resolve-sym var env)] 912 | {:op :the-var 913 | :env env 914 | :form form 915 | :var var} 916 | (throw (ex-info (str "var not found: " var) {:var var})))) 917 | 918 | (defn -parse 919 | "Takes a form and an env map and dispatches on the head of the form, that is 920 | a special form." 921 | [form env] 922 | ((case (first form) 923 | do parse-do 924 | if parse-if 925 | new parse-new 926 | quote parse-quote 927 | set! parse-set! 928 | try parse-try 929 | throw parse-throw 930 | def parse-def 931 | . parse-dot 932 | let* parse-let* 933 | letfn* parse-letfn* 934 | loop* parse-loop* 935 | recur parse-recur 936 | fn* parse-fn* 937 | var parse-var 938 | #_:else parse-invoke) 939 | form env)) 940 | --------------------------------------------------------------------------------