aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat (limited to '')
-rw-r--r--src/lux.clj10
-rw-r--r--src/lux/analyser.clj46
-rw-r--r--src/lux/analyser/base.clj13
-rw-r--r--src/lux/analyser/case.clj188
-rw-r--r--src/lux/analyser/host.clj35
-rw-r--r--src/lux/analyser/lambda.clj7
-rw-r--r--src/lux/analyser/lux.clj267
-rw-r--r--src/lux/analyser/module.clj29
-rw-r--r--src/lux/base.clj74
-rw-r--r--src/lux/compiler.clj500
-rw-r--r--src/lux/compiler/base.clj178
-rw-r--r--src/lux/compiler/case.clj9
-rw-r--r--src/lux/compiler/host.clj7
-rw-r--r--src/lux/compiler/lambda.clj20
-rw-r--r--src/lux/compiler/lux.clj16
-rw-r--r--src/lux/host.clj5
-rw-r--r--src/lux/lexer.clj16
-rw-r--r--src/lux/parser.clj17
-rw-r--r--src/lux/reader.clj13
-rw-r--r--src/lux/type.clj241
20 files changed, 689 insertions, 1002 deletions
diff --git a/src/lux.clj b/src/lux.clj
index de302b260..62e9d14f9 100644
--- a/src/lux.clj
+++ b/src/lux.clj
@@ -11,15 +11,5 @@
(comment
;; TODO: Finish total-locals
- (time (&compiler/compile-all (&/|list "program")))
-
- (time (&compiler/compile-all (&/|list "lux")))
- (System/gc)
- (time (&compiler/compile-all (&/|list "lux" "test2")))
-
- ;; jar cvf test2.jar *.class test2 && java -cp "test2.jar" test2
- ;; jar cvf program.jar output/*.class output/program && java -cp "program.jar" program
- ;; cd output && jar cvf test2.jar * && java -cp "test2.jar" test2 && cd ..
-
;; cd output && jar cvf program.jar * && java -cp "program.jar" program && cd ..
)
diff --git a/src/lux/analyser.clj b/src/lux/analyser.clj
index e2cdb83ce..eefb5b41c 100644
--- a/src/lux/analyser.clj
+++ b/src/lux/analyser.clj
@@ -88,9 +88,7 @@
["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" ["" ?name]]]]
["lux;Cons" [?value
["lux;Nil" _]]]]]]]]]]]
- (do ;; (when (= "if" ?name)
- ;; (prn "if" (&/show-ast ?value)))
- (&&lux/analyse-def analyse ?name ?value))
+ (&&lux/analyse-def analyse ?name ?value)
[["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "declare-macro'"]]]]
["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" ["" ?name]]]]
@@ -458,10 +456,6 @@
(fail "")))
(defn ^:private analyse-basic-ast [analyse eval! exo-type token]
- ;; (prn 'analyse-basic-ast (aget token 0))
- ;; (when (= "lux;Tag" (aget token 0))
- ;; (prn 'analyse-basic-ast/tag (aget token 1)))
- ;; (prn 'analyse-basic-ast token (&/show-ast token))
(fn [state]
(matchv ::M/objects [((aba1 analyse eval! exo-type token) state)]
[["lux;Right" [state* output]]]
@@ -472,36 +466,53 @@
[["lux;Right" [state* output]]]
(return* state* output)
- [_]
+ [["lux;Left" ""]]
(matchv ::M/objects [((aba3 analyse eval! exo-type token) state)]
[["lux;Right" [state* output]]]
(return* state* output)
- [_]
+ [["lux;Left" ""]]
(matchv ::M/objects [((aba4 analyse eval! exo-type token) state)]
[["lux;Right" [state* output]]]
(return* state* output)
- [_]
+ [["lux;Left" ""]]
(matchv ::M/objects [((aba5 analyse eval! exo-type token) state)]
[["lux;Right" [state* output]]]
(return* state* output)
- [_]
+ [["lux;Left" ""]]
(matchv ::M/objects [((aba6 analyse eval! exo-type token) state)]
[["lux;Right" [state* output]]]
(return* state* output)
-
- [_]
+
+ [["lux;Left" ""]]
(matchv ::M/objects [((aba7 analyse eval! exo-type token) state)]
[["lux;Right" [state* output]]]
(return* state* output)
[_]
- (fail* (str "[Analyser Error] Unmatched token: " (&/show-ast token))))))))))))
+ (fail* (str "[Analyser Error] Unmatched token: " (&/show-ast token))))
+
+ [_]
+ (fail* (str "[Analyser Error] Unmatched token: " (&/show-ast token))))
+
+ [_]
+ (fail* (str "[Analyser Error] Unmatched token: " (&/show-ast token))))
+
+ [_]
+ (fail* (str "[Analyser Error] Unmatched token: " (&/show-ast token))))
+
+ [_]
+ (fail* (str "[Analyser Error] Unmatched token: " (&/show-ast token))))
+
+ [_]
+ (fail* (str "[Analyser Error] Unmatched token: " (&/show-ast token))))
+
+ [_]
+ (fail* (str "[Analyser Error] Unmatched token: " (&/show-ast token))))))
(defn ^:private analyse-ast [eval! exo-type token]
- ;; (prn 'analyse-ast (aget token 0))
(matchv ::M/objects [token]
[["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Tag" ?ident]]] ?values]]]]]]
(do (assert (= 1 (&/|length ?values)) "[Analyser Error] Can only tag 1 value.")
@@ -509,15 +520,12 @@
[["lux;Meta" [meta ["lux;Form" ["lux;Cons" [?fn ?args]]]]]]
(fn [state]
- ;; (prn 'analyse-ast '(&/show-ast ?fn) (&/show-ast ?fn))
(matchv ::M/objects [((&type/with-var #(&&/analyse-1 (partial analyse-ast eval!) % ?fn)) state)]
[["lux;Right" [state* =fn]]]
((&&lux/analyse-apply (partial analyse-ast eval!) exo-type =fn ?args) state*)
[_]
- (do ;; (prn 'analyse-ast/token (aget token 0) (&/show-state state))
- ;; (prn 'NOT_A_FUNCTION (&/show-ast ?fn))
- ((analyse-basic-ast (partial analyse-ast eval!) eval! exo-type token) state))))
+ ((analyse-basic-ast (partial analyse-ast eval!) eval! exo-type token) state)))
[_]
(analyse-basic-ast (partial analyse-ast eval!) eval! exo-type token)))
diff --git a/src/lux/analyser/base.clj b/src/lux/analyser/base.clj
index 9913da4ae..b16025349 100644
--- a/src/lux/analyser/base.clj
+++ b/src/lux/analyser/base.clj
@@ -6,21 +6,18 @@
;; [Exports]
(defn expr-type [syntax+]
- ;; (prn 'expr-type syntax+)
- ;; (prn 'expr-type (aget syntax+ 0))
(matchv ::M/objects [syntax+]
[[_ type]]
(return type)))
(defn analyse-1 [analyse exo-type elem]
(|do [output (analyse exo-type elem)]
- (do ;; (prn 'analyse-1 (aget output 0))
- (matchv ::M/objects [output]
- [["lux;Cons" [x ["lux;Nil" _]]]]
- (return x)
+ (matchv ::M/objects [output]
+ [["lux;Cons" [x ["lux;Nil" _]]]]
+ (return x)
- [_]
- (fail "[Analyser Error] Can't expand to other than 1 element.")))))
+ [_]
+ (fail "[Analyser Error] Can't expand to other than 1 element."))))
(defn resolved-ident [ident]
(|let [[?module ?name] ident]
diff --git a/src/lux/analyser/case.clj b/src/lux/analyser/case.clj
index ea767d11c..cdcf40e0f 100644
--- a/src/lux/analyser/case.clj
+++ b/src/lux/analyser/case.clj
@@ -19,105 +19,102 @@
(&type/actual-type type)))
(defn ^:private analyse-pattern [value-type pattern kont]
- ;; (prn 'analyse-pattern/pattern (aget pattern 0) (aget pattern 1) (alength (aget pattern 1)))
(matchv ::M/objects [pattern]
[["lux;Meta" [_ pattern*]]]
- ;; (assert false)
- (do ;; (prn 'analyse-pattern/pattern* (aget pattern* 0))
- (matchv ::M/objects [pattern*]
- [["lux;Symbol" ?ident]]
- (|do [=kont (&env/with-local (&/ident->text ?ident) value-type
- kont)
- idx &env/next-local-idx]
- (return (&/T (&/V "StoreTestAC" idx) =kont)))
-
- [["lux;Bool" ?value]]
- (|do [_ (&type/check value-type &type/Bool)
- =kont kont]
- (return (&/T (&/V "BoolTestAC" ?value) =kont)))
-
- [["lux;Int" ?value]]
- (|do [_ (&type/check value-type &type/Int)
- =kont kont]
- (return (&/T (&/V "IntTestAC" ?value) =kont)))
-
- [["lux;Real" ?value]]
- (|do [_ (&type/check value-type &type/Real)
- =kont kont]
- (return (&/T (&/V "RealTestAC" ?value) =kont)))
-
- [["lux;Char" ?value]]
- (|do [_ (&type/check value-type &type/Char)
- =kont kont]
- (return (&/T (&/V "CharTestAC" ?value) =kont)))
-
- [["lux;Text" ?value]]
- (|do [_ (&type/check value-type &type/Text)
- =kont kont]
- (return (&/T (&/V "TextTestAC" ?value) =kont)))
-
- [["lux;Tuple" ?members]]
- (matchv ::M/objects [value-type]
- [["lux;TupleT" ?member-types]]
- (if (not (= (&/|length ?member-types) (&/|length ?members)))
- (fail (str "[Analyser error] Pattern-matching mismatch. Require tuple[" (&/|length ?member-types) "]. Given tuple [" (&/|length ?members) "]"))
- (|do [[=tests =kont] (&/fold (fn [kont* vm]
- (|let [[v m] vm]
- (|do [[=test [=tests =kont]] (analyse-pattern v m kont*)]
- (return (&/T (&/|cons =test =tests) =kont)))))
+ (matchv ::M/objects [pattern*]
+ [["lux;Symbol" ?ident]]
+ (|do [=kont (&env/with-local (&/ident->text ?ident) value-type
+ kont)
+ idx &env/next-local-idx]
+ (return (&/T (&/V "StoreTestAC" idx) =kont)))
+
+ [["lux;Bool" ?value]]
+ (|do [_ (&type/check value-type &type/Bool)
+ =kont kont]
+ (return (&/T (&/V "BoolTestAC" ?value) =kont)))
+
+ [["lux;Int" ?value]]
+ (|do [_ (&type/check value-type &type/Int)
+ =kont kont]
+ (return (&/T (&/V "IntTestAC" ?value) =kont)))
+
+ [["lux;Real" ?value]]
+ (|do [_ (&type/check value-type &type/Real)
+ =kont kont]
+ (return (&/T (&/V "RealTestAC" ?value) =kont)))
+
+ [["lux;Char" ?value]]
+ (|do [_ (&type/check value-type &type/Char)
+ =kont kont]
+ (return (&/T (&/V "CharTestAC" ?value) =kont)))
+
+ [["lux;Text" ?value]]
+ (|do [_ (&type/check value-type &type/Text)
+ =kont kont]
+ (return (&/T (&/V "TextTestAC" ?value) =kont)))
+
+ [["lux;Tuple" ?members]]
+ (matchv ::M/objects [value-type]
+ [["lux;TupleT" ?member-types]]
+ (if (not (= (&/|length ?member-types) (&/|length ?members)))
+ (fail (str "[Analyser error] Pattern-matching mismatch. Require tuple[" (&/|length ?member-types) "]. Given tuple [" (&/|length ?members) "]"))
+ (|do [[=tests =kont] (&/fold (fn [kont* vm]
+ (|let [[v m] vm]
+ (|do [[=test [=tests =kont]] (analyse-pattern v m kont*)]
+ (return (&/T (&/|cons =test =tests) =kont)))))
+ (|do [=kont kont]
+ (return (&/T (&/|list) =kont)))
+ (&/|reverse (&/zip2 ?member-types ?members)))]
+ (return (&/T (&/V "TupleTestAC" =tests) =kont))))
+
+ [_]
+ (fail "[Analyser Error] Tuple requires tuple-type."))
+
+ [["lux;Record" ?slots]]
+ (|do [value-type* (resolve-type value-type)]
+ (matchv ::M/objects [value-type*]
+ [["lux;RecordT" ?slot-types]]
+ (if (not (= (&/|length ?slot-types) (&/|length ?slots)))
+ (fail (str "[Analyser error] Pattern-matching mismatch. Require record[" (&/|length ?slot-types) "]. Given record[" (&/|length ?slots) "]"))
+ (|do [[=tests =kont] (&/fold (fn [kont* slot]
+ (|let [[sn sv] slot]
+ (matchv ::M/objects [sn]
+ [["lux;Meta" [_ ["lux;Tag" ?ident]]]]
+ (|do [=tag (&&/resolved-ident ?ident)]
+ (if-let [=slot-type (&/|get =tag ?slot-types)]
+ (|do [[=test [=tests =kont]] (analyse-pattern =slot-type sv kont*)]
+ (return (&/T (&/|put =tag =test =tests) =kont)))
+ (fail (str "[Pattern-Matching Error] Record-type lacks slot: " =tag))))
+
+ [_]
+ (fail (str "[Pattern-Matching Error] Record must use tags as slot-names: " (&/show-ast sn))))))
(|do [=kont kont]
- (return (&/T (&/|list) =kont)))
- (&/|reverse (&/zip2 ?member-types ?members)))]
- (return (&/T (&/V "TupleTestAC" =tests) =kont))))
+ (return (&/T (&/|table) =kont)))
+ (&/|reverse ?slots))]
+ (return (&/T (&/V "RecordTestAC" =tests) =kont))))
[_]
- (fail "[Analyser Error] Tuple requires tuple-type."))
-
- [["lux;Record" ?slots]]
- (|do [value-type* (resolve-type value-type)]
- (matchv ::M/objects [value-type*]
- [["lux;RecordT" ?slot-types]]
- (if (not (= (&/|length ?slot-types) (&/|length ?slots)))
- (fail (str "[Analyser error] Pattern-matching mismatch. Require record[" (&/|length ?slot-types) "]. Given record[" (&/|length ?slots) "]"))
- (|do [[=tests =kont] (&/fold (fn [kont* slot]
- (|let [[sn sv] slot]
- (matchv ::M/objects [sn]
- [["lux;Meta" [_ ["lux;Tag" ?ident]]]]
- (|do [=tag (&&/resolved-ident ?ident)]
- (if-let [=slot-type (&/|get =tag ?slot-types)]
- (|do [[=test [=tests =kont]] (analyse-pattern =slot-type sv kont*)]
- (return (&/T (&/|put =tag =test =tests) =kont)))
- (fail (str "[Pattern-Matching Error] Record-type lacks slot: " =tag))))
-
- [_]
- (fail (str "[Pattern-Matching Error] Record must use tags as slot-names: " (&/show-ast sn))))))
- (|do [=kont kont]
- (return (&/T (&/|table) =kont)))
- (&/|reverse ?slots))]
- (return (&/T (&/V "RecordTestAC" =tests) =kont))))
-
- [_]
- (fail "[Analyser Error] Record requires record-type.")))
-
- [["lux;Tag" ?ident]]
- (|do [=tag (&&/resolved-ident ?ident)
- value-type* (resolve-type value-type)
- case-type (&type/variant-case =tag value-type*)
- [=test =kont] (analyse-pattern case-type (&/V "lux;Meta" (&/T (&/T "" -1 -1)
- (&/V "lux;Tuple" (&/|list))))
- kont)]
- (return (&/T (&/V "VariantTestAC" (&/T =tag =test)) =kont)))
-
- [["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Tag" ?ident]]]
- ["lux;Cons" [?value
- ["lux;Nil" _]]]]]]]
- (|do [=tag (&&/resolved-ident ?ident)
- value-type* (resolve-type value-type)
- case-type (&type/variant-case =tag value-type*)
- [=test =kont] (analyse-pattern case-type ?value
- kont)]
- (return (&/T (&/V "VariantTestAC" (&/T =tag =test)) =kont)))
- ))))
+ (fail "[Analyser Error] Record requires record-type.")))
+
+ [["lux;Tag" ?ident]]
+ (|do [=tag (&&/resolved-ident ?ident)
+ value-type* (resolve-type value-type)
+ case-type (&type/variant-case =tag value-type*)
+ [=test =kont] (analyse-pattern case-type (&/V "lux;Meta" (&/T (&/T "" -1 -1)
+ (&/V "lux;Tuple" (&/|list))))
+ kont)]
+ (return (&/T (&/V "VariantTestAC" (&/T =tag =test)) =kont)))
+
+ [["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Tag" ?ident]]]
+ ["lux;Cons" [?value
+ ["lux;Nil" _]]]]]]]
+ (|do [=tag (&&/resolved-ident ?ident)
+ value-type* (resolve-type value-type)
+ case-type (&type/variant-case =tag value-type*)
+ [=test =kont] (analyse-pattern case-type ?value
+ kont)]
+ (return (&/T (&/V "VariantTestAC" (&/T =tag =test)) =kont)))
+ )))
(defn ^:private analyse-branch [analyse exo-type value-type pattern body patterns]
(|do [pattern+body (analyse-pattern value-type pattern
@@ -219,7 +216,6 @@
))))
(defn ^:private check-totality [value-type struct]
- ;; (prn 'check-totality (aget value-type 0) (aget struct 0) (&type/show-type value-type))
(matchv ::M/objects [struct]
[["BoolTotal" [?total ?values]]]
(return (or ?total
@@ -296,10 +292,8 @@
(analyse-branch analyse exo-type value-type pattern body patterns)))
(&/|list)
branches)
- ;; :let [_ (prn 'PRE_MERGE_TOTALS)]
struct (&/fold% merge-total (&/V "DefaultTotal" false) patterns)
? (check-totality value-type struct)]
(if ?
- ;; (return (&/|reverse patterns))
(return patterns)
(fail "[Pattern-maching error] Pattern-matching is non-total."))))
diff --git a/src/lux/analyser/host.clj b/src/lux/analyser/host.clj
index 3c9e3ce3f..d57493439 100644
--- a/src/lux/analyser/host.clj
+++ b/src/lux/analyser/host.clj
@@ -21,7 +21,6 @@
(defn ^:private analyse-1+ [analyse ?token]
(&type/with-var
(fn [$var]
- ;; (prn 'analyse-1+ (aget $var 1) (&/show-ast ?token))
(|do [=expr (&&/analyse-1 analyse $var ?token)]
(matchv ::M/objects [=expr]
[[?item ?type]]
@@ -77,10 +76,7 @@
(defn analyse-jvm-getstatic [analyse ?class ?field]
(|do [=class (&host/full-class-name ?class)
- ;; :let [_ (prn 'analyse-jvm-getstatic/=class =class)]
- =type (&host/lookup-static-field =class ?field)
- ;; :let [_ (prn 'analyse-jvm-getstatic/=type =type)]
- ]
+ =type (&host/lookup-static-field =class ?field)]
(return (&/|list (&/T (&/V "jvm-getstatic" (&/T =class ?field)) =type)))))
(defn analyse-jvm-getfield [analyse ?class ?field ?object]
@@ -91,9 +87,7 @@
(defn analyse-jvm-putstatic [analyse ?class ?field ?value]
(|do [=class (&host/full-class-name ?class)
- ;; :let [_ (prn 'analyse-jvm-getstatic/=class =class)]
=type (&host/lookup-static-field =class ?field)
- ;; :let [_ (prn 'analyse-jvm-getstatic/=type =type)]
=value (&&/analyse-1 analyse ?value)]
(return (&/|list (&/T (&/V "jvm-putstatic" (&/T =class ?field =value)) =type)))))
@@ -113,21 +107,14 @@
(do-template [<name> <tag>]
(defn <name> [analyse ?class ?method ?classes ?object ?args]
- ;; (prn '<name> ?class ?method)
(|do [=class (&host/full-class-name ?class)
- ;; :let [_ (prn 'analyse-jvm-invokevirtual/=class =class)]
=classes (&/map% &host/extract-jvm-param ?classes)
- ;; :let [_ (prn 'analyse-jvm-invokevirtual/=classes =classes)]
=return (&host/lookup-virtual-method =class ?method =classes)
- ;; :let [_ (prn 'analyse-jvm-invokevirtual/=return =return)]
=object (&&/analyse-1 analyse (&/V "lux;DataT" ?class) ?object)
- ;; :let [_ (prn 'analyse-jvm-invokevirtual/=object =object)]
=args (&/map% (fn [c+o]
(|let [[?c ?o] c+o]
(&&/analyse-1 analyse (&/V "lux;DataT" ?c) ?o)))
- (&/zip2 =classes ?args))
- ;; :let [_ (prn 'analyse-jvm-invokevirtual/=args =args)]
- ]
+ (&/zip2 =classes ?args))]
(return (&/|list (&/T (&/V <tag> (&/T =class ?method =classes =object =args)) =return)))))
analyse-jvm-invokevirtual "jvm-invokevirtual"
@@ -179,9 +166,7 @@
(return (&/|list (&/V "jvm-class" (&/T $module ?name ?super-class =fields {}))))))
(defn analyse-jvm-interface [analyse ?name ?members]
- ;; (prn 'analyse-jvm-interface ?name ?members)
(|do [=members (&/map% (fn [member]
- ;; (prn 'analyse-jvm-interface (&/show-ast member))
(matchv ::M/objects [member]
[["lux;Meta" [_ ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" ["" ":'"]]]]
["lux;Cons" [["lux;Meta" [_ ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "->"]]]]
@@ -190,15 +175,13 @@
["lux;Nil" _]]]]]]]]]]
["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ ?member-name]]]]
["lux;Nil" _]]]]]]]]]]]
- (do ;; (prn 'analyse-jvm-interface ?member-name ?inputs ?output)
- (|do [inputs* (&/map% extract-ident ?inputs)]
- (return [?member-name [inputs* ?output]])))
+ (|do [inputs* (&/map% extract-ident ?inputs)]
+ (return [?member-name [inputs* ?output]]))
[_]
(fail "[Analyser Error] Invalid method signature!")))
?members)
- :let [;; _ (prn '=members =members)
- =methods (into {} (for [[method [inputs output]] (&/->seq =members)]
+ :let [=methods (into {} (for [[method [inputs output]] (&/->seq =members)]
[method {:access :public
:type [inputs output]}]))]
$module &/get-module-name]
@@ -270,11 +253,7 @@
)
(defn analyse-jvm-program [analyse ?args ?body]
- (|do [;; =body (&&env/with-local ?args (&/V "lux;AppT" (&/T &type/List &type/Text))
- ;; (&&/analyse-1 analyse ?body))
- =body (&/with-scope ""
+ (|do [=body (&/with-scope ""
(&&env/with-local "" (&/V "lux;AppT" (&/T &type/List &type/Text))
- (analyse-1+ analyse ?body)))
- ;; =body (analyse-1+ analyse ?body)
- ]
+ (analyse-1+ analyse ?body)))]
(return (&/|list (&/V "jvm-program" =body)))))
diff --git a/src/lux/analyser/lambda.clj b/src/lux/analyser/lambda.clj
index 859f47e56..4dd1be38f 100644
--- a/src/lux/analyser/lambda.clj
+++ b/src/lux/analyser/lambda.clj
@@ -8,8 +8,6 @@
;; [Resource]
(defn with-lambda [self self-type arg arg-type body]
- ;; (prn 'with-lambda (&/|length self) (&/|length arg))
- ;; (prn 'with-lambda [(aget self 0) (aget self 1)] [(aget arg 0) (aget arg 1)] (alength self) (alength arg))
(|let [[?module1 ?name1] self
[?module2 ?name2] arg]
(&/with-closure
@@ -21,11 +19,6 @@
(return (&/T scope-name =captured =return)))))))))
(defn close-over [scope ident register frame]
- ;; (prn 'close-over
- ;; (&host/location scope)
- ;; (&host/location (&/|list ident))
- ;; register
- ;; (->> frame (&/get$ &/$CLOSURE) (&/get$ &/$COUNTER)))
(matchv ::M/objects [register]
[[_ register-type]]
(|let [register* (&/T (&/V "captured" (&/T scope
diff --git a/src/lux/analyser/lux.clj b/src/lux/analyser/lux.clj
index 2a68e0aeb..d461d5b6b 100644
--- a/src/lux/analyser/lux.clj
+++ b/src/lux/analyser/lux.clj
@@ -15,7 +15,6 @@
(defn ^:private analyse-1+ [analyse ?token]
(&type/with-var
(fn [$var]
- ;; (prn 'analyse-1+ (aget $var 1) (&/show-ast ?token))
(|do [=expr (&&/analyse-1 analyse $var ?token)]
(matchv ::M/objects [=expr]
[[?item ?type]]
@@ -25,9 +24,6 @@
;; [Exports]
(defn analyse-tuple [analyse exo-type ?elems]
- ;; (prn "^^ analyse-tuple ^^")
- ;; (prn 'analyse-tuple (str "[" (->> ?elems (&/|map &/show-ast) (&/|interpose " ") (&/fold str "")) "]")
- ;; (&type/show-type exo-type))
(|do [exo-type* (&type/actual-type exo-type)]
(matchv ::M/objects [exo-type*]
[["lux;TupleT" ?members]]
@@ -48,9 +44,7 @@
(fail (str "[Analyser Error] Tuples require tuple-types: " (&type/show-type exo-type*))))))
(defn analyse-variant [analyse exo-type ident ?value]
- ;; (prn "^^ analyse-variant ^^")
- (|do [;; :let [_ (prn 'analyse-variant/exo-type (&type/show-type exo-type))]
- exo-type* (matchv ::M/objects [exo-type]
+ (|do [exo-type* (matchv ::M/objects [exo-type]
[["lux;VarT" ?id]]
(&/try-all% (&/|list (|do [exo-type* (&/try-all% (&/|list (&type/deref ?id)
(fail "##8##")))]
@@ -59,17 +53,12 @@
(&type/actual-type &type/Type))))
[_]
- (&type/actual-type exo-type))
- ;; :let [_ (prn 'analyse-variant/exo-type* (&type/show-type exo-type*))]
- ]
+ (&type/actual-type exo-type))]
(matchv ::M/objects [exo-type*]
[["lux;VariantT" ?cases]]
(|do [?tag (&&/resolved-ident ident)]
(if-let [vtype (&/|get ?tag ?cases)]
- (|do [;; :let [_ (prn 'VARIANT_BODY ?tag (&/show-ast ?value) (&type/show-type vtype))]
- =value (&&/analyse-1 analyse vtype ?value)
- ;; :let [_ (prn 'GOT_VALUE =value)]
- ]
+ (|do [=value (&&/analyse-1 analyse vtype ?value)]
(return (&/|list (&/T (&/V "variant" (&/T ?tag =value))
exo-type))))
(fail (str "[Analyser Error] There is no case " ?tag " for variant type " (&type/show-type exo-type*)))))
@@ -105,7 +94,6 @@
slot-type (if-let [slot-type (&/|get ?tag types)]
(return slot-type)
(fail (str "[Analyser Error] Record type does not have slot: " ?tag)))
- ;; :let [_ (prn 'slot ?tag (&/show-ast ?value) (&type/show-type slot-type))]
=value (&&/analyse-1 analyse slot-type ?value)]
(return (&/T ?tag =value)))
@@ -118,101 +106,77 @@
(|do [module-name &/get-module-name]
(fn [state]
(|let [[?module ?name] ident
- ;; _ (prn 'analyse-symbol ?module ?name)
local-ident (str ?module ";" ?name)
stack (&/get$ &/$ENVS state)
no-binding? #(and (->> % (&/get$ &/$LOCALS) (&/get$ &/$MAPPINGS) (&/|contains? local-ident) not)
(->> % (&/get$ &/$CLOSURE) (&/get$ &/$MAPPINGS) (&/|contains? local-ident) not))
[inner outer] (&/|split-with no-binding? stack)]
- (do ;; (when (= "<" ?name)
- ;; (prn 'HALLO (&/|length inner) (&/|length outer)))
- (matchv ::M/objects [outer]
- [["lux;Nil" _]]
- (&/run-state (|do [[[r-module r-name] $def] (&&module/find-def (if (= "" ?module) module-name ?module)
- ?name)
- endo-type (matchv ::M/objects [$def]
- [["lux;ValueD" ?type]]
- (return ?type)
-
- [["lux;MacroD" _]]
- (return &type/Macro)
-
- [["lux;TypeD" _]]
- (return &type/Type))
- ;; :let [_ (println "Got endo-type:" endo-type)]
- _ (if (and (= &type/Type endo-type) (= &type/Type exo-type))
- (do ;; (println "OH YEAH" (if (= "" ?module) module-name ?module)
- ;; ?name)
- (return nil))
- (&type/check exo-type endo-type))
- ;; :let [_ (println "Type-checked:" exo-type endo-type)]
- ]
- (return (&/|list (&/T (&/V "lux;Global" (&/T r-module r-name))
- endo-type))))
- state)
-
- [["lux;Cons" [?genv ["lux;Nil" _]]]]
- (if-let [global (->> ?genv (&/get$ &/$LOCALS) (&/get$ &/$MAPPINGS) (&/|get local-ident))]
- (do (when (= "<" ?name)
- (prn 'GOT_GLOBAL local-ident))
- (matchv ::M/objects [global]
- [[["lux;Global" [?module* ?name*]] _]]
- (&/run-state (|do [;; :let [_ (prn 'GLOBAL/_1 ?module* ?name*)]
- ;; :let [_ (when (= "<" ?name)
- ;; (println "Pre Found def:" ?module* ?name*))]
- [[r-module r-name] $def] (&&module/find-def ?module* ?name*)
- ;; :let [_ (prn 'GLOBAL/_2 r-module r-name)]
- ;; :let [_ (when (= "<" ?name)
- ;; (println "Found def:" r-module r-name))]
- endo-type (matchv ::M/objects [$def]
- [["lux;ValueD" ?type]]
- (return ?type)
-
- [["lux;MacroD" _]]
- (return &type/Macro)
-
- [["lux;TypeD" _]]
- (return &type/Type))
- ;; :let [_ (println "Got endo-type:" endo-type)]
- _ (if (and (= &type/Type endo-type) (= &type/Type exo-type))
- (do ;; (println "OH YEAH" ?module* ?name*)
- (return nil))
- (&type/check exo-type endo-type))
- ;; :let [_ (println "Type-checked:" exo-type endo-type)]
- ;; :let [_ (when (= "<" ?name)
- ;; (println "Returnin'"))]
- ]
- (return (&/|list (&/T (&/V "lux;Global" (&/T r-module r-name))
- endo-type))))
- state)
-
- [_]
- (fail* "[Analyser Error] Can't have anything other than a global def in the global environment.")))
- (fail* ""))
-
- [["lux;Cons" [top-outer _]]]
- (|let [scopes (&/|tail (&/folds #(&/|cons (&/get$ &/$NAME %2) %1)
- (&/|map #(&/get$ &/$NAME %) outer)
- (&/|reverse inner)))
- [=local inner*] (&/fold (fn [register+new-inner frame+in-scope]
- (|let [[register new-inner] register+new-inner
- [frame in-scope] frame+in-scope
- [register* frame*] (&&lambda/close-over (&/|cons module-name (&/|reverse in-scope)) ident register frame)]
- (&/T register* (&/|cons frame* new-inner))))
- (&/T (or (->> top-outer (&/get$ &/$LOCALS) (&/get$ &/$MAPPINGS) (&/|get local-ident))
- (->> top-outer (&/get$ &/$CLOSURE) (&/get$ &/$MAPPINGS) (&/|get local-ident)))
- (&/|list))
- (&/zip2 (&/|reverse inner) scopes))]
- (&/run-state (|do [btype (&&/expr-type =local)
- _ (&type/check exo-type btype)]
- (return (&/|list =local)))
- (&/set$ &/$ENVS (&/|++ inner* outer) state)))
- ))))
+ (matchv ::M/objects [outer]
+ [["lux;Nil" _]]
+ (&/run-state (|do [[[r-module r-name] $def] (&&module/find-def (if (= "" ?module) module-name ?module)
+ ?name)
+ endo-type (matchv ::M/objects [$def]
+ [["lux;ValueD" ?type]]
+ (return ?type)
+
+ [["lux;MacroD" _]]
+ (return &type/Macro)
+
+ [["lux;TypeD" _]]
+ (return &type/Type))
+ _ (if (and (= &type/Type endo-type) (= &type/Type exo-type))
+ (return nil)
+ (&type/check exo-type endo-type))]
+ (return (&/|list (&/T (&/V "lux;Global" (&/T r-module r-name))
+ endo-type))))
+ state)
+
+ [["lux;Cons" [?genv ["lux;Nil" _]]]]
+ (if-let [global (->> ?genv (&/get$ &/$LOCALS) (&/get$ &/$MAPPINGS) (&/|get local-ident))]
+ (matchv ::M/objects [global]
+ [[["lux;Global" [?module* ?name*]] _]]
+ (&/run-state (|do [[[r-module r-name] $def] (&&module/find-def ?module* ?name*)
+ endo-type (matchv ::M/objects [$def]
+ [["lux;ValueD" ?type]]
+ (return ?type)
+
+ [["lux;MacroD" _]]
+ (return &type/Macro)
+
+ [["lux;TypeD" _]]
+ (return &type/Type))
+ _ (if (and (= &type/Type endo-type) (= &type/Type exo-type))
+ (return nil)
+ (&type/check exo-type endo-type))]
+ (return (&/|list (&/T (&/V "lux;Global" (&/T r-module r-name))
+ endo-type))))
+ state)
+
+ [_]
+ (fail* "[Analyser Error] Can't have anything other than a global def in the global environment."))
+ (fail* ""))
+
+ [["lux;Cons" [top-outer _]]]
+ (|let [scopes (&/|tail (&/folds #(&/|cons (&/get$ &/$NAME %2) %1)
+ (&/|map #(&/get$ &/$NAME %) outer)
+ (&/|reverse inner)))
+ [=local inner*] (&/fold (fn [register+new-inner frame+in-scope]
+ (|let [[register new-inner] register+new-inner
+ [frame in-scope] frame+in-scope
+ [register* frame*] (&&lambda/close-over (&/|cons module-name (&/|reverse in-scope)) ident register frame)]
+ (&/T register* (&/|cons frame* new-inner))))
+ (&/T (or (->> top-outer (&/get$ &/$LOCALS) (&/get$ &/$MAPPINGS) (&/|get local-ident))
+ (->> top-outer (&/get$ &/$CLOSURE) (&/get$ &/$MAPPINGS) (&/|get local-ident)))
+ (&/|list))
+ (&/zip2 (&/|reverse inner) scopes))]
+ (&/run-state (|do [btype (&&/expr-type =local)
+ _ (&type/check exo-type btype)]
+ (return (&/|list =local)))
+ (&/set$ &/$ENVS (&/|++ inner* outer) state)))
+ )))
))
(defn ^:private analyse-apply* [analyse exo-type =fn ?args]
- ;; (prn 'analyse-apply* (&/->seq (&/|map &/show-ast ?args)))
- ;; (prn 'analyse-apply*/exo-type (&type/show-type exo-type))
(matchv ::M/objects [=fn]
[[?fun-expr ?fun-type]]
(matchv ::M/objects [?args]
@@ -230,11 +194,6 @@
output (analyse-apply* analyse exo-type (&/T ?fun-expr type*) ?args)]
(matchv ::M/objects [output $var]
[[?expr* ?type*] ["lux;VarT" ?id]]
- ;; (|do [? (&type/bound? ?id)]
- ;; (if ?
- ;; (return (&/T ?expr* ?type*))
- ;; (|do [type** (&type/clean $var ?type*)]
- ;; (return (&/T ?expr* type**)))))
(|do [? (&type/bound? ?id)
_ (if ?
(return nil)
@@ -245,9 +204,6 @@
))))
[["lux;LambdaT" [?input-t ?output-t]]]
- ;; (|do [=arg (&&/analyse-1 analyse ?input-t ?arg)]
- ;; (return (&/T (&/V "apply" (&/T =fn =arg))
- ;; ?output-t)))
(|do [=arg (&&/analyse-1 analyse ?input-t ?arg)]
(analyse-apply* analyse exo-type (&/T (&/V "apply" (&/T =fn =arg))
?output-t)
@@ -258,58 +214,37 @@
)))
(defn analyse-apply [analyse exo-type =fn ?args]
- ;; (prn 'analyse-apply1 (aget =fn 0))
(|do [loader &/loader]
(matchv ::M/objects [=fn]
[[=fn-form =fn-type]]
- (do ;; (prn 'analyse-apply2 (aget =fn-form 0))
- (matchv ::M/objects [=fn-form]
- [["lux;Global" [?module ?name]]]
- (|do [[[r-module r-name] $def] (&&module/find-def ?module ?name)
- ;; :let [_ (prn 'apply [?module ?name] (aget $def 0))]
- ]
- (matchv ::M/objects [$def]
- [["lux;MacroD" macro]]
- (|do [macro-expansion #(-> macro (.apply ?args) (.apply %))
- ;; :let [_ (cond (= ?name "using")
- ;; (println (str "using: " (->> macro-expansion (&/|map &/show-ast) (&/|interpose " ") (&/fold str ""))))
-
- ;; ;; (= ?name "def")
- ;; ;; (println (str "def " ?module ";" ?name ": " (->> macro-expansion (&/|map &/show-ast) (&/|interpose " ") (&/fold str ""))))
-
- ;; ;; (= ?name "type`")
- ;; ;; (println (str "type`: " (->> macro-expansion (&/|map &/show-ast) (&/|interpose " ") (&/fold str ""))))
-
- ;; :else
- ;; nil)]
- ]
- (&/flat-map% (partial analyse exo-type) macro-expansion))
+ (matchv ::M/objects [=fn-form]
+ [["lux;Global" [?module ?name]]]
+ (|do [[[r-module r-name] $def] (&&module/find-def ?module ?name)]
+ (matchv ::M/objects [$def]
+ [["lux;MacroD" macro]]
+ (|do [macro-expansion #(-> macro (.apply ?args) (.apply %))]
+ (&/flat-map% (partial analyse exo-type) macro-expansion))
- [_]
- (|do [output (analyse-apply* analyse exo-type =fn ?args)]
- (return (&/|list output)))))
-
[_]
(|do [output (analyse-apply* analyse exo-type =fn ?args)]
(return (&/|list output)))))
+
+ [_]
+ (|do [output (analyse-apply* analyse exo-type =fn ?args)]
+ (return (&/|list output))))
)))
(defn analyse-case [analyse exo-type ?value ?branches]
- ;; (prn 'analyse-case 'exo-type (&type/show-type exo-type) (&/show-ast ?value))
(|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)
=value-type (&&/expr-type =value)
- ;; :let [_ (prn 'analyse-case/GOT_VALUE (&type/show-type =value-type))]
- =match (&&case/analyse-branches analyse exo-type =value-type (&/|as-pairs ?branches))
- ;; :let [_ (prn 'analyse-case/GOT_MATCH)]
- ]
+ =match (&&case/analyse-branches analyse exo-type =value-type (&/|as-pairs ?branches))]
(return (&/|list (&/T (&/V "case" (&/T =value =match))
exo-type)))))
(defn analyse-lambda* [analyse exo-type ?self ?arg ?body]
- ;; (prn 'analyse-lambda ?self ?arg ?body)
(matchv ::M/objects [exo-type]
[["lux;LambdaT" [?arg-t ?return-t]]]
(|do [[=scope =captured =body] (&&lambda/with-lambda ?self exo-type
@@ -319,13 +254,9 @@
[_]
(fail (str "[Analyser Error] Functions require function types: "
- ;; (str (aget ?self 0) ";" (aget ?self 1))
- ;; (str( aget ?arg 0) ";" (aget ?arg 1))
- ;; (&/show-ast ?body)
(&type/show-type exo-type)))))
(defn analyse-lambda** [analyse exo-type ?self ?arg ?body]
- ;; (prn 'analyse-lambda**/&& (aget exo-type 0))
(matchv ::M/objects [exo-type]
[["lux;AllT" [_env _self _arg _body]]]
(&type/with-var
@@ -351,44 +282,19 @@
(analyse-lambda* analyse exo-type* ?self ?arg ?body))
))
-;; (defn analyse-lambda** [analyse exo-type ?self ?arg ?body]
-;; ;; (prn 'analyse-lambda**/&& (aget exo-type 0))
-;; (matchv ::M/objects [exo-type]
-;; [["lux;AllT" [_env _self _arg _body]]]
-;; (&type/with-var
-;; (fn [$var]
-;; (|do [exo-type* (&type/apply-type exo-type $var)
-;; output (analyse-lambda** analyse exo-type* ?self ?arg ?body)]
-;; (matchv ::M/objects [$var]
-;; [["lux;VarT" ?id]]
-;; (|do [? (&type/bound? ?id)]
-;; (if ?
-;; (|do [dtype (&type/deref ?id)]
-;; (fail (str "[Analyser Error] Can't use type-var in any type-specific way inside polymorphic functions: " ?id ":" _arg " " (&type/show-type dtype))))
-;; (return output)))))))
-
-;; [_]
-;; (|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 (analyse-lambda** analyse exo-type ?self ?arg ?body)]
(return (&/|list output))))
(defn analyse-def [analyse ?name ?value]
- ;; (prn 'analyse-def/CODE ?name (&/show-ast ?value))
(prn 'analyse-def/BEGIN ?name)
(|do [module-name &/get-module-name
? (&&module/defined? module-name ?name)]
(if ?
(fail (str "[Analyser Error] Can't redefine " ?name))
- (|do [;; :let [_ (prn 'analyse-def/_0)]
- =value (&/with-scope ?name
+ (|do [=value (&/with-scope ?name
(analyse-1+ analyse ?value))
- =value-type (&&/expr-type =value)
- ;; :let [_ (prn 'analyse-def/_1 [?name ?value] (aget =value 0 0))]
- ]
+ =value-type (&&/expr-type =value)]
(matchv ::M/objects [=value]
[[["lux;Global" [?r-module ?r-name]] _]]
(|do [_ (&&module/def-alias module-name ?name ?r-module ?r-name =value-type)
@@ -410,11 +316,6 @@
))))
(defn analyse-declare-macro [analyse ?name]
- (|do [module-name &/get-module-name
- _ (&&module/declare-macro module-name ?name)]
- (return (&/|list))))
-
-(defn analyse-declare-macro [analyse ?name]
(|do [module-name &/get-module-name]
(return (&/|list (&/V "declare-macro" (&/T module-name ?name))))))
@@ -427,16 +328,10 @@
(return (&/|list))))
(defn analyse-check [analyse eval! exo-type ?type ?value]
- ;; (println "analyse-check#0")
(|do [=type (&&/analyse-1 analyse &type/Type ?type)
- ;; =type (analyse-1+ analyse ?type)
- ;; :let [_ (println "analyse-check#1")]
==type (eval! =type)
_ (&type/check exo-type ==type)
- ;; :let [_ (println "analyse-check#4" (&type/show-type ==type))]
- =value (&&/analyse-1 analyse ==type ?value)
- ;; :let [_ (println "analyse-check#5")]
- ]
+ =value (&&/analyse-1 analyse ==type ?value)]
(matchv ::M/objects [=value]
[[?expr ?expr-type]]
(return (&/|list (&/T ?expr ==type))))))
diff --git a/src/lux/analyser/module.clj b/src/lux/analyser/module.clj
index de68f48aa..5960d3080 100644
--- a/src/lux/analyser/module.clj
+++ b/src/lux/analyser/module.clj
@@ -32,7 +32,6 @@
(defn def-alias [a-module a-name r-module r-name type]
(fn [state]
- ;; (prn 'def-alias [a-module a-name] '=> [r-module r-name])
(matchv ::M/objects [(&/get$ &/$ENVS state)]
[["lux;Cons" [?env ["lux;Nil" _]]]]
(return* (->> state
@@ -53,7 +52,6 @@
(defn exists? [name]
(fn [state]
- ;; (prn `exists? name (->> state (&/get$ &/$MODULES) (&/|contains? name)))
(return* state
(->> state (&/get$ &/$MODULES) (&/|contains? name)))))
@@ -96,20 +94,19 @@
(if-let [$def (&/|get name $module)]
(matchv ::M/objects [$def]
[[exported? ["lux;ValueD" ?type]]]
- (do ;; (prn 'declare-macro/?type (aget ?type 0))
- (&/run-state (|do [_ (&type/check &type/Macro ?type)
- ^ClassLoader loader &/loader
- :let [macro (-> (.loadClass loader (&host/location (&/|list module name)))
- (.getField "_datum")
- (.get nil))]]
- (fn [state*]
- (return* (&/update$ &/$MODULES
- (fn [$modules]
- (&/|put module (&/|put name (&/T exported? (&/V "lux;MacroD" macro)) $module)
- $modules))
- state*)
- nil)))
- state))
+ (&/run-state (|do [_ (&type/check &type/Macro ?type)
+ ^ClassLoader loader &/loader
+ :let [macro (-> (.loadClass loader (&host/location (&/|list module name)))
+ (.getField "_datum")
+ (.get nil))]]
+ (fn [state*]
+ (return* (&/update$ &/$MODULES
+ (fn [$modules]
+ (&/|put module (&/|put name (&/T exported? (&/V "lux;MacroD" macro)) $module)
+ $modules))
+ state*)
+ nil)))
+ state)
[[_ ["lux;MacroD" _]]]
(fail* (str "[Analyser Error] Can't re-declare a macro: " (str module &/+name-separator+ name)))
diff --git a/src/lux/base.clj b/src/lux/base.clj
index 70a658d19..283d06f52 100644
--- a/src/lux/base.clj
+++ b/src/lux/base.clj
@@ -81,7 +81,6 @@
(reverse (partition 2 elems))))
(defn |get [slot table]
- ;; (prn '|get slot (aget table 0))
(matchv ::M/objects [table]
[["lux;Nil" _]]
nil
@@ -112,7 +111,6 @@
(V "lux;Cons" (T (T k v) (|remove slot table*))))))
(defn |merge [table1 table2]
- ;; (prn '|merge (aget table1 0) (aget table2 0))
(matchv ::M/objects [table2]
[["lux;Nil" _]]
table1
@@ -149,7 +147,6 @@
;; [Resources/Monads]
(defn fail [message]
(fn [_]
- ;; (prn 'FAIL message)
(V "lux;Left" message)))
(defn return [value]
@@ -178,10 +175,7 @@
(fn [val#]
(matchv ::M/objects [val#]
[~label]
- ~inner)))
- ;; `(bind ~computation
- ;; (fn [~label] ~inner))
- ))
+ ~inner)))))
return
(reverse (partition 2 steps))))
@@ -199,7 +193,6 @@
(V "lux;Cons" (T head tail)))
(defn |++ [xs ys]
- ;; (prn '|++ (and xs (aget xs 0)) (and ys (aget ys 0)))
(matchv ::M/objects [xs]
[["lux;Nil" _]]
ys
@@ -208,7 +201,6 @@
(V "lux;Cons" (T x (|++ xs* ys)))))
(defn |map [f xs]
- ;; (prn '|map (aget xs 0))
(matchv ::M/objects [xs]
[["lux;Nil" _]]
xs
@@ -288,7 +280,6 @@
(|cons init (folds f (f init x) xs*))))
(defn |length [xs]
- ;; (prn '|length (aget xs 0))
(fold (fn [acc _] (inc acc)) 0 xs))
(let [|range* (fn |range* [from to]
@@ -343,16 +334,13 @@
(do-template [<name> <joiner>]
(defn <name> [f xs]
- ;; (prn '<name> 0 (aget xs 0))
(matchv ::M/objects [xs]
[["lux;Nil" _]]
(return xs)
[["lux;Cons" [x xs*]]]
(|do [y (f x)
- ;; :let [_ (prn '<name> 1 (class y))
- ;; _ (prn '<name> 2 (aget y 0))]
- ys (<name> f xs*)]
+ ys (<name> f xs*)]
(return (<joiner> y ys)))))
map% |cons
@@ -373,7 +361,6 @@
xs))
(defn show-table [table]
- ;; (prn 'show-table (aget table 0))
(str "{{"
(->> table
(|map (fn [kv] (|let [[k v] kv] (str k " = ???"))))
@@ -383,9 +370,7 @@
(defn apply% [monad call-state]
(fn [state]
- ;; (prn 'apply-m monad call-state)
(let [output (monad call-state)]
- ;; (prn 'apply-m/output output)
(matchv ::M/objects [output]
[["lux;Right" [?state ?datum]]]
(return* state ?datum)
@@ -469,12 +454,6 @@
(return nil)
(fail msg)))
state)
- ;; (if (= "[Reader Error] EOF" msg)
- ;; ((|do [? source-consumed?
- ;; :let [_ (prn '? ?)]]
- ;; (return nil))
- ;; state)
- ;; (fail* msg))
)))
(defn ^:private normalize-char [char]
@@ -569,8 +548,6 @@
(def get-writer
(fn [state]
(let [writer* (->> state (get$ $HOST) (get$ $WRITER))]
- ;; (prn 'get-writer (class writer*))
- ;; (prn 'get-writer (aget writer* 0))
(matchv ::M/objects [writer*]
[["lux;Some" datum]]
(return* state datum)
@@ -656,16 +633,6 @@
output))))
(defn show-ast [ast]
- ;; (prn 'show-ast (aget ast 0))
- ;; (prn 'show-ast (aget ast 1 1 0))
- ;; (cond (= "lux;Meta" (aget ast 1 1 0))
- ;; (prn 'EXTRA 'show-ast (aget ast 1 1 1 1 0))
-
- ;; (= "lux;Symbol" (aget ast 1 1 0))
- ;; (prn 'EXTRA 'show-ast (aget ast 1 1 1 1))
-
- ;; :else
- ;; nil)
(matchv ::M/objects [ast]
[["lux;Meta" [_ ["lux;Bool" ?value]]]]
(pr-str ?value)
@@ -707,3 +674,40 @@
(defn ident->text [ident]
(|let [[?module ?name] ident]
(str ?module ";" ?name)))
+
+(defn map2% [f xs ys]
+ (matchv ::M/objects [xs ys]
+ [["lux;Cons" [x xs*]] ["lux;Cons" [y ys*]]]
+ (|do [z (f x y)
+ zs (map2% f xs* ys*)]
+ (return (|cons z zs)))
+
+ [["lux;Nil" _] ["lux;Nil" _]]
+ (return (V "lux;Nil" nil))
+
+ [_ _]
+ (fail "Lists don't match in size.")))
+
+(defn fold2% [f init xs ys]
+ (matchv ::M/objects [xs ys]
+ [["lux;Cons" [x xs*]] ["lux;Cons" [y ys*]]]
+ (|do [init* (f init x y)]
+ (fold2% f init* xs* ys*))
+
+ [["lux;Nil" _] ["lux;Nil" _]]
+ (return init)
+
+ [_ _]
+ (fail "Lists don't match in size.")))
+
+(defn fold2 [f init xs ys]
+ (matchv ::M/objects [xs ys]
+ [["lux;Cons" [x xs*]] ["lux;Cons" [y ys*]]]
+ (and init
+ (fold2 f (f init x y) xs* ys*))
+
+ [["lux;Nil" _] ["lux;Nil" _]]
+ init
+
+ [_ _]
+ false))
diff --git a/src/lux/compiler.clj b/src/lux/compiler.clj
index 5a9f1b39d..f970540c9 100644
--- a/src/lux/compiler.clj
+++ b/src/lux/compiler.clj
@@ -19,9 +19,7 @@
[lux :as &&lux]
[host :as &&host]
[case :as &&case]
- [lambda :as &&lambda])
- ;; :reload
- )
+ [lambda :as &&lambda]))
(:import (org.objectweb.asm Opcodes
Label
ClassWriter
@@ -29,280 +27,277 @@
;; [Utils/Compilers]
(defn ^:private compile-expression [syntax]
- ;; (prn 'compile-expression (aget syntax 0))
(matchv ::M/objects [syntax]
[[?form ?type]]
- (do ;; (prn 'compile-expression2 (aget ?form 0))
- (matchv ::M/objects [?form]
- [["bool" ?value]]
- (&&lux/compile-bool compile-expression ?type ?value)
-
- [["int" ?value]]
- (&&lux/compile-int compile-expression ?type ?value)
-
- [["real" ?value]]
- (&&lux/compile-real compile-expression ?type ?value)
-
- [["char" ?value]]
- (&&lux/compile-char compile-expression ?type ?value)
-
- [["text" ?value]]
- (&&lux/compile-text compile-expression ?type ?value)
-
- [["tuple" ?elems]]
- (&&lux/compile-tuple compile-expression ?type ?elems)
-
- [["record" ?elems]]
- (&&lux/compile-record compile-expression ?type ?elems)
-
- [["lux;Local" ?idx]]
- (&&lux/compile-local compile-expression ?type ?idx)
-
- [["captured" [?scope ?captured-id ?source]]]
- (&&lux/compile-captured compile-expression ?type ?scope ?captured-id ?source)
-
- [["lux;Global" [?owner-class ?name]]]
- (&&lux/compile-global compile-expression ?type ?owner-class ?name)
-
- [["apply" [?fn ?arg]]]
- (&&lux/compile-apply compile-expression ?type ?fn ?arg)
-
- [["variant" [?tag ?members]]]
- (&&lux/compile-variant compile-expression ?type ?tag ?members)
-
- [["case" [?value ?match]]]
- (&&case/compile-case compile-expression ?type ?value ?match)
-
- [["lambda" [?scope ?env ?body]]]
- (&&lambda/compile-lambda compile-expression ?scope ?env ?body)
-
- ;; Integer arithmetic
- [["jvm-iadd" [?x ?y]]]
- (&&host/compile-jvm-iadd compile-expression ?type ?x ?y)
-
- [["jvm-isub" [?x ?y]]]
- (&&host/compile-jvm-isub compile-expression ?type ?x ?y)
-
- [["jvm-imul" [?x ?y]]]
- (&&host/compile-jvm-imul compile-expression ?type ?x ?y)
-
- [["jvm-idiv" [?x ?y]]]
- (&&host/compile-jvm-idiv compile-expression ?type ?x ?y)
-
- [["jvm-irem" [?x ?y]]]
- (&&host/compile-jvm-irem compile-expression ?type ?x ?y)
-
- [["jvm-ieq" [?x ?y]]]
- (&&host/compile-jvm-ieq compile-expression ?type ?x ?y)
-
- [["jvm-ilt" [?x ?y]]]
- (&&host/compile-jvm-ilt compile-expression ?type ?x ?y)
-
- [["jvm-igt" [?x ?y]]]
- (&&host/compile-jvm-igt compile-expression ?type ?x ?y)
-
- ;; Long arithmetic
- [["jvm-ladd" [?x ?y]]]
- (&&host/compile-jvm-ladd compile-expression ?type ?x ?y)
-
- [["jvm-lsub" [?x ?y]]]
- (&&host/compile-jvm-lsub compile-expression ?type ?x ?y)
-
- [["jvm-lmul" [?x ?y]]]
- (&&host/compile-jvm-lmul compile-expression ?type ?x ?y)
-
- [["jvm-ldiv" [?x ?y]]]
- (&&host/compile-jvm-ldiv compile-expression ?type ?x ?y)
-
- [["jvm-lrem" [?x ?y]]]
- (&&host/compile-jvm-lrem compile-expression ?type ?x ?y)
-
- [["jvm-leq" [?x ?y]]]
- (&&host/compile-jvm-leq compile-expression ?type ?x ?y)
-
- [["jvm-llt" [?x ?y]]]
- (&&host/compile-jvm-llt compile-expression ?type ?x ?y)
-
- [["jvm-lgt" [?x ?y]]]
- (&&host/compile-jvm-lgt compile-expression ?type ?x ?y)
-
- ;; Float arithmetic
- [["jvm-fadd" [?x ?y]]]
- (&&host/compile-jvm-fadd compile-expression ?type ?x ?y)
-
- [["jvm-fsub" [?x ?y]]]
- (&&host/compile-jvm-fsub compile-expression ?type ?x ?y)
-
- [["jvm-fmul" [?x ?y]]]
- (&&host/compile-jvm-fmul compile-expression ?type ?x ?y)
-
- [["jvm-fdiv" [?x ?y]]]
- (&&host/compile-jvm-fdiv compile-expression ?type ?x ?y)
-
- [["jvm-frem" [?x ?y]]]
- (&&host/compile-jvm-frem compile-expression ?type ?x ?y)
-
- [["jvm-feq" [?x ?y]]]
- (&&host/compile-jvm-feq compile-expression ?type ?x ?y)
-
- [["jvm-flt" [?x ?y]]]
- (&&host/compile-jvm-flt compile-expression ?type ?x ?y)
-
- [["jvm-fgt" [?x ?y]]]
- (&&host/compile-jvm-fgt compile-expression ?type ?x ?y)
-
- ;; Double arithmetic
- [["jvm-dadd" [?x ?y]]]
- (&&host/compile-jvm-dadd compile-expression ?type ?x ?y)
-
- [["jvm-dsub" [?x ?y]]]
- (&&host/compile-jvm-dsub compile-expression ?type ?x ?y)
-
- [["jvm-dmul" [?x ?y]]]
- (&&host/compile-jvm-dmul compile-expression ?type ?x ?y)
-
- [["jvm-ddiv" [?x ?y]]]
- (&&host/compile-jvm-ddiv compile-expression ?type ?x ?y)
-
- [["jvm-drem" [?x ?y]]]
- (&&host/compile-jvm-drem compile-expression ?type ?x ?y)
-
- [["jvm-deq" [?x ?y]]]
- (&&host/compile-jvm-deq compile-expression ?type ?x ?y)
-
- [["jvm-dlt" [?x ?y]]]
- (&&host/compile-jvm-dlt compile-expression ?type ?x ?y)
-
- [["jvm-dgt" [?x ?y]]]
- (&&host/compile-jvm-dgt compile-expression ?type ?x ?y)
-
- [["jvm-null" _]]
- (&&host/compile-jvm-null compile-expression ?type)
-
- [["jvm-null?" ?object]]
- (&&host/compile-jvm-null? compile-expression ?type ?object)
-
- [["jvm-new" [?class ?classes ?args]]]
- (&&host/compile-jvm-new compile-expression ?type ?class ?classes ?args)
-
- [["jvm-getstatic" [?class ?field]]]
- (&&host/compile-jvm-getstatic compile-expression ?type ?class ?field)
-
- [["jvm-getfield" [?class ?field ?object]]]
- (&&host/compile-jvm-getfield compile-expression ?type ?class ?field ?object)
-
- [["jvm-putstatic" [?class ?field ?value]]]
- (&&host/compile-jvm-putstatic compile-expression ?type ?class ?field ?value)
-
- [["jvm-putfield" [?class ?field ?object ?value]]]
- (&&host/compile-jvm-putfield compile-expression ?type ?class ?field ?object ?value)
-
- [["jvm-invokestatic" [?class ?method ?classes ?args]]]
- (&&host/compile-jvm-invokestatic compile-expression ?type ?class ?method ?classes ?args)
-
- [["jvm-invokevirtual" [?class ?method ?classes ?object ?args]]]
- (&&host/compile-jvm-invokevirtual compile-expression ?type ?class ?method ?classes ?object ?args)
-
- [["jvm-invokeinterface" [?class ?method ?classes ?object ?args]]]
- (&&host/compile-jvm-invokeinterface compile-expression ?type ?class ?method ?classes ?object ?args)
-
- [["jvm-invokespecial" [?class ?method ?classes ?object ?args]]]
- (&&host/compile-jvm-invokespecial compile-expression ?type ?class ?method ?classes ?object ?args)
-
- [["jvm-new-array" [?class ?length]]]
- (&&host/compile-jvm-new-array compile-expression ?type ?class ?length)
+ (matchv ::M/objects [?form]
+ [["bool" ?value]]
+ (&&lux/compile-bool compile-expression ?type ?value)
+
+ [["int" ?value]]
+ (&&lux/compile-int compile-expression ?type ?value)
+
+ [["real" ?value]]
+ (&&lux/compile-real compile-expression ?type ?value)
+
+ [["char" ?value]]
+ (&&lux/compile-char compile-expression ?type ?value)
+
+ [["text" ?value]]
+ (&&lux/compile-text compile-expression ?type ?value)
+
+ [["tuple" ?elems]]
+ (&&lux/compile-tuple compile-expression ?type ?elems)
+
+ [["record" ?elems]]
+ (&&lux/compile-record compile-expression ?type ?elems)
+
+ [["lux;Local" ?idx]]
+ (&&lux/compile-local compile-expression ?type ?idx)
+
+ [["captured" [?scope ?captured-id ?source]]]
+ (&&lux/compile-captured compile-expression ?type ?scope ?captured-id ?source)
+
+ [["lux;Global" [?owner-class ?name]]]
+ (&&lux/compile-global compile-expression ?type ?owner-class ?name)
+
+ [["apply" [?fn ?arg]]]
+ (&&lux/compile-apply compile-expression ?type ?fn ?arg)
+
+ [["variant" [?tag ?members]]]
+ (&&lux/compile-variant compile-expression ?type ?tag ?members)
+
+ [["case" [?value ?match]]]
+ (&&case/compile-case compile-expression ?type ?value ?match)
+
+ [["lambda" [?scope ?env ?body]]]
+ (&&lambda/compile-lambda compile-expression ?scope ?env ?body)
+
+ ;; Integer arithmetic
+ [["jvm-iadd" [?x ?y]]]
+ (&&host/compile-jvm-iadd compile-expression ?type ?x ?y)
+
+ [["jvm-isub" [?x ?y]]]
+ (&&host/compile-jvm-isub compile-expression ?type ?x ?y)
+
+ [["jvm-imul" [?x ?y]]]
+ (&&host/compile-jvm-imul compile-expression ?type ?x ?y)
+
+ [["jvm-idiv" [?x ?y]]]
+ (&&host/compile-jvm-idiv compile-expression ?type ?x ?y)
+
+ [["jvm-irem" [?x ?y]]]
+ (&&host/compile-jvm-irem compile-expression ?type ?x ?y)
+
+ [["jvm-ieq" [?x ?y]]]
+ (&&host/compile-jvm-ieq compile-expression ?type ?x ?y)
+
+ [["jvm-ilt" [?x ?y]]]
+ (&&host/compile-jvm-ilt compile-expression ?type ?x ?y)
+
+ [["jvm-igt" [?x ?y]]]
+ (&&host/compile-jvm-igt compile-expression ?type ?x ?y)
+
+ ;; Long arithmetic
+ [["jvm-ladd" [?x ?y]]]
+ (&&host/compile-jvm-ladd compile-expression ?type ?x ?y)
+
+ [["jvm-lsub" [?x ?y]]]
+ (&&host/compile-jvm-lsub compile-expression ?type ?x ?y)
+
+ [["jvm-lmul" [?x ?y]]]
+ (&&host/compile-jvm-lmul compile-expression ?type ?x ?y)
+
+ [["jvm-ldiv" [?x ?y]]]
+ (&&host/compile-jvm-ldiv compile-expression ?type ?x ?y)
+
+ [["jvm-lrem" [?x ?y]]]
+ (&&host/compile-jvm-lrem compile-expression ?type ?x ?y)
+
+ [["jvm-leq" [?x ?y]]]
+ (&&host/compile-jvm-leq compile-expression ?type ?x ?y)
+
+ [["jvm-llt" [?x ?y]]]
+ (&&host/compile-jvm-llt compile-expression ?type ?x ?y)
+
+ [["jvm-lgt" [?x ?y]]]
+ (&&host/compile-jvm-lgt compile-expression ?type ?x ?y)
+
+ ;; Float arithmetic
+ [["jvm-fadd" [?x ?y]]]
+ (&&host/compile-jvm-fadd compile-expression ?type ?x ?y)
+
+ [["jvm-fsub" [?x ?y]]]
+ (&&host/compile-jvm-fsub compile-expression ?type ?x ?y)
+
+ [["jvm-fmul" [?x ?y]]]
+ (&&host/compile-jvm-fmul compile-expression ?type ?x ?y)
+
+ [["jvm-fdiv" [?x ?y]]]
+ (&&host/compile-jvm-fdiv compile-expression ?type ?x ?y)
+
+ [["jvm-frem" [?x ?y]]]
+ (&&host/compile-jvm-frem compile-expression ?type ?x ?y)
+
+ [["jvm-feq" [?x ?y]]]
+ (&&host/compile-jvm-feq compile-expression ?type ?x ?y)
+
+ [["jvm-flt" [?x ?y]]]
+ (&&host/compile-jvm-flt compile-expression ?type ?x ?y)
+
+ [["jvm-fgt" [?x ?y]]]
+ (&&host/compile-jvm-fgt compile-expression ?type ?x ?y)
+
+ ;; Double arithmetic
+ [["jvm-dadd" [?x ?y]]]
+ (&&host/compile-jvm-dadd compile-expression ?type ?x ?y)
+
+ [["jvm-dsub" [?x ?y]]]
+ (&&host/compile-jvm-dsub compile-expression ?type ?x ?y)
+
+ [["jvm-dmul" [?x ?y]]]
+ (&&host/compile-jvm-dmul compile-expression ?type ?x ?y)
+
+ [["jvm-ddiv" [?x ?y]]]
+ (&&host/compile-jvm-ddiv compile-expression ?type ?x ?y)
+
+ [["jvm-drem" [?x ?y]]]
+ (&&host/compile-jvm-drem compile-expression ?type ?x ?y)
+
+ [["jvm-deq" [?x ?y]]]
+ (&&host/compile-jvm-deq compile-expression ?type ?x ?y)
+
+ [["jvm-dlt" [?x ?y]]]
+ (&&host/compile-jvm-dlt compile-expression ?type ?x ?y)
+
+ [["jvm-dgt" [?x ?y]]]
+ (&&host/compile-jvm-dgt compile-expression ?type ?x ?y)
+
+ [["jvm-null" _]]
+ (&&host/compile-jvm-null compile-expression ?type)
+
+ [["jvm-null?" ?object]]
+ (&&host/compile-jvm-null? compile-expression ?type ?object)
+
+ [["jvm-new" [?class ?classes ?args]]]
+ (&&host/compile-jvm-new compile-expression ?type ?class ?classes ?args)
+
+ [["jvm-getstatic" [?class ?field]]]
+ (&&host/compile-jvm-getstatic compile-expression ?type ?class ?field)
+
+ [["jvm-getfield" [?class ?field ?object]]]
+ (&&host/compile-jvm-getfield compile-expression ?type ?class ?field ?object)
+
+ [["jvm-putstatic" [?class ?field ?value]]]
+ (&&host/compile-jvm-putstatic compile-expression ?type ?class ?field ?value)
+
+ [["jvm-putfield" [?class ?field ?object ?value]]]
+ (&&host/compile-jvm-putfield compile-expression ?type ?class ?field ?object ?value)
+
+ [["jvm-invokestatic" [?class ?method ?classes ?args]]]
+ (&&host/compile-jvm-invokestatic compile-expression ?type ?class ?method ?classes ?args)
+
+ [["jvm-invokevirtual" [?class ?method ?classes ?object ?args]]]
+ (&&host/compile-jvm-invokevirtual compile-expression ?type ?class ?method ?classes ?object ?args)
+
+ [["jvm-invokeinterface" [?class ?method ?classes ?object ?args]]]
+ (&&host/compile-jvm-invokeinterface compile-expression ?type ?class ?method ?classes ?object ?args)
+
+ [["jvm-invokespecial" [?class ?method ?classes ?object ?args]]]
+ (&&host/compile-jvm-invokespecial compile-expression ?type ?class ?method ?classes ?object ?args)
+
+ [["jvm-new-array" [?class ?length]]]
+ (&&host/compile-jvm-new-array compile-expression ?type ?class ?length)
- [["jvm-aastore" [?array ?idx ?elem]]]
- (&&host/compile-jvm-aastore compile-expression ?type ?array ?idx ?elem)
+ [["jvm-aastore" [?array ?idx ?elem]]]
+ (&&host/compile-jvm-aastore compile-expression ?type ?array ?idx ?elem)
- [["jvm-aaload" [?array ?idx]]]
- (&&host/compile-jvm-aaload compile-expression ?type ?array ?idx)
+ [["jvm-aaload" [?array ?idx]]]
+ (&&host/compile-jvm-aaload compile-expression ?type ?array ?idx)
- [["jvm-try" [?body ?catches ?finally]]]
- (&&host/compile-jvm-try compile-expression ?type ?body ?catches ?finally)
+ [["jvm-try" [?body ?catches ?finally]]]
+ (&&host/compile-jvm-try compile-expression ?type ?body ?catches ?finally)
- [["jvm-throw" ?ex]]
- (&&host/compile-jvm-throw compile-expression ?type ?ex)
+ [["jvm-throw" ?ex]]
+ (&&host/compile-jvm-throw compile-expression ?type ?ex)
- [["jvm-monitorenter" ?monitor]]
- (&&host/compile-jvm-monitorenter compile-expression ?type ?monitor)
+ [["jvm-monitorenter" ?monitor]]
+ (&&host/compile-jvm-monitorenter compile-expression ?type ?monitor)
- [["jvm-monitorexit" ?monitor]]
- (&&host/compile-jvm-monitorexit compile-expression ?type ?monitor)
+ [["jvm-monitorexit" ?monitor]]
+ (&&host/compile-jvm-monitorexit compile-expression ?type ?monitor)
- [["jvm-d2f" ?value]]
- (&&host/compile-jvm-d2f compile-expression ?type ?value)
+ [["jvm-d2f" ?value]]
+ (&&host/compile-jvm-d2f compile-expression ?type ?value)
- [["jvm-d2i" ?value]]
- (&&host/compile-jvm-d2i compile-expression ?type ?value)
+ [["jvm-d2i" ?value]]
+ (&&host/compile-jvm-d2i compile-expression ?type ?value)
- [["jvm-d2l" ?value]]
- (&&host/compile-jvm-d2l compile-expression ?type ?value)
-
- [["jvm-f2d" ?value]]
- (&&host/compile-jvm-f2d compile-expression ?type ?value)
+ [["jvm-d2l" ?value]]
+ (&&host/compile-jvm-d2l compile-expression ?type ?value)
+
+ [["jvm-f2d" ?value]]
+ (&&host/compile-jvm-f2d compile-expression ?type ?value)
- [["jvm-f2i" ?value]]
- (&&host/compile-jvm-f2i compile-expression ?type ?value)
+ [["jvm-f2i" ?value]]
+ (&&host/compile-jvm-f2i compile-expression ?type ?value)
- [["jvm-f2l" ?value]]
- (&&host/compile-jvm-f2l compile-expression ?type ?value)
-
- [["jvm-i2b" ?value]]
- (&&host/compile-jvm-i2b compile-expression ?type ?value)
+ [["jvm-f2l" ?value]]
+ (&&host/compile-jvm-f2l compile-expression ?type ?value)
+
+ [["jvm-i2b" ?value]]
+ (&&host/compile-jvm-i2b compile-expression ?type ?value)
- [["jvm-i2c" ?value]]
- (&&host/compile-jvm-i2c compile-expression ?type ?value)
+ [["jvm-i2c" ?value]]
+ (&&host/compile-jvm-i2c compile-expression ?type ?value)
- [["jvm-i2d" ?value]]
- (&&host/compile-jvm-i2d compile-expression ?type ?value)
+ [["jvm-i2d" ?value]]
+ (&&host/compile-jvm-i2d compile-expression ?type ?value)
- [["jvm-i2f" ?value]]
- (&&host/compile-jvm-i2f compile-expression ?type ?value)
+ [["jvm-i2f" ?value]]
+ (&&host/compile-jvm-i2f compile-expression ?type ?value)
- [["jvm-i2l" ?value]]
- (&&host/compile-jvm-i2l compile-expression ?type ?value)
+ [["jvm-i2l" ?value]]
+ (&&host/compile-jvm-i2l compile-expression ?type ?value)
- [["jvm-i2s" ?value]]
- (&&host/compile-jvm-i2s compile-expression ?type ?value)
+ [["jvm-i2s" ?value]]
+ (&&host/compile-jvm-i2s compile-expression ?type ?value)
- [["jvm-l2d" ?value]]
- (&&host/compile-jvm-l2d compile-expression ?type ?value)
+ [["jvm-l2d" ?value]]
+ (&&host/compile-jvm-l2d compile-expression ?type ?value)
- [["jvm-l2f" ?value]]
- (&&host/compile-jvm-l2f compile-expression ?type ?value)
+ [["jvm-l2f" ?value]]
+ (&&host/compile-jvm-l2f compile-expression ?type ?value)
- [["jvm-l2i" ?value]]
- (&&host/compile-jvm-l2i compile-expression ?type ?value)
+ [["jvm-l2i" ?value]]
+ (&&host/compile-jvm-l2i compile-expression ?type ?value)
- [["jvm-iand" [?x ?y]]]
- (&&host/compile-jvm-iand compile-expression ?type ?x ?y)
+ [["jvm-iand" [?x ?y]]]
+ (&&host/compile-jvm-iand compile-expression ?type ?x ?y)
- [["jvm-ior" [?x ?y]]]
- (&&host/compile-jvm-ior compile-expression ?type ?x ?y)
+ [["jvm-ior" [?x ?y]]]
+ (&&host/compile-jvm-ior compile-expression ?type ?x ?y)
- [["jvm-land" [?x ?y]]]
- (&&host/compile-jvm-land compile-expression ?type ?x ?y)
+ [["jvm-land" [?x ?y]]]
+ (&&host/compile-jvm-land compile-expression ?type ?x ?y)
- [["jvm-lor" [?x ?y]]]
- (&&host/compile-jvm-lor compile-expression ?type ?x ?y)
+ [["jvm-lor" [?x ?y]]]
+ (&&host/compile-jvm-lor compile-expression ?type ?x ?y)
- [["jvm-lxor" [?x ?y]]]
- (&&host/compile-jvm-lxor compile-expression ?type ?x ?y)
+ [["jvm-lxor" [?x ?y]]]
+ (&&host/compile-jvm-lxor compile-expression ?type ?x ?y)
- [["jvm-lshl" [?x ?y]]]
- (&&host/compile-jvm-lshl compile-expression ?type ?x ?y)
+ [["jvm-lshl" [?x ?y]]]
+ (&&host/compile-jvm-lshl compile-expression ?type ?x ?y)
- [["jvm-lshr" [?x ?y]]]
- (&&host/compile-jvm-lshr compile-expression ?type ?x ?y)
+ [["jvm-lshr" [?x ?y]]]
+ (&&host/compile-jvm-lshr compile-expression ?type ?x ?y)
- [["jvm-lushr" [?x ?y]]]
- (&&host/compile-jvm-lushr compile-expression ?type ?x ?y)
- ))
+ [["jvm-lushr" [?x ?y]]]
+ (&&host/compile-jvm-lushr compile-expression ?type ?x ?y)
+ )
))
(defn ^:private compile-statement [syntax]
- ;; (prn 'compile-statement syntax)
(matchv ::M/objects [syntax]
[["def" [?name ?body ?def-data]]]
(&&lux/compile-def compile-expression ?name ?body ?def-data)
@@ -320,8 +315,6 @@
(&&host/compile-jvm-class compile-expression ?package ?name ?super-class ?fields ?methods)))
(defn ^:private eval! [expr]
- ;; (prn 'eval! (aget expr 0))
- ;; (assert false)
(|do [eval-ctor &/get-eval-ctor
:let [class-name (str eval-ctor)
=class (doto (new ClassWriter ClassWriter/COMPUTE_MAXS)
@@ -348,17 +341,10 @@
(.get nil)
return)))
-(let [compiler-step (|do [analysis+ (&optimizer/optimize eval!)
- ;; :let [_ (prn 'analysis+ analysis+)]
- ]
- (&/map% compile-statement analysis+)
- ;; (if (&/|empty? analysis+)
- ;; (fail "[Compiler Error] No more to compile.")
- ;; (&/map% compile-statement analysis+))
- )]
+(let [compiler-step (|do [analysis+ (&optimizer/optimize eval!)]
+ (&/map% compile-statement analysis+))]
(defn ^:private compile-module [name]
(fn [state]
- (prn 'compile-module name (->> state (&/get$ &/$MODULES) &/|keys &/->seq))
(if (->> state (&/get$ &/$MODULES) (&/|contains? name))
(if (= name "lux")
(return* state nil)
@@ -373,8 +359,6 @@
(&/update$ &/$MODULES #(&/|put name &a-module/init-module %))))]
[["lux;Right" [?state _]]]
(do (.visitEnd =class)
- ;; (prn 'compile-module 'DONE name)
- ;; (prn 'compile-module/?vals ?vals)
(&/run-state (&&/save-class! name (.toByteArray =class)) ?state))
[["lux;Left" ?message]]
diff --git a/src/lux/compiler/base.clj b/src/lux/compiler/base.clj
index dd7e0ae13..c0a54ba53 100644
--- a/src/lux/compiler/base.clj
+++ b/src/lux/compiler/base.clj
@@ -32,104 +32,102 @@
(return nil)))
(defn total-locals [expr]
- ;; (prn 'total-locals1 (aget expr 0))
(matchv ::M/objects [expr]
[[?struct ?type]]
- (do ;; (prn 'total-locals2 (aget ?struct 0))
- (matchv ::M/objects [?struct]
- [["case" [?variant ?base-register ?num-registers ?branches]]]
- (+ ?num-registers (&/fold max 0 (&/|map (comp total-locals second) ?branches)))
-
- [["tuple" ?members]]
- (&/fold max 0 (&/|map total-locals ?members))
+ (matchv ::M/objects [?struct]
+ [["case" [?variant ?base-register ?num-registers ?branches]]]
+ (+ ?num-registers (&/fold max 0 (&/|map (comp total-locals second) ?branches)))
+
+ [["tuple" ?members]]
+ (&/fold max 0 (&/|map total-locals ?members))
- [["variant" [?tag ?value]]]
- (total-locals ?value)
+ [["variant" [?tag ?value]]]
+ (total-locals ?value)
- [["call" [?fn ?args]]]
- (&/fold max 0 (&/|map total-locals (&/|cons ?fn ?args)))
-
- [["jvm-iadd" [?x ?y]]]
- (&/fold max 0 (&/|map total-locals (&/|list ?x ?y)))
-
- [["jvm-isub" [?x ?y]]]
- (&/fold max 0 (&/|map total-locals (&/|list ?x ?y)))
-
- [["jvm-imul" [?x ?y]]]
- (&/fold max 0 (&/|map total-locals (&/|list ?x ?y)))
-
- [["jvm-idiv" [?x ?y]]]
- (&/fold max 0 (&/|map total-locals (&/|list ?x ?y)))
-
- [["jvm-irem" [?x ?y]]]
- (&/fold max 0 (&/|map total-locals (&/|list ?x ?y)))
-
- [["jvm-ladd" [?x ?y]]]
- (&/fold max 0 (&/|map total-locals (&/|list ?x ?y)))
-
- [["jvm-lsub" [?x ?y]]]
- (&/fold max 0 (&/|map total-locals (&/|list ?x ?y)))
-
- [["jvm-lmul" [?x ?y]]]
- (&/fold max 0 (&/|map total-locals (&/|list ?x ?y)))
-
- [["jvm-ldiv" [?x ?y]]]
- (&/fold max 0 (&/|map total-locals (&/|list ?x ?y)))
-
- [["jvm-lrem" [?x ?y]]]
- (&/fold max 0 (&/|map total-locals (&/|list ?x ?y)))
-
- [["jvm-fadd" [?x ?y]]]
- (&/fold max 0 (&/|map total-locals (&/|list ?x ?y)))
-
- [["jvm-fsub" [?x ?y]]]
- (&/fold max 0 (&/|map total-locals (&/|list ?x ?y)))
-
- [["jvm-fmul" [?x ?y]]]
- (&/fold max 0 (&/|map total-locals (&/|list ?x ?y)))
-
- [["jvm-fdiv" [?x ?y]]]
- (&/fold max 0 (&/|map total-locals (&/|list ?x ?y)))
-
- [["jvm-frem" [?x ?y]]]
- (&/fold max 0 (&/|map total-locals (&/|list ?x ?y)))
-
- [["jvm-dadd" [?x ?y]]]
- (&/fold max 0 (&/|map total-locals (&/|list ?x ?y)))
-
- [["jvm-dsub" [?x ?y]]]
- (&/fold max 0 (&/|map total-locals (&/|list ?x ?y)))
-
- [["jvm-dmul" [?x ?y]]]
- (&/fold max 0 (&/|map total-locals (&/|list ?x ?y)))
-
- [["jvm-ddiv" [?x ?y]]]
- (&/fold max 0 (&/|map total-locals (&/|list ?x ?y)))
-
- [["jvm-drem" [?x ?y]]]
- (&/fold max 0 (&/|map total-locals (&/|list ?x ?y)))
+ [["call" [?fn ?args]]]
+ (&/fold max 0 (&/|map total-locals (&/|cons ?fn ?args)))
+
+ [["jvm-iadd" [?x ?y]]]
+ (&/fold max 0 (&/|map total-locals (&/|list ?x ?y)))
+
+ [["jvm-isub" [?x ?y]]]
+ (&/fold max 0 (&/|map total-locals (&/|list ?x ?y)))
+
+ [["jvm-imul" [?x ?y]]]
+ (&/fold max 0 (&/|map total-locals (&/|list ?x ?y)))
+
+ [["jvm-idiv" [?x ?y]]]
+ (&/fold max 0 (&/|map total-locals (&/|list ?x ?y)))
+
+ [["jvm-irem" [?x ?y]]]
+ (&/fold max 0 (&/|map total-locals (&/|list ?x ?y)))
+
+ [["jvm-ladd" [?x ?y]]]
+ (&/fold max 0 (&/|map total-locals (&/|list ?x ?y)))
+
+ [["jvm-lsub" [?x ?y]]]
+ (&/fold max 0 (&/|map total-locals (&/|list ?x ?y)))
+
+ [["jvm-lmul" [?x ?y]]]
+ (&/fold max 0 (&/|map total-locals (&/|list ?x ?y)))
+
+ [["jvm-ldiv" [?x ?y]]]
+ (&/fold max 0 (&/|map total-locals (&/|list ?x ?y)))
+
+ [["jvm-lrem" [?x ?y]]]
+ (&/fold max 0 (&/|map total-locals (&/|list ?x ?y)))
+
+ [["jvm-fadd" [?x ?y]]]
+ (&/fold max 0 (&/|map total-locals (&/|list ?x ?y)))
+
+ [["jvm-fsub" [?x ?y]]]
+ (&/fold max 0 (&/|map total-locals (&/|list ?x ?y)))
+
+ [["jvm-fmul" [?x ?y]]]
+ (&/fold max 0 (&/|map total-locals (&/|list ?x ?y)))
+
+ [["jvm-fdiv" [?x ?y]]]
+ (&/fold max 0 (&/|map total-locals (&/|list ?x ?y)))
+
+ [["jvm-frem" [?x ?y]]]
+ (&/fold max 0 (&/|map total-locals (&/|list ?x ?y)))
+
+ [["jvm-dadd" [?x ?y]]]
+ (&/fold max 0 (&/|map total-locals (&/|list ?x ?y)))
+
+ [["jvm-dsub" [?x ?y]]]
+ (&/fold max 0 (&/|map total-locals (&/|list ?x ?y)))
+
+ [["jvm-dmul" [?x ?y]]]
+ (&/fold max 0 (&/|map total-locals (&/|list ?x ?y)))
+
+ [["jvm-ddiv" [?x ?y]]]
+ (&/fold max 0 (&/|map total-locals (&/|list ?x ?y)))
+
+ [["jvm-drem" [?x ?y]]]
+ (&/fold max 0 (&/|map total-locals (&/|list ?x ?y)))
- [["|do" ?exprs]]
- (&/fold max 0 (&/|map total-locals ?exprs))
+ [["|do" ?exprs]]
+ (&/fold max 0 (&/|map total-locals ?exprs))
- [["jvm-new" [?class ?classes ?args]]]
- (&/fold max 0 (&/|map total-locals ?args))
+ [["jvm-new" [?class ?classes ?args]]]
+ (&/fold max 0 (&/|map total-locals ?args))
- [["jvm-invokestatic" [?class ?method ?classes ?args]]]
- (&/fold max 0 (&/|map total-locals ?args))
+ [["jvm-invokestatic" [?class ?method ?classes ?args]]]
+ (&/fold max 0 (&/|map total-locals ?args))
- [["jvm-invokevirtual" [?class ?method ?classes ?object ?args]]]
- (&/fold max 0 (&/|map total-locals ?args))
+ [["jvm-invokevirtual" [?class ?method ?classes ?object ?args]]]
+ (&/fold max 0 (&/|map total-locals ?args))
- [["jvm-aastore" [?array ?idx ?elem]]]
- (&/fold max 0 (&/|map total-locals (&/|list ?array ?elem)))
+ [["jvm-aastore" [?array ?idx ?elem]]]
+ (&/fold max 0 (&/|map total-locals (&/|list ?array ?elem)))
- [["jvm-aaload" [?array ?idx]]]
- (total-locals ?array)
+ [["jvm-aaload" [?array ?idx]]]
+ (total-locals ?array)
- ;; [["lambda" _]]
- ;; 0
-
- [_]
- 0
- ))))
+ ;; [["lambda" _]]
+ ;; 0
+
+ [_]
+ 0
+ )))
diff --git a/src/lux/compiler/case.clj b/src/lux/compiler/case.clj
index 738d6bc35..2720e31f7 100644
--- a/src/lux/compiler/case.clj
+++ b/src/lux/compiler/case.clj
@@ -21,7 +21,6 @@
+equals-sig+ (str "(" (&host/->type-signature "java.lang.Object") ")Z")
compare-kv #(.compareTo ^String (aget ^objects %1 0) ^String (aget ^objects %2 0))]
(defn ^:private compile-match [^MethodVisitor writer ?match $target $else]
- ;; (prn 'compile-match (aget ?match 0) $target $else)
(matchv ::M/objects [?match]
[["StoreTestAC" ?idx]]
(doto writer
@@ -143,7 +142,6 @@
)))
(defn ^:private separate-bodies [patterns]
- ;; (prn 'separate-bodies (aget matches 0))
(|let [[_ mappings patterns*] (&/fold (fn [$id+mappings+=matches pattern+body]
(|let [[$id mappings =matches] $id+mappings+=matches
[pattern body] pattern+body]
@@ -154,7 +152,6 @@
(let [ex-class (&host/->class "java.lang.IllegalStateException")]
(defn ^:private compile-pattern-matching [^MethodVisitor writer compile mappings patterns $end]
- ;; (prn 'compile-pattern-matching ?matches $end)
(let [entries (&/|map (fn [?branch+?body]
(|let [[?branch ?body] ?branch+?body
label (new Label)]
@@ -167,10 +164,7 @@
(.visitLabel $else))
(->> (|let [[?body ?match] ?body+?match])
(doseq [?body+?match (&/->seq patterns)
- :let [;; _ (prn 'compile-pattern-matching/pattern pattern)
- ;; _ (prn '?body+?match (alength ?body+?match) (aget ?body+?match 0))
- ;; _ (prn '?body+?match (aget ?body+?match 0))
- $else (new Label)]])))
+ :let [$else (new Label)]])))
(.visitInsn Opcodes/POP)
(.visitTypeInsn Opcodes/NEW ex-class)
(.visitInsn Opcodes/DUP)
@@ -187,7 +181,6 @@
;; [Resources]
(defn compile-case [compile *type* ?value ?matches]
- ;; (prn 'compile-case ?value ?matches)
(|do [^MethodVisitor *writer* &/get-writer
:let [$end (new Label)]
_ (compile ?value)
diff --git a/src/lux/compiler/host.clj b/src/lux/compiler/host.clj
index 71d3ced53..429424240 100644
--- a/src/lux/compiler/host.clj
+++ b/src/lux/compiler/host.clj
@@ -198,7 +198,6 @@
(do-template [<name> <op>]
(defn <name> [compile *type* ?class ?method ?classes ?object ?args]
- ;; (prn 'compile-jvm-invokevirtual ?classes *type*)
(|do [^MethodVisitor *writer* &/get-writer
:let [method-sig (str "(" (&/fold str "" (&/|map &host/->type-signature ?classes)) ")" (&host/->java-sig *type*))]
_ (compile ?object)
@@ -327,7 +326,6 @@
(&&/save-class! full-name (.toByteArray =class))))
(defn compile-jvm-interface [compile ?package ?name ?methods]
- ;; (prn 'compile-jvm-interface ?package ?name ?methods)
(let [parent-dir (&host/->package ?package)
full-name (str parent-dir "/" ?name)
=interface (doto (new ClassWriter ClassWriter/COMPUTE_MAXS)
@@ -335,13 +333,10 @@
full-name nil "java/lang/Object" nil))
_ (do (doseq [[?method ?props] ?methods
:let [[?args ?return] (:type ?props)
- signature (str "(" (&/fold str "" (&/|map &host/->type-signature ?args)) ")" (&host/->type-signature ?return))
- ;; _ (prn 'signature signature)
- ]]
+ signature (str "(" (&/fold str "" (&/|map &host/->type-signature ?args)) ")" (&host/->type-signature ?return))]]
(.visitMethod =interface (+ Opcodes/ACC_PUBLIC Opcodes/ACC_ABSTRACT) ?method signature nil nil))
(.visitEnd =interface)
(.mkdirs (java.io.File. (str "output/" parent-dir))))]
- ;; (prn 'SAVED_CLASS full-name)
(&&/save-class! full-name (.toByteArray =interface))))
(defn compile-jvm-try [compile *type* ?body ?catches ?finally]
diff --git a/src/lux/compiler/lambda.clj b/src/lux/compiler/lambda.clj
index 962a32ab6..3ba6e52f1 100644
--- a/src/lux/compiler/lambda.clj
+++ b/src/lux/compiler/lambda.clj
@@ -11,9 +11,7 @@
[analyser :as &analyser]
[host :as &host])
[lux.analyser.base :as &a]
- (lux.compiler [base :as &&])
- ;; :reload
- )
+ (lux.compiler [base :as &&]))
(:import (org.objectweb.asm Opcodes
Label
ClassWriter
@@ -39,9 +37,7 @@
(-> (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)
- ;; _ (prn 'add-lambda-<init> class-name ?captured-id)
- ])
+ (->> (let [captured-name (str &&/closure-prefix ?captured-id)])
(matchv ::M/objects [?name+?captured]
[[?name [["captured" [_ ?captured-id ?source]] _]]])
(doseq [?name+?captured (&/->seq env)])))
@@ -79,7 +75,6 @@
(return ret))))
(defn ^:private instance-closure [compile lambda-class closed-over init-signature]
- ;; (prn 'instance-closure lambda-class (&/|length closed-over) init-signature)
(|do [^MethodVisitor *writer* &/get-writer
:let [_ (doto *writer*
(.visitTypeInsn Opcodes/NEW lambda-class)
@@ -100,7 +95,6 @@
;; [Exports]
(defn compile-lambda [compile ?scope ?env ?body]
- ;; (prn 'compile-lambda ?scope (&host/location ?scope) ?env)
(|do [:let [lambda-class (&host/location ?scope)
=class (doto (new ClassWriter ClassWriter/COMPUTE_MAXS)
(.visit Opcodes/V1_5 (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_SUPER)
@@ -110,17 +104,11 @@
(->> (let [captured-name (str &&/closure-prefix ?captured-id)])
(matchv ::M/objects [?name+?captured]
[[?name [["captured" [_ ?captured-id ?source]] _]]])
- (doseq [?name+?captured (&/->seq ?env)
- ;; :let [_ (prn '?name+?captured (alength ?name+?captured))
- ;; _ (prn '?name+?captured (aget ?name+?captured 1 0))
- ;; _ (prn '?name+?captured (aget ?name+?captured 1 1 0 0))]
- ])))
+ (doseq [?name+?captured (&/->seq ?env)])))
(add-lambda-apply lambda-class ?env)
(add-lambda-<init> lambda-class ?env)
)]
_ (add-lambda-impl =class compile lambda-impl-signature ?body)
- :let [_ (.visitEnd =class)
- ;; _ (prn 'SAVING_LAMBDA lambda-class)
- ]
+ :let [_ (.visitEnd =class)]
_ (&&/save-class! lambda-class (.toByteArray =class))]
(instance-closure compile lambda-class ?env (lambda-<init>-signature ?env))))
diff --git a/src/lux/compiler/lux.clj b/src/lux/compiler/lux.clj
index ad2c9d0c6..4e3e4add1 100644
--- a/src/lux/compiler/lux.clj
+++ b/src/lux/compiler/lux.clj
@@ -13,9 +13,7 @@
(lux.analyser [base :as &a]
[module :as &a-module])
(lux.compiler [base :as &&]
- [lambda :as &&lambda])
- ;; :reload
- )
+ [lambda :as &&lambda]))
(:import (org.objectweb.asm Opcodes
Label
ClassWriter
@@ -68,13 +66,11 @@
(return nil)))
(defn compile-record [compile *type* ?elems]
- ;; (prn 'compile-record (str "{{" (->> ?elems &/|keys (&/|interpose " ") (&/fold str "")) "}}"))
(|do [^MethodVisitor *writer* &/get-writer
:let [elems* (->> ?elems
&/->seq
(sort #(compare (&/|first %1) (&/|first %2)))
&/->list)
- ;; _ (prn 'compile-record (str "{{" (->> elems* &/|keys (&/|interpose " ") (&/fold str "")) "}}"))
num-elems (&/|length elems*)
_ (doto *writer*
(.visitLdcInsn (int num-elems))
@@ -111,7 +107,6 @@
(return nil)))
(defn compile-captured [compile *type* ?scope ?captured-id ?source]
- ;; (prn 'compile-captured ?scope ?captured-id)
(|do [^MethodVisitor *writer* &/get-writer
:let [_ (doto *writer*
(.visitVarInsn Opcodes/ALOAD 0)
@@ -145,25 +140,18 @@
current-class nil "java/lang/Object" (into-array [(&host/->class &host/function-class)]))
(-> (.visitField (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_STATIC) "_datum" datum-sig nil nil)
(doto (.visitEnd))))]
- ;; :let [_ (prn 'compile-def/pre-body)]
_ (&/with-writer (.visitMethod =class Opcodes/ACC_PUBLIC "<clinit>" "()V" nil nil)
(|do [^MethodVisitor **writer** &/get-writer
:let [_ (.visitCode **writer**)]
- ;; :let [_ (prn 'compile-def/pre-body2)]
_ (compile ?body)
- ;; :let [_ (prn 'compile-def/post-body2)]
:let [_ (doto **writer**
(.visitFieldInsn Opcodes/PUTSTATIC current-class "_datum" datum-sig)
(.visitInsn Opcodes/RETURN)
(.visitMaxs 0 0)
(.visitEnd))]]
(return nil)))
- ;; :let [_ (prn 'compile-def/post-body)]
:let [_ (.visitEnd *writer*)]
- ;; :let [_ (prn 'compile-def/_1 ?name current-class)]
- _ (&&/save-class! current-class (.toByteArray =class))
- ;; :let [_ (prn 'compile-def/_2 ?name)]
- ]
+ _ (&&/save-class! current-class (.toByteArray =class))]
(return nil)))
(defn compile-declare-macro [compile module name]
diff --git a/src/lux/host.clj b/src/lux/host.clj
index 80dfd78d5..783b61298 100644
--- a/src/lux/host.clj
+++ b/src/lux/host.clj
@@ -25,8 +25,7 @@
)))
(defn ^:private method->type [^Method method]
- (|do [;; =args (&/map% class->type (&/->list (seq (.getParameterTypes method))))
- =return (class->type (.getReturnType method))]
+ (|do [=return (class->type (.getReturnType method))]
(return =return)))
;; [Resources]
@@ -46,7 +45,6 @@
(fail (str "[Analyser Error] Unknown class: " class-name))))))
(defn full-class-name [class-name]
- ;; (prn 'full-class-name class-name)
(|do [^Class =class (full-class class-name)]
(return (.getName =class))))
@@ -116,7 +114,6 @@
(defn <name> [target method-name args]
(let [target (Class/forName target)]
(if-let [method (first (for [^Method =method (.getMethods target)
- ;; :let [_ (prn '<name> '=method =method (mapv #(.getName %) (.getParameterTypes =method)))]
:when (and (= target (.getDeclaringClass =method))
(= method-name (.getName =method))
(= <static?> (Modifier/isStatic (.getModifiers =method)))
diff --git a/src/lux/lexer.clj b/src/lux/lexer.clj
index b7729156a..eb4e7af7c 100644
--- a/src/lux/lexer.clj
+++ b/src/lux/lexer.clj
@@ -6,7 +6,6 @@
;; [Utils]
(defn ^:private escape-char [escaped]
- ;; (prn 'escape-char escaped)
(condp = escaped
"\\t" (return "\t")
"\\b" (return "\b")
@@ -20,12 +19,8 @@
(defn ^:private lex-text-body [_]
(&/try-all% (&/|list (|do [[_ [_ [prefix escaped]]] (&reader/read-regex2 #"(?s)^([^\"\\]*)(\\.)")
- ;; :let [_ (prn '[prefix escaped] [prefix escaped])]
unescaped (escape-char escaped)
- ;; :let [_ (prn 'unescaped unescaped)]
- postfix (lex-text-body nil)
- ;; :let [_ (prn 'postfix postfix)]
- ]
+ postfix (lex-text-body nil)]
(return (str prefix unescaped postfix)))
(|do [[_ [_ body]] (&reader/read-regex #"(?s)^([^\"\\]*)")]
(return body)))))
@@ -54,9 +49,7 @@
(return (&/V "lux;Meta" (&/T meta (&/V "Comment" comment))))))
(def ^:private lex-comment
- (&/try-all% (&/|list lex-single-line-comment
- ;; (lex-multi-line-comment nil)
- )))
+ (&/try-all% (&/|list lex-single-line-comment)))
(do-template [<name> <tag> <regex>]
(def <name>
@@ -111,10 +104,7 @@
(def ^:private lex-tag
(|do [[_ [meta _]] (&reader/read-text "#")
- ;; :let [_ (prn 'lex-tag)]
- [_ [_ ident]] lex-ident
- ;; :let [_ (prn 'lex-tag [(aget ident 0) (aget ident 1)])]
- ]
+ [_ [_ ident]] lex-ident]
(return (&/V "lux;Meta" (&/T meta (&/V "Tag" ident))))))
(do-template [<name> <text> <tag>]
diff --git a/src/lux/parser.clj b/src/lux/parser.clj
index cb89f63a2..d8817fc05 100644
--- a/src/lux/parser.clj
+++ b/src/lux/parser.clj
@@ -22,19 +22,13 @@
)
(defn ^:private parse-record [parse]
- (|do [;; :let [_ (prn 'parse-record 0)]
- elems* (&/repeat% parse)
- ;; :let [_ (prn 'parse-record 1)]
+ (|do [elems* (&/repeat% parse)
token &lexer/lex
- ;; :let [_ (prn 'parse-record 2)]
- :let [elems (&/fold &/|++ (&/|list) elems*)]
- ;; :let [_ (prn 'parse-record 3)]
- ]
+ :let [elems (&/fold &/|++ (&/|list) elems*)]]
(matchv ::M/objects [token]
[["lux;Meta" [meta ["Close_Brace" _]]]]
(if (even? (&/|length elems))
- (do ;; (prn 'PARSED_RECORD (&/|length elems))
- (return (&/V "lux;Record" (&/|as-pairs elems))))
+ (return (&/V "lux;Record" (&/|as-pairs elems)))
(fail (str "[Parser Error] Records must have an even number of elements.")))
[_]
@@ -42,10 +36,7 @@
;; [Interface]
(def parse
- (|do [token &lexer/lex
- ;; :let [_ (prn 'parse/token token)]
- ;; :let [_ (prn 'parse (aget token 0))]
- ]
+ (|do [token &lexer/lex]
(matchv ::M/objects [token]
[["lux;Meta" [meta ["White_Space" _]]]]
(return (&/|list))
diff --git a/src/lux/reader.clj b/src/lux/reader.clj
index d66a671aa..38ff4d5e6 100644
--- a/src/lux/reader.clj
+++ b/src/lux/reader.clj
@@ -35,9 +35,7 @@
(fn [file-name line-num column-num ^String line]
(if-let [[^String match] (re-find regex line)]
(let [match-length (.length match)
- line* (.substring line match-length)
- ;; _ (prn 'with-line line*)
- ]
+ line* (.substring line match-length)]
(&/V "Yes" (&/T (&/V "lux;Meta" (&/T (&/T file-name line-num column-num) match))
(if (empty? line*)
(&/V "lux;None" nil)
@@ -49,9 +47,7 @@
(fn [file-name line-num column-num ^String line]
(if-let [[^String match tok1 tok2] (re-find regex line)]
(let [match-length (.length match)
- line* (.substring line match-length)
- ;; _ (prn 'with-line line*)
- ]
+ line* (.substring line match-length)]
(&/V "Yes" (&/T (&/V "lux;Meta" (&/T (&/T file-name line-num column-num) (&/T tok1 tok2)))
(if (empty? line*)
(&/V "lux;None" nil)
@@ -61,12 +57,9 @@
(defn read-text [^String text]
(with-line
(fn [file-name line-num column-num ^String line]
- ;; (prn 'read-text text line)
(if (.startsWith line text)
(let [match-length (.length text)
- line* (.substring line match-length)
- ;; _ (prn 'with-line line*)
- ]
+ line* (.substring line match-length)]
(&/V "Yes" (&/T (&/V "lux;Meta" (&/T (&/T file-name line-num column-num) text))
(if (empty? line*)
(&/V "lux;None" nil)
diff --git a/src/lux/type.clj b/src/lux/type.clj
index 0df628b15..57c2d4624 100644
--- a/src/lux/type.clj
+++ b/src/lux/type.clj
@@ -190,29 +190,18 @@
(fail* (str "[Type Error] Unbound type-var: " id)))
(fail* (str "[Type Error] <deref> Unknown type-var: " id))))))
-(defn set-var* [id type]
- (fn [state]
- (if-let [tvar (->> state (&/get$ &/$TYPES) (&/get$ &/$MAPPINGS) (&/|get id))]
- (return* (&/update$ &/$TYPES (fn [ts] (&/update$ &/$MAPPINGS #(&/|put id (&/V "lux;Some" type) %)
- ts))
- state)
- nil)
- (fail* (str "[Type Error] <set-var> Unknown type-var: " id " | " (->> state (&/get$ &/$TYPES) (&/get$ &/$MAPPINGS) &/|length))))))
-
(defn set-var [id type]
(fn [state]
(if-let [tvar (->> state (&/get$ &/$TYPES) (&/get$ &/$MAPPINGS) (&/|get id))]
- (do ;; (prn 'set-var (aget tvar 0))
- (matchv ::M/objects [tvar]
- [["lux;Some" bound]]
- (fail* (str "[Type Error] Can't rebind type var: " id " | Current type: " (show-type bound)))
-
- [["lux;None" _]]
- (do ;; (prn 'set-var id (show-type type))
- (return* (&/update$ &/$TYPES (fn [ts] (&/update$ &/$MAPPINGS #(&/|put id (&/V "lux;Some" type) %)
- ts))
- state)
- nil))))
+ (matchv ::M/objects [tvar]
+ [["lux;Some" bound]]
+ (fail* (str "[Type Error] Can't rebind type var: " id " | Current type: " (show-type bound)))
+
+ [["lux;None" _]]
+ (return* (&/update$ &/$TYPES (fn [ts] (&/update$ &/$MAPPINGS #(&/|put id (&/V "lux;Some" type) %)
+ ts))
+ state)
+ nil))
(fail* (str "[Type Error] <set-var> Unknown type-var: " id " | " (->> state (&/get$ &/$TYPES) (&/get$ &/$MAPPINGS) &/|length))))))
;; [Exports]
@@ -251,10 +240,7 @@
[["lux;VarT" ?id*]]
(if (= id ?id*)
(return (&/T ?id (&/V "lux;None" nil)))
- (return binding)
- ;; (|do [?type** (clean* id ?type*)]
- ;; (return (&/T ?id (&/V "lux;Some" ?type**))))
- )
+ (return binding))
[_]
(|do [?type** (clean* id ?type*)]
@@ -275,11 +261,6 @@
_ (delete-var id)]
(return output)))
-;; (def delete-vars
-;; (|do [vars #(->> % (&/get$ &/$TYPES) (&/get$ &/$MAPPINGS) &/|keys (return* %))
-;; _ (&/map% delete-var vars)]
-;; (return nil)))
-
(defn with-vars [amount k]
(|do [=vars (&/map% (constantly create-var) (&/|range amount))
output (k (&/|map #(&/V "lux;VarT" %) =vars))
@@ -341,7 +322,6 @@
))
(defn clean [tvar type]
- ;; (prn "^^ clean ^^")
(matchv ::M/objects [tvar]
[["lux;VarT" ?id]]
(clean* ?id type)
@@ -350,7 +330,6 @@
(fail (str "[Type Error] Not type-var: " (show-type tvar)))))
(defn show-type [^objects type]
- ;; (prn 'show-type (aget type 0))
(matchv ::M/objects [type]
[["lux;DataT" name]]
(str "(^ " name ")")
@@ -413,34 +392,31 @@
))
(defn type= [x y]
- ;; (prn "^^ type= ^^")
(let [output (matchv ::M/objects [x y]
[["lux;DataT" xname] ["lux;DataT" yname]]
(= xname yname)
[["lux;TupleT" xelems] ["lux;TupleT" yelems]]
- (&/fold (fn [old xy]
- (|let [[x* y*] xy]
- (and old
- (type= x* y*))))
- true
- (&/zip2 xelems yelems))
+ (&/fold2 (fn [old x y]
+ (and old (type= x y)))
+ true
+ xelems yelems)
[["lux;VariantT" xcases] ["lux;VariantT" ycases]]
- (and (= (&/|length xcases) (&/|length ycases))
- (&/fold (fn [old case]
- (and old
- (type= (&/|get case xcases) (&/|get case ycases))))
- true
- (&/|keys xcases)))
-
- [["lux;RecordT" xfields] ["lux;RecordT" yfields]]
- (and (= (&/|length xfields) (&/|length yfields))
- (&/fold (fn [old field]
- (and old
- (type= (&/|get field xfields) (&/|get field yfields))))
- true
- (&/|keys xfields)))
+ (&/fold2 (fn [old xcase ycase]
+ (|let [[xname xtype] xcase
+ [yname ytype] ycase]
+ (and old (= xname yname) (type= xtype ytype))))
+ true
+ xcases ycases)
+
+ [["lux;RecordT" xslots] ["lux;RecordT" yslots]]
+ (&/fold2 (fn [old xslot yslot]
+ (|let [[xname xtype] xslot
+ [yname ytype] yslot]
+ (and old (= xname yname) (type= xtype ytype))))
+ true
+ xslots yslots)
[["lux;LambdaT" [xinput xoutput]] ["lux;LambdaT" [yinput youtput]]]
(and (type= xinput yinput)
@@ -456,37 +432,30 @@
(= xid yid)
[["lux;AppT" [xlambda xparam]] ["lux;AppT" [ylambda yparam]]]
- (and (type= xlambda ylambda)
- (type= xparam yparam))
+ (and (type= xlambda ylambda) (type= xparam yparam))
[["lux;AllT" [xenv xname xarg xbody]] ["lux;AllT" [yenv yname yarg ybody]]]
- (do ;; (prn 'TESTING_ALLT
- ;; 'NAME [xname yname] (= xname yname)
- ;; 'ARG (= xarg yarg)
- ;; 'LENGTH [(&/|length xenv) (&/|length yenv)] (= (&/|length xenv) (&/|length yenv)))
- (and (= xname yname)
- (= xarg yarg)
- ;; (matchv ::M/objects [xenv yenv]
- ;; [["lux;None" _] ["lux;None" _]]
- ;; true
-
- ;; [["lux;Some" xenv*] ["lux;Some" yenv*]]
- ;; (&/fold (fn [old bname]
- ;; (and old
- ;; (type= (&/|get bname xenv*) (&/|get bname yenv*))))
- ;; (= (&/|length xenv*) (&/|length yenv*))
- ;; (&/|keys xenv*))
-
- ;; [_ _]
- ;; false)
- (type= xbody ybody)
- ))
+ (and (= xname yname)
+ (= xarg yarg)
+ ;; (matchv ::M/objects [xenv yenv]
+ ;; [["lux;None" _] ["lux;None" _]]
+ ;; true
+
+ ;; [["lux;Some" xenv*] ["lux;Some" yenv*]]
+ ;; (&/fold (fn [old bname]
+ ;; (and old
+ ;; (type= (&/|get bname xenv*) (&/|get bname yenv*))))
+ ;; (= (&/|length xenv*) (&/|length yenv*))
+ ;; (&/|keys xenv*))
+
+ ;; [_ _]
+ ;; false)
+ (type= xbody ybody)
+ )
[_ _]
- (do ;; (prn 'type= (show-type x) (show-type y))
- false)
+ false
)]
- ;; (prn 'type= output (show-type x) (show-type y))
output))
(defn ^:private fp-get [k fixpoints]
@@ -509,7 +478,6 @@
(str "Type " (show-type expected) " does not subsume type " (show-type actual)))
(defn beta-reduce [env type]
- ;; (prn 'beta-reduce (aget type 0))
(matchv ::M/objects [type]
[["lux;VariantT" ?cases]]
(&/V "lux;VariantT" (&/|map (fn [kv]
@@ -559,11 +527,9 @@
(return* state type))))
(defn apply-type [type-fn param]
- ;; (prn 'apply-type (aget type-fn 0) (aget param 0))
(matchv ::M/objects [type-fn]
[["lux;AllT" [local-env local-name local-arg local-def]]]
- (let [;; _ (prn 'apply-type/local-env (aget local-env 0) (show-type type-fn))
- local-env* (matchv ::M/objects [local-env]
+ (let [local-env* (matchv ::M/objects [local-env]
[["lux;None" _]]
(&/|table)
@@ -584,9 +550,6 @@
(def init-fixpoints (&/|list))
(defn ^:private check* [fixpoints expected actual]
- ;; (prn "^^ check* ^^")
- ;; (prn 'check* (aget expected 0) (aget actual 0))
- ;; (prn 'check* (show-type expected) (show-type actual))
(matchv ::M/objects [expected actual]
[["lux;VarT" ?eid] ["lux;VarT" ?aid]]
(if (= ?eid ?aid)
@@ -601,8 +564,6 @@
(return (&/V "lux;None" nil))))]
(matchv ::M/objects [ebound abound]
[["lux;None" _] ["lux;None" _]]
- ;; (|do [_ (set-var ?aid expected)]
- ;; (return (&/T fixpoints nil)))
(|do [_ (set-var ?eid actual)]
(return (&/T fixpoints nil)))
@@ -613,8 +574,7 @@
(check* fixpoints expected atype)
[["lux;Some" etype] ["lux;Some" atype]]
- (check* fixpoints etype atype)))
- )
+ (check* fixpoints etype atype))))
[["lux;VarT" ?id] _]
(&/try-all% (&/|list (|do [_ (set-var ?id actual)]
@@ -635,10 +595,6 @@
_ (check* fixpoints A1 A2)]
(return (&/T fixpoints nil)))
- ;; [["lux;AppT" [["lux;VarT" ?id] A1]] ["lux;AppT" [F2 A2]]]
- ;; (|do [[fixpoints* _] (check* fixpoints (&/V "lux;VarT" ?id) F2)
- ;; [fixpoints** _] (check* fixpoints* A1 A2)]
- ;; (return (&/T fixpoints** nil)))
[["lux;AppT" [["lux;VarT" ?id] A1]] ["lux;AppT" [F2 A2]]]
(|do [[fixpoints* _] (check* fixpoints (&/V "lux;VarT" ?id) F2)
e* (apply-type F2 A1)
@@ -646,25 +602,15 @@
[fixpoints** _] (check* fixpoints* e* a*)]
(return (&/T fixpoints** nil)))
- ;; [["lux;AppT" [F1 A1]] ["lux;AppT" [["lux;VarT" ?id] A2]]]
- ;; (|do [[fixpoints* _] (check* fixpoints F1 (&/V "lux;VarT" ?id))
- ;; [fixpoints** _] (check* fixpoints* A1 A2)]
- ;; (return (&/T fixpoints** nil)))
[["lux;AppT" [F1 A1]] ["lux;AppT" [["lux;VarT" ?id] A2]]]
(|do [[fixpoints* _] (check* fixpoints F1 (&/V "lux;VarT" ?id))
e* (apply-type F1 A1)
a* (apply-type F1 A2)
[fixpoints** _] (check* fixpoints* e* a*)]
(return (&/T fixpoints** nil)))
-
- ;; [["lux;AppT" [F1 A1]] ["lux;AppT" [F2 A2]]]
- ;; (|do [[fixpoints* _] (check* (fp-put fp-pair true fixpoints) F1 F2)
- ;; [fixpoints** _] (check* fixpoints* A1 A2)]
- ;; (return (&/T fixpoints** nil)))
[["lux;AppT" [F A]] _]
(let [fp-pair (&/T expected actual)
- ;; _ (prn 'LEFT_APP (&/|length fixpoints))
_ (when (> (&/|length fixpoints) 40)
(println 'FIXPOINTS (->> (&/|keys fixpoints)
(&/|map (fn [pair]
@@ -687,26 +633,6 @@
[_ ["lux;AppT" [F A]]]
(|do [actual* (apply-type F A)]
(check* fixpoints expected actual*))
- ;; (let [fp-pair (&/T expected actual)
- ;; _ (prn 'RIGHT_APP (&/|length fixpoints))
- ;; _ (when (> (&/|length fixpoints) 10)
- ;; (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))]
- ;; (matchv ::M/objects [(fp-get fp-pair fixpoints)]
- ;; [["lux;Some" ?]]
- ;; (if ?
- ;; (return (&/T fixpoints nil))
- ;; (fail (check-error expected actual)))
-
- ;; [["lux;None" _]]
- ;; (|do [actual* (apply-type F A)]
- ;; (check* (fp-put fp-pair true fixpoints) expected actual*))))
[["lux;AllT" _] _]
(with-var
@@ -779,48 +705,36 @@
(check* fixpoints* eO aO))
[["lux;TupleT" e!members] ["lux;TupleT" a!members]]
- (if (= (&/|length e!members) (&/|length a!members))
- (|do [fixpoints* (&/fold% (fn [fixp ea]
- (|let [[e a] ea]
- (do ;; (prn "lux;TupleT" 'ITER (show-type e) (show-type a))
- (|do [[fixp* _] (check* fixp e a)]
- (return fixp*)))))
- fixpoints
- (&/zip2 e!members a!members))
- ;; :let [_ (prn "lux;TupleT" 'DONE)]
- ]
- (return (&/T fixpoints* nil)))
- (fail "[Type Error] Tuples don't match in size."))
+ (|do [fixpoints* (&/fold2% (fn [fp e a]
+ (|do [[fp* _] (check* fp e a)]
+ (return fp*)))
+ fixpoints
+ e!members a!members)]
+ (return (&/T fixpoints* nil)))
[["lux;VariantT" e!cases] ["lux;VariantT" a!cases]]
- (if (= (&/|length e!cases) (&/|length a!cases))
- (|do [fixpoints* (&/fold% (fn [fixp slot]
- ;; (prn 'VARIANT_CASE slot)
- (if-let [e!type (&/|get slot e!cases)]
- (if-let [a!type (&/|get slot a!cases)]
- (|do [[fixp* _] (check* fixp e!type a!type)]
- (return fixp*))
- (fail (check-error expected actual)))
- (fail (check-error expected actual))))
- fixpoints
- (&/|keys e!cases))]
- (return (&/T fixpoints* nil)))
- (fail "[Type Error] Variants don't match in size."))
-
- [["lux;RecordT" e!fields] ["lux;RecordT" a!fields]]
- (if (= (&/|length e!fields) (&/|length a!fields))
- (|do [fixpoints* (&/fold% (fn [fixp slot]
- ;; (prn 'RECORD_FIELD slot)
- (if-let [e!type (&/|get slot e!fields)]
- (if-let [a!type (&/|get slot a!fields)]
- (|do [[fixp* _] (check* fixp e!type a!type)]
- (return fixp*))
- (fail (check-error expected actual)))
- (fail (check-error expected actual))))
- fixpoints
- (&/|keys e!fields))]
- (return (&/T fixpoints* nil)))
- (fail "[Type Error] Records don't match in size."))
+ (|do [fixpoints* (&/fold2% (fn [fp e!case a!case]
+ (|let [[e!name e!type] e!case
+ [a!name a!type] a!case]
+ (if (= e!name a!name)
+ (|do [[fp* _] (check* fp e!type a!type)]
+ (return fp*))
+ (fail (check-error expected actual)))))
+ fixpoints
+ e!cases a!cases)]
+ (return (&/T fixpoints* nil)))
+
+ [["lux;RecordT" e!slots] ["lux;RecordT" a!slots]]
+ (|do [fixpoints* (&/fold2% (fn [fp e!slot a!slot]
+ (|let [[e!name e!type] e!slot
+ [a!name a!type] a!slot]
+ (if (= e!name a!name)
+ (|do [[fp* _] (check* fp e!type a!type)]
+ (return fp*))
+ (fail (check-error expected actual)))))
+ fixpoints
+ e!slots a!slots)]
+ (return (&/T fixpoints* nil)))
[["lux;ExT" e!id] ["lux;ExT" a!id]]
(if (= e!id a!id)
@@ -832,7 +746,6 @@
))
(defn check [expected actual]
- ;; (prn "^^ check ^^")
(|do [_ (check* init-fixpoints expected actual)]
(return nil)))
generated by cgit v1.2.3 (git 2.25.1) at 2025-10-31 17:44:28 +0000