{-# 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
    forall {t :: * -> *} {m :: * -> *} {a} {a}.
(Foldable t, MonadCError m) =>
(a -> m a) -> t a -> m ()
mapRecoverM_ forall (m :: * -> *).
MonadTrav m =>
CExternalDeclaration NodeInfo -> m ()
analyseExt [CExternalDeclaration NodeInfo]
decls
    -- check we are in global scope afterwards
    forall (m :: * -> *). MonadSymtab m => m DefTable
getDefTable forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \DefTable
dt -> forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (DefTable -> Bool
inFileScope DefTable
dt) forall a b. (a -> b) -> a -> b
$
        forall a. HasCallStack => [Char] -> a
error [Char]
"Internal Error: Not in filescope after analysis"
    -- get the global definition table (XXX: remove ?)
    forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM DefTable -> GlobalDecls
globalDefs forall (m :: * -> *). MonadSymtab m => m DefTable
getDefTable
    where
    mapRecoverM_ :: (a -> m a) -> t a -> m ()
mapRecoverM_ a -> m a
f = forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (forall (m :: * -> *) a. MonadCError m => m a -> m (Maybe a)
handleTravError 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
_)
    = forall (m :: * -> *).
MonadTrav m =>
CStringLiteral NodeInfo -> m ()
handleAsmBlock CStringLiteral NodeInfo
asm
analyseExt (CFDefExt CFunctionDef NodeInfo
fundef)
    = forall (m :: * -> *). MonadTrav m => CFunctionDef NodeInfo -> m ()
analyseFunDef CFunctionDef NodeInfo
fundef
analyseExt (CDeclExt CDeclaration NodeInfo
decl)
    = 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 <- 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 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
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (VarName -> Bool
isNoName VarName
name) forall a b. (a -> b) -> a -> b
$ 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' <- forall {m :: * -> *}. Monad m => Type -> m Type
improveFunDefType Type
ty
    -- compute storage
    Storage
fun_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
    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' <- forall (m :: * -> *).
MonadTrav m =>
NodeInfo
-> VarDecl -> CStatement NodeInfo -> m (CStatement NodeInfo)
analyseFunctionBody NodeInfo
node_info VarDecl
var_decl CStatement NodeInfo
stmt
    -- callback for definition
    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) =
      forall (m :: * -> *) a. Monad m => a -> m a
return 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 = 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 forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> 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) = 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)
    | 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]
_  -> forall (m :: * -> *) a. MonadCError m => NodeInfo -> [Char] -> m a
astError NodeInfo
node [Char]
"bad typedef declaration: missing declarator"
                             Maybe [CDeclarationSpecifier NodeInfo]
Nothing -> forall (m :: * -> *) a. Monad m => m a -> m ()
voidMforall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
MonadTrav m =>
CDeclaration NodeInfo -> m Type
analyseTypeDecl CDeclaration NodeInfo
decl
    | (Just [CDeclarationSpecifier NodeInfo]
declspecs') <- Maybe [CDeclarationSpecifier NodeInfo]
typedef_spec = forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (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) =
                             forall a.
[CDeclarationSpecifier a]
-> ([CStorageSpecifier a], [CAttribute a], [CTypeQualifier a],
    [CTypeSpecifier a], [CFunctionSpecifier a],
    [CAlignmentSpecifier a])
partitionDeclSpecs [CDeclarationSpecifier NodeInfo]
declspecs
                       TypeSpecAnalysis
canonTySpecs <- 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)
                       forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (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 = forall a b. [a] -> [b] -> [(a, b)]
zip (Bool
True forall a. a -> [a] -> [a]
: 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) -> 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)
_ -> 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
_) <-
          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 [] forall a. Maybe a
Nothing
        -- declare / define the object
        if Type -> Bool
isFunctionType Type
typ
            then forall (m :: * -> *). MonadTrav m => VarDeclInfo -> m ()
extFunProto VarDeclInfo
vardeclInfo
            else (if Bool
is_local then forall (m :: * -> *).
MonadTrav m =>
VarDeclInfo -> Maybe CInit -> m ()
localVarDecl else 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' <- forall (m :: * -> *) a b.
Monad m =>
Maybe a -> (a -> m b) -> m (Maybe b)
mapMaybeM Maybe CInit
init_opt (forall (m :: * -> *). MonadTrav m => Type -> CInit -> m CInit
tInit Type
typ)
        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
_)         = 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) = 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) <- 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 [] forall a. Maybe a
Nothing
    forall {m :: * -> *} {p}.
MonadCError m =>
FunctionAttrs -> StorageSpec -> p -> m ()
checkValidTypeDef FunctionAttrs
fun_attrs StorageSpec
storage_spec Attributes
attrs
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (VarName -> Bool
isNoName VarName
name) forall a b. (a -> b) -> a -> b
$ 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
    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 forall a. Eq a => a -> a -> Bool
/= FunctionAttrs
noFunctionAttrs =
                                         forall (m :: * -> *) a. MonadCError m => NodeInfo -> [Char] -> m a
astError NodeInfo
node_info [Char]
"inline specifier for typeDef"
    checkValidTypeDef FunctionAttrs
_ StorageSpec
NoStorageSpec p
_ = forall (m :: * -> *) a. Monad m => a -> m a
return ()
    checkValidTypeDef FunctionAttrs
_ StorageSpec
bad_storage p
_ = forall (m :: * -> *) a. MonadCError m => NodeInfo -> [Char] -> m a
astError NodeInfo
node_info forall a b. (a -> b) -> a -> b
$ [Char]
"storage specified for typeDef: " forall a. [a] -> [a] -> [a]
++ 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
_)  = forall (m :: * -> *) a. Monad m => a -> m a
returnforall a b. (a -> b) -> a -> b
$ Linkage -> Storage
FunLinkage Linkage
InternalLinkage
computeFunDefStorage Ident
ident StorageSpec
other_spec  = do
  Maybe IdentDecl
obj_opt <- 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  -> forall (m :: * -> *) a. Monad m => a -> m a
returnforall a b. (a -> b) -> a -> b
$ forall b a. b -> (a -> b) -> Maybe a -> b
maybe Storage
defaultSpec forall d. Declaration d => d -> Storage
declStorage Maybe IdentDecl
obj_opt
    StorageSpec
ClKernelSpec  -> forall (m :: * -> *) a. Monad m => a -> m a
returnforall a b. (a -> b) -> a -> b
$ forall b a. b -> (a -> b) -> Maybe a -> b
maybe Storage
defaultSpec forall d. Declaration d => d -> Storage
declStorage Maybe IdentDecl
obj_opt
    (ExternSpec Bool
False) -> forall (m :: * -> *) a. Monad m => a -> m a
returnforall a b. (a -> b) -> a -> b
$ forall b a. b -> (a -> b) -> Maybe a -> b
maybe Storage
defaultSpec forall d. Declaration d => d -> Storage
declStorage Maybe IdentDecl
obj_opt
    StorageSpec
bad_spec -> forall (m :: * -> *) e a. (MonadCError m, Error e) => e -> m a
throwTravError forall a b. (a -> b) -> a -> b
$ NodeInfo -> [Char] -> BadSpecifierError
badSpecifierError (forall a. CNode a => a -> NodeInfo
nodeInfo Ident
ident)
                  forall a b. (a -> b) -> a -> b
