From 09233c7fa0c6c6b5a61400e06c34b062cf575901 Mon Sep 17 00:00:00 2001 From: Joe Crayne Date: Tue, 19 Mar 2019 17:46:24 -0400 Subject: Implemented C comma operator. --- monkeypatch.hs | 65 +++++++++++++++++++++++++++++++++------------------------- 1 file changed, 37 insertions(+), 28 deletions(-) diff --git a/monkeypatch.hs b/monkeypatch.hs index a835e86..3b78c9f 100644 --- a/monkeypatch.hs +++ b/monkeypatch.hs @@ -156,16 +156,12 @@ hspvar v = PVar () (HS.Ident () v) cvarName (CVar (C.Ident n _ _) _) = Just n cvarName _ = Nothing -hsopApp = QVarOp () (UnQual () (Symbol () "$")) - -hsopBind = QVarOp () (UnQual () (Symbol () ">>=")) +hsopUnit = HS.Con () (Special () (UnitCon ())) -hsopSeq = QVarOp () (UnQual () (Symbol () ">>")) -hsopNeq = QVarOp () (UnQual () (Symbol () "/=")) - -hsopUnit = HS.Con () (Special () (UnitCon ())) +infixOp x op y = InfixApp () x (QVarOp () (UnQual () (Symbol () op))) y +infixFn x fn y = InfixApp () x (QVarOp () (UnQual () (HS.Ident () fn))) y @@ -212,7 +208,7 @@ grokExpression (CBinary CNeqOp a b _) = do return $ (,) ss $ Computation { compFree = compFree ca `Map.union` compFree cb , compIntro = Map.empty - , comp = InfixApp () (comp ca) hsopNeq (comp cb) + , comp = infixOp (comp ca) "/=" (comp cb) } grokExpression (CUnary CAdrOp (CVar cv0 _) _) = do let cv = identToString cv0 @@ -222,10 +218,9 @@ grokExpression (CUnary CAdrOp (CVar cv0 _) _) = do { compFree = Map.singleton cv () , compIntro = Map.singleton hv () , comp = Lambda () [hspvar k] - $ InfixApp () - (hsvar cv) - (QVarOp () (UnQual () (HS.Ident () "withPointer"))) - (Lambda () [hspvar hv] (hsvar k)) + $ infixFn (hsvar cv) + "withPointer" + (Lambda () [hspvar hv] (hsvar k)) } return $ (,) ss Computation { compFree = Map.singleton hv () @@ -241,6 +236,10 @@ grokExpression (CCond cond (Just thn) els _) = do return $ (,) cs $ fmap (\cnd -> If () cnd (comp tt) (comp ee)) c { compFree = compFree ee `Map.union` compFree tt `Map.union` compFree c } +grokExpression (CSizeofExpr expr _) = do + (xs,x) <- grokExpression expr + return $ (,) xs $ fmap (App () (hsvar "sizeOf")) x +grokExpression (CCast (CDecl [CTypeSpec (CVoidType _)] [] _) expr _) = grokExpression expr grokExpression (CCast (CDecl [ CTypeSpec (CVoidType _) ] [ ( Just (CDeclr Nothing [ CPtrDeclr [] _ ] Nothing [] _) , Nothing , Nothing) ] _) @@ -250,6 +249,17 @@ grokExpression (CCast (CDecl [ CTypeSpec (CVoidType _) ] , compIntro = Map.empty , comp = hsvar "nullPtr" } +grokExpression (CComma exps _) = do + gs <- mapM grokExpression exps + let ss = concatMap fst gs -- TODO: resolve variable name conflicts + cll = foldr1 (\x y -> infixFn x "seq" y) $ map (comp . snd) gs + frees = foldr1 Map.union (map (compFree . snd) gs) + k = uniqIdentifier "go" frees + return $ (,) ss Computation + { compFree = frees + , compIntro = Map.empty + , comp = cll + } grokExpression (C.CCall (CVar fn _) exps _) = do gs <- mapM grokExpression exps let ss = concatMap fst gs -- TODO: resolve variable name conflicts @@ -261,8 +271,8 @@ grokExpression (C.CCall (CVar fn _) exps _) = do { compFree = frees , compIntro = Map.singleton hv () , comp = Lambda () [hspvar k] - $ InfixApp () cll hsopBind - $ Lambda () [hspvar hv] (hsvar k) + $ infixOp cll ">>=" + $ Lambda () [hspvar hv] (hsvar k) } return $ (,) (ss++[s]) Computation { compFree = Map.singleton hv () @@ -277,7 +287,7 @@ grokInitialization _ (Just (CDeclr (Just cv0) _ _ _ _),CInitExpr exp _) = do (xs,x) <- grokExpression exp let hsexp = fmap (App () (hsvar "return")) x -- Paren () ( ret = flip (foldr applyComputation) xs $ - fmap (\exp -> InfixApp () exp hsopBind + fmap (\exp -> infixOp exp ">>=" $ Lambda () [hspvar v] (hsvar k)) hsexp k = uniqIdentifier "go" (compFree ret) return $ fmap (\exp -> Lambda () [hspvar k] exp) ret @@ -304,23 +314,19 @@ grokInitialization ts (Just (CDeclr (Just cv0) _ _ _ _),CInitList exps _) = do fieldlbl = identToString m return x { comp = Lambda () [hspvar k1] - $ InfixApp () - (App () - (App () - (App () - (hsvar "set") - (TypeApp - () (TyPromoted () (PromotedString () fieldlbl fieldlbl)))) - (hsvar v)) - fieldinit) hsopSeq (hsvar k1) + $ infixOp + (App () (App () (App () (hsvar "set") + (TypeApp () (TyPromoted () (PromotedString () fieldlbl fieldlbl)))) + (hsvar v)) + fieldinit) ">>" (hsvar k1) } return $ fmap (\exp -> Lambda () [hspvar k2] exp) ret let newstruct = Computation { compFree = Map.empty -- todo , compIntro = Map.singleton v () , comp = Lambda () [hspvar k] - $ InfixApp () (App () (hsvar "newStruct") (TypeApp () (TyCon () (UnQual () hident)))) hsopBind - $ Lambda () [hspvar v] (hsvar k) + $ infixOp (App () (hsvar "newStruct") (TypeApp () (TyCon () (UnQual () hident)))) ">>=" + $ Lambda () [hspvar v] (hsvar k) } k = uniqIdentifier "go" Map.empty -- (compFree ret) TODO ret = foldr applyComputation (Computation Map.empty Map.empty (hsvar k)) $ newstruct : assigns @@ -345,8 +351,8 @@ grokStatement (CBlockStmt (CExpr (Just { compFree = Map.singleton fn () , compIntro = Map.singleton v () , comp = Lambda () [hspvar k] - $ InfixApp () (hsvar fn) hsopBind - $ Lambda () [hspvar v] (hsvar k) + $ infixOp (hsvar fn) ">>=" + $ Lambda () [hspvar v] (hsvar k) } grokStatement (CBlockStmt (CIf exp (CCompound [] stmts _) Nothing _)) = do (xs,x) <- grokExpression exp @@ -358,6 +364,9 @@ grokStatement (CBlockStmt (CIf exp (CCompound [] stmts _) Nothing _)) = do , compIntro = compIntro s , comp = Lambda () [hspvar k] $ If () (comp x) (comp s) (hsvar k) } +-- TODO CStatExpr +-- TODO (CBlockStmt (CExpr Nothing _) -- semicolon +-- TODO (CBlockStmt (CExpr (Just (CComma exs _) _) _)) grokStatement (CBlockDecl (CDecl (t:ts) (v:vs) _)) = do -- case mapMaybe (\(cdeclr,_,_) -> cdeclr >>= \(CDeclr i _ initial _ _) -> initial) (v:vs) of -- case mapMaybe (\(cdeclr,_,_) -> cdeclr >>= \(CInitList xs _) -> Just xs) (v:vs) of -- cgit v1.2.3