aboutsummaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
Diffstat (limited to 'src')
-rw-r--r--src/lux/analyser/case.clj28
-rw-r--r--src/lux/analyser/lambda.clj8
-rw-r--r--src/lux/analyser/module.clj31
-rw-r--r--src/lux/base.clj4
-rw-r--r--src/lux/compiler/base.clj1
-rw-r--r--src/lux/compiler/case.clj25
-rw-r--r--src/lux/compiler/lux.clj4
-rw-r--r--src/lux/type.clj14
8 files changed, 76 insertions, 39 deletions
diff --git a/src/lux/analyser/case.clj b/src/lux/analyser/case.clj
index aab25d741..212f02665 100644
--- a/src/lux/analyser/case.clj
+++ b/src/lux/analyser/case.clj
@@ -25,6 +25,7 @@
"RealTotal"
"CharTotal"
"TextTotal"
+ "UnitTotal"
"ProdTotal"
"SumTotal"]
)
@@ -36,6 +37,7 @@
"RealTestAC"
"CharTestAC"
"TextTestAC"
+ "UnitTestAC"
"ProdTestAC"
"SumTestAC"]
)
@@ -113,11 +115,14 @@
type* (adjust-type type)
idx (&module/tag-index =module =name)
group (&module/tag-group =module =name)
+ ;; :let [_ (prn 'resolve-tag =module =name (&/adt->text group))]
case-type (&type/variant-case idx type*)]
(return ($$ &/P idx (&/|length group) case-type))))
(defn ^:private analyse-pattern [value-type pattern kont]
- (|let [[_ pattern*] pattern]
+ (|let [[_ pattern*] pattern
+ ;; :let [_ (prn 'analyse-pattern (&/adt->text pattern*) (&type/show-type value-type))]
+ ]
(|case pattern*
(&/$SymbolS "" name)
(|do [=kont (&env/with-local name value-type
@@ -153,6 +158,11 @@
=kont kont]
(return (&/P (&/S $TextTestAC ?value) =kont)))
+ (&/$TupleS (&/$Nil))
+ (|do [_ (&type/check value-type &type/Unit)
+ =kont kont]
+ (return (&/P (&/S $UnitTestAC nil) =kont)))
+
(&/$TupleS (&/$Cons ?_left ?tail))
(|do [value-type* (adjust-type value-type)]
(|case value-type*
@@ -168,7 +178,7 @@
_
(analyse-pattern ?right (&/S &/$TupleS ?tail) kont))]
(return (&/P =right =kont))))]
- (return (&/P (&/S $ProdTestAC =left =right) =kont)))
+ (return (&/P (&/S $ProdTestAC (&/P =left =right)) =kont)))
_
(fail (str "[Pattern-matching Error] Tuples require product-types: " (&type/show-type value-type*)))))
@@ -182,8 +192,7 @@
[=test =kont] (analyse-pattern case-type unit kont)]
(return (&/P (&/S $SumTestAC ($$ &/P idx group-count =test)) =kont)))
- (&/$FormS (&/$Cons [_ (&/$TagS ?ident)]
- ?values))
+ (&/$FormS (&/$Cons [_ (&/$TagS ?ident)] ?values))
(|do [[idx group-count case-type] (resolve-tag ?ident value-type)
[=test =kont] (case (&/|length ?values)
0 (analyse-pattern case-type unit kont)
@@ -240,6 +249,12 @@
[($TextTotal total? ?values) ($TextTestAC ?value)]
(return (&/S $TextTotal (&/P total? (&/Cons$ ?value ?values))))
+ [($DefaultTotal total?) ($UnitTestAC)]
+ (return (&/S $UnitTotal nil))
+
+ [($UnitTotal) ($UnitTestAC)]
+ (return (&/S $UnitTotal nil))
+
[($DefaultTotal total?) ($ProdTestAC ?left ?right)]
(|do [:let [_default (&/S $DefaultTotal total?)]
=left (merge-total _default (&/P ?left ?body))
@@ -301,6 +316,9 @@
($TextTotal ?total _)
(return ?total)
+ ($UnitTotal)
+ (return true)
+
($ProdTotal ?total ?_left ?_right)
(if ?total
(return true)
@@ -329,7 +347,7 @@
(fail "[Pattern-matching Error] Pattern-matching mismatch. Variant has wrong size.")
_
- (check-totality ?right ($SumTotal ?total ?tail)))]
+ (check-totality ?right (&/S $SumTotal (&/P ?total ?tail))))]
(return (and =left =right)))
_
diff --git a/src/lux/analyser/lambda.clj b/src/lux/analyser/lambda.clj
index 696c816e9..b30953f67 100644
--- a/src/lux/analyser/lambda.clj
+++ b/src/lux/analyser/lambda.clj
@@ -30,10 +30,10 @@
(->> frame (&/$get-closure) (&/$get-counter))
register))
register-type)]
- (do (prn 'close-over 'updating-closure
- [(->> frame (&/$get-closure) (&/$get-counter)) (->> frame (&/$get-closure) (&/$get-counter) inc)]
- [(->> frame (&/$get-closure) (&/$get-mappings) &/ident->text)
- (->> frame (&/$get-closure) (&/$get-mappings) (&/|put name register*) &/ident->text)])
+ (do ;; (prn 'close-over 'updating-closure
+ ;; [(->> frame (&/$get-closure) (&/$get-counter)) (->> frame (&/$get-closure) (&/$get-counter) inc)]
+ ;; [(->> frame (&/$get-closure) (&/$get-mappings) &/ident->text)
+ ;; (->> frame (&/$get-closure) (&/$get-mappings) (&/|put name register*) &/ident->text)])
($$ &/P register* (&/$update-closure #(->> %
(&/$update-counter inc)
(&/$update-mappings (fn [mps] (&/|put name register* mps))))
diff --git a/src/lux/analyser/module.clj b/src/lux/analyser/module.clj
index 909e7e2c4..bc9647f9f 100644
--- a/src/lux/analyser/module.clj
+++ b/src/lux/analyser/module.clj
@@ -349,20 +349,17 @@
nil))
(fail* (str "[Lux Error] Unknown module: " module))))))
-(defn tag-index [module tag-name]
- "(-> Text Text (Lux Int))"
- (fn [state]
- (if-let [=module (->> state (&/$get-modules) (&/|get module))]
- (if-let [^objects idx+tags (&/|get tag-name ($get-tags =module))]
- (return* state (aget idx+tags 0))
- (fail* (str "[Module Error] Unknown tag: " (&/ident->text (&/P module tag-name)))))
- (fail* (str "[Module Error] Unknown module: " module)))))
-
-(defn tag-group [module tag-name]
- "(-> Text Text (Lux (List Ident)))"
- (fn [state]
- (if-let [=module (->> state (&/$get-modules) (&/|get module))]
- (if-let [^objects idx+tags (&/|get tag-name ($get-tags =module))]
- (return* state (aget idx+tags 1))
- (fail* (str "[Module Error] Unknown tag: " (&/ident->text (&/P module tag-name)))))
- (fail* (str "[Module Error] Unknown module: " module)))))
+(do-template [<name> <member> <type>]
+ (defn <name> [module tag-name]
+ <type>
+ (fn [state]
+ (if-let [=module (->> state (&/$get-modules) (&/|get module))]
+ (if-let [^objects idx+tags (&/|get tag-name ($get-tags =module))]
+ (|let [[idx tags type] idx+tags]
+ (return* state <member>))
+ (fail* (str "[Module Error] Unknown tag: " (&/ident->text (&/P module tag-name)))))
+ (fail* (str "[Module Error] Unknown module: " module)))))
+
+ tag-index idx "(-> Text Text (Lux Int))"
+ tag-group tags "(-> Text Text (Lux (List Ident)))"
+ )
diff --git a/src/lux/base.clj b/src/lux/base.clj
index 2f0925586..d261145ae 100644
--- a/src/lux/base.clj
+++ b/src/lux/base.clj
@@ -21,7 +21,7 @@
(defmacro deftags [names]
(assert (vector? names))
`(do ~@(for [[name idx] (map vector names (range (count names)))]
- `(def ~(symbol (str "$" name)) ~idx))))
+ `(def ~(symbol (str "$" name)) (int ~idx)))))
(defn ^:private unfold-accesses
([elems]
@@ -793,7 +793,7 @@
(defn with-writer [writer body]
(fn [state]
- (prn 'with-writer writer body)
+ ;; (prn 'with-writer writer body)
(let [output (body ($update-host #($set-writer (Some$ writer) %) state))]
(|case output
($Right ?state ?value)
diff --git a/src/lux/compiler/base.clj b/src/lux/compiler/base.clj
index 72d569ed1..e327d1de4 100644
--- a/src/lux/compiler/base.clj
+++ b/src/lux/compiler/base.clj
@@ -94,6 +94,7 @@
(do-template [<name> <class> <sig> <method>]
(defn <name> [^MethodVisitor writer]
(doto writer
+ (.visitTypeInsn Opcodes/CHECKCAST <class>)
(.visitMethodInsn Opcodes/INVOKEVIRTUAL <class> <method> (str "()" <sig>))))
unwrap-boolean "java/lang/Boolean" "Z" "booleanValue"
diff --git a/src/lux/compiler/case.clj b/src/lux/compiler/case.clj
index b30fcb4f8..0a928a056 100644
--- a/src/lux/compiler/case.clj
+++ b/src/lux/compiler/case.clj
@@ -84,27 +84,36 @@
(.visitInsn Opcodes/POP)
(.visitJumpInsn Opcodes/GOTO $target))
+ (&a-case/$UnitTestAC)
+ (doto writer
+ (.visitInsn Opcodes/POP)
+ (.visitJumpInsn Opcodes/GOTO $target))
+
(&a-case/$ProdTestAC left right)
(let [$post-left (new Label)
- $post-right (new Label)]
+ $post-right (new Label)
+ $pre-else (new Label)]
(doto writer
(.visitTypeInsn Opcodes/CHECKCAST "[Ljava/lang/Object;")
(.visitInsn Opcodes/DUP)
(.visitLdcInsn (int 0))
(.visitInsn Opcodes/AALOAD)
- (compile-match left $post-left $else)
+ (compile-match left $post-left $pre-else)
(.visitLabel $post-left)
(.visitInsn Opcodes/DUP)
(.visitLdcInsn (int 1))
(.visitInsn Opcodes/AALOAD)
- (compile-match right $post-right $else)
+ (compile-match right $post-right $pre-else)
(.visitLabel $post-right)
(.visitInsn Opcodes/POP)
- (.visitJumpInsn Opcodes/GOTO $target)))
+ (.visitJumpInsn Opcodes/GOTO $target)
+ (.visitLabel $pre-else)
+ (.visitInsn Opcodes/POP)
+ (.visitJumpInsn Opcodes/GOTO $else)))
(&a-case/$SumTestAC ?tag ?count ?test)
(let [$value-then (new Label)
- $sum-else (new Label)]
+ $pre-else (new Label)]
(doto writer
(.visitTypeInsn Opcodes/CHECKCAST "[Ljava/lang/Object;")
(.visitInsn Opcodes/DUP)
@@ -112,15 +121,15 @@
(.visitInsn Opcodes/AALOAD)
(&&/unwrap-int)
(.visitLdcInsn (int ?tag))
- (.visitJumpInsn Opcodes/IF_ICMPNE $sum-else)
+ (.visitJumpInsn Opcodes/IF_ICMPNE $else)
(.visitInsn Opcodes/DUP)
(.visitLdcInsn (int 1))
(.visitInsn Opcodes/AALOAD)
- (compile-match ?test $value-then $sum-else)
+ (compile-match ?test $value-then $pre-else)
(.visitLabel $value-then)
(.visitInsn Opcodes/POP)
(.visitJumpInsn Opcodes/GOTO $target)
- (.visitLabel $sum-else)
+ (.visitLabel $pre-else)
(.visitInsn Opcodes/POP)
(.visitJumpInsn Opcodes/GOTO $else)))
)))
diff --git a/src/lux/compiler/lux.clj b/src/lux/compiler/lux.clj
index 79383acc0..10ee40839 100644
--- a/src/lux/compiler/lux.clj
+++ b/src/lux/compiler/lux.clj
@@ -138,7 +138,7 @@
(.visitInsn Opcodes/DUP) ;; VV
(.visitLdcInsn (int 0)) ;; VVI
(.visitLdcInsn &/$TypeD) ;; VVIT
- (&&/wrap-long)
+ (&&/wrap-int)
(.visitInsn Opcodes/AASTORE) ;; V
(.visitInsn Opcodes/DUP) ;; VV
(.visitLdcInsn (int 1)) ;; VVI
@@ -165,7 +165,7 @@
(.visitInsn Opcodes/DUP) ;; VV
(.visitLdcInsn (int 0)) ;; VVI
(.visitLdcInsn &/$ValueD) ;; VVIT
- (&&/wrap-long)
+ (&&/wrap-int)
(.visitInsn Opcodes/AASTORE) ;; V
(.visitInsn Opcodes/DUP) ;; VV
(.visitLdcInsn (int 1)) ;; VVI
diff --git a/src/lux/type.clj b/src/lux/type.clj
index 4193d8df4..91bc6e480 100644
--- a/src/lux/type.clj
+++ b/src/lux/type.clj
@@ -548,6 +548,12 @@
(defn type= [x y]
(or (clojure.lang.Util/identical x y)
(let [output (|case [x y]
+ [(&/$UnitT) (&/$UnitT)]
+ true
+
+ [(&/$VoidT) (&/$VoidT)]
+ true
+
[(&/$DataT xname) (&/$DataT yname)]
(.equals ^Object xname yname)
@@ -704,6 +710,9 @@
(if (clojure.lang.Util/identical expected actual)
(return (&/P fixpoints nil))
(|case [expected actual]
+ [(&/$UnitT) (&/$UnitT)]
+ (return (&/P fixpoints nil))
+
[(&/$VarT ?eid) (&/$VarT ?aid)]
(if (.equals ^Object ?eid ?aid)
(return (&/P fixpoints nil))
@@ -840,7 +849,7 @@
(println 'FIXPOINTS (->> (&/|keys fixpoints)
(&/|map (fn [pair]
(|let [[e a] pair]
- (str (show-type e) ":+:"
+ (str (show-type e) " :+: "
(show-type a)))))
(&/|interpose "\n\n")
(&/fold str "")))
@@ -909,6 +918,9 @@
[_ (&/$NamedT ?aname ?atype)]
(check* class-loader fixpoints expected ?atype)
+ [_ (&/$VoidT)]
+ (return (&/P fixpoints nil))
+
[_ _]
(fail (check-error expected actual))
)))
generated by cgit v1.2.3 (git 2.25.1) at 2024-09-12 23:14:31 +0000