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