diff options
| author | Eduardo Julian | 2016-12-01 11:00:44 -0400 |
|---|---|---|
| committer | Eduardo Julian | 2016-12-01 11:00:44 -0400 |
| commit | 7f66c54f4c9753b94dbf46ec50b8b16549daf324 (patch) | |
| tree | 1b5b896cfba870a66a99a03315b09df842eb5737 /luxc/src | |
| parent | 9c30546af022f8fe36b73e7e93414257ff28ee75 (diff) | |
- Collected the Lux compiler's repo, the Standard Library's, the Leiningen plugin's and the Emacs mode's into a big monorepo, to keep development unified.
Diffstat (limited to 'luxc/src')
35 files changed, 14025 insertions, 0 deletions
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 + ))) |