{-# 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 :: forall (m :: * -> *). MonadTrav m => CTranslUnit -> m GlobalDecls
analyseAST (CTranslUnit [CExternalDeclaration NodeInfo]
decls NodeInfo
_file_node) = do
    -- analyse all declarations, but recover from errors
    (CExternalDeclaration NodeInfo -> m ())
-> [CExternalDeclaration NodeInfo] -> m ()
forall {t :: * -> *} {m :: * -> *} {a} {a}.
(Foldable t, MonadCError m) =>
(a -> m a) -> t a -> m ()
mapRecoverM_ CExternalDeclaration NodeInfo -> m ()
forall (m :: * -> *).
MonadTrav m =>
CExternalDeclaration NodeInfo -> m ()
analyseExt [CExternalDeclaration NodeInfo]
decls
    -- check we are in global scope afterwards
    m DefTable
forall (m :: * -> *). MonadSymtab m => m DefTable
getDefTable m DefTable -> (DefTable -> m ()) -> m ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \DefTable
dt -> Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (DefTable -> Bool
inFileScope DefTable
dt) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
        [Char] -> m ()
forall a. HasCallStack => [Char] -> a
error [Char]
"Internal Error: Not in filescope after analysis"
    -- get the global definition table (XXX: remove ?)
    (DefTable -> GlobalDecls) -> m DefTable -> m GlobalDecls
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM DefTable -> GlobalDecls
globalDefs m DefTable
forall (m :: * -> *). MonadSymtab m => m DefTable
getDefTable
    where
    mapRecoverM_ :: (a -> m a) -> t a -> m ()
mapRecoverM_ a -> m a
f = (a -> m (Maybe a)) -> t a -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (m a -> m (Maybe a)
forall (m :: * -> *) a. MonadCError m => m a -> m (Maybe a)
handleTravError (m a -> m (Maybe a)) -> (a -> m a) -> a -> m (Maybe a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> m a
f)

-- | Analyse an top-level declaration
analyseExt :: (MonadTrav m) => CExtDecl -> m ()
analyseExt :: forall (m :: * -> *).
MonadTrav m =>
CExternalDeclaration NodeInfo -> m ()
analyseExt (CAsmExt CStringLiteral NodeInfo
asm NodeInfo
_)
    = CStringLiteral NodeInfo -> m ()
forall (m :: * -> *).
MonadTrav m =>
CStringLiteral NodeInfo -> m ()
handleAsmBlock CStringLiteral NodeInfo
asm
analyseExt (CFDefExt CFunctionDef NodeInfo
fundef)
    = CFunctionDef NodeInfo -> m ()
forall (m :: * -> *). MonadTrav m => CFunctionDef NodeInfo -> m ()
analyseFunDef CFunctionDef NodeInfo
fundef
analyseExt (CDeclExt CDeclaration NodeInfo
decl)
    = Bool -> CDeclaration NodeInfo -> m ()
forall (m :: * -> *).
MonadTrav m =>
Bool -> CDeclaration NodeInfo -> m ()
analyseDecl Bool
False CDeclaration NodeInfo
decl

-- | Analyse a function definition
analyseFunDef :: (MonadTrav m) => CFunDef -> m ()
analyseFunDef :: forall (m :: * -> *). MonadTrav m => CFunctionDef NodeInfo -> m ()
analyseFunDef (CFunDef [CDeclarationSpecifier NodeInfo]
declspecs CDeclarator NodeInfo
declr [CDeclaration NodeInfo]
oldstyle_decls CStatement NodeInfo
stmt NodeInfo
node_info) = do
    -- analyse the declarator
    VarDeclInfo
var_decl_info <- Bool
-> [CDeclarationSpecifier NodeInfo]
-> CDeclarator NodeInfo
-> [CDeclaration NodeInfo]
-> Maybe CInit
-> m VarDeclInfo
forall (m :: * -> *).
MonadTrav m =>
Bool
-> [CDeclarationSpecifier NodeInfo]
-> CDeclarator NodeInfo
-> [CDeclaration NodeInfo]
-> Maybe CInit
-> m VarDeclInfo
analyseVarDecl' Bool
True [CDeclarationSpecifier NodeInfo]
declspecs CDeclarator NodeInfo
declr [CDeclaration NodeInfo]
oldstyle_decls Maybe CInit
forall a. Maybe a
Nothing
    let (VarDeclInfo VarName
name FunctionAttrs
fun_spec StorageSpec
storage_spec Attributes
attrs Type
ty NodeInfo
_declr_node) = VarDeclInfo
var_decl_info
    Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (VarName -> Bool
isNoName VarName
name) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ NodeInfo -> [Char] -> m ()
forall (m :: * -> *) a. MonadCError m => NodeInfo -> [Char] -> m a
astError NodeInfo
node_info [Char]
"NoName in analyseFunDef"
    let ident :: Ident
ident = VarName -> Ident
identOfVarName VarName
name
    -- improve incomplete type
    Type
ty' <- Type -> m Type
forall {m :: * -> *}. Monad m => Type -> m Type
improveFunDefType Type
ty
    -- compute storage
    Storage
fun_storage <- Ident -> StorageSpec -> m Storage
forall (m :: * -> *).
MonadTrav m =>
Ident -> StorageSpec -> m Storage
computeFunDefStorage Ident
ident StorageSpec
storage_spec
    let var_decl :: VarDecl
var_decl = VarName -> DeclAttrs -> Type -> VarDecl
VarDecl VarName
name (FunctionAttrs -> Storage -> Attributes -> DeclAttrs
DeclAttrs FunctionAttrs
fun_spec Storage
fun_storage Attributes
attrs) Type
ty'
    -- callback for declaration
    Bool -> Decl -> m ()
forall (m :: * -> *). MonadTrav m => Bool -> Decl -> m ()
handleVarDecl Bool
False (VarDecl -> NodeInfo -> Decl
Decl VarDecl
var_decl NodeInfo
node_info)
    -- process body
    CStatement NodeInfo
stmt' <- NodeInfo
-> VarDecl -> CStatement NodeInfo -> m (CStatement NodeInfo)
forall (m :: * -> *).
MonadTrav m =>
NodeInfo
-> VarDecl -> CStatement NodeInfo -> m (CStatement NodeInfo)
analyseFunctionBody NodeInfo
node_info VarDecl
var_decl CStatement NodeInfo
stmt
    -- callback for definition
    Ident -> FunDef -> m ()
forall (m :: * -> *). MonadTrav m => Ident -> FunDef -> m ()
handleFunDef Ident
ident (VarDecl -> CStatement NodeInfo -> NodeInfo -> FunDef
FunDef VarDecl
var_decl CStatement NodeInfo
stmt' NodeInfo
node_info)
    where
    improveFunDefType :: Type -> m Type
improveFunDefType (FunctionType (FunTypeIncomplete Type
return_ty) Attributes
attrs) =
      Type -> m Type
forall (m :: * -> *) a. Monad m => a -> m a
return (Type -> m Type) -> Type -> m Type
forall a b. (a -> b) -> a -> b
$ FunType -> Attributes -> Type
FunctionType (Type -> [ParamDecl] -> Bool -> FunType
FunType Type
return_ty [] Bool
False) Attributes
attrs
    improveFunDefType Type
ty = Type -> m Type
forall (m :: * -> *) a. Monad m => a -> m a
return Type
ty

voidM :: Monad m => m a -> m ()
voidM :: forall (m :: * -> *) a. Monad m => m a -> m ()
voidM m a
m = m a
m m a -> m () -> m ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

-- | Analyse a declaration other than a function definition
--
--   Note: static assertions are not analysed
analyseDecl :: (MonadTrav m) => Bool -> CDecl -> m ()
analyseDecl :: forall (m :: * -> *).
MonadTrav m =>
Bool -> CDeclaration NodeInfo -> m ()
analyseDecl Bool
_is_local (CStaticAssert CExpression NodeInfo
_expr CStringLiteral NodeInfo
_strlit NodeInfo
_annot) = () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return () -- TODO
analyseDecl Bool
is_local decl :: CDeclaration NodeInfo
decl@(CDecl [CDeclarationSpecifier NodeInfo]
declspecs [(Maybe (CDeclarator NodeInfo), Maybe CInit,
  Maybe (CExpression NodeInfo))]
declrs NodeInfo
node)
    | [(Maybe (CDeclarator NodeInfo), Maybe CInit,
  Maybe (CExpression NodeInfo))]
-> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(Maybe (CDeclarator NodeInfo), Maybe CInit,
  Maybe (CExpression NodeInfo))]
declrs =
        case Maybe [CDeclarationSpecifier NodeInfo]
typedef_spec of Just [CDeclarationSpecifier NodeInfo]
_  -> NodeInfo -> [Char] -> m ()
forall (m :: * -> *) a. MonadCError m => NodeInfo -> [Char] -> m a
astError NodeInfo
node [Char]
"bad typedef declaration: missing declarator"
                             Maybe [CDeclarationSpecifier NodeInfo]
Nothing -> m Type -> m ()
forall (m :: * -> *) a. Monad m => m a -> m ()
voidM(m Type -> m ()) -> m Type -> m ()
forall a b. (a -> b) -> a -> b
$ CDeclaration NodeInfo -> m Type
forall (m :: * -> *).
MonadTrav m =>
CDeclaration NodeInfo -> m Type
analyseTypeDecl CDeclaration NodeInfo
decl
    | (Just [CDeclarationSpecifier NodeInfo]
declspecs') <- Maybe [CDeclarationSpecifier NodeInfo]
typedef_spec = ((Bool,
  (Maybe (CDeclarator NodeInfo), Maybe CInit,
   Maybe (CExpression NodeInfo)))
 -> m ())
-> [(Bool,
     (Maybe (CDeclarator NodeInfo), Maybe CInit,
      Maybe (CExpression NodeInfo)))]
-> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ((Bool
 -> (Maybe (CDeclarator NodeInfo), Maybe CInit,
     Maybe (CExpression NodeInfo))
 -> m ())
-> (Bool,
    (Maybe (CDeclarator NodeInfo), Maybe CInit,
     Maybe (CExpression NodeInfo)))
-> m ()
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry ([CDeclarationSpecifier NodeInfo]
-> Bool
-> (Maybe (CDeclarator NodeInfo), Maybe CInit,
    Maybe (CExpression NodeInfo))
-> m ()
forall {m :: * -> *} {a} {a}.
MonadTrav m =>
[CDeclarationSpecifier NodeInfo]
-> Bool -> (Maybe (CDeclarator NodeInfo), Maybe a, Maybe a) -> m ()
analyseTyDef [CDeclarationSpecifier NodeInfo]
declspecs')) [(Bool,
  (Maybe (CDeclarator NodeInfo), Maybe CInit,
   Maybe (CExpression NodeInfo)))]
declr_list
    | Bool
otherwise   = do let ([CStorageSpecifier NodeInfo]
storage_specs, [CAttribute NodeInfo]
attrs, [CTypeQualifier NodeInfo]
typequals, [CTypeSpecifier NodeInfo]
typespecs, [CFunctionSpecifier NodeInfo]
funspecs, [CAlignmentSpecifier NodeInfo]
_alignspecs) =
                             [CDeclarationSpecifier NodeInfo]
-> ([CStorageSpecifier NodeInfo], [CAttribute NodeInfo],
    [CTypeQualifier NodeInfo], [CTypeSpecifier NodeInfo],
    [CFunctionSpecifier NodeInfo], [CAlignmentSpecifier NodeInfo])
forall a.
[CDeclarationSpecifier a]
-> ([CStorageSpecifier a], [CAttribute a], [CTypeQualifier a],
    [CTypeSpecifier a], [CFunctionSpecifier a],
    [CAlignmentSpecifier a])
partitionDeclSpecs [CDeclarationSpecifier NodeInfo]
declspecs
                       TypeSpecAnalysis
canonTySpecs <- [CTypeSpecifier NodeInfo] -> m TypeSpecAnalysis
forall (m :: * -> *).
MonadTrav m =>
[CTypeSpecifier NodeInfo] -> m TypeSpecAnalysis
canonicalTypeSpec [CTypeSpecifier NodeInfo]
typespecs
                       -- TODO: alignspecs not yet processed
                       let specs :: ([CStorageSpecifier NodeInfo], [CAttribute NodeInfo],
 [CTypeQualifier NodeInfo], TypeSpecAnalysis,
 [CFunctionSpecifier NodeInfo])
specs =
                             ([CStorageSpecifier NodeInfo]
storage_specs, [CAttribute NodeInfo]
attrs, [CTypeQualifier NodeInfo]
typequals, TypeSpecAnalysis
canonTySpecs, [CFunctionSpecifier NodeInfo]
funspecs)
                       ((Bool,
  (Maybe (CDeclarator NodeInfo), Maybe CInit,
   Maybe (CExpression NodeInfo)))
 -> m ())
-> [(Bool,
     (Maybe (CDeclarator NodeInfo), Maybe CInit,
      Maybe (CExpression NodeInfo)))]
-> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ((Bool
 -> (Maybe (CDeclarator NodeInfo), Maybe CInit,
     Maybe (CExpression NodeInfo))
 -> m ())
-> (Bool,
    (Maybe (CDeclarator NodeInfo), Maybe CInit,
     Maybe (CExpression NodeInfo)))
-> m ()
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (([CStorageSpecifier NodeInfo], [CAttribute NodeInfo],
 [CTypeQualifier NodeInfo], TypeSpecAnalysis,
 [CFunctionSpecifier NodeInfo])
-> Bool
-> (Maybe (CDeclarator NodeInfo), Maybe CInit,
    Maybe (CExpression NodeInfo))
-> m ()
forall {m :: * -> *} {a}.
MonadTrav m =>
([CStorageSpecifier NodeInfo], [CAttribute NodeInfo],
 [CTypeQualifier NodeInfo], TypeSpecAnalysis,
 [CFunctionSpecifier NodeInfo])
-> Bool
-> (Maybe (CDeclarator NodeInfo), Maybe CInit, Maybe a)
-> m ()
analyseVarDeclr ([CStorageSpecifier NodeInfo], [CAttribute NodeInfo],
 [CTypeQualifier NodeInfo], TypeSpecAnalysis,
 [CFunctionSpecifier NodeInfo])
specs)) [(Bool,
  (Maybe (CDeclarator NodeInfo), Maybe CInit,
   Maybe (CExpression NodeInfo)))]
declr_list
    where
    declr_list :: [(Bool,
  (Maybe (CDeclarator NodeInfo), Maybe CInit,
   Maybe (CExpression NodeInfo)))]
declr_list = [Bool]
-> [(Maybe (CDeclarator NodeInfo), Maybe CInit,
     Maybe (CExpression NodeInfo))]
-> [(Bool,
     (Maybe (CDeclarator NodeInfo), Maybe CInit,
      Maybe (CExpression NodeInfo)))]
forall a b. [a] -> [b] -> [(a, b)]
zip (Bool
True Bool -> [Bool] -> [Bool]
forall a. a -> [a] -> [a]
: Bool -> [Bool]
forall a. a -> [a]
repeat Bool
False) [(Maybe (CDeclarator NodeInfo), Maybe CInit,
  Maybe (CExpression NodeInfo))]
declrs
    typedef_spec :: Maybe [CDeclarationSpecifier NodeInfo]
typedef_spec = [CDeclarationSpecifier NodeInfo]
-> Maybe [CDeclarationSpecifier NodeInfo]
hasTypeDef [CDeclarationSpecifier NodeInfo]
declspecs

    analyseTyDef :: [CDeclarationSpecifier NodeInfo]
-> Bool -> (Maybe (CDeclarator NodeInfo), Maybe a, Maybe a) -> m ()
analyseTyDef [CDeclarationSpecifier NodeInfo]
declspecs' Bool
handle_sue_def (Maybe (CDeclarator NodeInfo), Maybe a, Maybe a)
declr =
        case (Maybe (CDeclarator NodeInfo), Maybe a, Maybe a)
declr of
            (Just CDeclarator NodeInfo
tydeclr, Maybe a
Nothing , Maybe a
Nothing) -> Bool
-> [CDeclarationSpecifier NodeInfo]
-> CDeclarator NodeInfo
-> NodeInfo
-> m ()
forall (m :: * -> *).
MonadTrav m =>
Bool
-> [CDeclarationSpecifier NodeInfo]
-> CDeclarator NodeInfo
-> NodeInfo
-> m ()
analyseTypeDef Bool
handle_sue_def [CDeclarationSpecifier NodeInfo]
declspecs' CDeclarator NodeInfo
tydeclr NodeInfo
node
            (Maybe (CDeclarator NodeInfo), Maybe a, Maybe a)
_ -> NodeInfo -> [Char] -> m ()
forall (m :: * -> *) a. MonadCError m => NodeInfo -> [Char] -> m a
astError NodeInfo
node [Char]
"bad typdef declaration: bitfieldsize or initializer present"

    analyseVarDeclr :: ([CStorageSpecifier NodeInfo], [CAttribute NodeInfo],
 [CTypeQualifier NodeInfo], TypeSpecAnalysis,
 [CFunctionSpecifier NodeInfo])
-> Bool
-> (Maybe (CDeclarator NodeInfo), Maybe CInit, Maybe a)
-> m ()
analyseVarDeclr ([CStorageSpecifier NodeInfo], [CAttribute NodeInfo],
 [CTypeQualifier NodeInfo], TypeSpecAnalysis,
 [CFunctionSpecifier NodeInfo])
specs Bool
handle_sue_def (Just CDeclarator NodeInfo
declr, Maybe CInit
init_opt, Maybe a
Nothing) = do
        -- analyse the declarator
        let ([CStorageSpecifier NodeInfo]
storage_specs, [CAttribute NodeInfo]
attrs, [CTypeQualifier NodeInfo]
typequals, TypeSpecAnalysis
canonTySpecs, [CFunctionSpecifier NodeInfo]
inline) = ([CStorageSpecifier NodeInfo], [CAttribute NodeInfo],
 [CTypeQualifier NodeInfo], TypeSpecAnalysis,
 [CFunctionSpecifier NodeInfo])
specs
        vardeclInfo :: VarDeclInfo
vardeclInfo@(VarDeclInfo VarName
_ FunctionAttrs
_ StorageSpec
_ Attributes
_ Type
typ NodeInfo
_) <-
          Bool
-> [CStorageSpecifier NodeInfo]
-> [CAttribute NodeInfo]
-> [CTypeQualifier NodeInfo]
-> TypeSpecAnalysis
-> [CFunctionSpecifier NodeInfo]
-> CDeclarator NodeInfo
-> [CDeclaration NodeInfo]
-> Maybe CInit
-> m VarDeclInfo
forall (m :: * -> *).
MonadTrav m =>
Bool
-> [CStorageSpecifier NodeInfo]
-> [CAttribute NodeInfo]
-> [CTypeQualifier NodeInfo]
-> TypeSpecAnalysis
-> [CFunctionSpecifier NodeInfo]
-> CDeclarator NodeInfo
-> [CDeclaration NodeInfo]
-> Maybe CInit
-> m VarDeclInfo
analyseVarDecl Bool
handle_sue_def [CStorageSpecifier NodeInfo]
storage_specs [CAttribute NodeInfo]
attrs [CTypeQualifier NodeInfo]
typequals TypeSpecAnalysis
canonTySpecs [CFunctionSpecifier NodeInfo]
inline
                         CDeclarator NodeInfo
declr [] Maybe CInit
forall a. Maybe a
Nothing
        -- declare / define the object
        if Type -> Bool
isFunctionType Type
typ
            then VarDeclInfo -> m ()
forall (m :: * -> *). MonadTrav m => VarDeclInfo -> m ()
extFunProto VarDeclInfo
vardeclInfo
            else (if Bool
is_local then VarDeclInfo -> Maybe CInit -> m ()
forall (m :: * -> *).
MonadTrav m =>
VarDeclInfo -> Maybe CInit -> m ()
localVarDecl else VarDeclInfo -> Maybe CInit -> m ()
forall (m :: * -> *).
MonadTrav m =>
VarDeclInfo -> Maybe CInit -> m ()
extVarDecl)
                 -- XXX: if Initializer becomes different from CInit, this
                 -- will have to change.
                 VarDeclInfo
vardeclInfo Maybe CInit
init_opt
        Maybe CInit
_init_opt' <- Maybe CInit -> (CInit -> m CInit) -> m (Maybe CInit)
forall (m :: * -> *) a b.
Monad m =>
Maybe a -> (a -> m b) -> m (Maybe b)
mapMaybeM Maybe CInit
init_opt (Type -> CInit -> m CInit
forall (m :: * -> *). MonadTrav m => Type -> CInit -> m CInit
tInit Type
typ)
        () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    analyseVarDeclr ([CStorageSpecifier NodeInfo], [CAttribute NodeInfo],
 [CTypeQualifier NodeInfo], TypeSpecAnalysis,
 [CFunctionSpecifier NodeInfo])
_ Bool
_ (Maybe (CDeclarator NodeInfo)
Nothing,Maybe CInit
_,Maybe a
_)         = NodeInfo -> [Char] -> m ()
forall (m :: * -> *) a. MonadCError m => NodeInfo -> [Char] -> m a
astError NodeInfo
node [Char]
"abstract declarator in object declaration"
    analyseVarDeclr ([CStorageSpecifier NodeInfo], [CAttribute NodeInfo],
 [CTypeQualifier NodeInfo], TypeSpecAnalysis,
 [CFunctionSpecifier NodeInfo])
_ Bool
_ (Maybe (CDeclarator NodeInfo)
_,Maybe CInit
_,Just a
_bitfieldSz) = NodeInfo -> [Char] -> m ()
forall (m :: * -> *) a. MonadCError m => NodeInfo -> [Char] -> m a
astError NodeInfo
node [Char]
"bitfield size in object declaration"

-- | Analyse a typedef
analyseTypeDef :: (MonadTrav m) => Bool -> [CDeclSpec] -> CDeclr -> NodeInfo -> m ()
analyseTypeDef :: forall (m :: * -> *).
MonadTrav m =>
Bool
-> [CDeclarationSpecifier NodeInfo]
-> CDeclarator NodeInfo
-> NodeInfo
-> m ()
analyseTypeDef Bool
handle_sue_def [CDeclarationSpecifier NodeInfo]
declspecs CDeclarator NodeInfo
declr NodeInfo
node_info = do
    -- analyse the declarator
    (VarDeclInfo VarName
name FunctionAttrs
fun_attrs StorageSpec
storage_spec Attributes
attrs Type
ty NodeInfo
_node) <- Bool
-> [CDeclarationSpecifier NodeInfo]
-> CDeclarator NodeInfo
-> [CDeclaration NodeInfo]
-> Maybe CInit
-> m VarDeclInfo
forall (m :: * -> *).
MonadTrav m =>
Bool
-> [CDeclarationSpecifier NodeInfo]
-> CDeclarator NodeInfo
-> [CDeclaration NodeInfo]
-> Maybe CInit
-> m VarDeclInfo
analyseVarDecl' Bool
handle_sue_def [CDeclarationSpecifier NodeInfo]
declspecs CDeclarator NodeInfo
declr [] Maybe CInit
forall a. Maybe a
Nothing
    FunctionAttrs -> StorageSpec -> Attributes -> m ()
forall {m :: * -> *} {p}.
MonadCError m =>
FunctionAttrs -> StorageSpec -> p -> m ()
checkValidTypeDef FunctionAttrs
fun_attrs StorageSpec
storage_spec Attributes
attrs
    Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (VarName -> Bool
isNoName VarName
name) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ NodeInfo -> [Char] -> m ()
forall (m :: * -> *) a. MonadCError m => NodeInfo -> [Char] -> m a
astError NodeInfo
node_info [Char]
"NoName in analyseTypeDef"
    let ident :: Ident
ident = VarName -> Ident
identOfVarName VarName
name
    TypeDef -> m ()
forall (m :: * -> *). MonadTrav m => TypeDef -> m ()
handleTypeDef (Ident -> Type -> Attributes -> NodeInfo -> TypeDef
TypeDef Ident
ident Type
ty Attributes
attrs NodeInfo
node_info)
    where
    checkValidTypeDef :: FunctionAttrs -> StorageSpec -> p -> m ()
checkValidTypeDef FunctionAttrs
fun_attrs  StorageSpec
_ p
_ | FunctionAttrs
fun_attrs FunctionAttrs -> FunctionAttrs -> Bool
forall a. Eq a => a -> a -> Bool
/= FunctionAttrs
noFunctionAttrs =
                                         NodeInfo -> [Char] -> m ()
forall (m :: * -> *) a. MonadCError m => NodeInfo -> [Char] -> m a
astError NodeInfo
node_info [Char]
"inline specifier for typeDef"
    checkValidTypeDef FunctionAttrs
_ StorageSpec
NoStorageSpec p
_ = () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    checkValidTypeDef FunctionAttrs
_ StorageSpec
bad_storage p
_ = NodeInfo -> [Char] -> m ()
forall (m :: * -> *) a. MonadCError m => NodeInfo -> [Char] -> m a
astError NodeInfo
node_info ([Char] -> m ()) -> [Char] -> m ()
forall a b. (a -> b) -> a -> b
$ [Char]
"storage specified for typeDef: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ StorageSpec -> [Char]
forall a. Show a => a -> [Char]
show StorageSpec
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 :: forall (m :: * -> *).
MonadTrav m =>
Ident -> StorageSpec -> m Storage
computeFunDefStorage Ident
_ (StaticSpec Bool
_)  = Storage -> m Storage
forall (m :: * -> *) a. Monad m => a -> m a
return(Storage -> m Storage) -> Storage -> m Storage
forall a b. (a -> b) -> a -> b
$ Linkage -> Storage
FunLinkage Linkage
InternalLinkage
computeFunDefStorage Ident
ident StorageSpec
other_spec  = do
  Maybe IdentDecl
obj_opt <- Ident -> m (Maybe IdentDecl)
forall (m :: * -> *).
(MonadCError m, MonadSymtab m) =>
Ident -> m (Maybe IdentDecl)
lookupObject Ident
ident
  let defaultSpec :: Storage
defaultSpec = Linkage -> Storage
FunLinkage Linkage
ExternalLinkage
  case StorageSpec
other_spec of
    StorageSpec
NoStorageSpec  -> Storage -> m Storage
forall (m :: * -> *) a. Monad m => a -> m a
return(Storage -> m Storage) -> Storage -> m Storage
forall a b. (a -> b) -> a -> b
$ Storage -> (IdentDecl -> Storage) -> Maybe IdentDecl -> Storage
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Storage
defaultSpec IdentDecl -> Storage
forall d. Declaration d => d -> Storage
declStorage Maybe IdentDecl
obj_opt
    StorageSpec
ClKernelSpec  -> Storage -> m Storage
forall (m :: * -> *) a. Monad m => a -> m a
return(Storage -> m Storage) -> Storage -> m Storage
forall a b. (a -> b) -> a -> b
$ Storage -> (IdentDecl -> Storage) -> Maybe IdentDecl -> Storage
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Storage
defaultSpec IdentDecl -> Storage
forall d. Declaration d => d -> Storage
declStorage Maybe IdentDecl
obj_opt
    (ExternSpec Bool
False) -> Storage -> m Storage
forall (m :: * -> *) a. Monad m => a -> m a
return(Storage -> m Storage) -> Storage -> m Storage
forall a b. (a -> b) -> a -> b
$ Storage -> (IdentDecl -> Storage) -> Maybe IdentDecl -> Storage
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Storage
defaultSpec IdentDecl -> Storage
forall d. Declaration d => d -> Storage
declStorage Maybe IdentDecl
obj_opt
    StorageSpec
bad_spec -> BadSpecifierError -> m Storage
forall (m :: * -> *) e a. (MonadCError m, Error e) => e -> m a
throwTravError (BadSpecifierError -> m Storage) -> BadSpecifierError -> m Storage
forall a b. (a -> b) -> a -> b
$ NodeInfo -> [Char] -> BadSpecifierError
badSpecifierError (Ident -> NodeInfo
forall a. CNode a => a -> NodeInfo
nodeInfo Ident
ident)
                  ([Char] -> BadSpecifierError) -> [Char] -> BadSpecifierError
forall a b. (a -> b) -> a -> b
$ [Char]
"unexpected function storage specifier (only static or extern is allowed)" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ StorageSpec -> [Char]
forall a. Show a => a -> [Char]
show StorageSpec
bad_spec

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

-- | handle a function prototype
extFunProto :: (MonadTrav m) => VarDeclInfo -> m ()
extFunProto :: forall (m :: * -> *). MonadTrav m => VarDeclInfo -> m ()
extFunProto (VarDeclInfo VarName
var_name FunctionAttrs
fun_spec StorageSpec
storage_spec Attributes
attrs Type
ty NodeInfo
node_info) =
    do  Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (VarName -> Bool
isNoName VarName
var_name) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ NodeInfo -> [Char] -> m ()
forall (m :: * -> *) a. MonadCError m => NodeInfo -> [Char] -> m a
astError NodeInfo
node_info [Char]
"NoName in extFunProto"
        Maybe IdentDecl
old_fun <- Ident -> m (Maybe IdentDecl)
forall (m :: * -> *).
(MonadCError m, MonadSymtab m) =>
Ident -> m (Maybe IdentDecl)
lookupObject (VarName -> Ident
identOfVarName VarName
var_name)
        m ()
checkValidSpecs
        let decl :: VarDecl
decl = VarName -> DeclAttrs -> Type -> VarDecl
VarDecl VarName
var_name (FunctionAttrs -> Storage -> Attributes -> DeclAttrs
DeclAttrs FunctionAttrs
fun_spec (Maybe IdentDecl -> Storage
forall {d}. Declaration d => Maybe d -> Storage
funDeclLinkage Maybe IdentDecl
old_fun) Attributes
attrs) Type
ty
        Bool -> Decl -> m ()
forall (m :: * -> *). MonadTrav m => Bool -> Decl -> m ()
handleVarDecl Bool
False (VarDecl -> NodeInfo -> Decl
Decl VarDecl
decl NodeInfo
node_info)
        -- XXX: structs should be handled in 'function prototype scope' too
        m ()
forall (m :: * -> *). MonadSymtab m => m ()
enterPrototypeScope
        m () -> ([ParamDecl] -> m ()) -> Maybe [ParamDecl] -> m ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (() -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()) ((ParamDecl -> m ()) -> [ParamDecl] -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ParamDecl -> m ()
forall (m :: * -> *). MonadTrav m => ParamDecl -> m ()
handleParamDecl) (Type -> Maybe [ParamDecl]
getParams Type
ty)
        m ()
forall (m :: * -> *). MonadSymtab m => m ()
leavePrototypeScope
    where
    funDeclLinkage :: Maybe d -> Storage
funDeclLinkage Maybe d
old_fun =
        case StorageSpec
storage_spec of
            StorageSpec
NoStorageSpec    -> Linkage -> Storage
FunLinkage Linkage
ExternalLinkage -- prototype declaration / external linkage
            StaticSpec Bool
False -> Linkage -> Storage
FunLinkage Linkage
InternalLinkage -- prototype declaration / internal linkage
            ExternSpec Bool
False -> case Maybe d
old_fun of
                                    Maybe d
Nothing -> Linkage -> Storage
FunLinkage Linkage
ExternalLinkage
                                    Just d
f  -> d -> Storage
forall d. Declaration d => d -> Storage
declStorage d
f
            StorageSpec
_ -> [Char] -> Storage
forall a. HasCallStack => [Char] -> a
error ([Char] -> Storage) -> [Char] -> Storage
forall a b. (a -> b) -> a -> b
$ [Char]
"funDeclLinkage: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ StorageSpec -> [Char]
forall a. Show a => a -> [Char]
show StorageSpec
storage_spec
    checkValidSpecs :: m ()
checkValidSpecs
        | StorageSpec -> Bool
hasThreadLocalSpec StorageSpec
storage_spec = NodeInfo -> [Char] -> m ()
forall (m :: * -> *) a. MonadCError m => NodeInfo -> [Char] -> m a
astError NodeInfo
node_info [Char]
"thread local storage specified for function"
        | StorageSpec
RegSpec <- StorageSpec
storage_spec         = NodeInfo -> [Char] -> m ()
forall (m :: * -> *) a. MonadCError m => NodeInfo -> [Char] -> m a
astError NodeInfo
node_info [Char]
"invalid `register' storage specified for function"
        | Bool
otherwise                       = () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
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 :: forall (m :: * -> *).
MonadTrav m =>
VarDeclInfo -> Maybe CInit -> m ()
extVarDecl (VarDeclInfo VarName
var_name FunctionAttrs
fun_spec StorageSpec
storage_spec Attributes
attrs Type
typ NodeInfo
node_info) Maybe CInit
init_opt =
    do Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (VarName -> Bool
isNoName VarName
var_name) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ NodeInfo -> [Char] -> m ()
forall (m :: * -> *) a. MonadCError m => NodeInfo -> [Char] -> m a
astError NodeInfo
node_info [Char]
"NoName in extVarDecl"
       (Storage
storage,Bool
is_def) <- StorageSpec -> m (Storage, Bool)
forall {m :: * -> *}.
(MonadCError m, MonadSymtab m) =>
StorageSpec -> m (Storage, Bool)
globalStorage StorageSpec
storage_spec
       let vardecl :: VarDecl
vardecl = VarName -> DeclAttrs -> Type -> VarDecl
VarDecl VarName
var_name (FunctionAttrs -> Storage -> Attributes -> DeclAttrs
DeclAttrs FunctionAttrs
fun_spec Storage
storage Attributes
attrs) Type
typ
       if Bool
is_def
           then Bool -> Ident -> ObjDef -> m ()
forall (m :: * -> *).
MonadTrav m =>
Bool -> Ident -> ObjDef -> m ()
handleObjectDef Bool
False Ident
ident (ObjDef -> m ()) -> ObjDef -> m ()
forall a b. (a -> b) -> a -> b
$ VarDecl -> Maybe CInit -> NodeInfo -> ObjDef
ObjDef VarDecl
vardecl Maybe CInit
init_opt NodeInfo
node_info
           else Bool -> Decl -> m ()
forall (m :: * -> *). MonadTrav m => Bool -> Decl -> m ()
handleVarDecl Bool
False (Decl -> m ()) -> Decl -> m ()
forall a b. (a -> b) -> a -> b
$ VarDecl -> NodeInfo -> Decl
Decl VarDecl
vardecl NodeInfo
node_info
    where
       ident :: Ident
ident = VarName -> Ident
identOfVarName VarName
var_name
       globalStorage :: StorageSpec -> m (Storage, Bool)
globalStorage StorageSpec
_ | FunctionAttrs
fun_spec FunctionAttrs -> FunctionAttrs -> Bool
forall a. Eq a => a -> a -> Bool
/= FunctionAttrs
noFunctionAttrs =
                           NodeInfo -> [Char] -> m (Storage, Bool)
forall (m :: * -> *) a. MonadCError m => NodeInfo -> [Char] -> m a
astError NodeInfo
node_info [Char]
"invalid function specifier for external variable"
       globalStorage StorageSpec
AutoSpec      = NodeInfo -> [Char] -> m (Storage, Bool)
forall (m :: * -> *) a. MonadCError m => NodeInfo -> [Char] -> m a
astError NodeInfo
node_info [Char]
"file-scope declaration specifies storage `auto'"
       globalStorage StorageSpec
RegSpec       =
         do Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Maybe CInit -> Bool
forall a. Maybe a -> Bool
isJust Maybe CInit
init_opt) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ NodeInfo -> [Char] -> m ()
forall (m :: * -> *) a. MonadCError m => NodeInfo -> [Char] -> m a
astError NodeInfo
node_info [Char]
"initializer given for global register variable"
            case VarName
var_name of
              VarName
NoName -> NodeInfo -> [Char] -> m ()
forall (m :: * -> *) a. MonadCError m => NodeInfo -> [Char] -> m a
astError NodeInfo
node_info [Char]
"global register variable has no name"
              VarName Ident
_ Maybe (CStringLiteral NodeInfo)
Nothing -> NodeInfo -> [Char] -> m ()
forall (m :: * -> *) a. MonadCError m => NodeInfo -> [Char] -> m a
astError NodeInfo
node_info [Char]
"no register specified for global register variable"
              VarName
_ -> () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
            DefTable
dt <- m DefTable
forall (m :: * -> *). MonadSymtab m => m DefTable
getDefTable
            Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (DefTable -> Bool
hasFunDef DefTable
dt) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ NodeInfo -> [Char] -> m ()
forall (m :: * -> *) a. MonadCError m => NodeInfo -> [Char] -> m a
astError NodeInfo
node_info [Char]
"global register variable appears after a function definition"
            (Storage, Bool) -> m (Storage, Bool)
forall (m :: * -> *) a. Monad m => a -> m a
return (Linkage -> Bool -> Storage
Static Linkage
InternalLinkage Bool
False, Bool
False)
       -- tentative if there is no initializer, external
       globalStorage StorageSpec
NoStorageSpec = (Storage, Bool) -> m (Storage, Bool)
forall (m :: * -> *) a. Monad m => a -> m a
return (Linkage -> Bool -> Storage
Static Linkage
ExternalLinkage Bool
False, Bool
True)
       globalStorage StorageSpec
ThreadSpec    = (Storage, Bool) -> m (Storage, Bool)
forall (m :: * -> *) a. Monad m => a -> m a
return (Linkage -> Bool -> Storage
Static Linkage
ExternalLinkage Bool
True, Bool
True)
       -- tentative if there is no initializer, internal
       globalStorage (StaticSpec Bool
thread_local) = (Storage, Bool) -> m (Storage, Bool)
forall (m :: * -> *) a. Monad m => a -> m a
return (Linkage -> Bool -> Storage
Static Linkage
InternalLinkage Bool
thread_local, Bool
True)
       globalStorage (ExternSpec Bool
thread_local) =
           case Maybe CInit
init_opt of
               -- declaration with either external or old storage
               Maybe CInit
Nothing -> do Maybe IdentDecl
old_decl <- Ident -> m (Maybe IdentDecl)
forall (m :: * -> *).
(MonadCError m, MonadSymtab m) =>
Ident -> m (Maybe IdentDecl)
lookupObject Ident
ident
                             (Storage, Bool) -> m (Storage, Bool)
forall (m :: * -> *) a. Monad m => a -> m a
return (Storage -> (IdentDecl -> Storage) -> Maybe IdentDecl -> Storage
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Linkage -> Bool -> Storage
Static Linkage
ExternalLinkage Bool
thread_local) IdentDecl -> Storage
forall d. Declaration d => d -> Storage
declStorage Maybe IdentDecl
old_decl,Bool
False)
               -- warning, external definition
               Just CInit
