{-# LANGUAGE ScopedTypeVariables, PatternGuards #-}
-----------------------------------------------------------------------------
-- |
-- Module      :  Language.C.Parser.Translation
-- Copyright   :  (c) 2008 Benedikt Huber
-- License     :  BSD-style
-- Maintainer  :  benedikt.huber@gmail.com
-- Stability   :  alpha
-- Portability :  ghc
--
-- Analyse the parse tree
--
-- Traverses the AST, analyses declarations and invokes handlers.
-----------------------------------------------------------------------------
module Language.C.Analysis.AstAnalysis (
    -- * Top-level analysis
    analyseAST,
    analyseExt,analyseFunDef,analyseDecl,
    -- * Building blocks for additional analyses
    analyseFunctionBody,
    defineParams,
    -- * Type checking
    tExpr, ExprSide(..),
    tStmt, StmtCtx(..),
    tDesignator,
    defaultMD
)
where
import Language.C.Analysis.SemError
import Language.C.Analysis.SemRep
import Language.C.Analysis.TravMonad
import Language.C.Analysis.ConstEval
import Language.C.Analysis.DefTable (globalDefs, defineLabel, inFileScope,
                                     lookupLabel, insertType, lookupType)
import Language.C.Analysis.DeclAnalysis
import Language.C.Analysis.TypeUtils
import Language.C.Analysis.TypeCheck

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


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

-- * analysis

-- | Analyse the given AST
--
-- @analyseAST ast@ results in global declaration dictionaries.
-- If you want to perform specific actions on declarations or definitions, you may provide
-- callbacks in the @MonadTrav@ @m@.
--
-- Returns the set of global declarations and definitions which where successfully translated.
-- It is the users responsibility to check whether any hard errors occurred (@runTrav@ does this for you).
analyseAST :: (MonadTrav m) => CTranslUnit -> m GlobalDecls
analyseAST :: CTranslUnit -> m GlobalDecls
analyseAST (CTranslUnit decls :: [CExternalDeclaration NodeInfo]
decls _file_node :: NodeInfo
_file_node) = do
    -- analyse all declarations, but recover from errors
    (CExternalDeclaration NodeInfo -> m ())
-> [CExternalDeclaration NodeInfo] -> m ()
forall (t :: * -> *) (m :: * -> *) a a.
(Foldable t, MonadCError m) =>
(a -> m a) -> t a -> m ()
mapRecoverM_ CExternalDeclaration NodeInfo -> m ()
forall (m :: * -> *).
MonadTrav m =>
CExternalDeclaration NodeInfo -> m ()
analyseExt [CExternalDeclaration NodeInfo]
decls
    -- check we are in global scope afterwards
    m DefTable
forall (m :: * -> *). MonadSymtab m => m DefTable
getDefTable m DefTable -> (DefTable -> m ()) -> m ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \dt :: DefTable
dt -> Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (DefTable -> Bool
inFileScope DefTable
dt) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
        [Char] -> m ()
forall a. HasCallStack => [Char] -> a
error "Internal Error: Not in filescope after analysis"
    -- get the global definition table (XXX: remove ?)
    (DefTable -> GlobalDecls) -> m DefTable -> m GlobalDecls
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM DefTable -> GlobalDecls
globalDefs m DefTable
forall (m :: * -> *). MonadSymtab m => m DefTable
getDefTable
    where
    mapRecoverM_ :: (a -> m a) -> t a -> m ()
mapRecoverM_ f :: a -> m a
f = (a -> m (Maybe a)) -> t a -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (m a -> m (Maybe a)
forall (m :: * -> *) a. MonadCError m => m a -> m (Maybe a)
handleTravError (m a -> m (Maybe a)) -> (a -> m a) -> a -> m (Maybe a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> m a
f)

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

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

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

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

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

-- | Analyse a typedef
analyseTypeDef :: (MonadTrav m) => Bool -> [CDeclSpec] -> CDeclr -> NodeInfo -> m ()
analyseTypeDef :: Bool
-> [CDeclarationSpecifier NodeInfo]
-> CDeclarator NodeInfo
-> NodeInfo
-> m ()
analyseTypeDef handle_sue_def :: Bool
handle_sue_def declspecs :: [CDeclarationSpecifier NodeInfo]
declspecs declr :: CDeclarator NodeInfo
declr node_info :: NodeInfo
node_info = do
    -- analyse the declarator
    (VarDeclInfo name :: VarName
name fun_attrs :: FunctionAttrs
fun_attrs storage_spec :: StorageSpec
storage_spec attrs :: Attributes
attrs ty :: Type
ty _node :: NodeInfo
_node) <- Bool
-> [CDeclarationSpecifier NodeInfo]
-> CDeclarator NodeInfo
-> [CDeclaration NodeInfo]
-> Maybe CInit
-> m VarDeclInfo
forall (m :: * -> *).
MonadTrav m =>
Bool
-> [CDeclarationSpecifier NodeInfo]
-> CDeclarator NodeInfo
-> [CDeclaration NodeInfo]
-> Maybe CInit
-> m VarDeclInfo
analyseVarDecl' Bool
handle_sue_def [CDeclarationSpecifier NodeInfo]
declspecs CDeclarator NodeInfo
declr [] Maybe CInit
forall a. Maybe a
Nothing
    FunctionAttrs -> StorageSpec -> Attributes -> m ()
forall (m :: * -> *) p.
MonadCError m =>
FunctionAttrs -> StorageSpec -> p -> m ()
checkValidTypeDef FunctionAttrs
fun_attrs StorageSpec
storage_spec Attributes
attrs
    Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (VarName -> Bool
isNoName VarName
name) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ NodeInfo -> [Char] -> m ()
forall (m :: * -> *) a. MonadCError m => NodeInfo -> [Char] -> m a
astError NodeInfo
node_info "NoName in analyseTypeDef"
    let ident :: Ident
ident = VarName -> Ident
identOfVarName VarName
name
    TypeDef -> m ()
forall (m :: * -> *). MonadTrav m => TypeDef -> m ()
handleTypeDef (Ident -> Type -> Attributes -> NodeInfo -> TypeDef
TypeDef Ident
ident Type
ty Attributes
attrs NodeInfo
node_info)
    where
    checkValidTypeDef :: FunctionAttrs -> StorageSpec -> p -> m ()
checkValidTypeDef fun_attrs :: FunctionAttrs
fun_attrs  _ _ | FunctionAttrs
fun_attrs FunctionAttrs -> FunctionAttrs -> Bool
forall a. Eq a => a -> a -> Bool
/= FunctionAttrs
noFunctionAttrs =
                                         NodeInfo -> [Char] -> m ()
forall (m :: * -> *) a. MonadCError m => NodeInfo -> [Char] -> m a
astError NodeInfo
node_info "inline specifier for typeDef"
    checkValidTypeDef _ NoStorageSpec _ = () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    checkValidTypeDef _ bad_storage :: StorageSpec
bad_storage _ = NodeInfo -> [Char] -> m ()
forall (m :: * -> *) a. MonadCError m => NodeInfo -> [Char] -> m a
astError NodeInfo
node_info ([Char] -> m ()) -> [Char] -> m ()
forall a b. (a -> b) -> a -> b
$ "storage specified for typeDef: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ StorageSpec -> [Char]
forall a. Show a => a -> [Char]
show StorageSpec
bad_storage

-- | compute storage of a function definition
--
-- a function definition has static storage with internal linkage if specified `static`,
-- the previously declared linkage if any if 'extern' or no specifier are present. (See C99 6.2.2, clause 5)
--
-- This function won't raise an Trav error if the declaration is incompatible with the existing one,
-- this case is handled in 'handleFunDef'.
computeFunDefStorage :: (MonadTrav m) => Ident -> StorageSpec -> m Storage
computeFunDefStorage :: Ident -> StorageSpec -> m Storage
computeFunDefStorage _ (StaticSpec _)  = Storage -> m Storage
forall (m :: * -> *) a. Monad m => a -> m a
return(Storage -> m Storage) -> Storage -> m Storage
forall a b. (a -> b) -> a -> b
$ Linkage -> Storage
FunLinkage Linkage
InternalLinkage
computeFunDefStorage ident :: Ident
ident other_spec :: StorageSpec
other_spec  = do
  Maybe IdentDecl
obj_opt <- Ident -> m (Maybe IdentDecl)
forall (m :: * -> *).
(MonadCError m, MonadSymtab m) =>
Ident -> m (Maybe IdentDecl)
lookupObject Ident
ident
  let defaultSpec :: Storage
defaultSpec = Linkage -> Storage
FunLinkage Linkage
ExternalLinkage
  case StorageSpec
other_spec of
    NoStorageSpec  -> Storage -> m Storage
forall (m :: * -> *) a. Monad m => a -> m a
return(Storage -> m Storage) -> Storage -> m Storage
forall a b. (a -> b) -> a -> b
$ Storage -> (IdentDecl -> Storage) -> Maybe IdentDecl -> Storage
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Storage
defaultSpec IdentDecl -> Storage
forall d. Declaration d => d -> Storage
declStorage Maybe IdentDecl
obj_opt
    ClKernelSpec  -> Storage -> m Storage
forall (m :: * -> *) a. Monad m => a -> m a
return(Storage -> m Storage) -> Storage -> m Storage
forall a b. (a -> b) -> a -> b
$ Storage -> (IdentDecl -> Storage) -> Maybe IdentDecl -> Storage
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Storage
defaultSpec IdentDecl -> Storage
forall d. Declaration d => d -> Storage
declStorage Maybe IdentDecl
obj_opt
    (ExternSpec False) -> Storage -> m Storage
forall (m :: * -> *) a. Monad m => a -> m a
return(Storage -> m Storage) -> Storage -> m Storage
forall a b. (a -> b) -> a -> b
$ Storage -> (IdentDecl -> Storage) -> Maybe IdentDecl -> Storage
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Storage
defaultSpec IdentDecl -> Storage
forall d. Declaration d => d -> Storage
declStorage Maybe IdentDecl
obj_opt
    bad_spec :: StorageSpec
bad_spec -> BadSpecifierError -> m Storage
forall (m :: * -> *) e a. (MonadCError m, Error e) => e -> m a
throwTravError (BadSpecifierError -> m Storage) -> BadSpecifierError -> m Storage
forall a b. (a -> b) -> a -> b
$ NodeInfo -> [Char] -> BadSpecifierError
badSpecifierError (Ident -> NodeInfo
forall a. CNode a => a -> NodeInfo
nodeInfo Ident
ident)
                  ([Char] -> BadSpecifierError) -> [Char] -> BadSpecifierError
forall a b. (a -> b) -> a -> b
$ "unexpected function storage specifier (only static or extern is allowed)" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ StorageSpec -> [Char]
forall a. Show a => a -> [Char]
show StorageSpec
bad_spec

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

-- | handle a function prototype
extFunProto :: (MonadTrav m) => VarDeclInfo -> m ()
extFunProto :: VarDeclInfo -> m ()
extFunProto (VarDeclInfo var_name :: VarName
var_name fun_spec :: FunctionAttrs
fun_spec storage_spec :: StorageSpec
storage_spec attrs :: Attributes
attrs ty :: Type
ty node_info :: NodeInfo
node_info) =
    do  Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (VarName -> Bool
isNoName VarName
var_name) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ NodeInfo -> [Char] -> m ()
forall (m :: * -> *) a. MonadCError m => NodeInfo -> [Char] -> m a
astError NodeInfo
node_info "NoName in extFunProto"
        Maybe IdentDecl
old_fun <- Ident -> m (Maybe IdentDecl)
forall (m :: * -> *).
(MonadCError m, MonadSymtab m) =>
Ident -> m (Maybe IdentDecl)
lookupObject (VarName -> Ident
identOfVarName VarName
var_name)
        m ()
checkValidSpecs
        let decl :: VarDecl
decl = VarName -> DeclAttrs -> Type -> VarDecl
VarDecl VarName
var_name (FunctionAttrs -> Storage -> Attributes -> DeclAttrs
DeclAttrs FunctionAttrs
fun_spec (Maybe IdentDecl -> Storage
forall d. Declaration d => Maybe d -> Storage
funDeclLinkage Maybe IdentDecl
old_fun) Attributes
attrs) Type
ty
        Bool -> Decl -> m ()
forall (m :: * -> *). MonadTrav m => Bool -> Decl -> m ()
handleVarDecl Bool
False (VarDecl -> NodeInfo -> Decl
Decl VarDecl
decl NodeInfo
node_info)
        -- XXX: structs should be handled in 'function prototype scope' too
        m ()
forall (m :: * -> *). MonadSymtab m => m ()
enterPrototypeScope
        m () -> ([ParamDecl] -> m ()) -> Maybe [ParamDecl] -> m ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (() -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()) ((ParamDecl -> m ()) -> [ParamDecl] -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ParamDecl -> m ()
forall (m :: * -> *). MonadTrav m => ParamDecl -> m ()
handleParamDecl) (Type -> Maybe [ParamDecl]
getParams Type
ty)
        m ()
forall (m :: * -> *). MonadSymtab m => m ()
leavePrototypeScope
    where
    funDeclLinkage :: Maybe d -> Storage
funDeclLinkage old_fun :: Maybe d
old_fun =
        case StorageSpec
storage_spec of
            NoStorageSpec    -> Linkage -> Storage
FunLinkage Linkage
ExternalLinkage -- prototype declaration / external linkage
            StaticSpec False -> Linkage -> Storage
FunLinkage Linkage
InternalLinkage -- prototype declaration / internal linkage
            ExternSpec False -> case Maybe d
old_fun of
                                    Nothing -> Linkage -> Storage
FunLinkage Linkage
ExternalLinkage
                                    Just f :: d
f  -> d -> Storage
forall d. Declaration d => d -> Storage
declStorage d
f
            _ -> [Char] -> Storage
forall a. HasCallStack => [Char] -> a
error ([Char] -> Storage) -> [Char] -> Storage
forall a b. (a -> b) -> a -> b
$ "funDeclLinkage: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ StorageSpec -> [Char]
forall a. Show a => a -> [Char]
show StorageSpec
storage_spec
    checkValidSpecs :: m ()
checkValidSpecs
        | StorageSpec -> Bool
hasThreadLocalSpec StorageSpec
storage_spec = NodeInfo -> [Char] -> m ()
forall (m :: * -> *) a. MonadCError m => NodeInfo -> [Char] -> m a
astError NodeInfo
node_info "thread local storage specified for function"
        | StorageSpec
RegSpec <- StorageSpec
storage_spec         = NodeInfo -> [Char] -> m ()
forall (m :: * -> *) a. MonadCError m => NodeInfo -> [Char] -> m a
astError NodeInfo
node_info "invalid `register' storage specified for function"
        | Bool
otherwise                       = () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

-- | handle a object declaration \/ definition
--
-- We have to check the storage specifiers here, as they determine wheter we're dealing with decalartions
-- or definitions
-- see [http://www.sivity.net/projects/language.c/wiki/ExternalDefinitions]
extVarDecl :: (MonadTrav m) => VarDeclInfo -> Maybe Initializer -> m ()
extVarDecl :: VarDeclInfo -> Maybe CInit -> m ()
extVarDecl (VarDeclInfo var_name :: VarName
var_name fun_spec :: FunctionAttrs
fun_spec storage_spec :: StorageSpec
storage_spec attrs :: Attributes
attrs typ :: Type
typ node_info :: NodeInfo
node_info) init_opt :: Maybe CInit
init_opt =
    do Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (VarName -> Bool
isNoName VarName
var_name) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ NodeInfo -> [Char] -> m ()
forall (m :: * -> *) a. MonadCError m => NodeInfo -> [Char] -> m a
astError NodeInfo
node_info "NoName in extVarDecl"
       (storage :: Storage
storage,is_def :: Bool
is_def) <- StorageSpec -> m (Storage, Bool)
forall (m :: * -> *).
(MonadCError m, MonadSymtab m) =>
StorageSpec -> m (Storage, Bool)
globalStorage StorageSpec
storage_spec
       let vardecl :: VarDecl
vardecl = VarName -> DeclAttrs -> Type -> VarDecl
VarDecl VarName
var_name (FunctionAttrs -> Storage -> Attributes -> DeclAttrs
DeclAttrs FunctionAttrs
fun_spec Storage
storage Attributes
attrs) Type
typ
       if Bool
is_def
           then Bool -> Ident -> ObjDef -> m ()
forall (m :: * -> *).
MonadTrav m =>
Bool -> Ident -> ObjDef -> m ()
handleObjectDef Bool
False Ident
ident (ObjDef -> m ()) -> ObjDef -> m ()
forall a b. (a -> b) -> a -> b
$ VarDecl -> Maybe CInit -> NodeInfo -> ObjDef
ObjDef VarDecl
vardecl Maybe CInit
init_opt NodeInfo
node_info
           else Bool -> Decl -> m ()
forall (m :: * -> *). MonadTrav m => Bool -> Decl -> m ()
handleVarDecl Bool
False (Decl -> m ()) -> Decl -> m ()
forall a b. (a -> b) -> a -> b
$ VarDecl -> NodeInfo -> Decl
Decl VarDecl
vardecl NodeInfo
node_info
    where
       ident :: Ident
ident = VarName -> Ident
identOfVarName VarName
var_name
       globalStorage :: StorageSpec -> m (Storage, Bool)
globalStorage _ | FunctionAttrs
fun_spec FunctionAttrs -> FunctionAttrs -> Bool
forall a. Eq a => a -> a -> Bool
/= FunctionAttrs
noFunctionAttrs =
                           NodeInfo -> [Char] -> m (Storage, Bool)
forall (m :: * -> *) a. MonadCError m => NodeInfo -> [Char] -> m a
astError NodeInfo
node_info "invalid function specifier for external variable"
       globalStorage AutoSpec      = NodeInfo -> [Char] -> m (Storage, Bool)
forall (m :: * -> *) a. MonadCError m => NodeInfo -> [Char] -> m a
astError NodeInfo
node_info "file-scope declaration specifies storage `auto'"
       globalStorage RegSpec       =
         do Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Maybe CInit -> Bool
forall a. Maybe a -> Bool
isJust Maybe CInit
init_opt) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ NodeInfo -> [Char] -> m ()
forall (m :: * -> *) a. MonadCError m => NodeInfo -> [Char] -> m a
astError NodeInfo
node_info "initializer given for global register variable"
            case VarName
var_name of
              NoName -> NodeInfo -> [Char] -> m ()
forall (m :: * -> *) a. MonadCError m => NodeInfo -> [Char] -> m a
astError NodeInfo
node_info "global register variable has no name"
              VarName _ Nothing -> NodeInfo -> [Char] -> m ()
forall (m :: * -> *) a. MonadCError m => NodeInfo -> [Char] -> m a
astError NodeInfo
node_info "no register specified for global register variable"
              _ -> () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
            DefTable
dt <- m DefTable
forall (m :: * -> *). MonadSymtab m => m DefTable
getDefTable
            Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (DefTable -> Bool
hasFunDef DefTable
dt) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ NodeInfo -> [Char] -> m ()
forall (m :: * -> *) a. MonadCError m => NodeInfo -> [Char] -> m a
astError NodeInfo
node_info "global register variable appears after a function definition"
            (Storage, Bool) -> m (Storage, Bool)
forall (m :: * -> *) a. Monad m => a -> m a
return (Linkage -> Bool -> Storage
Static Linkage
InternalLinkage Bool
False, Bool
False)
       -- tentative if there is no initializer, external
       globalStorage NoStorageSpec = (Storage, Bool) -> m (Storage, Bool)
forall (m :: * -> *) a. Monad m => a -> m a
return (Linkage -> Bool -> Storage
Static Linkage
ExternalLinkage Bool
False, Bool
True)
       globalStorage ThreadSpec    = (Storage, Bool) -> m (Storage, Bool)
forall (m :: * -> *) a. Monad m => a -> m a
return (Linkage -> Bool -> Storage
Static Linkage
ExternalLinkage Bool
True, Bool
True)
       -- tentative if there is no initializer, internal
       globalStorage (StaticSpec thread_local :: Bool
thread_local) = (Storage, Bool) -> m (Storage, Bool)
forall (m :: * -> *) a. Monad m => a -> m a
return (Linkage -> Bool -> Storage
Static Linkage
InternalLinkage Bool
thread_local, Bool
True)
       globalStorage (ExternSpec thread_local :: Bool
thread_local) =
           case Maybe CInit
init_opt of
               -- declaration with either external or old storage
               Nothing -> do Maybe IdentDecl
old_decl <- Ident -> m (Maybe IdentDecl)
forall (m :: * -> *).
(MonadCError m, MonadSymtab m) =>
Ident -> m (Maybe IdentDecl)
lookupObject Ident
ident
                             (Storage, Bool) -> m (Storage, Bool)
forall (m :: * -> *) a. Monad m => a -> m a
return (Storage -> (IdentDecl -> Storage) -> Maybe IdentDecl -> Storage
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Linkage -> Bool -> Storage
Static Linkage
ExternalLinkage Bool
thread_local) IdentDecl -> Storage
forall d. Declaration d => d -> Storage
declStorage Maybe IdentDecl
old_decl,Bool
False)
               -- warning, external definition
               Just _  -> do BadSpecifierError -> m ()
forall e (m :: * -> *). (Error e, MonadCError m) => e -> m ()
warn (BadSpecifierError -> m ()) -> BadSpecifierError -> m ()
forall a b. (a -> b) -> a -> b
$ NodeInfo -> [Char] -> BadSpecifierError
badSpecifierError NodeInfo
node_info "Both initializer and `extern` specifier given - treating as definition"
                             (Storage, Bool) -> m (Storage, Bool)
forall (m :: * -> *) a. Monad m => a -> m a
return (Linkage -> Bool -> Storage
Static Linkage
ExternalLinkage Bool
thread_local, Bool
True)
       hasFunDef :: DefTable -> Bool
hasFunDef dt :: DefTable
dt = ((Ident, IdentDecl) -> Bool) -> [(Ident, IdentDecl)] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (IdentDecl -> Bool
isFuncDef (IdentDecl -> Bool)
-> ((Ident, IdentDecl) -> IdentDecl) -> (Ident, IdentDecl) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Ident, IdentDecl) -> IdentDecl
forall a b. (a, b) -> b
snd) (Map Ident IdentDecl -> [(Ident, IdentDecl)]
forall k a. Map k a -> [(k, a)]
Map.toList (Map Ident IdentDecl -> [(Ident, IdentDecl)])
-> Map Ident IdentDecl -> [(Ident, IdentDecl)]
forall a b. (a -> b) -> a -> b
$ GlobalDecls -> Map Ident IdentDecl
gObjs (GlobalDecls -> Map Ident IdentDecl)
-> GlobalDecls -> Map Ident IdentDecl
forall a b. (a -> b) -> a -> b
$ DefTable -> GlobalDecls
globalDefs DefTable
dt)
       isFuncDef :: IdentDecl -> Bool
