- Compilation and tests for fields.

2 files changed, 182 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)
           )))