├── spec ├── buildref.sh ├── gen-ref.clj ├── quickref.html.tpl └── ast-ref.edn ├── src ├── test │ └── clojure │ │ └── clojure │ │ └── tools │ │ └── analyzer │ │ └── js │ │ └── core_test.clj └── main │ └── clojure │ └── clojure │ └── tools │ └── analyzer │ ├── passes │ └── js │ │ ├── collect_keywords.clj │ │ ├── analyze_host_expr.clj │ │ ├── annotate_tag.clj │ │ ├── validate.clj │ │ ├── emit_form.clj │ │ └── infer_tag.clj │ ├── js │ ├── utils.clj │ └── cljs │ │ └── core.clj │ └── js.clj ├── project.clj ├── CONTRIBUTING.md ├── CHANGELOG.md ├── pom.xml ├── README.md └── LICENSE /spec/buildref.sh: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | 3 | java -cp .:`lein cp` clojure.main <env 9 | * Preserve metadata on 'ns 10 | * Release 0.1.0-beta3 on 11 Aug 2014 11 | * Added :passes-opts to analyze 12 | * Add :js-var node instead of desugaring js interop symbol syntax into js* + field access 13 | * Release 0.1.0-beta2 on 10 Aug 2014 14 | * Fixed emit-form 15 | * Throw on :maybe-host-form 16 | * Type literals are :var with :type true 17 | * Imports are :js-var 18 | * Resolve clojure.core symbols in the cljs.core ns 19 | * Fixed case* assertion 20 | * Don't throw when the symbol has :analyzer/allow-undefined metadata 21 | * Release 0.1.0-beta1 on 09 Aug 2014 22 | * Ensure cljs.core and cljs.user are setup automatically loading the lib 23 | * Cache cljs env 24 | * Update to cljs 0.0-2307 25 | * Release 0.1.0-alpha2 on 07 Aug 2014 26 | * Update to cljs 0.0-2301 27 | * Add suppoort for foo.bar syntax for vars/locals 28 | * Release 0.1.0-alpha1 on 30 Jul 2014 29 | * First alpha release 30 | -------------------------------------------------------------------------------- /src/main/clojure/clojure/tools/analyzer/passes/js/collect_keywords.clj: -------------------------------------------------------------------------------- 1 | ;; Copyright (c) Nicola Mometto, Rich Hickey & contributors. 2 | ;; The use and distribution terms for this software are covered by the 3 | ;; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) 4 | ;; which can be found in the file epl-v10.html at the root of this distribution. 5 | ;; By using this software in any fashion, you are agreeing to be bound by 6 | ;; the terms of this license. 7 | ;; You must not remove this notice, or any other, from this software. 8 | 9 | (ns clojure.tools.analyzer.passes.js.collect-keywords 10 | (:require [clojure.tools.analyzer.env :as env] 11 | [clojure.tools.analyzer.passes.elide-meta :refer [elide-meta]])) 12 | 13 | (defn collect-keywords 14 | "Assoc compilation-unit shared id to each :const node with :type :keyword, 15 | The keyword to id map is available in the global env under ::keywords" 16 | {:pass-info {:walk :any :depends #{#'elide-meta}}} 17 | [ast] 18 | (if (and (= (:op ast) :const) 19 | (= (:type ast) :keyword)) 20 | (let [v (:val ast) 21 | id (or (get-in (env/deref-env) [::keywords v]) 22 | (let [c (count (::keywords (env/deref-env)))] 23 | (swap! env/*env* assoc-in [::keywords v] c) 24 | c))] 25 | (assoc ast :id id)) 26 | ast)) 27 | -------------------------------------------------------------------------------- /src/main/clojure/clojure/tools/analyzer/passes/js/analyze_host_expr.clj: -------------------------------------------------------------------------------- 1 | ;; Copyright (c) Nicola Mometto, Rich Hickey & contributors. 2 | ;; The use and distribution terms for this software are covered by the 3 | ;; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) 4 | ;; which can be found in the file epl-v10.html at the root of this distribution. 5 | ;; By using this software in any fashion, you are agreeing to be bound by 6 | ;; the terms of this license. 7 | ;; You must not remove this notice, or any other, from this software. 8 | 9 | (ns clojure.tools.analyzer.passes.js.analyze-host-expr 10 | (:require [clojure.tools.analyzer.env :as env] 11 | [clojure.tools.analyzer.utils :refer [resolve-ns resolve-sym]])) 12 | 13 | (defmulti analyze-host-expr 14 | "Transform :host-interop nodes into :host-call, transform 15 | :maybe-class or :maybe-host-form nodes resolvable to js vars 16 | into :js-var nodes" 17 | {:pass-info {:walk :any :depends #{}}} 18 | :op) 19 | 20 | (defmethod analyze-host-expr :default [ast] ast) 21 | 22 | (defmethod analyze-host-expr :host-interop 23 | [{:keys [m-or-f target] :as ast}] 24 | (merge (dissoc ast :m-or-f) 25 | {:op :host-call 26 | :method m-or-f 27 | :args [] 28 | :children [:target :args]})) 29 | 30 | (defmethod analyze-host-expr :maybe-class 31 | [{:keys [class env] :as ast}] 32 | (if-let [v (resolve-sym class env)] 33 | (merge (dissoc ast :class) 34 | {:op :js-var 35 | :var v 36 | :assignable? true}) 37 | ast)) 38 | 39 | (defmethod analyze-host-expr :maybe-host-form 40 | [{:keys [class field env form] :as ast}] 41 | (cond 42 | (= 'js class) 43 | (merge (dissoc ast :field :class) 44 | {:op :js-var 45 | :var {:op :js-var 46 | :name field 47 | :ns nil} 48 | :assignable? true}) 49 | 50 | (get-in (env/deref-env) [:namespaces (resolve-ns class env) :js-namespace]) 51 | (let [field (or (:name (resolve-sym form env)) field)] 52 | (merge (dissoc ast :field :class) 53 | {:op :js-var 54 | :var {:op :js-var 55 | :name field 56 | :ns (resolve-ns class env)} 57 | :assignable? true})) 58 | :else 59 | ast)) 60 | -------------------------------------------------------------------------------- /spec/gen-ref.clj: -------------------------------------------------------------------------------- 1 | (use 'clojure.string) 2 | 3 | (def tej-ref (read-string (slurp "ast-ref.edn"))) 4 | (def html (slurp "quickref.html.tpl")) 5 | 6 | (defn fix [x] 7 | (-> (str x) 8 | (replace #"`(.*?)`" "$1") 9 | (replace #":([a-zA-Z\?!\-]*)" ":$1"))) 10 | 11 | (defn build-children [children] 12 | (if (some #(:optional (meta %)) children) 13 | (let [[c & rest] children] 14 | (let [k (build-children rest) 15 | kc (mapv (fn [x] (cons c x)) k)] 16 | (if (:optional (meta c)) 17 | (into k kc) 18 | kc))) 19 | (if (seq children) 20 | [children] 21 | [[]]))) 22 | 23 | (defn children [keys] 24 | (when-let [children (seq (filter #(:children (meta %)) keys))] 25 | (mapv #(mapv first %) (build-children children)))) 26 | 27 | (def nodes 28 | (apply str (for [{:keys [op doc keys]} (:node-keys tej-ref) :let [op (name op)]] 29 | (str "
" 30 | "

" "#" op "

" 31 | "

" doc "

" 32 | "
" 33 | "
:op
:" op "
" 34 | (apply str (for [[k d :as f] keys] 35 | (str "
" k "
" 36 | "
" (if (:optional (meta f)) 37 | "optional ") (fix d) "
"))) 38 | (if-let [c (children keys)] 39 | (str "
:children
" 40 | (join ", " (mapv (fn [c] (str "" c "")) c)) "
")) 41 | "
" 42 | "
\n")))) 43 | 44 | (def nav 45 | (apply str (for [{op :op} (:node-keys tej-ref) :let [op (name op)]] 46 | (str "
  • " op "
    • \n")))) 47 | 48 | (def common 49 | (apply str (str "
    " 50 | "
    " 51 | (apply str (for [[k d :as f] (:all-keys tej-ref)] 52 | (str "
    " k "
    " 53 | "
    " (if (:optional (meta f)) 54 | "optional ") (fix d) "
    "))) 55 | "
    " 56 | "
    \n"))) 57 | 58 | (spit "quickref.html" 59 | (-> html 60 | (replace "{nav}" nav) 61 | (replace "{common}" common) 62 | (replace "{nodes}" nodes))) 63 | -------------------------------------------------------------------------------- /src/main/clojure/clojure/tools/analyzer/passes/js/annotate_tag.clj: -------------------------------------------------------------------------------- 1 | ;; Copyright (c) Nicola Mometto, Rich Hickey & contributors. 2 | ;; The use and distribution terms for this software are covered by the 3 | ;; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) 4 | ;; which can be found in the file epl-v10.html at the root of this distribution. 5 | ;; By using this software in any fashion, you are agreeing to be bound by 6 | ;; the terms of this license. 7 | ;; You must not remove this notice, or any other, from this software. 8 | 9 | (ns clojure.tools.analyzer.passes.js.annotate-tag) 10 | 11 | (defmulti -annotate-tag :op) 12 | 13 | (defmethod -annotate-tag :seq 14 | [ast] 15 | (assoc ast :tag 'cljs.core/IList)) 16 | 17 | (defmethod -annotate-tag :vector 18 | [ast] 19 | (assoc ast :tag 'cljs.core/IVector)) 20 | 21 | (defmethod -annotate-tag :map 22 | [ast] 23 | (assoc ast :tag 'cljs.core/IMap)) 24 | 25 | (defmethod -annotate-tag :set 26 | [ast] 27 | (assoc ast :tag 'cljs.core/ISet)) 28 | 29 | (defmethod -annotate-tag :js-array 30 | [ast] 31 | (assoc ast :tag 'array)) 32 | 33 | (defmethod -annotate-tag :js-object 34 | [ast] 35 | (assoc ast :tag 'object)) 36 | 37 | (defmethod -annotate-tag :js 38 | [{:keys [form] :as ast}] 39 | (if (-> form meta :numeric) 40 | (assoc ast :tag 'number) 41 | ast)) 42 | 43 | (defmethod -annotate-tag :fn 44 | [ast] 45 | (assoc ast :tag 'function)) 46 | 47 | (defmethod -annotate-tag :const 48 | [ast] 49 | (let [ast ((get-method -annotate-tag (:type ast)) ast)] 50 | (if (:tag ast) 51 | ast 52 | (assoc ast :tag 'any)))) 53 | 54 | (defmethod -annotate-tag :nil 55 | [ast] 56 | (assoc ast :tag 'clj-nil)) 57 | 58 | (defmethod -annotate-tag :number 59 | [ast] 60 | (assoc ast :tag 'number)) 61 | 62 | (defmethod -annotate-tag :string 63 | [ast] 64 | (assoc ast :tag 'string)) 65 | 66 | (defmethod -annotate-tag :bool 67 | [ast] 68 | (assoc ast :tag 'boolean)) 69 | 70 | (defmethod -annotate-tag :symbol 71 | [ast] 72 | (assoc ast :tag 'cljs.core/Symbol)) 73 | 74 | (defmethod -annotate-tag :keyword 75 | [ast] 76 | (assoc ast :tag 'cljs.core/Keyword)) 77 | 78 | (defmethod -annotate-tag :default [ast] ast) 79 | 80 | (defn annotate-tag 81 | "If the AST node type is a constant object or contains :tag metadata, 82 | attach the appropriate :tag to the node." 83 | {:pass-info {:walk :any :depends #{}}} 84 | [ast] 85 | (if-let [tag (or (-> ast :form meta :tag) 86 | (-> ast :val meta :tag))] 87 | (assoc ast :tag tag) 88 | (-annotate-tag ast))) 89 | -------------------------------------------------------------------------------- /spec/quickref.html.tpl: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | tools.analyzer.js AST Quickref 6 | 94 | 95 | 96 | 102 |
    103 |

    tools.analyzer.js AST Quickref

    104 |

    Common AST fields

    105 | {common} 106 |

    Nodes reference

    107 | {nodes} 108 |
    109 | 110 | 111 | -------------------------------------------------------------------------------- /src/main/clojure/clojure/tools/analyzer/passes/js/validate.clj: -------------------------------------------------------------------------------- 1 | ;; Copyright (c) Nicola Mometto, Rich Hickey & contributors. 2 | ;; The use and distribution terms for this software are covered by the 3 | ;; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) 4 | ;; which can be found in the file epl-v10.html at the root of this distribution. 5 | ;; By using this software in any fashion, you are agreeing to be bound by 6 | ;; the terms of this license. 7 | ;; You must not remove this notice, or any other, from this software. 8 | 9 | (ns clojure.tools.analyzer.passes.js.validate 10 | (:require [clojure.tools.analyzer.ast :refer [prewalk]] 11 | [clojure.tools.analyzer.passes.cleanup :refer [cleanup]] 12 | [clojure.tools.analyzer.passes.js.infer-tag :refer [infer-tag]] 13 | [clojure.tools.analyzer.utils :refer [source-info resolve-sym resolve-ns]])) 14 | 15 | (defmulti -validate :op) 16 | (defmethod -validate :default [ast] ast) 17 | 18 | (defmethod -validate :maybe-class [{:keys [class form env] :as ast}] 19 | (when-not (:analyzer/allow-undefined (meta form)) 20 | (throw (ex-info (str "Cannot resolve: " class) 21 | (merge {:sym class 22 | :ast (prewalk ast cleanup)} 23 | (source-info env))))) ) 24 | 25 | (defmethod -validate :maybe-host-form [{:keys [form env] :as ast}] 26 | (when-not (:analyzer/allow-undefined (meta form)) 27 | (throw (ex-info (str "Cannot resolve: " form) 28 | (merge {:sym form 29 | :ast (prewalk ast cleanup)} 30 | (source-info env))))) ) 31 | 32 | (defn validate-tag [t {:keys [env] :as ast}] 33 | (let [tag (ast t)] 34 | (if (symbol? tag) 35 | (if-let [var (resolve-sym tag env)] 36 | (symbol (str (:ns var)) (str (:name var))) 37 | #_(if (or (= :type (:op var)) 38 | (:protocol (meta var))) 39 | (symbol (str (:ns var)) (str (:name var))) 40 | (throw (ex-info (str "Not type/protocol var used as a tag: " tag) 41 | (merge {:var var 42 | :ast (prewalk ast cleanup)} 43 | (source-info env))))) 44 | tag 45 | #_(if (or ('#{boolean string number clj-nil any function object array} tag) 46 | (and (namespace tag) 47 | (not (resolve-ns (symbol (namespace tag)) env)))) 48 | tag 49 | (throw (ex-info (str "Cannot resolve: " tag) 50 | (merge {:sym tag 51 | :ast (prewalk ast cleanup)} 52 | (source-info env)))))) 53 | (throw (ex-info (str "Invalid tag: " tag) 54 | (merge {:tag tag 55 | :ast (prewalk ast cleanup)} 56 | (source-info env))))))) 57 | 58 | (defn validate 59 | "Validate tags and symbols. 60 | Throws exceptions when invalid forms are encountered" 61 | {:pass-info {:walk :any :depends #{#'infer-tag}}} 62 | [ast] 63 | (merge (-validate ast) 64 | (when (:tag ast) 65 | {:tag (validate-tag :tag ast)}) 66 | (when (:return-tag ast) 67 | {:return-tag (validate-tag :return-tag ast)}))) 68 | -------------------------------------------------------------------------------- /pom.xml: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4.0.0 4 | tools.analyzer.js 5 | 0.1.0-SNAPSHOT 6 | tools.analyzer.js 7 | Provides js-specific passes for tools.analyzer 8 | 9 | 10 | org.clojure 11 | pom.contrib 12 | 0.2.0 13 | 14 | 15 | 16 | 1.6.0 17 | 18 | 19 | 20 | 21 | 22 | com.theoryinpractise 23 | clojure-maven-plugin 24 | 1.7.1 25 | 26 | false 27 | 28 | 29 | 30 | clojure-compile 31 | compile 32 | 33 | compile 34 | 35 | 36 | true 37 | 38 | !.* 39 | 40 | 41 | 42 | 43 | 44 | 45 | org.codehaus.mojo 46 | build-helper-maven-plugin 47 | 1.12 48 | 49 | 50 | add-clojure-source-dirs 51 | generate-sources 52 | 53 | add-resource 54 | 55 | 56 | 57 | 58 | resources/ 59 | 60 | 61 | 62 | 63 | 64 | 65 | 66 | 67 | 68 | 69 | bronsa 70 | Nicola Mometto 71 | 72 | 73 | 74 | 75 | 76 | org.clojure 77 | tools.analyzer 78 | 0.6.5-SNAPSHOT 79 | 80 | 81 | org.clojure 82 | tools.reader 83 | 0.8.13 84 | 85 | 86 | org.clojure 87 | clojurescript 88 | 0.0-2411 89 | 90 | 91 | 92 | 93 | scm:git:git://github.com/clojure/tools.analyzer.js.git 94 | scm:git:git://github.com/clojure/tools.analyzer.js.git 95 | http://github.com/clojure/tools.analyzer.js 96 | HEAD 97 | 98 | 99 | -------------------------------------------------------------------------------- /src/main/clojure/clojure/tools/analyzer/passes/js/emit_form.clj: -------------------------------------------------------------------------------- 1 | ;; Copyright (c) Nicola Mometto, Rich Hickey & contributors. 2 | ;; The use and distribution terms for this software are covered by the 3 | ;; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) 4 | ;; which can be found in the file epl-v10.html at the root of this distribution. 5 | ;; By using this software in any fashion, you are agreeing to be bound by 6 | ;; the terms of this license. 7 | ;; You must not remove this notice, or any other, from this software. 8 | 9 | (ns clojure.tools.analyzer.passes.js.emit-form 10 | (:require [clojure.tools.analyzer.passes 11 | [emit-form :as default] 12 | [uniquify :refer [uniquify-locals]]] 13 | [clojure.string :as s] 14 | [cljs.tagged-literals :refer [->JSValue]]) 15 | (:import cljs.tagged_literals.JSValue 16 | java.io.Writer)) 17 | 18 | (defmulti -emit-form (fn [{:keys [op]} _] op)) 19 | 20 | (defn -emit-form* 21 | [{:keys [form] :as ast} opts] 22 | (let [expr (-emit-form ast opts)] 23 | (if-let [m (and (instance? clojure.lang.IObj expr) 24 | (meta form))] 25 | (with-meta expr (merge m (meta expr))) 26 | expr))) 27 | 28 | (defn emit-form 29 | "Return the form represented by the given AST 30 | Opts is a set of options, valid options are: 31 | * :hygienic 32 | * :qualified-symbols" 33 | {:pass-info {:walk :none :depends #{#'uniquify-locals} :compiler true}} 34 | ([ast] (emit-form ast #{})) 35 | ([ast opts] 36 | (binding [default/-emit-form* -emit-form*] 37 | (-emit-form* ast opts)))) 38 | 39 | (defn emit-hygienic-form 40 | "Return an hygienic form represented by the given AST" 41 | {:pass-info {:walk :none :depends #{#'uniquify-locals} :compiler true}} 42 | [ast] 43 | (binding [default/-emit-form* -emit-form*] 44 | (-emit-form* ast #{:hygienic}))) 45 | 46 | (defmethod -emit-form :default 47 | [ast opts] 48 | (default/-emit-form ast opts)) 49 | 50 | (defmethod -emit-form :js 51 | [{:keys [segs args]} opts] 52 | (list* 'js* (s/join "~{}" segs) (mapv #(-emit-form* % opts) args))) 53 | 54 | (defmethod -emit-form :js-object 55 | [{:keys [keys vals]} opts] 56 | (->JSValue (zipmap (map #(-emit-form* % opts) keys) 57 | (map #(-emit-form* % opts) vals)))) 58 | 59 | (defmethod -emit-form :js-array 60 | [{:keys [items]} opts] 61 | (->JSValue (mapv #(-emit-form* % opts) items))) 62 | 63 | (defmethod print-method JSValue [^JSValue o ^Writer w] 64 | (.write w "#js ") 65 | (.write w (str (.val o)))) 66 | 67 | (defmethod -emit-form :deftype 68 | [{:keys [name fields pmask body]} opts] 69 | (list 'deftype* name (map #(-emit-form* % opts) fields) pmask 70 | (-emit-form* body opts))) 71 | 72 | (defmethod -emit-form :defrecord 73 | [{:keys [name fields pmask body]} opts] 74 | (list 'defrecord* name (map #(-emit-form* % opts) fields) pmask 75 | (-emit-form* body opts))) 76 | 77 | (defmethod -emit-form :case-then 78 | [{:keys [then]} opts] 79 | (-emit-form* then opts)) 80 | 81 | (defmethod -emit-form :case-test 82 | [{:keys [test]} opts] 83 | (-emit-form* test opts)) 84 | 85 | (defmethod -emit-form :case 86 | [{:keys [test nodes default]} opts] 87 | `(case* ~(-emit-form* test opts) 88 | ~@(reduce (fn [acc {:keys [tests then]}] 89 | (-> acc 90 | (update-in [0] conj (mapv #(-emit-form* % opts) tests)) 91 | (update-in [1] conj (-emit-form* then opts)))) 92 | [[] []] nodes) 93 | ~(-emit-form* default opts))) 94 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # tools.analyzer.js 2 | 3 | Provides js-specific passes for tools.analyzer 4 | 5 | # THIS PROJECT HAS BEEN ABANDONED, USE `cljs.analyzer` INSTEAD 6 | 7 | As of clojurescript 1.10.x, `cljs.analyzer` produces an AST in the same format as `tools.analyzer`. 8 | 9 | **The last version of `tools.analyzer.js` works with a very ancient version of `clojurescript`. 10 | This project should be considered abandoned and not be used as the official maintainer doesn't have time to update and maintain it.** 11 | 12 | --- 13 | 14 | * [Example Usage](#example-usage) 15 | * [AST Quickref](#ast-quickref) 16 | * [Releases and Dependency Information](#releases-and-dependency-information) 17 | * [Changelog](#changelog) 18 | * [API Index](#api-index) 19 | * [Developer Information](#developer-information) 20 | * [License](#license) 21 | 22 | ## Example Usage 23 | 24 | ```clojure 25 | user> (require '[clojure.tools.analyzer.js :as a] 26 | '[clojure.tools.analyzer.env :as env) 27 | nil 28 | user> (def env (a/global-env)) 29 | #'user/env 30 | user> (env/with-env env (a/analyze 1)) 31 | {:op :const, 32 | :top-level true, 33 | :tag number, 34 | :env {:context :ctx/statement, :locals {}, :ns cljs.user}, 35 | :type :number, 36 | :literal? true, 37 | :val 1, 38 | :form 1} 39 | user> (env/with-env env (a/analyze-ns 'cljs.core)) 40 | [{:op :ns ..} 41 | {:op :def ..} 42 | ..] 43 | ``` 44 | 45 | If `clojure.tools.analyzer.js` is used inside a cljs macro being expanded by `cljs.analyzer`, you can use `cljs-env->env` to populate tools.analyzer.js' global env from clojure.analyzer's one: 46 | ```clojure 47 | clojure.tools.analyzer.js> (env/ensure (env/with-env (merge (env/deref-env) 48 | {:namespaces (cljs-env->env)})) 49 | ..) 50 | ``` 51 | 52 | [AST Quickref](http://clojure.github.io/tools.analyzer.js/spec/quickref.html) 53 | ======================================== 54 | 55 | Releases and Dependency Information 56 | ======================================== 57 | 58 | Latest stable release: 0.1.0-beta5 59 | 60 | * [All Released Versions](http://search.maven.org/#search%7Cgav%7C1%7Cg%3A%22org.clojure%22%20AND%20a%3A%22tools.analyzer.js%22) 61 | 62 | * [Development Snapshot Versions](https://oss.sonatype.org/index.html#nexus-search;gav%7Eorg.clojure%7Etools.analyzer.js%7E%7E%7E) 63 | 64 | [Leiningen](https://github.com/technomancy/leiningen) dependency information: 65 | 66 | ```clojure 67 | [org.clojure/tools.analyzer.js "0.1.0-beta5"] 68 | ``` 69 | [Maven](http://maven.apache.org/) dependency information: 70 | 71 | ```xml 72 | 73 | org.clojure 74 | tools.analyzer.js 75 | 0.1.0-beta5 76 | 77 | ``` 78 | 79 | [Changelog](CHANGELOG.md) 80 | ======================================== 81 | 82 | API Index 83 | ======================================== 84 | 85 | * [CrossClj Documentation](http://crossclj.info/doc/org.clojure/tools.analyzer.js/lastest/index.html) 86 | * [API index](http://clojure.github.io/tools.analyzer.js) 87 | 88 | Developer Information 89 | ======================================== 90 | 91 | * [GitHub project](https://github.com/clojure/tools.analyzer.js) 92 | 93 | * [Bug Tracker](http://dev.clojure.org/jira/browse/TANAL) 94 | 95 | * [Continuous Integration](http://build.clojure.org/job/tools.analyzer.js/) 96 | 97 | * [Compatibility Test Matrix](http://build.clojure.org/job/tools.analyzer.js-test-matrix/) 98 | 99 | ## License 100 | 101 | Copyright © 2014 Nicola Mometto, Rich Hickey & contributors. 102 | 103 | Distributed under the Eclipse Public License, the same as Clojure. 104 | -------------------------------------------------------------------------------- /src/main/clojure/clojure/tools/analyzer/js/utils.clj: -------------------------------------------------------------------------------- 1 | ;; Copyright (c) Nicola Mometto, Rich Hickey & contributors. 2 | ;; The use and distribution terms for this software are covered by the 3 | ;; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) 4 | ;; which can be found in the file epl-v10.html at the root of this distribution. 5 | ;; By using this software in any fashion, you are agreeing to be bound by 6 | ;; the terms of this license. 7 | ;; You must not remove this notice, or any other, from this software. 8 | 9 | (ns clojure.tools.analyzer.js.utils 10 | (:require [clojure.string :as s] 11 | [clojure.tools.analyzer.utils :refer [-source-info]] 12 | [clojure.java.io :as io]) 13 | (:import java.io.File 14 | java.net.URL)) 15 | 16 | (defn desugar-macros [{:keys [require] :as ns-opts}] 17 | (let [sugar-keys #{:include-macros :refer-macros}] 18 | (reduce-kv (fn [ns-opts ns opts] 19 | (if (seq (select-keys opts sugar-keys)) 20 | (-> ns-opts 21 | (update-in [:require] assoc ns (apply dissoc opts sugar-keys)) 22 | (update-in [:require-macros] assoc ns (select-keys opts #{:refer-macros :as}))) 23 | ns-opts)) 24 | ns-opts require))) 25 | 26 | ;;TODO: assumes the libspecs are valid, crashes otherwise 27 | ;; needs to validate them 28 | (defn desugar-use [{:keys [use use-macros] :as ns-opts}] 29 | (let [ns-opts (reduce (fn [ns-opts [lib only syms]] 30 | (update-in ns-opts [:require] assoc lib {:refer syms})) 31 | ns-opts use)] 32 | (reduce (fn [ns-opts [lib only syms]] 33 | (update-in ns-opts [:require-macros] assoc lib {:refer syms})) 34 | ns-opts use))) 35 | 36 | (defn desugar-import [imports] 37 | (reduce (fn [imports import] 38 | (if (symbol? import) 39 | (let [s (s/split (name import) #"\.")] 40 | (assoc imports (symbol (s/join "." (butlast s))) #{(symbol (last s))})) 41 | (assoc imports (first import) (set (rest import))))) 42 | {} imports)) 43 | 44 | (defn mapify-ns-specs [ns-opts form env] 45 | (reduce (fn [m [k & specs]] 46 | (when (get m k) 47 | (throw (ex-info (str "Only one " k " form is allowed per namespace definition") 48 | (merge {:form form} 49 | (-source-info form env))))) 50 | (case k 51 | :refer-clojure 52 | (assoc m k (apply hash-map specs)) 53 | :import 54 | (assoc m k (desugar-import specs)) 55 | 56 | (assoc m k (reduce (fn [m s] 57 | (if (sequential? s) 58 | (assoc m (first s) (apply hash-map (rest s))) 59 | (assoc m s {}))) {} specs)))) {} ns-opts)) 60 | 61 | ;; desugars :include-macros/:refer-mcros into :require/:require-macros 62 | ;; and :use/:use-macros into :require/:require-macros 63 | (defn desugar-ns-specs [ns-opts form env] 64 | (-> ns-opts 65 | (mapify-ns-specs form env) 66 | desugar-macros 67 | desugar-use)) 68 | 69 | ;; TODO: validate 70 | (defn validate-ns-specs [ns-opts form env] 71 | (when-let [invalid (seq (dissoc ns-opts :require :require-macros :import :refer-clojure))] 72 | (throw (ex-info (str "Unsupported ns spec(s): " invalid) 73 | (merge {:form form} 74 | (-source-info form env)))))) 75 | 76 | (defn source-path [x] 77 | (if (instance? File x) 78 | (.getAbsolutePath ^File x) 79 | (str x))) 80 | 81 | (defn ns->relpath [s] 82 | (str (s/replace (munge (str s)) \. \/) ".cljs")) 83 | 84 | (defn ns-resource [ns] 85 | (let [f (ns->relpath ns)] 86 | (cond 87 | (instance? File f) f 88 | (instance? URL f) f 89 | (re-find #"^file://" f) (URL. f) 90 | :else (io/resource f)))) 91 | 92 | (defn res-path [res] 93 | (if (instance? File res) 94 | (.getPath ^File res) 95 | (.getPath ^URL res))) 96 | -------------------------------------------------------------------------------- /src/main/clojure/clojure/tools/analyzer/passes/js/infer_tag.clj: -------------------------------------------------------------------------------- 1 | ;; Copyright (c) Nicola Mometto, Rich Hickey & contributors. 2 | ;; The use and distribution terms for this software are covered by the 3 | ;; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) 4 | ;; which can be found in the file epl-v10.html at the root of this distribution. 5 | ;; By using this software in any fashion, you are agreeing to be bound by 6 | ;; the terms of this license. 7 | ;; You must not remove this notice, or any other, from this software. 8 | 9 | (ns clojure.tools.analyzer.passes.js.infer-tag 10 | (:require [clojure.tools.analyzer.env :as env] 11 | [clojure.tools.analyzer.utils :refer [arglist-for-arity]] 12 | [clojure.tools.analyzer.passes.add-binding-atom :refer [add-binding-atom]] 13 | [clojure.tools.analyzer.passes.js 14 | [annotate-tag :refer [annotate-tag]] 15 | [analyze-host-expr :refer [analyze-host-expr]]])) 16 | 17 | (defmulti -infer-tag :op) 18 | (defmethod -infer-tag :default [ast] ast) 19 | 20 | (defmethod -infer-tag :recur 21 | [ast] 22 | (assoc ast :tag 'ignore :ignore-tag true)) 23 | 24 | (defmethod -infer-tag :throw 25 | [ast] 26 | (assoc ast :tag 'ignore :ignore-tag true)) 27 | 28 | (defmethod -infer-tag :with-meta 29 | [{:keys [expr] :as ast}] 30 | (merge ast (select-keys expr [:return-tag :arglists :ignore-tag :tag]))) 31 | 32 | (defmethod -infer-tag :do 33 | [{:keys [ret] :as ast}] 34 | (merge ast (select-keys ret [:return-tag :arglists :ignore-tag :tag]))) 35 | 36 | (defmethod -infer-tag :let 37 | [{:keys [body] :as ast}] 38 | (merge ast (select-keys body [:return-tag :arglists :ignore-tag :tag]))) 39 | 40 | (defmethod -infer-tag :letfn 41 | [{:keys [body] :as ast}] 42 | (merge ast (select-keys body [:return-tag :arglists :ignore-tag :tag]))) 43 | 44 | (defmethod -infer-tag :loop 45 | [{:keys [body] :as ast}] 46 | (merge ast (select-keys body [:return-tag :arglists :ignore-tag :tag]))) 47 | 48 | (defmethod -infer-tag :binding 49 | [{:keys [init atom] :as ast}] 50 | (let [ast (if init 51 | (merge (select-keys init [:return-tag :arglists :ignore-tag :tag]) ast) 52 | ast)] 53 | (swap! atom merge (select-keys ast [:return-tag :arglists :ignore-tag :tag])) 54 | ast)) 55 | 56 | (defmethod -infer-tag :local 57 | [{:keys [atom] :as ast}] 58 | (merge ast @atom)) 59 | 60 | (defmethod -infer-tag :def 61 | [{:keys [init var] :as ast}] 62 | (let [info (select-keys init [:return-tag :arglists :ignore-tag :tag])] 63 | (swap! env/*env* update-in [:namespaces (:ns var) :mappings (:name var)] merge info) 64 | (merge ast info))) 65 | 66 | (defmethod -infer-tag :var 67 | [{:keys [var] :as ast}] 68 | (let [info (-> (env/deref-env) 69 | (get-in [:namespaces (:ns var) :mappings (:name var)]) 70 | (select-keys [:return-tag :arglists :ignore-tag :tag]))] 71 | (merge ast info))) 72 | 73 | (defmethod -infer-tag :set! 74 | [{:keys [target] :as ast}] 75 | (if-let [tag (:tag target)] 76 | (assoc ast :tag tag) 77 | ast)) 78 | 79 | (defmethod -infer-tag :invoke 80 | [{:keys [fn args] :as ast}] 81 | (if (:arglists fn) 82 | (let [argc (count args) 83 | arglist (arglist-for-arity fn argc) 84 | tag (or (:tag (meta arglist)) 85 | (:return-tag fn) 86 | (and (= :var (:op fn)) 87 | (:tag (meta (:var fn)))))] 88 | (merge ast 89 | (when tag 90 | {:tag tag}))) 91 | (if-let [tag (:return-tag fn)] 92 | (assoc ast :tag tag) 93 | ast))) 94 | 95 | (defn =-arglists? [a1 a2] 96 | (let [tag (fn [x] (-> x meta :tag))] 97 | (and (= a1 a2) 98 | (every? true? (mapv (fn [a1 a2] 99 | (and (= (tag a1) (tag a2)) 100 | (= (mapv tag a1) 101 | (mapv tag a2)))) 102 | a1 a2))))) 103 | 104 | (defmethod -infer-tag :if 105 | [{:keys [then else] :as ast}] 106 | (let [then-tag (:tag then) 107 | else-tag (:tag else) 108 | ignore-then? (:ignore-tag then) 109 | ignore-else? (:ignore-tag else)] 110 | (cond 111 | (and then-tag 112 | (or ignore-else? (= then-tag else-tag))) 113 | (merge ast 114 | {:tag then-tag} 115 | (when-let [return-tag (:return-tag then)] 116 | (when (or ignore-else? 117 | (= return-tag (:return-tag else))) 118 | {:return-tag return-tag})) 119 | (when-let [arglists (:arglists then)] 120 | (when (or ignore-else? 121 | (=-arglists? arglists (:arglists else))) 122 | {:arglists arglists}))) 123 | 124 | (and else-tag ignore-then?) 125 | (merge ast 126 | {:tag else-tag} 127 | (when-let [return-tag (:return-tag else)] 128 | {:return-tag return-tag}) 129 | (when-let [arglists (:arglists else)] 130 | {:arglists arglists})) 131 | 132 | (and (:ignore-tag then) (:ignore-tag else)) 133 | (assoc ast :tag 'ignore :ignore-tag true) 134 | 135 | :else 136 | ast))) 137 | 138 | ;;TODO: handle catches 139 | (defmethod -infer-tag :try 140 | [{:keys [body catches] :as ast}] 141 | (let [{:keys []} body] 142 | (merge ast (select-keys [:tag :return-tag :arglists :ignore-tag] body)))) 143 | 144 | ;;TODO: handle :ignore-tag ? 145 | (defmethod -infer-tag :fn-method 146 | [{:keys [form body params local] :as ast}] 147 | (let [annotated-tag (or (:tag (meta (first form))) 148 | (:tag (meta (:form local)))) 149 | body-tag (:tag body) 150 | tag (or annotated-tag body-tag)] 151 | (merge ast 152 | (when tag 153 | {:tag tag}) 154 | {:arglist (with-meta (vec (mapcat (fn [{:keys [form variadic?]}] 155 | (if variadic? ['& form] [form])) 156 | params)) 157 | (when tag {:tag tag}))}))) 158 | 159 | (defmethod -infer-tag :fn 160 | [{:keys [local methods] :as ast}] 161 | (merge ast 162 | {:arglists (seq (mapv :arglist methods))} 163 | (when-let [tag (:tag (meta (:form local)))] 164 | {:return-tag tag}))) 165 | 166 | (defn var-sym [var] 167 | (when-let [{:keys [ns name]} var] 168 | (symbol (str (or ns 'js)) (str name)))) 169 | 170 | (defmethod -infer-tag :new 171 | [{:keys [class] :as ast}] 172 | (if-let [v (var-sym (:var class))] 173 | (assoc ast :tag (case v 174 | js/Object 'object 175 | js/String 'string 176 | js/Array 'array 177 | js/Number 'number 178 | js/Function 'function 179 | js/Boolean 'boolean 180 | v)) 181 | ast)) 182 | 183 | (defn infer-tag 184 | "Performs local type inference on the AST adds, when possible, 185 | one or more of the following keys to the AST: 186 | * :tag represents the type the expression represented by the node 187 | * :return-tag implies that the node will return a function whose 188 | invocation will result in a object of this type 189 | * :arglists implies that the node will return a function with 190 | this arglists 191 | * :ignore-tag true when the node is untyped, does not imply that 192 | all untyped node will have this" 193 | {:pass-info {:walk :post :depends #{#'analyze-host-expr #'annotate-tag #'add-binding-atom}}} 194 | [{:keys [tag] :as ast}] 195 | (merge (-infer-tag ast) 196 | (when tag 197 | {:tag tag}))) 198 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Eclipse Public License - v 1.0 2 | 3 | THE ACCOMPANYING PROGRAM IS PROVIDED UNDER THE TERMS OF THIS ECLIPSE PUBLIC 4 | LICENSE ("AGREEMENT"). ANY USE, REPRODUCTION OR DISTRIBUTION OF THE PROGRAM 5 | CONSTITUTES RECIPIENT'S ACCEPTANCE OF THIS AGREEMENT. 6 | 7 | 1. DEFINITIONS 8 | 9 | "Contribution" means: 10 | 11 | a) in the case of the initial Contributor, the initial code and documentation 12 | distributed under this Agreement, and 13 | b) in the case of each subsequent Contributor: 14 | i) changes to the Program, and 15 | ii) additions to the Program; 16 | 17 | where such changes and/or additions to the Program originate from and are 18 | distributed by that particular Contributor. A Contribution 'originates' 19 | from a Contributor if it was added to the Program by such Contributor 20 | itself or anyone acting on such Contributor's behalf. Contributions do not 21 | include additions to the Program which: (i) are separate modules of 22 | software distributed in conjunction with the Program under their own 23 | license agreement, and (ii) are not derivative works of the Program. 24 | 25 | "Contributor" means any person or entity that distributes the Program. 26 | 27 | "Licensed Patents" mean patent claims licensable by a Contributor which are 28 | necessarily infringed by the use or sale of its Contribution alone or when 29 | combined with the Program. 30 | 31 | "Program" means the Contributions distributed in accordance with this 32 | Agreement. 33 | 34 | "Recipient" means anyone who receives the Program under this Agreement, 35 | including all Contributors. 36 | 37 | 2. GRANT OF RIGHTS 38 | a) Subject to the terms of this Agreement, each Contributor hereby grants 39 | Recipient a non-exclusive, worldwide, royalty-free copyright license to 40 | reproduce, prepare derivative works of, publicly display, publicly 41 | perform, distribute and sublicense the Contribution of such Contributor, 42 | if any, and such derivative works, in source code and object code form. 43 | b) Subject to the terms of this Agreement, each Contributor hereby grants 44 | Recipient a non-exclusive, worldwide, royalty-free patent license under 45 | Licensed Patents to make, use, sell, offer to sell, import and otherwise 46 | transfer the Contribution of such Contributor, if any, in source code and 47 | object code form. This patent license shall apply to the combination of 48 | the Contribution and the Program if, at the time the Contribution is 49 | added by the Contributor, such addition of the Contribution causes such 50 | combination to be covered by the Licensed Patents. The patent license 51 | shall not apply to any other combinations which include the Contribution. 52 | No hardware per se is licensed hereunder. 53 | c) Recipient understands that although each Contributor grants the licenses 54 | to its Contributions set forth herein, no assurances are provided by any 55 | Contributor that the Program does not infringe the patent or other 56 | intellectual property rights of any other entity. Each Contributor 57 | disclaims any liability to Recipient for claims brought by any other 58 | entity based on infringement of intellectual property rights or 59 | otherwise. As a condition to exercising the rights and licenses granted 60 | hereunder, each Recipient hereby assumes sole responsibility to secure 61 | any other intellectual property rights needed, if any. For example, if a 62 | third party patent license is required to allow Recipient to distribute 63 | the Program, it is Recipient's responsibility to acquire that license 64 | before distributing the Program. 65 | d) Each Contributor represents that to its knowledge it has sufficient 66 | copyright rights in its Contribution, if any, to grant the copyright 67 | license set forth in this Agreement. 68 | 69 | 3. REQUIREMENTS 70 | 71 | A Contributor may choose to distribute the Program in object code form under 72 | its own license agreement, provided that: 73 | 74 | a) it complies with the terms and conditions of this Agreement; and 75 | b) its license agreement: 76 | i) effectively disclaims on behalf of all Contributors all warranties 77 | and conditions, express and implied, including warranties or 78 | conditions of title and non-infringement, and implied warranties or 79 | conditions of merchantability and fitness for a particular purpose; 80 | ii) effectively excludes on behalf of all Contributors all liability for 81 | damages, including direct, indirect, special, incidental and 82 | consequential damages, such as lost profits; 83 | iii) states that any provisions which differ from this Agreement are 84 | offered by that Contributor alone and not by any other party; and 85 | iv) states that source code for the Program is available from such 86 | Contributor, and informs licensees how to obtain it in a reasonable 87 | manner on or through a medium customarily used for software exchange. 88 | 89 | When the Program is made available in source code form: 90 | 91 | a) it must be made available under this Agreement; and 92 | b) a copy of this Agreement must be included with each copy of the Program. 93 | Contributors may not remove or alter any copyright notices contained 94 | within the Program. 95 | 96 | Each Contributor must identify itself as the originator of its Contribution, 97 | if 98 | any, in a manner that reasonably allows subsequent Recipients to identify the 99 | originator of the Contribution. 100 | 101 | 4. COMMERCIAL DISTRIBUTION 102 | 103 | Commercial distributors of software may accept certain responsibilities with 104 | respect to end users, business partners and the like. While this license is 105 | intended to facilitate the commercial use of the Program, the Contributor who 106 | includes the Program in a commercial product offering should do so in a manner 107 | which does not create potential liability for other Contributors. Therefore, 108 | if a Contributor includes the Program in a commercial product offering, such 109 | Contributor ("Commercial Contributor") hereby agrees to defend and indemnify 110 | every other Contributor ("Indemnified Contributor") against any losses, 111 | damages and costs (collectively "Losses") arising from claims, lawsuits and 112 | other legal actions brought by a third party against the Indemnified 113 | Contributor to the extent caused by the acts or omissions of such Commercial 114 | Contributor in connection with its distribution of the Program in a commercial 115 | product offering. The obligations in this section do not apply to any claims 116 | or Losses relating to any actual or alleged intellectual property 117 | infringement. In order to qualify, an Indemnified Contributor must: 118 | a) promptly notify the Commercial Contributor in writing of such claim, and 119 | b) allow the Commercial Contributor to control, and cooperate with the 120 | Commercial Contributor in, the defense and any related settlement 121 | negotiations. The Indemnified Contributor may participate in any such claim at 122 | its own expense. 123 | 124 | For example, a Contributor might include the Program in a commercial product 125 | offering, Product X. That Contributor is then a Commercial Contributor. If 126 | that Commercial Contributor then makes performance claims, or offers 127 | warranties related to Product X, those performance claims and warranties are 128 | such Commercial Contributor's responsibility alone. Under this section, the 129 | Commercial Contributor would have to defend claims against the other 130 | Contributors related to those performance claims and warranties, and if a 131 | court requires any other Contributor to pay any damages as a result, the 132 | Commercial Contributor must pay those damages. 133 | 134 | 5. NO WARRANTY 135 | 136 | EXCEPT AS EXPRESSLY SET FORTH IN THIS AGREEMENT, THE PROGRAM IS PROVIDED ON AN 137 | "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, EITHER EXPRESS OR 138 | IMPLIED INCLUDING, WITHOUT LIMITATION, ANY WARRANTIES OR CONDITIONS OF TITLE, 139 | NON-INFRINGEMENT, MERCHANTABILITY OR FITNESS FOR A PARTICULAR PURPOSE. Each 140 | Recipient is solely responsible for determining the appropriateness of using 141 | and distributing the Program and assumes all risks associated with its 142 | exercise of rights under this Agreement , including but not limited to the 143 | risks and costs of program errors, compliance with applicable laws, damage to 144 | or loss of data, programs or equipment, and unavailability or interruption of 145 | operations. 146 | 147 | 6. DISCLAIMER OF LIABILITY 148 | 149 | EXCEPT AS EXPRESSLY SET FORTH IN THIS AGREEMENT, NEITHER RECIPIENT NOR ANY 150 | CONTRIBUTORS SHALL HAVE ANY LIABILITY FOR ANY DIRECT, INDIRECT, INCIDENTAL, 151 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING WITHOUT LIMITATION 152 | LOST PROFITS), HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN 153 | CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) 154 | ARISING IN ANY WAY OUT OF THE USE OR DISTRIBUTION OF THE PROGRAM OR THE 155 | EXERCISE OF ANY RIGHTS GRANTED HEREUNDER, EVEN IF ADVISED OF THE POSSIBILITY 156 | OF SUCH DAMAGES. 157 | 158 | 7. GENERAL 159 | 160 | If any provision of this Agreement is invalid or unenforceable under 161 | applicable law, it shall not affect the validity or enforceability of the 162 | remainder of the terms of this Agreement, and without further action by the 163 | parties hereto, such provision shall be reformed to the minimum extent 164 | necessary to make such provision valid and enforceable. 165 | 166 | If Recipient institutes patent litigation against any entity (including a 167 | cross-claim or counterclaim in a lawsuit) alleging that the Program itself 168 | (excluding combinations of the Program with other software or hardware) 169 | infringes such Recipient's patent(s), then such Recipient's rights granted 170 | under Section 2(b) shall terminate as of the date such litigation is filed. 171 | 172 | All Recipient's rights under this Agreement shall terminate if it fails to 173 | comply with any of the material terms or conditions of this Agreement and does 174 | not cure such failure in a reasonable period of time after becoming aware of 175 | such noncompliance. If all Recipient's rights under this Agreement terminate, 176 | Recipient agrees to cease use and distribution of the Program as soon as 177 | reasonably practicable. However, Recipient's obligations under this Agreement 178 | and any licenses granted by Recipient relating to the Program shall continue 179 | and survive. 180 | 181 | Everyone is permitted to copy and distribute copies of this Agreement, but in 182 | order to avoid inconsistency the Agreement is copyrighted and may only be 183 | modified in the following manner. The Agreement Steward reserves the right to 184 | publish new versions (including revisions) of this Agreement from time to 185 | time. No one other than the Agreement Steward has the right to modify this 186 | Agreement. The Eclipse Foundation is the initial Agreement Steward. The 187 | Eclipse Foundation may assign the responsibility to serve as the Agreement 188 | Steward to a suitable separate entity. Each new version of the Agreement will 189 | be given a distinguishing version number. The Program (including 190 | Contributions) may always be distributed subject to the version of the 191 | Agreement under which it was received. In addition, after a new version of the 192 | Agreement is published, Contributor may elect to distribute the Program 193 | (including its Contributions) under the new version. Except as expressly 194 | stated in Sections 2(a) and 2(b) above, Recipient receives no rights or 195 | licenses to the intellectual property of any Contributor under this Agreement, 196 | whether expressly, by implication, estoppel or otherwise. All rights in the 197 | Program not expressly granted under this Agreement are reserved. 198 | 199 | This Agreement is governed by the laws of the State of New York and the 200 | intellectual property laws of the United States of America. No party to this 201 | Agreement will bring a legal action under this Agreement more than one year 202 | after the cause of action arose. Each party waives its rights to a jury trial in 203 | any resulting litigation. -------------------------------------------------------------------------------- /spec/ast-ref.edn: -------------------------------------------------------------------------------- 1 | {:all-keys 2 | 3 | [[:op "The node op"] 4 | [:form "The clojure form from which the node originated"] 5 | [:env "The environment map"] 6 | ^:optional 7 | [:children "A vector of keywords, representing the children nodes of this node, in order of evaluation"] 8 | ^:optional 9 | [:raw-forms "If this node's :form has been macroexpanded, a sequence of all the intermediate forms from the original form to the macroexpanded form"] 10 | ^:optional 11 | [:top-level "`true` if this is the root node"] 12 | [:tag "The tag of the expression"] 13 | ^:optional 14 | [:ignore-tag "`true` if this node returns a statement rather than an expression"]] 15 | 16 | :node-keys 17 | [{:op :binding 18 | :doc "Node for a binding symbol" 19 | :keys [[:form "The binding symbol"] 20 | [:name "The binding symbol"] 21 | [:local "One of :arg, :catch, :fn, :let, :letfn, :loop or :field"] 22 | ^:optional 23 | [:arg-id "When :local is :arg, the parameter index"] 24 | ^:optional 25 | [:variadic? "When :local is :arg, a boolean indicating whether this parameter binds to a variable number of arguments"] 26 | ^:optional ^:children 27 | [:init "When :local is :let, :letfn or :loop, an AST node representing the bound value"]]} 28 | {:op :case 29 | :doc "Node for a case* special-form expression" 30 | :keys [[:form "`(case* expr [test*] [then*] default)`"] 31 | ^:children 32 | [:test "The AST node for the expression to test against"] 33 | ^:children 34 | [:nodes "A vector of :case-node AST nodes representing the test/then clauses of the case* expression"] 35 | ^:children 36 | [:default "An AST node representing the default value of the case expression"]]} 37 | {:op :case-node 38 | :doc "Grouping node for tests/then expressions in a case* expression" 39 | :keys [^:children 40 | [:tests "A vector of :case-test AST nodes representing the test values"] 41 | ^:children 42 | [:then "A :case-then AST node representing the value the case expression will evaluate to when one of the :tests expressions matches the :case :test value"]]} 43 | {:op :case-test 44 | :doc "Node for a test value in a case* expression" 45 | :keys [^:children 46 | [:test "A :const AST node representing the test value"]]} 47 | {:op :case-then 48 | :doc "Node for a then expression in a case* expression" 49 | :keys [^:children 50 | [:then "An AST node representing the expression the case will evaluate to when the :test expression matches this node's corresponding :case-test value"]]} 51 | {:op :catch 52 | :doc "Node for a catch expression" 53 | :keys [[:form "`(catch class local body*)`"] 54 | ^:children 55 | [:class "An AST node representing the type of exception to catch"] 56 | ^:children 57 | [:local "The :binding AST node for the caught exception"] 58 | ^:children 59 | [:body "Synthetic :do AST node (with :body? `true`) representing the body of the catch clause"]]} 60 | {:op :const 61 | :doc "Node for a constant literal or a quoted collection literal" 62 | :keys [[:form "A constant literal or a quoted collection literal"] 63 | [:literal? "`true`"] 64 | [:type "one of :nil, :bool, :keyword, :symbol, :string, :number, :seq, :char, :regex or :unknown"] 65 | [:val "The value of the constant node"] 66 | ^:optional ^:children 67 | [:meta "A :map AST node representing the metadata of the constant value, if present."]]} 68 | {:op :def 69 | :doc "Node for a def special-form expression" 70 | :keys [[:form "`(def name docstring? init?)`"] 71 | [:name "The var symbol to define in the current namespace"] 72 | [:var "The var object created (or found, if it already existed) named by the symbol :name in the current namespace"] 73 | ^:optional ^:children 74 | [:meta "An AST node representing the metadata attached to :name, if present. The node will be either a :map node or a :const node with :type :map"] 75 | ^:optional ^:children 76 | [:init "An AST node representing the initial value of the var"] 77 | ^:optional 78 | [:doc "The docstring for this var"]]} 79 | {:op :deftype 80 | :doc "Node for a deftype* special-form expression" 81 | :keys [[:form "`(deftype name [field*] pmask body)"] 82 | [:name "The symbol name of the deftype"] 83 | ^:children 84 | [:fields "A vector of :binding AST nodes with :local :field representing the deftype fields"] 85 | [:pmask "The protocol mask of the deftype"] 86 | ^:children 87 | [:body "A :do AST node representing the inline protocols extensions of the deftype"]]} 88 | {:op :defrecord 89 | :doc "Node for a defrecord* special-form expression" 90 | :keys [[:form "`(defrecord name [field*] pmask body)"] 91 | [:name "The symbol name of the defrecord"] 92 | ^:children 93 | [:fields "A vector of :binding AST nodes with :local :field representing the defrecord fields"] 94 | [:pmask "The protocol mask of the defrecord"] 95 | ^:children 96 | [:body "A :do AST node representing the inline protocols extensions of the defrecord"]]} 97 | {:op :do 98 | :doc "Node for a do special-form expression or for another special-form's body" 99 | :keys [[:form "`(do statement* ret)`"] 100 | ^:children 101 | [:statements "A vector of AST nodes representing all but the last expression in the do body"] 102 | ^:children 103 | [:ret "An AST node representing the last expression in the do body (the block's return value)"] 104 | ^:optional 105 | [:body? "`true` if this node is a synthetic body"]]} 106 | {:op :fn 107 | :doc "Node for a fn* special-form expression" 108 | :keys [[:form "`(fn* name? [arg*] body*)` or `(fn* name? method*)`"] 109 | [:variadic? "`true` if this function contains a variadic arity method"] 110 | [:max-fixed-arity "The number of arguments taken by the fixed-arity method taking the most arguments"] 111 | ^:optional ^:children 112 | [:local "A :binding AST node with :local :fn representing the function's local name, if one is supplied"] 113 | ^:children 114 | [:methods "A vector of :fn-method AST nodes representing the fn method arities"] 115 | [:once "`true` if the fn is marked as `^:once fn*`, meaning it will only be executed once and thus allowing for the clearing of closed-over locals"]]} 116 | {:op :fn-method 117 | :doc "Node for an arity method in a fn* expression" 118 | :keys [[:form "`([arg*] body*)`"] 119 | [:loop-id "Unique symbol identifying this method as a target for recursion"] 120 | [:variadic? "`true` if this fn-method takes a variable number of arguments"] 121 | ^:children 122 | [:params "A vector of :binding AST nodes with :local :arg representing this fn-method args"] 123 | [:fixed-arity "The number of non-variadic args this fn-method takes"] 124 | ^:children 125 | [:body "Synthetic :do node (with :body? `true`) representing the body of this fn-method"]]} 126 | {:op :host-call 127 | :doc "Node for a host interop call" 128 | :keys [[:form "`(.method target arg*)`"] 129 | [:method "Symbol naming the method to call"] 130 | ^:children 131 | [:target "An AST node representing the target object"] 132 | ^:children 133 | [:args "A vector of AST nodes representing the args passed to the method call"]]} 134 | {:op :host-field 135 | :doc "Node for a host interop field access" 136 | :keys [[:form "`(.-field target)`"] 137 | [:field "Symbol naming the field to access"] 138 | ^:children 139 | [:target "An AST node representing the target object"] 140 | [:assignable? "`true`"]]} 141 | {:op :if 142 | :doc "Node for an if special-form expression" 143 | :keys [[:form "`(if test then else?)`"] 144 | ^:children 145 | [:test "An AST node representing the test expression"] 146 | ^:children 147 | [:then "An AST node representing the expression's return value if :test evaluated to a truthy value"] 148 | ^:children 149 | [:else "An AST node representing the expression's return value if :test evaluated to a falsey value, if not supplied it will default to a :const node representing nil"]]} 150 | {:op :invoke 151 | :doc "Node for an invoke expression" 152 | :keys [[:form "`(f arg*)`"] 153 | ^:children 154 | [:fn "An AST node representing the function to invoke"] 155 | ^:children 156 | [:args "A vector of AST nodes representing the args to the function"] 157 | ^:optional 158 | [:meta "Map of metadata attached to the invoke :form"]]} 159 | {:op :js 160 | :doc "Node for a js* special-form expression" 161 | :keys [[:form "`(js* js-string arg*)"] 162 | [:segs "A vector of js strings that delimit the compiled args"] 163 | ^:children 164 | [:args "A vector of AST nodes representing the cljs expressions that will be interposed with the strings in segs"]]} 165 | {:op :js-array 166 | :doc "Node for a js array literal" 167 | :keys [[:form "`#js [item*]`"] 168 | ^:children 169 | [:items "A vector of AST nodes representing the items of the js array"]]} 170 | {:op :js-object 171 | :doc "Node for a js object literal" 172 | :keys [[:form "`#js {[key value]*}`"] 173 | ^:children 174 | [:keys "A vector of AST nodes representing the keys of the js object"] 175 | ^:children 176 | [:vals "A vector of AST nodes representing the vals of the js object"]]} 177 | {:op :js-var 178 | :doc "Node for a js-var symbol" 179 | :keys [[:form "A symbol naming the js-var in the form: `js/foo`, `js-ns/foo` or `js-var`"] 180 | [:var "The js-var object this symbol refers to, if `:form` is in the form `js/foo`, `:ns` will be nil"] 181 | [:assignable? "`true`"]]} 182 | {:op :let 183 | :doc "Node for a let* special-form expression" 184 | :keys [[:form "`(let* [binding*] body*)`"] 185 | ^:children 186 | [:bindings "A vector of :binding AST nodes with :local :let"] 187 | ^:children 188 | [:body "Synthetic :do node (with :body? `true`) representing the body of the let expression"]]} 189 | {:op :letfn 190 | :doc "Node for a letfn* special-form expression" 191 | :keys [[:form "`(letfn* [binding*] body*)`"] 192 | ^:children 193 | [:bindings "A vector of :binding AST nodes with :local :letfn"] 194 | ^:children 195 | [:body "Synthetic :do node (with :body? `true`) representing the body of the letfn expression"]]} 196 | {:op :local 197 | :doc "Node for a local symbol" 198 | :keys [[:form "The local symbol"] 199 | [:name "The local symbol"] 200 | [:local "One of :arg, :catch, :fn, :let, :letfn, :loop or :field"] 201 | ^:optional 202 | [:arg-id "When :local is :arg, the parameter index"] 203 | ^:optional 204 | [:variadic? "When :local is :arg, a boolean indicating whether this parameter binds to a variable number of arguments"]]} 205 | {:op :loop 206 | :doc "Node a loop* special-form expression" 207 | :keys [[:form "`(loop* [binding*] body*)`"] 208 | ^:children 209 | [:bindings "A vector of :binding AST nodes with :local :loop"] 210 | ^:children 211 | [:body "Synthetic :do node (with :body? `true`) representing the body of the loop expression"] 212 | [:loop-id "Unique symbol identifying this loop as a target for recursion"]]} 213 | {:op :map 214 | :doc "Node for a map literal" 215 | :keys [[:form "`{[key val]*}`"] 216 | ^:children 217 | [:keys "A vector of AST nodes representing the keys of the map"] 218 | ^:children 219 | [:vals "A vector of AST nodes representing the vals of the map"]]} 220 | {:op :new 221 | :doc "Node for a new special-form expression" 222 | :keys [[:form "`(new Class arg*)`"] 223 | ^:children 224 | [:class "An AST node :class representing the class to instantiate"] 225 | ^:children 226 | [:args "A vector of AST nodes representing the arguments passed to the class constructor"]]} 227 | {:op :quote 228 | :doc "Node for a quote special-form expression" 229 | :keys [[:form "`(quote expr)`"] 230 | ^:children 231 | [:expr "A :const AST node representing the quoted value"] 232 | [:literal? "`true`"]]} 233 | {:op :recur 234 | :doc "Node for a recur special-form expression" 235 | :keys [[:form "`(recur expr*)`"] 236 | ^:children 237 | [:exprs "A vector of AST nodes representing the new bound values for the loop binding on the next loop iteration"]]} 238 | {:op :set 239 | :doc "Node for a set literal" 240 | :keys [[:form "`#{item*}`"] 241 | ^:children 242 | [:items "A vector of AST nodes representing the items of the set"]]} 243 | {:op :set! 244 | :doc "Node for a set! special-form expression" 245 | :keys [[:form "`(set! target val)`"] 246 | ^:children 247 | [:target "An AST node representing the target of the set! expression, must be :assignable?"] 248 | [:val "An AST node representing the new value for the target"]]} 249 | {:op :throw 250 | :doc "Node for a throw special-form statement" 251 | :keys [[:form "`(throw exception)`"] 252 | ^:children 253 | [:exception "An AST node representing the exception to throw"]]} 254 | {:op :try 255 | :doc "Node for a try special-form expression" 256 | :keys [[:form "`(try body* catch* finally?)`"] 257 | ^:children 258 | [:catches "A vector of :catch AST nodes representing the catch clauses of this try expression"] 259 | ^:optional ^:children 260 | [:finally "Synthetic :do AST node (with :body? `true`) representing the final clause of this try expression"]]} 261 | {:op :var 262 | :doc "Node for a var symbol" 263 | :keys [[:form "A symbol naming the var"] 264 | [:var "The var object this symbol refers to"] 265 | ^:optional 266 | [:assignable? "`true` if the Var is :dynamic"]]} 267 | {:op :vector 268 | :doc "Node for a vector literal with attached metadata and/or non literal elements" 269 | :keys [[:form "`[item*]`"] 270 | ^:children 271 | [:items "A vector of AST nodes representing the items of the vector"]]} 272 | {:op :with-meta 273 | :doc "Node for a non quoted collection literal or a fn expression with attached metadata" 274 | :keys [[:form "Non quoted collection literal or fn expression with attached metadata"] 275 | ^:children 276 | [:meta "A :map AST node representing the metadata of expression."] 277 | ^:children 278 | [:expr "The expression this metadata is attached to, :op is one of :vector, :map, :set or :fn"]]}]} 279 | -------------------------------------------------------------------------------- /src/main/clojure/clojure/tools/analyzer/js.clj: -------------------------------------------------------------------------------- 1 | ;; Copyright (c) Nicola Mometto, Rich Hickey & contributors. 2 | ;; The use and distribution terms for this software are covered by the 3 | ;; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) 4 | ;; which can be found in the file epl-v10.html at the root of this distribution. 5 | ;; By using this software in any fashion, you are agreeing to be bound by 6 | ;; the terms of this license. 7 | ;; You must not remove this notice, or any other, from this software. 8 | 9 | (ns clojure.tools.analyzer.js 10 | "Analyzer for clojurescript code, extends tools.analyzer with JS specific passes/forms" 11 | (:refer-clojure :exclude [macroexpand-1 var? *ns* ns-resolve]) 12 | (:require [clojure.tools.analyzer 13 | :as ana 14 | :refer [analyze analyze-in-env] 15 | :rename {analyze -analyze}] 16 | [clojure.tools.analyzer 17 | [utils :refer [resolve-ns ctx -source-info dissoc-env const-val mmerge update-vals] :as u] 18 | [ast :refer [prewalk postwalk]] 19 | [env :as env :refer [*env*]] 20 | [passes :refer [schedule]]] 21 | [clojure.tools.analyzer.passes 22 | [source-info :refer [source-info]] 23 | [cleanup :refer [cleanup]] 24 | [elide-meta :refer [elide-meta elides]] 25 | [warn-earmuff :refer [warn-earmuff]] 26 | [add-binding-atom :refer [add-binding-atom]] 27 | [uniquify :refer [uniquify-locals]]] 28 | [clojure.tools.analyzer.passes.js 29 | [annotate-tag :refer [annotate-tag]] 30 | [infer-tag :refer [infer-tag]] 31 | [validate :refer [validate]] 32 | [collect-keywords :refer [collect-keywords]] 33 | [analyze-host-expr :refer [analyze-host-expr]]] 34 | [clojure.tools.analyzer.js.utils 35 | :refer [desugar-ns-specs validate-ns-specs ns-resource ns->relpath res-path]] 36 | [cljs 37 | [env :as cljs.env] 38 | [analyzer :as cljs.ana] 39 | [tagged-literals :as tags] 40 | [js-deps :as deps]] 41 | [clojure.string :as s] 42 | [clojure.java.io :as io] 43 | [clojure.tools.reader :as reader] 44 | [clojure.tools.reader.reader-types :as readers]) 45 | (:import cljs.tagged_literals.JSValue)) 46 | 47 | (alias 'c.c 'clojure.core) 48 | 49 | (def specials 50 | "Set of the special forms for clojurescript" 51 | (into ana/specials '#{ns deftype* defrecord* js* case*})) 52 | 53 | (defmulti parse 54 | "Extension to tools.analyzer/-parse for CLJS special forms" 55 | (fn [[op & rest] env] op)) 56 | 57 | (defmethod parse :default 58 | [form env] 59 | (ana/-parse form env)) 60 | 61 | (def ^:dynamic *ns* 'cljs.user) 62 | 63 | (defonce core-env (atom {})) 64 | 65 | (defn global-env [] 66 | (atom (merge (and cljs.env/*compiler* @cljs.env/*compiler*) 67 | {:namespaces (merge '{goog {:mappings {}, :js-namespace true, :ns goog} 68 | Math {:mappings {}, :js-namespace true, :ns Math}} 69 | @core-env) 70 | :js-dependency-index (deps/js-dependency-index {})}))) 71 | 72 | (defn empty-env 73 | "Returns an empty env map" 74 | [] 75 | {:context :ctx/statement 76 | :locals {} 77 | :ns *ns*}) 78 | 79 | (defn fix-ns [ns] 80 | (case ns 81 | ("clojure.core" "clojure.tools.analyzer.js.cljs.core") 82 | "cljs.core" 83 | ns)) 84 | 85 | (defn fix-ns-macro [ns] 86 | (let [ns (fix-ns ns)] 87 | (if (= "cljs.core" ns) 88 | "clojure.tools.analyzer.js.cljs.core" 89 | ns))) 90 | 91 | (defn fix-symbol [sym] 92 | (symbol (fix-ns (namespace sym)) (name sym))) 93 | 94 | (defn ns-resolve [ns sym] 95 | (let [ns (if (string? ns) 96 | (symbol ns) 97 | ns) 98 | sym (if (string? sym) 99 | (symbol sym) 100 | sym)] 101 | (and (find-ns ns) 102 | (c.c/ns-resolve ns sym)))) 103 | 104 | (defn maybe-macro [sym {:keys [ns]}] 105 | (let [var (if-let [sym-ns (fix-ns-macro (namespace sym))] 106 | (if-let [full-ns (get-in (env/deref-env) 107 | [:namespaces ns :macro-aliases (symbol sym-ns)])] 108 | (ns-resolve full-ns (name sym)) 109 | (ns-resolve sym-ns (name sym))) 110 | (get-in (env/deref-env) [:namespaces ns :macro-mappings sym]))] 111 | (when (:macro (meta var)) 112 | var))) 113 | 114 | (defn resolve-sym [sym env] 115 | (or (u/resolve-sym (fix-symbol sym) env) 116 | (get-in env [:locals sym]))) 117 | 118 | (defn dotted-symbol? [form env] 119 | (let [n (name form) 120 | ns (namespace form) 121 | idx (.indexOf n ".") 122 | sym (and (pos? idx) 123 | (symbol ns (.substring n 0 idx)))] 124 | (and (not= idx -1) 125 | (not (resolve-sym form env)) 126 | (not= sym form) 127 | (resolve-sym sym env)))) 128 | 129 | (defn desugar-symbol [form env] 130 | (let [ns (fix-ns (namespace form)) 131 | n (name form) 132 | form (symbol ns n)] 133 | (if (dotted-symbol? form env) 134 | (let [idx (.indexOf n ".") 135 | sym (symbol ns (.substring n 0 idx))] 136 | (list '. sym (symbol (str "-" (.substring n (inc idx) (count n)))))) 137 | 138 | form))) 139 | 140 | (defn desugar-host-expr [form env] 141 | (if (symbol? (first form)) 142 | (let [[op & expr] form 143 | opname (name op) 144 | opns (namespace op)] 145 | (cond 146 | 147 | ;; (.foo bar ..) -> (. bar foo ..) 148 | (= (first opname) \.) 149 | (let [[target & args] expr 150 | args (list* (symbol (subs opname 1)) args)] 151 | (list '. target (if (= 1 (count args)) 152 | (first args) args))) 153 | 154 | ;; (foo. ..) -> (new foo ..) 155 | (= (last opname) \.) 156 | (let [op-s (str op)] 157 | (list* 'new (symbol (subs op-s 0 (dec (count op-s)))) expr)) 158 | 159 | ;; (var.foo ..) -> (. var foo ..) 160 | (dotted-symbol? op env) 161 | (let [idx (.indexOf opname ".") 162 | sym (symbol opns (.substring opname 0 idx))] 163 | (list '. sym (list* (symbol (.substring opname (inc idx) (count opname))) expr))) 164 | 165 | :else (list* (fix-symbol op) expr))) 166 | form)) 167 | 168 | (defn macroexpand-1 [form env] 169 | "If form represents a macro form returns its expansion, else returns form." 170 | (env/ensure (global-env) 171 | (if (seq? form) 172 | (let [op (first form)] 173 | (if (or (not (symbol? op)) 174 | (specials op)) 175 | form 176 | (if-let [clj-macro (and (not (-> env :locals (get op))) 177 | (maybe-macro op env))] 178 | (with-bindings (merge {#'c.c/*ns* (create-ns *ns*)} 179 | (when-not (thread-bound? #'*ns*) 180 | {#'*ns* *ns*})) 181 | (let [ret (apply clj-macro form env (rest form))] ; (m &form &env & args) 182 | (if (and (seq? ret) 183 | (= 'js* (first ret))) 184 | (vary-meta ret merge 185 | (when (-> clj-macro meta :cljs.analyzer/numeric) 186 | {:tag 'number})) 187 | ret))) 188 | (with-meta (desugar-host-expr form env) (meta form))))) 189 | (with-meta (desugar-symbol form env) (meta form))))) 190 | 191 | (defn create-var 192 | "Creates a var map for sym and returns it." 193 | [sym {:keys [ns]}] 194 | (with-meta {:op :var 195 | :name sym 196 | :ns ns} 197 | (meta sym))) 198 | 199 | (defn var? [x] 200 | (= :var (:op x))) 201 | 202 | ;; can it be :literal ? 203 | (defn analyze-js-value 204 | [form env] 205 | (let [val (.val ^JSValue form) 206 | items-env (ctx env :expr)] 207 | (if (map? val) 208 | ;; keys should always be symbols/kewords, do we really need to analyze them? 209 | {:op :js-object 210 | :env env 211 | :keys (mapv (analyze-in-env items-env) (keys val)) 212 | :vals (mapv (analyze-in-env items-env) (vals val)) 213 | :form form 214 | :children [:keys :vals]} 215 | {:op :js-array 216 | :env env 217 | :items (mapv (analyze-in-env items-env) val) 218 | :form form 219 | :children [:items]}))) 220 | 221 | (defn analyze-form 222 | [form env] 223 | (if (instance? JSValue form) 224 | (analyze-js-value form env) 225 | (ana/-analyze-form form env))) 226 | 227 | (defn parse-type 228 | [op [_ name fields pmasks body :as form] {:keys [ns] :as env}] 229 | (let [fields-expr (mapv (fn [name] 230 | {:env env 231 | :form name 232 | :name name 233 | :mutable (:mutable (meta name)) 234 | :local :field 235 | :op :binding}) 236 | fields) 237 | protocols (-> name meta :protocols) 238 | 239 | _ (swap! *env* assoc-in [:namespaces ns :mappings name] 240 | {:op :var 241 | :type true 242 | :name name 243 | :ns ns 244 | :fields fields 245 | :protocols protocols}) 246 | 247 | body-expr (-analyze body (assoc env 248 | :locals (zipmap fields (map dissoc-env fields-expr))))] 249 | 250 | {:op op 251 | :env env 252 | :form form 253 | :name name 254 | :fields fields-expr 255 | :body body-expr 256 | :pmasks pmasks 257 | :protocols protocols 258 | :children [:fields :body]})) 259 | 260 | (defmethod parse 'deftype* 261 | [form env] 262 | (parse-type :deftype form env)) 263 | 264 | (defmethod parse 'defrecord* 265 | [form env] 266 | (parse-type :defrecord form env)) 267 | 268 | ;; no ~{foo} support since cljs itself doesn't use it anywhere 269 | (defmethod parse 'js* 270 | [[_ jsform & args :as form] env] 271 | (when-not (string? jsform) 272 | (throw (ex-info "Invalid js* form" 273 | (merge {:form form} 274 | (-source-info form env))))) 275 | (let [segs (loop [segs [] ^String s jsform] 276 | (let [idx (.indexOf s "~{")] 277 | (if (= -1 idx) 278 | (conj segs s) 279 | (recur (conj segs (subs s 0 idx)) 280 | (subs s (inc (.indexOf s "}" idx))))))) 281 | exprs (mapv (analyze-in-env (ctx env :ctx/expr)) args)] 282 | (merge 283 | {:op :js 284 | :env env 285 | :form form 286 | :segs segs} 287 | (when args 288 | {:args exprs 289 | :children [:args]})))) 290 | 291 | (defmethod parse 'case* 292 | [[_ test tests thens default :as form] env] 293 | (assert (symbol? test) "case* must switch on symbol") 294 | (assert (every? vector? tests) "case* tests must be grouped in vectors") 295 | (let [expr-env (ctx env :expr) 296 | test-expr (-analyze test expr-env) 297 | nodes (mapv (fn [tests then] 298 | {:op :case-node 299 | ;; no :form, this is a synthetic grouping node 300 | :env env 301 | :tests (mapv (fn [test] 302 | {:op :case-test 303 | :form test 304 | :env expr-env 305 | :test (-analyze test expr-env) 306 | :children [:test]}) 307 | tests) 308 | :then {:op :case-then 309 | :form test 310 | :env env 311 | :then (-analyze then env) 312 | :children [:then]} 313 | :children [:tests :then]}) 314 | tests thens) 315 | default-expr (-analyze default env)] 316 | (assert (every? (fn [t] (and (= :const (-> t :test :op)) 317 | ((some-fn number? string?) (:form t)))) 318 | (mapcat :tests nodes)) 319 | "case* tests must be numbers or strings") 320 | {:op :case 321 | :form form 322 | :env env 323 | :test (assoc test-expr :case-test true) 324 | :nodes nodes 325 | :default default-expr 326 | :children [:test :nodes :default]})) 327 | 328 | (def ^:private ^:dynamic *deps-map* {:path [] :deps #{}}) 329 | (declare analyze-ns) 330 | 331 | (defn ensure-loaded [ns {:keys [refer]}] 332 | (assert (not (contains? (:deps *deps-map*) ns)) 333 | (str "Circular dependency detected :" (conj (:path *deps-map*) ns))) 334 | (binding [*deps-map* (-> *deps-map* 335 | (update-in [:path] conj ns) 336 | (update-in [:deps] conj ns))] 337 | (let [namespaces (-> (env/deref-env) :namespaces)] 338 | (or (and (get namespaces ns) 339 | (not (get-in namespaces [ns :js-namespace]))) 340 | (and (get-in (env/deref-env) [:js-dependency-index (name ns)]) 341 | (swap! env/*env* update-in [:namespaces ns] merge 342 | {:ns ns 343 | :js-namespace true}) 344 | (swap! env/*env* update-in [:namespaces ns :mappings] merge 345 | (reduce (fn [m k] (assoc m k {:op :js-var 346 | :name k 347 | :ns ns})) 348 | {} refer))) 349 | (analyze-ns ns))))) 350 | 351 | (defn core-macros [] 352 | (reduce-kv (fn [m k v] 353 | (if (:macro (meta v)) 354 | (assoc m k v) 355 | m)) 356 | {} (ns-interns 'clojure.tools.analyzer.js.cljs.core))) 357 | 358 | (defn populate-env 359 | [{:keys [import require require-macros refer-clojure]} ns-name env] 360 | (let [imports (reduce-kv (fn [m prefix suffixes] 361 | (merge m (into {} (mapv (fn [s] [s {:op :js-var 362 | :ns prefix 363 | :name s}]) suffixes)))) {} import) 364 | require-aliases (reduce (fn [m [ns {:keys [as]}]] 365 | (if as 366 | (assoc m as ns) 367 | m)) {} require) 368 | require-mappings (reduce (fn [m [ns {:keys [refer] :as spec}]] 369 | (ensure-loaded ns spec) 370 | (reduce #(assoc %1 %2 (get-in (env/deref-env) 371 | [:namespaces ns :mappings %2])) m refer)) 372 | {} require) 373 | core-mappings (apply dissoc (get-in (env/deref-env) [:namespaces 'cljs.core :mappings]) (:exclude refer-clojure)) 374 | macro-aliases (reduce (fn [m [ns {:keys [as]}]] 375 | (if as 376 | (assoc m as ns) 377 | m)) {} require-macros) 378 | core-macro-mappings (apply dissoc (core-macros) (:exclude refer-clojure)) 379 | macro-mappings (reduce (fn [m [ns {:keys [refer]}]] 380 | (c.c/require ns) 381 | (reduce #(let [m (ns-resolve ns (name %2))] 382 | (if (:macro (meta m)) 383 | (assoc %1 %2 m) 384 | %1)) m refer)) 385 | {} require-macros)] 386 | 387 | (swap! *env* assoc-in [:namespaces ns-name] 388 | {:ns ns-name 389 | :mappings (merge core-mappings require-mappings imports) 390 | :aliases require-aliases 391 | :macro-mappings (merge core-macro-mappings macro-mappings) 392 | :macro-aliases macro-aliases}))) 393 | 394 | (defmethod parse 'ns 395 | [[_ name & args :as form] env] 396 | (when-not (symbol? name) 397 | (throw (ex-info (str "Namespaces must be named by a symbol, had: " 398 | (.getName ^Class (class name))) 399 | (merge {:form form} 400 | (-source-info form env))))) 401 | (let [[docstring & args] (if (string? (first args)) 402 | args 403 | (cons nil args)) 404 | [metadata & args] (if (map? (first args)) 405 | args 406 | (cons {} args)) 407 | name (vary-meta name merge metadata) 408 | ns-opts (doto (desugar-ns-specs args form env) 409 | (validate-ns-specs form env) 410 | (populate-env name env))] 411 | (set! *ns* name) 412 | (merge 413 | {:op :ns 414 | :env env 415 | :form form 416 | :name name 417 | :depends (set (keys (:require ns-opts)))} 418 | (when docstring 419 | {:doc docstring}) 420 | (when metadata 421 | {:meta metadata})))) 422 | 423 | (defmethod parse 'def 424 | [[_ sym & rest :as form] env] 425 | (let [ks #{:ns :name :doc :arglists :file :line :column} 426 | meta (meta sym) 427 | m (merge {} 428 | (update-vals (select-keys meta ks) (fn [x] (list 'quote x))) 429 | (when (:test meta) 430 | {:test `(.-cljs$lang$test ~sym)}))] 431 | (ana/-parse (with-meta `(def ~(with-meta sym m) ~@rest) (meta form)) env))) 432 | 433 | (def default-passes 434 | "Set of passes that will be run by default on the AST by #'run-passes" 435 | #{#'warn-earmuff 436 | 437 | #'uniquify-locals 438 | 439 | #'source-info 440 | #'elide-meta 441 | 442 | #'collect-keywords 443 | 444 | #'validate 445 | #'infer-tag}) 446 | 447 | (def scheduled-default-passes 448 | (schedule default-passes)) 449 | 450 | (defn ^:dynamic run-passes 451 | "Function that will be invoked on the AST tree immediately after it has been constructed, 452 | by default set-ups and runs the default passes declared in #'default-passes" 453 | [ast] 454 | (scheduled-default-passes ast)) 455 | 456 | (defn analyze 457 | "Returns an AST for the form. 458 | 459 | Binds tools.analyzer/{macroexpand-1,create-var,parse} to 460 | tools.analyzer.js/{macroexpand-1,create-var,parse} and analyzes the form. 461 | 462 | If provided, opts should be a map of options to analyze, currently the only valid 463 | options are :bindings and :passes-opts. 464 | If provided, :bindings should be a map of Var->value pairs that will be merged into the 465 | default bindings for tools.analyzer, useful to provide custom extension points. 466 | If provided, :passes-opts should be a map of pass-name-kw->pass-config-map pairs that 467 | can be used to configure the behaviour of each pass. 468 | 469 | E.g. 470 | (analyze form env {:bindings {#'ana/macroexpand-1 my-mexpand-1}}) 471 | 472 | Calls `run-passes` on the AST." 473 | ([form] (analyze form (empty-env) {})) 474 | ([form env] (analyze form env {})) 475 | ([form env opts] 476 | (with-bindings (merge {#'ana/macroexpand-1 macroexpand-1 477 | #'ana/create-var create-var 478 | #'ana/parse parse 479 | #'ana/var? var? 480 | #'ana/analyze-form analyze-form 481 | #'elides (-> elides 482 | (update-in [:all] into #{:line :column :end-line :end-column :file :source}) 483 | (assoc-in [:fn] #{:cljs.analyzer/type :cljs.analyzer/protocol-impl :cljs.analyzer/protocol-inline}))} 484 | (when-not (thread-bound? #'*ns*) 485 | {#'*ns* *ns*}) 486 | (:bindings opts)) 487 | (env/ensure (global-env) 488 | (swap! env/*env* mmerge {:passes-opts (:passes-opts opts)}) 489 | (run-passes (-analyze form env)))))) 490 | 491 | (defn analyze-ns 492 | "Analyzes a whole namespace, returns a vector of the ASTs for all the 493 | top-level ASTs of that namespace." 494 | [ns] 495 | (env/ensure (global-env) 496 | (let [res (ns-resource ns)] 497 | (assert res (str "Can't find " ns " in classpath")) 498 | (let [filename (ns->relpath ns) 499 | path (res-path res)] 500 | (when-not (get-in *env* [::analyzed-cljs path]) 501 | (binding [*ns* *ns* 502 | *file* filename] 503 | (with-open [rdr (io/reader res)] 504 | (let [pbr (readers/indexing-push-back-reader 505 | (java.io.PushbackReader. rdr) 1 filename) 506 | eof (Object.) 507 | env (empty-env)] 508 | (loop [] 509 | (let [form (binding [c.c/*ns* (create-ns *ns*) 510 | reader/*data-readers* tags/*cljs-data-readers* 511 | reader/*alias-map* (apply merge {} 512 | (-> (env/deref-env) :namespaces (get *ns*) 513 | (select-keys #{:aliases :macro-aliases}) 514 | vals))] 515 | (reader/read pbr nil eof))] 516 | (when-not (identical? form eof) 517 | (swap! *env* update-in [::analyzed-cljs path] 518 | (fnil conj []) 519 | (analyze form (assoc env :ns *ns*))) 520 | (recur)))))))) 521 | (get-in @*env* [::analyzed-cljs path]))))) 522 | 523 | (defn backup-env 524 | "Caches the current namespaces state in a resource file, can be restored with 525 | (restore-env)" 526 | [] 527 | (env/ensure (global-env) 528 | (with-redefs [clojure.core/pr-on (fn [x w] (if (clojure.core/var? x) 529 | (print-dup x w) 530 | (print-method x w)) 531 | nil)] 532 | (binding [*print-level* nil 533 | *print-length* nil 534 | *print-meta* true] 535 | (let [s (pr-str (:namespaces (env/deref-env)))] 536 | (spit (io/resource "tools.analyzer.js/cached-env.res") s)))))) 537 | 538 | (defn restore-env 539 | "Uses a cached env to populate the default namespace map" 540 | [] 541 | (reset! core-env 542 | (reader/read-string (slurp (io/resource "tools.analyzer.js/cached-env.res"))))) 543 | 544 | (defn setup-rt! 545 | "Setups the basic runtime, loading cljs.core and initializing cljs.user" 546 | [] 547 | (require 'clojure.tools.analyzer.js.cljs.core) 548 | (when-not (or (seq @core-env) 549 | (seq (restore-env))) 550 | (env/with-env (global-env) 551 | (analyze-ns 'cljs.core) 552 | (analyze '(ns cljs.user)) 553 | (reset! core-env (select-keys (:namespaces (env/deref-env)) '[cljs.core cljs.user]))))) 554 | 555 | (defn cljs-env->env 556 | "Converts the namespace map of the current cljs environment in a tools.analyzer.js 557 | namespace map and returns it." 558 | [] 559 | (env/ensure (global-env) 560 | (reduce (fn [m {:keys [name excludes uses requires use-macros require-macros imports defs]}] 561 | (let [imports (reduce-kv (fn [m k v] 562 | (assoc m k (let [s (s/split (c.c/name v) #"\.")] 563 | {:op :js-var 564 | :ns (symbol (s/join "." (butlast s))) 565 | :name (symbol (last s))}))) {} imports) 566 | parse-requires (fn [r] (reduce-kv (fn [m k v] (if (not= k v) 567 | (assoc m k v) 568 | m)) {} r)) 569 | core-mappings (apply dissoc (get-in (env/deref-env) [:namespaces 'cljs.core :mappings]) excludes) 570 | core-macro-mappings (apply dissoc (core-macros) excludes) 571 | js-namespaces (reduce (fn [m ns] (assoc m ns {:ns ns :js-namespace true})) {} (set (vals requires))) 572 | 573 | mappings (reduce-kv (fn [m k v] (assoc m k {:op (if (js-namespaces v) :js-var :var) 574 | :name k 575 | :ns v})) {} uses) 576 | macro-mappings (reduce-kv (fn [m k v] 577 | (let [macro (ns-resolve v k)] 578 | (if (:macro (meta macro)) 579 | (assoc m k macro) 580 | m))) {} uses) 581 | defs (reduce-kv (fn [m k v] 582 | (assoc m k {:op :var 583 | :name (vary-meta k merge (select-keys v #{:protocol-impl})) 584 | :ns name})) {} defs)] 585 | (merge m js-namespaces 586 | {name {:ns name 587 | :mappings (merge imports core-mappings mappings defs) 588 | :macro-mappings (merge core-macro-mappings macro-mappings) 589 | :aliases (parse-requires requires) 590 | :macro-aliases (parse-requires require-macros)}}))) 591 | {} (vals @cljs.ana/namespaces)))) 592 | 593 | (setup-rt!) 594 | -------------------------------------------------------------------------------- /src/main/clojure/clojure/tools/analyzer/js/cljs/core.clj: -------------------------------------------------------------------------------- 1 | ; Copyright (c) Rich Hickey. All rights reserved. 2 | ; The use and distribution terms for this software are covered by the 3 | ; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) 4 | ; which can be found in the file epl-v10.html at the root of this distribution. 5 | ; By using this software in any fashion, you are agreeing to be bound by 6 | ; the terms of this license. 7 | ; You must not remove this notice, or any other, from this software. 8 | 9 | (ns clojure.tools.analyzer.js.cljs.core 10 | (:refer-clojure :exclude [-> ->> .. amap and areduce alength aclone assert binding bound-fn case comment cond condp 11 | declare definline definterface defmethod defmulti defn defn- defonce 12 | defprotocol defrecord defstruct deftype delay destructure doseq dosync dotimes doto 13 | extend-protocol extend-type fn for future gen-class gen-interface 14 | if-let if-not import io! lazy-cat lazy-seq let letfn locking loop 15 | memfn ns or proxy proxy-super pvalues refer-clojure reify sync time 16 | when when-first when-let when-not while with-bindings with-in-str 17 | with-loading-context with-local-vars with-open with-out-str with-precision with-redefs 18 | satisfies? identical? true? false? number? nil? instance? symbol? keyword? string? str get 19 | make-array vector list hash-map array-map hash-set 20 | 21 | aget aset 22 | + - * / < <= > >= == zero? pos? neg? inc dec max min mod 23 | byte char short int long float double 24 | unchecked-byte unchecked-char unchecked-short unchecked-int 25 | unchecked-long unchecked-float unchecked-double 26 | unchecked-add unchecked-add-int unchecked-dec unchecked-dec-int 27 | unchecked-divide unchecked-divide-int unchecked-inc unchecked-inc-int 28 | unchecked-multiply unchecked-multiply-int unchecked-negate unchecked-negate-int 29 | unchecked-subtract unchecked-subtract-int unchecked-remainder-int 30 | unsigned-bit-shift-right 31 | 32 | bit-and bit-and-not bit-clear bit-flip bit-not bit-or bit-set 33 | bit-test bit-shift-left bit-shift-right bit-xor 34 | 35 | cond-> cond->> as-> some-> some->> 36 | 37 | if-some when-some test ns-interns]) 38 | (:require clojure.walk 39 | clojure.set 40 | cljs.compiler 41 | [clojure.tools.analyzer.env :as env] 42 | [clojure.tools.analyzer :as a] 43 | [clojure.tools.analyzer.utils :as utils])) 44 | 45 | (alias 'core 'clojure.core) 46 | (alias 'ana 'cljs.analyzer) 47 | 48 | (defmacro import-macros [ns [& vars]] 49 | (core/let [ns (find-ns ns) 50 | vars (map #(ns-resolve ns %) vars) 51 | syms (map (core/fn [^clojure.lang.Var v] (core/-> v .sym (with-meta {:macro true}))) vars) 52 | defs (map (core/fn [sym var] 53 | `(do (def ~sym (deref ~var)) 54 | ;for AOT compilation 55 | (alter-meta! (var ~sym) assoc :macro true))) 56 | syms vars)] 57 | `(do ~@defs 58 | :imported))) 59 | 60 | (import-macros clojure.core 61 | [-> ->> .. assert comment cond 62 | declare defn defn- 63 | doto 64 | extend-protocol fn for 65 | if-let if-not letfn 66 | memfn 67 | when when-first when-let when-not while 68 | cond-> cond->> as-> some-> some->> 69 | if-some when-some]) 70 | 71 | (defmacro defonce [x init] 72 | `(when-not (exists? ~x) 73 | (def ~x ~init))) 74 | 75 | (defmacro ^{:private true} assert-args [fnname & pairs] 76 | `(do (when-not ~(first pairs) 77 | (throw (IllegalArgumentException. 78 | ~(core/str fnname " requires " (second pairs))))) 79 | ~(core/let [more (nnext pairs)] 80 | (when more 81 | (list* `assert-args fnname more))))) 82 | 83 | (defn destructure [bindings] 84 | (core/let [bents (partition 2 bindings) 85 | pb (fn pb [bvec b v] 86 | (core/let [pvec 87 | (fn [bvec b val] 88 | (core/let [gvec (gensym "vec__")] 89 | (core/loop [ret (-> bvec (conj gvec) (conj val)) 90 | n 0 91 | bs b 92 | seen-rest? false] 93 | (if (seq bs) 94 | (core/let [firstb (first bs)] 95 | (core/cond 96 | (= firstb '&) (recur (pb ret (second bs) (core/list `nthnext gvec n)) 97 | n 98 | (nnext bs) 99 | true) 100 | (= firstb :as) (pb ret (second bs) gvec) 101 | :else (if seen-rest? 102 | (throw (new Exception "Unsupported binding form, only :as can follow & parameter")) 103 | (recur (pb ret firstb (core/list `nth gvec n nil)) 104 | (core/inc n) 105 | (next bs) 106 | seen-rest?)))) 107 | ret)))) 108 | pmap 109 | (fn [bvec b v] 110 | (core/let [gmap (gensym "map__") 111 | defaults (:or b)] 112 | (core/loop [ret (-> bvec (conj gmap) (conj v) 113 | (conj gmap) (conj `(if (seq? ~gmap) (apply core/hash-map ~gmap) ~gmap)) 114 | ((fn [ret] 115 | (if (:as b) 116 | (conj ret (:as b) gmap) 117 | ret)))) 118 | bes (reduce 119 | (fn [bes entry] 120 | (reduce #(assoc %1 %2 ((val entry) %2)) 121 | (dissoc bes (key entry)) 122 | ((key entry) bes))) 123 | (dissoc b :as :or) 124 | {:keys #(if (core/keyword? %) % (keyword (core/str %))), 125 | :strs core/str, :syms #(core/list `quote %)})] 126 | (if (seq bes) 127 | (core/let [bb (key (first bes)) 128 | bk (val (first bes)) 129 | has-default (contains? defaults bb)] 130 | (recur (pb ret bb (if has-default 131 | (core/list `get gmap bk (defaults bb)) 132 | (core/list `get gmap bk))) 133 | (next bes))) 134 | ret))))] 135 | (core/cond 136 | (core/symbol? b) (-> bvec (conj (if (namespace b) (symbol (name b)) b)) (conj v)) 137 | (core/keyword? b) (-> bvec (conj (symbol (name b))) (conj v)) 138 | (vector? b) (pvec bvec b v) 139 | (map? b) (pmap bvec b v) 140 | :else (throw (new Exception (core/str "Unsupported binding form: " b)))))) 141 | process-entry (fn [bvec b] (pb bvec (first b) (second b)))] 142 | (if (every? core/symbol? (map first bents)) 143 | bindings 144 | (if-let [kwbs (seq (filter #(core/keyword? (first %)) bents))] 145 | (throw (new Exception (core/str "Unsupported binding key: " (ffirst kwbs)))) 146 | (reduce process-entry [] bents))))) 147 | 148 | (defmacro let 149 | "binding => binding-form init-expr 150 | 151 | Evaluates the exprs in a lexical context in which the symbols in 152 | the binding-forms are bound to their respective init-exprs or parts 153 | therein." 154 | [bindings & body] 155 | (assert-args 156 | (vector? bindings) "a vector for its binding" 157 | (even? (count bindings)) "an even number of forms in binding vector") 158 | `(let* ~(destructure bindings) ~@body)) 159 | 160 | (defmacro loop 161 | "Evaluates the exprs in a lexical context in which the symbols in 162 | the binding-forms are bound to their respective init-exprs or parts 163 | therein. Acts as a recur target." 164 | [bindings & body] 165 | (assert-args 166 | (vector? bindings) "a vector for its binding" 167 | (even? (count bindings)) "an even number of forms in binding vector") 168 | (let [db (destructure bindings)] 169 | (if (= db bindings) 170 | `(loop* ~bindings ~@body) 171 | (let [vs (take-nth 2 (drop 1 bindings)) 172 | bs (take-nth 2 bindings) 173 | gs (map (fn [b] (if (core/symbol? b) b (gensym))) bs) 174 | bfs (reduce (fn [ret [b v g]] 175 | (if (core/symbol? b) 176 | (conj ret g v) 177 | (conj ret g v b g))) 178 | [] (map core/vector bs vs gs))] 179 | `(let ~bfs 180 | (loop* ~(vec (interleave gs gs)) 181 | (let ~(vec (interleave bs gs)) 182 | ~@body))))))) 183 | 184 | (def fast-path-protocols 185 | "protocol fqn -> [partition number, bit]" 186 | (zipmap (map #(symbol "cljs.core" (core/str %)) 187 | '[IFn ICounted IEmptyableCollection ICollection IIndexed ASeq ISeq INext 188 | ILookup IAssociative IMap IMapEntry ISet IStack IVector IDeref 189 | IDerefWithTimeout IMeta IWithMeta IReduce IKVReduce IEquiv IHash 190 | ISeqable ISequential IList IRecord IReversible ISorted IPrintWithWriter IWriter 191 | IPrintWithWriter IPending IWatchable IEditableCollection ITransientCollection 192 | ITransientAssociative ITransientMap ITransientVector ITransientSet 193 | IMultiFn IChunkedSeq IChunkedNext IComparable INamed ICloneable IAtom 194 | IReset ISwap]) 195 | (iterate (fn [[p b]] 196 | (if (core/== 2147483648 b) 197 | [(core/inc p) 1] 198 | [p (core/bit-shift-left b 1)])) 199 | [0 1]))) 200 | 201 | (def fast-path-protocol-partitions-count 202 | "total number of partitions" 203 | (let [c (count fast-path-protocols) 204 | m (core/mod c 32)] 205 | (if (core/zero? m) 206 | (core/quot c 32) 207 | (core/inc (core/quot c 32))))) 208 | 209 | (defmacro str [& xs] 210 | (let [strs (->> (repeat (count xs) "cljs.core.str(~{})") 211 | (interpose ",") 212 | (apply core/str))] 213 | (list* 'js* (core/str "[" strs "].join('')") xs))) 214 | 215 | (defn bool-expr [e] 216 | (vary-meta e assoc :tag 'boolean)) 217 | 218 | (defn simple-test-expr? [env ast] 219 | (core/and 220 | (#{:var :invoke :const :host-field :host-call :js} (:op ast)) 221 | ('#{boolean seq} (:tag ast)))) 222 | 223 | (defmacro and 224 | "Evaluates exprs one at a time, from left to right. If a form 225 | returns logical false (nil or false), and returns that value and 226 | doesn't evaluate any of the other expressions, otherwise it returns 227 | the value of the last expr. (and) returns true." 228 | ([] true) 229 | ([x] x) 230 | ([x & next] 231 | (let [forms (concat [x] next)] 232 | (if (every? #(simple-test-expr? &env %) 233 | (map #(clojure.tools.analyzer.js/analyze % &env) forms)) 234 | (let [and-str (->> (repeat (count forms) "(~{})") 235 | (interpose " && ") 236 | (apply core/str))] 237 | (bool-expr `(~'js* ~and-str ~@forms))) 238 | `(let [and# ~x] 239 | (if and# (and ~@next) and#)))))) 240 | 241 | (defmacro or 242 | "Evaluates exprs one at a time, from left to right. If a form 243 | returns a logical true value, or returns that value and doesn't 244 | evaluate any of the other expressions, otherwise it returns the 245 | value of the last expression. (or) returns nil." 246 | ([] nil) 247 | ([x] x) 248 | ([x & next] 249 | (let [forms (concat [x] next)] 250 | (if (every? #(simple-test-expr? &env %) 251 | (map #(clojure.tools.analyzer.js/analyze % &env) forms)) 252 | (let [or-str (->> (repeat (count forms) "(~{})") 253 | (interpose " || ") 254 | (apply core/str))] 255 | (bool-expr `(~'js* ~or-str ~@forms))) 256 | `(let [or# ~x] 257 | (if or# or# (or ~@next))))))) 258 | 259 | (defmacro nil? [x] 260 | `(coercive-= ~x nil)) 261 | 262 | ;; internal - do not use. 263 | (defmacro coercive-not [x] 264 | (bool-expr (core/list 'js* "(!~{})" x))) 265 | 266 | ;; internal - do not use. 267 | (defmacro coercive-not= [x y] 268 | (bool-expr (core/list 'js* "(~{} != ~{})" x y))) 269 | 270 | ;; internal - do not use. 271 | (defmacro coercive-= [x y] 272 | (bool-expr (core/list 'js* "(~{} == ~{})" x y))) 273 | 274 | ;; internal - do not use. 275 | (defmacro coercive-boolean [x] 276 | (with-meta (core/list 'js* "~{}" x) 277 | {:tag 'boolean})) 278 | 279 | ;; internal - do not use. 280 | (defmacro truth_ [x] 281 | (assert (clojure.core/symbol? x) "x is substituted twice") 282 | (core/list 'js* "(~{} != null && ~{} !== false)" x x)) 283 | 284 | ;; internal - do not use 285 | (defmacro js-arguments [] 286 | (core/list 'js* "arguments")) 287 | 288 | (defmacro js-delete [obj key] 289 | (core/list 'js* "delete ~{}[~{}]" obj key)) 290 | 291 | (defmacro js-in [key obj] 292 | (core/list 'js* "~{} in ~{}" key obj)) 293 | 294 | (defmacro true? [x] 295 | (bool-expr (core/list 'js* "~{} === true" x))) 296 | 297 | (defmacro false? [x] 298 | (bool-expr (core/list 'js* "~{} === false" x))) 299 | 300 | (defmacro array? [x] 301 | (if (= :nodejs (:target (env/deref-env))) 302 | (bool-expr `(.isArray js/Array ~x)) 303 | (bool-expr (core/list 'js* "~{} instanceof Array" x)))) 304 | 305 | (defmacro string? [x] 306 | (bool-expr (core/list 'js* "typeof ~{} === 'string'" x))) 307 | 308 | ;; TODO: x must be a symbol, not an arbitrary expression 309 | (defmacro exists? [x] 310 | (bool-expr 311 | (core/list 'js* "typeof ~{} !== 'undefined'" 312 | (vary-meta x assoc :analyzer/allow-undefined true)))) 313 | 314 | (defmacro undefined? [x] 315 | (bool-expr (core/list 'js* "(void 0 === ~{})" x))) 316 | 317 | (defmacro identical? [a b] 318 | (bool-expr (core/list 'js* "(~{} === ~{})" a b))) 319 | 320 | (defmacro instance? [t o] 321 | ;; Google Closure warns about some references to RegExp, so 322 | ;; (instance? RegExp ...) needs to be inlined, but the expansion 323 | ;; should preserve the order of argument evaluation. 324 | (bool-expr (if (clojure.core/symbol? t) 325 | (core/list 'js* "(~{} instanceof ~{})" o t) 326 | `(let [t# ~t o# ~o] 327 | (~'js* "(~{} instanceof ~{})" o# t#))))) 328 | 329 | (defmacro number? [x] 330 | (bool-expr (core/list 'js* "typeof ~{} === 'number'" x))) 331 | 332 | (defmacro symbol? [x] 333 | (bool-expr `(instance? Symbol ~x))) 334 | 335 | (defmacro keyword? [x] 336 | (bool-expr `(instance? Keyword ~x))) 337 | 338 | (defmacro aget 339 | ([a i] 340 | (core/list 'js* "(~{}[~{}])" a i)) 341 | ([a i & idxs] 342 | (let [astr (apply core/str (repeat (count idxs) "[~{}]"))] 343 | `(~'js* ~(core/str "(~{}[~{}]" astr ")") ~a ~i ~@idxs)))) 344 | 345 | (defmacro aset 346 | ([a i v] 347 | (core/list 'js* "(~{}[~{}] = ~{})" a i v)) 348 | ([a idx idx2 & idxv] 349 | (let [n (core/dec (count idxv)) 350 | astr (apply core/str (repeat n "[~{}]"))] 351 | `(~'js* ~(core/str "(~{}[~{}][~{}]" astr " = ~{})") ~a ~idx ~idx2 ~@idxv)))) 352 | 353 | (defmacro ^::ana/numeric + 354 | ([] 0) 355 | ([x] x) 356 | ([x y] (core/list 'js* "(~{} + ~{})" x y)) 357 | ([x y & more] `(+ (+ ~x ~y) ~@more))) 358 | 359 | (defmacro byte [x] x) 360 | (defmacro short [x] x) 361 | (defmacro float [x] x) 362 | (defmacro double [x] x) 363 | 364 | (defmacro unchecked-byte [x] x) 365 | (defmacro unchecked-char [x] x) 366 | (defmacro unchecked-short [x] x) 367 | (defmacro unchecked-float [x] x) 368 | (defmacro unchecked-double [x] x) 369 | 370 | (defmacro ^::ana/numeric unchecked-add 371 | ([& xs] `(+ ~@xs))) 372 | 373 | (defmacro ^::ana/numeric unchecked-add-int 374 | ([& xs] `(+ ~@xs))) 375 | 376 | (defmacro ^::ana/numeric unchecked-dec 377 | ([x] `(dec ~x))) 378 | 379 | (defmacro ^::ana/numeric unchecked-dec-int 380 | ([x] `(dec ~x))) 381 | 382 | (defmacro ^::ana/numeric unchecked-divide-int 383 | ([& xs] `(/ ~@xs))) 384 | 385 | (defmacro ^::ana/numeric unchecked-inc 386 | ([x] `(inc ~x))) 387 | 388 | (defmacro ^::ana/numeric unchecked-inc-int 389 | ([x] `(inc ~x))) 390 | 391 | (defmacro ^::ana/numeric unchecked-multiply 392 | ([& xs] `(* ~@xs))) 393 | 394 | (defmacro ^::ana/numeric unchecked-multiply-int 395 | ([& xs] `(* ~@xs))) 396 | 397 | (defmacro ^::ana/numeric unchecked-negate 398 | ([x] `(- ~x))) 399 | 400 | (defmacro ^::ana/numeric unchecked-negate-int 401 | ([x] `(- ~x))) 402 | 403 | (defmacro ^::ana/numeric unchecked-remainder-int 404 | ([x n] `(mod ~x ~n))) 405 | 406 | (defmacro ^::ana/numeric unchecked-subtract 407 | ([& xs] `(- ~@xs))) 408 | 409 | (defmacro ^::ana/numeric unchecked-subtract-int 410 | ([& xs] `(- ~@xs))) 411 | 412 | (defmacro ^::ana/numeric - 413 | ([x] (core/list 'js* "(- ~{})" x)) 414 | ([x y] (core/list 'js* "(~{} - ~{})" x y)) 415 | ([x y & more] `(- (- ~x ~y) ~@more))) 416 | 417 | (defmacro ^::ana/numeric * 418 | ([] 1) 419 | ([x] x) 420 | ([x y] (core/list 'js* "(~{} * ~{})" x y)) 421 | ([x y & more] `(* (* ~x ~y) ~@more))) 422 | 423 | (defmacro ^::ana/numeric / 424 | ([x] `(/ 1 ~x)) 425 | ([x y] (core/list 'js* "(~{} / ~{})" x y)) 426 | ([x y & more] `(/ (/ ~x ~y) ~@more))) 427 | 428 | (defmacro ^::ana/numeric divide 429 | ([x] `(/ 1 ~x)) 430 | ([x y] (core/list 'js* "(~{} / ~{})" x y)) 431 | ([x y & more] `(/ (/ ~x ~y) ~@more))) 432 | 433 | (defmacro ^::ana/numeric < 434 | ([x] true) 435 | ([x y] (bool-expr (core/list 'js* "(~{} < ~{})" x y))) 436 | ([x y & more] `(and (< ~x ~y) (< ~y ~@more)))) 437 | 438 | (defmacro ^::ana/numeric <= 439 | ([x] true) 440 | ([x y] (bool-expr (core/list 'js* "(~{} <= ~{})" x y))) 441 | ([x y & more] `(and (<= ~x ~y) (<= ~y ~@more)))) 442 | 443 | (defmacro ^::ana/numeric > 444 | ([x] true) 445 | ([x y] (bool-expr (core/list 'js* "(~{} > ~{})" x y))) 446 | ([x y & more] `(and (> ~x ~y) (> ~y ~@more)))) 447 | 448 | (defmacro ^::ana/numeric >= 449 | ([x] true) 450 | ([x y] (bool-expr (core/list 'js* "(~{} >= ~{})" x y))) 451 | ([x y & more] `(and (>= ~x ~y) (>= ~y ~@more)))) 452 | 453 | (defmacro ^::ana/numeric == 454 | ([x] true) 455 | ([x y] (bool-expr (core/list 'js* "(~{} === ~{})" x y))) 456 | ([x y & more] `(and (== ~x ~y) (== ~y ~@more)))) 457 | 458 | (defmacro ^::ana/numeric dec [x] 459 | `(- ~x 1)) 460 | 461 | (defmacro ^::ana/numeric inc [x] 462 | `(+ ~x 1)) 463 | 464 | (defmacro ^::ana/numeric zero? [x] 465 | `(== ~x 0)) 466 | 467 | (defmacro ^::ana/numeric pos? [x] 468 | `(> ~x 0)) 469 | 470 | (defmacro ^::ana/numeric neg? [x] 471 | `(< ~x 0)) 472 | 473 | (defmacro ^::ana/numeric max 474 | ([x] x) 475 | ([x y] `(let [x# ~x, y# ~y] 476 | (~'js* "((~{} > ~{}) ? ~{} : ~{})" x# y# x# y#))) 477 | ([x y & more] `(max (max ~x ~y) ~@more))) 478 | 479 | (defmacro ^::ana/numeric min 480 | ([x] x) 481 | ([x y] `(let [x# ~x, y# ~y] 482 | (~'js* "((~{} < ~{}) ? ~{} : ~{})" x# y# x# y#))) 483 | ([x y & more] `(min (min ~x ~y) ~@more))) 484 | 485 | (defmacro ^::ana/numeric js-mod [num div] 486 | (core/list 'js* "(~{} % ~{})" num div)) 487 | 488 | (defmacro ^::ana/numeric bit-not [x] 489 | (core/list 'js* "(~ ~{})" x)) 490 | 491 | (defmacro ^::ana/numeric bit-and 492 | ([x y] (core/list 'js* "(~{} & ~{})" x y)) 493 | ([x y & more] `(bit-and (bit-and ~x ~y) ~@more))) 494 | 495 | ;; internal do not use 496 | (defmacro ^::ana/numeric unsafe-bit-and 497 | ([x y] (bool-expr (core/list 'js* "(~{} & ~{})" x y))) 498 | ([x y & more] `(unsafe-bit-and (unsafe-bit-and ~x ~y) ~@more))) 499 | 500 | (defmacro ^::ana/numeric bit-or 501 | ([x y] (core/list 'js* "(~{} | ~{})" x y)) 502 | ([x y & more] `(bit-or (bit-or ~x ~y) ~@more))) 503 | 504 | (defmacro ^::ana/numeric int [x] 505 | `(bit-or ~x 0)) 506 | 507 | (defmacro ^::ana/numeric bit-xor 508 | ([x y] (core/list 'js* "(~{} ^ ~{})" x y)) 509 | ([x y & more] `(bit-xor (bit-xor ~x ~y) ~@more))) 510 | 511 | (defmacro ^::ana/numeric bit-and-not 512 | ([x y] (core/list 'js* "(~{} & ~~{})" x y)) 513 | ([x y & more] `(bit-and-not (bit-and-not ~x ~y) ~@more))) 514 | 515 | (defmacro ^::ana/numeric bit-clear [x n] 516 | (core/list 'js* "(~{} & ~(1 << ~{}))" x n)) 517 | 518 | (defmacro ^::ana/numeric bit-flip [x n] 519 | (core/list 'js* "(~{} ^ (1 << ~{}))" x n)) 520 | 521 | (defmacro ^::ana/numeric bit-test [x n] 522 | (core/list 'js* "((~{} & (1 << ~{})) != 0)" x n)) 523 | 524 | (defmacro ^::ana/numeric bit-shift-left [x n] 525 | (core/list 'js* "(~{} << ~{})" x n)) 526 | 527 | (defmacro ^::ana/numeric bit-shift-right [x n] 528 | (core/list 'js* "(~{} >> ~{})" x n)) 529 | 530 | (defmacro ^::ana/numeric bit-shift-right-zero-fill [x n] 531 | (core/list 'js* "(~{} >>> ~{})" x n)) 532 | 533 | (defmacro ^::ana/numeric unsigned-bit-shift-right [x n] 534 | (core/list 'js* "(~{} >>> ~{})" x n)) 535 | 536 | (defmacro ^::ana/numeric bit-set [x n] 537 | (core/list 'js* "(~{} | (1 << ~{}))" x n)) 538 | 539 | ;; internal 540 | (defmacro mask [hash shift] 541 | (core/list 'js* "((~{} >>> ~{}) & 0x01f)" hash shift)) 542 | 543 | ;; internal 544 | (defmacro bitpos [hash shift] 545 | (core/list 'js* "(1 << ~{})" `(mask ~hash ~shift))) 546 | 547 | ;; internal 548 | (defmacro caching-hash [coll hash-fn hash-key] 549 | (assert (clojure.core/symbol? hash-key) "hash-key is substituted twice") 550 | `(let [h# ~hash-key] 551 | (if-not (nil? h#) 552 | h# 553 | (let [h# (~hash-fn ~coll)] 554 | (set! ~hash-key h#) 555 | h#)))) 556 | 557 | ;;; internal -- reducers-related macros 558 | 559 | (defn- do-curried 560 | [name doc meta args body] 561 | (let [cargs (vec (butlast args))] 562 | `(defn ~name ~doc ~meta 563 | (~cargs (fn [x#] (~name ~@cargs x#))) 564 | (~args ~@body)))) 565 | 566 | (defmacro ^:private defcurried 567 | "Builds another arity of the fn that returns a fn awaiting the last 568 | param" 569 | [name doc meta args & body] 570 | (do-curried name doc meta args body)) 571 | 572 | (defn- do-rfn [f1 k fkv] 573 | `(fn 574 | ([] (~f1)) 575 | ~(clojure.walk/postwalk 576 | #(if (sequential? %) 577 | ((if (vector? %) vec identity) 578 | (core/remove #{k} %)) 579 | %) 580 | fkv) 581 | ~fkv)) 582 | 583 | (defmacro ^:private rfn 584 | "Builds 3-arity reducing fn given names of wrapped fn and key, and k/v impl." 585 | [[f1 k] fkv] 586 | (do-rfn f1 k fkv)) 587 | 588 | ;;; end of reducers macros 589 | 590 | (defn protocol-prefix [psym] 591 | (core/str (-> (core/str psym) (.replace \. \$) (.replace \/ \$)) "$")) 592 | 593 | (def #^:private base-type 594 | {nil "null" 595 | 'object "object" 596 | 'string "string" 597 | 'number "number" 598 | 'array "array" 599 | 'function "function" 600 | 'boolean "boolean" 601 | 'default "_"}) 602 | 603 | (def #^:private js-base-type 604 | {'js/Boolean "boolean" 605 | 'js/String "string" 606 | 'js/Array "array" 607 | 'js/Object "object" 608 | 'js/Number "number" 609 | 'js/Function "function"}) 610 | 611 | (defmacro reify [& impls] 612 | (let [t (with-meta (gensym "t") {:anonymous true}) 613 | meta-sym (gensym "meta") 614 | this-sym (gensym "_") 615 | locals (keys (:locals &env)) 616 | ns (-> &env :ns) 617 | munge cljs.compiler/munge] 618 | `(do 619 | (when-not (exists? ~(symbol (core/str ns) (core/str t))) 620 | (deftype ~t [~@locals ~meta-sym] 621 | IWithMeta 622 | (~'-with-meta [~this-sym ~meta-sym] 623 | (new ~t ~@locals ~meta-sym)) 624 | IMeta 625 | (~'-meta [~this-sym] ~meta-sym) 626 | ~@impls)) 627 | (new ~t ~@locals ~(meta &form))))) 628 | 629 | (defmacro specify! [expr & impls] 630 | (let [x (with-meta (gensym "x") {:extend :instance})] 631 | `(let [~x ~expr] 632 | (extend-type ~x ~@impls) 633 | ~x))) 634 | 635 | (defmacro specify [expr & impls] 636 | `(cljs.core/specify! (cljs.core/clone ~expr) 637 | ~@impls)) 638 | 639 | (defmacro ^:private js-this [] 640 | (core/list 'js* "this")) 641 | 642 | (defmacro this-as 643 | "Defines a scope where JavaScript's implicit \"this\" is bound to the name provided." 644 | [name & body] 645 | `(let [~name (js-this)] 646 | ~@body)) 647 | 648 | (defn to-property [sym] 649 | (symbol (core/str "-" sym))) 650 | 651 | (defn resolved-name [{:keys [ns] :as env} sym] 652 | (let [sym-ns (namespace sym) 653 | sym-ns (if (= "clojure.tools.analyzer.js.cljs.core" sym-ns) 654 | "cljs.core" 655 | sym-ns)] 656 | (cond 657 | (= 'Object sym) 658 | 'Object 659 | 660 | (= "js" sym-ns) 661 | (symbol (name sym)) 662 | 663 | sym-ns 664 | (symbol (core/str (utils/resolve-ns (symbol sym-ns) env)) (name sym)) 665 | 666 | :else 667 | (symbol (core/str ns) (name sym))))) 668 | 669 | (def resolve-var resolved-name) 670 | 671 | ;; TODO 672 | (defn warn-and-update-protocol [p type env] 673 | (when-not (= 'Object p) 674 | (if-let [var (utils/resolve-sym p (dissoc env :locals))] 675 | (do 676 | #_(when-not (:protocol-symbol var) 677 | (cljs.analyzer/warning :invalid-protocol-symbol env {:protocol p})) 678 | #_(when (core/and (:protocol-deprecated cljs.analyzer/*cljs-warnings*) 679 | (-> var :deprecated) 680 | (not (-> p meta :deprecation-nowarn))) 681 | (cljs.analyzer/warning :protocol-deprecated env {:protocol p})) 682 | (swap! env/*env* update-in [:namespaces (:ns var) :mappings (symbol (name p))] 683 | vary-meta update-in [:impls] conj type)) 684 | #_(when (:undeclared cljs.analyzer/*cljs-warnings*) 685 | (cljs.analyzer/warning :undeclared-protocol-symbol env {:protocol p}))))) 686 | 687 | (defn ->impl-map [impls] 688 | (loop [ret {} s impls] 689 | (if (seq s) 690 | (recur (assoc ret (first s) (take-while seq? (next s))) 691 | (drop-while seq? (next s))) 692 | ret))) 693 | 694 | (defn base-assign-impls [env resolve tsym type [p sigs]] 695 | (warn-and-update-protocol p tsym env) 696 | (let [psym (resolve p) 697 | pfn-prefix (subs (core/str psym) 0 698 | (clojure.core/inc (.indexOf (core/str psym) "/")))] 699 | (cons `(aset ~psym ~type true) 700 | (map (fn [[f & meths :as form]] 701 | `(aset ~(symbol (core/str pfn-prefix f)) 702 | ~type ~(with-meta `(fn ~@meths) (meta form)))) 703 | sigs)))) 704 | 705 | (core/defmulti extend-prefix (fn [tsym sym] (-> tsym meta :extend))) 706 | 707 | (core/defmethod extend-prefix :instance 708 | [tsym sym] `(.. ~tsym ~(to-property sym))) 709 | 710 | (core/defmethod extend-prefix :default 711 | [tsym sym] `(.. ~tsym -prototype ~(to-property sym))) 712 | 713 | (defn adapt-obj-params [type [[this & args :as sig] & body]] 714 | (core/list (vec args) 715 | (list* 'this-as (vary-meta this assoc :tag type) body))) 716 | 717 | (defn adapt-ifn-params [type [[this & args :as sig] & body]] 718 | (let [self-sym (with-meta 'self__ {:tag type})] 719 | `(~(vec (cons self-sym args)) 720 | (this-as ~self-sym 721 | (let [~this ~self-sym] 722 | ~@body))))) 723 | 724 | ;; for IFn invoke implementations, we need to drop first arg 725 | (defn adapt-ifn-invoke-params [type [[this & args :as sig] & body]] 726 | `(~(vec args) 727 | (this-as ~(vary-meta this assoc :tag type) 728 | ~@body))) 729 | 730 | (defn adapt-proto-params [type [[this & args :as sig] & body]] 731 | `(~(vec (cons (vary-meta this assoc :tag type) args)) 732 | (this-as ~this 733 | ~@body))) 734 | 735 | (defn add-obj-methods [type type-sym sigs] 736 | (map (fn [[f & meths :as form]] 737 | `(set! ~(extend-prefix type-sym f) 738 | ~(with-meta `(fn ~@(map #(adapt-obj-params type %) meths)) (meta form)))) 739 | sigs)) 740 | 741 | (defn ifn-invoke-methods [type type-sym [f & meths :as form]] 742 | (map 743 | (fn [meth] 744 | (let [arity (count (first meth))] 745 | `(set! ~(extend-prefix type-sym (symbol (core/str "cljs$core$IFn$_invoke$arity$" arity))) 746 | ~(with-meta `(fn ~meth) (meta form))))) 747 | (map #(adapt-ifn-invoke-params type %) meths))) 748 | 749 | (defn add-ifn-methods [type type-sym [f & meths :as form]] 750 | (let [meths (map #(adapt-ifn-params type %) meths) 751 | this-sym (with-meta 'self__ {:tag type}) 752 | argsym (gensym "args")] 753 | (concat 754 | [`(set! ~(extend-prefix type-sym 'call) ~(with-meta `(fn ~@meths) (meta form))) 755 | `(set! ~(extend-prefix type-sym 'apply) 756 | ~(with-meta 757 | `(fn ~[this-sym argsym] 758 | (this-as ~this-sym 759 | (.apply (.-call ~this-sym) ~this-sym 760 | (.concat (array ~this-sym) (aclone ~argsym))))) 761 | (meta form)))] 762 | (ifn-invoke-methods type type-sym form)))) 763 | 764 | (defn add-proto-methods* [pprefix type type-sym [f & meths :as form]] 765 | (let [pf (core/str pprefix f)] 766 | (if (vector? (first meths)) 767 | ;; single method case 768 | (let [meth meths] 769 | [`(set! ~(extend-prefix type-sym (core/str pf "$arity$" (count (first meth)))) 770 | ~(with-meta `(fn ~@(adapt-proto-params type meth)) (meta form)))]) 771 | (map (fn [[sig & body :as meth]] 772 | `(set! ~(extend-prefix type-sym (core/str pf "$arity$" (count sig))) 773 | ~(with-meta `(fn ~(adapt-proto-params type meth)) (meta form)))) 774 | meths)))) 775 | 776 | (defn proto-assign-impls [env resolve type-sym type [p sigs]] 777 | (warn-and-update-protocol p type env) 778 | (let [psym (resolve p) 779 | pprefix (protocol-prefix psym) 780 | skip-flag (set (-> type-sym meta :skip-protocol-flag))] 781 | (if (= p 'Object) 782 | (add-obj-methods type type-sym sigs) 783 | (concat 784 | (when-not (skip-flag psym) 785 | [`(set! ~(extend-prefix type-sym pprefix) true)]) 786 | (mapcat 787 | (fn [sig] 788 | (if (= psym 'cljs.core/IFn) 789 | (add-ifn-methods type type-sym sig) 790 | (add-proto-methods* pprefix type type-sym sig))) 791 | sigs))))) 792 | 793 | ;; TODO 794 | #_(defn validate-impl-sigs [env p method] 795 | (when-not (= p 'Object) 796 | (let [var (ana/resolve-var (dissoc env :locals) p) 797 | minfo (-> var :protocol-info :methods) 798 | [fname sigs] (if (core/vector? (second method)) 799 | [(first method) [(second method)]] 800 | [(first method) (map first (rest method))]) 801 | decmeths (core/get minfo fname ::not-found)] 802 | (when (= decmeths ::not-found) 803 | (ana/warning :protocol-invalid-method env {:protocol p :fname fname :no-such-method true})) 804 | (loop [sigs sigs seen #{}] 805 | (when (seq sigs) 806 | (let [sig (first sigs) 807 | c (count sig)] 808 | (when (contains? seen c) 809 | (ana/warning :protocol-duped-method env {:protocol p :fname fname})) 810 | (when (core/and (not= decmeths ::not-found) (not (some #{c} (map count decmeths)))) 811 | (ana/warning :protocol-invalid-method env {:protocol p :fname fname :invalid-arity c})) 812 | (recur (next sigs) (conj seen c)))))))) 813 | 814 | #_(defn validate-impls [env impls] 815 | (loop [protos #{} impls impls] 816 | (when (seq impls) 817 | (let [proto (first impls) 818 | methods (take-while seq? (next impls)) 819 | impls (drop-while seq? (next impls))] 820 | (when (contains? protos proto) 821 | (ana/warning :protocol-multiple-impls env {:protocol proto})) 822 | (core/doseq [method methods] 823 | (validate-impl-sigs env proto method)) 824 | (recur (conj protos proto) impls))))) 825 | 826 | (defmacro extend-type [type-sym & impls] 827 | (let [env &env 828 | #_[_ (validate-impls env impls)] 829 | resolve (partial resolve-var env) 830 | impl-map (->impl-map impls) 831 | [type assign-impls] (if-let [type (base-type type-sym)] 832 | [type base-assign-impls] 833 | [(resolve type-sym) proto-assign-impls])] 834 | #_(when (core/and (:extending-base-js-type cljs.analyzer/*cljs-warnings*) 835 | (js-base-type type-sym)) 836 | (cljs.analyzer/warning :extending-base-js-type env 837 | {:current-symbol type-sym :suggested-symbol (js-base-type type-sym)})) 838 | `(do ~@(mapcat #(assign-impls env resolve type-sym type %) impl-map)))) 839 | 840 | (defn- prepare-protocol-masks [env impls] 841 | (let [resolve (partial resolve-var env) 842 | impl-map (->impl-map impls) 843 | fpp-pbs (seq 844 | (keep fast-path-protocols 845 | (map resolve 846 | (keys impl-map))))] 847 | (if fpp-pbs 848 | (let [fpps (into #{} 849 | (filter (partial contains? fast-path-protocols) 850 | (map resolve (keys impl-map)))) 851 | parts (as-> (group-by first fpp-pbs) parts 852 | (into {} 853 | (map (juxt key (comp (partial map peek) val)) 854 | parts)) 855 | (into {} 856 | (map (juxt key (comp (partial reduce core/bit-or) val)) 857 | parts)))] 858 | [fpps (reduce (fn [ps p] (update-in ps [p] (fnil identity 0))) 859 | parts 860 | (range fast-path-protocol-partitions-count))])))) 861 | 862 | (defn annotate-specs [annots v [f sigs]] 863 | (conj v 864 | (vary-meta (cons f (map #(cons (second %) (nnext %)) sigs)) 865 | merge annots))) 866 | 867 | (defn dt->et 868 | ([type specs fields] 869 | (dt->et type specs fields false)) 870 | ([type specs fields inline] 871 | (let [annots {:cljs.analyzer/type type 872 | :cljs.analyzer/protocol-impl true 873 | :cljs.analyzer/protocol-inline inline}] 874 | (loop [ret [] specs specs] 875 | (if (seq specs) 876 | (let [p (first specs) 877 | ret (-> (conj ret p) 878 | (into (reduce (partial annotate-specs annots) [] 879 | (group-by first (take-while seq? (next specs)))))) 880 | specs (drop-while seq? (next specs))] 881 | (recur ret specs)) 882 | ret))))) 883 | 884 | (defn collect-protocols [impls env] 885 | (->> impls 886 | (filter core/symbol?) 887 | (map (partial resolved-name env)) 888 | (into #{}))) 889 | 890 | (defn- build-positional-factory 891 | [rsym rname fields] 892 | (let [fn-name (with-meta (symbol (core/str '-> rsym)) 893 | (assoc (meta rsym) :factory :positional))] 894 | `(defn ~fn-name 895 | [~@fields] 896 | (new ~rname ~@fields)))) 897 | 898 | (defmacro deftype [t fields & impls] 899 | (let [env &env 900 | r (resolved-name &env t) 901 | [fpps pmasks] (prepare-protocol-masks env impls) 902 | protocols (collect-protocols impls env) 903 | t (vary-meta t assoc 904 | :protocols protocols 905 | :skip-protocol-flag fpps) ] 906 | `(do 907 | (deftype* ~t ~fields ~pmasks 908 | ~(if (seq impls) 909 | `(extend-type ~t ~@(dt->et t impls fields)))) 910 | (set! (.-cljs$lang$type ~t) true) 911 | (set! (.-cljs$lang$ctorStr ~t) ~(core/str r)) 912 | (set! (.-cljs$lang$ctorPrWriter ~t) (fn [this# writer# opt#] (-write writer# ~(core/str r)))) 913 | 914 | ~(build-positional-factory t r fields) 915 | ~t))) 916 | 917 | (defn- emit-defrecord 918 | "Do not use this directly - use defrecord" 919 | [env tagname rname fields impls] 920 | (let [hinted-fields fields 921 | fields (vec (map #(with-meta % nil) fields)) 922 | base-fields fields 923 | pr-open (core/str "#" (.getNamespace rname) "." (.getName rname) "{") 924 | fields (conj fields '__meta '__extmap (with-meta '__hash {:mutable true}))] 925 | (let [gs (gensym) 926 | ksym (gensym "k") 927 | impls (concat 928 | impls 929 | ['IRecord 930 | 'ICloneable 931 | `(~'-clone [this#] (new ~tagname ~@fields)) 932 | 'IHash 933 | `(~'-hash [this#] (caching-hash this# ~'hash-imap ~'__hash)) 934 | 'IEquiv 935 | `(~'-equiv [this# other#] 936 | (if (and other# 937 | (identical? (.-constructor this#) 938 | (.-constructor other#)) 939 | (equiv-map this# other#)) 940 | true 941 | false)) 942 | 'IMeta 943 | `(~'-meta [this#] ~'__meta) 944 | 'IWithMeta 945 | `(~'-with-meta [this# ~gs] (new ~tagname ~@(replace {'__meta gs} fields))) 946 | 'ILookup 947 | `(~'-lookup [this# k#] (-lookup this# k# nil)) 948 | `(~'-lookup [this# ~ksym else#] 949 | (case ~ksym 950 | ~@(mapcat (fn [f] [(keyword f) f]) base-fields) 951 | (get ~'__extmap ~ksym else#))) 952 | 'ICounted 953 | `(~'-count [this#] (+ ~(count base-fields) (count ~'__extmap))) 954 | 'ICollection 955 | `(~'-conj [this# entry#] 956 | (if (vector? entry#) 957 | (-assoc this# (-nth entry# 0) (-nth entry# 1)) 958 | (reduce -conj 959 | this# 960 | entry#))) 961 | 'IAssociative 962 | `(~'-assoc [this# k# ~gs] 963 | (condp keyword-identical? k# 964 | ~@(mapcat (fn [fld] 965 | [(keyword fld) (list* `new tagname (replace {fld gs '__hash nil} fields))]) 966 | base-fields) 967 | (new ~tagname ~@(remove #{'__extmap '__hash} fields) (assoc ~'__extmap k# ~gs) nil))) 968 | 'IMap 969 | `(~'-dissoc [this# k#] (if (contains? #{~@(map keyword base-fields)} k#) 970 | (dissoc (with-meta (into {} this#) ~'__meta) k#) 971 | (new ~tagname ~@(remove #{'__extmap '__hash} fields) 972 | (not-empty (dissoc ~'__extmap k#)) 973 | nil))) 974 | 'ISeqable 975 | `(~'-seq [this#] (seq (concat [~@(map #(core/list `vector (keyword %) %) base-fields)] 976 | ~'__extmap))) 977 | 978 | 'IPrintWithWriter 979 | `(~'-pr-writer [this# writer# opts#] 980 | (let [pr-pair# (fn [keyval#] (pr-sequential-writer writer# pr-writer "" " " "" opts# keyval#))] 981 | (pr-sequential-writer 982 | writer# pr-pair# ~pr-open ", " "}" opts# 983 | (concat [~@(map #(core/list `vector (keyword %) %) base-fields)] 984 | ~'__extmap)))) 985 | ]) 986 | [fpps pmasks] (prepare-protocol-masks env impls) 987 | protocols (collect-protocols impls env) 988 | tagname (vary-meta tagname assoc 989 | :protocols protocols 990 | :skip-protocol-flag fpps)] 991 | `(do 992 | (~'defrecord* ~tagname ~hinted-fields ~pmasks 993 | (extend-type ~tagname ~@(dt->et tagname impls fields true))))))) 994 | 995 | (defn- build-map-factory [rsym rname fields] 996 | (let [fn-name (with-meta (symbol (core/str 'map-> rsym)) 997 | (assoc (meta rsym) :factory :map)) 998 | ms (gensym) 999 | ks (map keyword fields) 1000 | getters (map (fn [k] `(~k ~ms)) ks)] 1001 | `(defn ~fn-name [~ms] 1002 | (new ~rname ~@getters nil (dissoc ~ms ~@ks))))) 1003 | 1004 | (defmacro defrecord [rsym fields & impls] 1005 | (let [rsym (vary-meta rsym assoc :internal-ctor true) 1006 | r (vary-meta 1007 | (:name (cljs.analyzer/resolve-var (dissoc &env :locals) rsym)) 1008 | assoc :internal-ctor true)] 1009 | `(let [] 1010 | ~(emit-defrecord &env rsym r fields impls) 1011 | (set! (.-cljs$lang$type ~r) true) 1012 | (set! (.-cljs$lang$ctorPrSeq ~r) (fn [this#] (core/list ~(core/str r)))) 1013 | (set! (.-cljs$lang$ctorPrWriter ~r) (fn [this# writer#] (-write writer# ~(core/str r)))) 1014 | ~(build-positional-factory rsym r fields) 1015 | ~(build-map-factory rsym r fields) 1016 | ~r))) 1017 | 1018 | (defmacro defprotocol [psym & doc+methods] 1019 | (let [p (resolved-name &env psym) 1020 | psym (vary-meta psym assoc :protocol-symbol true) 1021 | ns-name (-> &env :ns name) 1022 | fqn (fn [n] (symbol ns-name (core/str n))) 1023 | prefix (protocol-prefix p) 1024 | methods (if (core/string? (first doc+methods)) (next doc+methods) doc+methods) 1025 | _ (core/doseq [[mname & arities] methods] 1026 | (when (some #{0} (map count arities)) 1027 | (throw (Exception. (core/str "Invalid protocol, " psym " defines method " mname " with arity 0"))))) 1028 | expand-sig (fn [fname slot sig] 1029 | `(~sig 1030 | (if (and ~(first sig) (. ~(first sig) ~(symbol (core/str "-" slot)))) ;; Property access needed here. 1031 | (. ~(first sig) ~slot ~@sig) 1032 | (let [x# (if (nil? ~(first sig)) nil ~(first sig))] 1033 | ((or 1034 | (aget ~(fqn fname) (goog/typeOf x#)) 1035 | (aget ~(fqn fname) "_") 1036 | (throw (missing-protocol 1037 | ~(core/str psym "." fname) ~(first sig)))) 1038 | ~@sig))))) 1039 | psym (vary-meta psym assoc-in [:protocol-info :methods] 1040 | (into {} 1041 | (map 1042 | (fn [[fname & sigs]] 1043 | (let [sigs (take-while vector? sigs)] 1044 | [fname (vec sigs)])) 1045 | methods))) 1046 | method (fn [[fname & sigs]] 1047 | (let [sigs (take-while vector? sigs) 1048 | slot (symbol (core/str prefix (name fname))) 1049 | fname (vary-meta fname assoc :protocol p)] 1050 | `(defn ~fname ~@(map (fn [sig] 1051 | (expand-sig fname 1052 | (symbol (core/str slot "$arity$" (count sig))) 1053 | sig)) 1054 | sigs))))] 1055 | `(do 1056 | (set! ~'*unchecked-if* true) 1057 | (def ~psym (js-obj)) 1058 | ~@(map method methods) 1059 | (set! ~'*unchecked-if* false)))) 1060 | 1061 | (defmacro implements? 1062 | "EXPERIMENTAL" 1063 | [psym x] 1064 | (let [p (resolved-name &env psym) 1065 | prefix (protocol-prefix p) 1066 | xsym (bool-expr (gensym)) 1067 | [part bit] (fast-path-protocols p) 1068 | msym (symbol 1069 | (core/str "-cljs$lang$protocol_mask$partition" part "$"))] 1070 | `(let [~xsym ~x] 1071 | (if ~xsym 1072 | (let [bit# ~(if bit `(unsafe-bit-and (. ~xsym ~msym) ~bit))] 1073 | (if (or bit# 1074 | ~(bool-expr `(. ~xsym ~(symbol (core/str "-" prefix))))) 1075 | true 1076 | false)) 1077 | false)))) 1078 | 1079 | (defmacro satisfies? 1080 | "Returns true if x satisfies the protocol" 1081 | [psym x] 1082 | (let [p (resolved-name &env psym) 1083 | prefix (protocol-prefix p) 1084 | xsym (bool-expr (gensym)) 1085 | [part bit] (fast-path-protocols p) 1086 | msym (symbol 1087 | (core/str "-cljs$lang$protocol_mask$partition" part "$"))] 1088 | `(let [~xsym ~x] 1089 | (if ~xsym 1090 | (let [bit# ~(if bit `(unsafe-bit-and (. ~xsym ~msym) ~bit))] 1091 | (if (or bit# 1092 | ~(bool-expr `(. ~xsym ~(symbol (core/str "-" prefix))))) 1093 | true 1094 | (if (coercive-not (. ~xsym ~msym)) 1095 | (cljs.core/native-satisfies? ~psym ~xsym) 1096 | false))) 1097 | (cljs.core/native-satisfies? ~psym ~xsym))))) 1098 | 1099 | (defmacro lazy-seq [& body] 1100 | `(new cljs.core/LazySeq nil (fn [] ~@body) nil nil)) 1101 | 1102 | (defmacro delay [& body] 1103 | "Takes a body of expressions and yields a Delay object that will 1104 | invoke the body only the first time it is forced (with force or deref/@), and 1105 | will cache the result and return it on all subsequent force 1106 | calls." 1107 | `(new cljs.core/Delay (fn [] ~@body) nil)) 1108 | 1109 | (defmacro with-redefs 1110 | "binding => var-symbol temp-value-expr 1111 | 1112 | Temporarily redefines vars while executing the body. The 1113 | temp-value-exprs will be evaluated and each resulting value will 1114 | replace in parallel the root value of its var. After the body is 1115 | executed, the root values of all the vars will be set back to their 1116 | old values. Useful for mocking out functions during testing." 1117 | [bindings & body] 1118 | (let [names (take-nth 2 bindings) 1119 | vals (take-nth 2 (drop 1 bindings)) 1120 | tempnames (map (comp gensym name) names) 1121 | binds (map core/vector names vals) 1122 | resets (reverse (map core/vector names tempnames)) 1123 | bind-value (fn [[k v]] (core/list 'set! k v))] 1124 | `(let [~@(interleave tempnames names)] 1125 | (try 1126 | ~@(map bind-value binds) 1127 | ~@body 1128 | (finally 1129 | ~@(map bind-value resets)))))) 1130 | 1131 | (defmacro binding 1132 | "binding => var-symbol init-expr 1133 | 1134 | Creates new bindings for the (already-existing) vars, with the 1135 | supplied initial values, executes the exprs in an implicit do, then 1136 | re-establishes the bindings that existed before. The new bindings 1137 | are made in parallel (unlike let); all init-exprs are evaluated 1138 | before the vars are bound to their new values." 1139 | [bindings & body] 1140 | (let [names (take-nth 2 bindings)] 1141 | #_(cljs.analyzer/confirm-bindings &env names) 1142 | `(with-redefs ~bindings ~@body))) 1143 | 1144 | (defmacro condp 1145 | "Takes a binary predicate, an expression, and a set of clauses. 1146 | Each clause can take the form of either: 1147 | 1148 | test-expr result-expr 1149 | 1150 | test-expr :>> result-fn 1151 | 1152 | Note :>> is an ordinary keyword. 1153 | 1154 | For each clause, (pred test-expr expr) is evaluated. If it returns 1155 | logical true, the clause is a match. If a binary clause matches, the 1156 | result-expr is returned, if a ternary clause matches, its result-fn, 1157 | which must be a unary function, is called with the result of the 1158 | predicate as its argument, the result of that call being the return 1159 | value of condp. A single default expression can follow the clauses, 1160 | and its value will be returned if no clause matches. If no default 1161 | expression is provided and no clause matches, an 1162 | IllegalArgumentException is thrown." 1163 | {:added "1.0"} 1164 | 1165 | [pred expr & clauses] 1166 | (let [gpred (gensym "pred__") 1167 | gexpr (gensym "expr__") 1168 | emit (fn emit [pred expr args] 1169 | (let [[[a b c :as clause] more] 1170 | (split-at (if (= :>> (second args)) 3 2) args) 1171 | n (count clause)] 1172 | (core/cond 1173 | (= 0 n) `(throw (js/Error. (core/str "No matching clause: " ~expr))) 1174 | (= 1 n) a 1175 | (= 2 n) `(if (~pred ~a ~expr) 1176 | ~b 1177 | ~(emit pred expr more)) 1178 | :else `(if-let [p# (~pred ~a ~expr)] 1179 | (~c p#) 1180 | ~(emit pred expr more))))) 1181 | gres (gensym "res__")] 1182 | `(let [~gpred ~pred 1183 | ~gexpr ~expr] 1184 | ~(emit gpred gexpr clauses)))) 1185 | 1186 | (defn- assoc-test [m test expr env] 1187 | (if (contains? m test) 1188 | (throw 1189 | (clojure.core/IllegalArgumentException. 1190 | (core/str "Duplicate case test constant '" 1191 | test "'" 1192 | (when (:line env) 1193 | (core/str " on line " (:line env) " " 1194 | #_cljs.analyzer/*cljs-file*))))) 1195 | (assoc m test expr))) 1196 | 1197 | (defmacro case [e & clauses] 1198 | (core/let [default (if (odd? (count clauses)) 1199 | (last clauses) 1200 | `(throw 1201 | (js/Error. 1202 | (core/str "No matching clause: " ~e)))) 1203 | env &env 1204 | pairs (reduce 1205 | (fn [m [test expr]] 1206 | (core/cond 1207 | (seq? test) 1208 | (reduce 1209 | (fn [m test] 1210 | (let [test (if (core/symbol? test) 1211 | (core/list 'quote test) 1212 | test)] 1213 | (assoc-test m test expr env))) 1214 | m test) 1215 | (core/symbol? test) 1216 | (assoc-test m (core/list 'quote test) expr env) 1217 | :else 1218 | (assoc-test m test expr env))) 1219 | {} (partition 2 clauses)) 1220 | esym (gensym) 1221 | tests (keys pairs)] 1222 | (cond 1223 | (every? (some-fn core/number? core/string? core/char?) tests) 1224 | (core/let [no-default (if (odd? (count clauses)) (butlast clauses) clauses) 1225 | tests (mapv #(if (seq? %) (vec %) [%]) (take-nth 2 no-default)) 1226 | thens (vec (take-nth 2 (drop 1 no-default)))] 1227 | `(let [~esym ~e] (case* ~esym ~tests ~thens ~default))) 1228 | 1229 | (every? core/keyword? tests) 1230 | (let [tests (->> tests 1231 | (map #(.substring (core/str %) 1)) 1232 | vec 1233 | (mapv #(if (seq? %) (vec %) [%]))) 1234 | thens (vec (vals pairs))] 1235 | `(let [~esym (if (keyword? ~e) (.-fqn ~e) nil)] 1236 | (case* ~esym ~tests ~thens ~default))) 1237 | 1238 | ;; equality 1239 | :else 1240 | `(let [~esym ~e] 1241 | (cond 1242 | ~@(mapcat (fn [[m c]] `((cljs.core/= ~m ~esym) ~c)) pairs) 1243 | :else ~default))))) 1244 | 1245 | (defmacro assert 1246 | "Evaluates expr and throws an exception if it does not evaluate to 1247 | logical true." 1248 | ([x] 1249 | (when *assert* 1250 | `(when-not ~x 1251 | (throw (js/Error. 1252 | (cljs.core/str "Assert failed: " (cljs.core/pr-str '~x))))))) 1253 | ([x message] 1254 | (when *assert* 1255 | `(when-not ~x 1256 | (throw (js/Error. 1257 | (cljs.core/str "Assert failed: " ~message "\n" (cljs.core/pr-str '~x)))))))) 1258 | 1259 | (defmacro for 1260 | "List comprehension. Takes a vector of one or more 1261 | binding-form/collection-expr pairs, each followed by zero or more 1262 | modifiers, and yields a lazy sequence of evaluations of expr. 1263 | Collections are iterated in a nested fashion, rightmost fastest, 1264 | and nested coll-exprs can refer to bindings created in prior 1265 | binding-forms. Supported modifiers are: :let [binding-form expr ...], 1266 | :while test, :when test. 1267 | 1268 | (take 100 (for [x (range 100000000) y (range 1000000) :while (< y x)] [x y]))" 1269 | [seq-exprs body-expr] 1270 | (assert-args for 1271 | (vector? seq-exprs) "a vector for its binding" 1272 | (even? (count seq-exprs)) "an even number of forms in binding vector") 1273 | (let [to-groups (fn [seq-exprs] 1274 | (reduce (fn [groups [k v]] 1275 | (if (core/keyword? k) 1276 | (conj (pop groups) (conj (peek groups) [k v])) 1277 | (conj groups [k v]))) 1278 | [] (partition 2 seq-exprs))) 1279 | err (fn [& msg] (throw (ex-info (apply core/str msg) {}))) 1280 | emit-bind (fn emit-bind [[[bind expr & mod-pairs] 1281 | & [[_ next-expr] :as next-groups]]] 1282 | (let [giter (gensym "iter__") 1283 | gxs (gensym "s__") 1284 | do-mod (fn do-mod [[[k v :as pair] & etc]] 1285 | (core/cond 1286 | (= k :let) `(let ~v ~(do-mod etc)) 1287 | (= k :while) `(when ~v ~(do-mod etc)) 1288 | (= k :when) `(if ~v 1289 | ~(do-mod etc) 1290 | (recur (rest ~gxs))) 1291 | (core/keyword? k) (err "Invalid 'for' keyword " k) 1292 | next-groups 1293 | `(let [iterys# ~(emit-bind next-groups) 1294 | fs# (seq (iterys# ~next-expr))] 1295 | (if fs# 1296 | (concat fs# (~giter (rest ~gxs))) 1297 | (recur (rest ~gxs)))) 1298 | :else `(cons ~body-expr 1299 | (~giter (rest ~gxs)))))] 1300 | (if next-groups 1301 | #_ "not the inner-most loop" 1302 | `(fn ~giter [~gxs] 1303 | (lazy-seq 1304 | (loop [~gxs ~gxs] 1305 | (when-first [~bind ~gxs] 1306 | ~(do-mod mod-pairs))))) 1307 | #_"inner-most loop" 1308 | (let [gi (gensym "i__") 1309 | gb (gensym "b__") 1310 | do-cmod (fn do-cmod [[[k v :as pair] & etc]] 1311 | (core/cond 1312 | (= k :let) `(let ~v ~(do-cmod etc)) 1313 | (= k :while) `(when ~v ~(do-cmod etc)) 1314 | (= k :when) `(if ~v 1315 | ~(do-cmod etc) 1316 | (recur 1317 | (unchecked-inc ~gi))) 1318 | (core/keyword? k) 1319 | (err "Invalid 'for' keyword " k) 1320 | :else 1321 | `(do (chunk-append ~gb ~body-expr) 1322 | (recur (unchecked-inc ~gi)))))] 1323 | `(fn ~giter [~gxs] 1324 | (lazy-seq 1325 | (loop [~gxs ~gxs] 1326 | (when-let [~gxs (seq ~gxs)] 1327 | (if (chunked-seq? ~gxs) 1328 | (let [c# ^not-native (chunk-first ~gxs) 1329 | size# (count c#) 1330 | ~gb (chunk-buffer size#)] 1331 | (if (coercive-boolean 1332 | (loop [~gi 0] 1333 | (if (< ~gi size#) 1334 | (let [~bind (-nth c# ~gi)] 1335 | ~(do-cmod mod-pairs)) 1336 | true))) 1337 | (chunk-cons 1338 | (chunk ~gb) 1339 | (~giter (chunk-rest ~gxs))) 1340 | (chunk-cons (chunk ~gb) nil))) 1341 | (let [~bind (first ~gxs)] 1342 | ~(do-mod mod-pairs)))))))))))] 1343 | `(let [iter# ~(emit-bind (to-groups seq-exprs))] 1344 | (iter# ~(second seq-exprs))))) 1345 | 1346 | (defmacro doseq 1347 | "Repeatedly executes body (presumably for side-effects) with 1348 | bindings and filtering as provided by \"for\". Does not retain 1349 | the head of the sequence. Returns nil." 1350 | [seq-exprs & body] 1351 | (assert-args doseq 1352 | (vector? seq-exprs) "a vector for its binding" 1353 | (even? (count seq-exprs)) "an even number of forms in binding vector") 1354 | (let [err (fn [& msg] (throw (ex-info (apply core/str msg) {}))) 1355 | step (fn step [recform exprs] 1356 | (if-not exprs 1357 | [true `(do ~@body)] 1358 | (let [k (first exprs) 1359 | v (second exprs) 1360 | 1361 | seqsym (gensym "seq__") 1362 | recform (if (core/keyword? k) recform `(recur (next ~seqsym) nil 0 0)) 1363 | steppair (step recform (nnext exprs)) 1364 | needrec (steppair 0) 1365 | subform (steppair 1)] 1366 | (core/cond 1367 | (= k :let) [needrec `(let ~v ~subform)] 1368 | (= k :while) [false `(when ~v 1369 | ~subform 1370 | ~@(when needrec [recform]))] 1371 | (= k :when) [false `(if ~v 1372 | (do 1373 | ~subform 1374 | ~@(when needrec [recform])) 1375 | ~recform)] 1376 | (core/keyword? k) (err "Invalid 'doseq' keyword" k) 1377 | :else (let [chunksym (with-meta (gensym "chunk__") 1378 | {:tag 'not-native}) 1379 | countsym (gensym "count__") 1380 | isym (gensym "i__") 1381 | recform-chunk `(recur ~seqsym ~chunksym ~countsym (unchecked-inc ~isym)) 1382 | steppair-chunk (step recform-chunk (nnext exprs)) 1383 | subform-chunk (steppair-chunk 1)] 1384 | [true `(loop [~seqsym (seq ~v) 1385 | ~chunksym nil 1386 | ~countsym 0 1387 | ~isym 0] 1388 | (if (coercive-boolean (< ~isym ~countsym)) 1389 | (let [~k (-nth ~chunksym ~isym)] 1390 | ~subform-chunk 1391 | ~@(when needrec [recform-chunk])) 1392 | (when-let [~seqsym (seq ~seqsym)] 1393 | (if (chunked-seq? ~seqsym) 1394 | (let [c# (chunk-first ~seqsym)] 1395 | (recur (chunk-rest ~seqsym) c# 1396 | (count c#) 0)) 1397 | (let [~k (first ~seqsym)] 1398 | ~subform 1399 | ~@(when needrec [recform]))))))])))))] 1400 | (nth (step nil (seq seq-exprs)) 1))) 1401 | 1402 | (defmacro array [& rest] 1403 | (let [xs-str (->> (repeat "~{}") 1404 | (take (count rest)) 1405 | (interpose ",") 1406 | (apply core/str))] 1407 | (vary-meta 1408 | (list* 'js* (core/str "[" xs-str "]") rest) 1409 | assoc :tag 'array))) 1410 | 1411 | (defmacro make-array 1412 | [size] 1413 | (vary-meta 1414 | (if (core/number? size) 1415 | `(array ~@(take size (repeat nil))) 1416 | `(js/Array. ~size)) 1417 | assoc :tag 'array)) 1418 | 1419 | (defmacro list 1420 | ([] '(.-EMPTY cljs.core/List)) 1421 | ([x & xs] 1422 | `(-conj (list ~@xs) ~x))) 1423 | 1424 | (defmacro vector 1425 | ([] '(.-EMPTY cljs.core/PersistentVector)) 1426 | ([& xs] 1427 | (let [cnt (count xs)] 1428 | (if (core/< cnt 32) 1429 | `(cljs.core/PersistentVector. nil ~cnt 5 1430 | (.-EMPTY-NODE cljs.core/PersistentVector) (array ~@xs) nil) 1431 | (vary-meta 1432 | `(.fromArray cljs.core/PersistentVector (array ~@xs) true) 1433 | assoc :tag 'cljs.core/PersistentVector))))) 1434 | 1435 | (defmacro array-map 1436 | ([] '(.-EMPTY cljs.core/PersistentArrayMap)) 1437 | ([& kvs] 1438 | (let [keys (map first (partition 2 kvs))] 1439 | (if (core/and (every? #(= (:op %) :const) 1440 | (map #(clojure.tools.analyzer.js/analyze % &env) keys)) 1441 | (= (count (into #{} keys)) (count keys))) 1442 | `(cljs.core/PersistentArrayMap. nil ~(clojure.core// (count kvs) 2) (array ~@kvs) nil) 1443 | `(.fromArray cljs.core/PersistentArrayMap (array ~@kvs) true false))))) 1444 | 1445 | (defmacro hash-map 1446 | ([] `(.-EMPTY cljs.core/PersistentHashMap)) 1447 | ([& kvs] 1448 | (let [pairs (partition 2 kvs) 1449 | ks (map first pairs) 1450 | vs (map second pairs)] 1451 | (vary-meta 1452 | `(.fromArrays cljs.core/PersistentHashMap (array ~@ks) (array ~@vs)) 1453 | assoc :tag 'cljs.core/PersistentHashMap)))) 1454 | 1455 | (defmacro hash-set 1456 | ([] `(.-EMPTY cljs.core/PersistentHashSet)) 1457 | ([& xs] 1458 | (if (core/and (core/<= (count xs) 8) 1459 | (every? #(= (:op %) :const) 1460 | (map #(clojure.tools.analyzer.js/analyze % &env) xs)) 1461 | (= (count (into #{} xs)) (count xs))) 1462 | `(cljs.core/PersistentHashSet. nil 1463 | (cljs.core/PersistentArrayMap. nil ~(count xs) (array ~@(interleave xs (repeat nil))) nil) 1464 | nil) 1465 | (vary-meta 1466 | `(.fromArray cljs.core/PersistentHashSet (array ~@xs) true) 1467 | assoc :tag 'cljs.core/PersistentHashSet)))) 1468 | 1469 | (defn js-obj* [kvs] 1470 | (let [kvs-str (->> (repeat "~{}:~{}") 1471 | (take (count kvs)) 1472 | (interpose ",") 1473 | (apply core/str))] 1474 | (vary-meta 1475 | (list* 'js* (core/str "{" kvs-str "}") (apply concat kvs)) 1476 | assoc :tag 'object))) 1477 | 1478 | (defmacro js-obj [& rest] 1479 | (let [sym-or-str? (fn [x] (core/or (core/symbol? x) (core/string? x))) 1480 | filter-on-keys (fn [f coll] 1481 | (->> coll 1482 | (filter (fn [[k _]] (f k))) 1483 | (into {}))) 1484 | kvs (into {} (map vec (partition 2 rest))) 1485 | sym-pairs (filter-on-keys core/symbol? kvs) 1486 | expr->local (zipmap 1487 | (filter (complement sym-or-str?) (keys kvs)) 1488 | (repeatedly gensym)) 1489 | obj (gensym "obj")] 1490 | `(let [~@(apply concat (clojure.set/map-invert expr->local)) 1491 | ~obj ~(js-obj* (filter-on-keys core/string? kvs))] 1492 | ~@(map (fn [[k v]] `(aset ~obj ~k ~v)) sym-pairs) 1493 | ~@(map (fn [[k v]] `(aset ~obj ~v ~(core/get kvs k))) expr->local) 1494 | ~obj))) 1495 | 1496 | (defmacro alength [a] 1497 | (vary-meta 1498 | (core/list 'js* "~{}.length" a) 1499 | assoc :tag 'number)) 1500 | 1501 | (defmacro amap 1502 | "Maps an expression across an array a, using an index named idx, and 1503 | return value named ret, initialized to a clone of a, then setting 1504 | each element of ret to the evaluation of expr, returning the new 1505 | array ret." 1506 | [a idx ret expr] 1507 | `(let [a# ~a 1508 | ~ret (aclone a#)] 1509 | (loop [~idx 0] 1510 | (if (< ~idx (alength a#)) 1511 | (do 1512 | (aset ~ret ~idx ~expr) 1513 | (recur (inc ~idx))) 1514 | ~ret)))) 1515 | 1516 | (defmacro areduce 1517 | "Reduces an expression across an array a, using an index named idx, 1518 | and return value named ret, initialized to init, setting ret to the 1519 | evaluation of expr at each step, returning ret." 1520 | [a idx ret init expr] 1521 | `(let [a# ~a] 1522 | (loop [~idx 0 ~ret ~init] 1523 | (if (< ~idx (alength a#)) 1524 | (recur (inc ~idx) ~expr) 1525 | ~ret)))) 1526 | 1527 | (defmacro dotimes 1528 | "bindings => name n 1529 | 1530 | Repeatedly executes body (presumably for side-effects) with name 1531 | bound to integers from 0 through n-1." 1532 | [bindings & body] 1533 | (let [i (first bindings) 1534 | n (second bindings)] 1535 | `(let [n# ~n] 1536 | (loop [~i 0] 1537 | (when (< ~i n#) 1538 | ~@body 1539 | (recur (inc ~i))))))) 1540 | 1541 | (defn ^:private check-valid-options 1542 | "Throws an exception if the given option map contains keys not listed 1543 | as valid, else returns nil." 1544 | [options & valid-keys] 1545 | (when (seq (apply disj (apply core/hash-set (keys options)) valid-keys)) 1546 | (throw 1547 | (apply core/str "Only these options are valid: " 1548 | (first valid-keys) 1549 | (map #(core/str ", " %) (rest valid-keys)))))) 1550 | 1551 | (defmacro defmulti 1552 | "Creates a new multimethod with the associated dispatch function. 1553 | The docstring and attribute-map are optional. 1554 | 1555 | Options are key-value pairs and may be one of: 1556 | :default the default dispatch value, defaults to :default 1557 | :hierarchy the isa? hierarchy to use for dispatching 1558 | defaults to the global hierarchy" 1559 | [mm-name & options] 1560 | (let [docstring (if (core/string? (first options)) 1561 | (first options) 1562 | nil) 1563 | options (if (core/string? (first options)) 1564 | (next options) 1565 | options) 1566 | m (if (map? (first options)) 1567 | (first options) 1568 | {}) 1569 | options (if (map? (first options)) 1570 | (next options) 1571 | options) 1572 | dispatch-fn (first options) 1573 | options (next options) 1574 | m (if docstring 1575 | (assoc m :doc docstring) 1576 | m) 1577 | m (if (meta mm-name) 1578 | (conj (meta mm-name) m) 1579 | m) 1580 | mm-ns (-> &env :ns core/str)] 1581 | (when (= (count options) 1) 1582 | (throw (Exception. "The syntax for defmulti has changed. Example: (defmulti name dispatch-fn :default dispatch-value)"))) 1583 | (let [options (apply core/hash-map options) 1584 | default (core/get options :default :default)] 1585 | (check-valid-options options :default :hierarchy) 1586 | `(def ~(with-meta mm-name m) 1587 | (let [method-table# (atom {}) 1588 | prefer-table# (atom {}) 1589 | method-cache# (atom {}) 1590 | cached-hierarchy# (atom {}) 1591 | hierarchy# (get ~options :hierarchy (cljs.core/get-global-hierarchy))] 1592 | (cljs.core/MultiFn. (cljs.core/symbol ~mm-ns ~(name mm-name)) ~dispatch-fn ~default hierarchy# 1593 | method-table# prefer-table# method-cache# cached-hierarchy#)))))) 1594 | 1595 | (defmacro defmethod 1596 | "Creates and installs a new method of multimethod associated with dispatch-value. " 1597 | [multifn dispatch-val & fn-tail] 1598 | `(-add-method ~(with-meta multifn {:tag 'cljs.core/MultiFn}) ~dispatch-val (fn ~@fn-tail))) 1599 | 1600 | (defmacro time 1601 | "Evaluates expr and prints the time it took. Returns the value of expr." 1602 | [expr] 1603 | `(let [start# (.getTime (js/Date.)) 1604 | ret# ~expr] 1605 | (prn (core/str "Elapsed time: " (- (.getTime (js/Date.)) start#) " msecs")) 1606 | ret#)) 1607 | 1608 | (defmacro simple-benchmark 1609 | "Runs expr iterations times in the context of a let expression with 1610 | the given bindings, then prints out the bindings and the expr 1611 | followed by number of iterations and total time. The optional 1612 | argument print-fn, defaulting to println, sets function used to 1613 | print the result. expr's string representation will be produced 1614 | using pr-str in any case." 1615 | [bindings expr iterations & {:keys [print-fn] :or {print-fn 'println}}] 1616 | (let [bs-str (pr-str bindings) 1617 | expr-str (pr-str expr)] 1618 | `(let ~bindings 1619 | (let [start# (.getTime (js/Date.)) 1620 | ret# (dotimes [_# ~iterations] ~expr) 1621 | end# (.getTime (js/Date.)) 1622 | elapsed# (- end# start#)] 1623 | (~print-fn (str ~bs-str ", " ~expr-str ", " 1624 | ~iterations " runs, " elapsed# " msecs")))))) 1625 | 1626 | (def cs (into [] (map (comp gensym core/str core/char) (range 97 118)))) 1627 | 1628 | (defn gen-apply-to-helper 1629 | ([] (gen-apply-to-helper 1)) 1630 | ([n] 1631 | (let [prop (symbol (core/str "-cljs$core$IFn$_invoke$arity$" n)) 1632 | f (symbol (core/str "cljs$core$IFn$_invoke$arity$" n))] 1633 | (if (core/<= n 20) 1634 | `(let [~(cs (core/dec n)) (-first ~'args) 1635 | ~'args (-rest ~'args)] 1636 | (if (core/== ~'argc ~n) 1637 | (if (. ~'f ~prop) 1638 | (. ~'f (~f ~@(take n cs))) 1639 | (~'f ~@(take n cs))) 1640 | ~(gen-apply-to-helper (core/inc n)))) 1641 | `(throw (js/Error. "Only up to 20 arguments supported on functions")))))) 1642 | 1643 | (defmacro gen-apply-to [] 1644 | `(do 1645 | (set! ~'*unchecked-if* true) 1646 | (defn ~'apply-to [~'f ~'argc ~'args] 1647 | (let [~'args (seq ~'args)] 1648 | (if (zero? ~'argc) 1649 | (~'f) 1650 | ~(gen-apply-to-helper)))) 1651 | (set! ~'*unchecked-if* false))) 1652 | 1653 | (defmacro with-out-str 1654 | "Evaluates exprs in a context in which *print-fn* is bound to .append 1655 | on a fresh StringBuffer. Returns the string created by any nested 1656 | printing calls." 1657 | [& body] 1658 | `(let [sb# (js/goog.string.StringBuffer.)] 1659 | (binding [cljs.core/*print-fn* (fn [x#] (.append sb# x#))] 1660 | ~@body) 1661 | (cljs.core/str sb#))) 1662 | 1663 | (defmacro lazy-cat 1664 | "Expands to code which yields a lazy sequence of the concatenation 1665 | of the supplied colls. Each coll expr is not evaluated until it is 1666 | needed. 1667 | 1668 | (lazy-cat xs ys zs) === (concat (lazy-seq xs) (lazy-seq ys) (lazy-seq zs))" 1669 | [& colls] 1670 | `(concat ~@(map #(core/list `lazy-seq %) colls))) 1671 | 1672 | (defmacro js-str [s] 1673 | (core/list 'js* "''+~{}" s)) 1674 | 1675 | (defmacro es6-iterable [ty] 1676 | `(aset (.-prototype ~ty) cljs.core/ITER_SYMBOL 1677 | (fn [] 1678 | (this-as this# 1679 | (cljs.core/es6-iterator this#))))) 1680 | 1681 | (defmacro ns-interns 1682 | "Returns a map of the intern mappings for the namespace." 1683 | [[quote ns]] 1684 | (core/assert (core/and (= quote 'quote) (core/symbol? ns)) 1685 | "Argument to ns-interns must be a quoted symbol") 1686 | `(into {} ~(mapv (fn [[sym {:keys [ns name]}]] `[~sym (var ~(core/symbol (core/name ns) (core/name name)))]) 1687 | (get-in (env/deref-env) [:namespaces ns :mappings])))) 1688 | --------------------------------------------------------------------------------