AstAnalysis.hs

{-# LANGUAGE ScopedTypeVariables, PatternGuards #-}
-----------------------------------------------------------------------------
-- |
-- Module      :  Language.C.Parser.Translation
-- Copyright   :  (c) 2008 Benedikt Huber
-- License     :  BSD-style
-- Maintainer  :  benedikt.huber@gmail.com
-- Stability   :  alpha
-- Portability :  ghc
--
-- Analyse the parse tree
--
-- Traverses the AST, analyses declarations and invokes handlers.
-----------------------------------------------------------------------------
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


-- * analysis

-- | Analyse the given AST
--
-- @analyseAST ast@ results in global declaration dictionaries.
-- If you want to perform specific actions on declarations or definitions, you may provide
-- callbacks in the @MonadTrav@ @m@.
--
-- Returns the set of global declarations and definitions which where successfully translated.
-- It is the users responsibility to check whether any hard errors occured (@runTrav@ does this for you).
analyseAST :: (MonadTrav m) => CTranslUnit -> m GlobalDecls
analyseAST (CTranslUnit decls _file_node) = do
    mapRecoverM_ analyseExt decls
    liftM globalDefs getDefTable
    where
    mapRecoverM_ f = mapM_ (handleTravError . f)

-- | Analyse an top-level declaration
analyseExt :: (MonadTrav m) => CExtDecl -> m ()
analyseExt (CAsmExt asm)
    = handleAsmBlock asm
analyseExt (CFDefExt fundef)
    = analyseFunDef fundef
analyseExt (CDeclExt decls)
    = analyseExtDecls decls

-- | Analyse a function definition
analyseFunDef :: (MonadTrav m) => CFunDef -> m ()
analyseFunDef (CFunDef declspecs declr oldstyle_decls stmt node_info) = do
    -- analyse the declarator
    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
    -- compute storage
    fun_storage <- computeFunDefStorage ident storage_spec
    let var_decl = VarDecl name (DeclAttrs is_inline fun_storage attrs) ty
    -- improve incomplete type
    ty' <- improveFunDefType ty
    -- callback
    handleVarDecl (Decl var_decl node_info)
    -- translate the body
    stmt' <- analyseFunctionBody var_decl stmt
    -- define the function
    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

-- | Analyse a top-level declaration other than a function definition
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
        -- analyse the declarator
        vardeclInfo@(VarDeclInfo _ _ _ _ typ _) <- analyseVarDecl handle_sue_def declspecs declr []
        -- declare / define the object
        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

-- | Analyse a typedef
analyseTypeDef :: (MonadTrav m) => Bool -> [CDeclSpec] -> CDeclr -> NodeInfo -> m ()
analyseTypeDef handle_sue_def declspecs declr node_info = do
    -- analyse the declarator
    (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

-- | Analyse declarators
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
    -- analyse the storage specifiers
    storage_spec  <- canonicalStorageSpec storagespecs
    -- translate the type into semantic representation
    typ          <- tType handle_sue_def node typequals typespecs derived_declrs oldstyle_params
    -- translate attributes
    attrs'       <- mapM tAttr (decl_attrs ++ declr_attrs)
    -- create the variable name
    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

-- | compute storage of a function definition
--
-- a function definition has static storage with internal linkage if specified `static`,
-- the previously declared linkage if any if 'extern' or no specifier are present. (See C99 6.2.2, clause 5)
--
-- This function won't raise an Trav error if the declaration is incompatible with the existing one,
-- this case is handled in 'handleFunDef'.
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

-- | handle a function prototype
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 -- prototype declaration / external linkage
            StaticSpec False -> FunLinkage InternalLinkage -- prototype declaration / internal linkage
            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 ()

-- | handle a object declaration \/ definition
--
-- We have to check the storage specifiers here, as they determine wheter we're dealing with decalartions
-- or definitions
-- see [doc\/ExternalDefinitions.txt]
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           -- tentative if there is no initializer, external
               -> handleObjectDef ident $ ObjDef (vardecl (Static ExternalLinkage False)) init_opt node_info
           StaticSpec thread_local -- tentative if there is no initializer, internal
               -> handleObjectDef ident $ ObjDef (vardecl (Static InternalLinkage thread_local)) init_opt node_info
           ExternSpec thread_local
             | Nothing <- init_opt  -- declaration with either external or old storage
               -> handleVarDecl $ decl $ maybe (Static ExternalLinkage thread_local) declStorage old_decl
             | otherwise            -- warning, external definition
               -> 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 ()

-- | /TODO/: Bogus
analyseFunctionBody :: (MonadTrav m) => VarDecl -> CStat -> m Stmt
analyseFunctionBody _ = return

-- | /TODO/: Bogus
tStmt :: (MonadTrav m) => CStat -> m Stmt
tStmt = return

-- | /TODO/: Bogus
tExpr :: (MonadTrav m) => CExpr -> m Expr
tExpr = return

-- | /TODO/: Bogus
tInit :: (MonadTrav m) => CInit -> m Initializer
tInit = return


-- return @Just declspecs@ without @CTypedef@ if the declaration specifier contain @typedef@
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)