isFuncDef (FunctionDef fd :: FunDef
fd) = Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ (FunctionAttrs -> Bool
isInline (FunctionAttrs -> Bool)
-> (FunDef -> FunctionAttrs) -> FunDef -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FunDef -> FunctionAttrs
forall d. Declaration d => d -> FunctionAttrs
functionAttrs) FunDef
fd
       isFuncDef _ = 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 :: VarDeclInfo -> Maybe CInit -> m ()
localVarDecl (VarDeclInfo var_name :: VarName
var_name fun_attrs :: FunctionAttrs
fun_attrs storage_spec :: StorageSpec
storage_spec attrs :: Attributes
attrs typ :: Type
typ node_info :: NodeInfo
node_info) init_opt :: Maybe CInit
init_opt =
    do Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (VarName -> Bool
isNoName VarName
var_name) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ NodeInfo -> [Char] -> m ()
forall (m :: * -> *) a. MonadCError m => NodeInfo -> [Char] -> m a
astError NodeInfo
node_info "NoName in localVarDecl"
       (storage :: Storage
storage,is_def :: Bool
is_def) <- StorageSpec -> m (Storage, Bool)
forall (m :: * -> *).
(MonadCError m, MonadSymtab m) =>
StorageSpec -> m (Storage, Bool)
localStorage StorageSpec
storage_spec
       let vardecl :: VarDecl
