| ... |
... |
@@ -51,78 +51,97 @@ import GHC.Utils.Outputable |
|
51
|
51
|
cppCond :: SrcSpan -> String -> PP Bool
|
|
52
|
52
|
cppCond loc str = do
|
|
53
|
53
|
s <- getPpState
|
|
54
|
|
- let
|
|
55
|
|
- expanded = expand (pp_defines s) str
|
|
|
54
|
+ expanded <- expand loc (pp_defines s) str
|
|
56
|
55
|
v <- case Parser.parseExpr expanded of
|
|
57
|
56
|
Left err -> do
|
|
58
|
|
- addGhcCPPError loc
|
|
59
|
|
- (hang (text "Error evaluating CPP condition:") 2
|
|
60
|
|
- (text err <+> text "of" $+$ text expanded))
|
|
|
57
|
+ addGhcCPPError
|
|
|
58
|
+ loc
|
|
|
59
|
+ ( hang
|
|
|
60
|
+ (text "Error evaluating CPP condition:")
|
|
|
61
|
+ 2
|
|
|
62
|
+ (text err <+> text "of" $+$ text expanded)
|
|
|
63
|
+ )
|
|
61
|
64
|
return 0
|
|
62
|
65
|
Right tree -> return (eval tree)
|
|
63
|
66
|
return (toBool v)
|
|
64
|
67
|
|
|
65
|
68
|
-- ---------------------------------------------------------------------
|
|
66
|
69
|
|
|
67
|
|
-expand :: MacroDefines -> String -> String
|
|
68
|
|
-expand s str = expanded
|
|
69
|
|
- where
|
|
70
|
|
- -- TODO: repeat until re-expand or fixpoint
|
|
71
|
|
- toks = case cppLex False str of
|
|
72
|
|
- Left err -> error $ "expand:" ++ show (err, str)
|
|
73
|
|
- Right tks -> tks
|
|
74
|
|
- expanded = combineToks $ map t_str $ expandToks maxExpansions s toks
|
|
|
70
|
+expand :: SrcSpan -> MacroDefines -> String -> PP String
|
|
|
71
|
+expand loc s str = do
|
|
|
72
|
+ toks <- case cppLex False str of
|
|
|
73
|
+ Left err -> do
|
|
|
74
|
+ addGhcCPPError
|
|
|
75
|
+ loc
|
|
|
76
|
+ ( hang
|
|
|
77
|
+ (text "Error evaluating CPP condition1:") -- AZ:TODO remove 1
|
|
|
78
|
+ 2
|
|
|
79
|
+ (text err <+> text "of" $+$ text str)
|
|
|
80
|
+ )
|
|
|
81
|
+ return []
|
|
|
82
|
+ Right tks -> return tks
|
|
|
83
|
+ expandedToks <- expandToks loc maxExpansions s toks
|
|
|
84
|
+ return $ combineToks $ map t_str expandedToks
|
|
75
|
85
|
|
|
76
|
86
|
maxExpansions :: Int
|
|
77
|
87
|
maxExpansions = 15
|
|
78
|
88
|
|
|
79
|
|
-expandToks :: Int -> MacroDefines -> [Token] -> [Token]
|
|
80
|
|
-expandToks 0 _ ts = error $ "macro_expansion limit (" ++ show maxExpansions ++ ") hit, aborting. ts=" ++ show ts
|
|
81
|
|
-expandToks cnt s ts =
|
|
82
|
|
- let
|
|
83
|
|
- (!expansionDone, !r) = doExpandToks False s ts
|
|
84
|
|
- in
|
|
85
|
|
- if expansionDone
|
|
86
|
|
- then expandToks (cnt - 1) s r
|
|
87
|
|
- else r
|
|
88
|
|
-
|
|
89
|
|
-doExpandToks :: Bool -> MacroDefines -> [Token] -> (Bool, [Token])
|
|
90
|
|
-doExpandToks ed _ [] = (ed, [])
|
|
91
|
|
-doExpandToks ed s (TIdentifierLParen n : ts) =
|
|
|
89
|
+expandToks :: SrcSpan -> Int -> MacroDefines -> [Token] -> PP [Token]
|
|
|
90
|
+expandToks loc 0 _ ts = do
|
|
|
91
|
+ -- error $ "macro_expansion limit (" ++ show maxExpansions ++ ") hit, aborting. ts=" ++ show ts
|
|
|
92
|
+ addGhcCPPError
|
|
|
93
|
+ loc
|
|
|
94
|
+ ( hang
|
|
|
95
|
+ (text "CPP macro expansion limit hit:")
|
|
|
96
|
+ 2
|
|
|
97
|
+ (text (combineToks $ map t_str ts))
|
|
|
98
|
+ )
|
|
|
99
|
+ return ts
|
|
|
100
|
+expandToks loc cnt s ts = do
|
|
|
101
|
+ (!expansionDone, !r) <- doExpandToks loc False s ts
|
|
|
102
|
+ if expansionDone
|
|
|
103
|
+ then expandToks loc (cnt - 1) s r
|
|
|
104
|
+ else return r
|
|
|
105
|
+
|
|
|
106
|
+doExpandToks :: SrcSpan -> Bool -> MacroDefines -> [Token] -> PP (Bool, [Token])
|
|
|
107
|
+doExpandToks _loc ed _ [] = return (ed, [])
|
|
|
108
|
+doExpandToks loc ed s (TIdentifierLParen n : ts) =
|
|
92
|
109
|
-- TIdentifierLParen has no meaning here (only in a #define), so
|
|
93
|
110
|
-- restore it to its constituent tokens
|
|
94
|
|
- doExpandToks ed s (TIdentifier (init n) : TOpenParen "(" : ts)
|
|
95
|
|
-doExpandToks _ s (TIdentifier "defined" : ts) = (True, rest)
|
|
96
|
|
- where
|
|
97
|
|
- -- See Note: [defined unary operator] below
|
|
98
|
|
-
|
|
99
|
|
- rest = case getExpandArgs ts of
|
|
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
|
|
110
|
|
-doExpandToks ed s (TIdentifier n : ts) = (ed'', expanded ++ rest)
|
|
111
|
|
- where
|
|
112
|
|
- (ed', expanded, ts') = case Map.lookup n s of
|
|
113
|
|
- Nothing -> (ed, [TIdentifier n], ts)
|
|
114
|
|
- Just defs -> (ed0, r, rest1)
|
|
115
|
|
- where
|
|
116
|
|
- (args, rest0) = getExpandArgs ts
|
|
117
|
|
- fallbackArgs = fromMaybe (Nothing, [TIdentifier n]) (Map.lookup Nothing defs)
|
|
118
|
|
- (m_args, rhs) = fromMaybe fallbackArgs (Map.lookup (arg_arity args) defs)
|
|
119
|
|
- (ed0, r, rest1) = case m_args of
|
|
120
|
|
- Nothing -> (True, rhs, ts)
|
|
121
|
|
- Just _ -> (True, replace_args args m_args rhs, rest0)
|
|
122
|
|
- (ed'', rest) = doExpandToks ed' s ts'
|
|
123
|
|
-doExpandToks ed s (t : ts) = (ed', t : r)
|
|
124
|
|
- where
|
|
125
|
|
- (ed', r) = doExpandToks ed s ts
|
|
|
111
|
+ doExpandToks loc ed s (TIdentifier (init n) : TOpenParen "(" : ts)
|
|
|
112
|
+doExpandToks loc _ s (TIdentifier "defined" : ts) = do
|
|
|
113
|
+ let
|
|
|
114
|
+ -- See Note: [defined unary operator] below
|
|
|
115
|
+
|
|
|
116
|
+ rest = case getExpandArgs ts of
|
|
|
117
|
+ (Just [[TIdentifier macro_name]], rest0) ->
|
|
|
118
|
+ case Map.lookup macro_name s of
|
|
|
119
|
+ Nothing -> TInteger "0" : rest0
|
|
|
120
|
+ Just _ -> TInteger "1" : rest0
|
|
|
121
|
+ (Nothing, TIdentifier macro_name : ts0) ->
|
|
|
122
|
+ case Map.lookup macro_name s of
|
|
|
123
|
+ Nothing -> TInteger "0" : ts0
|
|
|
124
|
+ Just _ -> TInteger "1" : ts0
|
|
|
125
|
+ (Nothing, _) -> error $ "defined: expected an identifier, got:" ++ show ts
|
|
|
126
|
+ (Just args, _) -> error $ "defined: expected a single arg, got:" ++ show args
|
|
|
127
|
+ return (True, rest)
|
|
|
128
|
+doExpandToks loc ed s (TIdentifier n : ts) = do
|
|
|
129
|
+ let
|
|
|
130
|
+ (ed', expanded, ts') = case Map.lookup n s of
|
|
|
131
|
+ Nothing -> (ed, [TIdentifier n], ts)
|
|
|
132
|
+ Just defs -> (ed0, r, rest1)
|
|
|
133
|
+ where
|
|
|
134
|
+ (args, rest0) = getExpandArgs ts
|
|
|
135
|
+ fallbackArgs = fromMaybe (Nothing, [TIdentifier n]) (Map.lookup Nothing defs)
|
|
|
136
|
+ (m_args, rhs) = fromMaybe fallbackArgs (Map.lookup (arg_arity args) defs)
|
|
|
137
|
+ (ed0, r, rest1) = case m_args of
|
|
|
138
|
+ Nothing -> (True, rhs, ts)
|
|
|
139
|
+ Just _ -> (True, replace_args args m_args rhs, rest0)
|
|
|
140
|
+ (ed'', rest) <- doExpandToks loc ed' s ts'
|
|
|
141
|
+ return (ed'', expanded ++ rest)
|
|
|
142
|
+doExpandToks loc ed s (t : ts) = do
|
|
|
143
|
+ (ed', r) <- doExpandToks loc ed s ts
|
|
|
144
|
+ return (ed', t : r)
|
|
126
|
145
|
|
|
127
|
146
|
{-
|
|
128
|
147
|
Note: [defined unary operator]
|