aboutsummaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
Diffstat (limited to '')
-rw-r--r--src/lux/analyser.clj6
-rw-r--r--src/lux/analyser/case.clj119
-rw-r--r--src/lux/analyser/lambda.clj20
-rw-r--r--src/lux/analyser/lux.clj61
-rw-r--r--src/lux/compiler.clj4
-rw-r--r--src/lux/compiler/lambda.clj4
-rw-r--r--src/lux/type.clj4
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 (&macro/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))