_  -> do BadSpecifierError -> m ()
forall e (m :: * -> *). (Error e, MonadCError m) => e -> m ()
warn (BadSpecifierError -> m ()) -> BadSpecifierError -> m ()
forall a b. (a -> b) -> a -> b
$ NodeInfo -> [Char] -> BadSpecifierError
badSpecifierError NodeInfo
node_info [Char]
"Both initializer and `extern` specifier given - treating as definition"
                             (Storage, Bool) -> m (Storage, Bool)
forall (m :: * -> *) a. Monad m => a -> m a
return (Linkage -> Bool -> Storage
Static Linkage
ExternalLinkage Bool
thread_local, Bool
True)
       hasFunDef :: DefTable -> Bool
hasFunDef DefTable
dt = ((Ident, IdentDecl) -> Bool) -> [(Ident, IdentDecl)] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (IdentDecl -> Bool
isFuncDef (IdentDecl -> Bool)
-> ((Ident, IdentDecl) -> IdentDecl) -> (Ident, IdentDecl) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Ident, IdentDecl) -> IdentDecl
forall a b. (a, b) -> b
snd) (Map Ident IdentDecl -> [(Ident, IdentDecl)]
forall k a. Map k a -> [(k, a)]
Map.toList (Map Ident IdentDecl -> [(Ident, IdentDecl)])
-> Map Ident IdentDecl -> [(Ident, IdentDecl)]
forall a b. (a -> b) -> a -> b
$ GlobalDecls -> Map Ident IdentDecl
gObjs (GlobalDecls -> Map Ident IdentDecl)
-> GlobalDecls -> Map Ident IdentDecl
forall a b. (a -> b) -> a -> b
$ DefTable -> GlobalDecls
globalDefs DefTable
dt)
       isFuncDef :: IdentDecl -> Bool