$ [Char]
"unexpected function storage specifier (only static or extern is allowed)" forall a. [a] -> [a] -> [a]
++ 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
_) = forall a. a -> Maybe a
Just [ParamDecl]
params
getParams Type
_ = 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  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (VarName -> Bool
isNoName VarName
var_name) forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadCError m => NodeInfo -> [Char] -> m a
astError NodeInfo
node_info [Char]
"NoName in extFunProto"
        Maybe IdentDecl
old_fun <- 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 (forall {d}. Declaration d => Maybe d -> Storage
funDeclLinkage Maybe IdentDecl
old_fun) Attributes
attrs) Type
ty
        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
        forall (m :: * -> *). MonadSymtab m => m ()
enterPrototypeScope
        forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (m :: * -> *) a. Monad m => a -> m a
return ()) (forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ forall (m :: * -> *). MonadTrav m => ParamDecl -> m ()
handleParamDecl) (Type -> Maybe [ParamDecl]
getParams Type
ty)
        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  -> forall d. Declaration d => d -> Storage
declStorage d
f
            StorageSpec
_ -> forall a. HasCallStack => [Char] -> a
error forall a b. (a -> b) -> a -> b
$ [Char]
"funDeclLinkage: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show StorageSpec
storage_spec
    checkValidSpecs :: m ()
checkValidSpecs
        | StorageSpec -> Bool
hasThreadLocalSpec StorageSpec
storage_spec = 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         = forall (m :: * -> *) a. MonadCError m => NodeInfo -> [Char] -> m a
astError NodeInfo
node_info [Char]
"invalid `register' storage specified for function"
        | Bool
otherwise                       = 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 forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (VarName -> Bool
isNoName VarName
var_name) forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadCError m => NodeInfo -> [Char] -> m a
astError NodeInfo
node_info [Char]
"NoName in extVarDecl"
       (Storage
storage,Bool
is_def) <- 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 forall (m :: * -> *).
MonadTrav m =>
Bool -> Ident -> ObjDef -> m ()
handleObjectDef Bool
False Ident
ident forall a b. (a -> b) -> a -> b
$ VarDecl -> Maybe CInit -> NodeInfo -> ObjDef
ObjDef VarDecl
vardecl Maybe CInit
init_opt NodeInfo
node_info
           else forall (m :: * -> *). MonadTrav m => Bool -> Decl -> m ()
handleVarDecl Bool
False 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 forall a. Eq a => a -> a -> Bool
/= FunctionAttrs
noFunctionAttrs =
                           forall (m :: * -> *) a. MonadCError m => NodeInfo -> [Char] -> m a
astError NodeInfo
node_info [Char]
"invalid function specifier for external variable"
       globalStorage StorageSpec
AutoSpec      = forall (m :: * -> *) a. MonadCError m => NodeInfo -> [Char] -> m a
astError NodeInfo
node_info [Char]
"file-scope declaration specifies storage `auto'"
       globalStorage StorageSpec
RegSpec       =
         do forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall a. Maybe a -> Bool
isJust Maybe CInit
init_opt) forall a b. (a -> b) -> a -> b
$ 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 -> 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 -> forall (m :: * -> *) a. MonadCError m => NodeInfo -> [Char] -> m a
astError NodeInfo
node_info [Char]
"no register specified for global register variable"
              VarName
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
            DefTable
dt <- forall (m :: * -> *). MonadSymtab m => m DefTable
getDefTable
            forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (DefTable -> Bool
hasFunDef DefTable
dt) forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadCError m => NodeInfo -> [Char] -> m a
astError NodeInfo
node_info [Char]
"global register variable appears after a function definition"
            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 = forall (m :: * -> *) a. Monad m => a -> m a
return (Linkage -> Bool -> Storage
Static Linkage
ExternalLinkage Bool
False, Bool
True)
       globalStorage StorageSpec
ThreadSpec    = 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) = 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 <- forall (m :: * -> *).
(MonadCError m, MonadSymtab m) =>
Ident -> m (Maybe IdentDecl)
lookupObject Ident
ident
                             forall (m :: * -> *) a. Monad m => a -> m a
return (forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Linkage -> Bool -> Storage
Static Linkage
ExternalLinkage Bool
thread_local) forall d. Declaration d => d -> Storage
declStorage Maybe IdentDecl
old_decl,Bool
False)
               -- warning, external definition
               Just CInit
_  -> do forall e (m :: * -> *). (Error e, MonadCError m) => e -> m ()
warn forall a b. (a -> b) -> a -> b
$ NodeInfo -> [Char] -> BadSpecifierError
badSpecifierError NodeInfo
node_info [Char]
"Both initializer and `extern` specifier given - treating as definition"
                             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 = forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (IdentDecl -> Bool
isFuncDef forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) (forall k a. Map k a -> [(k, a)]
Map.toList forall a b. (a -> b) -> a -> b
$ GlobalDecls -> Map Ident IdentDecl
gObjs forall a b. (a -> b) -> a -> b
$ DefTable -> GlobalDecls
globalDefs DefTable
dt)
       isFuncDef :: IdentDecl -> Bool
isFuncDef (FunctionDef FunDef
fd) = Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ (FunctionAttrs -> Bool
isInline forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (VarName -> Bool
isNoName VarName
var_name) forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadCError m => NodeInfo -> [Char] -> m a
astError NodeInfo
node_info [Char]
"NoName in localVarDecl"
       (Storage
storage,Bool
is_def) <- 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 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 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 = forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> Storage
Auto Bool
False,Bool
True)
    localStorage StorageSpec
ThreadSpec    = forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> Storage
Auto Bool
True,Bool
True)
    localStorage StorageSpec
RegSpec = forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> Storage
Auto Bool
True,Bool
True)
    -- static no linkage
    localStorage (StaticSpec Bool
thread_local) =
      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)
      | forall a. Maybe a -> Bool
isJust Maybe CInit
init_opt = 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 <- forall (m :: * -> *).
(MonadCError m, MonadSymtab m) =>
Ident -> m (Maybe IdentDecl)
lookupObject Ident
ident
             forall (m :: * -> *) a. Monad m => a -> m a
return (forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Linkage -> Bool -> Storage
Static Linkage
ExternalLinkage Bool
thread_local) forall d. Declaration d => d -> Storage
declStorage Maybe IdentDecl
old_decl,Bool
False)
    localStorage StorageSpec
_ = 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 (forall n. Declaration n => n -> Type
declType VarDecl
decl) of
    Maybe [ParamDecl]
Nothing -> forall (m :: * -> *) a. MonadCError m => NodeInfo -> [Char] -> m a
astError NodeInfo
ni
               [Char]
"expecting complete function type in function definition"
    Just [ParamDecl]
