{-# 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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall p. Pretty p => p -> Doc
pretty

typeErrorOnLeft :: (MonadCError m) => NodeInfo -> Either String a -> m a
typeErrorOnLeft :: forall (m :: * -> *) a.
MonadCError m =>
NodeInfo -> Either String a -> m a
typeErrorOnLeft NodeInfo
ni (Left String
err) = forall (m :: * -> *) a. MonadCError m => NodeInfo -> String -> m a
typeError NodeInfo
ni String
err
typeErrorOnLeft NodeInfo
_  (Right a
v)  = 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 :: forall (m :: * -> *) a. MonadCError m => NodeInfo -> String -> m a
typeError = forall (m :: * -> *) a. MonadCError m => NodeInfo -> String -> m a
astError

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

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

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

assignCompatible' :: MonadCError m =>
                     NodeInfo -> CAssignOp -> Type -> Type -> m ()
assignCompatible' :: forall (m :: * -> *).
MonadCError m =>
NodeInfo -> CAssignOp -> Type -> Type -> m ()
assignCompatible' NodeInfo
ni CAssignOp
op Type
t1 Type
t2 = 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' :: forall (m :: * -> *).
MonadCError m =>
NodeInfo -> CBinaryOp -> Type -> Type -> m Type
binopType' NodeInfo
ni CBinaryOp
op Type
t1 Type
t2 = 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' :: forall (m :: * -> *).
MonadCError m =>
NodeInfo -> Type -> Type -> m Type
conditionalType' NodeInfo
ni Type
t1 Type
t2 = forall (m :: * -> *) a.
MonadCError m =>
NodeInfo -> Either String a -> m a
typeErrorOnLeft NodeInfo
ni 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 Type
t =
  case Type -> Type
canonicalType Type
t of
    DirectType TypeName
_ TypeQuals
_ Attributes
_  -> forall a b. b -> Either a b
Right ()
    PtrType Type
_ TypeQuals
_ Attributes
_     -> forall a b. b -> Either a b
Right ()
    ArrayType Type
_ ArraySize
_ TypeQuals
_ Attributes
_ -> forall a b. b -> Either a b
Right () -- because it's just a pointer
    Type
t' -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$
          String
"expected scalar type, got: "
          forall a. [a] -> [a] -> [a]
++ Type -> String
pType Type
t forall a. [a] -> [a] -> [a]
++ String
" (" forall a. [a] -> [a] -> [a]
++ Type -> String
pType Type
t' forall a. [a] -> [a] -> [a]
++ String
")"

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

-- | Determine the type of a constant.
constType :: (MonadCError m, MonadName m) => CConst -> m Type
constType :: forall (m :: * -> *).
(MonadCError m, MonadName m) =>
CConst -> m Type
constType (CIntConst (CInteger Integer
_ CIntRepr
_ Flags CIntFlag
flags) NodeInfo
_) =
  forall (m :: * -> *) a. Monad m => a -> m a
return 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 Char
_ Bool
True) NodeInfo
_) =
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ TypeName -> TypeQuals -> Attributes -> Type
DirectType (IntType -> TypeName
TyIntegral IntType
TyInt) TypeQuals
noTypeQuals Attributes
noAttributes
constType (CCharConst (CChar Char
_ Bool
False) NodeInfo
_) =
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ TypeName -> TypeQuals -> Attributes -> Type
DirectType (IntType -> TypeName
TyIntegral IntType
TyChar) TypeQuals
noTypeQuals Attributes
noAttributes
constType (CCharConst (CChars String
_ Bool
_) NodeInfo
_)  =
  forall (m :: * -> *) a. Monad m => a -> m a
return 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 String
fs) NodeInfo
_) =
  forall (m :: * -> *) a. Monad m => a -> m a
return 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 String
chars Bool
wide) NodeInfo
ni) =
  do Name
n <- 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 (forall a. Pos a => a -> Position
posOf NodeInfo
ni) Name
n
         arraySize :: ArraySize
arraySize = Bool -> CExpr -> ArraySize
ArraySize
                     Bool
