{-# LANGUAGE FlexibleInstances, CPP #-}
module Language.C.Analysis.TypeCheck where

import Control.Monad
import Data.Maybe
import Language.C.Data.Ident
import Language.C.Data.Node
import Language.C.Data.Position
import Language.C.Pretty
import Language.C.Syntax.AST
import Language.C.Syntax.Constants
import Language.C.Syntax.Ops
import Language.C.Analysis.DefTable
import Language.C.Analysis.SemRep
import Language.C.Analysis.TravMonad
import Language.C.Analysis.TypeConversions
import Language.C.Analysis.TypeUtils
import Language.C.Analysis.Debug ()
import Text.PrettyPrint.HughesPJ

-- We used to re-implement and export the standard Either instance for
-- Monad, which is bad, because as of GHC 7 it is in Control.Monad.Instances
-- in base >4.2. For backwards compatibility with ghc-6.X, we use CPP here.
#if __GLASGOW_HASKELL__ < 700
instance Monad (Either String) where
    return        = Right
    Left  l >>= _ = Left l
    Right r >>= k = k r
    fail msg      = Left msg
#endif

pType :: Type -> String
pType :: Type -> String
pType = Doc -> String
render (Doc -> String) -> (Type -> Doc) -> Type -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> Doc
forall p. Pretty p => p -> Doc
pretty

typeErrorOnLeft :: (MonadCError m) => NodeInfo -> Either String a -> m a
typeErrorOnLeft :: NodeInfo -> Either String a -> m a
typeErrorOnLeft ni :: NodeInfo
ni (Left err :: String
err) = NodeInfo -> String -> m a
forall (m :: * -> *) a. MonadCError m => NodeInfo -> String -> m a
typeError NodeInfo
ni String
err
typeErrorOnLeft _  (Right v :: a
v)  = a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return a
v

-- XXX: this should use a custom error type, but typeMismatch isn't always right
typeError :: MonadCError m => NodeInfo -> String -> m a
typeError :: NodeInfo -> String -> m a
typeError = NodeInfo -> String -> m a
forall (m :: * -> *) a. MonadCError m => NodeInfo -> String -> m a
astError

notFound :: Ident -> Either String a
notFound :: Ident -> Either String a
notFound i :: Ident
i = String -> Either String a
forall a b. a -> Either a b
Left (String -> Either String a) -> String -> Either String a
forall a b. (a -> b) -> a -> b
$ "not found: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Ident -> String
identToString Ident
i

checkScalar' :: MonadCError m => NodeInfo -> Type -> m ()
checkScalar' :: NodeInfo -> Type -> m ()
checkScalar' ni :: NodeInfo
ni = NodeInfo -> Either String () -> m ()
forall (m :: * -> *) a.
MonadCError m =>
NodeInfo -> Either String a -> m a
typeErrorOnLeft NodeInfo
ni (Either String () -> m ())
-> (Type -> Either String ()) -> Type -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> Either String ()
checkScalar

checkIntegral' :: MonadCError m => NodeInfo -> Type -> m ()
checkIntegral' :: NodeInfo -> Type -> m ()
checkIntegral' ni :: NodeInfo
ni = NodeInfo -> Either String () -> m ()
forall (m :: * -> *) a.
MonadCError m =>
NodeInfo -> Either String a -> m a
typeErrorOnLeft NodeInfo
ni (Either String () -> m ())
-> (Type -> Either String ()) -> Type -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> Either String ()
checkIntegral

assignCompatible' :: MonadCError m =>
                     NodeInfo -> CAssignOp -> Type -> Type -> m ()
assignCompatible' :: NodeInfo -> CAssignOp -> Type -> Type -> m ()
assignCompatible' ni :: NodeInfo
ni op :: CAssignOp
op t1 :: Type
t1 t2 :: Type
t2 = NodeInfo -> Either String () -> m ()
forall (m :: * -> *) a.
MonadCError m =>
NodeInfo -> Either String a -> m a
typeErrorOnLeft NodeInfo
ni (CAssignOp -> Type -> Type -> Either String ()
assignCompatible CAssignOp
op Type
t1 Type
t2)

binopType' :: MonadCError m =>
              NodeInfo -> CBinaryOp -> Type -> Type -> m Type
binopType' :: NodeInfo -> CBinaryOp -> Type -> Type -> m Type
binopType' ni :: NodeInfo
ni op :: CBinaryOp
op t1 :: Type
t1 t2 :: Type
t2 = NodeInfo -> Either String Type -> m Type
forall (m :: * -> *) a.
MonadCError m =>
NodeInfo -> Either String a -> m a
typeErrorOnLeft NodeInfo
ni (CBinaryOp -> Type -> Type -> Either String Type
binopType CBinaryOp
op Type
t1 Type
t2)

conditionalType' :: MonadCError m => NodeInfo -> Type -> Type -> m Type
conditionalType' :: NodeInfo -> Type -> Type -> m Type
conditionalType' ni :: NodeInfo
ni t1 :: Type
t1 t2 :: Type
t2 = NodeInfo -> Either String Type -> m Type
forall (m :: * -> *) a.
MonadCError m =>
NodeInfo -> Either String a -> m a
typeErrorOnLeft NodeInfo
ni (Either String Type -> m Type) -> Either String Type -> m Type
forall a b. (a -> b) -> a -> b
$ Type -> Type -> Either String Type
conditionalType Type
t1 Type
t2

checkScalar :: Type -> Either String ()
checkScalar :: Type -> Either String ()
checkScalar t :: Type
t =
  case Type -> Type
canonicalType Type
t of
    DirectType _ _ _  -> () -> Either String ()
forall a b. b -> Either a b
Right ()
    PtrType _ _ _     -> () -> Either String ()
forall a b. b -> Either a b
Right ()
    ArrayType _ _ _ _ -> () -> Either String ()
forall a b. b -> Either a b
Right () -- because it's just a pointer
    t' :: Type
t' -> String -> Either String ()
forall a b. a -> Either a b
Left (String -> Either String ()) -> String -> Either String ()
forall a b. (a -> b) -> a -> b
$
          "expected scalar type, got: "
          String -> String -> String
forall a. [a] -> [a] -> [a]
++ Type -> String
pType Type
t String -> String -> String
forall a. [a] -> [a] -> [a]
++ " (" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Type -> String
pType Type
t' String -> String -> String
forall a. [a] -> [a] -> [a]
++ ")"

checkIntegral :: Type -> Either String ()
checkIntegral :: Type -> Either String ()
checkIntegral t :: Type
t | Type -> Bool
isIntegralType (Type -> Type
canonicalType Type
t) = () -> Either String ()
forall a b. b -> Either a b
Right ()
                | Bool
otherwise = String -> Either String ()
forall a b. a -> Either a b
Left (String -> Either String ()) -> String -> Either String ()
forall a b. (a -> b) -> a -> b
$
                              "expected integral type, got: " String -> String -> String
forall a. [a] -> [a] -> [a]
++
                              Type -> String
pType Type
t String -> String -> String
forall a. [a] -> [a] -> [a]
++ " (" String -> String -> String
forall a. [a] -> [a] -> [a]
++
                              Type -> String
pType (Type -> Type
canonicalType Type
t) String -> String -> String
forall a. [a] -> [a] -> [a]
++ ")"

-- | Determine the type of a constant.
constType :: (MonadCError m, MonadName m) => CConst -> m Type
constType :: CConst -> m Type
constType (CIntConst (CInteger _ _ flags :: Flags CIntFlag
flags) _) =
  Type -> m Type
forall (m :: * -> *) a. Monad m => a -> m a
return (Type -> m Type) -> Type -> m Type
forall a b. (a -> b) -> a -> b
$ TypeName -> TypeQuals -> Attributes -> Type
DirectType (IntType -> TypeName
TyIntegral (Flags CIntFlag -> IntType
getIntType Flags CIntFlag
flags)) TypeQuals
noTypeQuals Attributes
noAttributes
constType (CCharConst (CChar _ True) _) =
  Type -> m Type
forall (m :: * -> *) a. Monad m => a -> m a
return (Type -> m Type) -> Type -> m Type
forall a b. (a -> b) -> a -> b
$ TypeName -> TypeQuals -> Attributes -> Type
DirectType (IntType -> TypeName
TyIntegral IntType
TyInt) TypeQuals
noTypeQuals Attributes
noAttributes
constType (CCharConst (CChar _ False) _) =
  Type -> m Type
forall (m :: * -> *) a. Monad m => a -> m a
return (Type -> m Type) -> Type -> m Type
forall a b. (a -> b) -> a -> b
$ TypeName -> TypeQuals -> Attributes -> Type
DirectType (IntType -> TypeName
TyIntegral IntType
TyChar) TypeQuals
noTypeQuals Attributes
noAttributes
constType (CCharConst (CChars _ _) _)  =
  Type -> m Type
forall (m :: * -> *) a. Monad m => a -> m a
return (Type -> m Type) -> Type -> m Type
forall a b. (a -> b) -> a -> b
$ TypeName -> TypeQuals -> Attributes -> Type
DirectType (IntType -> TypeName
TyIntegral IntType
TyInt) TypeQuals
noTypeQuals Attributes
noAttributes -- XXX
constType (CFloatConst (CFloat fs :: String
fs) _) =
  Type -> m Type
forall (m :: * -> *) a. Monad m => a -> m a
return (Type -> m Type) -> Type -> m Type
forall a b. (a -> b) -> a -> b
$ TypeName -> TypeQuals -> Attributes -> Type
DirectType (FloatType -> TypeName
TyFloating (String -> FloatType
getFloatType String
fs)) TypeQuals
noTypeQuals Attributes
noAttributes
-- XXX: should strings have any type qualifiers or attributes?
constType (CStrConst (CString chars :: String
chars wide :: Bool
wide) ni :: NodeInfo
ni) =
  do Name
n <- m Name
forall (m :: * -> *). MonadName m => m Name
genName
     let charType :: IntType
charType | Bool
wide      = IntType
TyInt -- XXX: this isn't universal
                  | Bool
otherwise = IntType
TyChar
         ni' :: NodeInfo
ni' = Position -> Name -> NodeInfo
mkNodeInfo (NodeInfo -> Position
forall a. Pos a => a -> Position
posOf NodeInfo
ni) Name
n
         arraySize :: ArraySize
arraySize = Bool -> Expr -> ArraySize
ArraySize
                     Bool
True -- XXX: is it static?
                     (CConst -> Expr
forall a. CConstant a -> CExpression a
CConst
                      (CInteger -> NodeInfo -> CConst
forall a. CInteger -> a -> CConstant a
CIntConst
                       (Integer -> CInteger
cInteger (Int -> Integer
forall a. Integral a => a -> Integer
toInteger (String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
chars))) NodeInfo
ni'))
     Type -> m Type
forall (m :: * -> *) a. Monad m => a -> m a
return (Type -> m Type) -> Type -> m Type
forall a b. (a -> b) -> a -> b
$ Type -> ArraySize -> TypeQuals -> Attributes -> Type
ArrayType (TypeName -> TypeQuals -> Attributes -> Type
DirectType (IntType -> TypeName
TyIntegral IntType
charType) TypeQuals
noTypeQuals Attributes
noAttributes)
                        ArraySize
arraySize TypeQuals
noTypeQuals []

-- | Determine whether two types are compatible.
compatible :: Type -> Type -> Either String ()
compatible :: Type -> Type -> Either String ()
compatible t1 :: Type
t1 t2 :: Type
t2 = Either String Type -> Either String ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void(Either String Type -> Either String ())
-> Either String Type -> Either String ()
forall a b. (a -> b) -> a -> b
$ Type -> Type -> Either String Type
compositeType Type
t1 Type
t2

-- | Determine the composite type of two compatible types.
compositeType :: Type -> Type -> Either String Type
compositeType :: Type -> Type -> Either String Type
compositeType t1 :: Type
t1 (DirectType (TyBuiltin TyAny) _ _) = Type -> Either String Type
forall a b. b -> Either a b
Right Type
t1
compositeType (DirectType (TyBuiltin TyAny) _ _) t2 :: Type
t2 = Type -> Either String Type
forall a b. b -> Either a b
Right Type
t2
compositeType t1 :: Type
t1@(DirectType tn1 :: TypeName
tn1 q1 :: TypeQuals
q1 a1 :: Attributes
a1) t2 :: Type
t2@(DirectType tn2 :: TypeName
tn2 q2 :: TypeQuals
q2 a2 :: Attributes
a2) =
  do TypeName
tn <- case (TypeName
tn1, TypeName
tn2) of
             (TyVoid, TyVoid) -> TypeName -> Either String TypeName
forall a b. b -> Either a b
Right TypeName
TyVoid
             (TyIntegral _, TyEnum _) -> TypeName -> Either String TypeName
forall a b. b -> Either a b
Right TypeName
tn1
             (TyEnum _, TyIntegral _) -> TypeName -> Either String TypeName
forall a b. b -> Either a b
Right TypeName
tn2
             (TyIntegral i1 :: IntType
i1, TyIntegral i2 :: IntType
i2) ->
               TypeName -> Either String TypeName
forall a b. b -> Either a b
Right (TypeName -> Either String TypeName)
-> TypeName -> Either String TypeName
forall a b. (a -> b) -> a -> b
$ IntType -> TypeName
TyIntegral (IntType -> IntType -> IntType
intConversion IntType
i1 IntType
i2)
             (TyFloating f1 :: FloatType
f1, TyFloating f2 :: FloatType
f2) ->
               TypeName -> Either String TypeName
forall a b. b -> Either a b
Right (TypeName -> Either String TypeName)
-> TypeName -> Either String TypeName
forall a b. (a -> b) -> a -> b
$ FloatType -> TypeName
TyFloating (FloatType -> FloatType -> FloatType
floatConversion FloatType
f1 FloatType
f2)
             (TyComplex f1 :: FloatType
f1, TyComplex f2 :: FloatType
f2) ->
               TypeName -> Either String TypeName
forall a b. b -> Either a b
Right (TypeName -> Either String TypeName)
-> TypeName -> Either String TypeName
forall a b. (a -> b) -> a -> b
$ FloatType -> TypeName
TyComplex (FloatType -> FloatType -> FloatType
floatConversion FloatType
f1 FloatType
f2)
             (TyComp c1 :: CompTypeRef
c1, TyComp c2 :: CompTypeRef
c2) ->
               do Bool -> Either String () -> Either String ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (CompTypeRef -> SUERef
forall a. HasSUERef a => a -> SUERef
sueRef CompTypeRef
c1 SUERef -> SUERef -> Bool
forall a. Eq a => a -> a -> Bool
/= CompTypeRef -> SUERef
forall a. HasSUERef a => a -> SUERef
sueRef CompTypeRef
c2) (Either String () -> Either String ())
-> Either String () -> Either String ()
forall a b. (a -> b) -> a -> b
$
                       String -> Either String ()
forall a b. a -> Either a b
Left (String -> Either String ()) -> String -> Either String ()
forall a b. (a -> b) -> a -> b
$ "incompatible composite types: "
                              String -> String -> String
forall a. [a] -> [a] -> [a]
++ Type -> String
pType Type
t1 String -> String -> String
forall a. [a] -> [a] -> [a]
++ ", " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Type -> String
pType Type
t2
                  TypeName -> Either String TypeName
forall a b. b -> Either a b
Right TypeName
tn1
             (TyEnum e1 :: EnumTypeRef
e1, TyEnum e2 :: EnumTypeRef
e2) ->
               do Bool -> Either String () -> Either String ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (EnumTypeRef -> SUERef
forall a. HasSUERef a => a -> SUERef
sueRef EnumTypeRef
e1 SUERef -> SUERef -> Bool
forall a. Eq a => a -> a -> Bool
/= EnumTypeRef -> SUERef
forall a. HasSUERef a => a -> SUERef
sueRef EnumTypeRef
e2) (Either String () -> Either String ())
-> Either String () -> Either String ()
forall a b. (a -> b) -> a -> b
$
                       String -> Either String ()
forall a b. a -> Either a b
Left (String -> Either String ()) -> String -> Either String ()
forall a b. (a -> b) -> a -> b
$ "incompatible enumeration types: "
                              String -> String -> String
forall a. [a] -> [a] -> [a]
++ Type -> String
pType Type
t1 String -> String -> String
forall a. [a] -> [a] -> [a]
++ ", " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Type -> String
pType Type
t2
                  TypeName -> Either String TypeName
forall a b. b -> Either a b
Right (TypeName -> Either String TypeName)
-> TypeName -> Either String TypeName
forall a b. (a -> b) -> a -> b
$ EnumTypeRef -> TypeName
TyEnum EnumTypeRef
e1
             (TyBuiltin TyVaList, TyBuiltin TyVaList) ->
               TypeName -> Either String TypeName
forall a b. b -> Either a b
Right (TypeName -> Either String TypeName)
-> TypeName -> Either String TypeName
forall a b. (a -> b) -> a -> b
$ BuiltinType -> TypeName
TyBuiltin BuiltinType
TyVaList
             (TyBuiltin _, TyBuiltin _) ->
               String -> Either String TypeName
forall a b. a -> Either a b
Left (String -> Either String TypeName)
-> String -> Either String TypeName
forall a b. (a -> b) -> a -> b
$ "incompatible builtin types: "
                      String -> String -> String
forall a. [a] -> [a] -> [a]
++ Type -> String
pType Type
t1 String -> String -> String
forall a. [a] -> [a] -> [a]
++ ", " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Type -> String
pType Type
t2
             (_, _) -> String -> Either String TypeName
forall a b. a -> Either a b
Left (String -> Either String TypeName)
-> String -> Either String TypeName
forall a b. (a -> b) -> a -> b
$ "incompatible direct types: "
                       String -> String -> String
forall a. [a] -> [a] -> [a]
++ Type -> String
pType Type
t1 String -> String -> String
forall a. [a] -> [a] -> [a]
++ ", " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Type -> String
pType Type
t2
     Type -> Either String Type
forall a b. b -> Either a b
Right (Type -> Either String Type) -> Type -> Either String Type
forall a b. (a -> b) -> a -> b
$ TypeName -> TypeQuals -> Attributes -> Type
DirectType TypeName
tn (TypeQuals -> TypeQuals -> TypeQuals
mergeTypeQuals TypeQuals
q1 TypeQuals
q2) (Attributes -> Attributes -> Attributes
mergeAttributes Attributes
a1 Attributes
a2)
compositeType (PtrType t1 :: Type
t1 q1 :: TypeQuals
q1 a1 :: Attributes
a1) (PtrType (DirectType TyVoid _ _) q2 :: TypeQuals
q2 _) =
  Type -> Either String Type
forall a b. b -> Either a b
Right (Type -> Either String Type) -> Type -> Either String Type
forall a b. (a -> b) -> a -> b
$ Type -> TypeQuals -> Attributes -> Type
PtrType Type
t1 (TypeQuals -> TypeQuals -> TypeQuals
mergeTypeQuals TypeQuals
q1 TypeQuals
q2) Attributes
a1
compositeType (PtrType (DirectType TyVoid _ _) q1 :: TypeQuals
q1 _) (PtrType t2 :: Type
t2 q2 :: TypeQuals
q2 a2 :: Attributes
a2) =
  Type -> Either String Type
forall a b. b -> Either a b
Right (Type -> Either String Type) -> Type -> Either String Type
forall a b. (a -> b) -> a -> b
$ Type -> TypeQuals -> Attributes -> Type
PtrType Type
t2 (TypeQuals -> TypeQuals -> TypeQuals
mergeTypeQuals TypeQuals
q1 TypeQuals
q2) Attributes
a2
compositeType (PtrType t1 :: Type
t1 q1 :: TypeQuals
q1 a1 :: Attributes
a1) t2 :: Type
t2 | Type -> Bool
isIntegralType Type
t2 =
  Type -> Either String Type
forall a b. b -> Either a b
Right (Type -> Either String Type) -> Type -> Either String Type
forall a b. (a -> b) -> a -> b
$ Type -> TypeQuals -> Attributes -> Type
PtrType Type
t1 (TypeQuals -> TypeQuals -> TypeQuals
mergeTypeQuals TypeQuals
q1 (Type -> TypeQuals
typeQuals Type
t2)) Attributes
a1
compositeType t1 :: Type
t1 (PtrType t2 :: Type
t2 q2 :: TypeQuals
q2 a2 :: Attributes
a2) | Type -> Bool
isIntegralType Type
t1 =
  Type -> Either String Type
forall a b. b -> Either a b
Right (Type -> Either String Type) -> Type -> Either String Type
forall a b. (a -> b) -> a -> b
$ Type -> TypeQuals -> Attributes -> Type
PtrType Type
t2 (TypeQuals -> TypeQuals -> TypeQuals
mergeTypeQuals (Type -> TypeQuals
typeQuals Type
t1) TypeQuals
q2) Attributes
a2
compositeType (ArrayType t1 :: Type
t1 _sz1 :: ArraySize
_sz1 q1 :: TypeQuals
q1 a1 :: Attributes
a1) t2 :: Type
t2 | Type -> Bool
isIntegralType Type
t2 =
  Type -> Either String Type
forall a b. b -> Either a b
Right (Type -> Either String Type) -> Type -> Either String Type
forall a b. (a -> b) -> a -> b
$ Type -> TypeQuals -> Attributes -> Type
PtrType Type
t1 TypeQuals
q1 Attributes
a1
compositeType t1 :: Type
t1 (ArrayType t2 :: Type
t2 _sz2 :: ArraySize
_sz2 q2 :: TypeQuals
q2 a2 :: Attributes
a2) | Type -> Bool
isIntegralType Type
t1 =
  Type -> Either String Type
forall a b. b -> Either a b
Right (Type -> Either String Type) -> Type -> Either String Type
forall a b. (a -> b) -> a -> b
$ Type -> TypeQuals -> Attributes -> Type
PtrType Type
t2 TypeQuals
q2 Attributes
a2
compositeType (ArrayType t1 :: Type
t1 s1 :: ArraySize
s1 q1 :: TypeQuals
q1 a1 :: Attributes
a1) (ArrayType t2 :: Type
t2 s2 :: ArraySize
s2 q2 :: TypeQuals
q2 a2 :: Attributes
a2) =
  do Type
t <- Type -> Type -> Either String Type
compositeType Type
t1 Type
t2
     ArraySize
s <- ArraySize -> ArraySize -> Either String ArraySize
compositeSize ArraySize
s1 ArraySize
s2
     let quals :: TypeQuals
quals = TypeQuals -> TypeQuals -> TypeQuals
mergeTypeQuals TypeQuals
q1 TypeQuals
q2
         attrs :: Attributes
attrs = Attributes -> Attributes -> Attributes
mergeAttrs Attributes
a1 Attributes
a2
     Type -> Either String Type
forall a b. b -> Either a b
Right (Type -> ArraySize -> TypeQuals -> Attributes -> Type
ArrayType Type
t ArraySize
s TypeQuals
quals Attributes
attrs)
compositeType t1 :: Type
t1 t2 :: Type
t2 | Type -> Bool
isPointerType Type
t1 Bool -> Bool -> Bool
&& Type -> Bool
isPointerType Type
t2 =
  do Type
t <- Type -> Type -> Either String Type
compositeType (Type -> Type
baseType Type
t1) (Type -> Type
baseType Type
t2)
     let quals :: TypeQuals
quals = TypeQuals -> TypeQuals -> TypeQuals
mergeTypeQuals (Type -> TypeQuals
typeQuals Type
t1) (Type -> TypeQuals
typeQuals Type
t2)
         attrs :: Attributes
attrs = Attributes -> Attributes -> Attributes
mergeAttrs (Type -> Attributes
typeAttrs Type
t1) (Type -> Attributes
typeAttrs Type
t2)
     Type -> Either String Type
forall a b. b -> Either a b
Right (Type -> TypeQuals -> Attributes -> Type
PtrType Type
t TypeQuals
quals Attributes
attrs)
compositeType (TypeDefType tdr1 :: TypeDefRef
tdr1 _q1 :: TypeQuals
_q1 _a1 :: Attributes
_a1) (TypeDefType tdr2 :: TypeDefRef
tdr2 _q2 :: TypeQuals
_q2 _a2 :: Attributes
_a2) =
  case (TypeDefRef
tdr1, TypeDefRef
tdr2) of
    (TypeDefRef _ t1 :: Type
t1 _, TypeDefRef _ t2 :: Type
t2 _) ->
      Type -> Type -> Either String Type
compositeType Type
t1 Type
t2
compositeType (FunctionType ft1 :: FunType
ft1 attrs1 :: Attributes
attrs1) (FunctionType ft2 :: FunType
ft2 attrs2 :: Attributes
attrs2) =
  case (FunType
ft1, FunType
ft2) of
    (FunType rt1 :: Type
rt1 args1 :: [ParamDecl]
args1 varargs1 :: Bool
varargs1, FunType rt2 :: Type
rt2 args2 :: [ParamDecl]
args2 varargs2 :: Bool
varargs2) ->
      do {- when (length args1 /= length args2) $
              Left "different numbers of arguments in function types" -}
         [ParamDecl]
args <- (ParamDecl -> ParamDecl -> Either String ParamDecl)
-> [ParamDecl] -> [ParamDecl] -> Either String [ParamDecl]
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m [c]
zipWithM ParamDecl -> ParamDecl -> Either String ParamDecl
compositeParamDecl [ParamDecl]
args1 [ParamDecl]
args2
         Bool -> Either String () -> Either String ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool
varargs1 Bool -> Bool -> Bool
forall a. Eq a => a -> a -> Bool
/= Bool
varargs2) (Either String () -> Either String ())
-> Either String () -> Either String ()
forall a b. (a -> b) -> a -> b
$
              String -> Either String ()
forall a b. a -> Either a b
Left "incompatible varargs declarations"
         Type -> Type -> [ParamDecl] -> Bool -> Either String Type
doFunType Type
rt1 Type
rt2 [ParamDecl]
args Bool
varargs1
    (FunType rt1 :: Type
rt1 args1 :: [ParamDecl]
args1 varargs1 :: Bool
varargs1, FunTypeIncomplete rt2 :: Type
rt2) ->
      Type -> Type -> [ParamDecl] -> Bool -> Either String Type
doFunType Type
rt1 Type
rt2 [ParamDecl]
args1 Bool
varargs1
    (FunTypeIncomplete rt1 :: Type
rt1, FunType rt2 :: Type
rt2 args2 :: [ParamDecl]
args2 varargs2 :: Bool
varargs2) ->
      Type -> Type -> [ParamDecl] -> Bool -> Either String Type
doFunType Type
rt1 Type
rt2 [ParamDecl]
args2 Bool
varargs2
    (FunTypeIncomplete rt1 :: Type
rt1, FunTypeIncomplete rt2 :: Type
rt2) ->
      do Type
rt <- Type -> Type -> Either String Type
compositeType Type
rt1 Type
rt2
         Type -> Either String Type
forall a b. b -> Either a b
Right (FunType -> Attributes -> Type
FunctionType (Type -> FunType
FunTypeIncomplete Type
rt) (Attributes -> Attributes -> Attributes
mergeAttrs Attributes
attrs1 Attributes
attrs2))
  where doFunType :: Type -> Type -> [ParamDecl] -> Bool -> Either String Type
doFunType rt1 :: Type
rt1 rt2 :: Type
rt2 args :: [ParamDecl]
args varargs :: Bool
varargs =
          do Type
rt <- Type -> Type -> Either String Type
compositeType Type
rt1 Type
rt2
             Type -> Either String Type
forall a b. b -> Either a b
Right (FunType -> Attributes -> Type
FunctionType
                     (Type -> [ParamDecl] -> Bool -> FunType
FunType Type
rt [ParamDecl]
args Bool
varargs)
                     (Attributes -> Attributes -> Attributes
mergeAttrs Attributes
attrs1 Attributes
attrs2))
compositeType t1 :: Type
t1 t2 :: Type
t2 = String -> Either String Type
forall a b. a -> Either a b
Left (String -> Either String Type) -> String -> Either String Type
forall a b. (a -> b) -> a -> b
$ "incompatible types: "
                         String -> String -> String
forall a. [a] -> [a] -> [a]
++ Type -> String
pType Type
t1 String -> String -> String
forall a. [a] -> [a] -> [a]
++ ", " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Type -> String
pType Type
t2

-- XXX: this may not be correct
compositeSize :: ArraySize -> ArraySize -> Either String ArraySize
compositeSize :: ArraySize -> ArraySize -> Either String ArraySize
compositeSize (UnknownArraySize _) s2 :: ArraySize
s2 = ArraySize -> Either String ArraySize
forall a b. b -> Either a b
Right ArraySize
s2
compositeSize s1 :: ArraySize
s1 (UnknownArraySize _) = ArraySize -> Either String ArraySize
forall a b. b -> Either a b
Right ArraySize
s1
compositeSize (ArraySize s1 :: Bool
s1 e1 :: Expr
e1) (ArraySize s2 :: Bool
s2 e2 :: Expr
e2)
  | Bool
s1 Bool -> Bool -> Bool
forall a. Eq a => a -> a -> Bool
== Bool
s2 Bool -> Bool -> Bool
&& Expr -> Expr -> Bool
sizeEqual Expr
e1 Expr
e2 = ArraySize -> Either String ArraySize
forall a b. b -> Either a b
Right (ArraySize -> Either String ArraySize)
-> ArraySize -> Either String ArraySize
forall a b. (a -> b) -> a -> b
$ Bool -> Expr -> ArraySize
ArraySize Bool
s1 Expr
e1
  | Bool
otherwise = ArraySize -> Either String ArraySize
forall a b. b -> Either a b
Right (ArraySize -> Either String ArraySize)
-> ArraySize -> Either String ArraySize
forall a b. (a -> b) -> a -> b
$ Bool -> Expr -> ArraySize
ArraySize Bool
s1 Expr
e1
{-
    fail $ "incompatible array sizes: "
           ++ (render . pretty) e1 ++ ", " ++ (render . pretty) e2
-}

sizeEqual :: CExpr -> CExpr -> Bool
sizeEqual :: Expr -> Expr -> Bool
sizeEqual (CConst (CIntConst i1 :: CInteger
i1 _)) (CConst (CIntConst i2 :: CInteger
i2 _)) = CInteger
i1 CInteger -> CInteger -> Bool
forall a. Eq a => a -> a -> Bool
== CInteger
i2
sizeEqual e1 :: Expr
e1 e2 :: Expr
e2 = Expr -> NodeInfo
forall a. CNode a => a -> NodeInfo
nodeInfo Expr
e1 NodeInfo -> NodeInfo -> Bool
forall a. Eq a => a -> a -> Bool
== Expr -> NodeInfo
forall a. CNode a => a -> NodeInfo
nodeInfo Expr
e2

mergeAttrs :: Attributes -> Attributes -> Attributes
mergeAttrs :: Attributes -> Attributes -> Attributes
mergeAttrs = Attributes -> Attributes -> Attributes
forall a. [a] -> [a] -> [a]
(++) -- XXX: ultimately this should be smarter

compositeParamDecl :: ParamDecl -> ParamDecl -> Either String ParamDecl
compositeParamDecl :: ParamDecl -> ParamDecl -> Either String ParamDecl
compositeParamDecl (ParamDecl vd1 :: VarDecl
vd1 ni1 :: NodeInfo
ni1) (ParamDecl vd2 :: VarDecl
vd2 _) =
  (VarDecl -> NodeInfo -> ParamDecl)
-> VarDecl -> VarDecl -> NodeInfo -> Either String ParamDecl
compositeParamDecl' VarDecl -> NodeInfo -> ParamDecl
ParamDecl VarDecl
vd1 VarDecl
vd2 NodeInfo
ni1
compositeParamDecl (AbstractParamDecl vd1 :: VarDecl
vd1 _) (ParamDecl vd2 :: VarDecl
vd2 ni2 :: NodeInfo
ni2) =
  (VarDecl -> NodeInfo -> ParamDecl)
-> VarDecl -> VarDecl -> NodeInfo -> Either String ParamDecl
compositeParamDecl' VarDecl -> NodeInfo -> ParamDecl
ParamDecl VarDecl
vd1 VarDecl
vd2 NodeInfo
ni2
compositeParamDecl (ParamDecl vd1 :: VarDecl
vd1 ni1 :: NodeInfo
ni1) (AbstractParamDecl vd2 :: VarDecl
vd2 _) =
  (VarDecl -> NodeInfo -> ParamDecl)
-> VarDecl -> VarDecl -> NodeInfo -> Either String ParamDecl
compositeParamDecl' VarDecl -> NodeInfo -> ParamDecl
ParamDecl VarDecl
vd1 VarDecl
vd2 NodeInfo
ni1
compositeParamDecl (AbstractParamDecl vd1 :: VarDecl
vd1 ni1 :: NodeInfo
ni1) (AbstractParamDecl vd2 :: VarDecl
vd2 _) =
  (VarDecl -> NodeInfo -> ParamDecl)
-> VarDecl -> VarDecl -> NodeInfo -> Either String ParamDecl
compositeParamDecl' VarDecl -> NodeInfo -> ParamDecl
AbstractParamDecl VarDecl
vd1 VarDecl
vd2 NodeInfo
ni1

compositeParamDecl' :: (VarDecl -> NodeInfo -> ParamDecl)
                    -> VarDecl
                    -> VarDecl
                    -> NodeInfo
                    -> Either String ParamDecl
compositeParamDecl' :: (VarDecl -> NodeInfo -> ParamDecl)
-> VarDecl -> VarDecl -> NodeInfo -> Either String ParamDecl
compositeParamDecl' f :: VarDecl -> NodeInfo -> ParamDecl
f (VarDecl n1 :: VarName
n1 attrs1 :: DeclAttrs
attrs1 t1 :: Type
t1) (VarDecl n2 :: VarName
n2 attrs2 :: DeclAttrs
attrs2 t2 :: Type
t2) dni :: NodeInfo
dni =
  do VarDecl
vd <- VarDecl -> VarDecl -> Either String VarDecl
compositeVarDecl (VarName -> DeclAttrs -> Type -> VarDecl
VarDecl VarName
n1 DeclAttrs
attrs1 Type
t1') (VarName -> DeclAttrs -> Type -> VarDecl
VarDecl VarName
n2 DeclAttrs
attrs2 Type
t2')
     ParamDecl -> Either String ParamDecl
forall a b. b -> Either a b
Right (ParamDecl -> Either String ParamDecl)
-> ParamDecl -> Either String ParamDecl
forall a b. (a -> b) -> a -> b
$ VarDecl -> NodeInfo -> ParamDecl
f VarDecl
vd NodeInfo
dni
  where t1' :: Type
t1' = Type -> Type
canonicalType Type
t1
        t2' :: Type
t2' = Type -> Type
canonicalType Type
t2

compositeVarDecl :: VarDecl -> VarDecl -> Either String VarDecl
compositeVarDecl :: VarDecl -> VarDecl -> Either String VarDecl
compositeVarDecl (VarDecl n1 :: VarName
n1 attrs1 :: DeclAttrs
attrs1 t1 :: Type
t1) (VarDecl _ attrs2 :: DeclAttrs
attrs2 t2 :: Type
t2) =
  do Type
t <- Type -> Type -> Either String Type
compositeType Type
t1 Type
t2
     VarDecl -> Either String VarDecl
forall a b. b -> Either a b
Right (VarName -> DeclAttrs -> Type -> VarDecl
VarDecl VarName
n1 (DeclAttrs -> DeclAttrs -> DeclAttrs
compositeDeclAttrs DeclAttrs
attrs1 DeclAttrs
attrs2) Type
t)

-- XXX: bad treatement of inline and storage
compositeDeclAttrs :: DeclAttrs -> DeclAttrs -> DeclAttrs
compositeDeclAttrs :: DeclAttrs -> DeclAttrs -> DeclAttrs
compositeDeclAttrs (DeclAttrs inl :: FunctionAttrs
inl stor :: Storage
stor attrs1 :: Attributes
attrs1) (DeclAttrs _ _ attrs2 :: Attributes
attrs2) =
  FunctionAttrs -> Storage -> Attributes -> DeclAttrs
DeclAttrs FunctionAttrs
inl Storage
stor (Attributes -> Attributes -> Attributes
mergeAttrs Attributes
attrs1 Attributes
attrs2)

castCompatible :: Type -> Type -> Either String ()
castCompatible :: Type -> Type -> Either String ()
castCompatible t1 :: Type
t1 t2 :: Type
t2 =
  case (Type -> Type
canonicalType Type
t1, Type -> Type
canonicalType Type
t2) of
    (DirectType TyVoid _ _, _) -> () -> Either String ()
forall a b. b -> Either a b
Right ()
    (_, _) -> Type -> Either String ()
checkScalar Type
t1 Either String () -> Either String () -> Either String ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Type -> Either String ()
checkScalar Type
t2

-- | Determine whether two types are compatible in an assignment expression.
assignCompatible :: CAssignOp -> Type -> Type -> Either String ()
assignCompatible :: CAssignOp -> Type -> Type -> Either String ()
assignCompatible CAssignOp t1 :: Type
t1 t2 :: Type
t2 =
  case (Type -> Type
canonicalType Type
t1, Type -> Type
canonicalType Type
t2) of
    (DirectType (TyBuiltin TyAny) _ _, _) -> () -> Either String ()
forall a b. b -> Either a b
Right ()
    (_, DirectType (TyBuiltin TyAny) _ _) -> () -> Either String ()
forall a b. b -> Either a b
Right ()
    -- XXX: check qualifiers
    (PtrType (DirectType TyVoid _ _) _ _, t2' :: Type
t2') | Type -> Bool
isPointerType Type
t2' -> () -> Either String ()
forall a b. b -> Either a b
Right ()
    -- XXX: check qualifiers
    (t1' :: Type
t1', PtrType (DirectType TyVoid _ _) _ _) | Type -> Bool
isPointerType Type
t1' -> () -> Either String ()
forall a b. b -> Either a b
Right ()
    (PtrType _ _ _, t2' :: Type
t2') | Type -> Bool
isIntegralType Type
t2' -> () -> Either String ()
forall a b. b -> Either a b
Right ()
    (t1' :: Type
t1', t2' :: Type
t2') | Type -> Bool
isPointerType Type
t1' Bool -> Bool -> Bool
&& Type -> Bool
isPointerType Type
t2' ->
                 Type -> Type -> Either String ()
compatible (Type -> Type
baseType Type
t1') (Type -> Type
baseType Type
t2')
                --unless (typeQuals t2 <= typeQuals t1) $
                --       Left $
                --       "incompatible qualifiers in pointer assignment: "
                --       ++ pType t1 ++ ", " ++ pType t2
    (DirectType (TyComp c1 :: CompTypeRef
c1) _ _, DirectType (TyComp c2 :: CompTypeRef
c2) _ _)
      | CompTypeRef -> SUERef
forall a. HasSUERef a => a -> SUERef
sueRef CompTypeRef
c1 SUERef -> SUERef -> Bool
forall a. Eq a => a -> a -> Bool
== CompTypeRef -> SUERef
forall a. HasSUERef a => a -> SUERef
sueRef CompTypeRef
c2 -> () -> Either String ()
forall a b. b -> Either a b
Right ()
      | Bool
otherwise -> String -> Either String ()
forall a b. a -> Either a b
Left (String -> Either String ()) -> String -> Either String ()
forall a b. (a -> b) -> a -> b
$
                     "incompatible compound types in assignment: "
                     String -> String -> String
forall a. [a] -> [a] -> [a]
++ Type -> String
pType Type
t1 String -> String -> String
forall a. [a] -> [a] -> [a]
++ ", " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Type -> String
pType Type
t2
    (DirectType (TyBuiltin TyVaList) _ _, DirectType (TyBuiltin TyVaList) _ _) ->
      () -> Either String ()
forall a b. b -> Either a b
Right ()
    (DirectType tn1 :: TypeName
tn1 _ _, DirectType tn2 :: TypeName
tn2 _ _)
      | Maybe TypeName -> Bool
forall a. Maybe a -> Bool
isJust (TypeName -> TypeName -> Maybe TypeName
arithmeticConversion TypeName
tn1 TypeName
tn2) -> () -> Either String ()
forall a b. b -> Either a b
Right ()
      | Bool
otherwise -> String -> Either String ()
forall a b. a -> Either a b
Left (String -> Either String ()) -> String -> Either String ()
forall a b. (a -> b) -> a -> b
$ "incompatible direct types in assignment: "
                     String -> String -> String
forall a. [a] -> [a] -> [a]
++ Type -> String
pType Type
t1 String -> String -> String
forall a. [a] -> [a] -> [a]
++ ", " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Type -> String
pType Type
t2
    (t1' :: Type
t1', t2' :: Type
t2') -> Type -> Type -> Either String ()
compatible Type
t1' Type
t2'
assignCompatible op :: CAssignOp
op t1 :: Type
t1 t2 :: Type
t2 = Either String Type -> Either String ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void(Either String Type -> Either String ())
-> Either String Type -> Either String ()
forall a b. (a -> b) -> a -> b
$ CBinaryOp -> Type -> Type -> Either String Type
binopType (CAssignOp -> CBinaryOp
assignBinop CAssignOp
op) Type
t1 Type
t2

-- | Determine the type of a binary operation.
binopType :: CBinaryOp -> Type -> Type -> Either String Type
binopType :: CBinaryOp -> Type -> Type -> Either String Type
binopType op :: CBinaryOp
op t1 :: Type
t1 t2 :: Type
t2 =
  case (CBinaryOp
op, Type -> Type
canonicalType Type
t1, Type -> Type
canonicalType Type
t2) of
    (_, t1' :: Type
t1', t2' :: Type
t2')
      | CBinaryOp -> Bool
isLogicOp CBinaryOp
op ->
        Type -> Either String ()
checkScalar Type
t1' Either String () -> Either String () -> Either String ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Type -> Either String ()
checkScalar Type
t2' Either String () -> Either String Type -> Either String Type
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Type -> Either String Type
forall a b. b -> Either a b
Right Type
boolType
      | CBinaryOp -> Bool
isCmpOp CBinaryOp
op ->
        case (Type
t1', Type
t2') of
          (DirectType tn1 :: TypeName
tn1 _ _, DirectType tn2 :: TypeName
tn2 _ _) ->
                case TypeName -> TypeName -> Maybe TypeName
arithmeticConversion TypeName
tn1 TypeName
tn2 of
                  Just _ -> Type -> Either String Type
forall a b. b -> Either a b
Right Type
boolType
                  Nothing -> String -> Either String Type
forall a b. a -> Either a b
Left (String -> Either String Type) -> String -> Either String Type
forall a b. (a -> b) -> a -> b
$ Doc -> String
render (Doc -> String) -> Doc -> String
forall a b. (a -> b) -> a -> b
$
                             String -> Doc
text "incompatible arithmetic types in comparison: "
                             Doc -> Doc -> Doc
<+> Type -> Doc
forall p. Pretty p => p -> Doc
pretty Type
t1 Doc -> Doc -> Doc
<+> String -> Doc
text "and" Doc -> Doc -> Doc
<+> Type -> Doc
forall p. Pretty p => p -> Doc
pretty Type
t2
          (PtrType (DirectType TyVoid _ _) _ _, _)
            | Type -> Bool
isPointerType Type
t2' -> Type -> Either String Type
forall a b. b -> Either a b
Right Type
boolType
          (_, PtrType (DirectType TyVoid _ _) _ _)
            | Type -> Bool
isPointerType Type
t1' -> Type -> Either String Type
forall a b. b -> Either a b
Right Type
boolType
          (_, _)
            | Type -> Bool
isPointerType Type
t1' Bool -> Bool -> Bool
&& Type -> Bool
isIntegralType Type
t2' -> Type -> Either String Type
forall a b. b -> Either a b
Right Type
boolType
            | Type -> Bool
isIntegralType Type
t1' Bool -> Bool -> Bool
&& Type -> Bool
isPointerType Type
t2' -> Type -> Either String Type
forall a b. b -> Either a b
Right Type
boolType
            | Type -> Bool
isPointerType Type
t1' Bool -> Bool -> Bool
&& Type -> Bool
isPointerType Type
t2' ->
              Type -> Type -> Either String ()
compatible Type
t1' Type
t2' Either String () -> Either String Type -> Either String Type
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Type -> Either String Type
forall a b. b -> Either a b
Right Type
boolType
          (_, _) -> String -> Either String Type
forall a b. a -> Either a b
Left "incompatible types in comparison"
    (CSubOp, ArrayType t1' :: Type
t1' _ _ _, ArrayType t2' :: Type
t2' _ _ _) ->
      Type -> Type -> Either String ()
compatible Type
t1' Type
t2' Either String () -> Either String Type -> Either String Type
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Type -> Either String Type
forall a b. b -> Either a b
Right Type
ptrDiffType
    (CSubOp, ArrayType t1' :: Type
t1' _ _ _, PtrType t2' :: Type
t2' _ _) ->
      Type -> Type -> Either String ()
compatible Type
t1' Type
t2' Either String () -> Either String Type -> Either String Type
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Type -> Either String Type
forall a b. b -> Either a b
Right Type
ptrDiffType
    (CSubOp, PtrType t1' :: Type
t1' _ _, ArrayType t2' :: Type
t2' _ _ _) ->
      Type -> Type -> Either String ()
compatible Type
t1' Type
t2' Either String () -> Either String Type -> Either String Type
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Type -> Either String Type
forall a b. b -> Either a b
Right Type
ptrDiffType
    (CSubOp, PtrType t1' :: Type
t1' _ _, PtrType t2' :: Type
t2' _ _) ->
      Type -> Type -> Either String ()
compatible Type
t1' Type
t2' Either String () -> Either String Type -> Either String Type
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Type -> Either String Type
forall a b. b -> Either a b
Right Type
ptrDiffType
    (_, PtrType _ _ _, t2' :: Type
t2')
      | CBinaryOp -> Bool
isPtrOp CBinaryOp
op Bool -> Bool -> Bool
&& Type -> Bool
isIntegralType Type
t2' -> Type -> Either String Type
forall a b. b -> Either a b
Right Type
t1
      | Bool
otherwise -> String -> Either String Type
forall a b. a -> Either a b
Left (String -> Either String Type) -> String -> Either String Type
forall a b. (a -> b) -> a -> b
$ "invalid pointer operation: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Doc -> String
render (CBinaryOp -> Doc
forall p. Pretty p => p -> Doc
pretty CBinaryOp
op)
    (CAddOp, t1' :: Type
t1', PtrType _ _ _) | Type -> Bool
isIntegralType Type
t1' -> Type -> Either String Type
forall a b. b -> Either a b
Right Type
t2
    (_, ArrayType _ _ _ _, t2' :: Type
t2')
      | CBinaryOp -> Bool
isPtrOp CBinaryOp
op Bool -> Bool -> Bool
&& Type -> Bool
isIntegralType Type
t2' -> Type -> Either String Type
forall a b. b -> Either a b
Right Type
t1
      | Bool
otherwise -> String -> Either String Type
forall a b. a -> Either a b
Left (String -> Either String Type) -> String -> Either String Type
forall a b. (a -> b) -> a -> b
$ "invalid pointer operation: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Doc -> String
render (CBinaryOp -> Doc
forall p. Pretty p => p -> Doc
pretty CBinaryOp
op)
    (CAddOp, t1' :: Type
t1', ArrayType _ _ _ _) | Type -> Bool
isIntegralType Type
t1' -> Type -> Either String Type
forall a b. b -> Either a b
Right Type
t2
    (_, DirectType tn1 :: TypeName
tn1 q1 :: TypeQuals
q1 a1 :: Attributes
a1, DirectType tn2 :: TypeName
tn2 q2 :: TypeQuals
q2 a2 :: Attributes
a2) ->
        do Bool -> Either String () -> Either String ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (CBinaryOp -> Bool
isBitOp CBinaryOp
op) (Type -> Either String ()
checkIntegral Type
t1 Either String () -> Either String () -> Either String ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Type -> Either String ()
checkIntegral Type
t2)
           case TypeName -> TypeName -> Maybe TypeName
arithmeticConversion TypeName
tn1 TypeName
tn2 of
             Just tn :: TypeName
tn -> Type -> Either String Type
forall a b. b -> Either a b
Right (Type -> Either String Type) -> Type -> Either String Type
forall a b. (a -> b) -> a -> b
$ TypeName -> TypeQuals -> Attributes -> Type
DirectType TypeName
tn (TypeQuals -> TypeQuals -> TypeQuals
mergeTypeQuals TypeQuals
q1 TypeQuals
q2) (Attributes -> Attributes -> Attributes
mergeAttributes Attributes
a1 Attributes
a2)
             Nothing -> String -> Either String Type
forall a b. a -> Either a b
Left (String -> Either String Type) -> String -> Either String Type
forall a b. (a -> b) -> a -> b
$ Doc -> String
render (Doc -> String) -> Doc -> String
forall a b. (a -> b) -> a -> b
$
                        String -> Doc
text "invalid binary operation:" Doc -> Doc -> Doc
<+> Type -> Doc
forall p. Pretty p => p -> Doc
pretty Type
t1 Doc -> Doc -> Doc
<+> CBinaryOp -> Doc
forall p. Pretty p => p -> Doc
pretty CBinaryOp
op Doc -> Doc -> Doc
<+> Type -> Doc
forall p. Pretty p => p -> Doc
pretty Type
t2
    (_, _, _) -> String -> Either String Type
forall a b. a -> Either a b
Left (String -> Either String Type) -> String -> Either String Type
forall a b. (a -> b) -> a -> b
$ Doc -> String
render (Doc -> String) -> Doc -> String
forall a b. (a -> b) -> a -> b
$
                 String -> Doc
text "unhandled binary operation:" Doc -> Doc -> Doc
<+> Type -> Doc
forall p. Pretty p => p -> Doc
pretty Type
t1 Doc -> Doc -> Doc
<+> CBinaryOp -> Doc
forall p. Pretty p => p -> Doc
pretty CBinaryOp
op Doc -> Doc -> Doc
<+> Type -> Doc
forall p. Pretty p => p -> Doc
pretty Type
t2

-- | Determine the type of a conditional expression.
conditionalType :: Type -> Type -> Either String Type
conditionalType :: Type -> Type -> Either String Type
conditionalType t1 :: Type
t1 t2 :: Type
t2 =
  case (Type -> Type
canonicalType Type
t1, Type -> Type
canonicalType Type
t2) of
    (PtrType (DirectType TyVoid _ _) _ _, t2' :: Type
t2') | Type -> Bool
isPointerType Type
t2' -> Type -> Either String Type
forall a b. b -> Either a b
Right Type
t2
    (t1' :: Type
t1', PtrType (DirectType TyVoid _ _) _ _) | Type -> Bool
isPointerType Type
t1' -> Type -> Either String Type
forall a b. b -> Either a b
Right Type
t1
    (ArrayType t1' :: Type
t1' _ q1 :: TypeQuals
q1 a1 :: Attributes
a1, ArrayType t2' :: Type
t2' _ q2 :: TypeQuals
q2 a2 :: Attributes
a2) ->
      do Type
t <- Type -> Type -> Either String Type
compositeType Type
t1' Type
t2'
         Type -> Either String Type
forall a b. b -> Either a b
Right (Type -> Either String Type) -> Type -> Either String Type
forall a b. (a -> b) -> a -> b
$ Type -> ArraySize -> TypeQuals -> Attributes -> Type
ArrayType Type
t (Bool -> ArraySize
UnknownArraySize Bool
False)
                  (TypeQuals -> TypeQuals -> TypeQuals
mergeTypeQuals TypeQuals
q1 TypeQuals
q2) (Attributes -> Attributes -> Attributes
mergeAttrs Attributes
a1 Attributes
a2)
    (t1' :: Type
t1'@(DirectType tn1 :: TypeName
tn1 q1 :: TypeQuals
q1 a1 :: Attributes
a1), t2' :: Type
t2'@(DirectType tn2 :: TypeName
tn2 q2 :: TypeQuals
q2 a2 :: Attributes
a2)) ->
      case TypeName -> TypeName -> Maybe TypeName
arithmeticConversion TypeName
tn1 TypeName
tn2 of
        Just tn :: TypeName
tn -> Type -> Either String Type
forall a b. b -> Either a b
Right (Type -> Either String Type) -> Type -> Either String Type
forall a b. (a -> b) -> a -> b
$ TypeName -> TypeQuals -> Attributes -> Type
DirectType TypeName
tn (TypeQuals -> TypeQuals -> TypeQuals
mergeTypeQuals TypeQuals
q1 TypeQuals
q2) (Attributes -> Attributes -> Attributes
mergeAttributes Attributes
a1 Attributes
a2)
        Nothing -> Type -> Type -> Either String Type
compositeType Type
t1' Type
t2'
    (t1' :: Type
t1', t2' :: Type
t2') -> Type -> Type -> Either String Type
compositeType Type
t1' Type
t2'

derefType :: Type -> Either String Type
derefType :: Type -> Either String Type
derefType (PtrType t :: Type
t _ _) = Type -> Either String Type
forall a b. b -> Either a b
Right Type
t
derefType (ArrayType t :: Type
t _ _ _) = Type -> Either String Type
forall a b. b -> Either a b
Right Type
t
derefType t :: Type
t =
  -- XXX: is it good to use canonicalType here?
  case Type -> Type
canonicalType Type
t of
    PtrType t' :: Type
t' _ _ -> Type -> Either String Type
forall a b. b -> Either a b
Right Type
t'
    ArrayType t' :: Type
t' _ _ _ -> Type -> Either String Type
forall a b. b -> Either a b
Right Type
t'
    _ -> String -> Either String Type
forall a b. a -> Either a b
Left (String -> Either String Type) -> String -> Either String Type
forall a b. (a -> b) -> a -> b
$ "dereferencing non-pointer: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Type -> String
pType Type
t

varAddrType :: IdentDecl -> Either String Type
varAddrType :: IdentDecl -> Either String Type
varAddrType d :: IdentDecl
d =
  do case IdentDecl -> Storage
forall d. Declaration d => d -> Storage
declStorage IdentDecl
d of
       Auto True -> String -> Either String ()
forall a b. a -> Either a b
Left "address of register variable"
       _         -> () -> Either String ()
forall a b. b -> Either a b
Right ()
     case Type
t of
       ArrayType _ _ q :: TypeQuals
q a :: Attributes
a -> Type -> Either String Type
forall a b. b -> Either a b
Right (Type -> Either String Type) -> Type -> Either String Type
forall a b. (a -> b) -> a -> b
$ Type -> TypeQuals -> Attributes -> Type
PtrType Type
t TypeQuals
q Attributes
a
       _                 -> Type -> Either String Type
forall a b. b -> Either a b
Right (Type -> Either String Type) -> Type -> Either String Type
forall a b. (a -> b) -> a -> b
$ Type -> Type
simplePtr Type
t
  where t :: Type
t = IdentDecl -> Type
forall n. Declaration n => n -> Type
declType IdentDecl
d

-- | Get the type of field @m@ of type @t@
fieldType :: (MonadCError m, MonadSymtab m) => NodeInfo -> Ident -> Type -> m Type
fieldType :: NodeInfo -> Ident -> Type -> m Type
fieldType ni :: NodeInfo
ni m :: Ident
m t :: Type
t =
  case Type -> Type
canonicalType Type
t of
    DirectType (TyComp ctr :: CompTypeRef
ctr) _ _ ->
      do TagDef
td <- NodeInfo -> SUERef -> m TagDef
forall (m :: * -> *).
(MonadCError m, MonadSymtab m) =>
NodeInfo -> SUERef -> m TagDef
lookupSUE NodeInfo
ni (CompTypeRef -> SUERef
forall a. HasSUERef a => a -> SUERef
sueRef CompTypeRef
ctr)
         [(Ident, Type)]
ms <- NodeInfo -> TagDef -> m [(Ident, Type)]
forall (m :: * -> *).
(MonadCError m, MonadSymtab m) =>
NodeInfo -> TagDef -> m [(Ident, Type)]
tagMembers NodeInfo
ni TagDef
td
         case Ident -> [(Ident, Type)] -> Maybe Type
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Ident
m [(Ident, Type)]
ms of
           Just ft :: Type
ft -> Type -> m Type
forall (m :: * -> *) a. Monad m => a -> m a
return Type
ft
           Nothing -> NodeInfo -> String -> m Type
forall (m :: * -> *) a. MonadCError m => NodeInfo -> String -> m a
typeError NodeInfo
ni (String -> m Type) -> String -> m Type
forall a b. (a -> b) -> a -> b
$ "field not found: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Ident -> String
identToString Ident
m
    _t' :: Type
_t' -> NodeInfo -> String -> m Type
forall (m :: * -> *) a. MonadCError m => NodeInfo -> String -> m a
astError NodeInfo
ni (String -> m Type) -> String -> m Type
forall a b. (a -> b) -> a -> b
$
          "field of non-composite type: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Ident -> String
identToString Ident
m
          String -> String -> String
forall a. [a] -> [a] -> [a]
++ ", " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Type -> String
pType Type
t

-- | Get all members of a struct, union, or enum, with their
--   types. Collapse fields of anonymous members.
tagMembers :: (MonadCError m, MonadSymtab m) =>
              NodeInfo -> TagDef -> m [(Ident, Type)]
tagMembers :: NodeInfo -> TagDef -> m [(Ident, Type)]
tagMembers ni :: NodeInfo
ni td :: TagDef
td =
  case TagDef
td of
    CompDef (CompType _ _ ms :: [MemberDecl]
ms _ _) -> [MemberDecl] -> m [(Ident, Type)]
forall (m :: * -> *) n.
(MonadCError m, MonadSymtab m, Declaration n) =>
[n] -> m [(Ident, Type)]
getMembers [MemberDecl]
ms
    EnumDef (EnumType _ es :: [Enumerator]
es _ _) -> [Enumerator] -> m [(Ident, Type)]
forall (m :: * -> *) n.
(MonadCError m, MonadSymtab m, Declaration n) =>
[n] -> m [(Ident, Type)]
getMembers [Enumerator]
es
  where getMembers :: [n] -> m [(Ident, Type)]
getMembers ds :: [n]
ds =
          do let ts :: [Type]
ts = (n -> Type) -> [n] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map n -> Type
forall n. Declaration n => n -> Type
declType [n]
ds
                 ns :: [VarName]
ns = (n -> VarName) -> [n] -> [VarName]
forall a b. (a -> b) -> [a] -> [b]
map n -> VarName
forall n. Declaration n => n -> VarName
declName [n]
ds
             [[(Ident, Type)]] -> [(Ident, Type)]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[(Ident, Type)]] -> [(Ident, Type)])
-> m [[(Ident, Type)]] -> m [(Ident, Type)]
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
`liftM` ((VarName, Type) -> m [(Ident, Type)])
-> [(VarName, Type)] -> m [[(Ident, Type)]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (NodeInfo -> (VarName, Type) -> m [(Ident, Type)]
forall (m :: * -> *).
(MonadCError m, MonadSymtab m) =>
NodeInfo -> (VarName, Type) -> m [(Ident, Type)]
expandAnonymous NodeInfo
ni) ([VarName] -> [Type] -> [(VarName, Type)]
forall a b. [a] -> [b] -> [(a, b)]
zip [VarName]
ns [Type]
ts)

-- | Expand an anonymous composite type into a list of member names
--   and their associated types.
expandAnonymous :: (MonadCError m, MonadSymtab m) =>
                   NodeInfo -> (VarName, Type)
                -> m [(Ident, Type)]
expandAnonymous :: NodeInfo -> (VarName, Type) -> m [(Ident, Type)]
expandAnonymous ni :: NodeInfo
ni (NoName, DirectType (TyComp ctr :: CompTypeRef
ctr) _ _) =
  NodeInfo -> SUERef -> m TagDef
forall (m :: * -> *).
(MonadCError m, MonadSymtab m) =>
NodeInfo -> SUERef -> m TagDef
lookupSUE NodeInfo
ni (CompTypeRef -> SUERef
forall a. HasSUERef a => a -> SUERef
sueRef CompTypeRef
ctr) m TagDef -> (TagDef -> m [(Ident, Type)]) -> m [(Ident, Type)]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= NodeInfo -> TagDef -> m [(Ident, Type)]
forall (m :: * -> *).
(MonadCError m, MonadSymtab m) =>
NodeInfo -> TagDef -> m [(Ident, Type)]
tagMembers NodeInfo
ni
expandAnonymous _ (NoName, _) = [(Ident, Type)] -> m [(Ident, Type)]
forall (m :: * -> *) a. Monad m => a -> m a
return []
expandAnonymous _ (VarName n :: Ident
n _, t :: Type
t) = [(Ident, Type)] -> m [(Ident, Type)]
forall (m :: * -> *) a. Monad m => a -> m a
return [(Ident
n, Type
t)]

lookupSUE :: (MonadCError m, MonadSymtab m) =>
             NodeInfo -> SUERef -> m TagDef
lookupSUE :: NodeInfo -> SUERef -> m TagDef
lookupSUE ni :: NodeInfo
ni sue :: SUERef
sue =
  do DefTable
dt <- m DefTable
forall (m :: * -> *). MonadSymtab m => m DefTable
getDefTable
     case SUERef -> DefTable -> Maybe TagEntry
lookupTag SUERef
sue DefTable
dt of
       Just (Right td :: TagDef
td) -> TagDef -> m TagDef
forall (m :: * -> *) a. Monad m => a -> m a
return TagDef
td
       _               ->
         NodeInfo -> String -> m TagDef
forall (m :: * -> *) a. MonadCError m => NodeInfo -> String -> m a
typeError NodeInfo
ni (String -> m TagDef) -> String -> m TagDef
forall a b. (a -> b) -> a -> b
$ "unknown composite type: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ (Doc -> String
render (Doc -> String) -> (SUERef -> Doc) -> SUERef -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SUERef -> Doc
forall p. Pretty p => p -> Doc
pretty) SUERef
sue

deepTypeAttrs :: (MonadCError m, MonadSymtab m) =>
                 Type -> m Attributes
deepTypeAttrs :: Type -> m Attributes
deepTypeAttrs (DirectType (TyComp (CompTypeRef sue :: SUERef
sue _ ni :: NodeInfo
ni)) _ attrs :: Attributes
attrs) =
  (Attributes
attrs Attributes -> Attributes -> Attributes
forall a. [a] -> [a] -> [a]
++) (Attributes -> Attributes) -> m Attributes -> m Attributes
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
`liftM` NodeInfo -> SUERef -> m Attributes
forall (m :: * -> *).
(MonadCError m, MonadSymtab m) =>
NodeInfo -> SUERef -> m Attributes
sueAttrs NodeInfo
ni SUERef
sue
deepTypeAttrs (DirectType (TyEnum (EnumTypeRef sue :: SUERef
sue ni :: NodeInfo
ni)) _ attrs :: Attributes
attrs) =
  (Attributes
attrs Attributes -> Attributes -> Attributes
forall a. [a] -> [a] -> [a]
++) (Attributes -> Attributes) -> m Attributes -> m Attributes
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
`liftM` NodeInfo -> SUERef -> m Attributes
forall (m :: * -> *).
(MonadCError m, MonadSymtab m) =>
NodeInfo -> SUERef -> m Attributes
sueAttrs NodeInfo
ni SUERef
sue
deepTypeAttrs (DirectType _ _ attrs :: Attributes
attrs) = Attributes -> m Attributes
forall (m :: * -> *) a. Monad m => a -> m a
return Attributes
attrs
deepTypeAttrs (PtrType t :: Type
t _ attrs :: Attributes
attrs) = (Attributes
attrs Attributes -> Attributes -> Attributes
forall a. [a] -> [a] -> [a]
++) (Attributes -> Attributes) -> m Attributes -> m Attributes
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
`liftM` Type -> m Attributes
forall (m :: * -> *).
(MonadCError m, MonadSymtab m) =>
Type -> m Attributes
deepTypeAttrs Type
t
deepTypeAttrs (ArrayType t :: Type
t _ _ attrs :: Attributes
attrs) = (Attributes
attrs Attributes -> Attributes -> Attributes
forall a. [a] -> [a] -> [a]
++) (Attributes -> Attributes) -> m Attributes -> m Attributes
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
`liftM` Type -> m Attributes
forall (m :: * -> *).
(MonadCError m, MonadSymtab m) =>
Type -> m Attributes
deepTypeAttrs Type
t
deepTypeAttrs (FunctionType (FunType t :: Type
t _ _) attrs :: Attributes
attrs) =
  (Attributes
attrs Attributes -> Attributes -> Attributes
forall a. [a] -> [a] -> [a]
++) (Attributes -> Attributes) -> m Attributes -> m Attributes
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
`liftM` Type -> m Attributes
forall (m :: * -> *).
(MonadCError m, MonadSymtab m) =>
Type -> m Attributes
deepTypeAttrs Type
t
deepTypeAttrs (FunctionType (FunTypeIncomplete t :: Type
t)  attrs :: Attributes
attrs) =
  (Attributes
attrs Attributes -> Attributes -> Attributes
forall a. [a] -> [a] -> [a]
++) (Attributes -> Attributes) -> m Attributes -> m Attributes
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
`liftM` Type -> m Attributes
forall (m :: * -> *).
(MonadCError m, MonadSymtab m) =>
Type -> m Attributes
deepTypeAttrs Type
t
deepTypeAttrs (TypeDefType (TypeDefRef i :: Ident
i _ ni :: NodeInfo
ni) _ attrs :: Attributes
attrs) =
  (Attributes
attrs Attributes -> Attributes -> Attributes
forall a. [a] -> [a] -> [a]
++) (Attributes -> Attributes) -> m Attributes -> m Attributes
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
`liftM` NodeInfo -> Ident -> m Attributes
forall (m :: * -> *).
(MonadCError m, MonadSymtab m) =>
NodeInfo -> Ident -> m Attributes
typeDefAttrs NodeInfo
ni Ident
i

typeDefAttrs :: (MonadCError m, MonadSymtab m) =>
                NodeInfo -> Ident -> m Attributes
typeDefAttrs :: NodeInfo -> Ident -> m Attributes
typeDefAttrs ni :: NodeInfo
ni i :: Ident
i =
  do DefTable
dt <- m DefTable
forall (m :: * -> *). MonadSymtab m => m DefTable
getDefTable
     case Ident -> DefTable -> Maybe IdentEntry
lookupIdent Ident
i DefTable
dt of
       Nothing -> NodeInfo -> String -> m Attributes
forall (m :: * -> *) a. MonadCError m => NodeInfo -> String -> m a
astError NodeInfo
ni (String -> m Attributes) -> String -> m Attributes
forall a b. (a -> b) -> a -> b
$ "can't find typedef name: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Ident -> String
identToString Ident
i
       Just (Left (TypeDef _ t :: Type
t attrs :: Attributes
attrs _)) -> (Attributes
attrs Attributes -> Attributes -> Attributes
forall a. [a] -> [a] -> [a]
++) (Attributes -> Attributes) -> m Attributes -> m Attributes
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
`liftM` Type -> m Attributes
forall (m :: * -> *).
(MonadCError m, MonadSymtab m) =>
Type -> m Attributes
deepTypeAttrs Type
t
       Just (Right _) -> NodeInfo -> String -> m Attributes
forall (m :: * -> *) a. MonadCError m => NodeInfo -> String -> m a
astError NodeInfo
ni (String -> m Attributes) -> String -> m Attributes
forall a b. (a -> b) -> a -> b
$ "not a typedef name: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Ident -> String
identToString Ident
i

sueAttrs :: (MonadCError m, MonadSymtab m) =>
            NodeInfo -> SUERef -> m Attributes
sueAttrs :: NodeInfo -> SUERef -> m Attributes
sueAttrs ni :: NodeInfo
ni sue :: SUERef
sue =
  do DefTable
dt <- m DefTable
forall (m :: * -> *). MonadSymtab m => m DefTable
getDefTable
     case SUERef -> DefTable -> Maybe TagEntry
lookupTag SUERef
sue DefTable
dt of
       Nothing -> NodeInfo -> String -> m Attributes
forall (m :: * -> *) a. MonadCError m => NodeInfo -> String -> m a
astError NodeInfo
ni (String -> m Attributes) -> String -> m Attributes
forall a b. (a -> b) -> a -> b
$ "SUE not found: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Doc -> String
render (SUERef -> Doc
forall p. Pretty p => p -> Doc
pretty SUERef
sue)
       Just (Left _) -> Attributes -> m Attributes
forall (m :: * -> *) a. Monad m => a -> m a
return []
       Just (Right (CompDef (CompType _ _ _ attrs :: Attributes
attrs _))) -> Attributes -> m Attributes
forall (m :: * -> *) a. Monad m => a -> m a
return Attributes
attrs
       Just (Right (EnumDef (EnumType _ _ attrs :: Attributes
attrs _))) -> Attributes -> m Attributes
forall (m :: * -> *) a. Monad m => a -> m a
return Attributes
attrs