{-# 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 (
    -- * Top-level analysis
    analyseAST,
    analyseExt,analyseFunDef,analyseDecl,
    -- * Building blocks for additional analyses
    analyseFunctionBody,
    defineParams,
    -- * Type checking
    tExpr, ExprSide(..),
    tStmt, StmtCtx(..),
    tDesignator,
    defaultMD
)
where
import Language.C.Analysis.SemError
import Language.C.Analysis.SemRep
import Language.C.Analysis.TravMonad
import Language.C.Analysis.ConstEval
import Language.C.Analysis.DefTable (globalDefs, defineLabel, inFileScope,
                                     lookupLabel, insertType, lookupType)
import Language.C.Analysis.DeclAnalysis
import Language.C.Analysis.TypeUtils
import Language.C.Analysis.TypeCheck

import Language.C.Data
import Language.C.Pretty
import Language.C.Syntax.AST
import Language.C.Syntax.Constants
import Language.C.Syntax.Ops
import Language.C.Syntax.Utils
import Text.PrettyPrint.HughesPJ


import Prelude hiding (mapM, mapM_, reverse)
import Control.Monad hiding (mapM, mapM_)
import qualified Data.Map as Map
import Data.Maybe
import Data.Traversable (mapM)
import Data.Foldable (mapM_)

-- * 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 occurred (@runTrav@ does this for you).
analyseAST :: (MonadTrav m) => CTranslUnit -> m GlobalDecls
analyseAST (CTranslUnit decls _file_node) = do
    -- analyse all declarations, but recover from errors
    mapRecoverM_ analyseExt decls
    -- check we are in global scope afterwards
    getDefTable >>= \dt -> unless (inFileScope dt) $
        error "Internal Error: Not in filescope after analysis"
    -- get the global definition table (XXX: remove ?)
    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 decl)
    = analyseDecl False decl

-- | 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 Nothing
    let (VarDeclInfo name fun_spec storage_spec attrs ty _declr_node) = var_decl_info
    when (isNoName name) $ astError node_info "NoName in analyseFunDef"
    let ident = identOfVarName name
    -- improve incomplete type
    ty' <- improveFunDefType ty
    -- compute storage
    fun_storage <- computeFunDefStorage ident storage_spec
    let var_decl = VarDecl name (DeclAttrs fun_spec fun_storage attrs) ty'
    -- callback for declaration
    handleVarDecl False (Decl var_decl node_info)
    -- process body
    stmt' <- analyseFunctionBody node_info var_decl stmt
    -- callback for definition
    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

voidM :: Monad m => m a -> m ()
voidM m = m >> return ()

-- | Analyse a declaration other than a function definition
--
--   Note: static assertions are not analysed
analyseDecl :: (MonadTrav m) => Bool -> CDecl -> m ()
analyseDecl _is_local (CStaticAssert _expr _strlit _annot) = return () -- TODO
analyseDecl is_local decl@(CDecl declspecs declrs node)
    | null declrs =
        case typedef_spec of Just _  -> astError node "bad typedef declaration: missing declarator"
                             Nothing -> voidM$ analyseTypeDecl decl
    | (Just declspecs') <- typedef_spec = mapM_ (uncurry (analyseTyDef declspecs')) declr_list
    | otherwise   = do let (storage_specs, attrs, typequals, typespecs, funspecs, _alignspecs) =
                             partitionDeclSpecs declspecs
                       canonTySpecs <- canonicalTypeSpec typespecs
                       -- TODO: alignspecs not yet processed
                       let specs =
                             (storage_specs, attrs, typequals, canonTySpecs, funspecs)
                       mapM_ (uncurry (analyseVarDeclr specs)) 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 specs handle_sue_def (Just declr, init_opt, Nothing) = do
        -- analyse the declarator
        let (storage_specs, attrs, typequals, canonTySpecs, inline) = specs
        vardeclInfo@(VarDeclInfo _ _ _ _ typ _) <-
          analyseVarDecl handle_sue_def storage_specs attrs typequals canonTySpecs inline
                         declr [] Nothing
        -- declare / define the object
        if isFunctionType typ
            then extFunProto vardeclInfo
            else (if is_local then localVarDecl else extVarDecl)
                 -- XXX: if Initializer becomes different from CInit, this
                 -- will have to change.
                 vardeclInfo init_opt
        _init_opt' <- mapMaybeM init_opt (tInit typ)
        return ()
    analyseVarDeclr _ _ (Nothing,_,_)         = astError node "abstract declarator in object declaration"
    analyseVarDeclr _ _ (_,_,Just _bitfieldSz) = astError node "bitfield size in object declaration"

