[Git][ghc/ghc][wip/az/ghc-cpp] Process TIdentifierLParen

21 Apr 2025

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.

    

Alan Zimmerman (＠alanz)

tags

participants (1)