- Added loop synthesis.

- Some refactoring.

5 files changed, 237 insertions, 141 deletions

diff --git a/new-luxc/source/luxc/analyser/case/coverage.lux b/new-luxc/source/luxc/analyser/case/coverage.lux
index 754e555b2..5989952ee 100644
--- a/new-luxc/source/luxc/analyser/case/coverage.lux
+++ b/new-luxc/source/luxc/analyser/case/coverage.lux
@@ -271,13 +271,13 @@
           
           #;None
           (case (list;reverse possibilities)
-            #;Nil
-            (R;fail "{ This is not supposed to happen... }")
-            
             (#;Cons last prevs)
             (wrap (L/fold (function [left right] (#Alt left right))
                           last
-                          prevs))))))
+                          prevs))
+
+            #;Nil
+            (undefined)))))
 
     _
     (if (C/= so-far addition)
diff --git a/new-luxc/source/luxc/lang/synthesis.lux b/new-luxc/source/luxc/lang/synthesis.lux
index f5d3f9c33..b86f49fb2 100644
--- a/new-luxc/source/luxc/lang/synthesis.lux
+++ b/new-luxc/source/luxc/lang/synthesis.lux
@@ -1,6 +1,8 @@
 (;module:
   lux)
 
+(def: #export Arity Nat)
+(def: #export Register Nat)
 (def: #export Variable Int)
 
 (type: #export (Path' s)
@@ -31,14 +33,14 @@
   (#Variant Nat Bool Synthesis)
   (#Tuple (List Synthesis))
   (#Case Synthesis (Path' Synthesis))
-  (#Function Nat (List Variable) Synthesis)
+  (#Function Arity (List Variable) Synthesis)
   (#Call Synthesis (List Synthesis))
-  (#Recur Nat (List Synthesis))
+  (#Recur (List Synthesis))
   (#Procedure Text (List Synthesis))
   (#Variable Variable)
   (#Definition Ident)
-  (#Let Nat Synthesis Synthesis)
+  (#Let Register Synthesis Synthesis)
   (#If Synthesis Synthesis Synthesis)
-  (#Loop Nat (List Synthesis) Synthesis))
+  (#Loop Register (List Synthesis) Synthesis))
 
 (type: #export Path (Path' Synthesis))
diff --git a/new-luxc/source/luxc/synthesizer.lux b/new-luxc/source/luxc/synthesizer.lux
index 5dc4fa258..2f7344c6e 100644
--- a/new-luxc/source/luxc/synthesizer.lux
+++ b/new-luxc/source/luxc/synthesizer.lux
@@ -2,105 +2,30 @@
   lux
   (lux (data text/format
              [number]
-             (coll [list "L/" Functor<List> Fold<List>]
+             (coll [list "L/" Functor<List> Fold<List> Monoid<List>]
                    ["d" dict])))
   (luxc ["&" base]
         (lang ["la" analysis]
               ["ls" synthesis])
         (synthesizer ["&&;" structure]
-                     ["&&;" function])
+                     ["&&;" function]
+                     ["&&;" loop])
         ))
 
-## (def: (has-self-reference? exprS)
-##   (-> ls;Synthesis Bool)
-##   (case exprS
-##     (#ls;Tuple membersS)
-##     (list;any? has-self-reference? membersS)
-
-##     (#ls;Procedure name argsS)
-##     (list;any? has-self-reference? argsS)
-
-##     (#ls;Variant tag last? memberS)
-##     (has-self-reference? memberS)
-
-##     (#ls;Variable idx)
-##     (i.= 0 idx)
-
-##     (#ls;Recur offset argsS)
-##     (list;any? has-self-reference? argsS)
-
-##     (#ls;Call funcS argsS)
-##     (or (has-self-reference? funcS)
-##         (list;any? has-self-reference? argsS))
-
-##     (#ls;Let register inputS bodyS)
-##     (or (has-self-reference? inputS)
-##         (has-self-reference? bodyS))
-
-##     (#ls;If inputS thenS elseS)
-##     (or (has-self-reference? inputS)
-##         (has-self-reference? thenS)
-##         (has-self-reference? elseS))
-
-##     (#ls;Function num-args scope bodyS)
-##     (not (list;any? (i.= 0) scope))
-
-##     (#ls;Loop offset argsS bodyS)
-##     (or (list;any? has-self-reference? argsS)
-##         (has-self-reference? bodyS))
-
-##     _
-##     false
-##     ))
-
-## (def: (shift-loop-variables scope offset exprS)
-##   (-> (List Int) Nat ls;Synthesis ls;Synthesis)
-##   (loop [exprS exprS]
-##     (case exprS
-##       (#ls;Tuple members)
-##       (#ls;Tuple (L/map recur members))
-
-##       (#ls;Procedure name argsS)
-##       (#ls;Procedure name (L/map recur argsS))
-
-##       (#ls;Variant tag last? valueS)
-##       (#ls;Variant tag last? (recur valueS))
-
-##       (#ls;Variable idx)
-##       (if (captured-ref? idx)
-##         (let [scope-idx (|> idx (n.+ 1) (n.* -1) int-to-nat)]
-##           (|> scope (list;nth scope-idx) assume #ls;Variable))
-##         (#ls;Variable (i.+ idx (nat-to-int offset))))
-
-##       (#ls;Recur _offset argsS)
-##       (#ls;Recur (n.+ offset _offset) (L/map recur argsS))
-
-##       (#ls;Call funcS argsS)
-##       (#ls;Call (recur funcS) (L/map recur argsS))
-
-##       (#ls;Let register inputS bodyS)
-##       (#ls;Let (n.+ offset register) (recur inputS) (recur bodyS))
-
-##       (#ls;If inputS thenS elseS)
-##       (#ls;If (recur inputS) (recur thenS) (recur elseS))
-
-##       (#ls;Function _num-args _scope _bodyS)
-##       ...
-
-##       (#ls;Loop _offset _argsS _bodyS)
-##       (#ls;Loop (n.+ offset _offset) (L/map recur _argsS) (recur _bodyS))
-
-##       _
-##       exprS
-##       )))
-
 (def: init-env (List ls;Variable) (list))
 (def: init-resolver (d;Dict Int Int) (d;new number;Hash<Int>))
 
+(def: (prepare-body inner-arity arity body)
+  (-> Nat Nat ls;Synthesis ls;Synthesis)
+  (if (&&function;nested? inner-arity)
+    body
+    (&&loop;reify-recursion arity body)))
+
 (def: #export (synthesize analysis)
   (-> la;Analysis ls;Synthesis)
-  (loop [scope-args +0
+  (loop [outer-arity +0
          resolver init-resolver
+         num-locals +0
          exprA analysis]
     (case exprA
       (^template [<from> <to>]
@@ -117,34 +42,29 @@
        [#la;Absolute #ls;Definition])
 
       (#la;Product _)
-      (#ls;Tuple (L/map (recur +0 resolver) (&&structure;unfold-tuple exprA)))
+      (#ls;Tuple (L/map (recur +0 resolver num-locals) (&&structure;unfold-tuple exprA)))
 
       (#la;Sum choice)
       (let [[tag last? value] (&&structure;unfold-variant choice)]
-        (#ls;Variant tag last? (recur +0 resolver value)))
+        (#ls;Variant tag last? (recur +0 resolver num-locals value)))
 
       (#la;Relative ref)
-      (if (&&function;nested-function? scope-args)
-        (case ref
-          (#;Local local)
-          (if (n.= +0 local)
+      (case ref
+        (#;Local register)
+        (if (&&function;nested? outer-arity)
+          (if (n.= +0 register)
             (<| (#ls;Call (#ls;Variable 0))
-                (L/map (|>. nat-to-int #ls;Variable))
-                (list;n.range +1 (n.dec scope-args)))
-            (#ls;Variable (&&function;adjust-var scope-args (nat-to-int local))))
-          
-          (#;Captured register)
-          (#ls;Variable (default (&&function;to-captured register)
-                          (d;get (&&function;to-captured register) resolver))))
-        (case ref
-          (#;Local local)
-          (#ls;Variable (nat-to-int local))
-          
-          (#;Captured register)
-          (#ls;Variable (&&function;to-captured register))))
+                (L/map (|>. &&function;to-local #ls;Variable))
+                (list;n.range +1 (n.dec outer-arity)))
+            (#ls;Variable (&&function;adjust-var outer-arity (&&function;to-local register))))
+          (#ls;Variable (&&function;to-local register)))
+        
+        (#;Captured register)
+        (#ls;Variable (let [var (&&function;to-captured register)]
+                        (default var (d;get var resolver)))))
 
       (#la;Function scope bodyA)
-      (let [num-args (n.inc scope-args)
+      (let [inner-arity (n.inc outer-arity)
             raw-env (&&function;environment scope)
             env (L/map (function [var] (default var (d;get var resolver))) raw-env)
             env-vars (let [env-size (list;size raw-env)]
@@ -152,7 +72,7 @@
                           (case env-size
                             +0 (list)
                             _ (L/map &&function;to-captured (list;n.range +0 (n.dec env-size))))))
-            resolver' (if (&&function;nested-function? num-args)
+            resolver' (if (&&function;nested? inner-arity)
                         (L/fold (function [[from to] resolver']
                                   (d;put from to resolver'))
                                 init-resolver
@@ -161,33 +81,36 @@
                                   (d;put var var resolver'))
                                 init-resolver
                                 env-vars))]
-        (case (recur num-args resolver' bodyA)
-          (#ls;Function args' env' bodyS')
-          (#ls;Function (n.inc args') env bodyS')
+        (case (recur inner-arity resolver' +0 bodyA)
+          (#ls;Function arity' env' bodyS')
+          (let [arity (n.inc arity')]
+            (#ls;Function arity env (prepare-body inner-arity arity bodyS')))
 
           bodyS
-          (#ls;Function +1 env bodyS)))
-      
+          (#ls;Function +1 env (prepare-body inner-arity +1 bodyS))))
+
       (#la;Apply _)
       (let [[funcA argsA] (&&function;unfold-apply exprA)
-            funcS (recur +0 resolver funcA)
-            argsS (L/map (recur +0 resolver) argsA)]
+            funcS (recur +0 resolver num-locals funcA)
+            argsS (L/map (recur +0 resolver num-locals) argsA)]
         (case funcS
-          ## (^multi (#ls;Variable idx)
-          ##         (and (|> scope-args n.dec nat-to-int (i.* -1) (i.= idx))
-          ##              tail?))
-          ## (#ls;Recur +1 argsS)
-
-          ## (^multi (#ls;Function _scope-args _scope _bodyS)
-          ##         (and (n.= _scope-args (list;size argsS))
-          ##              (not (has-self-reference? _bodyS))))
-          ## (#ls;Loop local-offset argsS (shift-loop-variables local-offset _bodyS))
+          (^multi (#ls;Function _arity _env _bodyS)
+                  (and (n.= _arity (list;size argsS))
+                       (not (&&loop;contains-self-reference? _bodyS))))
+          (let [register-offset (if (&&function;top? outer-arity)
+                                  num-locals
+                                  (|> outer-arity n.inc (n.+ num-locals)))]
+            (#ls;Loop register-offset argsS
+                      (&&loop;adjust _env register-offset _bodyS)))
+
+          (#ls;Call funcS' argsS')
+          (#ls;Call funcS' (L/append argsS' argsS))
 
           _
           (#ls;Call funcS argsS)))
 
       (#la;Procedure name args)
-      (#ls;Procedure name (L/map (recur +0 resolver) args))
+      (#ls;Procedure name (L/map (recur +0 resolver num-locals) args))
 
       _
       (undefined)
diff --git a/new-luxc/source/luxc/synthesizer/function.lux b/new-luxc/source/luxc/synthesizer/function.lux
index be6a74da0..42aa7a6cd 100644
--- a/new-luxc/source/luxc/synthesizer/function.lux
+++ b/new-luxc/source/luxc/synthesizer/function.lux
@@ -22,18 +22,23 @@
      (-> ls;Variable Bool)
      (<comp> 0 var))]
 
-  [function-var? i.=]
-  [local-var?    i.>]
-  [captured-var? i.<]
+  [self?     i.=]
+  [local?    i.>]
+  [captured? i.<]
   )
 
-(def: #export (nested-function? scope-args)
-  (-> Nat Bool)
-  (n.> +1 scope-args))
+(do-template [<name> <comp> <ref>]
+  [(def: #export (<name> arity)
+     (-> ls;Arity Bool)
+     (<comp> <ref> arity))]
 
-(def: #export (adjust-var scope-args var)
-  (-> Nat ls;Variable ls;Variable)
-  (|> scope-args n.dec nat-to-int (i.+ var)))
+  [nested? n.> +1]
+  [top?    n.= +0]
+  )
+
+(def: #export (adjust-var outer var)
+  (-> ls;Arity ls;Variable ls;Variable)
+  (|> outer n.dec nat-to-int (i.+ var)))
 
 (def: #export (to-captured idx)
   (-> Nat Int)
diff --git a/new-luxc/source/luxc/synthesizer/loop.lux b/new-luxc/source/luxc/synthesizer/loop.lux
new file mode 100644
index 000000000..06b1d1bb0
--- /dev/null
+++ b/new-luxc/source/luxc/synthesizer/loop.lux
@@ -0,0 +1,166 @@
+(;module:
+  lux
+  (lux (data (coll [list "L/" Functor<List>])
+             text/format))
+  (luxc (lang ["ls" synthesis])
+        (synthesizer ["&&;" function])))
+
+(def: #export (contains-self-reference? exprS)
+  (-> ls;Synthesis Bool)
+  (case exprS
+    (#ls;Variant tag last? memberS)
+    (contains-self-reference? memberS)
+
+    (#ls;Tuple membersS)
+    (list;any? contains-self-reference? membersS)
+
+    (#ls;Case inputS pathS)
+    (or (contains-self-reference? inputS)
+        (loop [pathS pathS]
+          (case pathS
+            (^or (#ls;AltP leftS rightS)
+                 (#ls;SeqP leftS rightS))
+            (or (recur leftS)
+                (recur rightS))
+            
+            (#ls;ExecP bodyS)
+            (contains-self-reference? bodyS)
+            
+            _
+            false)))
+
+    (#ls;Function arity environment bodyS)
+    (list;any? &&function;self? environment)
+    
+    (#ls;Call funcS argsS)
+    (or (contains-self-reference? funcS)
+        (list;any? contains-self-reference? argsS))
+    
+    (^or (#ls;Recur argsS)
+         (#ls;Procedure name argsS))
+    (list;any? contains-self-reference? argsS)
+
+    (#ls;Variable idx)
+    (&&function;self? idx)
+
+    (#ls;Let register inputS bodyS)
+    (or (contains-self-reference? inputS)
+        (contains-self-reference? bodyS))
+
+    (#ls;If inputS thenS elseS)
+    (or (contains-self-reference? inputS)
+        (contains-self-reference? thenS)
+        (contains-self-reference? elseS))
+
+    (#ls;Loop offset argsS bodyS)
+    (or (list;any? contains-self-reference? argsS)
+        (contains-self-reference? bodyS))
+
+    _
+    false
+    ))
+
+(def: #export (reify-recursion arity exprS)
+  (-> Nat ls;Synthesis ls;Synthesis)
+  (loop [exprS exprS]
+    (case exprS
+      (#ls;Case inputS pathS)
+      (#ls;Case inputS
+                (let [reify-recursion' recur]
+                  (loop [pathS pathS]
+                    (case pathS
+                      (#ls;AltP leftS rightS)
+                      (#ls;AltP (recur leftS) (recur rightS))
+
+                      (#ls;SeqP leftS rightS)
+                      (#ls;SeqP leftS (recur rightS))
+                      
+                      (#ls;ExecP bodyS)
+                      (#ls;ExecP (reify-recursion' bodyS))
+                      
+                      _
+                      pathS))))
+
+      (^multi (#ls;Call (#ls;Variable 0) argsS)
+              (n.= arity (list;size argsS)))
+      (#ls;Recur argsS)
+
+      (#ls;Call (#ls;Variable var) argsS)
+      exprS
+
+      (#ls;Let register inputS bodyS)
+      (#ls;Let register inputS (recur bodyS))
+
+      (#ls;If inputS thenS elseS)
+      (#ls;If inputS
+              (recur thenS)
+              (recur elseS))
+
+      _
+      exprS
+      )))
+
+(def: #export (adjust env outer-offset exprS)
+  (-> (List ls;Variable) ls;Register ls;Synthesis ls;Synthesis)
+  (let [resolve-captured (: (-> ls;Variable ls;Variable)
+                            (function [var]
+                              (let [idx (|> var (i.* -1) int-to-nat n.dec)]
+                                (|> env (list;nth idx) assume))))]
+    (loop [exprS exprS]
+      (case exprS
+        (#ls;Variant tag last? valueS)
+        (#ls;Variant tag last? (recur valueS))
+        
+        (#ls;Tuple members)
+        (#ls;Tuple (L/map recur members))
+
+        (#ls;Case inputS pathS)
+        (#ls;Case (recur inputS)
+                  (let [adjust' recur]
+                    (loop [pathS pathS]
+                      (case pathS
+                        (^template [<tag>]
+                          (<tag> leftS rightS)
+                          (<tag> (recur leftS) (recur rightS)))
+                        ([#ls;AltP]
+                         [#ls;SeqP])
+                        
+                        (#ls;ExecP bodyS)
+                        (#ls;ExecP (adjust' bodyS))
+                        
+                        _
+                        pathS))))
+
+        (#ls;Function arity scope bodyS)
+        (#ls;Function arity
+                      (L/map resolve-captured scope)
+                      (recur bodyS))
+
+        (#ls;Call funcS argsS)
+        (#ls;Call (recur funcS) (L/map recur argsS))
+
+        (#ls;Recur argsS)
+        (#ls;Recur (L/map recur argsS))
+
+        (#ls;Procedure name argsS)
+        (#ls;Procedure name (L/map recur argsS))
+
+        (#ls;Variable var)
+        (if (&&function;captured? var)
+          (#ls;Variable (resolve-captured var))
+          (#ls;Variable (|> outer-offset nat-to-int (i.+ var))))
+
+        (#ls;Let register inputS bodyS)
+        (#ls;Let (n.+ outer-offset register) (recur inputS) (recur bodyS))
+
+        (#ls;If inputS thenS elseS)
+        (#ls;If (recur inputS) (recur thenS) (recur elseS))
+
+        (#ls;Loop inner-offset argsS bodyS)
+        (#ls;Loop (n.+ outer-offset inner-offset)
+                  (L/map recur argsS)
+                  (recur bodyS))
+
+        _
+        exprS
+        ))))