vardecl = VarName -> DeclAttrs -> Type -> VarDecl
VarDecl VarName
var_name (FunctionAttrs -> Storage -> Attributes -> DeclAttrs
DeclAttrs FunctionAttrs
fun_attrs Storage
storage Attributes
attrs) Type
typ
       if Bool
is_def
           then Bool -> Ident -> ObjDef -> m ()
forall (m :: * -> *).
MonadTrav m =>
Bool -> Ident -> ObjDef -> m ()
handleObjectDef Bool
True Ident
ident (VarDecl -> Maybe CInit -> NodeInfo -> ObjDef
ObjDef VarDecl
vardecl Maybe CInit
init_opt NodeInfo
node_info)
           else Bool -> Decl -> m ()
forall (m :: * -> *). MonadTrav m => Bool -> Decl -> m ()
handleVarDecl Bool
True (VarDecl -> NodeInfo -> Decl
Decl VarDecl
vardecl NodeInfo
node_info)
    where
    ident :: Ident
ident = VarName -> Ident
identOfVarName VarName
var_name
    localStorage :: StorageSpec -> m (Storage, Bool)
localStorage NoStorageSpec = (Storage, Bool) -> m (Storage, Bool)
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> Storage
Auto Bool
False,Bool
True)
    localStorage ThreadSpec    = (Storage, Bool) -> m (Storage, Bool)
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> Storage
Auto Bool
True,Bool
True)
    localStorage RegSpec = (Storage, Bool) -> m (Storage, Bool)
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> Storage
Auto Bool
True,Bool
True)
    -- static no linkage
    localStorage (StaticSpec thread_local :: Bool
thread_local) =
      (Storage, Bool) -> m (Storage, Bool)
