- Fixed some bugs.

9 files changed, 144 insertions, 100 deletions

diff --git a/new-luxc/source/luxc/host.jvm.lux b/new-luxc/source/luxc/host.jvm.lux
index 2cbdf5883..b2bf07d32 100644
--- a/new-luxc/source/luxc/host.jvm.lux
+++ b/new-luxc/source/luxc/host.jvm.lux
@@ -1,6 +1,7 @@
 (;module:
   lux
-  (lux (control [monad #+ do])
+  (lux (control [monad #+ do]
+                pipe)
        (concurrency ["A" atom])
        (data ["e" error]
              [text]
@@ -83,8 +84,56 @@
                         (A;atom (dict;new text;Hash<Text>)))]
            {#commonT;loader (memory-class-loader store)
             #commonT;store store
-            #commonT;function-class #;None
-            #commonT;artifacts (dict;new text;Hash<Text>)})))
+            #commonT;artifacts (dict;new text;Hash<Text>)
+            #commonT;context ["" +0]})))
+
+(def: #export (with-context name expr)
+  (All [a] (-> Text (Meta a) (Meta a)))
+  (;function [compiler]
+    (let [old (:! commonT;Host (get@ #;host compiler))]
+      (case (expr (set@ #;host
+                        (:! Void (set@ #commonT;context [name +0] old))
+                        compiler))
+        (#e;Success [compiler' output])
+        (#e;Success [(update@ #;host
+                              (|>. (:! commonT;Host)
+                                   (set@ #commonT;context (get@ #commonT;context old))
+                                   (:! Void))
+                              compiler')
+                     output])
+
+        (#e;Error error)
+        (#e;Error error)))))
+
+(def: #export (with-sub-context expr)
+  (All [a] (-> (Meta a) (Meta [Text a])))
+  (;function [compiler]
+    (let [old (:! commonT;Host (get@ #;host compiler))
+          [old-name old-sub] (get@ #commonT;context old)
+          new-name (format old-name "/" (%n old-sub))]
+      (case (expr (set@ #;host
+                        (:! Void (set@ #commonT;context [new-name +0] old))
+                        compiler))
+        (#e;Success [compiler' output])
+        (#e;Success [(update@ #;host
+                              (|>. (:! commonT;Host)
+                                   (set@ #commonT;context [old-name (n.inc old-sub)])
+                                   (:! Void))
+                              compiler')
+                     [new-name output]])
+
+        (#e;Error error)
+        (#e;Error error)))))
+
+(def: #export context
+  (Meta Text)
+  (;function [compiler]
+    (#e;Success [compiler
+                 (|> (get@ #;host compiler)
+                     (:! commonT;Host)
+                     (get@ #commonT;context)
+                     (let> [name sub]
+                           name))])))
 
 (def: #export class-loader
   (Meta ClassLoader)
diff --git a/new-luxc/source/luxc/lang/synthesis/case.lux b/new-luxc/source/luxc/lang/synthesis/case.lux
index e66bbf3a8..8bc1e43f9 100644
--- a/new-luxc/source/luxc/lang/synthesis/case.lux
+++ b/new-luxc/source/luxc/lang/synthesis/case.lux
@@ -9,8 +9,8 @@
   (luxc (lang ["la" analysis]
               ["ls" synthesis])))
 
-(def: #export (path pattern)
-  (-> la;Pattern ls;Path)
+(def: #export (path outer-arity pattern)
+  (-> ls;Arity la;Pattern ls;Path)
   (case pattern
     (^code ("lux case tuple" [(~@ membersP)]))
     (case (list;reverse membersP)
@@ -18,7 +18,7 @@
       (' ("lux case pop"))
 
       (#;Cons singletonP #;Nil)
-      (path singletonP)
+      (path outer-arity singletonP)
 
       (#;Cons lastP prevsP)
       (let [length (list;size membersP)
@@ -26,10 +26,10 @@
             [_ tuple-path] (list/fold (function [current-pattern [current-idx next-path]]
                                         [(n.dec current-idx)
                                          (` ("lux case seq"
-                                             ("lux case tuple left" (~ (code;nat current-idx)) (~ (path current-pattern)))
+                                             ("lux case tuple left" (~ (code;nat current-idx)) (~ (path outer-arity current-pattern)))
                                              (~ next-path)))])
                                       [(n.dec last-idx)
-                                       (` ("lux case tuple right" (~ (code;nat last-idx)) (~ (path lastP))))]
+                                       (` ("lux case tuple right" (~ (code;nat last-idx)) (~ (path outer-arity lastP))))]
                                       prevsP)]
         (` ("lux case seq"
             (~ tuple-path)
@@ -38,12 +38,21 @@
     (^code ("lux case variant" (~ [_ (#;Nat tag)]) (~ [_ (#;Nat num-tags)]) (~ memberP)))
     (` ("lux case seq"
         (~ (if (n.= (n.dec num-tags) tag)
-             (` ("lux case variant right" (~ (code;nat tag)) (~ (path memberP))))
-             (` ("lux case variant left" (~ (code;nat tag)) (~ (path memberP))))))
+             (` ("lux case variant right" (~ (code;nat tag)) (~ (path outer-arity memberP))))
+             (` ("lux case variant left" (~ (code;nat tag)) (~ (path outer-arity memberP))))))
+        ("lux case pop")))
+
+    (^code ("lux case bind" (~ [_ (#;Nat register)])))
+    (` ("lux case seq"
+        ("lux case bind" (~ (if (n.> +1 outer-arity)
+                              (code;nat (n.+ (n.dec outer-arity) register))
+                              (code;nat register))))
         ("lux case pop")))
 
     _
-    pattern))
+    (` ("lux case seq"
+        (~ pattern)
+        ("lux case pop")))))
 
 (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 531606ba7..9ea397576 100644
--- a/new-luxc/source/luxc/lang/synthesis/expression.lux
+++ b/new-luxc/source/luxc/lang/synthesis/expression.lux
@@ -60,9 +60,9 @@
   (-> ls;Synthesis (List ls;Synthesis) ls;Synthesis)
   (` ("lux call" (~ funcS) (~@ argsS))))
 
-(def: (synthesize-case synthesize inputA branchesA)
+(def: (synthesize-case synthesize outer-arity inputA branchesA)
   (-> (-> la;Analysis ls;Synthesis)
-      la;Analysis (List [la;Pattern la;Analysis])
+      ls;Arity la;Analysis (List [la;Pattern la;Analysis])
       ls;Synthesis)
   (let [inputS (synthesize inputA)]
     (case (list;reverse branchesA)
@@ -84,7 +84,7 @@
                                 (function [pattern expr]
                                   (|> (synthesize expr)
                                       (~) ("lux case exec")
-                                      ("lux case seq" (~ (caseS;path pattern)))
+                                      ("lux case seq" (~ (caseS;path outer-arity pattern)))
                                       (`))))
             pathS (list/fold caseS;weave
                              (transform-branch lastP lastA)
@@ -143,7 +143,7 @@
         (var$ (maybe;default var (dict;get var resolver))))
 
       (^code ("lux case" (~ inputA) (~ [_ (#;Record branchesA)])))
-      (synthesize-case (recur outer-arity resolver num-locals) inputA branchesA)
+      (synthesize-case (recur outer-arity resolver num-locals) outer-arity inputA branchesA)
 
       (^multi (^code ("lux function" [(~@ scope)] (~ bodyA)))
               [(s;run scope (p;some s;int)) (#e;Success raw-env)])
diff --git a/new-luxc/source/luxc/lang/translation.lux b/new-luxc/source/luxc/lang/translation.lux
index 60fbde6c8..779cb92fd 100644
--- a/new-luxc/source/luxc/lang/translation.lux
+++ b/new-luxc/source/luxc/lang/translation.lux
@@ -38,24 +38,25 @@
   (-> Code (Meta Unit))
   (case code
     (^code ("lux def" (~ [_ (#;Symbol ["" def-name])]) (~ valueC) (~ metaC)))
-    (do meta;Monad<Meta>
-      [[_ metaA] (&;with-scope
-                   (&;with-expected-type Code
-                     (analyse metaC)))
-       metaI (expressionT;translate (expressionS;synthesize metaA))
-       metaV (evalT;eval metaI)
-       [_ valueT valueA] (&;with-scope
-                           (if (meta;type? (:! Code metaV))
-                             (&;with-expected-type Type
-                               (do @
-                                 [valueA (analyse valueC)]
-                                 (wrap [Type valueA])))
-                             (commonA;with-unknown-type
-                               (analyse valueC))))
-       valueI (expressionT;translate (expressionS;synthesize valueA))
-       _ (&;with-scope
-           (statementT;translate-def def-name valueT valueI metaI (:! Code metaV)))]
-      (wrap []))
+    (hostL;with-context def-name
+      (do meta;Monad<Meta>
+        [[_ metaA] (&;with-scope
+                     (&;with-expected-type Code
+                       (analyse metaC)))
+         metaI (expressionT;translate (expressionS;synthesize metaA))
+         metaV (evalT;eval metaI)
+         [_ valueT valueA] (&;with-scope
+                             (if (meta;type? (:! Code metaV))
+                               (&;with-expected-type Type
+                                 (do @
+                                   [valueA (analyse valueC)]
+                                   (wrap [Type valueA])))
+                               (commonA;with-unknown-type
+                                 (analyse valueC))))
+         valueI (expressionT;translate (expressionS;synthesize valueA))
+         _ (&;with-scope
+             (statementT;translate-def def-name valueT valueI metaI (:! Code metaV)))]
+        (wrap [])))
 
     (^code ("lux program" (~ [_ (#;Symbol ["" program-args])]) (~ programC)))
     (do meta;Monad<Meta>
diff --git a/new-luxc/source/luxc/lang/translation/case.jvm.lux b/new-luxc/source/luxc/lang/translation/case.jvm.lux
index 3858627ff..09ffae328 100644
--- a/new-luxc/source/luxc/lang/translation/case.jvm.lux
+++ b/new-luxc/source/luxc/lang/translation/case.jvm.lux
@@ -70,8 +70,7 @@
 
     (^ [_ (#;Form (list [_ (#;Text "lux case bind")] [_ (#;Nat register)]))])
     (meta/wrap (|>. peekI
-                    ($i;ASTORE register)
-                    popI))
+                    ($i;ASTORE register)))
 
     [_ (#;Bool value)]
     (meta/wrap (let [jumpI (if value $i;IFEQ $i;IFNE)]
diff --git a/new-luxc/source/luxc/lang/translation/common.jvm.lux b/new-luxc/source/luxc/lang/translation/common.jvm.lux
index 1870530c2..f9825614a 100644
--- a/new-luxc/source/luxc/lang/translation/common.jvm.lux
+++ b/new-luxc/source/luxc/lang/translation/common.jvm.lux
@@ -33,8 +33,8 @@
 (type: #export Host
   {#loader ClassLoader
    #store Class-Store
-   #function-class (Maybe Text)
-   #artifacts Artifacts})
+   #artifacts Artifacts
+   #context [Text Nat]})
 
 (exception: Unknown-Class)
 (exception: Class-Already-Stored)
@@ -93,38 +93,6 @@
         (#e;Success [compiler (ClassLoader.loadClass [name] (get@ #loader host))])
         (ex;throw Unknown-Class name)))))
 
-(def: #export (with-function class expr)
-  (All [a] (-> Text (Meta a) (Meta a)))
-  (;function [compiler]
-    (let [host (:! Host (get@ #;host compiler))
-          old-function-class (get@ #function-class host)]
-      (case (expr (set@ #;host
-                        (:! Void (set@ #function-class
-                                       (#;Some class)
-                                       host))
-                        compiler))
-        (#e;Success [compiler' output])
-        (#e;Success [(update@ #;host
-                              (|>. (:! Host)
-                                   (set@ #function-class old-function-class)
-                                   (:! Void))
-                              compiler')
-                     output])
-
-        (#e;Error error)
-        (#e;Error error)))))
-
-(def: #export function
-  (Meta Text)
-  (;function [compiler]
-    (let [host (:! Host (get@ #;host compiler))]
-      (case (get@ #function-class host)
-        #;None
-        (ex;throw No-Function-Being-Compiled "")
-        
-        (#;Some function-class)
-        (#e;Success [compiler function-class])))))
-
 (def: #export bytecode-version Int Opcodes.V1_6)
 
 (def: #export value-field Text "_value")
diff --git a/new-luxc/source/luxc/lang/translation/function.jvm.lux b/new-luxc/source/luxc/lang/translation/function.jvm.lux
index ebdb28853..1b7f6267b 100644
--- a/new-luxc/source/luxc/lang/translation/function.jvm.lux
+++ b/new-luxc/source/luxc/lang/translation/function.jvm.lux
@@ -1,7 +1,8 @@
 (;module:
   lux
   (lux (control [monad #+ do])
-       (data text/format
+       (data [text]
+             text/format
              (coll [list "list/" Functor<List> Monoid<List>]))
        [meta])
   (luxc ["&" base]
@@ -266,13 +267,11 @@
                     $i;ARETURN
                     ))))
 
-(def: #export (with-function translate class env arity body)
-  (-> (-> ls;Synthesis (Meta $;Inst))
-      Text (List Variable) ls;Arity ls;Synthesis
+(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
-     bodyI (commonT;with-function class (translate body))
      #let [env-size (list;size env)
            applyD (: $;Def
                      (if (poly-arg? arity)
@@ -300,8 +299,10 @@
       (List Variable) ls;Arity ls;Synthesis
       (Meta $;Inst))
   (do meta;Monad<Meta>
-    [function-class (:: @ map %code (meta;gensym "function"))
-     [functionD instanceI] (with-function translate function-class env arity body)
+    [[context bodyI] (hostL;with-sub-context
+                       (translate body))
+     #let [function-class (text;replace-all "/+" "$" context)]
+     [functionD instanceI] (with-function function-class env arity bodyI)
      _ (commonT;store-class function-class
                             ($d;class #$;V1.6 #$;Public $;finalC
                                       function-class (list)
diff --git a/new-luxc/source/luxc/lang/translation/reference.jvm.lux b/new-luxc/source/luxc/lang/translation/reference.jvm.lux
index da86dd5b9..57336f27c 100644
--- a/new-luxc/source/luxc/lang/translation/reference.jvm.lux
+++ b/new-luxc/source/luxc/lang/translation/reference.jvm.lux
@@ -1,9 +1,11 @@
 (;module:
   lux
   (lux (control [monad #+ do])
-       (data text/format)
+       (data [text]
+             text/format)
        [meta "meta/" Monad<Meta>])
   (luxc ["&" base]
+        [";L" host]
         (host ["$" jvm]
               (jvm ["$t" type]
                    ["$i" inst]))
@@ -15,9 +17,9 @@
 (def: #export (translate-captured variable)
   (-> Variable (Meta $;Inst))
   (do meta;Monad<Meta>
-    [function-class commonT;function]
+    [function-class hostL;context]
     (wrap (|>. ($i;ALOAD +0)
-               ($i;GETFIELD function-class
+               ($i;GETFIELD (text;replace-all "/+" "$" function-class)
                             (|> variable i.inc (i.* -1) int-to-nat functionT;captured)
                             commonT;$Object)))))
 
diff --git a/new-luxc/source/luxc/scope.lux b/new-luxc/source/luxc/scope.lux
index 4ce8a51cb..165399c8f 100644
--- a/new-luxc/source/luxc/scope.lux
+++ b/new-luxc/source/luxc/scope.lux
@@ -1,36 +1,51 @@
 (;module:
   lux
   (lux (control monad)
-       (data [text]
+       (data [text "text/" Eq<Text>]
              text/format
              [maybe "maybe/" Monad<Maybe>]
              [product]
              ["e" error]
-             (coll [list "list/" Fold<List> Monoid<List>]))
+             (coll [list "list/" Functor<List> Fold<List> Monoid<List>]))
        [meta])
-  (luxc ["&" base]))
+  (luxc ["&" base]
+        (lang [";L" variable #+ Variable])))
 
 (type: Locals (Bindings Text [Type Nat]))
 (type: Captured (Bindings Text [Type Ref]))
 
-(do-template [<slot> <is> <get> <then>]
-  [(def: (<is> name scope)
-     (-> Text Scope Bool)
-     (|> scope
-         (get@ [<slot> #;mappings])
-         (&;pl-contains? name)))
-
-   (def: (<get> name scope)
-     (-> Text Scope (Maybe [Type Ref]))
-     (|> scope
-         (get@ [<slot> #;mappings])
-         (&;pl-get name)
-         (maybe/map (function [[type value]]
-                      [type (<then> value)]))))]
-
-  [#;locals   is-local?    get-local    #;Local]
-  [#;captured is-captured? get-captured id]
-  )
+(def: (is-local? name scope)
+  (-> Text Scope Bool)
+  (|> scope
+      (get@ [#;locals #;mappings])
+      (&;pl-contains? name)))
+
+(def: (get-local name scope)
+  (-> Text Scope (Maybe [Type Ref]))
+  (|> scope
+      (get@ [#;locals #;mappings])
+      (&;pl-get name)
+      (maybe/map (function [[type value]]
+                   [type (#;Local value)]))))
+
+(def: (is-captured? name scope)
+  (-> Text Scope Bool)
+  (|> scope
+      (get@ [#;captured #;mappings])
+      (&;pl-contains? name)))
+
+(def: (get-captured name scope)
+  (-> Text Scope (Maybe [Type Ref]))
+  (loop [idx +0
+         mappings (get@ [#;captured #;mappings] scope)]
+    (case mappings
+      #;Nil
+      #;None
+
+      (#;Cons [_name [_source-type _source-ref]] mappings')
+      (if (text/= name _name)
+        (#;Some [_source-type (#;Captured idx)])
+        (recur (n.inc idx) mappings')))))
 
 (def: (is-ref? name scope)
   (-> Text Scope Bool)