diff options
author | Eduardo Julian | 2017-10-18 18:59:41 -0400 |
---|---|---|
committer | Eduardo Julian | 2017-10-18 18:59:41 -0400 |
commit | ab24a9e2cededf2c59b2b0c336f00629ba7f2ccd (patch) | |
tree | 50873a24aec9a5e87f93a79e3179eb6728046aad /new-luxc/source/luxc/analyser/procedure | |
parent | 901b09dada43ec6f3b21618800ec7400fda54a0d (diff) |
- Method invocation analysis.
Diffstat (limited to 'new-luxc/source/luxc/analyser/procedure')
-rw-r--r-- | new-luxc/source/luxc/analyser/procedure/host.jvm.lux | 176 |
1 files changed, 119 insertions, 57 deletions
diff --git a/new-luxc/source/luxc/analyser/procedure/host.jvm.lux b/new-luxc/source/luxc/analyser/procedure/host.jvm.lux index ff4f0f3d6..d4029b15b 100644 --- a/new-luxc/source/luxc/analyser/procedure/host.jvm.lux +++ b/new-luxc/source/luxc/analyser/procedure/host.jvm.lux @@ -201,9 +201,7 @@ _ (&;fail (@;wrong-arity proc +1 (list;size args)))))) -(def: (not-object type) - (-> Type Text) - (format "Non-object type: " (%type type))) +(exception: #export Not-Object-Type) (def: (check-jvm objectT) (-> Type (Meta Text)) @@ -214,6 +212,9 @@ (#;Named name unnamed) (check-jvm unnamed) + (#;Var id) + (meta/wrap "java.lang.Object") + (^template [<tag>] (<tag> env unquantified) (check-jvm unquantified)) @@ -226,10 +227,10 @@ (check-jvm outputT) #;None - (&;fail (not-object objectT))) + (&;throw Not-Object-Type (%type objectT))) _ - (&;fail (not-object objectT)))) + (&;throw Not-Object-Type (%type objectT)))) (def: (check-object objectT) (-> Type (Meta Text)) @@ -627,6 +628,24 @@ #In to #Out from)) +(def: (correspond-type-params class type) + (-> (Class Object) Type (Meta Mappings)) + (case type + (#;Host name params) + (let [class-name (Class.getName [] class) + class-params (array;to-list (Class.getTypeParameters [] class))] + (if (text/= class-name name) + (if (n.= (list;size class-params) + (list;size params)) + (meta/wrap (|> params + (list;zip2 (list/map (TypeVariable.getName []) class-params)) + (dict;from-list text;Hash<Text>))) + (&;fail (format "Class and host-type parameters do not match: " "class = " class-name " | host type = " name))) + (&;fail (format "Class and host-type names do not match: " "class = " class-name " | host type = " name)))) + + _ + (&;fail (format "Not a host type: " (%type type))))) + (def: (cast direction to from) (-> Direction Type Type (Meta [Text Type])) (do meta;Monad<Meta> @@ -661,7 +680,7 @@ (do @ [class-name (java-type-to-class java-type) class (load-class class-name)] - (wrap [java-type (Class.isAssignableFrom [from-class] to-class)]))) + (wrap [java-type (Class.isAssignableFrom [class] to-class)]))) (list& (Class.getGenericSuperclass [] from-class) (array;to-list (Class.getGenericInterfaces [] from-class))))] (case (|> candiate-parents @@ -669,13 +688,23 @@ (list/map product;left)) (#;Cons parent _) (do @ - [parentT (java-type-to-lux-type fresh-mappings parent) + [mapping (correspond-type-params from-class from) + parentT (java-type-to-lux-type mapping parent) [_ castT] (cast direction to parentT)] (wrap [(choose direction to-name from-name) castT])) #;Nil (&;fail (format "No valid path between " (%type from) "and " (%type to) "."))))))) +(def: (infer-out outputT) + (-> Type (Meta [Text Type])) + (do meta;Monad<Meta> + [expectedT meta;expected-type + [unboxed castT] (cast #Out expectedT outputT) + _ (&;with-type-env + (tc;check expectedT castT))] + (wrap [unboxed castT]))) + (def: (find-field class-name field-name) (-> Text Text (Meta [(Class Object) Field])) (do meta;Monad<Meta> @@ -771,10 +800,7 @@ [[_ (#;Text class)] [_ (#;Text field)]] (do meta;Monad<Meta> [[fieldT final?] (static-field class field) - expectedT meta;expected-type - [unboxed castT] (cast #Out expectedT fieldT) - _ (&;with-type-env - (tc;check expectedT castT))] + [unboxed castT] (infer-out fieldT)] (wrap (#la;Procedure proc (list (#la;Text class) (#la;Text field) (#la;Text unboxed))))) _ @@ -816,10 +842,7 @@ (do meta;Monad<Meta> [[objectT objectA] (analyse-object class analyse objectC) [fieldT final?] (virtual-field class field objectT) - expectedT meta;expected-type - [unboxed castT] (cast #Out expectedT fieldT) - _ (&;with-type-env - (tc;check expectedT castT))] + [unboxed castT] (infer-out fieldT)] (wrap (#la;Procedure proc (list (#la;Text class) (#la;Text field) (#la;Text unboxed) objectA)))) _ @@ -864,6 +887,11 @@ (host;instance? WildcardType type)) (meta/wrap "java.lang.Object") + (host;instance? GenericArrayType type) + (do meta;Monad<Meta> + [componentP (java-type-to-parameter (GenericArrayType.getGenericComponentType [] (:! GenericArrayType type)))] + (wrap (format componentP "[]"))) + ## else (&;throw Cannot-Convert-To-Parameter (type-descriptor type)))) @@ -921,6 +949,13 @@ (-> Nat Type) (|>. (n.* +2) n.inc #;Bound)) +(def: (type-vars amount offset) + (-> Nat Nat (List Type)) + (if (n.= +0 amount) + (list) + (|> (list;n.range offset (|> amount n.dec (n.+ offset))) + (list/map idx-to-bound)))) + (def: (method-to-type method-type method) (-> Method-Type Method (Meta [Type (List Type)])) (let [owner (Method.getDeclaringClass [] method) @@ -937,10 +972,11 @@ array;to-list (list/map (TypeVariable.getName []))) num-owner-tvars (list;size owner-tvars) + num-method-tvars (list;size method-tvars) all-tvars (list/compose owner-tvars method-tvars) num-all-tvars (list;size all-tvars) - owner-tvarsT (|> (list;n.range +0 (n.dec num-owner-tvars)) (list/map idx-to-bound)) - method-tvarsT (|> (list;n.range num-owner-tvars (n.dec num-all-tvars)) (list/map idx-to-bound)) + owner-tvarsT (type-vars num-owner-tvars +0) + method-tvarsT (type-vars num-method-tvars num-owner-tvars) mappings (: Mappings (if (list;empty? all-tvars) fresh-mappings @@ -951,11 +987,11 @@ (do meta;Monad<Meta> [inputsT (|> (Method.getGenericParameterTypes [] method) array;to-list - (monad;map @ (java-type-to-lux-type fresh-mappings))) + (monad;map @ (java-type-to-lux-type mappings))) outputT (java-type-to-lux-type mappings (Method.getGenericReturnType [] method)) exceptionsT (|> (Method.getGenericExceptionTypes [] method) array;to-list - (monad;map @ (java-type-to-lux-type fresh-mappings))) + (monad;map @ (java-type-to-lux-type mappings))) #let [methodT (<| (type;univ-q num-all-tvars) (type;function (case method-type #Static @@ -1004,8 +1040,8 @@ num-owner-tvars (list;size owner-tvars) all-tvars (list/compose owner-tvars constructor-tvars) num-all-tvars (list;size all-tvars) - owner-tvarsT (|> (list;n.range +0 (n.dec num-owner-tvars)) (list/map idx-to-bound)) - constructor-tvarsT (|> (list;n.range num-owner-tvars (n.dec num-all-tvars)) (list/map idx-to-bound)) + owner-tvarsT (type-vars num-owner-tvars +0) + constructor-tvarsT (type-vars num-all-tvars num-owner-tvars) mappings (: Mappings (if (list;empty? all-tvars) fresh-mappings @@ -1016,10 +1052,10 @@ (do meta;Monad<Meta> [inputsT (|> (Constructor.getGenericParameterTypes [] constructor) array;to-list - (monad;map @ (java-type-to-lux-type fresh-mappings))) + (monad;map @ (java-type-to-lux-type mappings))) exceptionsT (|> (Constructor.getGenericExceptionTypes [] constructor) array;to-list - (monad;map @ (java-type-to-lux-type fresh-mappings))) + (monad;map @ (java-type-to-lux-type mappings))) #let [objectT (#;Host owner-name (list;reverse owner-tvarsT)) constructorT (<| (type;univ-q num-all-tvars) (type;function inputsT) @@ -1042,7 +1078,7 @@ (wrap [passes? constructor])))))] (case (list;filter product;left candidates) #;Nil - (&;throw No-Candidate-Constructor class-name) + (&;throw No-Candidate-Constructor (format class-name "(" (text;join-with ", " arg-classes) ")")) (#;Cons candidate #;Nil) (|> candidate product;right constructor-to-type) @@ -1050,17 +1086,35 @@ _ (&;throw Too-Many-Candidate-Constructors class-name)))) +(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)))) + +(def: (sub-type-analyser analyse) + (-> &;Analyser &;Analyser) + (function [argC] + (do meta;Monad<Meta> + [[argT argA] (&common;with-unknown-type + (analyse argC)) + expectedT meta;expected-type + [unboxed castT] (cast #In expectedT argT)] + (wrap argA)))) + (def: (invoke//static proc) (-> Text @;Proc) (function [analyse args] - (case (: (e;Error [(List Code) [Text Text (List [Text Code]) Unit]]) - (p;run args ($_ p;seq s;text s;text (p;some (s;tuple (p;seq s;text s;any))) s;end!))) - (#e;Success [_ [class method argsTC _]]) + (case (: (e;Error [Text Text (List [Text Code])]) + (s;run args ($_ p;seq s;text s;text (p;some (s;tuple (p;seq s;text s;any)))))) + (#e;Success [class method argsTC]) (do meta;Monad<Meta> - [[methodT exceptionsT] (methods class method #Static (list/map product;left argsTC)) - [outputT argsA] (&inference;apply-function analyse methodT (list/map product;right argsTC)) - _ (&;infer outputT)] - (wrap (#la;Procedure proc (list& (#la;Text class) (#la;Text method) argsA)))) + [#let [argsT (list/map product;left argsTC)] + [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))))) _ (&;fail (format "Wrong syntax for '" proc "'."))))) @@ -1068,14 +1122,16 @@ (def: (invoke//virtual proc) (-> Text @;Proc) (function [analyse args] - (case (: (e;Error [(List Code) [Text Text Code (List [Text Code]) Unit]]) - (p;run args ($_ p;seq s;text s;text s;any (p;some (s;tuple (p;seq s;text s;any))) s;end!))) - (#e;Success [_ [class method objectC argsTC _]]) + (case (: (e;Error [Text Text Code (List [Text Code])]) + (s;run args ($_ p;seq s;text s;text s;any (p;some (s;tuple (p;seq s;text s;any)))))) + (#e;Success [class method objectC argsTC]) (do meta;Monad<Meta> - [[methodT exceptionsT] (methods class method #Virtual (list/map product;left argsTC)) - [outputT argsA] (&inference;apply-function analyse methodT (list& objectC (list/map product;right argsTC))) - _ (&;infer outputT)] - (wrap (#la;Procedure proc (list& (#la;Text class) (#la;Text method) argsA)))) + [#let [argsT (list/map product;left argsTC)] + [methodT exceptionsT] (methods class method #Virtual 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))))) _ (&;fail (format "Wrong syntax for '" proc "'."))))) @@ -1087,10 +1143,12 @@ (p;run args ($_ p;seq s;text s;text s;any (p;some (s;tuple (p;seq s;text s;any))) s;end!))) (#e;Success [_ [class method objectC argsTC _]]) (do meta;Monad<Meta> - [[methodT exceptionsT] (methods class method #Special (list/map product;left argsTC)) - [outputT argsA] (&inference;apply-function analyse methodT (list& objectC (list/map product;right argsTC))) - _ (&;infer outputT)] - (wrap (#la;Procedure proc (list& (#la;Text class) (#la;Text method) argsA)))) + [#let [argsT (list/map product;left argsTC)] + [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))))) _ (&;fail (format "Wrong syntax for '" proc "'."))))) @@ -1100,17 +1158,19 @@ (def: (invoke//interface proc) (-> Text @;Proc) (function [analyse args] - (case (: (e;Error [(List Code) [Text Text Code (List [Text Code]) Unit]]) - (p;run args ($_ p;seq s;text s;text s;any (p;some (s;tuple (p;seq s;text s;any))) s;end!))) - (#e;Success [_ [class-name method objectC argsTC _]]) + (case (: (e;Error [Text Text Code (List [Text Code])]) + (s;run args ($_ p;seq s;text s;text s;any (p;some (s;tuple (p;seq s;text s;any)))))) + (#e;Success [class-name method objectC argsTC]) (do meta;Monad<Meta> - [class (load-class class-name) + [#let [argsT (list/map product;left argsTC)] + class (load-class class-name) _ (&;assert (Not-Interface class-name) (Modifier.isInterface [(Class.getModifiers [] class)])) - [methodT exceptionsT] (methods class-name method #Interface (list/map product;left argsTC)) - [outputT argsA] (&inference;apply-function analyse methodT (list& objectC (list/map product;right argsTC))) - _ (&;infer outputT)] - (wrap (#la;Procedure proc (list& (#la;Text class-name) (#la;Text method) argsA)))) + [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))))) _ (&;fail (format "Wrong syntax for '" proc "'."))))) @@ -1118,14 +1178,16 @@ (def: (invoke//constructor proc) (-> Text @;Proc) (function [analyse args] - (case (: (e;Error [(List Code) [Text (List [Text Code]) Unit]]) - (p;run args ($_ p;seq s;text (p;some (s;tuple (p;seq s;text s;any))) s;end!))) - (#e;Success [_ [class argsTC _]]) + (case (: (e;Error [Text (List [Text Code])]) + (s;run args ($_ p;seq s;text (p;some (s;tuple (p;seq s;text s;any)))))) + (#e;Success [class argsTC]) (do meta;Monad<Meta> - [[methodT exceptionsT] (constructor-methods class (list/map product;left argsTC)) - [outputT argsA] (&inference;apply-function analyse methodT (list/map product;right argsTC)) - _ (&;infer outputT)] - (wrap (#la;Procedure proc (list& (#la;Text class) argsA)))) + [#let [argsT (list/map product;left argsTC)] + [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) + (#la;Text unboxed) (decorate-inputs argsT argsA))))) _ (&;fail (format "Wrong syntax for '" proc "'."))))) |