Handle function calls and address-of operator.

1 files changed, 86 insertions, 35 deletions

diff --git a/monkeypatch.hs b/monkeypatch.hs
index 9060c3e..beaa58f 100644
--- a/monkeypatch.hs
+++ b/monkeypatch.hs
@@ -146,31 +146,6 @@ data Computation st = Computation
     }
  deriving (Eq,Ord,Functor)
 
-{-
- CUnary CAdrOp (CVar _) LT) LT
--}
-
-grokExpression (CVar cv _) = Just Computation
-    { compFree  = Map.singleton (identToString cv) ()
-    , compIntro = Map.empty
-    , comp      = hsvar (identToString cv)
-    }
-grokExpression (CConst (CIntConst n _)) = Just Computation
-    { compFree  = Map.empty
-    , compIntro = Map.empty
-    , comp      = Lit () (Int () (getCInteger n) (show n))
-    }
-grokExpression (CBinary CNeqOp a b _) = do
-    ca <- grokExpression a
-    cb <- grokExpression b
-    return Computation
-        { compFree  = compFree ca `Map.union` compFree cb
-        , compIntro = Map.empty
-        , comp      = InfixApp () (comp ca) hsopNeq (comp cb)
-        }
-grokExpression _ = Nothing
-
-
 hsvar :: String -> HS.Exp ()
 hsvar v = Var () (UnQual () (HS.Ident () v))
 
@@ -209,12 +184,79 @@ applyComputation a b = a
 varmap :: [String] -> Map String ()
 varmap vs = Map.fromList $ map (,()) vs
 
+{-
+ CUnary CAdrOp (CVar _ _) LT) LT
+ CCall (CVar i _) exps _
+
+-}
+
+-- Returns a list of statements bringing variables into scope and an
+-- expression.
+grokExpression (CVar cv _) = Just $ (,) [] $ Computation
+    { compFree  = Map.singleton (identToString cv) ()
+    , compIntro = Map.empty
+    , comp      = hsvar (identToString cv)
+    }
+grokExpression (CConst (CIntConst n _)) = Just $ (,) [] $ Computation
+    { compFree  = Map.empty
+    , compIntro = Map.empty
+    , comp      = Lit () (Int () (getCInteger n) (show n))
+    }
+grokExpression (CBinary CNeqOp a b _) = do
+    (as,ca) <- grokExpression a
+    (bs,cb) <- grokExpression b
+    let ss = as ++ bs -- TODO: resolve variable name conflicts
+    return $ (,) ss $ Computation
+        { compFree  = compFree ca `Map.union` compFree cb
+        , compIntro = Map.empty
+        , comp      = InfixApp () (comp ca) hsopNeq (comp cb)
+        }
+grokExpression (CUnary CAdrOp (CVar cv0 _) _) = do
+    let cv = identToString cv0
+        hv = "p" ++ cv
+        k = uniqIdentifier "go" (Map.empty {-todo-})
+        ss = pure Computation
+                { compFree = Map.singleton cv ()
+                , compIntro = Map.singleton hv ()
+                , comp = Lambda () [hspvar k]
+                            $ InfixApp ()
+                                (App () (hsvar "withPointer") (hsvar cv))
+                                hsopBind
+                                (Lambda () [hspvar hv] (hsvar k))
+                }
+    return $ (,) ss Computation
+        { compFree  = Map.singleton hv ()
+        , compIntro = Map.empty
+        , comp      = hsvar hv
+        }
+grokExpression (C.CCall (CVar fn _) exps _) = do
+    gs <- mapM grokExpression exps
+    let ss = concatMap fst gs -- TODO: resolve variable name conflicts
+        hv = "r" ++ identToString fn
+        cll = foldl (App ()) (hsvar (identToString fn)) $ map (comp . snd) gs
+        frees = foldr Map.union (Map.singleton (identToString fn) ()) (map (compFree . snd) gs)
+        k = uniqIdentifier "go" frees
+        s = Computation
+                { compFree = frees
+                , compIntro = Map.singleton hv ()
+                , comp = Lambda () [hspvar k]
+                            $ InfixApp () cll hsopBind
+                            $ Lambda () [hspvar hv] (hsvar k)
+                }
+    return $ (,) (ss++[s]) Computation
+        { compFree  = Map.singleton hv ()
+        , compIntro = Map.empty
+        , comp      = hsvar hv
+        }
+grokExpression _ = Nothing
+
 
 grokStatement :: CCompoundBlockItem a -> Maybe (Computation (HS.Exp ()))
 grokStatement (CBlockStmt (CReturn (Just exp) _)) = do