params -> forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ 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 forall (m :: * -> *). MonadSymtab m => m ()
enterFunctionScope
     forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (forall (m :: * -> *) a.
MonadSymtab m =>
(DefTable -> (a, DefTable)) -> m a
withDefTable forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ident -> DefTable -> (DeclarationStatus Ident, DefTable)
defineLabel) ([Ident]
localLabels forall a. [a] -> [a] -> [a]
++ CStatement NodeInfo -> [Ident]
getLabels CStatement NodeInfo
s)
     forall (m :: * -> *). MonadTrav m => NodeInfo -> VarDecl -> m ()
defineParams NodeInfo
node_info VarDecl
decl
     -- record parameters
     forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (forall (m :: * -> *).
MonadTrav m =>
[StmtCtx] -> CCompoundBlockItem NodeInfo -> m Type
tBlockItem [VarDecl -> StmtCtx
FunCtx VarDecl
decl]) [CCompoundBlockItem NodeInfo]
items
     forall (m :: * -> *). MonadSymtab m => m ()
leaveFunctionScope
     forall (m :: * -> *) a. Monad m => a -> m a
return CStatement NodeInfo
s -- XXX: bogus

analyseFunctionBody NodeInfo
_ VarDecl
_ CStatement NodeInfo
s = forall (m :: * -> *) a. MonadCError m => NodeInfo -> [Char] -> m a
astError (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 [] = forall a. Maybe a
Nothing
enclosingFunctionType (FunCtx VarDecl
vd : [StmtCtx]
_) = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ 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 = 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 = 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
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 -> ShowS
[ExprSide] -> ShowS
ExprSide -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [ExprSide] -> ShowS
$cshowList :: [ExprSide] -> ShowS
show :: ExprSide -> [Char]
$cshow :: ExprSide -> [Char]
showsPrec :: Int -> ExprSide -> ShowS
$cshowsPrec :: Int -> ExprSide -> ShowS
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
_)         = forall (m :: * -> *).
MonadTrav m =>
[StmtCtx] -> CStatement NodeInfo -> m Type
tStmt [StmtCtx]
c CStatement NodeInfo
s
tStmt [StmtCtx]
c (CExpr Maybe (CExpression NodeInfo)
e NodeInfo
_)              =
  forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (m :: * -> *) a. Monad m => a -> m a
return Type
voidType) (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 forall (m :: * -> *). MonadSymtab m => m ()
enterBlockScope
     forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (forall (m :: * -> *) a.
MonadSymtab m =>
(DefTable -> (a, DefTable)) -> m a
withDefTable forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ident -> DefTable -> (DeclarationStatus Ident, DefTable)
defineLabel) [Ident]
ls
     Type
t <- forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM (forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
MonadTrav m =>
[StmtCtx] -> CCompoundBlockItem NodeInfo -> m Type
tBlockItem [StmtCtx]
c) Type
voidType [CCompoundBlockItem NodeInfo]
body
     forall (m :: * -> *). MonadSymtab m => m ()
leaveBlockScope
     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
_)    =
  forall (m :: * -> *).
MonadTrav m =>
[StmtCtx] -> CExpression NodeInfo -> m ()
checkGuard [StmtCtx]
c CExpression NodeInfo
e forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *).
MonadTrav m =>
[StmtCtx] -> CStatement NodeInfo -> m Type
tStmt [StmtCtx]
c CStatement NodeInfo
sthen
                 forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (m :: * -> *) a. Monad m => a -> m a
return ()) (forall (m :: * -> *) a. Monad m => m a -> m ()
voidM forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *).
MonadTrav m =>
[StmtCtx] -> CStatement NodeInfo -> m Type
tStmt [StmtCtx]
c) Maybe (CStatement NodeInfo)
selse
                 forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return Type
voidType
tStmt [StmtCtx]
c (CSwitch CExpression NodeInfo
e CStatement NodeInfo
s NodeInfo
ni)         =
  forall (m :: * -> *).
MonadTrav m =>
[StmtCtx] -> ExprSide -> CExpression NodeInfo -> m Type
tExpr [StmtCtx]
c ExprSide
RValue CExpression NodeInfo
e forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *). MonadCError m => NodeInfo -> Type -> m ()
checkIntegral' NodeInfo
ni forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>>
  forall (m :: * -> *).
MonadTrav m =>
[StmtCtx] -> CStatement NodeInfo -> m Type
tStmt (StmtCtx
SwitchCtx forall a. a -> [a] -> [a]
: [StmtCtx]
c) CStatement NodeInfo
s
tStmt [StmtCtx]
c (CWhile CExpression NodeInfo
e CStatement NodeInfo
s Bool
_ NodeInfo
_)         =
  forall (m :: * -> *).
MonadTrav m =>
[StmtCtx] -> CExpression NodeInfo -> m ()
checkGuard [StmtCtx]
c CExpression NodeInfo
e forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *).
MonadTrav m =>
[StmtCtx] -> CStatement NodeInfo -> m Type
tStmt (StmtCtx
LoopCtx forall a. a -> [a] -> [a]
: [StmtCtx]
c) CStatement NodeInfo
s
tStmt [StmtCtx]
_ (CGoto Ident
l NodeInfo
ni)             =
  do DefTable
dt <- forall (m :: * -> *). MonadSymtab m => m DefTable
getDefTable
     case Ident -> DefTable -> Maybe Ident
lookupLabel Ident
l DefTable
dt of
       Just Ident
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return Type
voidType
       Maybe Ident
Nothing -> forall (m :: * -> *) a. MonadCError m => NodeInfo -> [Char] -> m a
typeError NodeInfo
ni forall a b. (a -> b) -> a -> b
$ [Char]
"undefined label in goto: " forall a. [a] -> [a] -> [a]
++ Ident -> [Char]
identToString Ident
l
tStmt [StmtCtx]
c (CCont NodeInfo
ni)               =
  do forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([StmtCtx] -> Bool
inLoop [StmtCtx]
c) forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadCError m => NodeInfo -> [Char] -> m a
astError NodeInfo
ni [Char]
"continue statement outside of loop"
     forall (m :: * -> *) a. Monad m => a -> m a
return Type
voidType
tStmt [StmtCtx]
c (CBreak NodeInfo
ni)              =
  do forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([StmtCtx] -> Bool
inLoop [StmtCtx]
c Bool -> Bool -> Bool
|| [StmtCtx] -> Bool
inSwitch [StmtCtx]
c) forall a b. (a -> b) -> a -> b
$
            forall (m :: * -> *) a. MonadCError m => NodeInfo -> [Char] -> m a
astError NodeInfo
ni [Char]
"break statement outside of loop or switch statement"
     forall (m :: * -> *) a. Monad m => a -> m a
return Type
voidType
tStmt [StmtCtx]
c (CReturn (Just CExpression NodeInfo
e) NodeInfo
ni)    =
  do Type
t <- 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
_) -> forall (m :: * -> *) a. Monad m => a -> m a
return Type
rt
             Just (FunctionType (FunTypeIncomplete Type
rt) Attributes
_) -> forall (m :: * -> *) a. Monad m => a -> m a
return Type
rt
             Just Type
ft -> forall (m :: * -> *) a. MonadCError m => NodeInfo -> [Char] -> m a
astError NodeInfo
ni forall a b. (a -> b) -> a -> b
$ [Char]
"bad function type: " forall a. [a] -> [a] -> [a]
++ Type -> [Char]
pType Type
ft
             Maybe Type
