diff --git a/rtree-c/src/ReduceC.hs b/rtree-c/src/ReduceC.hs
index 576a047e8e69ff082766e71b796736a574d1694e..17713bab3ea9988bf2eb42353a8f4e1b7c9d979d 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 0000000000000000000000000000000000000000..859c0d101db9f4bb2826587e741392aaf688076c
--- /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 0000000000000000000000000000000000000000..abba1457989153894db0709662065d00132e1505
--- /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 0000000000000000000000000000000000000000..17a42d0bf12e5052e607d276639fae9c7b2d5170
--- /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 0000000000000000000000000000000000000000..58af7c0dc9b585c48cfa2206cf06da454d32af29
--- /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 0000000000000000000000000000000000000000..2b85e1cf5c8c6c27e75e3c223135e48f0e218203
--- /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 0000000000000000000000000000000000000000..16b68a36ed8cea0ba7786ab1a4885813c675f00a
--- /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 0000000000000000000000000000000000000000..10f69869f89d86a4d6db0a00edf020d57b030094
--- /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 0000000000000000000000000000000000000000..ad5f67d2ad01419908eed9958ec2af437f5f862e
--- /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 0000000000000000000000000000000000000000..0ead7bc9a7482f4b0311aa49b7583cf91f146ecd
--- /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 0000000000000000000000000000000000000000..d7824e9f3be3a4ea6f66d57feb7157e674ea4d79
--- /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 58ee219f24a54ccf2dad8c19a71317726d146fa4..891f504492a909a9d40c3f811f14271ea1477332 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