True -- XXX: is it static?
                     (forall a. CConstant a -> CExpression a
CConst
                      (forall a. CInteger -> a -> CConstant a
CIntConst
                       (Integer -> CInteger
cInteger (forall a. Integral a => a -> Integer
toInteger (forall (t :: * -> *) a. Foldable t => t a -> Int
length String
chars))) NodeInfo
ni'))
     forall (m :: * -> *) a. Monad m => a -> m a
return 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 Type
t1 Type
t2 = forall (f :: * -> *) a. Functor f => f a -> f ()
voidforall 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 Type
t1 (DirectType (TyBuiltin BuiltinType
TyAny) TypeQuals
_ Attributes
_) = forall a b. b -> Either a b
Right Type
t1
compositeType (DirectType (TyBuiltin BuiltinType
TyAny) TypeQuals
_ Attributes
_) Type
t2 = forall a b. b -> Either a b
Right Type
t2
compositeType t1 :: Type
t1@(DirectType TypeName
tn1 TypeQuals
q1 Attributes
a1) t2 :: Type
t2@(DirectType TypeName
tn2 TypeQuals
q2 Attributes
a2) =
  do TypeName
tn <- case (TypeName
tn1, TypeName
tn2) of
             (TypeName
TyVoid, TypeName
TyVoid) -> forall a b. b -> Either a b
Right TypeName
TyVoid
             (TyIntegral IntType
_, TyEnum EnumTypeRef
_) -> forall a b. b -> Either a b
Right TypeName
tn1
             (TyEnum EnumTypeRef
_, TyIntegral IntType
_) -> forall a b. b -> Either a b
Right TypeName
tn2
             (TyIntegral IntType
i1, TyIntegral IntType
i2) ->
               forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ IntType -> TypeName
TyIntegral (IntType -> IntType -> IntType
intConversion IntType
i1 IntType
i2)
             (TyFloating FloatType
f1, TyFloating FloatType
f2) ->
               forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ FloatType -> TypeName
TyFloating (FloatType -> FloatType -> FloatType
floatConversion FloatType
f1 FloatType
f2)
             (TyComplex FloatType
f1, TyComplex FloatType
f2) ->
               forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ FloatType -> TypeName
TyComplex (FloatType -> FloatType -> FloatType
floatConversion FloatType
f1 FloatType
f2)
             (TyComp CompTypeRef
c1, TyComp CompTypeRef
c2) ->
               do forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall a. HasSUERef a => a -> SUERef
sueRef CompTypeRef
c1 forall a. Eq a => a -> a -> Bool
/= forall a. HasSUERef a => a -> SUERef
sueRef CompTypeRef
c2) forall a b. (a -> b) -> a -> b
$
                       forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ String
"incompatible composite types: "
                              forall a. [a] -> [a] -> [a]
++ Type -> String
pType Type
t1 forall a. [a] -> [a] -> [a]
++ String
", " forall a. [a] -> [a] -> [a]
++ Type -> String
pType Type
t2
                  forall a b. b -> Either a b
Right TypeName
tn1
             (TyEnum EnumTypeRef
e1, TyEnum EnumTypeRef
e2) ->
               do forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall a. HasSUERef a => a -> SUERef
sueRef EnumTypeRef
e1 forall a. Eq a => a -> a -> Bool
/= forall a. HasSUERef a => a -> SUERef
sueRef EnumTypeRef
e2) forall a b. (a -> b) -> a -> b
$
                       forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ String
"incompatible enumeration types: "
                              forall a. [a] -> [a] -> [a]
++ Type -> String
pType Type
t1 forall a. [a] -> [a] -> [a]
++ String
", " forall a. [a] -> [a] -> [a]
++ Type -> String
pType Type
t2
                  forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ EnumTypeRef -> TypeName
TyEnum EnumTypeRef
e1
             (TyBuiltin BuiltinType
TyVaList, TyBuiltin BuiltinType
TyVaList) ->
               forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ BuiltinType -> TypeName
TyBuiltin BuiltinType
TyVaList
             (TyBuiltin BuiltinType
_, TyBuiltin BuiltinType
_) ->
               forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ String
"incompatible builtin types: "
                      forall a. [a] -> [a] -> [a]
++ Type -> String
pType Type
t1 forall a. [a] -> [a] -> [a]
++ String
", " forall a. [a] -> [a] -> [a]
++ Type -> String
pType Type
t2
             (TypeName
_, TypeName
_) -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ String
"incompatible direct types: "
                       forall a. [a] -> [a] -> [a]
++ Type -> String
pType Type
t1 forall a. [a] -> [a] -> [a]
++ String
", " forall a. [a] -> [a] -> [a]
++ Type -> String
pType Type
t2
     forall a b. b -> Either a b
Right 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 Type
t1 TypeQuals
q1 Attributes
a1) (PtrType (DirectType TypeName
TyVoid TypeQuals
_ Attributes
_) TypeQuals
q2 Attributes
_) =
  forall a b. b -> Either a b
Right 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 TypeName
TyVoid TypeQuals
_ Attributes
_) TypeQuals
q1 Attributes
_) (PtrType Type
t2 TypeQuals
q2 Attributes
a2) =
  forall a b. b -> Either a b
Right 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 Type
t1 TypeQuals
q1 Attributes
a1) Type
t2 | Type -> Bool
isIntegralType Type
t2 =
  forall a b. b -> Either a b
Right 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 Type
t1 (PtrType Type
t2 TypeQuals
q2 Attributes
a2) | Type -> Bool
isIntegralType Type
t1 =
  forall a b. b -> Either a b