Nothing -> 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
_) -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
       (Type, Type)
_ -> forall (m :: * -> *).
MonadCError m =>
NodeInfo -> CAssignOp -> Type -> Type -> m ()
assignCompatible' NodeInfo
ni CAssignOp
CAssignOp Type
rt Type
t
     forall (m :: * -> *) a. Monad m => a -> m a
return Type
voidType
tStmt [StmtCtx]
_ (CReturn Maybe (CExpression NodeInfo)
Nothing NodeInfo
_)      = forall (m :: * -> *) a. Monad m => a -> m a
return Type
voidType
-- XXX: anything to do for assembly?
tStmt [StmtCtx]
_ (CAsm CAssemblyStatement NodeInfo
_ NodeInfo
_)               = forall (m :: * -> *) a. Monad m => a -> m a
return Type
voidType
tStmt [StmtCtx]
c (CCase CExpression NodeInfo
e CStatement NodeInfo
s NodeInfo
ni)           =
  do forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([StmtCtx] -> Bool
inSwitch [StmtCtx]
c) forall a b. (a -> b) -> a -> b
$
            forall (m :: * -> *) a. MonadCError m => NodeInfo -> [Char] -> m a
astError NodeInfo
ni [Char]
"case statement outside of switch statement"
     forall (m :: * -> *).
MonadTrav m =>
[StmtCtx] -> ExprSide -> CExpression NodeInfo -> m Type
tExpr [StmtCtx]
c ExprSide
RValue CExpression NodeInfo
e forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *). MonadCError m => NodeInfo -> Type -> m ()
checkIntegral' NodeInfo
ni
     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 forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([StmtCtx] -> Bool
inSwitch [StmtCtx]
c) forall a b. (a -> b) -> a -> b
$
            forall (m :: * -> *) a. MonadCError m => NodeInfo -> [Char] -> m a
astError NodeInfo
ni [Char]
"case statement outside of switch statement"
     forall (m :: * -> *).
MonadTrav m =>
[StmtCtx] -> ExprSide -> CExpression NodeInfo -> m Type
tExpr [StmtCtx]
c ExprSide
RValue CExpression NodeInfo
e1 forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *). MonadCError m => NodeInfo -> Type -> m ()
checkIntegral' NodeInfo
ni
     forall (m :: * -> *).
MonadTrav m =>
[StmtCtx] -> ExprSide -> CExpression NodeInfo -> m Type
tExpr [StmtCtx]
c ExprSide
RValue CExpression NodeInfo
e2 forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *). MonadCError m => NodeInfo -> Type -> m ()
checkIntegral' NodeInfo
ni
     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 forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([StmtCtx] -> Bool
inSwitch [StmtCtx]
c) forall a b. (a -> b) -> a -> b
$
            forall (m :: * -> *) a. MonadCError m => NodeInfo -> [Char] -> m a
astError NodeInfo
ni [Char]
"default statement outside of switch statement"
     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 forall (m :: * -> *). MonadSymtab m => m ()
enterBlockScope
     forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (m :: * -> *) a. Monad m => a -> m a
return ()) forall {m :: * -> *}. MonadTrav m => CExpression NodeInfo -> m ()
checkExpr) (forall (m :: * -> *).
MonadTrav m =>
Bool -> CDeclaration NodeInfo -> m ()
analyseDecl Bool
True) Either (Maybe (CExpression NodeInfo)) (CDeclaration NodeInfo)
i
     forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (m :: * -> *) a. Monad m => a -> m a
return ()) (forall (m :: * -> *).
MonadTrav m =>
[StmtCtx] -> CExpression NodeInfo -> m ()
checkGuard [StmtCtx]
c) Maybe (CExpression NodeInfo)
g
     forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (m :: * -> *) a. Monad m => a -> m a
return ()) forall {m :: * -> *}. MonadTrav m => CExpression NodeInfo -> m ()
checkExpr Maybe (CExpression NodeInfo)
inc
     Type
_ <- forall (m :: * -> *).
MonadTrav m =>
[StmtCtx] -> CStatement NodeInfo -> m Type
tStmt (StmtCtx
LoopCtx forall a. a -> [a] -> [a]
: [StmtCtx]
c) CStatement NodeInfo
s
     forall (m :: * -> *). MonadSymtab m => m ()
leaveBlockScope
     forall (m :: * -> *) a. Monad m => a -> m a
return Type
voidType
  where checkExpr :: CExpression NodeInfo -> m ()
checkExpr CExpression NodeInfo
e = forall (m :: * -> *) a. Monad m => m a -> m ()
voidMforall a b. (a -> b) -> a -> b
$ 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 <- 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
_) -> forall (m :: * -> *) a. Monad m => a -> m a
return Type
voidType
       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) = forall (m :: * -> *).
MonadTrav m =>
[StmtCtx] -> CStatement NodeInfo -> m Type
tStmt [StmtCtx]
c CStatement NodeInfo
s
tBlockItem [StmtCtx]
_ (CBlockDecl CDeclaration NodeInfo
d) = forall (m :: * -> *).
MonadTrav m =>
Bool -> CDeclaration NodeInfo -> m ()
analyseDecl Bool
True CDeclaration NodeInfo
d forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return Type
voidType
-- TODO: fixup analyseFunDef to handle nested functions
tBlockItem [StmtCtx]
_ (CNestedFunDef CFunctionDef NodeInfo
fd) = forall (m :: * -> *). MonadTrav m => CFunctionDef NodeInfo -> m ()
analyseFunDef CFunctionDef NodeInfo
fd forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> 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 = forall (m :: * -> *).
MonadTrav m =>
[StmtCtx] -> ExprSide -> CExpression NodeInfo -> m Type
tExpr [StmtCtx]
c ExprSide
RValue CExpression NodeInfo
e forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *). MonadCError m => NodeInfo -> Type -> m ()
checkScalar' (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
  { 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 (forall a. CNode a => a -> NodeInfo
nodeInfo CExpression NodeInfo
e) of
    Just Name
n ->
      do DefTable
dt <- forall (m :: * -> *). MonadSymtab m => m DefTable
getDefTable
         case DefTable -> Name -> Maybe Type
lookupType DefTable
dt Name
n of
           Just Type
t -> forall (m :: * -> *) a. Monad m => a -> m a
return Type
t
           Maybe Type
Nothing ->
             do Type
t <- forall (m :: * -> *).
MonadTrav m =>
[StmtCtx] -> ExprSide -> CExpression NodeInfo -> m Type
tExpr' [StmtCtx]
c ExprSide
side CExpression NodeInfo
e
                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 -> 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 forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ExprSide
side forall a. Eq a => a -> a -> Bool
== ExprSide
LValue) forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadCError m => NodeInfo -> [Char] -> m a
typeError NodeInfo
ni [Char]
"binary operator as lvalue"
     Type
lt <- forall (m :: * -> *).
MonadTrav m =>
[StmtCtx] -> ExprSide -> CExpression NodeInfo -> m Type
tExpr [StmtCtx]
c ExprSide
RValue CExpression NodeInfo
le
     Type
