Alan Zimmerman pushed to branch wip/az/ghc-cpp at Glasgow Haskell Compiler / GHC Commits: b70fb2a2 by Alan Zimmerman at 2025-06-08T16:16:16+02:00 Starting to report GHC_CPP errors using GHC machinery - - - - - 10 changed files: - compiler/GHC/Parser/Errors/Ppr.hs - compiler/GHC/Parser/Errors/Types.hs - compiler/GHC/Parser/Lexer.x - compiler/GHC/Parser/PreProcess.hs - compiler/GHC/Parser/PreProcess/State.hs - compiler/GHC/Types/Error/Codes.hs - + testsuite/tests/ghc-cpp/GhcCpp02.stderr - testsuite/tests/ghc-cpp/all.T - utils/check-cpp/PreProcess.hs - utils/check-cpp/State.hs Changes: ===================================== compiler/GHC/Parser/Errors/Ppr.hs ===================================== @@ -573,6 +573,9 @@ instance Diagnostic PsMessage where -> mkSimpleDecorated $ text "The" <+> quotes (text "pattern") <+> "namespace specifier is deprecated." + PsErrGhcCpp content + -> mkSimpleDecorated content + diagnosticReason = \case PsUnknownMessage m -> diagnosticReason m PsHeaderMessage m -> psHeaderMessageReason m @@ -695,6 +698,7 @@ instance Diagnostic PsMessage where PsErrSpecExprMultipleTypeAscription{} -> ErrorWithoutFlag PsWarnSpecMultipleTypeAscription{} -> WarningWithFlag Opt_WarnDeprecatedPragmas PsWarnPatternNamespaceSpecifier{} -> WarningWithFlag Opt_WarnPatternNamespaceSpecifier + PsErrGhcCpp{} -> ErrorWithoutFlag -- AZ: Is this correct? diagnosticHints = \case PsUnknownMessage m -> diagnosticHints m @@ -873,6 +877,7 @@ instance Diagnostic PsMessage where let info = text "and replace" <+> quotes (text "pattern") <+> text "with" <+> quotes (text "data") <> "." in [useExtensionInOrderTo info LangExt.ExplicitNamespaces] + PsErrGhcCpp{} -> noHints diagnosticCode = constructorCode @GHC ===================================== compiler/GHC/Parser/Errors/Types.hs ===================================== @@ -515,6 +515,9 @@ data PsMessage | PsWarnPatternNamespaceSpecifier !Bool -- ^ Is ExplicitNamespaces on? + -- | An error originating from processing a GHC_CPP directive + | PsErrGhcCpp !SDoc + deriving Generic -- | Extra details about a parse error, which helps ===================================== compiler/GHC/Parser/Lexer.x ===================================== @@ -335,9 +335,9 @@ $unigraphic / { isSmartQuote } { smart_quote_error } ^\# \ * $idchar+ .*\n / { ifExtensionGhcCppNotComment } { cppSkip } -- No leading space, otherwise clashes with OverloadedLabels - ^\# pragma .* \n / { ifExtensionGhcCppNotComment } { cppSkip } -- GCC 3.3 CPP generated, apparently - ^\# \! .* \n / { ifExtensionGhcCppNotComment } { cppSkip } -- #!, for scripts -- gcc - ^\ \# \! .* \n / { ifExtensionGhcCppNotComment } { cppSkip } -- #!, for scripts -- clang; See #6132 + ^\# pragma .* \n / { ifExtensionGhcCppNotComment } { cppSkip } -- GCC 3.3 CPP generated, apparently + ^\# \! .* \n / { ifExtensionGhcCppNotComment } { cppSkip } -- #!, for scripts -- gcc + ^\ \# \! .* \n / { ifExtensionGhcCppNotComment } { cppSkip } -- #!, for scripts -- clang; See #6132 ^\# pragma .* \n ; -- GCC 3.3 CPP generated, apparently ^\# \! .* \n ; -- #!, for scripts -- gcc @@ -351,7 +351,7 @@ $unigraphic / { isSmartQuote } { smart_quote_error } <skipping> { -- Ghc CPP symbols ^\# \ * @cppkeyword .* \n { cppToken cpp_prag } - ^.*\n { cppSkip } + ^.*\n { cppSkip } } -- after a layout keyword (let, where, do, of), we begin a new layout ===================================== compiler/GHC/Parser/PreProcess.hs ===================================== @@ -14,6 +14,7 @@ module GHC.Parser.PreProcess ( ) where import Data.List (intercalate, sortBy) +import Data.Maybe (fromMaybe, listToMaybe) import Data.Map qualified as Map import Debug.Trace (trace) import GHC.Data.FastString @@ -30,8 +31,10 @@ import GHC.Parser.PreProcess.ParserM qualified as PM import GHC.Parser.PreProcess.State import GHC.Prelude import GHC.Types.SrcLoc -import GHC.Utils.Outputable (SDoc, text) +import GHC.Utils.Error +import GHC.Utils.Outputable (text) import GHC.Utils.Panic.Plain (panic) +import GHC.Parser.Errors.Types (PsMessage(PsErrGhcCpp)) -- --------------------------------------------------------------------- @@ -212,7 +215,7 @@ ppLexer queueComments cont = pushContinuation tk contIgnoreTok tk else do - mdump <- processCppToks s + mdump <- processCppToks tk case mdump of Just dump -> -- We have a dump of the state, put it into an ignored token @@ -241,25 +244,25 @@ ppLexer queueComments cont = -- --------------------------------------------------------------------- -processCppToks :: FastString -> PP (Maybe String) +processCppToks :: Located Lexer.Token -> PP (Maybe String) processCppToks fs = do let get (L _ (ITcpp False s _)) = unpackFS s get (L _ (ITcpp True s _)) = init $ unpackFS s - get _ = error "should not" + get _ = panic "Should be ITcpp" -- Combine any prior continuation tokens cs <- popContinuation - processCpp (reverse $ unpackFS fs : map get cs) + let loc = combineLocs fs (fromMaybe fs (listToMaybe cs)) + processCpp loc (concat $ reverse $ map get (fs:cs)) -processCpp :: [String] -> PP (Maybe String) -processCpp ss = do - let s = concat ss +processCpp :: SrcSpan -> String -> PP (Maybe String) +processCpp loc s = do let directive = parseDirective s if directive == Right CppDumpState then return (Just "\ndumped state\n") else do case directive of - Left err -> error $ show (err, s) + Left err -> Lexer.addError $ mkPlainErrorMsgEnvelope loc $ PsErrGhcCpp (text err) Right (CppInclude filename) -> do ppInclude filename Right (CppDefine name args def) -> do @@ -280,14 +283,14 @@ processCpp ss = do acceptStateChange ar Right CppElse -> do accepting <- getAccepting - ar <- setAccepting (not accepting) + ar <- setAccepting loc (text "#else") (not accepting) acceptStateChange ar Right (CppElIf cond) -> do val <- cppCond cond - ar <- setAccepting val + ar <- setAccepting loc (text "#elif") val acceptStateChange ar Right CppEndif -> do - ar <- popAccepting + ar <- popAccepting loc acceptStateChange ar Right CppDumpState -> do return () @@ -298,15 +301,8 @@ processCpp ss = do acceptStateChange :: AcceptingResult -> PP () acceptStateChange ArNoChange = return () acceptStateChange ArNowIgnoring = do - -- alr <- Lexer.getAlrState - -- s <- getPpState - -- let s = trace ("acceptStateChange:ArNowIgnoring") s' - -- setPpState (s { pp_alr_state = Just alr}) Lexer.startSkipping acceptStateChange ArNowAccepting = do - -- s <- getPpState - -- let s = trace ("acceptStateChange:ArNowAccepting") s' - -- mapM_ Lexer.setAlrState (pp_alr_state s) _ <- Lexer.stopSkipping return () ===================================== compiler/GHC/Parser/PreProcess/State.hs ===================================== @@ -32,6 +32,7 @@ module GHC.Parser.PreProcess.State ( ghcCppEnabled, setInLinePragma, getInLinePragma, + addGhcCPPError, ) where import Data.List.NonEmpty ((<|)) @@ -41,12 +42,15 @@ import Data.Map.Strict qualified as Map import Data.Maybe (isJust) import GHC.Base import GHC.Data.StringBuffer +import GHC.Parser.Errors.Types (PsMessage (PsErrGhcCpp)) import GHC.Parser.Lexer (P (..), PState (..), ParseResult (..)) import GHC.Parser.Lexer qualified as Lexer import GHC.Parser.PreProcess.ParserM (Token (..)) import GHC.Types.SrcLoc +import GHC.Utils.Error import GHC.Prelude +import GHC.Utils.Outputable (text, (<+>)) -- --------------------------------------------------------------------- @@ -191,20 +195,22 @@ pushAccepting on = do -- Note: this is only ever called in the context of a pp group (i.e. -- after pushAccepting) from processing #else or #elif -setAccepting :: Bool -> PP AcceptingResult -setAccepting on = do +setAccepting :: SrcSpan -> SDoc -> Bool -> PP AcceptingResult +setAccepting loc ctx on = do current <- getAccepting parent_scope <- parentScope let parent_on = pp_accepting parent_scope current_scope <- getScope let group_state = pp_group_state current_scope let possible_accepting = parent_on && on - let (new_group_state, accepting) = - case (group_state, possible_accepting) of - (PpNoGroup, _) -> error "setAccepting for state PpNoGroup" -- AZ: Tested in GhcCpp02 - (PpInGroupStillInactive, True) -> (PpInGroupHasBeenActive, True) - (PpInGroupStillInactive, False) -> (PpInGroupStillInactive, False) - (PpInGroupHasBeenActive, _) -> (PpInGroupHasBeenActive, False) + (new_group_state, accepting) <- + case (group_state, possible_accepting) of + (PpNoGroup, _) -> do + addGhcCPPError loc (ctx <+> text "without #if") + return (PpNoGroup, True) + (PpInGroupStillInactive, True) -> return (PpInGroupHasBeenActive, True) + (PpInGroupStillInactive, False) -> return (PpInGroupStillInactive, False) + (PpInGroupHasBeenActive, _) -> return (PpInGroupHasBeenActive, False) -- let (new_group_state, accepting) -- = trace ("setAccepting:" ++ show ((group_state, possible_accepting), (new_group_state', accepting'))) (new_group_state', accepting') @@ -231,19 +237,29 @@ acceptingStateChange old new = _ -> ArNoChange -- Exit a scope group -popAccepting :: 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 :: 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 + c :| [] -> do + addGhcCPPError loc (text "#endif without #if") + return (c :| []) + _ :| (h : t) -> return (h :| t) + setScopes new_scope + let current = scopeValue scopes + return (acceptingStateChange current (scopeValue new_scope)) scopeValue :: NonEmpty PpScope -> Bool scopeValue s = pp_accepting $ NonEmpty.head s @@ -280,6 +296,13 @@ setScope scope = in POk s{pp = (pp s){pp_scope = new_scope}} () +getScopes :: PP (NonEmpty PpScope) +getScopes = P $ \s -> POk s (pp_scope (pp s)) + +setScopes :: (NonEmpty PpScope) -> PP () +setScopes new_scope = + P $ \s -> POk s{pp = (pp s){pp_scope = new_scope}} () + {- Note [PpScope stack] ~~~~~~~~~~~~~~~~~~~~ @@ -404,3 +427,7 @@ insertMacroDef (MacroName name args) def md = Just dm -> Map.insert name (Map.insert arity (args, def) dm) md -- --------------------------------------------------------------------- + +addGhcCPPError :: SrcSpan -> SDoc -> P p () +addGhcCPPError loc err = + Lexer.addError $ mkPlainErrorMsgEnvelope loc $ PsErrGhcCpp err ===================================== compiler/GHC/Types/Error/Codes.hs ===================================== @@ -371,6 +371,7 @@ type family GhcDiagnosticCode c = n | n -> c where GhcDiagnosticCode "PsErrSpecExprMultipleTypeAscription" = 62037 GhcDiagnosticCode "PsWarnSpecMultipleTypeAscription" = 73026 GhcDiagnosticCode "PsWarnPatternNamespaceSpecifier" = 68383 + GhcDiagnosticCode "PsErrGhcCpp" = 93098 -- Driver diagnostic codes GhcDiagnosticCode "DriverMissingHomeModules" = 32850 ===================================== testsuite/tests/ghc-cpp/GhcCpp02.stderr ===================================== @@ -0,0 +1,4 @@ +GhcCpp02.hs:5:1: error: [GHC-93098] #else without #if + +GhcCpp02.hs:7:1: error: [GHC-93098] #endif without #if + ===================================== testsuite/tests/ghc-cpp/all.T ===================================== @@ -20,4 +20,4 @@ test('GhcCpp01', compile, ['-ddump-ghc-cpp -dkeep-comments']) -test('GhcCpp02', normal, compile, ['']) \ No newline at end of file +test('GhcCpp02', normal, compile_fail, ['']) \ No newline at end of file ===================================== utils/check-cpp/PreProcess.hs ===================================== @@ -1,6 +1,7 @@ module PreProcess where import Data.List +import Data.Maybe (fromMaybe, listToMaybe) import qualified Data.Map as Map import Debug.Trace import GHC hiding (addSourceToTokens) @@ -20,6 +21,7 @@ import GHC.Types.SrcLoc import GHC.Utils.Error import GHC.Utils.Outputable import GHC.Utils.Panic.Plain +import GHC.Parser.Errors.Types (PsMessage(PsErrGhcCpp)) import Macro import ParsePP @@ -241,7 +243,7 @@ ppLexer queueComments cont = pushContinuation tk contIgnoreTok tk else do - mdump <- processCppToks s + mdump <- processCppToks tk case mdump of Just dump -> -- We have a dump of the state, put it into an ignored token @@ -270,25 +272,25 @@ ppLexer queueComments cont = -- --------------------------------------------------------------------- -processCppToks :: FastString -> PP (Maybe String) +processCppToks :: Located Lexer.Token -> PP (Maybe String) processCppToks fs = do let get (L _ (ITcpp False s _)) = unpackFS s get (L _ (ITcpp True s _)) = init $ unpackFS s - get _ = error "should not" + get _ = panic "Should be ITcpp" -- Combine any prior continuation tokens cs <- popContinuation - processCpp (reverse $ unpackFS fs : map get cs) + let loc = combineLocs fs (fromMaybe fs (listToMaybe cs)) + processCpp loc (concat $ reverse $ map get (fs:cs)) -processCpp :: [String] -> PP (Maybe String) -processCpp ss = do - let s = concat ss +processCpp :: SrcSpan -> String -> PP (Maybe String) +processCpp loc s = do let directive = parseDirective s if directive == Right CppDumpState then return (Just "\ndumped state\n") else do case directive of - Left err -> error $ show (err, s) + Left err -> Lexer.addError $ mkPlainErrorMsgEnvelope loc $ PsErrGhcCpp (fsLit (show err)) Right (CppInclude filename) -> do ppInclude filename Right (CppDefine name args def) -> do @@ -309,11 +311,11 @@ processCpp ss = do acceptStateChange ar Right CppElse -> do accepting <- getAccepting - ar <- setAccepting (not accepting) + ar <- setAccepting loc (not accepting) acceptStateChange ar Right (CppElIf cond) -> do val <- cppCond cond - ar <- setAccepting val + ar <- setAccepting loc val acceptStateChange ar Right CppEndif -> do ar <- popAccepting ===================================== utils/check-cpp/State.hs ===================================== @@ -32,17 +32,22 @@ module State ( ghcCppEnabled, setInLinePragma, getInLinePragma, + addGhcCPPError, ) where import Data.List.NonEmpty ((<|)) -import qualified Data.List.NonEmpty as NonEmpty -import Data.Map (Map) -import qualified Data.Map as Map +import Data.List.NonEmpty qualified as NonEmpty +import Data.Map.Strict (Map) +import Data.Map.Strict qualified as Map import Data.Maybe (isJust) import GHC.Base +import GHC.Data.FastString import GHC.Data.StringBuffer import GHC.Parser.Lexer (P (..), PState (..), ParseResult (..)) -import qualified GHC.Parser.Lexer as Lexer +import GHC.Parser.Lexer qualified as Lexer +import GHC.Parser.Errors.Types (PsMessage(PsErrGhcCpp)) +import GHC.Utils.Error +-- import GHC.Parser.PreProcess.ParserM (Token (..)) import GHC.Types.SrcLoc import ParserM (Token (..)) @@ -192,20 +197,22 @@ pushAccepting on = do -- Note: this is only ever called in the context of a pp group (i.e. -- after pushAccepting) from processing #else or #elif -setAccepting :: Bool -> PP AcceptingResult -setAccepting on = do +setAccepting :: SrcSpan -> Bool -> PP AcceptingResult +setAccepting loc on = do current <- getAccepting parent_scope <- parentScope let parent_on = pp_accepting parent_scope current_scope <- getScope let group_state = pp_group_state current_scope let possible_accepting = parent_on && on - let (new_group_state, accepting) = + (new_group_state, accepting) <- case (group_state, possible_accepting) of - (PpNoGroup, _) -> error "setAccepting for state PpNoGroup" - (PpInGroupStillInactive, True) -> (PpInGroupHasBeenActive, True) - (PpInGroupStillInactive, False) -> (PpInGroupStillInactive, False) - (PpInGroupHasBeenActive, _) -> (PpInGroupHasBeenActive, False) + (PpNoGroup, _) -> do + addGhcCPPError loc "setAccepting for state PpNoGroup" + return (PpNoGroup, True) + (PpInGroupStillInactive, True) -> return (PpInGroupHasBeenActive, True) + (PpInGroupStillInactive, False) -> return (PpInGroupStillInactive, False) + (PpInGroupHasBeenActive, _) -> return (PpInGroupHasBeenActive, False) -- let (new_group_state, accepting) -- = trace ("setAccepting:" ++ show ((group_state, possible_accepting), (new_group_state', accepting'))) (new_group_state', accepting') @@ -405,3 +412,7 @@ insertMacroDef (MacroName name args) def md = Just dm -> Map.insert name (Map.insert arity (args, def) dm) md -- --------------------------------------------------------------------- + +addGhcCPPError :: SrcSpan -> String -> P p () +addGhcCPPError loc err + = Lexer.addError $ mkPlainErrorMsgEnvelope loc $ PsErrGhcCpp (fsLit err) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/b70fb2a29cee983c058502c29572e503... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/b70fb2a29cee983c058502c29572e503... You're receiving this email because of your account on gitlab.haskell.org.