diff options
Diffstat (limited to '')
3 files changed, 215 insertions, 16 deletions
diff --git a/new-luxc/source/luxc/analyser/procedure/host.jvm.lux b/new-luxc/source/luxc/analyser/procedure/host.jvm.lux index a4cc20400..1592827db 100644 --- a/new-luxc/source/luxc/analyser/procedure/host.jvm.lux +++ b/new-luxc/source/luxc/analyser/procedure/host.jvm.lux @@ -24,7 +24,7 @@ ["@" ../common] ) -(def: null-class Text "#Null") +(def: #export null-class Text "#Null") (do-template [<name> <class>] [(def: #export <name> Type (#;Host <class> (list)))] @@ -591,28 +591,38 @@ ## else (&;throw Cannot-Convert-To-Lux-Type (type-descriptor java-type)))) -(def: (cast to from) - (-> Type Type (Lux [Text Type])) +(type: Direction + #In + #Out) + +(def: (choose direction to from) + (-> Direction Text Text Text) + (case direction + #In to + #Out from)) + +(def: (cast direction to from) + (-> Direction Type Type (Lux [Text Type])) (do macro;Monad<Lux> [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 [box (#;Host to-name (list))]) + (wrap [(choose direction to-name from-name) (#;Host to-name (list))]) (&;throw Cannot-Cast-To-Primitive (format from-name " => " to-name)))) (dict;contains? from-name boxes) (let [box (maybe;assume (dict;get from-name boxes))] (do @ - [[_ castT] (cast to (#;Host box (list)))] - (wrap [from-name castT]))) + [[_ castT] (cast direction to (#;Host box (list)))] + (wrap [(choose direction to-name from-name) castT]))) (text/= to-name from-name) - (wrap ["" from]) + (wrap [(choose direction to-name from-name) from]) (text/= null-class from-name) - (wrap ["" to]) + (wrap [(choose direction to-name from-name) to]) ## else (do @ @@ -633,8 +643,9 @@ (list/map product;left)) (#;Cons parent _) (do @ - [parentT (java-type-to-lux-type fresh-mappings parent)] - (cast to parentT)) + [parentT (java-type-to-lux-type fresh-mappings 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) "."))))))) @@ -709,9 +720,9 @@ (analyse sourceC)) sourceT (&;with-type-env (tc;read var-id)) - [unboxed castT] (cast targetT sourceT) + [unboxed castT] (cast #Out targetT sourceT) _ (&;assert (format "Object cannot be a primitive: " unboxed) - (text;empty? unboxed))] + (not (dict;contains? unboxed boxes)))] (wrap [castT sourceA])))) (def: (analyse-input analyse targetT sourceC) @@ -722,7 +733,7 @@ (analyse sourceC)) sourceT (&;with-type-env (tc;read var-id)) - [unboxed castT] (cast targetT sourceT)] + [unboxed castT] (cast #In targetT sourceT)] (wrap [castT unboxed sourceA])))) (def: (static-get proc) @@ -735,7 +746,7 @@ (do macro;Monad<Lux> [[fieldT final?] (static-field class field) expectedT macro;expected-type - [unboxed castT] (cast expectedT fieldT) + [unboxed castT] (cast #Out expectedT fieldT) _ (&;with-type-env (tc;check expectedT castT))] (wrap (#la;Procedure proc (list (#la;Text class) (#la;Text field) (#la;Text unboxed))))) @@ -780,7 +791,7 @@ [[objectT objectA] (analyse-object class analyse objectC) [fieldT final?] (virtual-field class field objectT) expectedT macro;expected-type - [unboxed castT] (cast expectedT fieldT) + [unboxed castT] (cast #Out expectedT fieldT) _ (&;with-type-env (tc;check expectedT castT))] (wrap (#la;Procedure proc (list (#la;Text class) (#la;Text field) (#la;Text unboxed) objectA)))) diff --git a/new-luxc/source/luxc/generator/procedure/host.jvm.lux b/new-luxc/source/luxc/generator/procedure/host.jvm.lux index a6e14659d..d99694554 100644 --- a/new-luxc/source/luxc/generator/procedure/host.jvm.lux +++ b/new-luxc/source/luxc/generator/procedure/host.jvm.lux @@ -1,7 +1,7 @@ (;module: lux (lux (control [monad #+ do]) - (data [text] + (data [text "text/" Eq<Text>] text/format (coll [list "list/" Functor<List>] [dict #+ Dict])) @@ -13,6 +13,7 @@ (lang ["la" analysis] ["ls" synthesis]) ["&;" analyser] + (analyser (procedure ["&;" host])) ["&;" synthesizer] (synthesizer [function]) (generator ["&;" common] @@ -428,6 +429,159 @@ (@;install "instance?" object//instance?) ))) +(def: primitives + (Dict Text $;Primitive) + (|> (list ["boolean" #$;Boolean] + ["byte" #$;Byte] + ["short" #$;Short] + ["int" #$;Int] + ["long" #$;Long] + ["float" #$;Float] + ["double" #$;Double] + ["char" #$;Char]) + (dict;from-list text;Hash<Text>))) + +(def: (static//get proc generate inputs) + (-> Text @;Proc) + (case inputs + (^ (list (#ls;Text class) (#ls;Text field) (#ls;Text unboxed))) + (do macro;Monad<Lux> + [] + (case (dict;get unboxed primitives) + (#;Some primitive) + (let [primitive (case unboxed + "boolean" #$;Boolean + "byte" #$;Byte + "short" #$;Short + "int" #$;Int + "long" #$;Long + "float" #$;Float + "double" #$;Double + "char" #$;Char + _ (undefined))] + (wrap (|>. ($i;GETSTATIC class field (#$;Primitive primitive)) + ($i;wrap primitive)))) + + #;None + (wrap ($i;GETSTATIC class field ($t;class unboxed (list)))))) + + _ + (&;fail (format "Wrong syntax for '" proc "'.")))) + +(def: (static//put proc generate inputs) + (-> Text @;Proc) + (case inputs + (^ (list (#ls;Text class) (#ls;Text field) (#ls;Text unboxed) valueS)) + (do macro;Monad<Lux> + [valueI (generate valueS)] + (case (dict;get unboxed primitives) + (#;Some primitive) + (let [primitive (case unboxed + "boolean" #$;Boolean + "byte" #$;Byte + "short" #$;Short + "int" #$;Int + "long" #$;Long + "float" #$;Float + "double" #$;Double + "char" #$;Char + _ (undefined))] + (wrap (|>. valueI + ($i;unwrap primitive) + ($i;PUTSTATIC class field (#$;Primitive primitive)) + ($i;string &runtime;unit)))) + + #;None + (wrap (|>. valueI + ($i;CHECKCAST class) + ($i;PUTSTATIC class field ($t;class class (list))) + ($i;string &runtime;unit))))) + + _ + (&;fail (format "Wrong syntax for '" proc "'.")))) + +(def: (virtual//get proc generate inputs) + (-> Text @;Proc) + (case inputs + (^ (list (#ls;Text class) (#ls;Text field) (#ls;Text unboxed) objectS)) + (do macro;Monad<Lux> + [objectI (generate objectS)] + (case (dict;get unboxed primitives) + (#;Some primitive) + (let [primitive (case unboxed + "boolean" #$;Boolean + "byte" #$;Byte + "short" #$;Short + "int" #$;Int + "long" #$;Long + "float" #$;Float + "double" #$;Double + "char" #$;Char + _ (undefined))] + (wrap (|>. objectI + ($i;CHECKCAST class) + ($i;GETFIELD class field (#$;Primitive primitive)) + ($i;wrap primitive)))) + + #;None + (wrap (|>. objectI + ($i;CHECKCAST class) + ($i;GETFIELD class field ($t;class class (list))))))) + + _ + (&;fail (format "Wrong syntax for '" proc "'.")))) + +(def: (virtual//put proc generate inputs) + (-> Text @;Proc) + (case inputs + (^ (list (#ls;Text class) (#ls;Text field) (#ls;Text unboxed) valueS objectS)) + (do macro;Monad<Lux> + [valueI (generate valueS) + objectI (generate objectS)] + (case (dict;get unboxed primitives) + (#;Some primitive) + (let [primitive (case unboxed + "boolean" #$;Boolean + "byte" #$;Byte + "short" #$;Short + "int" #$;Int + "long" #$;Long + "float" #$;Float + "double" #$;Double + "char" #$;Char + _ (undefined))] + (wrap (|>. objectI + ($i;CHECKCAST class) + valueI + ($i;unwrap primitive) + ($i;PUTFIELD class field (#$;Primitive primitive)) + ($i;string &runtime;unit)))) + + #;None + (wrap (|>. objectI + ($i;CHECKCAST class) + valueI + ($i;CHECKCAST class) + ($i;PUTFIELD class field ($t;class class (list))) + ($i;string &runtime;unit))))) + + _ + (&;fail (format "Wrong syntax for '" proc "'.")))) + +(def: member-procs + @;Bundle + (<| (@;prefix "member") + (|> (dict;new text;Hash<Text>) + (dict;merge (<| (@;prefix "static") + (|> (dict;new text;Hash<Text>) + (@;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)))) + ))) + (def: #export procedures @;Bundle (<| (@;prefix "jvm") @@ -440,4 +594,5 @@ (dict;merge char-procs) (dict;merge array-procs) (dict;merge object-procs) + (dict;merge member-procs) ))) diff --git a/new-luxc/test/test/luxc/generator/procedure/host.jvm.lux b/new-luxc/test/test/luxc/generator/procedure/host.jvm.lux index a33b6d52f..8f8728112 100644 --- a/new-luxc/test/test/luxc/generator/procedure/host.jvm.lux +++ b/new-luxc/test/test/luxc/generator/procedure/host.jvm.lux @@ -437,3 +437,36 @@ (#R;Error error) false))) )) + +(host;import java.util.GregorianCalendar + (#static AD int)) + +(context: "Member [Field]" + ($_ seq + (test "jvm member static get" + (|> (do macro;Monad<Lux> + [sampleI (@;generate (|> (#ls;Procedure "jvm member static get" (list (#ls;Text "java.util.GregorianCalendar") (#ls;Text "AD") (#ls;Text "int"))) + (list) (#ls;Procedure "jvm convert int-to-long")))] + (@eval;eval sampleI)) + (macro;run (init-compiler [])) + (case> (#R;Success outputG) + (i.= GregorianCalendar.AD (:! Int outputG)) + + (#R;Error error) + false))) + (test "jvm member static put" + (|> (do macro;Monad<Lux> + [sampleI (@;generate (#ls;Procedure "jvm member static put" (list (#ls;Text "java.awt.datatransfer.DataFlavor") (#ls;Text "allHtmlFlavor") (#ls;Text "java.awt.datatransfer.DataFlavor") + (#ls;Procedure "jvm member static get" (list (#ls;Text "java.awt.datatransfer.DataFlavor") (#ls;Text "allHtmlFlavor") (#ls;Text "java.awt.datatransfer.DataFlavor"))))))] + (@eval;eval sampleI)) + (macro;run (init-compiler [])) + (case> (#R;Success outputG) + (is @runtime;unit (:! Text outputG)) + + (#R;Error error) + false))) + (test "jvm member virtual get" + false) + (test "jvm member virtual put" + false) + )) |