forall (m :: * -> *) a. Monad m => a -> m a
return (Linkage -> Bool -> Storage
Static Linkage
NoLinkage Bool
thread_local,Bool
True)
    localStorage (ExternSpec thread_local :: Bool
thread_local)
      | Maybe CInit -> Bool
forall a. Maybe a -> Bool
isJust Maybe CInit
init_opt = NodeInfo -> [Char] -> m (Storage, Bool)
forall (m :: * -> *) a. MonadCError m => NodeInfo -> [Char] -> m a
astError NodeInfo
node_info "extern keyword and initializer for local"
      | Bool
otherwise =
          do Maybe IdentDecl
old_decl <- Ident -> m (Maybe IdentDecl)
forall (m :: * -> *).
(MonadCError m, MonadSymtab m) =>
Ident -> m (Maybe IdentDecl)
lookupObject Ident
ident
             (Storage, Bool) -> m (Storage, Bool)
forall (m :: * -> *) a. Monad m => a -> m a
return (Storage -> (IdentDecl -> Storage) -> Maybe IdentDecl -> Storage
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Linkage -> Bool -> Storage
Static Linkage
ExternalLinkage Bool
thread_local) IdentDecl -> Storage
forall d. Declaration d => d -> Storage
declStorage Maybe IdentDecl
old_decl,Bool
False)
    localStorage _ = NodeInfo -> [Char] -> m (Storage, Bool)
