diff options
| -rw-r--r-- | source/lux.lux | 154 | ||||
| -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 |
9 files changed, 158 insertions, 111 deletions
diff --git a/source/lux.lux b/source/lux.lux index 7c5fd5c8d..bdb845f1b 100644 --- a/source/lux.lux +++ b/source/lux.lux @@ -63,7 +63,7 @@ ## (1 a))) (_lux_def Maybe (11 ["lux" "Maybe"] - (9 (1 (0)) "lux;Maybe" "a" + (9 (1 #Nil) "lux;Maybe" "a" (2 ## "lux;None" Unit ## "lux;Some" @@ -92,7 +92,7 @@ Type (_lux_case (10 List (3 Text Type)) TypeEnv - (10 (9 (1 (0)) "Type" "_" + (10 (9 (#Some #Nil) "Type" "_" (2 ## lux;VoidT Unit (2 ## lux;UnitT @@ -493,7 +493,7 @@ (_lux_: Macro (_lux_lambda _ tokens (_lux_case tokens - (#Cons (#Meta _ (#TupleS (#Cons arg args'))) (#Cons body #Nil)) + (#Cons [_ (#TupleS (#Cons arg args'))] (#Cons body #Nil)) (return (#Cons (_meta (#FormS (#Cons (_meta (#SymbolS "" "_lux_lambda")) (#Cons (_meta (#SymbolS "" "")) (#Cons arg @@ -508,7 +508,7 @@ #Nil)))))) #Nil)) - (#Cons (#Meta _ (#SymbolS self)) (#Cons (#Meta _ (#TupleS (#Cons arg args'))) (#Cons body #Nil))) + (#Cons [_ (#SymbolS self)] (#Cons [_ (#TupleS (#Cons arg args'))] (#Cons body #Nil))) (return (#Cons (_meta (#FormS (#Cons (_meta (#SymbolS "" "_lux_lambda")) (#Cons (_meta (#SymbolS self)) (#Cons arg @@ -531,9 +531,9 @@ (_lux_: Macro (lambda'' [tokens] (_lux_case tokens - (#Cons [(#Meta [_ (#TagS ["" "export"])]) - (#Cons [(#Meta [_ (#FormS (#Cons [name args]))]) - (#Cons [type (#Cons [body #Nil])])])]) + (#Cons [_ (#TagS ["" "export"])] + (#Cons [_ (#FormS (#Cons name args))] + (#Cons type (#Cons body #Nil)))) (return (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["" "_lux_def"])) (#Cons [name (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["" "_lux_:"])) @@ -547,7 +547,7 @@ (#Cons [(_meta (#FormS (#Cons [(symbol$ ["" "_lux_export"]) (#Cons [name #Nil])]))) #Nil])])) - (#Cons [(#Meta [_ (#TagS ["" "export"])]) (#Cons [name (#Cons [type (#Cons [body #Nil])])])]) + (#Cons [_ (#TagS "" "export")] (#Cons name (#Cons type (#Cons body #Nil)))) (return (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["" "_lux_def"])) (#Cons [name (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["" "_lux_:"])) @@ -558,8 +558,8 @@ (#Cons [(_meta (#FormS (#Cons [(symbol$ ["" "_lux_export"]) (#Cons [name #Nil])]))) #Nil])])) - (#Cons [(#Meta [_ (#FormS (#Cons [name args]))]) - (#Cons [type (#Cons [body #Nil])])]) + (#Cons [_ (#FormS (#Cons name args))] + (#Cons type (#Cons body #Nil))) (return (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["" "_lux_def"])) (#Cons [name (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["" "_lux_:"])) @@ -572,7 +572,7 @@ #Nil])])]))) #Nil])) - (#Cons [name (#Cons [type (#Cons [body #Nil])])]) + (#Cons name (#Cons type (#Cons body #Nil))) (return (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["" "_lux_def"])) (#Cons [name (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["" "_lux_:"])) @@ -590,7 +590,7 @@ (def'' (defmacro tokens) Macro (_lux_case tokens - (#Cons [(#Meta [_ (#FormS (#Cons [name args]))]) (#Cons [body #Nil])]) + (#Cons [[_ (#FormS (#Cons [name args]))] (#Cons [body #Nil])]) (return (#Cons [(form$ (#Cons [(symbol$ ["lux" "def''"]) (#Cons [(form$ (#Cons [name args])) (#Cons [(symbol$ ["lux" "Macro"]) @@ -600,7 +600,7 @@ (#Cons [(form$ (#Cons [(symbol$ ["" "_lux_declare-macro"]) (#Cons [name #Nil])])) #Nil])])) - (#Cons [(#Meta [_ (#TagS ["" "export"])]) (#Cons [(#Meta [_ (#FormS (#Cons [name args]))]) (#Cons [body #Nil])])]) + (#Cons [[_ (#TagS ["" "export"])] (#Cons [[_ (#FormS (#Cons [name args]))] (#Cons [body #Nil])])]) (return (#Cons [(form$ (#Cons [(symbol$ ["lux" "def''"]) (#Cons [(tag$ ["" "export"]) (#Cons [(form$ (#Cons [name args])) @@ -640,12 +640,12 @@ (defmacro (All' tokens) (_lux_case tokens - (#Cons [(#Meta [_ (#TupleS #Nil)]) + (#Cons [[_ (#TupleS #Nil)] (#Cons [body #Nil])]) (return (#Cons [body #Nil])) - (#Cons [(#Meta [_ (#TupleS (#Cons [(#Meta [_ (#SymbolS ["" arg-name])]) other-args]))]) + (#Cons [[_ (#TupleS (#Cons [[_ (#SymbolS ["" arg-name])] other-args]))] (#Cons [body #Nil])]) (return (#Cons [(_meta (#FormS (#Cons [(_meta (#TagS ["lux" "AllT"])) (#Cons [(_meta (#TupleS (#Cons [(_meta (#TagS ["lux" "None"])) @@ -664,7 +664,7 @@ (defmacro (B' tokens) (_lux_case tokens - (#Cons [(#Meta [_ (#SymbolS ["" bound-name])]) + (#Cons [[_ (#SymbolS ["" bound-name])] #Nil]) (return (#Cons [(_meta (#FormS (#Cons [(_meta (#TagS ["lux" "BoundT"])) (#Cons [(_meta (#TextS bound-name)) @@ -732,15 +732,15 @@ (fail "Wrong syntax for list&"))) (defmacro (lambda' tokens) - (let'' [name tokens'] (_lux_: (#TupleT (list Ident ($' List AST))) + (let'' [name tokens'] (_lux_: (#ProdT Ident ($' List AST)) (_lux_case tokens - (#Cons [(#Meta [_ (#SymbolS name)]) tokens']) + (#Cons [[_ (#SymbolS name)] tokens']) [name tokens'] _ [["" ""] tokens])) (_lux_case tokens' - (#Cons [(#Meta [_ (#TupleS args)]) (#Cons [body #Nil])]) + (#Cons [[_ (#TupleS args)] (#Cons [body #Nil])]) (_lux_case args #Nil (fail "lambda' requires a non-empty arguments tuple.") @@ -762,8 +762,8 @@ (defmacro (def''' tokens) (_lux_case tokens - (#Cons [(#Meta [_ (#TagS ["" "export"])]) - (#Cons [(#Meta [_ (#FormS (#Cons [name args]))]) + (#Cons [[_ (#TagS ["" "export"])] + (#Cons [[_ (#FormS (#Cons [name args]))] (#Cons [type (#Cons [body #Nil])])])]) (return (list (form$ (list (symbol$ ["" "_lux_def"]) name @@ -775,7 +775,7 @@ body)))))) (form$ (list (symbol$ ["" "_lux_export"]) name)))) - (#Cons [(#Meta [_ (#TagS ["" "export"])]) (#Cons [name (#Cons [type (#Cons [body #Nil])])])]) + (#Cons [[_ (#TagS ["" "export"])] (#Cons [name (#Cons [type (#Cons [body #Nil])])])]) (return (list (form$ (list (symbol$ ["" "_lux_def"]) name (form$ (list (symbol$ ["" "_lux_:"]) @@ -783,7 +783,7 @@ body)))) (form$ (list (symbol$ ["" "_lux_export"]) name)))) - (#Cons [(#Meta [_ (#FormS (#Cons [name args]))]) + (#Cons [[_ (#FormS (#Cons [name args]))] (#Cons [type (#Cons [body #Nil])])]) (return (list (form$ (list (symbol$ ["" "_lux_def"]) name @@ -805,7 +805,7 @@ (def''' (as-pairs xs) (All' [a] - (->' ($' List (B' a)) ($' List (#TupleT (list (B' a) (B' a)))))) + (->' ($' List (B' a)) ($' List (#ProdT (B' a) (B' a))))) (_lux_case xs (#Cons [x (#Cons [y xs'])]) (#Cons [[x y] (as-pairs xs')]) @@ -815,8 +815,8 @@ (defmacro (let' tokens) (_lux_case tokens - (#Cons [(#Meta [_ (#TupleS bindings)]) (#Cons [body #Nil])]) - (return (list (foldL (_lux_: (->' AST (#TupleT (list AST AST)) + (#Cons [[_ (#TupleS bindings)] (#Cons [body #Nil])]) + (return (list (foldL (_lux_: (->' AST (#ProdT AST AST) AST) (lambda' [body binding] (_lux_case binding @@ -853,7 +853,7 @@ (def''' (spliced? token) (->' AST Bool) (_lux_case token - (#Meta [_ (#FormS (#Cons [(#Meta [_ (#SymbolS ["" "~@"])]) (#Cons [_ #Nil])]))]) + [_ (#FormS (#Cons [[_ (#SymbolS ["" "~@"])] (#Cons [_ #Nil])]))] true _ @@ -861,9 +861,8 @@ (def''' (wrap-meta content) (->' AST AST) - (_meta (#FormS (list (_meta (#TagS ["lux" "Meta"])) - (_meta (#TupleS (list (_meta (#TupleS (list (_meta (#TextS "")) (_meta (#IntS -1)) (_meta (#IntS -1))))) - content))))))) + (_meta (#TupleS (list (_meta (#TupleS (list (_meta (#TextS "")) (_meta (#IntS -1)) (_meta (#IntS -1))))) + content)))) (def''' (untemplate-list tokens) (->' ($' List AST) AST) @@ -902,7 +901,7 @@ true (let' [elems' (map (lambda' [elem] (_lux_case elem - (#Meta [_ (#FormS (#Cons [(#Meta [_ (#SymbolS ["" "~@"])]) (#Cons [spliced #Nil])]))]) + [_ (#FormS (#Cons [[_ (#SymbolS ["" "~@"])] (#Cons [spliced #Nil])]))] spliced _ @@ -923,23 +922,23 @@ (def''' (untemplate replace? subst token) (->' Bool Text AST AST) - (_lux_case (_lux_: (#TupleT (list Bool AST)) [replace? token]) - [_ (#Meta [_ (#BoolS value)])] + (_lux_case (_lux_: (#ProdT Bool AST) [replace? token]) + [_ [_ (#BoolS value)]] (wrap-meta (form$ (list (tag$ ["lux" "BoolS"]) (_meta (#BoolS value))))) - [_ (#Meta [_ (#IntS value)])] + [_ [_ (#IntS value)]] (wrap-meta (form$ (list (tag$ ["lux" "IntS"]) (_meta (#IntS value))))) - [_ (#Meta [_ (#RealS value)])] + [_ [_ (#RealS value)]] (wrap-meta (form$ (list (tag$ ["lux" "RealS"]) (_meta (#RealS value))))) - [_ (#Meta [_ (#CharS value)])] + [_ [_ (#CharS value)]] (wrap-meta (form$ (list (tag$ ["lux" "CharS"]) (_meta (#CharS value))))) - [_ (#Meta [_ (#TextS value)])] + [_ [_ (#TextS value)]] (wrap-meta (form$ (list (tag$ ["lux" "TextS"]) (_meta (#TextS value))))) - [_ (#Meta [_ (#TagS [module name])])] + [_ [_ (#TagS [module name])]] (let' [module' (_lux_case module "" subst @@ -948,7 +947,7 @@ module)] (wrap-meta (form$ (list (tag$ ["lux" "TagS"]) (tuple$ (list (text$ module') (text$ name))))))) - [_ (#Meta [_ (#SymbolS [module name])])] + [_ [_ (#SymbolS [module name])]] (let' [module' (_lux_case module "" subst @@ -957,19 +956,19 @@ module)] (wrap-meta (form$ (list (tag$ ["lux" "SymbolS"]) (tuple$ (list (text$ module') (text$ name))))))) - [_ (#Meta [_ (#TupleS elems)])] + [_ [_ (#TupleS elems)]] (splice replace? (untemplate replace? subst) (tag$ ["lux" "TupleS"]) elems) - [true (#Meta [_ (#FormS (#Cons [(#Meta [_ (#SymbolS ["" "~"])]) (#Cons [unquoted #Nil])]))])] + [true [_ (#FormS (#Cons [[_ (#SymbolS ["" "~"])] (#Cons [unquoted #Nil])]))]] unquoted - [_ (#Meta [meta (#FormS elems)])] - (let' [(#Meta [_ form']) (splice replace? (untemplate replace? subst) (tag$ ["lux" "FormS"]) elems)] - (#Meta [meta form'])) + [_ [meta (#FormS elems)]] + (let' [[_ form'] (splice replace? (untemplate replace? subst) (tag$ ["lux" "FormS"]) elems)] + [meta form']) - [_ (#Meta [_ (#RecordS fields)])] + [_ [_ (#RecordS fields)]] (wrap-meta (form$ (list (tag$ ["lux" "RecordS"]) - (untemplate-list (map (_lux_: (->' (#TupleT (list AST AST)) AST) + (untemplate-list (map (_lux_: (->' (#ProdT AST AST) AST) (lambda' [kv] (let' [[k v] kv] (tuple$ (list (untemplate replace? subst k) (untemplate replace? subst v)))))) @@ -995,16 +994,17 @@ (defmacro #export (|> tokens) (_lux_case tokens (#Cons [init apps]) - (return (list (foldL (lambda' [acc app] - (_lux_case app - (#Meta [_ (#TupleS parts)]) - (tuple$ (list:++ parts (list acc))) + (return (list (foldL (_lux_: (->' AST AST AST) + (lambda' [acc app] + (_lux_case app + [_ (#TupleS parts)] + (tuple$ (list:++ parts (list acc))) - (#Meta [_ (#FormS parts)]) - (form$ (list:++ parts (list acc))) + [_ (#FormS parts)] + (form$ (list:++ parts (list acc))) - _ - (`' ((~ app) (~ acc))))) + _ + (`' ((~ app) (~ acc)))))) init apps))) @@ -1026,7 +1026,7 @@ (def''' #export Lux Type (All' [a] - (->' Compiler ($' Either Text (#TupleT (list Compiler (B' a))))))) + (->' Compiler ($' Either Text (#ProdT Compiler (B' a)))))) ## (defsig (Monad m) ## (: (All [a] (-> a (m a))) @@ -1037,10 +1037,10 @@ Type (#NamedT ["lux" "Monad"] (All' [m] - (#TupleT (list (All' [a] (->' (B' a) ($' (B' m) (B' a)))) - (All' [a b] (->' (->' (B' a) ($' (B' m) (B' b))) - ($' (B' m) (B' a)) - ($' (B' m) (B' b))))))))) + (#ProdT (All' [a] (->' (B' a) ($' (B' m) (B' a)))) + (All' [a b] (->' (->' (B' a) ($' (B' m) (B' b))) + ($' (B' m) (B' a)) + ($' (B' m) (B' b)))))))) (_lux_declare-tags [#return #bind] Monad) (def''' Maybe/Monad @@ -1074,7 +1074,7 @@ (defmacro #export (^ tokens) (_lux_case tokens - (#Cons (#Meta _ (#SymbolS "" class-name)) #Nil) + (#Cons [_ (#SymbolS "" class-name)] #Nil) (return (list (`' (#;DataT (~ (_meta (#TextS class-name))))))) _ @@ -1083,7 +1083,8 @@ (defmacro #export (-> tokens) (_lux_case (reverse tokens) (#Cons output inputs) - (return (list (foldL (lambda' [o i] (`' (#;LambdaT (~ i) (~ o)))) + (return (list (foldL (_lux_: (->' AST AST AST) + (lambda' [o i] (`' (#;LambdaT (~ i) (~ o))))) output inputs))) @@ -1091,16 +1092,25 @@ (fail "Wrong syntax for ->"))) (defmacro #export (, tokens) - (return (list (`' (#;TupleT (~ (untemplate-list tokens))))))) + (_lux_case (reverse tokens) + (#Cons last prevs) + (return (list (foldL (_lux_: (->' AST AST AST) + (lambda' [r l] (`' (#;ProdT (~ l) (~ r))))) + last + prevs))) + + _ + (fail "Wrong syntax for ,")) + ) (defmacro (do tokens) (_lux_case tokens - (#Cons monad (#Cons (#Meta _ (#TupleS bindings)) (#Cons body #Nil))) + (#Cons monad (#Cons [_ (#TupleS bindings)] (#Cons body #Nil))) (let' [body' (foldL (_lux_: (-> AST (, AST AST) AST) (lambda' [body' binding] (let' [[var value] binding] (_lux_case var - (#Meta _ (#TagS "" "let")) + [_ (#TagS "" "let")] (`' (;let' (~ value) (~ body'))) _ @@ -1146,7 +1156,7 @@ (def''' (get-ident x) (-> AST ($' Maybe Ident)) (_lux_case x - (#Meta [_ (#SymbolS sname)]) + [_ (#SymbolS sname)] (#Some sname) _ @@ -1155,7 +1165,7 @@ (def''' (get-name x) (-> AST ($' Maybe Text)) (_lux_case x - (#Meta [_ (#SymbolS ["" sname])]) + [_ (#SymbolS ["" sname])] (#Some sname) _ @@ -1164,7 +1174,7 @@ (def''' (tuple->list tuple) (-> AST ($' Maybe ($' List AST))) (_lux_case tuple - (#Meta [_ (#TupleS members)]) + [_ (#TupleS members)] (#Some members) _ @@ -1203,7 +1213,7 @@ (def''' (apply-template env template) (-> RepEnv AST AST) (_lux_case template - (#Meta [_ (#SymbolS ["" sname])]) + [_ (#SymbolS ["" sname])] (_lux_case (get-rep sname env) (#Some subst) subst @@ -1211,13 +1221,13 @@ _ template) - (#Meta [_ (#TupleS elems)]) + [_ (#TupleS elems)] (tuple$ (map (apply-template env) elems)) - (#Meta [_ (#FormS elems)]) + [_ (#FormS elems)] (form$ (map (apply-template env) elems)) - (#Meta [_ (#RecordS members)]) + [_ (#RecordS members)] (record$ (map (_lux_: (-> (, AST AST) (, AST AST)) (lambda' [kv] (let' [[slot value] kv] @@ -1239,7 +1249,7 @@ (defmacro #export (do-template tokens) (_lux_case tokens - (#Cons [(#Meta [_ (#TupleS bindings)]) (#Cons [(#Meta [_ (#TupleS templates)]) data])]) + (#Cons [[_ (#TupleS bindings)] (#Cons [[_ (#TupleS templates)] data])]) (_lux_case (_lux_: (, ($' Maybe ($' List Text)) ($' Maybe ($' List ($' List AST)))) [(map% Maybe/Monad get-name bindings) (map% Maybe/Monad tuple->list data)]) 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)) ))) |