aboutsummaryrefslogtreecommitdiff
path: root/new-luxc/source/luxc/generator/procedure/host.jvm.lux
diff options
context:
space:
mode:
Diffstat (limited to 'new-luxc/source/luxc/generator/procedure/host.jvm.lux')
-rw-r--r--new-luxc/source/luxc/generator/procedure/host.jvm.lux157
1 files changed, 156 insertions, 1 deletions
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)
)))