module Language.C.Analysis.AstAnalysis (
analyseAST,
analyseExt,analyseFunDef,analyseExtDecls,
)
where
import Language.C.Analysis.SemError
import Language.C.Analysis.SemRep
import Language.C.Analysis.TravMonad
import Language.C.Analysis.DefTable
import Language.C.Analysis.DeclAnalysis
import Language.C.Data
import Language.C.Syntax
import Control.Monad
import Prelude hiding (reverse)
import Data.Foldable (foldrM)
import Data.List hiding (reverse)
import Data.Maybe
import Data.Map (Map)
import qualified Data.Map as Map
import Debug.Trace
analyseAST :: (MonadTrav m) => CTranslUnit -> m GlobalDecls
analyseAST (CTranslUnit decls _file_node) = do
mapRecoverM_ analyseExt decls
liftM globalDefs getDefTable
where
mapRecoverM_ f = mapM_ (handleTravError . f)
analyseExt :: (MonadTrav m) => CExtDecl -> m ()
analyseExt (CAsmExt asm)
= handleAsmBlock asm
analyseExt (CFDefExt fundef)
= analyseFunDef fundef
analyseExt (CDeclExt decls)
= analyseExtDecls decls
analyseFunDef :: (MonadTrav m) => CFunDef -> m ()
analyseFunDef (CFunDef declspecs declr oldstyle_decls stmt node_info) = do
var_decl_info <- analyseVarDecl True declspecs declr oldstyle_decls
let (VarDeclInfo name is_inline storage_spec attrs ty declr_node) = var_decl_info
let ident = identOfVarName name
fun_storage <- computeFunDefStorage ident storage_spec
let var_decl = VarDecl name (DeclAttrs is_inline fun_storage attrs) ty
ty' <- improveFunDefType ty
handleVarDecl (Decl var_decl node_info)
stmt' <- analyseFunctionBody var_decl stmt
handleFunDef ident (FunDef var_decl stmt' node_info)
where
improveFunDefType (FunctionType (FunTypeIncomplete return_ty attrs)) =
return . FunctionType $ FunType return_ty [] False attrs
improveFunDefType ty = return $ ty
analyseExtDecls :: (MonadTrav m) => CDecl -> m ()
analyseExtDecls decl@(CDecl declspecs declrs node)
| null declrs =
case typedef_spec of Just _ -> astError node "bad typedef declaration: missing declarator"
Nothing -> analyseTypeDecl decl >> return ()
| (Just declspecs') <- typedef_spec = mapM_ (uncurry (analyseTyDef declspecs')) declr_list
| otherwise = mapM_ (uncurry analyseVarDeclr) declr_list
where
declr_list = zip (True : repeat False) declrs
typedef_spec = hasTypeDef declspecs
analyseTyDef declspecs' handle_sue_def declr =
case declr of
(Just tydeclr, Nothing , Nothing) -> analyseTypeDef handle_sue_def declspecs' tydeclr node
_ -> astError node "bad typdef declaration: bitfieldsize or initializer present"
analyseVarDeclr handle_sue_def (Just declr, init_opt, Nothing) = do
vardeclInfo@(VarDeclInfo _ _ _ _ typ _) <- analyseVarDecl handle_sue_def declspecs declr []
init_opt' <- mapMaybeM init_opt tInit
when (isTypeOfExpr typ) $ astError node "we cannot analyse typeof(expr) yet"
if (isFunctionType typ)
then extFunProto vardeclInfo
else extVarDecl vardeclInfo init_opt'
analyseVarDeclr _ (Nothing,_,_) = astError node "abstract declarator in object declaration"
analyseVarDeclr _ (_,_,Just bitfieldSz) = astError node "bitfield size in object declaration"
isTypeOfExpr (TypeOfExpr _) = True
isTypeOfExpr _ = False
analyseTypeDef :: (MonadTrav m) => Bool -> [CDeclSpec] -> CDeclr -> NodeInfo -> m ()
analyseTypeDef handle_sue_def declspecs declr node_info = do
(VarDeclInfo name is_inline storage_spec attrs ty declr_node) <- analyseVarDecl handle_sue_def declspecs declr []
checkValidTypeDef is_inline storage_spec attrs
let ident = identOfVarName name
handleTypeDef (TypeDef ident ty attrs node_info)
where
checkValidTypeDef True _ _ = astError node_info "inline specifier for typeDef"
checkValidTypeDef _ NoStorageSpec _ = return ()
checkValidTypeDef _ bad_storage _ = astError node_info $ "storage specified for typeDef: " ++ show bad_storage
analyseVarDecl :: (MonadTrav m) => Bool -> [CDeclSpec] -> CDeclr -> [CDecl] -> m VarDeclInfo
analyseVarDecl handle_sue_def declspecs declr oldstyle_params = do
let (storagespecs, decl_attrs, typequals, typespecs, inline) = partitionDeclSpecs declspecs
storage_spec <- canonicalStorageSpec storagespecs
typ <- tType handle_sue_def node typequals typespecs derived_declrs oldstyle_params
attrs' <- mapM tAttr (decl_attrs ++ declr_attrs)
name <- mkVarName node nameOpt asmname_opt
return $ VarDeclInfo name inline storage_spec attrs' typ node
where
(CDeclr nameOpt derived_declrs asmname_opt declr_attrs node) = declr
isInlineSpec (CInlineQual _) = True
isInlineSpec _ = False
computeFunDefStorage :: (MonadTrav m) => Ident -> StorageSpec -> m Storage
computeFunDefStorage _ (StaticSpec b) = return$ FunLinkage InternalLinkage
computeFunDefStorage ident other_spec = do
obj_opt <- lookupObject ident
let defaultSpec = FunLinkage ExternalLinkage
case other_spec of
NoStorageSpec -> return$ maybe defaultSpec declStorage obj_opt
(ExternSpec False) -> return$ maybe defaultSpec declStorage obj_opt
bad_spec -> throwTravError $ badSpecifierError (nodeInfo ident)
$ "unexpected function storage specifier (only static or extern is allowed)" ++ show bad_spec
extFunProto :: (MonadTrav m) => VarDeclInfo -> m ()
extFunProto (VarDeclInfo var_name is_inline storage_spec attrs ty node_info) =
do old_fun <- lookupObject (identOfVarName var_name)
checkValidSpecs
let decl = VarDecl var_name (DeclAttrs is_inline (funDeclLinkage old_fun) attrs) ty
handleVarDecl (Decl decl node_info)
where
funDeclLinkage old_fun =
case storage_spec of
NoStorageSpec -> FunLinkage ExternalLinkage
StaticSpec False -> FunLinkage InternalLinkage
ExternSpec False -> case old_fun of
Nothing -> FunLinkage ExternalLinkage
Just f -> declStorage f
_ -> error $ "funDeclLinkage: " ++ show storage_spec
checkValidSpecs
| hasThreadLocalSpec storage_spec = astError node_info "thread local storage specified for function"
| RegSpec <- storage_spec = astError node_info "invalid `register' storage specified for function"
| otherwise = return ()
extVarDecl :: (MonadTrav m) => VarDeclInfo -> (Maybe Initializer) -> m ()
extVarDecl (VarDeclInfo var_name is_inline storage_spec attrs typ node_info) init_opt =
do let ident = identOfVarName var_name
old_decl <- lookupObject ident
checkValidVarDeclStorage
let vardecl linkage = VarDecl var_name (DeclAttrs is_inline linkage attrs) typ
let decl linkage = Decl (vardecl linkage) node_info
case storage_spec of
NoStorageSpec
-> handleObjectDef ident $ ObjDef (vardecl (Static ExternalLinkage False)) init_opt node_info
StaticSpec thread_local
-> handleObjectDef ident $ ObjDef (vardecl (Static InternalLinkage thread_local)) init_opt node_info
ExternSpec thread_local
| Nothing <- init_opt
-> handleVarDecl $ decl $ maybe (Static ExternalLinkage thread_local) declStorage old_decl
| otherwise
-> do warn $ badSpecifierError node_info
"Both initializer and `extern` specifier given - treating as definition"
handleObjectDef ident $ ObjDef (vardecl (Static ExternalLinkage thread_local)) init_opt node_info
_ -> error$ "extVarDecl: storage_spec: "++show storage_spec
where
checkValidVarDeclStorage
| is_inline = astError node_info "invalide `inline' specifier for non-function"
| RegSpec <- storage_spec = astError node_info "invalid `register' storage specified for external object"
| otherwise = return ()
analyseFunctionBody :: (MonadTrav m) => VarDecl -> CStat -> m Stmt
analyseFunctionBody _ = return
tStmt :: (MonadTrav m) => CStat -> m Stmt
tStmt = return
tExpr :: (MonadTrav m) => CExpr -> m Expr
tExpr = return
tInit :: (MonadTrav m) => CInit -> m Initializer
tInit = return
hasTypeDef :: [CDeclSpec] -> Maybe [CDeclSpec]
hasTypeDef declspecs =
case foldr hasTypeDefSpec (False,[]) declspecs of
(True,specs') -> Just specs'
(False,_) -> Nothing
where
hasTypeDefSpec (CStorageSpec (CTypedef n)) (_,specs) = (True, specs)
hasTypeDefSpec spec (b,specs) = (b,spec:specs)