-- | 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 fun_attrs storage_spec attrs ty _node) <- analyseVarDecl' handle_sue_def declspecs declr [] Nothing
    checkValidTypeDef fun_attrs storage_spec attrs
    when (isNoName name) $ astError node_info "NoName in analyseTypeDef"
    let ident = identOfVarName name
    handleTypeDef (TypeDef ident ty attrs node_info)
    where
    checkValidTypeDef fun_attrs  _ _ | fun_attrs /= noFunctionAttrs =
                                         astError node_info "inline specifier for typeDef"
    checkValidTypeDef _ NoStorageSpec _ = return ()
    checkValidTypeDef _ bad_storage _ = astError node_info $ "storage specified for typeDef: " ++ show bad_storage

-- | 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 _)  = 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
    ClKernelSpec  -> 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

-- (private) Get parameters of a function type
getParams :: Type -> Maybe [ParamDecl]
getParams (FunctionType (FunType _ params _) _) = Just params
getParams _ = Nothing

-- | handle a function prototype
extFunProto :: (MonadTrav m) => VarDeclInfo -> m ()
extFunProto (VarDeclInfo var_name fun_spec storage_spec attrs ty node_info) =
    do  when (isNoName var_name) $ astError node_info "NoName in extFunProto"
        old_fun <- lookupObject (identOfVarName var_name)
        checkValidSpecs
        let decl = VarDecl var_name (DeclAttrs fun_spec (funDeclLinkage old_fun) attrs) ty
        handleVarDecl False (Decl decl node_info)
        -- XXX: structs should be handled in 'function prototype scope' too
        enterPrototypeScope
        maybe (return ()) (mapM_ handleParamDecl) (getParams ty)
        leavePrototypeScope
    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 [http://www.sivity.net/projects/language.c/wiki/ExternalDefinitions]
extVarDecl :: (MonadTrav m) => VarDeclInfo -> Maybe Initializer -> m ()
extVarDecl (VarDeclInfo var_name fun_spec storage_spec attrs typ node_info) init_opt =
    do when (isNoName var_name) $ astError node_info "NoName in extVarDecl"
       (storage,is_def) <- globalStorage storage_spec
       let vardecl = VarDecl var_name (DeclAttrs fun_spec storage attrs) typ
       if is_def
           then handleObjectDef False ident $ ObjDef vardecl init_opt node_info
           else handleVarDecl False $ Decl vardecl node_info
    where
       ident = identOfVarName var_name
       globalStorage _ | fun_spec /= noFunctionAttrs =
                           astError node_info "invalid function specifier for external variable"
       globalStorage AutoSpec      = astError node_info "file-scope declaration specifies storage `auto'"
       globalStorage RegSpec       =
         do when (isJust init_opt) $ astError node_info "initializer given for global register variable"
            case var_name of
              NoName -> astError node_info "global register variable has no name"
              VarName _ Nothing -> astError node_info "no register specified for global register variable"
              _ -> return ()
            dt <- getDefTable
            when (hasFunDef dt) $ astError node_info "global register variable appears after a function definition"
            return (Static InternalLinkage False, False)
       -- tentative if there is no initializer, external
       globalStorage NoStorageSpec = return (Static ExternalLinkage False, True)
       globalStorage ThreadSpec    = return (Static ExternalLinkage True, True)
       -- tentative if there is no initializer, internal
       globalStorage (StaticSpec thread_local) = return (Static InternalLinkage thread_local, True)
       globalStorage (ExternSpec thread_local) =
           case init_opt of
               -- declaration with either external or old storage
               Nothing -> do old_decl <- lookupObject ident
                             return (maybe (Static ExternalLinkage thread_local) declStorage old_decl,False)
               -- warning, external definition
               Just _  -> do warn $ badSpecifierError node_info "Both initializer and `extern` specifier given - treating as definition"
                             return (Static ExternalLinkage thread_local, True)
       hasFunDef dt = any (isFuncDef . snd) (Map.toList $ gObjs $ globalDefs dt)
       isFuncDef (FunctionDef fd) = not $ (isInline . functionAttrs) fd
       isFuncDef _ = False

-- | handle a function-scope object declaration \/ definition
-- see [http://www.sivity.net/projects/language.c/wiki/LocalDefinitions]
localVarDecl :: (MonadTrav m) => VarDeclInfo -> Maybe Initializer -> m ()
localVarDecl (VarDeclInfo var_name fun_attrs storage_spec attrs typ node_info) init_opt =
    do when (isNoName var_name) $ astError node_info "NoName in localVarDecl"
       (storage,is_def) <- localStorage storage_spec
       let vardecl = VarDecl var_name (DeclAttrs fun_attrs storage attrs) typ
       if is_def
           then handleObjectDef True ident (ObjDef vardecl init_opt node_info)
           else handleVarDecl True (Decl vardecl node_info)
    where
    ident = identOfVarName var_name
    localStorage NoStorageSpec = return (Auto False,True)
    localStorage ThreadSpec    = return (Auto True,True)
    localStorage RegSpec = return (Auto True,True)
    -- static no linkage
    localStorage (StaticSpec thread_local) =
      return (Static NoLinkage thread_local,True)
    localStorage (ExternSpec thread_local)
      | isJust init_opt = astError node_info "extern keyword and initializer for local"
      | otherwise =
          do old_decl <- lookupObject ident
             return (maybe (Static ExternalLinkage thread_local) declStorage old_decl,False)
    localStorage _ = astError node_info "bad storage specifier for local"

defineParams :: MonadTrav m => NodeInfo -> VarDecl -> m ()
defineParams ni decl =
  case getParams (declType decl) of
    Nothing -> astError ni
               "expecting complete function type in function definition"
    Just params -> mapM_ handleParamDecl params

analyseFunctionBody :: (MonadTrav m) => NodeInfo -> VarDecl -> CStat -> m Stmt
analyseFunctionBody node_info decl s@(CCompound localLabels items _) =
  do enterFunctionScope
     mapM_ (withDefTable . defineLabel) (localLabels ++ getLabels s)
     defineParams node_info decl
     -- record parameters
     mapM_ (tBlockItem [FunCtx decl]) items
     leaveFunctionScope
     return s -- XXX: bogus

analyseFunctionBody _ _ s = astError (nodeInfo s) "Function body is no compound statement"

data StmtCtx = FunCtx VarDecl
             | LoopCtx
             | SwitchCtx

-- | Given a context, determine the type declaration for the enclosing
--   function, if possible, given a context.
enclosingFunctionType :: [StmtCtx] -> Maybe Type
enclosingFunctionType [] = Nothing
enclosingFunctionType (FunCtx vd : _) = Just $ declType vd
enclosingFunctionType (_ : cs) = enclosingFunctionType cs

inLoop :: [StmtCtx] -> Bool
inLoop c = any isLoop c
  where isLoop LoopCtx = True
        isLoop _ = False

inSwitch :: [StmtCtx] -> Bool
inSwitch c = any isSwitch c
  where isSwitch SwitchCtx = True
        isSwitch _ = False

data ExprSide = LValue | RValue
                deriving (Eq, Show)

-- | Typecheck a statement, given a statement context. The type of a
--   statement is usually @void@, but expression statements and blocks
--   can sometimes have other types.
tStmt :: MonadTrav m => [StmtCtx] -> CStat -> m Type
tStmt c (CLabel _ s _ _)         = tStmt c s
tStmt c (CExpr e _)              =
  maybe (return voidType) (tExpr c RValue) e
tStmt c (CCompound ls body _)    =
  do enterBlockScope
     mapM_ (withDefTable . defineLabel) ls
     t <- foldM (const $ tBlockItem c) voidType body
     leaveBlockScope
     return t
tStmt c (CIf e sthen selse _)    =
  checkGuard c e >> tStmt c sthen
                 >> maybe (return ()) (voidM . tStmt c) selse
                 >> return voidType
tStmt c (CSwitch e s ni)         =
  tExpr c RValue e >>= checkIntegral' ni >>
  tStmt (SwitchCtx : c) s
tStmt c (CWhile e s _ _)         =
  checkGuard c e >> tStmt (LoopCtx : c) s
tStmt _ (CGoto l ni)             =
  do dt <- getDefTable
     case lookupLabel l dt of
       Just _ -> return voidType
       Nothing -> typeError ni $ "undefined label in goto: " ++ identToString l
tStmt c (CCont ni)               =
  do unless (inLoop c) $ astError ni "continue statement outside of loop"
     return voidType
tStmt c (CBreak ni)              =
  do unless (inLoop c || inSwitch c) $
            astError ni "break statement outside of loop or switch statement"
     return voidType
tStmt c (CReturn (Just e) ni)    =
  do t <- tExpr c RValue e
     rt <- case enclosingFunctionType c of
             Just (FunctionType (FunType rt _ _) _) -> return rt
             Just (FunctionType (FunTypeIncomplete rt) _) -> return rt
             Just ft -> astError ni $ "bad function type: " ++ pType ft
             Nothing -> astError ni "return statement outside function"
     case (rt, t) of
       -- apparently it's ok to return void from a void function?
       (DirectType TyVoid _ _, DirectType TyVoid _ _) -> return ()
       _ -> assignCompatible' ni CAssignOp rt t
     return voidType
tStmt _ (CReturn Nothing _)      = return voidType
-- XXX: anything to do for assembly?
tStmt _ (CAsm _ _)               = return voidType
tStmt c (CCase e s ni)           =
  do unless (inSwitch c) $
            astError ni "case statement outside of switch statement"
     tExpr c RValue e >>= checkIntegral' ni
     tStmt c s
tStmt c (CCases e1 e2 s ni)      =
  do unless (inSwitch c) $
            astError ni "case statement outside of switch statement"
     tExpr c RValue e1 >>= checkIntegral' ni
     tExpr c RValue e2 >>= checkIntegral' ni
     tStmt c s
tStmt c (CDefault s ni)          =
  do unless (inSwitch c) $
            astError ni "default statement outside of switch statement"
     tStmt c s
tStmt c (CFor i g inc s _)       =
  do enterBlockScope
     either (maybe (return ()) checkExpr) (analyseDecl True) i
     maybe (return ()) (checkGuard c) g
     maybe (return ()) checkExpr inc
     _ <- tStmt (LoopCtx : c) s
     leaveBlockScope
     return voidType
  where checkExpr e = voidM$ tExpr c RValue e
tStmt c (CGotoPtr e ni)          =
  do t <- tExpr c RValue e
     case t of
       (PtrType _ _ _) -> return voidType
       _               -> typeError ni "can't goto non-pointer"

-- | Typecheck a block item. When statement expressions are blocks,
--   they have the type of their last expression statement, so this
--   needs to return a type.
tBlockItem :: MonadTrav m => [StmtCtx] -> CBlockItem -> m Type
tBlockItem c (CBlockStmt s) = tStmt c s
tBlockItem _ (CBlockDecl d) = analyseDecl True d >> return voidType
-- TODO: fixup analyseFunDef to handle nested functions
tBlockItem _ (CNestedFunDef fd) = analyseFunDef fd >> return voidType

checkGuard :: MonadTrav m => [StmtCtx] -> CExpr -> m ()
checkGuard c e = tExpr c RValue e >>= checkScalar' (nodeInfo e)

-- XXX: this is bogus, correct only for IA32. We should eventually
-- have a collection of these and allow people to choose one.
defaultMD :: MachineDesc
defaultMD =
  MachineDesc
  { iSize = \it ->
            case it of
              TyBool    -> 1
              TyChar    -> 1
              TySChar   -> 1
              TyUChar   -> 1
              TyShort   -> 2
              TyUShort  -> 2
              TyInt     -> 4
              TyUInt    -> 4
              TyLong    -> 4
              TyULong   -> 4
              TyLLong   -> 8
              TyULLong  -> 8
              TyInt128  -> 16
              TyUInt128 -> 16
  , fSize = \ft ->
            case ft of
              TyFloat   -> 4
              TyDouble  -> 8
              TyLDouble -> 16
  , builtinSize = \bt ->
                  case bt of
                    TyVaList -> 4
                    TyAny    -> 4
  , ptrSize = 4
  , voidSize = 1
  , iAlign = \it ->
             case it of
               TyBool    -> 1
               TyChar    -> 1
               TySChar   -> 1
               TyUChar   -> 1
               TyShort   -> 2
               TyUShort  -> 2
               TyInt     -> 4
               TyUInt    -> 4
               TyLong    -> 4
               TyULong   -> 4
               TyLLong   -> 8
               TyULLong  -> 8
               TyInt128  -> 16
               TyUInt128 -> 16
  , fAlign = \ft ->
             case ft of
               TyFloat   -> 4
               TyDouble  -> 8
               TyLDouble -> 16
  , builtinAlign = \bt ->
                   case bt of
                     TyVaList -> 4
                     TyAny    -> 4
  , ptrAlign = 4
  , voidAlign = 1
  }

tExpr :: MonadTrav m => [StmtCtx] -> ExprSide -> CExpr -> m Type
tExpr c side e =
  case nameOfNode (nodeInfo e) of
    Just n ->
      do dt <- getDefTable
         case lookupType dt n of
           Just t -> return t
           Nothing ->
             do t <- tExpr' c side e
                withDefTable (\dt' -> (t, insertType dt' n t))
    Nothing -> tExpr' c side e

-- | Typecheck an expression, with information about whether it
--   appears as an lvalue or an rvalue.
tExpr' :: MonadTrav m => [StmtCtx] -> ExprSide -> CExpr -> m Type
tExpr' c side (CBinary op le re ni)    =
  do when (side == LValue) $ typeError ni "binary operator as lvalue"
     lt <- tExpr c RValue le
     rt <- tExpr c RValue re
     binopType' ni op lt rt
tExpr' c side (CUnary CAdrOp e ni)     =
  do when (side == LValue) $
          typeError ni "address-of operator as lvalue"
     case e of
       CCompoundLit _ _ _ -> simplePtr `liftM` tExpr c RValue e
       CVar i _ -> lookupObject i >>=
                   typeErrorOnLeft ni . maybe (notFound i) varAddrType
       _        -> simplePtr `liftM` tExpr c LValue e
tExpr' c _ (CUnary CIndOp e ni)     =
  tExpr c RValue e >>= (typeErrorOnLeft ni . derefType)
tExpr' c _ (CUnary CCompOp e ni)    =
  do t <- tExpr c RValue e
     checkIntegral' ni t
     return t
tExpr' c side (CUnary CNegOp e ni)      =
  do when (side == LValue) $
          typeError ni "logical negation used as lvalue"
     tExpr c RValue e >>= checkScalar' ni
     return boolType
tExpr' c side (CUnary op e _)          =
  tExpr c (if isEffectfulOp op then LValue else side) e
tExpr' c _ (CIndex b i ni)             =
  do bt <- tExpr c RValue b
     it <- tExpr c RValue i
     addrTy <- binopType' ni CAddOp bt it
     typeErrorOnLeft ni $ derefType addrTy
tExpr' c side (CCond e1 me2 e3 ni)     =
  do t1 <- tExpr c RValue e1
     checkScalar' (nodeInfo e1) t1
     t3 <- tExpr c side e3
     case me2 of
       Just e2 ->
         do t2 <- tExpr c side e2
            conditionalType' ni t2 t3
       Nothing -> conditionalType' ni t1 t3
tExpr' c _ (CMember e m deref ni)   =
  do t <- tExpr c RValue e
     bt <- if deref then typeErrorOnLeft ni (derefType t) else return t
     fieldType ni m bt
tExpr' c side (CComma es _)            =
  mapM (tExpr c side) es >>= return . last
tExpr' c side (CCast d e ni)           =
  do dt <- analyseTypeDecl d
     et <- tExpr c side e
     typeErrorOnLeft ni $ castCompatible dt et
     return dt
tExpr' c side (CSizeofExpr e ni)       =
  do when (side == LValue) $ typeError ni "sizeof as lvalue"
     _ <- tExpr c RValue e
     return size_tType
tExpr' c side (CAlignofExpr e ni)      =
  do when (side == LValue) $ typeError ni "alignof as lvalue"
     _ <- tExpr c RValue e
     return size_tType
tExpr' c side (CComplexReal e ni)      = complexBaseType ni c side e
tExpr' c side (CComplexImag e ni)      = complexBaseType ni c side e
tExpr' _ side (CLabAddrExpr _ ni)      =
  do when (side == LValue) $ typeError ni "label address as lvalue"
     return $ PtrType voidType noTypeQuals []
tExpr' _ side (CCompoundLit d initList ni) =
  do when (side == LValue) $ typeError ni "compound literal as lvalue"
     lt <- analyseTypeDecl d
     tInitList ni (canonicalType lt) initList
     return lt
tExpr' _ RValue (CAlignofType _ _)     = return size_tType
tExpr' _ RValue (CSizeofType _ _)      = return size_tType
tExpr' _ LValue (CAlignofType _ ni)    =
  typeError ni "alignoftype as lvalue"
tExpr' _ LValue (CSizeofType _ ni)     =
  typeError ni "sizeoftype as lvalue"
tExpr' ctx side (CGenericSelection expr list ni) = do
  ty_sel <- tExpr ctx side expr
  ty_list <- mapM analyseAssoc list
  def_expr_ty <-
    case dropWhile (isJust . fst) ty_list of
      [(Nothing,tExpr'')] -> return (Just tExpr'')
      [] -> return Nothing
      _ -> astError ni "more than one default clause in generic selection"
  case dropWhile (maybe True (not . typesMatch ty_sel) . fst) ty_list of
    ((_,expr_ty) : _ ) -> return expr_ty
    [] -> case def_expr_ty of
      (Just expr_ty) -> return expr_ty
      Nothing -> astError ni ("no clause matches for generic selection (not fully supported) - selector type is " ++ show (pretty ty_sel) ++
                              ", available types are " ++ show (map (pretty.fromJust.fst) (filter (isJust.fst) ty_list)))
  where
    analyseAssoc (mdecl,expr') = do
      tDecl <- mapM analyseTypeDecl mdecl
      tExpr'' <- tExpr ctx side expr'
      return (tDecl, tExpr'')
    typesMatch (DirectType tn1 _ _) (DirectType tn2 _ _) = directTypesMatch tn1 tn2
    typesMatch _ _ = False -- not fully supported
    directTypesMatch TyVoid TyVoid = True
    directTypesMatch (TyIntegral t1) (TyIntegral t2) = t1 == t2
    directTypesMatch (TyFloating t1) (TyFloating t2) = t1 == t2
    directTypesMatch (TyComplex t1) (TyComplex t2) = t1 == t2
    directTypesMatch _ _ = False -- TODO: not fully supported
tExpr' _ _ (CVar i ni)              =
  lookupObject i >>=
  maybe (typeErrorOnLeft ni $ notFound i) (return . declType)
tExpr' _ _ (CConst c)                  = constType c
tExpr' _ _ (CBuiltinExpr b)            = builtinType b
tExpr' c side (CCall (CVar i _) args ni)
  | identToString i == "__builtin_choose_expr" =
    case args of
      [g, e1, e2] ->
        -- XXX: the MachineDesc parameter below should be configurable
        do b <- constEval defaultMD Map.empty g
           case boolValue b of
             Just True -> tExpr c side e1
             Just False -> tExpr c side e2
             Nothing ->
               astError ni "non-constant argument to __builtin_choose_expr"
      _ -> astError ni "wrong number of arguments to __builtin_choose_expr"
tExpr' c _ (CCall fe args ni)          =
  do let defType = FunctionType
                   (FunTypeIncomplete
                    (DirectType (TyIntegral TyInt) noTypeQuals noAttributes))
                   noAttributes
         fallback i = do warn $ invalidAST ni $
                                "unknown function: " ++ identToString i
                         return defType
     t <- case fe of
            CVar i _ -> lookupObject i >>=
                        maybe (fallback i) (const $ tExpr c RValue fe)
            _ -> tExpr c RValue fe
     atys <- mapM (tExpr c RValue) args
     -- XXX: we don't actually want to return the canonical return type here
     case canonicalType t of
       PtrType (FunctionType (FunType rt pdecls varargs) _) _ _ ->
         do let ptys = map declType pdecls
            mapM_ checkArg $ zip3 ptys atys args
            unless varargs $ when (length atys /= length ptys) $
                   typeError ni "incorrect number of arguments"
            return $ canonicalType rt
       PtrType (FunctionType (FunTypeIncomplete rt) _) _ _ ->
         do -- warn $ invalidAST ni "incomplete function type"
            return $ canonicalType rt
       _  -> typeError ni $ "attempt to call non-function of type " ++ pType t
  where checkArg (pty, aty, arg) =
          do attrs <- deepTypeAttrs pty
             if isTransparentUnion attrs
               then
                 case canonicalType pty of
                   DirectType (TyComp ctr) _ _ ->
                     do td <- lookupSUE (nodeInfo arg) (sueRef ctr)
                        _ms <- tagMembers (nodeInfo arg) td
                        {-
                        when (null $ rights $ matches ms) $
                             astError (nodeInfo arg) $
                             "argument matches none of the elements " ++
                             "of transparent union"
                        -}
                        return ()
                     -- where matches =
                     --         map (\d -> assignCompatible
                     --                    CAssignOp
                     --                    (snd d)
                     --                    aty
                     --             )
                   _ -> astError (nodeInfo arg)
                        "non-composite has __transparent_union__ attribute"
               else
                 assignCompatible' (nodeInfo arg) CAssignOp pty aty
        isTransparentUnion =
          any (\(Attr n _ _) -> identToString n == "__transparent_union__")
tExpr' c _ (CAssign op le re ni)       =
  do lt <- tExpr c LValue le
     rt <- tExpr c RValue re
     when (constant $ typeQuals lt) $
          typeError ni $ "assignment to lvalue with `constant' qualifier: "
                         ++ (render . pretty) le
     case (canonicalType lt, re) of
       (lt', CConst (CIntConst i _))
         | isPointerType lt' && getCInteger i == 0 -> return ()
       (_, _) -> assignCompatible' ni op lt rt
     return lt
tExpr' c _ (CStatExpr s _)             =
  do enterBlockScope
     mapM_ (withDefTable . defineLabel) (getLabels s)
     t <- tStmt c s
     leaveBlockScope
     return t

tInitList :: MonadTrav m => NodeInfo -> Type -> CInitList -> m ()
tInitList _ (ArrayType (DirectType (TyIntegral TyChar) _ _) _ _ _)
              [([], CInitExpr e@(CConst (CStrConst _ _)) _)] =
  tExpr [] RValue e >> return ()
tInitList ni t@(ArrayType _ _ _ _) initList =
  do let default_ds =
           repeat (CArrDesig (CConst (CIntConst (cInteger 0) ni)) ni)
     checkInits t default_ds initList
tInitList ni t@(DirectType (TyComp ctr) _ _) initList =
  do td <- lookupSUE ni (sueRef ctr)
     ms <- tagMembers ni td
     let default_ds = map (\m -> CMemberDesig (fst m) ni) ms
     checkInits t default_ds initList
tInitList _ (PtrType (DirectType TyVoid _ _) _ _ ) _ =
          return () -- XXX: more checking
tInitList _ t [([], i)] = voidM$ tInit t i
tInitList ni t _ = typeError ni $ "initializer list for type: " ++ pType t

checkInits :: MonadTrav m => Type -> [CDesignator] -> CInitList -> m ()
checkInits _ _ [] = return ()
checkInits t dds ((ds, i) : is) =
  do (dds', ds') <- case (dds, ds) of
                      ([], []) ->
                        typeError (nodeInfo i) "excess elements in initializer"
                      (dd' : rest, []) -> return (rest, [dd'])
                      (_, d : _) -> return (advanceDesigList dds d, ds)
     t' <- tDesignator t ds'
     _ <- tInit t' i
     checkInits t dds' is

advanceDesigList :: [CDesignator] -> CDesignator -> [CDesignator]
advanceDesigList ds d = drop 1 $ dropWhile (not . matchDesignator d) ds

matchDesignator :: CDesignator -> CDesignator -> Bool
matchDesignator (CMemberDesig m1 _) (CMemberDesig m2 _) = m1 == m2
matchDesignator _ _ = True -- XXX: for now, array ranges aren't checked

tDesignator :: MonadTrav m => Type -> [CDesignator] -> m Type
-- XXX: check that initializers are within array size
tDesignator (ArrayType bt _ _ _) (CArrDesig e ni : ds) =
  do tExpr [] RValue e >>= checkIntegral' ni
     tDesignator bt ds
tDesignator (ArrayType bt _ _ _) (CRangeDesig e1 e2 ni : ds) =
  do tExpr [] RValue e1 >>= checkIntegral' ni
     tExpr [] RValue e2 >>= checkIntegral' ni
     tDesignator bt ds
tDesignator (ArrayType _ _ _ _) (d : _) =
  typeError (nodeInfo d) "member designator in array initializer"
tDesignator t@(DirectType (TyComp _) _ _) (CMemberDesig m ni : ds) =
  do mt <- fieldType ni m t
     tDesignator (canonicalType mt) ds
tDesignator (DirectType (TyComp _) _ _) (d : _) =
  typeError (nodeInfo d) "array designator in compound initializer"
tDesignator t [] = return t
tDesignator _t _ =
  error "unepxected type with designator"

tInit :: MonadTrav m => Type -> CInit -> m Initializer
tInit t i@(CInitExpr e ni) =
  do it <- tExpr [] RValue e
     assignCompatible' ni CAssignOp t it
     return i
tInit t i@(CInitList initList ni) =
  tInitList ni (canonicalType t) initList >> return i

complexBaseType :: MonadTrav m => NodeInfo -> [StmtCtx] -> ExprSide -> CExpr -> m Type
complexBaseType ni c side e =
  do t <- tExpr c side e
     case canonicalType t of
       DirectType (TyComplex ft) quals attrs ->
         return $ DirectType (TyFloating ft) quals attrs
       _ -> typeError ni $ "expected complex type, got: " ++ pType t


-- | Return the type of a builtin.
builtinType :: MonadTrav m => CBuiltin -> m Type
builtinType (CBuiltinVaArg _ d _)           = analyseTypeDecl d
builtinType (CBuiltinOffsetOf _ _ _)        = return size_tType
builtinType (CBuiltinTypesCompatible _ _ _) = return boolType
builtinType (CBuiltinConvertVector _expr ty _) = analyseTypeDecl ty
builtinType (CBuiltinBitCast ty _expr _)    = analyseTypeDecl ty

-- 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 _)) (_,specs) = (True, specs)
    hasTypeDefSpec spec (b,specs) = (b,spec:specs)
