- Compilation for object-based procedures.

3 files changed, 182 insertions, 7 deletions

diff --git a/new-luxc/source/luxc/generator/host/jvm/inst.lux b/new-luxc/source/luxc/generator/host/jvm/inst.lux
index efc66f130..d5df6a9f7 100644
--- a/new-luxc/source/luxc/generator/host/jvm/inst.lux
+++ b/new-luxc/source/luxc/generator/host/jvm/inst.lux
@@ -28,6 +28,7 @@
                                         L2D L2F L2I)
                   <primitive> (declare T_BOOLEAN T_CHAR T_FLOAT T_DOUBLE
                                        T_BYTE T_SHORT T_INT T_LONG)
+                  <class> (declare CHECKCAST NEW INSTANCEOF)
                   <stack> (declare DUP DUP2 DUP2_X1 DUP2_X2
                                    POP POP2
                                    SWAP)
@@ -51,6 +52,7 @@
                                    FALOAD FASTORE
                                    DALOAD DASTORE
                                    CALOAD CASTORE)
+                  <concurrency> (declare MONITORENTER MONITOREXIT)
                   <return> (declare RETURN IRETURN LRETURN DRETURN ARETURN)]
   (host;import org.objectweb.asm.Opcodes
     (#static NOP int)
@@ -58,8 +60,7 @@
     <conversion>
     <primitive>
 
-    (#static CHECKCAST int)
-    (#static NEW int)
+    <class>
     
     <stack>
     <jump>
@@ -84,6 +85,8 @@
 
     (#static ATHROW int)
 
+    <concurrency>
+    
     <return>
     ))
 
@@ -196,6 +199,9 @@
   ## Exceptions
   [ATHROW]
 
+  ## Concurrency
+  [MONITORENTER] [MONITOREXIT]
+
   ## Return
   [RETURN] [IRETURN] [LRETURN] [DRETURN] [ARETURN]
   )
@@ -232,9 +238,10 @@
        (do-to visitor
          (MethodVisitor.visitTypeInsn [<inst> ($t;binary-name class)]))))]
 
-  [CHECKCAST Opcodes.CHECKCAST]
-  [NEW       Opcodes.NEW]
-  [ANEWARRAY Opcodes.ANEWARRAY]
+  [CHECKCAST  Opcodes.CHECKCAST]
+  [NEW        Opcodes.NEW]
+  [INSTANCEOF Opcodes.INSTANCEOF]
+  [ANEWARRAY  Opcodes.ANEWARRAY]
   )
 
 (def: #export (NEWARRAY type)
diff --git a/new-luxc/source/luxc/generator/procedure/host.jvm.lux b/new-luxc/source/luxc/generator/procedure/host.jvm.lux
index 128e8b517..a6e14659d 100644
--- a/new-luxc/source/luxc/generator/procedure/host.jvm.lux
+++ b/new-luxc/source/luxc/generator/procedure/host.jvm.lux
@@ -357,6 +357,77 @@
           (@;install "write" array//write)
           )))
 
