- Implemented loop translation.

4 files changed, 101 insertions, 47 deletions

diff --git a/new-luxc/source/luxc/lang/translation/function.jvm.lux b/new-luxc/source/luxc/lang/translation/function.jvm.lux
index ea6d371fa..0247b3d7f 100644
--- a/new-luxc/source/luxc/lang/translation/function.jvm.lux
+++ b/new-luxc/source/luxc/lang/translation/function.jvm.lux
@@ -321,28 +321,3 @@
                       $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/loop.jvm.lux b/new-luxc/source/luxc/lang/translation/loop.jvm.lux
new file mode 100644
index 000000000..d9216f1a7
--- /dev/null
+++ b/new-luxc/source/luxc/lang/translation/loop.jvm.lux
@@ -0,0 +1,62 @@
+(;module:
+  lux
+  (lux (control [monad #+ do])
+       (data [text]
+             text/format
+             (coll [list "list/" Functor<List> Monoid<List>]))
+       [meta])
+  (luxc ["&" base]
+        [";L" host]
+        (host ["$" jvm]
+              (jvm ["$t" type]
+                   ["$d" def]
+                   ["$i" inst]))
+        (lang ["la" analysis]
+              ["ls" synthesis]
+              (translation [";T" common]
+                           [";T" runtime]
+                           [";T" reference])
+              [";L" variable #+ Variable])))
+
+(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)))))
+
+(def: #export (translate-loop translate offset initsS+ bodyS)
+  (-> (-> ls;Synthesis (Meta $;Inst))
+      Nat (List ls;Synthesis) ls;Synthesis
+      (Meta $;Inst))
+  (do meta;Monad<Meta>
+    [@begin $i;make-label
+     initsI+ (monad;map @ translate initsS+)
+     bodyI (hostL;with-anchor [@begin offset]
+             (translate bodyS))
+     #let [initializationI (|> (list;enumerate initsI+)
+                               (list/map (function [[register initI]]
+                                           (|>. initI
+                                                ($i;ASTORE (|> register n.inc (n.+ offset))))))
+                               $i;fuse)]]
+    (wrap (|>. initializationI
+               ($i;label @begin)
+               bodyI))))
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 77ce7f6fa..2cdf65e32 100644
--- a/new-luxc/source/luxc/lang/translation/procedure/common.jvm.lux
+++ b/new-luxc/source/luxc/lang/translation/procedure/common.jvm.lux
@@ -1,7 +1,10 @@
 (;module:
   lux
-  (lux (control [monad #+ do])
-       (data [text]
+  (lux (control [monad #+ do]
+                ["p" parser]
+                ["ex" exception #+ exception:])
+       (data ["e" error]
+             [text]
              text/format
              (coll [list "list/" Functor<List>]
                    [dict #+ Dict]))
@@ -19,7 +22,8 @@
               ["ls" synthesis]
               (translation [";T" runtime]
                            [";T" case]
-                           [";T" function]))))
+                           [";T" function]
+                           [";T" loop]))))
 
 (host;import java.lang.Long
   (#static MIN_VALUE Long)
@@ -160,11 +164,29 @@
   Unary
   valueI)
 
+(exception: #export Wrong-Syntax)
+(def: #export (wrong-syntax procedure args)
+  (-> Text (List ls;Synthesis) Text)
+  (format "Procedure: " procedure "\n"
+          "Arguments: " (%code (code;tuple args))))
+
+(def: lux//loop
+  (-> Text Proc)
+  (function [proc-name]
+    (function [translate inputsS]
+      (case (s;run inputsS ($_ p;seq s;nat (s;tuple (p;many s;any)) s;any))
+        (#e;Success [offset initsS+ bodyS])
+        (loopT;translate-loop translate offset initsS+ bodyS)
+
+        (#e;Error error)
+        (&;throw Wrong-Syntax (wrong-syntax proc-name inputsS)))
+      )))
+
 (def: lux//recur
   (-> Text Proc)
   (function [proc-name]
     (function [translate inputsS]
-      (functionT;translate-recur translate inputsS))))
+      (loopT;translate-recur translate inputsS))))
 
 ## [[Bits]]
 (do-template [<name> <op>]
@@ -560,6 +582,7 @@
       (install "is" (binary lux//is))
       (install "try" (unary lux//try))
       (install "if" (trinary lux//if))
+      (install "loop" lux//loop)
       (install "recur" lux//recur)
       ))
 
diff --git a/new-luxc/source/luxc/lang/translation/procedure/host.jvm.lux b/new-luxc/source/luxc/lang/translation/procedure/host.jvm.lux
index a5e06aac3..e45c0b911 100644
--- a/new-luxc/source/luxc/lang/translation/procedure/host.jvm.lux
+++ b/new-luxc/source/luxc/lang/translation/procedure/host.jvm.lux
@@ -25,12 +25,6 @@
               ["ls" synthesis]))
   ["@" ../common])
 
-(exception: #export Wrong-Syntax)
-(def: (wrong-syntax procedure args)
-  (-> Text (List ls;Synthesis) Text)
-  (format "Procedure: " procedure "\n"
-          "Arguments: " (%code (code;tuple args))))
-
 (exception: #export Invalid-Syntax-For-JVM-Type)
 (exception: #export Invalid-Syntax-For-Argument-Generation)
 
@@ -304,7 +298,7 @@
                  ($i;array arrayJT))))
 
     _
-    (&;throw Wrong-Syntax (wrong-syntax proc inputs))))
+    (&;throw @;Wrong-Syntax (@;wrong-syntax proc inputs))))
 
 (def: (array//read proc translate inputs)
   (-> Text @;Proc)
@@ -330,7 +324,7 @@
                  loadI)))
 
     _
-    (&;throw Wrong-Syntax (wrong-syntax proc inputs))))
+    (&;throw @;Wrong-Syntax (@;wrong-syntax proc inputs))))
 
 (def: (array//write proc translate inputs)
   (-> Text @;Proc)
@@ -359,7 +353,7 @@
                  storeI)))
 
     _
