- Fixed some compiler tests.

6 files changed, 159 insertions, 60 deletions

diff --git a/new-luxc/source/luxc/analyser/procedure/host.jvm.lux b/new-luxc/source/luxc/analyser/procedure/host.jvm.lux
index e45e7d807..84592d4ee 100644
--- a/new-luxc/source/luxc/analyser/procedure/host.jvm.lux
+++ b/new-luxc/source/luxc/analyser/procedure/host.jvm.lux
@@ -866,7 +866,7 @@
            [valueT unboxed valueA] (analyse-input analyse fieldT valueC)
            _ (&;with-type-env
                (tc;check fieldT valueT))
-           _ (&;infer Unit)]
+           _ (&;infer objectT)]
           (wrap (#la;Procedure proc (list (#la;Text class) (#la;Text field) (#la;Text unboxed) valueA objectA))))
 
         _
diff --git a/new-luxc/source/luxc/generator/procedure/host.jvm.lux b/new-luxc/source/luxc/generator/procedure/host.jvm.lux
index a25c67feb..f908c6c6e 100644
--- a/new-luxc/source/luxc/generator/procedure/host.jvm.lux
+++ b/new-luxc/source/luxc/generator/procedure/host.jvm.lux
@@ -531,7 +531,7 @@
         #;None
         (wrap (|>. objectI
                    ($i;CHECKCAST class)
-                   ($i;GETFIELD class field ($t;class class (list)))))))
+                   ($i;GETFIELD class field ($t;class unboxed (list)))))))
 
     _
     (&;fail (format "Wrong syntax for '" proc "'."))))
@@ -557,18 +557,18 @@
                           _ (undefined))]
           (wrap (|>. objectI
                      ($i;CHECKCAST class)
+                     $i;DUP
                      valueI
                      ($i;unwrap primitive)
-                     ($i;PUTFIELD class field (#$;Primitive primitive))
-                     ($i;string &runtime;unit))))
+                     ($i;PUTFIELD class field (#$;Primitive primitive)))))
         
         #;None
         (wrap (|>. objectI
                    ($i;CHECKCAST class)
+                   $i;DUP
                    valueI
-                   ($i;CHECKCAST class)
-                   ($i;PUTFIELD class field ($t;class class (list)))
-                   ($i;string &runtime;unit)))))
+                   ($i;CHECKCAST unboxed)
+                   ($i;PUTFIELD class field ($t;class unboxed (list)))))))
 
     _
     (&;fail (format "Wrong syntax for '" proc "'."))))