isFuncDef (FunctionDef FunDef
fd) = Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ (FunctionAttrs -> Bool
isInline (FunctionAttrs -> Bool)
-> (FunDef -> FunctionAttrs) -> FunDef -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FunDef -> FunctionAttrs
forall d. Declaration d => d -> FunctionAttrs
functionAttrs) FunDef
fd
       isFuncDef IdentDecl
_ = Bool
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 :: forall (m :: * -> *).
MonadTrav m =>
VarDeclInfo -> Maybe CInit -> m ()
localVarDecl (VarDeclInfo VarName
var_name FunctionAttrs
fun_attrs StorageSpec
storage_spec Attributes
attrs Type
typ NodeInfo
node_info) Maybe CInit
init_opt =
    do Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (VarName -> Bool
isNoName VarName
var_name) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ NodeInfo -> [Char] -> m ()
forall (m :: * -> *) a. MonadCError m => NodeInfo -> [Char] -> m a
astError NodeInfo
node_info [Char]
"NoName in localVarDecl"
       (Storage
storage,Bool
is_def) <- StorageSpec -> m (Storage, Bool)
forall {m :: * -> *}.
(MonadCError m, MonadSymtab m) =>
StorageSpec -> m (Storage, Bool)
localStorage StorageSpec
storage_spec
       let vardecl :: VarDecl
