diff options
author | Joe Crayne <joe@jerkface.net> | 2019-03-19 17:46:24 -0400 |
---|---|---|
committer | Joe Crayne <joe@jerkface.net> | 2019-03-19 17:46:24 -0400 |
commit | 09233c7fa0c6c6b5a61400e06c34b062cf575901 (patch) | |
tree | 6eeae3865cc1d96c9bc295c19f184056c63c2bfa /monkeypatch.hs | |
parent | 272514b914d3cb715d09f1476e41bae731c98881 (diff) |
Implemented C comma operator.
Diffstat (limited to 'monkeypatch.hs')
-rw-r--r-- | monkeypatch.hs | 65 |
1 files 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) | |||
156 | cvarName (CVar (C.Ident n _ _) _) = Just n | 156 | cvarName (CVar (C.Ident n _ _) _) = Just n |
157 | cvarName _ = Nothing | 157 | cvarName _ = Nothing |
158 | 158 | ||
159 | hsopApp = QVarOp () (UnQual () (Symbol () "$")) | 159 | hsopUnit = HS.Con () (Special () (UnitCon ())) |
160 | |||
161 | hsopBind = QVarOp () (UnQual () (Symbol () ">>=")) | ||
162 | 160 | ||
163 | hsopSeq = QVarOp () (UnQual () (Symbol () ">>")) | ||
164 | 161 | ||
165 | hsopNeq = QVarOp () (UnQual () (Symbol () "/=")) | 162 | infixOp x op y = InfixApp () x (QVarOp () (UnQual () (Symbol () op))) y |
166 | |||
167 | hsopUnit = HS.Con () (Special () (UnitCon ())) | ||
168 | 163 | ||
164 | infixFn x fn y = InfixApp () x (QVarOp () (UnQual () (HS.Ident () fn))) y | ||
169 | 165 | ||
170 | 166 | ||
171 | 167 | ||
@@ -212,7 +208,7 @@ grokExpression (CBinary CNeqOp a b _) = do | |||
212 | return $ (,) ss $ Computation | 208 | return $ (,) ss $ Computation |
213 | { compFree = compFree ca `Map.union` compFree cb | 209 | { compFree = compFree ca `Map.union` compFree cb |
214 | , compIntro = Map.empty | 210 | , compIntro = Map.empty |
215 | , comp = InfixApp () (comp ca) hsopNeq (comp cb) | 211 | , comp = infixOp (comp ca) "/=" (comp cb) |
216 | } | 212 | } |
217 | grokExpression (CUnary CAdrOp (CVar cv0 _) _) = do | 213 | grokExpression (CUnary CAdrOp (CVar cv0 _) _) = do |
218 | let cv = identToString cv0 | 214 | let cv = identToString cv0 |
@@ -222,10 +218,9 @@ grokExpression (CUnary CAdrOp (CVar cv0 _) _) = do | |||
222 | { compFree = Map.singleton cv () | 218 | { compFree = Map.singleton cv () |
223 | , compIntro = Map.singleton hv () | 219 | , compIntro = Map.singleton hv () |
224 | , comp = Lambda () [hspvar k] | 220 | , comp = Lambda () [hspvar k] |
225 | $ InfixApp () | 221 | $ infixFn (hsvar cv) |
226 | (hsvar cv) | 222 | "withPointer" |
227 | (QVarOp () (UnQual () (HS.Ident () "withPointer"))) | 223 | (Lambda () [hspvar hv] (hsvar k)) |
228 | (Lambda () [hspvar hv] (hsvar k)) | ||
229 | } | 224 | } |
230 | return $ (,) ss Computation | 225 | return $ (,) ss Computation |
231 | { compFree = Map.singleton hv () | 226 | { compFree = Map.singleton hv () |
@@ -241,6 +236,10 @@ grokExpression (CCond cond (Just thn) els _) = do | |||
241 | return $ (,) cs $ fmap (\cnd -> If () cnd (comp tt) (comp ee)) c | 236 | return $ (,) cs $ fmap (\cnd -> If () cnd (comp tt) (comp ee)) c |
242 | { compFree = compFree ee `Map.union` compFree tt `Map.union` compFree c | 237 | { compFree = compFree ee `Map.union` compFree tt `Map.union` compFree c |
243 | } | 238 | } |
239 | grokExpression (CSizeofExpr expr _) = do | ||
240 | (xs,x) <- grokExpression expr | ||
241 | return $ (,) xs $ fmap (App () (hsvar "sizeOf")) x | ||
242 | grokExpression (CCast (CDecl [CTypeSpec (CVoidType _)] [] _) expr _) = grokExpression expr | ||
244 | grokExpression (CCast (CDecl [ CTypeSpec (CVoidType _) ] | 243 | grokExpression (CCast (CDecl [ CTypeSpec (CVoidType _) ] |
245 | [ ( Just (CDeclr Nothing [ CPtrDeclr [] _ ] Nothing [] _) , Nothing , Nothing) ] | 244 | [ ( Just (CDeclr Nothing [ CPtrDeclr [] _ ] Nothing [] _) , Nothing , Nothing) ] |
246 | _) | 245 | _) |
@@ -250,6 +249,17 @@ grokExpression (CCast (CDecl [ CTypeSpec (CVoidType _) ] | |||
250 | , compIntro = Map.empty | 249 | , compIntro = Map.empty |
251 | , comp = hsvar "nullPtr" | 250 | , comp = hsvar "nullPtr" |
252 | } | 251 | } |
252 | grokExpression (CComma exps _) = do | ||
253 | gs <- mapM grokExpression exps | ||
254 | let ss = concatMap fst gs -- TODO: resolve variable name conflicts | ||
255 | cll = foldr1 (\x y -> infixFn x "seq" y) $ map (comp . snd) gs | ||
256 | frees = foldr1 Map.union (map (compFree . snd) gs) | ||
257 | k = uniqIdentifier "go" frees | ||
258 | return $ (,) ss Computation | ||
259 | { compFree = frees | ||
260 | , compIntro = Map.empty | ||
261 | , comp = cll | ||
262 | } | ||
253 | grokExpression (C.CCall (CVar fn _) exps _) = do | 263 | grokExpression (C.CCall (CVar fn _) exps _) = do |
254 | gs <- mapM grokExpression exps | 264 | gs <- mapM grokExpression exps |
255 | let ss = concatMap fst gs -- TODO: resolve variable name conflicts | 265 | let ss = concatMap fst gs -- TODO: resolve variable name conflicts |
@@ -261,8 +271,8 @@ grokExpression (C.CCall (CVar fn _) exps _) = do | |||
261 | { compFree = frees | 271 | { compFree = frees |
262 | , compIntro = Map.singleton hv () | 272 | , compIntro = Map.singleton hv () |
263 | , comp = Lambda () [hspvar k] | 273 | , comp = Lambda () [hspvar k] |
264 | $ InfixApp () cll hsopBind | 274 | $ infixOp cll ">>=" |
265 | $ Lambda () [hspvar hv] (hsvar k) | 275 | $ Lambda () [hspvar hv] (hsvar k) |
266 | } | 276 | } |
267 | return $ (,) (ss++[s]) Computation | 277 | return $ (,) (ss++[s]) Computation |
268 | { compFree = Map.singleton hv () | 278 | { compFree = Map.singleton hv () |
@@ -277,7 +287,7 @@ grokInitialization _ (Just (CDeclr (Just cv0) _ _ _ _),CInitExpr exp _) = do | |||
277 | (xs,x) <- grokExpression exp | 287 | (xs,x) <- grokExpression exp |
278 | let hsexp = fmap (App () (hsvar "return")) x -- Paren () ( | 288 | let hsexp = fmap (App () (hsvar "return")) x -- Paren () ( |
279 | ret = flip (foldr applyComputation) xs $ | 289 | ret = flip (foldr applyComputation) xs $ |
280 | fmap (\exp -> InfixApp () exp hsopBind | 290 | fmap (\exp -> infixOp exp ">>=" |
281 | $ Lambda () [hspvar v] (hsvar k)) hsexp | 291 | $ Lambda () [hspvar v] (hsvar k)) hsexp |
282 | k = uniqIdentifier "go" (compFree ret) | 292 | k = uniqIdentifier "go" (compFree ret) |
283 | return $ fmap (\exp -> Lambda () [hspvar k] exp) ret | 293 | return $ fmap (\exp -> Lambda () [hspvar k] exp) ret |
@@ -304,23 +314,19 @@ grokInitialization ts (Just (CDeclr (Just cv0) _ _ _ _),CInitList exps _) = do | |||
304 | fieldlbl = identToString m | 314 | fieldlbl = identToString m |
305 | return x | 315 | return x |
306 | { comp = Lambda () [hspvar k1] | 316 | { comp = Lambda () [hspvar k1] |
307 | $ InfixApp () | 317 | $ infixOp |
308 | (App () | 318 | (App () (App () (App () (hsvar "set") |
309 | (App () | 319 | (TypeApp () (TyPromoted () (PromotedString () fieldlbl fieldlbl)))) |
310 | (App () | 320 | (hsvar v)) |
311 | (hsvar "set") | 321 | fieldinit) ">>" (hsvar k1) |
312 | (TypeApp | ||
313 | () (TyPromoted () (PromotedString () fieldlbl fieldlbl)))) | ||
314 | (hsvar v)) | ||
315 | fieldinit) hsopSeq (hsvar k1) | ||
316 | } | 322 | } |
317 | return $ fmap (\exp -> Lambda () [hspvar k2] exp) ret | 323 | return $ fmap (\exp -> Lambda () [hspvar k2] exp) ret |
318 | let newstruct = Computation | 324 | let newstruct = Computation |
319 | { compFree = Map.empty -- todo | 325 | { compFree = Map.empty -- todo |
320 | , compIntro = Map.singleton v () | 326 | , compIntro = Map.singleton v () |
321 | , comp = Lambda () [hspvar k] | 327 | , comp = Lambda () [hspvar k] |
322 | $ InfixApp () (App () (hsvar "newStruct") (TypeApp () (TyCon () (UnQual () hident)))) hsopBind | 328 | $ infixOp (App () (hsvar "newStruct") (TypeApp () (TyCon () (UnQual () hident)))) ">>=" |
323 | $ Lambda () [hspvar v] (hsvar k) | 329 | $ Lambda () [hspvar v] (hsvar k) |
324 | } | 330 | } |
325 | k = uniqIdentifier "go" Map.empty -- (compFree ret) TODO | 331 | k = uniqIdentifier "go" Map.empty -- (compFree ret) TODO |
326 | ret = foldr applyComputation (Computation Map.empty Map.empty (hsvar k)) $ newstruct : assigns | 332 | ret = foldr applyComputation (Computation Map.empty Map.empty (hsvar k)) $ newstruct : assigns |
@@ -345,8 +351,8 @@ grokStatement (CBlockStmt (CExpr (Just | |||
345 | { compFree = Map.singleton fn () | 351 | { compFree = Map.singleton fn () |
346 | , compIntro = Map.singleton v () | 352 | , compIntro = Map.singleton v () |
347 | , comp = Lambda () [hspvar k] | 353 | , comp = Lambda () [hspvar k] |
348 | $ InfixApp () (hsvar fn) hsopBind | 354 | $ infixOp (hsvar fn) ">>=" |
349 | $ Lambda () [hspvar v] (hsvar k) | 355 | $ Lambda () [hspvar v] (hsvar k) |
350 | } | 356 | } |
351 | grokStatement (CBlockStmt (CIf exp (CCompound [] stmts _) Nothing _)) = do | 357 | grokStatement (CBlockStmt (CIf exp (CCompound [] stmts _) Nothing _)) = do |
352 | (xs,x) <- grokExpression exp | 358 | (xs,x) <- grokExpression exp |
@@ -358,6 +364,9 @@ grokStatement (CBlockStmt (CIf exp (CCompound [] stmts _) Nothing _)) = do | |||
358 | , compIntro = compIntro s | 364 | , compIntro = compIntro s |
359 | , comp = Lambda () [hspvar k] $ If () (comp x) (comp s) (hsvar k) | 365 | , comp = Lambda () [hspvar k] $ If () (comp x) (comp s) (hsvar k) |
360 | } | 366 | } |
367 | -- TODO CStatExpr | ||
368 | -- TODO (CBlockStmt (CExpr Nothing _) -- semicolon | ||
369 | -- TODO (CBlockStmt (CExpr (Just (CComma exs _) _) _)) | ||
361 | grokStatement (CBlockDecl (CDecl (t:ts) (v:vs) _)) = do | 370 | grokStatement (CBlockDecl (CDecl (t:ts) (v:vs) _)) = do |
362 | -- case mapMaybe (\(cdeclr,_,_) -> cdeclr >>= \(CDeclr i _ initial _ _) -> initial) (v:vs) of | 371 | -- case mapMaybe (\(cdeclr,_,_) -> cdeclr >>= \(CDeclr i _ initial _ _) -> initial) (v:vs) of |
363 | -- case mapMaybe (\(cdeclr,_,_) -> cdeclr >>= \(CInitList xs _) -> Just xs) (v:vs) of | 372 | -- case mapMaybe (\(cdeclr,_,_) -> cdeclr >>= \(CInitList xs _) -> Just xs) (v:vs) of |