diff --git a/new-luxc/source/luxc/generator/runtime.jvm.lux b/new-luxc/source/luxc/generator/runtime.jvm.lux
index 66dd43019..ce138ca48 100644
--- a/new-luxc/source/luxc/generator/runtime.jvm.lux
+++ b/new-luxc/source/luxc/generator/runtime.jvm.lux
@@ -54,6 +54,7 @@
 (def: #export $Tag $;Type $t;int)
 (def: #export $Flag $;Type $Object)
 (def: #export $Datum $;Type $Object)
+(def: #export $Function $;Type ($t;class function-class (list)))
 
 (def: #export logI
   $;Inst
@@ -66,24 +67,42 @@
   $;Method
   ($t;method (list $t;int $Object $Object) (#;Some $Object-Array) (list)))
 
-(def: variant-makeI
+(def: variantI
   $;Inst
   ($i;INVOKESTATIC runtime-class "variant_make" variant-method false))
 
-(def: #export someI
+(def: #export leftI
+  $;Inst
+  (|>. ($i;int 0)
+       $i;NULL
+       $i;DUP2_X1
+       $i;POP2
+       variantI))
+
+(def: #export rightI
   $;Inst
   (|>. ($i;int 1)
        ($i;string "")
        $i;DUP2_X1
        $i;POP2
-       variant-makeI))
+       variantI))
+
+(def: #export someI $;Inst rightI)
 
 (def: #export noneI
   $;Inst
   (|>. ($i;int 0)
        $i;NULL
        ($i;string unit)
-       variant-makeI))
+       variantI))
+
+(def: #export partials-field Text "partials")
+(def: #export apply-method Text "apply")
+(def: #export num-apply-variants Nat +8)
+
+(def: #export (apply-signature arity)
+  (-> ls;Arity $;Method)
+  ($t;method (list;repeat arity $Object) (#;Some $Object) (list)))
 
 (def: adt-methods
   $;Def
@@ -372,7 +391,7 @@
                                             ($i;ILOAD +1) $i;ISUB ## Shorten tag
                                             ($i;ALOAD +0) flagI ## Get flag
                                             ($i;ALOAD +0) datumI ## Get value
-                                            variant-makeI ## Build sum
+                                            variantI ## Build sum
                                             $i;ARETURN)
                               update-tagI (|>. $i;ISUB ($i;ISTORE +1))
                               update-variantI (|>. ($i;ALOAD +0) datumI ($i;CHECKCAST ($t;descriptor $Variant)) ($i;ASTORE +0))
@@ -447,6 +466,26 @@
                              $i;ARETURN)))
          )))
 
+(def: io-methods
+  $;Def
+  (|>. ($d;method #$;Public $;staticM "try" ($t;method (list $Function) (#;Some $Variant) (list))
+                  (<| $i;with-label (function [@from])
+                      $i;with-label (function [@to])
+                      $i;with-label (function [@handler])
+                      (|>. ($i;try @from @to @handler "java.lang.Throwable")
+                           ($i;label @from)
+                           ($i;ALOAD +0)
+                           $i;NULL
+                           ($i;INVOKEVIRTUAL function-class apply-method (apply-signature +1) false)
+                           rightI
+                           $i;ARETURN
+                           ($i;label @to)
+                           ($i;label @handler)
+                           ($i;INVOKEVIRTUAL "java.lang.Throwable" "getMessage" ($t;method (list) (#;Some $String) (list)) false)
+                           leftI
+                           $i;ARETURN)))
+       ))
+
 (def: generate-runtime
   (Meta &common;Bytecode)
   (do Monad<Meta>
@@ -456,18 +495,11 @@
                                    nat-methods
                                    frac-methods
                                    deg-methods
-                                   pm-methods))]
+                                   pm-methods
+                                   io-methods))]
      _ (&common;store-class runtime-class bytecode)]
     (wrap bytecode)))
 
-(def: #export partials-field Text "partials")
-(def: #export apply-method Text "apply")
-(def: #export num-apply-variants Nat +8)
-
-(def: #export (apply-signature arity)
-  (-> ls;Arity $;Method)
-  ($t;method (list;repeat arity $Object) (#;Some $Object) (list)))
-
 (def: generate-function
   (Meta &common;Bytecode)
   (do Monad<Meta>
diff --git a/new-luxc/test/test/luxc/analyser/function.lux b/new-luxc/test/test/luxc/analyser/function.lux
index baef5c42c..6fbafd1eb 100644
--- a/new-luxc/test/test/luxc/analyser/function.lux
+++ b/new-luxc/test/test/luxc/analyser/function.lux
@@ -100,11 +100,6 @@
                         (@;analyse-function analyse func-name arg-name (code;symbol ["" func-name])))
                       (meta;run (init-compiler []))
                       succeeds?))
-            (test "Can infer recursive types for functions."
-                  (|> (@common;with-unknown-type
-                        (@;analyse-function analyse func-name arg-name (code;symbol ["" func-name])))
-                      (meta;run (init-compiler []))
-                      (check-type (type (Rec self (All [a] (-> a self)))))))
             ))))
 
 (context: "Function application."
diff --git a/new-luxc/test/test/luxc/analyser/procedure/host.jvm.lux b/new-luxc/test/test/luxc/analyser/procedure/host.jvm.lux
index ad5670cbe..d1520e5b7 100644
--- a/new-luxc/test/test/luxc/analyser/procedure/host.jvm.lux
+++ b/new-luxc/test/test/luxc/analyser/procedure/host.jvm.lux
@@ -434,7 +434,7 @@
                                 ("jvm object null")))
                            (`' ("lux check" (+0 "org.omg.CORBA.ValueMember" (+0))
                                 ("jvm object null"))))
-                     Unit))
+                     (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")
@@ -443,7 +443,7 @@
                                 ("jvm object null")))
                            (`' ("lux check" (+0 "javax.swing.text.html.parser.DTD" (+0))
                                 ("jvm object null"))))
