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

Commits:

5 changed files:

Changes:

  • compiler/GHC/Parser/PreProcess.hs
    ... ... @@ -270,7 +270,7 @@ processCpp loc s = do
    270 270 
                     Right (CppUndef name) -> do
    271 271 
                         ppUndef name
    272 272 
                     Right (CppIf cond) -> do
    273 
    -                    val <- cppCond cond
    273 
    +                    val <- cppCond loc cond
    274 274 
                         ar <- pushAccepting val
    275 275 
                         acceptStateChange ar
    276 276 
                     Right (CppIfdef name) -> do
    ... ... @@ -286,7 +286,7 @@ processCpp loc s = do
    286 286 
                         ar <- setAccepting loc (text "#else") (not accepting)
    287 287 
                         acceptStateChange ar
    288 288 
                     Right (CppElIf cond) -> do
    289 
    -                    val <- cppCond cond
    289 
    +                    val <- cppCond loc cond
    290 290 
                         ar <- setAccepting loc (text "#elif") val
    291 291 
                         acceptStateChange ar
    292 292 
                     Right CppEndif -> do

  • compiler/GHC/Parser/PreProcess/Macro.hs
    ... ... @@ -32,29 +32,35 @@ details
    32 32
    33 33 
     -- TODO: Parse tokens with original locations in them.
    34 34
    35 
    -import qualified Data.Map as Map
    35 
    +import Data.Map qualified as Map
    36 36 
     import Data.Maybe
    37 37
    38 
    +import Data.Semigroup qualified as S
    38 39 
     import GHC.Parser.PreProcess.Eval
    39 40 
     import GHC.Parser.PreProcess.ParsePP
    40 41 
     import GHC.Parser.PreProcess.Parser qualified as Parser
    41 42 
     import GHC.Parser.PreProcess.ParserM
    42 43 
     import GHC.Parser.PreProcess.State
    43 
    -import qualified Data.Semigroup as S
    44 44 
     import GHC.Prelude
    45 
    +import GHC.Types.SrcLoc
    46 
    +import GHC.Utils.Outputable
    45 47
    46 48 
     -- ---------------------------------------------------------------------
    47 49
    48 50 
     --    We evaluate to an Int, which we convert to a bool
    49 
    -cppCond :: String -> PP Bool
    50 
    -cppCond str = do
    51 
    -  s <- getPpState
    52 
    -  let
    53 
    -    expanded = expand (pp_defines s) str
    54 
    -    v = case Parser.parseExpr expanded of
    55 
    -        Left err -> error $ "parseExpr:" ++ show (err, expanded)
    56 
    -        Right tree -> eval tree
    57 
    -  return (toBool v)
    51 
    +cppCond :: SrcSpan -> String -> PP Bool
    52 
    +cppCond loc str = do
    53 
    +    s <- getPpState
    54 
    +    let
    55 
    +        expanded = expand (pp_defines s) str
    56 
    +    v <- case Parser.parseExpr expanded of
    57 
    +        Left err -> do
    58 
    +            addGhcCPPError loc
    59 
    +              (hang (text "Error evaluating CPP condition:") 2
    60 
    +               (text err <+> text "of" $+$ text expanded))
    61 
    +            return 0
    62 
    +        Right tree -> return (eval tree)
    63 
    +    return (toBool v)
    58 64
    59 65 
     -- ---------------------------------------------------------------------
    60 66
    ... ... @@ -75,31 +81,32 @@ expandToks 0 _ ts = error $ "macro_expansion limit (" ++ show maxExpansions ++ "
    75 81 
     expandToks cnt s ts =
    76 82 
         let
    77 83 
             (!expansionDone, !r) = doExpandToks False s ts
    78 
    -    in
    84 
    +     in
    79 85 
             if expansionDone
    80 
    -            then expandToks (cnt -1) s r
    86 
    +            then expandToks (cnt - 1) s r
    81 87 
                 else r
    82 88
    83 89 
     doExpandToks :: Bool -> MacroDefines -> [Token] -> (Bool, [Token])
    84 90 
     doExpandToks ed _ [] = (ed, [])
    85 
    -doExpandToks ed s (TIdentifierLParen n: ts) =
    86 
    -  -- TIdentifierLParen has no meaning here (only in a #define), so
    87 
    -  -- restore it to its constituent tokens
    88 
    -  doExpandToks ed s (TIdentifier (init n):TOpenParen "(":ts)
    89 
    -doExpandToks _  s (TIdentifier "defined" : ts) = (True, rest)
    90 
    -  -- See Note: [defined unary operator] below
    91 
    +doExpandToks ed s (TIdentifierLParen n : ts) =
    92 
    +    -- TIdentifierLParen has no meaning here (only in a #define), so
    93 
    +    -- restore it to its constituent tokens
    94 
    +    doExpandToks ed s (TIdentifier (init n) : TOpenParen "(" : ts)
    95 
    +doExpandToks _ s (TIdentifier "defined" : ts) = (True, rest)
    91 96 
       where
    97 
    +    -- See Note: [defined unary operator] below
    98 
    +
    92 99 
         rest = case getExpandArgs ts of
    93 
    -      (Just [[TIdentifier macro_name]], rest0) ->
    94 
    -        case Map.lookup macro_name s of
    95 
    -          Nothing -> TInteger "0" : rest0
    96 
    -          Just _ ->TInteger "1" : rest0
    97 
    -      (Nothing, TIdentifier macro_name:ts0) ->
    98 
    -        case Map.lookup macro_name s of
    99 
    -          Nothing -> TInteger "0" : ts0
    100 
    -          Just _ ->TInteger "1" : ts0
    101 
    -      (Nothing,_) -> error $ "defined: expected an identifier, got:" ++ show ts
    102 
    -      (Just args,_) -> error $ "defined: expected a single arg, got:" ++ show args
    100 
    +        (Just [[TIdentifier macro_name]], rest0) ->
    101 
    +            case Map.lookup macro_name s of
    102 
    +                Nothing -> TInteger "0" : rest0
    103 
    +                Just _ -> TInteger "1" : rest0
    104 
    +        (Nothing, TIdentifier macro_name : ts0) ->
    105 
    +            case Map.lookup macro_name s of
    106 
    +                Nothing -> TInteger "0" : ts0
    107 
    +                Just _ -> TInteger "1" : ts0
    108 
    +        (Nothing, _) -> error $ "defined: expected an identifier, got:" ++ show ts
    109 
    +        (Just args, _) -> error $ "defined: expected a single arg, got:" ++ show args
    103 110 
     doExpandToks ed s (TIdentifier n : ts) = (ed'', expanded ++ rest)
    104 111 
       where
    105 112 
         (ed', expanded, ts') = case Map.lookup n s of

  • compiler/GHC/Parser/PreProcess/State.hs
    ... ... @@ -238,18 +238,6 @@ acceptingStateChange old new =
    238 238
    239 239 
     -- Exit a scope group
    240 240 
     popAccepting :: SrcSpan -> PP AcceptingResult
    241 
    --- popAccepting =
    242 
    ---     P $ \s ->
    243 
    ---         let
    244 
    ---             current = scopeValue $ pp_scope (pp s)
    245 
    ---             new_scope = case pp_scope (pp s) of
    246 
    ---                 c :| [] -> c :| []
    247 
    ---                 -- c :| [] -> (trace ("popAccepting:keeping old:" ++ show c) c) :| []
    248 
    ---                 _ :| (h : t) -> h :| t
    249 
    ---          in
    250 
    ---             POk
    251 
    ---                 s{pp = (pp s){pp_scope = new_scope}}
    252 
    ---                 (acceptingStateChange current (scopeValue new_scope))
    253 241 
     popAccepting loc = do
    254 242 
       scopes <- getScopes
    255 243 
       new_scope <- case scopes of

  • testsuite/tests/ghc-cpp/GhcCpp02.hs
    ... ... @@ -5,3 +5,10 @@ foo =
    5 5 
     #else
    6 6 
         13
    7 7 
     #endif
    8 
    +
    9 
    +#define EXISTENT_MACRO(X) 2 + NONEXISTENT_MACRO(X)
    10 
    +
    11 
    +-- Note the evaluation error is reported on the *expanded* macro
    12 
    +#if EXISTENT_MACRO(4)
    13 
    +bar = 3
    14 
    +#endif

  • testsuite/tests/ghc-cpp/GhcCpp02.stderr
    ... ... @@ -2,3 +2,8 @@ GhcCpp02.hs:5:1: error: [GHC-93098] #else without #if
    2 2
    3 3 
     GhcCpp02.hs:7:1: error: [GHC-93098] #endif without #if
    4 4
    5 
    +GhcCpp02.hs:12:1: error: [GHC-93098]
    6 
    +    Error evaluating CPP condition:
    7 
    +      Parse error at line 1, column 23 of
    8 
    +      2 + NONEXISTENT_MACRO ( 4 )
    9 
    +

    • —
    View it on GitLab.
    You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications · Help