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 /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 'src')
35 files changed, 0 insertions, 14011 deletions
diff --git a/src/lux.clj b/src/lux.clj deleted file mode 100644 index e6fc3f4cc..000000000 --- a/src/lux.clj +++ /dev/null @@ -1,38 +0,0 @@ -;; 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."))) diff --git a/src/lux/analyser.clj b/src/lux/analyser.clj deleted file mode 100644 index 4133927e7..000000000 --- a/src/lux/analyser.clj +++ /dev/null @@ -1,211 +0,0 @@ -;; 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/src/lux/analyser/base.clj b/src/lux/analyser/base.clj deleted file mode 100644 index 9bdcdeb11..000000000 --- a/src/lux/analyser/base.clj +++ /dev/null @@ -1,131 +0,0 @@ -;; 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/src/lux/analyser/case.clj b/src/lux/analyser/case.clj deleted file mode 100644 index 6841577a8..000000000 --- a/src/lux/analyser/case.clj +++ /dev/null @@ -1,654 +0,0 @@ -;; 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/src/lux/analyser/env.clj b/src/lux/analyser/env.clj deleted file mode 100644 index 75e066e34..000000000 --- a/src/lux/analyser/env.clj +++ /dev/null @@ -1,74 +0,0 @@ -;; 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/src/lux/analyser/host.clj b/src/lux/analyser/host.clj deleted file mode 100644 index 209e36d0e..000000000 --- a/src/lux/analyser/host.clj +++ /dev/null @@ -1,1379 +0,0 @@ -;; 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/src/lux/analyser/lambda.clj b/src/lux/analyser/lambda.clj deleted file mode 100644 index b47b803d0..000000000 --- a/src/lux/analyser/lambda.clj +++ /dev/null @@ -1,33 +0,0 @@ -;; 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/src/lux/analyser/lux.clj b/src/lux/analyser/lux.clj deleted file mode 100644 index 1d46c2b60..000000000 --- a/src/lux/analyser/lux.clj +++ /dev/null @@ -1,736 +0,0 @@ -;; 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/src/lux/analyser/meta.clj b/src/lux/analyser/meta.clj deleted file mode 100644 index 831386f47..000000000 --- a/src/lux/analyser/meta.clj +++ /dev/null @@ -1,46 +0,0 @@ -;; 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/src/lux/analyser/module.clj b/src/lux/analyser/module.clj deleted file mode 100644 index 62948bf0d..000000000 --- a/src/lux/analyser/module.clj +++ /dev/null @@ -1,403 +0,0 @@ -;; 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/src/lux/analyser/parser.clj b/src/lux/analyser/parser.clj deleted file mode 100644 index e60f28a02..000000000 --- a/src/lux/analyser/parser.clj +++ /dev/null @@ -1,469 +0,0 @@ -;; 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/src/lux/analyser/record.clj b/src/lux/analyser/record.clj deleted file mode 100644 index 81332b34c..000000000 --- a/src/lux/analyser/record.clj +++ /dev/null @@ -1,47 +0,0 @@ -;; 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/src/lux/base.clj b/src/lux/base.clj deleted file mode 100644 index 5697415f8..000000000 --- a/src/lux/base.clj +++ /dev/null @@ -1,1449 +0,0 @@ -;; 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/src/lux/compiler.clj b/src/lux/compiler.clj deleted file mode 100644 index d8c5e4571..000000000 --- a/src/lux/compiler.clj +++ /dev/null @@ -1,268 +0,0 @@ -;; 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/src/lux/compiler/base.clj b/src/lux/compiler/base.clj deleted file mode 100644 index e57571fef..000000000 --- a/src/lux/compiler/base.clj +++ /dev/null @@ -1,116 +0,0 @@ -;; 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/src/lux/compiler/cache.clj b/src/lux/compiler/cache.clj deleted file mode 100644 index 6c44e2a45..000000000 --- a/src/lux/compiler/cache.clj +++ /dev/null @@ -1,188 +0,0 @@ -;; 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/src/lux/compiler/cache/ann.clj b/src/lux/compiler/cache/ann.clj deleted file mode 100644 index d50c02465..000000000 --- a/src/lux/compiler/cache/ann.clj +++ /dev/null @@ -1,159 +0,0 @@ -;; 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/src/lux/compiler/cache/type.clj b/src/lux/compiler/cache/type.clj deleted file mode 100644 index 80d3a93d6..000000000 --- a/src/lux/compiler/cache/type.clj +++ /dev/null @@ -1,164 +0,0 @@ -;; 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/src/lux/compiler/case.clj b/src/lux/compiler/case.clj deleted file mode 100644 index afdcd3eed..000000000 --- a/src/lux/compiler/case.clj +++ /dev/null @@ -1,219 +0,0 @@ -;; 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/src/lux/compiler/host.clj b/src/lux/compiler/host.clj deleted file mode 100644 index 9f6d077be..000000000 --- a/src/lux/compiler/host.clj +++ /dev/null @@ -1,2514 +0,0 @@ -;; 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/src/lux/compiler/io.clj b/src/lux/compiler/io.clj deleted file mode 100644 index ecb2066cd..000000000 --- a/src/lux/compiler/io.clj +++ /dev/null @@ -1,36 +0,0 @@ -;; 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/src/lux/compiler/lambda.clj b/src/lux/compiler/lambda.clj deleted file mode 100644 index c0096523f..000000000 --- a/src/lux/compiler/lambda.clj +++ /dev/null @@ -1,286 +0,0 @@ -;; 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/src/lux/compiler/lux.clj b/src/lux/compiler/lux.clj deleted file mode 100644 index 5dc8becc0..000000000 --- a/src/lux/compiler/lux.clj +++ /dev/null @@ -1,498 +0,0 @@ -;; 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/src/lux/compiler/module.clj b/src/lux/compiler/module.clj deleted file mode 100644 index 03bc311f2..000000000 --- a/src/lux/compiler/module.clj +++ /dev/null @@ -1,28 +0,0 @@ -;; 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/src/lux/compiler/parallel.clj b/src/lux/compiler/parallel.clj deleted file mode 100644 index 8f6fee99d..000000000 --- a/src/lux/compiler/parallel.clj +++ /dev/null @@ -1,47 +0,0 @@ -;; 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/src/lux/host.clj b/src/lux/host.clj deleted file mode 100644 index 39e659964..000000000 --- a/src/lux/host.clj +++ /dev/null @@ -1,432 +0,0 @@ -;; 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/src/lux/host/generics.clj b/src/lux/host/generics.clj deleted file mode 100644 index cfd0d2d54..000000000 --- a/src/lux/host/generics.clj +++ /dev/null @@ -1,205 +0,0 @@ -;; 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/src/lux/lexer.clj b/src/lux/lexer.clj deleted file mode 100644 index f519aa563..000000000 --- a/src/lux/lexer.clj +++ /dev/null @@ -1,254 +0,0 @@ -;; 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/src/lux/lib/loader.clj b/src/lux/lib/loader.clj deleted file mode 100644 index e8310f9f0..000000000 --- a/src/lux/lib/loader.clj +++ /dev/null @@ -1,54 +0,0 @@ -;; 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/src/lux/optimizer.clj b/src/lux/optimizer.clj deleted file mode 100644 index 5c30dc44f..000000000 --- a/src/lux/optimizer.clj +++ /dev/null @@ -1,1202 +0,0 @@ -;; 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/src/lux/parser.clj b/src/lux/parser.clj deleted file mode 100644 index ceafcd92e..000000000 --- a/src/lux/parser.clj +++ /dev/null @@ -1,117 +0,0 @@ -;; 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/src/lux/reader.clj b/src/lux/reader.clj deleted file mode 100644 index 5a7734061..000000000 --- a/src/lux/reader.clj +++ /dev/null @@ -1,141 +0,0 @@ -;; 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/src/lux/repl.clj b/src/lux/repl.clj deleted file mode 100644 index 195f3dc3e..000000000 --- a/src/lux/repl.clj +++ /dev/null @@ -1,89 +0,0 @@ -;; 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/src/lux/type.clj b/src/lux/type.clj deleted file mode 100644 index d387053dc..000000000 --- a/src/lux/type.clj +++ /dev/null @@ -1,972 +0,0 @@ -;; 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/src/lux/type/host.clj b/src/lux/type/host.clj deleted file mode 100644 index 462e1aebe..000000000 --- a/src/lux/type/host.clj +++ /dev/null @@ -1,352 +0,0 @@ -;; 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 - ))) |