Alan Zimmerman pushed to branch wip/az/ghc-cpp at Glasgow Haskell Compiler / GHC Commits: e4bb059f by Alan Zimmerman at 2025-06-08T17:25:24+02:00 More GHC_CPP diagnostic results - - - - - 5 changed files: - compiler/GHC/Parser/PreProcess.hs - compiler/GHC/Parser/PreProcess/Macro.hs - compiler/GHC/Parser/PreProcess/State.hs - testsuite/tests/ghc-cpp/GhcCpp02.hs - testsuite/tests/ghc-cpp/GhcCpp02.stderr Changes: ===================================== compiler/GHC/Parser/PreProcess.hs ===================================== @@ -270,7 +270,7 @@ processCpp loc s = do Right (CppUndef name) -> do ppUndef name Right (CppIf cond) -> do - val <- cppCond cond + val <- cppCond loc cond ar <- pushAccepting val acceptStateChange ar Right (CppIfdef name) -> do @@ -286,7 +286,7 @@ processCpp loc s = do ar <- setAccepting loc (text "#else") (not accepting) acceptStateChange ar Right (CppElIf cond) -> do - val <- cppCond cond + val <- cppCond loc cond ar <- setAccepting loc (text "#elif") val acceptStateChange ar Right CppEndif -> do ===================================== compiler/GHC/Parser/PreProcess/Macro.hs ===================================== @@ -32,29 +32,35 @@ details -- TODO: Parse tokens with original locations in them. -import qualified Data.Map as Map +import Data.Map qualified as Map import Data.Maybe +import Data.Semigroup qualified as S import GHC.Parser.PreProcess.Eval import GHC.Parser.PreProcess.ParsePP import GHC.Parser.PreProcess.Parser qualified as Parser import GHC.Parser.PreProcess.ParserM import GHC.Parser.PreProcess.State -import qualified Data.Semigroup as S import GHC.Prelude +import GHC.Types.SrcLoc +import GHC.Utils.Outputable -- --------------------------------------------------------------------- -- We evaluate to an Int, which we convert to a bool -cppCond :: String -> PP Bool -cppCond str = do - s <- getPpState - let - expanded = expand (pp_defines s) str - v = case Parser.parseExpr expanded of - Left err -> error $ "parseExpr:" ++ show (err, expanded) - Right tree -> eval tree - return (toBool v) +cppCond :: SrcSpan -> String -> PP Bool +cppCond loc str = do + s <- getPpState + let + expanded = expand (pp_defines s) str + v <- case Parser.parseExpr expanded of + Left err -> do + addGhcCPPError loc + (hang (text "Error evaluating CPP condition:") 2 + (text err <+> text "of" $+$ text expanded)) + return 0 + Right tree -> return (eval tree) + return (toBool v) -- --------------------------------------------------------------------- @@ -75,31 +81,32 @@ expandToks 0 _ ts = error $ "macro_expansion limit (" ++ show maxExpansions ++ " expandToks cnt s ts = let (!expansionDone, !r) = doExpandToks False s ts - in + in if expansionDone - then expandToks (cnt -1) s r + then expandToks (cnt - 1) s r else r doExpandToks :: Bool -> MacroDefines -> [Token] -> (Bool, [Token]) doExpandToks ed _ [] = (ed, []) -doExpandToks ed s (TIdentifierLParen n: ts) = - -- TIdentifierLParen has no meaning here (only in a #define), so - -- restore it to its constituent tokens - doExpandToks ed s (TIdentifier (init n):TOpenParen "(":ts) -doExpandToks _ s (TIdentifier "defined" : ts) = (True, rest) - -- See Note: [defined unary operator] below +doExpandToks ed s (TIdentifierLParen n : ts) = + -- TIdentifierLParen has no meaning here (only in a #define), so + -- restore it to its constituent tokens + doExpandToks ed s (TIdentifier (init n) : TOpenParen "(" : ts) +doExpandToks _ s (TIdentifier "defined" : ts) = (True, rest) where + -- See Note: [defined unary operator] below + rest = case getExpandArgs ts of - (Just [[TIdentifier macro_name]], rest0) -> - case Map.lookup macro_name s of - Nothing -> TInteger "0" : rest0 - Just _ ->TInteger "1" : rest0 - (Nothing, TIdentifier macro_name:ts0) -> - case Map.lookup macro_name s of - Nothing -> TInteger "0" : ts0 - Just _ ->TInteger "1" : ts0 - (Nothing,_) -> error $ "defined: expected an identifier, got:" ++ show ts - (Just args,_) -> error $ "defined: expected a single arg, got:" ++ show args + (Just [[TIdentifier macro_name]], rest0) -> + case Map.lookup macro_name s of + Nothing -> TInteger "0" : rest0 + Just _ -> TInteger "1" : rest0 + (Nothing, TIdentifier macro_name : ts0) -> + case Map.lookup macro_name s of + Nothing -> TInteger "0" : ts0 + Just _ -> TInteger "1" : ts0 + (Nothing, _) -> error $ "defined: expected an identifier, got:" ++ show ts + (Just args, _) -> error $ "defined: expected a single arg, got:" ++ show args doExpandToks ed s (TIdentifier n : ts) = (ed'', expanded ++ rest) where (ed', expanded, ts') = case Map.lookup n s of ===================================== compiler/GHC/Parser/PreProcess/State.hs ===================================== @@ -238,18 +238,6 @@ acceptingStateChange old new = -- Exit a scope group popAccepting :: SrcSpan -> PP AcceptingResult --- popAccepting = --- P $ \s -> --- let --- current = scopeValue $ pp_scope (pp s) --- new_scope = case pp_scope (pp s) of --- c :| [] -> c :| [] --- -- c :| [] -> (trace ("popAccepting:keeping old:" ++ show c) c) :| [] --- _ :| (h : t) -> h :| t --- in --- POk --- s{pp = (pp s){pp_scope = new_scope}} --- (acceptingStateChange current (scopeValue new_scope)) popAccepting loc = do scopes <- getScopes new_scope <- case scopes of ===================================== testsuite/tests/ghc-cpp/GhcCpp02.hs ===================================== @@ -5,3 +5,10 @@ foo = #else 13 #endif + +#define EXISTENT_MACRO(X) 2 + NONEXISTENT_MACRO(X) + +-- Note the evaluation error is reported on the *expanded* macro +#if EXISTENT_MACRO(4) +bar = 3 +#endif ===================================== testsuite/tests/ghc-cpp/GhcCpp02.stderr ===================================== @@ -2,3 +2,8 @@ GhcCpp02.hs:5:1: error: [GHC-93098] #else without #if GhcCpp02.hs:7:1: error: [GHC-93098] #endif without #if +GhcCpp02.hs:12:1: error: [GHC-93098] + Error evaluating CPP condition: + Parse error at line 1, column 23 of + 2 + NONEXISTENT_MACRO ( 4 ) + View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/e4bb059f18a7d11e494875fe7bbc78ec... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/e4bb059f18a7d11e494875fe7bbc78ec... You're receiving this email because of your account on gitlab.haskell.org.