diff options
author | Eduardo Julian | 2018-02-06 21:12:06 -0400 |
---|---|---|
committer | Eduardo Julian | 2018-02-06 21:12:06 -0400 |
commit | fb1a1d4b86f95cc16bdf0e7872dd20901023f6c6 (patch) | |
tree | 5e56decbb8ade68fa1dbb81c575c48597815f34d /new-luxc/source/luxc/lang/translation/jvm/procedure/host.jvm.lux | |
parent | f41bd812104958a9e374bacf10a84857dee798da (diff) |
- Fixed some failing new-luxc tests.
- Re-designed the way casting is done for JVM interop.
- Now always adding extensions when initializing compiler.
Diffstat (limited to '')
-rw-r--r-- | new-luxc/source/luxc/lang/translation/jvm/procedure/host.jvm.lux | 112 |
1 files changed, 52 insertions, 60 deletions
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)) |