diff options
Diffstat (limited to 'new-luxc/source/luxc')
| -rw-r--r-- | new-luxc/source/luxc/lang/extension/analysis/host.jvm.lux | 295 | ||||
| -rw-r--r-- | new-luxc/source/luxc/lang/init.lux | 10 | ||||
| -rw-r--r-- | new-luxc/source/luxc/lang/translation.lux | 64 | ||||
| -rw-r--r-- | new-luxc/source/luxc/lang/translation/jvm/procedure/host.jvm.lux | 112 |
4 files changed, 217 insertions, 264 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)) |