diff options
7 files changed, 300 insertions, 325 deletions
diff --git a/new-luxc/source/luxc/lang/extension/analysis/host.jvm.lux b/new-luxc/source/luxc/lang/extension/analysis/host.jvm.lux index dba0e3e66..5acc0cd46 100644 --- a/new-luxc/source/luxc/lang/extension/analysis/host.jvm.lux +++ b/new-luxc/source/luxc/lang/extension/analysis/host.jvm.lux @@ -58,10 +58,6 @@ (exception: #export Too-Many-Candidates) (exception: #export Cannot-Cast) -(def: (cannot-cast to from) - (-> Type Type Text) - (format "From: " (%type from) "\n" - " To: " (%type to))) (exception: #export Cannot-Possibly-Be-Instance) @@ -72,8 +68,6 @@ (exception: #export Type-Parameter-Mismatch) (exception: #export Cannot-Correspond-Type-With-Class) -(def: #export null-class Text "#Null") - (do-template [<name> <class>] [(def: #export <name> Type (#.Primitive <class> (list)))] @@ -348,7 +342,7 @@ (@.install "write" array-write) ))) -(def: (object-null proc) +(def: (object//null proc) (-> Text ///.Analysis) (function [analyse eval args] (case args @@ -361,7 +355,7 @@ _ (&.throw @.Incorrect-Procedure-Arity (@.wrong-arity proc +0 (list.size args)))))) -(def: (object-null? proc) +(def: (object//null? proc) (-> Text ///.Analysis) (function [analyse eval args] (case args @@ -376,7 +370,7 @@ _ (&.throw @.Incorrect-Procedure-Arity (@.wrong-arity proc +1 (list.size args)))))) -(def: (object-synchronized proc) +(def: (object//synchronized proc) (-> Text ///.Analysis) (function [analyse eval args] (case args @@ -471,7 +465,7 @@ sub (load-class sub)] (wrap (Class::isAssignableFrom [sub] super)))) -(def: (object-throw proc) +(def: (object//throw proc) (-> Text ///.Analysis) (function [analyse eval args] (case args @@ -491,7 +485,7 @@ _ (&.throw @.Incorrect-Procedure-Arity (@.wrong-arity proc +1 (list.size args)))))) -(def: (object-class proc) +(def: (object//class proc) (-> Text ///.Analysis) (function [analyse eval args] (case args @@ -509,7 +503,7 @@ _ (&.throw @.Incorrect-Procedure-Arity (@.wrong-arity proc +1 (list.size args)))))) -(def: (object-instance? proc) +(def: (object//instance? proc) (-> Text ///.Analysis) (function [analyse eval args] (case args @@ -532,18 +526,6 @@ _ (&.throw @.Incorrect-Procedure-Arity (@.wrong-arity proc +2 (list.size args)))))) -(def: object-procs - @.Bundle - (<| (@.prefix "object") - (|> (dict.new text.Hash<Text>) - (@.install "null" object-null) - (@.install "null?" object-null?) - (@.install "synchronized" object-synchronized) - (@.install "throw" object-throw) - (@.install "class" object-class) - (@.install "instance?" object-instance?) - ))) - (def: type-descriptor (-> java/lang/reflect/Type Text) (java/lang/reflect/Type::getTypeName [])) @@ -622,16 +604,6 @@ ## else (&.throw Cannot-Convert-To-Lux-Type (type-descriptor java-type)))) -(type: Direction - #In - #Out) - -(def: (choose direction to from) - (-> Direction Text Text Text) - (case direction - #In to - #Out from)) - (def: (correspond-type-params class type) (-> (Class Object) Type (Meta Mappings)) (case type @@ -661,64 +633,97 @@ _ (&.throw Non-JVM-Type (%type type)))) -(def: (cast direction to from) - (-> Direction Type Type (Meta [Text Type])) - (do macro.Monad<Meta> - [to-name (check-jvm to) - from-name (check-jvm from)] - (cond (dict.contains? to-name boxes) - (let [box (maybe.assume (dict.get to-name boxes))] - (if (text/= box from-name) - (wrap [(choose direction to-name from-name) (#.Primitive to-name (list))]) - (&.throw Cannot-Cast (cannot-cast to from)))) - - (dict.contains? from-name boxes) - (let [box (maybe.assume (dict.get from-name boxes))] - (do @ - [[_ castT] (cast direction to (#.Primitive box (list)))] - (wrap [(choose direction to-name from-name) castT]))) - - (text/= to-name from-name) - (wrap [(choose direction to-name from-name) from]) - - (text/= null-class from-name) - (wrap [(choose direction to-name from-name) to]) - - ## else - (do @ - [to-class (load-class to-name) - from-class (load-class from-name) - _ (&.assert Cannot-Cast (cannot-cast to from) - (Class::isAssignableFrom [from-class] to-class)) - candiate-parents (monad.map @ - (function [java-type] - (do @ - [class-name (java-type-to-class java-type) - class (load-class class-name)] - (wrap [java-type (Class::isAssignableFrom [class] to-class)]))) - (list& (Class::getGenericSuperclass [] from-class) - (array.to-list (Class::getGenericInterfaces [] from-class))))] - (case (|> candiate-parents - (list.filter product.right) - (list/map product.left)) - (#.Cons parent _) - (do @ - [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 - (&.throw Cannot-Cast (cannot-cast to from))))))) - -(def: (infer-out outputT) - (-> Type (Meta [Text Type])) - (do macro.Monad<Meta> - [expectedT macro.expected-type - [unboxed castT] (cast #Out expectedT outputT) - _ (&.with-type-env - (tc.check expectedT castT))] - (wrap [unboxed castT]))) +(def: (object//cast proc) + (-> Text ///.Analysis) + (function [analyse eval args] + (case args + (^ (list valueC)) + (do macro.Monad<Meta> + [toT macro.expected-type + to-name (check-jvm toT) + [valueT valueA] (&common.with-unknown-type + (analyse valueC)) + from-name (check-jvm valueT) + can-cast? (: (Meta Bool) + (case [from-name to-name] + (^template [<primitive> <object>] + (^or [<primitive> <object>] + [<object> <primitive>]) + (do @ + [_ (&.infer (#.Primitive to-name (list)))] + (wrap true))) + (["boolean" "java.lang.Boolean"] + ["byte" "java.lang.Byte"] + ["short" "java.lang.Short"] + ["int" "java.lang.Integer"] + ["long" "java.lang.Long"] + ["float" "java.lang.Float"] + ["double" "java.lang.Double"] + ["char" "java.lang.Character"]) + + _ + (do @ + [_ (&.assert Primitives-Are-Not-Objects from-name + (not (dict.contains? from-name boxes))) + _ (&.assert Primitives-Are-Not-Objects to-name + (not (dict.contains? to-name boxes))) + to-class (load-class to-name)] + (loop [[current-name currentT] [from-name valueT]] + (if (text/= to-name current-name) + (do @ + [_ (&.infer toT)] + (wrap true)) + (do @ + [current-class (load-class current-name) + _ (&.assert Cannot-Cast (format "From class/primitive: " current-name "\n" + " To class/primitive: " to-name "\n" + " For value: " (%code valueC) "\n") + (Class::isAssignableFrom [current-class] to-class)) + candiate-parents (monad.map @ + (function [java-type] + (do @ + [class-name (java-type-to-class java-type) + class (load-class class-name)] + (wrap [[class-name java-type] (Class::isAssignableFrom [class] to-class)]))) + (list& (Class::getGenericSuperclass [] current-class) + (array.to-list (Class::getGenericInterfaces [] current-class))))] + (case (|> candiate-parents + (list.filter product.right) + (list/map product.left)) + (#.Cons [next-name nextJT] _) + (do @ + [mapping (correspond-type-params current-class currentT) + nextT (java-type-to-lux-type mapping nextJT)] + (recur [next-name nextT])) + + #.Nil + (&.throw Cannot-Cast (format "From class/primitive: " from-name "\n" + " To class/primitive: " to-name "\n" + " For value: " (%code valueC) "\n"))) + ))))))] + (if can-cast? + (wrap (la.procedure proc (list (code.text from-name) + (code.text to-name) + valueA))) + (&.throw Cannot-Cast (format "From class/primitive: " from-name "\n" + " To class/primitive: " to-name "\n" + " For value: " (%code valueC) "\n")))) + + _ + (&.throw Wrong-Syntax (wrong-syntax proc args))))) + +(def: object-procs + @.Bundle + (<| (@.prefix "object") + (|> (dict.new text.Hash<Text>) + (@.install "null" object//null) + (@.install "null?" object//null?) + (@.install "synchronized" object//synchronized) + (@.install "throw" object//throw) + (@.install "class" object//class) + (@.install "instance?" object//instance?) + (@.install "cast" object//cast) + ))) (def: (find-field class-name field-name) (-> Text Text (Meta [(Class Object) Field])) @@ -782,29 +787,7 @@ (wrap [fieldT (Modifier::isFinal [modifiers])])) (&.throw Not-Virtual-Field (format class-name "#" field-name))))) -(def: (analyse-object class analyse sourceC) - (-> Text &.Analyser Code (Meta [Type la.Analysis])) - (do macro.Monad<Meta> - [target-class (load-class class) - targetT (java-type-to-lux-type fresh-mappings - (:! java/lang/reflect/Type - target-class)) - [sourceT sourceA] (&common.with-unknown-type - (analyse sourceC)) - [unboxed castT] (cast #Out targetT sourceT) - _ (&.assert Cannot-Cast (cannot-cast targetT sourceT) - (not (dict.contains? unboxed boxes)))] - (wrap [castT sourceA]))) - -(def: (analyse-input analyse targetT sourceC) - (-> &.Analyser Type Code (Meta [Type Text la.Analysis])) - (do macro.Monad<Meta> - [[sourceT sourceA] (&common.with-unknown-type - (analyse sourceC)) - [unboxed castT] (cast #In targetT sourceT)] - (wrap [castT unboxed sourceA]))) - -(def: (static-get proc) +(def: (static//get proc) (-> Text ///.Analysis) (function [analyse eval args] (case args @@ -812,10 +795,8 @@ (case [classC fieldC] [[_ (#.Text class)] [_ (#.Text field)]] (do macro.Monad<Meta> - [[fieldT final?] (static-field class field) - [unboxed castT] (infer-out fieldT)] - (wrap (la.procedure proc (list (code.text class) (code.text field) - (code.text unboxed))))) + [[fieldT final?] (static-field class field)] + (wrap (la.procedure proc (list (code.text class) (code.text field))))) _ (&.throw Wrong-Syntax (wrong-syntax proc args))) @@ -823,7 +804,7 @@ _ (&.throw @.Incorrect-Procedure-Arity (@.wrong-arity proc +2 (list.size args)))))) -(def: (static-put proc) +(def: (static//put proc) (-> Text ///.Analysis) (function [analyse eval args] (case args @@ -835,11 +816,9 @@ [fieldT final?] (static-field class field) _ (&.assert Cannot-Set-Final-Field (format class "#" field) (not final?)) - [valueT unboxed valueA] (analyse-input analyse fieldT valueC) - _ (&.with-type-env - (tc.check fieldT valueT))] - (wrap (la.procedure proc (list (code.text class) (code.text field) - (code.text unboxed) valueA)))) + valueA (&.with-type fieldT + (analyse valueC))] + (wrap (la.procedure proc (list (code.text class) (code.text field) valueA)))) _ (&.throw Wrong-Syntax (wrong-syntax proc args))) @@ -847,7 +826,7 @@ _ (&.throw @.Incorrect-Procedure-Arity (@.wrong-arity proc +3 (list.size args)))))) -(def: (virtual-get proc) +(def: (virtual//get proc) (-> Text ///.Analysis) (function [analyse eval args] (case args @@ -855,11 +834,10 @@ (case [classC fieldC] [[_ (#.Text class)] [_ (#.Text field)]] (do macro.Monad<Meta> - [[objectT objectA] (analyse-object class analyse objectC) - [fieldT final?] (virtual-field class field objectT) - [unboxed castT] (infer-out fieldT)] - (wrap (la.procedure proc (list (code.text class) (code.text field) - (code.text unboxed) objectA)))) + [[objectT objectA] (&common.with-unknown-type + (analyse objectC)) + [fieldT final?] (virtual-field class field objectT)] + (wrap (la.procedure proc (list (code.text class) (code.text field) objectA)))) _ (&.throw Wrong-Syntax (wrong-syntax proc args))) @@ -867,7 +845,7 @@ _ (&.throw @.Incorrect-Procedure-Arity (@.wrong-arity proc +3 (list.size args)))))) -(def: (virtual-put proc) +(def: (virtual//put proc) (-> Text ///.Analysis) (function [analyse eval args] (case args @@ -875,13 +853,15 @@ (case [classC fieldC] [[_ (#.Text class)] [_ (#.Text field)]] (do macro.Monad<Meta> - [[objectT objectA] (analyse-object class analyse objectC) + [[objectT objectA] (&common.with-unknown-type + (analyse objectC)) _ (&.infer objectT) [fieldT final?] (virtual-field class field objectT) _ (&.assert Cannot-Set-Final-Field (format class "#" field) (not final?)) - [valueT unboxed valueA] (analyse-input analyse fieldT valueC)] - (wrap (la.procedure proc (list (code.text class) (code.text field) (code.text unboxed) valueA objectA)))) + valueA (&.with-type fieldT + (analyse valueC))] + (wrap (la.procedure proc (list (code.text class) (code.text field) valueA objectA)))) _ (&.throw Wrong-Syntax (wrong-syntax proc args))) @@ -1101,16 +1081,6 @@ (list/map (function [[type value]] (la.product (list type value)))))) -(def: (sub-type-analyser analyse) - (-> &.Analyser &.Analyser) - (function [argC] - (do macro.Monad<Meta> - [[argT argA] (&common.with-unknown-type - (analyse argC)) - expectedT macro.expected-type - [unboxed castT] (cast #In expectedT argT)] - (wrap argA)))) - (def: (invoke//static proc) (-> Text ///.Analysis) (function [analyse eval args] @@ -1120,10 +1090,10 @@ (do macro.Monad<Meta> [#let [argsT (list/map product.left argsTC)] [methodT exceptionsT] (methods class method #Static argsT) - [outputT argsA] (inferenceA.general (sub-type-analyser analyse) methodT (list/map product.right argsTC)) - [unboxed castT] (infer-out outputT)] + [outputT argsA] (inferenceA.general analyse methodT (list/map product.right argsTC)) + outputJC (check-jvm outputT)] (wrap (la.procedure proc (list& (code.text class) (code.text method) - (code.text unboxed) (decorate-inputs argsT argsA))))) + (code.text outputJC) (decorate-inputs argsT argsA))))) _ (&.throw Wrong-Syntax (wrong-syntax proc args))))) @@ -1137,16 +1107,16 @@ (do macro.Monad<Meta> [#let [argsT (list/map product.left argsTC)] [methodT exceptionsT] (methods class method #Virtual argsT) - [outputT allA] (inferenceA.general (sub-type-analyser analyse) methodT (list& objectC (list/map product.right argsTC))) + [outputT allA] (inferenceA.general analyse methodT (list& objectC (list/map product.right argsTC))) #let [[objectA argsA] (case allA (#.Cons objectA argsA) [objectA argsA] _ (undefined))] - [unboxed castT] (infer-out outputT)] + outputJC (check-jvm outputT)] (wrap (la.procedure proc (list& (code.text class) (code.text method) - (code.text unboxed) objectA (decorate-inputs argsT argsA))))) + (code.text outputJC) objectA (decorate-inputs argsT argsA))))) _ (&.throw Wrong-Syntax (wrong-syntax proc args))))) @@ -1160,10 +1130,10 @@ (do macro.Monad<Meta> [#let [argsT (list/map product.left argsTC)] [methodT exceptionsT] (methods class method #Special argsT) - [outputT argsA] (inferenceA.general (sub-type-analyser analyse) methodT (list& objectC (list/map product.right argsTC))) - [unboxed castT] (infer-out outputT)] + [outputT argsA] (inferenceA.general analyse methodT (list& objectC (list/map product.right argsTC))) + outputJC (check-jvm outputT)] (wrap (la.procedure proc (list& (code.text class) (code.text method) - (code.text unboxed) (decorate-inputs argsT argsA))))) + (code.text outputJC) (decorate-inputs argsT argsA))))) _ (&.throw Wrong-Syntax (wrong-syntax proc args))))) @@ -1180,10 +1150,10 @@ _ (&.assert Non-Interface class-name (Modifier::isInterface [(Class::getModifiers [] class)])) [methodT exceptionsT] (methods class-name method #Interface argsT) - [outputT argsA] (inferenceA.general (sub-type-analyser analyse) methodT (list& objectC (list/map product.right argsTC))) - [unboxed castT] (infer-out outputT)] + [outputT argsA] (inferenceA.general analyse methodT (list& objectC (list/map product.right argsTC))) + outputJC (check-jvm outputT)] (wrap (la.procedure proc - (list& (code.text class-name) (code.text method) (code.text unboxed) + (list& (code.text class-name) (code.text method) (code.text outputJC) (decorate-inputs argsT argsA))))) _ @@ -1198,8 +1168,7 @@ (do macro.Monad<Meta> [#let [argsT (list/map product.left argsTC)] [methodT exceptionsT] (constructor-methods class argsT) - [outputT argsA] (inferenceA.general (sub-type-analyser analyse) methodT (list/map product.right argsTC)) - [unboxed castT] (infer-out outputT)] + [outputT argsA] (inferenceA.general analyse methodT (list/map product.right argsTC))] (wrap (la.procedure proc (list& (code.text class) (decorate-inputs argsT argsA))))) _ @@ -1211,12 +1180,12 @@ (|> (dict.new text.Hash<Text>) (dict.merge (<| (@.prefix "static") (|> (dict.new text.Hash<Text>) - (@.install "get" static-get) - (@.install "put" static-put)))) + (@.install "get" static//get) + (@.install "put" static//put)))) (dict.merge (<| (@.prefix "virtual") (|> (dict.new text.Hash<Text>) - (@.install "get" virtual-get) - (@.install "put" virtual-put)))) + (@.install "get" virtual//get) + (@.install "put" virtual//put)))) (dict.merge (<| (@.prefix "invoke") (|> (dict.new text.Hash<Text>) (@.install "static" invoke//static) diff --git a/new-luxc/source/luxc/lang/init.lux b/new-luxc/source/luxc/lang/init.lux index 55e02d0b6..a34399cc8 100644 --- a/new-luxc/source/luxc/lang/init.lux +++ b/new-luxc/source/luxc/lang/init.lux @@ -2,6 +2,10 @@ lux [//] (// [".L" extension] + (extension [".E" analysis] + [".E" synthesis] + [".E" translation] + [".E" statement]) (translation (jvm [".T" common])))) (def: #export (cursor file) @@ -41,5 +45,9 @@ #.expected #.None #.seed +0 #.scope-type-vars (list) - #.extensions (:! Void extensionL.fresh) + #.extensions (:! Void + {#extensionL.analysis analysisE.defaults + #extensionL.synthesis synthesisE.defaults + #extensionL.translation translationE.defaults + #extensionL.statement statementE.defaults}) #.host (:! Void host)}) diff --git a/new-luxc/source/luxc/lang/translation.lux b/new-luxc/source/luxc/lang/translation.lux index 30c4ec33c..8c42c2a71 100644 --- a/new-luxc/source/luxc/lang/translation.lux +++ b/new-luxc/source/luxc/lang/translation.lux @@ -27,22 +27,18 @@ [".L" macro] [".L" extension] [".L" init] - (extension [".E" analysis] - [".E" synthesis] - [".E" translation] - [".E" statement]) (host ["$" jvm]) (analysis [".A" expression] [".A" common]) (synthesis [".S" expression]) ["&." eval])) - (/ [js] - (js [".T" runtime] - [".T" statement] - ## [".T" common #+ Artifacts] - [".T" expression] - [".T" eval] - [".T" imports]))) + (/ ## [js] + (jvm [".T" runtime] + [".T" statement] + [".T" common #+ Artifacts] + [".T" expression] + [".T" eval] + [".T" imports]))) (def: analyse (&.Analyser) @@ -53,8 +49,8 @@ (exception: #export Invalid-Macro) (def: (process-annotations annsC) - (-> Code (Meta [js.Expression - ## $.Inst + (-> Code (Meta [## js.Expression + $.Inst Code])) (do macro.Monad<Meta> [[_ annsA] (&.with-scope @@ -242,39 +238,27 @@ (def: (initialize sources target) (-> (List File) File (Process Compiler)) (do io.Monad<Process> - [compiler (case (runtimeT.translate (initL.compiler (io.run js.init)) - ## (initL.compiler (io.run hostL.init-host)) + [compiler (case (runtimeT.translate ## (initL.compiler (io.run js.init)) + (initL.compiler (io.run hostL.init-host)) ) - (#e.Success [compiler disk-write]) - (do @ - [_ (&io.prepare-target target) - _ disk-write - ## _ (cache/io.pre-load sources target (commonT.load-definition compiler)) - ] - (wrap (|> compiler - (set@ [#.info #.mode] #.Build) - (set@ #.extensions - (:! Void - {#extensionL.analysis analysisE.defaults - #extensionL.synthesis synthesisE.defaults - #extensionL.translation translationE.defaults - #extensionL.statement statementE.defaults}))))) - - ## (#e.Success [compiler [runtime-bc function-bc]]) + ## (#e.Success [compiler disk-write]) ## (do @ ## [_ (&io.prepare-target target) - ## ## _ (&io.write target (format hostL.runtime-class ".class") runtime-bc) - ## ## _ (&io.write target (format hostL.function-class ".class") function-bc) + ## _ disk-write ## ## _ (cache/io.pre-load sources target (commonT.load-definition compiler)) ## ] ## (wrap (|> compiler - ## (set@ [#.info #.mode] #.Build) - ## (set@ #.extensions - ## (:! Void - ## {#extensionL.analysis analysisE.defaults - ## #extensionL.synthesis synthesisE.defaults - ## #extensionL.translation translationE.defaults - ## #extensionL.statement statementE.defaults}))))) + ## (set@ [#.info #.mode] #.Build)))) + + (#e.Success [compiler [runtime-bc function-bc]]) + (do @ + [_ (&io.prepare-target target) + ## _ (&io.write target (format hostL.runtime-class ".class") runtime-bc) + ## _ (&io.write target (format hostL.function-class ".class") function-bc) + ## _ (cache/io.pre-load sources target (commonT.load-definition compiler)) + ] + (wrap (|> compiler + (set@ [#.info #.mode] #.Build)))) (#e.Error error) (io.fail error))] diff --git a/new-luxc/source/luxc/lang/translation/jvm/procedure/host.jvm.lux b/new-luxc/source/luxc/lang/translation/jvm/procedure/host.jvm.lux index f585fb10c..609a0833c 100644 --- a/new-luxc/source/luxc/lang/translation/jvm/procedure/host.jvm.lux +++ b/new-luxc/source/luxc/lang/translation/jvm/procedure/host.jvm.lux @@ -424,6 +424,35 @@ _ (&.throw @.Wrong-Syntax (@.wrong-syntax proc inputs)))) +(def: (object//cast proc translate inputs) + (-> Text @.Proc) + (case inputs + (^ (list [_ (#.Text from)] [_ (#.Text to)] valueS)) + (do macro.Monad<Meta> + [valueI (translate valueS)] + (case [from to] + ## Wrap + (^template [<primitive> <object> <type>] + [<primitive> <object>] + (wrap (|>> valueI ($i.wrap <type>))) + + [<object> <primitive>] + (wrap (|>> valueI ($i.unwrap <type>)))) + (["boolean" "java.lang.Boolean" #$.Boolean] + ["byte" "java.lang.Byte" #$.Byte] + ["short" "java.lang.Short" #$.Short] + ["int" "java.lang.Integer" #$.Int] + ["long" "java.lang.Long" #$.Long] + ["float" "java.lang.Float" #$.Float] + ["double" "java.lang.Double" #$.Double] + ["char" "java.lang.Character" #$.Char]) + + _ + (wrap valueI))) + + _ + (&.throw @.Wrong-Syntax (@.wrong-syntax proc inputs)))) + (def: object-procs @.Bundle (<| (@.prefix "object") @@ -434,6 +463,7 @@ (@.install "throw" (@.unary object//throw)) (@.install "class" object//class) (@.install "instance?" object//instance?) + (@.install "cast" object//cast) ))) (def: primitives @@ -607,36 +637,15 @@ (#e.Success type) (macro/wrap type))) -(def: (prepare-input inputT inputI) - (-> $.Type $.Inst $.Inst) - (case inputT - (#$.Primitive primitive) - (|>> inputI ($i.unwrap primitive)) - - (#$.Generic generic) - (case generic - (^or (#$.Var _) (#$.Wildcard _)) - (|>> inputI ($i.CHECKCAST "java.lang.Object")) - - (#$.Class class-name _) - (|>> inputI ($i.CHECKCAST class-name))) - - _ - (|>> inputI ($i.CHECKCAST ($t.descriptor inputT))))) - -(def: (translate-args translate argsS) - (-> (-> ls.Synthesis (Meta $.Inst)) (List ls.Synthesis) - (Meta (List [$.Type $.Inst]))) - (case argsS - #.Nil - (macro/wrap #.Nil) - - (^ (list& [_ (#.Tuple (list [_ (#.Text argD)] argS))] tail)) +(def: (translate-arg translate argS) + (-> (-> ls.Synthesis (Meta $.Inst)) ls.Synthesis + (Meta [$.Type $.Inst])) + (case argS + (^ [_ (#.Tuple (list [_ (#.Text argD)] argS))]) (do macro.Monad<Meta> [argT (translate-type argD) - argI (:: @ map (prepare-input argT) (translate argS)) - =tail (translate-args translate tail)] - (wrap (list& [argT argI] =tail))) + argI (translate argS)] + (wrap [argT argI])) _ (&.throw Invalid-Syntax-For-Argument-Generation ""))) @@ -650,34 +659,18 @@ _ (macro/map (|>> #.Some) (translate-type description)))) -(def: (prepare-return returnT returnI) - (-> (Maybe $.Type) $.Inst $.Inst) - (case returnT - #.None - (|>> returnI - ($i.string hostL.unit)) - - (#.Some type) - (case type - (#$.Primitive primitive) - (|>> returnI ($i.wrap primitive)) - - _ - returnI))) - (def: (invoke//static proc translate inputs) (-> Text @.Proc) (case inputs (^ (list& [_ (#.Text class)] [_ (#.Text method)] [_ (#.Text unboxed)] argsS)) (do macro.Monad<Meta> - [argsTI (translate-args translate argsS) - returnT (method-return-type unboxed) - #let [callI (|>> ($i.fuse (list/map product.right argsTI)) - ($i.INVOKESTATIC class method - ($t.method (list/map product.left argsTI) returnT (list)) - false))]] - (wrap (prepare-return returnT callI))) + [argsTI (monad.map @ (translate-arg translate) argsS) + returnT (method-return-type unboxed)] + (wrap (|>> ($i.fuse (list/map product.right argsTI)) + ($i.INVOKESTATIC class method + ($t.method (list/map product.left argsTI) returnT (list)) + false)))) _ (&.throw @.Wrong-Syntax (@.wrong-syntax proc inputs)))) @@ -690,15 +683,14 @@ [_ (#.Text unboxed)] objectS argsS)) (do macro.Monad<Meta> [objectI (translate objectS) - argsTI (translate-args translate argsS) - returnT (method-return-type unboxed) - #let [callI (|>> objectI - ($i.CHECKCAST class) - ($i.fuse (list/map product.right argsTI)) - (<invoke> class method - ($t.method (list/map product.left argsTI) returnT (list)) - <interface?>))]] - (wrap (prepare-return returnT callI))) + argsTI (monad.map @ (translate-arg translate) argsS) + returnT (method-return-type unboxed)] + (wrap (|>> objectI + ($i.CHECKCAST class) + ($i.fuse (list/map product.right argsTI)) + (<invoke> class method + ($t.method (list/map product.left argsTI) returnT (list)) + <interface?>)))) _ (&.throw @.Wrong-Syntax (@.wrong-syntax proc inputs))))] @@ -713,7 +705,7 @@ (case inputs (^ (list& [_ (#.Text class)] argsS)) (do macro.Monad<Meta> - [argsTI (translate-args translate argsS)] + [argsTI (monad.map @ (translate-arg translate) argsS)] (wrap (|>> ($i.NEW class) $i.DUP ($i.fuse (list/map product.right argsTI)) diff --git a/new-luxc/test/test/luxc/lang/analysis/procedure/host.jvm.lux b/new-luxc/test/test/luxc/lang/analysis/procedure/host.jvm.lux index 382ad87e2..7b2b993d2 100644 --- a/new-luxc/test/test/luxc/lang/analysis/procedure/host.jvm.lux +++ b/new-luxc/test/test/luxc/lang/analysis/procedure/host.jvm.lux @@ -50,6 +50,26 @@ [failure false true] ) +(do-template [<name> <success> <failure>] + [(def: (<name> syntax output-type) + (-> Code Type Bool) + (|> (do Monad<Meta> + [runtime-bytecode @runtime.translate] + (&.with-scope + (&.with-type output-type + (expressionA.analyser evalL.eval syntax)))) + (&.with-current-module "") + (macro.run (init-compiler [])) + (case> (#e.Success _) + <success> + + (#e.Error error) + <failure>)))] + + [success' true false] + [failure' false true] + ) + (context: "Conversions [double + float]." (with-expansions [<conversions> (do-template [<procedure> <from> <to>] [(test (format <procedure> " SUCCESS") @@ -286,9 +306,9 @@ (list arrayC) Nat)) (test "jvm array read" - (success "jvm array read" - (list arrayC (code.nat idx)) - boxedT)) + (success' (` ("jvm object cast" + ("jvm array read" (~ arrayC) (~ (code.nat idx))))) + boxedT)) (test "jvm array write" (success "jvm array write" (list arrayC (code.nat idx) (`' ("lux coerce" (~ boxedTC) []))) @@ -407,8 +427,9 @@ (success "jvm member static put" (list (code.text "java.awt.datatransfer.DataFlavor") (code.text "allHtmlFlavor") - (`' ("lux check" (+0 "javax.activation.ActivationDataFlavor" (+0)) - ("jvm object null")))) + (`' ("jvm object cast" + ("lux check" (+0 "javax.activation.ActivationDataFlavor" (+0)) + ("jvm object null"))))) Unit)) )) @@ -450,8 +471,9 @@ (success "jvm member virtual put" (list (code.text "java.awt.GridBagConstraints") (code.text "insets") - (`' ("lux check" (+0 "javax.swing.plaf.InsetsUIResource" (+0)) - ("jvm object null"))) + (`' ("jvm object cast" + ("lux check" (+0 "javax.swing.plaf.InsetsUIResource" (+0)) + ("jvm object null")))) (`' ("lux check" (+0 "java.awt.GridBagConstraints" (+0)) ("jvm object null")))) (primitive "java.awt.GridBagConstraints"))) @@ -475,8 +497,9 @@ (success "jvm member virtual put" (list (code.text "javax.accessibility.AccessibleAttributeSequence") (code.text "startIndex") - (`' ("lux check" (+0 "java.lang.Integer" (+0)) - ("jvm object null"))) + (`' ("jvm object cast" + ("lux check" (+0 "java.lang.Integer" (+0)) + ("jvm object null")))) (`' ("lux check" (+0 "javax.accessibility.AccessibleAttributeSequence" (+0)) ("jvm object null")))) (primitive "javax.accessibility.AccessibleAttributeSequence"))) @@ -486,45 +509,38 @@ (let [longC (' ("lux coerce" (+0 "java.lang.Long" (+0)) +123)) intC (`' ("jvm convert long-to-int" (~ longC))) + stringC (' ("lux coerce" (+0 "java.lang.String" (+0)) + "YOLO")) objectC (`' ("lux check" (+0 "java.util.ArrayList" (+1 (+0 "java.lang.Long" (+0)) (+0))) ("jvm member invoke constructor" "java.util.ArrayList" - ["int" (~ intC)])))] + ["int" ("jvm object cast" (~ intC))])))] ($_ seq (test "jvm member invoke static" - (success "jvm member invoke static" - (list (code.text "java.lang.Long") - (code.text "decode") - (code.tuple (list (' "java.lang.String") - (' ("lux coerce" (+0 "java.lang.String" (+0)) - "YOLO"))))) - (#.Primitive "java.lang.Long" (list)))) + (success' (` ("jvm member invoke static" + "java.lang.Long" "decode" + ["java.lang.String" (~ stringC)])) + (#.Primitive "java.lang.Long" (list)))) (test "jvm member invoke virtual" - (success "jvm member invoke virtual" - (list (code.text "java.lang.Object") - (code.text "equals") - longC - (code.tuple (list (' "java.lang.Object") - longC))) - (#.Primitive "java.lang.Boolean" (list)))) + (success' (` ("jvm object cast" + ("jvm member invoke virtual" + "java.lang.Object" "equals" + ("jvm object cast" (~ longC)) ["java.lang.Object" ("jvm object cast" (~ longC))]))) + (#.Primitive "java.lang.Boolean" (list)))) (test "jvm member invoke special" - (success "jvm member invoke special" - (list (code.text "java.lang.Long") - (code.text "equals") - longC - (code.tuple (list (' "java.lang.Object") - longC))) - (#.Primitive "java.lang.Boolean" (list)))) + (success' (` ("jvm object cast" + ("jvm member invoke special" + "java.lang.Long" "equals" + ("jvm object cast" (~ longC)) ["java.lang.Object" ("jvm object cast" (~ longC))]))) + (#.Primitive "java.lang.Boolean" (list)))) (test "jvm member invoke interface" - (success "jvm member invoke interface" - (list (code.text "java.util.Collection") - (code.text "add") - objectC - (code.tuple (list (' "java.lang.Object") - longC))) - (#.Primitive "java.lang.Boolean" (list)))) + (success' (` ("jvm object cast" + ("jvm member invoke interface" + "java.util.Collection" "add" + ("jvm object cast" (~ objectC)) ["java.lang.Object" ("jvm object cast" (~ longC))]))) + (#.Primitive "java.lang.Boolean" (list)))) (test "jvm member invoke constructor" - (success "jvm member invoke constructor" - (list (code.text "java.util.ArrayList") - (code.tuple (list (' "int") intC))) - (All [a] (#.Primitive "java.util.ArrayList" (list a))))) + (success' (` ("jvm member invoke constructor" + "java.util.ArrayList" + ["int" ("jvm object cast" (~ intC))])) + (All [a] (#.Primitive "java.util.ArrayList" (list a))))) ))) diff --git a/new-luxc/test/test/luxc/lang/translation/jvm/procedure/host.jvm.lux b/new-luxc/test/test/luxc/lang/translation/jvm/procedure/host.jvm.lux index a8e53e79e..0db10f82a 100644 --- a/new-luxc/test/test/luxc/lang/translation/jvm/procedure/host.jvm.lux +++ b/new-luxc/test/test/luxc/lang/translation/jvm/procedure/host.jvm.lux @@ -520,7 +520,8 @@ [sample-short (|> r.int (:: @ map (|>> int/abs (i/% 100)))) sample-string (r.text +5) other-sample-string (r.text +5) - #let [shortS (` ["short" ("jvm convert long-to-short" (~ (code.int sample-short)))]) + #let [shortS (` ["short" ("jvm object cast" "java.lang.Short" "short" + ("jvm convert long-to-short" (~ (code.int sample-short))))]) stringS (` ["java.lang.String" (~ (code.text sample-string))]) type-codeS (` ["org.omg.CORBA.TypeCode" ("jvm object null")]) idl-typeS (` ["org.omg.CORBA.IDLType" ("jvm object null")]) @@ -587,13 +588,16 @@ (do @ [sample (|> r.int (:: @ map (|>> int/abs (i/% 100)))) #let [object-longS (` ["java.lang.Object" (~ (code.int sample))]) - intS (` ["int" ("jvm convert long-to-int" (~ (code.int sample)))]) + intS (` ["int" ("jvm object cast" "java.lang.Integer" "int" + ("jvm convert long-to-int" (~ (code.int sample))))]) coded-intS (` ["java.lang.String" (~ (code.text (int/encode sample)))]) array-listS (` ("jvm member invoke constructor" "java.util.ArrayList" (~ intS)))]] ($_ seq (test "jvm member invoke static" (|> (do macro.Monad<Meta> - [sampleI (expressionT.translate (` ("jvm member invoke static" "java.lang.Long" "decode" "java.lang.Long" (~ coded-intS))))] + [sampleI (expressionT.translate (` ("jvm member invoke static" "java.lang.Long" + "decode" "java.lang.Long" + (~ coded-intS))))] (@eval.eval sampleI)) (lang.with-current-module "") (macro.run (init-compiler [])) @@ -604,8 +608,9 @@ false))) (test "jvm member invoke virtual" (|> (do macro.Monad<Meta> - [sampleI (expressionT.translate (` ("jvm member invoke virtual" "java.lang.Object" "equals" "boolean" - (~ (code.int sample)) (~ object-longS))))] + [sampleI (expressionT.translate (` ("jvm object cast" "boolean" "java.lang.Boolean" + ("jvm member invoke virtual" "java.lang.Object" "equals" "boolean" + (~ (code.int sample)) (~ object-longS)))))] (@eval.eval sampleI)) (lang.with-current-module "") (macro.run (init-compiler [])) @@ -616,8 +621,9 @@ false))) (test "jvm member invoke interface" (|> (do macro.Monad<Meta> - [sampleI (expressionT.translate (` ("jvm member invoke interface" "java.util.Collection" "add" "boolean" - (~ array-listS) (~ object-longS))))] + [sampleI (expressionT.translate (` ("jvm object cast" "boolean" "java.lang.Boolean" + ("jvm member invoke interface" "java.util.Collection" "add" "boolean" + (~ array-listS) (~ object-longS)))))] (@eval.eval sampleI)) (lang.with-current-module "") (macro.run (init-compiler [])) diff --git a/new-luxc/test/test/luxc/lang/translation/jvm/reference.lux b/new-luxc/test/test/luxc/lang/translation/jvm/reference.lux index ddbefd8d9..8de6c4fa5 100644 --- a/new-luxc/test/test/luxc/lang/translation/jvm/reference.lux +++ b/new-luxc/test/test/luxc/lang/translation/jvm/reference.lux @@ -21,21 +21,19 @@ [".T" runtime])))) (test/luxc common)) -(def: nilI $.Inst runtimeT.noneI) - -(def: cursorI - $.Inst - (|>> ($i.int 3) - ($i.array runtimeT.$Tuple) - $i.DUP ($i.int 0) ($i.string "") $i.AASTORE - $i.DUP ($i.int 1) ($i.long 0) ($i.wrap #$.Long) $i.AASTORE - $i.DUP ($i.int 2) ($i.long 0) ($i.wrap #$.Long) $i.AASTORE)) +(def: ident-part + (r.Random Text) + (|> (r.text +5) + (r.filter (function [sample] + (not (or (text.contains? "/" sample) + (text.contains? "[" sample) + (text.contains? "]" sample))))))) (context: "Definitions." (<| (times +100) (do @ - [module-name (|> (r.text +5) (r.filter (|>> (text.contains? "/") not))) - def-name (r.text +5) + [module-name ident-part + def-name ident-part def-value r.int #let [valueI (|>> ($i.long def-value) ($i.wrap #$.Long))]] ($_ seq @@ -57,7 +55,8 @@ (context: "Variables." (<| (times +100) (do @ - [register (|> r.nat (:: @ map (n/% +100))) + [module-name (|> (r.text +5) (r.filter (|>> (text.contains? "/") not))) + register (|> r.nat (:: @ map (n/% +100))) value r.int] ($_ seq (test "Can refer to local variables/registers." @@ -67,6 +66,7 @@ (code.int value) (` ((~ (code.int (nat-to-int register))))))] (evalT.eval sampleI)) + (lang.with-current-module "") (macro.run (init-compiler [])) (case> (#e.Success outputT) (i/= value (:! Int outputT)) |