[Git][ghc/ghc][wip/az/ghc-cpp] Implement GHC_CPP undef

27 Apr 2025


      Alan Zimmerman pushed to branch wip/az/ghc-cpp at Glasgow Haskell Compiler / GHC


Commits:
53aa9b6a by Alan Zimmerman at 2025-04-27T13:28:33+01:00
Implement GHC_CPP undef

- - - - -


9 changed files:

- compiler/GHC/Parser/PreProcess.hs
- compiler/GHC/Parser/PreProcess/ParsePP.hs
- compiler/GHC/Parser/PreProcess/State.hs
- testsuite/tests/ghc-cpp/GhcCpp01.hs
- testsuite/tests/ghc-cpp/GhcCpp01.stderr
- utils/check-cpp/Main.hs
- utils/check-cpp/ParsePP.hs
- utils/check-cpp/PreProcess.hs
- utils/check-cpp/State.hs


Changes:

=====================================
compiler/GHC/Parser/PreProcess.hs
=====================================
@@ -264,6 +264,8 @@ processCpp ss = do
                     ppInclude filename
                 Right (CppDefine name args def) -> do
                     ppDefine (MacroName name args) def
+                Right (CppUndef name) -> do
+                    ppUndef name
                 Right (CppIf cond) -> do
                     val <- cppCond cond
                     ar <- pushAccepting val


=====================================
compiler/GHC/Parser/PreProcess/ParsePP.hs
=====================================
@@ -29,6 +29,7 @@ parseDirective s =
         Right toks ->
             case toks of
                 (THash "#" : TIdentifier "define" : ts) -> cppDefine ts
+                (THash "#" : TIdentifier "undef" : ts) -> Right $ cppUndef (map t_str ts)
                 (THash "#" : TIdentifier "include" : ts) -> Right $ cppInclude (map t_str ts)
                 (THash "#" : TIdentifier "if" : ts) -> Right $ cppIf (map t_str ts)
                 (THash "#" : TIdentifier "ifndef" : ts) -> Right $ cppIfndef (map t_str ts)
@@ -54,6 +55,9 @@ cppDefine (TIdentifierLParen n : ts) = Right $ CppDefine (init n) args def
 cppDefine (TIdentifier n : ts) = Right $ CppDefine n Nothing ts
 cppDefine (t : _) = Left $ "#define: expecting an identifier, got :" ++ show t
 
+cppUndef :: [String] -> CppDirective
+cppUndef ts = CppUndef (combineToks ts)
+
 cppInclude :: [String] -> CppDirective
 cppInclude ts = CppInclude (combineToks ts)
 