+(def: (object//null _)
+  @;Nullary
+  $i;NULL)
+
+(def: (object//null? objectI)
+  @;Unary
+  (<| $i;with-label (function [@then])
+      $i;with-label (function [@end])
+      (|>. objectI
+           ($i;IFNULL @then)
+           ($i;GETSTATIC "java.lang.Boolean" "FALSE" ($t;class "java.lang.Boolean" (list)))
+           ($i;GOTO @end)
+           ($i;label @then)
+           ($i;GETSTATIC "java.lang.Boolean" "TRUE" ($t;class "java.lang.Boolean" (list)))
+           ($i;label @end))))
+
+(def: (object//synchronized [monitorI exprI])
+  @;Binary
+  (|>. monitorI
+       $i;DUP
+       $i;MONITORENTER
+       exprI
+       $i;SWAP
+       $i;MONITOREXIT))
+
+(def: (object//throw exceptionI)
+  @;Unary
+  (|>. exceptionI
+       $i;ATHROW))
+
+(def: (object//class proc generate inputs)
+  (-> Text @;Proc)
+  (case inputs
+    (^ (list (#ls;Text class)))
+    (do macro;Monad<Lux>
+      []
+      (wrap (|>. ($i;string class)
+                 ($i;INVOKESTATIC "java.lang.Class" "forName"
+                                  ($t;method (list ($t;class "java.lang.String" (list)))
+                                             (#;Some ($t;class "java.lang.Class" (list)))
+                                             (list))
+                                  false))))
+
+    _
+    (&;fail (format "Wrong syntax for '" proc "'."))))
+
+(def: (object//instance? proc generate inputs)
+  (-> Text @;Proc)
+  (case inputs
+    (^ (list (#ls;Text class) objectS))
+    (do macro;Monad<Lux>
+      [objectI (generate objectS)]
+      (wrap (|>. objectI
+                 ($i;INSTANCEOF class)
+                 ($i;wrap #$;Boolean))))
+
+    _
+    (&;fail (format "Wrong syntax for '" proc "'."))))
+
+(def: object-procs
+  @;Bundle
+  (<| (@;prefix "object")
+      (|> (dict;new text;Hash<Text>)
+          (@;install "null" (@;nullary object//null))
+          (@;install "null?" (@;unary object//null?))
+          (@;install "synchronized" (@;binary object//synchronized))
+          (@;install "throw" (@;unary object//throw))
+          (@;install "class" object//class)
+          (@;install "instance?" object//instance?)
+          )))
+
 (def: #export procedures
   @;Bundle
   (<| (@;prefix "jvm")
@@ -368,4 +439,5 @@
           (dict;merge double-procs)
           (dict;merge char-procs)
           (dict;merge array-procs)
+          (dict;merge object-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 6371286a6..a33b6d52f 100644
--- a/new-luxc/test/test/luxc/generator/procedure/host.jvm.lux
+++ b/new-luxc/test/test/luxc/generator/procedure/host.jvm.lux
@@ -3,11 +3,14 @@
   (lux [io]
        (control [monad #+ do]
                 pipe)
-       (data ["R" result]
+       (data [maybe]
+             ["R" result]
              [bit]
              [bool "bool/" Eq<Bool>]
              [number "int/" Number<Int>]
-             text/format)
+             [text "text/" Eq<Text>]
+             text/format
+             (coll [list]))
        ["r" math/random "r/" Monad<Random>]
        [macro #+ Monad<Lux>]
        [host]
@@ -341,3 +344,96 @@
                          (#R;Error error)
                          false)))
         )))
+
+(host;import java.lang.Class
+  (getName [] String))
+
+(def: classes
+  (List Text)
+  (list "java.lang.Object" "java.lang.Class"
+        "java.lang.String" "java.lang.Number"))
+
+(def: instances
+  (List [Text (r;Random ls;Synthesis)])
+  (let [gen-boolean (|> r;bool (:: r;Functor<Random> map (|>. #ls;Bool)))
+        gen-integer (|> r;int (:: r;Functor<Random> map (|>. #ls;Int)))
+        gen-double (|> r;frac (:: r;Functor<Random> map (|>. #ls;Frac)))
+        gen-string (|> (r;text +5) (:: r;Functor<Random> map (|>. #ls;Text)))]
+    (list ["java.lang.Boolean" gen-boolean]
+          ["java.lang.Long" gen-integer]
+          ["java.lang.Double" gen-double]
+          ["java.lang.String" gen-string]
+          ["java.lang.Object" (r;either (r;either gen-boolean
+                                                  gen-integer)
+                                        (r;either gen-double
+                                                  gen-string))])))
+
+(context: "Object."
+  [#let [num-classes (list;size classes)]
+   #let [num-instances (list;size instances)]
+   class-idx (|> r;nat (:: @ map (n.% num-classes)))
+   instance-idx (|> r;nat (:: @ map (n.% num-instances)))
+   #let [class (maybe;assume (list;nth class-idx classes))
+         [instance-class instance-gen] (maybe;assume (list;nth instance-idx instances))]
+   sample r;int
+   monitor r;int
+   instance instance-gen]
+  ($_ seq
+      (test "jvm object null"
+            (|> (do macro;Monad<Lux>
+                  [sampleI (@;generate (|> (#ls;Procedure "jvm object null" (list))
+                                           (list) (#ls;Procedure "jvm object null?")))]
+                  (@eval;eval sampleI))
+                (macro;run (init-compiler []))
+                (case> (#R;Success outputG)
+                       (:! Bool outputG)
+
+                       (#R;Error error)
+                       false)))
+      (test "jvm object null?"
+            (|> (do macro;Monad<Lux>
+                  [sampleI (@;generate (|> (#ls;Int sample)
+                                           (list) (#ls;Procedure "jvm object null?")))]
+                  (@eval;eval sampleI))
+                (macro;run (init-compiler []))
+                (case> (#R;Success outputG)
+                       (not (:! Bool outputG))
+
+                       (#R;Error error)
+                       false)))
+      (test "jvm object synchronized"
+            (|> (do macro;Monad<Lux>
+                  [sampleI (@;generate (#ls;Procedure "jvm object synchronized"
+                                                      (list (#ls;Int monitor)
+                                                            (#ls;Int sample))))]
+                  (@eval;eval sampleI))
+                (macro;run (init-compiler []))
+                (case> (#R;Success outputG)
+                       (i.= sample (:! Int outputG))
+
+                       (#R;Error error)
+                       false)))
+      (test "jvm object throw"
+            false)
+      (test "jvm object class"
+            (|> (do macro;Monad<Lux>
+                  [sampleI (@;generate (#ls;Procedure "jvm object class" (list (#ls;Text class))))]
+                  (@eval;eval sampleI))
+                (macro;run (init-compiler []))
+                (case> (#R;Success outputG)
+                       (|> outputG (:! Class) (Class.getName []) (text/= class))
+
+                       (#R;Error error)
+                       false)))
+      (test "jvm object instance?"
+            (|> (do macro;Monad<Lux>
+                  [sampleI (@;generate (#ls;Procedure "jvm object instance?" (list (#ls;Text instance-class)
+                                                                                   instance)))]
+                  (@eval;eval sampleI))
+                (macro;run (init-compiler []))
+                (case> (#R;Success outputG)
+                       (:! Bool outputG)
+
+                       (#R;Error error)
+                       false)))
+      ))