Right 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 Type
t1 ArraySize
_sz1 TypeQuals
q1 Attributes
a1) Type
t2 | Type -> Bool
isIntegralType Type
t2 =
  forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ Type -> TypeQuals -> Attributes -> Type
PtrType Type
t1 TypeQuals
q1 Attributes
a1
compositeType Type
t1 (ArrayType Type
t2 ArraySize
_sz2 TypeQuals
q2 Attributes
a2) | Type -> Bool
isIntegralType Type
t1 =
  forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ Type -> TypeQuals -> Attributes -> Type
PtrType Type
t2 TypeQuals
q2 Attributes
a2
compositeType (ArrayType Type
t1 ArraySize
s1 TypeQuals
q1 Attributes
a1) (ArrayType Type
t2 ArraySize
s2 TypeQuals
q2 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
     forall a b. b -> Either a b
Right (Type -> ArraySize -> TypeQuals -> Attributes -> Type
ArrayType Type
t ArraySize
s TypeQuals
quals Attributes
attrs)
compositeType Type
t1 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)
     forall a b. b -> Either a b
Right (Type -> TypeQuals -> Attributes -> Type
PtrType Type
t TypeQuals
quals Attributes
attrs)
compositeType (TypeDefType TypeDefRef
tdr1 TypeQuals
_q1 Attributes
_a1) (TypeDefType TypeDefRef
tdr2 TypeQuals
_q2 Attributes
_a2) =
  case (TypeDefRef
tdr1, TypeDefRef
tdr2) of
    (TypeDefRef Ident
_ Type
t1 NodeInfo
_, TypeDefRef Ident
_ Type
t2 NodeInfo
_) ->
      Type -> Type -> Either String Type
compositeType Type
t1 Type
t2
compositeType (FunctionType FunType
ft1 Attributes
attrs1) (FunctionType FunType
ft2 Attributes
attrs2) =
  case (FunType
ft1, FunType
ft2) of
    (FunType Type
rt1 [ParamDecl]
args1 Bool
varargs1, FunType Type
rt2 [ParamDecl]
args2 Bool
varargs2) ->
      do {- when (length args1 /= length args2) $
              Left "different numbers of arguments in function types" -}
         [ParamDecl]
args <- 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
         forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool
varargs1 forall a. Eq a => a -> a -> Bool
/= Bool
varargs2) forall a b. (a -> b) -> a -> b
$
              forall a b. a -> Either a b
Left String
"incompatible varargs declarations"
         Type -> Type -> [ParamDecl] -> Bool -> Either String Type
doFunType Type
rt1 Type
rt2 [ParamDecl]
args Bool
varargs1
    (FunType Type
rt1 [ParamDecl]
args1 Bool
varargs1, FunTypeIncomplete Type
rt2) ->
      Type -> Type -> [ParamDecl] -> Bool -> Either String Type
doFunType Type
rt1 Type
rt2 [ParamDecl]
args1 Bool
varargs1
    (FunTypeIncomplete Type
rt1, FunType Type
rt2 [ParamDecl]
args2 Bool
varargs2) ->
      Type -> Type -> [ParamDecl] -> Bool -> Either String Type
doFunType Type
rt1 Type
rt2 [ParamDecl]
args2 Bool
varargs2
    (FunTypeIncomplete Type
rt1, FunTypeIncomplete Type
rt2) ->
      do Type
rt <- Type -> Type -> Either String Type
compositeType Type
rt1 Type
rt2
         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 Type
rt1 Type
rt2 [ParamDecl]
args Bool
varargs =
          do Type
rt <- Type -> Type -> Either String Type
compositeType Type
rt1 Type
rt2
             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 Type
t1 Type
t2 = forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ String
"incompatible types: "
                         forall a. [a] -> [a] -> [a]
++ Type -> String
pType Type
t1 forall a. [a] -> [a] -> [a]
++ 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 Bool
_) ArraySize
s2 = forall a b. b -> Either a b
Right ArraySize
s2
compositeSize ArraySize
s1 (UnknownArraySize Bool
_) = forall a b. b -> Either a b
Right ArraySize
s1
compositeSize (ArraySize Bool
s1 CExpr
e1) (ArraySize Bool
s2 CExpr
e2)
  | Bool
s1 forall a. Eq a => a -> a -> Bool
== Bool
s2 Bool -> Bool -> Bool
&& CExpr -> CExpr -> Bool
sizeEqual CExpr
e1 CExpr
e2 = forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ Bool -> CExpr -> ArraySize
ArraySize Bool
s1 CExpr
e1
  | Bool
otherwise = forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ Bool -> CExpr -> ArraySize
ArraySize Bool
s1 CExpr
e1
{-
    fail $ "incompatible array sizes: "
           ++ (render . pretty) e1 ++ ", " ++ (render . pretty) e2
-}

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

