Fixed the issue with nested capture and nested lambdas

examples/nested_lambdas.carp

@@ -0,0 +1,2 @@
+(defn my-curry [f] (fn [x] (fn [y] (f x y))))
+(defn double-curry [f] (fn [x] (fn [y] (fn [z] (f x y z)))))

run_carp_tests.sh

@@ -43,6 +43,7 @@ done
 ./carp.sh ./examples/guessing.carp -b
 ./carp.sh ./examples/no_core.carp --no-core --no-profile -b
 ./carp.sh ./examples/check_malloc.carp -b
+./carp.sh ./examples/nested_lambdas.carp -b
 
 # Run tests which rely on SDL unless the `--no_sdl` argument was passed in
 if [[ ${NO_SDL} -eq 0 ]]; then

src/Concretize.hs

@@ -110,8 +110,7 @@ concretizeXObj allowAmbiguityRoot typeEnv rootEnv visitedDefinitions root =
              let -- Analyse the body of the lambda to find what variables it captures
                  capturedVarsRaw = collectCapturedVars okBody
                  -- and then remove the captures that are actually our arguments
-                 capturedVars = filter (\xobj -> obj xobj `notElem` argObjs)
-                                capturedVarsRaw
+                 capturedVars = filter (\xobj -> obj (toGeneralSymbol xobj) `notElem` argObjs) capturedVarsRaw
 
                  -- Create a new (top-level) function that will be used when the lambda is called.
                  -- Its name will contain the name of the (normal, non-lambda) function it's contained within,
@@ -307,16 +306,25 @@ concretizeXObj allowAmbiguityRoot typeEnv rootEnv visitedDefinitions root =
         Nothing ->
           error ("No interface named '" ++ name ++ "' found.")
 
+toGeneralSymbol :: XObj -> XObj
+toGeneralSymbol (XObj (Sym path _) _ t) = XObj (Sym path Symbol) (Just dummyInfo) t
+toGeneralSymbol x = error ("Can't convert this to a general symbol: " ++ show x)
+
 -- | Find all lookups in a lambda body that should be captured by its environment
 collectCapturedVars :: XObj -> [XObj]
-collectCapturedVars root = removeDuplicates (map toGeneralSymbol (visit root))
+collectCapturedVars root = removeDuplicates (map decreaseCaptureLevel (visit root))
   where
     removeDuplicates :: Ord a => [a] -> [a]
     removeDuplicates = Set.toList . Set.fromList
 
-    toGeneralSymbol :: XObj -> XObj
-    toGeneralSymbol (XObj (Sym path _) _ t) = XObj (Sym path Symbol) (Just dummyInfo) t
-    toGeneralSymbol x = error ("Can't convert this to a general symbol: " ++ show x)
+    decreaseCaptureLevel :: XObj -> XObj
+    decreaseCaptureLevel (XObj (Sym path lookup) _ ty) =
+      XObj (Sym path (case lookup of
+                         Symbol -> Symbol
+                         LookupLocal NoCapture -> Symbol
+                         LookupLocal (Capture n) -> if n <= 1 then Symbol
+                                                    else LookupLocal (Capture (n-1))))
+      (Just dummyInfo) ty
 
     visit xobj =
       case obj xobj of
@@ -325,7 +333,7 @@ collectCapturedVars root = removeDuplicates (map toGeneralSymbol (visit root))
         (Lst _) -> visitList xobj
         (Arr _) -> visitArray xobj
         -- TODO: Static Arrays!
-        (Sym path (LookupLocal Capture)) -> [xobj]
+        (Sym path (LookupLocal (Capture _))) -> [xobj]
         _ -> []
 
     visitList :: XObj -> [XObj]
@@ -506,7 +514,7 @@ modeFromPath env p =
         RecursionEnv -> LookupRecursive
         _ ->  LookupLocal
                 (if envFunctionNestingLevel e < envFunctionNestingLevel env
-                            then Capture
+                            then Capture (envFunctionNestingLevel e - envFunctionNestingLevel env)
                             else NoCapture)
     Nothing -> error ("Couldn't find " ++ show p ++ " in env:\n" ++ prettyEnvironmentChain env)
 