vardecl = VarName -> DeclAttrs -> Type -> VarDecl
VarDecl VarName
var_name (FunctionAttrs -> Storage -> Attributes -> DeclAttrs
DeclAttrs FunctionAttrs
fun_attrs Storage
storage Attributes
attrs) Type
typ
       if Bool
is_def
           then Bool -> Ident -> ObjDef -> m ()
forall (m :: * -> *).
MonadTrav m =>
Bool -> Ident -> ObjDef -> m ()
handleObjectDef Bool
True Ident
ident (VarDecl -> Maybe CInit -> NodeInfo -> ObjDef
ObjDef VarDecl
vardecl Maybe CInit
init_opt NodeInfo
node_info)
           else Bool -> Decl -> m ()
forall (m :: * -> *). MonadTrav m => Bool -> Decl -> m ()
handleVarDecl Bool
True (VarDecl -> NodeInfo -> Decl
Decl VarDecl
vardecl NodeInfo
node_info)
    where
    ident :: Ident
ident = VarName -> Ident
identOfVarName VarName
var_name
    localStorage :: StorageSpec -> m (Storage, Bool)
localStorage StorageSpec
NoStorageSpec = (Storage, Bool) -> m (Storage, Bool)
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> Storage
Auto Bool
False,Bool
True)
    localStorage StorageSpec
ThreadSpec    = (Storage, Bool) -> m (Storage, Bool)
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> Storage
Auto Bool
True,Bool
True)
    localStorage StorageSpec
RegSpec = (Storage, Bool) -> m (Storage, Bool)
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> Storage
Auto Bool
True,Bool
True)
    -- static no linkage
    localStorage (StaticSpec Bool
thread_local) =
      (Storage, Bool) -> m (Storage, Bool)
forall (m :: * -> *) a. Monad m => a -> m a
return (Linkage -> Bool -> Storage
Static Linkage
NoLinkage Bool
thread_local,Bool
True)
    localStorage (ExternSpec Bool
thread_local)
      | Maybe CInit -> Bool
forall a. Maybe a -> Bool
isJust Maybe CInit
init_opt = NodeInfo -> [Char] -> m (Storage, Bool)
forall (m :: * -> *) a. MonadCError m => NodeInfo -> [Char] -> m a
astError NodeInfo
node_info [Char]
"extern keyword and initializer for local"
      | Bool
otherwise =
          do Maybe IdentDecl
old_decl <- Ident -> m (Maybe IdentDecl)
forall (m :: * -> *).
(MonadCError m, MonadSymtab m) =>
Ident -> m (Maybe IdentDecl)
lookupObject Ident
ident
             (Storage, Bool) -> m (Storage, Bool)
forall (m :: * -> *) a. Monad m => a -> m a
return (Storage -> (IdentDecl -> Storage) -> Maybe IdentDecl -> Storage
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Linkage -> Bool -> Storage
Static Linkage
ExternalLinkage Bool
thread_local) IdentDecl -> Storage
forall d. Declaration d => d -> Storage
declStorage Maybe IdentDecl
old_decl,Bool
False)
    localStorage StorageSpec
_ = NodeInfo -> [Char] -> m (Storage, Bool)
forall (m :: * -> *) a. MonadCError m => NodeInfo -> [Char] -> m a
astError NodeInfo
node_info [Char]
"bad storage specifier for local"

defineParams :: MonadTrav m => NodeInfo -> VarDecl -> m ()
defineParams :: forall (m :: * -> *). MonadTrav m => NodeInfo -> VarDecl -> m ()
defineParams NodeInfo
ni VarDecl
decl =
  case Type -> Maybe [ParamDecl]
getParams (VarDecl -> Type
forall n. Declaration n => n -> Type
declType VarDecl
decl) of
    Maybe [ParamDecl]
Nothing -> NodeInfo -> [Char] -> m ()
forall (m :: * -> *) a. MonadCError m => NodeInfo -> [Char] -> m a
astError NodeInfo
ni
               [Char]
"expecting complete function type in function definition"
    Just [ParamDecl]
params -> (ParamDecl -> m ()) -> [ParamDecl] -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ParamDecl -> m ()
forall (m :: * -> *). MonadTrav m => ParamDecl -> m ()
handleParamDecl [ParamDecl]
params

analyseFunctionBody :: (MonadTrav m) => NodeInfo -> VarDecl -> CStat -> m Stmt
analyseFunctionBody :: forall (m :: * -> *).
MonadTrav m =>
NodeInfo
-> VarDecl -> CStatement NodeInfo -> m (CStatement NodeInfo)
analyseFunctionBody NodeInfo
node_info VarDecl
decl s :: CStatement NodeInfo
s@(CCompound [Ident]
localLabels [CCompoundBlockItem NodeInfo]
items NodeInfo
_) =
  do m ()
forall (m :: * -> *). MonadSymtab m => m ()
enterFunctionScope
     (Ident -> m (DeclarationStatus Ident)) -> [Ident] -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ((DefTable -> (DeclarationStatus Ident, DefTable))
-> m (DeclarationStatus Ident)
forall (m :: * -> *) a.
MonadSymtab m =>
(DefTable -> (a, DefTable)) -> m a
withDefTable ((DefTable -> (DeclarationStatus Ident, DefTable))
 -> m (DeclarationStatus Ident))
-> (Ident -> DefTable -> (DeclarationStatus Ident, DefTable))
-> Ident
-> m (DeclarationStatus Ident)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ident -> DefTable -> (DeclarationStatus Ident, DefTable)
defineLabel) ([Ident]
localLabels [Ident] -> [Ident] -> [Ident]
forall a. [a] -> [a] -> [a]
++ CStatement NodeInfo -> [Ident]
getLabels CStatement NodeInfo
s)
     NodeInfo -> VarDecl -> m ()
forall (m :: * -> *). MonadTrav m => NodeInfo -> VarDecl -> m ()
defineParams NodeInfo
node_info VarDecl
decl
     -- record parameters
     (CCompoundBlockItem NodeInfo -> m Type)
-> [CCompoundBlockItem NodeInfo] -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ([StmtCtx] -> CCompoundBlockItem NodeInfo -> m Type
forall (m :: * -> *).
MonadTrav m =>
[StmtCtx] -> CCompoundBlockItem NodeInfo -> m Type
tBlockItem [VarDecl -> StmtCtx
FunCtx VarDecl
decl]) [CCompoundBlockItem NodeInfo]
items
     m ()
forall (m :: * -> *). MonadSymtab m => m ()
leaveFunctionScope
     CStatement NodeInfo -> m (CStatement NodeInfo)
forall (m :: * -> *) a. Monad m => a -> m a
return CStatement NodeInfo
s -- XXX: bogus

