diff options
Diffstat (limited to 'new-luxc/source/luxc/analyser/procedure')
| -rw-r--r-- | new-luxc/source/luxc/analyser/procedure/common.lux | 17 | ||||
| -rw-r--r-- | new-luxc/source/luxc/analyser/procedure/host.jvm.lux | 58 |
2 files changed, 41 insertions, 34 deletions
diff --git a/new-luxc/source/luxc/analyser/procedure/common.lux b/new-luxc/source/luxc/analyser/procedure/common.lux index f64c537cb..0fad41958 100644 --- a/new-luxc/source/luxc/analyser/procedure/common.lux +++ b/new-luxc/source/luxc/analyser/procedure/common.lux @@ -7,8 +7,9 @@ (coll [list "list/" Functor<List>] [array] [dict #+ Dict])) - [meta #+ Monad<Meta>] - (meta (type ["tc" check])) + [meta] + (meta [code] + (type ["tc" check])) [io]) (luxc ["&" base] (lang ["la" analysis]) @@ -48,7 +49,7 @@ (function [analyse eval args] (let [num-actual (list;size args)] (if (n.= num-expected num-actual) - (do Monad<Meta> + (do meta;Monad<Meta> [argsA (monad;map @ (function [[argT argC]] (&;with-expected-type argT @@ -57,7 +58,7 @@ expected meta;expected-type _ (&;with-type-env (tc;check expected output-type))] - (wrap (#la;Procedure proc argsA))) + (wrap (la;procedure proc argsA))) (&;fail (wrong-arity proc num-expected num-actual))))))) (def: #export (nullary valueT proc) @@ -95,7 +96,7 @@ (function [[var-id varT]] (case args (^ (list opC)) - (do Monad<Meta> + (do meta;Monad<Meta> [opA (&;with-expected-type (type (io;IO varT)) (analyse opC)) outputT (&;with-type-env @@ -103,7 +104,7 @@ expected meta;expected-type _ (&;with-type-env (tc;check expected outputT))] - (wrap (#la;Procedure proc (list opA)))) + (wrap (la;procedure proc (list opA)))) _ (&;fail (wrong-arity proc +1 (list;size args)))))))) @@ -352,7 +353,7 @@ (function [[var-id varT]] (case args (^ (list initC)) - (do Monad<Meta> + (do meta;Monad<Meta> [initA (&;with-expected-type varT (analyse initC)) outputT (&;with-type-env @@ -360,7 +361,7 @@ expected meta;expected-type _ (&;with-type-env (tc;check expected outputT))] - (wrap (#la;Procedure proc (list initA)))) + (wrap (la;procedure proc (list initA)))) _ (&;fail (wrong-arity proc +1 (list;size args)))))))) diff --git a/new-luxc/source/luxc/analyser/procedure/host.jvm.lux b/new-luxc/source/luxc/analyser/procedure/host.jvm.lux index 4db7b4dda..015379a1b 100644 --- a/new-luxc/source/luxc/analyser/procedure/host.jvm.lux +++ b/new-luxc/source/luxc/analyser/procedure/host.jvm.lux @@ -15,7 +15,8 @@ [array] [dict #+ Dict])) [meta "meta/" Monad<Meta>] - (meta ["s" syntax] + (meta [code] + ["s" syntax] [type] (type ["tc" check])) [host]) @@ -156,7 +157,7 @@ [arrayA (&;with-expected-type (type (Array varT)) (analyse arrayC)) _ (&;infer Nat)] - (wrap (#la;Procedure proc (list arrayA)))) + (wrap (la;procedure proc (list arrayA)))) _ (&;fail (@;wrong-arity proc +1 (list;size args)))))))) @@ -196,7 +197,7 @@ (&;fail (invalid-array-type expectedT))))) _ (&;assert "Must have at least 1 level of nesting in array type." (n.> +0 level))] - (wrap (#la;Procedure proc (list (#la;Nat (n.dec level)) (#la;Text elem-class) lengthA)))) + (wrap (la;procedure proc (list (code;nat (n.dec level)) (code;text elem-class) lengthA)))) _ (&;fail (@;wrong-arity proc +1 (list;size args)))))) @@ -275,7 +276,7 @@ idxA (&;with-expected-type Nat (analyse idxC)) _ (&;infer elemT)] - (wrap (#la;Procedure proc (list (#la;Text elem-class) idxA arrayA)))) + (wrap (la;procedure proc (list (code;text elem-class) idxA arrayA)))) _ (&;fail (@;wrong-arity proc +2 (list;size args)))))))) @@ -298,7 +299,7 @@ valueA (&;with-expected-type valueT (analyse valueC)) _ (&;infer (type (Array elemT)))] - (wrap (#la;Procedure proc (list (#la;Text elem-class) idxA valueA arrayA)))) + (wrap (la;procedure proc (list (code;text elem-class) idxA valueA arrayA)))) _ (&;fail (@;wrong-arity proc +3 (list;size args)))))))) @@ -321,7 +322,7 @@ (do meta;Monad<Meta> [expectedT meta;expected-type _ (check-object expectedT)] - (wrap (#la;Procedure proc (list)))) + (wrap (la;procedure proc (list)))) _ (&;fail (@;wrong-arity proc +0 (list;size args)))))) @@ -340,7 +341,7 @@ (tc;read var-id)) _ (check-object objectT) _ (&;infer Bool)] - (wrap (#la;Procedure proc (list objectA)))) + (wrap (la;procedure proc (list objectA)))) _ (&;fail (@;wrong-arity proc +1 (list;size args)))))))) @@ -359,7 +360,7 @@ (tc;read var-id)) _ (check-object monitorT) exprA (analyse exprC)] - (wrap (#la;Procedure proc (list monitorA exprA)))) + (wrap (la;procedure proc (list monitorA exprA)))) _ (&;fail (@;wrong-arity proc +2 (list;size args)))))))) @@ -465,7 +466,7 @@ (wrap []) (&;throw Not-Throwable exception-class))) _ (&;infer Bottom)] - (wrap (#la;Procedure proc (list exceptionA)))) + (wrap (la;procedure proc (list exceptionA)))) _ (&;fail (@;wrong-arity proc +1 (list;size args)))))))) @@ -480,7 +481,7 @@ (do meta;Monad<Meta> [_ (load-class class) _ (&;infer (#;Primitive "java.lang.Class" (list (#;Primitive class (list)))))] - (wrap (#la;Procedure proc (list (#la;Text class))))) + (wrap (la;procedure proc (list (code;text class))))) _ (&;fail (format "Wrong syntax for '" proc "'."))) @@ -509,7 +510,7 @@ (if ? (do @ [_ (&;infer Bool)] - (wrap (#la;Procedure proc (list (#la;Text class))))) + (wrap (la;procedure proc (list (code;text class))))) (&;throw Cannot-Be-Instance (format object-class " !<= " class)))) _ @@ -801,7 +802,8 @@ (do meta;Monad<Meta> [[fieldT final?] (static-field class field) [unboxed castT] (infer-out fieldT)] - (wrap (#la;Procedure proc (list (#la;Text class) (#la;Text field) (#la;Text unboxed))))) + (wrap (la;procedure proc (list (code;text class) (code;text field) + (code;text unboxed))))) _ (&;fail (format "Wrong syntax for '" proc "'."))) @@ -824,7 +826,8 @@ _ (&;with-type-env (tc;check fieldT valueT)) _ (&;infer Unit)] - (wrap (#la;Procedure proc (list (#la;Text class) (#la;Text field) (#la;Text unboxed) valueA)))) + (wrap (la;procedure proc (list (code;text class) (code;text field) + (code;text unboxed) valueA)))) _ (&;fail (format "Wrong syntax for '" proc "'."))) @@ -843,7 +846,8 @@ [[objectT objectA] (analyse-object class analyse objectC) [fieldT final?] (virtual-field class field objectT) [unboxed castT] (infer-out fieldT)] - (wrap (#la;Procedure proc (list (#la;Text class) (#la;Text field) (#la;Text unboxed) objectA)))) + (wrap (la;procedure proc (list (code;text class) (code;text field) + (code;text unboxed) objectA)))) _ (&;fail (format "Wrong syntax for '" proc "'."))) @@ -867,7 +871,7 @@ _ (&;with-type-env (tc;check fieldT valueT)) _ (&;infer objectT)] - (wrap (#la;Procedure proc (list (#la;Text class) (#la;Text field) (#la;Text unboxed) valueA objectA)))) + (wrap (la;procedure proc (list (code;text class) (code;text field) (code;text unboxed) valueA objectA)))) _ (&;fail (format "Wrong syntax for '" proc "'."))) @@ -1089,8 +1093,9 @@ (def: (decorate-inputs typesT inputsA) (-> (List Text) (List la;Analysis) (List la;Analysis)) (|> inputsA - (list;zip2 (list/map (|>. #la;Text) typesT)) - (list/map (|>. #la;Product)))) + (list;zip2 (list/map code;text typesT)) + (list/map (function [[type value]] + (la;product (list type value)))))) (def: (sub-type-analyser analyse) (-> &;Analyser &;Analyser) @@ -1113,8 +1118,8 @@ [methodT exceptionsT] (methods class method #Static argsT) [outputT argsA] (&inference;apply-function (sub-type-analyser analyse) methodT (list/map product;right argsTC)) [unboxed castT] (infer-out outputT)] - (wrap (#la;Procedure proc (list& (#la;Text class) (#la;Text method) - (#la;Text unboxed) (decorate-inputs argsT argsA))))) + (wrap (la;procedure proc (list& (code;text class) (code;text method) + (code;text unboxed) (decorate-inputs argsT argsA))))) _ (&;fail (format "Wrong syntax for '" proc "'."))))) @@ -1136,8 +1141,8 @@ _ (undefined))] [unboxed castT] (infer-out outputT)] - (wrap (#la;Procedure proc (list& (#la;Text class) (#la;Text method) - (#la;Text unboxed) objectA (decorate-inputs argsT argsA))))) + (wrap (la;procedure proc (list& (code;text class) (code;text method) + (code;text unboxed) objectA (decorate-inputs argsT argsA))))) _ (&;fail (format "Wrong syntax for '" proc "'."))))) @@ -1153,8 +1158,8 @@ [methodT exceptionsT] (methods class method #Special argsT) [outputT argsA] (&inference;apply-function (sub-type-analyser analyse) methodT (list& objectC (list/map product;right argsTC))) [unboxed castT] (infer-out outputT)] - (wrap (#la;Procedure proc (list& (#la;Text class) (#la;Text method) - (#la;Text unboxed) (decorate-inputs argsT argsA))))) + (wrap (la;procedure proc (list& (code;text class) (code;text method) + (code;text unboxed) (decorate-inputs argsT argsA))))) _ (&;fail (format "Wrong syntax for '" proc "'."))))) @@ -1175,8 +1180,9 @@ [methodT exceptionsT] (methods class-name method #Interface argsT) [outputT argsA] (&inference;apply-function (sub-type-analyser analyse) methodT (list& objectC (list/map product;right argsTC))) [unboxed castT] (infer-out outputT)] - (wrap (#la;Procedure proc (list& (#la;Text class-name) (#la;Text method) - (#la;Text unboxed) (decorate-inputs argsT argsA))))) + (wrap (la;procedure proc + (list& (code;text class-name) (code;text method) (code;text unboxed) + (decorate-inputs argsT argsA))))) _ (&;fail (format "Wrong syntax for '" proc "'."))))) @@ -1192,7 +1198,7 @@ [methodT exceptionsT] (constructor-methods class argsT) [outputT argsA] (&inference;apply-function (sub-type-analyser analyse) methodT (list/map product;right argsTC)) [unboxed castT] (infer-out outputT)] - (wrap (#la;Procedure proc (list& (#la;Text class) (decorate-inputs argsT argsA))))) + (wrap (la;procedure proc (list& (code;text class) (decorate-inputs argsT argsA))))) _ (&;fail (format "Wrong syntax for '" proc "'."))))) |