----------------------------------------------------------------------------- -- | -- Module : CppIfdef -- Copyright : 1999-2004 Malcolm Wallace -- Licence : LGPL -- -- Maintainer : Malcolm Wallace -- Stability : experimental -- Portability : All -- Perform a cpp.first-pass, gathering \#define's and evaluating \#ifdef's. -- and \#include's. ----------------------------------------------------------------------------- module Language.Preprocessor.Cpphs.CppIfdef ( cppIfdef -- :: FilePath -> [(String,String)] -> [String] -> Options -- -> String -> IO [(Posn,String)] ) where import Text.Parse import Language.Preprocessor.Cpphs.SymTab import Language.Preprocessor.Cpphs.Position (Posn,newfile,newline,newlines ,cppline,cpp2hask,newpos) import Language.Preprocessor.Cpphs.ReadFirst (readFirst) import Language.Preprocessor.Cpphs.Tokenise (linesCpp,reslash) import Language.Preprocessor.Cpphs.Options (BoolOptions(..)) import Language.Preprocessor.Cpphs.HashDefine(HashDefine(..),parseHashDefine ,expandMacro) import Language.Preprocessor.Cpphs.MacroPass (preDefine,defineMacro) import Data.Char (isDigit,isSpace,isAlphaNum) import Data.List (intercalate,isPrefixOf) import Numeric (readHex,readOct,readDec) import System.IO.Unsafe (unsafeInterleaveIO) import System.IO (hPutStrLn,stderr) import Control.Monad (when) -- | Run a first pass of cpp, evaluating \#ifdef's and processing \#include's, -- whilst taking account of \#define's and \#undef's as we encounter them. cppIfdef :: FilePath -- ^ File for error reports -> [(String,String)] -- ^ Pre-defined symbols and their values -> [String] -- ^ Search path for \#includes -> BoolOptions -- ^ Options controlling output style -> String -- ^ The input file content -> IO [(Posn,String)] -- ^ The file after processing (in lines) cppIfdef fp syms search options = cpp posn defs search options (Keep []) . initial . linesCpp where posn = newfile fp defs = preDefine options syms initial = if literate options then id else (cppline posn:) -- Previous versions had a very simple symbol table mapping strings -- to strings. Now the #ifdef pass uses a more elaborate table, in -- particular to deal with parameterised macros in conditionals. -- | Internal state for whether lines are being kept or dropped. -- In @Drop n b ps@, @n@ is the depth of nesting, @b@ is whether -- we have already succeeded in keeping some lines in a chain of -- @elif@'s, and @ps@ is the stack of positions of open @#if@ contexts, -- used for error messages in case EOF is reached too soon. data KeepState = Keep [Posn] | Drop Int Bool [Posn] -- | Return just the list of lines that the real cpp would decide to keep. cpp :: Posn -> SymTab HashDefine -> [String] -> BoolOptions -> KeepState -> [String] -> IO [(Posn,String)] cpp _ _ _ _ (Keep ps) [] | not (null ps) = do hPutStrLn stderr $ "Unmatched #if: positions of open context are:\n"++ unlines (map show ps) return [] cpp _ _ _ _ _ [] = return [] cpp p syms path options (Keep ps) (l@('#':x):xs) = let ws = words x cmd = if null ws then "" else head ws line = if null ws then [] else tail ws sym = if null line then "" else head line rest = if null line then [] else tail line def = defineMacro options (sym++" "++ maybe "1" id (un rest)) un v = if null v then Nothing else Just (unwords v) keepIf b = if b then Keep (p:ps) else Drop 1 False (p:ps) skipn syms' retain ud xs' = let n = 1 + length (filter (=='\n') l) in (if macros options && retain then emitOne (p,reslash l) else emitMany (replicate n (p,""))) $ cpp (newlines n p) syms' path options ud xs' in case cmd of "define" -> skipn (insertST def syms) True (Keep ps) xs "undef" -> skipn (deleteST sym syms) True (Keep ps) xs "ifndef" -> skipn syms False (keepIf (not (definedST sym syms))) xs "ifdef" -> skipn syms False (keepIf (definedST sym syms)) xs "if" -> do b <- gatherDefined p syms (unwords line) skipn syms False (keepIf b) xs "else" -> skipn syms False (Drop 1 False ps) xs "elif" -> skipn syms False (Drop 1 True ps) xs "endif" | null ps -> do hPutStrLn stderr $ "Unmatched #endif at "++show p return [] "endif" -> skipn syms False (Keep (tail ps)) xs "pragma" -> skipn syms True (Keep ps) xs ('!':_) -> skipn syms False (Keep ps) xs -- \#!runhs scripts "include"-> do (inc,content) <- readFirst (file syms (unwords line)) p path (warnings options) cpp p syms path options (Keep ps) (("#line 1 "++show inc): linesCpp content ++ cppline (newline p): xs) "warning"-> if warnings options then do hPutStrLn stderr (l++"\nin "++show p) skipn syms False (Keep ps) xs else skipn syms False (Keep ps) xs "error" -> error (l++"\nin "++show p) "line" | all isDigit sym -> (if locations options && hashline options then emitOne (p,l) else if locations options then emitOne (p,cpp2hask l) else id) $ cpp (newpos (read sym) (un rest) p) syms path options (Keep ps) xs n | all isDigit n && not (null n) -> (if locations options && hashline options then emitOne (p,l) else if locations options then emitOne (p,cpp2hask l) else id) $ cpp (newpos (read n) (un (tail ws)) p) syms path options (Keep ps) xs | otherwise -> do when (warnings options) $ hPutStrLn stderr ("Warning: unknown directive #"++n ++"\nin "++show p) emitOne (p,l) $ cpp (newline p) syms path options (Keep ps) xs cpp p syms path options (Drop n b ps) (('#':x):xs) = let ws = words x cmd = if null ws then "" else head ws delse | n==1 && b = Drop 1 b ps | n==1 = Keep ps | otherwise = Drop n b ps dend | n==1 = Keep (tail ps) | otherwise = Drop (n-1) b (tail ps) delif v | n==1 && not b && v = Keep ps | otherwise = Drop n b ps skipn ud xs' = let n' = 1 + length (filter (=='\n') x) in emitMany (replicate n' (p,"")) $ cpp (newlines n' p) syms path options ud xs' in if cmd == "ifndef" || cmd == "if" || cmd == "ifdef" then skipn (Drop (n+1) b (p:ps)) xs else if cmd == "elif" then do v <- gatherDefined p syms (unwords (tail ws)) skipn (delif v) xs else if cmd == "else" then skipn delse xs else if cmd == "endif" then if null ps then do hPutStrLn stderr $ "Unmatched #endif at "++show p return [] else skipn dend xs else skipn (Drop n b ps) xs -- define, undef, include, error, warning, pragma, line cpp p syms path options (Keep ps) (x:xs) = let p' = newline p in seq p' $ emitOne (p,x) $ cpp p' syms path options (Keep ps) xs cpp p syms path options d@(Drop _ _ _) (_:xs) = let p' = newline p in seq p' $ emitOne (p,"") $ cpp p' syms path options d xs -- | Auxiliary IO functions emitOne :: a -> IO [a] -> IO [a] emitMany :: [a] -> IO [a] -> IO [a] emitOne x io = do ys <- unsafeInterleaveIO io return (x:ys) emitMany xs io = do ys <- unsafeInterleaveIO io return (xs++ys) ---- gatherDefined :: Posn -> SymTab HashDefine -> String -> IO Bool gatherDefined p st inp = case runParser (preExpand st) inp of (Left msg, _) -> error ("Cannot expand #if directive in file "++show p ++":\n "++msg) (Right s, xs) -> do -- hPutStrLn stderr $ "Expanded #if at "++show p++" is:\n "++s when (any (not . isSpace) xs) $ hPutStrLn stderr ("Warning: trailing characters after #if" ++" macro expansion in file "++show p++": "++xs) case runParser parseBoolExp s of (Left msg, _) -> error ("Cannot parse #if directive in file "++show p ++":\n "++msg) (Right b, xs) -> do when (any (not . isSpace) xs && notComment xs) $ hPutStrLn stderr ("Warning: trailing characters after #if" ++" directive in file "++show p++": "++xs) return b notComment = not . ("//"`isPrefixOf`) . dropWhile isSpace -- | The preprocessor must expand all macros (recursively) before evaluating -- the conditional. preExpand :: SymTab HashDefine -> TextParser String preExpand st = do eof return "" <|> do a <- many1 (satisfy notIdent) commit $ pure (a++) `apply` preExpand st <|> do b <- expandSymOrCall st commit $ pure (b++) `apply` preExpand st -- | Expansion of symbols. expandSymOrCall :: SymTab HashDefine -> TextParser String expandSymOrCall st = do sym <- parseSym if sym=="defined" then do arg <- skip parseSym; convert sym [arg] <|> do arg <- skip $ parenthesis (do x <- skip parseSym; skip (return x)) convert sym [arg] <|> convert sym [] else ( do args <- parenthesis (commit $ fragment `sepBy` skip (isWord ",")) args' <- flip mapM args $ \arg-> case runParser (preExpand st) arg of (Left msg, _) -> fail msg (Right s, _) -> return s convert sym args' <|> convert sym [] ) where fragment = many1 (satisfy (`notElem`",)")) convert "defined" [arg] = case lookupST arg st of Nothing | all isDigit arg -> return arg Nothing -> return "0" Just (a@AntiDefined{}) -> return "0" Just (a@SymbolReplacement{}) -> return "1" Just (a@MacroExpansion{}) -> return "1" convert sym args = case lookupST sym st of Nothing -> if null args then return sym else return "0" -- else fail (disp sym args++" is not a defined macro") Just (a@SymbolReplacement{}) -> do reparse (replacement a) return "" Just (a@MacroExpansion{}) -> do reparse (expandMacro a args False) return "" Just (a@AntiDefined{}) -> if null args then return sym else return "0" -- else fail (disp sym args++" explicitly undefined with -U") disp sym args = let len = length args chars = map (:[]) ['a'..'z'] in sym ++ if null args then "" else "("++intercalate "," (take len chars)++")" parseBoolExp :: TextParser Bool parseBoolExp = do a <- parseExp1 bs <- many (do skip (isWord "||") commit $ skip parseBoolExp) return $ foldr (||) a bs parseExp1 :: TextParser Bool parseExp1 = do a <- parseExp0 bs <- many (do skip (isWord "&&") commit $ skip parseExp1) return $ foldr (&&) a bs parseExp0 :: TextParser Bool parseExp0 = do skip (isWord "!") a <- commit $ parseExp0 return (not a) <|> do val1 <- parseArithExp1 op <- parseCmpOp val2 <- parseArithExp1 return (val1 `op` val2) <|> do sym <- parseArithExp1 case sym of 0 -> return False _ -> return True <|> do parenthesis (commit parseBoolExp) parseArithExp1 :: TextParser Integer parseArithExp1 = do val1 <- parseArithExp0 ( do op <- parseArithOp1 val2 <- parseArithExp1 return (val1 `op` val2) <|> return val1 ) <|> do parenthesis parseArithExp1 parseArithExp0 :: TextParser Integer parseArithExp0 = do val1 <- parseNumber ( do op <- parseArithOp0 val2 <- parseArithExp0 return (val1 `op` val2) <|> return val1 ) <|> do parenthesis parseArithExp0 parseNumber :: TextParser Integer parseNumber = fmap safeRead $ skip parseSym where safeRead s = case s of '0':'x':s' -> number readHex s' '0':'o':s' -> number readOct s' _ -> number readDec s number rd s = case rd s of [] -> 0 :: Integer ((n,_):_) -> n :: Integer parseCmpOp :: TextParser (Integer -> Integer -> Bool) parseCmpOp = do skip (isWord ">=") return (>=) <|> do skip (isWord ">") return (>) <|> do skip (isWord "<=") return (<=) <|> do skip (isWord "<") return (<) <|> do skip (isWord "==") return (==) <|> do skip (isWord "!=") return (/=) parseArithOp1 :: TextParser (Integer -> Integer -> Integer) parseArithOp1 = do skip (isWord "+") return (+) <|> do skip (isWord "-") return (-) parseArithOp0 :: TextParser (Integer -> Integer -> Integer) parseArithOp0 = do skip (isWord "*") return (*) <|> do skip (isWord "/") return (div) <|> do skip (isWord "%") return (rem) -- | Return the expansion of the symbol (if there is one). parseSymOrCall :: SymTab HashDefine -> TextParser String parseSymOrCall st = do sym <- skip parseSym args <- parenthesis (commit $ parseSymOrCall st `sepBy` skip (isWord ",")) return $ convert sym args <|> do sym <- skip parseSym return $ convert sym [] where convert sym args = case lookupST sym st of Nothing -> sym Just (a@SymbolReplacement{}) -> recursivelyExpand st (replacement a) Just (a@MacroExpansion{}) -> recursivelyExpand st (expandMacro a args False) Just (a@AntiDefined{}) -> name a recursivelyExpand :: SymTab HashDefine -> String -> String recursivelyExpand st inp = case runParser (parseSymOrCall st) inp of (Left msg, _) -> inp (Right s, _) -> s parseSym :: TextParser String parseSym = many1 (satisfy (\c-> isAlphaNum c || c`elem`"'`_")) `onFail` do xs <- allAsString fail $ "Expected an identifier, got \""++xs++"\"" notIdent :: Char -> Bool notIdent c = not (isAlphaNum c || c`elem`"'`_") skip :: TextParser a -> TextParser a skip p = many (satisfy isSpace) >> p -- | The standard "parens" parser does not work for us here. Define our own. parenthesis :: TextParser a -> TextParser a parenthesis p = do isWord "(" x <- p isWord ")" return x -- | Determine filename in \#include file :: SymTab HashDefine -> String -> String file st name = case name of ('"':ns) -> init ns ('<':ns) -> init ns _ -> let ex = recursivelyExpand st name in if ex == name then name else file st ex