analyseFunctionBody NodeInfo
_ VarDecl
_ CStatement NodeInfo
s = NodeInfo -> [Char] -> m (CStatement NodeInfo)
forall (m :: * -> *) a. MonadCError m => NodeInfo -> [Char] -> m a
astError (CStatement NodeInfo -> NodeInfo
forall a. CNode a => a -> NodeInfo
nodeInfo CStatement NodeInfo
s) [Char]
"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 :: [StmtCtx] -> Maybe Type
enclosingFunctionType [] = Maybe Type
forall a. Maybe a
Nothing
enclosingFunctionType (FunCtx VarDecl
vd : [StmtCtx]
_) = Type -> Maybe Type
forall a. a -> Maybe a
Just (Type -> Maybe Type) -> Type -> Maybe Type
forall a b. (a -> b) -> a -> b
$ VarDecl -> Type
forall n. Declaration n => n -> Type
declType VarDecl
vd
enclosingFunctionType (StmtCtx
_ : [StmtCtx]
cs) = [StmtCtx] -> Maybe Type
enclosingFunctionType [StmtCtx]
cs

inLoop :: [StmtCtx] -> Bool
inLoop :: [StmtCtx] -> Bool
inLoop [StmtCtx]
c = (StmtCtx -> Bool) -> [StmtCtx] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any StmtCtx -> Bool
isLoop [StmtCtx]
c
  where isLoop :: StmtCtx -> Bool
isLoop StmtCtx
LoopCtx = Bool
True
        isLoop StmtCtx
_ = Bool
False

inSwitch :: [StmtCtx] -> Bool
inSwitch :: [StmtCtx] -> Bool
inSwitch [StmtCtx]
c = (StmtCtx -> Bool) -> [StmtCtx] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any StmtCtx -> Bool
isSwitch [StmtCtx]
c
  where isSwitch :: StmtCtx -> Bool
isSwitch StmtCtx
SwitchCtx = Bool
True
        isSwitch StmtCtx
_ = Bool
False

data ExprSide = LValue | RValue
                deriving (ExprSide -> ExprSide -> Bool
(ExprSide -> ExprSide -> Bool)
-> (ExprSide -> ExprSide -> Bool) -> Eq ExprSide
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ExprSide -> ExprSide -> Bool
$c/= :: ExprSide -> ExprSide -> Bool
== :: ExprSide -> ExprSide -> Bool
$c== :: ExprSide -> ExprSide -> Bool
Eq, Int -> ExprSide -> [Char] -> [Char]
[ExprSide] -> [Char] -> [Char]
ExprSide -> [Char]
(Int -> ExprSide -> [Char] -> [Char])
-> (ExprSide -> [Char])
-> ([ExprSide] -> [Char] -> [Char])
-> Show ExprSide
forall a.
(Int -> a -> [Char] -> [Char])
-> (a -> [Char]) -> ([a] -> [Char] -> [Char]) -> Show a
showList :: [ExprSide] -> [Char] -> [Char]
$cshowList :: [ExprSide] -> [Char] -> [Char]
show :: ExprSide -> [Char]
$cshow :: ExprSide -> [Char]
showsPrec :: Int -> ExprSide -> [Char] -> [Char]
$cshowsPrec :: Int -> ExprSide -> [Char] -> [Char]
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 :: forall (m :: * -> *).
MonadTrav m =>
[StmtCtx] -> CStatement NodeInfo -> m Type
tStmt [StmtCtx]
c (CLabel Ident
_ CStatement NodeInfo
s [CAttribute NodeInfo]
_ NodeInfo
_)         = [StmtCtx] -> CStatement NodeInfo -> m Type
forall (m :: * -> *).
MonadTrav m =>
[StmtCtx] -> CStatement NodeInfo -> m Type
tStmt [StmtCtx]
c CStatement NodeInfo
s
tStmt [StmtCtx]
c (CExpr Maybe (CExpression NodeInfo)
e NodeInfo
_)              =
  m Type
-> (CExpression NodeInfo -> m Type)
-> Maybe (CExpression NodeInfo)
-> m Type
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Type -> m Type
forall (m :: * -> *) a. Monad m => a -> m a
return Type
voidType) ([StmtCtx] -> ExprSide -> CExpression NodeInfo -> m Type
forall (m :: * -> *).
MonadTrav m =>
[StmtCtx] -> ExprSide -> CExpression NodeInfo -> m Type
tExpr [StmtCtx]
c ExprSide
RValue) Maybe (CExpression NodeInfo)
e
tStmt [StmtCtx]
c (CCompound [Ident]
ls [CCompoundBlockItem NodeInfo]
body NodeInfo
_)    =
  do m ()
forall (m :: * -> *). MonadSymtab m => m ()
enterBlockScope
     (Ident -> m (DeclarationStatus Ident)) -> [Ident] -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ((DefTable -> (DeclarationStatus Ident, DefTable))
-> m (DeclarationStatus Ident)
forall (m :: * -> *) a.
MonadSymtab m =>
(DefTable -> (a, DefTable)) -> m a
withDefTable ((DefTable -> (DeclarationStatus Ident, DefTable))
 -> m (DeclarationStatus Ident))
-> (Ident -> DefTable -> (DeclarationStatus Ident, DefTable))
-> Ident
-> m (DeclarationStatus Ident)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ident -> DefTable -> (DeclarationStatus Ident, DefTable)
defineLabel) [Ident]
ls
     Type
t <- (Type -> CCompoundBlockItem NodeInfo -> m Type)
-> Type -> [CCompoundBlockItem NodeInfo] -> m Type
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM ((CCompoundBlockItem NodeInfo -> m Type)
-> Type -> CCompoundBlockItem NodeInfo -> m Type
forall a b. a -> b -> a
const ((CCompoundBlockItem NodeInfo -> m Type)
 -> Type -> CCompoundBlockItem NodeInfo -> m Type)
-> (CCompoundBlockItem NodeInfo -> m Type)
-> Type
-> CCompoundBlockItem NodeInfo
-> m Type
forall a b. (a -> b) -> a -> b
$ [StmtCtx] -> CCompoundBlockItem NodeInfo -> m Type
forall (m :: * -> *).
MonadTrav m =>
[StmtCtx] -> CCompoundBlockItem NodeInfo -> m Type
tBlockItem [StmtCtx]
c) Type
voidType [CCompoundBlockItem NodeInfo]
body
     m ()
forall (m :: * -> *). MonadSymtab m => m ()
leaveBlockScope
     Type -> m Type
forall (m :: * -> *) a. Monad m => a -> m a
return Type
t
tStmt [StmtCtx]
c (CIf CExpression NodeInfo
e CStatement NodeInfo
sthen Maybe (CStatement NodeInfo)
selse NodeInfo
_)    =
  [StmtCtx] -> CExpression NodeInfo -> m ()
forall (m :: * -> *).
MonadTrav m =>
[StmtCtx] -> CExpression NodeInfo -> m ()
checkGuard [StmtCtx]
c CExpression NodeInfo
e m () -> m Type -> m Type
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> [StmtCtx] -> CStatement NodeInfo -> m Type
forall (m :: * -> *).
MonadTrav m =>
[StmtCtx] -> CStatement NodeInfo -> m Type
tStmt [StmtCtx]
c CStatement NodeInfo
sthen
                 m Type -> m () -> m ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> m ()
-> (CStatement NodeInfo -> m ())
-> Maybe (CStatement NodeInfo)
-> m ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (() -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()) (m Type -> m ()
forall (m :: * -> *) a. Monad m => m a -> m ()
voidM (m Type -> m ())
-> (CStatement NodeInfo -> m Type) -> CStatement NodeInfo -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [StmtCtx] -> CStatement NodeInfo -> m Type
forall (m :: * -> *).
MonadTrav m =>
[StmtCtx] -> CStatement NodeInfo -> m Type
tStmt [StmtCtx]
c) Maybe (CStatement NodeInfo)
selse
                 m () -> m Type -> m Type
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Type -> m Type
forall (m :: * -> *) a. Monad m => a -> m a
return Type
voidType
tStmt [StmtCtx]
c (CSwitch CExpression NodeInfo
e CStatement NodeInfo
s NodeInfo
ni)         =
  [StmtCtx] -> ExprSide -> CExpression NodeInfo -> m Type
forall (m :: * -> *).
MonadTrav m =>
[StmtCtx] -> ExprSide -> CExpression NodeInfo -> m Type
tExpr [StmtCtx]
c ExprSide
RValue CExpression NodeInfo
e m Type -> (Type -> m ()) -> m ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= NodeInfo -> Type -> m ()
forall (m :: * -> *). MonadCError m => NodeInfo -> Type -> m ()
checkIntegral' NodeInfo
ni m () -> m Type -> m Type
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>>
  [StmtCtx] -> CStatement NodeInfo -> m Type
forall (m :: * -> *).
MonadTrav m =>
[StmtCtx] -> CStatement NodeInfo -> m Type
tStmt (StmtCtx
SwitchCtx StmtCtx -> [StmtCtx] -> [StmtCtx]
forall a. a -> [a] -> [a]
: [StmtCtx]
c) CStatement NodeInfo
s
tStmt [StmtCtx]
c (CWhile CExpression NodeInfo
e CStatement NodeInfo
s Bool
_ NodeInfo
_)         =
  [StmtCtx] -> CExpression NodeInfo -> m ()
forall (m :: * -> *).
MonadTrav m =>
[StmtCtx] -> CExpression NodeInfo -> m ()
checkGuard [StmtCtx]
c CExpression NodeInfo
e m () -> m Type -> m Type
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> [StmtCtx] -> CStatement NodeInfo -> m Type
forall (m :: * -> *).
MonadTrav m =>
[StmtCtx] -> CStatement NodeInfo -> m Type
tStmt (StmtCtx
LoopCtx StmtCtx -> [StmtCtx] -> [StmtCtx]
forall a. a -> [a] -> [a]
: [StmtCtx]
c) CStatement NodeInfo
s
tStmt [StmtCtx]
_ (CGoto Ident
l NodeInfo
ni)             =
  do DefTable
dt <- m DefTable
forall (m :: * -> *). MonadSymtab m => m DefTable
getDefTable
     case Ident -> DefTable -> Maybe Ident
lookupLabel Ident
l DefTable
dt of
       Just Ident
_ -> Type -> m Type
forall (m :: * -> *) a. Monad m => a -> m a
return Type
voidType
       Maybe Ident
Nothing -> NodeInfo -> [Char] -> m Type
forall (m :: * -> *) a. MonadCError m => NodeInfo -> [Char] -> m a
typeError NodeInfo
ni ([Char] -> m Type) -> [Char] -> m Type
forall a b. (a -> b) -> a -> b
$ [Char]
"undefined label in goto: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Ident -> [Char]
identToString Ident
l
tStmt [StmtCtx]
c (CCont NodeInfo
ni)               =
  do Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([StmtCtx] -> Bool
inLoop [StmtCtx]
c) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ NodeInfo -> [Char] -> m ()
forall (m :: * -> *) a. MonadCError m => NodeInfo -> [Char] -> m a
astError NodeInfo
ni [Char]
"continue statement outside of loop"
     Type -> m Type
forall (m :: * -> *) a. Monad m => a -> m a
return Type
voidType
tStmt [StmtCtx]
c (CBreak NodeInfo
ni)              =
  do Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([StmtCtx] -> Bool
inLoop [StmtCtx]
c Bool -> Bool -> Bool
|| [StmtCtx] -> Bool
inSwitch [StmtCtx]
c) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
            NodeInfo -> [Char] -> m ()
forall (m :: * -> *) a. MonadCError m => NodeInfo -> [Char] -> m a
astError NodeInfo
ni [Char]
"break statement outside of loop or switch statement"
     Type -> m Type
forall (m :: * -> *) a. Monad m => a -> m a
return Type
voidType
tStmt [StmtCtx]
c (CReturn (Just CExpression NodeInfo
e) NodeInfo
ni)    =
  do Type
t <- [StmtCtx] -> ExprSide -> CExpression NodeInfo -> m Type
forall (m :: * -> *).
MonadTrav m =>
[StmtCtx] -> ExprSide -> CExpression NodeInfo -> m Type
tExpr [StmtCtx]
c ExprSide
RValue CExpression NodeInfo
e
     Type
