
Alan Zimmerman pushed to branch wip/az/ghc-cpp at Glasgow Haskell Compiler / GHC Commits: 937a9c4d by Alan Zimmerman at 2025-04-21T13:20:39+01:00 Process TIdentifierLParen Which only matters at the start of #define - - - - - 13 changed files: - compiler/GHC/Parser/PreProcess/Lexer.x - compiler/GHC/Parser/PreProcess/Macro.hs - compiler/GHC/Parser/PreProcess/ParsePP.hs - compiler/GHC/Parser/PreProcess/Parser.y - compiler/GHC/Parser/PreProcess/ParserM.hs - utils/check-cpp/Eval.hs - utils/check-cpp/Lexer.x - utils/check-cpp/Macro.hs - utils/check-cpp/Main.hs - utils/check-cpp/ParsePP.hs - utils/check-cpp/Parser.y - utils/check-cpp/ParserM.hs - utils/check-cpp/State.hs Changes: ===================================== compiler/GHC/Parser/PreProcess/Lexer.x ===================================== @@ -92,10 +92,11 @@ words :- <0> "xor" { mkTv TXor } <0> "xor_eq" { mkTv TXorEq } ---------------------------------------- - <0> [a-zA-Z_][a-zA-Z0-9_]* { mkTv TIdentifier } - <0> \-? [0-9][0-9]* { mkTv TInteger } - <0> \" [^\"]* \" { mkTv (TString . tail . init) } - <0> () { begin other } + <0> [a-zA-Z_][a-zA-Z0-9_]*\( { mkTv TIdentifierLParen } + <0> [a-zA-Z_][a-zA-Z0-9_]* { mkTv TIdentifier } + <0> \-? [0-9][0-9]* { mkTv TInteger } + <0> \" [^\"]* \" { mkTv (TString . tail . init) } + <0> () { begin other } <other> .+ { \i -> do {setStartCode 0; mkTv TOther i} } ===================================== compiler/GHC/Parser/PreProcess/Macro.hs ===================================== @@ -71,14 +71,18 @@ expandToks :: MacroDefines -> [Token] -> [Token] expandToks s ts = let (expansionDone, r) = doExpandToks False s ts - in + in if expansionDone then expandToks s r else r doExpandToks :: Bool -> MacroDefines -> [Token] -> (Bool, [Token]) doExpandToks ed _ [] = (ed, []) -doExpandToks _ s (TIdentifier "defined" : ts) = (True, rest) +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 n:TOpenParen "(":ts) +doExpandToks _ s (TIdentifier "defined" : ts) = (True, rest) -- See Note: [defined unary operator] below where rest = case getExpandArgs ts of ===================================== compiler/GHC/Parser/PreProcess/ParsePP.hs ===================================== @@ -7,6 +7,7 @@ module GHC.Parser.PreProcess.ParsePP ( t1, t2, t3, + t4, ) where import Data.List (intercalate) @@ -47,9 +48,10 @@ combineToks ss = intercalate " " ss cppDefine :: [Token] -> Either String CppDirective cppDefine [] = Left "error:empty #define directive" -cppDefine (TIdentifier n : ts) = Right $ CppDefine n args def +cppDefine (TIdentifierLParen n : ts) = Right $ CppDefine n args def where (args, def) = getArgs ts +cppDefine (TIdentifier n : ts) = Right $ CppDefine n Nothing ts cppDefine (t : _) = Left $ "#define: expecting an identifier, got :" ++ show t cppInclude :: [String] -> CppDirective @@ -79,14 +81,14 @@ cppDumpState _ts = CppDumpState -- --------------------------------------------------------------------- -- Crack out the arguments to a #define. This is of the form of --- comma-separated identifiers between parens +-- comma-separated identifiers between parens, where we have already +-- seen the opening paren. getArgs :: [Token] -> (Maybe [String], [Token]) getArgs [] = (Nothing, []) -getArgs (TOpenParen _ : ts) = +getArgs ts = case parseDefineArgs [] ts of Left err -> error err Right (args, rest) -> (Just (reverse args), rest) -getArgs ts = (Nothing, ts) parseDefineArgs :: [String] -> @@ -138,3 +140,5 @@ t2 = doATest "# if ((m1) < 1 || (m1) == 1 && (m2) < 7 || (m1) == 1 && (m2) == t3 :: Either String CppDirective t3 = parseDirective "# if FOO == 4" + +t4 = cppLex "#define foo(X) X" ===================================== compiler/GHC/Parser/PreProcess/Parser.y ===================================== @@ -92,6 +92,7 @@ import GHC.Prelude 'xor_eq' { TXorEq {} } identifier { TIdentifier {} } + identifierLP { TIdentifierLParen {} } integer { TInteger {} } string { TString {} } other { TOther {} } ===================================== compiler/GHC/Parser/PreProcess/ParserM.hs ===================================== @@ -91,6 +91,7 @@ init_state = data Token = TEOF {t_str :: String} | TIdentifier {t_str :: String} + | TIdentifierLParen {t_str :: String} | TInteger {t_str :: String} | -- preprocessing-op-or-punc -- https://timsong-cpp.github.io/cppwp/n4140/lex.operators#nt:preprocessing-op-... ===================================== utils/check-cpp/Eval.hs ===================================== @@ -8,7 +8,7 @@ eval :: Expr -> Int eval (Parens e) = eval e eval (Not e) = fromBool $ not (toBool $ eval e) -- eval (Var v) = error $ "need to look up :" ++ v -eval (Var v) = 0 -- Spec says remaining identifiers are replaces with zero +eval (Var _) = 0 -- Spec says remaining identifiers are replaces with zero eval (IntVal i) = i eval (Plus e1 e2) = (eval e1) + (eval e2) eval (Minus e1 e2) = (eval e1) - (eval e2) ===================================== utils/check-cpp/Lexer.x ===================================== @@ -90,10 +90,11 @@ words :- <0> "xor" { mkTv TXor } <0> "xor_eq" { mkTv TXorEq } ---------------------------------------- - <0> [a-zA-Z_][a-zA-Z0-9_]* { mkTv TIdentifier } - <0> \-? [0-9][0-9]* { mkTv TInteger } - <0> \" [^\"]* \" { mkTv (TString . tail . init) } - <0> () { begin other } + <0> [a-zA-Z_][a-zA-Z0-9_]*\( { mkTv TIdentifierLParen } + <0> [a-zA-Z_][a-zA-Z0-9_]* { mkTv TIdentifier } + <0> \-? [0-9][0-9]* { mkTv TInteger } + <0> \" [^\"]* \" { mkTv (TString . tail . init) } + <0> () { begin other } <other> .+ { \i -> do {setStartCode 0; mkTv TOther i} } ===================================== utils/check-cpp/Macro.hs ===================================== @@ -70,13 +70,17 @@ expandToks :: MacroDefines -> [Token] -> [Token] expandToks s ts = let (expansionDone, r) = doExpandToks False s ts - in + in if expansionDone then expandToks 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 n:TOpenParen "(":ts) doExpandToks _ s (TIdentifier "defined" : ts) = (True, rest) -- See Note: [defined unary operator] below where ===================================== utils/check-cpp/Main.hs ===================================== @@ -280,6 +280,7 @@ t2 = do , "#else" , "x = 5" , "#endif" + , "" ] -- x = 5 @@ -348,6 +349,7 @@ t4 = do , "#else" , "x = \"no version\"" , "#endif" + , "" ] -- x = "got version" @@ -399,6 +401,7 @@ t10 = do , "#else" , "x = 2" , "#endif" + , "" ] -- x = 1 @@ -424,6 +427,7 @@ t11 = do , "#else" , "x = 5" , "#endif" + , "" ] -- x = 1 @@ -438,6 +442,7 @@ t12 = do , "#else" , "x = 5" , "#endif" + , "" ] -- x = 1 @@ -450,6 +455,7 @@ t13 = do , "#else" , "x = 5" , "#endif" + , "" ] -- x = 1 @@ -473,6 +479,7 @@ t14 = do , "#else" , "z = 5" , "#endif" + , "" ] -- x = 1 @@ -496,6 +503,7 @@ t16 = do , "#else" , "x = 5" , "#endif" + , "" ] -- x = 1 @@ -509,6 +517,7 @@ t17 = do , "#else" , "x = 5" , "#endif" + , "" ] -- x = 1 @@ -525,6 +534,7 @@ t18 = do , "#else" , "x = 5" , "#endif" + , "" ] t19 :: IO () @@ -593,6 +603,7 @@ t22 = do , "also ignored" , "#endif" , "#endif" + , "" ] t23 :: IO () @@ -606,6 +617,7 @@ t23 = do , "#else" , "x = 2" , "#endif" + , "" ] t24 :: IO () @@ -619,6 +631,7 @@ t24 = do , "#else" , "x = 2" , "#endif" + , "" ] t25 :: IO () @@ -632,6 +645,7 @@ t25 = do , "#else" , "x = 2" , "#endif" + , "" ] t26 :: IO () @@ -662,6 +676,7 @@ t27 = do , "#ifdef DEBUG" , " hiding (rev)" , "#endif" + , "" ] t28 :: IO () ===================================== utils/check-cpp/ParsePP.hs ===================================== @@ -48,9 +48,10 @@ combineToks ss = intercalate " " ss cppDefine :: [Token] -> Either String CppDirective cppDefine [] = Left "error:empty #define directive" -cppDefine (TIdentifier n : ts) = Right $ CppDefine n args def +cppDefine (TIdentifierLParen n : ts) = Right $ CppDefine n args def where (args, def) = getArgs ts +cppDefine (TIdentifier n : ts) = Right $ CppDefine n Nothing ts cppDefine (t : _) = Left $ "#define: expecting an identifier, got :" ++ show t cppInclude :: [String] -> CppDirective @@ -80,14 +81,14 @@ cppDumpState _ts = CppDumpState -- --------------------------------------------------------------------- -- Crack out the arguments to a #define. This is of the form of --- comma-separated identifiers between parens +-- comma-separated identifiers between parens, where we have already +-- seen the opening paren. getArgs :: [Token] -> (Maybe [String], [Token]) getArgs [] = (Nothing, []) -getArgs (TOpenParen _ : ts) = +getArgs ts = case parseDefineArgs [] ts of Left err -> error err Right (args, rest) -> (Just (reverse args), rest) -getArgs ts = (Nothing, ts) parseDefineArgs :: [String] -> @@ -139,3 +140,5 @@ t2 = doATest "# if ((m1) < 1 || (m1) == 1 && (m2) < 7 || (m1) == 1 && (m2) == t3 :: Either String CppDirective t3 = parseDirective "# if FOO == 4" + +t4 = cppLex "#define foo(X) X" ===================================== utils/check-cpp/Parser.y ===================================== @@ -91,6 +91,7 @@ import qualified GHC.Internal.Data.Tuple as Happy_Prelude 'xor_eq' { TXorEq {} } identifier { TIdentifier {} } + identifierLP { TIdentifierLParen {} } integer { TInteger {} } string { TString {} } other { TOther {} } ===================================== utils/check-cpp/ParserM.hs ===================================== @@ -91,6 +91,7 @@ init_state = data Token = TEOF {t_str :: String} | TIdentifier {t_str :: String} + | TIdentifierLParen {t_str :: String} | TInteger {t_str :: String} | -- preprocessing-op-or-punc -- https://timsong-cpp.github.io/cppwp/n4140/lex.operators#nt:preprocessing-op-... ===================================== utils/check-cpp/State.hs ===================================== @@ -191,7 +191,7 @@ setAccepting on = do let possible_accepting = parent_on && on let (new_group_state, accepting) = case (group_state, possible_accepting) of - (PpNoGroup, v) -> error "setAccepting for state PpNoGroup" + (PpNoGroup, _) -> error "setAccepting for state PpNoGroup" (PpInGroupStillInactive, True) -> (PpInGroupHasBeenActive, True) (PpInGroupStillInactive, False) -> (PpInGroupStillInactive, False) (PpInGroupHasBeenActive, _) -> (PpInGroupHasBeenActive, False) @@ -317,7 +317,7 @@ addDefine name def = do addDefine' :: PpState -> MacroName -> MacroDef -> PpState addDefine' s name def = - s{pp_defines = insertMacroDef name def (pp_defines s)} + s{ pp_defines = insertMacroDef name def (pp_defines s)} ppDefine :: MacroName -> MacroDef -> PP () ppDefine name val = addDefine name val View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/937a9c4d2a142d0c7a4f29ce8515d348... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/937a9c4d2a142d0c7a4f29ce8515d348... You're receiving this email because of your account on gitlab.haskell.org.