rt <- forall (m :: * -> *).
MonadTrav m =>
[StmtCtx] -> ExprSide -> CExpression NodeInfo -> m Type
tExpr [StmtCtx]
c ExprSide
RValue CExpression NodeInfo
re
     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 forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ExprSide
side forall a. Eq a => a -> a -> Bool
== ExprSide
LValue) forall a b. (a -> b) -> a -> b
$
          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 forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
`liftM` forall (m :: * -> *).
MonadTrav m =>
[StmtCtx] -> ExprSide -> CExpression NodeInfo -> m Type
tExpr [StmtCtx]
c ExprSide
RValue CExpression NodeInfo
e
       CVar Ident
i NodeInfo
_ -> forall (m :: * -> *).
(MonadCError m, MonadSymtab m) =>
Ident -> m (Maybe IdentDecl)
lookupObject Ident
i forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
                   forall (m :: * -> *) a.
MonadCError m =>
NodeInfo -> Either [Char] a -> m a
typeErrorOnLeft NodeInfo
ni forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall a. Ident -> Either [Char] a
notFound Ident
i) IdentDecl -> Either [Char] Type
varAddrType
       CExpression NodeInfo
_        -> Type -> Type
simplePtr forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
`liftM` 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)     =
  forall (m :: * -> *).
MonadTrav m =>
[StmtCtx] -> ExprSide -> CExpression NodeInfo -> m Type
tExpr [StmtCtx]
c ExprSide
RValue CExpression NodeInfo
e forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (forall (m :: * -> *) a.
MonadCError m =>
NodeInfo -> Either [Char] a -> m a
typeErrorOnLeft NodeInfo
ni 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 <- forall (m :: * -> *).
MonadTrav m =>
[StmtCtx] -> ExprSide -> CExpression NodeInfo -> m Type
tExpr [StmtCtx]
c ExprSide
RValue CExpression NodeInfo
e
     forall (m :: * -> *). MonadCError m => NodeInfo -> Type -> m ()
checkIntegral' NodeInfo
ni Type
t
     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 forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ExprSide
side forall a. Eq a => a -> a -> Bool
== ExprSide
LValue) forall a b. (a -> b) -> a -> b
$
          forall (m :: * -> *) a. MonadCError m => NodeInfo -> [Char] -> m a
typeError NodeInfo
ni [Char]
"logical negation used as lvalue"
     forall (m :: * -> *).
MonadTrav m =>
[StmtCtx] -> ExprSide -> CExpression NodeInfo -> m Type
tExpr [StmtCtx]
c ExprSide
RValue CExpression NodeInfo
e forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *). MonadCError m => NodeInfo -> Type -> m ()
checkScalar' NodeInfo
ni
     forall (m :: * -> *) a. Monad m => a -> m a
return Type
boolType
tExpr' [StmtCtx]
c ExprSide
side (CUnary CUnaryOp
op CExpression NodeInfo
e NodeInfo
_)          =
  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 <- forall (m :: * -> *).
MonadTrav m =>
[StmtCtx] -> ExprSide -> CExpression NodeInfo -> m Type
tExpr [StmtCtx]
c ExprSide
RValue CExpression NodeInfo
b
     Type
it <- forall (m :: * -> *).
MonadTrav m =>
[StmtCtx] -> ExprSide -> CExpression NodeInfo -> m Type
tExpr [StmtCtx]
c ExprSide
RValue CExpression NodeInfo
i
     Type
addrTy <- forall (m :: * -> *).
MonadCError m =>
NodeInfo -> CBinaryOp -> Type -> Type -> m Type
binopType' NodeInfo
ni CBinaryOp
CAddOp Type
bt Type
it
     forall (m :: * -> *) a.
MonadCError m =>
NodeInfo -> Either [Char] a -> m a
typeErrorOnLeft NodeInfo
ni 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 <- forall (m :: * -> *).
MonadTrav m =>
[StmtCtx] -> ExprSide -> CExpression NodeInfo -> m Type
tExpr [StmtCtx]
c ExprSide
RValue CExpression NodeInfo
e1
     forall (m :: * -> *). MonadCError m => NodeInfo -> Type -> m ()
checkScalar' (forall a. CNode a => a -> NodeInfo
nodeInfo CExpression NodeInfo
e1) Type
t1
     Type
t3 <- 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 <- forall (m :: * -> *).
MonadTrav m =>
[StmtCtx] -> ExprSide -> CExpression NodeInfo -> m Type
tExpr [StmtCtx]
c ExprSide
side CExpression NodeInfo
e2
            forall (m :: * -> *).
MonadCError m =>
NodeInfo -> Type -> Type -> m Type
conditionalType' NodeInfo
ni Type
t2 Type
t3
       Maybe (CExpression NodeInfo)
Nothing -> 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 <- forall (m :: * -> *).
MonadTrav m =>
[StmtCtx] -> ExprSide -> CExpression NodeInfo -> m Type
tExpr [StmtCtx]
c ExprSide
RValue CExpression NodeInfo
e
     Type
bt <- if Bool
deref then forall (m :: * -> *) a.
MonadCError m =>
NodeInfo -> Either [Char] a -> m a
typeErrorOnLeft NodeInfo
ni (Type -> Either [Char] Type
derefType Type
t) else forall (m :: * -> *) a. Monad m => a -> m a
return Type
t
     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
_)            =
  forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall (m :: * -> *).
MonadTrav m =>
[StmtCtx] -> ExprSide -> CExpression NodeInfo -> m Type
tExpr [StmtCtx]
c ExprSide
side) [CExpression NodeInfo]
es forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> a
last
tExpr' [StmtCtx]
c ExprSide
side (CCast CDeclaration NodeInfo
d CExpression NodeInfo
e NodeInfo
ni)           =
  do Type
dt <- forall (m :: * -> *).
MonadTrav m =>
CDeclaration NodeInfo -> m Type
analyseTypeDecl CDeclaration NodeInfo
d
     Type
et <- forall (m :: * -> *).
MonadTrav m =>
[StmtCtx] -> ExprSide -> CExpression NodeInfo -> m Type
tExpr [StmtCtx]
c ExprSide
side CExpression NodeInfo
e
     forall (m :: * -> *) a.
MonadCError m =>
NodeInfo -> Either [Char] a -> m a
typeErrorOnLeft NodeInfo
ni forall a b. (a -> b) -> a -> b
$ Type -> Type -> Either [Char] ()
castCompatible Type
dt Type
et
     forall (m :: * -> *) a. Monad m => a -> m a
return Type
dt
tExpr' [StmtCtx]
c ExprSide
side (CSizeofExpr CExpression NodeInfo
e NodeInfo
ni)       =
  do forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ExprSide
side forall a. Eq a => a -> a -> Bool
== ExprSide
LValue) forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadCError m => NodeInfo -> [Char] -> m a
typeError NodeInfo
ni [Char]
"sizeof as lvalue"
     Type
_ <- forall (m :: * -> *).
MonadTrav m =>
[StmtCtx] -> ExprSide -> CExpression NodeInfo -> m Type
tExpr [StmtCtx]
c ExprSide
RValue CExpression NodeInfo
e
     forall (m :: * -> *) a. Monad m => a -> m a
