- Fixed some bugs.

- Some small refactoring.

3 files changed, 101 insertions, 91 deletions

diff --git a/new-luxc/source/luxc/lang/synthesis/case.lux b/new-luxc/source/luxc/lang/synthesis/case.lux
index dfe05e1bf..c35483dd8 100644
--- a/new-luxc/source/luxc/lang/synthesis/case.lux
+++ b/new-luxc/source/luxc/lang/synthesis/case.lux
@@ -13,45 +13,52 @@
 
 (def: popPS ls;Path (' ("lux case pop")))
 
-(def: (path' outer-arity pattern)
-  (-> ls;Arity la;Pattern (List ls;Path))
+(def: (path' arity num-locals pattern)
+  (-> ls;Arity Nat la;Pattern [Nat (List ls;Path)])
   (case pattern
     (^code ("lux case tuple" [(~@ membersP)]))
     (case membersP
       #;Nil
-      (list popPS)
+      [num-locals
+       (list popPS)]
 
       (#;Cons singletonP #;Nil)
-      (path' outer-arity singletonP)
+      (path' arity num-locals singletonP)
 
       (#;Cons _)
       (let [last-idx (n.dec (list;size membersP))
-            [_ tuple-path] (list/fold (function [current-pattern [current-idx next]]
-                                        [(n.dec current-idx)
-                                         (|> (list (if (n.= last-idx current-idx)
-                                                     (` ("lux case tuple right" (~ (code;nat current-idx))))
-                                                     (` ("lux case tuple left" (~ (code;nat current-idx))))))
-                                             (list/compose (path' outer-arity current-pattern))
-                                             (list/compose next))])
-                                      [last-idx (list popPS)]
-                                      (list;reverse membersP))]
-        tuple-path))
+            [_ output] (list/fold (: (-> la;Pattern [Nat [Nat (List ls;Path)]] [Nat [Nat (List ls;Path)]])
+                                     (function [current-pattern [current-idx num-locals' next]]
+                                       (let [[num-locals'' current-path] (path' arity num-locals' current-pattern)]
+                                         [(n.dec current-idx)
+                                          num-locals''
+                                          (|> (list (if (n.= last-idx current-idx)
+                                                      (` ("lux case tuple right" (~ (code;nat current-idx))))
+                                                      (` ("lux case tuple left" (~ (code;nat current-idx))))))
+                                              (list/compose current-path)
+                                              (list/compose next))])))
+                                  [last-idx num-locals (list popPS)]
+                                  (list;reverse membersP))]
+        output))
 
     (^code ("lux case variant" (~ [_ (#;Nat tag)]) (~ [_ (#;Nat num-tags)]) (~ memberP)))
-    (|> (list (if (n.= (n.dec num-tags) tag)
-                (` ("lux case variant right" (~ (code;nat tag))))
-                (` ("lux case variant left" (~ (code;nat tag))))))
-        (list/compose (path' outer-arity memberP))
-        (list& popPS))
+    (let [[num-locals' member-path] (path' arity num-locals memberP)]
+      [num-locals' (|> (list (if (n.= (n.dec num-tags) tag)
+                               (` ("lux case variant right" (~ (code;nat tag))))
+                               (` ("lux case variant left" (~ (code;nat tag))))))
+                       (list/compose member-path)
+                       (list& popPS))])
 
     (^code ("lux case bind" (~ [_ (#;Nat register)])))
-    (list popPS
-          (` ("lux case bind" (~ (code;nat (if (functionS;nested? outer-arity)
-                                             (|> register variableL;local (functionS;adjust-var outer-arity) variableL;local-register)
-                                             register))))))
+    [(n.inc num-locals)
+     (list popPS
+           (` ("lux case bind" (~ (code;nat (if (functionS;nested? arity)
+                                              (n.+ (n.dec arity) register)
+                                              register))))))]
 
     _
-    (list popPS pattern)))
+    [num-locals
+     (list popPS pattern)]))
 
 (def: (clean-unnecessary-pops paths)
   (-> (List ls;Path) (List ls;Path))
@@ -64,12 +71,14 @@
     #;Nil
     paths))
 
-(def: #export (path outer-arity pattern body)
-  (-> ls;Arity la;Pattern ls;Synthesis ls;Path)
-  (|> (path' outer-arity pattern) clean-unnecessary-pops
-      (list/fold (function [pre post]
-                   (` ("lux case seq" (~ pre) (~ post))))
-                 (` ("lux case exec" (~ body))))))
+(def: #export (path arity num-locals synthesize pattern bodyA)
+  (->  ls;Arity Nat (-> Nat la;Analysis ls;Synthesis) la;Pattern la;Analysis ls;Path)
+  (let [[num-locals' pieces] (path' arity num-locals pattern)]
+    (|> pieces
+        clean-unnecessary-pops
+        (list/fold (function [pre post]
+                     (` ("lux case seq" (~ pre) (~ post))))
+                   (` ("lux case exec" (~ (synthesize num-locals' bodyA))))))))
 
 (def: #export (weave leftP rightP)
   (-> ls;Path ls;Path ls;Path)
diff --git a/new-luxc/source/luxc/lang/synthesis/expression.lux b/new-luxc/source/luxc/lang/synthesis/expression.lux
index b9f5d56cc..aaa2cf2c7 100644
--- a/new-luxc/source/luxc/lang/synthesis/expression.lux
+++ b/new-luxc/source/luxc/lang/synthesis/expression.lux
@@ -59,33 +59,32 @@
   (-> ls;Synthesis (List ls;Synthesis) ls;Synthesis)
   (` ("lux call" (~ funcS) (~@ argsS))))
 
-(def: (synthesize-case synthesize outer-arity inputA branchesA)
-  (-> (-> la;Analysis ls;Synthesis)
-      ls;Arity la;Analysis (List [la;Pattern la;Analysis])
+(def: (synthesize-case arity num-locals synthesize inputA branchesA)
+  (-> ls;Arity Nat (-> Nat la;Analysis ls;Synthesis)
+      la;Analysis (List [la;Pattern la;Analysis])
       ls;Synthesis)
-  (let [inputS (synthesize inputA)]
+  (let [inputS (synthesize num-locals inputA)]
     (case (list;reverse branchesA)
       (^multi (^ (list [(^code ("lux case bind" (~ [_ (#;Nat input-register)])))
                         (^code ((~ [_ (#;Int var)])))]))
               (not (variableL;captured? var))
-              (n.= input-register (int-to-nat var)))
+              (n.= input-register (variableL;local-register var)))
       inputS
 
       (^ (list [(^code ("lux case bind" (~ [_ (#;Nat register)]))) bodyA]))
-      (let$ (if (functionS;nested? outer-arity)
-              (|> register variableL;local (functionS;adjust-var outer-arity) variableL;local-register)
+      (let$ (if (functionS;nested? arity)
+              (n.+ (n.dec arity) register)
               register)
             inputS
-            (synthesize bodyA))
+            (synthesize (n.inc num-locals) bodyA))
       
       (^or (^ (list [(^code true) thenA] [(^code false) elseA]))
            (^ (list [(^code false) elseA] [(^code true) thenA])))
-      (if$ inputS (synthesize thenA) (synthesize elseA))
+      (if$ inputS (synthesize num-locals thenA) (synthesize num-locals elseA))
 
       (#;Cons [lastP lastA] prevsPA)
       (let [transform-branch (: (-> la;Pattern la;Analysis ls;Path)
-                                (function [pattern expr]
-                                  (caseS;path outer-arity pattern (synthesize expr))))
+                                (caseS;path arity num-locals synthesize))
             pathS (list/fold caseS;weave
                              (transform-branch lastP lastA)
                              (list/map (product;uncurry transform-branch) prevsPA))]
@@ -95,23 +94,20 @@
       (undefined)
       )))
 
-(def: (synthesize-apply synthesize outer-arity num-locals exprA)
-  (-> (-> la;Analysis ls;Synthesis) ls;Arity Nat la;Analysis ls;Synthesis)
+(def: (synthesize-apply synthesize num-locals exprA)
+  (-> (-> la;Analysis ls;Synthesis) Nat la;Analysis ls;Synthesis)
   (let [[funcA argsA] (functionS;unfold-apply exprA)
         funcS (synthesize funcA)
         argsS (list/map synthesize argsA)]
     (case funcS
-      (^multi (^ [_ (#;Form (list [_ (#;Text "lux function")] [_ (#;Nat _arity)] [_ (#;Tuple _env)] _bodyS))])
+      (^multi (^code ("lux function" (~ [_ (#;Nat _arity)]) [(~@ _env)] (~ _bodyS)))
               (and (n.= _arity (list;size argsS))
                    (not (loopS;contains-self-reference? _bodyS)))
               [(s;run _env (p;some s;int)) (#e;Success _env)])
-      (let [register-offset (if (functionS;top? outer-arity)
-                              num-locals
-                              (|> outer-arity n.inc (n.+ num-locals)))]
-        (` ("lux loop" (~ (code;nat register-offset)) [(~@ argsS)]
-            (~ (loopS;adjust _env register-offset _bodyS)))))
+      (` ("lux loop" (~ (code;nat (n.inc num-locals))) [(~@ argsS)]
+          (~ (loopS;adjust _env num-locals _bodyS))))
 
-      (^ [_ (#;Form (list& [_ (#;Text "lux call")] funcS' argsS'))])
+      (^code ("lux call" (~ funcS') (~@ argsS')))
       (call$ funcS' (list/compose argsS' argsS))
 
       _
@@ -119,58 +115,59 @@
 
 (def: #export (synthesize expressionA)
   (-> la;Analysis ls;Synthesis)
-  (loop [outer-arity +0
+  (loop [arity +0
          resolver init-resolver
          direct? false
          num-locals +0
          expressionA expressionA]
     (case expressionA
       (^code [(~ _left) (~ _right)])
-      (` [(~@ (list/map (recur outer-arity resolver false num-locals) (la;unfold-tuple expressionA)))])
+      (` [(~@ (list/map (recur arity resolver false num-locals)
+                        (la;unfold-tuple expressionA)))])
 
       (^or (^code ("lux sum left" (~ _)))
            (^code ("lux sum right" (~ _))))
       (let [[tag last? value] (maybe;assume (la;unfold-variant expressionA))]
-        (variant$ tag last? (recur outer-arity resolver false num-locals value)))
+        (variant$ tag last? (recur arity resolver false num-locals value)))
 
       (^code ((~ [_ (#;Int var)])))
       (if (variableL;local? var)
-        (if (functionS;nested? outer-arity)
+        (if (functionS;nested? arity)
           (if (variableL;self? var)
-            (call$ (var$ 0) (|> (list;n.range +1 (n.dec outer-arity))
+            (call$ (var$ 0) (|> (list;n.range +1 (n.dec arity))
                                 (list/map (|>. variableL;local code;int (~) () (`)))))
-            (var$ (functionS;adjust-var outer-arity var)))
+            (var$ (functionS;adjust-var arity var)))
           (var$ var))
         (var$ (maybe;default var (dict;get var resolver))))
 
       (^code ("lux case" (~ inputA) (~ [_ (#;Record branchesA)])))
-      (synthesize-case (recur outer-arity resolver false num-locals) outer-arity inputA branchesA)
+      (synthesize-case arity num-locals (recur arity resolver false) inputA branchesA)
 
       (^multi (^code ("lux function" [(~@ scope)] (~ bodyA)))
               [(s;run scope (p;some s;int)) (#e;Success raw-env)])
-      (let [inner-arity (if direct?
-                          (n.inc outer-arity)
-                          +1)
+      (let [function-arity (if direct?
+                             (n.inc arity)
+                             +1)
             env (list/map (function [closure]
                             (case (dict;get closure resolver)
                               (#;Some resolved)
                               (if (and (variableL;local? resolved)
-                                       (functionS;nested? outer-arity)
-                                       (|> resolved variableL;local-register (n.>= outer-arity)))
-                                (functionS;adjust-var outer-arity resolved)
+                                       (functionS;nested? arity)
+                                       (|> resolved variableL;local-register (n.>= arity)))
+                                (functionS;adjust-var arity resolved)
                                 resolved)
 
                               #;None
                               (if (and (variableL;local? closure)
-                                       (functionS;nested? outer-arity))
-                                (functionS;adjust-var outer-arity closure)
+                                       (functionS;nested? arity))
+                                (functionS;adjust-var arity closure)
                                 closure)))
                           raw-env)
             env-vars (: (List Variable)
                         (case raw-env
                           #;Nil (list)
                           _ (|> (list;size raw-env) n.dec (list;n.range +0) (list/map variableL;captured))))
-            resolver' (if (and (functionS;nested? inner-arity)
+            resolver' (if (and (functionS;nested? function-arity)
                                direct?)
                         (list/fold (function [[from to] resolver']
                                      (dict;put from to resolver'))
@@ -180,19 +177,20 @@
                                      (dict;put var var resolver'))
                                    init-resolver
                                    env-vars))]
-        (case (recur inner-arity resolver' true num-locals bodyA)
-          (^ [_ (#;Form (list [_ (#;Text "lux function")] [_ (#;Nat arity')] env' bodyS'))])
-          (let [arity (n.inc arity')]
-            (function$ arity env (prepare-body inner-arity arity bodyS')))
+        (case (recur function-arity resolver' true function-arity bodyA)
+          (^ [_ (#;Form (list [_ (#;Text "lux function")] [_ (#;Nat unmerged-arity)] env' bodyS'))])
+          (let [merged-arity (n.inc unmerged-arity)]
+            (function$ merged-arity env
+                       (prepare-body function-arity merged-arity bodyS')))
 
           bodyS
-          (function$ +1 env (prepare-body inner-arity +1 bodyS))))
+          (function$ +1 env (prepare-body function-arity +1 bodyS))))
 
       (^code ("lux apply" (~@ _)))
-      (synthesize-apply (recur outer-arity resolver false num-locals) outer-arity num-locals expressionA)
+      (synthesize-apply (recur arity resolver false num-locals) num-locals expressionA)
 
       (^code ((~ [_ (#;Text name)]) (~@ args)))
-      (procedure$ name (list/map (recur outer-arity resolver false num-locals) args))
+      (procedure$ name (list/map (recur arity resolver false num-locals) args))
 
       _
       expressionA)))
diff --git a/new-luxc/source/luxc/lang/synthesis/loop.lux b/new-luxc/source/luxc/lang/synthesis/loop.lux
index 86c37a3f0..ac72e69b2 100644
--- a/new-luxc/source/luxc/lang/synthesis/loop.lux
+++ b/new-luxc/source/luxc/lang/synthesis/loop.lux
@@ -108,7 +108,7 @@
       exprS
       )))
 
-(def: #export (adjust env outer-offset exprS)
+(def: #export (adjust env offset exprS)
   (-> (List Variable) Register ls;Synthesis ls;Synthesis)
   (let [resolve-captured (: (-> Variable Variable)
                             (function [var]
@@ -116,13 +116,13 @@
                                 (|> env (list;nth idx) maybe;assume))))]
     (loop [exprS exprS]
       (case exprS
-        (^ [_ (#;Form (list [_ (#;Nat tag)] last? valueS))])
+        (^code ((~ [_ (#;Nat tag)]) (~ last?) (~ valueS)))
         (` ((~ (code;nat tag)) (~ last?) (~ (recur valueS))))
         
-        [_ (#;Tuple members)]
-        [_ (#;Tuple (list/map recur members))]
+        (^code [(~@ members)])
+        (` [(~@ (list/map recur members))])
 
-        (^ [_ (#;Form (list [_ (#;Text "lux case")] inputS pathS))])
+        (^code ("lux case" (~ inputS) (~ pathS)))
         (` ("lux case" (~ (recur inputS))
             (~ (let [adjust' recur]
                  (loop [pathS pathS]
@@ -133,22 +133,25 @@
                      (["lux case alt"]
                       ["lux case seq"])
 
+                     (^code ("lux case bind" (~ [_ (#;Nat register)])))
+                     (` ("lux case bind" (~ (code;nat (n.+ offset register)))))
+
                      (^ [_ (#;Form (list [_ (#;Text "lux case exec")] bodyS))])
                      (` ("lux case exec" (~ (adjust' bodyS))))
                      
                      _
                      pathS))))))
 
-        (^ [_ (#;Form (list [_ (#;Text "lux function")] arity [_ (#;Tuple environment)] bodyS))])
+        (^code ("lux function" (~ arity) [(~@ environment)] (~ bodyS)))
         (` ("lux function" (~ arity)
-            (~ [_ (#;Tuple (list/map (function [_var]
-                                       (case _var
-                                         (^ [_ (#;Form (list [_ (#;Int var)]))])
-                                         (` ((~ (code;int (resolve-captured var)))))
-
-                                         _
-                                         _var))
-                                     environment))])
+            [(~@ (list/map (function [_var]
+                             (case _var
+                               (^ [_ (#;Form (list [_ (#;Int var)]))])
+                               (` ((~ (code;int (resolve-captured var)))))
+
+                               _
+                               _var))
+                           environment))]
             (~ (recur bodyS))))
 
         (^ [_ (#;Form (list& [_ (#;Text "lux call")] funcS argsS))])
@@ -163,10 +166,10 @@
         (^ [_ (#;Form (list [_ (#;Int var)]))])
         (if (variableL;captured? var)
           (` ((~ (code;int (resolve-captured var)))))
-          (` ((~ (code;int (|> outer-offset nat-to-int (i.+ var)))))))
+          (` ((~ (code;int (|> offset nat-to-int (i.+ var)))))))
 
         (^ [_ (#;Form (list [_ (#;Text "lux let")] [_ (#;Nat register)] inputS bodyS))])
-        (` ("lux let" (~ (code;nat (n.+ outer-offset register)))
+        (` ("lux let" (~ (code;nat (n.+ offset register)))
             (~ (recur inputS))
             (~ (recur bodyS))))
 
@@ -175,8 +178,8 @@
             (~ (recur thenS))
             (~ (recur elseS))))
 
-        (^ [_ (#;Form (list [_ (#;Text "lux loop")] [_ (#;Nat inner-offset)] [_ (#;Tuple initsS)] bodyS))])
-        (` ("lux loop" (~ (code;nat (n.+ outer-offset inner-offset)))
+        (^ [_ (#;Form (list [_ (#;Text "lux loop")] [_ (#;Nat loop-offset)] [_ (#;Tuple initsS)] bodyS))])
+        (` ("lux loop" (~ (code;nat (n.+ offset loop-offset)))
             [(~@ (list/map recur initsS))]
             (~ (recur bodyS))))