From d7c3ede006e7a767bf5906e908d40caaa2951d4b Mon Sep 17 00:00:00 2001 From: Joe Crayne Date: Mon, 18 Mar 2019 17:28:38 -0400 Subject: Handle function calls and address-of operator. --- monkeypatch.hs | 121 ++++++++++++++++++++++++++++++++++++++++----------------- 1 file 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 -- cgit v1.2.3