forall (m :: * -> *) a. MonadCError m => NodeInfo -> [Char] -> m a
astError NodeInfo
node_info "bad storage specifier for local"

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

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

analyseFunctionBody _ _ s :: CStatement NodeInfo
s = NodeInfo -> [Char] -> m (CStatement NodeInfo)
forall (m :: * -> *) a. MonadCError m => NodeInfo -> [Char] -> m a
astError (CStatement NodeInfo -> NodeInfo
forall a. CNode a => a -> NodeInfo
nodeInfo CStatement NodeInfo
s) "Function body is no compound statement"

data StmtCtx = FunCtx VarDecl
             | LoopCtx
             | SwitchCtx

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

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

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

data ExprSide = LValue | RValue
                deriving (ExprSide -> ExprSide -> Bool
(ExprSide -> ExprSide -> Bool)
-> (ExprSide -> ExprSide -> Bool) -> Eq ExprSide
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ExprSide -> ExprSide -> Bool
$c/= :: ExprSide -> ExprSide -> Bool
== :: ExprSide -> ExprSide -> Bool
$c== :: ExprSide -> ExprSide -> Bool
Eq, Int -> ExprSide -> [Char] -> [Char]
[ExprSide] -> [Char] -> [Char]
ExprSide -> [Char]
(Int -> ExprSide -> [Char] -> [Char])
-> (ExprSide -> [Char])
-> ([ExprSide] -> [Char] -> [Char])
-> Show ExprSide
forall a.
(Int -> a -> [Char] -> [Char])
-> (a -> [Char]) -> ([a] -> [Char] -> [Char]) -> Show a
showList :: [ExprSide] -> [Char] -> [Char]
$cshowList :: [ExprSide] -> [Char] -> [Char]
show :: ExprSide -> [Char]
$cshow :: ExprSide -> [Char]
showsPrec :: Int -> ExprSide -> [Char] -> [Char]
$cshowsPrec :: Int -> ExprSide -> [Char] -> [Char]
Show)

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

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