return Type
size_tType
tExpr' [StmtCtx]
c ExprSide
side (CAlignofExpr CExpression NodeInfo
e NodeInfo
ni)      =
  do forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ExprSide
side forall a. Eq a => a -> a -> Bool
== ExprSide
LValue) forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadCError m => NodeInfo -> [Char] -> m a
typeError NodeInfo
ni [Char]
"alignof as lvalue"
     Type
_ <- forall (m :: * -> *).
MonadTrav m =>
[StmtCtx] -> ExprSide -> CExpression NodeInfo -> m Type
tExpr [StmtCtx]
c ExprSide
RValue CExpression NodeInfo
e
     forall (m :: * -> *) a. Monad m => a -> m a
return Type
size_tType
tExpr' [StmtCtx]
c ExprSide
side (CComplexReal CExpression NodeInfo
e NodeInfo
ni)      = 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)      = 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 forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ExprSide
side forall a. Eq a => a -> a -> Bool
== ExprSide
LValue) forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadCError m => NodeInfo -> [Char] -> m a
typeError NodeInfo
ni [Char]
"label address as lvalue"
     forall (m :: * -> *) a. Monad m => a -> m a
return 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 forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ExprSide
side forall a. Eq a => a -> a -> Bool
== ExprSide
LValue) forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadCError m => NodeInfo -> [Char] -> m a
typeError NodeInfo
ni [Char]
"compound literal as lvalue"
     Type
lt <- forall (m :: * -> *).
MonadTrav m =>
CDeclaration NodeInfo -> m Type
analyseTypeDecl CDeclaration NodeInfo
d
     forall (m :: * -> *).
MonadTrav m =>
NodeInfo -> Type -> CInitializerList NodeInfo -> m ()
tInitList NodeInfo
ni (Type -> Type
canonicalType Type
lt) CInitializerList NodeInfo
initList
     forall (m :: * -> *) a. Monad m => a -> m a
return Type
lt
tExpr' [StmtCtx]
_ ExprSide
RValue (CAlignofType CDeclaration NodeInfo
_ NodeInfo
_)     = forall (m :: * -> *) a. Monad m => a -> m a
return Type
size_tType
tExpr' [StmtCtx]
_ ExprSide
RValue (CSizeofType CDeclaration NodeInfo
_ NodeInfo
_)      = forall (m :: * -> *) a. Monad m => a -> m a
return Type
size_tType
tExpr' [StmtCtx]
_ ExprSide
LValue (CAlignofType CDeclaration NodeInfo
_ NodeInfo
ni)    =
  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)     =
  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 <- forall (m :: * -> *).
MonadTrav m =>
[StmtCtx] -> ExprSide -> CExpression NodeInfo -> m Type
tExpr [StmtCtx]
ctx ExprSide
side CExpression NodeInfo
expr
  [(Maybe Type, Type)]
ty_list <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM 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 forall a. (a -> Bool) -> [a] -> [a]
dropWhile (forall a. Maybe a -> Bool
isJust forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) [(Maybe Type, Type)]
ty_list of
      [(Maybe Type
Nothing,Type
tExpr'')] -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> Maybe a
Just Type
tExpr'')
      [] -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
      [(Maybe Type, Type)]
_ -> forall (m :: * -> *) a. MonadCError m => NodeInfo -> [Char] -> m a
astError NodeInfo
ni [Char]
"more than one default clause in generic selection"
  case forall a. (a -> Bool) -> [a] -> [a]
dropWhile (forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
True (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> Type -> Bool
typesMatch Type
ty_sel) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) [(Maybe Type, Type)]
ty_list of
    ((Maybe Type
_,Type
expr_ty) : [(Maybe Type, Type)]
_ ) -> forall (m :: * -> *) a. Monad m => a -> m a
return Type
expr_ty
    [] -> case Maybe Type
def_expr_ty of
      (Just Type
expr_ty) -> forall (m :: * -> *) a. Monad m => a -> m a
return Type
expr_ty
      Maybe Type
Nothing -> 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 " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show (forall p. Pretty p => p -> Doc
pretty Type
ty_sel) forall a. [a] -> [a] -> [a]
++
                              [Char]
", available types are " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show (forall a b. (a -> b) -> [a] -> [b]
map (forall p. Pretty p => p -> Doc
prettyforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall a. HasCallStack => Maybe a -> a
fromJustforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall a b. (a, b) -> a
fst) (forall a. (a -> Bool) -> [a] -> [a]
filter (forall a. Maybe a -> Bool
isJustforall b c a. (b -> c) -> (a -> b) -> a -> c
.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 <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall (m :: * -> *).
MonadTrav m =>
CDeclaration NodeInfo -> m Type
analyseTypeDecl t (CDeclaration NodeInfo)
mdecl
      Type
tExpr'' <- forall (m :: * -> *).
MonadTrav m =>
[StmtCtx] -> ExprSide -> CExpression NodeInfo -> m Type
tExpr [StmtCtx]
ctx ExprSide
side CExpression NodeInfo
expr'
      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 forall a. Eq a => a -> a -> Bool
== IntType
t2
    directTypesMatch (TyFloating FloatType
t1) (TyFloating FloatType
t2) = FloatType
t1 forall a. Eq a => a -> a -> Bool
== FloatType
t2
    directTypesMatch (TyComplex FloatType
t1) (TyComplex FloatType
t2) = FloatType
t1 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)              =
  forall (m :: * -> *).
(MonadCError m, MonadSymtab m) =>
Ident -> m (Maybe IdentDecl)
lookupObject Ident
i forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
  forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (m :: * -> *) a.
MonadCError m =>
NodeInfo -> Either [Char] a -> m a
typeErrorOnLeft NodeInfo
ni forall a b. (a -> b) -> a -> b
$ forall a. Ident -> Either [Char] a
notFound Ident
i) (forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall n. Declaration n => n -> Type
declType)
tExpr' [StmtCtx]
_ ExprSide
_ (CConst CConstant NodeInfo
c)                  = forall (m :: * -> *).
(MonadCError m, MonadName m) =>
CConstant NodeInfo -> m Type
constType CConstant NodeInfo
c
tExpr' [StmtCtx]
_ ExprSide
_ (CBuiltinExpr CBuiltinThing NodeInfo
b)            = 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 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 <- forall (m :: * -> *).
MonadTrav m =>
MachineDesc
-> Map Ident (CExpression NodeInfo)
-> CExpression NodeInfo
-> m (CExpression NodeInfo)
constEval MachineDesc
defaultMD forall k a. Map k a
Map.empty CExpression NodeInfo
g
           case CExpression NodeInfo -> Maybe Bool
boolValue CExpression NodeInfo
b of
             Just Bool
True -> forall (m :: * -> *).
MonadTrav m =>
[StmtCtx] -> ExprSide -> CExpression NodeInfo -> m Type
tExpr [StmtCtx]
c ExprSide
side CExpression NodeInfo
e1
             Just Bool
False -> forall (m :: * -> *).
MonadTrav m =>
[StmtCtx] -> ExprSide -> CExpression NodeInfo -> m Type
tExpr [StmtCtx]
c ExprSide
side CExpression NodeInfo
e2
             Maybe Bool
Nothing ->
               forall (m :: * -> *) a. MonadCError m => NodeInfo -> [Char] -> m a
astError NodeInfo
ni [Char]
"non-constant argument to __builtin_choose_expr"
      [CExpression NodeInfo]
_ -> 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 forall e (m :: * -> *). (Error e, MonadCError m) => e -> m ()
warn forall a b. (a -> b) -> a -> b
$ NodeInfo -> [Char] -> InvalidASTError
invalidAST NodeInfo
ni forall a b. (a -> b) -> a -> b
$
                                [Char]
"unknown function: " forall a. [a] -> [a] -> [a]
++ Ident -> [Char]
identToString Ident
i
                         forall (m :: * -> *) a. Monad m => a -> m a
return Type
defType
     Type
t <- case CExpression NodeInfo
fe of
            CVar Ident
i NodeInfo
_ -> forall (m :: * -> *).
(MonadCError m, MonadSymtab m) =>
Ident -> m (Maybe IdentDecl)
lookupObject Ident
i forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
                        forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall {m :: * -> *}. MonadCError m => Ident -> m Type
fallback Ident
i) (forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
MonadTrav m =>
[StmtCtx] -> ExprSide -> CExpression NodeInfo -> m Type
tExpr [StmtCtx]
c ExprSide
RValue CExpression NodeInfo
fe)
            CExpression NodeInfo