rt <- case [StmtCtx] -> Maybe Type
enclosingFunctionType [StmtCtx]
c of
             Just (FunctionType (FunType Type
rt [ParamDecl]
_ Bool
_) Attributes
_) -> Type -> m Type
forall (m :: * -> *) a. Monad m => a -> m a
return Type
rt
             Just (FunctionType (FunTypeIncomplete Type
rt) Attributes
_) -> Type -> m Type
forall (m :: * -> *) a. Monad m => a -> m a
return Type
rt
             Just Type
ft -> NodeInfo -> [Char] -> m Type
forall (m :: * -> *) a. MonadCError m => NodeInfo -> [Char] -> m a
astError NodeInfo
ni ([Char] -> m Type) -> [Char] -> m Type
forall a b. (a -> b) -> a -> b
$ [Char]
"bad function type: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Type -> [Char]
pType Type
ft
             Maybe Type
Nothing -> NodeInfo -> [Char] -> m Type
forall (m :: * -> *) a. MonadCError m => NodeInfo -> [Char] -> m a
astError NodeInfo
ni [Char]
"return statement outside function"
     case (Type
rt, Type
t) of
       -- apparently it's ok to return void from a void function?
       (DirectType TypeName
TyVoid TypeQuals
_ Attributes
_, DirectType TypeName
TyVoid TypeQuals
_ Attributes
_) -> () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
       (Type, Type)
_ -> NodeInfo -> CAssignOp -> Type -> Type -> m ()
forall (m :: * -> *).
MonadCError m =>
NodeInfo -> CAssignOp -> Type -> Type -> m ()
assignCompatible' NodeInfo
ni CAssignOp
CAssignOp Type
rt Type
t
     Type -> m Type
forall (m :: * -> *) a. Monad m => a -> m a
return Type
voidType
tStmt [StmtCtx]
_ (CReturn Maybe (CExpression NodeInfo)
Nothing NodeInfo
_)      = Type -> m Type
forall (m :: * -> *) a. Monad m => a -> m a
return Type
voidType
-- XXX: anything to do for assembly?
tStmt [StmtCtx]
_ (CAsm CAssemblyStatement NodeInfo
_ NodeInfo
_)               = Type -> m Type
forall (m :: * -> *) a. Monad m => a -> m a
return Type
voidType
tStmt [StmtCtx]
c (CCase CExpression NodeInfo
e CStatement NodeInfo
s NodeInfo
ni)           =
  do Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([StmtCtx] -> Bool
inSwitch [StmtCtx]
c) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
            NodeInfo -> [Char] -> m ()
forall (m :: * -> *) a. MonadCError m => NodeInfo -> [Char] -> m a
astError NodeInfo
ni [Char]
"case statement outside of switch statement"
     [StmtCtx] -> ExprSide -> CExpression NodeInfo -> m Type
forall (m :: * -> *).
MonadTrav m =>
[StmtCtx] -> ExprSide -> CExpression NodeInfo -> m Type
tExpr [StmtCtx]
c ExprSide
RValue CExpression NodeInfo
e m Type -> (Type -> m ()) -> m ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= NodeInfo -> Type -> m ()
forall (m :: * -> *). MonadCError m => NodeInfo -> Type -> m ()
checkIntegral' NodeInfo
ni
     [StmtCtx] -> CStatement NodeInfo -> m Type
forall (m :: * -> *).
MonadTrav m =>
[StmtCtx] -> CStatement NodeInfo -> m Type
tStmt [StmtCtx]
c CStatement NodeInfo
s
tStmt [StmtCtx]
c (CCases CExpression NodeInfo
e1 CExpression NodeInfo
e2 CStatement NodeInfo
s NodeInfo
ni)      =
  do Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([StmtCtx] -> Bool
inSwitch [StmtCtx]
c) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
            NodeInfo -> [Char] -> m ()
forall (m :: * -> *) a. MonadCError m => NodeInfo -> [Char] -> m a
astError NodeInfo
ni [Char]
"case statement outside of switch statement"
     [StmtCtx] -> ExprSide -> CExpression NodeInfo -> m Type
forall (m :: * -> *).
MonadTrav m =>
[StmtCtx] -> ExprSide -> CExpression NodeInfo -> m Type
tExpr [StmtCtx]
c ExprSide
RValue CExpression NodeInfo
e1 m Type -> (Type -> m ()) -> m ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= NodeInfo -> Type -> m ()
forall (m :: * -> *). MonadCError m => NodeInfo -> Type -> m ()
checkIntegral' NodeInfo
ni
     [StmtCtx] -> ExprSide -> CExpression NodeInfo -> m Type
forall (m :: * -> *).
MonadTrav m =>
[StmtCtx] -> ExprSide -> CExpression NodeInfo -> m Type
tExpr [StmtCtx]
c ExprSide
RValue CExpression NodeInfo
e2 m Type -> (Type -> m ()) -> m ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= NodeInfo -> Type -> m ()
forall (m :: * -> *). MonadCError m => NodeInfo -> Type -> m ()
checkIntegral' NodeInfo
ni
     [StmtCtx] -> CStatement NodeInfo -> m Type
forall (m :: * -> *).
MonadTrav m =>
[StmtCtx] -> CStatement NodeInfo -> m Type
tStmt [StmtCtx]
c CStatement NodeInfo
s
tStmt [StmtCtx]
c (CDefault CStatement NodeInfo
s NodeInfo
ni)          =
  do Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([StmtCtx] -> Bool
inSwitch [StmtCtx]
c) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
            NodeInfo -> [Char] -> m ()
forall (m :: * -> *) a. MonadCError m => NodeInfo -> [Char] -> m a
astError NodeInfo
ni [Char]
"default statement outside of switch statement"
     [StmtCtx] -> CStatement NodeInfo -> m Type
forall (m :: * -> *).
MonadTrav m =>
[StmtCtx] -> CStatement NodeInfo -> m Type
tStmt [StmtCtx]
c CStatement NodeInfo
s
tStmt [StmtCtx]
c (CFor Either (Maybe (CExpression NodeInfo)) (CDeclaration NodeInfo)
i Maybe (CExpression NodeInfo)
g Maybe (CExpression NodeInfo)
inc CStatement NodeInfo
s NodeInfo
_)       =
  do m ()
forall (m :: * -> *). MonadSymtab m => m ()
enterBlockScope
     (Maybe (CExpression NodeInfo) -> m ())
-> (CDeclaration NodeInfo -> m ())
-> Either (Maybe (CExpression NodeInfo)) (CDeclaration NodeInfo)
-> m ()
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (m ()
-> (CExpression NodeInfo -> m ())
-> Maybe (CExpression NodeInfo)
-> m ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (() -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()) CExpression NodeInfo -> m ()
forall {m :: * -> *}. MonadTrav m => CExpression NodeInfo -> m ()
checkExpr) (Bool -> CDeclaration NodeInfo -> m ()
forall (m :: * -> *).
MonadTrav m =>
Bool -> CDeclaration NodeInfo -> m ()
analyseDecl Bool
True) Either (Maybe (CExpression NodeInfo)) (CDeclaration NodeInfo)
i
     m ()
-> (CExpression NodeInfo -> m ())
-> Maybe (CExpression NodeInfo)
-> m ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (() -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()) ([StmtCtx] -> CExpression NodeInfo -> m ()
forall (m :: * -> *).
MonadTrav m =>
[StmtCtx] -> CExpression NodeInfo -> m ()
checkGuard [StmtCtx]
c) Maybe (CExpression NodeInfo)
g
     m ()
-> (CExpression NodeInfo -> m ())
-> Maybe (CExpression NodeInfo)
-> m ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (() -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()) CExpression NodeInfo -> m ()
forall {m :: * -> *}. MonadTrav m => CExpression NodeInfo -> m ()
checkExpr Maybe (CExpression NodeInfo)
inc
     Type
_ <- [StmtCtx] -> CStatement NodeInfo -> m Type
forall (m :: * -> *).
MonadTrav m =>
[StmtCtx] -> CStatement NodeInfo -> m Type
tStmt (StmtCtx
LoopCtx StmtCtx -> [StmtCtx] -> [StmtCtx]
forall a. a -> [a] -> [a]
: [StmtCtx]
c) CStatement NodeInfo
s
     m ()
forall (m :: * -> *). MonadSymtab m => m ()
leaveBlockScope
     Type -> m Type
forall (m :: * -> *) a. Monad m => a -> m a
return Type
voidType
  where checkExpr :: CExpression NodeInfo -> m ()
checkExpr CExpression NodeInfo
e = m Type -> m ()
forall (m :: * -> *) a. Monad m => m a -> m ()
voidM(m Type -> m ()) -> m Type -> m ()
forall a b. (a -> b) -> a -> b
$ [StmtCtx] -> ExprSide -> CExpression NodeInfo -> m Type
forall (m :: * -> *).
MonadTrav m =>
[StmtCtx] -> ExprSide -> CExpression NodeInfo -> m Type
tExpr [StmtCtx]
c ExprSide
RValue CExpression NodeInfo
e
tStmt [StmtCtx]
c (CGotoPtr CExpression NodeInfo
e NodeInfo
ni)          =
  do Type
t <- [StmtCtx] -> ExprSide -> CExpression NodeInfo -> m Type
forall (m :: * -> *).
MonadTrav m =>
[StmtCtx] -> ExprSide -> CExpression NodeInfo -> m Type
tExpr [StmtCtx]
c ExprSide
RValue CExpression NodeInfo
e
     case Type
t of
       (PtrType Type
_ TypeQuals
_ Attributes
_) -> Type -> m Type
forall (m :: * -> *) a. Monad m => a -> m a
return Type
voidType
       Type
_               -> NodeInfo -> [Char] -> m Type
forall (m :: * -> *) a. MonadCError m => NodeInfo -> [Char] -> m a
typeError NodeInfo
ni [Char]
"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 :: forall (m :: * -> *).
MonadTrav m =>
[StmtCtx] -> CCompoundBlockItem NodeInfo -> m Type
tBlockItem [StmtCtx]
c (CBlockStmt CStatement NodeInfo
s) = [StmtCtx] -> CStatement NodeInfo -> m Type
forall (m :: * -> *).
MonadTrav m =>
[StmtCtx] -> CStatement NodeInfo -> m Type
tStmt [StmtCtx]
c CStatement NodeInfo
s
tBlockItem [StmtCtx]
_ (CBlockDecl CDeclaration NodeInfo
d) = Bool -> CDeclaration NodeInfo -> m ()
forall (m :: * -> *).
MonadTrav m =>
Bool -> CDeclaration NodeInfo -> m ()
analyseDecl Bool
True CDeclaration NodeInfo
d m () -> m Type -> m Type
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Type -> m Type
forall (m :: * -> *) a. Monad m => a -> m a
return Type
voidType
-- TODO: fixup analyseFunDef to handle nested functions
tBlockItem [StmtCtx]
_ (CNestedFunDef CFunctionDef NodeInfo
fd) = CFunctionDef NodeInfo -> m ()
forall (m :: * -> *). MonadTrav m => CFunctionDef NodeInfo -> m ()
analyseFunDef CFunctionDef NodeInfo
fd m () -> m Type -> m Type
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Type -> m Type
forall (m :: * -> *) a. Monad m => a -> m a
return Type
voidType

checkGuard :: MonadTrav m => [StmtCtx] -> CExpr -> m ()
checkGuard :: forall (m :: * -> *).
MonadTrav m =>
[StmtCtx] -> CExpression NodeInfo -> m ()
checkGuard [StmtCtx]
c CExpression NodeInfo
e = [StmtCtx] -> ExprSide -> CExpression NodeInfo -> m Type
forall (m :: * -> *).
MonadTrav m =>
[StmtCtx] -> ExprSide -> CExpression NodeInfo -> m Type
tExpr [StmtCtx]
c ExprSide
RValue CExpression NodeInfo
e m Type -> (Type -> m ()) -> m ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= NodeInfo -> Type -> m ()
forall (m :: * -> *). MonadCError m => NodeInfo -> Type -> m ()
checkScalar' (CExpression NodeInfo -> NodeInfo
forall a. CNode a => a -> NodeInfo
nodeInfo CExpression 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
defaultMD =
  MachineDesc :: (IntType -> Integer)
