diff options
Diffstat (limited to '')
| -rw-r--r-- | src/lux/analyser.clj | 6 | ||||
| -rw-r--r-- | src/lux/analyser/case.clj | 119 | ||||
| -rw-r--r-- | src/lux/analyser/lambda.clj | 20 | ||||
| -rw-r--r-- | src/lux/analyser/lux.clj | 61 | ||||
| -rw-r--r-- | src/lux/compiler.clj | 4 | ||||
| -rw-r--r-- | src/lux/compiler/lambda.clj | 4 | ||||
| -rw-r--r-- | src/lux/type.clj | 4 |
7 files changed, 155 insertions, 63 deletions
diff --git a/src/lux/analyser.clj b/src/lux/analyser.clj index c56f3c053..156af6631 100644 --- a/src/lux/analyser.clj +++ b/src/lux/analyser.clj @@ -72,8 +72,8 @@ (&&lux/analyse-case analyse exo-type ?value ?branches) [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "lambda'"]]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ ?self]]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ ?arg]]]] + ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" ?self]]] + ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" ?arg]]] ["lux;Cons" [?body ["lux;Nil" _]]]]]]]]]]]]] (&&lux/analyse-lambda analyse exo-type ?self ?arg ?body) @@ -431,7 +431,7 @@ [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [?fn ?args]]]]]] (fn [state] ;; (prn '(&/show-ast ?fn) (&/show-ast ?fn)) - (matchv ::M/objects [((&&/analyse-1 (partial analyse-ast eval!) exo-type ?fn) state)] + (matchv ::M/objects [((&&/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*) diff --git a/src/lux/analyser/case.clj b/src/lux/analyser/case.clj index 0c9c55cf8..c33e32af1 100644 --- a/src/lux/analyser/case.clj +++ b/src/lux/analyser/case.clj @@ -20,6 +20,19 @@ [["lux;Meta" [_ pattern*]]] ;; (assert false) (do (prn 'analyse-pattern/pattern* (aget pattern* 0)) + (when (= "lux;Form" (aget pattern* 0)) + (prn 'analyse-pattern/_2 (aget pattern* 1 0)) ;; "lux;Cons" + (prn 'analyse-pattern/_2 (aget pattern* 1 1 0 0)) ;; "lux;Meta" + (prn 'analyse-pattern/_2 (alength (aget pattern* 1 1 0 1))) + (prn 'analyse-pattern/_2 (aget pattern* 1 1 0 1 1 0)) ;; "lux;Tag" + (prn 'analyse-pattern/_2 [(aget pattern* 1 1 0 1 1 1 0) (aget pattern* 1 1 0 1 1 1 1)]) ;; ["" "Cons"] + (prn 'analyse-pattern/_2 (aget pattern* 1 1 1 0)) ;; "lux;Cons" + (prn 'analyse-pattern/_2 (aget pattern* 1 1 1 1 0)) ;; #<Object[] [Ljava.lang.Object;@63c7c38b> + (prn 'analyse-pattern/_2 (aget pattern* 1 1 1 1 1 0)) ;; "lux;Nil" + ) + ;; ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Tag" [?module ?name]]]] + ;; ["lux;Cons" [?value + ;; ["lux;Nil" _]]]]]] (matchv ::M/objects [pattern*] [["lux;Symbol" [?module ?name]]] (return (&/T (inc idx) (&/V "StoreTestAC" (&/T idx (str ?module ";" ?name) value-type)))) @@ -49,9 +62,9 @@ (&/|range (&/|length ?members))) _ (&type/check value-type (&/V "lux;TupleT" =vars)) [idx* tests] (&/fold% (fn [idx+subs mv] - (|let [[idx subs] idx+subs + (|let [[_idx subs] idx+subs [?member ?var] mv] - (|do [[idx* test] (analyse-pattern idx ?var ?member)] + (|do [[idx* test] (analyse-pattern _idx ?var ?member)] (return (&/T idx* (&/|cons test subs)))))) (&/T idx (&/|list)) (&/zip2 ?members =vars))] @@ -62,21 +75,27 @@ (&/|range (&/|length ?fields))) _ (&type/check value-type (&/V "lux;RecordT" (&/zip2 (&/|keys ?fields) =vars))) tests (&/fold% (fn [idx+subs mv] - (|let [[idx subs] idx+subs + (|let [[_idx subs] idx+subs [[slot value] ?var] mv] - (|do [[idx* test] (analyse-pattern idx ?var value)] + (|do [[idx* test] (analyse-pattern _idx ?var value)] (return (&/T idx* (&/|cons (&/T slot test) subs)))))) (&/T idx (&/|list)) (&/zip2 ?fields =vars))] (return (&/V "RecordTestAC" tests))) - [["lux;Tag" ?tag]] - (analyse-variant analyse-pattern idx value-type ?tag (&/V "lus;Meta" (&/T (&/T "" -1 -1) - (&/V "lux;Tuple" (&/|list))))) + [["lux;Tag" [?module ?name]]] + (|do [module* (if (= "" ?module) + &/get-module-name + (return ?module))] + (analyse-variant analyse-pattern idx value-type (str module* ";" ?name) (&/V "lux;Meta" (&/T (&/T "" -1 -1) + (&/V "lux;Tuple" (&/|list)))))) - [["lux;Form" ["lux;Cons" [["lus;Meta" [_ ["lux;Tag" ?tag]]] + [["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Tag" [?module ?name]]]] ["lux;Cons" [?value ["lux;Nil" _]]]]]]] - (analyse-variant analyse-pattern idx value-type ?tag ?value) + (|do [module* (if (= "" ?module) + &/get-module-name + (return ?module))] + (analyse-variant analyse-pattern idx value-type (str module* ";" ?name) ?value)) )) )) @@ -110,9 +129,11 @@ (let [compare-kv #(compare (aget %1 0) (aget %2 0))] (defn ^:private merge-total [struct test+body] + (prn 'merge-total (aget struct 0) (class test+body)) + (prn 'merge-total (aget struct 0) (aget test+body 0)) (prn 'merge-total (aget struct 0) (aget test+body 0 0)) (matchv ::M/objects [test+body] - [[test _]] + [[test ?body]] (matchv ::M/objects [struct test] [["DefaultTotal" total?] ["StoreTestAC" [?idx ?name type]]] (return (&/V "DefaultTotal" true)) @@ -152,7 +173,7 @@ [["DefaultTotal" total?] ["TupleTestAC" ?tests]] (|do [structs (&/map% (fn [t] - (merge-total (&/V "DefaultTotal" total?) t)) + (merge-total (&/V "DefaultTotal" total?) (&/T t ?body))) ?tests)] (return (&/V "TupleTotal" (&/T total? structs)))) @@ -160,7 +181,7 @@ (if (= (&/|length ?values) (&/|length ?tests)) (|do [structs (&/map% (fn [vt] (|let [[v t] vt] - (merge-total v t))) + (merge-total v (&/T t ?body)))) (&/zip2 ?values ?tests))] (return (&/V "TupleTotal" (&/T total? structs)))) (fail "[Pattern-matching error] Inconsistent tuple-size.")) @@ -168,7 +189,7 @@ [["DefaultTotal" total?] ["RecordTestAC" ?tests]] (|do [structs (&/map% (fn [t] (|let [[slot value] t] - (|do [struct (merge-total (&/V "DefaultTotal" total?) value)] + (|do [struct (merge-total (&/V "DefaultTotal" total?) (&/T value ?body))] (return (&/T slot struct))))) (sort compare-kv ?tests))] (return (&/V "RecordTotal" (&/T total? structs)))) @@ -178,7 +199,7 @@ (|do [structs (&/map% (fn [lr] (|let [[[lslot struct] [rslot value]] lr] (if (= lslot rslot) - (|do [struct (merge-total (&/V "DefaultTotal" total?) value)] + (|do [struct (merge-total (&/V "DefaultTotal" total?) (&/T value ?body))] (return (&/T lslot struct))) (fail "[Pattern-matching error] Record slots mismatch.")))) (&/zip2 ?values @@ -187,13 +208,13 @@ (fail "[Pattern-matching error] Inconsistent record-size.")) [["DefaultTotal" total?] ["VariantTestAC" [?tag ?test]]] - (|do [struct (merge-total (&/V "DefaultTotal" total?) ?test)] - (return (&/V "VariantTotal" (&/T total? (&/|list (&/T ?tag struct)))))) + (|do [struct (merge-total (&/V "DefaultTotal" total?) (&/T ?test ?body))] + (return (&/V "VariantTotal" (&/T total? (&/|put ?tag struct (&/|table)))))) [["VariantTotal" [total? ?branches]] ["VariantTestAC" [?tag ?test]]] (|do [struct (merge-total (or (&/|get ?tag ?branches) (&/V "DefaultTotal" total?)) - ?test)] + (&/T ?test ?body))] (return (&/V "VariantTotal" (&/T total? (&/|put ?tag struct ?branches))))) )))) @@ -203,11 +224,68 @@ [["MatchAC" ?tests]] (&/fold% merge-total (&/V "DefaultTotal" false) ?tests)))) +(defn ^:private resolve-type [type] + (matchv ::M/objects [type] + [["lux;VarT" ?idx]] + (&type/deref ?idx) + + [_] + (return type))) + (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 [value-type struct] + [_ ["BoolTotal" [?total _]]] + (|do [_ (&type/check value-type &type/Bool)] + (return ?total)) + + [_ ["IntTotal" [?total _]]] + (|do [_ (&type/check value-type &type/Int)] + (return ?total)) + + [_ ["RealTotal" [?total _]]] + (|do [_ (&type/check value-type &type/Real)] + (return ?total)) + + [_ ["CharTotal" [?total _]]] + (|do [_ (&type/check value-type &type/Char)] + (return ?total)) + + [_ ["TextTotal" [?total _]]] + (|do [_ (&type/check value-type &type/Text)] + (return ?total)) + + [_ ["TupleTotal" [?total ?structs]]] + (|do [elems-vars (&/map% (constantly &type/fresh-var) (&/|range (&/|length ?structs))) + _ (&type/check value-type (&/V "lux;TupleT" elems-vars)) + totals (&/map% (fn [sv] + (|let [[struct tvar] sv] + (check-totality tvar struct))) + (&/zip2 ?structs elems-vars))] + (return (or ?total + (every? true? totals)))) + + [_ ["RecordTotal" [?total ?structs]]] + (|do [elems-vars (&/map% (constantly &type/fresh-var) (&/|range (&/|length ?structs))) + :let [structs+vars (&/zip2 ?structs elems-vars) + record-type (&/V "lux;RecordT" (&/|map (fn [sv] + (|let [[[k v] tvar] sv] + (&/T k tvar))) + structs+vars))] + _ (&type/check value-type record-type) + totals (&/map% (fn [sv] + (|let [[[k v] tvar] sv] + (check-totality tvar v))) + structs+vars)] + (return (or ?total + (every? true? totals)))) + + [_ ["VariantTotal" [?total ?structs]]] + (|do [real-type (resolve-type value-type)] + (assert false)) + [_ ["DefaultTotal" true]] - true + (return true) )) ;; [Exports] @@ -217,9 +295,10 @@ (analyse-branch analyse exo-type value-type pattern body match))) (&/V "MatchAC" (&/|list)) branches) - struct (totality-struct false =match)] + struct (totality-struct false =match) + ? (check-totality value-type struct)] (matchv ::M/objects [=match] [["MatchAC" ?tests]] - (if (check-totality value-type struct) + (if ? (return (&/V "MatchAC" (&/|reverse ?tests))) (fail "[Pattern-maching error] Pattern-matching is non-total."))))) diff --git a/src/lux/analyser/lambda.clj b/src/lux/analyser/lambda.clj index e12b22005..619c39766 100644 --- a/src/lux/analyser/lambda.clj +++ b/src/lux/analyser/lambda.clj @@ -1,19 +1,23 @@ (ns lux.analyser.lambda (:require [clojure.core.match :as M :refer [matchv]] clojure.core.match.array - (lux [base :as & :refer [|do return fail]]) + (lux [base :as & :refer [|let |do return fail]]) (lux.analyser [base :as &&] [env :as &env]))) ;; [Resource] (defn with-lambda [self self-type arg arg-type body] - (&/with-closure - (|do [scope-name &/get-scope-name] - (&env/with-local self self-type - (&env/with-local arg arg-type - (|do [=return body - =captured &env/captured-vars] - (return (&/T scope-name =captured =return)))))))) + ;; (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 + (|do [scope-name &/get-scope-name] + (&env/with-local (str ?module1 ";" ?name1) self-type + (&env/with-local (str ?module2 ";" ?name2) arg-type + (|do [=return body + =captured &env/captured-vars] + (return (&/T scope-name =captured =return))))))))) (defn close-over [scope ident register frame] ;; (prn 'close-over scope ident register frame) diff --git a/src/lux/analyser/lux.clj b/src/lux/analyser/lux.clj index 119e77826..61ca08b42 100644 --- a/src/lux/analyser/lux.clj +++ b/src/lux/analyser/lux.clj @@ -64,6 +64,11 @@ ] (return (&/|list (&/V "Expression" (&/T (&/V "lux;record" =elems) (&/V "lux;RecordT" =elems-types))))))) +(defn ^:private show-frame [frame] + (str "{{" (->> frame (&/get$ "lux;locals") (&/get$ "lux;mappings") + &/|keys &/->seq (interpose " ") (reduce str "")) + "}}")) + (defn analyse-symbol [analyse exo-type ident] (|do [module-name &/get-module-name] (fn [state] @@ -81,7 +86,8 @@ _ (&type/check exo-type =global-type)] (return (&/|list global))) state) - (fail* (str "[Analyser Error] Unrecognized identifier: " local-ident))) + (do (prn (str "((" (->> stack (&/|map show-frame) &/->seq (interpose " ") (reduce str "")) "))")) + (fail* (str "[Analyser Error] Unrecognized identifier: " local-ident)))) [["lux;Cons" [top-outer _]]] (|let [scopes (&/|tail (&/folds #(&/|cons (&/get$ "lux;name" %2) %1) @@ -101,21 +107,25 @@ )) (defn ^:private analyse-apply* [analyse exo-type =fn ?args] - (|do [=args (&/flat-map% analyse ?args) + (|do [=args (&/map% (fn [arg] (&&/with-var #(&&/analyse-1 analyse % arg))) + ?args) =fn-type (&&/expr-type =fn) - [=apply _] (&/fold% (fn [[=fn =fn-type] =input] - (|do [;; :let [_ (prn "#2")] - =input-type (&&/expr-type =input) - ;; :let [_ (prn "#3")] - =output-type (&type/apply-lambda =fn-type =input-type) - ;; :let [_ (prn "#4")] - ] - (return [(&/V "Expression" (&/T (&/V "apply" (&/T =fn =input)) - =output-type)) - =output-type]))) - [=fn =fn-type] - =args)] - (return (&/|list =apply)))) + [=apply =output-type] (&/fold% (fn [[=fn =fn-type] =input] + (|do [;; :let [_ (prn "#2")] + =input-type (&&/expr-type =input) + ;; :let [_ (prn "#3")] + =output-type (&type/apply-lambda =fn-type =input-type) + ;; :let [_ (prn "#4")] + ] + (return [(&/V "Expression" (&/T (&/V "apply" (&/T =fn =input)) + =output-type)) + =output-type]))) + [=fn =fn-type] + =args) + _ (&type/check exo-type =output-type)] + (matchv ::M/objects [=apply] + [["Expression" [?expr _]]] + (return (&/|list (&/V "Expression" (&/T ?expr exo-type))))))) (defn analyse-apply [analyse exo-type =fn ?args] ;; (prn 'analyse-apply1 (aget =fn 0)) @@ -131,7 +141,7 @@ (|do [macro-expansion (¯o/expand loader macro-class ?args) output (&/flat-map% analyse macro-expansion)] (return output))) - (analyse-apply* analyse =fn ?args))) + (analyse-apply* analyse exo-type =fn ?args))) [_] (analyse-apply* analyse =fn ?args))) @@ -157,25 +167,20 @@ [["lux;LambdaT" [=arg =return]]] (|do [[=scope =captured =body] (&&lambda/with-lambda ?self =lambda-type* ?arg =arg - (&&/analyse-1 analyse ?body)) - =body-type (&&/expr-type =body) - ;; _ =body-type - =lambda-type (|do [_ (&type/check &type/init-fixpoints =return =body-type)] - (&type/clean =return =lambda-type*)) + (&&/analyse-1 analyse =return ?body)) + =lambda-type** (&type/clean =return =lambda-type*) =bound-arg (&type/lookup =arg) =lambda-type (matchv ::M/objects [=arg =bound-arg] [["lux;VarT" id] ["lux;Some" bound]] - (&type/clean =arg =lambda-type) + (&type/clean =arg =lambda-type**) [["lux;VarT" id] ["lux;None" _]] (let [var-name (str (gensym "")) bound (&/V "lux;BoundT" var-name)] (|do [_ (&type/reset id bound) - lambda-type (&type/clean =arg =lambda-type)] - (return (&/V "lux;AllT" (&/T (&/|list) "" var-name lambda-type)))))) - ;; :let [_ (prn '=lambda-type =lambda-type)] - ] - (return (&/|list (&/V "Expression" (&/T (&/V "lambda" (&/T =scope =captured ?arg =body)) =lambda-type)))))))) + lambda-type (&type/clean =arg =lambda-type**)] + (return (&/V "lux;AllT" (&/T (&/|list) "" var-name lambda-type))))))] + (return (&/|list (&/V "Expression" (&/T (&/V "lambda" (&/T =scope =captured =body)) =lambda-type)))))))) (defn analyse-def [analyse exo-type ?name ?value] ;; (prn 'analyse-def ?name ?value) @@ -208,7 +213,7 @@ (|do [=type (&&/analyse-1 analyse &type/Type ?type) :let [_ (println "analyse-check#1")] ==type (eval! =type) - _ (&type/check &type/init-fixpoints exo-type ==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")]] diff --git a/src/lux/compiler.clj b/src/lux/compiler.clj index 280f27e63..352a69a3a 100644 --- a/src/lux/compiler.clj +++ b/src/lux/compiler.clj @@ -73,8 +73,8 @@ [["case" [?value ?match]]] (&&case/compile-case compile-expression ?type ?value ?match) - [["lambda" [?scope ?env ?args ?body]]] - (&&lambda/compile-lambda compile-expression ?scope ?env ?args ?body) + [["lambda" [?scope ?env ?body]]] + (&&lambda/compile-lambda compile-expression ?scope ?env ?body) ;; Integer arithmetic [["jvm-iadd" [?x ?y]]] diff --git a/src/lux/compiler/lambda.clj b/src/lux/compiler/lambda.clj index b914eb87b..c75ec4806 100644 --- a/src/lux/compiler/lambda.clj +++ b/src/lux/compiler/lambda.clj @@ -97,8 +97,8 @@ (return nil))) ;; [Exports] -(defn compile-lambda [compile ?scope ?env ?arg ?body] - ;; (prn 'compile-lambda ?scope (&host/location ?scope) ?arg ?env) +(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) diff --git a/src/lux/type.clj b/src/lux/type.clj index e136e8b5c..1fbaa78c0 100644 --- a/src/lux/type.clj +++ b/src/lux/type.clj @@ -413,6 +413,10 @@ success) (fail "[Type Error] Records don't match in size.")) + [_ _] + (do (prn (show-type expected) (show-type actual)) + (assert false)) + ;; [["lux;BoundT" name] _] ;; (do (prn "lux;BoundT" name) ;; (assert false)) |