checkGuard :: MonadTrav m => [StmtCtx] -> CExpr -> m ()
checkGuard :: [StmtCtx] -> CExpression NodeInfo -> m ()
checkGuard c :: [StmtCtx]
c e :: CExpression NodeInfo
e = [StmtCtx] -> ExprSide -> CExpression NodeInfo -> m Type
forall (m :: * -> *).
MonadTrav m =>
[StmtCtx] -> ExprSide -> CExpression NodeInfo -> m Type
tExpr [StmtCtx]
c ExprSide
RValue CExpression NodeInfo
e m Type -> (Type -> m ()) -> m ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= NodeInfo -> Type -> m ()
forall (m :: * -> *). MonadCError m => NodeInfo -> Type -> m ()
checkScalar' (CExpression NodeInfo -> NodeInfo
forall a. CNode a => a -> NodeInfo
nodeInfo CExpression NodeInfo
e)

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

tExpr :: MonadTrav m => [StmtCtx] -> ExprSide -> CExpr -> m Type
tExpr :: [StmtCtx] -> ExprSide -> CExpression NodeInfo -> m Type
tExpr c :: [StmtCtx]
c side :: ExprSide
side e :: CExpression NodeInfo
e =
  case NodeInfo -> Maybe Name
nameOfNode (CExpression NodeInfo -> NodeInfo
forall a. CNode a => a -> NodeInfo
nodeInfo CExpression NodeInfo
e) of
    Just n :: Name