-> (FloatType -> Integer)
-> (BuiltinType -> Integer)
-> Integer
-> Integer
-> (IntType -> Integer)
-> (FloatType -> Integer)
-> (BuiltinType -> Integer)
-> Integer
-> Integer
-> MachineDesc
MachineDesc
  { iSize :: IntType -> Integer
iSize = \IntType
it ->
            case IntType
it of
              IntType
TyBool    -> Integer
1
              IntType
TyChar    -> Integer
1
              IntType
TySChar   -> Integer
1
              IntType
TyUChar   -> Integer
1
              IntType
TyShort   -> Integer
2
              IntType
TyUShort  -> Integer
2
              IntType
TyInt     -> Integer
4
              IntType
TyUInt    -> Integer
4
              IntType
TyLong    -> Integer
4
              IntType
TyULong   -> Integer
4
              IntType
TyLLong   -> Integer
8
              IntType
TyULLong  -> Integer
8
              IntType
TyInt128  -> Integer
16
              IntType
TyUInt128 -> Integer
16
  , fSize :: FloatType -> Integer
fSize = \FloatType
ft ->
            case FloatType
ft of
              FloatType
TyFloat   -> Integer
4
              FloatType
TyDouble  -> Integer
8
              FloatType
TyLDouble -> Integer
16
  , builtinSize :: BuiltinType -> Integer
builtinSize = \BuiltinType
bt ->
                  case BuiltinType
bt of
                    BuiltinType
TyVaList -> Integer
4
                    BuiltinType
TyAny    -> Integer
4
  , ptrSize :: Integer
ptrSize = Integer
4
  , voidSize :: Integer
voidSize = Integer
1
  , iAlign :: IntType -> Integer
iAlign = \IntType
it ->
             case IntType
it of
               IntType
TyBool    -> Integer
1
               IntType
TyChar    -> Integer
1
               IntType
TySChar   -> Integer
1
               IntType
TyUChar   -> Integer
1
               IntType
TyShort   -> Integer
2
               IntType
TyUShort  -> Integer
2
               IntType
TyInt     -> Integer
4
               IntType
TyUInt    -> Integer
4
               IntType
TyLong    -> Integer
4
               IntType
TyULong   -> Integer
4
               IntType
TyLLong   -> Integer
8
               IntType
TyULLong  -> Integer
8
               IntType
TyInt128  -> Integer
16
               IntType
TyUInt128 -> Integer
16
  , fAlign :: FloatType -> Integer
fAlign = \FloatType
ft ->
             case FloatType
ft of
               FloatType
TyFloat   -> Integer
4
               FloatType
TyDouble  -> Integer
8
               FloatType
TyLDouble -> Integer
16
  , builtinAlign :: BuiltinType -> Integer
builtinAlign = \BuiltinType
bt ->
                   case BuiltinType
bt of
                     BuiltinType
TyVaList -> Integer
4
                     BuiltinType
TyAny    -> Integer
4
  , ptrAlign :: Integer
ptrAlign = Integer
4
  , voidAlign :: Integer
voidAlign = Integer
1
  }

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

tInitList :: MonadTrav m => NodeInfo -> Type -> CInitList -> m ()
tInitList :: forall (m :: * -> *).
MonadTrav m =>
NodeInfo -> Type -> CInitializerList NodeInfo -> m ()
tInitList NodeInfo
_ (ArrayType (DirectType (TyIntegral IntType
TyChar) TypeQuals
_ Attributes
_) ArraySize
_ TypeQuals
_ Attributes
_)
              [([], CInitExpr e :: CExpression NodeInfo
e@(CConst (CStrConst CString
_ NodeInfo
_)) NodeInfo
_)] =
  [StmtCtx] -> ExprSide -> CExpression NodeInfo -> m Type
forall (m :: * -> *).
MonadTrav m =>
[StmtCtx] -> ExprSide -> CExpression NodeInfo -> m Type
tExpr [] ExprSide
RValue CExpression NodeInfo
e m Type -> m () -> m ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
tInitList NodeInfo
ni t :: Type
t@(ArrayType Type
_ ArraySize
_ TypeQuals
_ Attributes
_) CInitializerList NodeInfo
initList =
  do let default_ds :: [CPartDesignator NodeInfo]
default_ds =
           CPartDesignator NodeInfo -> [CPartDesignator NodeInfo]
forall a. a -> [a]
repeat (CExpression NodeInfo -> NodeInfo -> CPartDesignator NodeInfo
forall a. CExpression a -> a -> CPartDesignator a
CArrDesig (CConstant NodeInfo -> CExpression NodeInfo
forall a. CConstant a -> CExpression a
CConst (CInteger -> NodeInfo -> CConstant NodeInfo
forall a. CInteger -> a -> CConstant a
CIntConst (Integer -> CInteger
cInteger Integer
0) NodeInfo
ni)) NodeInfo
ni)
     Type
-> [CPartDesignator NodeInfo] -> CInitializerList NodeInfo -> m ()
forall (m :: * -> *).
MonadTrav m =>
Type
-> [CPartDesignator NodeInfo] -> CInitializerList NodeInfo -> m ()
checkInits Type
t [CPartDesignator NodeInfo]
default_ds CInitializerList NodeInfo
initList
tInitList NodeInfo
ni t :: Type
t@(DirectType (TyComp CompTypeRef
ctr) TypeQuals
_ Attributes
_) CInitializerList NodeInfo
initList =
  do TagDef
td <- NodeInfo -> SUERef -> m TagDef
forall (m :: * -> *).
(MonadCError m, MonadSymtab m) =>
NodeInfo -> SUERef -> m TagDef
lookupSUE NodeInfo
ni (CompTypeRef -> SUERef
forall a. HasSUERef a => a -> SUERef
sueRef CompTypeRef
ctr)
     [(Ident, Type)]
ms <- NodeInfo -> TagDef -> m [(Ident, Type)]
forall (m :: * -> *).
(MonadCError m, MonadSymtab m) =>
NodeInfo -> TagDef -> m [(Ident, Type)]
tagMembers NodeInfo
ni TagDef
td
     let default_ds :: [CPartDesignator NodeInfo]
default_ds = ((Ident, Type) -> CPartDesignator NodeInfo)
-> [(Ident, Type)] -> [CPartDesignator NodeInfo]
forall a b. (a -> b) -> [a] -> [b]
map (\(Ident, Type)
m -> Ident -> NodeInfo -> CPartDesignator NodeInfo
forall a. Ident -> a -> CPartDesignator a
CMemberDesig ((Ident, Type) -> Ident
forall a b. (a, b) -> a
fst (Ident, Type)
m) NodeInfo
ni) [(Ident, Type)]
ms
     Type
-> [CPartDesignator NodeInfo] -> CInitializerList NodeInfo -> m ()
forall (m :: * -> *).
MonadTrav m =>
Type
-> [CPartDesignator NodeInfo] -> CInitializerList NodeInfo -> m ()
checkInits Type
t [CPartDesignator NodeInfo]
default_ds CInitializerList NodeInfo
initList
tInitList NodeInfo
_ (PtrType (DirectType TypeName
TyVoid TypeQuals
_ Attributes
_) TypeQuals
_ Attributes
_ ) CInitializerList NodeInfo
_ =
          () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return () -- XXX: more checking
tInitList NodeInfo
_ Type
t [([], CInit
i)] = m CInit -> m ()
forall (m :: * -> *) a. Monad m => m a -> m ()
voidM(m CInit -> m ()) -> m CInit -> m ()
forall a b. (a -> b) -> a -> b
$ Type -> CInit -> m CInit
forall (m :: * -> *). MonadTrav m => Type -> CInit -> m CInit
tInit Type
t CInit
i
tInitList NodeInfo
ni Type
t CInitializerList NodeInfo
_ = NodeInfo -> [Char] -> m ()
forall (m :: * -> *) a. MonadCError m => NodeInfo -> [Char] -> m a
typeError NodeInfo
ni ([Char] -> m ()) -> [Char] -> m ()
forall a b. (a -> b) -> a -> b
$ [Char]
"initializer list for type: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Type -> [Char]
pType Type
t

checkInits :: MonadTrav m => Type -> [CDesignator] -> CInitList -> m ()
checkInits :: forall (m :: * -> *).
MonadTrav m =>
Type
-> [CPartDesignator NodeInfo] -> CInitializerList NodeInfo -> m ()
checkInits Type
_ [CPartDesignator NodeInfo]
_ [] = () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
checkInits Type
t [CPartDesignator NodeInfo]
dds (([CPartDesignator NodeInfo]
ds, CInit
i) : CInitializerList NodeInfo
is) =
  do ([CPartDesignator NodeInfo]
dds', [CPartDesignator NodeInfo]
ds') <- case ([CPartDesignator NodeInfo]
dds, [CPartDesignator NodeInfo]
ds) of
                      ([], []) ->
                        NodeInfo