-                     Unit))
+                     (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")
@@ -452,7 +452,7 @@
                                 ("jvm object null")))
                            (`' ("lux check" (+0 "java.awt.GridBagConstraints" (+0))
                                 ("jvm object null"))))
-                     Unit))
+                     (primitive java.awt.GridBagConstraints)))
       ))
 
 (context: "Boxing/Unboxing."
@@ -477,7 +477,7 @@
                                 ("jvm object null")))
                            (`' ("lux check" (+0 "javax.accessibility.AccessibleAttributeSequence" (+0))
                                 ("jvm object null"))))
-                     Unit))
+                     (primitive javax.accessibility.AccessibleAttributeSequence)))
       ))
 
 (context: "Member [Method]."
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 5b22bc2a1..c5aad2cae 100644
--- a/new-luxc/test/test/luxc/generator/procedure/host.jvm.lux
+++ b/new-luxc/test/test/luxc/generator/procedure/host.jvm.lux
@@ -389,8 +389,11 @@
          #let [num-instances (list;size instances)]
          class-idx (|> r;nat (:: @ map (n.% num-classes)))
          instance-idx (|> r;nat (:: @ map (n.% num-instances)))
+         exception-message (r;text +5)
          #let [class (maybe;assume (list;nth class-idx classes))
-               [instance-class instance-gen] (maybe;assume (list;nth instance-idx instances))]
+               [instance-class instance-gen] (maybe;assume (list;nth instance-idx instances))
+               exception-message$ (|> (#ls;Text exception-message)
+                                      (list (#ls;Text "java.lang.String")) #ls;Tuple)]
          sample r;int
          monitor r;int
          instance instance-gen]
@@ -430,7 +433,25 @@
                              (#e;Error error)
                              false)))
             (test "jvm object throw"
-                  false)
+                  (|> (do meta;Monad<Meta>
+                        [_ @runtime;generate
+                         sampleI (@;generate (|> (#ls;Procedure "jvm member invoke constructor" (list (#ls;Text "java.lang.Throwable")
+                                                                                                      exception-message$))
+                                                 (list) (#ls;Procedure "jvm object throw")
+                                                 (#ls;Function +1 (list))
+                                                 (list) (#ls;Procedure "lux try")))]
+                        (@eval;eval sampleI))
+                      (meta;run (init-compiler []))
+                      (case> (#e;Success outputG)
+                             (case (:! (e;Error Top) outputG)
+                               (#e;Error error)
+                               (text/= exception-message error)
+
+                               (#e;Success outputG)
+                               false)
+
+                             (#e;Error error)
+                             false)))
             (test "jvm object class"
                   (|> (do meta;Monad<Meta>
                         [sampleI (@;generate (#ls;Procedure "jvm object class" (list (#ls;Text class))))]
@@ -458,34 +479,85 @@
   (#static AD int))
 
 (context: "Member [Field]"
-  ($_ seq
-      (test "jvm member static get"
-            (|> (do meta;Monad<Meta>
-                  [sampleI (@;generate (|> (#ls;Procedure "jvm member static get" (list (#ls;Text "java.util.GregorianCalendar") (#ls;Text "AD") (#ls;Text "int")))
-                                           (list) (#ls;Procedure "jvm convert int-to-long")))]
-                  (@eval;eval sampleI))
-                (meta;run (init-compiler []))
-                (case> (#e;Success outputG)
-                       (i.= GregorianCalendar.AD (:! Int outputG))
-
-                       (#e;Error error)
-                       false)))
-      (test "jvm member static put"
-            (|> (do meta;Monad<Meta>
-                  [sampleI (@;generate (#ls;Procedure "jvm member static put" (list (#ls;Text "java.awt.datatransfer.DataFlavor") (#ls;Text "allHtmlFlavor") (#ls;Text "java.awt.datatransfer.DataFlavor")
-                                                                                    (#ls;Procedure "jvm member static get" (list (#ls;Text "java.awt.datatransfer.DataFlavor") (#ls;Text "allHtmlFlavor") (#ls;Text "java.awt.datatransfer.DataFlavor"))))))]
-                  (@eval;eval sampleI))
-                (meta;run (init-compiler []))
-                (case> (#e;Success outputG)
-                       (is @runtime;unit (:! Text outputG))
-
-                       (#e;Error error)
-                       false)))
-      (test "jvm member virtual get"
-            false)
-      (test "jvm member virtual put"
-            false)
-      ))
+  (<| (times +100)
+      (do @
+        [sample-short (|> r;int (:: @ map (|>. int/abs (i.% 100))))
+         sample-string (r;text +5)
+         other-sample-string (r;text +5)
+         #let [shortS (|> (#ls;Int sample-short)
+                          (list) (#ls;Procedure "jvm convert long-to-short")
+                          (list (#ls;Text "short")) #ls;Tuple)
+               stringS (|> (#ls;Text sample-string)
+                           (list (#ls;Text "java.lang.String")) #ls;Tuple)
+               type-codeS (|> (#ls;Procedure "jvm object null" (list))
+                              (list (#ls;Text "org.omg.CORBA.TypeCode")) #ls;Tuple)
+               idl-typeS (|> (#ls;Procedure "jvm object null" (list))
+                             (list (#ls;Text "org.omg.CORBA.IDLType")) #ls;Tuple)
+               value-member$ (#ls;Procedure "jvm member invoke constructor" (list (#ls;Text "org.omg.CORBA.ValueMember")
+                                                                                  stringS
+                                                                                  stringS
+                                                                                  stringS
+                                                                                  stringS
+                                                                                  type-codeS
+                                                                                  idl-typeS
+                                                                                  shortS))]]
+        ($_ seq
+            (test "jvm member static get"
+                  (|> (do meta;Monad<Meta>
+                        [sampleI (@;generate (|> (#ls;Procedure "jvm member static get" (list (#ls;Text "java.util.GregorianCalendar") (#ls;Text "AD") (#ls;Text "int")))
+                                                 (list) (#ls;Procedure "jvm convert int-to-long")))]
+                        (@eval;eval sampleI))
+                      (meta;run (init-compiler []))
+                      (case> (#e;Success outputG)
+                             (i.= GregorianCalendar.AD (:! Int outputG))
+
+                             (#e;Error error)
+                             false)))
+            (test "jvm member static put"
+                  (|> (do meta;Monad<Meta>
+                        [sampleI (@;generate (#ls;Procedure "jvm member static put" (list (#ls;Text "java.awt.datatransfer.DataFlavor") (#ls;Text "allHtmlFlavor") (#ls;Text "java.awt.datatransfer.DataFlavor")
+                                                                                          (#ls;Procedure "jvm member static get" (list (#ls;Text "java.awt.datatransfer.DataFlavor") (#ls;Text "allHtmlFlavor") (#ls;Text "java.awt.datatransfer.DataFlavor"))))))]
+                        (@eval;eval sampleI))
+                      (meta;run (init-compiler []))
+                      (case> (#e;Success outputG)
+                             (is @runtime;unit (:! Text outputG))
+
+                             (#e;Error error)
+                             false)))
+            (test "jvm member virtual get"
+                  (|> (do meta;Monad<Meta>
+                        [sampleI (@;generate (|> value-member$
+                                                 (list (#ls;Text "org.omg.CORBA.ValueMember")
+                                                       (#ls;Text "name")
+                                                       (#ls;Text "java.lang.String"))
+                                                 (#ls;Procedure "jvm member virtual get")))]
+                        (@eval;eval sampleI))
+                      (meta;run (init-compiler []))
+                      (case> (#e;Success outputG)
+                             (text/= sample-string (:! Text outputG))
+
+                             (#e;Error error)
+                             false)))
+            (test "jvm member virtual put"
+                  (|> (do meta;Monad<Meta>
+                        [sampleI (@;generate (|> value-member$
+                                                 (list (#ls;Text "org.omg.CORBA.ValueMember")
+                                                       (#ls;Text "name")
+                                                       (#ls;Text "java.lang.String")
+                                                       (#ls;Text other-sample-string))
+                                                 (#ls;Procedure "jvm member virtual put")
+                                                 (list (#ls;Text "org.omg.CORBA.ValueMember")
+                                                       (#ls;Text "name")
+                                                       (#ls;Text "java.lang.String"))
+                                                 (#ls;Procedure "jvm member virtual get")))]
+                        (@eval;eval sampleI))
+                      (meta;run (init-compiler []))
+                      (case> (#e;Success outputG)
+                             (text/= other-sample-string (:! Text outputG))
+
+                             (#e;Error error)
+                             false)))
+            ))))
 
 (host;import java.lang.Object)