hpp (empty) → 0.1.0.0
raw patch · 14 files changed
+1774/−0 lines, 14 filesdep +basedep +directorydep +filepathsetup-changed
Dependencies added: base, directory, filepath, hpp, time, transformers
Files
- CHANGELOG.md +3/−0
- LICENSE +30/−0
- Setup.hs +2/−0
- hpp.cabal +76/−0
- src/Hpp.hs +539/−0
- src/Hpp/Config.hs +90/−0
- src/Hpp/Env.hs +22/−0
- src/Hpp/Expansion.hs +177/−0
- src/Hpp/Expr.hs +352/−0
- src/Hpp/String.hs +34/−0
- src/Hpp/Tokens.hs +96/−0
- src/Hpp/Types.hs +122/−0
- src/Main.hs +144/−0
- tests/mcpp-validation.sh +87/−0
+ CHANGELOG.md view
@@ -0,0 +1,3 @@+# 0.1++First release!
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2015, Anthony Cowley++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Anthony Cowley nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ hpp.cabal view
@@ -0,0 +1,76 @@+name: hpp+version: 0.1.0.0+synopsis: A Haskell pre-processor++description: @hpp@ is a Haskell pre-processor that is also a+ C89/C90-compatible pre-processor (with the addition of a+ @--cpp@ flag). It is packaged as both a library and+ an executable.+ + .++ To use as a Haskell preprocessor for resolving @#ifdef@+ conditionals and simple macro expansion while still+ allowing multi-line string literals, an invocation might+ look like,+ .+ @+ hpp -DDEBUG Foo.hs+ @+ .+ To use as a C preprocessor, an invocation might look+ like,+ .+ @+ hpp -DDEBUG --cpp foo.c+ @+ .++ To have GHC use @hpp@ as the C pre-processor, add this+ line to the top of a Haskell source file that makes use+ of the @CPP@ @LANGUAGE@ pragma.+ .+ + @+ {-\# OPTIONS_GHC -cpp -pgmPhpp -optP\-\-cpp \#-}+ @+++license: BSD3+license-file: LICENSE+author: Anthony Cowley+maintainer: acowley@gmail.com+copyright: (C) 2015 Anthony Cowley+category: Development+build-type: Simple+extra-source-files: tests/mcpp-validation.sh, CHANGELOG.md+cabal-version: >=1.10+homepage: https://github.com/acowley/hpp+source-repository head+ type: git+ location: http://github.com/acowley/hpp.git+++library+ exposed-modules: Hpp,+ Hpp.Config,+ Hpp.Env,+ Hpp.Expansion,+ Hpp.Expr,+ Hpp.String,+ Hpp.Tokens,+ Hpp.Types+ build-depends: base >=4.7 && <4.9, directory, time, filepath+ if impl(ghc < 7.10)+ build-depends: transformers+ hs-source-dirs: src+ default-language: Haskell2010+ ghc-options: -Wall++executable hpp+ main-is: src/Main.hs+ -- other-extensions: + build-depends: hpp, base >=4.7 && <4.9, directory, time, filepath+ hs-source-dirs: .+ default-language: Haskell2010+ ghc-options: -Wall -O2
+ src/Hpp.hs view
@@ -0,0 +1,539 @@+{-# LANGUAGE LambdaCase, ScopedTypeVariables #-}+-- | Front-end interface to the pre-processor.+module Hpp (parseDefinition, preprocess,+ liftHpp, errorHpp, getConfig, setConfig, hppReadFile,+ runErrHppIO) where+import Control.Arrow (second)+import Control.Exception (catch, IOException)+import Control.Monad ((<=<))+import Data.Char (isSpace)+import Data.Functor.Identity+import System.Directory (doesFileExist)+import System.FilePath ((</>))+import Text.Read (readMaybe)++import Hpp.Config+import Hpp.Env+import Hpp.Expansion+import Hpp.Expr+import Hpp.String+import Hpp.Tokens+import Hpp.Types++-- * Trigraphs++-- | The first component of each pair represents the end of a known+-- trigraph sequence (each trigraph begins with two consecutive+-- question marks (@"??"@). The second component is the+-- single-character equivalent that we substitute in for the trigraph.+trigraphs :: [(Char, Char)]+trigraphs = [ ('=', '#')+ , ('/', '\\')+ , ('\'', '^')+ , ('(', '[')+ , (')', ']')+ , ('!', '|')+ , ('<', '{')+ , ('>', '}')+ , ('-', '~') ]++-- | Count the prefix @?@ characters as we go.+data TrigraphPrefix = TP0 | TP1 | TP2 deriving (Enum, Show)++trigraphReplacement :: String -> String+trigraphReplacement = go TP0+ where go :: TrigraphPrefix -> String -> String+ go n [] = replicate (fromEnum n) '?'+ go TP2 ('?':xs) = '?' : go TP2 xs+ go TP2 (x:xs) = case lookup x trigraphs of+ Just x' -> x' : go TP0 xs+ Nothing -> "??" ++ x : go TP0 xs+ go i ('?':xs) = go (succ i) xs+ go TP0 (x:xs) = x : go TP0 xs+ go TP1 (x:xs) = '?' : x : go TP0 xs++-- * Line Splicing++lineSplicing :: [String] -> [String]+lineSplicing [] = []+lineSplicing [x] = [x]+lineSplicing ([]:t) = [] : lineSplicing t+lineSplicing (x:t@(y:xs))+ | last x == '\\' = lineSplicing ((init x++y) : xs)+ | otherwise = x : lineSplicing t++-- FIXME: This doesn't work! we can also end or start a line with an+-- operator! A #pragma line shouldn't be spliced. But note also that+-- treating a close parenthesis is risky.++-- | Applications can run across multiple lines. We join those lines+-- to simplify subsequent parsing. We simply look for trailing or+-- leading commas to determine which lines to splice.+spliceApplications :: [String] -> [String]+spliceApplications = go Nothing+ where go :: Maybe String -> [String] -> [String]+ go prev [] = maybe [] (:[]) prev+ go prev (l:ls)+ | headIs '#' l = let p = maybe [] (:[]) prev+ in p ++ l : go Nothing ls+ go (Just prev) (l:ls)+ | headOp opStarts l = go Nothing ((prev++l) : ls)+ | otherwise = prev : go Nothing (l:ls)+ go Nothing (l1:l2:ls)+ | headOp opEnds $ reverse l1 = go Nothing ((l1++l2):ls)+ go Nothing (l:ls) = go (Just l) ls+ + opEnds = [',','+','-','*','/','(','=','%','&','|','^']+ opStarts = [',','+','-','*','/','(',')','=','%','&','|','^']+ headOp ops xs = case dropWhile isSpace xs of+ c:_ -> c `elem` ops+ _ -> False+ headIs x xs = case dropWhile isSpace xs of+ (y:_) -> y == x+ _ -> False++-- * C Comments++breakBlockCommentStart :: String -> Maybe (String, String)+breakBlockCommentStart = go id+ where go _ [] = Nothing+ go acc ('"' : ts) = skipLiteral (go . (acc .)) ts+ go acc ('/' : '*' : t) = Just (acc [], t)+ go acc (c:cs) = go (acc . (c:)) cs++breakBlockCommentEnd :: String -> Maybe String+breakBlockCommentEnd [] = Nothing+breakBlockCommentEnd (_:'"':cs) = skipLiteral (const breakBlockCommentEnd) cs+breakBlockCommentEnd ('*':'/':t) = Just (' ':t)+breakBlockCommentEnd (_:cs) = breakBlockCommentEnd cs++dropOneLineBlockComments :: String -> String+dropOneLineBlockComments [] = []+dropOneLineBlockComments (c:'"':cs) =+ c : skipLiteral (\x y -> x [] ++ dropOneLineBlockComments y) cs+dropOneLineBlockComments ('/':'*':cs) = go cs+ where go [] = "/*"+ go ('*':'/':t) = ' ' : dropOneLineBlockComments t+ go (_:t) = go t+dropOneLineBlockComments (c:cs) = c : dropOneLineBlockComments cs++dropLineComments :: String -> String+dropLineComments [] = []+dropLineComments ('/':'/':_) = []+dropLineComments (c:cs) = c : dropLineComments cs++removeMultilineComments :: Int -> [String] -> [String]+removeMultilineComments _ [] = []+removeMultilineComments lineNum (l:ls) =+ case breakBlockCommentStart l of+ Nothing -> l : removeMultilineComments (lineNum+1) ls+ Just (pre,_) ->+ case go 0 ls of+ (numSkipped, []) -> pre : replicate (lineNum+numSkipped) []+ (numSkipped, (l':ls')) -> + let lineNum' = lineNum + numSkipped+ in (pre ++ l') : ("#line " ++ show (lineNum'+1))+ : removeMultilineComments lineNum' ls'+ where go :: Int -> [String] -> (Int, [String])+ go numSkipped [] = (numSkipped, [])+ go numSkipped (l':ls') =+ case breakBlockCommentEnd l' of+ Nothing -> go (numSkipped + 1) ls'+ Just rst -> (numSkipped+1, rst : ls')++commentRemoval :: [String] -> [String]+commentRemoval = map dropLineComments+ . removeMultilineComments 1+ . map dropOneLineBlockComments++-- * Token Splices++-- | Deal with the two-character '##' token pasting/splicing+-- operator. We do so eliminating spaces around the @##@+-- operator.+prepTokenSplices :: [Token] -> [Token]+prepTokenSplices = dropSpaces [] . mergeTokens []+ where -- Merges ## tokens, and reverses the input list+ mergeTokens acc [] = acc+ mergeTokens acc (Important "#" : Important "#" : ts) =+ mergeTokens (Important "##" : acc) (dropWhile (not . isImportant) ts)+ mergeTokens acc (t:ts) = mergeTokens (t : acc) ts+ -- Drop trailing spaces and re-reverse the list+ dropSpaces acc [] = acc+ dropSpaces acc (t@(Important "##") : ts) =+ dropSpaces (t : acc) (dropWhile (not . isImportant) ts)+ dropSpaces acc (t:ts) = dropSpaces (t : acc) ts++-- * Function-like macros as Haskell functions++-- | @functionMacro parameters body arguments@ substitutes @arguments@+-- for @parameters@ in @body@ and performs stringification for uses of+-- the @#@ operator and token concatenation for the @##@ operator.+functionMacro :: [String] -> [Token] -> [([Scan],String)] -> [Scan]+functionMacro params body = paste+ . subst body'+ . zip params+ where subst toks gamma = go toks+ where go [] = []+ go (p@(Important "##"):t@(Important s):ts) =+ case lookupKey s gamma of+ Nothing -> Rescan p : Rescan t : go ts+ Just ((_,arg),_) ->+ Rescan p : Rescan (Important arg) : go ts+ go (t@(Important s):p@(Important "##"):ts) =+ case lookupKey s gamma of+ Nothing -> Rescan t : go (p:ts)+ Just ((_,arg),_) -> Rescan (Important arg) : go (p:ts)+ go (t@(Important "##"):ts) = Rescan t : go ts+ go (t@(Important ('#':s)) : ts) =+ case lookupKey s gamma of+ Nothing -> Rescan t : go ts+ Just ((_,arg),_) ->+ Rescan (Important (stringify arg)) : go ts+ go (t@(Important s) : ts) =+ case lookupKey s gamma of+ Nothing -> Rescan t : go ts+ Just ((arg,_),_) -> arg ++ go ts+ go (t:ts) = Rescan t : go ts+ prepStringify [] = []+ prepStringify (Important "#" : ts) =+ case dropWhile (not . isImportant) ts of+ (Important t : ts') -> Important ('#':t) : prepStringify ts'+ _ -> Important "#" : ts+ prepStringify (t:ts) = t : prepStringify ts+ + body' = prepStringify . prepTokenSplices $+ dropWhile (not . isImportant) body+ paste [] = []+ paste (Rescan (Important s) : Rescan (Important "##")+ : Rescan (Important t) : ts) =+ paste (Rescan (Important (trimSpaces s ++ dropWhile isSpace t)) : ts)+ paste (t:ts) = t : paste ts++-- * Pre-Processor Capabilities++-- | Raise an error condition.+errorHpp :: Error -> ErrHpp a+errorHpp e = do f <- liftHpp . fmap curFileName $ getConfig+ ErrHpp . pure $ Left (f, e)++-- | Lift an 'Either' into an 'ErrHpp'+liftEither :: Either Error a -> ErrHpp a+liftEither = either errorHpp pure++-- | Lift an 'Hpp' into an 'ErrHpp'+liftHpp :: Hpp a -> ErrHpp a+liftHpp = ErrHpp . fmap Right++-- | Read a file as an 'Hpp' action+hppReadFile :: Int -> FilePath -> Hpp String+hppReadFile n file = ReadFile n file return++-- | Read a file available on the search path after the path+-- containing the current file.+hppReadNext :: Int -> FilePath -> Hpp String+hppReadNext n file = ReadNext n file return++-- | Obtain the current 'Config'+getConfig :: Hpp Config+getConfig = GetConfig return++-- | Set the current 'Config'+setConfig :: Config -> Hpp ()+setConfig = flip SetConfig (return ())++-- | Run an action with a substitute 'Config'+withConfig :: Config -> ErrHpp a -> ErrHpp a+withConfig cfg m = do oldCfg <- liftHpp getConfig+ liftHpp $ setConfig cfg+ r <- m+ liftHpp $ setConfig oldCfg+ return r++-- * Running an Hpp Action++includeCandidates :: [FilePath] -> String -> Maybe [FilePath]+includeCandidates searchPath nm =+ case nm of+ '<':nm' -> Just $ sysSearch (init nm')+ '"':nm' -> let nm'' = init nm'+ in Just $ nm'' : sysSearch nm''+ _ -> Nothing+ where sysSearch f = map (</> f) searchPath++searchForInclude :: [FilePath] -> String -> IO (Maybe FilePath)+searchForInclude paths = maybe (return Nothing) aux . includeCandidates paths+ where aux [] = return Nothing+ aux (f:fs) = do exists <- doesFileExist f+ if exists then return (Just f) else aux fs++searchForNextInclude :: [FilePath] -> String -> IO (Maybe FilePath)+searchForNextInclude paths = maybe (return Nothing) (aux False)+ . includeCandidates paths+ where aux _ [] = return Nothing+ aux n (f:fs) = do exists <- doesFileExist f+ if exists+ then if n + then return (Just f) + else aux True fs+ else aux n fs++runHpp :: Config -> Hpp a -> IO (Either (FilePath,Error) a)+runHpp cfg = go+ where go (Pure x) = return (Right x)+ go (ReadFile ln file k) = searchForInclude (includePaths cfg) file+ >>= readAux ln file k+ go (ReadNext ln file k) = searchForNextInclude (includePaths cfg) file+ >>= readAux ln file k+ go (GetConfig k) = go (k cfg)+ go (SetConfig cfg' k) = runHpp cfg' k+ curFile = curFileName cfg+ readAux ln file _ Nothing =+ return $ Left (curFile, IncludeDoesNotExist ln file)+ readAux ln file k (Just file') =+ catch (Just <$> readFile file')+ (\(_::IOException) -> return Nothing)+ >>= maybe (return . Left $ (curFile, FailedInclude ln file))+ (go . k)++-- * Preprocessor++-- | Parse the definition of an object-like or function macro.+parseDefinition :: [Token] -> Maybe (String, Macro)+parseDefinition toks =+ case dropWhile (not . isImportant) toks of+ (Important name:Important "(":rst) -> + let params = takeWhile (/= ")") $ filter (/= ",") (importants rst)+ body = trimUnimportant . tail $ dropWhile (/= Important ")") toks+ macro = Function (length params) (functionMacro params body)+ in Just (name, macro)+ (Important name:_) ->+ let rhs = case dropWhile (/= Important name) toks of+ [] -> [Important ""]+ str@(_:t)+ | all (not . isImportant) str -> [Important ""]+ | otherwise -> trimUnimportant t+ in Just (name, Object rhs)+ _ -> Nothing++-- | Trim 'Other' 'Token's from both ends of a list of 'Token's.+trimUnimportant :: [Token] -> [Token]+trimUnimportant = aux id . dropWhile (not .isImportant)+ where aux _ [] = []+ aux acc (t@(Important _) : ts) = acc (t : aux id ts)+ aux acc (t@(Other _) : ts) = aux (acc . (t:)) ts++-- | Handle preprocessor directives (commands prefixed with an octothorpe).+directive :: Config -> LineNum -> String+ -> ErrHpp ((LineNum -> [String] -> Config -> Env+ -> [String] -> ErrHpp r)+ -> Env -> [String] -> ErrHpp r)+directive cfg ln s =+ case importants toks of+ "pragma":_ -> pure $ \k -> k ln' [] cfg -- Pragmas are ignored+ "define":_ -> case parseDefinition . tail $+ dropWhile (/= Important "define") toks of+ Nothing -> errorHpp $ BadMacroDefinition ln+ Just def -> pure $ \k -> k ln' [] cfg . (def :)+ ["undef",name] -> pure $ \k -> k ln' [] cfg . deleteKey name++ "include":_ -> includeAux hppReadFile . trimUnimportant . tail+ $ dropWhile (/= Important "include") toks++ "include_next":_ -> includeAux hppReadNext . trimUnimportant . tail+ $ dropWhile (/= Important "include_next") toks+ + ("line":_) ->+ pure $ \k env lns ->+ do (env',rst) <- liftEither . expandLine cfg ln env . tail+ $ dropWhile (/= Important "line") toks+ case dropWhile (not . isImportant) rst of+ Important n:optFile ->+ case readMaybe n of+ Nothing -> errorHpp $ BadLineArgument ln n+ Just ln'' ->+ let cfg' = case optFile of+ [] -> cfg+ _ -> let f = unquote+ . detokenize+ . dropWhile (not . isImportant)+ . tail -- line number token+ . dropWhile (not . isImportant)+ $ rst+ in cfg { curFileNameF = pure f }+ in k ln'' [] cfg' env' lns+ _ -> errorHpp $ BadLineArgument ln s+ ["ifdef", x] -> pure $ \k env lns ->+ case lookupKey x env of+ Nothing -> do lns' <- liftEither $ dropBranch lns+ k ln [] cfg env lns'+ Just _ -> liftEither (takeBranch lns) >>= k ln [] cfg env+ ["ifndef", x] -> pure $ \k env lns ->+ case lookupKey x env of+ Nothing -> liftEither (takeBranch lns)+ >>= k ln [] cfg env+ Just (_,env') -> do lns' <- liftEither $ dropBranch lns+ k ln [] cfg env' lns'+ ["else"] -> pure $ \k env lns ->+ liftEither (takeBranch lns) >>= k ln [] cfg env++ "if":_ -> pure $ ifAux "if"+ "elif":_ -> pure $ ifAux "elif"+ ["endif"] -> pure $ \k env -> k ln [] cfg env+ "error":_ -> errorHpp . UserError ln . detokenize+ . dropWhile (not . isImportant) . tail+ $ dropWhile (/= Important "error") toks+ "warning":_ -> pure $ \k env -> k ln' [] cfg env -- FIXME+ _ -> errorHpp $ UnknownCommand ln s+ where toks = tokenize s+ ln' = ln + 1+ toksAfterCommand cmd = tail $ dropWhile (/= Important cmd) toks++ ifAux c k env lns =+ do (env',ex) <- liftEither . expandLine cfg ln env . squashDefines env+ $ toksAfterCommand c+ let res = evalExpr <$> parseExpr ex+ -- res' = (if curFileName cfg == "test"+ -- then trace ("Eval "++show ex++" => "++show res)+ -- else id) res+ if maybe False (/= 0) res+ then either errorHpp (k ln [] cfg env') (takeBranch lns)+ else either errorHpp (k ln [] cfg env') (dropBranch lns)+ includeAux readFun fileToks = pure $ \k env lns ->+ do (env', fileName) <- liftEither $ expandLine cfg ln env fileToks+ let fileName' = detokenize $ trimUnimportant fileName+ cfg' = -- trace ("Including "++show fileName') $+ cfg { curFileNameF = pure $ unquote fileName' }+ (env'',inc) <- liftHpp (readFun ln fileName')+ >>= withConfig cfg' . preprocess env'+ k ln' [inc] cfg env'' lns++-- | We want to expand macros in expressions that must be evaluated+-- for condtionalals, but we want to take special care when dealing+-- with the meta @defined@ operator of the expression language that is+-- a predicate on the evaluation environment.+squashDefines :: Env -> [Token] -> [Token]+squashDefines _ [] = []+squashDefines env (Important "defined" : ts) = go ts+ where go (t@(Other _) : ts') = t : go ts'+ go (Important "(" : ts') = Important "(" : go ts'+ go (Important t : ts') =+ case lookupKey t env of+ Nothing -> Important "0" : squashDefines env ts'+ Just (_,env') -> Important "1" : squashDefines env' ts'+ go [] = []+squashDefines env (t : ts) = t : squashDefines env ts++getCmd :: String -> Maybe (String,[Token])+getCmd = aux . dropWhile (not . isImportant) . tokenize+ where aux (Important "#" : ts) =+ let (Important cmd:toks) = dropWhile (not . isImportant) ts+ in Just (cmd, toks)+ aux _ = Nothing++-- | Feed an entire conditional block (bounded by @#if@/@#endif@) as+-- the first argument to the given continuation, and the remaining+-- input as the second argument.+takeConditional :: [String] -> (DList String -> [String] -> r) -> r+takeConditional lns0 k = go id lns0+ where go acc [] = k acc []+ go acc (ln:lns) =+ case getCmd ln of+ Nothing -> go (acc . (ln:)) lns+ Just (cmd,_)+ | cmd == "endif" -> k (acc . (ln:)) lns+ | cmd `elem` ["if","ifdef","ifndef"] ->+ takeConditional lns $+ \acc' lns' -> go (acc . (ln:) . acc') lns'+ | otherwise -> go (acc . (ln:)) lns++-- | Take everything up to the end of this branch, drop all remaining+-- branches (if any), and inject a @line@ update command in the+-- remaining stream. The first argument is the first line of branch+-- being taken. This is supplied so branches not taken can be+-- discounted from the running line count.+takeBranch :: [String] -> Either Error [String]+takeBranch = go id+ where go _ [] = Left UnterminatedBranch+ go acc (ln:lns) =+ case getCmd ln of+ Just (cmd,_)+ | cmd `elem` ["if","ifdef","ifndef"] ->+ takeConditional lns $+ \acc' lns' -> go (acc . (ln:) . acc') lns'+ | cmd == "endif" -> Right (acc [] ++ lns)+ | cmd `elem` ["else","elif"] ->+ case dropAllBranches lns of+ Right lns' -> Right $ acc [] ++ lns'+ Left err -> Left err+ _ -> go (acc . (ln:)) lns++dropAllBranches :: [String] -> Either Error [String]+dropAllBranches = aux <=< dropBranch+ where aux :: [String] -> Either Error [String]+ aux [] = Left UnterminatedBranch+ aux (ln:lns) = case getCmd ln of+ Just ("endif",_) -> Right lns+ _ -> dropAllBranches lns++-- | Skip to the end of a conditional branch, returning the remaining+-- input.+dropBranch :: [String] -> Either Error [String]+dropBranch = go+ where go [] = Left UnterminatedBranch+ go (l:ls) = case getCmd l of+ Just (cmd,_)+ -- Drop nested conditional blocks+ | cmd `elem` ["if","ifdef","ifndef"] ->+ dropAllBranches ls >>= go+ | cmd `elem` ["else","elif","endif"] -> Right (l:ls)+ | otherwise -> go ls+ Nothing -> go ls++-- | Returns a new macro binding environment and the result of+-- expanding the input string.+macroExpansion :: Config+ -- ^ Options controlling the preprocessor+ -> Env+ -- ^ Macro binding environment+ -> [String]+ -- ^ Input lines+ -> ErrHpp (Env, [String])+macroExpansion cfg0 macros = go 1 cfg0 macros id+ where go :: Int -> Config -> [(String, Macro)]+ -> DList String -> [String]+ -> ErrHpp (Env, [String])+ go _ _ ms acc [] = return (ms, acc [])+ go lineNum cfg ms acc (x:xs) =+ case dropWhile isSpace x of+ [] -> go (lineNum + 1) cfg ms (acc . (x:)) xs+ ('#':cmd) -> do k <- directive cfg lineNum cmd+ k (\lineNum' newLines cfg' ms' remainingInput ->+ go lineNum' cfg' ms' (acc . (newLines++))+ remainingInput)+ ms xs+ _ -> do (ms',x') <- either errorHpp pure $+ expandLine cfg lineNum ms (tokenize x)+ go (lineNum+1) cfg ms' (acc . (detokenize x':)) xs++-- | @preprocess env src@ runs the pre-processor over source code+-- @src@ beginning with macro binding environment @env@.+preprocess :: Env -> String -> ErrHpp (Env, String)+preprocess env inp =+ do cfg <- liftHpp $ GetConfig return+ let splicer = if spliceLongLines cfg then lineSplicing else id+ decomment = if eraseCComments cfg then commentRemoval else id+ appSplicer = if runIdentity (spliceApplicationsF cfg)+ then spliceApplications else id+ go = macroExpansion cfg env+ -- (\lns -> return (env, lns))+ . appSplicer . splicer . decomment+ . map trigraphReplacement+ fmap (second unlines) . go $ lines inp++-- | Run an 'Hpp' action that might fail with a given initial+-- configuration.+runErrHppIO :: Config -> ErrHpp a -> IO a+runErrHppIO cfg = fmap (either err (either err id)) . runHpp cfg . runErrHpp+ where err :: (FilePath,Error) -> a+ err = error . show
+ src/Hpp/Config.hs view
@@ -0,0 +1,90 @@+-- | Preprocessor Configuration+module Hpp.Config where+import Data.Functor.Identity+import Data.Time.Clock (getCurrentTime, UTCTime)+import Data.Time.Format++-- | A 'String' representing a time.+newtype TimeString = TimeString { getTimeString :: String }+ deriving (Eq, Ord, Show)++-- | A 'String' representing a date.+newtype DateString = DateString { getDateString :: String }+ deriving (Eq, Ord, Show)++-- | Pre-processor configuration parameterized over a functor. This is+-- used to normalize partial configurations, @ConfigF Maybe@, and+-- configurations suitable for the pre-processor logic, @ConfigF+-- Identity@. Specifically, the source file name of the file being+-- processed /must/ be set.+data ConfigF f = Config { curFileNameF :: f FilePath+ , includePathsF :: f [FilePath]+ , spliceLongLinesF :: f Bool+ , eraseCCommentsF :: f Bool+ , spliceApplicationsF :: f Bool+ , prepDateF :: f DateString+ , prepTimeF :: f TimeString }++-- | A fully-populated configuration for the pre-processor.+type Config = ConfigF Identity++-- | Ensure that required configuration fields are supplied.+realizeConfig :: ConfigF Maybe -> Maybe Config+realizeConfig (Config (Just fileName)+ (Just paths)+ (Just spliceLines)+ (Just comments)+ (Just spliceApps)+ (Just pdate)+ (Just ptime)) =+ Just (Config (pure fileName) (pure paths) (pure spliceLines) (pure comments)+ (pure spliceApps) (pure pdate) (pure ptime))+realizeConfig _ = Nothing++-- | Extract the current file name from a configuration.+curFileName :: Config -> FilePath+curFileName = runIdentity . curFileNameF++-- | Extract the include paths name from a configuration.+includePaths :: Config -> [FilePath]+includePaths = runIdentity . includePathsF++-- | Determine if continued long lines should be spliced.+spliceLongLines :: Config -> Bool+spliceLongLines = runIdentity . spliceLongLinesF++-- | Determine if C-style comments should be erased.+eraseCComments :: Config -> Bool+eraseCComments = runIdentity . eraseCCommentsF++-- | The date the pre-processor was run on.+prepDate :: Config -> DateString+prepDate = runIdentity . prepDateF++-- | The time of the active pre-processor invocation.+prepTime :: Config -> TimeString+prepTime = runIdentity . prepTimeF++-- | A default configuration with no current file name set.+defaultConfigF :: ConfigF Maybe+defaultConfigF = Config Nothing (Just [])+ (Just False) (Just False) (Just False)+ (Just (DateString "??? ?? ????"))+ (Just (TimeString "??:??:??"))++-- | Format a date according to the C spec.+formatPrepDate :: UTCTime -> DateString+formatPrepDate = DateString . formatTime defaultTimeLocale "%b %e %Y"++-- | Format a time according to the C spec.+formatPrepTime :: UTCTime -> TimeString+formatPrepTime = TimeString . formatTime defaultTimeLocale "%T"++-- | A default preprocessor configuration with date and time stamps+-- taken from the current system time.+defaultConfigFNow :: IO (ConfigF Maybe)+defaultConfigFNow = do now <- getCurrentTime+ let d = formatPrepDate now+ t = formatPrepTime now+ return $ defaultConfigF { prepDateF = Just d+ , prepTimeF = Just t }
+ src/Hpp/Env.hs view
@@ -0,0 +1,22 @@+-- | A name binding context, or environment.+module Hpp.Env where+import Hpp.Types (Macro)++-- | A macro binding environment.+type Env = [(String, Macro)]++-- | Delete an entry from an association list.+deleteKey :: Eq a => a -> [(a,b)] -> [(a,b)]+deleteKey k = go+ where go [] = []+ go (h@(x,_) : xs) = if x == k then xs else h : go xs++-- | Looks up a value in an association list. If the key is found, the+-- value is returned along with an updated association list with that+-- key at the front.+lookupKey :: Eq a => a -> [(a,b)] -> Maybe (b, [(a,b)])+lookupKey k = go id+ where go _ [] = Nothing+ go acc (h@(x,v) : xs)+ | k == x = Just (v, h : acc [] ++ xs)+ | otherwise = go (acc . (h:)) xs
+ src/Hpp/Expansion.hs view
@@ -0,0 +1,177 @@+-- | Line expansion is the core input token processing+-- logic. Object-like macros are substituted, and function-like macro+-- applications are expanded.+module Hpp.Expansion (expandLine) where+import Control.Arrow (first)+import Control.Monad ((<=<))+import Data.Bool (bool)+import Data.List (delete)+import Data.Maybe (listToMaybe, mapMaybe)+import Hpp.Config+import Hpp.Env+import Hpp.String+import Hpp.Tokens+import Hpp.Types++-- | Extract the 'Token' payload from a 'Scan'.+unscan :: Scan -> Maybe Token+unscan (Scan t) = Just t+unscan (Rescan t) = Just t+unscan _ = Nothing++-- | Expand a single line of tokenized code.+expandLine :: Config -> Int -> Env -> [Token]+ -> Either Error (Env, [Token])+expandLine cfg lineNum macros = fmap (\(e,ts) -> (e, mapMaybe unscan ts))+ . expandLine' cfg lineNum macros . map Scan++argError :: Int -> String -> Int -> [String] -> Error+argError lineNum name arity args =+ TooFewArgumentsToMacro lineNum $ name++"<"++show arity++">"++show args++-- | Returns the /used/ environment and the new token stream.+expandFunction :: String -> Int -> ([([Scan],String)] -> [Scan])+ -> ([String] -> Error)+ -> ([Scan] -> Either Error [Scan])+ -> [Scan]+ -> Maybe (Either Error [Scan])+expandFunction name arity f mkErr expand = aux <=< argParse+ where aux :: ([[Scan]],[Scan]) -> Maybe (Either Error [Scan])+ aux (args,rst)+ | length args /= arity = Just . Left . mkErr+ $ map (detokenize . mapMaybe unscan) args+ | otherwise = Just $+ do args' <- mapM expand args+ let raw = map (detokenize . mapMaybe unscan) args+ return $ Mask name : f (zip args' raw) +++ Unmask name : rst++type EnvLookup = String -> Maybe (Macro, Env)++expandMacro :: Config -> Int -> EnvLookup -> String -> Scan -> [Scan]+ -> (DList Scan -> Maybe Env -> [Scan] -> Either Error r)+ -> Either Error r+expandMacro cfg lineNum env name tok ts k =+ case name of+ "__LINE__" -> simple $ show lineNum+ "__FILE__" -> simple . stringify $ curFileName cfg+ "__DATE__" -> simple . stringify . getDateString $ prepDate cfg+ "__TIME__" -> simple . stringify . getTimeString $ prepTime cfg+ _ -> case env name of+ Nothing -> k (tok:) Nothing ts+ Just (m,env') ->+ case m of+ Object t' ->+ let expansion = Mask name+ : map Rescan (spaced t')+ ++ [Unmask name]+ in k id (Just env') (expansion++ts)+ Function arity f ->+ let ex = fmap snd+ . expandLine' cfg lineNum (deleteKey name env')+ err = argError lineNum name arity+ in case expandFunction name arity f err ex ts of+ Nothing -> k (tok:) (Just env') ts+ -- FIXME: Missing call to spaced?+ Just ts' ->+ do tsEx <- ts'+ k id (Just env') tsEx+ where simple s = k (Rescan (Important s):) Nothing ts+ -- Avoid accidentally merging tokens like @'-'@+ spaced xs = pre xs ++ pos+ where importantChar (Important [c]) = elem c oops+ importantChar _ = False+ pre = bool id (Other " ":)$+ (maybe False importantChar $ listToMaybe xs)+ pos = bool [] [Other " "] $+ (maybe False importantChar $ listToMaybe (reverse xs))+ oops = "-+*.><"++withMask :: Eq a => [a] -> (a -> Maybe b) -> a -> Maybe b+withMask mask f = \x -> if elem x mask then Nothing else f x++-- | Expand all macros on a /non-directive/ line. If there is a problem+-- expanding a macro (this will typically be a macro function), the+-- name of the name of the problematic macro is returned.+expandLine' :: Config -> Int -> Env -> [Scan]+ -> Either Error (Env, [Scan])+expandLine' cfg lineNum macros = go macros id []+ where go :: Env -> DList Scan -> [String] -> [Scan]+ -> Either Error (Env, [Scan])+ go env acc _ [] = Right (env, acc [])+ go env acc mask (tok@(Unmask name) : ts) =+ go env (acc . (tok:)) (delete name mask) ts+ go env acc mask (tok@(Mask name) : ts) =+ go env (acc . (tok:)) (name:mask) ts+ go env acc mask (tok@(Rescan (Important t)) : ts) =+ let envMasked = withMask mask (flip lookupKey env)+ in expandMacro cfg lineNum envMasked t tok ts $ \fAcc _ ts' ->+ go env (acc . fAcc) mask ts'+ go env acc mask (tok@(Scan (Important t)) : ts) =+ let envLook = flip lookupKey env+ in expandMacro cfg lineNum envLook t tok ts $ \fAcc env' ts' ->+ go (maybe env id env') (acc . fAcc) mask ts'+ go env acc mask (t:ts) = go env (acc . (t:)) mask ts++-- | @breakBalance end tokens@ uses the first element of @tokens@ as+-- the start of a balanced pair, and @end@ as the end of such a+-- pair. It breaks @tokens@ into a prefix with as many @end@ as start+-- tokens, and the remaining tokens.+breakBalance :: (a -> Bool) -> (a -> Bool) -> [a] -> Maybe ([a],[a])+breakBalance _ _ [] = Nothing+breakBalance start end ts0 = go (1::Int) id ts0+ where go 0 acc ts = Just (acc [], ts)+ go _ _ [] = Nothing+ go n acc (t:ts)+ | end t = go (n-1) (acc . (t:)) ts+ | start t = go (n+1) (acc . (t:)) ts+ | otherwise = go n (acc . (t:)) ts++-- | Trim whitespace from both ends of a sequence of 'Scan' tokens.+trimScan :: [Scan] -> [Scan]+trimScan [] = []+trimScan (Scan (Other _):ts) = trimScan ts+trimScan (Rescan (Other _):ts) = trimScan ts+trimScan (t@(Rescan (Important _)) : ts) = t : trimScanAux Nothing ts+trimScan (t@(Scan (Important _)) : ts) = t : trimScanAux Nothing ts+trimScan (t@(Mask _) : ts) = t : trimScan ts+trimScan (t@(Unmask _) : ts) = t : trimScan ts++-- | Collapse internal whitespace to single spaces, and trim trailing+-- space.+trimScanAux :: Maybe Scan -> [Scan] -> [Scan]+trimScanAux _ [] = []+trimScanAux _ (Scan (Other _) : ts) = trimScanAux (Just (Scan (Other " "))) ts+trimScanAux _ (Rescan (Other _) : ts) = trimScanAux (Just (Scan (Other " "))) ts+trimScanAux spc (t@(Mask _) : ts) = t : trimScanAux spc ts+trimScanAux spc (t@(Unmask _) : ts) = t : trimScanAux spc ts+trimScanAux spc (t:ts) = maybe [] (:[]) spc ++ (t : trimScanAux Nothing ts)++-- | Parse a function application. Arguments are separated by commas,+-- and the application runs until a closing parenthesis. The input+-- stream should begin immediately /after/ the opening parenthesis.+argParse :: [Scan] -> Maybe ([[Scan]], [Scan])+argParse = fmap (first (map trimScan))+ . go id id+ <=< isApplication+ . dropWhile (maybe True not . fmap isImportant . unscan)+ where go accArgs accArg (t@(Scan (Important s)):ts) =+ aux accArgs accArg t ts s+ go accArgs accArg (t@(Rescan (Important s)):ts) =+ aux accArgs accArg t ts s+ go accArgs accArg (t : ts) = go accArgs (accArg . (t:)) ts+ go _ _ [] = Nothing+ aux accArgs accArg t ts s =+ case s of + ")" -> Just (accArgs [accArg []], ts)+ "," -> go (accArgs . (accArg [] :)) id ts+ "(" -> case breakBalance (isTok "(") (isTok ")") ts of+ Nothing -> Nothing+ Just (arg,ts') -> go accArgs (accArg . (t:) . (arg++)) ts'+ _ -> go accArgs (accArg . (t:)) ts+ isApplication (Scan (Important "("):ts) = Just ts+ isApplication (Rescan (Important "("):ts) = Just ts+ isApplication _ = Nothing+ isTok t (Scan (Important s)) = t == s+ isTok t (Rescan (Important s)) = t == s+ isTok _ _ = False
+ src/Hpp/Expr.hs view
@@ -0,0 +1,352 @@+-- | An expression language corresponding to the subset of C syntax+-- that may be used in preprocessor conditional directives. See+-- <https://gcc.gnu.org/onlinedocs/cpp/If.html>+module Hpp.Expr (Expr(..), readLitInt, parseExpr, renderExpr, evalExpr) where+import Control.Applicative+import Control.Monad ((>=>))+import Data.Bits (complement, (.&.), (.|.), xor, shiftL, shiftR)+import Data.List (foldl')+import Text.Read (readMaybe)+import Hpp.Tokens+import Data.Char (digitToInt, toLower)++-- * Token Parsing Types++data BinOp = Add | Sub | Mul | Div | Mod+ | BitAnd | BitOr | BitXor | ShiftL | ShiftR+ | LessThan | GreaterThan | EqualTo | NotEqualTo+ | GreaterOrEqualTo | LessOrEqualTo+ | And | Or+ deriving (Eq, Ord, Show)++data UnaryOp = Neg | BitNot | Not | Defined deriving (Eq,Ord,Show)++data Lit = LitInt Int | LitStr String | LitChar Char | LitID String+ deriving (Eq,Ord,Show)++data Parsed = PBinOp BinOp | PUnaryOp UnaryOp | PLit Lit deriving (Eq,Ord,Show)++-- * Associativity and Precedence++data Assoc = RightLeft | LeftRight deriving (Eq, Ord, Show)++associativity :: Either BinOp UnaryOp -> Assoc+associativity = either (const LeftRight) (const RightLeft)++precedence :: Either BinOp UnaryOp -> Int+precedence (Right _) = 10+precedence (Left x) = precedenceBin x++-- | Precedence of binary operators from lowest to highest.+precedenceBin :: BinOp -> Int+precedenceBin Or = 0+precedenceBin And = 1+precedenceBin BitOr = 2+precedenceBin BitXor = 3+precedenceBin BitAnd = 4+precedenceBin EqualTo = 5+precedenceBin NotEqualTo = 5+precedenceBin LessThan = 6+precedenceBin GreaterThan = 6+precedenceBin GreaterOrEqualTo = 6+precedenceBin LessOrEqualTo = 6+precedenceBin ShiftL = 7+precedenceBin ShiftR = 7+precedenceBin Add = 8+precedenceBin Sub = 8+precedenceBin Mul = 9+precedenceBin Div = 9+precedenceBin Mod = 9++-- * Lexing++-- | String literals are split by tokenization. Fix them!+fixStringLits :: [Token] -> Maybe [String]+fixStringLits [] = Just []+fixStringLits (Important h@('"':_):xs) =+ let (hs,ys) = break ((== '"') . last . detok) xs+ in case ys of+ [] -> Nothing+ (y:ys') -> fmap ((h ++ detokenize hs ++ detok y) :)+ (fixStringLits ys')+fixStringLits (Important x:xs) = fmap (x :) (fixStringLits xs)+fixStringLits (Other _ : xs) = fixStringLits xs++onFirstImportant :: (String -> String)+ -> ([Token] -> [Token])+ -> [Token]+ -> [Token]+onFirstImportant f k = go+ where go [] = k []+ go (Important s : ts') = Important (f s) : k ts'+ go (o@(Other _) : ts') = o : go ts'++-- | Re-combine positive and negative unary operators with the tokens+-- to which they are attached.+fixUnaryOps :: [Token] -> [Token]+fixUnaryOps [] = []+fixUnaryOps (t0:ts0) =+ case t0 of+ Important "+" -> onFirstImportant ('+':) (go False) ts0+ Important "-" -> onFirstImportant ('-':) (go False) ts0+ _ -> go False (t0:ts0)+ where go _ [] = []+ go _ (Important "(":ts) = Important "(" : go True ts+ go True (Important "+":ts) = onFirstImportant ('+':) (go False) ts+ go True (Important "-":ts) = onFirstImportant ('-':) (go False) ts+ go _ (Important t:ts) = let isOp = maybe False (const True) $ parseOp t+ in Important t : go isOp ts+ go _ (o@(Other _):ts) = o : go False ts++-- | Re-combine multiple-character operators.+fixBinaryOps :: [Token] -> [Token]+fixBinaryOps [] = []+fixBinaryOps (h@(Important t1) : ts@(Important t2 : ts')) =+ case parseBinOp (t1++t2) of+ Just o -> Important (renderBinOp o) : fixBinaryOps ts'+ Nothing -> h : fixBinaryOps ts+fixBinaryOps (t:ts) = t : fixBinaryOps ts++renderBinOp :: BinOp -> String+renderBinOp Add = "+"+renderBinOp Sub = "-"+renderBinOp Mul = "*"+renderBinOp Div = "/"+renderBinOp Mod = "%"+renderBinOp BitAnd = "&"+renderBinOp BitOr = "|"+renderBinOp BitXor = "^"+renderBinOp ShiftL = "<<"+renderBinOp ShiftR = ">>"+renderBinOp LessThan = "<"+renderBinOp GreaterThan = ">"+renderBinOp EqualTo = "=="+renderBinOp NotEqualTo = "!="+renderBinOp GreaterOrEqualTo = ">="+renderBinOp LessOrEqualTo = "<="+renderBinOp And = "&&"+renderBinOp Or = "||"++renderUnaryOp :: UnaryOp -> String+renderUnaryOp Neg = "-"+renderUnaryOp BitNot = "~"+renderUnaryOp Not = "!"+renderUnaryOp Defined = "defined "++lexExpr :: [Token] -> Maybe [String]+lexExpr = fixStringLits . fixUnaryOps . fixBinaryOps++-- * Parsing Tokens++parseUnaryOp :: String -> Maybe UnaryOp+parseUnaryOp "-" = Just Neg+parseUnaryOp "~" = Just BitNot+parseUnaryOp "!" = Just Not+parseUnaryOp "defined" = Just Defined+parseUnaryOp _ = Nothing++parseBinOp :: String -> Maybe BinOp+parseBinOp "+" = Just Add+parseBinOp "-" = Just Sub+parseBinOp "*" = Just Mul+parseBinOp "/" = Just Div+parseBinOp "%" = Just Mod+parseBinOp "&" = Just BitAnd+parseBinOp "|" = Just BitOr+parseBinOp "^" = Just BitXor+parseBinOp "<<" = Just ShiftL+parseBinOp ">>" = Just ShiftR+parseBinOp "<" = Just LessThan+parseBinOp ">" = Just GreaterThan+parseBinOp "==" = Just EqualTo+parseBinOp "!=" = Just NotEqualTo+parseBinOp ">=" = Just GreaterOrEqualTo+parseBinOp "<=" = Just LessOrEqualTo+parseBinOp "&&" = Just And+parseBinOp "||" = Just Or+parseBinOp _ = Nothing++parseOp :: String -> Maybe (Either BinOp UnaryOp)+parseOp s = Left <$> parseBinOp s <|> Right <$> parseUnaryOp s++readWideChar :: String -> Maybe Char+readWideChar ('L':'\'':cs0) = go 0 cs0+ where go n ['\''] = Just $ toEnum n+ go n (c:cs) = go (n*256 + fromEnum c) cs+ go _ [] = Nothing+readWideChar _ = Nothing++readNarrowChar :: String -> Maybe Char+readNarrowChar ['\'',c,'\''] = Just c+readNarrowChar _ = Nothing++parseLit :: String -> Maybe Lit+parseLit s = case readLitInt s of+ Just i -> Just (LitInt i)+ Nothing -> case readNarrowChar s <|> readWideChar s of+ Just c -> Just (LitChar c)+ Nothing -> case readMaybe s of+ Just str -> Just (LitStr str)+ Nothing -> Nothing++digitsFromBase :: Int -> [Int] -> Int+digitsFromBase base = foldl' aux 0+ where aux acc d = base*acc + d++readLitInt' :: String -> Maybe Int+readLitInt' ('0':x:hexDigits)+ | x == 'x' || x == 'X' = fmap (digitsFromBase 16) (mapM hexDigit hexDigits)+ where hexDigit c+ | c >= '0' && c <= '9' = Just $ digitToInt c+ | c >= 'a' && c <= 'f' = Just $ (fromEnum c - fromEnum 'a') + 10+ | c >= 'A' && c <= 'F' = Just $ (fromEnum c - fromEnum 'A') + 10+ | otherwise = Nothing++readLitInt' ('0':octalDigits) = fmap (digitsFromBase 8)+ (mapM octalDigit octalDigits)+ where octalDigit c+ | c >= '0' && c < '8' = Just $ digitToInt c+ | otherwise = Nothing+readLitInt' s = readMaybe s++-- | Read a literal integer. These may be decimal, octal, or+-- hexadecimal, and may have a case-insensitive suffix of @u@, @l@, or+-- @ul@.+readLitInt :: String -> Maybe Int+readLitInt s = case map toLower . take 2 $ reverse s of+ "lu" -> readLitInt' (init (init s))+ 'l':_ -> readLitInt (init s)+ 'u':_ -> readLitInt (init s)+ _ -> readLitInt' s++-- * Shunting Yard++-- | For <https://en.wikipedia.org/wiki/Shunting-yard_algorithm reference>++data FunLike = FunBin BinOp | FunUnary UnaryOp | FunParen deriving (Eq,Ord,Show)++-- | Exhaust the function/operator stack returning the parsed+-- expression in RPN.+finishShunting :: [Parsed] -> [FunLike] -> Maybe [Parsed]+finishShunting q [] = Just (reverse q)+finishShunting _ (FunParen:_) = Nothing+finishShunting q (FunBin op:ops) = finishShunting (PBinOp op : q) ops+finishShunting q (FunUnary op:ops) = finishShunting (PUnaryOp op : q) ops++opParsed :: Either BinOp UnaryOp -> Parsed+opParsed (Left x) = PBinOp x+opParsed (Right x) = PUnaryOp x++opFun :: Either BinOp UnaryOp -> FunLike+opFun = either FunBin FunUnary++-- | Shunting yard algorithm part for dealing with operators.+juggleBinOps :: Either BinOp UnaryOp -> [Parsed] -> [FunLike]+ -> ([Parsed] -> [FunLike] -> r)+ -> r+juggleBinOps o q [] k = k q [opFun o]+juggleBinOps o1 q s@(o2:ss) k =+ case o2 of+ FunBin o -> aux $ Left o+ FunUnary o -> aux $ Right o+ FunParen -> done+ where a1 = associativity o1+ p1 = precedence o1+ aux o2'+ | a1 == LeftRight && p1 <= p2 = juggleBinOps o1 (opParsed o2':q) ss k+ | a1 == RightLeft && p1 < p2 = juggleBinOps o1 (opParsed o2':q) ss k+ | otherwise = done+ where p2 = precedence o2'+ done = k q (opFun o1 : s)++-- | Shunting yard to produce a reverse polish notation (RPN) list of+-- tokens.+shuntRPN :: [Parsed] -> [FunLike] -> [String] -> Maybe [Parsed]+shuntRPN q s [] = finishShunting q s+shuntRPN q s ("(":es) = shuntRPN q (FunParen:s) es+shuntRPN q s (")":es) = let go _ [] = Nothing+ go q' (FunParen:s') = shuntRPN q' s' es+ go q' (FunBin op:s') = go (PBinOp op : q') s'+ go q' (FunUnary op:s') = go (PUnaryOp op : q') s'+ in go q s+shuntRPN q s (('+':e@(_:_)):es) = shuntRPN q s (e:es)+shuntRPN q s (('-':e@(_:_)):es) = shuntRPN q (FunUnary Neg : s) (e:es)+shuntRPN q s ("!":es) = shuntRPN q (FunUnary Not : s) es+shuntRPN q s ("~":es) = shuntRPN q (FunUnary BitNot : s) es+shuntRPN q s ("defined":es) = shuntRPN q (FunUnary Defined : s) es+shuntRPN q s (e:es) =+ case parseLit e of+ Just l -> shuntRPN (PLit l : q) s es+ Nothing -> case parseOp e of+ Just o -> juggleBinOps o q s $+ \q' s' -> shuntRPN q' s' es+ Nothing -> shuntRPN (PLit (LitID e) : q) s es++-- * Expressions++-- | Expressions are literal values, binary operators applied to two+-- sub-expressions, or unary operators applied to a single+-- sub-expression.+data Expr = ELit Lit | EBinOp BinOp Expr Expr | EUnaryOp UnaryOp Expr+ deriving (Eq, Ord, Show)++-- | Convert an RPN list of parsed tokens into an 'Expr'.+rpnToExpr :: [Expr] -> [Parsed] -> Maybe Expr+rpnToExpr [e] [] = Just e+rpnToExpr _ [] = Nothing+rpnToExpr s (PLit e:es) = rpnToExpr (ELit e:s) es+rpnToExpr (s:ss) (PUnaryOp o : es) = rpnToExpr (EUnaryOp o s:ss) es+rpnToExpr (s1:s2:ss) (PBinOp o : es) = rpnToExpr (EBinOp o s2 s1 : ss) es+rpnToExpr _ _ = Nothing++-- | Try to read an 'Expr' from a sequence of 'Token's.+parseExpr :: [Token] -> Maybe Expr+parseExpr = lexExpr >=> shuntRPN [] [] >=> rpnToExpr []++-- | Pretty-print an 'Expr' to something semantically equivalent to the original+-- C syntax (some parentheses may be added).+renderExpr :: Expr -> String+renderExpr (ELit (LitInt e)) = show e+renderExpr (ELit (LitStr e)) = '"':e++"\""+renderExpr (ELit (LitChar c)) = [c]+renderExpr (ELit (LitID e)) = e+renderExpr (EBinOp o e1 e2) = concat [ "(", renderExpr e1," ",renderBinOp o + , " ", renderExpr e2, ")" ]+renderExpr (EUnaryOp o e1) = renderUnaryOp o ++ renderExpr e1++-- * Evaluation++-- | @evalExpr isDefined e@ evaluates expression @e@ in an environment+-- where the existence of macro definitions is captured by the+-- @isDefined@ predicate. All expressions evaluate to an 'Int'!+evalExpr :: Expr -> Int+evalExpr = go+ where go (ELit (LitInt e)) = e+ go (ELit (LitStr _)) = 1+ go (ELit (LitID _)) = 0+ go (ELit (LitChar c)) = fromEnum c+ go (EBinOp Add e2 e3) = go e2 + go e3+ go (EBinOp Sub e2 e3) = go e2 - go e3+ go (EBinOp Mul e2 e3) = go e2 * go e3+ go (EBinOp Div e2 e3) = go e2 `div` go e3+ go (EBinOp Mod e2 e3) = go e2 `mod` go e3+ go (EBinOp BitAnd e2 e3) = go e2 .&. go e3+ go (EBinOp BitOr e2 e3) = go e2 .|. go e3+ go (EBinOp BitXor e2 e3) = go e2 `xor` go e3+ go (EBinOp ShiftL e2 e3) = go e2 `shiftL` go e3+ go (EBinOp ShiftR e2 e3) = go e2 `shiftR` go e3+ go (EBinOp LessThan e2 e3) = fromEnum $ go e2 < go e3+ go (EBinOp GreaterThan e2 e3) = fromEnum $ go e2 > go e3+ go (EBinOp EqualTo e2 e3) = fromEnum $ go e2 == go e3+ go (EBinOp NotEqualTo e2 e3) = fromEnum $ go e2 /= go e3+ go (EBinOp GreaterOrEqualTo e2 e3) = fromEnum $ go e2 >= go e3+ go (EBinOp LessOrEqualTo e2 e3) = fromEnum $ go e2 <= go e3+ go (EBinOp And e2 e3) = fromEnum $ go e2 /= 0 && go e3 /= 0+ go (EBinOp Or e2 e3) = fromEnum $ go e2 /= 0 || go e3 /= 0+ go (EUnaryOp Neg e2) = -(go e2)+ go (EUnaryOp BitNot e2) = complement $ go e2+ go (EUnaryOp Not e2) = fromEnum $ go e2 == 0+ go (EUnaryOp Defined e2) =+ case e2 of + ELit (LitInt 1) -> 1+ _ -> 0
+ src/Hpp/String.hs view
@@ -0,0 +1,34 @@+-- | Helpers for working with 'String's+module Hpp.String where+import Data.Char (isSpace)++-- | Stringification puts double quotes around a string and+-- backslashes before existing double quote characters and backslash+-- characters.+stringify :: String -> String+stringify s = '"' : concatMap aux (strip s) ++ "\""+ where aux '\\' = "\\\\"+ aux '"' = "\\\""+ aux c = [c]+ strip = trimSpaces . dropWhile isSpace++-- | Remove double quote characters from the ends of a string.+unquote :: String -> String+unquote ('"':xs) = go xs+ where go ['"'] = []+ go [] = []+ go (c:cs) = c : go cs+unquote xs = xs++-- | Trim trailing spaces from a 'String'+trimSpaces :: String -> String+trimSpaces = trimEnd isSpace++-- | Remove a suffix of a list all of whose elements satisfy the given+-- predicate.+trimEnd :: (a -> Bool) -> [a] -> [a]+trimEnd p = go id+ where go _ [] = []+ go acc (c:cs)+ | p c = go (acc . (c:)) cs+ | otherwise = acc (c : go id cs)
+ src/Hpp/Tokens.hs view
@@ -0,0 +1,96 @@+-- | Tokenization breaks a 'String' into pieces of whitespace,+-- constants, symbols, and identifiers.+module Hpp.Tokens where+import Data.Char (isAlphaNum, isDigit, isSpace)++-- | Tokenization is 'words' except the white space is tagged rather+-- than discarded.+data Token = Important String+ -- ^ Identifiers, symbols, and constants+ | Other String+ -- ^ White space, etc.+ deriving (Eq,Ord,Show)++-- | Extract the contents of a 'Token'.+detok :: Token -> String+detok (Important s) = s+detok (Other s) = s++-- | 'True' if the given 'Token' is 'Important'; 'False' otherwise.+isImportant :: Token -> Bool+isImportant (Important _) = True+isImportant _ = False++-- | Return the contents of only 'Important' (non-space) tokens.+importants :: [Token] -> [String]+importants = map detok . filter isImportant++-- | Break a 'String' into space and non-whitespace runs.+tokWords :: String -> [Token]+tokWords [] = []+tokWords (c:cs)+ | isSpace c = let (spaces,rst) = break (not . isSpace) cs+ in Other (c : spaces) : tokWords rst+ | c == '\'' && isCharLit = goCharLit+ | c == '"' = flip skipLiteral cs $ \str rst ->+ Important (str []) : tokWords rst+ | otherwise = let (chars,rst) = break (not . validIdentifierChar) cs+ in Important (c:chars) : tokWords rst+ where (isCharLit, goCharLit) =+ case cs of+ (c':'\'':cs') -> (True, Important ['\'',c','\''] : tokWords cs')+ _ -> (False, [])++-- | If you encounter a string literal, call this helper with a+-- double-barreled continuation and the rest of your input. The+-- continuation will be called with the remainder of the string+-- literal as the first argument, and the remaining input as the+-- second argument.+skipLiteral :: ((String -> String) -> String -> r) -> String -> r+skipLiteral k = go ('"':)+ where go acc ('\\':'\\':cs) = go (acc . ("\\\\"++)) cs+ go acc ('\\':'"':cs) = go (acc . ("\\\""++)) cs+ -- go acc (c:'"':cs) = k (acc . ([c,'"']++)) cs+ go acc ('"':cs) = k (acc . ('"':)) cs+ go acc (c:cs) = go (acc . (c :)) cs+ go acc [] = k acc []++-- | @splits isDelimiter str@ tokenizes @str@ using @isDelimiter@ as a+-- delimiter predicate. Leading whitespace is also stripped from+-- tokens.+splits :: (Char -> Bool) -> String -> [String]+splits isDelim = filter (not . null) . go . dropWhile isSpace+ where go s = case break isDelim s of+ (h,[]) -> [dropWhile isSpace h]+ (h,d:t) -> dropWhile isSpace h : [d] : go t++-- | Predicate on space characters based on something approximating+-- valid identifier syntax. This is used to break apart non-space+-- characters.+validIdentifierChar :: Char -> Bool+validIdentifierChar c = isAlphaNum c || c == '_' || c == '\''++-- | Something like @12E+FOO@ is a single pre-processor token, so+-- @FOO@ should not be macro expanded.+fixExponents :: [Token] -> [Token]+fixExponents [] = []+fixExponents (Important (t1@(d1:_)):Important [c]:Important (d2:t2):ts)+ | elem c "-+" && isDigit d1 && elem (last t1) "eE" && isAlphaNum d2 =+ Important (t1++c:d2:t2) : fixExponents ts+fixExponents (t:ts) = t : fixExponents ts++-- | Break an input 'String' into a sequence of 'Tokens'. Warning:+-- This may not exactly correspond to your target language's+-- definition of a valid identifier!+tokenize :: String -> [Token]+tokenize = fixExponents . concatMap seps . tokWords+ where seps t@(Other _) = [t]+ seps t@(Important ('"':_)) = [t]+ seps t@(Important ('\'':_)) = [t]+ seps (Important s) = map Important $+ splits (not . validIdentifierChar) s++-- | Collapse a sequence of 'Tokens' back into a 'String'. @detokenize+-- . tokenize == id@.+detokenize :: [Token] -> String+detokenize = concatMap detok
+ src/Hpp/Types.hs view
@@ -0,0 +1,122 @@+{-# LANGUAGE LambdaCase #-}+-- | The core types involved used by the pre-processor.+module Hpp.Types where+import Hpp.Config+import Hpp.Tokens++-- | Line numbers are represented as 'Int's+type LineNum = Int++-- * Errors++-- | Error conditions we may encounter.+data Error = UnterminatedBranch+ | BadMacroDefinition LineNum+ | BadIfPredicate+ | BadLineArgument LineNum String+ | IncludeDoesNotExist LineNum FilePath+ | FailedInclude LineNum FilePath+ | UserError LineNum String+ | UnknownCommand LineNum String+ | TooFewArgumentsToMacro LineNum String+ | BadMacroArguments LineNum String+ | NoInputFile+ | BadCommandLine String+ deriving (Eq, Ord, Show)++-- * Pre-processor Actions++-- | A free monad construction to strictly delimit what capabilities+-- we need to perform pre-processing.+data Hpp a = Pure a+ | ReadFile Int FilePath (String -> Hpp a)+ | ReadNext Int FilePath (String -> Hpp a)+ | GetConfig (Config -> Hpp a)+ | SetConfig Config (Hpp a)++instance Functor Hpp where+ fmap f (Pure a) = Pure (f a)+ fmap f (ReadFile ln file k) = ReadFile ln file (fmap f . k)+ fmap f (ReadNext ln file k) = ReadNext ln file (fmap f . k)+ fmap f (GetConfig k) = GetConfig (fmap f . k)+ fmap f (SetConfig cfg k) = SetConfig cfg (fmap f k)++instance Applicative Hpp where+ pure = Pure+ Pure f <*> Pure x = Pure (f x)+ Pure f <*> ReadFile ln file k = ReadFile ln file (fmap f . k)+ Pure f <*> ReadNext ln file k = ReadNext ln file (fmap f . k)+ Pure f <*> GetConfig k = GetConfig (fmap f . k)+ Pure f <*> SetConfig cfg k = SetConfig cfg (fmap f k)+ ReadFile ln file k <*> x = ReadFile ln file ((<*> x) . k)+ ReadNext ln file k <*> x = ReadNext ln file ((<*> x) . k)+ GetConfig k <*> x = GetConfig ((<*> x) . k)+ SetConfig cfg k <*> x = SetConfig cfg (k <*> x)++instance Monad Hpp where+ return = pure+ Pure x >>= f = f x+ ReadFile ln file k >>= f = ReadFile ln file ((>>= f) . k)+ ReadNext ln file k >>= f = ReadNext ln file ((>>= f) . k)+ GetConfig k >>= f = GetConfig ((>>= f) . k)+ SetConfig cfg k >>= f = SetConfig cfg (k >>= f)++-- | An 'Hpp' action that can fail.+newtype ErrHpp a = ErrHpp { runErrHpp :: Hpp (Either (FilePath,Error) a) }++instance Functor ErrHpp where+ fmap f = ErrHpp . fmap (fmap f) . runErrHpp++instance Applicative ErrHpp where+ pure = ErrHpp . pure . pure+ ErrHpp f <*> ErrHpp x =+ ErrHpp $+ do f >>= \case+ Left err -> return (Left err)+ Right f' -> do x >>= \case+ Left err' -> return (Left err')+ Right x' -> return (Right $ f' x')++instance Monad ErrHpp where+ return = pure+ ErrHpp x >>= fb = ErrHpp $ do x >>= \case+ Left err -> return (Left err)+ Right x' -> runErrHpp (fb x')++-- * Expansion++-- | Macro expansion involves treating tokens differently if they+-- appear in the original source for or as the result of a previous+-- macro expansion. This distinction is used to prevent divergence by+-- masking out definitions that could be used recursively.+-- +-- Things are made somewhat more complicated than one might expect due+-- to the fact that the scope of this masking is /not/ structurally+-- recursive. A object-like macro can expand into a fragment of a+-- macro function application, one of whose arguments is a token+-- matching the original object-like macro. That argument should /not/+-- be expanded.+data Scan = Unmask String+ | Mask String+ | Scan Token+ | Rescan Token+ deriving Show++-- | A difference list is a list representation with @O(1)@ @snoc@'ing at+-- the end of the list.+type DList a = [a] -> [a]++-- * Macros++-- | There are object-like macros and function-like macros.+data Macro = Object [Token]+ -- ^ An object-like macro is replaced with its definition+ | Function Int ([([Scan],String)] -> [Scan])+ -- ^ A function-like macro of some arity taks+ -- macro-expanded and raw versions of its arguments, then+ -- substitutes them into a body producing a new set of+ -- tokens.++instance Show Macro where+ show (Object ts) = "Object "++ detokenize ts+ show (Function n _) = "Fun<"++show n++">"
+ src/Main.hs view
@@ -0,0 +1,144 @@+{-# LANGUAGE LambdaCase #-}+import Control.Monad (join, unless)+import Hpp+import Hpp.Config+import Hpp.Env (Env, deleteKey)+import Hpp.Tokens+import Hpp.Types (Error(..))+import System.Directory (doesFileExist)+import System.Environment+import System.FilePath (splitFileName)++usage :: IO ()+usage = mapM_ putStrLn+ [ "Usage: hpp [options] inputFile [outputFile]"+ , ""+ , "Options:"+ , "-D name"+ , " Define name as an object macro defined as 1."+ , "-D name=definition"+ , " Define name as an object macro defined as definition."+ , "-U name"+ , " Remove any previous definition of name."+ , "-I dir"+ , " Add directory dir to the search path for includes."+ , "-o file"+ , " Write output to file."+ , "-include file"+ , " Acts as if #include \"file\" were the first line "+ , " in the primary source file. -include options are "+ , " processed after -D and -U options."+ , "-imacros file"+ , " Like -include, except that output is discarded. Only"+ , " macro definitions are kept."+ , "--cpp"+ , " C98 compatibility. Implies: --fline-splice --ferase-comments"+ , " --fapplication-splice -D __STDC__ "+ , " -D __STDC_VERSION__=199409L -D _POSIX_C_SOURCE=200112L"+ , "--fline-splice"+ , " Enable continued line splicing."+ , "--ferase-comments"+ , " Remove all C-style comments before processing."+ , "--fapplication-splice"+ , " Support multi-line function applications." ]++breakEqs :: String -> [String]+breakEqs = aux . break (== '=')+ where aux (h,[]) = [h]+ aux (h,'=':t) = [h,"=",t]+ aux _ = error "breakEqs broke"++-- | If no space is included between a switch and its argument, break+-- it into two tokens to simplify parsing.+splitSwitches :: String -> [String]+splitSwitches ('-':'I':t@(_:_)) = ["-I",t]+splitSwitches ('-':'D':t@(_:_)) = ["-D",t]+splitSwitches ('-':'U':t@(_:_)) = ["-U",t]+splitSwitches ('-':'o':t@(_:_)) = ["-o",t]+splitSwitches x = [x]++-- FIXME: Defining function macros probably doesn't work here.+parseArgs :: ConfigF Maybe -> [String]+ -> IO (Either Error (Env, [String], Config, Maybe FilePath))+parseArgs cfg0 = go [] id cfg0 Nothing . concatMap breakEqs+ where go env acc cfg out [] =+ case realizeConfig cfg of+ Just cfg' -> return (Right (env, acc [], cfg', out))+ Nothing -> return (Left NoInputFile)+ go env acc cfg out ("-D":name:"=":body:rst) =+ case parseDefinition (Important name : Other " " : tokenize body) of+ Nothing -> return . Left $ BadMacroDefinition 0+ Just def -> go (def:env) acc cfg out rst+ go env acc cfg out ("-D":name:rst) =+ case parseDefinition ([Important name, Other " ", Important "1"]) of+ Nothing -> return . Left $ BadMacroDefinition 0+ Just def -> go (def:env) acc cfg out rst+ go env acc cfg out ("-U":name:rst) =+ go (deleteKey name env) acc cfg out rst+ go env acc cfg out ("-I":dir:rst) =+ let cfg' = cfg { includePathsF = fmap (++[dir]) (includePathsF cfg) }+ in go env acc cfg' out rst+ go env acc cfg out ("-include":file:rst) =+ let ln = "#include \"" ++ file ++ "\""+ in go env (acc . (ln:)) cfg out rst+ go env acc cfg out ("--cpp":rst) =+ let cfg' = cfg { spliceLongLinesF = Just True+ , eraseCCommentsF = Just True+ , spliceApplicationsF = Just True }+ defs = concatMap ("-D":)+ [ ["__STDC__"]+ -- __STDC_VERSION__ is only defined in C94 and later+ , ["__STDC_VERSION__","=","199409L"]+ , ["_POSIX_C_SOURCE","=","200112L"] ]+ in go env acc cfg' out (defs ++ rst)+ go env acc cfg out ("--fline-splice":rst) =+ go env acc (cfg { spliceLongLinesF = Just True }) out rst+ go env acc cfg out ("--ferase-comments":rst) =+ go env acc (cfg { eraseCCommentsF = Just True }) out rst+ go env acc cfg out ("--fapplication-splice":rst) =+ go env acc (cfg { spliceApplicationsF = Just True }) out rst+ go env acc cfg _ ("-o":file:rst) =+ go env acc cfg (Just file) rst+ go env acc cfg out ("-x":_lang:rst) =+ go env acc cfg out rst -- We ignore source language specification+ go env acc cfg Nothing (file:rst) =+ case curFileNameF cfg of+ Nothing -> go env acc (cfg { curFileNameF = Just file }) Nothing rst+ Just _ -> go env acc cfg (Just file) rst+ go _ _ _ (Just _) _ =+ return . Left $ BadCommandLine "Multiple output files given"++main :: IO ()+main = do getArgs >>= \case+ [] -> usage+ args -> do cfgNow <- defaultConfigFNow+ let args' = concatMap splitSwitches args+ (env,lns,cfg,outPath) <- fmap (either (error . show) id)+ (parseArgs cfgNow args')+ exists <- doesFileExist (curFileName cfg)+ unless exists . error $+ "Couldn't open input file: "++curFileName cfg+ let (_dir,fileName) = splitFileName $ curFileName cfg+ cfg' = cfg { curFileNameF = pure fileName }+ join . runErrHppIO cfg' $+ do src <- liftHpp . hppReadFile 0+ $ '"' : curFileName cfg ++ "\""+ + (_,r) <- preprocess env (unlines lns ++ src)+ case outPath of+ Nothing -> return (putStrLn r)+ Just f -> return (writeFile f r)+++{-++For testing against C:++hpp -I/usr/local/include -I/usr/include -fline-splice -ferase-comments -fapplication-splice -D __x86_64__ -D __GNUC__ -D _POSIX_C_SOURCE n_1.c++For the mcpp validation suite++../tool/cpp_test HPP "../../dist/build/hpp/hpp -I/usr/local/include -I/usr/include -fline-splice -ferase-comments -fapplication-splice -D __x86_64__ -D __GNUC__=4 -D __STDC__ -D __STDC_VERSION__=199409L -D _POSIX_C_SOURCE -D __DARWIN_ONLY_UNIX_CONFORMANCE %s.c | gcc -o %s -x c -" "rm %s" < n_i_.lst +++-}
+ tests/mcpp-validation.sh view
@@ -0,0 +1,87 @@+#!/usr/bin/env bash++HOST='http://tcpdiag.dl.sourceforge.net/project/mcpp/mcpp/V.2.7.2/'+FILE='mcpp-2.7.2.tar.gz'+GCC=gcc++# Note: head -n -1 would be faster than "sed '$ d'", but doesn't work+# with BSD or OS X head. ++# Get the include paths GCC will use by default.+GCCDIR=($(echo | ${GCC} -E -v - 2>&1 | sed -n '/#include <...> search starts/,/End of search list/ p' | tail -n +2 | sed '$ d' | grep -v '(framework directory)' | sed 's/^[[:space:]]*//'))++if (! [ $? -eq 0 ]) || [ -z "${GCCDIR}" ]; then+ GCCDIR=""+else+ GCCDIR="${GCCDIR[@]/#/-I}"+fi++if ! [ -d "mcpp-2.7.2" ]; then+ echo 'Downloading MCPP source'+ curl "${HOST}${FILE}" > "${FILE}"+ tar xf ${FILE}+fi++if ! [ -f tool/cpp_test ]; then+ echo 'Building the test runner'+ (cd mcpp-2.7.2/tool && gcc cpp_test.c -o cpp_test)+ if ! [ $? -eq 0 ]; then+ echo 'Building cpp_test failed'+ exit 1+ fi+fi++echo 'Building hpp'+(cd .. && cabal build)+if ! [ $? -eq 0 ]; then+ echo 'Building hpp failed'+ exit 1+fi++echo 'Running the validation suite'++# I explicitly add /usr/include to the start of the include file+# search path to avoid trouble on OS X. Specifically, the inclusion of+# <limits.h> causes trouble if the Clang version is picked up before+# the POSIX version.++# Note that we define __i386__ as the architecture as the MCPP+# validation test n_12.c assumes a long is 32 bits.++(cd mcpp-2.7.2/test-c && ../tool/cpp_test HPP "../../../dist/build/hpp/hpp -I/usr/include ${GCCDIR} --cpp -D__i386__ -D__DARWIN_ONLY_UNIX_CONFORMANCE %s.c | gcc -o %s -w -x c -" "rm %s" < n_i_.lst)++if ! [ $? -eq 0 ]; then+ echo 'The test runner exited with an error.'+ exit 1+fi+++ALLTESTS=($(cat mcpp-2.7.2/test-c/n_i_.lst))++if [ -f "mcpp-2.7.2/test-c/HPP.sum" ]; then+ GLOBIGNORE="*"+ RESULTS=($(tail -n +10 mcpp-2.7.2/test-c/HPP.sum | head -n 35))+ ALLPASSED=1+ for i in "${!ALLTESTS[@]}"; do+ case ${RESULTS[$i]} in+ "o")+ echo "Test ${ALLTESTS[$i]} compiled, but execution failed"+ ALLPASSED=0+ ;;+ "-")+ echo "Test ${ALLTESTS[$i]} could not be compiled"+ ALLPASSED=0+ ;;+ esac+ done+ if [ ${ALLPASSED} -eq 1 ]; then+ echo "All ${#ALLTESTS[@]} test files passed!"+ exit 0+ else+ cat "mcpp-2.7.2/test-c/HPP.err"+ exit 1+ fi+else+ echo 'Test suite did not produce any output'+ exit 1+fi