{-# LANGUAGE PatternGuards, FlexibleContexts #-}
module Language.C.Analysis.DeclAnalysis (
analyseTypeDecl,
tType,tDirectType,tNumType,tArraySize,tTypeQuals,
mergeOldStyle,
canonicalTypeSpec, NumBaseType(..),SignSpec(..),SizeMod(..),NumTypeSpec(..),TypeSpecAnalysis(..),
canonicalStorageSpec, StorageSpec(..), hasThreadLocalSpec, isTypeDef,
VarDeclInfo(..),
tAttr,mkVarName,getOnlyDeclr,nameOfDecl,analyseVarDecl,analyseVarDecl'
)
where
import Language.C.Data.Error
import Language.C.Data.Node
import Language.C.Data.Ident
import Language.C.Pretty
import Language.C.Syntax
import {-# SOURCE #-} Language.C.Analysis.AstAnalysis (tExpr, ExprSide(..))
import Language.C.Analysis.DefTable (TagFwdDecl(..), insertType)
import Language.C.Analysis.SemError
import Language.C.Analysis.SemRep
import Language.C.Analysis.TravMonad
import Data.Foldable as F (foldrM)
import Control.Monad (liftM,when,ap,unless,zipWithM)
import Data.List (intercalate, mapAccumL)
import qualified Data.Map as Map
import Text.PrettyPrint.HughesPJ
tParamDecl :: (MonadTrav m) => CDecl -> m ParamDecl
tParamDecl (CStaticAssert _ _ node) =
astError node "expected parameter, not static assertion"
tParamDecl (CDecl declspecs declrs node) =
do declr <- getParamDeclr
(VarDeclInfo name fun_spec storage_spec attrs ty declr_node) <- analyseVarDecl' True declspecs declr [] Nothing
when (isInline fun_spec || isNoreturn fun_spec) $
throwTravError (badSpecifierError node "parameter declaration with function specifier")
storage <- throwOnLeft $ computeParamStorage node storage_spec
let paramDecl = mkParamDecl name storage attrs ty declr_node
return paramDecl
where
getParamDeclr =
case declrs of
[] -> return (emptyDeclr node)
[(Just declr,Nothing,Nothing)] -> return declr
_ -> astError node "bad parameter declaration: multiple decls / bitfield or initializer present"
mkParamDecl name storage attrs ty declr_node =
let vd = VarDecl name (DeclAttrs noFunctionAttrs storage attrs) ty in
case name of
NoName -> AbstractParamDecl vd declr_node
_ -> ParamDecl vd declr_node
computeParamStorage :: NodeInfo -> StorageSpec -> Either BadSpecifierError Storage
computeParamStorage _ NoStorageSpec = Right (Auto False)
computeParamStorage _ RegSpec = Right (Auto True)
computeParamStorage node spec = Left . badSpecifierError node $ "Bad storage specified for parameter: " ++ show spec
tMemberDecls :: (MonadTrav m) => CDecl -> m [MemberDecl]
tMemberDecls (CStaticAssert _ _ node) =
astError node "expected struct or union member, found static assertion"
tMemberDecls (CDecl declspecs [] node) =
do let (_storage_specs, _attrs, typequals, typespecs, funspecs, _alignspecs) =
partitionDeclSpecs declspecs
unless (null funspecs) $ astError node "member declaration with function specifier"
canonTySpecs <- canonicalTypeSpec typespecs
ty <- tType True node typequals canonTySpecs [] []
case ty of
DirectType (TyComp _) _ _ ->
return $ [MemberDecl
(VarDecl NoName (DeclAttrs noFunctionAttrs NoStorage []) ty)
Nothing node]
_ -> astError node "anonymous member has a non-composite type"
tMemberDecls (CDecl declspecs declrs node) = zipWithM tMemberDecl (True:repeat False) declrs
where
tMemberDecl handle_sue_def (Just member_declr,Nothing,bit_field_size_opt) =
do var_decl <- analyseVarDecl' handle_sue_def declspecs member_declr [] Nothing
let (VarDeclInfo name fun_spec storage_spec attrs ty _node_info) = var_decl
checkValidMemberSpec fun_spec storage_spec
return $ MemberDecl (VarDecl name (DeclAttrs noFunctionAttrs NoStorage attrs) ty)
bit_field_size_opt node
tMemberDecl handle_sue_def (Nothing,Nothing,Just bit_field_size) =
do let (storage_specs, _attrs, typequals, typespecs, _funspecs, _alignspecs) = partitionDeclSpecs declspecs
_storage_spec <- canonicalStorageSpec storage_specs
canonTySpecs <- canonicalTypeSpec typespecs
typ <- tType handle_sue_def node typequals canonTySpecs [] []
return $ AnonBitField typ bit_field_size node
tMemberDecl _ _ = astError node "Bad member declaration"
checkValidMemberSpec fun_spec storage_spec =
do when (fun_spec /= noFunctionAttrs) $ astError node "member declaration with inline specifier"
when (storage_spec /= NoStorageSpec) $ astError node "storage specifier for member"
return ()
data StorageSpec = NoStorageSpec | AutoSpec | RegSpec | ThreadSpec | StaticSpec Bool | ExternSpec Bool
deriving (Eq,Ord,Show,Read)
hasThreadLocalSpec :: StorageSpec -> Bool
hasThreadLocalSpec ThreadSpec = True
hasThreadLocalSpec (StaticSpec b) = b
hasThreadLocalSpec (ExternSpec b) = b
hasThreadLocalSpec _ = False
data VarDeclInfo = VarDeclInfo VarName FunctionAttrs StorageSpec Attributes Type NodeInfo
analyseVarDecl' :: (MonadTrav m) =>
Bool -> [CDeclSpec] ->
CDeclr -> [CDecl] -> Maybe CInit -> m VarDeclInfo
analyseVarDecl' handle_sue_def declspecs declr oldstyle init_opt =
do let (storage_specs, attrs, type_quals, type_specs, funspecs, _alignspecs) =
partitionDeclSpecs declspecs
canonTySpecs <- canonicalTypeSpec type_specs
analyseVarDecl handle_sue_def storage_specs attrs type_quals canonTySpecs funspecs
declr oldstyle init_opt
analyseVarDecl :: (MonadTrav m) =>
Bool -> [CStorageSpec] -> [CAttr] -> [CTypeQual] ->
TypeSpecAnalysis -> [CFunSpec] ->
CDeclr -> [CDecl] -> Maybe CInit -> m VarDeclInfo
analyseVarDecl handle_sue_def storage_specs decl_attrs typequals canonTySpecs fun_specs
(CDeclr name_opt derived_declrs asmname_opt declr_attrs node)
oldstyle_params _init_opt
= do
storage_spec <- canonicalStorageSpec storage_specs
typ <- tType handle_sue_def node typequals canonTySpecs derived_declrs oldstyle_params
attrs' <- mapM tAttr (decl_attrs ++ declr_attrs)
name <- mkVarName node name_opt asmname_opt
return $ VarDeclInfo name function_spec storage_spec attrs' typ node
where
updateFunSpec (CInlineQual _) f = f { isInline = True }
updateFunSpec (CNoreturnQual _) f = f { isNoreturn = True }
function_spec = foldr updateFunSpec noFunctionAttrs fun_specs
isTypeDef :: [CDeclSpec] -> Bool
isTypeDef declspecs = not $ null [ n | (CStorageSpec (CTypedef n)) <- declspecs ]
analyseTypeDecl :: (MonadTrav m) => CDecl -> m Type
analyseTypeDecl (CStaticAssert _ _ node) =
astError node "Expected type declaration, found static assert"
analyseTypeDecl (CDecl declspecs declrs node)
| [] <- declrs = analyseTyDeclr (emptyDeclr node)
| [(Just declr,Nothing,Nothing)] <- declrs = analyseTyDeclr declr
| otherwise = astError node "Bad declarator for type declaration"
where
analyseTyDeclr (CDeclr Nothing derived_declrs Nothing attrs _declrnode)
| (not (null storagespec) || not (null funspecs) || not (null alignspecs)) =
astError node "storage, function or alignment specifier for type declaration"
| otherwise =
do canonTySpecs <- canonicalTypeSpec typespecs
t <- tType True node (map CAttrQual (attrs++attrs_decl) ++ typequals)
canonTySpecs derived_declrs []
case nameOfNode node of
Just n -> withDefTable (\dt -> (t, insertType dt n t))
Nothing -> return t
where
(storagespec, attrs_decl, typequals, typespecs, funspecs, alignspecs) = partitionDeclSpecs declspecs
analyseTyDeclr _ = astError node "Non-abstract declarator in type declaration"
tType :: (MonadTrav m) => Bool -> NodeInfo -> [CTypeQual] -> TypeSpecAnalysis -> [CDerivedDeclr] -> [CDecl] -> m Type
tType handle_sue_def top_node typequals canonTySpecs derived_declrs oldstyle_params
= mergeOldStyle top_node oldstyle_params derived_declrs >>= buildType
where
buildType [] =
tDirectType handle_sue_def top_node typequals canonTySpecs
buildType (CPtrDeclr ptrquals node : dds) =
buildType dds >>= buildPointerType ptrquals node
buildType (CArrDeclr arrquals size node : dds)
= buildType dds >>= buildArrayType arrquals size node
buildType (CFunDeclr (Right (params, isVariadic)) attrs node : dds)
= buildType dds >>= (liftM (uncurry FunctionType) . buildFunctionType params isVariadic attrs node)
buildType (CFunDeclr (Left _) _ _ : _)
= astError top_node "old-style parameters remaining after mergeOldStyle"
buildPointerType ptrquals _node inner_ty
= liftM (\(quals,attrs) -> PtrType inner_ty quals attrs) (tTypeQuals ptrquals)
buildArrayType arr_quals size _node inner_ty
= do (quals,attrs) <- tTypeQuals arr_quals
arr_sz <- tArraySize size
return$ ArrayType inner_ty arr_sz quals attrs
buildFunctionType params is_variadic attrs _node return_ty
= do enterPrototypeScope
params' <- mapM tParamDecl params
leavePrototypeScope
attrs' <- mapM tAttr attrs
return $ (\t -> (t,attrs')) $
case (map declType params',is_variadic) of
([],False) -> FunTypeIncomplete return_ty
([DirectType TyVoid _ _],False) -> FunType return_ty [] False
_ -> FunType return_ty params' is_variadic
tDirectType :: (MonadTrav m) =>
Bool -> NodeInfo -> [CTypeQual] -> TypeSpecAnalysis -> m Type
tDirectType handle_sue_def node ty_quals canonTySpec = do
(quals,attrs) <- tTypeQuals ty_quals
let baseType ty_name = DirectType ty_name quals attrs
case canonTySpec of
TSNone -> return$ baseType (TyIntegral TyInt)
TSVoid -> return$ baseType TyVoid
TSBool -> return$ baseType (TyIntegral TyBool)
TSNum tsnum -> do
numType <- tNumType tsnum
return . baseType $
case numType of
Left (floatType,iscomplex) | iscomplex -> TyComplex floatType
| otherwise -> TyFloating floatType
Right intType -> TyIntegral intType
TSTypeDef tdr -> return$ TypeDefType tdr quals attrs
TSNonBasic (CSUType su _tnode) -> liftM (baseType . TyComp) $ tCompTypeDecl handle_sue_def su
TSNonBasic (CEnumType enum _tnode) -> liftM (baseType . TyEnum) $ tEnumTypeDecl handle_sue_def enum
TSType t -> mergeTypeAttributes node quals attrs t
TSNonBasic t -> astError node ("Unexpected typespec: " ++ show t)
mergeTypeAttributes :: (MonadCError m) => NodeInfo -> TypeQuals -> [Attr] -> Type -> m Type
mergeTypeAttributes node_info quals attrs typ =
case typ of
DirectType ty_name quals' attrs' -> merge quals' attrs' $ DirectType ty_name
PtrType ty quals' attrs' -> merge quals' attrs' $ PtrType ty
ArrayType ty array_sz quals' attrs' -> merge quals' attrs' $ ArrayType ty array_sz
FunctionType fty attrs'
| quals /= noTypeQuals -> astError node_info "type qualifiers for function type"
| otherwise -> return$ FunctionType fty (attrs' ++ attrs)
TypeDefType tdr quals' attrs'
-> merge quals' attrs' $ TypeDefType tdr
where
merge quals' attrs' tyf = return $ tyf (mergeTypeQuals quals quals') (attrs' ++ attrs)
typeDefRef :: (MonadCError m, MonadSymtab m) => NodeInfo -> Ident -> m TypeDefRef
typeDefRef t_node name = lookupTypeDef name >>= \ty -> return (TypeDefRef name ty t_node)
tCompTypeDecl :: (MonadTrav m) => Bool -> CStructUnion -> m CompTypeRef
tCompTypeDecl handle_def (CStruct tag ident_opt member_decls_opt attrs node_info) = do
sue_ref <- createSUERef node_info ident_opt
let tag' = tTag tag
attrs' <- mapM tAttr attrs
let decl = CompTypeRef sue_ref tag' node_info
handleTagDecl (CompDecl decl)
when handle_def $
maybeM member_decls_opt $ \decls ->
tCompType sue_ref tag' decls attrs' node_info
>>= (handleTagDef.CompDef)
return decl
tTag :: CStructTag -> CompTyKind
tTag CStructTag = StructTag
tTag CUnionTag = UnionTag
tCompType :: (MonadTrav m) => SUERef -> CompTyKind -> [CDecl] -> Attributes -> NodeInfo -> m CompType
tCompType tag sue_ref member_decls attrs node
= return (CompType tag sue_ref) `ap`
(concatMapM tMemberDecls member_decls) `ap`
(return attrs) `ap`
(return node)
tEnumTypeDecl :: (MonadTrav m) => Bool -> CEnum -> m EnumTypeRef
tEnumTypeDecl handle_def (CEnum ident_opt enumerators_opt attrs node_info)
| (Nothing, Nothing) <- (ident_opt, enumerators_opt) = astError node_info "both definition and name of enum missing"
| Just [] <- enumerators_opt = astError node_info "empty enumerator list"
| otherwise
= do sue_ref <- createSUERef node_info ident_opt
attrs' <- mapM tAttr attrs
let decl = EnumTypeRef sue_ref node_info
when handle_def $
maybeM enumerators_opt $ \enumerators ->
tEnumType sue_ref enumerators attrs' node_info
>>= (handleTagDef . EnumDef)
return decl
tEnumType :: (MonadCError m, MonadSymtab m) =>
SUERef -> [(Ident, Maybe CExpr)] -> Attributes -> NodeInfo -> m EnumType
tEnumType sue_ref enumerators attrs node = do
mapM_ handleEnumeratorDef enumerators'
return ty
where
ty = EnumType sue_ref enumerators' attrs node
(_,enumerators') = mapAccumL nextEnumerator (Left 0) enumerators
nextEnumerator memo (ident,e) =
let (memo',expr) = nextEnrExpr memo e in
(memo', Enumerator ident expr ty (nodeInfo ident))
nextEnrExpr :: Either Integer (Expr,Integer) -> Maybe CExpr -> (Either Integer (Expr,Integer), CExpr)
nextEnrExpr (Left i) Nothing = (Left (succ i), intExpr i)
nextEnrExpr (Right (e,offs)) Nothing = (Right (e, succ offs), offsExpr e offs)
nextEnrExpr _ (Just e) = (Right (e,1), e)
intExpr i = CConst (CIntConst (cInteger i) undefNode)
offsExpr e offs = CBinary CAddOp e (intExpr offs) undefNode
tNumType :: (MonadCError m) => NumTypeSpec -> m (Either (FloatType,Bool) IntType)
tNumType (NumTypeSpec basetype sgn sz iscomplex) =
case (basetype,sgn,sz) of
(BaseChar,_,NoSizeMod) | Signed <- sgn -> intType TySChar
| Unsigned <- sgn -> intType TyUChar
| otherwise -> intType TyChar
(intbase, _, NoSizeMod) | optBase BaseInt intbase ->
intType$ case sgn of
Unsigned -> TyUInt
_ -> TyInt
(intbase, _, NoSizeMod) | optBase BaseInt128 intbase ->
intType$ case sgn of
Unsigned -> TyUInt128
_ -> TyInt128
(intbase, signed, sizemod) | optBase BaseInt intbase, optSign Signed signed ->
intType$ case sizemod of ShortMod -> TyShort
LongMod -> TyLong
LongLongMod -> TyLLong
_ -> internalErr "numTypeMapping: unexpected pattern matching error"
(intbase, Unsigned, sizemod) | optBase BaseInt intbase ->
intType$ case sizemod of ShortMod -> TyUShort
LongMod -> TyULong
LongLongMod -> TyULLong
_ -> internalErr "numTypeMapping: unexpected pattern matching error"
(BaseFloat, NoSignSpec, NoSizeMod) -> floatType TyFloat
(BaseDouble, NoSignSpec, NoSizeMod) -> floatType TyDouble
(BaseDouble, NoSignSpec, LongMod) -> floatType TyLDouble
(BaseFloatN n x, NoSignSpec, NoSizeMod) -> floatType (TyFloatN n x)
(_,_,_) -> error "Bad AST analysis"
where
optBase _ NoBaseType = True
optBase expect baseTy = expect == baseTy
optSign _ NoSignSpec = True
optSign expect sign = expect == sign
intType = return . Right
floatType ft = return (Left (ft,iscomplex))
tArraySize :: (MonadTrav m) => CArrSize -> m ArraySize
tArraySize (CNoArrSize False) = return (UnknownArraySize False)
tArraySize (CNoArrSize True) = return (UnknownArraySize True)
tArraySize (CArrSize static szexpr) = liftM (ArraySize static) (return szexpr)
tTypeQuals :: (MonadTrav m) => [CTypeQual] -> m (TypeQuals,Attributes)
tTypeQuals = foldrM go (noTypeQuals,[]) where
go (CConstQual _) (tq,attrs) = return (tq { constant = True },attrs)
go (CVolatQual _) (tq,attrs) = return (tq { volatile = True },attrs)
go (CRestrQual _) (tq,attrs) = return (tq { restrict = True },attrs)
go (CAtomicQual _) (tq,attrs) = return (tq { atomic = True },attrs)
go (CAttrQual attr) (tq,attrs) = liftM (\attr' -> (tq,attr':attrs)) (tAttr attr)
go (CNullableQual _) (tq,attrs) = return (tq { nullable = True }, attrs)
go (CNonnullQual _) (tq,attrs) = return (tq { nonnull = True }, attrs)
data NumBaseType = NoBaseType | BaseChar | BaseInt | BaseInt128 | BaseFloat |
BaseFloatN Int Bool | BaseDouble deriving (Eq,Ord)
data SignSpec = NoSignSpec | Signed | Unsigned deriving (Eq,Ord)
data SizeMod = NoSizeMod | ShortMod | LongMod | LongLongMod deriving (Eq,Ord)
data NumTypeSpec = NumTypeSpec { base :: NumBaseType, signSpec :: SignSpec, sizeMod :: SizeMod, isComplex :: Bool }
emptyNumTypeSpec :: NumTypeSpec
emptyNumTypeSpec = NumTypeSpec { base = NoBaseType, signSpec = NoSignSpec, sizeMod = NoSizeMod, isComplex = False }
data TypeSpecAnalysis =
TSNone | TSVoid | TSBool | TSNum NumTypeSpec |
TSTypeDef TypeDefRef | TSType Type | TSNonBasic CTypeSpec
canonicalTypeSpec :: (MonadTrav m) => [CTypeSpec] -> m TypeSpecAnalysis
canonicalTypeSpec = foldrM go TSNone where
getNTS TSNone = Just emptyNumTypeSpec
getNTS (TSNum nts) = Just nts
getNTS _ = Nothing
updLongMod NoSizeMod = Just LongMod
updLongMod LongMod = Just LongLongMod
updLongMod _ = Nothing
go :: (MonadTrav m) => CTypeSpec -> TypeSpecAnalysis -> m TypeSpecAnalysis
go (CVoidType _) TSNone = return TSVoid
go (CBoolType _) TSNone = return TSBool
go (CCharType _) tsa | (Just nts@(NumTypeSpec { base = NoBaseType })) <- getNTS tsa
= return$ TSNum$ nts { base = BaseChar }
go (CIntType _) tsa | (Just nts@(NumTypeSpec { base = NoBaseType })) <- getNTS tsa
= return$ TSNum$ nts { base = BaseInt }
go (CInt128Type _) tsa | (Just nts@(NumTypeSpec { base = NoBaseType })) <- getNTS tsa
= return$ TSNum$ nts { base = BaseInt128 }
go (CFloatType _) tsa | (Just nts@(NumTypeSpec { base = NoBaseType })) <- getNTS tsa
= return$ TSNum$ nts { base = BaseFloat }
go (CFloatNType n x _) tsa | (Just nts@(NumTypeSpec { base = NoBaseType })) <- getNTS tsa
= return$ TSNum$ nts { base = BaseFloatN n x }
go (CDoubleType _) tsa | (Just nts@(NumTypeSpec { base = NoBaseType })) <- getNTS tsa
= return$ TSNum$ nts { base = BaseDouble }
go (CShortType _) tsa | (Just nts@(NumTypeSpec { sizeMod = NoSizeMod })) <- getNTS tsa
= return$ TSNum$nts { sizeMod = ShortMod }
go (CLongType _) tsa | (Just nts@(NumTypeSpec { sizeMod = szMod })) <- getNTS tsa,
(Just szMod') <- updLongMod szMod
= return$ TSNum$ nts { sizeMod = szMod' }
go (CSignedType _) tsa | (Just nts@(NumTypeSpec { signSpec = NoSignSpec })) <- getNTS tsa
= return$ TSNum$ nts { signSpec = Signed }
go (CUnsigType _) tsa | (Just nts@(NumTypeSpec { signSpec = NoSignSpec })) <- getNTS tsa
= return$ TSNum$ nts { signSpec = Unsigned }
go (CComplexType _) tsa | (Just nts@(NumTypeSpec { isComplex = False })) <- getNTS tsa
= return$ TSNum$ nts { isComplex = True }
go (CTypeDef i ni) TSNone = liftM TSTypeDef $ typeDefRef ni i
go (CTypeOfType d _ni) TSNone = liftM TSType $ analyseTypeDecl d
go (CTypeOfExpr e _) TSNone = liftM TSType $ tExpr [] RValue e
go (CAtomicType d _ni) TSNone = liftM TSType $ analyseTypeDecl d
go otherType TSNone = return$ TSNonBasic otherType
go ty _ts = astError (nodeInfo ty) "Invalid type specifier"
canonicalStorageSpec :: (MonadCError m) =>[CStorageSpec] -> m StorageSpec
canonicalStorageSpec storagespecs = liftM elideAuto $ foldrM updStorage NoStorageSpec storagespecs where
updStorage (CAuto _) NoStorageSpec = return AutoSpec
updStorage (CRegister _) NoStorageSpec = return RegSpec
updStorage (CThread _) NoStorageSpec = return ThreadSpec
updStorage (CThread _) (StaticSpec _) = return$ StaticSpec True
updStorage (CThread _) (ExternSpec _) = return$ ExternSpec True
updStorage (CStatic _) NoStorageSpec = return$ StaticSpec False
updStorage (CExtern _) NoStorageSpec = return$ ExternSpec False
updStorage (CStatic _) ThreadSpec = return$ StaticSpec True
updStorage (CExtern _) ThreadSpec = return$ ExternSpec True
updStorage badSpec old
= astError (nodeInfo badSpec) $ "Invalid storage specifier "++render (pretty badSpec)++" in combination with "++show old
elideAuto AutoSpec = NoStorageSpec
elideAuto spec = spec
mergeOldStyle :: (MonadCError m) => NodeInfo -> [CDecl] -> [CDerivedDeclr] -> m [CDerivedDeclr]
mergeOldStyle _node [] declrs = return declrs
mergeOldStyle node oldstyle_params (CFunDeclr params attrs fdnode : dds) =
case params of
Left list -> do
oldstyle_params' <- liftM concat $ mapM splitCDecl oldstyle_params
param_map <- liftM Map.fromList $ mapM attachNameOfDecl oldstyle_params'
(newstyle_params,param_map') <- foldrM insertParamDecl ([],param_map) list
unless (Map.null param_map') $
astError node $ "declarations for parameter(s) "++ showParamMap param_map' ++" but no such parameter"
return (CFunDeclr (Right (newstyle_params, False)) attrs fdnode : dds)
Right _newstyle -> astError node "oldstyle parameter list, but newstyle function declaration"
where
attachNameOfDecl decl = nameOfDecl decl >>= \n -> return (n,decl)
insertParamDecl param_name (ps, param_map)
= case Map.lookup param_name param_map of
Just p -> return (p:ps, Map.delete param_name param_map)
Nothing -> return (implicitIntParam param_name : ps, param_map)
implicitIntParam param_name =
let nInfo = nodeInfo param_name in
CDecl [CTypeSpec (CIntType nInfo)] [(Just (CDeclr (Just param_name) [] Nothing [] nInfo),Nothing,Nothing)] nInfo
showParamMap = intercalate ", " . map identToString . Map.keys
mergeOldStyle node _ _ = astError node "oldstyle parameter list, but not function type"
splitCDecl :: (MonadCError m) => CDecl -> m [CDecl]
splitCDecl decl@(CStaticAssert _ _ _) = return [decl]
splitCDecl decl@(CDecl declspecs declrs node) =
case declrs of
[] -> internalErr "splitCDecl applied to empty declaration"
[_declr] -> return [decl]
(d1:ds) ->
let declspecs' = map elideSUEDef declspecs in
return$ (CDecl declspecs [d1] node) : [ CDecl declspecs' [declr] node | declr <- ds ]
where
elideSUEDef declspec@(CTypeSpec tyspec) =
case tyspec of
(CEnumType (CEnum name _def _attrs enum_node) node_info) ->
CTypeSpec (CEnumType (CEnum name Nothing [] enum_node) node_info)
(CSUType (CStruct tag name _def _attrs su_node) node_info) ->
CTypeSpec (CSUType (CStruct tag name Nothing [] su_node) node_info)
_ -> declspec
elideSUEDef declspec = declspec
tAttr :: (MonadCError m, MonadSymtab m) => CAttr -> m Attr
tAttr (CAttr name cexpr node) = return$ Attr name cexpr node
mkVarName :: (MonadCError m, MonadSymtab m) =>
NodeInfo -> Maybe Ident -> Maybe AsmName -> m VarName
mkVarName _node Nothing _ = return NoName
mkVarName _node (Just n) asm = return $ VarName n asm
nameOfDecl :: (MonadCError m) => CDecl -> m Ident
nameOfDecl d = getOnlyDeclr d >>= \declr ->
case declr of
(CDeclr (Just name) _ _ _ _node) -> return name
(CDeclr Nothing _ _ _ _node) -> internalErr "nameOfDecl: abstract declarator"
emptyDeclr :: NodeInfo -> CDeclr
emptyDeclr node = CDeclr Nothing [] Nothing [] node
getOnlyDeclr :: (MonadCError m) => CDecl -> m CDeclr
getOnlyDeclr (CDecl _ [(Just declr,_,_)] _) = return declr
getOnlyDeclr (CDecl _ _ _node) = internalErr "getOnlyDeclr: declaration doesn't have a unique declarator"
getOnlyDeclr (CStaticAssert _ _ _) = internalErr "getOnlyDeclr: static assertion doesn't have a unique declarator"