diff options
author | Eduardo Julian | 2015-08-23 17:41:45 -0400 |
---|---|---|
committer | Eduardo Julian | 2015-08-23 17:41:45 -0400 |
commit | 82b019a5b5f547f3b321642ce687d8aec59e802e (patch) | |
tree | e8f5e836f8667aedccc3112027b0fef3caa1b7c6 /src | |
parent | 9606c19f9947c8f2ff5647b4613ac2029ac3881f (diff) |
- Restructuring how sums & products work [part 2]
Diffstat (limited to 'src')
-rw-r--r-- | src/lux/analyser/case.clj | 28 | ||||
-rw-r--r-- | src/lux/analyser/lambda.clj | 8 | ||||
-rw-r--r-- | src/lux/analyser/module.clj | 31 | ||||
-rw-r--r-- | src/lux/base.clj | 4 | ||||
-rw-r--r-- | src/lux/compiler/base.clj | 1 | ||||
-rw-r--r-- | src/lux/compiler/case.clj | 25 | ||||
-rw-r--r-- | src/lux/compiler/lux.clj | 4 | ||||
-rw-r--r-- | src/lux/type.clj | 14 |
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)) ))) |