- Added tests for host procedures.

2 files changed, 355 insertions, 1 deletions

diff --git a/new-luxc/test/test/luxc/analyser/procedure/host.jvm.lux b/new-luxc/test/test/luxc/analyser/procedure/host.jvm.lux
new file mode 100644
index 000000000..eec4ec723
--- /dev/null
+++ b/new-luxc/test/test/luxc/analyser/procedure/host.jvm.lux
@@ -0,0 +1,353 @@
+(;module:
+  lux
+  (lux [io]
+       (control [monad #+ do]
+                pipe)
+       (concurrency [atom])
+       (data text/format
+             [text "text/" Eq<Text>]
+             ["R" result]
+             [product]
+             (coll [array]
+                   [list "list/" Fold<List>]
+                   [dict]))
+       ["r" math/random "r/" Monad<Random>]
+       [type]
+       [macro #+ Monad<Lux>]
+       (macro [code])
+       test)
+  (luxc ["&" base]
+        ["&;" scope]
+        ["&;" module]
+        (lang ["~" analysis])
+        [analyser]
+        (analyser ["@" procedure]
+                  ["@;" common]
+                  (procedure ["@;" host]))
+        (generator ["@;" runtime]))
+  (../.. common)
+  (test/luxc common))
+
+(do-template [<name> <success> <failure>]
+  [(def: (<name> procedure params output-type)
+     (-> Text (List Code) Type Bool)
+     (|> (do Monad<Lux>
+           [runtime-bytecode @runtime;generate]
+           (&;with-scope
+             (&;with-expected-type output-type
+               (@;analyse-procedure analyse procedure params))))
+         (macro;run (init-compiler []))
+         (case> (#R;Success _)
+                <success>
+
+                (#R;Error error)
+                <failure>)))]
+
+  [success true false]
+  [failure false true]
+  )
+
+(context: "Conversions [double + float]."
+  (with-expansions [<conversions> (do-template [<procedure> <from> <to>]
+                                    [(test (format <procedure> " SUCCESS")
+                                           (success <procedure> (list (' (_lux_coerce (+0 <from> (+0)) []))) <to>))
+                                     (test (format <procedure> " FAILURE")
+                                           (failure <procedure> (list (' [])) <to>))]
+
+                                    ["jvm convert double-to-float" "java.lang.Double" @host;Float]
+                                    ["jvm convert double-to-int" "java.lang.Double" @host;Integer]
+                                    ["jvm convert double-to-long" "java.lang.Double" @host;Long]
+                                    ["jvm convert float-to-double" "java.lang.Float" @host;Double]
+                                    ["jvm convert float-to-int" "java.lang.Float" @host;Integer]
+                                    ["jvm convert float-to-long" "java.lang.Float" @host;Long]
+                                    )]
+    ($_ seq
+        <conversions>
+        )))
+
+(context: "Conversions [int]."
+  (with-expansions [<conversions> (do-template [<procedure> <from> <to>]
+                                    [(test (format <procedure> " SUCCESS")
+                                           (success <procedure> (list (' (_lux_coerce (+0 <from> (+0)) []))) <to>))
+                                     (test (format <procedure> " FAILURE")
+                                           (failure <procedure> (list (' [])) <to>))]
+
+                                    ["jvm convert int-to-byte" "java.lang.Integer" @host;Byte]
+                                    ["jvm convert int-to-char" "java.lang.Integer" @host;Character]
+                                    ["jvm convert int-to-double" "java.lang.Integer" @host;Double]
+                                    ["jvm convert int-to-float" "java.lang.Integer" @host;Float]
+                                    ["jvm convert int-to-long" "java.lang.Integer" @host;Long]
+                                    ["jvm convert int-to-short" "java.lang.Integer" @host;Short]
+                                    )]
+    ($_ seq
+        <conversions>
+        )))
+
+(context: "Conversions [long]."
+  (with-expansions [<conversions> (do-template [<procedure> <from> <to>]
+                                    [(test (format <procedure> " SUCCESS")
+                                           (success <procedure> (list (' (_lux_coerce (+0 <from> (+0)) []))) <to>))
+                                     (test (format <procedure> " FAILURE")
+                                           (failure <procedure> (list (' [])) <to>))]
+
+                                    ["jvm convert long-to-double" "java.lang.Long" @host;Double]
+                                    ["jvm convert long-to-float" "java.lang.Long" @host;Float]
+                                    ["jvm convert long-to-int" "java.lang.Long" @host;Integer]
+                                    ["jvm convert long-to-short" "java.lang.Long" @host;Short]
+                                    ["jvm convert long-to-byte" "java.lang.Long" @host;Byte]
+                                    )]
+    ($_ seq
+        <conversions>
+        )))
+
+(context: "Conversions [char + byte + short]."
+  (with-expansions [<conversions> (do-template [<procedure> <from> <to>]
+                                    [(test (format <procedure> " SUCCESS")
+                                           (success <procedure> (list (' (_lux_coerce (+0 <from> (+0)) []))) <to>))
+                                     (test (format <procedure> " FAILURE")
+                                           (failure <procedure> (list (' [])) <to>))]
+
+                                    ["jvm convert char-to-byte" "java.lang.Character" @host;Byte]
+                                    ["jvm convert char-to-short" "java.lang.Character" @host;Short]
+                                    ["jvm convert char-to-int" "java.lang.Character" @host;Integer]
+                                    ["jvm convert char-to-long" "java.lang.Character" @host;Long]
+                                    ["jvm convert byte-to-long" "java.lang.Byte" @host;Long]
+                                    ["jvm convert short-to-long" "java.lang.Short" @host;Long]
+                                    )]
+    ($_ seq
+        <conversions>
+        )))
+
+(do-template [<domain> <boxed> <type>]
+  [(context: (format "Arithmetic " "[" <domain> "].")
+     (with-expansions [<instructions> (do-template [<procedure> <subject> <param> <output>]
+                                        [(test <procedure>
+                                               (success <procedure>
+                                                        (list (' (_lux_coerce (+0 <subject> (+0)) []))
+                                                              (' (_lux_coerce (+0 <param> (+0)) [])))
+                                                        <output>))]
+
+                                        [(format "jvm " <domain> " +") <boxed> <boxed> <type>]
+                                        [(format "jvm " <domain> " -") <boxed> <boxed> <type>]
+                                        [(format "jvm " <domain> " *") <boxed> <boxed> <type>]
+                                        [(format "jvm " <domain> " /") <boxed> <boxed> <type>]
+                                        [(format "jvm " <domain> " %") <boxed> <boxed> <type>]
+                                        )]
+       ($_ seq
+           <instructions>
+           )))
+
+   (context: (format "Order " "[" <domain> "].")
+     (with-expansions [<instructions> (do-template [<procedure> <subject> <param> <output>]
+                                        [(test <procedure>
+                                               (success <procedure>
+                                                        (list (' (_lux_coerce (+0 <subject> (+0)) []))
+                                                              (' (_lux_coerce (+0 <param> (+0)) [])))
+                                                        <output>))]
+
+                                        [(format "jvm " <domain> " =") <boxed> <boxed> @host;Boolean]
+                                        [(format "jvm " <domain> " <") <boxed> <boxed> @host;Boolean]
+                                        [(format "jvm " <domain> " >") <boxed> <boxed> @host;Boolean]
+                                        )]
+       ($_ seq
+           <instructions>
+           )))
+
+   (context: (format "Bitwise " "[" <domain> "].")
+     (with-expansions [<instructions> (do-template [<procedure> <subject> <param> <output>]
+                                        [(test <procedure>
+                                               (success <procedure>
+                                                        (list (' (_lux_coerce (+0 <subject> (+0)) []))
+                                                              (' (_lux_coerce (+0 <param> (+0)) [])))
+                                                        <output>))]
+
+                                        [(format "jvm " <domain> " and") <boxed> <boxed> <type>]
+                                        [(format "jvm " <domain> " or") <boxed> <boxed> <type>]
+                                        [(format "jvm " <domain> " xor") <boxed> <boxed> <type>]
+                                        [(format "jvm " <domain> " shl") <boxed> "java.lang.Integer" <type>]
+                                        [(format "jvm " <domain> " shr") <boxed> "java.lang.Integer" <type>]
+                                        [(format "jvm " <domain> " ushr") <boxed> "java.lang.Integer" <type>]
+                                        )]
+       ($_ seq
+           <instructions>
+           )))]
+
+
+  ["int" "java.lang.Integer" @host;Integer]
+  ["long" "java.lang.Long" @host;Long]
+  )
+
+(do-template [<domain> <boxed> <type>]
+  [(context: (format "Arithmetic " "[" <domain> "].")
+     (with-expansions [<instructions> (do-template [<procedure> <subject> <param> <output>]
+                                        [(test <procedure>
+                                               (success <procedure>
+                                                        (list (' (_lux_coerce (+0 <subject> (+0)) []))
+                                                              (' (_lux_coerce (+0 <param> (+0)) [])))
+                                                        <output>))]
+
+                                        [(format "jvm " <domain> " +") <boxed> <boxed> <type>]
+                                        [(format "jvm " <domain> " -") <boxed> <boxed> <type>]
+                                        [(format "jvm " <domain> " *") <boxed> <boxed> <type>]
+                                        [(format "jvm " <domain> " /") <boxed> <boxed> <type>]
+                                        [(format "jvm " <domain> " %") <boxed> <boxed> <type>]
+                                        )]
+       ($_ seq
+           <instructions>
+           )))
+
+   (context: (format "Order " "[" <domain> "].")
+     (with-expansions [<instructions> (do-template [<procedure> <subject> <param> <output>]
+                                        [(test <procedure>
+                                               (success <procedure>
+                                                        (list (' (_lux_coerce (+0 <subject> (+0)) []))
+                                                              (' (_lux_coerce (+0 <param> (+0)) [])))
+                                                        <output>))]
+
+                                        [(format "jvm " <domain> " =") <boxed> <boxed> @host;Boolean]
+                                        [(format "jvm " <domain> " <") <boxed> <boxed> @host;Boolean]
+                                        [(format "jvm " <domain> " >") <boxed> <boxed> @host;Boolean]
+                                        )]
+       ($_ seq
+           <instructions>
+           )))]
+
+
+  ["float" "java.lang.Float" @host;Float]
+  ["double" "java.lang.Double" @host;Double]
+  )
+
+(do-template [<domain> <boxed> <type>]
+  [(context: (format "Order " "[" <domain> "].")
+     (with-expansions [<instructions> (do-template [<procedure> <subject> <param> <output>]
+                                        [(test <procedure>
+                                               (success <procedure>
+                                                        (list (' (_lux_coerce (+0 <subject> (+0)) []))
+                                                              (' (_lux_coerce (+0 <param> (+0)) [])))
+                                                        <output>))]
+
+                                        [(format "jvm " <domain> " =") <boxed> <boxed> @host;Boolean]
+                                        [(format "jvm " <domain> " <") <boxed> <boxed> @host;Boolean]
+                                        [(format "jvm " <domain> " >") <boxed> <boxed> @host;Boolean]
+                                        )]
+       ($_ seq
+           <instructions>
+           )))]
+
+
+  ["char" "java.lang.Character" @host;Character]
+  )
+
+(def: array-type
+  (r;Random [Text Text])
+  (let [entries (dict;entries @host;boxes)
+        num-entries (list;size entries)]
+    (do r;Monad<Random>
+      [choice (|> r;nat (:: @ map (n.% (n.inc num-entries))))
+       #let [[unboxed boxed] (: [Text Text]
+                                (|> entries
+                                    (list;nth choice)
+                                    (default ["java.lang.Object" "java.lang.Object"])))]]
+      (wrap [unboxed boxed]))))
+
+(context: "Array."
+  [#let [cap (|>. (n.% +10) (n.max +1))]
+   [unboxed boxed] array-type
+   size (|> r;nat (:: @ map cap))
+   idx (|> r;nat (:: @ map (n.% size)))
+   level (|> r;nat (:: @ map cap))
+   #let [unboxedT (#;Host unboxed (list))
+         arrayT (#;Host "#Array" (list unboxedT))
+         arrayC (`' (_lux_check (+0 "#Array" (+1 (+0 (~ (code;text unboxed)) (+0)) (+0)))
+                                ("jvm array new" (~ (code;nat size)))))
+         boxedT (#;Host boxed (list))
+         boxedTC (` (+0 (~ (code;text boxed)) (+0)))
+         multi-arrayT (list/fold (function [_ innerT]
+                                   (|> innerT (list) (#;Host "#Array")))
+                                 boxedT
+                                 (list;n.range +1 level))]]
+  ($_ seq
+      (test "jvm array new"
+            (success "jvm array new"
+                     (list (code;nat size))
+                     arrayT))
+      (test "jvm array new (no nesting)"
+            (failure "jvm array new"
+                     (list (code;nat size))
+                     unboxedT))
+      (test "jvm array new (nested/multi-level)"
+            (success "jvm array new"
+                     (list (code;nat size))
+                     multi-arrayT))
+      (test "jvm array length"
+            (success "jvm array length"
+                     (list arrayC)
+                     Nat))
+      (test "jvm array read"
+            (success "jvm array read"
+                     (list arrayC (code;nat idx))
+                     boxedT))
+      (test "jvm array write"
+            (success "jvm array write"
+                     (list arrayC (code;nat idx) (`' (_lux_coerce (~ boxedTC) [])))
+                     arrayT))
+      ))
+
+(def: throwables
+  (List Text)
+  (list "java.lang.Throwable"
+        "java.lang.Error"
+        "java.io.IOError"
+        "java.lang.VirtualMachineError"
+        "java.lang.Exception"
+        "java.io.IOException"
+        "java.lang.RuntimeException"))
+
+(context: "Object."
+  [[unboxed boxed] array-type
+   #let [boxedT (#;Host boxed (list))
+         boxedC (`' (_lux_check (+0 (~ (code;text boxed)) (+0))
+                                ("jvm object null")))
+         unboxedC (`' (_lux_check (+0 (~ (code;text unboxed)) (+0))
+                                  ("jvm object null")))]
+   throwable (|> r;nat
+                 (:: @ map (n.% (n.inc (list;size throwables))))
+                 (:: @ map (function [idx]
+                             (|> throwables
+                                 (list;nth idx)
+                                 (default "java.lang.Object")))))
+   #let [throwableC (`' (_lux_check (+0 (~ (code;text throwable)) (+0))
+                                    ("jvm object null")))]]
+  ($_ seq
+      (test "jvm object null"
+            (success "jvm object null"
+                     (list)
+                     (#;Host boxed (list))))
+      (test "jvm object null (no primitives)"
+            (or (text/= "java.lang.Object" boxed)
+                (failure "jvm object null"
+                         (list)
+                         (#;Host unboxed (list)))))
+      (test "jvm object null?"
+            (success "jvm object null?"
+                     (list boxedC)
+                     Bool))
+      (test "jvm object synchronized"
+            (success "jvm object synchronized"
+                     (list boxedC boxedC)
+                     boxedT))
+      (test "jvm object synchronized (no primitives)"
+            (or (text/= "java.lang.Object" boxed)
+                (failure "jvm object synchronized"
+                         (list unboxedC boxedC)
+                         boxedT)))
+      (test "jvm object throw"
+            (or (text/= "java.lang.Object" throwable)
+                (success "jvm object throw"
+                         (list throwableC)
+                         Bottom)))
+      (test "jvm object class"
+            (success "jvm object class"
+                     (list (code;text boxed))
+                     (#;Host "java.lang.Class" (list boxedT))))
+      ))
diff --git a/new-luxc/test/tests.lux b/new-luxc/test/tests.lux
index 28ccefc42..311b6666f 100644
--- a/new-luxc/test/tests.lux
+++ b/new-luxc/test/tests.lux
@@ -12,7 +12,8 @@
                         ["_;A" case]
                         ["_;A" function]
                         ["_;A" type]
-                        (procedure ["_;A" common]))
+                        (procedure ["_;A" common]
+                                   ["_;A" host]))
               (synthesizer ["_;S" primitive]
                            ["_;S" structure]
                            (case ["_;S" special])