diff options
Diffstat (limited to 'luxc')
42 files changed, 15527 insertions, 0 deletions
diff --git a/luxc/code_of_conduct.md b/luxc/code_of_conduct.md new file mode 100644 index 000000000..01b8644f1 --- /dev/null +++ b/luxc/code_of_conduct.md @@ -0,0 +1,22 @@ +# Contributor Code of Conduct + +As contributors and maintainers of this project, and in the interest of fostering an open and welcoming community, we pledge to respect all people who contribute through reporting issues, posting feature requests, updating documentation, submitting pull requests or patches, and other activities. + +We are committed to making participation in this project a harassment-free experience for everyone, regardless of level of experience, gender, gender identity and expression, sexual orientation, disability, personal appearance, body size, race, ethnicity, age, religion, or nationality. + +Examples of unacceptable behavior by participants include: + +* The use of sexualized language or imagery +* Personal attacks +* Trolling or insulting/derogatory comments +* Public or private harassment +* Publishing other's private information, such as physical or electronic addresses, without explicit permission +* Other unethical or unprofessional conduct. + +Project maintainers have the right and responsibility to remove, edit, or reject comments, commits, code, wiki edits, issues, and other contributions that are not aligned to this Code of Conduct. By adopting this Code of Conduct, project maintainers commit themselves to fairly and consistently applying these principles to every aspect of managing this project. Project maintainers who do not follow or enforce the Code of Conduct may be permanently removed from the project team. + +This code of conduct applies both within project spaces and in public spaces when an individual is representing the project or its community. + +Instances of abusive, harassing, or otherwise unacceptable behavior may be reported by opening an issue or contacting one or more of the project maintainers. + +This Code of Conduct is adapted from the [Contributor Covenant](http://contributor-covenant.org), version 1.2.0, available at [http://contributor-covenant.org/version/1/2/0/](http://contributor-covenant.org/version/1/2/0/) diff --git a/luxc/license.txt b/luxc/license.txt new file mode 100644 index 000000000..52d135112 --- /dev/null +++ b/luxc/license.txt @@ -0,0 +1,374 @@ +Mozilla Public License Version 2.0 +================================== + +1. Definitions +-------------- + +1.1. "Contributor" + means each individual or legal entity that creates, contributes to + the creation of, or owns Covered Software. + +1.2. "Contributor Version" + means the combination of the Contributions of others (if any) used + by a Contributor and that particular Contributor's Contribution. + +1.3. "Contribution" + means Covered Software of a particular Contributor. + +1.4. "Covered Software" + means Source Code Form to which the initial Contributor has attached + the notice in Exhibit A, the Executable Form of such Source Code + Form, and Modifications of such Source Code Form, in each case + including portions thereof. + +1.5. "Incompatible With Secondary Licenses" + means + + (a) that the initial Contributor has attached the notice described + in Exhibit B to the Covered Software; or + + (b) that the Covered Software was made available under the terms of + version 1.1 or earlier of the License, but not also under the + terms of a Secondary License. + +1.6. "Executable Form" + means any form of the work other than Source Code Form. + +1.7. "Larger Work" + means a work that combines Covered Software with other material, in + a separate file or files, that is not Covered Software. + +1.8. "License" + means this document. + +1.9. "Licensable" + means having the right to grant, to the maximum extent possible, + whether at the time of the initial grant or subsequently, any and + all of the rights conveyed by this License. + +1.10. "Modifications" + means any of the following: + + (a) any file in Source Code Form that results from an addition to, + deletion from, or modification of the contents of Covered + Software; or + + (b) any new file in Source Code Form that contains any Covered + Software. + +1.11. "Patent Claims" of a Contributor + means any patent claim(s), including without limitation, method, + process, and apparatus claims, in any patent Licensable by such + Contributor that would be infringed, but for the grant of the + License, by the making, using, selling, offering for sale, having + made, import, or transfer of either its Contributions or its + Contributor Version. + +1.12. "Secondary License" + means either the GNU General Public License, Version 2.0, the GNU + Lesser General Public License, Version 2.1, the GNU Affero General + Public License, Version 3.0, or any later versions of those + licenses. + +1.13. "Source Code Form" + means the form of the work preferred for making modifications. + +1.14. "You" (or "Your") + means an individual or a legal entity exercising rights under this + License. For legal entities, "You" includes any entity that + controls, is controlled by, or is under common control with You. For + purposes of this definition, "control" means (a) the power, direct + or indirect, to cause the direction or management of such entity, + whether by contract or otherwise, or (b) ownership of more than + fifty percent (50%) of the outstanding shares or beneficial + ownership of such entity. + +2. License Grants and Conditions +-------------------------------- + +2.1. Grants + +Each Contributor hereby grants You a world-wide, royalty-free, +non-exclusive license: + +(a) under intellectual property rights (other than patent or trademark) + Licensable by such Contributor to use, reproduce, make available, + modify, display, perform, distribute, and otherwise exploit its + Contributions, either on an unmodified basis, with Modifications, or + as part of a Larger Work; and + +(b) under Patent Claims of such Contributor to make, use, sell, offer + for sale, have made, import, and otherwise transfer either its + Contributions or its Contributor Version. + +2.2. Effective Date + +The licenses granted in Section 2.1 with respect to any Contribution +become effective for each Contribution on the date the Contributor first +distributes such Contribution. + +2.3. Limitations on Grant Scope + +The licenses granted in this Section 2 are the only rights granted under +this License. No additional rights or licenses will be implied from the +distribution or licensing of Covered Software under this License. +Notwithstanding Section 2.1(b) above, no patent license is granted by a +Contributor: + +(a) for any code that a Contributor has removed from Covered Software; + or + +(b) for infringements caused by: (i) Your and any other third party's + modifications of Covered Software, or (ii) the combination of its + Contributions with other software (except as part of its Contributor + Version); or + +(c) under Patent Claims infringed by Covered Software in the absence of + its Contributions. + +This License does not grant any rights in the trademarks, service marks, +or logos of any Contributor (except as may be necessary to comply with +the notice requirements in Section 3.4). + +2.4. Subsequent Licenses + +No Contributor makes additional grants as a result of Your choice to +distribute the Covered Software under a subsequent version of this +License (see Section 10.2) or under the terms of a Secondary License (if +permitted under the terms of Section 3.3). + +2.5. Representation + +Each Contributor represents that the Contributor believes its +Contributions are its original creation(s) or it has sufficient rights +to grant the rights to its Contributions conveyed by this License. + +2.6. Fair Use + +This License is not intended to limit any rights You have under +applicable copyright doctrines of fair use, fair dealing, or other +equivalents. + +2.7. Conditions + +Sections 3.1, 3.2, 3.3, and 3.4 are conditions of the licenses granted +in Section 2.1. + +3. Responsibilities +------------------- + +3.1. Distribution of Source Form + +All distribution of Covered Software in Source Code Form, including any +Modifications that You create or to which You contribute, must be under +the terms of this License. You must inform recipients that the Source +Code Form of the Covered Software is governed by the terms of this +License, and how they can obtain a copy of this License. You may not +attempt to alter or restrict the recipients' rights in the Source Code +Form. + +3.2. Distribution of Executable Form + +If You distribute Covered Software in Executable Form then: + +(a) such Covered Software must also be made available in Source Code + Form, as described in Section 3.1, and You must inform recipients of + the Executable Form how they can obtain a copy of such Source Code + Form by reasonable means in a timely manner, at a charge no more + than the cost of distribution to the recipient; and + +(b) You may distribute such Executable Form under the terms of this + License, or sublicense it under different terms, provided that the + license for the Executable Form does not attempt to limit or alter + the recipients' rights in the Source Code Form under this License. + +3.3. Distribution of a Larger Work + +You may create and distribute a Larger Work under terms of Your choice, +provided that You also comply with the requirements of this License for +the Covered Software. If the Larger Work is a combination of Covered +Software with a work governed by one or more Secondary Licenses, and the +Covered Software is not Incompatible With Secondary Licenses, this +License permits You to additionally distribute such Covered Software +under the terms of such Secondary License(s), so that the recipient of +the Larger Work may, at their option, further distribute the Covered +Software under the terms of either this License or such Secondary +License(s). + +3.4. Notices + +You may not remove or alter the substance of any license notices +(including copyright notices, patent notices, disclaimers of warranty, +or limitations of liability) contained within the Source Code Form of +the Covered Software, except that You may alter any license notices to +the extent required to remedy known factual inaccuracies. + +3.5. Application of Additional Terms + +You may choose to offer, and to charge a fee for, warranty, support, +indemnity or liability obligations to one or more recipients of Covered +Software. However, You may do so only on Your own behalf, and not on +behalf of any Contributor. You must make it absolutely clear that any +such warranty, support, indemnity, or liability obligation is offered by +You alone, and You hereby agree to indemnify every Contributor for any +liability incurred by such Contributor as a result of warranty, support, +indemnity or liability terms You offer. You may include additional +disclaimers of warranty and limitations of liability specific to any +jurisdiction. + +4. Inability to Comply Due to Statute or Regulation +--------------------------------------------------- + +If it is impossible for You to comply with any of the terms of this +License with respect to some or all of the Covered Software due to +statute, judicial order, or regulation then You must: (a) comply with +the terms of this License to the maximum extent possible; and (b) +describe the limitations and the code they affect. Such description must +be placed in a text file included with all distributions of the Covered +Software under this License. Except to the extent prohibited by statute +or regulation, such description must be sufficiently detailed for a +recipient of ordinary skill to be able to understand it. + +5. Termination +-------------- + +5.1. The rights granted under this License will terminate automatically +if You fail to comply with any of its terms. However, if You become +compliant, then the rights granted under this License from a particular +Contributor are reinstated (a) provisionally, unless and until such +Contributor explicitly and finally terminates Your grants, and (b) on an +ongoing basis, if such Contributor fails to notify You of the +non-compliance by some reasonable means prior to 60 days after You have +come back into compliance. Moreover, Your grants from a particular +Contributor are reinstated on an ongoing basis if such Contributor +notifies You of the non-compliance by some reasonable means, this is the +first time You have received notice of non-compliance with this License +from such Contributor, and You become compliant prior to 30 days after +Your receipt of the notice. + +5.2. If You initiate litigation against any entity by asserting a patent +infringement claim (excluding declaratory judgment actions, +counter-claims, and cross-claims) alleging that a Contributor Version +directly or indirectly infringes any patent, then the rights granted to +You by any and all Contributors for the Covered Software under Section +2.1 of this License shall terminate. + +5.3. In the event of termination under Sections 5.1 or 5.2 above, all +end user license agreements (excluding distributors and resellers) which +have been validly granted by You or Your distributors under this License +prior to termination shall survive termination. + +************************************************************************ +* * +* 6. Disclaimer of Warranty * +* ------------------------- * +* * +* Covered Software is provided under this License on an "as is" * +* basis, without warranty of any kind, either expressed, implied, or * +* statutory, including, without limitation, warranties that the * +* Covered Software is free of defects, merchantable, fit for a * +* particular purpose or non-infringing. The entire risk as to the * +* quality and performance of the Covered Software is with You. * +* Should any Covered Software prove defective in any respect, You * +* (not any Contributor) assume the cost of any necessary servicing, * +* repair, or correction. This disclaimer of warranty constitutes an * +* essential part of this License. No use of any Covered Software is * +* authorized under this License except under this disclaimer. * +* * +************************************************************************ + +************************************************************************ +* * +* 7. Limitation of Liability * +* -------------------------- * +* * +* Under no circumstances and under no legal theory, whether tort * +* (including negligence), contract, or otherwise, shall any * +* Contributor, or anyone who distributes Covered Software as * +* permitted above, be liable to You for any direct, indirect, * +* special, incidental, or consequential damages of any character * +* including, without limitation, damages for lost profits, loss of * +* goodwill, work stoppage, computer failure or malfunction, or any * +* and all other commercial damages or losses, even if such party * +* shall have been informed of the possibility of such damages. This * +* limitation of liability shall not apply to liability for death or * +* personal injury resulting from such party's negligence to the * +* extent applicable law prohibits such limitation. Some * +* jurisdictions do not allow the exclusion or limitation of * +* incidental or consequential damages, so this exclusion and * +* limitation may not apply to You. * +* * +************************************************************************ + +8. Litigation +------------- + +Any litigation relating to this License may be brought only in the +courts of a jurisdiction where the defendant maintains its principal +place of business and such litigation shall be governed by laws of that +jurisdiction, without reference to its conflict-of-law provisions. +Nothing in this Section shall prevent a party's ability to bring +cross-claims or counter-claims. + +9. Miscellaneous +---------------- + +This License represents the complete agreement concerning the subject +matter hereof. If any provision of this License is held to be +unenforceable, such provision shall be reformed only to the extent +necessary to make it enforceable. Any law or regulation which provides +that the language of a contract shall be construed against the drafter +shall not be used to construe this License against a Contributor. + +10. Versions of the License +--------------------------- + +10.1. New Versions + +Mozilla Foundation is the license steward. Except as provided in Section +10.3, no one other than the license steward has the right to modify or +publish new versions of this License. Each version will be given a +distinguishing version number. + +10.2. Effect of New Versions + +You may distribute the Covered Software under the terms of the version +of the License under which You originally received the Covered Software, +or under the terms of any subsequent version published by the license +steward. + +10.3. Modified Versions + +If you create software not governed by this License, and you want to +create a new license for such software, you may create and use a +modified version of this License if you rename the license and remove +any references to the name of the license steward (except to note that +such modified license differs from this License). + +10.4. Distributing Source Code Form that is Incompatible With Secondary +Licenses + +If You choose to distribute Source Code Form that is Incompatible With +Secondary Licenses under the terms of this version of the License, the +notice described in Exhibit B of this License must be attached. + +Exhibit A - Source Code Form License Notice +------------------------------------------- + + This Source Code Form is subject to the terms of the Mozilla Public + License, v. 2.0. If a copy of the MPL was not distributed with this + file, You can obtain one at http://mozilla.org/MPL/2.0/. + +If it is not possible or desirable to put the notice in a particular +file, then You may include the notice in a location (such as a LICENSE +file in a relevant directory) where a recipient would be likely to look +for such a notice. + +You may add additional accurate notices of copyright ownership. + +Exhibit B - "Incompatible With Secondary Licenses" Notice +--------------------------------------------------------- + + This Source Code Form is "Incompatible With Secondary Licenses", as + defined by the Mozilla Public License, v. 2.0. + diff --git a/luxc/project.clj b/luxc/project.clj new file mode 100644 index 000000000..4650fbd58 --- /dev/null +++ b/luxc/project.clj @@ -0,0 +1,30 @@ +(defproject com.github.luxlang/luxc-jvm "0.5.0-SNAPSHOT" + :min-lein-version "2.1.0" ;; 2.1.0 introduced jar classifiers + :description "The JVM compiler for the Lux programming language." + :url "https://github.com/LuxLang/lux" + :license {:name "Mozilla Public License (Version 2.0)" + :url "https://www.mozilla.org/en-US/MPL/2.0/"} + :deploy-repositories [["releases" {:url "https://oss.sonatype.org/service/local/staging/deploy/maven2/" + :creds :gpg}] + ["snapshots" {:url "https://oss.sonatype.org/content/repositories/snapshots/" + :creds :gpg}]] + :pom-addition [:developers [:developer + [:name "Eduardo Julian"] + [:url "https://github.com/eduardoejp"]]] + :dependencies [[org.clojure/clojure "1.6.0"] + [org.clojure/core.match "0.2.1"] + [org.ow2.asm/asm-all "5.0.3"]] + :warn-on-reflection true + :main lux + :repositories [["snapshots" "https://oss.sonatype.org/content/repositories/snapshots/"] + ["releases" "https://oss.sonatype.org/service/local/staging/deploy/maven2/"]] + :source-paths ["src"] + + :classifiers {:sources {:resource-paths ["src"]} + :javadoc {:resource-paths ["src"]}} + + :aot [lux] + + :jvm-opts ^:replace ["-server" "-Xms2048m" "-Xmx2048m" + "-XX:+OptimizeStringConcat"] + ) diff --git a/luxc/src/lux.clj b/luxc/src/lux.clj new file mode 100644 index 000000000..4f73f79e0 --- /dev/null +++ b/luxc/src/lux.clj @@ -0,0 +1,52 @@ +;; Copyright (c) Eduardo Julian. All rights reserved. +;; This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +;; If a copy of the MPL was not distributed with this file, +;; You can obtain one at http://mozilla.org/MPL/2.0/. + +(ns lux + (:gen-class) + (:require [lux.base :as & :refer [|let |do return fail return* fail* |case]] + [lux.compiler.base :as &compiler-base] + [lux.compiler :as &compiler] + [lux.repl :as &repl] + [clojure.string :as string] + :reload-all) + (:import (java.io File))) + +(def unit-separator (str (char 31))) + +(defn ^:private process-dirs + "(-> Text (List Text))" + [resources-dirs] + (-> resources-dirs + (string/replace unit-separator "\n") + string/split-lines + &/->list)) + +(defn -main [& args] + (|case (&/->list args) + (&/$Cons "release" (&/$Cons program-module (&/$Cons resources-dirs (&/$Cons source-dirs (&/$Cons target-dir (&/$Nil)))))) + (time (&compiler/compile-program &/$Release program-module (process-dirs resources-dirs) (process-dirs source-dirs) target-dir)) + + (&/$Cons "debug" (&/$Cons program-module (&/$Cons resources-dirs (&/$Cons source-dirs (&/$Cons target-dir (&/$Nil)))))) + (time (&compiler/compile-program &/$Debug program-module (process-dirs resources-dirs) (process-dirs source-dirs) target-dir)) + + (&/$Cons "repl" (&/$Cons source-dirs (&/$Nil))) + (&repl/repl (process-dirs source-dirs)) + + _ + (println "Can't understand command."))) + +(comment + (-main "release" "tests" + "/home/eduardoejp/workspace/projects/lux-stdlib/resources" + (str "/home/eduardoejp/workspace/projects/lux-stdlib/source" unit-separator + "/home/eduardoejp/workspace/projects/lux-stdlib/test") + "/home/eduardoejp/workspace/projects/lux/target/jvm") + + (-main "release" "tests" + "/home/eduardoejp/workspace/projects/lux-stdlib/resources" + (str "/home/eduardoejp/workspace/projects/lux-stdlib/source" unit-separator + "/home/eduardoejp/workspace/projects/lux-stdlib/test") + "/home/eduardoejp/workspace/projects/lux-stdlib/target/jvm") + ) diff --git a/luxc/src/lux/analyser.clj b/luxc/src/lux/analyser.clj new file mode 100644 index 000000000..4133927e7 --- /dev/null +++ b/luxc/src/lux/analyser.clj @@ -0,0 +1,211 @@ +;; Copyright (c) Eduardo Julian. All rights reserved. +;; This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +;; If a copy of the MPL was not distributed with this file, +;; You can obtain one at http://mozilla.org/MPL/2.0/. + +(ns lux.analyser + (:require (clojure [template :refer [do-template]]) + clojure.core.match + clojure.core.match.array + (lux [base :as & :refer [|let |do return fail return* fail* |case]] + [reader :as &reader] + [parser :as &parser] + [type :as &type] + [host :as &host]) + (lux.analyser [base :as &&] + [lux :as &&lux] + [host :as &&host] + [module :as &&module] + [parser :as &&a-parser]))) + +;; [Utils] +(defn analyse-variant+ [analyse exo-type ident values] + (|do [[module tag-name] (&/normalize ident) + _ (&&module/ensure-can-see-tag module tag-name) + idx (&&module/tag-index module tag-name) + group (&&module/tag-group module tag-name) + :let [is-last? (= idx (dec (&/|length group)))]] + (if (= 1 (&/|length group)) + (|do [_cursor &/cursor] + (analyse exo-type (&/T [_cursor (&/$TupleS values)]))) + (|case exo-type + (&/$VarT id) + (|do [? (&type/bound? id)] + (if (or ? (&&/type-tag? module tag-name)) + (&&lux/analyse-variant analyse (&/$Right exo-type) idx is-last? values) + (|do [wanted-type (&&module/tag-type module tag-name) + wanted-type* (&type/instantiate-inference wanted-type) + [[variant-type variant-cursor] variant-analysis] (&&/cap-1 (&&lux/analyse-variant analyse (&/$Left wanted-type*) idx is-last? values)) + _ (&type/check exo-type variant-type)] + (return (&/|list (&&/|meta exo-type variant-cursor variant-analysis)))))) + + _ + (&&lux/analyse-variant analyse (&/$Right exo-type) idx is-last? values) + )) + )) + +(defn ^:private just-analyse [analyser syntax] + (&type/with-var + (fn [?var] + (|do [[[?output-type ?output-cursor] ?output-term] (&&/analyse-1 analyser ?var syntax)] + (|case [?var ?output-type] + [(&/$VarT ?e-id) (&/$VarT ?a-id)] + (if (= ?e-id ?a-id) + (|do [=output-type (&type/clean ?var ?output-type)] + (return (&&/|meta =output-type ?output-cursor ?output-term))) + (|do [=output-type (&type/clean ?var ?var)] + (return (&&/|meta =output-type ?output-cursor ?output-term)))) + + [_ _] + (|do [=output-type (&type/clean ?var ?output-type)] + (return (&&/|meta =output-type ?output-cursor ?output-term)))) + )))) + +(defn ^:private analyse-ast [optimize eval! compile-module compilers exo-type ?token] + (|let [analyse (partial analyse-ast optimize eval! compile-module compilers) + [cursor token] ?token + [compile-def compile-program compile-class compile-interface] compilers] + (|case token + ;; Standard special forms + (&/$BoolS ?value) + (|do [_ (&type/check exo-type &type/Bool)] + (return (&/|list (&&/|meta exo-type cursor (&&/$bool ?value))))) + + (&/$NatS ?value) + (|do [_ (&type/check exo-type &type/Nat)] + (return (&/|list (&&/|meta exo-type cursor (&&/$nat ?value))))) + + (&/$IntS ?value) + (|do [_ (&type/check exo-type &type/Int)] + (return (&/|list (&&/|meta exo-type cursor (&&/$int ?value))))) + + (&/$RealS ?value) + (|do [_ (&type/check exo-type &type/Real)] + (return (&/|list (&&/|meta exo-type cursor (&&/$real ?value))))) + + (&/$CharS ?value) + (|do [_ (&type/check exo-type &type/Char)] + (return (&/|list (&&/|meta exo-type cursor (&&/$char ?value))))) + + (&/$TextS ?value) + (|do [_ (&type/check exo-type &type/Text)] + (return (&/|list (&&/|meta exo-type cursor (&&/$text ?value))))) + + (&/$TupleS ?elems) + (&/with-analysis-meta cursor exo-type + (&&lux/analyse-tuple analyse (&/$Right exo-type) ?elems)) + + (&/$RecordS ?elems) + (&/with-analysis-meta cursor exo-type + (&&lux/analyse-record analyse exo-type ?elems)) + + (&/$TagS ?ident) + (&/with-analysis-meta cursor exo-type + (analyse-variant+ analyse exo-type ?ident &/$Nil)) + + (&/$SymbolS ?ident) + (&/with-analysis-meta cursor exo-type + (&&lux/analyse-symbol analyse exo-type ?ident)) + + (&/$FormS (&/$Cons [command-meta command] parameters)) + (|case command + (&/$SymbolS _ command-name) + (case command-name + "_lux_case" + (|let [(&/$Cons ?value ?branches) parameters] + (&/with-analysis-meta cursor exo-type + (&&lux/analyse-case analyse exo-type ?value ?branches))) + + "_lux_lambda" + (|let [(&/$Cons [_ (&/$SymbolS "" ?self)] + (&/$Cons [_ (&/$SymbolS "" ?arg)] + (&/$Cons ?body + (&/$Nil)))) parameters] + (&/with-analysis-meta cursor exo-type + (&&lux/analyse-lambda analyse exo-type ?self ?arg ?body))) + + "_lux_proc" + (|let [(&/$Cons [_ (&/$TupleS (&/$Cons [_ (&/$TextS ?category)] + (&/$Cons [_ (&/$TextS ?proc)] + (&/$Nil))))] + (&/$Cons [_ (&/$TupleS ?args)] + (&/$Nil))) parameters] + (&/with-analysis-meta cursor exo-type + (&&host/analyse-host analyse exo-type compilers ?category ?proc ?args))) + + "_lux_:" + (|let [(&/$Cons ?type + (&/$Cons ?value + (&/$Nil))) parameters] + (&/with-analysis-meta cursor exo-type + (&&lux/analyse-ann analyse eval! exo-type ?type ?value))) + + "_lux_:!" + (|let [(&/$Cons ?type + (&/$Cons ?value + (&/$Nil))) parameters] + (&/with-analysis-meta cursor exo-type + (&&lux/analyse-coerce analyse eval! exo-type ?type ?value))) + + "_lux_def" + (|let [(&/$Cons [_ (&/$SymbolS "" ?name)] + (&/$Cons ?value + (&/$Cons ?meta + (&/$Nil)) + )) parameters] + (&/with-cursor cursor + (&&lux/analyse-def analyse optimize eval! compile-def ?name ?value ?meta))) + + "_lux_module" + (|let [(&/$Cons ?meta (&/$Nil)) parameters] + (&/with-cursor cursor + (&&lux/analyse-module analyse optimize eval! compile-module ?meta))) + + "_lux_program" + (|let [(&/$Cons [_ (&/$SymbolS "" ?args)] + (&/$Cons ?body + (&/$Nil))) parameters] + (&/with-cursor cursor + (&&lux/analyse-program analyse optimize compile-program ?args ?body))) + + ;; else + (&/with-cursor cursor + (|do [=fn (just-analyse analyse (&/T [command-meta command]))] + (&&lux/analyse-apply analyse cursor exo-type =fn parameters)))) + + (&/$NatS idx) + (&/with-analysis-meta cursor exo-type + (&&lux/analyse-variant analyse (&/$Right exo-type) idx nil parameters)) + + (&/$TagS ?ident) + (&/with-analysis-meta cursor exo-type + (analyse-variant+ analyse exo-type ?ident parameters)) + + _ + (&/with-cursor cursor + (|do [=fn (just-analyse analyse (&/T [command-meta command]))] + (&&lux/analyse-apply analyse cursor exo-type =fn parameters)))) + + _ + (&/fail-with-loc (str "[Analyser Error] Unknown syntax: " (prn-str (&/show-ast (&/T [(&/T ["" -1 -1]) token]))))) + ))) + +;; [Resources] +(defn analyse [optimize eval! compile-module compilers] + (|do [asts &parser/parse] + (&/flat-map% (partial analyse-ast optimize eval! compile-module compilers &/$VoidT) asts))) + +(defn clean-output [?var analysis] + (|do [:let [[[?output-type ?output-cursor] ?output-term] analysis] + =output-type (&type/clean ?var ?output-type)] + (return (&&/|meta =output-type ?output-cursor ?output-term)))) + +(defn repl-analyse [optimize eval! compile-module compilers] + (|do [asts &parser/parse] + (&/flat-map% (fn [ast] + (&type/with-var + (fn [?var] + (|do [=outputs (&/with-closure + (analyse-ast optimize eval! compile-module compilers ?var ast))] + (&/map% (partial clean-output ?var) =outputs))))) + asts))) diff --git a/luxc/src/lux/analyser/base.clj b/luxc/src/lux/analyser/base.clj new file mode 100644 index 000000000..9bdcdeb11 --- /dev/null +++ b/luxc/src/lux/analyser/base.clj @@ -0,0 +1,131 @@ +;; Copyright (c) Eduardo Julian. All rights reserved. +;; This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +;; If a copy of the MPL was not distributed with this file, +;; You can obtain one at http://mozilla.org/MPL/2.0/. + +(ns lux.analyser.base + (:require clojure.core.match + clojure.core.match.array + (lux [base :as & :refer [defvariant |let |do return* return fail |case]] + [type :as &type]))) + +;; [Tags] +(defvariant + ("bool" 1) + ("nat" 1) + ("int" 1) + ("frac" 1) + ("real" 1) + ("char" 1) + ("text" 1) + ("variant" 3) + ("tuple" 1) + ("apply" 2) + ("case" 2) + ("lambda" 4) + ("ann" 2) + ("var" 1) + ("captured" 1) + ("proc" 3) + ) + +;; [Exports] +(defn expr-meta [analysis] + (|let [[meta _] analysis] + meta)) + +(defn expr-type* [analysis] + (|let [[[type _] _] analysis] + type)) + +(defn expr-term [analysis] + (|let [[[type _] term] analysis] + term)) + +(defn with-type [new-type analysis] + (|let [[[type cursor] adt] analysis] + (&/T [(&/T [new-type cursor]) adt]))) + +(defn clean-analysis [$var an] + "(-> Type Analysis (Lux Analysis))" + (|do [=an-type (&type/clean $var (expr-type* an))] + (return (with-type =an-type an)))) + +(def jvm-this "_jvm_this") + +(defn cap-1 [action] + (|do [result action] + (|case result + (&/$Cons x (&/$Nil)) + (return x) + + _ + (fail "[Analyser Error] Can't expand to other than 1 element.")))) + +(defn analyse-1 [analyse exo-type elem] + (&/with-expected-type exo-type + (cap-1 (analyse exo-type elem)))) + +(defn analyse-1+ [analyse ?token] + (&type/with-var + (fn [$var] + (|do [=expr (analyse-1 analyse $var ?token)] + (clean-analysis $var =expr))))) + +(defn resolved-ident [ident] + (|do [:let [[?module ?name] ident] + module* (if (.equals "" ?module) + &/get-module-name + (return ?module))] + (return (&/T [module* ?name])))) + +(let [tag-names #{"HostT" "VoidT" "UnitT" "SumT" "ProdT" "LambdaT" "BoundT" "VarT" "ExT" "UnivQ" "ExQ" "AppT" "NamedT"}] + (defn type-tag? [module name] + (and (= "lux" module) + (contains? tag-names name)))) + +(defn |meta [type cursor analysis] + (&/T [(&/T [type cursor]) analysis])) + +(defn de-meta + "(-> Analysis Analysis)" + [analysis] + (|let [[meta analysis-] analysis] + (|case analysis- + ($variant idx is-last? value) + ($variant idx is-last? (de-meta value)) + + ($tuple elems) + ($tuple (&/|map de-meta elems)) + + ($apply func args) + ($apply (de-meta func) + (&/|map de-meta args)) + + ($case value branches) + ($case (de-meta value) + (&/|map (fn [branch] + (|let [[_pattern _body] branch] + (&/T [_pattern (de-meta _body)]))) + branches)) + + ($lambda _register-offset scope captured body) + ($lambda _register-offset scope + (&/|map (fn [branch] + (|let [[_name _captured] branch] + (&/T [_name (de-meta _captured)]))) + captured) + (de-meta body)) + + ($ann value-expr type-expr) + (de-meta value-expr) + + ($captured scope idx source) + ($captured scope idx (de-meta source)) + + ($proc proc-ident args special-args) + ($proc proc-ident (&/|map de-meta args) special-args) + + _ + analysis- + ))) diff --git a/luxc/src/lux/analyser/case.clj b/luxc/src/lux/analyser/case.clj new file mode 100644 index 000000000..6841577a8 --- /dev/null +++ b/luxc/src/lux/analyser/case.clj @@ -0,0 +1,654 @@ +;; Copyright (c) Eduardo Julian. All rights reserved. +;; This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +;; If a copy of the MPL was not distributed with this file, +;; You can obtain one at http://mozilla.org/MPL/2.0/. + +(ns lux.analyser.case + (:require clojure.core.match + clojure.core.match.array + (lux [base :as & :refer [defvariant |do return fail |let |case]] + [parser :as &parser] + [type :as &type]) + (lux.analyser [base :as &&] + [env :as &env] + [module :as &module] + [record :as &&record]))) + +;; [Tags] +(defvariant + ("DefaultTotal" 1) + ("BoolTotal" 2) + ("NatTotal" 2) + ("IntTotal" 2) + ("FracTotal" 2) + ("RealTotal" 2) + ("CharTotal" 2) + ("TextTotal" 2) + ("TupleTotal" 2) + ("VariantTotal" 2)) + +(defvariant + ("NoTestAC" 0) + ("StoreTestAC" 1) + ("BoolTestAC" 1) + ("NatTestAC" 1) + ("IntTestAC" 1) + ("FracTestAC" 1) + ("RealTestAC" 1) + ("CharTestAC" 1) + ("TextTestAC" 1) + ("TupleTestAC" 1) + ("VariantTestAC" 1)) + +;; [Utils] +(def ^:private unit-tuple + (&/T [(&/T ["" -1 -1]) (&/$TupleS &/$Nil)])) + +(defn ^:private resolve-type [type] + (|case type + (&/$VarT ?id) + (|do [type* (&/try-all% (&/|list (&type/deref ?id) + (fail "##1##")))] + (resolve-type type*)) + + (&/$UnivQ _) + (|do [$var &type/existential + =type (&type/apply-type type $var)] + (&type/actual-type =type)) + + (&/$ExQ _ _) + (|do [$var &type/existential + =type (&type/apply-type type $var)] + (&type/actual-type =type)) + + _ + (&type/actual-type type))) + +(defn update-up-frame [frame] + (|let [[_env _idx _var] frame] + (&/T [_env (+ 2 _idx) _var]))) + +(defn clean! [level ?tid bound-idx type] + (|case type + (&/$VarT ?id) + (if (= ?tid ?id) + (&/$BoundT (+ (* 2 level) bound-idx)) + type) + + (&/$HostT ?name ?params) + (&/$HostT ?name (&/|map (partial clean! level ?tid bound-idx) + ?params)) + + (&/$LambdaT ?arg ?return) + (&/$LambdaT (clean! level ?tid bound-idx ?arg) + (clean! level ?tid bound-idx ?return)) + + (&/$AppT ?lambda ?param) + (&/$AppT (clean! level ?tid bound-idx ?lambda) + (clean! level ?tid bound-idx ?param)) + + (&/$ProdT ?left ?right) + (&/$ProdT (clean! level ?tid bound-idx ?left) + (clean! level ?tid bound-idx ?right)) + + (&/$SumT ?left ?right) + (&/$SumT (clean! level ?tid bound-idx ?left) + (clean! level ?tid bound-idx ?right)) + + (&/$UnivQ ?env ?body) + (&/$UnivQ (&/|map (partial clean! level ?tid bound-idx) ?env) + (clean! (inc level) ?tid bound-idx ?body)) + + (&/$ExQ ?env ?body) + (&/$ExQ (&/|map (partial clean! level ?tid bound-idx) ?env) + (clean! (inc level) ?tid bound-idx ?body)) + + _ + type + )) + +(defn beta-reduce! [level env type] + (|case type + (&/$HostT ?name ?params) + (&/$HostT ?name (&/|map (partial beta-reduce! level env) ?params)) + + (&/$SumT ?left ?right) + (&/$SumT (beta-reduce! level env ?left) + (beta-reduce! level env ?right)) + + (&/$ProdT ?left ?right) + (&/$ProdT (beta-reduce! level env ?left) + (beta-reduce! level env ?right)) + + (&/$AppT ?type-fn ?type-arg) + (&/$AppT (beta-reduce! level env ?type-fn) + (beta-reduce! level env ?type-arg)) + + (&/$UnivQ ?local-env ?local-def) + (&/$UnivQ ?local-env (beta-reduce! (inc level) env ?local-def)) + + (&/$ExQ ?local-env ?local-def) + (&/$ExQ ?local-env (beta-reduce! (inc level) env ?local-def)) + + (&/$LambdaT ?input ?output) + (&/$LambdaT (beta-reduce! level env ?input) + (beta-reduce! level env ?output)) + + (&/$BoundT ?idx) + (|case (&/|at (- ?idx (* 2 level)) env) + (&/$Some bound) + (beta-reduce! level env bound) + + _ + type) + + _ + type + )) + +(defn apply-type! [type-fn param] + (|case type-fn + (&/$UnivQ local-env local-def) + (return (beta-reduce! 0 (->> local-env + (&/$Cons param) + (&/$Cons type-fn)) + local-def)) + + (&/$ExQ local-env local-def) + (return (beta-reduce! 0 (->> local-env + (&/$Cons param) + (&/$Cons type-fn)) + local-def)) + + (&/$AppT F A) + (|do [type-fn* (apply-type! F A)] + (apply-type! type-fn* param)) + + (&/$NamedT ?name ?type) + (apply-type! ?type param) + + (&/$ExT id) + (return (&/$AppT type-fn param)) + + (&/$VarT id) + (|do [=type-fun (deref id)] + (apply-type! =type-fun param)) + + _ + (fail (str "[Type System] Not a type function:\n" (&type/show-type type-fn) "\n")))) + +(defn adjust-type* [up type] + "(-> (List (, (Maybe (List Type)) Int Type)) Type (Lux Type))" + (|case type + (&/$UnivQ _aenv _abody) + (&type/with-var + (fn [$var] + (|do [=type (apply-type! type $var) + ==type (adjust-type* (&/$Cons (&/T [_aenv 1 $var]) (&/|map update-up-frame up)) =type)] + (&type/clean $var ==type)))) + + (&/$ExQ _aenv _abody) + (|do [$var &type/existential + =type (apply-type! type $var)] + (adjust-type* up =type)) + + (&/$ProdT ?left ?right) + (|do [:let [=type (&/fold (fn [_abody ena] + (|let [[_aenv _aidx (&/$VarT _avar)] ena] + (clean! 0 _avar _aidx _abody))) + type + up)] + :let [distributor (fn [v] + (&/fold (fn [_abody ena] + (|let [[_aenv _aidx _avar] ena] + (&/$UnivQ _aenv _abody))) + v + up)) + adjusted-type (&type/Tuple$ (&/|map distributor (&type/flatten-prod =type)))]] + (return adjusted-type)) + + (&/$SumT ?left ?right) + (|do [:let [=type (&/fold (fn [_abody ena] + (|let [[_aenv _aidx (&/$VarT _avar)] ena] + (clean! 0 _avar _aidx _abody))) + type + up)] + :let [distributor (fn [v] + (&/fold (fn [_abody ena] + (|let [[_aenv _aidx _avar] ena] + (&/$UnivQ _aenv _abody))) + v + up)) + adjusted-type (&type/Variant$ (&/|map distributor (&type/flatten-sum =type)))]] + (return adjusted-type)) + + (&/$AppT ?tfun ?targ) + (|do [=type (apply-type! ?tfun ?targ)] + (adjust-type* up =type)) + + (&/$VarT ?id) + (|do [type* (&/try-all% (&/|list (&type/deref ?id) + (fail (str "##2##: " ?id))))] + (adjust-type* up type*)) + + (&/$NamedT ?name ?type) + (adjust-type* up ?type) + + (&/$UnitT) + (return type) + + _ + (fail (str "[Pattern-matching Error] Can't adjust type: " (&type/show-type type))) + )) + +(defn adjust-type [type] + "(-> Type (Lux Type))" + (adjust-type* &/$Nil type)) + +(defn ^:private analyse-pattern [var?? value-type pattern kont] + (|let [[meta pattern*] pattern] + (|case pattern* + (&/$SymbolS "" name) + (|case var?? + (&/$Some var-analysis) + (|do [=kont (&env/with-alias name var-analysis + kont)] + (return (&/T [$NoTestAC =kont]))) + + _ + (|do [=kont (&env/with-local name value-type + kont) + idx &env/next-local-idx] + (return (&/T [($StoreTestAC idx) =kont])))) + + (&/$SymbolS ident) + (fail (str "[Pattern-matching Error] Symbols must be unqualified: " (&/ident->text ident))) + + (&/$BoolS ?value) + (|do [_ (&type/check value-type &type/Bool) + =kont kont] + (return (&/T [($BoolTestAC ?value) =kont]))) + + (&/$NatS ?value) + (|do [_ (&type/check value-type &type/Nat) + =kont kont] + (return (&/T [($NatTestAC ?value) =kont]))) + + (&/$IntS ?value) + (|do [_ (&type/check value-type &type/Int) + =kont kont] + (return (&/T [($IntTestAC ?value) =kont]))) + + (&/$FracS ?value) + (|do [_ (&type/check value-type &type/Frac) + =kont kont] + (return (&/T [($FracTestAC ?value) =kont]))) + + (&/$RealS ?value) + (|do [_ (&type/check value-type &type/Real) + =kont kont] + (return (&/T [($RealTestAC ?value) =kont]))) + + (&/$CharS ?value) + (|do [_ (&type/check value-type &type/Char) + =kont kont] + (return (&/T [($CharTestAC ?value) =kont]))) + + (&/$TextS ?value) + (|do [_ (&type/check value-type &type/Text) + =kont kont] + (return (&/T [($TextTestAC ?value) =kont]))) + + (&/$TupleS ?members) + (|case ?members + (&/$Nil) + (|do [_ (&type/check value-type &/$UnitT) + =kont kont] + (return (&/T [($TupleTestAC (&/|list)) =kont]))) + + (&/$Cons ?member (&/$Nil)) + (analyse-pattern var?? value-type ?member kont) + + _ + (|do [must-infer? (&type/unknown? value-type) + value-type* (if must-infer? + (|do [member-types (&/map% (fn [_] &type/create-var+) (&/|range (&/|length ?members)))] + (return (&type/fold-prod member-types))) + (adjust-type value-type))] + (|case value-type* + (&/$ProdT _) + (|let [num-elems (&/|length ?members) + [_shorter _tuple-types] (&type/tuple-types-for (&/|length ?members) value-type*)] + (if (= num-elems _shorter) + (|do [[=tests =kont] (&/fold (fn [kont* vm] + (|let [[v m] vm] + (|do [[=test [=tests =kont]] (analyse-pattern &/$None v m kont*)] + (return (&/T [(&/$Cons =test =tests) =kont]))))) + (|do [=kont kont] + (return (&/T [&/$Nil =kont]))) + (&/|reverse (&/zip2 _tuple-types ?members)))] + (return (&/T [($TupleTestAC =tests) =kont]))) + (fail (str "[Pattern-matching Error] Pattern-matching mismatch. Require tuple[" (&/|length (&type/flatten-prod value-type*)) "]. Given tuple [" (&/|length ?members) "]" + " -- " (&/show-ast pattern) + " " (&type/show-type value-type*) " " (&type/show-type value-type))))) + + _ + (fail (str "[Pattern-matching Error] Tuples require tuple-types: " (&type/show-type value-type)))))) + + (&/$RecordS pairs) + (|do [[rec-members rec-type] (&&record/order-record pairs) + must-infer? (&type/unknown? value-type) + rec-type* (if must-infer? + (&type/instantiate-inference rec-type) + (return value-type)) + _ (&type/check value-type rec-type*)] + (analyse-pattern &/$None rec-type* (&/T [meta (&/$TupleS rec-members)]) kont)) + + (&/$TagS ?ident) + (|do [[=module =name] (&&/resolved-ident ?ident) + must-infer? (&type/unknown? value-type) + variant-type (if must-infer? + (|do [variant-type (&module/tag-type =module =name) + variant-type* (&type/instantiate-inference variant-type) + _ (&type/check value-type variant-type*)] + (return variant-type*)) + (return value-type)) + value-type* (adjust-type variant-type) + idx (&module/tag-index =module =name) + group (&module/tag-group =module =name) + case-type (&type/sum-at idx value-type*) + [=test =kont] (analyse-pattern &/$None case-type unit-tuple kont)] + (return (&/T [($VariantTestAC (&/T [idx (&/|length group) =test])) =kont]))) + + (&/$FormS (&/$Cons [_ (&/$NatS idx)] ?values)) + (|do [value-type* (adjust-type value-type) + case-type (&type/sum-at idx value-type*) + [=test =kont] (case (int (&/|length ?values)) + 0 (analyse-pattern &/$None case-type unit-tuple kont) + 1 (analyse-pattern &/$None case-type (&/|head ?values) kont) + ;; 1+ + (analyse-pattern &/$None case-type (&/T [(&/T ["" -1 -1]) (&/$TupleS ?values)]) kont))] + (return (&/T [($VariantTestAC (&/T [idx (&/|length (&type/flatten-sum value-type*)) =test])) =kont]))) + + (&/$FormS (&/$Cons [_ (&/$TagS ?ident)] ?values)) + (|do [[=module =name] (&&/resolved-ident ?ident) + must-infer? (&type/unknown? value-type) + variant-type (if must-infer? + (|do [variant-type (&module/tag-type =module =name) + variant-type* (&type/instantiate-inference variant-type) + _ (&type/check value-type variant-type*)] + (return variant-type*)) + (return value-type)) + value-type* (adjust-type variant-type) + idx (&module/tag-index =module =name) + group (&module/tag-group =module =name) + case-type (&type/sum-at idx value-type*) + [=test =kont] (case (int (&/|length ?values)) + 0 (analyse-pattern &/$None case-type unit-tuple kont) + 1 (analyse-pattern &/$None case-type (&/|head ?values) kont) + ;; 1+ + (analyse-pattern &/$None case-type (&/T [(&/T ["" -1 -1]) (&/$TupleS ?values)]) kont))] + (return (&/T [($VariantTestAC (&/T [idx (&/|length group) =test])) =kont]))) + + _ + (fail (str "[Pattern-matching Error] Unrecognized pattern syntax: " (&/show-ast pattern))) + ))) + +(defn ^:private analyse-branch [analyse exo-type var?? value-type pattern body patterns] + (|do [pattern+body (analyse-pattern var?? value-type pattern + (&&/analyse-1 analyse exo-type body))] + (return (&/$Cons pattern+body patterns)))) + +(defn ^:private merge-total [struct test+body] + (|let [[test ?body] test+body] + (|case [struct test] + [($DefaultTotal total?) ($NoTestAC)] + (return ($DefaultTotal true)) + + [($BoolTotal total? ?values) ($NoTestAC)] + (return ($BoolTotal true ?values)) + + [($NatTotal total? ?values) ($NoTestAC)] + (return ($NatTotal true ?values)) + + [($IntTotal total? ?values) ($NoTestAC)] + (return ($IntTotal true ?values)) + + [($FracTotal total? ?values) ($NoTestAC)] + (return ($FracTotal true ?values)) + + [($RealTotal total? ?values) ($NoTestAC)] + (return ($RealTotal true ?values)) + + [($CharTotal total? ?values) ($NoTestAC)] + (return ($CharTotal true ?values)) + + [($TextTotal total? ?values) ($NoTestAC)] + (return ($TextTotal true ?values)) + + [($TupleTotal total? ?values) ($NoTestAC)] + (return ($TupleTotal true ?values)) + + [($VariantTotal total? ?values) ($NoTestAC)] + (return ($VariantTotal true ?values)) + + [($DefaultTotal total?) ($StoreTestAC ?idx)] + (return ($DefaultTotal true)) + + [($BoolTotal total? ?values) ($StoreTestAC ?idx)] + (return ($BoolTotal true ?values)) + + [($NatTotal total? ?values) ($StoreTestAC ?idx)] + (return ($NatTotal true ?values)) + + [($IntTotal total? ?values) ($StoreTestAC ?idx)] + (return ($IntTotal true ?values)) + + [($FracTotal total? ?values) ($StoreTestAC ?idx)] + (return ($FracTotal true ?values)) + + [($RealTotal total? ?values) ($StoreTestAC ?idx)] + (return ($RealTotal true ?values)) + + [($CharTotal total? ?values) ($StoreTestAC ?idx)] + (return ($CharTotal true ?values)) + + [($TextTotal total? ?values) ($StoreTestAC ?idx)] + (return ($TextTotal true ?values)) + + [($TupleTotal total? ?values) ($StoreTestAC ?idx)] + (return ($TupleTotal true ?values)) + + [($VariantTotal total? ?values) ($StoreTestAC ?idx)] + (return ($VariantTotal true ?values)) + + [($DefaultTotal total?) ($BoolTestAC ?value)] + (return ($BoolTotal total? (&/|list ?value))) + + [($BoolTotal total? ?values) ($BoolTestAC ?value)] + (return ($BoolTotal total? (&/$Cons ?value ?values))) + + [($DefaultTotal total?) ($NatTestAC ?value)] + (return ($NatTotal total? (&/|list ?value))) + + [($NatTotal total? ?values) ($NatTestAC ?value)] + (return ($NatTotal total? (&/$Cons ?value ?values))) + + [($DefaultTotal total?) ($IntTestAC ?value)] + (return ($IntTotal total? (&/|list ?value))) + + [($IntTotal total? ?values) ($IntTestAC ?value)] + (return ($IntTotal total? (&/$Cons ?value ?values))) + + [($DefaultTotal total?) ($FracTestAC ?value)] + (return ($FracTotal total? (&/|list ?value))) + + [($FracTotal total? ?values) ($FracTestAC ?value)] + (return ($FracTotal total? (&/$Cons ?value ?values))) + + [($DefaultTotal total?) ($RealTestAC ?value)] + (return ($RealTotal total? (&/|list ?value))) + + [($RealTotal total? ?values) ($RealTestAC ?value)] + (return ($RealTotal total? (&/$Cons ?value ?values))) + + [($DefaultTotal total?) ($CharTestAC ?value)] + (return ($CharTotal total? (&/|list ?value))) + + [($CharTotal total? ?values) ($CharTestAC ?value)] + (return ($CharTotal total? (&/$Cons ?value ?values))) + + [($DefaultTotal total?) ($TextTestAC ?value)] + (return ($TextTotal total? (&/|list ?value))) + + [($TextTotal total? ?values) ($TextTestAC ?value)] + (return ($TextTotal total? (&/$Cons ?value ?values))) + + [($DefaultTotal total?) ($TupleTestAC ?tests)] + (|do [structs (&/map% (fn [t] + (merge-total ($DefaultTotal total?) (&/T [t ?body]))) + ?tests)] + (return ($TupleTotal total? structs))) + + [($TupleTotal total? ?values) ($TupleTestAC ?tests)] + (if (.equals ^Object (&/|length ?values) (&/|length ?tests)) + (|do [structs (&/map2% (fn [v t] + (merge-total v (&/T [t ?body]))) + ?values ?tests)] + (return ($TupleTotal total? structs))) + (fail "[Pattern-matching Error] Inconsistent tuple-size.")) + + [($DefaultTotal total?) ($VariantTestAC ?tag ?count ?test)] + (|do [sub-struct (merge-total ($DefaultTotal total?) + (&/T [?test ?body])) + structs (|case (&/|list-put ?tag sub-struct (&/|repeat ?count ($DefaultTotal total?))) + (&/$Some list) + (return list) + + (&/$None) + (fail "[Pattern-matching Error] YOLO"))] + (return ($VariantTotal total? structs))) + + [($VariantTotal total? ?branches) ($VariantTestAC ?tag ?count ?test)] + (|do [sub-struct (merge-total (|case (&/|at ?tag ?branches) + (&/$Some sub) + sub + + (&/$None) + ($DefaultTotal total?)) + (&/T [?test ?body])) + structs (|case (&/|list-put ?tag sub-struct ?branches) + (&/$Some list) + (return list) + + (&/$None) + (fail "[Pattern-matching Error] YOLO"))] + (return ($VariantTotal total? structs))) + ))) + +(defn check-totality+ [check-totality] + (fn [?token] + (&type/with-var + (fn [$var] + (|do [=output (check-totality $var ?token) + ?type (&type/deref+ $var) + =type (&type/clean $var ?type)] + (return (&/T [=output =type]))))))) + +(defn ^:private check-totality [value-type struct] + (|case struct + ($DefaultTotal ?total) + (return ?total) + + ($BoolTotal ?total ?values) + (|do [_ (&type/check value-type &type/Bool)] + (return (or ?total + (= #{true false} (set (&/->seq ?values)))))) + + ($NatTotal ?total _) + (|do [_ (&type/check value-type &type/Nat)] + (return ?total)) + + ($IntTotal ?total _) + (|do [_ (&type/check value-type &type/Int)] + (return ?total)) + + ($FracTotal ?total _) + (|do [_ (&type/check value-type &type/Frac)] + (return ?total)) + + ($RealTotal ?total _) + (|do [_ (&type/check value-type &type/Real)] + (return ?total)) + + ($CharTotal ?total _) + (|do [_ (&type/check value-type &type/Char)] + (return ?total)) + + ($TextTotal ?total _) + (|do [_ (&type/check value-type &type/Text)] + (return ?total)) + + ($TupleTotal ?total ?structs) + (|case ?structs + (&/$Nil) + (|do [value-type* (resolve-type value-type)] + (|case value-type* + (&/$UnitT) + (return true) + + _ + (fail "[Pattern-maching Error] Unit is not total."))) + + _ + (|do [unknown? (&type/unknown? value-type)] + (if unknown? + (|do [=structs (&/map% (check-totality+ check-totality) ?structs) + _ (&type/check value-type (|case (->> (&/|map &/|second =structs) (&/|reverse)) + (&/$Cons last prevs) + (&/fold (fn [right left] (&/$ProdT left right)) + last prevs)))] + (return (or ?total + (&/fold #(and %1 %2) true (&/|map &/|first =structs))))) + (if ?total + (return true) + (|do [value-type* (resolve-type value-type)] + (|case value-type* + (&/$ProdT _) + (|let [num-elems (&/|length ?structs) + [_shorter _tuple-types] (&type/tuple-types-for (&/|length ?structs) value-type*)] + (if (= num-elems _shorter) + (|do [totals (&/map2% check-totality _tuple-types ?structs)] + (return (&/fold #(and %1 %2) true totals))) + (fail (str "[Pattern-maching Error] Tuple-mismatch. Require tuple[" (&/|length (&type/flatten-prod value-type*)) "]. Given tuple [" (&/|length ?structs) "]")))) + + _ + (fail (str "[Pattern-maching Error] Tuple is not total." " - " (&type/show-type value-type*))))))))) + + ($VariantTotal ?total ?structs) + (if ?total + (return true) + (|do [value-type* (resolve-type value-type)] + (|case value-type* + (&/$SumT _) + (|do [totals (&/map2% check-totality + (&type/flatten-sum value-type*) + ?structs)] + (return (&/fold #(and %1 %2) true totals))) + + _ + (fail "[Pattern-maching Error] Variant is not total.")))) + )) + +;; [Exports] +(defn analyse-branches [analyse exo-type var?? value-type branches] + (|do [patterns (&/fold% (fn [patterns branch] + (|let [[pattern body] branch] + (analyse-branch analyse exo-type var?? value-type pattern body patterns))) + &/$Nil + branches) + struct (&/fold% merge-total ($DefaultTotal false) patterns) + ? (check-totality value-type struct)] + (if ? + (return patterns) + (fail "[Pattern-maching Error] Pattern-matching is non-total.")))) diff --git a/luxc/src/lux/analyser/env.clj b/luxc/src/lux/analyser/env.clj new file mode 100644 index 000000000..75e066e34 --- /dev/null +++ b/luxc/src/lux/analyser/env.clj @@ -0,0 +1,74 @@ +;; Copyright (c) Eduardo Julian. All rights reserved. +;; This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +;; If a copy of the MPL was not distributed with this file, +;; You can obtain one at http://mozilla.org/MPL/2.0/. + +(ns lux.analyser.env + (:require clojure.core.match + clojure.core.match.array + (lux [base :as & :refer [|do return return* fail fail* |case]]) + [lux.analyser.base :as &&])) + +;; [Exports] +(def next-local-idx + (fn [state] + (return* state (->> state (&/get$ &/$scopes) &/|head (&/get$ &/$locals) (&/get$ &/$counter))))) + +(defn with-local [name type body] + (fn [state] + (let [old-mappings (->> state (&/get$ &/$scopes) &/|head (&/get$ &/$locals) (&/get$ &/$mappings)) + =return (body (&/update$ &/$scopes + (fn [stack] + (let [var-analysis (&&/|meta type &/empty-cursor (&&/$var (&/$Local (->> (&/|head stack) (&/get$ &/$locals) (&/get$ &/$counter)))))] + (&/$Cons (&/update$ &/$locals #(->> % + (&/update$ &/$counter inc) + (&/update$ &/$mappings (fn [m] (&/|put name var-analysis m)))) + (&/|head stack)) + (&/|tail stack)))) + state))] + (|case =return + (&/$Right ?state ?value) + (return* (&/update$ &/$scopes (fn [stack*] + (&/$Cons (&/update$ &/$locals #(->> % + (&/update$ &/$counter dec) + (&/set$ &/$mappings old-mappings)) + (&/|head stack*)) + (&/|tail stack*))) + ?state) + ?value) + + _ + =return)))) + +(defn with-alias [name var-analysis body] + (fn [state] + (let [old-mappings (->> state (&/get$ &/$scopes) &/|head (&/get$ &/$locals) (&/get$ &/$mappings)) + =return (body (&/update$ &/$scopes + (fn [stack] + (&/$Cons (&/update$ &/$locals #(->> % + (&/update$ &/$mappings (fn [m] (&/|put name var-analysis m)))) + (&/|head stack)) + (&/|tail stack))) + state))] + (|case =return + (&/$Right ?state ?value) + (return* (&/update$ &/$scopes (fn [stack*] + (&/$Cons (&/update$ &/$locals #(->> % + (&/set$ &/$mappings old-mappings)) + (&/|head stack*)) + (&/|tail stack*))) + ?state) + ?value) + + _ + =return)))) + +(def captured-vars + (fn [state] + (|case (&/get$ &/$scopes state) + (&/$Nil) + (fail* "[Analyser Error] Can't obtain captured vars without environments.") + + (&/$Cons env _) + (return* state (->> env (&/get$ &/$closure) (&/get$ &/$mappings)))) + )) diff --git a/luxc/src/lux/analyser/host.clj b/luxc/src/lux/analyser/host.clj new file mode 100644 index 000000000..209e36d0e --- /dev/null +++ b/luxc/src/lux/analyser/host.clj @@ -0,0 +1,1379 @@ +;; Copyright (c) Eduardo Julian. All rights reserved. +;; This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +;; If a copy of the MPL was not distributed with this file, +;; You can obtain one at http://mozilla.org/MPL/2.0/. + +(ns lux.analyser.host + (:require (clojure [template :refer [do-template]] + [string :as string]) + clojure.core.match + clojure.core.match.array + (lux [base :as & :refer [|let |do return* return |case assert!]] + [type :as &type] + [host :as &host] + [lexer :as &lexer] + [parser :as &parser] + [reader :as &reader]) + [lux.type.host :as &host-type] + [lux.host.generics :as &host-generics] + (lux.analyser [base :as &&] + [lambda :as &&lambda] + [env :as &&env] + [parser :as &&a-parser]) + [lux.compiler.base :as &c!base]) + (:import (java.lang.reflect Type TypeVariable))) + +;; [Utils] +(defn ^:private ensure-catching [exceptions*] + "(-> (List Text) (Lux Null))" + (|do [class-loader &/loader] + (fn [state] + (|let [exceptions (&/|map #(Class/forName % true class-loader) exceptions*) + catching (->> state + (&/get$ &/$host) + (&/get$ &/$catching) + (&/|map #(Class/forName % true class-loader)))] + (if-let [missing-ex (&/fold (fn [prev ^Class now] + (or prev + (cond (or (.isAssignableFrom java.lang.RuntimeException now) + (.isAssignableFrom java.lang.Error now)) + nil + + (&/fold (fn [found? ^Class ex-catch] + (or found? + (.isAssignableFrom ex-catch now))) + false + catching) + nil + + :else + now))) + nil + exceptions)] + ((&/fail-with-loc (str "[Analyser Error] Unhandled exception: " missing-ex)) + state) + (&/return* state nil))) + ))) + +(defn ^:private with-catches [catches body] + "(All [a] (-> (List Text) (Lux a) (Lux a)))" + (fn [state] + (let [old-catches (->> state (&/get$ &/$host) (&/get$ &/$catching)) + state* (->> state (&/update$ &/$host #(&/update$ &/$catching (partial &/|++ catches) %)))] + (|case (&/run-state body state*) + (&/$Left msg) + (&/$Left msg) + + (&/$Right state** output) + (&/$Right (&/T [(->> state** (&/update$ &/$host #(&/set$ &/$catching old-catches %))) + output])))) + )) + +(defn ^:private ensure-object [type] + "(-> Type (Lux (, Text (List Type))))" + (|case type + (&/$HostT payload) + (return payload) + + (&/$VarT id) + (return (&/T ["java.lang.Object" (&/|list)])) + + (&/$ExT id) + (return (&/T ["java.lang.Object" (&/|list)])) + + (&/$NamedT _ type*) + (ensure-object type*) + + (&/$UnivQ _ type*) + (ensure-object type*) + + (&/$ExQ _ type*) + (ensure-object type*) + + (&/$AppT F A) + (|do [type* (&type/apply-type F A)] + (ensure-object type*)) + + _ + (&/fail-with-loc (str "[Analyser Error] Expecting object: " (&type/show-type type))))) + +(defn ^:private as-object [type] + "(-> Type Type)" + (|case type + (&/$HostT class params) + (&/$HostT (&host-type/as-obj class) params) + + _ + type)) + +(defn ^:private as-otype [tname] + (case tname + "boolean" "java.lang.Boolean" + "byte" "java.lang.Byte" + "short" "java.lang.Short" + "int" "java.lang.Integer" + "long" "java.lang.Long" + "float" "java.lang.Float" + "double" "java.lang.Double" + "char" "java.lang.Character" + ;; else + tname + )) + +(defn ^:private as-otype+ [type] + "(-> Type Type)" + (|case type + (&/$HostT name params) + (&/$HostT (as-otype name) params) + + _ + type)) + +(defn ^:private clean-gtype-var [idx gtype-var] + (|let [(&/$VarT id) gtype-var] + (|do [? (&type/bound? id)] + (if ? + (|do [real-type (&type/deref id)] + (return (&/T [idx real-type]))) + (return (&/T [(+ 2 idx) (&/$BoundT idx)])))))) + +(defn ^:private clean-gtype-vars [gtype-vars] + (|do [[_ clean-types] (&/fold% (fn [idx+types gtype-var] + (|do [:let [[idx types] idx+types] + [idx* real-type] (clean-gtype-var idx gtype-var)] + (return (&/T [idx* (&/$Cons real-type types)])))) + (&/T [1 &/$Nil]) + gtype-vars)] + (return clean-types))) + +(defn ^:private make-gtype [class-name type-args] + "(-> Text (List Type) Type)" + (&/fold (fn [base-type type-arg] + (|case type-arg + (&/$BoundT _) + (&/$UnivQ &type/empty-env base-type) + + _ + base-type)) + (&/$HostT class-name type-args) + type-args)) + +;; [Resources] +(defn ^:private analyse-field-access-helper [obj-type gvars gtype] + "(-> Type (List (^ java.lang.reflect.Type)) (^ java.lang.reflect.Type) (Lux Type))" + (|case obj-type + (&/$HostT class targs) + (if (= (&/|length targs) (&/|length gvars)) + (|let [gtype-env (&/fold2 (fn [m ^TypeVariable g t] (&/$Cons (&/T [(.getName g) t]) m)) + (&/|table) + gvars + targs)] + (&host-type/instance-param &type/existential gtype-env gtype)) + (&/fail-with-loc (str "[Type Error] Mismatched number of type-parameters: " (&/|length gvars) " - " (&type/show-type obj-type)))) + + _ + (&/fail-with-loc (str "[Type Error] Type is not an object type: " (&type/show-type obj-type))))) + +(defn generic-class->simple-class [gclass] + "(-> GenericClass Text)" + (|case gclass + (&/$GenericTypeVar var-name) + "java.lang.Object" + + (&/$GenericWildcard _) + "java.lang.Object" + + (&/$GenericClass name params) + name + + (&/$GenericArray param) + (|case param + (&/$GenericArray _) + (str "[" (generic-class->simple-class param)) + + (&/$GenericClass "boolean" _) + "[Z" + + (&/$GenericClass "byte" _) + "[B" + + (&/$GenericClass "short" _) + "[S" + + (&/$GenericClass "int" _) + "[I" + + (&/$GenericClass "long" _) + "[J" + + (&/$GenericClass "float" _) + "[F" + + (&/$GenericClass "double" _) + "[D" + + (&/$GenericClass "char" _) + "[C" + + (&/$GenericClass name params) + (str "[L" name ";") + + (&/$GenericTypeVar var-name) + "[Ljava.lang.Object;" + + (&/$GenericWildcard _) + "[Ljava.lang.Object;") + )) + +(defn generic-class->type [env gclass] + "(-> (List (, TypeVar Type)) GenericClass (Lux Type))" + (|case gclass + (&/$GenericTypeVar var-name) + (if-let [ex (&/|get var-name env)] + (return ex) + (&/fail-with-loc (str "[Analysis Error] Unknown type var: " var-name))) + + (&/$GenericClass name params) + (case name + "boolean" (return (&/$HostT "java.lang.Boolean" &/$Nil)) + "byte" (return (&/$HostT "java.lang.Byte" &/$Nil)) + "short" (return (&/$HostT "java.lang.Short" &/$Nil)) + "int" (return (&/$HostT "java.lang.Integer" &/$Nil)) + "long" (return (&/$HostT "java.lang.Long" &/$Nil)) + "float" (return (&/$HostT "java.lang.Float" &/$Nil)) + "double" (return (&/$HostT "java.lang.Double" &/$Nil)) + "char" (return (&/$HostT "java.lang.Character" &/$Nil)) + "void" (return &/$UnitT) + ;; else + (|do [=params (&/map% (partial generic-class->type env) params)] + (return (&/$HostT name =params)))) + + (&/$GenericArray param) + (|do [=param (generic-class->type env param)] + (return (&/$HostT &host-type/array-data-tag (&/|list =param)))) + + (&/$GenericWildcard _) + (return (&/$ExQ &/$Nil (&/$BoundT 1))) + )) + +(defn gen-super-env [class-env supers class-decl] + "(-> (List (, TypeVar Type)) (List SuperClassDecl) ClassDecl (Lux (List (, Text Type))))" + (|let [[class-name class-vars] class-decl] + (|case (&/|some (fn [super] + (|let [[super-name super-params] super] + (if (= class-name super-name) + (&/$Some (&/zip2 (&/|map &/|first class-vars) super-params)) + &/$None))) + supers) + (&/$None) + (&/fail-with-loc (str "[Analyser Error] Unrecognized super-class: " class-name)) + + (&/$Some vars+gtypes) + (&/map% (fn [var+gtype] + (|do [:let [[var gtype] var+gtype] + =gtype (generic-class->type class-env gtype)] + (return (&/T [var =gtype])))) + vars+gtypes) + ))) + +(defn ^:private make-type-env [type-params] + "(-> (List TypeParam) (Lux (List [Text Type])))" + (&/map% (fn [gvar] + (|do [:let [[gvar-name _] gvar] + ex &type/existential] + (return (&/T [gvar-name ex])))) + type-params)) + +(defn ^:private double-register-gclass? [gclass] + (|case gclass + (&/$GenericClass name _) + (|case name + "long" true + "double" true + _ false) + + _ + false)) + +(defn ^:private method-input-folder [full-env] + (fn [body* input*] + (|do [:let [[iname itype*] input*] + itype (generic-class->type full-env itype*)] + (if (double-register-gclass? itype*) + (&&env/with-local iname itype + (&&env/with-local "" &/$VoidT + body*)) + (&&env/with-local iname itype + body*))))) + +(defn ^:private analyse-method [analyse class-decl class-env all-supers method] + "(-> Analyser ClassDecl (List (, TypeVar Type)) (List SuperClassDecl) MethodSyntax (Lux MethodAnalysis))" + (|let [[?cname ?cparams] class-decl + class-type (&/$HostT ?cname (&/|map &/|second class-env))] + (|case method + (&/$ConstructorMethodSyntax =privacy-modifier ?strict ?anns ?gvars ?exceptions ?inputs ?ctor-args ?body) + (|do [method-env (make-type-env ?gvars) + :let [full-env (&/|++ class-env method-env)] + :let [output-type &/$UnitT] + =ctor-args (&/map% (fn [ctor-arg] + (|do [:let [[ca-type ca-term] ctor-arg] + =ca-type (generic-class->type full-env ca-type) + =ca-term (&&/analyse-1 analyse =ca-type ca-term)] + (return (&/T [ca-type =ca-term])))) + ?ctor-args) + =body (&/with-type-env full-env + (&&env/with-local &&/jvm-this class-type + (&/with-no-catches + (with-catches (&/|map &host-generics/gclass->class-name ?exceptions) + (&/fold (method-input-folder full-env) + (&&/analyse-1 analyse output-type ?body) + (&/|reverse ?inputs))))))] + (return (&/$ConstructorMethodAnalysis (&/T [=privacy-modifier ?strict ?anns ?gvars ?exceptions ?inputs =ctor-args =body])))) + + (&/$VirtualMethodSyntax ?name =privacy-modifier =final? ?strict ?anns ?gvars ?exceptions ?inputs ?output ?body) + (|do [method-env (make-type-env ?gvars) + :let [full-env (&/|++ class-env method-env)] + output-type (generic-class->type full-env ?output) + =body (&/with-type-env full-env + (&&env/with-local &&/jvm-this class-type + (&/with-no-catches + (with-catches (&/|map &host-generics/gclass->class-name ?exceptions) + (&/fold (method-input-folder full-env) + (&&/analyse-1 analyse output-type ?body) + (&/|reverse ?inputs))))))] + (return (&/$VirtualMethodAnalysis (&/T [?name =privacy-modifier =final? ?strict ?anns ?gvars ?exceptions ?inputs ?output =body])))) + + (&/$OverridenMethodSyntax ?class-decl ?name ?strict ?anns ?gvars ?exceptions ?inputs ?output ?body) + (|do [super-env (gen-super-env class-env all-supers ?class-decl) + method-env (make-type-env ?gvars) + :let [full-env (&/|++ super-env method-env)] + output-type (generic-class->type full-env ?output) + =body (&/with-type-env full-env + (&&env/with-local &&/jvm-this class-type + (&/with-no-catches + (with-catches (&/|map &host-generics/gclass->class-name ?exceptions) + (&/fold (method-input-folder full-env) + (&&/analyse-1 analyse output-type ?body) + (&/|reverse ?inputs))))))] + (return (&/$OverridenMethodAnalysis (&/T [?class-decl ?name ?strict ?anns ?gvars ?exceptions ?inputs ?output =body])))) + + (&/$StaticMethodSyntax ?name =privacy-modifier ?strict ?anns ?gvars ?exceptions ?inputs ?output ?body) + (|do [method-env (make-type-env ?gvars) + :let [full-env method-env] + output-type (generic-class->type full-env ?output) + =body (&/with-type-env full-env + (&/with-no-catches + (with-catches (&/|map &host-generics/gclass->class-name ?exceptions) + (&/fold (method-input-folder full-env) + (&&/analyse-1 analyse output-type ?body) + (&/|reverse ?inputs)))))] + (return (&/$StaticMethodAnalysis (&/T [?name =privacy-modifier ?strict ?anns ?gvars ?exceptions ?inputs ?output =body])))) + + (&/$AbstractMethodSyntax ?name =privacy-modifier ?anns ?gvars ?exceptions ?inputs ?output) + (return (&/$AbstractMethodAnalysis (&/T [?name =privacy-modifier ?anns ?gvars ?exceptions ?inputs ?output]))) + + (&/$NativeMethodSyntax ?name =privacy-modifier ?anns ?gvars ?exceptions ?inputs ?output) + (return (&/$NativeMethodAnalysis (&/T [?name =privacy-modifier ?anns ?gvars ?exceptions ?inputs ?output]))) + ))) + +(defn ^:private mandatory-methods [supers] + (|do [class-loader &/loader] + (&/flat-map% (partial &host/abstract-methods class-loader) supers))) + +(defn ^:private check-method-completion [supers methods] + "(-> (List SuperClassDecl) (List (, MethodDecl Analysis)) (Lux Null))" + (|do [abstract-methods (mandatory-methods supers) + :let [methods-map (&/fold (fn [mmap mentry] + (|case mentry + (&/$ConstructorMethodAnalysis _) + mmap + + (&/$VirtualMethodAnalysis _) + mmap + + (&/$OverridenMethodAnalysis =class-decl =name ?strict =anns =gvars =exceptions =inputs =output body) + (update-in mmap [=name] (fn [old-inputs] (if old-inputs (conj old-inputs =inputs) [=inputs]))) + + (&/$StaticMethodAnalysis _) + mmap + + (&/$AbstractMethodSyntax _) + mmap + + (&/$NativeMethodSyntax _) + mmap + )) + {} + methods) + missing-method (&/fold (fn [missing abs-meth] + (or missing + (|let [[am-name am-inputs] abs-meth] + (if-let [meth-struct (get methods-map am-name)] + (if (some (fn [=inputs] + (and (= (&/|length =inputs) (&/|length am-inputs)) + (&/fold2 (fn [prev mi ai] + (|let [[iname itype] mi] + (and prev (= (generic-class->simple-class itype) ai)))) + true + =inputs am-inputs))) + meth-struct) + nil + abs-meth) + abs-meth)))) + nil + abstract-methods)]] + (if (nil? missing-method) + (return nil) + (|let [[am-name am-inputs] missing-method] + (&/fail-with-loc (str "[Analyser Error] Missing method: " am-name " " "(" (->> am-inputs (&/|interpose " ") (&/fold str "")) ")")))))) + +(defn ^:private analyse-field [analyse gtype-env field] + "(-> Analyser GTypeEnv FieldSyntax (Lux FieldAnalysis))" + (|case field + (&/$ConstantFieldSyntax ?name ?anns ?gclass ?value) + (|do [=gtype (&host-type/instance-gtype &type/existential gtype-env ?gclass) + =value (&&/analyse-1 analyse =gtype ?value)] + (return (&/$ConstantFieldAnalysis ?name ?anns ?gclass =value))) + + (&/$VariableFieldSyntax ?name ?privacy-modifier ?state-modifier ?anns ?type) + (return (&/$VariableFieldAnalysis ?name ?privacy-modifier ?state-modifier ?anns ?type)) + )) + +(do-template [<name> <proc> <from-class> <to-class>] + (let [output-type (&/$HostT <to-class> &/$Nil)] + (defn <name> [analyse exo-type _?value] + (|do [:let [(&/$Cons ?value (&/$Nil)) _?value] + =value (&&/analyse-1 analyse (&/$HostT <from-class> &/$Nil) ?value) + _ (&type/check exo-type output-type) + _cursor &/cursor] + (return (&/|list (&&/|meta output-type _cursor (&&/$proc (&/T ["jvm" <proc>]) (&/|list =value) (&/|list)))))))) + + ^:private analyse-jvm-d2f "d2f" "java.lang.Double" "java.lang.Float" + ^:private analyse-jvm-d2i "d2i" "java.lang.Double" "java.lang.Integer" + ^:private analyse-jvm-d2l "d2l" "java.lang.Double" "java.lang.Long" + + ^:private analyse-jvm-f2d "f2d" "java.lang.Float" "java.lang.Double" + ^:private analyse-jvm-f2i "f2i" "java.lang.Float" "java.lang.Integer" + ^:private analyse-jvm-f2l "f2l" "java.lang.Float" "java.lang.Long" + + ^:private analyse-jvm-i2b "i2b" "java.lang.Integer" "java.lang.Byte" + ^:private analyse-jvm-i2c "i2c" "java.lang.Integer" "java.lang.Character" + ^:private analyse-jvm-i2d "i2d" "java.lang.Integer" "java.lang.Double" + ^:private analyse-jvm-i2f "i2f" "java.lang.Integer" "java.lang.Float" + ^:private analyse-jvm-i2l "i2l" "java.lang.Integer" "java.lang.Long" + ^:private analyse-jvm-i2s "i2s" "java.lang.Integer" "java.lang.Short" + + ^:private analyse-jvm-l2d "l2d" "java.lang.Long" "java.lang.Double" + ^:private analyse-jvm-l2f "l2f" "java.lang.Long" "java.lang.Float" + ^:private analyse-jvm-l2i "l2i" "java.lang.Long" "java.lang.Integer" + ^:private analyse-jvm-l2s "l2i" "java.lang.Long" "java.lang.Short" + ^:private analyse-jvm-l2b "l2i" "java.lang.Long" "java.lang.Byte" + + ^:private analyse-jvm-c2b "c2b" "java.lang.Character" "java.lang.Byte" + ^:private analyse-jvm-c2s "c2s" "java.lang.Character" "java.lang.Short" + ^:private analyse-jvm-c2i "c2i" "java.lang.Character" "java.lang.Integer" + ^:private analyse-jvm-c2l "c2l" "java.lang.Character" "java.lang.Long" + + ^:private analyse-jvm-s2l "s2l" "java.lang.Short" "java.lang.Long" + + ^:private analyse-jvm-b2l "b2l" "java.lang.Byte" "java.lang.Long" + ) + +(do-template [<name> <proc> <v1-class> <v2-class> <to-class>] + (let [output-type (&/$HostT <to-class> &/$Nil)] + (defn <name> [analyse exo-type ?values] + (|do [:let [(&/$Cons ?value1 (&/$Cons ?value2 (&/$Nil))) ?values] + =value1 (&&/analyse-1 analyse (&/$HostT <v1-class> &/$Nil) ?value1) + =value2 (&&/analyse-1 analyse (&/$HostT <v2-class> &/$Nil) ?value2) + _ (&type/check exo-type output-type) + _cursor &/cursor] + (return (&/|list (&&/|meta output-type _cursor (&&/$proc (&/T ["jvm" <proc>]) (&/|list =value1 =value2) (&/|list)))))))) + + ^:private analyse-jvm-iand "iand" "java.lang.Integer" "java.lang.Integer" "java.lang.Integer" + ^:private analyse-jvm-ior "ior" "java.lang.Integer" "java.lang.Integer" "java.lang.Integer" + ^:private analyse-jvm-ixor "ixor" "java.lang.Integer" "java.lang.Integer" "java.lang.Integer" + ^:private analyse-jvm-ishl "ishl" "java.lang.Integer" "java.lang.Integer" "java.lang.Integer" + ^:private analyse-jvm-ishr "ishr" "java.lang.Integer" "java.lang.Integer" "java.lang.Integer" + ^:private analyse-jvm-iushr "iushr" "java.lang.Integer" "java.lang.Integer" "java.lang.Integer" + + ^:private analyse-jvm-land "land" "java.lang.Long" "java.lang.Long" "java.lang.Long" + ^:private analyse-jvm-lor "lor" "java.lang.Long" "java.lang.Long" "java.lang.Long" + ^:private analyse-jvm-lxor "lxor" "java.lang.Long" "java.lang.Long" "java.lang.Long" + ^:private analyse-jvm-lshl "lshl" "java.lang.Long" "java.lang.Integer" "java.lang.Long" + ^:private analyse-jvm-lshr "lshr" "java.lang.Long" "java.lang.Integer" "java.lang.Long" + ^:private analyse-jvm-lushr "lushr" "java.lang.Long" "java.lang.Integer" "java.lang.Long" + ) + +(do-template [<name> <proc> <input-class> <output-class>] + (let [input-type (&/$HostT <input-class> &/$Nil) + output-type (&/$HostT <output-class> &/$Nil)] + (defn <name> [analyse exo-type ?values] + (|do [:let [(&/$Cons x (&/$Cons y (&/$Nil))) ?values] + =x (&&/analyse-1 analyse input-type x) + =y (&&/analyse-1 analyse input-type y) + _ (&type/check exo-type output-type) + _cursor &/cursor] + (return (&/|list (&&/|meta output-type _cursor + (&&/$proc (&/T ["jvm" <proc>]) (&/|list =x =y) (&/|list)))))))) + + ^:private analyse-jvm-iadd "iadd" "java.lang.Integer" "java.lang.Integer" + ^:private analyse-jvm-isub "isub" "java.lang.Integer" "java.lang.Integer" + ^:private analyse-jvm-imul "imul" "java.lang.Integer" "java.lang.Integer" + ^:private analyse-jvm-idiv "idiv" "java.lang.Integer" "java.lang.Integer" + ^:private analyse-jvm-irem "irem" "java.lang.Integer" "java.lang.Integer" + ^:private analyse-jvm-ieq "ieq" "java.lang.Integer" "java.lang.Boolean" + ^:private analyse-jvm-ilt "ilt" "java.lang.Integer" "java.lang.Boolean" + ^:private analyse-jvm-igt "igt" "java.lang.Integer" "java.lang.Boolean" + + ^:private analyse-jvm-ceq "ceq" "java.lang.Character" "java.lang.Boolean" + ^:private analyse-jvm-clt "clt" "java.lang.Character" "java.lang.Boolean" + ^:private analyse-jvm-cgt "cgt" "java.lang.Character" "java.lang.Boolean" + + ^:private analyse-jvm-ladd "ladd" "java.lang.Long" "java.lang.Long" + ^:private analyse-jvm-lsub "lsub" "java.lang.Long" "java.lang.Long" + ^:private analyse-jvm-lmul "lmul" "java.lang.Long" "java.lang.Long" + ^:private analyse-jvm-ldiv "ldiv" "java.lang.Long" "java.lang.Long" + ^:private analyse-jvm-lrem "lrem" "java.lang.Long" "java.lang.Long" + ^:private analyse-jvm-leq "leq" "java.lang.Long" "java.lang.Boolean" + ^:private analyse-jvm-llt "llt" "java.lang.Long" "java.lang.Boolean" + ^:private analyse-jvm-lgt "lgt" "java.lang.Long" "java.lang.Boolean" + + ^:private analyse-jvm-fadd "fadd" "java.lang.Float" "java.lang.Float" + ^:private analyse-jvm-fsub "fsub" "java.lang.Float" "java.lang.Float" + ^:private analyse-jvm-fmul "fmul" "java.lang.Float" "java.lang.Float" + ^:private analyse-jvm-fdiv "fdiv" "java.lang.Float" "java.lang.Float" + ^:private analyse-jvm-frem "frem" "java.lang.Float" "java.lang.Float" + ^:private analyse-jvm-feq "feq" "java.lang.Float" "java.lang.Boolean" + ^:private analyse-jvm-flt "flt" "java.lang.Float" "java.lang.Boolean" + ^:private analyse-jvm-fgt "fgt" "java.lang.Float" "java.lang.Boolean" + + ^:private analyse-jvm-dadd "dadd" "java.lang.Double" "java.lang.Double" + ^:private analyse-jvm-dsub "dsub" "java.lang.Double" "java.lang.Double" + ^:private analyse-jvm-dmul "dmul" "java.lang.Double" "java.lang.Double" + ^:private analyse-jvm-ddiv "ddiv" "java.lang.Double" "java.lang.Double" + ^:private analyse-jvm-drem "drem" "java.lang.Double" "java.lang.Double" + ^:private analyse-jvm-deq "deq" "java.lang.Double" "java.lang.Boolean" + ^:private analyse-jvm-dlt "dlt" "java.lang.Double" "java.lang.Boolean" + ^:private analyse-jvm-dgt "dgt" "java.lang.Double" "java.lang.Boolean" + ) + +(let [length-type &type/Nat + idx-type &type/Nat] + (do-template [<elem-class> <array-class> <new-name> <new-tag> <load-name> <load-tag> <store-name> <store-tag>] + (let [elem-type (&/$HostT <elem-class> &/$Nil) + array-type (&/$HostT <array-class> &/$Nil)] + (defn <new-name> [analyse exo-type ?values] + (|do [:let [(&/$Cons length (&/$Nil)) ?values] + =length (&&/analyse-1 analyse length-type length) + _ (&type/check exo-type array-type) + _cursor &/cursor] + (return (&/|list (&&/|meta exo-type _cursor + (&&/$proc (&/T ["jvm" <new-tag>]) (&/|list =length) (&/|list))))))) + + (defn <load-name> [analyse exo-type ?values] + (|do [:let [(&/$Cons array (&/$Cons idx (&/$Nil))) ?values] + =array (&&/analyse-1 analyse array-type array) + =idx (&&/analyse-1 analyse idx-type idx) + _ (&type/check exo-type elem-type) + _cursor &/cursor] + (return (&/|list (&&/|meta exo-type _cursor + (&&/$proc (&/T ["jvm" <load-tag>]) (&/|list =array =idx) (&/|list))))))) + + (defn <store-name> [analyse exo-type ?values] + (|do [:let [(&/$Cons array (&/$Cons idx (&/$Cons elem (&/$Nil)))) ?values] + =array (&&/analyse-1 analyse array-type array) + =idx (&&/analyse-1 analyse idx-type idx) + =elem (&&/analyse-1 analyse elem-type elem) + _ (&type/check exo-type array-type) + _cursor &/cursor] + (return (&/|list (&&/|meta exo-type _cursor + (&&/$proc (&/T ["jvm" <store-tag>]) (&/|list =array =idx =elem) (&/|list))))))) + ) + + "java.lang.Boolean" "[Z" ^:private analyse-jvm-znewarray "znewarray" analyse-jvm-zaload "zaload" analyse-jvm-zastore "zastore" + "java.lang.Byte" "[B" ^:private analyse-jvm-bnewarray "bnewarray" analyse-jvm-baload "baload" analyse-jvm-bastore "bastore" + "java.lang.Short" "[S" ^:private analyse-jvm-snewarray "snewarray" analyse-jvm-saload "saload" analyse-jvm-sastore "sastore" + "java.lang.Integer" "[I" ^:private analyse-jvm-inewarray "inewarray" analyse-jvm-iaload "iaload" analyse-jvm-iastore "iastore" + "java.lang.Long" "[J" ^:private analyse-jvm-lnewarray "lnewarray" analyse-jvm-laload "laload" analyse-jvm-lastore "lastore" + "java.lang.Float" "[F" ^:private analyse-jvm-fnewarray "fnewarray" analyse-jvm-faload "faload" analyse-jvm-fastore "fastore" + "java.lang.Double" "[D" ^:private analyse-jvm-dnewarray "dnewarray" analyse-jvm-daload "daload" analyse-jvm-dastore "dastore" + "java.lang.Character" "[C" ^:private analyse-jvm-cnewarray "cnewarray" analyse-jvm-caload "caload" analyse-jvm-castore "castore" + )) + +(defn ^:private array-class? [class-name] + (or (= &host-type/array-data-tag class-name) + (case class-name + ("[Z" "[B" "[S" "[I" "[J" "[F" "[D" "[C") true + ;; else + false))) + +(let [length-type &type/Nat + idx-type &type/Nat] + (defn ^:private analyse-jvm-anewarray [analyse exo-type ?values] + (|do [:let [(&/$Cons [_ (&/$TextS _gclass)] (&/$Cons length (&/$Nil))) ?values] + gclass (&reader/with-source "jvm-anewarray" _gclass + &&a-parser/parse-gclass) + gtype-env &/get-type-env + =gclass (&host-type/instance-gtype &type/existential gtype-env gclass) + :let [array-type (&/$HostT &host-type/array-data-tag (&/|list =gclass))] + =length (&&/analyse-1 analyse length-type length) + _ (&type/check exo-type array-type) + _cursor &/cursor] + (return (&/|list (&&/|meta exo-type _cursor + (&&/$proc (&/T ["jvm" "anewarray"]) (&/|list =length) (&/|list gclass gtype-env))))))) + + (defn ^:private analyse-jvm-aaload [analyse exo-type ?values] + (|do [:let [(&/$Cons array (&/$Cons idx (&/$Nil))) ?values] + =array (&&/analyse-1+ analyse array) + [arr-class arr-params] (ensure-object (&&/expr-type* =array)) + _ (&/assert! (= &host-type/array-data-tag arr-class) (str "[Analyser Error] Expected array. Instead got: " arr-class)) + :let [(&/$Cons inner-arr-type (&/$Nil)) arr-params] + =idx (&&/analyse-1 analyse idx-type idx) + _ (&type/check exo-type inner-arr-type) + _cursor &/cursor] + (return (&/|list (&&/|meta exo-type _cursor + (&&/$proc (&/T ["jvm" "aaload"]) (&/|list =array =idx) (&/|list))))))) + + (defn ^:private analyse-jvm-aastore [analyse exo-type ?values] + (|do [:let [(&/$Cons array (&/$Cons idx (&/$Cons elem (&/$Nil)))) ?values] + =array (&&/analyse-1+ analyse array) + :let [array-type (&&/expr-type* =array)] + [arr-class arr-params] (ensure-object array-type) + _ (&/assert! (= &host-type/array-data-tag arr-class) (str "[Analyser Error] Expected array. Instead got: " arr-class)) + :let [(&/$Cons inner-arr-type (&/$Nil)) arr-params] + =idx (&&/analyse-1 analyse idx-type idx) + =elem (&&/analyse-1 analyse inner-arr-type elem) + _ (&type/check exo-type array-type) + _cursor &/cursor] + (return (&/|list (&&/|meta exo-type _cursor + (&&/$proc (&/T ["jvm" "aastore"]) (&/|list =array =idx =elem) (&/|list)))))))) + +(defn ^:private analyse-jvm-arraylength [analyse exo-type ?values] + (|do [:let [(&/$Cons array (&/$Nil)) ?values] + =array (&&/analyse-1+ analyse array) + [arr-class arr-params] (ensure-object (&&/expr-type* =array)) + _ (&/assert! (array-class? arr-class) (str "[Analyser Error] Expected array. Instead got: " arr-class)) + _ (&type/check exo-type &type/Nat) + _cursor &/cursor] + (return (&/|list (&&/|meta exo-type _cursor + (&&/$proc (&/T ["jvm" "arraylength"]) (&/|list =array) (&/|list)) + ))))) + +(defn ^:private analyse-jvm-null? [analyse exo-type ?values] + (|do [:let [(&/$Cons object (&/$Nil)) ?values] + =object (&&/analyse-1+ analyse object) + _ (ensure-object (&&/expr-type* =object)) + :let [output-type &type/Bool] + _ (&type/check exo-type output-type) + _cursor &/cursor] + (return (&/|list (&&/|meta exo-type _cursor + (&&/$proc (&/T ["jvm" "null?"]) (&/|list =object) (&/|list))))))) + +(defn ^:private analyse-jvm-null [analyse exo-type ?values] + (|do [:let [(&/$Nil) ?values] + :let [output-type (&/$HostT &host-type/null-data-tag &/$Nil)] + _ (&type/check exo-type output-type) + _cursor &/cursor] + (return (&/|list (&&/|meta exo-type _cursor + (&&/$proc (&/T ["jvm" "null"]) (&/|list) (&/|list))))))) + +(defn analyse-jvm-synchronized [analyse exo-type ?values] + (|do [:let [(&/$Cons ?monitor (&/$Cons ?expr (&/$Nil))) ?values] + =monitor (&&/analyse-1+ analyse ?monitor) + _ (ensure-object (&&/expr-type* =monitor)) + =expr (&&/analyse-1 analyse exo-type ?expr) + _cursor &/cursor] + (return (&/|list (&&/|meta exo-type _cursor + (&&/$proc (&/T ["jvm" "synchronized"]) (&/|list =monitor =expr) (&/|list))))))) + +(do-template [<name> <tag>] + (defn <name> [analyse exo-type ?values] + (|do [:let [(&/$Cons ?monitor (&/$Nil)) ?values] + =monitor (&&/analyse-1+ analyse ?monitor) + _ (ensure-object (&&/expr-type* =monitor)) + :let [output-type &/$UnitT] + _ (&type/check exo-type output-type) + _cursor &/cursor] + (return (&/|list (&&/|meta exo-type _cursor + (&&/$proc (&/T ["jvm" <tag>]) (&/|list =monitor) (&/|list))))))) + + ^:private analyse-jvm-monitorenter "monitorenter" + ^:private analyse-jvm-monitorexit "monitorexit" + ) + +(defn ^:private analyse-jvm-throw [analyse exo-type ?values] + (|do [:let [(&/$Cons ?ex (&/$Nil)) ?values] + =ex (&&/analyse-1+ analyse ?ex) + _ (&type/check (&/$HostT "java.lang.Throwable" &/$Nil) (&&/expr-type* =ex)) + [throw-class throw-params] (ensure-object (&&/expr-type* =ex)) + _ (ensure-catching (&/|list throw-class)) + _cursor &/cursor + _ (&type/check exo-type &type/Bottom)] + (return (&/|list (&&/|meta exo-type _cursor + (&&/$proc (&/T ["jvm" "throw"]) (&/|list =ex) (&/|list))))))) + +(defn ^:private analyse-jvm-getstatic [analyse exo-type class field ?values] + (|do [!class! (&/de-alias-class class) + :let [(&/$Nil) ?values] + class-loader &/loader + [gvars gtype] (&host/lookup-static-field class-loader !class! field) + =type (&host-type/instance-param &type/existential &/$Nil gtype) + :let [output-type =type] + _ (&type/check exo-type output-type) + _cursor &/cursor] + (return (&/|list (&&/|meta exo-type _cursor + (&&/$proc (&/T ["jvm" "getstatic"]) (&/|list) (&/|list class field output-type))))))) + +(defn ^:private analyse-jvm-getfield [analyse exo-type class field ?values] + (|do [!class! (&/de-alias-class class) + :let [(&/$Cons object (&/$Nil)) ?values] + class-loader &/loader + =object (&&/analyse-1+ analyse object) + _ (ensure-object (&&/expr-type* =object)) + [gvars gtype] (&host/lookup-field class-loader !class! field) + =type (analyse-field-access-helper (&&/expr-type* =object) gvars gtype) + :let [output-type =type] + _ (&type/check exo-type output-type) + _cursor &/cursor] + (return (&/|list (&&/|meta exo-type _cursor + (&&/$proc (&/T ["jvm" "getfield"]) (&/|list =object) (&/|list class field output-type))))))) + +(defn ^:private analyse-jvm-putstatic [analyse exo-type class field ?values] + (|do [!class! (&/de-alias-class class) + :let [(&/$Cons value (&/$Nil)) ?values] + class-loader &/loader + [gvars gtype] (&host/lookup-static-field class-loader !class! field) + :let [gclass (&host-type/gtype->gclass gtype)] + =type (&host-type/instance-param &type/existential &/$Nil gtype) + =value (&&/analyse-1 analyse =type value) + :let [output-type &/$UnitT] + _ (&type/check exo-type output-type) + _cursor &/cursor] + (return (&/|list (&&/|meta exo-type _cursor + (&&/$proc (&/T ["jvm" "putstatic"]) (&/|list =value) (&/|list class field gclass))))))) + +(defn ^:private analyse-jvm-putfield [analyse exo-type class field ?values] + (|do [!class! (&/de-alias-class class) + :let [(&/$Cons object (&/$Cons value (&/$Nil))) ?values] + class-loader &/loader + =object (&&/analyse-1+ analyse object) + :let [obj-type (&&/expr-type* =object)] + _ (ensure-object obj-type) + [gvars gtype] (&host/lookup-field class-loader !class! field) + :let [gclass (&host-type/gtype->gclass gtype)] + =type (analyse-field-access-helper obj-type gvars gtype) + =value (&&/analyse-1 analyse =type value) + :let [output-type &/$UnitT] + _ (&type/check exo-type output-type) + _cursor &/cursor] + (return (&/|list (&&/|meta exo-type _cursor + (&&/$proc (&/T ["jvm" "putfield"]) (&/|list =object =value) (&/|list class field gclass =type))))))) + +(defn ^:private analyse-method-call-helper [analyse exo-type gret gtype-env gtype-vars gtype-args args] + (|case gtype-vars + (&/$Nil) + (|do [arg-types (&/map% (partial &host-type/instance-param &type/existential gtype-env) gtype-args) + =arg-types (&/map% &type/show-type+ arg-types) + =args (&/map2% (partial &&/analyse-1 analyse) arg-types args) + =gret (&host-type/instance-param &type/existential gtype-env gret) + _ (&type/check exo-type (as-otype+ =gret))] + (return (&/T [=gret =args]))) + + (&/$Cons ^TypeVariable gtv gtype-vars*) + (&type/with-var + (fn [$var] + (|do [:let [(&/$VarT _id) $var + gtype-env* (&/$Cons (&/T [(.getName gtv) $var]) gtype-env)] + [=gret =args] (analyse-method-call-helper analyse exo-type gret gtype-env* gtype-vars* gtype-args args) + ==gret (&type/clean $var =gret) + ==args (&/map% (partial &&/clean-analysis $var) =args)] + (return (&/T [==gret ==args]))))) + )) + +(let [dummy-type-param (&/$HostT "java.lang.Object" &/$Nil)] + (do-template [<name> <tag> <only-interface?>] + (defn <name> [analyse exo-type class method classes ?values] + (|do [!class! (&/de-alias-class class) + :let [(&/$Cons object args) ?values] + class-loader &/loader + _ (try (assert! (let [=class (Class/forName !class! true class-loader)] + (= <only-interface?> (.isInterface =class))) + (if <only-interface?> + (str "[Analyser Error] Can only invoke method \"" method "\"" " on interface.") + (str "[Analyser Error] Can only invoke method \"" method "\"" " on class."))) + (catch Exception e + (&/fail-with-loc (str "[Analyser Error] Unknown class: " class)))) + [gret exceptions parent-gvars gvars gargs] (if (= "<init>" method) + (return (&/T [Void/TYPE &/$Nil &/$Nil &/$Nil &/$Nil])) + (&host/lookup-virtual-method class-loader !class! method classes)) + _ (ensure-catching exceptions) + =object (&&/analyse-1+ analyse object) + [sub-class sub-params] (ensure-object (&&/expr-type* =object)) + (&/$HostT super-class* super-params*) (&host-type/->super-type &type/existential class-loader !class! (if (= sub-class class) + !class! + sub-class) + sub-params) + :let [gtype-env (&/fold2 (fn [m ^TypeVariable g t] (&/$Cons (&/T [(.getName g) t]) m)) + (&/|table) + parent-gvars + super-params*)] + [output-type =args] (analyse-method-call-helper analyse exo-type gret gtype-env gvars gargs args) + _cursor &/cursor] + (return (&/|list (&&/|meta exo-type _cursor + (&&/$proc (&/T ["jvm" <tag>]) (&/$Cons =object =args) (&/|list class method classes output-type gret))))))) + + ^:private analyse-jvm-invokevirtual "invokevirtual" false + ^:private analyse-jvm-invokespecial "invokespecial" false + ^:private analyse-jvm-invokeinterface "invokeinterface" true + )) + +(defn ^:private analyse-jvm-invokestatic [analyse exo-type class method classes ?values] + (|do [!class! (&/de-alias-class class) + :let [args ?values] + class-loader &/loader + [gret exceptions parent-gvars gvars gargs] (&host/lookup-static-method class-loader !class! method classes) + _ (ensure-catching exceptions) + :let [gtype-env (&/|table)] + [output-type =args] (analyse-method-call-helper analyse exo-type gret gtype-env gvars gargs args) + _cursor &/cursor] + (return (&/|list (&&/|meta exo-type _cursor + (&&/$proc (&/T ["jvm" "invokestatic"]) =args (&/|list class method classes output-type gret))))))) + +(defn ^:private analyse-jvm-new-helper [analyse gtype gtype-env gtype-vars gtype-args args] + (|case gtype-vars + (&/$Nil) + (|do [arg-types (&/map% (partial &host-type/instance-param &type/existential gtype-env) gtype-args) + =args (&/map2% (partial &&/analyse-1 analyse) arg-types args) + gtype-vars* (->> gtype-env (&/|map &/|second) (clean-gtype-vars))] + (return (&/T [(make-gtype gtype gtype-vars*) + =args]))) + + (&/$Cons ^TypeVariable gtv gtype-vars*) + (&type/with-var + (fn [$var] + (|do [:let [gtype-env* (&/$Cons (&/T [(.getName gtv) $var]) gtype-env)] + [=gret =args] (analyse-jvm-new-helper analyse gtype gtype-env* gtype-vars* gtype-args args) + ==gret (&type/clean $var =gret) + ==args (&/map% (partial &&/clean-analysis $var) =args)] + (return (&/T [==gret ==args]))))) + )) + +(defn ^:private analyse-jvm-new [analyse exo-type class classes ?values] + (|do [!class! (&/de-alias-class class) + :let [args ?values] + class-loader &/loader + [exceptions gvars gargs] (&host/lookup-constructor class-loader !class! classes) + _ (ensure-catching exceptions) + [output-type =args] (analyse-jvm-new-helper analyse class (&/|table) gvars gargs args) + _ (&type/check exo-type output-type) + _cursor &/cursor] + (return (&/|list (&&/|meta exo-type _cursor + (&&/$proc (&/T ["jvm" "new"]) =args (&/|list class classes))))))) + +(defn ^:private analyse-jvm-try [analyse exo-type ?values] + (|do [:let [(&/$Cons ?body (&/$Cons ?catch (&/$Nil))) ?values] + =body (with-catches (&/|list "java.lang.Exception") + (&&/analyse-1 analyse exo-type ?body)) + =catch (&&/analyse-1 analyse (&/$LambdaT (&/$HostT "java.lang.Exception" &/$Nil) exo-type) ?catch) + _cursor &/cursor] + (return (&/|list (&&/|meta exo-type _cursor + (&&/$proc (&/T ["jvm" "try"]) (&/|list =body =catch) (&/|list))))))) + +(defn ^:private analyse-jvm-instanceof [analyse exo-type class ?values] + (|do [:let [(&/$Cons object (&/$Nil)) ?values] + =object (&&/analyse-1+ analyse object) + _ (ensure-object (&&/expr-type* =object)) + :let [output-type &type/Bool] + _ (&type/check exo-type output-type) + _cursor &/cursor] + (return (&/|list (&&/|meta output-type _cursor + (&&/$proc (&/T ["jvm" "instanceof"]) (&/|list =object) (&/|list class))))))) + +(defn ^:private analyse-jvm-load-class [analyse exo-type ?values] + (|do [:let [(&/$Cons [_ (&/$TextS _class-name)] (&/$Nil)) ?values] + ^ClassLoader class-loader &/loader + _ (try (do (.loadClass class-loader _class-name) + (return nil)) + (catch Exception e + (&/fail-with-loc (str "[Analyser Error] Unknown class: " _class-name)))) + :let [output-type (&/$HostT "java.lang.Class" (&/|list (&/$HostT _class-name (&/|list))))] + _ (&type/check exo-type output-type) + _cursor &/cursor] + (return (&/|list (&&/|meta output-type _cursor + (&&/$proc (&/T ["jvm" "load-class"]) (&/|list) (&/|list _class-name output-type))))))) + +(let [length-type &type/Nat + idx-type &type/Nat] + (defn ^:private analyse-array-new [analyse exo-type ?values] + (|do [:let [(&/$Cons length (&/$Nil)) ?values] + :let [gclass (&/$GenericClass "java.lang.Object" (&/|list)) + array-type (&/$UnivQ (&/|list) (&/$HostT &host-type/array-data-tag (&/|list (&/$BoundT 1))))] + gtype-env &/get-type-env + =length (&&/analyse-1 analyse length-type length) + _ (&type/check exo-type array-type) + _cursor &/cursor] + (return (&/|list (&&/|meta exo-type _cursor + (&&/$proc (&/T ["jvm" "anewarray"]) (&/|list =length) (&/|list gclass gtype-env))))))) + + (defn ^:private analyse-array-get [analyse exo-type ?values] + (|do [:let [(&/$Cons array (&/$Cons idx (&/$Nil))) ?values] + =array (&&/analyse-1+ analyse array) + [arr-class arr-params] (ensure-object (&&/expr-type* =array)) + _ (&/assert! (= &host-type/array-data-tag arr-class) (str "[Analyser Error] Expected array. Instead got: " arr-class)) + :let [(&/$Cons inner-arr-type (&/$Nil)) arr-params] + =idx (&&/analyse-1 analyse idx-type idx) + _ (&type/check exo-type (&/$AppT &type/Maybe inner-arr-type)) + _cursor &/cursor] + (return (&/|list (&&/|meta exo-type _cursor + (&&/$proc (&/T ["array" "get"]) (&/|list =array =idx) (&/|list))))))) + + (defn ^:private analyse-array-remove [analyse exo-type ?values] + (|do [:let [(&/$Cons array (&/$Cons idx (&/$Nil))) ?values] + =array (&&/analyse-1+ analyse array) + :let [array-type (&&/expr-type* =array)] + [arr-class arr-params] (ensure-object array-type) + _ (&/assert! (= &host-type/array-data-tag arr-class) (str "[Analyser Error] Expected array. Instead got: " arr-class)) + :let [(&/$Cons inner-arr-type (&/$Nil)) arr-params] + =idx (&&/analyse-1 analyse idx-type idx) + _cursor &/cursor + :let [=elem (&&/|meta inner-arr-type _cursor + (&&/$proc (&/T ["jvm" "null"]) (&/|list) (&/|list)))] + _ (&type/check exo-type array-type)] + (return (&/|list (&&/|meta exo-type _cursor + (&&/$proc (&/T ["jvm" "aastore"]) (&/|list =array =idx =elem) (&/|list)))))))) + +(defn ^:private analyse-jvm-interface [analyse compile-interface interface-decl supers =anns =methods] + (|do [module &/get-module-name + _ (compile-interface interface-decl supers =anns =methods) + :let [_ (println 'INTERFACE (str module "." (&/|first interface-decl)))] + _cursor &/cursor] + (return (&/|list (&&/|meta &/$UnitT _cursor + (&&/$tuple (&/|list))))))) + +(defn ^:private analyse-jvm-class [analyse compile-class class-decl super-class interfaces =inheritance-modifier =anns ?fields methods] + (&/with-closure + (|do [module &/get-module-name + :let [[?name ?params] class-decl + full-name (str (string/replace module "/" ".") "." ?name) + class-decl* (&/T [full-name ?params]) + all-supers (&/$Cons super-class interfaces)] + class-env (make-type-env ?params) + =fields (&/map% (partial analyse-field analyse class-env) ?fields) + _ (&host/use-dummy-class class-decl super-class interfaces &/$None =fields methods) + =methods (&/map% (partial analyse-method analyse class-decl* class-env all-supers) methods) + _ (check-method-completion all-supers =methods) + _ (compile-class class-decl super-class interfaces =inheritance-modifier =anns =fields =methods &/$Nil &/$None) + _ &/pop-dummy-name + :let [_ (println 'CLASS full-name)] + _cursor &/cursor] + (return (&/|list (&&/|meta &/$UnitT _cursor + (&&/$tuple (&/|list)))))))) + +(defn ^:private captured-source [env-entry] + (|case env-entry + [name [_ (&&/$captured _ _ source)]] + source)) + +(let [default-<init> (&/$ConstructorMethodSyntax (&/T [&/$PublicPM + false + &/$Nil + &/$Nil + &/$Nil + &/$Nil + &/$Nil + (&/$TupleS &/$Nil)])) + captured-slot-class "java.lang.Object" + captured-slot-type (&/$GenericClass captured-slot-class &/$Nil)] + (defn ^:private analyse-jvm-anon-class [analyse compile-class exo-type super-class interfaces ctor-args methods] + (&/with-closure + (|do [module &/get-module-name + scope &/get-scope-name + :let [name (->> scope &/|reverse &/|tail &host/location) + class-decl (&/T [name &/$Nil]) + anon-class (str (string/replace module "/" ".") "." name) + anon-class-type (&/$HostT anon-class &/$Nil)] + =ctor-args (&/map% (fn [ctor-arg] + (|let [[arg-type arg-term] ctor-arg] + (|do [=arg-term (&&/analyse-1+ analyse arg-term)] + (return (&/T [arg-type =arg-term]))))) + ctor-args) + _ (->> methods + (&/$Cons default-<init>) + (&host/use-dummy-class class-decl super-class interfaces (&/$Some =ctor-args) &/$Nil)) + :let [all-supers (&/$Cons super-class interfaces) + class-env &/$Nil] + =methods (&/map% (partial analyse-method analyse class-decl class-env all-supers) methods) + _ (check-method-completion all-supers =methods) + =captured &&env/captured-vars + :let [=fields (&/|map (fn [^objects idx+capt] + (|let [[idx _] idx+capt] + (&/$VariableFieldAnalysis (str &c!base/closure-prefix idx) + &/$PublicPM + &/$FinalSM + &/$Nil + captured-slot-type))) + (&/enumerate =captured))] + :let [sources (&/|map captured-source =captured)] + _ (compile-class class-decl super-class interfaces &/$DefaultIM &/$Nil =fields =methods =captured (&/$Some =ctor-args)) + _ &/pop-dummy-name + _cursor &/cursor] + (return (&/|list (&&/|meta anon-class-type _cursor + (&&/$proc (&/T ["jvm" "new"]) sources (&/|list anon-class (&/|repeat (&/|length sources) captured-slot-class))) + ))) + )))) + +(do-template [<name> <op>] + (defn <name> [analyse exo-type ?values] + (|do [:let [(&/$Cons input (&/$Cons mask (&/$Nil))) ?values] + =mask (&&/analyse-1 analyse &type/Nat mask) + =input (&&/analyse-1 analyse &type/Nat input) + _ (&type/check exo-type &type/Nat) + _cursor &/cursor] + (return (&/|list (&&/|meta exo-type _cursor + (&&/$proc (&/T ["bit" <op>]) (&/|list =input =mask) (&/|list))))))) + + ^:private analyse-bit-and "and" + ^:private analyse-bit-or "or" + ^:private analyse-bit-xor "xor" + ) + +(defn ^:private analyse-bit-count [analyse exo-type ?values] + (|do [:let [(&/$Cons input (&/$Nil)) ?values] + =input (&&/analyse-1 analyse &type/Nat input) + _ (&type/check exo-type &type/Nat) + _cursor &/cursor] + (return (&/|list (&&/|meta exo-type _cursor + (&&/$proc (&/T ["bit" "count"]) (&/|list =input) (&/|list))))))) + +(do-template [<name> <op> <type>] + (defn <name> [analyse exo-type ?values] + (|do [:let [(&/$Cons input (&/$Cons shift (&/$Nil))) ?values] + =shift (&&/analyse-1 analyse &type/Nat shift) + =input (&&/analyse-1 analyse <type> input) + _ (&type/check exo-type <type>) + _cursor &/cursor] + (return (&/|list (&&/|meta exo-type _cursor + (&&/$proc (&/T ["bit" <op>]) (&/|list =input =shift) (&/|list))))))) + + ^:private analyse-bit-shift-left "shift-left" &type/Nat + ^:private analyse-bit-shift-right "shift-right" &type/Int + ^:private analyse-bit-unsigned-shift-right "unsigned-shift-right" &type/Nat + ) + +(defn ^:private analyse-lux-== [analyse exo-type ?values] + (&type/with-var + (fn [$var] + (|do [:let [(&/$Cons left (&/$Cons right (&/$Nil))) ?values] + =left (&&/analyse-1 analyse $var left) + =right (&&/analyse-1 analyse $var right) + _ (&type/check exo-type &type/Bool) + _cursor &/cursor] + (return (&/|list (&&/|meta exo-type _cursor + (&&/$proc (&/T ["lux" "=="]) (&/|list =left =right) (&/|list))))))))) + +(do-template [<name> <proc> <input-type> <output-type>] + (defn <name> [analyse exo-type ?values] + (|do [:let [(&/$Cons x (&/$Cons y (&/$Nil))) ?values] + =x (&&/analyse-1 analyse <input-type> x) + =y (&&/analyse-1 analyse <input-type> y) + _ (&type/check exo-type <output-type>) + _cursor &/cursor] + (return (&/|list (&&/|meta <output-type> _cursor + (&&/$proc (&/T <proc>) (&/|list =x =y) (&/|list))))))) + + ^:private analyse-nat-add ["nat" "+"] &type/Nat &type/Nat + ^:private analyse-nat-sub ["nat" "-"] &type/Nat &type/Nat + ^:private analyse-nat-mul ["nat" "*"] &type/Nat &type/Nat + ^:private analyse-nat-div ["nat" "/"] &type/Nat &type/Nat + ^:private analyse-nat-rem ["nat" "%"] &type/Nat &type/Nat + ^:private analyse-nat-eq ["nat" "="] &type/Nat &type/Bool + ^:private analyse-nat-lt ["nat" "<"] &type/Nat &type/Bool + + ^:private analyse-frac-add ["frac" "+"] &type/Frac &type/Frac + ^:private analyse-frac-sub ["frac" "-"] &type/Frac &type/Frac + ^:private analyse-frac-mul ["frac" "*"] &type/Frac &type/Frac + ^:private analyse-frac-div ["frac" "/"] &type/Frac &type/Frac + ^:private analyse-frac-rem ["frac" "%"] &type/Frac &type/Frac + ^:private analyse-frac-eq ["frac" "="] &type/Frac &type/Bool + ^:private analyse-frac-lt ["frac" "<"] &type/Frac &type/Bool + ) + +(defn ^:private analyse-frac-scale [analyse exo-type ?values] + (|do [:let [(&/$Cons x (&/$Cons y (&/$Nil))) ?values] + =x (&&/analyse-1 analyse &type/Frac x) + =y (&&/analyse-1 analyse &type/Nat y) + _ (&type/check exo-type &type/Frac) + _cursor &/cursor] + (return (&/|list (&&/|meta &type/Frac _cursor + (&&/$proc (&/T ["frac" "scale"]) (&/|list =x =y) (&/|list))))))) + +(do-template [<encode> <encode-op> <decode> <decode-op> <type>] + (do (defn <encode> [analyse exo-type ?values] + (|do [:let [(&/$Cons x (&/$Nil)) ?values] + =x (&&/analyse-1 analyse <type> x) + _ (&type/check exo-type &type/Text) + _cursor &/cursor] + (return (&/|list (&&/|meta &type/Text _cursor + (&&/$proc (&/T <encode-op>) (&/|list =x) (&/|list))))))) + + (let [decode-type (&/$AppT &type/Maybe <type>)] + (defn <decode> [analyse exo-type ?values] + (|do [:let [(&/$Cons x (&/$Nil)) ?values] + =x (&&/analyse-1 analyse &type/Text x) + _ (&type/check exo-type decode-type) + _cursor &/cursor] + (return (&/|list (&&/|meta decode-type _cursor + (&&/$proc (&/T <decode-op>) (&/|list =x) (&/|list))))))))) + + ^:private analyse-nat-encode ["nat" "encode"] ^:private analyse-nat-decode ["nat" "decode"] &type/Nat + ^:private analyse-frac-encode ["frac" "encode"] ^:private analyse-frac-decode ["frac" "decode"] &type/Frac + ) + +(do-template [<name> <type> <op>] + (defn <name> [analyse exo-type ?values] + (|do [:let [(&/$Nil) ?values] + _ (&type/check exo-type <type>) + _cursor &/cursor] + (return (&/|list (&&/|meta <type> _cursor + (&&/$proc (&/T <op>) (&/|list) (&/|list))))))) + + ^:private analyse-nat-min-value &type/Nat ["nat" "min-value"] + ^:private analyse-nat-max-value &type/Nat ["nat" "max-value"] + + ^:private analyse-frac-min-value &type/Frac ["frac" "min-value"] + ^:private analyse-frac-max-value &type/Frac ["frac" "max-value"] + ) + +(do-template [<name> <from-type> <to-type> <op>] + (defn <name> [analyse exo-type ?values] + (|do [:let [(&/$Cons x (&/$Nil)) ?values] + =x (&&/analyse-1 analyse <from-type> x) + _ (&type/check exo-type <to-type>) + _cursor &/cursor] + (return (&/|list (&&/|meta <to-type> _cursor + (&&/$proc (&/T <op>) (&/|list =x) (&/|list))))))) + + ^:private analyse-nat-to-int &type/Nat &type/Int ["nat" "to-int"] + ^:private analyse-nat-to-char &type/Nat &type/Char ["nat" "to-char"] + ^:private analyse-int-to-nat &type/Int &type/Nat ["int" "to-nat"] + ^:private analyse-char-to-nat &type/Char &type/Nat ["char" "to-nat"] + + ^:private analyse-frac-to-real &type/Frac &type/Real ["frac" "to-real"] + ^:private analyse-real-to-frac &type/Real &type/Frac ["real" "to-frac"] + ) + +(defn analyse-host [analyse exo-type compilers category proc ?values] + (|let [[_ _ compile-class compile-interface] compilers] + (case category + "lux" + (case proc + "==" (analyse-lux-== analyse exo-type ?values)) + + "bit" + (case proc + "count" (analyse-bit-count analyse exo-type ?values) + "and" (analyse-bit-and analyse exo-type ?values) + "or" (analyse-bit-or analyse exo-type ?values) + "xor" (analyse-bit-xor analyse exo-type ?values) + "shift-left" (analyse-bit-shift-left analyse exo-type ?values) + "shift-right" (analyse-bit-shift-right analyse exo-type ?values) + "unsigned-shift-right" (analyse-bit-unsigned-shift-right analyse exo-type ?values)) + + "array" + (case proc + "new" (analyse-array-new analyse exo-type ?values) + "get" (analyse-array-get analyse exo-type ?values) + "put" (analyse-jvm-aastore analyse exo-type ?values) + "remove" (analyse-array-remove analyse exo-type ?values) + "size" (analyse-jvm-arraylength analyse exo-type ?values)) + + "nat" + (case proc + "+" (analyse-nat-add analyse exo-type ?values) + "-" (analyse-nat-sub analyse exo-type ?values) + "*" (analyse-nat-mul analyse exo-type ?values) + "/" (analyse-nat-div analyse exo-type ?values) + "%" (analyse-nat-rem analyse exo-type ?values) + "=" (analyse-nat-eq analyse exo-type ?values) + "<" (analyse-nat-lt analyse exo-type ?values) + "encode" (analyse-nat-encode analyse exo-type ?values) + "decode" (analyse-nat-decode analyse exo-type ?values) + "min-value" (analyse-nat-min-value analyse exo-type ?values) + "max-value" (analyse-nat-max-value analyse exo-type ?values) + "to-int" (analyse-nat-to-int analyse exo-type ?values) + "to-char" (analyse-nat-to-char analyse exo-type ?values) + ) + + "frac" + (case proc + "+" (analyse-frac-add analyse exo-type ?values) + "-" (analyse-frac-sub analyse exo-type ?values) + "*" (analyse-frac-mul analyse exo-type ?values) + "/" (analyse-frac-div analyse exo-type ?values) + "%" (analyse-frac-rem analyse exo-type ?values) + "=" (analyse-frac-eq analyse exo-type ?values) + "<" (analyse-frac-lt analyse exo-type ?values) + "encode" (analyse-frac-encode analyse exo-type ?values) + "decode" (analyse-frac-decode analyse exo-type ?values) + "min-value" (analyse-frac-min-value analyse exo-type ?values) + "max-value" (analyse-frac-max-value analyse exo-type ?values) + "to-real" (analyse-frac-to-real analyse exo-type ?values) + "scale" (analyse-frac-scale analyse exo-type ?values) + ) + + "int" + (case proc + "to-nat" (analyse-int-to-nat analyse exo-type ?values) + ) + + "real" + (case proc + "to-frac" (analyse-real-to-frac analyse exo-type ?values) + ) + + "char" + (case proc + "to-nat" (analyse-char-to-nat analyse exo-type ?values) + ) + + "jvm" + (case proc + "synchronized" (analyse-jvm-synchronized analyse exo-type ?values) + "load-class" (analyse-jvm-load-class analyse exo-type ?values) + "try" (analyse-jvm-try analyse exo-type ?values) + "throw" (analyse-jvm-throw analyse exo-type ?values) + "monitorenter" (analyse-jvm-monitorenter analyse exo-type ?values) + "monitorexit" (analyse-jvm-monitorexit analyse exo-type ?values) + "null?" (analyse-jvm-null? analyse exo-type ?values) + "null" (analyse-jvm-null analyse exo-type ?values) + "anewarray" (analyse-jvm-anewarray analyse exo-type ?values) + "aaload" (analyse-jvm-aaload analyse exo-type ?values) + "aastore" (analyse-jvm-aastore analyse exo-type ?values) + "arraylength" (analyse-jvm-arraylength analyse exo-type ?values) + "znewarray" (analyse-jvm-znewarray analyse exo-type ?values) + "bnewarray" (analyse-jvm-bnewarray analyse exo-type ?values) + "snewarray" (analyse-jvm-snewarray analyse exo-type ?values) + "inewarray" (analyse-jvm-inewarray analyse exo-type ?values) + "lnewarray" (analyse-jvm-lnewarray analyse exo-type ?values) + "fnewarray" (analyse-jvm-fnewarray analyse exo-type ?values) + "dnewarray" (analyse-jvm-dnewarray analyse exo-type ?values) + "cnewarray" (analyse-jvm-cnewarray analyse exo-type ?values) + "iadd" (analyse-jvm-iadd analyse exo-type ?values) + "isub" (analyse-jvm-isub analyse exo-type ?values) + "imul" (analyse-jvm-imul analyse exo-type ?values) + "idiv" (analyse-jvm-idiv analyse exo-type ?values) + "irem" (analyse-jvm-irem analyse exo-type ?values) + "ieq" (analyse-jvm-ieq analyse exo-type ?values) + "ilt" (analyse-jvm-ilt analyse exo-type ?values) + "igt" (analyse-jvm-igt analyse exo-type ?values) + "ceq" (analyse-jvm-ceq analyse exo-type ?values) + "clt" (analyse-jvm-clt analyse exo-type ?values) + "cgt" (analyse-jvm-cgt analyse exo-type ?values) + "ladd" (analyse-jvm-ladd analyse exo-type ?values) + "lsub" (analyse-jvm-lsub analyse exo-type ?values) + "lmul" (analyse-jvm-lmul analyse exo-type ?values) + "ldiv" (analyse-jvm-ldiv analyse exo-type ?values) + "lrem" (analyse-jvm-lrem analyse exo-type ?values) + "leq" (analyse-jvm-leq analyse exo-type ?values) + "llt" (analyse-jvm-llt analyse exo-type ?values) + "lgt" (analyse-jvm-lgt analyse exo-type ?values) + "fadd" (analyse-jvm-fadd analyse exo-type ?values) + "fsub" (analyse-jvm-fsub analyse exo-type ?values) + "fmul" (analyse-jvm-fmul analyse exo-type ?values) + "fdiv" (analyse-jvm-fdiv analyse exo-type ?values) + "frem" (analyse-jvm-frem analyse exo-type ?values) + "feq" (analyse-jvm-feq analyse exo-type ?values) + "flt" (analyse-jvm-flt analyse exo-type ?values) + "fgt" (analyse-jvm-fgt analyse exo-type ?values) + "dadd" (analyse-jvm-dadd analyse exo-type ?values) + "dsub" (analyse-jvm-dsub analyse exo-type ?values) + "dmul" (analyse-jvm-dmul analyse exo-type ?values) + "ddiv" (analyse-jvm-ddiv analyse exo-type ?values) + "drem" (analyse-jvm-drem analyse exo-type ?values) + "deq" (analyse-jvm-deq analyse exo-type ?values) + "dlt" (analyse-jvm-dlt analyse exo-type ?values) + "dgt" (analyse-jvm-dgt analyse exo-type ?values) + "iand" (analyse-jvm-iand analyse exo-type ?values) + "ior" (analyse-jvm-ior analyse exo-type ?values) + "ixor" (analyse-jvm-ixor analyse exo-type ?values) + "ishl" (analyse-jvm-ishl analyse exo-type ?values) + "ishr" (analyse-jvm-ishr analyse exo-type ?values) + "iushr" (analyse-jvm-iushr analyse exo-type ?values) + "land" (analyse-jvm-land analyse exo-type ?values) + "lor" (analyse-jvm-lor analyse exo-type ?values) + "lxor" (analyse-jvm-lxor analyse exo-type ?values) + "lshl" (analyse-jvm-lshl analyse exo-type ?values) + "lshr" (analyse-jvm-lshr analyse exo-type ?values) + "lushr" (analyse-jvm-lushr analyse exo-type ?values) + "d2f" (analyse-jvm-d2f analyse exo-type ?values) + "d2i" (analyse-jvm-d2i analyse exo-type ?values) + "d2l" (analyse-jvm-d2l analyse exo-type ?values) + "f2d" (analyse-jvm-f2d analyse exo-type ?values) + "f2i" (analyse-jvm-f2i analyse exo-type ?values) + "f2l" (analyse-jvm-f2l analyse exo-type ?values) + "i2b" (analyse-jvm-i2b analyse exo-type ?values) + "i2c" (analyse-jvm-i2c analyse exo-type ?values) + "i2d" (analyse-jvm-i2d analyse exo-type ?values) + "i2f" (analyse-jvm-i2f analyse exo-type ?values) + "i2l" (analyse-jvm-i2l analyse exo-type ?values) + "i2s" (analyse-jvm-i2s analyse exo-type ?values) + "l2d" (analyse-jvm-l2d analyse exo-type ?values) + "l2f" (analyse-jvm-l2f analyse exo-type ?values) + "l2i" (analyse-jvm-l2i analyse exo-type ?values) + "l2s" (analyse-jvm-l2s analyse exo-type ?values) + "l2b" (analyse-jvm-l2b analyse exo-type ?values) + "c2b" (analyse-jvm-c2b analyse exo-type ?values) + "c2s" (analyse-jvm-c2s analyse exo-type ?values) + "c2i" (analyse-jvm-c2i analyse exo-type ?values) + "c2l" (analyse-jvm-c2l analyse exo-type ?values) + "b2l" (analyse-jvm-b2l analyse exo-type ?values) + "s2l" (analyse-jvm-s2l analyse exo-type ?values) + ;; else + (->> (&/fail-with-loc (str "[Analyser Error] Unknown host procedure: " [category proc])) + (if-let [[_ _def-code] (re-find #"^interface:(.*)$" proc)] + (&reader/with-source "interface" _def-code + (|do [[=gclass-decl =supers =anns =methods] &&a-parser/parse-interface-def] + (analyse-jvm-interface analyse compile-interface =gclass-decl =supers =anns =methods)))) + + (if-let [[_ _def-code] (re-find #"^class:(.*)$" proc)] + (&reader/with-source "class" _def-code + (|do [[=gclass-decl =super-class =interfaces =inheritance-modifier =anns =fields =methods] &&a-parser/parse-class-def] + (analyse-jvm-class analyse compile-class =gclass-decl =super-class =interfaces =inheritance-modifier =anns =fields =methods)))) + + (if-let [[_ _def-code] (re-find #"^anon-class:(.*)$" proc)] + (&reader/with-source "anon-class" _def-code + (|do [[=super-class =interfaces =ctor-args =methods] &&a-parser/parse-anon-class-def] + (analyse-jvm-anon-class analyse compile-class exo-type =super-class =interfaces =ctor-args =methods)))) + + (if-let [[_ _class] (re-find #"^instanceof:([^:]+)$" proc)] + (analyse-jvm-instanceof analyse exo-type _class ?values)) + + (if-let [[_ _class _arg-classes] (re-find #"^new:([^:]+):([^:]*)$" proc)] + (analyse-jvm-new analyse exo-type _class (if (= "" _arg-classes) (&/|list) (&/->list (string/split _arg-classes #","))) ?values)) + + (if-let [[_ _class _method _arg-classes] (re-find #"^invokestatic:([^:]+):([^:]+):([^:]*)$" proc)] + (analyse-jvm-invokestatic analyse exo-type _class _method (if (= "" _arg-classes) (&/|list) (&/->list (string/split _arg-classes #","))) ?values)) + + (if-let [[_ _class _method _arg-classes] (re-find #"^invokeinterface:([^:]+):([^:]+):([^:]*)$" proc)] + (analyse-jvm-invokeinterface analyse exo-type _class _method (if (= "" _arg-classes) (&/|list) (&/->list (string/split _arg-classes #","))) ?values)) + + (if-let [[_ _class _method _arg-classes] (re-find #"^invokevirtual:([^:]+):([^:]+):([^:]*)$" proc)] + (analyse-jvm-invokevirtual analyse exo-type _class _method (if (= "" _arg-classes) (&/|list) (&/->list (string/split _arg-classes #","))) ?values)) + + (if-let [[_ _class _method _arg-classes] (re-find #"^invokespecial:([^:]+):([^:]+):([^:]*)$" proc)] + (analyse-jvm-invokespecial analyse exo-type _class _method (if (= "" _arg-classes) (&/|list) (&/->list (string/split _arg-classes #","))) ?values)) + + (if-let [[_ _class _field] (re-find #"^getstatic:([^:]+):([^:]+)$" proc)] + (analyse-jvm-getstatic analyse exo-type _class _field ?values)) + + (if-let [[_ _class _field] (re-find #"^getfield:([^:]+):([^:]+)$" proc)] + (analyse-jvm-getfield analyse exo-type _class _field ?values)) + + (if-let [[_ _class _field] (re-find #"^putstatic:([^:]+):([^:]+)$" proc)] + (analyse-jvm-putstatic analyse exo-type _class _field ?values)) + + (if-let [[_ _class _field] (re-find #"^putfield:([^:]+):([^:]+)$" proc)] + (analyse-jvm-putfield analyse exo-type _class _field ?values)))) + + ;; else + (&/fail-with-loc (str "[Analyser Error] Unknown host procedure: " [category proc]))))) diff --git a/luxc/src/lux/analyser/lambda.clj b/luxc/src/lux/analyser/lambda.clj new file mode 100644 index 000000000..b47b803d0 --- /dev/null +++ b/luxc/src/lux/analyser/lambda.clj @@ -0,0 +1,33 @@ +;; Copyright (c) Eduardo Julian. All rights reserved. +;; This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +;; If a copy of the MPL was not distributed with this file, +;; You can obtain one at http://mozilla.org/MPL/2.0/. + +(ns lux.analyser.lambda + (:require clojure.core.match + clojure.core.match.array + (lux [base :as & :refer [|let |do return fail |case]] + [host :as &host]) + (lux.analyser [base :as &&] + [env :as &env]))) + +;; [Resource] +(defn with-lambda [self self-type arg arg-type body] + (&/with-closure + (|do [scope-name &/get-scope-name] + (&env/with-local self self-type + (&env/with-local arg arg-type + (|do [=return body + =captured &env/captured-vars] + (return (&/T [scope-name =captured =return])))))))) + +(defn close-over [scope name register frame] + (|let [[[register-type register-cursor] _] register + register* (&&/|meta register-type register-cursor + (&&/$captured (&/T [scope + (->> frame (&/get$ &/$closure) (&/get$ &/$counter)) + register])))] + (&/T [register* (&/update$ &/$closure #(->> % + (&/update$ &/$counter inc) + (&/update$ &/$mappings (fn [mps] (&/|put name register* mps)))) + frame)]))) diff --git a/luxc/src/lux/analyser/lux.clj b/luxc/src/lux/analyser/lux.clj new file mode 100644 index 000000000..1d46c2b60 --- /dev/null +++ b/luxc/src/lux/analyser/lux.clj @@ -0,0 +1,736 @@ +;; Copyright (c) Eduardo Julian. All rights reserved. +;; This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +;; If a copy of the MPL was not distributed with this file, +;; You can obtain one at http://mozilla.org/MPL/2.0/. + +(ns lux.analyser.lux + (:require (clojure [template :refer [do-template]] + [set :as set]) + clojure.core.match + clojure.core.match.array + (lux [base :as & :refer [|do return return* fail fail* |let |list |case]] + [parser :as &parser] + [type :as &type] + [host :as &host]) + (lux.analyser [base :as &&] + [lambda :as &&lambda] + [case :as &&case] + [env :as &&env] + [module :as &&module] + [record :as &&record] + [meta :as &&meta]))) + +;; [Utils] +;; TODO: Walk the type to set up the bound-type, instead of doing a +;; rough calculation like this one. +(defn ^:private count-univq [type] + "(-> Type Int)" + (|case type + (&/$UnivQ env type*) + (inc (count-univq type*)) + + _ + 0)) + +;; TODO: This technique won't work if the body of the type contains +;; nested quantifications that cannot be directly counted. +(defn ^:private next-bound-type [type] + "(-> Type Type)" + (&/$BoundT (->> (count-univq type) (* 2) (+ 1)))) + +(defn ^:private embed-inferred-input [input output] + "(-> Type Type Type)" + (|case output + (&/$UnivQ env output*) + (&/$UnivQ env (embed-inferred-input input output*)) + + _ + (&/$LambdaT input output))) + +;; [Exports] +(defn analyse-unit [analyse ?exo-type] + (|do [_cursor &/cursor + _ (&type/check ?exo-type &/$UnitT)] + (return (&/|list (&&/|meta ?exo-type _cursor + (&&/$tuple (&/|list))))))) + +(defn analyse-tuple [analyse ?exo-type ?elems] + (|case ?elems + (&/$Nil) + (analyse-unit analyse (|case ?exo-type + (&/$Left exo-type) exo-type + (&/$Right exo-type) exo-type)) + + (&/$Cons ?elem (&/$Nil)) + (analyse (|case ?exo-type + (&/$Left exo-type) exo-type + (&/$Right exo-type) exo-type) + ?elem) + + _ + (|case ?exo-type + (&/$Left exo-type) + (|do [exo-type* (&type/actual-type exo-type)] + (|case exo-type* + (&/$UnivQ _) + (&type/with-var + (fn [$var] + (|do [exo-type** (&type/apply-type exo-type* $var) + [[tuple-type tuple-cursor] tuple-analysis] (&&/cap-1 (analyse-tuple analyse (&/$Left exo-type**) ?elems)) + =var (&type/resolve-type $var) + inferred-type (|case =var + (&/$VarT iid) + (|do [:let [=var* (next-bound-type tuple-type)] + _ (&type/set-var iid =var*) + tuple-type* (&type/clean $var tuple-type)] + (return (&/$UnivQ &/$Nil tuple-type*))) + + _ + (&type/clean $var tuple-type))] + (return (&/|list (&&/|meta inferred-type tuple-cursor + tuple-analysis)))))) + + _ + (analyse-tuple analyse (&/$Right exo-type*) ?elems))) + + (&/$Right exo-type) + (|do [unknown? (&type/unknown? exo-type)] + (if unknown? + (|do [=elems (&/map% #(|do [=analysis (&&/analyse-1+ analyse %)] + (return =analysis)) + ?elems) + _ (&type/check exo-type (|case (->> (&/|map &&/expr-type* =elems) (&/|reverse)) + (&/$Cons last prevs) + (&/fold (fn [right left] (&/$ProdT left right)) + last prevs))) + _cursor &/cursor] + (return (&/|list (&&/|meta exo-type _cursor + (&&/$tuple =elems) + )))) + (|do [exo-type* (&type/actual-type exo-type)] + (&/with-attempt + (|case exo-type* + (&/$ProdT _) + (|let [num-elems (&/|length ?elems) + [_shorter _tuple-types] (&type/tuple-types-for num-elems exo-type*)] + (if (= num-elems _shorter) + (|do [=elems (&/map2% (fn [elem-t elem] + (&&/analyse-1 analyse elem-t elem)) + _tuple-types + ?elems) + _cursor &/cursor] + (return (&/|list (&&/|meta exo-type _cursor + (&&/$tuple =elems) + )))) + (|do [=direct-elems (&/map2% (fn [elem-t elem] (&&/analyse-1 analyse elem-t elem)) + (&/|take (dec _shorter) _tuple-types) + (&/|take (dec _shorter) ?elems)) + =indirect-elems (analyse-tuple analyse + (&/$Right (&/|last _tuple-types)) + (&/|drop (dec _shorter) ?elems)) + _cursor &/cursor] + (return (&/|list (&&/|meta exo-type _cursor + (&&/$tuple (&/|++ =direct-elems =indirect-elems)) + )))))) + + (&/$ExQ _) + (&type/with-var + (fn [$var] + (|do [exo-type** (&type/apply-type exo-type* $var) + [[tuple-type tuple-cursor] tuple-analysis] (&&/cap-1 (analyse-tuple analyse (&/$Right exo-type**) ?elems)) + =tuple-analysis (&&/clean-analysis $var (&&/|meta exo-type tuple-cursor + tuple-analysis))] + (return (&/|list =tuple-analysis))))) + + (&/$UnivQ _) + (|do [$var &type/existential + :let [(&/$ExT $var-id) $var] + exo-type** (&type/apply-type exo-type* $var) + [[tuple-type tuple-cursor] tuple-analysis] (&/with-scope-type-var $var-id + (&&/cap-1 (analyse-tuple analyse (&/$Right exo-type**) ?elems)))] + (return (&/|list (&&/|meta exo-type tuple-cursor + tuple-analysis)))) + + _ + (&/fail-with-loc (str "[Analyser Error] Tuples require tuple-types: " (&type/show-type exo-type*))) + ) + (fn [err] + (&/fail-with-loc (str err "\n" "[Analyser Error] Tuples require tuple-types: " (&type/show-type exo-type))))))))) + )) + +(defn ^:private analyse-variant-body [analyse exo-type ?values] + (|do [_cursor &/cursor + output (|case ?values + (&/$Nil) + (analyse-unit analyse exo-type) + + (&/$Cons ?value (&/$Nil)) + (analyse exo-type ?value) + + _ + (analyse-tuple analyse (&/$Right exo-type) ?values))] + (|case output + (&/$Cons x (&/$Nil)) + (return x) + + _ + (&/fail-with-loc "[Analyser Error] Can't expand to other than 1 element.")))) + +(defn analyse-variant [analyse ?exo-type idx is-last? ?values] + (|case ?exo-type + (&/$Left exo-type) + (|do [exo-type* (&type/actual-type exo-type)] + (|case exo-type* + (&/$UnivQ _) + (&type/with-var + (fn [$var] + (|do [exo-type** (&type/apply-type exo-type* $var) + [[variant-type variant-cursor] variant-analysis] (&&/cap-1 (analyse-variant analyse (&/$Left exo-type**) idx is-last? ?values)) + =var (&type/resolve-type $var) + inferred-type (|case =var + (&/$VarT iid) + (|do [:let [=var* (next-bound-type variant-type)] + _ (&type/set-var iid =var*) + variant-type* (&type/clean $var variant-type)] + (return (&/$UnivQ &/$Nil variant-type*))) + + _ + (&type/clean $var variant-type))] + (return (&/|list (&&/|meta inferred-type variant-cursor + variant-analysis)))))) + + _ + (analyse-variant analyse (&/$Right exo-type*) idx is-last? ?values))) + + (&/$Right exo-type) + (|do [exo-type* (|case exo-type + (&/$VarT ?id) + (&/try-all% (&/|list (|do [exo-type* (&type/deref ?id)] + (&type/actual-type exo-type*)) + (|do [_ (&type/set-var ?id &type/Type)] + (&type/actual-type &type/Type)))) + + _ + (&type/actual-type exo-type))] + (&/with-attempt + (|case exo-type* + (&/$SumT _) + (|do [vtype (&type/sum-at idx exo-type*) + :let [num-variant-types (&/|length (&type/flatten-sum exo-type*)) + is-last?* (if (nil? is-last?) + (= idx (dec num-variant-types)) + is-last?)] + =value (analyse-variant-body analyse vtype ?values) + _cursor &/cursor] + (if (= 1 num-variant-types) + (return (&/|list =value)) + (return (&/|list (&&/|meta exo-type _cursor (&&/$variant idx is-last?* =value)))) + )) + + (&/$UnivQ _) + (|do [$var &type/existential + exo-type** (&type/apply-type exo-type* $var)] + (analyse-variant analyse (&/$Right exo-type**) idx is-last? ?values)) + + (&/$ExQ _) + (&type/with-var + (fn [$var] + (|do [exo-type** (&type/apply-type exo-type* $var) + =exprs (analyse-variant analyse (&/$Right exo-type**) idx is-last? ?values)] + (&/map% (partial &&/clean-analysis $var) =exprs)))) + + _ + (&/fail-with-loc (str "[Analyser Error] Can't create variant if the expected type is " (&type/show-type exo-type*) " " idx " " (->> ?values (&/|map &/show-ast) (&/|interpose " ") (&/fold str ""))))) + (fn [err] + (|case exo-type + (&/$VarT ?id) + (|do [=exo-type (&type/deref ?id)] + (&/fail-with-loc (str err "\n" "[Analyser Error] Can't create variant if the expected type is " (&type/show-type =exo-type) " " idx " " (->> ?values (&/|map &/show-ast) (&/|interpose " ") (&/fold str ""))))) + + _ + (&/fail-with-loc (str err "\n" "[Analyser Error] Can't create variant if the expected type is " (&type/show-type exo-type) " " idx " " (->> ?values (&/|map &/show-ast) (&/|interpose " ") (&/fold str ""))))))) + ))) + +(defn analyse-record [analyse exo-type ?elems] + (|do [[rec-members rec-type] (&&record/order-record ?elems)] + (|case exo-type + (&/$VarT id) + (|do [? (&type/bound? id)] + (if ? + (analyse-tuple analyse (&/$Right exo-type) rec-members) + (|do [[[tuple-type tuple-cursor] tuple-analysis] (&&/cap-1 (analyse-tuple analyse (&/$Left rec-type) rec-members)) + _ (&type/check exo-type tuple-type)] + (return (&/|list (&&/|meta exo-type tuple-cursor + tuple-analysis)))))) + + _ + (analyse-tuple analyse (&/$Right exo-type) rec-members) + ))) + +(defn ^:private analyse-global [analyse exo-type module name] + (|do [[[r-module r-name] [endo-type ?meta ?value]] (&&module/find-def module name) + ;; This is a small shortcut to optimize analysis of typing code. + _ (if (and (clojure.lang.Util/identical &type/Type endo-type) + (clojure.lang.Util/identical &type/Type exo-type)) + (return nil) + (&type/check exo-type endo-type)) + _cursor &/cursor] + (return (&/|list (&&/|meta endo-type _cursor + (&&/$var (&/$Global (&/T [r-module r-name])))))))) + +(defn ^:private analyse-local [analyse exo-type name] + (fn [state] + (|let [stack (&/get$ &/$scopes state) + no-binding? #(and (->> % (&/get$ &/$locals) (&/get$ &/$mappings) (&/|contains? name) not) + (->> % (&/get$ &/$closure) (&/get$ &/$mappings) (&/|contains? name) not)) + [inner outer] (&/|split-with no-binding? stack)] + (|case outer + (&/$Nil) + (&/run-state (|do [module-name &/get-module-name] + (analyse-global analyse exo-type module-name name)) + state) + + (&/$Cons ?genv (&/$Nil)) + (if-let [global (->> ?genv (&/get$ &/$locals) (&/get$ &/$mappings) (&/|get name))] + (|case global + [(&/$Global ?module* name*) _] + (&/run-state (analyse-global analyse exo-type ?module* name*) + state) + + _ + (fail* "[Analyser Error] Can't have anything other than a global def in the global environment.")) + (fail* (str "[Analyser Error] Unknown global definition: " name))) + + (&/$Cons bottom-outer _) + (|let [scopes (&/|map #(&/get$ &/$name %) (&/|reverse inner)) + [=local inner*] (&/fold2 (fn [register+new-inner frame in-scope] + (|let [[register new-inner] register+new-inner + [register* frame*] (&&lambda/close-over in-scope name register frame)] + (&/T [register* (&/$Cons frame* new-inner)]))) + (&/T [(or (->> bottom-outer (&/get$ &/$locals) (&/get$ &/$mappings) (&/|get name)) + (->> bottom-outer (&/get$ &/$closure) (&/get$ &/$mappings) (&/|get name))) + &/$Nil]) + (&/|reverse inner) scopes)] + ((|do [_ (&type/check exo-type (&&/expr-type* =local))] + (return (&/|list =local))) + (&/set$ &/$scopes (&/|++ inner* outer) state))) + )))) + +(defn analyse-symbol [analyse exo-type ident] + (|do [:let [[?module ?name] ident]] + (if (= "" ?module) + (analyse-local analyse exo-type ?name) + (analyse-global analyse exo-type ?module ?name)) + )) + +(defn ^:private analyse-apply* [analyse exo-type fun-type ?args] + (|case ?args + (&/$Nil) + (|do [_ (&type/check exo-type fun-type)] + (return (&/T [fun-type &/$Nil]))) + + (&/$Cons ?arg ?args*) + (|do [?fun-type* (&type/actual-type fun-type)] + (&/with-attempt + (|case ?fun-type* + (&/$UnivQ _) + (&type/with-var + (fn [$var] + (|do [type* (&type/apply-type ?fun-type* $var) + [=output-t =args] (analyse-apply* analyse exo-type type* ?args) + ==args (&/map% (partial &&/clean-analysis $var) =args)] + (|case $var + (&/$VarT ?id) + (|do [? (&type/bound? ?id) + type** (if ? + (&type/clean $var =output-t) + (|do [_ (&type/set-var ?id (next-bound-type =output-t)) + cleaned-output* (&type/clean $var =output-t) + :let [cleaned-output (&/$UnivQ &/$Nil cleaned-output*)]] + (return cleaned-output))) + _ (&type/clean $var exo-type)] + (return (&/T [type** ==args]))) + )))) + + (&/$ExQ _) + (|do [$var &type/existential + type* (&type/apply-type ?fun-type* $var)] + (analyse-apply* analyse exo-type type* ?args)) + + (&/$LambdaT ?input-t ?output-t) + (|do [[=output-t =args] (analyse-apply* analyse exo-type ?output-t ?args*) + =arg (&/with-attempt + (&&/analyse-1 analyse ?input-t ?arg) + (fn [err] + (&/fail-with-loc (str err "\n" "[Analyser Error] Function expected: " (&type/show-type ?input-t)))))] + (return (&/T [=output-t (&/$Cons =arg =args)]))) + + _ + (&/fail-with-loc (str "[Analyser Error] Can't apply a non-function: " (&type/show-type ?fun-type*)))) + (fn [err] + (&/fail-with-loc (str err "\n" "[Analyser Error] Can't apply function " (&type/show-type fun-type) " to args: " (->> ?args (&/|map &/show-ast) (&/|interpose " ") (&/fold str ""))))))) + )) + +(defn ^:private do-analyse-apply [analyse exo-type =fn ?args] + (|do [:let [[[=fn-type =fn-cursor] =fn-form] =fn] + [=output-t =args] (analyse-apply* analyse exo-type =fn-type ?args)] + (return (&/|list (&&/|meta =output-t =fn-cursor + (&&/$apply =fn =args) + ))))) + +(defn analyse-apply [analyse cursor exo-type =fn ?args] + (|do [loader &/loader + :let [[[=fn-type =fn-cursor] =fn-form] =fn]] + (|case =fn-form + (&&/$var (&/$Global ?module ?name)) + (|do [[real-name [?type ?meta ?value]] (&&module/find-def ?module ?name)] + (|case (&&meta/meta-get &&meta/macro?-tag ?meta) + (&/$Some _) + (|do [macro-expansion (fn [state] + (|case (-> ?value (.apply ?args) (.apply state)) + (&/$Right state* output) + (&/$Right (&/T [state* output])) + + (&/$Left error) + ((&/fail-with-loc error) state))) + module-name &/get-module-name + ;; :let [[r-prefix r-name] real-name + ;; _ (when (or (= "actor:" r-name) + ;; ;; (= "|Codec@Json|" r-name) + ;; ;; (= "|Codec@Json//encode|" r-name) + ;; ;; (= "|Codec@Json//decode|" r-name) + ;; ;; (= "derived:" r-name) + ;; ) + ;; (->> (&/|map &/show-ast macro-expansion) + ;; (&/|interpose "\n") + ;; (&/fold str "") + ;; (prn (&/ident->text real-name) module-name))) + ;; ] + ] + (&/flat-map% (partial analyse exo-type) macro-expansion)) + + _ + (do-analyse-apply analyse exo-type =fn ?args))) + + _ + (do-analyse-apply analyse exo-type =fn ?args)) + )) + +(defn analyse-case [analyse exo-type ?value ?branches] + (|do [:let [num-branches (&/|length ?branches)] + _ (&/assert! (> num-branches 0) "[Analyser Error] Can't have empty branches in \"case\" expression.") + _ (&/assert! (even? num-branches) "[Analyser Error] Unbalanced branches in \"case\" expression.") + =value (&&/analyse-1+ analyse ?value) + :let [var?? (|case =value + [_ (&&/$var =var-kind)] + (&/$Some =value) + + _ + &/$None)] + =match (&&case/analyse-branches analyse exo-type var?? (&&/expr-type* =value) (&/|as-pairs ?branches)) + _cursor &/cursor] + (return (&/|list (&&/|meta exo-type _cursor + (&&/$case =value =match) + ))))) + +(defn ^:private unravel-inf-appt [type] + (|case type + (&/$AppT =input+ (&/$VarT _inf-var)) + (&/$Cons _inf-var (unravel-inf-appt =input+)) + + _ + (&/|list))) + +(defn ^:private clean-func-inference [$input $output =input =func] + (|case =input + (&/$VarT iid) + (|do [:let [=input* (next-bound-type =func)] + _ (&type/set-var iid =input*) + =func* (&type/clean $input =func) + =func** (&type/clean $output =func*)] + (return (&/$UnivQ &/$Nil =func**))) + + (&/$AppT =input+ (&/$VarT _inf-var)) + (&/fold% (fn [_func _inf-var] + (|do [:let [$inf-var (&/$VarT _inf-var)] + =inf-var (&type/resolve-type $inf-var) + _func* (clean-func-inference $inf-var $output =inf-var _func) + _ (&type/delete-var _inf-var)] + (return _func*))) + =func + (unravel-inf-appt =input)) + + (&/$ProdT _ _) + (&/fold% (fn [_func _inf-var] + (|do [:let [$inf-var (&/$VarT _inf-var)] + =inf-var (&type/resolve-type $inf-var) + _func* (clean-func-inference $inf-var $output =inf-var _func) + _ (&type/delete-var _inf-var)] + (return _func*))) + =func + (&/|reverse (&type/flatten-prod =input))) + + _ + (|do [=func* (&type/clean $input =func) + =func** (&type/clean $output =func*)] + (return =func**)))) + +(defn analyse-lambda* [analyse exo-type ?self ?arg ?body] + (|case exo-type + (&/$VarT id) + (|do [? (&type/bound? id)] + (if ? + (|do [exo-type* (&type/deref id)] + (analyse-lambda* analyse exo-type* ?self ?arg ?body)) + ;; Inference + (&type/with-var + (fn [$input] + (&type/with-var + (fn [$output] + (|do [[[lambda-type lambda-cursor] lambda-analysis] (analyse-lambda* analyse (&/$LambdaT $input $output) ?self ?arg ?body) + =input (&type/resolve-type $input) + =output (&type/resolve-type $output) + inferred-type (clean-func-inference $input $output =input (embed-inferred-input =input =output)) + _ (&type/check exo-type inferred-type)] + (return (&&/|meta inferred-type lambda-cursor + lambda-analysis))) + )))))) + + _ + (&/with-attempt + (|do [exo-type* (&type/actual-type exo-type)] + (|case exo-type* + (&/$UnivQ _) + (|do [$var &type/existential + :let [(&/$ExT $var-id) $var] + exo-type** (&type/apply-type exo-type* $var)] + (&/with-scope-type-var $var-id + (analyse-lambda* analyse exo-type** ?self ?arg ?body))) + + (&/$ExQ _) + (&type/with-var + (fn [$var] + (|do [exo-type** (&type/apply-type exo-type* $var) + =expr (analyse-lambda* analyse exo-type** ?self ?arg ?body)] + (&&/clean-analysis $var =expr)))) + + (&/$LambdaT ?arg-t ?return-t) + (|do [[=scope =captured =body] (&&lambda/with-lambda ?self exo-type* + ?arg ?arg-t + (&&/analyse-1 analyse ?return-t ?body)) + _cursor &/cursor + register-offset &&env/next-local-idx] + (return (&&/|meta exo-type* _cursor + (&&/$lambda register-offset =scope =captured =body)))) + + _ + (fail ""))) + (fn [err] + (&/fail-with-loc (str err "\n" "[Analyser Error] Functions require function types: " (&type/show-type exo-type))))) + )) + +(defn analyse-lambda** [analyse exo-type ?self ?arg ?body] + (|case exo-type + (&/$UnivQ _) + (|do [$var &type/existential + :let [(&/$ExT $var-id) $var] + exo-type* (&type/apply-type exo-type $var) + [_ _expr] (&/with-scope-type-var $var-id + (analyse-lambda** analyse exo-type* ?self ?arg ?body)) + _cursor &/cursor] + (return (&&/|meta exo-type _cursor _expr))) + + (&/$VarT id) + (|do [? (&type/bound? id)] + (if ? + (|do [exo-type* (&type/actual-type exo-type)] + (analyse-lambda* analyse exo-type* ?self ?arg ?body)) + ;; Inference + (analyse-lambda* analyse exo-type ?self ?arg ?body))) + + _ + (|do [exo-type* (&type/actual-type exo-type)] + (analyse-lambda* analyse exo-type* ?self ?arg ?body)) + )) + +(defn analyse-lambda [analyse exo-type ?self ?arg ?body] + (|do [output (&/with-no-catches + (analyse-lambda** analyse exo-type ?self ?arg ?body))] + (return (&/|list output)))) + +(defn analyse-def [analyse optimize eval! compile-def ?name ?value ?meta] + (|do [_ &/ensure-statement + module-name &/get-module-name + ? (&&module/defined? module-name ?name)] + (if ? + (&/fail-with-loc (str "[Analyser Error] Can't redefine " (str module-name ";" ?name))) + (|do [=value (&/without-repl-closure + (&/with-scope ?name + (&&/analyse-1+ analyse ?value))) + =meta (&&/analyse-1 analyse &type/Anns ?meta) + ==meta (eval! (optimize =meta)) + _ (&&module/test-type module-name ?name ==meta (&&/expr-type* =value)) + _ (&&module/test-macro module-name ?name ==meta (&&/expr-type* =value)) + _ (compile-def ?name (optimize =value) ==meta)] + (return &/$Nil)) + ))) + +(defn ^:private merge-hosts + "(-> Host Host Host)" + [new old] + (|let [merged-module-states (&/fold (fn [total m-state] + (|let [[_name _state] m-state] + (|case _state + (&/$Cached) + (&/|put _name _state total) + + (&/$Compiled) + (&/|put _name _state total) + + _ + total))) + (&/get$ &/$module-states old) + (&/get$ &/$module-states new))] + (->> old + (&/set$ &/$module-states merged-module-states)))) + +(defn ^:private merge-modules + "(-> Text Module Module Module)" + [current-module new old] + (&/fold (fn [total* entry] + (|let [[_name _module] entry] + (if (or (= current-module _name) + (->> _module + (&/get$ &&module/$defs) + &/|length + (= 0))) + ;; Don't modify the entry of the current module, to + ;; avoid overwritting it's data in improper ways. + ;; Since it's assumed the "original" old module + ;; contains all the proper own-module information. + total* + (&/|put _name _module total*)))) + old new)) + +(defn ^:private merge-compilers + "(-> Text Compiler Compiler Compiler)" + [current-module new old] + (->> old + (&/set$ &/$modules (merge-modules current-module + (&/get$ &/$modules new) + (&/get$ &/$modules old))) + (&/set$ &/$seed (max (&/get$ &/$seed new) + (&/get$ &/$seed old))) + (&/set$ &/$host (merge-hosts (&/get$ &/$host new) + (&/get$ &/$host old))))) + +(def ^:private get-compiler + (fn [compiler] + (return* compiler compiler))) + +(defn ^:private set-compiler [compiler*] + (fn [_] + (return* compiler* compiler*))) + +(defn analyse-module [analyse optimize eval! compile-module ?meta] + (|do [_ &/ensure-statement + =anns (&&/analyse-1 analyse &type/Anns ?meta) + ==anns (eval! (optimize =anns)) + module-name &/get-module-name + _ (&&module/set-anns ==anns module-name) + _imports (&&module/fetch-imports ==anns) + current-module &/get-module-name + ;; =asyncs (&/map% (fn [_import] + ;; (|let [[path alias] _import] + ;; (&/without-repl + ;; (&/save-module + ;; (|do [_ (if (= current-module path) + ;; (&/fail-with-loc (str "[Analyser Error] Module can't import itself: " path)) + ;; (return nil)) + ;; already-compiled? (&&module/exists? path) + ;; active? (&/active-module? path) + ;; _ (&/assert! (not active?) + ;; (str "[Analyser Error] Can't import a module that is mid-compilation: " path " @ " current-module)) + ;; _ (&&module/add-import path) + ;; ?async (if (not already-compiled?) + ;; (compile-module path) + ;; (|do [_compiler get-compiler] + ;; (return (doto (promise) + ;; (deliver (&/$Right _compiler)))))) + ;; _ (if (= "" alias) + ;; (return nil) + ;; (&&module/alias current-module alias path))] + ;; (return ?async)))))) + ;; _imports) + ;; _compiler get-compiler + ;; ;; Some type-vars in the typing environment stay in + ;; ;; the environment forever, making type-checking slower. + ;; ;; The merging process for compilers more-or-less "fixes" the + ;; ;; problem by resetting the typing enviroment, but ideally + ;; ;; those type-vars shouldn't survive in the first place. + ;; ;; TODO: MUST FIX + ;; _ (&/fold% (fn [compiler _async] + ;; (|case @_async + ;; (&/$Right _new-compiler) + ;; (set-compiler (merge-compilers current-module _new-compiler compiler)) + + ;; (&/$Left ?error) + ;; (fail ?error))) + ;; _compiler + ;; =asyncs) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + _ (&/map% (fn [_import] + (|let [[path alias] _import] + (&/without-repl + (&/save-module + (|do [_ (if (= current-module path) + (&/fail-with-loc (str "[Analyser Error] Module can't import itself: " path)) + (return nil)) + already-compiled? (&&module/exists? path) + active? (&/active-module? path) + _ (&/assert! (not active?) + (str "[Analyser Error] Can't import a module that is mid-compilation: " path " @ " current-module)) + _ (&&module/add-import path) + _ (if (not already-compiled?) + (compile-module path) + (return nil)) + _ (if (= "" alias) + (return nil) + (&&module/alias current-module alias path))] + (return nil)))))) + _imports)] + (return &/$Nil))) + +(defn ^:private coerce [new-type analysis] + "(-> Type Analysis Analysis)" + (|let [[[_type _cursor] _analysis] analysis] + (&&/|meta new-type _cursor + _analysis))) + +(defn analyse-ann [analyse eval! exo-type ?type ?value] + (|do [=type (&&/analyse-1 analyse &type/Type ?type) + ==type (eval! =type) + _ (&type/check exo-type ==type) + =value (&/with-expected-type ==type + (&&/analyse-1 analyse ==type ?value)) + _cursor &/cursor] + (return (&/|list (&&/|meta ==type _cursor + (&&/$ann =value =type) + ))))) + +(defn analyse-coerce [analyse eval! exo-type ?type ?value] + (|do [=type (&&/analyse-1 analyse &type/Type ?type) + ==type (eval! =type) + _ (&type/check exo-type ==type) + =value (&&/analyse-1+ analyse ?value)] + (return (&/|list (coerce ==type =value))))) + +(let [input-type (&/$AppT &type/List &type/Text) + output-type (&/$AppT &type/IO &/$UnitT)] + (defn analyse-program [analyse optimize compile-program ?args ?body] + (|do [_ &/ensure-statement + =body (&/with-scope "" + (&&env/with-local ?args input-type + (&&/analyse-1 analyse output-type ?body))) + _ (compile-program (optimize =body))] + (return &/$Nil)))) diff --git a/luxc/src/lux/analyser/meta.clj b/luxc/src/lux/analyser/meta.clj new file mode 100644 index 000000000..831386f47 --- /dev/null +++ b/luxc/src/lux/analyser/meta.clj @@ -0,0 +1,46 @@ +;; Copyright (c) Eduardo Julian. All rights reserved. +;; This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +;; If a copy of the MPL was not distributed with this file, +;; You can obtain one at http://mozilla.org/MPL/2.0/. + +(ns lux.analyser.meta + (:require (clojure [template :refer [do-template]]) + clojure.core.match + clojure.core.match.array + (lux [base :as & :refer [|let |do return return* fail fail* |case]]))) + +;; [Utils] +(defn ^:private ident= [x y] + (|let [[px nx] x + [py ny] y] + (and (= px py) + (= nx ny)))) + +(def ^:private tag-prefix "lux") + +;; [Values] +(defn meta-get [ident dict] + "(-> Ident Anns (Maybe Ann-Value))" + (|case dict + (&/$Cons [k v] dict*) + (if (ident= k ident) + (&/$Some v) + (meta-get ident dict*)) + + (&/$Nil) + &/$None + + _ + (assert false (prn-str (&/adt->text ident) + (&/adt->text dict))))) + +(do-template [<name> <tag-name>] + (def <name> (&/T [tag-prefix <tag-name>])) + + type?-tag "type?" + alias-tag "alias" + macro?-tag "macro?" + export?-tag "export?" + tags-tag "tags" + imports-tag "imports" + ) diff --git a/luxc/src/lux/analyser/module.clj b/luxc/src/lux/analyser/module.clj new file mode 100644 index 000000000..62948bf0d --- /dev/null +++ b/luxc/src/lux/analyser/module.clj @@ -0,0 +1,403 @@ +;; Copyright (c) Eduardo Julian. All rights reserved. +;; This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +;; If a copy of the MPL was not distributed with this file, +;; You can obtain one at http://mozilla.org/MPL/2.0/. + +(ns lux.analyser.module + (:refer-clojure :exclude [alias]) + (:require (clojure [string :as string] + [template :refer [do-template]]) + clojure.core.match + clojure.core.match.array + (lux [base :as & :refer [deftuple |let |do return return* |case]] + [type :as &type] + [host :as &host]) + [lux.host.generics :as &host-generics] + (lux.analyser [meta :as &meta]))) + +;; [Utils] +(deftuple + ["module-hash" + "module-aliases" + "defs" + "imports" + "tags" + "types" + "module-anns"]) + +(defn ^:private new-module [hash] + (&/T [;; lux;module-hash + hash + ;; "lux;module-aliases" + (&/|table) + ;; "lux;defs" + (&/|table) + ;; "lux;imports" + &/$Nil + ;; "lux;tags" + (&/|table) + ;; "lux;types" + (&/|table) + ;; module-anns + (&/|list)] + )) + +;; [Exports] +(defn add-import + "(-> Text (Lux Null))" + [module] + (|do [current-module &/get-module-name] + (fn [state] + (if (&/|member? module (->> state (&/get$ &/$modules) (&/|get current-module) (&/get$ $imports))) + ((&/fail-with-loc (str "[Analyser Error] Can't import module " (pr-str module) " twice @ " current-module)) + state) + (return* (&/update$ &/$modules + (fn [ms] + (&/|update current-module + (fn [m] (&/update$ $imports (partial &/$Cons module) m)) + ms)) + state) + nil))))) + +(defn set-imports + "(-> (List Text) (Lux Null))" + [imports] + (|do [current-module &/get-module-name] + (fn [state] + (return* (&/update$ &/$modules + (fn [ms] + (&/|update current-module + (fn [m] (&/set$ $imports imports m)) + ms)) + state) + nil)))) + +(defn define [module name def-type def-meta def-value] + (fn [state] + (when (and (= "Macro" name) (= "lux" module)) + (&type/set-macro-type! def-value)) + (|case (&/get$ &/$scopes state) + (&/$Cons ?env (&/$Nil)) + (return* (->> state + (&/update$ &/$modules + (fn [ms] + (&/|update module + (fn [m] + (&/update$ $defs + #(&/|put name (&/T [def-type def-meta def-value]) %) + m)) + ms)))) + nil) + + _ + ((&/fail-with-loc (str "[Analyser Error] Can't create a new global definition outside of a global environment: " module ";" name)) + state)))) + +(defn def-type + "(-> Text Text (Lux Type))" + [module name] + (fn [state] + (if-let [$module (->> state (&/get$ &/$modules) (&/|get module))] + (if-let [$def (->> $module (&/get$ $defs) (&/|get name))] + (|let [[?type ?meta ?value] $def] + (return* state ?type)) + ((&/fail-with-loc (str "[Analyser Error] Unknown definition: " (str module ";" name))) + state)) + ((&/fail-with-loc (str "[Analyser Error] Unknown module: " module)) + state)))) + +(defn type-def + "(-> Text Text (Lux [Bool Type]))" + [module name] + (fn [state] + (if-let [$module (->> state (&/get$ &/$modules) (&/|get module))] + (if-let [$def (->> $module (&/get$ $defs) (&/|get name))] + (|let [[?type ?meta ?value] $def] + (|case (&meta/meta-get &meta/type?-tag ?meta) + (&/$Some _) + (return* state (&/T [(|case (&meta/meta-get &meta/export?-tag ?meta) + (&/$Some _) + true + + _ + false) + ?value])) + + _ + ((&/fail-with-loc (str "[Analyser Error] Not a type: " (&/ident->text (&/T [module name])))) + state))) + ((&/fail-with-loc (str "[Analyser Error] Unknown definition: " (&/ident->text (&/T [module name])))) + state)) + ((&/fail-with-loc (str "[Analyser Error] Unknown module: " module)) + state)))) + +(defn exists? + "(-> Text (Lux Bool))" + [name] + (fn [state] + (return* state + (->> state (&/get$ &/$modules) (&/|contains? name))))) + +(defn dealias [name] + (|do [current-module &/get-module-name] + (fn [state] + (if-let [real-name (->> state (&/get$ &/$modules) (&/|get current-module) (&/get$ $module-aliases) (&/|get name))] + (return* state real-name) + ((&/fail-with-loc (str "[Analyser Error] Unknown alias: " name)) + state))))) + +(defn alias [module alias reference] + (fn [state] + (let [_module_ (->> state (&/get$ &/$modules) (&/|get module))] + (if (&/|member? module (->> _module_ (&/get$ $imports))) + ((&/fail-with-loc (str "[Analyser Error] Can't create alias that is the same as a module nameL " (pr-str alias) " for " reference)) + state) + (if-let [real-name (->> _module_ (&/get$ $module-aliases) (&/|get alias))] + ((&/fail-with-loc (str "[Analyser Error] Can't re-use alias \"" alias "\" @ " module)) + state) + (return* (->> state + (&/update$ &/$modules + (fn [ms] + (&/|update module + #(&/update$ $module-aliases + (fn [aliases] + (&/|put alias reference aliases)) + %) + ms)))) + nil)))) + )) + +(defn ^:private imports? [state imported-module-name source-module-name] + (->> state + (&/get$ &/$modules) + (&/|get source-module-name) + (&/get$ $imports) + (&/|any? (partial = imported-module-name)))) + +(defn get-anns [module-name] + (fn [state] + (if-let [module (->> state + (&/get$ &/$modules) + (&/|get module-name))] + (return* state (&/get$ $module-anns module)) + ((&/fail-with-loc (str "[Analyser Error] Module does not exist: " module-name)) + state)))) + +(defn set-anns [anns module-name] + (fn [state] + (return* (->> state + (&/update$ &/$modules + (fn [ms] + (&/|update module-name + #(&/set$ $module-anns anns %) + ms)))) + nil))) + +(defn find-def [module name] + (|do [current-module &/get-module-name] + (fn [state] + (if (or (= "lux" module) + (= current-module module) + (imports? state module current-module)) + (if-let [$module (->> state (&/get$ &/$modules) (&/|get module))] + (if-let [$def (->> $module (&/get$ $defs) (&/|get name))] + (|let [[?type ?meta ?value] $def] + (if (.equals ^Object current-module module) + (|case (&meta/meta-get &meta/alias-tag ?meta) + (&/$Some (&/$IdentM [?r-module ?r-name])) + ((find-def ?r-module ?r-name) + state) + + _ + (return* state (&/T [(&/T [module name]) $def]))) + (|case (&meta/meta-get &meta/export?-tag ?meta) + (&/$Some (&/$BoolM true)) + (return* state (&/T [(&/T [module name]) $def])) + + _ + ((&/fail-with-loc (str "[Analyser Error @ find-def] Can't use unexported definition: " (str module &/+name-separator+ name))) + state)))) + ((&/fail-with-loc (str "[Analyser Error @ find-def] Definition does not exist: " (str module &/+name-separator+ name))) + state)) + ((&/fail-with-loc (str "[Analyser Error @ find-def] Module doesn't exist: " module)) + state)) + ((&/fail-with-loc (str "[Analyser Error @ find-def] Unknown module: " module)) + state)) + ))) + +(defn ensure-type-def + "(-> DefData (Lux Type))" + [def-data] + (|let [[?type ?meta ?value] def-data] + (|case (&meta/meta-get &meta/type?-tag ?meta) + (&/$Some _) + (return ?type) + + _ + (&/fail-with-loc (str "[Analyser Error] Not a type definition: " (&/adt->text def-data)))))) + +(defn defined? [module name] + (&/try-all% (&/|list (|do [_ (find-def module name)] + (return true)) + (return false)))) + +(defn create-module + "(-> Text Hash-Code (Lux Null))" + [name hash] + (fn [state] + (return* (->> state + (&/update$ &/$modules #(&/|put name (new-module hash) %)) + (&/set$ &/$scopes (&/|list (&/env name &/$Nil)))) + nil))) + +(do-template [<name> <tag> <type>] + (defn <name> + <type> + [module] + (fn [state] + (if-let [=module (->> state (&/get$ &/$modules) (&/|get module))] + (return* state (&/get$ <tag> =module)) + ((&/fail-with-loc (str "[Lux Error] Unknown module: " module)) + state)) + )) + + tags-by-module $tags "(-> Text (Lux (List (, Text (, Int (List Text) Type)))))" + types-by-module $types "(-> Text (Lux (List (, Text (, (List Text) Type)))))" + module-hash $module-hash "(-> Text (Lux Int))" + ) + +(def imports + (|do [module &/get-module-name + _imports (fn [state] + (return* state (->> state (&/get$ &/$modules) (&/|get module) (&/get$ $imports))))] + (&/map% (fn [_module] + (|do [_hash (module-hash _module)] + (return (&/T [_module _hash])))) + _imports))) + +(defn ensure-undeclared-tags [module tags] + (|do [tags-table (tags-by-module module) + _ (&/map% (fn [tag] + (if (&/|get tag tags-table) + (&/fail-with-loc (str "[Analyser Error] Can't re-declare tag: " (&/ident->text (&/T [module tag])))) + (return nil))) + tags)] + (return nil))) + +(defn ensure-undeclared-type [module name] + (|do [types-table (types-by-module module) + _ (&/assert! (nil? (&/|get name types-table)) + (str "[Analyser Error] Can't re-declare type: " (&/ident->text (&/T [module name]))))] + (return nil))) + +(defn declare-tags + "(-> Text (List Text) Bool Type (Lux Null))" + [module tag-names was-exported? type] + (|do [_ (ensure-undeclared-tags module tag-names) + type-name (&type/type-name type) + :let [[_module _name] type-name] + _ (&/assert! (= module _module) + (str "[Module Error] Can't define tags for a type belonging to a foreign module: " (&/ident->text type-name))) + _ (ensure-undeclared-type _module _name)] + (fn [state] + (if-let [=module (->> state (&/get$ &/$modules) (&/|get module))] + (let [tags (&/|map (fn [tag-name] (&/T [module tag-name])) tag-names)] + (return* (&/update$ &/$modules + (fn [=modules] + (&/|update module + #(->> % + (&/set$ $tags (&/fold (fn [table idx+tag-name] + (|let [[idx tag-name] idx+tag-name] + (&/|put tag-name (&/T [idx tags was-exported? type]) table))) + (&/get$ $tags %) + (&/enumerate tag-names))) + (&/update$ $types (partial &/|put _name (&/T [tags was-exported? type])))) + =modules)) + state) + nil)) + ((&/fail-with-loc (str "[Lux Error] Unknown module: " module)) + state))))) + +(defn ensure-can-see-tag + "(-> Text Text (Lux Unit))" + [module tag-name] + (|do [current-module &/get-module-name] + (fn [state] + (if-let [=module (->> state (&/get$ &/$modules) (&/|get module))] + (if-let [^objects idx+tags+exported+type (&/|get tag-name (&/get$ $tags =module))] + (|let [[?idx ?tags ?exported ?type] idx+tags+exported+type] + (if (or ?exported + (= module current-module)) + (return* state &/unit-tag) + ((&/fail-with-loc (str "[Analyser Error] Can't access tag #" (&/ident->text (&/T [module tag-name])) " from module " current-module)) + state))) + ((&/fail-with-loc (str "[Module Error] Unknown tag: " (&/ident->text (&/T [module tag-name])))) + state)) + ((&/fail-with-loc (str "[Module Error] Unknown module: " module)) + state))))) + +(do-template [<name> <part> <doc>] + (defn <name> + <doc> + [module tag-name] + (fn [state] + (if-let [=module (->> state (&/get$ &/$modules) (&/|get module))] + (if-let [^objects idx+tags+exported+type (&/|get tag-name (&/get$ $tags =module))] + (|let [[?idx ?tags ?exported ?type] idx+tags+exported+type] + (return* state <part>)) + ((&/fail-with-loc (str "[Module Error] Unknown tag: " (&/ident->text (&/T [module tag-name])))) + state)) + ((&/fail-with-loc (str "[Module Error] Unknown module: " module)) + state)))) + + tag-index ?idx "(-> Text Text (Lux Int))" + tag-group ?tags "(-> Text Text (Lux (List Ident)))" + tag-type ?type "(-> Text Text (Lux Type))" + ) + +(def defs + (|do [module &/get-module-name] + (fn [state] + (return* state + (->> state (&/get$ &/$modules) (&/|get module) (&/get$ $defs) + (&/|map (fn [kv] + (|let [[k _def-data] kv + [_ ?def-meta _] _def-data] + (|case (&meta/meta-get &meta/alias-tag ?def-meta) + (&/$Some (&/$IdentM [?r-module ?r-name])) + (&/T [k (str ?r-module ";" ?r-name) _def-data]) + + _ + (&/T [k "" _def-data]) + ))))))))) + +(do-template [<name> <type> <tag> <desc>] + (defn <name> [module name meta type] + (|case (&meta/meta-get <tag> meta) + (&/$Some (&/$BoolM true)) + (&/try-all% (&/|list (&type/check <type> type) + (&/fail-with-loc (str "[Analyser Error] Can't tag as lux;" <desc> "? if it's not a " <desc> ": " (str module ";" name))))) + + _ + (return nil))) + + test-type &type/Type &meta/type?-tag "type" + test-macro &type/Macro &meta/macro?-tag "macro" + ) + +(defn fetch-imports [meta] + (|case (&meta/meta-get &meta/imports-tag meta) + (&/$Some (&/$ListM _parts)) + (&/map% (fn [_part] + (|case _part + (&/$ListM (&/$Cons [(&/$TextM _module) + (&/$Cons [(&/$TextM _alias) + (&/$Nil)])])) + (return (&/T [_module _alias])) + + _ + (&/fail-with-loc "[Analyser Error] Wrong import syntax."))) + _parts) + + _ + (&/fail-with-loc "[Analyser Error] No import meta-data."))) diff --git a/luxc/src/lux/analyser/parser.clj b/luxc/src/lux/analyser/parser.clj new file mode 100644 index 000000000..e60f28a02 --- /dev/null +++ b/luxc/src/lux/analyser/parser.clj @@ -0,0 +1,469 @@ +;; Copyright (c) Eduardo Julian. All rights reserved. +;; This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +;; If a copy of the MPL was not distributed with this file, +;; You can obtain one at http://mozilla.org/MPL/2.0/. + +(ns lux.analyser.parser + (:require (clojure [template :refer [do-template]]) + clojure.core.match + clojure.core.match.array + (lux [base :as & :refer [|do return* return fail fail* |let |case]] + [reader :as &reader] + [lexer :as &lexer] + [parser :as &parser]))) + +(declare parse-gclass) + +;; [Parsers] +(def ^:private _space_ (&reader/read-text " ")) + +(defn ^:private repeat% [action] + (fn [state] + (|case (action state) + (&/$Left ^String error) + (&/$Right (&/T [state &/$Nil])) + + (&/$Right state* head) + ((|do [tail (repeat% action)] + (return (&/$Cons head tail))) + state*)))) + +(defn ^:private spaced [action] + (fn [state] + (|case (action state) + (&/$Left ^String error) + (&/$Right (&/T [state &/$Nil])) + + (&/$Right state* head) + ((&/try-all% (&/|list (|do [_ _space_ + tail (spaced action)] + (return (&/$Cons head tail))) + (return (&/|list head)))) + state*)))) + +(def ^:private parse-name + (|do [[_ _ =name] (&reader/read-regex #"^([a-zA-Z0-9_\.]+)")] + (return =name))) + +(def ^:private parse-ident + (|do [[_ _ =name] (&reader/read-regex &lexer/+ident-re+)] + (return =name))) + +(defn ^:private with-parens [body] + (|do [_ (&reader/read-text "(") + output body + _ (&reader/read-text ")")] + (return output))) + +(defn ^:private with-brackets [body] + (|do [_ (&reader/read-text "[") + output body + _ (&reader/read-text "]")] + (return output))) + +(defn ^:private with-braces [body] + (|do [_ (&reader/read-text "{") + output body + _ (&reader/read-text "}")] + (return output))) + +(def ^:private parse-type-param + (with-parens + (|do [=name parse-name + _ _space_ + =bounds (spaced parse-gclass)] + (return (&/T [=name =bounds]))))) + +(def ^:private parse-gclass-decl + (with-parens + (|do [=class-name parse-name + _ _space_ + =params (spaced parse-type-param)] + (return (&/T [=class-name =params]))))) + +(def ^:private parse-bound-kind + (&/try-all% (&/|list (|do [_ (&reader/read-text "<")] + (return &/$UpperBound)) + + (|do [_ (&reader/read-text ">")] + (return &/$LowerBound)) + ))) + +(def parse-gclass + (&/try-all% (&/|list (|do [=bound-kind parse-bound-kind + =bound parse-gclass] + (return (&/$GenericWildcard (&/$Some (&/T [=bound-kind =bound]))))) + + (|do [_ (&reader/read-text "?")] + (return (&/$GenericWildcard &/$None))) + + (|do [var-name parse-name] + (return (&/$GenericTypeVar var-name))) + + (with-parens + (|do [class-name parse-name + _ _space_ + =params (spaced parse-gclass)] + (return (&/$GenericClass class-name =params)))) + + (with-parens + (|do [_ (&reader/read-text "Array") + _ _space_ + =param parse-gclass] + (return (&/$GenericArray =param)))) + ))) + +(def ^:private parse-gclass-super + (with-parens + (|do [class-name parse-name + _ _space_ + =params (spaced parse-gclass)] + (return (&/T [class-name =params]))))) + +(def ^:private parse-ctor-arg + (with-brackets + (|do [=class parse-gclass + (&/$Cons =term (&/$Nil)) &parser/parse] + (return (&/T [=class =term]))))) + +(def ^:private parse-ann-param + (|do [param-name parse-name + _ (&reader/read-text "=") + param-value (&/try-all% (&/|list (|do [[_ (&lexer/$Bool param-value*)] &lexer/lex-bool] + (return (boolean param-value*))) + + (|do [[_ (&lexer/$Int param-value*)] &lexer/lex-int] + (return (int param-value*))) + + (|do [_ (&reader/read-text "l") + [_ (&lexer/$Int param-value*)] &lexer/lex-int] + (return (long param-value*))) + + (|do [[_ (&lexer/$Real param-value*)] &lexer/lex-real] + (return (float param-value*))) + + (|do [_ (&reader/read-text "d") + [_ (&lexer/$Real param-value*)] &lexer/lex-real] + (return (double param-value*))) + + (|do [[_ (&lexer/$Char param-value*)] &lexer/lex-char] + (return (char param-value*))) + + (|do [[_ (&lexer/$Text param-value*)] &lexer/lex-text] + (return param-value*)) + ))] + (return (&/T [param-name param-value])))) + +(def ^:private parse-ann + (with-parens + (|do [ann-name parse-name + _ _space_ + =ann-params (with-braces + (spaced parse-ann-param))] + (return {:name ann-name + :params =ann-params})))) + +(def ^:private parse-arg-decl + (with-parens + (|do [=arg-name parse-ident + _ (&reader/read-text " ") + =gclass parse-gclass] + (return (&/T [=arg-name =gclass]))))) + +(def ^:private parse-gvars + (|do [=head parse-name + [_ _ ?] (&reader/read-text? " ")] + (if ? + (|do [=tail parse-gvars] + (return (&/$Cons =head =tail))) + (return (&/|list =head))))) + +(def ^:private parse-method-decl + (with-parens + (|do [=method-name parse-name + _ _space_ + =anns (with-brackets + (spaced parse-ann)) + _ _space_ + =gvars (with-brackets + parse-gvars) + _ _space_ + =exceptions (with-brackets + (spaced parse-gclass)) + _ _space_ + =inputs (with-brackets + (spaced parse-gclass)) + _ _space_ + =output parse-gclass] + (return (&/T [=method-name =anns =gvars =exceptions =inputs =output]))))) + +(def ^:private parse-privacy-modifier + (&/try-all% (&/|list (|do [_ (&reader/read-text "default")] + (return &/$DefaultPM)) + + (|do [_ (&reader/read-text "public")] + (return &/$PublicPM)) + + (|do [_ (&reader/read-text "protected")] + (return &/$ProtectedPM)) + + (|do [_ (&reader/read-text "private")] + (return &/$PrivatePM)) + ))) + +(def ^:private parse-state-modifier + (&/try-all% (&/|list (|do [_ (&reader/read-text "default")] + (return &/$DefaultSM)) + + (|do [_ (&reader/read-text "volatile")] + (return &/$VolatileSM)) + + (|do [_ (&reader/read-text "final")] + (return &/$FinalSM)) + ))) + +(def ^:private parse-inheritance-modifier + (&/try-all% (&/|list (|do [_ (&reader/read-text "default")] + (return &/$DefaultIM)) + + (|do [_ (&reader/read-text "abstract")] + (return &/$AbstractIM)) + + (|do [_ (&reader/read-text "final")] + (return &/$FinalIM)) + ))) + +(def ^:private parse-method-init-def + (|do [_ (&reader/read-text "init") + _ _space_ + =privacy-modifier parse-privacy-modifier + _ _space_ + [_ (&lexer/$Bool =strict*)] &lexer/lex-bool + :let [=strict (Boolean/parseBoolean =strict*)] + _ _space_ + =anns (with-brackets + (spaced parse-ann)) + _ _space_ + =gvars (with-brackets + (spaced parse-type-param)) + _ _space_ + =exceptions (with-brackets + (spaced parse-gclass)) + _ _space_ + =inputs (with-brackets + (spaced parse-arg-decl)) + _ _space_ + =ctor-args (with-brackets + (spaced parse-ctor-arg)) + _ _space_ + (&/$Cons =body (&/$Nil)) &parser/parse] + (return (&/$ConstructorMethodSyntax (&/T [=privacy-modifier =strict =anns =gvars =exceptions =inputs =ctor-args =body]))))) + +(def ^:private parse-method-virtual-def + (|do [_ (&reader/read-text "virtual") + _ _space_ + =name parse-name + _ _space_ + =privacy-modifier parse-privacy-modifier + _ _space_ + [_ (&lexer/$Bool =final?*)] &lexer/lex-bool + :let [=final? (Boolean/parseBoolean =final?*)] + _ _space_ + [_ (&lexer/$Bool =strict*)] &lexer/lex-bool + :let [=strict (Boolean/parseBoolean =strict*)] + _ _space_ + =anns (with-brackets + (spaced parse-ann)) + _ _space_ + =gvars (with-brackets + (spaced parse-type-param)) + _ _space_ + =exceptions (with-brackets + (spaced parse-gclass)) + _ _space_ + =inputs (with-brackets + (spaced parse-arg-decl)) + _ _space_ + =output parse-gclass + _ _space_ + (&/$Cons =body (&/$Nil)) &parser/parse] + (return (&/$VirtualMethodSyntax (&/T [=name =privacy-modifier =final? =strict =anns =gvars =exceptions =inputs =output =body]))))) + +(def ^:private parse-method-override-def + (|do [_ (&reader/read-text "override") + _ _space_ + =class-decl parse-gclass-decl + _ _space_ + =name parse-name + _ _space_ + [_ (&lexer/$Bool =strict*)] &lexer/lex-bool + :let [=strict (Boolean/parseBoolean =strict*)] + _ _space_ + =anns (with-brackets + (spaced parse-ann)) + _ _space_ + =gvars (with-brackets + (spaced parse-type-param)) + _ _space_ + =exceptions (with-brackets + (spaced parse-gclass)) + _ _space_ + =inputs (with-brackets + (spaced parse-arg-decl)) + _ _space_ + =output parse-gclass + _ _space_ + (&/$Cons =body (&/$Nil)) &parser/parse] + (return (&/$OverridenMethodSyntax (&/T [=class-decl =name =strict =anns =gvars =exceptions =inputs =output =body]))))) + +(def ^:private parse-method-static-def + (|do [_ (&reader/read-text "static") + _ _space_ + =name parse-name + _ _space_ + =privacy-modifier parse-privacy-modifier + _ _space_ + [_ (&lexer/$Bool =strict*)] &lexer/lex-bool + :let [=strict (Boolean/parseBoolean =strict*)] + _ _space_ + =anns (with-brackets + (spaced parse-ann)) + _ _space_ + =gvars (with-brackets + (spaced parse-type-param)) + _ _space_ + =exceptions (with-brackets + (spaced parse-gclass)) + _ _space_ + =inputs (with-brackets + (spaced parse-arg-decl)) + _ _space_ + =output parse-gclass + _ _space_ + (&/$Cons =body (&/$Nil)) &parser/parse] + (return (&/$StaticMethodSyntax (&/T [=name =privacy-modifier =strict =anns =gvars =exceptions =inputs =output =body]))))) + +(def ^:private parse-method-abstract-def + (|do [_ (&reader/read-text "abstract") + _ _space_ + =name parse-name + _ _space_ + =privacy-modifier parse-privacy-modifier + _ _space_ + =anns (with-brackets + (spaced parse-ann)) + _ _space_ + =gvars (with-brackets + (spaced parse-type-param)) + _ _space_ + =exceptions (with-brackets + (spaced parse-gclass)) + _ _space_ + =inputs (with-brackets + (spaced parse-arg-decl)) + _ _space_ + =output parse-gclass] + (return (&/$AbstractMethodSyntax (&/T [=name =privacy-modifier =anns =gvars =exceptions =inputs =output]))))) + +(def ^:private parse-method-native-def + (|do [_ (&reader/read-text "native") + _ _space_ + =name parse-name + _ _space_ + =privacy-modifier parse-privacy-modifier + _ _space_ + =anns (with-brackets + (spaced parse-ann)) + _ _space_ + =gvars (with-brackets + (spaced parse-type-param)) + _ _space_ + =exceptions (with-brackets + (spaced parse-gclass)) + _ _space_ + =inputs (with-brackets + (spaced parse-arg-decl)) + _ _space_ + =output parse-gclass] + (return (&/$NativeMethodSyntax (&/T [=name =privacy-modifier =anns =gvars =exceptions =inputs =output]))))) + +(def ^:private parse-method-def + (with-parens + (&/try-all% (&/|list parse-method-init-def + parse-method-virtual-def + parse-method-override-def + parse-method-static-def + parse-method-abstract-def + parse-method-native-def + )))) + +(def ^:private parse-field + (with-parens + (&/try-all% (&/|list (|do [_ (&reader/read-text "constant") + _ _space_ + =name parse-name + _ _space_ + =anns (with-brackets + (spaced parse-ann)) + _ _space_ + =type parse-gclass + _ _space_ + (&/$Cons =value (&/$Nil)) &parser/parse] + (return (&/$ConstantFieldSyntax =name =anns =type =value))) + + (|do [_ (&reader/read-text "variable") + _ _space_ + =name parse-name + _ _space_ + =privacy-modifier parse-privacy-modifier + _ _space_ + =state-modifier parse-state-modifier + _ _space_ + =anns (with-brackets + (spaced parse-ann)) + _ _space_ + =type parse-gclass] + (return (&/$VariableFieldSyntax =name =privacy-modifier =state-modifier =anns =type))) + )))) + +(def parse-interface-def + (|do [=gclass-decl parse-gclass-decl + =supers (with-brackets + (spaced parse-gclass-super)) + =anns (with-brackets + (spaced parse-ann)) + =methods (spaced parse-method-decl)] + (return (&/T [=gclass-decl =supers =anns =methods])))) + +(def parse-class-def + (|do [=gclass-decl parse-gclass-decl + _ _space_ + =super-class parse-gclass-super + _ _space_ + =interfaces (with-brackets + (spaced parse-gclass-super)) + _ _space_ + =inheritance-modifier parse-inheritance-modifier + _ _space_ + =anns (with-brackets + (spaced parse-ann)) + _ _space_ + =fields (with-brackets + (spaced parse-field)) + _ _space_ + =methods (with-brackets + (spaced parse-method-def))] + (return (&/T [=gclass-decl =super-class =interfaces =inheritance-modifier =anns =fields =methods])))) + +(def parse-anon-class-def + (|do [=super-class parse-gclass-super + _ _space_ + =interfaces (with-brackets + (spaced parse-gclass-super)) + _ _space_ + =ctor-args (with-brackets + (spaced parse-ctor-arg)) + _ _space_ + =methods (with-brackets + (spaced parse-method-def))] + (return (&/T [=super-class =interfaces =ctor-args =methods])))) diff --git a/luxc/src/lux/analyser/record.clj b/luxc/src/lux/analyser/record.clj new file mode 100644 index 000000000..81332b34c --- /dev/null +++ b/luxc/src/lux/analyser/record.clj @@ -0,0 +1,47 @@ +;; Copyright (c) Eduardo Julian. All rights reserved. +;; This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +;; If a copy of the MPL was not distributed with this file, +;; You can obtain one at http://mozilla.org/MPL/2.0/. + +(ns lux.analyser.record + (:require clojure.core.match + clojure.core.match.array + (lux [base :as & :refer [|let |do return fail |case]] + [type :as &type]) + (lux.analyser [base :as &&] + [module :as &&module]))) + +;; [Exports] +(defn order-record [pairs] + "(-> (List (, Syntax Syntax)) (Lux (List Syntax)))" + (|do [[tag-group tag-type] (|case pairs + (&/$Nil) + (return (&/T [&/$Nil &/$UnitT])) + + (&/$Cons [[_ (&/$TagS tag1)] _] _) + (|do [[module name] (&&/resolved-ident tag1) + tags (&&module/tag-group module name) + type (&&module/tag-type module name)] + (return (&/T [tags type]))) + + _ + (&/fail-with-loc "[Analyser Error] Wrong syntax for records. Odd elements must be tags.")) + =pairs (&/map% (fn [kv] + (|case kv + [[_ (&/$TagS k)] v] + (|do [=k (&&/resolved-ident k)] + (return (&/T [(&/ident->text =k) v]))) + + _ + (&/fail-with-loc "[Analyser Error] Wrong syntax for records. Odd elements must be tags."))) + pairs) + _ (let [num-expected (&/|length tag-group) + num-got (&/|length =pairs)] + (&/assert! (= num-expected num-got) + (str "[Analyser Error] Wrong number of record members. Expected " num-expected ", but got " num-got "."))) + =members (&/map% (fn [tag] + (if-let [member (&/|get tag =pairs)] + (return member) + (&/fail-with-loc (str "[Analyser Error] Missing tag: " tag)))) + (&/|map &/ident->text tag-group))] + (return (&/T [=members tag-type])))) diff --git a/luxc/src/lux/base.clj b/luxc/src/lux/base.clj new file mode 100644 index 000000000..5697415f8 --- /dev/null +++ b/luxc/src/lux/base.clj @@ -0,0 +1,1449 @@ +;; Copyright (c) Eduardo Julian. All rights reserved. +;; This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +;; If a copy of the MPL was not distributed with this file, +;; You can obtain one at http://mozilla.org/MPL/2.0/. + +(ns lux.base + (:require (clojure [template :refer [do-template]] + [string :as string]) + [clojure.core.match :as M :refer [matchv]] + clojure.core.match.array)) + +;; [Tags] +(def unit-tag (.intern (str (char 0) "unit" (char 0)))) + +(defn T [elems] + (case (count elems) + 0 + unit-tag + + 1 + (first elems) + + ;; else + (to-array elems))) + +(defmacro defvariant [& names] + (assert (> (count names) 1)) + `(do ~@(for [[[name num-params] idx] (map vector names (range (count names))) + :let [last-idx (dec (count names)) + is-last? (if (= idx last-idx) + "" + nil) + def-name (with-meta (symbol (str "$" name)) + {::idx idx + ::is-last? is-last?})]] + (cond (= 0 num-params) + `(def ~def-name + (to-array [(int ~idx) ~is-last? unit-tag])) + + (= 1 num-params) + `(defn ~def-name [arg#] + (to-array [(int ~idx) ~is-last? arg#])) + + :else + (let [g!args (map (fn [_] (gensym "arg")) + (range num-params))] + `(defn ~def-name [~@g!args] + (to-array [(int ~idx) ~is-last? (T [~@g!args])]))) + )))) + +(defmacro deftuple [names] + (assert (vector? names)) + `(do ~@(for [[name idx] (map vector names (range (count names)))] + `(def ~(symbol (str "$" name)) + (int ~idx))))) + +;; List +(defvariant + ("Nil" 0) + ("Cons" 2)) + +;; Maybe +(defvariant + ("None" 0) + ("Some" 1)) + +;; Either +(defvariant + ("Left" 1) + ("Right" 1)) + +;; AST +(defvariant + ("BoolS" 1) + ("NatS" 1) + ("IntS" 1) + ("FracS" 1) + ("RealS" 1) + ("CharS" 1) + ("TextS" 1) + ("SymbolS" 1) + ("TagS" 1) + ("FormS" 1) + ("TupleS" 1) + ("RecordS" 1)) + +;; Type +(defvariant + ("HostT" 2) + ("VoidT" 0) + ("UnitT" 0) + ("SumT" 2) + ("ProdT" 2) + ("LambdaT" 2) + ("BoundT" 1) + ("VarT" 1) + ("ExT" 1) + ("UnivQ" 2) + ("ExQ" 2) + ("AppT" 2) + ("NamedT" 2)) + +;; Vars +(defvariant + ("Local" 1) + ("Global" 1)) + +;; Binding +(deftuple + ["counter" + "mappings"]) + +;; Env +(deftuple + ["name" + "inner-closures" + "locals" + "closure"]) + +;; ModuleState +(defvariant + ("Active" 0) + ("Compiled" 0) + ("Cached" 0)) + +;; Host +(deftuple + ["writer" + "loader" + "classes" + "catching" + "module-states" + "type-env" + "dummy-mappings" + ]) + +;; Compiler +(defvariant + ("Release" 0) + ("Debug" 0) + ("Eval" 0) + ("REPL" 0)) + +(deftuple + ["compiler-name" + "compiler-version" + "compiler-mode"]) + +(deftuple + ["info" + "source" + "cursor" + "modules" + "scopes" + "type-vars" + "expected" + "seed" + "scope-type-vars" + "host"]) + +;; Compiler +(defvariant + ("UpperBound" 0) + ("LowerBound" 0)) + +(defvariant + ("GenericTypeVar" 1) + ("GenericClass" 2) + ("GenericArray" 1) + ("GenericWildcard" 1)) + +;; Privacy Modifiers +(defvariant + ("DefaultPM" 0) + ("PublicPM" 0) + ("PrivatePM" 0) + ("ProtectedPM" 0)) + +;; State Modifiers +(defvariant + ("DefaultSM" 0) + ("VolatileSM" 0) + ("FinalSM" 0)) + +;; Inheritance Modifiers +(defvariant + ("DefaultIM" 0) + ("AbstractIM" 0) + ("FinalIM" 0)) + +;; Fields +(defvariant + ("ConstantFieldSyntax" 4) + ("VariableFieldSyntax" 5)) + +(defvariant + ("ConstantFieldAnalysis" 4) + ("VariableFieldAnalysis" 5)) + +;; Methods +(defvariant + ("ConstructorMethodSyntax" 1) + ("VirtualMethodSyntax" 1) + ("OverridenMethodSyntax" 1) + ("StaticMethodSyntax" 1) + ("AbstractMethodSyntax" 1) + ("NativeMethodSyntax" 1)) + +(defvariant + ("ConstructorMethodAnalysis" 1) + ("VirtualMethodAnalysis" 1) + ("OverridenMethodAnalysis" 1) + ("StaticMethodAnalysis" 1) + ("AbstractMethodAnalysis" 1) + ("NativeMethodAnalysis" 1)) + +;; Meta-data +(defvariant + ("BoolM" 1) + ("NatM" 1) + ("IntM" 1) + ("FracM" 1) + ("RealM" 1) + ("CharM" 1) + ("TextM" 1) + ("IdentM" 1) + ("ListM" 1) + ("DictM" 1)) + +;; [Exports] +(def ^:const name-field "_name") +(def ^:const hash-field "_hash") +(def ^:const value-field "_value") +(def ^:const compiler-field "_compiler") +(def ^:const eval-field "_eval") +(def ^:const module-class-name "_") +(def ^:const +name-separator+ ";") + +(def ^:const ^String compiler-name "Lux/JVM") +(def ^:const ^String compiler-version "0.5.0") + +;; Constructors +(def empty-cursor (T ["" -1 -1])) + +(defn get$ [slot ^objects record] + (aget record slot)) + +(defn set$ [slot value ^objects record] + (doto (aclone ^objects record) + (aset slot value))) + +(defmacro update$ [slot f record] + `(let [record# ~record] + (set$ ~slot (~f (get$ ~slot record#)) + record#))) + +(defn fail* [message] + ($Left message)) + +(defn return* [state value] + ($Right (T [state value]))) + +(defn transform-pattern [pattern] + (cond (vector? pattern) (case (count pattern) + 0 + unit-tag + + 1 + (transform-pattern (first pattern)) + + ;; else + (mapv transform-pattern pattern)) + (seq? pattern) [(if-let [tag-var (ns-resolve *ns* (first pattern))] + (-> tag-var + meta + ::idx) + (assert false (str "Unknown var: " (first pattern)))) + '_ + (transform-pattern (vec (rest pattern)))] + :else pattern + )) + +(defmacro |case [value & branches] + (assert (= 0 (mod (count branches) 2))) + (let [value* (if (vector? value) + [`(T [~@value])] + [value])] + `(matchv ::M/objects ~value* + ~@(mapcat (fn [[pattern body]] + (list [(transform-pattern pattern)] + body)) + (partition 2 branches))))) + +(defmacro |let [bindings body] + (reduce (fn [inner [left right]] + `(|case ~right + ~left + ~inner)) + body + (reverse (partition 2 bindings)))) + +(defmacro |list [& elems] + (reduce (fn [tail head] + `($Cons ~head ~tail)) + `$Nil + (reverse elems))) + +(defmacro |table [& elems] + (reduce (fn [table [k v]] + `(|put ~k ~v ~table)) + `$Nil + (reverse (partition 2 elems)))) + +(defn |get [slot table] + (|case table + ($Nil) + nil + + ($Cons [k v] table*) + (if (.equals ^Object k slot) + v + (recur slot table*)))) + +(defn |put [slot value table] + (|case table + ($Nil) + ($Cons (T [slot value]) $Nil) + + ($Cons [k v] table*) + (if (.equals ^Object k slot) + ($Cons (T [slot value]) table*) + ($Cons (T [k v]) (|put slot value table*))) + )) + +(defn |remove [slot table] + (|case table + ($Nil) + table + + ($Cons [k v] table*) + (if (.equals ^Object k slot) + table* + ($Cons (T [k v]) (|remove slot table*))))) + +(defn |update [k f table] + (|case table + ($Nil) + table + + ($Cons [k* v] table*) + (if (.equals ^Object k k*) + ($Cons (T [k* (f v)]) table*) + ($Cons (T [k* v]) (|update k f table*))))) + +(defn |head [xs] + (|case xs + ($Nil) + (assert false (prn-str '|head)) + + ($Cons x _) + x)) + +(defn |tail [xs] + (|case xs + ($Nil) + (assert false (prn-str '|tail)) + + ($Cons _ xs*) + xs*)) + +;; [Resources/Monads] +(defn fail [message] + (fn [_] + ($Left message))) + +(defn return [value] + (fn [state] + ($Right (T [state value])))) + +(defn bind [m-value step] + (fn [state] + (let [inputs (m-value state)] + (|case inputs + ($Right ?state ?datum) + ((step ?datum) ?state) + + ($Left _) + inputs + )))) + +(defmacro |do [steps return] + (assert (= 0 (rem (count steps) 2)) "The number of steps must be even!") + (reduce (fn [inner [label computation]] + (case label + :let `(|let ~computation ~inner) + ;; else + `(bind ~computation + (fn [val#] + (|case val# + ~label + ~inner))))) + return + (reverse (partition 2 steps)))) + +;; [Resources/Combinators] +(let [array-class (class (to-array []))] + (defn adt->text [adt] + (if (= array-class (class adt)) + (str "[" (->> adt (map adt->text) (interpose " ") (reduce str "")) "]") + (pr-str adt)))) + +(defn |++ [xs ys] + (|case xs + ($Nil) + ys + + ($Cons x xs*) + ($Cons x (|++ xs* ys)))) + +(defn |map [f xs] + (|case xs + ($Nil) + xs + + ($Cons x xs*) + ($Cons (f x) (|map f xs*)) + + _ + (assert false (prn-str '|map f (adt->text xs))))) + +(defn |empty? [xs] + "(All [a] (-> (List a) Bool))" + (|case xs + ($Nil) + true + + ($Cons _ _) + false)) + +(defn |filter [p xs] + "(All [a] (-> (-> a Bool) (List a) (List a)))" + (|case xs + ($Nil) + xs + + ($Cons x xs*) + (if (p x) + ($Cons x (|filter p xs*)) + (|filter p xs*)))) + +(defn flat-map [f xs] + "(All [a b] (-> (-> a (List b)) (List a) (List b)))" + (|case xs + ($Nil) + xs + + ($Cons x xs*) + (|++ (f x) (flat-map f xs*)))) + +(defn |split-with [p xs] + (|case xs + ($Nil) + (T [xs xs]) + + ($Cons x xs*) + (if (p x) + (|let [[pre post] (|split-with p xs*)] + (T [($Cons x pre) post])) + (T [$Nil xs])))) + +(defn |contains? [k table] + (|case table + ($Nil) + false + + ($Cons [k* _] table*) + (or (.equals ^Object k k*) + (|contains? k table*)))) + +(defn |member? [x xs] + (|case xs + ($Nil) + false + + ($Cons x* xs*) + (or (= x x*) (|member? x xs*)))) + +(defn fold [f init xs] + (|case xs + ($Nil) + init + + ($Cons x xs*) + (recur f (f init x) xs*))) + +(defn fold% [f init xs] + (|case xs + ($Nil) + (return init) + + ($Cons x xs*) + (|do [init* (f init x)] + (fold% f init* xs*)))) + +(defn folds [f init xs] + (|case xs + ($Nil) + (|list init) + + ($Cons x xs*) + ($Cons init (folds f (f init x) xs*)))) + +(defn |length [xs] + (fold (fn [acc _] (inc acc)) 0 xs)) + +(defn |range* [from to] + (if (<= from to) + ($Cons from (|range* (inc from) to)) + $Nil)) + +(let [|range* (fn |range* [from to] + (if (< from to) + ($Cons from (|range* (inc from) to)) + $Nil))] + (defn |range [n] + (|range* 0 n))) + +(defn |first [pair] + (|let [[_1 _2] pair] + _1)) + +(defn |second [pair] + (|let [[_1 _2] pair] + _2)) + +(defn zip2 [xs ys] + (|case [xs ys] + [($Cons x xs*) ($Cons y ys*)] + ($Cons (T [x y]) (zip2 xs* ys*)) + + [_ _] + $Nil)) + +(defn |keys [plist] + (|case plist + ($Nil) + $Nil + + ($Cons [k v] plist*) + ($Cons k (|keys plist*)))) + +(defn |vals [plist] + (|case plist + ($Nil) + $Nil + + ($Cons [k v] plist*) + ($Cons v (|vals plist*)))) + +(defn |interpose [sep xs] + (|case xs + ($Nil) + xs + + ($Cons _ ($Nil)) + xs + + ($Cons x xs*) + ($Cons x ($Cons sep (|interpose sep xs*))))) + +(do-template [<name> <joiner>] + (defn <name> [f xs] + (|case xs + ($Nil) + (return xs) + + ($Cons x xs*) + (|do [y (f x) + ys (<name> f xs*)] + (return (<joiner> y ys))))) + + map% $Cons + flat-map% |++) + +(defn list-join [xss] + (fold |++ $Nil xss)) + +(defn |as-pairs [xs] + (|case xs + ($Cons x ($Cons y xs*)) + ($Cons (T [x y]) (|as-pairs xs*)) + + _ + $Nil)) + +(defn |reverse [xs] + (fold (fn [tail head] + ($Cons head tail)) + $Nil + xs)) + +(defn add-loc [meta ^String msg] + (if (.startsWith msg "@") + msg + (|let [[file line col] meta] + (str "@ " file "," line "," col "\n" msg)))) + +(defn fail-with-loc [msg] + (fn [state] + (fail* (add-loc (get$ $cursor state) msg)))) + +(defn assert! [test message] + (if test + (return unit-tag) + (fail-with-loc message))) + +(def get-state + (fn [state] + (return* state state))) + +(defn try-all% [monads] + (|case monads + ($Nil) + (fail "There are no alternatives to try!") + + ($Cons m monads*) + (fn [state] + (let [output (m state)] + (|case [output monads*] + [($Right _) _] + output + + [_ ($Nil)] + output + + [_ _] + ((try-all% monads*) state) + ))) + )) + +(defn try-all-% [prefix monads] + (|case monads + ($Nil) + (fail "There are no alternatives to try!") + + ($Cons m monads*) + (fn [state] + (let [output (m state)] + (|case [output monads*] + [($Right _) _] + output + + [_ ($Nil)] + output + + [($Left ^String error) _] + (if (.contains error prefix) + ((try-all-% prefix monads*) state) + output) + ))) + )) + +(defn exhaust% [step] + (fn [state] + (|case (step state) + ($Right state* _) + ((exhaust% step) state*) + + ($Left msg) + (if (.equals "[Reader Error] EOF" msg) + (return* state unit-tag) + (fail* msg))))) + +(defn ^:private normalize-char [char] + (case char + \* "_ASTER_" + \+ "_PLUS_" + \- "_DASH_" + \/ "_SLASH_" + \\ "_BSLASH_" + \_ "_UNDERS_" + \% "_PERCENT_" + \$ "_DOLLAR_" + \' "_QUOTE_" + \` "_BQUOTE_" + \@ "_AT_" + \^ "_CARET_" + \& "_AMPERS_" + \= "_EQ_" + \! "_BANG_" + \? "_QM_" + \: "_COLON_" + \. "_PERIOD_" + \, "_COMMA_" + \< "_LT_" + \> "_GT_" + \~ "_TILDE_" + \| "_PIPE_" + ;; default + char)) + +(defn normalize-name [ident] + (reduce str "" (map normalize-char ident))) + +(def classes + (fn [state] + (return* state (->> state (get$ $host) (get$ $classes))))) + +(def +init-bindings+ + (T [;; "lux;counter" + 0 + ;; "lux;mappings" + (|table)])) + +(defn env [name old-name] + (T [;; "lux;name" + ($Cons name old-name) + ;; "lux;inner-closures" + 0 + ;; "lux;locals" + +init-bindings+ + ;; "lux;closure" + +init-bindings+] + )) + +(let [define-class (doto (.getDeclaredMethod java.lang.ClassLoader "defineClass" (into-array [String + (class (byte-array [])) + Integer/TYPE + Integer/TYPE])) + (.setAccessible true))] + (defn memory-class-loader [store] + (proxy [java.lang.ClassLoader] + [] + (findClass [^String class-name] + (if-let [^bytes bytecode (get @store class-name)] + (.invoke define-class this (to-array [class-name bytecode (int 0) (int (alength bytecode))])) + (throw (IllegalStateException. (str "[Class Loader] Unknown class: " class-name)))))))) + +(def loader + (fn [state] + (return* state (->> state (get$ $host) (get$ $loader))))) + +(defn host [_] + (let [store (atom {})] + (T [;; "lux;writer" + $None + ;; "lux;loader" + (memory-class-loader store) + ;; "lux;classes" + store + ;; "lux;catching" + $Nil + ;; "lux;module-states" + (|table) + ;; lux;type-env + (|table) + ;; lux;dummy-mappings + (|table) + ]))) + +(defn with-no-catches [body] + "(All [a] (-> (Lux a) (Lux a)))" + (fn [state] + (let [old-catching (->> state (get$ $host) (get$ $catching))] + (|case (body (update$ $host #(set$ $catching $Nil %) state)) + ($Right state* output) + (return* (update$ $host #(set$ $catching old-catching %) state*) output) + + ($Left msg) + (fail* msg))))) + +(defn default-compiler-info [mode] + (T [;; compiler-name + compiler-name + ;; compiler-version + compiler-version + ;; compiler-mode + mode] + )) + +(defn init-state [mode] + (T [;; "lux;info" + (default-compiler-info mode) + ;; "lux;source" + $Nil + ;; "lux;cursor" + (T ["" -1 -1]) + ;; "lux;modules" + (|table) + ;; "lux;scopes" + $Nil + ;; "lux;types" + +init-bindings+ + ;; "lux;expected" + $None + ;; "lux;seed" + 0 + ;; scope-type-vars + $Nil + ;; "lux;host" + (host nil)] + )) + +(defn save-module [body] + (fn [state] + (|case (body state) + ($Right state* output) + (return* (->> state* + (set$ $scopes (get$ $scopes state)) + (set$ $source (get$ $source state))) + output) + + ($Left msg) + (fail* msg)))) + +(defn in-eval? [mode] + "(-> CompilerMode Bool)" + (|case mode + ($Eval) true + _ false)) + +(defn in-repl? [mode] + "(-> CompilerMode Bool)" + (|case mode + ($REPL) true + _ false)) + +(defn with-eval [body] + (fn [state] + (let [old-mode (->> state (get$ $info) (get$ $compiler-mode))] + (|case (body (update$ $info #(set$ $compiler-mode $Eval %) state)) + ($Right state* output) + (return* (update$ $info #(set$ $compiler-mode old-mode %) state*) output) + + ($Left msg) + (fail* msg))))) + +(def get-eval + (fn [state] + (return* state (->> state (get$ $info) (get$ $compiler-mode) in-eval?)))) + +(def get-mode + (fn [state] + (return* state (->> state (get$ $info) (get$ $compiler-mode))))) + +(def get-writer + (fn [state] + (let [writer* (->> state (get$ $host) (get$ $writer))] + (|case writer* + ($Some datum) + (return* state datum) + + _ + ((fail-with-loc "Writer hasn't been set.") state))))) + +(def get-top-local-env + (fn [state] + (try (let [top (|head (get$ $scopes state))] + (return* state top)) + (catch Throwable _ + ((fail-with-loc "No local environment.") state))))) + +(def gen-id + (fn [state] + (let [seed (get$ $seed state)] + (return* (set$ $seed (inc seed) state) seed)))) + +(defn ->seq [xs] + (|case xs + ($Nil) + (list) + + ($Cons x xs*) + (cons x (->seq xs*)))) + +(defn ->list [seq] + (if (empty? seq) + $Nil + ($Cons (first seq) (->list (rest seq))))) + +(defn |repeat [n x] + (if (> n 0) + ($Cons x (|repeat (dec n) x)) + $Nil)) + +(def get-module-name + (fn [state] + (|case (|reverse (get$ $scopes state)) + ($Nil) + ((fail-with-loc "[Analyser Error] Can't get the module-name without a module.") state) + + ($Cons ?global _) + (return* state (|head (get$ $name ?global)))))) + +(defn find-module [name] + "(-> Text (Lux (Module Compiler)))" + (fn [state] + (if-let [module (|get name (get$ $modules state))] + (return* state module) + ((fail-with-loc (str "[Error] Unknown module: " name)) state)))) + +(def get-current-module + "(Lux (Module Compiler))" + (|do [module-name get-module-name] + (find-module module-name))) + +(defn with-scope [name body] + (fn [state] + (let [old-name (->> state (get$ $scopes) |head (get$ $name)) + output (body (update$ $scopes #($Cons (env name old-name) %) state))] + (|case output + ($Right state* datum) + (return* (update$ $scopes |tail state*) datum) + + _ + output)))) + +(defn run-state [monad state] + (monad state)) + +(defn with-closure [body] + (|do [closure-name (|do [top get-top-local-env] + (return (->> top (get$ $inner-closures) str)))] + (fn [state] + (let [body* (with-scope closure-name body)] + (run-state body* (update$ $scopes #($Cons (update$ $inner-closures inc (|head %)) + (|tail %)) + state)))))) + +(defn without-repl-closure [body] + (|do [_mode get-mode] + (fn [state] + (let [output (body (if (in-repl? _mode) + (update$ $scopes |tail state) + state))] + (|case output + ($Right state* datum) + (return* (set$ $scopes (get$ $scopes state) state*) datum) + + _ + output))))) + +(defn without-repl [body] + (|do [_mode get-mode] + (fn [state] + (let [output (body (if (in-repl? _mode) + (update$ $info #(set$ $compiler-mode $Debug %) state) + state))] + (|case output + ($Right state* datum) + (return* (update$ $info #(set$ $compiler-mode _mode %) state*) datum) + + _ + output))))) + +(def get-scope-name + (fn [state] + (return* state (->> state (get$ $scopes) |head (get$ $name))))) + +(defn with-writer [writer body] + (fn [state] + (let [old-writer (->> state (get$ $host) (get$ $writer)) + output (body (update$ $host #(set$ $writer ($Some writer) %) state))] + (|case output + ($Right ?state ?value) + (return* (update$ $host #(set$ $writer old-writer %) ?state) + ?value) + + _ + output)))) + +(defn with-expected-type [type body] + "(All [a] (-> Type (Lux a)))" + (fn [state] + (let [output (body (set$ $expected ($Some type) state))] + (|case output + ($Right ?state ?value) + (return* (set$ $expected (get$ $expected state) ?state) + ?value) + + _ + output)))) + +(defn with-cursor [^objects cursor body] + "(All [a] (-> Cursor (Lux a)))" + (|let [[_file-name _ _] cursor] + (if (= "" _file-name) + body + (fn [state] + (let [output (body (set$ $cursor cursor state))] + (|case output + ($Right ?state ?value) + (return* (set$ $cursor (get$ $cursor state) ?state) + ?value) + + _ + output)))))) + +(defn with-analysis-meta [^objects cursor type body] + "(All [a] (-> Cursor Type (Lux a)))" + (|let [[_file-name _ _] cursor] + (if (= "" _file-name) + (fn [state] + (let [output (body (->> state + (set$ $expected ($Some type))))] + (|case output + ($Right ?state ?value) + (return* (->> ?state + (set$ $expected (get$ $expected state))) + ?value) + + _ + output))) + (fn [state] + (let [output (body (->> state + (set$ $cursor cursor) + (set$ $expected ($Some type))))] + (|case output + ($Right ?state ?value) + (return* (->> ?state + (set$ $cursor (get$ $cursor state)) + (set$ $expected (get$ $expected state))) + ?value) + + _ + output)))))) + +(def ensure-statement + "(Lux Unit)" + (fn [state] + (|case (get$ $expected state) + ($None) + (return* state unit-tag) + + ($Some _) + ((fail-with-loc "[Error] All statements must be top-level forms.") state)))) + +(def cursor + ;; (Lux Cursor) + (fn [state] + (return* state (get$ $cursor state)))) + +(let [remove-trailing-0s (fn [^String input] + (-> input + (.split "0*$") + (aget 0))) + make-text-start-0 (fn [input] + (loop [accum "" + range 10] + (if (< input range) + (recur (.concat accum "0") + (* 10 range)) + accum))) + count-bin-start-0 (fn [input] + (loop [counter 0 + idx 63] + (if (and (> idx -1) + (not (bit-test input idx))) + (recur (inc counter) + (dec idx)) + counter))) + read-frac-text (fn [^String input] + (let [output* (.split input "0*$")] + (if (= 0 (alength output*)) + (Long/parseUnsignedLong (aget output* 0)) + (Long/parseUnsignedLong input)))) + count-leading-0s (fn [^String input] + (let [parts (.split input "^0*")] + (if (= 2 (alength parts)) + (.length ^String (aget parts 0)) + 0)))] + (defn encode-frac [input] + (if (= 0 input) + ".0" + (let [^String prefix (->> (count-bin-start-0 input) + (bit-shift-left 1) + (make-text-start-0))] + (->> input + (Long/toUnsignedString) + remove-trailing-0s + (.concat prefix))))) + + (defn decode-frac [input] + (if-let [[_ frac-text] (re-find #"^\.(.+)$" input)] + (let [output* (-> frac-text + (string/replace #",_" "") + read-frac-text) + rows-to-move-forward (count-bin-start-0 output*) + scaling-factor (long (Math/pow 10.0 (double (count-leading-0s input))))] + (-> output* + (bit-shift-left rows-to-move-forward) + (/ scaling-factor))) + (assert false (str "Invalid Frac syntax: " input)))) + ) + +(defn show-ast [ast] + (|case ast + [_ ($BoolS ?value)] + (pr-str ?value) + + [_ ($NatS ?value)] + (str "+" (Long/toUnsignedString ?value)) + + [_ ($IntS ?value)] + (pr-str ?value) + + [_ ($FracS ?value)] + (encode-frac ?value) + + [_ ($RealS ?value)] + (pr-str ?value) + + [_ ($CharS ?value)] + (str "#\"" (pr-str ?value) "\"") + + [_ ($TextS ?value)] + (str "\"" ?value "\"") + + [_ ($TagS ?module ?tag)] + (if (.equals "" ?module) + (str "#" ?tag) + (str "#" ?module ";" ?tag)) + + [_ ($SymbolS ?module ?name)] + (if (.equals "" ?module) + ?name + (str ?module ";" ?name)) + + [_ ($TupleS ?elems)] + (str "[" (->> ?elems (|map show-ast) (|interpose " ") (fold str "")) "]") + + [_ ($RecordS ?elems)] + (str "{" (->> ?elems + (|map (fn [elem] + (|let [[k v] elem] + (str (show-ast k) " " (show-ast v))))) + (|interpose " ") (fold str "")) "}") + + [_ ($FormS ?elems)] + (str "(" (->> ?elems (|map show-ast) (|interpose " ") (fold str "")) ")") + + _ + (assert false (prn-str 'show-ast (adt->text ast))) + )) + +(defn ident->text [ident] + (|let [[?module ?name] ident] + (if (= "" ?module) + ?name + (str ?module ";" ?name)))) + +(defn fold2% [f init xs ys] + (|case [xs ys] + [($Cons x xs*) ($Cons y ys*)] + (|do [init* (f init x y)] + (fold2% f init* xs* ys*)) + + [($Nil) ($Nil)] + (return init) + + [_ _] + (assert false "Lists don't match in size."))) + +(defn map2% [f xs ys] + (|case [xs ys] + [($Cons x xs*) ($Cons y ys*)] + (|do [z (f x y) + zs (map2% f xs* ys*)] + (return ($Cons z zs))) + + [($Nil) ($Nil)] + (return $Nil) + + [_ _] + (assert false "Lists don't match in size."))) + +(defn map2 [f xs ys] + (|case [xs ys] + [($Cons x xs*) ($Cons y ys*)] + ($Cons (f x y) (map2 f xs* ys*)) + + [_ _] + $Nil)) + +(defn fold2 [f init xs ys] + (|case [xs ys] + [($Cons x xs*) ($Cons y ys*)] + (and init + (fold2 f (f init x y) xs* ys*)) + + [($Nil) ($Nil)] + init + + [_ _] + init + ;; (assert false) + )) + +(defn ^:private enumerate* [idx xs] + "(All [a] (-> Int (List a) (List (, Int a))))" + (|case xs + ($Cons x xs*) + ($Cons (T [idx x]) + (enumerate* (inc idx) xs*)) + + ($Nil) + xs + )) + +(defn enumerate [xs] + "(All [a] (-> (List a) (List (, Int a))))" + (enumerate* 0 xs)) + +(def modules + "(Lux (List Text))" + (fn [state] + (return* state (|keys (get$ $modules state))))) + +(defn when% [test body] + "(-> Bool (Lux Unit) (Lux Unit))" + (if test + body + (return unit-tag))) + +(defn |at [idx xs] + "(All [a] (-> Int (List a) (Maybe a)))" + (|case xs + ($Cons x xs*) + (cond (< idx 0) + $None + + (= idx 0) + ($Some x) + + :else ;; > 1 + (|at (dec idx) xs*)) + + ($Nil) + $None + )) + +(defn normalize [ident] + "(-> Ident (Lux Ident))" + (|case ident + ["" name] (|do [module get-module-name] + (return (T [module name]))) + _ (return ident))) + +(defn ident= [x y] + (|let [[xmodule xname] x + [ymodule yname] y] + (and (= xmodule ymodule) + (= xname yname)))) + +(defn |list-put [idx val xs] + (|case xs + ($Nil) + $None + + ($Cons x xs*) + (if (= idx 0) + ($Some ($Cons val xs*)) + (|case (|list-put (dec idx) val xs*) + ($None) $None + ($Some xs**) ($Some ($Cons x xs**))) + ))) + +(do-template [<flagger> <asker> <tag>] + (do (defn <flagger> [module] + "(-> Text (Lux Unit))" + (fn [state] + (let [state* (update$ $host (fn [host] + (update$ $module-states + (fn [module-states] + (|put module <tag> module-states)) + host)) + state)] + ($Right (T [state* unit-tag]))))) + (defn <asker> [module] + "(-> Text (Lux Bool))" + (fn [state] + (if-let [module-state (->> state (get$ $host) (get$ $module-states) (|get module))] + ($Right (T [state (|case module-state + (<tag>) true + _ false)])) + ($Right (T [state false]))) + ))) + + flag-active-module active-module? $Active + flag-compiled-module compiled-module? $Compiled + flag-cached-module cached-module? $Cached + ) + +(do-template [<name> <default> <op>] + (defn <name> [p xs] + "(All [a] (-> (-> a Bool) (List a) Bool))" + (|case xs + ($Nil) + <default> + + ($Cons x xs*) + (<op> (p x) (<name> p xs*)))) + + |every? true and + |any? false or) + +(defn m-comp [f g] + "(All [a b c] (-> (-> b (Lux c)) (-> a (Lux b)) (-> a (Lux c))))" + (fn [x] + (|do [y (g x)] + (f y)))) + +(defn with-attempt [m-value on-error] + "(All [a] (-> (Lux a) (-> Text (Lux a)) (Lux a)))" + (fn [state] + (|case (m-value state) + ($Left msg) + ((on-error msg) state) + + output + output))) + +(defn |some [f xs] + "(All [a b] (-> (-> a (Maybe b)) (List a) (Maybe b)))" + (|case xs + ($Nil) + $None + + ($Cons x xs*) + (|case (f x) + ($None) (|some f xs*) + output output) + )) + +(def get-type-env + "(Lux TypeEnv)" + (fn [state] + (return* state (->> state (get$ $host) (get$ $type-env))))) + +(defn with-type-env [type-env body] + "(All [a] (-> TypeEnv (Lux a) (Lux a)))" + (fn [state] + (|let [state* (update$ $host #(update$ $type-env (partial |++ type-env) %) + state)] + (|case (body state*) + ($Right [state** output]) + ($Right (T [(update$ $host + #(set$ $type-env + (->> state (get$ $host) (get$ $type-env)) + %) + state**) + output])) + + ($Left msg) + ($Left msg))))) + +(defn |take [n xs] + (|case (T [n xs]) + [0 _] $Nil + [_ ($Nil)] $Nil + [_ ($Cons x xs*)] ($Cons x (|take (dec n) xs*)) + )) + +(defn |drop [n xs] + (|case (T [n xs]) + [0 _] xs + [_ ($Nil)] $Nil + [_ ($Cons x xs*)] (|drop (dec n) xs*) + )) + +(defn |but-last [xs] + (|case xs + ($Nil) + $Nil + + ($Cons x ($Nil)) + $Nil + + ($Cons x xs*) + ($Cons x (|but-last xs*)) + + _ + (assert false (adt->text xs)))) + +(defn |last [xs] + (|case xs + ($Cons x ($Nil)) + x + + ($Cons x xs*) + (|last xs*) + + _ + (assert false (adt->text xs)))) + +(defn |partition [n xs] + (->> xs ->seq (partition-all n) (map ->list) ->list)) + +(defn with-scope-type-var [id body] + (fn [state] + (|case (body (set$ $scope-type-vars + ($Cons id (get$ $scope-type-vars state)) + state)) + ($Right [state* output]) + ($Right (T [(set$ $scope-type-vars + (get$ $scope-type-vars state) + state*) + output])) + + ($Left msg) + ($Left msg)))) + +(defn push-dummy-name [real-name store-name] + (fn [state] + ($Right (T [(update$ $host + #(update$ $dummy-mappings + (partial $Cons (T [real-name store-name])) + %) + state) + nil])))) + +(def pop-dummy-name + (fn [state] + ($Right (T [(update$ $host + #(update$ $dummy-mappings + |tail + %) + state) + nil])))) + +(defn de-alias-class [class-name] + (fn [state] + ($Right (T [state + (|case (|some #(|let [[real-name store-name] %] + (if (= real-name class-name) + ($Some store-name) + $None)) + (->> state (get$ $host) (get$ $dummy-mappings))) + ($Some store-name) + store-name + + _ + class-name)])))) + +(let [!out! *out*] + (defn |log! [& parts] + (binding [*out* !out!] + (do (print (apply str parts)) + (flush))))) diff --git a/luxc/src/lux/compiler.clj b/luxc/src/lux/compiler.clj new file mode 100644 index 000000000..d8c5e4571 --- /dev/null +++ b/luxc/src/lux/compiler.clj @@ -0,0 +1,268 @@ +;; Copyright (c) Eduardo Julian. All rights reserved. +;; This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +;; If a copy of the MPL was not distributed with this file, +;; You can obtain one at http://mozilla.org/MPL/2.0/. + +(ns lux.compiler + (:refer-clojure :exclude [compile]) + (:require (clojure [string :as string] + [set :as set] + [template :refer [do-template]]) + clojure.core.match + clojure.core.match.array + (lux [base :as & :refer [|let |do return* return fail fail* |case]] + [type :as &type] + [reader :as &reader] + [lexer :as &lexer] + [parser :as &parser] + [analyser :as &analyser] + [optimizer :as &optimizer] + [host :as &host]) + [lux.host.generics :as &host-generics] + [lux.optimizer :as &o] + [lux.analyser.base :as &a] + [lux.analyser.module :as &a-module] + (lux.compiler [base :as &&] + [cache :as &&cache] + [lux :as &&lux] + [host :as &&host] + [case :as &&case] + [lambda :as &&lambda] + [module :as &&module] + [io :as &&io] + [parallel :as &¶llel]) + (lux.compiler.cache [type :as &&&type] + [ann :as &&&ann])) + (:import (org.objectweb.asm Opcodes + Label + ClassWriter + MethodVisitor))) + +;; [Resources] +(def ^:private !source->last-line (atom nil)) + +(defn compile-expression [$begin syntax] + (|let [[[?type [_file-name _line _]] ?form] syntax] + (|do [^MethodVisitor *writer* &/get-writer + :let [debug-label (new Label) + _ (when (not= _line (get @!source->last-line _file-name)) + (doto *writer* + (.visitLabel debug-label) + (.visitLineNumber (int _line) debug-label)) + (swap! !source->last-line assoc _file-name _line))]] + (|case ?form + (&o/$bool ?value) + (&&lux/compile-bool ?value) + + (&o/$nat ?value) + (&&lux/compile-nat ?value) + + (&o/$int ?value) + (&&lux/compile-int ?value) + + (&o/$frac ?value) + (&&lux/compile-frac ?value) + + (&o/$real ?value) + (&&lux/compile-real ?value) + + (&o/$char ?value) + (&&lux/compile-char ?value) + + (&o/$text ?value) + (&&lux/compile-text ?value) + + (&o/$tuple ?elems) + (&&lux/compile-tuple (partial compile-expression $begin) ?elems) + + (&o/$var (&/$Local ?idx)) + (&&lux/compile-local (partial compile-expression $begin) ?idx) + + (&o/$captured ?scope ?captured-id ?source) + (&&lux/compile-captured (partial compile-expression $begin) ?scope ?captured-id ?source) + + (&o/$var (&/$Global ?owner-class ?name)) + (&&lux/compile-global (partial compile-expression $begin) ?owner-class ?name) + + (&o/$apply ?fn ?args) + (&&lux/compile-apply (partial compile-expression $begin) ?fn ?args) + + (&o/$loop _register-offset _inits _body) + (&&lux/compile-loop compile-expression _register-offset _inits _body) + + (&o/$iter _register-offset ?args) + (&&lux/compile-iter (partial compile-expression $begin) $begin _register-offset ?args) + + (&o/$variant ?tag ?tail ?members) + (&&lux/compile-variant (partial compile-expression $begin) ?tag ?tail ?members) + + (&o/$case ?value [?pm ?bodies]) + (&&case/compile-case (partial compile-expression $begin) ?value ?pm ?bodies) + + (&o/$let _value _register _body) + (&&lux/compile-let (partial compile-expression $begin) _value _register _body) + + (&o/$record-get _value _path) + (&&lux/compile-record-get (partial compile-expression $begin) _value _path) + + (&o/$if _test _then _else) + (&&lux/compile-if (partial compile-expression $begin) _test _then _else) + + (&o/$function _register-offset ?arity ?scope ?env ?body) + (&&lambda/compile-function compile-expression &/$None ?arity ?scope ?env ?body) + + (&o/$ann ?value-ex ?type-ex) + (compile-expression $begin ?value-ex) + + (&o/$proc [?proc-category ?proc-name] ?args special-args) + (&&host/compile-host (partial compile-expression $begin) ?proc-category ?proc-name ?args special-args) + + _ + (assert false (prn-str 'compile-expression (&/adt->text syntax))) + )) + )) + +(defn init! + "(-> (List Text) Null)" + [resources-dirs target-dir] + (do (reset! &&/!output-dir target-dir) + (&¶llel/setup!) + (reset! !source->last-line {}) + (.mkdirs (java.io.File. target-dir)) + (let [class-loader (ClassLoader/getSystemClassLoader) + addURL (doto (.getDeclaredMethod java.net.URLClassLoader "addURL" (into-array [java.net.URL])) + (.setAccessible true))] + (doseq [resources-dir (&/->seq resources-dirs)] + (.invoke addURL class-loader + (to-array [(->> resources-dir (new java.io.File) .toURI .toURL)])))))) + +(defn eval! [expr] + (&/with-eval + (|do [module &/get-module-name + id &/gen-id + [file-name _ _] &/cursor + :let [class-name (str (&host/->module-class module) "/" id) + =class (doto (new ClassWriter ClassWriter/COMPUTE_MAXS) + (.visit &host/bytecode-version (+ Opcodes/ACC_PUBLIC Opcodes/ACC_SUPER) + class-name nil "java/lang/Object" nil) + (-> (.visitField (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_STATIC) &/eval-field "Ljava/lang/Object;" nil nil) + (doto (.visitEnd))) + (.visitSource file-name nil))] + _ (&/with-writer (.visitMethod =class Opcodes/ACC_STATIC "<clinit>" "()V" nil nil) + (|do [^MethodVisitor *writer* &/get-writer + :let [_ (.visitCode *writer*)] + _ (compile-expression nil expr) + :let [_ (doto *writer* + (.visitFieldInsn Opcodes/PUTSTATIC class-name &/eval-field "Ljava/lang/Object;") + (.visitInsn Opcodes/RETURN) + (.visitMaxs 0 0) + (.visitEnd))]] + (return nil))) + :let [bytecode (.toByteArray (doto =class + .visitEnd))] + _ (&&/save-class! (str id) bytecode) + loader &/loader] + (-> (.loadClass ^ClassLoader loader (str (&host-generics/->class-name module) "." id)) + (.getField &/eval-field) + (.get nil) + return)))) + +(def all-compilers + (let [compile-expression* (partial compile-expression nil)] + (&/T [(partial &&lux/compile-def compile-expression) + (partial &&lux/compile-program compile-expression*) + (partial &&host/compile-jvm-class compile-expression*) + &&host/compile-jvm-interface]))) + +(let [+field-flags+ (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_STATIC) + +datum-sig+ "Ljava/lang/Object;"] + (defn compile-module [source-dirs name] + (let [file-name (str name ".lux")] + (|do [file-content (&&io/read-file source-dirs file-name) + :let [file-hash (hash file-content) + ;; compile-module!! (&¶llel/parallel-compilation (partial compile-module source-dirs)) + compile-module!! (partial compile-module source-dirs)]] + (if (&&cache/cached? name) + (&&cache/load source-dirs name file-hash compile-module!!) + (let [compiler-step (&analyser/analyse &optimizer/optimize eval! compile-module!! all-compilers)] + (|do [module-exists? (&a-module/exists? name)] + (if module-exists? + (fail "[Compiler Error] Can't redefine a module!") + (|do [_ (&&cache/delete name) + _ (&a-module/create-module name file-hash) + _ (&/flag-active-module name) + :let [module-class-name (str (&host/->module-class name) "/_") + =class (doto (new ClassWriter ClassWriter/COMPUTE_MAXS) + (.visit &host/bytecode-version (+ Opcodes/ACC_PUBLIC Opcodes/ACC_SUPER) + module-class-name nil "java/lang/Object" nil) + (-> (.visitField +field-flags+ &/hash-field "I" nil file-hash) + .visitEnd) + (-> (.visitField +field-flags+ &/compiler-field "Ljava/lang/String;" nil &/compiler-version) + .visitEnd) + (.visitSource file-name nil))] + _ (if (= "lux" name) + (|do [_ &&host/compile-Function-class + _ &&host/compile-LuxRT-class] + (return nil)) + (return nil))] + (fn [state] + (|case ((&/with-writer =class + (&/exhaust% compiler-step)) + (&/set$ &/$source (&reader/from name file-content) state)) + (&/$Right ?state _) + (&/run-state (|do [:let [_ (.visitEnd =class)] + module-anns (&a-module/get-anns name) + defs &a-module/defs + imports &a-module/imports + tag-groups &&module/tag-groups + :let [def-entries (->> defs + (&/|map (fn [_def] + (|let [[?name ?alias [?def-type ?def-anns ?def-value]] _def] + (if (= "" ?alias) + (str ?name &&/datum-separator (&&&type/serialize-type ?def-type) &&/datum-separator (&&&ann/serialize-anns ?def-anns)) + (str ?name &&/datum-separator ?alias))))) + (&/|interpose &&/entry-separator) + (&/fold str "")) + import-entries (->> imports + (&/|map (fn [import] + (|let [[_module _hash] import] + (str _module &&/datum-separator _hash)))) + (&/|interpose &&/entry-separator) + (&/fold str "")) + tag-entries (->> tag-groups + (&/|map (fn [group] + (|let [[type tags] group] + (->> tags + (&/|interpose &&/datum-separator) + (&/fold str "") + (str type &&/datum-separator))))) + (&/|interpose &&/entry-separator) + (&/fold str "")) + module-descriptor (->> (&/|list import-entries + tag-entries + (&&&ann/serialize-anns module-anns) + def-entries) + (&/|interpose &&/section-separator) + (&/fold str ""))] + _ (&/flag-compiled-module name) + _ (&&/save-class! &/module-class-name (.toByteArray =class)) + _ (&&/write-module-descriptor! name module-descriptor)] + (return file-hash)) + ?state) + + (&/$Left ?message) + (fail* ?message))))))) + )) + ))) + +(defn compile-program [mode program-module resources-dir source-dirs target-dir] + (do (init! resources-dir target-dir) + (let [m-action (|do [_ (compile-module source-dirs "lux")] + (compile-module source-dirs program-module))] + (|case (m-action (&/init-state mode)) + (&/$Right ?state _) + (do (println "Compilation complete!") + (&&cache/clean ?state)) + + (&/$Left ?message) + (assert false ?message))))) diff --git a/luxc/src/lux/compiler/base.clj b/luxc/src/lux/compiler/base.clj new file mode 100644 index 000000000..e57571fef --- /dev/null +++ b/luxc/src/lux/compiler/base.clj @@ -0,0 +1,116 @@ +;; Copyright (c) Eduardo Julian. All rights reserved. +;; This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +;; If a copy of the MPL was not distributed with this file, +;; You can obtain one at http://mozilla.org/MPL/2.0/. + +(ns lux.compiler.base + (:require (clojure [template :refer [do-template]] + [string :as string]) + [clojure.java.io :as io] + [clojure.core.match :as M :refer [matchv]] + clojure.core.match.array + (lux [base :as & :refer [|let |do return* return fail fail*]] + [type :as &type] + [host :as &host]) + (lux.analyser [base :as &a] + [module :as &a-module]) + [lux.host.generics :as &host-generics]) + (:import (org.objectweb.asm Opcodes + Label + ClassWriter + MethodVisitor) + (java.io File + BufferedOutputStream + FileOutputStream) + (java.lang.reflect Field))) + +;; [Constants] +(def !output-dir (atom nil)) + +(def ^:const ^String function-class "lux/Function") +(def ^:const ^String lux-utils-class "lux/LuxRT") +(def ^:const ^String unit-tag-field "unit_tag") + +;; Formats +(def ^:const ^String local-prefix "l") +(def ^:const ^String partial-prefix "p") +(def ^:const ^String closure-prefix "c") +(def ^:const ^String apply-method "apply") +(defn ^String apply-signature [n] + (str "(" (apply str (repeat n "Ljava/lang/Object;")) ")Ljava/lang/Object;")) +(def ^:const num-apply-variants 8) +(def ^:const arity-field "_arity_") +(def ^:const partials-field "_partials_") + +(def ^:const section-separator (->> 29 char str)) +(def ^:const datum-separator (->> 31 char str)) +(def ^:const entry-separator (->> 30 char str)) + +;; [Utils] +(defn ^:private write-file [^String file-name ^bytes data] + (do (assert (not (.exists (File. file-name))) (str "Can't overwrite file: " file-name)) + (with-open [stream (BufferedOutputStream. (FileOutputStream. file-name))] + (.write stream data)))) + +(defn ^:private write-output [module name data] + (let [module* (&host/->module-class module) + module-dir (str @!output-dir "/" module*)] + (.mkdirs (File. module-dir)) + (write-file (str module-dir "/" name ".class") data))) + +(defn class-exists? [^String module ^String class-name] + "(-> Text Text (IO Bool))" + (|do [_ (return nil) + :let [full-path (str @!output-dir "/" module "/" class-name ".class") + exists? (.exists (File. full-path))]] + (return exists?))) + +;; [Exports] +(defn ^Class load-class! [^ClassLoader loader name] + ;; (prn 'load-class! name) + (.loadClass loader name)) + +(defn save-class! [name bytecode] + (|do [eval? &/get-eval + module &/get-module-name + loader &/loader + !classes &/classes + :let [real-name (str (&host-generics/->class-name module) "." name) + _ (swap! !classes assoc real-name bytecode) + _ (when (not eval?) + (write-output module name bytecode)) + _ (load-class! loader real-name)]] + (return nil))) + +(def ^String lux-module-descriptor-name "lux_module_descriptor") + +(defn write-module-descriptor! [^String name ^String descriptor] + (|do [_ (return nil) + :let [lmd-dir (str @!output-dir "/" name) + _ (.mkdirs (File. lmd-dir)) + _ (write-file (str lmd-dir "/" lux-module-descriptor-name) (.getBytes descriptor java.nio.charset.StandardCharsets/UTF_8))]] + (return nil))) + +(defn read-module-descriptor! [^String name] + (|do [_ (return nil)] + (return (slurp (str @!output-dir "/" name "/" lux-module-descriptor-name) + :encoding "UTF-8")))) + +(do-template [<wrap-name> <unwrap-name> <class> <unwrap-method> <prim> <dup>] + (do (defn <wrap-name> [^MethodVisitor writer] + (doto writer + (.visitMethodInsn Opcodes/INVOKESTATIC <class> "valueOf" (str "(" <prim> ")" (&host-generics/->type-signature <class>))))) + (defn <unwrap-name> [^MethodVisitor writer] + (doto writer + (.visitTypeInsn Opcodes/CHECKCAST <class>) + (.visitMethodInsn Opcodes/INVOKEVIRTUAL <class> <unwrap-method> (str "()" <prim>))))) + + wrap-boolean unwrap-boolean "java/lang/Boolean" "booleanValue" "Z" Opcodes/DUP_X1 + wrap-byte unwrap-byte "java/lang/Byte" "byteValue" "B" Opcodes/DUP_X1 + wrap-short unwrap-short "java/lang/Short" "shortValue" "S" Opcodes/DUP_X1 + wrap-int unwrap-int "java/lang/Integer" "intValue" "I" Opcodes/DUP_X1 + wrap-long unwrap-long "java/lang/Long" "longValue" "J" Opcodes/DUP_X2 + wrap-float unwrap-float "java/lang/Float" "floatValue" "F" Opcodes/DUP_X1 + wrap-double unwrap-double "java/lang/Double" "doubleValue" "D" Opcodes/DUP_X2 + wrap-char unwrap-char "java/lang/Character" "charValue" "C" Opcodes/DUP_X1 + ) diff --git a/luxc/src/lux/compiler/cache.clj b/luxc/src/lux/compiler/cache.clj new file mode 100644 index 000000000..6c44e2a45 --- /dev/null +++ b/luxc/src/lux/compiler/cache.clj @@ -0,0 +1,188 @@ +;; Copyright (c) Eduardo Julian. All rights reserved. +;; This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +;; If a copy of the MPL was not distributed with this file, +;; You can obtain one at http://mozilla.org/MPL/2.0/. + +(ns lux.compiler.cache + (:refer-clojure :exclude [load]) + (:require [clojure.string :as string] + [clojure.java.io :as io] + clojure.core.match + clojure.core.match.array + (lux [base :as & :refer [|do return* return fail fail* |case |let]] + [type :as &type] + [host :as &host]) + [lux.host.generics :as &host-generics] + (lux.analyser [base :as &a] + [module :as &a-module] + [meta :as &a-meta]) + (lux.compiler [base :as &&] + [io :as &&io]) + (lux.compiler.cache [type :as &&&type] + [ann :as &&&ann])) + (:import (java.io File + BufferedOutputStream + FileOutputStream) + (java.lang.reflect Field))) + +;; [Utils] +(defn ^:private read-file [^File file] + "(-> File (Array Byte))" + (with-open [reader (io/input-stream file)] + (let [length (.length file) + buffer (byte-array length)] + (.read reader buffer 0 length) + buffer))) + +(defn ^:private clean-file [^File file] + "(-> File (,))" + (doseq [^File f (seq (.listFiles file)) + :when (not (.isDirectory f))] + (.delete f))) + +(defn ^:private get-field [^String field-name ^Class class] + "(-> Text Class Object)" + (-> class ^Field (.getField field-name) (.get nil))) + +;; [Resources] +(def module-class (str &/module-class-name ".class")) + +(defn cached? [module] + "(-> Text Bool)" + (.exists (new File (str @&&/!output-dir "/" (&host/->module-class module) "/" module-class))) + ;; false + ) + +(defn delete [module] + "(-> Text (Lux Null))" + (fn [state] + (do (clean-file (new File (str @&&/!output-dir "/" (&host/->module-class module)))) + (return* state nil)))) + +(defn ^:private module-dirs + "(-> File (clojure.Seq File))" + [^File module] + (->> module + .listFiles + (filter #(.isDirectory %)) + (map module-dirs) + (apply concat) + (list* module))) + +(defn clean [state] + "(-> Compiler Null)" + (let [needed-modules (->> state (&/get$ &/$modules) &/|keys &/->seq set) + output-dir-prefix (str (.getAbsolutePath (new File @&&/!output-dir)) "/") + outdated? #(->> % (contains? needed-modules) not) + outdated-modules (->> (new File @&&/!output-dir) + .listFiles (filter #(.isDirectory %)) + (map module-dirs) doall (apply concat) + (map #(-> ^File % .getAbsolutePath (string/replace output-dir-prefix ""))) + (filter outdated?))] + (doseq [^String f outdated-modules] + (clean-file (new File (str output-dir-prefix f)))) + nil)) + +(defn ^:private install-all-classes-in-module [!classes module* ^String module-path] + (doseq [^File file (seq (.listFiles (File. module-path))) + :when (not (.isDirectory file)) + :let [file-name (.getName file)] + :when (not= module-class file-name)] + (let [real-name (second (re-find #"^(.*)\.class$" file-name)) + bytecode (read-file file)] + (swap! !classes assoc (str module* "." real-name) bytecode)))) + +(defn ^:private assume-async-result + "(-> (Error Compiler) (Lux Null))" + [result] + (fn [_] + (|case result + (&/$Left error) + (&/$Left error) + + (&/$Right compiler) + (return* compiler nil)))) + +(defn load [source-dirs module module-hash compile-module] + "(-> (List Text) Text Int (-> Text (Lux (,))) (Lux Bool))" + (|do [already-loaded? (&a-module/exists? module)] + (if already-loaded? + (return module-hash) + (|let [redo-cache (|do [_ (delete module) + ;; async (compile-module module) + ] + ;; (assume-async-result @async) + (compile-module module))] + (if (cached? module) + (|do [loader &/loader + !classes &/classes + :let [module* (&host-generics/->class-name module) + module-path (str @&&/!output-dir "/" module) + class-name (str module* "._") + old-classes @!classes + ^Class module-class (do (swap! !classes assoc class-name (read-file (File. (str module-path "/_.class")))) + (&&/load-class! loader class-name)) + _ (install-all-classes-in-module !classes module* module-path)]] + (if (and (= module-hash (get-field &/hash-field module-class)) + (= &/compiler-version (get-field &/compiler-field module-class))) + (|do [^String descriptor (&&/read-module-descriptor! module) + :let [sections (.split descriptor &&/section-separator) + [^String imports-section ^String tags-section module-anns-section ^String defs-section] sections + imports (vec (.split imports-section &&/entry-separator))] + loads (&/map% (fn [^String _import] + (let [[_module _hash] (.split _import &&/datum-separator 2)] + (|do [file-content (&&io/read-file source-dirs (str _module ".lux")) + :let [file-hash (hash file-content) + __hash (Integer/parseInt _hash)] + _ (load source-dirs _module file-hash compile-module) + cached? (&/cached-module? _module) + :let [consistent-cache? (= file-hash __hash)]] + (return (and cached? + consistent-cache?))))) + (if (= [""] imports) + &/$Nil + (&/->list imports)))] + (if (->> loads &/->seq (every? true?)) + (|do [:let [tag-groups (if (= "" tags-section) + &/$Nil + (-> tags-section + (.split &&/entry-separator) + seq + (->> (map (fn [^String _group] + (let [[_type & _tags] (.split _group &&/datum-separator)] + (&/T [_type (->> _tags seq &/->list)]))))) + &/->list))] + _ (&a-module/create-module module module-hash) + _ (&a-module/set-anns (&&&ann/deserialize-anns module-anns-section) module) + _ (&/flag-cached-module module) + _ (&a-module/set-imports imports) + :let [desc-defs (vec (.split defs-section &&/entry-separator))] + _ (&/map% (fn [^String _def-entry] + (let [parts (.split _def-entry &&/datum-separator)] + (case (alength parts) + 2 (let [[_name _alias] parts + [_ __module __name] (re-find #"^(.*);(.*)$" _alias) + def-class (&&/load-class! loader (str (&host-generics/->class-name __module) "." (&host/def-name __name))) + def-type (&a-module/def-type __module __name) + def-anns (&/|list (&/T [&a-meta/alias-tag (&/$IdentM (&/T [__module __name]))])) + def-value (get-field &/value-field def-class)] + (&a-module/define module _name def-type def-anns def-value)) + 3 (let [[_name _type _anns] parts + def-class (&&/load-class! loader (str module* "." (&host/def-name _name))) + [def-anns _] (&&&ann/deserialize-anns _anns) + [def-type _] (&&&type/deserialize-type _type) + def-value (get-field &/value-field def-class)] + (&a-module/define module _name def-type def-anns def-value))))) + (if (= [""] desc-defs) + &/$Nil + (&/->list desc-defs))) + _ (&/map% (fn [group] + (|let [[_type _tags] group] + (|do [[was-exported? =type] (&a-module/type-def module _type)] + (&a-module/declare-tags module _tags was-exported? =type)))) + tag-groups)] + (return module-hash)) + redo-cache)) + (do (reset! !classes old-classes) + redo-cache))) + redo-cache))))) diff --git a/luxc/src/lux/compiler/cache/ann.clj b/luxc/src/lux/compiler/cache/ann.clj new file mode 100644 index 000000000..d50c02465 --- /dev/null +++ b/luxc/src/lux/compiler/cache/ann.clj @@ -0,0 +1,159 @@ +;; Copyright (c) Eduardo Julian. All rights reserved. +;; This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +;; If a copy of the MPL was not distributed with this file, +;; You can obtain one at http://mozilla.org/MPL/2.0/. + +(ns lux.compiler.cache.ann + (:require (clojure [template :refer [do-template]] + [string :as string]) + [clojure.core.match :as M :refer [matchv]] + clojure.core.match.array + (lux [base :as & :refer [|let |do return* return fail fail* |case]]))) + +(def ^:private stop (->> 7 char str)) +(def ^:private cons-signal (->> 5 char str)) +(def ^:private nil-signal (->> 6 char str)) +(def ^:private ident-separator ";") + +(defn ^:private serialize-seq [serialize-ann params] + (str (&/fold (fn [so-far param] + (str so-far cons-signal (serialize-ann param))) + "" + params) + nil-signal)) + +(defn ^:private serialize-text [value] + (str "T" value stop)) + +(defn ^:private serialize-ident [ident] + (|let [[module name] ident] + (str "@" module ident-separator name stop))) + +(defn serialize-ann + "(-> Ann-Value Text)" + [ann] + (|case ann + (&/$BoolM value) + (str "B" value stop) + + (&/$NatM value) + (str "N" value stop) + + (&/$IntM value) + (str "I" value stop) + + (&/$FracM value) + (str "F" value stop) + + (&/$RealM value) + (str "R" value stop) + + (&/$CharM value) + (str "C" value stop) + + (&/$TextM value) + (serialize-text value) + + (&/$IdentM ident) + (serialize-ident ident) + + (&/$ListM elems) + (str "L" (serialize-seq serialize-ann elems)) + + (&/$DictM kvs) + (str "D" (serialize-seq (fn [kv] + (|let [[k v] kv] + (str (serialize-text k) + (serialize-ann v)))) + kvs)) + + _ + (assert false) + )) + +(defn serialize-anns + "(-> Anns Text)" + [anns] + (serialize-seq (fn [kv] + (|let [[k v] kv] + (str (serialize-ident k) + (serialize-ann v)))) + anns)) + +(declare deserialize-ann) + +(do-template [<name> <signal> <ctor> <parser>] + (defn <name> [^String input] + (when (.startsWith input <signal>) + (let [[value* ^String input*] (.split (.substring input 1) stop 2)] + [(<ctor> (<parser> value*)) input*]))) + + ^:private deserialize-bool "B" &/$BoolM Boolean/parseBoolean + ^:private deserialize-nat "N" &/$NatM Long/parseLong + ^:private deserialize-int "I" &/$IntM Long/parseLong + ^:private deserialize-frac "F" &/$FracM Long/parseLong + ^:private deserialize-real "R" &/$RealM Double/parseDouble + ^:private deserialize-char "C" &/$CharM (fn [^String input] (.charAt input 0)) + ^:private deserialize-text "T" &/$TextM identity + ) + +(defn ^:private deserialize-ident* [^String input] + (when (.startsWith input "@") + (let [[ident* ^String input*] (.split (.substring input 1) stop 2) + [_module _name] (.split ident* ident-separator 2)] + [(&/T [_module _name]) input*]))) + +(defn ^:private deserialize-ident [^String input] + (when (.startsWith input "@") + (let [[ident* ^String input*] (.split (.substring input 1) stop 2) + [_module _name] (.split ident* ident-separator 2)] + [(&/$IdentM (&/T [_module _name])) input*]))) + +(defn ^:private deserialize-seq [deserializer input] + (cond (.startsWith input nil-signal) + [&/$Nil (.substring input 1)] + + (.startsWith input cons-signal) + (when-let [[head ^String input*] (deserializer (.substring input 1))] + (when-let [[tail ^String input*] (deserialize-seq deserializer input*)] + [(&/$Cons head tail) input*])) + )) + +(do-template [<name> <deserialize-key>] + (defn <name> [input] + (when-let [[key input*] (<deserialize-key> input)] + (when-let [[ann input*] (deserialize-ann input*)] + [(&/T [key ann]) input*]))) + + ^:private deserialize-kv deserialize-text + ^:private deserialize-ann-entry deserialize-ident* + ) + +(do-template [<name> <signal> <type> <deserializer>] + (defn <name> [^String input] + (when (.startsWith input <signal>) + (when-let [[elems ^String input*] (deserialize-seq <deserializer> + (.substring input 1))] + [(<type> elems) input*]))) + + ^:private deserialize-list "L" &/$ListM deserialize-ann + ^:private deserialize-dict "D" &/$DictM deserialize-kv + ) + +(defn ^:private deserialize-ann + "(-> Text Anns)" + [input] + (or (deserialize-bool input) + (deserialize-nat input) + (deserialize-int input) + (deserialize-frac input) + (deserialize-real input) + (deserialize-char input) + (deserialize-text input) + (deserialize-ident input) + (deserialize-list input) + (deserialize-dict input) + (assert false "[Cache error] Can't deserialize annocation."))) + +(defn deserialize-anns [^String input] + (deserialize-seq deserialize-ann-entry input)) diff --git a/luxc/src/lux/compiler/cache/type.clj b/luxc/src/lux/compiler/cache/type.clj new file mode 100644 index 000000000..80d3a93d6 --- /dev/null +++ b/luxc/src/lux/compiler/cache/type.clj @@ -0,0 +1,164 @@ +;; Copyright (c) Eduardo Julian. All rights reserved. +;; This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +;; If a copy of the MPL was not distributed with this file, +;; You can obtain one at http://mozilla.org/MPL/2.0/. + +(ns lux.compiler.cache.type + (:require (clojure [template :refer [do-template]] + [string :as string]) + [clojure.core.match :as M :refer [matchv]] + clojure.core.match.array + (lux [base :as & :refer [|let |do return* return fail fail* |case]] + [type :as &type]))) + +(def ^:private stop (->> 7 char str)) +(def ^:private cons-signal (->> 5 char str)) +(def ^:private nil-signal (->> 6 char str)) +(def ^:private ident-separator ";") + +(defn ^:private serialize-list [serialize-type params] + (str (&/fold (fn [so-far param] + (str so-far cons-signal (serialize-type param))) + "" + params) + nil-signal)) + +(defn serialize-type + "(-> Type Text)" + [type] + (if (clojure.lang.Util/identical &type/Type type) + "T" + (|case type + (&/$HostT name params) + (str "^" name stop (serialize-list serialize-type params)) + + (&/$VoidT) + "0" + + (&/$UnitT) + "1" + + (&/$ProdT left right) + (str "*" (serialize-type left) (serialize-type right)) + + (&/$SumT left right) + (str "+" (serialize-type left) (serialize-type right)) + + (&/$LambdaT left right) + (str ">" (serialize-type left) (serialize-type right)) + + (&/$UnivQ env body) + (str "U" (serialize-list serialize-type env) (serialize-type body)) + + (&/$ExQ env body) + (str "E" (serialize-list serialize-type env) (serialize-type body)) + + (&/$BoundT idx) + (str "$" idx stop) + + (&/$ExT idx) + (str "!" idx stop) + + (&/$VarT idx) + (str "?" idx stop) + + (&/$AppT left right) + (str "%" (serialize-type left) (serialize-type right)) + + (&/$NamedT [module name] type*) + (str "@" module ident-separator name stop (serialize-type type*)) + + _ + (assert false (prn 'serialize-type (&type/show-type type))) + ))) + +(declare deserialize-type) + +(defn ^:private deserialize-list [input] + (cond (.startsWith input nil-signal) + [&/$Nil (.substring input 1)] + + (.startsWith input cons-signal) + (when-let [[head ^String input*] (deserialize-type (.substring input 1))] + (when-let [[tail ^String input*] (deserialize-list input*)] + [(&/$Cons head tail) input*])) + )) + +(do-template [<name> <signal> <type>] + (defn <name> [^String input] + (when (.startsWith input <signal>) + [<type> (.substring input 1)] + )) + + ^:private deserialize-void "0" &/$VoidT + ^:private deserialize-unit "1" &/$UnitT + ^:private deserialize-type* "T" &type/Type + ) + +(do-template [<name> <signal> <type>] + (defn <name> [^String input] + (when (.startsWith input <signal>) + (when-let [[left ^String input*] (deserialize-type (.substring input 1))] + (when-let [[right ^String input*] (deserialize-type input*)] + [(<type> left right) input*])) + )) + + ^:private deserialize-sum "+" &/$SumT + ^:private deserialize-prod "*" &/$ProdT + ^:private deserialize-lambda ">" &/$LambdaT + ^:private deserialize-app "%" &/$AppT + ) + +(do-template [<name> <signal> <type>] + (defn <name> [^String input] + (when (.startsWith input <signal>) + (let [[idx ^String input*] (.split (.substring input 1) stop 2)] + [(<type> (Long/parseLong idx)) input*]))) + + ^:private deserialize-bound "$" &/$BoundT + ^:private deserialize-ex "!" &/$ExT + ^:private deserialize-var "?" &/$VarT + ) + +(defn ^:private deserialize-named [^String input] + (when (.startsWith input "@") + (let [[^String module+name ^String input*] (.split (.substring input 1) stop 2) + [module name] (.split module+name ident-separator 2)] + (when-let [[type* ^String input*] (deserialize-type input*)] + [(&/$NamedT (&/T [module name]) type*) input*])))) + +(do-template [<name> <signal> <type>] + (defn <name> [^String input] + (when (.startsWith input <signal>) + (when-let [[env ^String input*] (deserialize-list (.substring input 1))] + (when-let [[body ^String input*] (deserialize-type input*)] + [(<type> env body) input*])))) + + ^:private deserialize-univq "U" &/$UnivQ + ^:private deserialize-exq "E" &/$ExQ + ) + +(defn ^:private deserialize-host [^String input] + (when (.startsWith input "^") + (let [[name ^String input*] (.split (.substring input 1) stop 2)] + (when-let [[params ^String input*] (deserialize-list input*)] + [(&/$HostT name params) input*])))) + +(defn deserialize-type + "(-> Text Type)" + [input] + (or (deserialize-type* input) + (deserialize-void input) + (deserialize-unit input) + (deserialize-sum input) + (deserialize-prod input) + (deserialize-lambda input) + (deserialize-app input) + (deserialize-bound input) + (deserialize-ex input) + (deserialize-var input) + (deserialize-named input) + (deserialize-univq input) + (deserialize-exq input) + (deserialize-host input) + (assert false (str "[Cache error] Can't deserialize type. --- " input)))) diff --git a/luxc/src/lux/compiler/case.clj b/luxc/src/lux/compiler/case.clj new file mode 100644 index 000000000..afdcd3eed --- /dev/null +++ b/luxc/src/lux/compiler/case.clj @@ -0,0 +1,219 @@ +;; Copyright (c) Eduardo Julian. All rights reserved. +;; This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +;; If a copy of the MPL was not distributed with this file, +;; You can obtain one at http://mozilla.org/MPL/2.0/. + +(ns lux.compiler.case + (:require (clojure [set :as set] + [template :refer [do-template]]) + clojure.core.match + clojure.core.match.array + (lux [base :as & :refer [|do return* return fail fail* |let |case]] + [type :as &type] + [lexer :as &lexer] + [parser :as &parser] + [analyser :as &analyser] + [host :as &host] + [optimizer :as &o]) + [lux.analyser.case :as &a-case] + [lux.compiler.base :as &&]) + (:import (org.objectweb.asm Opcodes + Label + ClassWriter + MethodVisitor))) + +;; [Utils] +(defn ^:private pop-alt-stack [^MethodVisitor writer stack-depth] + (cond (= 0 stack-depth) + writer + + (= 1 stack-depth) + (doto writer + (.visitInsn Opcodes/POP)) + + (= 2 stack-depth) + (doto writer + (.visitInsn Opcodes/POP2)) + + :else ;; > 2 + (doto writer + (.visitInsn Opcodes/POP2) + (pop-alt-stack (- stack-depth 2))))) + +(defn ^:private stack-peek [^MethodVisitor writer] + (doto writer + (.visitInsn Opcodes/DUP) + (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "pm_stack_peek" "([Ljava/lang/Object;)Ljava/lang/Object;"))) + +(defn ^:private compile-pattern* [^MethodVisitor writer bodies stack-depth $else pm] + "(-> MethodVisitor Case-Pattern (List Label) Int Label MethodVisitor)" + (|case pm + (&o/$ExecPM _body-idx) + (|case (&/|at _body-idx bodies) + (&/$Some $body) + (doto writer + (pop-alt-stack stack-depth) + (.visitJumpInsn Opcodes/GOTO $body)) + + (&/$None) + (assert false)) + + (&o/$PopPM) + (doto writer + (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "pm_stack_pop" "([Ljava/lang/Object;)[Ljava/lang/Object;")) + + (&o/$BindPM _var-id) + (doto writer + stack-peek + (.visitVarInsn Opcodes/ASTORE _var-id) + (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "pm_stack_pop" "([Ljava/lang/Object;)[Ljava/lang/Object;")) + + (&o/$BoolPM _value) + (doto writer + stack-peek + &&/unwrap-boolean + (.visitJumpInsn (if _value Opcodes/IFEQ Opcodes/IFNE) $else)) + + (&o/$NatPM _value) + (doto writer + stack-peek + &&/unwrap-long + (.visitLdcInsn (long _value)) + (.visitInsn Opcodes/LCMP) + (.visitJumpInsn Opcodes/IFNE $else)) + + (&o/$IntPM _value) + (doto writer + stack-peek + &&/unwrap-long + (.visitLdcInsn (long _value)) + (.visitInsn Opcodes/LCMP) + (.visitJumpInsn Opcodes/IFNE $else)) + + (&o/$FracPM _value) + (doto writer + stack-peek + &&/unwrap-long + (.visitLdcInsn (long _value)) + (.visitInsn Opcodes/LCMP) + (.visitJumpInsn Opcodes/IFNE $else)) + + (&o/$RealPM _value) + (doto writer + stack-peek + &&/unwrap-double + (.visitLdcInsn (double _value)) + (.visitInsn Opcodes/DCMPL) + (.visitJumpInsn Opcodes/IFNE $else)) + + (&o/$CharPM _value) + (doto writer + stack-peek + &&/unwrap-char + (.visitLdcInsn _value) + (.visitJumpInsn Opcodes/IF_ICMPNE $else)) + + (&o/$TextPM _value) + (doto writer + stack-peek + (.visitLdcInsn _value) + (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/Object" "equals" "(Ljava/lang/Object;)Z") + (.visitJumpInsn Opcodes/IFEQ $else)) + + (&o/$TuplePM _idx+) + (|let [[_idx is-tail?] (|case _idx+ + (&/$Left _idx) + (&/T [_idx false]) + + (&/$Right _idx) + (&/T [_idx true]))] + (if (= 0 _idx) + (doto writer + stack-peek + (.visitTypeInsn Opcodes/CHECKCAST "[Ljava/lang/Object;") + (.visitLdcInsn (int 0)) + (.visitInsn Opcodes/AALOAD) + (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "pm_stack_push" "([Ljava/lang/Object;Ljava/lang/Object;)[Ljava/lang/Object;")) + (doto writer + stack-peek + (.visitTypeInsn Opcodes/CHECKCAST "[Ljava/lang/Object;") + (.visitLdcInsn (int _idx)) + (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" (if is-tail? "product_getRight" "product_getLeft") "([Ljava/lang/Object;I)Ljava/lang/Object;") + (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "pm_stack_push" "([Ljava/lang/Object;Ljava/lang/Object;)[Ljava/lang/Object;") + ))) + + (&o/$VariantPM _idx+) + (|let [$success (new Label) + $fail (new Label) + [_idx is-last] (|case _idx+ + (&/$Left _idx) + (&/T [_idx false]) + + (&/$Right _idx) + (&/T [_idx true])) + _ (doto writer + stack-peek + (.visitTypeInsn Opcodes/CHECKCAST "[Ljava/lang/Object;") + (.visitLdcInsn (int _idx))) + _ (if is-last + (.visitLdcInsn writer "") + (.visitInsn writer Opcodes/ACONST_NULL))] + (doto writer + (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "sum_get" "([Ljava/lang/Object;ILjava/lang/Object;)Ljava/lang/Object;") + (.visitInsn Opcodes/DUP) + (.visitJumpInsn Opcodes/IFNULL $fail) + (.visitJumpInsn Opcodes/GOTO $success) + (.visitLabel $fail) + (.visitInsn Opcodes/POP) + (.visitJumpInsn Opcodes/GOTO $else) + (.visitLabel $success) + (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "pm_stack_push" "([Ljava/lang/Object;Ljava/lang/Object;)[Ljava/lang/Object;"))) + + (&o/$SeqPM _left-pm _right-pm) + (doto writer + (compile-pattern* bodies stack-depth $else _left-pm) + (compile-pattern* bodies stack-depth $else _right-pm)) + + (&o/$AltPM _left-pm _right-pm) + (|let [$alt-else (new Label)] + (doto writer + (.visitInsn Opcodes/DUP) + (compile-pattern* bodies (inc stack-depth) $alt-else _left-pm) + (.visitLabel $alt-else) + (.visitInsn Opcodes/POP) + (compile-pattern* bodies stack-depth $else _right-pm))) + )) + +(defn ^:private compile-pattern [^MethodVisitor writer bodies pm $end] + (|let [$else (new Label)] + (doto writer + (compile-pattern* bodies 1 $else pm) + (.visitLabel $else) + (.visitInsn Opcodes/POP) + (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "pm_fail" "()V") + (.visitInsn Opcodes/ACONST_NULL) + (.visitJumpInsn Opcodes/GOTO $end)))) + +(defn ^:private compile-bodies [^MethodVisitor writer compile bodies-labels ?bodies $end] + (&/map% (fn [label+body] + (|let [[_label _body] label+body] + (|do [:let [_ (.visitLabel writer _label)] + _ (compile _body) + :let [_ (.visitJumpInsn writer Opcodes/GOTO $end)]] + (return nil)))) + (&/zip2 bodies-labels ?bodies))) + +;; [Resources] +(defn compile-case [compile ?value ?pm ?bodies] + (|do [^MethodVisitor *writer* &/get-writer + :let [$end (new Label) + bodies-labels (&/|map (fn [_] (new Label)) ?bodies)] + _ (compile ?value) + :let [_ (doto *writer* + (.visitInsn Opcodes/ACONST_NULL) + (.visitInsn Opcodes/SWAP) + (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "pm_stack_push" "([Ljava/lang/Object;Ljava/lang/Object;)[Ljava/lang/Object;")) + _ (compile-pattern *writer* bodies-labels ?pm $end)] + _ (compile-bodies *writer* compile bodies-labels ?bodies $end) + :let [_ (.visitLabel *writer* $end)]] + (return nil))) diff --git a/luxc/src/lux/compiler/host.clj b/luxc/src/lux/compiler/host.clj new file mode 100644 index 000000000..9f6d077be --- /dev/null +++ b/luxc/src/lux/compiler/host.clj @@ -0,0 +1,2514 @@ +;; Copyright (c) Eduardo Julian. All rights reserved. +;; This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +;; If a copy of the MPL was not distributed with this file, +;; You can obtain one at http://mozilla.org/MPL/2.0/. + +(ns lux.compiler.host + (:require (clojure [string :as string] + [set :as set] + [template :refer [do-template]]) + clojure.core.match + clojure.core.match.array + (lux [base :as & :refer [|do return* return fail fail* |let |case]] + [type :as &type] + [lexer :as &lexer] + [parser :as &parser] + [analyser :as &analyser] + [optimizer :as &o] + [host :as &host]) + [lux.type.host :as &host-type] + [lux.host.generics :as &host-generics] + [lux.analyser.base :as &a] + [lux.compiler.base :as &&]) + (:import (org.objectweb.asm Opcodes + Label + ClassWriter + MethodVisitor + AnnotationVisitor))) + +;; [Utils] +(def init-method "<init>") + +(let [class+method+sig {"boolean" [(&host-generics/->bytecode-class-name "java.lang.Boolean") "booleanValue" "()Z"] + "byte" [(&host-generics/->bytecode-class-name "java.lang.Byte") "byteValue" "()B"] + "short" [(&host-generics/->bytecode-class-name "java.lang.Short") "shortValue" "()S"] + "int" [(&host-generics/->bytecode-class-name "java.lang.Integer") "intValue" "()I"] + "long" [(&host-generics/->bytecode-class-name "java.lang.Long") "longValue" "()J"] + "float" [(&host-generics/->bytecode-class-name "java.lang.Float") "floatValue" "()F"] + "double" [(&host-generics/->bytecode-class-name "java.lang.Double") "doubleValue" "()D"] + "char" [(&host-generics/->bytecode-class-name "java.lang.Character") "charValue" "()C"]}] + (defn ^:private prepare-arg! [^MethodVisitor *writer* class-name] + (if-let [[class method sig] (get class+method+sig class-name)] + (doto *writer* + (.visitTypeInsn Opcodes/CHECKCAST class) + (.visitMethodInsn Opcodes/INVOKEVIRTUAL class method sig)) + (.visitTypeInsn *writer* Opcodes/CHECKCAST (&host-generics/->bytecode-class-name class-name))))) + +(let [boolean-class "java.lang.Boolean" + byte-class "java.lang.Byte" + short-class "java.lang.Short" + int-class "java.lang.Integer" + long-class "java.lang.Long" + float-class "java.lang.Float" + double-class "java.lang.Double" + char-class "java.lang.Character"] + (defn prepare-return! [^MethodVisitor *writer* *type*] + (|case *type* + (&/$UnitT) + (.visitLdcInsn *writer* &/unit-tag) + + (&/$HostT "boolean" (&/$Nil)) + (.visitMethodInsn *writer* Opcodes/INVOKESTATIC (&host-generics/->bytecode-class-name boolean-class) "valueOf" (str "(Z)" (&host-generics/->type-signature boolean-class))) + + (&/$HostT "byte" (&/$Nil)) + (.visitMethodInsn *writer* Opcodes/INVOKESTATIC (&host-generics/->bytecode-class-name byte-class) "valueOf" (str "(B)" (&host-generics/->type-signature byte-class))) + + (&/$HostT "short" (&/$Nil)) + (.visitMethodInsn *writer* Opcodes/INVOKESTATIC (&host-generics/->bytecode-class-name short-class) "valueOf" (str "(S)" (&host-generics/->type-signature short-class))) + + (&/$HostT "int" (&/$Nil)) + (.visitMethodInsn *writer* Opcodes/INVOKESTATIC (&host-generics/->bytecode-class-name int-class) "valueOf" (str "(I)" (&host-generics/->type-signature int-class))) + + (&/$HostT "long" (&/$Nil)) + (.visitMethodInsn *writer* Opcodes/INVOKESTATIC (&host-generics/->bytecode-class-name long-class) "valueOf" (str "(J)" (&host-generics/->type-signature long-class))) + + (&/$HostT "float" (&/$Nil)) + (.visitMethodInsn *writer* Opcodes/INVOKESTATIC (&host-generics/->bytecode-class-name float-class) "valueOf" (str "(F)" (&host-generics/->type-signature float-class))) + + (&/$HostT "double" (&/$Nil)) + (.visitMethodInsn *writer* Opcodes/INVOKESTATIC (&host-generics/->bytecode-class-name double-class) "valueOf" (str "(D)" (&host-generics/->type-signature double-class))) + + (&/$HostT "char" (&/$Nil)) + (.visitMethodInsn *writer* Opcodes/INVOKESTATIC (&host-generics/->bytecode-class-name char-class) "valueOf" (str "(C)" (&host-generics/->type-signature char-class))) + + (&/$HostT _ _) + nil + + (&/$NamedT ?name ?type) + (prepare-return! *writer* ?type) + + (&/$ExT _) + nil + + _ + (assert false (str 'prepare-return! " " (&type/show-type *type*)))) + *writer*)) + +;; [Resources] +(defn ^:private compile-annotation [writer ann] + (doto ^AnnotationVisitor (.visitAnnotation writer (&host-generics/->type-signature (:name ann)) true) + (-> (.visit param-name param-value) + (->> (|let [[param-name param-value] param]) + (doseq [param (&/->seq (:params ann))]))) + (.visitEnd)) + nil) + +(defn ^:private compile-field [^ClassWriter writer field] + (|case field + (&/$ConstantFieldSyntax ?name ?anns ?gclass ?value) + (|let [=field (.visitField writer + (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC Opcodes/ACC_FINAL) + ?name + (&host-generics/gclass->simple-signature ?gclass) + (&host-generics/gclass->signature ?gclass) nil)] + (do (&/|map (partial compile-annotation =field) ?anns) + (.visitEnd =field) + nil)) + + (&/$VariableFieldSyntax =name =privacy-modifier =state-modifier =anns =type) + (|let [=field (.visitField writer + (+ (&host/privacy-modifier->flag =privacy-modifier) + (&host/state-modifier->flag =state-modifier)) + =name + (&host-generics/gclass->simple-signature =type) + (&host-generics/gclass->signature =type) nil)] + (do (&/|map (partial compile-annotation =field) =anns) + (.visitEnd =field) + nil)) + )) + +(defn ^:private compile-method-return [^MethodVisitor writer output] + (|case output + (&/$GenericClass "void" (&/$Nil)) + (.visitInsn writer Opcodes/RETURN) + + (&/$GenericClass "boolean" (&/$Nil)) + (doto writer + &&/unwrap-boolean + (.visitInsn Opcodes/IRETURN)) + + (&/$GenericClass "byte" (&/$Nil)) + (doto writer + &&/unwrap-byte + (.visitInsn Opcodes/IRETURN)) + + (&/$GenericClass "short" (&/$Nil)) + (doto writer + &&/unwrap-short + (.visitInsn Opcodes/IRETURN)) + + (&/$GenericClass "int" (&/$Nil)) + (doto writer + &&/unwrap-int + (.visitInsn Opcodes/IRETURN)) + + (&/$GenericClass "long" (&/$Nil)) + (doto writer + &&/unwrap-long + (.visitInsn Opcodes/LRETURN)) + + (&/$GenericClass "float" (&/$Nil)) + (doto writer + &&/unwrap-float + (.visitInsn Opcodes/FRETURN)) + + (&/$GenericClass "double" (&/$Nil)) + (doto writer + &&/unwrap-double + (.visitInsn Opcodes/DRETURN)) + + (&/$GenericClass "char" (&/$Nil)) + (doto writer + &&/unwrap-char + (.visitInsn Opcodes/IRETURN)) + + _ + (.visitInsn writer Opcodes/ARETURN))) + +(defn ^:private prepare-method-input [idx input ^MethodVisitor method-visitor] + "(-> Int [Text GenericClass] MethodVisitor (Lux FrameTag))" + (|case input + [_ (&/$GenericClass name params)] + (case name + "boolean" (do (doto method-visitor + (.visitVarInsn Opcodes/ILOAD idx) + &&/wrap-boolean + (.visitVarInsn Opcodes/ASTORE idx)) + (return (&/T [(inc idx) (&/|list (&host-generics/gclass->class-name (&/$GenericClass "java.lang.Boolean" (&/|list))))]))) + "byte" (do (doto method-visitor + (.visitVarInsn Opcodes/ILOAD idx) + &&/wrap-byte + (.visitVarInsn Opcodes/ASTORE idx)) + (return (&/T [(inc idx) (&/|list (&host-generics/gclass->class-name (&/$GenericClass "java.lang.Byte" (&/|list))))]))) + "short" (do (doto method-visitor + (.visitVarInsn Opcodes/ILOAD idx) + &&/wrap-short + (.visitVarInsn Opcodes/ASTORE idx)) + (return (&/T [(inc idx) (&/|list (&host-generics/gclass->class-name (&/$GenericClass "java.lang.Short" (&/|list))))]))) + "int" (do (doto method-visitor + (.visitVarInsn Opcodes/ILOAD idx) + &&/wrap-int + (.visitVarInsn Opcodes/ASTORE idx)) + (return (&/T [(inc idx) (&/|list (&host-generics/gclass->class-name (&/$GenericClass "java.lang.Integer" (&/|list))))]))) + "long" (do (doto method-visitor + (.visitVarInsn Opcodes/LLOAD idx) + &&/wrap-long + (.visitVarInsn Opcodes/ASTORE idx)) + (return (&/T [(+ 2 idx) (&/|list (&host-generics/gclass->class-name (&/$GenericClass "java.lang.Long" (&/|list))) Opcodes/TOP)]))) + "float" (do (doto method-visitor + (.visitVarInsn Opcodes/FLOAD idx) + &&/wrap-float + (.visitVarInsn Opcodes/ASTORE idx)) + (return (&/T [(inc idx) (&/|list (&host-generics/gclass->class-name (&/$GenericClass "java.lang.Float" (&/|list))))]))) + "double" (do (doto method-visitor + (.visitVarInsn Opcodes/DLOAD idx) + &&/wrap-double + (.visitVarInsn Opcodes/ASTORE idx)) + (return (&/T [(+ 2 idx) (&/|list (&host-generics/gclass->class-name (&/$GenericClass "java.lang.Double" (&/|list))) Opcodes/TOP)]))) + "char" (do (doto method-visitor + (.visitVarInsn Opcodes/ILOAD idx) + &&/wrap-char + (.visitVarInsn Opcodes/ASTORE idx)) + (return (&/T [(inc idx) (&/|list (&host-generics/gclass->class-name (&/$GenericClass "java.lang.Character" (&/|list))))]))) + ;; else + (return (&/T [(inc idx) (&/|list (&host-generics/gclass->class-name (&/$GenericClass name params)))]))) + + [_ gclass] + (return (&/T [(inc idx) (&/|list (&host-generics/gclass->class-name gclass))])) + )) + +(defn ^:private prepare-method-inputs [idx inputs method-visitor] + "(-> Int (List GenericClass) MethodVisitor (Lux (List FrameTag)))" + (|case inputs + (&/$Nil) + (return &/$Nil) + + (&/$Cons input inputs*) + (|do [[_ outputs*] (&/fold% (fn [idx+outputs input] + (|do [:let [[_idx _outputs] idx+outputs] + [idx* output] (prepare-method-input _idx input method-visitor)] + (return (&/T [idx* (&/$Cons output _outputs)])))) + (&/T [idx &/$Nil]) + inputs)] + (return (&/list-join (&/|reverse outputs*)))) + )) + +(defn ^:private compile-method-def [compile ^ClassWriter class-writer bytecode-class-name ?super-class method-def] + (|case method-def + (&/$ConstructorMethodAnalysis ?privacy-modifier ?strict ?anns ?gvars ?exceptions ?inputs ?ctor-args ?body) + (|let [?output (&/$GenericClass "void" (&/|list)) + =method-decl (&/T [init-method ?anns ?gvars ?exceptions (&/|map &/|second ?inputs) ?output]) + [simple-signature generic-signature] (&host-generics/method-signatures =method-decl)] + (&/with-writer (.visitMethod class-writer + (+ (&host/privacy-modifier->flag ?privacy-modifier) + (if ?strict Opcodes/ACC_STRICT 0)) + init-method + simple-signature + generic-signature + (->> ?exceptions (&/|map &host-generics/gclass->class-name) &/->seq (into-array java.lang.String))) + (|do [^MethodVisitor =method &/get-writer + :let [[super-class-name super-class-params] ?super-class + init-types (->> ?ctor-args (&/|map (comp &host-generics/gclass->signature &/|first)) (&/fold str "")) + init-sig (str "(" init-types ")" "V") + _ (&/|map (partial compile-annotation =method) ?anns) + _ (.visitCode =method)] + =input-tags (prepare-method-inputs 1 ?inputs =method) + :let [_ (.visitVarInsn =method Opcodes/ALOAD 0)] + _ (->> ?ctor-args (&/|map &/|second) (&/map% compile)) + :let [_ (.visitMethodInsn =method Opcodes/INVOKESPECIAL (&host-generics/->bytecode-class-name super-class-name) init-method init-sig)] + _ (compile (&o/optimize ?body)) + :let [_ (doto =method + (compile-method-return ?output) + (.visitMaxs 0 0) + (.visitEnd))]] + (return nil)))) + + (&/$VirtualMethodAnalysis ?name ?privacy-modifier =final? ?strict ?anns ?gvars ?exceptions ?inputs ?output ?body) + (|let [=method-decl (&/T [?name ?anns ?gvars ?exceptions (&/|map &/|second ?inputs) ?output]) + [simple-signature generic-signature] (&host-generics/method-signatures =method-decl)] + (&/with-writer (.visitMethod class-writer + (+ (&host/privacy-modifier->flag ?privacy-modifier) + (if =final? Opcodes/ACC_FINAL 0) + (if ?strict Opcodes/ACC_STRICT 0)) + ?name + simple-signature + generic-signature + (->> ?exceptions (&/|map &host-generics/gclass->class-name) &/->seq (into-array java.lang.String))) + (|do [^MethodVisitor =method &/get-writer + :let [_ (&/|map (partial compile-annotation =method) ?anns) + _ (.visitCode =method)] + =input-tags (prepare-method-inputs 1 ?inputs =method) + _ (compile (&o/optimize ?body)) + :let [_ (doto =method + (compile-method-return ?output) + (.visitMaxs 0 0) + (.visitEnd))]] + (return nil)))) + + (&/$OverridenMethodAnalysis ?class-decl ?name ?strict ?anns ?gvars ?exceptions ?inputs ?output ?body) + (|let [=method-decl (&/T [?name ?anns ?gvars ?exceptions (&/|map &/|second ?inputs) ?output]) + [simple-signature generic-signature] (&host-generics/method-signatures =method-decl)] + (&/with-writer (.visitMethod class-writer + (+ Opcodes/ACC_PUBLIC + (if ?strict Opcodes/ACC_STRICT 0)) + ?name + simple-signature + generic-signature + (->> ?exceptions (&/|map &host-generics/gclass->class-name) &/->seq (into-array java.lang.String))) + (|do [^MethodVisitor =method &/get-writer + :let [_ (&/|map (partial compile-annotation =method) ?anns) + _ (.visitCode =method)] + =input-tags (prepare-method-inputs 1 ?inputs =method) + _ (compile (&o/optimize ?body)) + :let [_ (doto =method + (compile-method-return ?output) + (.visitMaxs 0 0) + (.visitEnd))]] + (return nil)))) + + (&/$StaticMethodAnalysis ?name ?privacy-modifier ?strict ?anns ?gvars ?exceptions ?inputs ?output ?body) + (|let [=method-decl (&/T [?name ?anns ?gvars ?exceptions (&/|map &/|second ?inputs) ?output]) + [simple-signature generic-signature] (&host-generics/method-signatures =method-decl)] + (&/with-writer (.visitMethod class-writer + (+ (&host/privacy-modifier->flag ?privacy-modifier) + (if ?strict Opcodes/ACC_STRICT 0) + Opcodes/ACC_STATIC) + ?name + simple-signature + generic-signature + (->> ?exceptions (&/|map &host-generics/gclass->class-name) &/->seq (into-array java.lang.String))) + (|do [^MethodVisitor =method &/get-writer + :let [_ (&/|map (partial compile-annotation =method) ?anns) + _ (.visitCode =method)] + =input-tags (prepare-method-inputs 0 ?inputs =method) + _ (compile (&o/optimize ?body)) + :let [_ (doto =method + (compile-method-return ?output) + (.visitMaxs 0 0) + (.visitEnd))]] + (return nil)))) + + (&/$AbstractMethodSyntax ?name ?privacy-modifier ?anns ?gvars ?exceptions ?inputs ?output) + (|let [=method-decl (&/T [?name ?anns ?gvars ?exceptions (&/|map &/|second ?inputs) ?output]) + [simple-signature generic-signature] (&host-generics/method-signatures =method-decl)] + (&/with-writer (.visitMethod class-writer + (+ Opcodes/ACC_ABSTRACT + (&host/privacy-modifier->flag ?privacy-modifier)) + ?name + simple-signature + generic-signature + (->> ?exceptions (&/|map &host-generics/gclass->class-name) &/->seq (into-array java.lang.String))) + (|do [^MethodVisitor =method &/get-writer + :let [_ (&/|map (partial compile-annotation =method) ?anns) + _ (.visitEnd =method)]] + (return nil)))) + + (&/$NativeMethodSyntax ?name ?privacy-modifier ?anns ?gvars ?exceptions ?inputs ?output) + (|let [=method-decl (&/T [?name ?anns ?gvars ?exceptions (&/|map &/|second ?inputs) ?output]) + [simple-signature generic-signature] (&host-generics/method-signatures =method-decl)] + (&/with-writer (.visitMethod class-writer + (+ Opcodes/ACC_PUBLIC Opcodes/ACC_NATIVE + (&host/privacy-modifier->flag ?privacy-modifier)) + ?name + simple-signature + generic-signature + (->> ?exceptions (&/|map &host-generics/gclass->class-name) &/->seq (into-array java.lang.String))) + (|do [^MethodVisitor =method &/get-writer + :let [_ (&/|map (partial compile-annotation =method) ?anns) + _ (.visitEnd =method)]] + (return nil)))) + )) + +(defn ^:private compile-method-decl [^ClassWriter class-writer =method-decl] + (|let [[=name =anns =gvars =exceptions =inputs =output] =method-decl + [simple-signature generic-signature] (&host-generics/method-signatures =method-decl) + =method (.visitMethod class-writer + (+ Opcodes/ACC_PUBLIC Opcodes/ACC_ABSTRACT) + =name + simple-signature + generic-signature + (->> =exceptions (&/|map &host-generics/gclass->class-name) &/->seq (into-array java.lang.String))) + _ (&/|map (partial compile-annotation =method) =anns) + _ (.visitEnd =method)] + nil)) + +(defn ^:private prepare-ctor-arg [^MethodVisitor writer type] + (case type + "boolean" (doto writer + (.visitTypeInsn Opcodes/CHECKCAST (&host-generics/->bytecode-class-name "java.lang.Boolean")) + &&/unwrap-boolean) + "byte" (doto writer + (.visitTypeInsn Opcodes/CHECKCAST (&host-generics/->bytecode-class-name "java.lang.Byte")) + &&/unwrap-byte) + "short" (doto writer + (.visitTypeInsn Opcodes/CHECKCAST (&host-generics/->bytecode-class-name "java.lang.Short")) + &&/unwrap-short) + "int" (doto writer + (.visitTypeInsn Opcodes/CHECKCAST (&host-generics/->bytecode-class-name "java.lang.Integer")) + &&/unwrap-int) + "long" (doto writer + (.visitTypeInsn Opcodes/CHECKCAST (&host-generics/->bytecode-class-name "java.lang.Long")) + &&/unwrap-long) + "float" (doto writer + (.visitTypeInsn Opcodes/CHECKCAST (&host-generics/->bytecode-class-name "java.lang.Float")) + &&/unwrap-float) + "double" (doto writer + (.visitTypeInsn Opcodes/CHECKCAST (&host-generics/->bytecode-class-name "java.lang.Double")) + &&/unwrap-double) + "char" (doto writer + (.visitTypeInsn Opcodes/CHECKCAST (&host-generics/->bytecode-class-name "java.lang.Character")) + &&/unwrap-char) + ;; else + (doto writer + (.visitTypeInsn Opcodes/CHECKCAST (&host-generics/->bytecode-class-name type))))) + +(let [clo-field-sig (&host-generics/->type-signature "java.lang.Object") + <init>-return "V"] + (defn ^:private anon-class-<init>-signature [env] + (str "(" (&/fold str "" (&/|repeat (&/|length env) clo-field-sig)) ")" + <init>-return)) + + (defn ^:private add-anon-class-<init> [^ClassWriter class-writer compile class-name super-class env ctor-args] + (|let [[super-class-name super-class-params] super-class + init-types (->> ctor-args (&/|map (comp &host-generics/->type-signature &/|first)) (&/fold str ""))] + (&/with-writer (.visitMethod class-writer Opcodes/ACC_PUBLIC init-method (anon-class-<init>-signature env) nil nil) + (|do [^MethodVisitor =method &/get-writer + :let [_ (doto =method + (.visitCode) + (.visitVarInsn Opcodes/ALOAD 0))] + _ (&/map% (fn [type+term] + (|let [[type term] type+term] + (|do [_ (compile term) + :let [_ (prepare-ctor-arg =method type)]] + (return nil)))) + ctor-args) + :let [_ (doto =method + (.visitMethodInsn Opcodes/INVOKESPECIAL (&host-generics/->bytecode-class-name super-class-name) init-method (str "(" init-types ")" <init>-return)) + (-> (doto (.visitVarInsn Opcodes/ALOAD 0) + (.visitVarInsn Opcodes/ALOAD (inc ?captured-id)) + (.visitFieldInsn Opcodes/PUTFIELD class-name captured-name clo-field-sig)) + (->> (let [captured-name (str &&/closure-prefix ?captured-id)]) + (|case ?name+?captured + [?name [_ (&o/$captured _ ?captured-id ?source)]]) + (doseq [?name+?captured (&/->seq env)]))) + (.visitInsn Opcodes/RETURN) + (.visitMaxs 0 0) + (.visitEnd))]] + (return nil))))) + ) + +(defn ^:private constant-inits [fields] + "(-> (List FieldAnalysis) (List [Text GenericClass Analysis]))" + (&/fold &/|++ + &/$Nil + (&/|map (fn [field] + (|case field + (&/$ConstantFieldSyntax ?name ?anns ?gclass ?value) + (&/|list (&/T [?name ?gclass ?value])) + + (&/$VariableFieldSyntax _) + (&/|list) + )) + fields))) + +(declare compile-jvm-putstatic) +(defn compile-jvm-class [compile class-decl ?super-class ?interfaces ?inheritance-modifier ?anns ?fields ?methods env ??ctor-args] + (|do [module &/get-module-name + [file-name line column] &/cursor + :let [[?name ?params] class-decl + class-signature (&host-generics/gclass-decl->signature class-decl (&/$Cons ?super-class ?interfaces)) + full-name (str module "/" ?name) + super-class* (&host-generics/->bytecode-class-name (&host-generics/super-class-name ?super-class)) + =class (doto (new ClassWriter ClassWriter/COMPUTE_MAXS) + (.visit &host/bytecode-version (+ Opcodes/ACC_PUBLIC Opcodes/ACC_SUPER + (&host/inheritance-modifier->flag ?inheritance-modifier)) + full-name (if (= "" class-signature) nil class-signature) super-class* (->> ?interfaces (&/|map (comp &host-generics/->bytecode-class-name &host-generics/super-class-name)) &/->seq (into-array String))) + (.visitSource file-name nil)) + _ (&/|map (partial compile-annotation =class) ?anns) + _ (&/|map (partial compile-field =class) + ?fields)] + _ (&/map% (partial compile-method-def compile =class full-name ?super-class) ?methods) + _ (|case ??ctor-args + (&/$Some ctor-args) + (add-anon-class-<init> =class compile full-name ?super-class env ctor-args) + + _ + (return nil)) + _ (&/with-writer (.visitMethod =class Opcodes/ACC_STATIC "<clinit>" "()V" nil nil) + (|do [^MethodVisitor =method &/get-writer + :let [_ (doto =method + (.visitCode))] + _ (&/map% (fn [ftriple] + (|let [[fname fgclass fvalue] ftriple] + (compile-jvm-putstatic compile (&/|list (&o/optimize fvalue)) (&/|list ?name fname fgclass)))) + (constant-inits ?fields)) + :let [_ (doto =method + (.visitInsn Opcodes/RETURN) + (.visitMaxs 0 0) + (.visitEnd))]] + (return nil)))] + (&&/save-class! ?name (.toByteArray (doto =class .visitEnd))))) + +(defn compile-jvm-interface [interface-decl ?supers ?anns ?methods] + (|do [:let [[interface-name interface-vars] interface-decl] + module &/get-module-name + [file-name _ _] &/cursor + :let [interface-signature (&host-generics/gclass-decl->signature interface-decl ?supers) + =interface (doto (new ClassWriter ClassWriter/COMPUTE_MAXS) + (.visit &host/bytecode-version (+ Opcodes/ACC_PUBLIC Opcodes/ACC_ABSTRACT Opcodes/ACC_INTERFACE) + (str module "/" interface-name) + (if (= "" interface-signature) nil interface-signature) + "java/lang/Object" + (->> ?supers (&/|map (comp &host-generics/->bytecode-class-name &host-generics/super-class-name)) &/->seq (into-array String))) + (.visitSource file-name nil)) + _ (&/|map (partial compile-annotation =interface) ?anns) + _ (do (&/|map (partial compile-method-decl =interface) ?methods) + (.visitEnd =interface))]] + (&&/save-class! interface-name (.toByteArray =interface)))) + +(def compile-Function-class + (|do [_ (return nil) + :let [super-class "java/lang/Object" + =class (doto (new ClassWriter ClassWriter/COMPUTE_MAXS) + (.visit &host/bytecode-version (+ Opcodes/ACC_PUBLIC Opcodes/ACC_SUPER + Opcodes/ACC_ABSTRACT + ;; Opcodes/ACC_INTERFACE + ) + &&/function-class nil super-class (into-array String [])) + (-> (.visitField (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL) &&/partials-field "I" nil nil) + (doto (.visitEnd)))) + =init-method (doto (.visitMethod =class Opcodes/ACC_PUBLIC init-method "(I)V" nil nil) + (.visitCode) + (.visitVarInsn Opcodes/ALOAD 0) + (.visitMethodInsn Opcodes/INVOKESPECIAL super-class init-method "()V") + (.visitVarInsn Opcodes/ALOAD 0) + (.visitVarInsn Opcodes/ILOAD 1) + (.visitFieldInsn Opcodes/PUTFIELD &&/function-class &&/partials-field "I") + (.visitInsn Opcodes/RETURN) + (.visitMaxs 0 0) + (.visitEnd)) + _ (dotimes [arity* &&/num-apply-variants] + (let [arity (inc arity*)] + (if (= 1 arity) + (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_ABSTRACT) &&/apply-method (&&/apply-signature arity) nil nil) + (.visitEnd)) + (doto (.visitMethod =class Opcodes/ACC_PUBLIC &&/apply-method (&&/apply-signature arity) nil nil) + (.visitCode) + (-> (.visitVarInsn Opcodes/ALOAD idx) + (->> (dotimes [idx arity]))) + (.visitMethodInsn Opcodes/INVOKEVIRTUAL &&/function-class &&/apply-method (&&/apply-signature (dec arity))) + (.visitTypeInsn Opcodes/CHECKCAST &&/function-class) + (.visitVarInsn Opcodes/ALOAD arity) + (.visitMethodInsn Opcodes/INVOKEVIRTUAL &&/function-class &&/apply-method (&&/apply-signature 1)) + (.visitInsn Opcodes/ARETURN) + (.visitMaxs 0 0) + (.visitEnd)))))]] + (&&/save-class! (second (string/split &&/function-class #"/")) + (.toByteArray (doto =class .visitEnd))))) + +(defn ^:private compile-LuxRT-adt-methods [^ClassWriter =class] + (|let [_ (let [$begin (new Label) + $not-rec (new Label)] + (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "product_getLeft" "([Ljava/lang/Object;I)Ljava/lang/Object;" nil nil) + (.visitCode) + (.visitLabel $begin) + (.visitVarInsn Opcodes/ALOAD 0) ;; tuple + (.visitInsn Opcodes/ARRAYLENGTH) ;; tuple-size + (.visitVarInsn Opcodes/ILOAD 1) ;; tuple-size, index + (.visitLdcInsn (int 1)) ;; tuple-size, index, offset-last-elem + (.visitInsn Opcodes/IADD) ;; tuple-size, index-last-elem + (.visitInsn Opcodes/DUP2) ;; tuple-size, index-last-elem, tuple-size, index-last-elem + (.visitJumpInsn Opcodes/IF_ICMPGT $not-rec) ;; tuple-size, index-last-elem + (.visitInsn Opcodes/SWAP) ;; index-last-elem, tuple-size + (.visitInsn Opcodes/ISUB) ;; sub-index + (.visitVarInsn Opcodes/ALOAD 0) ;; sub-index, tuple + (.visitInsn Opcodes/DUP) ;; sub-index, tuple, tuple + (.visitInsn Opcodes/ARRAYLENGTH) ;; sub-index, tuple, tuple-size + (.visitLdcInsn (int 1)) ;; sub-index, tuple, tuple-size, offset-last-elem + (.visitInsn Opcodes/ISUB) ;; sub-index, tuple, index-last-elem + (.visitInsn Opcodes/AALOAD) ;; sub-index, sub-tuple + (.visitTypeInsn Opcodes/CHECKCAST "[Ljava/lang/Object;") + (.visitVarInsn Opcodes/ASTORE 0) ;; sub-index + (.visitVarInsn Opcodes/ISTORE 1) ;; + (.visitJumpInsn Opcodes/GOTO $begin) + (.visitLabel $not-rec) ;; tuple-size, index-last-elem + (.visitInsn Opcodes/POP2) ;; + (.visitVarInsn Opcodes/ALOAD 0) ;; tuple + (.visitVarInsn Opcodes/ILOAD 1) ;; tuple, index + (.visitInsn Opcodes/AALOAD) ;; elem + (.visitInsn Opcodes/ARETURN) + (.visitMaxs 0 0) + (.visitEnd))) + _ (let [$begin (new Label) + $is-last (new Label) + $must-copy (new Label)] + (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "product_getRight" "([Ljava/lang/Object;I)Ljava/lang/Object;" nil nil) + (.visitCode) + (.visitLabel $begin) + (.visitVarInsn Opcodes/ALOAD 0) ;; tuple + (.visitInsn Opcodes/ARRAYLENGTH) ;; tuple-size + (.visitVarInsn Opcodes/ILOAD 1) ;; tuple-size, index + (.visitLdcInsn (int 1)) ;; tuple-size, index, offset-last-elem + (.visitInsn Opcodes/IADD) ;; tuple-size, index-last-elem + (.visitInsn Opcodes/DUP2) ;; tuple-size, index-last-elem, tuple-size, index-last-elem + (.visitJumpInsn Opcodes/IF_ICMPEQ $is-last) ;; tuple-size, index-last-elem + (.visitJumpInsn Opcodes/IF_ICMPGT $must-copy) ;; + ;; Must recurse + (.visitVarInsn Opcodes/ALOAD 0) ;; tuple + (.visitInsn Opcodes/DUP) ;; tuple, tuple + (.visitInsn Opcodes/ARRAYLENGTH) ;; tuple, tuple-size + (.visitLdcInsn (int 1)) ;; tuple, tuple-size, offset-last-elem + (.visitInsn Opcodes/ISUB) ;; tuple, offset-tuple-last-elem + (.visitInsn Opcodes/AALOAD) ;; tuple-tail + (.visitVarInsn Opcodes/ILOAD 1) ;; tuple-tail, index + (.visitVarInsn Opcodes/ALOAD 0) ;; tuple-tail, index, tuple + (.visitInsn Opcodes/ARRAYLENGTH) ;; tuple-tail, index, tuple-size + (.visitLdcInsn (int 1)) ;; tuple-tail, index, tuple-size, 1 + (.visitInsn Opcodes/ISUB) ;; tuple-tail, index, tuple-size* + (.visitInsn Opcodes/ISUB) ;; tuple-tail, index* + (.visitVarInsn Opcodes/ISTORE 1) ;; tuple-tail + (.visitTypeInsn Opcodes/CHECKCAST "[Ljava/lang/Object;") ;; tuple-tail + (.visitVarInsn Opcodes/ASTORE 0) ;; + (.visitJumpInsn Opcodes/GOTO $begin) + (.visitLabel $must-copy) + (.visitVarInsn Opcodes/ALOAD 0) + (.visitVarInsn Opcodes/ILOAD 1) + (.visitVarInsn Opcodes/ALOAD 0) + (.visitInsn Opcodes/ARRAYLENGTH) + (.visitMethodInsn Opcodes/INVOKESTATIC "java/util/Arrays" "copyOfRange" "([Ljava/lang/Object;II)[Ljava/lang/Object;") + (.visitInsn Opcodes/ARETURN) + (.visitLabel $is-last) ;; tuple-size, index-last-elem + (.visitInsn Opcodes/POP2) ;; + (.visitVarInsn Opcodes/ALOAD 0) ;; tuple + (.visitVarInsn Opcodes/ILOAD 1) ;; tuple, index + (.visitInsn Opcodes/AALOAD) ;; elem + (.visitInsn Opcodes/ARETURN) + (.visitMaxs 0 0) + (.visitEnd))) + _ (let [$begin (new Label) + $just-return (new Label) + $then (new Label) + $further (new Label) + $not-right (new Label)] + (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "sum_get" "([Ljava/lang/Object;ILjava/lang/Object;)Ljava/lang/Object;" nil nil) + (.visitCode) + (.visitLabel $begin) + (.visitVarInsn Opcodes/ILOAD 1) ;; tag + (.visitVarInsn Opcodes/ALOAD 0) ;; tag, sum + (.visitLdcInsn (int 0)) ;; tag, sum, sum-tag-idx + (.visitInsn Opcodes/AALOAD) ;; tag, sum-tag' + &&/unwrap-int ;; tag, sum-tag + (.visitInsn Opcodes/DUP2) ;; tag, sum-tag, tag, sum-tag + (.visitJumpInsn Opcodes/IF_ICMPEQ $then) ;; tag, sum-tag + (.visitInsn Opcodes/DUP2) ;; tag, sum-tag, tag, sum-tag + (.visitJumpInsn Opcodes/IF_ICMPGT $further) ;; tag, sum-tag + (.visitInsn Opcodes/POP2) + (.visitInsn Opcodes/ACONST_NULL) + (.visitInsn Opcodes/ARETURN) + (.visitLabel $then) ;; tag, sum-tag + (.visitVarInsn Opcodes/ALOAD 2) ;; tag, sum-tag, wants-last? + (.visitVarInsn Opcodes/ALOAD 0) + (.visitLdcInsn (int 1)) + (.visitInsn Opcodes/AALOAD) ;; tag, sum-tag, wants-last?, is-last? + (.visitJumpInsn Opcodes/IF_ACMPEQ $just-return) + (.visitJumpInsn Opcodes/GOTO $further) + (.visitLabel $just-return) + (.visitInsn Opcodes/POP2) + (.visitVarInsn Opcodes/ALOAD 0) + (.visitLdcInsn (int 2)) + (.visitInsn Opcodes/AALOAD) + (.visitInsn Opcodes/ARETURN) + (.visitLabel $further) ;; tag, sum-tag + (.visitVarInsn Opcodes/ALOAD 0) ;; tag, sum-tag, sum + (.visitLdcInsn (int 1)) ;; tag, sum-tag, sum, last-index? + (.visitInsn Opcodes/AALOAD) ;; tag, sum-tag, last? + (.visitJumpInsn Opcodes/IFNULL $not-right) ;; tag, sum-tag + (.visitInsn Opcodes/ISUB) ;; sub-tag + (.visitVarInsn Opcodes/ALOAD 0) ;; sub-tag, sum + (.visitLdcInsn (int 2)) ;; sub-tag, sum, sub-sum-idx + (.visitInsn Opcodes/AALOAD) ;; sub-tag, sub-sum + (.visitTypeInsn Opcodes/CHECKCAST "[Ljava/lang/Object;") + (.visitVarInsn Opcodes/ASTORE 0) ;; sub-tag + (.visitVarInsn Opcodes/ISTORE 1) ;; + (.visitJumpInsn Opcodes/GOTO $begin) + (.visitLabel $not-right) ;; tag, sum-tag + (.visitInsn Opcodes/POP2) + (.visitInsn Opcodes/ACONST_NULL) + (.visitInsn Opcodes/ARETURN) + (.visitMaxs 0 0) + (.visitEnd))) + _ (let [;; $is-null (new Label) + ] + ;; I commented out some parts because a null-check was + ;; done to ensure variants were never created with null + ;; values (this would interfere later with + ;; pattern-matching). + ;; Since Lux itself doesn't have null values as part of + ;; the language, the burden of ensuring non-nulls was + ;; shifted to library code dealing with host-interop, to + ;; ensure variant-making was as fast as possible. + ;; The null-checking code was left as comments in case I + ;; ever change my mind. + (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "sum_make" "(ILjava/lang/Object;Ljava/lang/Object;)[Ljava/lang/Object;" nil nil) + (.visitCode) + ;; (.visitVarInsn Opcodes/ALOAD 2) + ;; (.visitJumpInsn Opcodes/IFNULL $is-null) + (.visitLdcInsn (int 3)) + (.visitTypeInsn Opcodes/ANEWARRAY "java/lang/Object") + (.visitInsn Opcodes/DUP) + (.visitLdcInsn (int 0)) + (.visitVarInsn Opcodes/ILOAD 0) + (&&/wrap-int) + (.visitInsn Opcodes/AASTORE) + (.visitInsn Opcodes/DUP) + (.visitLdcInsn (int 1)) + (.visitVarInsn Opcodes/ALOAD 1) + (.visitInsn Opcodes/AASTORE) + (.visitInsn Opcodes/DUP) + (.visitLdcInsn (int 2)) + (.visitVarInsn Opcodes/ALOAD 2) + (.visitInsn Opcodes/AASTORE) + (.visitInsn Opcodes/ARETURN) + ;; (.visitLabel $is-null) + ;; (.visitTypeInsn Opcodes/NEW "java/lang/IllegalStateException") + ;; (.visitInsn Opcodes/DUP) + ;; (.visitLdcInsn "Can't create variant for null pointer") + ;; (.visitMethodInsn Opcodes/INVOKESPECIAL "java/lang/IllegalStateException" "<init>" "(Ljava/lang/String;)V") + ;; (.visitInsn Opcodes/ATHROW) + (.visitMaxs 0 0) + (.visitEnd)))] + nil)) + +(defn ^:private low-4b [^MethodVisitor =method] + (doto =method + ;; Assume there is a long at the top of the stack... + ;; Add mask corresponding to -1 (FFFF...), on the low 32 bits. + (.visitLdcInsn (int -1)) + (.visitInsn Opcodes/I2L) + ;; Then do a bitwise and. + (.visitInsn Opcodes/LAND) + )) + +(defn ^:private high-4b [^MethodVisitor =method] + (doto =method + ;; Assume there is a long at the top of the stack... + (.visitLdcInsn (int 32)) + (.visitInsn Opcodes/LUSHR) + )) + +(defn ^:private swap2 [^MethodVisitor =method] + (doto =method + ;; X2, Y2 + (.visitInsn Opcodes/DUP2_X2) ;; Y2, X2, Y2 + (.visitInsn Opcodes/POP2) ;; Y2, X2 + )) + +(defn ^:private bit-set-64? [^MethodVisitor =method] + (doto =method + ;; L, I + (.visitLdcInsn (long 1)) ;; L, I, L + (.visitInsn Opcodes/DUP2_X1) ;; L, L, I, L + (.visitInsn Opcodes/POP2) ;; L, L, I + (.visitInsn Opcodes/LSHL) ;; L, L + (.visitInsn Opcodes/LAND) ;; L + (.visitLdcInsn (long 0)) ;; L, L + (.visitInsn Opcodes/LCMP) ;; I + )) + +(defn ^:private compile-LuxRT-frac-methods [^ClassWriter =class] + (|let [_ (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "mul_frac" "(JJ)J" nil nil) + ;; Based on: http://stackoverflow.com/a/31629280/6823464 + (.visitCode) + ;; Bottom part + (.visitVarInsn Opcodes/LLOAD 0) low-4b + (.visitVarInsn Opcodes/LLOAD 2) low-4b + (.visitInsn Opcodes/LMUL) + (.visitLdcInsn (int 32)) + (.visitInsn Opcodes/LUSHR) + ;; Middle part + (.visitVarInsn Opcodes/LLOAD 0) high-4b + (.visitVarInsn Opcodes/LLOAD 2) low-4b + (.visitInsn Opcodes/LMUL) + (.visitVarInsn Opcodes/LLOAD 0) low-4b + (.visitVarInsn Opcodes/LLOAD 2) high-4b + (.visitInsn Opcodes/LMUL) + (.visitInsn Opcodes/LADD) + ;; Join middle and bottom + (.visitInsn Opcodes/LADD) + (.visitLdcInsn (int 32)) + (.visitInsn Opcodes/LUSHR) + ;; Top part + (.visitVarInsn Opcodes/LLOAD 0) high-4b + (.visitVarInsn Opcodes/LLOAD 2) high-4b + (.visitInsn Opcodes/LMUL) + ;; Join top with rest + (.visitInsn Opcodes/LADD) + ;; Return + (.visitInsn Opcodes/LRETURN) + (.visitMaxs 0 0) + (.visitEnd)) + _ (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "div_frac" "(JJ)J" nil nil) + (.visitCode) + ;; Based on: http://stackoverflow.com/a/8510587/6823464 + (.visitVarInsn Opcodes/LLOAD 0) + (.visitVarInsn Opcodes/LLOAD 2) high-4b + (.visitInsn Opcodes/LDIV) + (.visitLdcInsn (int 32)) + (.visitInsn Opcodes/LSHL) + (.visitInsn Opcodes/LRETURN) + (.visitMaxs 0 0) + (.visitEnd)) + _ (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "frac-to-real" "(J)D" nil nil) + (.visitCode) + ;; Translate high bytes + (.visitVarInsn Opcodes/LLOAD 0) high-4b + (.visitInsn Opcodes/L2D) + (.visitLdcInsn (double (Math/pow 2 32))) + (.visitInsn Opcodes/DDIV) + ;; Translate low bytes + (.visitVarInsn Opcodes/LLOAD 0) low-4b + (.visitInsn Opcodes/L2D) + (.visitLdcInsn (double (Math/pow 2 32))) + (.visitInsn Opcodes/DDIV) + (.visitLdcInsn (double (Math/pow 2 32))) + (.visitInsn Opcodes/DDIV) + ;; Combine and return + (.visitInsn Opcodes/DADD) + (.visitInsn Opcodes/DRETURN) + (.visitMaxs 0 0) + (.visitEnd)) + _ (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "real-to-frac" "(D)J" nil nil) + (.visitCode) + ;; Drop any excess + (.visitVarInsn Opcodes/DLOAD 0) + (.visitLdcInsn (double 1.0)) + (.visitInsn Opcodes/DREM) + ;; Shift upper half, but retain remaining decimals + (.visitLdcInsn (double (Math/pow 2 32))) + (.visitInsn Opcodes/DMUL) + ;; Make a copy, so the lower half can be extracted + (.visitInsn Opcodes/DUP2) + ;; Get that lower half + (.visitLdcInsn (double 1.0)) + (.visitInsn Opcodes/DREM) + (.visitLdcInsn (double (Math/pow 2 32))) + (.visitInsn Opcodes/DMUL) + ;; Turn it into a frac + (.visitInsn Opcodes/D2L) + ;; Turn the upper half into frac too + swap2 + (.visitInsn Opcodes/D2L) + ;; Combine both pieces + (.visitInsn Opcodes/LADD) + ;; FINISH + (.visitInsn Opcodes/LRETURN) + (.visitMaxs 0 0) + (.visitEnd)) + _ (let [$start (new Label) + $body (new Label) + $end (new Label) + $zero (new Label)] + (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "count_bin_start_0" "(J)I" nil nil) + (.visitCode) + ;; Initialize counter + (.visitLdcInsn (int 0)) ; I + (.visitVarInsn Opcodes/ISTORE 2) ; + ;; Initialize index var + (.visitLdcInsn (int 63)) ; I + ;; Begin loop + (.visitLabel $start) ; I + ;; Make sure we're still on the valid index range + (.visitInsn Opcodes/DUP) ; I, I + (.visitLdcInsn (int -1)) ; I, I, I + (.visitJumpInsn Opcodes/IF_ICMPGT $body) ; I + ;; If not, just return what we've got. + (.visitInsn Opcodes/POP) ; + (.visitVarInsn Opcodes/ILOAD 2) ; I + (.visitJumpInsn Opcodes/GOTO $end) + ;; If so, run the body + (.visitLabel $body) ;; I + (.visitInsn Opcodes/DUP) ;; I, I + (.visitVarInsn Opcodes/LLOAD 0) ;; I, I, L + (.visitInsn Opcodes/DUP2_X1) ;; I, L, I, L + (.visitInsn Opcodes/POP2) ;; I, L, I + bit-set-64? ;; I, I + (.visitJumpInsn Opcodes/IFEQ $zero) ;; I + ;; No more zeroes from now on... + (.visitInsn Opcodes/POP) ;; + (.visitVarInsn Opcodes/ILOAD 2) ;; I + (.visitJumpInsn Opcodes/GOTO $end) + ;; Found another zero... + (.visitLabel $zero) ;; I + ;; Increase counter + (.visitVarInsn Opcodes/ILOAD 2) ;; I, I + (.visitLdcInsn (int 1)) ;; I, I, I + (.visitInsn Opcodes/IADD) ;; I, I + (.visitVarInsn Opcodes/ISTORE 2) ;; I + ;; Increase index, then iterate again... + (.visitLdcInsn (int 1)) ;; I, I + (.visitInsn Opcodes/ISUB) ;; I + (.visitJumpInsn Opcodes/GOTO $start) + ;; Finally, return + (.visitLabel $end) ; I + (.visitInsn Opcodes/IRETURN) + (.visitMaxs 0 0) + (.visitEnd))) + _ (let [$start (new Label) + $can-append (new Label) + $end (new Label)] + (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "make_text_start_0" "(J)Ljava/lang/String;" nil nil) + (.visitCode) + ;; Initialize accum + (.visitLdcInsn "") ;; S + (.visitVarInsn Opcodes/ASTORE 2) ;; + ;; Initialize comparator + (.visitLdcInsn (long 10)) ;; L + ;; Testing/accum loop + (.visitLabel $start) ;; L + (.visitInsn Opcodes/DUP2) ;; L, L + (.visitVarInsn Opcodes/LLOAD 0) ;; L, L, L + (.visitInsn Opcodes/LCMP) ;; L, I + (.visitJumpInsn Opcodes/IFLT $can-append) ;; L + ;; No more testing. + ;; Throw away the comparator and return accum. + (.visitInsn Opcodes/POP2) ;; + (.visitVarInsn Opcodes/ALOAD 2) ;; S + (.visitJumpInsn Opcodes/GOTO $end) + ;; Can keep accumulating + (.visitLabel $can-append) ;; L + ;; Add one more 0 to accum + (.visitVarInsn Opcodes/ALOAD 2) ;; L, S + (.visitLdcInsn "0") ;; L, S, S + (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "concat" "(Ljava/lang/String;)Ljava/lang/String;") ;; L, S + (.visitVarInsn Opcodes/ASTORE 2) ;; L + ;; Update comparator and re-iterate + (.visitLdcInsn (long 10)) ;; L, L + (.visitInsn Opcodes/LMUL) ;; L + (.visitJumpInsn Opcodes/GOTO $start) + (.visitLabel $end) ;; S + (.visitInsn Opcodes/ARETURN) + (.visitMaxs 0 0) + (.visitEnd))) + _ (let [$is-zero (new Label) + $end (new Label)] + (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "encode_frac" "(J)Ljava/lang/String;" nil nil) + (.visitCode) + (.visitVarInsn Opcodes/LLOAD 0) + (.visitLdcInsn (long 0)) + (.visitInsn Opcodes/LCMP) + (.visitJumpInsn Opcodes/IFEQ $is-zero) + ;; IF =/= 0 + ;; Generate leading 0s + (.visitLdcInsn (long 1)) + (.visitVarInsn Opcodes/LLOAD 0) + (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "count_bin_start_0" "(J)I") + (.visitInsn Opcodes/LSHL) + (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "make_text_start_0" "(J)Ljava/lang/String;") + ;; Convert to number text + (.visitVarInsn Opcodes/LLOAD 0) + (.visitMethodInsn Opcodes/INVOKESTATIC "java/lang/Long" "toUnsignedString" "(J)Ljava/lang/String;") + ;; Remove unnecessary trailing zeroes + (.visitLdcInsn "0*$") + (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "split" "(Ljava/lang/String;)[Ljava/lang/String;") + (.visitLdcInsn (int 0)) + (.visitInsn Opcodes/AALOAD) + ;; Join leading 0s with number text + (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "concat" "(Ljava/lang/String;)Ljava/lang/String;") + ;; FINISH + (.visitJumpInsn Opcodes/GOTO $end) + ;; IF == 0 + (.visitLabel $is-zero) + (.visitLdcInsn ".0") + (.visitLabel $end) + (.visitInsn Opcodes/ARETURN) + (.visitMaxs 0 0) + (.visitEnd))) + _ (let [$end (new Label) + ;; $then (new Label) + $else (new Label) + $from (new Label) + $to (new Label) + $handler (new Label)] + (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "decode_frac" "(Ljava/lang/String;)Ljava/lang/Object;" nil nil) + (.visitCode) + ;; Check prefix + (.visitVarInsn Opcodes/ALOAD 0) + (.visitLdcInsn ".") + (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "startsWith" "(Ljava/lang/String;)Z") + (.visitJumpInsn Opcodes/IFEQ $else) + ;; Remove prefix + (.visitVarInsn Opcodes/ALOAD 0) + (.visitLdcInsn (int 1)) + (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "substring" "(I)Ljava/lang/String;") + (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "clean_separators" "(Ljava/lang/String;)Ljava/lang/String;") + (.visitInsn Opcodes/DUP) + (.visitTryCatchBlock $from $to $handler "java/lang/Exception") + (.visitLabel $from) + (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "read_frac_text" "(Ljava/lang/String;)J") + (.visitLabel $to) + (.visitInsn Opcodes/DUP2) + (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "count_bin_start_0" "(J)I") + (.visitInsn Opcodes/LSHL) + (.visitInsn Opcodes/DUP2_X1) + (.visitInsn Opcodes/POP2) + (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "count_leading_zeroes" "(Ljava/lang/String;)J") + (.visitInsn Opcodes/L2D) + (.visitLdcInsn (double 10.0)) + swap2 + (.visitMethodInsn Opcodes/INVOKESTATIC "java/lang/Math" "pow" "(DD)D") + (.visitInsn Opcodes/D2L) + (.visitInsn Opcodes/LDIV) + ;; (.visitJumpInsn Opcodes/GOTO $then) + ;; (.visitLabel $then) + (&&/wrap-long) + (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "make_some" "(Ljava/lang/Object;)Ljava/lang/Object;") + (.visitFrame Opcodes/F_NEW 1 (to-array ["java/lang/String"]) 1 (to-array ["java/lang/Object"])) + (.visitJumpInsn Opcodes/GOTO $end) + (.visitLabel $handler) + (.visitFrame Opcodes/F_NEW 1 (to-array ["java/lang/String"]) 1 (to-array ["java/lang/Exception"])) + (.visitInsn Opcodes/POP) + (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "make_none" "()Ljava/lang/Object;") + (.visitFrame Opcodes/F_NEW 1 (to-array ["java/lang/String"]) 1 (to-array ["java/lang/Object"])) + (.visitJumpInsn Opcodes/GOTO $end) + ;; Doesn't start with necessary prefix. + (.visitLabel $else) + (.visitFrame Opcodes/F_NEW 1 (to-array ["java/lang/String"]) 0 (to-array [])) + (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "make_none" "()Ljava/lang/Object;") + (.visitLabel $end) + (.visitFrame Opcodes/F_NEW 1 (to-array ["java/lang/String"]) 1 (to-array ["java/lang/Object"])) + (.visitInsn Opcodes/ARETURN) + (.visitMaxs 0 0) + (.visitEnd))) + _ (let [string-bcn (&host-generics/->bytecode-class-name "java.lang.String") + $valid (new Label) + $end (new Label)] + (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "count_leading_zeroes" "(Ljava/lang/String;)J" nil nil) + (.visitCode) + (.visitVarInsn Opcodes/ALOAD 0) ;; S + (.visitLdcInsn "^0*") ;; S, S + (.visitMethodInsn Opcodes/INVOKEVIRTUAL string-bcn "split" "(Ljava/lang/String;)[Ljava/lang/String;") ;; [S + (.visitInsn Opcodes/DUP) ;; [S, [S + (.visitInsn Opcodes/ARRAYLENGTH) ;; [S, I + (.visitLdcInsn (int 2)) ;; [S, I, I + (.visitJumpInsn Opcodes/IF_ICMPEQ $valid) ;; [S + ;; Invalid... + (.visitInsn Opcodes/POP) ;; + (.visitLdcInsn (long 0)) ;; J + (.visitJumpInsn Opcodes/GOTO $end) + (.visitLabel $valid) ;; [S + ;; Valid... + (.visitLdcInsn (int 1)) ;; [S, I + (.visitInsn Opcodes/AALOAD) ;; S + (.visitMethodInsn Opcodes/INVOKEVIRTUAL string-bcn "length" "()I") ;; I + (.visitVarInsn Opcodes/ALOAD 0) ;; I, S + (.visitMethodInsn Opcodes/INVOKEVIRTUAL string-bcn "length" "()I") ;; I, I + (.visitInsn Opcodes/SWAP) ;; I, I + (.visitInsn Opcodes/ISUB) ;; I + (.visitInsn Opcodes/I2L) ;; J + (.visitLabel $end) ;; J + (.visitInsn Opcodes/LRETURN) + (.visitMaxs 0 0) + (.visitEnd))) + _ (let [$only-zeroes (new Label) + $end (new Label)] + (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "read_frac_text" "(Ljava/lang/String;)J" nil nil) + (.visitCode) + (.visitVarInsn Opcodes/ALOAD 0) + (.visitLdcInsn "0*$") + (.visitMethodInsn Opcodes/INVOKEVIRTUAL + (&host-generics/->bytecode-class-name "java.lang.String") + "split" "(Ljava/lang/String;)[Ljava/lang/String;") + (.visitInsn Opcodes/DUP) + (.visitInsn Opcodes/ARRAYLENGTH) + (.visitJumpInsn Opcodes/IFEQ $only-zeroes) + (.visitLdcInsn (int 0)) + (.visitInsn Opcodes/AALOAD) + (.visitMethodInsn Opcodes/INVOKESTATIC "java/lang/Long" "parseUnsignedLong" "(Ljava/lang/String;)J") + (.visitJumpInsn Opcodes/GOTO $end) + (.visitLabel $only-zeroes) + (.visitInsn Opcodes/POP) + (.visitVarInsn Opcodes/ALOAD 0) + (.visitMethodInsn Opcodes/INVOKESTATIC "java/lang/Long" "parseUnsignedLong" "(Ljava/lang/String;)J") + (.visitLabel $end) + (.visitInsn Opcodes/LRETURN) + (.visitMaxs 0 0) + (.visitEnd))) + ] + nil)) + +(let [+wrapper-class+ (&host-generics/->bytecode-class-name "java.lang.Long")] + (defn ^:private compile-LuxRT-nat-methods [^ClassWriter =class] + (|let [;; http://grepcode.com/file/repository.grepcode.com/java/root/jdk/openjdk/8u40-b25/java/lang/Long.java#677 + _ (let [$from (new Label) + $to (new Label) + $handler (new Label) + + $good-start (new Label) + $short-enough (new Label) + $bad-digit (new Label) + $out-of-bounds (new Label)] + (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "decode_nat" "(Ljava/lang/String;)Ljava/lang/Object;" nil nil) + (.visitCode) + (.visitTryCatchBlock $from $to $handler "java/lang/Exception") + (.visitLabel $from) + ;; Remove the + at the beginning... + (.visitVarInsn Opcodes/ALOAD 0) + (.visitLdcInsn (int 0)) + (.visitLdcInsn (int 0)) + (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "substring" "(II)Ljava/lang/String;") + (.visitLdcInsn "+") + (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/Object" "equals" "(Ljava/lang/Object;)Z") + (.visitJumpInsn Opcodes/IFNE $good-start) + ;; Doesn't start with + + (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "make_none" "()Ljava/lang/Object;") + (.visitInsn Opcodes/ARETURN) + ;; Starts with + + (.visitLabel $good-start) + (.visitVarInsn Opcodes/ALOAD 0) + (.visitLdcInsn (int 1)) + (.visitVarInsn Opcodes/ALOAD 0) + (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "length" "()I") + (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "substring" "(II)Ljava/lang/String;") + (.visitVarInsn Opcodes/ASTORE 0) ;; Removed the + prefix... + ;; Begin parsing processs + (.visitVarInsn Opcodes/ALOAD 0) + (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "length" "()I") + (.visitLdcInsn (int 18)) + (.visitJumpInsn Opcodes/IF_ICMPLE $short-enough) + ;; Too long + ;; Get prefix... + (.visitVarInsn Opcodes/ALOAD 0) + (.visitLdcInsn (int 0)) + (.visitVarInsn Opcodes/ALOAD 0) + (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "length" "()I") + (.visitLdcInsn (int 1)) + (.visitInsn Opcodes/ISUB) + (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "substring" "(II)Ljava/lang/String;") + (.visitMethodInsn Opcodes/INVOKESTATIC "java/lang/Long" "parseLong" "(Ljava/lang/String;)J") + (.visitInsn Opcodes/DUP2) ;; Clone prefix, for later... + ;; Get last digit... + (.visitVarInsn Opcodes/ALOAD 0) + (.visitVarInsn Opcodes/ALOAD 0) + (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "length" "()I") + (.visitLdcInsn (int 1)) + (.visitInsn Opcodes/ISUB) + (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "charAt" "(I)C") + (.visitLdcInsn (int 10)) + (.visitMethodInsn Opcodes/INVOKESTATIC "java/lang/Character" "digit" "(CI)I") + ;; Test last digit... + (.visitInsn Opcodes/DUP) + (.visitJumpInsn Opcodes/IFLT $bad-digit) + ;; Good digit... + ;; Stack: prefix::L, prefix::L, last-digit::I + (.visitInsn Opcodes/I2L) + ;; Build the result... + swap2 + (.visitLdcInsn (long 10)) + (.visitInsn Opcodes/LMUL) + (.visitInsn Opcodes/LADD) ;; Stack: prefix::L, result::L + (.visitInsn Opcodes/DUP2_X2) ;; Stack: result::L, prefix::L, result::L + swap2 ;; Stack: result::L, result::L, prefix::L + (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "_compareUnsigned" "(JJ)I") + (.visitJumpInsn Opcodes/IFLT $out-of-bounds) + ;; Within bounds + ;; Stack: result::L + &&/wrap-long + (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "make_some" "(Ljava/lang/Object;)Ljava/lang/Object;") + (.visitInsn Opcodes/ARETURN) + ;; Out of bounds + (.visitLabel $out-of-bounds) + (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "make_none" "()Ljava/lang/Object;") + (.visitInsn Opcodes/ARETURN) + ;; Bad digit... + (.visitLabel $bad-digit) + (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "make_none" "()Ljava/lang/Object;") + (.visitInsn Opcodes/ARETURN) + ;; 18 chars or less + (.visitLabel $short-enough) + (.visitVarInsn Opcodes/ALOAD 0) + (.visitMethodInsn Opcodes/INVOKESTATIC "java/lang/Long" "parseLong" "(Ljava/lang/String;)J") + &&/wrap-long + (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "make_some" "(Ljava/lang/Object;)Ljava/lang/Object;") + (.visitInsn Opcodes/ARETURN) + (.visitLabel $to) + (.visitLabel $handler) + (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "make_none" "()Ljava/lang/Object;") + (.visitInsn Opcodes/ARETURN) + (.visitMaxs 0 0) + (.visitEnd))) + ;; http://grepcode.com/file/repository.grepcode.com/java/root/jdk/openjdk/8u40-b25/java/lang/Long.java#172 + _ (let [$too-big (new Label)] + (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "encode_nat" "(J)Ljava/lang/String;" nil nil) + (.visitCode) + (.visitLdcInsn "+") + (.visitVarInsn Opcodes/LLOAD 0) + (.visitLdcInsn (long 0)) + (.visitInsn Opcodes/LCMP) + (.visitJumpInsn Opcodes/IFLT $too-big) + ;; then + (.visitVarInsn Opcodes/LLOAD 0) + (.visitMethodInsn Opcodes/INVOKESTATIC "java/lang/Long" "toString" "(J)Ljava/lang/String;") + (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "concat" "(Ljava/lang/String;)Ljava/lang/String;") + (.visitInsn Opcodes/ARETURN) + ;; else + (.visitLabel $too-big) + ;; Set up parts of the number string... + ;; First digits + (.visitVarInsn Opcodes/LLOAD 0) + (.visitLdcInsn (int 1)) + (.visitInsn Opcodes/LUSHR) + (.visitLdcInsn (long 5)) + (.visitInsn Opcodes/LDIV) ;; quot + ;; Last digit + (.visitInsn Opcodes/DUP2) + (.visitLdcInsn (long 10)) + (.visitInsn Opcodes/LMUL) + (.visitVarInsn Opcodes/LLOAD 0) + swap2 + (.visitInsn Opcodes/LSUB) ;; quot, rem + ;; Conversion to string... + (.visitMethodInsn Opcodes/INVOKESTATIC "java/lang/Long" "toString" "(J)Ljava/lang/String;") ;; quot, rem* + (.visitInsn Opcodes/DUP_X2);; rem*, quot, rem* + (.visitInsn Opcodes/POP) ;; rem*, quot + (.visitMethodInsn Opcodes/INVOKESTATIC "java/lang/Long" "toString" "(J)Ljava/lang/String;") ;; rem*, quot* + (.visitInsn Opcodes/SWAP) ;; quot*, rem* + (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "concat" "(Ljava/lang/String;)Ljava/lang/String;") + (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "concat" "(Ljava/lang/String;)Ljava/lang/String;") + (.visitInsn Opcodes/ARETURN) + (.visitMaxs 0 0) + (.visitEnd))) + ;; http://grepcode.com/file/repository.grepcode.com/java/root/jdk/openjdk/8u40-b25/java/lang/Long.java#215 + _ (let [$simple-case (new Label)] + (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "_toUnsignedBigInteger" "(J)Ljava/math/BigInteger;" nil nil) + (.visitCode) + (.visitVarInsn Opcodes/LLOAD 0) + (.visitLdcInsn (long 0)) + (.visitInsn Opcodes/LCMP) + (.visitJumpInsn Opcodes/IFGE $simple-case) + ;; else + (.visitVarInsn Opcodes/LLOAD 0) + (.visitLdcInsn (int 32)) + (.visitInsn Opcodes/LUSHR) + (.visitMethodInsn Opcodes/INVOKESTATIC "java/math/BigInteger" "valueOf" "(J)Ljava/math/BigInteger;") + (.visitLdcInsn (int 32)) + (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/math/BigInteger" "shiftLeft" "(I)Ljava/math/BigInteger;") + (.visitVarInsn Opcodes/LLOAD 0) + (.visitLdcInsn (int 32)) + (.visitInsn Opcodes/LSHL) + (.visitLdcInsn (int 32)) + (.visitInsn Opcodes/LUSHR) + (.visitMethodInsn Opcodes/INVOKESTATIC "java/math/BigInteger" "valueOf" "(J)Ljava/math/BigInteger;") + (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/math/BigInteger" "add" "(Ljava/math/BigInteger;)Ljava/math/BigInteger;") + (.visitInsn Opcodes/ARETURN) + ;; then + (.visitLabel $simple-case) + (.visitVarInsn Opcodes/LLOAD 0) + (.visitMethodInsn Opcodes/INVOKESTATIC "java/math/BigInteger" "valueOf" "(J)Ljava/math/BigInteger;") + (.visitInsn Opcodes/ARETURN) + (.visitMaxs 0 0) + (.visitEnd))) + ;; http://grepcode.com/file/repository.grepcode.com/java/root/jdk/openjdk/8u40-b25/java/lang/Long.java?av=f#1267 + _ (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "_compareUnsigned" "(JJ)I" nil nil) + (.visitCode) + (.visitVarInsn Opcodes/LLOAD 0) + (.visitFieldInsn Opcodes/GETSTATIC "java/lang/Long" "MIN_VALUE" "J") + (.visitInsn Opcodes/LADD) + (.visitVarInsn Opcodes/LLOAD 2) + (.visitFieldInsn Opcodes/GETSTATIC "java/lang/Long" "MIN_VALUE" "J") + (.visitInsn Opcodes/LADD) + (.visitInsn Opcodes/LCMP) + (.visitInsn Opcodes/IRETURN) + (.visitMaxs 0 0) + (.visitEnd)) + ;; http://grepcode.com/file/repository.grepcode.com/java/root/jdk/openjdk/8u40-b25/java/lang/Long.java#1290 + _ (let [$case-1 (new Label) + $0 (new Label) + $case-2 (new Label)] + (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "div_nat" "(JJ)J" nil nil) + (.visitCode) + ;; Test #1 + (.visitVarInsn Opcodes/LLOAD 2) + (.visitLdcInsn (long 0)) + (.visitInsn Opcodes/LCMP) + (.visitJumpInsn Opcodes/IFLT $case-1) + ;; Test #2 + (.visitVarInsn Opcodes/LLOAD 0) + (.visitLdcInsn (long 0)) + (.visitInsn Opcodes/LCMP) + (.visitJumpInsn Opcodes/IFGT $case-2) + ;; Case #3 + (.visitVarInsn Opcodes/LLOAD 0) + (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "_toUnsignedBigInteger" "(J)Ljava/math/BigInteger;") + (.visitVarInsn Opcodes/LLOAD 2) + (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "_toUnsignedBigInteger" "(J)Ljava/math/BigInteger;") + (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/math/BigInteger" "divide" "(Ljava/math/BigInteger;)Ljava/math/BigInteger;") + (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/math/BigInteger" "longValue" "()J") + (.visitInsn Opcodes/LRETURN) + ;; Case #2 + (.visitLabel $case-2) + (.visitVarInsn Opcodes/LLOAD 0) + (.visitVarInsn Opcodes/LLOAD 2) + (.visitInsn Opcodes/LDIV) + (.visitInsn Opcodes/LRETURN) + ;; Case #1 + (.visitLabel $case-1) + (.visitVarInsn Opcodes/LLOAD 0) + (.visitVarInsn Opcodes/LLOAD 2) + (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "_compareUnsigned" "(JJ)I") + (.visitJumpInsn Opcodes/IFLT $0) + ;; 1 + (.visitLdcInsn (long 1)) + (.visitInsn Opcodes/LRETURN) + ;; 0 + (.visitLabel $0) + (.visitLdcInsn (long 0)) + (.visitInsn Opcodes/LRETURN) + (.visitMaxs 0 0) + (.visitEnd))) + ;; http://grepcode.com/file/repository.grepcode.com/java/root/jdk/openjdk/8u40-b25/java/lang/Long.java#1323 + _ (let [$test-2 (new Label) + $case-2 (new Label)] + (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "rem_nat" "(JJ)J" nil nil) + (.visitCode) + ;; Test #1 + (.visitVarInsn Opcodes/LLOAD 0) + (.visitLdcInsn (long 0)) + (.visitInsn Opcodes/LCMP) + (.visitJumpInsn Opcodes/IFLE $test-2) + (.visitVarInsn Opcodes/LLOAD 2) + (.visitLdcInsn (long 0)) + (.visitInsn Opcodes/LCMP) + (.visitJumpInsn Opcodes/IFLE $test-2) + ;; Case #1 + (.visitVarInsn Opcodes/LLOAD 0) + (.visitVarInsn Opcodes/LLOAD 2) + (.visitInsn Opcodes/LREM) + (.visitInsn Opcodes/LRETURN) + ;; Test #2 + (.visitLabel $test-2) + (.visitVarInsn Opcodes/LLOAD 0) + (.visitVarInsn Opcodes/LLOAD 2) + (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "_compareUnsigned" "(JJ)I") + (.visitJumpInsn Opcodes/IFLT $case-2) + ;; Case #3 + (.visitVarInsn Opcodes/LLOAD 0) + (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "_toUnsignedBigInteger" "(J)Ljava/math/BigInteger;") + (.visitVarInsn Opcodes/LLOAD 2) + (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "_toUnsignedBigInteger" "(J)Ljava/math/BigInteger;") + (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/math/BigInteger" "remainder" "(Ljava/math/BigInteger;)Ljava/math/BigInteger;") + (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/math/BigInteger" "longValue" "()J") + (.visitInsn Opcodes/LRETURN) + ;; Case #2 + (.visitLabel $case-2) + (.visitVarInsn Opcodes/LLOAD 0) + (.visitInsn Opcodes/LRETURN) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + (.visitMaxs 0 0) + (.visitEnd)))] + nil))) + +(defn ^:private compile-LuxRT-pm-methods [^ClassWriter =class] + (|let [_ (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "pm_fail" "()V" nil nil) + (.visitCode) + (.visitTypeInsn Opcodes/NEW "java/lang/IllegalStateException") + (.visitInsn Opcodes/DUP) + (.visitLdcInsn "Invalid expression for pattern-matching.") + (.visitMethodInsn Opcodes/INVOKESPECIAL "java/lang/IllegalStateException" "<init>" "(Ljava/lang/String;)V") + (.visitInsn Opcodes/ATHROW) + (.visitMaxs 0 0) + (.visitEnd)) + _ (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "pm_stack_push" "([Ljava/lang/Object;Ljava/lang/Object;)[Ljava/lang/Object;" nil nil) + (.visitCode) + (.visitLdcInsn (int 2)) + (.visitTypeInsn Opcodes/ANEWARRAY "java/lang/Object") + (.visitInsn Opcodes/DUP) + (.visitLdcInsn (int 0)) + (.visitVarInsn Opcodes/ALOAD 0) + (.visitInsn Opcodes/AASTORE) + (.visitInsn Opcodes/DUP) + (.visitLdcInsn (int 1)) + (.visitVarInsn Opcodes/ALOAD 1) + (.visitInsn Opcodes/AASTORE) + (.visitInsn Opcodes/ARETURN) + (.visitMaxs 0 0) + (.visitEnd)) + _ (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "pm_stack_pop" "([Ljava/lang/Object;)[Ljava/lang/Object;" nil nil) + (.visitCode) + (.visitVarInsn Opcodes/ALOAD 0) + (.visitLdcInsn (int 0)) + (.visitInsn Opcodes/AALOAD) + (.visitTypeInsn Opcodes/CHECKCAST "[Ljava/lang/Object;") + (.visitInsn Opcodes/ARETURN) + (.visitMaxs 0 0) + (.visitEnd)) + _ (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "pm_stack_peek" "([Ljava/lang/Object;)Ljava/lang/Object;" nil nil) + (.visitCode) + (.visitVarInsn Opcodes/ALOAD 0) + (.visitLdcInsn (int 1)) + (.visitInsn Opcodes/AALOAD) + (.visitInsn Opcodes/ARETURN) + (.visitMaxs 0 0) + (.visitEnd))] + nil)) + +(def compile-LuxRT-class + (|do [_ (return nil) + :let [full-name &&/lux-utils-class + super-class (&host-generics/->bytecode-class-name "java.lang.Object") + tag-sig (&host-generics/->type-signature "java.lang.String") + =class (doto (new ClassWriter ClassWriter/COMPUTE_MAXS) + (.visit &host/bytecode-version (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_SUPER) + full-name nil super-class (into-array String []))) + =unit-tag (doto (.visitField =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) &&/unit-tag-field tag-sig nil &/unit-tag) + (.visitEnd)) + =init-method (doto (.visitMethod =class Opcodes/ACC_PRIVATE init-method "()V" nil nil) + (.visitCode) + (.visitVarInsn Opcodes/ALOAD 0) + (.visitMethodInsn Opcodes/INVOKESPECIAL super-class init-method "()V") + (.visitInsn Opcodes/RETURN) + (.visitMaxs 0 0) + (.visitEnd)) + _ (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "log" "(Ljava/lang/Object;)Ljava/lang/Object;" nil nil) + (.visitCode) + (.visitFieldInsn Opcodes/GETSTATIC "java/lang/System" "out" "Ljava/io/PrintStream;") + (.visitLdcInsn "LOG: ") + (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/io/PrintStream" "print" "(Ljava/lang/Object;)V") + (.visitFieldInsn Opcodes/GETSTATIC "java/lang/System" "out" "Ljava/io/PrintStream;") + (.visitVarInsn Opcodes/ALOAD 0) + (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/io/PrintStream" "println" "(Ljava/lang/Object;)V") + (.visitVarInsn Opcodes/ALOAD 0) + (.visitInsn Opcodes/ARETURN) + (.visitMaxs 0 0) + (.visitEnd)) + _ (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "make_none" "()Ljava/lang/Object;" nil nil) + (.visitCode) + (.visitLdcInsn (->> #'&/$None meta ::&/idx int)) ;; I + (.visitInsn Opcodes/ACONST_NULL) ;; I? + (.visitLdcInsn &/unit-tag) ;; I?U + (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "sum_make" "(ILjava/lang/Object;Ljava/lang/Object;)[Ljava/lang/Object;") + (.visitInsn Opcodes/ARETURN) + (.visitMaxs 0 0) + (.visitEnd)) + _ (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "make_some" "(Ljava/lang/Object;)Ljava/lang/Object;" nil nil) + (.visitCode) + (.visitLdcInsn (->> #'&/$Some meta ::&/idx int)) ;; I + (.visitInsn Opcodes/ACONST_NULL) ;; I? + (.visitVarInsn Opcodes/ALOAD 0) ;; I?O + (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "sum_make" "(ILjava/lang/Object;Ljava/lang/Object;)[Ljava/lang/Object;") + (.visitInsn Opcodes/ARETURN) + (.visitMaxs 0 0) + (.visitEnd)) + _ (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "clean_separators" "(Ljava/lang/String;)Ljava/lang/String;" nil nil) + (.visitCode) + (.visitVarInsn Opcodes/ALOAD 0) + (.visitLdcInsn ",|_") + (.visitLdcInsn "") + (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "replaceAll" "(Ljava/lang/String;Ljava/lang/String;)Ljava/lang/String;") + (.visitInsn Opcodes/ARETURN) + (.visitMaxs 0 0) + (.visitEnd)) + _ (doto =class + (compile-LuxRT-pm-methods) + (compile-LuxRT-adt-methods) + (compile-LuxRT-nat-methods) + (compile-LuxRT-frac-methods))]] + (&&/save-class! (second (string/split &&/lux-utils-class #"/")) + (.toByteArray (doto =class .visitEnd))))) + +(defn ^:private compile-jvm-try [compile ?values special-args] + (|do [:let [(&/$Cons ?body (&/$Cons ?catch (&/$Nil))) ?values + ;; (&/$Nil) special-args + ] + ^MethodVisitor *writer* &/get-writer + :let [$from (new Label) + $to (new Label) + $handler (new Label) + $end (new Label)] + :let [_ (doto *writer* + (.visitTryCatchBlock $from $to $handler "java/lang/Exception") + (.visitLabel $from))] + _ (compile ?body) + :let [_ (doto *writer* + (.visitJumpInsn Opcodes/GOTO $end) + (.visitLabel $to) + (.visitLabel $handler))] + _ (compile ?catch) + :let [_ (doto *writer* + (.visitTypeInsn Opcodes/CHECKCAST &&/function-class) + (.visitInsn Opcodes/SWAP) + (.visitMethodInsn Opcodes/INVOKEVIRTUAL &&/function-class &&/apply-method (&&/apply-signature 1)))] + :let [_ (.visitLabel *writer* $end)]] + (return nil))) + +(do-template [<name> <op> <from-class> <from-method> <from-sig> <to-class> <to-sig>] + (defn <name> [compile _?value special-args] + (|do [:let [(&/$Cons ?value (&/$Nil)) _?value] + ^MethodVisitor *writer* &/get-writer + :let [_ (doto *writer* + (.visitTypeInsn Opcodes/NEW (&host-generics/->bytecode-class-name <to-class>)) + (.visitInsn Opcodes/DUP))] + _ (compile ?value) + :let [_ (doto *writer* + (.visitTypeInsn Opcodes/CHECKCAST (&host-generics/->bytecode-class-name <from-class>)) + (.visitMethodInsn Opcodes/INVOKEVIRTUAL (&host-generics/->bytecode-class-name <from-class>) <from-method> <from-sig>) + (.visitInsn <op>) + (.visitMethodInsn Opcodes/INVOKESPECIAL (&host-generics/->bytecode-class-name <to-class>) init-method <to-sig>))]] + (return nil))) + + ^:private compile-jvm-d2f Opcodes/D2F "java.lang.Double" "doubleValue" "()D" "java.lang.Float" "(F)V" + ^:private compile-jvm-d2i Opcodes/D2I "java.lang.Double" "doubleValue" "()D" "java.lang.Integer" "(I)V" + ^:private compile-jvm-d2l Opcodes/D2L "java.lang.Double" "doubleValue" "()D" "java.lang.Long" "(J)V" + + ^:private compile-jvm-f2d Opcodes/F2D "java.lang.Float" "floatValue" "()F" "java.lang.Double" "(D)V" + ^:private compile-jvm-f2i Opcodes/F2I "java.lang.Float" "floatValue" "()F" "java.lang.Integer" "(I)V" + ^:private compile-jvm-f2l Opcodes/F2L "java.lang.Float" "floatValue" "()F" "java.lang.Long" "(J)V" + + ^:private compile-jvm-i2b Opcodes/I2B "java.lang.Integer" "intValue" "()I" "java.lang.Byte" "(B)V" + ^:private compile-jvm-i2c Opcodes/I2C "java.lang.Integer" "intValue" "()I" "java.lang.Character" "(C)V" + ^:private compile-jvm-i2d Opcodes/I2D "java.lang.Integer" "intValue" "()I" "java.lang.Double" "(D)V" + ^:private compile-jvm-i2f Opcodes/I2F "java.lang.Integer" "intValue" "()I" "java.lang.Float" "(F)V" + ^:private compile-jvm-i2l Opcodes/I2L "java.lang.Integer" "intValue" "()I" "java.lang.Long" "(J)V" + ^:private compile-jvm-i2s Opcodes/I2S "java.lang.Integer" "intValue" "()I" "java.lang.Short" "(S)V" + + ^:private compile-jvm-l2d Opcodes/L2D "java.lang.Long" "longValue" "()J" "java.lang.Double" "(D)V" + ^:private compile-jvm-l2f Opcodes/L2F "java.lang.Long" "longValue" "()J" "java.lang.Float" "(F)V" + ^:private compile-jvm-l2i Opcodes/L2I "java.lang.Long" "longValue" "()J" "java.lang.Integer" "(I)V" + ^:private compile-jvm-l2s Opcodes/L2I "java.lang.Long" "longValue" "()J" "java.lang.Short" "(S)V" + ^:private compile-jvm-l2b Opcodes/L2I "java.lang.Long" "longValue" "()J" "java.lang.Byte" "(B)V" + + ^:private compile-jvm-c2b Opcodes/I2B "java.lang.Character" "charValue" "()C" "java.lang.Byte" "(B)V" + ^:private compile-jvm-c2s Opcodes/I2S "java.lang.Character" "charValue" "()C" "java.lang.Short" "(S)V" + ^:private compile-jvm-c2i Opcodes/NOP "java.lang.Character" "charValue" "()C" "java.lang.Integer" "(I)V" + ^:private compile-jvm-c2l Opcodes/I2L "java.lang.Character" "charValue" "()C" "java.lang.Long" "(J)V" + + ^:private compile-jvm-s2l Opcodes/I2L "java.lang.Short" "shortValue" "()S" "java.lang.Long" "(J)V" + + ^:private compile-jvm-b2l Opcodes/I2L "java.lang.Byte" "byteValue" "()B" "java.lang.Long" "(J)V" + ) + +(do-template [<name> <op> <from1-method> <from1-sig> <from1-class> <from2-method> <from2-sig> <from2-class> <to-class> <to-sig>] + (defn <name> [compile ?values special-args] + (|do [:let [(&/$Cons ?x (&/$Cons ?y (&/$Nil))) ?values] + ^MethodVisitor *writer* &/get-writer + :let [_ (doto *writer* + (.visitTypeInsn Opcodes/NEW (&host-generics/->bytecode-class-name <to-class>)) + (.visitInsn Opcodes/DUP))] + _ (compile ?x) + :let [_ (doto *writer* + (.visitTypeInsn Opcodes/CHECKCAST (&host-generics/->bytecode-class-name <from1-class>)) + (.visitMethodInsn Opcodes/INVOKEVIRTUAL (&host-generics/->bytecode-class-name <from1-class>) <from1-method> <from1-sig>))] + _ (compile ?y) + :let [_ (doto *writer* + (.visitTypeInsn Opcodes/CHECKCAST (&host-generics/->bytecode-class-name <from2-class>)) + (.visitMethodInsn Opcodes/INVOKEVIRTUAL (&host-generics/->bytecode-class-name <from2-class>) <from2-method> <from2-sig>))] + :let [_ (doto *writer* + (.visitInsn <op>) + (.visitMethodInsn Opcodes/INVOKESPECIAL (&host-generics/->bytecode-class-name <to-class>) init-method <to-sig>))]] + (return nil))) + + ^:private compile-jvm-iand Opcodes/IAND "intValue" "()I" "java.lang.Integer" "intValue" "()I" "java.lang.Integer" "java.lang.Integer" "(I)V" + ^:private compile-jvm-ior Opcodes/IOR "intValue" "()I" "java.lang.Integer" "intValue" "()I" "java.lang.Integer" "java.lang.Integer" "(I)V" + ^:private compile-jvm-ixor Opcodes/IXOR "intValue" "()I" "java.lang.Integer" "intValue" "()I" "java.lang.Integer" "java.lang.Integer" "(I)V" + ^:private compile-jvm-ishl Opcodes/ISHL "intValue" "()I" "java.lang.Integer" "intValue" "()I" "java.lang.Integer" "java.lang.Integer" "(I)V" + ^:private compile-jvm-ishr Opcodes/ISHR "intValue" "()I" "java.lang.Integer" "intValue" "()I" "java.lang.Integer" "java.lang.Integer" "(I)V" + ^:private compile-jvm-iushr Opcodes/IUSHR "intValue" "()I" "java.lang.Integer" "intValue" "()I" "java.lang.Integer" "java.lang.Integer" "(I)V" + + ^:private compile-jvm-land Opcodes/LAND "longValue" "()J" "java.lang.Long" "longValue" "()J" "java.lang.Long" "java.lang.Long" "(J)V" + ^:private compile-jvm-lor Opcodes/LOR "longValue" "()J" "java.lang.Long" "longValue" "()J" "java.lang.Long" "java.lang.Long" "(J)V" + ^:private compile-jvm-lxor Opcodes/LXOR "longValue" "()J" "java.lang.Long" "longValue" "()J" "java.lang.Long" "java.lang.Long" "(J)V" + ^:private compile-jvm-lshl Opcodes/LSHL "longValue" "()J" "java.lang.Long" "intValue" "()I" "java.lang.Integer" "java.lang.Long" "(J)V" + ^:private compile-jvm-lshr Opcodes/LSHR "longValue" "()J" "java.lang.Long" "intValue" "()I" "java.lang.Integer" "java.lang.Long" "(J)V" + ^:private compile-jvm-lushr Opcodes/LUSHR "longValue" "()J" "java.lang.Long" "intValue" "()I" "java.lang.Integer" "java.lang.Long" "(J)V" + ) + +(do-template [<name> <opcode> <wrapper-class> <value-method> <value-method-sig> <wrap>] + (defn <name> [compile ?values special-args] + (|do [:let [(&/$Cons ?x (&/$Cons ?y (&/$Nil))) ?values] + :let [+wrapper-class+ (&host-generics/->bytecode-class-name <wrapper-class>)] + ^MethodVisitor *writer* &/get-writer + _ (compile ?x) + :let [_ (doto *writer* + (.visitTypeInsn Opcodes/CHECKCAST +wrapper-class+) + (.visitMethodInsn Opcodes/INVOKEVIRTUAL +wrapper-class+ <value-method> <value-method-sig>))] + _ (compile ?y) + :let [_ (doto *writer* + (.visitTypeInsn Opcodes/CHECKCAST +wrapper-class+) + (.visitMethodInsn Opcodes/INVOKEVIRTUAL +wrapper-class+ <value-method> <value-method-sig>)) + _ (doto *writer* + (.visitInsn <opcode>) + (<wrap>))]] + (return nil))) + + ^:private compile-jvm-iadd Opcodes/IADD "java.lang.Integer" "intValue" "()I" &&/wrap-int + ^:private compile-jvm-isub Opcodes/ISUB "java.lang.Integer" "intValue" "()I" &&/wrap-int + ^:private compile-jvm-imul Opcodes/IMUL "java.lang.Integer" "intValue" "()I" &&/wrap-int + ^:private compile-jvm-idiv Opcodes/IDIV "java.lang.Integer" "intValue" "()I" &&/wrap-int + ^:private compile-jvm-irem Opcodes/IREM "java.lang.Integer" "intValue" "()I" &&/wrap-int + + ^:private compile-jvm-ladd Opcodes/LADD "java.lang.Long" "longValue" "()J" &&/wrap-long + ^:private compile-jvm-lsub Opcodes/LSUB "java.lang.Long" "longValue" "()J" &&/wrap-long + ^:private compile-jvm-lmul Opcodes/LMUL "java.lang.Long" "longValue" "()J" &&/wrap-long + ^:private compile-jvm-ldiv Opcodes/LDIV "java.lang.Long" "longValue" "()J" &&/wrap-long + ^:private compile-jvm-lrem Opcodes/LREM "java.lang.Long" "longValue" "()J" &&/wrap-long + + ^:private compile-jvm-fadd Opcodes/FADD "java.lang.Float" "floatValue" "()F" &&/wrap-float + ^:private compile-jvm-fsub Opcodes/FSUB "java.lang.Float" "floatValue" "()F" &&/wrap-float + ^:private compile-jvm-fmul Opcodes/FMUL "java.lang.Float" "floatValue" "()F" &&/wrap-float + ^:private compile-jvm-fdiv Opcodes/FDIV "java.lang.Float" "floatValue" "()F" &&/wrap-float + ^:private compile-jvm-frem Opcodes/FREM "java.lang.Float" "floatValue" "()F" &&/wrap-float + + ^:private compile-jvm-dadd Opcodes/DADD "java.lang.Double" "doubleValue" "()D" &&/wrap-double + ^:private compile-jvm-dsub Opcodes/DSUB "java.lang.Double" "doubleValue" "()D" &&/wrap-double + ^:private compile-jvm-dmul Opcodes/DMUL "java.lang.Double" "doubleValue" "()D" &&/wrap-double + ^:private compile-jvm-ddiv Opcodes/DDIV "java.lang.Double" "doubleValue" "()D" &&/wrap-double + ^:private compile-jvm-drem Opcodes/DREM "java.lang.Double" "doubleValue" "()D" &&/wrap-double + ) + +(do-template [<name> <opcode> <wrapper-class> <value-method> <value-method-sig>] + (defn <name> [compile ?values special-args] + (|do [:let [(&/$Cons ?x (&/$Cons ?y (&/$Nil))) ?values] + :let [+wrapper-class+ (&host-generics/->bytecode-class-name <wrapper-class>)] + ^MethodVisitor *writer* &/get-writer + _ (compile ?x) + :let [_ (doto *writer* + (.visitTypeInsn Opcodes/CHECKCAST +wrapper-class+) + (.visitMethodInsn Opcodes/INVOKEVIRTUAL +wrapper-class+ <value-method> <value-method-sig>))] + _ (compile ?y) + :let [_ (doto *writer* + (.visitTypeInsn Opcodes/CHECKCAST +wrapper-class+) + (.visitMethodInsn Opcodes/INVOKEVIRTUAL +wrapper-class+ <value-method> <value-method-sig>)) + $then (new Label) + $end (new Label) + _ (doto *writer* + (.visitJumpInsn <opcode> $then) + (.visitFieldInsn Opcodes/GETSTATIC (&host-generics/->bytecode-class-name "java.lang.Boolean") "FALSE" (&host-generics/->type-signature "java.lang.Boolean")) + (.visitJumpInsn Opcodes/GOTO $end) + (.visitLabel $then) + (.visitFieldInsn Opcodes/GETSTATIC (&host-generics/->bytecode-class-name "java.lang.Boolean") "TRUE" (&host-generics/->type-signature "java.lang.Boolean")) + (.visitLabel $end))]] + (return nil))) + + ^:private compile-jvm-ieq Opcodes/IF_ICMPEQ "java.lang.Integer" "intValue" "()I" + ^:private compile-jvm-ilt Opcodes/IF_ICMPLT "java.lang.Integer" "intValue" "()I" + ^:private compile-jvm-igt Opcodes/IF_ICMPGT "java.lang.Integer" "intValue" "()I" + + ^:private compile-jvm-ceq Opcodes/IF_ICMPEQ "java.lang.Character" "charValue" "()C" + ^:private compile-jvm-clt Opcodes/IF_ICMPLT "java.lang.Character" "charValue" "()C" + ^:private compile-jvm-cgt Opcodes/IF_ICMPGT "java.lang.Character" "charValue" "()C" + ) + +(do-template [<name> <cmpcode> <cmp-output> <wrapper-class> <value-method> <value-method-sig>] + (defn <name> [compile ?values special-args] + (|do [:let [(&/$Cons ?x (&/$Cons ?y (&/$Nil))) ?values] + :let [+wrapper-class+ (&host-generics/->bytecode-class-name <wrapper-class>)] + ^MethodVisitor *writer* &/get-writer + _ (compile ?x) + :let [_ (doto *writer* + (.visitTypeInsn Opcodes/CHECKCAST +wrapper-class+) + (.visitMethodInsn Opcodes/INVOKEVIRTUAL +wrapper-class+ <value-method> <value-method-sig>))] + _ (compile ?y) + :let [_ (doto *writer* + (.visitTypeInsn Opcodes/CHECKCAST +wrapper-class+) + (.visitMethodInsn Opcodes/INVOKEVIRTUAL +wrapper-class+ <value-method> <value-method-sig>)) + $then (new Label) + $end (new Label) + _ (doto *writer* + (.visitInsn <cmpcode>) + (.visitLdcInsn (int <cmp-output>)) + (.visitJumpInsn Opcodes/IF_ICMPEQ $then) + (.visitFieldInsn Opcodes/GETSTATIC (&host-generics/->bytecode-class-name "java.lang.Boolean") "FALSE" (&host-generics/->type-signature "java.lang.Boolean")) + (.visitJumpInsn Opcodes/GOTO $end) + (.visitLabel $then) + (.visitFieldInsn Opcodes/GETSTATIC (&host-generics/->bytecode-class-name "java.lang.Boolean") "TRUE" (&host-generics/->type-signature "java.lang.Boolean")) + (.visitLabel $end))]] + (return nil))) + + ^:private compile-jvm-leq Opcodes/LCMP 0 "java.lang.Long" "longValue" "()J" + ^:private compile-jvm-llt Opcodes/LCMP -1 "java.lang.Long" "longValue" "()J" + ^:private compile-jvm-lgt Opcodes/LCMP 1 "java.lang.Long" "longValue" "()J" + + ^:private compile-jvm-feq Opcodes/FCMPG 0 "java.lang.Float" "floatValue" "()F" + ^:private compile-jvm-flt Opcodes/FCMPG -1 "java.lang.Float" "floatValue" "()F" + ^:private compile-jvm-fgt Opcodes/FCMPG 1 "java.lang.Float" "floatValue" "()F" + + ^:private compile-jvm-deq Opcodes/DCMPG 0 "java.lang.Double" "doubleValue" "()D" + ^:private compile-jvm-dlt Opcodes/DCMPG -1 "java.lang.Double" "doubleValue" "()D" + ^:private compile-jvm-dgt Opcodes/DCMPG 1 "java.lang.Double" "doubleValue" "()D" + ) + +(do-template [<prim-type> <array-type> <new-name> <load-name> <load-op> <store-name> <store-op> <wrapper> <unwrapper>] + (do (defn <new-name> [compile ?values special-args] + (|do [:let [(&/$Cons ?length (&/$Nil)) ?values + ;; (&/$Nil) special-args + ] + ^MethodVisitor *writer* &/get-writer + _ (compile ?length) + :let [_ (doto *writer* + &&/unwrap-long + (.visitInsn Opcodes/L2I))] + :let [_ (.visitIntInsn *writer* Opcodes/NEWARRAY <prim-type>)]] + (return nil))) + + (defn <load-name> [compile ?values special-args] + (|do [:let [(&/$Cons ?array (&/$Cons ?idx (&/$Nil))) ?values + ;; (&/$Nil) special-args + ] + ^MethodVisitor *writer* &/get-writer + _ (compile ?array) + :let [_ (.visitTypeInsn *writer* Opcodes/CHECKCAST <array-type>)] + _ (compile ?idx) + :let [_ (doto *writer* + &&/unwrap-long + (.visitInsn Opcodes/L2I))] + :let [_ (doto *writer* + (.visitInsn <load-op>) + <wrapper>)]] + (return nil))) + + (defn <store-name> [compile ?values special-args] + (|do [:let [(&/$Cons ?array (&/$Cons ?idx (&/$Cons ?elem (&/$Nil)))) ?values + ;; (&/$Nil) special-args + ] + ^MethodVisitor *writer* &/get-writer + _ (compile ?array) + :let [_ (.visitTypeInsn *writer* Opcodes/CHECKCAST <array-type>)] + :let [_ (.visitInsn *writer* Opcodes/DUP)] + _ (compile ?idx) + :let [_ (doto *writer* + &&/unwrap-long + (.visitInsn Opcodes/L2I))] + _ (compile ?elem) + :let [_ (doto *writer* + <unwrapper> + (.visitInsn <store-op>))]] + (return nil))) + ) + + Opcodes/T_BOOLEAN "[Z" ^:private compile-jvm-znewarray compile-jvm-zaload Opcodes/BALOAD compile-jvm-zastore Opcodes/BASTORE &&/wrap-boolean &&/unwrap-boolean + Opcodes/T_BYTE "[B" ^:private compile-jvm-bnewarray compile-jvm-baload Opcodes/BALOAD compile-jvm-bastore Opcodes/BASTORE &&/wrap-byte &&/unwrap-byte + Opcodes/T_SHORT "[S" ^:private compile-jvm-snewarray compile-jvm-saload Opcodes/SALOAD compile-jvm-sastore Opcodes/SASTORE &&/wrap-short &&/unwrap-short + Opcodes/T_INT "[I" ^:private compile-jvm-inewarray compile-jvm-iaload Opcodes/IALOAD compile-jvm-iastore Opcodes/IASTORE &&/wrap-int &&/unwrap-int + Opcodes/T_LONG "[J" ^:private compile-jvm-lnewarray compile-jvm-laload Opcodes/LALOAD compile-jvm-lastore Opcodes/LASTORE &&/wrap-long &&/unwrap-long + Opcodes/T_FLOAT "[F" ^:private compile-jvm-fnewarray compile-jvm-faload Opcodes/FALOAD compile-jvm-fastore Opcodes/FASTORE &&/wrap-float &&/unwrap-float + Opcodes/T_DOUBLE "[D" ^:private compile-jvm-dnewarray compile-jvm-daload Opcodes/DALOAD compile-jvm-dastore Opcodes/DASTORE &&/wrap-double &&/unwrap-double + Opcodes/T_CHAR "[C" ^:private compile-jvm-cnewarray compile-jvm-caload Opcodes/CALOAD compile-jvm-castore Opcodes/CASTORE &&/wrap-char &&/unwrap-char + ) + +(defn ^:private compile-jvm-anewarray [compile ?values special-args] + (|do [:let [(&/$Cons ?length (&/$Nil)) ?values + (&/$Cons ?gclass (&/$Cons type-env (&/$Nil))) special-args] + ^MethodVisitor *writer* &/get-writer + _ (compile ?length) + :let [_ (doto *writer* + &&/unwrap-long + (.visitInsn Opcodes/L2I))] + :let [_ (.visitTypeInsn *writer* Opcodes/ANEWARRAY (&host-generics/gclass->bytecode-class-name* ?gclass type-env))]] + (return nil))) + +(defn ^:private compile-jvm-aaload [compile ?values special-args] + (|do [:let [(&/$Cons ?array (&/$Cons ?idx (&/$Nil))) ?values + ;; (&/$Nil) special-args + ] + ^MethodVisitor *writer* &/get-writer + array-type (&host/->java-sig (&a/expr-type* ?array)) + _ (compile ?array) + :let [_ (.visitTypeInsn *writer* Opcodes/CHECKCAST array-type)] + _ (compile ?idx) + :let [_ (doto *writer* + &&/unwrap-long + (.visitInsn Opcodes/L2I))] + :let [_ (.visitInsn *writer* Opcodes/AALOAD)]] + (return nil))) + +(defn ^:private compile-jvm-aastore [compile ?values special-args] + (|do [:let [(&/$Cons ?array (&/$Cons ?idx (&/$Cons ?elem (&/$Nil)))) ?values + ;; (&/$Nil) special-args + ] + ^MethodVisitor *writer* &/get-writer + array-type (&host/->java-sig (&a/expr-type* ?array)) + _ (compile ?array) + :let [_ (.visitTypeInsn *writer* Opcodes/CHECKCAST array-type)] + :let [_ (.visitInsn *writer* Opcodes/DUP)] + _ (compile ?idx) + :let [_ (doto *writer* + &&/unwrap-long + (.visitInsn Opcodes/L2I))] + _ (compile ?elem) + :let [_ (.visitInsn *writer* Opcodes/AASTORE)]] + (return nil))) + +(defn ^:private compile-jvm-arraylength [compile ?values special-args] + (|do [:let [(&/$Cons ?array (&/$Nil)) ?values + ;; (&/$Nil) special-args + ] + ^MethodVisitor *writer* &/get-writer + array-type (&host/->java-sig (&a/expr-type* ?array)) + _ (compile ?array) + :let [_ (.visitTypeInsn *writer* Opcodes/CHECKCAST array-type)] + :let [_ (doto *writer* + (.visitInsn Opcodes/ARRAYLENGTH) + (.visitInsn Opcodes/I2L) + &&/wrap-long)]] + (return nil))) + +(defn ^:private compile-jvm-null [compile ?values special-args] + (|do [:let [;; (&/$Nil) ?values + (&/$Nil) special-args] + ^MethodVisitor *writer* &/get-writer + :let [_ (.visitInsn *writer* Opcodes/ACONST_NULL)]] + (return nil))) + +(defn ^:private compile-jvm-null? [compile ?values special-args] + (|do [:let [(&/$Cons ?object (&/$Nil)) ?values + ;; (&/$Nil) special-args + ] + ^MethodVisitor *writer* &/get-writer + _ (compile ?object) + :let [$then (new Label) + $end (new Label) + _ (doto *writer* + (.visitJumpInsn Opcodes/IFNULL $then) + (.visitFieldInsn Opcodes/GETSTATIC (&host-generics/->bytecode-class-name "java.lang.Boolean") "FALSE" (&host-generics/->type-signature "java.lang.Boolean")) + (.visitJumpInsn Opcodes/GOTO $end) + (.visitLabel $then) + (.visitFieldInsn Opcodes/GETSTATIC (&host-generics/->bytecode-class-name "java.lang.Boolean") "TRUE" (&host-generics/->type-signature "java.lang.Boolean")) + (.visitLabel $end))]] + (return nil))) + +(defn compile-jvm-synchronized [compile ?values special-args] + (|do [:let [(&/$Cons ?monitor (&/$Cons ?expr (&/$Nil))) ?values + ;; (&/$Nil) special-args + ] + ^MethodVisitor *writer* &/get-writer + _ (compile ?monitor) + :let [_ (doto *writer* + (.visitInsn Opcodes/DUP) + (.visitInsn Opcodes/MONITORENTER))] + _ (compile ?expr) + :let [_ (doto *writer* + (.visitInsn Opcodes/SWAP) + (.visitInsn Opcodes/MONITOREXIT))]] + (return nil))) + +(do-template [<name> <op>] + (defn <name> [compile ?values special-args] + (|do [:let [(&/$Cons ?monitor (&/$Nil)) ?values + ;; (&/$Nil) special-args + ] + ^MethodVisitor *writer* &/get-writer + _ (compile ?monitor) + :let [_ (doto *writer* + (.visitInsn <op>) + (.visitInsn Opcodes/ACONST_NULL))]] + (return nil))) + + ^:private compile-jvm-monitorenter Opcodes/MONITORENTER + ^:private compile-jvm-monitorexit Opcodes/MONITOREXIT + ) + +(defn ^:private compile-jvm-throw [compile ?values special-args] + (|do [:let [(&/$Cons ?ex (&/$Nil)) ?values + ;; (&/$Nil) special-args + ] + ^MethodVisitor *writer* &/get-writer + _ (compile ?ex) + :let [_ (.visitInsn *writer* Opcodes/ATHROW)]] + (return nil))) + +(defn ^:private compile-jvm-getstatic [compile ?values special-args] + (|do [:let [;; (&/$Nil) ?values + (&/$Cons ?class (&/$Cons ?field (&/$Cons ?output-type (&/$Nil)))) special-args] + ^MethodVisitor *writer* &/get-writer + =output-type (&host/->java-sig ?output-type) + :let [_ (doto *writer* + (.visitFieldInsn Opcodes/GETSTATIC (&host-generics/->bytecode-class-name (&host-type/as-obj ?class)) ?field =output-type) + (prepare-return! ?output-type))]] + (return nil))) + +(defn ^:private compile-jvm-getfield [compile ?values special-args] + (|do [:let [(&/$Cons ?object (&/$Nil)) ?values + (&/$Cons ?class (&/$Cons ?field (&/$Cons ?output-type (&/$Nil)))) special-args] + :let [class* (&host-generics/->bytecode-class-name (&host-type/as-obj ?class))] + ^MethodVisitor *writer* &/get-writer + _ (compile ?object) + =output-type (&host/->java-sig ?output-type) + :let [_ (doto *writer* + (.visitTypeInsn Opcodes/CHECKCAST class*) + (.visitFieldInsn Opcodes/GETFIELD class* ?field =output-type) + (prepare-return! ?output-type))]] + (return nil))) + +(defn ^:private compile-jvm-putstatic [compile ?values special-args] + (|do [:let [(&/$Cons ?value (&/$Nil)) ?values + (&/$Cons ?class (&/$Cons ?field (&/$Cons input-gclass (&/$Nil)))) special-args] + ^MethodVisitor *writer* &/get-writer + _ (compile ?value) + :let [=input-sig (&host-type/gclass->sig input-gclass) + _ (doto *writer* + (prepare-arg! (&host-generics/gclass->class-name input-gclass)) + (.visitFieldInsn Opcodes/PUTSTATIC (&host-generics/->bytecode-class-name (&host-type/as-obj ?class)) ?field =input-sig) + (.visitInsn Opcodes/ACONST_NULL))]] + (return nil))) + +(defn ^:private compile-jvm-putfield [compile ?values special-args] + (|do [:let [(&/$Cons ?object (&/$Cons ?value (&/$Nil))) ?values + (&/$Cons ?class (&/$Cons ?field (&/$Cons input-gclass (&/$Cons ?input-type (&/$Nil))))) special-args] + :let [class* (&host-generics/->bytecode-class-name (&host-type/as-obj ?class))] + ^MethodVisitor *writer* &/get-writer + _ (compile ?object) + :let [_ (.visitTypeInsn *writer* Opcodes/CHECKCAST class*)] + _ (compile ?value) + =input-sig (&host/->java-sig ?input-type) + :let [_ (doto *writer* + (prepare-arg! (&host-generics/gclass->class-name input-gclass)) + (.visitFieldInsn Opcodes/PUTFIELD class* ?field =input-sig) + (.visitInsn Opcodes/ACONST_NULL))]] + (return nil))) + +(defn ^:private compile-jvm-invokestatic [compile ?values special-args] + (|do [:let [?args ?values + (&/$Cons ?class (&/$Cons ?method (&/$Cons ?classes (&/$Cons ?output-type (&/$Cons ?gret (&/$Nil)))))) special-args] + ^MethodVisitor *writer* &/get-writer + :let [method-sig (str "(" (&/fold str "" (&/|map &host-generics/->type-signature ?classes)) ")" (&host-type/principal-class ?gret))] + _ (&/map2% (fn [class-name arg] + (|do [ret (compile arg) + :let [_ (prepare-arg! *writer* class-name)]] + (return ret))) + ?classes ?args) + :let [_ (doto *writer* + (.visitMethodInsn Opcodes/INVOKESTATIC (&host-generics/->bytecode-class-name (&host-type/as-obj ?class)) ?method method-sig) + (prepare-return! ?output-type))]] + (return nil))) + +(do-template [<name> <op>] + (defn <name> [compile ?values special-args] + (|do [:let [(&/$Cons ?object ?args) ?values + (&/$Cons ?class (&/$Cons ?method (&/$Cons ?classes (&/$Cons ?output-type (&/$Cons ?gret (&/$Nil)))))) special-args] + :let [?class* (&host-generics/->bytecode-class-name (&host-type/as-obj ?class))] + ^MethodVisitor *writer* &/get-writer + :let [method-sig (str "(" (&/fold str "" (&/|map &host-generics/->type-signature ?classes)) ")" (&host-type/principal-class ?gret))] + _ (compile ?object) + :let [_ (when (not= "<init>" ?method) + (.visitTypeInsn *writer* Opcodes/CHECKCAST ?class*))] + _ (&/map2% (fn [class-name arg] + (|do [ret (compile arg) + :let [_ (prepare-arg! *writer* class-name)]] + (return ret))) + ?classes ?args) + :let [_ (doto *writer* + (.visitMethodInsn <op> ?class* ?method method-sig) + (prepare-return! ?output-type))]] + (return nil))) + + ^:private compile-jvm-invokevirtual Opcodes/INVOKEVIRTUAL + ^:private compile-jvm-invokeinterface Opcodes/INVOKEINTERFACE + ^:private compile-jvm-invokespecial Opcodes/INVOKESPECIAL + ) + +(defn ^:private compile-jvm-new [compile ?values special-args] + (|do [:let [?args ?values + (&/$Cons ?class (&/$Cons ?classes (&/$Nil))) special-args] + ^MethodVisitor *writer* &/get-writer + :let [init-sig (str "(" (&/fold str "" (&/|map &host-generics/->type-signature ?classes)) ")V") + class* (&host-generics/->bytecode-class-name ?class) + _ (doto *writer* + (.visitTypeInsn Opcodes/NEW class*) + (.visitInsn Opcodes/DUP))] + _ (&/map% (fn [class-name+arg] + (|do [:let [[class-name arg] class-name+arg] + ret (compile arg) + :let [_ (prepare-arg! *writer* class-name)]] + (return ret))) + (&/zip2 ?classes ?args)) + :let [_ (doto *writer* + (.visitMethodInsn Opcodes/INVOKESPECIAL class* "<init>" init-sig))]] + (return nil))) + +(defn ^:private compile-jvm-try [compile ?values special-args] + (|do [:let [(&/$Cons ?body (&/$Cons ?catch (&/$Nil))) ?values + ;; (&/$Nil) special-args + ] + ^MethodVisitor *writer* &/get-writer + :let [$from (new Label) + $to (new Label) + $handler (new Label) + $end (new Label)] + :let [_ (doto *writer* + (.visitTryCatchBlock $from $to $handler "java/lang/Exception") + (.visitLabel $from))] + _ (compile ?body) + :let [_ (doto *writer* + (.visitJumpInsn Opcodes/GOTO $end) + (.visitLabel $to) + (.visitLabel $handler))] + _ (compile ?catch) + :let [_ (doto *writer* + (.visitTypeInsn Opcodes/CHECKCAST &&/function-class) + (.visitInsn Opcodes/SWAP) + (.visitMethodInsn Opcodes/INVOKEVIRTUAL &&/function-class &&/apply-method (&&/apply-signature 1)))] + :let [_ (.visitLabel *writer* $end)]] + (return nil))) + +(defn ^:private compile-jvm-load-class [compile ?values special-args] + (|do [:let [(&/$Cons _class-name (&/$Cons ?output-type (&/$Nil))) special-args] + ^MethodVisitor *writer* &/get-writer + :let [_ (doto *writer* + (.visitLdcInsn _class-name) + (.visitMethodInsn Opcodes/INVOKESTATIC "java/lang/Class" "forName" "(Ljava/lang/String;)Ljava/lang/Class;") + (prepare-return! ?output-type))]] + (return nil))) + +(defn ^:private compile-jvm-instanceof [compile ?values special-args] + (|do [:let [(&/$Cons object (&/$Nil)) ?values + (&/$Cons class (&/$Nil)) special-args] + :let [class* (&host-generics/->bytecode-class-name class)] + ^MethodVisitor *writer* &/get-writer + _ (compile object) + :let [_ (doto *writer* + (.visitTypeInsn Opcodes/INSTANCEOF class*) + (&&/wrap-boolean))]] + (return nil))) + +(defn ^:private compile-array-get [compile ?values special-args] + (|do [:let [(&/$Cons ?array (&/$Cons ?idx (&/$Nil))) ?values + ;; (&/$Nil) special-args + ] + ^MethodVisitor *writer* &/get-writer + array-type (&host/->java-sig (&a/expr-type* ?array)) + _ (compile ?array) + :let [_ (.visitTypeInsn *writer* Opcodes/CHECKCAST array-type)] + _ (compile ?idx) + :let [_ (doto *writer* + &&/unwrap-long + (.visitInsn Opcodes/L2I))] + :let [_ (.visitInsn *writer* Opcodes/AALOAD)] + :let [$is-null (new Label) + $end (new Label) + _ (doto *writer* + (.visitInsn Opcodes/DUP) + (.visitJumpInsn Opcodes/IFNULL $is-null) + (.visitLdcInsn (int 1)) + (.visitLdcInsn "") + (.visitInsn Opcodes/DUP2_X1) ;; I?2I? + (.visitInsn Opcodes/POP2) ;; I?2 + (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "sum_make" "(ILjava/lang/Object;Ljava/lang/Object;)[Ljava/lang/Object;") + (.visitJumpInsn Opcodes/GOTO $end) + (.visitLabel $is-null) + (.visitInsn Opcodes/POP) + (.visitLdcInsn (int 0)) + (.visitInsn Opcodes/ACONST_NULL) + (.visitLdcInsn &/unit-tag) + (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "sum_make" "(ILjava/lang/Object;Ljava/lang/Object;)[Ljava/lang/Object;") + (.visitLabel $end))]] + (return nil))) + +(do-template [<name> <op>] + (defn <name> [compile ?values special-args] + (|do [:let [(&/$Cons ?input (&/$Cons ?mask (&/$Nil))) ?values] + ^MethodVisitor *writer* &/get-writer + _ (compile ?input) + :let [_ (&&/unwrap-long *writer*)] + _ (compile ?mask) + :let [_ (&&/unwrap-long *writer*)] + :let [_ (doto *writer* + (.visitInsn <op>) + &&/wrap-long)]] + (return nil))) + + ^:private compile-bit-and Opcodes/LAND + ^:private compile-bit-or Opcodes/LOR + ^:private compile-bit-xor Opcodes/LXOR + ) + +(defn ^:private compile-bit-count [compile ?values special-args] + (|do [:let [(&/$Cons ?input (&/$Nil)) ?values] + ^MethodVisitor *writer* &/get-writer + _ (compile ?input) + :let [_ (&&/unwrap-long *writer*)] + :let [_ (doto *writer* + (.visitMethodInsn Opcodes/INVOKESTATIC "java/lang/Long" "bitCount" "(J)I") + (.visitInsn Opcodes/I2L) + &&/wrap-long)]] + (return nil))) + +(do-template [<name> <op>] + (defn <name> [compile ?values special-args] + (|do [:let [(&/$Cons ?input (&/$Cons ?shift (&/$Nil))) ?values] + ^MethodVisitor *writer* &/get-writer + _ (compile ?input) + :let [_ (&&/unwrap-long *writer*)] + _ (compile ?shift) + :let [_ (doto *writer* + &&/unwrap-long + (.visitInsn Opcodes/L2I))] + :let [_ (doto *writer* + (.visitInsn <op>) + &&/wrap-long)]] + (return nil))) + + ^:private compile-bit-shift-left Opcodes/LSHL + ^:private compile-bit-shift-right Opcodes/LSHR + ^:private compile-bit-unsigned-shift-right Opcodes/LUSHR + ) + +(defn ^:private compile-lux-== [compile ?values special-args] + (|do [:let [(&/$Cons ?left (&/$Cons ?right (&/$Nil))) ?values] + ^MethodVisitor *writer* &/get-writer + _ (compile ?left) + _ (compile ?right) + :let [$then (new Label) + $end (new Label) + _ (doto *writer* + (.visitJumpInsn Opcodes/IF_ACMPEQ $then) + ;; else + (.visitFieldInsn Opcodes/GETSTATIC "java/lang/Boolean" "FALSE" "Ljava/lang/Boolean;") + (.visitJumpInsn Opcodes/GOTO $end) + (.visitLabel $then) + (.visitFieldInsn Opcodes/GETSTATIC "java/lang/Boolean" "TRUE" "Ljava/lang/Boolean;") + (.visitLabel $end))]] + (return nil))) + +(do-template [<name> <opcode> <wrapper-class> <value-method> <value-method-sig> <wrap>] + (defn <name> [compile ?values special-args] + (|do [:let [(&/$Cons ?x (&/$Cons ?y (&/$Nil))) ?values] + :let [+wrapper-class+ (&host-generics/->bytecode-class-name <wrapper-class>)] + ^MethodVisitor *writer* &/get-writer + _ (compile ?x) + :let [_ (doto *writer* + (.visitTypeInsn Opcodes/CHECKCAST +wrapper-class+) + (.visitMethodInsn Opcodes/INVOKEVIRTUAL +wrapper-class+ <value-method> <value-method-sig>))] + _ (compile ?y) + :let [_ (doto *writer* + (.visitTypeInsn Opcodes/CHECKCAST +wrapper-class+) + (.visitMethodInsn Opcodes/INVOKEVIRTUAL +wrapper-class+ <value-method> <value-method-sig>)) + _ (doto *writer* + (.visitInsn <opcode>) + (<wrap>))]] + (return nil))) + + ^:private compile-nat-add Opcodes/LADD "java.lang.Long" "longValue" "()J" &&/wrap-long + ^:private compile-nat-sub Opcodes/LSUB "java.lang.Long" "longValue" "()J" &&/wrap-long + ^:private compile-nat-mul Opcodes/LMUL "java.lang.Long" "longValue" "()J" &&/wrap-long + + ^:private compile-frac-add Opcodes/LADD "java.lang.Long" "longValue" "()J" &&/wrap-long + ^:private compile-frac-sub Opcodes/LSUB "java.lang.Long" "longValue" "()J" &&/wrap-long + ^:private compile-frac-rem Opcodes/LSUB "java.lang.Long" "longValue" "()J" &&/wrap-long + ^:private compile-frac-scale Opcodes/LMUL "java.lang.Long" "longValue" "()J" &&/wrap-long + ) + +(do-template [<name> <comp-method>] + (defn <name> [compile ?values special-args] + (|do [:let [(&/$Cons ?x (&/$Cons ?y (&/$Nil))) ?values] + :let [+wrapper-class+ (&host-generics/->bytecode-class-name "java.lang.Long")] + ^MethodVisitor *writer* &/get-writer + _ (compile ?x) + :let [_ (doto *writer* + (.visitTypeInsn Opcodes/CHECKCAST +wrapper-class+) + (.visitMethodInsn Opcodes/INVOKEVIRTUAL +wrapper-class+ "longValue" "()J"))] + _ (compile ?y) + :let [_ (doto *writer* + (.visitTypeInsn Opcodes/CHECKCAST +wrapper-class+) + (.visitMethodInsn Opcodes/INVOKEVIRTUAL +wrapper-class+ "longValue" "()J")) + _ (doto *writer* + (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" <comp-method> "(JJ)J") + (&&/wrap-long))]] + (return nil))) + + ^:private compile-nat-div "div_nat" + ^:private compile-nat-rem "rem_nat" + ) + +(do-template [<name> <cmp-output>] + (defn <name> [compile ?values special-args] + (|do [:let [(&/$Cons ?x (&/$Cons ?y (&/$Nil))) ?values] + :let [+wrapper-class+ (&host-generics/->bytecode-class-name "java.lang.Long")] + ^MethodVisitor *writer* &/get-writer + _ (compile ?x) + :let [_ (doto *writer* + (.visitTypeInsn Opcodes/CHECKCAST +wrapper-class+) + (.visitMethodInsn Opcodes/INVOKEVIRTUAL +wrapper-class+ "longValue" "()J"))] + _ (compile ?y) + :let [_ (doto *writer* + (.visitTypeInsn Opcodes/CHECKCAST +wrapper-class+) + (.visitMethodInsn Opcodes/INVOKEVIRTUAL +wrapper-class+ "longValue" "()J")) + $then (new Label) + $end (new Label) + _ (doto *writer* + (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "_compareUnsigned" "(JJ)I") + (.visitLdcInsn (int <cmp-output>)) + (.visitJumpInsn Opcodes/IF_ICMPEQ $then) + (.visitFieldInsn Opcodes/GETSTATIC (&host-generics/->bytecode-class-name "java.lang.Boolean") "FALSE" (&host-generics/->type-signature "java.lang.Boolean")) + (.visitJumpInsn Opcodes/GOTO $end) + (.visitLabel $then) + (.visitFieldInsn Opcodes/GETSTATIC (&host-generics/->bytecode-class-name "java.lang.Boolean") "TRUE" (&host-generics/->type-signature "java.lang.Boolean")) + (.visitLabel $end))]] + (return nil))) + + ^:private compile-nat-eq 0 + + ^:private compile-frac-eq 0 + ^:private compile-frac-lt -1 + ) + +(let [+wrapper-class+ (&host-generics/->bytecode-class-name "java.lang.Long")] + (defn ^:private compile-nat-lt [compile ?values special-args] + (|do [:let [(&/$Cons ?x (&/$Cons ?y (&/$Nil))) ?values] + ^MethodVisitor *writer* &/get-writer + _ (compile ?x) + :let [_ (doto *writer* + (.visitTypeInsn Opcodes/CHECKCAST +wrapper-class+) + (.visitMethodInsn Opcodes/INVOKEVIRTUAL +wrapper-class+ "longValue" "()J"))] + _ (compile ?y) + :let [_ (doto *writer* + (.visitTypeInsn Opcodes/CHECKCAST +wrapper-class+) + (.visitMethodInsn Opcodes/INVOKEVIRTUAL +wrapper-class+ "longValue" "()J")) + $then (new Label) + $end (new Label) + _ (doto *writer* + (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "_compareUnsigned" "(JJ)I") + (.visitLdcInsn (int -1)) + (.visitJumpInsn Opcodes/IF_ICMPEQ $then) + (.visitFieldInsn Opcodes/GETSTATIC (&host-generics/->bytecode-class-name "java.lang.Boolean") "FALSE" (&host-generics/->type-signature "java.lang.Boolean")) + (.visitJumpInsn Opcodes/GOTO $end) + (.visitLabel $then) + (.visitFieldInsn Opcodes/GETSTATIC (&host-generics/->bytecode-class-name "java.lang.Boolean") "TRUE" (&host-generics/->type-signature "java.lang.Boolean")) + (.visitLabel $end))]] + (return nil)))) + +(do-template [<name> <instr> <wrapper>] + (defn <name> [compile ?values special-args] + (|do [:let [(&/$Nil) ?values] + ^MethodVisitor *writer* &/get-writer + :let [_ (doto *writer* + <instr> + <wrapper>)]] + (return nil))) + + ^:private compile-nat-min-value (.visitLdcInsn 0) &&/wrap-long + ^:private compile-nat-max-value (.visitLdcInsn -1) &&/wrap-long + + ^:private compile-frac-min-value (.visitLdcInsn 0) &&/wrap-long + ^:private compile-frac-max-value (.visitLdcInsn -1) &&/wrap-long + ) + +(do-template [<encode-name> <encode-method> <decode-name> <decode-method>] + (do (defn <encode-name> [compile ?values special-args] + (|do [:let [(&/$Cons ?x (&/$Nil)) ?values] + ^MethodVisitor *writer* &/get-writer + _ (compile ?x) + :let [_ (doto *writer* + &&/unwrap-long + (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" <encode-method> "(J)Ljava/lang/String;"))]] + (return nil))) + + (let [+wrapper-class+ (&host-generics/->bytecode-class-name "java.lang.String")] + (defn <decode-name> [compile ?values special-args] + (|do [:let [(&/$Cons ?x (&/$Nil)) ?values] + ^MethodVisitor *writer* &/get-writer + _ (compile ?x) + :let [_ (doto *writer* + (.visitTypeInsn Opcodes/CHECKCAST +wrapper-class+) + (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" <decode-method> "(Ljava/lang/String;)Ljava/lang/Object;"))]] + (return nil))))) + + ^:private compile-nat-encode "encode_nat" ^:private compile-nat-decode "decode_nat" + ^:private compile-frac-encode "encode_frac" ^:private compile-frac-decode "decode_frac" + ) + +(do-template [<name> <method>] + (defn <name> [compile ?values special-args] + (|do [:let [(&/$Cons ?x (&/$Cons ?y (&/$Nil))) ?values] + :let [+wrapper-class+ (&host-generics/->bytecode-class-name "java.lang.Long")] + ^MethodVisitor *writer* &/get-writer + _ (compile ?x) + :let [_ (doto *writer* + (.visitTypeInsn Opcodes/CHECKCAST +wrapper-class+) + &&/unwrap-long)] + _ (compile ?y) + :let [_ (doto *writer* + (.visitTypeInsn Opcodes/CHECKCAST +wrapper-class+) + &&/unwrap-long)] + :let [_ (doto *writer* + (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" <method> "(JJ)J") + &&/wrap-long)]] + (return nil))) + + ^:private compile-frac-mul "mul_frac" + ^:private compile-frac-div "div_frac" + ) + +(do-template [<name> <class> <method> <sig> <unwrap> <wrap>] + (let [+wrapper-class+ (&host-generics/->bytecode-class-name <class>)] + (defn <name> [compile ?values special-args] + (|do [:let [(&/$Cons ?x (&/$Nil)) ?values] + ^MethodVisitor *writer* &/get-writer + _ (compile ?x) + :let [_ (doto *writer* + <unwrap> + (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" <method> <sig>) + <wrap>)]] + (return nil)))) + + ^:private compile-frac-to-real "java.lang.Long" "frac-to-real" "(J)D" &&/unwrap-long &&/wrap-double + ^:private compile-real-to-frac "java.lang.Double" "real-to-frac" "(D)J" &&/unwrap-double &&/wrap-long + ) + +(let [widen (fn [^MethodVisitor *writer*] + (doto *writer* + (.visitInsn Opcodes/I2L))) + shrink (fn [^MethodVisitor *writer*] + (doto *writer* + (.visitInsn Opcodes/L2I) + (.visitInsn Opcodes/I2C)))] + (do-template [<name> <unwrap> <wrap> <adjust>] + (defn <name> [compile ?values special-args] + (|do [:let [(&/$Cons ?x (&/$Nil)) ?values] + ^MethodVisitor *writer* &/get-writer + _ (compile ?x) + :let [_ (doto *writer* + <unwrap> + <adjust> + <wrap>)]] + (return nil))) + + ^:private compile-nat-to-char &&/unwrap-long &&/wrap-char shrink + ^:private compile-char-to-nat &&/unwrap-char &&/wrap-long widen + )) + +(do-template [<name>] + (defn <name> [compile ?values special-args] + (|do [:let [(&/$Cons ?x (&/$Nil)) ?values] + ^MethodVisitor *writer* &/get-writer + _ (compile ?x)] + (return nil))) + + ^:private compile-nat-to-int + ^:private compile-int-to-nat + ) + +(defn compile-host [compile proc-category proc-name ?values special-args] + (case proc-category + "lux" + (case proc-name + "==" (compile-lux-== compile ?values special-args)) + + "bit" + (case proc-name + "count" (compile-bit-count compile ?values special-args) + "and" (compile-bit-and compile ?values special-args) + "or" (compile-bit-or compile ?values special-args) + "xor" (compile-bit-xor compile ?values special-args) + "shift-left" (compile-bit-shift-left compile ?values special-args) + "shift-right" (compile-bit-shift-right compile ?values special-args) + "unsigned-shift-right" (compile-bit-unsigned-shift-right compile ?values special-args)) + + "array" + (case proc-name + "get" (compile-array-get compile ?values special-args)) + + "nat" + (case proc-name + "+" (compile-nat-add compile ?values special-args) + "-" (compile-nat-sub compile ?values special-args) + "*" (compile-nat-mul compile ?values special-args) + "/" (compile-nat-div compile ?values special-args) + "%" (compile-nat-rem compile ?values special-args) + "=" (compile-nat-eq compile ?values special-args) + "<" (compile-nat-lt compile ?values special-args) + "encode" (compile-nat-encode compile ?values special-args) + "decode" (compile-nat-decode compile ?values special-args) + "max-value" (compile-nat-max-value compile ?values special-args) + "min-value" (compile-nat-min-value compile ?values special-args) + "to-int" (compile-nat-to-int compile ?values special-args) + "to-char" (compile-nat-to-char compile ?values special-args) + ) + + "frac" + (case proc-name + "+" (compile-frac-add compile ?values special-args) + "-" (compile-frac-sub compile ?values special-args) + "*" (compile-frac-mul compile ?values special-args) + "/" (compile-frac-div compile ?values special-args) + "%" (compile-frac-rem compile ?values special-args) + "=" (compile-frac-eq compile ?values special-args) + "<" (compile-frac-lt compile ?values special-args) + "encode" (compile-frac-encode compile ?values special-args) + "decode" (compile-frac-decode compile ?values special-args) + "max-value" (compile-frac-max-value compile ?values special-args) + "min-value" (compile-frac-min-value compile ?values special-args) + "to-real" (compile-frac-to-real compile ?values special-args) + "scale" (compile-frac-scale compile ?values special-args) + ) + + "int" + (case proc-name + "to-nat" (compile-int-to-nat compile ?values special-args) + ) + + "real" + (case proc-name + "to-frac" (compile-real-to-frac compile ?values special-args) + ) + + "char" + (case proc-name + "to-nat" (compile-char-to-nat compile ?values special-args) + ) + + "jvm" + (case proc-name + "synchronized" (compile-jvm-synchronized compile ?values special-args) + "load-class" (compile-jvm-load-class compile ?values special-args) + "instanceof" (compile-jvm-instanceof compile ?values special-args) + "try" (compile-jvm-try compile ?values special-args) + "new" (compile-jvm-new compile ?values special-args) + "invokestatic" (compile-jvm-invokestatic compile ?values special-args) + "invokeinterface" (compile-jvm-invokeinterface compile ?values special-args) + "invokevirtual" (compile-jvm-invokevirtual compile ?values special-args) + "invokespecial" (compile-jvm-invokespecial compile ?values special-args) + "getstatic" (compile-jvm-getstatic compile ?values special-args) + "getfield" (compile-jvm-getfield compile ?values special-args) + "putstatic" (compile-jvm-putstatic compile ?values special-args) + "putfield" (compile-jvm-putfield compile ?values special-args) + "throw" (compile-jvm-throw compile ?values special-args) + "monitorenter" (compile-jvm-monitorenter compile ?values special-args) + "monitorexit" (compile-jvm-monitorexit compile ?values special-args) + "null?" (compile-jvm-null? compile ?values special-args) + "null" (compile-jvm-null compile ?values special-args) + "anewarray" (compile-jvm-anewarray compile ?values special-args) + "aaload" (compile-jvm-aaload compile ?values special-args) + "aastore" (compile-jvm-aastore compile ?values special-args) + "arraylength" (compile-jvm-arraylength compile ?values special-args) + "znewarray" (compile-jvm-znewarray compile ?values special-args) + "bnewarray" (compile-jvm-bnewarray compile ?values special-args) + "snewarray" (compile-jvm-snewarray compile ?values special-args) + "inewarray" (compile-jvm-inewarray compile ?values special-args) + "lnewarray" (compile-jvm-lnewarray compile ?values special-args) + "fnewarray" (compile-jvm-fnewarray compile ?values special-args) + "dnewarray" (compile-jvm-dnewarray compile ?values special-args) + "cnewarray" (compile-jvm-cnewarray compile ?values special-args) + "iadd" (compile-jvm-iadd compile ?values special-args) + "isub" (compile-jvm-isub compile ?values special-args) + "imul" (compile-jvm-imul compile ?values special-args) + "idiv" (compile-jvm-idiv compile ?values special-args) + "irem" (compile-jvm-irem compile ?values special-args) + "ieq" (compile-jvm-ieq compile ?values special-args) + "ilt" (compile-jvm-ilt compile ?values special-args) + "igt" (compile-jvm-igt compile ?values special-args) + "ceq" (compile-jvm-ceq compile ?values special-args) + "clt" (compile-jvm-clt compile ?values special-args) + "cgt" (compile-jvm-cgt compile ?values special-args) + "ladd" (compile-jvm-ladd compile ?values special-args) + "lsub" (compile-jvm-lsub compile ?values special-args) + "lmul" (compile-jvm-lmul compile ?values special-args) + "ldiv" (compile-jvm-ldiv compile ?values special-args) + "lrem" (compile-jvm-lrem compile ?values special-args) + "leq" (compile-jvm-leq compile ?values special-args) + "llt" (compile-jvm-llt compile ?values special-args) + "lgt" (compile-jvm-lgt compile ?values special-args) + "fadd" (compile-jvm-fadd compile ?values special-args) + "fsub" (compile-jvm-fsub compile ?values special-args) + "fmul" (compile-jvm-fmul compile ?values special-args) + "fdiv" (compile-jvm-fdiv compile ?values special-args) + "frem" (compile-jvm-frem compile ?values special-args) + "feq" (compile-jvm-feq compile ?values special-args) + "flt" (compile-jvm-flt compile ?values special-args) + "fgt" (compile-jvm-fgt compile ?values special-args) + "dadd" (compile-jvm-dadd compile ?values special-args) + "dsub" (compile-jvm-dsub compile ?values special-args) + "dmul" (compile-jvm-dmul compile ?values special-args) + "ddiv" (compile-jvm-ddiv compile ?values special-args) + "drem" (compile-jvm-drem compile ?values special-args) + "deq" (compile-jvm-deq compile ?values special-args) + "dlt" (compile-jvm-dlt compile ?values special-args) + "dgt" (compile-jvm-dgt compile ?values special-args) + "iand" (compile-jvm-iand compile ?values special-args) + "ior" (compile-jvm-ior compile ?values special-args) + "ixor" (compile-jvm-ixor compile ?values special-args) + "ishl" (compile-jvm-ishl compile ?values special-args) + "ishr" (compile-jvm-ishr compile ?values special-args) + "iushr" (compile-jvm-iushr compile ?values special-args) + "land" (compile-jvm-land compile ?values special-args) + "lor" (compile-jvm-lor compile ?values special-args) + "lxor" (compile-jvm-lxor compile ?values special-args) + "lshl" (compile-jvm-lshl compile ?values special-args) + "lshr" (compile-jvm-lshr compile ?values special-args) + "lushr" (compile-jvm-lushr compile ?values special-args) + "d2f" (compile-jvm-d2f compile ?values special-args) + "d2i" (compile-jvm-d2i compile ?values special-args) + "d2l" (compile-jvm-d2l compile ?values special-args) + "f2d" (compile-jvm-f2d compile ?values special-args) + "f2i" (compile-jvm-f2i compile ?values special-args) + "f2l" (compile-jvm-f2l compile ?values special-args) + "i2b" (compile-jvm-i2b compile ?values special-args) + "i2c" (compile-jvm-i2c compile ?values special-args) + "i2d" (compile-jvm-i2d compile ?values special-args) + "i2f" (compile-jvm-i2f compile ?values special-args) + "i2l" (compile-jvm-i2l compile ?values special-args) + "i2s" (compile-jvm-i2s compile ?values special-args) + "l2d" (compile-jvm-l2d compile ?values special-args) + "l2f" (compile-jvm-l2f compile ?values special-args) + "l2i" (compile-jvm-l2i compile ?values special-args) + "l2s" (compile-jvm-l2s compile ?values special-args) + "l2b" (compile-jvm-l2b compile ?values special-args) + "c2b" (compile-jvm-c2b compile ?values special-args) + "c2s" (compile-jvm-c2s compile ?values special-args) + "c2i" (compile-jvm-c2i compile ?values special-args) + "c2l" (compile-jvm-c2l compile ?values special-args) + "s2l" (compile-jvm-s2l compile ?values special-args) + "b2l" (compile-jvm-b2l compile ?values special-args) + ;; else + (fail (str "[Compiler Error] Unknown host procedure: " [proc-category proc-name]))) + + ;; else + (fail (str "[Compiler Error] Unknown host procedure: " [proc-category proc-name])))) diff --git a/luxc/src/lux/compiler/io.clj b/luxc/src/lux/compiler/io.clj new file mode 100644 index 000000000..ecb2066cd --- /dev/null +++ b/luxc/src/lux/compiler/io.clj @@ -0,0 +1,36 @@ +;; Copyright (c) Eduardo Julian. All rights reserved. +;; This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +;; If a copy of the MPL was not distributed with this file, +;; You can obtain one at http://mozilla.org/MPL/2.0/. + +(ns lux.compiler.io + (:require (lux [base :as & :refer [|case |let |do return* return fail fail*]]) + (lux.compiler [base :as &&]) + [lux.lib.loader :as &lib])) + +;; [Utils] +(def ^:private !libs (atom nil)) + +(defn ^:private libs-imported? [] + (not (nil? @!libs))) + +(defn ^:private init-libs! [] + (reset! !libs (&lib/load))) + +;; [Resources] +(defn read-file [source-dirs ^String file-name] + (|case (&/|some (fn [source-dir] + (let [file (new java.io.File (str source-dir "/" file-name))] + (if (.exists file) + (&/$Some file) + &/$None))) + source-dirs) + (&/$Some file) + (return (slurp file)) + + (&/$None) + (do (when (not (libs-imported?)) + (init-libs!)) + (if-let [code (get @!libs file-name)] + (return code) + (fail (str "[I/O Error] File doesn't exist: " file-name)))))) diff --git a/luxc/src/lux/compiler/lambda.clj b/luxc/src/lux/compiler/lambda.clj new file mode 100644 index 000000000..c0096523f --- /dev/null +++ b/luxc/src/lux/compiler/lambda.clj @@ -0,0 +1,286 @@ +;; Copyright (c) Eduardo Julian. All rights reserved. +;; This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +;; If a copy of the MPL was not distributed with this file, +;; You can obtain one at http://mozilla.org/MPL/2.0/. + +(ns lux.compiler.lambda + (:require (clojure [string :as string] + [set :as set] + [template :refer [do-template]]) + clojure.core.match + clojure.core.match.array + (lux [base :as & :refer [|do return* return fail fail* |case |let]] + [type :as &type] + [lexer :as &lexer] + [parser :as &parser] + [analyser :as &analyser] + [host :as &host] + [optimizer :as &o]) + [lux.host.generics :as &host-generics] + [lux.analyser.base :as &a] + (lux.compiler [base :as &&])) + (:import (org.objectweb.asm Opcodes + Label + ClassWriter + MethodVisitor))) + +;; [Utils] +(def ^:private field-sig (&host-generics/->type-signature "java.lang.Object")) +(def ^:private lambda-return-sig (&host-generics/->type-signature "java.lang.Object")) +(def ^:private <init>-return "V") + +(defn ^:private ^String reset-signature [function-class] + (str "()" (&host-generics/->type-signature function-class))) + +(defn ^:private ^MethodVisitor get-num-partials! [^MethodVisitor method-writer] + (doto method-writer + (.visitVarInsn Opcodes/ALOAD 0) + (.visitFieldInsn Opcodes/GETFIELD &&/function-class &&/partials-field "I"))) + +(defn ^:private ^MethodVisitor inc-int! [^MethodVisitor method-writer by] + (doto method-writer + (.visitLdcInsn (int by)) + (.visitInsn Opcodes/IADD))) + +(defn ^:private ^MethodVisitor get-field! [^MethodVisitor method-writer class-name field-name] + (doto method-writer + (.visitVarInsn Opcodes/ALOAD 0) + (.visitFieldInsn Opcodes/GETFIELD class-name field-name field-sig))) + +(defn ^:private ^MethodVisitor put-field! [^MethodVisitor method-writer class-name field-name field-sig value-thunk] + (doto method-writer + (.visitVarInsn Opcodes/ALOAD 0) + value-thunk + (.visitFieldInsn Opcodes/PUTFIELD class-name field-name field-sig))) + +(defn ^:private ^MethodVisitor fill-nulls! [^MethodVisitor method-writer amount] + (doto method-writer + (-> (.visitInsn Opcodes/ACONST_NULL) + (->> (dotimes [_ amount]))))) + +(defn ^:private ^MethodVisitor consecutive-args [^MethodVisitor method-writer start amount] + (doto method-writer + (-> (.visitVarInsn Opcodes/ALOAD (+ start idx)) + (->> (dotimes [idx amount]))))) + +(defn ^:private ^MethodVisitor consecutive-applys [^MethodVisitor method-writer start amount] + (let [max-args-num (min amount &&/num-apply-variants)] + (doto method-writer + (.visitTypeInsn Opcodes/CHECKCAST &&/function-class) + (consecutive-args start max-args-num) + (.visitMethodInsn Opcodes/INVOKEVIRTUAL &&/function-class &&/apply-method (&&/apply-signature max-args-num)) + (-> (consecutive-applys (+ start &&/num-apply-variants) (- amount &&/num-apply-variants)) + (->> (when (> amount &&/num-apply-variants))))))) + +(defn ^:private lambda-impl-signature [arity] + (str "(" (&/fold str "" (&/|repeat arity field-sig)) ")" lambda-return-sig)) + +(defn ^:private lambda-<init>-signature [env arity] + (if (> arity 1) + (str "(" (&/fold str "" (&/|repeat (&/|length env) field-sig)) "I" (&/fold str "" (&/|repeat (dec arity) field-sig)) ")" + <init>-return) + (str "(" (&/fold str "" (&/|repeat (&/|length env) field-sig)) ")" + <init>-return))) + +(defn ^:private init-function [^MethodVisitor method-writer arity closure-length] + (if (= 1 arity) + (doto method-writer + (.visitLdcInsn (int 0)) + (.visitMethodInsn Opcodes/INVOKESPECIAL &&/function-class "<init>" "(I)V")) + (doto method-writer + (.visitVarInsn Opcodes/ILOAD (inc closure-length)) + (.visitMethodInsn Opcodes/INVOKESPECIAL &&/function-class "<init>" "(I)V")))) + +(defn ^:private add-lambda-<init> [^ClassWriter class class-name arity env] + (let [closure-length (&/|length env)] + (doto (.visitMethod class Opcodes/ACC_PUBLIC "<init>" (lambda-<init>-signature env arity) nil nil) + (.visitCode) + ;; Do normal object initialization + (.visitVarInsn Opcodes/ALOAD 0) + (init-function arity closure-length) + ;; Add all of the closure variables + (-> (put-field! class-name (str &&/closure-prefix ?captured-id) field-sig #(.visitVarInsn ^MethodVisitor % Opcodes/ALOAD (inc ?captured-id))) + (->> (|let [[?name [_ (&o/$captured _ ?captured-id ?source)]] ?name+?captured]) + (doseq [?name+?captured (&/->seq env)]))) + ;; Add all the partial arguments + (-> (put-field! class-name (str &&/partial-prefix idx*) field-sig #(.visitVarInsn ^MethodVisitor % Opcodes/ALOAD partial-register)) + (->> (|let [partial-register (+ (inc idx*) (inc closure-length))]) + (dotimes [idx* (dec arity)]))) + ;; Finish + (.visitInsn Opcodes/RETURN) + (.visitMaxs 0 0) + (.visitEnd)))) + +(let [impl-flags (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL)] + (defn ^:private add-lambda-impl [^ClassWriter class class-name compile arity impl-body] + (let [$begin (new Label)] + (&/with-writer (doto (.visitMethod class impl-flags "impl" (lambda-impl-signature arity) nil nil) + (.visitCode) + (.visitLabel $begin)) + (|do [^MethodVisitor *writer* &/get-writer + ret (compile $begin impl-body) + :let [_ (doto *writer* + (.visitInsn Opcodes/ARETURN) + (.visitMaxs 0 0) + (.visitEnd))]] + (return ret)))))) + +(defn ^:private instance-closure [compile lambda-class arity closed-over] + (|do [^MethodVisitor *writer* &/get-writer + :let [_ (doto *writer* + (.visitTypeInsn Opcodes/NEW lambda-class) + (.visitInsn Opcodes/DUP))] + _ (&/map% (fn [?name+?captured] + (|case ?name+?captured + [?name [_ (&o/$captured _ _ ?source)]] + (compile nil ?source))) + closed-over) + :let [_ (when (> arity 1) + (doto *writer* + (.visitLdcInsn (int 0)) + (fill-nulls! (dec arity))))] + :let [_ (.visitMethodInsn *writer* Opcodes/INVOKESPECIAL lambda-class "<init>" (lambda-<init>-signature closed-over arity))]] + (return nil))) + +(defn ^:private add-lambda-reset [^ClassWriter class-writer class-name arity env] + (if (> arity 1) + (doto (.visitMethod class-writer Opcodes/ACC_PUBLIC "reset" (reset-signature class-name) nil nil) + (.visitCode) + (.visitTypeInsn Opcodes/NEW class-name) + (.visitInsn Opcodes/DUP) + (-> (get-field! class-name (str &&/closure-prefix cidx)) + (->> (dotimes [cidx (&/|length env)]))) + (.visitLdcInsn (int 0)) + (fill-nulls! (dec arity)) + (.visitMethodInsn Opcodes/INVOKESPECIAL class-name "<init>" (lambda-<init>-signature env arity)) + (.visitInsn Opcodes/ARETURN) + (.visitMaxs 0 0) + (.visitEnd)) + (doto (.visitMethod class-writer Opcodes/ACC_PUBLIC "reset" (reset-signature class-name) nil nil) + (.visitCode) + (.visitVarInsn Opcodes/ALOAD 0) + (.visitInsn Opcodes/ARETURN) + (.visitMaxs 0 0) + (.visitEnd)))) + +(defn ^:private add-lambda-apply-n [^ClassWriter class-writer +degree+ class-name arity env compile impl-body] + (if (> arity 1) + (let [num-partials (dec arity) + $default (new Label) + $labels* (map (fn [_] (new Label)) (repeat num-partials nil)) + $labels (vec (concat $labels* (list $default))) + $end (new Label) + method-writer (.visitMethod class-writer Opcodes/ACC_PUBLIC &&/apply-method (&&/apply-signature +degree+) nil nil) + frame-locals (to-array (list class-name "java/lang/Object" "java/lang/Object")) + frame-stack (to-array [Opcodes/INTEGER]) + arity-over-extent (- arity +degree+)] + (do (doto method-writer + (.visitCode) + get-num-partials! + (.visitTableSwitchInsn 0 (dec num-partials) $default (into-array Label $labels*)) + ;; (< stage (- arity +degree+)) + (-> (doto (.visitLabel $label) + (.visitTypeInsn Opcodes/NEW class-name) + (.visitInsn Opcodes/DUP) + (-> (get-field! class-name (str &&/closure-prefix cidx)) + (->> (dotimes [cidx (&/|length env)]))) + get-num-partials! + (inc-int! +degree+) + (-> (get-field! class-name (str &&/partial-prefix idx)) + (->> (dotimes [idx stage]))) + (consecutive-args 1 +degree+) + (fill-nulls! (- (- num-partials +degree+) stage)) + (.visitMethodInsn Opcodes/INVOKESPECIAL class-name "<init>" (lambda-<init>-signature env arity)) + (.visitJumpInsn Opcodes/GOTO $end)) + (->> (cond (= stage arity-over-extent) + (doto method-writer + (.visitLabel $label) + (.visitVarInsn Opcodes/ALOAD 0) + (-> (.visitMethodInsn Opcodes/INVOKEVIRTUAL class-name "reset" (reset-signature class-name)) + (->> (when (not= 0 stage)))) + (-> (get-field! class-name (str &&/partial-prefix idx)) + (->> (dotimes [idx stage]))) + (consecutive-args 1 +degree+) + (.visitMethodInsn Opcodes/INVOKEVIRTUAL class-name "impl" (lambda-impl-signature arity)) + (.visitJumpInsn Opcodes/GOTO $end)) + + (> stage arity-over-extent) + (let [args-to-completion (- arity stage) + args-left (- +degree+ args-to-completion)] + (doto method-writer + (.visitLabel $label) + (.visitVarInsn Opcodes/ALOAD 0) + (.visitMethodInsn Opcodes/INVOKEVIRTUAL class-name "reset" (reset-signature class-name)) + (-> (get-field! class-name (str &&/partial-prefix idx)) + (->> (dotimes [idx stage]))) + (consecutive-args 1 args-to-completion) + (.visitMethodInsn Opcodes/INVOKEVIRTUAL class-name "impl" (lambda-impl-signature arity)) + (consecutive-applys (+ 1 args-to-completion) args-left) + (.visitJumpInsn Opcodes/GOTO $end))) + + :else) + (doseq [[stage $label] (map vector (range arity) $labels)]))) + (.visitLabel $end) + (.visitInsn Opcodes/ARETURN) + (.visitMaxs 0 0) + (.visitEnd)) + (return nil))) + (let [$begin (new Label)] + (&/with-writer (doto (.visitMethod ^ClassWriter class-writer Opcodes/ACC_PUBLIC &&/apply-method (&&/apply-signature 1) nil nil) + (.visitCode) + (.visitLabel $begin)) + (|do [^MethodVisitor *writer* &/get-writer + ret (compile $begin impl-body) + :let [_ (doto *writer* + (.visitInsn Opcodes/ARETURN) + (.visitMaxs 0 0) + (.visitEnd))]] + (return ret)))) + )) + +;; [Exports] +(let [lambda-flags (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_SUPER) + datum-flags (+ Opcodes/ACC_PRIVATE Opcodes/ACC_FINAL)] + (defn compile-function [compile ?prev-writer arity ?scope ?env ?body] + (|do [[file-name _ _] &/cursor + :let [??scope (&/|reverse ?scope) + name (&host/location (&/|tail ??scope)) + class-name (str (&host/->module-class (&/|head ??scope)) "/" name) + [^ClassWriter =class save?] (|case ?prev-writer + (&/$Some _writer) + (&/T [_writer false]) + + (&/$None) + (&/T [(doto (new ClassWriter ClassWriter/COMPUTE_MAXS) + (.visit &host/bytecode-version lambda-flags + class-name nil &&/function-class (into-array String []))) + true])) + _ (doto =class + (-> (.visitField (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC Opcodes/ACC_FINAL) &&/arity-field "I" nil (int arity)) + (doto (.visitEnd))) + (-> (doto (.visitField datum-flags captured-name field-sig nil nil) + (.visitEnd)) + (->> (let [captured-name (str &&/closure-prefix ?captured-id)]) + (|case ?name+?captured + [?name [_ (&o/$captured _ ?captured-id ?source)]]) + (doseq [?name+?captured (&/->seq ?env)]))) + (-> (.visitField datum-flags (str &&/partial-prefix idx) field-sig nil nil) + (doto (.visitEnd)) + (->> (dotimes [idx (dec arity)]))) + (-> (.visitSource file-name nil) + (when save?)) + (add-lambda-<init> class-name arity ?env) + (add-lambda-reset class-name arity ?env) + )] + _ (if (> arity 1) + (add-lambda-impl =class class-name compile arity ?body) + (return nil)) + _ (&/map% #(add-lambda-apply-n =class % class-name arity ?env compile ?body) + (&/|range* 1 (min arity &&/num-apply-variants))) + :let [_ (.visitEnd =class)] + _ (if save? + (&&/save-class! name (.toByteArray =class)) + (return nil))] + (if save? + (instance-closure compile class-name arity ?env) + (return (instance-closure compile class-name arity ?env)))))) diff --git a/luxc/src/lux/compiler/lux.clj b/luxc/src/lux/compiler/lux.clj new file mode 100644 index 000000000..5dc8becc0 --- /dev/null +++ b/luxc/src/lux/compiler/lux.clj @@ -0,0 +1,498 @@ +;; Copyright (c) Eduardo Julian. All rights reserved. +;; This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +;; If a copy of the MPL was not distributed with this file, +;; You can obtain one at http://mozilla.org/MPL/2.0/. + +(ns lux.compiler.lux + (:require (clojure [string :as string] + [set :as set] + [template :refer [do-template]]) + clojure.core.match + clojure.core.match.array + (lux [base :as & :refer [|do return* return fail fail* |let |case]] + [type :as &type] + [lexer :as &lexer] + [parser :as &parser] + [analyser :as &analyser] + [host :as &host] + [optimizer :as &o]) + [lux.host.generics :as &host-generics] + (lux.analyser [base :as &a] + [module :as &a-module] + [meta :as &a-meta]) + (lux.compiler [base :as &&] + [lambda :as &&lambda])) + (:import (org.objectweb.asm Opcodes + Label + ClassWriter + MethodVisitor) + java.lang.reflect.Field)) + +;; [Exports] +(defn compile-bool [?value] + (|do [^MethodVisitor *writer* &/get-writer + :let [_ (.visitFieldInsn *writer* Opcodes/GETSTATIC "java/lang/Boolean" (if ?value "TRUE" "FALSE") "Ljava/lang/Boolean;")]] + (return nil))) + +(do-template [<name> <class> <prim> <caster>] + (defn <name> [value] + (|do [^MethodVisitor *writer* &/get-writer + :let [_ (doto *writer* + (.visitLdcInsn (<caster> value)) + (.visitMethodInsn Opcodes/INVOKESTATIC <class> "valueOf" (str "(" <prim> ")" (&host-generics/->type-signature <class>))))]] + (return nil))) + + compile-nat "java/lang/Long" "J" long + compile-int "java/lang/Long" "J" long + compile-frac "java/lang/Long" "J" long + compile-real "java/lang/Double" "D" double + compile-char "java/lang/Character" "C" char + ) + +(defn compile-text [?value] + (|do [^MethodVisitor *writer* &/get-writer + :let [_ (.visitLdcInsn *writer* ?value)]] + (return nil))) + +(defn compile-tuple [compile ?elems] + (|do [^MethodVisitor *writer* &/get-writer + :let [num-elems (&/|length ?elems)]] + (|case num-elems + 0 + (|do [:let [_ (.visitLdcInsn *writer* &/unit-tag)]] + (return nil)) + + 1 + (compile (&/|head ?elems)) + + _ + (|do [:let [_ (doto *writer* + (.visitLdcInsn (int num-elems)) + (.visitTypeInsn Opcodes/ANEWARRAY "java/lang/Object"))] + _ (&/map2% (fn [idx elem] + (|do [:let [_ (doto *writer* + (.visitInsn Opcodes/DUP) + (.visitLdcInsn (int idx)))] + ret (compile elem) + :let [_ (.visitInsn *writer* Opcodes/AASTORE)]] + (return ret))) + (&/|range num-elems) ?elems)] + (return nil))))) + +(defn compile-variant [compile tag tail? value] + (|do [^MethodVisitor *writer* &/get-writer + :let [_ (.visitLdcInsn *writer* (int tag)) + _ (if tail? + (.visitLdcInsn *writer* "") + (.visitInsn *writer* Opcodes/ACONST_NULL))] + _ (compile value) + :let [_ (.visitMethodInsn *writer* Opcodes/INVOKESTATIC "lux/LuxRT" "sum_make" "(ILjava/lang/Object;Ljava/lang/Object;)[Ljava/lang/Object;")]] + (return nil))) + +(defn compile-local [compile ?idx] + (|do [^MethodVisitor *writer* &/get-writer + :let [_ (.visitVarInsn *writer* Opcodes/ALOAD (int ?idx))]] + (return nil))) + +(defn compile-captured [compile ?scope ?captured-id ?source] + (|do [:let [??scope (&/|reverse ?scope)] + ^MethodVisitor *writer* &/get-writer + :let [_ (doto *writer* + (.visitVarInsn Opcodes/ALOAD 0) + (.visitFieldInsn Opcodes/GETFIELD + (str (&host/->module-class (&/|head ??scope)) "/" (&host/location (&/|tail ??scope))) + (str &&/closure-prefix ?captured-id) + "Ljava/lang/Object;"))]] + (return nil))) + +(defn compile-global [compile ?owner-class ?name] + (|do [^MethodVisitor *writer* &/get-writer + :let [_ (.visitFieldInsn *writer* Opcodes/GETSTATIC (str (&host/->module-class ?owner-class) "/" (&host/def-name ?name)) &/value-field "Ljava/lang/Object;")]] + (return nil))) + +(defn ^:private compile-apply* [compile ?args] + (|do [^MethodVisitor *writer* &/get-writer + _ (&/map% (fn [?args] + (|do [:let [_ (.visitTypeInsn *writer* Opcodes/CHECKCAST &&/function-class)] + _ (&/map% compile ?args) + :let [_ (.visitMethodInsn *writer* Opcodes/INVOKEVIRTUAL &&/function-class &&/apply-method (&&/apply-signature (&/|length ?args)))]] + (return nil))) + (&/|partition &&/num-apply-variants ?args))] + (return nil))) + +(defn compile-apply [compile ?fn ?args] + (|case ?fn + [_ (&o/$var (&/$Global ?module ?name))] + (|do [[_ [_ _ func-obj]] (&a-module/find-def ?module ?name) + class-loader &/loader + :let [func-class (class func-obj) + func-arity (.get ^Field (.getDeclaredField func-class &&/arity-field) nil) + func-partials (.get ^Field (.getDeclaredField (Class/forName "lux.Function" true class-loader) &&/partials-field) func-obj) + num-args (&/|length ?args) + func-class-name (->> func-class .getName &host-generics/->bytecode-class-name)]] + (if (and (= 0 func-partials) + (>= num-args func-arity)) + (|do [_ (compile ?fn) + ^MethodVisitor *writer* &/get-writer + :let [_ (.visitTypeInsn *writer* Opcodes/CHECKCAST func-class-name)] + _ (&/map% compile (&/|take func-arity ?args)) + :let [_ (.visitMethodInsn *writer* Opcodes/INVOKEVIRTUAL func-class-name (if (= 1 func-arity) &&/apply-method "impl") (&&/apply-signature func-arity))] + _ (if (= num-args func-arity) + (return nil) + (compile-apply* compile (&/|drop func-arity ?args)))] + (return nil)) + (|do [_ (compile ?fn)] + (compile-apply* compile ?args)))) + + _ + (|do [_ (compile ?fn)] + (compile-apply* compile ?args)) + )) + +(defn compile-loop [compile-expression register-offset inits body] + (|do [^MethodVisitor *writer* &/get-writer + :let [idxs+inits (&/zip2 (&/|range* 0 (dec (&/|length inits))) + inits)] + _ (&/map% (fn [idx+_init] + (|do [:let [[idx _init] idx+_init + idx+ (+ register-offset idx)] + _ (compile-expression nil _init) + :let [_ (.visitVarInsn *writer* Opcodes/ASTORE idx+)]] + (return nil))) + idxs+inits) + :let [$begin (new Label) + _ (.visitLabel *writer* $begin)]] + (compile-expression $begin body) + )) + +(defn compile-iter [compile $begin register-offset ?args] + (|do [^MethodVisitor *writer* &/get-writer + :let [idxs+args (&/zip2 (&/|range* 0 (dec (&/|length ?args))) + ?args)] + _ (&/map% (fn [idx+?arg] + (|do [:let [[idx ?arg] idx+?arg + idx+ (+ register-offset idx) + already-set? (|case ?arg + [_ (&o/$var (&/$Local l-idx))] + (= idx+ l-idx) + + _ + false)]] + (if already-set? + (return nil) + (compile ?arg)))) + idxs+args) + _ (&/map% (fn [idx+?arg] + (|do [:let [[idx ?arg] idx+?arg + idx+ (+ register-offset idx) + already-set? (|case ?arg + [_ (&o/$var (&/$Local l-idx))] + (= idx+ l-idx) + + _ + false)] + :let [_ (when (not already-set?) + (.visitVarInsn *writer* Opcodes/ASTORE idx+))]] + (return nil))) + (&/|reverse idxs+args)) + :let [_ (.visitJumpInsn *writer* Opcodes/GOTO $begin)]] + (return nil))) + +(defn compile-let [compile _value _register _body] + (|do [^MethodVisitor *writer* &/get-writer + _ (compile _value) + :let [_ (.visitVarInsn *writer* Opcodes/ASTORE _register)] + _ (compile _body)] + (return nil))) + +(defn compile-record-get [compile _value _path] + (|do [^MethodVisitor *writer* &/get-writer + _ (compile _value) + :let [_ (&/|map (fn [step] + (|let [[idx tail?] step] + (doto *writer* + (.visitTypeInsn Opcodes/CHECKCAST "[Ljava/lang/Object;") + (.visitLdcInsn (int idx)) + (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" + (if tail? "product_getRight" "product_getLeft") + "([Ljava/lang/Object;I)Ljava/lang/Object;")))) + _path)]] + (return nil))) + +(defn compile-if [compile _test _then _else] + (|do [^MethodVisitor *writer* &/get-writer + _ (compile _test) + :let [$else (new Label) + $end (new Label) + _ (doto *writer* + &&/unwrap-boolean + (.visitJumpInsn Opcodes/IFEQ $else))] + _ (compile _then) + :let [_ (.visitJumpInsn *writer* Opcodes/GOTO $end)] + :let [_ (.visitLabel *writer* $else)] + _ (compile _else) + :let [_ (.visitJumpInsn *writer* Opcodes/GOTO $end) + _ (.visitLabel *writer* $end)]] + (return nil))) + +(defn ^:private de-ann [optim] + (|case optim + [_ (&o/$ann value-expr _)] + value-expr + + _ + optim)) + +(defn ^:private throwable->text [^Throwable t] + (let [base (->> t + .getStackTrace + (map str) + (cons (.getMessage t)) + (interpose "\n") + (apply str))] + (if-let [cause (.getCause t)] + (str base "\n\n" "Caused by: " (throwable->text cause)) + base))) + +(let [class-flags (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_SUPER) + field-flags (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_STATIC)] + (defn compile-def [compile ?name ?body ?meta] + (|do [module-name &/get-module-name + class-loader &/loader] + (|case (&a-meta/meta-get &a-meta/alias-tag ?meta) + (&/$Some (&/$IdentM [r-module r-name])) + (if (= 1 (&/|length ?meta)) + (|do [:let [current-class (&host-generics/->class-name (str (&host/->module-class r-module) "/" (&host/def-name r-name))) + def-class (&&/load-class! class-loader current-class) + def-type (&a-module/def-type r-module r-name) + def-meta ?meta + def-value (-> def-class (.getField &/value-field) (.get nil))] + _ (&/without-repl-closure + (&a-module/define module-name ?name def-type def-meta def-value))] + (return nil)) + (fail (str "[Compilation Error] Aliases cannot contain meta-data: " module-name ";" ?name))) + + (&/$Some _) + (fail "[Compilation Error] Invalid syntax for lux;alias meta-data. Must be an Ident.") + + _ + (|case (de-ann ?body) + [_ (&o/$function _ _ __scope _ _)] + (|let [[_ (&o/$function _ _arity _scope _captured ?body+)] (&o/shift-function-body (&/|tail __scope) __scope + false + (de-ann ?body))] + (|do [:let [=value-type (&a/expr-type* ?body)] + [file-name _ _] &/cursor + :let [datum-sig "Ljava/lang/Object;" + def-name (&host/def-name ?name) + current-class (str (&host/->module-class module-name) "/" def-name) + =class (doto (new ClassWriter ClassWriter/COMPUTE_MAXS) + (.visit &host/bytecode-version class-flags + current-class nil &&/function-class (into-array String [])) + (-> (.visitField field-flags &/name-field "Ljava/lang/String;" nil ?name) + (doto (.visitEnd))) + (-> (.visitField field-flags &/value-field datum-sig nil nil) + (doto (.visitEnd))) + (.visitSource file-name nil))] + instancer (&&lambda/compile-function compile (&/$Some =class) _arity _scope _captured ?body+) + _ (&/with-writer (.visitMethod =class Opcodes/ACC_STATIC "<clinit>" "()V" nil nil) + (|do [^MethodVisitor **writer** &/get-writer + :let [_ (.visitCode **writer**)] + _ instancer + :let [_ (.visitTypeInsn **writer** Opcodes/CHECKCAST "java/lang/Object") + _ (.visitFieldInsn **writer** Opcodes/PUTSTATIC current-class &/value-field datum-sig)] + :let [_ (doto **writer** + (.visitInsn Opcodes/RETURN) + (.visitMaxs 0 0) + (.visitEnd))]] + (return nil))) + :let [_ (.visitEnd =class)] + _ (&&/save-class! def-name (.toByteArray =class)) + :let [def-class (&&/load-class! class-loader (&host-generics/->class-name current-class)) + def-type (&a/expr-type* ?body) + is-type? (|case (&a-meta/meta-get &a-meta/type?-tag ?meta) + (&/$Some (&/$BoolM true)) + true + + _ + false) + def-meta ?meta + def-value (-> def-class (.getField &/value-field) (.get nil))] + _ (&/without-repl-closure + (&a-module/define module-name ?name def-type def-meta def-value)) + _ (|case (&/T [is-type? (&a-meta/meta-get &a-meta/tags-tag def-meta)]) + [true (&/$Some (&/$ListM tags*))] + (|do [:let [was-exported? (|case (&a-meta/meta-get &a-meta/export?-tag def-meta) + (&/$Some _) + true + + _ + false)] + tags (&/map% (fn [tag*] + (|case tag* + (&/$TextM tag) + (return tag) + + _ + (fail "[Compiler Error] Incorrect format for tags."))) + tags*) + _ (&a-module/declare-tags module-name tags was-exported? def-value)] + (return nil)) + + [false (&/$Some _)] + (fail "[Compiler Error] Can't define tags for non-type.") + + [true (&/$Some _)] + (fail "[Compiler Error] Incorrect format for tags.") + + [_ (&/$None)] + (return nil)) + :let [_ (println 'DEF (str module-name ";" ?name))]] + (return nil))) + + _ + (|do [:let [=value-type (&a/expr-type* ?body)] + [file-name _ _] &/cursor + :let [datum-sig "Ljava/lang/Object;" + def-name (&host/def-name ?name) + current-class (str (&host/->module-class module-name) "/" def-name) + =class (doto (new ClassWriter ClassWriter/COMPUTE_MAXS) + (.visit &host/bytecode-version class-flags + current-class nil "java/lang/Object" (into-array String [])) + (-> (.visitField field-flags &/name-field "Ljava/lang/String;" nil ?name) + (doto (.visitEnd))) + (-> (.visitField field-flags &/value-field datum-sig nil nil) + (doto (.visitEnd))) + (.visitSource file-name nil))] + _ (&/with-writer (.visitMethod =class Opcodes/ACC_STATIC "<clinit>" "()V" nil nil) + (|do [^MethodVisitor **writer** &/get-writer + :let [_ (.visitCode **writer**)] + _ (compile nil ?body) + :let [_ (.visitTypeInsn **writer** Opcodes/CHECKCAST "java/lang/Object") + _ (.visitFieldInsn **writer** Opcodes/PUTSTATIC current-class &/value-field datum-sig)] + :let [_ (doto **writer** + (.visitInsn Opcodes/RETURN) + (.visitMaxs 0 0) + (.visitEnd))]] + (return nil))) + :let [_ (.visitEnd =class)] + _ (&&/save-class! def-name (.toByteArray =class)) + :let [def-class (&&/load-class! class-loader (&host-generics/->class-name current-class)) + def-type (&a/expr-type* ?body) + is-type? (|case (&a-meta/meta-get &a-meta/type?-tag ?meta) + (&/$Some (&/$BoolM true)) + true + + _ + false) + def-meta ?meta] + def-value (try (return (-> def-class (.getField &/value-field) (.get nil))) + (catch Throwable t + (&/assert! false (throwable->text t)))) + _ (&/without-repl-closure + (&a-module/define module-name ?name def-type def-meta def-value)) + _ (|case (&/T [is-type? (&a-meta/meta-get &a-meta/tags-tag def-meta)]) + [true (&/$Some (&/$ListM tags*))] + (|do [:let [was-exported? (|case (&a-meta/meta-get &a-meta/export?-tag def-meta) + (&/$Some _) + true + + _ + false)] + tags (&/map% (fn [tag*] + (|case tag* + (&/$TextM tag) + (return tag) + + _ + (fail "[Compiler Error] Incorrect format for tags."))) + tags*) + _ (&a-module/declare-tags module-name tags was-exported? def-value)] + (return nil)) + + [false (&/$Some _)] + (fail "[Compiler Error] Can't define tags for non-type.") + + [true (&/$Some _)] + (fail "[Compiler Error] Incorrect format for tags.") + + [_ (&/$None)] + (return nil)) + :let [_ (println 'DEF (str module-name ";" ?name))]] + (return nil))) + )))) + +(defn compile-program [compile ?body] + (|do [module-name &/get-module-name + ^ClassWriter *writer* &/get-writer] + (&/with-writer (doto (.visitMethod *writer* (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "main" "([Ljava/lang/String;)V" nil nil) + (.visitCode)) + (|do [^MethodVisitor main-writer &/get-writer + :let [$loop (new Label) + $end (new Label) + _ (doto main-writer + ;; Tail: Begin + (.visitLdcInsn (->> #'&/$Nil meta ::&/idx int)) ;; I + (.visitInsn Opcodes/ACONST_NULL) ;; I? + (.visitLdcInsn &/unit-tag) ;; I?U + (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "sum_make" "(ILjava/lang/Object;Ljava/lang/Object;)[Ljava/lang/Object;") ;; V + ;; Tail: End + ;; Size: Begin + (.visitVarInsn Opcodes/ALOAD 0) ;; VA + (.visitInsn Opcodes/ARRAYLENGTH) ;; VI + ;; Size: End + ;; Loop: Begin + (.visitLabel $loop) + (.visitLdcInsn (int 1)) ;; VII + (.visitInsn Opcodes/ISUB) ;; VI + (.visitInsn Opcodes/DUP) ;; VII + (.visitJumpInsn Opcodes/IFLT $end) ;; VI + ;; Head: Begin + (.visitInsn Opcodes/DUP) ;; VII + (.visitVarInsn Opcodes/ALOAD 0) ;; VIIA + (.visitInsn Opcodes/SWAP) ;; VIAI + (.visitInsn Opcodes/AALOAD) ;; VIO + (.visitInsn Opcodes/SWAP) ;; VOI + (.visitInsn Opcodes/DUP_X2) ;; IVOI + (.visitInsn Opcodes/POP) ;; IVO + ;; Head: End + ;; Tuple: Begin + (.visitLdcInsn (int 2)) ;; IVOS + (.visitTypeInsn Opcodes/ANEWARRAY "java/lang/Object") ;; IVO2 + (.visitInsn Opcodes/DUP_X1) ;; IV2O2 + (.visitInsn Opcodes/SWAP) ;; IV22O + (.visitLdcInsn (int 0)) ;; IV22OI + (.visitInsn Opcodes/SWAP) ;; IV22IO + (.visitInsn Opcodes/AASTORE) ;; IV2 + (.visitInsn Opcodes/DUP_X1) ;; I2V2 + (.visitInsn Opcodes/SWAP) ;; I22V + (.visitLdcInsn (int 1)) ;; I22VI + (.visitInsn Opcodes/SWAP) ;; I22IV + (.visitInsn Opcodes/AASTORE) ;; I2 + ;; Tuple: End + ;; Cons: Begin + (.visitLdcInsn (->> #'&/$Cons meta ::&/idx int)) ;; I2I + (.visitLdcInsn "") ;; I2I? + (.visitInsn Opcodes/DUP2_X1) ;; II?2I? + (.visitInsn Opcodes/POP2) ;; II?2 + (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "sum_make" "(ILjava/lang/Object;Ljava/lang/Object;)[Ljava/lang/Object;") ;; IV + ;; Cons: End + (.visitInsn Opcodes/SWAP) ;; VI + (.visitJumpInsn Opcodes/GOTO $loop) + ;; Loop: End + (.visitLabel $end) ;; VI + (.visitInsn Opcodes/POP) ;; V + (.visitVarInsn Opcodes/ASTORE (int 0)) ;; + ) + ] + _ (compile ?body) + :let [_ (doto main-writer + (.visitTypeInsn Opcodes/CHECKCAST &&/function-class) + (.visitInsn Opcodes/ACONST_NULL) + (.visitMethodInsn Opcodes/INVOKEVIRTUAL &&/function-class &&/apply-method (&&/apply-signature 1)))] + :let [_ (doto main-writer + (.visitInsn Opcodes/POP) + (.visitInsn Opcodes/RETURN) + (.visitMaxs 0 0) + (.visitEnd))]] + (return nil))))) diff --git a/luxc/src/lux/compiler/module.clj b/luxc/src/lux/compiler/module.clj new file mode 100644 index 000000000..03bc311f2 --- /dev/null +++ b/luxc/src/lux/compiler/module.clj @@ -0,0 +1,28 @@ +;; Copyright (c) Eduardo Julian. All rights reserved. +;; This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +;; If a copy of the MPL was not distributed with this file, +;; You can obtain one at http://mozilla.org/MPL/2.0/. + +(ns lux.compiler.module + (:require (clojure [string :as string] + [set :as set] + [template :refer [do-template]]) + clojure.core.match + clojure.core.match.array + (lux [base :as & :refer [|let |do return* return fail fail* |case]] + [type :as &type]) + [lux.analyser.module :as &module])) + +;; [Exports] +(def tag-groups + "(Lux (List (, Text (List Text))))" + (|do [module &/get-current-module] + (return (&/|map (fn [pair] + (|case pair + [name [tags exported? _]] + (&/T [name (&/|map (fn [tag] + (|let [[t-prefix t-name] tag] + t-name)) + tags)]))) + (&/get$ &module/$types module))) + )) diff --git a/luxc/src/lux/compiler/parallel.clj b/luxc/src/lux/compiler/parallel.clj new file mode 100644 index 000000000..8f6fee99d --- /dev/null +++ b/luxc/src/lux/compiler/parallel.clj @@ -0,0 +1,47 @@ +;; Copyright (c) Eduardo Julian. All rights reserved. +;; This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +;; If a copy of the MPL was not distributed with this file, +;; You can obtain one at http://mozilla.org/MPL/2.0/. + +(ns lux.compiler.parallel + (:require (clojure [string :as string] + [set :as set] + [template :refer [do-template]]) + clojure.core.match + clojure.core.match.array + (lux [base :as & :refer [|let |do return* return fail fail* |case]]))) + +;; [Utils] +(def ^:private !state! (ref {})) + +(def ^:private get-compiler + (fn [compiler] + (return* compiler compiler))) + +;; [Exports] +(defn setup! + "Must always call this function before using parallel compilation to make sure that the state that is being tracked is in proper shape." + [] + (dosync (ref-set !state! {}))) + +(defn parallel-compilation [compile-module*] + (fn [module-name] + (|do [compiler get-compiler + :let [[task new?] (dosync (if-let [existing-task (get @!state! module-name)] + (&/T [existing-task false]) + (let [new-task (promise)] + (do (alter !state! assoc module-name new-task) + (&/T [new-task true]))))) + _ (when new? + (.start (new Thread + (fn [] + (let [out-str (with-out-str + (|case (&/run-state (compile-module* module-name) + compiler) + (&/$Right post-compiler _) + (deliver task (&/$Right post-compiler)) + + (&/$Left ?error) + (deliver task (&/$Left ?error))))] + (&/|log! out-str))))))]] + (return task)))) diff --git a/luxc/src/lux/host.clj b/luxc/src/lux/host.clj new file mode 100644 index 000000000..39e659964 --- /dev/null +++ b/luxc/src/lux/host.clj @@ -0,0 +1,432 @@ +;; Copyright (c) Eduardo Julian. All rights reserved. +;; This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +;; If a copy of the MPL was not distributed with this file, +;; You can obtain one at http://mozilla.org/MPL/2.0/. + +(ns lux.host + (:require (clojure [string :as string] + [template :refer [do-template]]) + clojure.core.match + clojure.core.match.array + (lux [base :as & :refer [|do return* return fail fail* |let |case]] + [type :as &type]) + [lux.type.host :as &host-type] + [lux.host.generics :as &host-generics]) + (:import (java.lang.reflect Field Method Constructor Modifier Type + GenericArrayType ParameterizedType TypeVariable) + (org.objectweb.asm Opcodes + Label + ClassWriter + MethodVisitor))) + +;; [Constants] +(def function-class "lux.Function") +(def module-separator "/") +(def class-name-separator ".") +(def class-separator "/") +(def bytecode-version Opcodes/V1_6) + +;; [Resources] +(defn ^String ->module-class [old] + old) + +(def ->package ->module-class) + +(defn unfold-array [type] + "(-> Type (, Int Type))" + (|case type + (&/$HostT "#Array" (&/$Cons param (&/$Nil))) + (|let [[count inner] (unfold-array param)] + (&/T [(inc count) inner])) + + _ + (&/T [0 type]))) + +(let [ex-type-class (str "L" (&host-generics/->bytecode-class-name "java.lang.Object") ";") + object-array (str "[" "L" (&host-generics/->bytecode-class-name "java.lang.Object") ";")] + (defn ->java-sig [^objects type] + "(-> Type (Lux Text))" + (|case type + (&/$HostT ?name params) + (cond (= &host-type/array-data-tag ?name) (|do [:let [[level base] (unfold-array type)] + base-sig (|case base + (&/$HostT base-class _) + (return (&host-generics/->type-signature base-class)) + + _ + (->java-sig base))] + (return (str (->> (&/|repeat level "[") (&/fold str "")) + base-sig))) + (= &host-type/null-data-tag ?name) (return (&host-generics/->type-signature "java.lang.Object")) + :else (return (&host-generics/->type-signature ?name))) + + (&/$LambdaT _ _) + (return (&host-generics/->type-signature function-class)) + + (&/$UnitT) + (return "V") + + (&/$SumT _) + (return object-array) + + (&/$ProdT _) + (return object-array) + + (&/$NamedT ?name ?type) + (->java-sig ?type) + + (&/$AppT ?F ?A) + (|do [type* (&type/apply-type ?F ?A)] + (->java-sig type*)) + + (&/$ExT _) + (return ex-type-class) + + _ + (assert false (str '->java-sig " " (&type/show-type type))) + ))) + +(do-template [<name> <static?>] + (defn <name> [class-loader target field] + (|let [target-class (Class/forName target true class-loader)] + (if-let [^Type gtype (first (for [^Field =field (seq (.getDeclaredFields target-class)) + :when (and (.equals ^Object field (.getName =field)) + (.equals ^Object <static?> (Modifier/isStatic (.getModifiers =field))))] + (.getGenericType =field)))] + (|let [gvars (->> target-class .getTypeParameters seq &/->list)] + (return (&/T [gvars gtype]))) + (&/fail-with-loc (str "[Host Error] Field does not exist: " target "." field))))) + + lookup-static-field true + lookup-field false + ) + +(do-template [<name> <static?> <method-type>] + (defn <name> [class-loader target method-name args] + (|let [target-class (Class/forName target true class-loader)] + (if-let [[^Method method ^Class declarer] (first (for [^Method =method (.getDeclaredMethods target-class) + :when (and (.equals ^Object method-name (.getName =method)) + (.equals ^Object <static?> (Modifier/isStatic (.getModifiers =method))) + (let [param-types (&/->list (seq (.getParameterTypes =method)))] + (and (= (&/|length args) (&/|length param-types)) + (&/fold2 #(and %1 (.equals ^Object %2 %3)) + true + args + (&/|map #(.getName ^Class %) param-types)))))] + [=method + (.getDeclaringClass =method)]))] + (if (= target-class declarer) + (|let [parent-gvars (->> target-class .getTypeParameters seq &/->list) + gvars (->> method .getTypeParameters seq &/->list) + gargs (->> method .getGenericParameterTypes seq &/->list) + _ (when (.getAnnotation method java.lang.Deprecated) + (println (str "[Host Warning] Deprecated method: " target "." method-name " " (->> args &/->seq print-str))))] + (return (&/T [(.getGenericReturnType method) + (->> method .getExceptionTypes &/->list (&/|map #(.getName ^Class %))) + parent-gvars + gvars + gargs]))) + (&/fail-with-loc (str "[Host Error] " <method-type> " method " (pr-str method-name) " for " "(" (->> args (&/|interpose ", ") (&/fold str "")) ")" " belongs to parent " (.getName declarer) " instead of " target))) + (&/fail-with-loc (str "[Host Error] " <method-type> " method does not exist: " target "." method-name " " "(" (->> args (&/|interpose ", ") (&/fold str "")) ")"))))) + + lookup-static-method true "Static" + lookup-virtual-method false "Virtual" + ) + +(defn lookup-constructor [class-loader target args] + (let [target-class (Class/forName target true class-loader)] + (if-let [^Constructor ctor (first (for [^Constructor =method (.getDeclaredConstructors target-class) + :when (let [param-types (&/->list (seq (.getParameterTypes =method)))] + (and (= (&/|length args) (&/|length param-types)) + (&/fold2 #(and %1 (.equals ^Object %2 %3)) + true + args + (&/|map #(.getName ^Class %) param-types))))] + =method))] + (|let [gvars (->> target-class .getTypeParameters seq &/->list) + gargs (->> ctor .getGenericParameterTypes seq &/->list) + exs (->> ctor .getExceptionTypes &/->list (&/|map #(.getName ^Class %))) + _ (when (.getAnnotation ctor java.lang.Deprecated) + (println (str "[Host Warning] Deprecated constructor: " target " " (->> args &/->seq print-str))))] + (return (&/T [exs gvars gargs]))) + (&/fail-with-loc (str "[Host Error] Constructor does not exist: " target " " (->> args &/->seq print-str)))))) + +(defn abstract-methods [class-loader super-class] + "(-> ClassLoader SuperClassDecl (Lux (List (, Text (List Text)))))" + (|let [[super-name super-params] super-class] + (return (&/->list (for [^Method =method (.getDeclaredMethods (Class/forName super-name true class-loader)) + :when (Modifier/isAbstract (.getModifiers =method))] + (&/T [(.getName =method) (&/|map #(.getName ^Class %) (&/->list (seq (.getParameterTypes =method))))])))))) + +(defn def-name [name] + (str (&/normalize-name name) "_" (Long/toUnsignedString (hash name)))) + +(defn location [scope] + (let [scope (&/$Cons (def-name (&/|head scope)) + (&/|map &/normalize-name (&/|tail scope)))] + (->> scope + (&/|interpose "$") + (&/fold str "")))) + +(defn primitive-jvm-type? [type] + (case type + ("boolean" "byte" "short" "int" "long" "float" "double" "char") + true + ;; else + false)) + +(defn dummy-value [^MethodVisitor writer class] + (|case class + (&/$GenericClass "boolean" (&/$Nil)) + (doto writer + (.visitLdcInsn false)) + + (&/$GenericClass "byte" (&/$Nil)) + (doto writer + (.visitLdcInsn (byte 0))) + + (&/$GenericClass "short" (&/$Nil)) + (doto writer + (.visitLdcInsn (short 0))) + + (&/$GenericClass "int" (&/$Nil)) + (doto writer + (.visitLdcInsn (int 0))) + + (&/$GenericClass "long" (&/$Nil)) + (doto writer + (.visitLdcInsn (long 0))) + + (&/$GenericClass "float" (&/$Nil)) + (doto writer + (.visitLdcInsn (float 0.0))) + + (&/$GenericClass "double" (&/$Nil)) + (doto writer + (.visitLdcInsn (double 0.0))) + + (&/$GenericClass "char" (&/$Nil)) + (doto writer + (.visitLdcInsn (char 0))) + + _ + (doto writer + (.visitInsn Opcodes/ACONST_NULL)))) + +(defn ^:private dummy-return [^MethodVisitor writer output] + (|case output + (&/$GenericClass "void" (&/$Nil)) + (.visitInsn writer Opcodes/RETURN) + + (&/$GenericClass "boolean" (&/$Nil)) + (doto writer + (dummy-value output) + (.visitInsn Opcodes/IRETURN)) + + (&/$GenericClass "byte" (&/$Nil)) + (doto writer + (dummy-value output) + (.visitInsn Opcodes/IRETURN)) + + (&/$GenericClass "short" (&/$Nil)) + (doto writer + (dummy-value output) + (.visitInsn Opcodes/IRETURN)) + + (&/$GenericClass "int" (&/$Nil)) + (doto writer + (dummy-value output) + (.visitInsn Opcodes/IRETURN)) + + (&/$GenericClass "long" (&/$Nil)) + (doto writer + (dummy-value output) + (.visitInsn Opcodes/LRETURN)) + + (&/$GenericClass "float" (&/$Nil)) + (doto writer + (dummy-value output) + (.visitInsn Opcodes/FRETURN)) + + (&/$GenericClass "double" (&/$Nil)) + (doto writer + (dummy-value output) + (.visitInsn Opcodes/DRETURN)) + + (&/$GenericClass "char" (&/$Nil)) + (doto writer + (dummy-value output) + (.visitInsn Opcodes/IRETURN)) + + _ + (doto writer + (dummy-value output) + (.visitInsn Opcodes/ARETURN)))) + +(defn ^:private ->dummy-type [real-name store-name gclass] + (|case gclass + (&/$GenericClass _name _params) + (if (= real-name _name) + (&/$GenericClass store-name (&/|map (partial ->dummy-type real-name store-name) _params)) + gclass) + + _ + gclass)) + +(def init-method-name "<init>") + +(defn ^:private dummy-ctor [^MethodVisitor writer real-name store-name super-class ctor-args] + (|let [ctor-arg-types (->> ctor-args (&/|map (comp &host-generics/->type-signature (comp (partial ->dummy-type real-name store-name) &/|first))) (&/fold str ""))] + (doto writer + (.visitVarInsn Opcodes/ALOAD 0) + (-> (doto (dummy-value arg-type) + (-> (.visitTypeInsn Opcodes/CHECKCAST (&host-generics/->bytecode-class-name arg-type)) + (->> (when (not (primitive-jvm-type? arg-type)))))) + (->> (doseq [ctor-arg (&/->seq ctor-args) + :let [;; arg-term (&/|first ctor-arg) + arg-type (->dummy-type real-name store-name (&/|first ctor-arg))]]))) + (.visitMethodInsn Opcodes/INVOKESPECIAL (&host-generics/->bytecode-class-name (&host-generics/super-class-name super-class)) init-method-name (str "(" ctor-arg-types ")V")) + (.visitInsn Opcodes/RETURN)))) + +(defn ^:private compile-dummy-method [^ClassWriter =class real-name store-name super-class method-def] + (|case method-def + (&/$ConstructorMethodSyntax =privacy-modifier ?strict =anns =gvars =exceptions =inputs =ctor-args body) + (|let [=output (&/$GenericClass "void" (&/|list)) + method-decl [init-method-name =anns =gvars (&/|map (partial ->dummy-type real-name store-name) =exceptions) (&/|map (comp (partial ->dummy-type real-name store-name) &/|second) =inputs) (->dummy-type real-name store-name =output)] + [simple-signature generic-signature] (&host-generics/method-signatures method-decl)] + (doto (.visitMethod =class Opcodes/ACC_PUBLIC + init-method-name + simple-signature + generic-signature + (->> =exceptions (&/|map &host-generics/gclass->bytecode-class-name) &/->seq (into-array java.lang.String))) + .visitCode + (dummy-ctor real-name store-name super-class =ctor-args) + (.visitMaxs 0 0) + (.visitEnd))) + + (&/$VirtualMethodSyntax =name =privacy-modifier =final? ?strict =anns =gvars =exceptions =inputs =output body) + (|let [method-decl [=name =anns =gvars (&/|map (partial ->dummy-type real-name store-name) =exceptions) (&/|map (comp (partial ->dummy-type real-name store-name) &/|second) =inputs) (->dummy-type real-name store-name =output)] + [simple-signature generic-signature] (&host-generics/method-signatures method-decl)] + (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC + (if =final? Opcodes/ACC_FINAL 0)) + =name + simple-signature + generic-signature + (->> =exceptions (&/|map &host-generics/gclass->bytecode-class-name) &/->seq (into-array java.lang.String))) + .visitCode + (dummy-return =output) + (.visitMaxs 0 0) + (.visitEnd))) + + (&/$OverridenMethodSyntax =class-decl =name ?strict =anns =gvars =exceptions =inputs =output body) + (|let [method-decl [=name =anns =gvars (&/|map (partial ->dummy-type real-name store-name) =exceptions) (&/|map (comp (partial ->dummy-type real-name store-name) &/|second) =inputs) (->dummy-type real-name store-name =output)] + [simple-signature generic-signature] (&host-generics/method-signatures method-decl)] + (doto (.visitMethod =class Opcodes/ACC_PUBLIC + =name + simple-signature + generic-signature + (->> =exceptions (&/|map &host-generics/gclass->bytecode-class-name) &/->seq (into-array java.lang.String))) + .visitCode + (dummy-return =output) + (.visitMaxs 0 0) + (.visitEnd))) + + (&/$StaticMethodSyntax =name =privacy-modifier ?strict =anns =gvars =exceptions =inputs =output body) + (|let [method-decl [=name =anns =gvars (&/|map (partial ->dummy-type real-name store-name) =exceptions) (&/|map (comp (partial ->dummy-type real-name store-name) &/|second) =inputs) (->dummy-type real-name store-name =output)] + [simple-signature generic-signature] (&host-generics/method-signatures method-decl)] + (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) + =name + simple-signature + generic-signature + (->> =exceptions (&/|map &host-generics/gclass->bytecode-class-name) &/->seq (into-array java.lang.String))) + .visitCode + (dummy-return =output) + (.visitMaxs 0 0) + (.visitEnd))) + + (&/$AbstractMethodSyntax =name =privacy-modifier =anns =gvars =exceptions =inputs =output) + (|let [method-decl [=name =anns =gvars (&/|map (partial ->dummy-type real-name store-name) =exceptions) (&/|map (comp (partial ->dummy-type real-name store-name) &/|second) =inputs) (->dummy-type real-name store-name =output)] + [simple-signature generic-signature] (&host-generics/method-signatures method-decl)] + (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_ABSTRACT) + =name + simple-signature + generic-signature + (->> =exceptions (&/|map &host-generics/gclass->bytecode-class-name) &/->seq (into-array java.lang.String))) + (.visitEnd))) + + (&/$NativeMethodSyntax =name =privacy-modifier =anns =gvars =exceptions =inputs =output) + (|let [method-decl [=name =anns =gvars (&/|map (partial ->dummy-type real-name store-name) =exceptions) (&/|map (comp (partial ->dummy-type real-name store-name) &/|second) =inputs) (->dummy-type real-name store-name =output)] + [simple-signature generic-signature] (&host-generics/method-signatures method-decl)] + (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_NATIVE) + =name + simple-signature + generic-signature + (->> =exceptions (&/|map &host-generics/gclass->bytecode-class-name) &/->seq (into-array java.lang.String))) + (.visitEnd))) + + _ + (assert false (println-str 'compile-dummy-method (&/adt->text method-def))) + )) + +(defn privacy-modifier->flag [privacy-modifier] + "(-> PrivacyModifier Int)" + (|case privacy-modifier + (&/$PublicPM) Opcodes/ACC_PUBLIC + (&/$PrivatePM) Opcodes/ACC_PRIVATE + (&/$ProtectedPM) Opcodes/ACC_PROTECTED + (&/$DefaultPM) 0 + )) + +(defn state-modifier->flag [state-modifier] + "(-> StateModifier Int)" + (|case state-modifier + (&/$DefaultSM) 0 + (&/$VolatileSM) Opcodes/ACC_VOLATILE + (&/$FinalSM) Opcodes/ACC_FINAL)) + +(defn inheritance-modifier->flag [inheritance-modifier] + "(-> InheritanceModifier Int)" + (|case inheritance-modifier + (&/$DefaultIM) 0 + (&/$AbstractIM) Opcodes/ACC_ABSTRACT + (&/$FinalIM) Opcodes/ACC_FINAL)) + +(defn use-dummy-class [class-decl super-class interfaces ctor-args fields methods] + (|do [module &/get-module-name + :let [[?name ?params] class-decl + dummy-name ?name;; (str ?name "__DUMMY__") + dummy-full-name (str module "/" dummy-name) + real-name (str (&host-generics/->class-name module) "." ?name) + store-name (str (&host-generics/->class-name module) "." dummy-name) + class-signature (&host-generics/gclass-decl->signature class-decl (&/$Cons super-class interfaces)) + =class (doto (new ClassWriter ClassWriter/COMPUTE_MAXS) + (.visit bytecode-version (+ Opcodes/ACC_PUBLIC Opcodes/ACC_SUPER) + dummy-full-name + (if (= "" class-signature) nil class-signature) + (&host-generics/->bytecode-class-name (&host-generics/super-class-name super-class)) + (->> interfaces (&/|map (comp &host-generics/->bytecode-class-name &host-generics/super-class-name)) &/->seq (into-array String)))) + _ (&/|map (fn [field] + (|case field + (&/$ConstantFieldAnalysis =name =anns =type ?value) + (doto (.visitField =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC Opcodes/ACC_FINAL) =name + (&host-generics/gclass->simple-signature =type) + (&host-generics/gclass->signature =type) + nil) + (.visitEnd)) + + (&/$VariableFieldAnalysis =name =privacy-modifier =state-modifier =anns =type) + (doto (.visitField =class (+ Opcodes/ACC_PUBLIC (state-modifier->flag =state-modifier)) =name + (&host-generics/gclass->simple-signature =type) + (&host-generics/gclass->signature =type) + nil) + (.visitEnd)) + )) + fields) + _ (&/|map (partial compile-dummy-method =class real-name store-name super-class) methods) + bytecode (.toByteArray (doto =class .visitEnd))] + ^ClassLoader loader &/loader + !classes &/classes + :let [_ (swap! !classes assoc store-name bytecode) + _ (.loadClass loader store-name)] + _ (&/push-dummy-name real-name store-name)] + (return nil))) diff --git a/luxc/src/lux/host/generics.clj b/luxc/src/lux/host/generics.clj new file mode 100644 index 000000000..cfd0d2d54 --- /dev/null +++ b/luxc/src/lux/host/generics.clj @@ -0,0 +1,205 @@ +;; Copyright (c) Eduardo Julian. All rights reserved. +;; This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +;; If a copy of the MPL was not distributed with this file, +;; You can obtain one at http://mozilla.org/MPL/2.0/. + +(ns lux.host.generics + (:require (clojure [string :as string] + [template :refer [do-template]]) + clojure.core.match + clojure.core.match.array + (lux [base :as & :refer [|do return* return fail fail* |let |case]])) + (:import java.util.regex.Pattern)) + +(declare gclass->signature) + +(do-template [<name> <old-sep> <new-sep>] + (let [regex (-> <old-sep> Pattern/quote re-pattern)] + (defn <name> [old] + (string/replace old regex <new-sep>))) + + ;; ->class + ^String ->bytecode-class-name "." "/" + ;; ->class-name + ^String ->class-name "/" "." + ) + +;; ->type-signature +(defn ->type-signature [class] + (case class + "void" "V" + "boolean" "Z" + "byte" "B" + "short" "S" + "int" "I" + "long" "J" + "float" "F" + "double" "D" + "char" "C" + ;; else + (let [class* (->bytecode-class-name class)] + (if (.startsWith class* "[") + class* + (str "L" class* ";"))) + )) + +(defn super-class-name [super] + "(-> GenericSuperClassDecl Text)" + (|let [[super-name super-params] super] + super-name)) + +(defn formal-type-parameter->signature [param] + (|let [[pname pbounds] param] + (|case pbounds + (&/$Nil) + pname + + _ + (->> pbounds + (&/|map (fn [pbound] (str ": " (gclass->signature pbound)))) + (&/|interpose " ") + (str pname " ")) + ))) + +(defn formal-type-parameters->signature [params] + (if (&/|empty? params) + "" + (str "<" (->> params (&/|map formal-type-parameter->signature) (&/|interpose " ") (&/fold str "")) ">"))) + +(defn gclass->signature [super] + "(-> GenericClass Text)" + (|case super + (&/$GenericTypeVar name) + (str "T" name ";") + + (&/$GenericWildcard (&/$None)) + "*" + + (&/$GenericWildcard (&/$Some [(&/$UpperBound) ?bound])) + (str "+" (gclass->signature ?bound)) + + (&/$GenericWildcard (&/$Some [(&/$LowerBound) ?bound])) + (str "-" (gclass->signature ?bound)) + + (&/$GenericClass ^String name params) + (case name + "void" "V" + "boolean" "Z" + "byte" "B" + "short" "S" + "int" "I" + "long" "J" + "float" "F" + "double" "D" + "char" "C" + ;; else + (if (.startsWith name "[") + name + (let [params* (if (&/|empty? params) + "" + (str "<" (->> params (&/|map gclass->signature) (&/|interpose "") (&/fold str "")) ">"))] + (str "L" (->bytecode-class-name name) params* ";")))) + + (&/$GenericArray param) + (str "[" (gclass->signature param)))) + +(defn gsuper-decl->signature [super] + "(-> GenericSuperClassDecl Text)" + (|let [[super-name super-params] super + params* (if (&/|empty? super-params) + "" + (str "<" (->> super-params (&/|map gclass->signature) (&/|interpose " ") (&/fold str "")) ">"))] + (str "L" (->bytecode-class-name super-name) params* ";"))) + +(defn gclass-decl->signature [class-decl supers] + "(-> GenericClassDecl (List GenericSuperClassDecl) Text)" + (|let [[class-name class-vars] class-decl + vars-section (formal-type-parameters->signature class-vars) + super-section (->> (&/|map gsuper-decl->signature supers) (&/|interpose " ") (&/fold str ""))] + (str vars-section super-section))) + +(let [object-simple-signature (->type-signature "java.lang.Object")] + (defn gclass->simple-signature [gclass] + "(-> GenericClass Text)" + (|case gclass + (&/$GenericTypeVar name) + object-simple-signature + + (&/$GenericWildcard _) + object-simple-signature + + (&/$GenericClass name params) + (->type-signature name) + + (&/$GenericArray param) + (str "[" (gclass->simple-signature param)) + + _ + (assert false (str 'gclass->simple-signature " " (&/adt->text gclass)))))) + +(defn gclass->class-name [gclass] + "(-> GenericClass Text)" + (|case gclass + (&/$GenericTypeVar name) + (->bytecode-class-name "java.lang.Object") + + (&/$GenericWildcard _) + (->bytecode-class-name "java.lang.Object") + + (&/$GenericClass name params) + (->bytecode-class-name name) + + (&/$GenericArray param) + (str "[" (gclass->class-name param)) + + _ + (assert false (str 'gclass->class-name " " (&/adt->text gclass))))) + +(let [object-bc-name (->bytecode-class-name "java.lang.Object")] + (defn gclass->bytecode-class-name* [gclass type-env] + "(-> GenericClass Text)" + (|case gclass + (&/$GenericTypeVar name) + object-bc-name + + (&/$GenericWildcard _) + object-bc-name + + (&/$GenericClass name params) + ;; When referring to type-parameters during class or method + ;; definition, a type-environment is set for storing the names + ;; of such parameters. + ;; When a "class" shows up with the name of one of those + ;; parameters, it must be detected, and the bytecode class-name + ;; must correspond to Object's. + (if (&/|get name type-env) + object-bc-name + (->bytecode-class-name name)) + + (&/$GenericArray param) + (assert false "gclass->bytecode-class-name* doesn't work on arrays.")))) + +(let [object-bc-name (->bytecode-class-name "java.lang.Object")] + (defn gclass->bytecode-class-name [gclass] + "(-> GenericClass Text)" + (|case gclass + (&/$GenericTypeVar name) + object-bc-name + + (&/$GenericWildcard _) + object-bc-name + + (&/$GenericClass name params) + (->bytecode-class-name name) + + (&/$GenericArray param) + (assert false "gclass->bytecode-class-name doesn't work on arrays.")))) + +(defn method-signatures [method-decl] + (|let [[=name =anns =gvars =exceptions =inputs =output] method-decl + simple-signature (str "(" (&/fold str "" (&/|map gclass->simple-signature =inputs)) ")" (gclass->simple-signature =output)) + generic-signature (str (formal-type-parameters->signature =gvars) + "(" (&/fold str "" (&/|map gclass->signature =inputs)) ")" + (gclass->signature =output) + (->> =exceptions (&/|map gclass->signature) (&/|interpose " ") (&/fold str "")))] + (&/T [simple-signature generic-signature]))) diff --git a/luxc/src/lux/lexer.clj b/luxc/src/lux/lexer.clj new file mode 100644 index 000000000..f519aa563 --- /dev/null +++ b/luxc/src/lux/lexer.clj @@ -0,0 +1,254 @@ +;; Copyright (c) Eduardo Julian. All rights reserved. +;; This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +;; If a copy of the MPL was not distributed with this file, +;; You can obtain one at http://mozilla.org/MPL/2.0/. + +(ns lux.lexer + (:require (clojure [template :refer [do-template]] + [string :as string]) + (lux [base :as & :refer [defvariant |do return* return fail fail* |case]] + [reader :as &reader]) + [lux.analyser.module :as &module])) + +;; [Tags] +(defvariant + ("White_Space" 1) + ("Comment" 1) + ("Bool" 1) + ("Nat" 1) + ("Int" 1) + ("Frac" 1) + ("Real" 1) + ("Char" 1) + ("Text" 1) + ("Symbol" 1) + ("Tag" 1) + ("Open_Paren" 0) + ("Close_Paren" 0) + ("Open_Bracket" 0) + ("Close_Bracket" 0) + ("Open_Brace" 0) + ("Close_Brace" 0) + ) + +;; [Utils] +(defn ^:private escape-char [escaped] + "(-> Text (Lux Text))" + (cond (.equals ^Object escaped "\\t") (return "\t") + (.equals ^Object escaped "\\b") (return "\b") + (.equals ^Object escaped "\\n") (return "\n") + (.equals ^Object escaped "\\r") (return "\r") + (.equals ^Object escaped "\\f") (return "\f") + (.equals ^Object escaped "\\\"") (return "\"") + (.equals ^Object escaped "\\\\") (return "\\") + :else + (&/fail-with-loc (str "[Lexer Error] Unknown escape character: " escaped)))) + +(defn ^:private escape-char* [escaped] + "(-> Text Text)" + (cond (.equals ^Object escaped "\\t") "\t" + (.equals ^Object escaped "\\b") "\b" + (.equals ^Object escaped "\\n") "\n" + (.equals ^Object escaped "\\r") "\r" + (.equals ^Object escaped "\\f") "\f" + (.equals ^Object escaped "\\\"") "\"" + (.equals ^Object escaped "\\\\") "\\" + :else + (assert false (str "[Lexer Error] Unknown escape character: " escaped)))) + +(defn ^:private clean-line [^String raw-line] + "(-> Text Text)" + (let [line-length (.length raw-line) + buffer (new StringBuffer line-length)] + (loop [idx 0] + (if (< idx line-length) + (let [current-char (.charAt raw-line idx)] + (if (= \\ current-char) + (do (assert (< (+ 1 idx) line-length) (str "[Lexer Error] Text is too short for escaping: " raw-line " " idx)) + (case (.charAt raw-line (+ 1 idx)) + \t (do (.append buffer "\t") + (recur (+ 2 idx))) + \b (do (.append buffer "\b") + (recur (+ 2 idx))) + \n (do (.append buffer "\n") + (recur (+ 2 idx))) + \r (do (.append buffer "\r") + (recur (+ 2 idx))) + \f (do (.append buffer "\f") + (recur (+ 2 idx))) + \" (do (.append buffer "\"") + (recur (+ 2 idx))) + \\ (do (.append buffer "\\") + (recur (+ 2 idx))) + \u (do (assert (< (+ 5 idx) line-length) (str "[Lexer Error] Text is too short for unicode-escaping: " raw-line " " idx)) + (.append buffer (char (Integer/valueOf (.substring raw-line (+ 2 idx) (+ 6 idx)) 16))) + (recur (+ 6 idx))) + ;; else + (assert false (str "[Lexer Error] Invalid escaping syntax: " raw-line " " idx)))) + (do (.append buffer current-char) + (recur (+ 1 idx))))) + (.toString buffer))))) + +(defn ^:private lex-text-body [multi-line? offset] + (|do [[_ eol? ^String pre-quotes**] (&reader/read-regex #"^([^\"]*)") + ^String pre-quotes* (if multi-line? + (|do [:let [empty-line? (and eol? (= "" pre-quotes**))] + _ (&/assert! (or empty-line? + (>= (.length pre-quotes**) offset)) + "Each line of a multi-line text must have an appropriate offset!")] + (return (if empty-line? + "\n" + (str "\n" (.substring pre-quotes** offset))))) + (return pre-quotes**)) + [pre-quotes post-quotes] (if (.endsWith pre-quotes* "\\") + (if eol? + (&/fail-with-loc "[Lexer Error] Can't leave dangling back-slash \\") + (if (if-let [^String back-slashes (re-find #"\\+$" pre-quotes*)] + (odd? (.length back-slashes))) + (|do [[_ eol?* _] (&reader/read-regex #"^([\"])") + next-part (lex-text-body eol?* offset)] + (return (&/T [(.substring pre-quotes* 0 (dec (.length pre-quotes*))) + (str "\"" next-part)]))) + (|do [post-quotes* (lex-text-body false offset)] + (return (&/T [pre-quotes* post-quotes*]))))) + (if eol? + (|do [next-part (lex-text-body true offset)] + (return (&/T [pre-quotes* + next-part]))) + (return (&/T [pre-quotes* ""]))))] + (return (str (clean-line pre-quotes) post-quotes)))) + +(def lex-text + (|do [[meta _ _] (&reader/read-text "\"") + :let [[_ _ _column] meta] + token (lex-text-body false (inc _column)) + _ (&reader/read-text "\"")] + (return (&/T [meta ($Text token)])))) + +(def +ident-re+ + #"^([^0-9\[\]\{\}\(\)\s\"#;][^\[\]\{\}\(\)\s\"#;]*)") + +;; [Lexers] +(def ^:private lex-white-space + (|do [[meta _ white-space] (&reader/read-regex #"^(\s+|$)")] + (return (&/T [meta ($White_Space white-space)])))) + +(def ^:private lex-single-line-comment + (|do [_ (&reader/read-text "##") + [meta _ comment] (&reader/read-regex #"^(.*)$")] + (return (&/T [meta ($Comment comment)])))) + +(defn ^:private lex-multi-line-comment [_] + (|do [_ (&reader/read-text "#(") + [meta comment] (&/try-all% (&/|list (|do [[meta comment] (&reader/read-regex+ #"(?is)^(?!#\()((?!\)#).)*")] + (return (&/T [meta comment]))) + (|do [[meta pre] (&reader/read-regex+ #"(?is)^((?!#\().)*") + [_ ($Comment inner)] (lex-multi-line-comment nil) + [_ post] (&reader/read-regex+ #"(?is)^((?!\)#).)*")] + (return (&/T [meta (str pre "#(" inner ")#" post)]))))) + _ (&reader/read-text ")#")] + (return (&/T [meta ($Comment comment)])))) + +(def ^:private lex-comment + (&/try-all% (&/|list lex-single-line-comment + (lex-multi-line-comment nil)))) + +(do-template [<name> <tag> <regex>] + (def <name> + (|do [[meta _ token] (&reader/read-regex <regex>)] + (return (&/T [meta (<tag> token)])))) + + lex-bool $Bool #"^(true|false)" + ) + +(do-template [<name> <tag> <regex>] + (def <name> + (|do [[meta _ token] (&reader/read-regex <regex>)] + (return (&/T [meta (<tag> (string/replace token #",|_" ""))])))) + + lex-nat $Nat #"^\+(0|[1-9][0-9,_]*)" + lex-int $Int #"^-?(0|[1-9][0-9,_]*)" + lex-frac $Frac #"^(\.[0-9,_]+)" + lex-real $Real #"^-?(0\.[0-9,_]+|[1-9][0-9,_]*\.[0-9,_]+)(e-?[1-9][0-9,_]*)?" + ) + +(def lex-char + (|do [[meta _ _] (&reader/read-text "#\"") + token (&/try-all% (&/|list (|do [[_ _ escaped] (&reader/read-regex #"^(\\.)")] + (escape-char escaped)) + (|do [[_ _ ^String unicode] (&reader/read-regex #"^(\\u[0-9a-fA-F]{4})")] + (return (str (char (Integer/valueOf (.substring unicode 2) 16))))) + (|do [[_ _ char] (&reader/read-regex #"^(.)")] + (return char)))) + _ (&reader/read-text "\"")] + (return (&/T [meta ($Char token)])))) + +(def ^:private lex-ident + (&/try-all-% "[Reader Error]" + (&/|list (|do [[meta _ token] (&reader/read-regex +ident-re+) + [_ _ got-it?] (&reader/read-text? ";")] + (|case got-it? + (&/$Some _) + (|do [[_ _ local-token] (&reader/read-regex +ident-re+) + ? (&module/exists? token)] + (if ? + (return (&/T [meta (&/T [token local-token])])) + (|do [unaliased (&module/dealias token)] + (return (&/T [meta (&/T [unaliased local-token])]))))) + + (&/$None) + (return (&/T [meta (&/T ["" token])])))) + (|do [[meta _ _] (&reader/read-text ";;") + [_ _ token] (&reader/read-regex +ident-re+) + module-name &/get-module-name] + (return (&/T [meta (&/T [module-name token])]))) + (|do [[meta _ _] (&reader/read-text ";") + [_ _ token] (&reader/read-regex +ident-re+)] + (return (&/T [meta (&/T ["lux" token])]))) + ))) + +(def ^:private lex-symbol + (|do [[meta ident] lex-ident] + (return (&/T [meta ($Symbol ident)])))) + +(def ^:private lex-tag + (|do [[meta _ _] (&reader/read-text "#") + [_ ident] lex-ident] + (return (&/T [meta ($Tag ident)])))) + +(do-template [<name> <text> <tag>] + (def <name> + (|do [[meta _ _] (&reader/read-text <text>)] + (return (&/T [meta <tag>])))) + + ^:private lex-open-paren "(" $Open_Paren + ^:private lex-close-paren ")" $Close_Paren + ^:private lex-open-bracket "[" $Open_Bracket + ^:private lex-close-bracket "]" $Close_Bracket + ^:private lex-open-brace "{" $Open_Brace + ^:private lex-close-brace "}" $Close_Brace + ) + +(def ^:private lex-delimiter + (&/try-all% (&/|list lex-open-paren + lex-close-paren + lex-open-bracket + lex-close-bracket + lex-open-brace + lex-close-brace))) + +;; [Exports] +(def lex + (&/try-all-% "[Reader Error]" + (&/|list lex-white-space + lex-comment + lex-bool + lex-nat + lex-real + lex-frac + lex-int + lex-char + lex-text + lex-symbol + lex-tag + lex-delimiter))) diff --git a/luxc/src/lux/lib/loader.clj b/luxc/src/lux/lib/loader.clj new file mode 100644 index 000000000..e8310f9f0 --- /dev/null +++ b/luxc/src/lux/lib/loader.clj @@ -0,0 +1,54 @@ +;; Copyright (c) Eduardo Julian. All rights reserved. +;; This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +;; If a copy of the MPL was not distributed with this file, +;; You can obtain one at http://mozilla.org/MPL/2.0/. + +(ns lux.lib.loader + (:refer-clojure :exclude [load]) + (:require (lux [base :as & :refer [|let |do return fail return* fail* |case]])) + (:import (java.io InputStream + File + FileInputStream + ByteArrayInputStream + ByteArrayOutputStream) + java.util.jar.JarInputStream)) + +;; [Utils] +(defn ^:private fetch-libs [] + (->> ^java.net.URLClassLoader (ClassLoader/getSystemClassLoader) + (.getURLs) + seq + (map #(.getFile ^java.net.URL %)) + (filter #(.endsWith ^String % ".jar")) + (map #(new File ^String %)))) + +(let [init-capacity (* 100 1024) + buffer-size 1024] + (defn ^:private ^"[B" read-stream [^InputStream is] + (let [buffer (byte-array buffer-size)] + (with-open [os (new ByteArrayOutputStream init-capacity)] + (loop [bytes-read (.read is buffer 0 buffer-size)] + (when (not= -1 bytes-read) + (do (.write os buffer 0 bytes-read) + (recur (.read is buffer 0 buffer-size))))) + (.toByteArray os))))) + +(defn ^:private unpackage [^File lib-file] + (let [is (->> lib-file + (new FileInputStream) + (new JarInputStream))] + (loop [lib-data {} + entry (.getNextJarEntry is)] + (if entry + (if (.endsWith (.getName entry) ".lux") + (recur (assoc lib-data (.getName entry) (new String (read-stream is))) + (.getNextJarEntry is)) + (recur lib-data + (.getNextJarEntry is))) + lib-data)))) + +;; [Exports] +(defn load [] + (->> (fetch-libs) + (map unpackage) + (reduce merge {}))) diff --git a/luxc/src/lux/optimizer.clj b/luxc/src/lux/optimizer.clj new file mode 100644 index 000000000..5c30dc44f --- /dev/null +++ b/luxc/src/lux/optimizer.clj @@ -0,0 +1,1202 @@ +;; Copyright (c) Eduardo Julian. All rights reserved. +;; This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +;; If a copy of the MPL was not distributed with this file, +;; You can obtain one at http://mozilla.org/MPL/2.0/. +(ns lux.optimizer + (:require (lux [base :as & :refer [|let |do return fail return* fail* |case defvariant]]) + (lux.analyser [base :as &a] + [case :as &a-case]))) + +;; [Tags] +(defvariant + ;; These tags just have a one-to-one correspondence with Analysis data-structures. + ("bool" 1) + ("nat" 1) + ("int" 1) + ("frac" 1) + ("real" 1) + ("char" 1) + ("text" 1) + ("variant" 3) + ("tuple" 1) + ("apply" 2) + ("case" 2) + ("function" 5) + ("ann" 2) + ("var" 1) + ("captured" 3) + ("proc" 3) + + ;; These other tags represent higher-order constructs that manifest + ;; themselves as patterns in the code. + ;; Lux doesn't formally provide these features, but some macros + ;; expose ways to implement them in terms of the other (primitive) + ;; features. + ;; The optimizer looks for those usage patterns and transforms them + ;; into explicit constructs, which are then subject to specialized optimizations. + + ;; Loop scope, for doing loop inlining + ("loop" 3) ;; {register-offset Int, inits (List Optimized), body Optimized} + ;; This is loop iteration, as expected in imperative programming. + ("iter" 2) ;; {register-offset Int, vals (List Optimized)} + ;; This is a simple let-expression, as opposed to the more general pattern-matching. + ("let" 3) + ;; This is an access to a record's member. It can be multi-level: + ;; e.g. record.l1.l2.l3 + ;; The record-get token stores the path, for simpler compilation. + ("record-get" 2) + ;; Regular, run-of-the-mill if expressions. + ("if" 3) + ) + +;; [Utils] + +;; [[Pattern-Matching Traversal Optimization]] + +;; This represents an alternative way to view pattern-matching. +;; The PM that Lux provides has declarative semantics, with the user +;; specifying how his data is shaped, but not how to traverse it. +;; The optimizer's PM is operational in nature, and relies on +;; specifying a path of traversal, with a variety of operations that +;; can be done along the way. +;; The algorithm relies on looking at pattern-matching as traversing a +;; (possibly) branching path, where each step along the path +;; corresponds to a value, the ends of the path are the jumping-off +;; points for the bodies of branches, and branching decisions can be +;; backtracked, if they don't result in a valid jump. +(defvariant + ;; Throw away the current data-node (CDN). It's useless. + ("PopPM" 0) + ;; Store the CDN in a register. + ("BindPM" 1) + ;; Compare the CDN with a boolean value. + ("BoolPM" 1) + ;; Compare the CDN with a natural value. + ("NatPM" 1) + ;; Compare the CDN with an integer value. + ("IntPM" 1) + ;; Compare the CDN with a fractional value. + ("FracPM" 1) + ;; Compare the CDN with a real value. + ("RealPM" 1) + ;; Compare the CDN with a character value. + ("CharPM" 1) + ;; Compare the CDN with a text value. + ("TextPM" 1) + ;; Compare the CDN with a variant value. If valid, proceed to test + ;; the variant's inner value. + ("VariantPM" 1) + ;; Access a tuple value at a given index, for further examination. + ("TuplePM" 1) + ;; Creates an instance of the backtracking info, as a preparatory + ;; step to exploring one of the branching paths. + ("AltPM" 2) + ;; Allows to test the CDN, while keeping a copy of it for more + ;; tasting later on. + ;; If necessary when doing multiple tests on a single value, like + ;; when testing multiple parts of a tuple. + ("SeqPM" 2) + ;; This is the jumping-off point for the PM part, where the PM + ;; data-structure is thrown away and the program jumps to the + ;; branch's body. + ("ExecPM" 1)) + +(defn de-meta + "(-> Optimized Optimized)" + [optim] + (|let [[meta optim-] optim] + (|case optim- + ($variant idx is-last? value) + ($variant idx is-last? (de-meta value)) + + ($tuple elems) + ($tuple (&/|map de-meta elems)) + + ($case value [_pm _bodies]) + ($case (de-meta value) + (&/T [_pm (&/|map de-meta _bodies)])) + + ($function _register-offset arity scope captured body*) + ($function _register-offset + arity + scope + (&/|map (fn [capture] + (|let [[_name [_meta ($captured _scope _idx _source)]] capture] + (&/T [_name ($captured _scope _idx (de-meta _source))]))) + captured) + (de-meta body*)) + + ($ann value-expr type-expr) + (de-meta value-expr) + + ($apply func args) + ($apply (de-meta func) + (&/|map de-meta args)) + + ($captured scope idx source) + ($captured scope idx (de-meta source)) + + ($proc proc-ident args special-args) + ($proc proc-ident (&/|map de-meta args) special-args) + + ($loop _register-offset _inits _body) + ($loop _register-offset + (&/|map de-meta _inits) + (de-meta _body)) + + ($iter _iter-register-offset args) + ($iter _iter-register-offset + (&/|map de-meta args)) + + ($let _value _register _body) + ($let (de-meta _value) + _register + (de-meta _body)) + + ($record-get _value _path) + ($record-get (de-meta _value) + _path) + + ($if _test _then _else) + ($if (de-meta _test) + (de-meta _then) + (de-meta _else)) + + _ + optim- + ))) + +;; This function does a simple transformation from the declarative +;; model of PM of the analyser, to the operational model of PM of the +;; optimizer. +;; You may notice that all branches end in PopPM. +;; The reason is that testing does not immediately imply throwing away +;; the data to be tested, which is why a popping step must immediately follow. +(defn ^:private transform-pm* [test] + (|case test + (&a-case/$NoTestAC) + (&/|list $PopPM) + + (&a-case/$StoreTestAC _register) + (&/|list ($BindPM _register)) + + (&a-case/$BoolTestAC _value) + (&/|list ($BoolPM _value) + $PopPM) + + (&a-case/$NatTestAC _value) + (&/|list ($NatPM _value) + $PopPM) + + (&a-case/$IntTestAC _value) + (&/|list ($IntPM _value) + $PopPM) + + (&a-case/$FracTestAC _value) + (&/|list ($FracPM _value) + $PopPM) + + (&a-case/$RealTestAC _value) + (&/|list ($RealPM _value) + $PopPM) + + (&a-case/$CharTestAC _value) + (&/|list ($CharPM _value) + $PopPM) + + (&a-case/$TextTestAC _value) + (&/|list ($TextPM _value) + $PopPM) + + (&a-case/$VariantTestAC _idx _num-options _sub-test) + (&/|++ (&/|list ($VariantPM (if (= _idx (dec _num-options)) + (&/$Right _idx) + (&/$Left _idx)))) + (&/|++ (transform-pm* _sub-test) + (&/|list $PopPM))) + + (&a-case/$TupleTestAC _sub-tests) + (|case _sub-tests + ;; An empty tuple corresponds to unit, which can't be tested in + ;; any meaningful way, so it's just popped. + (&/$Nil) + (&/|list $PopPM) + + ;; A tuple of a single element is equivalent to the element + ;; itself, to the element's PM is generated. + (&/$Cons _only-test (&/$Nil)) + (transform-pm* _only-test) + + ;; Single tuple PM features the tests of each tuple member + ;; inlined, it's operational equivalent is interleaving the + ;; access to each tuple member, followed by the testing of said + ;; member. + ;; That is way each sequence of access+subtesting gets generated + ;; and later they all get concatenated. + _ + (|let [tuple-size (&/|length _sub-tests)] + (&/|++ (&/flat-map (fn [idx+test*] + (|let [[idx test*] idx+test*] + (&/$Cons ($TuplePM (if (< idx (dec tuple-size)) + (&/$Left idx) + (&/$Right idx))) + (transform-pm* test*)))) + (&/zip2 (&/|range tuple-size) + _sub-tests)) + (&/|list $PopPM)))))) + +;; It will be common for pattern-matching on a very nested +;; data-structure to require popping all the intermediate +;; data-structures that were visited once it's all done. +;; However, the PM infrastructure employs a single data-stack to keep +;; all data nodes in the trajectory, and that data-stack can just be +;; thrown again entirely, in just one step. +;; Because of that, any ending POPs prior to throwing away the +;; data-stack would be completely useless. +;; This function cleans them all up, to avoid wasteful computation later. +(defn ^:private clean-unnecessary-pops [steps] + (|case steps + (&/$Cons ($PopPM) _steps) + (clean-unnecessary-pops _steps) + + _ + steps)) + +;; This transforms a single branch of a PM tree into it's operational +;; equivalent, while also associating the PM of the branch with the +;; jump to the branch's body. +(defn ^:private transform-pm [test body-id] + (&/fold (fn [right left] ($SeqPM left right)) + ($ExecPM body-id) + (clean-unnecessary-pops (&/|reverse (transform-pm* test))))) + +(defn ^:private pattern->text [pattern] + (|case pattern + ($PopPM) + "$PopPM" + + ($BindPM _id) + (str "($BindPM " _id ")") + + ($BoolPM _value) + (str "($BoolPM " (pr-str _value) ")") + + ($NatPM _value) + (str "($NatPM " (pr-str _value) ")") + + ($IntPM _value) + (str "($IntPM " (pr-str _value) ")") + + ($FracPM _value) + (str "($FracPM " (pr-str _value) ")") + + ($RealPM _value) + (str "($RealPM " (pr-str _value) ")") + + ($CharPM _value) + (str "($CharPM " (pr-str _value) ")") + + ($TextPM _value) + (str "($TextPM " (pr-str _value) ")") + + ($TuplePM (&/$Left _idx)) + (str "($TuplePM L" _idx ")") + + ($TuplePM (&/$Right _idx)) + (str "($TuplePM R" _idx ")") + + ($VariantPM (&/$Left _idx)) + (str "($VariantPM L" _idx ")") + + ($VariantPM (&/$Right _idx)) + (str "($VariantPM R" _idx ")") + + ($SeqPM _left _right) + (str "($SeqPM " (pattern->text _left) " " (pattern->text _right) ")") + + ($ExecPM _idx) + (str "($ExecPM " _idx ")") + + ;; $AltPM is not considered because it's not supposed to be + ;; present anywhere at this point in time. + )) + +;; This function fuses together the paths of the PM traversal, adding +;; branching AltPMs where necessary, and fusing similar paths together +;; as much as possible, when early parts of them coincide. +;; The goal is to minimize rework as much as possible by sharing as +;; much of each path as possible. +(defn ^:private fuse-pms [pre post] + (|case (&/T [pre post]) + [($PopPM) ($PopPM)] + $PopPM + + [($BindPM _pre-var-id) ($BindPM _post-var-id)] + (if (= _pre-var-id _post-var-id) + ($BindPM _pre-var-id) + ($AltPM pre post)) + + [($BoolPM _pre-value) ($BoolPM _post-value)] + (if (= _pre-value _post-value) + ($BoolPM _pre-value) + ($AltPM pre post)) + + [($NatPM _pre-value) ($NatPM _post-value)] + (if (= _pre-value _post-value) + ($NatPM _pre-value) + ($AltPM pre post)) + + [($IntPM _pre-value) ($IntPM _post-value)] + (if (= _pre-value _post-value) + ($IntPM _pre-value) + ($AltPM pre post)) + + [($FracPM _pre-value) ($FracPM _post-value)] + (if (= _pre-value _post-value) + ($FracPM _pre-value) + ($AltPM pre post)) + + [($RealPM _pre-value) ($RealPM _post-value)] + (if (= _pre-value _post-value) + ($RealPM _pre-value) + ($AltPM pre post)) + + [($CharPM _pre-value) ($CharPM _post-value)] + (if (= _pre-value _post-value) + ($CharPM _pre-value) + ($AltPM pre post)) + + [($TextPM _pre-value) ($TextPM _post-value)] + (if (= _pre-value _post-value) + ($TextPM _pre-value) + ($AltPM pre post)) + + [($TuplePM (&/$Left _pre-idx)) ($TuplePM (&/$Left _post-idx))] + (if (= _pre-idx _post-idx) + ($TuplePM (&/$Left _pre-idx)) + ($AltPM pre post)) + + [($TuplePM (&/$Right _pre-idx)) ($TuplePM (&/$Right _post-idx))] + (if (= _pre-idx _post-idx) + ($TuplePM (&/$Right _pre-idx)) + ($AltPM pre post)) + + [($VariantPM (&/$Left _pre-idx)) ($VariantPM (&/$Left _post-idx))] + (if (= _pre-idx _post-idx) + ($VariantPM (&/$Left _pre-idx)) + ($AltPM pre post)) + + [($VariantPM (&/$Right _pre-idx)) ($VariantPM (&/$Right _post-idx))] + (if (= _pre-idx _post-idx) + ($VariantPM (&/$Right _pre-idx)) + ($AltPM pre post)) + + [($SeqPM _pre-pre _pre-post) ($SeqPM _post-pre _post-post)] + (|case (fuse-pms _pre-pre _post-pre) + ($AltPM _ _) + ($AltPM pre post) + + fused-pre + ($SeqPM fused-pre (fuse-pms _pre-post _post-post))) + + _ + ($AltPM pre post) + )) + +(defn ^:private pattern-vars [pattern] + (|case pattern + ($BindPM _id) + (&/|list (&/T [_id false])) + + ($SeqPM _left _right) + (&/|++ (pattern-vars _left) (pattern-vars _right)) + + _ + (&/|list) + + ;; $AltPM is not considered because it's not supposed to be + ;; present anywhere at this point in time. + )) + +(defn ^:private find-unused-vars [var-table body] + (|let [[meta body-] body] + (|case body- + ($var (&/$Local _idx)) + (&/|update _idx (fn [_] true) var-table) + + ($captured _scope _c-idx [_ ($var (&/$Local _idx))]) + (&/|update _idx (fn [_] true) var-table) + + ($variant _idx _is-last? _value) + (find-unused-vars var-table _value) + + ($tuple _elems) + (&/fold find-unused-vars var-table _elems) + + ($ann _value-expr _type-expr) + (find-unused-vars var-table _value-expr) + + ($apply _func _args) + (&/fold find-unused-vars + (find-unused-vars var-table _func) + _args) + + ($proc _proc-ident _args _special-args) + (&/fold find-unused-vars var-table _args) + + ($loop _register-offset _inits _body) + (&/|++ (&/fold find-unused-vars var-table _inits) + (find-unused-vars var-table _body)) + + ($iter _ _args) + (&/fold find-unused-vars var-table _args) + + ($let _value _register _body) + (-> var-table + (find-unused-vars _value) + (find-unused-vars _body)) + + ($record-get _value _path) + (find-unused-vars var-table _value) + + ($if _test _then _else) + (-> var-table + (find-unused-vars _test) + (find-unused-vars _then) + (find-unused-vars _else)) + + ($case _value [_pm _bodies]) + (&/fold find-unused-vars + (find-unused-vars var-table _value) + _bodies) + + ($function _ _ _ _captured _) + (->> _captured + (&/|map &/|second) + (&/fold find-unused-vars var-table)) + + _ + var-table + ))) + +(defn ^:private clean-unused-pattern-registers [var-table pattern] + (|case pattern + ($BindPM _idx) + (|let [_new-idx (&/|get _idx var-table)] + (cond (= _idx _new-idx) + pattern + + (>= _new-idx 0) + ($BindPM _new-idx) + + :else + $PopPM)) + + ($SeqPM _left _right) + ($SeqPM (clean-unused-pattern-registers var-table _left) + (clean-unused-pattern-registers var-table _right)) + + _ + pattern + + ;; $AltPM is not considered because it's not supposed to be + ;; present anywhere at this point in time. + )) + +;; This function assumes that the var-table has an ascending index +;; order. +;; For example: (2 3 4 5 6 7 8), instead of (8 7 6 5 4 3 2) +(defn ^:private adjust-register-indexes* [offset var-table] + (|case var-table + (&/$Nil) + (&/|list) + + (&/$Cons [_idx _used?] _tail) + (if _used? + (&/$Cons (&/T [_idx (- _idx offset)]) + (adjust-register-indexes* offset _tail)) + (&/$Cons (&/T [_idx -1]) + (adjust-register-indexes* (inc offset) _tail)) + ))) + +(defn ^:private adjust-register-indexes [var-table] + (adjust-register-indexes* 0 var-table)) + +(defn ^:private clean-unused-body-registers [var-table body] + (|let [[meta body-] body] + (|case body- + ($var (&/$Local _idx)) + (|let [new-idx (or (&/|get _idx var-table) + _idx)] + (&/T [meta ($var (&/$Local new-idx))])) + + ($captured _scope _c-idx [_sub-meta ($var (&/$Local _idx))]) + (|let [new-idx (or (&/|get _idx var-table) + _idx)] + (&/T [meta ($captured _scope _c-idx (&/T [_sub-meta ($var (&/$Local new-idx))]))])) + + ($variant _idx _is-last? _value) + (&/T [meta ($variant _idx _is-last? (clean-unused-body-registers var-table _value))]) + + ($tuple _elems) + (&/T [meta ($tuple (&/|map (partial clean-unused-body-registers var-table) + _elems))]) + + ($ann _value-expr _type-expr) + (&/T [meta ($ann (clean-unused-body-registers var-table _value-expr) _type-expr)]) + + ($apply _func _args) + (&/T [meta ($apply (clean-unused-body-registers var-table _func) + (&/|map (partial clean-unused-body-registers var-table) + _args))]) + + ($proc _proc-ident _args _special-args) + (&/T [meta ($proc _proc-ident + (&/|map (partial clean-unused-body-registers var-table) + _args) + _special-args)]) + + ($loop _register-offset _inits _body) + (&/T [meta ($loop _register-offset + (&/|map (partial clean-unused-body-registers var-table) + _inits) + (clean-unused-body-registers var-table _body))]) + + ($iter _iter-register-offset _args) + (&/T [meta ($iter _iter-register-offset + (&/|map (partial clean-unused-body-registers var-table) + _args))]) + + ($let _value _register _body) + (&/T [meta ($let (clean-unused-body-registers var-table _value) + _register + (clean-unused-body-registers var-table _body))]) + + ($record-get _value _path) + (&/T [meta ($record-get (clean-unused-body-registers var-table _value) + _path)]) + + ($if _test _then _else) + (&/T [meta ($if (clean-unused-body-registers var-table _test) + (clean-unused-body-registers var-table _then) + (clean-unused-body-registers var-table _else))]) + + ($case _value [_pm _bodies]) + (&/T [meta ($case (clean-unused-body-registers var-table _value) + (&/T [_pm + (&/|map (partial clean-unused-body-registers var-table) + _bodies)]))]) + + ($function _register-offset _arity _scope _captured _body) + (&/T [meta ($function _register-offset + _arity + _scope + (&/|map (fn [capture] + (|let [[_name __var] capture] + (&/T [_name (clean-unused-body-registers var-table __var)]))) + _captured) + _body)]) + + _ + body + ))) + +(defn ^:private simplify-pattern [pattern] + (|case pattern + ($SeqPM ($TuplePM _idx) ($SeqPM ($PopPM) pattern*)) + (simplify-pattern pattern*) + + ($SeqPM ($TuplePM _idx) _right) + (|case (simplify-pattern _right) + ($SeqPM ($PopPM) pattern*) + pattern* + + _right* + ($SeqPM ($TuplePM _idx) _right*)) + + ($SeqPM _left _right) + ($SeqPM _left (simplify-pattern _right)) + + _ + pattern)) + +(defn ^:private optimize-register-use [pattern body] + (|let [p-vars (pattern-vars pattern) + p-vars* (find-unused-vars p-vars body) + adjusted-vars (adjust-register-indexes p-vars*) + clean-pattern (clean-unused-pattern-registers adjusted-vars pattern) + simple-pattern (simplify-pattern clean-pattern) + clean-body (clean-unused-body-registers adjusted-vars body)] + (&/T [simple-pattern clean-body]))) + +;; This is the top-level function for optimizing PM, which transforms +;; each branch and then fuses them together. +(defn ^:private optimize-pm [branches] + (|let [;; branches (&/|reverse branches*) + pms+bodies (&/map2 (fn [branch _body-id] + (|let [[_pattern _body] branch] + (optimize-register-use (transform-pm _pattern _body-id) + _body))) + branches + (&/|range (&/|length branches))) + pms (&/|map &/|first pms+bodies) + bodies (&/|map &/|second pms+bodies)] + (|case (&/|reverse pms) + (&/$Nil) + (assert false) + + (&/$Cons _head-pm _tail-pms) + (&/T [(&/fold fuse-pms _head-pm _tail-pms) + bodies]) + ))) + +;; [[Function-Folding Optimization]] + +;; The semantics of Lux establish that all functions are of a single +;; argument and the multi-argument functions are actually nested +;; functions being generated and then applied. +;; This, of course, would generate a lot of waste. +;; To avoid it, Lux actually folds function definitions together, +;; thereby creating functions that can be used both +;; one-argument-at-a-time, and also being called with all, or just a +;; partial amount of their arguments. +;; This avoids generating too many artifacts during compilation, since +;; they get "compressed", and it can also lead to faster execution, by +;; enabling optimized function calls later. + +;; Functions and captured variables have "scopes", which tell which +;; function they are, or to which function they belong. +;; During the folding, inner functions dissapear, since their bodies +;; are merged into their outer "parent" functions. +;; Their scopes must change accordingy. +(defn ^:private de-scope + "(-> Scope Scope Scope Scope)" + [old-scope new-scope scope] + (if (identical? new-scope scope) + old-scope + scope)) + +;; Also, it must be noted that when folding functions, the indexes of +;; the registers have to be changed accodingly. +;; That is what the following "shifting" functions are for. + +;; Shifts the registers for PM operations. +(defn ^:private shift-pattern [pattern] + (|case pattern + ($BindPM _var-id) + ($BindPM (inc _var-id)) + + ($SeqPM _left-pm _right-pm) + ($SeqPM (shift-pattern _left-pm) (shift-pattern _right-pm)) + + ($AltPM _left-pm _right-pm) + ($AltPM (shift-pattern _left-pm) (shift-pattern _right-pm)) + + _ + pattern + )) + +;; Shifts the body of a function after a folding is performed. +(defn shift-function-body + "(-> Scope Scope Bool Optimized Optimized)" + [old-scope new-scope own-body? body] + (|let [[meta body-] body] + (|case body- + ($variant idx is-last? value) + (&/T [meta ($variant idx is-last? (shift-function-body old-scope new-scope own-body? value))]) + + ($tuple elems) + (&/T [meta ($tuple (&/|map (partial shift-function-body old-scope new-scope own-body?) elems))]) + + ($case value [_pm _bodies]) + (&/T [meta ($case (shift-function-body old-scope new-scope own-body? value) + (&/T [(if own-body? + (shift-pattern _pm) + _pm) + (&/|map (partial shift-function-body old-scope new-scope own-body?) _bodies)]))]) + + ($function _register-offset arity scope captured body*) + (|let [scope* (de-scope old-scope new-scope scope)] + (&/T [meta ($function _register-offset + arity + scope* + (&/|map (fn [capture] + (|let [[_name [_meta ($captured _scope _idx _source)]] capture] + (&/T [_name (&/T [_meta ($captured scope* _idx (shift-function-body old-scope new-scope own-body? _source))])]))) + captured) + (shift-function-body old-scope new-scope false body*))])) + + ($ann value-expr type-expr) + (&/T [meta ($ann (shift-function-body old-scope new-scope own-body? value-expr) + type-expr)]) + + ($var var-kind) + (if own-body? + (|case var-kind + (&/$Local 0) + (&/T [meta ($apply body + (&/|list [meta ($var (&/$Local 1))]))]) + + (&/$Local idx) + (&/T [meta ($var (&/$Local (inc idx)))]) + + (&/$Global ?module ?name) + body) + body) + + ;; This special "apply" rule is for handling recursive calls better. + ($apply [meta-0 ($var (&/$Local 0))] args) + (if own-body? + (&/T [meta ($apply (&/T [meta-0 ($var (&/$Local 0))]) + (&/$Cons (&/T [meta-0 ($var (&/$Local 1))]) + (&/|map (partial shift-function-body old-scope new-scope own-body?) args)))]) + (&/T [meta ($apply (&/T [meta-0 ($var (&/$Local 0))]) + (&/|map (partial shift-function-body old-scope new-scope own-body?) args))])) + + ($apply func args) + (&/T [meta ($apply (shift-function-body old-scope new-scope own-body? func) + (&/|map (partial shift-function-body old-scope new-scope own-body?) args))]) + + ($captured scope idx source) + (if own-body? + source + (|case scope + (&/$Cons _ (&/$Cons _ (&/$Nil))) + source + + _ + (&/T [meta ($captured (de-scope old-scope new-scope scope) idx (shift-function-body old-scope new-scope own-body? source))]))) + + ($proc proc-ident args special-args) + (&/T [meta ($proc proc-ident (&/|map (partial shift-function-body old-scope new-scope own-body?) args) special-args)]) + + ($loop _register-offset _inits _body) + (&/T [meta ($loop (if own-body? + (inc _register-offset) + _register-offset) + (&/|map (partial shift-function-body old-scope new-scope own-body?) + _inits) + (shift-function-body old-scope new-scope own-body? _body))]) + + ($iter _iter-register-offset args) + (&/T [meta ($iter (if own-body? + (inc _iter-register-offset) + _iter-register-offset) + (&/|map (partial shift-function-body old-scope new-scope own-body?) args))]) + + ($let _value _register _body) + (&/T [meta ($let (shift-function-body old-scope new-scope own-body? _value) + (if own-body? + (inc _register) + _register) + (shift-function-body old-scope new-scope own-body? _body))]) + + ($record-get _value _path) + (&/T [meta ($record-get (shift-function-body old-scope new-scope own-body? _value) + _path)]) + + ($if _test _then _else) + (&/T [meta ($if (shift-function-body old-scope new-scope own-body? _test) + (shift-function-body old-scope new-scope own-body? _then) + (shift-function-body old-scope new-scope own-body? _else))]) + + _ + body + ))) + +;; [[Record-Manipulation Optimizations]] + +;; If a pattern-matching tree with a single branch is found, and that +;; branch corresponds to a tuple PM, and the body corresponds to a +;; local variable, it's likely that the local refers to some member of +;; the tuple that is being extracted. +;; That is the pattern that is to be expected of record read-access, +;; so this function tries to extract the (possibly nested) path +;; necessary, ending in the data-node of the wanted member. +(defn ^:private record-read-path + "(-> (List PM) Idx (List Idx))" + [pms member-idx] + (loop [current-idx 0 + pms pms] + (|case pms + (&/$Nil) + &/$None + + (&/$Cons _pm _pms) + (|case _pm + (&a-case/$NoTestAC) + (recur (inc current-idx) + _pms) + + (&a-case/$StoreTestAC _register) + (if (= member-idx _register) + (&/|list (&/T [current-idx (&/|empty? _pms)])) + (recur (inc current-idx) + _pms)) + + (&a-case/$TupleTestAC _sub-tests) + (let [sub-path (record-read-path _sub-tests member-idx)] + (if (not (&/|empty? sub-path)) + (&/$Cons (&/T [current-idx (&/|empty? _pms)]) sub-path) + (recur (inc current-idx) + _pms) + )) + + _ + (&/|list)) + ))) + +;; [[Loop Optimizations]] + +;; Lux doesn't offer any looping constructs, relying instead on +;; recursion. +;; Some common usages of recursion can be written more efficiently +;; just using regular loops/iteration. +;; This optimization looks for tail-calls in the function body, +;; rewriting them as jumps to the beginning of the function, while +;; they also updated the necessary local variables for the next iteration. +(defn ^:private optimize-iter + "(-> Int Optimized Optimized)" + [arity optim] + (|let [[meta optim-] optim] + (|case optim- + ($apply [meta-0 ($var (&/$Local 0))] _args) + (if (= arity (&/|length _args)) + (&/T [meta ($iter 1 _args)]) + optim) + + ($case _value [_pattern _bodies]) + (&/T [meta ($case _value + (&/T [_pattern + (&/|map (partial optimize-iter arity) + _bodies)]))]) + + ($let _value _register _body) + (&/T [meta ($let _value _register (optimize-iter arity _body))]) + + ($if _test _then _else) + (&/T [meta ($if _test + (optimize-iter arity _then) + (optimize-iter arity _else))]) + + ($ann _value-expr _type-expr) + (&/T [meta ($ann (optimize-iter arity _value-expr) _type-expr)]) + + _ + optim + ))) + +(defn ^:private contains-self-reference? + "(-> Optimized Bool)" + [body] + (|let [[meta body-] body + stepwise-test (fn [base arg] (or base (contains-self-reference? arg)))] + (|case body- + ($variant idx is-last? value) + (contains-self-reference? value) + + ($tuple elems) + (&/fold stepwise-test false elems) + + ($case value [_pm _bodies]) + (or (contains-self-reference? value) + (&/fold stepwise-test false _bodies)) + + ($function _ _ _ captured _) + (->> captured + (&/|map (fn [capture] + (|let [[_name [_meta ($captured _scope _idx _source)]] capture] + _source))) + (&/fold stepwise-test false)) + + ($ann value-expr type-expr) + (contains-self-reference? value-expr) + + ($var (&/$Local 0)) + true + + ($apply func args) + (or (contains-self-reference? func) + (&/fold stepwise-test false args)) + + ($proc proc-ident args special-args) + (&/fold stepwise-test false args) + + ($loop _register-offset _inits _body) + (or (&/fold stepwise-test false _inits) + (contains-self-reference? _body)) + + ($iter _ args) + (&/fold stepwise-test false args) + + ($let _value _register _body) + (or (contains-self-reference? _value) + (contains-self-reference? _body)) + + ($record-get _value _path) + (contains-self-reference? _value) + + ($if _test _then _else) + (or (contains-self-reference? _test) + (contains-self-reference? _then) + (contains-self-reference? _else)) + + _ + false + ))) + +(defn ^:private pm-loop-transform [register-offset direct? pattern] + (|case pattern + ($BindPM _var-id) + ($BindPM (+ register-offset (if direct? + (- _var-id 2) + (- _var-id 1)))) + + ($SeqPM _left-pm _right-pm) + ($SeqPM (pm-loop-transform register-offset direct? _left-pm) + (pm-loop-transform register-offset direct? _right-pm)) + + ($AltPM _left-pm _right-pm) + ($AltPM (pm-loop-transform register-offset direct? _left-pm) + (pm-loop-transform register-offset direct? _right-pm)) + + _ + pattern + )) + +;; This function must be run STRICTLY before shift-function body, as +;; the transformation assumes that SFB will be invoke after it. +(defn ^:private loop-transform [register-offset direct? body] + (|let [adjust-direct (fn [register] + ;; The register must be decreased once, since + ;; it will be re-increased in + ;; shift-function-body. + ;; The decrease is meant to keep things stable. + (if direct? + ;; And, if this adjustment is done + ;; directly during a loop-transform (and + ;; not indirectly if transforming an inner + ;; loop), then it must be decreased again + ;; because the 0/self var will no longer + ;; exist in the loop's context. + (- register 2) + (- register 1))) + [meta body-] body] + (|case body- + ($variant idx is-last? value) + (&/T [meta ($variant idx is-last? (loop-transform register-offset direct? value))]) + + ($tuple elems) + (&/T [meta ($tuple (&/|map (partial loop-transform register-offset direct?) elems))]) + + ($case value [_pm _bodies]) + (&/T [meta ($case (loop-transform register-offset direct? value) + (&/T [(pm-loop-transform register-offset direct? _pm) + (&/|map (partial loop-transform register-offset direct?) + _bodies)]))]) + + ;; Functions are ignored because they'll be handled properly at shift-function-body + + ($ann value-expr type-expr) + (&/T [meta ($ann (loop-transform register-offset direct? value-expr) + type-expr)]) + + ($var (&/$Local idx)) + ;; The index must be decreased once, because the var index is + ;; 1-based (since 0 is reserved for self-reference). + ;; Then it must be decreased again, since it will be increased + ;; in the shift-function-body call. + ;; Then, I add the offset to ensure the var points to the right register. + (&/T [meta ($var (&/$Local (-> (adjust-direct idx) + (+ register-offset))))]) + + ($apply func args) + (&/T [meta ($apply (loop-transform register-offset direct? func) + (&/|map (partial loop-transform register-offset direct?) args))]) + + ;; Captured-vars are ignored because they'll be handled properly at shift-function-body + + ($proc proc-ident args special-args) + (&/T [meta ($proc proc-ident (&/|map (partial loop-transform register-offset direct?) args) special-args)]) + + ($loop _register-offset _inits _body) + (&/T [meta ($loop (+ register-offset (adjust-direct _register-offset)) + (&/|map (partial loop-transform register-offset direct?) _inits) + (loop-transform register-offset direct? _body))]) + + ($iter _iter-register-offset args) + (&/T [meta ($iter (+ register-offset (adjust-direct _iter-register-offset)) + (&/|map (partial loop-transform register-offset direct?) args))]) + + ($let _value _register _body) + (&/T [meta ($let (loop-transform register-offset direct? _value) + (+ register-offset (adjust-direct _register)) + (loop-transform register-offset direct? _body))]) + + ($record-get _value _path) + (&/T [meta ($record-get (loop-transform register-offset direct? _value) + _path)]) + + ($if _test _then _else) + (&/T [meta ($if (loop-transform register-offset direct? _test) + (loop-transform register-offset direct? _then) + (loop-transform register-offset direct? _else))]) + + _ + body + ))) + +(defn ^:private inline-loop [meta register-offset scope captured args body] + (->> body + (loop-transform register-offset true) + (shift-function-body scope (&/|tail scope) true) + ($loop register-offset args) + (list meta) + (&/T))) + +;; [[Initial Optimization]] + +;; Before any big optimization can be done, the incoming Analysis nodes +;; must be transformed into Optimized nodes, amenable to further transformations. +;; This function does the job, while also detecting (and optimizing) +;; some simple surface patterns it may encounter. +(let [optimize-closure (fn [optimize closure] + (&/|map (fn [capture] + (|let [[_name _analysis] capture] + (&/T [_name (optimize _analysis)]))) + closure))] + (defn ^:private pass-0 + "(-> Bool Analysis Optimized)" + [top-level-func? analysis] + (|let [[meta analysis-] analysis] + (|case analysis- + (&a/$bool value) + (&/T [meta ($bool value)]) + + (&a/$nat value) + (&/T [meta ($nat value)]) + + (&a/$int value) + (&/T [meta ($int value)]) + + (&a/$frac value) + (&/T [meta ($frac value)]) + + (&a/$real value) + (&/T [meta ($real value)]) + + (&a/$char value) + (&/T [meta ($char value)]) + + (&a/$text value) + (&/T [meta ($text value)]) + + (&a/$variant idx is-last? value) + (&/T [meta ($variant idx is-last? (pass-0 top-level-func? value))]) + + (&a/$tuple elems) + (&/T [meta ($tuple (&/|map (partial pass-0 top-level-func?) elems))]) + + (&a/$apply func args) + (|let [=func (pass-0 top-level-func? func) + =args (&/|map (partial pass-0 top-level-func?) args)] + (|case =func + [_ ($ann [_ ($function _register-offset _arity _scope _captured _body)] + _)] + (if (and (= _arity (&/|length =args)) + (not (contains-self-reference? _body))) + (inline-loop meta _register-offset _scope _captured =args _body) + (&/T [meta ($apply =func =args)])) + + _ + (&/T [meta ($apply =func =args)]))) + + (&a/$case value branches) + (let [normal-case-optim (fn [] + (&/T [meta ($case (pass-0 top-level-func? value) + (optimize-pm (&/|map (fn [branch] + (|let [[_pattern _body] branch] + (&/T [_pattern (pass-0 top-level-func? _body)]))) + branches)))]))] + (|case branches + ;; The pattern for a let-expression is a single branch, + ;; tying the value to a register. + (&/$Cons [(&a-case/$StoreTestAC _register) _body] (&/$Nil)) + (&/T [meta ($let (pass-0 top-level-func? value) _register (pass-0 top-level-func? _body))]) + + (&/$Cons [(&a-case/$BoolTestAC false) _else] + (&/$Cons [(&a-case/$BoolTestAC true) _then] + (&/$Nil))) + (&/T [meta ($if (pass-0 top-level-func? value) (pass-0 top-level-func? _then) (pass-0 top-level-func? _else))]) + + ;; The pattern for a record-get is a single branch, with a + ;; tuple pattern and a body corresponding to a + ;; local-variable extracted from the tuple. + (&/$Cons [(&a-case/$TupleTestAC _sub-tests) [_ (&a/$var (&/$Local _member-idx))]] (&/$Nil)) + (|let [_path (record-read-path _sub-tests _member-idx)] + (if (&/|empty? _path) + ;; If the path is empty, that means it was a + ;; false-positive and normal PM optimization should be + ;; done instead. + (normal-case-optim) + ;; Otherwise, we've got ourselves a record-get expression. + (&/T [meta ($record-get (pass-0 top-level-func? value) _path)]))) + + ;; If no special patterns are found, just do normal PM optimization. + _ + (normal-case-optim))) + + (&a/$lambda _register-offset scope captured body) + (|let [inner-func? (|case body + [_ (&a/$lambda _ _ _ _)] + true + + _ + false)] + (|case (pass-0 (not inner-func?) body) + ;; If the body of a function is another function, that means + ;; no work was done in-between and both layers can be folded + ;; into one. + [_ ($function _ _arity _scope _captured _body)] + (|let [new-arity (inc _arity) + collapsed-body (shift-function-body scope _scope true _body)] + (&/T [meta ($function _register-offset + new-arity + scope + (optimize-closure (partial pass-0 top-level-func?) captured) + (if top-level-func? + (optimize-iter new-arity collapsed-body) + collapsed-body))])) + + ;; Otherwise, they're nothing to be done and we've got a + ;; 1-arity function. + =body + (&/T [meta ($function _register-offset + 1 scope + (optimize-closure (partial pass-0 top-level-func?) captured) + (if top-level-func? + (optimize-iter 1 =body) + =body))]))) + + (&a/$ann value-expr type-expr) + (&/T [meta ($ann (pass-0 top-level-func? value-expr) type-expr)]) + + (&a/$var var-kind) + (&/T [meta ($var var-kind)]) + + (&a/$captured scope idx source) + (&/T [meta ($captured scope idx (pass-0 top-level-func? source))]) + + (&a/$proc proc-ident args special-args) + (&/T [meta ($proc proc-ident (&/|map (partial pass-0 top-level-func?) args) special-args)]) + + _ + (assert false (prn-str 'pass-0 top-level-func? (&/adt->text analysis))) + )))) + +;; [Exports] +(defn optimize + "(-> Analysis Optimized)" + [analysis] + (->> analysis + (pass-0 true))) diff --git a/luxc/src/lux/parser.clj b/luxc/src/lux/parser.clj new file mode 100644 index 000000000..ceafcd92e --- /dev/null +++ b/luxc/src/lux/parser.clj @@ -0,0 +1,117 @@ +;; Copyright (c) Eduardo Julian. All rights reserved. +;; This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +;; If a copy of the MPL was not distributed with this file, +;; You can obtain one at http://mozilla.org/MPL/2.0/. + +(ns lux.parser + (:require [clojure.template :refer [do-template]] + clojure.core.match + clojure.core.match.array + (lux [base :as & :refer [|do return |case]] + [lexer :as &lexer]))) + +;; [Utils] +(def ^:private base-uneven-record-error + "[Parser Error] Records must have an even number of elements.") + +(defn ^:private repeat% [action] + (fn [state] + (|case (action state) + (&/$Left ^String error) + (cond (.contains error base-uneven-record-error) + (&/$Left error) + + (not (.contains error "[Parser Error]")) + (&/$Left error) + + :else + (&/$Right (&/T [state &/$Nil]))) + + (&/$Right state* head) + ((|do [tail (repeat% action)] + (return (&/$Cons head tail))) + state*)))) + +(do-template [<name> <close-tag> <description> <tag>] + (defn <name> [parse] + (|do [elems (repeat% parse) + token &lexer/lex] + (|case token + [meta (<close-tag> _)] + (return (<tag> (&/fold &/|++ &/$Nil elems))) + + _ + (&/fail-with-loc (str "[Parser Error] Unbalanced " <description> ".")) + ))) + + ^:private parse-form &lexer/$Close_Paren "parantheses" &/$FormS + ^:private parse-tuple &lexer/$Close_Bracket "brackets" &/$TupleS + ) + +(defn ^:private parse-record [parse] + (|do [elems* (repeat% parse) + token &lexer/lex + :let [elems (&/fold &/|++ &/$Nil elems*)]] + (|case token + [meta (&lexer/$Close_Brace _)] + (if (even? (&/|length elems)) + (return (&/$RecordS (&/|as-pairs elems))) + (&/fail-with-loc base-uneven-record-error)) + + _ + (&/fail-with-loc "[Parser Error] Unbalanced braces.") + ))) + +;; [Interface] +(def parse + (|do [token &lexer/lex + :let [[meta token*] token]] + (|case token* + (&lexer/$White_Space _) + (return &/$Nil) + + (&lexer/$Comment _) + (return &/$Nil) + + (&lexer/$Bool ?value) + (return (&/|list (&/T [meta (&/$BoolS (Boolean/parseBoolean ?value))]))) + + (&lexer/$Nat ?value) + (return (&/|list (&/T [meta (&/$NatS (Long/parseUnsignedLong ?value))]))) + + (&lexer/$Int ?value) + (return (&/|list (&/T [meta (&/$IntS (Long/parseLong ?value))]))) + + (&lexer/$Frac ?value) + (return (&/|list (&/T [meta (&/$FracS (&/decode-frac ?value))]))) + + (&lexer/$Real ?value) + (return (&/|list (&/T [meta (&/$RealS (Double/parseDouble ?value))]))) + + (&lexer/$Char ^String ?value) + (return (&/|list (&/T [meta (&/$CharS (.charAt ?value 0))]))) + + (&lexer/$Text ?value) + (return (&/|list (&/T [meta (&/$TextS ?value)]))) + + (&lexer/$Symbol ?ident) + (return (&/|list (&/T [meta (&/$SymbolS ?ident)]))) + + (&lexer/$Tag ?ident) + (return (&/|list (&/T [meta (&/$TagS ?ident)]))) + + (&lexer/$Open_Paren _) + (|do [syntax (parse-form parse)] + (return (&/|list (&/T [meta syntax])))) + + (&lexer/$Open_Bracket _) + (|do [syntax (parse-tuple parse)] + (return (&/|list (&/T [meta syntax])))) + + (&lexer/$Open_Brace _) + (|do [syntax (parse-record parse)] + (return (&/|list (&/T [meta syntax])))) + + _ + (&/fail-with-loc "[Parser Error] Unknown lexer token.") + ))) diff --git a/luxc/src/lux/reader.clj b/luxc/src/lux/reader.clj new file mode 100644 index 000000000..5a7734061 --- /dev/null +++ b/luxc/src/lux/reader.clj @@ -0,0 +1,141 @@ +;; Copyright (c) Eduardo Julian. All rights reserved. +;; This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +;; If a copy of the MPL was not distributed with this file, +;; You can obtain one at http://mozilla.org/MPL/2.0/. + +(ns lux.reader + (:require [clojure.string :as string] + clojure.core.match + clojure.core.match.array + [lux.base :as & :refer [defvariant |do return* return fail* |let |case]])) + +;; [Tags] +(defvariant + ("No" 1) + ("Done" 1) + ("Yes" 2)) + +;; [Utils] +(defn ^:private with-line [body] + (fn [state] + (|case (&/get$ &/$source state) + (&/$Nil) + (fail* "[Reader Error] EOF") + + (&/$Cons [[file-name line-num column-num] line] + more) + (|case (body file-name line-num column-num line) + ($No msg) + ((&/fail-with-loc msg) state) + + ($Done output) + (return* (&/set$ &/$source more state) + output) + + ($Yes output line*) + (return* (&/set$ &/$source (&/$Cons line* more) state) + output)) + ))) + +(defn ^:private with-lines [body] + (fn [state] + (|case (body (&/get$ &/$source state)) + (&/$Right reader* match) + (return* (&/set$ &/$source reader* state) + match) + + (&/$Left msg) + ((&/fail-with-loc msg) state) + ))) + +(defn ^:private re-find! [^java.util.regex.Pattern regex column ^String line] + (let [matcher (doto (.matcher regex line) + (.region column (.length line)) + (.useAnchoringBounds true))] + (when (.find matcher) + (.group matcher 0)))) + +;; [Exports] +(defn read-regex [regex] + (with-line + (fn [file-name line-num column-num ^String line] + (if-let [^String match (re-find! regex column-num line)] + (let [match-length (.length match) + column-num* (+ column-num match-length)] + (if (= column-num* (.length line)) + ($Done (&/T [(&/T [file-name line-num column-num]) true match])) + ($Yes (&/T [(&/T [file-name line-num column-num]) false match]) + (&/T [(&/T [file-name line-num column-num*]) line])))) + ($No (str "[Reader Error] Pattern failed: " regex)))))) + +(defn read-regex+ [regex] + (with-lines + (fn [reader] + (loop [prefix "" + reader* reader] + (|case reader* + (&/$Nil) + (&/$Left "[Reader Error] EOF") + + (&/$Cons [[file-name line-num column-num] ^String line] + reader**) + (if-let [^String match (re-find! regex column-num line)] + (let [match-length (.length match) + column-num* (+ column-num match-length) + prefix* (if (= 0 column-num) + (str prefix "\n" match) + (str prefix match))] + (if (= column-num* (.length line)) + (recur prefix* reader**) + (&/$Right (&/T [(&/$Cons (&/T [(&/T [file-name line-num column-num*]) line]) + reader**) + (&/T [(&/T [file-name line-num column-num]) prefix*])])))) + (&/$Left (str "[Reader Error] Pattern failed: " regex)))))))) + +(defn read-text [^String text] + "(-> Text (Reader Text))" + (with-line + (fn [file-name line-num column-num ^String line] + (if (.startsWith line text column-num) + (let [match-length (.length text) + column-num* (+ column-num match-length)] + (if (= column-num* (.length line)) + ($Done (&/T [(&/T [file-name line-num column-num]) true text])) + ($Yes (&/T [(&/T [file-name line-num column-num]) false text]) + (&/T [(&/T [file-name line-num column-num*]) line])))) + ($No (str "[Reader Error] Text failed: " text)))))) + +(defn read-text? [^String text] + "(-> Text (Reader (Maybe Text)))" + (with-line + (fn [file-name line-num column-num ^String line] + (if (.startsWith line text column-num) + (let [match-length (.length text) + column-num* (+ column-num match-length)] + (if (= column-num* (.length line)) + ($Done (&/T [(&/T [file-name line-num column-num]) true (&/$Some text)])) + ($Yes (&/T [(&/T [file-name line-num column-num]) false (&/$Some text)]) + (&/T [(&/T [file-name line-num column-num*]) line])))) + ($Yes (&/T [(&/T [file-name line-num column-num]) false &/$None]) + (&/T [(&/T [file-name line-num column-num]) line])))))) + +(defn from [^String name ^String source-code] + (let [lines (string/split-lines source-code) + indexed-lines (map (fn [line line-num] + (&/T [(&/T [name (inc line-num) 0]) + line])) + lines + (range (count lines)))] + (reduce (fn [tail head] (&/$Cons head tail)) + &/$Nil + (reverse indexed-lines)))) + +(defn with-source [name content body] + (fn [state] + (|let [old-source (&/get$ &/$source state)] + (|case (body (&/set$ &/$source (from name content) state)) + (&/$Left error) + (&/$Left error) + + (&/$Right state* output) + (&/$Right (&/T [(&/set$ &/$source old-source state*) output])))))) diff --git a/luxc/src/lux/repl.clj b/luxc/src/lux/repl.clj new file mode 100644 index 000000000..195f3dc3e --- /dev/null +++ b/luxc/src/lux/repl.clj @@ -0,0 +1,89 @@ +;; Copyright (c) Eduardo Julian. All rights reserved. +;; This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +;; If a copy of the MPL was not distributed with this file, +;; You can obtain one at http://mozilla.org/MPL/2.0/. + +(ns lux.repl + (:require clojure.core.match + clojure.core.match.array + (lux [base :as & :refer [|let |do return* return fail fail* |case]] + [type :as &type] + [analyser :as &analyser] + [optimizer :as &optimizer] + [compiler :as &compiler]) + [lux.compiler.cache :as &cache] + [lux.analyser.base :as &a-base] + [lux.analyser.lux :as &a-lux] + [lux.analyser.module :as &module]) + (:import (java.io InputStreamReader + BufferedReader))) + +;; [Utils] +(def ^:private repl-module "REPL") + +(defn ^:private repl-cursor [repl-line] + (&/T [repl-module repl-line 0])) + +(defn ^:private init [source-dirs] + (do (&compiler/init!) + (|case ((|do [_ (&compiler/compile-module source-dirs "lux") + _ (&cache/delete repl-module) + _ (&module/create-module repl-module 0) + _ (fn [?state] + (return* (&/set$ &/$source + (&/|list (&/T [(repl-cursor -1) "(;import lux)"])) + ?state) + nil)) + analysed-tokens (&analyser/repl-analyse &optimizer/optimize &compiler/eval! (partial &compiler/compile-module source-dirs) &compiler/all-compilers) + eval-values (->> analysed-tokens (&/|map &optimizer/optimize) (&/map% &compiler/eval!))] + (return nil)) + (&/init-state &/$REPL)) + (&/$Right ?state _) + (do (println) + (println "Welcome to the REPL!") + (println "Type \"exit\" to leave.") + (println) + ?state) + + (&/$Left ?message) + (assert false ?message)) + )) + +;; [Values] +(defn repl [source-dirs] + (with-open [input (->> System/in (new InputStreamReader) (new BufferedReader))] + (loop [state (init source-dirs) + repl-line 0 + multi-line? false] + (let [_ (if (not multi-line?) + (.print System/out "> ") + (.print System/out " ")) + line (.readLine input)] + (if (= "exit" line) + (println "Till next time...") + (let [line* (&/|list (&/T [(repl-cursor repl-line) line])) + state* (&/update$ &/$source + (fn [_source] (&/|++ _source line*)) + state)] + (|case ((|do [analysed-tokens (&analyser/repl-analyse &optimizer/optimize &compiler/eval! (partial &compiler/compile-module source-dirs) &compiler/all-compilers) + eval-values (->> analysed-tokens (&/|map &optimizer/optimize) (&/map% &compiler/eval!)) + :let [outputs (map (fn [analysis value] + (|let [[[_type _cursor] _term] analysis] + [_type value])) + (&/->seq analysed-tokens) + (&/->seq eval-values))]] + (return outputs)) + state*) + (&/$Right state** outputs) + (do (doseq [[_type _value] outputs] + (.println System/out (str "=> " (pr-str _value) "\n:: " (&type/show-type _type)"\n"))) + (recur state** (inc repl-line) false)) + + (&/$Left ^String ?message) + (if (or (= "[Reader Error] EOF" ?message) + (.contains ?message "[Parser Error] Unbalanced ")) + (recur state* (inc repl-line) true) + (do (println ?message) + (recur state (inc repl-line) false))) + )))) + ))) diff --git a/luxc/src/lux/type.clj b/luxc/src/lux/type.clj new file mode 100644 index 000000000..d387053dc --- /dev/null +++ b/luxc/src/lux/type.clj @@ -0,0 +1,972 @@ +;; Copyright (c) Eduardo Julian. All rights reserved. +;; This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +;; If a copy of the MPL was not distributed with this file, +;; You can obtain one at http://mozilla.org/MPL/2.0/. + +(ns lux.type + (:refer-clojure :exclude [deref apply merge bound?]) + (:require [clojure.template :refer [do-template]] + clojure.core.match + clojure.core.match.array + (lux [base :as & :refer [|do return* return fail fail* assert! |let |case]]) + [lux.type.host :as &&host])) + +(declare show-type + type=) + +;; [Utils] +(defn |list? [xs] + (|case xs + (&/$Nil) + true + + (&/$Cons x xs*) + (|list? xs*) + + _ + false)) + +(def empty-env &/$Nil) + +(def Bool (&/$NamedT (&/T ["lux" "Bool"]) (&/$HostT "java.lang.Boolean" &/$Nil))) +(def Nat (&/$NamedT (&/T ["lux" "Nat"]) (&/$HostT &&host/nat-data-tag &/$Nil))) +(def Frac (&/$NamedT (&/T ["lux" "Frac"]) (&/$HostT &&host/frac-data-tag &/$Nil))) +(def Int (&/$NamedT (&/T ["lux" "Int"]) (&/$HostT "java.lang.Long" &/$Nil))) +(def Real (&/$NamedT (&/T ["lux" "Real"]) (&/$HostT "java.lang.Double" &/$Nil))) +(def Char (&/$NamedT (&/T ["lux" "Char"]) (&/$HostT "java.lang.Character" &/$Nil))) +(def Text (&/$NamedT (&/T ["lux" "Text"]) (&/$HostT "java.lang.String" &/$Nil))) +(def Ident (&/$NamedT (&/T ["lux" "Ident"]) (&/$ProdT Text Text))) + +(def Bottom + (&/$NamedT (&/T ["lux" "Bottom"]) + (&/$UnivQ empty-env + (&/$BoundT 1)))) + +(def IO + (&/$NamedT (&/T ["lux/codata" "IO"]) + (&/$UnivQ empty-env + (&/$LambdaT &/$VoidT (&/$BoundT 1))))) + +(def List + (&/$NamedT (&/T ["lux" "List"]) + (&/$UnivQ empty-env + (&/$SumT + ;; lux;Nil + &/$UnitT + ;; lux;Cons + (&/$ProdT (&/$BoundT 1) + (&/$AppT (&/$BoundT 0) + (&/$BoundT 1))))))) + +(def Maybe + (&/$NamedT (&/T ["lux" "Maybe"]) + (&/$UnivQ empty-env + (&/$SumT + ;; lux;None + &/$UnitT + ;; lux;Some + (&/$BoundT 1)) + ))) + +(def Type + (&/$NamedT (&/T ["lux" "Type"]) + (let [Type (&/$AppT (&/$BoundT 0) (&/$BoundT 1)) + TypeList (&/$AppT List Type) + TypePair (&/$ProdT Type Type)] + (&/$AppT (&/$UnivQ empty-env + (&/$SumT + ;; HostT + (&/$ProdT Text TypeList) + (&/$SumT + ;; VoidT + &/$UnitT + (&/$SumT + ;; UnitT + &/$UnitT + (&/$SumT + ;; SumT + TypePair + (&/$SumT + ;; ProdT + TypePair + (&/$SumT + ;; LambdaT + TypePair + (&/$SumT + ;; BoundT + Nat + (&/$SumT + ;; VarT + Nat + (&/$SumT + ;; ExT + Nat + (&/$SumT + ;; UnivQ + (&/$ProdT TypeList Type) + (&/$SumT + ;; ExQ + (&/$ProdT TypeList Type) + (&/$SumT + ;; AppT + TypePair + ;; NamedT + (&/$ProdT Ident Type))))))))))))) + ) + &/$VoidT)))) + +(def Ann-Value + (&/$NamedT (&/T ["lux" "Ann-Value"]) + (let [Ann-Value (&/$AppT (&/$BoundT 0) (&/$BoundT 1))] + (&/$AppT (&/$UnivQ empty-env + (&/$SumT + ;; BoolM + Bool + (&/$SumT + ;; NatM + Nat + (&/$SumT + ;; IntM + Int + (&/$SumT + ;; FracM + Frac + (&/$SumT + ;; RealM + Real + (&/$SumT + ;; CharM + Char + (&/$SumT + ;; TextM + Text + (&/$SumT + ;; IdentM + Ident + (&/$SumT + ;; ListM + (&/$AppT List Ann-Value) + ;; DictM + (&/$AppT List (&/$ProdT Text Ann-Value))))))))))) + ) + &/$VoidT)))) + +(def Anns + (&/$NamedT (&/T ["lux" "Anns"]) + (&/$AppT List (&/$ProdT Ident Ann-Value)))) + +(def Macro) + +(defn set-macro-type! [type] + (def Macro type) + nil) + +(defn bound? [id] + (fn [state] + (if-let [type (->> state (&/get$ &/$type-vars) (&/get$ &/$mappings) (&/|get id))] + (|case type + (&/$Some type*) + (return* state true) + + (&/$None) + (return* state false)) + (fail* (str "[Type Error] <bound?> Unknown type-var: " id))))) + +(defn deref [id] + (fn [state] + (if-let [type* (->> state (&/get$ &/$type-vars) (&/get$ &/$mappings) (&/|get id))] + (|case type* + (&/$Some type) + (return* state type) + + (&/$None) + (fail* (str "[Type Error] Unbound type-var: " id))) + (fail* (str "[Type Error] <deref> Unknown type-var: " id))))) + +(defn deref+ [type] + (|case type + (&/$VarT id) + (deref id) + + _ + (fail (str "[Type Error] Type is not a variable: " (show-type type))) + )) + +(defn set-var [id type] + (fn [state] + (if-let [tvar (->> state (&/get$ &/$type-vars) (&/get$ &/$mappings) (&/|get id))] + (|case tvar + (&/$Some bound) + (if (type= type bound) + (return* state nil) + (fail* (str "[Type Error] Can't re-bind type var: " id " | Current type: " (show-type bound)))) + + (&/$None) + (return* (&/update$ &/$type-vars (fn [ts] (&/update$ &/$mappings #(&/|put id (&/$Some type) %) + ts)) + state) + nil)) + (fail* (str "[Type Error] <set-var> Unknown type-var: " id " | " (->> state (&/get$ &/$type-vars) (&/get$ &/$mappings) &/|length)))))) + +(defn reset-var [id type] + (fn [state] + (if-let [tvar (->> state (&/get$ &/$type-vars) (&/get$ &/$mappings) (&/|get id))] + (return* (&/update$ &/$type-vars (fn [ts] (&/update$ &/$mappings #(&/|put id (&/$Some type) %) + ts)) + state) + nil) + (fail* (str "[Type Error] <set-var> Unknown type-var: " id " | " (->> state (&/get$ &/$type-vars) (&/get$ &/$mappings) &/|length)))))) + +(defn unset-var [id] + (fn [state] + (if-let [tvar (->> state (&/get$ &/$type-vars) (&/get$ &/$mappings) (&/|get id))] + (return* (&/update$ &/$type-vars (fn [ts] (&/update$ &/$mappings #(&/|put id &/$None %) + ts)) + state) + nil) + (fail* (str "[Type Error] <set-var> Unknown type-var: " id " | " (->> state (&/get$ &/$type-vars) (&/get$ &/$mappings) &/|length)))))) + +;; [Exports] +;; Type vars +(def create-var + (fn [state] + (let [id (->> state (&/get$ &/$type-vars) (&/get$ &/$counter))] + (return* (&/update$ &/$type-vars #(->> % + (&/update$ &/$counter inc) + (&/update$ &/$mappings (fn [ms] (&/|put id &/$None ms)))) + state) + id)))) + +(def existential + ;; (Lux Type) + (|do [seed &/gen-id] + (return (&/$ExT seed)))) + +(declare clean*) +(defn delete-var [id] + (|do [? (bound? id) + _ (if ? + (return nil) + (|do [ex existential] + (set-var id ex)))] + (fn [state] + ((|do [mappings* (&/map% (fn [binding] + (|let [[?id ?type] binding] + (if (.equals ^Object id ?id) + (return binding) + (|case ?type + (&/$None) + (return binding) + + (&/$Some ?type*) + (|case ?type* + (&/$VarT ?id*) + (if (.equals ^Object id ?id*) + (return (&/T [?id &/$None])) + (return binding)) + + _ + (|do [?type** (clean* id ?type*)] + (return (&/T [?id (&/$Some ?type**)])))) + )))) + (->> state (&/get$ &/$type-vars) (&/get$ &/$mappings)))] + (fn [state] + (return* (&/update$ &/$type-vars #(&/set$ &/$mappings (&/|remove id mappings*) %) + state) + nil))) + state)))) + +(defn with-var [k] + (|do [id create-var + output (k (&/$VarT id)) + _ (delete-var id)] + (return output))) + +(defn clean* [?tid type] + (|case type + (&/$VarT ?id) + (if (.equals ^Object ?tid ?id) + (|do [? (bound? ?id)] + (if ? + (deref ?id) + (return type))) + (|do [? (bound? ?id)] + (if ? + (|do [=type (deref ?id) + ==type (clean* ?tid =type)] + (|case ==type + (&/$VarT =id) + (if (.equals ^Object ?tid =id) + (|do [_ (unset-var ?id)] + (return type)) + (|do [_ (reset-var ?id ==type)] + (return type))) + + _ + (|do [_ (reset-var ?id ==type)] + (return type)))) + (return type))) + ) + + (&/$HostT ?name ?params) + (|do [=params (&/map% (partial clean* ?tid) ?params)] + (return (&/$HostT ?name =params))) + + (&/$LambdaT ?arg ?return) + (|do [=arg (clean* ?tid ?arg) + =return (clean* ?tid ?return)] + (return (&/$LambdaT =arg =return))) + + (&/$AppT ?lambda ?param) + (|do [=lambda (clean* ?tid ?lambda) + =param (clean* ?tid ?param)] + (return (&/$AppT =lambda =param))) + + (&/$ProdT ?left ?right) + (|do [=left (clean* ?tid ?left) + =right (clean* ?tid ?right)] + (return (&/$ProdT =left =right))) + + (&/$SumT ?left ?right) + (|do [=left (clean* ?tid ?left) + =right (clean* ?tid ?right)] + (return (&/$SumT =left =right))) + + (&/$UnivQ ?env ?body) + (|do [=env (&/map% (partial clean* ?tid) ?env) + body* (clean* ?tid ?body)] ;; TODO: DON'T CLEAN THE BODY + (return (&/$UnivQ =env body*))) + + (&/$ExQ ?env ?body) + (|do [=env (&/map% (partial clean* ?tid) ?env) + body* (clean* ?tid ?body)] ;; TODO: DON'T CLEAN THE BODY + (return (&/$ExQ =env body*))) + + _ + (return type) + )) + +(defn clean [tvar type] + (|case tvar + (&/$VarT ?id) + (clean* ?id type) + + _ + (fail (str "[Type Error] Not type-var: " (show-type tvar))))) + +(defn ^:private unravel-fun [type] + (|case type + (&/$LambdaT ?in ?out) + (|let [[??out ?args] (unravel-fun ?out)] + (&/T [??out (&/$Cons ?in ?args)])) + + _ + (&/T [type &/$Nil]))) + +(defn ^:private unravel-app [fun-type] + (|case fun-type + (&/$AppT ?left ?right) + (|let [[?fun-type ?args] (unravel-app ?left)] + (&/T [?fun-type (&/|++ ?args (&/|list ?right))])) + + _ + (&/T [fun-type &/$Nil]))) + +(do-template [<tag> <flatten> <at> <desc>] + (do (defn <flatten> [type] + "(-> Type (List Type))" + (|case type + (<tag> left right) + (&/$Cons left (<flatten> right)) + + _ + (&/|list type))) + + (defn <at> [tag type] + "(-> Int Type (Lux Type))" + (|case type + (&/$NamedT ?name ?type) + (<at> tag ?type) + + (<tag> ?left ?right) + (|case (&/T [tag ?right]) + [0 _] (return ?left) + [1 (<tag> ?left* _)] (return ?left*) + [1 _] (return ?right) + [_ (<tag> _ _)] (<at> (dec tag) ?right) + _ (fail (str "[Type Error] " <desc> " lacks member: " tag " | " (show-type type)))) + + _ + (fail (str "[Type Error] Type is not a " <desc> ": " (show-type type)))))) + + &/$SumT flatten-sum sum-at "Sum" + &/$ProdT flatten-prod prod-at "Product" + ) + +(do-template [<name> <ctor> <unit>] + (defn <name> [types] + "(-> (List Type) Type)" + (|case (&/|reverse types) + (&/$Cons last prevs) + (&/fold (fn [right left] (<ctor> left right)) last prevs) + + (&/$Nil) + <unit>)) + + Variant$ &/$SumT &/$VoidT + Tuple$ &/$ProdT &/$UnitT + ) + +(defn show-type [^objects type] + (|case type + (&/$HostT name params) + (|case params + (&/$Nil) + (str "(host " name ")") + + _ + (str "(host " name " " (->> params (&/|map show-type) (&/|interpose " ") (&/fold str "")) ")")) + + (&/$VoidT) + "Void" + + (&/$UnitT) + "Unit" + + (&/$ProdT _) + (str "[" (->> (flatten-prod type) (&/|map show-type) (&/|interpose " ") (&/fold str "")) "]") + + (&/$SumT _) + (str "(| " (->> (flatten-sum type) (&/|map show-type) (&/|interpose " ") (&/fold str "")) ")") + + (&/$LambdaT input output) + (|let [[?out ?ins] (unravel-fun type)] + (str "(-> " (->> ?ins (&/|map show-type) (&/|interpose " ") (&/fold str "")) " " (show-type ?out) ")")) + + (&/$VarT id) + (str "⌈v:" id "⌋") + + (&/$ExT ?id) + (str "⟨e:" ?id "⟩") + + (&/$BoundT idx) + (str idx) + + (&/$AppT _ _) + (|let [[?call-fun ?call-args] (unravel-app type)] + (str "(" (show-type ?call-fun) " " (->> ?call-args (&/|map show-type) (&/|interpose " ") (&/fold str "")) ")")) + + (&/$UnivQ ?env ?body) + (str "(All " (show-type ?body) ")") + + (&/$ExQ ?env ?body) + (str "(Ex " (show-type ?body) ")") + + (&/$NamedT ?name ?type) + (&/ident->text ?name) + + _ + (assert false (prn-str 'show-type (&/adt->text type))))) + +(defn type= [x y] + (or (clojure.lang.Util/identical x y) + (let [output (|case [x y] + [(&/$NamedT [?xmodule ?xname] ?xtype) (&/$NamedT [?ymodule ?yname] ?ytype)] + (and (= ?xmodule ?ymodule) + (= ?xname ?yname)) + + [(&/$HostT xname xparams) (&/$HostT yname yparams)] + (and (.equals ^Object xname yname) + (= (&/|length xparams) (&/|length yparams)) + (&/fold2 #(and %1 (type= %2 %3)) true xparams yparams)) + + [(&/$VoidT) (&/$VoidT)] + true + + [(&/$UnitT) (&/$UnitT)] + true + + [(&/$ProdT xL xR) (&/$ProdT yL yR)] + (and (type= xL yL) + (type= xR yR)) + + [(&/$SumT xL xR) (&/$SumT yL yR)] + (and (type= xL yL) + (type= xR yR)) + + [(&/$LambdaT xinput xoutput) (&/$LambdaT yinput youtput)] + (and (type= xinput yinput) + (type= xoutput youtput)) + + [(&/$VarT xid) (&/$VarT yid)] + (.equals ^Object xid yid) + + [(&/$BoundT xidx) (&/$BoundT yidx)] + (= xidx yidx) + + [(&/$ExT xid) (&/$ExT yid)] + (.equals ^Object xid yid) + + [(&/$AppT xlambda xparam) (&/$AppT ylambda yparam)] + (and (type= xlambda ylambda) (type= xparam yparam)) + + [(&/$UnivQ xenv xbody) (&/$UnivQ yenv ybody)] + (type= xbody ybody) + + [(&/$NamedT ?xname ?xtype) _] + (type= ?xtype y) + + [_ (&/$NamedT ?yname ?ytype)] + (type= x ?ytype) + + [_ _] + false + )] + output))) + +(defn ^:private fp-get [k fixpoints] + (|let [[e a] k] + (|case fixpoints + (&/$Nil) + &/$None + + (&/$Cons [[e* a*] v*] fixpoints*) + (if (and (type= e e*) + (type= a a*)) + (&/$Some v*) + (fp-get k fixpoints*)) + ))) + +(defn ^:private fp-put [k v fixpoints] + (&/$Cons (&/T [k v]) fixpoints)) + +(defn show-type+ [type] + (|case type + (&/$VarT ?id) + (fn [state] + (|case ((deref ?id) state) + (&/$Right state* bound) + (return* state (str (show-type type) " = " (show-type bound))) + + (&/$Left _) + (return* state (show-type type)))) + + _ + (return (show-type type)))) + +(defn ^:private check-error [err expected actual] + (|do [=expected (show-type+ expected) + =actual (show-type+ actual)] + (&/fail-with-loc (str (if (= "" err) err (str err "\n")) + "[Type Checker]\n" + "Expected: " =expected "\n\n" + "Actual: " =actual + "\n")))) + +(defn beta-reduce [env type] + (|case type + (&/$HostT ?name ?params) + (&/$HostT ?name (&/|map (partial beta-reduce env) ?params)) + + (&/$SumT ?left ?right) + (&/$SumT (beta-reduce env ?left) (beta-reduce env ?right)) + + (&/$ProdT ?left ?right) + (&/$ProdT (beta-reduce env ?left) (beta-reduce env ?right)) + + (&/$AppT ?type-fn ?type-arg) + (&/$AppT (beta-reduce env ?type-fn) (beta-reduce env ?type-arg)) + + (&/$UnivQ ?local-env ?local-def) + (|case ?local-env + (&/$Nil) + (&/$UnivQ env ?local-def) + + _ + type) + + (&/$ExQ ?local-env ?local-def) + (|case ?local-env + (&/$Nil) + (&/$ExQ env ?local-def) + + _ + type) + + (&/$LambdaT ?input ?output) + (&/$LambdaT (beta-reduce env ?input) (beta-reduce env ?output)) + + (&/$BoundT ?idx) + (|case (&/|at ?idx env) + (&/$Some bound) + (beta-reduce env bound) + + _ + (assert false (str "[Type Error] Unknown var: " ?idx " | " (&/->seq (&/|map show-type env))))) + + _ + type + )) + +(defn apply-type [type-fn param] + (|case type-fn + (&/$UnivQ local-env local-def) + (return (beta-reduce (->> local-env + (&/$Cons param) + (&/$Cons type-fn)) + local-def)) + + (&/$ExQ local-env local-def) + (return (beta-reduce (->> local-env + (&/$Cons param) + (&/$Cons type-fn)) + local-def)) + + (&/$AppT F A) + (|do [type-fn* (apply-type F A)] + (apply-type type-fn* param)) + + (&/$NamedT ?name ?type) + (apply-type ?type param) + + ;; TODO: This one must go... + (&/$ExT id) + (return (&/$AppT type-fn param)) + + (&/$VarT id) + (|do [=type-fun (deref id)] + (apply-type =type-fun param)) + + _ + (fail (str "[Type System] Not a type function:\n" (show-type type-fn) "\n")))) + +(def ^:private init-fixpoints &/$Nil) + +(defn ^:private check* [class-loader fixpoints invariant?? expected actual] + (if (clojure.lang.Util/identical expected actual) + (return fixpoints) + (&/with-attempt + (|case [expected actual] + [(&/$VarT ?eid) (&/$VarT ?aid)] + (if (.equals ^Object ?eid ?aid) + (return fixpoints) + (|do [ebound (fn [state] + (|case ((deref ?eid) state) + (&/$Right state* ebound) + (return* state* (&/$Some ebound)) + + (&/$Left _) + (return* state &/$None))) + abound (fn [state] + (|case ((deref ?aid) state) + (&/$Right state* abound) + (return* state* (&/$Some abound)) + + (&/$Left _) + (return* state &/$None)))] + (|case [ebound abound] + [(&/$None _) (&/$None _)] + (|do [_ (set-var ?eid actual)] + (return fixpoints)) + + [(&/$Some etype) (&/$None _)] + (check* class-loader fixpoints invariant?? etype actual) + + [(&/$None _) (&/$Some atype)] + (check* class-loader fixpoints invariant?? expected atype) + + [(&/$Some etype) (&/$Some atype)] + (check* class-loader fixpoints invariant?? etype atype)))) + + [(&/$VarT ?id) _] + (fn [state] + (|case ((set-var ?id actual) state) + (&/$Right state* _) + (return* state* fixpoints) + + (&/$Left _) + ((|do [bound (deref ?id)] + (check* class-loader fixpoints invariant?? bound actual)) + state))) + + [_ (&/$VarT ?id)] + (fn [state] + (|case ((set-var ?id expected) state) + (&/$Right state* _) + (return* state* fixpoints) + + (&/$Left _) + ((|do [bound (deref ?id)] + (check* class-loader fixpoints invariant?? expected bound)) + state))) + + [(&/$AppT (&/$ExT eid) eA) (&/$AppT (&/$ExT aid) aA)] + (if (= eid aid) + (check* class-loader fixpoints invariant?? eA aA) + (check-error "" expected actual)) + + [(&/$AppT (&/$VarT ?id) A1) (&/$AppT F2 A2)] + (fn [state] + (|case ((|do [F1 (deref ?id)] + (check* class-loader fixpoints invariant?? (&/$AppT F1 A1) actual)) + state) + (&/$Right state* output) + (return* state* output) + + (&/$Left _) + (|case F2 + (&/$UnivQ (&/$Cons _) _) + ((|do [actual* (apply-type F2 A2)] + (check* class-loader fixpoints invariant?? expected actual*)) + state) + + (&/$ExT _) + ((|do [fixpoints* (check* class-loader fixpoints invariant?? (&/$VarT ?id) F2)] + (check* class-loader fixpoints* invariant?? A1 A2)) + state) + + _ + ((|do [fixpoints* (check* class-loader fixpoints invariant?? (&/$VarT ?id) F2) + e* (apply-type F2 A1) + a* (apply-type F2 A2)] + (check* class-loader fixpoints* invariant?? e* a*)) + state)))) + + [(&/$AppT F1 A1) (&/$AppT (&/$VarT ?id) A2)] + (fn [state] + (|case ((|do [F2 (deref ?id)] + (check* class-loader fixpoints invariant?? expected (&/$AppT F2 A2))) + state) + (&/$Right state* output) + (return* state* output) + + (&/$Left _) + ((|do [fixpoints* (check* class-loader fixpoints invariant?? F1 (&/$VarT ?id)) + e* (apply-type F1 A1) + a* (apply-type F1 A2)] + (check* class-loader fixpoints* invariant?? e* a*)) + state))) + + [(&/$AppT F A) _] + (let [fp-pair (&/T [expected actual]) + _ (when (> (&/|length fixpoints) 40) + (println 'FIXPOINTS (->> (&/|keys fixpoints) + (&/|map (fn [pair] + (|let [[e a] pair] + (str (show-type e) ":+:" + (show-type a))))) + (&/|interpose "\n\n") + (&/fold str ""))) + (assert false (prn-str 'check* '[(&/$AppT F A) _] (&/|length fixpoints) (show-type expected) (show-type actual))))] + (|case (fp-get fp-pair fixpoints) + (&/$Some ?) + (if ? + (return fixpoints) + (check-error "" expected actual)) + + (&/$None) + (|do [expected* (apply-type F A)] + (check* class-loader (fp-put fp-pair true fixpoints) invariant?? expected* actual)))) + + [_ (&/$AppT (&/$ExT aid) A)] + (check-error "" expected actual) + + [_ (&/$AppT F A)] + (|do [actual* (apply-type F A)] + (check* class-loader fixpoints invariant?? expected actual*)) + + [(&/$UnivQ _) _] + (|do [$arg existential + expected* (apply-type expected $arg)] + (check* class-loader fixpoints invariant?? expected* actual)) + + [_ (&/$UnivQ _)] + (with-var + (fn [$arg] + (|do [actual* (apply-type actual $arg) + =output (check* class-loader fixpoints invariant?? expected actual*) + _ (clean $arg expected)] + (return =output)))) + + [(&/$ExQ e!env e!def) _] + (with-var + (fn [$arg] + (|do [expected* (apply-type expected $arg) + =output (check* class-loader fixpoints invariant?? expected* actual) + _ (clean $arg actual)] + (return =output)))) + + [_ (&/$ExQ a!env a!def)] + (|do [$arg existential + actual* (apply-type actual $arg)] + (check* class-loader fixpoints invariant?? expected actual*)) + + [(&/$HostT e!data) (&/$HostT a!data)] + (&&host/check-host-types (partial check* class-loader fixpoints true) + check-error + fixpoints + existential + class-loader + invariant?? + e!data + a!data) + + [(&/$VoidT) (&/$VoidT)] + (return fixpoints) + + [(&/$UnitT) (&/$UnitT)] + (return fixpoints) + + [(&/$LambdaT eI eO) (&/$LambdaT aI aO)] + (|do [fixpoints* (check* class-loader fixpoints invariant?? aI eI)] + (check* class-loader fixpoints* invariant?? eO aO)) + + [(&/$ProdT eL eR) (&/$ProdT aL aR)] + (|do [fixpoints* (check* class-loader fixpoints invariant?? eL aL)] + (check* class-loader fixpoints* invariant?? eR aR)) + + [(&/$SumT eL eR) (&/$SumT aL aR)] + (|do [fixpoints* (check* class-loader fixpoints invariant?? eL aL)] + (check* class-loader fixpoints* invariant?? eR aR)) + + [(&/$ExT e!id) (&/$ExT a!id)] + (if (.equals ^Object e!id a!id) + (return fixpoints) + (check-error "" expected actual)) + + [(&/$NamedT _ ?etype) _] + (check* class-loader fixpoints invariant?? ?etype actual) + + [_ (&/$NamedT _ ?atype)] + (check* class-loader fixpoints invariant?? expected ?atype) + + [_ _] + (fail "")) + (fn [err] + (check-error err expected actual))))) + +(defn check [expected actual] + (|do [class-loader &/loader + _ (check* class-loader init-fixpoints false expected actual)] + (return nil))) + +(defn actual-type [type] + "(-> Type (Lux Type))" + (|case type + (&/$AppT ?all ?param) + (|do [type* (apply-type ?all ?param)] + (actual-type type*)) + + (&/$VarT id) + (|do [=type (deref id)] + (actual-type =type)) + + (&/$NamedT ?name ?type) + (actual-type ?type) + + _ + (return type) + )) + +(defn type-name [type] + "(-> Type (Lux Ident))" + (|case type + (&/$NamedT name _) + (return name) + + _ + (fail (str "[Type Error] Type is not named: " (show-type type))) + )) + +(defn unknown? [type] + "(-> Type (Lux Bool))" + (|case type + (&/$VarT id) + (|do [? (bound? id)] + (return (not ?))) + + _ + (return false))) + +(defn resolve-type [type] + "(-> Type (Lux Type))" + (|case type + (&/$VarT id) + (|do [? (bound? id)] + (if ? + (deref id) + (return type))) + + _ + (return type))) + +(defn tuple-types-for [size-members type] + "(-> Int Type [Int (List Type)])" + (|let [?member-types (flatten-prod type) + size-types (&/|length ?member-types)] + (if (>= size-types size-members) + (&/T [size-members (&/|++ (&/|take (dec size-members) ?member-types) + (&/|list (|case (->> ?member-types (&/|drop (dec size-members)) (&/|reverse)) + (&/$Cons last prevs) + (&/fold (fn [right left] (&/$ProdT left right)) + last prevs))))]) + (&/T [size-types ?member-types]) + ))) + +(do-template [<name> <zero> <plus>] + (defn <name> [types] + (|case (&/|reverse types) + (&/$Nil) + <zero> + + (&/$Cons type (&/$Nil)) + type + + (&/$Cons last prevs) + (&/fold (fn [r l] (<plus> l r)) last prevs))) + + fold-prod &/$UnitT &/$ProdT + fold-sum &/$VoidT &/$SumT + ) + +(def create-var+ + (|do [id create-var] + (return (&/$VarT id)))) + +(defn ^:private push-app [inf-type inf-var] + (|case inf-type + (&/$AppT inf-type* inf-var*) + (&/$AppT (push-app inf-type* inf-var) inf-var*) + + _ + (&/$AppT inf-type inf-var))) + +(defn ^:private push-name [name inf-type] + (|case inf-type + (&/$AppT inf-type* inf-var*) + (&/$AppT (push-name name inf-type*) inf-var*) + + _ + (&/$NamedT name inf-type))) + +(defn ^:private push-univq [env inf-type] + (|case inf-type + (&/$AppT inf-type* inf-var*) + (&/$AppT (push-univq env inf-type*) inf-var*) + + _ + (&/$UnivQ env inf-type))) + +(defn instantiate-inference [type] + (|case type + (&/$NamedT ?name ?type) + (|do [output (instantiate-inference ?type)] + (return (push-name ?name output))) + + (&/$UnivQ _aenv _abody) + (|do [inf-var create-var + output (instantiate-inference _abody)] + (return (push-univq _aenv (push-app output (&/$VarT inf-var))))) + + _ + (return type))) diff --git a/luxc/src/lux/type/host.clj b/luxc/src/lux/type/host.clj new file mode 100644 index 000000000..462e1aebe --- /dev/null +++ b/luxc/src/lux/type/host.clj @@ -0,0 +1,352 @@ +;; Copyright (c) Eduardo Julian. All rights reserved. +;; This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +;; If a copy of the MPL was not distributed with this file, +;; You can obtain one at http://mozilla.org/MPL/2.0/. + +(ns lux.type.host + (:require clojure.core.match + clojure.core.match.array + (lux [base :as & :refer [|do return* return fail fail* assert! |let |case]]) + [lux.host.generics :as &host-generics]) + (:import (java.lang.reflect GenericArrayType + ParameterizedType + TypeVariable + WildcardType))) + +;; [Exports] +(def array-data-tag "#Array") +(def null-data-tag "#Null") +(def nat-data-tag "#Nat") +(def frac-data-tag "#Frac") + +;; [Utils] +(defn ^:private trace-lineage* [^Class super-class ^Class sub-class] + "(-> Class Class (List Class))" + ;; Either they're both interfaces, of they're both classes + (let [valid-sub? #(if (or (= super-class %) + (.isAssignableFrom super-class %)) + % + nil)] + (cond (.isInterface sub-class) + (loop [sub-class sub-class + stack (&/|list)] + (let [super-interface (some valid-sub? (.getInterfaces sub-class))] + (if (= super-class super-interface) + (&/$Cons super-interface stack) + (recur super-interface (&/$Cons super-interface stack))))) + + (.isInterface super-class) + (loop [sub-class sub-class + stack (&/|list)] + (if-let [super-interface (some valid-sub? (.getInterfaces sub-class))] + (if (= super-class super-interface) + (&/$Cons super-interface stack) + (recur super-interface (&/$Cons super-interface stack))) + (let [super* (.getSuperclass sub-class)] + (recur super* (&/$Cons super* stack))))) + + :else + (loop [sub-class sub-class + stack (&/|list)] + (let [super* (.getSuperclass sub-class)] + (if (= super* super-class) + (&/$Cons super* stack) + (recur super* (&/$Cons super* stack)))))))) + +(defn ^:private trace-lineage [^Class sub-class ^Class super-class] + "(-> Class Class (List Class))" + (if (= sub-class super-class) + (&/|list) + (&/|reverse (trace-lineage* super-class sub-class)))) + +(let [matcher (fn [m ^TypeVariable jt lt] (&/$Cons (&/T [(.getName jt) lt]) m))] + (defn ^:private match-params [sub-type-params params] + (assert (and (= (&/|length sub-type-params) (&/|length params)) + (&/|every? (partial instance? TypeVariable) sub-type-params))) + (&/fold2 matcher (&/|table) sub-type-params params))) + +;; [Exports] +(let [class-name-re #"((\[+)L([^\s]+);|([^\s]+)|(\[+)([ZBSIJFDC]))" + jprim->lprim (fn [prim] + (case prim + "Z" "boolean" + "B" "byte" + "S" "short" + "I" "int" + "J" "long" + "F" "float" + "D" "double" + "C" "char"))] + (defn class->type [^Class class] + "(-> Class Type)" + (let [gclass-name (.getName class)] + (case gclass-name + ("[Z" "[B" "[S" "[I" "[J" "[F" "[D" "[C") + (&/$HostT gclass-name (&/|list)) + ;; else + (if-let [[_ _ arr-obrackets arr-obase simple-base arr-pbrackets arr-pbase] (re-find class-name-re gclass-name)] + (let [base (or arr-obase simple-base (jprim->lprim arr-pbase))] + (if (.equals "void" base) + &/$UnitT + (reduce (fn [inner _] (&/$HostT array-data-tag (&/|list inner))) + (&/$HostT base (try (-> (Class/forName base) .getTypeParameters + seq count (repeat (&/$HostT "java.lang.Object" &/$Nil)) + &/->list) + (catch Exception e + (&/|list)))) + (range (count (or arr-obrackets arr-pbrackets ""))))) + )))))) + +(defn instance-param [existential matchings refl-type] + "(-> (Lux Type) (List (, Text Type)) (^ java.lang.reflect.Type) (Lux Type))" + (cond (instance? Class refl-type) + (return (class->type refl-type)) + + (instance? GenericArrayType refl-type) + (|do [inner-type (instance-param existential matchings (.getGenericComponentType ^GenericArrayType refl-type))] + (return (&/$HostT array-data-tag (&/|list inner-type)))) + + (instance? ParameterizedType refl-type) + (|do [:let [refl-type* ^ParameterizedType refl-type] + params* (->> refl-type* + .getActualTypeArguments + seq &/->list + (&/map% (partial instance-param existential matchings)))] + (return (&/$HostT (->> refl-type* ^Class (.getRawType) .getName) + params*))) + + (instance? TypeVariable refl-type) + (let [gvar (.getName ^TypeVariable refl-type)] + (if-let [m-type (&/|get gvar matchings)] + (return m-type) + (fail (str "[Type Error] Unknown generic type variable: " gvar " -- " (->> matchings + (&/|map &/|first) + &/->seq))))) + + (instance? WildcardType refl-type) + (if-let [bound (->> ^WildcardType refl-type .getUpperBounds seq first)] + (instance-param existential matchings bound) + existential))) + +(defn principal-class [refl-type] + (cond (instance? Class refl-type) + (|case (class->type refl-type) + (&/$HostT "#Array" (&/$Cons (&/$HostT class-name _) (&/$Nil))) + (str "[" (&host-generics/->type-signature class-name)) + + (&/$HostT class-name _) + (&host-generics/->type-signature class-name) + + (&/$UnitT) + "V") + + (instance? GenericArrayType refl-type) + (&host-generics/->type-signature (str refl-type)) + + (instance? ParameterizedType refl-type) + (&host-generics/->type-signature (->> ^ParameterizedType refl-type ^Class (.getRawType) .getName)) + + (instance? TypeVariable refl-type) + (if-let [bound (->> ^TypeVariable refl-type .getBounds seq first)] + (principal-class bound) + (&host-generics/->type-signature "java.lang.Object")) + + (instance? WildcardType refl-type) + (if-let [bound (->> ^WildcardType refl-type .getUpperBounds seq first)] + (principal-class bound) + (&host-generics/->type-signature "java.lang.Object")))) + +(defn instance-gtype [existential matchings gtype] + "(-> (Lux Type) (List (, Text Type)) GenericType (Lux Type))" + (|case gtype + (&/$GenericArray component-type) + (|do [inner-type (instance-gtype existential matchings component-type)] + (return (&/$HostT array-data-tag (&/|list inner-type)))) + + (&/$GenericClass type-name type-params) + ;; When referring to type-parameters during class or method + ;; definition, a type-environment is set for storing the names + ;; of such parameters. + ;; When a "class" shows up with the name of one of those + ;; parameters, it must be detected, and the bytecode class-name + ;; must correspond to Object's. + + (if-let [m-type (&/|get type-name matchings)] + (return m-type) + (|do [params* (&/map% (partial instance-gtype existential matchings) + type-params)] + (return (&/$HostT type-name params*)))) + + (&/$GenericTypeVar var-name) + (if-let [m-type (&/|get var-name matchings)] + (return m-type) + (fail (str "[Type Error] Unknown generic type variable: " var-name " -- " (->> matchings + (&/|map &/|first) + &/->seq)))) + + (&/$GenericWildcard) + existential)) + +;; [Utils] +(defn ^:private translate-params [existential super-type-params sub-type-params params] + "(-> (List (^ java.lang.reflect.Type)) (List (^ java.lang.reflect.Type)) (List Type) (Lux (List Type)))" + (|let [matchings (match-params sub-type-params params)] + (&/map% (partial instance-param existential matchings) super-type-params))) + +(defn ^:private raise* [existential sub+params ^Class super] + "(-> (, Class (List Type)) Class (Lux (, Class (List Type))))" + (|let [[^Class sub params] sub+params] + (if (.isInterface super) + (|do [:let [super-params (->> sub + .getGenericInterfaces + (some #(if (= super (if (instance? Class %) % (.getRawType ^ParameterizedType %))) + (if (instance? Class %) + (&/|list) + (->> ^ParameterizedType % .getActualTypeArguments seq &/->list)) + nil)))] + params* (translate-params existential + (or super-params (&/|list)) + (->> sub .getTypeParameters seq &/->list) + params)] + (return (&/T [super params*]))) + (let [super* (.getGenericSuperclass sub)] + (cond (instance? Class super*) + (return (&/T [super* (&/|list)])) + + (instance? ParameterizedType super*) + (|do [params* (translate-params existential + (->> ^ParameterizedType super* .getActualTypeArguments seq &/->list) + (->> sub .getTypeParameters seq &/->list) + params)] + (return (&/T [super params*]))) + + :else + (assert false (prn-str super* (class super*) [sub super]))))))) + +(defn ^:private raise [existential lineage class params] + "(-> (List Class) Class (List Type) (Lux (, Class (List Type))))" + (&/fold% (partial raise* existential) (&/T [class params]) lineage)) + +;; [Exports] +(defn ->super-type [existential class-loader super-class sub-class sub-params] + "(-> Text Text (List Type) (Lux Type))" + (let [super-class+ (Class/forName super-class true class-loader) + sub-class+ (Class/forName sub-class true class-loader)] + (if (.isAssignableFrom super-class+ sub-class+) + (let [lineage (trace-lineage sub-class+ super-class+)] + (|do [[^Class sub-class* sub-params*] (raise existential lineage sub-class+ sub-params)] + (return (&/$HostT (.getName sub-class*) sub-params*)))) + (fail (str "[Type Error] Classes don't have a subtyping relationship: " sub-class " </= " super-class))))) + +(defn as-obj [class] + (case class + "boolean" "java.lang.Boolean" + "byte" "java.lang.Byte" + "short" "java.lang.Short" + "int" "java.lang.Integer" + "long" "java.lang.Long" + "float" "java.lang.Float" + "double" "java.lang.Double" + "char" "java.lang.Character" + ;; else + class)) + +(let [primitive-types #{"boolean" "byte" "short" "int" "long" "float" "double" "char"}] + (defn primitive-type? [type-name] + (contains? primitive-types type-name))) + +(defn check-host-types [check check-error fixpoints existential class-loader invariant?? expected actual] + (|let [[e!name e!params] expected + [a!name a!params] actual] + ;; TODO: Delete first branch. It smells like a hack... + (try (cond (or (= "java.lang.Object" e!name) + (and (= nat-data-tag e!name) + (= nat-data-tag a!name)) + (and (= frac-data-tag e!name) + (= frac-data-tag a!name)) + (and (= null-data-tag e!name) + (= null-data-tag a!name)) + (and (not (primitive-type? e!name)) + (= null-data-tag a!name))) + (return fixpoints) + + (or (and (= array-data-tag e!name) + (not= array-data-tag a!name)) + (= nat-data-tag e!name) (= nat-data-tag a!name) + (= frac-data-tag e!name) (= frac-data-tag a!name) + (= null-data-tag e!name) (= null-data-tag a!name)) + (check-error "" (&/$HostT e!name e!params) (&/$HostT a!name a!params)) + + :else + (let [e!name (as-obj e!name) + a!name (as-obj a!name)] + (cond (= e!name a!name) + (if (= (&/|length e!params) (&/|length a!params)) + (|do [_ (&/map2% check e!params a!params)] + (return fixpoints)) + (fail (str "[Type Error] Amounts of generic parameters don't match: " e!name "(" (&/|length e!params) ")" " vs " a!name "(" (&/|length a!params) ")"))) + + (not invariant??) + (|do [actual* (->super-type existential class-loader e!name a!name a!params)] + (check (&/$HostT e!name e!params) actual*)) + + :else + (fail (str "[Type Error] Names don't match: " e!name " =/= " a!name))))) + (catch Exception e + (prn 'check-host-types e [e!name a!name]) + (throw e))))) + +(defn gtype->gclass [gtype] + "(-> GenericType GenericClass)" + (cond (instance? Class gtype) + (&/$GenericClass (.getName ^Class gtype) &/$Nil) + + (instance? GenericArrayType gtype) + (&/$GenericArray (gtype->gclass (.getGenericComponentType ^GenericArrayType gtype))) + + (instance? ParameterizedType gtype) + (let [type-name (->> ^ParameterizedType gtype ^Class (.getRawType) .getName) + type-params (->> ^ParameterizedType gtype + .getActualTypeArguments + seq &/->list + (&/|map gtype->gclass))] + (&/$GenericClass type-name type-params)) + + (instance? TypeVariable gtype) + (&/$GenericTypeVar (.getName ^TypeVariable gtype)) + + (instance? WildcardType gtype) + (if-let [bound (->> ^WildcardType gtype .getUpperBounds seq first)] + (&/$GenericWildcard (&/$Some (&/T &/$UpperBound (gtype->gclass bound)))) + (if-let [bound (->> ^WildcardType gtype .getLowerBounds seq first)] + (&/$GenericWildcard (&/$Some (&/T &/$LowerBound (gtype->gclass bound)))) + (&/$GenericWildcard &/$None))))) + +(let [generic-type-sig "Ljava/lang/Object;"] + (defn gclass->sig [gclass] + "(-> GenericClass Text)" + (|case gclass + (&/$GenericClass gclass-name (&/$Nil)) + (case gclass-name + "void" "V" + "boolean" "Z" + "byte" "B" + "short" "S" + "int" "I" + "long" "J" + "float" "F" + "double" "D" + "char" "C" + ("[Z" "[B" "[S" "[I" "[J" "[F" "[D" "[C") gclass-name + ;; else + (str "L" (clojure.string/replace gclass-name #"\." "/") ";")) + + (&/$GenericArray inner-gtype) + (str "[" (gclass->sig inner-gtype)) + + (&/$GenericTypeVar ?vname) + generic-type-sig + + (&/$GenericWildcard _) + generic-type-sig + ))) diff --git a/luxc/test/test/lux/lexer.clj b/luxc/test/test/lux/lexer.clj new file mode 100644 index 000000000..3bd45cb5f --- /dev/null +++ b/luxc/test/test/lux/lexer.clj @@ -0,0 +1,276 @@ +;; Copyright (c) Eduardo Julian. All rights reserved. +;; This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +;; If a copy of the MPL was not distributed with this file, +;; You can obtain one at http://mozilla.org/MPL/2.0/. + +(ns test.lux.lexer + (:use clojure.test) + (:require (lux [base :as & :refer [|do return* return fail fail* |let |case]] + [reader :as &reader] + [lexer :as &lexer]) + [lux.analyser.module :as &a-module] + :reload-all + )) + +;; [Utils] +(def ^:private module-name "test") + +(defn ^:private make-state [source-code] + (&/set$ &/$source (&reader/from module-name source-code) + (&/init-state nil))) + +;; [Tests] +(deftest lex-white-space + (let [input " \t"] + (|case (&/run-state &lexer/lex (make-state input)) + (&/$Right state [cursor (&lexer/$White_Space output)]) + (is (= input output)) + + _ + (is false "Couldn't read.") + ))) + +(deftest lex-comment + ;; Should be capable of recognizing both single-line & multi-line comments. + (let [input1 " YOLO" + input2 "\nLOL\n" + input3 " NYAN\n#(\nCAT )#\n"] + (|case (&/run-state (|do [[_ single-line] &lexer/lex + [_ multi-line] &lexer/lex + [_ multi-line-embedded] &lexer/lex] + (return (&/T [single-line multi-line multi-line-embedded]))) + (make-state (str "##" input1 "\n" "#(" input2 ")#" "\n" "#(" input3 ")#"))) + (&/$Right state [(&lexer/$Comment output1) + (&lexer/$Comment output2) + (&lexer/$Comment output3)]) + (are [input output] (= input output) + input1 output1 + input2 output2 + input3 output3) + + _ + (is false "Couldn't read.") + ))) + +(deftest lex-bool + (let [input1 "true" + input2 "false"] + (|case (&/run-state (|do [[_ output1] &lexer/lex + [_ output2] &lexer/lex] + (return (&/T [output1 output2]))) + (make-state (str input1 "\n" input2))) + (&/$Right state [(&lexer/$Bool output1) + (&lexer/$Bool output2)]) + (are [input output] (= input output) + input1 output1 + input2 output2) + + _ + (is false "Couldn't read.") + ))) + +(deftest lex-int + (let [input1 "0" + input2 "12" + input3 "-123"] + (|case (&/run-state (|do [[_ output1] &lexer/lex + [_ output2] &lexer/lex + [_ output3] &lexer/lex] + (return (&/T [output1 output2 output3]))) + (make-state (str input1 "\n" input2 "\n" input3))) + (&/$Right state [(&lexer/$Int output1) + (&lexer/$Int output2) + (&lexer/$Int output3)]) + (are [input output] (= input output) + input1 output1 + input2 output2 + input3 output3) + + _ + (is false "Couldn't read.") + ))) + +(deftest lex-real + (let [input1 "0.00123" + input2 "12.01020300" + input3 "-12.3"] + (|case (&/run-state (|do [[_ output1] &lexer/lex + [_ output2] &lexer/lex + [_ output3] &lexer/lex] + (return (&/T [output1 output2 output3]))) + (make-state (str input1 "\n" input2 "\n" input3))) + (&/$Right state [(&lexer/$Real output1) + (&lexer/$Real output2) + (&lexer/$Real output3)]) + (are [input output] (= input output) + input1 output1 + input2 output2 + input3 output3) + + _ + (is false "Couldn't read.") + ))) + +(deftest lex-char + (let [input1 "a" + input2 "\\n" + input3 " " + input4 "\\t" + input5 "\\b" + input6 "\\r" + input7 "\\f" + input8 "\\\"" + input9 "\\\\"] + (|case (&/run-state (|do [[_ output1] &lexer/lex + [_ output2] &lexer/lex + [_ output3] &lexer/lex + [_ output4] &lexer/lex + [_ output5] &lexer/lex + [_ output6] &lexer/lex + [_ output7] &lexer/lex + [_ output8] &lexer/lex + [_ output9] &lexer/lex] + (return (&/T [output1 output2 output3 output4 output5 output6 output7 output8 output9]))) + (make-state (str "#\"" input1 "\"" "\n" "#\"" input2 "\"" "\n" "#\"" input3 "\"" + "\n" "#\"" input4 "\"" "\n" "#\"" input5 "\"" "\n" "#\"" input6 "\"" + "\n" "#\"" input7 "\"" "\n" "#\"" input8 "\"" "\n" "#\"" input9 "\""))) + (&/$Right state [(&lexer/$Char output1) + (&lexer/$Char output2) + (&lexer/$Char output3) + (&lexer/$Char output4) + (&lexer/$Char output5) + (&lexer/$Char output6) + (&lexer/$Char output7) + (&lexer/$Char output8) + (&lexer/$Char output9)]) + (are [input output] (= input output) + input1 output1 + "\n" output2 + input3 output3 + "\t" output4 + "\b" output5 + "\r" output6 + "\f" output7 + "\"" output8 + "\\" output9) + + _ + (is false "Couldn't read.") + ))) + +(deftest lex-text + (let [input1 "" + input2 "abc" + input3 "yolo\\nlol\\tmeme" + input4 "This is a test\\nof multi-line text.\\n\\nI just wanna make sure it works alright..."] + (|case (&/run-state (|do [[_ output1] &lexer/lex + [_ output2] &lexer/lex + [_ output3] &lexer/lex + [_ output4] &lexer/lex] + (return (&/T [output1 output2 output3 output4]))) + (make-state (str "\"" input1 "\"" "\n" "\"" input2 "\"" "\n" "\"" input3 "\"" "\n" "\"" input4 "\""))) + (&/$Right state [(&lexer/$Text output1) + (&lexer/$Text output2) + (&lexer/$Text output3) + (&lexer/$Text output4)]) + (are [input output] (= input output) + input1 output1 + input2 output2 + "yolo\nlol\tmeme" output3 + "This is a test\nof multi-line text.\n\nI just wanna make sure it works alright..." output4) + + _ + (is false "Couldn't read.") + ))) + +(deftest lex-symbol + (let [input1 "foo" + input2 "test;bar0123456789" + input3 ";b1a2z3" + input4 ";;quux" + input5 "!_@$%^&*-+=.<>?/|\\~`':"] + (|case (&/run-state (|do [_ (&a-module/enter-module module-name) + [_ output1] &lexer/lex + [_ output2] &lexer/lex + [_ output3] &lexer/lex + [_ output4] &lexer/lex + [_ output5] &lexer/lex] + (return (&/T [output1 output2 output3 output4 output5]))) + (make-state (str input1 "\n" input2 "\n" input3 "\n" input4 "\n" input5 " "))) + (&/$Right state [(&lexer/$Symbol output1) + (&lexer/$Symbol output2) + (&lexer/$Symbol output3) + (&lexer/$Symbol output4) + (&lexer/$Symbol output5)]) + (are [input output] (&/ident= input output) + (&/T ["" "foo"]) output1 + (&/T ["test" "bar0123456789"]) output2 + (&/T ["lux" "b1a2z3"]) output3 + (&/T ["test" "quux"]) output4 + (&/T ["" "!_@$%^&*-+=.<>?/|\\~`':"]) output5) + + _ + (is false "Couldn't read") + ))) + +(deftest lex-tag + (let [input1 "foo" + input2 "test;bar0123456789" + input3 ";b1a2z3" + input4 ";;quux" + input5 "!_@$%^&*-+=.<>?/|\\~`':"] + (|case (&/run-state (|do [_ (&a-module/enter-module module-name) + [_ output1] &lexer/lex + [_ output2] &lexer/lex + [_ output3] &lexer/lex + [_ output4] &lexer/lex + [_ output5] &lexer/lex] + (return (&/T [output1 output2 output3 output4 output5]))) + (make-state (str "#" input1 "\n" "#" input2 "\n" "#" input3 "\n" "#" input4 "\n" "#" input5 " "))) + (&/$Right state [(&lexer/$Tag output1) + (&lexer/$Tag output2) + (&lexer/$Tag output3) + (&lexer/$Tag output4) + (&lexer/$Tag output5)]) + (are [input output] (&/ident= input output) + (&/T ["" "foo"]) output1 + (&/T ["test" "bar0123456789"]) output2 + (&/T ["lux" "b1a2z3"]) output3 + (&/T ["test" "quux"]) output4 + (&/T ["" "!_@$%^&*-+=.<>?/|\\~`':"]) output5) + + _ + (is false "Couldn't read.") + ))) + +(deftest lex-delimiter + (let [input1 "(" + input2 ")" + input3 "[" + input4 "]" + input5 "{" + input6 "}"] + (|case (&/run-state (|do [_ (&a-module/enter-module module-name) + [_ output1] &lexer/lex + [_ output2] &lexer/lex + [_ output3] &lexer/lex + [_ output4] &lexer/lex + [_ output5] &lexer/lex + [_ output6] &lexer/lex] + (return (&/T [output1 output2 output3 output4 output5 output6]))) + (make-state (str input1 "\n" input2 "\n" input3 "\n" input4 "\n" input5 "\n" input6))) + (&/$Right state [(&lexer/$Open_Paren) + (&lexer/$Close_Paren) + (&lexer/$Open_Bracket) + (&lexer/$Close_Bracket) + (&lexer/$Open_Brace) + (&lexer/$Close_Brace)]) + (is true) + + _ + (is false "Couldn't read.") + ))) + +(comment + (run-all-tests) + ) diff --git a/luxc/test/test/lux/parser.clj b/luxc/test/test/lux/parser.clj new file mode 100644 index 000000000..29e916b74 --- /dev/null +++ b/luxc/test/test/lux/parser.clj @@ -0,0 +1,274 @@ +;; Copyright (c) Eduardo Julian. All rights reserved. +;; This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +;; If a copy of the MPL was not distributed with this file, +;; You can obtain one at http://mozilla.org/MPL/2.0/. + +(ns test.lux.parser + (:use (clojure test + template)) + (:require (lux [base :as & :refer [|do return* return fail fail* |let |case]] + [reader :as &reader] + [parser :as &parser]) + [lux.analyser.module :as &a-module] + :reload-all)) + +;; [Utils] +(def ^:private module-name "test") + +(defn ^:private make-state [source-code] + (&/set$ &/$source (&reader/from module-name source-code) + (&/init-state nil))) + +;; [Tests] +(deftest parse-white-space + (let [input " \t"] + (|case (&/run-state &parser/parse (make-state input)) + (&/$Right state (&/$Nil)) + (is true) + + _ + (is false "Couldn't read.") + ))) + +(deftest parse-comment + (let [input1 " YOLO" + input2 "\nLOL\n" + input3 " NYAN\n#(\nCAT )#\n"] + (|case (&/run-state &parser/parse (make-state (str "##" input1 "\n" "#(" input2 ")#" "\n" "#(" input3 ")#"))) + (&/$Right state (&/$Nil)) + (is true) + + _ + (is false "Couldn't read.") + ))) + +(deftest parse-bool + (let [input1 "true" + input2 "false"] + (|case (&/run-state (|do [output1 &parser/parse + output2 &parser/parse] + (return (&/|++ output1 output2))) + (make-state (str input1 "\n" input2))) + (&/$Right state (&/$Cons [_ (&/$BoolS output1)] (&/$Cons [_ (&/$BoolS output2)] (&/$Nil)))) + (are [input output] (= input output) + true output1 + false output2) + + _ + (is false "Couldn't read.") + ))) + +(deftest parse-int + (let [input1 "0" + input2 "12" + input3 "-123"] + (|case (&/run-state (|do [output1 &parser/parse + output2 &parser/parse + output3 &parser/parse] + (return (&/|++ output1 (&/|++ output2 output3)))) + (make-state (str input1 "\n" input2 "\n" input3))) + (&/$Right state (&/$Cons [_ (&/$IntS output1)] (&/$Cons [_ (&/$IntS output2)] (&/$Cons [_ (&/$IntS output3)] (&/$Nil))))) + (are [input output] (= input output) + 0 output1 + 12 output2 + -123 output3) + + _ + (is false "Couldn't read.") + ))) + +(deftest parse-real + (let [input1 "0.00123" + input2 "12.01020300" + input3 "-12.3"] + (|case (&/run-state (|do [output1 &parser/parse + output2 &parser/parse + output3 &parser/parse] + (return (&/|++ output1 (&/|++ output2 output3)))) + (make-state (str input1 "\n" input2 "\n" input3))) + (&/$Right state (&/$Cons [_ (&/$RealS output1)] (&/$Cons [_ (&/$RealS output2)] (&/$Cons [_ (&/$RealS output3)] (&/$Nil))))) + (are [input output] (= input output) + 0.00123 output1 + 12.010203 output2 + -12.3 output3) + + _ + (is false "Couldn't read.") + ))) + +(deftest parse-char + (let [input1 "a" + input2 "\\n" + input3 " " + input4 "\\t" + input5 "\\b" + input6 "\\r" + input7 "\\f" + input8 "\\\"" + input9 "\\\\"] + (|case (&/run-state (|do [output1 &parser/parse + output2 &parser/parse + output3 &parser/parse + output4 &parser/parse + output5 &parser/parse + output6 &parser/parse + output7 &parser/parse + output8 &parser/parse + output9 &parser/parse] + (return (&/|++ output1 (&/|++ output2 (&/|++ output3 (&/|++ output4 (&/|++ output5 (&/|++ output6 (&/|++ output7 (&/|++ output8 output9)))))))))) + (make-state (str "#\"" input1 "\"" "\n" "#\"" input2 "\"" "\n" "#\"" input3 "\"" + "\n" "#\"" input4 "\"" "\n" "#\"" input5 "\"" "\n" "#\"" input6 "\"" + "\n" "#\"" input7 "\"" "\n" "#\"" input8 "\"" "\n" "#\"" input9 "\""))) + (&/$Right state (&/$Cons [_ (&/$CharS output1)] + (&/$Cons [_ (&/$CharS output2)] + (&/$Cons [_ (&/$CharS output3)] + (&/$Cons [_ (&/$CharS output4)] + (&/$Cons [_ (&/$CharS output5)] + (&/$Cons [_ (&/$CharS output6)] + (&/$Cons [_ (&/$CharS output7)] + (&/$Cons [_ (&/$CharS output8)] + (&/$Cons [_ (&/$CharS output9)] + (&/$Nil))))))))))) + (are [input output] (= input output) + \a output1 + \newline output2 + \space output3 + \tab output4 + \backspace output5 + \return output6 + \formfeed output7 + \" output8 + \\ output9) + + _ + (is false "Couldn't read.") + ))) + +(deftest parse-text + (let [input1 "" + input2 "abc" + input3 "yolo\\nlol\\tmeme" + input4 "This is a test\\nof multi-line text.\\n\\nI just wanna make sure it works alright..."] + (|case (&/run-state (|do [output1 &parser/parse + output2 &parser/parse + output3 &parser/parse + output4 &parser/parse] + (return (&/|++ output1 (&/|++ output2 (&/|++ output3 output4))))) + (make-state (str "\"" input1 "\"" "\n" "\"" input2 "\"" "\n" "\"" input3 "\"" "\n" "\"" input4 "\""))) + (&/$Right state (&/$Cons [_ (&/$TextS output1)] (&/$Cons [_ (&/$TextS output2)] (&/$Cons [_ (&/$TextS output3)] (&/$Cons [_ (&/$TextS output4)] (&/$Nil)))))) + (are [input output] (= input output) + input1 output1 + input2 output2 + "yolo\nlol\tmeme" output3 + "This is a test\nof multi-line text.\n\nI just wanna make sure it works alright..." output4) + + _ + (is false "Couldn't read.") + ))) + +(deftest parse-symbol + (let [input1 "foo" + input2 "test;bar0123456789" + input3 ";b1a2z3" + input4 ";;quux" + input5 "!_@$%^&*-+=.<>?/|\\~`':"] + (|case (&/run-state (|do [_ (&a-module/enter-module module-name) + output1 &parser/parse + output2 &parser/parse + output3 &parser/parse + output4 &parser/parse + output5 &parser/parse] + (return (&/|++ output1 (&/|++ output2 (&/|++ output3 (&/|++ output4 output5)))))) + (make-state (str input1 "\n" input2 "\n" input3 "\n" input4 "\n" input5 " "))) + (&/$Right state (&/$Cons [_ (&/$SymbolS output1)] + (&/$Cons [_ (&/$SymbolS output2)] + (&/$Cons [_ (&/$SymbolS output3)] + (&/$Cons [_ (&/$SymbolS output4)] + (&/$Cons [_ (&/$SymbolS output5)] + (&/$Nil))))))) + (are [input output] (&/ident= input output) + (&/T ["" "foo"]) output1 + (&/T ["test" "bar0123456789"]) output2 + (&/T ["lux" "b1a2z3"]) output3 + (&/T ["test" "quux"]) output4 + (&/T ["" "!_@$%^&*-+=.<>?/|\\~`':"]) output5) + + _ + (is false "Couldn't read.") + ))) + +(deftest parse-tag + (let [input1 "foo" + input2 "test;bar0123456789" + input3 ";b1a2z3" + input4 ";;quux" + input5 "!_@$%^&*-+=.<>?/|\\~`':"] + (|case (&/run-state (|do [_ (&a-module/enter-module module-name) + output1 &parser/parse + output2 &parser/parse + output3 &parser/parse + output4 &parser/parse + output5 &parser/parse] + (return (&/|++ output1 (&/|++ output2 (&/|++ output3 (&/|++ output4 output5)))))) + (make-state (str "#" input1 "\n" "#" input2 "\n" "#" input3 "\n" "#" input4 "\n" "#" input5 " "))) + (&/$Right state (&/$Cons [_ (&/$TagS output1)] + (&/$Cons [_ (&/$TagS output2)] + (&/$Cons [_ (&/$TagS output3)] + (&/$Cons [_ (&/$TagS output4)] + (&/$Cons [_ (&/$TagS output5)] + (&/$Nil))))))) + (are [input output] (&/ident= input output) + (&/T ["" "foo"]) output1 + (&/T ["test" "bar0123456789"]) output2 + (&/T ["lux" "b1a2z3"]) output3 + (&/T ["test" "quux"]) output4 + (&/T ["" "!_@$%^&*-+=.<>?/|\\~`':"]) output5) + + _ + (is false "Couldn't read.") + ))) + +(do-template [<name> <tag> <open> <close>] + (deftest <name> + (let [input1 "yolo 123 \"lol\" #meme"] + (|case (&/run-state &parser/parse + (make-state (str <open> input1 <close>))) + (&/$Right state (&/$Cons [_ (<tag> (&/$Cons [_ (&/$SymbolS symv)] + (&/$Cons [_ (&/$IntS intv)] + (&/$Cons [_ (&/$TextS textv)] + (&/$Cons [_ (&/$TagS tagv)] + (&/$Nil))))))] + (&/$Nil))) + (do (is (&/ident= (&/T ["" "yolo"]) symv)) + (is (= 123 intv)) + (is (= "lol" textv)) + (is (&/ident= (&/T ["" "meme"]) tagv))) + + _ + (is false "Couldn't read.") + ))) + + parse-form &/$FormS "(" ")" + parse-tuple &/$TupleS "[" "]" + ) + +(deftest parse-record + (let [input1 "yolo 123 \"lol\" #meme"] + (|case (&/run-state &parser/parse + (make-state (str "{" input1 "}"))) + (&/$Right state (&/$Cons [_ (&/$RecordS (&/$Cons [[_ (&/$SymbolS symv)] [_ (&/$IntS intv)]] + (&/$Cons [[_ (&/$TextS textv)] [_ (&/$TagS tagv)]] + (&/$Nil))))] + (&/$Nil))) + (do (is (&/ident= (&/T ["" "yolo"]) symv)) + (is (= 123 intv)) + (is (= "lol" textv)) + (is (&/ident= (&/T ["" "meme"]) tagv))) + + _ + (is false "Couldn't read.") + ))) + +(comment + (run-all-tests) + ) diff --git a/luxc/test/test/lux/reader.clj b/luxc/test/test/lux/reader.clj new file mode 100644 index 000000000..ee9cb4c35 --- /dev/null +++ b/luxc/test/test/lux/reader.clj @@ -0,0 +1,53 @@ +;; Copyright (c) Eduardo Julian. All rights reserved. +;; This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +;; If a copy of the MPL was not distributed with this file, +;; You can obtain one at http://mozilla.org/MPL/2.0/. + +(ns test.lux.reader + (:use clojure.test) + (:require (lux [base :as & :refer [|do return* return fail fail* |let |case]] + [reader :as &reader]) + :reload-all)) + +;; [Utils] +(def source (&reader/from "test" "lol\nmeme\nnyan cat\n\nlolcat")) +(def init-state (&/set$ &/$source source (&/init-state nil))) + +;; [Tests] +(deftest test-source-code-reading + (is (= 5 (&/|length source)))) + +(deftest test-text-reading + ;; Should be capable of recognizing literal texts. + (let [input "lo"] + (|case (&/run-state (&reader/read-text input) init-state) + (&/$Right state [cursor end-line? output]) + (is (= input output)) + + _ + (is false "Couldn't read.") + ))) + +(deftest test-regex-reading + ;; Should be capable of matching simple, grouping regex-patterns. + (|case (&/run-state (&reader/read-regex #"l(.)l") init-state) + (&/$Right state [cursor end-line? output]) + (is (= "lol" output)) + + _ + (is false "Couldn't read.") + )) + +(deftest test-regex+-reading + ;; Should be capable of matching multi-line regex-patterns. + (|case (&/run-state (&reader/read-regex+ #"(?is)^((?!cat).)*") init-state) + (&/$Right state [cursor output]) + (is (= "\nlol\nmeme\nnyan " output)) + + _ + (is false "Couldn't read.") + )) + +(comment + (run-all-tests) + ) diff --git a/luxc/test/test/lux/type.clj b/luxc/test/test/lux/type.clj new file mode 100644 index 000000000..1a43f7cc4 --- /dev/null +++ b/luxc/test/test/lux/type.clj @@ -0,0 +1,473 @@ +;; Copyright (c) Eduardo Julian. All rights reserved. +;; This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +;; If a copy of the MPL was not distributed with this file, +;; You can obtain one at http://mozilla.org/MPL/2.0/. + +(ns test.lux.type + (:use clojure.test) + (:require (lux [base :as & :refer [|do return* return fail fail* |let |case]] + [type :as &type]) + :reload-all + )) + +;; [Tests] +(deftest check-base-types + (|case (&/run-state (|do [_ (&type/check &/$UnitT &/$UnitT) + + _ (&type/check &/$VoidT &/$VoidT)] + (return nil)) + (&/init-state nil)) + (&/$Right state nil) + (is true) + + (&/$Left error) + (is false error) + )) + +(deftest check-simple-host-types + (|case (&/run-state (|do [_ (&type/check (&/$HostT "java.lang.Boolean" &/$Nil) + (&/$HostT "java.lang.Boolean" &/$Nil)) + + _ (&type/check (&/$HostT "java.lang.Object" &/$Nil) + (&/$HostT "java.lang.Boolean" &/$Nil))] + (return nil)) + (&/init-state nil)) + (&/$Right state nil) + (is true) + + (&/$Left error) + (is false error) + )) + +(deftest check-complex-host-types + (|case (&/run-state (|do [_ (&type/check (&/$HostT "java.util.List" (&/|list (&/$HostT "java.lang.Boolean" &/$Nil))) + (&/$HostT "java.util.List" (&/|list (&/$HostT "java.lang.Boolean" &/$Nil)))) + + _ (&type/check (&/$HostT "java.util.List" (&/|list (&/$HostT "java.lang.Object" &/$Nil))) + (&/$HostT "java.util.List" (&/|list (&/$HostT "java.lang.Boolean" &/$Nil)))) + + _ (&type/check (&/$HostT "java.util.List" (&/|list (&/$HostT "java.lang.Boolean" &/$Nil))) + (&/$HostT "java.util.ArrayList" (&/|list (&/$HostT "java.lang.Boolean" &/$Nil))))] + (return nil)) + (&/init-state nil)) + (&/$Right state nil) + (is true) + + (&/$Left error) + (is false error) + )) + +(deftest check-named-types + (|case (&/run-state (|do [_ (&type/check (&/$NamedT (&/T ["lux" "Bool"]) (&/$HostT "java.lang.Boolean" &/$Nil)) + (&/$HostT "java.lang.Boolean" &/$Nil)) + + _ (&type/check (&/$HostT "java.lang.Boolean" &/$Nil) + (&/$NamedT (&/T ["lux" "Bool"]) (&/$HostT "java.lang.Boolean" &/$Nil))) + + _ (&type/check (&/$NamedT (&/T ["lux" "Bool"]) (&/$HostT "java.lang.Boolean" &/$Nil)) + (&/$NamedT (&/T ["lux" "Bool"]) (&/$HostT "java.lang.Boolean" &/$Nil)))] + (return nil)) + (&/init-state nil)) + (&/$Right state nil) + (is true) + + (&/$Left error) + (is false error) + )) + +(deftest check-sum-types + (|case (&/run-state (|do [_ (&type/check (&/$SumT (&/$HostT "java.lang.Boolean" &/$Nil) + (&/$HostT "java.lang.Boolean" &/$Nil)) + (&/$SumT (&/$HostT "java.lang.Boolean" &/$Nil) + (&/$HostT "java.lang.Boolean" &/$Nil))) + + _ (&type/check (&/$SumT (&/$HostT "java.lang.Object" &/$Nil) + (&/$HostT "java.lang.Boolean" &/$Nil)) + (&/$SumT (&/$HostT "java.lang.Boolean" &/$Nil) + (&/$HostT "java.lang.Boolean" &/$Nil))) + + _ (&type/check (&/$SumT (&/$HostT "java.lang.Object" &/$Nil) + (&/$HostT "java.lang.Object" &/$Nil)) + (&/$SumT (&/$HostT "java.lang.Boolean" &/$Nil) + (&/$HostT "java.lang.Boolean" &/$Nil))) + + _ (&type/check (&/$SumT (&/$HostT "java.lang.Boolean" &/$Nil) + (&/$SumT (&/$HostT "java.lang.Boolean" &/$Nil) + (&/$HostT "java.lang.Boolean" &/$Nil))) + (&/$SumT (&/$HostT "java.lang.Boolean" &/$Nil) + (&/$SumT (&/$HostT "java.lang.Boolean" &/$Nil) + (&/$HostT "java.lang.Boolean" &/$Nil)))) + + _ (&type/check (&/$SumT (&/$HostT "java.lang.Object" &/$Nil) + (&/$SumT (&/$HostT "java.lang.Boolean" &/$Nil) + (&/$HostT "java.lang.Boolean" &/$Nil))) + (&/$SumT (&/$HostT "java.lang.Boolean" &/$Nil) + (&/$SumT (&/$HostT "java.lang.Boolean" &/$Nil) + (&/$HostT "java.lang.Boolean" &/$Nil)))) + + _ (&type/check (&/$SumT (&/$HostT "java.lang.Object" &/$Nil) + (&/$SumT (&/$HostT "java.lang.Boolean" &/$Nil) + (&/$HostT "java.lang.Object" &/$Nil))) + (&/$SumT (&/$HostT "java.lang.Boolean" &/$Nil) + (&/$SumT (&/$HostT "java.lang.Boolean" &/$Nil) + (&/$HostT "java.lang.Boolean" &/$Nil))))] + (return nil)) + (&/init-state nil)) + (&/$Right state nil) + (is true) + + (&/$Left error) + (is false error) + )) + +(deftest check-prod-types + (|case (&/run-state (|do [_ (&type/check (&/$ProdT (&/$HostT "java.lang.Boolean" &/$Nil) + (&/$HostT "java.lang.Boolean" &/$Nil)) + (&/$ProdT (&/$HostT "java.lang.Boolean" &/$Nil) + (&/$HostT "java.lang.Boolean" &/$Nil))) + + _ (&type/check (&/$ProdT (&/$HostT "java.lang.Object" &/$Nil) + (&/$HostT "java.lang.Boolean" &/$Nil)) + (&/$ProdT (&/$HostT "java.lang.Boolean" &/$Nil) + (&/$HostT "java.lang.Boolean" &/$Nil))) + + _ (&type/check (&/$ProdT (&/$HostT "java.lang.Object" &/$Nil) + (&/$HostT "java.lang.Object" &/$Nil)) + (&/$ProdT (&/$HostT "java.lang.Boolean" &/$Nil) + (&/$HostT "java.lang.Boolean" &/$Nil))) + + _ (&type/check (&/$ProdT (&/$HostT "java.lang.Boolean" &/$Nil) + (&/$ProdT (&/$HostT "java.lang.Boolean" &/$Nil) + (&/$HostT "java.lang.Boolean" &/$Nil))) + (&/$ProdT (&/$HostT "java.lang.Boolean" &/$Nil) + (&/$ProdT (&/$HostT "java.lang.Boolean" &/$Nil) + (&/$HostT "java.lang.Boolean" &/$Nil)))) + + _ (&type/check (&/$ProdT (&/$HostT "java.lang.Object" &/$Nil) + (&/$ProdT (&/$HostT "java.lang.Boolean" &/$Nil) + (&/$HostT "java.lang.Boolean" &/$Nil))) + (&/$ProdT (&/$HostT "java.lang.Boolean" &/$Nil) + (&/$ProdT (&/$HostT "java.lang.Boolean" &/$Nil) + (&/$HostT "java.lang.Boolean" &/$Nil)))) + + _ (&type/check (&/$ProdT (&/$HostT "java.lang.Object" &/$Nil) + (&/$ProdT (&/$HostT "java.lang.Boolean" &/$Nil) + (&/$HostT "java.lang.Object" &/$Nil))) + (&/$ProdT (&/$HostT "java.lang.Boolean" &/$Nil) + (&/$ProdT (&/$HostT "java.lang.Boolean" &/$Nil) + (&/$HostT "java.lang.Boolean" &/$Nil))))] + (return nil)) + (&/init-state nil)) + (&/$Right state nil) + (is true) + + (&/$Left error) + (is false error) + )) + +(deftest check-lambda-types + (|case (&/run-state (|do [_ (&type/check (&/$LambdaT (&/$HostT "java.lang.Boolean" &/$Nil) + (&/$HostT "java.lang.Boolean" &/$Nil)) + (&/$LambdaT (&/$HostT "java.lang.Boolean" &/$Nil) + (&/$HostT "java.lang.Boolean" &/$Nil))) + + _ (&type/check (&/$LambdaT (&/$HostT "java.lang.Boolean" &/$Nil) + (&/$HostT "java.lang.Boolean" &/$Nil)) + (&/$LambdaT (&/$HostT "java.lang.Object" &/$Nil) + (&/$HostT "java.lang.Boolean" &/$Nil))) + + _ (&type/check (&/$LambdaT (&/$HostT "java.lang.Boolean" &/$Nil) + (&/$HostT "java.lang.Object" &/$Nil)) + (&/$LambdaT (&/$HostT "java.lang.Object" &/$Nil) + (&/$HostT "java.lang.Boolean" &/$Nil))) + + _ (&type/check (&/$LambdaT (&/$HostT "java.lang.Boolean" &/$Nil) + (&/$LambdaT (&/$HostT "java.lang.Boolean" &/$Nil) + (&/$HostT "java.lang.Boolean" &/$Nil))) + (&/$LambdaT (&/$HostT "java.lang.Boolean" &/$Nil) + (&/$LambdaT (&/$HostT "java.lang.Boolean" &/$Nil) + (&/$HostT "java.lang.Boolean" &/$Nil)))) + + _ (&type/check (&/$LambdaT (&/$HostT "java.lang.Boolean" &/$Nil) + (&/$LambdaT (&/$HostT "java.lang.Boolean" &/$Nil) + (&/$HostT "java.lang.Boolean" &/$Nil))) + (&/$LambdaT (&/$HostT "java.lang.Object" &/$Nil) + (&/$LambdaT (&/$HostT "java.lang.Boolean" &/$Nil) + (&/$HostT "java.lang.Boolean" &/$Nil)))) + + _ (&type/check (&/$LambdaT (&/$HostT "java.lang.Boolean" &/$Nil) + (&/$LambdaT (&/$HostT "java.lang.Boolean" &/$Nil) + (&/$HostT "java.lang.Object" &/$Nil))) + (&/$LambdaT (&/$HostT "java.lang.Object" &/$Nil) + (&/$LambdaT (&/$HostT "java.lang.Boolean" &/$Nil) + (&/$HostT "java.lang.Boolean" &/$Nil)))) + ] + (return nil)) + (&/init-state nil)) + (&/$Right state nil) + (is true) + + (&/$Left error) + (is false error) + )) + +(deftest check-ex-types + (|case (&/run-state (|do [_ (&type/check (&/$ExT 0) (&/$ExT 0))] + (return nil)) + (&/init-state nil)) + (&/$Right state nil) + (is true) + + (&/$Left error) + (is false error) + )) + +(deftest check-univ-quantification + (|case (&/run-state (|do [_ (&type/check (&/$UnivQ (&/|list) + (&/$LambdaT &/$VoidT (&/$BoundT 1))) + (&/$UnivQ (&/|list) + (&/$LambdaT &/$VoidT (&/$BoundT 1)))) + + _ (&type/check (&/$UnivQ (&/|list) + (&/$SumT + ;; lux;None + &/$UnitT + ;; lux;Some + (&/$BoundT 1))) + (&/$UnivQ (&/|list) + (&/$SumT + ;; lux;None + &/$UnitT + ;; lux;Some + (&/$BoundT 1)))) + + _ (&type/check (&/$UnivQ (&/|list) + (&/$SumT + ;; lux;Nil + &/$UnitT + ;; lux;Cons + (&/$ProdT (&/$BoundT 1) + (&/$AppT (&/$BoundT 0) + (&/$BoundT 1))))) + (&/$UnivQ (&/|list) + (&/$SumT + ;; lux;Nil + &/$UnitT + ;; lux;Cons + (&/$ProdT (&/$BoundT 1) + (&/$AppT (&/$BoundT 0) + (&/$BoundT 1))))))] + (return nil)) + (&/init-state nil)) + (&/$Right state nil) + (is true) + + (&/$Left error) + (is false error) + )) + +(deftest check-ex-quantification + (|case (&/run-state (|do [_ (&type/check (&/$ExQ (&/|list) + (&/$LambdaT &/$VoidT (&/$BoundT 1))) + (&/$ExQ (&/|list) + (&/$LambdaT &/$VoidT (&/$BoundT 1)))) + + _ (&type/check (&/$ExQ (&/|list) + (&/$SumT + ;; lux;None + &/$UnitT + ;; lux;Some + (&/$BoundT 1))) + (&/$ExQ (&/|list) + (&/$SumT + ;; lux;None + &/$UnitT + ;; lux;Some + (&/$BoundT 1)))) + + _ (&type/check (&/$ExQ (&/|list) + (&/$SumT + ;; lux;Nil + &/$UnitT + ;; lux;Cons + (&/$ProdT (&/$BoundT 1) + (&/$AppT (&/$BoundT 0) + (&/$BoundT 1))))) + (&/$ExQ (&/|list) + (&/$SumT + ;; lux;Nil + &/$UnitT + ;; lux;Cons + (&/$ProdT (&/$BoundT 1) + (&/$AppT (&/$BoundT 0) + (&/$BoundT 1))))))] + (return nil)) + (&/init-state nil)) + (&/$Right state nil) + (is true) + + (&/$Left error) + (is false error) + )) + +(deftest check-app-type + (|case (&/run-state (|do [_ (&type/check (&/$AppT (&/$UnivQ (&/|list) + (&/$LambdaT &/$VoidT (&/$BoundT 1))) + (&/$HostT "java.lang.Boolean" &/$Nil)) + (&/$AppT (&/$UnivQ (&/|list) + (&/$LambdaT &/$VoidT (&/$BoundT 1))) + (&/$HostT "java.lang.Boolean" &/$Nil))) + + _ (&type/check (&/$AppT (&/$UnivQ (&/|list) + (&/$SumT + ;; lux;None + &/$UnitT + ;; lux;Some + (&/$BoundT 1))) + (&/$HostT "java.lang.Object" &/$Nil)) + (&/$AppT (&/$UnivQ (&/|list) + (&/$SumT + ;; lux;None + &/$UnitT + ;; lux;Some + (&/$BoundT 1))) + (&/$HostT "java.lang.Boolean" &/$Nil))) + + _ (&type/check (&/$AppT (&/$ExQ (&/|list) + (&/$LambdaT &/$VoidT (&/$BoundT 1))) + (&/$HostT "java.lang.Boolean" &/$Nil)) + (&/$AppT (&/$ExQ (&/|list) + (&/$LambdaT &/$VoidT (&/$BoundT 1))) + (&/$HostT "java.lang.Boolean" &/$Nil))) + + _ (&type/check (&/$AppT (&/$ExQ (&/|list) + (&/$SumT + ;; lux;None + &/$UnitT + ;; lux;Some + (&/$BoundT 1))) + (&/$HostT "java.lang.Object" &/$Nil)) + (&/$AppT (&/$ExQ (&/|list) + (&/$SumT + ;; lux;None + &/$UnitT + ;; lux;Some + (&/$BoundT 1))) + (&/$HostT "java.lang.Boolean" &/$Nil)))] + (return nil)) + (&/init-state nil)) + (&/$Right state nil) + (is true) + + (&/$Left error) + (is false error) + )) + +(deftest check-var-type + (|case (&/run-state (|do [_ (&type/with-var + (fn [$var] + (|do [_ (&type/check $var (&/$HostT "java.lang.Boolean" &/$Nil)) + (&/$HostT "java.lang.Boolean" (&/$Nil)) (&type/deref+ $var)] + (return nil)))) + + _ (&type/with-var + (fn [$var] + (|do [_ (&type/check (&/$AppT (&/$UnivQ (&/|list) + (&/$LambdaT &/$VoidT (&/$BoundT 1))) + $var) + (&/$AppT (&/$UnivQ (&/|list) + (&/$LambdaT &/$VoidT (&/$BoundT 1))) + (&/$HostT "java.lang.Boolean" &/$Nil))) + (&/$HostT "java.lang.Boolean" (&/$Nil)) (&type/deref+ $var)] + (return nil)))) + + _ (&type/with-var + (fn [$var] + (|do [_ (&type/check (&/$HostT "java.lang.Boolean" &/$Nil) $var) + (&/$HostT "java.lang.Boolean" (&/$Nil)) (&type/deref+ $var)] + (return nil)))) + + _ (&type/with-var + (fn [$var] + (|do [_ (&type/check (&/$AppT (&/$UnivQ (&/|list) + (&/$LambdaT &/$VoidT (&/$BoundT 1))) + (&/$HostT "java.lang.Boolean" &/$Nil)) + (&/$AppT (&/$UnivQ (&/|list) + (&/$LambdaT &/$VoidT (&/$BoundT 1))) + $var)) + (&/$HostT "java.lang.Boolean" (&/$Nil)) (&type/deref+ $var)] + (return nil)))) + + _ (&type/with-var + (fn [$var1] + (&type/with-var + (fn [$var2] + (|do [_ (&type/check $var1 $var2)] + (return nil)))))) + + _ (&type/with-var + (fn [$var1] + (&type/with-var + (fn [$var2] + (|do [_ (&type/check $var2 $var1)] + (return nil)))))) + + _ (&type/with-var + (fn [$var1] + (&type/with-var + (fn [$var2] + (|do [_ (&type/check $var1 $var2) + _ (&type/check $var1 (&/$HostT "java.lang.Boolean" (&/|list))) + =var1 (&type/deref+ $var1) + _ (&/assert! (&type/type= =var1 $var2) "") + =var2 (&type/deref+ $var2) + _ (&/assert! (&type/type= =var2 (&/$HostT "java.lang.Boolean" (&/|list))) "")] + (return nil)))))) + + _ (&type/with-var + (fn [$var1] + (&type/with-var + (fn [$var2] + (|do [_ (&type/check $var2 $var1) + _ (&type/check $var1 (&/$HostT "java.lang.Boolean" (&/|list))) + =var2 (&type/deref+ $var2) + _ (&/assert! (&type/type= =var2 $var1) "") + =var1 (&type/deref+ $var1) + _ (&/assert! (&type/type= =var1 (&/$HostT "java.lang.Boolean" (&/|list))) "")] + (return nil)))))) + + _ (&type/with-var + (fn [$var1] + (&type/with-var + (fn [$var2] + (|do [_ (&type/check $var1 $var2) + _ (&type/check $var2 (&/$HostT "java.lang.Boolean" (&/|list))) + =var1 (&type/deref+ $var1) + _ (&/assert! (&type/type= =var1 $var2) "") + =var2 (&type/deref+ $var2) + _ (&/assert! (&type/type= =var2 (&/$HostT "java.lang.Boolean" (&/|list))) "")] + (return nil)))))) + + _ (&type/with-var + (fn [$var1] + (&type/with-var + (fn [$var2] + (|do [_ (&type/check $var2 $var1) + _ (&type/check $var2 (&/$HostT "java.lang.Boolean" (&/|list))) + =var2 (&type/deref+ $var2) + _ (&/assert! (&type/type= =var2 $var1) "") + =var1 (&type/deref+ $var1) + _ (&/assert! (&type/type= =var1 (&/$HostT "java.lang.Boolean" (&/|list))) "")] + (return nil))))))] + (return nil)) + (&/init-state nil)) + (&/$Right state nil) + (is true) + + (&/$Left error) + (is false error) + )) + +(comment + (run-all-tests) + ) |