From 2fcf80b356506a63af11b869dfec452bd745f02a Mon Sep 17 00:00:00 2001
From: Christian Gram Kalhauge <chrg@dtu.dk>
Date: Mon, 24 Mar 2025 09:32:06 +0100
Subject: [PATCH] Try to support OldFunctions
---
rtree-c/src/ReduceC.hs | 71 +++++++++++--------
rtree-c/test/cases/small/oldfun.c | 7 ++
rtree-c/test/expected/oldfun/main.c | 8 +++
.../test/expected/oldfun/reduction/r0000.c | 13 ++++
.../test/expected/oldfun/reduction/r0001.c | 12 ++++
.../test/expected/oldfun/reduction/r0010.c | 12 ++++
.../test/expected/oldfun/reduction/r0011.c | 11 +++
rtree-c/test/expected/oldfun/reduction/r010.c | 11 +++
rtree-c/test/expected/oldfun/reduction/r011.c | 10 +++
rtree-c/test/expected/oldfun/reduction/r10.c | 7 ++
rtree-c/test/expected/oldfun/reduction/r11.c | 6 ++
rtree-c/test/src/ReduceCSpec.hs | 7 +-
12 files changed, 143 insertions(+), 32 deletions(-)
create mode 100644 rtree-c/test/cases/small/oldfun.c
create mode 100644 rtree-c/test/expected/oldfun/main.c
create mode 100644 rtree-c/test/expected/oldfun/reduction/r0000.c
create mode 100644 rtree-c/test/expected/oldfun/reduction/r0001.c
create mode 100644 rtree-c/test/expected/oldfun/reduction/r0010.c
create mode 100644 rtree-c/test/expected/oldfun/reduction/r0011.c
create mode 100644 rtree-c/test/expected/oldfun/reduction/r010.c
create mode 100644 rtree-c/test/expected/oldfun/reduction/r011.c
create mode 100644 rtree-c/test/expected/oldfun/reduction/r10.c
create mode 100644 rtree-c/test/expected/oldfun/reduction/r11.c
diff --git a/rtree-c/src/ReduceC.hs b/rtree-c/src/ReduceC.hs
index 576a047..17713ba 100644
--- a/rtree-c/src/ReduceC.hs
+++ b/rtree-c/src/ReduceC.hs
@@ -84,7 +84,7 @@ defaultReduceC a = reduceCTranslUnit a defaultContext
{-# SPECIALIZE defaultReduceC :: C.CTranslUnit -> IRTree.IRTree (String, C.Position) C.CTranslUnit #-}
reduceCTranslUnit ::
- (MonadReduce Lab m) =>
+ (MonadReduce Lab m, HasCallStack) =>
C.CTranslationUnit C.NodeInfo ->
Context ->
m (C.CTranslationUnit C.NodeInfo)
@@ -233,6 +233,7 @@ updateCDeclarationSpecifiers sf ctx spec = do
_ow -> Just $ pure [a]
filterStruct ::
+ (HasCallStack) =>
[(a1, Maybe a2)] ->
[C.CDeclaration C.NodeInfo] ->
m [C.CDeclaration C.NodeInfo]
@@ -334,25 +335,24 @@ typeFromCDeclarationSpecifiers ctx =
applyDD = \case
C.CPtrDeclr _ _ -> fmap (NonVoid . TPointer)
C.CArrDeclr{} -> fmap (NonVoid . TPointer)
- C.CFunDeclr params _ ni -> \c ->
- case params of
- C.CFunParamsNew params' varadic -> do
- c' <- c
- Just $ NonVoid $ TFun (FunType c' (findParams varadic params'))
- b -> notSupportedYet b ni
-
- findParams varadic = \case
- [C.CDecl [C.CTypeSpec (C.CVoidType _)] [] _] -> VoidParams
- rst -> flip Params varadic $ flip map rst \case
+ C.CFunDeclr params _ _ -> \c -> do
+ c' <- c
+ Just . NonVoid . TFun . FunType c' $ findParams params
+
+ findParams = \case
+ C.CFunParamsNew [C.CDecl [C.CTypeSpec (C.CVoidType _)] [] _] _ -> VoidParams
+ C.CFunParamsNew rst varadic -> flip Params varadic $ flip map rst \case
C.CDecl spec' [] _ ->
nonVoid <$> typeFromCDeclarationSpecifiers ctx spec'
C.CDecl spec' [C.CDeclarationItem decl _ _] _ ->
nonVoid <$> typeOf spec' decl
a -> notSupportedYet' a
+ C.CFunParamsOld ids -> Params [Just TNum | _ <- ids] False
typeFromCDerivedDeclarators ::
forall m.
( MonadPlus m
+ , HasCallStack
) =>
Voidable ->
Context ->
@@ -371,13 +371,15 @@ typeFromCDerivedDeclarators bt ctx dd =
pure (NonVoid . TPointer $ t)
C.CArrDeclr{} -> do
pure (NonVoid . TPointer $ t)
- C.CFunDeclr params _ ni -> do
+ C.CFunDeclr params _ _ -> do
case params of
C.CFunParamsNew params' varadic -> do
tp <- findParams varadic params'
let t' = NonVoid $ TFun (FunType t tp)
pure t'
- b -> notSupportedYet b ni
+ C.CFunParamsOld params' -> do
+ let t' = NonVoid $ TFun (FunType t (Params [Just TNum | _ <- params'] False))
+ pure t'
findParams ::
Bool ->
@@ -405,6 +407,7 @@ updateCDerivedDeclarators ::
forall m.
( MonadState Context m
, MonadReduce (String, C.Position) m
+ , HasCallStack
) =>
Voidable ->
[Bool] ->
@@ -430,21 +433,29 @@ updateCDerivedDeclarators bt ff dd = do
_ -> pure d
pure (NonVoid . TPointer $ t, d' : dd')
C.CFunDeclr params arr ni -> do
- case params of
- C.CFunParamsNew params' varadic -> do
- (tp, params'') <- findParams varadic params'
- let t' = NonVoid $ TFun (FunType t tp)
- pure (t', C.CFunDeclr (C.CFunParamsNew params'' varadic) arr ni : dd')
- b -> notSupportedYet b ni
+ (tp, params'') <- findParams params
+ let t' = NonVoid $ TFun (FunType t tp)
+ pure (t', C.CFunDeclr params'' arr ni : dd')
findParams ::
- Bool ->
- [C.CDeclaration C.NodeInfo] ->
- m (Params, [C.CDeclaration C.NodeInfo])
- findParams varadic decls = case decls of
- [C.CDecl [C.CTypeSpec (C.CVoidType _)] [] _] ->
- pure (VoidParams, decls)
- _ow -> flip evalStateT ff do
+ C.CFunParams C.NodeInfo ->
+ m (Params, C.CFunParams C.NodeInfo)
+ findParams fp = case fp of
+ C.CFunParamsOld ids -> do
+ (tp, ids') <-
+ unzip <$> forM (zip ff ids) \(keep, i) -> do
+ if keep
+ then do
+ modify' (addInlineExpr i (IEKeep TNum))
+ pure (Just TNum, [i])
+ else do
+ modify' (addInlineExpr i IEDelete)
+ pure (Nothing, [])
+
+ pure (Params tp False, C.CFunParamsOld (concat ids'))
+ C.CFunParamsNew [C.CDecl [C.CTypeSpec (C.CVoidType _)] [] _] _ ->
+ pure (VoidParams, fp)
+ C.CFunParamsNew decls varadic -> flip evalStateT ff do
result <-
forM decls $ \case
C.CDecl spec items ni -> do
@@ -475,7 +486,7 @@ updateCDerivedDeclarators bt ff dd = do
let (ts, decls') = unzip $ flip map result \case
Just (t, d') -> (Just t, [d'])
Nothing -> (Nothing, [])
- pure (Params ts varadic, concat decls')
+ pure (Params ts varadic, C.CFunParamsNew (concat decls') varadic)
joinLiftMaybe :: (MonadPlus m) => Maybe (m a) -> m a
joinLiftMaybe = join . liftMaybe
@@ -1158,7 +1169,7 @@ msplit ctx l m1 m2
Nothing -> m2
{-# INLINE msplit #-}
-inferType :: Context -> C.CExpr -> Maybe Voidable
+inferType :: (HasCallStack) => Context -> C.CExpr -> Maybe Voidable
inferType ctx = \case
C.CVar i _ -> do
case lookupVariable ctx i of
@@ -1551,7 +1562,7 @@ data Function = Function
deriving (Show, Eq)
findFunctions ::
- (Monoid m) =>
+ (Monoid m, HasCallStack) =>
(Function -> m) ->
C.CExternalDeclaration C.NodeInfo ->
m
@@ -1584,7 +1595,7 @@ findFunctions inject = \case
_
| var -> Nothing
| otherwise -> Just [True | _ <- declr]
- a -> notSupportedYet (void a) ni
+ C.CFunParamsOld idents -> Just [True | _ <- idents]
Nothing -> mempty
_ow -> mempty
diff --git a/rtree-c/test/cases/small/oldfun.c b/rtree-c/test/cases/small/oldfun.c
new file mode 100644
index 0000000..859c0d1
--- /dev/null
+++ b/rtree-c/test/cases/small/oldfun.c
@@ -0,0 +1,7 @@
+int fun(a) {
+ return a;
+}
+
+int main() {
+ return;
+}
diff --git a/rtree-c/test/expected/oldfun/main.c b/rtree-c/test/expected/oldfun/main.c
new file mode 100644
index 0000000..abba145
--- /dev/null
+++ b/rtree-c/test/expected/oldfun/main.c
@@ -0,0 +1,8 @@
+int fun(a)
+{
+ return a;
+}
+int main()
+{
+ return;
+}
diff --git a/rtree-c/test/expected/oldfun/reduction/r0000.c b/rtree-c/test/expected/oldfun/reduction/r0000.c
new file mode 100644
index 0000000..17a42d0
--- /dev/null
+++ b/rtree-c/test/expected/oldfun/reduction/r0000.c
@@ -0,0 +1,13 @@
+// 0 remove function fun (26) at ("test/cases/small/oldfun.c": line 1)
+// 0 remove parameter 1 from fun at ("test/cases/small/oldfun.c": line 1)
+// 0 remove return statement at ("test/cases/small/oldfun.c": line 2)
+// 0 remove return statement at ("test/cases/small/oldfun.c": line 6)
+
+int fun(a)
+{
+ return a;
+}
+int main()
+{
+ return;
+}
diff --git a/rtree-c/test/expected/oldfun/reduction/r0001.c b/rtree-c/test/expected/oldfun/reduction/r0001.c
new file mode 100644
index 0000000..58af7c0
--- /dev/null
+++ b/rtree-c/test/expected/oldfun/reduction/r0001.c
@@ -0,0 +1,12 @@
+// 0 remove function fun (26) at ("test/cases/small/oldfun.c": line 1)
+// 0 remove parameter 1 from fun at ("test/cases/small/oldfun.c": line 1)
+// 0 remove return statement at ("test/cases/small/oldfun.c": line 2)
+// 1 remove return statement at ("test/cases/small/oldfun.c": line 6)
+
+int fun(a)
+{
+ return a;
+}
+int main()
+{
+}
diff --git a/rtree-c/test/expected/oldfun/reduction/r0010.c b/rtree-c/test/expected/oldfun/reduction/r0010.c
new file mode 100644
index 0000000..2b85e1c
--- /dev/null
+++ b/rtree-c/test/expected/oldfun/reduction/r0010.c
@@ -0,0 +1,12 @@
+// 0 remove function fun (26) at ("test/cases/small/oldfun.c": line 1)
+// 0 remove parameter 1 from fun at ("test/cases/small/oldfun.c": line 1)
+// 1 remove return statement at ("test/cases/small/oldfun.c": line 2)
+// 0 remove return statement at ("test/cases/small/oldfun.c": line 6)
+
+int fun(a)
+{
+}
+int main()
+{
+ return;
+}
diff --git a/rtree-c/test/expected/oldfun/reduction/r0011.c b/rtree-c/test/expected/oldfun/reduction/r0011.c
new file mode 100644
index 0000000..16b68a3
--- /dev/null
+++ b/rtree-c/test/expected/oldfun/reduction/r0011.c
@@ -0,0 +1,11 @@
+// 0 remove function fun (26) at ("test/cases/small/oldfun.c": line 1)
+// 0 remove parameter 1 from fun at ("test/cases/small/oldfun.c": line 1)
+// 1 remove return statement at ("test/cases/small/oldfun.c": line 2)
+// 1 remove return statement at ("test/cases/small/oldfun.c": line 6)
+
+int fun(a)
+{
+}
+int main()
+{
+}
diff --git a/rtree-c/test/expected/oldfun/reduction/r010.c b/rtree-c/test/expected/oldfun/reduction/r010.c
new file mode 100644
index 0000000..10f6986
--- /dev/null
+++ b/rtree-c/test/expected/oldfun/reduction/r010.c
@@ -0,0 +1,11 @@
+// 0 remove function fun (26) at ("test/cases/small/oldfun.c": line 1)
+// 1 remove parameter 1 from fun at ("test/cases/small/oldfun.c": line 1)
+// 0 remove return statement at ("test/cases/small/oldfun.c": line 6)
+
+int fun()
+{
+}
+int main()
+{
+ return;
+}
diff --git a/rtree-c/test/expected/oldfun/reduction/r011.c b/rtree-c/test/expected/oldfun/reduction/r011.c
new file mode 100644
index 0000000..ad5f67d
--- /dev/null
+++ b/rtree-c/test/expected/oldfun/reduction/r011.c
@@ -0,0 +1,10 @@
+// 0 remove function fun (26) at ("test/cases/small/oldfun.c": line 1)
+// 1 remove parameter 1 from fun at ("test/cases/small/oldfun.c": line 1)
+// 1 remove return statement at ("test/cases/small/oldfun.c": line 6)
+
+int fun()
+{
+}
+int main()
+{
+}
diff --git a/rtree-c/test/expected/oldfun/reduction/r10.c b/rtree-c/test/expected/oldfun/reduction/r10.c
new file mode 100644
index 0000000..0ead7bc
--- /dev/null
+++ b/rtree-c/test/expected/oldfun/reduction/r10.c
@@ -0,0 +1,7 @@
+// 1 remove function fun (26) at ("test/cases/small/oldfun.c": line 1)
+// 0 remove return statement at ("test/cases/small/oldfun.c": line 6)
+
+int main()
+{
+ return;
+}
diff --git a/rtree-c/test/expected/oldfun/reduction/r11.c b/rtree-c/test/expected/oldfun/reduction/r11.c
new file mode 100644
index 0000000..d7824e9
--- /dev/null
+++ b/rtree-c/test/expected/oldfun/reduction/r11.c
@@ -0,0 +1,6 @@
+// 1 remove function fun (26) at ("test/cases/small/oldfun.c": line 1)
+// 1 remove return statement at ("test/cases/small/oldfun.c": line 6)
+
+int main()
+{
+}
diff --git a/rtree-c/test/src/ReduceCSpec.hs b/rtree-c/test/src/ReduceCSpec.hs
index 58ee219..891f504 100644
--- a/rtree-c/test/src/ReduceCSpec.hs
+++ b/rtree-c/test/src/ReduceCSpec.hs
@@ -132,6 +132,9 @@ validate fp = do
, "-Wno-error=unused-value"
, "-Wno-error=return-type"
, "-Wno-error=incompatible-library-redeclaration"
+ , "-Wno-error=implicit-int"
+ , "-Wno-error=deprecated-non-prototype"
+ , "-std=gnu89"
, "-o"
, "/dev/null"
, fp
@@ -154,11 +157,11 @@ validate fp = do
simplevalidate :: FilePath -> IO ()
simplevalidate fp = do
(ec, _, stderr_) <-
- readProcess (proc "clang" ["-o", "/dev/null", fp])
+ readProcess (proc "clang" ["-std=gnu89", "-o", "/dev/null", fp])
case ec of
ExitFailure _ ->
expectationFailure $
- "could not validate "
+ "could not simple validate "
<> show fp
<> "\n"
<> ( LazyText.unpack
--
GitLab