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)
| (Just declspecs') <- hasTypeDef declspecs =
case declrs of
[(Just tydeclr,Nothing,Nothing)] -> analyseTypeDef declspecs' tydeclr node
_ -> astError node "bad typdef declaration: declarator missing or bitfieldsize/initializer present"
| null declrs = analyseTypeDecl decl >> return ()
| otherwise = mapM_ (uncurry convertVarDeclr) $ zip (True : repeat False) declrs
where
convertVarDeclr 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'
convertVarDeclr _ (Nothing,_,_) = astError node "abstract declarator in object declaration"
convertVarDeclr _ (_,_,Just bitfieldSz) = astError node "bitfield size in object declaration"
isTypeOfExpr (TypeOfExpr _) = True
isTypeOfExpr _ = False
analyseTypeDef :: (MonadTrav m) => [CDeclSpec] -> CDeclr -> NodeInfo -> m ()
analyseTypeDef declspecs declr node_info = do
(VarDeclInfo name is_inline storage_spec attrs ty declr_node) <- analyseVarDecl True 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)