diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,3 @@ +# 0.1 + +First release! diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/hpp.cabal b/hpp.cabal new file mode 100644 --- /dev/null +++ b/hpp.cabal @@ -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 diff --git a/src/Hpp.hs b/src/Hpp.hs new file mode 100644 --- /dev/null +++ b/src/Hpp.hs @@ -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 diff --git a/src/Hpp/Config.hs b/src/Hpp/Config.hs new file mode 100644 --- /dev/null +++ b/src/Hpp/Config.hs @@ -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 } diff --git a/src/Hpp/Env.hs b/src/Hpp/Env.hs new file mode 100644 --- /dev/null +++ b/src/Hpp/Env.hs @@ -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 diff --git a/src/Hpp/Expansion.hs b/src/Hpp/Expansion.hs new file mode 100644 --- /dev/null +++ b/src/Hpp/Expansion.hs @@ -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 diff --git a/src/Hpp/Expr.hs b/src/Hpp/Expr.hs new file mode 100644 --- /dev/null +++ b/src/Hpp/Expr.hs @@ -0,0 +1,352 @@ +-- | An expression language corresponding to the subset of C syntax +-- that may be used in preprocessor conditional directives. See +-- +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 + +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 diff --git a/src/Hpp/String.hs b/src/Hpp/String.hs new file mode 100644 --- /dev/null +++ b/src/Hpp/String.hs @@ -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) diff --git a/src/Hpp/Tokens.hs b/src/Hpp/Tokens.hs new file mode 100644 --- /dev/null +++ b/src/Hpp/Tokens.hs @@ -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 diff --git a/src/Hpp/Types.hs b/src/Hpp/Types.hs new file mode 100644 --- /dev/null +++ b/src/Hpp/Types.hs @@ -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++">" diff --git a/src/Main.hs b/src/Main.hs new file mode 100644 --- /dev/null +++ b/src/Main.hs @@ -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 + + +-} diff --git a/tests/mcpp-validation.sh b/tests/mcpp-validation.sh new file mode 100644 --- /dev/null +++ b/tests/mcpp-validation.sh @@ -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 +# 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