- Fixes for compiler build [part 0].

1 files changed, 551 insertions, 0 deletions

diff --git a/new-luxc/test/test/luxc/lang/analysis/host.jvm.lux b/new-luxc/test/test/luxc/lang/analysis/host.jvm.lux
new file mode 100644
index 000000000..02574a31a
--- /dev/null
+++ b/new-luxc/test/test/luxc/lang/analysis/host.jvm.lux
@@ -0,0 +1,551 @@
+(.module:
+  [lux #*
+   [io]
+   [control
+    [monad (#+ do)]
+    pipe]
+   [concurrency
+    [atom]]
+   [data
+    ["e" error]
+    [product]
+    [maybe]
+    [text ("text/" Equivalence<Text>)
+     format]
+    [collection
+     [array]
+     [list ("list/" Fold<List>)]
+     ["dict" dictionary]]]
+   [math
+    ["r" random "r/" Monad<Random>]]
+   [macro (#+ Monad<Meta>)
+    [code]]
+   ["." language
+    [type]
+    [compiler
+     [".L" init]
+     [analysis
+      [".A" type]]
+     [extension
+      [analysis
+       [".AE" host]]]]]
+   test]
+  [///
+   ["_." primitive]])
+
+(do-template [<name> <success> <failure>]
+  [(def: (<name> procedure params output-type)
+     (-> Text (List Code) Type Bool)
+     (|> (do Monad<Meta>
+           [## runtime-bytecode @runtime.translate
+            ]
+           (language.with-scope
+             (typeA.with-type output-type
+               (_primitive.analyse (` ((~ (code.text procedure)) (~+ params)))))))
+         (language.with-current-module "")
+         (macro.run (initL.compiler []))
+         (case> (#e.Success _)
+                <success>
+
+                (#e.Error error)
+                <failure>)))]
+
+  [success true false]
+  [failure false true]
+  )
+
+(do-template [<name> <success> <failure>]
+  [(def: (<name> syntax output-type)
+     (-> Code Type Bool)
+     (|> (do Monad<Meta>
+           [## runtime-bytecode @runtime.translate
+            ]
+           (language.with-scope
+             (typeA.with-type output-type
+               (_primitive.analyse syntax))))
+         (language.with-current-module "")
+         (macro.run (initL.compiler []))
+         (case> (#e.Success _)
+                <success>
+
+                (#e.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" hostAE.Float]
+                                    ["jvm convert double-to-int" "java.lang.Double" hostAE.Integer]
+                                    ["jvm convert double-to-long" "java.lang.Double" hostAE.Long]
+                                    ["jvm convert float-to-double" "java.lang.Float" hostAE.Double]
+                                    ["jvm convert float-to-int" "java.lang.Float" hostAE.Integer]
+                                    ["jvm convert float-to-long" "java.lang.Float" hostAE.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" hostAE.Byte]
+                                    ["jvm convert int-to-char" "java.lang.Integer" hostAE.Character]
+                                    ["jvm convert int-to-double" "java.lang.Integer" hostAE.Double]
+                                    ["jvm convert int-to-float" "java.lang.Integer" hostAE.Float]
+                                    ["jvm convert int-to-long" "java.lang.Integer" hostAE.Long]
+                                    ["jvm convert int-to-short" "java.lang.Integer" hostAE.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" hostAE.Double]
+                                    ["jvm convert long-to-float" "java.lang.Long" hostAE.Float]
+                                    ["jvm convert long-to-int" "java.lang.Long" hostAE.Integer]
+                                    ["jvm convert long-to-short" "java.lang.Long" hostAE.Short]
+                                    ["jvm convert long-to-byte" "java.lang.Long" hostAE.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" hostAE.Byte]
+                                    ["jvm convert char-to-short" "java.lang.Character" hostAE.Short]
+                                    ["jvm convert char-to-int" "java.lang.Character" hostAE.Integer]
+                                    ["jvm convert char-to-long" "java.lang.Character" hostAE.Long]
+                                    ["jvm convert byte-to-long" "java.lang.Byte" hostAE.Long]
+                                    ["jvm convert short-to-long" "java.lang.Short" hostAE.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> hostAE.Boolean]
+                                        [(format "jvm " <domain> " <") <boxed> <boxed> hostAE.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" hostAE.Integer]
+  ["long" "java.lang.Long" hostAE.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> hostAE.Boolean]
+                                        [(format "jvm " <domain> " <") <boxed> <boxed> hostAE.Boolean]
+                                        )]
+       ($_ seq
+           <instructions>
+           )))]
+
+
+  ["float" "java.lang.Float" hostAE.Float]
+  ["double" "java.lang.Double" hostAE.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> hostAE.Boolean]
+                                        [(format "jvm " <domain> " <") <boxed> <boxed> hostAE.Boolean]
+                                        )]
+       ($_ seq
+           <instructions>
+           )))]
+
+
+  ["char" "java.lang.Character" hostAE.Character]
+  )
+
+(def: array-type
+  (r.Random [Text Text])
+  (let [entries (dict.entries hostAE.boxes)
+        num-entries (list.size entries)]
+    (do r.Monad<Random>
+      [choice (|> r.nat (:: @ map (n/% (inc num-entries))))
+       #let [[unboxed boxed] (: [Text Text]
+                                (|> entries
+                                    (list.nth choice)
+                                    (maybe.default ["java.lang.Object" "java.lang.Object"])))]]
+      (wrap [unboxed boxed]))))
+
+(context: "Array."
+  (<| (times +100)
+      (do @
+        [#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 (#.Primitive unboxed (list))
+               arrayT (#.Primitive "#Array" (list unboxedT))
+               arrayC (`' ("lux check" (+0 "#Array" (+1 (+0 (~ (code.text unboxed)) (+0)) (+0)))
+                           ("jvm array new" (~ (code.nat size)))))
+               boxedT (#.Primitive boxed (list))
+               boxedTC (` (+0 (~ (code.text boxed)) (+0)))
+               multi-arrayT (list/fold (function (_ _ innerT)
+                                         (|> innerT (list) (#.Primitive "#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 object cast"
+                                ("jvm array read" (~ 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."
+  (<| (times +100)
+      (do @
+        [[unboxed boxed] array-type
+         [!unboxed !boxed] (|> array-type
+                               (r.filter (function (_ [!unboxed !boxed])
+                                           (not (text/= boxed !boxed)))))
+         #let [boxedT (#.Primitive boxed (list))
+               boxedC (`' ("lux check" (+0 (~ (code.text boxed)) (+0))
+                           ("jvm object null")))
+               !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/% (inc (list.size throwables))))
+                       (:: @ map (function (_ idx)
+                                   (|> throwables
+                                       (list.nth idx)
+                                       (maybe.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)
+                           (#.Primitive boxed (list))))
+            (test "jvm object null (no primitives)"
+                  (or (text/= "java.lang.Object" boxed)
+                      (failure "jvm object null"
+                               (list)
+                               (#.Primitive 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)
+                               Nothing)))
+            (test "jvm object class"
+                  (success "jvm object class"
+                           (list (code.text boxed))
+                           (#.Primitive "java.lang.Class" (list boxedT))))
+            (test "jvm object instance?"
+                  (success "jvm object instance?"
+                           (list (code.text boxed)
+                                 boxedC)
+                           Bool))
+            (test "jvm object instance? (lineage)"
+                  (success "jvm object instance?"
+                           (list (' "java.lang.Object")
+                                 boxedC)
+                           Bool))
+            (test "jvm object instance? (no lineage)"
+                  (or (text/= "java.lang.Object" boxed)
+                      (failure "jvm object instance?"
+                               (list (code.text boxed)
+                                     !boxedC)
+                               Bool)))
+            ))))
+
+(context: "Member [Static Field]."
+  ($_ seq
+      (test "jvm member static get"
+            (success "jvm member static get"
+                     (list (code.text "java.lang.System")
+                           (code.text "out"))
+                     (#.Primitive "java.io.PrintStream" (list))))
+      (test "jvm member static get (inheritance out)"
+            (success "jvm member static get"
+                     (list (code.text "java.lang.System")
+                           (code.text "out"))
+                     (#.Primitive "java.lang.Object" (list))))
+      (test "jvm member static put"
+            (success "jvm member static put"
+                     (list (code.text "java.awt.datatransfer.DataFlavor")
+                           (code.text "allHtmlFlavor")
+                           (`' ("lux check" (+0 "java.awt.datatransfer.DataFlavor" (+0))
+                                ("jvm object null"))))
+                     Any))
+      (test "jvm member static put (final)"
+            (failure "jvm member static put"
+                     (list (code.text "java.lang.System")
+                           (code.text "out")
+                           (`' ("lux check" (+0 "java.io.PrintStream" (+0))
+                                ("jvm object null"))))
+                     Any))
+      (test "jvm member static put (inheritance in)"
+            (success "jvm member static put"
+                     (list (code.text "java.awt.datatransfer.DataFlavor")
+                           (code.text "allHtmlFlavor")
+                           (`' ("jvm object cast"
+                                ("lux check" (+0 "javax.activation.ActivationDataFlavor" (+0))
+                                 ("jvm object null")))))
+                     Any))
+      ))
+
+(context: "Member [Virtual Field]."
+  ($_ seq
+      (test "jvm member virtual get"
+            (success "jvm member virtual get"
+                     (list (code.text "org.omg.CORBA.ValueMember")
+                           (code.text "id")
+                           (`' ("lux check" (+0 "org.omg.CORBA.ValueMember" (+0))
+                                ("jvm object null"))))
+                     (#.Primitive "java.lang.String" (list))))
+      (test "jvm member virtual get (inheritance out)"
+            (success "jvm member virtual get"
+                     (list (code.text "org.omg.CORBA.ValueMember")
+                           (code.text "id")
+                           (`' ("lux check" (+0 "org.omg.CORBA.ValueMember" (+0))
+                                ("jvm object null"))))
+                     (#.Primitive "java.lang.Object" (list))))
+      (test "jvm member virtual put"
+            (success "jvm member virtual put"
+                     (list (code.text "org.omg.CORBA.ValueMember")
+                           (code.text "id")
+                           (`' ("lux check" (+0 "java.lang.String" (+0))
+                                ("jvm object null")))
+                           (`' ("lux check" (+0 "org.omg.CORBA.ValueMember" (+0))
+                                ("jvm object null"))))
+                     (primitive "org.omg.CORBA.ValueMember")))
+      (test "jvm member virtual put (final)"
+            (failure "jvm member virtual put"
+                     (list (code.text "javax.swing.text.html.parser.DTD")
+                           (code.text "applet")
+                           (`' ("lux check" (+0 "javax.swing.text.html.parser.Element" (+0))
+                                ("jvm object null")))
+                           (`' ("lux check" (+0 "javax.swing.text.html.parser.DTD" (+0))
+                                ("jvm object null"))))
+                     (primitive "javax.swing.text.html.parser.DTD")))
+      (test "jvm member virtual put (inheritance in)"
+            (success "jvm member virtual put"
+                     (list (code.text "java.awt.GridBagConstraints")
+                           (code.text "insets")
+                           (`' ("jvm object cast"
+                                ("lux check" (+0 "javax.swing.plaf.InsetsUIResource" (+0))
+                                 ("jvm object null"))))
+                           (`' ("lux check" (+0 "java.awt.GridBagConstraints" (+0))
+                                ("jvm object null"))))
+                     (primitive "java.awt.GridBagConstraints")))
+      ))
+
+(context: "Boxing/Unboxing."
+  ($_ seq
+      (test "jvm member static get"
+            (success "jvm member static get"
+                     (list (code.text "java.util.GregorianCalendar")
+                           (code.text "AD"))
+                     (#.Primitive "java.lang.Integer" (list))))
+      (test "jvm member virtual get"
+            (success "jvm member virtual get"
+                     (list (code.text "javax.accessibility.AccessibleAttributeSequence")
+                           (code.text "startIndex")
+                           (`' ("lux check" (+0 "javax.accessibility.AccessibleAttributeSequence" (+0))
+                                ("jvm object null"))))
+                     (#.Primitive "java.lang.Integer" (list))))
+      (test "jvm member virtual put"
+            (success "jvm member virtual put"
+                     (list (code.text "javax.accessibility.AccessibleAttributeSequence")
+                           (code.text "startIndex")
+                           (`' ("jvm object cast"
+                                ("lux check" (+0 "java.lang.Integer" (+0))
+                                 ("jvm object null"))))
+                           (`' ("lux check" (+0 "javax.accessibility.AccessibleAttributeSequence" (+0))
+                                ("jvm object null"))))
+                     (primitive "javax.accessibility.AccessibleAttributeSequence")))
+      ))
+
+(context: "Member [Method]."
+  (let [longC (' ("lux coerce" (+0 "java.lang.Long" (+0))
+                  +123))
+        intC (`' ("jvm convert long-to-int" (~ longC)))
+        stringC (' ("lux coerce" (+0 "java.lang.String" (+0))
+                    "YOLO"))
+        objectC (`' ("lux check" (+0 "java.util.ArrayList" (+1 (+0 "java.lang.Long" (+0)) (+0)))
+                     ("jvm member invoke constructor" "java.util.ArrayList"
+                      ["int" ("jvm object cast" (~ intC))])))]
+    ($_ seq
+        (test "jvm member invoke static"
+              (success' (` ("jvm member invoke static"
+                            "java.lang.Long" "decode"
+                            ["java.lang.String" (~ stringC)]))
+                        (#.Primitive "java.lang.Long" (list))))
+        (test "jvm member invoke virtual"
+              (success' (` ("jvm object cast"
+                            ("jvm member invoke virtual"
+                             "java.lang.Object" "equals"
+                             ("jvm object cast" (~ longC)) ["java.lang.Object" ("jvm object cast" (~ longC))])))
+                        (#.Primitive "java.lang.Boolean" (list))))
+        (test "jvm member invoke special"
+              (success' (` ("jvm object cast"
+                            ("jvm member invoke special"
+                             "java.lang.Long" "equals"
+                             ("jvm object cast" (~ longC)) ["java.lang.Object" ("jvm object cast" (~ longC))])))
+                        (#.Primitive "java.lang.Boolean" (list))))
+        (test "jvm member invoke interface"
+              (success' (` ("jvm object cast"
+                            ("jvm member invoke interface"
+                             "java.util.Collection" "add"
+                             ("jvm object cast" (~ objectC)) ["java.lang.Object" ("jvm object cast" (~ longC))])))
+                        (#.Primitive "java.lang.Boolean" (list))))
+        (test "jvm member invoke constructor"
+              (success' (` ("jvm member invoke constructor"
+                            "java.util.ArrayList"
+                            ["int" ("jvm object cast" (~ intC))]))
+                        (All [a] (#.Primitive "java.util.ArrayList" (list a)))))
+        )))