Alan Zimmerman pushed to branch wip/az/ghc-cpp at Glasgow Haskell Compiler / GHC Commits: 186cff7e by Alan Zimmerman at 2025-04-27T20:16:04+01:00 Sort out expansion of no-arg macros, in a context with args And make the expansion bottom out, in the case of recursion - - - - - 4 changed files: - compiler/GHC/Parser/PreProcess/Macro.hs - testsuite/tests/ghc-cpp/GhcCpp01.hs - utils/check-cpp/Macro.hs - utils/check-cpp/Main.hs Changes: ===================================== compiler/GHC/Parser/PreProcess/Macro.hs ===================================== @@ -65,15 +65,19 @@ expand s str = expanded toks = case cppLex False str of Left err -> error $ "expand:" ++ show (err, str) Right tks -> tks - expanded = combineToks $ map t_str $ expandToks s toks + expanded = combineToks $ map t_str $ expandToks maxExpansions s toks -expandToks :: MacroDefines -> [Token] -> [Token] -expandToks s ts = +maxExpansions :: Int +maxExpansions = 15 + +expandToks :: Int -> MacroDefines -> [Token] -> [Token] +expandToks 0 _ ts = error $ "macro_expansion limit (" ++ show maxExpansions ++ ") hit, aborting. ts=" ++ show ts +expandToks cnt s ts = let - (expansionDone, r) = doExpandToks False s ts + (!expansionDone, !r) = doExpandToks False s ts in if expansionDone - then expandToks s r + then expandToks (cnt -1) s r else r doExpandToks :: Bool -> MacroDefines -> [Token] -> (Bool, [Token]) @@ -100,13 +104,14 @@ doExpandToks ed s (TIdentifier n : ts) = (ed'', expanded ++ rest) where (ed', expanded, ts') = case Map.lookup n s of Nothing -> (ed, [TIdentifier n], ts) - Just defs -> (ed0, r, rest0) + Just defs -> (ed0, r, rest1) where (args, rest0) = getExpandArgs ts - (m_args, rhs) = fromMaybe (Nothing, [TIdentifier n]) (Map.lookup (arg_arity args) defs) - (ed0, r) = case m_args of - Nothing -> (True, rhs) - Just _ -> (True, replace_args args m_args rhs) + fallbackArgs = fromMaybe (Nothing, [TIdentifier n]) (Map.lookup Nothing defs) + (m_args, rhs) = fromMaybe fallbackArgs (Map.lookup (arg_arity args) defs) + (ed0, r, rest1) = case m_args of + Nothing -> (True, rhs, ts) + Just _ -> (True, replace_args args m_args rhs, rest0) (ed'', rest) = doExpandToks ed' s ts' doExpandToks ed s (t : ts) = (ed', t : r) where ===================================== testsuite/tests/ghc-cpp/GhcCpp01.hs ===================================== @@ -33,3 +33,15 @@ complete junk! #ifdef AA aa = 1 #endif + +-- undef and rewrite base name only +#define MIN_VERSION_Cabal(a,b,c) 1 + +#ifdef MIN_VERSION_Cabal +#undef CH_MIN_VERSION_Cabal +#define CH_MIN_VERSION_Cabal MIN_VERSION_Cabal +#endif + +#if CH_MIN_VERSION_Cabal(1,22,0) +x = 1 +#endif ===================================== utils/check-cpp/Macro.hs ===================================== @@ -64,15 +64,19 @@ expand s str = expanded toks = case cppLex False str of Left err -> error $ "expand:" ++ show (err, str) Right tks -> tks - expanded = combineToks $ map t_str $ expandToks s toks + expanded = combineToks $ map t_str $ expandToks maxExpansions s toks -expandToks :: MacroDefines -> [Token] -> [Token] -expandToks s ts = +maxExpansions :: Int +maxExpansions = 15 + +expandToks :: Int -> MacroDefines -> [Token] -> [Token] +expandToks 0 _ ts = error $ "macro_expansion limit (" ++ show maxExpansions ++ ") hit, aborting. ts=" ++ show ts +expandToks cnt s ts = let - (expansionDone, r) = doExpandToks False s ts + (!expansionDone, !r) = doExpandToks False s ts in if expansionDone - then expandToks s r + then expandToks (cnt -1) s r else r doExpandToks :: Bool -> MacroDefines -> [Token] -> (Bool, [Token]) @@ -99,13 +103,14 @@ doExpandToks ed s (TIdentifier n : ts) = (ed'', expanded ++ rest) where (ed', expanded, ts') = case Map.lookup n s of Nothing -> (ed, [TIdentifier n], ts) - Just defs -> (ed0, r, rest0) + Just defs -> (ed0, r, rest1) where (args, rest0) = getExpandArgs ts - (m_args, rhs) = fromMaybe (Nothing, [TIdentifier n]) (Map.lookup (arg_arity args) defs) - (ed0, r) = case m_args of - Nothing -> (True, rhs) - Just _ -> (True, replace_args args m_args rhs) + fallbackArgs = fromMaybe (Nothing, [TIdentifier n]) (Map.lookup Nothing defs) + (m_args, rhs) = fromMaybe fallbackArgs (Map.lookup (arg_arity args) defs) + (ed0, r, rest1) = case m_args of + Nothing -> (True, rhs, ts) + Just _ -> (True, replace_args args m_args rhs, rest0) (ed'', rest) = doExpandToks ed' s ts' doExpandToks ed s (t : ts) = (ed', t : r) where ===================================== utils/check-cpp/Main.hs ===================================== @@ -820,3 +820,21 @@ t35 = do , "#endif" , "" ] + +t36 :: IO () +t36 = do + dump + [ "{-# LANGUAGE GHC_CPP #-}" + , "module Example15 where" + , "#define MIN_VERSION_Cabal(a,b,c) 1" + , "" + , "#ifdef MIN_VERSION_Cabal" + , "#undef CH_MIN_VERSION_Cabal" + , "#define CH_MIN_VERSION_Cabal MIN_VERSION_Cabal" + , "#endif" + , "" + , "#if CH_MIN_VERSION_Cabal(1,22,0)" + , "x = 1" + , "#endif" + , "" + ] View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/186cff7e2725ff7e2c58fc62e5cbe85d... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/186cff7e2725ff7e2c58fc62e5cbe85d... You're receiving this email because of your account on gitlab.haskell.org.