mergeAttrs :: Attributes -> Attributes -> Attributes
mergeAttrs :: Attributes -> Attributes -> Attributes
mergeAttrs = 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 VarDecl
vd1 NodeInfo
ni1) (ParamDecl VarDecl
vd2 NodeInfo
_) =
  (VarDecl -> NodeInfo -> ParamDecl)
-> VarDecl -> VarDecl -> NodeInfo -> Either String ParamDecl
compositeParamDecl' VarDecl -> NodeInfo -> ParamDecl
ParamDecl VarDecl
vd1 VarDecl
vd2 NodeInfo
ni1
compositeParamDecl (AbstractParamDecl VarDecl
vd1 NodeInfo
_) (ParamDecl VarDecl
vd2 NodeInfo
ni2) =
  (VarDecl -> NodeInfo -> ParamDecl)
-> VarDecl -> VarDecl -> NodeInfo -> Either String ParamDecl
compositeParamDecl' VarDecl -> NodeInfo -> ParamDecl
ParamDecl VarDecl
vd1 VarDecl
vd2 NodeInfo
ni2
compositeParamDecl (ParamDecl VarDecl
vd1 NodeInfo
ni1) (AbstractParamDecl VarDecl
vd2 NodeInfo
_) =
  (VarDecl -> NodeInfo -> ParamDecl)
-> VarDecl -> VarDecl -> NodeInfo -> Either String ParamDecl
compositeParamDecl' VarDecl -> NodeInfo -> ParamDecl
ParamDecl VarDecl
vd1 VarDecl
vd2 NodeInfo
ni1
compositeParamDecl (AbstractParamDecl VarDecl
vd1 NodeInfo
ni1) (AbstractParamDecl VarDecl
vd2 NodeInfo
_) =
  (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' VarDecl -> NodeInfo -> ParamDecl
f (VarDecl VarName
n1 DeclAttrs
attrs1 Type
t1) (VarDecl VarName
n2 DeclAttrs
attrs2 Type
t2) 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')
     forall a b. b -> Either a b
Right 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 VarName
n1 DeclAttrs
attrs1 Type
t1) (VarDecl VarName
_ DeclAttrs
attrs2 Type
t2) =
  do Type
t <- Type -> Type -> Either String Type
compositeType Type
t1 Type
t2
     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 FunctionAttrs