@@ -865,7 +873,7 @@ manageMemory typeEnv globalEnv root =
                           LookupGlobal _ _ -> return ()
 
                         case okMode of
-                          LookupLocal Capture ->
+                          LookupLocal (Capture _) ->
                             return (Left (CannotSetVariableFromLambda variable setbangExpr))
                           _ ->
                             return $ do okValue <- visitedValue
@@ -1252,7 +1260,7 @@ manageMemory typeEnv globalEnv root =
         isSymbolThatCaptures :: XObj -> Bool
         isSymbolThatCaptures xobj =
           case xobj of
-            XObj (Sym _ (LookupLocal Capture)) _ _ -> True
+            XObj (Sym _ (LookupLocal (Capture _))) _ _ -> True
             _ -> False
 
         unmanage :: XObj -> State MemState (Either TypeError ())

src/Emit.hs

@@ -177,7 +177,7 @@ toC toCMode (Binder meta root) = emitterSrc (execState (visit startingIndent roo
                           appendToSrc (addIndent indent ++ "Lambda " ++ var ++ " = { .callback = " ++ pathToC path ++ ", .env = NULL, .delete = NULL, .copy = NULL }; //" ++ show sym ++ "\n")
                           return var
                   else case lookupMode of
-                         LookupLocal Capture -> return ("_env->" ++ pathToC path)
+                         LookupLocal (Capture _) -> return ("_env->" ++ pathToC path)
                          _ -> return (pathToC path)
 
         visitSymbol _ xobj@(XObj (Sym path _) Nothing _) = error ("Symbol missing info: " ++ show xobj)
@@ -221,9 +221,12 @@ toC toCMode (Binder meta root) = emitterSrc (execState (visit startingIndent roo
                  when needEnv $
                    do appendToSrc (addIndent indent ++ tyToC lambdaEnvType ++ " *" ++ lambdaEnvName ++
                                    " = CARP_MALLOC(sizeof(" ++ tyToC lambdaEnvType ++ "));\n")
-                      mapM_ (\(XObj (Sym path _) _ _) ->
-                               appendToSrc (addIndent indent ++ lambdaEnvName ++ "->" ++
-                                            pathToC path ++ " = " ++ pathToC path ++ ";\n"))
+                      mapM_ (\(XObj (Sym path lookupMode) _ _) ->
+                                appendToSrc (addIndent indent ++ lambdaEnvName ++ "->" ++
+                                             pathToC path ++ " = " ++
+                                             (case lookupMode of
+                                                LookupLocal (Capture _) -> "_env->" ++ pathToC path
+                                                _ -> pathToC path) ++ ";\n"))
                         capturedVars
                  appendToSrc (addIndent indent ++ "Lambda " ++ retVar ++ " = {\n")
                  appendToSrc (addIndent indent ++ "  .callback = " ++ callbackMangled ++ ",\n")

src/Obj.hs

@@ -25,7 +25,7 @@ data DefinitionMode = AVariable
 
 -- | For local lookups, does the variable live in the current function or is it captured from outside it's body?
 data CaptureMode = NoCapture
-                 | Capture
+                 | Capture Int
                  deriving (Eq, Show, Ord)
 
 -- | A symbol knows a bit about what it refers to - is it a local scope or a global one? (the latter include modules).

src/Qualify.hs

@@ -131,7 +131,7 @@ setFullyQualifiedSymbols typeEnv globalEnv localEnv xobj@(XObj (Sym path _) i t)
       XObj (InterfaceSym name) i t
 
     captureOrNot foundEnv = if envFunctionNestingLevel foundEnv < envFunctionNestingLevel localEnv
-                            then Capture
+                            then Capture (envFunctionNestingLevel localEnv - envFunctionNestingLevel foundEnv)
                             else NoCapture
 
     doesNotBelongToAnInterface :: Bool -> Env -> XObj