_ -> forall (m :: * -> *).
MonadTrav m =>
[StmtCtx] -> ExprSide -> CExpression NodeInfo -> m Type
tExpr [StmtCtx]
c ExprSide
RValue CExpression NodeInfo
fe
     [Type]
atys <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (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 = forall a b. (a -> b) -> [a] -> [b]
map forall n. Declaration n => n -> Type
declType [ParamDecl]
pdecls
            forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ forall {m :: * -> *} {a}.
(MonadCError m, MonadSymtab m, CNode a) =>
(Type, Type, a) -> m ()
checkArg forall a b. (a -> b) -> a -> b
$ forall a b c. [a] -> [b] -> [c] -> [(a, b, c)]
zip3 [Type]
ptys [Type]
atys [CExpression NodeInfo]
args
            forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
varargs forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall (t :: * -> *) a. Foldable t => t a -> Int
length [Type]
atys forall a. Eq a => a -> a -> Bool
/= forall (t :: * -> *) a. Foldable t => t a -> Int
length [Type]
ptys) forall a b. (a -> b) -> a -> b
$
                   forall (m :: * -> *) a. MonadCError m => NodeInfo -> [Char] -> m a
typeError NodeInfo
ni [Char]
"incorrect number of arguments"
            forall (m :: * -> *) a. Monad m => a -> m a
return 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"
            forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Type -> Type
canonicalType Type
rt
       Type
_  -> forall (m :: * -> *) a. MonadCError m => NodeInfo -> [Char] -> m a
typeError NodeInfo
ni forall a b. (a -> b) -> a -> b
$ [Char]
"attempt to call non-function of type " 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 <- 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 <- forall (m :: * -> *).
(MonadCError m, MonadSymtab m) =>
NodeInfo -> SUERef -> m TagDef
lookupSUE (forall a. CNode a => a -> NodeInfo
nodeInfo a
arg) (forall a. HasSUERef a => a -> SUERef
sueRef CompTypeRef
ctr)
                        [(Ident, Type)]
_ms <- forall (m :: * -> *).
(MonadCError m, MonadSymtab m) =>
NodeInfo -> TagDef -> m [(Ident, Type)]
tagMembers (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"
                        -}
                        forall (m :: * -> *) a. Monad m => a -> m a
return ()
                     -- where matches =
                     --         map (\d -> assignCompatible
                     --                    CAssignOp
                     --                    (snd d)
                     --                    aty
                     --             )
                   Type
_ -> forall (m :: * -> *) a. MonadCError m => NodeInfo -> [Char] -> m a
astError (forall a. CNode a => a -> NodeInfo
nodeInfo a
arg)
                        [Char]
"non-composite has __transparent_union__ attribute"
               else
                 forall (m :: * -> *).
MonadCError m =>
NodeInfo -> CAssignOp -> Type -> Type -> m ()
assignCompatible' (forall a. CNode a => a -> NodeInfo
nodeInfo a
arg) CAssignOp
CAssignOp Type
pty Type
aty
        isTransparentUnion :: Attributes -> Bool
isTransparentUnion =
          forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (\(Attr Ident
n [CExpression NodeInfo]
_ NodeInfo
_) -> Ident -> [Char]
identToString Ident
n 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 <- forall (m :: * -> *).
MonadTrav m =>
[StmtCtx] -> ExprSide -> CExpression NodeInfo -> m Type
tExpr [StmtCtx]
c ExprSide
LValue CExpression NodeInfo
le
     Type
rt <- forall (m :: * -> *).
MonadTrav m =>
[StmtCtx] -> ExprSide -> CExpression NodeInfo -> m Type
tExpr [StmtCtx]
c ExprSide
RValue CExpression NodeInfo
re
     forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (TypeQuals -> Bool
constant forall a b. (a -> b) -> a -> b
$ Type -> TypeQuals
typeQuals Type
lt) forall a b. (a -> b) -> a -> b
$
          forall (m :: * -> *) a. MonadCError m => NodeInfo -> [Char] -> m a
typeError NodeInfo
ni forall a b. (a -> b) -> a -> b
$ [Char]
"assignment to lvalue with `constant' qualifier: "
                         forall a. [a] -> [a] -> [a]
++ (Doc -> [Char]
render forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 forall a. Eq a => a -> a -> Bool
== Integer
0 -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
       (Type
_, CExpression NodeInfo
_) -> forall (m :: * -> *).
MonadCError m =>
NodeInfo -> CAssignOp -> Type -> Type -> m ()
assignCompatible' NodeInfo
ni CAssignOp
op Type
lt Type
rt
     forall (m :: * -> *) a. Monad m => a -> m a
return Type
lt
tExpr' [StmtCtx]
c ExprSide
_ (CStatExpr CStatement NodeInfo
s NodeInfo
_)             =
  do forall (m :: * -> *). MonadSymtab m => m ()
enterBlockScope
     forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (forall (m :: * -> *) a.
MonadSymtab m =>
(DefTable -> (a, DefTable)) -> m a
withDefTable 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 <- forall (m :: * -> *).
MonadTrav m =>
[StmtCtx] -> CStatement NodeInfo -> m Type
tStmt [StmtCtx]
c CStatement NodeInfo
s
     forall (m :: * -> *). MonadSymtab m => m ()
leaveBlockScope
     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
_)] =
  forall (m :: * -> *).
MonadTrav m =>
[StmtCtx] -> ExprSide -> CExpression NodeInfo -> m Type
tExpr [] ExprSide
RValue CExpression NodeInfo
e forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> 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 =
           forall a. a -> [a]
repeat (forall a. CExpression a -> a -> CPartDesignator a
CArrDesig (forall a. CConstant a -> CExpression a
CConst (forall a. CInteger -> a -> CConstant a
CIntConst (Integer -> CInteger
cInteger Integer
0) NodeInfo
ni)) NodeInfo
ni)
     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 <- forall (m :: * -> *).
(MonadCError m, MonadSymtab m) =>
NodeInfo -> SUERef -> m TagDef
lookupSUE NodeInfo
ni (forall a. HasSUERef a => a -> SUERef
sueRef CompTypeRef
ctr)
     [(Ident, Type)]
ms <- forall (m :: * -> *).
(MonadCError m, MonadSymtab m) =>
NodeInfo -> TagDef -> m [(Ident, Type)]
tagMembers NodeInfo
ni TagDef
td
     let default_ds :: [CPartDesignator NodeInfo]
default_ds = forall a b. (a -> b) -> [a] -> [b]
map (\(Ident, Type)
m -> forall a. Ident -> a -> CPartDesignator a
CMemberDesig (forall a b. (a, b) -> a
fst (Ident, Type)
m) NodeInfo
ni) [(Ident, Type)]
ms
     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
_ =
          forall (m :: * -> *) a. Monad m => a -> m a
return () -- XXX: more checking
tInitList NodeInfo
_ Type
t [([], CInit
i)] = forall (m :: * -> *) a. Monad m => m a -> m ()
voidMforall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). MonadTrav m => Type -> CInit -> m CInit
tInit Type
t CInit
i
tInitList NodeInfo
ni Type
t CInitializerList NodeInfo
_ = forall (m :: * -> *) a. MonadCError m => NodeInfo -> [Char] -> m a
typeError NodeInfo
ni forall a b. (a -> b) -> a -> b
$ [Char]
"initializer list for type: " 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]
_ [] = 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
                      ([], []) ->
                        forall (m :: * -> *) a. MonadCError m => NodeInfo -> [Char] -> m a
