aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat (limited to '')
-rw-r--r--new-luxc/source/luxc/analyser/procedure/host.jvm.lux41
-rw-r--r--new-luxc/source/luxc/generator/procedure/host.jvm.lux157
-rw-r--r--new-luxc/test/test/luxc/generator/procedure/host.jvm.lux33
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)
+ ))