-    (&;throw Wrong-Syntax (wrong-syntax proc inputs))))
+    (&;throw @;Wrong-Syntax (@;wrong-syntax proc inputs))))
 
 (def: array-procs
   @;Bundle
@@ -415,7 +409,7 @@
                                   false))))
 
     _
-    (&;throw Wrong-Syntax (wrong-syntax proc inputs))))
+    (&;throw @;Wrong-Syntax (@;wrong-syntax proc inputs))))
 
 (def: (object//instance? proc translate inputs)
   (-> Text @;Proc)
@@ -428,7 +422,7 @@
                  ($i;wrap #$;Boolean))))
 
     _
-    (&;throw Wrong-Syntax (wrong-syntax proc inputs))))
+    (&;throw @;Wrong-Syntax (@;wrong-syntax proc inputs))))
 
 (def: object-procs
   @;Bundle
@@ -479,7 +473,7 @@
         (wrap ($i;GETSTATIC class field ($t;class unboxed (list))))))
 
     _
-    (&;throw Wrong-Syntax (wrong-syntax proc inputs))))
+    (&;throw @;Wrong-Syntax (@;wrong-syntax proc inputs))))
 
 (def: (static//put proc translate inputs)
   (-> Text @;Proc)
@@ -511,7 +505,7 @@
                    ($i;string hostL;unit)))))
 
     _
-    (&;throw Wrong-Syntax (wrong-syntax proc inputs))))
+    (&;throw @;Wrong-Syntax (@;wrong-syntax proc inputs))))
 
 (def: (virtual//get proc translate inputs)
   (-> Text @;Proc)
@@ -542,7 +536,7 @@
                    ($i;GETFIELD class field ($t;class unboxed (list)))))))
 
     _
-    (&;throw Wrong-Syntax (wrong-syntax proc inputs))))
+    (&;throw @;Wrong-Syntax (@;wrong-syntax proc inputs))))
 
 (def: (virtual//put proc translate inputs)
   (-> Text @;Proc)
@@ -579,7 +573,7 @@
                    ($i;PUTFIELD class field ($t;class unboxed (list)))))))
 
     _
-    (&;throw Wrong-Syntax (wrong-syntax proc inputs))))
+    (&;throw @;Wrong-Syntax (@;wrong-syntax proc inputs))))
 
 (def: base-type
   (l;Lexer $;Type)
@@ -686,7 +680,7 @@
       (wrap (prepare-return returnT callI)))
 
     _
-    (&;throw Wrong-Syntax (wrong-syntax proc inputs))))
+    (&;throw @;Wrong-Syntax (@;wrong-syntax proc inputs))))
 
 (do-template [<name> <invoke> <interface?>]
   [(def: (<name> proc translate inputs)
@@ -707,7 +701,7 @@
          (wrap (prepare-return returnT callI)))
 
        _
-       (&;throw Wrong-Syntax (wrong-syntax proc inputs))))]
+       (&;throw @;Wrong-Syntax (@;wrong-syntax proc inputs))))]
 
   [invoke//virtual $i;INVOKEVIRTUAL false]
   [invoke//special $i;INVOKESPECIAL false]
@@ -728,7 +722,7 @@
                                    false))))
 
     _
-    (&;throw Wrong-Syntax (wrong-syntax proc inputs))))
+    (&;throw @;Wrong-Syntax (@;wrong-syntax proc inputs))))
 
 (def: member-procs
   @;Bundle