From 2560b63dcc98a6a6b5e2f938d8279d9bb4627052 Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Wed, 6 May 2015 17:46:08 -0400 Subject: - Removed all the unnecesary comments. - Made some changes to the way type-checking is performed on variants, records & tuples in order to improve the speed of type-checking. --- src/lux.clj | 10 - src/lux/analyser.clj | 46 ++-- src/lux/analyser/base.clj | 13 +- src/lux/analyser/case.clj | 188 ++++++++--------- src/lux/analyser/host.clj | 35 +--- src/lux/analyser/lambda.clj | 7 - src/lux/analyser/lux.clj | 267 +++++++---------------- src/lux/analyser/module.clj | 29 ++- src/lux/base.clj | 74 +++---- src/lux/compiler.clj | 500 +++++++++++++++++++++----------------------- src/lux/compiler/base.clj | 178 ++++++++-------- src/lux/compiler/case.clj | 9 +- src/lux/compiler/host.clj | 7 +- src/lux/compiler/lambda.clj | 20 +- src/lux/compiler/lux.clj | 16 +- src/lux/host.clj | 5 +- src/lux/lexer.clj | 16 +- src/lux/parser.clj | 17 +- src/lux/reader.clj | 13 +- src/lux/type.clj | 241 +++++++-------------- 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 [ ] (defn [analyse ?class ?method ?classes ?object ?args] - ;; (prn ' ?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 (&/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) @@ -409,11 +315,6 @@ (return (&/|list (&/V "def" (&/T ?name =value def-data)))))) )))) -(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 [ ] (defn [f xs] - ;; (prn ' 0 (aget xs 0)) (matchv ::M/objects [xs] [["lux;Nil" _]] (return xs) [["lux;Cons" [x xs*]]] (|do [y (f x) - ;; :let [_ (prn ' 1 (class y)) - ;; _ (prn ' 2 (aget y 0))] - ys ( f xs*)] + ys ( f xs*)] (return ( 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 [ ] (defn [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- 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- 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--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 "" "()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 [target method-name args] (let [target (Class/forName target)] (if-let [method (first (for [^Method =method (.getMethods target) - ;; :let [_ (prn ' '=method =method (mapv #(.getName %) (.getParameterTypes =method)))] :when (and (= target (.getDeclaringClass =method)) (= method-name (.getName =method)) (= (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 [ ] (def @@ -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 [ ] 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] 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] 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] 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))) -- cgit v1.2.3