aboutsummaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
Diffstat (limited to 'src')
-rw-r--r--src/lux.clj38
-rw-r--r--src/lux/analyser.clj211
-rw-r--r--src/lux/analyser/base.clj131
-rw-r--r--src/lux/analyser/case.clj654
-rw-r--r--src/lux/analyser/env.clj74
-rw-r--r--src/lux/analyser/host.clj1379
-rw-r--r--src/lux/analyser/lambda.clj33
-rw-r--r--src/lux/analyser/lux.clj736
-rw-r--r--src/lux/analyser/meta.clj46
-rw-r--r--src/lux/analyser/module.clj403
-rw-r--r--src/lux/analyser/parser.clj469
-rw-r--r--src/lux/analyser/record.clj47
-rw-r--r--src/lux/base.clj1449
-rw-r--r--src/lux/compiler.clj268
-rw-r--r--src/lux/compiler/base.clj116
-rw-r--r--src/lux/compiler/cache.clj188
-rw-r--r--src/lux/compiler/cache/ann.clj159
-rw-r--r--src/lux/compiler/cache/type.clj164
-rw-r--r--src/lux/compiler/case.clj219
-rw-r--r--src/lux/compiler/host.clj2514
-rw-r--r--src/lux/compiler/io.clj36
-rw-r--r--src/lux/compiler/lambda.clj286
-rw-r--r--src/lux/compiler/lux.clj498
-rw-r--r--src/lux/compiler/module.clj28
-rw-r--r--src/lux/compiler/parallel.clj47
-rw-r--r--src/lux/host.clj432
-rw-r--r--src/lux/host/generics.clj205
-rw-r--r--src/lux/lexer.clj254
-rw-r--r--src/lux/lib/loader.clj54
-rw-r--r--src/lux/optimizer.clj1202
-rw-r--r--src/lux/parser.clj117
-rw-r--r--src/lux/reader.clj141
-rw-r--r--src/lux/repl.clj89
-rw-r--r--src/lux/type.clj972
-rw-r--r--src/lux/type/host.clj352
35 files changed, 0 insertions, 14011 deletions
diff --git a/src/lux.clj b/src/lux.clj
deleted file mode 100644
index e6fc3f4cc..000000000
--- a/src/lux.clj
+++ /dev/null
@@ -1,38 +0,0 @@
-;; Copyright (c) Eduardo Julian. All rights reserved.
-;; This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0.
-;; If a copy of the MPL was not distributed with this file,
-;; You can obtain one at http://mozilla.org/MPL/2.0/.
-
-(ns lux
- (:gen-class)
- (:require [lux.base :as & :refer [|let |do return fail return* fail* |case]]
- [lux.compiler.base :as &compiler-base]
- [lux.compiler :as &compiler]
- [lux.repl :as &repl]
- [clojure.string :as string]
- :reload-all)
- (:import (java.io File)))
-
-(def unit-separator (str (char 31)))
-
-(defn ^:private process-dirs
- "(-> Text (List Text))"
- [resources-dirs]
- (-> resources-dirs
- (string/replace unit-separator "\n")
- string/split-lines
- &/->list))
-
-(defn -main [& args]
- (|case (&/->list args)
- (&/$Cons "release" (&/$Cons program-module (&/$Cons resources-dirs (&/$Cons source-dirs (&/$Cons target-dir (&/$Nil))))))
- (time (&compiler/compile-program &/$Release program-module (process-dirs resources-dirs) (process-dirs source-dirs) target-dir))
-
- (&/$Cons "debug" (&/$Cons program-module (&/$Cons resources-dirs (&/$Cons source-dirs (&/$Cons target-dir (&/$Nil))))))
- (time (&compiler/compile-program &/$Debug program-module (process-dirs resources-dirs) (process-dirs source-dirs) target-dir))
-
- (&/$Cons "repl" (&/$Cons source-dirs (&/$Nil)))
- (&repl/repl (process-dirs source-dirs))
-
- _
- (println "Can't understand command.")))
diff --git a/src/lux/analyser.clj b/src/lux/analyser.clj
deleted file mode 100644
index 4133927e7..000000000
--- a/src/lux/analyser.clj
+++ /dev/null
@@ -1,211 +0,0 @@
-;; Copyright (c) Eduardo Julian. All rights reserved.
-;; This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0.
-;; If a copy of the MPL was not distributed with this file,
-;; You can obtain one at http://mozilla.org/MPL/2.0/.
-
-(ns lux.analyser
- (:require (clojure [template :refer [do-template]])
- clojure.core.match
- clojure.core.match.array
- (lux [base :as & :refer [|let |do return fail return* fail* |case]]
- [reader :as &reader]
- [parser :as &parser]
- [type :as &type]
- [host :as &host])
- (lux.analyser [base :as &&]
- [lux :as &&lux]
- [host :as &&host]
- [module :as &&module]
- [parser :as &&a-parser])))
-
-;; [Utils]
-(defn analyse-variant+ [analyse exo-type ident values]
- (|do [[module tag-name] (&/normalize ident)
- _ (&&module/ensure-can-see-tag module tag-name)
- idx (&&module/tag-index module tag-name)
- group (&&module/tag-group module tag-name)
- :let [is-last? (= idx (dec (&/|length group)))]]
- (if (= 1 (&/|length group))
- (|do [_cursor &/cursor]
- (analyse exo-type (&/T [_cursor (&/$TupleS values)])))
- (|case exo-type
- (&/$VarT id)
- (|do [? (&type/bound? id)]
- (if (or ? (&&/type-tag? module tag-name))
- (&&lux/analyse-variant analyse (&/$Right exo-type) idx is-last? values)
- (|do [wanted-type (&&module/tag-type module tag-name)
- wanted-type* (&type/instantiate-inference wanted-type)
- [[variant-type variant-cursor] variant-analysis] (&&/cap-1 (&&lux/analyse-variant analyse (&/$Left wanted-type*) idx is-last? values))
- _ (&type/check exo-type variant-type)]
- (return (&/|list (&&/|meta exo-type variant-cursor variant-analysis))))))
-
- _
- (&&lux/analyse-variant analyse (&/$Right exo-type) idx is-last? values)
- ))
- ))
-
-(defn ^:private just-analyse [analyser syntax]
- (&type/with-var
- (fn [?var]
- (|do [[[?output-type ?output-cursor] ?output-term] (&&/analyse-1 analyser ?var syntax)]
- (|case [?var ?output-type]
- [(&/$VarT ?e-id) (&/$VarT ?a-id)]
- (if (= ?e-id ?a-id)
- (|do [=output-type (&type/clean ?var ?output-type)]
- (return (&&/|meta =output-type ?output-cursor ?output-term)))
- (|do [=output-type (&type/clean ?var ?var)]
- (return (&&/|meta =output-type ?output-cursor ?output-term))))
-
- [_ _]
- (|do [=output-type (&type/clean ?var ?output-type)]
- (return (&&/|meta =output-type ?output-cursor ?output-term))))
- ))))
-
-(defn ^:private analyse-ast [optimize eval! compile-module compilers exo-type ?token]
- (|let [analyse (partial analyse-ast optimize eval! compile-module compilers)
- [cursor token] ?token
- [compile-def compile-program compile-class compile-interface] compilers]
- (|case token
- ;; Standard special forms
- (&/$BoolS ?value)
- (|do [_ (&type/check exo-type &type/Bool)]
- (return (&/|list (&&/|meta exo-type cursor (&&/$bool ?value)))))
-
- (&/$NatS ?value)
- (|do [_ (&type/check exo-type &type/Nat)]
- (return (&/|list (&&/|meta exo-type cursor (&&/$nat ?value)))))
-
- (&/$IntS ?value)
- (|do [_ (&type/check exo-type &type/Int)]
- (return (&/|list (&&/|meta exo-type cursor (&&/$int ?value)))))
-
- (&/$RealS ?value)
- (|do [_ (&type/check exo-type &type/Real)]
- (return (&/|list (&&/|meta exo-type cursor (&&/$real ?value)))))
-
- (&/$CharS ?value)
- (|do [_ (&type/check exo-type &type/Char)]
- (return (&/|list (&&/|meta exo-type cursor (&&/$char ?value)))))
-
- (&/$TextS ?value)
- (|do [_ (&type/check exo-type &type/Text)]
- (return (&/|list (&&/|meta exo-type cursor (&&/$text ?value)))))
-
- (&/$TupleS ?elems)
- (&/with-analysis-meta cursor exo-type
- (&&lux/analyse-tuple analyse (&/$Right exo-type) ?elems))
-
- (&/$RecordS ?elems)
- (&/with-analysis-meta cursor exo-type
- (&&lux/analyse-record analyse exo-type ?elems))
-
- (&/$TagS ?ident)
- (&/with-analysis-meta cursor exo-type
- (analyse-variant+ analyse exo-type ?ident &/$Nil))
-
- (&/$SymbolS ?ident)
- (&/with-analysis-meta cursor exo-type
- (&&lux/analyse-symbol analyse exo-type ?ident))
-
- (&/$FormS (&/$Cons [command-meta command] parameters))
- (|case command
- (&/$SymbolS _ command-name)
- (case command-name
- "_lux_case"
- (|let [(&/$Cons ?value ?branches) parameters]
- (&/with-analysis-meta cursor exo-type
- (&&lux/analyse-case analyse exo-type ?value ?branches)))
-
- "_lux_lambda"
- (|let [(&/$Cons [_ (&/$SymbolS "" ?self)]
- (&/$Cons [_ (&/$SymbolS "" ?arg)]
- (&/$Cons ?body
- (&/$Nil)))) parameters]
- (&/with-analysis-meta cursor exo-type
- (&&lux/analyse-lambda analyse exo-type ?self ?arg ?body)))
-
- "_lux_proc"
- (|let [(&/$Cons [_ (&/$TupleS (&/$Cons [_ (&/$TextS ?category)]
- (&/$Cons [_ (&/$TextS ?proc)]
- (&/$Nil))))]
- (&/$Cons [_ (&/$TupleS ?args)]
- (&/$Nil))) parameters]
- (&/with-analysis-meta cursor exo-type
- (&&host/analyse-host analyse exo-type compilers ?category ?proc ?args)))
-
- "_lux_:"
- (|let [(&/$Cons ?type
- (&/$Cons ?value
- (&/$Nil))) parameters]
- (&/with-analysis-meta cursor exo-type
- (&&lux/analyse-ann analyse eval! exo-type ?type ?value)))
-
- "_lux_:!"
- (|let [(&/$Cons ?type
- (&/$Cons ?value
- (&/$Nil))) parameters]
- (&/with-analysis-meta cursor exo-type
- (&&lux/analyse-coerce analyse eval! exo-type ?type ?value)))
-
- "_lux_def"
- (|let [(&/$Cons [_ (&/$SymbolS "" ?name)]
- (&/$Cons ?value
- (&/$Cons ?meta
- (&/$Nil))
- )) parameters]
- (&/with-cursor cursor
- (&&lux/analyse-def analyse optimize eval! compile-def ?name ?value ?meta)))
-
- "_lux_module"
- (|let [(&/$Cons ?meta (&/$Nil)) parameters]
- (&/with-cursor cursor
- (&&lux/analyse-module analyse optimize eval! compile-module ?meta)))
-
- "_lux_program"
- (|let [(&/$Cons [_ (&/$SymbolS "" ?args)]
- (&/$Cons ?body
- (&/$Nil))) parameters]
- (&/with-cursor cursor
- (&&lux/analyse-program analyse optimize compile-program ?args ?body)))
-
- ;; else
- (&/with-cursor cursor
- (|do [=fn (just-analyse analyse (&/T [command-meta command]))]
- (&&lux/analyse-apply analyse cursor exo-type =fn parameters))))
-
- (&/$NatS idx)
- (&/with-analysis-meta cursor exo-type
- (&&lux/analyse-variant analyse (&/$Right exo-type) idx nil parameters))
-
- (&/$TagS ?ident)
- (&/with-analysis-meta cursor exo-type
- (analyse-variant+ analyse exo-type ?ident parameters))
-
- _
- (&/with-cursor cursor
- (|do [=fn (just-analyse analyse (&/T [command-meta command]))]
- (&&lux/analyse-apply analyse cursor exo-type =fn parameters))))
-
- _
- (&/fail-with-loc (str "[Analyser Error] Unknown syntax: " (prn-str (&/show-ast (&/T [(&/T ["" -1 -1]) token])))))
- )))
-
-;; [Resources]
-(defn analyse [optimize eval! compile-module compilers]
- (|do [asts &parser/parse]
- (&/flat-map% (partial analyse-ast optimize eval! compile-module compilers &/$VoidT) asts)))
-
-(defn clean-output [?var analysis]
- (|do [:let [[[?output-type ?output-cursor] ?output-term] analysis]
- =output-type (&type/clean ?var ?output-type)]
- (return (&&/|meta =output-type ?output-cursor ?output-term))))
-
-(defn repl-analyse [optimize eval! compile-module compilers]
- (|do [asts &parser/parse]
- (&/flat-map% (fn [ast]
- (&type/with-var
- (fn [?var]
- (|do [=outputs (&/with-closure
- (analyse-ast optimize eval! compile-module compilers ?var ast))]
- (&/map% (partial clean-output ?var) =outputs)))))
- asts)))
diff --git a/src/lux/analyser/base.clj b/src/lux/analyser/base.clj
deleted file mode 100644
index 9bdcdeb11..000000000
--- a/src/lux/analyser/base.clj
+++ /dev/null
@@ -1,131 +0,0 @@
-;; Copyright (c) Eduardo Julian. All rights reserved.
-;; This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0.
-;; If a copy of the MPL was not distributed with this file,
-;; You can obtain one at http://mozilla.org/MPL/2.0/.
-
-(ns lux.analyser.base
- (:require clojure.core.match
- clojure.core.match.array
- (lux [base :as & :refer [defvariant |let |do return* return fail |case]]
- [type :as &type])))
-
-;; [Tags]
-(defvariant
- ("bool" 1)
- ("nat" 1)
- ("int" 1)
- ("frac" 1)
- ("real" 1)
- ("char" 1)
- ("text" 1)
- ("variant" 3)
- ("tuple" 1)
- ("apply" 2)
- ("case" 2)
- ("lambda" 4)
- ("ann" 2)
- ("var" 1)
- ("captured" 1)
- ("proc" 3)
- )
-
-;; [Exports]
-(defn expr-meta [analysis]
- (|let [[meta _] analysis]
- meta))
-
-(defn expr-type* [analysis]
- (|let [[[type _] _] analysis]
- type))
-
-(defn expr-term [analysis]
- (|let [[[type _] term] analysis]
- term))
-
-(defn with-type [new-type analysis]
- (|let [[[type cursor] adt] analysis]
- (&/T [(&/T [new-type cursor]) adt])))
-
-(defn clean-analysis [$var an]
- "(-> Type Analysis (Lux Analysis))"
- (|do [=an-type (&type/clean $var (expr-type* an))]
- (return (with-type =an-type an))))
-
-(def jvm-this "_jvm_this")
-
-(defn cap-1 [action]
- (|do [result action]
- (|case result
- (&/$Cons x (&/$Nil))
- (return x)
-
- _
- (fail "[Analyser Error] Can't expand to other than 1 element."))))
-
-(defn analyse-1 [analyse exo-type elem]
- (&/with-expected-type exo-type
- (cap-1 (analyse exo-type elem))))
-
-(defn analyse-1+ [analyse ?token]
- (&type/with-var
- (fn [$var]
- (|do [=expr (analyse-1 analyse $var ?token)]
- (clean-analysis $var =expr)))))
-
-(defn resolved-ident [ident]
- (|do [:let [[?module ?name] ident]
- module* (if (.equals "" ?module)
- &/get-module-name
- (return ?module))]
- (return (&/T [module* ?name]))))
-
-(let [tag-names #{"HostT" "VoidT" "UnitT" "SumT" "ProdT" "LambdaT" "BoundT" "VarT" "ExT" "UnivQ" "ExQ" "AppT" "NamedT"}]
- (defn type-tag? [module name]
- (and (= "lux" module)
- (contains? tag-names name))))
-
-(defn |meta [type cursor analysis]
- (&/T [(&/T [type cursor]) analysis]))
-
-(defn de-meta
- "(-> Analysis Analysis)"
- [analysis]
- (|let [[meta analysis-] analysis]
- (|case analysis-
- ($variant idx is-last? value)
- ($variant idx is-last? (de-meta value))
-
- ($tuple elems)
- ($tuple (&/|map de-meta elems))
-
- ($apply func args)
- ($apply (de-meta func)
- (&/|map de-meta args))
-
- ($case value branches)
- ($case (de-meta value)
- (&/|map (fn [branch]
- (|let [[_pattern _body] branch]
- (&/T [_pattern (de-meta _body)])))
- branches))
-
- ($lambda _register-offset scope captured body)
- ($lambda _register-offset scope
- (&/|map (fn [branch]
- (|let [[_name _captured] branch]
- (&/T [_name (de-meta _captured)])))
- captured)
- (de-meta body))
-
- ($ann value-expr type-expr)
- (de-meta value-expr)
-
- ($captured scope idx source)
- ($captured scope idx (de-meta source))
-
- ($proc proc-ident args special-args)
- ($proc proc-ident (&/|map de-meta args) special-args)
-
- _
- analysis-
- )))
diff --git a/src/lux/analyser/case.clj b/src/lux/analyser/case.clj
deleted file mode 100644
index 6841577a8..000000000
--- a/src/lux/analyser/case.clj
+++ /dev/null
@@ -1,654 +0,0 @@
-;; Copyright (c) Eduardo Julian. All rights reserved.
-;; This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0.
-;; If a copy of the MPL was not distributed with this file,
-;; You can obtain one at http://mozilla.org/MPL/2.0/.
-
-(ns lux.analyser.case
- (:require clojure.core.match
- clojure.core.match.array
- (lux [base :as & :refer [defvariant |do return fail |let |case]]
- [parser :as &parser]
- [type :as &type])
- (lux.analyser [base :as &&]
- [env :as &env]
- [module :as &module]
- [record :as &&record])))
-
-;; [Tags]
-(defvariant
- ("DefaultTotal" 1)
- ("BoolTotal" 2)
- ("NatTotal" 2)
- ("IntTotal" 2)
- ("FracTotal" 2)
- ("RealTotal" 2)
- ("CharTotal" 2)
- ("TextTotal" 2)
- ("TupleTotal" 2)
- ("VariantTotal" 2))
-
-(defvariant
- ("NoTestAC" 0)
- ("StoreTestAC" 1)
- ("BoolTestAC" 1)
- ("NatTestAC" 1)
- ("IntTestAC" 1)
- ("FracTestAC" 1)
- ("RealTestAC" 1)
- ("CharTestAC" 1)
- ("TextTestAC" 1)
- ("TupleTestAC" 1)
- ("VariantTestAC" 1))
-
-;; [Utils]
-(def ^:private unit-tuple
- (&/T [(&/T ["" -1 -1]) (&/$TupleS &/$Nil)]))
-
-(defn ^:private resolve-type [type]
- (|case type
- (&/$VarT ?id)
- (|do [type* (&/try-all% (&/|list (&type/deref ?id)
- (fail "##1##")))]
- (resolve-type type*))
-
- (&/$UnivQ _)
- (|do [$var &type/existential
- =type (&type/apply-type type $var)]
- (&type/actual-type =type))
-
- (&/$ExQ _ _)
- (|do [$var &type/existential
- =type (&type/apply-type type $var)]
- (&type/actual-type =type))
-
- _
- (&type/actual-type type)))
-
-(defn update-up-frame [frame]
- (|let [[_env _idx _var] frame]
- (&/T [_env (+ 2 _idx) _var])))
-
-(defn clean! [level ?tid bound-idx type]
- (|case type
- (&/$VarT ?id)
- (if (= ?tid ?id)
- (&/$BoundT (+ (* 2 level) bound-idx))
- type)
-
- (&/$HostT ?name ?params)
- (&/$HostT ?name (&/|map (partial clean! level ?tid bound-idx)
- ?params))
-
- (&/$LambdaT ?arg ?return)
- (&/$LambdaT (clean! level ?tid bound-idx ?arg)
- (clean! level ?tid bound-idx ?return))
-
- (&/$AppT ?lambda ?param)
- (&/$AppT (clean! level ?tid bound-idx ?lambda)
- (clean! level ?tid bound-idx ?param))
-
- (&/$ProdT ?left ?right)
- (&/$ProdT (clean! level ?tid bound-idx ?left)
- (clean! level ?tid bound-idx ?right))
-
- (&/$SumT ?left ?right)
- (&/$SumT (clean! level ?tid bound-idx ?left)
- (clean! level ?tid bound-idx ?right))
-
- (&/$UnivQ ?env ?body)
- (&/$UnivQ (&/|map (partial clean! level ?tid bound-idx) ?env)
- (clean! (inc level) ?tid bound-idx ?body))
-
- (&/$ExQ ?env ?body)
- (&/$ExQ (&/|map (partial clean! level ?tid bound-idx) ?env)
- (clean! (inc level) ?tid bound-idx ?body))
-
- _
- type
- ))
-
-(defn beta-reduce! [level env type]
- (|case type
- (&/$HostT ?name ?params)
- (&/$HostT ?name (&/|map (partial beta-reduce! level env) ?params))
-
- (&/$SumT ?left ?right)
- (&/$SumT (beta-reduce! level env ?left)
- (beta-reduce! level env ?right))
-
- (&/$ProdT ?left ?right)
- (&/$ProdT (beta-reduce! level env ?left)
- (beta-reduce! level env ?right))
-
- (&/$AppT ?type-fn ?type-arg)
- (&/$AppT (beta-reduce! level env ?type-fn)
- (beta-reduce! level env ?type-arg))
-
- (&/$UnivQ ?local-env ?local-def)
- (&/$UnivQ ?local-env (beta-reduce! (inc level) env ?local-def))
-
- (&/$ExQ ?local-env ?local-def)
- (&/$ExQ ?local-env (beta-reduce! (inc level) env ?local-def))
-
- (&/$LambdaT ?input ?output)
- (&/$LambdaT (beta-reduce! level env ?input)
- (beta-reduce! level env ?output))
-
- (&/$BoundT ?idx)
- (|case (&/|at (- ?idx (* 2 level)) env)
- (&/$Some bound)
- (beta-reduce! level env bound)
-
- _
- type)
-
- _
- type
- ))
-
-(defn apply-type! [type-fn param]
- (|case type-fn
- (&/$UnivQ local-env local-def)
- (return (beta-reduce! 0 (->> local-env
- (&/$Cons param)
- (&/$Cons type-fn))
- local-def))
-
- (&/$ExQ local-env local-def)
- (return (beta-reduce! 0 (->> local-env
- (&/$Cons param)
- (&/$Cons type-fn))
- local-def))
-
- (&/$AppT F A)
- (|do [type-fn* (apply-type! F A)]
- (apply-type! type-fn* param))
-
- (&/$NamedT ?name ?type)
- (apply-type! ?type param)
-
- (&/$ExT id)
- (return (&/$AppT type-fn param))
-
- (&/$VarT id)
- (|do [=type-fun (deref id)]
- (apply-type! =type-fun param))
-
- _
- (fail (str "[Type System] Not a type function:\n" (&type/show-type type-fn) "\n"))))
-
-(defn adjust-type* [up type]
- "(-> (List (, (Maybe (List Type)) Int Type)) Type (Lux Type))"
- (|case type
- (&/$UnivQ _aenv _abody)
- (&type/with-var
- (fn [$var]
- (|do [=type (apply-type! type $var)
- ==type (adjust-type* (&/$Cons (&/T [_aenv 1 $var]) (&/|map update-up-frame up)) =type)]
- (&type/clean $var ==type))))
-
- (&/$ExQ _aenv _abody)
- (|do [$var &type/existential
- =type (apply-type! type $var)]
- (adjust-type* up =type))
-
- (&/$ProdT ?left ?right)
- (|do [:let [=type (&/fold (fn [_abody ena]
- (|let [[_aenv _aidx (&/$VarT _avar)] ena]
- (clean! 0 _avar _aidx _abody)))
- type
- up)]
- :let [distributor (fn [v]
- (&/fold (fn [_abody ena]
- (|let [[_aenv _aidx _avar] ena]
- (&/$UnivQ _aenv _abody)))
- v
- up))
- adjusted-type (&type/Tuple$ (&/|map distributor (&type/flatten-prod =type)))]]
- (return adjusted-type))
-
- (&/$SumT ?left ?right)
- (|do [:let [=type (&/fold (fn [_abody ena]
- (|let [[_aenv _aidx (&/$VarT _avar)] ena]
- (clean! 0 _avar _aidx _abody)))
- type
- up)]
- :let [distributor (fn [v]
- (&/fold (fn [_abody ena]
- (|let [[_aenv _aidx _avar] ena]
- (&/$UnivQ _aenv _abody)))
- v
- up))
- adjusted-type (&type/Variant$ (&/|map distributor (&type/flatten-sum =type)))]]
- (return adjusted-type))
-
- (&/$AppT ?tfun ?targ)
- (|do [=type (apply-type! ?tfun ?targ)]
- (adjust-type* up =type))
-
- (&/$VarT ?id)
- (|do [type* (&/try-all% (&/|list (&type/deref ?id)
- (fail (str "##2##: " ?id))))]
- (adjust-type* up type*))
-
- (&/$NamedT ?name ?type)
- (adjust-type* up ?type)
-
- (&/$UnitT)
- (return type)
-
- _
- (fail (str "[Pattern-matching Error] Can't adjust type: " (&type/show-type type)))
- ))
-
-(defn adjust-type [type]
- "(-> Type (Lux Type))"
- (adjust-type* &/$Nil type))
-
-(defn ^:private analyse-pattern [var?? value-type pattern kont]
- (|let [[meta pattern*] pattern]
- (|case pattern*
- (&/$SymbolS "" name)
- (|case var??
- (&/$Some var-analysis)
- (|do [=kont (&env/with-alias name var-analysis
- kont)]
- (return (&/T [$NoTestAC =kont])))
-
- _
- (|do [=kont (&env/with-local name value-type
- kont)
- idx &env/next-local-idx]
- (return (&/T [($StoreTestAC idx) =kont]))))
-
- (&/$SymbolS ident)
- (fail (str "[Pattern-matching Error] Symbols must be unqualified: " (&/ident->text ident)))
-
- (&/$BoolS ?value)
- (|do [_ (&type/check value-type &type/Bool)
- =kont kont]
- (return (&/T [($BoolTestAC ?value) =kont])))
-
- (&/$NatS ?value)
- (|do [_ (&type/check value-type &type/Nat)
- =kont kont]
- (return (&/T [($NatTestAC ?value) =kont])))
-
- (&/$IntS ?value)
- (|do [_ (&type/check value-type &type/Int)
- =kont kont]
- (return (&/T [($IntTestAC ?value) =kont])))
-
- (&/$FracS ?value)
- (|do [_ (&type/check value-type &type/Frac)
- =kont kont]
- (return (&/T [($FracTestAC ?value) =kont])))
-
- (&/$RealS ?value)
- (|do [_ (&type/check value-type &type/Real)
- =kont kont]
- (return (&/T [($RealTestAC ?value) =kont])))
-
- (&/$CharS ?value)
- (|do [_ (&type/check value-type &type/Char)
- =kont kont]
- (return (&/T [($CharTestAC ?value) =kont])))
-
- (&/$TextS ?value)
- (|do [_ (&type/check value-type &type/Text)
- =kont kont]
- (return (&/T [($TextTestAC ?value) =kont])))
-
- (&/$TupleS ?members)
- (|case ?members
- (&/$Nil)
- (|do [_ (&type/check value-type &/$UnitT)
- =kont kont]
- (return (&/T [($TupleTestAC (&/|list)) =kont])))
-
- (&/$Cons ?member (&/$Nil))
- (analyse-pattern var?? value-type ?member kont)
-
- _
- (|do [must-infer? (&type/unknown? value-type)
- value-type* (if must-infer?
- (|do [member-types (&/map% (fn [_] &type/create-var+) (&/|range (&/|length ?members)))]
- (return (&type/fold-prod member-types)))
- (adjust-type value-type))]
- (|case value-type*
- (&/$ProdT _)
- (|let [num-elems (&/|length ?members)
- [_shorter _tuple-types] (&type/tuple-types-for (&/|length ?members) value-type*)]
- (if (= num-elems _shorter)
- (|do [[=tests =kont] (&/fold (fn [kont* vm]
- (|let [[v m] vm]
- (|do [[=test [=tests =kont]] (analyse-pattern &/$None v m kont*)]
- (return (&/T [(&/$Cons =test =tests) =kont])))))
- (|do [=kont kont]
- (return (&/T [&/$Nil =kont])))
- (&/|reverse (&/zip2 _tuple-types ?members)))]
- (return (&/T [($TupleTestAC =tests) =kont])))
- (fail (str "[Pattern-matching Error] Pattern-matching mismatch. Require tuple[" (&/|length (&type/flatten-prod value-type*)) "]. Given tuple [" (&/|length ?members) "]"
- " -- " (&/show-ast pattern)
- " " (&type/show-type value-type*) " " (&type/show-type value-type)))))
-
- _
- (fail (str "[Pattern-matching Error] Tuples require tuple-types: " (&type/show-type value-type))))))
-
- (&/$RecordS pairs)
- (|do [[rec-members rec-type] (&&record/order-record pairs)
- must-infer? (&type/unknown? value-type)
- rec-type* (if must-infer?
- (&type/instantiate-inference rec-type)
- (return value-type))
- _ (&type/check value-type rec-type*)]
- (analyse-pattern &/$None rec-type* (&/T [meta (&/$TupleS rec-members)]) kont))
-
- (&/$TagS ?ident)
- (|do [[=module =name] (&&/resolved-ident ?ident)
- must-infer? (&type/unknown? value-type)
- variant-type (if must-infer?
- (|do [variant-type (&module/tag-type =module =name)
- variant-type* (&type/instantiate-inference variant-type)
- _ (&type/check value-type variant-type*)]
- (return variant-type*))
- (return value-type))
- value-type* (adjust-type variant-type)
- idx (&module/tag-index =module =name)
- group (&module/tag-group =module =name)
- case-type (&type/sum-at idx value-type*)
- [=test =kont] (analyse-pattern &/$None case-type unit-tuple kont)]
- (return (&/T [($VariantTestAC (&/T [idx (&/|length group) =test])) =kont])))
-
- (&/$FormS (&/$Cons [_ (&/$NatS idx)] ?values))
- (|do [value-type* (adjust-type value-type)
- case-type (&type/sum-at idx value-type*)
- [=test =kont] (case (int (&/|length ?values))
- 0 (analyse-pattern &/$None case-type unit-tuple kont)
- 1 (analyse-pattern &/$None case-type (&/|head ?values) kont)
- ;; 1+
- (analyse-pattern &/$None case-type (&/T [(&/T ["" -1 -1]) (&/$TupleS ?values)]) kont))]
- (return (&/T [($VariantTestAC (&/T [idx (&/|length (&type/flatten-sum value-type*)) =test])) =kont])))
-
- (&/$FormS (&/$Cons [_ (&/$TagS ?ident)] ?values))
- (|do [[=module =name] (&&/resolved-ident ?ident)
- must-infer? (&type/unknown? value-type)
- variant-type (if must-infer?
- (|do [variant-type (&module/tag-type =module =name)
- variant-type* (&type/instantiate-inference variant-type)
- _ (&type/check value-type variant-type*)]
- (return variant-type*))
- (return value-type))
- value-type* (adjust-type variant-type)
- idx (&module/tag-index =module =name)
- group (&module/tag-group =module =name)
- case-type (&type/sum-at idx value-type*)
- [=test =kont] (case (int (&/|length ?values))
- 0 (analyse-pattern &/$None case-type unit-tuple kont)
- 1 (analyse-pattern &/$None case-type (&/|head ?values) kont)
- ;; 1+
- (analyse-pattern &/$None case-type (&/T [(&/T ["" -1 -1]) (&/$TupleS ?values)]) kont))]
- (return (&/T [($VariantTestAC (&/T [idx (&/|length group) =test])) =kont])))
-
- _
- (fail (str "[Pattern-matching Error] Unrecognized pattern syntax: " (&/show-ast pattern)))
- )))
-
-(defn ^:private analyse-branch [analyse exo-type var?? value-type pattern body patterns]
- (|do [pattern+body (analyse-pattern var?? value-type pattern
- (&&/analyse-1 analyse exo-type body))]
- (return (&/$Cons pattern+body patterns))))
-
-(defn ^:private merge-total [struct test+body]
- (|let [[test ?body] test+body]
- (|case [struct test]
- [($DefaultTotal total?) ($NoTestAC)]
- (return ($DefaultTotal true))
-
- [($BoolTotal total? ?values) ($NoTestAC)]
- (return ($BoolTotal true ?values))
-
- [($NatTotal total? ?values) ($NoTestAC)]
- (return ($NatTotal true ?values))
-
- [($IntTotal total? ?values) ($NoTestAC)]
- (return ($IntTotal true ?values))
-
- [($FracTotal total? ?values) ($NoTestAC)]
- (return ($FracTotal true ?values))
-
- [($RealTotal total? ?values) ($NoTestAC)]
- (return ($RealTotal true ?values))
-
- [($CharTotal total? ?values) ($NoTestAC)]
- (return ($CharTotal true ?values))
-
- [($TextTotal total? ?values) ($NoTestAC)]
- (return ($TextTotal true ?values))
-
- [($TupleTotal total? ?values) ($NoTestAC)]
- (return ($TupleTotal true ?values))
-
- [($VariantTotal total? ?values) ($NoTestAC)]
- (return ($VariantTotal true ?values))
-
- [($DefaultTotal total?) ($StoreTestAC ?idx)]
- (return ($DefaultTotal true))
-
- [($BoolTotal total? ?values) ($StoreTestAC ?idx)]
- (return ($BoolTotal true ?values))
-
- [($NatTotal total? ?values) ($StoreTestAC ?idx)]
- (return ($NatTotal true ?values))
-
- [($IntTotal total? ?values) ($StoreTestAC ?idx)]
- (return ($IntTotal true ?values))
-
- [($FracTotal total? ?values) ($StoreTestAC ?idx)]
- (return ($FracTotal true ?values))
-
- [($RealTotal total? ?values) ($StoreTestAC ?idx)]
- (return ($RealTotal true ?values))
-
- [($CharTotal total? ?values) ($StoreTestAC ?idx)]
- (return ($CharTotal true ?values))
-
- [($TextTotal total? ?values) ($StoreTestAC ?idx)]
- (return ($TextTotal true ?values))
-
- [($TupleTotal total? ?values) ($StoreTestAC ?idx)]
- (return ($TupleTotal true ?values))
-
- [($VariantTotal total? ?values) ($StoreTestAC ?idx)]
- (return ($VariantTotal true ?values))
-
- [($DefaultTotal total?) ($BoolTestAC ?value)]
- (return ($BoolTotal total? (&/|list ?value)))
-
- [($BoolTotal total? ?values) ($BoolTestAC ?value)]
- (return ($BoolTotal total? (&/$Cons ?value ?values)))
-
- [($DefaultTotal total?) ($NatTestAC ?value)]
- (return ($NatTotal total? (&/|list ?value)))
-
- [($NatTotal total? ?values) ($NatTestAC ?value)]
- (return ($NatTotal total? (&/$Cons ?value ?values)))
-
- [($DefaultTotal total?) ($IntTestAC ?value)]
- (return ($IntTotal total? (&/|list ?value)))
-
- [($IntTotal total? ?values) ($IntTestAC ?value)]
- (return ($IntTotal total? (&/$Cons ?value ?values)))
-
- [($DefaultTotal total?) ($FracTestAC ?value)]
- (return ($FracTotal total? (&/|list ?value)))
-
- [($FracTotal total? ?values) ($FracTestAC ?value)]
- (return ($FracTotal total? (&/$Cons ?value ?values)))
-
- [($DefaultTotal total?) ($RealTestAC ?value)]
- (return ($RealTotal total? (&/|list ?value)))
-
- [($RealTotal total? ?values) ($RealTestAC ?value)]
- (return ($RealTotal total? (&/$Cons ?value ?values)))
-
- [($DefaultTotal total?) ($CharTestAC ?value)]
- (return ($CharTotal total? (&/|list ?value)))
-
- [($CharTotal total? ?values) ($CharTestAC ?value)]
- (return ($CharTotal total? (&/$Cons ?value ?values)))
-
- [($DefaultTotal total?) ($TextTestAC ?value)]
- (return ($TextTotal total? (&/|list ?value)))
-
- [($TextTotal total? ?values) ($TextTestAC ?value)]
- (return ($TextTotal total? (&/$Cons ?value ?values)))
-
- [($DefaultTotal total?) ($TupleTestAC ?tests)]
- (|do [structs (&/map% (fn [t]
- (merge-total ($DefaultTotal total?) (&/T [t ?body])))
- ?tests)]
- (return ($TupleTotal total? structs)))
-
- [($TupleTotal total? ?values) ($TupleTestAC ?tests)]
- (if (.equals ^Object (&/|length ?values) (&/|length ?tests))
- (|do [structs (&/map2% (fn [v t]
- (merge-total v (&/T [t ?body])))
- ?values ?tests)]
- (return ($TupleTotal total? structs)))
- (fail "[Pattern-matching Error] Inconsistent tuple-size."))
-
- [($DefaultTotal total?) ($VariantTestAC ?tag ?count ?test)]
- (|do [sub-struct (merge-total ($DefaultTotal total?)
- (&/T [?test ?body]))
- structs (|case (&/|list-put ?tag sub-struct (&/|repeat ?count ($DefaultTotal total?)))
- (&/$Some list)
- (return list)
-
- (&/$None)
- (fail "[Pattern-matching Error] YOLO"))]
- (return ($VariantTotal total? structs)))
-
- [($VariantTotal total? ?branches) ($VariantTestAC ?tag ?count ?test)]
- (|do [sub-struct (merge-total (|case (&/|at ?tag ?branches)
- (&/$Some sub)
- sub
-
- (&/$None)
- ($DefaultTotal total?))
- (&/T [?test ?body]))
- structs (|case (&/|list-put ?tag sub-struct ?branches)
- (&/$Some list)
- (return list)
-
- (&/$None)
- (fail "[Pattern-matching Error] YOLO"))]
- (return ($VariantTotal total? structs)))
- )))
-
-(defn check-totality+ [check-totality]
- (fn [?token]
- (&type/with-var
- (fn [$var]
- (|do [=output (check-totality $var ?token)
- ?type (&type/deref+ $var)
- =type (&type/clean $var ?type)]
- (return (&/T [=output =type])))))))
-
-(defn ^:private check-totality [value-type struct]
- (|case struct
- ($DefaultTotal ?total)
- (return ?total)
-
- ($BoolTotal ?total ?values)
- (|do [_ (&type/check value-type &type/Bool)]
- (return (or ?total
- (= #{true false} (set (&/->seq ?values))))))
-
- ($NatTotal ?total _)
- (|do [_ (&type/check value-type &type/Nat)]
- (return ?total))
-
- ($IntTotal ?total _)
- (|do [_ (&type/check value-type &type/Int)]
- (return ?total))
-
- ($FracTotal ?total _)
- (|do [_ (&type/check value-type &type/Frac)]
- (return ?total))
-
- ($RealTotal ?total _)
- (|do [_ (&type/check value-type &type/Real)]
- (return ?total))
-
- ($CharTotal ?total _)
- (|do [_ (&type/check value-type &type/Char)]
- (return ?total))
-
- ($TextTotal ?total _)
- (|do [_ (&type/check value-type &type/Text)]
- (return ?total))
-
- ($TupleTotal ?total ?structs)
- (|case ?structs
- (&/$Nil)
- (|do [value-type* (resolve-type value-type)]
- (|case value-type*
- (&/$UnitT)
- (return true)
-
- _
- (fail "[Pattern-maching Error] Unit is not total.")))
-
- _
- (|do [unknown? (&type/unknown? value-type)]
- (if unknown?
- (|do [=structs (&/map% (check-totality+ check-totality) ?structs)
- _ (&type/check value-type (|case (->> (&/|map &/|second =structs) (&/|reverse))
- (&/$Cons last prevs)
- (&/fold (fn [right left] (&/$ProdT left right))
- last prevs)))]
- (return (or ?total
- (&/fold #(and %1 %2) true (&/|map &/|first =structs)))))
- (if ?total
- (return true)
- (|do [value-type* (resolve-type value-type)]
- (|case value-type*
- (&/$ProdT _)
- (|let [num-elems (&/|length ?structs)
- [_shorter _tuple-types] (&type/tuple-types-for (&/|length ?structs) value-type*)]
- (if (= num-elems _shorter)
- (|do [totals (&/map2% check-totality _tuple-types ?structs)]
- (return (&/fold #(and %1 %2) true totals)))
- (fail (str "[Pattern-maching Error] Tuple-mismatch. Require tuple[" (&/|length (&type/flatten-prod value-type*)) "]. Given tuple [" (&/|length ?structs) "]"))))
-
- _
- (fail (str "[Pattern-maching Error] Tuple is not total." " - " (&type/show-type value-type*)))))))))
-
- ($VariantTotal ?total ?structs)
- (if ?total
- (return true)
- (|do [value-type* (resolve-type value-type)]
- (|case value-type*
- (&/$SumT _)
- (|do [totals (&/map2% check-totality
- (&type/flatten-sum value-type*)
- ?structs)]
- (return (&/fold #(and %1 %2) true totals)))
-
- _
- (fail "[Pattern-maching Error] Variant is not total."))))
- ))
-
-;; [Exports]
-(defn analyse-branches [analyse exo-type var?? value-type branches]
- (|do [patterns (&/fold% (fn [patterns branch]
- (|let [[pattern body] branch]
- (analyse-branch analyse exo-type var?? value-type pattern body patterns)))
- &/$Nil
- branches)
- struct (&/fold% merge-total ($DefaultTotal false) patterns)
- ? (check-totality value-type struct)]
- (if ?
- (return patterns)
- (fail "[Pattern-maching Error] Pattern-matching is non-total."))))
diff --git a/src/lux/analyser/env.clj b/src/lux/analyser/env.clj
deleted file mode 100644
index 75e066e34..000000000
--- a/src/lux/analyser/env.clj
+++ /dev/null
@@ -1,74 +0,0 @@
-;; Copyright (c) Eduardo Julian. All rights reserved.
-;; This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0.
-;; If a copy of the MPL was not distributed with this file,
-;; You can obtain one at http://mozilla.org/MPL/2.0/.
-
-(ns lux.analyser.env
- (:require clojure.core.match
- clojure.core.match.array
- (lux [base :as & :refer [|do return return* fail fail* |case]])
- [lux.analyser.base :as &&]))
-
-;; [Exports]
-(def next-local-idx
- (fn [state]
- (return* state (->> state (&/get$ &/$scopes) &/|head (&/get$ &/$locals) (&/get$ &/$counter)))))
-
-(defn with-local [name type body]
- (fn [state]
- (let [old-mappings (->> state (&/get$ &/$scopes) &/|head (&/get$ &/$locals) (&/get$ &/$mappings))
- =return (body (&/update$ &/$scopes
- (fn [stack]
- (let [var-analysis (&&/|meta type &/empty-cursor (&&/$var (&/$Local (->> (&/|head stack) (&/get$ &/$locals) (&/get$ &/$counter)))))]
- (&/$Cons (&/update$ &/$locals #(->> %
- (&/update$ &/$counter inc)
- (&/update$ &/$mappings (fn [m] (&/|put name var-analysis m))))
- (&/|head stack))
- (&/|tail stack))))
- state))]
- (|case =return
- (&/$Right ?state ?value)
- (return* (&/update$ &/$scopes (fn [stack*]
- (&/$Cons (&/update$ &/$locals #(->> %
- (&/update$ &/$counter dec)
- (&/set$ &/$mappings old-mappings))
- (&/|head stack*))
- (&/|tail stack*)))
- ?state)
- ?value)
-
- _
- =return))))
-
-(defn with-alias [name var-analysis body]
- (fn [state]
- (let [old-mappings (->> state (&/get$ &/$scopes) &/|head (&/get$ &/$locals) (&/get$ &/$mappings))
- =return (body (&/update$ &/$scopes
- (fn [stack]
- (&/$Cons (&/update$ &/$locals #(->> %
- (&/update$ &/$mappings (fn [m] (&/|put name var-analysis m))))
- (&/|head stack))
- (&/|tail stack)))
- state))]
- (|case =return
- (&/$Right ?state ?value)
- (return* (&/update$ &/$scopes (fn [stack*]
- (&/$Cons (&/update$ &/$locals #(->> %
- (&/set$ &/$mappings old-mappings))
- (&/|head stack*))
- (&/|tail stack*)))
- ?state)
- ?value)
-
- _
- =return))))
-
-(def captured-vars
- (fn [state]
- (|case (&/get$ &/$scopes state)
- (&/$Nil)
- (fail* "[Analyser Error] Can't obtain captured vars without environments.")
-
- (&/$Cons env _)
- (return* state (->> env (&/get$ &/$closure) (&/get$ &/$mappings))))
- ))
diff --git a/src/lux/analyser/host.clj b/src/lux/analyser/host.clj
deleted file mode 100644
index 209e36d0e..000000000
--- a/src/lux/analyser/host.clj
+++ /dev/null
@@ -1,1379 +0,0 @@
-;; Copyright (c) Eduardo Julian. All rights reserved.
-;; This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0.
-;; If a copy of the MPL was not distributed with this file,
-;; You can obtain one at http://mozilla.org/MPL/2.0/.
-
-(ns lux.analyser.host
- (:require (clojure [template :refer [do-template]]
- [string :as string])
- clojure.core.match
- clojure.core.match.array
- (lux [base :as & :refer [|let |do return* return |case assert!]]
- [type :as &type]
- [host :as &host]
- [lexer :as &lexer]
- [parser :as &parser]
- [reader :as &reader])
- [lux.type.host :as &host-type]
- [lux.host.generics :as &host-generics]
- (lux.analyser [base :as &&]
- [lambda :as &&lambda]
- [env :as &&env]
- [parser :as &&a-parser])
- [lux.compiler.base :as &c!base])
- (:import (java.lang.reflect Type TypeVariable)))
-
-;; [Utils]
-(defn ^:private ensure-catching [exceptions*]
- "(-> (List Text) (Lux Null))"
- (|do [class-loader &/loader]
- (fn [state]
- (|let [exceptions (&/|map #(Class/forName % true class-loader) exceptions*)
- catching (->> state
- (&/get$ &/$host)
- (&/get$ &/$catching)
- (&/|map #(Class/forName % true class-loader)))]
- (if-let [missing-ex (&/fold (fn [prev ^Class now]
- (or prev
- (cond (or (.isAssignableFrom java.lang.RuntimeException now)
- (.isAssignableFrom java.lang.Error now))
- nil
-
- (&/fold (fn [found? ^Class ex-catch]
- (or found?
- (.isAssignableFrom ex-catch now)))
- false
- catching)
- nil
-
- :else
- now)))
- nil
- exceptions)]
- ((&/fail-with-loc (str "[Analyser Error] Unhandled exception: " missing-ex))
- state)
- (&/return* state nil)))
- )))
-
-(defn ^:private with-catches [catches body]
- "(All [a] (-> (List Text) (Lux a) (Lux a)))"
- (fn [state]
- (let [old-catches (->> state (&/get$ &/$host) (&/get$ &/$catching))
- state* (->> state (&/update$ &/$host #(&/update$ &/$catching (partial &/|++ catches) %)))]
- (|case (&/run-state body state*)
- (&/$Left msg)
- (&/$Left msg)
-
- (&/$Right state** output)
- (&/$Right (&/T [(->> state** (&/update$ &/$host #(&/set$ &/$catching old-catches %)))
- output]))))
- ))
-
-(defn ^:private ensure-object [type]
- "(-> Type (Lux (, Text (List Type))))"
- (|case type
- (&/$HostT payload)
- (return payload)
-
- (&/$VarT id)
- (return (&/T ["java.lang.Object" (&/|list)]))
-
- (&/$ExT id)
- (return (&/T ["java.lang.Object" (&/|list)]))
-
- (&/$NamedT _ type*)
- (ensure-object type*)
-
- (&/$UnivQ _ type*)
- (ensure-object type*)
-
- (&/$ExQ _ type*)
- (ensure-object type*)
-
- (&/$AppT F A)
- (|do [type* (&type/apply-type F A)]
- (ensure-object type*))
-
- _
- (&/fail-with-loc (str "[Analyser Error] Expecting object: " (&type/show-type type)))))
-
-(defn ^:private as-object [type]
- "(-> Type Type)"
- (|case type
- (&/$HostT class params)
- (&/$HostT (&host-type/as-obj class) params)
-
- _
- type))
-
-(defn ^:private as-otype [tname]
- (case tname
- "boolean" "java.lang.Boolean"
- "byte" "java.lang.Byte"
- "short" "java.lang.Short"
- "int" "java.lang.Integer"
- "long" "java.lang.Long"
- "float" "java.lang.Float"
- "double" "java.lang.Double"
- "char" "java.lang.Character"
- ;; else
- tname
- ))
-
-(defn ^:private as-otype+ [type]
- "(-> Type Type)"
- (|case type
- (&/$HostT name params)
- (&/$HostT (as-otype name) params)
-
- _
- type))
-
-(defn ^:private clean-gtype-var [idx gtype-var]
- (|let [(&/$VarT id) gtype-var]
- (|do [? (&type/bound? id)]
- (if ?
- (|do [real-type (&type/deref id)]
- (return (&/T [idx real-type])))
- (return (&/T [(+ 2 idx) (&/$BoundT idx)]))))))
-
-(defn ^:private clean-gtype-vars [gtype-vars]
- (|do [[_ clean-types] (&/fold% (fn [idx+types gtype-var]
- (|do [:let [[idx types] idx+types]
- [idx* real-type] (clean-gtype-var idx gtype-var)]
- (return (&/T [idx* (&/$Cons real-type types)]))))
- (&/T [1 &/$Nil])
- gtype-vars)]
- (return clean-types)))
-
-(defn ^:private make-gtype [class-name type-args]
- "(-> Text (List Type) Type)"
- (&/fold (fn [base-type type-arg]
- (|case type-arg
- (&/$BoundT _)
- (&/$UnivQ &type/empty-env base-type)
-
- _
- base-type))
- (&/$HostT class-name type-args)
- type-args))
-
-;; [Resources]
-(defn ^:private analyse-field-access-helper [obj-type gvars gtype]
- "(-> Type (List (^ java.lang.reflect.Type)) (^ java.lang.reflect.Type) (Lux Type))"
- (|case obj-type
- (&/$HostT class targs)
- (if (= (&/|length targs) (&/|length gvars))
- (|let [gtype-env (&/fold2 (fn [m ^TypeVariable g t] (&/$Cons (&/T [(.getName g) t]) m))
- (&/|table)
- gvars
- targs)]
- (&host-type/instance-param &type/existential gtype-env gtype))
- (&/fail-with-loc (str "[Type Error] Mismatched number of type-parameters: " (&/|length gvars) " - " (&type/show-type obj-type))))
-
- _
- (&/fail-with-loc (str "[Type Error] Type is not an object type: " (&type/show-type obj-type)))))
-
-(defn generic-class->simple-class [gclass]
- "(-> GenericClass Text)"
- (|case gclass
- (&/$GenericTypeVar var-name)
- "java.lang.Object"
-
- (&/$GenericWildcard _)
- "java.lang.Object"
-
- (&/$GenericClass name params)
- name
-
- (&/$GenericArray param)
- (|case param
- (&/$GenericArray _)
- (str "[" (generic-class->simple-class param))
-
- (&/$GenericClass "boolean" _)
- "[Z"
-
- (&/$GenericClass "byte" _)
- "[B"
-
- (&/$GenericClass "short" _)
- "[S"
-
- (&/$GenericClass "int" _)
- "[I"
-
- (&/$GenericClass "long" _)
- "[J"
-
- (&/$GenericClass "float" _)
- "[F"
-
- (&/$GenericClass "double" _)
- "[D"
-
- (&/$GenericClass "char" _)
- "[C"
-
- (&/$GenericClass name params)
- (str "[L" name ";")
-
- (&/$GenericTypeVar var-name)
- "[Ljava.lang.Object;"
-
- (&/$GenericWildcard _)
- "[Ljava.lang.Object;")
- ))
-
-(defn generic-class->type [env gclass]
- "(-> (List (, TypeVar Type)) GenericClass (Lux Type))"
- (|case gclass
- (&/$GenericTypeVar var-name)
- (if-let [ex (&/|get var-name env)]
- (return ex)
- (&/fail-with-loc (str "[Analysis Error] Unknown type var: " var-name)))
-
- (&/$GenericClass name params)
- (case name
- "boolean" (return (&/$HostT "java.lang.Boolean" &/$Nil))
- "byte" (return (&/$HostT "java.lang.Byte" &/$Nil))
- "short" (return (&/$HostT "java.lang.Short" &/$Nil))
- "int" (return (&/$HostT "java.lang.Integer" &/$Nil))
- "long" (return (&/$HostT "java.lang.Long" &/$Nil))
- "float" (return (&/$HostT "java.lang.Float" &/$Nil))
- "double" (return (&/$HostT "java.lang.Double" &/$Nil))
- "char" (return (&/$HostT "java.lang.Character" &/$Nil))
- "void" (return &/$UnitT)
- ;; else
- (|do [=params (&/map% (partial generic-class->type env) params)]
- (return (&/$HostT name =params))))
-
- (&/$GenericArray param)
- (|do [=param (generic-class->type env param)]
- (return (&/$HostT &host-type/array-data-tag (&/|list =param))))
-
- (&/$GenericWildcard _)
- (return (&/$ExQ &/$Nil (&/$BoundT 1)))
- ))
-
-(defn gen-super-env [class-env supers class-decl]
- "(-> (List (, TypeVar Type)) (List SuperClassDecl) ClassDecl (Lux (List (, Text Type))))"
- (|let [[class-name class-vars] class-decl]
- (|case (&/|some (fn [super]
- (|let [[super-name super-params] super]
- (if (= class-name super-name)
- (&/$Some (&/zip2 (&/|map &/|first class-vars) super-params))
- &/$None)))
- supers)
- (&/$None)
- (&/fail-with-loc (str "[Analyser Error] Unrecognized super-class: " class-name))
-
- (&/$Some vars+gtypes)
- (&/map% (fn [var+gtype]
- (|do [:let [[var gtype] var+gtype]
- =gtype (generic-class->type class-env gtype)]
- (return (&/T [var =gtype]))))
- vars+gtypes)
- )))
-
-(defn ^:private make-type-env [type-params]
- "(-> (List TypeParam) (Lux (List [Text Type])))"
- (&/map% (fn [gvar]
- (|do [:let [[gvar-name _] gvar]
- ex &type/existential]
- (return (&/T [gvar-name ex]))))
- type-params))
-
-(defn ^:private double-register-gclass? [gclass]
- (|case gclass
- (&/$GenericClass name _)
- (|case name
- "long" true
- "double" true
- _ false)
-
- _
- false))
-
-(defn ^:private method-input-folder [full-env]
- (fn [body* input*]
- (|do [:let [[iname itype*] input*]
- itype (generic-class->type full-env itype*)]
- (if (double-register-gclass? itype*)
- (&&env/with-local iname itype
- (&&env/with-local "" &/$VoidT
- body*))
- (&&env/with-local iname itype
- body*)))))
-
-(defn ^:private analyse-method [analyse class-decl class-env all-supers method]
- "(-> Analyser ClassDecl (List (, TypeVar Type)) (List SuperClassDecl) MethodSyntax (Lux MethodAnalysis))"
- (|let [[?cname ?cparams] class-decl
- class-type (&/$HostT ?cname (&/|map &/|second class-env))]
- (|case method
- (&/$ConstructorMethodSyntax =privacy-modifier ?strict ?anns ?gvars ?exceptions ?inputs ?ctor-args ?body)
- (|do [method-env (make-type-env ?gvars)
- :let [full-env (&/|++ class-env method-env)]
- :let [output-type &/$UnitT]
- =ctor-args (&/map% (fn [ctor-arg]
- (|do [:let [[ca-type ca-term] ctor-arg]
- =ca-type (generic-class->type full-env ca-type)
- =ca-term (&&/analyse-1 analyse =ca-type ca-term)]
- (return (&/T [ca-type =ca-term]))))
- ?ctor-args)
- =body (&/with-type-env full-env
- (&&env/with-local &&/jvm-this class-type
- (&/with-no-catches
- (with-catches (&/|map &host-generics/gclass->class-name ?exceptions)
- (&/fold (method-input-folder full-env)
- (&&/analyse-1 analyse output-type ?body)
- (&/|reverse ?inputs))))))]
- (return (&/$ConstructorMethodAnalysis (&/T [=privacy-modifier ?strict ?anns ?gvars ?exceptions ?inputs =ctor-args =body]))))
-
- (&/$VirtualMethodSyntax ?name =privacy-modifier =final? ?strict ?anns ?gvars ?exceptions ?inputs ?output ?body)
- (|do [method-env (make-type-env ?gvars)
- :let [full-env (&/|++ class-env method-env)]
- output-type (generic-class->type full-env ?output)
- =body (&/with-type-env full-env
- (&&env/with-local &&/jvm-this class-type
- (&/with-no-catches
- (with-catches (&/|map &host-generics/gclass->class-name ?exceptions)
- (&/fold (method-input-folder full-env)
- (&&/analyse-1 analyse output-type ?body)
- (&/|reverse ?inputs))))))]
- (return (&/$VirtualMethodAnalysis (&/T [?name =privacy-modifier =final? ?strict ?anns ?gvars ?exceptions ?inputs ?output =body]))))
-
- (&/$OverridenMethodSyntax ?class-decl ?name ?strict ?anns ?gvars ?exceptions ?inputs ?output ?body)
- (|do [super-env (gen-super-env class-env all-supers ?class-decl)
- method-env (make-type-env ?gvars)
- :let [full-env (&/|++ super-env method-env)]
- output-type (generic-class->type full-env ?output)
- =body (&/with-type-env full-env
- (&&env/with-local &&/jvm-this class-type
- (&/with-no-catches
- (with-catches (&/|map &host-generics/gclass->class-name ?exceptions)
- (&/fold (method-input-folder full-env)
- (&&/analyse-1 analyse output-type ?body)
- (&/|reverse ?inputs))))))]
- (return (&/$OverridenMethodAnalysis (&/T [?class-decl ?name ?strict ?anns ?gvars ?exceptions ?inputs ?output =body]))))
-
- (&/$StaticMethodSyntax ?name =privacy-modifier ?strict ?anns ?gvars ?exceptions ?inputs ?output ?body)
- (|do [method-env (make-type-env ?gvars)
- :let [full-env method-env]
- output-type (generic-class->type full-env ?output)
- =body (&/with-type-env full-env
- (&/with-no-catches
- (with-catches (&/|map &host-generics/gclass->class-name ?exceptions)
- (&/fold (method-input-folder full-env)
- (&&/analyse-1 analyse output-type ?body)
- (&/|reverse ?inputs)))))]
- (return (&/$StaticMethodAnalysis (&/T [?name =privacy-modifier ?strict ?anns ?gvars ?exceptions ?inputs ?output =body]))))
-
- (&/$AbstractMethodSyntax ?name =privacy-modifier ?anns ?gvars ?exceptions ?inputs ?output)
- (return (&/$AbstractMethodAnalysis (&/T [?name =privacy-modifier ?anns ?gvars ?exceptions ?inputs ?output])))
-
- (&/$NativeMethodSyntax ?name =privacy-modifier ?anns ?gvars ?exceptions ?inputs ?output)
- (return (&/$NativeMethodAnalysis (&/T [?name =privacy-modifier ?anns ?gvars ?exceptions ?inputs ?output])))
- )))
-
-(defn ^:private mandatory-methods [supers]
- (|do [class-loader &/loader]
- (&/flat-map% (partial &host/abstract-methods class-loader) supers)))
-
-(defn ^:private check-method-completion [supers methods]
- "(-> (List SuperClassDecl) (List (, MethodDecl Analysis)) (Lux Null))"
- (|do [abstract-methods (mandatory-methods supers)
- :let [methods-map (&/fold (fn [mmap mentry]
- (|case mentry
- (&/$ConstructorMethodAnalysis _)
- mmap
-
- (&/$VirtualMethodAnalysis _)
- mmap
-
- (&/$OverridenMethodAnalysis =class-decl =name ?strict =anns =gvars =exceptions =inputs =output body)
- (update-in mmap [=name] (fn [old-inputs] (if old-inputs (conj old-inputs =inputs) [=inputs])))
-
- (&/$StaticMethodAnalysis _)
- mmap
-
- (&/$AbstractMethodSyntax _)
- mmap
-
- (&/$NativeMethodSyntax _)
- mmap
- ))
- {}
- methods)
- missing-method (&/fold (fn [missing abs-meth]
- (or missing
- (|let [[am-name am-inputs] abs-meth]
- (if-let [meth-struct (get methods-map am-name)]
- (if (some (fn [=inputs]
- (and (= (&/|length =inputs) (&/|length am-inputs))
- (&/fold2 (fn [prev mi ai]
- (|let [[iname itype] mi]
- (and prev (= (generic-class->simple-class itype) ai))))
- true
- =inputs am-inputs)))
- meth-struct)
- nil
- abs-meth)
- abs-meth))))
- nil
- abstract-methods)]]
- (if (nil? missing-method)
- (return nil)
- (|let [[am-name am-inputs] missing-method]
- (&/fail-with-loc (str "[Analyser Error] Missing method: " am-name " " "(" (->> am-inputs (&/|interpose " ") (&/fold str "")) ")"))))))
-
-(defn ^:private analyse-field [analyse gtype-env field]
- "(-> Analyser GTypeEnv FieldSyntax (Lux FieldAnalysis))"
- (|case field
- (&/$ConstantFieldSyntax ?name ?anns ?gclass ?value)
- (|do [=gtype (&host-type/instance-gtype &type/existential gtype-env ?gclass)
- =value (&&/analyse-1 analyse =gtype ?value)]
- (return (&/$ConstantFieldAnalysis ?name ?anns ?gclass =value)))
-
- (&/$VariableFieldSyntax ?name ?privacy-modifier ?state-modifier ?anns ?type)
- (return (&/$VariableFieldAnalysis ?name ?privacy-modifier ?state-modifier ?anns ?type))
- ))
-
-(do-template [<name> <proc> <from-class> <to-class>]
- (let [output-type (&/$HostT <to-class> &/$Nil)]
- (defn <name> [analyse exo-type _?value]
- (|do [:let [(&/$Cons ?value (&/$Nil)) _?value]
- =value (&&/analyse-1 analyse (&/$HostT <from-class> &/$Nil) ?value)
- _ (&type/check exo-type output-type)
- _cursor &/cursor]
- (return (&/|list (&&/|meta output-type _cursor (&&/$proc (&/T ["jvm" <proc>]) (&/|list =value) (&/|list))))))))
-
- ^:private analyse-jvm-d2f "d2f" "java.lang.Double" "java.lang.Float"
- ^:private analyse-jvm-d2i "d2i" "java.lang.Double" "java.lang.Integer"
- ^:private analyse-jvm-d2l "d2l" "java.lang.Double" "java.lang.Long"
-
- ^:private analyse-jvm-f2d "f2d" "java.lang.Float" "java.lang.Double"
- ^:private analyse-jvm-f2i "f2i" "java.lang.Float" "java.lang.Integer"
- ^:private analyse-jvm-f2l "f2l" "java.lang.Float" "java.lang.Long"
-
- ^:private analyse-jvm-i2b "i2b" "java.lang.Integer" "java.lang.Byte"
- ^:private analyse-jvm-i2c "i2c" "java.lang.Integer" "java.lang.Character"
- ^:private analyse-jvm-i2d "i2d" "java.lang.Integer" "java.lang.Double"
- ^:private analyse-jvm-i2f "i2f" "java.lang.Integer" "java.lang.Float"
- ^:private analyse-jvm-i2l "i2l" "java.lang.Integer" "java.lang.Long"
- ^:private analyse-jvm-i2s "i2s" "java.lang.Integer" "java.lang.Short"
-
- ^:private analyse-jvm-l2d "l2d" "java.lang.Long" "java.lang.Double"
- ^:private analyse-jvm-l2f "l2f" "java.lang.Long" "java.lang.Float"
- ^:private analyse-jvm-l2i "l2i" "java.lang.Long" "java.lang.Integer"
- ^:private analyse-jvm-l2s "l2i" "java.lang.Long" "java.lang.Short"
- ^:private analyse-jvm-l2b "l2i" "java.lang.Long" "java.lang.Byte"
-
- ^:private analyse-jvm-c2b "c2b" "java.lang.Character" "java.lang.Byte"
- ^:private analyse-jvm-c2s "c2s" "java.lang.Character" "java.lang.Short"
- ^:private analyse-jvm-c2i "c2i" "java.lang.Character" "java.lang.Integer"
- ^:private analyse-jvm-c2l "c2l" "java.lang.Character" "java.lang.Long"
-
- ^:private analyse-jvm-s2l "s2l" "java.lang.Short" "java.lang.Long"
-
- ^:private analyse-jvm-b2l "b2l" "java.lang.Byte" "java.lang.Long"
- )
-
-(do-template [<name> <proc> <v1-class> <v2-class> <to-class>]
- (let [output-type (&/$HostT <to-class> &/$Nil)]
- (defn <name> [analyse exo-type ?values]
- (|do [:let [(&/$Cons ?value1 (&/$Cons ?value2 (&/$Nil))) ?values]
- =value1 (&&/analyse-1 analyse (&/$HostT <v1-class> &/$Nil) ?value1)
- =value2 (&&/analyse-1 analyse (&/$HostT <v2-class> &/$Nil) ?value2)
- _ (&type/check exo-type output-type)
- _cursor &/cursor]
- (return (&/|list (&&/|meta output-type _cursor (&&/$proc (&/T ["jvm" <proc>]) (&/|list =value1 =value2) (&/|list))))))))
-
- ^:private analyse-jvm-iand "iand" "java.lang.Integer" "java.lang.Integer" "java.lang.Integer"
- ^:private analyse-jvm-ior "ior" "java.lang.Integer" "java.lang.Integer" "java.lang.Integer"
- ^:private analyse-jvm-ixor "ixor" "java.lang.Integer" "java.lang.Integer" "java.lang.Integer"
- ^:private analyse-jvm-ishl "ishl" "java.lang.Integer" "java.lang.Integer" "java.lang.Integer"
- ^:private analyse-jvm-ishr "ishr" "java.lang.Integer" "java.lang.Integer" "java.lang.Integer"
- ^:private analyse-jvm-iushr "iushr" "java.lang.Integer" "java.lang.Integer" "java.lang.Integer"
-
- ^:private analyse-jvm-land "land" "java.lang.Long" "java.lang.Long" "java.lang.Long"
- ^:private analyse-jvm-lor "lor" "java.lang.Long" "java.lang.Long" "java.lang.Long"
- ^:private analyse-jvm-lxor "lxor" "java.lang.Long" "java.lang.Long" "java.lang.Long"
- ^:private analyse-jvm-lshl "lshl" "java.lang.Long" "java.lang.Integer" "java.lang.Long"
- ^:private analyse-jvm-lshr "lshr" "java.lang.Long" "java.lang.Integer" "java.lang.Long"
- ^:private analyse-jvm-lushr "lushr" "java.lang.Long" "java.lang.Integer" "java.lang.Long"
- )
-
-(do-template [<name> <proc> <input-class> <output-class>]
- (let [input-type (&/$HostT <input-class> &/$Nil)
- output-type (&/$HostT <output-class> &/$Nil)]
- (defn <name> [analyse exo-type ?values]
- (|do [:let [(&/$Cons x (&/$Cons y (&/$Nil))) ?values]
- =x (&&/analyse-1 analyse input-type x)
- =y (&&/analyse-1 analyse input-type y)
- _ (&type/check exo-type output-type)
- _cursor &/cursor]
- (return (&/|list (&&/|meta output-type _cursor
- (&&/$proc (&/T ["jvm" <proc>]) (&/|list =x =y) (&/|list))))))))
-
- ^:private analyse-jvm-iadd "iadd" "java.lang.Integer" "java.lang.Integer"
- ^:private analyse-jvm-isub "isub" "java.lang.Integer" "java.lang.Integer"
- ^:private analyse-jvm-imul "imul" "java.lang.Integer" "java.lang.Integer"
- ^:private analyse-jvm-idiv "idiv" "java.lang.Integer" "java.lang.Integer"
- ^:private analyse-jvm-irem "irem" "java.lang.Integer" "java.lang.Integer"
- ^:private analyse-jvm-ieq "ieq" "java.lang.Integer" "java.lang.Boolean"
- ^:private analyse-jvm-ilt "ilt" "java.lang.Integer" "java.lang.Boolean"
- ^:private analyse-jvm-igt "igt" "java.lang.Integer" "java.lang.Boolean"
-
- ^:private analyse-jvm-ceq "ceq" "java.lang.Character" "java.lang.Boolean"
- ^:private analyse-jvm-clt "clt" "java.lang.Character" "java.lang.Boolean"
- ^:private analyse-jvm-cgt "cgt" "java.lang.Character" "java.lang.Boolean"
-
- ^:private analyse-jvm-ladd "ladd" "java.lang.Long" "java.lang.Long"
- ^:private analyse-jvm-lsub "lsub" "java.lang.Long" "java.lang.Long"
- ^:private analyse-jvm-lmul "lmul" "java.lang.Long" "java.lang.Long"
- ^:private analyse-jvm-ldiv "ldiv" "java.lang.Long" "java.lang.Long"
- ^:private analyse-jvm-lrem "lrem" "java.lang.Long" "java.lang.Long"
- ^:private analyse-jvm-leq "leq" "java.lang.Long" "java.lang.Boolean"
- ^:private analyse-jvm-llt "llt" "java.lang.Long" "java.lang.Boolean"
- ^:private analyse-jvm-lgt "lgt" "java.lang.Long" "java.lang.Boolean"
-
- ^:private analyse-jvm-fadd "fadd" "java.lang.Float" "java.lang.Float"
- ^:private analyse-jvm-fsub "fsub" "java.lang.Float" "java.lang.Float"
- ^:private analyse-jvm-fmul "fmul" "java.lang.Float" "java.lang.Float"
- ^:private analyse-jvm-fdiv "fdiv" "java.lang.Float" "java.lang.Float"
- ^:private analyse-jvm-frem "frem" "java.lang.Float" "java.lang.Float"
- ^:private analyse-jvm-feq "feq" "java.lang.Float" "java.lang.Boolean"
- ^:private analyse-jvm-flt "flt" "java.lang.Float" "java.lang.Boolean"
- ^:private analyse-jvm-fgt "fgt" "java.lang.Float" "java.lang.Boolean"
-
- ^:private analyse-jvm-dadd "dadd" "java.lang.Double" "java.lang.Double"
- ^:private analyse-jvm-dsub "dsub" "java.lang.Double" "java.lang.Double"
- ^:private analyse-jvm-dmul "dmul" "java.lang.Double" "java.lang.Double"
- ^:private analyse-jvm-ddiv "ddiv" "java.lang.Double" "java.lang.Double"
- ^:private analyse-jvm-drem "drem" "java.lang.Double" "java.lang.Double"
- ^:private analyse-jvm-deq "deq" "java.lang.Double" "java.lang.Boolean"
- ^:private analyse-jvm-dlt "dlt" "java.lang.Double" "java.lang.Boolean"
- ^:private analyse-jvm-dgt "dgt" "java.lang.Double" "java.lang.Boolean"
- )
-
-(let [length-type &type/Nat
- idx-type &type/Nat]
- (do-template [<elem-class> <array-class> <new-name> <new-tag> <load-name> <load-tag> <store-name> <store-tag>]
- (let [elem-type (&/$HostT <elem-class> &/$Nil)
- array-type (&/$HostT <array-class> &/$Nil)]
- (defn <new-name> [analyse exo-type ?values]
- (|do [:let [(&/$Cons length (&/$Nil)) ?values]
- =length (&&/analyse-1 analyse length-type length)
- _ (&type/check exo-type array-type)
- _cursor &/cursor]
- (return (&/|list (&&/|meta exo-type _cursor
- (&&/$proc (&/T ["jvm" <new-tag>]) (&/|list =length) (&/|list)))))))
-
- (defn <load-name> [analyse exo-type ?values]
- (|do [:let [(&/$Cons array (&/$Cons idx (&/$Nil))) ?values]
- =array (&&/analyse-1 analyse array-type array)
- =idx (&&/analyse-1 analyse idx-type idx)
- _ (&type/check exo-type elem-type)
- _cursor &/cursor]
- (return (&/|list (&&/|meta exo-type _cursor
- (&&/$proc (&/T ["jvm" <load-tag>]) (&/|list =array =idx) (&/|list)))))))
-
- (defn <store-name> [analyse exo-type ?values]
- (|do [:let [(&/$Cons array (&/$Cons idx (&/$Cons elem (&/$Nil)))) ?values]
- =array (&&/analyse-1 analyse array-type array)
- =idx (&&/analyse-1 analyse idx-type idx)
- =elem (&&/analyse-1 analyse elem-type elem)
- _ (&type/check exo-type array-type)
- _cursor &/cursor]
- (return (&/|list (&&/|meta exo-type _cursor
- (&&/$proc (&/T ["jvm" <store-tag>]) (&/|list =array =idx =elem) (&/|list)))))))
- )
-
- "java.lang.Boolean" "[Z" ^:private analyse-jvm-znewarray "znewarray" analyse-jvm-zaload "zaload" analyse-jvm-zastore "zastore"
- "java.lang.Byte" "[B" ^:private analyse-jvm-bnewarray "bnewarray" analyse-jvm-baload "baload" analyse-jvm-bastore "bastore"
- "java.lang.Short" "[S" ^:private analyse-jvm-snewarray "snewarray" analyse-jvm-saload "saload" analyse-jvm-sastore "sastore"
- "java.lang.Integer" "[I" ^:private analyse-jvm-inewarray "inewarray" analyse-jvm-iaload "iaload" analyse-jvm-iastore "iastore"
- "java.lang.Long" "[J" ^:private analyse-jvm-lnewarray "lnewarray" analyse-jvm-laload "laload" analyse-jvm-lastore "lastore"
- "java.lang.Float" "[F" ^:private analyse-jvm-fnewarray "fnewarray" analyse-jvm-faload "faload" analyse-jvm-fastore "fastore"
- "java.lang.Double" "[D" ^:private analyse-jvm-dnewarray "dnewarray" analyse-jvm-daload "daload" analyse-jvm-dastore "dastore"
- "java.lang.Character" "[C" ^:private analyse-jvm-cnewarray "cnewarray" analyse-jvm-caload "caload" analyse-jvm-castore "castore"
- ))
-
-(defn ^:private array-class? [class-name]
- (or (= &host-type/array-data-tag class-name)
- (case class-name
- ("[Z" "[B" "[S" "[I" "[J" "[F" "[D" "[C") true
- ;; else
- false)))
-
-(let [length-type &type/Nat
- idx-type &type/Nat]
- (defn ^:private analyse-jvm-anewarray [analyse exo-type ?values]
- (|do [:let [(&/$Cons [_ (&/$TextS _gclass)] (&/$Cons length (&/$Nil))) ?values]
- gclass (&reader/with-source "jvm-anewarray" _gclass
- &&a-parser/parse-gclass)
- gtype-env &/get-type-env
- =gclass (&host-type/instance-gtype &type/existential gtype-env gclass)
- :let [array-type (&/$HostT &host-type/array-data-tag (&/|list =gclass))]
- =length (&&/analyse-1 analyse length-type length)
- _ (&type/check exo-type array-type)
- _cursor &/cursor]
- (return (&/|list (&&/|meta exo-type _cursor
- (&&/$proc (&/T ["jvm" "anewarray"]) (&/|list =length) (&/|list gclass gtype-env)))))))
-
- (defn ^:private analyse-jvm-aaload [analyse exo-type ?values]
- (|do [:let [(&/$Cons array (&/$Cons idx (&/$Nil))) ?values]
- =array (&&/analyse-1+ analyse array)
- [arr-class arr-params] (ensure-object (&&/expr-type* =array))
- _ (&/assert! (= &host-type/array-data-tag arr-class) (str "[Analyser Error] Expected array. Instead got: " arr-class))
- :let [(&/$Cons inner-arr-type (&/$Nil)) arr-params]
- =idx (&&/analyse-1 analyse idx-type idx)
- _ (&type/check exo-type inner-arr-type)
- _cursor &/cursor]
- (return (&/|list (&&/|meta exo-type _cursor
- (&&/$proc (&/T ["jvm" "aaload"]) (&/|list =array =idx) (&/|list)))))))
-
- (defn ^:private analyse-jvm-aastore [analyse exo-type ?values]
- (|do [:let [(&/$Cons array (&/$Cons idx (&/$Cons elem (&/$Nil)))) ?values]
- =array (&&/analyse-1+ analyse array)
- :let [array-type (&&/expr-type* =array)]
- [arr-class arr-params] (ensure-object array-type)
- _ (&/assert! (= &host-type/array-data-tag arr-class) (str "[Analyser Error] Expected array. Instead got: " arr-class))
- :let [(&/$Cons inner-arr-type (&/$Nil)) arr-params]
- =idx (&&/analyse-1 analyse idx-type idx)
- =elem (&&/analyse-1 analyse inner-arr-type elem)
- _ (&type/check exo-type array-type)
- _cursor &/cursor]
- (return (&/|list (&&/|meta exo-type _cursor
- (&&/$proc (&/T ["jvm" "aastore"]) (&/|list =array =idx =elem) (&/|list))))))))
-
-(defn ^:private analyse-jvm-arraylength [analyse exo-type ?values]
- (|do [:let [(&/$Cons array (&/$Nil)) ?values]
- =array (&&/analyse-1+ analyse array)
- [arr-class arr-params] (ensure-object (&&/expr-type* =array))
- _ (&/assert! (array-class? arr-class) (str "[Analyser Error] Expected array. Instead got: " arr-class))
- _ (&type/check exo-type &type/Nat)
- _cursor &/cursor]
- (return (&/|list (&&/|meta exo-type _cursor
- (&&/$proc (&/T ["jvm" "arraylength"]) (&/|list =array) (&/|list))
- )))))
-
-(defn ^:private analyse-jvm-null? [analyse exo-type ?values]
- (|do [:let [(&/$Cons object (&/$Nil)) ?values]
- =object (&&/analyse-1+ analyse object)
- _ (ensure-object (&&/expr-type* =object))
- :let [output-type &type/Bool]
- _ (&type/check exo-type output-type)
- _cursor &/cursor]
- (return (&/|list (&&/|meta exo-type _cursor
- (&&/$proc (&/T ["jvm" "null?"]) (&/|list =object) (&/|list)))))))
-
-(defn ^:private analyse-jvm-null [analyse exo-type ?values]
- (|do [:let [(&/$Nil) ?values]
- :let [output-type (&/$HostT &host-type/null-data-tag &/$Nil)]
- _ (&type/check exo-type output-type)
- _cursor &/cursor]
- (return (&/|list (&&/|meta exo-type _cursor
- (&&/$proc (&/T ["jvm" "null"]) (&/|list) (&/|list)))))))
-
-(defn analyse-jvm-synchronized [analyse exo-type ?values]
- (|do [:let [(&/$Cons ?monitor (&/$Cons ?expr (&/$Nil))) ?values]
- =monitor (&&/analyse-1+ analyse ?monitor)
- _ (ensure-object (&&/expr-type* =monitor))
- =expr (&&/analyse-1 analyse exo-type ?expr)
- _cursor &/cursor]
- (return (&/|list (&&/|meta exo-type _cursor
- (&&/$proc (&/T ["jvm" "synchronized"]) (&/|list =monitor =expr) (&/|list)))))))
-
-(do-template [<name> <tag>]
- (defn <name> [analyse exo-type ?values]
- (|do [:let [(&/$Cons ?monitor (&/$Nil)) ?values]
- =monitor (&&/analyse-1+ analyse ?monitor)
- _ (ensure-object (&&/expr-type* =monitor))
- :let [output-type &/$UnitT]
- _ (&type/check exo-type output-type)
- _cursor &/cursor]
- (return (&/|list (&&/|meta exo-type _cursor
- (&&/$proc (&/T ["jvm" <tag>]) (&/|list =monitor) (&/|list)))))))
-
- ^:private analyse-jvm-monitorenter "monitorenter"
- ^:private analyse-jvm-monitorexit "monitorexit"
- )
-
-(defn ^:private analyse-jvm-throw [analyse exo-type ?values]
- (|do [:let [(&/$Cons ?ex (&/$Nil)) ?values]
- =ex (&&/analyse-1+ analyse ?ex)
- _ (&type/check (&/$HostT "java.lang.Throwable" &/$Nil) (&&/expr-type* =ex))
- [throw-class throw-params] (ensure-object (&&/expr-type* =ex))
- _ (ensure-catching (&/|list throw-class))
- _cursor &/cursor
- _ (&type/check exo-type &type/Bottom)]
- (return (&/|list (&&/|meta exo-type _cursor
- (&&/$proc (&/T ["jvm" "throw"]) (&/|list =ex) (&/|list)))))))
-
-(defn ^:private analyse-jvm-getstatic [analyse exo-type class field ?values]
- (|do [!class! (&/de-alias-class class)
- :let [(&/$Nil) ?values]
- class-loader &/loader
- [gvars gtype] (&host/lookup-static-field class-loader !class! field)
- =type (&host-type/instance-param &type/existential &/$Nil gtype)
- :let [output-type =type]
- _ (&type/check exo-type output-type)
- _cursor &/cursor]
- (return (&/|list (&&/|meta exo-type _cursor
- (&&/$proc (&/T ["jvm" "getstatic"]) (&/|list) (&/|list class field output-type)))))))
-
-(defn ^:private analyse-jvm-getfield [analyse exo-type class field ?values]
- (|do [!class! (&/de-alias-class class)
- :let [(&/$Cons object (&/$Nil)) ?values]
- class-loader &/loader
- =object (&&/analyse-1+ analyse object)
- _ (ensure-object (&&/expr-type* =object))
- [gvars gtype] (&host/lookup-field class-loader !class! field)
- =type (analyse-field-access-helper (&&/expr-type* =object) gvars gtype)
- :let [output-type =type]
- _ (&type/check exo-type output-type)
- _cursor &/cursor]
- (return (&/|list (&&/|meta exo-type _cursor
- (&&/$proc (&/T ["jvm" "getfield"]) (&/|list =object) (&/|list class field output-type)))))))
-
-(defn ^:private analyse-jvm-putstatic [analyse exo-type class field ?values]
- (|do [!class! (&/de-alias-class class)
- :let [(&/$Cons value (&/$Nil)) ?values]
- class-loader &/loader
- [gvars gtype] (&host/lookup-static-field class-loader !class! field)
- :let [gclass (&host-type/gtype->gclass gtype)]
- =type (&host-type/instance-param &type/existential &/$Nil gtype)
- =value (&&/analyse-1 analyse =type value)
- :let [output-type &/$UnitT]
- _ (&type/check exo-type output-type)
- _cursor &/cursor]
- (return (&/|list (&&/|meta exo-type _cursor
- (&&/$proc (&/T ["jvm" "putstatic"]) (&/|list =value) (&/|list class field gclass)))))))
-
-(defn ^:private analyse-jvm-putfield [analyse exo-type class field ?values]
- (|do [!class! (&/de-alias-class class)
- :let [(&/$Cons object (&/$Cons value (&/$Nil))) ?values]
- class-loader &/loader
- =object (&&/analyse-1+ analyse object)
- :let [obj-type (&&/expr-type* =object)]
- _ (ensure-object obj-type)
- [gvars gtype] (&host/lookup-field class-loader !class! field)
- :let [gclass (&host-type/gtype->gclass gtype)]
- =type (analyse-field-access-helper obj-type gvars gtype)
- =value (&&/analyse-1 analyse =type value)
- :let [output-type &/$UnitT]
- _ (&type/check exo-type output-type)
- _cursor &/cursor]
- (return (&/|list (&&/|meta exo-type _cursor
- (&&/$proc (&/T ["jvm" "putfield"]) (&/|list =object =value) (&/|list class field gclass =type)))))))
-
-(defn ^:private analyse-method-call-helper [analyse exo-type gret gtype-env gtype-vars gtype-args args]
- (|case gtype-vars
- (&/$Nil)
- (|do [arg-types (&/map% (partial &host-type/instance-param &type/existential gtype-env) gtype-args)
- =arg-types (&/map% &type/show-type+ arg-types)
- =args (&/map2% (partial &&/analyse-1 analyse) arg-types args)
- =gret (&host-type/instance-param &type/existential gtype-env gret)
- _ (&type/check exo-type (as-otype+ =gret))]
- (return (&/T [=gret =args])))
-
- (&/$Cons ^TypeVariable gtv gtype-vars*)
- (&type/with-var
- (fn [$var]
- (|do [:let [(&/$VarT _id) $var
- gtype-env* (&/$Cons (&/T [(.getName gtv) $var]) gtype-env)]
- [=gret =args] (analyse-method-call-helper analyse exo-type gret gtype-env* gtype-vars* gtype-args args)
- ==gret (&type/clean $var =gret)
- ==args (&/map% (partial &&/clean-analysis $var) =args)]
- (return (&/T [==gret ==args])))))
- ))
-
-(let [dummy-type-param (&/$HostT "java.lang.Object" &/$Nil)]
- (do-template [<name> <tag> <only-interface?>]
- (defn <name> [analyse exo-type class method classes ?values]
- (|do [!class! (&/de-alias-class class)
- :let [(&/$Cons object args) ?values]
- class-loader &/loader
- _ (try (assert! (let [=class (Class/forName !class! true class-loader)]
- (= <only-interface?> (.isInterface =class)))
- (if <only-interface?>
- (str "[Analyser Error] Can only invoke method \"" method "\"" " on interface.")
- (str "[Analyser Error] Can only invoke method \"" method "\"" " on class.")))
- (catch Exception e
- (&/fail-with-loc (str "[Analyser Error] Unknown class: " class))))
- [gret exceptions parent-gvars gvars gargs] (if (= "<init>" method)
- (return (&/T [Void/TYPE &/$Nil &/$Nil &/$Nil &/$Nil]))
- (&host/lookup-virtual-method class-loader !class! method classes))
- _ (ensure-catching exceptions)
- =object (&&/analyse-1+ analyse object)
- [sub-class sub-params] (ensure-object (&&/expr-type* =object))
- (&/$HostT super-class* super-params*) (&host-type/->super-type &type/existential class-loader !class! (if (= sub-class class)
- !class!
- sub-class)
- sub-params)
- :let [gtype-env (&/fold2 (fn [m ^TypeVariable g t] (&/$Cons (&/T [(.getName g) t]) m))
- (&/|table)
- parent-gvars
- super-params*)]
- [output-type =args] (analyse-method-call-helper analyse exo-type gret gtype-env gvars gargs args)
- _cursor &/cursor]
- (return (&/|list (&&/|meta exo-type _cursor
- (&&/$proc (&/T ["jvm" <tag>]) (&/$Cons =object =args) (&/|list class method classes output-type gret)))))))
-
- ^:private analyse-jvm-invokevirtual "invokevirtual" false
- ^:private analyse-jvm-invokespecial "invokespecial" false
- ^:private analyse-jvm-invokeinterface "invokeinterface" true
- ))
-
-(defn ^:private analyse-jvm-invokestatic [analyse exo-type class method classes ?values]
- (|do [!class! (&/de-alias-class class)
- :let [args ?values]
- class-loader &/loader
- [gret exceptions parent-gvars gvars gargs] (&host/lookup-static-method class-loader !class! method classes)
- _ (ensure-catching exceptions)
- :let [gtype-env (&/|table)]
- [output-type =args] (analyse-method-call-helper analyse exo-type gret gtype-env gvars gargs args)
- _cursor &/cursor]
- (return (&/|list (&&/|meta exo-type _cursor
- (&&/$proc (&/T ["jvm" "invokestatic"]) =args (&/|list class method classes output-type gret)))))))
-
-(defn ^:private analyse-jvm-new-helper [analyse gtype gtype-env gtype-vars gtype-args args]
- (|case gtype-vars
- (&/$Nil)
- (|do [arg-types (&/map% (partial &host-type/instance-param &type/existential gtype-env) gtype-args)
- =args (&/map2% (partial &&/analyse-1 analyse) arg-types args)
- gtype-vars* (->> gtype-env (&/|map &/|second) (clean-gtype-vars))]
- (return (&/T [(make-gtype gtype gtype-vars*)
- =args])))
-
- (&/$Cons ^TypeVariable gtv gtype-vars*)
- (&type/with-var
- (fn [$var]
- (|do [:let [gtype-env* (&/$Cons (&/T [(.getName gtv) $var]) gtype-env)]
- [=gret =args] (analyse-jvm-new-helper analyse gtype gtype-env* gtype-vars* gtype-args args)
- ==gret (&type/clean $var =gret)
- ==args (&/map% (partial &&/clean-analysis $var) =args)]
- (return (&/T [==gret ==args])))))
- ))
-
-(defn ^:private analyse-jvm-new [analyse exo-type class classes ?values]
- (|do [!class! (&/de-alias-class class)
- :let [args ?values]
- class-loader &/loader
- [exceptions gvars gargs] (&host/lookup-constructor class-loader !class! classes)
- _ (ensure-catching exceptions)
- [output-type =args] (analyse-jvm-new-helper analyse class (&/|table) gvars gargs args)
- _ (&type/check exo-type output-type)
- _cursor &/cursor]
- (return (&/|list (&&/|meta exo-type _cursor
- (&&/$proc (&/T ["jvm" "new"]) =args (&/|list class classes)))))))
-
-(defn ^:private analyse-jvm-try [analyse exo-type ?values]
- (|do [:let [(&/$Cons ?body (&/$Cons ?catch (&/$Nil))) ?values]
- =body (with-catches (&/|list "java.lang.Exception")
- (&&/analyse-1 analyse exo-type ?body))
- =catch (&&/analyse-1 analyse (&/$LambdaT (&/$HostT "java.lang.Exception" &/$Nil) exo-type) ?catch)
- _cursor &/cursor]
- (return (&/|list (&&/|meta exo-type _cursor
- (&&/$proc (&/T ["jvm" "try"]) (&/|list =body =catch) (&/|list)))))))
-
-(defn ^:private analyse-jvm-instanceof [analyse exo-type class ?values]
- (|do [:let [(&/$Cons object (&/$Nil)) ?values]
- =object (&&/analyse-1+ analyse object)
- _ (ensure-object (&&/expr-type* =object))
- :let [output-type &type/Bool]
- _ (&type/check exo-type output-type)
- _cursor &/cursor]
- (return (&/|list (&&/|meta output-type _cursor
- (&&/$proc (&/T ["jvm" "instanceof"]) (&/|list =object) (&/|list class)))))))
-
-(defn ^:private analyse-jvm-load-class [analyse exo-type ?values]
- (|do [:let [(&/$Cons [_ (&/$TextS _class-name)] (&/$Nil)) ?values]
- ^ClassLoader class-loader &/loader
- _ (try (do (.loadClass class-loader _class-name)
- (return nil))
- (catch Exception e
- (&/fail-with-loc (str "[Analyser Error] Unknown class: " _class-name))))
- :let [output-type (&/$HostT "java.lang.Class" (&/|list (&/$HostT _class-name (&/|list))))]
- _ (&type/check exo-type output-type)
- _cursor &/cursor]
- (return (&/|list (&&/|meta output-type _cursor
- (&&/$proc (&/T ["jvm" "load-class"]) (&/|list) (&/|list _class-name output-type)))))))
-
-(let [length-type &type/Nat
- idx-type &type/Nat]
- (defn ^:private analyse-array-new [analyse exo-type ?values]
- (|do [:let [(&/$Cons length (&/$Nil)) ?values]
- :let [gclass (&/$GenericClass "java.lang.Object" (&/|list))
- array-type (&/$UnivQ (&/|list) (&/$HostT &host-type/array-data-tag (&/|list (&/$BoundT 1))))]
- gtype-env &/get-type-env
- =length (&&/analyse-1 analyse length-type length)
- _ (&type/check exo-type array-type)
- _cursor &/cursor]
- (return (&/|list (&&/|meta exo-type _cursor
- (&&/$proc (&/T ["jvm" "anewarray"]) (&/|list =length) (&/|list gclass gtype-env)))))))
-
- (defn ^:private analyse-array-get [analyse exo-type ?values]
- (|do [:let [(&/$Cons array (&/$Cons idx (&/$Nil))) ?values]
- =array (&&/analyse-1+ analyse array)
- [arr-class arr-params] (ensure-object (&&/expr-type* =array))
- _ (&/assert! (= &host-type/array-data-tag arr-class) (str "[Analyser Error] Expected array. Instead got: " arr-class))
- :let [(&/$Cons inner-arr-type (&/$Nil)) arr-params]
- =idx (&&/analyse-1 analyse idx-type idx)
- _ (&type/check exo-type (&/$AppT &type/Maybe inner-arr-type))
- _cursor &/cursor]
- (return (&/|list (&&/|meta exo-type _cursor
- (&&/$proc (&/T ["array" "get"]) (&/|list =array =idx) (&/|list)))))))
-
- (defn ^:private analyse-array-remove [analyse exo-type ?values]
- (|do [:let [(&/$Cons array (&/$Cons idx (&/$Nil))) ?values]
- =array (&&/analyse-1+ analyse array)
- :let [array-type (&&/expr-type* =array)]
- [arr-class arr-params] (ensure-object array-type)
- _ (&/assert! (= &host-type/array-data-tag arr-class) (str "[Analyser Error] Expected array. Instead got: " arr-class))
- :let [(&/$Cons inner-arr-type (&/$Nil)) arr-params]
- =idx (&&/analyse-1 analyse idx-type idx)
- _cursor &/cursor
- :let [=elem (&&/|meta inner-arr-type _cursor
- (&&/$proc (&/T ["jvm" "null"]) (&/|list) (&/|list)))]
- _ (&type/check exo-type array-type)]
- (return (&/|list (&&/|meta exo-type _cursor
- (&&/$proc (&/T ["jvm" "aastore"]) (&/|list =array =idx =elem) (&/|list))))))))
-
-(defn ^:private analyse-jvm-interface [analyse compile-interface interface-decl supers =anns =methods]
- (|do [module &/get-module-name
- _ (compile-interface interface-decl supers =anns =methods)
- :let [_ (println 'INTERFACE (str module "." (&/|first interface-decl)))]
- _cursor &/cursor]
- (return (&/|list (&&/|meta &/$UnitT _cursor
- (&&/$tuple (&/|list)))))))
-
-(defn ^:private analyse-jvm-class [analyse compile-class class-decl super-class interfaces =inheritance-modifier =anns ?fields methods]
- (&/with-closure
- (|do [module &/get-module-name
- :let [[?name ?params] class-decl
- full-name (str (string/replace module "/" ".") "." ?name)
- class-decl* (&/T [full-name ?params])
- all-supers (&/$Cons super-class interfaces)]
- class-env (make-type-env ?params)
- =fields (&/map% (partial analyse-field analyse class-env) ?fields)
- _ (&host/use-dummy-class class-decl super-class interfaces &/$None =fields methods)
- =methods (&/map% (partial analyse-method analyse class-decl* class-env all-supers) methods)
- _ (check-method-completion all-supers =methods)
- _ (compile-class class-decl super-class interfaces =inheritance-modifier =anns =fields =methods &/$Nil &/$None)
- _ &/pop-dummy-name
- :let [_ (println 'CLASS full-name)]
- _cursor &/cursor]
- (return (&/|list (&&/|meta &/$UnitT _cursor
- (&&/$tuple (&/|list))))))))
-
-(defn ^:private captured-source [env-entry]
- (|case env-entry
- [name [_ (&&/$captured _ _ source)]]
- source))
-
-(let [default-<init> (&/$ConstructorMethodSyntax (&/T [&/$PublicPM
- false
- &/$Nil
- &/$Nil
- &/$Nil
- &/$Nil
- &/$Nil
- (&/$TupleS &/$Nil)]))
- captured-slot-class "java.lang.Object"
- captured-slot-type (&/$GenericClass captured-slot-class &/$Nil)]
- (defn ^:private analyse-jvm-anon-class [analyse compile-class exo-type super-class interfaces ctor-args methods]
- (&/with-closure
- (|do [module &/get-module-name
- scope &/get-scope-name
- :let [name (->> scope &/|reverse &/|tail &host/location)
- class-decl (&/T [name &/$Nil])
- anon-class (str (string/replace module "/" ".") "." name)
- anon-class-type (&/$HostT anon-class &/$Nil)]
- =ctor-args (&/map% (fn [ctor-arg]
- (|let [[arg-type arg-term] ctor-arg]
- (|do [=arg-term (&&/analyse-1+ analyse arg-term)]
- (return (&/T [arg-type =arg-term])))))
- ctor-args)
- _ (->> methods
- (&/$Cons default-<init>)
- (&host/use-dummy-class class-decl super-class interfaces (&/$Some =ctor-args) &/$Nil))
- :let [all-supers (&/$Cons super-class interfaces)
- class-env &/$Nil]
- =methods (&/map% (partial analyse-method analyse class-decl class-env all-supers) methods)
- _ (check-method-completion all-supers =methods)
- =captured &&env/captured-vars
- :let [=fields (&/|map (fn [^objects idx+capt]
- (|let [[idx _] idx+capt]
- (&/$VariableFieldAnalysis (str &c!base/closure-prefix idx)
- &/$PublicPM
- &/$FinalSM
- &/$Nil
- captured-slot-type)))
- (&/enumerate =captured))]
- :let [sources (&/|map captured-source =captured)]
- _ (compile-class class-decl super-class interfaces &/$DefaultIM &/$Nil =fields =methods =captured (&/$Some =ctor-args))
- _ &/pop-dummy-name
- _cursor &/cursor]
- (return (&/|list (&&/|meta anon-class-type _cursor
- (&&/$proc (&/T ["jvm" "new"]) sources (&/|list anon-class (&/|repeat (&/|length sources) captured-slot-class)))
- )))
- ))))
-
-(do-template [<name> <op>]
- (defn <name> [analyse exo-type ?values]
- (|do [:let [(&/$Cons input (&/$Cons mask (&/$Nil))) ?values]
- =mask (&&/analyse-1 analyse &type/Nat mask)
- =input (&&/analyse-1 analyse &type/Nat input)
- _ (&type/check exo-type &type/Nat)
- _cursor &/cursor]
- (return (&/|list (&&/|meta exo-type _cursor
- (&&/$proc (&/T ["bit" <op>]) (&/|list =input =mask) (&/|list)))))))
-
- ^:private analyse-bit-and "and"
- ^:private analyse-bit-or "or"
- ^:private analyse-bit-xor "xor"
- )
-
-(defn ^:private analyse-bit-count [analyse exo-type ?values]
- (|do [:let [(&/$Cons input (&/$Nil)) ?values]
- =input (&&/analyse-1 analyse &type/Nat input)
- _ (&type/check exo-type &type/Nat)
- _cursor &/cursor]
- (return (&/|list (&&/|meta exo-type _cursor
- (&&/$proc (&/T ["bit" "count"]) (&/|list =input) (&/|list)))))))
-
-(do-template [<name> <op> <type>]
- (defn <name> [analyse exo-type ?values]
- (|do [:let [(&/$Cons input (&/$Cons shift (&/$Nil))) ?values]
- =shift (&&/analyse-1 analyse &type/Nat shift)
- =input (&&/analyse-1 analyse <type> input)
- _ (&type/check exo-type <type>)
- _cursor &/cursor]
- (return (&/|list (&&/|meta exo-type _cursor
- (&&/$proc (&/T ["bit" <op>]) (&/|list =input =shift) (&/|list)))))))
-
- ^:private analyse-bit-shift-left "shift-left" &type/Nat
- ^:private analyse-bit-shift-right "shift-right" &type/Int
- ^:private analyse-bit-unsigned-shift-right "unsigned-shift-right" &type/Nat
- )
-
-(defn ^:private analyse-lux-== [analyse exo-type ?values]
- (&type/with-var
- (fn [$var]
- (|do [:let [(&/$Cons left (&/$Cons right (&/$Nil))) ?values]
- =left (&&/analyse-1 analyse $var left)
- =right (&&/analyse-1 analyse $var right)
- _ (&type/check exo-type &type/Bool)
- _cursor &/cursor]
- (return (&/|list (&&/|meta exo-type _cursor
- (&&/$proc (&/T ["lux" "=="]) (&/|list =left =right) (&/|list)))))))))
-
-(do-template [<name> <proc> <input-type> <output-type>]
- (defn <name> [analyse exo-type ?values]
- (|do [:let [(&/$Cons x (&/$Cons y (&/$Nil))) ?values]
- =x (&&/analyse-1 analyse <input-type> x)
- =y (&&/analyse-1 analyse <input-type> y)
- _ (&type/check exo-type <output-type>)
- _cursor &/cursor]
- (return (&/|list (&&/|meta <output-type> _cursor
- (&&/$proc (&/T <proc>) (&/|list =x =y) (&/|list)))))))
-
- ^:private analyse-nat-add ["nat" "+"] &type/Nat &type/Nat
- ^:private analyse-nat-sub ["nat" "-"] &type/Nat &type/Nat
- ^:private analyse-nat-mul ["nat" "*"] &type/Nat &type/Nat
- ^:private analyse-nat-div ["nat" "/"] &type/Nat &type/Nat
- ^:private analyse-nat-rem ["nat" "%"] &type/Nat &type/Nat
- ^:private analyse-nat-eq ["nat" "="] &type/Nat &type/Bool
- ^:private analyse-nat-lt ["nat" "<"] &type/Nat &type/Bool
-
- ^:private analyse-frac-add ["frac" "+"] &type/Frac &type/Frac
- ^:private analyse-frac-sub ["frac" "-"] &type/Frac &type/Frac
- ^:private analyse-frac-mul ["frac" "*"] &type/Frac &type/Frac
- ^:private analyse-frac-div ["frac" "/"] &type/Frac &type/Frac
- ^:private analyse-frac-rem ["frac" "%"] &type/Frac &type/Frac
- ^:private analyse-frac-eq ["frac" "="] &type/Frac &type/Bool
- ^:private analyse-frac-lt ["frac" "<"] &type/Frac &type/Bool
- )
-
-(defn ^:private analyse-frac-scale [analyse exo-type ?values]
- (|do [:let [(&/$Cons x (&/$Cons y (&/$Nil))) ?values]
- =x (&&/analyse-1 analyse &type/Frac x)
- =y (&&/analyse-1 analyse &type/Nat y)
- _ (&type/check exo-type &type/Frac)
- _cursor &/cursor]
- (return (&/|list (&&/|meta &type/Frac _cursor
- (&&/$proc (&/T ["frac" "scale"]) (&/|list =x =y) (&/|list)))))))
-
-(do-template [<encode> <encode-op> <decode> <decode-op> <type>]
- (do (defn <encode> [analyse exo-type ?values]
- (|do [:let [(&/$Cons x (&/$Nil)) ?values]
- =x (&&/analyse-1 analyse <type> x)
- _ (&type/check exo-type &type/Text)
- _cursor &/cursor]
- (return (&/|list (&&/|meta &type/Text _cursor
- (&&/$proc (&/T <encode-op>) (&/|list =x) (&/|list)))))))
-
- (let [decode-type (&/$AppT &type/Maybe <type>)]
- (defn <decode> [analyse exo-type ?values]
- (|do [:let [(&/$Cons x (&/$Nil)) ?values]
- =x (&&/analyse-1 analyse &type/Text x)
- _ (&type/check exo-type decode-type)
- _cursor &/cursor]
- (return (&/|list (&&/|meta decode-type _cursor
- (&&/$proc (&/T <decode-op>) (&/|list =x) (&/|list)))))))))
-
- ^:private analyse-nat-encode ["nat" "encode"] ^:private analyse-nat-decode ["nat" "decode"] &type/Nat
- ^:private analyse-frac-encode ["frac" "encode"] ^:private analyse-frac-decode ["frac" "decode"] &type/Frac
- )
-
-(do-template [<name> <type> <op>]
- (defn <name> [analyse exo-type ?values]
- (|do [:let [(&/$Nil) ?values]
- _ (&type/check exo-type <type>)
- _cursor &/cursor]
- (return (&/|list (&&/|meta <type> _cursor
- (&&/$proc (&/T <op>) (&/|list) (&/|list)))))))
-
- ^:private analyse-nat-min-value &type/Nat ["nat" "min-value"]
- ^:private analyse-nat-max-value &type/Nat ["nat" "max-value"]
-
- ^:private analyse-frac-min-value &type/Frac ["frac" "min-value"]
- ^:private analyse-frac-max-value &type/Frac ["frac" "max-value"]
- )
-
-(do-template [<name> <from-type> <to-type> <op>]
- (defn <name> [analyse exo-type ?values]
- (|do [:let [(&/$Cons x (&/$Nil)) ?values]
- =x (&&/analyse-1 analyse <from-type> x)
- _ (&type/check exo-type <to-type>)
- _cursor &/cursor]
- (return (&/|list (&&/|meta <to-type> _cursor
- (&&/$proc (&/T <op>) (&/|list =x) (&/|list)))))))
-
- ^:private analyse-nat-to-int &type/Nat &type/Int ["nat" "to-int"]
- ^:private analyse-nat-to-char &type/Nat &type/Char ["nat" "to-char"]
- ^:private analyse-int-to-nat &type/Int &type/Nat ["int" "to-nat"]
- ^:private analyse-char-to-nat &type/Char &type/Nat ["char" "to-nat"]
-
- ^:private analyse-frac-to-real &type/Frac &type/Real ["frac" "to-real"]
- ^:private analyse-real-to-frac &type/Real &type/Frac ["real" "to-frac"]
- )
-
-(defn analyse-host [analyse exo-type compilers category proc ?values]
- (|let [[_ _ compile-class compile-interface] compilers]
- (case category
- "lux"
- (case proc
- "==" (analyse-lux-== analyse exo-type ?values))
-
- "bit"
- (case proc
- "count" (analyse-bit-count analyse exo-type ?values)
- "and" (analyse-bit-and analyse exo-type ?values)
- "or" (analyse-bit-or analyse exo-type ?values)
- "xor" (analyse-bit-xor analyse exo-type ?values)
- "shift-left" (analyse-bit-shift-left analyse exo-type ?values)
- "shift-right" (analyse-bit-shift-right analyse exo-type ?values)
- "unsigned-shift-right" (analyse-bit-unsigned-shift-right analyse exo-type ?values))
-
- "array"
- (case proc
- "new" (analyse-array-new analyse exo-type ?values)
- "get" (analyse-array-get analyse exo-type ?values)
- "put" (analyse-jvm-aastore analyse exo-type ?values)
- "remove" (analyse-array-remove analyse exo-type ?values)
- "size" (analyse-jvm-arraylength analyse exo-type ?values))
-
- "nat"
- (case proc
- "+" (analyse-nat-add analyse exo-type ?values)
- "-" (analyse-nat-sub analyse exo-type ?values)
- "*" (analyse-nat-mul analyse exo-type ?values)
- "/" (analyse-nat-div analyse exo-type ?values)
- "%" (analyse-nat-rem analyse exo-type ?values)
- "=" (analyse-nat-eq analyse exo-type ?values)
- "<" (analyse-nat-lt analyse exo-type ?values)
- "encode" (analyse-nat-encode analyse exo-type ?values)
- "decode" (analyse-nat-decode analyse exo-type ?values)
- "min-value" (analyse-nat-min-value analyse exo-type ?values)
- "max-value" (analyse-nat-max-value analyse exo-type ?values)
- "to-int" (analyse-nat-to-int analyse exo-type ?values)
- "to-char" (analyse-nat-to-char analyse exo-type ?values)
- )
-
- "frac"
- (case proc
- "+" (analyse-frac-add analyse exo-type ?values)
- "-" (analyse-frac-sub analyse exo-type ?values)
- "*" (analyse-frac-mul analyse exo-type ?values)
- "/" (analyse-frac-div analyse exo-type ?values)
- "%" (analyse-frac-rem analyse exo-type ?values)
- "=" (analyse-frac-eq analyse exo-type ?values)
- "<" (analyse-frac-lt analyse exo-type ?values)
- "encode" (analyse-frac-encode analyse exo-type ?values)
- "decode" (analyse-frac-decode analyse exo-type ?values)
- "min-value" (analyse-frac-min-value analyse exo-type ?values)
- "max-value" (analyse-frac-max-value analyse exo-type ?values)
- "to-real" (analyse-frac-to-real analyse exo-type ?values)
- "scale" (analyse-frac-scale analyse exo-type ?values)
- )
-
- "int"
- (case proc
- "to-nat" (analyse-int-to-nat analyse exo-type ?values)
- )
-
- "real"
- (case proc
- "to-frac" (analyse-real-to-frac analyse exo-type ?values)
- )
-
- "char"
- (case proc
- "to-nat" (analyse-char-to-nat analyse exo-type ?values)
- )
-
- "jvm"
- (case proc
- "synchronized" (analyse-jvm-synchronized analyse exo-type ?values)
- "load-class" (analyse-jvm-load-class analyse exo-type ?values)
- "try" (analyse-jvm-try analyse exo-type ?values)
- "throw" (analyse-jvm-throw analyse exo-type ?values)
- "monitorenter" (analyse-jvm-monitorenter analyse exo-type ?values)
- "monitorexit" (analyse-jvm-monitorexit analyse exo-type ?values)
- "null?" (analyse-jvm-null? analyse exo-type ?values)
- "null" (analyse-jvm-null analyse exo-type ?values)
- "anewarray" (analyse-jvm-anewarray analyse exo-type ?values)
- "aaload" (analyse-jvm-aaload analyse exo-type ?values)
- "aastore" (analyse-jvm-aastore analyse exo-type ?values)
- "arraylength" (analyse-jvm-arraylength analyse exo-type ?values)
- "znewarray" (analyse-jvm-znewarray analyse exo-type ?values)
- "bnewarray" (analyse-jvm-bnewarray analyse exo-type ?values)
- "snewarray" (analyse-jvm-snewarray analyse exo-type ?values)
- "inewarray" (analyse-jvm-inewarray analyse exo-type ?values)
- "lnewarray" (analyse-jvm-lnewarray analyse exo-type ?values)
- "fnewarray" (analyse-jvm-fnewarray analyse exo-type ?values)
- "dnewarray" (analyse-jvm-dnewarray analyse exo-type ?values)
- "cnewarray" (analyse-jvm-cnewarray analyse exo-type ?values)
- "iadd" (analyse-jvm-iadd analyse exo-type ?values)
- "isub" (analyse-jvm-isub analyse exo-type ?values)
- "imul" (analyse-jvm-imul analyse exo-type ?values)
- "idiv" (analyse-jvm-idiv analyse exo-type ?values)
- "irem" (analyse-jvm-irem analyse exo-type ?values)
- "ieq" (analyse-jvm-ieq analyse exo-type ?values)
- "ilt" (analyse-jvm-ilt analyse exo-type ?values)
- "igt" (analyse-jvm-igt analyse exo-type ?values)
- "ceq" (analyse-jvm-ceq analyse exo-type ?values)
- "clt" (analyse-jvm-clt analyse exo-type ?values)
- "cgt" (analyse-jvm-cgt analyse exo-type ?values)
- "ladd" (analyse-jvm-ladd analyse exo-type ?values)
- "lsub" (analyse-jvm-lsub analyse exo-type ?values)
- "lmul" (analyse-jvm-lmul analyse exo-type ?values)
- "ldiv" (analyse-jvm-ldiv analyse exo-type ?values)
- "lrem" (analyse-jvm-lrem analyse exo-type ?values)
- "leq" (analyse-jvm-leq analyse exo-type ?values)
- "llt" (analyse-jvm-llt analyse exo-type ?values)
- "lgt" (analyse-jvm-lgt analyse exo-type ?values)
- "fadd" (analyse-jvm-fadd analyse exo-type ?values)
- "fsub" (analyse-jvm-fsub analyse exo-type ?values)
- "fmul" (analyse-jvm-fmul analyse exo-type ?values)
- "fdiv" (analyse-jvm-fdiv analyse exo-type ?values)
- "frem" (analyse-jvm-frem analyse exo-type ?values)
- "feq" (analyse-jvm-feq analyse exo-type ?values)
- "flt" (analyse-jvm-flt analyse exo-type ?values)
- "fgt" (analyse-jvm-fgt analyse exo-type ?values)
- "dadd" (analyse-jvm-dadd analyse exo-type ?values)
- "dsub" (analyse-jvm-dsub analyse exo-type ?values)
- "dmul" (analyse-jvm-dmul analyse exo-type ?values)
- "ddiv" (analyse-jvm-ddiv analyse exo-type ?values)
- "drem" (analyse-jvm-drem analyse exo-type ?values)
- "deq" (analyse-jvm-deq analyse exo-type ?values)
- "dlt" (analyse-jvm-dlt analyse exo-type ?values)
- "dgt" (analyse-jvm-dgt analyse exo-type ?values)
- "iand" (analyse-jvm-iand analyse exo-type ?values)
- "ior" (analyse-jvm-ior analyse exo-type ?values)
- "ixor" (analyse-jvm-ixor analyse exo-type ?values)
- "ishl" (analyse-jvm-ishl analyse exo-type ?values)
- "ishr" (analyse-jvm-ishr analyse exo-type ?values)
- "iushr" (analyse-jvm-iushr analyse exo-type ?values)
- "land" (analyse-jvm-land analyse exo-type ?values)
- "lor" (analyse-jvm-lor analyse exo-type ?values)
- "lxor" (analyse-jvm-lxor analyse exo-type ?values)
- "lshl" (analyse-jvm-lshl analyse exo-type ?values)
- "lshr" (analyse-jvm-lshr analyse exo-type ?values)
- "lushr" (analyse-jvm-lushr analyse exo-type ?values)
- "d2f" (analyse-jvm-d2f analyse exo-type ?values)
- "d2i" (analyse-jvm-d2i analyse exo-type ?values)
- "d2l" (analyse-jvm-d2l analyse exo-type ?values)
- "f2d" (analyse-jvm-f2d analyse exo-type ?values)
- "f2i" (analyse-jvm-f2i analyse exo-type ?values)
- "f2l" (analyse-jvm-f2l analyse exo-type ?values)
- "i2b" (analyse-jvm-i2b analyse exo-type ?values)
- "i2c" (analyse-jvm-i2c analyse exo-type ?values)
- "i2d" (analyse-jvm-i2d analyse exo-type ?values)
- "i2f" (analyse-jvm-i2f analyse exo-type ?values)
- "i2l" (analyse-jvm-i2l analyse exo-type ?values)
- "i2s" (analyse-jvm-i2s analyse exo-type ?values)
- "l2d" (analyse-jvm-l2d analyse exo-type ?values)
- "l2f" (analyse-jvm-l2f analyse exo-type ?values)
- "l2i" (analyse-jvm-l2i analyse exo-type ?values)
- "l2s" (analyse-jvm-l2s analyse exo-type ?values)
- "l2b" (analyse-jvm-l2b analyse exo-type ?values)
- "c2b" (analyse-jvm-c2b analyse exo-type ?values)
- "c2s" (analyse-jvm-c2s analyse exo-type ?values)
- "c2i" (analyse-jvm-c2i analyse exo-type ?values)
- "c2l" (analyse-jvm-c2l analyse exo-type ?values)
- "b2l" (analyse-jvm-b2l analyse exo-type ?values)
- "s2l" (analyse-jvm-s2l analyse exo-type ?values)
- ;; else
- (->> (&/fail-with-loc (str "[Analyser Error] Unknown host procedure: " [category proc]))
- (if-let [[_ _def-code] (re-find #"^interface:(.*)$" proc)]
- (&reader/with-source "interface" _def-code
- (|do [[=gclass-decl =supers =anns =methods] &&a-parser/parse-interface-def]
- (analyse-jvm-interface analyse compile-interface =gclass-decl =supers =anns =methods))))
-
- (if-let [[_ _def-code] (re-find #"^class:(.*)$" proc)]
- (&reader/with-source "class" _def-code
- (|do [[=gclass-decl =super-class =interfaces =inheritance-modifier =anns =fields =methods] &&a-parser/parse-class-def]
- (analyse-jvm-class analyse compile-class =gclass-decl =super-class =interfaces =inheritance-modifier =anns =fields =methods))))
-
- (if-let [[_ _def-code] (re-find #"^anon-class:(.*)$" proc)]
- (&reader/with-source "anon-class" _def-code
- (|do [[=super-class =interfaces =ctor-args =methods] &&a-parser/parse-anon-class-def]
- (analyse-jvm-anon-class analyse compile-class exo-type =super-class =interfaces =ctor-args =methods))))
-
- (if-let [[_ _class] (re-find #"^instanceof:([^:]+)$" proc)]
- (analyse-jvm-instanceof analyse exo-type _class ?values))
-
- (if-let [[_ _class _arg-classes] (re-find #"^new:([^:]+):([^:]*)$" proc)]
- (analyse-jvm-new analyse exo-type _class (if (= "" _arg-classes) (&/|list) (&/->list (string/split _arg-classes #","))) ?values))
-
- (if-let [[_ _class _method _arg-classes] (re-find #"^invokestatic:([^:]+):([^:]+):([^:]*)$" proc)]
- (analyse-jvm-invokestatic analyse exo-type _class _method (if (= "" _arg-classes) (&/|list) (&/->list (string/split _arg-classes #","))) ?values))
-
- (if-let [[_ _class _method _arg-classes] (re-find #"^invokeinterface:([^:]+):([^:]+):([^:]*)$" proc)]
- (analyse-jvm-invokeinterface analyse exo-type _class _method (if (= "" _arg-classes) (&/|list) (&/->list (string/split _arg-classes #","))) ?values))
-
- (if-let [[_ _class _method _arg-classes] (re-find #"^invokevirtual:([^:]+):([^:]+):([^:]*)$" proc)]
- (analyse-jvm-invokevirtual analyse exo-type _class _method (if (= "" _arg-classes) (&/|list) (&/->list (string/split _arg-classes #","))) ?values))
-
- (if-let [[_ _class _method _arg-classes] (re-find #"^invokespecial:([^:]+):([^:]+):([^:]*)$" proc)]
- (analyse-jvm-invokespecial analyse exo-type _class _method (if (= "" _arg-classes) (&/|list) (&/->list (string/split _arg-classes #","))) ?values))
-
- (if-let [[_ _class _field] (re-find #"^getstatic:([^:]+):([^:]+)$" proc)]
- (analyse-jvm-getstatic analyse exo-type _class _field ?values))
-
- (if-let [[_ _class _field] (re-find #"^getfield:([^:]+):([^:]+)$" proc)]
- (analyse-jvm-getfield analyse exo-type _class _field ?values))
-
- (if-let [[_ _class _field] (re-find #"^putstatic:([^:]+):([^:]+)$" proc)]
- (analyse-jvm-putstatic analyse exo-type _class _field ?values))
-
- (if-let [[_ _class _field] (re-find #"^putfield:([^:]+):([^:]+)$" proc)]
- (analyse-jvm-putfield analyse exo-type _class _field ?values))))
-
- ;; else
- (&/fail-with-loc (str "[Analyser Error] Unknown host procedure: " [category proc])))))
diff --git a/src/lux/analyser/lambda.clj b/src/lux/analyser/lambda.clj
deleted file mode 100644
index b47b803d0..000000000
--- a/src/lux/analyser/lambda.clj
+++ /dev/null
@@ -1,33 +0,0 @@
-;; Copyright (c) Eduardo Julian. All rights reserved.
-;; This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0.
-;; If a copy of the MPL was not distributed with this file,
-;; You can obtain one at http://mozilla.org/MPL/2.0/.
-
-(ns lux.analyser.lambda
- (:require clojure.core.match
- clojure.core.match.array
- (lux [base :as & :refer [|let |do return fail |case]]
- [host :as &host])
- (lux.analyser [base :as &&]
- [env :as &env])))
-
-;; [Resource]
-(defn with-lambda [self self-type arg arg-type body]
- (&/with-closure
- (|do [scope-name &/get-scope-name]
- (&env/with-local self self-type
- (&env/with-local arg arg-type
- (|do [=return body
- =captured &env/captured-vars]
- (return (&/T [scope-name =captured =return]))))))))
-
-(defn close-over [scope name register frame]
- (|let [[[register-type register-cursor] _] register
- register* (&&/|meta register-type register-cursor
- (&&/$captured (&/T [scope
- (->> frame (&/get$ &/$closure) (&/get$ &/$counter))
- register])))]
- (&/T [register* (&/update$ &/$closure #(->> %
- (&/update$ &/$counter inc)
- (&/update$ &/$mappings (fn [mps] (&/|put name register* mps))))
- frame)])))
diff --git a/src/lux/analyser/lux.clj b/src/lux/analyser/lux.clj
deleted file mode 100644
index 1d46c2b60..000000000
--- a/src/lux/analyser/lux.clj
+++ /dev/null
@@ -1,736 +0,0 @@
-;; Copyright (c) Eduardo Julian. All rights reserved.
-;; This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0.
-;; If a copy of the MPL was not distributed with this file,
-;; You can obtain one at http://mozilla.org/MPL/2.0/.
-
-(ns lux.analyser.lux
- (:require (clojure [template :refer [do-template]]
- [set :as set])
- clojure.core.match
- clojure.core.match.array
- (lux [base :as & :refer [|do return return* fail fail* |let |list |case]]
- [parser :as &parser]
- [type :as &type]
- [host :as &host])
- (lux.analyser [base :as &&]
- [lambda :as &&lambda]
- [case :as &&case]
- [env :as &&env]
- [module :as &&module]
- [record :as &&record]
- [meta :as &&meta])))
-
-;; [Utils]
-;; TODO: Walk the type to set up the bound-type, instead of doing a
-;; rough calculation like this one.
-(defn ^:private count-univq [type]
- "(-> Type Int)"
- (|case type
- (&/$UnivQ env type*)
- (inc (count-univq type*))
-
- _
- 0))
-
-;; TODO: This technique won't work if the body of the type contains
-;; nested quantifications that cannot be directly counted.
-(defn ^:private next-bound-type [type]
- "(-> Type Type)"
- (&/$BoundT (->> (count-univq type) (* 2) (+ 1))))
-
-(defn ^:private embed-inferred-input [input output]
- "(-> Type Type Type)"
- (|case output
- (&/$UnivQ env output*)
- (&/$UnivQ env (embed-inferred-input input output*))
-
- _
- (&/$LambdaT input output)))
-
-;; [Exports]
-(defn analyse-unit [analyse ?exo-type]
- (|do [_cursor &/cursor
- _ (&type/check ?exo-type &/$UnitT)]
- (return (&/|list (&&/|meta ?exo-type _cursor
- (&&/$tuple (&/|list)))))))
-
-(defn analyse-tuple [analyse ?exo-type ?elems]
- (|case ?elems
- (&/$Nil)
- (analyse-unit analyse (|case ?exo-type
- (&/$Left exo-type) exo-type
- (&/$Right exo-type) exo-type))
-
- (&/$Cons ?elem (&/$Nil))
- (analyse (|case ?exo-type
- (&/$Left exo-type) exo-type
- (&/$Right exo-type) exo-type)
- ?elem)
-
- _
- (|case ?exo-type
- (&/$Left exo-type)
- (|do [exo-type* (&type/actual-type exo-type)]
- (|case exo-type*
- (&/$UnivQ _)
- (&type/with-var
- (fn [$var]
- (|do [exo-type** (&type/apply-type exo-type* $var)
- [[tuple-type tuple-cursor] tuple-analysis] (&&/cap-1 (analyse-tuple analyse (&/$Left exo-type**) ?elems))
- =var (&type/resolve-type $var)
- inferred-type (|case =var
- (&/$VarT iid)
- (|do [:let [=var* (next-bound-type tuple-type)]
- _ (&type/set-var iid =var*)
- tuple-type* (&type/clean $var tuple-type)]
- (return (&/$UnivQ &/$Nil tuple-type*)))
-
- _
- (&type/clean $var tuple-type))]
- (return (&/|list (&&/|meta inferred-type tuple-cursor
- tuple-analysis))))))
-
- _
- (analyse-tuple analyse (&/$Right exo-type*) ?elems)))
-
- (&/$Right exo-type)
- (|do [unknown? (&type/unknown? exo-type)]
- (if unknown?
- (|do [=elems (&/map% #(|do [=analysis (&&/analyse-1+ analyse %)]
- (return =analysis))
- ?elems)
- _ (&type/check exo-type (|case (->> (&/|map &&/expr-type* =elems) (&/|reverse))
- (&/$Cons last prevs)
- (&/fold (fn [right left] (&/$ProdT left right))
- last prevs)))
- _cursor &/cursor]
- (return (&/|list (&&/|meta exo-type _cursor
- (&&/$tuple =elems)
- ))))
- (|do [exo-type* (&type/actual-type exo-type)]
- (&/with-attempt
- (|case exo-type*
- (&/$ProdT _)
- (|let [num-elems (&/|length ?elems)
- [_shorter _tuple-types] (&type/tuple-types-for num-elems exo-type*)]
- (if (= num-elems _shorter)
- (|do [=elems (&/map2% (fn [elem-t elem]
- (&&/analyse-1 analyse elem-t elem))
- _tuple-types
- ?elems)
- _cursor &/cursor]
- (return (&/|list (&&/|meta exo-type _cursor
- (&&/$tuple =elems)
- ))))
- (|do [=direct-elems (&/map2% (fn [elem-t elem] (&&/analyse-1 analyse elem-t elem))
- (&/|take (dec _shorter) _tuple-types)
- (&/|take (dec _shorter) ?elems))
- =indirect-elems (analyse-tuple analyse
- (&/$Right (&/|last _tuple-types))
- (&/|drop (dec _shorter) ?elems))
- _cursor &/cursor]
- (return (&/|list (&&/|meta exo-type _cursor
- (&&/$tuple (&/|++ =direct-elems =indirect-elems))
- ))))))
-
- (&/$ExQ _)
- (&type/with-var
- (fn [$var]
- (|do [exo-type** (&type/apply-type exo-type* $var)
- [[tuple-type tuple-cursor] tuple-analysis] (&&/cap-1 (analyse-tuple analyse (&/$Right exo-type**) ?elems))
- =tuple-analysis (&&/clean-analysis $var (&&/|meta exo-type tuple-cursor
- tuple-analysis))]
- (return (&/|list =tuple-analysis)))))
-
- (&/$UnivQ _)
- (|do [$var &type/existential
- :let [(&/$ExT $var-id) $var]
- exo-type** (&type/apply-type exo-type* $var)
- [[tuple-type tuple-cursor] tuple-analysis] (&/with-scope-type-var $var-id
- (&&/cap-1 (analyse-tuple analyse (&/$Right exo-type**) ?elems)))]
- (return (&/|list (&&/|meta exo-type tuple-cursor
- tuple-analysis))))
-
- _
- (&/fail-with-loc (str "[Analyser Error] Tuples require tuple-types: " (&type/show-type exo-type*)))
- )
- (fn [err]
- (&/fail-with-loc (str err "\n" "[Analyser Error] Tuples require tuple-types: " (&type/show-type exo-type)))))))))
- ))
-
-(defn ^:private analyse-variant-body [analyse exo-type ?values]
- (|do [_cursor &/cursor
- output (|case ?values
- (&/$Nil)
- (analyse-unit analyse exo-type)
-
- (&/$Cons ?value (&/$Nil))
- (analyse exo-type ?value)
-
- _
- (analyse-tuple analyse (&/$Right exo-type) ?values))]
- (|case output
- (&/$Cons x (&/$Nil))
- (return x)
-
- _
- (&/fail-with-loc "[Analyser Error] Can't expand to other than 1 element."))))
-
-(defn analyse-variant [analyse ?exo-type idx is-last? ?values]
- (|case ?exo-type
- (&/$Left exo-type)
- (|do [exo-type* (&type/actual-type exo-type)]
- (|case exo-type*
- (&/$UnivQ _)
- (&type/with-var
- (fn [$var]
- (|do [exo-type** (&type/apply-type exo-type* $var)
- [[variant-type variant-cursor] variant-analysis] (&&/cap-1 (analyse-variant analyse (&/$Left exo-type**) idx is-last? ?values))
- =var (&type/resolve-type $var)
- inferred-type (|case =var
- (&/$VarT iid)
- (|do [:let [=var* (next-bound-type variant-type)]
- _ (&type/set-var iid =var*)
- variant-type* (&type/clean $var variant-type)]
- (return (&/$UnivQ &/$Nil variant-type*)))
-
- _
- (&type/clean $var variant-type))]
- (return (&/|list (&&/|meta inferred-type variant-cursor
- variant-analysis))))))
-
- _
- (analyse-variant analyse (&/$Right exo-type*) idx is-last? ?values)))
-
- (&/$Right exo-type)
- (|do [exo-type* (|case exo-type
- (&/$VarT ?id)
- (&/try-all% (&/|list (|do [exo-type* (&type/deref ?id)]
- (&type/actual-type exo-type*))
- (|do [_ (&type/set-var ?id &type/Type)]
- (&type/actual-type &type/Type))))
-
- _
- (&type/actual-type exo-type))]
- (&/with-attempt
- (|case exo-type*
- (&/$SumT _)
- (|do [vtype (&type/sum-at idx exo-type*)
- :let [num-variant-types (&/|length (&type/flatten-sum exo-type*))
- is-last?* (if (nil? is-last?)
- (= idx (dec num-variant-types))
- is-last?)]
- =value (analyse-variant-body analyse vtype ?values)
- _cursor &/cursor]
- (if (= 1 num-variant-types)
- (return (&/|list =value))
- (return (&/|list (&&/|meta exo-type _cursor (&&/$variant idx is-last?* =value))))
- ))
-
- (&/$UnivQ _)
- (|do [$var &type/existential
- exo-type** (&type/apply-type exo-type* $var)]
- (analyse-variant analyse (&/$Right exo-type**) idx is-last? ?values))
-
- (&/$ExQ _)
- (&type/with-var
- (fn [$var]
- (|do [exo-type** (&type/apply-type exo-type* $var)
- =exprs (analyse-variant analyse (&/$Right exo-type**) idx is-last? ?values)]
- (&/map% (partial &&/clean-analysis $var) =exprs))))
-
- _
- (&/fail-with-loc (str "[Analyser Error] Can't create variant if the expected type is " (&type/show-type exo-type*) " " idx " " (->> ?values (&/|map &/show-ast) (&/|interpose " ") (&/fold str "")))))
- (fn [err]
- (|case exo-type
- (&/$VarT ?id)
- (|do [=exo-type (&type/deref ?id)]
- (&/fail-with-loc (str err "\n" "[Analyser Error] Can't create variant if the expected type is " (&type/show-type =exo-type) " " idx " " (->> ?values (&/|map &/show-ast) (&/|interpose " ") (&/fold str "")))))
-
- _
- (&/fail-with-loc (str err "\n" "[Analyser Error] Can't create variant if the expected type is " (&type/show-type exo-type) " " idx " " (->> ?values (&/|map &/show-ast) (&/|interpose " ") (&/fold str "")))))))
- )))
-
-(defn analyse-record [analyse exo-type ?elems]
- (|do [[rec-members rec-type] (&&record/order-record ?elems)]
- (|case exo-type
- (&/$VarT id)
- (|do [? (&type/bound? id)]
- (if ?
- (analyse-tuple analyse (&/$Right exo-type) rec-members)
- (|do [[[tuple-type tuple-cursor] tuple-analysis] (&&/cap-1 (analyse-tuple analyse (&/$Left rec-type) rec-members))
- _ (&type/check exo-type tuple-type)]
- (return (&/|list (&&/|meta exo-type tuple-cursor
- tuple-analysis))))))
-
- _
- (analyse-tuple analyse (&/$Right exo-type) rec-members)
- )))
-
-(defn ^:private analyse-global [analyse exo-type module name]
- (|do [[[r-module r-name] [endo-type ?meta ?value]] (&&module/find-def module name)
- ;; This is a small shortcut to optimize analysis of typing code.
- _ (if (and (clojure.lang.Util/identical &type/Type endo-type)
- (clojure.lang.Util/identical &type/Type exo-type))
- (return nil)
- (&type/check exo-type endo-type))
- _cursor &/cursor]
- (return (&/|list (&&/|meta endo-type _cursor
- (&&/$var (&/$Global (&/T [r-module r-name]))))))))
-
-(defn ^:private analyse-local [analyse exo-type name]
- (fn [state]
- (|let [stack (&/get$ &/$scopes state)
- no-binding? #(and (->> % (&/get$ &/$locals) (&/get$ &/$mappings) (&/|contains? name) not)
- (->> % (&/get$ &/$closure) (&/get$ &/$mappings) (&/|contains? name) not))
- [inner outer] (&/|split-with no-binding? stack)]
- (|case outer
- (&/$Nil)
- (&/run-state (|do [module-name &/get-module-name]
- (analyse-global analyse exo-type module-name name))
- state)
-
- (&/$Cons ?genv (&/$Nil))
- (if-let [global (->> ?genv (&/get$ &/$locals) (&/get$ &/$mappings) (&/|get name))]
- (|case global
- [(&/$Global ?module* name*) _]
- (&/run-state (analyse-global analyse exo-type ?module* name*)
- state)
-
- _
- (fail* "[Analyser Error] Can't have anything other than a global def in the global environment."))
- (fail* (str "[Analyser Error] Unknown global definition: " name)))
-
- (&/$Cons bottom-outer _)
- (|let [scopes (&/|map #(&/get$ &/$name %) (&/|reverse inner))
- [=local inner*] (&/fold2 (fn [register+new-inner frame in-scope]
- (|let [[register new-inner] register+new-inner
- [register* frame*] (&&lambda/close-over in-scope name register frame)]
- (&/T [register* (&/$Cons frame* new-inner)])))
- (&/T [(or (->> bottom-outer (&/get$ &/$locals) (&/get$ &/$mappings) (&/|get name))
- (->> bottom-outer (&/get$ &/$closure) (&/get$ &/$mappings) (&/|get name)))
- &/$Nil])
- (&/|reverse inner) scopes)]
- ((|do [_ (&type/check exo-type (&&/expr-type* =local))]
- (return (&/|list =local)))
- (&/set$ &/$scopes (&/|++ inner* outer) state)))
- ))))
-
-(defn analyse-symbol [analyse exo-type ident]
- (|do [:let [[?module ?name] ident]]
- (if (= "" ?module)
- (analyse-local analyse exo-type ?name)
- (analyse-global analyse exo-type ?module ?name))
- ))
-
-(defn ^:private analyse-apply* [analyse exo-type fun-type ?args]
- (|case ?args
- (&/$Nil)
- (|do [_ (&type/check exo-type fun-type)]
- (return (&/T [fun-type &/$Nil])))
-
- (&/$Cons ?arg ?args*)
- (|do [?fun-type* (&type/actual-type fun-type)]
- (&/with-attempt
- (|case ?fun-type*
- (&/$UnivQ _)
- (&type/with-var
- (fn [$var]
- (|do [type* (&type/apply-type ?fun-type* $var)
- [=output-t =args] (analyse-apply* analyse exo-type type* ?args)
- ==args (&/map% (partial &&/clean-analysis $var) =args)]
- (|case $var
- (&/$VarT ?id)
- (|do [? (&type/bound? ?id)
- type** (if ?
- (&type/clean $var =output-t)
- (|do [_ (&type/set-var ?id (next-bound-type =output-t))
- cleaned-output* (&type/clean $var =output-t)
- :let [cleaned-output (&/$UnivQ &/$Nil cleaned-output*)]]
- (return cleaned-output)))
- _ (&type/clean $var exo-type)]
- (return (&/T [type** ==args])))
- ))))
-
- (&/$ExQ _)
- (|do [$var &type/existential
- type* (&type/apply-type ?fun-type* $var)]
- (analyse-apply* analyse exo-type type* ?args))
-
- (&/$LambdaT ?input-t ?output-t)
- (|do [[=output-t =args] (analyse-apply* analyse exo-type ?output-t ?args*)
- =arg (&/with-attempt
- (&&/analyse-1 analyse ?input-t ?arg)
- (fn [err]
- (&/fail-with-loc (str err "\n" "[Analyser Error] Function expected: " (&type/show-type ?input-t)))))]
- (return (&/T [=output-t (&/$Cons =arg =args)])))
-
- _
- (&/fail-with-loc (str "[Analyser Error] Can't apply a non-function: " (&type/show-type ?fun-type*))))
- (fn [err]
- (&/fail-with-loc (str err "\n" "[Analyser Error] Can't apply function " (&type/show-type fun-type) " to args: " (->> ?args (&/|map &/show-ast) (&/|interpose " ") (&/fold str "")))))))
- ))
-
-(defn ^:private do-analyse-apply [analyse exo-type =fn ?args]
- (|do [:let [[[=fn-type =fn-cursor] =fn-form] =fn]
- [=output-t =args] (analyse-apply* analyse exo-type =fn-type ?args)]
- (return (&/|list (&&/|meta =output-t =fn-cursor
- (&&/$apply =fn =args)
- )))))
-
-(defn analyse-apply [analyse cursor exo-type =fn ?args]
- (|do [loader &/loader
- :let [[[=fn-type =fn-cursor] =fn-form] =fn]]
- (|case =fn-form
- (&&/$var (&/$Global ?module ?name))
- (|do [[real-name [?type ?meta ?value]] (&&module/find-def ?module ?name)]
- (|case (&&meta/meta-get &&meta/macro?-tag ?meta)
- (&/$Some _)
- (|do [macro-expansion (fn [state]
- (|case (-> ?value (.apply ?args) (.apply state))
- (&/$Right state* output)
- (&/$Right (&/T [state* output]))
-
- (&/$Left error)
- ((&/fail-with-loc error) state)))
- module-name &/get-module-name
- ;; :let [[r-prefix r-name] real-name
- ;; _ (when (or (= "actor:" r-name)
- ;; ;; (= "|Codec@Json|" r-name)
- ;; ;; (= "|Codec@Json//encode|" r-name)
- ;; ;; (= "|Codec@Json//decode|" r-name)
- ;; ;; (= "derived:" r-name)
- ;; )
- ;; (->> (&/|map &/show-ast macro-expansion)
- ;; (&/|interpose "\n")
- ;; (&/fold str "")
- ;; (prn (&/ident->text real-name) module-name)))
- ;; ]
- ]
- (&/flat-map% (partial analyse exo-type) macro-expansion))
-
- _
- (do-analyse-apply analyse exo-type =fn ?args)))
-
- _
- (do-analyse-apply analyse exo-type =fn ?args))
- ))
-
-(defn analyse-case [analyse exo-type ?value ?branches]
- (|do [:let [num-branches (&/|length ?branches)]
- _ (&/assert! (> num-branches 0) "[Analyser Error] Can't have empty branches in \"case\" expression.")
- _ (&/assert! (even? num-branches) "[Analyser Error] Unbalanced branches in \"case\" expression.")
- =value (&&/analyse-1+ analyse ?value)
- :let [var?? (|case =value
- [_ (&&/$var =var-kind)]
- (&/$Some =value)
-
- _
- &/$None)]
- =match (&&case/analyse-branches analyse exo-type var?? (&&/expr-type* =value) (&/|as-pairs ?branches))
- _cursor &/cursor]
- (return (&/|list (&&/|meta exo-type _cursor
- (&&/$case =value =match)
- )))))
-
-(defn ^:private unravel-inf-appt [type]
- (|case type
- (&/$AppT =input+ (&/$VarT _inf-var))
- (&/$Cons _inf-var (unravel-inf-appt =input+))
-
- _
- (&/|list)))
-
-(defn ^:private clean-func-inference [$input $output =input =func]
- (|case =input
- (&/$VarT iid)
- (|do [:let [=input* (next-bound-type =func)]
- _ (&type/set-var iid =input*)
- =func* (&type/clean $input =func)
- =func** (&type/clean $output =func*)]
- (return (&/$UnivQ &/$Nil =func**)))
-
- (&/$AppT =input+ (&/$VarT _inf-var))
- (&/fold% (fn [_func _inf-var]
- (|do [:let [$inf-var (&/$VarT _inf-var)]
- =inf-var (&type/resolve-type $inf-var)
- _func* (clean-func-inference $inf-var $output =inf-var _func)
- _ (&type/delete-var _inf-var)]
- (return _func*)))
- =func
- (unravel-inf-appt =input))
-
- (&/$ProdT _ _)
- (&/fold% (fn [_func _inf-var]
- (|do [:let [$inf-var (&/$VarT _inf-var)]
- =inf-var (&type/resolve-type $inf-var)
- _func* (clean-func-inference $inf-var $output =inf-var _func)
- _ (&type/delete-var _inf-var)]
- (return _func*)))
- =func
- (&/|reverse (&type/flatten-prod =input)))
-
- _
- (|do [=func* (&type/clean $input =func)
- =func** (&type/clean $output =func*)]
- (return =func**))))
-
-(defn analyse-lambda* [analyse exo-type ?self ?arg ?body]
- (|case exo-type
- (&/$VarT id)
- (|do [? (&type/bound? id)]
- (if ?
- (|do [exo-type* (&type/deref id)]
- (analyse-lambda* analyse exo-type* ?self ?arg ?body))
- ;; Inference
- (&type/with-var
- (fn [$input]
- (&type/with-var
- (fn [$output]
- (|do [[[lambda-type lambda-cursor] lambda-analysis] (analyse-lambda* analyse (&/$LambdaT $input $output) ?self ?arg ?body)
- =input (&type/resolve-type $input)
- =output (&type/resolve-type $output)
- inferred-type (clean-func-inference $input $output =input (embed-inferred-input =input =output))
- _ (&type/check exo-type inferred-type)]
- (return (&&/|meta inferred-type lambda-cursor
- lambda-analysis)))
- ))))))
-
- _
- (&/with-attempt
- (|do [exo-type* (&type/actual-type exo-type)]
- (|case exo-type*
- (&/$UnivQ _)
- (|do [$var &type/existential
- :let [(&/$ExT $var-id) $var]
- exo-type** (&type/apply-type exo-type* $var)]
- (&/with-scope-type-var $var-id
- (analyse-lambda* analyse exo-type** ?self ?arg ?body)))
-
- (&/$ExQ _)
- (&type/with-var
- (fn [$var]
- (|do [exo-type** (&type/apply-type exo-type* $var)
- =expr (analyse-lambda* analyse exo-type** ?self ?arg ?body)]
- (&&/clean-analysis $var =expr))))
-
- (&/$LambdaT ?arg-t ?return-t)
- (|do [[=scope =captured =body] (&&lambda/with-lambda ?self exo-type*
- ?arg ?arg-t
- (&&/analyse-1 analyse ?return-t ?body))
- _cursor &/cursor
- register-offset &&env/next-local-idx]
- (return (&&/|meta exo-type* _cursor
- (&&/$lambda register-offset =scope =captured =body))))
-
- _
- (fail "")))
- (fn [err]
- (&/fail-with-loc (str err "\n" "[Analyser Error] Functions require function types: " (&type/show-type exo-type)))))
- ))
-
-(defn analyse-lambda** [analyse exo-type ?self ?arg ?body]
- (|case exo-type
- (&/$UnivQ _)
- (|do [$var &type/existential
- :let [(&/$ExT $var-id) $var]
- exo-type* (&type/apply-type exo-type $var)
- [_ _expr] (&/with-scope-type-var $var-id
- (analyse-lambda** analyse exo-type* ?self ?arg ?body))
- _cursor &/cursor]
- (return (&&/|meta exo-type _cursor _expr)))
-
- (&/$VarT id)
- (|do [? (&type/bound? id)]
- (if ?
- (|do [exo-type* (&type/actual-type exo-type)]
- (analyse-lambda* analyse exo-type* ?self ?arg ?body))
- ;; Inference
- (analyse-lambda* analyse exo-type ?self ?arg ?body)))
-
- _
- (|do [exo-type* (&type/actual-type exo-type)]
- (analyse-lambda* analyse exo-type* ?self ?arg ?body))
- ))
-
-(defn analyse-lambda [analyse exo-type ?self ?arg ?body]
- (|do [output (&/with-no-catches
- (analyse-lambda** analyse exo-type ?self ?arg ?body))]
- (return (&/|list output))))
-
-(defn analyse-def [analyse optimize eval! compile-def ?name ?value ?meta]
- (|do [_ &/ensure-statement
- module-name &/get-module-name
- ? (&&module/defined? module-name ?name)]
- (if ?
- (&/fail-with-loc (str "[Analyser Error] Can't redefine " (str module-name ";" ?name)))
- (|do [=value (&/without-repl-closure
- (&/with-scope ?name
- (&&/analyse-1+ analyse ?value)))
- =meta (&&/analyse-1 analyse &type/Anns ?meta)
- ==meta (eval! (optimize =meta))
- _ (&&module/test-type module-name ?name ==meta (&&/expr-type* =value))
- _ (&&module/test-macro module-name ?name ==meta (&&/expr-type* =value))
- _ (compile-def ?name (optimize =value) ==meta)]
- (return &/$Nil))
- )))
-
-(defn ^:private merge-hosts
- "(-> Host Host Host)"
- [new old]
- (|let [merged-module-states (&/fold (fn [total m-state]
- (|let [[_name _state] m-state]
- (|case _state
- (&/$Cached)
- (&/|put _name _state total)
-
- (&/$Compiled)
- (&/|put _name _state total)
-
- _
- total)))
- (&/get$ &/$module-states old)
- (&/get$ &/$module-states new))]
- (->> old
- (&/set$ &/$module-states merged-module-states))))
-
-(defn ^:private merge-modules
- "(-> Text Module Module Module)"
- [current-module new old]
- (&/fold (fn [total* entry]
- (|let [[_name _module] entry]
- (if (or (= current-module _name)
- (->> _module
- (&/get$ &&module/$defs)
- &/|length
- (= 0)))
- ;; Don't modify the entry of the current module, to
- ;; avoid overwritting it's data in improper ways.
- ;; Since it's assumed the "original" old module
- ;; contains all the proper own-module information.
- total*
- (&/|put _name _module total*))))
- old new))
-
-(defn ^:private merge-compilers
- "(-> Text Compiler Compiler Compiler)"
- [current-module new old]
- (->> old
- (&/set$ &/$modules (merge-modules current-module
- (&/get$ &/$modules new)
- (&/get$ &/$modules old)))
- (&/set$ &/$seed (max (&/get$ &/$seed new)
- (&/get$ &/$seed old)))
- (&/set$ &/$host (merge-hosts (&/get$ &/$host new)
- (&/get$ &/$host old)))))
-
-(def ^:private get-compiler
- (fn [compiler]
- (return* compiler compiler)))
-
-(defn ^:private set-compiler [compiler*]
- (fn [_]
- (return* compiler* compiler*)))
-
-(defn analyse-module [analyse optimize eval! compile-module ?meta]
- (|do [_ &/ensure-statement
- =anns (&&/analyse-1 analyse &type/Anns ?meta)
- ==anns (eval! (optimize =anns))
- module-name &/get-module-name
- _ (&&module/set-anns ==anns module-name)
- _imports (&&module/fetch-imports ==anns)
- current-module &/get-module-name
- ;; =asyncs (&/map% (fn [_import]
- ;; (|let [[path alias] _import]
- ;; (&/without-repl
- ;; (&/save-module
- ;; (|do [_ (if (= current-module path)
- ;; (&/fail-with-loc (str "[Analyser Error] Module can't import itself: " path))
- ;; (return nil))
- ;; already-compiled? (&&module/exists? path)
- ;; active? (&/active-module? path)
- ;; _ (&/assert! (not active?)
- ;; (str "[Analyser Error] Can't import a module that is mid-compilation: " path " @ " current-module))
- ;; _ (&&module/add-import path)
- ;; ?async (if (not already-compiled?)
- ;; (compile-module path)
- ;; (|do [_compiler get-compiler]
- ;; (return (doto (promise)
- ;; (deliver (&/$Right _compiler))))))
- ;; _ (if (= "" alias)
- ;; (return nil)
- ;; (&&module/alias current-module alias path))]
- ;; (return ?async))))))
- ;; _imports)
- ;; _compiler get-compiler
- ;; ;; Some type-vars in the typing environment stay in
- ;; ;; the environment forever, making type-checking slower.
- ;; ;; The merging process for compilers more-or-less "fixes" the
- ;; ;; problem by resetting the typing enviroment, but ideally
- ;; ;; those type-vars shouldn't survive in the first place.
- ;; ;; TODO: MUST FIX
- ;; _ (&/fold% (fn [compiler _async]
- ;; (|case @_async
- ;; (&/$Right _new-compiler)
- ;; (set-compiler (merge-compilers current-module _new-compiler compiler))
-
- ;; (&/$Left ?error)
- ;; (fail ?error)))
- ;; _compiler
- ;; =asyncs)
- ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
- _ (&/map% (fn [_import]
- (|let [[path alias] _import]
- (&/without-repl
- (&/save-module
- (|do [_ (if (= current-module path)
- (&/fail-with-loc (str "[Analyser Error] Module can't import itself: " path))
- (return nil))
- already-compiled? (&&module/exists? path)
- active? (&/active-module? path)
- _ (&/assert! (not active?)
- (str "[Analyser Error] Can't import a module that is mid-compilation: " path " @ " current-module))
- _ (&&module/add-import path)
- _ (if (not already-compiled?)
- (compile-module path)
- (return nil))
- _ (if (= "" alias)
- (return nil)
- (&&module/alias current-module alias path))]
- (return nil))))))
- _imports)]
- (return &/$Nil)))
-
-(defn ^:private coerce [new-type analysis]
- "(-> Type Analysis Analysis)"
- (|let [[[_type _cursor] _analysis] analysis]
- (&&/|meta new-type _cursor
- _analysis)))
-
-(defn analyse-ann [analyse eval! exo-type ?type ?value]
- (|do [=type (&&/analyse-1 analyse &type/Type ?type)
- ==type (eval! =type)
- _ (&type/check exo-type ==type)
- =value (&/with-expected-type ==type
- (&&/analyse-1 analyse ==type ?value))
- _cursor &/cursor]
- (return (&/|list (&&/|meta ==type _cursor
- (&&/$ann =value =type)
- )))))
-
-(defn analyse-coerce [analyse eval! exo-type ?type ?value]
- (|do [=type (&&/analyse-1 analyse &type/Type ?type)
- ==type (eval! =type)
- _ (&type/check exo-type ==type)
- =value (&&/analyse-1+ analyse ?value)]
- (return (&/|list (coerce ==type =value)))))
-
-(let [input-type (&/$AppT &type/List &type/Text)
- output-type (&/$AppT &type/IO &/$UnitT)]
- (defn analyse-program [analyse optimize compile-program ?args ?body]
- (|do [_ &/ensure-statement
- =body (&/with-scope ""
- (&&env/with-local ?args input-type
- (&&/analyse-1 analyse output-type ?body)))
- _ (compile-program (optimize =body))]
- (return &/$Nil))))
diff --git a/src/lux/analyser/meta.clj b/src/lux/analyser/meta.clj
deleted file mode 100644
index 831386f47..000000000
--- a/src/lux/analyser/meta.clj
+++ /dev/null
@@ -1,46 +0,0 @@
-;; Copyright (c) Eduardo Julian. All rights reserved.
-;; This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0.
-;; If a copy of the MPL was not distributed with this file,
-;; You can obtain one at http://mozilla.org/MPL/2.0/.
-
-(ns lux.analyser.meta
- (:require (clojure [template :refer [do-template]])
- clojure.core.match
- clojure.core.match.array
- (lux [base :as & :refer [|let |do return return* fail fail* |case]])))
-
-;; [Utils]
-(defn ^:private ident= [x y]
- (|let [[px nx] x
- [py ny] y]
- (and (= px py)
- (= nx ny))))
-
-(def ^:private tag-prefix "lux")
-
-;; [Values]
-(defn meta-get [ident dict]
- "(-> Ident Anns (Maybe Ann-Value))"
- (|case dict
- (&/$Cons [k v] dict*)
- (if (ident= k ident)
- (&/$Some v)
- (meta-get ident dict*))
-
- (&/$Nil)
- &/$None
-
- _
- (assert false (prn-str (&/adt->text ident)
- (&/adt->text dict)))))
-
-(do-template [<name> <tag-name>]
- (def <name> (&/T [tag-prefix <tag-name>]))
-
- type?-tag "type?"
- alias-tag "alias"
- macro?-tag "macro?"
- export?-tag "export?"
- tags-tag "tags"
- imports-tag "imports"
- )
diff --git a/src/lux/analyser/module.clj b/src/lux/analyser/module.clj
deleted file mode 100644
index 62948bf0d..000000000
--- a/src/lux/analyser/module.clj
+++ /dev/null
@@ -1,403 +0,0 @@
-;; Copyright (c) Eduardo Julian. All rights reserved.
-;; This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0.
-;; If a copy of the MPL was not distributed with this file,
-;; You can obtain one at http://mozilla.org/MPL/2.0/.
-
-(ns lux.analyser.module
- (:refer-clojure :exclude [alias])
- (:require (clojure [string :as string]
- [template :refer [do-template]])
- clojure.core.match
- clojure.core.match.array
- (lux [base :as & :refer [deftuple |let |do return return* |case]]
- [type :as &type]
- [host :as &host])
- [lux.host.generics :as &host-generics]
- (lux.analyser [meta :as &meta])))
-
-;; [Utils]
-(deftuple
- ["module-hash"
- "module-aliases"
- "defs"
- "imports"
- "tags"
- "types"
- "module-anns"])
-
-(defn ^:private new-module [hash]
- (&/T [;; lux;module-hash
- hash
- ;; "lux;module-aliases"
- (&/|table)
- ;; "lux;defs"
- (&/|table)
- ;; "lux;imports"
- &/$Nil
- ;; "lux;tags"
- (&/|table)
- ;; "lux;types"
- (&/|table)
- ;; module-anns
- (&/|list)]
- ))
-
-;; [Exports]
-(defn add-import
- "(-> Text (Lux Null))"
- [module]
- (|do [current-module &/get-module-name]
- (fn [state]
- (if (&/|member? module (->> state (&/get$ &/$modules) (&/|get current-module) (&/get$ $imports)))
- ((&/fail-with-loc (str "[Analyser Error] Can't import module " (pr-str module) " twice @ " current-module))
- state)
- (return* (&/update$ &/$modules
- (fn [ms]
- (&/|update current-module
- (fn [m] (&/update$ $imports (partial &/$Cons module) m))
- ms))
- state)
- nil)))))
-
-(defn set-imports
- "(-> (List Text) (Lux Null))"
- [imports]
- (|do [current-module &/get-module-name]
- (fn [state]
- (return* (&/update$ &/$modules
- (fn [ms]
- (&/|update current-module
- (fn [m] (&/set$ $imports imports m))
- ms))
- state)
- nil))))
-
-(defn define [module name def-type def-meta def-value]
- (fn [state]
- (when (and (= "Macro" name) (= "lux" module))
- (&type/set-macro-type! def-value))
- (|case (&/get$ &/$scopes state)
- (&/$Cons ?env (&/$Nil))
- (return* (->> state
- (&/update$ &/$modules
- (fn [ms]
- (&/|update module
- (fn [m]
- (&/update$ $defs
- #(&/|put name (&/T [def-type def-meta def-value]) %)
- m))
- ms))))
- nil)
-
- _
- ((&/fail-with-loc (str "[Analyser Error] Can't create a new global definition outside of a global environment: " module ";" name))
- state))))
-
-(defn def-type
- "(-> Text Text (Lux Type))"
- [module name]
- (fn [state]
- (if-let [$module (->> state (&/get$ &/$modules) (&/|get module))]
- (if-let [$def (->> $module (&/get$ $defs) (&/|get name))]
- (|let [[?type ?meta ?value] $def]
- (return* state ?type))
- ((&/fail-with-loc (str "[Analyser Error] Unknown definition: " (str module ";" name)))
- state))
- ((&/fail-with-loc (str "[Analyser Error] Unknown module: " module))
- state))))
-
-(defn type-def
- "(-> Text Text (Lux [Bool Type]))"
- [module name]
- (fn [state]
- (if-let [$module (->> state (&/get$ &/$modules) (&/|get module))]
- (if-let [$def (->> $module (&/get$ $defs) (&/|get name))]
- (|let [[?type ?meta ?value] $def]
- (|case (&meta/meta-get &meta/type?-tag ?meta)
- (&/$Some _)
- (return* state (&/T [(|case (&meta/meta-get &meta/export?-tag ?meta)
- (&/$Some _)
- true
-
- _
- false)
- ?value]))
-
- _
- ((&/fail-with-loc (str "[Analyser Error] Not a type: " (&/ident->text (&/T [module name]))))
- state)))
- ((&/fail-with-loc (str "[Analyser Error] Unknown definition: " (&/ident->text (&/T [module name]))))
- state))
- ((&/fail-with-loc (str "[Analyser Error] Unknown module: " module))
- state))))
-
-(defn exists?
- "(-> Text (Lux Bool))"
- [name]
- (fn [state]
- (return* state
- (->> state (&/get$ &/$modules) (&/|contains? name)))))
-
-(defn dealias [name]
- (|do [current-module &/get-module-name]
- (fn [state]
- (if-let [real-name (->> state (&/get$ &/$modules) (&/|get current-module) (&/get$ $module-aliases) (&/|get name))]
- (return* state real-name)
- ((&/fail-with-loc (str "[Analyser Error] Unknown alias: " name))
- state)))))
-
-(defn alias [module alias reference]
- (fn [state]
- (let [_module_ (->> state (&/get$ &/$modules) (&/|get module))]
- (if (&/|member? module (->> _module_ (&/get$ $imports)))
- ((&/fail-with-loc (str "[Analyser Error] Can't create alias that is the same as a module nameL " (pr-str alias) " for " reference))
- state)
- (if-let [real-name (->> _module_ (&/get$ $module-aliases) (&/|get alias))]
- ((&/fail-with-loc (str "[Analyser Error] Can't re-use alias \"" alias "\" @ " module))
- state)
- (return* (->> state
- (&/update$ &/$modules
- (fn [ms]
- (&/|update module
- #(&/update$ $module-aliases
- (fn [aliases]
- (&/|put alias reference aliases))
- %)
- ms))))
- nil))))
- ))
-
-(defn ^:private imports? [state imported-module-name source-module-name]
- (->> state
- (&/get$ &/$modules)
- (&/|get source-module-name)
- (&/get$ $imports)
- (&/|any? (partial = imported-module-name))))
-
-(defn get-anns [module-name]
- (fn [state]
- (if-let [module (->> state
- (&/get$ &/$modules)
- (&/|get module-name))]
- (return* state (&/get$ $module-anns module))
- ((&/fail-with-loc (str "[Analyser Error] Module does not exist: " module-name))
- state))))
-
-(defn set-anns [anns module-name]
- (fn [state]
- (return* (->> state
- (&/update$ &/$modules
- (fn [ms]
- (&/|update module-name
- #(&/set$ $module-anns anns %)
- ms))))
- nil)))
-
-(defn find-def [module name]
- (|do [current-module &/get-module-name]
- (fn [state]
- (if (or (= "lux" module)
- (= current-module module)
- (imports? state module current-module))
- (if-let [$module (->> state (&/get$ &/$modules) (&/|get module))]
- (if-let [$def (->> $module (&/get$ $defs) (&/|get name))]
- (|let [[?type ?meta ?value] $def]
- (if (.equals ^Object current-module module)
- (|case (&meta/meta-get &meta/alias-tag ?meta)
- (&/$Some (&/$IdentM [?r-module ?r-name]))
- ((find-def ?r-module ?r-name)
- state)
-
- _
- (return* state (&/T [(&/T [module name]) $def])))
- (|case (&meta/meta-get &meta/export?-tag ?meta)
- (&/$Some (&/$BoolM true))
- (return* state (&/T [(&/T [module name]) $def]))
-
- _
- ((&/fail-with-loc (str "[Analyser Error @ find-def] Can't use unexported definition: " (str module &/+name-separator+ name)))
- state))))
- ((&/fail-with-loc (str "[Analyser Error @ find-def] Definition does not exist: " (str module &/+name-separator+ name)))
- state))
- ((&/fail-with-loc (str "[Analyser Error @ find-def] Module doesn't exist: " module))
- state))
- ((&/fail-with-loc (str "[Analyser Error @ find-def] Unknown module: " module))
- state))
- )))
-
-(defn ensure-type-def
- "(-> DefData (Lux Type))"
- [def-data]
- (|let [[?type ?meta ?value] def-data]
- (|case (&meta/meta-get &meta/type?-tag ?meta)
- (&/$Some _)
- (return ?type)
-
- _
- (&/fail-with-loc (str "[Analyser Error] Not a type definition: " (&/adt->text def-data))))))
-
-(defn defined? [module name]
- (&/try-all% (&/|list (|do [_ (find-def module name)]
- (return true))
- (return false))))
-
-(defn create-module
- "(-> Text Hash-Code (Lux Null))"
- [name hash]
- (fn [state]
- (return* (->> state
- (&/update$ &/$modules #(&/|put name (new-module hash) %))
- (&/set$ &/$scopes (&/|list (&/env name &/$Nil))))
- nil)))
-
-(do-template [<name> <tag> <type>]
- (defn <name>
- <type>
- [module]
- (fn [state]
- (if-let [=module (->> state (&/get$ &/$modules) (&/|get module))]
- (return* state (&/get$ <tag> =module))
- ((&/fail-with-loc (str "[Lux Error] Unknown module: " module))
- state))
- ))
-
- tags-by-module $tags "(-> Text (Lux (List (, Text (, Int (List Text) Type)))))"
- types-by-module $types "(-> Text (Lux (List (, Text (, (List Text) Type)))))"
- module-hash $module-hash "(-> Text (Lux Int))"
- )
-
-(def imports
- (|do [module &/get-module-name
- _imports (fn [state]
- (return* state (->> state (&/get$ &/$modules) (&/|get module) (&/get$ $imports))))]
- (&/map% (fn [_module]
- (|do [_hash (module-hash _module)]
- (return (&/T [_module _hash]))))
- _imports)))
-
-(defn ensure-undeclared-tags [module tags]
- (|do [tags-table (tags-by-module module)
- _ (&/map% (fn [tag]
- (if (&/|get tag tags-table)
- (&/fail-with-loc (str "[Analyser Error] Can't re-declare tag: " (&/ident->text (&/T [module tag]))))
- (return nil)))
- tags)]
- (return nil)))
-
-(defn ensure-undeclared-type [module name]
- (|do [types-table (types-by-module module)
- _ (&/assert! (nil? (&/|get name types-table))
- (str "[Analyser Error] Can't re-declare type: " (&/ident->text (&/T [module name]))))]
- (return nil)))
-
-(defn declare-tags
- "(-> Text (List Text) Bool Type (Lux Null))"
- [module tag-names was-exported? type]
- (|do [_ (ensure-undeclared-tags module tag-names)
- type-name (&type/type-name type)
- :let [[_module _name] type-name]
- _ (&/assert! (= module _module)
- (str "[Module Error] Can't define tags for a type belonging to a foreign module: " (&/ident->text type-name)))
- _ (ensure-undeclared-type _module _name)]
- (fn [state]
- (if-let [=module (->> state (&/get$ &/$modules) (&/|get module))]
- (let [tags (&/|map (fn [tag-name] (&/T [module tag-name])) tag-names)]
- (return* (&/update$ &/$modules
- (fn [=modules]
- (&/|update module
- #(->> %
- (&/set$ $tags (&/fold (fn [table idx+tag-name]
- (|let [[idx tag-name] idx+tag-name]
- (&/|put tag-name (&/T [idx tags was-exported? type]) table)))
- (&/get$ $tags %)
- (&/enumerate tag-names)))
- (&/update$ $types (partial &/|put _name (&/T [tags was-exported? type]))))
- =modules))
- state)
- nil))
- ((&/fail-with-loc (str "[Lux Error] Unknown module: " module))
- state)))))
-
-(defn ensure-can-see-tag
- "(-> Text Text (Lux Unit))"
- [module tag-name]
- (|do [current-module &/get-module-name]
- (fn [state]
- (if-let [=module (->> state (&/get$ &/$modules) (&/|get module))]
- (if-let [^objects idx+tags+exported+type (&/|get tag-name (&/get$ $tags =module))]
- (|let [[?idx ?tags ?exported ?type] idx+tags+exported+type]
- (if (or ?exported
- (= module current-module))
- (return* state &/unit-tag)
- ((&/fail-with-loc (str "[Analyser Error] Can't access tag #" (&/ident->text (&/T [module tag-name])) " from module " current-module))
- state)))
- ((&/fail-with-loc (str "[Module Error] Unknown tag: " (&/ident->text (&/T [module tag-name]))))
- state))
- ((&/fail-with-loc (str "[Module Error] Unknown module: " module))
- state)))))
-
-(do-template [<name> <part> <doc>]
- (defn <name>
- <doc>
- [module tag-name]
- (fn [state]
- (if-let [=module (->> state (&/get$ &/$modules) (&/|get module))]
- (if-let [^objects idx+tags+exported+type (&/|get tag-name (&/get$ $tags =module))]
- (|let [[?idx ?tags ?exported ?type] idx+tags+exported+type]
- (return* state <part>))
- ((&/fail-with-loc (str "[Module Error] Unknown tag: " (&/ident->text (&/T [module tag-name]))))
- state))
- ((&/fail-with-loc (str "[Module Error] Unknown module: " module))
- state))))
-
- tag-index ?idx "(-> Text Text (Lux Int))"
- tag-group ?tags "(-> Text Text (Lux (List Ident)))"
- tag-type ?type "(-> Text Text (Lux Type))"
- )
-
-(def defs
- (|do [module &/get-module-name]
- (fn [state]
- (return* state
- (->> state (&/get$ &/$modules) (&/|get module) (&/get$ $defs)
- (&/|map (fn [kv]
- (|let [[k _def-data] kv
- [_ ?def-meta _] _def-data]
- (|case (&meta/meta-get &meta/alias-tag ?def-meta)
- (&/$Some (&/$IdentM [?r-module ?r-name]))
- (&/T [k (str ?r-module ";" ?r-name) _def-data])
-
- _
- (&/T [k "" _def-data])
- )))))))))
-
-(do-template [<name> <type> <tag> <desc>]
- (defn <name> [module name meta type]
- (|case (&meta/meta-get <tag> meta)
- (&/$Some (&/$BoolM true))
- (&/try-all% (&/|list (&type/check <type> type)
- (&/fail-with-loc (str "[Analyser Error] Can't tag as lux;" <desc> "? if it's not a " <desc> ": " (str module ";" name)))))
-
- _
- (return nil)))
-
- test-type &type/Type &meta/type?-tag "type"
- test-macro &type/Macro &meta/macro?-tag "macro"
- )
-
-(defn fetch-imports [meta]
- (|case (&meta/meta-get &meta/imports-tag meta)
- (&/$Some (&/$ListM _parts))
- (&/map% (fn [_part]
- (|case _part
- (&/$ListM (&/$Cons [(&/$TextM _module)
- (&/$Cons [(&/$TextM _alias)
- (&/$Nil)])]))
- (return (&/T [_module _alias]))
-
- _
- (&/fail-with-loc "[Analyser Error] Wrong import syntax.")))
- _parts)
-
- _
- (&/fail-with-loc "[Analyser Error] No import meta-data.")))
diff --git a/src/lux/analyser/parser.clj b/src/lux/analyser/parser.clj
deleted file mode 100644
index e60f28a02..000000000
--- a/src/lux/analyser/parser.clj
+++ /dev/null
@@ -1,469 +0,0 @@
-;; Copyright (c) Eduardo Julian. All rights reserved.
-;; This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0.
-;; If a copy of the MPL was not distributed with this file,
-;; You can obtain one at http://mozilla.org/MPL/2.0/.
-
-(ns lux.analyser.parser
- (:require (clojure [template :refer [do-template]])
- clojure.core.match
- clojure.core.match.array
- (lux [base :as & :refer [|do return* return fail fail* |let |case]]
- [reader :as &reader]
- [lexer :as &lexer]
- [parser :as &parser])))
-
-(declare parse-gclass)
-
-;; [Parsers]
-(def ^:private _space_ (&reader/read-text " "))
-
-(defn ^:private repeat% [action]
- (fn [state]
- (|case (action state)
- (&/$Left ^String error)
- (&/$Right (&/T [state &/$Nil]))
-
- (&/$Right state* head)
- ((|do [tail (repeat% action)]
- (return (&/$Cons head tail)))
- state*))))
-
-(defn ^:private spaced [action]
- (fn [state]
- (|case (action state)
- (&/$Left ^String error)
- (&/$Right (&/T [state &/$Nil]))
-
- (&/$Right state* head)
- ((&/try-all% (&/|list (|do [_ _space_
- tail (spaced action)]
- (return (&/$Cons head tail)))
- (return (&/|list head))))
- state*))))
-
-(def ^:private parse-name
- (|do [[_ _ =name] (&reader/read-regex #"^([a-zA-Z0-9_\.]+)")]
- (return =name)))
-
-(def ^:private parse-ident
- (|do [[_ _ =name] (&reader/read-regex &lexer/+ident-re+)]
- (return =name)))
-
-(defn ^:private with-parens [body]
- (|do [_ (&reader/read-text "(")
- output body
- _ (&reader/read-text ")")]
- (return output)))
-
-(defn ^:private with-brackets [body]
- (|do [_ (&reader/read-text "[")
- output body
- _ (&reader/read-text "]")]
- (return output)))
-
-(defn ^:private with-braces [body]
- (|do [_ (&reader/read-text "{")
- output body
- _ (&reader/read-text "}")]
- (return output)))
-
-(def ^:private parse-type-param
- (with-parens
- (|do [=name parse-name
- _ _space_
- =bounds (spaced parse-gclass)]
- (return (&/T [=name =bounds])))))
-
-(def ^:private parse-gclass-decl
- (with-parens
- (|do [=class-name parse-name
- _ _space_
- =params (spaced parse-type-param)]
- (return (&/T [=class-name =params])))))
-
-(def ^:private parse-bound-kind
- (&/try-all% (&/|list (|do [_ (&reader/read-text "<")]
- (return &/$UpperBound))
-
- (|do [_ (&reader/read-text ">")]
- (return &/$LowerBound))
- )))
-
-(def parse-gclass
- (&/try-all% (&/|list (|do [=bound-kind parse-bound-kind
- =bound parse-gclass]
- (return (&/$GenericWildcard (&/$Some (&/T [=bound-kind =bound])))))
-
- (|do [_ (&reader/read-text "?")]
- (return (&/$GenericWildcard &/$None)))
-
- (|do [var-name parse-name]
- (return (&/$GenericTypeVar var-name)))
-
- (with-parens
- (|do [class-name parse-name
- _ _space_
- =params (spaced parse-gclass)]
- (return (&/$GenericClass class-name =params))))
-
- (with-parens
- (|do [_ (&reader/read-text "Array")
- _ _space_
- =param parse-gclass]
- (return (&/$GenericArray =param))))
- )))
-
-(def ^:private parse-gclass-super
- (with-parens
- (|do [class-name parse-name
- _ _space_
- =params (spaced parse-gclass)]
- (return (&/T [class-name =params])))))
-
-(def ^:private parse-ctor-arg
- (with-brackets
- (|do [=class parse-gclass
- (&/$Cons =term (&/$Nil)) &parser/parse]
- (return (&/T [=class =term])))))
-
-(def ^:private parse-ann-param
- (|do [param-name parse-name
- _ (&reader/read-text "=")
- param-value (&/try-all% (&/|list (|do [[_ (&lexer/$Bool param-value*)] &lexer/lex-bool]
- (return (boolean param-value*)))
-
- (|do [[_ (&lexer/$Int param-value*)] &lexer/lex-int]
- (return (int param-value*)))
-
- (|do [_ (&reader/read-text "l")
- [_ (&lexer/$Int param-value*)] &lexer/lex-int]
- (return (long param-value*)))
-
- (|do [[_ (&lexer/$Real param-value*)] &lexer/lex-real]
- (return (float param-value*)))
-
- (|do [_ (&reader/read-text "d")
- [_ (&lexer/$Real param-value*)] &lexer/lex-real]
- (return (double param-value*)))
-
- (|do [[_ (&lexer/$Char param-value*)] &lexer/lex-char]
- (return (char param-value*)))
-
- (|do [[_ (&lexer/$Text param-value*)] &lexer/lex-text]
- (return param-value*))
- ))]
- (return (&/T [param-name param-value]))))
-
-(def ^:private parse-ann
- (with-parens
- (|do [ann-name parse-name
- _ _space_
- =ann-params (with-braces
- (spaced parse-ann-param))]
- (return {:name ann-name
- :params =ann-params}))))
-
-(def ^:private parse-arg-decl
- (with-parens
- (|do [=arg-name parse-ident
- _ (&reader/read-text " ")
- =gclass parse-gclass]
- (return (&/T [=arg-name =gclass])))))
-
-(def ^:private parse-gvars
- (|do [=head parse-name
- [_ _ ?] (&reader/read-text? " ")]
- (if ?
- (|do [=tail parse-gvars]
- (return (&/$Cons =head =tail)))
- (return (&/|list =head)))))
-
-(def ^:private parse-method-decl
- (with-parens
- (|do [=method-name parse-name
- _ _space_
- =anns (with-brackets
- (spaced parse-ann))
- _ _space_
- =gvars (with-brackets
- parse-gvars)
- _ _space_
- =exceptions (with-brackets
- (spaced parse-gclass))
- _ _space_
- =inputs (with-brackets
- (spaced parse-gclass))
- _ _space_
- =output parse-gclass]
- (return (&/T [=method-name =anns =gvars =exceptions =inputs =output])))))
-
-(def ^:private parse-privacy-modifier
- (&/try-all% (&/|list (|do [_ (&reader/read-text "default")]
- (return &/$DefaultPM))
-
- (|do [_ (&reader/read-text "public")]
- (return &/$PublicPM))
-
- (|do [_ (&reader/read-text "protected")]
- (return &/$ProtectedPM))
-
- (|do [_ (&reader/read-text "private")]
- (return &/$PrivatePM))
- )))
-
-(def ^:private parse-state-modifier
- (&/try-all% (&/|list (|do [_ (&reader/read-text "default")]
- (return &/$DefaultSM))
-
- (|do [_ (&reader/read-text "volatile")]
- (return &/$VolatileSM))
-
- (|do [_ (&reader/read-text "final")]
- (return &/$FinalSM))
- )))
-
-(def ^:private parse-inheritance-modifier
- (&/try-all% (&/|list (|do [_ (&reader/read-text "default")]
- (return &/$DefaultIM))
-
- (|do [_ (&reader/read-text "abstract")]
- (return &/$AbstractIM))
-
- (|do [_ (&reader/read-text "final")]
- (return &/$FinalIM))
- )))
-
-(def ^:private parse-method-init-def
- (|do [_ (&reader/read-text "init")
- _ _space_
- =privacy-modifier parse-privacy-modifier
- _ _space_
- [_ (&lexer/$Bool =strict*)] &lexer/lex-bool
- :let [=strict (Boolean/parseBoolean =strict*)]
- _ _space_
- =anns (with-brackets
- (spaced parse-ann))
- _ _space_
- =gvars (with-brackets
- (spaced parse-type-param))
- _ _space_
- =exceptions (with-brackets
- (spaced parse-gclass))
- _ _space_
- =inputs (with-brackets
- (spaced parse-arg-decl))
- _ _space_
- =ctor-args (with-brackets
- (spaced parse-ctor-arg))
- _ _space_
- (&/$Cons =body (&/$Nil)) &parser/parse]
- (return (&/$ConstructorMethodSyntax (&/T [=privacy-modifier =strict =anns =gvars =exceptions =inputs =ctor-args =body])))))
-
-(def ^:private parse-method-virtual-def
- (|do [_ (&reader/read-text "virtual")
- _ _space_
- =name parse-name
- _ _space_
- =privacy-modifier parse-privacy-modifier
- _ _space_
- [_ (&lexer/$Bool =final?*)] &lexer/lex-bool
- :let [=final? (Boolean/parseBoolean =final?*)]
- _ _space_
- [_ (&lexer/$Bool =strict*)] &lexer/lex-bool
- :let [=strict (Boolean/parseBoolean =strict*)]
- _ _space_
- =anns (with-brackets
- (spaced parse-ann))
- _ _space_
- =gvars (with-brackets
- (spaced parse-type-param))
- _ _space_
- =exceptions (with-brackets
- (spaced parse-gclass))
- _ _space_
- =inputs (with-brackets
- (spaced parse-arg-decl))
- _ _space_
- =output parse-gclass
- _ _space_
- (&/$Cons =body (&/$Nil)) &parser/parse]
- (return (&/$VirtualMethodSyntax (&/T [=name =privacy-modifier =final? =strict =anns =gvars =exceptions =inputs =output =body])))))
-
-(def ^:private parse-method-override-def
- (|do [_ (&reader/read-text "override")
- _ _space_
- =class-decl parse-gclass-decl
- _ _space_
- =name parse-name
- _ _space_
- [_ (&lexer/$Bool =strict*)] &lexer/lex-bool
- :let [=strict (Boolean/parseBoolean =strict*)]
- _ _space_
- =anns (with-brackets
- (spaced parse-ann))
- _ _space_
- =gvars (with-brackets
- (spaced parse-type-param))
- _ _space_
- =exceptions (with-brackets
- (spaced parse-gclass))
- _ _space_
- =inputs (with-brackets
- (spaced parse-arg-decl))
- _ _space_
- =output parse-gclass
- _ _space_
- (&/$Cons =body (&/$Nil)) &parser/parse]
- (return (&/$OverridenMethodSyntax (&/T [=class-decl =name =strict =anns =gvars =exceptions =inputs =output =body])))))
-
-(def ^:private parse-method-static-def
- (|do [_ (&reader/read-text "static")
- _ _space_
- =name parse-name
- _ _space_
- =privacy-modifier parse-privacy-modifier
- _ _space_
- [_ (&lexer/$Bool =strict*)] &lexer/lex-bool
- :let [=strict (Boolean/parseBoolean =strict*)]
- _ _space_
- =anns (with-brackets
- (spaced parse-ann))
- _ _space_
- =gvars (with-brackets
- (spaced parse-type-param))
- _ _space_
- =exceptions (with-brackets
- (spaced parse-gclass))
- _ _space_
- =inputs (with-brackets
- (spaced parse-arg-decl))
- _ _space_
- =output parse-gclass
- _ _space_
- (&/$Cons =body (&/$Nil)) &parser/parse]
- (return (&/$StaticMethodSyntax (&/T [=name =privacy-modifier =strict =anns =gvars =exceptions =inputs =output =body])))))
-
-(def ^:private parse-method-abstract-def
- (|do [_ (&reader/read-text "abstract")
- _ _space_
- =name parse-name
- _ _space_
- =privacy-modifier parse-privacy-modifier
- _ _space_
- =anns (with-brackets
- (spaced parse-ann))
- _ _space_
- =gvars (with-brackets
- (spaced parse-type-param))
- _ _space_
- =exceptions (with-brackets
- (spaced parse-gclass))
- _ _space_
- =inputs (with-brackets
- (spaced parse-arg-decl))
- _ _space_
- =output parse-gclass]
- (return (&/$AbstractMethodSyntax (&/T [=name =privacy-modifier =anns =gvars =exceptions =inputs =output])))))
-
-(def ^:private parse-method-native-def
- (|do [_ (&reader/read-text "native")
- _ _space_
- =name parse-name
- _ _space_
- =privacy-modifier parse-privacy-modifier
- _ _space_
- =anns (with-brackets
- (spaced parse-ann))
- _ _space_
- =gvars (with-brackets
- (spaced parse-type-param))
- _ _space_
- =exceptions (with-brackets
- (spaced parse-gclass))
- _ _space_
- =inputs (with-brackets
- (spaced parse-arg-decl))
- _ _space_
- =output parse-gclass]
- (return (&/$NativeMethodSyntax (&/T [=name =privacy-modifier =anns =gvars =exceptions =inputs =output])))))
-
-(def ^:private parse-method-def
- (with-parens
- (&/try-all% (&/|list parse-method-init-def
- parse-method-virtual-def
- parse-method-override-def
- parse-method-static-def
- parse-method-abstract-def
- parse-method-native-def
- ))))
-
-(def ^:private parse-field
- (with-parens
- (&/try-all% (&/|list (|do [_ (&reader/read-text "constant")
- _ _space_
- =name parse-name
- _ _space_
- =anns (with-brackets
- (spaced parse-ann))
- _ _space_
- =type parse-gclass
- _ _space_
- (&/$Cons =value (&/$Nil)) &parser/parse]
- (return (&/$ConstantFieldSyntax =name =anns =type =value)))
-
- (|do [_ (&reader/read-text "variable")
- _ _space_
- =name parse-name
- _ _space_
- =privacy-modifier parse-privacy-modifier
- _ _space_
- =state-modifier parse-state-modifier
- _ _space_
- =anns (with-brackets
- (spaced parse-ann))
- _ _space_
- =type parse-gclass]
- (return (&/$VariableFieldSyntax =name =privacy-modifier =state-modifier =anns =type)))
- ))))
-
-(def parse-interface-def
- (|do [=gclass-decl parse-gclass-decl
- =supers (with-brackets
- (spaced parse-gclass-super))
- =anns (with-brackets
- (spaced parse-ann))
- =methods (spaced parse-method-decl)]
- (return (&/T [=gclass-decl =supers =anns =methods]))))
-
-(def parse-class-def
- (|do [=gclass-decl parse-gclass-decl
- _ _space_
- =super-class parse-gclass-super
- _ _space_
- =interfaces (with-brackets
- (spaced parse-gclass-super))
- _ _space_
- =inheritance-modifier parse-inheritance-modifier
- _ _space_
- =anns (with-brackets
- (spaced parse-ann))
- _ _space_
- =fields (with-brackets
- (spaced parse-field))
- _ _space_
- =methods (with-brackets
- (spaced parse-method-def))]
- (return (&/T [=gclass-decl =super-class =interfaces =inheritance-modifier =anns =fields =methods]))))
-
-(def parse-anon-class-def
- (|do [=super-class parse-gclass-super
- _ _space_
- =interfaces (with-brackets
- (spaced parse-gclass-super))
- _ _space_
- =ctor-args (with-brackets
- (spaced parse-ctor-arg))
- _ _space_
- =methods (with-brackets
- (spaced parse-method-def))]
- (return (&/T [=super-class =interfaces =ctor-args =methods]))))
diff --git a/src/lux/analyser/record.clj b/src/lux/analyser/record.clj
deleted file mode 100644
index 81332b34c..000000000
--- a/src/lux/analyser/record.clj
+++ /dev/null
@@ -1,47 +0,0 @@
-;; Copyright (c) Eduardo Julian. All rights reserved.
-;; This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0.
-;; If a copy of the MPL was not distributed with this file,
-;; You can obtain one at http://mozilla.org/MPL/2.0/.
-
-(ns lux.analyser.record
- (:require clojure.core.match
- clojure.core.match.array
- (lux [base :as & :refer [|let |do return fail |case]]
- [type :as &type])
- (lux.analyser [base :as &&]
- [module :as &&module])))
-
-;; [Exports]
-(defn order-record [pairs]
- "(-> (List (, Syntax Syntax)) (Lux (List Syntax)))"
- (|do [[tag-group tag-type] (|case pairs
- (&/$Nil)
- (return (&/T [&/$Nil &/$UnitT]))
-
- (&/$Cons [[_ (&/$TagS tag1)] _] _)
- (|do [[module name] (&&/resolved-ident tag1)
- tags (&&module/tag-group module name)
- type (&&module/tag-type module name)]
- (return (&/T [tags type])))
-
- _
- (&/fail-with-loc "[Analyser Error] Wrong syntax for records. Odd elements must be tags."))
- =pairs (&/map% (fn [kv]
- (|case kv
- [[_ (&/$TagS k)] v]
- (|do [=k (&&/resolved-ident k)]
- (return (&/T [(&/ident->text =k) v])))
-
- _
- (&/fail-with-loc "[Analyser Error] Wrong syntax for records. Odd elements must be tags.")))
- pairs)
- _ (let [num-expected (&/|length tag-group)
- num-got (&/|length =pairs)]
- (&/assert! (= num-expected num-got)
- (str "[Analyser Error] Wrong number of record members. Expected " num-expected ", but got " num-got ".")))
- =members (&/map% (fn [tag]
- (if-let [member (&/|get tag =pairs)]
- (return member)
- (&/fail-with-loc (str "[Analyser Error] Missing tag: " tag))))
- (&/|map &/ident->text tag-group))]
- (return (&/T [=members tag-type]))))
diff --git a/src/lux/base.clj b/src/lux/base.clj
deleted file mode 100644
index 5697415f8..000000000
--- a/src/lux/base.clj
+++ /dev/null
@@ -1,1449 +0,0 @@
-;; Copyright (c) Eduardo Julian. All rights reserved.
-;; This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0.
-;; If a copy of the MPL was not distributed with this file,
-;; You can obtain one at http://mozilla.org/MPL/2.0/.
-
-(ns lux.base
- (:require (clojure [template :refer [do-template]]
- [string :as string])
- [clojure.core.match :as M :refer [matchv]]
- clojure.core.match.array))
-
-;; [Tags]
-(def unit-tag (.intern (str (char 0) "unit" (char 0))))
-
-(defn T [elems]
- (case (count elems)
- 0
- unit-tag
-
- 1
- (first elems)
-
- ;; else
- (to-array elems)))
-
-(defmacro defvariant [& names]
- (assert (> (count names) 1))
- `(do ~@(for [[[name num-params] idx] (map vector names (range (count names)))
- :let [last-idx (dec (count names))
- is-last? (if (= idx last-idx)
- ""
- nil)
- def-name (with-meta (symbol (str "$" name))
- {::idx idx
- ::is-last? is-last?})]]
- (cond (= 0 num-params)
- `(def ~def-name
- (to-array [(int ~idx) ~is-last? unit-tag]))
-
- (= 1 num-params)
- `(defn ~def-name [arg#]
- (to-array [(int ~idx) ~is-last? arg#]))
-
- :else
- (let [g!args (map (fn [_] (gensym "arg"))
- (range num-params))]
- `(defn ~def-name [~@g!args]
- (to-array [(int ~idx) ~is-last? (T [~@g!args])])))
- ))))
-
-(defmacro deftuple [names]
- (assert (vector? names))
- `(do ~@(for [[name idx] (map vector names (range (count names)))]
- `(def ~(symbol (str "$" name))
- (int ~idx)))))
-
-;; List
-(defvariant
- ("Nil" 0)
- ("Cons" 2))
-
-;; Maybe
-(defvariant
- ("None" 0)
- ("Some" 1))
-
-;; Either
-(defvariant
- ("Left" 1)
- ("Right" 1))
-
-;; AST
-(defvariant
- ("BoolS" 1)
- ("NatS" 1)
- ("IntS" 1)
- ("FracS" 1)
- ("RealS" 1)
- ("CharS" 1)
- ("TextS" 1)
- ("SymbolS" 1)
- ("TagS" 1)
- ("FormS" 1)
- ("TupleS" 1)
- ("RecordS" 1))
-
-;; Type
-(defvariant
- ("HostT" 2)
- ("VoidT" 0)
- ("UnitT" 0)
- ("SumT" 2)
- ("ProdT" 2)
- ("LambdaT" 2)
- ("BoundT" 1)
- ("VarT" 1)
- ("ExT" 1)
- ("UnivQ" 2)
- ("ExQ" 2)
- ("AppT" 2)
- ("NamedT" 2))
-
-;; Vars
-(defvariant
- ("Local" 1)
- ("Global" 1))
-
-;; Binding
-(deftuple
- ["counter"
- "mappings"])
-
-;; Env
-(deftuple
- ["name"
- "inner-closures"
- "locals"
- "closure"])
-
-;; ModuleState
-(defvariant
- ("Active" 0)
- ("Compiled" 0)
- ("Cached" 0))
-
-;; Host
-(deftuple
- ["writer"
- "loader"
- "classes"
- "catching"
- "module-states"
- "type-env"
- "dummy-mappings"
- ])
-
-;; Compiler
-(defvariant
- ("Release" 0)
- ("Debug" 0)
- ("Eval" 0)
- ("REPL" 0))
-
-(deftuple
- ["compiler-name"
- "compiler-version"
- "compiler-mode"])
-
-(deftuple
- ["info"
- "source"
- "cursor"
- "modules"
- "scopes"
- "type-vars"
- "expected"
- "seed"
- "scope-type-vars"
- "host"])
-
-;; Compiler
-(defvariant
- ("UpperBound" 0)
- ("LowerBound" 0))
-
-(defvariant
- ("GenericTypeVar" 1)
- ("GenericClass" 2)
- ("GenericArray" 1)
- ("GenericWildcard" 1))
-
-;; Privacy Modifiers
-(defvariant
- ("DefaultPM" 0)
- ("PublicPM" 0)
- ("PrivatePM" 0)
- ("ProtectedPM" 0))
-
-;; State Modifiers
-(defvariant
- ("DefaultSM" 0)
- ("VolatileSM" 0)
- ("FinalSM" 0))
-
-;; Inheritance Modifiers
-(defvariant
- ("DefaultIM" 0)
- ("AbstractIM" 0)
- ("FinalIM" 0))
-
-;; Fields
-(defvariant
- ("ConstantFieldSyntax" 4)
- ("VariableFieldSyntax" 5))
-
-(defvariant
- ("ConstantFieldAnalysis" 4)
- ("VariableFieldAnalysis" 5))
-
-;; Methods
-(defvariant
- ("ConstructorMethodSyntax" 1)
- ("VirtualMethodSyntax" 1)
- ("OverridenMethodSyntax" 1)
- ("StaticMethodSyntax" 1)
- ("AbstractMethodSyntax" 1)
- ("NativeMethodSyntax" 1))
-
-(defvariant
- ("ConstructorMethodAnalysis" 1)
- ("VirtualMethodAnalysis" 1)
- ("OverridenMethodAnalysis" 1)
- ("StaticMethodAnalysis" 1)
- ("AbstractMethodAnalysis" 1)
- ("NativeMethodAnalysis" 1))
-
-;; Meta-data
-(defvariant
- ("BoolM" 1)
- ("NatM" 1)
- ("IntM" 1)
- ("FracM" 1)
- ("RealM" 1)
- ("CharM" 1)
- ("TextM" 1)
- ("IdentM" 1)
- ("ListM" 1)
- ("DictM" 1))
-
-;; [Exports]
-(def ^:const name-field "_name")
-(def ^:const hash-field "_hash")
-(def ^:const value-field "_value")
-(def ^:const compiler-field "_compiler")
-(def ^:const eval-field "_eval")
-(def ^:const module-class-name "_")
-(def ^:const +name-separator+ ";")
-
-(def ^:const ^String compiler-name "Lux/JVM")
-(def ^:const ^String compiler-version "0.5.0")
-
-;; Constructors
-(def empty-cursor (T ["" -1 -1]))
-
-(defn get$ [slot ^objects record]
- (aget record slot))
-
-(defn set$ [slot value ^objects record]
- (doto (aclone ^objects record)
- (aset slot value)))
-
-(defmacro update$ [slot f record]
- `(let [record# ~record]
- (set$ ~slot (~f (get$ ~slot record#))
- record#)))
-
-(defn fail* [message]
- ($Left message))
-
-(defn return* [state value]
- ($Right (T [state value])))
-
-(defn transform-pattern [pattern]
- (cond (vector? pattern) (case (count pattern)
- 0
- unit-tag
-
- 1
- (transform-pattern (first pattern))
-
- ;; else
- (mapv transform-pattern pattern))
- (seq? pattern) [(if-let [tag-var (ns-resolve *ns* (first pattern))]
- (-> tag-var
- meta
- ::idx)
- (assert false (str "Unknown var: " (first pattern))))
- '_
- (transform-pattern (vec (rest pattern)))]
- :else pattern
- ))
-
-(defmacro |case [value & branches]
- (assert (= 0 (mod (count branches) 2)))
- (let [value* (if (vector? value)
- [`(T [~@value])]
- [value])]
- `(matchv ::M/objects ~value*
- ~@(mapcat (fn [[pattern body]]
- (list [(transform-pattern pattern)]
- body))
- (partition 2 branches)))))
-
-(defmacro |let [bindings body]
- (reduce (fn [inner [left right]]
- `(|case ~right
- ~left
- ~inner))
- body
- (reverse (partition 2 bindings))))
-
-(defmacro |list [& elems]
- (reduce (fn [tail head]
- `($Cons ~head ~tail))
- `$Nil
- (reverse elems)))
-
-(defmacro |table [& elems]
- (reduce (fn [table [k v]]
- `(|put ~k ~v ~table))
- `$Nil
- (reverse (partition 2 elems))))
-
-(defn |get [slot table]
- (|case table
- ($Nil)
- nil
-
- ($Cons [k v] table*)
- (if (.equals ^Object k slot)
- v
- (recur slot table*))))
-
-(defn |put [slot value table]
- (|case table
- ($Nil)
- ($Cons (T [slot value]) $Nil)
-
- ($Cons [k v] table*)
- (if (.equals ^Object k slot)
- ($Cons (T [slot value]) table*)
- ($Cons (T [k v]) (|put slot value table*)))
- ))
-
-(defn |remove [slot table]
- (|case table
- ($Nil)
- table
-
- ($Cons [k v] table*)
- (if (.equals ^Object k slot)
- table*
- ($Cons (T [k v]) (|remove slot table*)))))
-
-(defn |update [k f table]
- (|case table
- ($Nil)
- table
-
- ($Cons [k* v] table*)
- (if (.equals ^Object k k*)
- ($Cons (T [k* (f v)]) table*)
- ($Cons (T [k* v]) (|update k f table*)))))
-
-(defn |head [xs]
- (|case xs
- ($Nil)
- (assert false (prn-str '|head))
-
- ($Cons x _)
- x))
-
-(defn |tail [xs]
- (|case xs
- ($Nil)
- (assert false (prn-str '|tail))
-
- ($Cons _ xs*)
- xs*))
-
-;; [Resources/Monads]
-(defn fail [message]
- (fn [_]
- ($Left message)))
-
-(defn return [value]
- (fn [state]
- ($Right (T [state value]))))
-
-(defn bind [m-value step]
- (fn [state]
- (let [inputs (m-value state)]
- (|case inputs
- ($Right ?state ?datum)
- ((step ?datum) ?state)
-
- ($Left _)
- inputs
- ))))
-
-(defmacro |do [steps return]
- (assert (= 0 (rem (count steps) 2)) "The number of steps must be even!")
- (reduce (fn [inner [label computation]]
- (case label
- :let `(|let ~computation ~inner)
- ;; else
- `(bind ~computation
- (fn [val#]
- (|case val#
- ~label
- ~inner)))))
- return
- (reverse (partition 2 steps))))
-
-;; [Resources/Combinators]
-(let [array-class (class (to-array []))]
- (defn adt->text [adt]
- (if (= array-class (class adt))
- (str "[" (->> adt (map adt->text) (interpose " ") (reduce str "")) "]")
- (pr-str adt))))
-
-(defn |++ [xs ys]
- (|case xs
- ($Nil)
- ys
-
- ($Cons x xs*)
- ($Cons x (|++ xs* ys))))
-
-(defn |map [f xs]
- (|case xs
- ($Nil)
- xs
-
- ($Cons x xs*)
- ($Cons (f x) (|map f xs*))
-
- _
- (assert false (prn-str '|map f (adt->text xs)))))
-
-(defn |empty? [xs]
- "(All [a] (-> (List a) Bool))"
- (|case xs
- ($Nil)
- true
-
- ($Cons _ _)
- false))
-
-(defn |filter [p xs]
- "(All [a] (-> (-> a Bool) (List a) (List a)))"
- (|case xs
- ($Nil)
- xs
-
- ($Cons x xs*)
- (if (p x)
- ($Cons x (|filter p xs*))
- (|filter p xs*))))
-
-(defn flat-map [f xs]
- "(All [a b] (-> (-> a (List b)) (List a) (List b)))"
- (|case xs
- ($Nil)
- xs
-
- ($Cons x xs*)
- (|++ (f x) (flat-map f xs*))))
-
-(defn |split-with [p xs]
- (|case xs
- ($Nil)
- (T [xs xs])
-
- ($Cons x xs*)
- (if (p x)
- (|let [[pre post] (|split-with p xs*)]
- (T [($Cons x pre) post]))
- (T [$Nil xs]))))
-
-(defn |contains? [k table]
- (|case table
- ($Nil)
- false
-
- ($Cons [k* _] table*)
- (or (.equals ^Object k k*)
- (|contains? k table*))))
-
-(defn |member? [x xs]
- (|case xs
- ($Nil)
- false
-
- ($Cons x* xs*)
- (or (= x x*) (|member? x xs*))))
-
-(defn fold [f init xs]
- (|case xs
- ($Nil)
- init
-
- ($Cons x xs*)
- (recur f (f init x) xs*)))
-
-(defn fold% [f init xs]
- (|case xs
- ($Nil)
- (return init)
-
- ($Cons x xs*)
- (|do [init* (f init x)]
- (fold% f init* xs*))))
-
-(defn folds [f init xs]
- (|case xs
- ($Nil)
- (|list init)
-
- ($Cons x xs*)
- ($Cons init (folds f (f init x) xs*))))
-
-(defn |length [xs]
- (fold (fn [acc _] (inc acc)) 0 xs))
-
-(defn |range* [from to]
- (if (<= from to)
- ($Cons from (|range* (inc from) to))
- $Nil))
-
-(let [|range* (fn |range* [from to]
- (if (< from to)
- ($Cons from (|range* (inc from) to))
- $Nil))]
- (defn |range [n]
- (|range* 0 n)))
-
-(defn |first [pair]
- (|let [[_1 _2] pair]
- _1))
-
-(defn |second [pair]
- (|let [[_1 _2] pair]
- _2))
-
-(defn zip2 [xs ys]
- (|case [xs ys]
- [($Cons x xs*) ($Cons y ys*)]
- ($Cons (T [x y]) (zip2 xs* ys*))
-
- [_ _]
- $Nil))
-
-(defn |keys [plist]
- (|case plist
- ($Nil)
- $Nil
-
- ($Cons [k v] plist*)
- ($Cons k (|keys plist*))))
-
-(defn |vals [plist]
- (|case plist
- ($Nil)
- $Nil
-
- ($Cons [k v] plist*)
- ($Cons v (|vals plist*))))
-
-(defn |interpose [sep xs]
- (|case xs
- ($Nil)
- xs
-
- ($Cons _ ($Nil))
- xs
-
- ($Cons x xs*)
- ($Cons x ($Cons sep (|interpose sep xs*)))))
-
-(do-template [<name> <joiner>]
- (defn <name> [f xs]
- (|case xs
- ($Nil)
- (return xs)
-
- ($Cons x xs*)
- (|do [y (f x)
- ys (<name> f xs*)]
- (return (<joiner> y ys)))))
-
- map% $Cons
- flat-map% |++)
-
-(defn list-join [xss]
- (fold |++ $Nil xss))
-
-(defn |as-pairs [xs]
- (|case xs
- ($Cons x ($Cons y xs*))
- ($Cons (T [x y]) (|as-pairs xs*))
-
- _
- $Nil))
-
-(defn |reverse [xs]
- (fold (fn [tail head]
- ($Cons head tail))
- $Nil
- xs))
-
-(defn add-loc [meta ^String msg]
- (if (.startsWith msg "@")
- msg
- (|let [[file line col] meta]
- (str "@ " file "," line "," col "\n" msg))))
-
-(defn fail-with-loc [msg]
- (fn [state]
- (fail* (add-loc (get$ $cursor state) msg))))
-
-(defn assert! [test message]
- (if test
- (return unit-tag)
- (fail-with-loc message)))
-
-(def get-state
- (fn [state]
- (return* state state)))
-
-(defn try-all% [monads]
- (|case monads
- ($Nil)
- (fail "There are no alternatives to try!")
-
- ($Cons m monads*)
- (fn [state]
- (let [output (m state)]
- (|case [output monads*]
- [($Right _) _]
- output
-
- [_ ($Nil)]
- output
-
- [_ _]
- ((try-all% monads*) state)
- )))
- ))
-
-(defn try-all-% [prefix monads]
- (|case monads
- ($Nil)
- (fail "There are no alternatives to try!")
-
- ($Cons m monads*)
- (fn [state]
- (let [output (m state)]
- (|case [output monads*]
- [($Right _) _]
- output
-
- [_ ($Nil)]
- output
-
- [($Left ^String error) _]
- (if (.contains error prefix)
- ((try-all-% prefix monads*) state)
- output)
- )))
- ))
-
-(defn exhaust% [step]
- (fn [state]
- (|case (step state)
- ($Right state* _)
- ((exhaust% step) state*)
-
- ($Left msg)
- (if (.equals "[Reader Error] EOF" msg)
- (return* state unit-tag)
- (fail* msg)))))
-
-(defn ^:private normalize-char [char]
- (case char
- \* "_ASTER_"
- \+ "_PLUS_"
- \- "_DASH_"
- \/ "_SLASH_"
- \\ "_BSLASH_"
- \_ "_UNDERS_"
- \% "_PERCENT_"
- \$ "_DOLLAR_"
- \' "_QUOTE_"
- \` "_BQUOTE_"
- \@ "_AT_"
- \^ "_CARET_"
- \& "_AMPERS_"
- \= "_EQ_"
- \! "_BANG_"
- \? "_QM_"
- \: "_COLON_"
- \. "_PERIOD_"
- \, "_COMMA_"
- \< "_LT_"
- \> "_GT_"
- \~ "_TILDE_"
- \| "_PIPE_"
- ;; default
- char))
-
-(defn normalize-name [ident]
- (reduce str "" (map normalize-char ident)))
-
-(def classes
- (fn [state]
- (return* state (->> state (get$ $host) (get$ $classes)))))
-
-(def +init-bindings+
- (T [;; "lux;counter"
- 0
- ;; "lux;mappings"
- (|table)]))
-
-(defn env [name old-name]
- (T [;; "lux;name"
- ($Cons name old-name)
- ;; "lux;inner-closures"
- 0
- ;; "lux;locals"
- +init-bindings+
- ;; "lux;closure"
- +init-bindings+]
- ))
-
-(let [define-class (doto (.getDeclaredMethod java.lang.ClassLoader "defineClass" (into-array [String
- (class (byte-array []))
- Integer/TYPE
- Integer/TYPE]))
- (.setAccessible true))]
- (defn memory-class-loader [store]
- (proxy [java.lang.ClassLoader]
- []
- (findClass [^String class-name]
- (if-let [^bytes bytecode (get @store class-name)]
- (.invoke define-class this (to-array [class-name bytecode (int 0) (int (alength bytecode))]))
- (throw (IllegalStateException. (str "[Class Loader] Unknown class: " class-name))))))))
-
-(def loader
- (fn [state]
- (return* state (->> state (get$ $host) (get$ $loader)))))
-
-(defn host [_]
- (let [store (atom {})]
- (T [;; "lux;writer"
- $None
- ;; "lux;loader"
- (memory-class-loader store)
- ;; "lux;classes"
- store
- ;; "lux;catching"
- $Nil
- ;; "lux;module-states"
- (|table)
- ;; lux;type-env
- (|table)
- ;; lux;dummy-mappings
- (|table)
- ])))
-
-(defn with-no-catches [body]
- "(All [a] (-> (Lux a) (Lux a)))"
- (fn [state]
- (let [old-catching (->> state (get$ $host) (get$ $catching))]
- (|case (body (update$ $host #(set$ $catching $Nil %) state))
- ($Right state* output)
- (return* (update$ $host #(set$ $catching old-catching %) state*) output)
-
- ($Left msg)
- (fail* msg)))))
-
-(defn default-compiler-info [mode]
- (T [;; compiler-name
- compiler-name
- ;; compiler-version
- compiler-version
- ;; compiler-mode
- mode]
- ))
-
-(defn init-state [mode]
- (T [;; "lux;info"
- (default-compiler-info mode)
- ;; "lux;source"
- $Nil
- ;; "lux;cursor"
- (T ["" -1 -1])
- ;; "lux;modules"
- (|table)
- ;; "lux;scopes"
- $Nil
- ;; "lux;types"
- +init-bindings+
- ;; "lux;expected"
- $None
- ;; "lux;seed"
- 0
- ;; scope-type-vars
- $Nil
- ;; "lux;host"
- (host nil)]
- ))
-
-(defn save-module [body]
- (fn [state]
- (|case (body state)
- ($Right state* output)
- (return* (->> state*
- (set$ $scopes (get$ $scopes state))
- (set$ $source (get$ $source state)))
- output)
-
- ($Left msg)
- (fail* msg))))
-
-(defn in-eval? [mode]
- "(-> CompilerMode Bool)"
- (|case mode
- ($Eval) true
- _ false))
-
-(defn in-repl? [mode]
- "(-> CompilerMode Bool)"
- (|case mode
- ($REPL) true
- _ false))
-
-(defn with-eval [body]
- (fn [state]
- (let [old-mode (->> state (get$ $info) (get$ $compiler-mode))]
- (|case (body (update$ $info #(set$ $compiler-mode $Eval %) state))
- ($Right state* output)
- (return* (update$ $info #(set$ $compiler-mode old-mode %) state*) output)
-
- ($Left msg)
- (fail* msg)))))
-
-(def get-eval
- (fn [state]
- (return* state (->> state (get$ $info) (get$ $compiler-mode) in-eval?))))
-
-(def get-mode
- (fn [state]
- (return* state (->> state (get$ $info) (get$ $compiler-mode)))))
-
-(def get-writer
- (fn [state]
- (let [writer* (->> state (get$ $host) (get$ $writer))]
- (|case writer*
- ($Some datum)
- (return* state datum)
-
- _
- ((fail-with-loc "Writer hasn't been set.") state)))))
-
-(def get-top-local-env
- (fn [state]
- (try (let [top (|head (get$ $scopes state))]
- (return* state top))
- (catch Throwable _
- ((fail-with-loc "No local environment.") state)))))
-
-(def gen-id
- (fn [state]
- (let [seed (get$ $seed state)]
- (return* (set$ $seed (inc seed) state) seed))))
-
-(defn ->seq [xs]
- (|case xs
- ($Nil)
- (list)
-
- ($Cons x xs*)
- (cons x (->seq xs*))))
-
-(defn ->list [seq]
- (if (empty? seq)
- $Nil
- ($Cons (first seq) (->list (rest seq)))))
-
-(defn |repeat [n x]
- (if (> n 0)
- ($Cons x (|repeat (dec n) x))
- $Nil))
-
-(def get-module-name
- (fn [state]
- (|case (|reverse (get$ $scopes state))
- ($Nil)
- ((fail-with-loc "[Analyser Error] Can't get the module-name without a module.") state)
-
- ($Cons ?global _)
- (return* state (|head (get$ $name ?global))))))
-
-(defn find-module [name]
- "(-> Text (Lux (Module Compiler)))"
- (fn [state]
- (if-let [module (|get name (get$ $modules state))]
- (return* state module)
- ((fail-with-loc (str "[Error] Unknown module: " name)) state))))
-
-(def get-current-module
- "(Lux (Module Compiler))"
- (|do [module-name get-module-name]
- (find-module module-name)))
-
-(defn with-scope [name body]
- (fn [state]
- (let [old-name (->> state (get$ $scopes) |head (get$ $name))
- output (body (update$ $scopes #($Cons (env name old-name) %) state))]
- (|case output
- ($Right state* datum)
- (return* (update$ $scopes |tail state*) datum)
-
- _
- output))))
-
-(defn run-state [monad state]
- (monad state))
-
-(defn with-closure [body]
- (|do [closure-name (|do [top get-top-local-env]
- (return (->> top (get$ $inner-closures) str)))]
- (fn [state]
- (let [body* (with-scope closure-name body)]
- (run-state body* (update$ $scopes #($Cons (update$ $inner-closures inc (|head %))
- (|tail %))
- state))))))
-
-(defn without-repl-closure [body]
- (|do [_mode get-mode]
- (fn [state]
- (let [output (body (if (in-repl? _mode)
- (update$ $scopes |tail state)
- state))]
- (|case output
- ($Right state* datum)
- (return* (set$ $scopes (get$ $scopes state) state*) datum)
-
- _
- output)))))
-
-(defn without-repl [body]
- (|do [_mode get-mode]
- (fn [state]
- (let [output (body (if (in-repl? _mode)
- (update$ $info #(set$ $compiler-mode $Debug %) state)
- state))]
- (|case output
- ($Right state* datum)
- (return* (update$ $info #(set$ $compiler-mode _mode %) state*) datum)
-
- _
- output)))))
-
-(def get-scope-name
- (fn [state]
- (return* state (->> state (get$ $scopes) |head (get$ $name)))))
-
-(defn with-writer [writer body]
- (fn [state]
- (let [old-writer (->> state (get$ $host) (get$ $writer))
- output (body (update$ $host #(set$ $writer ($Some writer) %) state))]
- (|case output
- ($Right ?state ?value)
- (return* (update$ $host #(set$ $writer old-writer %) ?state)
- ?value)
-
- _
- output))))
-
-(defn with-expected-type [type body]
- "(All [a] (-> Type (Lux a)))"
- (fn [state]
- (let [output (body (set$ $expected ($Some type) state))]
- (|case output
- ($Right ?state ?value)
- (return* (set$ $expected (get$ $expected state) ?state)
- ?value)
-
- _
- output))))
-
-(defn with-cursor [^objects cursor body]
- "(All [a] (-> Cursor (Lux a)))"
- (|let [[_file-name _ _] cursor]
- (if (= "" _file-name)
- body
- (fn [state]
- (let [output (body (set$ $cursor cursor state))]
- (|case output
- ($Right ?state ?value)
- (return* (set$ $cursor (get$ $cursor state) ?state)
- ?value)
-
- _
- output))))))
-
-(defn with-analysis-meta [^objects cursor type body]
- "(All [a] (-> Cursor Type (Lux a)))"
- (|let [[_file-name _ _] cursor]
- (if (= "" _file-name)
- (fn [state]
- (let [output (body (->> state
- (set$ $expected ($Some type))))]
- (|case output
- ($Right ?state ?value)
- (return* (->> ?state
- (set$ $expected (get$ $expected state)))
- ?value)
-
- _
- output)))
- (fn [state]
- (let [output (body (->> state
- (set$ $cursor cursor)
- (set$ $expected ($Some type))))]
- (|case output
- ($Right ?state ?value)
- (return* (->> ?state
- (set$ $cursor (get$ $cursor state))
- (set$ $expected (get$ $expected state)))
- ?value)
-
- _
- output))))))
-
-(def ensure-statement
- "(Lux Unit)"
- (fn [state]
- (|case (get$ $expected state)
- ($None)
- (return* state unit-tag)
-
- ($Some _)
- ((fail-with-loc "[Error] All statements must be top-level forms.") state))))
-
-(def cursor
- ;; (Lux Cursor)
- (fn [state]
- (return* state (get$ $cursor state))))
-
-(let [remove-trailing-0s (fn [^String input]
- (-> input
- (.split "0*$")
- (aget 0)))
- make-text-start-0 (fn [input]
- (loop [accum ""
- range 10]
- (if (< input range)
- (recur (.concat accum "0")
- (* 10 range))
- accum)))
- count-bin-start-0 (fn [input]
- (loop [counter 0
- idx 63]
- (if (and (> idx -1)
- (not (bit-test input idx)))
- (recur (inc counter)
- (dec idx))
- counter)))
- read-frac-text (fn [^String input]
- (let [output* (.split input "0*$")]
- (if (= 0 (alength output*))
- (Long/parseUnsignedLong (aget output* 0))
- (Long/parseUnsignedLong input))))
- count-leading-0s (fn [^String input]
- (let [parts (.split input "^0*")]
- (if (= 2 (alength parts))
- (.length ^String (aget parts 0))
- 0)))]
- (defn encode-frac [input]
- (if (= 0 input)
- ".0"
- (let [^String prefix (->> (count-bin-start-0 input)
- (bit-shift-left 1)
- (make-text-start-0))]
- (->> input
- (Long/toUnsignedString)
- remove-trailing-0s
- (.concat prefix)))))
-
- (defn decode-frac [input]
- (if-let [[_ frac-text] (re-find #"^\.(.+)$" input)]
- (let [output* (-> frac-text
- (string/replace #",_" "")
- read-frac-text)
- rows-to-move-forward (count-bin-start-0 output*)
- scaling-factor (long (Math/pow 10.0 (double (count-leading-0s input))))]
- (-> output*
- (bit-shift-left rows-to-move-forward)
- (/ scaling-factor)))
- (assert false (str "Invalid Frac syntax: " input))))
- )
-
-(defn show-ast [ast]
- (|case ast
- [_ ($BoolS ?value)]
- (pr-str ?value)
-
- [_ ($NatS ?value)]
- (str "+" (Long/toUnsignedString ?value))
-
- [_ ($IntS ?value)]
- (pr-str ?value)
-
- [_ ($FracS ?value)]
- (encode-frac ?value)
-
- [_ ($RealS ?value)]
- (pr-str ?value)
-
- [_ ($CharS ?value)]
- (str "#\"" (pr-str ?value) "\"")
-
- [_ ($TextS ?value)]
- (str "\"" ?value "\"")
-
- [_ ($TagS ?module ?tag)]
- (if (.equals "" ?module)
- (str "#" ?tag)
- (str "#" ?module ";" ?tag))
-
- [_ ($SymbolS ?module ?name)]
- (if (.equals "" ?module)
- ?name
- (str ?module ";" ?name))
-
- [_ ($TupleS ?elems)]
- (str "[" (->> ?elems (|map show-ast) (|interpose " ") (fold str "")) "]")
-
- [_ ($RecordS ?elems)]
- (str "{" (->> ?elems
- (|map (fn [elem]
- (|let [[k v] elem]
- (str (show-ast k) " " (show-ast v)))))
- (|interpose " ") (fold str "")) "}")
-
- [_ ($FormS ?elems)]
- (str "(" (->> ?elems (|map show-ast) (|interpose " ") (fold str "")) ")")
-
- _
- (assert false (prn-str 'show-ast (adt->text ast)))
- ))
-
-(defn ident->text [ident]
- (|let [[?module ?name] ident]
- (if (= "" ?module)
- ?name
- (str ?module ";" ?name))))
-
-(defn fold2% [f init xs ys]
- (|case [xs ys]
- [($Cons x xs*) ($Cons y ys*)]
- (|do [init* (f init x y)]
- (fold2% f init* xs* ys*))
-
- [($Nil) ($Nil)]
- (return init)
-
- [_ _]
- (assert false "Lists don't match in size.")))
-
-(defn map2% [f xs ys]
- (|case [xs ys]
- [($Cons x xs*) ($Cons y ys*)]
- (|do [z (f x y)
- zs (map2% f xs* ys*)]
- (return ($Cons z zs)))
-
- [($Nil) ($Nil)]
- (return $Nil)
-
- [_ _]
- (assert false "Lists don't match in size.")))
-
-(defn map2 [f xs ys]
- (|case [xs ys]
- [($Cons x xs*) ($Cons y ys*)]
- ($Cons (f x y) (map2 f xs* ys*))
-
- [_ _]
- $Nil))
-
-(defn fold2 [f init xs ys]
- (|case [xs ys]
- [($Cons x xs*) ($Cons y ys*)]
- (and init
- (fold2 f (f init x y) xs* ys*))
-
- [($Nil) ($Nil)]
- init
-
- [_ _]
- init
- ;; (assert false)
- ))
-
-(defn ^:private enumerate* [idx xs]
- "(All [a] (-> Int (List a) (List (, Int a))))"
- (|case xs
- ($Cons x xs*)
- ($Cons (T [idx x])
- (enumerate* (inc idx) xs*))
-
- ($Nil)
- xs
- ))
-
-(defn enumerate [xs]
- "(All [a] (-> (List a) (List (, Int a))))"
- (enumerate* 0 xs))
-
-(def modules
- "(Lux (List Text))"
- (fn [state]
- (return* state (|keys (get$ $modules state)))))
-
-(defn when% [test body]
- "(-> Bool (Lux Unit) (Lux Unit))"
- (if test
- body
- (return unit-tag)))
-
-(defn |at [idx xs]
- "(All [a] (-> Int (List a) (Maybe a)))"
- (|case xs
- ($Cons x xs*)
- (cond (< idx 0)
- $None
-
- (= idx 0)
- ($Some x)
-
- :else ;; > 1
- (|at (dec idx) xs*))
-
- ($Nil)
- $None
- ))
-
-(defn normalize [ident]
- "(-> Ident (Lux Ident))"
- (|case ident
- ["" name] (|do [module get-module-name]
- (return (T [module name])))
- _ (return ident)))
-
-(defn ident= [x y]
- (|let [[xmodule xname] x
- [ymodule yname] y]
- (and (= xmodule ymodule)
- (= xname yname))))
-
-(defn |list-put [idx val xs]
- (|case xs
- ($Nil)
- $None
-
- ($Cons x xs*)
- (if (= idx 0)
- ($Some ($Cons val xs*))
- (|case (|list-put (dec idx) val xs*)
- ($None) $None
- ($Some xs**) ($Some ($Cons x xs**)))
- )))
-
-(do-template [<flagger> <asker> <tag>]
- (do (defn <flagger> [module]
- "(-> Text (Lux Unit))"
- (fn [state]
- (let [state* (update$ $host (fn [host]
- (update$ $module-states
- (fn [module-states]
- (|put module <tag> module-states))
- host))
- state)]
- ($Right (T [state* unit-tag])))))
- (defn <asker> [module]
- "(-> Text (Lux Bool))"
- (fn [state]
- (if-let [module-state (->> state (get$ $host) (get$ $module-states) (|get module))]
- ($Right (T [state (|case module-state
- (<tag>) true
- _ false)]))
- ($Right (T [state false])))
- )))
-
- flag-active-module active-module? $Active
- flag-compiled-module compiled-module? $Compiled
- flag-cached-module cached-module? $Cached
- )
-
-(do-template [<name> <default> <op>]
- (defn <name> [p xs]
- "(All [a] (-> (-> a Bool) (List a) Bool))"
- (|case xs
- ($Nil)
- <default>
-
- ($Cons x xs*)
- (<op> (p x) (<name> p xs*))))
-
- |every? true and
- |any? false or)
-
-(defn m-comp [f g]
- "(All [a b c] (-> (-> b (Lux c)) (-> a (Lux b)) (-> a (Lux c))))"
- (fn [x]
- (|do [y (g x)]
- (f y))))
-
-(defn with-attempt [m-value on-error]
- "(All [a] (-> (Lux a) (-> Text (Lux a)) (Lux a)))"
- (fn [state]
- (|case (m-value state)
- ($Left msg)
- ((on-error msg) state)
-
- output
- output)))
-
-(defn |some [f xs]
- "(All [a b] (-> (-> a (Maybe b)) (List a) (Maybe b)))"
- (|case xs
- ($Nil)
- $None
-
- ($Cons x xs*)
- (|case (f x)
- ($None) (|some f xs*)
- output output)
- ))
-
-(def get-type-env
- "(Lux TypeEnv)"
- (fn [state]
- (return* state (->> state (get$ $host) (get$ $type-env)))))
-
-(defn with-type-env [type-env body]
- "(All [a] (-> TypeEnv (Lux a) (Lux a)))"
- (fn [state]
- (|let [state* (update$ $host #(update$ $type-env (partial |++ type-env) %)
- state)]
- (|case (body state*)
- ($Right [state** output])
- ($Right (T [(update$ $host
- #(set$ $type-env
- (->> state (get$ $host) (get$ $type-env))
- %)
- state**)
- output]))
-
- ($Left msg)
- ($Left msg)))))
-
-(defn |take [n xs]
- (|case (T [n xs])
- [0 _] $Nil
- [_ ($Nil)] $Nil
- [_ ($Cons x xs*)] ($Cons x (|take (dec n) xs*))
- ))
-
-(defn |drop [n xs]
- (|case (T [n xs])
- [0 _] xs
- [_ ($Nil)] $Nil
- [_ ($Cons x xs*)] (|drop (dec n) xs*)
- ))
-
-(defn |but-last [xs]
- (|case xs
- ($Nil)
- $Nil
-
- ($Cons x ($Nil))
- $Nil
-
- ($Cons x xs*)
- ($Cons x (|but-last xs*))
-
- _
- (assert false (adt->text xs))))
-
-(defn |last [xs]
- (|case xs
- ($Cons x ($Nil))
- x
-
- ($Cons x xs*)
- (|last xs*)
-
- _
- (assert false (adt->text xs))))
-
-(defn |partition [n xs]
- (->> xs ->seq (partition-all n) (map ->list) ->list))
-
-(defn with-scope-type-var [id body]
- (fn [state]
- (|case (body (set$ $scope-type-vars
- ($Cons id (get$ $scope-type-vars state))
- state))
- ($Right [state* output])
- ($Right (T [(set$ $scope-type-vars
- (get$ $scope-type-vars state)
- state*)
- output]))
-
- ($Left msg)
- ($Left msg))))
-
-(defn push-dummy-name [real-name store-name]
- (fn [state]
- ($Right (T [(update$ $host
- #(update$ $dummy-mappings
- (partial $Cons (T [real-name store-name]))
- %)
- state)
- nil]))))
-
-(def pop-dummy-name
- (fn [state]
- ($Right (T [(update$ $host
- #(update$ $dummy-mappings
- |tail
- %)
- state)
- nil]))))
-
-(defn de-alias-class [class-name]
- (fn [state]
- ($Right (T [state
- (|case (|some #(|let [[real-name store-name] %]
- (if (= real-name class-name)
- ($Some store-name)
- $None))
- (->> state (get$ $host) (get$ $dummy-mappings)))
- ($Some store-name)
- store-name
-
- _
- class-name)]))))
-
-(let [!out! *out*]
- (defn |log! [& parts]
- (binding [*out* !out!]
- (do (print (apply str parts))
- (flush)))))
diff --git a/src/lux/compiler.clj b/src/lux/compiler.clj
deleted file mode 100644
index d8c5e4571..000000000
--- a/src/lux/compiler.clj
+++ /dev/null
@@ -1,268 +0,0 @@
-;; Copyright (c) Eduardo Julian. All rights reserved.
-;; This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0.
-;; If a copy of the MPL was not distributed with this file,
-;; You can obtain one at http://mozilla.org/MPL/2.0/.
-
-(ns lux.compiler
- (:refer-clojure :exclude [compile])
- (:require (clojure [string :as string]
- [set :as set]
- [template :refer [do-template]])
- clojure.core.match
- clojure.core.match.array
- (lux [base :as & :refer [|let |do return* return fail fail* |case]]
- [type :as &type]
- [reader :as &reader]
- [lexer :as &lexer]
- [parser :as &parser]
- [analyser :as &analyser]
- [optimizer :as &optimizer]
- [host :as &host])
- [lux.host.generics :as &host-generics]
- [lux.optimizer :as &o]
- [lux.analyser.base :as &a]
- [lux.analyser.module :as &a-module]
- (lux.compiler [base :as &&]
- [cache :as &&cache]
- [lux :as &&lux]
- [host :as &&host]
- [case :as &&case]
- [lambda :as &&lambda]
- [module :as &&module]
- [io :as &&io]
- [parallel :as &&parallel])
- (lux.compiler.cache [type :as &&&type]
- [ann :as &&&ann]))
- (:import (org.objectweb.asm Opcodes
- Label
- ClassWriter
- MethodVisitor)))
-
-;; [Resources]
-(def ^:private !source->last-line (atom nil))
-
-(defn compile-expression [$begin syntax]
- (|let [[[?type [_file-name _line _]] ?form] syntax]
- (|do [^MethodVisitor *writer* &/get-writer
- :let [debug-label (new Label)
- _ (when (not= _line (get @!source->last-line _file-name))
- (doto *writer*
- (.visitLabel debug-label)
- (.visitLineNumber (int _line) debug-label))
- (swap! !source->last-line assoc _file-name _line))]]
- (|case ?form
- (&o/$bool ?value)
- (&&lux/compile-bool ?value)
-
- (&o/$nat ?value)
- (&&lux/compile-nat ?value)
-
- (&o/$int ?value)
- (&&lux/compile-int ?value)
-
- (&o/$frac ?value)
- (&&lux/compile-frac ?value)
-
- (&o/$real ?value)
- (&&lux/compile-real ?value)
-
- (&o/$char ?value)
- (&&lux/compile-char ?value)
-
- (&o/$text ?value)
- (&&lux/compile-text ?value)
-
- (&o/$tuple ?elems)
- (&&lux/compile-tuple (partial compile-expression $begin) ?elems)
-
- (&o/$var (&/$Local ?idx))
- (&&lux/compile-local (partial compile-expression $begin) ?idx)
-
- (&o/$captured ?scope ?captured-id ?source)
- (&&lux/compile-captured (partial compile-expression $begin) ?scope ?captured-id ?source)
-
- (&o/$var (&/$Global ?owner-class ?name))
- (&&lux/compile-global (partial compile-expression $begin) ?owner-class ?name)
-
- (&o/$apply ?fn ?args)
- (&&lux/compile-apply (partial compile-expression $begin) ?fn ?args)
-
- (&o/$loop _register-offset _inits _body)
- (&&lux/compile-loop compile-expression _register-offset _inits _body)
-
- (&o/$iter _register-offset ?args)
- (&&lux/compile-iter (partial compile-expression $begin) $begin _register-offset ?args)
-
- (&o/$variant ?tag ?tail ?members)
- (&&lux/compile-variant (partial compile-expression $begin) ?tag ?tail ?members)
-
- (&o/$case ?value [?pm ?bodies])
- (&&case/compile-case (partial compile-expression $begin) ?value ?pm ?bodies)
-
- (&o/$let _value _register _body)
- (&&lux/compile-let (partial compile-expression $begin) _value _register _body)
-
- (&o/$record-get _value _path)
- (&&lux/compile-record-get (partial compile-expression $begin) _value _path)
-
- (&o/$if _test _then _else)
- (&&lux/compile-if (partial compile-expression $begin) _test _then _else)
-
- (&o/$function _register-offset ?arity ?scope ?env ?body)
- (&&lambda/compile-function compile-expression &/$None ?arity ?scope ?env ?body)
-
- (&o/$ann ?value-ex ?type-ex)
- (compile-expression $begin ?value-ex)
-
- (&o/$proc [?proc-category ?proc-name] ?args special-args)
- (&&host/compile-host (partial compile-expression $begin) ?proc-category ?proc-name ?args special-args)
-
- _
- (assert false (prn-str 'compile-expression (&/adt->text syntax)))
- ))
- ))
-
-(defn init!
- "(-> (List Text) Null)"
- [resources-dirs target-dir]
- (do (reset! &&/!output-dir target-dir)
- (&&parallel/setup!)
- (reset! !source->last-line {})
- (.mkdirs (java.io.File. target-dir))
- (let [class-loader (ClassLoader/getSystemClassLoader)
- addURL (doto (.getDeclaredMethod java.net.URLClassLoader "addURL" (into-array [java.net.URL]))
- (.setAccessible true))]
- (doseq [resources-dir (&/->seq resources-dirs)]
- (.invoke addURL class-loader
- (to-array [(->> resources-dir (new java.io.File) .toURI .toURL)]))))))
-
-(defn eval! [expr]
- (&/with-eval
- (|do [module &/get-module-name
- id &/gen-id
- [file-name _ _] &/cursor
- :let [class-name (str (&host/->module-class module) "/" id)
- =class (doto (new ClassWriter ClassWriter/COMPUTE_MAXS)
- (.visit &host/bytecode-version (+ Opcodes/ACC_PUBLIC Opcodes/ACC_SUPER)
- class-name nil "java/lang/Object" nil)
- (-> (.visitField (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_STATIC) &/eval-field "Ljava/lang/Object;" nil nil)
- (doto (.visitEnd)))
- (.visitSource file-name nil))]
- _ (&/with-writer (.visitMethod =class Opcodes/ACC_STATIC "<clinit>" "()V" nil nil)
- (|do [^MethodVisitor *writer* &/get-writer
- :let [_ (.visitCode *writer*)]
- _ (compile-expression nil expr)
- :let [_ (doto *writer*
- (.visitFieldInsn Opcodes/PUTSTATIC class-name &/eval-field "Ljava/lang/Object;")
- (.visitInsn Opcodes/RETURN)
- (.visitMaxs 0 0)
- (.visitEnd))]]
- (return nil)))
- :let [bytecode (.toByteArray (doto =class
- .visitEnd))]
- _ (&&/save-class! (str id) bytecode)
- loader &/loader]
- (-> (.loadClass ^ClassLoader loader (str (&host-generics/->class-name module) "." id))
- (.getField &/eval-field)
- (.get nil)
- return))))
-
-(def all-compilers
- (let [compile-expression* (partial compile-expression nil)]
- (&/T [(partial &&lux/compile-def compile-expression)
- (partial &&lux/compile-program compile-expression*)
- (partial &&host/compile-jvm-class compile-expression*)
- &&host/compile-jvm-interface])))
-
-(let [+field-flags+ (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_STATIC)
- +datum-sig+ "Ljava/lang/Object;"]
- (defn compile-module [source-dirs name]
- (let [file-name (str name ".lux")]
- (|do [file-content (&&io/read-file source-dirs file-name)
- :let [file-hash (hash file-content)
- ;; compile-module!! (&&parallel/parallel-compilation (partial compile-module source-dirs))
- compile-module!! (partial compile-module source-dirs)]]
- (if (&&cache/cached? name)
- (&&cache/load source-dirs name file-hash compile-module!!)
- (let [compiler-step (&analyser/analyse &optimizer/optimize eval! compile-module!! all-compilers)]
- (|do [module-exists? (&a-module/exists? name)]
- (if module-exists?
- (fail "[Compiler Error] Can't redefine a module!")
- (|do [_ (&&cache/delete name)
- _ (&a-module/create-module name file-hash)
- _ (&/flag-active-module name)
- :let [module-class-name (str (&host/->module-class name) "/_")
- =class (doto (new ClassWriter ClassWriter/COMPUTE_MAXS)
- (.visit &host/bytecode-version (+ Opcodes/ACC_PUBLIC Opcodes/ACC_SUPER)
- module-class-name nil "java/lang/Object" nil)
- (-> (.visitField +field-flags+ &/hash-field "I" nil file-hash)
- .visitEnd)
- (-> (.visitField +field-flags+ &/compiler-field "Ljava/lang/String;" nil &/compiler-version)
- .visitEnd)
- (.visitSource file-name nil))]
- _ (if (= "lux" name)
- (|do [_ &&host/compile-Function-class
- _ &&host/compile-LuxRT-class]
- (return nil))
- (return nil))]
- (fn [state]
- (|case ((&/with-writer =class
- (&/exhaust% compiler-step))
- (&/set$ &/$source (&reader/from name file-content) state))
- (&/$Right ?state _)
- (&/run-state (|do [:let [_ (.visitEnd =class)]
- module-anns (&a-module/get-anns name)
- defs &a-module/defs
- imports &a-module/imports
- tag-groups &&module/tag-groups
- :let [def-entries (->> defs
- (&/|map (fn [_def]
- (|let [[?name ?alias [?def-type ?def-anns ?def-value]] _def]
- (if (= "" ?alias)
- (str ?name &&/datum-separator (&&&type/serialize-type ?def-type) &&/datum-separator (&&&ann/serialize-anns ?def-anns))
- (str ?name &&/datum-separator ?alias)))))
- (&/|interpose &&/entry-separator)
- (&/fold str ""))
- import-entries (->> imports
- (&/|map (fn [import]
- (|let [[_module _hash] import]
- (str _module &&/datum-separator _hash))))
- (&/|interpose &&/entry-separator)
- (&/fold str ""))
- tag-entries (->> tag-groups
- (&/|map (fn [group]
- (|let [[type tags] group]
- (->> tags
- (&/|interpose &&/datum-separator)
- (&/fold str "")
- (str type &&/datum-separator)))))
- (&/|interpose &&/entry-separator)
- (&/fold str ""))
- module-descriptor (->> (&/|list import-entries
- tag-entries
- (&&&ann/serialize-anns module-anns)
- def-entries)
- (&/|interpose &&/section-separator)
- (&/fold str ""))]
- _ (&/flag-compiled-module name)
- _ (&&/save-class! &/module-class-name (.toByteArray =class))
- _ (&&/write-module-descriptor! name module-descriptor)]
- (return file-hash))
- ?state)
-
- (&/$Left ?message)
- (fail* ?message)))))))
- ))
- )))
-
-(defn compile-program [mode program-module resources-dir source-dirs target-dir]
- (do (init! resources-dir target-dir)
- (let [m-action (|do [_ (compile-module source-dirs "lux")]
- (compile-module source-dirs program-module))]
- (|case (m-action (&/init-state mode))
- (&/$Right ?state _)
- (do (println "Compilation complete!")
- (&&cache/clean ?state))
-
- (&/$Left ?message)
- (assert false ?message)))))
diff --git a/src/lux/compiler/base.clj b/src/lux/compiler/base.clj
deleted file mode 100644
index e57571fef..000000000
--- a/src/lux/compiler/base.clj
+++ /dev/null
@@ -1,116 +0,0 @@
-;; Copyright (c) Eduardo Julian. All rights reserved.
-;; This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0.
-;; If a copy of the MPL was not distributed with this file,
-;; You can obtain one at http://mozilla.org/MPL/2.0/.
-
-(ns lux.compiler.base
- (:require (clojure [template :refer [do-template]]
- [string :as string])
- [clojure.java.io :as io]
- [clojure.core.match :as M :refer [matchv]]
- clojure.core.match.array
- (lux [base :as & :refer [|let |do return* return fail fail*]]
- [type :as &type]
- [host :as &host])
- (lux.analyser [base :as &a]
- [module :as &a-module])
- [lux.host.generics :as &host-generics])
- (:import (org.objectweb.asm Opcodes
- Label
- ClassWriter
- MethodVisitor)
- (java.io File
- BufferedOutputStream
- FileOutputStream)
- (java.lang.reflect Field)))
-
-;; [Constants]
-(def !output-dir (atom nil))
-
-(def ^:const ^String function-class "lux/Function")
-(def ^:const ^String lux-utils-class "lux/LuxRT")
-(def ^:const ^String unit-tag-field "unit_tag")
-
-;; Formats
-(def ^:const ^String local-prefix "l")
-(def ^:const ^String partial-prefix "p")
-(def ^:const ^String closure-prefix "c")
-(def ^:const ^String apply-method "apply")
-(defn ^String apply-signature [n]
- (str "(" (apply str (repeat n "Ljava/lang/Object;")) ")Ljava/lang/Object;"))
-(def ^:const num-apply-variants 8)
-(def ^:const arity-field "_arity_")
-(def ^:const partials-field "_partials_")
-
-(def ^:const section-separator (->> 29 char str))
-(def ^:const datum-separator (->> 31 char str))
-(def ^:const entry-separator (->> 30 char str))
-
-;; [Utils]
-(defn ^:private write-file [^String file-name ^bytes data]
- (do (assert (not (.exists (File. file-name))) (str "Can't overwrite file: " file-name))
- (with-open [stream (BufferedOutputStream. (FileOutputStream. file-name))]
- (.write stream data))))
-
-(defn ^:private write-output [module name data]
- (let [module* (&host/->module-class module)
- module-dir (str @!output-dir "/" module*)]
- (.mkdirs (File. module-dir))
- (write-file (str module-dir "/" name ".class") data)))
-
-(defn class-exists? [^String module ^String class-name]
- "(-> Text Text (IO Bool))"
- (|do [_ (return nil)
- :let [full-path (str @!output-dir "/" module "/" class-name ".class")
- exists? (.exists (File. full-path))]]
- (return exists?)))
-
-;; [Exports]
-(defn ^Class load-class! [^ClassLoader loader name]
- ;; (prn 'load-class! name)
- (.loadClass loader name))
-
-(defn save-class! [name bytecode]
- (|do [eval? &/get-eval
- module &/get-module-name
- loader &/loader
- !classes &/classes
- :let [real-name (str (&host-generics/->class-name module) "." name)
- _ (swap! !classes assoc real-name bytecode)
- _ (when (not eval?)
- (write-output module name bytecode))
- _ (load-class! loader real-name)]]
- (return nil)))
-
-(def ^String lux-module-descriptor-name "lux_module_descriptor")
-
-(defn write-module-descriptor! [^String name ^String descriptor]
- (|do [_ (return nil)
- :let [lmd-dir (str @!output-dir "/" name)
- _ (.mkdirs (File. lmd-dir))
- _ (write-file (str lmd-dir "/" lux-module-descriptor-name) (.getBytes descriptor java.nio.charset.StandardCharsets/UTF_8))]]
- (return nil)))
-
-(defn read-module-descriptor! [^String name]
- (|do [_ (return nil)]
- (return (slurp (str @!output-dir "/" name "/" lux-module-descriptor-name)
- :encoding "UTF-8"))))
-
-(do-template [<wrap-name> <unwrap-name> <class> <unwrap-method> <prim> <dup>]
- (do (defn <wrap-name> [^MethodVisitor writer]
- (doto writer
- (.visitMethodInsn Opcodes/INVOKESTATIC <class> "valueOf" (str "(" <prim> ")" (&host-generics/->type-signature <class>)))))
- (defn <unwrap-name> [^MethodVisitor writer]
- (doto writer
- (.visitTypeInsn Opcodes/CHECKCAST <class>)
- (.visitMethodInsn Opcodes/INVOKEVIRTUAL <class> <unwrap-method> (str "()" <prim>)))))
-
- wrap-boolean unwrap-boolean "java/lang/Boolean" "booleanValue" "Z" Opcodes/DUP_X1
- wrap-byte unwrap-byte "java/lang/Byte" "byteValue" "B" Opcodes/DUP_X1
- wrap-short unwrap-short "java/lang/Short" "shortValue" "S" Opcodes/DUP_X1
- wrap-int unwrap-int "java/lang/Integer" "intValue" "I" Opcodes/DUP_X1
- wrap-long unwrap-long "java/lang/Long" "longValue" "J" Opcodes/DUP_X2
- wrap-float unwrap-float "java/lang/Float" "floatValue" "F" Opcodes/DUP_X1
- wrap-double unwrap-double "java/lang/Double" "doubleValue" "D" Opcodes/DUP_X2
- wrap-char unwrap-char "java/lang/Character" "charValue" "C" Opcodes/DUP_X1
- )
diff --git a/src/lux/compiler/cache.clj b/src/lux/compiler/cache.clj
deleted file mode 100644
index 6c44e2a45..000000000
--- a/src/lux/compiler/cache.clj
+++ /dev/null
@@ -1,188 +0,0 @@
-;; Copyright (c) Eduardo Julian. All rights reserved.
-;; This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0.
-;; If a copy of the MPL was not distributed with this file,
-;; You can obtain one at http://mozilla.org/MPL/2.0/.
-
-(ns lux.compiler.cache
- (:refer-clojure :exclude [load])
- (:require [clojure.string :as string]
- [clojure.java.io :as io]
- clojure.core.match
- clojure.core.match.array
- (lux [base :as & :refer [|do return* return fail fail* |case |let]]
- [type :as &type]
- [host :as &host])
- [lux.host.generics :as &host-generics]
- (lux.analyser [base :as &a]
- [module :as &a-module]
- [meta :as &a-meta])
- (lux.compiler [base :as &&]
- [io :as &&io])
- (lux.compiler.cache [type :as &&&type]
- [ann :as &&&ann]))
- (:import (java.io File
- BufferedOutputStream
- FileOutputStream)
- (java.lang.reflect Field)))
-
-;; [Utils]
-(defn ^:private read-file [^File file]
- "(-> File (Array Byte))"
- (with-open [reader (io/input-stream file)]
- (let [length (.length file)
- buffer (byte-array length)]
- (.read reader buffer 0 length)
- buffer)))
-
-(defn ^:private clean-file [^File file]
- "(-> File (,))"
- (doseq [^File f (seq (.listFiles file))
- :when (not (.isDirectory f))]
- (.delete f)))
-
-(defn ^:private get-field [^String field-name ^Class class]
- "(-> Text Class Object)"
- (-> class ^Field (.getField field-name) (.get nil)))
-
-;; [Resources]
-(def module-class (str &/module-class-name ".class"))
-
-(defn cached? [module]
- "(-> Text Bool)"
- (.exists (new File (str @&&/!output-dir "/" (&host/->module-class module) "/" module-class)))
- ;; false
- )
-
-(defn delete [module]
- "(-> Text (Lux Null))"
- (fn [state]
- (do (clean-file (new File (str @&&/!output-dir "/" (&host/->module-class module))))
- (return* state nil))))
-
-(defn ^:private module-dirs
- "(-> File (clojure.Seq File))"
- [^File module]
- (->> module
- .listFiles
- (filter #(.isDirectory %))
- (map module-dirs)
- (apply concat)
- (list* module)))
-
-(defn clean [state]
- "(-> Compiler Null)"
- (let [needed-modules (->> state (&/get$ &/$modules) &/|keys &/->seq set)
- output-dir-prefix (str (.getAbsolutePath (new File @&&/!output-dir)) "/")
- outdated? #(->> % (contains? needed-modules) not)
- outdated-modules (->> (new File @&&/!output-dir)
- .listFiles (filter #(.isDirectory %))
- (map module-dirs) doall (apply concat)
- (map #(-> ^File % .getAbsolutePath (string/replace output-dir-prefix "")))
- (filter outdated?))]
- (doseq [^String f outdated-modules]
- (clean-file (new File (str output-dir-prefix f))))
- nil))
-
-(defn ^:private install-all-classes-in-module [!classes module* ^String module-path]
- (doseq [^File file (seq (.listFiles (File. module-path)))
- :when (not (.isDirectory file))
- :let [file-name (.getName file)]
- :when (not= module-class file-name)]
- (let [real-name (second (re-find #"^(.*)\.class$" file-name))
- bytecode (read-file file)]
- (swap! !classes assoc (str module* "." real-name) bytecode))))
-
-(defn ^:private assume-async-result
- "(-> (Error Compiler) (Lux Null))"
- [result]
- (fn [_]
- (|case result
- (&/$Left error)
- (&/$Left error)
-
- (&/$Right compiler)
- (return* compiler nil))))
-
-(defn load [source-dirs module module-hash compile-module]
- "(-> (List Text) Text Int (-> Text (Lux (,))) (Lux Bool))"
- (|do [already-loaded? (&a-module/exists? module)]
- (if already-loaded?
- (return module-hash)
- (|let [redo-cache (|do [_ (delete module)
- ;; async (compile-module module)
- ]
- ;; (assume-async-result @async)
- (compile-module module))]
- (if (cached? module)
- (|do [loader &/loader
- !classes &/classes
- :let [module* (&host-generics/->class-name module)
- module-path (str @&&/!output-dir "/" module)
- class-name (str module* "._")
- old-classes @!classes
- ^Class module-class (do (swap! !classes assoc class-name (read-file (File. (str module-path "/_.class"))))
- (&&/load-class! loader class-name))
- _ (install-all-classes-in-module !classes module* module-path)]]
- (if (and (= module-hash (get-field &/hash-field module-class))
- (= &/compiler-version (get-field &/compiler-field module-class)))
- (|do [^String descriptor (&&/read-module-descriptor! module)
- :let [sections (.split descriptor &&/section-separator)
- [^String imports-section ^String tags-section module-anns-section ^String defs-section] sections
- imports (vec (.split imports-section &&/entry-separator))]
- loads (&/map% (fn [^String _import]
- (let [[_module _hash] (.split _import &&/datum-separator 2)]
- (|do [file-content (&&io/read-file source-dirs (str _module ".lux"))
- :let [file-hash (hash file-content)
- __hash (Integer/parseInt _hash)]
- _ (load source-dirs _module file-hash compile-module)
- cached? (&/cached-module? _module)
- :let [consistent-cache? (= file-hash __hash)]]
- (return (and cached?
- consistent-cache?)))))
- (if (= [""] imports)
- &/$Nil
- (&/->list imports)))]
- (if (->> loads &/->seq (every? true?))
- (|do [:let [tag-groups (if (= "" tags-section)
- &/$Nil
- (-> tags-section
- (.split &&/entry-separator)
- seq
- (->> (map (fn [^String _group]
- (let [[_type & _tags] (.split _group &&/datum-separator)]
- (&/T [_type (->> _tags seq &/->list)])))))
- &/->list))]
- _ (&a-module/create-module module module-hash)
- _ (&a-module/set-anns (&&&ann/deserialize-anns module-anns-section) module)
- _ (&/flag-cached-module module)
- _ (&a-module/set-imports imports)
- :let [desc-defs (vec (.split defs-section &&/entry-separator))]
- _ (&/map% (fn [^String _def-entry]
- (let [parts (.split _def-entry &&/datum-separator)]
- (case (alength parts)
- 2 (let [[_name _alias] parts
- [_ __module __name] (re-find #"^(.*);(.*)$" _alias)
- def-class (&&/load-class! loader (str (&host-generics/->class-name __module) "." (&host/def-name __name)))
- def-type (&a-module/def-type __module __name)
- def-anns (&/|list (&/T [&a-meta/alias-tag (&/$IdentM (&/T [__module __name]))]))
- def-value (get-field &/value-field def-class)]
- (&a-module/define module _name def-type def-anns def-value))
- 3 (let [[_name _type _anns] parts
- def-class (&&/load-class! loader (str module* "." (&host/def-name _name)))
- [def-anns _] (&&&ann/deserialize-anns _anns)
- [def-type _] (&&&type/deserialize-type _type)
- def-value (get-field &/value-field def-class)]
- (&a-module/define module _name def-type def-anns def-value)))))
- (if (= [""] desc-defs)
- &/$Nil
- (&/->list desc-defs)))
- _ (&/map% (fn [group]
- (|let [[_type _tags] group]
- (|do [[was-exported? =type] (&a-module/type-def module _type)]
- (&a-module/declare-tags module _tags was-exported? =type))))
- tag-groups)]
- (return module-hash))
- redo-cache))
- (do (reset! !classes old-classes)
- redo-cache)))
- redo-cache)))))
diff --git a/src/lux/compiler/cache/ann.clj b/src/lux/compiler/cache/ann.clj
deleted file mode 100644
index d50c02465..000000000
--- a/src/lux/compiler/cache/ann.clj
+++ /dev/null
@@ -1,159 +0,0 @@
-;; Copyright (c) Eduardo Julian. All rights reserved.
-;; This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0.
-;; If a copy of the MPL was not distributed with this file,
-;; You can obtain one at http://mozilla.org/MPL/2.0/.
-
-(ns lux.compiler.cache.ann
- (:require (clojure [template :refer [do-template]]
- [string :as string])
- [clojure.core.match :as M :refer [matchv]]
- clojure.core.match.array
- (lux [base :as & :refer [|let |do return* return fail fail* |case]])))
-
-(def ^:private stop (->> 7 char str))
-(def ^:private cons-signal (->> 5 char str))
-(def ^:private nil-signal (->> 6 char str))
-(def ^:private ident-separator ";")
-
-(defn ^:private serialize-seq [serialize-ann params]
- (str (&/fold (fn [so-far param]
- (str so-far cons-signal (serialize-ann param)))
- ""
- params)
- nil-signal))
-
-(defn ^:private serialize-text [value]
- (str "T" value stop))
-
-(defn ^:private serialize-ident [ident]
- (|let [[module name] ident]
- (str "@" module ident-separator name stop)))
-
-(defn serialize-ann
- "(-> Ann-Value Text)"
- [ann]
- (|case ann
- (&/$BoolM value)
- (str "B" value stop)
-
- (&/$NatM value)
- (str "N" value stop)
-
- (&/$IntM value)
- (str "I" value stop)
-
- (&/$FracM value)
- (str "F" value stop)
-
- (&/$RealM value)
- (str "R" value stop)
-
- (&/$CharM value)
- (str "C" value stop)
-
- (&/$TextM value)
- (serialize-text value)
-
- (&/$IdentM ident)
- (serialize-ident ident)
-
- (&/$ListM elems)
- (str "L" (serialize-seq serialize-ann elems))
-
- (&/$DictM kvs)
- (str "D" (serialize-seq (fn [kv]
- (|let [[k v] kv]
- (str (serialize-text k)
- (serialize-ann v))))
- kvs))
-
- _
- (assert false)
- ))
-
-(defn serialize-anns
- "(-> Anns Text)"
- [anns]
- (serialize-seq (fn [kv]
- (|let [[k v] kv]
- (str (serialize-ident k)
- (serialize-ann v))))
- anns))
-
-(declare deserialize-ann)
-
-(do-template [<name> <signal> <ctor> <parser>]
- (defn <name> [^String input]
- (when (.startsWith input <signal>)
- (let [[value* ^String input*] (.split (.substring input 1) stop 2)]
- [(<ctor> (<parser> value*)) input*])))
-
- ^:private deserialize-bool "B" &/$BoolM Boolean/parseBoolean
- ^:private deserialize-nat "N" &/$NatM Long/parseLong
- ^:private deserialize-int "I" &/$IntM Long/parseLong
- ^:private deserialize-frac "F" &/$FracM Long/parseLong
- ^:private deserialize-real "R" &/$RealM Double/parseDouble
- ^:private deserialize-char "C" &/$CharM (fn [^String input] (.charAt input 0))
- ^:private deserialize-text "T" &/$TextM identity
- )
-
-(defn ^:private deserialize-ident* [^String input]
- (when (.startsWith input "@")
- (let [[ident* ^String input*] (.split (.substring input 1) stop 2)
- [_module _name] (.split ident* ident-separator 2)]
- [(&/T [_module _name]) input*])))
-
-(defn ^:private deserialize-ident [^String input]
- (when (.startsWith input "@")
- (let [[ident* ^String input*] (.split (.substring input 1) stop 2)
- [_module _name] (.split ident* ident-separator 2)]
- [(&/$IdentM (&/T [_module _name])) input*])))
-
-(defn ^:private deserialize-seq [deserializer input]
- (cond (.startsWith input nil-signal)
- [&/$Nil (.substring input 1)]
-
- (.startsWith input cons-signal)
- (when-let [[head ^String input*] (deserializer (.substring input 1))]
- (when-let [[tail ^String input*] (deserialize-seq deserializer input*)]
- [(&/$Cons head tail) input*]))
- ))
-
-(do-template [<name> <deserialize-key>]
- (defn <name> [input]
- (when-let [[key input*] (<deserialize-key> input)]
- (when-let [[ann input*] (deserialize-ann input*)]
- [(&/T [key ann]) input*])))
-
- ^:private deserialize-kv deserialize-text
- ^:private deserialize-ann-entry deserialize-ident*
- )
-
-(do-template [<name> <signal> <type> <deserializer>]
- (defn <name> [^String input]
- (when (.startsWith input <signal>)
- (when-let [[elems ^String input*] (deserialize-seq <deserializer>
- (.substring input 1))]
- [(<type> elems) input*])))
-
- ^:private deserialize-list "L" &/$ListM deserialize-ann
- ^:private deserialize-dict "D" &/$DictM deserialize-kv
- )
-
-(defn ^:private deserialize-ann
- "(-> Text Anns)"
- [input]
- (or (deserialize-bool input)
- (deserialize-nat input)
- (deserialize-int input)
- (deserialize-frac input)
- (deserialize-real input)
- (deserialize-char input)
- (deserialize-text input)
- (deserialize-ident input)
- (deserialize-list input)
- (deserialize-dict input)
- (assert false "[Cache error] Can't deserialize annocation.")))
-
-(defn deserialize-anns [^String input]
- (deserialize-seq deserialize-ann-entry input))
diff --git a/src/lux/compiler/cache/type.clj b/src/lux/compiler/cache/type.clj
deleted file mode 100644
index 80d3a93d6..000000000
--- a/src/lux/compiler/cache/type.clj
+++ /dev/null
@@ -1,164 +0,0 @@
-;; Copyright (c) Eduardo Julian. All rights reserved.
-;; This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0.
-;; If a copy of the MPL was not distributed with this file,
-;; You can obtain one at http://mozilla.org/MPL/2.0/.
-
-(ns lux.compiler.cache.type
- (:require (clojure [template :refer [do-template]]
- [string :as string])
- [clojure.core.match :as M :refer [matchv]]
- clojure.core.match.array
- (lux [base :as & :refer [|let |do return* return fail fail* |case]]
- [type :as &type])))
-
-(def ^:private stop (->> 7 char str))
-(def ^:private cons-signal (->> 5 char str))
-(def ^:private nil-signal (->> 6 char str))
-(def ^:private ident-separator ";")
-
-(defn ^:private serialize-list [serialize-type params]
- (str (&/fold (fn [so-far param]
- (str so-far cons-signal (serialize-type param)))
- ""
- params)
- nil-signal))
-
-(defn serialize-type
- "(-> Type Text)"
- [type]
- (if (clojure.lang.Util/identical &type/Type type)
- "T"
- (|case type
- (&/$HostT name params)
- (str "^" name stop (serialize-list serialize-type params))
-
- (&/$VoidT)
- "0"
-
- (&/$UnitT)
- "1"
-
- (&/$ProdT left right)
- (str "*" (serialize-type left) (serialize-type right))
-
- (&/$SumT left right)
- (str "+" (serialize-type left) (serialize-type right))
-
- (&/$LambdaT left right)
- (str ">" (serialize-type left) (serialize-type right))
-
- (&/$UnivQ env body)
- (str "U" (serialize-list serialize-type env) (serialize-type body))
-
- (&/$ExQ env body)
- (str "E" (serialize-list serialize-type env) (serialize-type body))
-
- (&/$BoundT idx)
- (str "$" idx stop)
-
- (&/$ExT idx)
- (str "!" idx stop)
-
- (&/$VarT idx)
- (str "?" idx stop)
-
- (&/$AppT left right)
- (str "%" (serialize-type left) (serialize-type right))
-
- (&/$NamedT [module name] type*)
- (str "@" module ident-separator name stop (serialize-type type*))
-
- _
- (assert false (prn 'serialize-type (&type/show-type type)))
- )))
-
-(declare deserialize-type)
-
-(defn ^:private deserialize-list [input]
- (cond (.startsWith input nil-signal)
- [&/$Nil (.substring input 1)]
-
- (.startsWith input cons-signal)
- (when-let [[head ^String input*] (deserialize-type (.substring input 1))]
- (when-let [[tail ^String input*] (deserialize-list input*)]
- [(&/$Cons head tail) input*]))
- ))
-
-(do-template [<name> <signal> <type>]
- (defn <name> [^String input]
- (when (.startsWith input <signal>)
- [<type> (.substring input 1)]
- ))
-
- ^:private deserialize-void "0" &/$VoidT
- ^:private deserialize-unit "1" &/$UnitT
- ^:private deserialize-type* "T" &type/Type
- )
-
-(do-template [<name> <signal> <type>]
- (defn <name> [^String input]
- (when (.startsWith input <signal>)
- (when-let [[left ^String input*] (deserialize-type (.substring input 1))]
- (when-let [[right ^String input*] (deserialize-type input*)]
- [(<type> left right) input*]))
- ))
-
- ^:private deserialize-sum "+" &/$SumT
- ^:private deserialize-prod "*" &/$ProdT
- ^:private deserialize-lambda ">" &/$LambdaT
- ^:private deserialize-app "%" &/$AppT
- )
-
-(do-template [<name> <signal> <type>]
- (defn <name> [^String input]
- (when (.startsWith input <signal>)
- (let [[idx ^String input*] (.split (.substring input 1) stop 2)]
- [(<type> (Long/parseLong idx)) input*])))
-
- ^:private deserialize-bound "$" &/$BoundT
- ^:private deserialize-ex "!" &/$ExT
- ^:private deserialize-var "?" &/$VarT
- )
-
-(defn ^:private deserialize-named [^String input]
- (when (.startsWith input "@")
- (let [[^String module+name ^String input*] (.split (.substring input 1) stop 2)
- [module name] (.split module+name ident-separator 2)]
- (when-let [[type* ^String input*] (deserialize-type input*)]
- [(&/$NamedT (&/T [module name]) type*) input*]))))
-
-(do-template [<name> <signal> <type>]
- (defn <name> [^String input]
- (when (.startsWith input <signal>)
- (when-let [[env ^String input*] (deserialize-list (.substring input 1))]
- (when-let [[body ^String input*] (deserialize-type input*)]
- [(<type> env body) input*]))))
-
- ^:private deserialize-univq "U" &/$UnivQ
- ^:private deserialize-exq "E" &/$ExQ
- )
-
-(defn ^:private deserialize-host [^String input]
- (when (.startsWith input "^")
- (let [[name ^String input*] (.split (.substring input 1) stop 2)]
- (when-let [[params ^String input*] (deserialize-list input*)]
- [(&/$HostT name params) input*]))))
-
-(defn deserialize-type
- "(-> Text Type)"
- [input]
- (or (deserialize-type* input)
- (deserialize-void input)
- (deserialize-unit input)
- (deserialize-sum input)
- (deserialize-prod input)
- (deserialize-lambda input)
- (deserialize-app input)
- (deserialize-bound input)
- (deserialize-ex input)
- (deserialize-var input)
- (deserialize-named input)
- (deserialize-univq input)
- (deserialize-exq input)
- (deserialize-host input)
- (assert false (str "[Cache error] Can't deserialize type. --- " input))))
diff --git a/src/lux/compiler/case.clj b/src/lux/compiler/case.clj
deleted file mode 100644
index afdcd3eed..000000000
--- a/src/lux/compiler/case.clj
+++ /dev/null
@@ -1,219 +0,0 @@
-;; Copyright (c) Eduardo Julian. All rights reserved.
-;; This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0.
-;; If a copy of the MPL was not distributed with this file,
-;; You can obtain one at http://mozilla.org/MPL/2.0/.
-
-(ns lux.compiler.case
- (:require (clojure [set :as set]
- [template :refer [do-template]])
- clojure.core.match
- clojure.core.match.array
- (lux [base :as & :refer [|do return* return fail fail* |let |case]]
- [type :as &type]
- [lexer :as &lexer]
- [parser :as &parser]
- [analyser :as &analyser]
- [host :as &host]
- [optimizer :as &o])
- [lux.analyser.case :as &a-case]
- [lux.compiler.base :as &&])
- (:import (org.objectweb.asm Opcodes
- Label
- ClassWriter
- MethodVisitor)))
-
-;; [Utils]
-(defn ^:private pop-alt-stack [^MethodVisitor writer stack-depth]
- (cond (= 0 stack-depth)
- writer
-
- (= 1 stack-depth)
- (doto writer
- (.visitInsn Opcodes/POP))
-
- (= 2 stack-depth)
- (doto writer
- (.visitInsn Opcodes/POP2))
-
- :else ;; > 2
- (doto writer
- (.visitInsn Opcodes/POP2)
- (pop-alt-stack (- stack-depth 2)))))
-
-(defn ^:private stack-peek [^MethodVisitor writer]
- (doto writer
- (.visitInsn Opcodes/DUP)
- (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "pm_stack_peek" "([Ljava/lang/Object;)Ljava/lang/Object;")))
-
-(defn ^:private compile-pattern* [^MethodVisitor writer bodies stack-depth $else pm]
- "(-> MethodVisitor Case-Pattern (List Label) Int Label MethodVisitor)"
- (|case pm
- (&o/$ExecPM _body-idx)
- (|case (&/|at _body-idx bodies)
- (&/$Some $body)
- (doto writer
- (pop-alt-stack stack-depth)
- (.visitJumpInsn Opcodes/GOTO $body))
-
- (&/$None)
- (assert false))
-
- (&o/$PopPM)
- (doto writer
- (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "pm_stack_pop" "([Ljava/lang/Object;)[Ljava/lang/Object;"))
-
- (&o/$BindPM _var-id)
- (doto writer
- stack-peek
- (.visitVarInsn Opcodes/ASTORE _var-id)
- (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "pm_stack_pop" "([Ljava/lang/Object;)[Ljava/lang/Object;"))
-
- (&o/$BoolPM _value)
- (doto writer
- stack-peek
- &&/unwrap-boolean
- (.visitJumpInsn (if _value Opcodes/IFEQ Opcodes/IFNE) $else))
-
- (&o/$NatPM _value)
- (doto writer
- stack-peek
- &&/unwrap-long
- (.visitLdcInsn (long _value))
- (.visitInsn Opcodes/LCMP)
- (.visitJumpInsn Opcodes/IFNE $else))
-
- (&o/$IntPM _value)
- (doto writer
- stack-peek
- &&/unwrap-long
- (.visitLdcInsn (long _value))
- (.visitInsn Opcodes/LCMP)
- (.visitJumpInsn Opcodes/IFNE $else))
-
- (&o/$FracPM _value)
- (doto writer
- stack-peek
- &&/unwrap-long
- (.visitLdcInsn (long _value))
- (.visitInsn Opcodes/LCMP)
- (.visitJumpInsn Opcodes/IFNE $else))
-
- (&o/$RealPM _value)
- (doto writer
- stack-peek
- &&/unwrap-double
- (.visitLdcInsn (double _value))
- (.visitInsn Opcodes/DCMPL)
- (.visitJumpInsn Opcodes/IFNE $else))
-
- (&o/$CharPM _value)
- (doto writer
- stack-peek
- &&/unwrap-char
- (.visitLdcInsn _value)
- (.visitJumpInsn Opcodes/IF_ICMPNE $else))
-
- (&o/$TextPM _value)
- (doto writer
- stack-peek
- (.visitLdcInsn _value)
- (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/Object" "equals" "(Ljava/lang/Object;)Z")
- (.visitJumpInsn Opcodes/IFEQ $else))
-
- (&o/$TuplePM _idx+)
- (|let [[_idx is-tail?] (|case _idx+
- (&/$Left _idx)
- (&/T [_idx false])
-
- (&/$Right _idx)
- (&/T [_idx true]))]
- (if (= 0 _idx)
- (doto writer
- stack-peek
- (.visitTypeInsn Opcodes/CHECKCAST "[Ljava/lang/Object;")
- (.visitLdcInsn (int 0))
- (.visitInsn Opcodes/AALOAD)
- (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "pm_stack_push" "([Ljava/lang/Object;Ljava/lang/Object;)[Ljava/lang/Object;"))
- (doto writer
- stack-peek
- (.visitTypeInsn Opcodes/CHECKCAST "[Ljava/lang/Object;")
- (.visitLdcInsn (int _idx))
- (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" (if is-tail? "product_getRight" "product_getLeft") "([Ljava/lang/Object;I)Ljava/lang/Object;")
- (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "pm_stack_push" "([Ljava/lang/Object;Ljava/lang/Object;)[Ljava/lang/Object;")
- )))
-
- (&o/$VariantPM _idx+)
- (|let [$success (new Label)
- $fail (new Label)
- [_idx is-last] (|case _idx+
- (&/$Left _idx)
- (&/T [_idx false])
-
- (&/$Right _idx)
- (&/T [_idx true]))
- _ (doto writer
- stack-peek
- (.visitTypeInsn Opcodes/CHECKCAST "[Ljava/lang/Object;")
- (.visitLdcInsn (int _idx)))
- _ (if is-last
- (.visitLdcInsn writer "")
- (.visitInsn writer Opcodes/ACONST_NULL))]
- (doto writer
- (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "sum_get" "([Ljava/lang/Object;ILjava/lang/Object;)Ljava/lang/Object;")
- (.visitInsn Opcodes/DUP)
- (.visitJumpInsn Opcodes/IFNULL $fail)
- (.visitJumpInsn Opcodes/GOTO $success)
- (.visitLabel $fail)
- (.visitInsn Opcodes/POP)
- (.visitJumpInsn Opcodes/GOTO $else)
- (.visitLabel $success)
- (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "pm_stack_push" "([Ljava/lang/Object;Ljava/lang/Object;)[Ljava/lang/Object;")))
-
- (&o/$SeqPM _left-pm _right-pm)
- (doto writer
- (compile-pattern* bodies stack-depth $else _left-pm)
- (compile-pattern* bodies stack-depth $else _right-pm))
-
- (&o/$AltPM _left-pm _right-pm)
- (|let [$alt-else (new Label)]
- (doto writer
- (.visitInsn Opcodes/DUP)
- (compile-pattern* bodies (inc stack-depth) $alt-else _left-pm)
- (.visitLabel $alt-else)
- (.visitInsn Opcodes/POP)
- (compile-pattern* bodies stack-depth $else _right-pm)))
- ))
-
-(defn ^:private compile-pattern [^MethodVisitor writer bodies pm $end]
- (|let [$else (new Label)]
- (doto writer
- (compile-pattern* bodies 1 $else pm)
- (.visitLabel $else)
- (.visitInsn Opcodes/POP)
- (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "pm_fail" "()V")
- (.visitInsn Opcodes/ACONST_NULL)
- (.visitJumpInsn Opcodes/GOTO $end))))
-
-(defn ^:private compile-bodies [^MethodVisitor writer compile bodies-labels ?bodies $end]
- (&/map% (fn [label+body]
- (|let [[_label _body] label+body]
- (|do [:let [_ (.visitLabel writer _label)]
- _ (compile _body)
- :let [_ (.visitJumpInsn writer Opcodes/GOTO $end)]]
- (return nil))))
- (&/zip2 bodies-labels ?bodies)))
-
-;; [Resources]
-(defn compile-case [compile ?value ?pm ?bodies]
- (|do [^MethodVisitor *writer* &/get-writer
- :let [$end (new Label)
- bodies-labels (&/|map (fn [_] (new Label)) ?bodies)]
- _ (compile ?value)
- :let [_ (doto *writer*
- (.visitInsn Opcodes/ACONST_NULL)
- (.visitInsn Opcodes/SWAP)
- (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "pm_stack_push" "([Ljava/lang/Object;Ljava/lang/Object;)[Ljava/lang/Object;"))
- _ (compile-pattern *writer* bodies-labels ?pm $end)]
- _ (compile-bodies *writer* compile bodies-labels ?bodies $end)
- :let [_ (.visitLabel *writer* $end)]]
- (return nil)))
diff --git a/src/lux/compiler/host.clj b/src/lux/compiler/host.clj
deleted file mode 100644
index 9f6d077be..000000000
--- a/src/lux/compiler/host.clj
+++ /dev/null
@@ -1,2514 +0,0 @@
-;; Copyright (c) Eduardo Julian. All rights reserved.
-;; This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0.
-;; If a copy of the MPL was not distributed with this file,
-;; You can obtain one at http://mozilla.org/MPL/2.0/.
-
-(ns lux.compiler.host
- (:require (clojure [string :as string]
- [set :as set]
- [template :refer [do-template]])
- clojure.core.match
- clojure.core.match.array
- (lux [base :as & :refer [|do return* return fail fail* |let |case]]
- [type :as &type]
- [lexer :as &lexer]
- [parser :as &parser]
- [analyser :as &analyser]
- [optimizer :as &o]
- [host :as &host])
- [lux.type.host :as &host-type]
- [lux.host.generics :as &host-generics]
- [lux.analyser.base :as &a]
- [lux.compiler.base :as &&])
- (:import (org.objectweb.asm Opcodes
- Label
- ClassWriter
- MethodVisitor
- AnnotationVisitor)))
-
-;; [Utils]
-(def init-method "<init>")
-
-(let [class+method+sig {"boolean" [(&host-generics/->bytecode-class-name "java.lang.Boolean") "booleanValue" "()Z"]
- "byte" [(&host-generics/->bytecode-class-name "java.lang.Byte") "byteValue" "()B"]
- "short" [(&host-generics/->bytecode-class-name "java.lang.Short") "shortValue" "()S"]
- "int" [(&host-generics/->bytecode-class-name "java.lang.Integer") "intValue" "()I"]
- "long" [(&host-generics/->bytecode-class-name "java.lang.Long") "longValue" "()J"]
- "float" [(&host-generics/->bytecode-class-name "java.lang.Float") "floatValue" "()F"]
- "double" [(&host-generics/->bytecode-class-name "java.lang.Double") "doubleValue" "()D"]
- "char" [(&host-generics/->bytecode-class-name "java.lang.Character") "charValue" "()C"]}]
- (defn ^:private prepare-arg! [^MethodVisitor *writer* class-name]
- (if-let [[class method sig] (get class+method+sig class-name)]
- (doto *writer*
- (.visitTypeInsn Opcodes/CHECKCAST class)
- (.visitMethodInsn Opcodes/INVOKEVIRTUAL class method sig))
- (.visitTypeInsn *writer* Opcodes/CHECKCAST (&host-generics/->bytecode-class-name class-name)))))
-
-(let [boolean-class "java.lang.Boolean"
- byte-class "java.lang.Byte"
- short-class "java.lang.Short"
- int-class "java.lang.Integer"
- long-class "java.lang.Long"
- float-class "java.lang.Float"
- double-class "java.lang.Double"
- char-class "java.lang.Character"]
- (defn prepare-return! [^MethodVisitor *writer* *type*]
- (|case *type*
- (&/$UnitT)
- (.visitLdcInsn *writer* &/unit-tag)
-
- (&/$HostT "boolean" (&/$Nil))
- (.visitMethodInsn *writer* Opcodes/INVOKESTATIC (&host-generics/->bytecode-class-name boolean-class) "valueOf" (str "(Z)" (&host-generics/->type-signature boolean-class)))
-
- (&/$HostT "byte" (&/$Nil))
- (.visitMethodInsn *writer* Opcodes/INVOKESTATIC (&host-generics/->bytecode-class-name byte-class) "valueOf" (str "(B)" (&host-generics/->type-signature byte-class)))
-
- (&/$HostT "short" (&/$Nil))
- (.visitMethodInsn *writer* Opcodes/INVOKESTATIC (&host-generics/->bytecode-class-name short-class) "valueOf" (str "(S)" (&host-generics/->type-signature short-class)))
-
- (&/$HostT "int" (&/$Nil))
- (.visitMethodInsn *writer* Opcodes/INVOKESTATIC (&host-generics/->bytecode-class-name int-class) "valueOf" (str "(I)" (&host-generics/->type-signature int-class)))
-
- (&/$HostT "long" (&/$Nil))
- (.visitMethodInsn *writer* Opcodes/INVOKESTATIC (&host-generics/->bytecode-class-name long-class) "valueOf" (str "(J)" (&host-generics/->type-signature long-class)))
-
- (&/$HostT "float" (&/$Nil))
- (.visitMethodInsn *writer* Opcodes/INVOKESTATIC (&host-generics/->bytecode-class-name float-class) "valueOf" (str "(F)" (&host-generics/->type-signature float-class)))
-
- (&/$HostT "double" (&/$Nil))
- (.visitMethodInsn *writer* Opcodes/INVOKESTATIC (&host-generics/->bytecode-class-name double-class) "valueOf" (str "(D)" (&host-generics/->type-signature double-class)))
-
- (&/$HostT "char" (&/$Nil))
- (.visitMethodInsn *writer* Opcodes/INVOKESTATIC (&host-generics/->bytecode-class-name char-class) "valueOf" (str "(C)" (&host-generics/->type-signature char-class)))
-
- (&/$HostT _ _)
- nil
-
- (&/$NamedT ?name ?type)
- (prepare-return! *writer* ?type)
-
- (&/$ExT _)
- nil
-
- _
- (assert false (str 'prepare-return! " " (&type/show-type *type*))))
- *writer*))
-
-;; [Resources]
-(defn ^:private compile-annotation [writer ann]
- (doto ^AnnotationVisitor (.visitAnnotation writer (&host-generics/->type-signature (:name ann)) true)
- (-> (.visit param-name param-value)
- (->> (|let [[param-name param-value] param])
- (doseq [param (&/->seq (:params ann))])))
- (.visitEnd))
- nil)
-
-(defn ^:private compile-field [^ClassWriter writer field]
- (|case field
- (&/$ConstantFieldSyntax ?name ?anns ?gclass ?value)
- (|let [=field (.visitField writer
- (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC Opcodes/ACC_FINAL)
- ?name
- (&host-generics/gclass->simple-signature ?gclass)
- (&host-generics/gclass->signature ?gclass) nil)]
- (do (&/|map (partial compile-annotation =field) ?anns)
- (.visitEnd =field)
- nil))
-
- (&/$VariableFieldSyntax =name =privacy-modifier =state-modifier =anns =type)
- (|let [=field (.visitField writer
- (+ (&host/privacy-modifier->flag =privacy-modifier)
- (&host/state-modifier->flag =state-modifier))
- =name
- (&host-generics/gclass->simple-signature =type)
- (&host-generics/gclass->signature =type) nil)]
- (do (&/|map (partial compile-annotation =field) =anns)
- (.visitEnd =field)
- nil))
- ))
-
-(defn ^:private compile-method-return [^MethodVisitor writer output]
- (|case output
- (&/$GenericClass "void" (&/$Nil))
- (.visitInsn writer Opcodes/RETURN)
-
- (&/$GenericClass "boolean" (&/$Nil))
- (doto writer
- &&/unwrap-boolean
- (.visitInsn Opcodes/IRETURN))
-
- (&/$GenericClass "byte" (&/$Nil))
- (doto writer
- &&/unwrap-byte
- (.visitInsn Opcodes/IRETURN))
-
- (&/$GenericClass "short" (&/$Nil))
- (doto writer
- &&/unwrap-short
- (.visitInsn Opcodes/IRETURN))
-
- (&/$GenericClass "int" (&/$Nil))
- (doto writer
- &&/unwrap-int
- (.visitInsn Opcodes/IRETURN))
-
- (&/$GenericClass "long" (&/$Nil))
- (doto writer
- &&/unwrap-long
- (.visitInsn Opcodes/LRETURN))
-
- (&/$GenericClass "float" (&/$Nil))
- (doto writer
- &&/unwrap-float
- (.visitInsn Opcodes/FRETURN))
-
- (&/$GenericClass "double" (&/$Nil))
- (doto writer
- &&/unwrap-double
- (.visitInsn Opcodes/DRETURN))
-
- (&/$GenericClass "char" (&/$Nil))
- (doto writer
- &&/unwrap-char
- (.visitInsn Opcodes/IRETURN))
-
- _
- (.visitInsn writer Opcodes/ARETURN)))
-
-(defn ^:private prepare-method-input [idx input ^MethodVisitor method-visitor]
- "(-> Int [Text GenericClass] MethodVisitor (Lux FrameTag))"
- (|case input
- [_ (&/$GenericClass name params)]
- (case name
- "boolean" (do (doto method-visitor
- (.visitVarInsn Opcodes/ILOAD idx)
- &&/wrap-boolean
- (.visitVarInsn Opcodes/ASTORE idx))
- (return (&/T [(inc idx) (&/|list (&host-generics/gclass->class-name (&/$GenericClass "java.lang.Boolean" (&/|list))))])))
- "byte" (do (doto method-visitor
- (.visitVarInsn Opcodes/ILOAD idx)
- &&/wrap-byte
- (.visitVarInsn Opcodes/ASTORE idx))
- (return (&/T [(inc idx) (&/|list (&host-generics/gclass->class-name (&/$GenericClass "java.lang.Byte" (&/|list))))])))
- "short" (do (doto method-visitor
- (.visitVarInsn Opcodes/ILOAD idx)
- &&/wrap-short
- (.visitVarInsn Opcodes/ASTORE idx))
- (return (&/T [(inc idx) (&/|list (&host-generics/gclass->class-name (&/$GenericClass "java.lang.Short" (&/|list))))])))
- "int" (do (doto method-visitor
- (.visitVarInsn Opcodes/ILOAD idx)
- &&/wrap-int
- (.visitVarInsn Opcodes/ASTORE idx))
- (return (&/T [(inc idx) (&/|list (&host-generics/gclass->class-name (&/$GenericClass "java.lang.Integer" (&/|list))))])))
- "long" (do (doto method-visitor
- (.visitVarInsn Opcodes/LLOAD idx)
- &&/wrap-long
- (.visitVarInsn Opcodes/ASTORE idx))
- (return (&/T [(+ 2 idx) (&/|list (&host-generics/gclass->class-name (&/$GenericClass "java.lang.Long" (&/|list))) Opcodes/TOP)])))
- "float" (do (doto method-visitor
- (.visitVarInsn Opcodes/FLOAD idx)
- &&/wrap-float
- (.visitVarInsn Opcodes/ASTORE idx))
- (return (&/T [(inc idx) (&/|list (&host-generics/gclass->class-name (&/$GenericClass "java.lang.Float" (&/|list))))])))
- "double" (do (doto method-visitor
- (.visitVarInsn Opcodes/DLOAD idx)
- &&/wrap-double
- (.visitVarInsn Opcodes/ASTORE idx))
- (return (&/T [(+ 2 idx) (&/|list (&host-generics/gclass->class-name (&/$GenericClass "java.lang.Double" (&/|list))) Opcodes/TOP)])))
- "char" (do (doto method-visitor
- (.visitVarInsn Opcodes/ILOAD idx)
- &&/wrap-char
- (.visitVarInsn Opcodes/ASTORE idx))
- (return (&/T [(inc idx) (&/|list (&host-generics/gclass->class-name (&/$GenericClass "java.lang.Character" (&/|list))))])))
- ;; else
- (return (&/T [(inc idx) (&/|list (&host-generics/gclass->class-name (&/$GenericClass name params)))])))
-
- [_ gclass]
- (return (&/T [(inc idx) (&/|list (&host-generics/gclass->class-name gclass))]))
- ))
-
-(defn ^:private prepare-method-inputs [idx inputs method-visitor]
- "(-> Int (List GenericClass) MethodVisitor (Lux (List FrameTag)))"
- (|case inputs
- (&/$Nil)
- (return &/$Nil)
-
- (&/$Cons input inputs*)
- (|do [[_ outputs*] (&/fold% (fn [idx+outputs input]
- (|do [:let [[_idx _outputs] idx+outputs]
- [idx* output] (prepare-method-input _idx input method-visitor)]
- (return (&/T [idx* (&/$Cons output _outputs)]))))
- (&/T [idx &/$Nil])
- inputs)]
- (return (&/list-join (&/|reverse outputs*))))
- ))
-
-(defn ^:private compile-method-def [compile ^ClassWriter class-writer bytecode-class-name ?super-class method-def]
- (|case method-def
- (&/$ConstructorMethodAnalysis ?privacy-modifier ?strict ?anns ?gvars ?exceptions ?inputs ?ctor-args ?body)
- (|let [?output (&/$GenericClass "void" (&/|list))
- =method-decl (&/T [init-method ?anns ?gvars ?exceptions (&/|map &/|second ?inputs) ?output])
- [simple-signature generic-signature] (&host-generics/method-signatures =method-decl)]
- (&/with-writer (.visitMethod class-writer
- (+ (&host/privacy-modifier->flag ?privacy-modifier)
- (if ?strict Opcodes/ACC_STRICT 0))
- init-method
- simple-signature
- generic-signature
- (->> ?exceptions (&/|map &host-generics/gclass->class-name) &/->seq (into-array java.lang.String)))
- (|do [^MethodVisitor =method &/get-writer
- :let [[super-class-name super-class-params] ?super-class
- init-types (->> ?ctor-args (&/|map (comp &host-generics/gclass->signature &/|first)) (&/fold str ""))
- init-sig (str "(" init-types ")" "V")
- _ (&/|map (partial compile-annotation =method) ?anns)
- _ (.visitCode =method)]
- =input-tags (prepare-method-inputs 1 ?inputs =method)
- :let [_ (.visitVarInsn =method Opcodes/ALOAD 0)]
- _ (->> ?ctor-args (&/|map &/|second) (&/map% compile))
- :let [_ (.visitMethodInsn =method Opcodes/INVOKESPECIAL (&host-generics/->bytecode-class-name super-class-name) init-method init-sig)]
- _ (compile (&o/optimize ?body))
- :let [_ (doto =method
- (compile-method-return ?output)
- (.visitMaxs 0 0)
- (.visitEnd))]]
- (return nil))))
-
- (&/$VirtualMethodAnalysis ?name ?privacy-modifier =final? ?strict ?anns ?gvars ?exceptions ?inputs ?output ?body)
- (|let [=method-decl (&/T [?name ?anns ?gvars ?exceptions (&/|map &/|second ?inputs) ?output])
- [simple-signature generic-signature] (&host-generics/method-signatures =method-decl)]
- (&/with-writer (.visitMethod class-writer
- (+ (&host/privacy-modifier->flag ?privacy-modifier)
- (if =final? Opcodes/ACC_FINAL 0)
- (if ?strict Opcodes/ACC_STRICT 0))
- ?name
- simple-signature
- generic-signature
- (->> ?exceptions (&/|map &host-generics/gclass->class-name) &/->seq (into-array java.lang.String)))
- (|do [^MethodVisitor =method &/get-writer
- :let [_ (&/|map (partial compile-annotation =method) ?anns)
- _ (.visitCode =method)]
- =input-tags (prepare-method-inputs 1 ?inputs =method)
- _ (compile (&o/optimize ?body))
- :let [_ (doto =method
- (compile-method-return ?output)
- (.visitMaxs 0 0)
- (.visitEnd))]]
- (return nil))))
-
- (&/$OverridenMethodAnalysis ?class-decl ?name ?strict ?anns ?gvars ?exceptions ?inputs ?output ?body)
- (|let [=method-decl (&/T [?name ?anns ?gvars ?exceptions (&/|map &/|second ?inputs) ?output])
- [simple-signature generic-signature] (&host-generics/method-signatures =method-decl)]
- (&/with-writer (.visitMethod class-writer
- (+ Opcodes/ACC_PUBLIC
- (if ?strict Opcodes/ACC_STRICT 0))
- ?name
- simple-signature
- generic-signature
- (->> ?exceptions (&/|map &host-generics/gclass->class-name) &/->seq (into-array java.lang.String)))
- (|do [^MethodVisitor =method &/get-writer
- :let [_ (&/|map (partial compile-annotation =method) ?anns)
- _ (.visitCode =method)]
- =input-tags (prepare-method-inputs 1 ?inputs =method)
- _ (compile (&o/optimize ?body))
- :let [_ (doto =method
- (compile-method-return ?output)
- (.visitMaxs 0 0)
- (.visitEnd))]]
- (return nil))))
-
- (&/$StaticMethodAnalysis ?name ?privacy-modifier ?strict ?anns ?gvars ?exceptions ?inputs ?output ?body)
- (|let [=method-decl (&/T [?name ?anns ?gvars ?exceptions (&/|map &/|second ?inputs) ?output])
- [simple-signature generic-signature] (&host-generics/method-signatures =method-decl)]
- (&/with-writer (.visitMethod class-writer
- (+ (&host/privacy-modifier->flag ?privacy-modifier)
- (if ?strict Opcodes/ACC_STRICT 0)
- Opcodes/ACC_STATIC)
- ?name
- simple-signature
- generic-signature
- (->> ?exceptions (&/|map &host-generics/gclass->class-name) &/->seq (into-array java.lang.String)))
- (|do [^MethodVisitor =method &/get-writer
- :let [_ (&/|map (partial compile-annotation =method) ?anns)
- _ (.visitCode =method)]
- =input-tags (prepare-method-inputs 0 ?inputs =method)
- _ (compile (&o/optimize ?body))
- :let [_ (doto =method
- (compile-method-return ?output)
- (.visitMaxs 0 0)
- (.visitEnd))]]
- (return nil))))
-
- (&/$AbstractMethodSyntax ?name ?privacy-modifier ?anns ?gvars ?exceptions ?inputs ?output)
- (|let [=method-decl (&/T [?name ?anns ?gvars ?exceptions (&/|map &/|second ?inputs) ?output])
- [simple-signature generic-signature] (&host-generics/method-signatures =method-decl)]
- (&/with-writer (.visitMethod class-writer
- (+ Opcodes/ACC_ABSTRACT
- (&host/privacy-modifier->flag ?privacy-modifier))
- ?name
- simple-signature
- generic-signature
- (->> ?exceptions (&/|map &host-generics/gclass->class-name) &/->seq (into-array java.lang.String)))
- (|do [^MethodVisitor =method &/get-writer
- :let [_ (&/|map (partial compile-annotation =method) ?anns)
- _ (.visitEnd =method)]]
- (return nil))))
-
- (&/$NativeMethodSyntax ?name ?privacy-modifier ?anns ?gvars ?exceptions ?inputs ?output)
- (|let [=method-decl (&/T [?name ?anns ?gvars ?exceptions (&/|map &/|second ?inputs) ?output])
- [simple-signature generic-signature] (&host-generics/method-signatures =method-decl)]
- (&/with-writer (.visitMethod class-writer
- (+ Opcodes/ACC_PUBLIC Opcodes/ACC_NATIVE
- (&host/privacy-modifier->flag ?privacy-modifier))
- ?name
- simple-signature
- generic-signature
- (->> ?exceptions (&/|map &host-generics/gclass->class-name) &/->seq (into-array java.lang.String)))
- (|do [^MethodVisitor =method &/get-writer
- :let [_ (&/|map (partial compile-annotation =method) ?anns)
- _ (.visitEnd =method)]]
- (return nil))))
- ))
-
-(defn ^:private compile-method-decl [^ClassWriter class-writer =method-decl]
- (|let [[=name =anns =gvars =exceptions =inputs =output] =method-decl
- [simple-signature generic-signature] (&host-generics/method-signatures =method-decl)
- =method (.visitMethod class-writer
- (+ Opcodes/ACC_PUBLIC Opcodes/ACC_ABSTRACT)
- =name
- simple-signature
- generic-signature
- (->> =exceptions (&/|map &host-generics/gclass->class-name) &/->seq (into-array java.lang.String)))
- _ (&/|map (partial compile-annotation =method) =anns)
- _ (.visitEnd =method)]
- nil))
-
-(defn ^:private prepare-ctor-arg [^MethodVisitor writer type]
- (case type
- "boolean" (doto writer
- (.visitTypeInsn Opcodes/CHECKCAST (&host-generics/->bytecode-class-name "java.lang.Boolean"))
- &&/unwrap-boolean)
- "byte" (doto writer
- (.visitTypeInsn Opcodes/CHECKCAST (&host-generics/->bytecode-class-name "java.lang.Byte"))
- &&/unwrap-byte)
- "short" (doto writer
- (.visitTypeInsn Opcodes/CHECKCAST (&host-generics/->bytecode-class-name "java.lang.Short"))
- &&/unwrap-short)
- "int" (doto writer
- (.visitTypeInsn Opcodes/CHECKCAST (&host-generics/->bytecode-class-name "java.lang.Integer"))
- &&/unwrap-int)
- "long" (doto writer
- (.visitTypeInsn Opcodes/CHECKCAST (&host-generics/->bytecode-class-name "java.lang.Long"))
- &&/unwrap-long)
- "float" (doto writer
- (.visitTypeInsn Opcodes/CHECKCAST (&host-generics/->bytecode-class-name "java.lang.Float"))
- &&/unwrap-float)
- "double" (doto writer
- (.visitTypeInsn Opcodes/CHECKCAST (&host-generics/->bytecode-class-name "java.lang.Double"))
- &&/unwrap-double)
- "char" (doto writer
- (.visitTypeInsn Opcodes/CHECKCAST (&host-generics/->bytecode-class-name "java.lang.Character"))
- &&/unwrap-char)
- ;; else
- (doto writer
- (.visitTypeInsn Opcodes/CHECKCAST (&host-generics/->bytecode-class-name type)))))
-
-(let [clo-field-sig (&host-generics/->type-signature "java.lang.Object")
- <init>-return "V"]
- (defn ^:private anon-class-<init>-signature [env]
- (str "(" (&/fold str "" (&/|repeat (&/|length env) clo-field-sig)) ")"
- <init>-return))
-
- (defn ^:private add-anon-class-<init> [^ClassWriter class-writer compile class-name super-class env ctor-args]
- (|let [[super-class-name super-class-params] super-class
- init-types (->> ctor-args (&/|map (comp &host-generics/->type-signature &/|first)) (&/fold str ""))]
- (&/with-writer (.visitMethod class-writer Opcodes/ACC_PUBLIC init-method (anon-class-<init>-signature env) nil nil)
- (|do [^MethodVisitor =method &/get-writer
- :let [_ (doto =method
- (.visitCode)
- (.visitVarInsn Opcodes/ALOAD 0))]
- _ (&/map% (fn [type+term]
- (|let [[type term] type+term]
- (|do [_ (compile term)
- :let [_ (prepare-ctor-arg =method type)]]
- (return nil))))
- ctor-args)
- :let [_ (doto =method
- (.visitMethodInsn Opcodes/INVOKESPECIAL (&host-generics/->bytecode-class-name super-class-name) init-method (str "(" init-types ")" <init>-return))
- (-> (doto (.visitVarInsn Opcodes/ALOAD 0)
- (.visitVarInsn Opcodes/ALOAD (inc ?captured-id))
- (.visitFieldInsn Opcodes/PUTFIELD class-name captured-name clo-field-sig))
- (->> (let [captured-name (str &&/closure-prefix ?captured-id)])
- (|case ?name+?captured
- [?name [_ (&o/$captured _ ?captured-id ?source)]])
- (doseq [?name+?captured (&/->seq env)])))
- (.visitInsn Opcodes/RETURN)
- (.visitMaxs 0 0)
- (.visitEnd))]]
- (return nil)))))
- )
-
-(defn ^:private constant-inits [fields]
- "(-> (List FieldAnalysis) (List [Text GenericClass Analysis]))"
- (&/fold &/|++
- &/$Nil
- (&/|map (fn [field]
- (|case field
- (&/$ConstantFieldSyntax ?name ?anns ?gclass ?value)
- (&/|list (&/T [?name ?gclass ?value]))
-
- (&/$VariableFieldSyntax _)
- (&/|list)
- ))
- fields)))
-
-(declare compile-jvm-putstatic)
-(defn compile-jvm-class [compile class-decl ?super-class ?interfaces ?inheritance-modifier ?anns ?fields ?methods env ??ctor-args]
- (|do [module &/get-module-name
- [file-name line column] &/cursor
- :let [[?name ?params] class-decl
- class-signature (&host-generics/gclass-decl->signature class-decl (&/$Cons ?super-class ?interfaces))
- full-name (str module "/" ?name)
- super-class* (&host-generics/->bytecode-class-name (&host-generics/super-class-name ?super-class))
- =class (doto (new ClassWriter ClassWriter/COMPUTE_MAXS)
- (.visit &host/bytecode-version (+ Opcodes/ACC_PUBLIC Opcodes/ACC_SUPER
- (&host/inheritance-modifier->flag ?inheritance-modifier))
- full-name (if (= "" class-signature) nil class-signature) super-class* (->> ?interfaces (&/|map (comp &host-generics/->bytecode-class-name &host-generics/super-class-name)) &/->seq (into-array String)))
- (.visitSource file-name nil))
- _ (&/|map (partial compile-annotation =class) ?anns)
- _ (&/|map (partial compile-field =class)
- ?fields)]
- _ (&/map% (partial compile-method-def compile =class full-name ?super-class) ?methods)
- _ (|case ??ctor-args
- (&/$Some ctor-args)
- (add-anon-class-<init> =class compile full-name ?super-class env ctor-args)
-
- _
- (return nil))
- _ (&/with-writer (.visitMethod =class Opcodes/ACC_STATIC "<clinit>" "()V" nil nil)
- (|do [^MethodVisitor =method &/get-writer
- :let [_ (doto =method
- (.visitCode))]
- _ (&/map% (fn [ftriple]
- (|let [[fname fgclass fvalue] ftriple]
- (compile-jvm-putstatic compile (&/|list (&o/optimize fvalue)) (&/|list ?name fname fgclass))))
- (constant-inits ?fields))
- :let [_ (doto =method
- (.visitInsn Opcodes/RETURN)
- (.visitMaxs 0 0)
- (.visitEnd))]]
- (return nil)))]
- (&&/save-class! ?name (.toByteArray (doto =class .visitEnd)))))
-
-(defn compile-jvm-interface [interface-decl ?supers ?anns ?methods]
- (|do [:let [[interface-name interface-vars] interface-decl]
- module &/get-module-name
- [file-name _ _] &/cursor
- :let [interface-signature (&host-generics/gclass-decl->signature interface-decl ?supers)
- =interface (doto (new ClassWriter ClassWriter/COMPUTE_MAXS)
- (.visit &host/bytecode-version (+ Opcodes/ACC_PUBLIC Opcodes/ACC_ABSTRACT Opcodes/ACC_INTERFACE)
- (str module "/" interface-name)
- (if (= "" interface-signature) nil interface-signature)
- "java/lang/Object"
- (->> ?supers (&/|map (comp &host-generics/->bytecode-class-name &host-generics/super-class-name)) &/->seq (into-array String)))
- (.visitSource file-name nil))
- _ (&/|map (partial compile-annotation =interface) ?anns)
- _ (do (&/|map (partial compile-method-decl =interface) ?methods)
- (.visitEnd =interface))]]
- (&&/save-class! interface-name (.toByteArray =interface))))
-
-(def compile-Function-class
- (|do [_ (return nil)
- :let [super-class "java/lang/Object"
- =class (doto (new ClassWriter ClassWriter/COMPUTE_MAXS)
- (.visit &host/bytecode-version (+ Opcodes/ACC_PUBLIC Opcodes/ACC_SUPER
- Opcodes/ACC_ABSTRACT
- ;; Opcodes/ACC_INTERFACE
- )
- &&/function-class nil super-class (into-array String []))
- (-> (.visitField (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL) &&/partials-field "I" nil nil)
- (doto (.visitEnd))))
- =init-method (doto (.visitMethod =class Opcodes/ACC_PUBLIC init-method "(I)V" nil nil)
- (.visitCode)
- (.visitVarInsn Opcodes/ALOAD 0)
- (.visitMethodInsn Opcodes/INVOKESPECIAL super-class init-method "()V")
- (.visitVarInsn Opcodes/ALOAD 0)
- (.visitVarInsn Opcodes/ILOAD 1)
- (.visitFieldInsn Opcodes/PUTFIELD &&/function-class &&/partials-field "I")
- (.visitInsn Opcodes/RETURN)
- (.visitMaxs 0 0)
- (.visitEnd))
- _ (dotimes [arity* &&/num-apply-variants]
- (let [arity (inc arity*)]
- (if (= 1 arity)
- (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_ABSTRACT) &&/apply-method (&&/apply-signature arity) nil nil)
- (.visitEnd))
- (doto (.visitMethod =class Opcodes/ACC_PUBLIC &&/apply-method (&&/apply-signature arity) nil nil)
- (.visitCode)
- (-> (.visitVarInsn Opcodes/ALOAD idx)
- (->> (dotimes [idx arity])))
- (.visitMethodInsn Opcodes/INVOKEVIRTUAL &&/function-class &&/apply-method (&&/apply-signature (dec arity)))
- (.visitTypeInsn Opcodes/CHECKCAST &&/function-class)
- (.visitVarInsn Opcodes/ALOAD arity)
- (.visitMethodInsn Opcodes/INVOKEVIRTUAL &&/function-class &&/apply-method (&&/apply-signature 1))
- (.visitInsn Opcodes/ARETURN)
- (.visitMaxs 0 0)
- (.visitEnd)))))]]
- (&&/save-class! (second (string/split &&/function-class #"/"))
- (.toByteArray (doto =class .visitEnd)))))
-
-(defn ^:private compile-LuxRT-adt-methods [^ClassWriter =class]
- (|let [_ (let [$begin (new Label)
- $not-rec (new Label)]
- (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "product_getLeft" "([Ljava/lang/Object;I)Ljava/lang/Object;" nil nil)
- (.visitCode)
- (.visitLabel $begin)
- (.visitVarInsn Opcodes/ALOAD 0) ;; tuple
- (.visitInsn Opcodes/ARRAYLENGTH) ;; tuple-size
- (.visitVarInsn Opcodes/ILOAD 1) ;; tuple-size, index
- (.visitLdcInsn (int 1)) ;; tuple-size, index, offset-last-elem
- (.visitInsn Opcodes/IADD) ;; tuple-size, index-last-elem
- (.visitInsn Opcodes/DUP2) ;; tuple-size, index-last-elem, tuple-size, index-last-elem
- (.visitJumpInsn Opcodes/IF_ICMPGT $not-rec) ;; tuple-size, index-last-elem
- (.visitInsn Opcodes/SWAP) ;; index-last-elem, tuple-size
- (.visitInsn Opcodes/ISUB) ;; sub-index
- (.visitVarInsn Opcodes/ALOAD 0) ;; sub-index, tuple
- (.visitInsn Opcodes/DUP) ;; sub-index, tuple, tuple
- (.visitInsn Opcodes/ARRAYLENGTH) ;; sub-index, tuple, tuple-size
- (.visitLdcInsn (int 1)) ;; sub-index, tuple, tuple-size, offset-last-elem
- (.visitInsn Opcodes/ISUB) ;; sub-index, tuple, index-last-elem
- (.visitInsn Opcodes/AALOAD) ;; sub-index, sub-tuple
- (.visitTypeInsn Opcodes/CHECKCAST "[Ljava/lang/Object;")
- (.visitVarInsn Opcodes/ASTORE 0) ;; sub-index
- (.visitVarInsn Opcodes/ISTORE 1) ;;
- (.visitJumpInsn Opcodes/GOTO $begin)
- (.visitLabel $not-rec) ;; tuple-size, index-last-elem
- (.visitInsn Opcodes/POP2) ;;
- (.visitVarInsn Opcodes/ALOAD 0) ;; tuple
- (.visitVarInsn Opcodes/ILOAD 1) ;; tuple, index
- (.visitInsn Opcodes/AALOAD) ;; elem
- (.visitInsn Opcodes/ARETURN)
- (.visitMaxs 0 0)
- (.visitEnd)))
- _ (let [$begin (new Label)
- $is-last (new Label)
- $must-copy (new Label)]
- (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "product_getRight" "([Ljava/lang/Object;I)Ljava/lang/Object;" nil nil)
- (.visitCode)
- (.visitLabel $begin)
- (.visitVarInsn Opcodes/ALOAD 0) ;; tuple
- (.visitInsn Opcodes/ARRAYLENGTH) ;; tuple-size
- (.visitVarInsn Opcodes/ILOAD 1) ;; tuple-size, index
- (.visitLdcInsn (int 1)) ;; tuple-size, index, offset-last-elem
- (.visitInsn Opcodes/IADD) ;; tuple-size, index-last-elem
- (.visitInsn Opcodes/DUP2) ;; tuple-size, index-last-elem, tuple-size, index-last-elem
- (.visitJumpInsn Opcodes/IF_ICMPEQ $is-last) ;; tuple-size, index-last-elem
- (.visitJumpInsn Opcodes/IF_ICMPGT $must-copy) ;;
- ;; Must recurse
- (.visitVarInsn Opcodes/ALOAD 0) ;; tuple
- (.visitInsn Opcodes/DUP) ;; tuple, tuple
- (.visitInsn Opcodes/ARRAYLENGTH) ;; tuple, tuple-size
- (.visitLdcInsn (int 1)) ;; tuple, tuple-size, offset-last-elem
- (.visitInsn Opcodes/ISUB) ;; tuple, offset-tuple-last-elem
- (.visitInsn Opcodes/AALOAD) ;; tuple-tail
- (.visitVarInsn Opcodes/ILOAD 1) ;; tuple-tail, index
- (.visitVarInsn Opcodes/ALOAD 0) ;; tuple-tail, index, tuple
- (.visitInsn Opcodes/ARRAYLENGTH) ;; tuple-tail, index, tuple-size
- (.visitLdcInsn (int 1)) ;; tuple-tail, index, tuple-size, 1
- (.visitInsn Opcodes/ISUB) ;; tuple-tail, index, tuple-size*
- (.visitInsn Opcodes/ISUB) ;; tuple-tail, index*
- (.visitVarInsn Opcodes/ISTORE 1) ;; tuple-tail
- (.visitTypeInsn Opcodes/CHECKCAST "[Ljava/lang/Object;") ;; tuple-tail
- (.visitVarInsn Opcodes/ASTORE 0) ;;
- (.visitJumpInsn Opcodes/GOTO $begin)
- (.visitLabel $must-copy)
- (.visitVarInsn Opcodes/ALOAD 0)
- (.visitVarInsn Opcodes/ILOAD 1)
- (.visitVarInsn Opcodes/ALOAD 0)
- (.visitInsn Opcodes/ARRAYLENGTH)
- (.visitMethodInsn Opcodes/INVOKESTATIC "java/util/Arrays" "copyOfRange" "([Ljava/lang/Object;II)[Ljava/lang/Object;")
- (.visitInsn Opcodes/ARETURN)
- (.visitLabel $is-last) ;; tuple-size, index-last-elem
- (.visitInsn Opcodes/POP2) ;;
- (.visitVarInsn Opcodes/ALOAD 0) ;; tuple
- (.visitVarInsn Opcodes/ILOAD 1) ;; tuple, index
- (.visitInsn Opcodes/AALOAD) ;; elem
- (.visitInsn Opcodes/ARETURN)
- (.visitMaxs 0 0)
- (.visitEnd)))
- _ (let [$begin (new Label)
- $just-return (new Label)
- $then (new Label)
- $further (new Label)
- $not-right (new Label)]
- (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "sum_get" "([Ljava/lang/Object;ILjava/lang/Object;)Ljava/lang/Object;" nil nil)
- (.visitCode)
- (.visitLabel $begin)
- (.visitVarInsn Opcodes/ILOAD 1) ;; tag
- (.visitVarInsn Opcodes/ALOAD 0) ;; tag, sum
- (.visitLdcInsn (int 0)) ;; tag, sum, sum-tag-idx
- (.visitInsn Opcodes/AALOAD) ;; tag, sum-tag'
- &&/unwrap-int ;; tag, sum-tag
- (.visitInsn Opcodes/DUP2) ;; tag, sum-tag, tag, sum-tag
- (.visitJumpInsn Opcodes/IF_ICMPEQ $then) ;; tag, sum-tag
- (.visitInsn Opcodes/DUP2) ;; tag, sum-tag, tag, sum-tag
- (.visitJumpInsn Opcodes/IF_ICMPGT $further) ;; tag, sum-tag
- (.visitInsn Opcodes/POP2)
- (.visitInsn Opcodes/ACONST_NULL)
- (.visitInsn Opcodes/ARETURN)
- (.visitLabel $then) ;; tag, sum-tag
- (.visitVarInsn Opcodes/ALOAD 2) ;; tag, sum-tag, wants-last?
- (.visitVarInsn Opcodes/ALOAD 0)
- (.visitLdcInsn (int 1))
- (.visitInsn Opcodes/AALOAD) ;; tag, sum-tag, wants-last?, is-last?
- (.visitJumpInsn Opcodes/IF_ACMPEQ $just-return)
- (.visitJumpInsn Opcodes/GOTO $further)
- (.visitLabel $just-return)
- (.visitInsn Opcodes/POP2)
- (.visitVarInsn Opcodes/ALOAD 0)
- (.visitLdcInsn (int 2))
- (.visitInsn Opcodes/AALOAD)
- (.visitInsn Opcodes/ARETURN)
- (.visitLabel $further) ;; tag, sum-tag
- (.visitVarInsn Opcodes/ALOAD 0) ;; tag, sum-tag, sum
- (.visitLdcInsn (int 1)) ;; tag, sum-tag, sum, last-index?
- (.visitInsn Opcodes/AALOAD) ;; tag, sum-tag, last?
- (.visitJumpInsn Opcodes/IFNULL $not-right) ;; tag, sum-tag
- (.visitInsn Opcodes/ISUB) ;; sub-tag
- (.visitVarInsn Opcodes/ALOAD 0) ;; sub-tag, sum
- (.visitLdcInsn (int 2)) ;; sub-tag, sum, sub-sum-idx
- (.visitInsn Opcodes/AALOAD) ;; sub-tag, sub-sum
- (.visitTypeInsn Opcodes/CHECKCAST "[Ljava/lang/Object;")
- (.visitVarInsn Opcodes/ASTORE 0) ;; sub-tag
- (.visitVarInsn Opcodes/ISTORE 1) ;;
- (.visitJumpInsn Opcodes/GOTO $begin)
- (.visitLabel $not-right) ;; tag, sum-tag
- (.visitInsn Opcodes/POP2)
- (.visitInsn Opcodes/ACONST_NULL)
- (.visitInsn Opcodes/ARETURN)
- (.visitMaxs 0 0)
- (.visitEnd)))
- _ (let [;; $is-null (new Label)
- ]
- ;; I commented out some parts because a null-check was
- ;; done to ensure variants were never created with null
- ;; values (this would interfere later with
- ;; pattern-matching).
- ;; Since Lux itself doesn't have null values as part of
- ;; the language, the burden of ensuring non-nulls was
- ;; shifted to library code dealing with host-interop, to
- ;; ensure variant-making was as fast as possible.
- ;; The null-checking code was left as comments in case I
- ;; ever change my mind.
- (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "sum_make" "(ILjava/lang/Object;Ljava/lang/Object;)[Ljava/lang/Object;" nil nil)
- (.visitCode)
- ;; (.visitVarInsn Opcodes/ALOAD 2)
- ;; (.visitJumpInsn Opcodes/IFNULL $is-null)
- (.visitLdcInsn (int 3))
- (.visitTypeInsn Opcodes/ANEWARRAY "java/lang/Object")
- (.visitInsn Opcodes/DUP)
- (.visitLdcInsn (int 0))
- (.visitVarInsn Opcodes/ILOAD 0)
- (&&/wrap-int)
- (.visitInsn Opcodes/AASTORE)
- (.visitInsn Opcodes/DUP)
- (.visitLdcInsn (int 1))
- (.visitVarInsn Opcodes/ALOAD 1)
- (.visitInsn Opcodes/AASTORE)
- (.visitInsn Opcodes/DUP)
- (.visitLdcInsn (int 2))
- (.visitVarInsn Opcodes/ALOAD 2)
- (.visitInsn Opcodes/AASTORE)
- (.visitInsn Opcodes/ARETURN)
- ;; (.visitLabel $is-null)
- ;; (.visitTypeInsn Opcodes/NEW "java/lang/IllegalStateException")
- ;; (.visitInsn Opcodes/DUP)
- ;; (.visitLdcInsn "Can't create variant for null pointer")
- ;; (.visitMethodInsn Opcodes/INVOKESPECIAL "java/lang/IllegalStateException" "<init>" "(Ljava/lang/String;)V")
- ;; (.visitInsn Opcodes/ATHROW)
- (.visitMaxs 0 0)
- (.visitEnd)))]
- nil))
-
-(defn ^:private low-4b [^MethodVisitor =method]
- (doto =method
- ;; Assume there is a long at the top of the stack...
- ;; Add mask corresponding to -1 (FFFF...), on the low 32 bits.
- (.visitLdcInsn (int -1))
- (.visitInsn Opcodes/I2L)
- ;; Then do a bitwise and.
- (.visitInsn Opcodes/LAND)
- ))
-
-(defn ^:private high-4b [^MethodVisitor =method]
- (doto =method
- ;; Assume there is a long at the top of the stack...
- (.visitLdcInsn (int 32))
- (.visitInsn Opcodes/LUSHR)
- ))
-
-(defn ^:private swap2 [^MethodVisitor =method]
- (doto =method
- ;; X2, Y2
- (.visitInsn Opcodes/DUP2_X2) ;; Y2, X2, Y2
- (.visitInsn Opcodes/POP2) ;; Y2, X2
- ))
-
-(defn ^:private bit-set-64? [^MethodVisitor =method]
- (doto =method
- ;; L, I
- (.visitLdcInsn (long 1)) ;; L, I, L
- (.visitInsn Opcodes/DUP2_X1) ;; L, L, I, L
- (.visitInsn Opcodes/POP2) ;; L, L, I
- (.visitInsn Opcodes/LSHL) ;; L, L
- (.visitInsn Opcodes/LAND) ;; L
- (.visitLdcInsn (long 0)) ;; L, L
- (.visitInsn Opcodes/LCMP) ;; I
- ))
-
-(defn ^:private compile-LuxRT-frac-methods [^ClassWriter =class]
- (|let [_ (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "mul_frac" "(JJ)J" nil nil)
- ;; Based on: http://stackoverflow.com/a/31629280/6823464
- (.visitCode)
- ;; Bottom part
- (.visitVarInsn Opcodes/LLOAD 0) low-4b
- (.visitVarInsn Opcodes/LLOAD 2) low-4b
- (.visitInsn Opcodes/LMUL)
- (.visitLdcInsn (int 32))
- (.visitInsn Opcodes/LUSHR)
- ;; Middle part
- (.visitVarInsn Opcodes/LLOAD 0) high-4b
- (.visitVarInsn Opcodes/LLOAD 2) low-4b
- (.visitInsn Opcodes/LMUL)
- (.visitVarInsn Opcodes/LLOAD 0) low-4b
- (.visitVarInsn Opcodes/LLOAD 2) high-4b
- (.visitInsn Opcodes/LMUL)
- (.visitInsn Opcodes/LADD)
- ;; Join middle and bottom
- (.visitInsn Opcodes/LADD)
- (.visitLdcInsn (int 32))
- (.visitInsn Opcodes/LUSHR)
- ;; Top part
- (.visitVarInsn Opcodes/LLOAD 0) high-4b
- (.visitVarInsn Opcodes/LLOAD 2) high-4b
- (.visitInsn Opcodes/LMUL)
- ;; Join top with rest
- (.visitInsn Opcodes/LADD)
- ;; Return
- (.visitInsn Opcodes/LRETURN)
- (.visitMaxs 0 0)
- (.visitEnd))
- _ (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "div_frac" "(JJ)J" nil nil)
- (.visitCode)
- ;; Based on: http://stackoverflow.com/a/8510587/6823464
- (.visitVarInsn Opcodes/LLOAD 0)
- (.visitVarInsn Opcodes/LLOAD 2) high-4b
- (.visitInsn Opcodes/LDIV)
- (.visitLdcInsn (int 32))
- (.visitInsn Opcodes/LSHL)
- (.visitInsn Opcodes/LRETURN)
- (.visitMaxs 0 0)
- (.visitEnd))
- _ (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "frac-to-real" "(J)D" nil nil)
- (.visitCode)
- ;; Translate high bytes
- (.visitVarInsn Opcodes/LLOAD 0) high-4b
- (.visitInsn Opcodes/L2D)
- (.visitLdcInsn (double (Math/pow 2 32)))
- (.visitInsn Opcodes/DDIV)
- ;; Translate low bytes
- (.visitVarInsn Opcodes/LLOAD 0) low-4b
- (.visitInsn Opcodes/L2D)
- (.visitLdcInsn (double (Math/pow 2 32)))
- (.visitInsn Opcodes/DDIV)
- (.visitLdcInsn (double (Math/pow 2 32)))
- (.visitInsn Opcodes/DDIV)
- ;; Combine and return
- (.visitInsn Opcodes/DADD)
- (.visitInsn Opcodes/DRETURN)
- (.visitMaxs 0 0)
- (.visitEnd))
- _ (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "real-to-frac" "(D)J" nil nil)
- (.visitCode)
- ;; Drop any excess
- (.visitVarInsn Opcodes/DLOAD 0)
- (.visitLdcInsn (double 1.0))
- (.visitInsn Opcodes/DREM)
- ;; Shift upper half, but retain remaining decimals
- (.visitLdcInsn (double (Math/pow 2 32)))
- (.visitInsn Opcodes/DMUL)
- ;; Make a copy, so the lower half can be extracted
- (.visitInsn Opcodes/DUP2)
- ;; Get that lower half
- (.visitLdcInsn (double 1.0))
- (.visitInsn Opcodes/DREM)
- (.visitLdcInsn (double (Math/pow 2 32)))
- (.visitInsn Opcodes/DMUL)
- ;; Turn it into a frac
- (.visitInsn Opcodes/D2L)
- ;; Turn the upper half into frac too
- swap2
- (.visitInsn Opcodes/D2L)
- ;; Combine both pieces
- (.visitInsn Opcodes/LADD)
- ;; FINISH
- (.visitInsn Opcodes/LRETURN)
- (.visitMaxs 0 0)
- (.visitEnd))
- _ (let [$start (new Label)
- $body (new Label)
- $end (new Label)
- $zero (new Label)]
- (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "count_bin_start_0" "(J)I" nil nil)
- (.visitCode)
- ;; Initialize counter
- (.visitLdcInsn (int 0)) ; I
- (.visitVarInsn Opcodes/ISTORE 2) ;
- ;; Initialize index var
- (.visitLdcInsn (int 63)) ; I
- ;; Begin loop
- (.visitLabel $start) ; I
- ;; Make sure we're still on the valid index range
- (.visitInsn Opcodes/DUP) ; I, I
- (.visitLdcInsn (int -1)) ; I, I, I
- (.visitJumpInsn Opcodes/IF_ICMPGT $body) ; I
- ;; If not, just return what we've got.
- (.visitInsn Opcodes/POP) ;
- (.visitVarInsn Opcodes/ILOAD 2) ; I
- (.visitJumpInsn Opcodes/GOTO $end)
- ;; If so, run the body
- (.visitLabel $body) ;; I
- (.visitInsn Opcodes/DUP) ;; I, I
- (.visitVarInsn Opcodes/LLOAD 0) ;; I, I, L
- (.visitInsn Opcodes/DUP2_X1) ;; I, L, I, L
- (.visitInsn Opcodes/POP2) ;; I, L, I
- bit-set-64? ;; I, I
- (.visitJumpInsn Opcodes/IFEQ $zero) ;; I
- ;; No more zeroes from now on...
- (.visitInsn Opcodes/POP) ;;
- (.visitVarInsn Opcodes/ILOAD 2) ;; I
- (.visitJumpInsn Opcodes/GOTO $end)
- ;; Found another zero...
- (.visitLabel $zero) ;; I
- ;; Increase counter
- (.visitVarInsn Opcodes/ILOAD 2) ;; I, I
- (.visitLdcInsn (int 1)) ;; I, I, I
- (.visitInsn Opcodes/IADD) ;; I, I
- (.visitVarInsn Opcodes/ISTORE 2) ;; I
- ;; Increase index, then iterate again...
- (.visitLdcInsn (int 1)) ;; I, I
- (.visitInsn Opcodes/ISUB) ;; I
- (.visitJumpInsn Opcodes/GOTO $start)
- ;; Finally, return
- (.visitLabel $end) ; I
- (.visitInsn Opcodes/IRETURN)
- (.visitMaxs 0 0)
- (.visitEnd)))
- _ (let [$start (new Label)
- $can-append (new Label)
- $end (new Label)]
- (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "make_text_start_0" "(J)Ljava/lang/String;" nil nil)
- (.visitCode)
- ;; Initialize accum
- (.visitLdcInsn "") ;; S
- (.visitVarInsn Opcodes/ASTORE 2) ;;
- ;; Initialize comparator
- (.visitLdcInsn (long 10)) ;; L
- ;; Testing/accum loop
- (.visitLabel $start) ;; L
- (.visitInsn Opcodes/DUP2) ;; L, L
- (.visitVarInsn Opcodes/LLOAD 0) ;; L, L, L
- (.visitInsn Opcodes/LCMP) ;; L, I
- (.visitJumpInsn Opcodes/IFLT $can-append) ;; L
- ;; No more testing.
- ;; Throw away the comparator and return accum.
- (.visitInsn Opcodes/POP2) ;;
- (.visitVarInsn Opcodes/ALOAD 2) ;; S
- (.visitJumpInsn Opcodes/GOTO $end)
- ;; Can keep accumulating
- (.visitLabel $can-append) ;; L
- ;; Add one more 0 to accum
- (.visitVarInsn Opcodes/ALOAD 2) ;; L, S
- (.visitLdcInsn "0") ;; L, S, S
- (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "concat" "(Ljava/lang/String;)Ljava/lang/String;") ;; L, S
- (.visitVarInsn Opcodes/ASTORE 2) ;; L
- ;; Update comparator and re-iterate
- (.visitLdcInsn (long 10)) ;; L, L
- (.visitInsn Opcodes/LMUL) ;; L
- (.visitJumpInsn Opcodes/GOTO $start)
- (.visitLabel $end) ;; S
- (.visitInsn Opcodes/ARETURN)
- (.visitMaxs 0 0)
- (.visitEnd)))
- _ (let [$is-zero (new Label)
- $end (new Label)]
- (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "encode_frac" "(J)Ljava/lang/String;" nil nil)
- (.visitCode)
- (.visitVarInsn Opcodes/LLOAD 0)
- (.visitLdcInsn (long 0))
- (.visitInsn Opcodes/LCMP)
- (.visitJumpInsn Opcodes/IFEQ $is-zero)
- ;; IF =/= 0
- ;; Generate leading 0s
- (.visitLdcInsn (long 1))
- (.visitVarInsn Opcodes/LLOAD 0)
- (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "count_bin_start_0" "(J)I")
- (.visitInsn Opcodes/LSHL)
- (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "make_text_start_0" "(J)Ljava/lang/String;")
- ;; Convert to number text
- (.visitVarInsn Opcodes/LLOAD 0)
- (.visitMethodInsn Opcodes/INVOKESTATIC "java/lang/Long" "toUnsignedString" "(J)Ljava/lang/String;")
- ;; Remove unnecessary trailing zeroes
- (.visitLdcInsn "0*$")
- (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "split" "(Ljava/lang/String;)[Ljava/lang/String;")
- (.visitLdcInsn (int 0))
- (.visitInsn Opcodes/AALOAD)
- ;; Join leading 0s with number text
- (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "concat" "(Ljava/lang/String;)Ljava/lang/String;")
- ;; FINISH
- (.visitJumpInsn Opcodes/GOTO $end)
- ;; IF == 0
- (.visitLabel $is-zero)
- (.visitLdcInsn ".0")
- (.visitLabel $end)
- (.visitInsn Opcodes/ARETURN)
- (.visitMaxs 0 0)
- (.visitEnd)))
- _ (let [$end (new Label)
- ;; $then (new Label)
- $else (new Label)
- $from (new Label)
- $to (new Label)
- $handler (new Label)]
- (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "decode_frac" "(Ljava/lang/String;)Ljava/lang/Object;" nil nil)
- (.visitCode)
- ;; Check prefix
- (.visitVarInsn Opcodes/ALOAD 0)
- (.visitLdcInsn ".")
- (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "startsWith" "(Ljava/lang/String;)Z")
- (.visitJumpInsn Opcodes/IFEQ $else)
- ;; Remove prefix
- (.visitVarInsn Opcodes/ALOAD 0)
- (.visitLdcInsn (int 1))
- (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "substring" "(I)Ljava/lang/String;")
- (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "clean_separators" "(Ljava/lang/String;)Ljava/lang/String;")
- (.visitInsn Opcodes/DUP)
- (.visitTryCatchBlock $from $to $handler "java/lang/Exception")
- (.visitLabel $from)
- (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "read_frac_text" "(Ljava/lang/String;)J")
- (.visitLabel $to)
- (.visitInsn Opcodes/DUP2)
- (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "count_bin_start_0" "(J)I")
- (.visitInsn Opcodes/LSHL)
- (.visitInsn Opcodes/DUP2_X1)
- (.visitInsn Opcodes/POP2)
- (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "count_leading_zeroes" "(Ljava/lang/String;)J")
- (.visitInsn Opcodes/L2D)
- (.visitLdcInsn (double 10.0))
- swap2
- (.visitMethodInsn Opcodes/INVOKESTATIC "java/lang/Math" "pow" "(DD)D")
- (.visitInsn Opcodes/D2L)
- (.visitInsn Opcodes/LDIV)
- ;; (.visitJumpInsn Opcodes/GOTO $then)
- ;; (.visitLabel $then)
- (&&/wrap-long)
- (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "make_some" "(Ljava/lang/Object;)Ljava/lang/Object;")
- (.visitFrame Opcodes/F_NEW 1 (to-array ["java/lang/String"]) 1 (to-array ["java/lang/Object"]))
- (.visitJumpInsn Opcodes/GOTO $end)
- (.visitLabel $handler)
- (.visitFrame Opcodes/F_NEW 1 (to-array ["java/lang/String"]) 1 (to-array ["java/lang/Exception"]))
- (.visitInsn Opcodes/POP)
- (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "make_none" "()Ljava/lang/Object;")
- (.visitFrame Opcodes/F_NEW 1 (to-array ["java/lang/String"]) 1 (to-array ["java/lang/Object"]))
- (.visitJumpInsn Opcodes/GOTO $end)
- ;; Doesn't start with necessary prefix.
- (.visitLabel $else)
- (.visitFrame Opcodes/F_NEW 1 (to-array ["java/lang/String"]) 0 (to-array []))
- (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "make_none" "()Ljava/lang/Object;")
- (.visitLabel $end)
- (.visitFrame Opcodes/F_NEW 1 (to-array ["java/lang/String"]) 1 (to-array ["java/lang/Object"]))
- (.visitInsn Opcodes/ARETURN)
- (.visitMaxs 0 0)
- (.visitEnd)))
- _ (let [string-bcn (&host-generics/->bytecode-class-name "java.lang.String")
- $valid (new Label)
- $end (new Label)]
- (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "count_leading_zeroes" "(Ljava/lang/String;)J" nil nil)
- (.visitCode)
- (.visitVarInsn Opcodes/ALOAD 0) ;; S
- (.visitLdcInsn "^0*") ;; S, S
- (.visitMethodInsn Opcodes/INVOKEVIRTUAL string-bcn "split" "(Ljava/lang/String;)[Ljava/lang/String;") ;; [S
- (.visitInsn Opcodes/DUP) ;; [S, [S
- (.visitInsn Opcodes/ARRAYLENGTH) ;; [S, I
- (.visitLdcInsn (int 2)) ;; [S, I, I
- (.visitJumpInsn Opcodes/IF_ICMPEQ $valid) ;; [S
- ;; Invalid...
- (.visitInsn Opcodes/POP) ;;
- (.visitLdcInsn (long 0)) ;; J
- (.visitJumpInsn Opcodes/GOTO $end)
- (.visitLabel $valid) ;; [S
- ;; Valid...
- (.visitLdcInsn (int 1)) ;; [S, I
- (.visitInsn Opcodes/AALOAD) ;; S
- (.visitMethodInsn Opcodes/INVOKEVIRTUAL string-bcn "length" "()I") ;; I
- (.visitVarInsn Opcodes/ALOAD 0) ;; I, S
- (.visitMethodInsn Opcodes/INVOKEVIRTUAL string-bcn "length" "()I") ;; I, I
- (.visitInsn Opcodes/SWAP) ;; I, I
- (.visitInsn Opcodes/ISUB) ;; I
- (.visitInsn Opcodes/I2L) ;; J
- (.visitLabel $end) ;; J
- (.visitInsn Opcodes/LRETURN)
- (.visitMaxs 0 0)
- (.visitEnd)))
- _ (let [$only-zeroes (new Label)
- $end (new Label)]
- (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "read_frac_text" "(Ljava/lang/String;)J" nil nil)
- (.visitCode)
- (.visitVarInsn Opcodes/ALOAD 0)
- (.visitLdcInsn "0*$")
- (.visitMethodInsn Opcodes/INVOKEVIRTUAL
- (&host-generics/->bytecode-class-name "java.lang.String")
- "split" "(Ljava/lang/String;)[Ljava/lang/String;")
- (.visitInsn Opcodes/DUP)
- (.visitInsn Opcodes/ARRAYLENGTH)
- (.visitJumpInsn Opcodes/IFEQ $only-zeroes)
- (.visitLdcInsn (int 0))
- (.visitInsn Opcodes/AALOAD)
- (.visitMethodInsn Opcodes/INVOKESTATIC "java/lang/Long" "parseUnsignedLong" "(Ljava/lang/String;)J")
- (.visitJumpInsn Opcodes/GOTO $end)
- (.visitLabel $only-zeroes)
- (.visitInsn Opcodes/POP)
- (.visitVarInsn Opcodes/ALOAD 0)
- (.visitMethodInsn Opcodes/INVOKESTATIC "java/lang/Long" "parseUnsignedLong" "(Ljava/lang/String;)J")
- (.visitLabel $end)
- (.visitInsn Opcodes/LRETURN)
- (.visitMaxs 0 0)
- (.visitEnd)))
- ]
- nil))
-
-(let [+wrapper-class+ (&host-generics/->bytecode-class-name "java.lang.Long")]
- (defn ^:private compile-LuxRT-nat-methods [^ClassWriter =class]
- (|let [;; http://grepcode.com/file/repository.grepcode.com/java/root/jdk/openjdk/8u40-b25/java/lang/Long.java#677
- _ (let [$from (new Label)
- $to (new Label)
- $handler (new Label)
-
- $good-start (new Label)
- $short-enough (new Label)
- $bad-digit (new Label)
- $out-of-bounds (new Label)]
- (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "decode_nat" "(Ljava/lang/String;)Ljava/lang/Object;" nil nil)
- (.visitCode)
- (.visitTryCatchBlock $from $to $handler "java/lang/Exception")
- (.visitLabel $from)
- ;; Remove the + at the beginning...
- (.visitVarInsn Opcodes/ALOAD 0)
- (.visitLdcInsn (int 0))
- (.visitLdcInsn (int 0))
- (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "substring" "(II)Ljava/lang/String;")
- (.visitLdcInsn "+")
- (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/Object" "equals" "(Ljava/lang/Object;)Z")
- (.visitJumpInsn Opcodes/IFNE $good-start)
- ;; Doesn't start with +
- (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "make_none" "()Ljava/lang/Object;")
- (.visitInsn Opcodes/ARETURN)
- ;; Starts with +
- (.visitLabel $good-start)
- (.visitVarInsn Opcodes/ALOAD 0)
- (.visitLdcInsn (int 1))
- (.visitVarInsn Opcodes/ALOAD 0)
- (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "length" "()I")
- (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "substring" "(II)Ljava/lang/String;")
- (.visitVarInsn Opcodes/ASTORE 0) ;; Removed the + prefix...
- ;; Begin parsing processs
- (.visitVarInsn Opcodes/ALOAD 0)
- (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "length" "()I")
- (.visitLdcInsn (int 18))
- (.visitJumpInsn Opcodes/IF_ICMPLE $short-enough)
- ;; Too long
- ;; Get prefix...
- (.visitVarInsn Opcodes/ALOAD 0)
- (.visitLdcInsn (int 0))
- (.visitVarInsn Opcodes/ALOAD 0)
- (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "length" "()I")
- (.visitLdcInsn (int 1))
- (.visitInsn Opcodes/ISUB)
- (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "substring" "(II)Ljava/lang/String;")
- (.visitMethodInsn Opcodes/INVOKESTATIC "java/lang/Long" "parseLong" "(Ljava/lang/String;)J")
- (.visitInsn Opcodes/DUP2) ;; Clone prefix, for later...
- ;; Get last digit...
- (.visitVarInsn Opcodes/ALOAD 0)
- (.visitVarInsn Opcodes/ALOAD 0)
- (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "length" "()I")
- (.visitLdcInsn (int 1))
- (.visitInsn Opcodes/ISUB)
- (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "charAt" "(I)C")
- (.visitLdcInsn (int 10))
- (.visitMethodInsn Opcodes/INVOKESTATIC "java/lang/Character" "digit" "(CI)I")
- ;; Test last digit...
- (.visitInsn Opcodes/DUP)
- (.visitJumpInsn Opcodes/IFLT $bad-digit)
- ;; Good digit...
- ;; Stack: prefix::L, prefix::L, last-digit::I
- (.visitInsn Opcodes/I2L)
- ;; Build the result...
- swap2
- (.visitLdcInsn (long 10))
- (.visitInsn Opcodes/LMUL)
- (.visitInsn Opcodes/LADD) ;; Stack: prefix::L, result::L
- (.visitInsn Opcodes/DUP2_X2) ;; Stack: result::L, prefix::L, result::L
- swap2 ;; Stack: result::L, result::L, prefix::L
- (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "_compareUnsigned" "(JJ)I")
- (.visitJumpInsn Opcodes/IFLT $out-of-bounds)
- ;; Within bounds
- ;; Stack: result::L
- &&/wrap-long
- (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "make_some" "(Ljava/lang/Object;)Ljava/lang/Object;")
- (.visitInsn Opcodes/ARETURN)
- ;; Out of bounds
- (.visitLabel $out-of-bounds)
- (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "make_none" "()Ljava/lang/Object;")
- (.visitInsn Opcodes/ARETURN)
- ;; Bad digit...
- (.visitLabel $bad-digit)
- (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "make_none" "()Ljava/lang/Object;")
- (.visitInsn Opcodes/ARETURN)
- ;; 18 chars or less
- (.visitLabel $short-enough)
- (.visitVarInsn Opcodes/ALOAD 0)
- (.visitMethodInsn Opcodes/INVOKESTATIC "java/lang/Long" "parseLong" "(Ljava/lang/String;)J")
- &&/wrap-long
- (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "make_some" "(Ljava/lang/Object;)Ljava/lang/Object;")
- (.visitInsn Opcodes/ARETURN)
- (.visitLabel $to)
- (.visitLabel $handler)
- (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "make_none" "()Ljava/lang/Object;")
- (.visitInsn Opcodes/ARETURN)
- (.visitMaxs 0 0)
- (.visitEnd)))
- ;; http://grepcode.com/file/repository.grepcode.com/java/root/jdk/openjdk/8u40-b25/java/lang/Long.java#172
- _ (let [$too-big (new Label)]
- (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "encode_nat" "(J)Ljava/lang/String;" nil nil)
- (.visitCode)
- (.visitLdcInsn "+")
- (.visitVarInsn Opcodes/LLOAD 0)
- (.visitLdcInsn (long 0))
- (.visitInsn Opcodes/LCMP)
- (.visitJumpInsn Opcodes/IFLT $too-big)
- ;; then
- (.visitVarInsn Opcodes/LLOAD 0)
- (.visitMethodInsn Opcodes/INVOKESTATIC "java/lang/Long" "toString" "(J)Ljava/lang/String;")
- (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "concat" "(Ljava/lang/String;)Ljava/lang/String;")
- (.visitInsn Opcodes/ARETURN)
- ;; else
- (.visitLabel $too-big)
- ;; Set up parts of the number string...
- ;; First digits
- (.visitVarInsn Opcodes/LLOAD 0)
- (.visitLdcInsn (int 1))
- (.visitInsn Opcodes/LUSHR)
- (.visitLdcInsn (long 5))
- (.visitInsn Opcodes/LDIV) ;; quot
- ;; Last digit
- (.visitInsn Opcodes/DUP2)
- (.visitLdcInsn (long 10))
- (.visitInsn Opcodes/LMUL)
- (.visitVarInsn Opcodes/LLOAD 0)
- swap2
- (.visitInsn Opcodes/LSUB) ;; quot, rem
- ;; Conversion to string...
- (.visitMethodInsn Opcodes/INVOKESTATIC "java/lang/Long" "toString" "(J)Ljava/lang/String;") ;; quot, rem*
- (.visitInsn Opcodes/DUP_X2);; rem*, quot, rem*
- (.visitInsn Opcodes/POP) ;; rem*, quot
- (.visitMethodInsn Opcodes/INVOKESTATIC "java/lang/Long" "toString" "(J)Ljava/lang/String;") ;; rem*, quot*
- (.visitInsn Opcodes/SWAP) ;; quot*, rem*
- (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "concat" "(Ljava/lang/String;)Ljava/lang/String;")
- (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "concat" "(Ljava/lang/String;)Ljava/lang/String;")
- (.visitInsn Opcodes/ARETURN)
- (.visitMaxs 0 0)
- (.visitEnd)))
- ;; http://grepcode.com/file/repository.grepcode.com/java/root/jdk/openjdk/8u40-b25/java/lang/Long.java#215
- _ (let [$simple-case (new Label)]
- (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "_toUnsignedBigInteger" "(J)Ljava/math/BigInteger;" nil nil)
- (.visitCode)
- (.visitVarInsn Opcodes/LLOAD 0)
- (.visitLdcInsn (long 0))
- (.visitInsn Opcodes/LCMP)
- (.visitJumpInsn Opcodes/IFGE $simple-case)
- ;; else
- (.visitVarInsn Opcodes/LLOAD 0)
- (.visitLdcInsn (int 32))
- (.visitInsn Opcodes/LUSHR)
- (.visitMethodInsn Opcodes/INVOKESTATIC "java/math/BigInteger" "valueOf" "(J)Ljava/math/BigInteger;")
- (.visitLdcInsn (int 32))
- (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/math/BigInteger" "shiftLeft" "(I)Ljava/math/BigInteger;")
- (.visitVarInsn Opcodes/LLOAD 0)
- (.visitLdcInsn (int 32))
- (.visitInsn Opcodes/LSHL)
- (.visitLdcInsn (int 32))
- (.visitInsn Opcodes/LUSHR)
- (.visitMethodInsn Opcodes/INVOKESTATIC "java/math/BigInteger" "valueOf" "(J)Ljava/math/BigInteger;")
- (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/math/BigInteger" "add" "(Ljava/math/BigInteger;)Ljava/math/BigInteger;")
- (.visitInsn Opcodes/ARETURN)
- ;; then
- (.visitLabel $simple-case)
- (.visitVarInsn Opcodes/LLOAD 0)
- (.visitMethodInsn Opcodes/INVOKESTATIC "java/math/BigInteger" "valueOf" "(J)Ljava/math/BigInteger;")
- (.visitInsn Opcodes/ARETURN)
- (.visitMaxs 0 0)
- (.visitEnd)))
- ;; http://grepcode.com/file/repository.grepcode.com/java/root/jdk/openjdk/8u40-b25/java/lang/Long.java?av=f#1267
- _ (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "_compareUnsigned" "(JJ)I" nil nil)
- (.visitCode)
- (.visitVarInsn Opcodes/LLOAD 0)
- (.visitFieldInsn Opcodes/GETSTATIC "java/lang/Long" "MIN_VALUE" "J")
- (.visitInsn Opcodes/LADD)
- (.visitVarInsn Opcodes/LLOAD 2)
- (.visitFieldInsn Opcodes/GETSTATIC "java/lang/Long" "MIN_VALUE" "J")
- (.visitInsn Opcodes/LADD)
- (.visitInsn Opcodes/LCMP)
- (.visitInsn Opcodes/IRETURN)
- (.visitMaxs 0 0)
- (.visitEnd))
- ;; http://grepcode.com/file/repository.grepcode.com/java/root/jdk/openjdk/8u40-b25/java/lang/Long.java#1290
- _ (let [$case-1 (new Label)
- $0 (new Label)
- $case-2 (new Label)]
- (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "div_nat" "(JJ)J" nil nil)
- (.visitCode)
- ;; Test #1
- (.visitVarInsn Opcodes/LLOAD 2)
- (.visitLdcInsn (long 0))
- (.visitInsn Opcodes/LCMP)
- (.visitJumpInsn Opcodes/IFLT $case-1)
- ;; Test #2
- (.visitVarInsn Opcodes/LLOAD 0)
- (.visitLdcInsn (long 0))
- (.visitInsn Opcodes/LCMP)
- (.visitJumpInsn Opcodes/IFGT $case-2)
- ;; Case #3
- (.visitVarInsn Opcodes/LLOAD 0)
- (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "_toUnsignedBigInteger" "(J)Ljava/math/BigInteger;")
- (.visitVarInsn Opcodes/LLOAD 2)
- (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "_toUnsignedBigInteger" "(J)Ljava/math/BigInteger;")
- (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/math/BigInteger" "divide" "(Ljava/math/BigInteger;)Ljava/math/BigInteger;")
- (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/math/BigInteger" "longValue" "()J")
- (.visitInsn Opcodes/LRETURN)
- ;; Case #2
- (.visitLabel $case-2)
- (.visitVarInsn Opcodes/LLOAD 0)
- (.visitVarInsn Opcodes/LLOAD 2)
- (.visitInsn Opcodes/LDIV)
- (.visitInsn Opcodes/LRETURN)
- ;; Case #1
- (.visitLabel $case-1)
- (.visitVarInsn Opcodes/LLOAD 0)
- (.visitVarInsn Opcodes/LLOAD 2)
- (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "_compareUnsigned" "(JJ)I")
- (.visitJumpInsn Opcodes/IFLT $0)
- ;; 1
- (.visitLdcInsn (long 1))
- (.visitInsn Opcodes/LRETURN)
- ;; 0
- (.visitLabel $0)
- (.visitLdcInsn (long 0))
- (.visitInsn Opcodes/LRETURN)
- (.visitMaxs 0 0)
- (.visitEnd)))
- ;; http://grepcode.com/file/repository.grepcode.com/java/root/jdk/openjdk/8u40-b25/java/lang/Long.java#1323
- _ (let [$test-2 (new Label)
- $case-2 (new Label)]
- (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "rem_nat" "(JJ)J" nil nil)
- (.visitCode)
- ;; Test #1
- (.visitVarInsn Opcodes/LLOAD 0)
- (.visitLdcInsn (long 0))
- (.visitInsn Opcodes/LCMP)
- (.visitJumpInsn Opcodes/IFLE $test-2)
- (.visitVarInsn Opcodes/LLOAD 2)
- (.visitLdcInsn (long 0))
- (.visitInsn Opcodes/LCMP)
- (.visitJumpInsn Opcodes/IFLE $test-2)
- ;; Case #1
- (.visitVarInsn Opcodes/LLOAD 0)
- (.visitVarInsn Opcodes/LLOAD 2)
- (.visitInsn Opcodes/LREM)
- (.visitInsn Opcodes/LRETURN)
- ;; Test #2
- (.visitLabel $test-2)
- (.visitVarInsn Opcodes/LLOAD 0)
- (.visitVarInsn Opcodes/LLOAD 2)
- (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "_compareUnsigned" "(JJ)I")
- (.visitJumpInsn Opcodes/IFLT $case-2)
- ;; Case #3
- (.visitVarInsn Opcodes/LLOAD 0)
- (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "_toUnsignedBigInteger" "(J)Ljava/math/BigInteger;")
- (.visitVarInsn Opcodes/LLOAD 2)
- (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "_toUnsignedBigInteger" "(J)Ljava/math/BigInteger;")
- (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/math/BigInteger" "remainder" "(Ljava/math/BigInteger;)Ljava/math/BigInteger;")
- (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/math/BigInteger" "longValue" "()J")
- (.visitInsn Opcodes/LRETURN)
- ;; Case #2
- (.visitLabel $case-2)
- (.visitVarInsn Opcodes/LLOAD 0)
- (.visitInsn Opcodes/LRETURN)
- ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
- (.visitMaxs 0 0)
- (.visitEnd)))]
- nil)))
-
-(defn ^:private compile-LuxRT-pm-methods [^ClassWriter =class]
- (|let [_ (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "pm_fail" "()V" nil nil)
- (.visitCode)
- (.visitTypeInsn Opcodes/NEW "java/lang/IllegalStateException")
- (.visitInsn Opcodes/DUP)
- (.visitLdcInsn "Invalid expression for pattern-matching.")
- (.visitMethodInsn Opcodes/INVOKESPECIAL "java/lang/IllegalStateException" "<init>" "(Ljava/lang/String;)V")
- (.visitInsn Opcodes/ATHROW)
- (.visitMaxs 0 0)
- (.visitEnd))
- _ (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "pm_stack_push" "([Ljava/lang/Object;Ljava/lang/Object;)[Ljava/lang/Object;" nil nil)
- (.visitCode)
- (.visitLdcInsn (int 2))
- (.visitTypeInsn Opcodes/ANEWARRAY "java/lang/Object")
- (.visitInsn Opcodes/DUP)
- (.visitLdcInsn (int 0))
- (.visitVarInsn Opcodes/ALOAD 0)
- (.visitInsn Opcodes/AASTORE)
- (.visitInsn Opcodes/DUP)
- (.visitLdcInsn (int 1))
- (.visitVarInsn Opcodes/ALOAD 1)
- (.visitInsn Opcodes/AASTORE)
- (.visitInsn Opcodes/ARETURN)
- (.visitMaxs 0 0)
- (.visitEnd))
- _ (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "pm_stack_pop" "([Ljava/lang/Object;)[Ljava/lang/Object;" nil nil)
- (.visitCode)
- (.visitVarInsn Opcodes/ALOAD 0)
- (.visitLdcInsn (int 0))
- (.visitInsn Opcodes/AALOAD)
- (.visitTypeInsn Opcodes/CHECKCAST "[Ljava/lang/Object;")
- (.visitInsn Opcodes/ARETURN)
- (.visitMaxs 0 0)
- (.visitEnd))
- _ (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "pm_stack_peek" "([Ljava/lang/Object;)Ljava/lang/Object;" nil nil)
- (.visitCode)
- (.visitVarInsn Opcodes/ALOAD 0)
- (.visitLdcInsn (int 1))
- (.visitInsn Opcodes/AALOAD)
- (.visitInsn Opcodes/ARETURN)
- (.visitMaxs 0 0)
- (.visitEnd))]
- nil))
-
-(def compile-LuxRT-class
- (|do [_ (return nil)
- :let [full-name &&/lux-utils-class
- super-class (&host-generics/->bytecode-class-name "java.lang.Object")
- tag-sig (&host-generics/->type-signature "java.lang.String")
- =class (doto (new ClassWriter ClassWriter/COMPUTE_MAXS)
- (.visit &host/bytecode-version (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_SUPER)
- full-name nil super-class (into-array String [])))
- =unit-tag (doto (.visitField =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) &&/unit-tag-field tag-sig nil &/unit-tag)
- (.visitEnd))
- =init-method (doto (.visitMethod =class Opcodes/ACC_PRIVATE init-method "()V" nil nil)
- (.visitCode)
- (.visitVarInsn Opcodes/ALOAD 0)
- (.visitMethodInsn Opcodes/INVOKESPECIAL super-class init-method "()V")
- (.visitInsn Opcodes/RETURN)
- (.visitMaxs 0 0)
- (.visitEnd))
- _ (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "log" "(Ljava/lang/Object;)Ljava/lang/Object;" nil nil)
- (.visitCode)
- (.visitFieldInsn Opcodes/GETSTATIC "java/lang/System" "out" "Ljava/io/PrintStream;")
- (.visitLdcInsn "LOG: ")
- (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/io/PrintStream" "print" "(Ljava/lang/Object;)V")
- (.visitFieldInsn Opcodes/GETSTATIC "java/lang/System" "out" "Ljava/io/PrintStream;")
- (.visitVarInsn Opcodes/ALOAD 0)
- (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/io/PrintStream" "println" "(Ljava/lang/Object;)V")
- (.visitVarInsn Opcodes/ALOAD 0)
- (.visitInsn Opcodes/ARETURN)
- (.visitMaxs 0 0)
- (.visitEnd))
- _ (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "make_none" "()Ljava/lang/Object;" nil nil)
- (.visitCode)
- (.visitLdcInsn (->> #'&/$None meta ::&/idx int)) ;; I
- (.visitInsn Opcodes/ACONST_NULL) ;; I?
- (.visitLdcInsn &/unit-tag) ;; I?U
- (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "sum_make" "(ILjava/lang/Object;Ljava/lang/Object;)[Ljava/lang/Object;")
- (.visitInsn Opcodes/ARETURN)
- (.visitMaxs 0 0)
- (.visitEnd))
- _ (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "make_some" "(Ljava/lang/Object;)Ljava/lang/Object;" nil nil)
- (.visitCode)
- (.visitLdcInsn (->> #'&/$Some meta ::&/idx int)) ;; I
- (.visitInsn Opcodes/ACONST_NULL) ;; I?
- (.visitVarInsn Opcodes/ALOAD 0) ;; I?O
- (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "sum_make" "(ILjava/lang/Object;Ljava/lang/Object;)[Ljava/lang/Object;")
- (.visitInsn Opcodes/ARETURN)
- (.visitMaxs 0 0)
- (.visitEnd))
- _ (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "clean_separators" "(Ljava/lang/String;)Ljava/lang/String;" nil nil)
- (.visitCode)
- (.visitVarInsn Opcodes/ALOAD 0)
- (.visitLdcInsn ",|_")
- (.visitLdcInsn "")
- (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "replaceAll" "(Ljava/lang/String;Ljava/lang/String;)Ljava/lang/String;")
- (.visitInsn Opcodes/ARETURN)
- (.visitMaxs 0 0)
- (.visitEnd))
- _ (doto =class
- (compile-LuxRT-pm-methods)
- (compile-LuxRT-adt-methods)
- (compile-LuxRT-nat-methods)
- (compile-LuxRT-frac-methods))]]
- (&&/save-class! (second (string/split &&/lux-utils-class #"/"))
- (.toByteArray (doto =class .visitEnd)))))
-
-(defn ^:private compile-jvm-try [compile ?values special-args]
- (|do [:let [(&/$Cons ?body (&/$Cons ?catch (&/$Nil))) ?values
- ;; (&/$Nil) special-args
- ]
- ^MethodVisitor *writer* &/get-writer
- :let [$from (new Label)
- $to (new Label)
- $handler (new Label)
- $end (new Label)]
- :let [_ (doto *writer*
- (.visitTryCatchBlock $from $to $handler "java/lang/Exception")
- (.visitLabel $from))]
- _ (compile ?body)
- :let [_ (doto *writer*
- (.visitJumpInsn Opcodes/GOTO $end)
- (.visitLabel $to)
- (.visitLabel $handler))]
- _ (compile ?catch)
- :let [_ (doto *writer*
- (.visitTypeInsn Opcodes/CHECKCAST &&/function-class)
- (.visitInsn Opcodes/SWAP)
- (.visitMethodInsn Opcodes/INVOKEVIRTUAL &&/function-class &&/apply-method (&&/apply-signature 1)))]
- :let [_ (.visitLabel *writer* $end)]]
- (return nil)))
-
-(do-template [<name> <op> <from-class> <from-method> <from-sig> <to-class> <to-sig>]
- (defn <name> [compile _?value special-args]
- (|do [:let [(&/$Cons ?value (&/$Nil)) _?value]
- ^MethodVisitor *writer* &/get-writer
- :let [_ (doto *writer*
- (.visitTypeInsn Opcodes/NEW (&host-generics/->bytecode-class-name <to-class>))
- (.visitInsn Opcodes/DUP))]
- _ (compile ?value)
- :let [_ (doto *writer*
- (.visitTypeInsn Opcodes/CHECKCAST (&host-generics/->bytecode-class-name <from-class>))
- (.visitMethodInsn Opcodes/INVOKEVIRTUAL (&host-generics/->bytecode-class-name <from-class>) <from-method> <from-sig>)
- (.visitInsn <op>)
- (.visitMethodInsn Opcodes/INVOKESPECIAL (&host-generics/->bytecode-class-name <to-class>) init-method <to-sig>))]]
- (return nil)))
-
- ^:private compile-jvm-d2f Opcodes/D2F "java.lang.Double" "doubleValue" "()D" "java.lang.Float" "(F)V"
- ^:private compile-jvm-d2i Opcodes/D2I "java.lang.Double" "doubleValue" "()D" "java.lang.Integer" "(I)V"
- ^:private compile-jvm-d2l Opcodes/D2L "java.lang.Double" "doubleValue" "()D" "java.lang.Long" "(J)V"
-
- ^:private compile-jvm-f2d Opcodes/F2D "java.lang.Float" "floatValue" "()F" "java.lang.Double" "(D)V"
- ^:private compile-jvm-f2i Opcodes/F2I "java.lang.Float" "floatValue" "()F" "java.lang.Integer" "(I)V"
- ^:private compile-jvm-f2l Opcodes/F2L "java.lang.Float" "floatValue" "()F" "java.lang.Long" "(J)V"
-
- ^:private compile-jvm-i2b Opcodes/I2B "java.lang.Integer" "intValue" "()I" "java.lang.Byte" "(B)V"
- ^:private compile-jvm-i2c Opcodes/I2C "java.lang.Integer" "intValue" "()I" "java.lang.Character" "(C)V"
- ^:private compile-jvm-i2d Opcodes/I2D "java.lang.Integer" "intValue" "()I" "java.lang.Double" "(D)V"
- ^:private compile-jvm-i2f Opcodes/I2F "java.lang.Integer" "intValue" "()I" "java.lang.Float" "(F)V"
- ^:private compile-jvm-i2l Opcodes/I2L "java.lang.Integer" "intValue" "()I" "java.lang.Long" "(J)V"
- ^:private compile-jvm-i2s Opcodes/I2S "java.lang.Integer" "intValue" "()I" "java.lang.Short" "(S)V"
-
- ^:private compile-jvm-l2d Opcodes/L2D "java.lang.Long" "longValue" "()J" "java.lang.Double" "(D)V"
- ^:private compile-jvm-l2f Opcodes/L2F "java.lang.Long" "longValue" "()J" "java.lang.Float" "(F)V"
- ^:private compile-jvm-l2i Opcodes/L2I "java.lang.Long" "longValue" "()J" "java.lang.Integer" "(I)V"
- ^:private compile-jvm-l2s Opcodes/L2I "java.lang.Long" "longValue" "()J" "java.lang.Short" "(S)V"
- ^:private compile-jvm-l2b Opcodes/L2I "java.lang.Long" "longValue" "()J" "java.lang.Byte" "(B)V"
-
- ^:private compile-jvm-c2b Opcodes/I2B "java.lang.Character" "charValue" "()C" "java.lang.Byte" "(B)V"
- ^:private compile-jvm-c2s Opcodes/I2S "java.lang.Character" "charValue" "()C" "java.lang.Short" "(S)V"
- ^:private compile-jvm-c2i Opcodes/NOP "java.lang.Character" "charValue" "()C" "java.lang.Integer" "(I)V"
- ^:private compile-jvm-c2l Opcodes/I2L "java.lang.Character" "charValue" "()C" "java.lang.Long" "(J)V"
-
- ^:private compile-jvm-s2l Opcodes/I2L "java.lang.Short" "shortValue" "()S" "java.lang.Long" "(J)V"
-
- ^:private compile-jvm-b2l Opcodes/I2L "java.lang.Byte" "byteValue" "()B" "java.lang.Long" "(J)V"
- )
-
-(do-template [<name> <op> <from1-method> <from1-sig> <from1-class> <from2-method> <from2-sig> <from2-class> <to-class> <to-sig>]
- (defn <name> [compile ?values special-args]
- (|do [:let [(&/$Cons ?x (&/$Cons ?y (&/$Nil))) ?values]
- ^MethodVisitor *writer* &/get-writer
- :let [_ (doto *writer*
- (.visitTypeInsn Opcodes/NEW (&host-generics/->bytecode-class-name <to-class>))
- (.visitInsn Opcodes/DUP))]
- _ (compile ?x)
- :let [_ (doto *writer*
- (.visitTypeInsn Opcodes/CHECKCAST (&host-generics/->bytecode-class-name <from1-class>))
- (.visitMethodInsn Opcodes/INVOKEVIRTUAL (&host-generics/->bytecode-class-name <from1-class>) <from1-method> <from1-sig>))]
- _ (compile ?y)
- :let [_ (doto *writer*
- (.visitTypeInsn Opcodes/CHECKCAST (&host-generics/->bytecode-class-name <from2-class>))
- (.visitMethodInsn Opcodes/INVOKEVIRTUAL (&host-generics/->bytecode-class-name <from2-class>) <from2-method> <from2-sig>))]
- :let [_ (doto *writer*
- (.visitInsn <op>)
- (.visitMethodInsn Opcodes/INVOKESPECIAL (&host-generics/->bytecode-class-name <to-class>) init-method <to-sig>))]]
- (return nil)))
-
- ^:private compile-jvm-iand Opcodes/IAND "intValue" "()I" "java.lang.Integer" "intValue" "()I" "java.lang.Integer" "java.lang.Integer" "(I)V"
- ^:private compile-jvm-ior Opcodes/IOR "intValue" "()I" "java.lang.Integer" "intValue" "()I" "java.lang.Integer" "java.lang.Integer" "(I)V"
- ^:private compile-jvm-ixor Opcodes/IXOR "intValue" "()I" "java.lang.Integer" "intValue" "()I" "java.lang.Integer" "java.lang.Integer" "(I)V"
- ^:private compile-jvm-ishl Opcodes/ISHL "intValue" "()I" "java.lang.Integer" "intValue" "()I" "java.lang.Integer" "java.lang.Integer" "(I)V"
- ^:private compile-jvm-ishr Opcodes/ISHR "intValue" "()I" "java.lang.Integer" "intValue" "()I" "java.lang.Integer" "java.lang.Integer" "(I)V"
- ^:private compile-jvm-iushr Opcodes/IUSHR "intValue" "()I" "java.lang.Integer" "intValue" "()I" "java.lang.Integer" "java.lang.Integer" "(I)V"
-
- ^:private compile-jvm-land Opcodes/LAND "longValue" "()J" "java.lang.Long" "longValue" "()J" "java.lang.Long" "java.lang.Long" "(J)V"
- ^:private compile-jvm-lor Opcodes/LOR "longValue" "()J" "java.lang.Long" "longValue" "()J" "java.lang.Long" "java.lang.Long" "(J)V"
- ^:private compile-jvm-lxor Opcodes/LXOR "longValue" "()J" "java.lang.Long" "longValue" "()J" "java.lang.Long" "java.lang.Long" "(J)V"
- ^:private compile-jvm-lshl Opcodes/LSHL "longValue" "()J" "java.lang.Long" "intValue" "()I" "java.lang.Integer" "java.lang.Long" "(J)V"
- ^:private compile-jvm-lshr Opcodes/LSHR "longValue" "()J" "java.lang.Long" "intValue" "()I" "java.lang.Integer" "java.lang.Long" "(J)V"
- ^:private compile-jvm-lushr Opcodes/LUSHR "longValue" "()J" "java.lang.Long" "intValue" "()I" "java.lang.Integer" "java.lang.Long" "(J)V"
- )
-
-(do-template [<name> <opcode> <wrapper-class> <value-method> <value-method-sig> <wrap>]
- (defn <name> [compile ?values special-args]
- (|do [:let [(&/$Cons ?x (&/$Cons ?y (&/$Nil))) ?values]
- :let [+wrapper-class+ (&host-generics/->bytecode-class-name <wrapper-class>)]
- ^MethodVisitor *writer* &/get-writer
- _ (compile ?x)
- :let [_ (doto *writer*
- (.visitTypeInsn Opcodes/CHECKCAST +wrapper-class+)
- (.visitMethodInsn Opcodes/INVOKEVIRTUAL +wrapper-class+ <value-method> <value-method-sig>))]
- _ (compile ?y)
- :let [_ (doto *writer*
- (.visitTypeInsn Opcodes/CHECKCAST +wrapper-class+)
- (.visitMethodInsn Opcodes/INVOKEVIRTUAL +wrapper-class+ <value-method> <value-method-sig>))
- _ (doto *writer*
- (.visitInsn <opcode>)
- (<wrap>))]]
- (return nil)))
-
- ^:private compile-jvm-iadd Opcodes/IADD "java.lang.Integer" "intValue" "()I" &&/wrap-int
- ^:private compile-jvm-isub Opcodes/ISUB "java.lang.Integer" "intValue" "()I" &&/wrap-int
- ^:private compile-jvm-imul Opcodes/IMUL "java.lang.Integer" "intValue" "()I" &&/wrap-int
- ^:private compile-jvm-idiv Opcodes/IDIV "java.lang.Integer" "intValue" "()I" &&/wrap-int
- ^:private compile-jvm-irem Opcodes/IREM "java.lang.Integer" "intValue" "()I" &&/wrap-int
-
- ^:private compile-jvm-ladd Opcodes/LADD "java.lang.Long" "longValue" "()J" &&/wrap-long
- ^:private compile-jvm-lsub Opcodes/LSUB "java.lang.Long" "longValue" "()J" &&/wrap-long
- ^:private compile-jvm-lmul Opcodes/LMUL "java.lang.Long" "longValue" "()J" &&/wrap-long
- ^:private compile-jvm-ldiv Opcodes/LDIV "java.lang.Long" "longValue" "()J" &&/wrap-long
- ^:private compile-jvm-lrem Opcodes/LREM "java.lang.Long" "longValue" "()J" &&/wrap-long
-
- ^:private compile-jvm-fadd Opcodes/FADD "java.lang.Float" "floatValue" "()F" &&/wrap-float
- ^:private compile-jvm-fsub Opcodes/FSUB "java.lang.Float" "floatValue" "()F" &&/wrap-float
- ^:private compile-jvm-fmul Opcodes/FMUL "java.lang.Float" "floatValue" "()F" &&/wrap-float
- ^:private compile-jvm-fdiv Opcodes/FDIV "java.lang.Float" "floatValue" "()F" &&/wrap-float
- ^:private compile-jvm-frem Opcodes/FREM "java.lang.Float" "floatValue" "()F" &&/wrap-float
-
- ^:private compile-jvm-dadd Opcodes/DADD "java.lang.Double" "doubleValue" "()D" &&/wrap-double
- ^:private compile-jvm-dsub Opcodes/DSUB "java.lang.Double" "doubleValue" "()D" &&/wrap-double
- ^:private compile-jvm-dmul Opcodes/DMUL "java.lang.Double" "doubleValue" "()D" &&/wrap-double
- ^:private compile-jvm-ddiv Opcodes/DDIV "java.lang.Double" "doubleValue" "()D" &&/wrap-double
- ^:private compile-jvm-drem Opcodes/DREM "java.lang.Double" "doubleValue" "()D" &&/wrap-double
- )
-
-(do-template [<name> <opcode> <wrapper-class> <value-method> <value-method-sig>]
- (defn <name> [compile ?values special-args]
- (|do [:let [(&/$Cons ?x (&/$Cons ?y (&/$Nil))) ?values]
- :let [+wrapper-class+ (&host-generics/->bytecode-class-name <wrapper-class>)]
- ^MethodVisitor *writer* &/get-writer
- _ (compile ?x)
- :let [_ (doto *writer*
- (.visitTypeInsn Opcodes/CHECKCAST +wrapper-class+)
- (.visitMethodInsn Opcodes/INVOKEVIRTUAL +wrapper-class+ <value-method> <value-method-sig>))]
- _ (compile ?y)
- :let [_ (doto *writer*
- (.visitTypeInsn Opcodes/CHECKCAST +wrapper-class+)
- (.visitMethodInsn Opcodes/INVOKEVIRTUAL +wrapper-class+ <value-method> <value-method-sig>))
- $then (new Label)
- $end (new Label)
- _ (doto *writer*
- (.visitJumpInsn <opcode> $then)
- (.visitFieldInsn Opcodes/GETSTATIC (&host-generics/->bytecode-class-name "java.lang.Boolean") "FALSE" (&host-generics/->type-signature "java.lang.Boolean"))
- (.visitJumpInsn Opcodes/GOTO $end)
- (.visitLabel $then)
- (.visitFieldInsn Opcodes/GETSTATIC (&host-generics/->bytecode-class-name "java.lang.Boolean") "TRUE" (&host-generics/->type-signature "java.lang.Boolean"))
- (.visitLabel $end))]]
- (return nil)))
-
- ^:private compile-jvm-ieq Opcodes/IF_ICMPEQ "java.lang.Integer" "intValue" "()I"
- ^:private compile-jvm-ilt Opcodes/IF_ICMPLT "java.lang.Integer" "intValue" "()I"
- ^:private compile-jvm-igt Opcodes/IF_ICMPGT "java.lang.Integer" "intValue" "()I"
-
- ^:private compile-jvm-ceq Opcodes/IF_ICMPEQ "java.lang.Character" "charValue" "()C"
- ^:private compile-jvm-clt Opcodes/IF_ICMPLT "java.lang.Character" "charValue" "()C"
- ^:private compile-jvm-cgt Opcodes/IF_ICMPGT "java.lang.Character" "charValue" "()C"
- )
-
-(do-template [<name> <cmpcode> <cmp-output> <wrapper-class> <value-method> <value-method-sig>]
- (defn <name> [compile ?values special-args]
- (|do [:let [(&/$Cons ?x (&/$Cons ?y (&/$Nil))) ?values]
- :let [+wrapper-class+ (&host-generics/->bytecode-class-name <wrapper-class>)]
- ^MethodVisitor *writer* &/get-writer
- _ (compile ?x)
- :let [_ (doto *writer*
- (.visitTypeInsn Opcodes/CHECKCAST +wrapper-class+)
- (.visitMethodInsn Opcodes/INVOKEVIRTUAL +wrapper-class+ <value-method> <value-method-sig>))]
- _ (compile ?y)
- :let [_ (doto *writer*
- (.visitTypeInsn Opcodes/CHECKCAST +wrapper-class+)
- (.visitMethodInsn Opcodes/INVOKEVIRTUAL +wrapper-class+ <value-method> <value-method-sig>))
- $then (new Label)
- $end (new Label)
- _ (doto *writer*
- (.visitInsn <cmpcode>)
- (.visitLdcInsn (int <cmp-output>))
- (.visitJumpInsn Opcodes/IF_ICMPEQ $then)
- (.visitFieldInsn Opcodes/GETSTATIC (&host-generics/->bytecode-class-name "java.lang.Boolean") "FALSE" (&host-generics/->type-signature "java.lang.Boolean"))
- (.visitJumpInsn Opcodes/GOTO $end)
- (.visitLabel $then)
- (.visitFieldInsn Opcodes/GETSTATIC (&host-generics/->bytecode-class-name "java.lang.Boolean") "TRUE" (&host-generics/->type-signature "java.lang.Boolean"))
- (.visitLabel $end))]]
- (return nil)))
-
- ^:private compile-jvm-leq Opcodes/LCMP 0 "java.lang.Long" "longValue" "()J"
- ^:private compile-jvm-llt Opcodes/LCMP -1 "java.lang.Long" "longValue" "()J"
- ^:private compile-jvm-lgt Opcodes/LCMP 1 "java.lang.Long" "longValue" "()J"
-
- ^:private compile-jvm-feq Opcodes/FCMPG 0 "java.lang.Float" "floatValue" "()F"
- ^:private compile-jvm-flt Opcodes/FCMPG -1 "java.lang.Float" "floatValue" "()F"
- ^:private compile-jvm-fgt Opcodes/FCMPG 1 "java.lang.Float" "floatValue" "()F"
-
- ^:private compile-jvm-deq Opcodes/DCMPG 0 "java.lang.Double" "doubleValue" "()D"
- ^:private compile-jvm-dlt Opcodes/DCMPG -1 "java.lang.Double" "doubleValue" "()D"
- ^:private compile-jvm-dgt Opcodes/DCMPG 1 "java.lang.Double" "doubleValue" "()D"
- )
-
-(do-template [<prim-type> <array-type> <new-name> <load-name> <load-op> <store-name> <store-op> <wrapper> <unwrapper>]
- (do (defn <new-name> [compile ?values special-args]
- (|do [:let [(&/$Cons ?length (&/$Nil)) ?values
- ;; (&/$Nil) special-args
- ]
- ^MethodVisitor *writer* &/get-writer
- _ (compile ?length)
- :let [_ (doto *writer*
- &&/unwrap-long
- (.visitInsn Opcodes/L2I))]
- :let [_ (.visitIntInsn *writer* Opcodes/NEWARRAY <prim-type>)]]
- (return nil)))
-
- (defn <load-name> [compile ?values special-args]
- (|do [:let [(&/$Cons ?array (&/$Cons ?idx (&/$Nil))) ?values
- ;; (&/$Nil) special-args
- ]
- ^MethodVisitor *writer* &/get-writer
- _ (compile ?array)
- :let [_ (.visitTypeInsn *writer* Opcodes/CHECKCAST <array-type>)]
- _ (compile ?idx)
- :let [_ (doto *writer*
- &&/unwrap-long
- (.visitInsn Opcodes/L2I))]
- :let [_ (doto *writer*
- (.visitInsn <load-op>)
- <wrapper>)]]
- (return nil)))
-
- (defn <store-name> [compile ?values special-args]
- (|do [:let [(&/$Cons ?array (&/$Cons ?idx (&/$Cons ?elem (&/$Nil)))) ?values
- ;; (&/$Nil) special-args
- ]
- ^MethodVisitor *writer* &/get-writer
- _ (compile ?array)
- :let [_ (.visitTypeInsn *writer* Opcodes/CHECKCAST <array-type>)]
- :let [_ (.visitInsn *writer* Opcodes/DUP)]
- _ (compile ?idx)
- :let [_ (doto *writer*
- &&/unwrap-long
- (.visitInsn Opcodes/L2I))]
- _ (compile ?elem)
- :let [_ (doto *writer*
- <unwrapper>
- (.visitInsn <store-op>))]]
- (return nil)))
- )
-
- Opcodes/T_BOOLEAN "[Z" ^:private compile-jvm-znewarray compile-jvm-zaload Opcodes/BALOAD compile-jvm-zastore Opcodes/BASTORE &&/wrap-boolean &&/unwrap-boolean
- Opcodes/T_BYTE "[B" ^:private compile-jvm-bnewarray compile-jvm-baload Opcodes/BALOAD compile-jvm-bastore Opcodes/BASTORE &&/wrap-byte &&/unwrap-byte
- Opcodes/T_SHORT "[S" ^:private compile-jvm-snewarray compile-jvm-saload Opcodes/SALOAD compile-jvm-sastore Opcodes/SASTORE &&/wrap-short &&/unwrap-short
- Opcodes/T_INT "[I" ^:private compile-jvm-inewarray compile-jvm-iaload Opcodes/IALOAD compile-jvm-iastore Opcodes/IASTORE &&/wrap-int &&/unwrap-int
- Opcodes/T_LONG "[J" ^:private compile-jvm-lnewarray compile-jvm-laload Opcodes/LALOAD compile-jvm-lastore Opcodes/LASTORE &&/wrap-long &&/unwrap-long
- Opcodes/T_FLOAT "[F" ^:private compile-jvm-fnewarray compile-jvm-faload Opcodes/FALOAD compile-jvm-fastore Opcodes/FASTORE &&/wrap-float &&/unwrap-float
- Opcodes/T_DOUBLE "[D" ^:private compile-jvm-dnewarray compile-jvm-daload Opcodes/DALOAD compile-jvm-dastore Opcodes/DASTORE &&/wrap-double &&/unwrap-double
- Opcodes/T_CHAR "[C" ^:private compile-jvm-cnewarray compile-jvm-caload Opcodes/CALOAD compile-jvm-castore Opcodes/CASTORE &&/wrap-char &&/unwrap-char
- )
-
-(defn ^:private compile-jvm-anewarray [compile ?values special-args]
- (|do [:let [(&/$Cons ?length (&/$Nil)) ?values
- (&/$Cons ?gclass (&/$Cons type-env (&/$Nil))) special-args]
- ^MethodVisitor *writer* &/get-writer
- _ (compile ?length)
- :let [_ (doto *writer*
- &&/unwrap-long
- (.visitInsn Opcodes/L2I))]
- :let [_ (.visitTypeInsn *writer* Opcodes/ANEWARRAY (&host-generics/gclass->bytecode-class-name* ?gclass type-env))]]
- (return nil)))
-
-(defn ^:private compile-jvm-aaload [compile ?values special-args]
- (|do [:let [(&/$Cons ?array (&/$Cons ?idx (&/$Nil))) ?values
- ;; (&/$Nil) special-args
- ]
- ^MethodVisitor *writer* &/get-writer
- array-type (&host/->java-sig (&a/expr-type* ?array))
- _ (compile ?array)
- :let [_ (.visitTypeInsn *writer* Opcodes/CHECKCAST array-type)]
- _ (compile ?idx)
- :let [_ (doto *writer*
- &&/unwrap-long
- (.visitInsn Opcodes/L2I))]
- :let [_ (.visitInsn *writer* Opcodes/AALOAD)]]
- (return nil)))
-
-(defn ^:private compile-jvm-aastore [compile ?values special-args]
- (|do [:let [(&/$Cons ?array (&/$Cons ?idx (&/$Cons ?elem (&/$Nil)))) ?values
- ;; (&/$Nil) special-args
- ]
- ^MethodVisitor *writer* &/get-writer
- array-type (&host/->java-sig (&a/expr-type* ?array))
- _ (compile ?array)
- :let [_ (.visitTypeInsn *writer* Opcodes/CHECKCAST array-type)]
- :let [_ (.visitInsn *writer* Opcodes/DUP)]
- _ (compile ?idx)
- :let [_ (doto *writer*
- &&/unwrap-long
- (.visitInsn Opcodes/L2I))]
- _ (compile ?elem)
- :let [_ (.visitInsn *writer* Opcodes/AASTORE)]]
- (return nil)))
-
-(defn ^:private compile-jvm-arraylength [compile ?values special-args]
- (|do [:let [(&/$Cons ?array (&/$Nil)) ?values
- ;; (&/$Nil) special-args
- ]
- ^MethodVisitor *writer* &/get-writer
- array-type (&host/->java-sig (&a/expr-type* ?array))
- _ (compile ?array)
- :let [_ (.visitTypeInsn *writer* Opcodes/CHECKCAST array-type)]
- :let [_ (doto *writer*
- (.visitInsn Opcodes/ARRAYLENGTH)
- (.visitInsn Opcodes/I2L)
- &&/wrap-long)]]
- (return nil)))
-
-(defn ^:private compile-jvm-null [compile ?values special-args]
- (|do [:let [;; (&/$Nil) ?values
- (&/$Nil) special-args]
- ^MethodVisitor *writer* &/get-writer
- :let [_ (.visitInsn *writer* Opcodes/ACONST_NULL)]]
- (return nil)))
-
-(defn ^:private compile-jvm-null? [compile ?values special-args]
- (|do [:let [(&/$Cons ?object (&/$Nil)) ?values
- ;; (&/$Nil) special-args
- ]
- ^MethodVisitor *writer* &/get-writer
- _ (compile ?object)
- :let [$then (new Label)
- $end (new Label)
- _ (doto *writer*
- (.visitJumpInsn Opcodes/IFNULL $then)
- (.visitFieldInsn Opcodes/GETSTATIC (&host-generics/->bytecode-class-name "java.lang.Boolean") "FALSE" (&host-generics/->type-signature "java.lang.Boolean"))
- (.visitJumpInsn Opcodes/GOTO $end)
- (.visitLabel $then)
- (.visitFieldInsn Opcodes/GETSTATIC (&host-generics/->bytecode-class-name "java.lang.Boolean") "TRUE" (&host-generics/->type-signature "java.lang.Boolean"))
- (.visitLabel $end))]]
- (return nil)))
-
-(defn compile-jvm-synchronized [compile ?values special-args]
- (|do [:let [(&/$Cons ?monitor (&/$Cons ?expr (&/$Nil))) ?values
- ;; (&/$Nil) special-args
- ]
- ^MethodVisitor *writer* &/get-writer
- _ (compile ?monitor)
- :let [_ (doto *writer*
- (.visitInsn Opcodes/DUP)
- (.visitInsn Opcodes/MONITORENTER))]
- _ (compile ?expr)
- :let [_ (doto *writer*
- (.visitInsn Opcodes/SWAP)
- (.visitInsn Opcodes/MONITOREXIT))]]
- (return nil)))
-
-(do-template [<name> <op>]
- (defn <name> [compile ?values special-args]
- (|do [:let [(&/$Cons ?monitor (&/$Nil)) ?values
- ;; (&/$Nil) special-args
- ]
- ^MethodVisitor *writer* &/get-writer
- _ (compile ?monitor)
- :let [_ (doto *writer*
- (.visitInsn <op>)
- (.visitInsn Opcodes/ACONST_NULL))]]
- (return nil)))
-
- ^:private compile-jvm-monitorenter Opcodes/MONITORENTER
- ^:private compile-jvm-monitorexit Opcodes/MONITOREXIT
- )
-
-(defn ^:private compile-jvm-throw [compile ?values special-args]
- (|do [:let [(&/$Cons ?ex (&/$Nil)) ?values
- ;; (&/$Nil) special-args
- ]
- ^MethodVisitor *writer* &/get-writer
- _ (compile ?ex)
- :let [_ (.visitInsn *writer* Opcodes/ATHROW)]]
- (return nil)))
-
-(defn ^:private compile-jvm-getstatic [compile ?values special-args]
- (|do [:let [;; (&/$Nil) ?values
- (&/$Cons ?class (&/$Cons ?field (&/$Cons ?output-type (&/$Nil)))) special-args]
- ^MethodVisitor *writer* &/get-writer
- =output-type (&host/->java-sig ?output-type)
- :let [_ (doto *writer*
- (.visitFieldInsn Opcodes/GETSTATIC (&host-generics/->bytecode-class-name (&host-type/as-obj ?class)) ?field =output-type)
- (prepare-return! ?output-type))]]
- (return nil)))
-
-(defn ^:private compile-jvm-getfield [compile ?values special-args]
- (|do [:let [(&/$Cons ?object (&/$Nil)) ?values
- (&/$Cons ?class (&/$Cons ?field (&/$Cons ?output-type (&/$Nil)))) special-args]
- :let [class* (&host-generics/->bytecode-class-name (&host-type/as-obj ?class))]
- ^MethodVisitor *writer* &/get-writer
- _ (compile ?object)
- =output-type (&host/->java-sig ?output-type)
- :let [_ (doto *writer*
- (.visitTypeInsn Opcodes/CHECKCAST class*)
- (.visitFieldInsn Opcodes/GETFIELD class* ?field =output-type)
- (prepare-return! ?output-type))]]
- (return nil)))
-
-(defn ^:private compile-jvm-putstatic [compile ?values special-args]
- (|do [:let [(&/$Cons ?value (&/$Nil)) ?values
- (&/$Cons ?class (&/$Cons ?field (&/$Cons input-gclass (&/$Nil)))) special-args]
- ^MethodVisitor *writer* &/get-writer
- _ (compile ?value)
- :let [=input-sig (&host-type/gclass->sig input-gclass)
- _ (doto *writer*
- (prepare-arg! (&host-generics/gclass->class-name input-gclass))
- (.visitFieldInsn Opcodes/PUTSTATIC (&host-generics/->bytecode-class-name (&host-type/as-obj ?class)) ?field =input-sig)
- (.visitInsn Opcodes/ACONST_NULL))]]
- (return nil)))
-
-(defn ^:private compile-jvm-putfield [compile ?values special-args]
- (|do [:let [(&/$Cons ?object (&/$Cons ?value (&/$Nil))) ?values
- (&/$Cons ?class (&/$Cons ?field (&/$Cons input-gclass (&/$Cons ?input-type (&/$Nil))))) special-args]
- :let [class* (&host-generics/->bytecode-class-name (&host-type/as-obj ?class))]
- ^MethodVisitor *writer* &/get-writer
- _ (compile ?object)
- :let [_ (.visitTypeInsn *writer* Opcodes/CHECKCAST class*)]
- _ (compile ?value)
- =input-sig (&host/->java-sig ?input-type)
- :let [_ (doto *writer*
- (prepare-arg! (&host-generics/gclass->class-name input-gclass))
- (.visitFieldInsn Opcodes/PUTFIELD class* ?field =input-sig)
- (.visitInsn Opcodes/ACONST_NULL))]]
- (return nil)))
-
-(defn ^:private compile-jvm-invokestatic [compile ?values special-args]
- (|do [:let [?args ?values
- (&/$Cons ?class (&/$Cons ?method (&/$Cons ?classes (&/$Cons ?output-type (&/$Cons ?gret (&/$Nil)))))) special-args]
- ^MethodVisitor *writer* &/get-writer
- :let [method-sig (str "(" (&/fold str "" (&/|map &host-generics/->type-signature ?classes)) ")" (&host-type/principal-class ?gret))]
- _ (&/map2% (fn [class-name arg]
- (|do [ret (compile arg)
- :let [_ (prepare-arg! *writer* class-name)]]
- (return ret)))
- ?classes ?args)
- :let [_ (doto *writer*
- (.visitMethodInsn Opcodes/INVOKESTATIC (&host-generics/->bytecode-class-name (&host-type/as-obj ?class)) ?method method-sig)
- (prepare-return! ?output-type))]]
- (return nil)))
-
-(do-template [<name> <op>]
- (defn <name> [compile ?values special-args]
- (|do [:let [(&/$Cons ?object ?args) ?values
- (&/$Cons ?class (&/$Cons ?method (&/$Cons ?classes (&/$Cons ?output-type (&/$Cons ?gret (&/$Nil)))))) special-args]
- :let [?class* (&host-generics/->bytecode-class-name (&host-type/as-obj ?class))]
- ^MethodVisitor *writer* &/get-writer
- :let [method-sig (str "(" (&/fold str "" (&/|map &host-generics/->type-signature ?classes)) ")" (&host-type/principal-class ?gret))]
- _ (compile ?object)
- :let [_ (when (not= "<init>" ?method)
- (.visitTypeInsn *writer* Opcodes/CHECKCAST ?class*))]
- _ (&/map2% (fn [class-name arg]
- (|do [ret (compile arg)
- :let [_ (prepare-arg! *writer* class-name)]]
- (return ret)))
- ?classes ?args)
- :let [_ (doto *writer*
- (.visitMethodInsn <op> ?class* ?method method-sig)
- (prepare-return! ?output-type))]]
- (return nil)))
-
- ^:private compile-jvm-invokevirtual Opcodes/INVOKEVIRTUAL
- ^:private compile-jvm-invokeinterface Opcodes/INVOKEINTERFACE
- ^:private compile-jvm-invokespecial Opcodes/INVOKESPECIAL
- )
-
-(defn ^:private compile-jvm-new [compile ?values special-args]
- (|do [:let [?args ?values
- (&/$Cons ?class (&/$Cons ?classes (&/$Nil))) special-args]
- ^MethodVisitor *writer* &/get-writer
- :let [init-sig (str "(" (&/fold str "" (&/|map &host-generics/->type-signature ?classes)) ")V")
- class* (&host-generics/->bytecode-class-name ?class)
- _ (doto *writer*
- (.visitTypeInsn Opcodes/NEW class*)
- (.visitInsn Opcodes/DUP))]
- _ (&/map% (fn [class-name+arg]
- (|do [:let [[class-name arg] class-name+arg]
- ret (compile arg)
- :let [_ (prepare-arg! *writer* class-name)]]
- (return ret)))
- (&/zip2 ?classes ?args))
- :let [_ (doto *writer*
- (.visitMethodInsn Opcodes/INVOKESPECIAL class* "<init>" init-sig))]]
- (return nil)))
-
-(defn ^:private compile-jvm-try [compile ?values special-args]
- (|do [:let [(&/$Cons ?body (&/$Cons ?catch (&/$Nil))) ?values
- ;; (&/$Nil) special-args
- ]
- ^MethodVisitor *writer* &/get-writer
- :let [$from (new Label)
- $to (new Label)
- $handler (new Label)
- $end (new Label)]
- :let [_ (doto *writer*
- (.visitTryCatchBlock $from $to $handler "java/lang/Exception")
- (.visitLabel $from))]
- _ (compile ?body)
- :let [_ (doto *writer*
- (.visitJumpInsn Opcodes/GOTO $end)
- (.visitLabel $to)
- (.visitLabel $handler))]
- _ (compile ?catch)
- :let [_ (doto *writer*
- (.visitTypeInsn Opcodes/CHECKCAST &&/function-class)
- (.visitInsn Opcodes/SWAP)
- (.visitMethodInsn Opcodes/INVOKEVIRTUAL &&/function-class &&/apply-method (&&/apply-signature 1)))]
- :let [_ (.visitLabel *writer* $end)]]
- (return nil)))
-
-(defn ^:private compile-jvm-load-class [compile ?values special-args]
- (|do [:let [(&/$Cons _class-name (&/$Cons ?output-type (&/$Nil))) special-args]
- ^MethodVisitor *writer* &/get-writer
- :let [_ (doto *writer*
- (.visitLdcInsn _class-name)
- (.visitMethodInsn Opcodes/INVOKESTATIC "java/lang/Class" "forName" "(Ljava/lang/String;)Ljava/lang/Class;")
- (prepare-return! ?output-type))]]
- (return nil)))
-
-(defn ^:private compile-jvm-instanceof [compile ?values special-args]
- (|do [:let [(&/$Cons object (&/$Nil)) ?values
- (&/$Cons class (&/$Nil)) special-args]
- :let [class* (&host-generics/->bytecode-class-name class)]
- ^MethodVisitor *writer* &/get-writer
- _ (compile object)
- :let [_ (doto *writer*
- (.visitTypeInsn Opcodes/INSTANCEOF class*)
- (&&/wrap-boolean))]]
- (return nil)))
-
-(defn ^:private compile-array-get [compile ?values special-args]
- (|do [:let [(&/$Cons ?array (&/$Cons ?idx (&/$Nil))) ?values
- ;; (&/$Nil) special-args
- ]
- ^MethodVisitor *writer* &/get-writer
- array-type (&host/->java-sig (&a/expr-type* ?array))
- _ (compile ?array)
- :let [_ (.visitTypeInsn *writer* Opcodes/CHECKCAST array-type)]
- _ (compile ?idx)
- :let [_ (doto *writer*
- &&/unwrap-long
- (.visitInsn Opcodes/L2I))]
- :let [_ (.visitInsn *writer* Opcodes/AALOAD)]
- :let [$is-null (new Label)
- $end (new Label)
- _ (doto *writer*
- (.visitInsn Opcodes/DUP)
- (.visitJumpInsn Opcodes/IFNULL $is-null)
- (.visitLdcInsn (int 1))
- (.visitLdcInsn "")
- (.visitInsn Opcodes/DUP2_X1) ;; I?2I?
- (.visitInsn Opcodes/POP2) ;; I?2
- (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "sum_make" "(ILjava/lang/Object;Ljava/lang/Object;)[Ljava/lang/Object;")
- (.visitJumpInsn Opcodes/GOTO $end)
- (.visitLabel $is-null)
- (.visitInsn Opcodes/POP)
- (.visitLdcInsn (int 0))
- (.visitInsn Opcodes/ACONST_NULL)
- (.visitLdcInsn &/unit-tag)
- (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "sum_make" "(ILjava/lang/Object;Ljava/lang/Object;)[Ljava/lang/Object;")
- (.visitLabel $end))]]
- (return nil)))
-
-(do-template [<name> <op>]
- (defn <name> [compile ?values special-args]
- (|do [:let [(&/$Cons ?input (&/$Cons ?mask (&/$Nil))) ?values]
- ^MethodVisitor *writer* &/get-writer
- _ (compile ?input)
- :let [_ (&&/unwrap-long *writer*)]
- _ (compile ?mask)
- :let [_ (&&/unwrap-long *writer*)]
- :let [_ (doto *writer*
- (.visitInsn <op>)
- &&/wrap-long)]]
- (return nil)))
-
- ^:private compile-bit-and Opcodes/LAND
- ^:private compile-bit-or Opcodes/LOR
- ^:private compile-bit-xor Opcodes/LXOR
- )
-
-(defn ^:private compile-bit-count [compile ?values special-args]
- (|do [:let [(&/$Cons ?input (&/$Nil)) ?values]
- ^MethodVisitor *writer* &/get-writer
- _ (compile ?input)
- :let [_ (&&/unwrap-long *writer*)]
- :let [_ (doto *writer*
- (.visitMethodInsn Opcodes/INVOKESTATIC "java/lang/Long" "bitCount" "(J)I")
- (.visitInsn Opcodes/I2L)
- &&/wrap-long)]]
- (return nil)))
-
-(do-template [<name> <op>]
- (defn <name> [compile ?values special-args]
- (|do [:let [(&/$Cons ?input (&/$Cons ?shift (&/$Nil))) ?values]
- ^MethodVisitor *writer* &/get-writer
- _ (compile ?input)
- :let [_ (&&/unwrap-long *writer*)]
- _ (compile ?shift)
- :let [_ (doto *writer*
- &&/unwrap-long
- (.visitInsn Opcodes/L2I))]
- :let [_ (doto *writer*
- (.visitInsn <op>)
- &&/wrap-long)]]
- (return nil)))
-
- ^:private compile-bit-shift-left Opcodes/LSHL
- ^:private compile-bit-shift-right Opcodes/LSHR
- ^:private compile-bit-unsigned-shift-right Opcodes/LUSHR
- )
-
-(defn ^:private compile-lux-== [compile ?values special-args]
- (|do [:let [(&/$Cons ?left (&/$Cons ?right (&/$Nil))) ?values]
- ^MethodVisitor *writer* &/get-writer
- _ (compile ?left)
- _ (compile ?right)
- :let [$then (new Label)
- $end (new Label)
- _ (doto *writer*
- (.visitJumpInsn Opcodes/IF_ACMPEQ $then)
- ;; else
- (.visitFieldInsn Opcodes/GETSTATIC "java/lang/Boolean" "FALSE" "Ljava/lang/Boolean;")
- (.visitJumpInsn Opcodes/GOTO $end)
- (.visitLabel $then)
- (.visitFieldInsn Opcodes/GETSTATIC "java/lang/Boolean" "TRUE" "Ljava/lang/Boolean;")
- (.visitLabel $end))]]
- (return nil)))
-
-(do-template [<name> <opcode> <wrapper-class> <value-method> <value-method-sig> <wrap>]
- (defn <name> [compile ?values special-args]
- (|do [:let [(&/$Cons ?x (&/$Cons ?y (&/$Nil))) ?values]
- :let [+wrapper-class+ (&host-generics/->bytecode-class-name <wrapper-class>)]
- ^MethodVisitor *writer* &/get-writer
- _ (compile ?x)
- :let [_ (doto *writer*
- (.visitTypeInsn Opcodes/CHECKCAST +wrapper-class+)
- (.visitMethodInsn Opcodes/INVOKEVIRTUAL +wrapper-class+ <value-method> <value-method-sig>))]
- _ (compile ?y)
- :let [_ (doto *writer*
- (.visitTypeInsn Opcodes/CHECKCAST +wrapper-class+)
- (.visitMethodInsn Opcodes/INVOKEVIRTUAL +wrapper-class+ <value-method> <value-method-sig>))
- _ (doto *writer*
- (.visitInsn <opcode>)
- (<wrap>))]]
- (return nil)))
-
- ^:private compile-nat-add Opcodes/LADD "java.lang.Long" "longValue" "()J" &&/wrap-long
- ^:private compile-nat-sub Opcodes/LSUB "java.lang.Long" "longValue" "()J" &&/wrap-long
- ^:private compile-nat-mul Opcodes/LMUL "java.lang.Long" "longValue" "()J" &&/wrap-long
-
- ^:private compile-frac-add Opcodes/LADD "java.lang.Long" "longValue" "()J" &&/wrap-long
- ^:private compile-frac-sub Opcodes/LSUB "java.lang.Long" "longValue" "()J" &&/wrap-long
- ^:private compile-frac-rem Opcodes/LSUB "java.lang.Long" "longValue" "()J" &&/wrap-long
- ^:private compile-frac-scale Opcodes/LMUL "java.lang.Long" "longValue" "()J" &&/wrap-long
- )
-
-(do-template [<name> <comp-method>]
- (defn <name> [compile ?values special-args]
- (|do [:let [(&/$Cons ?x (&/$Cons ?y (&/$Nil))) ?values]
- :let [+wrapper-class+ (&host-generics/->bytecode-class-name "java.lang.Long")]
- ^MethodVisitor *writer* &/get-writer
- _ (compile ?x)
- :let [_ (doto *writer*
- (.visitTypeInsn Opcodes/CHECKCAST +wrapper-class+)
- (.visitMethodInsn Opcodes/INVOKEVIRTUAL +wrapper-class+ "longValue" "()J"))]
- _ (compile ?y)
- :let [_ (doto *writer*
- (.visitTypeInsn Opcodes/CHECKCAST +wrapper-class+)
- (.visitMethodInsn Opcodes/INVOKEVIRTUAL +wrapper-class+ "longValue" "()J"))
- _ (doto *writer*
- (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" <comp-method> "(JJ)J")
- (&&/wrap-long))]]
- (return nil)))
-
- ^:private compile-nat-div "div_nat"
- ^:private compile-nat-rem "rem_nat"
- )
-
-(do-template [<name> <cmp-output>]
- (defn <name> [compile ?values special-args]
- (|do [:let [(&/$Cons ?x (&/$Cons ?y (&/$Nil))) ?values]
- :let [+wrapper-class+ (&host-generics/->bytecode-class-name "java.lang.Long")]
- ^MethodVisitor *writer* &/get-writer
- _ (compile ?x)
- :let [_ (doto *writer*
- (.visitTypeInsn Opcodes/CHECKCAST +wrapper-class+)
- (.visitMethodInsn Opcodes/INVOKEVIRTUAL +wrapper-class+ "longValue" "()J"))]
- _ (compile ?y)
- :let [_ (doto *writer*
- (.visitTypeInsn Opcodes/CHECKCAST +wrapper-class+)
- (.visitMethodInsn Opcodes/INVOKEVIRTUAL +wrapper-class+ "longValue" "()J"))
- $then (new Label)
- $end (new Label)
- _ (doto *writer*
- (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "_compareUnsigned" "(JJ)I")
- (.visitLdcInsn (int <cmp-output>))
- (.visitJumpInsn Opcodes/IF_ICMPEQ $then)
- (.visitFieldInsn Opcodes/GETSTATIC (&host-generics/->bytecode-class-name "java.lang.Boolean") "FALSE" (&host-generics/->type-signature "java.lang.Boolean"))
- (.visitJumpInsn Opcodes/GOTO $end)
- (.visitLabel $then)
- (.visitFieldInsn Opcodes/GETSTATIC (&host-generics/->bytecode-class-name "java.lang.Boolean") "TRUE" (&host-generics/->type-signature "java.lang.Boolean"))
- (.visitLabel $end))]]
- (return nil)))
-
- ^:private compile-nat-eq 0
-
- ^:private compile-frac-eq 0
- ^:private compile-frac-lt -1
- )
-
-(let [+wrapper-class+ (&host-generics/->bytecode-class-name "java.lang.Long")]
- (defn ^:private compile-nat-lt [compile ?values special-args]
- (|do [:let [(&/$Cons ?x (&/$Cons ?y (&/$Nil))) ?values]
- ^MethodVisitor *writer* &/get-writer
- _ (compile ?x)
- :let [_ (doto *writer*
- (.visitTypeInsn Opcodes/CHECKCAST +wrapper-class+)
- (.visitMethodInsn Opcodes/INVOKEVIRTUAL +wrapper-class+ "longValue" "()J"))]
- _ (compile ?y)
- :let [_ (doto *writer*
- (.visitTypeInsn Opcodes/CHECKCAST +wrapper-class+)
- (.visitMethodInsn Opcodes/INVOKEVIRTUAL +wrapper-class+ "longValue" "()J"))
- $then (new Label)
- $end (new Label)
- _ (doto *writer*
- (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "_compareUnsigned" "(JJ)I")
- (.visitLdcInsn (int -1))
- (.visitJumpInsn Opcodes/IF_ICMPEQ $then)
- (.visitFieldInsn Opcodes/GETSTATIC (&host-generics/->bytecode-class-name "java.lang.Boolean") "FALSE" (&host-generics/->type-signature "java.lang.Boolean"))
- (.visitJumpInsn Opcodes/GOTO $end)
- (.visitLabel $then)
- (.visitFieldInsn Opcodes/GETSTATIC (&host-generics/->bytecode-class-name "java.lang.Boolean") "TRUE" (&host-generics/->type-signature "java.lang.Boolean"))
- (.visitLabel $end))]]
- (return nil))))
-
-(do-template [<name> <instr> <wrapper>]
- (defn <name> [compile ?values special-args]
- (|do [:let [(&/$Nil) ?values]
- ^MethodVisitor *writer* &/get-writer
- :let [_ (doto *writer*
- <instr>
- <wrapper>)]]
- (return nil)))
-
- ^:private compile-nat-min-value (.visitLdcInsn 0) &&/wrap-long
- ^:private compile-nat-max-value (.visitLdcInsn -1) &&/wrap-long
-
- ^:private compile-frac-min-value (.visitLdcInsn 0) &&/wrap-long
- ^:private compile-frac-max-value (.visitLdcInsn -1) &&/wrap-long
- )
-
-(do-template [<encode-name> <encode-method> <decode-name> <decode-method>]
- (do (defn <encode-name> [compile ?values special-args]
- (|do [:let [(&/$Cons ?x (&/$Nil)) ?values]
- ^MethodVisitor *writer* &/get-writer
- _ (compile ?x)
- :let [_ (doto *writer*
- &&/unwrap-long
- (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" <encode-method> "(J)Ljava/lang/String;"))]]
- (return nil)))
-
- (let [+wrapper-class+ (&host-generics/->bytecode-class-name "java.lang.String")]
- (defn <decode-name> [compile ?values special-args]
- (|do [:let [(&/$Cons ?x (&/$Nil)) ?values]
- ^MethodVisitor *writer* &/get-writer
- _ (compile ?x)
- :let [_ (doto *writer*
- (.visitTypeInsn Opcodes/CHECKCAST +wrapper-class+)
- (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" <decode-method> "(Ljava/lang/String;)Ljava/lang/Object;"))]]
- (return nil)))))
-
- ^:private compile-nat-encode "encode_nat" ^:private compile-nat-decode "decode_nat"
- ^:private compile-frac-encode "encode_frac" ^:private compile-frac-decode "decode_frac"
- )
-
-(do-template [<name> <method>]
- (defn <name> [compile ?values special-args]
- (|do [:let [(&/$Cons ?x (&/$Cons ?y (&/$Nil))) ?values]
- :let [+wrapper-class+ (&host-generics/->bytecode-class-name "java.lang.Long")]
- ^MethodVisitor *writer* &/get-writer
- _ (compile ?x)
- :let [_ (doto *writer*
- (.visitTypeInsn Opcodes/CHECKCAST +wrapper-class+)
- &&/unwrap-long)]
- _ (compile ?y)
- :let [_ (doto *writer*
- (.visitTypeInsn Opcodes/CHECKCAST +wrapper-class+)
- &&/unwrap-long)]
- :let [_ (doto *writer*
- (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" <method> "(JJ)J")
- &&/wrap-long)]]
- (return nil)))
-
- ^:private compile-frac-mul "mul_frac"
- ^:private compile-frac-div "div_frac"
- )
-
-(do-template [<name> <class> <method> <sig> <unwrap> <wrap>]
- (let [+wrapper-class+ (&host-generics/->bytecode-class-name <class>)]
- (defn <name> [compile ?values special-args]
- (|do [:let [(&/$Cons ?x (&/$Nil)) ?values]
- ^MethodVisitor *writer* &/get-writer
- _ (compile ?x)
- :let [_ (doto *writer*
- <unwrap>
- (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" <method> <sig>)
- <wrap>)]]
- (return nil))))
-
- ^:private compile-frac-to-real "java.lang.Long" "frac-to-real" "(J)D" &&/unwrap-long &&/wrap-double
- ^:private compile-real-to-frac "java.lang.Double" "real-to-frac" "(D)J" &&/unwrap-double &&/wrap-long
- )
-
-(let [widen (fn [^MethodVisitor *writer*]
- (doto *writer*
- (.visitInsn Opcodes/I2L)))
- shrink (fn [^MethodVisitor *writer*]
- (doto *writer*
- (.visitInsn Opcodes/L2I)
- (.visitInsn Opcodes/I2C)))]
- (do-template [<name> <unwrap> <wrap> <adjust>]
- (defn <name> [compile ?values special-args]
- (|do [:let [(&/$Cons ?x (&/$Nil)) ?values]
- ^MethodVisitor *writer* &/get-writer
- _ (compile ?x)
- :let [_ (doto *writer*
- <unwrap>
- <adjust>
- <wrap>)]]
- (return nil)))
-
- ^:private compile-nat-to-char &&/unwrap-long &&/wrap-char shrink
- ^:private compile-char-to-nat &&/unwrap-char &&/wrap-long widen
- ))
-
-(do-template [<name>]
- (defn <name> [compile ?values special-args]
- (|do [:let [(&/$Cons ?x (&/$Nil)) ?values]
- ^MethodVisitor *writer* &/get-writer
- _ (compile ?x)]
- (return nil)))
-
- ^:private compile-nat-to-int
- ^:private compile-int-to-nat
- )
-
-(defn compile-host [compile proc-category proc-name ?values special-args]
- (case proc-category
- "lux"
- (case proc-name
- "==" (compile-lux-== compile ?values special-args))
-
- "bit"
- (case proc-name
- "count" (compile-bit-count compile ?values special-args)
- "and" (compile-bit-and compile ?values special-args)
- "or" (compile-bit-or compile ?values special-args)
- "xor" (compile-bit-xor compile ?values special-args)
- "shift-left" (compile-bit-shift-left compile ?values special-args)
- "shift-right" (compile-bit-shift-right compile ?values special-args)
- "unsigned-shift-right" (compile-bit-unsigned-shift-right compile ?values special-args))
-
- "array"
- (case proc-name
- "get" (compile-array-get compile ?values special-args))
-
- "nat"
- (case proc-name
- "+" (compile-nat-add compile ?values special-args)
- "-" (compile-nat-sub compile ?values special-args)
- "*" (compile-nat-mul compile ?values special-args)
- "/" (compile-nat-div compile ?values special-args)
- "%" (compile-nat-rem compile ?values special-args)
- "=" (compile-nat-eq compile ?values special-args)
- "<" (compile-nat-lt compile ?values special-args)
- "encode" (compile-nat-encode compile ?values special-args)
- "decode" (compile-nat-decode compile ?values special-args)
- "max-value" (compile-nat-max-value compile ?values special-args)
- "min-value" (compile-nat-min-value compile ?values special-args)
- "to-int" (compile-nat-to-int compile ?values special-args)
- "to-char" (compile-nat-to-char compile ?values special-args)
- )
-
- "frac"
- (case proc-name
- "+" (compile-frac-add compile ?values special-args)
- "-" (compile-frac-sub compile ?values special-args)
- "*" (compile-frac-mul compile ?values special-args)
- "/" (compile-frac-div compile ?values special-args)
- "%" (compile-frac-rem compile ?values special-args)
- "=" (compile-frac-eq compile ?values special-args)
- "<" (compile-frac-lt compile ?values special-args)
- "encode" (compile-frac-encode compile ?values special-args)
- "decode" (compile-frac-decode compile ?values special-args)
- "max-value" (compile-frac-max-value compile ?values special-args)
- "min-value" (compile-frac-min-value compile ?values special-args)
- "to-real" (compile-frac-to-real compile ?values special-args)
- "scale" (compile-frac-scale compile ?values special-args)
- )
-
- "int"
- (case proc-name
- "to-nat" (compile-int-to-nat compile ?values special-args)
- )
-
- "real"
- (case proc-name
- "to-frac" (compile-real-to-frac compile ?values special-args)
- )
-
- "char"
- (case proc-name
- "to-nat" (compile-char-to-nat compile ?values special-args)
- )
-
- "jvm"
- (case proc-name
- "synchronized" (compile-jvm-synchronized compile ?values special-args)
- "load-class" (compile-jvm-load-class compile ?values special-args)
- "instanceof" (compile-jvm-instanceof compile ?values special-args)
- "try" (compile-jvm-try compile ?values special-args)
- "new" (compile-jvm-new compile ?values special-args)
- "invokestatic" (compile-jvm-invokestatic compile ?values special-args)
- "invokeinterface" (compile-jvm-invokeinterface compile ?values special-args)
- "invokevirtual" (compile-jvm-invokevirtual compile ?values special-args)
- "invokespecial" (compile-jvm-invokespecial compile ?values special-args)
- "getstatic" (compile-jvm-getstatic compile ?values special-args)
- "getfield" (compile-jvm-getfield compile ?values special-args)
- "putstatic" (compile-jvm-putstatic compile ?values special-args)
- "putfield" (compile-jvm-putfield compile ?values special-args)
- "throw" (compile-jvm-throw compile ?values special-args)
- "monitorenter" (compile-jvm-monitorenter compile ?values special-args)
- "monitorexit" (compile-jvm-monitorexit compile ?values special-args)
- "null?" (compile-jvm-null? compile ?values special-args)
- "null" (compile-jvm-null compile ?values special-args)
- "anewarray" (compile-jvm-anewarray compile ?values special-args)
- "aaload" (compile-jvm-aaload compile ?values special-args)
- "aastore" (compile-jvm-aastore compile ?values special-args)
- "arraylength" (compile-jvm-arraylength compile ?values special-args)
- "znewarray" (compile-jvm-znewarray compile ?values special-args)
- "bnewarray" (compile-jvm-bnewarray compile ?values special-args)
- "snewarray" (compile-jvm-snewarray compile ?values special-args)
- "inewarray" (compile-jvm-inewarray compile ?values special-args)
- "lnewarray" (compile-jvm-lnewarray compile ?values special-args)
- "fnewarray" (compile-jvm-fnewarray compile ?values special-args)
- "dnewarray" (compile-jvm-dnewarray compile ?values special-args)
- "cnewarray" (compile-jvm-cnewarray compile ?values special-args)
- "iadd" (compile-jvm-iadd compile ?values special-args)
- "isub" (compile-jvm-isub compile ?values special-args)
- "imul" (compile-jvm-imul compile ?values special-args)
- "idiv" (compile-jvm-idiv compile ?values special-args)
- "irem" (compile-jvm-irem compile ?values special-args)
- "ieq" (compile-jvm-ieq compile ?values special-args)
- "ilt" (compile-jvm-ilt compile ?values special-args)
- "igt" (compile-jvm-igt compile ?values special-args)
- "ceq" (compile-jvm-ceq compile ?values special-args)
- "clt" (compile-jvm-clt compile ?values special-args)
- "cgt" (compile-jvm-cgt compile ?values special-args)
- "ladd" (compile-jvm-ladd compile ?values special-args)
- "lsub" (compile-jvm-lsub compile ?values special-args)
- "lmul" (compile-jvm-lmul compile ?values special-args)
- "ldiv" (compile-jvm-ldiv compile ?values special-args)
- "lrem" (compile-jvm-lrem compile ?values special-args)
- "leq" (compile-jvm-leq compile ?values special-args)
- "llt" (compile-jvm-llt compile ?values special-args)
- "lgt" (compile-jvm-lgt compile ?values special-args)
- "fadd" (compile-jvm-fadd compile ?values special-args)
- "fsub" (compile-jvm-fsub compile ?values special-args)
- "fmul" (compile-jvm-fmul compile ?values special-args)
- "fdiv" (compile-jvm-fdiv compile ?values special-args)
- "frem" (compile-jvm-frem compile ?values special-args)
- "feq" (compile-jvm-feq compile ?values special-args)
- "flt" (compile-jvm-flt compile ?values special-args)
- "fgt" (compile-jvm-fgt compile ?values special-args)
- "dadd" (compile-jvm-dadd compile ?values special-args)
- "dsub" (compile-jvm-dsub compile ?values special-args)
- "dmul" (compile-jvm-dmul compile ?values special-args)
- "ddiv" (compile-jvm-ddiv compile ?values special-args)
- "drem" (compile-jvm-drem compile ?values special-args)
- "deq" (compile-jvm-deq compile ?values special-args)
- "dlt" (compile-jvm-dlt compile ?values special-args)
- "dgt" (compile-jvm-dgt compile ?values special-args)
- "iand" (compile-jvm-iand compile ?values special-args)
- "ior" (compile-jvm-ior compile ?values special-args)
- "ixor" (compile-jvm-ixor compile ?values special-args)
- "ishl" (compile-jvm-ishl compile ?values special-args)
- "ishr" (compile-jvm-ishr compile ?values special-args)
- "iushr" (compile-jvm-iushr compile ?values special-args)
- "land" (compile-jvm-land compile ?values special-args)
- "lor" (compile-jvm-lor compile ?values special-args)
- "lxor" (compile-jvm-lxor compile ?values special-args)
- "lshl" (compile-jvm-lshl compile ?values special-args)
- "lshr" (compile-jvm-lshr compile ?values special-args)
- "lushr" (compile-jvm-lushr compile ?values special-args)
- "d2f" (compile-jvm-d2f compile ?values special-args)
- "d2i" (compile-jvm-d2i compile ?values special-args)
- "d2l" (compile-jvm-d2l compile ?values special-args)
- "f2d" (compile-jvm-f2d compile ?values special-args)
- "f2i" (compile-jvm-f2i compile ?values special-args)
- "f2l" (compile-jvm-f2l compile ?values special-args)
- "i2b" (compile-jvm-i2b compile ?values special-args)
- "i2c" (compile-jvm-i2c compile ?values special-args)
- "i2d" (compile-jvm-i2d compile ?values special-args)
- "i2f" (compile-jvm-i2f compile ?values special-args)
- "i2l" (compile-jvm-i2l compile ?values special-args)
- "i2s" (compile-jvm-i2s compile ?values special-args)
- "l2d" (compile-jvm-l2d compile ?values special-args)
- "l2f" (compile-jvm-l2f compile ?values special-args)
- "l2i" (compile-jvm-l2i compile ?values special-args)
- "l2s" (compile-jvm-l2s compile ?values special-args)
- "l2b" (compile-jvm-l2b compile ?values special-args)
- "c2b" (compile-jvm-c2b compile ?values special-args)
- "c2s" (compile-jvm-c2s compile ?values special-args)
- "c2i" (compile-jvm-c2i compile ?values special-args)
- "c2l" (compile-jvm-c2l compile ?values special-args)
- "s2l" (compile-jvm-s2l compile ?values special-args)
- "b2l" (compile-jvm-b2l compile ?values special-args)
- ;; else
- (fail (str "[Compiler Error] Unknown host procedure: " [proc-category proc-name])))
-
- ;; else
- (fail (str "[Compiler Error] Unknown host procedure: " [proc-category proc-name]))))
diff --git a/src/lux/compiler/io.clj b/src/lux/compiler/io.clj
deleted file mode 100644
index ecb2066cd..000000000
--- a/src/lux/compiler/io.clj
+++ /dev/null
@@ -1,36 +0,0 @@
-;; Copyright (c) Eduardo Julian. All rights reserved.
-;; This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0.
-;; If a copy of the MPL was not distributed with this file,
-;; You can obtain one at http://mozilla.org/MPL/2.0/.
-
-(ns lux.compiler.io
- (:require (lux [base :as & :refer [|case |let |do return* return fail fail*]])
- (lux.compiler [base :as &&])
- [lux.lib.loader :as &lib]))
-
-;; [Utils]
-(def ^:private !libs (atom nil))
-
-(defn ^:private libs-imported? []
- (not (nil? @!libs)))
-
-(defn ^:private init-libs! []
- (reset! !libs (&lib/load)))
-
-;; [Resources]
-(defn read-file [source-dirs ^String file-name]
- (|case (&/|some (fn [source-dir]
- (let [file (new java.io.File (str source-dir "/" file-name))]
- (if (.exists file)
- (&/$Some file)
- &/$None)))
- source-dirs)
- (&/$Some file)
- (return (slurp file))
-
- (&/$None)
- (do (when (not (libs-imported?))
- (init-libs!))
- (if-let [code (get @!libs file-name)]
- (return code)
- (fail (str "[I/O Error] File doesn't exist: " file-name))))))
diff --git a/src/lux/compiler/lambda.clj b/src/lux/compiler/lambda.clj
deleted file mode 100644
index c0096523f..000000000
--- a/src/lux/compiler/lambda.clj
+++ /dev/null
@@ -1,286 +0,0 @@
-;; Copyright (c) Eduardo Julian. All rights reserved.
-;; This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0.
-;; If a copy of the MPL was not distributed with this file,
-;; You can obtain one at http://mozilla.org/MPL/2.0/.
-
-(ns lux.compiler.lambda
- (:require (clojure [string :as string]
- [set :as set]
- [template :refer [do-template]])
- clojure.core.match
- clojure.core.match.array
- (lux [base :as & :refer [|do return* return fail fail* |case |let]]
- [type :as &type]
- [lexer :as &lexer]
- [parser :as &parser]
- [analyser :as &analyser]
- [host :as &host]
- [optimizer :as &o])
- [lux.host.generics :as &host-generics]
- [lux.analyser.base :as &a]
- (lux.compiler [base :as &&]))
- (:import (org.objectweb.asm Opcodes
- Label
- ClassWriter
- MethodVisitor)))
-
-;; [Utils]
-(def ^:private field-sig (&host-generics/->type-signature "java.lang.Object"))
-(def ^:private lambda-return-sig (&host-generics/->type-signature "java.lang.Object"))
-(def ^:private <init>-return "V")
-
-(defn ^:private ^String reset-signature [function-class]
- (str "()" (&host-generics/->type-signature function-class)))
-
-(defn ^:private ^MethodVisitor get-num-partials! [^MethodVisitor method-writer]
- (doto method-writer
- (.visitVarInsn Opcodes/ALOAD 0)
- (.visitFieldInsn Opcodes/GETFIELD &&/function-class &&/partials-field "I")))
-
-(defn ^:private ^MethodVisitor inc-int! [^MethodVisitor method-writer by]
- (doto method-writer
- (.visitLdcInsn (int by))
- (.visitInsn Opcodes/IADD)))
-
-(defn ^:private ^MethodVisitor get-field! [^MethodVisitor method-writer class-name field-name]
- (doto method-writer
- (.visitVarInsn Opcodes/ALOAD 0)
- (.visitFieldInsn Opcodes/GETFIELD class-name field-name field-sig)))
-
-(defn ^:private ^MethodVisitor put-field! [^MethodVisitor method-writer class-name field-name field-sig value-thunk]
- (doto method-writer
- (.visitVarInsn Opcodes/ALOAD 0)
- value-thunk
- (.visitFieldInsn Opcodes/PUTFIELD class-name field-name field-sig)))
-
-(defn ^:private ^MethodVisitor fill-nulls! [^MethodVisitor method-writer amount]
- (doto method-writer
- (-> (.visitInsn Opcodes/ACONST_NULL)
- (->> (dotimes [_ amount])))))
-
-(defn ^:private ^MethodVisitor consecutive-args [^MethodVisitor method-writer start amount]
- (doto method-writer
- (-> (.visitVarInsn Opcodes/ALOAD (+ start idx))
- (->> (dotimes [idx amount])))))
-
-(defn ^:private ^MethodVisitor consecutive-applys [^MethodVisitor method-writer start amount]
- (let [max-args-num (min amount &&/num-apply-variants)]
- (doto method-writer
- (.visitTypeInsn Opcodes/CHECKCAST &&/function-class)
- (consecutive-args start max-args-num)
- (.visitMethodInsn Opcodes/INVOKEVIRTUAL &&/function-class &&/apply-method (&&/apply-signature max-args-num))
- (-> (consecutive-applys (+ start &&/num-apply-variants) (- amount &&/num-apply-variants))
- (->> (when (> amount &&/num-apply-variants)))))))
-
-(defn ^:private lambda-impl-signature [arity]
- (str "(" (&/fold str "" (&/|repeat arity field-sig)) ")" lambda-return-sig))
-
-(defn ^:private lambda-<init>-signature [env arity]
- (if (> arity 1)
- (str "(" (&/fold str "" (&/|repeat (&/|length env) field-sig)) "I" (&/fold str "" (&/|repeat (dec arity) field-sig)) ")"
- <init>-return)
- (str "(" (&/fold str "" (&/|repeat (&/|length env) field-sig)) ")"
- <init>-return)))
-
-(defn ^:private init-function [^MethodVisitor method-writer arity closure-length]
- (if (= 1 arity)
- (doto method-writer
- (.visitLdcInsn (int 0))
- (.visitMethodInsn Opcodes/INVOKESPECIAL &&/function-class "<init>" "(I)V"))
- (doto method-writer
- (.visitVarInsn Opcodes/ILOAD (inc closure-length))
- (.visitMethodInsn Opcodes/INVOKESPECIAL &&/function-class "<init>" "(I)V"))))
-
-(defn ^:private add-lambda-<init> [^ClassWriter class class-name arity env]
- (let [closure-length (&/|length env)]
- (doto (.visitMethod class Opcodes/ACC_PUBLIC "<init>" (lambda-<init>-signature env arity) nil nil)
- (.visitCode)
- ;; Do normal object initialization
- (.visitVarInsn Opcodes/ALOAD 0)
- (init-function arity closure-length)
- ;; Add all of the closure variables
- (-> (put-field! class-name (str &&/closure-prefix ?captured-id) field-sig #(.visitVarInsn ^MethodVisitor % Opcodes/ALOAD (inc ?captured-id)))
- (->> (|let [[?name [_ (&o/$captured _ ?captured-id ?source)]] ?name+?captured])
- (doseq [?name+?captured (&/->seq env)])))
- ;; Add all the partial arguments
- (-> (put-field! class-name (str &&/partial-prefix idx*) field-sig #(.visitVarInsn ^MethodVisitor % Opcodes/ALOAD partial-register))
- (->> (|let [partial-register (+ (inc idx*) (inc closure-length))])
- (dotimes [idx* (dec arity)])))
- ;; Finish
- (.visitInsn Opcodes/RETURN)
- (.visitMaxs 0 0)
- (.visitEnd))))
-
-(let [impl-flags (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL)]
- (defn ^:private add-lambda-impl [^ClassWriter class class-name compile arity impl-body]
- (let [$begin (new Label)]
- (&/with-writer (doto (.visitMethod class impl-flags "impl" (lambda-impl-signature arity) nil nil)
- (.visitCode)
- (.visitLabel $begin))
- (|do [^MethodVisitor *writer* &/get-writer
- ret (compile $begin impl-body)
- :let [_ (doto *writer*
- (.visitInsn Opcodes/ARETURN)
- (.visitMaxs 0 0)
- (.visitEnd))]]
- (return ret))))))
-
-(defn ^:private instance-closure [compile lambda-class arity closed-over]
- (|do [^MethodVisitor *writer* &/get-writer
- :let [_ (doto *writer*
- (.visitTypeInsn Opcodes/NEW lambda-class)
- (.visitInsn Opcodes/DUP))]
- _ (&/map% (fn [?name+?captured]
- (|case ?name+?captured
- [?name [_ (&o/$captured _ _ ?source)]]
- (compile nil ?source)))
- closed-over)
- :let [_ (when (> arity 1)
- (doto *writer*
- (.visitLdcInsn (int 0))
- (fill-nulls! (dec arity))))]
- :let [_ (.visitMethodInsn *writer* Opcodes/INVOKESPECIAL lambda-class "<init>" (lambda-<init>-signature closed-over arity))]]
- (return nil)))
-
-(defn ^:private add-lambda-reset [^ClassWriter class-writer class-name arity env]
- (if (> arity 1)
- (doto (.visitMethod class-writer Opcodes/ACC_PUBLIC "reset" (reset-signature class-name) nil nil)
- (.visitCode)
- (.visitTypeInsn Opcodes/NEW class-name)
- (.visitInsn Opcodes/DUP)
- (-> (get-field! class-name (str &&/closure-prefix cidx))
- (->> (dotimes [cidx (&/|length env)])))
- (.visitLdcInsn (int 0))
- (fill-nulls! (dec arity))
- (.visitMethodInsn Opcodes/INVOKESPECIAL class-name "<init>" (lambda-<init>-signature env arity))
- (.visitInsn Opcodes/ARETURN)
- (.visitMaxs 0 0)
- (.visitEnd))
- (doto (.visitMethod class-writer Opcodes/ACC_PUBLIC "reset" (reset-signature class-name) nil nil)
- (.visitCode)
- (.visitVarInsn Opcodes/ALOAD 0)
- (.visitInsn Opcodes/ARETURN)
- (.visitMaxs 0 0)
- (.visitEnd))))
-
-(defn ^:private add-lambda-apply-n [^ClassWriter class-writer +degree+ class-name arity env compile impl-body]
- (if (> arity 1)
- (let [num-partials (dec arity)
- $default (new Label)
- $labels* (map (fn [_] (new Label)) (repeat num-partials nil))
- $labels (vec (concat $labels* (list $default)))
- $end (new Label)
- method-writer (.visitMethod class-writer Opcodes/ACC_PUBLIC &&/apply-method (&&/apply-signature +degree+) nil nil)
- frame-locals (to-array (list class-name "java/lang/Object" "java/lang/Object"))
- frame-stack (to-array [Opcodes/INTEGER])
- arity-over-extent (- arity +degree+)]
- (do (doto method-writer
- (.visitCode)
- get-num-partials!
- (.visitTableSwitchInsn 0 (dec num-partials) $default (into-array Label $labels*))
- ;; (< stage (- arity +degree+))
- (-> (doto (.visitLabel $label)
- (.visitTypeInsn Opcodes/NEW class-name)
- (.visitInsn Opcodes/DUP)
- (-> (get-field! class-name (str &&/closure-prefix cidx))
- (->> (dotimes [cidx (&/|length env)])))
- get-num-partials!
- (inc-int! +degree+)
- (-> (get-field! class-name (str &&/partial-prefix idx))
- (->> (dotimes [idx stage])))
- (consecutive-args 1 +degree+)
- (fill-nulls! (- (- num-partials +degree+) stage))
- (.visitMethodInsn Opcodes/INVOKESPECIAL class-name "<init>" (lambda-<init>-signature env arity))
- (.visitJumpInsn Opcodes/GOTO $end))
- (->> (cond (= stage arity-over-extent)
- (doto method-writer
- (.visitLabel $label)
- (.visitVarInsn Opcodes/ALOAD 0)
- (-> (.visitMethodInsn Opcodes/INVOKEVIRTUAL class-name "reset" (reset-signature class-name))
- (->> (when (not= 0 stage))))
- (-> (get-field! class-name (str &&/partial-prefix idx))
- (->> (dotimes [idx stage])))
- (consecutive-args 1 +degree+)
- (.visitMethodInsn Opcodes/INVOKEVIRTUAL class-name "impl" (lambda-impl-signature arity))
- (.visitJumpInsn Opcodes/GOTO $end))
-
- (> stage arity-over-extent)
- (let [args-to-completion (- arity stage)
- args-left (- +degree+ args-to-completion)]
- (doto method-writer
- (.visitLabel $label)
- (.visitVarInsn Opcodes/ALOAD 0)
- (.visitMethodInsn Opcodes/INVOKEVIRTUAL class-name "reset" (reset-signature class-name))
- (-> (get-field! class-name (str &&/partial-prefix idx))
- (->> (dotimes [idx stage])))
- (consecutive-args 1 args-to-completion)
- (.visitMethodInsn Opcodes/INVOKEVIRTUAL class-name "impl" (lambda-impl-signature arity))
- (consecutive-applys (+ 1 args-to-completion) args-left)
- (.visitJumpInsn Opcodes/GOTO $end)))
-
- :else)
- (doseq [[stage $label] (map vector (range arity) $labels)])))
- (.visitLabel $end)
- (.visitInsn Opcodes/ARETURN)
- (.visitMaxs 0 0)
- (.visitEnd))
- (return nil)))
- (let [$begin (new Label)]
- (&/with-writer (doto (.visitMethod ^ClassWriter class-writer Opcodes/ACC_PUBLIC &&/apply-method (&&/apply-signature 1) nil nil)
- (.visitCode)
- (.visitLabel $begin))
- (|do [^MethodVisitor *writer* &/get-writer
- ret (compile $begin impl-body)
- :let [_ (doto *writer*
- (.visitInsn Opcodes/ARETURN)
- (.visitMaxs 0 0)
- (.visitEnd))]]
- (return ret))))
- ))
-
-;; [Exports]
-(let [lambda-flags (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_SUPER)
- datum-flags (+ Opcodes/ACC_PRIVATE Opcodes/ACC_FINAL)]
- (defn compile-function [compile ?prev-writer arity ?scope ?env ?body]
- (|do [[file-name _ _] &/cursor
- :let [??scope (&/|reverse ?scope)
- name (&host/location (&/|tail ??scope))
- class-name (str (&host/->module-class (&/|head ??scope)) "/" name)
- [^ClassWriter =class save?] (|case ?prev-writer
- (&/$Some _writer)
- (&/T [_writer false])
-
- (&/$None)
- (&/T [(doto (new ClassWriter ClassWriter/COMPUTE_MAXS)
- (.visit &host/bytecode-version lambda-flags
- class-name nil &&/function-class (into-array String [])))
- true]))
- _ (doto =class
- (-> (.visitField (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC Opcodes/ACC_FINAL) &&/arity-field "I" nil (int arity))
- (doto (.visitEnd)))
- (-> (doto (.visitField datum-flags captured-name field-sig nil nil)
- (.visitEnd))
- (->> (let [captured-name (str &&/closure-prefix ?captured-id)])
- (|case ?name+?captured
- [?name [_ (&o/$captured _ ?captured-id ?source)]])
- (doseq [?name+?captured (&/->seq ?env)])))
- (-> (.visitField datum-flags (str &&/partial-prefix idx) field-sig nil nil)
- (doto (.visitEnd))
- (->> (dotimes [idx (dec arity)])))
- (-> (.visitSource file-name nil)
- (when save?))
- (add-lambda-<init> class-name arity ?env)
- (add-lambda-reset class-name arity ?env)
- )]
- _ (if (> arity 1)
- (add-lambda-impl =class class-name compile arity ?body)
- (return nil))
- _ (&/map% #(add-lambda-apply-n =class % class-name arity ?env compile ?body)
- (&/|range* 1 (min arity &&/num-apply-variants)))
- :let [_ (.visitEnd =class)]
- _ (if save?
- (&&/save-class! name (.toByteArray =class))
- (return nil))]
- (if save?
- (instance-closure compile class-name arity ?env)
- (return (instance-closure compile class-name arity ?env))))))
diff --git a/src/lux/compiler/lux.clj b/src/lux/compiler/lux.clj
deleted file mode 100644
index 5dc8becc0..000000000
--- a/src/lux/compiler/lux.clj
+++ /dev/null
@@ -1,498 +0,0 @@
-;; Copyright (c) Eduardo Julian. All rights reserved.
-;; This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0.
-;; If a copy of the MPL was not distributed with this file,
-;; You can obtain one at http://mozilla.org/MPL/2.0/.
-
-(ns lux.compiler.lux
- (:require (clojure [string :as string]
- [set :as set]
- [template :refer [do-template]])
- clojure.core.match
- clojure.core.match.array
- (lux [base :as & :refer [|do return* return fail fail* |let |case]]
- [type :as &type]
- [lexer :as &lexer]
- [parser :as &parser]
- [analyser :as &analyser]
- [host :as &host]
- [optimizer :as &o])
- [lux.host.generics :as &host-generics]
- (lux.analyser [base :as &a]
- [module :as &a-module]
- [meta :as &a-meta])
- (lux.compiler [base :as &&]
- [lambda :as &&lambda]))
- (:import (org.objectweb.asm Opcodes
- Label
- ClassWriter
- MethodVisitor)
- java.lang.reflect.Field))
-
-;; [Exports]
-(defn compile-bool [?value]
- (|do [^MethodVisitor *writer* &/get-writer
- :let [_ (.visitFieldInsn *writer* Opcodes/GETSTATIC "java/lang/Boolean" (if ?value "TRUE" "FALSE") "Ljava/lang/Boolean;")]]
- (return nil)))
-
-(do-template [<name> <class> <prim> <caster>]
- (defn <name> [value]
- (|do [^MethodVisitor *writer* &/get-writer
- :let [_ (doto *writer*
- (.visitLdcInsn (<caster> value))
- (.visitMethodInsn Opcodes/INVOKESTATIC <class> "valueOf" (str "(" <prim> ")" (&host-generics/->type-signature <class>))))]]
- (return nil)))
-
- compile-nat "java/lang/Long" "J" long
- compile-int "java/lang/Long" "J" long
- compile-frac "java/lang/Long" "J" long
- compile-real "java/lang/Double" "D" double
- compile-char "java/lang/Character" "C" char
- )
-
-(defn compile-text [?value]
- (|do [^MethodVisitor *writer* &/get-writer
- :let [_ (.visitLdcInsn *writer* ?value)]]
- (return nil)))
-
-(defn compile-tuple [compile ?elems]
- (|do [^MethodVisitor *writer* &/get-writer
- :let [num-elems (&/|length ?elems)]]
- (|case num-elems
- 0
- (|do [:let [_ (.visitLdcInsn *writer* &/unit-tag)]]
- (return nil))
-
- 1
- (compile (&/|head ?elems))
-
- _
- (|do [:let [_ (doto *writer*
- (.visitLdcInsn (int num-elems))
- (.visitTypeInsn Opcodes/ANEWARRAY "java/lang/Object"))]
- _ (&/map2% (fn [idx elem]
- (|do [:let [_ (doto *writer*
- (.visitInsn Opcodes/DUP)
- (.visitLdcInsn (int idx)))]
- ret (compile elem)
- :let [_ (.visitInsn *writer* Opcodes/AASTORE)]]
- (return ret)))
- (&/|range num-elems) ?elems)]
- (return nil)))))
-
-(defn compile-variant [compile tag tail? value]
- (|do [^MethodVisitor *writer* &/get-writer
- :let [_ (.visitLdcInsn *writer* (int tag))
- _ (if tail?
- (.visitLdcInsn *writer* "")
- (.visitInsn *writer* Opcodes/ACONST_NULL))]
- _ (compile value)
- :let [_ (.visitMethodInsn *writer* Opcodes/INVOKESTATIC "lux/LuxRT" "sum_make" "(ILjava/lang/Object;Ljava/lang/Object;)[Ljava/lang/Object;")]]
- (return nil)))
-
-(defn compile-local [compile ?idx]
- (|do [^MethodVisitor *writer* &/get-writer
- :let [_ (.visitVarInsn *writer* Opcodes/ALOAD (int ?idx))]]
- (return nil)))
-
-(defn compile-captured [compile ?scope ?captured-id ?source]
- (|do [:let [??scope (&/|reverse ?scope)]
- ^MethodVisitor *writer* &/get-writer
- :let [_ (doto *writer*
- (.visitVarInsn Opcodes/ALOAD 0)
- (.visitFieldInsn Opcodes/GETFIELD
- (str (&host/->module-class (&/|head ??scope)) "/" (&host/location (&/|tail ??scope)))
- (str &&/closure-prefix ?captured-id)
- "Ljava/lang/Object;"))]]
- (return nil)))
-
-(defn compile-global [compile ?owner-class ?name]
- (|do [^MethodVisitor *writer* &/get-writer
- :let [_ (.visitFieldInsn *writer* Opcodes/GETSTATIC (str (&host/->module-class ?owner-class) "/" (&host/def-name ?name)) &/value-field "Ljava/lang/Object;")]]
- (return nil)))
-
-(defn ^:private compile-apply* [compile ?args]
- (|do [^MethodVisitor *writer* &/get-writer
- _ (&/map% (fn [?args]
- (|do [:let [_ (.visitTypeInsn *writer* Opcodes/CHECKCAST &&/function-class)]
- _ (&/map% compile ?args)
- :let [_ (.visitMethodInsn *writer* Opcodes/INVOKEVIRTUAL &&/function-class &&/apply-method (&&/apply-signature (&/|length ?args)))]]
- (return nil)))
- (&/|partition &&/num-apply-variants ?args))]
- (return nil)))
-
-(defn compile-apply [compile ?fn ?args]
- (|case ?fn
- [_ (&o/$var (&/$Global ?module ?name))]
- (|do [[_ [_ _ func-obj]] (&a-module/find-def ?module ?name)
- class-loader &/loader
- :let [func-class (class func-obj)
- func-arity (.get ^Field (.getDeclaredField func-class &&/arity-field) nil)
- func-partials (.get ^Field (.getDeclaredField (Class/forName "lux.Function" true class-loader) &&/partials-field) func-obj)
- num-args (&/|length ?args)
- func-class-name (->> func-class .getName &host-generics/->bytecode-class-name)]]
- (if (and (= 0 func-partials)
- (>= num-args func-arity))
- (|do [_ (compile ?fn)
- ^MethodVisitor *writer* &/get-writer
- :let [_ (.visitTypeInsn *writer* Opcodes/CHECKCAST func-class-name)]
- _ (&/map% compile (&/|take func-arity ?args))
- :let [_ (.visitMethodInsn *writer* Opcodes/INVOKEVIRTUAL func-class-name (if (= 1 func-arity) &&/apply-method "impl") (&&/apply-signature func-arity))]
- _ (if (= num-args func-arity)
- (return nil)
- (compile-apply* compile (&/|drop func-arity ?args)))]
- (return nil))
- (|do [_ (compile ?fn)]
- (compile-apply* compile ?args))))
-
- _
- (|do [_ (compile ?fn)]
- (compile-apply* compile ?args))
- ))
-
-(defn compile-loop [compile-expression register-offset inits body]
- (|do [^MethodVisitor *writer* &/get-writer
- :let [idxs+inits (&/zip2 (&/|range* 0 (dec (&/|length inits)))
- inits)]
- _ (&/map% (fn [idx+_init]
- (|do [:let [[idx _init] idx+_init
- idx+ (+ register-offset idx)]
- _ (compile-expression nil _init)
- :let [_ (.visitVarInsn *writer* Opcodes/ASTORE idx+)]]
- (return nil)))
- idxs+inits)
- :let [$begin (new Label)
- _ (.visitLabel *writer* $begin)]]
- (compile-expression $begin body)
- ))
-
-(defn compile-iter [compile $begin register-offset ?args]
- (|do [^MethodVisitor *writer* &/get-writer
- :let [idxs+args (&/zip2 (&/|range* 0 (dec (&/|length ?args)))
- ?args)]
- _ (&/map% (fn [idx+?arg]
- (|do [:let [[idx ?arg] idx+?arg
- idx+ (+ register-offset idx)
- already-set? (|case ?arg
- [_ (&o/$var (&/$Local l-idx))]
- (= idx+ l-idx)
-
- _
- false)]]
- (if already-set?
- (return nil)
- (compile ?arg))))
- idxs+args)
- _ (&/map% (fn [idx+?arg]
- (|do [:let [[idx ?arg] idx+?arg
- idx+ (+ register-offset idx)
- already-set? (|case ?arg
- [_ (&o/$var (&/$Local l-idx))]
- (= idx+ l-idx)
-
- _
- false)]
- :let [_ (when (not already-set?)
- (.visitVarInsn *writer* Opcodes/ASTORE idx+))]]
- (return nil)))
- (&/|reverse idxs+args))
- :let [_ (.visitJumpInsn *writer* Opcodes/GOTO $begin)]]
- (return nil)))
-
-(defn compile-let [compile _value _register _body]
- (|do [^MethodVisitor *writer* &/get-writer
- _ (compile _value)
- :let [_ (.visitVarInsn *writer* Opcodes/ASTORE _register)]
- _ (compile _body)]
- (return nil)))
-
-(defn compile-record-get [compile _value _path]
- (|do [^MethodVisitor *writer* &/get-writer
- _ (compile _value)
- :let [_ (&/|map (fn [step]
- (|let [[idx tail?] step]
- (doto *writer*
- (.visitTypeInsn Opcodes/CHECKCAST "[Ljava/lang/Object;")
- (.visitLdcInsn (int idx))
- (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT"
- (if tail? "product_getRight" "product_getLeft")
- "([Ljava/lang/Object;I)Ljava/lang/Object;"))))
- _path)]]
- (return nil)))
-
-(defn compile-if [compile _test _then _else]
- (|do [^MethodVisitor *writer* &/get-writer
- _ (compile _test)
- :let [$else (new Label)
- $end (new Label)
- _ (doto *writer*
- &&/unwrap-boolean
- (.visitJumpInsn Opcodes/IFEQ $else))]
- _ (compile _then)
- :let [_ (.visitJumpInsn *writer* Opcodes/GOTO $end)]
- :let [_ (.visitLabel *writer* $else)]
- _ (compile _else)
- :let [_ (.visitJumpInsn *writer* Opcodes/GOTO $end)
- _ (.visitLabel *writer* $end)]]
- (return nil)))
-
-(defn ^:private de-ann [optim]
- (|case optim
- [_ (&o/$ann value-expr _)]
- value-expr
-
- _
- optim))
-
-(defn ^:private throwable->text [^Throwable t]
- (let [base (->> t
- .getStackTrace
- (map str)
- (cons (.getMessage t))
- (interpose "\n")
- (apply str))]
- (if-let [cause (.getCause t)]
- (str base "\n\n" "Caused by: " (throwable->text cause))
- base)))
-
-(let [class-flags (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_SUPER)
- field-flags (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_STATIC)]
- (defn compile-def [compile ?name ?body ?meta]
- (|do [module-name &/get-module-name
- class-loader &/loader]
- (|case (&a-meta/meta-get &a-meta/alias-tag ?meta)
- (&/$Some (&/$IdentM [r-module r-name]))
- (if (= 1 (&/|length ?meta))
- (|do [:let [current-class (&host-generics/->class-name (str (&host/->module-class r-module) "/" (&host/def-name r-name)))
- def-class (&&/load-class! class-loader current-class)
- def-type (&a-module/def-type r-module r-name)
- def-meta ?meta
- def-value (-> def-class (.getField &/value-field) (.get nil))]
- _ (&/without-repl-closure
- (&a-module/define module-name ?name def-type def-meta def-value))]
- (return nil))
- (fail (str "[Compilation Error] Aliases cannot contain meta-data: " module-name ";" ?name)))
-
- (&/$Some _)
- (fail "[Compilation Error] Invalid syntax for lux;alias meta-data. Must be an Ident.")
-
- _
- (|case (de-ann ?body)
- [_ (&o/$function _ _ __scope _ _)]
- (|let [[_ (&o/$function _ _arity _scope _captured ?body+)] (&o/shift-function-body (&/|tail __scope) __scope
- false
- (de-ann ?body))]
- (|do [:let [=value-type (&a/expr-type* ?body)]
- [file-name _ _] &/cursor
- :let [datum-sig "Ljava/lang/Object;"
- def-name (&host/def-name ?name)
- current-class (str (&host/->module-class module-name) "/" def-name)
- =class (doto (new ClassWriter ClassWriter/COMPUTE_MAXS)
- (.visit &host/bytecode-version class-flags
- current-class nil &&/function-class (into-array String []))
- (-> (.visitField field-flags &/name-field "Ljava/lang/String;" nil ?name)
- (doto (.visitEnd)))
- (-> (.visitField field-flags &/value-field datum-sig nil nil)
- (doto (.visitEnd)))
- (.visitSource file-name nil))]
- instancer (&&lambda/compile-function compile (&/$Some =class) _arity _scope _captured ?body+)
- _ (&/with-writer (.visitMethod =class Opcodes/ACC_STATIC "<clinit>" "()V" nil nil)
- (|do [^MethodVisitor **writer** &/get-writer
- :let [_ (.visitCode **writer**)]
- _ instancer
- :let [_ (.visitTypeInsn **writer** Opcodes/CHECKCAST "java/lang/Object")
- _ (.visitFieldInsn **writer** Opcodes/PUTSTATIC current-class &/value-field datum-sig)]
- :let [_ (doto **writer**
- (.visitInsn Opcodes/RETURN)
- (.visitMaxs 0 0)
- (.visitEnd))]]
- (return nil)))
- :let [_ (.visitEnd =class)]
- _ (&&/save-class! def-name (.toByteArray =class))
- :let [def-class (&&/load-class! class-loader (&host-generics/->class-name current-class))
- def-type (&a/expr-type* ?body)
- is-type? (|case (&a-meta/meta-get &a-meta/type?-tag ?meta)
- (&/$Some (&/$BoolM true))
- true
-
- _
- false)
- def-meta ?meta
- def-value (-> def-class (.getField &/value-field) (.get nil))]
- _ (&/without-repl-closure
- (&a-module/define module-name ?name def-type def-meta def-value))
- _ (|case (&/T [is-type? (&a-meta/meta-get &a-meta/tags-tag def-meta)])
- [true (&/$Some (&/$ListM tags*))]
- (|do [:let [was-exported? (|case (&a-meta/meta-get &a-meta/export?-tag def-meta)
- (&/$Some _)
- true
-
- _
- false)]
- tags (&/map% (fn [tag*]
- (|case tag*
- (&/$TextM tag)
- (return tag)
-
- _
- (fail "[Compiler Error] Incorrect format for tags.")))
- tags*)
- _ (&a-module/declare-tags module-name tags was-exported? def-value)]
- (return nil))
-
- [false (&/$Some _)]
- (fail "[Compiler Error] Can't define tags for non-type.")
-
- [true (&/$Some _)]
- (fail "[Compiler Error] Incorrect format for tags.")
-
- [_ (&/$None)]
- (return nil))
- :let [_ (println 'DEF (str module-name ";" ?name))]]
- (return nil)))
-
- _
- (|do [:let [=value-type (&a/expr-type* ?body)]
- [file-name _ _] &/cursor
- :let [datum-sig "Ljava/lang/Object;"
- def-name (&host/def-name ?name)
- current-class (str (&host/->module-class module-name) "/" def-name)
- =class (doto (new ClassWriter ClassWriter/COMPUTE_MAXS)
- (.visit &host/bytecode-version class-flags
- current-class nil "java/lang/Object" (into-array String []))
- (-> (.visitField field-flags &/name-field "Ljava/lang/String;" nil ?name)
- (doto (.visitEnd)))
- (-> (.visitField field-flags &/value-field datum-sig nil nil)
- (doto (.visitEnd)))
- (.visitSource file-name nil))]
- _ (&/with-writer (.visitMethod =class Opcodes/ACC_STATIC "<clinit>" "()V" nil nil)
- (|do [^MethodVisitor **writer** &/get-writer
- :let [_ (.visitCode **writer**)]
- _ (compile nil ?body)
- :let [_ (.visitTypeInsn **writer** Opcodes/CHECKCAST "java/lang/Object")
- _ (.visitFieldInsn **writer** Opcodes/PUTSTATIC current-class &/value-field datum-sig)]
- :let [_ (doto **writer**
- (.visitInsn Opcodes/RETURN)
- (.visitMaxs 0 0)
- (.visitEnd))]]
- (return nil)))
- :let [_ (.visitEnd =class)]
- _ (&&/save-class! def-name (.toByteArray =class))
- :let [def-class (&&/load-class! class-loader (&host-generics/->class-name current-class))
- def-type (&a/expr-type* ?body)
- is-type? (|case (&a-meta/meta-get &a-meta/type?-tag ?meta)
- (&/$Some (&/$BoolM true))
- true
-
- _
- false)
- def-meta ?meta]
- def-value (try (return (-> def-class (.getField &/value-field) (.get nil)))
- (catch Throwable t
- (&/assert! false (throwable->text t))))
- _ (&/without-repl-closure
- (&a-module/define module-name ?name def-type def-meta def-value))
- _ (|case (&/T [is-type? (&a-meta/meta-get &a-meta/tags-tag def-meta)])
- [true (&/$Some (&/$ListM tags*))]
- (|do [:let [was-exported? (|case (&a-meta/meta-get &a-meta/export?-tag def-meta)
- (&/$Some _)
- true
-
- _
- false)]
- tags (&/map% (fn [tag*]
- (|case tag*
- (&/$TextM tag)
- (return tag)
-
- _
- (fail "[Compiler Error] Incorrect format for tags.")))
- tags*)
- _ (&a-module/declare-tags module-name tags was-exported? def-value)]
- (return nil))
-
- [false (&/$Some _)]
- (fail "[Compiler Error] Can't define tags for non-type.")
-
- [true (&/$Some _)]
- (fail "[Compiler Error] Incorrect format for tags.")
-
- [_ (&/$None)]
- (return nil))
- :let [_ (println 'DEF (str module-name ";" ?name))]]
- (return nil)))
- ))))
-
-(defn compile-program [compile ?body]
- (|do [module-name &/get-module-name
- ^ClassWriter *writer* &/get-writer]
- (&/with-writer (doto (.visitMethod *writer* (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "main" "([Ljava/lang/String;)V" nil nil)
- (.visitCode))
- (|do [^MethodVisitor main-writer &/get-writer
- :let [$loop (new Label)
- $end (new Label)
- _ (doto main-writer
- ;; Tail: Begin
- (.visitLdcInsn (->> #'&/$Nil meta ::&/idx int)) ;; I
- (.visitInsn Opcodes/ACONST_NULL) ;; I?
- (.visitLdcInsn &/unit-tag) ;; I?U
- (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "sum_make" "(ILjava/lang/Object;Ljava/lang/Object;)[Ljava/lang/Object;") ;; V
- ;; Tail: End
- ;; Size: Begin
- (.visitVarInsn Opcodes/ALOAD 0) ;; VA
- (.visitInsn Opcodes/ARRAYLENGTH) ;; VI
- ;; Size: End
- ;; Loop: Begin
- (.visitLabel $loop)
- (.visitLdcInsn (int 1)) ;; VII
- (.visitInsn Opcodes/ISUB) ;; VI
- (.visitInsn Opcodes/DUP) ;; VII
- (.visitJumpInsn Opcodes/IFLT $end) ;; VI
- ;; Head: Begin
- (.visitInsn Opcodes/DUP) ;; VII
- (.visitVarInsn Opcodes/ALOAD 0) ;; VIIA
- (.visitInsn Opcodes/SWAP) ;; VIAI
- (.visitInsn Opcodes/AALOAD) ;; VIO
- (.visitInsn Opcodes/SWAP) ;; VOI
- (.visitInsn Opcodes/DUP_X2) ;; IVOI
- (.visitInsn Opcodes/POP) ;; IVO
- ;; Head: End
- ;; Tuple: Begin
- (.visitLdcInsn (int 2)) ;; IVOS
- (.visitTypeInsn Opcodes/ANEWARRAY "java/lang/Object") ;; IVO2
- (.visitInsn Opcodes/DUP_X1) ;; IV2O2
- (.visitInsn Opcodes/SWAP) ;; IV22O
- (.visitLdcInsn (int 0)) ;; IV22OI
- (.visitInsn Opcodes/SWAP) ;; IV22IO
- (.visitInsn Opcodes/AASTORE) ;; IV2
- (.visitInsn Opcodes/DUP_X1) ;; I2V2
- (.visitInsn Opcodes/SWAP) ;; I22V
- (.visitLdcInsn (int 1)) ;; I22VI
- (.visitInsn Opcodes/SWAP) ;; I22IV
- (.visitInsn Opcodes/AASTORE) ;; I2
- ;; Tuple: End
- ;; Cons: Begin
- (.visitLdcInsn (->> #'&/$Cons meta ::&/idx int)) ;; I2I
- (.visitLdcInsn "") ;; I2I?
- (.visitInsn Opcodes/DUP2_X1) ;; II?2I?
- (.visitInsn Opcodes/POP2) ;; II?2
- (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "sum_make" "(ILjava/lang/Object;Ljava/lang/Object;)[Ljava/lang/Object;") ;; IV
- ;; Cons: End
- (.visitInsn Opcodes/SWAP) ;; VI
- (.visitJumpInsn Opcodes/GOTO $loop)
- ;; Loop: End
- (.visitLabel $end) ;; VI
- (.visitInsn Opcodes/POP) ;; V
- (.visitVarInsn Opcodes/ASTORE (int 0)) ;;
- )
- ]
- _ (compile ?body)
- :let [_ (doto main-writer
- (.visitTypeInsn Opcodes/CHECKCAST &&/function-class)
- (.visitInsn Opcodes/ACONST_NULL)
- (.visitMethodInsn Opcodes/INVOKEVIRTUAL &&/function-class &&/apply-method (&&/apply-signature 1)))]
- :let [_ (doto main-writer
- (.visitInsn Opcodes/POP)
- (.visitInsn Opcodes/RETURN)
- (.visitMaxs 0 0)
- (.visitEnd))]]
- (return nil)))))
diff --git a/src/lux/compiler/module.clj b/src/lux/compiler/module.clj
deleted file mode 100644
index 03bc311f2..000000000
--- a/src/lux/compiler/module.clj
+++ /dev/null
@@ -1,28 +0,0 @@
-;; Copyright (c) Eduardo Julian. All rights reserved.
-;; This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0.
-;; If a copy of the MPL was not distributed with this file,
-;; You can obtain one at http://mozilla.org/MPL/2.0/.
-
-(ns lux.compiler.module
- (:require (clojure [string :as string]
- [set :as set]
- [template :refer [do-template]])
- clojure.core.match
- clojure.core.match.array
- (lux [base :as & :refer [|let |do return* return fail fail* |case]]
- [type :as &type])
- [lux.analyser.module :as &module]))
-
-;; [Exports]
-(def tag-groups
- "(Lux (List (, Text (List Text))))"
- (|do [module &/get-current-module]
- (return (&/|map (fn [pair]
- (|case pair
- [name [tags exported? _]]
- (&/T [name (&/|map (fn [tag]
- (|let [[t-prefix t-name] tag]
- t-name))
- tags)])))
- (&/get$ &module/$types module)))
- ))
diff --git a/src/lux/compiler/parallel.clj b/src/lux/compiler/parallel.clj
deleted file mode 100644
index 8f6fee99d..000000000
--- a/src/lux/compiler/parallel.clj
+++ /dev/null
@@ -1,47 +0,0 @@
-;; Copyright (c) Eduardo Julian. All rights reserved.
-;; This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0.
-;; If a copy of the MPL was not distributed with this file,
-;; You can obtain one at http://mozilla.org/MPL/2.0/.
-
-(ns lux.compiler.parallel
- (:require (clojure [string :as string]
- [set :as set]
- [template :refer [do-template]])
- clojure.core.match
- clojure.core.match.array
- (lux [base :as & :refer [|let |do return* return fail fail* |case]])))
-
-;; [Utils]
-(def ^:private !state! (ref {}))
-
-(def ^:private get-compiler
- (fn [compiler]
- (return* compiler compiler)))
-
-;; [Exports]
-(defn setup!
- "Must always call this function before using parallel compilation to make sure that the state that is being tracked is in proper shape."
- []
- (dosync (ref-set !state! {})))
-
-(defn parallel-compilation [compile-module*]
- (fn [module-name]
- (|do [compiler get-compiler
- :let [[task new?] (dosync (if-let [existing-task (get @!state! module-name)]
- (&/T [existing-task false])
- (let [new-task (promise)]
- (do (alter !state! assoc module-name new-task)
- (&/T [new-task true])))))
- _ (when new?
- (.start (new Thread
- (fn []
- (let [out-str (with-out-str
- (|case (&/run-state (compile-module* module-name)
- compiler)
- (&/$Right post-compiler _)
- (deliver task (&/$Right post-compiler))
-
- (&/$Left ?error)
- (deliver task (&/$Left ?error))))]
- (&/|log! out-str))))))]]
- (return task))))
diff --git a/src/lux/host.clj b/src/lux/host.clj
deleted file mode 100644
index 39e659964..000000000
--- a/src/lux/host.clj
+++ /dev/null
@@ -1,432 +0,0 @@
-;; Copyright (c) Eduardo Julian. All rights reserved.
-;; This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0.
-;; If a copy of the MPL was not distributed with this file,
-;; You can obtain one at http://mozilla.org/MPL/2.0/.
-
-(ns lux.host
- (:require (clojure [string :as string]
- [template :refer [do-template]])
- clojure.core.match
- clojure.core.match.array
- (lux [base :as & :refer [|do return* return fail fail* |let |case]]
- [type :as &type])
- [lux.type.host :as &host-type]
- [lux.host.generics :as &host-generics])
- (:import (java.lang.reflect Field Method Constructor Modifier Type
- GenericArrayType ParameterizedType TypeVariable)
- (org.objectweb.asm Opcodes
- Label
- ClassWriter
- MethodVisitor)))
-
-;; [Constants]
-(def function-class "lux.Function")
-(def module-separator "/")
-(def class-name-separator ".")
-(def class-separator "/")
-(def bytecode-version Opcodes/V1_6)
-
-;; [Resources]
-(defn ^String ->module-class [old]
- old)
-
-(def ->package ->module-class)
-
-(defn unfold-array [type]
- "(-> Type (, Int Type))"
- (|case type
- (&/$HostT "#Array" (&/$Cons param (&/$Nil)))
- (|let [[count inner] (unfold-array param)]
- (&/T [(inc count) inner]))
-
- _
- (&/T [0 type])))
-
-(let [ex-type-class (str "L" (&host-generics/->bytecode-class-name "java.lang.Object") ";")
- object-array (str "[" "L" (&host-generics/->bytecode-class-name "java.lang.Object") ";")]
- (defn ->java-sig [^objects type]
- "(-> Type (Lux Text))"
- (|case type
- (&/$HostT ?name params)
- (cond (= &host-type/array-data-tag ?name) (|do [:let [[level base] (unfold-array type)]
- base-sig (|case base
- (&/$HostT base-class _)
- (return (&host-generics/->type-signature base-class))
-
- _
- (->java-sig base))]
- (return (str (->> (&/|repeat level "[") (&/fold str ""))
- base-sig)))
- (= &host-type/null-data-tag ?name) (return (&host-generics/->type-signature "java.lang.Object"))
- :else (return (&host-generics/->type-signature ?name)))
-
- (&/$LambdaT _ _)
- (return (&host-generics/->type-signature function-class))
-
- (&/$UnitT)
- (return "V")
-
- (&/$SumT _)
- (return object-array)
-
- (&/$ProdT _)
- (return object-array)
-
- (&/$NamedT ?name ?type)
- (->java-sig ?type)
-
- (&/$AppT ?F ?A)
- (|do [type* (&type/apply-type ?F ?A)]
- (->java-sig type*))
-
- (&/$ExT _)
- (return ex-type-class)
-
- _
- (assert false (str '->java-sig " " (&type/show-type type)))
- )))
-
-(do-template [<name> <static?>]
- (defn <name> [class-loader target field]
- (|let [target-class (Class/forName target true class-loader)]
- (if-let [^Type gtype (first (for [^Field =field (seq (.getDeclaredFields target-class))
- :when (and (.equals ^Object field (.getName =field))
- (.equals ^Object <static?> (Modifier/isStatic (.getModifiers =field))))]
- (.getGenericType =field)))]
- (|let [gvars (->> target-class .getTypeParameters seq &/->list)]
- (return (&/T [gvars gtype])))
- (&/fail-with-loc (str "[Host Error] Field does not exist: " target "." field)))))
-
- lookup-static-field true
- lookup-field false
- )
-
-(do-template [<name> <static?> <method-type>]
- (defn <name> [class-loader target method-name args]
- (|let [target-class (Class/forName target true class-loader)]
- (if-let [[^Method method ^Class declarer] (first (for [^Method =method (.getDeclaredMethods target-class)
- :when (and (.equals ^Object method-name (.getName =method))
- (.equals ^Object <static?> (Modifier/isStatic (.getModifiers =method)))
- (let [param-types (&/->list (seq (.getParameterTypes =method)))]
- (and (= (&/|length args) (&/|length param-types))
- (&/fold2 #(and %1 (.equals ^Object %2 %3))
- true
- args
- (&/|map #(.getName ^Class %) param-types)))))]
- [=method
- (.getDeclaringClass =method)]))]
- (if (= target-class declarer)
- (|let [parent-gvars (->> target-class .getTypeParameters seq &/->list)
- gvars (->> method .getTypeParameters seq &/->list)
- gargs (->> method .getGenericParameterTypes seq &/->list)
- _ (when (.getAnnotation method java.lang.Deprecated)
- (println (str "[Host Warning] Deprecated method: " target "." method-name " " (->> args &/->seq print-str))))]
- (return (&/T [(.getGenericReturnType method)
- (->> method .getExceptionTypes &/->list (&/|map #(.getName ^Class %)))
- parent-gvars
- gvars
- gargs])))
- (&/fail-with-loc (str "[Host Error] " <method-type> " method " (pr-str method-name) " for " "(" (->> args (&/|interpose ", ") (&/fold str "")) ")" " belongs to parent " (.getName declarer) " instead of " target)))
- (&/fail-with-loc (str "[Host Error] " <method-type> " method does not exist: " target "." method-name " " "(" (->> args (&/|interpose ", ") (&/fold str "")) ")")))))
-
- lookup-static-method true "Static"
- lookup-virtual-method false "Virtual"
- )
-
-(defn lookup-constructor [class-loader target args]
- (let [target-class (Class/forName target true class-loader)]
- (if-let [^Constructor ctor (first (for [^Constructor =method (.getDeclaredConstructors target-class)
- :when (let [param-types (&/->list (seq (.getParameterTypes =method)))]
- (and (= (&/|length args) (&/|length param-types))
- (&/fold2 #(and %1 (.equals ^Object %2 %3))
- true
- args
- (&/|map #(.getName ^Class %) param-types))))]
- =method))]
- (|let [gvars (->> target-class .getTypeParameters seq &/->list)
- gargs (->> ctor .getGenericParameterTypes seq &/->list)
- exs (->> ctor .getExceptionTypes &/->list (&/|map #(.getName ^Class %)))
- _ (when (.getAnnotation ctor java.lang.Deprecated)
- (println (str "[Host Warning] Deprecated constructor: " target " " (->> args &/->seq print-str))))]
- (return (&/T [exs gvars gargs])))
- (&/fail-with-loc (str "[Host Error] Constructor does not exist: " target " " (->> args &/->seq print-str))))))
-
-(defn abstract-methods [class-loader super-class]
- "(-> ClassLoader SuperClassDecl (Lux (List (, Text (List Text)))))"
- (|let [[super-name super-params] super-class]
- (return (&/->list (for [^Method =method (.getDeclaredMethods (Class/forName super-name true class-loader))
- :when (Modifier/isAbstract (.getModifiers =method))]
- (&/T [(.getName =method) (&/|map #(.getName ^Class %) (&/->list (seq (.getParameterTypes =method))))]))))))
-
-(defn def-name [name]
- (str (&/normalize-name name) "_" (Long/toUnsignedString (hash name))))
-
-(defn location [scope]
- (let [scope (&/$Cons (def-name (&/|head scope))
- (&/|map &/normalize-name (&/|tail scope)))]
- (->> scope
- (&/|interpose "$")
- (&/fold str ""))))
-
-(defn primitive-jvm-type? [type]
- (case type
- ("boolean" "byte" "short" "int" "long" "float" "double" "char")
- true
- ;; else
- false))
-
-(defn dummy-value [^MethodVisitor writer class]
- (|case class
- (&/$GenericClass "boolean" (&/$Nil))
- (doto writer
- (.visitLdcInsn false))
-
- (&/$GenericClass "byte" (&/$Nil))
- (doto writer
- (.visitLdcInsn (byte 0)))
-
- (&/$GenericClass "short" (&/$Nil))
- (doto writer
- (.visitLdcInsn (short 0)))
-
- (&/$GenericClass "int" (&/$Nil))
- (doto writer
- (.visitLdcInsn (int 0)))
-
- (&/$GenericClass "long" (&/$Nil))
- (doto writer
- (.visitLdcInsn (long 0)))
-
- (&/$GenericClass "float" (&/$Nil))
- (doto writer
- (.visitLdcInsn (float 0.0)))
-
- (&/$GenericClass "double" (&/$Nil))
- (doto writer
- (.visitLdcInsn (double 0.0)))
-
- (&/$GenericClass "char" (&/$Nil))
- (doto writer
- (.visitLdcInsn (char 0)))
-
- _
- (doto writer
- (.visitInsn Opcodes/ACONST_NULL))))
-
-(defn ^:private dummy-return [^MethodVisitor writer output]
- (|case output
- (&/$GenericClass "void" (&/$Nil))
- (.visitInsn writer Opcodes/RETURN)
-
- (&/$GenericClass "boolean" (&/$Nil))
- (doto writer
- (dummy-value output)
- (.visitInsn Opcodes/IRETURN))
-
- (&/$GenericClass "byte" (&/$Nil))
- (doto writer
- (dummy-value output)
- (.visitInsn Opcodes/IRETURN))
-
- (&/$GenericClass "short" (&/$Nil))
- (doto writer
- (dummy-value output)
- (.visitInsn Opcodes/IRETURN))
-
- (&/$GenericClass "int" (&/$Nil))
- (doto writer
- (dummy-value output)
- (.visitInsn Opcodes/IRETURN))
-
- (&/$GenericClass "long" (&/$Nil))
- (doto writer
- (dummy-value output)
- (.visitInsn Opcodes/LRETURN))
-
- (&/$GenericClass "float" (&/$Nil))
- (doto writer
- (dummy-value output)
- (.visitInsn Opcodes/FRETURN))
-
- (&/$GenericClass "double" (&/$Nil))
- (doto writer
- (dummy-value output)
- (.visitInsn Opcodes/DRETURN))
-
- (&/$GenericClass "char" (&/$Nil))
- (doto writer
- (dummy-value output)
- (.visitInsn Opcodes/IRETURN))
-
- _
- (doto writer
- (dummy-value output)
- (.visitInsn Opcodes/ARETURN))))
-
-(defn ^:private ->dummy-type [real-name store-name gclass]
- (|case gclass
- (&/$GenericClass _name _params)
- (if (= real-name _name)
- (&/$GenericClass store-name (&/|map (partial ->dummy-type real-name store-name) _params))
- gclass)
-
- _
- gclass))
-
-(def init-method-name "<init>")
-
-(defn ^:private dummy-ctor [^MethodVisitor writer real-name store-name super-class ctor-args]
- (|let [ctor-arg-types (->> ctor-args (&/|map (comp &host-generics/->type-signature (comp (partial ->dummy-type real-name store-name) &/|first))) (&/fold str ""))]
- (doto writer
- (.visitVarInsn Opcodes/ALOAD 0)
- (-> (doto (dummy-value arg-type)
- (-> (.visitTypeInsn Opcodes/CHECKCAST (&host-generics/->bytecode-class-name arg-type))
- (->> (when (not (primitive-jvm-type? arg-type))))))
- (->> (doseq [ctor-arg (&/->seq ctor-args)
- :let [;; arg-term (&/|first ctor-arg)
- arg-type (->dummy-type real-name store-name (&/|first ctor-arg))]])))
- (.visitMethodInsn Opcodes/INVOKESPECIAL (&host-generics/->bytecode-class-name (&host-generics/super-class-name super-class)) init-method-name (str "(" ctor-arg-types ")V"))
- (.visitInsn Opcodes/RETURN))))
-
-(defn ^:private compile-dummy-method [^ClassWriter =class real-name store-name super-class method-def]
- (|case method-def
- (&/$ConstructorMethodSyntax =privacy-modifier ?strict =anns =gvars =exceptions =inputs =ctor-args body)
- (|let [=output (&/$GenericClass "void" (&/|list))
- method-decl [init-method-name =anns =gvars (&/|map (partial ->dummy-type real-name store-name) =exceptions) (&/|map (comp (partial ->dummy-type real-name store-name) &/|second) =inputs) (->dummy-type real-name store-name =output)]
- [simple-signature generic-signature] (&host-generics/method-signatures method-decl)]
- (doto (.visitMethod =class Opcodes/ACC_PUBLIC
- init-method-name
- simple-signature
- generic-signature
- (->> =exceptions (&/|map &host-generics/gclass->bytecode-class-name) &/->seq (into-array java.lang.String)))
- .visitCode
- (dummy-ctor real-name store-name super-class =ctor-args)
- (.visitMaxs 0 0)
- (.visitEnd)))
-
- (&/$VirtualMethodSyntax =name =privacy-modifier =final? ?strict =anns =gvars =exceptions =inputs =output body)
- (|let [method-decl [=name =anns =gvars (&/|map (partial ->dummy-type real-name store-name) =exceptions) (&/|map (comp (partial ->dummy-type real-name store-name) &/|second) =inputs) (->dummy-type real-name store-name =output)]
- [simple-signature generic-signature] (&host-generics/method-signatures method-decl)]
- (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC
- (if =final? Opcodes/ACC_FINAL 0))
- =name
- simple-signature
- generic-signature
- (->> =exceptions (&/|map &host-generics/gclass->bytecode-class-name) &/->seq (into-array java.lang.String)))
- .visitCode
- (dummy-return =output)
- (.visitMaxs 0 0)
- (.visitEnd)))
-
- (&/$OverridenMethodSyntax =class-decl =name ?strict =anns =gvars =exceptions =inputs =output body)
- (|let [method-decl [=name =anns =gvars (&/|map (partial ->dummy-type real-name store-name) =exceptions) (&/|map (comp (partial ->dummy-type real-name store-name) &/|second) =inputs) (->dummy-type real-name store-name =output)]
- [simple-signature generic-signature] (&host-generics/method-signatures method-decl)]
- (doto (.visitMethod =class Opcodes/ACC_PUBLIC
- =name
- simple-signature
- generic-signature
- (->> =exceptions (&/|map &host-generics/gclass->bytecode-class-name) &/->seq (into-array java.lang.String)))
- .visitCode
- (dummy-return =output)
- (.visitMaxs 0 0)
- (.visitEnd)))
-
- (&/$StaticMethodSyntax =name =privacy-modifier ?strict =anns =gvars =exceptions =inputs =output body)
- (|let [method-decl [=name =anns =gvars (&/|map (partial ->dummy-type real-name store-name) =exceptions) (&/|map (comp (partial ->dummy-type real-name store-name) &/|second) =inputs) (->dummy-type real-name store-name =output)]
- [simple-signature generic-signature] (&host-generics/method-signatures method-decl)]
- (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC)
- =name
- simple-signature
- generic-signature
- (->> =exceptions (&/|map &host-generics/gclass->bytecode-class-name) &/->seq (into-array java.lang.String)))
- .visitCode
- (dummy-return =output)
- (.visitMaxs 0 0)
- (.visitEnd)))
-
- (&/$AbstractMethodSyntax =name =privacy-modifier =anns =gvars =exceptions =inputs =output)
- (|let [method-decl [=name =anns =gvars (&/|map (partial ->dummy-type real-name store-name) =exceptions) (&/|map (comp (partial ->dummy-type real-name store-name) &/|second) =inputs) (->dummy-type real-name store-name =output)]
- [simple-signature generic-signature] (&host-generics/method-signatures method-decl)]
- (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_ABSTRACT)
- =name
- simple-signature
- generic-signature
- (->> =exceptions (&/|map &host-generics/gclass->bytecode-class-name) &/->seq (into-array java.lang.String)))
- (.visitEnd)))
-
- (&/$NativeMethodSyntax =name =privacy-modifier =anns =gvars =exceptions =inputs =output)
- (|let [method-decl [=name =anns =gvars (&/|map (partial ->dummy-type real-name store-name) =exceptions) (&/|map (comp (partial ->dummy-type real-name store-name) &/|second) =inputs) (->dummy-type real-name store-name =output)]
- [simple-signature generic-signature] (&host-generics/method-signatures method-decl)]
- (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_NATIVE)
- =name
- simple-signature
- generic-signature
- (->> =exceptions (&/|map &host-generics/gclass->bytecode-class-name) &/->seq (into-array java.lang.String)))
- (.visitEnd)))
-
- _
- (assert false (println-str 'compile-dummy-method (&/adt->text method-def)))
- ))
-
-(defn privacy-modifier->flag [privacy-modifier]
- "(-> PrivacyModifier Int)"
- (|case privacy-modifier
- (&/$PublicPM) Opcodes/ACC_PUBLIC
- (&/$PrivatePM) Opcodes/ACC_PRIVATE
- (&/$ProtectedPM) Opcodes/ACC_PROTECTED
- (&/$DefaultPM) 0
- ))
-
-(defn state-modifier->flag [state-modifier]
- "(-> StateModifier Int)"
- (|case state-modifier
- (&/$DefaultSM) 0
- (&/$VolatileSM) Opcodes/ACC_VOLATILE
- (&/$FinalSM) Opcodes/ACC_FINAL))
-
-(defn inheritance-modifier->flag [inheritance-modifier]
- "(-> InheritanceModifier Int)"
- (|case inheritance-modifier
- (&/$DefaultIM) 0
- (&/$AbstractIM) Opcodes/ACC_ABSTRACT
- (&/$FinalIM) Opcodes/ACC_FINAL))
-
-(defn use-dummy-class [class-decl super-class interfaces ctor-args fields methods]
- (|do [module &/get-module-name
- :let [[?name ?params] class-decl
- dummy-name ?name;; (str ?name "__DUMMY__")
- dummy-full-name (str module "/" dummy-name)
- real-name (str (&host-generics/->class-name module) "." ?name)
- store-name (str (&host-generics/->class-name module) "." dummy-name)
- class-signature (&host-generics/gclass-decl->signature class-decl (&/$Cons super-class interfaces))
- =class (doto (new ClassWriter ClassWriter/COMPUTE_MAXS)
- (.visit bytecode-version (+ Opcodes/ACC_PUBLIC Opcodes/ACC_SUPER)
- dummy-full-name
- (if (= "" class-signature) nil class-signature)
- (&host-generics/->bytecode-class-name (&host-generics/super-class-name super-class))
- (->> interfaces (&/|map (comp &host-generics/->bytecode-class-name &host-generics/super-class-name)) &/->seq (into-array String))))
- _ (&/|map (fn [field]
- (|case field
- (&/$ConstantFieldAnalysis =name =anns =type ?value)
- (doto (.visitField =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC Opcodes/ACC_FINAL) =name
- (&host-generics/gclass->simple-signature =type)
- (&host-generics/gclass->signature =type)
- nil)
- (.visitEnd))
-
- (&/$VariableFieldAnalysis =name =privacy-modifier =state-modifier =anns =type)
- (doto (.visitField =class (+ Opcodes/ACC_PUBLIC (state-modifier->flag =state-modifier)) =name
- (&host-generics/gclass->simple-signature =type)
- (&host-generics/gclass->signature =type)
- nil)
- (.visitEnd))
- ))
- fields)
- _ (&/|map (partial compile-dummy-method =class real-name store-name super-class) methods)
- bytecode (.toByteArray (doto =class .visitEnd))]
- ^ClassLoader loader &/loader
- !classes &/classes
- :let [_ (swap! !classes assoc store-name bytecode)
- _ (.loadClass loader store-name)]
- _ (&/push-dummy-name real-name store-name)]
- (return nil)))
diff --git a/src/lux/host/generics.clj b/src/lux/host/generics.clj
deleted file mode 100644
index cfd0d2d54..000000000
--- a/src/lux/host/generics.clj
+++ /dev/null
@@ -1,205 +0,0 @@
-;; Copyright (c) Eduardo Julian. All rights reserved.
-;; This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0.
-;; If a copy of the MPL was not distributed with this file,
-;; You can obtain one at http://mozilla.org/MPL/2.0/.
-
-(ns lux.host.generics
- (:require (clojure [string :as string]
- [template :refer [do-template]])
- clojure.core.match
- clojure.core.match.array
- (lux [base :as & :refer [|do return* return fail fail* |let |case]]))
- (:import java.util.regex.Pattern))
-
-(declare gclass->signature)
-
-(do-template [<name> <old-sep> <new-sep>]
- (let [regex (-> <old-sep> Pattern/quote re-pattern)]
- (defn <name> [old]
- (string/replace old regex <new-sep>)))
-
- ;; ->class
- ^String ->bytecode-class-name "." "/"
- ;; ->class-name
- ^String ->class-name "/" "."
- )
-
-;; ->type-signature
-(defn ->type-signature [class]
- (case class
- "void" "V"
- "boolean" "Z"
- "byte" "B"
- "short" "S"
- "int" "I"
- "long" "J"
- "float" "F"
- "double" "D"
- "char" "C"
- ;; else
- (let [class* (->bytecode-class-name class)]
- (if (.startsWith class* "[")
- class*
- (str "L" class* ";")))
- ))
-
-(defn super-class-name [super]
- "(-> GenericSuperClassDecl Text)"
- (|let [[super-name super-params] super]
- super-name))
-
-(defn formal-type-parameter->signature [param]
- (|let [[pname pbounds] param]
- (|case pbounds
- (&/$Nil)
- pname
-
- _
- (->> pbounds
- (&/|map (fn [pbound] (str ": " (gclass->signature pbound))))
- (&/|interpose " ")
- (str pname " "))
- )))
-
-(defn formal-type-parameters->signature [params]
- (if (&/|empty? params)
- ""
- (str "<" (->> params (&/|map formal-type-parameter->signature) (&/|interpose " ") (&/fold str "")) ">")))
-
-(defn gclass->signature [super]
- "(-> GenericClass Text)"
- (|case super
- (&/$GenericTypeVar name)
- (str "T" name ";")
-
- (&/$GenericWildcard (&/$None))
- "*"
-
- (&/$GenericWildcard (&/$Some [(&/$UpperBound) ?bound]))
- (str "+" (gclass->signature ?bound))
-
- (&/$GenericWildcard (&/$Some [(&/$LowerBound) ?bound]))
- (str "-" (gclass->signature ?bound))
-
- (&/$GenericClass ^String name params)
- (case name
- "void" "V"
- "boolean" "Z"
- "byte" "B"
- "short" "S"
- "int" "I"
- "long" "J"
- "float" "F"
- "double" "D"
- "char" "C"
- ;; else
- (if (.startsWith name "[")
- name
- (let [params* (if (&/|empty? params)
- ""
- (str "<" (->> params (&/|map gclass->signature) (&/|interpose "") (&/fold str "")) ">"))]
- (str "L" (->bytecode-class-name name) params* ";"))))
-
- (&/$GenericArray param)
- (str "[" (gclass->signature param))))
-
-(defn gsuper-decl->signature [super]
- "(-> GenericSuperClassDecl Text)"
- (|let [[super-name super-params] super
- params* (if (&/|empty? super-params)
- ""
- (str "<" (->> super-params (&/|map gclass->signature) (&/|interpose " ") (&/fold str "")) ">"))]
- (str "L" (->bytecode-class-name super-name) params* ";")))
-
-(defn gclass-decl->signature [class-decl supers]
- "(-> GenericClassDecl (List GenericSuperClassDecl) Text)"
- (|let [[class-name class-vars] class-decl
- vars-section (formal-type-parameters->signature class-vars)
- super-section (->> (&/|map gsuper-decl->signature supers) (&/|interpose " ") (&/fold str ""))]
- (str vars-section super-section)))
-
-(let [object-simple-signature (->type-signature "java.lang.Object")]
- (defn gclass->simple-signature [gclass]
- "(-> GenericClass Text)"
- (|case gclass
- (&/$GenericTypeVar name)
- object-simple-signature
-
- (&/$GenericWildcard _)
- object-simple-signature
-
- (&/$GenericClass name params)
- (->type-signature name)
-
- (&/$GenericArray param)
- (str "[" (gclass->simple-signature param))
-
- _
- (assert false (str 'gclass->simple-signature " " (&/adt->text gclass))))))
-
-(defn gclass->class-name [gclass]
- "(-> GenericClass Text)"
- (|case gclass
- (&/$GenericTypeVar name)
- (->bytecode-class-name "java.lang.Object")
-
- (&/$GenericWildcard _)
- (->bytecode-class-name "java.lang.Object")
-
- (&/$GenericClass name params)
- (->bytecode-class-name name)
-
- (&/$GenericArray param)
- (str "[" (gclass->class-name param))
-
- _
- (assert false (str 'gclass->class-name " " (&/adt->text gclass)))))
-
-(let [object-bc-name (->bytecode-class-name "java.lang.Object")]
- (defn gclass->bytecode-class-name* [gclass type-env]
- "(-> GenericClass Text)"
- (|case gclass
- (&/$GenericTypeVar name)
- object-bc-name
-
- (&/$GenericWildcard _)
- object-bc-name
-
- (&/$GenericClass name params)
- ;; When referring to type-parameters during class or method
- ;; definition, a type-environment is set for storing the names
- ;; of such parameters.
- ;; When a "class" shows up with the name of one of those
- ;; parameters, it must be detected, and the bytecode class-name
- ;; must correspond to Object's.
- (if (&/|get name type-env)
- object-bc-name
- (->bytecode-class-name name))
-
- (&/$GenericArray param)
- (assert false "gclass->bytecode-class-name* doesn't work on arrays."))))
-
-(let [object-bc-name (->bytecode-class-name "java.lang.Object")]
- (defn gclass->bytecode-class-name [gclass]
- "(-> GenericClass Text)"
- (|case gclass
- (&/$GenericTypeVar name)
- object-bc-name
-
- (&/$GenericWildcard _)
- object-bc-name
-
- (&/$GenericClass name params)
- (->bytecode-class-name name)
-
- (&/$GenericArray param)
- (assert false "gclass->bytecode-class-name doesn't work on arrays."))))
-
-(defn method-signatures [method-decl]
- (|let [[=name =anns =gvars =exceptions =inputs =output] method-decl
- simple-signature (str "(" (&/fold str "" (&/|map gclass->simple-signature =inputs)) ")" (gclass->simple-signature =output))
- generic-signature (str (formal-type-parameters->signature =gvars)
- "(" (&/fold str "" (&/|map gclass->signature =inputs)) ")"
- (gclass->signature =output)
- (->> =exceptions (&/|map gclass->signature) (&/|interpose " ") (&/fold str "")))]
- (&/T [simple-signature generic-signature])))
diff --git a/src/lux/lexer.clj b/src/lux/lexer.clj
deleted file mode 100644
index f519aa563..000000000
--- a/src/lux/lexer.clj
+++ /dev/null
@@ -1,254 +0,0 @@
-;; Copyright (c) Eduardo Julian. All rights reserved.
-;; This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0.
-;; If a copy of the MPL was not distributed with this file,
-;; You can obtain one at http://mozilla.org/MPL/2.0/.
-
-(ns lux.lexer
- (:require (clojure [template :refer [do-template]]
- [string :as string])
- (lux [base :as & :refer [defvariant |do return* return fail fail* |case]]
- [reader :as &reader])
- [lux.analyser.module :as &module]))
-
-;; [Tags]
-(defvariant
- ("White_Space" 1)
- ("Comment" 1)
- ("Bool" 1)
- ("Nat" 1)
- ("Int" 1)
- ("Frac" 1)
- ("Real" 1)
- ("Char" 1)
- ("Text" 1)
- ("Symbol" 1)
- ("Tag" 1)
- ("Open_Paren" 0)
- ("Close_Paren" 0)
- ("Open_Bracket" 0)
- ("Close_Bracket" 0)
- ("Open_Brace" 0)
- ("Close_Brace" 0)
- )
-
-;; [Utils]
-(defn ^:private escape-char [escaped]
- "(-> Text (Lux Text))"
- (cond (.equals ^Object escaped "\\t") (return "\t")
- (.equals ^Object escaped "\\b") (return "\b")
- (.equals ^Object escaped "\\n") (return "\n")
- (.equals ^Object escaped "\\r") (return "\r")
- (.equals ^Object escaped "\\f") (return "\f")
- (.equals ^Object escaped "\\\"") (return "\"")
- (.equals ^Object escaped "\\\\") (return "\\")
- :else
- (&/fail-with-loc (str "[Lexer Error] Unknown escape character: " escaped))))
-
-(defn ^:private escape-char* [escaped]
- "(-> Text Text)"
- (cond (.equals ^Object escaped "\\t") "\t"
- (.equals ^Object escaped "\\b") "\b"
- (.equals ^Object escaped "\\n") "\n"
- (.equals ^Object escaped "\\r") "\r"
- (.equals ^Object escaped "\\f") "\f"
- (.equals ^Object escaped "\\\"") "\""
- (.equals ^Object escaped "\\\\") "\\"
- :else
- (assert false (str "[Lexer Error] Unknown escape character: " escaped))))
-
-(defn ^:private clean-line [^String raw-line]
- "(-> Text Text)"
- (let [line-length (.length raw-line)
- buffer (new StringBuffer line-length)]
- (loop [idx 0]
- (if (< idx line-length)
- (let [current-char (.charAt raw-line idx)]
- (if (= \\ current-char)
- (do (assert (< (+ 1 idx) line-length) (str "[Lexer Error] Text is too short for escaping: " raw-line " " idx))
- (case (.charAt raw-line (+ 1 idx))
- \t (do (.append buffer "\t")
- (recur (+ 2 idx)))
- \b (do (.append buffer "\b")
- (recur (+ 2 idx)))
- \n (do (.append buffer "\n")
- (recur (+ 2 idx)))
- \r (do (.append buffer "\r")
- (recur (+ 2 idx)))
- \f (do (.append buffer "\f")
- (recur (+ 2 idx)))
- \" (do (.append buffer "\"")
- (recur (+ 2 idx)))
- \\ (do (.append buffer "\\")
- (recur (+ 2 idx)))
- \u (do (assert (< (+ 5 idx) line-length) (str "[Lexer Error] Text is too short for unicode-escaping: " raw-line " " idx))
- (.append buffer (char (Integer/valueOf (.substring raw-line (+ 2 idx) (+ 6 idx)) 16)))
- (recur (+ 6 idx)))
- ;; else
- (assert false (str "[Lexer Error] Invalid escaping syntax: " raw-line " " idx))))
- (do (.append buffer current-char)
- (recur (+ 1 idx)))))
- (.toString buffer)))))
-
-(defn ^:private lex-text-body [multi-line? offset]
- (|do [[_ eol? ^String pre-quotes**] (&reader/read-regex #"^([^\"]*)")
- ^String pre-quotes* (if multi-line?
- (|do [:let [empty-line? (and eol? (= "" pre-quotes**))]
- _ (&/assert! (or empty-line?
- (>= (.length pre-quotes**) offset))
- "Each line of a multi-line text must have an appropriate offset!")]
- (return (if empty-line?
- "\n"
- (str "\n" (.substring pre-quotes** offset)))))
- (return pre-quotes**))
- [pre-quotes post-quotes] (if (.endsWith pre-quotes* "\\")
- (if eol?
- (&/fail-with-loc "[Lexer Error] Can't leave dangling back-slash \\")
- (if (if-let [^String back-slashes (re-find #"\\+$" pre-quotes*)]
- (odd? (.length back-slashes)))
- (|do [[_ eol?* _] (&reader/read-regex #"^([\"])")
- next-part (lex-text-body eol?* offset)]
- (return (&/T [(.substring pre-quotes* 0 (dec (.length pre-quotes*)))
- (str "\"" next-part)])))
- (|do [post-quotes* (lex-text-body false offset)]
- (return (&/T [pre-quotes* post-quotes*])))))
- (if eol?
- (|do [next-part (lex-text-body true offset)]
- (return (&/T [pre-quotes*
- next-part])))
- (return (&/T [pre-quotes* ""]))))]
- (return (str (clean-line pre-quotes) post-quotes))))
-
-(def lex-text
- (|do [[meta _ _] (&reader/read-text "\"")
- :let [[_ _ _column] meta]
- token (lex-text-body false (inc _column))
- _ (&reader/read-text "\"")]
- (return (&/T [meta ($Text token)]))))
-
-(def +ident-re+
- #"^([^0-9\[\]\{\}\(\)\s\"#;][^\[\]\{\}\(\)\s\"#;]*)")
-
-;; [Lexers]
-(def ^:private lex-white-space
- (|do [[meta _ white-space] (&reader/read-regex #"^(\s+|$)")]
- (return (&/T [meta ($White_Space white-space)]))))
-
-(def ^:private lex-single-line-comment
- (|do [_ (&reader/read-text "##")
- [meta _ comment] (&reader/read-regex #"^(.*)$")]
- (return (&/T [meta ($Comment comment)]))))
-
-(defn ^:private lex-multi-line-comment [_]
- (|do [_ (&reader/read-text "#(")
- [meta comment] (&/try-all% (&/|list (|do [[meta comment] (&reader/read-regex+ #"(?is)^(?!#\()((?!\)#).)*")]
- (return (&/T [meta comment])))
- (|do [[meta pre] (&reader/read-regex+ #"(?is)^((?!#\().)*")
- [_ ($Comment inner)] (lex-multi-line-comment nil)
- [_ post] (&reader/read-regex+ #"(?is)^((?!\)#).)*")]
- (return (&/T [meta (str pre "#(" inner ")#" post)])))))
- _ (&reader/read-text ")#")]
- (return (&/T [meta ($Comment comment)]))))
-
-(def ^:private lex-comment
- (&/try-all% (&/|list lex-single-line-comment
- (lex-multi-line-comment nil))))
-
-(do-template [<name> <tag> <regex>]
- (def <name>
- (|do [[meta _ token] (&reader/read-regex <regex>)]
- (return (&/T [meta (<tag> token)]))))
-
- lex-bool $Bool #"^(true|false)"
- )
-
-(do-template [<name> <tag> <regex>]
- (def <name>
- (|do [[meta _ token] (&reader/read-regex <regex>)]
- (return (&/T [meta (<tag> (string/replace token #",|_" ""))]))))
-
- lex-nat $Nat #"^\+(0|[1-9][0-9,_]*)"
- lex-int $Int #"^-?(0|[1-9][0-9,_]*)"
- lex-frac $Frac #"^(\.[0-9,_]+)"
- lex-real $Real #"^-?(0\.[0-9,_]+|[1-9][0-9,_]*\.[0-9,_]+)(e-?[1-9][0-9,_]*)?"
- )
-
-(def lex-char
- (|do [[meta _ _] (&reader/read-text "#\"")
- token (&/try-all% (&/|list (|do [[_ _ escaped] (&reader/read-regex #"^(\\.)")]
- (escape-char escaped))
- (|do [[_ _ ^String unicode] (&reader/read-regex #"^(\\u[0-9a-fA-F]{4})")]
- (return (str (char (Integer/valueOf (.substring unicode 2) 16)))))
- (|do [[_ _ char] (&reader/read-regex #"^(.)")]
- (return char))))
- _ (&reader/read-text "\"")]
- (return (&/T [meta ($Char token)]))))
-
-(def ^:private lex-ident
- (&/try-all-% "[Reader Error]"
- (&/|list (|do [[meta _ token] (&reader/read-regex +ident-re+)
- [_ _ got-it?] (&reader/read-text? ";")]
- (|case got-it?
- (&/$Some _)
- (|do [[_ _ local-token] (&reader/read-regex +ident-re+)
- ? (&module/exists? token)]
- (if ?
- (return (&/T [meta (&/T [token local-token])]))
- (|do [unaliased (&module/dealias token)]
- (return (&/T [meta (&/T [unaliased local-token])])))))
-
- (&/$None)
- (return (&/T [meta (&/T ["" token])]))))
- (|do [[meta _ _] (&reader/read-text ";;")
- [_ _ token] (&reader/read-regex +ident-re+)
- module-name &/get-module-name]
- (return (&/T [meta (&/T [module-name token])])))
- (|do [[meta _ _] (&reader/read-text ";")
- [_ _ token] (&reader/read-regex +ident-re+)]
- (return (&/T [meta (&/T ["lux" token])])))
- )))
-
-(def ^:private lex-symbol
- (|do [[meta ident] lex-ident]
- (return (&/T [meta ($Symbol ident)]))))
-
-(def ^:private lex-tag
- (|do [[meta _ _] (&reader/read-text "#")
- [_ ident] lex-ident]
- (return (&/T [meta ($Tag ident)]))))
-
-(do-template [<name> <text> <tag>]
- (def <name>
- (|do [[meta _ _] (&reader/read-text <text>)]
- (return (&/T [meta <tag>]))))
-
- ^:private lex-open-paren "(" $Open_Paren
- ^:private lex-close-paren ")" $Close_Paren
- ^:private lex-open-bracket "[" $Open_Bracket
- ^:private lex-close-bracket "]" $Close_Bracket
- ^:private lex-open-brace "{" $Open_Brace
- ^:private lex-close-brace "}" $Close_Brace
- )
-
-(def ^:private lex-delimiter
- (&/try-all% (&/|list lex-open-paren
- lex-close-paren
- lex-open-bracket
- lex-close-bracket
- lex-open-brace
- lex-close-brace)))
-
-;; [Exports]
-(def lex
- (&/try-all-% "[Reader Error]"
- (&/|list lex-white-space
- lex-comment
- lex-bool
- lex-nat
- lex-real
- lex-frac
- lex-int
- lex-char
- lex-text
- lex-symbol
- lex-tag
- lex-delimiter)))
diff --git a/src/lux/lib/loader.clj b/src/lux/lib/loader.clj
deleted file mode 100644
index e8310f9f0..000000000
--- a/src/lux/lib/loader.clj
+++ /dev/null
@@ -1,54 +0,0 @@
-;; Copyright (c) Eduardo Julian. All rights reserved.
-;; This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0.
-;; If a copy of the MPL was not distributed with this file,
-;; You can obtain one at http://mozilla.org/MPL/2.0/.
-
-(ns lux.lib.loader
- (:refer-clojure :exclude [load])
- (:require (lux [base :as & :refer [|let |do return fail return* fail* |case]]))
- (:import (java.io InputStream
- File
- FileInputStream
- ByteArrayInputStream
- ByteArrayOutputStream)
- java.util.jar.JarInputStream))
-
-;; [Utils]
-(defn ^:private fetch-libs []
- (->> ^java.net.URLClassLoader (ClassLoader/getSystemClassLoader)
- (.getURLs)
- seq
- (map #(.getFile ^java.net.URL %))
- (filter #(.endsWith ^String % ".jar"))
- (map #(new File ^String %))))
-
-(let [init-capacity (* 100 1024)
- buffer-size 1024]
- (defn ^:private ^"[B" read-stream [^InputStream is]
- (let [buffer (byte-array buffer-size)]
- (with-open [os (new ByteArrayOutputStream init-capacity)]
- (loop [bytes-read (.read is buffer 0 buffer-size)]
- (when (not= -1 bytes-read)
- (do (.write os buffer 0 bytes-read)
- (recur (.read is buffer 0 buffer-size)))))
- (.toByteArray os)))))
-
-(defn ^:private unpackage [^File lib-file]
- (let [is (->> lib-file
- (new FileInputStream)
- (new JarInputStream))]
- (loop [lib-data {}
- entry (.getNextJarEntry is)]
- (if entry
- (if (.endsWith (.getName entry) ".lux")
- (recur (assoc lib-data (.getName entry) (new String (read-stream is)))
- (.getNextJarEntry is))
- (recur lib-data
- (.getNextJarEntry is)))
- lib-data))))
-
-;; [Exports]
-(defn load []
- (->> (fetch-libs)
- (map unpackage)
- (reduce merge {})))
diff --git a/src/lux/optimizer.clj b/src/lux/optimizer.clj
deleted file mode 100644
index 5c30dc44f..000000000
--- a/src/lux/optimizer.clj
+++ /dev/null
@@ -1,1202 +0,0 @@
-;; Copyright (c) Eduardo Julian. All rights reserved.
-;; This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0.
-;; If a copy of the MPL was not distributed with this file,
-;; You can obtain one at http://mozilla.org/MPL/2.0/.
-(ns lux.optimizer
- (:require (lux [base :as & :refer [|let |do return fail return* fail* |case defvariant]])
- (lux.analyser [base :as &a]
- [case :as &a-case])))
-
-;; [Tags]
-(defvariant
- ;; These tags just have a one-to-one correspondence with Analysis data-structures.
- ("bool" 1)
- ("nat" 1)
- ("int" 1)
- ("frac" 1)
- ("real" 1)
- ("char" 1)
- ("text" 1)
- ("variant" 3)
- ("tuple" 1)
- ("apply" 2)
- ("case" 2)
- ("function" 5)
- ("ann" 2)
- ("var" 1)
- ("captured" 3)
- ("proc" 3)
-
- ;; These other tags represent higher-order constructs that manifest
- ;; themselves as patterns in the code.
- ;; Lux doesn't formally provide these features, but some macros
- ;; expose ways to implement them in terms of the other (primitive)
- ;; features.
- ;; The optimizer looks for those usage patterns and transforms them
- ;; into explicit constructs, which are then subject to specialized optimizations.
-
- ;; Loop scope, for doing loop inlining
- ("loop" 3) ;; {register-offset Int, inits (List Optimized), body Optimized}
- ;; This is loop iteration, as expected in imperative programming.
- ("iter" 2) ;; {register-offset Int, vals (List Optimized)}
- ;; This is a simple let-expression, as opposed to the more general pattern-matching.
- ("let" 3)
- ;; This is an access to a record's member. It can be multi-level:
- ;; e.g. record.l1.l2.l3
- ;; The record-get token stores the path, for simpler compilation.
- ("record-get" 2)
- ;; Regular, run-of-the-mill if expressions.
- ("if" 3)
- )
-
-;; [Utils]
-
-;; [[Pattern-Matching Traversal Optimization]]
-
-;; This represents an alternative way to view pattern-matching.
-;; The PM that Lux provides has declarative semantics, with the user
-;; specifying how his data is shaped, but not how to traverse it.
-;; The optimizer's PM is operational in nature, and relies on
-;; specifying a path of traversal, with a variety of operations that
-;; can be done along the way.
-;; The algorithm relies on looking at pattern-matching as traversing a
-;; (possibly) branching path, where each step along the path
-;; corresponds to a value, the ends of the path are the jumping-off
-;; points for the bodies of branches, and branching decisions can be
-;; backtracked, if they don't result in a valid jump.
-(defvariant
- ;; Throw away the current data-node (CDN). It's useless.
- ("PopPM" 0)
- ;; Store the CDN in a register.
- ("BindPM" 1)
- ;; Compare the CDN with a boolean value.
- ("BoolPM" 1)
- ;; Compare the CDN with a natural value.
- ("NatPM" 1)
- ;; Compare the CDN with an integer value.
- ("IntPM" 1)
- ;; Compare the CDN with a fractional value.
- ("FracPM" 1)
- ;; Compare the CDN with a real value.
- ("RealPM" 1)
- ;; Compare the CDN with a character value.
- ("CharPM" 1)
- ;; Compare the CDN with a text value.
- ("TextPM" 1)
- ;; Compare the CDN with a variant value. If valid, proceed to test
- ;; the variant's inner value.
- ("VariantPM" 1)
- ;; Access a tuple value at a given index, for further examination.
- ("TuplePM" 1)
- ;; Creates an instance of the backtracking info, as a preparatory
- ;; step to exploring one of the branching paths.
- ("AltPM" 2)
- ;; Allows to test the CDN, while keeping a copy of it for more
- ;; tasting later on.
- ;; If necessary when doing multiple tests on a single value, like
- ;; when testing multiple parts of a tuple.
- ("SeqPM" 2)
- ;; This is the jumping-off point for the PM part, where the PM
- ;; data-structure is thrown away and the program jumps to the
- ;; branch's body.
- ("ExecPM" 1))
-
-(defn de-meta
- "(-> Optimized Optimized)"
- [optim]
- (|let [[meta optim-] optim]
- (|case optim-
- ($variant idx is-last? value)
- ($variant idx is-last? (de-meta value))
-
- ($tuple elems)
- ($tuple (&/|map de-meta elems))
-
- ($case value [_pm _bodies])
- ($case (de-meta value)
- (&/T [_pm (&/|map de-meta _bodies)]))
-
- ($function _register-offset arity scope captured body*)
- ($function _register-offset
- arity
- scope
- (&/|map (fn [capture]
- (|let [[_name [_meta ($captured _scope _idx _source)]] capture]
- (&/T [_name ($captured _scope _idx (de-meta _source))])))
- captured)
- (de-meta body*))
-
- ($ann value-expr type-expr)
- (de-meta value-expr)
-
- ($apply func args)
- ($apply (de-meta func)
- (&/|map de-meta args))
-
- ($captured scope idx source)
- ($captured scope idx (de-meta source))
-
- ($proc proc-ident args special-args)
- ($proc proc-ident (&/|map de-meta args) special-args)
-
- ($loop _register-offset _inits _body)
- ($loop _register-offset
- (&/|map de-meta _inits)
- (de-meta _body))
-
- ($iter _iter-register-offset args)
- ($iter _iter-register-offset
- (&/|map de-meta args))
-
- ($let _value _register _body)
- ($let (de-meta _value)
- _register
- (de-meta _body))
-
- ($record-get _value _path)
- ($record-get (de-meta _value)
- _path)
-
- ($if _test _then _else)
- ($if (de-meta _test)
- (de-meta _then)
- (de-meta _else))
-
- _
- optim-
- )))
-
-;; This function does a simple transformation from the declarative
-;; model of PM of the analyser, to the operational model of PM of the
-;; optimizer.
-;; You may notice that all branches end in PopPM.
-;; The reason is that testing does not immediately imply throwing away
-;; the data to be tested, which is why a popping step must immediately follow.
-(defn ^:private transform-pm* [test]
- (|case test
- (&a-case/$NoTestAC)
- (&/|list $PopPM)
-
- (&a-case/$StoreTestAC _register)
- (&/|list ($BindPM _register))
-
- (&a-case/$BoolTestAC _value)
- (&/|list ($BoolPM _value)
- $PopPM)
-
- (&a-case/$NatTestAC _value)
- (&/|list ($NatPM _value)
- $PopPM)
-
- (&a-case/$IntTestAC _value)
- (&/|list ($IntPM _value)
- $PopPM)
-
- (&a-case/$FracTestAC _value)
- (&/|list ($FracPM _value)
- $PopPM)
-
- (&a-case/$RealTestAC _value)
- (&/|list ($RealPM _value)
- $PopPM)
-
- (&a-case/$CharTestAC _value)
- (&/|list ($CharPM _value)
- $PopPM)
-
- (&a-case/$TextTestAC _value)
- (&/|list ($TextPM _value)
- $PopPM)
-
- (&a-case/$VariantTestAC _idx _num-options _sub-test)
- (&/|++ (&/|list ($VariantPM (if (= _idx (dec _num-options))
- (&/$Right _idx)
- (&/$Left _idx))))
- (&/|++ (transform-pm* _sub-test)
- (&/|list $PopPM)))
-
- (&a-case/$TupleTestAC _sub-tests)
- (|case _sub-tests
- ;; An empty tuple corresponds to unit, which can't be tested in
- ;; any meaningful way, so it's just popped.
- (&/$Nil)
- (&/|list $PopPM)
-
- ;; A tuple of a single element is equivalent to the element
- ;; itself, to the element's PM is generated.
- (&/$Cons _only-test (&/$Nil))
- (transform-pm* _only-test)
-
- ;; Single tuple PM features the tests of each tuple member
- ;; inlined, it's operational equivalent is interleaving the
- ;; access to each tuple member, followed by the testing of said
- ;; member.
- ;; That is way each sequence of access+subtesting gets generated
- ;; and later they all get concatenated.
- _
- (|let [tuple-size (&/|length _sub-tests)]
- (&/|++ (&/flat-map (fn [idx+test*]
- (|let [[idx test*] idx+test*]
- (&/$Cons ($TuplePM (if (< idx (dec tuple-size))
- (&/$Left idx)
- (&/$Right idx)))
- (transform-pm* test*))))
- (&/zip2 (&/|range tuple-size)
- _sub-tests))
- (&/|list $PopPM))))))
-
-;; It will be common for pattern-matching on a very nested
-;; data-structure to require popping all the intermediate
-;; data-structures that were visited once it's all done.
-;; However, the PM infrastructure employs a single data-stack to keep
-;; all data nodes in the trajectory, and that data-stack can just be
-;; thrown again entirely, in just one step.
-;; Because of that, any ending POPs prior to throwing away the
-;; data-stack would be completely useless.
-;; This function cleans them all up, to avoid wasteful computation later.
-(defn ^:private clean-unnecessary-pops [steps]
- (|case steps
- (&/$Cons ($PopPM) _steps)
- (clean-unnecessary-pops _steps)
-
- _
- steps))
-
-;; This transforms a single branch of a PM tree into it's operational
-;; equivalent, while also associating the PM of the branch with the
-;; jump to the branch's body.
-(defn ^:private transform-pm [test body-id]
- (&/fold (fn [right left] ($SeqPM left right))
- ($ExecPM body-id)
- (clean-unnecessary-pops (&/|reverse (transform-pm* test)))))
-
-(defn ^:private pattern->text [pattern]
- (|case pattern
- ($PopPM)
- "$PopPM"
-
- ($BindPM _id)
- (str "($BindPM " _id ")")
-
- ($BoolPM _value)
- (str "($BoolPM " (pr-str _value) ")")
-
- ($NatPM _value)
- (str "($NatPM " (pr-str _value) ")")
-
- ($IntPM _value)
- (str "($IntPM " (pr-str _value) ")")
-
- ($FracPM _value)
- (str "($FracPM " (pr-str _value) ")")
-
- ($RealPM _value)
- (str "($RealPM " (pr-str _value) ")")
-
- ($CharPM _value)
- (str "($CharPM " (pr-str _value) ")")
-
- ($TextPM _value)
- (str "($TextPM " (pr-str _value) ")")
-
- ($TuplePM (&/$Left _idx))
- (str "($TuplePM L" _idx ")")
-
- ($TuplePM (&/$Right _idx))
- (str "($TuplePM R" _idx ")")
-
- ($VariantPM (&/$Left _idx))
- (str "($VariantPM L" _idx ")")
-
- ($VariantPM (&/$Right _idx))
- (str "($VariantPM R" _idx ")")
-
- ($SeqPM _left _right)
- (str "($SeqPM " (pattern->text _left) " " (pattern->text _right) ")")
-
- ($ExecPM _idx)
- (str "($ExecPM " _idx ")")
-
- ;; $AltPM is not considered because it's not supposed to be
- ;; present anywhere at this point in time.
- ))
-
-;; This function fuses together the paths of the PM traversal, adding
-;; branching AltPMs where necessary, and fusing similar paths together
-;; as much as possible, when early parts of them coincide.
-;; The goal is to minimize rework as much as possible by sharing as
-;; much of each path as possible.
-(defn ^:private fuse-pms [pre post]
- (|case (&/T [pre post])
- [($PopPM) ($PopPM)]
- $PopPM
-
- [($BindPM _pre-var-id) ($BindPM _post-var-id)]
- (if (= _pre-var-id _post-var-id)
- ($BindPM _pre-var-id)
- ($AltPM pre post))
-
- [($BoolPM _pre-value) ($BoolPM _post-value)]
- (if (= _pre-value _post-value)
- ($BoolPM _pre-value)
- ($AltPM pre post))
-
- [($NatPM _pre-value) ($NatPM _post-value)]
- (if (= _pre-value _post-value)
- ($NatPM _pre-value)
- ($AltPM pre post))
-
- [($IntPM _pre-value) ($IntPM _post-value)]
- (if (= _pre-value _post-value)
- ($IntPM _pre-value)
- ($AltPM pre post))
-
- [($FracPM _pre-value) ($FracPM _post-value)]
- (if (= _pre-value _post-value)
- ($FracPM _pre-value)
- ($AltPM pre post))
-
- [($RealPM _pre-value) ($RealPM _post-value)]
- (if (= _pre-value _post-value)
- ($RealPM _pre-value)
- ($AltPM pre post))
-
- [($CharPM _pre-value) ($CharPM _post-value)]
- (if (= _pre-value _post-value)
- ($CharPM _pre-value)
- ($AltPM pre post))
-
- [($TextPM _pre-value) ($TextPM _post-value)]
- (if (= _pre-value _post-value)
- ($TextPM _pre-value)
- ($AltPM pre post))
-
- [($TuplePM (&/$Left _pre-idx)) ($TuplePM (&/$Left _post-idx))]
- (if (= _pre-idx _post-idx)
- ($TuplePM (&/$Left _pre-idx))
- ($AltPM pre post))
-
- [($TuplePM (&/$Right _pre-idx)) ($TuplePM (&/$Right _post-idx))]
- (if (= _pre-idx _post-idx)
- ($TuplePM (&/$Right _pre-idx))
- ($AltPM pre post))
-
- [($VariantPM (&/$Left _pre-idx)) ($VariantPM (&/$Left _post-idx))]
- (if (= _pre-idx _post-idx)
- ($VariantPM (&/$Left _pre-idx))
- ($AltPM pre post))
-
- [($VariantPM (&/$Right _pre-idx)) ($VariantPM (&/$Right _post-idx))]
- (if (= _pre-idx _post-idx)
- ($VariantPM (&/$Right _pre-idx))
- ($AltPM pre post))
-
- [($SeqPM _pre-pre _pre-post) ($SeqPM _post-pre _post-post)]
- (|case (fuse-pms _pre-pre _post-pre)
- ($AltPM _ _)
- ($AltPM pre post)
-
- fused-pre
- ($SeqPM fused-pre (fuse-pms _pre-post _post-post)))
-
- _
- ($AltPM pre post)
- ))
-
-(defn ^:private pattern-vars [pattern]
- (|case pattern
- ($BindPM _id)
- (&/|list (&/T [_id false]))
-
- ($SeqPM _left _right)
- (&/|++ (pattern-vars _left) (pattern-vars _right))
-
- _
- (&/|list)
-
- ;; $AltPM is not considered because it's not supposed to be
- ;; present anywhere at this point in time.
- ))
-
-(defn ^:private find-unused-vars [var-table body]
- (|let [[meta body-] body]
- (|case body-
- ($var (&/$Local _idx))
- (&/|update _idx (fn [_] true) var-table)
-
- ($captured _scope _c-idx [_ ($var (&/$Local _idx))])
- (&/|update _idx (fn [_] true) var-table)
-
- ($variant _idx _is-last? _value)
- (find-unused-vars var-table _value)
-
- ($tuple _elems)
- (&/fold find-unused-vars var-table _elems)
-
- ($ann _value-expr _type-expr)
- (find-unused-vars var-table _value-expr)
-
- ($apply _func _args)
- (&/fold find-unused-vars
- (find-unused-vars var-table _func)
- _args)
-
- ($proc _proc-ident _args _special-args)
- (&/fold find-unused-vars var-table _args)
-
- ($loop _register-offset _inits _body)
- (&/|++ (&/fold find-unused-vars var-table _inits)
- (find-unused-vars var-table _body))
-
- ($iter _ _args)
- (&/fold find-unused-vars var-table _args)
-
- ($let _value _register _body)
- (-> var-table
- (find-unused-vars _value)
- (find-unused-vars _body))
-
- ($record-get _value _path)
- (find-unused-vars var-table _value)
-
- ($if _test _then _else)
- (-> var-table
- (find-unused-vars _test)
- (find-unused-vars _then)
- (find-unused-vars _else))
-
- ($case _value [_pm _bodies])
- (&/fold find-unused-vars
- (find-unused-vars var-table _value)
- _bodies)
-
- ($function _ _ _ _captured _)
- (->> _captured
- (&/|map &/|second)
- (&/fold find-unused-vars var-table))
-
- _
- var-table
- )))
-
-(defn ^:private clean-unused-pattern-registers [var-table pattern]
- (|case pattern
- ($BindPM _idx)
- (|let [_new-idx (&/|get _idx var-table)]
- (cond (= _idx _new-idx)
- pattern
-
- (>= _new-idx 0)
- ($BindPM _new-idx)
-
- :else
- $PopPM))
-
- ($SeqPM _left _right)
- ($SeqPM (clean-unused-pattern-registers var-table _left)
- (clean-unused-pattern-registers var-table _right))
-
- _
- pattern
-
- ;; $AltPM is not considered because it's not supposed to be
- ;; present anywhere at this point in time.
- ))
-
-;; This function assumes that the var-table has an ascending index
-;; order.
-;; For example: (2 3 4 5 6 7 8), instead of (8 7 6 5 4 3 2)
-(defn ^:private adjust-register-indexes* [offset var-table]
- (|case var-table
- (&/$Nil)
- (&/|list)
-
- (&/$Cons [_idx _used?] _tail)
- (if _used?
- (&/$Cons (&/T [_idx (- _idx offset)])
- (adjust-register-indexes* offset _tail))
- (&/$Cons (&/T [_idx -1])
- (adjust-register-indexes* (inc offset) _tail))
- )))
-
-(defn ^:private adjust-register-indexes [var-table]
- (adjust-register-indexes* 0 var-table))
-
-(defn ^:private clean-unused-body-registers [var-table body]
- (|let [[meta body-] body]
- (|case body-
- ($var (&/$Local _idx))
- (|let [new-idx (or (&/|get _idx var-table)
- _idx)]
- (&/T [meta ($var (&/$Local new-idx))]))
-
- ($captured _scope _c-idx [_sub-meta ($var (&/$Local _idx))])
- (|let [new-idx (or (&/|get _idx var-table)
- _idx)]
- (&/T [meta ($captured _scope _c-idx (&/T [_sub-meta ($var (&/$Local new-idx))]))]))
-
- ($variant _idx _is-last? _value)
- (&/T [meta ($variant _idx _is-last? (clean-unused-body-registers var-table _value))])
-
- ($tuple _elems)
- (&/T [meta ($tuple (&/|map (partial clean-unused-body-registers var-table)
- _elems))])
-
- ($ann _value-expr _type-expr)
- (&/T [meta ($ann (clean-unused-body-registers var-table _value-expr) _type-expr)])
-
- ($apply _func _args)
- (&/T [meta ($apply (clean-unused-body-registers var-table _func)
- (&/|map (partial clean-unused-body-registers var-table)
- _args))])
-
- ($proc _proc-ident _args _special-args)
- (&/T [meta ($proc _proc-ident
- (&/|map (partial clean-unused-body-registers var-table)
- _args)
- _special-args)])
-
- ($loop _register-offset _inits _body)
- (&/T [meta ($loop _register-offset
- (&/|map (partial clean-unused-body-registers var-table)
- _inits)
- (clean-unused-body-registers var-table _body))])
-
- ($iter _iter-register-offset _args)
- (&/T [meta ($iter _iter-register-offset
- (&/|map (partial clean-unused-body-registers var-table)
- _args))])
-
- ($let _value _register _body)
- (&/T [meta ($let (clean-unused-body-registers var-table _value)
- _register
- (clean-unused-body-registers var-table _body))])
-
- ($record-get _value _path)
- (&/T [meta ($record-get (clean-unused-body-registers var-table _value)
- _path)])
-
- ($if _test _then _else)
- (&/T [meta ($if (clean-unused-body-registers var-table _test)
- (clean-unused-body-registers var-table _then)
- (clean-unused-body-registers var-table _else))])
-
- ($case _value [_pm _bodies])
- (&/T [meta ($case (clean-unused-body-registers var-table _value)
- (&/T [_pm
- (&/|map (partial clean-unused-body-registers var-table)
- _bodies)]))])
-
- ($function _register-offset _arity _scope _captured _body)
- (&/T [meta ($function _register-offset
- _arity
- _scope
- (&/|map (fn [capture]
- (|let [[_name __var] capture]
- (&/T [_name (clean-unused-body-registers var-table __var)])))
- _captured)
- _body)])
-
- _
- body
- )))
-
-(defn ^:private simplify-pattern [pattern]
- (|case pattern
- ($SeqPM ($TuplePM _idx) ($SeqPM ($PopPM) pattern*))
- (simplify-pattern pattern*)
-
- ($SeqPM ($TuplePM _idx) _right)
- (|case (simplify-pattern _right)
- ($SeqPM ($PopPM) pattern*)
- pattern*
-
- _right*
- ($SeqPM ($TuplePM _idx) _right*))
-
- ($SeqPM _left _right)
- ($SeqPM _left (simplify-pattern _right))
-
- _
- pattern))
-
-(defn ^:private optimize-register-use [pattern body]
- (|let [p-vars (pattern-vars pattern)
- p-vars* (find-unused-vars p-vars body)
- adjusted-vars (adjust-register-indexes p-vars*)
- clean-pattern (clean-unused-pattern-registers adjusted-vars pattern)
- simple-pattern (simplify-pattern clean-pattern)
- clean-body (clean-unused-body-registers adjusted-vars body)]
- (&/T [simple-pattern clean-body])))
-
-;; This is the top-level function for optimizing PM, which transforms
-;; each branch and then fuses them together.
-(defn ^:private optimize-pm [branches]
- (|let [;; branches (&/|reverse branches*)
- pms+bodies (&/map2 (fn [branch _body-id]
- (|let [[_pattern _body] branch]
- (optimize-register-use (transform-pm _pattern _body-id)
- _body)))
- branches
- (&/|range (&/|length branches)))
- pms (&/|map &/|first pms+bodies)
- bodies (&/|map &/|second pms+bodies)]
- (|case (&/|reverse pms)
- (&/$Nil)
- (assert false)
-
- (&/$Cons _head-pm _tail-pms)
- (&/T [(&/fold fuse-pms _head-pm _tail-pms)
- bodies])
- )))
-
-;; [[Function-Folding Optimization]]
-
-;; The semantics of Lux establish that all functions are of a single
-;; argument and the multi-argument functions are actually nested
-;; functions being generated and then applied.
-;; This, of course, would generate a lot of waste.
-;; To avoid it, Lux actually folds function definitions together,
-;; thereby creating functions that can be used both
-;; one-argument-at-a-time, and also being called with all, or just a
-;; partial amount of their arguments.
-;; This avoids generating too many artifacts during compilation, since
-;; they get "compressed", and it can also lead to faster execution, by
-;; enabling optimized function calls later.
-
-;; Functions and captured variables have "scopes", which tell which
-;; function they are, or to which function they belong.
-;; During the folding, inner functions dissapear, since their bodies
-;; are merged into their outer "parent" functions.
-;; Their scopes must change accordingy.
-(defn ^:private de-scope
- "(-> Scope Scope Scope Scope)"
- [old-scope new-scope scope]
- (if (identical? new-scope scope)
- old-scope
- scope))
-
-;; Also, it must be noted that when folding functions, the indexes of
-;; the registers have to be changed accodingly.
-;; That is what the following "shifting" functions are for.
-
-;; Shifts the registers for PM operations.
-(defn ^:private shift-pattern [pattern]
- (|case pattern
- ($BindPM _var-id)
- ($BindPM (inc _var-id))
-
- ($SeqPM _left-pm _right-pm)
- ($SeqPM (shift-pattern _left-pm) (shift-pattern _right-pm))
-
- ($AltPM _left-pm _right-pm)
- ($AltPM (shift-pattern _left-pm) (shift-pattern _right-pm))
-
- _
- pattern
- ))
-
-;; Shifts the body of a function after a folding is performed.
-(defn shift-function-body
- "(-> Scope Scope Bool Optimized Optimized)"
- [old-scope new-scope own-body? body]
- (|let [[meta body-] body]
- (|case body-
- ($variant idx is-last? value)
- (&/T [meta ($variant idx is-last? (shift-function-body old-scope new-scope own-body? value))])
-
- ($tuple elems)
- (&/T [meta ($tuple (&/|map (partial shift-function-body old-scope new-scope own-body?) elems))])
-
- ($case value [_pm _bodies])
- (&/T [meta ($case (shift-function-body old-scope new-scope own-body? value)
- (&/T [(if own-body?
- (shift-pattern _pm)
- _pm)
- (&/|map (partial shift-function-body old-scope new-scope own-body?) _bodies)]))])
-
- ($function _register-offset arity scope captured body*)
- (|let [scope* (de-scope old-scope new-scope scope)]
- (&/T [meta ($function _register-offset
- arity
- scope*
- (&/|map (fn [capture]
- (|let [[_name [_meta ($captured _scope _idx _source)]] capture]
- (&/T [_name (&/T [_meta ($captured scope* _idx (shift-function-body old-scope new-scope own-body? _source))])])))
- captured)
- (shift-function-body old-scope new-scope false body*))]))
-
- ($ann value-expr type-expr)
- (&/T [meta ($ann (shift-function-body old-scope new-scope own-body? value-expr)
- type-expr)])
-
- ($var var-kind)
- (if own-body?
- (|case var-kind
- (&/$Local 0)
- (&/T [meta ($apply body
- (&/|list [meta ($var (&/$Local 1))]))])
-
- (&/$Local idx)
- (&/T [meta ($var (&/$Local (inc idx)))])
-
- (&/$Global ?module ?name)
- body)
- body)
-
- ;; This special "apply" rule is for handling recursive calls better.
- ($apply [meta-0 ($var (&/$Local 0))] args)
- (if own-body?
- (&/T [meta ($apply (&/T [meta-0 ($var (&/$Local 0))])
- (&/$Cons (&/T [meta-0 ($var (&/$Local 1))])
- (&/|map (partial shift-function-body old-scope new-scope own-body?) args)))])
- (&/T [meta ($apply (&/T [meta-0 ($var (&/$Local 0))])
- (&/|map (partial shift-function-body old-scope new-scope own-body?) args))]))
-
- ($apply func args)
- (&/T [meta ($apply (shift-function-body old-scope new-scope own-body? func)
- (&/|map (partial shift-function-body old-scope new-scope own-body?) args))])
-
- ($captured scope idx source)
- (if own-body?
- source
- (|case scope
- (&/$Cons _ (&/$Cons _ (&/$Nil)))
- source
-
- _
- (&/T [meta ($captured (de-scope old-scope new-scope scope) idx (shift-function-body old-scope new-scope own-body? source))])))
-
- ($proc proc-ident args special-args)
- (&/T [meta ($proc proc-ident (&/|map (partial shift-function-body old-scope new-scope own-body?) args) special-args)])
-
- ($loop _register-offset _inits _body)
- (&/T [meta ($loop (if own-body?
- (inc _register-offset)
- _register-offset)
- (&/|map (partial shift-function-body old-scope new-scope own-body?)
- _inits)
- (shift-function-body old-scope new-scope own-body? _body))])
-
- ($iter _iter-register-offset args)
- (&/T [meta ($iter (if own-body?
- (inc _iter-register-offset)
- _iter-register-offset)
- (&/|map (partial shift-function-body old-scope new-scope own-body?) args))])
-
- ($let _value _register _body)
- (&/T [meta ($let (shift-function-body old-scope new-scope own-body? _value)
- (if own-body?
- (inc _register)
- _register)
- (shift-function-body old-scope new-scope own-body? _body))])
-
- ($record-get _value _path)
- (&/T [meta ($record-get (shift-function-body old-scope new-scope own-body? _value)
- _path)])
-
- ($if _test _then _else)
- (&/T [meta ($if (shift-function-body old-scope new-scope own-body? _test)
- (shift-function-body old-scope new-scope own-body? _then)
- (shift-function-body old-scope new-scope own-body? _else))])
-
- _
- body
- )))
-
-;; [[Record-Manipulation Optimizations]]
-
-;; If a pattern-matching tree with a single branch is found, and that
-;; branch corresponds to a tuple PM, and the body corresponds to a
-;; local variable, it's likely that the local refers to some member of
-;; the tuple that is being extracted.
-;; That is the pattern that is to be expected of record read-access,
-;; so this function tries to extract the (possibly nested) path
-;; necessary, ending in the data-node of the wanted member.
-(defn ^:private record-read-path
- "(-> (List PM) Idx (List Idx))"
- [pms member-idx]
- (loop [current-idx 0
- pms pms]
- (|case pms
- (&/$Nil)
- &/$None
-
- (&/$Cons _pm _pms)
- (|case _pm
- (&a-case/$NoTestAC)
- (recur (inc current-idx)
- _pms)
-
- (&a-case/$StoreTestAC _register)
- (if (= member-idx _register)
- (&/|list (&/T [current-idx (&/|empty? _pms)]))
- (recur (inc current-idx)
- _pms))
-
- (&a-case/$TupleTestAC _sub-tests)
- (let [sub-path (record-read-path _sub-tests member-idx)]
- (if (not (&/|empty? sub-path))
- (&/$Cons (&/T [current-idx (&/|empty? _pms)]) sub-path)
- (recur (inc current-idx)
- _pms)
- ))
-
- _
- (&/|list))
- )))
-
-;; [[Loop Optimizations]]
-
-;; Lux doesn't offer any looping constructs, relying instead on
-;; recursion.
-;; Some common usages of recursion can be written more efficiently
-;; just using regular loops/iteration.
-;; This optimization looks for tail-calls in the function body,
-;; rewriting them as jumps to the beginning of the function, while
-;; they also updated the necessary local variables for the next iteration.
-(defn ^:private optimize-iter
- "(-> Int Optimized Optimized)"
- [arity optim]
- (|let [[meta optim-] optim]
- (|case optim-
- ($apply [meta-0 ($var (&/$Local 0))] _args)
- (if (= arity (&/|length _args))
- (&/T [meta ($iter 1 _args)])
- optim)
-
- ($case _value [_pattern _bodies])
- (&/T [meta ($case _value
- (&/T [_pattern
- (&/|map (partial optimize-iter arity)
- _bodies)]))])
-
- ($let _value _register _body)
- (&/T [meta ($let _value _register (optimize-iter arity _body))])
-
- ($if _test _then _else)
- (&/T [meta ($if _test
- (optimize-iter arity _then)
- (optimize-iter arity _else))])
-
- ($ann _value-expr _type-expr)
- (&/T [meta ($ann (optimize-iter arity _value-expr) _type-expr)])
-
- _
- optim
- )))
-
-(defn ^:private contains-self-reference?
- "(-> Optimized Bool)"
- [body]
- (|let [[meta body-] body
- stepwise-test (fn [base arg] (or base (contains-self-reference? arg)))]
- (|case body-
- ($variant idx is-last? value)
- (contains-self-reference? value)
-
- ($tuple elems)
- (&/fold stepwise-test false elems)
-
- ($case value [_pm _bodies])
- (or (contains-self-reference? value)
- (&/fold stepwise-test false _bodies))
-
- ($function _ _ _ captured _)
- (->> captured
- (&/|map (fn [capture]
- (|let [[_name [_meta ($captured _scope _idx _source)]] capture]
- _source)))
- (&/fold stepwise-test false))
-
- ($ann value-expr type-expr)
- (contains-self-reference? value-expr)
-
- ($var (&/$Local 0))
- true
-
- ($apply func args)
- (or (contains-self-reference? func)
- (&/fold stepwise-test false args))
-
- ($proc proc-ident args special-args)
- (&/fold stepwise-test false args)
-
- ($loop _register-offset _inits _body)
- (or (&/fold stepwise-test false _inits)
- (contains-self-reference? _body))
-
- ($iter _ args)
- (&/fold stepwise-test false args)
-
- ($let _value _register _body)
- (or (contains-self-reference? _value)
- (contains-self-reference? _body))
-
- ($record-get _value _path)
- (contains-self-reference? _value)
-
- ($if _test _then _else)
- (or (contains-self-reference? _test)
- (contains-self-reference? _then)
- (contains-self-reference? _else))
-
- _
- false
- )))
-
-(defn ^:private pm-loop-transform [register-offset direct? pattern]
- (|case pattern
- ($BindPM _var-id)
- ($BindPM (+ register-offset (if direct?
- (- _var-id 2)
- (- _var-id 1))))
-
- ($SeqPM _left-pm _right-pm)
- ($SeqPM (pm-loop-transform register-offset direct? _left-pm)
- (pm-loop-transform register-offset direct? _right-pm))
-
- ($AltPM _left-pm _right-pm)
- ($AltPM (pm-loop-transform register-offset direct? _left-pm)
- (pm-loop-transform register-offset direct? _right-pm))
-
- _
- pattern
- ))
-
-;; This function must be run STRICTLY before shift-function body, as
-;; the transformation assumes that SFB will be invoke after it.
-(defn ^:private loop-transform [register-offset direct? body]
- (|let [adjust-direct (fn [register]
- ;; The register must be decreased once, since
- ;; it will be re-increased in
- ;; shift-function-body.
- ;; The decrease is meant to keep things stable.
- (if direct?
- ;; And, if this adjustment is done
- ;; directly during a loop-transform (and
- ;; not indirectly if transforming an inner
- ;; loop), then it must be decreased again
- ;; because the 0/self var will no longer
- ;; exist in the loop's context.
- (- register 2)
- (- register 1)))
- [meta body-] body]
- (|case body-
- ($variant idx is-last? value)
- (&/T [meta ($variant idx is-last? (loop-transform register-offset direct? value))])
-
- ($tuple elems)
- (&/T [meta ($tuple (&/|map (partial loop-transform register-offset direct?) elems))])
-
- ($case value [_pm _bodies])
- (&/T [meta ($case (loop-transform register-offset direct? value)
- (&/T [(pm-loop-transform register-offset direct? _pm)
- (&/|map (partial loop-transform register-offset direct?)
- _bodies)]))])
-
- ;; Functions are ignored because they'll be handled properly at shift-function-body
-
- ($ann value-expr type-expr)
- (&/T [meta ($ann (loop-transform register-offset direct? value-expr)
- type-expr)])
-
- ($var (&/$Local idx))
- ;; The index must be decreased once, because the var index is
- ;; 1-based (since 0 is reserved for self-reference).
- ;; Then it must be decreased again, since it will be increased
- ;; in the shift-function-body call.
- ;; Then, I add the offset to ensure the var points to the right register.
- (&/T [meta ($var (&/$Local (-> (adjust-direct idx)
- (+ register-offset))))])
-
- ($apply func args)
- (&/T [meta ($apply (loop-transform register-offset direct? func)
- (&/|map (partial loop-transform register-offset direct?) args))])
-
- ;; Captured-vars are ignored because they'll be handled properly at shift-function-body
-
- ($proc proc-ident args special-args)
- (&/T [meta ($proc proc-ident (&/|map (partial loop-transform register-offset direct?) args) special-args)])
-
- ($loop _register-offset _inits _body)
- (&/T [meta ($loop (+ register-offset (adjust-direct _register-offset))
- (&/|map (partial loop-transform register-offset direct?) _inits)
- (loop-transform register-offset direct? _body))])
-
- ($iter _iter-register-offset args)
- (&/T [meta ($iter (+ register-offset (adjust-direct _iter-register-offset))
- (&/|map (partial loop-transform register-offset direct?) args))])
-
- ($let _value _register _body)
- (&/T [meta ($let (loop-transform register-offset direct? _value)
- (+ register-offset (adjust-direct _register))
- (loop-transform register-offset direct? _body))])
-
- ($record-get _value _path)
- (&/T [meta ($record-get (loop-transform register-offset direct? _value)
- _path)])
-
- ($if _test _then _else)
- (&/T [meta ($if (loop-transform register-offset direct? _test)
- (loop-transform register-offset direct? _then)
- (loop-transform register-offset direct? _else))])
-
- _
- body
- )))
-
-(defn ^:private inline-loop [meta register-offset scope captured args body]
- (->> body
- (loop-transform register-offset true)
- (shift-function-body scope (&/|tail scope) true)
- ($loop register-offset args)
- (list meta)
- (&/T)))
-
-;; [[Initial Optimization]]
-
-;; Before any big optimization can be done, the incoming Analysis nodes
-;; must be transformed into Optimized nodes, amenable to further transformations.
-;; This function does the job, while also detecting (and optimizing)
-;; some simple surface patterns it may encounter.
-(let [optimize-closure (fn [optimize closure]
- (&/|map (fn [capture]
- (|let [[_name _analysis] capture]
- (&/T [_name (optimize _analysis)])))
- closure))]
- (defn ^:private pass-0
- "(-> Bool Analysis Optimized)"
- [top-level-func? analysis]
- (|let [[meta analysis-] analysis]
- (|case analysis-
- (&a/$bool value)
- (&/T [meta ($bool value)])
-
- (&a/$nat value)
- (&/T [meta ($nat value)])
-
- (&a/$int value)
- (&/T [meta ($int value)])
-
- (&a/$frac value)
- (&/T [meta ($frac value)])
-
- (&a/$real value)
- (&/T [meta ($real value)])
-
- (&a/$char value)
- (&/T [meta ($char value)])
-
- (&a/$text value)
- (&/T [meta ($text value)])
-
- (&a/$variant idx is-last? value)
- (&/T [meta ($variant idx is-last? (pass-0 top-level-func? value))])
-
- (&a/$tuple elems)
- (&/T [meta ($tuple (&/|map (partial pass-0 top-level-func?) elems))])
-
- (&a/$apply func args)
- (|let [=func (pass-0 top-level-func? func)
- =args (&/|map (partial pass-0 top-level-func?) args)]
- (|case =func
- [_ ($ann [_ ($function _register-offset _arity _scope _captured _body)]
- _)]
- (if (and (= _arity (&/|length =args))
- (not (contains-self-reference? _body)))
- (inline-loop meta _register-offset _scope _captured =args _body)
- (&/T [meta ($apply =func =args)]))
-
- _
- (&/T [meta ($apply =func =args)])))
-
- (&a/$case value branches)
- (let [normal-case-optim (fn []
- (&/T [meta ($case (pass-0 top-level-func? value)
- (optimize-pm (&/|map (fn [branch]
- (|let [[_pattern _body] branch]
- (&/T [_pattern (pass-0 top-level-func? _body)])))
- branches)))]))]
- (|case branches
- ;; The pattern for a let-expression is a single branch,
- ;; tying the value to a register.
- (&/$Cons [(&a-case/$StoreTestAC _register) _body] (&/$Nil))
- (&/T [meta ($let (pass-0 top-level-func? value) _register (pass-0 top-level-func? _body))])
-
- (&/$Cons [(&a-case/$BoolTestAC false) _else]
- (&/$Cons [(&a-case/$BoolTestAC true) _then]
- (&/$Nil)))
- (&/T [meta ($if (pass-0 top-level-func? value) (pass-0 top-level-func? _then) (pass-0 top-level-func? _else))])
-
- ;; The pattern for a record-get is a single branch, with a
- ;; tuple pattern and a body corresponding to a
- ;; local-variable extracted from the tuple.
- (&/$Cons [(&a-case/$TupleTestAC _sub-tests) [_ (&a/$var (&/$Local _member-idx))]] (&/$Nil))
- (|let [_path (record-read-path _sub-tests _member-idx)]
- (if (&/|empty? _path)
- ;; If the path is empty, that means it was a
- ;; false-positive and normal PM optimization should be
- ;; done instead.
- (normal-case-optim)
- ;; Otherwise, we've got ourselves a record-get expression.
- (&/T [meta ($record-get (pass-0 top-level-func? value) _path)])))
-
- ;; If no special patterns are found, just do normal PM optimization.
- _
- (normal-case-optim)))
-
- (&a/$lambda _register-offset scope captured body)
- (|let [inner-func? (|case body
- [_ (&a/$lambda _ _ _ _)]
- true
-
- _
- false)]
- (|case (pass-0 (not inner-func?) body)
- ;; If the body of a function is another function, that means
- ;; no work was done in-between and both layers can be folded
- ;; into one.
- [_ ($function _ _arity _scope _captured _body)]
- (|let [new-arity (inc _arity)
- collapsed-body (shift-function-body scope _scope true _body)]
- (&/T [meta ($function _register-offset
- new-arity
- scope
- (optimize-closure (partial pass-0 top-level-func?) captured)
- (if top-level-func?
- (optimize-iter new-arity collapsed-body)
- collapsed-body))]))
-
- ;; Otherwise, they're nothing to be done and we've got a
- ;; 1-arity function.
- =body
- (&/T [meta ($function _register-offset
- 1 scope
- (optimize-closure (partial pass-0 top-level-func?) captured)
- (if top-level-func?
- (optimize-iter 1 =body)
- =body))])))
-
- (&a/$ann value-expr type-expr)
- (&/T [meta ($ann (pass-0 top-level-func? value-expr) type-expr)])
-
- (&a/$var var-kind)
- (&/T [meta ($var var-kind)])
-
- (&a/$captured scope idx source)
- (&/T [meta ($captured scope idx (pass-0 top-level-func? source))])
-
- (&a/$proc proc-ident args special-args)
- (&/T [meta ($proc proc-ident (&/|map (partial pass-0 top-level-func?) args) special-args)])
-
- _
- (assert false (prn-str 'pass-0 top-level-func? (&/adt->text analysis)))
- ))))
-
-;; [Exports]
-(defn optimize
- "(-> Analysis Optimized)"
- [analysis]
- (->> analysis
- (pass-0 true)))
diff --git a/src/lux/parser.clj b/src/lux/parser.clj
deleted file mode 100644
index ceafcd92e..000000000
--- a/src/lux/parser.clj
+++ /dev/null
@@ -1,117 +0,0 @@
-;; Copyright (c) Eduardo Julian. All rights reserved.
-;; This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0.
-;; If a copy of the MPL was not distributed with this file,
-;; You can obtain one at http://mozilla.org/MPL/2.0/.
-
-(ns lux.parser
- (:require [clojure.template :refer [do-template]]
- clojure.core.match
- clojure.core.match.array
- (lux [base :as & :refer [|do return |case]]
- [lexer :as &lexer])))
-
-;; [Utils]
-(def ^:private base-uneven-record-error
- "[Parser Error] Records must have an even number of elements.")
-
-(defn ^:private repeat% [action]
- (fn [state]
- (|case (action state)
- (&/$Left ^String error)
- (cond (.contains error base-uneven-record-error)
- (&/$Left error)
-
- (not (.contains error "[Parser Error]"))
- (&/$Left error)
-
- :else
- (&/$Right (&/T [state &/$Nil])))
-
- (&/$Right state* head)
- ((|do [tail (repeat% action)]
- (return (&/$Cons head tail)))
- state*))))
-
-(do-template [<name> <close-tag> <description> <tag>]
- (defn <name> [parse]
- (|do [elems (repeat% parse)
- token &lexer/lex]
- (|case token
- [meta (<close-tag> _)]
- (return (<tag> (&/fold &/|++ &/$Nil elems)))
-
- _
- (&/fail-with-loc (str "[Parser Error] Unbalanced " <description> "."))
- )))
-
- ^:private parse-form &lexer/$Close_Paren "parantheses" &/$FormS
- ^:private parse-tuple &lexer/$Close_Bracket "brackets" &/$TupleS
- )
-
-(defn ^:private parse-record [parse]
- (|do [elems* (repeat% parse)
- token &lexer/lex
- :let [elems (&/fold &/|++ &/$Nil elems*)]]
- (|case token
- [meta (&lexer/$Close_Brace _)]
- (if (even? (&/|length elems))
- (return (&/$RecordS (&/|as-pairs elems)))
- (&/fail-with-loc base-uneven-record-error))
-
- _
- (&/fail-with-loc "[Parser Error] Unbalanced braces.")
- )))
-
-;; [Interface]
-(def parse
- (|do [token &lexer/lex
- :let [[meta token*] token]]
- (|case token*
- (&lexer/$White_Space _)
- (return &/$Nil)
-
- (&lexer/$Comment _)
- (return &/$Nil)
-
- (&lexer/$Bool ?value)
- (return (&/|list (&/T [meta (&/$BoolS (Boolean/parseBoolean ?value))])))
-
- (&lexer/$Nat ?value)
- (return (&/|list (&/T [meta (&/$NatS (Long/parseUnsignedLong ?value))])))
-
- (&lexer/$Int ?value)
- (return (&/|list (&/T [meta (&/$IntS (Long/parseLong ?value))])))
-
- (&lexer/$Frac ?value)
- (return (&/|list (&/T [meta (&/$FracS (&/decode-frac ?value))])))
-
- (&lexer/$Real ?value)
- (return (&/|list (&/T [meta (&/$RealS (Double/parseDouble ?value))])))
-
- (&lexer/$Char ^String ?value)
- (return (&/|list (&/T [meta (&/$CharS (.charAt ?value 0))])))
-
- (&lexer/$Text ?value)
- (return (&/|list (&/T [meta (&/$TextS ?value)])))
-
- (&lexer/$Symbol ?ident)
- (return (&/|list (&/T [meta (&/$SymbolS ?ident)])))
-
- (&lexer/$Tag ?ident)
- (return (&/|list (&/T [meta (&/$TagS ?ident)])))
-
- (&lexer/$Open_Paren _)
- (|do [syntax (parse-form parse)]
- (return (&/|list (&/T [meta syntax]))))
-
- (&lexer/$Open_Bracket _)
- (|do [syntax (parse-tuple parse)]
- (return (&/|list (&/T [meta syntax]))))
-
- (&lexer/$Open_Brace _)
- (|do [syntax (parse-record parse)]
- (return (&/|list (&/T [meta syntax]))))
-
- _
- (&/fail-with-loc "[Parser Error] Unknown lexer token.")
- )))
diff --git a/src/lux/reader.clj b/src/lux/reader.clj
deleted file mode 100644
index 5a7734061..000000000
--- a/src/lux/reader.clj
+++ /dev/null
@@ -1,141 +0,0 @@
-;; Copyright (c) Eduardo Julian. All rights reserved.
-;; This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0.
-;; If a copy of the MPL was not distributed with this file,
-;; You can obtain one at http://mozilla.org/MPL/2.0/.
-
-(ns lux.reader
- (:require [clojure.string :as string]
- clojure.core.match
- clojure.core.match.array
- [lux.base :as & :refer [defvariant |do return* return fail* |let |case]]))
-
-;; [Tags]
-(defvariant
- ("No" 1)
- ("Done" 1)
- ("Yes" 2))
-
-;; [Utils]
-(defn ^:private with-line [body]
- (fn [state]
- (|case (&/get$ &/$source state)
- (&/$Nil)
- (fail* "[Reader Error] EOF")
-
- (&/$Cons [[file-name line-num column-num] line]
- more)
- (|case (body file-name line-num column-num line)
- ($No msg)
- ((&/fail-with-loc msg) state)
-
- ($Done output)
- (return* (&/set$ &/$source more state)
- output)
-
- ($Yes output line*)
- (return* (&/set$ &/$source (&/$Cons line* more) state)
- output))
- )))
-
-(defn ^:private with-lines [body]
- (fn [state]
- (|case (body (&/get$ &/$source state))
- (&/$Right reader* match)
- (return* (&/set$ &/$source reader* state)
- match)
-
- (&/$Left msg)
- ((&/fail-with-loc msg) state)
- )))
-
-(defn ^:private re-find! [^java.util.regex.Pattern regex column ^String line]
- (let [matcher (doto (.matcher regex line)
- (.region column (.length line))
- (.useAnchoringBounds true))]
- (when (.find matcher)
- (.group matcher 0))))
-
-;; [Exports]
-(defn read-regex [regex]
- (with-line
- (fn [file-name line-num column-num ^String line]
- (if-let [^String match (re-find! regex column-num line)]
- (let [match-length (.length match)
- column-num* (+ column-num match-length)]
- (if (= column-num* (.length line))
- ($Done (&/T [(&/T [file-name line-num column-num]) true match]))
- ($Yes (&/T [(&/T [file-name line-num column-num]) false match])
- (&/T [(&/T [file-name line-num column-num*]) line]))))
- ($No (str "[Reader Error] Pattern failed: " regex))))))
-
-(defn read-regex+ [regex]
- (with-lines
- (fn [reader]
- (loop [prefix ""
- reader* reader]
- (|case reader*
- (&/$Nil)
- (&/$Left "[Reader Error] EOF")
-
- (&/$Cons [[file-name line-num column-num] ^String line]
- reader**)
- (if-let [^String match (re-find! regex column-num line)]
- (let [match-length (.length match)
- column-num* (+ column-num match-length)
- prefix* (if (= 0 column-num)
- (str prefix "\n" match)
- (str prefix match))]
- (if (= column-num* (.length line))
- (recur prefix* reader**)
- (&/$Right (&/T [(&/$Cons (&/T [(&/T [file-name line-num column-num*]) line])
- reader**)
- (&/T [(&/T [file-name line-num column-num]) prefix*])]))))
- (&/$Left (str "[Reader Error] Pattern failed: " regex))))))))
-
-(defn read-text [^String text]
- "(-> Text (Reader Text))"
- (with-line
- (fn [file-name line-num column-num ^String line]
- (if (.startsWith line text column-num)
- (let [match-length (.length text)
- column-num* (+ column-num match-length)]
- (if (= column-num* (.length line))
- ($Done (&/T [(&/T [file-name line-num column-num]) true text]))
- ($Yes (&/T [(&/T [file-name line-num column-num]) false text])
- (&/T [(&/T [file-name line-num column-num*]) line]))))
- ($No (str "[Reader Error] Text failed: " text))))))
-
-(defn read-text? [^String text]
- "(-> Text (Reader (Maybe Text)))"
- (with-line
- (fn [file-name line-num column-num ^String line]
- (if (.startsWith line text column-num)
- (let [match-length (.length text)
- column-num* (+ column-num match-length)]
- (if (= column-num* (.length line))
- ($Done (&/T [(&/T [file-name line-num column-num]) true (&/$Some text)]))
- ($Yes (&/T [(&/T [file-name line-num column-num]) false (&/$Some text)])
- (&/T [(&/T [file-name line-num column-num*]) line]))))
- ($Yes (&/T [(&/T [file-name line-num column-num]) false &/$None])
- (&/T [(&/T [file-name line-num column-num]) line]))))))
-
-(defn from [^String name ^String source-code]
- (let [lines (string/split-lines source-code)
- indexed-lines (map (fn [line line-num]
- (&/T [(&/T [name (inc line-num) 0])
- line]))
- lines
- (range (count lines)))]
- (reduce (fn [tail head] (&/$Cons head tail))
- &/$Nil
- (reverse indexed-lines))))
-
-(defn with-source [name content body]
- (fn [state]
- (|let [old-source (&/get$ &/$source state)]
- (|case (body (&/set$ &/$source (from name content) state))
- (&/$Left error)
- (&/$Left error)
-
- (&/$Right state* output)
- (&/$Right (&/T [(&/set$ &/$source old-source state*) output]))))))
diff --git a/src/lux/repl.clj b/src/lux/repl.clj
deleted file mode 100644
index 195f3dc3e..000000000
--- a/src/lux/repl.clj
+++ /dev/null
@@ -1,89 +0,0 @@
-;; Copyright (c) Eduardo Julian. All rights reserved.
-;; This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0.
-;; If a copy of the MPL was not distributed with this file,
-;; You can obtain one at http://mozilla.org/MPL/2.0/.
-
-(ns lux.repl
- (:require clojure.core.match
- clojure.core.match.array
- (lux [base :as & :refer [|let |do return* return fail fail* |case]]
- [type :as &type]
- [analyser :as &analyser]
- [optimizer :as &optimizer]
- [compiler :as &compiler])
- [lux.compiler.cache :as &cache]
- [lux.analyser.base :as &a-base]
- [lux.analyser.lux :as &a-lux]
- [lux.analyser.module :as &module])
- (:import (java.io InputStreamReader
- BufferedReader)))
-
-;; [Utils]
-(def ^:private repl-module "REPL")
-
-(defn ^:private repl-cursor [repl-line]
- (&/T [repl-module repl-line 0]))
-
-(defn ^:private init [source-dirs]
- (do (&compiler/init!)
- (|case ((|do [_ (&compiler/compile-module source-dirs "lux")
- _ (&cache/delete repl-module)
- _ (&module/create-module repl-module 0)
- _ (fn [?state]
- (return* (&/set$ &/$source
- (&/|list (&/T [(repl-cursor -1) "(;import lux)"]))
- ?state)
- nil))
- analysed-tokens (&analyser/repl-analyse &optimizer/optimize &compiler/eval! (partial &compiler/compile-module source-dirs) &compiler/all-compilers)
- eval-values (->> analysed-tokens (&/|map &optimizer/optimize) (&/map% &compiler/eval!))]
- (return nil))
- (&/init-state &/$REPL))
- (&/$Right ?state _)
- (do (println)
- (println "Welcome to the REPL!")
- (println "Type \"exit\" to leave.")
- (println)
- ?state)
-
- (&/$Left ?message)
- (assert false ?message))
- ))
-
-;; [Values]
-(defn repl [source-dirs]
- (with-open [input (->> System/in (new InputStreamReader) (new BufferedReader))]
- (loop [state (init source-dirs)
- repl-line 0
- multi-line? false]
- (let [_ (if (not multi-line?)
- (.print System/out "> ")
- (.print System/out " "))
- line (.readLine input)]
- (if (= "exit" line)
- (println "Till next time...")
- (let [line* (&/|list (&/T [(repl-cursor repl-line) line]))
- state* (&/update$ &/$source
- (fn [_source] (&/|++ _source line*))
- state)]
- (|case ((|do [analysed-tokens (&analyser/repl-analyse &optimizer/optimize &compiler/eval! (partial &compiler/compile-module source-dirs) &compiler/all-compilers)
- eval-values (->> analysed-tokens (&/|map &optimizer/optimize) (&/map% &compiler/eval!))
- :let [outputs (map (fn [analysis value]
- (|let [[[_type _cursor] _term] analysis]
- [_type value]))
- (&/->seq analysed-tokens)
- (&/->seq eval-values))]]
- (return outputs))
- state*)
- (&/$Right state** outputs)
- (do (doseq [[_type _value] outputs]
- (.println System/out (str "=> " (pr-str _value) "\n:: " (&type/show-type _type)"\n")))
- (recur state** (inc repl-line) false))
-
- (&/$Left ^String ?message)
- (if (or (= "[Reader Error] EOF" ?message)
- (.contains ?message "[Parser Error] Unbalanced "))
- (recur state* (inc repl-line) true)
- (do (println ?message)
- (recur state (inc repl-line) false)))
- ))))
- )))
diff --git a/src/lux/type.clj b/src/lux/type.clj
deleted file mode 100644
index d387053dc..000000000
--- a/src/lux/type.clj
+++ /dev/null
@@ -1,972 +0,0 @@
-;; Copyright (c) Eduardo Julian. All rights reserved.
-;; This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0.
-;; If a copy of the MPL was not distributed with this file,
-;; You can obtain one at http://mozilla.org/MPL/2.0/.
-
-(ns lux.type
- (:refer-clojure :exclude [deref apply merge bound?])
- (:require [clojure.template :refer [do-template]]
- clojure.core.match
- clojure.core.match.array
- (lux [base :as & :refer [|do return* return fail fail* assert! |let |case]])
- [lux.type.host :as &&host]))
-
-(declare show-type
- type=)
-
-;; [Utils]
-(defn |list? [xs]
- (|case xs
- (&/$Nil)
- true
-
- (&/$Cons x xs*)
- (|list? xs*)
-
- _
- false))
-
-(def empty-env &/$Nil)
-
-(def Bool (&/$NamedT (&/T ["lux" "Bool"]) (&/$HostT "java.lang.Boolean" &/$Nil)))
-(def Nat (&/$NamedT (&/T ["lux" "Nat"]) (&/$HostT &&host/nat-data-tag &/$Nil)))
-(def Frac (&/$NamedT (&/T ["lux" "Frac"]) (&/$HostT &&host/frac-data-tag &/$Nil)))
-(def Int (&/$NamedT (&/T ["lux" "Int"]) (&/$HostT "java.lang.Long" &/$Nil)))
-(def Real (&/$NamedT (&/T ["lux" "Real"]) (&/$HostT "java.lang.Double" &/$Nil)))
-(def Char (&/$NamedT (&/T ["lux" "Char"]) (&/$HostT "java.lang.Character" &/$Nil)))
-(def Text (&/$NamedT (&/T ["lux" "Text"]) (&/$HostT "java.lang.String" &/$Nil)))
-(def Ident (&/$NamedT (&/T ["lux" "Ident"]) (&/$ProdT Text Text)))
-
-(def Bottom
- (&/$NamedT (&/T ["lux" "Bottom"])
- (&/$UnivQ empty-env
- (&/$BoundT 1))))
-
-(def IO
- (&/$NamedT (&/T ["lux/codata" "IO"])
- (&/$UnivQ empty-env
- (&/$LambdaT &/$VoidT (&/$BoundT 1)))))
-
-(def List
- (&/$NamedT (&/T ["lux" "List"])
- (&/$UnivQ empty-env
- (&/$SumT
- ;; lux;Nil
- &/$UnitT
- ;; lux;Cons
- (&/$ProdT (&/$BoundT 1)
- (&/$AppT (&/$BoundT 0)
- (&/$BoundT 1)))))))
-
-(def Maybe
- (&/$NamedT (&/T ["lux" "Maybe"])
- (&/$UnivQ empty-env
- (&/$SumT
- ;; lux;None
- &/$UnitT
- ;; lux;Some
- (&/$BoundT 1))
- )))
-
-(def Type
- (&/$NamedT (&/T ["lux" "Type"])
- (let [Type (&/$AppT (&/$BoundT 0) (&/$BoundT 1))
- TypeList (&/$AppT List Type)
- TypePair (&/$ProdT Type Type)]
- (&/$AppT (&/$UnivQ empty-env
- (&/$SumT
- ;; HostT
- (&/$ProdT Text TypeList)
- (&/$SumT
- ;; VoidT
- &/$UnitT
- (&/$SumT
- ;; UnitT
- &/$UnitT
- (&/$SumT
- ;; SumT
- TypePair
- (&/$SumT
- ;; ProdT
- TypePair
- (&/$SumT
- ;; LambdaT
- TypePair
- (&/$SumT
- ;; BoundT
- Nat
- (&/$SumT
- ;; VarT
- Nat
- (&/$SumT
- ;; ExT
- Nat
- (&/$SumT
- ;; UnivQ
- (&/$ProdT TypeList Type)
- (&/$SumT
- ;; ExQ
- (&/$ProdT TypeList Type)
- (&/$SumT
- ;; AppT
- TypePair
- ;; NamedT
- (&/$ProdT Ident Type)))))))))))))
- )
- &/$VoidT))))
-
-(def Ann-Value
- (&/$NamedT (&/T ["lux" "Ann-Value"])
- (let [Ann-Value (&/$AppT (&/$BoundT 0) (&/$BoundT 1))]
- (&/$AppT (&/$UnivQ empty-env
- (&/$SumT
- ;; BoolM
- Bool
- (&/$SumT
- ;; NatM
- Nat
- (&/$SumT
- ;; IntM
- Int
- (&/$SumT
- ;; FracM
- Frac
- (&/$SumT
- ;; RealM
- Real
- (&/$SumT
- ;; CharM
- Char
- (&/$SumT
- ;; TextM
- Text
- (&/$SumT
- ;; IdentM
- Ident
- (&/$SumT
- ;; ListM
- (&/$AppT List Ann-Value)
- ;; DictM
- (&/$AppT List (&/$ProdT Text Ann-Value)))))))))))
- )
- &/$VoidT))))
-
-(def Anns
- (&/$NamedT (&/T ["lux" "Anns"])
- (&/$AppT List (&/$ProdT Ident Ann-Value))))
-
-(def Macro)
-
-(defn set-macro-type! [type]
- (def Macro type)
- nil)
-
-(defn bound? [id]
- (fn [state]
- (if-let [type (->> state (&/get$ &/$type-vars) (&/get$ &/$mappings) (&/|get id))]
- (|case type
- (&/$Some type*)
- (return* state true)
-
- (&/$None)
- (return* state false))
- (fail* (str "[Type Error] <bound?> Unknown type-var: " id)))))
-
-(defn deref [id]
- (fn [state]
- (if-let [type* (->> state (&/get$ &/$type-vars) (&/get$ &/$mappings) (&/|get id))]
- (|case type*
- (&/$Some type)
- (return* state type)
-
- (&/$None)
- (fail* (str "[Type Error] Unbound type-var: " id)))
- (fail* (str "[Type Error] <deref> Unknown type-var: " id)))))
-
-(defn deref+ [type]
- (|case type
- (&/$VarT id)
- (deref id)
-
- _
- (fail (str "[Type Error] Type is not a variable: " (show-type type)))
- ))
-
-(defn set-var [id type]
- (fn [state]
- (if-let [tvar (->> state (&/get$ &/$type-vars) (&/get$ &/$mappings) (&/|get id))]
- (|case tvar
- (&/$Some bound)
- (if (type= type bound)
- (return* state nil)
- (fail* (str "[Type Error] Can't re-bind type var: " id " | Current type: " (show-type bound))))
-
- (&/$None)
- (return* (&/update$ &/$type-vars (fn [ts] (&/update$ &/$mappings #(&/|put id (&/$Some type) %)
- ts))
- state)
- nil))
- (fail* (str "[Type Error] <set-var> Unknown type-var: " id " | " (->> state (&/get$ &/$type-vars) (&/get$ &/$mappings) &/|length))))))
-
-(defn reset-var [id type]
- (fn [state]
- (if-let [tvar (->> state (&/get$ &/$type-vars) (&/get$ &/$mappings) (&/|get id))]
- (return* (&/update$ &/$type-vars (fn [ts] (&/update$ &/$mappings #(&/|put id (&/$Some type) %)
- ts))
- state)
- nil)
- (fail* (str "[Type Error] <set-var> Unknown type-var: " id " | " (->> state (&/get$ &/$type-vars) (&/get$ &/$mappings) &/|length))))))
-
-(defn unset-var [id]
- (fn [state]
- (if-let [tvar (->> state (&/get$ &/$type-vars) (&/get$ &/$mappings) (&/|get id))]
- (return* (&/update$ &/$type-vars (fn [ts] (&/update$ &/$mappings #(&/|put id &/$None %)
- ts))
- state)
- nil)
- (fail* (str "[Type Error] <set-var> Unknown type-var: " id " | " (->> state (&/get$ &/$type-vars) (&/get$ &/$mappings) &/|length))))))
-
-;; [Exports]
-;; Type vars
-(def create-var
- (fn [state]
- (let [id (->> state (&/get$ &/$type-vars) (&/get$ &/$counter))]
- (return* (&/update$ &/$type-vars #(->> %
- (&/update$ &/$counter inc)
- (&/update$ &/$mappings (fn [ms] (&/|put id &/$None ms))))
- state)
- id))))
-
-(def existential
- ;; (Lux Type)
- (|do [seed &/gen-id]
- (return (&/$ExT seed))))
-
-(declare clean*)
-(defn delete-var [id]
- (|do [? (bound? id)
- _ (if ?
- (return nil)
- (|do [ex existential]
- (set-var id ex)))]
- (fn [state]
- ((|do [mappings* (&/map% (fn [binding]
- (|let [[?id ?type] binding]
- (if (.equals ^Object id ?id)
- (return binding)
- (|case ?type
- (&/$None)
- (return binding)
-
- (&/$Some ?type*)
- (|case ?type*
- (&/$VarT ?id*)
- (if (.equals ^Object id ?id*)
- (return (&/T [?id &/$None]))
- (return binding))
-
- _
- (|do [?type** (clean* id ?type*)]
- (return (&/T [?id (&/$Some ?type**)]))))
- ))))
- (->> state (&/get$ &/$type-vars) (&/get$ &/$mappings)))]
- (fn [state]
- (return* (&/update$ &/$type-vars #(&/set$ &/$mappings (&/|remove id mappings*) %)
- state)
- nil)))
- state))))
-
-(defn with-var [k]
- (|do [id create-var
- output (k (&/$VarT id))
- _ (delete-var id)]
- (return output)))
-
-(defn clean* [?tid type]
- (|case type
- (&/$VarT ?id)
- (if (.equals ^Object ?tid ?id)
- (|do [? (bound? ?id)]
- (if ?
- (deref ?id)
- (return type)))
- (|do [? (bound? ?id)]
- (if ?
- (|do [=type (deref ?id)
- ==type (clean* ?tid =type)]
- (|case ==type
- (&/$VarT =id)
- (if (.equals ^Object ?tid =id)
- (|do [_ (unset-var ?id)]
- (return type))
- (|do [_ (reset-var ?id ==type)]
- (return type)))
-
- _
- (|do [_ (reset-var ?id ==type)]
- (return type))))
- (return type)))
- )
-
- (&/$HostT ?name ?params)
- (|do [=params (&/map% (partial clean* ?tid) ?params)]
- (return (&/$HostT ?name =params)))
-
- (&/$LambdaT ?arg ?return)
- (|do [=arg (clean* ?tid ?arg)
- =return (clean* ?tid ?return)]
- (return (&/$LambdaT =arg =return)))
-
- (&/$AppT ?lambda ?param)
- (|do [=lambda (clean* ?tid ?lambda)
- =param (clean* ?tid ?param)]
- (return (&/$AppT =lambda =param)))
-
- (&/$ProdT ?left ?right)
- (|do [=left (clean* ?tid ?left)
- =right (clean* ?tid ?right)]
- (return (&/$ProdT =left =right)))
-
- (&/$SumT ?left ?right)
- (|do [=left (clean* ?tid ?left)
- =right (clean* ?tid ?right)]
- (return (&/$SumT =left =right)))
-
- (&/$UnivQ ?env ?body)
- (|do [=env (&/map% (partial clean* ?tid) ?env)
- body* (clean* ?tid ?body)] ;; TODO: DON'T CLEAN THE BODY
- (return (&/$UnivQ =env body*)))
-
- (&/$ExQ ?env ?body)
- (|do [=env (&/map% (partial clean* ?tid) ?env)
- body* (clean* ?tid ?body)] ;; TODO: DON'T CLEAN THE BODY
- (return (&/$ExQ =env body*)))
-
- _
- (return type)
- ))
-
-(defn clean [tvar type]
- (|case tvar
- (&/$VarT ?id)
- (clean* ?id type)
-
- _
- (fail (str "[Type Error] Not type-var: " (show-type tvar)))))
-
-(defn ^:private unravel-fun [type]
- (|case type
- (&/$LambdaT ?in ?out)
- (|let [[??out ?args] (unravel-fun ?out)]
- (&/T [??out (&/$Cons ?in ?args)]))
-
- _
- (&/T [type &/$Nil])))
-
-(defn ^:private unravel-app [fun-type]
- (|case fun-type
- (&/$AppT ?left ?right)
- (|let [[?fun-type ?args] (unravel-app ?left)]
- (&/T [?fun-type (&/|++ ?args (&/|list ?right))]))
-
- _
- (&/T [fun-type &/$Nil])))
-
-(do-template [<tag> <flatten> <at> <desc>]
- (do (defn <flatten> [type]
- "(-> Type (List Type))"
- (|case type
- (<tag> left right)
- (&/$Cons left (<flatten> right))
-
- _
- (&/|list type)))
-
- (defn <at> [tag type]
- "(-> Int Type (Lux Type))"
- (|case type
- (&/$NamedT ?name ?type)
- (<at> tag ?type)
-
- (<tag> ?left ?right)
- (|case (&/T [tag ?right])
- [0 _] (return ?left)
- [1 (<tag> ?left* _)] (return ?left*)
- [1 _] (return ?right)
- [_ (<tag> _ _)] (<at> (dec tag) ?right)
- _ (fail (str "[Type Error] " <desc> " lacks member: " tag " | " (show-type type))))
-
- _
- (fail (str "[Type Error] Type is not a " <desc> ": " (show-type type))))))
-
- &/$SumT flatten-sum sum-at "Sum"
- &/$ProdT flatten-prod prod-at "Product"
- )
-
-(do-template [<name> <ctor> <unit>]
- (defn <name> [types]
- "(-> (List Type) Type)"
- (|case (&/|reverse types)
- (&/$Cons last prevs)
- (&/fold (fn [right left] (<ctor> left right)) last prevs)
-
- (&/$Nil)
- <unit>))
-
- Variant$ &/$SumT &/$VoidT
- Tuple$ &/$ProdT &/$UnitT
- )
-
-(defn show-type [^objects type]
- (|case type
- (&/$HostT name params)
- (|case params
- (&/$Nil)
- (str "(host " name ")")
-
- _
- (str "(host " name " " (->> params (&/|map show-type) (&/|interpose " ") (&/fold str "")) ")"))
-
- (&/$VoidT)
- "Void"
-
- (&/$UnitT)
- "Unit"
-
- (&/$ProdT _)
- (str "[" (->> (flatten-prod type) (&/|map show-type) (&/|interpose " ") (&/fold str "")) "]")
-
- (&/$SumT _)
- (str "(| " (->> (flatten-sum type) (&/|map show-type) (&/|interpose " ") (&/fold str "")) ")")
-
- (&/$LambdaT input output)
- (|let [[?out ?ins] (unravel-fun type)]
- (str "(-> " (->> ?ins (&/|map show-type) (&/|interpose " ") (&/fold str "")) " " (show-type ?out) ")"))
-
- (&/$VarT id)
- (str "⌈v:" id "⌋")
-
- (&/$ExT ?id)
- (str "⟨e:" ?id "⟩")
-
- (&/$BoundT idx)
- (str idx)
-
- (&/$AppT _ _)
- (|let [[?call-fun ?call-args] (unravel-app type)]
- (str "(" (show-type ?call-fun) " " (->> ?call-args (&/|map show-type) (&/|interpose " ") (&/fold str "")) ")"))
-
- (&/$UnivQ ?env ?body)
- (str "(All " (show-type ?body) ")")
-
- (&/$ExQ ?env ?body)
- (str "(Ex " (show-type ?body) ")")
-
- (&/$NamedT ?name ?type)
- (&/ident->text ?name)
-
- _
- (assert false (prn-str 'show-type (&/adt->text type)))))
-
-(defn type= [x y]
- (or (clojure.lang.Util/identical x y)
- (let [output (|case [x y]
- [(&/$NamedT [?xmodule ?xname] ?xtype) (&/$NamedT [?ymodule ?yname] ?ytype)]
- (and (= ?xmodule ?ymodule)
- (= ?xname ?yname))
-
- [(&/$HostT xname xparams) (&/$HostT yname yparams)]
- (and (.equals ^Object xname yname)
- (= (&/|length xparams) (&/|length yparams))
- (&/fold2 #(and %1 (type= %2 %3)) true xparams yparams))
-
- [(&/$VoidT) (&/$VoidT)]
- true
-
- [(&/$UnitT) (&/$UnitT)]
- true
-
- [(&/$ProdT xL xR) (&/$ProdT yL yR)]
- (and (type= xL yL)
- (type= xR yR))
-
- [(&/$SumT xL xR) (&/$SumT yL yR)]
- (and (type= xL yL)
- (type= xR yR))
-
- [(&/$LambdaT xinput xoutput) (&/$LambdaT yinput youtput)]
- (and (type= xinput yinput)
- (type= xoutput youtput))
-
- [(&/$VarT xid) (&/$VarT yid)]
- (.equals ^Object xid yid)
-
- [(&/$BoundT xidx) (&/$BoundT yidx)]
- (= xidx yidx)
-
- [(&/$ExT xid) (&/$ExT yid)]
- (.equals ^Object xid yid)
-
- [(&/$AppT xlambda xparam) (&/$AppT ylambda yparam)]
- (and (type= xlambda ylambda) (type= xparam yparam))
-
- [(&/$UnivQ xenv xbody) (&/$UnivQ yenv ybody)]
- (type= xbody ybody)
-
- [(&/$NamedT ?xname ?xtype) _]
- (type= ?xtype y)
-
- [_ (&/$NamedT ?yname ?ytype)]
- (type= x ?ytype)
-
- [_ _]
- false
- )]
- output)))
-
-(defn ^:private fp-get [k fixpoints]
- (|let [[e a] k]
- (|case fixpoints
- (&/$Nil)
- &/$None
-
- (&/$Cons [[e* a*] v*] fixpoints*)
- (if (and (type= e e*)
- (type= a a*))
- (&/$Some v*)
- (fp-get k fixpoints*))
- )))
-
-(defn ^:private fp-put [k v fixpoints]
- (&/$Cons (&/T [k v]) fixpoints))
-
-(defn show-type+ [type]
- (|case type
- (&/$VarT ?id)
- (fn [state]
- (|case ((deref ?id) state)
- (&/$Right state* bound)
- (return* state (str (show-type type) " = " (show-type bound)))
-
- (&/$Left _)
- (return* state (show-type type))))
-
- _
- (return (show-type type))))
-
-(defn ^:private check-error [err expected actual]
- (|do [=expected (show-type+ expected)
- =actual (show-type+ actual)]
- (&/fail-with-loc (str (if (= "" err) err (str err "\n"))
- "[Type Checker]\n"
- "Expected: " =expected "\n\n"
- "Actual: " =actual
- "\n"))))
-
-(defn beta-reduce [env type]
- (|case type
- (&/$HostT ?name ?params)
- (&/$HostT ?name (&/|map (partial beta-reduce env) ?params))
-
- (&/$SumT ?left ?right)
- (&/$SumT (beta-reduce env ?left) (beta-reduce env ?right))
-
- (&/$ProdT ?left ?right)
- (&/$ProdT (beta-reduce env ?left) (beta-reduce env ?right))
-
- (&/$AppT ?type-fn ?type-arg)
- (&/$AppT (beta-reduce env ?type-fn) (beta-reduce env ?type-arg))
-
- (&/$UnivQ ?local-env ?local-def)
- (|case ?local-env
- (&/$Nil)
- (&/$UnivQ env ?local-def)
-
- _
- type)
-
- (&/$ExQ ?local-env ?local-def)
- (|case ?local-env
- (&/$Nil)
- (&/$ExQ env ?local-def)
-
- _
- type)
-
- (&/$LambdaT ?input ?output)
- (&/$LambdaT (beta-reduce env ?input) (beta-reduce env ?output))
-
- (&/$BoundT ?idx)
- (|case (&/|at ?idx env)
- (&/$Some bound)
- (beta-reduce env bound)
-
- _
- (assert false (str "[Type Error] Unknown var: " ?idx " | " (&/->seq (&/|map show-type env)))))
-
- _
- type
- ))
-
-(defn apply-type [type-fn param]
- (|case type-fn
- (&/$UnivQ local-env local-def)
- (return (beta-reduce (->> local-env
- (&/$Cons param)
- (&/$Cons type-fn))
- local-def))
-
- (&/$ExQ local-env local-def)
- (return (beta-reduce (->> local-env
- (&/$Cons param)
- (&/$Cons type-fn))
- local-def))
-
- (&/$AppT F A)
- (|do [type-fn* (apply-type F A)]
- (apply-type type-fn* param))
-
- (&/$NamedT ?name ?type)
- (apply-type ?type param)
-
- ;; TODO: This one must go...
- (&/$ExT id)
- (return (&/$AppT type-fn param))
-
- (&/$VarT id)
- (|do [=type-fun (deref id)]
- (apply-type =type-fun param))
-
- _
- (fail (str "[Type System] Not a type function:\n" (show-type type-fn) "\n"))))
-
-(def ^:private init-fixpoints &/$Nil)
-
-(defn ^:private check* [class-loader fixpoints invariant?? expected actual]
- (if (clojure.lang.Util/identical expected actual)
- (return fixpoints)
- (&/with-attempt
- (|case [expected actual]
- [(&/$VarT ?eid) (&/$VarT ?aid)]
- (if (.equals ^Object ?eid ?aid)
- (return fixpoints)
- (|do [ebound (fn [state]
- (|case ((deref ?eid) state)
- (&/$Right state* ebound)
- (return* state* (&/$Some ebound))
-
- (&/$Left _)
- (return* state &/$None)))
- abound (fn [state]
- (|case ((deref ?aid) state)
- (&/$Right state* abound)
- (return* state* (&/$Some abound))
-
- (&/$Left _)
- (return* state &/$None)))]
- (|case [ebound abound]
- [(&/$None _) (&/$None _)]
- (|do [_ (set-var ?eid actual)]
- (return fixpoints))
-
- [(&/$Some etype) (&/$None _)]
- (check* class-loader fixpoints invariant?? etype actual)
-
- [(&/$None _) (&/$Some atype)]
- (check* class-loader fixpoints invariant?? expected atype)
-
- [(&/$Some etype) (&/$Some atype)]
- (check* class-loader fixpoints invariant?? etype atype))))
-
- [(&/$VarT ?id) _]
- (fn [state]
- (|case ((set-var ?id actual) state)
- (&/$Right state* _)
- (return* state* fixpoints)
-
- (&/$Left _)
- ((|do [bound (deref ?id)]
- (check* class-loader fixpoints invariant?? bound actual))
- state)))
-
- [_ (&/$VarT ?id)]
- (fn [state]
- (|case ((set-var ?id expected) state)
- (&/$Right state* _)
- (return* state* fixpoints)
-
- (&/$Left _)
- ((|do [bound (deref ?id)]
- (check* class-loader fixpoints invariant?? expected bound))
- state)))
-
- [(&/$AppT (&/$ExT eid) eA) (&/$AppT (&/$ExT aid) aA)]
- (if (= eid aid)
- (check* class-loader fixpoints invariant?? eA aA)
- (check-error "" expected actual))
-
- [(&/$AppT (&/$VarT ?id) A1) (&/$AppT F2 A2)]
- (fn [state]
- (|case ((|do [F1 (deref ?id)]
- (check* class-loader fixpoints invariant?? (&/$AppT F1 A1) actual))
- state)
- (&/$Right state* output)
- (return* state* output)
-
- (&/$Left _)
- (|case F2
- (&/$UnivQ (&/$Cons _) _)
- ((|do [actual* (apply-type F2 A2)]
- (check* class-loader fixpoints invariant?? expected actual*))
- state)
-
- (&/$ExT _)
- ((|do [fixpoints* (check* class-loader fixpoints invariant?? (&/$VarT ?id) F2)]
- (check* class-loader fixpoints* invariant?? A1 A2))
- state)
-
- _
- ((|do [fixpoints* (check* class-loader fixpoints invariant?? (&/$VarT ?id) F2)
- e* (apply-type F2 A1)
- a* (apply-type F2 A2)]
- (check* class-loader fixpoints* invariant?? e* a*))
- state))))
-
- [(&/$AppT F1 A1) (&/$AppT (&/$VarT ?id) A2)]
- (fn [state]
- (|case ((|do [F2 (deref ?id)]
- (check* class-loader fixpoints invariant?? expected (&/$AppT F2 A2)))
- state)
- (&/$Right state* output)
- (return* state* output)
-
- (&/$Left _)
- ((|do [fixpoints* (check* class-loader fixpoints invariant?? F1 (&/$VarT ?id))
- e* (apply-type F1 A1)
- a* (apply-type F1 A2)]
- (check* class-loader fixpoints* invariant?? e* a*))
- state)))
-
- [(&/$AppT F A) _]
- (let [fp-pair (&/T [expected actual])
- _ (when (> (&/|length fixpoints) 40)
- (println 'FIXPOINTS (->> (&/|keys fixpoints)
- (&/|map (fn [pair]
- (|let [[e a] pair]
- (str (show-type e) ":+:"
- (show-type a)))))
- (&/|interpose "\n\n")
- (&/fold str "")))
- (assert false (prn-str 'check* '[(&/$AppT F A) _] (&/|length fixpoints) (show-type expected) (show-type actual))))]
- (|case (fp-get fp-pair fixpoints)
- (&/$Some ?)
- (if ?
- (return fixpoints)
- (check-error "" expected actual))
-
- (&/$None)
- (|do [expected* (apply-type F A)]
- (check* class-loader (fp-put fp-pair true fixpoints) invariant?? expected* actual))))
-
- [_ (&/$AppT (&/$ExT aid) A)]
- (check-error "" expected actual)
-
- [_ (&/$AppT F A)]
- (|do [actual* (apply-type F A)]
- (check* class-loader fixpoints invariant?? expected actual*))
-
- [(&/$UnivQ _) _]
- (|do [$arg existential
- expected* (apply-type expected $arg)]
- (check* class-loader fixpoints invariant?? expected* actual))
-
- [_ (&/$UnivQ _)]
- (with-var
- (fn [$arg]
- (|do [actual* (apply-type actual $arg)
- =output (check* class-loader fixpoints invariant?? expected actual*)
- _ (clean $arg expected)]
- (return =output))))
-
- [(&/$ExQ e!env e!def) _]
- (with-var
- (fn [$arg]
- (|do [expected* (apply-type expected $arg)
- =output (check* class-loader fixpoints invariant?? expected* actual)
- _ (clean $arg actual)]
- (return =output))))
-
- [_ (&/$ExQ a!env a!def)]
- (|do [$arg existential
- actual* (apply-type actual $arg)]
- (check* class-loader fixpoints invariant?? expected actual*))
-
- [(&/$HostT e!data) (&/$HostT a!data)]
- (&&host/check-host-types (partial check* class-loader fixpoints true)
- check-error
- fixpoints
- existential
- class-loader
- invariant??
- e!data
- a!data)
-
- [(&/$VoidT) (&/$VoidT)]
- (return fixpoints)
-
- [(&/$UnitT) (&/$UnitT)]
- (return fixpoints)
-
- [(&/$LambdaT eI eO) (&/$LambdaT aI aO)]
- (|do [fixpoints* (check* class-loader fixpoints invariant?? aI eI)]
- (check* class-loader fixpoints* invariant?? eO aO))
-
- [(&/$ProdT eL eR) (&/$ProdT aL aR)]
- (|do [fixpoints* (check* class-loader fixpoints invariant?? eL aL)]
- (check* class-loader fixpoints* invariant?? eR aR))
-
- [(&/$SumT eL eR) (&/$SumT aL aR)]
- (|do [fixpoints* (check* class-loader fixpoints invariant?? eL aL)]
- (check* class-loader fixpoints* invariant?? eR aR))
-
- [(&/$ExT e!id) (&/$ExT a!id)]
- (if (.equals ^Object e!id a!id)
- (return fixpoints)
- (check-error "" expected actual))
-
- [(&/$NamedT _ ?etype) _]
- (check* class-loader fixpoints invariant?? ?etype actual)
-
- [_ (&/$NamedT _ ?atype)]
- (check* class-loader fixpoints invariant?? expected ?atype)
-
- [_ _]
- (fail ""))
- (fn [err]
- (check-error err expected actual)))))
-
-(defn check [expected actual]
- (|do [class-loader &/loader
- _ (check* class-loader init-fixpoints false expected actual)]
- (return nil)))
-
-(defn actual-type [type]
- "(-> Type (Lux Type))"
- (|case type
- (&/$AppT ?all ?param)
- (|do [type* (apply-type ?all ?param)]
- (actual-type type*))
-
- (&/$VarT id)
- (|do [=type (deref id)]
- (actual-type =type))
-
- (&/$NamedT ?name ?type)
- (actual-type ?type)
-
- _
- (return type)
- ))
-
-(defn type-name [type]
- "(-> Type (Lux Ident))"
- (|case type
- (&/$NamedT name _)
- (return name)
-
- _
- (fail (str "[Type Error] Type is not named: " (show-type type)))
- ))
-
-(defn unknown? [type]
- "(-> Type (Lux Bool))"
- (|case type
- (&/$VarT id)
- (|do [? (bound? id)]
- (return (not ?)))
-
- _
- (return false)))
-
-(defn resolve-type [type]
- "(-> Type (Lux Type))"
- (|case type
- (&/$VarT id)
- (|do [? (bound? id)]
- (if ?
- (deref id)
- (return type)))
-
- _
- (return type)))
-
-(defn tuple-types-for [size-members type]
- "(-> Int Type [Int (List Type)])"
- (|let [?member-types (flatten-prod type)
- size-types (&/|length ?member-types)]
- (if (>= size-types size-members)
- (&/T [size-members (&/|++ (&/|take (dec size-members) ?member-types)
- (&/|list (|case (->> ?member-types (&/|drop (dec size-members)) (&/|reverse))
- (&/$Cons last prevs)
- (&/fold (fn [right left] (&/$ProdT left right))
- last prevs))))])
- (&/T [size-types ?member-types])
- )))
-
-(do-template [<name> <zero> <plus>]
- (defn <name> [types]
- (|case (&/|reverse types)
- (&/$Nil)
- <zero>
-
- (&/$Cons type (&/$Nil))
- type
-
- (&/$Cons last prevs)
- (&/fold (fn [r l] (<plus> l r)) last prevs)))
-
- fold-prod &/$UnitT &/$ProdT
- fold-sum &/$VoidT &/$SumT
- )
-
-(def create-var+
- (|do [id create-var]
- (return (&/$VarT id))))
-
-(defn ^:private push-app [inf-type inf-var]
- (|case inf-type
- (&/$AppT inf-type* inf-var*)
- (&/$AppT (push-app inf-type* inf-var) inf-var*)
-
- _
- (&/$AppT inf-type inf-var)))
-
-(defn ^:private push-name [name inf-type]
- (|case inf-type
- (&/$AppT inf-type* inf-var*)
- (&/$AppT (push-name name inf-type*) inf-var*)
-
- _
- (&/$NamedT name inf-type)))
-
-(defn ^:private push-univq [env inf-type]
- (|case inf-type
- (&/$AppT inf-type* inf-var*)
- (&/$AppT (push-univq env inf-type*) inf-var*)
-
- _
- (&/$UnivQ env inf-type)))
-
-(defn instantiate-inference [type]
- (|case type
- (&/$NamedT ?name ?type)
- (|do [output (instantiate-inference ?type)]
- (return (push-name ?name output)))
-
- (&/$UnivQ _aenv _abody)
- (|do [inf-var create-var
- output (instantiate-inference _abody)]
- (return (push-univq _aenv (push-app output (&/$VarT inf-var)))))
-
- _
- (return type)))
diff --git a/src/lux/type/host.clj b/src/lux/type/host.clj
deleted file mode 100644
index 462e1aebe..000000000
--- a/src/lux/type/host.clj
+++ /dev/null
@@ -1,352 +0,0 @@
-;; Copyright (c) Eduardo Julian. All rights reserved.
-;; This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0.
-;; If a copy of the MPL was not distributed with this file,
-;; You can obtain one at http://mozilla.org/MPL/2.0/.
-
-(ns lux.type.host
- (:require clojure.core.match
- clojure.core.match.array
- (lux [base :as & :refer [|do return* return fail fail* assert! |let |case]])
- [lux.host.generics :as &host-generics])
- (:import (java.lang.reflect GenericArrayType
- ParameterizedType
- TypeVariable
- WildcardType)))
-
-;; [Exports]
-(def array-data-tag "#Array")
-(def null-data-tag "#Null")
-(def nat-data-tag "#Nat")
-(def frac-data-tag "#Frac")
-
-;; [Utils]
-(defn ^:private trace-lineage* [^Class super-class ^Class sub-class]
- "(-> Class Class (List Class))"
- ;; Either they're both interfaces, of they're both classes
- (let [valid-sub? #(if (or (= super-class %)
- (.isAssignableFrom super-class %))
- %
- nil)]
- (cond (.isInterface sub-class)
- (loop [sub-class sub-class
- stack (&/|list)]
- (let [super-interface (some valid-sub? (.getInterfaces sub-class))]
- (if (= super-class super-interface)
- (&/$Cons super-interface stack)
- (recur super-interface (&/$Cons super-interface stack)))))
-
- (.isInterface super-class)
- (loop [sub-class sub-class
- stack (&/|list)]
- (if-let [super-interface (some valid-sub? (.getInterfaces sub-class))]
- (if (= super-class super-interface)
- (&/$Cons super-interface stack)
- (recur super-interface (&/$Cons super-interface stack)))
- (let [super* (.getSuperclass sub-class)]
- (recur super* (&/$Cons super* stack)))))
-
- :else
- (loop [sub-class sub-class
- stack (&/|list)]
- (let [super* (.getSuperclass sub-class)]
- (if (= super* super-class)
- (&/$Cons super* stack)
- (recur super* (&/$Cons super* stack))))))))
-
-(defn ^:private trace-lineage [^Class sub-class ^Class super-class]
- "(-> Class Class (List Class))"
- (if (= sub-class super-class)
- (&/|list)
- (&/|reverse (trace-lineage* super-class sub-class))))
-
-(let [matcher (fn [m ^TypeVariable jt lt] (&/$Cons (&/T [(.getName jt) lt]) m))]
- (defn ^:private match-params [sub-type-params params]
- (assert (and (= (&/|length sub-type-params) (&/|length params))
- (&/|every? (partial instance? TypeVariable) sub-type-params)))
- (&/fold2 matcher (&/|table) sub-type-params params)))
-
-;; [Exports]
-(let [class-name-re #"((\[+)L([^\s]+);|([^\s]+)|(\[+)([ZBSIJFDC]))"
- jprim->lprim (fn [prim]
- (case prim
- "Z" "boolean"
- "B" "byte"
- "S" "short"
- "I" "int"
- "J" "long"
- "F" "float"
- "D" "double"
- "C" "char"))]
- (defn class->type [^Class class]
- "(-> Class Type)"
- (let [gclass-name (.getName class)]
- (case gclass-name
- ("[Z" "[B" "[S" "[I" "[J" "[F" "[D" "[C")
- (&/$HostT gclass-name (&/|list))
- ;; else
- (if-let [[_ _ arr-obrackets arr-obase simple-base arr-pbrackets arr-pbase] (re-find class-name-re gclass-name)]
- (let [base (or arr-obase simple-base (jprim->lprim arr-pbase))]
- (if (.equals "void" base)
- &/$UnitT
- (reduce (fn [inner _] (&/$HostT array-data-tag (&/|list inner)))
- (&/$HostT base (try (-> (Class/forName base) .getTypeParameters
- seq count (repeat (&/$HostT "java.lang.Object" &/$Nil))
- &/->list)
- (catch Exception e
- (&/|list))))
- (range (count (or arr-obrackets arr-pbrackets "")))))
- ))))))
-
-(defn instance-param [existential matchings refl-type]
- "(-> (Lux Type) (List (, Text Type)) (^ java.lang.reflect.Type) (Lux Type))"
- (cond (instance? Class refl-type)
- (return (class->type refl-type))
-
- (instance? GenericArrayType refl-type)
- (|do [inner-type (instance-param existential matchings (.getGenericComponentType ^GenericArrayType refl-type))]
- (return (&/$HostT array-data-tag (&/|list inner-type))))
-
- (instance? ParameterizedType refl-type)
- (|do [:let [refl-type* ^ParameterizedType refl-type]
- params* (->> refl-type*
- .getActualTypeArguments
- seq &/->list
- (&/map% (partial instance-param existential matchings)))]
- (return (&/$HostT (->> refl-type* ^Class (.getRawType) .getName)
- params*)))
-
- (instance? TypeVariable refl-type)
- (let [gvar (.getName ^TypeVariable refl-type)]
- (if-let [m-type (&/|get gvar matchings)]
- (return m-type)
- (fail (str "[Type Error] Unknown generic type variable: " gvar " -- " (->> matchings
- (&/|map &/|first)
- &/->seq)))))
-
- (instance? WildcardType refl-type)
- (if-let [bound (->> ^WildcardType refl-type .getUpperBounds seq first)]
- (instance-param existential matchings bound)
- existential)))
-
-(defn principal-class [refl-type]
- (cond (instance? Class refl-type)
- (|case (class->type refl-type)
- (&/$HostT "#Array" (&/$Cons (&/$HostT class-name _) (&/$Nil)))
- (str "[" (&host-generics/->type-signature class-name))
-
- (&/$HostT class-name _)
- (&host-generics/->type-signature class-name)
-
- (&/$UnitT)
- "V")
-
- (instance? GenericArrayType refl-type)
- (&host-generics/->type-signature (str refl-type))
-
- (instance? ParameterizedType refl-type)
- (&host-generics/->type-signature (->> ^ParameterizedType refl-type ^Class (.getRawType) .getName))
-
- (instance? TypeVariable refl-type)
- (if-let [bound (->> ^TypeVariable refl-type .getBounds seq first)]
- (principal-class bound)
- (&host-generics/->type-signature "java.lang.Object"))
-
- (instance? WildcardType refl-type)
- (if-let [bound (->> ^WildcardType refl-type .getUpperBounds seq first)]
- (principal-class bound)
- (&host-generics/->type-signature "java.lang.Object"))))
-
-(defn instance-gtype [existential matchings gtype]
- "(-> (Lux Type) (List (, Text Type)) GenericType (Lux Type))"
- (|case gtype
- (&/$GenericArray component-type)
- (|do [inner-type (instance-gtype existential matchings component-type)]
- (return (&/$HostT array-data-tag (&/|list inner-type))))
-
- (&/$GenericClass type-name type-params)
- ;; When referring to type-parameters during class or method
- ;; definition, a type-environment is set for storing the names
- ;; of such parameters.
- ;; When a "class" shows up with the name of one of those
- ;; parameters, it must be detected, and the bytecode class-name
- ;; must correspond to Object's.
-
- (if-let [m-type (&/|get type-name matchings)]
- (return m-type)
- (|do [params* (&/map% (partial instance-gtype existential matchings)
- type-params)]
- (return (&/$HostT type-name params*))))
-
- (&/$GenericTypeVar var-name)
- (if-let [m-type (&/|get var-name matchings)]
- (return m-type)
- (fail (str "[Type Error] Unknown generic type variable: " var-name " -- " (->> matchings
- (&/|map &/|first)
- &/->seq))))
-
- (&/$GenericWildcard)
- existential))
-
-;; [Utils]
-(defn ^:private translate-params [existential super-type-params sub-type-params params]
- "(-> (List (^ java.lang.reflect.Type)) (List (^ java.lang.reflect.Type)) (List Type) (Lux (List Type)))"
- (|let [matchings (match-params sub-type-params params)]
- (&/map% (partial instance-param existential matchings) super-type-params)))
-
-(defn ^:private raise* [existential sub+params ^Class super]
- "(-> (, Class (List Type)) Class (Lux (, Class (List Type))))"
- (|let [[^Class sub params] sub+params]
- (if (.isInterface super)
- (|do [:let [super-params (->> sub
- .getGenericInterfaces
- (some #(if (= super (if (instance? Class %) % (.getRawType ^ParameterizedType %)))
- (if (instance? Class %)
- (&/|list)
- (->> ^ParameterizedType % .getActualTypeArguments seq &/->list))
- nil)))]
- params* (translate-params existential
- (or super-params (&/|list))
- (->> sub .getTypeParameters seq &/->list)
- params)]
- (return (&/T [super params*])))
- (let [super* (.getGenericSuperclass sub)]
- (cond (instance? Class super*)
- (return (&/T [super* (&/|list)]))
-
- (instance? ParameterizedType super*)
- (|do [params* (translate-params existential
- (->> ^ParameterizedType super* .getActualTypeArguments seq &/->list)
- (->> sub .getTypeParameters seq &/->list)
- params)]
- (return (&/T [super params*])))
-
- :else
- (assert false (prn-str super* (class super*) [sub super])))))))
-
-(defn ^:private raise [existential lineage class params]
- "(-> (List Class) Class (List Type) (Lux (, Class (List Type))))"
- (&/fold% (partial raise* existential) (&/T [class params]) lineage))
-
-;; [Exports]
-(defn ->super-type [existential class-loader super-class sub-class sub-params]
- "(-> Text Text (List Type) (Lux Type))"
- (let [super-class+ (Class/forName super-class true class-loader)
- sub-class+ (Class/forName sub-class true class-loader)]
- (if (.isAssignableFrom super-class+ sub-class+)
- (let [lineage (trace-lineage sub-class+ super-class+)]
- (|do [[^Class sub-class* sub-params*] (raise existential lineage sub-class+ sub-params)]
- (return (&/$HostT (.getName sub-class*) sub-params*))))
- (fail (str "[Type Error] Classes don't have a subtyping relationship: " sub-class " </= " super-class)))))
-
-(defn as-obj [class]
- (case class
- "boolean" "java.lang.Boolean"
- "byte" "java.lang.Byte"
- "short" "java.lang.Short"
- "int" "java.lang.Integer"
- "long" "java.lang.Long"
- "float" "java.lang.Float"
- "double" "java.lang.Double"
- "char" "java.lang.Character"
- ;; else
- class))
-
-(let [primitive-types #{"boolean" "byte" "short" "int" "long" "float" "double" "char"}]
- (defn primitive-type? [type-name]
- (contains? primitive-types type-name)))
-
-(defn check-host-types [check check-error fixpoints existential class-loader invariant?? expected actual]
- (|let [[e!name e!params] expected
- [a!name a!params] actual]
- ;; TODO: Delete first branch. It smells like a hack...
- (try (cond (or (= "java.lang.Object" e!name)
- (and (= nat-data-tag e!name)
- (= nat-data-tag a!name))
- (and (= frac-data-tag e!name)
- (= frac-data-tag a!name))
- (and (= null-data-tag e!name)
- (= null-data-tag a!name))
- (and (not (primitive-type? e!name))
- (= null-data-tag a!name)))
- (return fixpoints)
-
- (or (and (= array-data-tag e!name)
- (not= array-data-tag a!name))
- (= nat-data-tag e!name) (= nat-data-tag a!name)
- (= frac-data-tag e!name) (= frac-data-tag a!name)
- (= null-data-tag e!name) (= null-data-tag a!name))
- (check-error "" (&/$HostT e!name e!params) (&/$HostT a!name a!params))
-
- :else
- (let [e!name (as-obj e!name)
- a!name (as-obj a!name)]
- (cond (= e!name a!name)
- (if (= (&/|length e!params) (&/|length a!params))
- (|do [_ (&/map2% check e!params a!params)]
- (return fixpoints))
- (fail (str "[Type Error] Amounts of generic parameters don't match: " e!name "(" (&/|length e!params) ")" " vs " a!name "(" (&/|length a!params) ")")))
-
- (not invariant??)
- (|do [actual* (->super-type existential class-loader e!name a!name a!params)]
- (check (&/$HostT e!name e!params) actual*))
-
- :else
- (fail (str "[Type Error] Names don't match: " e!name " =/= " a!name)))))
- (catch Exception e
- (prn 'check-host-types e [e!name a!name])
- (throw e)))))
-
-(defn gtype->gclass [gtype]
- "(-> GenericType GenericClass)"
- (cond (instance? Class gtype)
- (&/$GenericClass (.getName ^Class gtype) &/$Nil)
-
- (instance? GenericArrayType gtype)
- (&/$GenericArray (gtype->gclass (.getGenericComponentType ^GenericArrayType gtype)))
-
- (instance? ParameterizedType gtype)
- (let [type-name (->> ^ParameterizedType gtype ^Class (.getRawType) .getName)
- type-params (->> ^ParameterizedType gtype
- .getActualTypeArguments
- seq &/->list
- (&/|map gtype->gclass))]
- (&/$GenericClass type-name type-params))
-
- (instance? TypeVariable gtype)
- (&/$GenericTypeVar (.getName ^TypeVariable gtype))
-
- (instance? WildcardType gtype)
- (if-let [bound (->> ^WildcardType gtype .getUpperBounds seq first)]
- (&/$GenericWildcard (&/$Some (&/T &/$UpperBound (gtype->gclass bound))))
- (if-let [bound (->> ^WildcardType gtype .getLowerBounds seq first)]
- (&/$GenericWildcard (&/$Some (&/T &/$LowerBound (gtype->gclass bound))))
- (&/$GenericWildcard &/$None)))))
-
-(let [generic-type-sig "Ljava/lang/Object;"]
- (defn gclass->sig [gclass]
- "(-> GenericClass Text)"
- (|case gclass
- (&/$GenericClass gclass-name (&/$Nil))
- (case gclass-name
- "void" "V"
- "boolean" "Z"
- "byte" "B"
- "short" "S"
- "int" "I"
- "long" "J"
- "float" "F"
- "double" "D"
- "char" "C"
- ("[Z" "[B" "[S" "[I" "[J" "[F" "[D" "[C") gclass-name
- ;; else
- (str "L" (clojure.string/replace gclass-name #"\." "/") ";"))
-
- (&/$GenericArray inner-gtype)
- (str "[" (gclass->sig inner-gtype))
-
- (&/$GenericTypeVar ?vname)
- generic-type-sig
-
- (&/$GenericWildcard _)
- generic-type-sig
- )))