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
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:
| ... | ... | @@ -65,15 +65,19 @@ expand s str = expanded |
| 65 | 65 | toks = case cppLex False str of
|
| 66 | 66 | Left err -> error $ "expand:" ++ show (err, str)
|
| 67 | 67 | Right tks -> tks
|
| 68 | - expanded = combineToks $ map t_str $ expandToks s toks
|
|
| 68 | + expanded = combineToks $ map t_str $ expandToks maxExpansions s toks
|
|
| 69 | 69 | |
| 70 | -expandToks :: MacroDefines -> [Token] -> [Token]
|
|
| 71 | -expandToks s ts =
|
|
| 70 | +maxExpansions :: Int
|
|
| 71 | +maxExpansions = 15
|
|
| 72 | + |
|
| 73 | +expandToks :: Int -> MacroDefines -> [Token] -> [Token]
|
|
| 74 | +expandToks 0 _ ts = error $ "macro_expansion limit (" ++ show maxExpansions ++ ") hit, aborting. ts=" ++ show ts
|
|
| 75 | +expandToks cnt s ts =
|
|
| 72 | 76 | let
|
| 73 | - (expansionDone, r) = doExpandToks False s ts
|
|
| 77 | + (!expansionDone, !r) = doExpandToks False s ts
|
|
| 74 | 78 | in
|
| 75 | 79 | if expansionDone
|
| 76 | - then expandToks s r
|
|
| 80 | + then expandToks (cnt -1) s r
|
|
| 77 | 81 | else r
|
| 78 | 82 | |
| 79 | 83 | doExpandToks :: Bool -> MacroDefines -> [Token] -> (Bool, [Token])
|
| ... | ... | @@ -100,13 +104,14 @@ doExpandToks ed s (TIdentifier n : ts) = (ed'', expanded ++ rest) |
| 100 | 104 | where
|
| 101 | 105 | (ed', expanded, ts') = case Map.lookup n s of
|
| 102 | 106 | Nothing -> (ed, [TIdentifier n], ts)
|
| 103 | - Just defs -> (ed0, r, rest0)
|
|
| 107 | + Just defs -> (ed0, r, rest1)
|
|
| 104 | 108 | where
|
| 105 | 109 | (args, rest0) = getExpandArgs ts
|
| 106 | - (m_args, rhs) = fromMaybe (Nothing, [TIdentifier n]) (Map.lookup (arg_arity args) defs)
|
|
| 107 | - (ed0, r) = case m_args of
|
|
| 108 | - Nothing -> (True, rhs)
|
|
| 109 | - Just _ -> (True, replace_args args m_args rhs)
|
|
| 110 | + fallbackArgs = fromMaybe (Nothing, [TIdentifier n]) (Map.lookup Nothing defs)
|
|
| 111 | + (m_args, rhs) = fromMaybe fallbackArgs (Map.lookup (arg_arity args) defs)
|
|
| 112 | + (ed0, r, rest1) = case m_args of
|
|
| 113 | + Nothing -> (True, rhs, ts)
|
|
| 114 | + Just _ -> (True, replace_args args m_args rhs, rest0)
|
|
| 110 | 115 | (ed'', rest) = doExpandToks ed' s ts'
|
| 111 | 116 | doExpandToks ed s (t : ts) = (ed', t : r)
|
| 112 | 117 | where
|
| ... | ... | @@ -33,3 +33,15 @@ complete junk! |
| 33 | 33 | #ifdef AA
|
| 34 | 34 | aa = 1
|
| 35 | 35 | #endif
|
| 36 | + |
|
| 37 | +-- undef and rewrite base name only
|
|
| 38 | +#define MIN_VERSION_Cabal(a,b,c) 1
|
|
| 39 | + |
|
| 40 | +#ifdef MIN_VERSION_Cabal
|
|
| 41 | +#undef CH_MIN_VERSION_Cabal
|
|
| 42 | +#define CH_MIN_VERSION_Cabal MIN_VERSION_Cabal
|
|
| 43 | +#endif
|
|
| 44 | + |
|
| 45 | +#if CH_MIN_VERSION_Cabal(1,22,0)
|
|
| 46 | +x = 1
|
|
| 47 | +#endif |
| ... | ... | @@ -64,15 +64,19 @@ expand s str = expanded |
| 64 | 64 | toks = case cppLex False str of
|
| 65 | 65 | Left err -> error $ "expand:" ++ show (err, str)
|
| 66 | 66 | Right tks -> tks
|
| 67 | - expanded = combineToks $ map t_str $ expandToks s toks
|
|
| 67 | + expanded = combineToks $ map t_str $ expandToks maxExpansions s toks
|
|
| 68 | 68 | |
| 69 | -expandToks :: MacroDefines -> [Token] -> [Token]
|
|
| 70 | -expandToks s ts =
|
|
| 69 | +maxExpansions :: Int
|
|
| 70 | +maxExpansions = 15
|
|
| 71 | + |
|
| 72 | +expandToks :: Int -> MacroDefines -> [Token] -> [Token]
|
|
| 73 | +expandToks 0 _ ts = error $ "macro_expansion limit (" ++ show maxExpansions ++ ") hit, aborting. ts=" ++ show ts
|
|
| 74 | +expandToks cnt s ts =
|
|
| 71 | 75 | let
|
| 72 | - (expansionDone, r) = doExpandToks False s ts
|
|
| 76 | + (!expansionDone, !r) = doExpandToks False s ts
|
|
| 73 | 77 | in
|
| 74 | 78 | if expansionDone
|
| 75 | - then expandToks s r
|
|
| 79 | + then expandToks (cnt -1) s r
|
|
| 76 | 80 | else r
|
| 77 | 81 | |
| 78 | 82 | doExpandToks :: Bool -> MacroDefines -> [Token] -> (Bool, [Token])
|
| ... | ... | @@ -99,13 +103,14 @@ doExpandToks ed s (TIdentifier n : ts) = (ed'', expanded ++ rest) |
| 99 | 103 | where
|
| 100 | 104 | (ed', expanded, ts') = case Map.lookup n s of
|
| 101 | 105 | Nothing -> (ed, [TIdentifier n], ts)
|
| 102 | - Just defs -> (ed0, r, rest0)
|
|
| 106 | + Just defs -> (ed0, r, rest1)
|
|
| 103 | 107 | where
|
| 104 | 108 | (args, rest0) = getExpandArgs ts
|
| 105 | - (m_args, rhs) = fromMaybe (Nothing, [TIdentifier n]) (Map.lookup (arg_arity args) defs)
|
|
| 106 | - (ed0, r) = case m_args of
|
|
| 107 | - Nothing -> (True, rhs)
|
|
| 108 | - Just _ -> (True, replace_args args m_args rhs)
|
|
| 109 | + fallbackArgs = fromMaybe (Nothing, [TIdentifier n]) (Map.lookup Nothing defs)
|
|
| 110 | + (m_args, rhs) = fromMaybe fallbackArgs (Map.lookup (arg_arity args) defs)
|
|
| 111 | + (ed0, r, rest1) = case m_args of
|
|
| 112 | + Nothing -> (True, rhs, ts)
|
|
| 113 | + Just _ -> (True, replace_args args m_args rhs, rest0)
|
|
| 109 | 114 | (ed'', rest) = doExpandToks ed' s ts'
|
| 110 | 115 | doExpandToks ed s (t : ts) = (ed', t : r)
|
| 111 | 116 | where
|
| ... | ... | @@ -820,3 +820,21 @@ t35 = do |
| 820 | 820 | , "#endif"
|
| 821 | 821 | , ""
|
| 822 | 822 | ]
|
| 823 | + |
|
| 824 | +t36 :: IO ()
|
|
| 825 | +t36 = do
|
|
| 826 | + dump
|
|
| 827 | + [ "{-# LANGUAGE GHC_CPP #-}"
|
|
| 828 | + , "module Example15 where"
|
|
| 829 | + , "#define MIN_VERSION_Cabal(a,b,c) 1"
|
|
| 830 | + , ""
|
|
| 831 | + , "#ifdef MIN_VERSION_Cabal"
|
|
| 832 | + , "#undef CH_MIN_VERSION_Cabal"
|
|
| 833 | + , "#define CH_MIN_VERSION_Cabal MIN_VERSION_Cabal"
|
|
| 834 | + , "#endif"
|
|
| 835 | + , ""
|
|
| 836 | + , "#if CH_MIN_VERSION_Cabal(1,22,0)"
|
|
| 837 | + , "x = 1"
|
|
| 838 | + , "#endif"
|
|
| 839 | + , ""
|
|
| 840 | + ] |