ځD0('qOZg%6r99z[^,eQ572)2aޅOII)*tVO!}I -xpB 8(RUicUyvvmgo+(U h fq$fn[lcvӻG'#:~r36fb}N.B* r*W! h( ަ bTVUdKb?ik4o Bq8ZE)_XUmZb:flp*="]α/uAAz`nxXpɐg9 %87' ګQ[ ҂]4R@70 <ހH9'_42N%1,2K ֲK`<͌u3uOUG , XnQzѝ 'K r. ӆR"/H5p0 雷_yƦ3ރm&]03^"Α^~1|r Y>G=rԉقfJ7M2x+g,olkl bO !2 1';2`^/Yހ'Z2~]}g>g}_5Ly6_Cs 6O_D1;`gw |¡ߊ\#=ޑsXKUCz^pxgwgb?c%do co 4Q,|є` a LQ a| '< j = )eG jJq2Uwt2ΓHIS~S~ #>Ck:dXd@!_ PaSňOP Q8MyqM8 tv]8A.WQ@0g; 0@{)¥ E_dffasp?py?& 1/2 32f0,퍣(̰fq' JRzxBPY 3 )NXɃCcA`( #GkGPKy4c[gL 6!g(dZlFxۯPp[><#U؆{ n@7uJ,. _QQȧo^aX%^i 4YS3m > endobj xref 0 195 0000000000 65535 f 0000094042 00000 n 0000000642 00000 n 0000037181 00000 n 0000000022 00000 n 0000000623 00000 n 0000000762 00000 n 0000007168 00000 n 0000058993 00000 n 0000004396 00000 n 0000037929 00000 n 0000000870 00000 n 0000039536 00000 n 0000039321 00000 n 0000000904 00000 n 0000004375 00000 n 0000004432 00000 n 0000007147 00000 n 0000007527 00000 n 0000007204 00000 n 0000007507 00000 n 0000007635 00000 n 0000039031 00000 n 0000008539 00000 n 0000007744 00000 n 0000008519 00000 n 0000008647 00000 n 0000085335 00000 n 0000038578 00000 n 0000009318 00000 n 0000008757 00000 n 0000009298 00000 n 0000009426 00000 n 0000038212 00000 n 0000010033 00000 n 0000009524 00000 n 0000010013 00000 n 0000010141 00000 n 0000038092 00000 n 0000010671 00000 n 0000010239 00000 n 0000010651 00000 n 0000010779 00000 n 0000038252 00000 n 0000011814 00000 n 0000010877 00000 n 0000011794 00000 n 0000011922 00000 n 0000038132 00000 n 0000013016 00000 n 0000012032 00000 n 0000012996 00000 n 0000013124 00000 n 0000038951 00000 n 0000014014 00000 n 0000037305 00000 n 0000013234 00000 n 0000013994 00000 n 0000014123 00000 n 0000068964 00000 n 0000039758 00000 n 0000038172 00000 n 0000015233 00000 n 0000014245 00000 n 0000015213 00000 n 0000015342 00000 n 0000038828 00000 n 0000016232 00000 n 0000015464 00000 n 0000016212 00000 n 0000016341 00000 n 0000038498 00000 n 0000017392 00000 n 0000016463 00000 n 0000017372 00000 n 0000017501 00000 n 0000038334 00000 n 0000018379 00000 n 0000017623 00000 n 0000018359 00000 n 0000018488 00000 n 0000037968 00000 n 0000019524 00000 n 0000018610 00000 n 0000019504 00000 n 0000019633 00000 n 0000038538 00000 n 0000020594 00000 n 0000019755 00000 n 0000020574 00000 n 0000020703 00000 n 0000038991 00000 n 0000021831 00000 n 0000020825 00000 n 0000021811 00000 n 0000021940 00000 n 0000038416 00000 n 0000022922 00000 n 0000037431 00000 n 0000022062 00000 n 0000022901 00000 n 0000023032 00000 n 0000038910 00000 n 0000024203 00000 n 0000023155 00000 n 0000024182 00000 n 0000024315 00000 n 0000038786 00000 n 0000026107 00000 n 0000024438 00000 n 0000026085 00000 n 0000026219 00000 n 0000037845 00000 n 0000027666 00000 n 0000026353 00000 n 0000027644 00000 n 0000027778 00000 n 0000038292 00000 n 0000028691 00000 n 0000027912 00000 n 0000028670 00000 n 0000028803 00000 n 0000038618 00000 n 0000029466 00000 n 0000028914 00000 n 0000029445 00000 n 0000029578 00000 n 0000038868 00000 n 0000030307 00000 n 0000029677 00000 n 0000030286 00000 n 0000030419 00000 n 0000038744 00000 n 0000031143 00000 n 0000030530 00000 n 0000031122 00000 n 0000031255 00000 n 0000038050 00000 n 0000032527 00000 n 0000037564 00000 n 0000031354 00000 n 0000032505 00000 n 0000032656 00000 n 0000038456 00000 n 0000032767 00000 n 0000039071 00000 n 0000033216 00000 n 0000032796 00000 n 0000033195 00000 n 0000033329 00000 n 0000038660 00000 n 0000034905 00000 n 0000033428 00000 n 0000034883 00000 n 0000035018 00000 n 0000038374 00000 n 0000035815 00000 n 0000035152 00000 n 0000035794 00000 n 0000035928 00000 n 0000038008 00000 n 0000036500 00000 n 0000036027 00000 n 0000036479 00000 n 0000036613 00000 n 0000038702 00000 n 0000036969 00000 n 0000036712 00000 n 0000036948 00000 n 0000037082 00000 n 0000037887 00000 n 0000037683 00000 n 0000037792 00000 n 0000039181 00000 n 0000039239 00000 n 0000039433 00000 n 0000039491 00000 n 0000039645 00000 n 0000039703 00000 n 0000040185 00000 n 0000040434 00000 n 0000058970 00000 n 0000059705 00000 n 0000059963 00000 n 0000068942 00000 n 0000069420 00000 n 0000069664 00000 n 0000085312 00000 n 0000085757 00000 n 0000086017 00000 n 0000093859 00000 n 0000093881 00000 n 0000093918 00000 n 0000093972 00000 n 0000093999 00000 n trailer << /Size 195 /Root 172 0 R /Info 1 0 R /ID [ <0875988bdb4806ea7ba420b8003d054e> <0875988bdb4806ea7ba420b8003d054e> ] >> startxref 94152 %%EOF tools.analyzer.jvm-tools.analyzer.jvm-0.7.1/epl.html 0000664 0000000 0000000 00000030536 13122450003 0022516 0 ustar 00root root 0000000 0000000 Eclipse Public License - Version 1.0 Eclipse Public License - v 1.0
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.jvm-tools.analyzer.jvm-0.7.1/pom.xml 0000664 0000000 0000000 00000003305 13122450003 0022357 0 ustar 00root root 0000000 0000000tools.analyzer.jvm-tools.analyzer.jvm-0.7.1/project.clj 0000664 0000000 0000000 00000001445 13122450003 0023205 0 ustar 00root root 0000000 0000000 (defproject org.clojure/tools.analyzer.jvm "0.7.1-SNAPSHOT" :description "Additional jvm-specific passes for tools.analyzer." :url "https://github.com/clojure/tools.analyzer.jvm" :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-master-SNAPSHOT"] [org.clojure/core.memoize "0.5.9"] [org.clojure/tools.reader "1.0.0-beta4"] [org.clojure/tools.analyzer "0.6.9"] [org.ow2.asm/asm "5.2"]] :repositories [["sonatype" "http://oss.sonatype.org/content/repositories/releases"] ["snapshots" "http://oss.sonatype.org/content/repositories/snapshots"]]) tools.analyzer.jvm-tools.analyzer.jvm-0.7.1/spec/ 0000775 0000000 0000000 00000000000 13122450003 0021773 5 ustar 00root root 0000000 0000000 tools.analyzer.jvm-tools.analyzer.jvm-0.7.1/spec/ast-ref.edn 0000664 0000000 0000000 00000054615 13122450003 0024037 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"] [:tag "The tag this expression is required to have"] [:o-tag "The tag of this expression, based on the node's children"] ^:optional [:ignore-tag "`true` if this node returns a statement rather than an expression"] ^:optional [:loops "A set of the loop-ids that might cause this node to recur"]] :node-keys [{:op :binding :doc "Node for a binding symbol" :keys [[:form "The binding symbol"] [:name "The uniquified binding symbol"] [:local "One of :arg, :catch, :fn, :let, :letfn, :loop, :field or :this"] ^: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"] [:atom "An atom shared by this :binding node and all the :local nodes that refer to this binding"] #_ ^:optional [:to-clear? "When :local is :let, :loop, :catch or :arg, a boolean indicating whether this binding is never used and this is immediately eligible for clearing"]]} {:op :case :doc "Node for a case* special-form expression" :keys [[:form "`(case* expr shift maks default case-map switch-type test-type skip-check?)`"] ^:children [:test "The AST node for the expression to test against"] ^:children [:tests "A vector of :case-test AST nodes, each node has a corresponding :case-then node in the :thens field"] ^:children [:thens "A vector of :case-then AST nodes, each node has a corresponding :case-test node in the :tests field"] ^:children [:default "An AST node representing the default value of the case expression"] [:shift] [:mask] [:low] [:high] [:switch-type "One of :sparse or :compact"] [:test-type "One of :int, :hash-equiv or :hash-identity"] [:skip-check? "A set of case ints for which equivalence checking should not be done"]]} {:op :case-test :doc "Node for a test value in a case* expression" :keys [^:children [:test "A :const AST node representing the test value"] [:hash]]} {:op :case-then :doc "Node for a then expression in a case* expression" :keys [^:children [:then "An AST node representing the expression the case will evaluate to when the :test expression matches this node's corresponding :case-test value"] [:hash]]} {:op :catch :doc "Node for a catch expression" :keys [[:form "`(catch class local body*)`"] ^:children [:class "A :const AST node with :type :class 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"] #_ ^:optional [:id "A numeric id for the constant value, will be the same for every instance of this constant inside the same compilation unit, not present if :type is :nil or :bool"]]} {: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"] #_ [:id "A numeric id for this var, will be the same for every instance of this var inside the same compilation unit"]]} {:op :deftype :doc "Node for a deftype* special-form expression" :keys [[:form "`(deftype* name class.name [arg*] :implements [interface*] method*)`"] [:interfaces "A set of the interfaces implemented by the type"] [:name "The symbol name of the deftype"] [:class-name "A class for the deftype, should *never* be instantiated or used on instance? checks as this will not be the same class the deftype will evaluate to after compilation"] ^:children [:fields "A vector of :binding AST nodes with :local :field representing the deftype fields"] ^:children [:methods "A vector :method AST nodes representing the deftype methods"] #_#_#_#_ [:closed-overs "A map of field name -> :binding AST node of the field"] [:protocol-callsites "A map of protocol Vars that appear in the bodies of the deftype methods"] [:keyword-callsites "A map of keywords that appear in keyword-invoke position in the bodies of the deftype methods"] [:constants "A map of the constants that appear in the bodies of the deftype methods. The mapping is from a map with :form, :meta and :tag fields to a map with :id, :tag :val and :type fields, the :id will be the same for all every instance of this constant inside the same compilation unit."]]} {: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"] #_#_ [:internal-name "The internal name symbol used for the fn"] [:class-id "A unique id representing this function"] ^: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"] #_#_#_#_ [:closed-overs "A map of uniquified local name -> :binding AST node of the local, containing all the locals closed-over by this fn"] [:protocol-callsites "A map of protocol Vars that appear in the bodies of the fn methods"] [:keyword-callsites "A map of keywords that appear in keyword-invoke position in the bodies of the fn methods"] [:constants "A map of the constants that appear in the bodies of the fn methods. The mapping is from a map with :form, :meta and :tag fields to a map with :id, :tag :val and :type fields, the :id will be the same for all every instance of this constant inside the same compilation unit."]]} {: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-interop :doc "Node for a no-arg instance-call or for an instance-field that couldn't be resolved at compile time" :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 lookup 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 :import :doc "Node for a clojure.core/import* special-form expression" :keys [[:form "`(clojure.core/import* \"qualified.class\")`"] [:class "String representing the qualified class to import"]]} {:op :instance-call :doc "Node for an instance method call" :keys [[:form "`(.method instance arg*)`"] [:method "Symbol naming the invoked method"] ^:children [:instance "An AST node representing the instance to call the method on"] ^:children [:args "A vector of AST nodes representing the args passed to the method call"] ^:optional [:validated? "`true` if the method call could be resolved at compile time"] ^:optional [:class "If :validated? the class or interface the method belongs to"]]} {:op :instance-field :doc "Node for an instance field access" :keys [[:form "`(.-field instance)`"] [:field "Symbol naming the field to access"] ^:children [:instance "An AST node representing the instance to lookup the symbol on"] [:assignable? "`true` if the field is set!able"] [:class "The class the field belongs to"]]} {:op :instance? :doc "Node for a clojure.core/instance? call where the Class is known at compile time" :keys [[:form "`(clojure.core/instance? Class x)`"] [:class "The Class to test the :target for instanceability"] ^:children [:target "An AST node representing the object to test for instanceability"]]} {: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 :keyword-invoke :doc "Node for an invoke expression where the fn is a not-namespaced keyword and thus a keyword callsite can be emitted" :keys [[:form "`(:k instance)`"] ^:children [:keyword "An AST node representing the keyword to lookup in the instance"] ^:children [:target "An AST node representing the instance to lookup the keyword in"]]} {: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"] [:assignable? "`true` if the corresponding :binding AST node is :local :field and is declared either ^:volatile-mutable or ^:unsynchronized-mutable"] [:name "The uniquified local symbol"] [:local "One of :arg, :catch, :fn, :let, :letfn, :loop, :field or :this"] ^: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"] [:atom "An atom shared by this :local node, the :binding node this local refers to and all the other :local nodes that refer to this same local"] #_ ^:optional [:to-clear? "When :local is :let, :loop, :catch or :arg, a boolean indicating whether this local is eligible for locals clearing"]]} {: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"] #_ [:closed-overs "A map of uniquified local name -> :binding AST node of the local, containing all the locals closed-over by this loop"]]} {:op :map :doc "Node for a map literal with attached metadata and/or non literal elements" :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 :method :doc "Node for a method in a deftype* or reify* special-form expression" :keys [[:form "`(method [this arg*] body*)`"] [:bridges "A list of signature for bridge methods to emit"] [:interface "The interface (or Object) this method belongs to"] ^:children [:this "A :binding AST node with :local :this representing the \"this\" local"] [:loop-id "Unique symbol identifying this method as a target for recursion"] [:name "The symbol name of this method"] ^:children [:params "A vector of AST :binding nodes with :local :arg representing the arguments of the method"] [:fixed-arity "The number of args this method takes"] ^:children [:body "Synthetic :do node (with :body? `true`) representing the body of this method"]]} {:op :monitor-enter :doc "Node for a monitor-enter special-form statement" :keys [[:form "`(monitor-enter target)`"] ^:children [:target "An AST node representing the monitor-enter sentinel"]]} {:op :monitor-exit :doc "Node for a monitor-exit special-form statement" :keys [[:form "`(monitor-exit target)`"] ^:children [:target "An AST node representing the monitor-exit sentinel"]]} {:op :new :doc "Node for a new special-form expression" :keys [[:form "`(new Class arg*)`"] ^:children [:class "A :const AST node with :type :class representing the Class to instantiate"] ^:children [:args "A vector of AST nodes representing the arguments passed to the Class constructor"] ^:optional [:validated? "`true` if the constructor call could be resolved at compile time"]]} {:op :primitive-invoke :doc "Node for an invoke expression that can be optimized using one of the primitive interfaces in IFn" :keys [[:form "`(prim-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"] [:prim-interface "The primitive interface in IFn that will be used"] ^:optional [:meta "Map of metadata attached to the invoke :form"]]} {:op :protocol-invoke :doc "Node for an invoke expression where the function is a protocol function var" :keys [[:form "`(proto-fn target arg*)`"] ^:children [:protocol-fn "An AST node representing the protocol function var to invoke"] ^:children [:target "An AST node representing the target of the protocol function call"] ^:children [:args "A vector of AST nodes representing the args to the protocol function"]]} {: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 :reify :doc "Node for a reify* special-form expression" :keys [[:form "`(reify* [interface*] method*)`"] [:interfaces "A set of the interfaces implemented by the generated type"] [:class-name "The generated class for the reify, should *never* be instantiated or used on instance? checks"] ^:children [:methods "A vector :method AST nodes representing the reify methods"] #_#_#_#_#_ [:class-id "A unique id representing this reify"] [:closed-overs "A map of uniquified local name -> :binding AST node of the local, containing all the locals closed-over by this reify"] [:protocol-callsites "A map of protocol Vars that appear in the bodies of the reify methods"] [:keyword-callsites "A map of keywords that appear in keyword-invoke position in the bodies of the reify methods"] [:constants "A map of the constants that appear in the bodies of the reify methods. The mapping is from a map with :form, :meta and :tag fields to a map with :id, :tag :val and :type fields, the :id will be the same for all every instance of this constant inside the same compilation unit."]]} {:op :set :doc "Node for a set literal with attached metadata and/or non literal elements" :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 :static-call :doc "Node for a static method call" :keys [[:form "`(Class/method arg*)`"] [:class "The Class the static method belongs to"] [:method "The symbol name of the static method"] ^:children [:args "A vector of AST nodes representing the args to the method call"] ^:optional [:validated? "`true` if the static method could be resolved at compile time"]]} {:op :static-field :doc "Node for a static field access" :keys [[:form "`Class/field`"] [:class "The Class the static field belongs to"] [:field "The symbol name of the static field"] ^:optional [:assignable? "`true` if the static field is set!able"]]} {:op :the-var :doc "Node for a var special-form expression" :keys [[:form "`(var var-name)`"] [:var "The Var object this expression refers to"] #_ [:id "A numeric id for this var, will be the same for every instance of this var inside the same compilation unit"]]} {: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"] #_ [:id "A numeric id for this var, will be the same for every instance of this var inside the same compilation unit"]]} {: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 fn/reify expression with attached metadata" :keys [[:form "Non quoted collection literal or fn/reify 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, :fn or :reify"]]}]} tools.analyzer.jvm-tools.analyzer.jvm-0.7.1/spec/buildref.sh 0000775 0000000 0000000 00000000431 13122450003 0024124 0 ustar 00root root 0000000 0000000 #!/bin/sh java -cp .:`lein cp` clojure.main < 4.0.0 tools.analyzer.jvm 0.7.1 tools.analyzer.jvm Additional jvm-specific passes for tools.analyzer org.clojure pom.contrib 0.2.2 1.5.1 bronsa Nicola Mometto org.clojure tools.analyzer 0.6.9 org.clojure core.memoize 0.5.9 org.ow2.asm asm-all 4.2 org.clojure tools.reader 1.0.0-beta4 scm:git:git://github.com/clojure/tools.analyzer.jvm.git scm:git:git://github.com/clojure/tools.analyzer.jvm.git http://github.com/clojure/tools.analyzer.jvm tools.analyzer.jvm-0.7.1 (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 "" " \n")))) (def nav (apply str (for [{op :op} (:node-keys tej-ref) :let [op (name op)]] (str "" "#" op "
" "" doc "
" "" "
" "- :op
- " (apply str (for [[k d :as f] keys] (str "
:" op "- " k "
" "- " (if (:optional (meta f)) "optional ") (fix d) "
"))) (if-let [c (children keys)] (str "- :children
- " (join ", " (mapv (fn [c] (str "
")) "" c "")) c)) "" op " \n")))) (def common (apply str (str "" " \n"))) (spit "quickref.html" (-> html (replace "{nav}" nav) (replace "{common}" common) (replace "{nodes}" nodes))) tools.analyzer.jvm-tools.analyzer.jvm-0.7.1/spec/quickref.html.tpl 0000664 0000000 0000000 00000004022 13122450003 0025266 0 ustar 00root root 0000000 0000000" (apply str (for [[k d :as f] (:all-keys tej-ref)] (str "
" "- " k "
" "- " (if (:optional (meta f)) "optional ") (fix d) "
"))) "tools.analyzer.jvm AST Quickref tools.analyzer.jvm-tools.analyzer.jvm-0.7.1/src/ 0000775 0000000 0000000 00000000000 13122450003 0021630 5 ustar 00root root 0000000 0000000 tools.analyzer.jvm-tools.analyzer.jvm-0.7.1/src/main/ 0000775 0000000 0000000 00000000000 13122450003 0022554 5 ustar 00root root 0000000 0000000 tools.analyzer.jvm-tools.analyzer.jvm-0.7.1/src/main/clojure/ 0000775 0000000 0000000 00000000000 13122450003 0024217 5 ustar 00root root 0000000 0000000 tools.analyzer.jvm-tools.analyzer.jvm-0.7.1/src/main/clojure/clojure/ 0000775 0000000 0000000 00000000000 13122450003 0025662 5 ustar 00root root 0000000 0000000 tools.analyzer.jvm-tools.analyzer.jvm-0.7.1/src/main/clojure/clojure/tools/ 0000775 0000000 0000000 00000000000 13122450003 0027022 5 ustar 00root root 0000000 0000000 tools.analyzer.jvm-tools.analyzer.jvm-0.7.1/src/main/clojure/clojure/tools/analyzer/ 0000775 0000000 0000000 00000000000 13122450003 0030647 5 ustar 00root root 0000000 0000000 tools.analyzer.jvm-tools.analyzer.jvm-0.7.1/src/main/clojure/clojure/tools/analyzer/jvm.clj 0000664 0000000 0000000 00000056364 13122450003 0032153 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.jvm "Analyzer for clojure code, extends tools.analyzer with JVM specific passes/forms" (:refer-clojure :exclude [macroexpand-1 macroexpand]) (:require [clojure.tools.analyzer :as ana :refer [analyze analyze-in-env wrapping-meta analyze-fn-method] :rename {analyze -analyze}] [clojure.tools.analyzer [utils :refer [ctx resolve-sym -source-info resolve-ns obj? dissoc-env butlast+last mmerge]] [ast :refer [walk prewalk postwalk] :as ast] [env :as env :refer [*env*]] [passes :refer [schedule]]] [clojure.tools.analyzer.jvm.utils :refer :all :as u :exclude [box specials]] [clojure.tools.analyzer.passes [source-info :refer [source-info]] [trim :refer [trim]] [elide-meta :refer [elide-meta elides]] [warn-earmuff :refer [warn-earmuff]] [uniquify :refer [uniquify-locals]]] [clojure.tools.analyzer.passes.jvm [analyze-host-expr :refer [analyze-host-expr]] [box :refer [box]] [constant-lifter :refer [constant-lift]] [classify-invoke :refer [classify-invoke]] [validate :refer [validate]] [infer-tag :refer [infer-tag]] [validate-loop-locals :refer [validate-loop-locals]] [warn-on-reflection :refer [warn-on-reflection]] [emit-form :refer [emit-form]]] [clojure.java.io :as io] [clojure.tools.reader :as reader] [clojure.tools.reader.reader-types :as readers] [clojure.core.memoize :refer [memo-clear!]]) (:import (clojure.lang IObj RT Compiler Var) java.net.URL)) (def specials "Set of the special forms for clojure in the JVM" (into ana/specials '#{monitor-enter monitor-exit clojure.core/import* reify* deftype* case*})) (defn build-ns-map [] (into {} (mapv #(vector (ns-name %) {:mappings (merge (ns-map %) {'in-ns #'clojure.core/in-ns 'ns #'clojure.core/ns}) :aliases (reduce-kv (fn [a k v] (assoc a k (ns-name v))) {} (ns-aliases %)) :ns (ns-name %)}) (all-ns)))) (defn update-ns-map! [] ((get (env/deref-env) :update-ns-map! #()))) (defn global-env [] (atom {:namespaces (build-ns-map) :update-ns-map! (fn update-ns-map! [] (swap! *env* assoc-in [:namespaces] (build-ns-map)))})) (defn empty-env "Returns an empty env map" [] {:context :ctx/expr :locals {} :ns (ns-name *ns*)}) (defn desugar-symbol [form env] (let [sym-ns (namespace form)] (if-let [target (and sym-ns (not (resolve-ns (symbol sym-ns) env)) (maybe-class-literal sym-ns))] ;; Class/field (with-meta (list '. target (symbol (str "-" (name form)))) ;; transform to (. Class -field) (meta form)) form))) (defn desugar-host-expr [form env] (let [[op & expr] form] (if (symbol? op) (let [opname (name op) opns (namespace op)] (if-let [target (and opns (not (resolve-ns (symbol opns) env)) (maybe-class-literal opns))] ; (class/field ..) (let [op (symbol opname)] (with-meta (list '. target (if (zero? (count expr)) op (list* op expr))) (meta form))) (cond (.startsWith opname ".") ; (.foo bar ..) (let [[target & args] expr target (if-let [target (maybe-class-literal target)] (with-meta (list 'do target) {:tag 'java.lang.Class}) target) args (list* (symbol (subs opname 1)) args)] (with-meta (list '. target (if (= 1 (count args)) ;; we don't know if (.foo bar) is (first args) args)) ;; a method call or a field access (meta form))) (.endsWith opname ".") ;; (class. ..) (with-meta (list* 'new (symbol (subs opname 0 (dec (count opname)))) expr) (meta form)) :else form))) form))) (defn macroexpand-1 "If form represents a macro form or an inlineable function,returns its expansion, else returns form." ([form] (macroexpand-1 form (empty-env))) ([form env] (env/ensure (global-env) (cond (seq? form) (let [[op & args] form] (if (specials op) form (let [v (resolve-sym op env) m (meta v) local? (-> env :locals (get op)) macro? (and (not local?) (:macro m)) ;; locals shadow macros inline-arities-f (:inline-arities m) inline? (and (not local?) (or (not inline-arities-f) (inline-arities-f (count args))) (:inline m)) t (:tag m)] (cond macro? (let [res (apply v form (:locals env) (rest form))] ; (m &form &env & args) (update-ns-map!) (if (obj? res) (vary-meta res merge (meta form)) res)) inline? (let [res (apply inline? args)] (update-ns-map!) (if (obj? res) (vary-meta res merge (and t {:tag t}) (meta form)) res)) :else (desugar-host-expr form env))))) (symbol? form) (desugar-symbol form env) :else form)))) (defn qualify-arglists [arglists] (vary-meta arglists merge (when-let [t (:tag (meta arglists))] {:tag (if (or (string? t) (u/specials (str t)) (u/special-arrays (str t))) t (if-let [c (maybe-class t)] (let [new-t (-> c .getName symbol)] (if (= new-t t) t (with-meta new-t {::qualified? true}))) t))}))) (defn create-var "Creates a Var for sym and returns it. The Var gets interned in the env namespace." [sym {:keys [ns]}] (let [v (get-in (env/deref-env) [:namespaces ns :mappings (symbol (name sym))])] (if (and v (or (class? v) (= ns (ns-name (.ns ^Var v) )))) v (let [meta (dissoc (meta sym) :inline :inline-arities :macro) meta (if-let [arglists (:arglists meta)] (assoc meta :arglists (qualify-arglists arglists)) meta)] (intern ns (with-meta sym meta)))))) (defn parse-monitor-enter [[_ target :as form] env] (when-not (= 2 (count form)) (throw (ex-info (str "Wrong number of args to monitor-enter, had: " (dec (count form))) (merge {:form form} (-source-info form env))))) {:op :monitor-enter :env env :form form :target (-analyze target (ctx env :ctx/expr)) :children [:target]}) (defn parse-monitor-exit [[_ target :as form] env] (when-not (= 2 (count form)) (throw (ex-info (str "Wrong number of args to monitor-exit, had: " (dec (count form))) (merge {:form form} (-source-info form env))))) {:op :monitor-exit :env env :form form :target (-analyze target (ctx env :ctx/expr)) :children [:target]}) (defn parse-import* [[_ class :as form] env] (when-not (= 2 (count form)) (throw (ex-info (str "Wrong number of args to import*, had: " (dec (count form))) (merge {:form form} (-source-info form env))))) {:op :import :env env :form form :class class}) (defn analyze-method-impls [[method [this & params :as args] & body :as form] env] (when-let [error-msg (cond (not (symbol? method)) (str "Method method must be a symbol, had: " (class method)) (not (vector? args)) (str "Parameter listing should be a vector, had: " (class args)) (not (first args)) (str"Must supply at least one argument for 'this' in: " method))] (throw (ex-info error-msg (merge {:form form :in (:this env) :method method :args args} (-source-info form env))))) (let [meth (cons (vec params) body) ;; this is an implicit arg this-expr {:name this :env env :form this :op :binding :o-tag (:this env) :tag (:this env) :local :this} env (assoc-in (dissoc env :this) [:locals this] (dissoc-env this-expr)) method-expr (analyze-fn-method meth env)] (assoc (dissoc method-expr :variadic?) :op :method :form form :this this-expr :name (symbol (name method)) :children (into [:this] (:children method-expr))))) ;; HACK (defn -deftype [name class-name args interfaces] (doseq [arg [class-name name]] (memo-clear! members* [arg]) (memo-clear! members* [(str arg)])) (let [interfaces (mapv #(symbol (.getName ^Class %)) interfaces)] (eval (list 'let [] (list 'deftype* name class-name args :implements interfaces) (list 'import class-name))))) (defn parse-reify* [[_ interfaces & methods :as form] env] (let [interfaces (conj (disj (set (mapv maybe-class interfaces)) Object) IObj) name (gensym "reify__") class-name (symbol (str (namespace-munge *ns*) "$" name)) menv (assoc env :this class-name) methods (mapv #(assoc (analyze-method-impls % menv) :interfaces interfaces) methods)] (-deftype name class-name [] interfaces) (wrapping-meta {:op :reify :env env :form form :class-name class-name :methods methods :interfaces interfaces :children [:methods]}))) (defn parse-opts+methods [methods] (loop [opts {} methods methods] (if (keyword? (first methods)) (recur (assoc opts (first methods) (second methods)) (nnext methods)) [opts methods]))) (defn parse-deftype* [[_ name class-name fields _ interfaces & methods :as form] env] (let [interfaces (disj (set (mapv maybe-class interfaces)) Object) fields-expr (mapv (fn [name] {:env env :form name :name name :mutable (let [m (meta name)] (or (and (:unsynchronized-mutable m) :unsynchronized-mutable) (and (:volatile-mutable m) :volatile-mutable))) :local :field :op :binding}) fields) menv (assoc env :context :ctx/expr :locals (zipmap fields (map dissoc-env fields-expr)) :this class-name) [opts methods] (parse-opts+methods methods) methods (mapv #(assoc (analyze-method-impls % menv) :interfaces interfaces) methods)] (-deftype name class-name fields interfaces) {:op :deftype :env env :form form :name name :class-name class-name ;; internal, don't use as a Class :fields fields-expr :methods methods :interfaces interfaces :children [:fields :methods]})) (defn parse-case* [[_ expr shift mask default case-map switch-type test-type & [skip-check?] :as form] env] (let [[low high] ((juxt first last) (keys case-map)) ;;case-map is a sorted-map e (ctx env :ctx/expr) test-expr (-analyze expr e) [tests thens] (reduce (fn [[te th] [min-hash [test then]]] (let [test-expr (ana/analyze-const test e) then-expr (-analyze then env)] [(conj te {:op :case-test :form test :env e :hash min-hash :test test-expr :children [:test]}) (conj th {:op :case-then :form then :env env :hash min-hash :then then-expr :children [:then]})])) [[] []] case-map) default-expr (-analyze default env)] {:op :case :form form :env env :test (assoc test-expr :case-test true) :default default-expr :tests tests :thens thens :shift shift :mask mask :low low :high high :switch-type switch-type :test-type test-type :skip-check? skip-check? :children [:test :tests :thens :default]})) (defn parse "Extension to tools.analyzer/-parse for JVM special forms" [form env] ((case (first form) monitor-enter parse-monitor-enter monitor-exit parse-monitor-exit clojure.core/import* parse-import* reify* parse-reify* deftype* parse-deftype* case* parse-case* #_:else ana/-parse) form env)) (def default-passes "Set of passes that will be run by default on the AST by #'run-passes" #{#'warn-on-reflection #'warn-earmuff #'uniquify-locals #'source-info #'elide-meta #'constant-lift #'trim #'box #'analyze-host-expr #'validate-loop-locals #'validate #'infer-tag #'classify-invoke}) (def scheduled-default-passes (schedule default-passes)) (defn ^:dynamic run-passes "Function that will be invoked on the AST tree immediately after it has been constructed, by default runs the passes declared in #'default-passes, should be rebound if a different set of passes is required. Use #'clojure.tools.analyzer.passes/schedule to get a function from a set of passes that run-passes can be bound to." [ast] (scheduled-default-passes ast)) (def default-passes-opts "Default :passes-opts for `analyze`" {:collect/what #{:constants :callsites} :collect/where #{:deftype :reify :fn} :collect/top-level? false :collect-closed-overs/where #{:deftype :reify :fn :loop :try} :collect-closed-overs/top-level? false}) (defn analyze "Analyzes a clojure form using tools.analyzer augmented with the JVM specific special ops and returns its AST, after running #'run-passes on it. If no configuration option is provides, analyze will setup tools.analyzer using the extension points declared in this namespace. If provided, opts should be a map of options to analyze, currently the only valid options are :bindings and :passes-opts (if not provided, :passes-opts defaults to the value of `default-passes-opts`). If provided, :bindings should be a map of Var->value pairs that will be merged into the default bindings for tools.analyzer, useful to provide custom extension points. If provided, :passes-opts should be a map of pass-name-kw->pass-config-map pairs that can be used to configure the behaviour of each pass. E.g. (analyze form env {:bindings {#'ana/macroexpand-1 my-mexpand-1}})" ([form] (analyze form (empty-env) {})) ([form env] (analyze form env {})) ([form env opts] (with-bindings (merge {Compiler/LOADER (RT/makeClassLoader) #'ana/macroexpand-1 macroexpand-1 #'ana/create-var create-var #'ana/parse parse #'ana/var? var? #'elides (merge {:fn #{:line :column :end-line :end-column :file :source} :reify #{:line :column :end-line :end-column :file :source}} elides) #'*ns* (the-ns (:ns env))} (:bindings opts)) (env/ensure (global-env) (doto (env/with-env (mmerge (env/deref-env) {:passes-opts (get opts :passes-opts default-passes-opts)}) (run-passes (-analyze form env))) (do (update-ns-map!))))))) (deftype ExceptionThrown [e ast]) (defn ^:private throw! [e] (throw (.e ^ExceptionThrown e))) (defn analyze+eval "Like analyze but evals the form after the analysis and attaches the returned value in the :result field of the AST node. If evaluating the form will cause an exception to be thrown, the exception will be caught and wrapped in an ExceptionThrown object, containing the exception in the `e` field and the AST in the `ast` field. The ExceptionThrown object is then passed to `handle-evaluation-exception`, which by defaults throws the original exception, but can be used to provide a replacement return value for the evaluation of the AST. Unrolls `do` forms to handle the Gilardi scenario. Useful when analyzing whole files/namespaces." ([form] (analyze+eval form (empty-env) {})) ([form env] (analyze+eval form env {})) ([form env {:keys [handle-evaluation-exception] :or {handle-evaluation-exception throw!} :as opts}] (env/ensure (global-env) (update-ns-map!) (let [env (merge env (-source-info form env)) [mform raw-forms] (with-bindings {Compiler/LOADER (RT/makeClassLoader) #'*ns* (the-ns (:ns env)) #'ana/macroexpand-1 (get-in opts [:bindings #'ana/macroexpand-1] macroexpand-1)} (loop [form form raw-forms []] (let [mform (ana/macroexpand-1 form env)] (if (= mform form) [mform (seq raw-forms)] (recur mform (conj raw-forms (if-let [[op & r] (and (seq? form) form)] (if (or (u/macro? op env) (u/inline? op r env)) (vary-meta form assoc ::ana/resolved-op (resolve-sym op env)) form) form)))))))] (if (and (seq? mform) (= 'do (first mform)) (next mform)) ;; handle the Gilardi scenario (let [[statements ret] (butlast+last (rest mform)) statements-expr (mapv (fn [s] (analyze+eval s (-> env (ctx :ctx/statement) (assoc :ns (ns-name *ns*))) opts)) statements) ret-expr (analyze+eval ret (assoc env :ns (ns-name *ns*)) opts)] {:op :do :top-level true :form mform :statements statements-expr :ret ret-expr :children [:statements :ret] :env env :result (:result ret-expr) :raw-forms raw-forms}) (let [a (analyze mform env opts) frm (emit-form a) result (try (eval frm) ;; eval the emitted form rather than directly the form to avoid double macroexpansion (catch Exception e (handle-evaluation-exception (ExceptionThrown. e a))))] (merge a {:result result :raw-forms raw-forms}))))))) (defn analyze-ns "Analyzes a whole namespace, returns a vector of the ASTs for all the top-level ASTs of that namespace. Evaluates all the forms." ([ns] (analyze-ns ns (empty-env))) ([ns env] (analyze-ns ns env {})) ([ns env opts] (env/ensure (global-env) (let [res ^URL (ns-url ns)] (assert res (str "Can't find " ns " in classpath")) (let [filename (str res) path (.getPath res)] (when-not (get-in (env/deref-env) [::analyzed-clj path]) (binding [*ns* *ns* *file* filename] (with-open [rdr (io/reader res)] (let [pbr (readers/indexing-push-back-reader (java.io.PushbackReader. rdr) 1 filename) eof (Object.) read-opts {:eof eof :features #{:clj :t.a.jvm}} read-opts (if (.endsWith filename "cljc") (assoc read-opts :read-cond :allow) read-opts)] (loop [] (let [form (reader/read read-opts pbr)] (when-not (identical? form eof) (swap! *env* update-in [::analyzed-clj path] (fnil conj []) (analyze+eval form (assoc env :ns (ns-name *ns*)) opts)) (recur)))))))) (get-in @*env* [::analyzed-clj path])))))) (defn macroexpand-all "Like clojure.walk/macroexpand-all but correctly handles lexical scope" ([form] (macroexpand-all form (empty-env) {})) ([form env] (macroexpand-all form env {})) ([form env opts] (binding [run-passes emit-form] (analyze form env opts)))) tools.analyzer.jvm-tools.analyzer.jvm-0.7.1/src/main/clojure/clojure/tools/analyzer/jvm/ 0000775 0000000 0000000 00000000000 13122450003 0031443 5 ustar 00root root 0000000 0000000 tools.analyzer.jvm-tools.analyzer.jvm-0.7.1/src/main/clojure/clojure/tools/analyzer/jvm/utils.clj 0000664 0000000 0000000 00000030730 13122450003 0033300 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.jvm.utils (:require [clojure.tools.analyzer.utils :as u] [clojure.tools.analyzer.env :as env] [clojure.reflect :as reflect] [clojure.string :as s] [clojure.core.memoize :refer [lru]] [clojure.java.io :as io]) (:import (clojure.lang RT Symbol Var) org.objectweb.asm.Type)) (defn ^:private type-reflect [typeref & options] (apply reflect/type-reflect typeref :reflector (reflect/->JavaReflector (RT/baseLoader)) options)) (defn macro? [sym env] (when-let [v (u/resolve-sym sym env)] (and (not (-> env :locals (get sym))) (u/macro? v) v))) (defn inline? [sym args env] (when-let [v (u/resolve-sym sym env)] (let [inline-arities-f (:inline-arities (meta v))] (and (not (-> env :locals (get sym))) (or (not inline-arities-f) (inline-arities-f (count args))) (:inline (meta v)))))) (defn specials [c] (case c "byte" Byte/TYPE "boolean" Boolean/TYPE "char" Character/TYPE "int" Integer/TYPE "long" Long/TYPE "float" Float/TYPE "double" Double/TYPE "short" Short/TYPE "void" Void/TYPE "object" Object nil)) (defn special-arrays [c] (case c "bytes" (Class/forName "[B") "booleans" (Class/forName "[Z") "chars" (Class/forName "[C") "ints" (Class/forName "[I") "longs" (Class/forName "[J") "floats" (Class/forName "[F") "doubles" (Class/forName "[D") "shorts" (Class/forName "[S") "objects" (Class/forName "[Ljava.lang.Object;") nil)) (defmulti ^Class maybe-class "Takes a Symbol, String or Class and tires to resolve to a matching Class" class) (defn array-class [element-type] (RT/classForName (str "[" (-> element-type maybe-class Type/getType .getDescriptor (.replace \/ \.))))) (defn maybe-class-from-string [^String s] (or (when-let [maybe-class (and (neg? (.indexOf s ".")) (not= \[ (first s)) (if env/*env* (u/resolve-sym (symbol s) {:ns (ns-name *ns*)}) ((ns-map *ns*) (symbol s))))] (when (class? maybe-class) maybe-class)) (try (RT/classForName s) (catch ClassNotFoundException _)))) (defmethod maybe-class :default [_] nil) (defmethod maybe-class Class [c] c) (defmethod maybe-class String [s] (maybe-class (symbol s))) (defmethod maybe-class Symbol [sym] (when-not (namespace sym) (let [sname (name sym) snamec (count sname)] (if-let [base-type (and (.endsWith sname "<>") (maybe-class (subs sname 0 (- snamec 2))))] (array-class base-type) (if-let [ret (or (specials sname) (special-arrays sname))] ret (maybe-class-from-string sname)))))) (defn maybe-class-literal [x] (cond (class? x) x (symbol? x) (and (not (namespace x)) (maybe-class-from-string (name x))) (string? x) (maybe-class-from-string x))) (def primitive? "Returns non-nil if the argument represents a primitive Class other than Void" #{Double/TYPE Character/TYPE Byte/TYPE Boolean/TYPE Short/TYPE Float/TYPE Long/TYPE Integer/TYPE}) (def ^:private convertible-primitives "If the argument is a primitive Class, returns a set of Classes to which the primitive Class can be casted" {Integer/TYPE #{Integer Long/TYPE Long Short/TYPE Byte/TYPE Object Number} Float/TYPE #{Float Double/TYPE Object Number} Double/TYPE #{Double Float/TYPE Object Number} Long/TYPE #{Long Integer/TYPE Short/TYPE Byte/TYPE Object Number} Character/TYPE #{Character Object} Short/TYPE #{Short Object Number} Byte/TYPE #{Byte Object Number} Boolean/TYPE #{Boolean Object} Void/TYPE #{Void}}) (defn ^Class box "If the argument is a primitive Class, returns its boxed equivalent, otherwise returns the argument" [c] ({Integer/TYPE Integer Float/TYPE Float Double/TYPE Double Long/TYPE Long Character/TYPE Character Short/TYPE Short Byte/TYPE Byte Boolean/TYPE Boolean Void/TYPE Void} c c)) (defn ^Class unbox "If the argument is a Class with a primitive equivalent, returns that, otherwise returns the argument" [c] ({Integer Integer/TYPE, Long Long/TYPE, Float Float/TYPE, Short Short/TYPE, Boolean Boolean/TYPE, Byte Byte/TYPE, Character Character/TYPE, Double Double/TYPE, Void Void/TYPE} c c)) (defn numeric? "Returns true if the given class is numeric" [c] (when c (.isAssignableFrom Number (box c)))) (defn subsumes? "Returns true if c2 is subsumed by c1" [c1 c2] (let [c1 (maybe-class c1) c2 (maybe-class c2)] (and (not= c1 c2) (or (and (not (primitive? c1)) (primitive? c2)) (.isAssignableFrom c2 c1))))) (defn convertible? "Returns true if it's possible to convert from c1 to c2" [c1 c2] (let [c1 (maybe-class c1) c2 (maybe-class c2)] (if (nil? c1) (not (primitive? c2)) (or (= c1 c2) (.isAssignableFrom c2 c1) (and (primitive? c2) ((convertible-primitives c2) c1)) (and (primitive? c1) (.isAssignableFrom (box c1) c2)))))) (def wider-than "If the argument is a numeric primitive Class, returns a set of primitive Classes that are narrower than the given one" {Long/TYPE #{Integer/TYPE Short/TYPE Byte/TYPE} Integer/TYPE #{Short/TYPE Byte/TYPE} Float/TYPE #{Integer/TYPE Short/TYPE Byte/TYPE Long/TYPE} Double/TYPE #{Integer/TYPE Short/TYPE Byte/TYPE Long/TYPE Float/TYPE} Short/TYPE #{Byte/TYPE} Byte/TYPE #{}}) (defn wider-primitive "Given two numeric primitive Classes, returns the wider one" [from to] (if ((wider-than from) to) from to)) (defn wider-tag* "Given two Classes returns the wider one" [from to] (if (not= from to) (if (primitive? from) (if (primitive? to) (wider-primitive from to) (or (and (numeric? from) (numeric? to) to) ((convertible-primitives from) to))) (if (primitive? to) (or (and (numeric? from) (numeric? to) from) ((convertible-primitives to) from)) (if (convertible? from to) to (when (convertible? to from) from)))) from)) (defn wider-tag "Given a collection of Classes returns the wider one" [tags] (let [tags* (filter identity tags) wider (loop [wider (first tags*) tags* (rest tags*)] (if (seq tags*) (if-let [t (wider-tag* wider (first tags*))] (recur t (rest tags*))) wider))] (when (or (= tags* tags) (not (primitive? wider))) wider))) (defn name-matches? [member] (let [member-name (str member) i (.lastIndexOf member-name ".") member-name* (when (pos? i) (str (s/replace (subs member-name 0 i) "-" "_") (subs member-name i))) member-name** (s/replace member-name "-" "_") member-name*** (munge member-name)] (fn [name] (let [name (str name)] (or (= member-name name) (= member-name* name) (= member-name** name) (= member-name*** name)))))) (def object-members (:members (type-reflect Object))) (def members* (lru (fn members* ([class] (into object-members (remove (fn [{:keys [flags]}] (not-any? #{:public :protected} flags)) (-> class maybe-class ^Class (box) .getName symbol (type-reflect :ancestors true) :members))))))) (defn members ([class] (members* class)) ([class member] (when-let [members (filter #((name-matches? member) (:name %)) (members* class))] members))) (defn static-members [class f] (when-let [members (members class f)] (when-let [statics (filter (comp :static :flags) members)] statics))) (defn instance-members [class f] (when-let [members (members class f)] (when-let [i-members (remove (comp :static :flags) members)] i-members))) (defn static-methods [class method argc] (filter #(= argc (count (:parameter-types %))) (filter :return-type (static-members class method)))) (defn instance-methods [class method argc] (filter #(= argc (count (:parameter-types %))) (filter :return-type (instance-members class method)))) (defn static-field [class f] (when-let [statics (static-members class f)] (when-let [[member] (filter (every-pred (comp nil? seq :parameter-types) (comp nil? :return-type)) statics)] member))) (defn instance-field [class f] (when-let [i-members (instance-members class f)] (when-let [[member] (filter (every-pred (comp nil? seq :parameter-types) (comp nil? :return-type)) i-members)] member))) (defn static-method [class method] (first (static-methods class method 0))) (defn instance-method [class method] (first (instance-methods class method 0))) (defn prim-or-obj "If the given Class is a primitive, returns that Class, otherwise returns Object" [tag] (if (and tag (primitive? tag)) tag java.lang.Object)) (defn prim-interface [tags] (when (some primitive? tags) (let [sig (apply str (mapv #(.toUpperCase (subs (.getSimpleName ^Class %) 0 1)) tags))] (maybe-class (str "clojure.lang.IFn$" sig))))) (defn tag-match? [arg-tags meth] (every? identity (map convertible? arg-tags (:parameter-types meth)))) (defn try-best-match "Given a vector of arg tags and a collection of methods, tries to return the subset of methods that match best the given tags" [tags methods] (let [o-tags (mapv #(or (maybe-class %) Object) tags)] (if-let [methods (or (seq (filter #(= o-tags (mapv maybe-class (:parameter-types %))) methods)) (seq (filter #(tag-match? tags %) methods)))] (reduce (fn [[prev & _ :as p] next] (let [prev-params (mapv maybe-class (:parameter-types prev)) next-params (mapv maybe-class (:parameter-types next)) prev-ret (maybe-class (:return-type prev)) next-ret (maybe-class (:return-type next)) prev-decl (maybe-class (:declaring-class prev)) next-decl (maybe-class (:declaring-class next))] (cond (not prev) [next] (= prev-params next-params) (cond (= prev-ret next-ret) (cond (.isAssignableFrom prev-decl next-decl) [next] (.isAssignableFrom next-decl prev-decl) p :else (conj p next)) (.isAssignableFrom prev-ret next-ret) [next] (.isAssignableFrom next-ret prev-ret) p :else (conj p next)) (and (some true? (map subsumes? next-params prev-params)) (not-any? true? (map subsumes? prev-params next-params))) [next] :else (conj p next)))) [] methods) methods))) (defn ns->relpath [s] (-> s str (s/replace \. \/) (s/replace \- \_) (str ".clj"))) (defn ns-url [ns] (let [f (ns->relpath ns)] (or (io/resource f) (io/resource (str f "c"))))) tools.analyzer.jvm-tools.analyzer.jvm-0.7.1/src/main/clojure/clojure/tools/analyzer/passes/ 0000775 0000000 0000000 00000000000 13122450003 0032145 5 ustar 00root root 0000000 0000000 tools.analyzer.jvm-tools.analyzer.jvm-0.7.1/src/main/clojure/clojure/tools/analyzer/passes/jvm/ 0000775 0000000 0000000 00000000000 13122450003 0032741 5 ustar 00root root 0000000 0000000 analyze_host_expr.clj 0000664 0000000 0000000 00000016275 13122450003 0037125 0 ustar 00root root 0000000 0000000 tools.analyzer.jvm-tools.analyzer.jvm-0.7.1/src/main/clojure/clojure/tools/analyzer/passes/jvm ;; 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.jvm.analyze-host-expr (:require [clojure.tools.analyzer :as ana] [clojure.tools.analyzer.utils :refer [ctx source-info merge']] [clojure.tools.analyzer.jvm.utils :refer :all])) (defn maybe-static-field [[_ class sym]] (when-let [{:keys [flags type name]} (static-field class sym)] {:op :static-field :assignable? (not (:final flags)) :class class :field name :o-tag type :tag type})) (defn maybe-static-method [[_ class sym]] (when-let [{:keys [name return-type]} (static-method class sym)] {:op :static-call :tag return-type :o-tag return-type :class class :method name})) (defn maybe-instance-method [target-expr class sym] (when-let [{:keys [return-type]} (instance-method class sym)] {:op :instance-call :tag return-type :o-tag return-type :instance target-expr :class class :method sym :children [:instance]})) (defn maybe-instance-field [target-expr class sym] (when-let [{:keys [flags name type]} (instance-field class sym)] {:op :instance-field :assignable? (not (:final flags)) :class class :instance target-expr :field name :tag type :o-tag type :children [:instance]})) (defn analyze-host-call [target-type method args target-expr class env] (let [op (case target-type :static :static-call :instance :instance-call)] (merge {:op op :method method :args args} (case target-type :static {:class class :children [:args]} :instance {:instance target-expr :class (maybe-class (:tag target-expr)) :children [:instance :args]})))) (defn analyze-host-field [target-type field target-expr class env] (if class (case target-type :static (or (maybe-static-field (list '. class field)) (throw (ex-info (str "Cannot find field " field " for class " class) (merge {:class class :field field} (source-info env))))) :instance (or (maybe-instance-field target-expr class field) {:op :host-interop :target (dissoc target-expr :tag :validated?) :m-or-f field :assignable? true :children [:target]} (when (:literal? target-expr) (throw (ex-info (str "Cannot find field " field " for class " class) (merge {:instance (dissoc target-expr :env) :field field} (source-info env))))))) {:op :host-interop :target target-expr :m-or-f field :assignable? true :children [:target]})) (defn -analyze-host-expr [target-type m-or-f target-expr class env] (let [target-class (-> target-expr :tag) [field method] (if class [(maybe-static-field (list '. class m-or-f)) (maybe-static-method (list '. class m-or-f))] (when target-class [(maybe-instance-field target-expr target-class m-or-f) (maybe-instance-method target-expr target-class m-or-f)]))] (cond (not (or class target-class)) {:op :host-interop :target target-expr :m-or-f m-or-f :assignable? true :children [:target]} method method field field class (throw (ex-info (str "Cannot find field or no-arg method call " m-or-f " for class " class) (merge {:class class :m-or-f m-or-f} (source-info env)))) target-class {:op :host-interop :target (dissoc target-expr :tag :validated?) :m-or-f m-or-f :assignable? true :children [:target]} :else (when (:literal? target-expr) (throw (ex-info (str "Cannot find field or no-arg method call " m-or-f " for class " target-class) (merge {:instance (dissoc target-expr :env) :m-or-f m-or-f} (source-info env)))))))) (defn analyze-host-expr "Performing some reflection, transforms :host-interop/:host-call/:host-field nodes in either: :static-field, :static-call, :instance-call, :instance-field or :host-interop nodes, and a :var or :maybe-class node in a :const :class node, if necessary (class literals shadow Vars). A :host-interop node represents either an instance-field or a no-arg instance-method. " {:pass-info {:walk :post :depends #{}}} [{:keys [op target form tag env class] :as ast}] (case op (:host-interop :host-call :host-field) (let [target (if-let [the-class (and (= :local (:op target)) (maybe-class-literal (:form target)))] (merge target (assoc (ana/analyze-const the-class env :class) :tag Class :o-tag Class)) target) class? (and (= :const (:op target)) (= :class (:type target)) (:form target)) target-type (if class? :static :instance)] (merge' (dissoc ast :assignable? :target :args :children) (case op :host-call (analyze-host-call target-type (:method ast) (:args ast) target class? env) :host-field (analyze-host-field target-type (:field ast) target (or class? (:tag target)) env) :host-interop (-analyze-host-expr target-type (:m-or-f ast) target class? env)) (when tag {:tag tag}))) :var (if-let [the-class (and (not (namespace form)) (pos? (.indexOf (str form) ".")) (maybe-class-literal form))] (assoc (ana/analyze-const the-class env :class) :form form) ast) :maybe-class (if-let [the-class (maybe-class-literal class)] (assoc (ana/analyze-const the-class env :class) :form form) ast) ast)) annotate_branch.clj 0000664 0000000 0000000 00000002637 13122450003 0036512 0 ustar 00root root 0000000 0000000 tools.analyzer.jvm-tools.analyzer.jvm-0.7.1/src/main/clojure/clojure/tools/analyzer/passes/jvm ;; 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.jvm.annotate-branch) (defmulti annotate-branch "Adds :branch? to branch AST nodes (if/case), :test? to the test children node of the branching op and :path? to the branching paths. Example: {:op if :branch? true :test {:test? true ..} :then {:path? true ..} ..}" {:pass-info {:walk :any :depends #{}}} :op) (defmethod annotate-branch :if [ast] (-> ast (assoc :branch? true) (assoc-in [:test :test?] true) (assoc-in [:then :path?] true) (assoc-in [:else :path?] true))) (defmethod annotate-branch :fn-method [ast] (assoc ast :path? true)) (defmethod annotate-branch :method [ast] (assoc ast :path? true)) (defmethod annotate-branch :case [ast] (-> ast (assoc :branch? true) (assoc-in [:test :test?] true) (assoc-in [:default :path?] true))) (defmethod annotate-branch :case-then [ast] (assoc ast :path? true)) (defmethod annotate-branch :default [ast] ast) annotate_host_info.clj 0000664 0000000 0000000 00000013006 13122450003 0037235 0 ustar 00root root 0000000 0000000 tools.analyzer.jvm-tools.analyzer.jvm-0.7.1/src/main/clojure/clojure/tools/analyzer/passes/jvm ;; 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.jvm.annotate-host-info (:require [clojure.tools.analyzer :as ana] [clojure.tools.analyzer.ast :refer [prewalk]] [clojure.tools.analyzer.passes [cleanup :refer [cleanup]] [elide-meta :refer [elide-meta]]] [clojure.tools.analyzer.utils :refer [source-info]] [clojure.tools.analyzer.jvm.utils :refer [members name-matches? try-best-match] :as u])) (defn annotate-host-info "Adds a :methods key to reify/deftype :methods info representing the reflected informations for the required methods, replaces (catch :default ..) forms with (catch Throwable ..)" {:pass-info {:walk :pre :depends #{} :after #{#'elide-meta}}} [{:keys [op methods interfaces class env] :as ast}] (case op (:reify :deftype) (let [all-methods (into #{} (mapcat (fn [class] (mapv (fn [method] (dissoc method :exception-types)) (filter (fn [{:keys [flags return-type]}] (and return-type (not-any? #{:final :static} flags))) (members class)))) (conj interfaces Object)))] (assoc ast :methods (mapv (fn [ast] (let [name (:name ast) argc (count (:params ast))] (assoc ast :methods (filter #(and ((name-matches? name) (:name %)) (= argc (count (:parameter-types %)))) all-methods)))) methods))) :catch (let [the-class (cond (and (= :const (:op class)) (= :default (:form class))) Throwable (= :maybe-class (:op class)) (u/maybe-class-literal (:class class))) ast (if the-class (-> ast (assoc :class (assoc (ana/analyze-const the-class env :class) :form (:form class) :tag Class :o-tag Class))) ast)] (assoc-in ast [:local :tag] (-> ast :class :val))) :method ;; this should actually be in validate but it's here since it needs to be prewalked ;; for infer-tag purposes (let [{:keys [name class tag form params fixed-arity env]} ast] (if interfaces (let [tags (mapv (comp u/maybe-class :tag meta :form) params) methods-set (set (mapv (fn [x] (dissoc x :declaring-class :flags)) methods))] (let [[m & rest :as matches] (try-best-match tags methods)] (if m (let [ret-tag (u/maybe-class (:return-type m)) i-tag (u/maybe-class (:declaring-class m)) arg-tags (mapv u/maybe-class (:parameter-types m)) params (mapv (fn [{:keys [atom] :as arg} tag] (assoc arg :tag tag :o-tag tag)) params arg-tags)] (if (or (empty? rest) (every? (fn [{:keys [return-type parameter-types]}] (and (= (u/maybe-class return-type) ret-tag) (= arg-tags (mapv u/maybe-class parameter-types)))) rest)) (assoc (dissoc ast :interfaces :methods) :bridges (filter #(and (= arg-tags (mapv u/maybe-class (:parameter-types %))) (.isAssignableFrom (u/maybe-class (:return-type %)) ret-tag)) (disj methods-set (dissoc m :declaring-class :flags))) :methods methods :interface i-tag :tag ret-tag :o-tag ret-tag :params params) (throw (ex-info (str "Ambiguous method signature for method: " name) (merge {:method name :interfaces interfaces :form form :params (mapv (fn [x] (prewalk x cleanup)) params) :matches matches} (source-info env)))))) (throw (ex-info (str "No such method found: " name " with given signature in any of the" " provided interfaces: " interfaces) (merge {:method name :methods methods :interfaces interfaces :form form :params params} (source-info env))))))) ast)) ast)) annotate_loops.clj 0000664 0000000 0000000 00000010044 13122450003 0036400 0 ustar 00root root 0000000 0000000 tools.analyzer.jvm-tools.analyzer.jvm-0.7.1/src/main/clojure/clojure/tools/analyzer/passes/jvm ;; 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.jvm.annotate-loops (:require [clojure.tools.analyzer.ast :refer [update-children]])) (defmulti annotate-loops "Adds a :loops field to nodes that represent a code path that might be visited more than once because of a recur. The field is a set of loop-ids representing the loops that might recur into that path Note that because (recur expr) is equivalent to (let [e expr] (recur e)) the node corresponting to expr will have the same :loops field as the nodes in the same code path of the recur" {:pass-info {:walk :pre :depends #{}}} :op) (defmulti check-recur :op) (defn -check-recur [ast k] (let [ast (update-in ast [k] check-recur)] (if (:recurs (k ast)) (assoc ast :recurs true) ast))) (defmethod check-recur :do [ast] (let [ast (-check-recur ast :ret)] (if (:recurs ast) (assoc ast :statements (mapv (fn [s] (assoc s :recurs true)) (:statements ast))) ast))) (defmethod check-recur :let [ast] (-check-recur ast :body)) (defmethod check-recur :letfn [ast] (-check-recur ast :body)) (defmethod check-recur :if [ast] (-> ast (-check-recur :then) (-check-recur :else))) (defmethod check-recur :case [ast] (let [ast (-> ast (-check-recur :default) (update-in [:thens] #(mapv check-recur %)))] (if (some :recurs (:thens ast)) (assoc ast :recurs true) ast))) (defmethod check-recur :case-then [ast] (-check-recur ast :then)) (defmethod check-recur :recur [ast] (assoc ast :recurs true)) (defmethod check-recur :default [ast] ast) (defn -loops [ast loop-id] (update-in ast [:loops] (fnil conj #{}) loop-id)) (defmethod annotate-loops :loop [{:keys [loops loop-id] :as ast}] (let [ast (if loops (update-children ast #(assoc % :loops loops)) ast) ast (update-in ast [:body] check-recur)] (if (-> ast :body :recurs) (update-in ast [:body] -loops loop-id) ast))) (defmethod annotate-loops :default [{:keys [loops] :as ast}] (if loops (update-children ast #(assoc % :loops loops)) ast)) (defmethod annotate-loops :if [{:keys [loops test then else env] :as ast}] (if loops (let [loop-id (:loop-id env) loops-no-recur (disj loops loop-id) branch-recurs? (or (:recurs then) (:recurs else)) then (if (or (:recurs then) ;; the recur is inside the then branch ;; the recur is in the same code path of the if expression (not branch-recurs?)) (assoc then :loops loops) (assoc then :loops loops-no-recur)) else (if (or (:recurs else) (not branch-recurs?)) (assoc else :loops loops) (assoc else :loops loops-no-recur))] (assoc ast :then then :else else :test (assoc test :loops loops))) ast)) (defmethod annotate-loops :case [{:keys [loops test default thens env] :as ast}] (if loops (let [loop-id (:loop-id env) loops-no-recur (disj loops loop-id) branch-recurs? (some :recurs (conj thens default)) default (if (or (:recurs default) (not branch-recurs?)) (assoc default :loops loops) (assoc default :loops loops-no-recur)) thens (mapv #(if (or (:recurs %) (not branch-recurs?)) (assoc % :loops loops) (assoc % :loops loops-no-recur)) thens)] (assoc ast :thens thens :default default :test (assoc test :loops loops))) ast)) annotate_tag.clj 0000664 0000000 0000000 00000006245 13122450003 0036027 0 ustar 00root root 0000000 0000000 tools.analyzer.jvm-tools.analyzer.jvm-0.7.1/src/main/clojure/clojure/tools/analyzer/passes/jvm ;; 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.jvm.annotate-tag (:require [clojure.tools.analyzer.jvm.utils :refer [unbox maybe-class]] [clojure.tools.analyzer.passes.jvm.constant-lifter :refer [constant-lift]]) (:import (clojure.lang ISeq Var AFunction))) (defmulti -annotate-tag :op) (defmethod -annotate-tag :default [ast] ast) (defmethod -annotate-tag :map [{:keys [val form] :as ast}] (let [t (class (or val form))] (assoc ast :o-tag t :tag t))) (defmethod -annotate-tag :set [{:keys [val form] :as ast}] (let [t (class (or val form))] (assoc ast :o-tag t :tag t))) (defmethod -annotate-tag :vector [{:keys [val form] :as ast}] (let [t (class (or val form))] (assoc ast :o-tag t :tag t))) (defmethod -annotate-tag :the-var [ast] (assoc ast :o-tag Var :tag Var)) (defmethod -annotate-tag :const [ast] (case (:type ast) ;; char and numbers are unboxed by default :number (let [t (unbox (class (:val ast)))] (assoc ast :o-tag t :tag t)) :char (assoc ast :o-tag Character/TYPE :tag Character/TYPE) :seq (assoc ast :o-tag ISeq :tag ISeq) (let [t (class (:val ast))] (assoc ast :o-tag t :tag t)))) (defmethod -annotate-tag :binding [{:keys [form tag atom o-tag init local name variadic?] :as ast}] (let [o-tag (or (:tag init) ;; should defer to infer-tag? (and (= :fn local) AFunction) (and (= :arg local) variadic? ISeq) o-tag Object) o-tag (if (#{Void Void/TYPE} o-tag) Object o-tag)] (if-let [tag (or (:tag (meta form)) tag)] (let [ast (assoc ast :tag tag :o-tag tag)] (if init (assoc-in ast [:init :tag] (maybe-class tag)) ast)) (assoc ast :tag o-tag :o-tag o-tag)))) (defmethod -annotate-tag :local [{:keys [name form tag atom case-test] :as ast}] (let [o-tag (@atom :tag)] (assoc ast :o-tag o-tag :tag o-tag))) ;; TODO: move binding/local logic to infer-tag (defn annotate-tag "If the AST node type is a constant object or contains :tag metadata, attach the appropriate :tag and :o-tag to the node." {:pass-info {:walk :post :depends #{} :after #{#'constant-lift}}} [{:keys [op tag o-tag atom] :as ast}] (let [ast (if (and atom (:case-test @atom)) (update-in ast [:form] vary-meta dissoc :tag) ast) ast (if (and o-tag tag) ast (if-let [tag (or tag (-> ast :val meta :tag) (-> ast :form meta :tag))] (assoc (-annotate-tag ast) :tag tag) (-annotate-tag ast)))] (when (= op :binding) (swap! atom assoc :tag (:tag ast))) ast)) box.clj 0000664 0000000 0000000 00000013037 13122450003 0034150 0 ustar 00root root 0000000 0000000 tools.analyzer.jvm-tools.analyzer.jvm-0.7.1/src/main/clojure/clojure/tools/analyzer/passes/jvm ;; 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.jvm.box (:require [clojure.tools.analyzer.jvm.utils :as u] [clojure.tools.analyzer.utils :refer [protocol-node? arglist-for-arity]] [clojure.tools.analyzer.passes.jvm [validate :refer [validate]] [infer-tag :refer [infer-tag]]])) (defmulti box "Box the AST node tag where necessary" {:pass-info {:walk :pre :depends #{#'infer-tag} :after #{#'validate}}} :op) (defmacro if-let-box [class then else] `(let [c# ~class ~class (u/box c#)] (if (u/primitive? c#) ~then ~else))) (defn -box [ast] (let [tag (:tag ast)] (if (u/primitive? tag) (assoc ast :tag (u/box tag)) ast))) (defn boxed? [tag expr] (and (or (nil? tag) (not (u/primitive? tag))) (u/primitive? (:tag expr)))) (defmethod box :instance-call [{:keys [args class validated? tag] :as ast}] (let [ast (if-let-box class (assoc (update-in ast [:instance :tag] u/box) :class class) ast)] (if validated? ast (assoc ast :args (mapv -box args) :o-tag Object :tag (if (not (#{Void Void/TYPE} tag)) tag Object))))) (defmethod box :static-call [{:keys [args validated? tag] :as ast}] (if validated? ast (assoc ast :args (mapv -box args) :o-tag Object :tag (if (not (#{Void Void/TYPE} tag)) tag Object)))) (defmethod box :new [{:keys [args validated?] :as ast}] (if validated? ast (assoc ast :args (mapv -box args) :o-tag Object))) (defmethod box :instance-field [{:keys [class] :as ast}] (if-let-box class (assoc (update-in ast [:instance :tag] u/box) :class class) ast)) (defmethod box :def [{:keys [init] :as ast}] (if (and init (u/primitive? (:tag init))) (update-in ast [:init] -box) ast)) (defmethod box :vector [ast] (assoc ast :items (mapv -box (:items ast)))) (defmethod box :set [ast] (assoc ast :items (mapv -box (:items ast)))) (defmethod box :map [ast] (let [keys (mapv -box (:keys ast)) vals (mapv -box (:vals ast))] (assoc ast :keys keys :vals vals))) (defmethod box :do [ast] (if (boxed? (:tag ast) (:ret ast)) (-> ast (update-in [:ret] -box) (update-in [:o-tag] u/box)) ast)) (defmethod box :quote [ast] (if (boxed? (:tag ast) (:ret ast)) (-> ast (update-in [:expr] -box) (update-in [:o-tag] u/box)) ast)) (defmethod box :protocol-invoke [ast] (assoc ast :args (mapv -box (:args ast)))) (defmethod box :let [{:keys [tag body] :as ast}] (if (boxed? tag body) (-> ast (update-in [:body] -box) (update-in [:o-tag] u/box)) ast)) (defmethod box :letfn [ast] (if (boxed? (:tag ast) (:body ast)) (-> ast (update-in [:body] -box) (update-in [:o-tag] u/box)) ast)) (defmethod box :loop [ast] (if (boxed? (:tag ast) (:body ast)) (-> ast (update-in [:body] -box) (update-in [:o-tag] u/box)) ast)) (defmethod box :fn-method [{:keys [params tag] :as ast}] (let [ast (if (u/primitive? tag) ast (-> ast (update-in [:body] -box) (update-in [:o-tag] u/box)))] (assoc ast :params (mapv (fn [{:keys [o-tag] :as p}] (assoc p :o-tag (u/prim-or-obj o-tag))) params) :tag (u/prim-or-obj tag) :o-tag (u/prim-or-obj tag)))) (defmethod box :if [{:keys [test then else tag o-tag] :as ast}] (let [test-tag (:tag test) test (if (and (u/primitive? test-tag) (not= Boolean/TYPE test-tag)) (assoc test :tag (u/box test-tag)) test) [then else o-tag] (if (or (boxed? tag then) (boxed? tag else) (not o-tag)) (conj (mapv -box [then else]) (u/box o-tag)) [then else o-tag])] (merge ast {:test test :o-tag o-tag :then then :else else}))) (defmethod box :case [{:keys [tag default tests thens test-type] :as ast}] (let [ast (if (and tag (u/primitive? tag)) ast (-> ast (assoc-in [:thens] (mapv (fn [t] (update-in t [:then] -box)) thens)) (update-in [:default] -box) (update-in [:o-tag] u/box)))] (if (= :hash-equiv test-type) (-> ast (update-in [:test] -box) (assoc-in [:tests] (mapv (fn [t] (update-in t [:test] -box)) tests))) ast))) (defmethod box :try [{:keys [tag] :as ast}] (let [ast (if (and tag (u/primitive? tag)) ast (-> ast (update-in [:catches] #(mapv -box %)) (update-in [:body] -box) (update-in [:o-tag] u/box)))] (-> ast (update-in [:finally] -box)))) (defmethod box :invoke [ast] (assoc ast :args (mapv -box (:args ast)) :o-tag Object)) (defmethod box :default [ast] ast) classify_invoke.clj 0000664 0000000 0000000 00000007541 13122450003 0036553 0 ustar 00root root 0000000 0000000 tools.analyzer.jvm-tools.analyzer.jvm-0.7.1/src/main/clojure/clojure/tools/analyzer/passes/jvm ;; 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.jvm.classify-invoke (:require [clojure.tools.analyzer.utils :refer [arglist-for-arity protocol-node? source-info]] [clojure.tools.analyzer.jvm.utils :refer [specials prim-interface]] [clojure.tools.analyzer.passes.jvm.validate :refer [validate]])) (defn classify-invoke "If the AST node is an :invoke, check the node in function position, * if it is a keyword, transform the node in a :keyword-invoke node; * if it is the clojure.core/instance? var and the first argument is a literal class, transform the node in a :instance? node to be inlined by the emitter * if it is a protocol function var, transform the node in a :protocol-invoke node * if it is a regular function with primitive type hints that match a clojure.lang.IFn$[primitive interface], transform the node in a :prim-invoke node" {:pass-info {:walk :post :depends #{#'validate}}} [{:keys [op args tag env form] :as ast}] (if-not (= op :invoke) ast (let [argc (count args) the-fn (:fn ast) op (:op the-fn) var? (= :var op) the-var (:var the-fn)] (cond (and (= :const op) (= :keyword (:type the-fn))) (if (<= 1 argc 2) (if (and (not (namespace (:val the-fn))) (= 1 argc)) (merge (dissoc ast :fn :args) {:op :keyword-invoke :target (first args) :keyword the-fn :children [:keyword :target]}) ast) (throw (ex-info (str "Cannot invoke keyword with " argc " arguments") (merge {:form form} (source-info env))))) (and (= 2 argc) var? (= #'clojure.core/instance? the-var) (= :const (:op (first args))) (= :class (:type (first args)))) (merge (dissoc ast :fn :args) {:op :instance? :class (:val (first args)) :target (second args) :form form :env env :o-tag Boolean/TYPE :tag (or tag Boolean/TYPE) :children [:target]}) (and var? (protocol-node? the-var (:meta the-fn))) (if (>= argc 1) (merge (dissoc ast :fn) {:op :protocol-invoke :protocol-fn the-fn :target (first args) :args (vec (rest args)) :children [:protocol-fn :target :args]}) (throw (ex-info "Cannot invoke protocol method with no args" (merge {:form form} (source-info env))))) :else (let [arglist (arglist-for-arity the-fn argc) arg-tags (mapv (comp specials str :tag meta) arglist) ret-tag (-> arglist meta :tag str specials) tags (conj arg-tags ret-tag)] (if-let [prim-interface (prim-interface (mapv #(if (nil? %) Object %) tags))] (merge ast {:op :prim-invoke :prim-interface prim-interface :args (mapv (fn [arg tag] (assoc arg :tag tag)) args arg-tags) :o-tag ret-tag :tag (or tag ret-tag)}) ast)))))) constant_lifter.clj 0000664 0000000 0000000 00000002107 13122450003 0036552 0 ustar 00root root 0000000 0000000 tools.analyzer.jvm-tools.analyzer.jvm-0.7.1/src/main/clojure/clojure/tools/analyzer/passes/jvm (ns clojure.tools.analyzer.passes.jvm.constant-lifter (:require [clojure.tools.analyzer.passes.constant-lifter :as orig] [clojure.tools.analyzer :refer [analyze-const]] [clojure.tools.analyzer.utils :refer [constant? classify]] [clojure.tools.analyzer.passes.jvm.analyze-host-expr :refer [analyze-host-expr]] [clojure.tools.analyzer.passes.elide-meta :refer [elide-meta]])) (defn constant-lift* [ast] (if (= :var (:op ast)) (let [{:keys [var env form meta]} ast] (if (constant? var meta) (let [val @var] (assoc (analyze-const val env (classify val)) :form form)) ast)) (orig/constant-lift ast))) (defn constant-lift "Like clojure.tools.analyzer.passes.constant-lifter/constant-lift but transforms also :var nodes where the var has :const in the metadata into :const nodes and preserves tag info" {:pass-info {:walk :post :depends #{} :after #{#'elide-meta #'analyze-host-expr}}} [ast] (merge (constant-lift* ast) (select-keys ast [:tag :o-tag :return-tag :arglists]))) emit_form.clj 0000664 0000000 0000000 00000013002 13122450003 0035331 0 ustar 00root root 0000000 0000000 tools.analyzer.jvm-tools.analyzer.jvm-0.7.1/src/main/clojure/clojure/tools/analyzer/passes/jvm ;; 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.jvm.emit-form (:require [clojure.tools.analyzer.passes [emit-form :as default] [uniquify :refer [uniquify-locals]]])) (defmulti -emit-form (fn [{:keys [op]} _] op)) (defn -emit-form* [{: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))) ;; TODO: use pass opts infr (defn emit-form "Return the form represented by the given AST Opts is a set of options, valid options are: * :hygienic * :qualified-vars (DEPRECATED, use :qualified-symbols instead) * :qualified-symbols" {:pass-info {:walk :none :depends #{#'uniquify-locals} :compiler true}} ([ast] (emit-form ast #{})) ([ast opts] (binding [default/-emit-form* -emit-form*] (-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] (binding [default/-emit-form* -emit-form*] (-emit-form* ast #{:hygienic}))) (defmethod -emit-form :default [ast opts] (default/-emit-form ast opts)) (defmethod -emit-form :const [{:keys [type val] :as ast} opts] (if (and (= type :class) (:qualified-symbols opts)) (symbol (.getName ^Class val)) (default/-emit-form ast opts))) (defmethod -emit-form :monitor-enter [{:keys [target]} opts] `(monitor-enter ~(-emit-form* target opts))) (defmethod -emit-form :monitor-exit [{:keys [target]} opts] `(monitor-exit ~(-emit-form* target opts))) (defmethod -emit-form :import [{:keys [class]} opts] `(clojure.core/import* ~class)) (defmethod -emit-form :the-var [{:keys [^clojure.lang.Var var]} opts] `(var ~(symbol (name (ns-name (.ns var))) (name (.sym var))))) (defmethod -emit-form :method [{:keys [params body this name form]} opts] (let [params (into [this] params)] `(~(with-meta name (meta (first form))) ~(with-meta (mapv #(-emit-form* % opts) params) (meta (second form))) ~(-emit-form* body opts)))) (defn class->str [class] (if (symbol? class) (name class) (.getName ^Class class))) (defn class->sym [class] (if (symbol? class) class (symbol (.getName ^Class class)))) (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 :deftype [{:keys [name class-name fields interfaces methods]} opts] `(deftype* ~name ~(class->sym class-name) ~(mapv #(-emit-form* % opts) fields) :implements ~(mapv class->sym interfaces) ~@(mapv #(-emit-form* % opts) methods))) (defmethod -emit-form :reify [{:keys [interfaces methods]} opts] `(reify* ~(mapv class->sym (disj interfaces clojure.lang.IObj)) ~@(mapv #(-emit-form* % opts) methods))) (defmethod -emit-form :case [{:keys [test default tests thens shift mask low high switch-type test-type skip-check?]} opts] `(case* ~(-emit-form* test opts) ~shift ~mask ~(-emit-form* default opts) ~(apply sorted-map (mapcat (fn [{:keys [hash test]} {:keys [then]}] [hash [(-emit-form* test opts) (-emit-form* then opts)]]) tests thens)) ~switch-type ~test-type ~skip-check?)) (defmethod -emit-form :static-field [{:keys [class field]} opts] (symbol (class->str class) (name field))) (defmethod -emit-form :static-call [{:keys [class method args]} opts] `(~(symbol (class->str class) (name method)) ~@(mapv #(-emit-form* % opts) args))) (defmethod -emit-form :instance-field [{:keys [instance field]} opts] `(~(symbol (str ".-" (name field))) ~(-emit-form* instance opts))) (defmethod -emit-form :instance-call [{:keys [instance method args]} opts] `(~(symbol (str "." (name method))) ~(-emit-form* instance opts) ~@(mapv #(-emit-form* % opts) args))) (defmethod -emit-form :prim-invoke [{:keys [fn args]} opts] `(~(-emit-form* fn opts) ~@(mapv #(-emit-form* % opts) args))) (defmethod -emit-form :protocol-invoke [{:keys [protocol-fn target args]} opts] `(~(-emit-form* protocol-fn opts) ~(-emit-form* target opts) ~@(mapv #(-emit-form* % opts) args))) (defmethod -emit-form :keyword-invoke [{:keys [target keyword]} opts] (list (-emit-form* keyword opts) (-emit-form* target opts))) (defmethod -emit-form :instance? [{:keys [class target]} opts] `(instance? ~class ~(-emit-form* target opts))) (defmethod -emit-form :var [{:keys [form ^clojure.lang.Var var]} opts] (if (or (:qualified-symbols opts) (:qualified-vars opts)) (with-meta (symbol (-> var .ns ns-name name) (-> var .sym name)) (meta form)) form)) (defmethod -emit-form :def [ast opts] (let [f (default/-emit-form ast opts)] (if (:qualified-symbols opts) `(def ~(with-meta (symbol (-> ast :env :ns name) (str (second f))) (meta (second f))) ~@(nthrest f 2)) f))) fix_case_test.clj 0000664 0000000 0000000 00000001610 13122450003 0036172 0 ustar 00root root 0000000 0000000 tools.analyzer.jvm-tools.analyzer.jvm-0.7.1/src/main/clojure/clojure/tools/analyzer/passes/jvm ;; 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.jvm.fix-case-test (:require [clojure.tools.analyzer.passes.add-binding-atom :refer [add-binding-atom]])) (defn fix-case-test "If the node is a :case-test, annotates in the atom shared by the binding and the local node with :case-test" {:pass-info {:walk :pre :depends #{#'add-binding-atom}}} [ast] (when (:case-test ast) (swap! (:atom ast) assoc :case-test true)) ast) infer_tag.clj 0000664 0000000 0000000 00000023277 13122450003 0035325 0 ustar 00root root 0000000 0000000 tools.analyzer.jvm-tools.analyzer.jvm-0.7.1/src/main/clojure/clojure/tools/analyzer/passes/jvm ;; 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.jvm.infer-tag (:require [clojure.tools.analyzer.utils :refer [arglist-for-arity]] [clojure.tools.analyzer.jvm.utils :as u] [clojure.tools.analyzer.env :as env] [clojure.set :refer [rename-keys]] [clojure.tools.analyzer.passes.trim :refer [trim]] [clojure.tools.analyzer.passes.jvm [annotate-tag :refer [annotate-tag]] [annotate-host-info :refer [annotate-host-info]] [analyze-host-expr :refer [analyze-host-expr]] [fix-case-test :refer [fix-case-test]]])) (defmulti -infer-tag :op) (defmethod -infer-tag :default [ast] ast) (defmethod -infer-tag :binding [{:keys [init atom] :as ast}] (if init (let [info (select-keys init [:return-tag :arglists])] (swap! atom merge info) (merge ast info)) ast)) (defmethod -infer-tag :local [ast] (let [atom @(:atom ast)] (merge atom ast {:o-tag (:tag atom)}))) (defmethod -infer-tag :var [{:keys [var form] :as ast}] (let [{:keys [tag arglists]} (:meta ast) arglists (if (= 'quote (first arglists)) (second arglists) arglists) form-tag (:tag (meta form))] ;;if (not dynamic) (merge ast {:o-tag Object} (when-let [tag (or form-tag tag)] (if (fn? @var) {:tag clojure.lang.AFunction :return-tag tag} {:tag tag})) (when arglists {:arglists arglists})))) (defmethod -infer-tag :def [{:keys [var init name] :as ast}] (let [info (merge (select-keys init [:return-tag :arglists :tag]) (select-keys (meta name) [:tag :arglists]))] (when (and (seq info) (not (:dynamic (meta name))) (= :global (-> (env/deref-env) :passes-opts :infer-tag/level))) (alter-meta! var merge (rename-keys info {:return-tag :tag}))) (merge ast info {:tag clojure.lang.Var :o-tag clojure.lang.Var}))) (defmethod -infer-tag :quote [ast] (let [tag (-> ast :expr :tag)] (assoc ast :tag tag :o-tag tag))) (defmethod -infer-tag :new [ast] (let [t (-> ast :class :val)] (assoc ast :o-tag t :tag t))) (defmethod -infer-tag :with-meta [{:keys [expr] :as ast}] (merge ast (select-keys expr [:return-tag :arglists]) {:tag (or (:tag expr) Object) :o-tag Object})) ;;trying to be smart here (defmethod -infer-tag :recur [ast] (assoc ast :ignore-tag true)) (defmethod -infer-tag :do [{:keys [ret] :as ast}] (merge ast (select-keys ret [:return-tag :arglists :ignore-tag :tag]) {:o-tag (:tag ret)})) (defmethod -infer-tag :let [{:keys [body] :as ast}] (merge ast (select-keys body [:return-tag :arglists :ignore-tag :tag]) {:o-tag (:tag body)})) (defmethod -infer-tag :letfn [{:keys [body] :as ast}] (merge ast (select-keys body [:return-tag :arglists :ignore-tag :tag]) {:o-tag (:tag body)})) (defmethod -infer-tag :loop [{:keys [body] :as ast}] (merge ast (select-keys body [:return-tag :arglists]) {:o-tag (:tag body)} (let [tag (:tag body)] (if (#{Void Void/TYPE} tag) (assoc ast :tag Object) (assoc ast :tag tag))))) (defn =-arglists? [a1 a2] (let [tag (fn [x] (-> x meta :tag u/maybe-class))] (and (= a1 a2) (every? true? (mapv (fn [a1 a2] (and (= (tag a1) (tag a2)) (= (mapv tag a1) (mapv tag a2)))) a1 a2))))) (defmethod -infer-tag :if [{:keys [then else] :as ast}] (let [then-tag (:tag then) else-tag (:tag else) ignore-then? (:ignore-tag then) ignore-else? (:ignore-tag else)] (cond (and then-tag (or ignore-else? (= then-tag else-tag))) (merge ast {:tag then-tag :o-tag then-tag} (when-let [return-tag (:return-tag then)] (when (or ignore-else? (= return-tag (:return-tag else))) {:return-tag return-tag})) (when-let [arglists (:arglists then)] (when (or ignore-else? (=-arglists? arglists (:arglists else))) {:arglists arglists}))) (and else-tag ignore-then?) (merge ast {:tag else-tag :o-tag else-tag} (when-let [return-tag (:return-tag else)] {:return-tag return-tag}) (when-let [arglists (:arglists else)] {:arglists arglists})) (and (:ignore-tag then) (:ignore-tag else)) (assoc ast :ignore-tag true) :else ast))) (defmethod -infer-tag :throw [ast] (assoc ast :ignore-tag true)) (defmethod -infer-tag :case [{:keys [thens default] :as ast}] (let [thens (conj (mapv :then thens) default) exprs (seq (remove :ignore-tag thens)) tag (:tag (first exprs))] (cond (and tag (every? #(= (:tag %) tag) exprs)) (merge ast {:tag tag :o-tag tag} (when-let [return-tag (:return-tag (first exprs))] (when (every? #(= (:return-tag %) return-tag) exprs) {:return-tag return-tag})) (when-let [arglists (:arglists (first exprs))] (when (every? #(=-arglists? (:arglists %) arglists) exprs) {:arglists arglists}))) (every? :ignore-tag thens) (assoc ast :ignore-tag true) :else ast))) (defmethod -infer-tag :try [{:keys [body catches] :as ast}] (let [{:keys [tag return-tag arglists]} body catches (remove :ignore-tag (mapv :body catches))] (merge ast (when (and tag (every? #(= % tag) (mapv :tag catches))) {:tag tag :o-tag tag}) (when (and return-tag (every? #(= % return-tag) (mapv :return-tag catches))) {:return-tag return-tag}) (when (and arglists (every? #(=-arglists? % arglists) (mapv :arglists catches))) {:arglists arglists})))) (defmethod -infer-tag :fn-method [{:keys [form body params local] :as ast}] (let [annotated-tag (or (:tag (meta (first form))) (:tag (meta (:form local)))) body-tag (:tag body) tag (or annotated-tag body-tag) tag (if (#{Void Void/TYPE} tag) Object tag)] (merge (if (not= tag body-tag) (assoc-in ast [:body :tag] (u/maybe-class tag)) ast) (when tag {:tag tag :o-tag tag}) {:arglist (with-meta (vec (mapcat (fn [{:keys [form variadic?]}] (if variadic? ['& form] [form])) params)) (when tag {:tag tag}))}))) (defmethod -infer-tag :fn [{:keys [local methods] :as ast}] (merge ast {:arglists (seq (mapv :arglist methods)) :tag clojure.lang.AFunction :o-tag clojure.lang.AFunction} (when-let [tag (or (:tag (meta (:form local))) (and (apply = (mapv :tag methods)) (:tag (first methods))))] {:return-tag tag}))) (defmethod -infer-tag :invoke [{:keys [fn args] :as ast}] (if (:arglists fn) (let [argc (count args) arglist (arglist-for-arity fn argc) tag (or (:tag (meta arglist)) (:return-tag fn) (and (= :var (:op fn)) (:tag (:meta fn))))] (merge ast (when tag {:tag tag :o-tag tag}))) (if-let [tag (:return-tag fn)] (assoc ast :tag tag :o-tag tag) ast))) (defmethod -infer-tag :method [{:keys [form body params] :as ast}] (let [tag (or (:tag (meta (first form))) (:tag (meta (second form)))) body-tag (:tag body)] (assoc ast :tag (or tag body-tag) :o-tag body-tag))) (defmethod -infer-tag :reify [{:keys [class-name] :as ast}] (assoc ast :tag class-name :o-tag class-name)) (defmethod -infer-tag :set! [ast] (let [t (:tag (:target ast))] (assoc ast :tag t :o-tag t))) (defn infer-tag "Performs local type inference on the AST adds, when possible, one or more of the following keys to the AST: * :o-tag represents the current type of the expression represented by the node * :tag represents the type the expression represented by the node is required to have, possibly the same as :o-tag * :return-tag implies that the node will return a function whose invocation will result in a object of this type * :arglists implies that the node will return a function with this arglists * :ignore-tag true when the node is untyped, does not imply that all untyped node will have this Passes opts: * :infer-tag/level If :global, infer-tag will perform Var tag inference" {:pass-info {:walk :post :depends #{#'annotate-tag #'annotate-host-info #'fix-case-test #'analyze-host-expr} :after #{#'trim}}} [{:keys [tag form] :as ast}] (let [tag (or tag (:tag (meta form))) ast (-infer-tag ast)] (merge ast (when tag {:tag tag}) (when-let [o-tag (:o-tag ast)] {:o-tag o-tag})))) validate.clj 0000664 0000000 0000000 00000030171 13122450003 0035147 0 ustar 00root root 0000000 0000000 tools.analyzer.jvm-tools.analyzer.jvm-0.7.1/src/main/clojure/clojure/tools/analyzer/passes/jvm ;; 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.jvm.validate (:require [clojure.tools.analyzer.ast :refer [prewalk]] [clojure.tools.analyzer.env :as env] [clojure.tools.analyzer.passes.cleanup :refer [cleanup]] [clojure.tools.analyzer.passes.jvm [validate-recur :refer [validate-recur]] [infer-tag :refer [infer-tag]] [analyze-host-expr :refer [analyze-host-expr]]] [clojure.tools.analyzer.utils :refer [arglist-for-arity source-info resolve-sym resolve-ns merge']] [clojure.tools.analyzer.jvm.utils :as u :refer [tag-match? try-best-match]]) (:import (clojure.lang IFn ExceptionInfo))) (defmulti -validate :op) (defmethod -validate :maybe-class [{:keys [class env] :as ast}] (if-let [handle (-> (env/deref-env) :passes-opts :validate/unresolvable-symbol-handler)] (handle nil class ast) (if (not (.contains (str class) ".")) (throw (ex-info (str "Could not resolve var: " class) (merge {:var class} (source-info env)))) (throw (ex-info (str "Class not found: " class) (merge {:class class} (source-info env))))))) (defmethod -validate :maybe-host-form [{:keys [class field form env] :as ast}] (if-let [handle (-> (env/deref-env) :passes-opts :validate/unresolvable-symbol-handler)] (handle class field ast) (if (resolve-ns class env) (throw (ex-info (str "No such var: " class) (merge {:form form} (source-info env)))) (throw (ex-info (str "No such namespace: " class) (merge {:ns class :form form} (source-info env))))))) (defmethod -validate :set! [{:keys [target form env] :as ast}] (when (not (:assignable? target)) (throw (ex-info "Cannot set! non-assignable target" (merge {:target (prewalk target cleanup) :form form} (source-info env))))) ast) (defmethod -validate :new [{:keys [args] :as ast}] (if (:validated? ast) ast (if-not (= :class (-> ast :class :type)) (throw (ex-info (str "Unable to resolve classname: " (:form (:class ast))) (merge {:class (:form (:class ast)) :ast ast} (source-info (:env ast))))) (let [^Class class (-> ast :class :val) c-name (symbol (.getName class)) argc (count args) tags (mapv :tag args)] (let [[ctor & rest] (->> (filter #(= (count (:parameter-types %)) argc) (u/members class c-name)) (try-best-match tags))] (if ctor (if (empty? rest) (let [arg-tags (mapv u/maybe-class (:parameter-types ctor)) args (mapv (fn [arg tag] (assoc arg :tag tag)) args arg-tags)] (assoc ast :args args :validated? true)) ast) (throw (ex-info (str "no ctor found for ctor of class: " class " and given signature") (merge {:class class :args (mapv (fn [a] (prewalk a cleanup)) args)} (source-info (:env ast))))))))))) (defn validate-call [{:keys [class instance method args tag env op] :as ast}] (let [argc (count args) instance? (= :instance-call op) f (if instance? u/instance-methods u/static-methods) tags (mapv :tag args)] (if-let [matching-methods (seq (f class method argc))] (let [[m & rest :as matching] (try-best-match tags matching-methods)] (if m (let [all-ret-equals? (apply = (mapv :return-type matching))] (if (or (empty? rest) (and all-ret-equals? ;; if the method signature is the same just pick the first one (apply = (mapv #(mapv u/maybe-class (:parameter-types %)) matching)))) (let [ret-tag (:return-type m) arg-tags (mapv u/maybe-class (:parameter-types m)) args (mapv (fn [arg tag] (assoc arg :tag tag)) args arg-tags) class (u/maybe-class (:declaring-class m))] (merge' ast {:method (:name m) :validated? true :class class :o-tag ret-tag :tag (or tag ret-tag) :args args} (if instance? {:instance (assoc instance :tag class)}))) (if all-ret-equals? (let [ret-tag (:return-type m)] (assoc ast :o-tag Object :tag (or tag ret-tag))) ast))) (if instance? (assoc (dissoc ast :class) :tag Object :o-tag Object) (throw (ex-info (str "No matching method: " method " for class: " class " and given signature") (merge {:method method :class class :args (mapv (fn [a] (prewalk a cleanup)) args)} (source-info env))))))) (if instance? (assoc (dissoc ast :class) :tag Object :o-tag Object) (throw (ex-info (str "No matching method: " method " for class: " class " and arity: " argc) (merge {:method method :class class :argc argc} (source-info env)))))))) (defmethod -validate :static-call [ast] (if (:validated? ast) ast (validate-call (assoc ast :class (u/maybe-class (:class ast)))))) (defmethod -validate :static-field [ast] (if (:validated? ast) ast (assoc ast :class (u/maybe-class (:class ast))))) (defmethod -validate :instance-call [{:keys [class validated? instance] :as ast}] (let [class (or class (:tag instance))] (if (and class (not validated?)) (validate-call (assoc ast :class (u/maybe-class class))) ast))) (defmethod -validate :instance-field [{:keys [instance class] :as ast}] (let [class (u/maybe-class class)] (assoc ast :class class :instance (assoc instance :tag class)))) (defmethod -validate :import [{:keys [^String class validated? env form] :as ast}] (if-not validated? (let [class-sym (-> class (subs (inc (.lastIndexOf class "."))) symbol) sym-val (resolve-sym class-sym env)] (if (and (class? sym-val) (not= (.getName ^Class sym-val) class)) ;; allow deftype redef (throw (ex-info (str class-sym " already refers to: " sym-val " in namespace: " (:ns env)) (merge {:class class :class-sym class-sym :sym-val sym-val :form form} (source-info env)))) (assoc ast :validated? true))) ast)) (defmethod -validate :def [ast] (when-not (var? (:var ast)) (throw (ex-info (str "Cannot def " (:name ast) " as it refers to the class " (.getName ^Class (:var ast))) (merge {:ast (prewalk ast cleanup)} (source-info (:env ast)))))) (merge ast (when-let [tag (-> ast :name meta :tag)] (when (and (symbol? tag) (or (u/specials (str tag)) (u/special-arrays (str tag)))) ;; we cannot validate all tags since :tag might contain a function call that returns ;; a valid tag at runtime, however if tag is one of u/specials or u/special-arrays ;; we know that it's a wrong tag as it's going to be evaluated as a clojure.core function (if-let [handle (-> (env/deref-env) :passes-opts :validate/wrong-tag-handler)] (handle :name/tag ast) (throw (ex-info (str "Wrong tag: " (eval tag) " in def: " (:name ast)) (merge {:ast (prewalk ast cleanup)} (source-info (:env ast)))))))))) (defmethod -validate :invoke [{:keys [args env fn form] :as ast}] (let [argc (count args)] (when (and (= :const (:op fn)) (not (instance? IFn (:form fn)))) (throw (ex-info (str (class (:form fn)) " is not a function, but it's used as such") (merge {:form form} (source-info env))))) (if (and (:arglists fn) (not (arglist-for-arity fn argc))) (if (-> (env/deref-env) :passes-opts :validate/throw-on-arity-mismatch) (throw (ex-info (str "No matching arity found for function: " (:name fn)) {:arity (count args) :fn fn})) (assoc ast :maybe-arity-mismatch true)) ast))) (defn validate-interfaces [{:keys [env form interfaces]}] (when-not (every? #(.isInterface ^Class %) (disj interfaces Object)) (throw (ex-info "only interfaces or Object can be implemented by deftype/reify" (merge {:interfaces interfaces :form form} (source-info env)))))) (defmethod -validate :deftype [{:keys [class-name] :as ast}] (validate-interfaces ast) (assoc ast :class-name (u/maybe-class class-name))) (defmethod -validate :reify [{:keys [class-name] :as ast}] (validate-interfaces ast) (assoc ast :class-name (u/maybe-class class-name))) (defmethod -validate :default [ast] ast) (defn validate-tag [t {:keys [env] :as ast}] (let [tag (ast t)] (if-let [the-class (u/maybe-class tag)] {t the-class} (if-let [handle (-> (env/deref-env) :passes-opts :validate/wrong-tag-handler)] (handle t ast) (throw (ex-info (str "Class not found: " tag) (merge {:class tag :ast (prewalk ast cleanup)} (source-info env)))))))) (defn validate "Validate tags, classes, method calls. Throws exceptions when invalid forms are encountered, replaces class symbols with class objects. Passes opts: * :validate/throw-on-arity-mismatch If true, validate will throw on potential arity mismatch * :validate/wrong-tag-handler If bound to a function, will invoke that function instead of throwing on invalid tag. The function takes the tag key (or :name/tag if the node is :def and the wrong tag is the one on the :name field meta) and the originating AST node and must return a map (or nil) that will be merged into the AST, possibly shadowing the wrong tag with Object or nil. * :validate/unresolvable-symbol-handler If bound to a function, will invoke that function instead of throwing on unresolvable symbol. The function takes three arguments: the namespace (possibly nil) and name part of the symbol, as symbols and the originating AST node which can be either a :maybe-class or a :maybe-host-form, those nodes are documented in the tools.analyzer quickref. The function must return a valid tools.analyzer.jvm AST node." {:pass-info {:walk :post :depends #{#'infer-tag #'analyze-host-expr #'validate-recur}}} [{:keys [tag form env] :as ast}] (let [ast (merge (-validate ast) (when tag {:tag tag}))] (merge ast (when (:tag ast) (validate-tag :tag ast)) (when (:o-tag ast) (validate-tag :o-tag ast)) (when (:return-tag ast) (validate-tag :return-tag ast))))) validate_loop_locals.clj 0000664 0000000 0000000 00000014260 13122450003 0037536 0 ustar 00root root 0000000 0000000 tools.analyzer.jvm-tools.analyzer.jvm-0.7.1/src/main/clojure/clojure/tools/analyzer/passes/jvm ;; 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.jvm.validate-loop-locals (:require [clojure.tools.analyzer.ast :refer [postwalk children update-children]] [clojure.tools.analyzer.jvm.utils :refer [wider-tag maybe-class primitive?]] [clojure.tools.analyzer.passes.jvm [validate :refer [validate]] [classify-invoke :refer [classify-invoke]] [infer-tag :refer [infer-tag]] [analyze-host-expr :refer [analyze-host-expr]]])) (def ^:dynamic ^:private validating nil) (def ^:dynamic ^:private mismatch?) (def ^:dynamic ^:private *loop-locals* []) (defn find-mismatches [{:keys [op exprs] :as ast} bindings] (case op :recur (when (some true? (mapv (fn [e {:keys [tag init form]}] (and (or (primitive? tag) (not (or (:tag (meta form)) (:tag (meta (:form init)))))) (not= (:tag e) tag))) exprs bindings)) (swap! mismatch? conj (mapv :tag exprs))) :do (doseq [child (children ast)] (find-mismatches child bindings)) (:let :letfn) (find-mismatches (:body ast) bindings) :if (do (find-mismatches (:then ast) bindings) (find-mismatches (:else ast) bindings)) :case (do (find-mismatches (:default ast) bindings) (doseq [child (:thens ast)] (find-mismatches child bindings))) nil) ast) (defmulti -validate-loop-locals (fn [_ {:keys [op]}] op)) (defmulti -cleanup-dirty-nodes :op) (defmethod -cleanup-dirty-nodes :local [{:keys [form name atom env] :as ast}] (if-let [cast ((:loop-locals-casts env) name)] (assoc ast :dirty? true :o-tag cast :tag (or (:tag (meta form)) cast)) (if (and (:dirty? @atom) (not (:tag (meta form)))) (dissoc (assoc ast :dirty? true) :o-tag :tag) ast))) (defn dirty [ast] (when-let [atom (:atom ast)] (swap! atom assoc :dirty? true)) (assoc (update-children ast (fn [ast] (dissoc ast :dirty?))) :dirty? true)) (defmethod -cleanup-dirty-nodes :do [{:keys [op ret] :as ast}] (if (:dirty? ret) (dissoc (dirty ast) :tag) ast)) ;; should check for :tag meta form (defmethod -cleanup-dirty-nodes :default [{:keys [op] :as ast}] (if (some :dirty? (children ast)) (dissoc (dirty ast) :tag :validated? (when (= :instance-call op) :class)) ast)) (defn -validate-loop-locals* [analyze {:keys [body env loop-id] :as ast} key] (if validating ast (binding [mismatch? (atom #{})] (let [bindings (key ast)] (find-mismatches body bindings) (if-let [mismatches (seq @mismatch?)] (let [bindings-form (apply mapv (fn [{:keys [form tag]} & mismatches] (when-not (every? #{tag} mismatches) (let [tags (conj mismatches tag)] (with-meta form {:tag (or (and (some primitive? tags) (wider-tag tags)) Object)})))) bindings mismatches) loop-locals (mapv :name bindings) binds (zipmap loop-locals (mapv (comp maybe-class :tag meta) bindings-form)) analyze* (fn [ast] (analyze (postwalk ast (fn [ast] (when-let [atom (:atom ast)] (swap! atom dissoc :dirty?)) ast))))] (binding [validating loop-id *loop-locals* loop-locals] (analyze* (dissoc (postwalk (assoc ast key (mapv (fn [{:keys [atom] :as bind} f] (if f (do (swap! atom assoc :dirty? true) (assoc (dissoc bind :tag) :form f)) bind)) (key ast) bindings-form)) (comp -cleanup-dirty-nodes (fn [ast] (assoc-in ast [:env :loop-locals-casts] binds)))) :dirty?)))) ast))))) (defmethod -validate-loop-locals :loop [analyze ast] (-validate-loop-locals* analyze ast :bindings)) (defmethod -validate-loop-locals :fn-method [analyze ast] (-validate-loop-locals* analyze ast :params)) (defmethod -validate-loop-locals :method [analyze ast] (-validate-loop-locals* analyze ast :params)) (defmethod -validate-loop-locals :recur [_ {:keys [exprs env loop-id] :as ast}] (if (= validating loop-id) (let [casts (:loop-locals-casts env)] (assoc ast :exprs (mapv (fn [{:keys [env form] :as e} n] (if-let [c (casts n)] (assoc e :tag c) e)) exprs *loop-locals*))) ast)) (defmethod -validate-loop-locals :default [_ ast] ast) (defn validate-loop-locals "Returns a pass that validates the loop locals, calling analyze on the loop AST when a mismatched loop-local is found" {:pass-info {:walk :post :depends #{#'validate} :affects #{#'analyze-host-expr #'infer-tag #'validate} :after #{#'classify-invoke}}} [analyze] (fn [ast] (-validate-loop-locals analyze ast))) validate_recur.clj 0000664 0000000 0000000 00000003033 13122450003 0036344 0 ustar 00root root 0000000 0000000 tools.analyzer.jvm-tools.analyzer.jvm-0.7.1/src/main/clojure/clojure/tools/analyzer/passes/jvm ;; 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.jvm.validate-recur (:require [clojure.tools.analyzer.ast :refer [update-children]] [clojure.tools.analyzer.utils :refer [-source-info]])) (defmulti validate-recur "Ensures recurs don't cross try boundaries" {:pass-info {:walk :pre :depends #{}}} :op) (defmethod validate-recur :default [ast] (if (-> ast :env :no-recur) (update-children ast (fn [ast] (update-in ast [:env] assoc :no-recur true))) ast)) (defmethod validate-recur :try [ast] (update-children ast (fn [ast] (update-in ast [:env] assoc :no-recur true)))) (defmethod validate-recur :fn-method [ast] (update-in ast [:env] dissoc :no-recur)) (defmethod validate-recur :method [ast] (update-in ast [:env] dissoc :no-recur)) (defmethod validate-recur :loop [ast] (update-in ast [:env] dissoc :no-recur)) (defmethod validate-recur :recur [ast] (when (-> ast :env :no-recur) (throw (ex-info "Cannot recur accross try" (merge {:form (:form ast)} (-source-info (:form ast) (:env ast)))))) ast) warn_on_reflection.clj 0000664 0000000 0000000 00000004372 13122450003 0037237 0 ustar 00root root 0000000 0000000 tools.analyzer.jvm-tools.analyzer.jvm-0.7.1/src/main/clojure/clojure/tools/analyzer/passes/jvm ;; 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.jvm.warn-on-reflection (:require [clojure.tools.analyzer.passes.jvm [validate-loop-locals :refer [validate-loop-locals]] [validate :refer [validate]]])) (defn warn [what {:keys [file line column]}] (when *warn-on-reflection* (binding [*err* *out*] (println (str "Reflection warning: " (when file (str file ":")) (when line (str line ":")) (when column (str column " ")) "- " what))))) (defmulti warn-on-reflection "Prints a warning to *err* when *warn-on-reflection* is true and a node requires runtime reflection" {:pass-info {:walk :pre :depends #{#'validate} :after #{#'validate-loop-locals}}} :op) (defmethod warn-on-reflection :instance-call [ast] (when-not (:validated? ast) (warn (str "call to method " (:method ast) (when-let [class (:class ast)] (str " on " (.getName ^Class class))) " cannot be resolved") (:env ast))) ast) (defmethod warn-on-reflection :static-call [ast] (when-not (:validated? ast) (warn (str "call to static method " (:method ast) " on " (.getName ^Class (:class ast)) " cannot be resolved") (:env ast))) ast) (defmethod warn-on-reflection :host-interop [ast] (warn (str "reference to field or no args method call " (:m-or-f ast) " cannot be resolved") (:env ast)) ast) (defmethod warn-on-reflection :new [ast] (when-not (:validated? ast) (warn (str "call to " (.getName ^Class (:val (:class ast))) " ctor cannot be resolved") (:env ast))) ast) (defmethod warn-on-reflection :default [ast] ast) tools.analyzer.jvm-tools.analyzer.jvm-0.7.1/src/test/ 0000775 0000000 0000000 00000000000 13122450003 0022607 5 ustar 00root root 0000000 0000000 tools.analyzer.jvm-tools.analyzer.jvm-0.7.1/src/test/clojure/ 0000775 0000000 0000000 00000000000 13122450003 0024252 5 ustar 00root root 0000000 0000000 tools.analyzer.jvm-tools.analyzer.jvm-0.7.1/src/test/clojure/clojure/ 0000775 0000000 0000000 00000000000 13122450003 0025715 5 ustar 00root root 0000000 0000000 tools.analyzer.jvm-tools.analyzer.jvm-0.7.1/src/test/clojure/clojure/tools/ 0000775 0000000 0000000 00000000000 13122450003 0027055 5 ustar 00root root 0000000 0000000 tools.analyzer.jvm-tools.analyzer.jvm-0.7.1/src/test/clojure/clojure/tools/analyzer/ 0000775 0000000 0000000 00000000000 13122450003 0030702 5 ustar 00root root 0000000 0000000 tools.analyzer.jvm-tools.analyzer.jvm-0.7.1/src/test/clojure/clojure/tools/analyzer/jvm/ 0000775 0000000 0000000 00000000000 13122450003 0031476 5 ustar 00root root 0000000 0000000 core_test.clj 0000664 0000000 0000000 00000010033 13122450003 0034075 0 ustar 00root root 0000000 0000000 tools.analyzer.jvm-tools.analyzer.jvm-0.7.1/src/test/clojure/clojure/tools/analyzer/jvm (ns clojure.tools.analyzer.jvm.core-test (:refer-clojure :exclude [macroexpand-1]) (:require [clojure.tools.analyzer :as ana] [clojure.tools.analyzer.jvm :as ana.jvm] [clojure.tools.analyzer.env :as env] [clojure.tools.analyzer.passes.elide-meta :refer [elides elide-meta]] [clojure.tools.analyzer.ast :refer [postwalk]] [clojure.test :refer [deftest is]])) (defprotocol p (f [_])) (defn f1 [^long x]) (def e (ana.jvm/empty-env)) (defmacro ast [form] `(binding [ana/macroexpand-1 ana.jvm/macroexpand-1 ana/create-var ana.jvm/create-var ana/parse ana.jvm/parse ana/var? var? elides {:all #{:line :column :file}}] (env/with-env (ana.jvm/global-env) (postwalk (ana/analyze '~form e) elide-meta)))) (defmacro ast1 [form] `(binding [ana/macroexpand-1 ana.jvm/macroexpand-1 ana/create-var ana.jvm/create-var ana/parse ana.jvm/parse ana/var? var? elides {:all #{:line :column :file}}] (ana.jvm/analyze '~form e))) (defmacro mexpand [form] `(ana.jvm/macroexpand-1 '~form e)) (deftest macroexpander-test (is (= (list '. (list 'do java.lang.Object) 'toString) (mexpand (.toString Object)))) (is (= (list '. java.lang.Integer '(parseInt "2")) (mexpand (Integer/parseInt "2"))))) (deftest analyzer-test (let [v-ast (ast #'+)] (is (= :the-var (:op v-ast))) (is (= #'+ (:var v-ast)))) (let [mn-ast (ast (monitor-enter 1))] (is (= :monitor-enter (:op mn-ast))) (is (= 1 (-> mn-ast :target :form)))) (let [mx-ast (ast (monitor-exit 1))] (is (= :monitor-exit (:op mx-ast))) (is (= 1 (-> mx-ast :target :form)))) (let [i-ast (ast (clojure.core/import* "java.lang.String"))] (is (= :import (:op i-ast))) (is (= "java.lang.String" (:class i-ast)))) (let [r-ast (ast ^:foo (reify Object (toString [this] "") Appendable (^Appendable append [this ^char x] this)))] (is (= :with-meta (-> r-ast :op))) ;; line/column info (is (= :reify (-> r-ast :expr :op))) (is (= #{Appendable clojure.lang.IObj} (-> r-ast :expr :interfaces))) (is (= '#{toString append} (->> r-ast :expr :methods (mapv :name) set)))) (let [dt-ast (ast (deftype* x user.x [a b] :implements [Appendable] (^Appendable append [this ^char x] this)))] (is (= :deftype (-> dt-ast :op))) (is (= '[a b] (->> dt-ast :fields (mapv :name)))) (is (= '[append] (->> dt-ast :methods (mapv :name)))) (is (= 'user.x (-> dt-ast :class-name)))) (let [c-ast (ast (case* 1 0 0 :number {2 [2 :two] 3 [3 :three]} :compact :int))] (is (= :number (-> c-ast :default :form))) (is (= #{2 3} (->> c-ast :tests (mapv (comp :form :test)) set))) (is (= #{:three :two} (->> c-ast :thens (mapv (comp :form :then)) set))) (is (= 3 (-> c-ast :high))) (is (= :int (-> c-ast :test-type))) (is (= :compact (-> c-ast :switch-type))) (is (= 2 (-> c-ast :low))) (is (= 0 (-> c-ast :shift))) (is (= 0 (-> c-ast :mask)))) (is (= Throwable (-> (ast1 (try (catch :default e))) :catches first :class :val))) (is (= Exception (-> (ast1 (try (catch Exception e e))) :catches first :body :tag)))) (deftest doseq-chunk-hint (let [tree (ast1 (doseq [item (range 10)] (println item))) {[_ chunk] :bindings} tree] (is (= :loop (:op tree))) (is (.startsWith (name (:name chunk)) "chunk")) (is (= clojure.lang.IChunk (:tag chunk))))) (def ^:dynamic x) (deftest set!-dynamic-var (is (ast1 (set! x 1)))) (deftest analyze-proxy (is (ast1 (proxy [Object] [])))) (deftest analyze-record (is (ast1 (defrecord TestRecord [x y])))) (deftest eq-no-reflection (is (:validated? (-> (ast1 (fn [s] (= s \f))) :methods first :body)))) (deftest analyze+eval-context-test (let [do-ast (ana.jvm/analyze+eval '(do 1 2 3))] (is (= :ctx/statement (-> do-ast :statements first :env :context))))) passes_test.clj 0000664 0000000 0000000 00000017513 13122450003 0034455 0 ustar 00root root 0000000 0000000 tools.analyzer.jvm-tools.analyzer.jvm-0.7.1/src/test/clojure/clojure/tools/analyzer/jvm (ns clojure.tools.analyzer.jvm.passes-test (:refer-clojure :exclude [macroexpand-1]) (:require [clojure.tools.analyzer.ast :refer :all] [clojure.tools.analyzer.jvm :as ana.jvm] [clojure.tools.analyzer.env :as env] [clojure.tools.analyzer.passes :refer [schedule]] [clojure.test :refer [deftest is]] [clojure.set :as set] [clojure.tools.analyzer.passes.add-binding-atom :refer [add-binding-atom]] [clojure.tools.analyzer.passes.collect-closed-overs :refer [collect-closed-overs]] [clojure.tools.analyzer.jvm.core-test :refer [ast ast1 e f f1]] [clojure.tools.analyzer.passes.jvm.emit-form :refer [emit-form emit-hygienic-form]] [clojure.tools.analyzer.passes.jvm.validate :as v] [clojure.tools.analyzer.passes.jvm.annotate-tag :refer [annotate-tag]] [clojure.tools.analyzer.passes.jvm.infer-tag :refer [infer-tag]] [clojure.tools.analyzer.passes.jvm.annotate-branch :refer [annotate-branch]] [clojure.tools.analyzer.passes.jvm.annotate-host-info :refer [annotate-host-info]] [clojure.tools.analyzer.passes.jvm.annotate-loops :refer [annotate-loops]] [clojure.tools.analyzer.passes.jvm.fix-case-test :refer [fix-case-test]] [clojure.tools.analyzer.passes.jvm.analyze-host-expr :refer [analyze-host-expr]] [clojure.tools.analyzer.passes.jvm.classify-invoke :refer [classify-invoke]]) (:import (clojure.lang Keyword Var Symbol AFunction PersistentVector PersistentArrayMap PersistentHashSet ISeq) java.util.regex.Pattern)) (defn validate [ast] (env/with-env (ana.jvm/global-env) (v/validate ast))) (deftest emit-form-test (is (= '(monitor-enter 1) (emit-form (ast (monitor-enter 1))))) (is (= '(monitor-exit 1) (emit-form (ast (monitor-exit 1))))) (is (= '(clojure.core/import* "java.lang.String") (emit-form (validate (ast (clojure.core/import* "java.lang.String")))))) (is (= '(var clojure.core/+) (emit-form (ast #'+)))) (is (= '(:foo {}) (emit-form (ast (:foo {}))))) (is (= '(try 1 (catch Exception e nil)) (emit-form (ana.jvm/analyze '(try 1 (catch Exception e)))))) (is (= '(try 1 (catch Exception e nil)) (emit-form (ana.jvm/analyze '(try 1 (catch Exception e))) {:qualifed-symbols true}))) (is (= '(f [] 1) (emit-form (ast (f [] 1)))))) (deftest annotate-branch-test (let [i-ast (annotate-branch (ast (if 1 2 3)))] (is (:branch? i-ast)) (is (= true (-> i-ast :test :test?))) (is (= true (-> i-ast :then :path?))) (is (= true (-> i-ast :else :path?)))) (let [fn-ast (prewalk (ast (fn ([]) ([x]))) annotate-branch)] (is (every? :path? (-> fn-ast :methods)))) (let [r-ast (prewalk (ast (reify Object (toString [this] x))) annotate-branch)] (is (every? :path? (-> r-ast :methods)))) (let [c-ast (-> (ast (case 1 0 0 2 2 1)) :body :ret (prewalk annotate-branch))] (is (:branch? c-ast)) (is (= true (-> c-ast :test :test?))) (is (= true (-> c-ast :default :path?))) (is (every? :path? (-> c-ast :thens))))) (deftest fix-case-test-test (let [c-ast (-> (ast (case 1 1 1)) add-binding-atom (prewalk fix-case-test))] (is (= true (-> c-ast :body :ret :test :atom deref :case-test))))) (deftest annotate-tag-test (is (= PersistentVector (-> {:op :const :form [] :val []} annotate-tag :tag))) (is (= PersistentVector (-> (ast []) annotate-tag :tag))) (is (= PersistentArrayMap(-> (ast {}) annotate-tag :tag))) (is (= PersistentHashSet (-> (ast #{}) annotate-tag :tag))) (is (= Class (-> {:op :const :type :class :form Object :val Object} annotate-tag :tag))) (is (= String (-> (ast "foo") annotate-tag :tag))) (is (= Keyword (-> (ast :foo) annotate-tag :tag))) (is (= Character/TYPE (-> (ast \f) annotate-tag :tag))) (is (= Long/TYPE (-> (ast 1) annotate-tag :tag))) (is (= Pattern (-> (ast #"foo") annotate-tag :tag))) (is (= Var (-> (ast #'+) annotate-tag :tag))) (is (= Boolean (-> (ast true) annotate-tag :tag))) (let [b-ast (-> (ast (let [a 1] a)) add-binding-atom (postwalk annotate-tag))] (is (= Long/TYPE (-> b-ast :body :ret :tag))))) (deftest classify-invoke-test (is (= :keyword-invoke (-> (ast (:foo {})) classify-invoke :op))) (is (= :invoke (-> (ast (:foo {} 1)) classify-invoke :op))) (is (= :protocol-invoke (-> (ast (f nil)) classify-invoke :op))) (is (= :instance? (-> (ast (instance? String "")) (prewalk analyze-host-expr) classify-invoke :op))) (is (= :prim-invoke (-> (ast (f1 1)) (prewalk infer-tag) classify-invoke :op)))) (deftest annotate-host-info-test (let [r-ast (-> (ast ^:foo (reify Object (toString [_] ""))) (prewalk annotate-host-info))] (is (= 'toString (-> r-ast :expr :methods first :name))) (is (= [] (-> r-ast :expr :methods first :params))) (is (= '_ (-> r-ast :expr :methods first :this :name))))) ;; TODO: test primitives, tag matching, throwing validation, method validation (deftest validate-test (is (= Exception (-> (ast (try (catch Exception e))) (prewalk (comp validate analyze-host-expr)) :catches first :class :val))) (is (-> (ast (set! *warn-on-reflection* true)) validate)) (is (= true (-> (ast (String. "foo")) (postwalk (comp validate annotate-tag analyze-host-expr)) :validated?))) (let [s-ast (-> (ast (Integer/parseInt "7")) (prewalk annotate-tag) analyze-host-expr validate)] (is (:validated? s-ast)) (is (= Integer/TYPE (:tag s-ast))) (is (= [String] (mapv :tag (:args s-ast))))) (let [i-ast (-> (ast (.hashCode "7")) (prewalk annotate-tag) analyze-host-expr validate)] (is (:validated? i-ast)) (is (= Integer/TYPE (:tag i-ast))) (is (= [] (mapv :tag (:args i-ast)))) (is (= String (:class i-ast)))) (is (= true (-> (ast (import java.lang.String)) (prewalk validate) :ret :validated?)))) ;; we need all or most those passes to perform those tests (deftest all-passes-test (let [t-ast (ast1 (let [a 1 b 2 c (str a) d (Integer/parseInt c b)] (Integer/getInteger c d)))] (is (= Integer (-> t-ast :body :tag))) (is (= Integer (-> t-ast :tag))) (is (= Long/TYPE (->> t-ast :bindings (filter #(= 'a (:form %))) first :tag))) (is (= String (->> t-ast :bindings (filter #(= 'c (:form %))) first :tag))) (is (= Integer/TYPE (->> t-ast :bindings (filter #(= 'd (:form %))) first :tag)))) (is (= Void/TYPE (:tag (ast1 (.println System/out "foo"))))) (is (= String (-> (ast1 String) :val))) (is (= 'String (-> (ast1 String) :form))) (is (= PersistentVector (-> (ast1 '[]) :tag))) (is (= ISeq (-> (ast1 '()) :tag))) (let [d-ast (ast1 (Double/isInfinite 2))] (is (= Boolean/TYPE (-> d-ast :tag))) (is (= Double/TYPE (->> d-ast :args first :tag))))) ;; checks for specific bugs that have surfaced (deftest annotate-case-loop (is (ast1 (loop [] (case 1 :a (recur) :b 42))))) (deftest var-tag-inference (let [ast (ana.jvm/analyze '(def a "foo") (ana.jvm/empty-env) {:passes-opts (merge ana.jvm/default-passes-opts {:infer-tag/level :global})})] (is (= String (-> ast :var meta :tag))))) (deftest validate-handlers ;; test for tanal-24, without the handler analysis would throw ;; with an handler that ignores the tag, we can simulate the current behaviour ;; of the clojure compiler (is (ana.jvm/analyze '(defn ^long a [] 1) (ana.jvm/empty-env) {:passes-opts (merge ana.jvm/default-passes-opts {:validate/wrong-tag-handler (fn [t ast] {t nil})})}))) tools.analyzer.jvm AST Quickref
Common AST fields
{common}Nodes reference
{nodes}