n ->
      do DefTable
dt <- m DefTable
forall (m :: * -> *). MonadSymtab m => m DefTable
getDefTable
         case DefTable -> Name -> Maybe Type
lookupType DefTable
dt Name
n of
           Just t :: Type
t -> Type -> m Type
forall (m :: * -> *) a. Monad m => a -> m a
return Type
t
           Nothing ->
             do Type
t <- [StmtCtx] -> ExprSide -> CExpression NodeInfo -> m Type
forall (m :: * -> *).
MonadTrav m =>
[StmtCtx] -> ExprSide -> CExpression NodeInfo -> m Type
tExpr' [StmtCtx]
c ExprSide
side CExpression NodeInfo
e
                (DefTable -> (Type, DefTable)) -> m Type
forall (m :: * -> *) a.
MonadSymtab m =>
(DefTable -> (a, DefTable)) -> m a
withDefTable (\dt' :: DefTable
dt' -> (Type
t, DefTable -> Name -> Type -> DefTable
insertType DefTable
dt' Name
n Type
t))
    Nothing -> [StmtCtx] -> ExprSide -> CExpression NodeInfo -> m Type
forall (m :: * -> *).
MonadTrav m =>
[StmtCtx] -> ExprSide -> CExpression NodeInfo -> m Type
tExpr' [StmtCtx]
c ExprSide
side CExpression NodeInfo
e

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

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

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

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

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

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

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


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

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