{-# LANGUAGE PatternGuards, FlexibleContexts #-} ----------------------------------------------------------------------------- -- | -- Module : Language.C.Analysis.DeclAnalysis -- Copyright : (c) 2008 Benedikt Huber -- License : BSD-style -- Maintainer : benedikt.huber@gmail.com -- Stability : alpha -- Portability : ghc -- -- This module performs the analysis of declarations and the translation of -- type specifications in the AST. ----------------------------------------------------------------------------- module Language.C.Analysis.DeclAnalysis ( -- * Translating types analyseTypeDecl, tType,tDirectType,tNumType,tArraySize,tTypeQuals, mergeOldStyle, -- * Dissecting type specs canonicalTypeSpec, NumBaseType(..),SignSpec(..),SizeMod(..),NumTypeSpec(..),TypeSpecAnalysis(..), canonicalStorageSpec, StorageSpec(..), hasThreadLocalSpec, hasClKernelSpec, isTypeDef, -- * Helpers 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 -- * handling declarations -- | analyse and translate a parameter declaration -- Should be called in either prototype or block scope tParamDecl :: (MonadTrav m) => CDecl -> m ParamDecl tParamDecl (CStaticAssert _ _ node) = astError node "expected parameter, not static assertion" tParamDecl (CDecl declspecs declrs node) = do declr <- getParamDeclr -- analyse the variable declaration (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") -- compute storage of parameter (NoStorage, but might have a register specifier) storage <- throwOnLeft $ computeParamStorage node storage_spec let paramDecl = mkParamDecl name storage attrs ty declr_node -- XXX: we shouldn't modify the deftable here, just analyse and build representation 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 -- | a parameter declaration has no linkage and either auto or register storage computeParamStorage :: NodeInfo -> StorageSpec -> Either BadSpecifierError Storage computeParamStorage _ NoStorageSpec = Right (Auto False) computeParamStorage _ RegSpec = Right (Auto True) computeParamStorage _ ClGlobalSpec = Right (Static NoLinkage False) computeParamStorage _ ClLocalSpec = Right (Static NoLinkage True) computeParamStorage node spec = Left . badSpecifierError node $ "Bad storage specified for parameter: " ++ show spec -- | analyse and translate a member declaration tMemberDecls :: (MonadTrav m) => CDecl -> m [MemberDecl] -- Anonymous struct or union members -- TODO storage specs, align specs and attributes are ignored 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 -- XXX: are these DeclAttrs correct? (VarDecl NoName (DeclAttrs noFunctionAttrs NoStorage []) ty) Nothing node] _ -> astError node "anonymous member has a non-composite type" -- Named members tMemberDecls (CDecl declspecs declrs node) = zipWithM tMemberDecl (True:repeat False) declrs where tMemberDecl handle_sue_def (Just member_declr,Nothing,bit_field_size_opt) = -- TODO: use analyseVarDecl here, not analyseVarDecl' 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 -- TODO: funspecs/alignspecs not yet processed _storage_spec <- canonicalStorageSpec storage_specs -- TODO: storage_spec not used 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 | ClKernelSpec | ClGlobalSpec | ClLocalSpec deriving (Eq,Ord,Show,Read) hasThreadLocalSpec :: StorageSpec -> Bool hasThreadLocalSpec ThreadSpec = True hasThreadLocalSpec ClLocalSpec = True hasThreadLocalSpec (StaticSpec b) = b hasThreadLocalSpec (ExternSpec b) = b hasThreadLocalSpec _ = False hasClKernelSpec :: StorageSpec -> Bool hasClKernelSpec ClKernelSpec = True 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 -- TODO: alignspecs not yet processed analyseVarDecl handle_sue_def storage_specs attrs type_quals canonTySpecs funspecs declr oldstyle init_opt -- | analyse declarators 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 -- analyse the storage specifiers storage_spec <- canonicalStorageSpec storage_specs -- translate the type into semantic representation typ <- tType handle_sue_def node typequals canonTySpecs derived_declrs oldstyle_params -- translate attributes attrs' <- mapM tAttr (decl_attrs ++ declr_attrs) -- make name 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 -- return @True@ if the declarations is a type def isTypeDef :: [CDeclSpec] -> Bool isTypeDef declspecs = not $ null [ n | (CStorageSpec (CTypedef n)) <- declspecs ] -- * translation -- | get the type of a /type declaration/ -- -- A type declaration @T@ may appear in thre forms: -- -- * @typeof(T)@ -- -- * as abstract declarator in a function prototype, as in @f(int)@ -- -- * in a declaration without declarators, as in @struct x { int a } ;@ -- -- Currently, @analyseTypeDecl@ is exlusively used for analysing types for GNU's @typeof(T)@. -- -- We move attributes to the type, as they have no meaning for the abstract declarator 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" -- | translate a type 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 _) _ _ : _) -- /FIXME/: this is really an internal error, not an AST error. = 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 -- We build functions in function prototype scope. -- When analyzing the the function body, we push parameters in function body scope. 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 -- may be improved later on ([DirectType TyVoid _ _],False) -> FunType return_ty [] False _ -> FunType return_ty params' is_variadic -- | translate a type without (syntactic) indirections -- Due to the GNU @typeof@ extension and typeDefs, this can be an arbitrary type 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) -- | Merge type attributes -- -- This handles for example the form -- -- > /* tyqual attr typeof(type) */ -- > const typeof(char volatile) x; 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) -- extract a struct\/union -- we emit @declStructUnion@ and @defStructUnion@ actions -- -- TODO: should attributes be part of declarartions too ? tCompTypeDecl :: (MonadTrav m) => Bool -> CStructUnion -> m CompTypeRef tCompTypeDecl handle_def (CStruct tag ident_opt member_decls_opt attrs node_info) = do -- create reference sue_ref <- createSUERef node_info ident_opt let tag' = tTag tag attrs' <- mapM tAttr attrs -- record tag name let decl = CompTypeRef sue_ref tag' node_info handleTagDecl (CompDecl decl) -- when handle_def is true, enter the definition 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) -- | translate a enum type decl -- -- > enum my_enum -- > enum your_enum { x, y=3 } -- 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 -- | translate and analyse an enumeration type 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 -- | Mapping from num type specs to C types (C99 6.7.2-2), ignoring the complex qualifier. 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) -- TODO: error analysis (_,_,_) -> 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)) -- TODO: currently bogus 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) go (CClRdOnlyQual _) (tq,attrs) = return (tq { clrdonly = True },attrs) go (CClWrOnlyQual _) (tq,attrs) = return (tq { clwronly = True },attrs) -- * analysis {- To canoicalize type specifiers, we define a canonical form: void | bool | (char|int|int128|float|double|floatNx)? (signed|unsigned)? (long long?)? complex? | othertype -} 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 -- todo: atomic qualifier discarded go (CAtomicType d _ni) TSNone = liftM TSType $ analyseTypeDecl d go otherType TSNone = return$ TSNonBasic otherType go ty _ts = astError (nodeInfo ty) "Invalid type specifier" -- compute storage given storage specifiers 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 (CClKernel _) NoStorageSpec = return ClKernelSpec updStorage (CClGlobal _) NoStorageSpec = return ClGlobalSpec updStorage (CClLocal _) NoStorageSpec = return ClLocalSpec 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 -- | convert old style parameters -- -- This requires matching parameter names and declarations, as in the following example: -- -- > int f(d,c,a,b) -- > char a,*b; -- > int c; -- > { } -- -- is converted to -- -- > int f(int d, int c, char a, char* b) -- -- TODO: This could be moved to syntax, as it operates on the AST only 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 -- FIXME: This translation doesn't work in the following example -- [| int f(b,a) struct x { }; int b,a; { struct x local; return local.x } |] 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" -- | split a CDecl into declarators, hereby eliding SUE defs from the second declarator on. -- -- There are several reasons why this isn't the preferred way for handling multiple-declarator declarations, -- but it can be convinient some times. -- -- > splitCDecl [d| struct x { int z; } a,*b; |] -- > [ [d| struct x { int z; } a, struct x *b; |] ] -- -- /TODO/: This could be moved to syntax, as it operates on the AST only 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" -- single declarator, not need to split [_declr] -> return [decl] -- more than one declarator (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 -- | translate @__attribute__@ annotations -- TODO: This is a unwrap and wrap stub tAttr :: (MonadCError m, MonadSymtab m) => CAttr -> m Attr tAttr (CAttr name cexpr node) = return$ Attr name cexpr node -- | construct a name for a variable -- TODO: more or less bogus 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 -- helpers 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"