{-# LANGUAGE ScopedTypeVariables, PatternGuards #-}
module Language.C.Analysis.AstAnalysis (
analyseAST,
analyseExt,analyseFunDef,analyseDecl,
analyseFunctionBody,
defineParams,
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_)
analyseAST :: (MonadTrav m) => CTranslUnit -> m GlobalDecls
analyseAST :: forall (m :: * -> *). MonadTrav m => CTranslUnit -> m GlobalDecls
analyseAST (CTranslUnit [CExternalDeclaration NodeInfo]
decls NodeInfo
_file_node) = do
forall {t :: * -> *} {m :: * -> *} {a} {a}.
(Foldable t, MonadCError m) =>
(a -> m a) -> t a -> m ()
mapRecoverM_ forall (m :: * -> *).
MonadTrav m =>
CExternalDeclaration NodeInfo -> m ()
analyseExt [CExternalDeclaration NodeInfo]
decls
forall (m :: * -> *). MonadSymtab m => m DefTable
getDefTable forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \DefTable
dt -> forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (DefTable -> Bool
inFileScope DefTable
dt) forall a b. (a -> b) -> a -> b
$
forall a. HasCallStack => [Char] -> a
error [Char]
"Internal Error: Not in filescope after analysis"
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM DefTable -> GlobalDecls
globalDefs forall (m :: * -> *). MonadSymtab m => m DefTable
getDefTable
where
mapRecoverM_ :: (a -> m a) -> t a -> m ()
mapRecoverM_ a -> m a
f = forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (forall (m :: * -> *) a. MonadCError m => m a -> m (Maybe a)
handleTravError forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> m a
f)
analyseExt :: (MonadTrav m) => CExtDecl -> m ()
analyseExt :: forall (m :: * -> *).
MonadTrav m =>
CExternalDeclaration NodeInfo -> m ()
analyseExt (CAsmExt CStringLiteral NodeInfo
asm NodeInfo
_)
= forall (m :: * -> *).
MonadTrav m =>
CStringLiteral NodeInfo -> m ()
handleAsmBlock CStringLiteral NodeInfo
asm
analyseExt (CFDefExt CFunctionDef NodeInfo
fundef)
= forall (m :: * -> *). MonadTrav m => CFunctionDef NodeInfo -> m ()
analyseFunDef CFunctionDef NodeInfo
fundef
analyseExt (CDeclExt CDeclaration NodeInfo
decl)
= forall (m :: * -> *).
MonadTrav m =>
Bool -> CDeclaration NodeInfo -> m ()
analyseDecl Bool
False CDeclaration NodeInfo
decl
analyseFunDef :: (MonadTrav m) => CFunDef -> m ()
analyseFunDef :: forall (m :: * -> *). MonadTrav m => CFunctionDef NodeInfo -> m ()
analyseFunDef (CFunDef [CDeclarationSpecifier NodeInfo]
declspecs CDeclarator NodeInfo
declr [CDeclaration NodeInfo]
oldstyle_decls CStatement NodeInfo
stmt NodeInfo
node_info) = do
VarDeclInfo
var_decl_info <- forall (m :: * -> *).
MonadTrav m =>
Bool
-> [CDeclarationSpecifier NodeInfo]
-> CDeclarator NodeInfo
-> [CDeclaration NodeInfo]
-> Maybe CInit
-> m VarDeclInfo
analyseVarDecl' Bool
True [CDeclarationSpecifier NodeInfo]
declspecs CDeclarator NodeInfo
declr [CDeclaration NodeInfo]
oldstyle_decls forall a. Maybe a
Nothing
let (VarDeclInfo VarName
name FunctionAttrs
fun_spec StorageSpec
storage_spec Attributes
attrs Type
ty NodeInfo
_declr_node) = VarDeclInfo
var_decl_info
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (VarName -> Bool
isNoName VarName
name) forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadCError m => NodeInfo -> [Char] -> m a
astError NodeInfo
node_info [Char]
"NoName in analyseFunDef"
let ident :: Ident
ident = VarName -> Ident
identOfVarName VarName
name
Type
ty' <- forall {m :: * -> *}. Monad m => Type -> m Type
improveFunDefType Type
ty
Storage
fun_storage <- forall (m :: * -> *).
MonadTrav m =>
Ident -> StorageSpec -> m Storage
computeFunDefStorage Ident
ident StorageSpec
storage_spec
let var_decl :: VarDecl
var_decl = VarName -> DeclAttrs -> Type -> VarDecl
VarDecl VarName
name (FunctionAttrs -> Storage -> Attributes -> DeclAttrs
DeclAttrs FunctionAttrs
fun_spec Storage
fun_storage Attributes
attrs) Type
ty'
forall (m :: * -> *). MonadTrav m => Bool -> Decl -> m ()
handleVarDecl Bool
False (VarDecl -> NodeInfo -> Decl
Decl VarDecl
var_decl NodeInfo
node_info)
CStatement NodeInfo
stmt' <- forall (m :: * -> *).
MonadTrav m =>
NodeInfo
-> VarDecl -> CStatement NodeInfo -> m (CStatement NodeInfo)
analyseFunctionBody NodeInfo
node_info VarDecl
var_decl CStatement NodeInfo
stmt
forall (m :: * -> *). MonadTrav m => Ident -> FunDef -> m ()
handleFunDef Ident
ident (VarDecl -> CStatement NodeInfo -> NodeInfo -> FunDef
FunDef VarDecl
var_decl CStatement NodeInfo
stmt' NodeInfo
node_info)
where
improveFunDefType :: Type -> m Type
improveFunDefType (FunctionType (FunTypeIncomplete Type
return_ty) Attributes
attrs) =
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ FunType -> Attributes -> Type
FunctionType (Type -> [ParamDecl] -> Bool -> FunType
FunType Type
return_ty [] Bool
False) Attributes
attrs
improveFunDefType Type
ty = forall (m :: * -> *) a. Monad m => a -> m a
return Type
ty
voidM :: Monad m => m a -> m ()
voidM :: forall (m :: * -> *) a. Monad m => m a -> m ()
voidM m a
m = m a
m forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return ()
analyseDecl :: (MonadTrav m) => Bool -> CDecl -> m ()
analyseDecl :: forall (m :: * -> *).
MonadTrav m =>
Bool -> CDeclaration NodeInfo -> m ()
analyseDecl Bool
_is_local (CStaticAssert CExpression NodeInfo
_expr CStringLiteral NodeInfo
_strlit NodeInfo
_annot) = forall (m :: * -> *) a. Monad m => a -> m a
return ()
analyseDecl Bool
is_local decl :: CDeclaration NodeInfo
decl@(CDecl [CDeclarationSpecifier NodeInfo]
declspecs [(Maybe (CDeclarator NodeInfo), Maybe CInit,
Maybe (CExpression NodeInfo))]
declrs NodeInfo
node)
| forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(Maybe (CDeclarator NodeInfo), Maybe CInit,
Maybe (CExpression NodeInfo))]
declrs =
case Maybe [CDeclarationSpecifier NodeInfo]
typedef_spec of Just [CDeclarationSpecifier NodeInfo]
_ -> forall (m :: * -> *) a. MonadCError m => NodeInfo -> [Char] -> m a
astError NodeInfo
node [Char]
"bad typedef declaration: missing declarator"
Maybe [CDeclarationSpecifier NodeInfo]
Nothing -> forall (m :: * -> *) a. Monad m => m a -> m ()
voidMforall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
MonadTrav m =>
CDeclaration NodeInfo -> m Type
analyseTypeDecl CDeclaration NodeInfo
decl
| (Just [CDeclarationSpecifier NodeInfo]
declspecs') <- Maybe [CDeclarationSpecifier NodeInfo]
typedef_spec = forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (forall {m :: * -> *} {a} {a}.
MonadTrav m =>
[CDeclarationSpecifier NodeInfo]
-> Bool -> (Maybe (CDeclarator NodeInfo), Maybe a, Maybe a) -> m ()
analyseTyDef [CDeclarationSpecifier NodeInfo]
declspecs')) [(Bool,
(Maybe (CDeclarator NodeInfo), Maybe CInit,
Maybe (CExpression NodeInfo)))]
declr_list
| Bool
otherwise = do let ([CStorageSpecifier NodeInfo]
storage_specs, [CAttribute NodeInfo]
attrs, [CTypeQualifier NodeInfo]
typequals, [CTypeSpecifier NodeInfo]
typespecs, [CFunctionSpecifier NodeInfo]
funspecs, [CAlignmentSpecifier NodeInfo]
_alignspecs) =
forall a.
[CDeclarationSpecifier a]
-> ([CStorageSpecifier a], [CAttribute a], [CTypeQualifier a],
[CTypeSpecifier a], [CFunctionSpecifier a],
[CAlignmentSpecifier a])
partitionDeclSpecs [CDeclarationSpecifier NodeInfo]
declspecs
TypeSpecAnalysis
canonTySpecs <- forall (m :: * -> *).
MonadTrav m =>
[CTypeSpecifier NodeInfo] -> m TypeSpecAnalysis
canonicalTypeSpec [CTypeSpecifier NodeInfo]
typespecs
let specs :: ([CStorageSpecifier NodeInfo], [CAttribute NodeInfo],
[CTypeQualifier NodeInfo], TypeSpecAnalysis,
[CFunctionSpecifier NodeInfo])
specs =
([CStorageSpecifier NodeInfo]
storage_specs, [CAttribute NodeInfo]
attrs, [CTypeQualifier NodeInfo]
typequals, TypeSpecAnalysis
canonTySpecs, [CFunctionSpecifier NodeInfo]
funspecs)
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (forall {m :: * -> *} {a}.
MonadTrav m =>
([CStorageSpecifier NodeInfo], [CAttribute NodeInfo],
[CTypeQualifier NodeInfo], TypeSpecAnalysis,
[CFunctionSpecifier NodeInfo])
-> Bool
-> (Maybe (CDeclarator NodeInfo), Maybe CInit, Maybe a)
-> m ()
analyseVarDeclr ([CStorageSpecifier NodeInfo], [CAttribute NodeInfo],
[CTypeQualifier NodeInfo], TypeSpecAnalysis,
[CFunctionSpecifier NodeInfo])
specs)) [(Bool,
(Maybe (CDeclarator NodeInfo), Maybe CInit,
Maybe (CExpression NodeInfo)))]
declr_list
where
declr_list :: [(Bool,
(Maybe (CDeclarator NodeInfo), Maybe CInit,
Maybe (CExpression NodeInfo)))]
declr_list = forall a b. [a] -> [b] -> [(a, b)]
zip (Bool
True forall a. a -> [a] -> [a]
: forall a. a -> [a]
repeat Bool
False) [(Maybe (CDeclarator NodeInfo), Maybe CInit,
Maybe (CExpression NodeInfo))]
declrs
typedef_spec :: Maybe [CDeclarationSpecifier NodeInfo]
typedef_spec = [CDeclarationSpecifier NodeInfo]
-> Maybe [CDeclarationSpecifier NodeInfo]
hasTypeDef [CDeclarationSpecifier NodeInfo]
declspecs
analyseTyDef :: [CDeclarationSpecifier NodeInfo]
-> Bool -> (Maybe (CDeclarator NodeInfo), Maybe a, Maybe a) -> m ()
analyseTyDef [CDeclarationSpecifier NodeInfo]
declspecs' Bool
handle_sue_def (Maybe (CDeclarator NodeInfo), Maybe a, Maybe a)
declr =
case (Maybe (CDeclarator NodeInfo), Maybe a, Maybe a)
declr of
(Just CDeclarator NodeInfo
tydeclr, Maybe a
Nothing , Maybe a
Nothing) -> forall (m :: * -> *).
MonadTrav m =>
Bool
-> [CDeclarationSpecifier NodeInfo]
-> CDeclarator NodeInfo
-> NodeInfo
-> m ()
analyseTypeDef Bool
handle_sue_def [CDeclarationSpecifier NodeInfo]
declspecs' CDeclarator NodeInfo
tydeclr NodeInfo
node
(Maybe (CDeclarator NodeInfo), Maybe a, Maybe a)
_ -> forall (m :: * -> *) a. MonadCError m => NodeInfo -> [Char] -> m a
astError NodeInfo
node [Char]
"bad typdef declaration: bitfieldsize or initializer present"
analyseVarDeclr :: ([CStorageSpecifier NodeInfo], [CAttribute NodeInfo],
[CTypeQualifier NodeInfo], TypeSpecAnalysis,
[CFunctionSpecifier NodeInfo])
-> Bool
-> (Maybe (CDeclarator NodeInfo), Maybe CInit, Maybe a)
-> m ()
analyseVarDeclr ([CStorageSpecifier NodeInfo], [CAttribute NodeInfo],
[CTypeQualifier NodeInfo], TypeSpecAnalysis,
[CFunctionSpecifier NodeInfo])
specs Bool
handle_sue_def (Just CDeclarator NodeInfo
declr, Maybe CInit
init_opt, Maybe a
Nothing) = do
let ([CStorageSpecifier NodeInfo]
storage_specs, [CAttribute NodeInfo]
attrs, [CTypeQualifier NodeInfo]
typequals, TypeSpecAnalysis
canonTySpecs, [CFunctionSpecifier NodeInfo]
inline) = ([CStorageSpecifier NodeInfo], [CAttribute NodeInfo],
[CTypeQualifier NodeInfo], TypeSpecAnalysis,
[CFunctionSpecifier NodeInfo])
specs
vardeclInfo :: VarDeclInfo
vardeclInfo@(VarDeclInfo VarName
_ FunctionAttrs
_ StorageSpec
_ Attributes
_ Type
typ NodeInfo
_) <-
forall (m :: * -> *).
MonadTrav m =>
Bool
-> [CStorageSpecifier NodeInfo]
-> [CAttribute NodeInfo]
-> [CTypeQualifier NodeInfo]
-> TypeSpecAnalysis
-> [CFunctionSpecifier NodeInfo]
-> CDeclarator NodeInfo
-> [CDeclaration NodeInfo]
-> Maybe CInit
-> m VarDeclInfo
analyseVarDecl Bool
handle_sue_def [CStorageSpecifier NodeInfo]
storage_specs [CAttribute NodeInfo]
attrs [CTypeQualifier NodeInfo]
typequals TypeSpecAnalysis
canonTySpecs [CFunctionSpecifier NodeInfo]
inline
CDeclarator NodeInfo
declr [] forall a. Maybe a
Nothing
if Type -> Bool
isFunctionType Type
typ
then forall (m :: * -> *). MonadTrav m => VarDeclInfo -> m ()
extFunProto VarDeclInfo
vardeclInfo
else (if Bool
is_local then forall (m :: * -> *).
MonadTrav m =>
VarDeclInfo -> Maybe CInit -> m ()
localVarDecl else forall (m :: * -> *).
MonadTrav m =>
VarDeclInfo -> Maybe CInit -> m ()
extVarDecl)
VarDeclInfo
vardeclInfo Maybe CInit
init_opt
Maybe CInit
_init_opt' <- forall (m :: * -> *) a b.
Monad m =>
Maybe a -> (a -> m b) -> m (Maybe b)
mapMaybeM Maybe CInit
init_opt (forall (m :: * -> *). MonadTrav m => Type -> CInit -> m CInit
tInit Type
typ)
forall (m :: * -> *) a. Monad m => a -> m a
return ()
analyseVarDeclr ([CStorageSpecifier NodeInfo], [CAttribute NodeInfo],
[CTypeQualifier NodeInfo], TypeSpecAnalysis,
[CFunctionSpecifier NodeInfo])
_ Bool
_ (Maybe (CDeclarator NodeInfo)
Nothing,Maybe CInit
_,Maybe a
_) = forall (m :: * -> *) a. MonadCError m => NodeInfo -> [Char] -> m a
astError NodeInfo
node [Char]
"abstract declarator in object declaration"
analyseVarDeclr ([CStorageSpecifier NodeInfo], [CAttribute NodeInfo],
[CTypeQualifier NodeInfo], TypeSpecAnalysis,
[CFunctionSpecifier NodeInfo])
_ Bool
_ (Maybe (CDeclarator NodeInfo)
_,Maybe CInit
_,Just a
_bitfieldSz) = forall (m :: * -> *) a. MonadCError m => NodeInfo -> [Char] -> m a
astError NodeInfo
node [Char]
"bitfield size in object declaration"
analyseTypeDef :: (MonadTrav m) => Bool -> [CDeclSpec] -> CDeclr -> NodeInfo -> m ()
analyseTypeDef :: forall (m :: * -> *).
MonadTrav m =>
Bool
-> [CDeclarationSpecifier NodeInfo]
-> CDeclarator NodeInfo
-> NodeInfo
-> m ()
analyseTypeDef Bool
handle_sue_def [CDeclarationSpecifier NodeInfo]
declspecs CDeclarator NodeInfo
declr NodeInfo
node_info = do
(VarDeclInfo VarName
name FunctionAttrs
fun_attrs StorageSpec
storage_spec Attributes
attrs Type
ty NodeInfo
_node) <- forall (m :: * -> *).
MonadTrav m =>
Bool
-> [CDeclarationSpecifier NodeInfo]
-> CDeclarator NodeInfo
-> [CDeclaration NodeInfo]
-> Maybe CInit
-> m VarDeclInfo
analyseVarDecl' Bool
handle_sue_def [CDeclarationSpecifier NodeInfo]
declspecs CDeclarator NodeInfo
declr [] forall a. Maybe a
Nothing
forall {m :: * -> *} {p}.
MonadCError m =>
FunctionAttrs -> StorageSpec -> p -> m ()
checkValidTypeDef FunctionAttrs
fun_attrs StorageSpec
storage_spec Attributes
attrs
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (VarName -> Bool
isNoName VarName
name) forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadCError m => NodeInfo -> [Char] -> m a
astError NodeInfo
node_info [Char]
"NoName in analyseTypeDef"
let ident :: Ident
ident = VarName -> Ident
identOfVarName VarName
name
forall (m :: * -> *). MonadTrav m => TypeDef -> m ()
handleTypeDef (Ident -> Type -> Attributes -> NodeInfo -> TypeDef
TypeDef Ident
ident Type
ty Attributes
attrs NodeInfo
node_info)
where
checkValidTypeDef :: FunctionAttrs -> StorageSpec -> p -> m ()
checkValidTypeDef FunctionAttrs
fun_attrs StorageSpec
_ p
_ | FunctionAttrs
fun_attrs forall a. Eq a => a -> a -> Bool
/= FunctionAttrs
noFunctionAttrs =
forall (m :: * -> *) a. MonadCError m => NodeInfo -> [Char] -> m a
astError NodeInfo
node_info [Char]
"inline specifier for typeDef"
checkValidTypeDef FunctionAttrs
_ StorageSpec
NoStorageSpec p
_ = forall (m :: * -> *) a. Monad m => a -> m a
return ()
checkValidTypeDef FunctionAttrs
_ StorageSpec
bad_storage p
_ = forall (m :: * -> *) a. MonadCError m => NodeInfo -> [Char] -> m a
astError NodeInfo
node_info forall a b. (a -> b) -> a -> b
$ [Char]
"storage specified for typeDef: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show StorageSpec
bad_storage
computeFunDefStorage :: (MonadTrav m) => Ident -> StorageSpec -> m Storage
computeFunDefStorage :: forall (m :: * -> *).
MonadTrav m =>
Ident -> StorageSpec -> m Storage
computeFunDefStorage Ident
_ (StaticSpec Bool
_) = forall (m :: * -> *) a. Monad m => a -> m a
returnforall a b. (a -> b) -> a -> b
$ Linkage -> Storage
FunLinkage Linkage
InternalLinkage
computeFunDefStorage Ident
ident StorageSpec
other_spec = do
Maybe IdentDecl
obj_opt <- forall (m :: * -> *).
(MonadCError m, MonadSymtab m) =>
Ident -> m (Maybe IdentDecl)
lookupObject Ident
ident
let defaultSpec :: Storage
defaultSpec = Linkage -> Storage
FunLinkage Linkage
ExternalLinkage
case StorageSpec
other_spec of
StorageSpec
NoStorageSpec -> forall (m :: * -> *) a. Monad m => a -> m a
returnforall a b. (a -> b) -> a -> b
$ forall b a. b -> (a -> b) -> Maybe a -> b
maybe Storage
defaultSpec forall d. Declaration d => d -> Storage
declStorage Maybe IdentDecl
obj_opt
StorageSpec
ClKernelSpec -> forall (m :: * -> *) a. Monad m => a -> m a
returnforall a b. (a -> b) -> a -> b
$ forall b a. b -> (a -> b) -> Maybe a -> b
maybe Storage
defaultSpec forall d. Declaration d => d -> Storage
declStorage Maybe IdentDecl
obj_opt
(ExternSpec Bool
False) -> forall (m :: * -> *) a. Monad m => a -> m a
returnforall a b. (a -> b) -> a -> b
$ forall b a. b -> (a -> b) -> Maybe a -> b
maybe Storage
defaultSpec forall d. Declaration d => d -> Storage
declStorage Maybe IdentDecl
obj_opt
StorageSpec
bad_spec -> forall (m :: * -> *) e a. (MonadCError m, Error e) => e -> m a
throwTravError forall a b. (a -> b) -> a -> b
$ NodeInfo -> [Char] -> BadSpecifierError
badSpecifierError (forall a. CNode a => a -> NodeInfo
nodeInfo Ident
ident)
forall a b. (a -> b) -> a -> b
$ [Char]
"unexpected function storage specifier (only static or extern is allowed)" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show StorageSpec
bad_spec
getParams :: Type -> Maybe [ParamDecl]
getParams :: Type -> Maybe [ParamDecl]
getParams (FunctionType (FunType Type
_ [ParamDecl]
params Bool
_) Attributes
_) = forall a. a -> Maybe a
Just [ParamDecl]
params
getParams Type
_ = forall a. Maybe a
Nothing
extFunProto :: (MonadTrav m) => VarDeclInfo -> m ()
extFunProto :: forall (m :: * -> *). MonadTrav m => VarDeclInfo -> m ()
extFunProto (VarDeclInfo VarName
var_name FunctionAttrs
fun_spec StorageSpec
storage_spec Attributes
attrs Type
ty NodeInfo
node_info) =
do forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (VarName -> Bool
isNoName VarName
var_name) forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadCError m => NodeInfo -> [Char] -> m a
astError NodeInfo
node_info [Char]
"NoName in extFunProto"
Maybe IdentDecl
old_fun <- forall (m :: * -> *).
(MonadCError m, MonadSymtab m) =>
Ident -> m (Maybe IdentDecl)
lookupObject (VarName -> Ident
identOfVarName VarName
var_name)
m ()
checkValidSpecs
let decl :: VarDecl
decl = VarName -> DeclAttrs -> Type -> VarDecl
VarDecl VarName
var_name (FunctionAttrs -> Storage -> Attributes -> DeclAttrs
DeclAttrs FunctionAttrs
fun_spec (forall {d}. Declaration d => Maybe d -> Storage
funDeclLinkage Maybe IdentDecl
old_fun) Attributes
attrs) Type
ty
forall (m :: * -> *). MonadTrav m => Bool -> Decl -> m ()
handleVarDecl Bool
False (VarDecl -> NodeInfo -> Decl
Decl VarDecl
decl NodeInfo
node_info)
forall (m :: * -> *). MonadSymtab m => m ()
enterPrototypeScope
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (m :: * -> *) a. Monad m => a -> m a
return ()) (forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ forall (m :: * -> *). MonadTrav m => ParamDecl -> m ()
handleParamDecl) (Type -> Maybe [ParamDecl]
getParams Type
ty)
forall (m :: * -> *). MonadSymtab m => m ()
leavePrototypeScope
where
funDeclLinkage :: Maybe d -> Storage
funDeclLinkage Maybe d
old_fun =
case StorageSpec
storage_spec of
StorageSpec
NoStorageSpec -> Linkage -> Storage
FunLinkage Linkage
ExternalLinkage
StaticSpec Bool
False -> Linkage -> Storage
FunLinkage Linkage
InternalLinkage
ExternSpec Bool
False -> case Maybe d
old_fun of
Maybe d
Nothing -> Linkage -> Storage
FunLinkage Linkage
ExternalLinkage
Just d
f -> forall d. Declaration d => d -> Storage
declStorage d
f
StorageSpec
_ -> forall a. HasCallStack => [Char] -> a
error forall a b. (a -> b) -> a -> b
$ [Char]
"funDeclLinkage: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show StorageSpec
storage_spec
checkValidSpecs :: m ()
checkValidSpecs
| StorageSpec -> Bool
hasThreadLocalSpec StorageSpec
storage_spec = forall (m :: * -> *) a. MonadCError m => NodeInfo -> [Char] -> m a
astError NodeInfo
node_info [Char]
"thread local storage specified for function"
| StorageSpec
RegSpec <- StorageSpec
storage_spec = forall (m :: * -> *) a. MonadCError m => NodeInfo -> [Char] -> m a
astError NodeInfo
node_info [Char]
"invalid `register' storage specified for function"
| Bool
otherwise = forall (m :: * -> *) a. Monad m => a -> m a
return ()
extVarDecl :: (MonadTrav m) => VarDeclInfo -> Maybe Initializer -> m ()
extVarDecl :: forall (m :: * -> *).
MonadTrav m =>
VarDeclInfo -> Maybe CInit -> m ()
extVarDecl (VarDeclInfo VarName
var_name FunctionAttrs
fun_spec StorageSpec
storage_spec Attributes
attrs Type
typ NodeInfo
node_info) Maybe CInit
init_opt =
do forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (VarName -> Bool
isNoName VarName
var_name) forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadCError m => NodeInfo -> [Char] -> m a
astError NodeInfo
node_info [Char]
"NoName in extVarDecl"
(Storage
storage,Bool
is_def) <- forall {m :: * -> *}.
(MonadCError m, MonadSymtab m) =>
StorageSpec -> m (Storage, Bool)
globalStorage StorageSpec
storage_spec
let vardecl :: VarDecl
vardecl = VarName -> DeclAttrs -> Type -> VarDecl
VarDecl VarName
var_name (FunctionAttrs -> Storage -> Attributes -> DeclAttrs
DeclAttrs FunctionAttrs
fun_spec Storage
storage Attributes
attrs) Type
typ
if Bool
is_def
then forall (m :: * -> *).
MonadTrav m =>
Bool -> Ident -> ObjDef -> m ()
handleObjectDef Bool
False Ident
ident forall a b. (a -> b) -> a -> b
$ VarDecl -> Maybe CInit -> NodeInfo -> ObjDef
ObjDef VarDecl
vardecl Maybe CInit
init_opt NodeInfo
node_info
else forall (m :: * -> *). MonadTrav m => Bool -> Decl -> m ()
handleVarDecl Bool
False forall a b. (a -> b) -> a -> b
$ VarDecl -> NodeInfo -> Decl
Decl VarDecl
vardecl NodeInfo
node_info
where
ident :: Ident
ident = VarName -> Ident
identOfVarName VarName
var_name
globalStorage :: StorageSpec -> m (Storage, Bool)
globalStorage StorageSpec
_ | FunctionAttrs
fun_spec forall a. Eq a => a -> a -> Bool
/= FunctionAttrs
noFunctionAttrs =
forall (m :: * -> *) a. MonadCError m => NodeInfo -> [Char] -> m a
astError NodeInfo
node_info [Char]
"invalid function specifier for external variable"
globalStorage StorageSpec
AutoSpec = forall (m :: * -> *) a. MonadCError m => NodeInfo -> [Char] -> m a
astError NodeInfo
node_info [Char]
"file-scope declaration specifies storage `auto'"
globalStorage StorageSpec
RegSpec =
do forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall a. Maybe a -> Bool
isJust Maybe CInit
init_opt) forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadCError m => NodeInfo -> [Char] -> m a
astError NodeInfo
node_info [Char]
"initializer given for global register variable"
case VarName
var_name of
VarName
NoName -> forall (m :: * -> *) a. MonadCError m => NodeInfo -> [Char] -> m a
astError NodeInfo
node_info [Char]
"global register variable has no name"
VarName Ident
_ Maybe (CStringLiteral NodeInfo)
Nothing -> forall (m :: * -> *) a. MonadCError m => NodeInfo -> [Char] -> m a
astError NodeInfo
node_info [Char]
"no register specified for global register variable"
VarName
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
DefTable
dt <- forall (m :: * -> *). MonadSymtab m => m DefTable
getDefTable
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (DefTable -> Bool
hasFunDef DefTable
dt) forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadCError m => NodeInfo -> [Char] -> m a
astError NodeInfo
node_info [Char]
"global register variable appears after a function definition"
forall (m :: * -> *) a. Monad m => a -> m a
return (Linkage -> Bool -> Storage
Static Linkage
InternalLinkage Bool
False, Bool
False)
globalStorage StorageSpec
NoStorageSpec = forall (m :: * -> *) a. Monad m => a -> m a
return (Linkage -> Bool -> Storage
Static Linkage
ExternalLinkage Bool
False, Bool
True)
globalStorage StorageSpec
ThreadSpec = forall (m :: * -> *) a. Monad m => a -> m a
return (Linkage -> Bool -> Storage
Static Linkage
ExternalLinkage Bool
True, Bool
True)
globalStorage (StaticSpec Bool
thread_local) = forall (m :: * -> *) a. Monad m => a -> m a
return (Linkage -> Bool -> Storage
Static Linkage
InternalLinkage Bool
thread_local, Bool
True)
globalStorage (ExternSpec Bool
thread_local) =
case Maybe CInit
init_opt of
Maybe CInit
Nothing -> do Maybe IdentDecl
old_decl <- forall (m :: * -> *).
(MonadCError m, MonadSymtab m) =>
Ident -> m (Maybe IdentDecl)
lookupObject Ident
ident
forall (m :: * -> *) a. Monad m => a -> m a
return (forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Linkage -> Bool -> Storage
Static Linkage
ExternalLinkage Bool
thread_local) forall d. Declaration d => d -> Storage
declStorage Maybe IdentDecl
old_decl,Bool
False)
Just CInit
_ -> do forall e (m :: * -> *). (Error e, MonadCError m) => e -> m ()
warn forall a b. (a -> b) -> a -> b
$ NodeInfo -> [Char] -> BadSpecifierError
badSpecifierError NodeInfo
node_info [Char]
"Both initializer and `extern` specifier given - treating as definition"
forall (m :: * -> *) a. Monad m => a -> m a
return (Linkage -> Bool -> Storage
Static Linkage
ExternalLinkage Bool
thread_local, Bool
True)
hasFunDef :: DefTable -> Bool
hasFunDef DefTable
dt = forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (IdentDecl -> Bool
isFuncDef forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) (forall k a. Map k a -> [(k, a)]
Map.toList forall a b. (a -> b) -> a -> b
$ GlobalDecls -> Map Ident IdentDecl
gObjs forall a b. (a -> b) -> a -> b
$ DefTable -> GlobalDecls
globalDefs DefTable
dt)
isFuncDef :: IdentDecl -> Bool
isFuncDef (FunctionDef FunDef
fd) = Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ (FunctionAttrs -> Bool
isInline forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall d. Declaration d => d -> FunctionAttrs
functionAttrs) FunDef
fd
isFuncDef IdentDecl
_ = Bool
False
localVarDecl :: (MonadTrav m) => VarDeclInfo -> Maybe Initializer -> m ()
localVarDecl :: forall (m :: * -> *).
MonadTrav m =>
VarDeclInfo -> Maybe CInit -> m ()
localVarDecl (VarDeclInfo VarName
var_name FunctionAttrs
fun_attrs StorageSpec
storage_spec Attributes
attrs Type
typ NodeInfo
node_info) Maybe CInit
init_opt =
do forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (VarName -> Bool
isNoName VarName
var_name) forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadCError m => NodeInfo -> [Char] -> m a
astError NodeInfo
node_info [Char]
"NoName in localVarDecl"
(Storage
storage,Bool
is_def) <- forall {m :: * -> *}.
(MonadCError m, MonadSymtab m) =>
StorageSpec -> m (Storage, Bool)
localStorage StorageSpec
storage_spec
let vardecl :: VarDecl
vardecl = VarName -> DeclAttrs -> Type -> VarDecl
VarDecl VarName
var_name (FunctionAttrs -> Storage -> Attributes -> DeclAttrs
DeclAttrs FunctionAttrs
fun_attrs Storage
storage Attributes
attrs) Type
typ
if Bool
is_def
then forall (m :: * -> *).
MonadTrav m =>
Bool -> Ident -> ObjDef -> m ()
handleObjectDef Bool
True Ident
ident (VarDecl -> Maybe CInit -> NodeInfo -> ObjDef
ObjDef VarDecl
vardecl Maybe CInit
init_opt NodeInfo
node_info)
else forall (m :: * -> *). MonadTrav m => Bool -> Decl -> m ()
handleVarDecl Bool
True (VarDecl -> NodeInfo -> Decl
Decl VarDecl
vardecl NodeInfo
node_info)
where
ident :: Ident
ident = VarName -> Ident
identOfVarName VarName
var_name
localStorage :: StorageSpec -> m (Storage, Bool)
localStorage StorageSpec
NoStorageSpec = forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> Storage
Auto Bool
False,Bool
True)
localStorage StorageSpec
ThreadSpec = forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> Storage
Auto Bool
True,Bool
True)
localStorage StorageSpec
RegSpec = forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> Storage
Auto Bool
True,Bool
True)
localStorage (StaticSpec Bool
thread_local) =
forall (m :: * -> *) a. Monad m => a -> m a
return (Linkage -> Bool -> Storage
Static Linkage
NoLinkage Bool
thread_local,Bool
True)
localStorage (ExternSpec Bool
thread_local)
| forall a. Maybe a -> Bool
isJust Maybe CInit
init_opt = forall (m :: * -> *) a. MonadCError m => NodeInfo -> [Char] -> m a
astError NodeInfo
node_info [Char]
"extern keyword and initializer for local"
| Bool
otherwise =
do Maybe IdentDecl
old_decl <- forall (m :: * -> *).
(MonadCError m, MonadSymtab m) =>
Ident -> m (Maybe IdentDecl)
lookupObject Ident
ident
forall (m :: * -> *) a. Monad m => a -> m a
return (forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Linkage -> Bool -> Storage
Static Linkage
ExternalLinkage Bool
thread_local) forall d. Declaration d => d -> Storage
declStorage Maybe IdentDecl
old_decl,Bool
False)
localStorage StorageSpec
_ = forall (m :: * -> *) a. MonadCError m => NodeInfo -> [Char] -> m a
astError NodeInfo
node_info [Char]
"bad storage specifier for local"
defineParams :: MonadTrav m => NodeInfo -> VarDecl -> m ()
defineParams :: forall (m :: * -> *). MonadTrav m => NodeInfo -> VarDecl -> m ()
defineParams NodeInfo
ni VarDecl
decl =
case Type -> Maybe [ParamDecl]
getParams (forall n. Declaration n => n -> Type
declType VarDecl
decl) of
Maybe [ParamDecl]
Nothing -> forall (m :: * -> *) a. MonadCError m => NodeInfo -> [Char] -> m a
astError NodeInfo
ni
[Char]
"expecting complete function type in function definition"
Just [ParamDecl]
params -> forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ forall (m :: * -> *). MonadTrav m => ParamDecl -> m ()
handleParamDecl [ParamDecl]
params
analyseFunctionBody :: (MonadTrav m) => NodeInfo -> VarDecl -> CStat -> m Stmt
analyseFunctionBody :: forall (m :: * -> *).
MonadTrav m =>
NodeInfo
-> VarDecl -> CStatement NodeInfo -> m (CStatement NodeInfo)
analyseFunctionBody NodeInfo
node_info VarDecl
decl s :: CStatement NodeInfo
s@(CCompound [Ident]
localLabels [CCompoundBlockItem NodeInfo]
items NodeInfo
_) =
do forall (m :: * -> *). MonadSymtab m => m ()
enterFunctionScope
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (forall (m :: * -> *) a.
MonadSymtab m =>
(DefTable -> (a, DefTable)) -> m a
withDefTable forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ident -> DefTable -> (DeclarationStatus Ident, DefTable)
defineLabel) ([Ident]
localLabels forall a. [a] -> [a] -> [a]
++ CStatement NodeInfo -> [Ident]
getLabels CStatement NodeInfo
s)
forall (m :: * -> *). MonadTrav m => NodeInfo -> VarDecl -> m ()
defineParams NodeInfo
node_info VarDecl
decl
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (forall (m :: * -> *).
MonadTrav m =>
[StmtCtx] -> CCompoundBlockItem NodeInfo -> m Type
tBlockItem [VarDecl -> StmtCtx
FunCtx VarDecl
decl]) [CCompoundBlockItem NodeInfo]
items
forall (m :: * -> *). MonadSymtab m => m ()
leaveFunctionScope
forall (m :: * -> *) a. Monad m => a -> m a
return CStatement NodeInfo
s
analyseFunctionBody NodeInfo
_ VarDecl
_ CStatement NodeInfo
s = forall (m :: * -> *) a. MonadCError m => NodeInfo -> [Char] -> m a
astError (forall a. CNode a => a -> NodeInfo
nodeInfo CStatement NodeInfo
s) [Char]
"Function body is no compound statement"
data StmtCtx = FunCtx VarDecl
| LoopCtx
| SwitchCtx
enclosingFunctionType :: [StmtCtx] -> Maybe Type
enclosingFunctionType :: [StmtCtx] -> Maybe Type
enclosingFunctionType [] = forall a. Maybe a
Nothing
enclosingFunctionType (FunCtx VarDecl
vd : [StmtCtx]
_) = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall n. Declaration n => n -> Type
declType VarDecl
vd
enclosingFunctionType (StmtCtx
_ : [StmtCtx]
cs) = [StmtCtx] -> Maybe Type
enclosingFunctionType [StmtCtx]
cs
inLoop :: [StmtCtx] -> Bool
inLoop :: [StmtCtx] -> Bool
inLoop [StmtCtx]
c = forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any StmtCtx -> Bool
isLoop [StmtCtx]
c
where isLoop :: StmtCtx -> Bool
isLoop StmtCtx
LoopCtx = Bool
True
isLoop StmtCtx
_ = Bool
False
inSwitch :: [StmtCtx] -> Bool
inSwitch :: [StmtCtx] -> Bool
inSwitch [StmtCtx]
c = forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any StmtCtx -> Bool
isSwitch [StmtCtx]
c
where isSwitch :: StmtCtx -> Bool
isSwitch StmtCtx
SwitchCtx = Bool
True
isSwitch StmtCtx
_ = Bool
False
data ExprSide = LValue | RValue
deriving (ExprSide -> ExprSide -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ExprSide -> ExprSide -> Bool
$c/= :: ExprSide -> ExprSide -> Bool
== :: ExprSide -> ExprSide -> Bool
$c== :: ExprSide -> ExprSide -> Bool
Eq, Int -> ExprSide -> ShowS
[ExprSide] -> ShowS
ExprSide -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [ExprSide] -> ShowS
$cshowList :: [ExprSide] -> ShowS
show :: ExprSide -> [Char]
$cshow :: ExprSide -> [Char]
showsPrec :: Int -> ExprSide -> ShowS
$cshowsPrec :: Int -> ExprSide -> ShowS
Show)
tStmt :: MonadTrav m => [StmtCtx] -> CStat -> m Type
tStmt :: forall (m :: * -> *).
MonadTrav m =>
[StmtCtx] -> CStatement NodeInfo -> m Type
tStmt [StmtCtx]
c (CLabel Ident
_ CStatement NodeInfo
s [CAttribute NodeInfo]
_ NodeInfo
_) = forall (m :: * -> *).
MonadTrav m =>
[StmtCtx] -> CStatement NodeInfo -> m Type
tStmt [StmtCtx]
c CStatement NodeInfo
s
tStmt [StmtCtx]
c (CExpr Maybe (CExpression NodeInfo)
e NodeInfo
_) =
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (m :: * -> *) a. Monad m => a -> m a
return Type
voidType) (forall (m :: * -> *).
MonadTrav m =>
[StmtCtx] -> ExprSide -> CExpression NodeInfo -> m Type
tExpr [StmtCtx]
c ExprSide
RValue) Maybe (CExpression NodeInfo)
e
tStmt [StmtCtx]
c (CCompound [Ident]
ls [CCompoundBlockItem NodeInfo]
body NodeInfo
_) =
do forall (m :: * -> *). MonadSymtab m => m ()
enterBlockScope
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (forall (m :: * -> *) a.
MonadSymtab m =>
(DefTable -> (a, DefTable)) -> m a
withDefTable forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ident -> DefTable -> (DeclarationStatus Ident, DefTable)
defineLabel) [Ident]
ls
Type
t <- forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM (forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
MonadTrav m =>
[StmtCtx] -> CCompoundBlockItem NodeInfo -> m Type
tBlockItem [StmtCtx]
c) Type
voidType [CCompoundBlockItem NodeInfo]
body
forall (m :: * -> *). MonadSymtab m => m ()
leaveBlockScope
forall (m :: * -> *) a. Monad m => a -> m a
return Type
t
tStmt [StmtCtx]
c (CIf CExpression NodeInfo
e CStatement NodeInfo
sthen Maybe (CStatement NodeInfo)
selse NodeInfo
_) =
forall (m :: * -> *).
MonadTrav m =>
[StmtCtx] -> CExpression NodeInfo -> m ()
checkGuard [StmtCtx]
c CExpression NodeInfo
e forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *).
MonadTrav m =>
[StmtCtx] -> CStatement NodeInfo -> m Type
tStmt [StmtCtx]
c CStatement NodeInfo
sthen
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (m :: * -> *) a. Monad m => a -> m a
return ()) (forall (m :: * -> *) a. Monad m => m a -> m ()
voidM forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *).
MonadTrav m =>
[StmtCtx] -> CStatement NodeInfo -> m Type
tStmt [StmtCtx]
c) Maybe (CStatement NodeInfo)
selse
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return Type
voidType
tStmt [StmtCtx]
c (CSwitch CExpression NodeInfo
e CStatement NodeInfo
s NodeInfo
ni) =
forall (m :: * -> *).
MonadTrav m =>
[StmtCtx] -> ExprSide -> CExpression NodeInfo -> m Type
tExpr [StmtCtx]
c ExprSide
RValue CExpression NodeInfo
e forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *). MonadCError m => NodeInfo -> Type -> m ()
checkIntegral' NodeInfo
ni forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>>
forall (m :: * -> *).
MonadTrav m =>
[StmtCtx] -> CStatement NodeInfo -> m Type
tStmt (StmtCtx
SwitchCtx forall a. a -> [a] -> [a]
: [StmtCtx]
c) CStatement NodeInfo
s
tStmt [StmtCtx]
c (CWhile CExpression NodeInfo
e CStatement NodeInfo
s Bool
_ NodeInfo
_) =
forall (m :: * -> *).
MonadTrav m =>
[StmtCtx] -> CExpression NodeInfo -> m ()
checkGuard [StmtCtx]
c CExpression NodeInfo
e forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *).
MonadTrav m =>
[StmtCtx] -> CStatement NodeInfo -> m Type
tStmt (StmtCtx
LoopCtx forall a. a -> [a] -> [a]
: [StmtCtx]
c) CStatement NodeInfo
s
tStmt [StmtCtx]
_ (CGoto Ident
l NodeInfo
ni) =
do DefTable
dt <- forall (m :: * -> *). MonadSymtab m => m DefTable
getDefTable
case Ident -> DefTable -> Maybe Ident
lookupLabel Ident
l DefTable
dt of
Just Ident
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return Type
voidType
Maybe Ident
Nothing -> forall (m :: * -> *) a. MonadCError m => NodeInfo -> [Char] -> m a
typeError NodeInfo
ni forall a b. (a -> b) -> a -> b
$ [Char]
"undefined label in goto: " forall a. [a] -> [a] -> [a]
++ Ident -> [Char]
identToString Ident
l
tStmt [StmtCtx]
c (CCont NodeInfo
ni) =
do forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([StmtCtx] -> Bool
inLoop [StmtCtx]
c) forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadCError m => NodeInfo -> [Char] -> m a
astError NodeInfo
ni [Char]
"continue statement outside of loop"
forall (m :: * -> *) a. Monad m => a -> m a
return Type
voidType
tStmt [StmtCtx]
c (CBreak NodeInfo
ni) =
do forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([StmtCtx] -> Bool
inLoop [StmtCtx]
c Bool -> Bool -> Bool
|| [StmtCtx] -> Bool
inSwitch [StmtCtx]
c) forall a b. (a -> b) -> a -> b
$
forall (m :: * -> *) a. MonadCError m => NodeInfo -> [Char] -> m a
astError NodeInfo
ni [Char]
"break statement outside of loop or switch statement"
forall (m :: * -> *) a. Monad m => a -> m a
return Type
voidType
tStmt [StmtCtx]
c (CReturn (Just CExpression NodeInfo
e) NodeInfo
ni) =
do Type
t <- forall (m :: * -> *).
MonadTrav m =>
[StmtCtx] -> ExprSide -> CExpression NodeInfo -> m Type
tExpr [StmtCtx]
c ExprSide
RValue CExpression NodeInfo
e
Type
rt <- case [StmtCtx] -> Maybe Type
enclosingFunctionType [StmtCtx]
c of
Just (FunctionType (FunType Type
rt [ParamDecl]
_ Bool
_) Attributes
_) -> forall (m :: * -> *) a. Monad m => a -> m a
return Type
rt
Just (FunctionType (FunTypeIncomplete Type
rt) Attributes
_) -> forall (m :: * -> *) a. Monad m => a -> m a
return Type
rt
Just Type
ft -> forall (m :: * -> *) a. MonadCError m => NodeInfo -> [Char] -> m a
astError NodeInfo
ni forall a b. (a -> b) -> a -> b
$ [Char]
"bad function type: " forall a. [a] -> [a] -> [a]
++ Type -> [Char]
pType Type
ft
Maybe Type
Nothing -> forall (m :: * -> *) a. MonadCError m => NodeInfo -> [Char] -> m a
astError NodeInfo
ni [Char]
"return statement outside function"
case (Type
rt, Type
t) of
(DirectType TypeName
TyVoid TypeQuals
_ Attributes
_, DirectType TypeName
TyVoid TypeQuals
_ Attributes
_) -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
(Type, Type)
_ -> forall (m :: * -> *).
MonadCError m =>
NodeInfo -> CAssignOp -> Type -> Type -> m ()
assignCompatible' NodeInfo
ni CAssignOp
CAssignOp Type
rt Type
t
forall (m :: * -> *) a. Monad m => a -> m a
return Type
voidType
tStmt [StmtCtx]
_ (CReturn Maybe (CExpression NodeInfo)
Nothing NodeInfo
_) = forall (m :: * -> *) a. Monad m => a -> m a
return Type
voidType
tStmt [StmtCtx]
_ (CAsm CAssemblyStatement NodeInfo
_ NodeInfo
_) = forall (m :: * -> *) a. Monad m => a -> m a
return Type
voidType
tStmt [StmtCtx]
c (CCase CExpression NodeInfo
e CStatement NodeInfo
s NodeInfo
ni) =
do forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([StmtCtx] -> Bool
inSwitch [StmtCtx]
c) forall a b. (a -> b) -> a -> b
$
forall (m :: * -> *) a. MonadCError m => NodeInfo -> [Char] -> m a
astError NodeInfo
ni [Char]
"case statement outside of switch statement"
forall (m :: * -> *).
MonadTrav m =>
[StmtCtx] -> ExprSide -> CExpression NodeInfo -> m Type
tExpr [StmtCtx]
c ExprSide
RValue CExpression NodeInfo
e forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *). MonadCError m => NodeInfo -> Type -> m ()
checkIntegral' NodeInfo
ni
forall (m :: * -> *).
MonadTrav m =>
[StmtCtx] -> CStatement NodeInfo -> m Type
tStmt [StmtCtx]
c CStatement NodeInfo
s
tStmt [StmtCtx]
c (CCases CExpression NodeInfo
e1 CExpression NodeInfo
e2 CStatement NodeInfo
s NodeInfo
ni) =
do forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([StmtCtx] -> Bool
inSwitch [StmtCtx]
c) forall a b. (a -> b) -> a -> b
$
forall (m :: * -> *) a. MonadCError m => NodeInfo -> [Char] -> m a
astError NodeInfo
ni [Char]
"case statement outside of switch statement"
forall (m :: * -> *).
MonadTrav m =>
[StmtCtx] -> ExprSide -> CExpression NodeInfo -> m Type
tExpr [StmtCtx]
c ExprSide
RValue CExpression NodeInfo
e1 forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *). MonadCError m => NodeInfo -> Type -> m ()
checkIntegral' NodeInfo
ni
forall (m :: * -> *).
MonadTrav m =>
[StmtCtx] -> ExprSide -> CExpression NodeInfo -> m Type
tExpr [StmtCtx]
c ExprSide
RValue CExpression NodeInfo
e2 forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *). MonadCError m => NodeInfo -> Type -> m ()
checkIntegral' NodeInfo
ni
forall (m :: * -> *).
MonadTrav m =>
[StmtCtx] -> CStatement NodeInfo -> m Type
tStmt [StmtCtx]
c CStatement NodeInfo
s
tStmt [StmtCtx]
c (CDefault CStatement NodeInfo
s NodeInfo
ni) =
do forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([StmtCtx] -> Bool
inSwitch [StmtCtx]
c) forall a b. (a -> b) -> a -> b
$
forall (m :: * -> *) a. MonadCError m => NodeInfo -> [Char] -> m a
astError NodeInfo
ni [Char]
"default statement outside of switch statement"
forall (m :: * -> *).
MonadTrav m =>
[StmtCtx] -> CStatement NodeInfo -> m Type
tStmt [StmtCtx]
c CStatement NodeInfo
s
tStmt [StmtCtx]
c (CFor Either (Maybe (CExpression NodeInfo)) (CDeclaration NodeInfo)
i Maybe (CExpression NodeInfo)
g Maybe (CExpression NodeInfo)
inc CStatement NodeInfo
s NodeInfo
_) =
do forall (m :: * -> *). MonadSymtab m => m ()
enterBlockScope
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (m :: * -> *) a. Monad m => a -> m a
return ()) forall {m :: * -> *}. MonadTrav m => CExpression NodeInfo -> m ()
checkExpr) (forall (m :: * -> *).
MonadTrav m =>
Bool -> CDeclaration NodeInfo -> m ()
analyseDecl Bool
True) Either (Maybe (CExpression NodeInfo)) (CDeclaration NodeInfo)
i
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (m :: * -> *) a. Monad m => a -> m a
return ()) (forall (m :: * -> *).
MonadTrav m =>
[StmtCtx] -> CExpression NodeInfo -> m ()
checkGuard [StmtCtx]
c) Maybe (CExpression NodeInfo)
g
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (m :: * -> *) a. Monad m => a -> m a
return ()) forall {m :: * -> *}. MonadTrav m => CExpression NodeInfo -> m ()
checkExpr Maybe (CExpression NodeInfo)
inc
Type
_ <- forall (m :: * -> *).
MonadTrav m =>
[StmtCtx] -> CStatement NodeInfo -> m Type
tStmt (StmtCtx
LoopCtx forall a. a -> [a] -> [a]
: [StmtCtx]
c) CStatement NodeInfo
s
forall (m :: * -> *). MonadSymtab m => m ()
leaveBlockScope
forall (m :: * -> *) a. Monad m => a -> m a
return Type
voidType
where checkExpr :: CExpression NodeInfo -> m ()
checkExpr CExpression NodeInfo
e = forall (m :: * -> *) a. Monad m => m a -> m ()
voidMforall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
MonadTrav m =>
[StmtCtx] -> ExprSide -> CExpression NodeInfo -> m Type
tExpr [StmtCtx]
c ExprSide
RValue CExpression NodeInfo
e
tStmt [StmtCtx]
c (CGotoPtr CExpression NodeInfo
e NodeInfo
ni) =
do Type
t <- forall (m :: * -> *).
MonadTrav m =>
[StmtCtx] -> ExprSide -> CExpression NodeInfo -> m Type
tExpr [StmtCtx]
c ExprSide
RValue CExpression NodeInfo
e
case Type
t of
(PtrType Type
_ TypeQuals
_ Attributes
_) -> forall (m :: * -> *) a. Monad m => a -> m a
return Type
voidType
Type
_ -> forall (m :: * -> *) a. MonadCError m => NodeInfo -> [Char] -> m a
typeError NodeInfo
ni [Char]
"can't goto non-pointer"
tBlockItem :: MonadTrav m => [StmtCtx] -> CBlockItem -> m Type
tBlockItem :: forall (m :: * -> *).
MonadTrav m =>
[StmtCtx] -> CCompoundBlockItem NodeInfo -> m Type
tBlockItem [StmtCtx]
c (CBlockStmt CStatement NodeInfo
s) = forall (m :: * -> *).
MonadTrav m =>
[StmtCtx] -> CStatement NodeInfo -> m Type
tStmt [StmtCtx]
c CStatement NodeInfo
s
tBlockItem [StmtCtx]
_ (CBlockDecl CDeclaration NodeInfo
d) = forall (m :: * -> *).
MonadTrav m =>
Bool -> CDeclaration NodeInfo -> m ()
analyseDecl Bool
True CDeclaration NodeInfo
d forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return Type
voidType
tBlockItem [StmtCtx]
_ (CNestedFunDef CFunctionDef NodeInfo
fd) = forall (m :: * -> *). MonadTrav m => CFunctionDef NodeInfo -> m ()
analyseFunDef CFunctionDef NodeInfo
fd forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return Type
voidType
checkGuard :: MonadTrav m => [StmtCtx] -> CExpr -> m ()
checkGuard :: forall (m :: * -> *).
MonadTrav m =>
[StmtCtx] -> CExpression NodeInfo -> m ()
checkGuard [StmtCtx]
c CExpression NodeInfo
e = forall (m :: * -> *).
MonadTrav m =>
[StmtCtx] -> ExprSide -> CExpression NodeInfo -> m Type
tExpr [StmtCtx]
c ExprSide
RValue CExpression NodeInfo
e forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *). MonadCError m => NodeInfo -> Type -> m ()
checkScalar' (forall a. CNode a => a -> NodeInfo
nodeInfo CExpression NodeInfo
e)
defaultMD :: MachineDesc
defaultMD :: MachineDesc
defaultMD =
MachineDesc
{ iSize :: IntType -> Integer
iSize = \IntType
it ->
case IntType
it of
IntType
TyBool -> Integer
1
IntType
TyChar -> Integer
1
IntType
TySChar -> Integer
1
IntType
TyUChar -> Integer
1
IntType
TyShort -> Integer
2
IntType
TyUShort -> Integer
2
IntType
TyInt -> Integer
4
IntType
TyUInt -> Integer
4
IntType
TyLong -> Integer
4
IntType
TyULong -> Integer
4
IntType
TyLLong -> Integer
8
IntType
TyULLong -> Integer
8
IntType
TyInt128 -> Integer
16
IntType
TyUInt128 -> Integer
16
, fSize :: FloatType -> Integer
fSize = \FloatType
ft ->
case FloatType
ft of
FloatType
TyFloat -> Integer
4
FloatType
TyDouble -> Integer
8
FloatType
TyLDouble -> Integer
16
, builtinSize :: BuiltinType -> Integer
builtinSize = \BuiltinType
bt ->
case BuiltinType
bt of
BuiltinType
TyVaList -> Integer
4
BuiltinType
TyAny -> Integer
4
, ptrSize :: Integer
ptrSize = Integer
4
, voidSize :: Integer
voidSize = Integer
1
, iAlign :: IntType -> Integer
iAlign = \IntType
it ->
case IntType
it of
IntType
TyBool -> Integer
1
IntType
TyChar -> Integer
1
IntType
TySChar -> Integer
1
IntType
TyUChar -> Integer
1
IntType
TyShort -> Integer
2
IntType
TyUShort -> Integer
2
IntType
TyInt -> Integer
4
IntType
TyUInt -> Integer
4
IntType
TyLong -> Integer
4
IntType
TyULong -> Integer
4
IntType
TyLLong -> Integer
8
IntType
TyULLong -> Integer
8
IntType
TyInt128 -> Integer
16
IntType
TyUInt128 -> Integer
16
, fAlign :: FloatType -> Integer
fAlign = \FloatType
ft ->
case FloatType
ft of
FloatType
TyFloat -> Integer
4
FloatType
TyDouble -> Integer
8
FloatType
TyLDouble -> Integer
16
, builtinAlign :: BuiltinType -> Integer
builtinAlign = \BuiltinType
bt ->
case BuiltinType
bt of
BuiltinType
TyVaList -> Integer
4
BuiltinType
TyAny -> Integer
4
, ptrAlign :: Integer
ptrAlign = Integer
4
, voidAlign :: Integer
voidAlign = Integer
1
}
tExpr :: MonadTrav m => [StmtCtx] -> ExprSide -> CExpr -> m Type
tExpr :: forall (m :: * -> *).
MonadTrav m =>
[StmtCtx] -> ExprSide -> CExpression NodeInfo -> m Type
tExpr [StmtCtx]
c ExprSide
side CExpression NodeInfo
e =
case NodeInfo -> Maybe Name
nameOfNode (forall a. CNode a => a -> NodeInfo
nodeInfo CExpression NodeInfo
e) of
Just Name
n ->
do DefTable
dt <- forall (m :: * -> *). MonadSymtab m => m DefTable
getDefTable
case DefTable -> Name -> Maybe Type
lookupType DefTable
dt Name
n of
Just Type
t -> forall (m :: * -> *) a. Monad m => a -> m a
return Type
t
Maybe Type
Nothing ->
do Type
t <- forall (m :: * -> *).
MonadTrav m =>
[StmtCtx] -> ExprSide -> CExpression NodeInfo -> m Type
tExpr' [StmtCtx]
c ExprSide
side CExpression NodeInfo
e
forall (m :: * -> *) a.
MonadSymtab m =>
(DefTable -> (a, DefTable)) -> m a
withDefTable (\DefTable
dt' -> (Type
t, DefTable -> Name -> Type -> DefTable
insertType DefTable
dt' Name
n Type
t))
Maybe Name
Nothing -> forall (m :: * -> *).
MonadTrav m =>
[StmtCtx] -> ExprSide -> CExpression NodeInfo -> m Type
tExpr' [StmtCtx]
c ExprSide
side CExpression NodeInfo
e
tExpr' :: MonadTrav m => [StmtCtx] -> ExprSide -> CExpr -> m Type
tExpr' :: forall (m :: * -> *).
MonadTrav m =>
[StmtCtx] -> ExprSide -> CExpression NodeInfo -> m Type
tExpr' [StmtCtx]
c ExprSide
side (CBinary CBinaryOp
op CExpression NodeInfo
le CExpression NodeInfo
re NodeInfo
ni) =
do forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ExprSide
side forall a. Eq a => a -> a -> Bool
== ExprSide
LValue) forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadCError m => NodeInfo -> [Char] -> m a
typeError NodeInfo
ni [Char]
"binary operator as lvalue"
Type
lt <- forall (m :: * -> *).
MonadTrav m =>
[StmtCtx] -> ExprSide -> CExpression NodeInfo -> m Type
tExpr [StmtCtx]
c ExprSide
RValue CExpression NodeInfo
le
Type
rt <- forall (m :: * -> *).
MonadTrav m =>
[StmtCtx] -> ExprSide -> CExpression NodeInfo -> m Type
tExpr [StmtCtx]
c ExprSide
RValue CExpression NodeInfo
re
forall (m :: * -> *).
MonadCError m =>
NodeInfo -> CBinaryOp -> Type -> Type -> m Type
binopType' NodeInfo
ni CBinaryOp
op Type
lt Type
rt
tExpr' [StmtCtx]
c ExprSide
side (CUnary CUnaryOp
CAdrOp CExpression NodeInfo
e NodeInfo
ni) =
do forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ExprSide
side forall a. Eq a => a -> a -> Bool
== ExprSide
LValue) forall a b. (a -> b) -> a -> b
$
forall (m :: * -> *) a. MonadCError m => NodeInfo -> [Char] -> m a
typeError NodeInfo
ni [Char]
"address-of operator as lvalue"
case CExpression NodeInfo
e of
CCompoundLit CDeclaration NodeInfo
_ CInitializerList NodeInfo
_ NodeInfo
_ -> Type -> Type
simplePtr forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
`liftM` forall (m :: * -> *).
MonadTrav m =>
[StmtCtx] -> ExprSide -> CExpression NodeInfo -> m Type
tExpr [StmtCtx]
c ExprSide
RValue CExpression NodeInfo
e
CVar Ident
i NodeInfo
_ -> forall (m :: * -> *).
(MonadCError m, MonadSymtab m) =>
Ident -> m (Maybe IdentDecl)
lookupObject Ident
i forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
forall (m :: * -> *) a.
MonadCError m =>
NodeInfo -> Either [Char] a -> m a
typeErrorOnLeft NodeInfo
ni forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall a. Ident -> Either [Char] a
notFound Ident
i) IdentDecl -> Either [Char] Type
varAddrType
CExpression NodeInfo
_ -> Type -> Type
simplePtr forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
`liftM` forall (m :: * -> *).
MonadTrav m =>
[StmtCtx] -> ExprSide -> CExpression NodeInfo -> m Type
tExpr [StmtCtx]
c ExprSide
LValue CExpression NodeInfo
e
tExpr' [StmtCtx]
c ExprSide
_ (CUnary CUnaryOp
CIndOp CExpression NodeInfo
e NodeInfo
ni) =
forall (m :: * -> *).
MonadTrav m =>
[StmtCtx] -> ExprSide -> CExpression NodeInfo -> m Type
tExpr [StmtCtx]
c ExprSide
RValue CExpression NodeInfo
e forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (forall (m :: * -> *) a.
MonadCError m =>
NodeInfo -> Either [Char] a -> m a
typeErrorOnLeft NodeInfo
ni forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> Either [Char] Type
derefType)
tExpr' [StmtCtx]
c ExprSide
_ (CUnary CUnaryOp
CCompOp CExpression NodeInfo
e NodeInfo
ni) =
do Type
t <- forall (m :: * -> *).
MonadTrav m =>
[StmtCtx] -> ExprSide -> CExpression NodeInfo -> m Type
tExpr [StmtCtx]
c ExprSide
RValue CExpression NodeInfo
e
forall (m :: * -> *). MonadCError m => NodeInfo -> Type -> m ()
checkIntegral' NodeInfo
ni Type
t
forall (m :: * -> *) a. Monad m => a -> m a
return Type
t
tExpr' [StmtCtx]
c ExprSide
side (CUnary CUnaryOp
CNegOp CExpression NodeInfo
e NodeInfo
ni) =
do forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ExprSide
side forall a. Eq a => a -> a -> Bool
== ExprSide
LValue) forall a b. (a -> b) -> a -> b
$
forall (m :: * -> *) a. MonadCError m => NodeInfo -> [Char] -> m a
typeError NodeInfo
ni [Char]
"logical negation used as lvalue"
forall (m :: * -> *).
MonadTrav m =>
[StmtCtx] -> ExprSide -> CExpression NodeInfo -> m Type
tExpr [StmtCtx]
c ExprSide
RValue CExpression NodeInfo
e forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *). MonadCError m => NodeInfo -> Type -> m ()
checkScalar' NodeInfo
ni
forall (m :: * -> *) a. Monad m => a -> m a
return Type
boolType
tExpr' [StmtCtx]
c ExprSide
side (CUnary CUnaryOp
op CExpression NodeInfo
e NodeInfo
_) =
forall (m :: * -> *).
MonadTrav m =>
[StmtCtx] -> ExprSide -> CExpression NodeInfo -> m Type
tExpr [StmtCtx]
c (if CUnaryOp -> Bool
isEffectfulOp CUnaryOp
op then ExprSide
LValue else ExprSide
side) CExpression NodeInfo
e
tExpr' [StmtCtx]
c ExprSide
_ (CIndex CExpression NodeInfo
b CExpression NodeInfo
i NodeInfo
ni) =
do Type
bt <- forall (m :: * -> *).
MonadTrav m =>
[StmtCtx] -> ExprSide -> CExpression NodeInfo -> m Type
tExpr [StmtCtx]
c ExprSide
RValue CExpression NodeInfo
b
Type
it <- forall (m :: * -> *).
MonadTrav m =>
[StmtCtx] -> ExprSide -> CExpression NodeInfo -> m Type
tExpr [StmtCtx]
c ExprSide
RValue CExpression NodeInfo
i
Type
addrTy <- forall (m :: * -> *).
MonadCError m =>
NodeInfo -> CBinaryOp -> Type -> Type -> m Type
binopType' NodeInfo
ni CBinaryOp
CAddOp Type
bt Type
it
forall (m :: * -> *) a.
MonadCError m =>
NodeInfo -> Either [Char] a -> m a
typeErrorOnLeft NodeInfo
ni forall a b. (a -> b) -> a -> b
$ Type -> Either [Char] Type
derefType Type
addrTy
tExpr' [StmtCtx]
c ExprSide
side (CCond CExpression NodeInfo
e1 Maybe (CExpression NodeInfo)
me2 CExpression NodeInfo
e3 NodeInfo
ni) =
do Type
t1 <- forall (m :: * -> *).
MonadTrav m =>
[StmtCtx] -> ExprSide -> CExpression NodeInfo -> m Type
tExpr [StmtCtx]
c ExprSide
RValue CExpression NodeInfo
e1
forall (m :: * -> *). MonadCError m => NodeInfo -> Type -> m ()
checkScalar' (forall a. CNode a => a -> NodeInfo
nodeInfo CExpression NodeInfo
e1) Type
t1
Type
t3 <- forall (m :: * -> *).
MonadTrav m =>
[StmtCtx] -> ExprSide -> CExpression NodeInfo -> m Type
tExpr [StmtCtx]
c ExprSide
side CExpression NodeInfo
e3
case Maybe (CExpression NodeInfo)
me2 of
Just CExpression NodeInfo
e2 ->
do Type
t2 <- forall (m :: * -> *).
MonadTrav m =>
[StmtCtx] -> ExprSide -> CExpression NodeInfo -> m Type
tExpr [StmtCtx]
c ExprSide
side CExpression NodeInfo
e2
forall (m :: * -> *).
MonadCError m =>
NodeInfo -> Type -> Type -> m Type
conditionalType' NodeInfo
ni Type
t2 Type
t3
Maybe (CExpression NodeInfo)
Nothing -> forall (m :: * -> *).
MonadCError m =>
NodeInfo -> Type -> Type -> m Type
conditionalType' NodeInfo
ni Type
t1 Type
t3
tExpr' [StmtCtx]
c ExprSide
_ (CMember CExpression NodeInfo
e Ident
m Bool
deref NodeInfo
ni) =
do Type
t <- forall (m :: * -> *).
MonadTrav m =>
[StmtCtx] -> ExprSide -> CExpression NodeInfo -> m Type
tExpr [StmtCtx]
c ExprSide
RValue CExpression NodeInfo
e
Type
bt <- if Bool
deref then forall (m :: * -> *) a.
MonadCError m =>
NodeInfo -> Either [Char] a -> m a
typeErrorOnLeft NodeInfo
ni (Type -> Either [Char] Type
derefType Type
t) else forall (m :: * -> *) a. Monad m => a -> m a
return Type
t
forall (m :: * -> *).
(MonadCError m, MonadSymtab m) =>
NodeInfo -> Ident -> Type -> m Type
fieldType NodeInfo
ni Ident
m Type
bt
tExpr' [StmtCtx]
c ExprSide
side (CComma [CExpression NodeInfo]
es NodeInfo
_) =
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall (m :: * -> *).
MonadTrav m =>
[StmtCtx] -> ExprSide -> CExpression NodeInfo -> m Type
tExpr [StmtCtx]
c ExprSide
side) [CExpression NodeInfo]
es forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> a
last
tExpr' [StmtCtx]
c ExprSide
side (CCast CDeclaration NodeInfo
d CExpression NodeInfo
e NodeInfo
ni) =
do Type
dt <- forall (m :: * -> *).
MonadTrav m =>
CDeclaration NodeInfo -> m Type
analyseTypeDecl CDeclaration NodeInfo
d
Type
et <- forall (m :: * -> *).
MonadTrav m =>
[StmtCtx] -> ExprSide -> CExpression NodeInfo -> m Type
tExpr [StmtCtx]
c ExprSide
side CExpression NodeInfo
e
forall (m :: * -> *) a.
MonadCError m =>
NodeInfo -> Either [Char] a -> m a
typeErrorOnLeft NodeInfo
ni forall a b. (a -> b) -> a -> b
$ Type -> Type -> Either [Char] ()
castCompatible Type
dt Type
et
forall (m :: * -> *) a. Monad m => a -> m a
return Type
dt
tExpr' [StmtCtx]
c ExprSide
side (CSizeofExpr CExpression NodeInfo
e NodeInfo
ni) =
do forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ExprSide
side forall a. Eq a => a -> a -> Bool
== ExprSide
LValue) forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadCError m => NodeInfo -> [Char] -> m a
typeError NodeInfo
ni [Char]
"sizeof as lvalue"
Type
_ <- forall (m :: * -> *).
MonadTrav m =>
[StmtCtx] -> ExprSide -> CExpression NodeInfo -> m Type
tExpr [StmtCtx]
c ExprSide
RValue CExpression NodeInfo
e
forall (m :: * -> *) a. Monad m => a -> m a
return Type
size_tType
tExpr' [StmtCtx]
c ExprSide
side (CAlignofExpr CExpression NodeInfo
e NodeInfo
ni) =
do forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ExprSide
side forall a. Eq a => a -> a -> Bool
== ExprSide
LValue) forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadCError m => NodeInfo -> [Char] -> m a
typeError NodeInfo
ni [Char]
"alignof as lvalue"
Type
_ <- forall (m :: * -> *).
MonadTrav m =>
[StmtCtx] -> ExprSide -> CExpression NodeInfo -> m Type
tExpr [StmtCtx]
c ExprSide
RValue CExpression NodeInfo
e
forall (m :: * -> *) a. Monad m => a -> m a
return Type
size_tType
tExpr' [StmtCtx]
c ExprSide
side (CComplexReal CExpression NodeInfo
e NodeInfo
ni) = forall (m :: * -> *).
MonadTrav m =>
NodeInfo -> [StmtCtx] -> ExprSide -> CExpression NodeInfo -> m Type
complexBaseType NodeInfo
ni [StmtCtx]
c ExprSide
side CExpression NodeInfo
e
tExpr' [StmtCtx]
c ExprSide
side (CComplexImag CExpression NodeInfo
e NodeInfo
ni) = forall (m :: * -> *).
MonadTrav m =>
NodeInfo -> [StmtCtx] -> ExprSide -> CExpression NodeInfo -> m Type
complexBaseType NodeInfo
ni [StmtCtx]
c ExprSide
side CExpression NodeInfo
e
tExpr' [StmtCtx]
_ ExprSide
side (CLabAddrExpr Ident
_ NodeInfo
ni) =
do forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ExprSide
side forall a. Eq a => a -> a -> Bool
== ExprSide
LValue) forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadCError m => NodeInfo -> [Char] -> m a
typeError NodeInfo
ni [Char]
"label address as lvalue"
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Type -> TypeQuals -> Attributes -> Type
PtrType Type
voidType TypeQuals
noTypeQuals []
tExpr' [StmtCtx]
_ ExprSide
side (CCompoundLit CDeclaration NodeInfo
d CInitializerList NodeInfo
initList NodeInfo
ni) =
do forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ExprSide
side forall a. Eq a => a -> a -> Bool
== ExprSide
LValue) forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadCError m => NodeInfo -> [Char] -> m a
typeError NodeInfo
ni [Char]
"compound literal as lvalue"
Type
lt <- forall (m :: * -> *).
MonadTrav m =>
CDeclaration NodeInfo -> m Type
analyseTypeDecl CDeclaration NodeInfo
d
forall (m :: * -> *).
MonadTrav m =>
NodeInfo -> Type -> CInitializerList NodeInfo -> m ()
tInitList NodeInfo
ni (Type -> Type
canonicalType Type
lt) CInitializerList NodeInfo
initList
forall (m :: * -> *) a. Monad m => a -> m a
return Type
lt
tExpr' [StmtCtx]
_ ExprSide
RValue (CAlignofType CDeclaration NodeInfo
_ NodeInfo
_) = forall (m :: * -> *) a. Monad m => a -> m a
return Type
size_tType
tExpr' [StmtCtx]
_ ExprSide
RValue (CSizeofType CDeclaration NodeInfo
_ NodeInfo
_) = forall (m :: * -> *) a. Monad m => a -> m a
return Type
size_tType
tExpr' [StmtCtx]
_ ExprSide
LValue (CAlignofType CDeclaration NodeInfo
_ NodeInfo
ni) =
forall (m :: * -> *) a. MonadCError m => NodeInfo -> [Char] -> m a
typeError NodeInfo
ni [Char]
"alignoftype as lvalue"
tExpr' [StmtCtx]
_ ExprSide
LValue (CSizeofType CDeclaration NodeInfo
_ NodeInfo
ni) =
forall (m :: * -> *) a. MonadCError m => NodeInfo -> [Char] -> m a
typeError NodeInfo
ni [Char]
"sizeoftype as lvalue"
tExpr' [StmtCtx]
ctx ExprSide
side (CGenericSelection CExpression NodeInfo
expr [(Maybe (CDeclaration NodeInfo), CExpression NodeInfo)]
list NodeInfo
ni) = do
Type
ty_sel <- forall (m :: * -> *).
MonadTrav m =>
[StmtCtx] -> ExprSide -> CExpression NodeInfo -> m Type
tExpr [StmtCtx]
ctx ExprSide
side CExpression NodeInfo
expr
[(Maybe Type, Type)]
ty_list <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall {m :: * -> *} {t :: * -> *}.
(Traversable t, MonadTrav m) =>
(t (CDeclaration NodeInfo), CExpression NodeInfo)
-> m (t Type, Type)
analyseAssoc [(Maybe (CDeclaration NodeInfo), CExpression NodeInfo)]
list
Maybe Type
def_expr_ty <-
case forall a. (a -> Bool) -> [a] -> [a]
dropWhile (forall a. Maybe a -> Bool
isJust forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) [(Maybe Type, Type)]
ty_list of
[(Maybe Type
Nothing,Type
tExpr'')] -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> Maybe a
Just Type
tExpr'')
[] -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
[(Maybe Type, Type)]
_ -> forall (m :: * -> *) a. MonadCError m => NodeInfo -> [Char] -> m a
astError NodeInfo
ni [Char]
"more than one default clause in generic selection"
case forall a. (a -> Bool) -> [a] -> [a]
dropWhile (forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
True (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> Type -> Bool
typesMatch Type
ty_sel) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) [(Maybe Type, Type)]
ty_list of
((Maybe Type
_,Type
expr_ty) : [(Maybe Type, Type)]
_ ) -> forall (m :: * -> *) a. Monad m => a -> m a
return Type
expr_ty
[] -> case Maybe Type
def_expr_ty of
(Just Type
expr_ty) -> forall (m :: * -> *) a. Monad m => a -> m a
return Type
expr_ty
Maybe Type
Nothing -> forall (m :: * -> *) a. MonadCError m => NodeInfo -> [Char] -> m a
astError NodeInfo
ni ([Char]
"no clause matches for generic selection (not fully supported) - selector type is " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show (forall p. Pretty p => p -> Doc
pretty Type
ty_sel) forall a. [a] -> [a] -> [a]
++
[Char]
", available types are " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show (forall a b. (a -> b) -> [a] -> [b]
map (forall p. Pretty p => p -> Doc
prettyforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall a. HasCallStack => Maybe a -> a
fromJustforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall a b. (a, b) -> a
fst) (forall a. (a -> Bool) -> [a] -> [a]
filter (forall a. Maybe a -> Bool
isJustforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall a b. (a, b) -> a
fst) [(Maybe Type, Type)]
ty_list)))
where
analyseAssoc :: (t (CDeclaration NodeInfo), CExpression NodeInfo)
-> m (t Type, Type)
analyseAssoc (t (CDeclaration NodeInfo)
mdecl,CExpression NodeInfo
expr') = do
t Type
tDecl <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall (m :: * -> *).
MonadTrav m =>
CDeclaration NodeInfo -> m Type
analyseTypeDecl t (CDeclaration NodeInfo)
mdecl
Type
tExpr'' <- forall (m :: * -> *).
MonadTrav m =>
[StmtCtx] -> ExprSide -> CExpression NodeInfo -> m Type
tExpr [StmtCtx]
ctx ExprSide
side CExpression NodeInfo
expr'
forall (m :: * -> *) a. Monad m => a -> m a
return (t Type
tDecl, Type
tExpr'')
typesMatch :: Type -> Type -> Bool
typesMatch (DirectType TypeName
tn1 TypeQuals
_ Attributes
_) (DirectType TypeName
tn2 TypeQuals
_ Attributes
_) = TypeName -> TypeName -> Bool
directTypesMatch TypeName
tn1 TypeName
tn2
typesMatch Type
_ Type
_ = Bool
False
directTypesMatch :: TypeName -> TypeName -> Bool
directTypesMatch TypeName
TyVoid TypeName
TyVoid = Bool
True
directTypesMatch (TyIntegral IntType
t1) (TyIntegral IntType
t2) = IntType
t1 forall a. Eq a => a -> a -> Bool
== IntType
t2
directTypesMatch (TyFloating FloatType
t1) (TyFloating FloatType
t2) = FloatType
t1 forall a. Eq a => a -> a -> Bool
== FloatType
t2
directTypesMatch (TyComplex FloatType
t1) (TyComplex FloatType
t2) = FloatType
t1 forall a. Eq a => a -> a -> Bool
== FloatType
t2
directTypesMatch TypeName
_ TypeName
_ = Bool
False
tExpr' [StmtCtx]
_ ExprSide
_ (CVar Ident
i NodeInfo
ni) =
forall (m :: * -> *).
(MonadCError m, MonadSymtab m) =>
Ident -> m (Maybe IdentDecl)
lookupObject Ident
i forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (m :: * -> *) a.
MonadCError m =>
NodeInfo -> Either [Char] a -> m a
typeErrorOnLeft NodeInfo
ni forall a b. (a -> b) -> a -> b
$ forall a. Ident -> Either [Char] a
notFound Ident
i) (forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall n. Declaration n => n -> Type
declType)
tExpr' [StmtCtx]
_ ExprSide
_ (CConst CConstant NodeInfo
c) = forall (m :: * -> *).
(MonadCError m, MonadName m) =>
CConstant NodeInfo -> m Type
constType CConstant NodeInfo
c
tExpr' [StmtCtx]
_ ExprSide
_ (CBuiltinExpr CBuiltinThing NodeInfo
b) = forall (m :: * -> *).
MonadTrav m =>
CBuiltinThing NodeInfo -> m Type
builtinType CBuiltinThing NodeInfo
b
tExpr' [StmtCtx]
c ExprSide
side (CCall (CVar Ident
i NodeInfo
_) [CExpression NodeInfo]
args NodeInfo
ni)
| Ident -> [Char]
identToString Ident
i forall a. Eq a => a -> a -> Bool
== [Char]
"__builtin_choose_expr" =
case [CExpression NodeInfo]
args of
[CExpression NodeInfo
g, CExpression NodeInfo
e1, CExpression NodeInfo
e2] ->
do CExpression NodeInfo
b <- forall (m :: * -> *).
MonadTrav m =>
MachineDesc
-> Map Ident (CExpression NodeInfo)
-> CExpression NodeInfo
-> m (CExpression NodeInfo)
constEval MachineDesc
defaultMD forall k a. Map k a
Map.empty CExpression NodeInfo
g
case CExpression NodeInfo -> Maybe Bool
boolValue CExpression NodeInfo
b of
Just Bool
True -> forall (m :: * -> *).
MonadTrav m =>
[StmtCtx] -> ExprSide -> CExpression NodeInfo -> m Type
tExpr [StmtCtx]
c ExprSide
side CExpression NodeInfo
e1
Just Bool
False -> forall (m :: * -> *).
MonadTrav m =>
[StmtCtx] -> ExprSide -> CExpression NodeInfo -> m Type
tExpr [StmtCtx]
c ExprSide
side CExpression NodeInfo
e2
Maybe Bool
Nothing ->
forall (m :: * -> *) a. MonadCError m => NodeInfo -> [Char] -> m a
astError NodeInfo
ni [Char]
"non-constant argument to __builtin_choose_expr"
[CExpression NodeInfo]
_ -> forall (m :: * -> *) a. MonadCError m => NodeInfo -> [Char] -> m a
astError NodeInfo
ni [Char]
"wrong number of arguments to __builtin_choose_expr"
tExpr' [StmtCtx]
c ExprSide
_ (CCall CExpression NodeInfo
fe [CExpression NodeInfo]
args NodeInfo
ni) =
do let defType :: Type
defType = FunType -> Attributes -> Type
FunctionType
(Type -> FunType
FunTypeIncomplete
(TypeName -> TypeQuals -> Attributes -> Type
DirectType (IntType -> TypeName
TyIntegral IntType
TyInt) TypeQuals
noTypeQuals Attributes
noAttributes))
Attributes
noAttributes
fallback :: Ident -> m Type
fallback Ident
i = do forall e (m :: * -> *). (Error e, MonadCError m) => e -> m ()
warn forall a b. (a -> b) -> a -> b
$ NodeInfo -> [Char] -> InvalidASTError
invalidAST NodeInfo
ni forall a b. (a -> b) -> a -> b
$
[Char]
"unknown function: " forall a. [a] -> [a] -> [a]
++ Ident -> [Char]
identToString Ident
i
forall (m :: * -> *) a. Monad m => a -> m a
return Type
defType
Type
t <- case CExpression NodeInfo
fe of
CVar Ident
i NodeInfo
_ -> forall (m :: * -> *).
(MonadCError m, MonadSymtab m) =>
Ident -> m (Maybe IdentDecl)
lookupObject Ident
i forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall {m :: * -> *}. MonadCError m => Ident -> m Type
fallback Ident
i) (forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
MonadTrav m =>
[StmtCtx] -> ExprSide -> CExpression NodeInfo -> m Type
tExpr [StmtCtx]
c ExprSide
RValue CExpression NodeInfo
fe)
CExpression NodeInfo
_ -> forall (m :: * -> *).
MonadTrav m =>
[StmtCtx] -> ExprSide -> CExpression NodeInfo -> m Type
tExpr [StmtCtx]
c ExprSide
RValue CExpression NodeInfo
fe
[Type]
atys <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall (m :: * -> *).
MonadTrav m =>
[StmtCtx] -> ExprSide -> CExpression NodeInfo -> m Type
tExpr [StmtCtx]
c ExprSide
RValue) [CExpression NodeInfo]
args
case Type -> Type
canonicalType Type
t of
PtrType (FunctionType (FunType Type
rt [ParamDecl]
pdecls Bool
varargs) Attributes
_) TypeQuals
_ Attributes
_ ->
do let ptys :: [Type]
ptys = forall a b. (a -> b) -> [a] -> [b]
map forall n. Declaration n => n -> Type
declType [ParamDecl]
pdecls
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ forall {m :: * -> *} {a}.
(MonadCError m, MonadSymtab m, CNode a) =>
(Type, Type, a) -> m ()
checkArg forall a b. (a -> b) -> a -> b
$ forall a b c. [a] -> [b] -> [c] -> [(a, b, c)]
zip3 [Type]
ptys [Type]
atys [CExpression NodeInfo]
args
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
varargs forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall (t :: * -> *) a. Foldable t => t a -> Int
length [Type]
atys forall a. Eq a => a -> a -> Bool
/= forall (t :: * -> *) a. Foldable t => t a -> Int
length [Type]
ptys) forall a b. (a -> b) -> a -> b
$
forall (m :: * -> *) a. MonadCError m => NodeInfo -> [Char] -> m a
typeError NodeInfo
ni [Char]
"incorrect number of arguments"
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Type -> Type
canonicalType Type
rt
PtrType (FunctionType (FunTypeIncomplete Type
rt) Attributes
_) TypeQuals
_ Attributes
_ ->
do
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Type -> Type
canonicalType Type
rt
Type
_ -> forall (m :: * -> *) a. MonadCError m => NodeInfo -> [Char] -> m a
typeError NodeInfo
ni forall a b. (a -> b) -> a -> b
$ [Char]
"attempt to call non-function of type " forall a. [a] -> [a] -> [a]
++ Type -> [Char]
pType Type
t
where checkArg :: (Type, Type, a) -> m ()
checkArg (Type
pty, Type
aty, a
arg) =
do Attributes
attrs <- forall (m :: * -> *).
(MonadCError m, MonadSymtab m) =>
Type -> m Attributes
deepTypeAttrs Type
pty
if Attributes -> Bool
isTransparentUnion Attributes
attrs
then
case Type -> Type
canonicalType Type
pty of
DirectType (TyComp CompTypeRef
ctr) TypeQuals
_ Attributes
_ ->
do TagDef
td <- forall (m :: * -> *).
(MonadCError m, MonadSymtab m) =>
NodeInfo -> SUERef -> m TagDef
lookupSUE (forall a. CNode a => a -> NodeInfo
nodeInfo a
arg) (forall a. HasSUERef a => a -> SUERef
sueRef CompTypeRef
ctr)
[(Ident, Type)]
_ms <- forall (m :: * -> *).
(MonadCError m, MonadSymtab m) =>
NodeInfo -> TagDef -> m [(Ident, Type)]
tagMembers (forall a. CNode a => a -> NodeInfo
nodeInfo a
arg) TagDef
td
forall (m :: * -> *) a. Monad m => a -> m a
return ()
Type
_ -> forall (m :: * -> *) a. MonadCError m => NodeInfo -> [Char] -> m a
astError (forall a. CNode a => a -> NodeInfo
nodeInfo a
arg)
[Char]
"non-composite has __transparent_union__ attribute"
else
forall (m :: * -> *).
MonadCError m =>
NodeInfo -> CAssignOp -> Type -> Type -> m ()
assignCompatible' (forall a. CNode a => a -> NodeInfo
nodeInfo a
arg) CAssignOp
CAssignOp Type
pty Type
aty
isTransparentUnion :: Attributes -> Bool
isTransparentUnion =
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (\(Attr Ident
n [CExpression NodeInfo]
_ NodeInfo
_) -> Ident -> [Char]
identToString Ident
n forall a. Eq a => a -> a -> Bool
== [Char]
"__transparent_union__")
tExpr' [StmtCtx]
c ExprSide
_ (CAssign CAssignOp
op CExpression NodeInfo
le CExpression NodeInfo
re NodeInfo
ni) =
do Type
lt <- forall (m :: * -> *).
MonadTrav m =>
[StmtCtx] -> ExprSide -> CExpression NodeInfo -> m Type
tExpr [StmtCtx]
c ExprSide
LValue CExpression NodeInfo
le
Type
rt <- forall (m :: * -> *).
MonadTrav m =>
[StmtCtx] -> ExprSide -> CExpression NodeInfo -> m Type
tExpr [StmtCtx]
c ExprSide
RValue CExpression NodeInfo
re
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (TypeQuals -> Bool
constant forall a b. (a -> b) -> a -> b
$ Type -> TypeQuals
typeQuals Type
lt) forall a b. (a -> b) -> a -> b
$
forall (m :: * -> *) a. MonadCError m => NodeInfo -> [Char] -> m a
typeError NodeInfo
ni forall a b. (a -> b) -> a -> b
$ [Char]
"assignment to lvalue with `constant' qualifier: "
forall a. [a] -> [a] -> [a]
++ (Doc -> [Char]
render forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall p. Pretty p => p -> Doc
pretty) CExpression NodeInfo
le
case (Type -> Type
canonicalType Type
lt, CExpression NodeInfo
re) of
(Type
lt', CConst (CIntConst CInteger
i NodeInfo
_))
| Type -> Bool
isPointerType Type
lt' Bool -> Bool -> Bool
&& CInteger -> Integer
getCInteger CInteger
i forall a. Eq a => a -> a -> Bool
== Integer
0 -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
(Type
_, CExpression NodeInfo
_) -> forall (m :: * -> *).
MonadCError m =>
NodeInfo -> CAssignOp -> Type -> Type -> m ()
assignCompatible' NodeInfo
ni CAssignOp
op Type
lt Type
rt
forall (m :: * -> *) a. Monad m => a -> m a
return Type
lt
tExpr' [StmtCtx]
c ExprSide
_ (CStatExpr CStatement NodeInfo
s NodeInfo
_) =
do forall (m :: * -> *). MonadSymtab m => m ()
enterBlockScope
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (forall (m :: * -> *) a.
MonadSymtab m =>
(DefTable -> (a, DefTable)) -> m a
withDefTable forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ident -> DefTable -> (DeclarationStatus Ident, DefTable)
defineLabel) (CStatement NodeInfo -> [Ident]
getLabels CStatement NodeInfo
s)
Type
t <- forall (m :: * -> *).
MonadTrav m =>
[StmtCtx] -> CStatement NodeInfo -> m Type
tStmt [StmtCtx]
c CStatement NodeInfo
s
forall (m :: * -> *). MonadSymtab m => m ()
leaveBlockScope
forall (m :: * -> *) a. Monad m => a -> m a
return Type
t
tInitList :: MonadTrav m => NodeInfo -> Type -> CInitList -> m ()
tInitList :: forall (m :: * -> *).
MonadTrav m =>
NodeInfo -> Type -> CInitializerList NodeInfo -> m ()
tInitList NodeInfo
_ (ArrayType (DirectType (TyIntegral IntType
TyChar) TypeQuals
_ Attributes
_) ArraySize
_ TypeQuals
_ Attributes
_)
[([], CInitExpr e :: CExpression NodeInfo
e@(CConst (CStrConst CString
_ NodeInfo
_)) NodeInfo
_)] =
forall (m :: * -> *).
MonadTrav m =>
[StmtCtx] -> ExprSide -> CExpression NodeInfo -> m Type
tExpr [] ExprSide
RValue CExpression NodeInfo
e forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return ()
tInitList NodeInfo
ni t :: Type
t@(ArrayType Type
_ ArraySize
_ TypeQuals
_ Attributes
_) CInitializerList NodeInfo
initList =
do let default_ds :: [CPartDesignator NodeInfo]
default_ds =
forall a. a -> [a]
repeat (forall a. CExpression a -> a -> CPartDesignator a
CArrDesig (forall a. CConstant a -> CExpression a
CConst (forall a. CInteger -> a -> CConstant a
CIntConst (Integer -> CInteger
cInteger Integer
0) NodeInfo
ni)) NodeInfo
ni)
forall (m :: * -> *).
MonadTrav m =>
Type
-> [CPartDesignator NodeInfo] -> CInitializerList NodeInfo -> m ()
checkInits Type
t [CPartDesignator NodeInfo]
default_ds CInitializerList NodeInfo
initList
tInitList NodeInfo
ni t :: Type
t@(DirectType (TyComp CompTypeRef
ctr) TypeQuals
_ Attributes
_) CInitializerList NodeInfo
initList =
do TagDef
td <- forall (m :: * -> *).
(MonadCError m, MonadSymtab m) =>
NodeInfo -> SUERef -> m TagDef
lookupSUE NodeInfo
ni (forall a. HasSUERef a => a -> SUERef
sueRef CompTypeRef
ctr)
[(Ident, Type)]
ms <- forall (m :: * -> *).
(MonadCError m, MonadSymtab m) =>
NodeInfo -> TagDef -> m [(Ident, Type)]
tagMembers NodeInfo
ni TagDef
td
let default_ds :: [CPartDesignator NodeInfo]
default_ds = forall a b. (a -> b) -> [a] -> [b]
map (\(Ident, Type)
m -> forall a. Ident -> a -> CPartDesignator a
CMemberDesig (forall a b. (a, b) -> a
fst (Ident, Type)
m) NodeInfo
ni) [(Ident, Type)]
ms
forall (m :: * -> *).
MonadTrav m =>
Type
-> [CPartDesignator NodeInfo] -> CInitializerList NodeInfo -> m ()
checkInits Type
t [CPartDesignator NodeInfo]
default_ds CInitializerList NodeInfo
initList
tInitList NodeInfo
_ (PtrType (DirectType TypeName
TyVoid TypeQuals
_ Attributes
_) TypeQuals
_ Attributes
_ ) CInitializerList NodeInfo
_ =
forall (m :: * -> *) a. Monad m => a -> m a
return ()
tInitList NodeInfo
_ Type
t [([], CInit
i)] = forall (m :: * -> *) a. Monad m => m a -> m ()
voidMforall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). MonadTrav m => Type -> CInit -> m CInit
tInit Type
t CInit
i
tInitList NodeInfo
ni Type
t CInitializerList NodeInfo
_ = forall (m :: * -> *) a. MonadCError m => NodeInfo -> [Char] -> m a
typeError NodeInfo
ni forall a b. (a -> b) -> a -> b
$ [Char]
"initializer list for type: " forall a. [a] -> [a] -> [a]
++ Type -> [Char]
pType Type
t
checkInits :: MonadTrav m => Type -> [CDesignator] -> CInitList -> m ()
checkInits :: forall (m :: * -> *).
MonadTrav m =>
Type
-> [CPartDesignator NodeInfo] -> CInitializerList NodeInfo -> m ()
checkInits Type
_ [CPartDesignator NodeInfo]
_ [] = forall (m :: * -> *) a. Monad m => a -> m a
return ()
checkInits Type
t [CPartDesignator NodeInfo]
dds (([CPartDesignator NodeInfo]
ds, CInit
i) : CInitializerList NodeInfo
is) =
do ([CPartDesignator NodeInfo]
dds', [CPartDesignator NodeInfo]
ds') <- case ([CPartDesignator NodeInfo]
dds, [CPartDesignator NodeInfo]
ds) of
([], []) ->
forall (m :: * -> *) a. MonadCError m => NodeInfo -> [Char] -> m a
typeError (forall a. CNode a => a -> NodeInfo
nodeInfo CInit
i) [Char]
"excess elements in initializer"
(CPartDesignator NodeInfo
dd' : [CPartDesignator NodeInfo]
rest, []) -> forall (m :: * -> *) a. Monad m => a -> m a
return ([CPartDesignator NodeInfo]
rest, [CPartDesignator NodeInfo
dd'])
([CPartDesignator NodeInfo]
_, CPartDesignator NodeInfo
d : [CPartDesignator NodeInfo]
_) -> forall (m :: * -> *) a. Monad m => a -> m a
return ([CPartDesignator NodeInfo]
-> CPartDesignator NodeInfo -> [CPartDesignator NodeInfo]
advanceDesigList [CPartDesignator NodeInfo]
dds CPartDesignator NodeInfo
d, [CPartDesignator NodeInfo]
ds)
Type
t' <- forall (m :: * -> *).
MonadTrav m =>
Type -> [CPartDesignator NodeInfo] -> m Type
tDesignator Type
t [CPartDesignator NodeInfo]
ds'
CInit
_ <- forall (m :: * -> *). MonadTrav m => Type -> CInit -> m CInit
tInit Type
t' CInit
i
forall (m :: * -> *).
MonadTrav m =>
Type
-> [CPartDesignator NodeInfo] -> CInitializerList NodeInfo -> m ()
checkInits Type
t [CPartDesignator NodeInfo]
dds' CInitializerList NodeInfo
is
advanceDesigList :: [CDesignator] -> CDesignator -> [CDesignator]
advanceDesigList :: [CPartDesignator NodeInfo]
-> CPartDesignator NodeInfo -> [CPartDesignator NodeInfo]
advanceDesigList [CPartDesignator NodeInfo]
ds CPartDesignator NodeInfo
d = forall a. Int -> [a] -> [a]
drop Int
1 forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> [a] -> [a]
dropWhile (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. CPartDesignator NodeInfo -> CPartDesignator NodeInfo -> Bool
matchDesignator CPartDesignator NodeInfo
d) [CPartDesignator NodeInfo]
ds
matchDesignator :: CDesignator -> CDesignator -> Bool
matchDesignator :: CPartDesignator NodeInfo -> CPartDesignator NodeInfo -> Bool
matchDesignator (CMemberDesig Ident
m1 NodeInfo
_) (CMemberDesig Ident
m2 NodeInfo
_) = Ident
m1 forall a. Eq a => a -> a -> Bool
== Ident
m2
matchDesignator CPartDesignator NodeInfo
_ CPartDesignator NodeInfo
_ = Bool
True
tDesignator :: MonadTrav m => Type -> [CDesignator] -> m Type
tDesignator :: forall (m :: * -> *).
MonadTrav m =>
Type -> [CPartDesignator NodeInfo] -> m Type
tDesignator (ArrayType Type
bt ArraySize
_ TypeQuals
_ Attributes
_) (CArrDesig CExpression NodeInfo
e NodeInfo
ni : [CPartDesignator NodeInfo]
ds) =
do forall (m :: * -> *).
MonadTrav m =>
[StmtCtx] -> ExprSide -> CExpression NodeInfo -> m Type
tExpr [] ExprSide
RValue CExpression NodeInfo
e forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *). MonadCError m => NodeInfo -> Type -> m ()
checkIntegral' NodeInfo
ni
forall (m :: * -> *).
MonadTrav m =>
Type -> [CPartDesignator NodeInfo] -> m Type
tDesignator Type
bt [CPartDesignator NodeInfo]
ds
tDesignator (ArrayType Type
bt ArraySize
_ TypeQuals
_ Attributes
_) (CRangeDesig CExpression NodeInfo
e1 CExpression NodeInfo
e2 NodeInfo
ni : [CPartDesignator NodeInfo]
ds) =
do forall (m :: * -> *).
MonadTrav m =>
[StmtCtx] -> ExprSide -> CExpression NodeInfo -> m Type
tExpr [] ExprSide
RValue CExpression NodeInfo
e1 forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *). MonadCError m => NodeInfo -> Type -> m ()
checkIntegral' NodeInfo
ni
forall (m :: * -> *).
MonadTrav m =>
[StmtCtx] -> ExprSide -> CExpression NodeInfo -> m Type
tExpr [] ExprSide
RValue CExpression NodeInfo
e2 forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *). MonadCError m => NodeInfo -> Type -> m ()
checkIntegral' NodeInfo
ni
forall (m :: * -> *).
MonadTrav m =>
Type -> [CPartDesignator NodeInfo] -> m Type
tDesignator Type
bt [CPartDesignator NodeInfo]
ds
tDesignator (ArrayType Type
_ ArraySize
_ TypeQuals
_ Attributes
_) (CPartDesignator NodeInfo
d : [CPartDesignator NodeInfo]
_) =
forall (m :: * -> *) a. MonadCError m => NodeInfo -> [Char] -> m a
typeError (forall a. CNode a => a -> NodeInfo
nodeInfo CPartDesignator NodeInfo
d) [Char]
"member designator in array initializer"
tDesignator t :: Type
t@(DirectType (TyComp CompTypeRef
_) TypeQuals
_ Attributes
_) (CMemberDesig Ident
m NodeInfo
ni : [CPartDesignator NodeInfo]
ds) =
do Type
mt <- forall (m :: * -> *).
(MonadCError m, MonadSymtab m) =>
NodeInfo -> Ident -> Type -> m Type
fieldType NodeInfo
ni Ident
m Type
t
forall (m :: * -> *).
MonadTrav m =>
Type -> [CPartDesignator NodeInfo] -> m Type
tDesignator (Type -> Type
canonicalType Type
mt) [CPartDesignator NodeInfo]
ds
tDesignator (DirectType (TyComp CompTypeRef
_) TypeQuals
_ Attributes
_) (CPartDesignator NodeInfo
d : [CPartDesignator NodeInfo]
_) =
forall (m :: * -> *) a. MonadCError m => NodeInfo -> [Char] -> m a
typeError (forall a. CNode a => a -> NodeInfo
nodeInfo CPartDesignator NodeInfo
d) [Char]
"array designator in compound initializer"
tDesignator Type
t [] = forall (m :: * -> *) a. Monad m => a -> m a
return Type
t
tDesignator Type
_t [CPartDesignator NodeInfo]
_ =
forall a. HasCallStack => [Char] -> a
error [Char]
"unepxected type with designator"
tInit :: MonadTrav m => Type -> CInit -> m Initializer
tInit :: forall (m :: * -> *). MonadTrav m => Type -> CInit -> m CInit
tInit Type
t i :: CInit
i@(CInitExpr CExpression NodeInfo
e NodeInfo
ni) =
do Type
it <- forall (m :: * -> *).
MonadTrav m =>
[StmtCtx] -> ExprSide -> CExpression NodeInfo -> m Type
tExpr [] ExprSide
RValue CExpression NodeInfo
e
forall (m :: * -> *).
MonadCError m =>
NodeInfo -> CAssignOp -> Type -> Type -> m ()
assignCompatible' NodeInfo
ni CAssignOp
CAssignOp Type
t Type
it
forall (m :: * -> *) a. Monad m => a -> m a
return CInit
i
tInit Type
t i :: CInit
i@(CInitList CInitializerList NodeInfo
initList NodeInfo
ni) =
forall (m :: * -> *).
MonadTrav m =>
NodeInfo -> Type -> CInitializerList NodeInfo -> m ()
tInitList NodeInfo
ni (Type -> Type
canonicalType Type
t) CInitializerList NodeInfo
initList forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return CInit
i
complexBaseType :: MonadTrav m => NodeInfo -> [StmtCtx] -> ExprSide -> CExpr -> m Type
complexBaseType :: forall (m :: * -> *).
MonadTrav m =>
NodeInfo -> [StmtCtx] -> ExprSide -> CExpression NodeInfo -> m Type
complexBaseType NodeInfo
ni [StmtCtx]
c ExprSide
side CExpression NodeInfo
e =
do Type
t <- forall (m :: * -> *).
MonadTrav m =>
[StmtCtx] -> ExprSide -> CExpression NodeInfo -> m Type
tExpr [StmtCtx]
c ExprSide
side CExpression NodeInfo
e
case Type -> Type
canonicalType Type
t of
DirectType (TyComplex FloatType
ft) TypeQuals
quals Attributes
attrs ->
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ TypeName -> TypeQuals -> Attributes -> Type
DirectType (FloatType -> TypeName
TyFloating FloatType
ft) TypeQuals
quals Attributes
attrs
Type
_ -> forall (m :: * -> *) a. MonadCError m => NodeInfo -> [Char] -> m a
typeError NodeInfo
ni forall a b. (a -> b) -> a -> b
$ [Char]
"expected complex type, got: " forall a. [a] -> [a] -> [a]
++ Type -> [Char]
pType Type
t
builtinType :: MonadTrav m => CBuiltin -> m Type
builtinType :: forall (m :: * -> *).
MonadTrav m =>
CBuiltinThing NodeInfo -> m Type
builtinType (CBuiltinVaArg CExpression NodeInfo
_ CDeclaration NodeInfo
d NodeInfo
_) = forall (m :: * -> *).
MonadTrav m =>
CDeclaration NodeInfo -> m Type
analyseTypeDecl CDeclaration NodeInfo
d
builtinType (CBuiltinOffsetOf CDeclaration NodeInfo
_ [CPartDesignator NodeInfo]
_ NodeInfo
_) = forall (m :: * -> *) a. Monad m => a -> m a
return Type
size_tType
builtinType (CBuiltinTypesCompatible CDeclaration NodeInfo
_ CDeclaration NodeInfo
_ NodeInfo
_) = forall (m :: * -> *) a. Monad m => a -> m a
return Type
boolType
builtinType (CBuiltinConvertVector CExpression NodeInfo
_expr CDeclaration NodeInfo
ty NodeInfo
_) = forall (m :: * -> *).
MonadTrav m =>
CDeclaration NodeInfo -> m Type
analyseTypeDecl CDeclaration NodeInfo
ty
hasTypeDef :: [CDeclSpec] -> Maybe [CDeclSpec]
hasTypeDef :: [CDeclarationSpecifier NodeInfo]
-> Maybe [CDeclarationSpecifier NodeInfo]
hasTypeDef [CDeclarationSpecifier NodeInfo]
declspecs =
case forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr forall {a}.
CDeclarationSpecifier a
-> (Bool, [CDeclarationSpecifier a])
-> (Bool, [CDeclarationSpecifier a])
hasTypeDefSpec (Bool
False,[]) [CDeclarationSpecifier NodeInfo]
declspecs of
(Bool
True,[CDeclarationSpecifier NodeInfo]
specs') -> forall a. a -> Maybe a
Just [CDeclarationSpecifier NodeInfo]
specs'
(Bool
False,[CDeclarationSpecifier NodeInfo]
_) -> forall a. Maybe a
Nothing
where
hasTypeDefSpec :: CDeclarationSpecifier a
-> (Bool, [CDeclarationSpecifier a])
-> (Bool, [CDeclarationSpecifier a])
hasTypeDefSpec (CStorageSpec (CTypedef a
_)) (Bool
_,[CDeclarationSpecifier a]
specs) = (Bool
True, [CDeclarationSpecifier a]
specs)
hasTypeDefSpec CDeclarationSpecifier a
spec (Bool
b,[CDeclarationSpecifier a]
specs) = (Bool
b,CDeclarationSpecifier a
specforall a. a -> [a] -> [a]
:[CDeclarationSpecifier a]
specs)