=====================================
compiler/GHC/Parser/PreProcess/State.hs
=====================================
@@ -27,6 +27,7 @@ module GHC.Parser.PreProcess.State (
     popContinuation,
     ppDefine,
     ppIsDefined,
+    ppUndef,
     getCppState,
     ghcCppEnabled,
     setInLinePragma,
@@ -98,6 +99,7 @@ data CppDirective
     = CppInclude String
     | -- | name, optional args, replacement
       CppDefine String (Maybe [String]) MacroDef
+    | CppUndef String
     | CppIfdef String
     | CppIfndef String
     | CppIf String
@@ -332,9 +334,25 @@ addDefine' :: PpState -> MacroName -> MacroDef -> PpState
 addDefine' s name def =
     s{pp_defines = insertMacroDef name def (pp_defines s)}
 
+removeDefine :: String -> PP ()
+removeDefine name = do
+    accepting <- getAccepting
+    when accepting $ do
+        s <- getPpState
+        setPpState $ removeDefine' s name
+
+removeDefine' :: PpState -> String -> PpState
+removeDefine' s name =
+    s{pp_defines = Map.delete name (pp_defines s)}
+
+-- -------------------------------------
+
 ppDefine :: MacroName -> MacroDef -> PP ()
 ppDefine name val = addDefine name val
 
+ppUndef :: String -> PP ()
+ppUndef name = removeDefine name
+
 ppIsDefined :: MacroName -> PP Bool
 ppIsDefined name = do
     s <- getPpState


=====================================
testsuite/tests/ghc-cpp/GhcCpp01.hs
=====================================
@@ -18,3 +18,18 @@ x = 5
 #if defined(BAR) || defined FOO
 y = 1
 #endif
+
+#undef FOO
+#ifdef FOO
+complete junk!
+#endif
+
+-- nested undef
+#define AA
+#if 0
+#undef AA
+#endif
+
+#ifdef AA
+aa = 1
+#endif


=====================================
testsuite/tests/ghc-cpp/GhcCpp01.stderr
=====================================
@@ -4,8 +4,7 @@
 ------------------------------
 
 
-#define FOO(A,B) A + B
-#define FOO(A,B,C) A + B + C
+#define AA 
 
 
 #define MIN_VERSION_Cabal(major1,major2,minor) ( ( major1 ) < 3 || ( major1 ) == 3 && ( major2 ) < 14 || ( major1 ) == 3 && ( major2 ) == 14 && ( minor ) <= 1 )
@@ -216,6 +215,29 @@
   |
   
 - |#if de
+
+- |#endif
+
+- |
+
+- |#undef FOO
+
+- |#ifdef
+
+- |#endif
+
+- |
+
+- |-- ne
+- |#define A
+- |#if 0
+
+
+- |#endif
+
+  |
+  
+- |#ifdef
   |
 ------------------------------
 


=====================================
utils/check-cpp/Main.hs
=====================================
@@ -783,6 +783,7 @@ t33 = do
 t34 :: IO ()
 t34 = do
     dump
+
         [ "{-# LANGUAGE GHC_CPP #-}"
         , "module Example4 where"
         , ""
@@ -799,3 +800,23 @@ t34 = do
         , "#endif"
         , ""
         ]
+
+t35 :: IO ()
+t35 = do
+    dump
+        [ "{-# LANGUAGE GHC_CPP #-}"
+        , "module Example14 where"
+
+        , "#define FOO"
+        , "#define FOO(X) X"
+        , ""
+        , "#undef FOO"
+        , ""
+        , "foo ="
+        , "#ifdef FOO"
+        , "  'a'"
+        , "#else"
+        , "  'b'"
+        , "#endif"
+        , ""
+        ]


=====================================
utils/check-cpp/ParsePP.hs
=====================================
@@ -29,6 +29,7 @@ parseDirective s =
         Right toks ->
             case toks of
                 (THash "#" : TIdentifier "define" : ts) -> cppDefine ts
+                (THash "#" : TIdentifier "undef" : ts) -> Right $ cppUndef (map t_str ts)
                 (THash "#" : TIdentifier "include" : ts) -> Right $ cppInclude (map t_str ts)
                 (THash "#" : TIdentifier "if" : ts) -> Right $ cppIf (map t_str ts)
                 (THash "#" : TIdentifier "ifndef" : ts) -> Right $ cppIfndef (map t_str ts)
@@ -54,6 +55,9 @@ cppDefine (TIdentifierLParen n : ts) = Right $ CppDefine (init n) args def
 cppDefine (TIdentifier n : ts) = Right $ CppDefine n Nothing ts
 cppDefine (t : _) = Left $ "#define: expecting an identifier, got :" ++ show t
 
+cppUndef :: [String] -> CppDirective
+cppUndef ts = CppUndef (combineToks ts)
+
 cppInclude :: [String] -> CppDirective
 cppInclude ts = CppInclude (combineToks ts)
 


=====================================
utils/check-cpp/PreProcess.hs
=====================================
@@ -293,6 +293,8 @@ processCpp ss = do
                     ppInclude filename
                 Right (CppDefine name args def) -> do
                     ppDefine (MacroName name args) def
+                Right (CppUndef name) -> do
+                    ppUndef name
                 Right (CppIf cond) -> do
                     val <- cppCond cond
                     ar <- pushAccepting val


=====================================
utils/check-cpp/State.hs
=====================================
@@ -27,6 +27,7 @@ module State (
     popContinuation,
     ppDefine,
     ppIsDefined,
+    ppUndef,
     getCppState,
     ghcCppEnabled,
     setInLinePragma,
@@ -99,6 +100,7 @@ data CppDirective
     = CppInclude String
     | -- | name, optional args, replacement
       CppDefine String (Maybe [String]) MacroDef
+    | CppUndef String
     | CppIfdef String
     | CppIfndef String
     | CppIf String
@@ -333,9 +335,25 @@ addDefine' :: PpState -> MacroName -> MacroDef -> PpState
 addDefine' s name def =
     s{pp_defines = insertMacroDef name def (pp_defines s)}
 
+removeDefine :: String -> PP ()
+removeDefine name = do
+    accepting <- getAccepting
+    when accepting $ do
+        s <- getPpState
+        setPpState $ removeDefine' s name
+
+removeDefine' :: PpState -> String -> PpState
+removeDefine' s name =
+    s{pp_defines = Map.delete name (pp_defines s)}
+
+-- -------------------------------------
+
 ppDefine :: MacroName -> MacroDef -> PP ()
 ppDefine name val = addDefine name val
 
+ppUndef :: String -> PP ()
+ppUndef name = removeDefine name
+
 ppIsDefined :: MacroName -> PP Bool
 ppIsDefined name = do
     s <- getPpState



View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/53aa9b6a95ca7b721c8ff0b90074f9da...

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/53aa9b6a95ca7b721c8ff0b90074f9da...
You're receiving this email because of your account on gitlab.haskell.org.

    

Alan Zimmerman (＠alanz)

tags

participants (1)