inl Storage
stor Attributes
attrs1) (DeclAttrs FunctionAttrs
_ Storage
_ 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 Type
t1 Type
t2 =
  case (Type -> Type
canonicalType Type
t1, Type -> Type
canonicalType Type
t2) of
    (DirectType TypeName
TyVoid TypeQuals
_ Attributes
_, Type
_) -> forall a b. b -> Either a b
Right ()
    (Type
_, Type
_) -> Type -> Either String ()
checkScalar Type
t1 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
CAssignOp Type
t1 Type
t2 =
  case (Type -> Type
canonicalType Type
t1, Type -> Type
canonicalType Type
t2) of
    (DirectType (TyBuiltin BuiltinType
TyAny) TypeQuals
_ Attributes
_, Type
_) -> forall a b. b -> Either a b
Right ()
    (Type
_, DirectType (TyBuiltin BuiltinType
TyAny) TypeQuals
_ Attributes
_) -> forall a b. b -> Either a b
Right ()
    -- XXX: check qualifiers
    (PtrType (DirectType TypeName
TyVoid TypeQuals
_ Attributes
_) TypeQuals
_ Attributes
_, Type
t2') | Type -> Bool
isPointerType Type
t2' -> forall a b. b -> Either a b
Right ()
    -- XXX: check qualifiers
    (Type
t1', PtrType (DirectType TypeName
TyVoid TypeQuals
_ Attributes
_) TypeQuals
_ Attributes
_) | Type -> Bool
isPointerType Type
t1' -> forall a b. b -> Either a b
Right ()
    (PtrType Type
_ TypeQuals
_ Attributes
_, Type
t2') | Type -> Bool
isIntegralType Type
t2' -> forall a b. b -> Either a b
Right ()
    (Type
t1', 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 CompTypeRef
c1) TypeQuals
_ Attributes
_, DirectType (TyComp CompTypeRef
c2) TypeQuals
_ Attributes
_)
      | forall a. HasSUERef a => a -> SUERef
sueRef CompTypeRef
c1 forall a. Eq a => a -> a -> Bool
== forall a. HasSUERef a => a -> SUERef
sueRef CompTypeRef
c2 -> forall a b. b -> Either a b
Right ()
      | Bool
otherwise -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$
                     String
"incompatible compound types in assignment: "
                     forall a. [a] -> [a] -> [a]
++ Type -> String
pType Type
t1 forall a. [a] -> [a] -> [a]
++ String
", " forall a. [a] -> [a] -> [a]
++ Type -> String
pType Type
t2
    (DirectType (TyBuiltin BuiltinType
TyVaList) TypeQuals
_ Attributes
_, DirectType (TyBuiltin BuiltinType
TyVaList) TypeQuals
_ Attributes
_) ->
      forall a b. b -> Either a b
Right ()
    (DirectType TypeName
tn1 TypeQuals
_ Attributes
_, DirectType TypeName
tn2 TypeQuals
_ Attributes
_)
      | forall a. Maybe a -> Bool
isJust (TypeName -> TypeName -> Maybe TypeName
arithmeticConversion TypeName
tn1 TypeName
tn2) -> forall a b. b -> Either a b
Right ()
      | Bool
otherwise -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ String
"incompatible direct types in assignment: "
                     forall a. [a] -> [a] -> [a]
++ Type -> String
pType Type
t1 forall a. [a] -> [a] -> [a]
++ String
", " forall a. [a] -> [a] -> [a]
++ Type -> String
pType Type
t2
    (Type
t1', Type
t2') -> Type -> Type -> Either String ()
compatible Type
t1' Type
t2'
assignCompatible CAssignOp
op Type
t1 Type
t2 = forall (f :: * -> *) a. Functor f => f a -> f ()
voidforall 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 CBinaryOp
op Type
t1 Type
t2 =
  case (CBinaryOp
op, Type -> Type
canonicalType Type
t1, Type -> Type
canonicalType Type
t2) of
    (CBinaryOp
_, Type
t1', Type
t2')
      | CBinaryOp -> Bool
isLogicOp CBinaryOp
op ->
        Type -> Either String ()
checkScalar Type
t1' forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Type -> Either String ()
checkScalar Type
t2' forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall a b. b -> Either a b
Right Type
boolType
      | CBinaryOp -> Bool
isCmpOp CBinaryOp
op ->
        case (Type
t1', Type
t2') of
          (DirectType TypeName
tn1 TypeQuals
_ Attributes
_, DirectType TypeName
tn2 TypeQuals
_ Attributes
_) ->
                case TypeName -> TypeName -> Maybe TypeName
arithmeticConversion TypeName
tn1 TypeName
tn2 of
                  Just TypeName
_ -> forall a b. b -> Either a b
Right Type
boolType
                  Maybe TypeName
Nothing -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ Doc -> String
render forall a b. (a -> b) -> a -> b
$
                             String -> Doc
text String
"incompatible arithmetic types in comparison: "
                             Doc -> Doc -> Doc
<+> forall p. Pretty p => p -> Doc
pretty Type
t1 Doc -> Doc -> Doc
<+> String -> Doc
text String
"and" Doc -> Doc -> Doc
<+> forall p. Pretty p => p -> Doc
pretty Type
t2
          (PtrType (DirectType TypeName
TyVoid TypeQuals
_ Attributes
_) TypeQuals
_ Attributes
_, Type
_)
            | Type -> Bool
isPointerType Type
t2' -> forall a b. b -> Either a b
Right Type
boolType
          (Type
_, PtrType (DirectType TypeName
TyVoid TypeQuals
_ Attributes
_) TypeQuals
_ Attributes
_)
            | Type -> Bool
isPointerType Type
t1' -> forall a b. b -> Either a b
Right Type
boolType
          (Type
_, Type
_)
            | Type -> Bool
isPointerType Type
t1' Bool -> Bool -> Bool
&& Type -> Bool
isIntegralType Type
t2' -> forall a b. b -> Either a b
Right Type
boolType
            | Type -> Bool
isIntegralType Type
t1' Bool -> Bool -> Bool
&& Type -> Bool
isPointerType Type
t2' -> 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' forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall a b. b -> Either a b
Right Type
boolType
          (Type
_, Type
_) -> forall a b. a -> Either a b
Left String
"incompatible types in comparison"
    (CBinaryOp
CSubOp, ArrayType Type
t1' ArraySize
_ TypeQuals
_ Attributes
_, ArrayType Type
t2' ArraySize
_ TypeQuals
_ Attributes
_) ->
      Type -> Type -> Either String ()
compatible Type
t1' Type
t2' forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall a b. b -> Either a b
Right Type
ptrDiffType
    (CBinaryOp
CSubOp, ArrayType Type
t1' ArraySize
_ TypeQuals
_ Attributes
_, PtrType Type
t2' TypeQuals
_ Attributes
_) ->
      Type -> Type -> Either String ()
compatible Type
t1' Type
t2' forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall a b. b -> Either a b
Right Type
ptrDiffType
    (CBinaryOp
CSubOp, PtrType Type
t1' TypeQuals
_ Attributes
_, ArrayType Type
t2' ArraySize
_ TypeQuals
_ Attributes
_) ->
      Type -> Type -> Either String ()
compatible Type
t1' Type
t2' forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall a b. b -> Either a b
Right Type
ptrDiffType
    (CBinaryOp
CSubOp, PtrType Type
t1' TypeQuals
_ Attributes
_, PtrType Type
t2' TypeQuals
_ Attributes
_) ->
      Type -> Type -> Either String ()
compatible Type
t1' Type
t2' forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall a b. b -> Either a b
Right Type
ptrDiffType
    (CBinaryOp
_, PtrType Type
_ TypeQuals
_ Attributes
_, Type
t2')
      | CBinaryOp -> Bool
isPtrOp CBinaryOp
op Bool -> Bool -> Bool
&& Type -> Bool
isIntegralType Type
t2' -> forall a b. b -> Either a b
Right Type
t1
      | Bool
otherwise -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ String
"invalid pointer operation: " forall a. [a] -> [a] -> [a]
++ Doc -> String
render (forall p. Pretty p => p -> Doc
pretty CBinaryOp
op)
    (CBinaryOp
CAddOp, Type
t1', PtrType Type
_ TypeQuals
_ Attributes
_) | Type -> Bool
isIntegralType Type
t1' -> forall a b. b -> Either a b
Right Type
t2
    (CBinaryOp
_, ArrayType Type
_ ArraySize
_ TypeQuals
_ Attributes
_, Type
t2')
      | CBinaryOp -> Bool
isPtrOp CBinaryOp
op Bool -> Bool -> Bool
&& Type -> Bool
isIntegralType Type
t2' -> forall a b. b -> Either a b
Right Type
t1
      | Bool
otherwise -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ String
"invalid pointer operation: " forall a. [a] -> [a] -> [a]
++ Doc -> String
render (forall p. Pretty p => p -> Doc
pretty CBinaryOp
op)
    (CBinaryOp
CAddOp, Type
t1', ArrayType Type
_ ArraySize
_ TypeQuals
_ Attributes
_) | Type -> Bool
isIntegralType Type
t1' -> forall a b. b -> Either a b
Right Type
t2
    (CBinaryOp
_, DirectType TypeName
tn1 TypeQuals
q1 Attributes
a1, DirectType TypeName
tn2 TypeQuals
q2 Attributes
a2) ->
        do forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (CBinaryOp -> Bool
isBitOp CBinaryOp
op) (Type -> Either String ()
checkIntegral Type
t1 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 TypeName
tn -> forall a b. b -> Either a b
Right 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)
             Maybe TypeName
Nothing -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ Doc -> String
render forall a b. (a -> b) -> a -> b
$
                        String -> Doc
text String
"invalid binary operation:" Doc -> Doc -> Doc
<+> forall p. Pretty p => p -> Doc
pretty Type
t1 Doc -> Doc -> Doc
<+> forall p. Pretty p => p -> Doc
pretty CBinaryOp
op Doc -> Doc -> Doc
<+> forall p. Pretty p => p -> Doc
pretty Type
t2
    (CBinaryOp
_, Type
_, Type
_) -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ Doc -> String
render forall a b. (a -> b) -> a -> b
$
                 String -> Doc
text String
"unhandled binary operation:" Doc -> Doc -> Doc
<+> forall p. Pretty p => p -> Doc
pretty Type
t1 Doc -> Doc -> Doc
<+> forall p. Pretty p => p -> Doc
pretty CBinaryOp
op Doc -> Doc -> 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 Type
t1 Type
t2 =
  case (Type -> Type
canonicalType Type
t1, Type -> Type
canonicalType Type
t2) of
    (PtrType (DirectType TypeName
TyVoid TypeQuals
_ Attributes
_) TypeQuals
_ Attributes
_, Type
t2') | Type -> Bool
isPointerType Type
t2' -> forall a b. b -> Either a b
Right Type
t2
    (Type
t1', PtrType (DirectType TypeName
TyVoid TypeQuals
_ Attributes
_) TypeQuals
_ Attributes
_) | Type -> Bool
isPointerType Type
t1' -> forall a b. b -> Either a b
Right Type
t1
    (ArrayType Type
t1' ArraySize
_ TypeQuals
q1 Attributes
a1, ArrayType Type
t2' ArraySize
_ TypeQuals
q2 Attributes
a2) ->
      do Type
t <- Type -> Type -> Either String Type
compositeType Type
t1' Type
t2'
         forall a b. b -> Either a b
Right 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 TypeName
tn1 TypeQuals
q1 Attributes
a1), t2' :: Type
t2'@(DirectType TypeName
tn2 TypeQuals
q2 Attributes
a2)) ->
      case TypeName -> TypeName -> Maybe TypeName
arithmeticConversion TypeName
tn1 TypeName
tn2 of
        Just TypeName
tn -> forall a b. b -> Either a b
Right 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)
        Maybe TypeName
Nothing -> Type -> Type -> Either String Type
compositeType Type
t1' Type
t2'
    (Type
t1', Type
t2') -> Type -> Type -> Either String Type
compositeType Type
t1' Type
t2'

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

varAddrType :: IdentDecl -> Either String Type
varAddrType :: IdentDecl -> Either String Type
varAddrType IdentDecl
d =
  do case forall d. Declaration d => d -> Storage
declStorage IdentDecl
d of
       Auto Bool
True -> forall a b. a -> Either a b
Left String
"address of register variable"
       Storage
_         -> forall a b. b -> Either a b
Right ()
     case Type
t of
       ArrayType Type
_ ArraySize
_ TypeQuals
q Attributes
a -> forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ Type -> TypeQuals -> Attributes -> Type
PtrType Type
t TypeQuals
q Attributes
a
       Type
_                 -> forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ Type -> Type
simplePtr Type
t
  where t :: Type
t = 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 :: forall (m :: * -> *).
(MonadCError m, MonadSymtab m) =>
NodeInfo -> Ident -> Type -> m Type
fieldType NodeInfo
ni Ident
m Type
t =
  case Type -> Type
canonicalType Type
t of
    DirectType (TyComp CompTypeRef
ctr) TypeQuals
_ Attributes
_ ->
      do TagDef
td <- forall (m :: * -> *).
(MonadCError m, MonadSymtab m) =>
NodeInfo -> SUERef -> m TagDef
lookupSUE NodeInfo
ni (forall a. HasSUERef a => a -> SUERef
sueRef CompTypeRef
ctr)
         [(Ident, Type)]
ms <- forall (m :: * -> *).
(MonadCError m, MonadSymtab m) =>
NodeInfo -> TagDef -> m [(Ident, Type)]
tagMembers NodeInfo
ni TagDef
td
         case forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Ident
m [(Ident, Type)]
ms of
           Just Type
ft -> forall (m :: * -> *) a. Monad m => a -> m a
return Type
ft
           Maybe Type
Nothing -> forall (m :: * -> *) a. MonadCError m => NodeInfo -> String -> m a
typeError NodeInfo
ni forall a b. (a -> b) -> a -> b
$ String
"field not found: " forall a. [a] -> [a] -> [a]
++ Ident -> String
identToString Ident
m
    Type
_t' -> forall (m :: * -> *) a. MonadCError m => NodeInfo -> String -> m a
astError NodeInfo
ni forall a b. (a -> b) -> a -> b
$
          String
"field of non-composite type: " forall a. [a] -> [a] -> [a]
++ Ident -> String
identToString Ident
m
          forall a. [a] -> [a] -> [a]
++ 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 :: forall (m :: * -> *).
(MonadCError m, MonadSymtab m) =>
NodeInfo -> TagDef -> m [(Ident, Type)]
tagMembers NodeInfo
ni TagDef
td =
  case TagDef
td of
    CompDef (CompType SUERef
_ CompTyKind
_ [MemberDecl]
ms Attributes
_ NodeInfo
_) -> forall {m :: * -> *} {a}.
(MonadCError m, MonadSymtab m, Declaration a) =>
[a] -> m [(Ident, Type)]
getMembers [MemberDecl]
ms
    EnumDef (EnumType SUERef
_ [Enumerator]
es Attributes
_ NodeInfo
_) -> forall {m :: * -> *} {a}.
(MonadCError m, MonadSymtab m, Declaration a) =>
[a] -> m [(Ident, Type)]
getMembers [Enumerator]
es
  where getMembers :: [a] -> m [(Ident, Type)]
getMembers [a]
ds =
          do let ts :: [Type]
ts = forall a b. (a -> b) -> [a] -> [b]
map forall n. Declaration n => n -> Type
declType [a]
ds
                 ns :: [VarName]
ns = forall a b. (a -> b) -> [a] -> [b]
map forall n. Declaration n => n -> VarName
declName [a]
ds
             forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
`liftM` forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall (m :: * -> *).
(MonadCError m, MonadSymtab m) =>
NodeInfo -> (VarName, Type) -> m [(Ident, Type)]
expandAnonymous NodeInfo
ni) (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 :: forall (m :: * -> *).
(MonadCError m, MonadSymtab m) =>
NodeInfo -> (VarName, Type) -> m [(Ident, Type)]
expandAnonymous NodeInfo
ni (VarName
NoName, DirectType (TyComp CompTypeRef
ctr) TypeQuals
_ Attributes
_) =
  forall (m :: * -> *).
(MonadCError m, MonadSymtab m) =>
NodeInfo -> SUERef -> m TagDef
lookupSUE NodeInfo
ni (forall a. HasSUERef a => a -> SUERef
sueRef CompTypeRef
ctr) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *).
(MonadCError m, MonadSymtab m) =>
NodeInfo -> TagDef -> m [(Ident, Type)]
tagMembers NodeInfo
ni
expandAnonymous NodeInfo
_ (VarName
NoName, Type
_) = forall (m :: * -> *) a. Monad m => a -> m a
return []
expandAnonymous NodeInfo
_ (VarName Ident
n Maybe AsmName
_, Type
t) = forall (m :: * -> *) a. Monad m => a -> m a
return [(Ident
n, Type
t)]

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

deepTypeAttrs :: (MonadCError m, MonadSymtab m) =>
                 Type -> m Attributes
deepTypeAttrs :: forall (m :: * -> *).
(MonadCError m, MonadSymtab m) =>
Type -> m Attributes
deepTypeAttrs (DirectType (TyComp (CompTypeRef SUERef
sue CompTyKind
_ NodeInfo
ni)) TypeQuals
_ Attributes
attrs) =
  (Attributes
attrs forall a. [a] -> [a] -> [a]
++) forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
`liftM` forall (m :: * -> *).
(MonadCError m, MonadSymtab m) =>
NodeInfo -> SUERef -> m Attributes
sueAttrs NodeInfo
ni SUERef
sue
deepTypeAttrs (DirectType (TyEnum (EnumTypeRef SUERef
sue NodeInfo
ni)) TypeQuals
_ Attributes
attrs) =
  (Attributes
attrs forall a. [a] -> [a] -> [a]
++) forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
`liftM` forall (m :: * -> *).
(MonadCError m, MonadSymtab m) =>
NodeInfo -> SUERef -> m Attributes
sueAttrs NodeInfo
ni SUERef
sue
deepTypeAttrs (DirectType TypeName
_ TypeQuals
_ Attributes
attrs) = forall (m :: * -> *) a. Monad m => a -> m a
return Attributes
attrs
deepTypeAttrs (PtrType Type
t TypeQuals
_ Attributes
attrs) = (Attributes
attrs forall a. [a] -> [a] -> [a]
++) forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
`liftM` forall (m :: * -> *).
(MonadCError m, MonadSymtab m) =>
Type -> m Attributes
deepTypeAttrs Type
t
deepTypeAttrs (ArrayType Type
t ArraySize
_ TypeQuals
_ Attributes
attrs) = (Attributes
attrs forall a. [a] -> [a] -> [a]
++) forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
`liftM` forall (m :: * -> *).
(MonadCError m, MonadSymtab m) =>
Type -> m Attributes
deepTypeAttrs Type
t
deepTypeAttrs (FunctionType (FunType Type
t [ParamDecl]
_ Bool
_) Attributes
attrs) =
  (Attributes
attrs forall a. [a] -> [a] -> [a]
++) forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
`liftM` forall (m :: * -> *).
(MonadCError m, MonadSymtab m) =>
Type -> m Attributes
deepTypeAttrs Type
t
deepTypeAttrs (FunctionType (FunTypeIncomplete Type
t)  Attributes
attrs) =
  (Attributes
attrs forall a. [a] -> [a] -> [a]
++) forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
`liftM` forall (m :: * -> *).
(MonadCError m, MonadSymtab m) =>
Type -> m Attributes
deepTypeAttrs Type
t
deepTypeAttrs (TypeDefType (TypeDefRef Ident
i Type
_ NodeInfo
ni) TypeQuals
_ Attributes
attrs) =
  (Attributes
attrs forall a. [a] -> [a] -> [a]
++) forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
`liftM` 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 :: forall (m :: * -> *).
(MonadCError m, MonadSymtab m) =>
NodeInfo -> Ident -> m Attributes
typeDefAttrs NodeInfo
ni Ident
i =
  do DefTable
dt <- forall (m :: * -> *). MonadSymtab m => m DefTable
getDefTable
     case Ident -> DefTable -> Maybe IdentEntry
lookupIdent Ident
i DefTable
dt of
       Maybe IdentEntry
Nothing -> forall (m :: * -> *) a. MonadCError m => NodeInfo -> String -> m a
astError NodeInfo
ni forall a b. (a -> b) -> a -> b
$ String
"can't find typedef name: " forall a. [a] -> [a] -> [a]
++ Ident -> String
identToString Ident
i
       Just (Left (TypeDef Ident
_ Type
t Attributes
attrs NodeInfo
_)) -> (Attributes
attrs forall a. [a] -> [a] -> [a]
++) forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
`liftM` forall (m :: * -> *).
(MonadCError m, MonadSymtab m) =>
Type -> m Attributes
deepTypeAttrs Type
t
       Just (Right IdentDecl
_) -> forall (m :: * -> *) a. MonadCError m => NodeInfo -> String -> m a
astError NodeInfo
ni forall a b. (a -> b) -> a -> b
$ String
"not a typedef name: " forall a. [a] -> [a] -> [a]
++ Ident -> String
identToString Ident
i

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