- Fixed the tests.

- Fixed a few bugs.
- Can now translate recursion.

5 files changed, 87 insertions, 40 deletions

diff --git a/new-luxc/source/luxc/lang/translation/case.jvm.lux b/new-luxc/source/luxc/lang/translation/case.jvm.lux
index 3e05ba334..7821db70d 100644
--- a/new-luxc/source/luxc/lang/translation/case.jvm.lux
+++ b/new-luxc/source/luxc/lang/translation/case.jvm.lux
@@ -204,6 +204,7 @@
   (<| $i;with-label (function [@else])
       $i;with-label (function [@end])
       (|>. testI
+           ($i;unwrap #$;Boolean)
            ($i;IFEQ @else)
            thenI
            ($i;GOTO @end)
diff --git a/new-luxc/source/luxc/lang/translation/common.jvm.lux b/new-luxc/source/luxc/lang/translation/common.jvm.lux
index f9825614a..baafc233a 100644
--- a/new-luxc/source/luxc/lang/translation/common.jvm.lux
+++ b/new-luxc/source/luxc/lang/translation/common.jvm.lux
@@ -9,7 +9,8 @@
              (coll [dict #+ Dict]))
        [host]
        (world [blob #+ Blob]))
-  (luxc (host ["$" jvm]
+  (luxc (lang [";L" variable #+ Register])
+        (host ["$" jvm]
               (jvm ["$t" type]
                    ["$d" def]
                    ["$i" inst]))))
@@ -17,6 +18,8 @@
 (host;import org.objectweb.asm.Opcodes
   (#static V1_6 int))
 
+(host;import org.objectweb.asm.Label)
+
 (host;import java.lang.Object)
 
 (host;import (java.lang.Class a))
@@ -34,7 +37,8 @@
   {#loader ClassLoader
    #store Class-Store
    #artifacts Artifacts
-   #context [Text Nat]})
+   #context [Text Nat]
+   #anchor (Maybe [Label Register])})
 
 (exception: Unknown-Class)
 (exception: Class-Already-Stored)
diff --git a/new-luxc/source/luxc/lang/translation/function.jvm.lux b/new-luxc/source/luxc/lang/translation/function.jvm.lux
index eceaecd9d..bbf295d18 100644
--- a/new-luxc/source/luxc/lang/translation/function.jvm.lux
+++ b/new-luxc/source/luxc/lang/translation/function.jvm.lux
@@ -267,42 +267,42 @@
                     $i;ARETURN
                     ))))
 
-(def: #export (with-function class env arity bodyI)
-  (-> Text (List Variable) ls;Arity $;Inst
-      (Meta [$;Def $;Inst]))
-  (do meta;Monad<Meta>
-    [@begin $i;make-label
-     #let [env-size (list;size env)
-           applyD (: $;Def
-                     (if (poly-arg? arity)
-                       (|> (n.min arity runtimeT;num-apply-variants)
-                           (list;n.range +1)
-                           (list/map (with-apply class env arity @begin bodyI))
-                           (list& (with-implementation arity @begin bodyI))
-                           $d;fuse)
-                       ($d;method #$;Public $;strictM runtimeT;apply-method (runtimeT;apply-signature +1)
-                                  (|>. ($i;label @begin)
-                                       bodyI
-                                       $i;ARETURN))))
-           functionD (: $;Def
-                        (|>. ($d;int-field #$;Public ($_ $;++F $;staticF $;finalF) arity-field (nat-to-int arity))
-                             (with-captured env)
-                             (with-partial arity)
-                             (with-init class env arity)
-                             (with-reset class arity env)
-                             applyD))
-           instanceI (instance class arity env)]]
-    (wrap [functionD instanceI])))
-
-(def: #export (translate-function translate env arity body)
+(def: #export (with-function @begin class env arity bodyI)
+  (-> $;Label Text (List Variable) ls;Arity $;Inst
+      [$;Def $;Inst])
+  (let [env-size (list;size env)
+        applyD (: $;Def
+                  (if (poly-arg? arity)
+                    (|> (n.min arity runtimeT;num-apply-variants)
+                        (list;n.range +1)
+                        (list/map (with-apply class env arity @begin bodyI))
+                        (list& (with-implementation arity @begin bodyI))
+                        $d;fuse)
+                    ($d;method #$;Public $;strictM runtimeT;apply-method (runtimeT;apply-signature +1)
+                               (|>. ($i;label @begin)
+                                    bodyI
+                                    $i;ARETURN))))
+        functionD (: $;Def
+                     (|>. ($d;int-field #$;Public ($_ $;++F $;staticF $;finalF) arity-field (nat-to-int arity))
+                          (with-captured env)
+                          (with-partial arity)
+                          (with-init class env arity)
+                          (with-reset class arity env)
+                          applyD
+                          ))
+        instanceI (instance class arity env)]
+    [functionD instanceI]))
+
+(def: #export (translate-function translate env arity bodyS)
   (-> (-> ls;Synthesis (Meta $;Inst))
       (List Variable) ls;Arity ls;Synthesis
       (Meta $;Inst))
   (do meta;Monad<Meta>
-    [[context bodyI] (hostL;with-sub-context
-                       (translate body))
-     #let [function-class (&;normalize-name context)]
-     [functionD instanceI] (with-function function-class env arity bodyI)
+    [@begin $i;make-label
+     [function-class bodyI] (hostL;with-sub-context
+                              (hostL;with-anchor [@begin +1]
+                                (translate bodyS)))
+     #let [[functionD instanceI] (with-function @begin function-class env arity bodyI)]
      _ (commonT;store-class function-class
                             ($d;class #$;V1.6 #$;Public $;finalC
                                       function-class (list)
@@ -332,3 +332,28 @@
                       $i;fuse)]]
     (wrap (|>. functionI
                applyI))))
+
+(def: #export (translate-recur translate argsS)
+  (-> (-> ls;Synthesis (Meta $;Inst))
+      (List ls;Synthesis)
+      (Meta $;Inst))
+  (do meta;Monad<Meta>
+    [[@begin offset] hostL;anchor
+     argsI (monad;map @ (function [[register argS]]
+                          (let [register' (n.+ offset register)]
+                            (: (Meta $;Inst)
+                               (case argS
+                                 (^multi (^code ((~ [_ (#;Int var)])))
+                                         (i.= (variableL;local register')
+                                              var))
+                                 (wrap id)
+
+                                 _
+                                 (do @
+                                   [argI (translate argS)]
+                                   (wrap (|>. argI
+                                              ($i;ASTORE register'))))))))
+                      (list;zip2 (list;n.range +0 (n.dec (list;size argsS)))
+                                 argsS))]
+    (wrap (|>. ($i;fuse argsI)
+               ($i;GOTO @begin)))))
diff --git a/new-luxc/source/luxc/lang/translation/procedure/common.jvm.lux b/new-luxc/source/luxc/lang/translation/procedure/common.jvm.lux
index 7c049a99f..77ce7f6fa 100644
--- a/new-luxc/source/luxc/lang/translation/procedure/common.jvm.lux
+++ b/new-luxc/source/luxc/lang/translation/procedure/common.jvm.lux
@@ -18,7 +18,8 @@
         (lang ["la" analysis]
               ["ls" synthesis]
               (translation [";T" runtime]
-                           [";T" case]))))
+                           [";T" case]
+                           [";T" function]))))
 
 (host;import java.lang.Long
   (#static MIN_VALUE Long)
@@ -32,11 +33,11 @@
   (#static NEGATIVE_INFINITY Double))
 
 ## [Types]
-(type: #export Generator
+(type: #export Translator
   (-> ls;Synthesis (Meta $;Inst)))
 
 (type: #export Proc
-  (-> Generator (List ls;Synthesis) (Meta $;Inst)))
+  (-> Translator (List ls;Synthesis) (Meta $;Inst)))
 
 (type: #export Bundle
   (Dict Text Proc))
@@ -48,6 +49,7 @@
 (type: #export Unary   (-> (Vector +1 $;Inst) $;Inst))
 (type: #export Binary  (-> (Vector +2 $;Inst) $;Inst))
 (type: #export Trinary (-> (Vector +3 $;Inst) $;Inst))
+(type: #export Variadic (-> (List $;Inst) $;Inst))
 
 ## [Utils]
 (def: $Object $;Type ($t;class "java.lang.Object" (list)))
@@ -100,6 +102,14 @@
 (arity: binary +2)
 (arity: trinary +3)
 
+(def: #export (variadic proc)
+  (-> Variadic (-> Text Proc))
+  (function [proc-name]
+    (function [translate inputsS]
+      (do meta;Monad<Meta>
+        [inputsI (monad;map @ translate inputsS)]
+        (wrap (proc inputsI))))))
+
 ## [Instructions]
 (def: lux-intI $;Inst (|>. $i;I2L ($i;wrap #$;Long)))
 (def: jvm-intI $;Inst (|>. ($i;unwrap #$;Long) $i;L2I))
@@ -150,6 +160,12 @@
   Unary
   valueI)
 
+(def: lux//recur
+  (-> Text Proc)
+  (function [proc-name]
+    (function [translate inputsS]
+      (functionT;translate-recur translate inputsS))))
+
 ## [[Bits]]
 (do-template [<name> <op>]
   [(def: (<name> [inputI maskI])
@@ -363,7 +379,7 @@
   [text//lt ($i;CHECKCAST "java.lang.String") ($i;CHECKCAST "java.lang.String")
    ($i;INVOKEVIRTUAL "java.lang.String" "compareTo" ($t;method (list $String) (#;Some $t;int) (list)) false)
    (predicateI $i;IF_ICMPEQ)]
-  [text//append ($i;CHECKCAST "java.lang.String") ($i;CHECKCAST "java.lang.String")
+  [text//concat ($i;CHECKCAST "java.lang.String") ($i;CHECKCAST "java.lang.String")
    ($i;INVOKEVIRTUAL "java.lang.String" "concat" ($t;method (list $String) (#;Some $String) (list)) false)
    id]
   [text//contains? ($i;CHECKCAST "java.lang.String") ($i;CHECKCAST "java.lang.String")
@@ -544,6 +560,7 @@
       (install "is" (binary lux//is))
       (install "try" (unary lux//try))
       (install "if" (trinary lux//if))
+      (install "recur" lux//recur)
       ))
 
 (def: bit-procs
@@ -630,7 +647,7 @@
   (|> (dict;new text;Hash<Text>)
       (install "text =" (binary text//eq))
       (install "text <" (binary text//lt))
-      (install "text append" (binary text//append))
+      (install "text concat" (binary text//concat))
       (install "text index" (trinary text//index))
       (install "text size" (unary text//size))
       (install "text hash" (unary text//hash))
diff --git a/new-luxc/source/luxc/lang/translation/reference.jvm.lux b/new-luxc/source/luxc/lang/translation/reference.jvm.lux
index c9243cae3..3e835f8e1 100644
--- a/new-luxc/source/luxc/lang/translation/reference.jvm.lux
+++ b/new-luxc/source/luxc/lang/translation/reference.jvm.lux
@@ -19,7 +19,7 @@
   (do meta;Monad<Meta>
     [function-class hostL;context]
     (wrap (|>. ($i;ALOAD +0)
-               ($i;GETFIELD (&;normalize-name function-class)
+               ($i;GETFIELD function-class
                             (|> variable i.inc (i.* -1) int-to-nat functionT;captured)
                             commonT;$Object)))))