typeError (forall a. CNode a => a -> NodeInfo
nodeInfo CInit
i) [Char]
"excess elements in initializer"
                      (CPartDesignator NodeInfo
dd' : [CPartDesignator NodeInfo]
rest, []) -> forall (m :: * -> *) a. Monad m => a -> m a
return ([CPartDesignator NodeInfo]
rest, [CPartDesignator NodeInfo
dd'])
                      ([CPartDesignator NodeInfo]
_, CPartDesignator NodeInfo
d : [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' <- forall (m :: * -> *).
MonadTrav m =>
Type -> [CPartDesignator NodeInfo] -> m Type
tDesignator Type
t [CPartDesignator NodeInfo]
ds'
     CInit
_ <- forall (m :: * -> *). MonadTrav m => Type -> CInit -> m CInit
tInit Type
t' CInit
i
     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 = forall a. Int -> [a] -> [a]
drop Int
1 forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> [a] -> [a]
dropWhile (Bool -> Bool
not 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 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 forall (m :: * -> *).
MonadTrav m =>
[StmtCtx] -> ExprSide -> CExpression NodeInfo -> m Type
tExpr [] ExprSide
RValue CExpression NodeInfo
e forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *). MonadCError m => NodeInfo -> Type -> m ()
checkIntegral' NodeInfo
ni
     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 forall (m :: * -> *).
MonadTrav m =>
[StmtCtx] -> ExprSide -> CExpression NodeInfo -> m Type
tExpr [] ExprSide
RValue CExpression NodeInfo
e1 forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *). MonadCError m => NodeInfo -> Type -> m ()
checkIntegral' NodeInfo
ni
     forall (m :: * -> *).
MonadTrav m =>
[StmtCtx] -> ExprSide -> CExpression NodeInfo -> m Type
tExpr [] ExprSide
RValue CExpression NodeInfo
e2 forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *). MonadCError m => NodeInfo -> Type -> m ()
checkIntegral' NodeInfo
ni
     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]
_) =
  forall (m :: * -> *) a. MonadCError m => NodeInfo -> [Char] -> m a
typeError (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 <- forall (m :: * -> *).
(MonadCError m, MonadSymtab m) =>
NodeInfo -> Ident -> Type -> m Type
fieldType NodeInfo
ni Ident
m Type
t
     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]
_) =
  forall (m :: * -> *) a. MonadCError m => NodeInfo -> [Char] -> m a
typeError (forall a. CNode a => a -> NodeInfo
nodeInfo CPartDesignator NodeInfo
d) [Char]
"array designator in compound initializer"
tDesignator Type
t [] = forall (m :: * -> *) a. Monad m => a -> m a
return Type
t
tDesignator Type
_t [CPartDesignator NodeInfo]
_ =
  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 <- forall (m :: * -> *).
MonadTrav m =>
[StmtCtx] -> ExprSide -> CExpression NodeInfo -> m Type
tExpr [] ExprSide
RValue CExpression NodeInfo
e
     forall (m :: * -> *).
MonadCError m =>
NodeInfo -> CAssignOp -> Type -> Type -> m ()
assignCompatible' NodeInfo
ni CAssignOp
CAssignOp Type
t Type
it
     forall (m :: * -> *) a. Monad m => a -> m a
return CInit
i
tInit Type
t i :: CInit
i@(CInitList CInitializerList NodeInfo
initList NodeInfo
ni) =
  forall (m :: * -> *).
MonadTrav m =>
NodeInfo -> Type -> CInitializerList NodeInfo -> m ()
tInitList NodeInfo
ni (Type -> Type
canonicalType Type
t) CInitializerList NodeInfo
initList forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> 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 <- 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 ->
         forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ TypeName -> TypeQuals -> Attributes -> Type
DirectType (FloatType -> TypeName
TyFloating FloatType
ft) TypeQuals
quals Attributes
attrs
       Type
_ -> forall (m :: * -> *) a. MonadCError m => NodeInfo -> [Char] -> m a
typeError NodeInfo
ni forall a b. (a -> b) -> a -> b
$ [Char]
"expected complex type, got: " 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
_)           = forall (m :: * -> *).
MonadTrav m =>
CDeclaration NodeInfo -> m Type
analyseTypeDecl CDeclaration NodeInfo
d
builtinType (CBuiltinOffsetOf CDeclaration NodeInfo
_ [CPartDesignator NodeInfo]
_ NodeInfo
_)        = forall (m :: * -> *) a. Monad m => a -> m a
return Type
size_tType
builtinType (CBuiltinTypesCompatible CDeclaration NodeInfo
_ CDeclaration NodeInfo
_ NodeInfo
_) = forall (m :: * -> *) a. Monad m => a -> m a
return Type
boolType
builtinType (CBuiltinConvertVector CExpression NodeInfo
_expr CDeclaration NodeInfo
ty NodeInfo
_) = 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 forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr forall {a}.
CDeclarationSpecifier a
-> (Bool, [CDeclarationSpecifier a])
-> (Bool, [CDeclarationSpecifier a])
hasTypeDefSpec (Bool
False,[]) [CDeclarationSpecifier NodeInfo]
declspecs of
        (Bool
True,[CDeclarationSpecifier NodeInfo]
specs') -> forall a. a -> Maybe a
Just [CDeclarationSpecifier NodeInfo]
specs'
        (Bool
False,[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
specforall a. a -> [a] -> [a]
:[CDeclarationSpecifier a]
specs)