From 64ac2f552ec9e19131fc9671f14d14b0651cd988 Mon Sep 17 00:00:00 2001
From: Eduardo Julian
Date: Thu, 26 Oct 2017 19:21:17 -0400
Subject: - Fixed some compiler tests.

---
 .../source/luxc/analyser/procedure/host.jvm.lux    |  2 +-
 .../source/luxc/generator/procedure/host.jvm.lux   | 12 ++---
 new-luxc/source/luxc/generator/runtime.jvm.lux     | 60 +++++++++++++++++-----
 3 files changed, 53 insertions(+), 21 deletions(-)

(limited to 'new-luxc/source')

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>
-- 
cgit v1.2.3