diff --git a/language-c/src/Language/C/Analysis/Debug.hs b/language-c/src/Language/C/Analysis/Debug.hs index c993d44f..f4e0995f 100644 --- a/language-c/src/Language/C/Analysis/Debug.hs +++ b/language-c/src/Language/C/Analysis/Debug.hs @@ -27,6 +27,7 @@ import Language.C.Data import Language.C.Pretty import Language.C.Syntax +import Prelude hiding ((<>)) import Text.PrettyPrint.HughesPJ import Data.Map (Map) ; import qualified Data.Map as Map diff --git a/language-c/src/Language/C/Analysis/DefTable.hs b/language-c/src/Language/C/Analysis/DefTable.hs index 959e525e..cb7dc55a 100644 --- a/language-c/src/Language/C/Analysis/DefTable.hs +++ b/language-c/src/Language/C/Analysis/DefTable.hs @@ -108,7 +108,7 @@ emptyDefTable = DefTable nameSpaceMap nameSpaceMap nameSpaceMap nameSpaceMap Int -- | get the globally defined entries of a definition table globalDefs :: DefTable -> GlobalDecls -globalDefs deftbl = Map.foldWithKey insertDecl (GlobalDecls e gtags e) (globalNames $ identDecls deftbl) +globalDefs deftbl = Map.foldrWithKey insertDecl (GlobalDecls e gtags e) (globalNames $ identDecls deftbl) where e = Map.empty (_fwd_decls,gtags) = Map.mapEither id $ globalNames (tagDecls deftbl) diff --git a/language-c/src/Language/C/Analysis/SemRep.hs b/language-c/src/Language/C/Analysis/SemRep.hs index 54cb134c..7f527be0 100644 --- a/language-c/src/Language/C/Analysis/SemRep.hs +++ b/language-c/src/Language/C/Analysis/SemRep.hs @@ -137,7 +137,7 @@ splitIdentDecls :: Bool -> Map Ident IdentDecl -> (Map Ident Decl, ( Map Ident Enumerator, Map Ident ObjDef, Map Ident FunDef ) ) -splitIdentDecls include_all = Map.foldWithKey (if include_all then deal else deal') (Map.empty,(Map.empty,Map.empty,Map.empty)) +splitIdentDecls include_all = Map.foldrWithKey (if include_all then deal else deal') (Map.empty,(Map.empty,Map.empty,Map.empty)) where deal ident entry (decls,defs) = (Map.insert ident (declOfDef entry) decls, addDef ident entry defs) deal' ident (Declaration d) (decls,defs) = (Map.insert ident d decls,defs) diff --git a/language-c/src/Language/C/Analysis/TypeCheck.hs b/language-c/src/Language/C/Analysis/TypeCheck.hs index e51ed148..f18d8e39 100644 --- a/language-c/src/Language/C/Analysis/TypeCheck.hs +++ b/language-c/src/Language/C/Analysis/TypeCheck.hs @@ -64,16 +64,16 @@ conditionalType' ni t1 t2 = typeErrorOnLeft ni $ conditionalType t1 t2 checkScalar :: Type -> Either String () checkScalar t = case canonicalType t of - DirectType _ _ _ -> return () - PtrType _ _ _ -> return () - ArrayType _ _ _ _ -> return () -- because it's just a pointer - t' -> fail $ + DirectType _ _ _ -> Right () + PtrType _ _ _ -> Right () + ArrayType _ _ _ _ -> Right () -- because it's just a pointer + t' -> Left $ "expected scalar type, got: " ++ pType t ++ " (" ++ pType t' ++ ")" checkIntegral :: Type -> Either String () -checkIntegral t | isIntegralType (canonicalType t) = return () - | otherwise = fail $ +checkIntegral t | isIntegralType (canonicalType t) = Right () + | otherwise = Left $ "expected integral type, got: " ++ pType t ++ " (" ++ pType (canonicalType t) ++ ")" @@ -110,60 +110,60 @@ compatible t1 t2 = compositeType t1 t2 >> return () -- | Determine the composite type of two compatible types. compositeType :: Type -> Type -> Either String Type -compositeType t1 (DirectType (TyBuiltin TyAny) _ _) = return t1 -compositeType (DirectType (TyBuiltin TyAny) _ _) t2 = return t2 +compositeType t1 (DirectType (TyBuiltin TyAny) _ _) = Right t1 +compositeType (DirectType (TyBuiltin TyAny) _ _) t2 = Right t2 compositeType t1@(DirectType tn1 q1 a1) t2@(DirectType tn2 q2 a2) = do tn <- case (tn1, tn2) of - (TyVoid, TyVoid) -> return TyVoid - (TyIntegral _, TyEnum _) -> return tn1 - (TyEnum _, TyIntegral _) -> return tn2 + (TyVoid, TyVoid) -> Right TyVoid + (TyIntegral _, TyEnum _) -> Right tn1 + (TyEnum _, TyIntegral _) -> Right tn2 (TyIntegral i1, TyIntegral i2) -> - return $ TyIntegral (intConversion i1 i2) + Right $ TyIntegral (intConversion i1 i2) (TyFloating f1, TyFloating f2) -> - return $ TyFloating (floatConversion f1 f2) + Right $ TyFloating (floatConversion f1 f2) (TyComplex f1, TyComplex f2) -> - return $ TyComplex (floatConversion f1 f2) + Right $ TyComplex (floatConversion f1 f2) (TyComp c1, TyComp c2) -> do when (sueRef c1 /= sueRef c2) $ - fail $ "incompatible composite types: " + Left $ "incompatible composite types: " ++ pType t1 ++ ", " ++ pType t2 - return tn1 + Right tn1 (TyEnum e1, TyEnum e2) -> do when (sueRef e1 /= sueRef e2) $ - fail $ "incompatible enumeration types: " + Left $ "incompatible enumeration types: " ++ pType t1 ++ ", " ++ pType t2 - return $ TyEnum e1 + Right $ TyEnum e1 (TyBuiltin TyVaList, TyBuiltin TyVaList) -> - return $ TyBuiltin TyVaList + Right $ TyBuiltin TyVaList (TyBuiltin _, TyBuiltin _) -> - fail $ "incompatible builtin types: " + Left $ "incompatible builtin types: " ++ pType t1 ++ ", " ++ pType t2 - (_, _) -> fail $ "incompatible direct types: " + (_, _) -> Left $ "incompatible direct types: " ++ pType t1 ++ ", " ++ pType t2 - return $ DirectType tn (mergeTypeQuals q1 q2) (mergeAttributes a1 a2) + Right $ DirectType tn (mergeTypeQuals q1 q2) (mergeAttributes a1 a2) compositeType (PtrType t1 q1 a1) (PtrType (DirectType TyVoid _ _) q2 _) = - return $ PtrType t1 (mergeTypeQuals q1 q2) a1 + Right $ PtrType t1 (mergeTypeQuals q1 q2) a1 compositeType (PtrType (DirectType TyVoid _ _) q1 _) (PtrType t2 q2 a2) = - return $ PtrType t2 (mergeTypeQuals q1 q2) a2 + Right $ PtrType t2 (mergeTypeQuals q1 q2) a2 compositeType (PtrType t1 q1 a1) t2 | isIntegralType t2 = - return $ PtrType t1 (mergeTypeQuals q1 (typeQuals t2)) a1 + Right $ PtrType t1 (mergeTypeQuals q1 (typeQuals t2)) a1 compositeType t1 (PtrType t2 q2 a2) | isIntegralType t1 = - return $ PtrType t2 (mergeTypeQuals (typeQuals t1) q2) a2 + Right $ PtrType t2 (mergeTypeQuals (typeQuals t1) q2) a2 compositeType (ArrayType t1 sz1 q1 a1) t2 | isIntegralType t2 = - return $ PtrType t1 q1 a1 + Right $ PtrType t1 q1 a1 compositeType t1 (ArrayType t2 sz2 q2 a2) | isIntegralType t1 = - return $ PtrType t2 q2 a2 + Right $ PtrType t2 q2 a2 compositeType (ArrayType t1 s1 q1 a1) (ArrayType t2 s2 q2 a2) = do t <- compositeType t1 t2 s <- compositeSize s1 s2 let quals = mergeTypeQuals q1 q2 attrs = mergeAttrs a1 a2 - return (ArrayType t s quals attrs) + Right (ArrayType t s quals attrs) compositeType t1 t2 | isPointerType t1 && isPointerType t2 = do t <- compositeType (baseType t1) (baseType t2) let quals = mergeTypeQuals (typeQuals t1) (typeQuals t2) attrs = mergeAttrs (typeAttrs t1) (typeAttrs t2) - return (PtrType t quals attrs) + Right (PtrType t quals attrs) compositeType (TypeDefType tdr1 q1 a1) (TypeDefType tdr2 q2 a2) = case (tdr1, tdr2) of (TypeDefRef i1 Nothing _, TypeDefRef i2 _ _) -> doTypeDef i1 i2 tdr1 @@ -171,17 +171,17 @@ compositeType (TypeDefType tdr1 q1 a1) (TypeDefType tdr2 q2 a2) = (TypeDefRef _ (Just t1) _, TypeDefRef _ (Just t2) _) -> compositeType t1 t2 where doTypeDef i1 i2 tdr = - do when (i1 /= i2) $ fail $ "incompatible typedef types: " + do when (i1 /= i2) $ Left $ "incompatible typedef types: " ++ identToString i1 ++ ", " ++ identToString i2 - return (TypeDefType tdr (mergeTypeQuals q1 q2) (mergeAttributes a1 a2)) + Right (TypeDefType tdr (mergeTypeQuals q1 q2) (mergeAttributes a1 a2)) compositeType (FunctionType ft1 attrs1) (FunctionType ft2 attrs2) = case (ft1, ft2) of (FunType rt1 args1 varargs1, FunType rt2 args2 varargs2) -> do {- when (length args1 /= length args2) $ - fail "different numbers of arguments in function types" -} + Left "different numbers of arguments in function types" -} args <- mapM (uncurry compositeParamDecl) (zip args1 args2) when (varargs1 /= varargs2) $ - fail "incompatible varargs declarations" + Left "incompatible varargs declarations" doFunType rt1 rt2 args varargs1 (FunType rt1 args1 varargs1, FunTypeIncomplete rt2) -> doFunType rt1 rt2 args1 varargs1 @@ -189,22 +189,22 @@ compositeType (FunctionType ft1 attrs1) (FunctionType ft2 attrs2) = doFunType rt1 rt2 args2 varargs2 (FunTypeIncomplete rt1, FunTypeIncomplete rt2) -> do rt <- compositeType rt1 rt2 - return (FunctionType (FunTypeIncomplete rt) (mergeAttrs attrs1 attrs2)) + Right (FunctionType (FunTypeIncomplete rt) (mergeAttrs attrs1 attrs2)) where doFunType rt1 rt2 args varargs = do rt <- compositeType rt1 rt2 - return (FunctionType + Right (FunctionType (FunType rt args varargs) (mergeAttrs attrs1 attrs2)) -compositeType t1 t2 = fail $ "incompatible types: " +compositeType t1 t2 = Left $ "incompatible types: " ++ pType t1 ++ ", " ++ pType t2 -- XXX: this may not be correct compositeSize :: ArraySize -> ArraySize -> Either String ArraySize -compositeSize (UnknownArraySize _) s2 = return s2 -compositeSize s1 (UnknownArraySize _) = return s1 +compositeSize (UnknownArraySize _) s2 = Right s2 +compositeSize s1 (UnknownArraySize _) = Right s1 compositeSize (ArraySize s1 e1) (ArraySize s2 e2) - | s1 == s2 && sizeEqual e1 e2 = return $ ArraySize s1 e1 - | otherwise = return $ ArraySize s1 e1 + | s1 == s2 && sizeEqual e1 e2 = Right $ ArraySize s1 e1 + | otherwise = Right $ ArraySize s1 e1 {- fail $ "incompatible array sizes: " ++ (render . pretty) e1 ++ ", " ++ (render . pretty) e2 @@ -234,14 +234,14 @@ compositeParamDecl' :: (VarDecl -> NodeInfo -> ParamDecl) -> Either String ParamDecl compositeParamDecl' f (VarDecl n1 attrs1 t1) (VarDecl n2 attrs2 t2) dni = do vd <- compositeVarDecl (VarDecl n1 attrs1 t1') (VarDecl n2 attrs2 t2') - return $ f vd dni + Right $ f vd dni where t1' = canonicalType t1 t2' = canonicalType t2 compositeVarDecl :: VarDecl -> VarDecl -> Either String VarDecl compositeVarDecl (VarDecl n1 attrs1 t1) (VarDecl _ attrs2 t2) = do t <- compositeType t1 t2 - return (VarDecl n1 (compositeDeclAttrs attrs1 attrs2) t) + Right (VarDecl n1 (compositeDeclAttrs attrs1 attrs2) t) -- XXX: bad treatement of inline and storage compositeDeclAttrs :: DeclAttrs -> DeclAttrs -> DeclAttrs @@ -251,39 +251,39 @@ compositeDeclAttrs (DeclAttrs inl stor attrs1) (DeclAttrs _ _ attrs2) = castCompatible :: Type -> Type -> Either String () castCompatible t1 t2 = case (canonicalType t1, canonicalType t2) of - (DirectType TyVoid _ _, _) -> return () + (DirectType TyVoid _ _, _) -> Right () (_, _) -> checkScalar t1 >> checkScalar t2 -- | Determine whether two types are compatible in an assignment expression. assignCompatible :: CAssignOp -> Type -> Type -> Either String () assignCompatible CAssignOp t1 t2 = case (canonicalType t1, canonicalType t2) of - (DirectType (TyBuiltin TyAny) _ _, _) -> return () - (_, DirectType (TyBuiltin TyAny) _ _) -> return () + (DirectType (TyBuiltin TyAny) _ _, _) -> Right () + (_, DirectType (TyBuiltin TyAny) _ _) -> Right () -- XXX: check qualifiers - (PtrType (DirectType TyVoid _ _) _ _, t2') | isPointerType t2' -> return () + (PtrType (DirectType TyVoid _ _) _ _, t2') | isPointerType t2' -> Right () -- XXX: check qualifiers - (t1', PtrType (DirectType TyVoid _ _) _ _) | isPointerType t1' -> return () - (PtrType _ _ _, t2') | isIntegralType t2' -> return () + (t1', PtrType (DirectType TyVoid _ _) _ _) | isPointerType t1' -> Right () + (PtrType _ _ _, t2') | isIntegralType t2' -> Right () (t1', t2') | isPointerType t1' && isPointerType t2' -> do compatible (baseType t1') (baseType t2') --unless (typeQuals t2 <= typeQuals t1) $ - -- fail $ + -- Left $ -- "incompatible qualifiers in pointer assignment: " -- ++ pType t1 ++ ", " ++ pType t2 (DirectType (TyComp c1) _ _, DirectType (TyComp c2) _ _) - | sueRef c1 == sueRef c2 -> return () - | otherwise -> fail $ + | sueRef c1 == sueRef c2 -> Right () + | otherwise -> Left $ "incompatible compound types in assignment: " ++ pType t1 ++ ", " ++ pType t2 (DirectType (TyBuiltin TyVaList) _ _, DirectType (TyBuiltin TyVaList) _ _) -> - return () + Right () (DirectType tn1 _ _, DirectType tn2 _ _) - | isJust (arithmeticConversion tn1 tn2) -> return () - | otherwise -> fail $ "incompatible direct types in assignment: " + | isJust (arithmeticConversion tn1 tn2) -> Right () + | otherwise -> Left $ "incompatible direct types in assignment: " ++ pType t1 ++ ", " ++ pType t2 (t1', t2') -> compatible t1' t2' -assignCompatible op t1 t2 = binopType (assignBinop op) t1 t2 >> return () +assignCompatible op t1 t2 = binopType (assignBinop op) t1 t2 >> Right () -- | Determine the type of a binary operation. binopType :: CBinaryOp -> Type -> Type -> Either String Type @@ -291,83 +291,83 @@ binopType op t1 t2 = case (op, canonicalType t1, canonicalType t2) of (_, t1', t2') | isLogicOp op -> - checkScalar t1' >> checkScalar t2' >> return boolType + checkScalar t1' >> checkScalar t2' >> Right boolType | isCmpOp op -> case (t1', t2') of (DirectType tn1 _ _, DirectType tn2 _ _) -> case arithmeticConversion tn1 tn2 of - Just _ -> return boolType - Nothing -> fail + Just _ -> Right boolType + Nothing -> Left "incompatible arithmetic types in comparison" (PtrType (DirectType TyVoid _ _) _ _, _) - | isPointerType t2' -> return boolType + | isPointerType t2' -> Right boolType (_, PtrType (DirectType TyVoid _ _) _ _) - | isPointerType t1' -> return boolType + | isPointerType t1' -> Right boolType (_, _) - | isPointerType t1' && isIntegralType t2' -> return boolType - | isIntegralType t1' && isPointerType t2' -> return boolType + | isPointerType t1' && isIntegralType t2' -> Right boolType + | isIntegralType t1' && isPointerType t2' -> Right boolType | isPointerType t1' && isPointerType t2' -> - compatible t1' t2' >> return boolType - (_, _) -> fail "incompatible types in comparison" + compatible t1' t2' >> Right boolType + (_, _) -> Left "incompatible types in comparison" (CSubOp, ArrayType t1' _ _ _, ArrayType t2' _ _ _) -> - compatible t1' t2' >> return ptrDiffType + compatible t1' t2' >> Right ptrDiffType (CSubOp, ArrayType t1' _ _ _, PtrType t2' _ _) -> - compatible t1' t2' >> return ptrDiffType + compatible t1' t2' >> Right ptrDiffType (CSubOp, PtrType t1' _ _, ArrayType t2' _ _ _) -> - compatible t1' t2' >> return ptrDiffType + compatible t1' t2' >> Right ptrDiffType (CSubOp, PtrType t1' _ _, PtrType t2' _ _) -> - compatible t1' t2' >> return ptrDiffType + compatible t1' t2' >> Right ptrDiffType (_, PtrType _ _ _, t2') - | isPtrOp op && isIntegralType t2' -> return t1 - | otherwise -> fail $ "invalid pointer operation: " ++ render (pretty op) - (CAddOp, t1', PtrType _ _ _) | isIntegralType t1' -> return t2 + | isPtrOp op && isIntegralType t2' -> Right t1 + | otherwise -> Left $ "invalid pointer operation: " ++ render (pretty op) + (CAddOp, t1', PtrType _ _ _) | isIntegralType t1' -> Right t2 (_, ArrayType _ _ _ _, t2') - | isPtrOp op && isIntegralType t2' -> return t1 - | otherwise -> fail $ "invalid pointer operation: " ++ render (pretty op) - (CAddOp, t1', ArrayType _ _ _ _) | isIntegralType t1' -> return t2 + | isPtrOp op && isIntegralType t2' -> Right t1 + | otherwise -> Left $ "invalid pointer operation: " ++ render (pretty op) + (CAddOp, t1', ArrayType _ _ _ _) | isIntegralType t1' -> Right t2 (_, DirectType tn1 q1 a1, DirectType tn2 q2 a2) -> do when (isBitOp op) (checkIntegral t1 >> checkIntegral t2) case arithmeticConversion tn1 tn2 of - Just tn -> return $ DirectType tn (mergeTypeQuals q1 q2) (mergeAttributes a1 a2) - Nothing -> fail $ render $ + Just tn -> Right $ DirectType tn (mergeTypeQuals q1 q2) (mergeAttributes a1 a2) + Nothing -> Left $ render $ text "invalid binary operation:" <+> pretty t1 <+> pretty op <+> pretty t2 - (_, _, _) -> fail $ render $ + (_, _, _) -> Left $ render $ text "unhandled binary operation:" <+> pretty t1 <+> pretty op <+> pretty t2 -- | Determine the type of a conditional expression. conditionalType :: Type -> Type -> Either String Type conditionalType t1 t2 = case (canonicalType t1, canonicalType t2) of - (PtrType (DirectType TyVoid _ _) _ _, t2') | isPointerType t2' -> return t2 - (t1', PtrType (DirectType TyVoid _ _) _ _) | isPointerType t1' -> return t1 + (PtrType (DirectType TyVoid _ _) _ _, t2') | isPointerType t2' -> Right t2 + (t1', PtrType (DirectType TyVoid _ _) _ _) | isPointerType t1' -> Right t1 (ArrayType t1' _ q1 a1, ArrayType t2' _ q2 a2) -> do t <- compositeType t1' t2' - return $ ArrayType t (UnknownArraySize False) + Right $ ArrayType t (UnknownArraySize False) (mergeTypeQuals q1 q2) (mergeAttrs a1 a2) (t1'@(DirectType tn1 q1 a1), t2'@(DirectType tn2 q2 a2)) -> case arithmeticConversion tn1 tn2 of - Just tn -> return $ DirectType tn (mergeTypeQuals q1 q2) (mergeAttributes a1 a2) + Just tn -> Right $ DirectType tn (mergeTypeQuals q1 q2) (mergeAttributes a1 a2) Nothing -> compositeType t1' t2' (t1', t2') -> compositeType t1' t2' derefType :: Type -> Either String Type -derefType (PtrType t _ _) = return t -derefType (ArrayType t _ _ _) = return t +derefType (PtrType t _ _) = Right t +derefType (ArrayType t _ _ _) = Right t derefType t = -- XXX: is it good to use canonicalType here? case canonicalType t of - PtrType t' _ _ -> return t' - ArrayType t' _ _ _ -> return t' - _ -> fail $ "dereferencing non-pointer: " ++ pType t + PtrType t' _ _ -> Right t' + ArrayType t' _ _ _ -> Right t' + _ -> Left $ "dereferencing non-pointer: " ++ pType t varAddrType :: IdentDecl -> Either String Type varAddrType d = do case declStorage d of - Auto True -> fail "address of register variable" - _ -> return () + Auto True -> Left "address of register variable" + _ -> Right () case t of - ArrayType _ _ q a -> return $ PtrType t q a - _ -> return $ simplePtr t + ArrayType _ _ q a -> Right $ PtrType t q a + _ -> Right $ simplePtr t where t = declType d -- | Get the type of field @m@ of type @t@ diff --git a/language-c/src/Language/C/Parser/ParserMonad.hs b/language-c/src/Language/C/Parser/ParserMonad.hs index 76ba40e6..b710870a 100644 --- a/language-c/src/Language/C/Parser/ParserMonad.hs +++ b/language-c/src/Language/C/Parser/ParserMonad.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} ----------------------------------------------------------------------------- -- | -- Module : Language.C.Syntax.ParserMonad @@ -48,6 +49,9 @@ import Language.C.Parser.Tokens (CToken(CTokEof)) import Control.Applicative (Applicative(..)) import Control.Monad (liftM, ap) +#if MIN_VERSION_base(4,9,0) +import Control.Monad.Fail (MonadFail (..)) +#endif import Data.Set (Set) import qualified Data.Set as Set (fromList, insert, member, delete) @@ -82,8 +86,14 @@ instance Applicative P where instance Monad P where return = returnP (>>=) = thenP +#if !MIN_VERSION_base(4,13,0) fail m = getPos >>= \pos -> failP pos [m] +#endif +#if MIN_VERSION_base(4,9,0) +instance MonadFail P where + fail m = getPos >>= \pos -> failP pos [m] +#endif -- | execute the given parser on the supplied input stream. -- returns 'ParseError' if the parser failed, and a pair of diff --git a/language-c/src/Language/C/Pretty.hs b/language-c/src/Language/C/Pretty.hs index 52d44ca2..11f5fa1a 100644 --- a/language-c/src/Language/C/Pretty.hs +++ b/language-c/src/Language/C/Pretty.hs @@ -20,6 +20,7 @@ module Language.C.Pretty ( ) where import Data.List (partition,nub,isSuffixOf) import qualified Data.Set as Set +import Prelude hiding ((<>)) import Text.PrettyPrint.HughesPJ import Debug.Trace {- for warnings -}