module Language.C.Analysis.TypeUtils (
integral,
floating,
simplePtr,
uint16_tType,
uint32_tType,
uint64_tType,
size_tType,
ptrDiffType,
boolType,
voidType,
voidPtr,
constVoidPtr,
charPtr,
constCharPtr,
stringType,
valistType,
isIntegralType,
isFloatingType,
isPointerType,
isScalarType,
isFunctionType,
typeQuals,
typeQualsUpd,
typeAttrs,
typeAttrsUpd,
baseType,
derefTypeDef,
deepDerefTypeDef,
canonicalType,
sameType,
getIntType,
getFloatType
) where
import Language.C.Analysis.SemRep
import Language.C.Data.Node (CNode(..))
import Language.C.Syntax.AST (CExpression (..), CConstant (..))
import Language.C.Syntax.Constants
integral :: IntType -> Type
integral ty = DirectType (TyIntegral ty) noTypeQuals noAttributes
floating :: FloatType -> Type
floating ty = DirectType (TyFloating ty) noTypeQuals noAttributes
simplePtr :: Type -> Type
simplePtr t = PtrType t noTypeQuals []
constPtr :: Type -> Type
constPtr t = PtrType t (noTypeQuals { constant = True }) []
uint16_tType :: Type
uint16_tType = integral TyUShort
uint32_tType :: Type
uint32_tType = integral TyUInt
uint64_tType :: Type
uint64_tType = integral TyULLong
size_tType :: Type
size_tType = integral TyInt
ptrDiffType :: Type
ptrDiffType = integral TyInt
boolType :: Type
boolType = integral TyInt
voidType :: Type
voidType = DirectType TyVoid noTypeQuals noAttributes
voidPtr :: Type
voidPtr = simplePtr voidType
constVoidPtr :: Type
constVoidPtr = constPtr voidType
charPtr :: Type
charPtr = simplePtr (integral TyChar)
constCharPtr :: Type
constCharPtr = constPtr (integral TyChar)
stringType :: Type
stringType = ArrayType
(DirectType (TyIntegral TyChar)
(noTypeQuals { constant = True })
noAttributes)
(UnknownArraySize False)
noTypeQuals
[]
valistType :: Type
valistType = DirectType (TyBuiltin TyVaList) noTypeQuals noAttributes
isIntegralType :: Type -> Bool
isIntegralType (DirectType (TyIntegral _) _ _) = True
isIntegralType (DirectType (TyEnum _) _ _) = True
isIntegralType _ = False
isFloatingType :: Type -> Bool
isFloatingType (DirectType (TyFloating _) _ _) = True
isFloatingType _ = False
isPointerType :: Type -> Bool
isPointerType (PtrType _ _ _) = True
isPointerType (ArrayType _ _ _ _) = True
isPointerType _ = False
isScalarType :: Type -> Bool
isScalarType t = isIntegralType t || isPointerType t || isFloatingType t
isFunctionType :: Type -> Bool
isFunctionType ty =
case ty of TypeDefType (TypeDefRef _ actual_ty _) _ _ -> isFunctionType actual_ty
FunctionType _ _ -> True
_ -> False
typeQuals :: Type -> TypeQuals
typeQuals (DirectType _ q _) = q
typeQuals (PtrType _ q _) = q
typeQuals (ArrayType _ _ q _) = q
typeQuals (FunctionType _ _) = noTypeQuals
typeQuals (TypeDefType (TypeDefRef _ t _) q _) = mergeTypeQuals q (typeQuals t)
typeQualsUpd :: (TypeQuals -> TypeQuals) -> Type -> Type
typeQualsUpd f ty =
case ty of DirectType ty_name ty_quals ty_attrs -> DirectType ty_name (f ty_quals) ty_attrs
PtrType ty_inner ty_quals ty_attrs -> PtrType ty_inner (f ty_quals) ty_attrs
ArrayType ty_inner sz ty_quals ty_attrs -> ArrayType ty_inner sz (f ty_quals) ty_attrs
FunctionType ty_inner ty_attrs -> FunctionType ty_inner ty_attrs
TypeDefType ty_ref ty_quals ty_attrs -> TypeDefType ty_ref (f ty_quals) ty_attrs
typeAttrs :: Type -> Attributes
typeAttrs (DirectType _ _ a) = a
typeAttrs (PtrType _ _ a) = a
typeAttrs (ArrayType _ _ _ a) = a
typeAttrs (FunctionType _ a) = a
typeAttrs (TypeDefType (TypeDefRef _ t _) _ a) = mergeAttributes a (typeAttrs t)
typeAttrsUpd :: (Attributes -> Attributes) -> Type -> Type
typeAttrsUpd f ty =
case ty of DirectType ty_name ty_quals ty_attrs -> DirectType ty_name ty_quals (f ty_attrs)
PtrType ty_inner ty_quals ty_attrs -> PtrType ty_inner ty_quals (f ty_attrs)
ArrayType ty_inner sz ty_quals ty_attrs -> ArrayType ty_inner sz ty_quals (f ty_attrs)
FunctionType ty_inner ty_attrs -> FunctionType ty_inner (f ty_attrs)
TypeDefType ty_ref ty_quals ty_attrs -> TypeDefType ty_ref ty_quals (f ty_attrs)
baseType :: Type -> Type
baseType (PtrType t _ _) = t
baseType (ArrayType t _ _ _) = t
baseType _ = error "base of non-pointer type"
derefTypeDef :: Type -> Type
derefTypeDef (TypeDefType (TypeDefRef _ t _) q a) =
(typeAttrsUpd (mergeAttributes a) . typeQualsUpd (mergeTypeQuals q))
(derefTypeDef t)
derefTypeDef ty = ty
deepDerefTypeDef :: Type -> Type
deepDerefTypeDef (PtrType t quals attrs) =
PtrType (deepDerefTypeDef t) quals attrs
deepDerefTypeDef (ArrayType t size quals attrs) =
ArrayType (deepDerefTypeDef t) size quals attrs
deepDerefTypeDef (FunctionType (FunType rt params varargs) attrs) =
FunctionType (FunType (deepDerefTypeDef rt) params varargs) attrs
deepDerefTypeDef (FunctionType (FunTypeIncomplete rt) attrs) =
FunctionType (FunTypeIncomplete (deepDerefTypeDef rt)) attrs
deepDerefTypeDef (TypeDefType (TypeDefRef _ t _) q a) =
(typeAttrsUpd (mergeAttributes a) . typeQualsUpd (mergeTypeQuals q))
(deepDerefTypeDef t)
deepDerefTypeDef t = t
isVariablyModifiedType :: Type -> Bool
isVariablyModifiedType t =
case derefTypeDef t of
TypeDefType {} -> error "impossible: derefTypeDef t returned a TypeDefType"
DirectType {} -> False
PtrType ptr_ty _ _ -> isVariablyModifiedType ptr_ty
ArrayType _ sz _ _ -> isVariableArraySize sz
FunctionType {} -> False
where
isVariableArraySize :: ArraySize -> Bool
isVariableArraySize (UnknownArraySize isStarred) = isStarred
isVariableArraySize (ArraySize isStatic e) = isStatic || isConstantSize e
isConstantSize :: Expr -> Bool
isConstantSize (CConst (CIntConst {})) = True
isConstantSize _ = False
sameType :: Type -> Type -> Bool
sameType t1 t2 =
not (isVariablyModifiedType t1 || isVariablyModifiedType t2) && sameType'
where
sameType' =
case (derefTypeDef t1, derefTypeDef t2) of
(TypeDefType {}, _) -> error "impossible: derefTypeDef t1 returned a TypeDefType"
(_, TypeDefType {}) -> error "impossible: derefTypeDef t2 returned a TypeDefType"
(DirectType tn1 q1 _a1, DirectType tn2 q2 _a2) ->
sameTypeName tn1 tn2 && sameQuals q1 q2
(PtrType pt1 q1 _a1, PtrType pt2 q2 _a2) ->
sameType pt1 pt2 && sameQuals q1 q2
(ArrayType at1 sz1 q1 _a1, ArrayType at2 sz2 q2 _a2) ->
sameType at1 at2 && sameArraySize sz1 sz2 && sameQuals q1 q2
(FunctionType ft1 _a1, FunctionType ft2 _a2) ->
sameFunType ft1 ft2
_ -> False
sameTypeName :: TypeName -> TypeName -> Bool
sameTypeName t1 t2 =
case (t1, t2) of
(TyVoid, TyVoid) -> True
(TyIntegral i1, TyIntegral i2) -> i1 == i2
(TyFloating f1, TyFloating f2) -> f1 == f2
(TyComplex f1, TyComplex f2) -> f1 == f2
(TyComp ctr1, TyComp ctr2) -> sameCompTypeRef ctr1 ctr2
(TyEnum etr1, TyEnum etr2) -> sameEnumTypeRef etr1 etr2
(TyBuiltin b1, TyBuiltin b2) -> sameBuiltinType b1 b2
_ -> False
sameBuiltinType :: BuiltinType -> BuiltinType -> Bool
sameBuiltinType TyVaList TyVaList = True
sameBuiltinType TyAny TyAny = False
sameBuiltinType _ _ = False
sameCompTypeRef :: CompTypeRef -> CompTypeRef -> Bool
sameCompTypeRef (CompTypeRef sue1 kind1 _) (CompTypeRef sue2 kind2 _) =
sue1 == sue2 && kind1 == kind2
sameEnumTypeRef :: EnumTypeRef -> EnumTypeRef -> Bool
sameEnumTypeRef (EnumTypeRef sue1 _) (EnumTypeRef sue2 _) = sue1 == sue2
sameFunType :: FunType -> FunType -> Bool
sameFunType (FunType rt1 params1 isVar1) (FunType rt2 params2 isVar2) =
sameType rt1 rt2 && sameParamDecls params1 params2 && isVar1 == isVar2
where
sameParamDecls :: [ParamDecl] -> [ParamDecl] -> Bool
sameParamDecls param_list1 param_list2 =
length param_list1 == length param_list2
&& and (zipWith sameParamDecl param_list1 param_list2)
sameParamDecl :: ParamDecl -> ParamDecl -> Bool
sameParamDecl p1 p2 = sameType (declType p1) (declType p2)
sameFunType (FunTypeIncomplete rt1) (FunTypeIncomplete rt2) =
sameType rt1 rt2
sameFunType _ _ = False
sameArraySize :: ArraySize -> ArraySize -> Bool
sameArraySize (UnknownArraySize isStar1) (UnknownArraySize isStar2) = isStar1 == isStar2
sameArraySize (ArraySize s1 e1) (ArraySize s2 e2) = s1 == s2 && sizeEqual e1 e2
where
sizeEqual :: Expr -> Expr -> Bool
sizeEqual (CConst (CIntConst i1 _)) (CConst (CIntConst i2 _)) = i1 == i2
sizeEqual oe1 oe2 = nodeInfo oe1 == nodeInfo oe2
sameArraySize _ _ = False
sameQuals :: TypeQuals -> TypeQuals -> Bool
sameQuals (TypeQuals {constant = c1, volatile = v1, restrict = r1})
(TypeQuals {constant = c2, volatile = v2, restrict = r2}) =
c1 == c2 && v1 == v2 && r1 == r2
canonicalType :: Type -> Type
canonicalType t =
case deepDerefTypeDef t of
FunctionType ft attrs -> simplePtr (FunctionType ft attrs)
t' -> t'
testFlags :: Enum f => [f] -> Flags f -> Bool
testFlags flags fi = all (`testFlag` fi) flags
getIntType :: Flags CIntFlag -> IntType
getIntType flags | testFlags [FlagLongLong, FlagUnsigned] flags = TyULLong
| testFlag FlagLongLong flags = TyLLong
| testFlags [FlagLong, FlagUnsigned] flags = TyULong
| testFlag FlagLong flags = TyLong
| testFlag FlagUnsigned flags = TyUInt
| otherwise = TyInt
getFloatType :: String -> FloatType
getFloatType fs | last fs `elem` ['f', 'F'] = TyFloat
| last fs `elem` ['l', 'L'] = TyLDouble
| otherwise = TyDouble