1----------------------------------------------------------------------------- 2-- | 3-- Module : CppIfdef 4-- Copyright : 1999-2004 Malcolm Wallace 5-- Licence : LGPL 6-- 7-- Maintainer : Malcolm Wallace <Malcolm.Wallace@cs.york.ac.uk> 8-- Stability : experimental 9-- Portability : All 10 11-- Perform a cpp.first-pass, gathering \#define's and evaluating \#ifdef's. 12-- and \#include's. 13----------------------------------------------------------------------------- 14 15module Language.Preprocessor.Cpphs.CppIfdef 16 ( cppIfdef -- :: FilePath -> [(String,String)] -> [String] -> Options 17 -- -> String -> IO [(Posn,String)] 18 ) where 19 20 21import Text.Parse 22import Language.Preprocessor.Cpphs.SymTab 23import Language.Preprocessor.Cpphs.Position (Posn,newfile,newline,newlines 24 ,cppline,cpp2hask,newpos) 25import Language.Preprocessor.Cpphs.ReadFirst (readFirst) 26import Language.Preprocessor.Cpphs.Tokenise (linesCpp,reslash) 27import Language.Preprocessor.Cpphs.Options (BoolOptions(..)) 28import Language.Preprocessor.Cpphs.HashDefine(HashDefine(..),parseHashDefine 29 ,expandMacro) 30import Language.Preprocessor.Cpphs.MacroPass (preDefine,defineMacro) 31import Data.Char (isDigit,isSpace,isAlphaNum) 32import Data.List (intercalate,isPrefixOf) 33import Numeric (readHex,readOct,readDec) 34import System.IO.Unsafe (unsafeInterleaveIO) 35import System.IO (hPutStrLn,stderr) 36import Control.Monad (when) 37 38-- | Run a first pass of cpp, evaluating \#ifdef's and processing \#include's, 39-- whilst taking account of \#define's and \#undef's as we encounter them. 40cppIfdef :: FilePath -- ^ File for error reports 41 -> [(String,String)] -- ^ Pre-defined symbols and their values 42 -> [String] -- ^ Search path for \#includes 43 -> BoolOptions -- ^ Options controlling output style 44 -> String -- ^ The input file content 45 -> IO [(Posn,String)] -- ^ The file after processing (in lines) 46cppIfdef fp syms search options = 47 cpp posn defs search options (Keep []) . initial . linesCpp 48 where 49 posn = newfile fp 50 defs = preDefine options syms 51 initial = if literate options then id else (cppline posn:) 52-- Previous versions had a very simple symbol table mapping strings 53-- to strings. Now the #ifdef pass uses a more elaborate table, in 54-- particular to deal with parameterised macros in conditionals. 55 56 57-- | Internal state for whether lines are being kept or dropped. 58-- In @Drop n b ps@, @n@ is the depth of nesting, @b@ is whether 59-- we have already succeeded in keeping some lines in a chain of 60-- @elif@'s, and @ps@ is the stack of positions of open @#if@ contexts, 61-- used for error messages in case EOF is reached too soon. 62data KeepState = Keep [Posn] | Drop Int Bool [Posn] 63 64-- | Return just the list of lines that the real cpp would decide to keep. 65cpp :: Posn -> SymTab HashDefine -> [String] -> BoolOptions -> KeepState 66 -> [String] -> IO [(Posn,String)] 67 68cpp _ _ _ _ (Keep ps) [] | not (null ps) = do 69 hPutStrLn stderr $ "Unmatched #if: positions of open context are:\n"++ 70 unlines (map show ps) 71 return [] 72cpp _ _ _ _ _ [] = return [] 73 74cpp p syms path options (Keep ps) (l@('#':x):xs) = 75 let ws = words x 76 cmd = if null ws then "" else head ws 77 line = if null ws then [] else tail ws 78 sym = if null line then "" else head line 79 rest = if null line then [] else tail line 80 def = defineMacro options (sym++" "++ maybe "1" id (un rest)) 81 un v = if null v then Nothing else Just (unwords v) 82 keepIf b = if b then Keep (p:ps) else Drop 1 False (p:ps) 83 skipn syms' retain ud xs' = 84 let n = 1 + length (filter (=='\n') l) in 85 (if macros options && retain then emitOne (p,reslash l) 86 else emitMany (replicate n (p,""))) $ 87 cpp (newlines n p) syms' path options ud xs' 88 in case cmd of 89 "define" -> skipn (insertST def syms) True (Keep ps) xs 90 "undef" -> skipn (deleteST sym syms) True (Keep ps) xs 91 "ifndef" -> skipn syms False (keepIf (not (definedST sym syms))) xs 92 "ifdef" -> skipn syms False (keepIf (definedST sym syms)) xs 93 "if" -> do b <- gatherDefined p syms (unwords line) 94 skipn syms False (keepIf b) xs 95 "else" -> skipn syms False (Drop 1 False ps) xs 96 "elif" -> skipn syms False (Drop 1 True ps) xs 97 "endif" | null ps -> 98 do hPutStrLn stderr $ "Unmatched #endif at "++show p 99 return [] 100 "endif" -> skipn syms False (Keep (tail ps)) xs 101 "pragma" -> skipn syms True (Keep ps) xs 102 ('!':_) -> skipn syms False (Keep ps) xs -- \#!runhs scripts 103 "include"-> do (inc,content) <- readFirst (file syms (unwords line)) 104 p path 105 (warnings options) 106 cpp p syms path options (Keep ps) 107 (("#line 1 "++show inc): linesCpp content 108 ++ cppline (newline p): xs) 109 "warning"-> if warnings options then 110 do hPutStrLn stderr (l++"\nin "++show p) 111 skipn syms False (Keep ps) xs 112 else skipn syms False (Keep ps) xs 113 "error" -> error (l++"\nin "++show p) 114 "line" | all isDigit sym 115 -> (if locations options && hashline options then emitOne (p,l) 116 else if locations options then emitOne (p,cpp2hask l) 117 else id) $ 118 cpp (newpos (read sym) (un rest) p) 119 syms path options (Keep ps) xs 120 n | all isDigit n && not (null n) 121 -> (if locations options && hashline options then emitOne (p,l) 122 else if locations options then emitOne (p,cpp2hask l) 123 else id) $ 124 cpp (newpos (read n) (un (tail ws)) p) 125 syms path options (Keep ps) xs 126 | otherwise 127 -> do when (warnings options) $ 128 hPutStrLn stderr ("Warning: unknown directive #"++n 129 ++"\nin "++show p) 130 emitOne (p,l) $ 131 cpp (newline p) syms path options (Keep ps) xs 132 133cpp p syms path options (Drop n b ps) (('#':x):xs) = 134 let ws = words x 135 cmd = if null ws then "" else head ws 136 delse | n==1 && b = Drop 1 b ps 137 | n==1 = Keep ps 138 | otherwise = Drop n b ps 139 dend | n==1 = Keep (tail ps) 140 | otherwise = Drop (n-1) b (tail ps) 141 delif v | n==1 && not b && v 142 = Keep ps 143 | otherwise = Drop n b ps 144 skipn ud xs' = 145 let n' = 1 + length (filter (=='\n') x) in 146 emitMany (replicate n' (p,"")) $ 147 cpp (newlines n' p) syms path options ud xs' 148 in 149 if cmd == "ifndef" || 150 cmd == "if" || 151 cmd == "ifdef" then skipn (Drop (n+1) b (p:ps)) xs 152 else if cmd == "elif" then do v <- gatherDefined p syms (unwords (tail ws)) 153 skipn (delif v) xs 154 else if cmd == "else" then skipn delse xs 155 else if cmd == "endif" then 156 if null ps then do hPutStrLn stderr $ "Unmatched #endif at "++show p 157 return [] 158 else skipn dend xs 159 else skipn (Drop n b ps) xs 160 -- define, undef, include, error, warning, pragma, line 161 162cpp p syms path options (Keep ps) (x:xs) = 163 let p' = newline p in seq p' $ 164 emitOne (p,x) $ cpp p' syms path options (Keep ps) xs 165cpp p syms path options d@(Drop _ _ _) (_:xs) = 166 let p' = newline p in seq p' $ 167 emitOne (p,"") $ cpp p' syms path options d xs 168 169 170-- | Auxiliary IO functions 171emitOne :: a -> IO [a] -> IO [a] 172emitMany :: [a] -> IO [a] -> IO [a] 173emitOne x io = do ys <- unsafeInterleaveIO io 174 return (x:ys) 175emitMany xs io = do ys <- unsafeInterleaveIO io 176 return (xs++ys) 177 178 179---- 180gatherDefined :: Posn -> SymTab HashDefine -> String -> IO Bool 181gatherDefined p st inp = 182 case runParser (preExpand st) inp of 183 (Left msg, _) -> error ("Cannot expand #if directive in file "++show p 184 ++":\n "++msg) 185 (Right s, xs) -> do 186-- hPutStrLn stderr $ "Expanded #if at "++show p++" is:\n "++s 187 when (any (not . isSpace) xs) $ 188 hPutStrLn stderr ("Warning: trailing characters after #if" 189 ++" macro expansion in file "++show p++": "++xs) 190 191 case runParser parseBoolExp s of 192 (Left msg, _) -> error ("Cannot parse #if directive in file "++show p 193 ++":\n "++msg) 194 (Right b, xs) -> do when (any (not . isSpace) xs && notComment xs) $ 195 hPutStrLn stderr 196 ("Warning: trailing characters after #if" 197 ++" directive in file "++show p++": "++xs) 198 return b 199 200notComment = not . ("//"`isPrefixOf`) . dropWhile isSpace 201 202 203-- | The preprocessor must expand all macros (recursively) before evaluating 204-- the conditional. 205preExpand :: SymTab HashDefine -> TextParser String 206preExpand st = 207 do eof 208 return "" 209 <|> 210 do a <- many1 (satisfy notIdent) 211 commit $ pure (a++) `apply` preExpand st 212 <|> 213 do b <- expandSymOrCall st 214 commit $ pure (b++) `apply` preExpand st 215 216-- | Expansion of symbols. 217expandSymOrCall :: SymTab HashDefine -> TextParser String 218expandSymOrCall st = 219 do sym <- parseSym 220 if sym=="defined" then do arg <- skip parseSym; convert sym [arg] 221 <|> 222 do arg <- skip $ parenthesis (do x <- skip parseSym; 223 skip (return x)) 224 convert sym [arg] 225 <|> convert sym [] 226 else 227 ( do args <- parenthesis (commit $ fragment `sepBy` skip (isWord ",")) 228 args' <- flip mapM args $ \arg-> 229 case runParser (preExpand st) arg of 230 (Left msg, _) -> fail msg 231 (Right s, _) -> return s 232 convert sym args' 233 <|> convert sym [] 234 ) 235 where 236 fragment = many1 (satisfy (`notElem`",)")) 237 convert "defined" [arg] = 238 case lookupST arg st of 239 Nothing | all isDigit arg -> return arg 240 Nothing -> return "0" 241 Just (a@AntiDefined{}) -> return "0" 242 Just (a@SymbolReplacement{}) -> return "1" 243 Just (a@MacroExpansion{}) -> return "1" 244 convert sym args = 245 case lookupST sym st of 246 Nothing -> if null args then return sym 247 else return "0" 248 -- else fail (disp sym args++" is not a defined macro") 249 Just (a@SymbolReplacement{}) -> do reparse (replacement a) 250 return "" 251 Just (a@MacroExpansion{}) -> do reparse (expandMacro a args False) 252 return "" 253 Just (a@AntiDefined{}) -> 254 if null args then return sym 255 else return "0" 256 -- else fail (disp sym args++" explicitly undefined with -U") 257 disp sym args = let len = length args 258 chars = map (:[]) ['a'..'z'] 259 in sym ++ if null args then "" 260 else "("++intercalate "," (take len chars)++")" 261 262parseBoolExp :: TextParser Bool 263parseBoolExp = 264 do a <- parseExp1 265 bs <- many (do skip (isWord "||") 266 commit $ skip parseBoolExp) 267 return $ foldr (||) a bs 268 269parseExp1 :: TextParser Bool 270parseExp1 = 271 do a <- parseExp0 272 bs <- many (do skip (isWord "&&") 273 commit $ skip parseExp1) 274 return $ foldr (&&) a bs 275 276parseExp0 :: TextParser Bool 277parseExp0 = 278 do skip (isWord "!") 279 a <- commit $ parseExp0 280 return (not a) 281 <|> 282 do val1 <- parseArithExp1 283 op <- parseCmpOp 284 val2 <- parseArithExp1 285 return (val1 `op` val2) 286 <|> 287 do sym <- parseArithExp1 288 case sym of 289 0 -> return False 290 _ -> return True 291 <|> 292 do parenthesis (commit parseBoolExp) 293 294parseArithExp1 :: TextParser Integer 295parseArithExp1 = 296 do val1 <- parseArithExp0 297 ( do op <- parseArithOp1 298 val2 <- parseArithExp1 299 return (val1 `op` val2) 300 <|> return val1 ) 301 <|> 302 do parenthesis parseArithExp1 303 304parseArithExp0 :: TextParser Integer 305parseArithExp0 = 306 do val1 <- parseNumber 307 ( do op <- parseArithOp0 308 val2 <- parseArithExp0 309 return (val1 `op` val2) 310 <|> return val1 ) 311 <|> 312 do parenthesis parseArithExp0 313 314parseNumber :: TextParser Integer 315parseNumber = fmap safeRead $ skip parseSym 316 where 317 safeRead s = 318 case s of 319 '0':'x':s' -> number readHex s' 320 '0':'o':s' -> number readOct s' 321 _ -> number readDec s 322 number rd s = 323 case rd s of 324 [] -> 0 :: Integer 325 ((n,_):_) -> n :: Integer 326 327parseCmpOp :: TextParser (Integer -> Integer -> Bool) 328parseCmpOp = 329 do skip (isWord ">=") 330 return (>=) 331 <|> 332 do skip (isWord ">") 333 return (>) 334 <|> 335 do skip (isWord "<=") 336 return (<=) 337 <|> 338 do skip (isWord "<") 339 return (<) 340 <|> 341 do skip (isWord "==") 342 return (==) 343 <|> 344 do skip (isWord "!=") 345 return (/=) 346 347parseArithOp1 :: TextParser (Integer -> Integer -> Integer) 348parseArithOp1 = 349 do skip (isWord "+") 350 return (+) 351 <|> 352 do skip (isWord "-") 353 return (-) 354 355parseArithOp0 :: TextParser (Integer -> Integer -> Integer) 356parseArithOp0 = 357 do skip (isWord "*") 358 return (*) 359 <|> 360 do skip (isWord "/") 361 return (div) 362 <|> 363 do skip (isWord "%") 364 return (rem) 365 366-- | Return the expansion of the symbol (if there is one). 367parseSymOrCall :: SymTab HashDefine -> TextParser String 368parseSymOrCall st = 369 do sym <- skip parseSym 370 args <- parenthesis (commit $ parseSymOrCall st `sepBy` skip (isWord ",")) 371 return $ convert sym args 372 <|> 373 do sym <- skip parseSym 374 return $ convert sym [] 375 where 376 convert sym args = 377 case lookupST sym st of 378 Nothing -> sym 379 Just (a@SymbolReplacement{}) -> recursivelyExpand st (replacement a) 380 Just (a@MacroExpansion{}) -> recursivelyExpand st (expandMacro a args False) 381 Just (a@AntiDefined{}) -> name a 382 383recursivelyExpand :: SymTab HashDefine -> String -> String 384recursivelyExpand st inp = 385 case runParser (parseSymOrCall st) inp of 386 (Left msg, _) -> inp 387 (Right s, _) -> s 388 389parseSym :: TextParser String 390parseSym = many1 (satisfy (\c-> isAlphaNum c || c`elem`"'`_")) 391 `onFail` 392 do xs <- allAsString 393 fail $ "Expected an identifier, got \""++xs++"\"" 394 395notIdent :: Char -> Bool 396notIdent c = not (isAlphaNum c || c`elem`"'`_") 397 398skip :: TextParser a -> TextParser a 399skip p = many (satisfy isSpace) >> p 400 401-- | The standard "parens" parser does not work for us here. Define our own. 402parenthesis :: TextParser a -> TextParser a 403parenthesis p = do isWord "(" 404 x <- p 405 isWord ")" 406 return x 407 408-- | Determine filename in \#include 409file :: SymTab HashDefine -> String -> String 410file st name = 411 case name of 412 ('"':ns) -> init ns 413 ('<':ns) -> init ns 414 _ -> let ex = recursivelyExpand st name in 415 if ex == name then name else file st ex 416 417