-> [Char]
-> m ([CPartDesignator NodeInfo], [CPartDesignator NodeInfo])
forall (m :: * -> *) a. MonadCError m => NodeInfo -> [Char] -> m a
typeError (CInit -> NodeInfo
forall a. CNode a => a -> NodeInfo
nodeInfo CInit
i) [Char]
"excess elements in initializer"
                      (CPartDesignator NodeInfo
dd' : [CPartDesignator NodeInfo]
rest, []) -> ([CPartDesignator NodeInfo], [CPartDesignator NodeInfo])
-> m ([CPartDesignator NodeInfo], [CPartDesignator NodeInfo])
forall (m :: * -> *) a. Monad m => a -> m a
return ([CPartDesignator NodeInfo]
rest, [CPartDesignator NodeInfo
dd'])
                      ([CPartDesignator NodeInfo]
_, CPartDesignator NodeInfo
d : [CPartDesignator NodeInfo]
_) -> ([CPartDesignator NodeInfo], [CPartDesignator NodeInfo])
-> m ([CPartDesignator NodeInfo], [CPartDesignator NodeInfo])
forall (m :: * -> *) a. Monad m => a -> m a
return ([CPartDesignator NodeInfo]
-> CPartDesignator NodeInfo -> [CPartDesignator NodeInfo]
advanceDesigList [CPartDesignator NodeInfo]
dds CPartDesignator NodeInfo
d, [CPartDesignator NodeInfo]
ds)
     Type
t' <- Type -> [CPartDesignator NodeInfo] -> m Type
forall (m :: * -> *).
MonadTrav m =>
Type -> [CPartDesignator NodeInfo] -> m Type
tDesignator Type
t [CPartDesignator NodeInfo]
ds'
     CInit
_ <- Type -> CInit -> m CInit
forall (m :: * -> *). MonadTrav m => Type -> CInit -> m CInit
tInit Type
t' CInit
i
     Type
-> [CPartDesignator NodeInfo] -> CInitializerList NodeInfo -> m ()
forall (m :: * -> *).
MonadTrav m =>
Type
-> [CPartDesignator NodeInfo] -> CInitializerList NodeInfo -> m ()
checkInits Type
t [CPartDesignator NodeInfo]
dds' CInitializerList NodeInfo
is

advanceDesigList :: [CDesignator] -> CDesignator -> [CDesignator]
advanceDesigList :: [CPartDesignator NodeInfo]
-> CPartDesignator NodeInfo -> [CPartDesignator NodeInfo]
advanceDesigList [CPartDesignator NodeInfo]
ds CPartDesignator NodeInfo
d = Int -> [CPartDesignator NodeInfo] -> [CPartDesignator NodeInfo]
forall a. Int -> [a] -> [a]
drop Int
1 ([CPartDesignator NodeInfo] -> [CPartDesignator NodeInfo])
-> [CPartDesignator NodeInfo] -> [CPartDesignator NodeInfo]
forall a b. (a -> b) -> a -> b
$ (CPartDesignator NodeInfo -> Bool)
-> [CPartDesignator NodeInfo] -> [CPartDesignator NodeInfo]
forall a. (a -> Bool) -> [a] -> [a]
dropWhile (Bool -> Bool
not (Bool -> Bool)
-> (CPartDesignator NodeInfo -> Bool)
-> CPartDesignator NodeInfo
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CPartDesignator NodeInfo -> CPartDesignator NodeInfo -> Bool
matchDesignator CPartDesignator NodeInfo
d) [CPartDesignator NodeInfo]
ds

matchDesignator :: CDesignator -> CDesignator -> Bool
matchDesignator :: CPartDesignator NodeInfo -> CPartDesignator NodeInfo -> Bool
matchDesignator (CMemberDesig Ident
m1 NodeInfo
_) (CMemberDesig Ident
m2 NodeInfo
_) = Ident
m1 Ident -> Ident -> Bool
forall a. Eq a => a -> a -> Bool
== Ident
m2
matchDesignator CPartDesignator NodeInfo
_ CPartDesignator NodeInfo
_ = Bool
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 :: forall (m :: * -> *).
MonadTrav m =>
Type -> [CPartDesignator NodeInfo] -> m Type
tDesignator (ArrayType Type
bt ArraySize
_ TypeQuals
_ Attributes
_) (CArrDesig CExpression NodeInfo
e NodeInfo
ni : [CPartDesignator NodeInfo]
ds) =
  do [StmtCtx] -> ExprSide -> CExpression NodeInfo -> m Type
forall (m :: * -> *).
MonadTrav m =>
[StmtCtx] -> ExprSide -> CExpression NodeInfo -> m Type
tExpr [] ExprSide
RValue CExpression NodeInfo
e m Type -> (Type -> m ()) -> m ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= NodeInfo -> Type -> m ()
forall (m :: * -> *). MonadCError m => NodeInfo -> Type -> m ()
checkIntegral' NodeInfo
ni
     Type -> [CPartDesignator NodeInfo] -> m Type
forall (m :: * -> *).
MonadTrav m =>
Type -> [CPartDesignator NodeInfo] -> m Type
tDesignator Type
bt [CPartDesignator NodeInfo]
ds
tDesignator (ArrayType Type
bt ArraySize
_ TypeQuals
_ Attributes
_) (CRangeDesig CExpression NodeInfo
e1 CExpression NodeInfo
e2 NodeInfo
ni : [CPartDesignator NodeInfo]
ds) =
  do [StmtCtx] -> ExprSide -> CExpression NodeInfo -> m Type
forall (m :: * -> *).
MonadTrav m =>
[StmtCtx] -> ExprSide -> CExpression NodeInfo -> m Type
tExpr [] ExprSide
RValue CExpression NodeInfo
e1 m Type -> (Type -> m ()) -> m ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= NodeInfo -> Type -> m ()
forall (m :: * -> *). MonadCError m => NodeInfo -> Type -> m ()
checkIntegral' NodeInfo
ni
     [StmtCtx] -> ExprSide -> CExpression NodeInfo -> m Type
forall (m :: * -> *).
MonadTrav m =>
[StmtCtx] -> ExprSide -> CExpression NodeInfo -> m Type
tExpr [] ExprSide
RValue CExpression NodeInfo
e2 m Type -> (Type -> m ()) -> m ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= NodeInfo -> Type -> m ()
forall (m :: * -> *). MonadCError m => NodeInfo -> Type -> m ()
checkIntegral' NodeInfo
ni
     Type -> [CPartDesignator NodeInfo] -> m Type
forall (m :: * -> *).
MonadTrav m =>
Type -> [CPartDesignator NodeInfo] -> m Type
tDesignator Type
bt [CPartDesignator NodeInfo]
ds
tDesignator (ArrayType Type
_ ArraySize
_ TypeQuals
_ Attributes
_) (CPartDesignator NodeInfo
d : [CPartDesignator NodeInfo]
_) =
  NodeInfo -> [Char] -> m Type
forall (m :: * -> *) a. MonadCError m => NodeInfo -> [Char] -> m a
typeError (CPartDesignator NodeInfo -> NodeInfo
forall a. CNode a => a -> NodeInfo
nodeInfo CPartDesignator NodeInfo
d) [Char]
"member designator in array initializer"
tDesignator t :: Type
t@(DirectType (TyComp CompTypeRef
_) TypeQuals
_ Attributes
_) (CMemberDesig Ident
m NodeInfo
ni : [CPartDesignator NodeInfo]
ds) =
  do Type
mt <- NodeInfo -> Ident -> Type -> m Type
forall (m :: * -> *).
(MonadCError m, MonadSymtab m) =>
NodeInfo -> Ident -> Type -> m Type
fieldType NodeInfo
ni Ident
m Type
t
     Type -> [CPartDesignator NodeInfo] -> m Type
forall (m :: * -> *).
MonadTrav m =>
Type -> [CPartDesignator NodeInfo] -> m Type
tDesignator (Type -> Type
canonicalType Type
mt) [CPartDesignator NodeInfo]
ds
tDesignator (DirectType (TyComp CompTypeRef
_) TypeQuals
_ Attributes
_) (CPartDesignator NodeInfo
d : [CPartDesignator NodeInfo]
_) =
  NodeInfo -> [Char] -> m Type
forall (m :: * -> *) a. MonadCError m => NodeInfo -> [Char] -> m a
typeError (CPartDesignator NodeInfo -> NodeInfo
forall a. CNode a => a -> NodeInfo
nodeInfo CPartDesignator NodeInfo
d) [Char]
"array designator in compound initializer"
tDesignator Type
t [] = Type -> m Type
forall (m :: * -> *) a. Monad m => a -> m a
return Type
t
tDesignator Type
_t [CPartDesignator NodeInfo]
_ =
  [Char] -> m Type
forall a. HasCallStack => [Char] -> a
error [Char]
"unepxected type with designator"

tInit :: MonadTrav m => Type -> CInit -> m Initializer
tInit :: forall (m :: * -> *). MonadTrav m => Type -> CInit -> m CInit
tInit Type
t i :: CInit
i@(CInitExpr CExpression NodeInfo
e NodeInfo
ni) =
  do Type
it <- [StmtCtx] -> ExprSide -> CExpression NodeInfo -> m Type
forall (m :: * -> *).
MonadTrav m =>
[StmtCtx] -> ExprSide -> CExpression NodeInfo -> m Type
tExpr [] ExprSide
RValue CExpression NodeInfo
e
     NodeInfo -> CAssignOp -> Type -> Type -> m ()
forall (m :: * -> *).
MonadCError m =>
NodeInfo -> CAssignOp -> Type -> Type -> m ()
assignCompatible' NodeInfo
ni CAssignOp
CAssignOp Type
t Type
it
     CInit -> m CInit
forall (m :: * -> *) a. Monad m => a -> m a
return CInit
i
tInit Type
t i :: CInit
i@(CInitList CInitializerList NodeInfo
initList NodeInfo
ni) =
  NodeInfo -> Type -> CInitializerList NodeInfo -> m ()
forall (m :: * -> *).
MonadTrav m =>
NodeInfo -> Type -> CInitializerList NodeInfo -> m ()
tInitList NodeInfo
ni (Type -> Type
canonicalType Type
t) CInitializerList NodeInfo
initList m () -> m CInit -> m CInit
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> CInit -> m CInit
forall (m :: * -> *) a. Monad m => a -> m a
return CInit
i

complexBaseType :: MonadTrav m => NodeInfo -> [StmtCtx] -> ExprSide -> CExpr -> m Type
complexBaseType :: forall (m :: * -> *).
MonadTrav m =>
NodeInfo -> [StmtCtx] -> ExprSide -> CExpression NodeInfo -> m Type
complexBaseType NodeInfo
ni [StmtCtx]
c ExprSide
side CExpression NodeInfo
e =
  do Type
t <- [StmtCtx] -> ExprSide -> CExpression NodeInfo -> m Type
forall (m :: * -> *).
MonadTrav m =>
[StmtCtx] -> ExprSide -> CExpression NodeInfo -> m Type
tExpr [StmtCtx]
c ExprSide
side CExpression NodeInfo
e
     case Type -> Type
canonicalType Type
t of
       DirectType (TyComplex FloatType
ft) TypeQuals
quals Attributes
attrs ->
         Type -> m Type
forall (m :: * -> *) a. Monad m => a -> m a
return (Type -> m Type) -> Type -> m Type
forall a b. (a -> b) -> a -> b
$ TypeName -> TypeQuals -> Attributes -> Type
DirectType (FloatType -> TypeName
TyFloating FloatType
ft) TypeQuals
quals Attributes
attrs
       Type
_ -> NodeInfo -> [Char] -> m Type
forall (m :: * -> *) a. MonadCError m => NodeInfo -> [Char] -> m a
typeError NodeInfo
ni ([Char] -> m Type) -> [Char] -> m Type
forall a b. (a -> b) -> a -> b
$ [Char]
"expected complex type, got: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Type -> [Char]
pType Type
t


-- | Return the type of a builtin.
builtinType :: MonadTrav m => CBuiltin -> m Type
builtinType :: forall (m :: * -> *).
MonadTrav m =>
CBuiltinThing NodeInfo -> m Type
builtinType (CBuiltinVaArg CExpression NodeInfo
_ CDeclaration NodeInfo
d NodeInfo
_)           = CDeclaration NodeInfo -> m Type
forall (m :: * -> *).
MonadTrav m =>
CDeclaration NodeInfo -> m Type
analyseTypeDecl CDeclaration NodeInfo
d
builtinType (CBuiltinOffsetOf CDeclaration NodeInfo
_ [CPartDesignator NodeInfo]
_ NodeInfo
_)        = Type -> m Type
forall (m :: * -> *) a. Monad m => a -> m a
return Type
size_tType
builtinType (CBuiltinTypesCompatible CDeclaration NodeInfo
_ CDeclaration NodeInfo
_ NodeInfo
_) = Type -> m Type
forall (m :: * -> *) a. Monad m => a -> m a
return Type
boolType
builtinType (CBuiltinConvertVector CExpression NodeInfo
_expr CDeclaration NodeInfo
ty NodeInfo
_) = CDeclaration NodeInfo -> m Type
forall (m :: * -> *).
MonadTrav m =>
CDeclaration NodeInfo -> m Type
analyseTypeDecl CDeclaration NodeInfo
ty

-- return @Just declspecs@ without @CTypedef@ if the declaration specifier contain @typedef@
hasTypeDef :: [CDeclSpec] -> Maybe [CDeclSpec]
hasTypeDef :: [CDeclarationSpecifier NodeInfo]
-> Maybe [CDeclarationSpecifier NodeInfo]
hasTypeDef [CDeclarationSpecifier NodeInfo]
declspecs =
    case (CDeclarationSpecifier NodeInfo
 -> (Bool, [CDeclarationSpecifier NodeInfo])
 -> (Bool, [CDeclarationSpecifier NodeInfo]))
-> (Bool, [CDeclarationSpecifier NodeInfo])
-> [CDeclarationSpecifier NodeInfo]
-> (Bool, [CDeclarationSpecifier NodeInfo])
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr CDeclarationSpecifier NodeInfo
-> (Bool, [CDeclarationSpecifier NodeInfo])
-> (Bool, [CDeclarationSpecifier NodeInfo])
forall {a}.
CDeclarationSpecifier a
-> (Bool, [CDeclarationSpecifier a])
-> (Bool, [CDeclarationSpecifier a])
hasTypeDefSpec (Bool
False,[]) [CDeclarationSpecifier NodeInfo]
declspecs of
        (Bool
True,[CDeclarationSpecifier NodeInfo]
specs') -> [CDeclarationSpecifier NodeInfo]
-> Maybe [CDeclarationSpecifier NodeInfo]
forall a. a -> Maybe a
Just [CDeclarationSpecifier NodeInfo]
specs'
        (Bool
False,[CDeclarationSpecifier NodeInfo]
_)     -> Maybe [CDeclarationSpecifier NodeInfo]
forall a. Maybe a
Nothing
    where
    hasTypeDefSpec :: CDeclarationSpecifier a
-> (Bool, [CDeclarationSpecifier a])
-> (Bool, [CDeclarationSpecifier a])
hasTypeDefSpec (CStorageSpec (CTypedef a
_)) (Bool
_,[CDeclarationSpecifier a]
specs) = (Bool
True, [CDeclarationSpecifier a]
specs)
    hasTypeDefSpec CDeclarationSpecifier a
spec (Bool
b,[CDeclarationSpecifier a]
specs) = (Bool
b,CDeclarationSpecifier a
specCDeclarationSpecifier a
-> [CDeclarationSpecifier a] -> [CDeclarationSpecifier a]
forall a. a -> [a] -> [a]
:[CDeclarationSpecifier a]
specs)