aboutsummaryrefslogtreecommitdiff
path: root/lux-bootstrapper/src
diff options
context:
space:
mode:
Diffstat (limited to 'lux-bootstrapper/src')
-rw-r--r--lux-bootstrapper/src/lux.clj35
-rw-r--r--lux-bootstrapper/src/lux/analyser.clj233
-rw-r--r--lux-bootstrapper/src/lux/analyser/base.clj127
-rw-r--r--lux-bootstrapper/src/lux/analyser/case.clj637
-rw-r--r--lux-bootstrapper/src/lux/analyser/env.clj78
-rw-r--r--lux-bootstrapper/src/lux/analyser/function.clj28
-rw-r--r--lux-bootstrapper/src/lux/analyser/lux.clj726
-rw-r--r--lux-bootstrapper/src/lux/analyser/module.clj431
-rw-r--r--lux-bootstrapper/src/lux/analyser/parser.clj478
-rw-r--r--lux-bootstrapper/src/lux/analyser/proc/common.clj299
-rw-r--r--lux-bootstrapper/src/lux/analyser/proc/jvm.clj1082
-rw-r--r--lux-bootstrapper/src/lux/analyser/record.clj42
-rw-r--r--lux-bootstrapper/src/lux/base.clj1490
-rw-r--r--lux-bootstrapper/src/lux/compiler.clj29
-rw-r--r--lux-bootstrapper/src/lux/compiler/cache.clj244
-rw-r--r--lux-bootstrapper/src/lux/compiler/cache/ann.clj138
-rw-r--r--lux-bootstrapper/src/lux/compiler/cache/type.clj143
-rw-r--r--lux-bootstrapper/src/lux/compiler/core.clj93
-rw-r--r--lux-bootstrapper/src/lux/compiler/io.clj36
-rw-r--r--lux-bootstrapper/src/lux/compiler/jvm.clj256
-rw-r--r--lux-bootstrapper/src/lux/compiler/jvm/base.clj88
-rw-r--r--lux-bootstrapper/src/lux/compiler/jvm/cache.clj63
-rw-r--r--lux-bootstrapper/src/lux/compiler/jvm/case.clj207
-rw-r--r--lux-bootstrapper/src/lux/compiler/jvm/function.clj278
-rw-r--r--lux-bootstrapper/src/lux/compiler/jvm/lux.clj402
-rw-r--r--lux-bootstrapper/src/lux/compiler/jvm/proc/common.clj460
-rw-r--r--lux-bootstrapper/src/lux/compiler/jvm/proc/host.clj1112
-rw-r--r--lux-bootstrapper/src/lux/compiler/jvm/rt.clj410
-rw-r--r--lux-bootstrapper/src/lux/compiler/parallel.clj45
-rw-r--r--lux-bootstrapper/src/lux/host.clj432
-rw-r--r--lux-bootstrapper/src/lux/host/generics.clj200
-rw-r--r--lux-bootstrapper/src/lux/lexer.clj137
-rw-r--r--lux-bootstrapper/src/lux/lib/loader.clj42
-rw-r--r--lux-bootstrapper/src/lux/optimizer.clj1150
-rw-r--r--lux-bootstrapper/src/lux/parser.clj105
-rw-r--r--lux-bootstrapper/src/lux/reader.clj153
-rw-r--r--lux-bootstrapper/src/lux/repl.clj87
-rw-r--r--lux-bootstrapper/src/lux/type.clj973
-rw-r--r--lux-bootstrapper/src/lux/type/host.clj411
39 files changed, 13380 insertions, 0 deletions
diff --git a/lux-bootstrapper/src/lux.clj b/lux-bootstrapper/src/lux.clj
new file mode 100644
index 000000000..dc6066669
--- /dev/null
+++ b/lux-bootstrapper/src/lux.clj
@@ -0,0 +1,35 @@
+(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/lux-bootstrapper/src/lux/analyser.clj b/lux-bootstrapper/src/lux/analyser.clj
new file mode 100644
index 000000000..af272fa91
--- /dev/null
+++ b/lux-bootstrapper/src/lux/analyser.clj
@@ -0,0 +1,233 @@
+(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/lux-bootstrapper/src/lux/analyser/base.clj b/lux-bootstrapper/src/lux/analyser/base.clj
new file mode 100644
index 000000000..d6787280f
--- /dev/null
+++ b/lux-bootstrapper/src/lux/analyser/base.clj
@@ -0,0 +1,127 @@
+(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/lux-bootstrapper/src/lux/analyser/case.clj b/lux-bootstrapper/src/lux/analyser/case.clj
new file mode 100644
index 000000000..d059ce189
--- /dev/null
+++ b/lux-bootstrapper/src/lux/analyser/case.clj
@@ -0,0 +1,637 @@
+(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/lux-bootstrapper/src/lux/analyser/env.clj b/lux-bootstrapper/src/lux/analyser/env.clj
new file mode 100644
index 000000000..a2b6e5ad3
--- /dev/null
+++ b/lux-bootstrapper/src/lux/analyser/env.clj
@@ -0,0 +1,78 @@
+(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/lux-bootstrapper/src/lux/analyser/function.clj b/lux-bootstrapper/src/lux/analyser/function.clj
new file mode 100644
index 000000000..3db24acef
--- /dev/null
+++ b/lux-bootstrapper/src/lux/analyser/function.clj
@@ -0,0 +1,28 @@
+(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/lux-bootstrapper/src/lux/analyser/lux.clj b/lux-bootstrapper/src/lux/analyser/lux.clj
new file mode 100644
index 000000000..b7d78aa23
--- /dev/null
+++ b/lux-bootstrapper/src/lux/analyser/lux.clj
@@ -0,0 +1,726 @@
+(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/lux-bootstrapper/src/lux/analyser/module.clj b/lux-bootstrapper/src/lux/analyser/module.clj
new file mode 100644
index 000000000..d41eb73d5
--- /dev/null
+++ b/lux-bootstrapper/src/lux/analyser/module.clj
@@ -0,0 +1,431 @@
+(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/lux-bootstrapper/src/lux/analyser/parser.clj b/lux-bootstrapper/src/lux/analyser/parser.clj
new file mode 100644
index 000000000..6a46bab3c
--- /dev/null
+++ b/lux-bootstrapper/src/lux/analyser/parser.clj
@@ -0,0 +1,478 @@
+(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/lux-bootstrapper/src/lux/analyser/proc/common.clj b/lux-bootstrapper/src/lux/analyser/proc/common.clj
new file mode 100644
index 000000000..6a1521909
--- /dev/null
+++ b/lux-bootstrapper/src/lux/analyser/proc/common.clj
@@ -0,0 +1,299 @@
+(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/lux-bootstrapper/src/lux/analyser/proc/jvm.clj b/lux-bootstrapper/src/lux/analyser/proc/jvm.clj
new file mode 100644
index 000000000..cc77bf72c
--- /dev/null
+++ b/lux-bootstrapper/src/lux/analyser/proc/jvm.clj
@@ -0,0 +1,1082 @@
+(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/lux-bootstrapper/src/lux/analyser/record.clj b/lux-bootstrapper/src/lux/analyser/record.clj
new file mode 100644
index 000000000..3d3d8169f
--- /dev/null
+++ b/lux-bootstrapper/src/lux/analyser/record.clj
@@ -0,0 +1,42 @@
+(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/lux-bootstrapper/src/lux/base.clj b/lux-bootstrapper/src/lux/base.clj
new file mode 100644
index 000000000..5ef710a03
--- /dev/null
+++ b/lux-bootstrapper/src/lux/base.clj
@@ -0,0 +1,1490 @@
+(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/lux-bootstrapper/src/lux/compiler.clj b/lux-bootstrapper/src/lux/compiler.clj
new file mode 100644
index 000000000..a3e60e463
--- /dev/null
+++ b/lux-bootstrapper/src/lux/compiler.clj
@@ -0,0 +1,29 @@
+(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 &&parallel]
+ [jvm :as &&jvm])))
+
+(defn init! [dependencies ^String target-dir]
+ (do (reset! &&core/!output-dir target-dir)
+ (&&parallel/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/lux-bootstrapper/src/lux/compiler/cache.clj b/lux-bootstrapper/src/lux/compiler/cache.clj
new file mode 100644
index 000000000..01e05c8de
--- /dev/null
+++ b/lux-bootstrapper/src/lux/compiler/cache.clj
@@ -0,0 +1,244 @@
+(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/lux-bootstrapper/src/lux/compiler/cache/ann.clj b/lux-bootstrapper/src/lux/compiler/cache/ann.clj
new file mode 100644
index 000000000..4c08af276
--- /dev/null
+++ b/lux-bootstrapper/src/lux/compiler/cache/ann.clj
@@ -0,0 +1,138 @@
+(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/lux-bootstrapper/src/lux/compiler/cache/type.clj b/lux-bootstrapper/src/lux/compiler/cache/type.clj
new file mode 100644
index 000000000..7c622d2c4
--- /dev/null
+++ b/lux-bootstrapper/src/lux/compiler/cache/type.clj
@@ -0,0 +1,143 @@
+(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/lux-bootstrapper/src/lux/compiler/core.clj b/lux-bootstrapper/src/lux/compiler/core.clj
new file mode 100644
index 000000000..88da626bd
--- /dev/null
+++ b/lux-bootstrapper/src/lux/compiler/core.clj
@@ -0,0 +1,93 @@
+(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/lux-bootstrapper/src/lux/compiler/io.clj b/lux-bootstrapper/src/lux/compiler/io.clj
new file mode 100644
index 000000000..d3658edd3
--- /dev/null
+++ b/lux-bootstrapper/src/lux/compiler/io.clj
@@ -0,0 +1,36 @@
+(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/lux-bootstrapper/src/lux/compiler/jvm.clj b/lux-bootstrapper/src/lux/compiler/jvm.clj
new file mode 100644
index 000000000..07c28dfac
--- /dev/null
+++ b/lux-bootstrapper/src/lux/compiler/jvm.clj
@@ -0,0 +1,256 @@
+(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 &&parallel])
+ (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!! (&&parallel/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/lux-bootstrapper/src/lux/compiler/jvm/base.clj b/lux-bootstrapper/src/lux/compiler/jvm/base.clj
new file mode 100644
index 000000000..b5e520de5
--- /dev/null
+++ b/lux-bootstrapper/src/lux/compiler/jvm/base.clj
@@ -0,0 +1,88 @@
+(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/lux-bootstrapper/src/lux/compiler/jvm/cache.clj b/lux-bootstrapper/src/lux/compiler/jvm/cache.clj
new file mode 100644
index 000000000..f54eacc92
--- /dev/null
+++ b/lux-bootstrapper/src/lux/compiler/jvm/cache.clj
@@ -0,0 +1,63 @@
+(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/lux-bootstrapper/src/lux/compiler/jvm/case.clj b/lux-bootstrapper/src/lux/compiler/jvm/case.clj
new file mode 100644
index 000000000..b7cdb7571
--- /dev/null
+++ b/lux-bootstrapper/src/lux/compiler/jvm/case.clj
@@ -0,0 +1,207 @@
+(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/lux-bootstrapper/src/lux/compiler/jvm/function.clj b/lux-bootstrapper/src/lux/compiler/jvm/function.clj
new file mode 100644
index 000000000..eb779a7b6
--- /dev/null
+++ b/lux-bootstrapper/src/lux/compiler/jvm/function.clj
@@ -0,0 +1,278 @@
+(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/lux-bootstrapper/src/lux/compiler/jvm/lux.clj b/lux-bootstrapper/src/lux/compiler/jvm/lux.clj
new file mode 100644
index 000000000..043fc2273
--- /dev/null
+++ b/lux-bootstrapper/src/lux/compiler/jvm/lux.clj
@@ -0,0 +1,402 @@
+(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/lux-bootstrapper/src/lux/compiler/jvm/proc/common.clj b/lux-bootstrapper/src/lux/compiler/jvm/proc/common.clj
new file mode 100644
index 000000000..d4c825282
--- /dev/null
+++ b/lux-bootstrapper/src/lux/compiler/jvm/proc/common.clj
@@ -0,0 +1,460 @@
+(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/lux-bootstrapper/src/lux/compiler/jvm/proc/host.clj b/lux-bootstrapper/src/lux/compiler/jvm/proc/host.clj
new file mode 100644
index 000000000..ec934ae7b
--- /dev/null
+++ b/lux-bootstrapper/src/lux/compiler/jvm/proc/host.clj
@@ -0,0 +1,1112 @@
+(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/lux-bootstrapper/src/lux/compiler/jvm/rt.clj b/lux-bootstrapper/src/lux/compiler/jvm/rt.clj
new file mode 100644
index 000000000..7fabd27ed
--- /dev/null
+++ b/lux-bootstrapper/src/lux/compiler/jvm/rt.clj
@@ -0,0 +1,410 @@
+(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/lux-bootstrapper/src/lux/compiler/parallel.clj b/lux-bootstrapper/src/lux/compiler/parallel.clj
new file mode 100644
index 000000000..28716b45b
--- /dev/null
+++ b/lux-bootstrapper/src/lux/compiler/parallel.clj
@@ -0,0 +1,45 @@
+(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/lux-bootstrapper/src/lux/host.clj b/lux-bootstrapper/src/lux/host.clj
new file mode 100644
index 000000000..562d582f6
--- /dev/null
+++ b/lux-bootstrapper/src/lux/host.clj
@@ -0,0 +1,432 @@
+(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/lux-bootstrapper/src/lux/host/generics.clj b/lux-bootstrapper/src/lux/host/generics.clj
new file mode 100644
index 000000000..9e0359760
--- /dev/null
+++ b/lux-bootstrapper/src/lux/host/generics.clj
@@ -0,0 +1,200 @@
+(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/lux-bootstrapper/src/lux/lexer.clj b/lux-bootstrapper/src/lux/lexer.clj
new file mode 100644
index 000000000..49e29710a
--- /dev/null
+++ b/lux-bootstrapper/src/lux/lexer.clj
@@ -0,0 +1,137 @@
+(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/lux-bootstrapper/src/lux/lib/loader.clj b/lux-bootstrapper/src/lux/lib/loader.clj
new file mode 100644
index 000000000..97e6ee684
--- /dev/null
+++ b/lux-bootstrapper/src/lux/lib/loader.clj
@@ -0,0 +1,42 @@
+(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/lux-bootstrapper/src/lux/optimizer.clj b/lux-bootstrapper/src/lux/optimizer.clj
new file mode 100644
index 000000000..6e235e084
--- /dev/null
+++ b/lux-bootstrapper/src/lux/optimizer.clj
@@ -0,0 +1,1150 @@
+(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/lux-bootstrapper/src/lux/parser.clj b/lux-bootstrapper/src/lux/parser.clj
new file mode 100644
index 000000000..dd33129b8
--- /dev/null
+++ b/lux-bootstrapper/src/lux/parser.clj
@@ -0,0 +1,105 @@
+(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/lux-bootstrapper/src/lux/reader.clj b/lux-bootstrapper/src/lux/reader.clj
new file mode 100644
index 000000000..14914cc2e
--- /dev/null
+++ b/lux-bootstrapper/src/lux/reader.clj
@@ -0,0 +1,153 @@
+(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/lux-bootstrapper/src/lux/repl.clj b/lux-bootstrapper/src/lux/repl.clj
new file mode 100644
index 000000000..d980ac9ec
--- /dev/null
+++ b/lux-bootstrapper/src/lux/repl.clj
@@ -0,0 +1,87 @@
+(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/lux-bootstrapper/src/lux/type.clj b/lux-bootstrapper/src/lux/type.clj
new file mode 100644
index 000000000..8853224b5
--- /dev/null
+++ b/lux-bootstrapper/src/lux/type.clj
@@ -0,0 +1,973 @@
+(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/lux-bootstrapper/src/lux/type/host.clj b/lux-bootstrapper/src/lux/type/host.clj
new file mode 100644
index 000000000..36e969046
--- /dev/null
+++ b/lux-bootstrapper/src/lux/type/host.clj
@@ -0,0 +1,411 @@
+(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
+ )))