{-# LANGUAGE ScopedTypeVariables, PatternGuards #-}
-----------------------------------------------------------------------------
-- |
-- Module      :  Language.CFamily.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.CFamily.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.CFamily.Constants

import Language.CFamily.C.Analysis.SemError
import Language.CFamily.C.Analysis.SemRep
import Language.CFamily.C.Analysis.ConstEval
import Language.CFamily.C.Analysis.DeclAnalysis
import Language.CFamily.C.Analysis.TypeUtils
import Language.CFamily.C.Analysis.TypeCheck

import Language.CFamily.C.DefTable
import Language.CFamily.C.Pretty
import Language.CFamily.C.Syntax.AST
import Language.CFamily.C.Syntax.Ops
import Language.CFamily.C.Syntax.Utils
import Language.CFamily.C.TravMonad

import Language.CFamily.Data.Ident
import Language.CFamily.Data.Node

import Text.PrettyPrint.HughesPJ
import Control.Monad
import Prelude hiding (reverse)
import qualified Data.Map as Map
import Data.Maybe

-- * 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 -> when (not (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 is_inline storage_spec attrs ty _) = 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 is_inline 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

-- | Analyse a declaration other than a function definition
analyseDecl :: (MonadTrav m) => Bool -> CDecl -> m ()
analyseDecl is_local 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   = do let (storage_specs, attrs, typequals, typespecs, inline) =
                             partitionDeclSpecs declspecs
                       canonTySpecs <- canonicalTypeSpec typespecs
                       let specs =
                             (storage_specs, attrs, typequals, canonTySpecs, inline)
                       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
        _ <- mapMaybeM init_opt (tInit typ)
        return ()
    analyseVarDeclr _ _ (Nothing,_,_     ) = astError node "abstract declarator in object declaration"
    analyseVarDeclr _ _ (_      ,_,Just _) = 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 is_inline storage_spec attrs ty _) <- analyseVarDecl' handle_sue_def declspecs declr [] Nothing
    checkValidTypeDef is_inline 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 True _ _ = 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
    (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 is_inline 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 is_inline (funDeclLinkage old_fun) attrs) ty
        handleVarDecl False (Decl decl node_info)
        -- XXX: structs should be handled in 'function prototype scope' too
        enterProtoScope
        maybe (return ()) (mapM_ handleParamDecl) (getParams ty)
        leaveProtoScope
    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 is_inline 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 is_inline 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 _ | is_inline = astError node_info "invalid `inline' specifier external variable"
       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)
       -- 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)
       globalStorage _ = error "AstAnalysis.hs:extVarDecl unhandled pattern in globalStorage"
       hasFunDef dt = any (isFuncDef . snd) (Map.toList $ gObjs $ globalDefs dt)
       isFuncDef (FunctionDef fd) = not $ isInline $ declAttrs fd
       isFuncDef _ = False
       isInline (DeclAttrs inl _ _) = inl

