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

Commits:

13 changed files:

Changes:

  • compiler/GHC/Parser/PreProcess/Lexer.x
    ... ... @@ -92,10 +92,11 @@ words :-
    92 92
         <0>         "xor"                { mkTv TXor }
    
    93 93
         <0>         "xor_eq"             { mkTv TXorEq }
    
    94 94
     ----------------------------------------
    
    95
    -    <0>         [a-zA-Z_][a-zA-Z0-9_]* { mkTv TIdentifier }
    
    96
    -    <0>         \-? [0-9][0-9]*        { mkTv TInteger  }
    
    97
    -    <0>         \" [^\"]* \"           { mkTv (TString . tail . init) }
    
    98
    -    <0>         ()                     { begin other }
    
    95
    +    <0>         [a-zA-Z_][a-zA-Z0-9_]*\( { mkTv TIdentifierLParen }
    
    96
    +    <0>         [a-zA-Z_][a-zA-Z0-9_]*   { mkTv TIdentifier }
    
    97
    +    <0>         \-? [0-9][0-9]*          { mkTv TInteger  }
    
    98
    +    <0>         \" [^\"]* \"             { mkTv (TString . tail . init) }
    
    99
    +    <0>         ()                       { begin other }
    
    99 100
     
    
    100 101
         <other>     .+                   { \i -> do {setStartCode 0;
    
    101 102
                                                      mkTv TOther i} }
    

  • compiler/GHC/Parser/PreProcess/Macro.hs
    ... ... @@ -71,14 +71,18 @@ expandToks :: MacroDefines -> [Token] -> [Token]
    71 71
     expandToks s ts =
    
    72 72
         let
    
    73 73
             (expansionDone, r) = doExpandToks False s ts
    
    74
    -     in
    
    74
    +    in
    
    75 75
             if expansionDone
    
    76 76
                 then expandToks s r
    
    77 77
                 else r
    
    78 78
     
    
    79 79
     doExpandToks :: Bool -> MacroDefines -> [Token] -> (Bool, [Token])
    
    80 80
     doExpandToks ed _ [] = (ed, [])
    
    81
    -doExpandToks _ s (TIdentifier "defined" : ts) = (True, rest)
    
    81
    +doExpandToks ed s (TIdentifierLParen n: ts) =
    
    82
    +  -- TIdentifierLParen has no meaning here (only in a #define), so
    
    83
    +  -- restore it to its constituent tokens
    
    84
    +  doExpandToks ed s (TIdentifier n:TOpenParen "(":ts)
    
    85
    +doExpandToks _  s (TIdentifier "defined" : ts) = (True, rest)
    
    82 86
       -- See Note: [defined unary operator] below
    
    83 87
       where
    
    84 88
         rest = case getExpandArgs ts of
    

  • compiler/GHC/Parser/PreProcess/ParsePP.hs
    ... ... @@ -7,6 +7,7 @@ module GHC.Parser.PreProcess.ParsePP (
    7 7
         t1,
    
    8 8
         t2,
    
    9 9
         t3,
    
    10
    +    t4,
    
    10 11
     ) where
    
    11 12
     
    
    12 13
     import Data.List (intercalate)
    
    ... ... @@ -47,9 +48,10 @@ combineToks ss = intercalate " " ss
    47 48
     
    
    48 49
     cppDefine :: [Token] -> Either String CppDirective
    
    49 50
     cppDefine [] = Left "error:empty #define directive"
    
    50
    -cppDefine (TIdentifier n : ts) = Right $ CppDefine n args def
    
    51
    +cppDefine (TIdentifierLParen n : ts) = Right $ CppDefine n args def
    
    51 52
       where
    
    52 53
         (args, def) = getArgs ts
    
    54
    +cppDefine (TIdentifier n : ts) = Right $ CppDefine n Nothing ts
    
    53 55
     cppDefine (t : _) = Left $ "#define: expecting an identifier, got :" ++ show t
    
    54 56
     
    
    55 57
     cppInclude :: [String] -> CppDirective
    
    ... ... @@ -79,14 +81,14 @@ cppDumpState _ts = CppDumpState
    79 81
     -- ---------------------------------------------------------------------
    
    80 82
     
    
    81 83
     -- Crack out the arguments to a #define. This is of the form of
    
    82
    --- comma-separated identifiers between parens
    
    84
    +-- comma-separated identifiers between parens, where we have already
    
    85
    +-- seen the opening paren.
    
    83 86
     getArgs :: [Token] -> (Maybe [String], [Token])
    
    84 87
     getArgs [] = (Nothing, [])
    
    85
    -getArgs (TOpenParen _ : ts) =
    
    88
    +getArgs ts =
    
    86 89
         case parseDefineArgs [] ts of
    
    87 90
             Left err -> error err
    
    88 91
             Right (args, rest) -> (Just (reverse args), rest)
    
    89
    -getArgs ts = (Nothing, ts)
    
    90 92
     
    
    91 93
     parseDefineArgs ::
    
    92 94
         [String] ->
    
    ... ... @@ -138,3 +140,5 @@ t2 = doATest "# if ((m1) < 1 || (m1) == 1 && (m2) < 7 || (m1) == 1 && (m2) ==
    138 140
     
    
    139 141
     t3 :: Either String CppDirective
    
    140 142
     t3 = parseDirective "# if FOO == 4"
    
    143
    +
    
    144
    +t4 = cppLex "#define foo(X) X"

  • compiler/GHC/Parser/PreProcess/Parser.y
    ... ... @@ -92,6 +92,7 @@ import GHC.Prelude
    92 92
         'xor_eq'           { TXorEq {} }
    
    93 93
     
    
    94 94
         identifier         { TIdentifier {} }
    
    95
    +    identifierLP       { TIdentifierLParen {} }
    
    95 96
         integer            { TInteger {} }
    
    96 97
         string             { TString {} }
    
    97 98
         other              { TOther {} }
    

  • compiler/GHC/Parser/PreProcess/ParserM.hs
    ... ... @@ -91,6 +91,7 @@ init_state =
    91 91
     data Token
    
    92 92
         = TEOF {t_str :: String}
    
    93 93
         | TIdentifier {t_str :: String}
    
    94
    +    | TIdentifierLParen {t_str :: String}
    
    94 95
         | TInteger {t_str :: String}
    
    95 96
         | -- preprocessing-op-or-punc
    
    96 97
           -- https://timsong-cpp.github.io/cppwp/n4140/lex.operators#nt:preprocessing-op-or-punc
    

  • utils/check-cpp/Eval.hs
    ... ... @@ -8,7 +8,7 @@ eval :: Expr -> Int
    8 8
     eval (Parens e) = eval e
    
    9 9
     eval (Not e) = fromBool $ not (toBool $ eval e)
    
    10 10
     -- eval (Var v) = error $ "need to look up :" ++ v
    
    11
    -eval (Var v) = 0 -- Spec says remaining identifiers are replaces with zero
    
    11
    +eval (Var _) = 0 -- Spec says remaining identifiers are replaces with zero
    
    12 12
     eval (IntVal i) = i
    
    13 13
     eval (Plus e1 e2) = (eval e1) + (eval e2)
    
    14 14
     eval (Minus e1 e2) = (eval e1) - (eval e2)
    

  • utils/check-cpp/Lexer.x
    ... ... @@ -90,10 +90,11 @@ words :-
    90 90
         <0>         "xor"                { mkTv TXor }
    
    91 91
         <0>         "xor_eq"             { mkTv TXorEq }
    
    92 92
     ----------------------------------------
    
    93
    -    <0>         [a-zA-Z_][a-zA-Z0-9_]* { mkTv TIdentifier }
    
    94
    -    <0>         \-? [0-9][0-9]*        { mkTv TInteger  }
    
    95
    -    <0>         \" [^\"]* \"           { mkTv (TString . tail . init) }
    
    96
    -    <0>         ()                     { begin other }
    
    93
    +    <0>         [a-zA-Z_][a-zA-Z0-9_]*\( { mkTv TIdentifierLParen }
    
    94
    +    <0>         [a-zA-Z_][a-zA-Z0-9_]*   { mkTv TIdentifier }
    
    95
    +    <0>         \-? [0-9][0-9]*          { mkTv TInteger  }
    
    96
    +    <0>         \" [^\"]* \"             { mkTv (TString . tail . init) }
    
    97
    +    <0>         ()                       { begin other }
    
    97 98
     
    
    98 99
         <other>     .+                   { \i -> do {setStartCode 0;
    
    99 100
                                                      mkTv TOther i} }
    

  • utils/check-cpp/Macro.hs
    ... ... @@ -70,13 +70,17 @@ expandToks :: MacroDefines -> [Token] -> [Token]
    70 70
     expandToks s ts =
    
    71 71
         let
    
    72 72
             (expansionDone, r) = doExpandToks False s ts
    
    73
    -     in
    
    73
    +    in
    
    74 74
             if expansionDone
    
    75 75
                 then expandToks s r
    
    76 76
                 else r
    
    77 77
     
    
    78 78
     doExpandToks :: Bool -> MacroDefines -> [Token] -> (Bool, [Token])
    
    79 79
     doExpandToks ed _ [] = (ed, [])
    
    80
    +doExpandToks ed s (TIdentifierLParen n: ts) =
    
    81
    +  -- TIdentifierLParen has no meaning here (only in a #define), so
    
    82
    +  -- restore it to its constituent tokens
    
    83
    +  doExpandToks ed s (TIdentifier n:TOpenParen "(":ts)
    
    80 84
     doExpandToks _  s (TIdentifier "defined" : ts) = (True, rest)
    
    81 85
       -- See Note: [defined unary operator] below
    
    82 86
       where
    

  • utils/check-cpp/Main.hs
    ... ... @@ -280,6 +280,7 @@ t2 = do
    280 280
             , "#else"
    
    281 281
             , "x = 5"
    
    282 282
             , "#endif"
    
    283
    +        , ""
    
    283 284
             ]
    
    284 285
     
    
    285 286
     -- x = 5
    
    ... ... @@ -348,6 +349,7 @@ t4 = do
    348 349
             , "#else"
    
    349 350
             , "x = \"no version\""
    
    350 351
             , "#endif"
    
    352
    +        , ""
    
    351 353
             ]
    
    352 354
     
    
    353 355
     -- x = "got version"
    
    ... ... @@ -399,6 +401,7 @@ t10 = do
    399 401
             , "#else"
    
    400 402
             , "x = 2"
    
    401 403
             , "#endif"
    
    404
    +        , ""
    
    402 405
             ]
    
    403 406
     
    
    404 407
     -- x = 1
    
    ... ... @@ -424,6 +427,7 @@ t11 = do
    424 427
             , "#else"
    
    425 428
             , "x = 5"
    
    426 429
             , "#endif"
    
    430
    +        , ""
    
    427 431
             ]
    
    428 432
     
    
    429 433
     -- x = 1
    
    ... ... @@ -438,6 +442,7 @@ t12 = do
    438 442
             , "#else"
    
    439 443
             , "x = 5"
    
    440 444
             , "#endif"
    
    445
    +        , ""
    
    441 446
             ]
    
    442 447
     
    
    443 448
     -- x = 1
    
    ... ... @@ -450,6 +455,7 @@ t13 = do
    450 455
             , "#else"
    
    451 456
             , "x = 5"
    
    452 457
             , "#endif"
    
    458
    +        , ""
    
    453 459
             ]
    
    454 460
     
    
    455 461
     -- x = 1
    
    ... ... @@ -473,6 +479,7 @@ t14 = do
    473 479
             , "#else"
    
    474 480
             , "z = 5"
    
    475 481
             , "#endif"
    
    482
    +        , ""
    
    476 483
             ]
    
    477 484
     
    
    478 485
     -- x = 1
    
    ... ... @@ -496,6 +503,7 @@ t16 = do
    496 503
             , "#else"
    
    497 504
             , "x = 5"
    
    498 505
             , "#endif"
    
    506
    +        , ""
    
    499 507
             ]
    
    500 508
     
    
    501 509
     -- x = 1
    
    ... ... @@ -509,6 +517,7 @@ t17 = do
    509 517
             , "#else"
    
    510 518
             , "x = 5"
    
    511 519
             , "#endif"
    
    520
    +        , ""
    
    512 521
             ]
    
    513 522
     
    
    514 523
     -- x = 1
    
    ... ... @@ -525,6 +534,7 @@ t18 = do
    525 534
             , "#else"
    
    526 535
             , "x = 5"
    
    527 536
             , "#endif"
    
    537
    +        , ""
    
    528 538
             ]
    
    529 539
     
    
    530 540
     t19 :: IO ()
    
    ... ... @@ -593,6 +603,7 @@ t22 = do
    593 603
             , "also ignored"
    
    594 604
             , "#endif"
    
    595 605
             , "#endif"
    
    606
    +        , ""
    
    596 607
             ]
    
    597 608
     
    
    598 609
     t23 :: IO ()
    
    ... ... @@ -606,6 +617,7 @@ t23 = do
    606 617
             , "#else"
    
    607 618
             , "x = 2"
    
    608 619
             , "#endif"
    
    620
    +        , ""
    
    609 621
             ]
    
    610 622
     
    
    611 623
     t24 :: IO ()
    
    ... ... @@ -619,6 +631,7 @@ t24 = do
    619 631
             , "#else"
    
    620 632
             , "x = 2"
    
    621 633
             , "#endif"
    
    634
    +        , ""
    
    622 635
             ]
    
    623 636
     
    
    624 637
     t25 :: IO ()
    
    ... ... @@ -632,6 +645,7 @@ t25 = do
    632 645
             , "#else"
    
    633 646
             , "x = 2"
    
    634 647
             , "#endif"
    
    648
    +        , ""
    
    635 649
             ]
    
    636 650
     
    
    637 651
     t26 :: IO ()
    
    ... ... @@ -662,6 +676,7 @@ t27 = do
    662 676
             , "#ifdef DEBUG"
    
    663 677
             , "                                 hiding (rev)"
    
    664 678
             , "#endif"
    
    679
    +        , ""
    
    665 680
             ]
    
    666 681
     
    
    667 682
     t28 :: IO ()
    

  • utils/check-cpp/ParsePP.hs
    ... ... @@ -48,9 +48,10 @@ combineToks ss = intercalate " " ss
    48 48
     
    
    49 49
     cppDefine :: [Token] -> Either String CppDirective
    
    50 50
     cppDefine [] = Left "error:empty #define directive"
    
    51
    -cppDefine (TIdentifier n : ts) = Right $ CppDefine n args def
    
    51
    +cppDefine (TIdentifierLParen n : ts) = Right $ CppDefine n args def
    
    52 52
       where
    
    53 53
         (args, def) = getArgs ts
    
    54
    +cppDefine (TIdentifier n : ts) = Right $ CppDefine n Nothing ts
    
    54 55
     cppDefine (t : _) = Left $ "#define: expecting an identifier, got :" ++ show t
    
    55 56
     
    
    56 57
     cppInclude :: [String] -> CppDirective
    
    ... ... @@ -80,14 +81,14 @@ cppDumpState _ts = CppDumpState
    80 81
     -- ---------------------------------------------------------------------
    
    81 82
     
    
    82 83
     -- Crack out the arguments to a #define. This is of the form of
    
    83
    --- comma-separated identifiers between parens
    
    84
    +-- comma-separated identifiers between parens, where we have already
    
    85
    +-- seen the opening paren.
    
    84 86
     getArgs :: [Token] -> (Maybe [String], [Token])
    
    85 87
     getArgs [] = (Nothing, [])
    
    86
    -getArgs (TOpenParen _ : ts) =
    
    88
    +getArgs ts =
    
    87 89
         case parseDefineArgs [] ts of
    
    88 90
             Left err -> error err
    
    89 91
             Right (args, rest) -> (Just (reverse args), rest)
    
    90
    -getArgs ts = (Nothing, ts)
    
    91 92
     
    
    92 93
     parseDefineArgs ::
    
    93 94
         [String] ->
    
    ... ... @@ -139,3 +140,5 @@ t2 = doATest "# if ((m1) < 1 || (m1) == 1 && (m2) < 7 || (m1) == 1 && (m2) ==
    139 140
     
    
    140 141
     t3 :: Either String CppDirective
    
    141 142
     t3 = parseDirective "# if FOO == 4"
    
    143
    +
    
    144
    +t4 = cppLex "#define foo(X) X"

  • utils/check-cpp/Parser.y
    ... ... @@ -91,6 +91,7 @@ import qualified GHC.Internal.Data.Tuple as Happy_Prelude
    91 91
         'xor_eq'           { TXorEq {} }
    
    92 92
     
    
    93 93
         identifier         { TIdentifier {} }
    
    94
    +    identifierLP       { TIdentifierLParen {} }
    
    94 95
         integer            { TInteger {} }
    
    95 96
         string             { TString {} }
    
    96 97
         other              { TOther {} }
    

  • utils/check-cpp/ParserM.hs
    ... ... @@ -91,6 +91,7 @@ init_state =
    91 91
     data Token
    
    92 92
         = TEOF {t_str :: String}
    
    93 93
         | TIdentifier {t_str :: String}
    
    94
    +    | TIdentifierLParen {t_str :: String}
    
    94 95
         | TInteger {t_str :: String}
    
    95 96
         | -- preprocessing-op-or-punc
    
    96 97
           -- https://timsong-cpp.github.io/cppwp/n4140/lex.operators#nt:preprocessing-op-or-punc
    

  • utils/check-cpp/State.hs
    ... ... @@ -191,7 +191,7 @@ setAccepting on = do
    191 191
       let possible_accepting = parent_on && on
    
    192 192
       let (new_group_state, accepting) =
    
    193 193
             case (group_state, possible_accepting) of
    
    194
    -          (PpNoGroup, v) -> error "setAccepting for state PpNoGroup"
    
    194
    +          (PpNoGroup, _) -> error "setAccepting for state PpNoGroup"
    
    195 195
               (PpInGroupStillInactive, True) -> (PpInGroupHasBeenActive, True)
    
    196 196
               (PpInGroupStillInactive, False) -> (PpInGroupStillInactive, False)
    
    197 197
               (PpInGroupHasBeenActive, _) -> (PpInGroupHasBeenActive, False)
    
    ... ... @@ -317,7 +317,7 @@ addDefine name def = do
    317 317
     
    
    318 318
     addDefine' :: PpState -> MacroName -> MacroDef -> PpState
    
    319 319
     addDefine' s name def =
    
    320
    -    s{pp_defines = insertMacroDef name def (pp_defines s)}
    
    320
    +    s{ pp_defines = insertMacroDef name def (pp_defines s)}
    
    321 321
     
    
    322 322
     ppDefine :: MacroName -> MacroDef -> PP ()
    
    323 323
     ppDefine name val = addDefine name val