-    x <- grokExpression exp
+    (xs,x) <- grokExpression exp
     let k = uniqIdentifier "go" (compFree x `Map.union` compIntro x)
-    return $ fmap (\y -> Lambda () [hspvar k] $ App () (hsvar "return") y) x
+        x' = fmap (\y -> App () (hsvar "return") y) x
+    return $ fmap (\y -> Lambda () [hspvar k] y) $ foldr applyComputation x' xs
 grokStatement (CBlockStmt (CExpr (Just
                 (CAssign CAssignOp cvarnew
                     (C.CCall cvarfun [] _) _)) _)) = do
@@ -229,21 +271,26 @@ grokStatement (CBlockStmt (CExpr (Just
             $ Lambda () [hspvar v] (hsvar k)
         }
 grokStatement (CBlockStmt (CIf exp (CCompound [] stmts _) Nothing _)) = do
-    x <- grokExpression exp
+    (xs,x) <- grokExpression exp
     ss <- sequence $ map grokStatement stmts
     let s = foldr applyComputation (Computation Map.empty Map.empty (hsvar k)) ss
         k = uniqIdentifier "go" (Map.union (compFree x) (compFree s))
-    return Computation
+    return $ flip (foldr applyComputation) xs Computation
         { compFree = compFree x `Map.union` compFree s
         , compIntro = compIntro s
         , comp = Lambda () [hspvar k] $ If () (comp x) (comp s) (hsvar k)
         }
 grokStatement (CBlockDecl (CDecl (t:_) (v:vs) _)) = do
-    return Computation
-        { compFree  = Map.empty
-        , compIntro = Map.empty
-        , comp      = Lambda () [hspvar "go"] $ hsvar "go"
-        }
+    -- case mapMaybe (\(cdeclr,_,_) -> cdeclr >>= \(CDeclr i _ initial _ _) -> initial) (v:vs) of
+    -- case mapMaybe (\(cdeclr,_,_) -> cdeclr >>= \(CInitList xs _) -> Just xs) (v:vs) of
+    case mapMaybe (\(_,inits,_) -> inits) (v:vs) of
+        [] ->
+            return Computation
+                { compFree  = Map.empty
+                , compIntro = Map.empty
+                , comp      = Lambda () [hspvar "go"] $ hsvar "go"
+                }
+        initials -> Nothing -- TODO
 grokStatement _ = Nothing
 
 isFunctionDecl (CDeclExt (CDecl _ [(Just (CDeclr _ [CFunDeclr _ _ _] _ _ _),_,_)] _)) = True
@@ -296,8 +343,12 @@ transpile o fname incs (CTranslUnit edecls _) = do
                                 forM_ bdy $ \d -> do
                                     putStrLn $ " C: " ++ show (pretty d)
                                     case grokStatement d of
-                                        Just hd -> putStrLn $ "HS: " ++ HS.prettyPrint (comp hd)
+
+                                        Just hd -> do putStrLn $ "fr: " ++ intercalate " " (Map.keys (compFree hd))
+                                                      putStrLn $ "HS: " ++ HS.prettyPrint (comp hd)
+
                                         Nothing -> putStrLn $ "??: " ++ ppShow (cleanTree d)
+                                    putStrLn ""
     return ()
 
 isHeaderDecl :: CNode a => a -> Bool