-- | 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 is_inline 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 is_inline 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 _
      | is_inline = astError node_info "invalid `inline' specifier for local variable"
    localStorage NoStorageSpec = return $ (Auto False,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@(VarDecl (VarName namei _) _ _) s@(CCompound localLabels items _) =
  do enterFuncScope
     mapM_ (withDefTable . defineLabel) (localLabels ++ getLabels s)
     defineParams node_info decl
     -- record parameters
     --mapM_ (tBlockItem [FunCtx decl]) items
     mapM_ (ctCBlockItem namei) items
     leaveFuncScope
     return s -- XXX: bogus

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

ctCBlockItem
   :: (MonadTrav m)
   => Ident
   -> CBlockItem
   -> m ()
ctCBlockItem fn (CBlockStmt s) = ctCStat fn s
ctCBlockItem fn (CBlockDecl d) = ctCDecl fn d
ctCBlockItem _  _              = error "AstAnalysis.ctCBlockItem unhandled case"

ctCStat
   :: (MonadTrav m)
   => Ident
   -> CStat
   -> m ()
ctCStat fn (CLabel    _           s1  _      _) = ctCStat fn s1
ctCStat fn (CCase     e1          s1         _) = ctCExpr fn e1 >> ctCStat fn s1
ctCStat fn (CCases    e1          e2  s1     _) = ctCExpr fn e1 >> ctCExpr fn e2 >> ctCStat fn s1
ctCStat fn (CDefault  s1                     _) = ctCStat fn s1
ctCStat fn (CExpr     me1                    _) = ume fn me1
ctCStat fn (CCompound _           bis        _) = mapM_ (ctCBlockItem fn) bis
ctCStat fn (CIf       e1          s1  ms2    _) = ctCExpr fn e1 >> ctCStat fn s1 >> ums fn ms2
ctCStat fn (CSwitch   e1          s1         _) = ctCExpr fn e1 >> ctCStat fn s1
ctCStat fn (CWhile    e1          s1  _      _) = ctCExpr fn e1 >> ctCStat fn s1
ctCStat fn (CFor      (Left me1) me2 me3 s1  _) = ume fn me1    >> ume fn me2 >> ume fn me3 >> ctCStat fn s1
ctCStat fn (CFor      (Right d1) me2 me3 s1  _) = ctCDecl fn d1 >> ume fn me2 >> ume fn me3 >> ctCStat fn s1
ctCStat _  (CGoto     _                      _) = return ()
ctCStat fn (CGotoPtr  e1                     _) = ctCExpr fn e1
ctCStat _  (CCont                            _) = return ()
ctCStat _  (CBreak                           _) = return ()
ctCStat fn (CReturn   me1                    _) = ume fn me1
ctCStat _  (CAsm      _                      _) = return ()

ctCExpr
   :: (MonadTrav m)
   => Ident
   -> CExpr
   -> m ()
ctCExpr fn (CComma    es1 _) = mapM_ (ctCExpr fn) es1
ctCExpr fn (CAssign _ e1 e2 _) = ctCExpr fn e1 >> ctCExpr fn e2
ctCExpr fn (CCond     e1 me2 e3 _) = ctCExpr fn e1 >> ume fn me2 >> ctCExpr fn e3
ctCExpr fn (CBinary _ e1 e2     _) = ctCExpr fn e1 >> ctCExpr fn e2
ctCExpr fn (CCast   _ e1        _) = ctCExpr fn e1
ctCExpr fn (CUnary  _ e1        _) = ctCExpr fn e1
ctCExpr fn (CSizeofExpr  e1 _) = ctCExpr fn e1
ctCExpr _  (CSizeofType  _  _) = return ()
ctCExpr fn (CAlignofExpr e1 _) = ctCExpr fn e1
ctCExpr _  (CAlignofType _  _) = return ()
ctCExpr fn (CComplexReal e1 _) = ctCExpr fn e1
ctCExpr fn (CComplexImag e1 _) = ctCExpr fn e1
ctCExpr fn (CIndex       e1 e2 _) = ctCExpr fn e1 >> ctCExpr fn e2
ctCExpr fn (CCall        (CVar i _) es2 ni) = mapM_ (ctCExpr fn) es2 >> handleCall fn (Left  i ) ni
ctCExpr fn (CCall        e1         es2 ni) = mapM_ (ctCExpr fn) es2 >> handleCall fn (Right e1) ni
ctCExpr fn (CMember      e1 _ _ _) = ctCExpr fn e1
ctCExpr _  (CVar         _  _) = return ()
ctCExpr _  (CConst       _   ) = return ()
ctCExpr _  (CCompoundLit _ _ _) = return ()
ctCExpr fn (CStatExpr    s1 _) = ctCStat fn s1
ctCExpr _  (CLabAddrExpr _  _) = return ()
ctCExpr _  (CBuiltinExpr _) = return ()

ctCDecl
   :: (MonadTrav m)
   => Ident
   -> CDecl
   -> m ()
ctCDecl fn (CDecl _ diss _) = mapM_ unDiss diss
   where
      unDiss (_, Just (CInitExpr e1 _), _) = ctCExpr fn e1
      unDiss _                             = return ()

ume
   :: (MonadTrav m)
   => Ident
   -> Maybe CExpr
   -> m ()
ume fn (Just e) = ctCExpr fn e
ume _  Nothing  = return ()

ums
   :: (MonadTrav m)
   => Ident
   -> Maybe CStat
   -> m ()
ums fn (Just s) = ctCStat fn s
ums _  Nothing  = return ()


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 enterBlkScope
     mapM_ (withDefTable . defineLabel) ls
     t <- foldM (const $ tBlockItem c) voidType body
     leaveBlkScope
     return t
tStmt c (CIf e sthen selse _)    =
  checkGuard c e >> tStmt c sthen
                 >> maybe (return ()) (\s -> tStmt c s >> return ()) 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 enterBlkScope
     either (maybe (return ()) checkExpr) (analyseDecl True) i
     maybe (return ()) (checkGuard c) g
     maybe (return ()) checkExpr inc
     _ <- tStmt (LoopCtx : c) s
     leaveBlkScope
     return voidType
  where checkExpr e = tExpr c RValue e >> return ()
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
  , 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
  , 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' _ _ (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
             case isTransparentUnion attrs of
               True ->
                 case canonicalType pty of
                   DirectType (TyComp ctr) _ _ ->
                     do td <- lookupSUE (nodeInfo arg) (sueRef ctr)
                        _ <- 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"
               False -> 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 enterBlkScope
     mapM_ (withDefTable . defineLabel) (getLabels s)
     t <- tStmt c s
     leaveBlkScope
     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)] = tInit t i >> return ()
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 _ _ = error "AstAnalysis.hs:tDesignator unhandled pattern"

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

-- 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)
