module C.Analyzer (analyzeC) where
import Control.Monad.State
import Data.Either
import Language.C
import Language.C.Data.Ident
import Language.C.System.GCC
import Data.List
import Analyzer
import Defs.Common
import Defs.Structures
import C.Functions
-- | Name of the starting function
startingFunction :: FunctionName
startingFunction = F "main"
analyzeC :: FilePath -> IO [DSInfo]
analyzeC file = do
ast <- parseMyFile file
let (eithers, s) = runState (analyzeCTranslUnit ast) (AS [])
return $ stupidMerge $ analyzeFunctions $ rights eithers
parseMyFile :: FilePath -> IO CTranslUnit
parseMyFile input_file =
do parse_result <- parseCFile (newGCC "gcc") Nothing [] input_file
case parse_result of
Left parse_err -> error (show parse_err)
Right ast -> return ast
-- | Puts a function call into the state
putCall :: FunctionName -> [CExpr] -> TermAnalyzer ()
putCall name exprs = do
let cleanArgs = map justifyArgs exprs
modify $ \s -> s {getStateCalls = (name, cleanArgs) : getStateCalls s} where
justifyArgs :: CExpr -> Maybe VariableName
justifyArgs (CVar (Ident v _ _) _) = Just (V v)
justifyArgs _ = Nothing -- TODO function calls returning struct ds or a pointer, not only vars
getName :: CDeclr -> String
getName (CDeclr (Just (Ident str _ _)) _ _ _ _) = str
getName (CDeclr Nothing _ _ _ _) = error "function without a name? that's just ridiculous"
getType :: [CDeclSpec] -> CTypeSpec
getType declSpecs = let (_,_,_,specs,_) = partitionDeclSpecs declSpecs in
if length specs > 1
then error $ show specs -- >:D
else head specs
getArgsWithTypes :: CDeclr -> [(VariableName, CTypeSpec)]
getArgsWithTypes declr = [] --STUB
analyzeCTranslUnit :: CTranslUnit -> TermAnalyzer [Either Output (DSFun CTypeSpec)] --TODO add global variables here
analyzeCTranslUnit (CTranslUnit extDecls _) = mapM analyzeCExtDecl extDecls
analyzeCExtDecl :: CExtDecl -> TermAnalyzer (Either Output (DSFun CTypeSpec)) --TODO add global variables here
analyzeCExtDecl (CDeclExt decl) = Left `fmap` analyzeCDecl decl
analyzeCExtDecl (CFDefExt cFunDef) = Right `fmap` analyzeCFunDef cFunDef
analyzeCExtDecl a@(CAsmExt strLit dunno) = return $ Left [] --HMMM do i want to play with asm
analyzeCDecl :: CDecl -> TermAnalyzer Output
analyzeCDecl (CDecl declSpecs tripleList _) = fmcs [analyzeCDeclSpecs declSpecs, analyzeCTripleList tripleList]
analyzeCInit :: CInit -> TermAnalyzer Output
analyzeCInit (CInitExpr expr _) = analyzeCExpr expr
analyzeCInit (CInitList initList _) = analyzeCInitList initList
analyzeCInitList :: CInitList -> TermAnalyzer Output
analyzeCInitList initList = fmcs $ map (\(pds, init) -> fmcs $ analyzeCInit init : map analyzeCDesignator pds) initList
analyzeCTripleList :: [(Maybe CDeclr, Maybe CInit, Maybe CExpr)] -> TermAnalyzer Output
analyzeCTripleList tripleList = fmcs $
map (manalyzeCDeclr . (\(f,_,_) -> f)) tripleList ++
map (manalyzeCInit . (\(_,s,_) -> s)) tripleList ++
map (manalyzeCExpr . (\(_,_,t) -> t)) tripleList
analyzeCDeclSpecs :: [CDeclSpec]-> TermAnalyzer Output
analyzeCDeclSpecs declSpecs = let (_,attribs,_,_,_) = partitionDeclSpecs declSpecs in
fmcs $ map analyzeCAttr attribs
analyzeCFunDef :: CFunDef -> TermAnalyzer (DSFun CTypeSpec)
analyzeCFunDef (CFunDef declSpecs declr declarations statement _) = do
let funDec = FunDecl (F $ getName declr) (getType declSpecs) (getArgsWithTypes declr)
modify $ \s -> s {getStateCalls = []}
body <- fmcs $
[ analyzeCDeclSpecs declSpecs
, analyzeCDeclr declr
, analyzeCStat statement] ++ map analyzeCDecl declarations
s <- get
return DSF {getDSFFun = funDec, getDSFCalls = getStateCalls s, getDSFDSI = generateDSI (getFunName funDec) body}
analyzeCDerivedDeclarator :: CDerivedDeclr -> TermAnalyzer Output
analyzeCDerivedDeclarator (CPtrDeclr qualifs _) = fmcs $ map analyzeCTypeQualifier qualifs
analyzeCDerivedDeclarator (CArrDeclr qualifs arrsize _) = fmcs $ analyzeCArraySize arrsize : map analyzeCTypeQualifier qualifs
analyzeCDerivedDeclarator (CFunDeclr eidentpair attribs _) = return [] --undefined --FIXME implement this shit
analyzeCAttr :: CAttr -> TermAnalyzer Output
analyzeCAttr (CAttr ident exprs _) = fmcs $ map analyzeCExpr exprs
analyzeCTypeQualifier :: CTypeQual -> TermAnalyzer Output
analyzeCTypeQualifier (CConstQual _) = return []
analyzeCTypeQualifier (CVolatQual _) = return []
analyzeCTypeQualifier (CRestrQual _) = return []
analyzeCTypeQualifier (CInlineQual _) = return []
analyzeCTypeQualifier (CAttrQual attrib) = analyzeCAttr attrib
analyzeCArraySize :: CArrSize -> TermAnalyzer Output
analyzeCArraySize (CNoArrSize _) = return []
analyzeCArraySize (CArrSize _ expr) = analyzeCExpr expr
analyzeCDeclr :: CDeclr -> TermAnalyzer Output
analyzeCDeclr (CDeclr mident derives mliteral attribs _) = fmcs $
map analyzeCDerivedDeclarator derives ++ map analyzeCAttr attribs
analyzeCStat :: CStat -> TermAnalyzer Output
analyzeCStat (CLabel ident statement attribs _) = fmcs $ analyzeCStat statement : map analyzeCAttr attribs
analyzeCStat (CCase expr statement _) = fmcs [analyzeCExpr expr, analyzeCStat statement]
analyzeCStat (CCases expr1 expr2 statement _) = fmcs $ analyzeCStat statement : map analyzeCExpr [expr1, expr2]
analyzeCStat (CDefault statement _) = analyzeCStat statement
analyzeCStat (CExpr mexpr _) = manalyzeCExpr mexpr
analyzeCStat (CCompound idents compoundBlockItems _) = fmcs $ map analyzeCCompoundBlockItem compoundBlockItems
analyzeCStat (CIf expr statement mstatement _) = fmcs
[analyzeCExpr expr
, analyzeCStat statement
, manalyzeCStat mstatement] --TODO fix to substitute environments for cases
analyzeCStat (CSwitch expr statement _) = fmcs [analyzeCExpr expr, analyzeCStat statement]
analyzeCStat (CWhile expr statement isdowhile _) = fmcs [analyzeCExpr expr, analyzeCStat statement]
analyzeCStat (CFor emexprdecl mexpr1 mexpr2 statement _)= fmcs $
either manalyzeCExpr analyzeCDecl emexprdecl :
analyzeCStat statement :
map manalyzeCExpr [mexpr1, mexpr2]
analyzeCStat (CGoto ident _) = return [] --TODO implement goto
analyzeCStat (CGotoPtr expr _) = analyzeCExpr expr --TODO implement goto
analyzeCStat (CCont _) = return []
analyzeCStat (CBreak _) = return []
analyzeCStat (CReturn mexpr _) = manalyzeCExpr mexpr
analyzeCStat (CAsm asm _) = return [] --HMMM do i really want to care about somebody's asm?
analyzeCCompoundBlockItem :: CBlockItem -> TermAnalyzer Output
analyzeCCompoundBlockItem (CBlockStmt statement) = analyzeCStat statement
analyzeCCompoundBlockItem (CBlockDecl declaration) = analyzeCDecl declaration
analyzeCCompoundBlockItem (CNestedFunDef funDef) = return [] --TODO implement nested functions
analyzeCExpr :: CExpr -> TermAnalyzer Output
analyzeCExpr (CAlignofExpr expr _) = analyzeCExpr expr
analyzeCExpr (CAlignofType decln _) = analyzeCDecl decln
analyzeCExpr (CAssign assignop expr1 expr2 _) = fmcs $ map analyzeCExpr [expr1, expr2]
analyzeCExpr (CBinary binop expr1 expr2 _) = fmcs $ map analyzeCExpr [expr1, expr2]
analyzeCExpr (CBuiltinExpr builtin) = analyzeCBuiltin builtin
analyzeCExpr (CCall (CVar (Ident funName _ _) _) (CVar (Ident varName _ _) _:exprs) _) = do
analysis <- fmcs $ map analyzeCExpr exprs
case find (\(fd,_) -> getFunName fd == (F funName)) dsinfFunctions of
Just (_,ops) -> putCall (F funName) exprs >> (return $ analysis ++ map (\op -> (V varName, DSU op False False)) ops)
Nothing -> return analysis
analyzeCExpr (CCall expr exprs _) = fmcs $ map analyzeCExpr (expr : exprs) --TODO calling a pointer
analyzeCExpr (CCast decln expr _) = fmcs [analyzeCDecl decln, analyzeCExpr expr]
analyzeCExpr (CComma exprs _) = fmcs $ map analyzeCExpr exprs
analyzeCExpr (CComplexImag expr _) = analyzeCExpr expr
analyzeCExpr (CComplexReal expr _) = analyzeCExpr expr
analyzeCExpr (CCompoundLit decln initList _) = fmcs [analyzeCDecl decln, analyzeCInitList initList]
analyzeCExpr (CCond expr1 mexpr expr2 _) = fmcs $ manalyzeCExpr mexpr : map analyzeCExpr [expr1, expr2]
analyzeCExpr (CConst const) = return []
analyzeCExpr (CIndex expr1 expr2 _) = fmcs $ map analyzeCExpr [expr1, expr2]
analyzeCExpr (CLabAddrExpr ident _) = return []
analyzeCExpr (CMember expr ident dereferred _) = analyzeCExpr expr
analyzeCExpr (CSizeofExpr expr _) = analyzeCExpr expr
analyzeCExpr (CSizeofType decln _) = analyzeCDecl decln
analyzeCExpr (CStatExpr statement _) = analyzeCStat statement
analyzeCExpr (CUnary unop expr _) = analyzeCExpr expr
analyzeCExpr (CVar ident _) = return []
analyzeCBuiltin :: CBuiltin -> TermAnalyzer Output
analyzeCBuiltin (CBuiltinVaArg expr decl _) = fmcs [analyzeCExpr expr, analyzeCDecl decl]
analyzeCBuiltin (CBuiltinOffsetOf decl cPartDesns _) = fmcs $ analyzeCDecl decl : map analyzeCDesignator cPartDesns
analyzeCBuiltin (CBuiltinTypesCompatible decl1 decl2 _) = fmcs $ map analyzeCDecl [decl1, decl2]
analyzeCDesignator :: CDesignator -> TermAnalyzer Output
analyzeCDesignator (CArrDesig expr _) = analyzeCExpr expr
analyzeCDesignator (CMemberDesig ident _) = return []
analyzeCDesignator (CRangeDesig expr1 expr2 _) = fmcs $ map analyzeCExpr [expr1, expr2]
-- |Shortcut for 'fmap' 'concat' . 'sequence', useful in combining analysis of subterms
fmcs :: (Functor m, Monad m) => [m [a]] -> m [a]
fmcs = fmap concat . sequence
-- | Wrapper for analyzing 'Maybe' values
ma :: (a -> TermAnalyzer Output) -> Maybe a -> TermAnalyzer Output
ma = maybe (return [])
manalyzeCDeclr :: Maybe CDeclr -> TermAnalyzer Output
manalyzeCDeclr = ma analyzeCDeclr
manalyzeCStat :: Maybe CStat -> TermAnalyzer Output
manalyzeCStat = ma analyzeCStat
manalyzeCExpr :: Maybe CExpr -> TermAnalyzer Output
manalyzeCExpr = ma analyzeCExpr
manalyzeCInit :: Maybe CInit -> TermAnalyzer Output
manalyzeCInit = ma analyzeCInit