diff options
| author | Eduardo Julian | 2020-12-04 01:13:01 -0400 |
|---|---|---|
| committer | Eduardo Julian | 2020-12-04 01:13:01 -0400 |
| commit | 8df63aae42c40ac0413ccfacc3b2e8eb72e00a15 (patch) | |
| tree | 5e1eb6833398b8a67a2e3d0db4a615204a25f80f /luxc/src | |
| parent | 0205e5146b50ab066d152fccda0fc8cef4eef852 (diff) | |
Re-named old luxc-jvm to lux-bootstrapper.
Diffstat (limited to 'luxc/src')
39 files changed, 0 insertions, 13380 deletions
diff --git a/luxc/src/lux.clj b/luxc/src/lux.clj deleted file mode 100644 index dc6066669..000000000 --- a/luxc/src/lux.clj +++ /dev/null @@ -1,35 +0,0 @@ -(ns lux - (:gen-class) - (:require [lux.base :as & :refer [|let |do return return* |case]] - [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- separate-paths - "(-> Text (List Text))" - [paths] - (-> paths - (string/replace unit-separator "\n") - string/split-lines - rest - &/->list)) - -(defn -main [& args] - (|case (&/->list args) - (&/$Cons "release" (&/$Cons program-module (&/$Cons dependencies (&/$Cons source-dirs (&/$Cons target-dir (&/$Nil)))))) - (&compiler/compile-program &/$Build program-module - (separate-paths dependencies) - (separate-paths source-dirs) - target-dir) - - (&/$Cons "repl" (&/$Cons dependencies (&/$Cons source-dirs (&/$Cons target-dir (&/$Nil))))) - (&repl/repl (separate-paths dependencies) - (separate-paths source-dirs) - target-dir) - - _ - (println "Cannot understand command."))) diff --git a/luxc/src/lux/analyser.clj b/luxc/src/lux/analyser.clj deleted file mode 100644 index af272fa91..000000000 --- a/luxc/src/lux/analyser.clj +++ /dev/null @@ -1,233 +0,0 @@ -(ns lux.analyser - (:require (clojure [template :refer [do-template]]) - clojure.core.match - clojure.core.match.array - (lux [base :as & :refer [|let |do return return* |case]] - [reader :as &reader] - [parser :as &parser] - [type :as &type] - [host :as &host]) - (lux.analyser [base :as &&] - [lux :as &&lux] - [module :as &&module] - [parser :as &&a-parser]) - (lux.analyser.proc [common :as &&common] - [jvm :as &&jvm]))) - -;; [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 [_location &/location] - (analyse exo-type (&/T [_location (&/$Tuple values)]))) - (|case exo-type - (&/$Var 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-location] 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-location 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-location] ?output-term] (&&/analyse-1 analyser ?var syntax)] - (|case [?var ?output-type] - [(&/$Var ?e-id) (&/$Var ?a-id)] - (if (= ?e-id ?a-id) - (|do [=output-type (&type/clean ?var ?output-type)] - (return (&&/|meta =output-type ?output-location ?output-term))) - (|do [=output-type (&type/clean ?var ?var)] - (return (&&/|meta =output-type ?output-location ?output-term)))) - - [_ _] - (|do [=output-type (&type/clean ?var ?output-type)] - (return (&&/|meta =output-type ?output-location ?output-term)))) - )))) - -(defn ^:private analyse-ast [optimize eval! compile-module ^"[Ljava.lang.Object;" compilers exo-type ?token] - (|let [analyse (partial analyse-ast optimize eval! compile-module compilers) - [location token] ?token - compile-def (aget compilers 0) - compile-program (aget compilers 1) - macro-caller (aget compilers 2)] - (|case token - ;; Standard special forms - (&/$Bit ?value) - (|do [_ (&type/check exo-type &type/Bit)] - (return (&/|list (&&/|meta exo-type location (&&/$bit ?value))))) - - (&/$Nat ?value) - (|do [_ (&type/check exo-type &type/Nat)] - (return (&/|list (&&/|meta exo-type location (&&/$nat ?value))))) - - (&/$Int ?value) - (|do [_ (&type/check exo-type &type/Int)] - (return (&/|list (&&/|meta exo-type location (&&/$int ?value))))) - - (&/$Rev ?value) - (|do [_ (&type/check exo-type &type/Rev)] - (return (&/|list (&&/|meta exo-type location (&&/$rev ?value))))) - - (&/$Frac ?value) - (|do [_ (&type/check exo-type &type/Frac)] - (return (&/|list (&&/|meta exo-type location (&&/$frac ?value))))) - - (&/$Text ?value) - (|do [_ (&type/check exo-type &type/Text)] - (return (&/|list (&&/|meta exo-type location (&&/$text ?value))))) - - (&/$Tuple ?elems) - (&/with-analysis-meta location exo-type - (&&lux/analyse-tuple analyse (&/$Right exo-type) ?elems)) - - (&/$Record ?elems) - (&/with-analysis-meta location exo-type - (&&lux/analyse-record analyse exo-type ?elems)) - - (&/$Tag ?ident) - (&/with-analysis-meta location exo-type - (analyse-variant+ analyse exo-type ?ident &/$Nil)) - - (&/$Identifier ?ident) - (&/with-analysis-meta location exo-type - (&&lux/analyse-identifier analyse exo-type ?ident)) - - (&/$Form (&/$Cons [command-meta command] parameters)) - (|case command - (&/$Text ?procedure) - (case ?procedure - "lux check" - (|let [(&/$Cons ?type - (&/$Cons ?value - (&/$Nil))) parameters] - (&/with-analysis-meta location exo-type - (&&lux/analyse-ann analyse eval! exo-type ?type ?value))) - - "lux check type" - (|let [(&/$Cons ?value (&/$Nil)) parameters] - (analyse-ast optimize eval! compile-module compilers &type/Type ?value)) - - "lux coerce" - (|let [(&/$Cons ?type - (&/$Cons ?value - (&/$Nil))) parameters] - (&/with-analysis-meta location exo-type - (&&lux/analyse-coerce analyse eval! exo-type ?type ?value))) - - "lux def" - (|let [(&/$Cons [_ (&/$Identifier "" ?name)] - (&/$Cons ?value - (&/$Cons ?meta - (&/$Cons [_ (&/$Bit exported?)] - (&/$Nil))) - )) parameters] - (&/with-location location - (&&lux/analyse-def analyse optimize eval! compile-def ?name ?value ?meta exported?))) - - "lux def alias" - (|let [(&/$Cons [_ (&/$Identifier "" ?alias)] - (&/$Cons [_ (&/$Identifier ?original)] - (&/$Nil) - )) parameters] - (&/with-location location - (&&lux/analyse-def-alias ?alias ?original))) - - "lux def type tagged" - (|let [(&/$Cons [_ (&/$Identifier "" ?name)] - (&/$Cons ?value - (&/$Cons ?meta - (&/$Cons [_ (&/$Tuple ?tags)] - (&/$Cons [_ (&/$Bit exported?)] - (&/$Nil)))) - )) parameters] - (&/with-location location - (&&lux/analyse-def-type-tagged analyse optimize eval! compile-def ?name ?value ?meta ?tags exported?))) - - "lux def program" - (|let [(&/$Cons ?program (&/$Nil)) parameters] - (&/with-location location - (&&lux/analyse-program analyse optimize compile-program ?program))) - - "lux def module" - (|let [(&/$Cons ?meta (&/$Cons ?imports (&/$Nil))) parameters] - (&/with-location location - (&&lux/analyse-module analyse optimize eval! compile-module ?meta ?imports))) - - "lux in-module" - (|let [(&/$Cons [_ (&/$Text ?module)] (&/$Cons ?expr (&/$Nil))) parameters] - (&/with-location location - (&/with-module ?module - (analyse exo-type ?expr)))) - - ;; else - (&/with-analysis-meta location exo-type - (cond (.startsWith ^String ?procedure "jvm") - (|do [_ &/jvm-host] - (&&jvm/analyse-host analyse exo-type compilers ?procedure parameters)) - - :else - (&&common/analyse-proc analyse exo-type ?procedure parameters)))) - - (&/$Nat idx) - (|let [(&/$Cons [_ (&/$Bit ?right)] parameters*) parameters] - (&/with-analysis-meta location exo-type - (&&lux/analyse-variant analyse (&/$Right exo-type) (if ?right (inc idx) idx) ?right parameters*))) - - (&/$Tag ?ident) - (&/with-analysis-meta location exo-type - (analyse-variant+ analyse exo-type ?ident parameters)) - - ;; Pattern-matching syntax. - (&/$Record ?pattern-matching) - (|let [(&/$Cons ?input (&/$Nil)) parameters] - (&/with-analysis-meta location exo-type - (&&lux/analyse-case analyse exo-type ?input ?pattern-matching))) - - ;; Function syntax. - (&/$Tuple (&/$Cons [_ (&/$Identifier "" ?self)] - (&/$Cons [_ (&/$Identifier "" ?arg)] (&/$Nil)))) - (|let [(&/$Cons ?body (&/$Nil)) parameters] - (&/with-analysis-meta location exo-type - (&&lux/analyse-function analyse exo-type ?self ?arg ?body))) - - _ - (&/with-location location - (|do [=fn (just-analyse analyse (&/T [command-meta command]))] - (&&lux/analyse-apply analyse location exo-type macro-caller =fn parameters)))) - - _ - (&/fail-with-loc (str "[Analyser Error] Unknown syntax: " (&/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 &type/Nothing) asts))) - -(defn clean-output [?var analysis] - (|do [:let [[[?output-type ?output-location] ?output-term] analysis] - =output-type (&type/clean ?var ?output-type)] - (return (&&/|meta =output-type ?output-location ?output-term)))) - -(defn repl-analyse [optimize eval! compile-module compilers] - (|do [asts &parser/parse] - (&/flat-map% (fn [ast] - (&type/with-var - (fn [?var] - (|do [=outputs (&/with-closure - (analyse-ast optimize eval! compile-module compilers ?var ast))] - (&/map% (partial clean-output ?var) =outputs))))) - asts))) diff --git a/luxc/src/lux/analyser/base.clj b/luxc/src/lux/analyser/base.clj deleted file mode 100644 index d6787280f..000000000 --- a/luxc/src/lux/analyser/base.clj +++ /dev/null @@ -1,127 +0,0 @@ -(ns lux.analyser.base - (:require clojure.core.match - clojure.core.match.array - (lux [base :as & :refer [defvariant |let |do return* return |case]] - [type :as &type]))) - -;; [Tags] -(defvariant - ("bit" 1) - ("nat" 1) - ("int" 1) - ("rev" 1) - ("frac" 1) - ("text" 1) - ("variant" 3) - ("tuple" 1) - ("apply" 2) - ("case" 2) - ("function" 4) - ("ann" 2) - ("def" 1) - ("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 location] adt] analysis] - (&/T [(&/T [new-type location]) adt]))) - -(defn clean-analysis - "(-> Type Analysis (Lux Analysis))" - [$var an] - (|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-with-loc "[Analyser Error] Macro cannot expand to more than 1 output.")))) - -(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 #{"Primitive" "Sum" "Product" "Function" "Parameter" "Var" "Ex" "UnivQ" "ExQ" "Apply" "Named"}] - (defn type-tag? [module name] - (and (= "lux" module) - (contains? tag-names name)))) - -(defn |meta [type location analysis] - (&/T [(&/T [type location]) 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)) - - ($function _register-offset scope captured body) - ($function _register-offset scope - (&/|map (fn [branch] - (|let [[_name _captured] branch] - (&/T [_name (de-meta _captured)]))) - captured) - (de-meta body)) - - ($ann value-expr type-expr) - (de-meta value-expr) - - ($captured scope idx source) - ($captured scope idx (de-meta source)) - - ($proc proc-ident args special-args) - ($proc proc-ident (&/|map de-meta args) special-args) - - _ - analysis- - ))) diff --git a/luxc/src/lux/analyser/case.clj b/luxc/src/lux/analyser/case.clj deleted file mode 100644 index d059ce189..000000000 --- a/luxc/src/lux/analyser/case.clj +++ /dev/null @@ -1,637 +0,0 @@ -(ns lux.analyser.case - (:require clojure.core.match - clojure.core.match.array - (lux [base :as & :refer [defvariant |do return |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) - ("BitTotal" 2) - ("NatTotal" 2) - ("IntTotal" 2) - ("RevTotal" 2) - ("FracTotal" 2) - ("TextTotal" 2) - ("TupleTotal" 2) - ("VariantTotal" 2)) - -(defvariant - ("NoTestAC" 0) - ("StoreTestAC" 1) - ("BitTestAC" 1) - ("NatTestAC" 1) - ("IntTestAC" 1) - ("RevTestAC" 1) - ("FracTestAC" 1) - ("TextTestAC" 1) - ("TupleTestAC" 1) - ("VariantTestAC" 1)) - -;; [Utils] -(def ^:private unit-tuple - (&/T [(&/T ["" -1 -1]) (&/$Tuple &/$Nil)])) - -(defn ^:private resolve-type [type] - (if (&type/type= &type/Any type) - (return type) - (|case type - (&/$Var ?id) - (|do [type* (&/try-all% (&/|list (&type/deref ?id) - (&/fail-with-loc "##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 parameter-idx type] - (|case type - (&/$Var ?id) - (if (= ?tid ?id) - (&/$Parameter (+ (* 2 level) parameter-idx)) - type) - - (&/$Primitive ?name ?params) - (&/$Primitive ?name (&/|map (partial clean! level ?tid parameter-idx) - ?params)) - - (&/$Function ?arg ?return) - (&/$Function (clean! level ?tid parameter-idx ?arg) - (clean! level ?tid parameter-idx ?return)) - - (&/$Apply ?param ?lambda) - (&/$Apply (clean! level ?tid parameter-idx ?param) - (clean! level ?tid parameter-idx ?lambda)) - - (&/$Product ?left ?right) - (&/$Product (clean! level ?tid parameter-idx ?left) - (clean! level ?tid parameter-idx ?right)) - - (&/$Sum ?left ?right) - (&/$Sum (clean! level ?tid parameter-idx ?left) - (clean! level ?tid parameter-idx ?right)) - - (&/$UnivQ ?env ?body) - (&/$UnivQ (&/|map (partial clean! level ?tid parameter-idx) ?env) - (clean! (inc level) ?tid parameter-idx ?body)) - - (&/$ExQ ?env ?body) - (&/$ExQ (&/|map (partial clean! level ?tid parameter-idx) ?env) - (clean! (inc level) ?tid parameter-idx ?body)) - - _ - type - )) - -(defn beta-reduce! [level env type] - (|case type - (&/$Primitive ?name ?params) - (&/$Primitive ?name (&/|map (partial beta-reduce! level env) ?params)) - - (&/$Sum ?left ?right) - (&/$Sum (beta-reduce! level env ?left) - (beta-reduce! level env ?right)) - - (&/$Product ?left ?right) - (&/$Product (beta-reduce! level env ?left) - (beta-reduce! level env ?right)) - - (&/$Apply ?type-arg ?type-fn) - (&/$Apply (beta-reduce! level env ?type-arg) - (beta-reduce! level env ?type-fn)) - - (&/$UnivQ ?local-env ?local-def) - (|case ?local-env - (&/$Nil) - (&/$UnivQ ?local-env (beta-reduce! (inc level) env ?local-def)) - - _ - type) - - (&/$ExQ ?local-env ?local-def) - (|case ?local-env - (&/$Nil) - (&/$ExQ ?local-env (beta-reduce! (inc level) env ?local-def)) - - _ - type) - - (&/$Function ?input ?output) - (&/$Function (beta-reduce! level env ?input) - (beta-reduce! level env ?output)) - - (&/$Parameter ?idx) - (|case (&/|at (- ?idx (* 2 level)) env) - (&/$Some parameter) - (beta-reduce! level env parameter) - - _ - 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)) - - (&/$Apply A F) - (|do [type-fn* (apply-type! F A)] - (apply-type! type-fn* param)) - - (&/$Named ?name ?type) - (apply-type! ?type param) - - (&/$Ex id) - (return (&/$Apply param type-fn)) - - (&/$Var id) - (|do [=type-fun (deref id)] - (apply-type! =type-fun param)) - - _ - (&/fail-with-loc (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)) - - (&/$Product ?left ?right) - (let [=type (&/fold (fn [_abody ena] - (|let [[_aenv _aidx (&/$Var _avar)] ena] - (clean! 0 _avar _aidx _abody))) - type - up) - distributor (fn [v] - (&/fold (fn [_abody ena] - (|let [[_aenv _aidx _avar] ena] - (&/$UnivQ _aenv _abody))) - v - up))] - (return (&type/Tuple$ (&/|map distributor - (&type/flatten-prod =type))))) - - (&/$Sum ?left ?right) - (let [=type (&/fold (fn [_abody ena] - (|let [[_aenv _aidx (&/$Var _avar)] ena] - (clean! 0 _avar _aidx _abody))) - type - up) - distributor (fn [v] - (&/fold (fn [_abody ena] - (|let [[_aenv _aidx _avar] ena] - (&/$UnivQ _aenv _abody))) - v - up))] - (return (&type/Variant$ (&/|map distributor - (&type/flatten-sum =type))))) - - (&/$Apply ?targ ?tfun) - (|do [=type (apply-type! ?tfun ?targ)] - (adjust-type* up =type)) - - (&/$Var ?id) - (|do [type* (&/try-all% (&/|list (&type/deref ?id) - (&/fail-with-loc (str "##2##: " ?id))))] - (adjust-type* up type*)) - - (&/$Named ?name ?type) - (adjust-type* up ?type) - - _ - (&/fail-with-loc (str "[Pattern-matching Error] Cannot pattern-match against 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* - (&/$Identifier "" 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])))) - - (&/$Identifier ident) - (&/fail-with-loc (str "[Pattern-matching Error] Identifiers must be unqualified: " (&/ident->text ident))) - - (&/$Bit ?value) - (|do [_ (&type/check value-type &type/Bit) - =kont kont] - (return (&/T [($BitTestAC ?value) =kont]))) - - (&/$Nat ?value) - (|do [_ (&type/check value-type &type/Nat) - =kont kont] - (return (&/T [($NatTestAC ?value) =kont]))) - - (&/$Int ?value) - (|do [_ (&type/check value-type &type/Int) - =kont kont] - (return (&/T [($IntTestAC ?value) =kont]))) - - (&/$Rev ?value) - (|do [_ (&type/check value-type &type/Rev) - =kont kont] - (return (&/T [($RevTestAC ?value) =kont]))) - - (&/$Frac ?value) - (|do [_ (&type/check value-type &type/Frac) - =kont kont] - (return (&/T [($FracTestAC ?value) =kont]))) - - (&/$Text ?value) - (|do [_ (&type/check value-type &type/Text) - =kont kont] - (return (&/T [($TextTestAC ?value) =kont]))) - - (&/$Tuple ?members) - (|case ?members - (&/$Nil) - (|do [_ (&type/check value-type &type/Any) - =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* - (&/$Product _) - (|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-with-loc (str "[Pattern-matching Error] Pattern-matching mismatch. Requires tuple[" (&/|length (&type/flatten-prod value-type*)) "]. Given tuple [" (&/|length ?members) "].\n" - " At: " (&/show-ast pattern) "\n" - "Expected type: " (&type/show-type value-type*) "\n" - " Actual type: " (&type/show-type value-type))))) - - _ - (&/fail-with-loc (str "[Pattern-matching Error] Tuples require tuple-types: " (&type/show-type value-type)))))) - - (&/$Record 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 (&/$Tuple rec-members)]) kont)) - - (&/$Tag ?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]))) - - (&/$Form (&/$Cons [_ (&/$Nat idx)] (&/$Cons [_ (&/$Bit right?)] ?values))) - (let [idx (if right? (inc idx) idx)] - (|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]) (&/$Tuple ?values)]) kont))] - (return (&/T [($VariantTestAC (&/T [idx (&/|length (&type/flatten-sum value-type*)) =test])) =kont])))) - - (&/$Form (&/$Cons [_ (&/$Tag ?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]) (&/$Tuple ?values)]) kont))] - (return (&/T [($VariantTestAC (&/T [idx (&/|length group) =test])) =kont]))) - - _ - (&/fail-with-loc (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)) - - [($BitTotal total? ?values) ($NoTestAC)] - (return ($BitTotal true ?values)) - - [($NatTotal total? ?values) ($NoTestAC)] - (return ($NatTotal true ?values)) - - [($IntTotal total? ?values) ($NoTestAC)] - (return ($IntTotal true ?values)) - - [($RevTotal total? ?values) ($NoTestAC)] - (return ($RevTotal true ?values)) - - [($FracTotal total? ?values) ($NoTestAC)] - (return ($FracTotal 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)) - - [($BitTotal total? ?values) ($StoreTestAC ?idx)] - (return ($BitTotal true ?values)) - - [($NatTotal total? ?values) ($StoreTestAC ?idx)] - (return ($NatTotal true ?values)) - - [($IntTotal total? ?values) ($StoreTestAC ?idx)] - (return ($IntTotal true ?values)) - - [($RevTotal total? ?values) ($StoreTestAC ?idx)] - (return ($RevTotal true ?values)) - - [($FracTotal total? ?values) ($StoreTestAC ?idx)] - (return ($FracTotal 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?) ($BitTestAC ?value)] - (return ($BitTotal total? (&/|list ?value))) - - [($BitTotal total? ?values) ($BitTestAC ?value)] - (return ($BitTotal 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?) ($RevTestAC ?value)] - (return ($RevTotal total? (&/|list ?value))) - - [($RevTotal total? ?values) ($RevTestAC ?value)] - (return ($RevTotal 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?) ($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-with-loc (str "[Pattern-matching Error] Inconsistent tuple-size.\n" - "Expected: " (&/|length ?values) "\n" - " Actual: " (&/|length ?tests)))) - - [($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) - (assert false))] - (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) - (assert false))] - (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) - - ($BitTotal ?total ?values) - (|do [_ (&type/check value-type &type/Bit)] - (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)) - - ($RevTotal ?total _) - (|do [_ (&type/check value-type &type/Rev)] - (return ?total)) - - ($FracTotal ?total _) - (|do [_ (&type/check value-type &type/Frac)] - (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)] - (if (&type/type= &type/Any value-type*) - (return true) - (&/fail-with-loc "[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] (&/$Product 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* - (&/$Product _) - (|let [num-elems (&/|length ?structs) - [_shorter _tuple-types] (&type/tuple-types-for (&/|length ?structs) value-type*) - _ (&/assert! (= num-elems _shorter) - (&/fail-with-loc (str "[Pattern-maching Error] Tuple-mismatch. Require tuple[" (&/|length (&type/flatten-prod value-type*)) "]. Given tuple [" (&/|length ?structs) "]")))] - (|do [totals (&/map2% check-totality _tuple-types ?structs)] - (return (&/fold #(and %1 %2) true totals)))) - - _ - (&/fail-with-loc (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* - (&/$Sum _) - (|do [totals (&/map2% check-totality - (&type/flatten-sum value-type*) - ?structs)] - (return (&/fold #(and %1 %2) true totals))) - - _ - (&/fail-with-loc "[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) - _ (&/assert! ? "[Pattern-maching Error] Pattern-matching is not total.")] - (return patterns))) diff --git a/luxc/src/lux/analyser/env.clj b/luxc/src/lux/analyser/env.clj deleted file mode 100644 index a2b6e5ad3..000000000 --- a/luxc/src/lux/analyser/env.clj +++ /dev/null @@ -1,78 +0,0 @@ -(ns lux.analyser.env - (:require clojure.core.match - clojure.core.match.array - (lux [base :as & :refer [|do return return* |case |let]]) - [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-location (&&/$var (&/$Local (->> (&/|head stack) (&/get$ &/$locals) (&/get$ &/$counter)))))] - (&/$Cons (&/update$ &/$locals #(->> % - (&/update$ &/$counter inc) - (&/update$ &/$mappings (fn [m] (&/|put name (&/T [type 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 - (&/T [(&&/expr-type* var-analysis) - 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-with-loc "[Analyser Error] Cannot obtain captured vars without environments.") - state) - - (&/$Cons env _) - (return* state (->> env - (&/get$ &/$captured) - (&/get$ &/$mappings) - (&/|map (fn [mapping] - (|let [[k v] mapping] - (&/T [k (&/|second v)]))))))) - )) diff --git a/luxc/src/lux/analyser/function.clj b/luxc/src/lux/analyser/function.clj deleted file mode 100644 index 3db24acef..000000000 --- a/luxc/src/lux/analyser/function.clj +++ /dev/null @@ -1,28 +0,0 @@ -(ns lux.analyser.function - (:require clojure.core.match - clojure.core.match.array - (lux [base :as & :refer [|let |do return |case]] - [host :as &host]) - (lux.analyser [base :as &&] - [env :as &env]))) - -;; [Resource] -(defn with-function [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-location] _] register - register* (&&/|meta register-type register-location - (&&/$captured (&/T [scope - (->> frame (&/get$ &/$captured) (&/get$ &/$counter)) - register])))] - (&/T [register* (&/update$ &/$captured #(->> % - (&/update$ &/$counter inc) - (&/update$ &/$mappings (fn [mps] (&/|put name (&/T [register-type register*]) mps)))) - frame)]))) diff --git a/luxc/src/lux/analyser/lux.clj b/luxc/src/lux/analyser/lux.clj deleted file mode 100644 index b7d78aa23..000000000 --- a/luxc/src/lux/analyser/lux.clj +++ /dev/null @@ -1,726 +0,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* |let |list |case]] - [parser :as &parser] - [type :as &type] - [host :as &host]) - (lux.analyser [base :as &&] - [function :as &&function] - [case :as &&case] - [env :as &&env] - [module :as &&module] - [record :as &&record]))) - -;; [Utils] -;; TODO: Walk the type to set up the parameter-type, instead of doing a -;; rough calculation like this one. -(defn ^:private count-univq - "(-> Type Int)" - [type] - (|case type - (&/$UnivQ env type*) - (inc (count-univq type*)) - - _ - 0)) - -;; TODO: This technique will not work if the body of the type contains -;; nested quantifications that cannot be directly counted. -(defn ^:private next-parameter-type - "(-> Type Type)" - [type] - (&/$Parameter (->> (count-univq type) (* 2) (+ 1)))) - -(defn ^:private embed-inferred-input - "(-> Type Type Type)" - [input output] - (|case output - (&/$UnivQ env output*) - (&/$UnivQ env (embed-inferred-input input output*)) - - _ - (&/$Function input output))) - -;; [Exports] -(defn analyse-unit [analyse ?exo-type] - (|do [_location &/location - _ (&type/check ?exo-type &type/Any)] - (return (&/|list (&&/|meta ?exo-type _location - (&&/$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-location] tuple-analysis] (&&/cap-1 (analyse-tuple analyse (&/$Left exo-type**) ?elems)) - =var (&type/resolve-type $var) - inferred-type (|case =var - (&/$Var iid) - (|do [:let [=var* (next-parameter-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-location - 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] (&/$Product left right)) - last prevs))) - _location &/location] - (return (&/|list (&&/|meta exo-type _location - (&&/$tuple =elems) - )))) - (|do [exo-type* (&type/actual-type exo-type)] - (&/with-attempt - (|case exo-type* - (&/$Product _) - (|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) - _location &/location] - (return (&/|list (&&/|meta exo-type _location - (&&/$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)) - _location &/location] - (return (&/|list (&&/|meta exo-type _location - (&&/$tuple (&/|++ =direct-elems =indirect-elems)) - )))))) - - (&/$ExQ _) - (&type/with-var - (fn [$var] - (|do [exo-type** (&type/apply-type exo-type* $var) - [[tuple-type tuple-location] tuple-analysis] (&&/cap-1 (analyse-tuple analyse (&/$Right exo-type**) ?elems)) - =tuple-analysis (&&/clean-analysis $var (&&/|meta exo-type tuple-location - tuple-analysis))] - (return (&/|list =tuple-analysis))))) - - (&/$UnivQ _) - (|do [$var &type/existential - :let [(&/$Ex $var-id) $var] - exo-type** (&type/apply-type exo-type* $var) - [[tuple-type tuple-location] tuple-analysis] (&/with-scope-type-var $var-id - (&&/cap-1 (analyse-tuple analyse (&/$Right exo-type**) ?elems)))] - (return (&/|list (&&/|meta exo-type tuple-location - 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 [_location &/location - 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] Macro cannot expand to more than 1 output.")))) - -(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-location] variant-analysis] (&&/cap-1 (analyse-variant analyse (&/$Left exo-type**) idx is-last? ?values)) - =var (&type/resolve-type $var) - inferred-type (|case =var - (&/$Var iid) - (|do [:let [=var* (next-parameter-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-location - variant-analysis)))))) - - _ - (analyse-variant analyse (&/$Right exo-type*) idx is-last? ?values))) - - (&/$Right exo-type) - (|do [exo-type* (|case exo-type - (&/$Var ?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* - (&/$Sum _) - (|do [vtype (&type/sum-at idx exo-type*) - =value (analyse-variant-body analyse vtype ?values) - _location &/location] - (if (= 1 (&/|length (&type/flatten-sum exo-type*))) - (return (&/|list =value)) - (return (&/|list (&&/|meta exo-type _location (&&/$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] Cannot 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 - (&/$Var ?id) - (|do [=exo-type (&type/deref ?id)] - (&/fail-with-loc (str err "\n" "[Analyser Error] Cannot 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] Cannot 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 - (&/$Var id) - (|do [? (&type/bound? id)] - (if ? - (analyse-tuple analyse (&/$Right exo-type) rec-members) - (|do [[[tuple-type tuple-location] tuple-analysis] (&&/cap-1 (analyse-tuple analyse (&/$Left rec-type) rec-members)) - _ (&type/check exo-type tuple-type)] - (return (&/|list (&&/|meta exo-type tuple-location - tuple-analysis)))))) - - _ - (analyse-tuple analyse (&/$Right exo-type) rec-members) - ))) - -(defn ^:private analyse-global [analyse exo-type module name] - (|do [[[r-module r-name] [exported? endo-type ?meta ?value]] (&&module/find-def module name) - ;; This is a small shortcut to optimize analysis of typing code. - _ (if (and (&type/type= &type/Type endo-type) - (&type/type= &type/Type exo-type)) - (return nil) - (&type/check exo-type endo-type)) - _location &/location] - (return (&/|list (&&/|meta endo-type _location - (&&/$def (&/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$ &/$captured) (&/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 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*] (&&function/close-over in-scope name register frame)] - (&/T [register* (&/$Cons frame* new-inner)]))) - (&/T [(&/|second (or (->> bottom-outer (&/get$ &/$locals) (&/get$ &/$mappings) (&/|get name)) - (->> bottom-outer (&/get$ &/$captured) (&/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-identifier [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 - (&/$Var ?id) - (|do [? (&type/bound? ?id) - type** (if ? - (&type/clean $var =output-t) - (|do [_ (&type/set-var ?id (next-parameter-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 _) - (&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 - (&/$Var ?id) - (|do [? (&type/bound? ?id) - type** (if ? - (&type/clean $var =output-t) - (|do [idT &type/existential - _ (&type/set-var ?id idT)] - (&type/clean $var =output-t))) - _ (&type/clean $var exo-type)] - (return (&/T [type** ==args]))) - )))) - - (&/$Function ?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] Argument expected: " (&type/show-type ?input-t)))))] - (return (&/T [=output-t (&/$Cons =arg =args)]))) - - _ - (&/fail-with-loc (str "[Analyser Error] Cannot apply a non-function: " (&type/show-type ?fun-type*)))) - (fn [err] - (&/fail-with-loc (str err "\n" "[Analyser Error] Cannot 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-location] =fn-form] =fn] - [=output-t =args] (analyse-apply* analyse exo-type =fn-type ?args)] - (return (&/|list (&&/|meta =output-t =fn-location - (&&/$apply =fn =args) - ))))) - -(defn analyse-apply [analyse location exo-type macro-caller =fn ?args] - (|case =fn - [_ (&&/$def ?module ?name)] - (|do [[real-name [exported? ?type ?meta ?value]] (&&module/find-def! ?module ?name)] - (if (&type/type= &type/Macro ?type) - (|do [macro-expansion (fn [state] - (|case (macro-caller ?value ?args 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 (= "module:" r-name) - ;; (->> macro-expansion - ;; (&/|map (fn [ast] (str (&/show-ast ast) "\n"))) - ;; (&/fold str "") - ;; (&/|log! (str 'macro-expansion " " (&/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 [_ (&/assert! (> (&/|length ?branches) 0) "[Analyser Error] Cannot have empty 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) ?branches) - _location &/location] - (return (&/|list (&&/|meta exo-type _location - (&&/$case =value =match) - ))))) - -(defn ^:private unravel-inf-appt [type] - (|case type - (&/$Apply (&/$Var _inf-var) =input+) - (&/$Cons _inf-var (unravel-inf-appt =input+)) - - _ - (&/|list))) - -(defn ^:private clean-func-inference [$input $output =input =func] - (|case =input - (&/$Var iid) - (|do [:let [=input* (next-parameter-type =func)] - _ (&type/set-var iid =input*) - =func* (&type/clean $input =func) - =func** (&type/clean $output =func*)] - (return (&/$UnivQ &/$Nil =func**))) - - (&/$Apply (&/$Var _inf-var) =input+) - (&/fold% (fn [_func _inf-var] - (|do [:let [$inf-var (&/$Var _inf-var)] - =inf-var (&type/resolve-type $inf-var) - _func* (clean-func-inference $inf-var $output =inf-var _func)] - (return _func*))) - =func - (unravel-inf-appt =input)) - - (&/$Product _ _) - (&/fold% (fn [_func _inf-var] - (|do [:let [$inf-var (&/$Var _inf-var)] - =inf-var (&type/resolve-type $inf-var) - _func* (clean-func-inference $inf-var $output =inf-var _func)] - (return _func*))) - =func - (&/|reverse (&type/flatten-prod =input))) - - _ - (|do [=func* (&type/clean $input =func) - =func** (&type/clean $output =func*)] - (return =func**)))) - -(defn analyse-function* [analyse exo-type ?self ?arg ?body] - (|case exo-type - (&/$Var id) - (|do [? (&type/bound? id)] - (if ? - (|do [exo-type* (&type/deref id)] - (analyse-function* analyse exo-type* ?self ?arg ?body)) - ;; Inference - (&type/with-var - (fn [$input] - (&type/with-var - (fn [$output] - (|do [[[function-type function-location] function-analysis] (analyse-function* analyse (&/$Function $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 function-location - function-analysis))) - )))))) - - _ - (&/with-attempt - (|do [exo-type* (&type/actual-type exo-type)] - (|case exo-type* - (&/$UnivQ _) - (|do [$var &type/existential - :let [(&/$Ex $var-id) $var] - exo-type** (&type/apply-type exo-type* $var)] - (&/with-scope-type-var $var-id - (analyse-function* analyse exo-type** ?self ?arg ?body))) - - (&/$ExQ _) - (&type/with-var - (fn [$var] - (|do [exo-type** (&type/apply-type exo-type* $var) - =expr (analyse-function* analyse exo-type** ?self ?arg ?body)] - (&&/clean-analysis $var =expr)))) - - (&/$Function ?arg-t ?return-t) - (|do [[=scope =captured =body] (&&function/with-function ?self exo-type* - ?arg ?arg-t - (&&/analyse-1 analyse ?return-t ?body)) - _location &/location - register-offset &&env/next-local-idx] - (return (&&/|meta exo-type* _location - (&&/$function 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-function** [analyse exo-type ?self ?arg ?body] - (|case exo-type - (&/$UnivQ _) - (|do [$var &type/existential - :let [(&/$Ex $var-id) $var] - exo-type* (&type/apply-type exo-type $var) - [_ _expr] (&/with-scope-type-var $var-id - (analyse-function** analyse exo-type* ?self ?arg ?body)) - _location &/location] - (return (&&/|meta exo-type _location _expr))) - - (&/$Var id) - (|do [? (&type/bound? id)] - (if ? - (|do [exo-type* (&type/actual-type exo-type)] - (analyse-function* analyse exo-type* ?self ?arg ?body)) - ;; Inference - (analyse-function* analyse exo-type ?self ?arg ?body))) - - _ - (|do [exo-type* (&type/actual-type exo-type)] - (analyse-function* analyse exo-type* ?self ?arg ?body)) - )) - -(defn analyse-function [analyse exo-type ?self ?arg ?body] - (|do [output (analyse-function** analyse exo-type ?self ?arg ?body)] - (return (&/|list output)))) - -(defn ^:private ensure-undefined! [module-name local-name] - (|do [verdict (&&module/defined? module-name local-name)] - (if verdict - (|do [[[real-module real-name] _] (&&module/find-def module-name local-name) - :let [wanted-name (str module-name &/+name-separator+ local-name) - source-name (str real-module &/+name-separator+ real-name)]] - (&/assert! false (str "[Analyser Error] Cannot re-define " wanted-name - (if (= wanted-name source-name) - "" - (str "\nThis is an alias for " source-name))))) - (return &/$Nil)))) - -(defn analyse-def* [analyse optimize eval! compile-def ?name ?value ?meta exported? & [?expected-type]] - (|do [_ &/ensure-directive - module-name &/get-module-name - _ (ensure-undefined! module-name ?name) - =value (&/without-repl-closure - (&/with-scope ?name - (if ?expected-type - (&/with-expected-type ?expected-type - (&&/analyse-1 analyse ?expected-type ?value)) - (&&/analyse-1+ analyse ?value)))) - =meta (&&/analyse-1 analyse &type/Code ?meta) - ==meta (eval! (optimize =meta)) - def-value (compile-def ?name (optimize =value) ==meta exported?) - _ &type/reset-mappings] - (return (&/T [module-name (&&/expr-type* =value) def-value])))) - -(defn analyse-def [analyse optimize eval! compile-def ?name ?value ?meta exported?] - (|do [_ (analyse-def* analyse optimize eval! compile-def ?name ?value ?meta exported?)] - (return &/$Nil))) - -(defn analyse-def-type-tagged [analyse optimize eval! compile-def ?name ?value ?meta tags* exported?] - (|do [[module-name def-type def-value] (analyse-def* analyse optimize eval! compile-def ?name ?value ?meta exported? &type/Type) - _ (&/assert! (&type/type= &type/Type def-type) - "[Analyser Error] Cannot define tags for non-type.") - tags (&/map% (fn [tag*] - (|case tag* - [_ (&/$Text tag)] - (return tag) - - _ - (&/fail-with-loc "[Analyser Error] Incorrect format for tags."))) - tags*) - _ (&&module/declare-tags module-name tags exported? def-value)] - (return &/$Nil))) - -(defn analyse-def-alias [?alias ?original] - (|let [[r-module r-name] ?original] - (|do [module-name &/get-module-name - _ (ensure-undefined! module-name ?alias) - _ (&&module/find-def r-module r-name) - _ (&/without-repl-closure - (&&module/define-alias module-name ?alias ?original))] - (return &/$Nil)))) - -(defn ^:private merge-module-states - "(-> Host Host Host)" - [new old] - (|let [merged-module-states (&/fold (fn [total new-module] - (|let [[_name _module] new-module] - (|case (&/get$ &&module/$module-state _module) - (&&module/$Cached) - (&/|put _name _module total) - - (&&module/$Compiled) - (&/|put _name _module total) - - _ - total))) - (&/get$ &/$modules old) - (&/get$ &/$modules new))] - (&/set$ &/$modules merged-module-states old))) - -(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))) - ;; Do not 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 Lux Lux Lux)" - [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))) - (merge-module-states new))) - -(def ^:private get-compiler - (fn [compiler] - (return* compiler compiler))) - -(defn ^:private set-compiler [compiler*] - (fn [_] - (return* compiler* compiler*))) - -(defn try-async-compilation [path compile-module] - (|do [already-compiled? (&&module/exists? path)] - (if (not already-compiled?) - (compile-module path) - (|do [_compiler get-compiler] - (return (doto (promise) - (deliver (&/$Right _compiler)))))))) - -(defn analyse-module [analyse optimize eval! compile-module ?meta ?imports] - (|do [_ &/ensure-directive - =anns (&&/analyse-1 analyse &type/Code ?meta) - ==anns (eval! (optimize =anns)) - module-name &/get-module-name - _ (&&module/set-anns ==anns module-name) - _imports (&&module/fetch-imports ?imports) - current-module &/get-module-name - =asyncs (&/map% (fn [_import] - (|let [[path alias] _import] - (&/without-repl - (&/save-module - (|do [_ (&/assert! (not (= current-module path)) - (&/fail-with-loc (str "[Analyser Error] Module cannot import itself: " path))) - active? (&&module/active-module? path) - ;; TODO: Enrich this error-message - ;; to explicitly show the cyclic dependency. - _ (&/assert! (not active?) - (str "[Analyser Error] Cannot import a module that is mid-compilation { cyclic dependency }: " path " @ " current-module)) - _ (&&module/add-import path) - _ (if (= "" alias) - (return nil) - (&&module/alias current-module alias path))] - (try-async-compilation path compile-module)))))) - _imports) - _compiler get-compiler - _ (&/fold% (fn [compiler _async] - (|case @_async - (&/$Right _new-compiler) - (set-compiler (merge-compilers current-module _new-compiler compiler)) - - (&/$Left ?error) - (&/fail ?error))) - _compiler - =asyncs)] - (return &/$Nil))) - -(defn ^:private coerce - "(-> Type Analysis Analysis)" - [new-type analysis] - (|let [[[_type _location] _analysis] analysis] - (&&/|meta new-type _location - _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 (&&/analyse-1 analyse ==type ?value) - _location &/location] - (return (&/|list (&&/|meta ==type _location - (&&/$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 [program-type (&/$Function (&/$Apply &type/Text &type/List) - (&/$Apply &type/Any &type/IO))] - (defn analyse-program [analyse optimize compile-program ?program] - (|do [_ &/ensure-directive - =program (&&/analyse-1 analyse program-type ?program) - _ (compile-program (optimize =program))] - (return &/$Nil)))) diff --git a/luxc/src/lux/analyser/module.clj b/luxc/src/lux/analyser/module.clj deleted file mode 100644 index d41eb73d5..000000000 --- a/luxc/src/lux/analyser/module.clj +++ /dev/null @@ -1,431 +0,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 [defvariant deftuple |let |do return return* |case]] - [type :as &type] - [host :as &host]) - [lux.host.generics :as &host-generics])) - -;; [Utils] -;; ModuleState -(defvariant - ("Active" 0) - ("Compiled" 0) - ("Cached" 0)) - -;; Module -(deftuple - ["module-hash" - "module-aliases" - "defs" - "imports" - "tags" - "types" - "module-annotations" - "module-state"]) - -(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-annotations - &/$None - ;; "module-state" - $Active] - )) - -(do-template [<flagger> <asker> <tag>] - (do (defn <flagger> - "(-> Text (Lux Any))" - [module-name] - (fn [state] - (let [state* (&/update$ &/$modules - (fn [modules] - (&/|update module-name - (fn [=module] - (&/set$ $module-state <tag> =module)) - modules)) - state)] - (&/$Right (&/T [state* &/unit-tag]))))) - (defn <asker> - "(-> Text (Lux Bit))" - [module-name] - (fn [state] - (if-let [=module (->> state (&/get$ &/$modules) (&/|get module-name))] - (&/$Right (&/T [state (|case (&/get$ $module-state =module) - (<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 - ) - -;; [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] Cannot 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-alias [module name de-aliased] - (fn [state] - (|case (&/get$ &/$scopes state) - (&/$Cons ?env (&/$Nil)) - (return* (->> state - (&/update$ &/$modules - (fn [ms] - (&/|update module - (fn [m] - (&/update$ $defs - #(&/|put name (&/$Left de-aliased) %) - m)) - ms)))) - nil) - - _ - ((&/fail-with-loc (str "[Analyser Error] Cannot create a new global definition outside of a global environment: " (str module &/+name-separator+ name))) - state)))) - -(defn define [module name exported? def-type def-meta def-value] - (fn [state] - (|case (&/get$ &/$scopes state) - (&/$Cons ?env (&/$Nil)) - (return* (->> state - (&/update$ &/$modules - (fn [ms] - (&/|update module - (fn [m] - (&/update$ $defs - #(&/|put name (&/$Right (&/T [exported? def-type def-meta def-value])) %) - m)) - ms)))) - nil) - - _ - ((&/fail-with-loc (str "[Analyser Error] Cannot create a new global definition outside of a global environment: " (str module &/+name-separator+ name))) - state)))) - -(defn type-def - "(-> Text Text (Lux [Bit Type]))" - [module name] - (fn [state] - (if-let [$module (->> state (&/get$ &/$modules) (&/|get module))] - (if-let [$def (->> $module (&/get$ $defs) (&/|get name))] - (|case $def - (&/$Left [o-module o-name]) - ((type-def o-module o-name) state) - - (&/$Right [exported? ?type ?meta ?value]) - (if (&type/type= &type/Type ?type) - (return* state (&/T [exported? ?value])) - ((&/fail-with-loc (str "[Analyser Error] Not a type: " (&/ident->text (&/T [module name])) - "\nMETA: " (&/show-ast ?meta))) - 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 Bit))" - [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] Cannot 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] Cannot 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-annotations 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-annotations (&/$Some anns) %) - ms)))) - nil))) - -(defn find-def! [module name] - (|do [current-module &/get-module-name] - (fn [state] - (if-let [$module (->> state (&/get$ &/$modules) (&/|get module))] - (if-let [$def (->> $module (&/get$ $defs) (&/|get name))] - (|case $def - (&/$Left [?r-module ?r-name]) - ((find-def! ?r-module ?r-name) - state) - - (&/$Right $def*) - (return* state (&/T [(&/T [module name]) $def*]))) - ((&/fail-with-loc (str "[Analyser Error @ find-def!] Definition does not exist: " (str module &/+name-separator+ name) - " at module: " current-module)) - state)) - ((&/fail-with-loc (str "[Analyser Error @ find-def!] Module does not exist: " module - " at module: " current-module)) - state))))) - -(defn find-def [module name] - (|do [current-module &/get-module-name] - (fn [state] - (if-let [$module (->> state (&/get$ &/$modules) (&/|get module))] - (if-let [$def (->> $module (&/get$ $defs) (&/|get name))] - (|case $def - (&/$Left [?r-module ?r-name]) - (if (.equals ^Object current-module module) - ((find-def! ?r-module ?r-name) - state) - ((&/fail-with-loc (str "[Analyser Error @ find-def] Cannot use (private) alias: " (str module &/+name-separator+ name) - " at module: " current-module)) - state)) - - (&/$Right [exported? ?type ?meta ?value]) - (if (or (.equals ^Object current-module module) - (and exported? - (or (.equals ^Object module &/prelude) - (imports? state module current-module)))) - (return* state (&/T [(&/T [module name]) - (&/T [exported? ?type ?meta ?value])])) - ((&/fail-with-loc (str "[Analyser Error @ find-def] Cannot use private definition: " (str module &/+name-separator+ name) - " at module: " current-module)) - state))) - ((&/fail-with-loc (str "[Analyser Error @ find-def] Definition does not exist: " (str module &/+name-separator+ name) - " at module: " current-module)) - state)) - ((&/fail-with-loc (str "[Analyser Error @ find-def] Module does not exist: " module - " at module: " current-module)) - state))))) - -(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))) - (&/set$ &/$current-module (&/$Some name))) - 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] Cannot 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] Cannot re-declare type: " (&/ident->text (&/T [module name]))))] - (return nil))) - -(defn declare-tags - "(-> Text (List Text) Bit 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] Cannot 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 Any))" - [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] Cannot 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)))))) - -(defn fetch-imports [imports] - (|case imports - [_ (&/$Tuple _parts)] - (&/map% (fn [_part] - (|case _part - [_ (&/$Tuple (&/$Cons [[_ (&/$Text _module)] - (&/$Cons [[_ (&/$Text _alias)] - (&/$Nil)])]))] - (return (&/T [_module _alias])) - - _ - (&/fail-with-loc "[Analyser Error] Incorrect import syntax."))) - _parts) - - _ - (&/fail-with-loc "[Analyser Error] Incorrect import syntax."))) - -(def ^{:doc "(Lux (List [Text (List Text)]))"} - tag-groups - (|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$ $types module))))) diff --git a/luxc/src/lux/analyser/parser.clj b/luxc/src/lux/analyser/parser.clj deleted file mode 100644 index 6a46bab3c..000000000 --- a/luxc/src/lux/analyser/parser.clj +++ /dev/null @@ -1,478 +0,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 |let |case]] - [reader :as &reader] - [lexer :as &lexer] - [parser :as &parser]))) - -(declare parse-gclass) - -;; [Parsers] -(def ^:private _space_ (&reader/read-text " ")) - -(defn ^:private with-pre-space [action] - (|do [_ _space_] - action)) - -(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-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 - =bounds (with-pre-space - (spaced parse-gclass))] - (return (&/T [=name =bounds]))))) - -(def ^:private parse-gclass-decl - (with-parens - (|do [=class-name parse-name - =params (with-pre-space - (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 - =params (with-pre-space - (spaced parse-gclass))] - (return (&/$GenericClass class-name =params)))) - - (with-parens - (|do [_ (&reader/read-text "#Array") - =param (with-pre-space - parse-gclass)] - (return (&/$GenericArray =param)))) - ))) - -(def ^:private parse-gclass-super - (with-parens - (|do [class-name parse-name - =params (with-pre-space - (spaced parse-gclass))] - (return (&/T [class-name =params]))))) - -(def ^:private parse-ctor-arg - (with-brackets - (|do [=class parse-gclass - (&/$Cons =term (&/$Nil)) (with-pre-space - &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/$Bit param-value*)] &lexer/lex-bit] - (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/$Frac param-value*)] &lexer/lex-frac] - (return (float param-value*))) - - (|do [_ (&reader/read-text "d") - [_ (&lexer/$Frac param-value*)] &lexer/lex-frac] - (return (double 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 - =ann-params (with-pre-space - (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?] - (|case ?=head - (&/$Some =head) - (|do [[_ _ ?] (&reader/read-text? " ")] - (if ? - (|do [=tail parse-gvars] - (return (&/$Cons =head =tail))) - (return (&/|list =head)))) - - (&/$None) - (return (&/|list))))) - -(def ^:private parse-method-decl - (with-parens - (|do [=method-name parse-name - =anns (with-pre-space - (with-brackets - (spaced parse-ann))) - =gvars (with-pre-space - (with-brackets - parse-gvars)) - =exceptions (with-pre-space - (with-brackets - (spaced parse-gclass))) - =inputs (with-pre-space - (with-brackets - (spaced parse-gclass))) - =output (with-pre-space - 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") - =privacy-modifier (with-pre-space - parse-privacy-modifier) - [_ (&lexer/$Bit =strict*)] (with-pre-space - &lexer/lex-bit) - :let [=strict (Boolean/parseBoolean =strict*)] - =anns (with-pre-space - (with-brackets - (spaced parse-ann))) - =gvars (with-pre-space - (with-brackets - (spaced parse-type-param))) - =exceptions (with-pre-space - (with-brackets - (spaced parse-gclass))) - =inputs (with-pre-space - (with-brackets - (spaced parse-arg-decl))) - =ctor-args (with-pre-space - (with-brackets - (spaced parse-ctor-arg))) - (&/$Cons =body (&/$Nil)) (with-pre-space - &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") - =name (with-pre-space - parse-name) - =privacy-modifier (with-pre-space - parse-privacy-modifier) - [_ (&lexer/$Bit =final?*)] (with-pre-space - &lexer/lex-bit) - :let [=final? (Boolean/parseBoolean =final?*)] - [_ (&lexer/$Bit =strict*)] (with-pre-space - &lexer/lex-bit) - :let [=strict (Boolean/parseBoolean =strict*)] - =anns (with-pre-space - (with-brackets - (spaced parse-ann))) - =gvars (with-pre-space - (with-brackets - (spaced parse-type-param))) - =exceptions (with-pre-space - (with-brackets - (spaced parse-gclass))) - =inputs (with-pre-space - (with-brackets - (spaced parse-arg-decl))) - =output (with-pre-space - parse-gclass) - (&/$Cons =body (&/$Nil)) (with-pre-space - &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") - =class-decl (with-pre-space - parse-gclass-decl) - =name (with-pre-space - parse-name) - [_ (&lexer/$Bit =strict*)] (with-pre-space - &lexer/lex-bit) - :let [=strict (Boolean/parseBoolean =strict*)] - =anns (with-pre-space - (with-brackets - (spaced parse-ann))) - =gvars (with-pre-space - (with-brackets - (spaced parse-type-param))) - =exceptions (with-pre-space - (with-brackets - (spaced parse-gclass))) - =inputs (with-pre-space - (with-brackets - (spaced parse-arg-decl))) - =output (with-pre-space - parse-gclass) - (&/$Cons =body (&/$Nil)) (with-pre-space - &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") - =name (with-pre-space - parse-name) - =privacy-modifier (with-pre-space - parse-privacy-modifier) - [_ (&lexer/$Bit =strict*)] (with-pre-space - &lexer/lex-bit) - :let [=strict (Boolean/parseBoolean =strict*)] - =anns (with-pre-space - (with-brackets - (spaced parse-ann))) - =gvars (with-pre-space - (with-brackets - (spaced parse-type-param))) - =exceptions (with-pre-space - (with-brackets - (spaced parse-gclass))) - =inputs (with-pre-space - (with-brackets - (spaced parse-arg-decl))) - =output (with-pre-space - parse-gclass) - (&/$Cons =body (&/$Nil)) (with-pre-space - &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") - =name (with-pre-space - parse-name) - =privacy-modifier (with-pre-space - parse-privacy-modifier) - =anns (with-pre-space - (with-brackets - (spaced parse-ann))) - =gvars (with-pre-space - (with-brackets - (spaced parse-type-param))) - =exceptions (with-pre-space - (with-brackets - (spaced parse-gclass))) - =inputs (with-pre-space - (with-brackets - (spaced parse-arg-decl))) - =output (with-pre-space - parse-gclass)] - (return (&/$AbstractMethodSyntax (&/T [=name =privacy-modifier =anns =gvars =exceptions =inputs =output]))))) - -(def ^:private parse-method-native-def - (|do [_ (&reader/read-text "native") - =name (with-pre-space - parse-name) - =privacy-modifier (with-pre-space - parse-privacy-modifier) - =anns (with-pre-space - (with-brackets - (spaced parse-ann))) - =gvars (with-pre-space - (with-brackets - (spaced parse-type-param))) - =exceptions (with-pre-space - (with-brackets - (spaced parse-gclass))) - =inputs (with-pre-space - (with-brackets - (spaced parse-arg-decl))) - =output (with-pre-space - 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") - =name (with-pre-space - parse-name) - =anns (with-pre-space - (with-brackets - (spaced parse-ann))) - =type (with-pre-space - parse-gclass) - (&/$Cons =value (&/$Nil)) (with-pre-space - &parser/parse)] - (return (&/$ConstantFieldSyntax =name =anns =type =value))) - - (|do [_ (&reader/read-text "variable") - =name (with-pre-space - parse-name) - =privacy-modifier (with-pre-space - parse-privacy-modifier) - =state-modifier (with-pre-space - parse-state-modifier) - =anns (with-pre-space - (with-brackets - (spaced parse-ann))) - =type (with-pre-space - parse-gclass)] - (return (&/$VariableFieldSyntax =name =privacy-modifier =state-modifier =anns =type))) - )))) - -(def parse-interface-def - (|do [=gclass-decl parse-gclass-decl - =supers (with-pre-space - (with-brackets - (spaced parse-gclass-super))) - =anns (with-pre-space - (with-brackets - (spaced parse-ann))) - =methods (with-pre-space - (spaced parse-method-decl))] - (return (&/T [=gclass-decl =supers =anns =methods])))) - -(def parse-class-def - (|do [=gclass-decl parse-gclass-decl - =super-class (with-pre-space - parse-gclass-super) - =interfaces (with-pre-space - (with-brackets - (spaced parse-gclass-super))) - =inheritance-modifier (with-pre-space - parse-inheritance-modifier) - =anns (with-pre-space - (with-brackets - (spaced parse-ann))) - =fields (with-pre-space - (with-brackets - (spaced parse-field))) - =methods (with-pre-space - (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 - =interfaces (with-pre-space - (with-brackets - (spaced parse-gclass-super))) - =ctor-args (with-pre-space - (with-brackets - (spaced parse-ctor-arg))) - =methods (with-pre-space - (with-brackets - (spaced parse-method-def)))] - (return (&/T [=super-class =interfaces =ctor-args =methods])))) diff --git a/luxc/src/lux/analyser/proc/common.clj b/luxc/src/lux/analyser/proc/common.clj deleted file mode 100644 index 6a1521909..000000000 --- a/luxc/src/lux/analyser/proc/common.clj +++ /dev/null @@ -1,299 +0,0 @@ -(ns lux.analyser.proc.common - (:require (clojure [template :refer [do-template]]) - clojure.core.match - clojure.core.match.array - (lux [base :as & :refer [|let |do return* return |case assert!]] - [type :as &type]) - (lux.analyser [base :as &&] - [module :as &&module]))) - -(defn- analyse-lux-is [analyse exo-type ?values] - (&type/with-var - (fn [$var] - (|do [:let [(&/$Cons reference (&/$Cons sample (&/$Nil))) ?values] - =reference (&&/analyse-1 analyse $var reference) - =sample (&&/analyse-1 analyse $var sample) - _ (&type/check exo-type &type/Bit) - _location &/location] - (return (&/|list (&&/|meta exo-type _location - (&&/$proc (&/T ["lux" "is"]) (&/|list =sample =reference) (&/|list))))))))) - -(defn- analyse-lux-try [analyse exo-type ?values] - (&type/with-var - (fn [$var] - (|do [:let [(&/$Cons op (&/$Nil)) ?values] - =op (&&/analyse-1 analyse (&/$Apply $var &type/IO) op) - _ (&type/check exo-type (&/$Sum &type/Text ;; lux.Left - $var ;; lux.Right - )) - _location &/location] - (return (&/|list (&&/|meta exo-type _location - (&&/$proc (&/T ["lux" "try"]) (&/|list =op) (&/|list))))))))) - -(defn- analyse-lux-macro [analyse exo-type ?values] - (|do [:let [(&/$Cons macro (&/$Nil)) ?values] - [_real-name [_exported? _def-type _meta macro-type]] (&&module/find-def! &/prelude "Macro'") - [[=macro*-type =location] =macro] (&&/analyse-1 analyse macro-type macro) - _ (&type/check exo-type &type/Macro)] - (return (&/|list (&&/|meta exo-type =location - =macro))))) - -(do-template [<name> <proc> <input-type> <output-type>] - (defn- <name> [analyse exo-type ?values] - (|do [:let [(&/$Cons reference (&/$Cons sample (&/$Nil))) ?values] - =reference (&&/analyse-1 analyse <input-type> reference) - =sample (&&/analyse-1 analyse <input-type> sample) - _ (&type/check exo-type <output-type>) - _location &/location] - (return (&/|list (&&/|meta exo-type _location - (&&/$proc (&/T <proc>) (&/|list =sample =reference) (&/|list))))))) - - analyse-text-eq ["text" "="] &type/Text &type/Bit - analyse-text-lt ["text" "<"] &type/Text &type/Bit - ) - -(defn- analyse-text-concat [analyse exo-type ?values] - (|do [:let [(&/$Cons parameter (&/$Cons subject (&/$Nil))) ?values] - =parameter (&&/analyse-1 analyse &type/Text parameter) - =subject (&&/analyse-1 analyse &type/Text subject) - _ (&type/check exo-type &type/Text) - _location &/location] - (return (&/|list (&&/|meta exo-type _location - (&&/$proc (&/T ["text" "concat"]) (&/|list =parameter =subject) (&/|list))))))) - -(defn- analyse-text-index [analyse exo-type ?values] - (|do [:let [(&/$Cons start (&/$Cons part (&/$Cons text (&/$Nil)))) ?values] - =start (&&/analyse-1 analyse &type/Nat start) - =part (&&/analyse-1 analyse &type/Text part) - =text (&&/analyse-1 analyse &type/Text text) - _ (&type/check exo-type (&/$Apply &type/Nat &type/Maybe)) - _location &/location] - (return (&/|list (&&/|meta exo-type _location - (&&/$proc (&/T ["text" "index"]) - (&/|list =text =part =start) - (&/|list))))))) - -(defn- analyse-text-clip [analyse exo-type ?values] - (|do [:let [(&/$Cons from (&/$Cons to (&/$Cons text (&/$Nil)))) ?values] - =from (&&/analyse-1 analyse &type/Nat from) - =to (&&/analyse-1 analyse &type/Nat to) - =text (&&/analyse-1 analyse &type/Text text) - _ (&type/check exo-type &type/Text) - _location &/location] - (return (&/|list (&&/|meta exo-type _location - (&&/$proc (&/T ["text" "clip"]) - (&/|list =text =from =to) - (&/|list))))))) - -(do-template [<name> <proc>] - (defn- <name> [analyse exo-type ?values] - (|do [:let [(&/$Cons text (&/$Nil)) ?values] - =text (&&/analyse-1 analyse &type/Text text) - _ (&type/check exo-type &type/Nat) - _location &/location] - (return (&/|list (&&/|meta exo-type _location - (&&/$proc (&/T ["text" <proc>]) - (&/|list =text) - (&/|list))))))) - - analyse-text-size "size" - ) - -(defn- analyse-text-char [analyse exo-type ?values] - (|do [:let [(&/$Cons idx (&/$Cons text (&/$Nil))) ?values] - =idx (&&/analyse-1 analyse &type/Nat idx) - =text (&&/analyse-1 analyse &type/Text text) - _ (&type/check exo-type &type/Nat) - _location &/location] - (return (&/|list (&&/|meta exo-type _location - (&&/$proc (&/T ["text" "char"]) - (&/|list =text =idx) - (&/|list))))))) - -(do-template [<name> <op>] - (let [inputT (&/$Apply &type/Any &type/I64) - outputT &type/I64] - (defn- <name> [analyse exo-type ?values] - (|do [:let [(&/$Cons mask (&/$Cons input (&/$Nil))) ?values] - =mask (&&/analyse-1 analyse inputT mask) - =input (&&/analyse-1 analyse inputT input) - _ (&type/check exo-type outputT) - _location &/location] - (return (&/|list (&&/|meta exo-type _location - (&&/$proc (&/T ["i64" <op>]) (&/|list =input =mask) (&/|list)))))))) - - analyse-i64-and "and" - analyse-i64-or "or" - analyse-i64-xor "xor" - ) - -(do-template [<name> <op>] - (let [inputT (&/$Apply &type/Any &type/I64) - outputT &type/I64] - (defn- <name> [analyse exo-type ?values] - (|do [:let [(&/$Cons shift (&/$Cons input (&/$Nil))) ?values] - =shift (&&/analyse-1 analyse &type/Nat shift) - =input (&&/analyse-1 analyse inputT input) - _ (&type/check exo-type outputT) - _location &/location] - (return (&/|list (&&/|meta exo-type _location - (&&/$proc (&/T ["i64" <op>]) (&/|list =input =shift) (&/|list)))))))) - - analyse-i64-left-shift "left-shift" - analyse-i64-arithmetic-right-shift "arithmetic-right-shift" - analyse-i64-logical-right-shift "logical-right-shift" - ) - -(do-template [<name> <proc> <input-type> <output-type>] - (let [inputT <input-type> - outputT <output-type>] - (defn- <name> [analyse exo-type ?values] - (|do [:let [(&/$Cons parameterC (&/$Cons subjectC (&/$Nil))) ?values] - parameterA (&&/analyse-1 analyse <input-type> parameterC) - subjectA (&&/analyse-1 analyse <input-type> subjectC) - _ (&type/check exo-type <output-type>) - _location &/location] - (return (&/|list (&&/|meta exo-type _location - (&&/$proc (&/T <proc>) (&/|list subjectA parameterA) (&/|list)))))))) - - analyse-i64-eq ["i64" "="] (&/$Apply &type/Any &type/I64) &type/Bit - analyse-i64-add ["i64" "+"] (&/$Apply &type/Any &type/I64) &type/I64 - analyse-i64-sub ["i64" "-"] (&/$Apply &type/Any &type/I64) &type/I64 - - analyse-int-mul ["i64" "*"] &type/Int &type/Int - analyse-int-div ["i64" "/"] &type/Int &type/Int - analyse-int-rem ["i64" "%"] &type/Int &type/Int - analyse-int-lt ["i64" "<"] &type/Int &type/Bit - - analyse-frac-add ["f64" "+"] &type/Frac &type/Frac - analyse-frac-sub ["f64" "-"] &type/Frac &type/Frac - analyse-frac-mul ["f64" "*"] &type/Frac &type/Frac - analyse-frac-div ["f64" "/"] &type/Frac &type/Frac - analyse-frac-rem ["f64" "%"] &type/Frac &type/Frac - analyse-frac-eq ["f64" "="] &type/Frac &type/Bit - analyse-frac-lt ["f64" "<"] &type/Frac &type/Bit - ) - -(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) - _location &/location] - (return (&/|list (&&/|meta exo-type _location - (&&/$proc (&/T <encode-op>) (&/|list =x) (&/|list))))))) - - (let [decode-type (&/$Apply <type> &type/Maybe)] - (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) - _location &/location] - (return (&/|list (&&/|meta exo-type _location - (&&/$proc (&/T <decode-op>) (&/|list =x) (&/|list))))))))) - - analyse-frac-encode ["f64" "encode"] analyse-frac-decode ["f64" "decode"] &type/Frac - ) - -(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>) - _location &/location] - (return (&/|list (&&/|meta exo-type _location - (&&/$proc (&/T <op>) (&/|list =x) (&/|list))))))) - - analyse-int-char &type/Int &type/Text ["i64" "char"] - analyse-int-frac &type/Int &type/Frac ["i64" "f64"] - analyse-frac-int &type/Frac &type/Int ["f64" "i64"] - - analyse-io-log &type/Text &type/Any ["io" "log"] - analyse-io-error &type/Text &type/Nothing ["io" "error"] - analyse-io-exit &type/Int &type/Nothing ["io" "exit"] - ) - -(defn- analyse-io-current-time [analyse exo-type ?values] - (|do [:let [(&/$Nil) ?values] - _ (&type/check exo-type &type/Int) - _location &/location] - (return (&/|list (&&/|meta exo-type _location - (&&/$proc (&/T ["io" "current-time"]) (&/|list) (&/|list))))))) - -(defn- analyse-syntax-char-case! [analyse exo-type ?values] - (|do [:let [(&/$Cons ?input (&/$Cons [_ (&/$Tuple ?pairs)] (&/$Cons ?else (&/$Nil)))) ?values] - _location &/location - =input (&&/analyse-1 analyse &type/Nat ?input) - _ (assert! (even? (&/|length ?pairs)) "The number of matches must be even!") - =pairs (&/map% (fn [?pair] - (|let [[[_ (&/$Tuple ?patterns)] ?match] ?pair] - (|do [=match (&&/analyse-1 analyse exo-type ?match)] - (return (&/T [(&/|map (fn [?pattern] - (|let [[_ (&/$Text ^String ?pattern-char)] ?pattern] - (int (.charAt ?pattern-char 0)))) - ?patterns) - =match]))))) - (&/|as-pairs ?pairs)) - =else (&&/analyse-1 analyse exo-type ?else)] - (return (&/|list (&&/|meta exo-type _location - (&&/$proc (&/T ["lux" "syntax char case!"]) - (&/|list =input - (&&/|meta exo-type _location (&&/$tuple (&/|map &/|second =pairs))) - =else) - (&/|map &/|first =pairs))))))) - -(defn analyse-proc [analyse exo-type proc ?values] - (try (case proc - "lux is" (analyse-lux-is analyse exo-type ?values) - "lux try" (analyse-lux-try analyse exo-type ?values) - "lux macro" (analyse-lux-macro analyse exo-type ?values) - - "lux io log" (analyse-io-log analyse exo-type ?values) - "lux io error" (analyse-io-error analyse exo-type ?values) - "lux io exit" (analyse-io-exit analyse exo-type ?values) - "lux io current-time" (analyse-io-current-time analyse exo-type ?values) - - "lux text =" (analyse-text-eq analyse exo-type ?values) - "lux text <" (analyse-text-lt analyse exo-type ?values) - "lux text concat" (analyse-text-concat analyse exo-type ?values) - "lux text clip" (analyse-text-clip analyse exo-type ?values) - "lux text index" (analyse-text-index analyse exo-type ?values) - "lux text size" (analyse-text-size analyse exo-type ?values) - "lux text char" (analyse-text-char analyse exo-type ?values) - - "lux i64 and" (analyse-i64-and analyse exo-type ?values) - "lux i64 or" (analyse-i64-or analyse exo-type ?values) - "lux i64 xor" (analyse-i64-xor analyse exo-type ?values) - "lux i64 left-shift" (analyse-i64-left-shift analyse exo-type ?values) - "lux i64 arithmetic-right-shift" (analyse-i64-arithmetic-right-shift analyse exo-type ?values) - "lux i64 logical-right-shift" (analyse-i64-logical-right-shift analyse exo-type ?values) - "lux i64 +" (analyse-i64-add analyse exo-type ?values) - "lux i64 -" (analyse-i64-sub analyse exo-type ?values) - "lux i64 =" (analyse-i64-eq analyse exo-type ?values) - - "lux i64 *" (analyse-int-mul analyse exo-type ?values) - "lux i64 /" (analyse-int-div analyse exo-type ?values) - "lux i64 %" (analyse-int-rem analyse exo-type ?values) - "lux i64 <" (analyse-int-lt analyse exo-type ?values) - "lux i64 f64" (analyse-int-frac analyse exo-type ?values) - "lux i64 char" (analyse-int-char analyse exo-type ?values) - - "lux f64 +" (analyse-frac-add analyse exo-type ?values) - "lux f64 -" (analyse-frac-sub analyse exo-type ?values) - "lux f64 *" (analyse-frac-mul analyse exo-type ?values) - "lux f64 /" (analyse-frac-div analyse exo-type ?values) - "lux f64 %" (analyse-frac-rem analyse exo-type ?values) - "lux f64 =" (analyse-frac-eq analyse exo-type ?values) - "lux f64 <" (analyse-frac-lt analyse exo-type ?values) - "lux f64 encode" (analyse-frac-encode analyse exo-type ?values) - "lux f64 decode" (analyse-frac-decode analyse exo-type ?values) - "lux f64 i64" (analyse-frac-int analyse exo-type ?values) - - ;; Special extensions for performance reasons - ;; Will be replaced by custom extensions in the future. - "lux syntax char case!" (analyse-syntax-char-case! analyse exo-type ?values) - - ;; else - (&/fail-with-loc (str "[Analyser Error] Unknown host procedure: " proc))) - (catch Exception ex - (&/fail-with-loc (str "[Analyser Error] Invalid syntax for procedure: " proc))))) diff --git a/luxc/src/lux/analyser/proc/jvm.clj b/luxc/src/lux/analyser/proc/jvm.clj deleted file mode 100644 index cc77bf72c..000000000 --- a/luxc/src/lux/analyser/proc/jvm.clj +++ /dev/null @@ -1,1082 +0,0 @@ -(ns lux.analyser.proc.jvm - (: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 &&] - [env :as &&env] - [parser :as &&a-parser]) - [lux.compiler.jvm.base :as &c!base]) - (:import (java.lang.reflect Type TypeVariable))) - -;; [Utils] -(defn- ensure-object - "(-> Type (Lux (, Text (List Type))))" - [type] - (|case type - (&/$Primitive payload) - (return payload) - - (&/$Var id) - (return (&/T ["java.lang.Object" (&/|list)])) - - (&/$Ex id) - (return (&/T ["java.lang.Object" (&/|list)])) - - (&/$Named _ type*) - (ensure-object type*) - - (&/$UnivQ _ type*) - (ensure-object type*) - - (&/$ExQ _ type*) - (ensure-object type*) - - (&/$Apply A F) - (|do [type* (&type/apply-type F A)] - (ensure-object type*)) - - _ - (&/fail-with-loc (str "[Analyser Error] Was expecting object type. Instead got: " (&type/show-type type))))) - -(defn- as-object - "(-> Type Type)" - [type] - (|case type - (&/$Primitive class params) - (&/$Primitive (&host-type/as-obj class) params) - - _ - type)) - -(defn- 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- as-otype+ - "(-> Type Type)" - [type] - (|case type - (&/$Primitive name params) - (&/$Primitive (as-otype name) params) - - _ - type)) - -(defn- clean-gtype-var [idx gtype-var] - (|let [(&/$Var id) gtype-var] - (|do [? (&type/bound? id)] - (if ? - (|do [real-type (&type/deref id)] - (return (&/T [idx real-type]))) - (return (&/T [(+ 2 idx) (&/$Parameter idx)])))))) - -(defn- 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- make-gtype - "(-> Text (List Type) Type)" - [class-name type-args] - (&/fold (fn [base-type type-arg] - (|case type-arg - (&/$Parameter _) - (&/$UnivQ &type/empty-env base-type) - - _ - base-type)) - (&/$Primitive class-name type-args) - type-args)) - -;; [Resources] -(defn- analyse-field-access-helper - "(-> Type (List (^ java.lang.reflect.Type)) (^ java.lang.reflect.Type) (Lux Type))" - [obj-type gvars gtype] - (|case obj-type - (&/$Primitive 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 for " (&type/show-type obj-type) "\n" - "Expected: " (&/|length targs) "\n" - " Actual: " (&/|length gvars)))) - - _ - (&/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 (&/$Primitive "java.lang.Boolean" &/$Nil)) - "byte" (return (&/$Primitive "java.lang.Byte" &/$Nil)) - "short" (return (&/$Primitive "java.lang.Short" &/$Nil)) - "int" (return (&/$Primitive "java.lang.Integer" &/$Nil)) - "long" (return (&/$Primitive "java.lang.Long" &/$Nil)) - "float" (return (&/$Primitive "java.lang.Float" &/$Nil)) - "double" (return (&/$Primitive "java.lang.Double" &/$Nil)) - "char" (return (&/$Primitive "java.lang.Character" &/$Nil)) - "void" (return &type/Any) - ;; else - (|do [=params (&/map% (partial generic-class->type env) params)] - (return (&/$Primitive name =params)))) - - (&/$GenericArray param) - (|do [=param (generic-class->type env param)] - (return (&/$Primitive &host-type/array-data-tag (&/|list =param)))) - - (&/$GenericWildcard _) - (return (&/$ExQ &/$Nil (&/$Parameter 1))) - )) - -(defn gen-super-env - "(-> (List (, TypeVar Type)) (List SuperClassDecl) ClassDecl (Lux (List (, Text Type))))" - [class-env supers class-decl] - (|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- make-type-env - "(-> (List TypeParam) (Lux (List [Text Type])))" - [type-params] - (&/map% (fn [gvar] - (|do [:let [[gvar-name _] gvar] - ex &type/existential] - (return (&/T [gvar-name ex])))) - type-params)) - -(defn- double-register-gclass? [gclass] - (|case gclass - (&/$GenericClass name _) - (|case name - "long" true - "double" true - _ false) - - _ - false)) - -(defn- 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 "" &type/Nothing - body*)) - (&&env/with-local iname itype - body*))))) - -(defn- analyse-method - "(-> Analyser ClassDecl (List (, TypeVar Type)) (List SuperClassDecl) MethodSyntax (Lux MethodAnalysis))" - [analyse class-decl class-env all-supers method] - (|let [[?cname ?cparams] class-decl - class-type (&/$Primitive ?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 &type/Any] - =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 - (&/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 - (&/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 - (&/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 - (&/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- mandatory-methods [supers] - (|do [class-loader &/loader] - (&/flat-map% (partial &host/abstract-methods class-loader) supers))) - -(defn- check-method-completion - "(-> (List SuperClassDecl) (List (, MethodDecl Analysis)) (Lux Null))" - [supers methods] - (|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- analyse-field - "(-> Analyser GTypeEnv FieldSyntax (Lux FieldAnalysis))" - [analyse gtype-env field] - (|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 (&/$Primitive <to-class> &/$Nil)] - (defn- <name> [analyse exo-type _?value] - (|do [:let [(&/$Cons ?value (&/$Nil)) _?value] - =value (&&/analyse-1 analyse (&/$Primitive <from-class> &/$Nil) ?value) - _ (&type/check exo-type output-type) - _location &/location] - (return (&/|list (&&/|meta output-type _location (&&/$proc (&/T ["jvm" <proc>]) (&/|list =value) (&/|list)))))))) - - analyse-jvm-double-to-float "double-to-float" "java.lang.Double" "java.lang.Float" - analyse-jvm-double-to-int "double-to-int" "java.lang.Double" "java.lang.Integer" - analyse-jvm-double-to-long "double-to-long" "java.lang.Double" "java.lang.Long" - - analyse-jvm-float-to-double "float-to-double" "java.lang.Float" "java.lang.Double" - analyse-jvm-float-to-int "float-to-int" "java.lang.Float" "java.lang.Integer" - analyse-jvm-float-to-long "float-to-long" "java.lang.Float" "java.lang.Long" - - analyse-jvm-int-to-byte "int-to-byte" "java.lang.Integer" "java.lang.Byte" - analyse-jvm-int-to-char "int-to-char" "java.lang.Integer" "java.lang.Character" - analyse-jvm-int-to-double "int-to-double" "java.lang.Integer" "java.lang.Double" - analyse-jvm-int-to-float "int-to-float" "java.lang.Integer" "java.lang.Float" - analyse-jvm-int-to-long "int-to-long" "java.lang.Integer" "java.lang.Long" - analyse-jvm-int-to-short "int-to-short" "java.lang.Integer" "java.lang.Short" - - analyse-jvm-long-to-double "long-to-double" "java.lang.Long" "java.lang.Double" - analyse-jvm-long-to-float "long-to-float" "java.lang.Long" "java.lang.Float" - analyse-jvm-long-to-int "long-to-int" "java.lang.Long" "java.lang.Integer" - analyse-jvm-long-to-short "long-to-short" "java.lang.Long" "java.lang.Short" - analyse-jvm-long-to-byte "long-to-byte" "java.lang.Long" "java.lang.Byte" - - analyse-jvm-char-to-byte "char-to-byte" "java.lang.Character" "java.lang.Byte" - analyse-jvm-char-to-short "char-to-short" "java.lang.Character" "java.lang.Short" - analyse-jvm-char-to-int "char-to-int" "java.lang.Character" "java.lang.Integer" - analyse-jvm-char-to-long "char-to-long" "java.lang.Character" "java.lang.Long" - - analyse-jvm-short-to-long "short-to-long" "java.lang.Short" "java.lang.Long" - - analyse-jvm-byte-to-long "byte-to-long" "java.lang.Byte" "java.lang.Long" - ) - -(do-template [<name> <proc> <v1-class> <v2-class> <to-class>] - (let [output-type (&/$Primitive <to-class> &/$Nil)] - (defn- <name> [analyse exo-type ?values] - (|do [:let [(&/$Cons ?value1 (&/$Cons ?value2 (&/$Nil))) ?values] - =value1 (&&/analyse-1 analyse (&/$Primitive <v1-class> &/$Nil) ?value1) - =value2 (&&/analyse-1 analyse (&/$Primitive <v2-class> &/$Nil) ?value2) - _ (&type/check exo-type output-type) - _location &/location] - (return (&/|list (&&/|meta output-type _location (&&/$proc (&/T ["jvm" <proc>]) (&/|list =value1 =value2) (&/|list)))))))) - - analyse-jvm-iand "iand" "java.lang.Integer" "java.lang.Integer" "java.lang.Integer" - analyse-jvm-ior "ior" "java.lang.Integer" "java.lang.Integer" "java.lang.Integer" - analyse-jvm-ixor "ixor" "java.lang.Integer" "java.lang.Integer" "java.lang.Integer" - analyse-jvm-ishl "ishl" "java.lang.Integer" "java.lang.Integer" "java.lang.Integer" - analyse-jvm-ishr "ishr" "java.lang.Integer" "java.lang.Integer" "java.lang.Integer" - analyse-jvm-iushr "iushr" "java.lang.Integer" "java.lang.Integer" "java.lang.Integer" - - analyse-jvm-land "land" "java.lang.Long" "java.lang.Long" "java.lang.Long" - analyse-jvm-lor "lor" "java.lang.Long" "java.lang.Long" "java.lang.Long" - analyse-jvm-lxor "lxor" "java.lang.Long" "java.lang.Long" "java.lang.Long" - analyse-jvm-lshl "lshl" "java.lang.Long" "java.lang.Integer" "java.lang.Long" - analyse-jvm-lshr "lshr" "java.lang.Long" "java.lang.Integer" "java.lang.Long" - analyse-jvm-lushr "lushr" "java.lang.Long" "java.lang.Integer" "java.lang.Long" - ) - -(do-template [<name> <proc> <input-class> <output-class>] - (let [input-type (&/$Primitive <input-class> &/$Nil) - output-type (&/$Primitive <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) - _location &/location] - (return (&/|list (&&/|meta output-type _location - (&&/$proc (&/T ["jvm" <proc>]) (&/|list =x =y) (&/|list)))))))) - - analyse-jvm-iadd "iadd" "java.lang.Integer" "java.lang.Integer" - analyse-jvm-isub "isub" "java.lang.Integer" "java.lang.Integer" - analyse-jvm-imul "imul" "java.lang.Integer" "java.lang.Integer" - analyse-jvm-idiv "idiv" "java.lang.Integer" "java.lang.Integer" - analyse-jvm-irem "irem" "java.lang.Integer" "java.lang.Integer" - analyse-jvm-ieq "ieq" "java.lang.Integer" "#Bit" - analyse-jvm-ilt "ilt" "java.lang.Integer" "#Bit" - analyse-jvm-igt "igt" "java.lang.Integer" "#Bit" - - analyse-jvm-ceq "ceq" "java.lang.Character" "#Bit" - analyse-jvm-clt "clt" "java.lang.Character" "#Bit" - analyse-jvm-cgt "cgt" "java.lang.Character" "#Bit" - - analyse-jvm-ladd "ladd" "java.lang.Long" "java.lang.Long" - analyse-jvm-lsub "lsub" "java.lang.Long" "java.lang.Long" - analyse-jvm-lmul "lmul" "java.lang.Long" "java.lang.Long" - analyse-jvm-ldiv "ldiv" "java.lang.Long" "java.lang.Long" - analyse-jvm-lrem "lrem" "java.lang.Long" "java.lang.Long" - analyse-jvm-leq "leq" "java.lang.Long" "#Bit" - analyse-jvm-llt "llt" "java.lang.Long" "#Bit" - analyse-jvm-lgt "lgt" "java.lang.Long" "#Bit" - - analyse-jvm-fadd "fadd" "java.lang.Float" "java.lang.Float" - analyse-jvm-fsub "fsub" "java.lang.Float" "java.lang.Float" - analyse-jvm-fmul "fmul" "java.lang.Float" "java.lang.Float" - analyse-jvm-fdiv "fdiv" "java.lang.Float" "java.lang.Float" - analyse-jvm-frem "frem" "java.lang.Float" "java.lang.Float" - analyse-jvm-feq "feq" "java.lang.Float" "#Bit" - analyse-jvm-flt "flt" "java.lang.Float" "#Bit" - analyse-jvm-fgt "fgt" "java.lang.Float" "#Bit" - - analyse-jvm-dadd "dadd" "java.lang.Double" "java.lang.Double" - analyse-jvm-dsub "dsub" "java.lang.Double" "java.lang.Double" - analyse-jvm-dmul "dmul" "java.lang.Double" "java.lang.Double" - analyse-jvm-ddiv "ddiv" "java.lang.Double" "java.lang.Double" - analyse-jvm-drem "drem" "java.lang.Double" "java.lang.Double" - analyse-jvm-deq "deq" "java.lang.Double" "#Bit" - analyse-jvm-dlt "dlt" "java.lang.Double" "#Bit" - analyse-jvm-dgt "dgt" "java.lang.Double" "#Bit" - ) - -(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 (&/$Primitive <elem-class> &/$Nil) - array-type (&/$Primitive <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) - _location &/location] - (return (&/|list (&&/|meta exo-type _location - (&&/$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) - _location &/location] - (return (&/|list (&&/|meta exo-type _location - (&&/$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) - _location &/location] - (return (&/|list (&&/|meta exo-type _location - (&&/$proc (&/T ["jvm" <store-tag>]) (&/|list =array =idx =elem) (&/|list))))))) - ) - - "java.lang.Boolean" "[Z" analyse-jvm-znewarray "znewarray" analyse-jvm-zaload "zaload" analyse-jvm-zastore "zastore" - "java.lang.Byte" "[B" analyse-jvm-bnewarray "bnewarray" analyse-jvm-baload "baload" analyse-jvm-bastore "bastore" - "java.lang.Short" "[S" analyse-jvm-snewarray "snewarray" analyse-jvm-saload "saload" analyse-jvm-sastore "sastore" - "java.lang.Integer" "[I" analyse-jvm-inewarray "inewarray" analyse-jvm-iaload "iaload" analyse-jvm-iastore "iastore" - "java.lang.Long" "[J" analyse-jvm-lnewarray "lnewarray" analyse-jvm-laload "laload" analyse-jvm-lastore "lastore" - "java.lang.Float" "[F" analyse-jvm-fnewarray "fnewarray" analyse-jvm-faload "faload" analyse-jvm-fastore "fastore" - "java.lang.Double" "[D" analyse-jvm-dnewarray "dnewarray" analyse-jvm-daload "daload" analyse-jvm-dastore "dastore" - "java.lang.Character" "[C" analyse-jvm-cnewarray "cnewarray" analyse-jvm-caload "caload" analyse-jvm-castore "castore" - )) - -(defn- 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- analyse-jvm-anewarray [analyse exo-type ?values] - (|do [:let [(&/$Cons [_ (&/$Text _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 (&/$Primitive &host-type/array-data-tag (&/|list =gclass))] - =length (&&/analyse-1 analyse length-type length) - _ (&type/check exo-type array-type) - _location &/location] - (return (&/|list (&&/|meta exo-type _location - (&&/$proc (&/T ["jvm" "anewarray"]) (&/|list =length) (&/|list gclass gtype-env))))))) - - (defn- 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) - _location &/location] - (return (&/|list (&&/|meta exo-type _location - (&&/$proc (&/T ["jvm" "aaload"]) (&/|list =array =idx) (&/|list))))))) - - (defn- 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) - _location &/location] - (return (&/|list (&&/|meta exo-type _location - (&&/$proc (&/T ["jvm" "aastore"]) (&/|list =array =idx =elem) (&/|list)))))))) - -(defn- 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) - _location &/location] - (return (&/|list (&&/|meta exo-type _location - (&&/$proc (&/T ["jvm" "arraylength"]) (&/|list =array) (&/|list)) - ))))) - -(defn- analyse-jvm-object-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/Bit] - _ (&type/check exo-type output-type) - _location &/location] - (return (&/|list (&&/|meta exo-type _location - (&&/$proc (&/T ["jvm" "object null?"]) (&/|list =object) (&/|list))))))) - -(defn- analyse-jvm-object-null [analyse exo-type ?values] - (|do [:let [(&/$Nil) ?values] - :let [output-type (&/$Primitive &host-type/null-data-tag &/$Nil)] - _ (&type/check exo-type output-type) - _location &/location] - (return (&/|list (&&/|meta exo-type _location - (&&/$proc (&/T ["jvm" "object null"]) (&/|list) (&/|list))))))) - -(defn analyse-jvm-object-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) - _location &/location] - (return (&/|list (&&/|meta exo-type _location - (&&/$proc (&/T ["jvm" "object synchronized"]) (&/|list =monitor =expr) (&/|list))))))) - -(defn- analyse-jvm-throw [analyse exo-type ?values] - (|do [:let [(&/$Cons ?ex (&/$Nil)) ?values] - =ex (&&/analyse-1+ analyse ?ex) - _ (&type/check (&/$Primitive "java.lang.Throwable" &/$Nil) (&&/expr-type* =ex)) - [throw-class throw-params] (ensure-object (&&/expr-type* =ex)) - _location &/location - _ (&type/check exo-type &type/Nothing)] - (return (&/|list (&&/|meta exo-type _location - (&&/$proc (&/T ["jvm" "throw"]) (&/|list =ex) (&/|list))))))) - -(defn- 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) - _location &/location] - (return (&/|list (&&/|meta exo-type _location - (&&/$proc (&/T ["jvm" "getstatic"]) (&/|list) (&/|list class field output-type))))))) - -(defn- 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) - _location &/location] - (return (&/|list (&&/|meta exo-type _location - (&&/$proc (&/T ["jvm" "getfield"]) (&/|list =object) (&/|list class field output-type))))))) - -(defn- 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 &type/Any] - _ (&type/check exo-type output-type) - _location &/location] - (return (&/|list (&&/|meta exo-type _location - (&&/$proc (&/T ["jvm" "putstatic"]) (&/|list =value) (&/|list class field gclass))))))) - -(defn- 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 &type/Any] - _ (&type/check exo-type output-type) - _location &/location] - (return (&/|list (&&/|meta exo-type _location - (&&/$proc (&/T ["jvm" "putfield"]) (&/|list =object =value) (&/|list class field gclass =type))))))) - -(defn- 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 [(&/$Var _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]))))) - )) - -(defn- up-cast [class parent-gvars class-loader !class! object-type] - (|do [[sub-class sub-params] (ensure-object object-type) - (&/$Primitive super-class* super-params*) (&host-type/->super-type &type/existential class-loader !class! (if (= sub-class class) - !class! - sub-class) - sub-params)] - (return (&/fold2 (fn [m ^TypeVariable g t] (&/$Cons (&/T [(.getName g) t]) m)) - (&/|table) - parent-gvars - super-params*)))) - -(defn- check-method! [only-interface? class method] - (|do [!class!* (&/de-alias-class class) - :let [!class! (string/replace !class!* "/" ".")] - 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!))))] - (return (&/T [!class! class-loader])))) - -(let [dummy-type-param (&/$Primitive "java.lang.Object" &/$Nil)] - (do-template [<name> <tag> <only-interface?>] - (defn- <name> [analyse exo-type class method classes ?values] - (|do [:let [(&/$Cons object args) ?values] - [!class! class-loader] (check-method! <only-interface?> class method) - [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)) - =object (&&/analyse-1+ analyse object) - gtype-env (up-cast class parent-gvars class-loader !class! (&&/expr-type* =object)) - [output-type =args] (analyse-method-call-helper analyse exo-type gret gtype-env gvars gargs args) - _location &/location] - (return (&/|list (&&/|meta exo-type _location - (&&/$proc (&/T ["jvm" <tag>]) (&/$Cons =object =args) (&/|list class method classes output-type gret))))))) - - analyse-jvm-invokevirtual "invokevirtual" false - analyse-jvm-invokespecial "invokespecial" false - analyse-jvm-invokeinterface "invokeinterface" true - )) - -(defn- 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) - :let [gtype-env (&/|table)] - [output-type =args] (analyse-method-call-helper analyse exo-type gret gtype-env gvars gargs args) - _location &/location] - (return (&/|list (&&/|meta exo-type _location - (&&/$proc (&/T ["jvm" "invokestatic"]) =args (&/|list class method classes output-type gret))))))) - -(defn- 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- 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) - [output-type =args] (analyse-jvm-new-helper analyse class (&/|table) gvars gargs args) - _ (&type/check exo-type output-type) - _location &/location] - (return (&/|list (&&/|meta exo-type _location - (&&/$proc (&/T ["jvm" "new"]) =args (&/|list class classes))))))) - -(defn- 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/Bit] - _ (&type/check exo-type output-type) - _location &/location] - (return (&/|list (&&/|meta output-type _location - (&&/$proc (&/T ["jvm" "instanceof"]) (&/|list =object) (&/|list class))))))) - -(defn- analyse-jvm-object-class [analyse exo-type ?values] - (|do [:let [(&/$Cons [_ (&/$Text _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 (&/$Primitive "java.lang.Class" (&/|list (&/$Primitive _class-name (&/|list))))] - _ (&type/check exo-type output-type) - _location &/location] - (return (&/|list (&&/|meta output-type _location - (&&/$proc (&/T ["jvm" "object class"]) (&/|list) (&/|list _class-name output-type))))))) - -(defn- 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)))] - _location &/location] - (return (&/|list (&&/|meta &type/Any _location - (&&/$tuple (&/|list))))))) - -(defn- 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)] - _location &/location] - (return (&/|list (&&/|meta &type/Any _location - (&&/$tuple (&/|list)))))))) - -(defn- captured-source [env-entry] - (|case env-entry - [name [_ (&&/$captured _ _ source)]] - source)) - -(defn- analyse-methods [analyse class-decl all-supers methods] - (|do [=methods (&/map% (partial analyse-method analyse class-decl &/$Nil all-supers) methods) - _ (check-method-completion all-supers =methods) - =captured &&env/captured-vars] - (return (&/T [=methods =captured])))) - -(defn- get-names [] - (|do [module &/get-module-name - scope &/get-scope-name] - (return (&/T [module scope])))) - -(let [default-<init> (&/$ConstructorMethodSyntax (&/T [&/$PublicPM - false - &/$Nil - &/$Nil - &/$Nil - &/$Nil - &/$Nil - (&/$Tuple &/$Nil)])) - captured-slot-class "java.lang.Object" - captured-slot-type (&/$GenericClass captured-slot-class &/$Nil)] - (defn- analyse-jvm-anon-class [analyse compile-class exo-type super-class interfaces ctor-args methods] - (&/with-closure - (|do [[module scope] (get-names) - :let [name (->> scope &/|reverse &/|tail &host/location) - class-decl (&/T [name &/$Nil]) - anon-class (str (string/replace module "/" ".") "." name) - class-type-decl (&/T [anon-class &/$Nil]) - anon-class-type (&/$Primitive 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)) - [=methods =captured] (let [all-supers (&/$Cons super-class interfaces)] - (analyse-methods analyse class-type-decl all-supers methods)) - _ (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))] - (compile-class class-decl super-class interfaces &/$DefaultIM &/$Nil =fields =methods =captured (&/$Some =ctor-args))) - _ &/pop-dummy-name - _location &/location] - (let [sources (&/|map captured-source =captured)] - (return (&/|list (&&/|meta anon-class-type _location - (&&/$proc (&/T ["jvm" "new"]) sources (&/|list anon-class (&/|repeat (&/|length sources) captured-slot-class))))))) - )))) - -(defn analyse-host [analyse exo-type compilers proc ?values] - (|let [[_ _ _ compile-class compile-interface] compilers] - (try (case proc - "jvm object synchronized" (analyse-jvm-object-synchronized analyse exo-type ?values) - "jvm object class" (analyse-jvm-object-class analyse exo-type ?values) - "jvm throw" (analyse-jvm-throw analyse exo-type ?values) - "jvm object null?" (analyse-jvm-object-null? analyse exo-type ?values) - "jvm object null" (analyse-jvm-object-null analyse exo-type ?values) - "jvm anewarray" (analyse-jvm-anewarray analyse exo-type ?values) - "jvm aaload" (analyse-jvm-aaload analyse exo-type ?values) - "jvm aastore" (analyse-jvm-aastore analyse exo-type ?values) - "jvm arraylength" (analyse-jvm-arraylength analyse exo-type ?values) - "jvm znewarray" (analyse-jvm-znewarray analyse exo-type ?values) - "jvm bnewarray" (analyse-jvm-bnewarray analyse exo-type ?values) - "jvm snewarray" (analyse-jvm-snewarray analyse exo-type ?values) - "jvm inewarray" (analyse-jvm-inewarray analyse exo-type ?values) - "jvm lnewarray" (analyse-jvm-lnewarray analyse exo-type ?values) - "jvm fnewarray" (analyse-jvm-fnewarray analyse exo-type ?values) - "jvm dnewarray" (analyse-jvm-dnewarray analyse exo-type ?values) - "jvm cnewarray" (analyse-jvm-cnewarray analyse exo-type ?values) - "jvm zaload" (analyse-jvm-zaload analyse exo-type ?values) - "jvm zastore" (analyse-jvm-zastore analyse exo-type ?values) - "jvm baload" (analyse-jvm-baload analyse exo-type ?values) - "jvm bastore" (analyse-jvm-bastore analyse exo-type ?values) - "jvm saload" (analyse-jvm-saload analyse exo-type ?values) - "jvm sastore" (analyse-jvm-sastore analyse exo-type ?values) - "jvm iaload" (analyse-jvm-iaload analyse exo-type ?values) - "jvm iastore" (analyse-jvm-iastore analyse exo-type ?values) - "jvm laload" (analyse-jvm-laload analyse exo-type ?values) - "jvm lastore" (analyse-jvm-lastore analyse exo-type ?values) - "jvm faload" (analyse-jvm-faload analyse exo-type ?values) - "jvm fastore" (analyse-jvm-fastore analyse exo-type ?values) - "jvm daload" (analyse-jvm-daload analyse exo-type ?values) - "jvm dastore" (analyse-jvm-dastore analyse exo-type ?values) - "jvm caload" (analyse-jvm-caload analyse exo-type ?values) - "jvm castore" (analyse-jvm-castore analyse exo-type ?values) - "jvm iadd" (analyse-jvm-iadd analyse exo-type ?values) - "jvm isub" (analyse-jvm-isub analyse exo-type ?values) - "jvm imul" (analyse-jvm-imul analyse exo-type ?values) - "jvm idiv" (analyse-jvm-idiv analyse exo-type ?values) - "jvm irem" (analyse-jvm-irem analyse exo-type ?values) - "jvm ieq" (analyse-jvm-ieq analyse exo-type ?values) - "jvm ilt" (analyse-jvm-ilt analyse exo-type ?values) - "jvm igt" (analyse-jvm-igt analyse exo-type ?values) - "jvm ceq" (analyse-jvm-ceq analyse exo-type ?values) - "jvm clt" (analyse-jvm-clt analyse exo-type ?values) - "jvm cgt" (analyse-jvm-cgt analyse exo-type ?values) - "jvm ladd" (analyse-jvm-ladd analyse exo-type ?values) - "jvm lsub" (analyse-jvm-lsub analyse exo-type ?values) - "jvm lmul" (analyse-jvm-lmul analyse exo-type ?values) - "jvm ldiv" (analyse-jvm-ldiv analyse exo-type ?values) - "jvm lrem" (analyse-jvm-lrem analyse exo-type ?values) - "jvm leq" (analyse-jvm-leq analyse exo-type ?values) - "jvm llt" (analyse-jvm-llt analyse exo-type ?values) - "jvm lgt" (analyse-jvm-lgt analyse exo-type ?values) - "jvm fadd" (analyse-jvm-fadd analyse exo-type ?values) - "jvm fsub" (analyse-jvm-fsub analyse exo-type ?values) - "jvm fmul" (analyse-jvm-fmul analyse exo-type ?values) - "jvm fdiv" (analyse-jvm-fdiv analyse exo-type ?values) - "jvm frem" (analyse-jvm-frem analyse exo-type ?values) - "jvm feq" (analyse-jvm-feq analyse exo-type ?values) - "jvm flt" (analyse-jvm-flt analyse exo-type ?values) - "jvm fgt" (analyse-jvm-fgt analyse exo-type ?values) - "jvm dadd" (analyse-jvm-dadd analyse exo-type ?values) - "jvm dsub" (analyse-jvm-dsub analyse exo-type ?values) - "jvm dmul" (analyse-jvm-dmul analyse exo-type ?values) - "jvm ddiv" (analyse-jvm-ddiv analyse exo-type ?values) - "jvm drem" (analyse-jvm-drem analyse exo-type ?values) - "jvm deq" (analyse-jvm-deq analyse exo-type ?values) - "jvm dlt" (analyse-jvm-dlt analyse exo-type ?values) - "jvm dgt" (analyse-jvm-dgt analyse exo-type ?values) - "jvm iand" (analyse-jvm-iand analyse exo-type ?values) - "jvm ior" (analyse-jvm-ior analyse exo-type ?values) - "jvm ixor" (analyse-jvm-ixor analyse exo-type ?values) - "jvm ishl" (analyse-jvm-ishl analyse exo-type ?values) - "jvm ishr" (analyse-jvm-ishr analyse exo-type ?values) - "jvm iushr" (analyse-jvm-iushr analyse exo-type ?values) - "jvm land" (analyse-jvm-land analyse exo-type ?values) - "jvm lor" (analyse-jvm-lor analyse exo-type ?values) - "jvm lxor" (analyse-jvm-lxor analyse exo-type ?values) - "jvm lshl" (analyse-jvm-lshl analyse exo-type ?values) - "jvm lshr" (analyse-jvm-lshr analyse exo-type ?values) - "jvm lushr" (analyse-jvm-lushr analyse exo-type ?values) - "jvm convert double-to-float" (analyse-jvm-double-to-float analyse exo-type ?values) - "jvm convert double-to-int" (analyse-jvm-double-to-int analyse exo-type ?values) - "jvm convert double-to-long" (analyse-jvm-double-to-long analyse exo-type ?values) - "jvm convert float-to-double" (analyse-jvm-float-to-double analyse exo-type ?values) - "jvm convert float-to-int" (analyse-jvm-float-to-int analyse exo-type ?values) - "jvm convert float-to-long" (analyse-jvm-float-to-long analyse exo-type ?values) - "jvm convert int-to-byte" (analyse-jvm-int-to-byte analyse exo-type ?values) - "jvm convert int-to-char" (analyse-jvm-int-to-char analyse exo-type ?values) - "jvm convert int-to-double" (analyse-jvm-int-to-double analyse exo-type ?values) - "jvm convert int-to-float" (analyse-jvm-int-to-float analyse exo-type ?values) - "jvm convert int-to-long" (analyse-jvm-int-to-long analyse exo-type ?values) - "jvm convert int-to-short" (analyse-jvm-int-to-short analyse exo-type ?values) - "jvm convert long-to-double" (analyse-jvm-long-to-double analyse exo-type ?values) - "jvm convert long-to-float" (analyse-jvm-long-to-float analyse exo-type ?values) - "jvm convert long-to-int" (analyse-jvm-long-to-int analyse exo-type ?values) - "jvm convert long-to-short" (analyse-jvm-long-to-short analyse exo-type ?values) - "jvm convert long-to-byte" (analyse-jvm-long-to-byte analyse exo-type ?values) - "jvm convert char-to-byte" (analyse-jvm-char-to-byte analyse exo-type ?values) - "jvm convert char-to-short" (analyse-jvm-char-to-short analyse exo-type ?values) - "jvm convert char-to-int" (analyse-jvm-char-to-int analyse exo-type ?values) - "jvm convert char-to-long" (analyse-jvm-char-to-long analyse exo-type ?values) - "jvm convert byte-to-long" (analyse-jvm-byte-to-long analyse exo-type ?values) - "jvm convert short-to-long" (analyse-jvm-short-to-long analyse exo-type ?values) - ;; else - (->> (&/fail-with-loc (str "[Analyser Error] Unknown host procedure: " ["jvm" proc])) - (if-let [[_ _def-code] (re-find #"^jvm interface:(.*)$" proc)] - (|do [[_module _line _column] &/location] - (&reader/with-source (str "interface@" "(" _module "," _line "," _column ")") _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 #"^jvm class:(.*)$" proc)] - (|do [[_module _line _column] &/location] - (&reader/with-source (str "class@" "(" _module "," _line "," _column ")") _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 #"^jvm anon-class:(.*)$" proc)] - (|do [[_module _line _column] &/location] - (&reader/with-source (str "anon-class@" "(" _module "," _line "," _column ")") _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 #"^jvm instanceof:([^:]+)$" proc)] - (analyse-jvm-instanceof analyse exo-type _class ?values)) - - (if-let [[_ _class _arg-classes] (re-find #"^jvm 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 #"^jvm 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 #"^jvm 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 #"^jvm 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 #"^jvm 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 #"^jvm getstatic:([^:]+):([^:]+)$" proc)] - (analyse-jvm-getstatic analyse exo-type _class _field ?values)) - - (if-let [[_ _class _field] (re-find #"^jvm getfield:([^:]+):([^:]+)$" proc)] - (analyse-jvm-getfield analyse exo-type _class _field ?values)) - - (if-let [[_ _class _field] (re-find #"^jvm putstatic:([^:]+):([^:]+)$" proc)] - (analyse-jvm-putstatic analyse exo-type _class _field ?values)) - - (if-let [[_ _class _field] (re-find #"^jvm putfield:([^:]+):([^:]+)$" proc)] - (analyse-jvm-putfield analyse exo-type _class _field ?values)))) - (catch Exception ex - (&/fail-with-loc (str "[Analyser Error] Invalid syntax for procedure: " proc)))) - )) diff --git a/luxc/src/lux/analyser/record.clj b/luxc/src/lux/analyser/record.clj deleted file mode 100644 index 3d3d8169f..000000000 --- a/luxc/src/lux/analyser/record.clj +++ /dev/null @@ -1,42 +0,0 @@ -(ns lux.analyser.record - (:require clojure.core.match - clojure.core.match.array - (lux [base :as & :refer [|let |do return |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 &type/Any])) - - (&/$Cons [[_ (&/$Tag 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 - [[_ (&/$Tag k)] v] - (|do [=k (&&/resolved-ident k)] - (return (&/T [(&/ident->text =k) v]))) - - _ - (&/fail-with-loc "[Analyser Error] Wrong syntax for records. Odd elements must be tags."))) - pairs) - _ (let [num-expected (&/|length tag-group) - num-got (&/|length =pairs)] - (&/assert! (= num-expected num-got) - (str "[Analyser Error] Wrong number of record members. Expected " num-expected ", but got " num-got "."))) - =members (&/map% (fn [tag] - (if-let [member (&/|get tag =pairs)] - (return member) - (&/fail-with-loc (str "[Analyser Error] Missing tag: " tag)))) - (&/|map &/ident->text tag-group))] - (return (&/T [=members tag-type])))) diff --git a/luxc/src/lux/base.clj b/luxc/src/lux/base.clj deleted file mode 100644 index 5ef710a03..000000000 --- a/luxc/src/lux/base.clj +++ /dev/null @@ -1,1490 +0,0 @@ -(ns lux.base - (:require (clojure [template :refer [do-template]] - [string :as string]) - [clojure.core.match :as M :refer [matchv]] - clojure.core.match.array)) - -(def prelude - "lux") - -(def !log! (atom false)) -(defn flag-prn! [& args] - (when @!log! - (apply prn args))) - -;; [Tags] -(def unit-tag (.intern "")) - -(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)) - -;; Code -(defvariant - ("Bit" 1) - ("Nat" 1) - ("Int" 1) - ("Rev" 1) - ("Frac" 1) - ("Text" 1) - ("Identifier" 1) - ("Tag" 1) - ("Form" 1) - ("Tuple" 1) - ("Record" 1)) - -;; Type -(defvariant - ("Primitive" 2) - ("Sum" 2) - ("Product" 2) - ("Function" 2) - ("Parameter" 1) - ("Var" 1) - ("Ex" 1) - ("UnivQ" 2) - ("ExQ" 2) - ("Apply" 2) - ("Named" 2)) - -;; Vars -(defvariant - ("Local" 1) - ("Captured" 1)) - -;; Binding -(deftuple - ["counter" - "mappings"]) - -;; Type-Context -(deftuple - ["ex-counter" - "var-counter" - "var-bindings"]) - -;; Env -(deftuple - ["name" - "inner" - "locals" - "captured"]) - -;; Host -(deftuple - ["writer" - "loader" - "classes" - "type-env" - "dummy-mappings" - ]) - -(defvariant - ("Build" 0) - ("Eval" 0) - ("REPL" 0)) - -(deftuple - ["target" - "version" - "mode"]) - -;; Hosts -(defvariant - ("Jvm" 1) - ("Js" 1)) - -(deftuple - ["info" - "source" - "location" - "current-module" - "modules" - "scopes" - "type-context" - "expected" - "seed" - "scope-type-vars" - "extensions" - "host"]) - -(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)) - -;; [Exports] -(def ^:const value-field "_value") -(def ^:const module-class-name "_") -(def ^:const +name-separator+ ".") - -(def ^:const ^String version "0.6.0") - -;; Constructors -(def empty-location (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 (= k slot) - v - (recur slot table*)))) - -(defn |put [slot value table] - (|case table - ($Nil) - ($Cons (T [slot value]) $Nil) - - ($Cons [k v] table*) - (if (= 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 (= k slot) - table* - ($Cons (T [k v]) (|remove slot table*))))) - -(defn |update [k f table] - (|case table - ($Nil) - table - - ($Cons [k* v] table*) - (if (= 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? - "(All [a] (-> (List a) Bit))" - [xs] - (|case xs - ($Nil) - true - - ($Cons _ _) - false)) - -(defn |filter - "(All [a] (-> (-> a Bit) (List a) (List a)))" - [p xs] - (|case xs - ($Nil) - xs - - ($Cons x xs*) - (if (p x) - ($Cons x (|filter p xs*)) - (|filter p xs*)))) - -(defn flat-map - "(All [a b] (-> (-> a (List b)) (List a) (List b)))" - [f xs] - (|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 (= 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$ $location 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 "[Error] 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 "[Error] 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 ^String msg) - (if (.contains msg "[Reader Error] EOF") - (return* state unit-tag) - (fail* msg))))) - -(defn |some - "(All [a b] (-> (-> a (Maybe b)) (List a) (Maybe b)))" - [f xs] - (|case xs - ($Nil) - $None - - ($Cons x xs*) - (|case (f x) - ($None) (|some f xs*) - output output) - )) - -(defn ^:private normalize-char [char] - (case char - \* "_AS" - \+ "_PL" - \- "_DS" - \/ "_SL" - \\ "_BS" - \_ "_US" - \% "_PC" - \$ "_DL" - \' "_QU" - \` "_BQ" - \@ "_AT" - \^ "_CR" - \& "_AA" - \= "_EQ" - \! "_BG" - \? "_QM" - \: "_CO" - \; "_SC" - \. "_PD" - \, "_CM" - \< "_LT" - \> "_GT" - \~ "_TI" - \| "_PI" - ;; default - char)) - -(defn normalize-name [ident] - (reduce str "" (map normalize-char ident))) - -(def +init-bindings+ - (T [;; "lux;counter" - 0 - ;; "lux;mappings" - (|table)])) - -(def +init-type-context+ - (T [;; ex-counter - 0 - ;; var-counter - 0 - ;; var-bindings - (|table)])) - -(defn env [name old-name] - (T [;; name - ($Cons name old-name) - ;; inner - 0 - ;; locals - +init-bindings+ - ;; captured - +init-bindings+] - )) - -(do-template [<tag> <host-desc> <host> <ask> <change> <with>] - (do (def <host> - (fn [compiler] - (|case (get$ $host compiler) - (<tag> host-data) - (return* compiler host-data) - - _ - ((fail-with-loc (str "[Error] Wrong host.\nExpected: " <host-desc>)) - compiler)))) - - (def <ask> - (fn [compiler] - (|case (get$ $host compiler) - (<tag> host-data) - (return* compiler true) - - _ - (return* compiler false)))) - - (defn <change> [slot updater] - (|do [host <host>] - (fn [compiler] - (return* (set$ $host (<tag> (update$ slot updater host)) compiler) - (get$ slot host))))) - - (defn <with> [slot updater body] - (|do [old-val (<change> slot updater) - ?output-val body - new-val (<change> slot (fn [_] old-val))] - (return ?output-val)))) - - $Jvm "JVM" jvm-host jvm? change-jvm-host-slot with-jvm-host-slot - $Js "JS" js-host js? change-js-host-slot with-js-host-slot - ) - -(do-template [<name> <slot>] - (def <name> - (|do [host jvm-host] - (return (get$ <slot> host)))) - - loader $loader - classes $classes - get-type-env $type-env - ) - -(def get-writer - (|do [host jvm-host] - (|case (get$ $writer host) - ($Some writer) - (return writer) - - _ - (fail-with-loc "[Error] Writer has not been set.")))) - -(defn with-writer [writer body] - (with-jvm-host-slot $writer (fn [_] ($Some writer)) body)) - -(defn with-type-env - "(All [a] (-> TypeEnv (Meta a) (Meta a)))" - [type-env body] - (with-jvm-host-slot $type-env (partial |++ type-env) body)) - -(defn push-dummy-name [real-name store-name] - (change-jvm-host-slot $dummy-mappings (partial $Cons (T [real-name store-name])))) - -(def pop-dummy-name - (change-jvm-host-slot $dummy-mappings |tail)) - -(defn de-alias-class [class-name] - (|do [host jvm-host] - (return (|case (|some #(|let [[real-name store-name] %] - (if (= real-name class-name) - ($Some store-name) - $None)) - (get$ $dummy-mappings host)) - ($Some store-name) - store-name - - _ - class-name)))) - -(defn default-info [target mode] - (T [;; target - target - ;; version - version - ;; mode - mode] - )) - -(defn init-state [name mode host-data] - (T [;; "lux;info" - (default-info name mode) - ;; "lux;source" - $Nil - ;; "lux;location" - (T ["" -1 -1]) - ;; "current-module" - $None - ;; "lux;modules" - (|table) - ;; "lux;scopes" - $Nil - ;; "lux;type-context" - +init-type-context+ - ;; "lux;expected" - $None - ;; "lux;seed" - 0 - ;; scope-type-vars - $Nil - ;; extensions - nil - ;; "lux;host" - host-data] - )) - -(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)))) - -(do-template [<name> <tag>] - (defn <name> - "(-> CompilerMode Bit)" - [mode] - (|case mode - (<tag>) true - _ false)) - - in-eval? $Eval - in-repl? $REPL - ) - -(defn with-eval [body] - (fn [state] - (let [old-mode (->> state (get$ $info) (get$ $mode))] - (|case (body (update$ $info #(set$ $mode $Eval %) state)) - ($Right state* output) - (return* (update$ $info #(set$ $mode old-mode %) state*) output) - - ($Left msg) - (fail* msg))))) - -(def get-eval - (fn [state] - (return* state (->> state (get$ $info) (get$ $mode) in-eval?)))) - -(def get-mode - (fn [state] - (return* state (->> state (get$ $info) (get$ $mode))))) - -(def get-top-local-env - (fn [state] - (try (let [top (|head (get$ $scopes state))] - (return* state top)) - (catch Throwable _ - ((fail-with-loc "[Error] 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 (get$ $current-module state) - ($None) - ((fail-with-loc "[Analyser Error] Cannot get the module-name without a module.") - state) - - ($Some module-name) - (return* state module-name)))) - -(defn find-module - "(-> Text (Meta (Module Lux)))" - [name] - (fn [state] - (if-let [module (|get name (get$ $modules state))] - (return* state module) - ((fail-with-loc (str "[Error] Unknown module: " name)) - state)))) - -(def ^{:doc "(Meta (Module Lux))"} - get-current-module - (|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) str)))] - (fn [state] - (let [body* (with-scope closure-name body)] - (run-state body* (update$ $scopes #($Cons (update$ $inner inc (|head %)) - (|tail %)) - state)))))) - -(let [!out! *out*] - (defn |log! [& parts] - (binding [*out* !out!] - (do (print (str (apply str parts) "\n")) - (flush))))) - -(defn |last [xs] - (|case xs - ($Cons x ($Nil)) - x - - ($Cons x xs*) - (|last xs*) - - _ - (assert false (adt->text xs)))) - -(def get-scope-name - (fn [state] - (return* state (->> state (get$ $scopes) |head (get$ $name))))) - -(defn without-repl-closure [body] - (|do [_mode get-mode - current-scope get-scope-name] - (fn [state] - (let [output (body (if (and (in-repl? _mode) - (->> current-scope |last (= "REPL"))) - (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$ $mode $Build %) state) - state))] - (|case output - ($Right state* datum) - (return* (update$ $info #(set$ $mode _mode %) state*) datum) - - _ - output))))) - -(defn with-expected-type - "(All [a] (-> Type (Meta a)))" - [type body] - (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-location - "(All [a] (-> Location (Meta a)))" - [^objects location body] - (|let [[_file-name _ _] location] - (if (= "" _file-name) - body - (fn [state] - (let [output (body (set$ $location location state))] - (|case output - ($Right ?state ?value) - (return* (set$ $location (get$ $location state) ?state) - ?value) - - _ - output)))))) - -(defn with-analysis-meta - "(All [a] (-> Location Type (Meta a)))" - [^objects location type body] - (|let [[_file-name _ _] location] - (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$ $location location) - (set$ $expected ($Some type))))] - (|case output - ($Right ?state ?value) - (return* (->> ?state - (set$ $location (get$ $location state)) - (set$ $expected (get$ $expected state))) - ?value) - - _ - output)))))) - -(def ^{:doc "(Meta Any)"} - ensure-directive - (fn [state] - (|case (get$ $expected state) - ($None) - (return* state unit-tag) - - ($Some _) - ((fail-with-loc "[Error] All directives must be top-level forms.") - state)))) - -(def location - ;; (Meta Location) - (fn [state] - (return* state (get$ $location state)))) - -(def rev-bits 64) - -(let [clean-separators (fn [^String input] - (.replaceAll input "_" "")) - rev-text-to-digits (fn [^String input] - (loop [output (vec (repeat rev-bits 0)) - index (dec (.length input))] - (if (>= index 0) - (let [digit (Byte/parseByte (.substring input index (inc index)))] - (recur (assoc output index digit) - (dec index))) - output))) - times5 (fn [index digits] - (loop [index index - carry 0 - digits digits] - (if (>= index 0) - (let [raw (->> (get digits index) (* 5) (+ carry))] - (recur (dec index) - (int (/ raw 10)) - (assoc digits index (rem raw 10)))) - digits))) - rev-digit-power (fn [level] - (loop [output (-> (vec (repeat rev-bits 0)) - (assoc level 1)) - times level] - (if (>= times 0) - (recur (times5 level output) - (dec times)) - output))) - rev-digits-lt (fn rev-digits-lt - ([subject param index] - (and (< index rev-bits) - (or (< (get subject index) - (get param index)) - (and (= (get subject index) - (get param index)) - (rev-digits-lt subject param (inc index)))))) - ([subject param] - (rev-digits-lt subject param 0))) - rev-digits-sub-once (fn [subject param-digit index] - (if (>= (get subject index) - param-digit) - (update-in subject [index] #(- % param-digit)) - (recur (update-in subject [index] #(- 10 (- param-digit %))) - 1 - (dec index)))) - rev-digits-sub (fn [subject param] - (loop [target subject - index (dec rev-bits)] - (if (>= index 0) - (recur (rev-digits-sub-once target (get param index) index) - (dec index)) - target))) - rev-digits-to-text (fn [digits] - (loop [output "" - index (dec rev-bits)] - (if (>= index 0) - (recur (-> (get digits index) - (Character/forDigit 10) - (str output)) - (dec index)) - output))) - add-rev-digit-powers (fn [dl dr] - (loop [index (dec rev-bits) - output (vec (repeat rev-bits 0)) - carry 0] - (if (>= index 0) - (let [raw (+ carry - (get dl index) - (get dr index))] - (recur (dec index) - (assoc output index (rem raw 10)) - (int (/ raw 10)))) - output)))] - ;; Based on the LuxRT.encode_rev method - (defn encode-rev [input] - (if (= 0 input) - ".0" - (loop [index (dec rev-bits) - output (vec (repeat rev-bits 0))] - (if (>= index 0) - (recur (dec index) - (if (bit-test input index) - (->> (- (dec rev-bits) index) - rev-digit-power - (add-rev-digit-powers output)) - output)) - (-> output rev-digits-to-text - (->> (str ".")) - (.split "0*$") - (aget 0)))))) - - ;; Based on the LuxRT.decode_rev method - (defn decode-rev [^String input] - (if (and (.startsWith input ".") - (<= (.length input) (inc rev-bits))) - (loop [digits-left (-> input - (.substring 1) - clean-separators - rev-text-to-digits) - index 0 - ouput 0] - (if (< index rev-bits) - (let [power-slice (rev-digit-power index)] - (if (not (rev-digits-lt digits-left power-slice)) - (recur (rev-digits-sub digits-left power-slice) - (inc index) - (bit-set ouput (- (dec rev-bits) index))) - (recur digits-left - (inc index) - ouput))) - ouput)) - (throw (new java.lang.Exception (str "Bad format for Rev number: " input))))) - ) - -(defn show-ast [ast] - (|case ast - [_ ($Bit ?value)] - (pr-str ?value) - - [_ ($Nat ?value)] - (Long/toUnsignedString ?value) - - [_ ($Int ?value)] - (if (< ?value 0) - (pr-str ?value) - (str "+" (pr-str ?value))) - - [_ ($Rev ?value)] - (encode-rev ?value) - - [_ ($Frac ?value)] - (pr-str ?value) - - [_ ($Text ?value)] - (str "\"" ?value "\"") - - [_ ($Tag ?module ?tag)] - (if (.equals "" ?module) - (str "#" ?tag) - (str "#" ?module +name-separator+ ?tag)) - - [_ ($Identifier ?module ?name)] - (if (.equals "" ?module) - ?name - (str ?module +name-separator+ ?name)) - - [_ ($Tuple ?elems)] - (str "[" (->> ?elems (|map show-ast) (|interpose " ") (fold str "")) "]") - - [_ ($Record ?elems)] - (str "{" (->> ?elems - (|map (fn [elem] - (|let [[k v] elem] - (str (show-ast k) " " (show-ast v))))) - (|interpose " ") (fold str "")) "}") - - [_ ($Form ?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-separator+ ?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 do not 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 do not 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* - "(All [a] (-> Int (List a) (List (, Int a))))" - [idx xs] - (|case xs - ($Cons x xs*) - ($Cons (T [idx x]) - (enumerate* (inc idx) xs*)) - - ($Nil) - xs - )) - -(defn enumerate - "(All [a] (-> (List a) (List (, Int a))))" - [xs] - (enumerate* 0 xs)) - -(def ^{:doc "(Meta (List Text))"} - modules - (fn [state] - (return* state (|keys (get$ $modules state))))) - -(defn when% - "(-> Bit (Meta Any) (Meta Any))" - [test body] - (if test - body - (return unit-tag))) - -(defn |at - "(All [a] (-> Int (List a) (Maybe a)))" - [idx xs] - (|case xs - ($Cons x xs*) - (cond (< idx 0) - $None - - (= idx 0) - ($Some x) - - :else ;; > 1 - (|at (dec idx) xs*)) - - ($Nil) - $None)) - -(defn normalize - "(-> Ident (Meta Ident))" - [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 [<name> <default> <op>] - (defn <name> - "(All [a] (-> (-> a Bit) (List a) Bit))" - [p xs] - (|case xs - ($Nil) - <default> - - ($Cons x xs*) - (<op> (p x) (<name> p xs*)))) - - |every? true and - |any? false or) - -(defn m-comp - "(All [a b c] (-> (-> b (Meta c)) (-> a (Meta b)) (-> a (Meta c))))" - [f g] - (fn [x] - (|do [y (g x)] - (f y)))) - -(defn with-attempt - "(All [a] (-> (Meta a) (-> Text (Meta a)) (Meta a)))" - [m-value on-error] - (fn [state] - (|case (m-value state) - ($Left msg) - ((on-error msg) state) - - output - output))) - -(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 |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 with-module [name body] - (fn [state] - (|case (body (set$ $current-module ($Some name) state)) - ($Right [state* output]) - ($Right (T [(set$ $current-module (get$ $current-module state) state*) - output])) - - ($Left msg) - ($Left msg)))) - -(defn |eitherL [left right] - (fn [compiler] - (|case (run-state left compiler) - ($Left _error) - (run-state right compiler) - - _output - _output))) - -(defn timed% [what when operation] - (fn [state] - (let [pre (System/currentTimeMillis)] - (|case (operation state) - ($Right state* output) - (let [post (System/currentTimeMillis) - duration (- post pre) - _ (|log! (str what " [" when "]: +" duration "ms"))] - ($Right (T [state* output]))) - - ($Left ^String msg) - (fail* msg))))) diff --git a/luxc/src/lux/compiler.clj b/luxc/src/lux/compiler.clj deleted file mode 100644 index a3e60e463..000000000 --- a/luxc/src/lux/compiler.clj +++ /dev/null @@ -1,29 +0,0 @@ -(ns lux.compiler - (:refer-clojure :exclude [compile]) - (:require clojure.core.match - clojure.core.match.array - (lux [base :as & :refer [|let |do return* return |case]]) - (lux.compiler [core :as &&core] - [io :as &&io] - [parallel :as &¶llel] - [jvm :as &&jvm]))) - -(defn init! [dependencies ^String target-dir] - (do (reset! &&core/!output-dir target-dir) - (&¶llel/setup!) - (&&io/init-libs! dependencies) - (.mkdirs (new java.io.File target-dir)) - (&&jvm/init!))) - -(def all-compilers - &&jvm/all-compilers) - -(defn eval! [expr] - (&&jvm/eval! expr)) - -(defn compile-module [source-dirs name] - (&&jvm/compile-module source-dirs name)) - -(defn compile-program [mode program-module dependencies source-dirs target-dir] - (init! dependencies target-dir) - (&&jvm/compile-program mode program-module source-dirs)) diff --git a/luxc/src/lux/compiler/cache.clj b/luxc/src/lux/compiler/cache.clj deleted file mode 100644 index 01e05c8de..000000000 --- a/luxc/src/lux/compiler/cache.clj +++ /dev/null @@ -1,244 +0,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 |case |let]] - [type :as &type] - [host :as &host]) - (lux.analyser [base :as &a] - [module :as &a-module]) - (lux.compiler [core :as &&core] - [io :as &&io]) - (lux.compiler.cache [type :as &&&type] - [ann :as &&&ann])) - (:import (java.io File) - )) - -;; [Resources] -(defn ^:private delete-all-module-files [^File file] - (doseq [^File f (seq (.listFiles file)) - :when (not (.isDirectory f))] - (.delete f))) - -(defn ^:private ^String module-path [module] - (str @&&core/!output-dir - java.io.File/separator - (.replace ^String (&host/->module-class module) "/" java.io.File/separator))) - -(defn cached? - "(-> Text Bit)" - [module] - (.exists (new File (str (module-path module) java.io.File/separator &&core/lux-module-descriptor-name)))) - -(defn delete - "(-> Text (Lux Null))" - [module] - (fn [state] - (do (delete-all-module-files (new File (module-path module))) - (return* state nil)))) - -(defn ^:private module-dirs - "(-> File (clojure.Seq File))" - [^File module] - (->> module - .listFiles - (filter #(.isDirectory ^File %)) - (map module-dirs) - (apply concat) - (list* module))) - -(defn clean - "(-> Lux Null)" - [state] - (let [needed-modules (->> state (&/get$ &/$modules) &/|keys &/->seq set) - output-dir-prefix (str (.getAbsolutePath (new File ^String @&&core/!output-dir)) java.io.File/separator) - outdated? #(->> % (contains? needed-modules) not) - outdated-modules (->> (new File ^String @&&core/!output-dir) - .listFiles (filter #(.isDirectory ^File %)) - (map module-dirs) doall (apply concat) - (map (fn [^File dir-file] - (let [^String dir-module (-> dir-file - .getAbsolutePath - (string/replace output-dir-prefix "")) - corrected-dir-module (.replace dir-module java.io.File/separator "/")] - corrected-dir-module))) - (filter outdated?))] - (doseq [^String f outdated-modules] - (delete-all-module-files (new File (str output-dir-prefix f)))) - nil)) - -(defn ^:private parse-tag-groups [^String tags-section] - (if (= "" tags-section) - &/$Nil - (-> tags-section - (.split &&core/entry-separator) - seq - (->> (map (fn [^String _group] - (let [[_type & _tags] (.split _group &&core/datum-separator)] - (&/T [_type (->> _tags seq &/->list)]))))) - &/->list))) - -(defn ^:private process-tag-group [module group] - (|let [[_type _tags] group] - (|do [[was-exported? =type] (&a-module/type-def module _type)] - (&a-module/declare-tags module _tags was-exported? =type)))) - -(defn make-tag [ident] - (&/T [(&/T ["" 0 0]) (&/$Tag ident)])) - -(defn make-identifier [ident] - (&/T [(&/T ["" 0 0]) (&/$Identifier ident)])) - -(defn make-record [ident] - (&/T [(&/T ["" 0 0]) (&/$Record ident)])) - -(defn ^:private process-def-entry [load-def-value module ^String _def-entry] - (let [parts (.split _def-entry &&core/datum-separator)] - (case (alength parts) - 2 (let [[_name ^String _alias] parts - [__module __name] (.split _alias &/+name-separator+)] - (&a-module/define-alias module _name (&/T [__module __name]))) - 4 (let [[_name _exported? _type _anns] parts - [def-anns _] (&&&ann/deserialize _anns) - [def-type _] (&&&type/deserialize-type _type)] - (|do [def-value (load-def-value module _name)] - (&a-module/define module _name (= "1" _exported?) def-type def-anns def-value)))))) - -(defn ^:private uninstall-cache [module] - (|do [_ (delete module)] - (return false))) - -(defn ^:private install-module [load-def-value module module-hash imports tag-groups ?module-anns def-entries] - (|do [_ (&a-module/create-module module module-hash) - _ (&a-module/flag-cached-module module) - _ (|case ?module-anns - (&/$Some module-anns) - (&a-module/set-anns module-anns module) - - (&/$None _) - (return nil)) - _ (&a-module/set-imports imports) - _ (&/map% (partial process-def-entry load-def-value module) - def-entries) - _ (&/map% (partial process-tag-group module) tag-groups)] - (return nil))) - -(defn ^:private process-module [pre-load! source-dirs cache-table module-name module-hash - _imports-section _tags-section _module-anns-section _defs-section - load-def-value install-all-defs-in-module uninstall-all-defs-in-module] - (|do [^String descriptor (&&core/read-module-descriptor! module-name) - :let [imports (let [imports (vec (.split ^String _imports-section &&core/entry-separator)) - imports (if (= [""] imports) - &/$Nil - (&/->list imports))] - (&/|map #(first (vec (.split ^String % &&core/datum-separator 2))) imports))] - cache-table* (&/fold% (fn [cache-table* _module] - (|do [[file-name file-content] (&&io/read-file source-dirs _module) - output (pre-load! source-dirs cache-table* _module (hash file-content) - load-def-value install-all-defs-in-module uninstall-all-defs-in-module)] - (return output))) - cache-table - imports)] - (if (&/|every? (fn [_module] (contains? cache-table* _module)) - imports) - (let [tag-groups (parse-tag-groups _tags-section) - [?module-anns _] (if (= "..." _module-anns-section) - [&/$None nil] - (let [[module-anns _] (&&&ann/deserialize _module-anns-section)] - [(&/$Some module-anns) _])) - def-entries (let [def-entries (vec (.split ^String _defs-section &&core/entry-separator))] - (if (= [""] def-entries) - &/$Nil - (&/->list def-entries)))] - (|do [_ (install-all-defs-in-module module-name) - _ (install-module load-def-value module-name module-hash - imports tag-groups ?module-anns def-entries) - =module (&/find-module module-name)] - (return (&/T [true (assoc cache-table* module-name =module)])))) - (return (&/T [false cache-table*]))))) - -(defn ^:private enumerate-cached-modules!* [^File parent] - (if (.isDirectory parent) - (let [children (for [^File child (seq (.listFiles parent)) - entry (enumerate-cached-modules!* child)] - entry)] - (if (.exists (new File parent &&core/lux-module-descriptor-name)) - (list* (.getAbsolutePath parent) - children) - children)) - (list))) - -(defn ^:private enumerate-cached-modules! [] - (let [output-dir (new File ^String @&&core/!output-dir) - prefix-to-subtract (inc (.length (.getAbsolutePath output-dir)))] - (->> output-dir - enumerate-cached-modules!* - rest - (map #(-> ^String % - (.replace java.io.File/separator "/") - (.substring prefix-to-subtract))) - &/->list))) - -(defn ^:private pre-load! [source-dirs cache-table module-name module-hash - load-def-value install-all-defs-in-module uninstall-all-defs-in-module] - (cond (contains? cache-table module-name) - (return cache-table) - - (not (cached? module-name)) - (return cache-table) - - :else - (|do [^String descriptor (&&core/read-module-descriptor! module-name) - :let [[_compiler _hash _imports-section _tags-section _module-anns-section _defs-section] (.split descriptor &&core/section-separator) - drop-cache! (|do [_ (uninstall-cache module-name) - _ (uninstall-all-defs-in-module module-name)] - (return cache-table))]] - (if (and (= module-hash (Long/parseUnsignedLong ^String _hash)) - (= &/version _compiler)) - (|do [[success? cache-table*] (process-module pre-load! source-dirs cache-table module-name module-hash - _imports-section _tags-section _module-anns-section _defs-section - load-def-value install-all-defs-in-module uninstall-all-defs-in-module) - _ (if success? - (return nil) - drop-cache!)] - (return cache-table*)) - drop-cache!)))) - -(def ^:private !pre-loaded-cache (atom nil)) -(defn pre-load-cache! [source-dirs - load-def-value install-all-defs-in-module uninstall-all-defs-in-module] - (|do [:let [fs-cached-modules (enumerate-cached-modules!)] - pre-loaded-modules (&/fold% (fn [cache-table module-name] - (fn [_compiler] - (|case ((&&io/read-file source-dirs module-name) - _compiler) - (&/$Left error) - (return* _compiler cache-table) - - (&/$Right _compiler* [file-name file-content]) - ((pre-load! source-dirs cache-table module-name (hash file-content) - load-def-value install-all-defs-in-module uninstall-all-defs-in-module) - _compiler*)))) - {} - fs-cached-modules) - :let [_ (reset! !pre-loaded-cache pre-loaded-modules)]] - (return nil))) - -(defn ^:private inject-module - "(-> Module Lux (Lux Null))" - [module-name module] - (fn [compiler] - (return* (&/update$ &/$modules - #(&/|put module-name module %) - compiler) - nil))) - -(defn load - "(-> Text (Lux Null))" - [module-name] - (if-let [module-struct (get @!pre-loaded-cache module-name)] - (|do [_ (inject-module module-name module-struct)] - (return nil)) - (&/fail (str "[Cache Error] Module is not cached: " module-name)))) diff --git a/luxc/src/lux/compiler/cache/ann.clj b/luxc/src/lux/compiler/cache/ann.clj deleted file mode 100644 index 4c08af276..000000000 --- a/luxc/src/lux/compiler/cache/ann.clj +++ /dev/null @@ -1,138 +0,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 |case]]))) - -(def ^:private stop (->> 7 char str)) -(def ^:private cons-signal (->> 5 char str)) -(def ^:private nil-signal (->> 6 char str)) - -(defn ^:private serialize-seq [serialize params] - (str (&/fold (fn [so-far param] - (str so-far cons-signal (serialize param))) - "" - params) - nil-signal)) - -(defn ^:private serialize-ident [ident] - (|let [[module name] ident] - (str module &/+name-separator+ name))) - -(defn serialize - "(-> Code Text)" - [ann] - (|case ann - [_ (&/$Bit value)] - (str "B" value stop) - - [_ (&/$Nat value)] - (str "N" value stop) - - [_ (&/$Int value)] - (str "I" value stop) - - [_ (&/$Rev value)] - (str "D" value stop) - - [_ (&/$Frac value)] - (str "F" value stop) - - [_ (&/$Text value)] - (str "T" value stop) - - [_ (&/$Identifier ident)] - (str "@" (serialize-ident ident) stop) - - [_ (&/$Tag ident)] - (str "#" (serialize-ident ident) stop) - - [_ (&/$Form elems)] - (str "(" (serialize-seq serialize elems)) - - [_ (&/$Tuple elems)] - (str "[" (serialize-seq serialize elems)) - - [_ (&/$Record kvs)] - (str "{" (serialize-seq (fn [kv] - (|let [[k v] kv] - (str (serialize k) - (serialize v)))) - kvs)) - - _ - (assert false) - )) - -(declare deserialize) - -(def dummy-location - (&/T ["" 0 0])) - -(do-template [<name> <signal> <ctor> <parser>] - (defn <name> [^String input] - (when (.startsWith input <signal>) - (let [[value* ^String input*] (.split (.substring input 1) stop 2)] - [(&/T [dummy-location (<ctor> (<parser> value*))]) input*]))) - - ^:private deserialize-bit "B" &/$Bit Boolean/parseBoolean - ^:private deserialize-nat "N" &/$Nat Long/parseLong - ^:private deserialize-int "I" &/$Int Long/parseLong - ^:private deserialize-rev "D" &/$Rev Long/parseLong - ^:private deserialize-frac "F" &/$Frac Double/parseDouble - ^:private deserialize-text "T" &/$Text identity - ) - -(do-template [<name> <marker> <tag>] - (defn <name> [^String input] - (when (.startsWith input <marker>) - (let [[^String ident* ^String input*] (.split (.substring input 1) stop 2) - [_module _name] (.split ident* "\\." 2)] - [(&/T [dummy-location (<tag> (&/T [_module _name]))]) input*]))) - - ^:private deserialize-identifier "@" &/$Identifier - ^:private deserialize-tag "#" &/$Tag) - -(defn ^:private deserialize-seq [deserializer ^String 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*])) - )) - -(defn ^:private deserialize-kv [input] - (when-let [[key input*] (deserialize input)] - (when-let [[ann input*] (deserialize input*)] - [(&/T [key ann]) input*]))) - -(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))] - [(&/T [dummy-location (<type> elems)]) input*]))) - - ^:private deserialize-form "(" &/$Form deserialize - ^:private deserialize-tuple "[" &/$Tuple deserialize - ^:private deserialize-record "{" &/$Record deserialize-kv - ) - -(defn deserialize - "(-> Text V[Code Text])" - [input] - (or (deserialize-bit input) - (deserialize-nat input) - (deserialize-int input) - (deserialize-rev input) - (deserialize-frac input) - (deserialize-text input) - (deserialize-identifier input) - (deserialize-tag input) - (deserialize-form input) - (deserialize-tuple input) - (deserialize-record input) - (assert false "[Cache Error] Cannot deserialize annocation."))) diff --git a/luxc/src/lux/compiler/cache/type.clj b/luxc/src/lux/compiler/cache/type.clj deleted file mode 100644 index 7c622d2c4..000000000 --- a/luxc/src/lux/compiler/cache/type.clj +++ /dev/null @@ -1,143 +0,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 |case]] - [type :as &type]))) - -(def ^:private stop (->> 7 char str)) -(def ^:private cons-signal (->> 5 char str)) -(def ^:private nil-signal (->> 6 char str)) - -(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 (&type/type= &type/Type type) - "T" - (|case type - (&/$Primitive name params) - (str "^" name stop (serialize-list serialize-type params)) - - (&/$Product left right) - (str "*" (serialize-type left) (serialize-type right)) - - (&/$Sum left right) - (str "+" (serialize-type left) (serialize-type right)) - - (&/$Function 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)) - - (&/$Parameter idx) - (str "$" idx stop) - - (&/$Ex idx) - (str "!" idx stop) - - (&/$Var idx) - (str "?" idx stop) - - (&/$Apply left right) - (str "%" (serialize-type left) (serialize-type right)) - - (&/$Named [module name] type*) - (str "@" module &/+name-separator+ name stop (serialize-type type*)) - - _ - (assert false (prn 'serialize-type (&type/show-type type))) - ))) - -(declare deserialize-type) - -(defn ^:private deserialize-list [^String 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*])) - )) - -(defn ^:private deserialize-type* [^String input] - (when (.startsWith input "T") - [&type/Type (.substring input 1)])) - -(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 "+" &/$Sum - ^:private deserialize-prod "*" &/$Product - ^:private deserialize-lambda ">" &/$Function - ^:private deserialize-app "%" &/$Apply - ) - -(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-parameter "$" &/$Parameter - ^:private deserialize-ex "!" &/$Ex - ^:private deserialize-var "?" &/$Var - ) - -(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 "\\." 2)] - (when-let [[type* ^String input*] (deserialize-type input*)] - [(&/$Named (&/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*)] - [(&/$Primitive name params) input*])))) - -(defn deserialize-type - "(-> Text Type)" - [input] - (or (deserialize-type* input) - (deserialize-sum input) - (deserialize-prod input) - (deserialize-lambda input) - (deserialize-app input) - (deserialize-parameter input) - (deserialize-ex input) - (deserialize-var input) - (deserialize-named input) - (deserialize-univq input) - (deserialize-exq input) - (deserialize-host input) - (assert false (str "[Cache error] Cannot deserialize type. --- " input)))) diff --git a/luxc/src/lux/compiler/core.clj b/luxc/src/lux/compiler/core.clj deleted file mode 100644 index 88da626bd..000000000 --- a/luxc/src/lux/compiler/core.clj +++ /dev/null @@ -1,93 +0,0 @@ -(ns lux.compiler.core - (: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 [|case |let |do return* return fail*]]) - (lux.analyser [base :as &a] - [module :as &a-module]) - (lux.compiler.cache [type :as &&&type] - [ann :as &&&ann])) - (:import (java.io File - BufferedOutputStream - FileOutputStream))) - -;; [Constants] -(def !output-dir (atom nil)) - -(def ^:const section-separator (->> 29 char str)) -(def ^:const datum-separator (->> 31 char str)) -(def ^:const entry-separator (->> 30 char str)) - -;; [Utils] -(defn write-file [^String file-name ^bytes data] - (do (assert (not (.exists (File. file-name))) (str "Cannot overwrite file: " file-name)) - (with-open [stream (BufferedOutputStream. (FileOutputStream. file-name))] - (.write stream data) - (.flush stream)))) - -;; [Exports] -(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 java.io.File/separator (.replace name "/" java.io.File/separator)) - _ (.mkdirs (File. lmd-dir)) - _ (write-file (str lmd-dir java.io.File/separator 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 java.io.File/separator (.replace name "/" java.io.File/separator) java.io.File/separator lux-module-descriptor-name) - :encoding "UTF-8")))) - -(defn generate-module-descriptor [file-hash] - (|do [module-name &/get-module-name - ?module-anns (&a-module/get-anns module-name) - defs &a-module/defs - imports &a-module/imports - tag-groups &a-module/tag-groups - :let [def-entries (->> defs - (&/|map (fn [_def] - (|let [[?name _definition] _def] - (|case _definition - (&/$Left [_dmodule _dname]) - (str ?name datum-separator _dmodule &/+name-separator+ _dname) - - (&/$Right [exported? ?def-type ?def-anns ?def-value]) - (str ?name - datum-separator (if exported? "1" "0") - datum-separator (&&&type/serialize-type ?def-type) - datum-separator (&&&ann/serialize ?def-anns)))))) - (&/|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 &/version - (Long/toUnsignedString file-hash) - import-entries - tag-entries - (|case ?module-anns - (&/$Some module-anns) - (&&&ann/serialize module-anns) - - (&/$None _) - "...") - def-entries) - (&/|interpose section-separator) - (&/fold str ""))]] - (return module-descriptor))) diff --git a/luxc/src/lux/compiler/io.clj b/luxc/src/lux/compiler/io.clj deleted file mode 100644 index d3658edd3..000000000 --- a/luxc/src/lux/compiler/io.clj +++ /dev/null @@ -1,36 +0,0 @@ -(ns lux.compiler.io - (:require (lux [base :as & :refer [|case |let |do return* return fail*]]) - (lux.compiler.jvm [base :as &&]) - [lux.lib.loader :as &lib])) - -;; [Utils] -(def ^:private !libs (atom nil)) - -;; [Resources] -(defn init-libs! [dependencies] - (reset! !libs (&lib/load dependencies))) - -(defn read-file [source-dirs module-name] - (let [^String host-file-name (str module-name ".old.lux") - ^String lux-file-name (str module-name ".lux")] - (|case (&/|some (fn [^String source-dir] - (let [host-file (new java.io.File source-dir host-file-name) - lux-file (new java.io.File source-dir lux-file-name)] - (cond (.exists host-file) - (&/$Some (&/T [host-file-name host-file])) - - (.exists lux-file) - (&/$Some (&/T [lux-file-name lux-file])) - - :else - &/$None))) - source-dirs) - (&/$Some [file-name file]) - (return (&/T [file-name (slurp file)])) - - (&/$None) - (if-let [code (get @!libs host-file-name)] - (return (&/T [host-file-name code])) - (if-let [code (get @!libs lux-file-name)] - (return (&/T [lux-file-name code])) - (&/fail-with-loc (str "[I/O Error] Module does not exist: " module-name))))))) diff --git a/luxc/src/lux/compiler/jvm.clj b/luxc/src/lux/compiler/jvm.clj deleted file mode 100644 index 07c28dfac..000000000 --- a/luxc/src/lux/compiler/jvm.clj +++ /dev/null @@ -1,256 +0,0 @@ -(ns lux.compiler.jvm - (: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 |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 [core :as &&core] - [io :as &&io] - [cache :as &&cache] - [parallel :as &¶llel]) - (lux.compiler.jvm [base :as &&] - [lux :as &&lux] - [case :as &&case] - [function :as &&function] - [rt :as &&rt] - [cache :as &&jvm-cache]) - (lux.compiler.jvm.proc [common :as &&proc-common] - [host :as &&proc-host])) - (:import (org.objectweb.asm Opcodes - Label - ClassWriter - MethodVisitor))) - -;; [Resources] -(def ^:private !source->last-line (atom nil)) - -(defn ^:private 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/$bit ?value) - (&&lux/compile-bit ?value) - - (&o/$nat ?value) - (&&lux/compile-nat ?value) - - (&o/$int ?value) - (&&lux/compile-int ?value) - - (&o/$rev ?value) - (&&lux/compile-rev ?value) - - (&o/$frac ?value) - (&&lux/compile-frac ?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/$def ?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) - (&&function/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) - (if (= "jvm" ?proc-category) - (&&proc-host/compile-proc (partial compile-expression $begin) ?proc-name ?args special-args) - (&&proc-common/compile-proc (partial compile-expression $begin) ?proc-category ?proc-name ?args special-args)) - - _ - (assert false (prn-str 'compile-expression (&/adt->text syntax))) - )) - )) - -(defn init! - "(-> Null)" - [] - (reset! !source->last-line {})) - -(defn eval! [expr] - (&/with-eval - (|do [module &/get-module-name - id &/gen-id - [file-name _ _] &/location - :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) &/value-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 &/value-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 &/value-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*) - (fn [macro args state] (.apply macro args state)) - (partial &&proc-host/compile-jvm-class compile-expression*) - &&proc-host/compile-jvm-interface]))) - -(defn ^:private activate-module! [name file-hash] - (|do [_ (&&cache/delete name) - _ (&a-module/create-module name file-hash)] - (&a-module/flag-active-module name))) - -(defn ^:private save-module! [name file-hash class-bytes] - (|do [_ (&a-module/flag-compiled-module name) - _ (&&/save-class! &/module-class-name class-bytes) - module-descriptor (&&core/generate-module-descriptor file-hash)] - (&&core/write-module-descriptor! name module-descriptor))) - -(let [+field-flags+ (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_STATIC) - +datum-sig+ "Ljava/lang/Object;"] - (defn compile-module [source-dirs name] - (|do [[file-name file-content] (&&io/read-file source-dirs name) - :let [file-hash (hash file-content) - compile-module!! (&¶llel/parallel-compilation (partial compile-module source-dirs))]] - (&/|eitherL (&&cache/load name) - (|do [module-exists? (&a-module/exists? name)] - (if module-exists? - (&/fail-with-loc (str "[Compiler Error] Cannot re-define a module: " name)) - (|do [_ (activate-module! name file-hash) - :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) - (.visitSource file-name nil))] - _ (if (= "lux" name) - (|do [_ &&rt/compile-Function-class - _ &&rt/compile-LuxRT-class] - (return nil)) - (return nil)) - :let [compiler-step (&analyser/analyse &optimizer/optimize eval! compile-module!! all-compilers)]] - (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)] - _ (save-module! name file-hash (.toByteArray =class))] - (return file-hash)) - ?state) - - (&/$Left ?message) - (&/fail* ?message))))))) - ))) - -(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)))))))) - -(defn jvm-host [] - (let [store (atom {})] - (&/$Jvm (&/T [;; "lux;writer" - &/$None - ;; "lux;loader" - (memory-class-loader store) - ;; "lux;classes" - store - ;; lux;type-env - (&/|table) - ;; lux;dummy-mappings - (&/|table) - ])))) - -(let [!err! *err*] - (defn compile-program [mode program-module source-dirs] - (let [m-action (|do [_ (&&cache/pre-load-cache! source-dirs - &&jvm-cache/load-def-value - &&jvm-cache/install-all-defs-in-module - &&jvm-cache/uninstall-all-defs-in-module) - _ (compile-module source-dirs "lux")] - (compile-module source-dirs program-module))] - (|case (m-action (&/init-state "{old}" mode (jvm-host))) - (&/$Right ?state _) - (do (println "Compilation complete!") - (&&cache/clean ?state)) - - (&/$Left ?message) - (binding [*out* !err!] - (do (println (str "Compilation failed:\n" ?message)) - (flush) - (System/exit 1))) - )))) diff --git a/luxc/src/lux/compiler/jvm/base.clj b/luxc/src/lux/compiler/jvm/base.clj deleted file mode 100644 index b5e520de5..000000000 --- a/luxc/src/lux/compiler/jvm/base.clj +++ /dev/null @@ -1,88 +0,0 @@ -(ns lux.compiler.jvm.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*]] - [type :as &type] - [host :as &host]) - (lux.analyser [base :as &a] - [module :as &a-module]) - [lux.host.generics :as &host-generics] - [lux.compiler.core :as &&]) - (:import (org.objectweb.asm Opcodes - Label - ClassWriter - MethodVisitor) - (java.io File - BufferedOutputStream - FileOutputStream) - (java.lang.reflect Field))) - -;; [Constants] -(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_") - -;; [Utils] -(defn ^:private write-output [module name data] - (let [^String module* (&host/->module-class module) - module-dir (str @&&/!output-dir java.io.File/separator (.replace module* "/" java.io.File/separator))] - (.mkdirs (File. module-dir)) - (&&/write-file (str module-dir java.io.File/separator name ".class") data))) - -(defn class-exists? - "(-> Text Text (IO Bit))" - [^String module ^String class-name] - (|do [_ (return nil) - :let [full-path (str @&&/!output-dir java.io.File/separator module java.io.File/separator class-name ".class") - exists? (.exists (File. full-path))]] - (return exists?))) - -;; [Exports] -(defn ^Class load-class! [^ClassLoader loader 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))) - -(do-template [<wrap-name> <unwrap-name> <class> <unwrap-method> <prim> <dup>] - (do (defn <wrap-name> [^MethodVisitor writer] - (doto writer - (.visitMethodInsn Opcodes/INVOKESTATIC <class> "valueOf" (str "(" <prim> ")" (&host-generics/->type-signature <class>))))) - (defn <unwrap-name> [^MethodVisitor writer] - (doto writer - (.visitTypeInsn Opcodes/CHECKCAST <class>) - (.visitMethodInsn Opcodes/INVOKEVIRTUAL <class> <unwrap-method> (str "()" <prim>))))) - - wrap-boolean unwrap-boolean "java/lang/Boolean" "booleanValue" "Z" Opcodes/DUP_X1 - wrap-byte unwrap-byte "java/lang/Byte" "byteValue" "B" Opcodes/DUP_X1 - wrap-short unwrap-short "java/lang/Short" "shortValue" "S" Opcodes/DUP_X1 - wrap-int unwrap-int "java/lang/Integer" "intValue" "I" Opcodes/DUP_X1 - wrap-long unwrap-long "java/lang/Long" "longValue" "J" Opcodes/DUP_X2 - wrap-float unwrap-float "java/lang/Float" "floatValue" "F" Opcodes/DUP_X1 - wrap-double unwrap-double "java/lang/Double" "doubleValue" "D" Opcodes/DUP_X2 - wrap-char unwrap-char "java/lang/Character" "charValue" "C" Opcodes/DUP_X1 - ) diff --git a/luxc/src/lux/compiler/jvm/cache.clj b/luxc/src/lux/compiler/jvm/cache.clj deleted file mode 100644 index f54eacc92..000000000 --- a/luxc/src/lux/compiler/jvm/cache.clj +++ /dev/null @@ -1,63 +0,0 @@ -(ns lux.compiler.jvm.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 |case |let]] - [type :as &type] - [host :as &host]) - [lux.host.generics :as &host-generics] - (lux.analyser [base :as &a] - [module :as &a-module]) - (lux.compiler [core :as &&core] - [io :as &&io]) - (lux.compiler.jvm [base :as &&])) - (:import (java.io File) - (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 get-field [^String field-name ^Class class] - "(-> Text Class Object)" - (-> class ^Field (.getField field-name) (.get nil))) - -;; [Resources] -(defn load-def-value [module name] - (|do [loader &/loader - :let [def-class (&&/load-class! loader (str (&host-generics/->class-name module) "." (&host/def-name name)))]] - (return (get-field &/value-field def-class)))) - -(defn install-all-defs-in-module [module-name] - (|do [!classes &/classes - :let [module-path (str @&&core/!output-dir java.io.File/separator module-name) - file-name+content (for [^File file (seq (.listFiles (new File module-path))) - :when (not (.isDirectory file)) - :let [file-name (.getName file)]] - [(second (re-find #"^(.*)\.class$" file-name)) - (read-file file)]) - _ (doseq [[file-name content] file-name+content] - (swap! !classes assoc (str (&host-generics/->class-name module-name) - "." - file-name) - content))]] - (return (map first file-name+content)))) - -(defn uninstall-all-defs-in-module [module-name] - (|do [!classes &/classes - :let [module-path (str @&&core/!output-dir java.io.File/separator module-name) - installed-files (for [^File file (seq (.listFiles (new File module-path))) - :when (not (.isDirectory file)) - :let [file-name (.getName file)]] - (second (re-find #"^(.*)\.class$" file-name))) - _ (swap! !classes (fn [_classes-dict] - (reduce dissoc _classes-dict installed-files)))]] - (return nil))) diff --git a/luxc/src/lux/compiler/jvm/case.clj b/luxc/src/lux/compiler/jvm/case.clj deleted file mode 100644 index b7cdb7571..000000000 --- a/luxc/src/lux/compiler/jvm/case.clj +++ /dev/null @@ -1,207 +0,0 @@ -(ns lux.compiler.jvm.case - (:require (clojure [set :as set] - [template :refer [do-template]]) - clojure.core.match - clojure.core.match.array - (lux [base :as & :refer [|do return* return |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.jvm.base :as &&] - [lux.compiler.jvm.rt :as &rt]) - (: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) - &rt/peekI)) - -(defn ^:private compile-pattern* - "(-> MethodVisitor Case-Pattern (List Label) Int Label MethodVisitor)" - [^MethodVisitor writer bodies stack-depth $else pm] - (|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) - (&rt/popI writer) - - (&o/$BindPM _var-id) - (doto writer - stack-peek - (.visitVarInsn Opcodes/ASTORE _var-id) - &rt/popI) - - (&o/$BitPM _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/$RevPM _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-double - (.visitLdcInsn (double _value)) - (.visitInsn Opcodes/DCMPL) - (.visitJumpInsn Opcodes/IFNE $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 (&/$Left lefts)) - (let [accessI (if (= 0 lefts) - #(doto ^MethodVisitor % - (.visitInsn Opcodes/AALOAD)) - #(doto ^MethodVisitor % - (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "tuple_left" "([Ljava/lang/Object;I)Ljava/lang/Object;")))] - (doto writer - stack-peek - (.visitTypeInsn Opcodes/CHECKCAST "[Ljava/lang/Object;") - (.visitLdcInsn (int lefts)) - accessI - (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "pm_stack_push" "([Ljava/lang/Object;Ljava/lang/Object;)[Ljava/lang/Object;"))) - - (&o/$TuplePM (&/$Right _idx)) - (doto writer - stack-peek - (.visitTypeInsn Opcodes/CHECKCAST "[Ljava/lang/Object;") - (.visitLdcInsn (int (dec _idx))) - (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "tuple_right" "([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)] - :let [_ (doto *writer* - (.visitInsn Opcodes/ACONST_NULL))] - _ (compile ?value) - :let [_ (doto *writer* - (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "pm_stack_push" "([Ljava/lang/Object;Ljava/lang/Object;)[Ljava/lang/Object;")) - _ (compile-pattern *writer* bodies-labels ?pm $end)] - _ (compile-bodies *writer* compile bodies-labels ?bodies $end) - :let [_ (.visitLabel *writer* $end)]] - (return nil))) diff --git a/luxc/src/lux/compiler/jvm/function.clj b/luxc/src/lux/compiler/jvm/function.clj deleted file mode 100644 index eb779a7b6..000000000 --- a/luxc/src/lux/compiler/jvm/function.clj +++ /dev/null @@ -1,278 +0,0 @@ -(ns lux.compiler.jvm.function - (: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 |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.jvm [base :as &&])) - (:import (org.objectweb.asm Opcodes - Label - ClassWriter - MethodVisitor))) - -;; [Utils] -(def ^:private field-sig (&host-generics/->type-signature "java.lang.Object")) -(def ^:private function-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 function-impl-signature [arity] - (str "(" (&/fold str "" (&/|repeat arity field-sig)) ")" function-return-sig)) - -(defn ^:private function-<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-function-<init> [^ClassWriter class class-name arity env] - (let [closure-length (&/|length env)] - (doto (.visitMethod class Opcodes/ACC_PUBLIC "<init>" (function-<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 Opcodes/ACC_STRICT)] - (defn ^:private add-function-impl [^ClassWriter class class-name compile arity impl-body] - (let [$begin (new Label)] - (&/with-writer (doto (.visitMethod class impl-flags "impl" (function-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 function-class arity closed-over] - (|do [^MethodVisitor *writer* &/get-writer - :let [_ (doto *writer* - (.visitTypeInsn Opcodes/NEW function-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 function-class "<init>" (function-<init>-signature closed-over arity))]] - (return nil))) - -(defn ^:private add-function-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>" (function-<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-function-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))) - method-writer (.visitMethod class-writer (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STRICT) &&/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>" (function-<init>-signature env arity)) - (.visitInsn Opcodes/ARETURN)) - (->> (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" (function-impl-signature arity)) - (.visitInsn Opcodes/ARETURN)) - - (> 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" (function-impl-signature arity)) - (consecutive-applys (+ 1 args-to-completion) args-left) - (.visitInsn Opcodes/ARETURN))) - - :else) - (doseq [[stage $label] (map vector (range arity) $labels)]))) - (.visitMaxs 0 0) - (.visitEnd)) - (return nil))) - (let [$begin (new Label)] - (&/with-writer (doto (.visitMethod ^ClassWriter class-writer (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STRICT) &&/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 [function-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 _ _] &/location - :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 function-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-function-<init> class-name arity ?env) - (add-function-reset class-name arity ?env) - )] - _ (if (> arity 1) - (add-function-impl =class class-name compile arity ?body) - (return nil)) - _ (&/map% #(add-function-apply-n =class % class-name arity ?env compile ?body) - (&/|range* 1 (min arity &&/num-apply-variants))) - :let [_ (.visitEnd =class)] - _ (if save? - (&&/save-class! name (.toByteArray =class)) - (return nil))] - (if save? - (instance-closure compile class-name arity ?env) - (return (instance-closure compile class-name arity ?env)))))) diff --git a/luxc/src/lux/compiler/jvm/lux.clj b/luxc/src/lux/compiler/jvm/lux.clj deleted file mode 100644 index 043fc2273..000000000 --- a/luxc/src/lux/compiler/jvm/lux.clj +++ /dev/null @@ -1,402 +0,0 @@ -(ns lux.compiler.jvm.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 |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]) - (lux.compiler.jvm [base :as &&] - [function :as &&function])) - (:import (org.objectweb.asm Opcodes - Label - ClassWriter - MethodVisitor) - java.lang.reflect.Field)) - -;; [Exports] -(defn compile-bit [?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-rev "java/lang/Long" "J" long - compile-frac "java/lang/Double" "D" double - ) - -(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/$def ?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 (if tail? - (dec idx) - idx))) - (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" - (if tail? "tuple_right" "tuple_left") - "([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))) - -(defn ^:private install-def! [class-loader current-class module-name ?name ?body ?meta exported?] - (|do [_ (return nil) - :let [def-class (&&/load-class! class-loader (&host-generics/->class-name current-class)) - def-type (&a/expr-type* ?body)] - def-value (try (return (-> def-class (.getField &/value-field) (.get nil))) - (catch Throwable t - (&/assert! false - (str "Error during value initialization:\n" - (throwable->text t))))) - _ (&/without-repl-closure - (&a-module/define module-name ?name exported? def-type ?meta def-value))] - (return def-value))) - -(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 exported?] - (|do [module-name &/get-module-name - class-loader &/loader] - (|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 [[file-name _ _] &/location - :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 &/value-field datum-sig nil nil) - (doto (.visitEnd))) - (.visitSource file-name nil))] - instancer (&&function/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 [_ (.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)) - def-value (install-def! class-loader current-class module-name ?name ?body ?meta exported?) - :let [_ (println 'DEF (str module-name &/+name-separator+ ?name))]] - (return def-value))) - - _ - (|do [[file-name _ _] &/location - :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 &/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 [_ (.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)) - def-value (install-def! class-loader current-class module-name ?name ?body ?meta exported?) - :let [_ (println 'DEF (str module-name &/+name-separator+ ?name))]] - (return def-value)))))) - -(defn compile-program [compile ?program] - (|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 - _ (compile ?program) - :let [_ (.visitTypeInsn main-writer Opcodes/CHECKCAST &&/function-class)] - :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 - )] - :let [_ (doto main-writer - (.visitMethodInsn Opcodes/INVOKEVIRTUAL &&/function-class &&/apply-method (&&/apply-signature 1)) - (.visitTypeInsn Opcodes/CHECKCAST &&/function-class) - (.visitInsn Opcodes/ACONST_NULL) - (.visitMethodInsn Opcodes/INVOKEVIRTUAL &&/function-class &&/apply-method (&&/apply-signature 1)))] - :let [_ (doto main-writer - (.visitInsn Opcodes/POP) - (.visitInsn Opcodes/RETURN) - (.visitMaxs 0 0) - (.visitEnd))]] - (return nil))))) diff --git a/luxc/src/lux/compiler/jvm/proc/common.clj b/luxc/src/lux/compiler/jvm/proc/common.clj deleted file mode 100644 index d4c825282..000000000 --- a/luxc/src/lux/compiler/jvm/proc/common.clj +++ /dev/null @@ -1,460 +0,0 @@ -(ns lux.compiler.jvm.proc.common - (: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 |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.jvm.base :as &&]) - (:import (org.objectweb.asm Opcodes - Label - ClassWriter - MethodVisitor - AnnotationVisitor))) - -;; [Resources] -(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-i64-and Opcodes/LAND - ^:private compile-i64-or Opcodes/LOR - ^:private compile-i64-xor Opcodes/LXOR - ) - -(do-template [<op> <name>] - (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))) - - Opcodes/LSHL ^:private compile-i64-left-shift - Opcodes/LSHR ^:private compile-i64-arithmetic-right-shift - Opcodes/LUSHR ^:private compile-i64-logical-right-shift - ) - -(defn ^:private compile-lux-is [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))) - -(defn ^:private compile-lux-try [compile ?values special-args] - (|do [:let [(&/$Cons ?op (&/$Nil)) ?values] - ^MethodVisitor *writer* &/get-writer - _ (compile ?op) - :let [_ (doto *writer* - (.visitTypeInsn Opcodes/CHECKCAST "lux/Function") - (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "runTry" "(Llux/Function;)[Ljava/lang/Object;"))]] - (return nil))) - -(do-template [<name> <opcode> <unwrap> <wrap>] - (defn <name> [compile ?values special-args] - (|do [:let [(&/$Cons ?x (&/$Cons ?y (&/$Nil))) ?values] - ^MethodVisitor *writer* &/get-writer - _ (compile ?x) - :let [_ (doto *writer* - <unwrap>)] - _ (compile ?y) - :let [_ (doto *writer* - <unwrap>) - _ (doto *writer* - (.visitInsn <opcode>) - <wrap>)]] - (return nil))) - - ^:private compile-i64-add Opcodes/LADD &&/unwrap-long &&/wrap-long - ^:private compile-i64-sub Opcodes/LSUB &&/unwrap-long &&/wrap-long - - ^:private compile-int-mul Opcodes/LMUL &&/unwrap-long &&/wrap-long - ^:private compile-int-div Opcodes/LDIV &&/unwrap-long &&/wrap-long - ^:private compile-int-rem Opcodes/LREM &&/unwrap-long &&/wrap-long - - ^:private compile-frac-add Opcodes/DADD &&/unwrap-double &&/wrap-double - ^:private compile-frac-sub Opcodes/DSUB &&/unwrap-double &&/wrap-double - ^:private compile-frac-mul Opcodes/DMUL &&/unwrap-double &&/wrap-double - ^:private compile-frac-div Opcodes/DDIV &&/unwrap-double &&/wrap-double - ^:private compile-frac-rem Opcodes/DREM &&/unwrap-double &&/wrap-double - ) - -(do-template [<name> <cmpcode> <cmp-output> <unwrap>] - (defn <name> [compile ?values special-args] - (|do [:let [(&/$Cons ?x (&/$Cons ?y (&/$Nil))) ?values] - ^MethodVisitor *writer* &/get-writer - _ (compile ?x) - :let [_ (doto *writer* - <unwrap>)] - _ (compile ?y) - :let [_ (doto *writer* - <unwrap>) - $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-i64-eq Opcodes/LCMP 0 &&/unwrap-long - - ^:private compile-int-lt Opcodes/LCMP -1 &&/unwrap-long - - ^:private compile-frac-eq Opcodes/DCMPG 0 &&/unwrap-double - ^:private compile-frac-lt Opcodes/DCMPG -1 &&/unwrap-double - ) - -(defn ^:private compile-frac-encode [compile ?values special-args] - (|do [:let [(&/$Cons ?input (&/$Nil)) ?values] - ^MethodVisitor *writer* &/get-writer - _ (compile ?input) - :let [_ (doto *writer* - &&/unwrap-double - (.visitMethodInsn Opcodes/INVOKESTATIC "java/lang/Double" "toString" "(D)Ljava/lang/String;"))]] - (return nil))) - -(defn ^:private compile-frac-decode [compile ?values special-args] - (|do [:let [(&/$Cons ?input (&/$Nil)) ?values] - ^MethodVisitor *writer* &/get-writer - _ (compile ?input) - :let [_ (doto *writer* - (.visitTypeInsn Opcodes/CHECKCAST "java/lang/String") - (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "decode_frac" "(Ljava/lang/String;)[Ljava/lang/Object;"))]] - (return nil))) - -(defn ^:private compile-int-char [compile ?values special-args] - (|do [:let [(&/$Cons ?x (&/$Nil)) ?values] - ^MethodVisitor *writer* &/get-writer - _ (compile ?x) - :let [_ (doto *writer* - &&/unwrap-long - (.visitInsn Opcodes/L2I) - (.visitInsn Opcodes/I2C) - (.visitMethodInsn Opcodes/INVOKESTATIC "java/lang/String" "valueOf" "(C)Ljava/lang/String;"))]] - (return nil))) - -(do-template [<name> <unwrap> <op> <wrap>] - (defn <name> [compile ?values special-args] - (|do [:let [(&/$Cons ?input (&/$Nil)) ?values] - ^MethodVisitor *writer* &/get-writer - _ (compile ?input) - :let [_ (doto *writer* - <unwrap> - (.visitInsn <op>) - <wrap>)]] - (return nil))) - - ^:private compile-frac-int &&/unwrap-double Opcodes/D2L &&/wrap-long - ^:private compile-int-frac &&/unwrap-long Opcodes/L2D &&/wrap-double - ) - -(defn ^:private compile-text-eq [compile ?values special-args] - (|do [:let [(&/$Cons ?x (&/$Cons ?y (&/$Nil))) ?values] - ^MethodVisitor *writer* &/get-writer - _ (compile ?x) - _ (compile ?y) - :let [_ (doto *writer* - (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/Object" "equals" "(Ljava/lang/Object;)Z") - (&&/wrap-boolean))]] - (return nil))) - -(defn ^:private compile-text-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 "java/lang/String"))] - _ (compile ?y) - :let [_ (doto *writer* - (.visitTypeInsn Opcodes/CHECKCAST "java/lang/String"))] - :let [$then (new Label) - $end (new Label) - _ (doto *writer* - (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "compareTo" "(Ljava/lang/String;)I") - (.visitJumpInsn Opcodes/IFLT $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-text-concat [compile ?values special-args] - (|do [:let [(&/$Cons ?x (&/$Cons ?y (&/$Nil))) ?values] - ^MethodVisitor *writer* &/get-writer - _ (compile ?x) - :let [_ (doto *writer* - (.visitTypeInsn Opcodes/CHECKCAST "java/lang/String"))] - _ (compile ?y) - :let [_ (doto *writer* - (.visitTypeInsn Opcodes/CHECKCAST "java/lang/String"))] - :let [_ (doto *writer* - (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "concat" "(Ljava/lang/String;)Ljava/lang/String;"))]] - (return nil))) - -(defn compile-text-clip [compile ?values special-args] - (|do [:let [(&/$Cons ?text (&/$Cons ?from (&/$Cons ?to (&/$Nil)))) ?values] - ^MethodVisitor *writer* &/get-writer - _ (compile ?text) - :let [_ (doto *writer* - (.visitTypeInsn Opcodes/CHECKCAST "java/lang/String"))] - _ (compile ?from) - :let [_ (doto *writer* - &&/unwrap-long - (.visitInsn Opcodes/L2I))] - _ (compile ?to) - :let [_ (doto *writer* - &&/unwrap-long - (.visitInsn Opcodes/L2I))] - :let [_ (doto *writer* - (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "substring" "(II)Ljava/lang/String;"))]] - (return nil))) - -(defn ^:private compile-text-index [compile ?values special-args] - (|do [:let [(&/$Cons ?text (&/$Cons ?part (&/$Cons ?start (&/$Nil)))) ?values] - ^MethodVisitor *writer* &/get-writer - _ (compile ?text) - :let [_ (doto *writer* - (.visitTypeInsn Opcodes/CHECKCAST "java/lang/String"))] - _ (compile ?part) - :let [_ (doto *writer* - (.visitTypeInsn Opcodes/CHECKCAST "java/lang/String"))] - _ (compile ?start) - :let [_ (doto *writer* - &&/unwrap-long - (.visitInsn Opcodes/L2I))] - :let [_ (doto *writer* - (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "indexOf" "(Ljava/lang/String;I)I"))] - :let [$not-found (new Label) - $end (new Label) - _ (doto *writer* - (.visitInsn Opcodes/DUP) - (.visitLdcInsn (int -1)) - (.visitJumpInsn Opcodes/IF_ICMPEQ $not-found) - (.visitInsn Opcodes/I2L) - &&/wrap-long - (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "make_some" "(Ljava/lang/Object;)[Ljava/lang/Object;") - (.visitJumpInsn Opcodes/GOTO $end) - (.visitLabel $not-found) - (.visitInsn Opcodes/POP) - (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "make_none" "()[Ljava/lang/Object;") - (.visitLabel $end))]] - (return nil))) - -(do-template [<name> <class> <method>] - (defn <name> [compile ?values special-args] - (|do [:let [(&/$Cons ?text (&/$Nil)) ?values] - ^MethodVisitor *writer* &/get-writer - _ (compile ?text) - :let [_ (doto *writer* - (.visitTypeInsn Opcodes/CHECKCAST "java/lang/String") - (.visitMethodInsn Opcodes/INVOKEVIRTUAL <class> <method> "()I") - (.visitInsn Opcodes/I2L) - &&/wrap-long)]] - (return nil))) - - ^:private compile-text-size "java/lang/String" "length" - ) - -(defn ^:private compile-text-char [compile ?values special-args] - (|do [:let [(&/$Cons ?text (&/$Cons ?idx (&/$Nil))) ?values] - ^MethodVisitor *writer* &/get-writer - _ (compile ?text) - :let [_ (doto *writer* - (.visitTypeInsn Opcodes/CHECKCAST "java/lang/String"))] - _ (compile ?idx) - :let [_ (doto *writer* - &&/unwrap-long - (.visitInsn Opcodes/L2I) - (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "charAt" "(I)C") - (.visitInsn Opcodes/I2L) - &&/wrap-long)]] - (return nil))) - -(defn ^:private compile-io-log [compile ?values special-args] - (|do [:let [(&/$Cons ?x (&/$Nil)) ?values] - ^MethodVisitor *writer* &/get-writer - :let [_ (doto *writer* - (.visitFieldInsn Opcodes/GETSTATIC "java/lang/System" "out" "Ljava/io/PrintStream;"))] - _ (compile ?x) - :let [_ (doto *writer* - (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/io/PrintStream" "println" "(Ljava/lang/Object;)V") - (.visitLdcInsn &/unit-tag))]] - (return nil))) - -(defn ^:private compile-io-error [compile ?values special-args] - (|do [:let [(&/$Cons ?message (&/$Nil)) ?values] - ^MethodVisitor *writer* &/get-writer - :let [_ (doto *writer* - (.visitTypeInsn Opcodes/NEW "java/lang/Error") - (.visitInsn Opcodes/DUP))] - _ (compile ?message) - :let [_ (doto *writer* - (.visitTypeInsn Opcodes/CHECKCAST "java/lang/String") - (.visitMethodInsn Opcodes/INVOKESPECIAL "java/lang/Error" "<init>" "(Ljava/lang/String;)V") - (.visitInsn Opcodes/ATHROW))]] - (return nil))) - -(defn ^:private compile-io-exit [compile ?values special-args] - (|do [:let [(&/$Cons ?code (&/$Nil)) ?values] - ^MethodVisitor *writer* &/get-writer - _ (compile ?code) - :let [_ (doto *writer* - &&/unwrap-long - (.visitInsn Opcodes/L2I) - (.visitMethodInsn Opcodes/INVOKESTATIC "java/lang/System" "exit" "(I)V") - (.visitInsn Opcodes/ACONST_NULL))]] - (return nil))) - -(defn ^:private compile-io-current-time [compile ?values special-args] - (|do [:let [(&/$Nil) ?values] - ^MethodVisitor *writer* &/get-writer - :let [_ (doto *writer* - (.visitMethodInsn Opcodes/INVOKESTATIC "java/lang/System" "currentTimeMillis" "()J") - &&/wrap-long)]] - (return nil))) - -(defn ^:private compile-syntax-char-case! [compile ?values ?patterns] - (|do [:let [(&/$Cons ?input (&/$Cons [_ (&a/$tuple ?matches)] (&/$Cons ?else (&/$Nil)))) ?values] - ^MethodVisitor *writer* &/get-writer - :let [pattern-labels (&/|map (fn [_] (new Label)) ?patterns) - matched-patterns (->> (&/zip2 ?patterns pattern-labels) - (&/flat-map (fn [?chars+?label] - (|let [[?chars ?label] ?chars+?label] - (&/|map (fn [?char] - (&/T [?char ?label])) - ?chars)))) - &/->seq - (sort-by &/|first <) - &/->list) - end-label (new Label) - else-label (new Label)] - _ (compile ?input) - :let [_ (doto *writer* - &&/unwrap-long - (.visitInsn Opcodes/L2I) - (.visitLookupSwitchInsn else-label - (int-array (&/->seq (&/|map &/|first matched-patterns))) - (into-array (&/->seq (&/|map &/|second matched-patterns)))))] - _ (&/map% (fn [?label+?match] - (|let [[?label ?match] ?label+?match] - (|do [:let [_ (doto *writer* - (.visitLabel ?label))] - _ (compile ?match) - :let [_ (doto *writer* - (.visitJumpInsn Opcodes/GOTO end-label))]] - (return nil)))) - (&/zip2 pattern-labels ?matches)) - :let [_ (doto *writer* - (.visitLabel else-label))] - _ (compile ?else) - :let [_ (doto *writer* - (.visitLabel end-label))]] - (return nil))) - -(defn compile-proc [compile category proc ?values special-args] - (case category - "lux" - (case proc - "is" (compile-lux-is compile ?values special-args) - "try" (compile-lux-try compile ?values special-args) - ;; Special extensions for performance reasons - ;; Will be replaced by custom extensions in the future. - "syntax char case!" (compile-syntax-char-case! compile ?values special-args)) - - "io" - (case proc - "log" (compile-io-log compile ?values special-args) - "error" (compile-io-error compile ?values special-args) - "exit" (compile-io-exit compile ?values special-args) - "current-time" (compile-io-current-time compile ?values special-args) - ) - - "text" - (case proc - "=" (compile-text-eq compile ?values special-args) - "<" (compile-text-lt compile ?values special-args) - "concat" (compile-text-concat compile ?values special-args) - "clip" (compile-text-clip compile ?values special-args) - "index" (compile-text-index compile ?values special-args) - "size" (compile-text-size compile ?values special-args) - "char" (compile-text-char compile ?values special-args) - ) - - "i64" - (case proc - "and" (compile-i64-and compile ?values special-args) - "or" (compile-i64-or compile ?values special-args) - "xor" (compile-i64-xor compile ?values special-args) - "left-shift" (compile-i64-left-shift compile ?values special-args) - "arithmetic-right-shift" (compile-i64-arithmetic-right-shift compile ?values special-args) - "logical-right-shift" (compile-i64-logical-right-shift compile ?values special-args) - "=" (compile-i64-eq compile ?values special-args) - "+" (compile-i64-add compile ?values special-args) - "-" (compile-i64-sub compile ?values special-args) - "*" (compile-int-mul compile ?values special-args) - "/" (compile-int-div compile ?values special-args) - "%" (compile-int-rem compile ?values special-args) - "<" (compile-int-lt compile ?values special-args) - "f64" (compile-int-frac compile ?values special-args) - "char" (compile-int-char compile ?values special-args) - ) - - "f64" - (case proc - "+" (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) - "i64" (compile-frac-int compile ?values special-args) - "encode" (compile-frac-encode compile ?values special-args) - "decode" (compile-frac-decode compile ?values special-args) - ) - - ;; else - (&/fail-with-loc (str "[Compiler Error] Unknown procedure: " [category proc])))) diff --git a/luxc/src/lux/compiler/jvm/proc/host.clj b/luxc/src/lux/compiler/jvm/proc/host.clj deleted file mode 100644 index ec934ae7b..000000000 --- a/luxc/src/lux/compiler/jvm/proc/host.clj +++ /dev/null @@ -1,1112 +0,0 @@ -(ns lux.compiler.jvm.proc.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 |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.jvm.base :as &&]) - (:import (org.objectweb.asm Opcodes - Label - ClassWriter - MethodVisitor - AnnotationVisitor))) - -;; [Utils] -(def init-method "<init>") - -(let [class+method+sig {"boolean" &&/unwrap-boolean - "byte" &&/unwrap-byte - "short" &&/unwrap-short - "int" &&/unwrap-int - "long" &&/unwrap-long - "float" &&/unwrap-float - "double" &&/unwrap-double - "char" &&/unwrap-char}] - (defn ^:private prepare-arg! [^MethodVisitor *writer* class-name] - (if-let [unwrap (get class+method+sig class-name)] - (doto *writer* - unwrap) - (.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*] - (if (&type/type= &type/Any *type*) - (.visitLdcInsn *writer* &/unit-tag) - (|case *type* - (&/$Primitive "boolean" (&/$Nil)) - (.visitMethodInsn *writer* Opcodes/INVOKESTATIC (&host-generics/->bytecode-class-name boolean-class) "valueOf" (str "(Z)" (&host-generics/->type-signature boolean-class))) - - (&/$Primitive "byte" (&/$Nil)) - (.visitMethodInsn *writer* Opcodes/INVOKESTATIC (&host-generics/->bytecode-class-name byte-class) "valueOf" (str "(B)" (&host-generics/->type-signature byte-class))) - - (&/$Primitive "short" (&/$Nil)) - (.visitMethodInsn *writer* Opcodes/INVOKESTATIC (&host-generics/->bytecode-class-name short-class) "valueOf" (str "(S)" (&host-generics/->type-signature short-class))) - - (&/$Primitive "int" (&/$Nil)) - (.visitMethodInsn *writer* Opcodes/INVOKESTATIC (&host-generics/->bytecode-class-name int-class) "valueOf" (str "(I)" (&host-generics/->type-signature int-class))) - - (&/$Primitive "long" (&/$Nil)) - (.visitMethodInsn *writer* Opcodes/INVOKESTATIC (&host-generics/->bytecode-class-name long-class) "valueOf" (str "(J)" (&host-generics/->type-signature long-class))) - - (&/$Primitive "float" (&/$Nil)) - (.visitMethodInsn *writer* Opcodes/INVOKESTATIC (&host-generics/->bytecode-class-name float-class) "valueOf" (str "(F)" (&host-generics/->type-signature float-class))) - - (&/$Primitive "double" (&/$Nil)) - (.visitMethodInsn *writer* Opcodes/INVOKESTATIC (&host-generics/->bytecode-class-name double-class) "valueOf" (str "(D)" (&host-generics/->type-signature double-class))) - - (&/$Primitive "char" (&/$Nil)) - (.visitMethodInsn *writer* Opcodes/INVOKESTATIC (&host-generics/->bytecode-class-name char-class) "valueOf" (str "(C)" (&host-generics/->type-signature char-class))) - - (&/$Primitive _ _) - nil - - (&/$Named ?name ?type) - (prepare-return! *writer* ?type) - - (&/$Ex _) - nil - - _ - (assert false (str 'prepare-return! " " (&type/show-type *type*))))) - *writer*)) - -;; [Resources] -(defn ^:private compile-annotation [^ClassWriter 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)) - - (&/$GenericClass _class-name _) - (doto writer - (.visitTypeInsn Opcodes/CHECKCAST (&host-generics/->bytecode-class-name _class-name)) - (.visitInsn Opcodes/ARETURN)) - - _ - (.visitInsn writer Opcodes/ARETURN))) - -(defn ^:private prepare-method-input - "(-> Int [Text GenericClass] MethodVisitor (Lux FrameTag))" - [idx input ^MethodVisitor method-visitor] - (|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 - "(-> Int (List GenericClass) MethodVisitor (Lux (List FrameTag)))" - [idx inputs method-visitor] - (|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 - &&/unwrap-boolean) - "byte" (doto writer - &&/unwrap-byte) - "short" (doto writer - &&/unwrap-short) - "int" (doto writer - &&/unwrap-int) - "long" (doto writer - &&/unwrap-long) - "float" (doto writer - &&/unwrap-float) - "double" (doto writer - &&/unwrap-double) - "char" (doto writer - &&/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 - "(-> (List FieldAnalysis) (List [Text GenericClass Analysis]))" - [fields] - (&/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] &/location - :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 _ _] &/location - :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)))) - -(do-template [<name> <op> <unwrap> <wrap>] - (defn <name> [compile _?value special-args] - (|do [:let [(&/$Cons ?value (&/$Nil)) _?value] - ^MethodVisitor *writer* &/get-writer - _ (compile ?value) - :let [_ (doto *writer* - <unwrap> - (.visitInsn <op>) - <wrap>)]] - (return nil))) - - ^:private compile-jvm-double-to-float Opcodes/D2F &&/unwrap-double &&/wrap-float - ^:private compile-jvm-double-to-int Opcodes/D2I &&/unwrap-double &&/wrap-int - ^:private compile-jvm-double-to-long Opcodes/D2L &&/unwrap-double &&/wrap-long - - ^:private compile-jvm-float-to-double Opcodes/F2D &&/unwrap-float &&/wrap-double - ^:private compile-jvm-float-to-int Opcodes/F2I &&/unwrap-float &&/wrap-int - ^:private compile-jvm-float-to-long Opcodes/F2L &&/unwrap-float &&/wrap-long - - ^:private compile-jvm-int-to-byte Opcodes/I2B &&/unwrap-int &&/wrap-byte - ^:private compile-jvm-int-to-char Opcodes/I2C &&/unwrap-int &&/wrap-char - ^:private compile-jvm-int-to-double Opcodes/I2D &&/unwrap-int &&/wrap-double - ^:private compile-jvm-int-to-float Opcodes/I2F &&/unwrap-int &&/wrap-float - ^:private compile-jvm-int-to-long Opcodes/I2L &&/unwrap-int &&/wrap-long - ^:private compile-jvm-int-to-short Opcodes/I2S &&/unwrap-int &&/wrap-short - - ^:private compile-jvm-long-to-double Opcodes/L2D &&/unwrap-long &&/wrap-double - ^:private compile-jvm-long-to-float Opcodes/L2F &&/unwrap-long &&/wrap-float - ^:private compile-jvm-long-to-int Opcodes/L2I &&/unwrap-long &&/wrap-int - - ^:private compile-jvm-char-to-byte Opcodes/I2B &&/unwrap-char &&/wrap-byte - ^:private compile-jvm-char-to-short Opcodes/I2S &&/unwrap-char &&/wrap-short - ^:private compile-jvm-char-to-int Opcodes/NOP &&/unwrap-char &&/wrap-int - ^:private compile-jvm-char-to-long Opcodes/I2L &&/unwrap-char &&/wrap-long - - ^:private compile-jvm-short-to-long Opcodes/I2L &&/unwrap-short &&/wrap-long - - ^:private compile-jvm-byte-to-long Opcodes/I2L &&/unwrap-byte &&/wrap-long - ) - -(do-template [<name> <op> <wrap>] - (defn <name> [compile _?value special-args] - (|do [:let [(&/$Cons ?value (&/$Nil)) _?value] - ^MethodVisitor *writer* &/get-writer - _ (compile ?value) - :let [_ (doto *writer* - &&/unwrap-long - (.visitInsn Opcodes/L2I) - (.visitInsn <op>) - <wrap>)]] - (return nil))) - - ^:private compile-jvm-long-to-short Opcodes/I2S &&/wrap-short - ^:private compile-jvm-long-to-byte Opcodes/I2B &&/wrap-byte - ) - -(do-template [<name> <op> <unwrap-left> <unwrap-right> <wrap>] - (defn <name> [compile ?values special-args] - (|do [:let [(&/$Cons ?x (&/$Cons ?y (&/$Nil))) ?values] - ^MethodVisitor *writer* &/get-writer - _ (compile ?x) - :let [_ (doto *writer* - <unwrap-left>)] - _ (compile ?y) - :let [_ (doto *writer* - <unwrap-right>)] - :let [_ (doto *writer* - (.visitInsn <op>) - <wrap>)]] - (return nil))) - - ^:private compile-jvm-iand Opcodes/IAND &&/unwrap-int &&/unwrap-int &&/wrap-int - ^:private compile-jvm-ior Opcodes/IOR &&/unwrap-int &&/unwrap-int &&/wrap-int - ^:private compile-jvm-ixor Opcodes/IXOR &&/unwrap-int &&/unwrap-int &&/wrap-int - ^:private compile-jvm-ishl Opcodes/ISHL &&/unwrap-int &&/unwrap-int &&/wrap-int - ^:private compile-jvm-ishr Opcodes/ISHR &&/unwrap-int &&/unwrap-int &&/wrap-int - ^:private compile-jvm-iushr Opcodes/IUSHR &&/unwrap-int &&/unwrap-int &&/wrap-int - - ^:private compile-jvm-land Opcodes/LAND &&/unwrap-long &&/unwrap-long &&/wrap-long - ^:private compile-jvm-lor Opcodes/LOR &&/unwrap-long &&/unwrap-long &&/wrap-long - ^:private compile-jvm-lxor Opcodes/LXOR &&/unwrap-long &&/unwrap-long &&/wrap-long - ^:private compile-jvm-lshl Opcodes/LSHL &&/unwrap-long &&/unwrap-int &&/wrap-long - ^:private compile-jvm-lshr Opcodes/LSHR &&/unwrap-long &&/unwrap-int &&/wrap-long - ^:private compile-jvm-lushr Opcodes/LUSHR &&/unwrap-long &&/unwrap-int &&/wrap-long - ) - -(do-template [<name> <opcode> <unwrap> <wrap>] - (defn <name> [compile ?values special-args] - (|do [:let [(&/$Cons ?x (&/$Cons ?y (&/$Nil))) ?values] - ^MethodVisitor *writer* &/get-writer - _ (compile ?x) - :let [_ (doto *writer* - <unwrap>)] - _ (compile ?y) - :let [_ (doto *writer* - <unwrap>) - _ (doto *writer* - (.visitInsn <opcode>) - (<wrap>))]] - (return nil))) - - ^:private compile-jvm-iadd Opcodes/IADD &&/unwrap-int &&/wrap-int - ^:private compile-jvm-isub Opcodes/ISUB &&/unwrap-int &&/wrap-int - ^:private compile-jvm-imul Opcodes/IMUL &&/unwrap-int &&/wrap-int - ^:private compile-jvm-idiv Opcodes/IDIV &&/unwrap-int &&/wrap-int - ^:private compile-jvm-irem Opcodes/IREM &&/unwrap-int &&/wrap-int - - ^:private compile-jvm-ladd Opcodes/LADD &&/unwrap-long &&/wrap-long - ^:private compile-jvm-lsub Opcodes/LSUB &&/unwrap-long &&/wrap-long - ^:private compile-jvm-lmul Opcodes/LMUL &&/unwrap-long &&/wrap-long - ^:private compile-jvm-ldiv Opcodes/LDIV &&/unwrap-long &&/wrap-long - ^:private compile-jvm-lrem Opcodes/LREM &&/unwrap-long &&/wrap-long - - ^:private compile-jvm-fadd Opcodes/FADD &&/unwrap-float &&/wrap-float - ^:private compile-jvm-fsub Opcodes/FSUB &&/unwrap-float &&/wrap-float - ^:private compile-jvm-fmul Opcodes/FMUL &&/unwrap-float &&/wrap-float - ^:private compile-jvm-fdiv Opcodes/FDIV &&/unwrap-float &&/wrap-float - ^:private compile-jvm-frem Opcodes/FREM &&/unwrap-float &&/wrap-float - - ^:private compile-jvm-dadd Opcodes/DADD &&/unwrap-double &&/wrap-double - ^:private compile-jvm-dsub Opcodes/DSUB &&/unwrap-double &&/wrap-double - ^:private compile-jvm-dmul Opcodes/DMUL &&/unwrap-double &&/wrap-double - ^:private compile-jvm-ddiv Opcodes/DDIV &&/unwrap-double &&/wrap-double - ^:private compile-jvm-drem Opcodes/DREM &&/unwrap-double &&/wrap-double - ) - -(do-template [<name> <opcode> <unwrap>] - (defn <name> [compile ?values special-args] - (|do [:let [(&/$Cons ?x (&/$Cons ?y (&/$Nil))) ?values] - ^MethodVisitor *writer* &/get-writer - _ (compile ?x) - :let [_ (doto *writer* - <unwrap>)] - _ (compile ?y) - :let [_ (doto *writer* - <unwrap>) - $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 &&/unwrap-int - ^:private compile-jvm-ilt Opcodes/IF_ICMPLT &&/unwrap-int - ^:private compile-jvm-igt Opcodes/IF_ICMPGT &&/unwrap-int - - ^:private compile-jvm-ceq Opcodes/IF_ICMPEQ &&/unwrap-char - ^:private compile-jvm-clt Opcodes/IF_ICMPLT &&/unwrap-char - ^:private compile-jvm-cgt Opcodes/IF_ICMPGT &&/unwrap-char - ) - -(do-template [<name> <cmpcode> <cmp-output> <unwrap>] - (defn <name> [compile ?values special-args] - (|do [:let [(&/$Cons ?x (&/$Cons ?y (&/$Nil))) ?values] - ^MethodVisitor *writer* &/get-writer - _ (compile ?x) - :let [_ (doto *writer* - <unwrap>)] - _ (compile ?y) - :let [_ (doto *writer* - <unwrap>) - $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 &&/unwrap-long - ^:private compile-jvm-llt Opcodes/LCMP -1 &&/unwrap-long - ^:private compile-jvm-lgt Opcodes/LCMP 1 &&/unwrap-long - - ^:private compile-jvm-feq Opcodes/FCMPG 0 &&/unwrap-float - ^:private compile-jvm-flt Opcodes/FCMPG -1 &&/unwrap-float - ^:private compile-jvm-fgt Opcodes/FCMPG 1 &&/unwrap-float - - ^:private compile-jvm-deq Opcodes/DCMPG 0 &&/unwrap-double - ^:private compile-jvm-dlt Opcodes/DCMPG -1 &&/unwrap-double - ^:private compile-jvm-dgt Opcodes/DCMPG 1 &&/unwrap-double - ) - -(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-object-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-object-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-object-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))) - -(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-object-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 compile-proc [compile proc-name ?values special-args] - (case proc-name - "object synchronized" (compile-jvm-object-synchronized compile ?values special-args) - "object class" (compile-jvm-object-class compile ?values special-args) - "instanceof" (compile-jvm-instanceof 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) - "object null?" (compile-jvm-object-null? compile ?values special-args) - "object null" (compile-jvm-object-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) - "zaload" (compile-jvm-zaload compile ?values special-args) - "zastore" (compile-jvm-zastore compile ?values special-args) - "baload" (compile-jvm-baload compile ?values special-args) - "bastore" (compile-jvm-bastore compile ?values special-args) - "saload" (compile-jvm-saload compile ?values special-args) - "sastore" (compile-jvm-sastore compile ?values special-args) - "iaload" (compile-jvm-iaload compile ?values special-args) - "iastore" (compile-jvm-iastore compile ?values special-args) - "laload" (compile-jvm-laload compile ?values special-args) - "lastore" (compile-jvm-lastore compile ?values special-args) - "faload" (compile-jvm-faload compile ?values special-args) - "fastore" (compile-jvm-fastore compile ?values special-args) - "daload" (compile-jvm-daload compile ?values special-args) - "dastore" (compile-jvm-dastore compile ?values special-args) - "caload" (compile-jvm-caload compile ?values special-args) - "castore" (compile-jvm-castore 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) - "double-to-float" (compile-jvm-double-to-float compile ?values special-args) - "double-to-int" (compile-jvm-double-to-int compile ?values special-args) - "double-to-long" (compile-jvm-double-to-long compile ?values special-args) - "float-to-double" (compile-jvm-float-to-double compile ?values special-args) - "float-to-int" (compile-jvm-float-to-int compile ?values special-args) - "float-to-long" (compile-jvm-float-to-long compile ?values special-args) - "int-to-byte" (compile-jvm-int-to-byte compile ?values special-args) - "int-to-char" (compile-jvm-int-to-char compile ?values special-args) - "int-to-double" (compile-jvm-int-to-double compile ?values special-args) - "int-to-float" (compile-jvm-int-to-float compile ?values special-args) - "int-to-long" (compile-jvm-int-to-long compile ?values special-args) - "int-to-short" (compile-jvm-int-to-short compile ?values special-args) - "long-to-double" (compile-jvm-long-to-double compile ?values special-args) - "long-to-float" (compile-jvm-long-to-float compile ?values special-args) - "long-to-int" (compile-jvm-long-to-int compile ?values special-args) - "long-to-short" (compile-jvm-long-to-short compile ?values special-args) - "long-to-byte" (compile-jvm-long-to-byte compile ?values special-args) - "char-to-byte" (compile-jvm-char-to-byte compile ?values special-args) - "char-to-short" (compile-jvm-char-to-short compile ?values special-args) - "char-to-int" (compile-jvm-char-to-int compile ?values special-args) - "char-to-long" (compile-jvm-char-to-long compile ?values special-args) - "short-to-long" (compile-jvm-short-to-long compile ?values special-args) - "byte-to-long" (compile-jvm-byte-to-long compile ?values special-args) - ;; else - (&/fail-with-loc (str "[Compiler Error] Unknown host procedure: " ["jvm" proc-name])))) diff --git a/luxc/src/lux/compiler/jvm/rt.clj b/luxc/src/lux/compiler/jvm/rt.clj deleted file mode 100644 index 7fabd27ed..000000000 --- a/luxc/src/lux/compiler/jvm/rt.clj +++ /dev/null @@ -1,410 +0,0 @@ -(ns lux.compiler.jvm.rt - (: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 |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.jvm.base :as &&]) - (:import (org.objectweb.asm Opcodes - Label - ClassWriter - MethodVisitor - AnnotationVisitor))) - -;; [Utils] -(def init-method "<init>") - -;; [Resources] -;; Functions -(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))))) - -(defmacro <bytecode> [& instructions] - `(fn [^MethodVisitor writer#] - (doto writer# - ~@instructions))) - -;; Runtime infrastructure -(defn ^:private compile-LuxRT-adt-methods [^ClassWriter =class] - (|let [lefts #(doto ^MethodVisitor % - (.visitVarInsn Opcodes/ILOAD 1)) - tuple-size #(doto ^MethodVisitor % - (.visitVarInsn Opcodes/ALOAD 0) - (.visitInsn Opcodes/ARRAYLENGTH)) - last-right #(doto ^MethodVisitor % - tuple-size - (.visitLdcInsn (int 1)) - (.visitInsn Opcodes/ISUB)) - sub-lefts #(doto ^MethodVisitor % - lefts - last-right - (.visitInsn Opcodes/ISUB)) - sub-tuple #(doto ^MethodVisitor % - (.visitVarInsn Opcodes/ALOAD 0) - last-right - (.visitInsn Opcodes/AALOAD) - (.visitTypeInsn Opcodes/CHECKCAST "[Ljava/lang/Object;")) - recurI (fn [$begin] - #(doto ^MethodVisitor % - sub-lefts (.visitVarInsn Opcodes/ISTORE 1) - sub-tuple (.visitVarInsn Opcodes/ASTORE 0) - (.visitJumpInsn Opcodes/GOTO $begin))) - _ (let [$begin (new Label) - $recursive (new Label) - left-index lefts - left-access #(doto ^MethodVisitor % - (.visitVarInsn Opcodes/ALOAD 0) - left-index - (.visitInsn Opcodes/AALOAD))] - (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "tuple_left" "([Ljava/lang/Object;I)Ljava/lang/Object;" nil nil) - (.visitCode) - (.visitLabel $begin) - lefts last-right (.visitJumpInsn Opcodes/IF_ICMPGE $recursive) - left-access - (.visitInsn Opcodes/ARETURN) - (.visitLabel $recursive) - ((recurI $begin)) - (.visitMaxs 0 0) - (.visitEnd))) - _ (let [$begin (new Label) - $not-last (new Label) - $must-copy (new Label) - right-index #(doto ^MethodVisitor % - lefts - (.visitLdcInsn (int 1)) - (.visitInsn Opcodes/IADD)) - right-access #(doto ^MethodVisitor % - (.visitVarInsn Opcodes/ALOAD 0) - (.visitInsn Opcodes/SWAP) - (.visitInsn Opcodes/AALOAD)) - sub-right #(doto ^MethodVisitor % - (.visitVarInsn Opcodes/ALOAD 0) - right-index - tuple-size - (.visitMethodInsn Opcodes/INVOKESTATIC "java/util/Arrays" "copyOfRange" "([Ljava/lang/Object;II)[Ljava/lang/Object;"))] - (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "tuple_right" "([Ljava/lang/Object;I)Ljava/lang/Object;" nil nil) - (.visitCode) - (.visitLabel $begin) - last-right right-index - (.visitInsn Opcodes/DUP2) (.visitJumpInsn Opcodes/IF_ICMPNE $not-last) - right-access - (.visitInsn Opcodes/ARETURN) - (.visitLabel $not-last) - (.visitJumpInsn Opcodes/IF_ICMPGT $must-copy) - ;; Must recurse - ((recurI $begin)) - (.visitLabel $must-copy) - sub-right - (.visitInsn Opcodes/ARETURN) - (.visitMaxs 0 0) - (.visitEnd))) - _ (let [$loop (new Label) - $perfect-match! (new Label) - $tags-match! (new Label) - $maybe-nested (new Label) - $mismatch! (new Label) - - !variant (<bytecode> (.visitVarInsn Opcodes/ALOAD 0)) - !tag (<bytecode> (.visitVarInsn Opcodes/ILOAD 1)) - !last? (<bytecode> (.visitVarInsn Opcodes/ALOAD 2)) - - <>tag (<bytecode> (.visitLdcInsn (int 0)) - (.visitInsn Opcodes/AALOAD) - &&/unwrap-int) - <>last? (<bytecode> (.visitLdcInsn (int 1)) - (.visitInsn Opcodes/AALOAD)) - <>value (<bytecode> (.visitLdcInsn (int 2)) - (.visitInsn Opcodes/AALOAD)) - - not-found (<bytecode> (.visitInsn Opcodes/ACONST_NULL)) - - super-nested-tag (<bytecode> (.visitInsn Opcodes/SWAP) - (.visitInsn Opcodes/ISUB)) - super-nested (<bytecode> super-nested-tag ;; super-tag - !variant <>last? ;; super-tag, super-last - !variant <>value ;; super-tag, super-last, super-value - (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "sum_make" "(ILjava/lang/Object;Ljava/lang/Object;)[Ljava/lang/Object;")) - - update-!variant (<bytecode> !variant <>value - (.visitTypeInsn Opcodes/CHECKCAST "[Ljava/lang/Object;") - (.visitVarInsn Opcodes/ASTORE 0)) - update-!tag (<bytecode> (.visitInsn Opcodes/ISUB)) - iterate! (fn [^Label $loop] - (<bytecode> update-!variant - update-!tag - (.visitJumpInsn Opcodes/GOTO $loop)))] - (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "sum_get" "([Ljava/lang/Object;ILjava/lang/Object;)Ljava/lang/Object;" nil nil) - (.visitCode) - !tag ;; tag - (.visitLabel $loop) - !variant <>tag ;; tag, variant::tag - (.visitInsn Opcodes/DUP2) (.visitJumpInsn Opcodes/IF_ICMPEQ $tags-match!) ;; tag, variant::tag - (.visitInsn Opcodes/DUP2) (.visitJumpInsn Opcodes/IF_ICMPGT $maybe-nested) ;; tag, variant::tag - !last? (.visitJumpInsn Opcodes/IFNULL $mismatch!) ;; tag, variant::tag - super-nested ;; super-variant - (.visitInsn Opcodes/ARETURN) - (.visitLabel $tags-match!) ;; tag, variant::tag - !last? ;; tag, variant::tag, last? - !variant <>last? - (.visitJumpInsn Opcodes/IF_ACMPEQ $perfect-match!) - (.visitLabel $maybe-nested) ;; tag, variant::tag - !variant <>last? ;; tag, variant::tag, variant::last? - (.visitJumpInsn Opcodes/IFNULL $mismatch!) ;; tag, variant::tag - ((iterate! $loop)) - (.visitLabel $perfect-match!) - ;; (.visitInsn Opcodes/POP2) - !variant <>value - (.visitInsn Opcodes/ARETURN) - (.visitLabel $mismatch!) ;; tag, variant::tag - ;; (.visitInsn Opcodes/POP2) - not-found - (.visitInsn Opcodes/ARETURN) - (.visitMaxs 0 0) - (.visitEnd))) - _ (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "sum_make" "(ILjava/lang/Object;Ljava/lang/Object;)[Ljava/lang/Object;" nil nil) - (.visitCode) - (.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) - (.visitMaxs 0 0) - (.visitEnd))] - nil)) - -(defn ^:private swap2x1 [^MethodVisitor =method] - (doto =method - ;; X1, Y2 - (.visitInsn Opcodes/DUP2_X1) ;; Y2, X1, Y2 - (.visitInsn Opcodes/POP2) ;; Y2, X1 - )) - -(do-template [<name> <method> <class> <parse-method> <signature> <wrapper>] - (defn <name> [^ClassWriter =class] - (do (let [$from (new Label) - $to (new Label) - $handler (new Label)] - (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) <method> "(Ljava/lang/String;)[Ljava/lang/Object;" nil nil) - (.visitCode) - (.visitTryCatchBlock $from $to $handler "java/lang/Exception") - (.visitLabel $from) - (.visitVarInsn Opcodes/ALOAD 0) - (.visitMethodInsn Opcodes/INVOKESTATIC <class> <parse-method> <signature>) - <wrapper> - (.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))) - nil)) - - ^:private compile-LuxRT-int-methods "decode_int" "java/lang/Long" "parseLong" "(Ljava/lang/String;)J" &&/wrap-long - ^:private compile-LuxRT-frac-methods "decode_frac" "java/lang/Double" "parseDouble" "(Ljava/lang/String;)D" &&/wrap-double - ) - -(defn peekI [^MethodVisitor writer] - (doto writer - (.visitLdcInsn (int 0)) - (.visitInsn Opcodes/AALOAD))) - -(defn popI [^MethodVisitor writer] - (doto writer - (.visitLdcInsn (int 1)) - (.visitInsn Opcodes/AALOAD) - (.visitTypeInsn Opcodes/CHECKCAST "[Ljava/lang/Object;"))) - -(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 1)) - (.visitVarInsn Opcodes/ALOAD 0) - (.visitInsn Opcodes/AASTORE) - (.visitInsn Opcodes/DUP) - (.visitLdcInsn (int 0)) - (.visitVarInsn Opcodes/ALOAD 1) - (.visitInsn Opcodes/AASTORE) - (.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 - (.visitLdcInsn "") ;; 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)) - _ (let [$from (new Label) - $to (new Label) - $handler (new Label) - make-string-writerI (fn [^MethodVisitor _method_] - (doto _method_ - (.visitTypeInsn Opcodes/NEW "java/io/StringWriter") - (.visitInsn Opcodes/DUP) - (.visitMethodInsn Opcodes/INVOKESPECIAL "java/io/StringWriter" "<init>" "()V"))) - make-print-writerI (fn [^MethodVisitor _method_] - (doto _method_ - ;; W - (.visitTypeInsn Opcodes/NEW "java/io/PrintWriter") ;; WP - (.visitInsn Opcodes/SWAP) ;; PW - (.visitInsn Opcodes/DUP2) ;; PWPW - (.visitInsn Opcodes/POP) ;; PWP - (.visitInsn Opcodes/SWAP) ;; PPW - (.visitLdcInsn true) ;; PPW? - (.visitMethodInsn Opcodes/INVOKESPECIAL "java/io/PrintWriter" "<init>" "(Ljava/io/Writer;Z)V") - ;; P - ))] - (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "runTry" "(Llux/Function;)[Ljava/lang/Object;" nil nil) - (.visitCode) - (.visitTryCatchBlock $from $to $handler "java/lang/Throwable") - (.visitLabel $from) - (.visitVarInsn Opcodes/ALOAD 0) - (.visitInsn Opcodes/ACONST_NULL) - (.visitMethodInsn Opcodes/INVOKEVIRTUAL "lux/Function" &&/apply-method (&&/apply-signature 1)) - (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "make_some" "(Ljava/lang/Object;)[Ljava/lang/Object;") - (.visitInsn Opcodes/ARETURN) - (.visitLabel $to) - (.visitLabel $handler) ;; T - make-string-writerI ;; TW - (.visitInsn Opcodes/DUP2) ;; TWTW - make-print-writerI ;; TWTP - (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/Throwable" "printStackTrace" "(Ljava/io/PrintWriter;)V") ;; TW - (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/io/StringWriter" "toString" "()Ljava/lang/String;") ;; TS - (.visitInsn Opcodes/SWAP) (.visitInsn Opcodes/POP) ;; S - (.visitLdcInsn (->> #'&/$Left meta ::&/idx int)) ;; SI - (.visitInsn Opcodes/ACONST_NULL) ;; SI? - swap2x1 ;; I?S - (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "sum_make" "(ILjava/lang/Object;Ljava/lang/Object;)[Ljava/lang/Object;") - (.visitInsn Opcodes/ARETURN) - (.visitMaxs 0 0) - (.visitEnd))) - _ (doto =class - (compile-LuxRT-pm-methods) - (compile-LuxRT-adt-methods) - (compile-LuxRT-int-methods) - (compile-LuxRT-frac-methods))]] - (&&/save-class! (second (string/split &&/lux-utils-class #"/")) - (.toByteArray (doto =class .visitEnd))))) diff --git a/luxc/src/lux/compiler/parallel.clj b/luxc/src/lux/compiler/parallel.clj deleted file mode 100644 index 28716b45b..000000000 --- a/luxc/src/lux/compiler/parallel.clj +++ /dev/null @@ -1,45 +0,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 |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 - (try (|case (&/run-state (compile-module* module-name) - compiler) - (&/$Right post-compiler _) - (deliver task (&/$Right post-compiler)) - - (&/$Left ?error) - (deliver task (&/$Left ?error))) - (catch Throwable ex - (.printStackTrace ex) - (deliver task (&/$Left "")))))] - (&/|log! out-str))))))]] - (return task)))) diff --git a/luxc/src/lux/host.clj b/luxc/src/lux/host.clj deleted file mode 100644 index 562d582f6..000000000 --- a/luxc/src/lux/host.clj +++ /dev/null @@ -1,432 +0,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 |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 (, Int Type))" - [type] - (|case type - (&/$Primitive "#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 - "(-> Type (Lux Text))" - [^objects type] - (|case type - (&/$Primitive ?name params) - (cond (= &host-type/array-data-tag ?name) (|do [:let [[level base] (unfold-array type)] - base-sig (|case base - (&/$Primitive 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))) - - (&/$Function _ _) - (return (&host-generics/->type-signature function-class)) - - (&/$Sum _) - (return object-array) - - (&/$Product _) - (return object-array) - - (&/$Named ?name ?type) - (->java-sig ?type) - - (&/$Apply ?A ?F) - (|do [type* (&type/apply-type ?F ?A)] - (->java-sig type*)) - - (&/$Ex _) - (return ex-type-class) - - _ - (if (&type/type= &type/Any type) - (return "V") - (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 - "(-> ClassLoader SuperClassDecl (Lux (List (, Text (List Text)))))" - [class-loader super-class] - (|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 - "(-> PrivacyModifier Int)" - [privacy-modifier] - (|case privacy-modifier - (&/$PublicPM) Opcodes/ACC_PUBLIC - (&/$PrivatePM) Opcodes/ACC_PRIVATE - (&/$ProtectedPM) Opcodes/ACC_PROTECTED - (&/$DefaultPM) 0 - )) - -(defn state-modifier->flag - "(-> StateModifier Int)" - [state-modifier] - (|case state-modifier - (&/$DefaultSM) 0 - (&/$VolatileSM) Opcodes/ACC_VOLATILE - (&/$FinalSM) Opcodes/ACC_FINAL)) - -(defn inheritance-modifier->flag - "(-> InheritanceModifier Int)" - [inheritance-modifier] - (|case inheritance-modifier - (&/$DefaultIM) 0 - (&/$AbstractIM) Opcodes/ACC_ABSTRACT - (&/$FinalIM) Opcodes/ACC_FINAL)) - -(defn use-dummy-class [class-decl super-class interfaces ctor-args fields methods] - (|do [module &/get-module-name - :let [[?name ?params] class-decl - dummy-name ?name;; (str ?name "__DUMMY__") - dummy-full-name (str module "/" dummy-name) - real-name (str (&host-generics/->class-name module) "." ?name) - store-name (str (&host-generics/->class-name module) "." dummy-name) - class-signature (&host-generics/gclass-decl->signature class-decl (&/$Cons super-class interfaces)) - =class (doto (new ClassWriter ClassWriter/COMPUTE_MAXS) - (.visit bytecode-version (+ Opcodes/ACC_PUBLIC Opcodes/ACC_SUPER) - dummy-full-name - (if (= "" class-signature) nil class-signature) - (&host-generics/->bytecode-class-name (&host-generics/super-class-name super-class)) - (->> interfaces (&/|map (comp &host-generics/->bytecode-class-name &host-generics/super-class-name)) &/->seq (into-array String)))) - _ (&/|map (fn [field] - (|case field - (&/$ConstantFieldAnalysis =name =anns =type ?value) - (doto (.visitField =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC Opcodes/ACC_FINAL) =name - (&host-generics/gclass->simple-signature =type) - (&host-generics/gclass->signature =type) - nil) - (.visitEnd)) - - (&/$VariableFieldAnalysis =name =privacy-modifier =state-modifier =anns =type) - (doto (.visitField =class (+ Opcodes/ACC_PUBLIC (state-modifier->flag =state-modifier)) =name - (&host-generics/gclass->simple-signature =type) - (&host-generics/gclass->signature =type) - nil) - (.visitEnd)) - )) - fields) - _ (&/|map (partial compile-dummy-method =class real-name store-name super-class) methods) - bytecode (.toByteArray (doto =class .visitEnd))] - ^ClassLoader loader &/loader - !classes &/classes - :let [_ (swap! !classes assoc store-name bytecode) - _ (.loadClass loader store-name)] - _ (&/push-dummy-name real-name store-name)] - (return nil))) diff --git a/luxc/src/lux/host/generics.clj b/luxc/src/lux/host/generics.clj deleted file mode 100644 index 9e0359760..000000000 --- a/luxc/src/lux/host/generics.clj +++ /dev/null @@ -1,200 +0,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 |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* does not 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 does not work on arrays.")))) - -(defn method-signatures [method-decl] - (|let [[=name =anns =gvars =exceptions =inputs =output] method-decl - simple-signature (str "(" (&/fold str "" (&/|map gclass->simple-signature =inputs)) ")" (gclass->simple-signature =output)) - generic-signature (str (formal-type-parameters->signature =gvars) - "(" (&/fold str "" (&/|map gclass->signature =inputs)) ")" - (gclass->signature =output) - (->> =exceptions (&/|map gclass->signature) (&/|interpose " ") (&/fold str "")))] - (&/T [simple-signature generic-signature]))) diff --git a/luxc/src/lux/lexer.clj b/luxc/src/lux/lexer.clj deleted file mode 100644 index 49e29710a..000000000 --- a/luxc/src/lux/lexer.clj +++ /dev/null @@ -1,137 +0,0 @@ -(ns lux.lexer - (:require (clojure [template :refer [do-template]] - [string :as string]) - (lux [base :as & :refer [defvariant |do return* return |case]] - [reader :as &reader]) - [lux.analyser.module :as &module])) - -;; [Tags] -(defvariant - ("White_Space" 1) - ("Comment" 1) - ("Bit" 1) - ("Nat" 1) - ("Int" 1) - ("Rev" 1) - ("Frac" 1) - ("Text" 1) - ("Identifier" 1) - ("Tag" 1) - ("Open_Paren" 0) - ("Close_Paren" 0) - ("Open_Bracket" 0) - ("Close_Bracket" 0) - ("Open_Brace" 0) - ("Close_Brace" 0) - ) - -;; [Utils] -(def lex-text - (|do [[meta _ _] (&reader/read-text "\"") - :let [[_ _ _column] meta] - [_ _ ^String content] (&reader/read-regex #"^([^\"]*)") - _ (&reader/read-text "\"")] - (return (&/T [meta ($Text content)])))) - -(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-comment - (|do [_ (&reader/read-text "##") - [meta _ comment] (&reader/read-regex #"^(.*)$")] - (return (&/T [meta ($Comment comment)])))) - -(do-template [<name> <tag> <regex>] - (def <name> - (|do [[meta _ token] (&reader/read-regex <regex>)] - (return (&/T [meta (<tag> token)])))) - - lex-bit $Bit #"^#(0|1)" - ) - -(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-9][0-9,]*" - lex-int $Int #"^(-|\+)[0-9][0-9,]*" - lex-rev $Rev #"^\.[0-9][0-9,]*" - lex-frac $Frac #"^(-|\+)[0-9][0-9,]*\.[0-9][0-9,]*((e|E)(-|\+)[0-9][0-9,]*)?" - ) - -(def +same-module-mark+ (str &/+name-separator+ &/+name-separator+)) - -(def ^:private lex-ident - (&/try-all-% "[Reader Error]" - (&/|list (|do [[meta _ token] (&reader/read-regex +ident-re+) - [_ _ got-it?] (&reader/read-text? &/+name-separator+)] - (|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 +same-module-mark+) - [_ _ token] (&reader/read-regex +ident-re+) - module-name &/get-module-name] - (return (&/T [meta (&/T [module-name token])]))) - (|do [[meta _ _] (&reader/read-text &/+name-separator+) - [_ _ token] (&reader/read-regex +ident-re+)] - (return (&/T [meta (&/T [&/prelude token])]))) - ))) - -(def ^:private lex-identifier - (|do [[meta ident] lex-ident] - (return (&/T [meta ($Identifier 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-bit - lex-nat - lex-frac - lex-rev - lex-int - lex-text - lex-identifier - lex-tag - lex-delimiter))) diff --git a/luxc/src/lux/lib/loader.clj b/luxc/src/lux/lib/loader.clj deleted file mode 100644 index 97e6ee684..000000000 --- a/luxc/src/lux/lib/loader.clj +++ /dev/null @@ -1,42 +0,0 @@ -(ns lux.lib.loader - (:refer-clojure :exclude [load]) - (:require (lux [base :as & :refer [|let |do return return* |case]])) - (:import (java.io InputStream - File - FileInputStream - ByteArrayInputStream - ByteArrayOutputStream) - java.util.jar.JarInputStream)) - -;; [Utils] -(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 [dependencies] - (->> dependencies - &/->seq - (map #(->> ^String % (new File) unpackage)) - (reduce merge {}))) diff --git a/luxc/src/lux/optimizer.clj b/luxc/src/lux/optimizer.clj deleted file mode 100644 index 6e235e084..000000000 --- a/luxc/src/lux/optimizer.clj +++ /dev/null @@ -1,1150 +0,0 @@ -(ns lux.optimizer - (:require (lux [base :as & :refer [|let |do return return* |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. - ("bit" 1) - ("nat" 1) - ("int" 1) - ("rev" 1) - ("frac" 1) - ("text" 1) - ("variant" 3) - ("tuple" 1) - ("apply" 2) - ("case" 2) - ("function" 5) - ("ann" 2) - ("def" 1) - ("var" 1) - ("captured" 3) - ("proc" 3) - - ;; These other tags represent higher-order constructs that manifest - ;; themselves as patterns in the code. - ;; Lux does not 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 do not 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 bit value. - ("BitPM" 1) - ;; Compare the CDN with a natural value. - ("NatPM" 1) - ;; Compare the CDN with an integer value. - ("IntPM" 1) - ;; Compare the CDN with a revolution value. - ("RevPM" 1) - ;; Compare the CDN with a frac value. - ("FracPM" 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/$BitTestAC _value) - (&/|list ($BitPM _value) - $PopPM) - - (&a-case/$NatTestAC _value) - (&/|list ($NatPM _value) - $PopPM) - - (&a-case/$IntTestAC _value) - (&/|list ($IntPM _value) - $PopPM) - - (&a-case/$RevTestAC _value) - (&/|list ($RevPM _value) - $PopPM) - - (&a-case/$FracTestAC _value) - (&/|list ($FracPM _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 cannot 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))))) - -;; 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)) - - [($BitPM _pre-value) ($BitPM _post-value)] - (if (= _pre-value _post-value) - ($BitPM _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)) - - [($RevPM _pre-value) ($RevPM _post-value)] - (if (= _pre-value _post-value) - ($RevPM _pre-value) - ($AltPM pre post)) - - [($FracPM _pre-value) ($FracPM _post-value)] - (if (= _pre-value _post-value) - ($FracPM _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 Bit 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 (&/T [meta ($var (&/$Local 1))])))]) - - (&/$Local idx) - (&/T [meta ($var (&/$Local (inc idx)))])) - 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 does not 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 Bit)" - [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 - "(-> Bit Analysis Optimized)" - [top-level-func? analysis] - (|let [[meta analysis-] analysis] - (|case analysis- - (&a/$bit value) - (&/T [meta ($bit value)]) - - (&a/$nat value) - (&/T [meta ($nat value)]) - - (&a/$int value) - (&/T [meta ($int value)]) - - (&a/$rev value) - (&/T [meta ($rev value)]) - - (&a/$frac value) - (&/T [meta ($frac 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)] - (&/T [meta ($apply =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/$BitTestAC true) _then] - (&/$Cons [(&a-case/$BitTestAC false) _else] - (&/$Nil))) - (&/T [meta ($if (pass-0 top-level-func? value) (pass-0 top-level-func? _then) (pass-0 top-level-func? _else))]) - - (&/$Cons [(&a-case/$BitTestAC true) _then] - (&/$Cons [(&a-case/$NoTestAC false) _else] - (&/$Nil))) - (&/T [meta ($if (pass-0 top-level-func? value) (pass-0 top-level-func? _then) (pass-0 top-level-func? _else))]) - - (&/$Cons [(&a-case/$BitTestAC false) _else] - (&/$Cons [(&a-case/$BitTestAC true) _then] - (&/$Nil))) - (&/T [meta ($if (pass-0 top-level-func? value) (pass-0 top-level-func? _then) (pass-0 top-level-func? _else))]) - - (&/$Cons [(&a-case/$BitTestAC false) _else] - (&/$Cons [(&a-case/$NoTestAC) _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/$function _register-offset scope captured body) - (|let [inner-func? (|case body - [_ (&a/$function _ _ _ _)] - 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/$def def-name) - (&/T [meta ($def def-name)]) - - (&a/$var var-kind) - (&/T [meta ($var var-kind)]) - - (&a/$captured scope idx source) - (&/T [meta ($captured scope idx (pass-0 top-level-func? source))]) - - (&a/$proc proc-ident args special-args) - (&/T [meta ($proc proc-ident (&/|map (partial pass-0 top-level-func?) args) special-args)]) - - _ - (assert false (prn-str 'pass-0 top-level-func? (&/adt->text analysis))) - )))) - -;; [Exports] -(defn optimize - "(-> Analysis Optimized)" - [analysis] - (->> analysis - (pass-0 true))) diff --git a/luxc/src/lux/parser.clj b/luxc/src/lux/parser.clj deleted file mode 100644 index dd33129b8..000000000 --- a/luxc/src/lux/parser.clj +++ /dev/null @@ -1,105 +0,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) - (if (or (.contains error base-uneven-record-error) - (not (.contains error "[Parser Error]"))) - (&/$Left error) - (&/$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" &/$Form - ^:private parse-tuple &lexer/$Close_Bracket "brackets" &/$Tuple - ) - -(defn ^:private parse-record [parse] - (|do [elems* (repeat% parse) - token &lexer/lex - :let [elems (&/fold &/|++ &/$Nil elems*)]] - (|case token - [meta (&lexer/$Close_Brace _)] - (|do [_ (&/assert! (even? (&/|length elems)) - (&/fail-with-loc base-uneven-record-error))] - (return (&/$Record (&/|as-pairs elems)))) - - _ - (&/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/$Bit ?value) - (return (&/|list (&/T [meta (&/$Bit (.equals ^String ?value "#1"))]))) - - (&lexer/$Nat ?value) - (return (&/|list (&/T [meta (&/$Nat (Long/parseUnsignedLong ?value))]))) - - (&lexer/$Int ?value) - (return (&/|list (&/T [meta (&/$Int (Long/parseLong ?value))]))) - - (&lexer/$Rev ?value) - (return (&/|list (&/T [meta (&/$Rev (&/decode-rev ?value))]))) - - (&lexer/$Frac ?value) - (return (&/|list (&/T [meta (&/$Frac (Double/parseDouble ?value))]))) - - (&lexer/$Text ?value) - (return (&/|list (&/T [meta (&/$Text ?value)]))) - - (&lexer/$Identifier ?ident) - (return (&/|list (&/T [meta (&/$Identifier ?ident)]))) - - (&lexer/$Tag ?ident) - (return (&/|list (&/T [meta (&/$Tag ?ident)]))) - - (&lexer/$Open_Paren _) - (|do [syntax (parse-form parse)] - (return (&/|list (&/T [meta syntax])))) - - (&lexer/$Open_Bracket _) - (|do [syntax (parse-tuple parse)] - (return (&/|list (&/T [meta syntax])))) - - (&lexer/$Open_Brace _) - (|do [syntax (parse-record parse)] - (return (&/|list (&/T [meta syntax])))) - - _ - (&/fail-with-loc "[Parser Error] Unknown lexer token.") - ))) diff --git a/luxc/src/lux/reader.clj b/luxc/src/lux/reader.clj deleted file mode 100644 index 14914cc2e..000000000 --- a/luxc/src/lux/reader.clj +++ /dev/null @@ -1,153 +0,0 @@ -(ns lux.reader - (:require [clojure.string :as string] - clojure.core.match - clojure.core.match.array - [lux.base :as & :refer [defvariant |do return* return |let |case]])) - -;; [Tags] -(defvariant - ("No" 1) - ("Done" 1) - ("Yes" 2)) - -;; [Utils] -(defn- with-line [body] - (fn [state] - (|case (&/get$ &/$source state) - (&/$Nil) - ((&/fail-with-loc "[Reader Error] EOF") state) - - (&/$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- 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- 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 (Reader (Maybe Text)))" - [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 (&/$Some match)])) - ($Yes (&/T [(&/T [file-name line-num column-num]) false (&/$Some match)]) - (&/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 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 - "(-> Text (Reader Text))" - [^String 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? - "(-> Text (Reader (Maybe Text)))" - [^String 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) - ((&/fail-with-loc error) state) - - (&/$Right state* output) - (&/$Right (&/T [(&/set$ &/$source old-source state*) output])))))) diff --git a/luxc/src/lux/repl.clj b/luxc/src/lux/repl.clj deleted file mode 100644 index d980ac9ec..000000000 --- a/luxc/src/lux/repl.clj +++ /dev/null @@ -1,87 +0,0 @@ -(ns lux.repl - (:require clojure.core.match - clojure.core.match.array - (lux [base :as & :refer [|let |do return* return |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 :as &a-lux] - [module :as &module])) - (:import (java.io InputStreamReader - BufferedReader))) - -;; [Utils] -(def ^:private repl-module "REPL") - -(defn ^:private repl-location [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-location -1) "(;module: 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) - (do (println (str "Initialization failed:\n" ?message)) - (flush) - (System/exit 1))) - )) - -;; [Values] -(defn repl [dependencies source-dirs target-dir] - (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-location 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 _location] _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 ": " (&type/show-type _type) "\n" - "=> " (pr-str _value) "\n"))) - (recur state** (inc repl-line) false)) - - (&/$Left ^String ?message) - (if (or (= "[Reader Error] EOF" ?message) - (.contains ?message "[Parser Error] Unbalanced ")) - (recur state* (inc repl-line) true) - (do (println ?message) - (recur state (inc repl-line) false))) - )))) - ))) diff --git a/luxc/src/lux/type.clj b/luxc/src/lux/type.clj deleted file mode 100644 index 8853224b5..000000000 --- a/luxc/src/lux/type.clj +++ /dev/null @@ -1,973 +0,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 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 max-stack-size 256) - -(def empty-env &/$Nil) - -(def I64 (&/$Named (&/T ["lux" "I64"]) - (&/$UnivQ empty-env - (&/$Primitive "#I64" (&/|list (&/$Parameter 1)))))) -(def Nat* (&/$Primitive &&host/nat-data-tag &/$Nil)) -(def Rev* (&/$Primitive &&host/rev-data-tag &/$Nil)) -(def Int* (&/$Primitive &&host/int-data-tag &/$Nil)) - -(def Bit (&/$Named (&/T ["lux" "Bit"]) (&/$Primitive "#Bit" &/$Nil))) -(def Nat (&/$Named (&/T ["lux" "Nat"]) (&/$Apply Nat* I64))) -(def Rev (&/$Named (&/T ["lux" "Rev"]) (&/$Apply Rev* I64))) -(def Int (&/$Named (&/T ["lux" "Int"]) (&/$Apply Int* I64))) -(def Frac (&/$Named (&/T ["lux" "Frac"]) (&/$Primitive "#Frac" &/$Nil))) -(def Text (&/$Named (&/T ["lux" "Text"]) (&/$Primitive "#Text" &/$Nil))) -(def Ident (&/$Named (&/T ["lux" "Ident"]) (&/$Product Text Text))) - -(defn Array [elemT] - (&/$Primitive "#Array" (&/|list elemT))) - -(def Nothing - (&/$Named (&/T ["lux" "Nothing"]) - (&/$UnivQ empty-env - (&/$Parameter 1)))) - -(def Any - (&/$Named (&/T ["lux" "Any"]) - (&/$ExQ empty-env - (&/$Parameter 1)))) - -(def IO - (&/$Named (&/T ["lux/control/io" "IO"]) - (&/$UnivQ empty-env - (&/$Primitive "lux/type/abstract.Abstraction lux/control/io.IO" (&/|list (&/$Parameter 1)))))) - -(def List - (&/$Named (&/T ["lux" "List"]) - (&/$UnivQ empty-env - (&/$Sum - ;; lux;Nil - Any - ;; lux;Cons - (&/$Product (&/$Parameter 1) - (&/$Apply (&/$Parameter 1) - (&/$Parameter 0))))))) - -(def Maybe - (&/$Named (&/T ["lux" "Maybe"]) - (&/$UnivQ empty-env - (&/$Sum - ;; lux;None - Any - ;; lux;Some - (&/$Parameter 1)) - ))) - -(def Type - (&/$Named (&/T ["lux" "Type"]) - (let [Type (&/$Apply (&/$Parameter 1) (&/$Parameter 0)) - TypeList (&/$Apply Type List) - TypePair (&/$Product Type Type)] - (&/$Apply Nothing - (&/$UnivQ empty-env - (&/$Sum - ;; Primitive - (&/$Product Text TypeList) - (&/$Sum - ;; Sum - TypePair - (&/$Sum - ;; Product - TypePair - (&/$Sum - ;; Function - TypePair - (&/$Sum - ;; Parameter - Nat - (&/$Sum - ;; Var - Nat - (&/$Sum - ;; Ex - Nat - (&/$Sum - ;; UnivQ - (&/$Product TypeList Type) - (&/$Sum - ;; ExQ - (&/$Product TypeList Type) - (&/$Sum - ;; App - TypePair - ;; Named - (&/$Product Ident Type))))))))))) - ))))) - -(def Location - (&/$Named (&/T ["lux" "Location"]) - (&/$Product Text (&/$Product Nat Nat)))) - -(def Meta - (&/$Named (&/T ["lux" "Meta"]) - (&/$UnivQ empty-env - (&/$UnivQ empty-env - (&/$Product (&/$Parameter 3) - (&/$Parameter 1)))))) - -(def Code* - (&/$Named (&/T ["lux" "Code'"]) - (let [Code (&/$Apply (&/$Apply (&/$Parameter 1) - (&/$Parameter 0)) - (&/$Parameter 1)) - Code-List (&/$Apply Code List)] - (&/$UnivQ empty-env - (&/$Sum ;; "lux;Bit" - Bit - (&/$Sum ;; "lux;Nat" - Nat - (&/$Sum ;; "lux;Int" - Int - (&/$Sum ;; "lux;Rev" - Rev - (&/$Sum ;; "lux;Frac" - Frac - (&/$Sum ;; "lux;Text" - Text - (&/$Sum ;; "lux;Identifier" - Ident - (&/$Sum ;; "lux;Tag" - Ident - (&/$Sum ;; "lux;Form" - Code-List - (&/$Sum ;; "lux;Tuple" - Code-List - ;; "lux;Record" - (&/$Apply (&/$Product Code Code) List) - )))))))))) - )))) - -(def Code - (&/$Named (&/T ["lux" "Code"]) - (let [w (&/$Apply Location Meta)] - (&/$Apply (&/$Apply w Code*) w)))) - -(def Macro - (&/$Named (&/T ["lux" "Macro"]) - (&/$Primitive "#Macro" &/$Nil))) - -(defn bound? [id] - (fn [state] - (if-let [type (->> state (&/get$ &/$type-context) (&/get$ &/$var-bindings) (&/|get id))] - (|case type - (&/$Some type*) - (return* state true) - - (&/$None) - (return* state false)) - ((&/fail-with-loc (str "[Type Error] Unknown type-var: " id)) - state)))) - -(defn deref [id] - (fn [state] - (if-let [type* (->> state (&/get$ &/$type-context) (&/get$ &/$var-bindings) (&/|get id))] - (|case type* - (&/$Some type) - (return* state type) - - (&/$None) - ((&/fail-with-loc (str "[Type Error] Un-bound type-var: " id)) - state)) - ((&/fail-with-loc (str "[Type Error] Unknown type-var: " id)) - state)))) - -(defn deref+ [type] - (|case type - (&/$Var id) - (deref id) - - _ - (&/fail-with-loc (str "[Type Error] Type is not a variable: " (show-type type))) - )) - -(defn set-var [id type] - (fn [state] - (if-let [tvar (->> state (&/get$ &/$type-context) (&/get$ &/$var-bindings) (&/|get id))] - (|case tvar - (&/$Some bound) - (if (type= type bound) - (return* state nil) - ((&/fail-with-loc (str "[Type Error] Cannot re-bind type var: " id " | Current type: " (show-type bound))) - state)) - - (&/$None) - (return* (&/update$ &/$type-context (fn [ts] (&/update$ &/$var-bindings #(&/|put id (&/$Some type) %) - ts)) - state) - nil)) - ((&/fail-with-loc (str "[Type Error] Unknown type-var: " id " | " (->> state (&/get$ &/$type-context) (&/get$ &/$var-bindings) &/|length))) - state)))) - -(defn reset-var [id type] - (fn [state] - (if-let [tvar (->> state (&/get$ &/$type-context) (&/get$ &/$var-bindings) (&/|get id))] - (return* (&/update$ &/$type-context (fn [ts] (&/update$ &/$var-bindings #(&/|put id (&/$Some type) %) - ts)) - state) - nil) - ((&/fail-with-loc (str "[Type Error] Unknown type-var: " id " | " (->> state (&/get$ &/$type-context) (&/get$ &/$var-bindings) &/|length))) - state)))) - -(defn unset-var [id] - (fn [state] - (if-let [tvar (->> state (&/get$ &/$type-context) (&/get$ &/$var-bindings) (&/|get id))] - (return* (&/update$ &/$type-context (fn [ts] (&/update$ &/$var-bindings #(&/|put id &/$None %) - ts)) - state) - nil) - ((&/fail-with-loc (str "[Type Error] Unknown type-var: " id " | " (->> state (&/get$ &/$type-context) (&/get$ &/$var-bindings) &/|length))) - state)))) - -;; [Exports] -;; Type vars -(def reset-mappings - (fn [state] - (return* (&/update$ &/$type-context #(->> % - (&/set$ &/$var-counter 0) - (&/set$ &/$var-bindings (&/|table))) - state) - nil))) - -(def create-var - (fn [state] - (let [id (->> state (&/get$ &/$type-context) (&/get$ &/$var-counter))] - (return* (&/update$ &/$type-context #(->> % - (&/update$ &/$var-counter inc) - (&/update$ &/$var-bindings (fn [ms] (&/|put id &/$None ms)))) - state) - id)))) - -(def existential - ;; (Lux Type) - (fn [compiler] - (return* (&/update$ &/$type-context - (fn [context] - (&/update$ &/$ex-counter inc context)) - compiler) - (->> compiler - (&/get$ &/$type-context) - (&/get$ &/$ex-counter) - &/$Ex)))) - -(defn with-var [k] - (|do [id create-var] - (k (&/$Var id)))) - -(defn clean* [?tid type] - (|case type - (&/$Var ?id) - (if (= ?tid ?id) - (|do [? (bound? ?id)] - (if ? - (deref ?id) - (return type))) - (|do [? (bound? ?id)] - (if ? - (|do [=type (deref ?id) - ==type (clean* ?tid =type)] - (|case ==type - (&/$Var =id) - (if (= ?tid =id) - (|do [_ (unset-var ?id)] - (return type)) - (|do [_ (reset-var ?id ==type)] - (return type))) - - _ - (|do [_ (reset-var ?id ==type)] - (return ==type)))) - (return type))) - ) - - (&/$Primitive ?name ?params) - (|do [=params (&/map% (partial clean* ?tid) ?params)] - (return (&/$Primitive ?name =params))) - - (&/$Function ?arg ?return) - (|do [=arg (clean* ?tid ?arg) - =return (clean* ?tid ?return)] - (return (&/$Function =arg =return))) - - (&/$Apply ?param ?lambda) - (|do [=lambda (clean* ?tid ?lambda) - =param (clean* ?tid ?param)] - (return (&/$Apply =param =lambda))) - - (&/$Product ?left ?right) - (|do [=left (clean* ?tid ?left) - =right (clean* ?tid ?right)] - (return (&/$Product =left =right))) - - (&/$Sum ?left ?right) - (|do [=left (clean* ?tid ?left) - =right (clean* ?tid ?right)] - (return (&/$Sum =left =right))) - - (&/$UnivQ ?env ?body) - (|do [=env (&/map% (partial clean* ?tid) ?env) - body* (clean* ?tid ?body)] ;; TODO: DO NOT CLEAN THE BODY - (return (&/$UnivQ =env body*))) - - (&/$ExQ ?env ?body) - (|do [=env (&/map% (partial clean* ?tid) ?env) - body* (clean* ?tid ?body)] ;; TODO: DO NOT CLEAN THE BODY - (return (&/$ExQ =env body*))) - - _ - (return type) - )) - -(defn clean [tvar type] - (|case tvar - (&/$Var ?id) - (clean* ?id type) - - _ - (&/fail-with-loc (str "[Type Error] Not type-var: " (show-type tvar))))) - -(defn ^:private unravel-fun [type] - (|case type - (&/$Function ?in ?out) - (|let [[??out ?args] (unravel-fun ?out)] - (&/T [??out (&/$Cons ?in ?args)])) - - _ - (&/T [type &/$Nil]))) - -(defn ^:private unravel-app - ([fun-type tail] - (|case fun-type - (&/$Apply ?arg ?func) - (unravel-app ?func (&/$Cons ?arg tail)) - - _ - (&/T [fun-type tail]))) - ([fun-type] - (unravel-app fun-type &/$Nil))) - -(do-template [<tag> <flatten> <at> <desc>] - (do (defn <flatten> - "(-> Type (List Type))" - [type] - (|case type - (<tag> left right) - (&/$Cons left (<flatten> right)) - - _ - (&/|list type))) - - (defn <at> - "(-> Int Type (Lux Type))" - [tag type] - (|case type - (&/$Named ?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-with-loc (str "[Type Error] " <desc> " lacks member: " tag " | " (show-type type)))) - - _ - (&/fail-with-loc (str "[Type Error] Type is not a " <desc> ": " (show-type type)))))) - - &/$Sum flatten-sum sum-at "Sum" - &/$Product flatten-prod prod-at "Product" - ) - -(do-template [<name> <ctor> <unit>] - (defn <name> - "(-> (List Type) Type)" - [types] - (|case (&/|reverse types) - (&/$Cons last prevs) - (&/fold (fn [right left] (<ctor> left right)) last prevs) - - (&/$Nil) - <unit>)) - - Variant$ &/$Sum Nothing - Tuple$ &/$Product Any - ) - -(defn show-type [^objects type] - (|case type - (&/$Primitive name params) - (|case params - (&/$Nil) - (str "(primitive " (pr-str name) ")") - - _ - (str "(primitive " (pr-str name) " " (->> params (&/|map show-type) (&/|interpose " ") (&/fold str "")) ")")) - - (&/$Product _) - (str "[" (->> (flatten-prod type) (&/|map show-type) (&/|interpose " ") (&/fold str "")) "]") - - (&/$Sum _) - (str "(| " (->> (flatten-sum type) (&/|map show-type) (&/|interpose " ") (&/fold str "")) ")") - - (&/$Function input output) - (|let [[?out ?ins] (unravel-fun type)] - (str "(-> " (->> ?ins (&/|map show-type) (&/|interpose " ") (&/fold str "")) " " (show-type ?out) ")")) - - (&/$Var id) - (str "⌈v:" id "⌋") - - (&/$Ex ?id) - (str "⟨e:" ?id "⟩") - - (&/$Parameter idx) - (str idx) - - (&/$Apply _ _) - (|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 " "{" (->> ?env (&/|map show-type) (&/|interpose " ") (&/fold str "")) "} " - (show-type ?body) ")") - - (&/$ExQ ?env ?body) - (str "(Ex " "{" (->> ?env (&/|map show-type) (&/|interpose " ") (&/fold str "")) "} " - (show-type ?body) ")") - - (&/$Named ?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] - [(&/$Named [?xmodule ?xname] ?xtype) (&/$Named [?ymodule ?yname] ?ytype)] - (and (= ?xmodule ?ymodule) - (= ?xname ?yname)) - - [(&/$Primitive xname xparams) (&/$Primitive yname yparams)] - (and (.equals ^Object xname yname) - (= (&/|length xparams) (&/|length yparams)) - (&/fold2 #(and %1 (type= %2 %3)) true xparams yparams)) - - [(&/$Product xL xR) (&/$Product yL yR)] - (and (type= xL yL) - (type= xR yR)) - - [(&/$Sum xL xR) (&/$Sum yL yR)] - (and (type= xL yL) - (type= xR yR)) - - [(&/$Function xinput xoutput) (&/$Function yinput youtput)] - (and (type= xinput yinput) - (type= xoutput youtput)) - - [(&/$Var xid) (&/$Var yid)] - (= xid yid) - - [(&/$Parameter xidx) (&/$Parameter yidx)] - (= xidx yidx) - - [(&/$Ex xid) (&/$Ex yid)] - (= xid yid) - - [(&/$Apply xparam xlambda) (&/$Apply yparam ylambda)] - (and (type= xparam yparam) (type= xlambda ylambda)) - - [(&/$UnivQ xenv xbody) (&/$UnivQ yenv ybody)] - (type= xbody ybody) - - [(&/$Named ?xname ?xtype) _] - (type= ?xtype y) - - [_ (&/$Named ?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 - (&/$Var ?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 Error]\n" - "Expected: " =expected "\n\n" - " Actual: " =actual - "\n")))) - -(defn beta-reduce [env type] - (|case type - (&/$Primitive ?name ?params) - (&/$Primitive ?name (&/|map (partial beta-reduce env) ?params)) - - (&/$Sum ?left ?right) - (&/$Sum (beta-reduce env ?left) (beta-reduce env ?right)) - - (&/$Product ?left ?right) - (&/$Product (beta-reduce env ?left) (beta-reduce env ?right)) - - (&/$Apply ?type-arg ?type-fn) - (&/$Apply (beta-reduce env ?type-arg) (beta-reduce env ?type-fn)) - - (&/$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) - - (&/$Function ?input ?output) - (&/$Function (beta-reduce env ?input) (beta-reduce env ?output)) - - (&/$Parameter ?idx) - (|case (&/|at ?idx env) - (&/$Some parameter) - (beta-reduce env parameter) - - _ - (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)) - - (&/$Apply A F) - (|do [type-fn* (apply-type F A)] - (apply-type type-fn* param)) - - (&/$Named ?name ?type) - (apply-type ?type param) - - ;; TODO: This one must go... - (&/$Ex id) - (return (&/$Apply param type-fn)) - - (&/$Var id) - (|do [=type-fun (deref id)] - (apply-type =type-fun param)) - - _ - (&/fail-with-loc (str "[Type System] Not a type function:\n" (show-type type-fn) "\n" - "for arg: " (show-type param))))) - -(def ^:private init-fixpoints &/$Nil) - -(defn ^:private check* [fixpoints invariant?? expected actual] - (if (clojure.lang.Util/identical expected actual) - (return fixpoints) - (&/with-attempt - (|case [expected actual] - [(&/$Var ?eid) (&/$Var ?aid)] - (if (= ?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* fixpoints invariant?? etype actual) - - [(&/$None _) (&/$Some atype)] - (check* fixpoints invariant?? expected atype) - - [(&/$Some etype) (&/$Some atype)] - (check* fixpoints invariant?? etype atype)))) - - [(&/$Var ?id) _] - (fn [state] - (|case ((set-var ?id actual) state) - (&/$Right state* _) - (return* state* fixpoints) - - (&/$Left _) - ((|do [bound (deref ?id)] - (check* fixpoints invariant?? bound actual)) - state))) - - [_ (&/$Var ?id)] - (fn [state] - (|case ((set-var ?id expected) state) - (&/$Right state* _) - (return* state* fixpoints) - - (&/$Left _) - ((|do [bound (deref ?id)] - (check* fixpoints invariant?? expected bound)) - state))) - - [(&/$Apply eA (&/$Ex eid)) (&/$Apply aA (&/$Ex aid))] - (if (= eid aid) - (check* fixpoints invariant?? eA aA) - (check-error "" expected actual)) - - [(&/$Apply A1 (&/$Var ?id)) (&/$Apply A2 F2)] - (fn [state] - (|case ((|do [F1 (deref ?id)] - (check* fixpoints invariant?? (&/$Apply A1 F1) actual)) - state) - (&/$Right state* output) - (return* state* output) - - (&/$Left _) - (|case F2 - (&/$UnivQ (&/$Cons _) _) - ((|do [actual* (apply-type F2 A2)] - (check* fixpoints invariant?? expected actual*)) - state) - - (&/$Ex _) - ((|do [fixpoints* (check* fixpoints invariant?? (&/$Var ?id) F2)] - (check* fixpoints* invariant?? A1 A2)) - state) - - _ - ((|do [fixpoints* (check* fixpoints invariant?? (&/$Var ?id) F2) - e* (apply-type F2 A1) - a* (apply-type F2 A2)] - (check* fixpoints* invariant?? e* a*)) - state)))) - - [(&/$Apply A1 F1) (&/$Apply A2 (&/$Var ?id))] - (fn [state] - (|case ((|do [F2 (deref ?id)] - (check* fixpoints invariant?? expected (&/$Apply A2 F2))) - state) - (&/$Right state* output) - (return* state* output) - - (&/$Left _) - ((|do [fixpoints* (check* fixpoints invariant?? F1 (&/$Var ?id)) - e* (apply-type F1 A1) - a* (apply-type F1 A2)] - (check* fixpoints* invariant?? e* a*)) - state))) - - [(&/$Apply A F) _] - (let [fp-pair (&/T [expected actual]) - _ (when (> (&/|length fixpoints) max-stack-size) - (&/|log! (print-str '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* '[(&/$Apply A F) _] (&/|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* (fp-put fp-pair true fixpoints) invariant?? expected* actual)))) - - [_ (&/$Apply A (&/$Ex aid))] - (check-error "" expected actual) - - [_ (&/$Apply A F)] - (|do [actual* (apply-type F A)] - (check* fixpoints invariant?? expected actual*)) - - [(&/$UnivQ _) _] - (|do [$arg existential - expected* (apply-type expected $arg)] - (check* fixpoints invariant?? expected* actual)) - - [_ (&/$UnivQ _)] - (with-var - (fn [$arg] - (|do [actual* (apply-type actual $arg) - =output (check* 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* fixpoints invariant?? expected* actual) - _ (clean $arg actual)] - (return =output)))) - - [_ (&/$ExQ a!env a!def)] - (|do [$arg existential - actual* (apply-type actual $arg)] - (check* fixpoints invariant?? expected actual*)) - - [(&/$Primitive e!data) (&/$Primitive a!data)] - (|do [? &/jvm?] - (if ? - (|do [class-loader &/loader] - (&&host/check-host-types (partial check* fixpoints true) - check-error - fixpoints - existential - class-loader - invariant?? - e!data - a!data)) - (|let [[e!name e!params] e!data - [a!name a!params] a!data] - (if (and (= e!name a!name) - (= (&/|length e!params) (&/|length a!params))) - (|do [_ (&/map2% (partial check* fixpoints true) e!params a!params)] - (return fixpoints)) - (check-error "" expected actual))))) - - [(&/$Function eI eO) (&/$Function aI aO)] - (|do [fixpoints* (check* fixpoints invariant?? aI eI)] - (check* fixpoints* invariant?? eO aO)) - - [(&/$Product eL eR) (&/$Product aL aR)] - (|do [fixpoints* (check* fixpoints invariant?? eL aL)] - (check* fixpoints* invariant?? eR aR)) - - [(&/$Sum eL eR) (&/$Sum aL aR)] - (|do [fixpoints* (check* fixpoints invariant?? eL aL)] - (check* fixpoints* invariant?? eR aR)) - - [(&/$Ex e!id) (&/$Ex a!id)] - (if (= e!id a!id) - (return fixpoints) - (check-error "" expected actual)) - - [(&/$Named _ ?etype) _] - (check* fixpoints invariant?? ?etype actual) - - [_ (&/$Named _ ?atype)] - (check* fixpoints invariant?? expected ?atype) - - [_ _] - (&/fail "")) - (fn [err] - (check-error err expected actual))))) - -(defn check [expected actual] - (|do [_ (check* init-fixpoints false expected actual)] - (return nil))) - -(defn actual-type - "(-> Type (Lux Type))" - [type] - (|case type - (&/$Apply ?param ?all) - (|do [type* (apply-type ?all ?param)] - (actual-type type*)) - - (&/$Var id) - (|do [=type (deref id)] - (actual-type =type)) - - (&/$Named ?name ?type) - (actual-type ?type) - - _ - (return type) - )) - -(defn type-name - "(-> Type (Lux Ident))" - [type] - (|case type - (&/$Named name _) - (return name) - - _ - (&/fail-with-loc (str "[Type Error] Type is not named: " (show-type type))) - )) - -(defn unknown? - "(-> Type (Lux Bit))" - [type] - (|case type - (&/$Var id) - (|do [? (bound? id)] - (return (not ?))) - - _ - (return false))) - -(defn resolve-type - "(-> Type (Lux Type))" - [type] - (|case type - (&/$Var id) - (|do [? (bound? id)] - (if ? - (deref id) - (return type))) - - _ - (return type))) - -(defn tuple-types-for - "(-> Int Type [Int (List Type)])" - [size-members 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] (&/$Product 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 Any &/$Product - fold-sum Nothing &/$Sum - ) - -(def create-var+ - (|do [id create-var] - (return (&/$Var id)))) - -(defn ^:private push-app [inf-type inf-var] - (|case inf-type - (&/$Apply inf-var* inf-type*) - (&/$Apply inf-var* (push-app inf-type* inf-var)) - - _ - (&/$Apply inf-var inf-type))) - -(defn ^:private push-name [name inf-type] - (|case inf-type - (&/$Apply inf-var* inf-type*) - (&/$Apply inf-var* (push-name name inf-type*)) - - _ - (&/$Named name inf-type))) - -(defn ^:private push-univq [env inf-type] - (|case inf-type - (&/$Apply inf-var* inf-type*) - (&/$Apply inf-var* (push-univq env inf-type*)) - - _ - (&/$UnivQ env inf-type))) - -(defn instantiate-inference [type] - (|case type - (&/$Named ?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 (&/$Var inf-var))))) - - _ - (return type))) diff --git a/luxc/src/lux/type/host.clj b/luxc/src/lux/type/host.clj deleted file mode 100644 index 36e969046..000000000 --- a/luxc/src/lux/type/host.clj +++ /dev/null @@ -1,411 +0,0 @@ -(ns lux.type.host - (:require clojure.core.match - clojure.core.match.array - (lux [base :as & :refer [|do return* return assert! |let |case]]) - [lux.host.generics :as &host-generics]) - (:import (java.lang.reflect GenericArrayType - ParameterizedType - TypeVariable - WildcardType))) - -(defn ^:private type= [x y] - (or (clojure.lang.Util/identical x y) - (let [output (|case [x y] - [(&/$Named [?xmodule ?xname] ?xtype) (&/$Named [?ymodule ?yname] ?ytype)] - (and (= ?xmodule ?ymodule) - (= ?xname ?yname)) - - [(&/$Primitive xname xparams) (&/$Primitive yname yparams)] - (and (.equals ^Object xname yname) - (= (&/|length xparams) (&/|length yparams)) - (&/fold2 #(and %1 (type= %2 %3)) true xparams yparams)) - - [(&/$Product xL xR) (&/$Product yL yR)] - (and (type= xL yL) - (type= xR yR)) - - [(&/$Sum xL xR) (&/$Sum yL yR)] - (and (type= xL yL) - (type= xR yR)) - - [(&/$Function xinput xoutput) (&/$Function yinput youtput)] - (and (type= xinput yinput) - (type= xoutput youtput)) - - [(&/$Var xid) (&/$Var yid)] - (= xid yid) - - [(&/$Parameter xidx) (&/$Parameter yidx)] - (= xidx yidx) - - [(&/$Ex xid) (&/$Ex yid)] - (= xid yid) - - [(&/$Apply xparam xlambda) (&/$Apply yparam ylambda)] - (and (type= xparam yparam) (type= xlambda ylambda)) - - [(&/$UnivQ xenv xbody) (&/$UnivQ yenv ybody)] - (type= xbody ybody) - - [(&/$Named ?xname ?xtype) _] - (type= ?xtype y) - - [_ (&/$Named ?yname ?ytype)] - (type= x ?ytype) - - [_ _] - false - )] - output))) - -(def ^:private Any - (&/$Named (&/T ["lux" "Any"]) - (&/$ExQ (&/|list) - (&/$Parameter 1)))) - -;; [Exports] -(def array-data-tag "#Array") -(def null-data-tag "#Null") -(def i64-data-tag "#I64") -(def nat-data-tag "#Nat") -(def int-data-tag "#Int") -(def rev-data-tag "#Rev") - -;; [Utils] -(defn ^:private trace-lineage* - "(-> Class Class (List Class))" - [^Class super-class ^Class sub-class] - ;; Either they're both interfaces, or they're both classes - (let [valid-sub? #(if (or (= super-class %) - (.isAssignableFrom super-class %)) - % - nil)] - (if (or (.isInterface sub-class) - (.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))) - (if-let [super* (.getSuperclass sub-class)] - (recur super* (&/$Cons super* stack)) - stack))) - (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 Class (List Class))" - [^Class sub-class ^Class super-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 Type)" - [^Class class] - (let [gclass-name (.getName class)] - (case gclass-name - ("[Z" "[B" "[S" "[I" "[J" "[F" "[D" "[C") - (&/$Primitive 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) - Any - (reduce (fn [inner _] (&/$Primitive array-data-tag (&/|list inner))) - (&/$Primitive base (try (-> (Class/forName base) .getTypeParameters - seq count (repeat (&/$Primitive "java.lang.Object" &/$Nil)) - &/->list) - (catch Exception e - (&/|list)))) - (range (count (or arr-obrackets arr-pbrackets ""))))) - )))))) - -(defn instance-param - "(-> (Lux Type) (List (, Text Type)) (^ java.lang.reflect.Type) (Lux Type))" - [existential matchings refl-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 (&/$Primitive 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 (&/$Primitive (->> 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-with-loc (str "[Host Error] Unknown generic type-variable: " gvar "\n" - "Available type-variables: " (->> 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) - (let [class-type (class->type refl-type)] - (if (type= Any class-type) - "V" - (|case class-type - (&/$Primitive "#Array" (&/$Cons (&/$Primitive class-name _) (&/$Nil))) - (str "[" (&host-generics/->type-signature class-name)) - - (&/$Primitive class-name _) - (&host-generics/->type-signature class-name)))) - - (instance? GenericArrayType refl-type) - (str "[" (principal-class (.getGenericComponentType ^GenericArrayType 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 - "(-> (Lux Type) (List (, Text Type)) GenericType (Lux Type))" - [existential matchings gtype] - (|case gtype - (&/$GenericArray component-type) - (|do [inner-type (instance-gtype existential matchings component-type)] - (return (&/$Primitive 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 (&/$Primitive type-name params*)))) - - (&/$GenericTypeVar var-name) - (if-let [m-type (&/|get var-name matchings)] - (return m-type) - (&/fail-with-loc (str "[Host Error] Unknown generic type-variable: " var-name "\n" - "Available type-variables: " (->> matchings - (&/|map &/|first) - &/->seq)))) - - (&/$GenericWildcard) - existential)) - -;; [Utils] -(defn ^:private translate-params - "(-> (List (^ java.lang.reflect.Type)) (List (^ java.lang.reflect.Type)) (List Type) (Lux (List Type)))" - [existential super-type-params sub-type-params params] - (|let [matchings (match-params sub-type-params params)] - (&/map% (partial instance-param existential matchings) super-type-params))) - -(defn ^:private raise* - "(-> (, Class (List Type)) Class (Lux (, Class (List Type))))" - [existential sub+params ^Class super] - (|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- raise - "(-> (List Class) Class (List Type) (Lux (, Class (List Type))))" - [existential lineage class params] - (&/fold% (partial raise* existential) (&/T [class params]) lineage)) - -;; [Exports] -(defn find-class! [class class-loader] - (try (return (Class/forName class true class-loader)) - (catch java.lang.ClassNotFoundException ex - (&/fail-with-loc (str "[Host Error] Cannot find class: " (pr-str class)))))) - -(defn ->super-type - "(-> Text Text (List Type) (Lux Type))" - [existential class-loader super-class sub-class sub-params] - (|do [^Class super-class+ (find-class! super-class class-loader) - ^Class sub-class+ (find-class! sub-class 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 (&/$Primitive (.getName sub-class*) sub-params*)))) - (&/fail-with-loc (str "[Host Error] Classes do not 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))) - -(def ^:private lux-jvm-type-combos - #{#{"java.lang.Boolean" "#Bit"} - #{"java.lang.Long" i64-data-tag} - #{"java.lang.Double" "#Frac"} - #{"java.lang.String" "#Text"}}) - -(defn ^:private lux-type? [^String class-name] - (.startsWith class-name "#")) - -(defn check-host-types [check check-error fixpoints existential class-loader invariant?? expected actual] - (|let [[^String e!name e!params] expected - [^String a!name a!params] actual] - (try (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)) - (check-error "" (&/$Primitive e!name e!params) (&/$Primitive a!name a!params))) - - (or (lux-type? e!name) - (lux-type? a!name)) - (if (or (= "java.lang.Object" e!name) - (contains? lux-jvm-type-combos #{e!name a!name}) - (and (not (primitive-type? e!name)) - (= null-data-tag a!name))) - (return fixpoints) - (check-error "" (&/$Primitive e!name e!params) (&/$Primitive a!name a!params))) - - (not invariant??) - (|do [actual* (->super-type existential class-loader e!name a!name a!params)] - (check (&/$Primitive e!name e!params) actual*)) - - :else - (check-error "" (&/$Primitive e!name e!params) (&/$Primitive a!name a!params)))) - (catch Exception e - (throw e))))) - -(defn gtype->gclass - "(-> GenericType GenericClass)" - [gtype] - (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 - "(-> GenericClass Text)" - [gclass] - (|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 - ))) |