THE ACCOMPANYING PROGRAM IS PROVIDED UNDER THE TERMS OF THIS ECLIPSE
PUBLIC LICENSE ("AGREEMENT"). ANY USE, REPRODUCTION OR
DISTRIBUTION OF THE PROGRAM CONSTITUTES RECIPIENT'S ACCEPTANCE OF THIS
AGREEMENT.
1. DEFINITIONS
"Contribution" means:
a) in the case of the initial Contributor, the initial
code and documentation distributed under this Agreement, and
b) in the case of each subsequent Contributor:
i) changes to the Program, and
ii) additions to the Program;
where such changes and/or additions to the Program
originate from and are distributed by that particular Contributor. A
Contribution 'originates' from a Contributor if it was added to the
Program by such Contributor itself or anyone acting on such
Contributor's behalf. Contributions do not include additions to the
Program which: (i) are separate modules of software distributed in
conjunction with the Program under their own license agreement, and (ii)
are not derivative works of the Program.
"Contributor" means any person or entity that distributes
the Program.
"Licensed Patents" mean patent claims licensable by a
Contributor which are necessarily infringed by the use or sale of its
Contribution alone or when combined with the Program.
"Program" means the Contributions distributed in accordance
with this Agreement.
"Recipient" means anyone who receives the Program under
this Agreement, including all Contributors.
2. GRANT OF RIGHTS
a) Subject to the terms of this Agreement, each
Contributor hereby grants Recipient a non-exclusive, worldwide,
royalty-free copyright license to reproduce, prepare derivative works
of, publicly display, publicly perform, distribute and sublicense the
Contribution of such Contributor, if any, and such derivative works, in
source code and object code form.
b) Subject to the terms of this Agreement, each
Contributor hereby grants Recipient a non-exclusive, worldwide,
royalty-free patent license under Licensed Patents to make, use, sell,
offer to sell, import and otherwise transfer the Contribution of such
Contributor, if any, in source code and object code form. This patent
license shall apply to the combination of the Contribution and the
Program if, at the time the Contribution is added by the Contributor,
such addition of the Contribution causes such combination to be covered
by the Licensed Patents. The patent license shall not apply to any other
combinations which include the Contribution. No hardware per se is
licensed hereunder.
c) Recipient understands that although each Contributor
grants the licenses to its Contributions set forth herein, no assurances
are provided by any Contributor that the Program does not infringe the
patent or other intellectual property rights of any other entity. Each
Contributor disclaims any liability to Recipient for claims brought by
any other entity based on infringement of intellectual property rights
or otherwise. As a condition to exercising the rights and licenses
granted hereunder, each Recipient hereby assumes sole responsibility to
secure any other intellectual property rights needed, if any. For
example, if a third party patent license is required to allow Recipient
to distribute the Program, it is Recipient's responsibility to acquire
that license before distributing the Program.
d) Each Contributor represents that to its knowledge it
has sufficient copyright rights in its Contribution, if any, to grant
the copyright license set forth in this Agreement.
3. REQUIREMENTS
A Contributor may choose to distribute the Program in object code
form under its own license agreement, provided that:
a) it complies with the terms and conditions of this
Agreement; and
b) its license agreement:
i) effectively disclaims on behalf of all Contributors
all warranties and conditions, express and implied, including warranties
or conditions of title and non-infringement, and implied warranties or
conditions of merchantability and fitness for a particular purpose;
ii) effectively excludes on behalf of all Contributors
all liability for damages, including direct, indirect, special,
incidental and consequential damages, such as lost profits;
iii) states that any provisions which differ from this
Agreement are offered by that Contributor alone and not by any other
party; and
iv) states that source code for the Program is available
from such Contributor, and informs licensees how to obtain it in a
reasonable manner on or through a medium customarily used for software
exchange.
When the Program is made available in source code form:
a) it must be made available under this Agreement; and
b) a copy of this Agreement must be included with each
copy of the Program.
Contributors may not remove or alter any copyright notices contained
within the Program.
Each Contributor must identify itself as the originator of its
Contribution, if any, in a manner that reasonably allows subsequent
Recipients to identify the originator of the Contribution.
4. COMMERCIAL DISTRIBUTION
Commercial distributors of software may accept certain
responsibilities with respect to end users, business partners and the
like. While this license is intended to facilitate the commercial use of
the Program, the Contributor who includes the Program in a commercial
product offering should do so in a manner which does not create
potential liability for other Contributors. Therefore, if a Contributor
includes the Program in a commercial product offering, such Contributor
("Commercial Contributor") hereby agrees to defend and
indemnify every other Contributor ("Indemnified Contributor")
against any losses, damages and costs (collectively "Losses")
arising from claims, lawsuits and other legal actions brought by a third
party against the Indemnified Contributor to the extent caused by the
acts or omissions of such Commercial Contributor in connection with its
distribution of the Program in a commercial product offering. The
obligations in this section do not apply to any claims or Losses
relating to any actual or alleged intellectual property infringement. In
order to qualify, an Indemnified Contributor must: a) promptly notify
the Commercial Contributor in writing of such claim, and b) allow the
Commercial Contributor to control, and cooperate with the Commercial
Contributor in, the defense and any related settlement negotiations. The
Indemnified Contributor may participate in any such claim at its own
expense.
For example, a Contributor might include the Program in a commercial
product offering, Product X. That Contributor is then a Commercial
Contributor. If that Commercial Contributor then makes performance
claims, or offers warranties related to Product X, those performance
claims and warranties are such Commercial Contributor's responsibility
alone. Under this section, the Commercial Contributor would have to
defend claims against the other Contributors related to those
performance claims and warranties, and if a court requires any other
Contributor to pay any damages as a result, the Commercial Contributor
must pay those damages.
5. NO WARRANTY
EXCEPT AS EXPRESSLY SET FORTH IN THIS AGREEMENT, THE PROGRAM IS
PROVIDED ON AN "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS
OF ANY KIND, EITHER EXPRESS OR IMPLIED INCLUDING, WITHOUT LIMITATION,
ANY WARRANTIES OR CONDITIONS OF TITLE, NON-INFRINGEMENT, MERCHANTABILITY
OR FITNESS FOR A PARTICULAR PURPOSE. Each Recipient is solely
responsible for determining the appropriateness of using and
distributing the Program and assumes all risks associated with its
exercise of rights under this Agreement , including but not limited to
the risks and costs of program errors, compliance with applicable laws,
damage to or loss of data, programs or equipment, and unavailability or
interruption of operations.
6. DISCLAIMER OF LIABILITY
EXCEPT AS EXPRESSLY SET FORTH IN THIS AGREEMENT, NEITHER RECIPIENT
NOR ANY CONTRIBUTORS SHALL HAVE ANY LIABILITY FOR ANY DIRECT, INDIRECT,
INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING
WITHOUT LIMITATION LOST PROFITS), HOWEVER CAUSED AND ON ANY THEORY OF
LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OR
DISTRIBUTION OF THE PROGRAM OR THE EXERCISE OF ANY RIGHTS GRANTED
HEREUNDER, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGES.
7. GENERAL
If any provision of this Agreement is invalid or unenforceable under
applicable law, it shall not affect the validity or enforceability of
the remainder of the terms of this Agreement, and without further action
by the parties hereto, such provision shall be reformed to the minimum
extent necessary to make such provision valid and enforceable.
If Recipient institutes patent litigation against any entity
(including a cross-claim or counterclaim in a lawsuit) alleging that the
Program itself (excluding combinations of the Program with other
software or hardware) infringes such Recipient's patent(s), then such
Recipient's rights granted under Section 2(b) shall terminate as of the
date such litigation is filed.
All Recipient's rights under this Agreement shall terminate if it
fails to comply with any of the material terms or conditions of this
Agreement and does not cure such failure in a reasonable period of time
after becoming aware of such noncompliance. If all Recipient's rights
under this Agreement terminate, Recipient agrees to cease use and
distribution of the Program as soon as reasonably practicable. However,
Recipient's obligations under this Agreement and any licenses granted by
Recipient relating to the Program shall continue and survive.
Everyone is permitted to copy and distribute copies of this
Agreement, but in order to avoid inconsistency the Agreement is
copyrighted and may only be modified in the following manner. The
Agreement Steward reserves the right to publish new versions (including
revisions) of this Agreement from time to time. No one other than the
Agreement Steward has the right to modify this Agreement. The Eclipse
Foundation is the initial Agreement Steward. The Eclipse Foundation may
assign the responsibility to serve as the Agreement Steward to a
suitable separate entity. Each new version of the Agreement will be
given a distinguishing version number. The Program (including
Contributions) may always be distributed subject to the version of the
Agreement under which it was received. In addition, after a new version
of the Agreement is published, Contributor may elect to distribute the
Program (including its Contributions) under the new version. Except as
expressly stated in Sections 2(a) and 2(b) above, Recipient receives no
rights or licenses to the intellectual property of any Contributor under
this Agreement, whether expressly, by implication, estoppel or
otherwise. All rights in the Program not expressly granted under this
Agreement are reserved.
This Agreement is governed by the laws of the State of New York and
the intellectual property laws of the United States of America. No party
to this Agreement will bring a legal action under this Agreement more
than one year after the cause of action arose. Each party waives its
rights to a jury trial in any resulting litigation.
tools.analyzer-tools.analyzer-1.0.0/pom.xml 0000664 0000000 0000000 00000002124 13622775470 0021007 0 ustar 00root root 0000000 0000000
4.0.0tools.analyzer1.0.0tools.analyzerAn analyzer for Clojure code, written in Clojure and producing AST in EDN1.5.1org.clojurepom.contrib0.2.2bronsaNicola Momettoscm:git:git://github.com/clojure/tools.analyzer.gitscm:git:git://github.com/clojure/tools.analyzer.githttp://github.com/clojure/tools.analyzertools.analyzer-1.0.0
tools.analyzer-tools.analyzer-1.0.0/project.clj 0000664 0000000 0000000 00000001273 13622775470 0021636 0 ustar 00root root 0000000 0000000 (defproject org.clojure/tools.analyzer "0.7.1-SNAPSHOT"
:description "An analyzer for Clojure code, written in Clojure and producing AST in EDN."
:url "https://github.com/clojure/tools.analyzer"
:license {:name "Eclipse Public License"
:url "http://www.eclipse.org/legal/epl-v10.html"}
:source-paths ["src/main/clojure"]
:test-paths ["src/test/clojure"]
:dependencies [[org.clojure/clojure "1.9.0"]
[com.datomic/datomic-free "0.9.5327" :scope "provided" :exclusions [joda-time]]]
:repositories [["sonatype" "https://oss.sonatype.org/content/repositories/releases"]
["snapshots" "https://oss.sonatype.org/content/repositories/snapshots"]])
tools.analyzer-tools.analyzer-1.0.0/spec/ 0000775 0000000 0000000 00000000000 13622775470 0020425 5 ustar 00root root 0000000 0000000 tools.analyzer-tools.analyzer-1.0.0/spec/ast-ref.edn 0000664 0000000 0000000 00000027246 13622775470 0022471 0 ustar 00root root 0000000 0000000 {:all-keys
[[:op "The node op"]
[:form "The clojure form from which the node originated"]
[:env "The environment map"]
^:optional
[:children "A vector of keywords, representing the children nodes of this node, in order of evaluation"]
^:optional
[: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"]
^:optional
[:top-level "`true` if this is the root node"]]
:node-keys
[{:op :binding
:doc "Node for a binding symbol"
:keys [[:form "The binding symbol"]
[:name "The binding symbol"]
[:local "One of :arg, :catch, :fn, :let, :letfn or :loop"]
^:optional
[:arg-id "When :local is :arg, the parameter index"]
^:optional
[:variadic? "When :local is :arg, a boolean indicating whether this parameter binds to a variable number of arguments"]
^:optional ^:children
[:init "When :local is :let, :letfn or :loop, an AST node representing the bound value"]]}
{:op :catch
:doc "Node for a catch expression"
:keys [[:form "`(catch class local body*)`"]
^:children
[:class "A :maybe-class AST node representing the type of exception to catch"]
^:children
[:local "The :binding AST node for the caught exception"]
^:children
[:body "Synthetic :do AST node (with :body? `true`) representing the body of the catch clause"]]}
{:op :const
:doc "Node for a constant literal or a quoted collection literal"
:keys [[:form "A constant literal or a quoted collection literal"]
[:literal? "`true`"]
[:type "one of :nil, :bool, :keyword, :symbol, :string, :number, :type, :record, :map, :vector, :set, :seq, :char, :regex, :class, :var, or :unknown"]
[:val "The value of the constant node"]
^:optional ^:children
[:meta "An AST node representing the metadata of the constant value, if present. The node will be either a :map node or a :const node with :type :map"]]}
{:op :def
:doc "Node for a def special-form expression"
:keys [[:form "`(def name docstring? init?)`"]
[:name "The var symbol to define in the current namespace"]
[:var "The var object created (or found, if it already existed) named by the symbol :name in the current namespace"]
^:optional ^:children
[: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"]
^:optional ^:children
[:init "An AST node representing the initial value of the var"]
^:optional
[:doc "The docstring for this var"]]}
{:op :do
:doc "Node for a do special-form expression or for another special-form's body"
:keys [[:form "`(do statement* ret)`"]
^:children
[:statements "A vector of AST nodes representing all but the last expression in the do body"]
^:children
[:ret "An AST node representing the last expression in the do body (the block's return value)"]
^:optional
[:body? "`true` if this node is a synthetic body"]]}
{:op :fn
:doc "Node for a fn* special-form expression"
:keys [[:form "`(fn* name? [arg*] body*)` or `(fn* name? method*)`"]
[:variadic? "`true` if this function contains a variadic arity method"]
[:max-fixed-arity "The number of arguments taken by the fixed-arity method taking the most arguments"]
^:optional ^:children
[:local "A :binding AST node with :local :fn representing the function's local name, if one is supplied"]
^:children
[:methods "A vector of :fn-method AST nodes representing the fn method arities"]
[: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"]]}
{:op :fn-method
:doc "Node for an arity method in a fn* expression"
:keys [[:form "`([arg*] body*)`"]
[:loop-id "Unique symbol identifying this method as a target for recursion"]
[:variadic? "`true` if this fn-method takes a variable number of arguments"]
^:children
[:params "A vector of :binding AST nodes with :local :arg representing this fn-method args"]
[:fixed-arity "The number of non-variadic args this fn-method takes"]
^:children
[:body "Synthetic :do node (with :body? `true`) representing the body of this fn-method"]]}
{:op :host-call
:doc "Node for a host interop call"
:keys [[:form "`(.method target arg*)`"]
[:method "Symbol naming the method to call"]
^:children
[:target "An AST node representing the target object"]
^:children
[:args "A vector of AST nodes representing the args passed to the method call"]]}
{:op :host-field
:doc "Node for a host interop field access"
:keys [[:form "`(.-field target)`"]
[:field "Symbol naming the field to access"]
^:children
[:target "An AST node representing the target object"]
[:assignable? "`true`"]]}
{:op :host-interop
:doc "Node for a no-arg host interop call or for a host interop field access"
:keys [[:form "`(. target m-or-f)`"]
^:children
[:target "An AST node representing the target object"]
[:m-or-f "Symbol naming the no-arg method or field to access in the target"]
[:assignable? "`true`"]]}
{:op :if
:doc "Node for an if special-form expression"
:keys [[:form "`(if test then else?)`"]
^:children
[:test "An AST node representing the test expression"]
^:children
[:then "An AST node representing the expression's return value if :test evaluated to a truthy value"]
^:children
[: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"]]}
{:op :invoke
:doc "Node for an invoke expression"
:keys [[:form "`(f arg*)`"]
^:children
[:fn "An AST node representing the function to invoke"]
^:children
[:args "A vector of AST nodes representing the args to the function"]
^:optional
[:meta "Map of metadata attached to the invoke :form"]]}
{:op :let
:doc "Node for a let* special-form expression"
:keys [[:form "`(let* [binding*] body*)`"]
^:children
[:bindings "A vector of :binding AST nodes with :local :let"]
^:children
[:body "Synthetic :do node (with :body? `true`) representing the body of the let expression"]]}
{:op :letfn
:doc "Node for a letfn* special-form expression"
:keys [[:form "`(letfn* [binding*] body*)`"]
^:children
[:bindings "A vector of :binding AST nodes with :local :letfn"]
^:children
[:body "Synthetic :do node (with :body? `true`) representing the body of the letfn expression"]]}
{:op :local
:doc "Node for a local symbol"
:keys [[:form "The local symbol"]
[:name "The local symbol"]
[:local "One of :arg, :catch, :fn, :let, :letfn or :loop"]
^:optional
[:arg-id "When :local is :arg, the parameter index"]
[:assignable? "`true` if the local is mutable"]
^:optional
[:variadic? "When :local is :arg, a boolean indicating whether this parameter binds to a variable number of arguments"]]}
{:op :loop
:doc "Node a loop* special-form expression"
:keys [[:form "`(loop* [binding*] body*)`"]
^:children
[:bindings "A vector of :binding AST nodes with :local :loop"]
^:children
[:body "Synthetic :do node (with :body? `true`) representing the body of the loop expression"]
[:loop-id "Unique symbol identifying this loop as a target for recursion"]]}
{:op :map
:doc "Node for a map literal"
:keys [[:form "`{[key val]*}`"]
^:children
[:keys "A vector of AST nodes representing the keys of the map"]
^:children
[:vals "A vector of AST nodes representing the vals of the map"]]}
{:op :maybe-class
:doc "Node for a not-namespaced symbol that couldn't be resolved as a var"
:keys [[:form "The not namespaced symbol"]
[:class "The not namespaced symbol that might represent a class"]]}
{:op :maybe-host-form
:doc "Node for namespaced symbol that couldn't be resolved as a var"
:keys [[:form "The namespaced symbol"]
[:class "The namespace part of the symbol, as a symbol"]
[:field "The name part of the symbol, as a symbol"]]}
{:op :new
:doc "Node for a new special-form expression"
:keys [[:form "`(new Class arg*)`"]
^:children
[:class "A :maybe-class AST node :class representing the Class to instantiate"]
^:children
[:args "A vector of AST nodes representing the arguments passed to the Class constructor"]]}
{:op :quote
:doc "Node for a quote special-form expression"
:keys [[:form "`(quote expr)`"]
^:children
[:expr "A :const AST node representing the quoted value"]
[:literal? "`true`"]]}
{:op :recur
:doc "Node for a recur special-form expression"
:keys [[:form "`(recur expr*)`"]
^:children
[:exprs "A vector of AST nodes representing the new bound values for the loop binding on the next loop iteration"]
[:loop-id "Unique symbol identifying the enclosing loop target"]]}
{:op :set
:doc "Node for a set literal"
:keys [[:form "`#{item*}`"]
^:children
[:items "A vector of AST nodes representing the items of the set"]]}
{:op :set!
:doc "Node for a set! special-form expression"
:keys [[:form "`(set! target val)`"]
^:children
[:target "An AST node representing the target of the set! expression, must be :assignable?"]
^:children
[:val "An AST node representing the new value for the target"]]}
{:op :throw
:doc "Node for a throw special-form statement"
:keys [[:form "`(throw exception)`"]
^:children
[:exception "An AST node representing the exception to throw"]]}
{:op :try
:doc "Node for a try special-form expression"
:keys [[:form "`(try body* catch* finally?)`"]
^:children
[:body "Synthetic :do AST node (with :body? `true`) representing the body of this try expression"]
^:children
[:catches "A vector of :catch AST nodes representing the catch clauses of this try expression"]
^:optional ^:children
[:finally "Synthetic :do AST node (with :body? `true`) representing the final clause of this try expression"]]}
{:op :var
:doc "Node for a var symbol"
:keys [[:form "A symbol naming the var"]
[:var "The var object this symbol refers to"]
^:optional
[:assignable? "`true` if the Var is :dynamic"]]}
{:op :vector
:doc "Node for a vector literal with attached metadata and/or non literal elements"
:keys [[:form "`[item*]`"]
^:children
[:items "A vector of AST nodes representing the items of the vector"]]}
{:op :with-meta
:doc "Node for a non quoted collection literal or a fn expression with attached metadata"
:keys [[:form "Non quoted collection literal or fn expression with attached metadata"]
^:children
[:meta "An AST node representing the metadata of expression. The node will be either a :map node or a :const node with :type :map"]
^:children
[:expr "The expression this metadata is attached to, :op is one of :vector, :map, :set or :fn"]]}]}
tools.analyzer-tools.analyzer-1.0.0/spec/buildref.sh 0000775 0000000 0000000 00000000431 13622775470 0022556 0 ustar 00root root 0000000 0000000 #!/bin/sh
java -cp .:`lein cp` clojure.main < (str x)
(replace #"`(.*?)`" "$1")
(replace #":([a-zA-Z\?!\-]*)" ":$1")))
(defn build-children [children]
(if (some #(:optional (meta %)) children)
(let [[c & rest] children]
(let [k (build-children rest)
kc (mapv (fn [x] (cons c x)) k)]
(if (:optional (meta c))
(into k kc)
kc)))
(if (seq children)
[children]
[[]])))
(defn children [keys]
(when-let [children (seq (filter #(:children (meta %)) keys))]
(mapv #(mapv first %) (build-children children))))
(def nodes
(apply str (for [{:keys [op doc keys]} (:node-keys tej-ref) :let [op (name op)]]
(str ""
"
{nodes}
tools.analyzer-tools.analyzer-1.0.0/src/ 0000775 0000000 0000000 00000000000 13622775470 0020262 5 ustar 00root root 0000000 0000000 tools.analyzer-tools.analyzer-1.0.0/src/main/ 0000775 0000000 0000000 00000000000 13622775470 0021206 5 ustar 00root root 0000000 0000000 tools.analyzer-tools.analyzer-1.0.0/src/main/clojure/ 0000775 0000000 0000000 00000000000 13622775470 0022651 5 ustar 00root root 0000000 0000000 tools.analyzer-tools.analyzer-1.0.0/src/main/clojure/clojure/ 0000775 0000000 0000000 00000000000 13622775470 0024314 5 ustar 00root root 0000000 0000000 tools.analyzer-tools.analyzer-1.0.0/src/main/clojure/clojure/tools/ 0000775 0000000 0000000 00000000000 13622775470 0025454 5 ustar 00root root 0000000 0000000 tools.analyzer-tools.analyzer-1.0.0/src/main/clojure/clojure/tools/analyzer.clj 0000664 0000000 0000000 00000073621 13622775470 0030004 0 ustar 00root root 0000000 0000000 ;; Copyright (c) Nicola Mometto, Rich Hickey & contributors.
;; The use and distribution terms for this software are covered by the
;; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php)
;; which can be found in the file epl-v10.html at the root of this distribution.
;; By using this software in any fashion, you are agreeing to be bound by
;; the terms of this license.
;; You must not remove this notice, or any other, from this software.
(ns clojure.tools.analyzer
"Analyzer for clojure code, host agnostic.
Entry point:
* analyze
Platform implementers must provide dynamic bindings for:
* macroexpand-1
* parse
* create-var
* var?
Setting up the global env is also required, see clojure.tools.analyzer.env
See clojure.tools.analyzer.core-test for an example on how to setup the analyzer."
(:refer-clojure :exclude [macroexpand-1 macroexpand var? record? boolean?])
(:require [clojure.tools.analyzer.utils :refer :all]
[clojure.tools.analyzer.env :as env])
(:import (clojure.lang Symbol IPersistentVector IPersistentMap IPersistentSet ISeq IType IRecord)))
(derive :ctx/return :ctx/expr)
(defmulti -analyze-form (fn [form _] (class form)))
(declare analyze-symbol
analyze-vector
analyze-map
analyze-set
analyze-seq
analyze-const)
(def ^:dynamic analyze-form
"Like analyze, but does not mark the form with :top-level true"
-analyze-form)
(defmethod -analyze-form Symbol
[form env]
(analyze-symbol form env))
(defmethod -analyze-form IPersistentVector
[form env]
(analyze-vector form env))
(defmethod -analyze-form IPersistentMap
[form env]
(analyze-map form env))
(defmethod -analyze-form IPersistentSet
[form env]
(analyze-set form env))
(defmethod -analyze-form ISeq
[form env]
(if-let [form (seq form)]
(analyze-seq form env)
(analyze-const form env)))
(defmethod -analyze-form IType
[form env]
(analyze-const form env :type))
(prefer-method -analyze-form IType IPersistentMap)
(prefer-method -analyze-form IType IPersistentVector)
(prefer-method -analyze-form IType IPersistentSet)
(prefer-method -analyze-form IType ISeq)
(defmethod -analyze-form IRecord
[form env]
(analyze-const form env :record))
(prefer-method -analyze-form IRecord IPersistentMap)
(prefer-method -analyze-form IRecord IPersistentVector)
(prefer-method -analyze-form IRecord IPersistentSet)
(prefer-method -analyze-form IRecord ISeq)
(defmethod -analyze-form :default
[form env]
(analyze-const form env))
(defn analyze
"Given a form to analyze and an environment, a map containing:
* :locals a map from binding symbol to AST of the binding value
* :context a keyword describing the form's context from the :ctx/* hierarchy.
** :ctx/expr the form is an expression: its value is used
** :ctx/return the form is an expression in return position, derives :ctx/expr
** :ctx/statement the value of the form is not used
* :ns a symbol representing the current namespace of the form to be
analyzed
returns an AST for that form.
Every node in the AST is a map that is *guaranteed* to have the following keys:
* :op a keyword describing the AST node
* :form the form represented by the AST node
* :env the environment map of the AST node
Additionaly if the AST node contains sub-nodes, it is guaranteed to have:
* :children a vector of the keys of the AST node mapping to the sub-nodes,
ordered, when that makes sense
It is considered a node either the top-level node (marked with :top-level true)
or a node that can be reached via :children; if a node contains a node-like
map that is not reachable by :children, there's no guarantee that such a map
will contain the guaranteed keys."
[form env]
(assoc (analyze-form form env) :top-level true))
(defn empty-env
"Returns an empty env"
[]
{:context :ctx/expr
:locals {}
:ns 'user})
(defn analyze-in-env
"Takes an env map and returns a function that analyzes a form in that env"
[env]
(fn [form] (analyze-form form env)))
(def ^{:dynamic true
:arglists '([form env])
:doc "If form represents a macro form, returns its expansion,
else returns form."}
macroexpand-1)
(def ^{:dynamic true
:arglists '([[op & args] env])
:doc "Multimethod that dispatches on op, should default to -parse"}
parse)
(def ^{:dynamic true
:arglists '([sym env])
:doc "Creates a var for sym and returns it"}
create-var)
(def ^{:dynamic true
:arglists '([obj])
:doc "Returns true if obj represent a var form as returned by create-var"}
var?)
;; this node wraps non-quoted collections literals with metadata attached
;; to them, the metadata will be evaluated at run-time, not treated like a constant
(defn wrapping-meta
[{:keys [form env] :as expr}]
(let [meta (meta form)]
(if (and (obj? form)
(seq meta))
{:op :with-meta
:env env
:form form
:meta (analyze-form meta (ctx env :ctx/expr))
:expr (assoc-in expr [:env :context] :ctx/expr)
:children [:meta :expr]}
expr)))
(defn analyze-const
[form env & [type]]
(let [type (or type (classify form))]
(merge
{:op :const
:env env
:type type
:literal? true
:val form
:form form}
(when-let [m (and (obj? form)
(not-empty (meta form)))]
{:meta (analyze-const m (ctx env :ctx/expr) :map) ;; metadata on a constant literal will not be evaluated at
:children [:meta]})))) ;; runtime, this is also true for metadata on quoted collection literals
(defn analyze-vector
[form env]
(let [items-env (ctx env :ctx/expr)
items (mapv (analyze-in-env items-env) form)]
(wrapping-meta
{:op :vector
:env env
:items items
:form form
:children [:items]})))
(defn analyze-map
[form env]
(let [kv-env (ctx env :ctx/expr)
[keys vals] (reduce-kv (fn [[keys vals] k v]
[(conj keys k) (conj vals v)])
[[] []] form)
ks (mapv (analyze-in-env kv-env) keys)
vs (mapv (analyze-in-env kv-env) vals)]
(wrapping-meta
{:op :map
:env env
:keys ks
:vals vs
:form form
:children [:keys :vals]})))
(defn analyze-set
[form env]
(let [items-env (ctx env :ctx/expr)
items (mapv (analyze-in-env items-env) form)]
(wrapping-meta
{:op :set
:env env
:items items
:form form
:children [:items]})))
(def specials
"Set of special forms common to every clojure variant"
'#{do if new quote set! try var
catch throw finally def .
let* letfn* loop* recur fn*})
(defn macroexpand
"Repeatedly calls macroexpand-1 on form until it no longer
represents a macro form, then returns it."
[form env]
(loop [form form]
(let [mform (macroexpand-1 form env)]
(if (= mform form)
mform
(recur mform)))))
(defn analyze-symbol
[sym env]
(let [mform (macroexpand-1 sym env)] ;; t.a.j/macroexpand-1 macroexpands Class/Field into (. Class Field)
(if (= mform sym)
(merge (if-let [{:keys [mutable children] :as local-binding} (-> env :locals sym)] ;; locals shadow globals
(merge (dissoc local-binding :init) ;; avoids useless passes later
{:op :local
:assignable? (boolean mutable)
:children (vec (remove #{:init} children))})
(if-let [var (let [v (resolve-sym sym env)]
(and (var? v) v))]
(let [m (meta var)]
{:op :var
:assignable? (dynamic? var m) ;; we cannot statically determine if a Var is in a thread-local context
:var var ;; so checking whether it's dynamic or not is the most we can do
:meta m})
(if-let [maybe-class (namespace sym)] ;; e.g. js/foo.bar or Long/MAX_VALUE
(let [maybe-class (symbol maybe-class)]
{:op :maybe-host-form
:class maybe-class
:field (symbol (name sym))})
{:op :maybe-class ;; e.g. java.lang.Integer or Long
:class mform})))
{:env env
:form mform})
(-> (analyze-form mform env)
(update-in [:raw-forms] (fnil conj ()) sym)))))
(defn analyze-seq
[form env]
(let [op (first form)]
(when (nil? op)
(throw (ex-info "Can't call nil"
(merge {:form form}
(-source-info form env)))))
(let [mform (macroexpand-1 form env)]
(if (= form mform) ;; function/special-form invocation
(parse mform env)
(-> (analyze-form mform env)
(update-in [:raw-forms] (fnil conj ())
(vary-meta form assoc ::resolved-op (resolve-sym op env))))))))
(defn parse-do
[[_ & exprs :as form] env]
(let [statements-env (ctx env :ctx/statement)
[statements ret] (loop [statements [] [e & exprs] exprs]
(if (seq exprs)
(recur (conj statements e) exprs)
[statements e]))
statements (mapv (analyze-in-env statements-env) statements)
ret (analyze-form ret env)]
{:op :do
:env env
:form form
:statements statements
:ret ret
:children [:statements :ret]}))
(defn parse-if
[[_ test then else :as form] env]
(let [formc (count form)]
(when-not (or (= formc 3) (= formc 4))
(throw (ex-info (str "Wrong number of args to if, had: " (dec (count form)))
(merge {:form form}
(-source-info form env))))))
(let [test-expr (analyze-form test (ctx env :ctx/expr))
then-expr (analyze-form then env)
else-expr (analyze-form else env)]
{:op :if
:form form
:env env
:test test-expr
:then then-expr
:else else-expr
:children [:test :then :else]}))
(defn parse-new
[[_ class & args :as form] env]
(when-not (>= (count form) 2)
(throw (ex-info (str "Wrong number of args to new, had: " (dec (count form)))
(merge {:form form}
(-source-info form env)))))
(let [args-env (ctx env :ctx/expr)
args (mapv (analyze-in-env args-env) args)]
{:op :new
:env env
:form form
:class (analyze-form class (assoc env :locals {})) ;; avoid shadowing
:args args
:children [:class :args]}))
(defn parse-quote
[[_ expr :as form] env]
(when-not (= 2 (count form))
(throw (ex-info (str "Wrong number of args to quote, had: " (dec (count form)))
(merge {:form form}
(-source-info form env)))))
(let [const (analyze-const expr env)]
{:op :quote
:expr const
:form form
:env env
:literal? true
:children [:expr]}))
(defn parse-set!
[[_ target val :as form] env]
(when-not (= 3 (count form))
(throw (ex-info (str "Wrong number of args to set!, had: " (dec (count form)))
(merge {:form form}
(-source-info form env)))))
(let [target (analyze-form target (ctx env :ctx/expr))
val (analyze-form val (ctx env :ctx/expr))]
{:op :set!
:env env
:form form
:target target
:val val
:children [:target :val]}))
(defn analyze-body [body env]
;; :body is used by emit-form to remove the artificial 'do
(assoc (parse (cons 'do body) env) :body? true))
(defn valid-binding-symbol? [s]
(and (symbol? s)
(not (namespace s))
(not (re-find #"\." (name s)))))
(defn ^:private split-with' [pred coll]
(loop [take [] drop coll]
(if (seq drop)
(let [[el & r] drop]
(if (pred el)
(recur (conj take el) r)
[(seq take) drop]))
[(seq take) ()])))
(declare parse-catch)
(defn parse-try
[[_ & body :as form] env]
(let [catch? (every-pred seq? #(= (first %) 'catch))
finally? (every-pred seq? #(= (first %) 'finally))
[body tail'] (split-with' (complement (some-fn catch? finally?)) body)
[cblocks tail] (split-with' catch? tail')
[[fblock & fbs :as fblocks] tail] (split-with' finally? tail)]
(when-not (empty? tail)
(throw (ex-info "Only catch or finally clause can follow catch in try expression"
(merge {:expr tail
:form form}
(-source-info form env)))))
(when-not (empty? fbs)
(throw (ex-info "Only one finally clause allowed in try expression"
(merge {:expr fblocks
:form form}
(-source-info form env)))))
(let [env' (assoc env :in-try true)
body (analyze-body body env')
cenv (ctx env' :ctx/expr)
cblocks (mapv #(parse-catch % cenv) cblocks)
fblock (when-not (empty? fblock)
(analyze-body (rest fblock) (ctx env :ctx/statement)))]
(merge {:op :try
:env env
:form form
:body body
:catches cblocks}
(when fblock
{:finally fblock})
{:children (into [:body :catches]
(when fblock [:finally]))}))))
(defn parse-catch
[[_ etype ename & body :as form] env]
(when-not (valid-binding-symbol? ename)
(throw (ex-info (str "Bad binding form: " ename)
(merge {:sym ename
:form form}
(-source-info form env)))))
(let [env (dissoc env :in-try)
local {:op :binding
:env env
:form ename
:name ename
:local :catch}]
{:op :catch
:class (analyze-form etype (assoc env :locals {}))
:local local
:env env
:form form
:body (analyze-body body (assoc-in env [:locals ename] (dissoc-env local)))
:children [:class :local :body]}))
(defn parse-throw
[[_ throw :as form] env]
(when-not (= 2 (count form))
(throw (ex-info (str "Wrong number of args to throw, had: " (dec (count form)))
(merge {:form form}
(-source-info form env)))))
{:op :throw
:env env
:form form
:exception (analyze-form throw (ctx env :ctx/expr))
:children [:exception]})
(defn validate-bindings
[[op bindings & _ :as form] env]
(when-let [error-msg
(cond
(not (vector? bindings))
(str op " requires a vector for its bindings, had: "
(class bindings))
(not (even? (count bindings)))
(str op " requires an even number of forms in binding vector, had: "
(count bindings)))]
(throw (ex-info error-msg
(merge {:form form
:bindings bindings}
(-source-info form env))))))
(defn parse-letfn*
[[_ bindings & body :as form] env]
(validate-bindings form env)
(let [bindings (apply array-map bindings) ;; pick only one local with the same name, if more are present.
fns (keys bindings)]
(when-let [[sym] (seq (remove valid-binding-symbol? fns))]
(throw (ex-info (str "Bad binding form: " sym)
(merge {:form form
:sym sym}
(-source-info form env)))))
(let [binds (reduce (fn [binds name]
(assoc binds name
{:op :binding
:env env
:name name
:form name
:local :letfn}))
{} fns)
e (update-in env [:locals] merge binds) ;; pre-seed locals
binds (reduce-kv (fn [binds name bind]
(assoc binds name
(merge bind
{:init (analyze-form (bindings name)
(ctx e :ctx/expr))
:children [:init]})))
{} binds)
e (update-in env [:locals] merge (update-vals binds dissoc-env))
body (analyze-body body e)]
{:op :letfn
:env env
:form form
:bindings (vec (vals binds)) ;; order is irrelevant
:body body
:children [:bindings :body]})))
(defn analyze-let
[[op bindings & body :as form] {:keys [context loop-id] :as env}]
(validate-bindings form env)
(let [loop? (= 'loop* op)]
(loop [bindings bindings
env (ctx env :ctx/expr)
binds []]
(if-let [[name init & bindings] (seq bindings)]
(if (not (valid-binding-symbol? name))
(throw (ex-info (str "Bad binding form: " name)
(merge {:form form
:sym name}
(-source-info form env))))
(let [init-expr (analyze-form init env)
bind-expr {:op :binding
:env env
:name name
:init init-expr
:form name
:local (if loop? :loop :let)
:children [:init]}]
(recur bindings
(assoc-in env [:locals name] (dissoc-env bind-expr))
(conj binds bind-expr))))
(let [body-env (assoc env :context (if loop? :ctx/return context))
body (analyze-body body (merge body-env
(when loop?
{:loop-id loop-id
:loop-locals (count binds)})))]
{:body body
:bindings binds
:children [:bindings :body]})))))
(defn parse-let*
[form env]
(into {:op :let
:form form
:env env}
(analyze-let form env)))
(defn parse-loop*
[form env]
(let [loop-id (gensym "loop_") ;; can be used to find matching recur
env (assoc env :loop-id loop-id)]
(into {:op :loop
:form form
:env env
:loop-id loop-id}
(analyze-let form env))))
(defn parse-recur
[[_ & exprs :as form] {:keys [context loop-locals loop-id]
:as env}]
(when-let [error-msg
(cond
(not (isa? context :ctx/return))
"Can only recur from tail position"
(not (= (count exprs) loop-locals))
(str "Mismatched argument count to recur, expected: " loop-locals
" args, had: " (count exprs)))]
(throw (ex-info error-msg
(merge {:exprs exprs
:form form}
(-source-info form env)))))
(let [exprs (mapv (analyze-in-env (ctx env :ctx/expr)) exprs)]
{:op :recur
:env env
:form form
:exprs exprs
:loop-id loop-id
:children [:exprs]}))
(defn analyze-fn-method [[params & body :as form] {:keys [locals local] :as env}]
(when-not (vector? params)
(throw (ex-info "Parameter declaration should be a vector"
(merge {:params params
:form form}
(-source-info form env)
(-source-info params env)))))
(when (not-every? valid-binding-symbol? params)
(throw (ex-info (str "Params must be valid binding symbols, had: "
(mapv class params))
(merge {:params params
:form form}
(-source-info form env)
(-source-info params env))))) ;; more specific
(let [variadic? (boolean (some '#{&} params))
params-names (if variadic? (conj (pop (pop params)) (peek params)) params)
env (dissoc env :local)
arity (count params-names)
params-expr (mapv (fn [name id]
{:env env
:form name
:name name
:variadic? (and variadic?
(= id (dec arity)))
:op :binding
:arg-id id
:local :arg})
params-names (range))
fixed-arity (if variadic?
(dec arity)
arity)
loop-id (gensym "loop_")
body-env (into (update-in env [:locals]
merge (zipmap params-names (map dissoc-env params-expr)))
{:context :ctx/return
:loop-id loop-id
:loop-locals (count params-expr)})
body (analyze-body body body-env)]
(when variadic?
(let [x (drop-while #(not= % '&) params)]
(when (contains? #{nil '&} (second x))
(throw (ex-info "Invalid parameter list"
(merge {:params params
:form form}
(-source-info form env)
(-source-info params env)))))
(when (not= 2 (count x))
(throw (ex-info (str "Unexpected parameter: " (first (drop 2 x))
" after variadic parameter: " (second x))
(merge {:params params
:form form}
(-source-info form env)
(-source-info params env)))))))
(merge
{:op :fn-method
:form form
:loop-id loop-id
:env env
:variadic? variadic?
:params params-expr
:fixed-arity fixed-arity
:body body
:children [:params :body]}
(when local
{:local (dissoc-env local)}))))
(defn parse-fn*
[[op & args :as form] env]
(wrapping-meta
(let [[n meths] (if (symbol? (first args))
[(first args) (next args)]
[nil (seq args)])
name-expr {:op :binding
:env env
:form n
:local :fn
:name n}
e (if n (assoc (assoc-in env [:locals n] (dissoc-env name-expr)) :local name-expr) env)
once? (-> op meta :once boolean)
menv (assoc (dissoc e :in-try) :once once?)
meths (if (vector? (first meths)) (list meths) meths) ;;turn (fn [] ...) into (fn ([]...))
methods-exprs (mapv #(analyze-fn-method % menv) meths)
variadic (seq (filter :variadic? methods-exprs))
variadic? (boolean variadic)
fixed-arities (seq (map :fixed-arity (remove :variadic? methods-exprs)))
max-fixed-arity (when fixed-arities (apply max fixed-arities))]
(when (>= (count variadic) 2)
(throw (ex-info "Can't have more than 1 variadic overload"
(merge {:variadics (mapv :form variadic)
:form form}
(-source-info form env)))))
(when (not= (seq (distinct fixed-arities)) fixed-arities)
(throw (ex-info "Can't have 2 or more overloads with the same arity"
(merge {:form form}
(-source-info form env)))))
(when (and variadic?
(not-every? #(<= (:fixed-arity %)
(:fixed-arity (first variadic)))
(remove :variadic? methods-exprs)))
(throw (ex-info "Can't have fixed arity overload with more params than variadic overload"
(merge {:form form}
(-source-info form env)))))
(merge {:op :fn
:env env
:form form
:variadic? variadic?
:max-fixed-arity max-fixed-arity
:methods methods-exprs
:once once?}
(when n
{:local name-expr})
{:children (conj (if n [:local] []) :methods)}))))
(defn parse-def
[[_ sym & expr :as form] {:keys [ns] :as env}]
(when (not (symbol? sym))
(throw (ex-info (str "First argument to def must be a symbol, had: " (class sym))
(merge {:form form}
(-source-info form env)))))
(when (and (namespace sym)
(not= *ns* (the-ns (symbol (namespace sym)))))
(throw (ex-info "Cannot def namespace qualified symbol"
(merge {:form form
:sym sym}
(-source-info form env)))))
(let [pfn (fn
([])
([init]
{:init init})
([doc init]
{:pre [(string? doc)]}
{:init init :doc doc}))
args (apply pfn expr)
doc (or (:doc args) (-> sym meta :doc))
arglists (when-let [arglists (:arglists (meta sym))]
(second arglists)) ;; drop quote
sym (with-meta (symbol (name sym))
(merge (meta sym)
(when arglists
{:arglists arglists})
(when doc
{:doc doc})
(-source-info form env)))
var (create-var sym env) ;; interned var will have quoted arglists, replaced on evaluation
_ (env/deref-env) ;; make sure *env* is bound
_ (swap! env/*env* assoc-in [:namespaces ns :mappings sym] var)
meta (merge (meta sym)
(when arglists
{:arglists (list 'quote arglists)}))
meta-expr (when meta (analyze-form meta (ctx env :ctx/expr))) ;; meta on def sym will be evaluated
args (when-let [[_ init] (find args :init)]
(assoc args :init (analyze-form init (ctx env :ctx/expr))))
init? (:init args)
children (into (into [] (when meta [:meta]))
(when init? [:init]))]
(merge {:op :def
:env env
:form form
:name sym
:var var}
(when meta
{:meta meta-expr})
args
(when-not (empty? children)
{:children children}))))
(defn parse-dot
[[_ target & [m-or-f & args] :as form] env]
(when-not (>= (count form) 3)
(throw (ex-info (str "Wrong number of args to ., had: " (dec (count form)))
(merge {:form form}
(-source-info form env)))))
(let [[m-or-f field?] (if (and (symbol? m-or-f)
(= \- (first (name m-or-f))))
[(-> m-or-f name (subs 1) symbol) true]
[(if args (cons m-or-f args) m-or-f) false])
target-expr (analyze-form target (ctx env :ctx/expr))
call? (and (not field?) (seq? m-or-f))]
(when (and call? (not (symbol? (first m-or-f))))
(throw (ex-info (str "Method name must be a symbol, had: " (class (first m-or-f)))
(merge {:form form
:method m-or-f}
(-source-info form env)))))
(merge {:form form
:env env
:target target-expr}
(cond
call?
{:op :host-call
:method (symbol (name (first m-or-f)))
:args (mapv (analyze-in-env (ctx env :ctx/expr)) (next m-or-f))
:children [:target :args]}
field?
{:op :host-field
:assignable? true
:field (symbol (name m-or-f))
:children [:target]}
:else
{:op :host-interop ;; either field access or no-args method call
:assignable? true
:m-or-f (symbol (name m-or-f))
:children [:target]}))))
(defn parse-invoke
[[f & args :as form] env]
(let [fenv (ctx env :ctx/expr)
fn-expr (analyze-form f fenv)
args-expr (mapv (analyze-in-env fenv) args)
m (meta form)]
(merge {:op :invoke
:form form
:env env
:fn fn-expr
:args args-expr}
(when (seq m)
{:meta m}) ;; meta on invoke form will not be evaluated
{:children [:fn :args]})))
(defn parse-var
[[_ var :as form] env]
(when-not (= 2 (count form))
(throw (ex-info (str "Wrong number of args to var, had: " (dec (count form)))
(merge {:form form}
(-source-info form env)))))
(if-let [var (resolve-sym var env)]
{:op :the-var
:env env
:form form
:var var}
(throw (ex-info (str "var not found: " var) {:var var}))))
(defn -parse
"Takes a form and an env map and dispatches on the head of the form, that is
a special form."
[form env]
((case (first form)
do parse-do
if parse-if
new parse-new
quote parse-quote
set! parse-set!
try parse-try
throw parse-throw
def parse-def
. parse-dot
let* parse-let*
letfn* parse-letfn*
loop* parse-loop*
recur parse-recur
fn* parse-fn*
var parse-var
#_:else parse-invoke)
form env))
tools.analyzer-tools.analyzer-1.0.0/src/main/clojure/clojure/tools/analyzer/ 0000775 0000000 0000000 00000000000 13622775470 0027301 5 ustar 00root root 0000000 0000000 tools.analyzer-tools.analyzer-1.0.0/src/main/clojure/clojure/tools/analyzer/ast.clj 0000664 0000000 0000000 00000011375 13622775470 0030571 0 ustar 00root root 0000000 0000000 ;; Copyright (c) Nicola Mometto, Rich Hickey & contributors.
;; The use and distribution terms for this software are covered by the
;; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php)
;; which can be found in the file epl-v10.html at the root of this distribution.
;; By using this software in any fashion, you are agreeing to be bound by
;; the terms of this license.
;; You must not remove this notice, or any other, from this software.
(ns clojure.tools.analyzer.ast
"Utilities for AST walking/updating"
(:refer-clojure :exclude [unreduced])
(:require [clojure.tools.analyzer.utils :refer [into! rseqv mapv']]))
(defn cycling
"Combine the given passes in a single pass that will be applieed repeatedly
to the AST until applying it another time will have no effect"
[& fns*]
(let [fns (cycle fns*)]
(fn [ast]
(loop [[f & fns] fns ast ast res (zipmap fns* (repeat nil))]
(let [ast* (f ast)]
(if (= ast* (res f))
ast
(recur fns ast* (assoc res f ast*))))))))
(defn children*
"Return a vector of vectors of the children node key and the children expression
of the AST node, if it has any.
The returned vector returns the childrens in the order as they appear in the
:children field of the AST, and the children expressions may be either a node
or a vector of nodes."
[{:keys [children] :as ast}]
(when children
(mapv #(find ast %) children)))
(defn children
"Return a vector of the children expression of the AST node, if it has any.
The children expressions are kept in order and flattened so that the returning
vector contains only nodes and not vectors of nodes."
[ast]
(persistent!
(reduce (fn [acc [_ c]] ((if (vector? c) into! conj!) acc c))
(transient []) (children* ast))))
;; return transient or reduced holding transient
(defn ^:private -update-children
[ast f r?]
(let [fix (if r? rseqv identity)]
(reduce (fn [ast [k v]]
(let [multi (vector? v)
val (if multi (mapv' f (fix v)) (f v))]
(if (reduced? val)
(reduced (reduced (assoc! ast k (if multi (fix @val) @val))))
(assoc! ast k (if multi (fix val) val)))))
(transient ast)
(fix (children* ast)))))
(defn update-children-reduced
"Like update-children but returns a reduced holding the AST if f short-circuited."
([ast f] (update-children-reduced ast f false))
([ast f reversed?]
(if (and (not (reduced? ast))
(:children ast))
(let [ret (-update-children ast f reversed?)]
(if (reduced? ret)
(reduced (persistent! @ret))
(persistent! ret)))
ast)))
(defn ^:private unreduced [x]
(if (reduced? x)
@x
x))
(defn update-children
"Applies `f` to each AST children node, replacing it with the returned value.
If reversed? is not-nil, `pre` and `post` will be applied starting from the last
children of the AST node to the first one.
Short-circuits on reduced."
([ast f] (update-children ast f false))
([ast f reversed?]
(unreduced (update-children-reduced ast f reversed?))))
(defn walk
"Walk the ast applying `pre` when entering the nodes, and `post` when exiting.
Both functions must return a valid node since the returned value will replace
the node in the AST which was given as input to the function.
If reversed? is not-nil, `pre` and `post` will be applied starting from the last
children of the AST node to the first one.
Short-circuits on reduced."
([ast pre post]
(walk ast pre post false))
([ast pre post reversed?]
(unreduced
((fn walk [ast pre post reversed?]
(let [walk #(walk % pre post reversed?)]
(if (reduced? ast)
ast
(let [ret (update-children-reduced (pre ast) walk reversed?)]
(if (reduced? ret)
ret
(post ret))))))
ast pre post reversed?))))
(defn prewalk
"Shorthand for (walk ast f identity)"
[ast f]
(walk ast f identity))
(defn postwalk
"Shorthand for (walk ast identity f reversed?)"
([ast f]
(postwalk ast f false))
([ast f reversed?]
(walk ast identity f reversed?)))
(defn nodes
"Returns a lazy-seq of all the nodes in the given AST, in depth-first pre-order."
[ast]
(lazy-seq
(cons ast (mapcat nodes (children ast)))))
(defn ast->eav
"Returns an EAV representation of the current AST that can be used by
Datomic's Datalog."
[ast]
(let [children (set (:children ast))]
(mapcat (fn [[k v]]
(if (children k)
(if (map? v)
(into [[ast k v]] (ast->eav v))
(mapcat (fn [v] (into [[ast k v]] (ast->eav v))) v))
[[ast k v]])) ast)))
tools.analyzer-tools.analyzer-1.0.0/src/main/clojure/clojure/tools/analyzer/ast/ 0000775 0000000 0000000 00000000000 13622775470 0030070 5 ustar 00root root 0000000 0000000 tools.analyzer-tools.analyzer-1.0.0/src/main/clojure/clojure/tools/analyzer/ast/query.clj 0000664 0000000 0000000 00000007737 13622775470 0031745 0 ustar 00root root 0000000 0000000 ;; Copyright (c) Nicola Mometto, Rich Hickey & contributors.
;; The use and distribution terms for this software are covered by the
;; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php)
;; which can be found in the file epl-v10.html at the root of this distribution.
;; By using this software in any fashion, you are agreeing to be bound by
;; the terms of this license.
;; You must not remove this notice, or any other, from this software.
(ns clojure.tools.analyzer.ast.query
"Utilities for querying tools.analyzer ASTs with Datomic"
(:require [clojure.tools.analyzer.ast :as ast]
[clojure.tools.analyzer.utils :refer [compile-if]]))
(defn query-map
"Transforms a Datomic query from its vector representation to its map one.
If the given query is already in its map representation, the original query
is returned."
[query]
(if (map? query)
query
(loop [ret {:find [] :in [] :where []} query query op nil]
(if-let [[el & query] (seq query)]
(if (keyword? el)
(recur ret query el)
(recur (update-in ret [op] conj el) query op))
(reduce-kv (fn [m k v] (if (seq v) (assoc m k v) m)) {} ret)))))
(defn unfold-expression-clauses
"Given a Datomic query, walk the :where clauses searching for
expression clauses with nested calls, unnesting those calls.
E.g {:where [[(inc (dec ?foo)) ?bar] ..] ..} will be transformed in
{:where [[(dec ?foo) ?1234] [(inc ?1234) ?bar] ..] ..}"
[query]
(let [{:keys [where] :as query} (query-map query)]
(if-not where
query
(assoc query :where
(mapcat (fn [[op & rest :as form]]
(if-let [[f & args] (and (seq? op) op)]
(if (some seq? args)
(loop [args args to-ssa {} cur [f] binds rest ret []]
(if-let [[a & args] (seq args)]
(if (and (seq? a)
(not= 'quote (first a)))
(let [g (gensym "?")]
(recur args (assoc to-ssa g a) (conj cur g) binds ret))
(recur args to-ssa (conj cur a) binds ret))
(let [ret (conj ret (into [(seq cur)] binds))]
(if-let [[k [f & args]] (first to-ssa)]
(recur args (dissoc to-ssa k) [f] [k] ret)
ret))))
[form])
[form])) where)))))
(defn resolve-calls
"Automatically replace fn name symbols in expression clauses with
their namespace qualified one if the symbol can be resolved in the
current namespace."
[query]
(let [{:keys [where] :as query} (query-map query)]
(if-not where
query
(assoc query :where
(mapv (fn [[op & rest :as form]]
(if-let [[f & args] (and (seq? op) op)]
(if-let [f-var (and (symbol? f) (resolve f))]
(into [(seq (into [(symbol (str (ns-name (.ns f-var)))
(str (.sym f-var)))] args))]
rest)
form)
form)) where)))))
(defn db
"Given a list of ASTs, returns a representation of those
that can be used as a database in a Datomic Datalog query."
[asts]
(mapcat ast/ast->eav asts))
(defn q
"Execute a Datomic Datalog query against the ASTs.
The first input is always assumed to be an AST database, if more
are required, it's required to call `db` on them.
`unfold-expression-clauses` is automatically applied to the
query."
[query asts & inputs]
(compile-if (Class/forName "datomic.Datom")
(do (require '[datomic.api :as d])
(apply (resolve 'datomic.api/q) (unfold-expression-clauses query) (db asts) inputs))
(throw (Exception. "Datomic is required"))))
tools.analyzer-tools.analyzer-1.0.0/src/main/clojure/clojure/tools/analyzer/env.clj 0000664 0000000 0000000 00000003525 13622775470 0030570 0 ustar 00root root 0000000 0000000 ;; Copyright (c) Nicola Mometto, Rich Hickey & contributors.
;; The use and distribution terms for this software are covered by the
;; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php)
;; which can be found in the file epl-v10.html at the root of this distribution.
;; By using this software in any fashion, you are agreeing to be bound by
;; the terms of this license.
;; You must not remove this notice, or any other, from this software.
(ns clojure.tools.analyzer.env
(:refer-clojure :exclude [ensure]))
(def ^:dynamic *env*
"Global env atom
Required options:
* :namespaces an atom containing a map from namespace symbol to namespace map,
the namespace map contains at least the following keys:
** :mappings a map of mappings of the namespace, symbol to var/class
** :aliases a map of the aliases of the namespace, symbol to symbol
** :ns a symbol representing the namespace"
nil)
(defmacro with-env
"Binds the global env to env, then executes the body"
[env & body]
`(let [env# ~env
env# (cond
(map? env#) (atom env#)
(and (instance? clojure.lang.Atom env#)
(map? @env#)) env#
:default (throw (ex-info (str "global env must be a map or atom containing a map, not "
(class env#))
{:env env#})))]
(binding [*env* env#] ~@body)))
;; if *env* is not bound, bind it to env
(defmacro ensure
"If *env* is not bound it binds it to env before executing the body"
[env & body]
`(if *env*
(do ~@body)
(with-env ~env
~@body)))
(defn deref-env
"Returns the value of the current global env if bound, otherwise
throws an exception."
[]
(if *env*
@*env*
(throw (Exception. "global env not bound"))))
tools.analyzer-tools.analyzer-1.0.0/src/main/clojure/clojure/tools/analyzer/passes.clj 0000664 0000000 0000000 00000023023 13622775470 0031271 0 ustar 00root root 0000000 0000000 (ns clojure.tools.analyzer.passes
"Utilities for pass scheduling"
(:require [clojure.tools.analyzer.ast :refer [prewalk postwalk]]
[clojure.tools.analyzer.utils :refer [update-vals]]))
(defn ^:private has-deps?
"Returns true if the pass has any dependencies"
[pass]
(seq (:dependencies pass)))
(defn ^:private indicize
"Takes a set of pass-infos and returns a map of pass-name -> pass-info"
[passes]
(zipmap (map :name passes) passes))
(defn ^:private remove-pass
"Takes a set of pass-infos and a pass, and removes the pass from the set of
pass-infos, updating :dependencies and :dependants as well."
[passes pass]
(indicize (reduce (fn [m p] (conj m (-> p (update-in [:dependencies] disj pass)
(update-in [:dependants] disj pass))))
#{} (vals (dissoc passes pass)))))
(defn desugar-deps
"Takes a map of pass-name -> pass deps and puts the :after :affects and :before passes
in the appropriate pass :depends"
[passes]
(reduce-kv (fn [m name {:keys [after affects before]}]
(reduce (fn [m p] (update-in m [p :depends] (fnil conj #{}) name))
(update-in m [name :depends] (fnil into #{}) (into affects (filter passes after)))
before)) passes passes))
(defn ^:private calc-deps
"Takes a map of pass-name -> pass deps, a pass name, the explicit pass dependencies
and a set of available pass-infos.
Resolves all the transitive deps of the pass and assocs them to the map, indexed by
the pass name."
[m k deps passes]
(if (m k)
m
(reduce (fn [m dep]
(let [m (calc-deps m dep (get-in passes [dep :depends]) passes)]
(update-in m [k] into (conj (or (m dep) #{}) dep))))
(assoc m k deps) deps)))
(defn calculate-deps
"Takes a map of pass-name -> pass-info and adds to each pass-info :dependencies and
:dependants info, which also contains the transitive dependencies"
[passes]
(let [passes (desugar-deps passes)
dependencies (reduce-kv (fn [deps pname {:keys [depends]}]
(calc-deps deps pname depends passes))
{} passes)
dependants (reduce-kv (fn [m k v] (reduce (fn [m v] (update-in m [v] (fnil conj #{}) k))
(update-in m [k] (fnil into #{}) nil) v))
{} dependencies)]
(reduce-kv (fn [m k v] (assoc m k (merge (dissoc (passes k) :depends)
{:dependencies (set v) :dependants (set (dependants k))})))
{} dependencies)))
(defn group
"Takes a scheduler state and returns a vector of three elements (or nil):
* the :walk of the current group
* a vector of consecutive passes that can be collapsed in a single pass (the current group)
* the remaining scheduler state
E.g. given:
[{:walk :any .. } {:walk :pre ..} {:walk :post ..} {:walk :pre ..}]
it will return:
[:pre [{:walk :any ..} {:walk :pre ..}] [{:walk :post ..} {:walk :pre ..}]]"
[state]
(loop [w nil group [] [cur & rest :as state] state]
(if (seq state)
(cond
(:affects (last group))
[w group state]
w
(if (#{w :any} (:walk cur))
(recur w (conj group cur) rest)
[w group state])
:else
(case (:walk cur)
:any
(recur nil (conj group cur) rest)
:none
[w group state]
(recur (:walk cur) (conj group cur) rest)))
[w group state])))
(defn satisfies-affected? [{:keys [affects walk]} passes]
(loop [passes passes]
(let [free (vals (filter (comp empty? :dependants val) passes))]
(if-let [available-passes (seq (filter (comp #{walk :any} :walk) free))]
(recur (reduce remove-pass passes (mapv :name available-passes)))
(empty? (filter (fn [{:keys [name]}] ((set affects) name)) (vals passes)))))))
(defn maybe-looping-pass [free passes]
(if-let [looping (seq (filter :affects free))]
(loop [[l & ls] looping]
(if l
(if (satisfies-affected? l (remove-pass passes (:name l)))
;; all deps satisfied
l
(recur ls))
(if-let [p (first (remove :affects free))]
;; pick a random avaliable non-looping pass
p
(throw (ex-info (str "looping pass doesn't encompass affected passes: " (:name l))
{:pass l})))))
;; pick a random available pass
(first free)))
(def ^:private ffilter (comp first filter))
(defn ^:private first-walk [f c]
(ffilter (comp #{f} :walk) c))
(defn schedule* [state passes]
(let [free (filter (comp empty? :dependants) (vals passes))
w (first (group state))
non-looping-free (remove :affects free)]
(if (seq passes)
(let [{:keys [name] :as pass} (or (ffilter :compiler free)
(and w (or (first-walk w non-looping-free)
(first-walk :any non-looping-free)))
(first-walk :none free)
(maybe-looping-pass free passes))]
(recur (cons (assoc pass :passes [name]) state)
(remove-pass passes name)))
state)))
(defn collapse [state]
(loop [[cur & rest :as state] state ret []]
(if (seq state)
(if (= :none (:walk cur))
(recur rest (conj ret cur))
(let [[w g state] (group state)]
(recur state (conj ret {:walk (or w :pre) :passes (mapv :name g)}))))
ret)))
(defn schedule-passes
[passes]
(let [passes (calculate-deps passes)]
(when (every? has-deps? (vals passes))
(throw (ex-info "Dependency cycle detected" passes)))
(when (next (filter :compiler (vals passes)))
(throw (ex-info "Only one compiler pass allowed" passes)))
(collapse (schedule* () passes))))
(defn compile-passes [passes walk info]
(let [with-state (filter (comp :state info) passes)
state (zipmap with-state (mapv #(:state (info %)) with-state))
pfns (reduce (fn [f p]
(let [i (info p)
p (cond
(:state i)
(fn [_ s ast] (p (s p) ast))
(:affects i)
(fn [a _ ast] ((p a) ast))
:else
(fn [_ _ ast] (p ast)))]
(fn [a s ast]
(p a s (f a s ast))))) (fn [_ _ ast] ast) passes)]
(fn analyze [ast]
(walk ast (partial pfns analyze (update-vals state #(%)))))))
(defn schedule
"Takes a set of Vars that represent tools.analyzer passes and returns a function
that takes an AST and applies all the passes and their dependencies to the AST,
trying to compose together as many passes as possible to reduce the number of
full tree traversals.
Each pass must have a :pass-info element in its Var's metadata and it must point
to a map with the following parameters (:before, :after, :affects and :state are
optional):
* :after a set of Vars, the passes that must be run before this pass
* :before a set of Vars, the passes that must be run after this pass
* :depends a set of Vars, the passes this pass depends on, implies :after
* :walk a keyword, one of:
- :none if the pass does its own tree walking and cannot be composed
with other passes
- :post if the pass requires a postwalk and can be composed with other
passes
- :pre if the pass requires a prewalk and can be composed with other
passes
- :any if the pass can be composed with other passes in both a prewalk
or a postwalk
* :affects a set of Vars, this pass must be the last in the same tree traversal that all
the specified passes must participate in
This pass must take a function as argument and return the actual pass, the
argument represents the reified tree traversal which the pass can use to
control a recursive traversal, implies :depends
* :state a no-arg function that should return an atom holding an init value that will be
passed as the first argument to the pass (the pass will thus take the ast
as the second parameter), the atom will be the same for the whole tree traversal
and thus can be used to preserve state across the traversal
An opts map might be provided, valid parameters:
* :debug? if true, returns a vector of the scheduled passes rather than the concrete
function"
[passes & [opts]]
{:pre [(set? passes)
(every? var? passes)]}
(let [info (indicize (mapv (fn [p] (merge {:name p} (:pass-info (meta p)))) passes))
passes+deps (into passes (mapcat :depends (vals info)))]
(if (not= passes passes+deps)
(recur passes+deps [opts])
(if (:debug? opts)
(mapv #(select-keys % [:passes :walk])
(schedule-passes info))
(reduce (fn [f {:keys [passes walk]}]
(let [pass (if (= walk :none)
(first passes)
(compile-passes passes (if (= :pre walk) prewalk postwalk) info))]
(comp pass f)))
identity (schedule-passes info))))))
tools.analyzer-tools.analyzer-1.0.0/src/main/clojure/clojure/tools/analyzer/passes/ 0000775 0000000 0000000 00000000000 13622775470 0030577 5 ustar 00root root 0000000 0000000 add_binding_atom.clj 0000664 0000000 0000000 00000002646 13622775470 0034464 0 ustar 00root root 0000000 0000000 tools.analyzer-tools.analyzer-1.0.0/src/main/clojure/clojure/tools/analyzer/passes ;; Copyright (c) Nicola Mometto, Rich Hickey & contributors.
;; The use and distribution terms for this software are covered by the
;; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php)
;; which can be found in the file epl-v10.html at the root of this distribution.
;; By using this software in any fashion, you are agreeing to be bound by
;; the terms of this license.
;; You must not remove this notice, or any other, from this software.
(ns clojure.tools.analyzer.passes.add-binding-atom
(:require [clojure.tools.analyzer.ast :refer [prewalk]]
[clojure.tools.analyzer.passes.uniquify :refer [uniquify-locals]]))
(defn add-binding-atom
"Adds an atom-backed-map to every local binding,the same
atom will be shared between all occurences of that local.
The atom is put in the :atom field of the node."
{:pass-info {:walk :pre :depends #{#'uniquify-locals} :state (fn [] (atom {}))}}
([ast] (prewalk ast (partial add-binding-atom (atom {}))))
([state ast]
(case (:op ast)
:binding
(let [a (atom {})]
(swap! state assoc (:name ast) a)
(assoc ast :atom a))
:local
(if-let [a (@state (:name ast))]
(assoc ast :atom a)
;; handle injected locals
(let [a (get-in ast [:env :locals (:name ast) :atom] (atom {}))]
(swap! state assoc (:name ast) a)
(assoc ast :atom a)))
ast)))
tools.analyzer-tools.analyzer-1.0.0/src/main/clojure/clojure/tools/analyzer/passes/cleanup.clj 0000664 0000000 0000000 00000001374 13622775470 0032725 0 ustar 00root root 0000000 0000000 ;; Copyright (c) Nicola Mometto, Rich Hickey & contributors.
;; The use and distribution terms for this software are covered by the
;; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php)
;; which can be found in the file epl-v10.html at the root of this distribution.
;; By using this software in any fashion, you are agreeing to be bound by
;; the terms of this license.
;; You must not remove this notice, or any other, from this software.
(ns clojure.tools.analyzer.passes.cleanup)
(defn cleanup
{:pass-info {:walk :any :depends #{}}}
[ast]
(-> ast
(update-in [:env] dissoc :loop-locals-casts)
(update-in [:env :locals] #(reduce-kv (fn [m k l] (assoc m k (dissoc l :env :init))) {} %))
(dissoc :atom)))
collect_closed_overs.clj 0000664 0000000 0000000 00000007744 13622775470 0035422 0 ustar 00root root 0000000 0000000 tools.analyzer-tools.analyzer-1.0.0/src/main/clojure/clojure/tools/analyzer/passes ;; Copyright (c) Nicola Mometto, Rich Hickey & contributors.
;; The use and distribution terms for this software are covered by the
;; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php)
;; which can be found in the file epl-v10.html at the root of this distribution.
;; By using this software in any fashion, you are agreeing to be bound by
;; the terms of this license.
;; You must not remove this notice, or any other, from this software.
(ns clojure.tools.analyzer.passes.collect-closed-overs
(:require [clojure.tools.analyzer.ast :refer [update-children]]
[clojure.tools.analyzer.env :as env]
[clojure.tools.analyzer.passes.cleanup :refer [cleanup]]
[clojure.tools.analyzer.passes.uniquify :refer [uniquify-locals]]))
(def ^:private ^:dynamic *collects*)
(declare collect-closed-overs*)
(defn -collect-closed-overs
[ast]
(-> (case (:op ast)
:letfn ;; seed letfn bindings
(let [bindings (:bindings ast)]
(doseq [{:keys [name]} bindings]
(swap! *collects* #(update-in % [:locals] conj name)))
ast)
:binding
(let [name (:name ast)]
(if (= :field (:local ast))
(swap! *collects* #(assoc-in % [:closed-overs name] (cleanup ast))) ;; special-case: put directly as closed-overs
(swap! *collects* #(update-in % [:locals] conj name))) ;; register the local as a frame-local locals
ast)
:local
(let [name (:name ast)]
(when-not ((:locals @*collects*) name) ;; if the local is not in the frame-local locals
(swap! *collects* #(assoc-in % [:closed-overs name] (cleanup ast)))) ;; then it's from the outer frame locals, thus a closed-over
ast)
ast)
(update-children collect-closed-overs*))) ;; recursively collect closed-overs in the children nodes
(defn collect-closed-overs*
[{:keys [op] :as ast}]
(let [collects @*collects*
collect? ((:where collects) op)]
(if collect?
(let [[ast {:keys [closed-overs locals]}]
(binding [*collects* (atom (merge @*collects*
{:closed-overs {} :locals #{}}))]
[(update-children ast -collect-closed-overs) @*collects*])]
(swap! *collects* #(update-in % [:closed-overs] merge ;; propagate closed-overs from the inner frame to the outer frame
(into {}
(remove (fn [[_ {:keys [local]}]] ;; remove deftype fields from the closed-over locals
(and (= op :deftype)
(= :field local)))
(apply dissoc closed-overs ;; remove from the closed-overs locals that were
(:locals @*collects*)))))) ;; local to the inner frame
(assoc ast :closed-overs closed-overs))
(-collect-closed-overs ast))))
(defn collect-closed-overs
"Attach closed-overs info to the AST as specified by the passes opts:
* :where set of :op nodes where to attach the closed-overs
* :top-level? if true attach closed-overs info to the top-level node
The info will be attached in the :closed-overs field of the AST node
and will be a map of local name -> binding AST node"
{:pass-info {:walk :none :depends #{#'uniquify-locals}}}
[ast]
(let [passes-opts (:passes-opts (env/deref-env))
{:keys [top-level?] :as opts} {:where (or (:collect-closed-overs/where passes-opts) #{})
:top-level? (:collect-closed-overs/top-level? passes-opts)}]
(binding [*collects* (atom (merge opts {:closed-overs {} :locals #{}}))]
(let [ast (collect-closed-overs* ast)]
(if top-level?
(assoc ast :closed-overs (:closed-overs @*collects*))
ast)))))
constant_lifter.clj 0000664 0000000 0000000 00000004120 13622775470 0034405 0 ustar 00root root 0000000 0000000 tools.analyzer-tools.analyzer-1.0.0/src/main/clojure/clojure/tools/analyzer/passes ;; Copyright (c) Nicola Mometto, Rich Hickey & contributors.
;; The use and distribution terms for this software are covered by the
;; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php)
;; which can be found in the file epl-v10.html at the root of this distribution.
;; By using this software in any fashion, you are agreeing to be bound by
;; the terms of this license.
;; You must not remove this notice, or any other, from this software.
(ns clojure.tools.analyzer.passes.constant-lifter
(:require [clojure.tools.analyzer.utils :refer [const-val]]))
(defmulti constant-lift
"If the node represents a collection with no metadata, and every item of that
collection is a literal, transform the node to an equivalent :const node."
{:pass-info {:walk :post :depends #{}}}
:op)
(defmethod constant-lift :vector
[{:keys [items form env] :as ast}]
(if (and (every? :literal? items)
(empty? (meta form)))
(merge (dissoc ast :items :children)
{:op :const
:val (mapv const-val items)
:type :vector
:literal? true})
ast))
(defmethod constant-lift :map
[{:keys [keys vals form env] :as ast}]
(if (and (every? :literal? keys)
(every? :literal? vals)
(empty? (meta form)))
(let [c (into (empty form)
(zipmap (mapv const-val keys)
(mapv const-val vals)))
c (if (= (class c) (class form))
c
(apply array-map (mapcat identity c)))]
(merge (dissoc ast :keys :vals :children)
{:op :const
:val c
:type :map
:literal? true}))
ast))
(defmethod constant-lift :set
[{:keys [items form env] :as ast}]
(if (and (every? :literal? items)
(empty? (meta form)))
(merge (dissoc ast :items :children)
{:op :const
:val (into (empty form) (mapv const-val items))
:type :set
:literal? true})
ast))
(defmethod constant-lift :default [ast] ast)
tools.analyzer-tools.analyzer-1.0.0/src/main/clojure/clojure/tools/analyzer/passes/elide_meta.clj 0000664 0000000 0000000 00000005617 13622775470 0033372 0 ustar 00root root 0000000 0000000 ;; Copyright (c) Nicola Mometto, Rich Hickey & contributors.
;; The use and distribution terms for this software are covered by the
;; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php)
;; which can be found in the file epl-v10.html at the root of this distribution.
;; By using this software in any fashion, you are agreeing to be bound by
;; the terms of this license.
;; You must not remove this notice, or any other, from this software.
(ns clojure.tools.analyzer.passes.elide-meta
(:require [clojure.tools.analyzer.passes.source-info :refer [source-info]]))
(def ^:dynamic elides
"A map of op keywords to predicate IFns.
The predicate will be used to indicate what map keys should be elided on
metadata of nodes for that op.
:all can be used to indicate what should be elided for every node with
metadata.
Defaults to {:all (set (:elide-meta *compiler-options*))}"
{:all (set (:elide-meta *compiler-options*))})
(defn replace-meta [meta new-meta]
(if (= :const (:op meta))
(assoc meta :val new-meta)
(let [meta-map (mapv (fn [k v]
(when-not (elides (:form k))
[k v]))
(:keys meta) (:vals meta))]
(assoc meta
:keys (vec (keep first meta-map))
:vals (vec (keep second meta-map))))))
(defn get-elides [{:keys [op expr type]}]
(let [k (case op
:with-meta
(:op expr)
:const
type
nil)
f (get elides k)]
(if f
(some-fn (:all elides) f)
(:all elides))))
(defn -elide-meta
[{:keys [op meta expr env] :as ast}]
(let [form (:form meta)
new-meta (apply dissoc form (filter (get-elides ast) (keys form)))]
(case op
:const
(if (or (not meta)
(= new-meta (:form meta)))
ast
(if (not (empty? new-meta))
(assoc-in ast [:meta :val] new-meta)
(-> ast
(update-in [:val] with-meta nil)
(dissoc :children :meta))))
:with-meta
(if (not (empty? new-meta))
(if (= new-meta (:form meta))
ast
(assoc ast :meta (replace-meta meta new-meta)))
(merge (dissoc ast :meta :expr)
{:op :do
:body? true
:ret expr
:statements []
:children [:statements :ret]}))
:def
(if (not (empty? new-meta))
(if (= new-meta (:form meta))
ast
(assoc ast :meta (replace-meta meta new-meta)))
(assoc (dissoc ast :meta) :children [:init]))
ast)))
(defn elide-meta
"If elides is not empty and the AST node contains metadata,
dissoc all the keys in elides from the metadata."
{:pass-info {:walk :any :depends #{} :after #{#'source-info}}}
[ast]
(if (some #(if (seq? %) (seq %) %) (vals elides))
(-elide-meta ast)
ast))
tools.analyzer-tools.analyzer-1.0.0/src/main/clojure/clojure/tools/analyzer/passes/emit_form.clj 0000664 0000000 0000000 00000013500 13622775470 0033251 0 ustar 00root root 0000000 0000000 ;; Copyright (c) Nicola Mometto, Rich Hickey & contributors.
;; The use and distribution terms for this software are covered by the
;; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php)
;; which can be found in the file epl-v10.html at the root of this distribution.
;; By using this software in any fashion, you are agreeing to be bound by
;; the terms of this license.
;; You must not remove this notice, or any other, from this software.
(ns clojure.tools.analyzer.passes.emit-form
(:require [clojure.tools.analyzer.passes.uniquify :refer [uniquify-locals]]))
(defmulti -emit-form (fn [{:keys [op]} _] op))
(defn ^:dynamic -emit-form*
"Extension point for custom emit-form implementations, should be rebound
to a multimethod with custom emit-form :opts."
[{:keys [form] :as ast} opts]
(let [expr (-emit-form ast opts)]
(if-let [m (and (instance? clojure.lang.IObj expr)
(meta form))]
(with-meta expr (merge m (meta expr)))
expr)))
(defn emit-form
"Return the form represented by the given AST.
Opts is a set of options, valid options are:
* :hygienic"
{:pass-info {:walk :none :depends #{#'uniquify-locals} :compiler true}}
([ast] (emit-form ast #{}))
([ast opts] (-emit-form* ast opts)))
(defn emit-hygienic-form
"Return an hygienic form represented by the given AST"
{:pass-info {:walk :none :depends #{#'uniquify-locals} :compiler true}}
[ast]
(-emit-form* ast #{:hygienic}))
(defmethod -emit-form :maybe-class
[{:keys [class]} opts]
class)
(defmethod -emit-form :maybe-host-form
[{:keys [class field]} opts]
(symbol (name class) (name field)))
(defmethod -emit-form :host-call
[{:keys [target method args]} opts]
(list '. (-emit-form* target opts)
(list* method (mapv #(-emit-form* % opts) args))))
(defmethod -emit-form :host-field
[{:keys [target field]} opts]
(list '. (-emit-form* target opts)
(symbol (str "-" (name field)))))
(defmethod -emit-form :host-interop
[{:keys [target m-or-f]} opts]
(list '. (-emit-form* target opts) m-or-f))
(defmethod -emit-form :local
[{:keys [name form]} opts]
(if (:hygienic opts) (with-meta name (meta form)) form))
(defmethod -emit-form :binding
[{:keys [name form]} opts]
(if (:hygienic opts) (with-meta name (meta form)) form))
(defmethod -emit-form :var
[{:keys [form]} opts]
form)
(defn emit-bindings [bindings opts]
(mapcat (fn [{:keys [name form init]}]
[(if (:hygienic opts) name form) (-emit-form* init opts)])
bindings))
(defmethod -emit-form :letfn
[{:keys [bindings body]} opts]
`(letfn* [~@(emit-bindings bindings opts)]
~(-emit-form* body opts)))
(defmethod -emit-form :let
[{:keys [bindings body]} opts]
`(let* [~@(emit-bindings bindings opts)]
~(-emit-form* body opts)))
(defmethod -emit-form :loop
[{:keys [bindings body]} opts]
`(loop* [~@(emit-bindings bindings opts)]
~(-emit-form* body opts)))
(defmethod -emit-form :const
[{:keys [form]} _]
form)
(defmethod -emit-form :quote
[{:keys [expr]} opts]
(list 'quote (-emit-form* expr opts)))
(defmethod -emit-form :vector
[{:keys [items]} opts]
(mapv #(-emit-form* % opts) items))
(defmethod -emit-form :set
[{:keys [items]} opts]
(set (mapv #(-emit-form* % opts) items)))
(defmethod -emit-form :map
[{:keys [keys vals]} opts]
(apply hash-map (interleave (mapv #(-emit-form* % opts) keys)
(mapv #(-emit-form* % opts) vals))))
(defmethod -emit-form :with-meta
[{:keys [expr meta]} opts]
(with-meta (-emit-form* expr opts)
(-emit-form* meta opts)))
(defmethod -emit-form :do
[{:keys [ret statements body?]} opts]
(if (and body? (empty? statements))
(-emit-form* ret opts)
`(do ~@(mapv #(-emit-form* % opts) statements)
~(-emit-form* ret opts))))
(defmethod -emit-form :if
[{:keys [test then else]} opts]
`(if ~(-emit-form* test opts)
~(-emit-form* then opts)
~@(when-not (nil? (:form else))
[(-emit-form* else opts)])))
(defmethod -emit-form :new
[{:keys [class args]} opts]
`(new ~(-emit-form* class opts) ~@(mapv #(-emit-form* % opts) args)))
(defmethod -emit-form :set!
[{:keys [target val]} opts]
`(set! ~(-emit-form* target opts) ~(-emit-form* val opts)))
(defmethod -emit-form :recur
[{:keys [exprs]} opts]
`(recur ~@(mapv #(-emit-form* % opts) exprs)))
(defmethod -emit-form :fn-method
[{:keys [variadic? params body form]} opts]
(let [params-form (mapv #(-emit-form* % opts) params)]
`(~(with-meta
(if variadic? (into (pop params-form)
(conj '[&] (peek params-form)))
params-form)
(meta (first form)))
~(-emit-form* body opts))))
(defmethod -emit-form :fn
[{:keys [local methods]} opts]
`(fn* ~@(when local [(-emit-form* local opts)])
~@(mapv #(-emit-form* % opts) methods)))
(defmethod -emit-form :def
[{:keys [name doc init]} opts]
(let [name (if-let [arglists (:arglists (meta name))]
(with-meta name (assoc (meta name) :arglists (list 'quote arglists)))
name)]
`(def ~name ~@(when doc [doc]) ~@(when init [(-emit-form* init opts)]))))
(defmethod -emit-form :invoke
[{:keys [fn args meta]} opts]
(let [expr `(~(-emit-form* fn opts)
~@(mapv #(-emit-form* % opts) args))]
(if meta
(with-meta expr meta)
expr)))
(defmethod -emit-form :try
[{:keys [body catches finally]} opts]
`(try ~(-emit-form* body opts)
~@(mapv #(-emit-form* % opts) catches)
~@(when finally
[`(finally ~(-emit-form* finally opts))])))
(defmethod -emit-form :catch
[{:keys [class local body]} opts]
`(catch ~(-emit-form* class opts) ~(-emit-form* local opts)
~(-emit-form* body opts)))
(defmethod -emit-form :throw
[{:keys [exception]} opts]
`(throw ~(-emit-form* exception opts)))
index_vector_nodes.clj 0000664 0000000 0000000 00000002015 13622775470 0035071 0 ustar 00root root 0000000 0000000 tools.analyzer-tools.analyzer-1.0.0/src/main/clojure/clojure/tools/analyzer/passes ;; Copyright (c) Nicola Mometto, Rich Hickey & contributors.
;; The use and distribution terms for this software are covered by the
;; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php)
;; which can be found in the file epl-v10.html at the root of this distribution.
;; By using this software in any fashion, you are agreeing to be bound by
;; the terms of this license.
;; You must not remove this notice, or any other, from this software.
(ns clojure.tools.analyzer.passes.index-vector-nodes)
(defn index-vector-nodes
"Adds an :idx attribute to nodes in a vector children, representing the position
of the node vector."
{:pass-info {:walk :any :depends #{}}}
[ast]
(merge ast
(reduce (fn [m c]
(let [v (c ast)
v (if (vector? v)
(mapv (fn [x i] (assoc x :idx i ))
v (range))
v)]
(assoc m c v))) {} (:children ast))))
tools.analyzer-tools.analyzer-1.0.0/src/main/clojure/clojure/tools/analyzer/passes/source_info.clj 0000664 0000000 0000000 00000002133 13622775470 0033603 0 ustar 00root root 0000000 0000000 ;; Copyright (c) Nicola Mometto, Rich Hickey & contributors.
;; The use and distribution terms for this software are covered by the
;; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php)
;; which can be found in the file epl-v10.html at the root of this distribution.
;; By using this software in any fashion, you are agreeing to be bound by
;; the terms of this license.
;; You must not remove this notice, or any other, from this software.
(ns clojure.tools.analyzer.passes.source-info
(:require [clojure.tools.analyzer.utils :refer [-source-info merge']]
[clojure.tools.analyzer.ast :refer [update-children]]))
(defn -merge-source-info [source-info]
(fn [ast]
(update-in ast [:env] merge' source-info)))
(defn source-info
"Adds (when avaliable) :line, :column, :end-line, :end-column and :file info to the AST :env"
{:pass-info {:walk :pre :depends #{}}}
[ast]
(let [source-info (-source-info (:form ast) (:env ast))
merge-source-info (-merge-source-info source-info)]
(update-children (merge-source-info ast) merge-source-info)))
tools.analyzer-tools.analyzer-1.0.0/src/main/clojure/clojure/tools/analyzer/passes/trim.clj 0000664 0000000 0000000 00000003510 13622775470 0032243 0 ustar 00root root 0000000 0000000 ;; Copyright (c) Nicola Mometto, Rich Hickey & contributors.
;; The use and distribution terms for this software are covered by the
;; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php)
;; which can be found in the file epl-v10.html at the root of this distribution.
;; By using this software in any fashion, you are agreeing to be bound by
;; the terms of this license.
;; You must not remove this notice, or any other, from this software.
(ns clojure.tools.analyzer.passes.trim
(:require [clojure.tools.analyzer.passes.elide-meta :refer [elide-meta]]
[clojure.tools.analyzer.ast :refer [postwalk]]))
(defmulti -trim :op)
(defmethod -trim :default [ast] ast)
(defn preserving-raw-forms [{:keys [form raw-forms] :as ast} body]
(let [raw-forms (reverse (cons form raw-forms))]
(update-in (into ast body) [:raw-forms] into raw-forms)))
(defmethod -trim :do
[{:keys [statements ret form] :as ast}]
(if (and (every? :literal? statements)
(not (:tag (meta form))))
(preserving-raw-forms (dissoc ast :children :statements :ret) ret)
ast))
;;TODO: letfn/loop
(defmethod -trim :let
[{:keys [bindings body form] :as ast}]
(if (and (or (and (every? (comp :literal? :init) bindings)
(:literal? body))
(empty? bindings))
(not (:tag (meta form))))
(preserving-raw-forms (dissoc ast :children :bindings :body) body)
ast))
(defmethod -trim :try
[{:keys [catches finally body form] :as ast}]
(if (and (empty? catches)
(empty? finally)
(not (:tag (meta form))))
(preserving-raw-forms (dissoc ast :children :body :finally :catches) body)
ast))
(defn trim
"Trims the AST of unnecessary nodes, e.g. (do (do 1)) -> 1"
{:pass-info {:walk :none :depends #{} :after #{#'elide-meta}}}
[ast]
(postwalk ast -trim))
tools.analyzer-tools.analyzer-1.0.0/src/main/clojure/clojure/tools/analyzer/passes/uniquify.clj 0000664 0000000 0000000 00000006325 13622775470 0033150 0 ustar 00root root 0000000 0000000 ;; Copyright (c) Nicola Mometto, Rich Hickey & contributors.
;; The use and distribution terms for this software are covered by the
;; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php)
;; which can be found in the file epl-v10.html at the root of this distribution.
;; By using this software in any fashion, you are agreeing to be bound by
;; the terms of this license.
;; You must not remove this notice, or any other, from this software.
(ns clojure.tools.analyzer.passes.uniquify
(:require [clojure.tools.analyzer.ast :refer [update-children children]]
[clojure.tools.analyzer.utils :refer [update-vals]]
[clojure.tools.analyzer.env :as env]))
(def ^:dynamic *locals-counter*) ;; global counter, map sym -> count
(def ^:dynamic *locals-frame*) ;; holds the id for the locals in the current frame
(defn normalize [name]
(or (@*locals-frame* name) name))
(defn uniquify [name]
(swap! *locals-counter* #(update-in % [name] (fnil inc -1)))
(swap! *locals-frame* #(assoc-in % [name] (symbol (str name "__#" (@*locals-counter* name))))))
(defmulti -uniquify-locals :op)
(defn uniquify-locals-around
[ast]
(let [ast (if (-> (env/deref-env) :passes-opts :uniquify/uniquify-env)
(update-in ast [:env :locals]
update-vals #(update-in % [:name] normalize))
ast)]
(-uniquify-locals ast)))
(defn uniquify-locals* [ast]
(update-children ast uniquify-locals-around))
(defmethod -uniquify-locals :local
[ast]
(if (= :field (:local ast)) ;; deftype fields cannot be uniquified
ast ;; to allow field access/set! to work
(let [name (normalize (:name ast))]
(assoc ast :name name))))
(defn uniquify-binding
[b]
(let [i (binding [*locals-frame* (atom @*locals-frame*)] ;; inits need to be uniquified before the local
(uniquify-locals-around (:init b))) ;; to avoid potential shadowings
name (:name b)]
(uniquify name)
(let [name (normalize name)]
(assoc b
:name name
:init i))))
(defmethod -uniquify-locals :letfn
[ast]
(doseq [{:keys [name]} (:bindings ast)] ;; take into account that letfn
(uniquify name)) ;; accepts parallel bindings
(uniquify-locals* ast))
(defmethod -uniquify-locals :binding
[{:keys [name local] :as ast}]
(case local
(:let :loop)
(uniquify-binding ast)
:letfn
(-> ast
(assoc :name (normalize name))
uniquify-locals*)
:field
ast
(do (uniquify name)
(assoc ast :name (normalize name)))))
(defmethod -uniquify-locals :default
[ast]
(if (some #(= :binding (:op %)) (children ast))
(binding [*locals-frame* (atom @*locals-frame*)] ;; set up frame so locals won't leak
(uniquify-locals* ast))
(uniquify-locals* ast)))
(defn uniquify-locals
"Walks the AST performing alpha-conversion on the :name field
of :local/:binding nodes, invalidates :local map in :env field
Passes opts:
* :uniquify/uniquify-env If true, uniquifies the :env :locals map"
{:pass-info {:walk :none :depends #{}}}
[ast]
(binding [*locals-counter* (atom {})
*locals-frame* (atom {})]
(uniquify-locals-around ast)))
tools.analyzer-tools.analyzer-1.0.0/src/main/clojure/clojure/tools/analyzer/passes/warn_earmuff.clj 0000664 0000000 0000000 00000002470 13622775470 0033750 0 ustar 00root root 0000000 0000000 ;; Copyright (c) Nicola Mometto, Rich Hickey & contributors.
;; The use and distribution terms for this software are covered by the
;; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php)
;; which can be found in the file epl-v10.html at the root of this distribution.
;; By using this software in any fashion, you are agreeing to be bound by
;; the terms of this license.
;; You must not remove this notice, or any other, from this software.
(ns clojure.tools.analyzer.passes.warn-earmuff
(:require [clojure.tools.analyzer.utils :refer [dynamic?]]))
(defn warn-earmuff
"Prints a warning to *err* if the AST node is a :def node and the
var name contains earmuffs but the var is not marked dynamic"
{:pass-info {:walk :pre :depends #{}}}
[ast]
(let [name (str (:name ast))]
(when (and (= :def (:op ast))
(> (count name) 2) ;; Allow * and ** as non-dynamic names
(.startsWith name "*")
(.endsWith name "*")
(not (dynamic? (:var ast) (:val (:meta ast)))))
(binding [*out* *err*]
(println "Warning:" name "not declared dynamic and thus is not dynamically rebindable,"
"but its name suggests otherwise."
"Please either indicate ^:dynamic" name "or change the name"))))
ast)
tools.analyzer-tools.analyzer-1.0.0/src/main/clojure/clojure/tools/analyzer/utils.clj 0000664 0000000 0000000 00000014642 13622775470 0031142 0 ustar 00root root 0000000 0000000 ;; Copyright (c) Nicola Mometto, Rich Hickey & contributors.
;; The use and distribution terms for this software are covered by the
;; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php)
;; which can be found in the file epl-v10.html at the root of this distribution.
;; By using this software in any fashion, you are agreeing to be bound by
;; the terms of this license.
;; You must not remove this notice, or any other, from this software.
(ns clojure.tools.analyzer.utils
(:refer-clojure :exclude [record? boolean?])
(:require [clojure.tools.analyzer.env :as env])
(:import (clojure.lang IRecord IType IObj
IReference Var)))
(defn into!
"Like into, but for transients"
[to from]
(reduce conj! to from))
(defn rseqv
"Same as (comp vec rseq)"
[v]
(vec (rseq v)))
(defn ctx
"Returns a copy of the passed environment with :context set to ctx"
[env ctx]
(assoc env :context ctx))
(defn dissoc-env
"Dissocs :env from the ast"
[ast]
(dissoc ast :env))
(defn butlast+last
"Returns same value as (juxt butlast last), but slightly more
efficient since it only traverses the input sequence s once, not
twice."
[s]
(loop [butlast (transient [])
s s]
(if-let [xs (next s)]
(recur (conj! butlast (first s)) xs)
[(seq (persistent! butlast)) (first s)])))
(defn update-vals
"Applies f to all the vals in the map"
[m f]
(reduce-kv (fn [m k v] (assoc m k (f v))) {} (or m {})))
(defn update-keys
"Applies f to all the keys in the map"
[m f]
(reduce-kv (fn [m k v] (assoc m (f k) v)) {} (or m {})))
(defn update-kv
"Applies f to all the keys and vals in the map"
[m f]
(reduce-kv (fn [m k v] (assoc m (f k) (f v))) {} (or m {})))
(defn record?
"Returns true if x is a record"
[x]
(instance? IRecord x))
(defn type?
"Returns true if x is a type"
[x]
(instance? IType x))
(defn obj?
"Returns true if x implements IObj"
[x]
(instance? IObj x))
(defn reference?
"Returns true if x implements IReference"
[x]
(instance? IReference x))
(defmacro compile-if
[exp then & else]
(if (try (eval exp)
(catch Exception _ false))
`(do ~then)
`(do ~@else)))
(defn regex?
"Returns true if x is a regex"
[x]
(instance? (compile-if (Class/forName "java.util.regex.Pattern")
java.util.regex.Pattern
System.Text.RegularExpressions.Regex)
x))
(defn boolean?
"Returns true if x is a boolean"
[x]
(or (true? x) (false? x)))
(defn classify
"Returns a keyword describing the form type"
[form]
(cond
(nil? form) :nil
(boolean? form) :bool
(keyword? form) :keyword
(symbol? form) :symbol
(string? form) :string
(number? form) :number
(type? form) :type
(record? form) :record
(map? form) :map
(vector? form) :vector
(set? form) :set
(seq? form) :seq
(char? form) :char
(regex? form) :regex
(class? form) :class
(var? form) :var
:else :unknown))
(defn private?
"Returns true if the var is private"
([var] (private? var nil))
([var m]
(:private (or m (meta var)))))
(defn macro?
"Returns true if the var maps to a macro"
([var] (macro? var nil))
([var m]
(:macro (or m (meta var)))))
(defn constant?
"Returns true if the var is a const"
([var] (constant? var nil))
([var m]
(:const (or m (meta var)))))
(defn dynamic?
"Returns true if the var is dynamic"
([var] (dynamic? var nil))
([var m]
(or (:dynamic (or m (meta var)))
(when (var? var) ;; workaround needed since Clojure doesn't always propagate :dynamic
(.isDynamic ^Var var)))))
(defn protocol-node?
"Returns true if the var maps to a protocol function"
([var] (protocol-node? var nil))
([var m]
(boolean (:protocol (or m (meta var)))))) ;; conveniently this is true in both clojure and clojurescript
(defn resolve-ns
"Resolves the ns mapped by the given sym in the global env"
[ns-sym {:keys [ns]}]
(when ns-sym
(let [namespaces (:namespaces (env/deref-env))]
(or (get-in namespaces [ns :aliases ns-sym])
(:ns (namespaces ns-sym))))))
(defn resolve-sym
"Resolves the value mapped by the given sym in the global env"
[sym {:keys [ns] :as env}]
(when (symbol? sym)
(let [sym-ns (when-let [ns (namespace sym)]
(symbol ns))
full-ns (resolve-ns sym-ns env)]
(when (or (not sym-ns) full-ns)
(let [name (if sym-ns (-> sym name symbol) sym)]
(-> (env/deref-env) :namespaces (get (or full-ns ns)) :mappings (get name)))))))
(defn arglist-for-arity
"Takes a fn node and an argc and returns the matching arglist"
[fn argc]
(let [arglists (->> fn :arglists (sort-by count))
arglist (->> arglists (filter #(= argc (count %))) first)
last-arglist (last arglists)]
(or arglist
(when (and (some '#{&} last-arglist)
(>= argc (- (count last-arglist) 2)))
last-arglist))))
(defn select-keys'
"Like clojure.core/select-keys, but uses transients and doesn't preserve meta"
[map keyseq]
(loop [ret (transient {}) keys (seq keyseq)]
(if keys
(let [entry (find map (first keys))]
(recur (if entry
(conj! ret entry)
ret)
(next keys)))
(persistent! ret))))
(defn merge'
"Like merge, but uses transients"
[m & mms]
(persistent! (reduce conj! (transient (or m {})) mms)))
(defn mapv'
"Like mapv, but short-circuits on reduced"
[f v]
(let [c (count v)]
(loop [ret (transient []) i 0]
(if (> c i)
(let [val (f (nth v i))]
(if (reduced? val)
(reduced (persistent! (reduce conj! (conj! ret @val) (subvec v (inc i)))))
(recur (conj! ret val) (inc i))))
(persistent! ret)))))
(defn source-info
"Returns the available source-info keys from a map"
[m]
(when (:line m)
(select-keys' m #{:file :line :column :end-line :end-column :source-span})))
(defn -source-info
"Returns the source-info of x"
[x env]
(merge' (source-info env)
(source-info (meta x))
(when-let [file (and (not= *file* "NO_SOURCE_FILE")
*file*)]
{:file file})))
(defn const-val
"Returns the value of a constant node (either :quote or :const)"
[{:keys [form val]}]
(or val form))
(def mmerge
"Same as (fn [m1 m2] (merge-with merge m2 m1))"
#(merge-with merge' %2 %1))
tools.analyzer-tools.analyzer-1.0.0/src/test/ 0000775 0000000 0000000 00000000000 13622775470 0021241 5 ustar 00root root 0000000 0000000 tools.analyzer-tools.analyzer-1.0.0/src/test/clojure/ 0000775 0000000 0000000 00000000000 13622775470 0022704 5 ustar 00root root 0000000 0000000 tools.analyzer-tools.analyzer-1.0.0/src/test/clojure/clojure/ 0000775 0000000 0000000 00000000000 13622775470 0024347 5 ustar 00root root 0000000 0000000 tools.analyzer-tools.analyzer-1.0.0/src/test/clojure/clojure/tools/ 0000775 0000000 0000000 00000000000 13622775470 0025507 5 ustar 00root root 0000000 0000000 tools.analyzer-tools.analyzer-1.0.0/src/test/clojure/clojure/tools/analyzer/ 0000775 0000000 0000000 00000000000 13622775470 0027334 5 ustar 00root root 0000000 0000000 tools.analyzer-tools.analyzer-1.0.0/src/test/clojure/clojure/tools/analyzer/core_test.clj 0000664 0000000 0000000 00000014725 13622775470 0032026 0 ustar 00root root 0000000 0000000 (ns clojure.tools.analyzer.core-test
(:refer-clojure :exclude [macroexpand-1])
(:require [clojure.tools.analyzer :as ana]
[clojure.tools.analyzer.ast :refer [postwalk]]
[clojure.tools.analyzer.env :refer [with-env]]
[clojure.tools.analyzer.passes.elide-meta :refer [elides elide-meta]]
[clojure.test :refer [deftest is]]
[clojure.tools.analyzer.utils :refer [resolve-sym]]))
(defn desugar-host-expr [[op & expr :as form]]
(if (symbol? op)
(let [opname (name op)]
(cond
(= (first opname) \.) ; (.foo bar ..)
(let [[target & args] expr
args (list* (symbol (subs opname 1)) args)]
(with-meta (list '. target (if (= 1 (count args)) ;; we don't know if (.foo bar) ia
(first args) args)) ;; a method call or a field access
(meta form)))
(= (last opname) \.) ;; (class. ..)
(with-meta (list* 'new (symbol (subs opname 0 (dec (count opname)))) expr)
(meta form))
:else form))
form))
(defn macroexpand-1 [form env]
(if (seq? form)
(let [op (first form)]
(if (ana/specials op)
form
(let [v (resolve-sym op env)]
(if (and (not (-> env :locals (get op))) ;; locals cannot be macros
(:macro (meta v)))
(apply v form env (rest form)) ; (m &form &env & args)
(desugar-host-expr form)))))
form))
(defmacro foo [] 1)
(def e {:context :ctx/expr
:locals {}
:ns 'user})
(def e1 (atom {:namespaces {'user {:mappings (into (ns-map 'clojure.core)
{'foo #'foo})
:aliases {}
:ns 'user}
'clojure.core {:mappings (ns-map 'clojure.core)
:aliases {}
:ns 'clojure.core}}}))
(defmacro ast [form]
`(binding [ana/macroexpand-1 macroexpand-1
ana/create-var ~(fn [sym env]
(doto (intern (:ns env) sym)
(reset-meta! (meta sym))))
ana/parse ana/-parse
ana/var? ~var?
elides {:all #{:line :column :file :source-span}}]
(with-env e1
(postwalk (ana/analyze '~form e) elide-meta))))
(defmacro mexpand [form]
`(with-env e1
(macroexpand-1 '~form e)))
(deftest analyzer-test
(let [nil-ast (ast nil)]
(is (= :const (:op nil-ast)))
(is (= :nil (:type nil-ast)))
(is (:literal? nil-ast)))
(let [v-ast (ast ^:foo [1 2])]
(is (= :with-meta (:op v-ast)))
(is (= :map (-> v-ast :meta :op)))
(is (= {:foo true} (-> v-ast :meta :form)))
(is (= [1 2] (-> v-ast :expr :form))))
(let [m-ast (ast {:a 1 :b 2})]
(is (= {:a 1 :b 2} (:form m-ast)))
(is (= [:a :b] (->> m-ast :keys (mapv :form))))
(is (= [1 2] (->> m-ast :vals (mapv :form)))))
(is (= 'a (mexpand a)))
(is (= ::foo (mexpand ::foo)))
(is (= '(new foo) (mexpand (foo.))))
(is (= '(new foo a) (mexpand (foo. a))))
(is (= 'foo/bar (mexpand foo/bar)))
(is (= '(. bar (foo 1)) (mexpand (.foo bar 1))))
(is (= '(. bar foo) (mexpand (.foo bar))))
(is (= 1 (mexpand (user/foo))))
(let [s-ast (:expr (ast '+))]
(is (= :symbol (:type s-ast)))
(is (= '+ (:form s-ast))))
(let [v-ast (ast +)]
(is (= :var (:op v-ast)))
(is (= '+ (:form v-ast)))
(is (= #'+ (:var v-ast)))
(is (not (:assignable? v-ast))))
(is (:assignable? (ast *warn-on-reflection*)))
(let [mh-ast (ast foo/bar)]
(is (= :maybe-host-form (:op mh-ast)))
(is (= 'foo (:class mh-ast)))
(is (= 'bar (:field mh-ast))))
(let [mc-ast (ast bar)]
(is (= :maybe-class (:op mc-ast)))
(is (= 'bar (:class mc-ast))))
(let [l-ast (ast (let [a 1] a))]
(is (= :local (-> l-ast :body :ret :op)))
(is (= :let (-> l-ast :body :ret :local))))
(let [do-ast (ast (do 1 2 3))]
(is (= 3 (-> do-ast :ret :form)))
(is (= [1 2] (->> do-ast :statements (mapv :form))))
(is (= :ctx/statement (-> do-ast :statements first :env :context))))
(let [if-ast (ast (if 1 2 3))]
(is (= [1 2 3] (->> if-ast ((juxt :test :then :else)) (mapv :form)))))
(let [new-ast (ast (foo. 1 2))]
(is (= 'foo (-> new-ast :class :form)))
(is (= [1 2] (->> new-ast :args (mapv :form)))))
(let [q-ast (:expr (ast '^{a b} [c d]))]
(is (= :const (-> q-ast :meta :op)))
(is (= :const (-> q-ast :op)))
(is (= '{a b} (-> q-ast :meta :form)))
(is (= '[c d] (-> q-ast :form))))
(let [s-ast (ast (set! *warn-on-reflection* true))]
(is (= :set! (:op s-ast)))
(is (= #'*warn-on-reflection* (-> s-ast :target :var)))
(is (= true (-> s-ast :val :form))))
(let [t-ast (ast (try 0 (catch E1 e e) (catch E2 e 2) (finally 3)))]
(is (= 0 (-> t-ast :body :ret :form)))
(is (= 2 (-> t-ast :catches second :body :ret :form)))
(is (= :maybe-class (-> t-ast :catches first :class :op)))
(is (= 'E1 (-> t-ast :catches first :class :class)))
(is (= 'e (-> t-ast :catches first :local :name)))
(is (= 3 (-> t-ast :finally :ret :form))))
(let [lfn-ast (ast (letfn [(a [] (b)) (b [] (a))] a))]
(is (= :letfn (-> lfn-ast :body :ret :local)))
(is (= '#{a b} (->> lfn-ast :bindings (mapv :name) set))))
(let [l-ast (ast (loop [x 1] (recur 2)))]
(is (= :loop (-> l-ast :bindings first :local)))
(is (= :ctx/return (-> l-ast :body :env :context))))
(let [f-ast (:ret (ast (fn a ([y & x] [x y]) ([] a) ([z] z))))]
(is (= 1 (-> f-ast :max-fixed-arity)) (:meta f-ast))
(is (:variadic? f-ast))
(is (= true (-> f-ast :methods first :variadic?))))
(let [d-ast (ast (def ^{c d} a 1))]
(is (= 'a (-> d-ast :name)))
(is (= '{c d} (-> d-ast :var meta (dissoc :line :column :file :source-span))))
(is (= (ns-resolve 'user 'a)
(-> e1 deref :namespaces (get 'user) :mappings (get 'a)))))
(let [hc-ast (ast (.foo bar baz))]
(is (= :host-call (-> hc-ast :op)))
(is (= 'foo (-> hc-ast :method))))
(let [hf-ast (ast (.-foo bar))]
(is (= :host-field (-> hf-ast :op)))
(is (= 'foo (-> hf-ast :field))))
(let [hi-ast (ast (.foo bar))]
(is (= :host-interop (-> hi-ast :op)))
(is (= 'foo (-> hi-ast :m-or-f))))
(let [i-ast (ast (1 2))]
(is (= :invoke (-> i-ast :op)))
(is (= 1 (-> i-ast :fn :form)))
(is (= [2] (->> i-ast :args (mapv :form))))))
tools.analyzer-tools.analyzer-1.0.0/src/test/clojure/clojure/tools/analyzer/passes_test.clj 0000664 0000000 0000000 00000012763 13622775470 0032374 0 ustar 00root root 0000000 0000000 (ns clojure.tools.analyzer.passes-test
(:refer-clojure :exclude [macroexpand-1])
(:require [clojure.tools.analyzer.ast :refer :all]
[clojure.test :refer [deftest is]]
[clojure.set :as set]
[clojure.tools.analyzer.core-test :refer [ast e e1]]
[clojure.tools.analyzer.passes.add-binding-atom :refer [add-binding-atom]]
[clojure.tools.analyzer.passes.source-info :refer [source-info]]
[clojure.tools.analyzer.passes.uniquify :refer [uniquify-locals]]
[clojure.tools.analyzer.passes.constant-lifter :refer [constant-lift]]
[clojure.tools.analyzer.passes.emit-form :refer [emit-form emit-hygienic-form]]
[clojure.tools.analyzer.env :refer [with-env]]))
(deftest passes-utils-test
(let [ast {:foo [{:a 1} {:a 2}] :bar [{:a 3}] :children [:foo :bar]}]
(is (= 2 (-> ast (prewalk (fn [ast] (if (:a ast)
(update-in ast [:a] inc)
ast)))
:foo first :a)))
(is (= 2 (-> ast (postwalk (fn [ast] (if (:a ast)
(update-in ast [:a] inc)
ast)))
:foo first :a)))
(is (= nil (-> ast (walk (fn [ast] (dissoc ast :a))
(fn [ast] (if (:a ast)
(update-in ast [:a] inc)
ast)))
:foo first :a)))
(is (= [3 2 1] (let [a (atom [])]
(-> ast (postwalk
(fn [ast] (when-let [el (:a ast)]
(swap! a conj el))
ast) :reversed))
@a)))
(is (= [[{:a 1} {:a 2}] [{:a 3}]] (mapv second (children* ast))))
(is (= [{:a 1} {:a 2} {:a 3}] (children ast)))))
(deftest add-binding-atom-test
(let [the-ast (prewalk (ast (let [a 1] a))
(partial add-binding-atom (atom {})))]
(swap! (-> the-ast :bindings first :atom) assoc :a 1)
(is (= 1 (-> the-ast :body :ret :atom deref :a)))))
(deftest source-info-test
(is (= 1 (-> {:form ^{:line 1} [1]} source-info :env :line)))
(is (= 1 (-> {:form ^{:column 1 :line 1} [1]} source-info :env :column)))
(is (= 1 (-> {:form ^{:end-line 1 :line 1} [1]} source-info :env :end-line)))
(is (= 1 (-> {:form ^{:end-column 1 :line 1} [1]} source-info :env :end-column))))
(deftest constant-lift-test
(is (= :const (-> (ast {:a {:b :c}}) (postwalk constant-lift) :op)))
(is (not= :const (-> (ast {:a {:b #()}}) (postwalk constant-lift) :op)))
(is (= :const (-> (ast [:foo 1 "bar" #{#"baz" {23 []}}])
(postwalk constant-lift) :op))))
(deftest uniquify-test
(let [the-ast (with-env e1
(uniquify-locals (ast (let [x 1 y x x (let [x x] x)]
(fn [y] x)))))]
(is (= 'x__#2 (-> the-ast :body :ret :ret :methods first :body :ret :name)))
(is (= 'y__#1 (-> the-ast :body :ret :ret :methods first :params first :name)))
(is (apply not= (->> the-ast :bindings (mapv :name))))))
(deftest emit-form-test
(is (= 1 (emit-form (ast 1))))
(is (= "a" (emit-form (ast "a"))))
(is (= :foo/bar (emit-form (ast :foo/bar))))
(is (= 'a (emit-form (ast a))))
(is (= 'a/b (emit-form (ast a/b))))
(is (= 'a.b (emit-form (ast a.b))))
(is (= 'a.b/c (emit-form (ast a.b/c))))
(is (= '(. b (a c)) (emit-form (ast (.a b c)))))
(is (= '(. b (a (c))) (emit-form (ast (.a b (c))))))
(is (= '(. b -a) (emit-form (ast (.-a b)))))
(is (= '(. b a) (emit-form (ast (.a b)))))
(is (= '(let* [a 1] a) (emit-form (ast (let [a 1] a)))))
(is (= '(fn* ([] nil)) (emit-form (ast (fn [])))))
(is (= '(fn* ([] nil) ([a] nil)) (emit-form (ast (fn ([]) ([a]))))))
(is (= '(loop* [a 1] (recur 2)) (emit-form (ast (loop [a 1] (recur 2))))))
(is (= ''a (emit-form (ast 'a))))
(is (= [1 2 3] (emit-form (ast [1 2 3]))))
(is (= {:a 1 [:b] 2} (emit-form (ast {:a 1 [:b] 2}))))
(is (= {:a 1} (meta (emit-form (ast ^{:a 1} [:foo])))))
(is (= '(do 1) (emit-form (ast (do 1)))))
(is (= '(do a b c) (emit-form (ast (do a b c)))))
(is (= '(if 1 2) (emit-form (ast (if 1 2)))))
(is (= '(if 1 2 3) (emit-form (ast (if 1 2 3)))))
(is (= '(new a b c) (emit-form (ast (a. b c)))))
(is (= '(set! a 1) (emit-form (ast (set! a 1)))))
(is (= '(def a 1) (emit-form (ast (def a 1)))))
(is (= '(def a "doc" 1) (emit-form (ast (def a "doc" 1)))))
(is (= '(a b) (emit-form (ast (a b)))))
(is (= '(try (throw 1) (catch e t b) (finally 2))
(emit-form (ast (try (throw 1) (catch e t b) (finally 2)))))))
(deftest emit-hygienic-form-test
(with-env e1
(is (= '(let* [a__#0 1 a__#1 a__#0] a__#1)
(emit-hygienic-form (uniquify-locals (ast (let [a 1 a a] a))))))
(is (= '(let* [x__#0 1] (fn* ([x__#1] x__#1)))
(emit-hygienic-form (uniquify-locals (ast (let [x 1] (fn [x] x)))))))
(is (= '(fn* x__#0 ([x__#1] x__#1))
(emit-hygienic-form (uniquify-locals (ast (fn x [x] x))))))))
(deftest deeply-nested-uniquify
(is (= '(fn* ([x__#0 y__#0 z__#0]
(let* [foo__#0 (fn* ([y__#1 z__#1] [y__#1 z__#1]))]
(foo__#0 x__#0 y__#0))))
(with-env e1
(emit-hygienic-form (uniquify-locals (ast (fn [x y z]
(let [foo (fn [y z]
[y z])]
(foo x y))))))))))
tools.analyzer-tools.analyzer-1.0.0/src/test/clojure/clojure/tools/analyzer/query_test.clj 0000664 0000000 0000000 00000002204 13622775470 0032230 0 ustar 00root root 0000000 0000000 (ns clojure.tools.analyzer.query-test
(:refer-clojure :exclude [macroexpand-1])
(:require [clojure.tools.analyzer.ast :refer :all]
[clojure.test :refer [deftest is]]
[clojure.tools.analyzer.core-test :refer [ast e]]
[clojure.tools.analyzer.ast.query :refer [q]]
[clojure.tools.analyzer.ast :as ast]
[clojure.tools.analyzer.utils :refer [compile-if]]
[clojure.tools.analyzer.passes.index-vector-nodes :refer [index-vector-nodes]]))
(compile-if (Class/forName "datomic.Datom")
(deftest query
(let [ast (ast/prewalk (ast (defn x [] "misplaced docstring" 1))
index-vector-nodes)]
(is (= "misplaced docstring"
(ffirst
(q '[:find ?docstring
:where
[?def :op :def]
[?def :init ?fn]
[?fn :methods ?method]
[?method :body ?body]
[?body :statements ?statement]
[?statement :val ?docstring]
[?statement :type :string]
[?statement :idx 0]]
[ast])))))))