{-# LANGUAGE ScopedTypeVariables, PatternGuards #-} ----------------------------------------------------------------------------- -- | -- Module : Language.ObjC.Parser.Translation -- Copyright : (c) 2008 Benedikt Huber -- License : BSD-style -- Maintainer : jwlato@gmail.com -- Stability : alpha -- Portability : ghc -- -- Analyse the parse tree -- -- Traverses the AST, analyses declarations and invokes handlers. ----------------------------------------------------------------------------- module Language.ObjC.Analysis.AstAnalysis ( -- * Top-level analysis analyseAST, analyseExt,analyseFunDef,analyseDecl, -- * Building blocks for additional analyses analyseFunctionBody, defineParams, -- * Type checking tExpr, ExprSide(..), tStmt, StmtCtx(..), tDesignator, defaultMD ) where import Language.ObjC.Analysis.SemError import Language.ObjC.Analysis.SemRep import Language.ObjC.Analysis.TravMonad import Language.ObjC.Analysis.ConstEval import Language.ObjC.Analysis.Debug import Language.ObjC.Analysis.DefTable (DefTable, globalDefs, defineScopedIdent, defineLabel, inFileScope, lookupTag, lookupLabel, insertType, lookupType) import Language.ObjC.Analysis.DeclAnalysis import Language.ObjC.Analysis.TypeUtils import Language.ObjC.Analysis.TypeCheck import Language.ObjC.Data import Language.ObjC.Pretty import Language.ObjC.Syntax.AST import Language.ObjC.Syntax.Constants import Language.ObjC.Syntax.Ops import Language.ObjC.Syntax.Utils import Text.PrettyPrint.HughesPJ import Control.Monad import Prelude hiding (reverse) import qualified Data.Map as Map import Data.Maybe -- * analysis -- | Analyse the given AST -- -- @analyseAST ast@ results in global declaration dictionaries. -- If you want to perform specific actions on declarations or definitions, you may provide -- callbacks in the @MonadTrav@ @m@. -- -- Returns the set of global declarations and definitions which where successfully translated. -- It is the users responsibility to check whether any hard errors occurred (@runTrav@ does this for you). analyseAST :: (MonadTrav m) => CTranslUnit -> m GlobalDecls analyseAST (CTranslUnit decls _file_node) = do -- analyse all declarations, but recover from errors mapRecoverM_ analyseExt decls -- check we are in global scope afterwards getDefTable >>= \dt -> when (not (inFileScope dt)) $ error "Internal Error: Not in filescope after analysis" -- get the global definition table (XXX: remove ?) liftM globalDefs getDefTable where mapRecoverM_ f = mapM_ (handleTravError . f) -- | Analyse an top-level declaration analyseExt :: (MonadTrav m) => CExtDecl -> m () analyseExt (CAsmExt asm _) = handleAsmBlock asm analyseExt (CFDefExt fundef) = analyseFunDef fundef analyseExt (CDeclExt decl) = analyseDecl False decl -- | Analyse a function definition analyseFunDef :: (MonadTrav m) => CFunDef -> m () analyseFunDef (CFunDef declspecs declr oldstyle_decls stmt node_info) = do -- analyse the declarator var_decl_info <- analyseVarDecl' True declspecs declr oldstyle_decls Nothing let (VarDeclInfo name is_inline storage_spec attrs ty declr_node) = var_decl_info when (isNoName name) $ astError node_info "NoName in analyseFunDef" let ident = identOfVarName name -- improve incomplete type ty' <- improveFunDefType ty -- compute storage fun_storage <- computeFunDefStorage ident storage_spec let var_decl = VarDecl name (DeclAttrs is_inline fun_storage attrs) ty' -- callback for declaration handleVarDecl False (Decl var_decl node_info) -- process body stmt' <- analyseFunctionBody node_info var_decl stmt -- callback for definition handleFunDef ident (FunDef var_decl stmt' node_info) where improveFunDefType (FunctionType (FunTypeIncomplete return_ty) attrs) = return $ FunctionType (FunType return_ty [] False) attrs improveFunDefType ty = return $ ty -- | Analyse a declaration other than a function definition analyseDecl :: (MonadTrav m) => Bool -> CDecl -> m () analyseDecl is_local decl@(CDecl declspecs declrs node) | null declrs = case typedef_spec of Just _ -> astError node "bad typedef declaration: missing declarator" Nothing -> analyseTypeDecl decl >> return () | (Just declspecs') <- typedef_spec = mapM_ (uncurry (analyseTyDef declspecs')) declr_list | otherwise = do let (storage_specs, attrs, typequals, typespecs, inline) = partitionDeclSpecs declspecs canonTySpecs <- canonicalTypeSpec typespecs let specs = (storage_specs, attrs, typequals, canonTySpecs, inline) mapM_ (uncurry (analyseVarDeclr specs)) declr_list where declr_list = zip (True : repeat False) declrs typedef_spec = hasTypeDef declspecs analyseTyDef declspecs' handle_sue_def declr = case declr of (Just tydeclr, Nothing , Nothing) -> analyseTypeDef handle_sue_def declspecs' tydeclr node _ -> astError node "bad typdef declaration: bitfieldsize or initializer present" analyseVarDeclr specs handle_sue_def (Just declr, init_opt, Nothing) = do -- analyse the declarator let (storage_specs, attrs, typequals, canonTySpecs, inline) = specs vardeclInfo@(VarDeclInfo _ _ _ _ typ _) <- analyseVarDecl handle_sue_def storage_specs attrs typequals canonTySpecs inline declr [] Nothing -- declare / define the object if (isFunctionType typ) then extFunProto vardeclInfo else (if is_local then localVarDecl else extVarDecl) -- XXX: if Initializer becomes different from CInit, this -- will have to change. vardeclInfo init_opt init_opt' <- mapMaybeM init_opt (tInit typ) return () analyseVarDeclr _ _ (Nothing,_,_) = astError node "abstract declarator in object declaration" analyseVarDeclr _ _ (_,_,Just bitfieldSz) = astError node "bitfield size in object declaration" -- | Analyse a typedef analyseTypeDef :: (MonadTrav m) => Bool -> [CDeclSpec] -> CDeclr -> NodeInfo -> m () analyseTypeDef handle_sue_def declspecs declr node_info = do -- analyse the declarator (VarDeclInfo name is_inline storage_spec attrs ty declr_node) <- analyseVarDecl' handle_sue_def declspecs declr [] Nothing checkValidTypeDef is_inline storage_spec attrs when (isNoName name) $ astError node_info "NoName in analyseTypeDef" let ident = identOfVarName name handleTypeDef (TypeDef ident ty attrs node_info) where checkValidTypeDef True _ _ = astError node_info "inline specifier for typeDef" checkValidTypeDef _ NoStorageSpec _ = return () checkValidTypeDef _ bad_storage _ = astError node_info $ "storage specified for typeDef: " ++ show bad_storage -- | compute storage of a function definition -- -- a function definition has static storage with internal linkage if specified `static`, -- the previously declared linkage if any if 'extern' or no specifier are present. (See C99 6.2.2, clause 5) -- -- This function won't raise an Trav error if the declaration is incompatible with the existing one, -- this case is handled in 'handleFunDef'. computeFunDefStorage :: (MonadTrav m) => Ident -> StorageSpec -> m Storage computeFunDefStorage _ (StaticSpec b) = return$ FunLinkage InternalLinkage computeFunDefStorage ident other_spec = do obj_opt <- lookupObject ident let defaultSpec = FunLinkage ExternalLinkage case other_spec of NoStorageSpec -> return$ maybe defaultSpec declStorage obj_opt (ExternSpec False) -> return$ maybe defaultSpec declStorage obj_opt bad_spec -> throwTravError $ badSpecifierError (nodeInfo ident) $ "unexpected function storage specifier (only static or extern is allowed)" ++ show bad_spec -- (private) Get parameters of a function type getParams :: Type -> Maybe [ParamDecl] getParams (FunctionType (FunType _ params _) _) = Just params getParams _ = Nothing -- | handle a function prototype extFunProto :: (MonadTrav m) => VarDeclInfo -> m () extFunProto (VarDeclInfo var_name is_inline storage_spec attrs ty node_info) = do when (isNoName var_name) $ astError node_info "NoName in extFunProto" old_fun <- lookupObject (identOfVarName var_name) checkValidSpecs let decl = VarDecl var_name (DeclAttrs is_inline (funDeclLinkage old_fun) attrs) ty handleVarDecl False (Decl decl node_info) -- XXX: structs should be handled in 'function prototype scope' too enterPrototypeScope maybe (return ()) (mapM_ handleParamDecl) (getParams ty) leavePrototypeScope where funDeclLinkage old_fun = case storage_spec of NoStorageSpec -> FunLinkage ExternalLinkage -- prototype declaration / external linkage StaticSpec False -> FunLinkage InternalLinkage -- prototype declaration / internal linkage ExternSpec False -> case old_fun of Nothing -> FunLinkage ExternalLinkage Just f -> declStorage f _ -> error $ "funDeclLinkage: " ++ show storage_spec checkValidSpecs | hasThreadLocalSpec storage_spec = astError node_info "thread local storage specified for function" | RegSpec <- storage_spec = astError node_info "invalid `register' storage specified for function" | otherwise = return () -- | handle a object declaration \/ definition -- -- We have to check the storage specifiers here, as they determine wheter we're dealing with decalartions -- or definitions -- see [http://www.sivity.net/projects/language.c/wiki/ExternalDefinitions] extVarDecl :: (MonadTrav m) => VarDeclInfo -> (Maybe Initializer) -> m () extVarDecl (VarDeclInfo var_name is_inline storage_spec attrs typ node_info) init_opt = do when (isNoName var_name) $ astError node_info "NoName in extVarDecl" (storage,is_def) <- globalStorage storage_spec let vardecl = VarDecl var_name (DeclAttrs is_inline storage attrs) typ if is_def then handleObjectDef False ident $ ObjDef vardecl init_opt node_info else handleVarDecl False $ Decl vardecl node_info where ident = identOfVarName var_name globalStorage _ | is_inline = astError node_info "invalid `inline' specifier external variable" globalStorage RegSpec = do when (isJust init_opt) $ astError node_info "initializer given for global register variable" case var_name of NoName -> astError node_info "global register variable has no name" VarName _ Nothing -> astError node_info "no register specified for global register variable" _ -> return () dt <- getDefTable when (hasFunDef dt) $ astError node_info "global register variable appears after a function definition" return (Static InternalLinkage False, False) -- tentative if there is no initializer, external globalStorage NoStorageSpec = return $ (Static ExternalLinkage False, True) -- tentative if there is no initializer, internal globalStorage (StaticSpec thread_local) = return $ (Static InternalLinkage thread_local, True) globalStorage (ExternSpec thread_local) = case init_opt of -- declaration with either external or old storage Nothing -> do old_decl <- lookupObject ident return $ (maybe (Static ExternalLinkage thread_local) declStorage old_decl,False) -- warning, external definition Just _ -> do warn $ badSpecifierError node_info "Both initializer and `extern` specifier given - treating as definition" return $ (Static ExternalLinkage thread_local, True) hasFunDef dt = any (isFuncDef . snd) (Map.toList $ gObjs $ globalDefs dt) isFuncDef (FunctionDef fd) = not $ isInline $ declAttrs fd isFuncDef _ = False isInline (DeclAttrs inl _ _) = inl -- | handle a function-scope object declaration \/ definition -- see [http://www.sivity.net/projects/language.c/wiki/LocalDefinitions] localVarDecl :: (MonadTrav m) => VarDeclInfo -> (Maybe Initializer) -> m () localVarDecl (VarDeclInfo var_name is_inline storage_spec attrs typ node_info) init_opt = do when (isNoName var_name) $ astError node_info "NoName in localVarDecl" (storage,is_def) <- localStorage storage_spec let vardecl = VarDecl var_name (DeclAttrs is_inline storage attrs) typ if is_def then handleObjectDef True ident (ObjDef vardecl init_opt node_info) else handleVarDecl True (Decl vardecl node_info) where ident = identOfVarName var_name localStorage _ | is_inline = astError node_info "invalid `inline' specifier for local variable" localStorage NoStorageSpec = return $ (Auto False,True) localStorage RegSpec = return $ (Auto True,True) -- static no linkage localStorage (StaticSpec thread_local) = return $ (Static NoLinkage thread_local,True) localStorage (ExternSpec thread_local) | isJust init_opt = astError node_info "extern keyword and initializer for local" | otherwise = do old_decl <- lookupObject ident return (maybe (Static ExternalLinkage thread_local) declStorage old_decl,False) localStorage s = astError node_info "bad storage specifier for local" defineParams :: MonadTrav m => NodeInfo -> VarDecl -> m () defineParams ni decl = case (getParams $ declType decl) of Nothing -> astError ni "expecting complete function type in function definition" Just params -> mapM_ handleParamDecl params analyseFunctionBody :: (MonadTrav m) => NodeInfo -> VarDecl -> CStat -> m Stmt analyseFunctionBody node_info decl s@(CCompound localLabels items _) = do enterFunctionScope mapM_ (withDefTable . defineLabel) (localLabels ++ getLabels s) defineParams node_info decl -- record parameters mapM_ (tBlockItem [FunCtx decl]) items leaveFunctionScope return s -- XXX: bogus analyseFunctionBody _ _ s = astError (nodeInfo s) "Function body is no compound statement" data StmtCtx = FunCtx VarDecl | LoopCtx | SwitchCtx -- | Given a context, determine the type declaration for the enclosing -- function, if possible, given a context. enclosingFunctionType :: [StmtCtx] -> Maybe Type enclosingFunctionType [] = Nothing enclosingFunctionType (FunCtx vd : _) = Just $ declType vd enclosingFunctionType (_ : cs) = enclosingFunctionType cs inLoop :: [StmtCtx] -> Bool inLoop c = any isLoop c where isLoop LoopCtx = True isLoop _ = False inSwitch :: [StmtCtx] -> Bool inSwitch c = any isSwitch c where isSwitch SwitchCtx = True isSwitch _ = False data ExprSide = LValue | RValue deriving (Eq, Show) -- | Typecheck a statement, given a statement context. The type of a -- statement is usually @void@, but expression statements and blocks -- can sometimes have other types. tStmt :: MonadTrav m => [StmtCtx] -> CStat -> m Type tStmt c (CLabel _ s _ _) = tStmt c s tStmt c (CExpr e _) = maybe (return voidType) (tExpr c RValue) e tStmt c (CCompound ls body _) = do enterBlockScope mapM_ (withDefTable . defineLabel) ls t <- foldM (const $ tBlockItem c) voidType body leaveBlockScope return t tStmt c (CIf e sthen selse _) = checkGuard c e >> tStmt c sthen >> maybe (return ()) (\s -> tStmt c s >> return ()) selse >> return voidType tStmt c (CSwitch e s ni) = tExpr c RValue e >>= checkIntegral' ni >> tStmt (SwitchCtx : c) s tStmt c (CWhile e s _ _) = checkGuard c e >> tStmt (LoopCtx : c) s tStmt _ (CGoto l ni) = do dt <- getDefTable case lookupLabel l dt of Just _ -> return voidType Nothing -> typeError ni $ "undefined label in goto: " ++ identToString l tStmt c (CCont ni) = do unless (inLoop c) $ astError ni "continue statement outside of loop" return voidType tStmt c (CBreak ni) = do unless (inLoop c || inSwitch c) $ astError ni "break statement outside of loop or switch statement" return voidType tStmt c (CReturn (Just e) ni) = do t <- tExpr c RValue e rt <- case enclosingFunctionType c of Just (FunctionType (FunType rt _ _) _) -> return rt Just (FunctionType (FunTypeIncomplete rt) _) -> return rt Just ft -> astError ni $ "bad function type: " ++ pType ft Nothing -> astError ni "return statement outside function" case (rt, t) of -- apparently it's ok to return void from a void function? (DirectType TyVoid _ _, DirectType TyVoid _ _) -> return () _ -> assignCompatible' ni CAssignOp rt t return voidType tStmt _ (CReturn Nothing _) = return voidType -- XXX: anything to do for assembly? tStmt _ (CAsm _ _) = return voidType tStmt c (CCase e s ni) = do unless (inSwitch c) $ astError ni "case statement outside of switch statement" tExpr c RValue e >>= checkIntegral' ni tStmt c s tStmt c (CCases e1 e2 s ni) = do unless (inSwitch c) $ astError ni "case statement outside of switch statement" tExpr c RValue e1 >>= checkIntegral' ni tExpr c RValue e2 >>= checkIntegral' ni tStmt c s tStmt c (CDefault s ni) = do unless (inSwitch c) $ astError ni "default statement outside of switch statement" tStmt c s tStmt c (CFor i g inc s _) = do enterBlockScope either (maybe (return ()) checkExpr) (analyseDecl True) i maybe (return ()) (checkGuard c) g maybe (return ()) checkExpr inc tStmt (LoopCtx : c) s leaveBlockScope return voidType where checkExpr e = tExpr c RValue e >> return () tStmt c (CGotoPtr e ni) = do t <- tExpr c RValue e case t of (PtrType _ _ _) -> return voidType _ -> typeError ni "can't goto non-pointer" -- | Typecheck a block item. When statement expressions are blocks, -- they have the type of their last expression statement, so this -- needs to return a type. tBlockItem :: MonadTrav m => [StmtCtx] -> CBlockItem -> m Type tBlockItem c (CBlockStmt s) = tStmt c s tBlockItem _ (CBlockDecl d) = analyseDecl True d >> return voidType -- TODO: fixup analyseFunDef to handle nested functions tBlockItem _ (CNestedFunDef fd) = analyseFunDef fd >> return voidType checkGuard :: MonadTrav m => [StmtCtx] -> CExpr -> m () checkGuard c e = tExpr c RValue e >>= checkScalar' (nodeInfo e) -- XXX: this is bogus, correct only for IA32. We should eventually -- have a collection of these and allow people to choose one. defaultMD :: MachineDesc defaultMD = MachineDesc { iSize = \it -> case it of TyBool -> 1 TyChar -> 1 TySChar -> 1 TyUChar -> 1 TyShort -> 2 TyUShort -> 2 TyInt -> 4 TyUInt -> 4 TyLong -> 4 TyULong -> 4 TyLLong -> 8 TyULLong -> 8 , fSize = \ft -> case ft of TyFloat -> 4 TyDouble -> 8 TyLDouble -> 16 , builtinSize = \bt -> case bt of TyVaList -> 4 TyAny -> 4 , ptrSize = 4 , voidSize = 1 , iAlign = \it -> case it of TyBool -> 1 TyChar -> 1 TySChar -> 1 TyUChar -> 1 TyShort -> 2 TyUShort -> 2 TyInt -> 4 TyUInt -> 4 TyLong -> 4 TyULong -> 4 TyLLong -> 8 TyULLong -> 8 , fAlign = \ft -> case ft of TyFloat -> 4 TyDouble -> 8 TyLDouble -> 16 , builtinAlign = \bt -> case bt of TyVaList -> 4 TyAny -> 4 , ptrAlign = 4 , voidAlign = 1 } tExpr :: MonadTrav m => [StmtCtx] -> ExprSide -> CExpr -> m Type tExpr c side e = case nameOfNode (nodeInfo e) of Just n -> do dt <- getDefTable case lookupType dt n of Just t -> return t Nothing -> do t <- tExpr' c side e withDefTable (\dt -> (t, insertType dt n t)) Nothing -> tExpr' c side e -- | Typecheck an expression, with information about whether it -- appears as an lvalue or an rvalue. tExpr' :: MonadTrav m => [StmtCtx] -> ExprSide -> CExpr -> m Type tExpr' c side (CBinary op le re ni) = do when (side == LValue) $ typeError ni "binary operator as lvalue" lt <- tExpr c RValue le rt <- tExpr c RValue re binopType' ni op lt rt tExpr' c side (CUnary CAdrOp e ni) = do when (side == LValue) $ typeError ni "address-of operator as lvalue" case e of CCompoundLit _ _ _ -> simplePtr `liftM` tExpr c RValue e CVar i _ -> lookupObject i >>= typeErrorOnLeft ni . maybe (notFound i) varAddrType _ -> simplePtr `liftM` tExpr c LValue e tExpr' c _ (CUnary CIndOp e ni) = tExpr c RValue e >>= (typeErrorOnLeft ni . derefType) tExpr' c _ (CUnary CCompOp e ni) = do t <- tExpr c RValue e checkIntegral' ni t return t tExpr' c side (CUnary CNegOp e ni) = do when (side == LValue) $ typeError ni "logical negation used as lvalue" tExpr c RValue e >>= checkScalar' ni return boolType tExpr' c side (CUnary op e _) = tExpr c (if isEffectfulOp op then LValue else side) e tExpr' c _ (CIndex b i ni) = do bt <- tExpr c RValue b it <- tExpr c RValue i addrTy <- binopType' ni CAddOp bt it typeErrorOnLeft ni $ derefType addrTy tExpr' c side (CCond e1 me2 e3 ni) = do t1 <- tExpr c RValue e1 checkScalar' (nodeInfo e1) t1 t3 <- tExpr c side e3 case me2 of Just e2 -> do t2 <- tExpr c side e2 conditionalType' ni t2 t3 Nothing -> conditionalType' ni t1 t3 tExpr' c _side (CMember e m deref ni) = do t <- tExpr c RValue e bt <- if deref then typeErrorOnLeft ni (derefType t) else return t fieldType ni m bt tExpr' c side (CComma es _) = mapM (tExpr c side) es >>= return . last tExpr' c side (CCast d e ni) = do dt <- analyseTypeDecl d et <- tExpr c side e typeErrorOnLeft ni $ castCompatible dt et return dt tExpr' c side (CSizeofExpr e ni) = do when (side == LValue) $ typeError ni "sizeof as lvalue" void $ tExpr c RValue e return size_tType tExpr' c side (CAlignofExpr e ni) = do when (side == LValue) $ typeError ni "alignof as lvalue" void $ tExpr c RValue e return size_tType tExpr' c side (CComplexReal e ni) = complexBaseType ni c side e tExpr' c side (CComplexImag e ni) = complexBaseType ni c side e tExpr' _ side (CLabAddrExpr _ ni) = do when (side == LValue) $ typeError ni "label address as lvalue" return $ PtrType voidType noTypeQuals [] tExpr' _ side (CCompoundLit d initList ni) = do when (side == LValue) $ typeError ni "compound literal as lvalue" lt <- analyseTypeDecl d tInitList ni (canonicalType lt) initList return lt tExpr' _ RValue (CAlignofType _ _) = return size_tType tExpr' _ RValue (CSizeofType _ _) = return size_tType tExpr' _ LValue (CAlignofType _ ni) = typeError ni "alignoftype as lvalue" tExpr' _ LValue (CSizeofType _ ni) = typeError ni "sizeoftype as lvalue" tExpr' _ _ (CVar i ni) = lookupObject i >>= maybe (typeErrorOnLeft ni $ notFound i) (return . declType) tExpr' _ _ (CConst c) = constType c tExpr' _ _ (CBuiltinExpr b) = builtinType b tExpr' c side (CCall (CVar i _) args ni) | identToString i == "__builtin_choose_expr" = case args of [g, e1, e2] -> -- XXX: the MachineDesc parameter below should be configurable do b <- constEval defaultMD Map.empty g case boolValue b of Just True -> tExpr c side e1 Just False -> tExpr c side e2 Nothing -> astError ni "non-constant argument to __builtin_choose_expr" _ -> astError ni "wrong number of arguments to __builtin_choose_expr" tExpr' c _ (CCall fe args ni) = do let defType = FunctionType (FunTypeIncomplete (DirectType (TyIntegral TyInt) noTypeQuals noAttributes)) noAttributes fallback i = do warn $ invalidAST ni $ "unknown function: " ++ identToString i return defType t <- case fe of CVar i _ -> lookupObject i >>= maybe (fallback i) (const $ tExpr c RValue fe) _ -> tExpr c RValue fe atys <- mapM (tExpr c RValue) args -- XXX: we don't actually want to return the canonical return type here case canonicalType t of PtrType (FunctionType (FunType rt pdecls varargs) _) _ _ -> do let ptys = map declType pdecls mapM_ checkArg $ zip3 ptys atys args unless varargs $ when (length atys /= length ptys) $ typeError ni "incorrect number of arguments" return $ canonicalType rt PtrType (FunctionType (FunTypeIncomplete rt) _) _ _ -> do -- warn $ invalidAST ni "incomplete function type" return $ canonicalType rt _ -> typeError ni $ "attempt to call non-function of type " ++ pType t where checkArg (pty, aty, arg) = do attrs <- deepTypeAttrs pty case isTransparentUnion attrs of True -> case canonicalType pty of DirectType (TyComp ctr) _ _ -> do td <- lookupSUE (nodeInfo arg) (sueRef ctr) ms <- tagMembers (nodeInfo arg) td {- when (null $ rights $ matches ms) $ astError (nodeInfo arg) $ "argument matches none of the elements " ++ "of transparent union" -} return () where matches = map (\d -> assignCompatible CAssignOp (snd d) aty ) _ -> astError (nodeInfo arg) "non-composite has __transparent_union__ attribute" False -> assignCompatible' (nodeInfo arg) CAssignOp pty aty isTransparentUnion = any (\(Attr n _ _) -> identToString n == "__transparent_union__") tExpr' c _ (CAssign op le re ni) = do lt <- tExpr c LValue le rt <- tExpr c RValue re when (constant $ typeQuals lt) $ typeError ni $ "assignment to lvalue with `constant' qualifier: " ++ (render . pretty) le case (canonicalType lt, re) of (lt', CConst (CIntConst i _)) | isPointerType lt' && getCInteger i == 0 -> return () (_, _) -> assignCompatible' ni op lt rt return lt tExpr' c _ (CStatExpr s _) = do enterBlockScope mapM_ (withDefTable . defineLabel) (getLabels s) t <- tStmt c s leaveBlockScope return t tExpr' _ _ (CBlockExpr _ _ ni) = typeError ni $ "tExpr': don't know how to type block expressions" tExpr' _ _ (ObjCMessageExpr _ ni) = typeError ni $ "tExpr': don't know how to type message expressions" tExpr' _ _ (ObjCSelectorExpr _ ni) = typeError ni $ "tExpr': don't know how to type selector expressions" tExpr' _ _ (ObjCProtoExpr _ ni) = typeError ni $ "tExpr': don't know how to type protocol expressions" tInitList :: MonadTrav m => NodeInfo -> Type -> CInitList -> m () tInitList _ (ArrayType (DirectType (TyIntegral TyChar) _ _) _ _ _) [([], CInitExpr e@(CConst (CStrConst _ _)) _)] = tExpr [] RValue e >> return () tInitList ni t@(ArrayType _ _ _ _) initList = do let default_ds = repeat (CArrDesig (CConst (CIntConst (cInteger 0) ni)) ni) checkInits t default_ds initList tInitList ni t@(DirectType (TyComp ctr) _ _) initList = do td <- lookupSUE ni (sueRef ctr) ms <- tagMembers ni td let default_ds = map (\m -> CMemberDesig (fst m) ni) ms checkInits t default_ds initList tInitList _ (PtrType (DirectType TyVoid _ _) _ _ ) _ = return () -- XXX: more checking tInitList _ t [([], i)] = tInit t i >> return () tInitList ni t _ = typeError ni $ "initializer list for type: " ++ pType t checkInits :: MonadTrav m => Type -> [CDesignator] -> CInitList -> m () checkInits _ _ [] = return () checkInits t dds ((ds, i) : is) = do (dds', ds') <- case (dds, ds) of ([], []) -> typeError (nodeInfo i) "excess elements in initializer" (dd' : rest, []) -> return (rest, [dd']) (_, d : _) -> return (advanceDesigList dds d, ds) t' <- tDesignator t ds' void $ tInit t' i checkInits t dds' is advanceDesigList :: [CDesignator] -> CDesignator -> [CDesignator] advanceDesigList ds d = drop 1 $ dropWhile (not . matchDesignator d) ds matchDesignator :: CDesignator -> CDesignator -> Bool matchDesignator (CMemberDesig m1 _) (CMemberDesig m2 _) = m1 == m2 matchDesignator _ _ = True -- XXX: for now, array ranges aren't checked tDesignator :: MonadTrav m => Type -> [CDesignator] -> m Type -- XXX: check that initializers are within array size tDesignator (ArrayType bt _ _ _) (CArrDesig e ni : ds) = do tExpr [] RValue e >>= checkIntegral' ni tDesignator bt ds tDesignator (ArrayType bt _ _ _) (CRangeDesig e1 e2 ni : ds) = do tExpr [] RValue e1 >>= checkIntegral' ni tExpr [] RValue e2 >>= checkIntegral' ni tDesignator bt ds tDesignator (ArrayType _ _ _ _) (d : _) = typeError (nodeInfo d) "member designator in array initializer" tDesignator t@(DirectType (TyComp _) _ _) (CMemberDesig m ni : ds) = do mt <- fieldType ni m t tDesignator (canonicalType mt) ds tDesignator (DirectType (TyComp _) _ _) (d : _) = typeError (nodeInfo d) "array designator in compound initializer" tDesignator t [] = return t tInit :: MonadTrav m => Type -> CInit -> m Initializer tInit t i@(CInitExpr e ni) = do it <- tExpr [] RValue e assignCompatible' ni CAssignOp t it return i tInit t i@(CInitList initList ni) = tInitList ni (canonicalType t) initList >> return i complexBaseType :: MonadTrav m => NodeInfo -> [StmtCtx] -> ExprSide -> CExpr -> m Type complexBaseType ni c side e = do t <- tExpr c side e case canonicalType t of DirectType (TyComplex ft) quals attrs -> return $ DirectType (TyFloating ft) quals attrs _ -> typeError ni $ "expected complex type, got: " ++ pType t -- | Return the type of a builtin. builtinType :: MonadTrav m => CBuiltin -> m Type builtinType (CBuiltinVaArg _ d _) = analyseTypeDecl d builtinType (CBuiltinOffsetOf _ _ _) = return size_tType builtinType (CBuiltinTypesCompatible _ _ _) = return boolType -- return @Just declspecs@ without @CTypedef@ if the declaration specifier contain @typedef@ hasTypeDef :: [CDeclSpec] -> Maybe [CDeclSpec] hasTypeDef declspecs = case foldr hasTypeDefSpec (False,[]) declspecs of (True,specs') -> Just specs' (False,_) -> Nothing where hasTypeDefSpec (CStorageSpec (CTypedef _n)) (_,specs) = (True, specs) hasTypeDefSpec spec (b,specs) = (b,spec:specs)