WIP: Tests for JVM bytecode machinery. [Part 3]

1 files changed, 196 insertions, 3 deletions

diff --git a/stdlib/source/test/lux/target/jvm.lux b/stdlib/source/test/lux/target/jvm.lux
index 1ab7ed5ab..f0e6b2b91 100644
--- a/stdlib/source/test/lux/target/jvm.lux
+++ b/stdlib/source/test/lux/target/jvm.lux
@@ -13,6 +13,7 @@
      ["!" capability]]]
    [data
     [binary (#+ Binary)]
+    ["." maybe]
     ["." bit ("#@." equivalence)]
     [number
      ["." i32 (#+ I32)]
@@ -27,7 +28,9 @@
     [collection
      ["." array]
      ["." dictionary]
-     ["." row]]]
+     ["." row]
+     ["." set]
+     ["." list ("#@." functor)]]]
    [world
     ["." file (#+ File)]]
    [math
@@ -47,8 +50,9 @@
      ["#/." pool]]
     [encoding
      ["#." name]
+     ["#." signed]
      ["#." unsigned]]
-    ["#" bytecode (#+ Bytecode)
+    ["#" bytecode (#+ Label Bytecode)
      ["#." instruction]
      [environment
       [limit
@@ -945,7 +949,24 @@
                   (_.lift "ISTORE/ILOAD"
                           (store-and-load ..$Integer::random ..$Integer::literal ..$Integer::wrap [/.istore /.iload]
                                           (function (_ expected actual)
-                                            (|> actual (:coerce java/lang/Integer) ("jvm ieq" expected))))))))
+                                            (|> actual (:coerce java/lang/Integer) ("jvm ieq" expected)))))
+                  (_.lift "IINC"
+                          (do random.monad
+                            [base ..$Byte::random
+                             increment (:: @ map (|>> (n.% 100) /unsigned.u1 try.assume)
+                                           random.nat)
+                             #let [expected ("jvm ladd"
+                                             (host.byte-to-long base)
+                                             (.int (/unsigned.value increment)))]]
+                            (..bytecode (|>> (:coerce java/lang/Long) ("jvm leq" expected))
+                                        (do /.monad
+                                          [_ (..$Byte::literal base)
+                                           _ /.istore-0
+                                           @0 (/.register 0)
+                                           _ (/.iinc @0 increment)
+                                           _ /.iload-0
+                                           _ /.i2l]
+                                          ..$Long::wrap)))))))
         (<| (_.context "long")
             (let [test-long (: (-> Int Int (-> Any Bit))
                                (function (_ parameter subject)
@@ -1159,11 +1180,183 @@
                                            (function (_ expected actual) (text@= expected (:coerce java/lang/String actual)))))
         )))
 
+(def: branching
+  Test
+  (do random.monad
+    [expected ..$Long::random
+     dummy ..$Long::random
+     #let [if! (: (-> (-> Label (Bytecode Any)) (Bytecode Any) (Random Bit))
+                  (function (_ instruction prelude)
+                    (<| (..bytecode (|>> (:coerce java/lang/Long) ("jvm leq" expected)))
+                        (do /.monad
+                          [@then /.new-label
+                           @end /.new-label
+                           _ prelude
+                           _ (instruction @then)
+                           _ (..$Long::literal dummy)
+                           _ (/.goto @end)
+                           _ (/.set-label @then)
+                           _ (..$Long::literal expected)
+                           _ (/.set-label @end)]
+                          ..$Long::wrap))))
+           comparison-against-zero ($_ _.and
+                                       (_.lift "IFEQ" (if! /.ifeq /.iconst-0))
+                                       (_.lift "IFNE" (if! /.ifne /.iconst-1))
+                                       (_.lift "IFLT" (if! /.iflt /.iconst-m1))
+                                       (_.lift "IFLE" (if! /.ifle /.iconst-0))
+                                       (_.lift "IFGT" (if! /.ifgt /.iconst-1))
+                                       (_.lift "IFGE" (if! /.ifge /.iconst-0)))
+           null-test ($_ _.and
+                         (_.lift "IFNULL" (if! /.ifnull /.aconst-null))
+                         (_.lift "IFNONNULL" (if! /.ifnonnull (/.string ""))))]
+     reference ..$Integer::random
+     subject (|> ..$Integer::random
+                 (random.filter (|>> ("jvm ieq" reference) not)))
+     #let [[lesser greater] (if ("jvm ilt" reference subject)
+                              [reference subject]
+                              [subject reference])
+           int-comparison ($_ _.and
+                              (_.lift "IF_ICMPEQ" (if! /.if-icmpeq (do /.monad [_ (..$Integer::literal reference)] /.dup)))
+                              (_.lift "IF_ICMPNE" (if! /.if-icmpne (do /.monad [_ (..$Integer::literal reference)] (..$Integer::literal subject))))
+                              (_.lift "IF_ICMPLT" (if! /.if-icmplt (do /.monad [_ (..$Integer::literal lesser)] (..$Integer::literal greater))))
+                              (_.lift "IF_ICMPLE" (if! /.if-icmple (do /.monad [_ (..$Integer::literal lesser)] (..$Integer::literal greater))))
+                              (_.lift "IF_ICMPGT" (if! /.if-icmpgt (do /.monad [_ (..$Integer::literal greater)] (..$Integer::literal lesser))))
+                              (_.lift "IF_ICMPGE" (if! /.if-icmpge (do /.monad [_ (..$Integer::literal greater)] (..$Integer::literal lesser)))))
+           new-object (: (Bytecode Any)
+                         (do /.monad
+                           [_ (/.new ..$Object)
+                            _ /.dup]
+                           (/.invokespecial ..$Object "<init>" (/type.method [(list) /type.void (list)]))))
+           reference-comparison ($_ _.and
+                                    (_.lift "IF_ACMPEQ" (if! /.if-acmpeq (do /.monad [_ new-object] /.dup)))
+                                    (_.lift "IF_ACMPNE" (if! /.if-acmpne (do /.monad [_ new-object] new-object)))
+                                    )]]
+    ($_ _.and
+        comparison-against-zero
+        null-test
+        int-comparison
+        reference-comparison
+        )))
+
+(def: jump
+  Test
+  (do random.monad
+    [expected ..$Long::random
+     dummy ..$Long::random
+     #let [jump (: (-> (-> Label (Bytecode Any)) (Random Bit))
+                   (function (_ goto)
+                     (<| (..bytecode (|>> (:coerce java/lang/Long) ("jvm leq" expected)))
+                         (do /.monad
+                           [^value /.new-label
+                            ^end /.new-label
+                            _ (goto ^value)
+                            _ (..$Long::literal dummy)
+                            _ (goto ^end)
+                            _ (/.set-label ^value)
+                            _ (..$Long::literal expected)
+                            _ (/.set-label ^end)]
+                           ..$Long::wrap))))]]
+    ($_ _.and
+        (_.lift "GOTO" (jump /.goto))
+        (_.lift "GOTO_W" (jump /.goto-w)))))
+
+(def: switch
+  Test
+  ($_ _.and
+      (<| (_.lift "TABLESWITCH")
+          (do random.monad
+            [expected ..$Long::random
+             dummy ..$Long::random
+             minimum (:: @ map (|>> (n.% 100) .int /signed.s4 try.assume)
+                         random.nat)
+             afterwards (:: @ map (n.% 10) random.nat)])
+          (..bytecode (|>> (:coerce java/lang/Long) ("jvm leq" expected)))
+          (do /.monad
+            [^right /.new-label
+             ^wrong /.new-label
+             ^return /.new-label
+             _ (/.bipush (|> minimum /signed.value .nat /unsigned.u1 try.assume))
+             _ (/.tableswitch minimum ^wrong [^right (list.repeat afterwards ^wrong)])
+             _ (/.set-label ^wrong)
+             _ (..$Long::literal dummy)
+             _ (/.goto ^return)
+             _ (/.set-label ^right)
+             _ (..$Long::literal expected)
+             _ (/.set-label ^return)]
+            ..$Long::wrap))
+      (<| (_.lift "LOOKUPSWITCH")
+          (do random.monad
+            [options (:: @ map (|>> (n.% 10) (n.+ 1))
+                         random.nat)
+             choice (:: @ map (n.% options) random.nat)
+             options (|> random.int
+                         (:: @ map (|>> host.long-to-int host.int-to-long))
+                         (random.set i.hash options)
+                         (:: @ map set.to-list))
+             #let [choice (maybe.assume (list.nth choice options))]
+             expected ..$Long::random
+             dummy ..$Long::random])
+          (..bytecode (|>> (:coerce java/lang/Long) ("jvm leq" expected)))
+          (do /.monad
+            [^right /.new-label
+             ^wrong /.new-label
+             ^return /.new-label
+             _ (..$Integer::literal (host.long-to-int choice))
+             _ (/.lookupswitch ^wrong (list@map (function (_ option)
+                                                  [(|> option /signed.s4 try.assume)
+                                                   (if (i.= choice option) ^right ^wrong)])
+                                                options))
+             _ (/.set-label ^wrong)
+             _ (..$Long::literal dummy)
+             _ (/.goto ^return)
+             _ (/.set-label ^right)
+             _ (..$Long::literal expected)
+             _ (/.set-label ^return)]
+            ..$Long::wrap))
+      ))
+
+(def: exception
+  Test
+  (do random.monad
+    [expected ..$Long::random
+     dummy ..$Long::random
+     exception ..$String::random]
+    (<| (_.lift "ATHROW")
+        (..bytecode (|>> (:coerce java/lang/Long) ("jvm leq" expected)))
+        (do /.monad
+          [#let [$Exception (/type.class "java.lang.Exception" (list))]
+           ^start /.new-label
+           ^end /.new-label
+           ^handler /.new-label
+           ^return /.new-label
+           _ (/.try ^start ^end ^handler $Exception)
+           _ (/.set-label ^start)
+           _ (/.new $Exception)
+           _ /.dup
+           _ (..$String::literal exception)
+           _ (/.invokespecial $Exception "<init>" (/type.method [(list ..$String) /type.void (list)]))
+           _ /.athrow
+           _ (..$Long::literal dummy)
+           _ (/.goto ^return)
+           _ (/.set-label ^end)
+           _ (/.set-label ^handler)
+           _ (..$Long::literal expected)
+           _ (/.set-label ^return)]
+          ..$Long::wrap))))
+
 (def: code
   Test
   ($_ _.and
       (<| (_.context "return")
           ..return)
+      (<| (_.context "branching")
+          ..branching)
+      (<| (_.context "jump")
+          ..jump)
+      (<| (_.context "switch")
+          ..switch)
+      (<| (_.context "exception")
+          ..exception)
       ))
 
 (def: instruction