{-# LANGUAGE PatternGuards, FlexibleContexts #-}
-----------------------------------------------------------------------------
-- |
-- Module      :  Language.C.Analysis.DeclAnalysis
-- Copyright   :  (c) 2008 Benedikt Huber
-- License     :  BSD-style
-- Maintainer  :  benedikt.huber@gmail.com
-- Stability   :  alpha
-- Portability :  ghc
--
-- This module performs the analysis of declarations and the translation of
-- type specifications in the AST.
-----------------------------------------------------------------------------
module Language.C.Analysis.DeclAnalysis (
  -- * Translating types
  analyseTypeDecl,
  tType,tDirectType,tNumType,tArraySize,tTypeQuals,
  mergeOldStyle,
  -- * Dissecting type specs
  canonicalTypeSpec, NumBaseType(..),SignSpec(..),SizeMod(..),NumTypeSpec(..),TypeSpecAnalysis(..),
  canonicalStorageSpec, StorageSpec(..), hasThreadLocalSpec, hasClKernelSpec, isTypeDef,
  -- * Helpers
  VarDeclInfo(..),
  tAttr,mkVarName,getOnlyDeclr,nameOfDecl,analyseVarDecl,analyseVarDecl'
)
where
import Language.C.Data.Error
import Language.C.Data.Node
import Language.C.Data.Ident
import Language.C.Pretty
import Language.C.Syntax
import {-# SOURCE #-} Language.C.Analysis.AstAnalysis (tExpr, ExprSide(..))
import Language.C.Analysis.DefTable (TagFwdDecl(..), insertType)
import Language.C.Analysis.SemError
import Language.C.Analysis.SemRep
import Language.C.Analysis.TravMonad

import Data.Foldable as F (foldrM)
import Control.Monad (liftM,when,ap,unless,zipWithM)
import Data.List (intercalate, mapAccumL)
import qualified Data.Map as Map
import Text.PrettyPrint.HughesPJ


-- * handling declarations

-- | analyse and translate a parameter declaration
-- Should be called in either prototype or block scope
tParamDecl :: (MonadTrav m) => CDecl -> m ParamDecl
tParamDecl :: CDecl -> m ParamDecl
tParamDecl (CStaticAssert _ _ node :: NodeInfo
node) =
  NodeInfo -> String -> m ParamDecl
forall (m :: * -> *) a. MonadCError m => NodeInfo -> String -> m a
astError NodeInfo
node "expected parameter, not static assertion"
tParamDecl (CDecl declspecs :: [CDeclarationSpecifier NodeInfo]
declspecs declrs :: [(Maybe (CDeclarator NodeInfo), Maybe (CInitializer NodeInfo),
  Maybe (CExpression NodeInfo))]
declrs node :: NodeInfo
node) =
  do CDeclarator NodeInfo
declr <- m (CDeclarator NodeInfo)
getParamDeclr
     -- analyse the variable declaration
     (VarDeclInfo name :: VarName
name fun_spec :: FunctionAttrs
fun_spec  storage_spec :: StorageSpec
storage_spec attrs :: Attributes
attrs ty :: Type
ty declr_node :: NodeInfo
declr_node) <- Bool
-> [CDeclarationSpecifier NodeInfo]
-> CDeclarator NodeInfo
-> [CDecl]
-> Maybe (CInitializer NodeInfo)
-> m VarDeclInfo
forall (m :: * -> *).
MonadTrav m =>
Bool
-> [CDeclarationSpecifier NodeInfo]
-> CDeclarator NodeInfo
-> [CDecl]
-> Maybe (CInitializer NodeInfo)
-> m VarDeclInfo
analyseVarDecl' Bool
True [CDeclarationSpecifier NodeInfo]
declspecs CDeclarator NodeInfo
declr [] Maybe (CInitializer NodeInfo)
forall a. Maybe a
Nothing
     Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (FunctionAttrs -> Bool
isInline FunctionAttrs
fun_spec Bool -> Bool -> Bool
|| FunctionAttrs -> Bool
isNoreturn FunctionAttrs
fun_spec) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
       BadSpecifierError -> m ()
forall (m :: * -> *) e a. (MonadCError m, Error e) => e -> m a
throwTravError (NodeInfo -> String -> BadSpecifierError
badSpecifierError NodeInfo
node "parameter declaration with function specifier")
     -- compute storage of parameter (NoStorage, but might have a register specifier)
     Storage
storage <- Either BadSpecifierError Storage -> m Storage
forall (m :: * -> *) e a.
(MonadCError m, Error e) =>
Either e a -> m a
throwOnLeft (Either BadSpecifierError Storage -> m Storage)
-> Either BadSpecifierError Storage -> m Storage
forall a b. (a -> b) -> a -> b
$ NodeInfo -> StorageSpec -> Either BadSpecifierError Storage
computeParamStorage NodeInfo
node StorageSpec
storage_spec
     let paramDecl :: ParamDecl
paramDecl = VarName -> Storage -> Attributes -> Type -> NodeInfo -> ParamDecl
mkParamDecl VarName
name Storage
storage Attributes
attrs Type
ty NodeInfo
declr_node
     -- XXX: we shouldn't modify the deftable here, just analyse and build representation
     ParamDecl -> m ParamDecl
forall (m :: * -> *) a. Monad m => a -> m a
return ParamDecl
paramDecl
  where
  getParamDeclr :: m (CDeclarator NodeInfo)
getParamDeclr =
      case [(Maybe (CDeclarator NodeInfo), Maybe (CInitializer NodeInfo),
  Maybe (CExpression NodeInfo))]
declrs of
          [] -> CDeclarator NodeInfo -> m (CDeclarator NodeInfo)
forall (m :: * -> *) a. Monad m => a -> m a
return (NodeInfo -> CDeclarator NodeInfo
emptyDeclr NodeInfo
node)
          [(Just declr :: CDeclarator NodeInfo
declr,Nothing,Nothing)] -> CDeclarator NodeInfo -> m (CDeclarator NodeInfo)
forall (m :: * -> *) a. Monad m => a -> m a
return CDeclarator NodeInfo
declr
          _ -> NodeInfo -> String -> m (CDeclarator NodeInfo)
forall (m :: * -> *) a. MonadCError m => NodeInfo -> String -> m a
astError NodeInfo
node "bad parameter declaration: multiple decls / bitfield or initializer present"
  mkParamDecl :: VarName -> Storage -> Attributes -> Type -> NodeInfo -> ParamDecl
mkParamDecl name :: VarName
name storage :: Storage
storage attrs :: Attributes
attrs ty :: Type
ty declr_node :: NodeInfo
declr_node =
    let vd :: VarDecl
vd = VarName -> DeclAttrs -> Type -> VarDecl
VarDecl VarName
name (FunctionAttrs -> Storage -> Attributes -> DeclAttrs
DeclAttrs FunctionAttrs
noFunctionAttrs Storage
storage Attributes
attrs) Type
ty in
    case VarName
name of
      NoName -> VarDecl -> NodeInfo -> ParamDecl
AbstractParamDecl VarDecl
vd NodeInfo
declr_node
      _ -> VarDecl -> NodeInfo -> ParamDecl
ParamDecl VarDecl
vd NodeInfo
declr_node

-- | a parameter declaration has no linkage and either auto or register storage
computeParamStorage :: NodeInfo -> StorageSpec -> Either BadSpecifierError Storage
computeParamStorage :: NodeInfo -> StorageSpec -> Either BadSpecifierError Storage
computeParamStorage _ NoStorageSpec = Storage -> Either BadSpecifierError Storage
forall a b. b -> Either a b
Right (Bool -> Storage
Auto Bool
False)
computeParamStorage _ RegSpec       = Storage -> Either BadSpecifierError Storage
forall a b. b -> Either a b
Right (Bool -> Storage
Auto Bool
True)
computeParamStorage _ ClGlobalSpec  = Storage -> Either BadSpecifierError Storage
forall a b. b -> Either a b
Right (Linkage -> Bool -> Storage
Static Linkage
NoLinkage Bool
False)
computeParamStorage _ ClLocalSpec   = Storage -> Either BadSpecifierError Storage
forall a b. b -> Either a b
Right (Linkage -> Bool -> Storage
Static Linkage
NoLinkage Bool
True)
computeParamStorage node :: NodeInfo
node spec :: StorageSpec
spec       = BadSpecifierError -> Either BadSpecifierError Storage
forall a b. a -> Either a b
Left (BadSpecifierError -> Either BadSpecifierError Storage)
-> (String -> BadSpecifierError)
-> String
-> Either BadSpecifierError Storage
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NodeInfo -> String -> BadSpecifierError
badSpecifierError NodeInfo
node (String -> Either BadSpecifierError Storage)
-> String -> Either BadSpecifierError Storage
forall a b. (a -> b) -> a -> b
$ "Bad storage specified for parameter: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ StorageSpec -> String
forall a. Show a => a -> String
show StorageSpec
spec

-- | analyse and translate a member declaration
tMemberDecls :: (MonadTrav m) => CDecl -> m [MemberDecl]
-- Anonymous struct or union members
-- TODO storage specs, align specs and attributes are ignored
tMemberDecls :: CDecl -> m [MemberDecl]
tMemberDecls (CStaticAssert _ _ node :: NodeInfo
node) =
  NodeInfo -> String -> m [MemberDecl]
forall (m :: * -> *) a. MonadCError m => NodeInfo -> String -> m a
astError NodeInfo
node "expected struct or union member, found static assertion"
tMemberDecls (CDecl declspecs :: [CDeclarationSpecifier NodeInfo]
declspecs [] node :: NodeInfo
node) =
  do let (_storage_specs :: [CStorageSpecifier NodeInfo]
_storage_specs, _attrs :: [CAttribute NodeInfo]
_attrs, typequals :: [CTypeQualifier NodeInfo]
typequals, typespecs :: [CTypeSpecifier NodeInfo]
typespecs, funspecs :: [CFunctionSpecifier NodeInfo]
funspecs, _alignspecs :: [CAlignmentSpecifier NodeInfo]
_alignspecs) =
           [CDeclarationSpecifier NodeInfo]
-> ([CStorageSpecifier NodeInfo], [CAttribute NodeInfo],
    [CTypeQualifier NodeInfo], [CTypeSpecifier NodeInfo],
    [CFunctionSpecifier NodeInfo], [CAlignmentSpecifier NodeInfo])
forall a.
[CDeclarationSpecifier a]
-> ([CStorageSpecifier a], [CAttribute a], [CTypeQualifier a],
    [CTypeSpecifier a], [CFunctionSpecifier a],
    [CAlignmentSpecifier a])
partitionDeclSpecs [CDeclarationSpecifier NodeInfo]
declspecs
     Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([CFunctionSpecifier NodeInfo] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [CFunctionSpecifier NodeInfo]
funspecs) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ NodeInfo -> String -> m ()
forall (m :: * -> *) a. MonadCError m => NodeInfo -> String -> m a
astError NodeInfo
node "member declaration with function specifier"
     TypeSpecAnalysis
canonTySpecs <- [CTypeSpecifier NodeInfo] -> m TypeSpecAnalysis
forall (m :: * -> *).
MonadTrav m =>
[CTypeSpecifier NodeInfo] -> m TypeSpecAnalysis
canonicalTypeSpec [CTypeSpecifier NodeInfo]
typespecs
     Type
ty <- Bool
-> NodeInfo
-> [CTypeQualifier NodeInfo]
-> TypeSpecAnalysis
-> [CDerivedDeclr]
-> [CDecl]
-> m Type
forall (m :: * -> *).
MonadTrav m =>
Bool
-> NodeInfo
-> [CTypeQualifier NodeInfo]
-> TypeSpecAnalysis
-> [CDerivedDeclr]
-> [CDecl]
-> m Type
tType Bool
True NodeInfo
node [CTypeQualifier NodeInfo]
typequals TypeSpecAnalysis
canonTySpecs [] []
     case Type
ty of
       DirectType (TyComp _) _ _ ->
         [MemberDecl] -> m [MemberDecl]
forall (m :: * -> *) a. Monad m => a -> m a
return ([MemberDecl] -> m [MemberDecl]) -> [MemberDecl] -> m [MemberDecl]
forall a b. (a -> b) -> a -> b
$ [VarDecl -> Maybe (CExpression NodeInfo) -> NodeInfo -> MemberDecl
MemberDecl
                   -- XXX: are these DeclAttrs correct?
                   (VarName -> DeclAttrs -> Type -> VarDecl
VarDecl VarName
NoName (FunctionAttrs -> Storage -> Attributes -> DeclAttrs
DeclAttrs FunctionAttrs
noFunctionAttrs Storage
NoStorage []) Type
ty)
                   Maybe (CExpression NodeInfo)
forall a. Maybe a
Nothing NodeInfo
node]
       _ -> NodeInfo -> String -> m [MemberDecl]
forall (m :: * -> *) a. MonadCError m => NodeInfo -> String -> m a
astError NodeInfo
node "anonymous member has a non-composite type"
-- Named members
tMemberDecls (CDecl declspecs :: [CDeclarationSpecifier NodeInfo]
declspecs declrs :: [(Maybe (CDeclarator NodeInfo), Maybe (CInitializer NodeInfo),
  Maybe (CExpression NodeInfo))]
declrs node :: NodeInfo
node) = (Bool
 -> (Maybe (CDeclarator NodeInfo), Maybe (CInitializer NodeInfo),
     Maybe (CExpression NodeInfo))
 -> m MemberDecl)
-> [Bool]
-> [(Maybe (CDeclarator NodeInfo), Maybe (CInitializer NodeInfo),
     Maybe (CExpression NodeInfo))]
-> m [MemberDecl]
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m [c]
zipWithM Bool
-> (Maybe (CDeclarator NodeInfo), Maybe (CInitializer NodeInfo),
    Maybe (CExpression NodeInfo))
-> m MemberDecl
forall (m :: * -> *) a.
MonadTrav m =>
Bool
-> (Maybe (CDeclarator NodeInfo), Maybe a,
    Maybe (CExpression NodeInfo))
-> m MemberDecl
tMemberDecl (Bool
TrueBool -> [Bool] -> [Bool]
forall a. a -> [a] -> [a]
:Bool -> [Bool]
forall a. a -> [a]
repeat Bool
False) [(Maybe (CDeclarator NodeInfo), Maybe (CInitializer NodeInfo),
  Maybe (CExpression NodeInfo))]
declrs
    where
    tMemberDecl :: Bool
-> (Maybe (CDeclarator NodeInfo), Maybe a,
    Maybe (CExpression NodeInfo))
-> m MemberDecl
tMemberDecl handle_sue_def :: Bool
handle_sue_def (Just member_declr :: CDeclarator NodeInfo
member_declr,Nothing,bit_field_size_opt :: Maybe (CExpression NodeInfo)
bit_field_size_opt) =
        -- TODO: use analyseVarDecl here, not analyseVarDecl'
        do VarDeclInfo
var_decl <- Bool
-> [CDeclarationSpecifier NodeInfo]
-> CDeclarator NodeInfo
-> [CDecl]
-> Maybe (CInitializer NodeInfo)
-> m VarDeclInfo
forall (m :: * -> *).
MonadTrav m =>
Bool
-> [CDeclarationSpecifier NodeInfo]
-> CDeclarator NodeInfo
-> [CDecl]
-> Maybe (CInitializer NodeInfo)
-> m VarDeclInfo
analyseVarDecl' Bool
handle_sue_def [CDeclarationSpecifier NodeInfo]
declspecs CDeclarator NodeInfo
member_declr [] Maybe (CInitializer NodeInfo)
forall a. Maybe a
Nothing
           let (VarDeclInfo name :: VarName
name fun_spec :: FunctionAttrs
fun_spec storage_spec :: StorageSpec
storage_spec attrs :: Attributes
attrs ty :: Type
ty _node_info :: NodeInfo
_node_info) = VarDeclInfo
var_decl
           --
           FunctionAttrs -> StorageSpec -> m ()
forall (m :: * -> *).
MonadCError m =>
FunctionAttrs -> StorageSpec -> m ()
checkValidMemberSpec FunctionAttrs
fun_spec StorageSpec
storage_spec
           MemberDecl -> m MemberDecl
forall (m :: * -> *) a. Monad m => a -> m a
return (MemberDecl -> m MemberDecl) -> MemberDecl -> m MemberDecl
forall a b. (a -> b) -> a -> b
$ VarDecl -> Maybe (CExpression NodeInfo) -> NodeInfo -> MemberDecl
MemberDecl (VarName -> DeclAttrs -> Type -> VarDecl
VarDecl VarName
name (FunctionAttrs -> Storage -> Attributes -> DeclAttrs
DeclAttrs FunctionAttrs
noFunctionAttrs Storage
NoStorage Attributes
attrs) Type
ty)
                               Maybe (CExpression NodeInfo)
bit_field_size_opt NodeInfo
node
    tMemberDecl handle_sue_def :: Bool
handle_sue_def (Nothing,Nothing,Just bit_field_size :: CExpression NodeInfo
bit_field_size) =
        do let (storage_specs :: [CStorageSpecifier NodeInfo]
storage_specs, _attrs :: [CAttribute NodeInfo]
_attrs, typequals :: [CTypeQualifier NodeInfo]
typequals, typespecs :: [CTypeSpecifier NodeInfo]
typespecs, _funspecs :: [CFunctionSpecifier NodeInfo]
_funspecs, _alignspecs :: [CAlignmentSpecifier NodeInfo]
_alignspecs) = [CDeclarationSpecifier NodeInfo]
-> ([CStorageSpecifier NodeInfo], [CAttribute NodeInfo],
    [CTypeQualifier NodeInfo], [CTypeSpecifier NodeInfo],
    [CFunctionSpecifier NodeInfo], [CAlignmentSpecifier NodeInfo])
forall a.
[CDeclarationSpecifier a]
-> ([CStorageSpecifier a], [CAttribute a], [CTypeQualifier a],
    [CTypeSpecifier a], [CFunctionSpecifier a],
    [CAlignmentSpecifier a])
partitionDeclSpecs [CDeclarationSpecifier NodeInfo]
declspecs
           -- TODO: funspecs/alignspecs not yet processed
           StorageSpec
_storage_spec  <- [CStorageSpecifier NodeInfo] -> m StorageSpec
forall (m :: * -> *).
MonadCError m =>
[CStorageSpecifier NodeInfo] -> m StorageSpec
canonicalStorageSpec [CStorageSpecifier NodeInfo]
storage_specs
           -- TODO: storage_spec not used
           TypeSpecAnalysis
canonTySpecs  <- [CTypeSpecifier NodeInfo] -> m TypeSpecAnalysis
forall (m :: * -> *).
MonadTrav m =>
[CTypeSpecifier NodeInfo] -> m TypeSpecAnalysis
canonicalTypeSpec [CTypeSpecifier NodeInfo]
typespecs
           Type
typ           <- Bool
-> NodeInfo
-> [CTypeQualifier NodeInfo]
-> TypeSpecAnalysis
-> [CDerivedDeclr]
-> [CDecl]
-> m Type
forall (m :: * -> *).
MonadTrav m =>
Bool
-> NodeInfo
-> [CTypeQualifier NodeInfo]
-> TypeSpecAnalysis
-> [CDerivedDeclr]
-> [CDecl]
-> m Type
tType Bool
handle_sue_def NodeInfo
node [CTypeQualifier NodeInfo]
typequals TypeSpecAnalysis
canonTySpecs [] []
           --
           MemberDecl -> m MemberDecl
forall (m :: * -> *) a. Monad m => a -> m a
return (MemberDecl -> m MemberDecl) -> MemberDecl -> m MemberDecl
forall a b. (a -> b) -> a -> b
$ Type -> CExpression NodeInfo -> NodeInfo -> MemberDecl
AnonBitField Type
typ CExpression NodeInfo
bit_field_size NodeInfo
node
    tMemberDecl _ _ = NodeInfo -> String -> m MemberDecl
forall (m :: * -> *) a. MonadCError m => NodeInfo -> String -> m a
astError NodeInfo
node "Bad member declaration"
    checkValidMemberSpec :: FunctionAttrs -> StorageSpec -> m ()
checkValidMemberSpec fun_spec :: FunctionAttrs
fun_spec storage_spec :: StorageSpec
storage_spec =
        do  Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (FunctionAttrs
fun_spec FunctionAttrs -> FunctionAttrs -> Bool
forall a. Eq a => a -> a -> Bool
/= FunctionAttrs
noFunctionAttrs)   (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ NodeInfo -> String -> m ()
forall (m :: * -> *) a. MonadCError m => NodeInfo -> String -> m a
astError NodeInfo
node "member declaration with inline specifier"
            Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (StorageSpec
storage_spec StorageSpec -> StorageSpec -> Bool
forall a. Eq a => a -> a -> Bool
/= StorageSpec
NoStorageSpec) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ NodeInfo -> String -> m ()
forall (m :: * -> *) a. MonadCError m => NodeInfo -> String -> m a
astError NodeInfo
node "storage specifier for member"
            () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

data StorageSpec = NoStorageSpec | AutoSpec | RegSpec | ThreadSpec | StaticSpec Bool | ExternSpec Bool
                 | ClKernelSpec | ClGlobalSpec | ClLocalSpec
                    deriving (StorageSpec -> StorageSpec -> Bool
(StorageSpec -> StorageSpec -> Bool)
-> (StorageSpec -> StorageSpec -> Bool) -> Eq StorageSpec
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: StorageSpec -> StorageSpec -> Bool
$c/= :: StorageSpec -> StorageSpec -> Bool
== :: StorageSpec -> StorageSpec -> Bool
$c== :: StorageSpec -> StorageSpec -> Bool
Eq,Eq StorageSpec
Eq StorageSpec =>
(StorageSpec -> StorageSpec -> Ordering)
-> (StorageSpec -> StorageSpec -> Bool)
-> (StorageSpec -> StorageSpec -> Bool)
-> (StorageSpec -> StorageSpec -> Bool)
-> (StorageSpec -> StorageSpec -> Bool)
-> (StorageSpec -> StorageSpec -> StorageSpec)
-> (StorageSpec -> StorageSpec -> StorageSpec)
-> Ord StorageSpec
StorageSpec -> StorageSpec -> Bool
StorageSpec -> StorageSpec -> Ordering
StorageSpec -> StorageSpec -> StorageSpec
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: StorageSpec -> StorageSpec -> StorageSpec
$cmin :: StorageSpec -> StorageSpec -> StorageSpec
max :: StorageSpec -> StorageSpec -> StorageSpec
$cmax :: StorageSpec -> StorageSpec -> StorageSpec
>= :: StorageSpec -> StorageSpec -> Bool
$c>= :: StorageSpec -> StorageSpec -> Bool
> :: StorageSpec -> StorageSpec -> Bool
$c> :: StorageSpec -> StorageSpec -> Bool
<= :: StorageSpec -> StorageSpec -> Bool
$c<= :: StorageSpec -> StorageSpec -> Bool
< :: StorageSpec -> StorageSpec -> Bool
$c< :: StorageSpec -> StorageSpec -> Bool
compare :: StorageSpec -> StorageSpec -> Ordering
$ccompare :: StorageSpec -> StorageSpec -> Ordering
$cp1Ord :: Eq StorageSpec
Ord,Int -> StorageSpec -> String -> String
[StorageSpec] -> String -> String
StorageSpec -> String
(Int -> StorageSpec -> String -> String)
-> (StorageSpec -> String)
-> ([StorageSpec] -> String -> String)
-> Show StorageSpec
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [StorageSpec] -> String -> String
$cshowList :: [StorageSpec] -> String -> String
show :: StorageSpec -> String
$cshow :: StorageSpec -> String
showsPrec :: Int -> StorageSpec -> String -> String
$cshowsPrec :: Int -> StorageSpec -> String -> String
Show,ReadPrec [StorageSpec]
ReadPrec StorageSpec
Int -> ReadS StorageSpec
ReadS [StorageSpec]
(Int -> ReadS StorageSpec)
-> ReadS [StorageSpec]
-> ReadPrec StorageSpec
-> ReadPrec [StorageSpec]
-> Read StorageSpec
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [StorageSpec]
$creadListPrec :: ReadPrec [StorageSpec]
readPrec :: ReadPrec StorageSpec
$creadPrec :: ReadPrec StorageSpec
readList :: ReadS [StorageSpec]
$creadList :: ReadS [StorageSpec]
readsPrec :: Int -> ReadS StorageSpec
$creadsPrec :: Int -> ReadS StorageSpec
Read)

hasThreadLocalSpec :: StorageSpec -> Bool
hasThreadLocalSpec :: StorageSpec -> Bool
hasThreadLocalSpec ThreadSpec = Bool
True
hasThreadLocalSpec ClLocalSpec = Bool
True
hasThreadLocalSpec (StaticSpec b :: Bool
b) = Bool
b
hasThreadLocalSpec (ExternSpec b :: Bool
b) = Bool
b
hasThreadLocalSpec _  = Bool
False

hasClKernelSpec :: StorageSpec -> Bool
hasClKernelSpec :: StorageSpec -> Bool
hasClKernelSpec ClKernelSpec = Bool
True

data VarDeclInfo = VarDeclInfo VarName FunctionAttrs StorageSpec Attributes Type NodeInfo

analyseVarDecl' :: (MonadTrav m) =>
                  Bool -> [CDeclSpec] ->
                  CDeclr -> [CDecl] -> Maybe CInit -> m VarDeclInfo
analyseVarDecl' :: Bool
-> [CDeclarationSpecifier NodeInfo]
-> CDeclarator NodeInfo
-> [CDecl]
-> Maybe (CInitializer NodeInfo)
-> m VarDeclInfo
analyseVarDecl' handle_sue_def :: Bool
handle_sue_def declspecs :: [CDeclarationSpecifier NodeInfo]
declspecs declr :: CDeclarator NodeInfo
declr oldstyle :: [CDecl]
oldstyle init_opt :: Maybe (CInitializer NodeInfo)
init_opt =
  do let (storage_specs :: [CStorageSpecifier NodeInfo]
storage_specs, attrs :: [CAttribute NodeInfo]
attrs, type_quals :: [CTypeQualifier NodeInfo]
type_quals, type_specs :: [CTypeSpecifier NodeInfo]
type_specs, funspecs :: [CFunctionSpecifier NodeInfo]
funspecs, _alignspecs :: [CAlignmentSpecifier NodeInfo]
_alignspecs) =
           [CDeclarationSpecifier NodeInfo]
-> ([CStorageSpecifier NodeInfo], [CAttribute NodeInfo],
    [CTypeQualifier NodeInfo], [CTypeSpecifier NodeInfo],
    [CFunctionSpecifier NodeInfo], [CAlignmentSpecifier NodeInfo])
forall a.
[CDeclarationSpecifier a]
-> ([CStorageSpecifier a], [CAttribute a], [CTypeQualifier a],
    [CTypeSpecifier a], [CFunctionSpecifier a],
    [CAlignmentSpecifier a])
partitionDeclSpecs [CDeclarationSpecifier NodeInfo]
declspecs
     TypeSpecAnalysis
canonTySpecs <- [CTypeSpecifier NodeInfo] -> m TypeSpecAnalysis
forall (m :: * -> *).
MonadTrav m =>
[CTypeSpecifier NodeInfo] -> m TypeSpecAnalysis
canonicalTypeSpec [CTypeSpecifier NodeInfo]
type_specs
     -- TODO: alignspecs not yet processed
     Bool
-> [CStorageSpecifier NodeInfo]
-> [CAttribute NodeInfo]
-> [CTypeQualifier NodeInfo]
-> TypeSpecAnalysis
-> [CFunctionSpecifier NodeInfo]
-> CDeclarator NodeInfo
-> [CDecl]
-> Maybe (CInitializer NodeInfo)
-> m VarDeclInfo
forall (m :: * -> *).
MonadTrav m =>
Bool
-> [CStorageSpecifier NodeInfo]
-> [CAttribute NodeInfo]
-> [CTypeQualifier NodeInfo]
-> TypeSpecAnalysis
-> [CFunctionSpecifier NodeInfo]
-> CDeclarator NodeInfo
-> [CDecl]
-> Maybe (CInitializer NodeInfo)
-> m VarDeclInfo
analyseVarDecl Bool
handle_sue_def [CStorageSpecifier NodeInfo]
storage_specs [CAttribute NodeInfo]
attrs [CTypeQualifier NodeInfo]
type_quals TypeSpecAnalysis
canonTySpecs [CFunctionSpecifier NodeInfo]
funspecs
                    CDeclarator NodeInfo
declr [CDecl]
oldstyle Maybe (CInitializer NodeInfo)
init_opt

-- | analyse declarators
analyseVarDecl :: (MonadTrav m) =>
                  Bool -> [CStorageSpec] -> [CAttr] -> [CTypeQual] ->
                  TypeSpecAnalysis -> [CFunSpec] ->
                  CDeclr -> [CDecl] -> Maybe CInit -> m VarDeclInfo
analyseVarDecl :: Bool
-> [CStorageSpecifier NodeInfo]
-> [CAttribute NodeInfo]
-> [CTypeQualifier NodeInfo]
-> TypeSpecAnalysis
-> [CFunctionSpecifier NodeInfo]
-> CDeclarator NodeInfo
-> [CDecl]
-> Maybe (CInitializer NodeInfo)
-> m VarDeclInfo
analyseVarDecl handle_sue_def :: Bool
handle_sue_def storage_specs :: [CStorageSpecifier NodeInfo]
storage_specs decl_attrs :: [CAttribute NodeInfo]
decl_attrs typequals :: [CTypeQualifier NodeInfo]
typequals canonTySpecs :: TypeSpecAnalysis
canonTySpecs fun_specs :: [CFunctionSpecifier NodeInfo]
fun_specs
               (CDeclr name_opt :: Maybe Ident
name_opt derived_declrs :: [CDerivedDeclr]
derived_declrs asmname_opt :: Maybe (CStringLiteral NodeInfo)
asmname_opt declr_attrs :: [CAttribute NodeInfo]
declr_attrs node :: NodeInfo
node)
               oldstyle_params :: [CDecl]
oldstyle_params _init_opt :: Maybe (CInitializer NodeInfo)
_init_opt
    = do -- analyse the storage specifiers
         StorageSpec
storage_spec  <- [CStorageSpecifier NodeInfo] -> m StorageSpec
forall (m :: * -> *).
MonadCError m =>
[CStorageSpecifier NodeInfo] -> m StorageSpec
canonicalStorageSpec [CStorageSpecifier NodeInfo]
storage_specs
         -- translate the type into semantic representation
         Type
typ          <- Bool
-> NodeInfo
-> [CTypeQualifier NodeInfo]
-> TypeSpecAnalysis
-> [CDerivedDeclr]
-> [CDecl]
-> m Type
forall (m :: * -> *).
MonadTrav m =>
Bool
-> NodeInfo
-> [CTypeQualifier NodeInfo]
-> TypeSpecAnalysis
-> [CDerivedDeclr]
-> [CDecl]
-> m Type
tType Bool
handle_sue_def NodeInfo
node [CTypeQualifier NodeInfo]
typequals TypeSpecAnalysis
canonTySpecs [CDerivedDeclr]
derived_declrs [CDecl]
oldstyle_params
         -- translate attributes
         Attributes
attrs'       <- (CAttribute NodeInfo -> m Attr)
-> [CAttribute NodeInfo] -> m Attributes
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM CAttribute NodeInfo -> m Attr
forall (m :: * -> *).
(MonadCError m, MonadSymtab m) =>
CAttribute NodeInfo -> m Attr
tAttr ([CAttribute NodeInfo]
decl_attrs [CAttribute NodeInfo]
-> [CAttribute NodeInfo] -> [CAttribute NodeInfo]
forall a. [a] -> [a] -> [a]
++ [CAttribute NodeInfo]
declr_attrs)
         -- make name
         VarName
name         <- NodeInfo
-> Maybe Ident -> Maybe (CStringLiteral NodeInfo) -> m VarName
forall (m :: * -> *).
(MonadCError m, MonadSymtab m) =>
NodeInfo
-> Maybe Ident -> Maybe (CStringLiteral NodeInfo) -> m VarName
mkVarName NodeInfo
node Maybe Ident
name_opt Maybe (CStringLiteral NodeInfo)
asmname_opt
         VarDeclInfo -> m VarDeclInfo
forall (m :: * -> *) a. Monad m => a -> m a
return (VarDeclInfo -> m VarDeclInfo) -> VarDeclInfo -> m VarDeclInfo
forall a b. (a -> b) -> a -> b
$ VarName
-> FunctionAttrs
-> StorageSpec
-> Attributes
-> Type
-> NodeInfo
-> VarDeclInfo
VarDeclInfo VarName
name FunctionAttrs
function_spec StorageSpec
storage_spec Attributes
attrs' Type
typ NodeInfo
node
    where
        updateFunSpec :: CFunctionSpecifier a -> FunctionAttrs -> FunctionAttrs
updateFunSpec (CInlineQual _) f :: FunctionAttrs
f = FunctionAttrs
f { isInline :: Bool
isInline = Bool
True }
        updateFunSpec (CNoreturnQual _) f :: FunctionAttrs
f = FunctionAttrs
f { isNoreturn :: Bool
isNoreturn = Bool
True }
        function_spec :: FunctionAttrs
function_spec = (CFunctionSpecifier NodeInfo -> FunctionAttrs -> FunctionAttrs)
-> FunctionAttrs -> [CFunctionSpecifier NodeInfo] -> FunctionAttrs
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr CFunctionSpecifier NodeInfo -> FunctionAttrs -> FunctionAttrs
forall a. CFunctionSpecifier a -> FunctionAttrs -> FunctionAttrs
updateFunSpec FunctionAttrs
noFunctionAttrs [CFunctionSpecifier NodeInfo]
fun_specs

-- return @True@ if the declarations is a type def
isTypeDef :: [CDeclSpec] -> Bool
isTypeDef :: [CDeclarationSpecifier NodeInfo] -> Bool
isTypeDef declspecs :: [CDeclarationSpecifier NodeInfo]
declspecs = Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ [NodeInfo] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ NodeInfo
n | (CStorageSpec (CTypedef n :: NodeInfo
n)) <- [CDeclarationSpecifier NodeInfo]
declspecs ]

-- * translation

-- | get the type of a /type declaration/
--
-- A type declaration @T@ may appear in thre forms:
--
--  * @typeof(T)@
--
--  * as abstract declarator in a function prototype, as in @f(int)@
--
--  * in a declaration without declarators, as in @struct x { int a } ;@
--
-- Currently, @analyseTypeDecl@ is exlusively used for analysing types for GNU's @typeof(T)@.
--
-- We move attributes to the type, as they have no meaning for the abstract declarator
analyseTypeDecl :: (MonadTrav m) => CDecl -> m Type
analyseTypeDecl :: CDecl -> m Type
analyseTypeDecl (CStaticAssert _ _ node :: NodeInfo
node) =
  NodeInfo -> String -> m Type
forall (m :: * -> *) a. MonadCError m => NodeInfo -> String -> m a
astError NodeInfo
node "Expected type declaration, found static assert"
analyseTypeDecl (CDecl declspecs :: [CDeclarationSpecifier NodeInfo]
declspecs declrs :: [(Maybe (CDeclarator NodeInfo), Maybe (CInitializer NodeInfo),
  Maybe (CExpression NodeInfo))]
declrs node :: NodeInfo
node)
    | [] <- [(Maybe (CDeclarator NodeInfo), Maybe (CInitializer NodeInfo),
  Maybe (CExpression NodeInfo))]
declrs = CDeclarator NodeInfo -> m Type
forall (m :: * -> *). MonadTrav m => CDeclarator NodeInfo -> m Type
analyseTyDeclr (NodeInfo -> CDeclarator NodeInfo
emptyDeclr NodeInfo
node)
    | [(Just declr :: CDeclarator NodeInfo
declr,Nothing,Nothing)] <- [(Maybe (CDeclarator NodeInfo), Maybe (CInitializer NodeInfo),
  Maybe (CExpression NodeInfo))]
declrs = CDeclarator NodeInfo -> m Type
forall (m :: * -> *). MonadTrav m => CDeclarator NodeInfo -> m Type
analyseTyDeclr CDeclarator NodeInfo
declr
    | Bool
otherwise = NodeInfo -> String -> m Type
forall (m :: * -> *) a. MonadCError m => NodeInfo -> String -> m a
astError NodeInfo
node "Bad declarator for type declaration"
    where
    analyseTyDeclr :: CDeclarator NodeInfo -> m Type
analyseTyDeclr (CDeclr Nothing derived_declrs :: [CDerivedDeclr]
derived_declrs Nothing attrs :: [CAttribute NodeInfo]
attrs _declrnode :: NodeInfo
_declrnode)
        | (Bool -> Bool
not ([CStorageSpecifier NodeInfo] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [CStorageSpecifier NodeInfo]
storagespec) Bool -> Bool -> Bool
|| Bool -> Bool
not ([CFunctionSpecifier NodeInfo] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [CFunctionSpecifier NodeInfo]
funspecs) Bool -> Bool -> Bool
|| Bool -> Bool
not ([CAlignmentSpecifier NodeInfo] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [CAlignmentSpecifier NodeInfo]
alignspecs)) =
            NodeInfo -> String -> m Type
forall (m :: * -> *) a. MonadCError m => NodeInfo -> String -> m a
astError NodeInfo
node "storage, function or alignment specifier for type declaration"
        | Bool
otherwise                          =
          do TypeSpecAnalysis
canonTySpecs <- [CTypeSpecifier NodeInfo] -> m TypeSpecAnalysis
forall (m :: * -> *).
MonadTrav m =>
[CTypeSpecifier NodeInfo] -> m TypeSpecAnalysis
canonicalTypeSpec [CTypeSpecifier NodeInfo]
typespecs
             Type
t <- Bool
-> NodeInfo
-> [CTypeQualifier NodeInfo]
-> TypeSpecAnalysis
-> [CDerivedDeclr]
-> [CDecl]
-> m Type
forall (m :: * -> *).
MonadTrav m =>
Bool
-> NodeInfo
-> [CTypeQualifier NodeInfo]
-> TypeSpecAnalysis
-> [CDerivedDeclr]
-> [CDecl]
-> m Type
tType Bool
True NodeInfo
node ((CAttribute NodeInfo -> CTypeQualifier NodeInfo)
-> [CAttribute NodeInfo] -> [CTypeQualifier NodeInfo]
forall a b. (a -> b) -> [a] -> [b]
map CAttribute NodeInfo -> CTypeQualifier NodeInfo
forall a. CAttribute a -> CTypeQualifier a
CAttrQual ([CAttribute NodeInfo]
attrs[CAttribute NodeInfo]
-> [CAttribute NodeInfo] -> [CAttribute NodeInfo]
forall a. [a] -> [a] -> [a]
++[CAttribute NodeInfo]
attrs_decl) [CTypeQualifier NodeInfo]
-> [CTypeQualifier NodeInfo] -> [CTypeQualifier NodeInfo]
forall a. [a] -> [a] -> [a]
++ [CTypeQualifier NodeInfo]
typequals)
                   TypeSpecAnalysis
canonTySpecs [CDerivedDeclr]
derived_declrs []
             case NodeInfo -> Maybe Name
nameOfNode NodeInfo
node of
               Just n :: Name
n -> (DefTable -> (Type, DefTable)) -> m Type
forall (m :: * -> *) a.
MonadSymtab m =>
(DefTable -> (a, DefTable)) -> m a
withDefTable (\dt :: DefTable
dt -> (Type
t, DefTable -> Name -> Type -> DefTable
insertType DefTable
dt Name
n Type
t))
               Nothing -> Type -> m Type
forall (m :: * -> *) a. Monad m => a -> m a
return Type
t
        where
        (storagespec :: [CStorageSpecifier NodeInfo]
storagespec, attrs_decl :: [CAttribute NodeInfo]
attrs_decl, typequals :: [CTypeQualifier NodeInfo]
typequals, typespecs :: [CTypeSpecifier NodeInfo]
typespecs, funspecs :: [CFunctionSpecifier NodeInfo]
funspecs, alignspecs :: [CAlignmentSpecifier NodeInfo]
alignspecs) = [CDeclarationSpecifier NodeInfo]
-> ([CStorageSpecifier NodeInfo], [CAttribute NodeInfo],
    [CTypeQualifier NodeInfo], [CTypeSpecifier NodeInfo],
    [CFunctionSpecifier NodeInfo], [CAlignmentSpecifier NodeInfo])
forall a.
[CDeclarationSpecifier a]
-> ([CStorageSpecifier a], [CAttribute a], [CTypeQualifier a],
    [CTypeSpecifier a], [CFunctionSpecifier a],
    [CAlignmentSpecifier a])
partitionDeclSpecs [CDeclarationSpecifier NodeInfo]
declspecs
    analyseTyDeclr _ = NodeInfo -> String -> m Type
forall (m :: * -> *) a. MonadCError m => NodeInfo -> String -> m a
astError NodeInfo
node "Non-abstract declarator in type declaration"


-- | translate a type
tType :: (MonadTrav m) => Bool -> NodeInfo -> [CTypeQual] -> TypeSpecAnalysis -> [CDerivedDeclr] -> [CDecl] -> m Type
tType :: Bool
-> NodeInfo
-> [CTypeQualifier NodeInfo]
-> TypeSpecAnalysis
-> [CDerivedDeclr]
-> [CDecl]
-> m Type
tType handle_sue_def :: Bool
handle_sue_def top_node :: NodeInfo
top_node typequals :: [CTypeQualifier NodeInfo]
typequals canonTySpecs :: TypeSpecAnalysis
canonTySpecs derived_declrs :: [CDerivedDeclr]
derived_declrs oldstyle_params :: [CDecl]
oldstyle_params
    = NodeInfo -> [CDecl] -> [CDerivedDeclr] -> m [CDerivedDeclr]
forall (m :: * -> *).
MonadCError m =>
NodeInfo -> [CDecl] -> [CDerivedDeclr] -> m [CDerivedDeclr]
mergeOldStyle NodeInfo
top_node [CDecl]
oldstyle_params [CDerivedDeclr]
derived_declrs m [CDerivedDeclr] -> ([CDerivedDeclr] -> m Type) -> m Type
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= [CDerivedDeclr] -> m Type
forall (m :: * -> *). MonadTrav m => [CDerivedDeclr] -> m Type
buildType
    where
    buildType :: [CDerivedDeclr] -> m Type
buildType [] =
        Bool
-> NodeInfo
-> [CTypeQualifier NodeInfo]
-> TypeSpecAnalysis
-> m Type
forall (m :: * -> *).
MonadTrav m =>
Bool
-> NodeInfo
-> [CTypeQualifier NodeInfo]
-> TypeSpecAnalysis
-> m Type
tDirectType Bool
handle_sue_def NodeInfo
top_node [CTypeQualifier NodeInfo]
typequals TypeSpecAnalysis
canonTySpecs
    buildType (CPtrDeclr ptrquals :: [CTypeQualifier NodeInfo]
ptrquals node :: NodeInfo
node : dds :: [CDerivedDeclr]
dds) =
        [CDerivedDeclr] -> m Type
buildType [CDerivedDeclr]
dds m Type -> (Type -> m Type) -> m Type
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= [CTypeQualifier NodeInfo] -> NodeInfo -> Type -> m Type
forall (m :: * -> *) p.
MonadTrav m =>
[CTypeQualifier NodeInfo] -> p -> Type -> m Type
buildPointerType [CTypeQualifier NodeInfo]
ptrquals NodeInfo
node
    buildType (CArrDeclr arrquals :: [CTypeQualifier NodeInfo]
arrquals size :: CArraySize NodeInfo
size node :: NodeInfo
node : dds :: [CDerivedDeclr]
dds)
        = [CDerivedDeclr] -> m Type
buildType [CDerivedDeclr]
dds m Type -> (Type -> m Type) -> m Type
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= [CTypeQualifier NodeInfo]
-> CArraySize NodeInfo -> NodeInfo -> Type -> m Type
forall (m :: * -> *) p.
MonadTrav m =>
[CTypeQualifier NodeInfo]
-> CArraySize NodeInfo -> p -> Type -> m Type
buildArrayType [CTypeQualifier NodeInfo]
arrquals CArraySize NodeInfo
size NodeInfo
node
    buildType (CFunDeclr (Right (params :: [CDecl]
params, isVariadic :: Bool
isVariadic)) attrs :: [CAttribute NodeInfo]
attrs node :: NodeInfo
node : dds :: [CDerivedDeclr]
dds)
        = [CDerivedDeclr] -> m Type
buildType [CDerivedDeclr]
dds m Type -> (Type -> m Type) -> m Type
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (((FunType, Attributes) -> Type)
-> m (FunType, Attributes) -> m Type
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM  ((FunType -> Attributes -> Type) -> (FunType, Attributes) -> Type
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry FunType -> Attributes -> Type
FunctionType) (m (FunType, Attributes) -> m Type)
-> (Type -> m (FunType, Attributes)) -> Type -> m Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [CDecl]
-> Bool
-> [CAttribute NodeInfo]
-> NodeInfo
-> Type
-> m (FunType, Attributes)
forall (m :: * -> *) (t :: * -> *) p.
(MonadTrav m, Traversable t) =>
[CDecl]
-> Bool
-> t (CAttribute NodeInfo)
-> p
-> Type
-> m (FunType, t Attr)
buildFunctionType [CDecl]
params Bool
isVariadic [CAttribute NodeInfo]
attrs NodeInfo
node)
    buildType (CFunDeclr (Left _) _ _ : _)
        -- /FIXME/: this is really an internal error, not an AST error.
        = NodeInfo -> String -> m Type
forall (m :: * -> *) a. MonadCError m => NodeInfo -> String -> m a
astError NodeInfo
top_node "old-style parameters remaining after mergeOldStyle"
    buildPointerType :: [CTypeQualifier NodeInfo] -> p -> Type -> m Type
buildPointerType ptrquals :: [CTypeQualifier NodeInfo]
ptrquals _node :: p
_node inner_ty :: Type
inner_ty
        = ((TypeQuals, Attributes) -> Type)
-> m (TypeQuals, Attributes) -> m Type
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (\(quals :: TypeQuals
quals,attrs :: Attributes
attrs) -> Type -> TypeQuals -> Attributes -> Type
PtrType Type
inner_ty TypeQuals
quals Attributes
attrs) ([CTypeQualifier NodeInfo] -> m (TypeQuals, Attributes)
forall (m :: * -> *).
MonadTrav m =>
[CTypeQualifier NodeInfo] -> m (TypeQuals, Attributes)
tTypeQuals [CTypeQualifier NodeInfo]
ptrquals)
    buildArrayType :: [CTypeQualifier NodeInfo]
-> CArraySize NodeInfo -> p -> Type -> m Type
buildArrayType arr_quals :: [CTypeQualifier NodeInfo]
arr_quals size :: CArraySize NodeInfo
size _node :: p
_node inner_ty :: Type
inner_ty
        = do (quals :: TypeQuals
quals,attrs :: Attributes
attrs) <- [CTypeQualifier NodeInfo] -> m (TypeQuals, Attributes)
forall (m :: * -> *).
MonadTrav m =>
[CTypeQualifier NodeInfo] -> m (TypeQuals, Attributes)
tTypeQuals [CTypeQualifier NodeInfo]
arr_quals
             ArraySize
arr_sz        <- CArraySize NodeInfo -> m ArraySize
forall (m :: * -> *).
MonadTrav m =>
CArraySize NodeInfo -> m ArraySize
tArraySize CArraySize NodeInfo
size
             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 Type
inner_ty ArraySize
arr_sz TypeQuals
quals Attributes
attrs
    -- We build functions in function prototype scope.
    -- When analyzing the  the function body, we push parameters in function body scope.
    buildFunctionType :: [CDecl]
-> Bool
-> t (CAttribute NodeInfo)
-> p
-> Type
-> m (FunType, t Attr)
buildFunctionType params :: [CDecl]
params is_variadic :: Bool
is_variadic attrs :: t (CAttribute NodeInfo)
attrs _node :: p
_node return_ty :: Type
return_ty
        = do m ()
forall (m :: * -> *). MonadSymtab m => m ()
enterPrototypeScope
             [ParamDecl]
params' <- (CDecl -> m ParamDecl) -> [CDecl] -> m [ParamDecl]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM CDecl -> m ParamDecl
forall (m :: * -> *). MonadTrav m => CDecl -> m ParamDecl
tParamDecl [CDecl]
params
             m ()
forall (m :: * -> *). MonadSymtab m => m ()
leavePrototypeScope
             t Attr
attrs'  <- (CAttribute NodeInfo -> m Attr)
-> t (CAttribute NodeInfo) -> m (t Attr)
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM CAttribute NodeInfo -> m Attr
forall (m :: * -> *).
(MonadCError m, MonadSymtab m) =>
CAttribute NodeInfo -> m Attr
tAttr t (CAttribute NodeInfo)
attrs
             (FunType, t Attr) -> m (FunType, t Attr)
forall (m :: * -> *) a. Monad m => a -> m a
return ((FunType, t Attr) -> m (FunType, t Attr))
-> (FunType, t Attr) -> m (FunType, t Attr)
forall a b. (a -> b) -> a -> b
$ (\t :: FunType
t -> (FunType
t,t Attr
attrs')) (FunType -> (FunType, t Attr)) -> FunType -> (FunType, t Attr)
forall a b. (a -> b) -> a -> b
$
                case ((ParamDecl -> Type) -> [ParamDecl] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map ParamDecl -> Type
forall n. Declaration n => n -> Type
declType [ParamDecl]
params',Bool
is_variadic) of
                    ([],False) -> Type -> FunType
FunTypeIncomplete Type
return_ty  -- may be improved later on
                    ([DirectType TyVoid _ _],False) -> Type -> [ParamDecl] -> Bool -> FunType
FunType Type
return_ty [] Bool
False
                    _ -> Type -> [ParamDecl] -> Bool -> FunType
FunType Type
return_ty [ParamDecl]
params' Bool
is_variadic

-- | translate a type without (syntactic) indirections
-- Due to the GNU @typeof@ extension and typeDefs, this can be an arbitrary type
tDirectType :: (MonadTrav m) =>
               Bool -> NodeInfo -> [CTypeQual] -> TypeSpecAnalysis -> m Type
tDirectType :: Bool
-> NodeInfo
-> [CTypeQualifier NodeInfo]
-> TypeSpecAnalysis
-> m Type
tDirectType handle_sue_def :: Bool
handle_sue_def node :: NodeInfo
node ty_quals :: [CTypeQualifier NodeInfo]
ty_quals canonTySpec :: TypeSpecAnalysis
canonTySpec = do
    (quals :: TypeQuals
quals,attrs :: Attributes
attrs) <- [CTypeQualifier NodeInfo] -> m (TypeQuals, Attributes)
forall (m :: * -> *).
MonadTrav m =>
[CTypeQualifier NodeInfo] -> m (TypeQuals, Attributes)
tTypeQuals [CTypeQualifier NodeInfo]
ty_quals
    let baseType :: TypeName -> Type
baseType ty_name :: TypeName
ty_name = TypeName -> TypeQuals -> Attributes -> Type
DirectType TypeName
ty_name TypeQuals
quals Attributes
attrs
    case TypeSpecAnalysis
canonTySpec of
        TSNone -> 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 -> Type
baseType (IntType -> TypeName
TyIntegral IntType
TyInt)
        TSVoid -> 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 -> Type
baseType TypeName
TyVoid
        TSBool -> 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 -> Type
baseType (IntType -> TypeName
TyIntegral IntType
TyBool)
        TSNum tsnum :: NumTypeSpec
tsnum -> do
            Either (FloatType, Bool) IntType
numType <- NumTypeSpec -> m (Either (FloatType, Bool) IntType)
forall (m :: * -> *).
MonadCError m =>
NumTypeSpec -> m (Either (FloatType, Bool) IntType)
tNumType NumTypeSpec
tsnum
            Type -> m Type
forall (m :: * -> *) a. Monad m => a -> m a
return (Type -> m Type) -> (TypeName -> Type) -> TypeName -> m Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TypeName -> Type
baseType (TypeName -> m Type) -> TypeName -> m Type
forall a b. (a -> b) -> a -> b
$
                case Either (FloatType, Bool) IntType
numType of
                    Left (floatType :: FloatType
floatType,iscomplex :: Bool
iscomplex) | Bool
iscomplex -> FloatType -> TypeName
TyComplex FloatType
floatType
                                               | Bool
otherwise -> FloatType -> TypeName
TyFloating FloatType
floatType
                    Right intType :: IntType
intType  -> IntType -> TypeName
TyIntegral IntType
intType
        TSTypeDef tdr :: TypeDefRef
tdr -> 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
$ TypeDefRef -> TypeQuals -> Attributes -> Type
TypeDefType TypeDefRef
tdr TypeQuals
quals Attributes
attrs
        TSNonBasic (CSUType su :: CStructureUnion NodeInfo
su _tnode :: NodeInfo
_tnode)       -> (CompTypeRef -> Type) -> m CompTypeRef -> m Type
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (TypeName -> Type
baseType (TypeName -> Type)
-> (CompTypeRef -> TypeName) -> CompTypeRef -> Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CompTypeRef -> TypeName
TyComp) (m CompTypeRef -> m Type) -> m CompTypeRef -> m Type
forall a b. (a -> b) -> a -> b
$ Bool -> CStructureUnion NodeInfo -> m CompTypeRef
forall (m :: * -> *).
MonadTrav m =>
Bool -> CStructureUnion NodeInfo -> m CompTypeRef
tCompTypeDecl Bool
handle_sue_def CStructureUnion NodeInfo
su
        TSNonBasic (CEnumType enum :: CEnumeration NodeInfo
enum _tnode :: NodeInfo
_tnode)   -> (EnumTypeRef -> Type) -> m EnumTypeRef -> m Type
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (TypeName -> Type
baseType (TypeName -> Type)
-> (EnumTypeRef -> TypeName) -> EnumTypeRef -> Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. EnumTypeRef -> TypeName
TyEnum) (m EnumTypeRef -> m Type) -> m EnumTypeRef -> m Type
forall a b. (a -> b) -> a -> b
$ Bool -> CEnumeration NodeInfo -> m EnumTypeRef
forall (m :: * -> *).
MonadTrav m =>
Bool -> CEnumeration NodeInfo -> m EnumTypeRef
tEnumTypeDecl Bool
handle_sue_def CEnumeration NodeInfo
enum
        TSType t :: Type
t                             ->  NodeInfo -> TypeQuals -> Attributes -> Type -> m Type
forall (m :: * -> *).
MonadCError m =>
NodeInfo -> TypeQuals -> Attributes -> Type -> m Type
mergeTypeAttributes NodeInfo
node TypeQuals
quals Attributes
attrs Type
t
        TSNonBasic t :: CTypeSpecifier NodeInfo
t -> NodeInfo -> String -> m Type
forall (m :: * -> *) a. MonadCError m => NodeInfo -> String -> m a
astError NodeInfo
node ("Unexpected typespec: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ CTypeSpecifier NodeInfo -> String
forall a. Show a => a -> String
show CTypeSpecifier NodeInfo
t)

-- | Merge type attributes
--
-- This handles for example the form
--
-- > /* tyqual attr typeof(type) */
-- > const typeof(char volatile) x;
mergeTypeAttributes :: (MonadCError m) => NodeInfo -> TypeQuals -> [Attr] -> Type -> m Type
mergeTypeAttributes :: NodeInfo -> TypeQuals -> Attributes -> Type -> m Type
mergeTypeAttributes node_info :: NodeInfo
node_info quals :: TypeQuals
quals attrs :: Attributes
attrs typ :: Type
typ =
    case Type
typ of
        DirectType ty_name :: TypeName
ty_name quals' :: TypeQuals
quals' attrs' :: Attributes
attrs' -> TypeQuals
-> Attributes -> (TypeQuals -> Attributes -> Type) -> m Type
forall (m :: * -> *) a.
Monad m =>
TypeQuals -> Attributes -> (TypeQuals -> Attributes -> a) -> m a
merge TypeQuals
quals' Attributes
attrs' ((TypeQuals -> Attributes -> Type) -> m Type)
-> (TypeQuals -> Attributes -> Type) -> m Type
forall a b. (a -> b) -> a -> b
$ TypeName -> TypeQuals -> Attributes -> Type
DirectType TypeName
ty_name
        PtrType ty :: Type
ty quals' :: TypeQuals
quals' attrs' :: Attributes
attrs'  -> TypeQuals
-> Attributes -> (TypeQuals -> Attributes -> Type) -> m Type
forall (m :: * -> *) a.
Monad m =>
TypeQuals -> Attributes -> (TypeQuals -> Attributes -> a) -> m a
merge TypeQuals
quals' Attributes
attrs' ((TypeQuals -> Attributes -> Type) -> m Type)
-> (TypeQuals -> Attributes -> Type) -> m Type
forall a b. (a -> b) -> a -> b
$ Type -> TypeQuals -> Attributes -> Type
PtrType Type
ty
        ArrayType ty :: Type
ty array_sz :: ArraySize
array_sz quals' :: TypeQuals
quals' attrs' :: Attributes
attrs' -> TypeQuals
-> Attributes -> (TypeQuals -> Attributes -> Type) -> m Type
forall (m :: * -> *) a.
Monad m =>
TypeQuals -> Attributes -> (TypeQuals -> Attributes -> a) -> m a
merge TypeQuals
quals' Attributes
attrs' ((TypeQuals -> Attributes -> Type) -> m Type)
-> (TypeQuals -> Attributes -> Type) -> m Type
forall a b. (a -> b) -> a -> b
$ Type -> ArraySize -> TypeQuals -> Attributes -> Type
ArrayType Type
ty ArraySize
array_sz
        FunctionType fty :: FunType
fty attrs' :: Attributes
attrs'
             | TypeQuals
quals TypeQuals -> TypeQuals -> Bool
forall a. Eq a => a -> a -> Bool
/= TypeQuals
noTypeQuals -> NodeInfo -> String -> m Type
forall (m :: * -> *) a. MonadCError m => NodeInfo -> String -> m a
astError NodeInfo
node_info "type qualifiers for function type"
             | Bool
otherwise            -> 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
$ FunType -> Attributes -> Type
FunctionType FunType
fty (Attributes
attrs' Attributes -> Attributes -> Attributes
forall a. [a] -> [a] -> [a]
++ Attributes
attrs)
        TypeDefType tdr :: TypeDefRef
tdr quals' :: TypeQuals
quals' attrs' :: Attributes
attrs'
            -> TypeQuals
-> Attributes -> (TypeQuals -> Attributes -> Type) -> m Type
forall (m :: * -> *) a.
Monad m =>
TypeQuals -> Attributes -> (TypeQuals -> Attributes -> a) -> m a
merge TypeQuals
quals' Attributes
attrs' ((TypeQuals -> Attributes -> Type) -> m Type)
-> (TypeQuals -> Attributes -> Type) -> m Type
forall a b. (a -> b) -> a -> b
$ TypeDefRef -> TypeQuals -> Attributes -> Type
TypeDefType TypeDefRef
tdr
    where
    merge :: TypeQuals -> Attributes -> (TypeQuals -> Attributes -> a) -> m a
merge quals' :: TypeQuals
quals' attrs' :: Attributes
attrs' tyf :: TypeQuals -> Attributes -> a
tyf = a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> m a) -> a -> m a
forall a b. (a -> b) -> a -> b
$ TypeQuals -> Attributes -> a
tyf (TypeQuals -> TypeQuals -> TypeQuals
mergeTypeQuals TypeQuals
quals TypeQuals
quals') (Attributes
attrs' Attributes -> Attributes -> Attributes
forall a. [a] -> [a] -> [a]
++ Attributes
attrs)

typeDefRef :: (MonadCError m, MonadSymtab m) => NodeInfo -> Ident -> m TypeDefRef
typeDefRef :: NodeInfo -> Ident -> m TypeDefRef
typeDefRef t_node :: NodeInfo
t_node name :: Ident
name = Ident -> m Type
forall (m :: * -> *).
(MonadCError m, MonadSymtab m) =>
Ident -> m Type
lookupTypeDef Ident
name m Type -> (Type -> m TypeDefRef) -> m TypeDefRef
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \ty :: Type
ty -> TypeDefRef -> m TypeDefRef
forall (m :: * -> *) a. Monad m => a -> m a
return (Ident -> Type -> NodeInfo -> TypeDefRef
TypeDefRef Ident
name Type
ty NodeInfo
t_node)

-- extract a struct\/union
-- we emit @declStructUnion@ and @defStructUnion@ actions
--
-- TODO: should attributes be part of declarartions too ?
tCompTypeDecl :: (MonadTrav m) => Bool -> CStructUnion -> m CompTypeRef
tCompTypeDecl :: Bool -> CStructureUnion NodeInfo -> m CompTypeRef
tCompTypeDecl handle_def :: Bool
handle_def (CStruct tag :: CStructTag
tag ident_opt :: Maybe Ident
ident_opt member_decls_opt :: Maybe [CDecl]
member_decls_opt attrs :: [CAttribute NodeInfo]
attrs node_info :: NodeInfo
node_info) = do
    -- create reference
    SUERef
sue_ref <- NodeInfo -> Maybe Ident -> m SUERef
forall (m :: * -> *).
(MonadCError m, MonadSymtab m) =>
NodeInfo -> Maybe Ident -> m SUERef
createSUERef NodeInfo
node_info Maybe Ident
ident_opt
    let tag' :: CompTyKind
tag' = CStructTag -> CompTyKind
tTag CStructTag
tag
    Attributes
attrs' <- (CAttribute NodeInfo -> m Attr)
-> [CAttribute NodeInfo] -> m Attributes
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM CAttribute NodeInfo -> m Attr
forall (m :: * -> *).
(MonadCError m, MonadSymtab m) =>
CAttribute NodeInfo -> m Attr
tAttr [CAttribute NodeInfo]
attrs
    -- record tag name
    let decl :: CompTypeRef
decl = SUERef -> CompTyKind -> NodeInfo -> CompTypeRef
CompTypeRef SUERef
sue_ref CompTyKind
tag' NodeInfo
node_info
    TagFwdDecl -> m ()
forall (m :: * -> *).
(MonadCError m, MonadSymtab m) =>
TagFwdDecl -> m ()
handleTagDecl (CompTypeRef -> TagFwdDecl
CompDecl CompTypeRef
decl)
    -- when handle_def is true, enter the definition
    Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
handle_def (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
        Maybe [CDecl] -> ([CDecl] -> m ()) -> m ()
forall (m :: * -> *) a. Monad m => Maybe a -> (a -> m ()) -> m ()
maybeM Maybe [CDecl]
member_decls_opt (([CDecl] -> m ()) -> m ()) -> ([CDecl] -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \decls :: [CDecl]
decls ->
                SUERef
-> CompTyKind -> [CDecl] -> Attributes -> NodeInfo -> m CompType
forall (m :: * -> *).
MonadTrav m =>
SUERef
-> CompTyKind -> [CDecl] -> Attributes -> NodeInfo -> m CompType
tCompType SUERef
sue_ref CompTyKind
tag' [CDecl]
decls Attributes
attrs' NodeInfo
node_info
            m CompType -> (CompType -> m ()) -> m ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (TagDef -> m ()
forall (m :: * -> *). MonadTrav m => TagDef -> m ()
handleTagDef(TagDef -> m ()) -> (CompType -> TagDef) -> CompType -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
.CompType -> TagDef
CompDef)
    CompTypeRef -> m CompTypeRef
forall (m :: * -> *) a. Monad m => a -> m a
return CompTypeRef
decl

tTag :: CStructTag -> CompTyKind
tTag :: CStructTag -> CompTyKind
tTag CStructTag = CompTyKind
StructTag
tTag CUnionTag  = CompTyKind
UnionTag

tCompType :: (MonadTrav m) => SUERef -> CompTyKind -> [CDecl] -> Attributes -> NodeInfo -> m CompType
tCompType :: SUERef
-> CompTyKind -> [CDecl] -> Attributes -> NodeInfo -> m CompType
tCompType tag :: SUERef
tag sue_ref :: CompTyKind
sue_ref member_decls :: [CDecl]
member_decls attrs :: Attributes
attrs node :: NodeInfo
node
    = ([MemberDecl] -> Attributes -> NodeInfo -> CompType)
-> m ([MemberDecl] -> Attributes -> NodeInfo -> CompType)
forall (m :: * -> *) a. Monad m => a -> m a
return (SUERef
-> CompTyKind -> [MemberDecl] -> Attributes -> NodeInfo -> CompType
CompType SUERef
tag CompTyKind
sue_ref) m ([MemberDecl] -> Attributes -> NodeInfo -> CompType)
-> m [MemberDecl] -> m (Attributes -> NodeInfo -> CompType)
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
`ap`
        ((CDecl -> m [MemberDecl]) -> [CDecl] -> m [MemberDecl]
forall (m :: * -> *) a b. Monad m => (a -> m [b]) -> [a] -> m [b]
concatMapM CDecl -> m [MemberDecl]
forall (m :: * -> *). MonadTrav m => CDecl -> m [MemberDecl]
tMemberDecls [CDecl]
member_decls) m (Attributes -> NodeInfo -> CompType)
-> m Attributes -> m (NodeInfo -> CompType)
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
`ap`
        (Attributes -> m Attributes
forall (m :: * -> *) a. Monad m => a -> m a
return Attributes
attrs) m (NodeInfo -> CompType) -> m NodeInfo -> m CompType
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
`ap`
        (NodeInfo -> m NodeInfo
forall (m :: * -> *) a. Monad m => a -> m a
return NodeInfo
node)

-- | translate a enum type decl
--
--  > enum my_enum
--  > enum your_enum { x, y=3 }
--
tEnumTypeDecl :: (MonadTrav m) => Bool -> CEnum -> m EnumTypeRef
tEnumTypeDecl :: Bool -> CEnumeration NodeInfo -> m EnumTypeRef
tEnumTypeDecl handle_def :: Bool
handle_def (CEnum ident_opt :: Maybe Ident
ident_opt enumerators_opt :: Maybe [(Ident, Maybe (CExpression NodeInfo))]
enumerators_opt attrs :: [CAttribute NodeInfo]
attrs node_info :: NodeInfo
node_info)
    | (Nothing, Nothing) <- (Maybe Ident
ident_opt, Maybe [(Ident, Maybe (CExpression NodeInfo))]
enumerators_opt) = NodeInfo -> String -> m EnumTypeRef
forall (m :: * -> *) a. MonadCError m => NodeInfo -> String -> m a
astError NodeInfo
node_info "both definition and name of enum missing"
    | Just [] <- Maybe [(Ident, Maybe (CExpression NodeInfo))]
enumerators_opt                         = NodeInfo -> String -> m EnumTypeRef
forall (m :: * -> *) a. MonadCError m => NodeInfo -> String -> m a
astError NodeInfo
node_info "empty enumerator list"
    | Bool
otherwise
        = do SUERef
sue_ref <- NodeInfo -> Maybe Ident -> m SUERef
forall (m :: * -> *).
(MonadCError m, MonadSymtab m) =>
NodeInfo -> Maybe Ident -> m SUERef
createSUERef NodeInfo
node_info Maybe Ident
ident_opt
             Attributes
attrs' <- (CAttribute NodeInfo -> m Attr)
-> [CAttribute NodeInfo] -> m Attributes
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM CAttribute NodeInfo -> m Attr
forall (m :: * -> *).
(MonadCError m, MonadSymtab m) =>
CAttribute NodeInfo -> m Attr
tAttr [CAttribute NodeInfo]
attrs
             let decl :: EnumTypeRef
decl = SUERef -> NodeInfo -> EnumTypeRef
EnumTypeRef SUERef
sue_ref NodeInfo
node_info
             Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
handle_def (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
                 Maybe [(Ident, Maybe (CExpression NodeInfo))]
-> ([(Ident, Maybe (CExpression NodeInfo))] -> m ()) -> m ()
forall (m :: * -> *) a. Monad m => Maybe a -> (a -> m ()) -> m ()
maybeM Maybe [(Ident, Maybe (CExpression NodeInfo))]
enumerators_opt (([(Ident, Maybe (CExpression NodeInfo))] -> m ()) -> m ())
-> ([(Ident, Maybe (CExpression NodeInfo))] -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \enumerators :: [(Ident, Maybe (CExpression NodeInfo))]
enumerators ->
                         SUERef
-> [(Ident, Maybe (CExpression NodeInfo))]
-> Attributes
-> NodeInfo
-> m EnumType
forall (m :: * -> *).
(MonadCError m, MonadSymtab m) =>
SUERef
-> [(Ident, Maybe (CExpression NodeInfo))]
-> Attributes
-> NodeInfo
-> m EnumType
tEnumType SUERef
sue_ref [(Ident, Maybe (CExpression NodeInfo))]
enumerators Attributes
attrs' NodeInfo
node_info
                    m EnumType -> (EnumType -> m ()) -> m ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=  (TagDef -> m ()
forall (m :: * -> *). MonadTrav m => TagDef -> m ()
handleTagDef (TagDef -> m ()) -> (EnumType -> TagDef) -> EnumType -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. EnumType -> TagDef
EnumDef)
             EnumTypeRef -> m EnumTypeRef
forall (m :: * -> *) a. Monad m => a -> m a
return EnumTypeRef
decl

-- | translate and analyse an enumeration type
tEnumType :: (MonadCError m, MonadSymtab m) =>
             SUERef -> [(Ident, Maybe CExpr)] -> Attributes -> NodeInfo -> m EnumType
tEnumType :: SUERef
-> [(Ident, Maybe (CExpression NodeInfo))]
-> Attributes
-> NodeInfo
-> m EnumType
tEnumType sue_ref :: SUERef
sue_ref enumerators :: [(Ident, Maybe (CExpression NodeInfo))]
enumerators attrs :: Attributes
attrs node :: NodeInfo
node = do
    (Enumerator -> m ()) -> [Enumerator] -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Enumerator -> m ()
forall (m :: * -> *).
(MonadCError m, MonadSymtab m) =>
Enumerator -> m ()
handleEnumeratorDef [Enumerator]
enumerators'
    EnumType -> m EnumType
forall (m :: * -> *) a. Monad m => a -> m a
return EnumType
ty
    where
    ty :: EnumType
ty = SUERef -> [Enumerator] -> Attributes -> NodeInfo -> EnumType
EnumType SUERef
sue_ref [Enumerator]
enumerators' Attributes
attrs NodeInfo
node
    (_,enumerators' :: [Enumerator]
enumerators') = (Either Integer (CExpression NodeInfo, Integer)
 -> (Ident, Maybe (CExpression NodeInfo))
 -> (Either Integer (CExpression NodeInfo, Integer), Enumerator))
-> Either Integer (CExpression NodeInfo, Integer)
-> [(Ident, Maybe (CExpression NodeInfo))]
-> (Either Integer (CExpression NodeInfo, Integer), [Enumerator])
forall (t :: * -> *) a b c.
Traversable t =>
(a -> b -> (a, c)) -> a -> t b -> (a, t c)
mapAccumL Either Integer (CExpression NodeInfo, Integer)
-> (Ident, Maybe (CExpression NodeInfo))
-> (Either Integer (CExpression NodeInfo, Integer), Enumerator)
nextEnumerator (Integer -> Either Integer (CExpression NodeInfo, Integer)
forall a b. a -> Either a b
Left 0) [(Ident, Maybe (CExpression NodeInfo))]
enumerators
    nextEnumerator :: Either Integer (CExpression NodeInfo, Integer)
-> (Ident, Maybe (CExpression NodeInfo))
-> (Either Integer (CExpression NodeInfo, Integer), Enumerator)
nextEnumerator memo :: Either Integer (CExpression NodeInfo, Integer)
memo (ident :: Ident
ident,e :: Maybe (CExpression NodeInfo)
e) =
      let (memo' :: Either Integer (CExpression NodeInfo, Integer)
memo',expr :: CExpression NodeInfo
expr) = Either Integer (CExpression NodeInfo, Integer)
-> Maybe (CExpression NodeInfo)
-> (Either Integer (CExpression NodeInfo, Integer),
    CExpression NodeInfo)
nextEnrExpr Either Integer (CExpression NodeInfo, Integer)
memo Maybe (CExpression NodeInfo)
e in
      (Either Integer (CExpression NodeInfo, Integer)
memo', Ident -> CExpression NodeInfo -> EnumType -> NodeInfo -> Enumerator
Enumerator Ident
ident CExpression NodeInfo
expr EnumType
ty (Ident -> NodeInfo
forall a. CNode a => a -> NodeInfo
nodeInfo Ident
ident))
    nextEnrExpr :: Either Integer (Expr,Integer) -> Maybe CExpr -> (Either Integer (Expr,Integer), CExpr)
    nextEnrExpr :: Either Integer (CExpression NodeInfo, Integer)
-> Maybe (CExpression NodeInfo)
-> (Either Integer (CExpression NodeInfo, Integer),
    CExpression NodeInfo)
nextEnrExpr (Left i :: Integer
i) Nothing = (Integer -> Either Integer (CExpression NodeInfo, Integer)
forall a b. a -> Either a b
Left (Integer -> Integer
forall a. Enum a => a -> a
succ Integer
i), Integer -> CExpression NodeInfo
intExpr Integer
i)
    nextEnrExpr (Right (e :: CExpression NodeInfo
e,offs :: Integer
offs)) Nothing = ((CExpression NodeInfo, Integer)
-> Either Integer (CExpression NodeInfo, Integer)
forall a b. b -> Either a b
Right (CExpression NodeInfo
e, Integer -> Integer
forall a. Enum a => a -> a
succ Integer
offs), CExpression NodeInfo -> Integer -> CExpression NodeInfo
offsExpr CExpression NodeInfo
e Integer
offs)
    nextEnrExpr _ (Just e :: CExpression NodeInfo
e) = ((CExpression NodeInfo, Integer)
-> Either Integer (CExpression NodeInfo, Integer)
forall a b. b -> Either a b
Right (CExpression NodeInfo
e,1), CExpression NodeInfo
e)
    intExpr :: Integer -> CExpression NodeInfo
intExpr i :: Integer
i = CConstant NodeInfo -> CExpression NodeInfo
forall a. CConstant a -> CExpression a
CConst (CInteger -> NodeInfo -> CConstant NodeInfo
forall a. CInteger -> a -> CConstant a
CIntConst (Integer -> CInteger
cInteger Integer
i) NodeInfo
undefNode)
    offsExpr :: CExpression NodeInfo -> Integer -> CExpression NodeInfo
offsExpr e :: CExpression NodeInfo
e offs :: Integer
offs = CBinaryOp
-> CExpression NodeInfo
-> CExpression NodeInfo
-> NodeInfo
-> CExpression NodeInfo
forall a.
CBinaryOp -> CExpression a -> CExpression a -> a -> CExpression a
CBinary CBinaryOp
CAddOp CExpression NodeInfo
e (Integer -> CExpression NodeInfo
intExpr Integer
offs) NodeInfo
undefNode

-- | Mapping from num type specs to C types (C99 6.7.2-2), ignoring the complex qualifier.
tNumType :: (MonadCError m) => NumTypeSpec -> m (Either (FloatType,Bool) IntType)
tNumType :: NumTypeSpec -> m (Either (FloatType, Bool) IntType)
tNumType (NumTypeSpec basetype :: NumBaseType
basetype sgn :: SignSpec
sgn sz :: SizeMod
sz iscomplex :: Bool
iscomplex) =
    case (NumBaseType
basetype,SignSpec
sgn,SizeMod
sz) of
        (BaseChar,_,NoSizeMod)      | SignSpec
Signed <- SignSpec
sgn   -> IntType -> m (Either (FloatType, Bool) IntType)
forall b a. b -> m (Either a b)
intType IntType
TySChar
                                    | SignSpec
Unsigned <- SignSpec
sgn -> IntType -> m (Either (FloatType, Bool) IntType)
forall b a. b -> m (Either a b)
intType IntType
TyUChar
                                    | Bool
otherwise       -> IntType -> m (Either (FloatType, Bool) IntType)
forall b a. b -> m (Either a b)
intType IntType
TyChar
        (intbase :: NumBaseType
intbase, _, NoSizeMod)  | NumBaseType -> NumBaseType -> Bool
optBase NumBaseType
BaseInt NumBaseType
intbase ->
            IntType -> m (Either (FloatType, Bool) IntType)
forall b a. b -> m (Either a b)
intType(IntType -> m (Either (FloatType, Bool) IntType))
-> IntType -> m (Either (FloatType, Bool) IntType)
forall a b. (a -> b) -> a -> b
$ case SignSpec
sgn of
                            Unsigned -> IntType
TyUInt
                            _        -> IntType
TyInt
        (intbase :: NumBaseType
intbase, _, NoSizeMod)  | NumBaseType -> NumBaseType -> Bool
optBase NumBaseType
BaseInt128 NumBaseType
intbase ->
            IntType -> m (Either (FloatType, Bool) IntType)
forall b a. b -> m (Either a b)
intType(IntType -> m (Either (FloatType, Bool) IntType))
-> IntType -> m (Either (FloatType, Bool) IntType)
forall a b. (a -> b) -> a -> b
$ case SignSpec
sgn of
                            Unsigned -> IntType
TyUInt128
                            _        -> IntType
TyInt128
        (intbase :: NumBaseType
intbase, signed :: SignSpec
signed, sizemod :: SizeMod
sizemod)    | NumBaseType -> NumBaseType -> Bool
optBase NumBaseType
BaseInt NumBaseType
intbase, SignSpec -> SignSpec -> Bool
optSign SignSpec
Signed SignSpec
signed ->
            IntType -> m (Either (FloatType, Bool) IntType)
forall b a. b -> m (Either a b)
intType(IntType -> m (Either (FloatType, Bool) IntType))
-> IntType -> m (Either (FloatType, Bool) IntType)
forall a b. (a -> b) -> a -> b
$ case SizeMod
sizemod of ShortMod    -> IntType
TyShort
                                     LongMod     -> IntType
TyLong
                                     LongLongMod -> IntType
TyLLong
                                     _ -> String -> IntType
forall a. String -> a
internalErr "numTypeMapping: unexpected pattern matching error"
        (intbase :: NumBaseType
intbase, Unsigned, sizemod :: SizeMod
sizemod) | NumBaseType -> NumBaseType -> Bool
optBase NumBaseType
BaseInt NumBaseType
intbase ->
            IntType -> m (Either (FloatType, Bool) IntType)
forall b a. b -> m (Either a b)
intType(IntType -> m (Either (FloatType, Bool) IntType))
-> IntType -> m (Either (FloatType, Bool) IntType)
forall a b. (a -> b) -> a -> b
$ case SizeMod
sizemod of ShortMod    -> IntType
TyUShort
                                     LongMod     -> IntType
TyULong
                                     LongLongMod -> IntType
TyULLong
                                     _ -> String -> IntType
forall a. String -> a
internalErr "numTypeMapping: unexpected pattern matching error"
        (BaseFloat, NoSignSpec, NoSizeMod)  -> FloatType -> m (Either (FloatType, Bool) IntType)
forall (m :: * -> *) a b. Monad m => a -> m (Either (a, Bool) b)
floatType FloatType
TyFloat
        (BaseDouble, NoSignSpec, NoSizeMod) -> FloatType -> m (Either (FloatType, Bool) IntType)
forall (m :: * -> *) a b. Monad m => a -> m (Either (a, Bool) b)
floatType FloatType
TyDouble
        (BaseDouble, NoSignSpec, LongMod)   -> FloatType -> m (Either (FloatType, Bool) IntType)
forall (m :: * -> *) a b. Monad m => a -> m (Either (a, Bool) b)
floatType FloatType
TyLDouble
        (BaseFloatN n :: Int
n x :: Bool
x, NoSignSpec, NoSizeMod) -> FloatType -> m (Either (FloatType, Bool) IntType)
forall (m :: * -> *) a b. Monad m => a -> m (Either (a, Bool) b)
floatType (Int -> Bool -> FloatType
TyFloatN Int
n Bool
x)
        -- TODO: error analysis
        (_,_,_)   -> String -> m (Either (FloatType, Bool) IntType)
forall a. HasCallStack => String -> a
error "Bad AST analysis"
    where
    optBase :: NumBaseType -> NumBaseType -> Bool
optBase _ NoBaseType = Bool
True
    optBase expect :: NumBaseType
expect baseTy :: NumBaseType
baseTy = NumBaseType
expect NumBaseType -> NumBaseType -> Bool
forall a. Eq a => a -> a -> Bool
== NumBaseType
baseTy
    optSign :: SignSpec -> SignSpec -> Bool
optSign _ NoSignSpec = Bool
True
    optSign expect :: SignSpec
expect sign :: SignSpec
sign = SignSpec
expect SignSpec -> SignSpec -> Bool
forall a. Eq a => a -> a -> Bool
== SignSpec
sign
    intType :: b -> m (Either a b)
intType = Either a b -> m (Either a b)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either a b -> m (Either a b))
-> (b -> Either a b) -> b -> m (Either a b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. b -> Either a b
forall a b. b -> Either a b
Right
    floatType :: a -> m (Either (a, Bool) b)
floatType ft :: a
ft = Either (a, Bool) b -> m (Either (a, Bool) b)
forall (m :: * -> *) a. Monad m => a -> m a
return ((a, Bool) -> Either (a, Bool) b
forall a b. a -> Either a b
Left (a
ft,Bool
iscomplex))

-- TODO: currently bogus
tArraySize :: (MonadTrav m) => CArrSize -> m ArraySize
tArraySize :: CArraySize NodeInfo -> m ArraySize
tArraySize (CNoArrSize False) = ArraySize -> m ArraySize
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> ArraySize
UnknownArraySize Bool
False)
tArraySize (CNoArrSize True) = ArraySize -> m ArraySize
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> ArraySize
UnknownArraySize Bool
True)
tArraySize (CArrSize static :: Bool
static szexpr :: CExpression NodeInfo
szexpr) = (CExpression NodeInfo -> ArraySize)
-> m (CExpression NodeInfo) -> m ArraySize
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (Bool -> CExpression NodeInfo -> ArraySize
ArraySize Bool
static) (CExpression NodeInfo -> m (CExpression NodeInfo)
forall (m :: * -> *) a. Monad m => a -> m a
return CExpression NodeInfo
szexpr)

tTypeQuals :: (MonadTrav m) => [CTypeQual] -> m (TypeQuals,Attributes)
tTypeQuals :: [CTypeQualifier NodeInfo] -> m (TypeQuals, Attributes)
tTypeQuals = (CTypeQualifier NodeInfo
 -> (TypeQuals, Attributes) -> m (TypeQuals, Attributes))
-> (TypeQuals, Attributes)
-> [CTypeQualifier NodeInfo]
-> m (TypeQuals, Attributes)
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> b -> m b) -> b -> t a -> m b
foldrM CTypeQualifier NodeInfo
-> (TypeQuals, Attributes) -> m (TypeQuals, Attributes)
forall (m :: * -> *).
(MonadCError m, MonadSymtab m) =>
CTypeQualifier NodeInfo
-> (TypeQuals, Attributes) -> m (TypeQuals, Attributes)
go (TypeQuals
noTypeQuals,[]) where
    go :: CTypeQualifier NodeInfo
-> (TypeQuals, Attributes) -> m (TypeQuals, Attributes)
go (CConstQual _) (tq :: TypeQuals
tq,attrs :: Attributes
attrs) = (TypeQuals, Attributes) -> m (TypeQuals, Attributes)
forall (m :: * -> *) a. Monad m => a -> m a
return (TypeQuals
tq { constant :: Bool
constant = Bool
True },Attributes
attrs)
    go (CVolatQual _) (tq :: TypeQuals
tq,attrs :: Attributes
attrs) = (TypeQuals, Attributes) -> m (TypeQuals, Attributes)
forall (m :: * -> *) a. Monad m => a -> m a
return (TypeQuals
tq { volatile :: Bool
volatile = Bool
True },Attributes
attrs)
    go (CRestrQual _) (tq :: TypeQuals
tq,attrs :: Attributes
attrs) = (TypeQuals, Attributes) -> m (TypeQuals, Attributes)
forall (m :: * -> *) a. Monad m => a -> m a
return (TypeQuals
tq { restrict :: Bool
restrict = Bool
True },Attributes
attrs)
    go (CAtomicQual _) (tq :: TypeQuals
tq,attrs :: Attributes
attrs) = (TypeQuals, Attributes) -> m (TypeQuals, Attributes)
forall (m :: * -> *) a. Monad m => a -> m a
return (TypeQuals
tq { atomic :: Bool
atomic = Bool
True },Attributes
attrs)
    go (CAttrQual attr :: CAttribute NodeInfo
attr) (tq :: TypeQuals
tq,attrs :: Attributes
attrs) = (Attr -> (TypeQuals, Attributes))
-> m Attr -> m (TypeQuals, Attributes)
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (\attr' :: Attr
attr' -> (TypeQuals
tq,Attr
attr'Attr -> Attributes -> Attributes
forall a. a -> [a] -> [a]
:Attributes
attrs)) (CAttribute NodeInfo -> m Attr
forall (m :: * -> *).
(MonadCError m, MonadSymtab m) =>
CAttribute NodeInfo -> m Attr
tAttr CAttribute NodeInfo
attr)
    go (CNullableQual _) (tq :: TypeQuals
tq,attrs :: Attributes
attrs) = (TypeQuals, Attributes) -> m (TypeQuals, Attributes)
forall (m :: * -> *) a. Monad m => a -> m a
return (TypeQuals
tq { nullable :: Bool
nullable = Bool
True }, Attributes
attrs)
    go (CNonnullQual _) (tq :: TypeQuals
tq,attrs :: Attributes
attrs) = (TypeQuals, Attributes) -> m (TypeQuals, Attributes)
forall (m :: * -> *) a. Monad m => a -> m a
return (TypeQuals
tq { nonnull :: Bool
nonnull = Bool
True }, Attributes
attrs)
    go (CClRdOnlyQual _) (tq :: TypeQuals
tq,attrs :: Attributes
attrs) = (TypeQuals, Attributes) -> m (TypeQuals, Attributes)
forall (m :: * -> *) a. Monad m => a -> m a
return (TypeQuals
tq { clrdonly :: Bool
clrdonly = Bool
True },Attributes
attrs)
    go (CClWrOnlyQual _) (tq :: TypeQuals
tq,attrs :: Attributes
attrs) = (TypeQuals, Attributes) -> m (TypeQuals, Attributes)
forall (m :: * -> *) a. Monad m => a -> m a
return (TypeQuals
tq { clwronly :: Bool
clwronly = Bool
True },Attributes
attrs)

-- * analysis


{-
To canoicalize type specifiers, we define a canonical form:
void | bool | (char|int|int128|float|double|floatNx)? (signed|unsigned)? (long long?)? complex? | othertype
-}
data NumBaseType = NoBaseType | BaseChar | BaseInt | BaseInt128 | BaseFloat |
                   BaseFloatN Int Bool | BaseDouble deriving (NumBaseType -> NumBaseType -> Bool
(NumBaseType -> NumBaseType -> Bool)
-> (NumBaseType -> NumBaseType -> Bool) -> Eq NumBaseType
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: NumBaseType -> NumBaseType -> Bool
$c/= :: NumBaseType -> NumBaseType -> Bool
== :: NumBaseType -> NumBaseType -> Bool
$c== :: NumBaseType -> NumBaseType -> Bool
Eq,Eq NumBaseType
Eq NumBaseType =>
(NumBaseType -> NumBaseType -> Ordering)
-> (NumBaseType -> NumBaseType -> Bool)
-> (NumBaseType -> NumBaseType -> Bool)
-> (NumBaseType -> NumBaseType -> Bool)
-> (NumBaseType -> NumBaseType -> Bool)
-> (NumBaseType -> NumBaseType -> NumBaseType)
-> (NumBaseType -> NumBaseType -> NumBaseType)
-> Ord NumBaseType
NumBaseType -> NumBaseType -> Bool
NumBaseType -> NumBaseType -> Ordering
NumBaseType -> NumBaseType -> NumBaseType
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: NumBaseType -> NumBaseType -> NumBaseType
$cmin :: NumBaseType -> NumBaseType -> NumBaseType
max :: NumBaseType -> NumBaseType -> NumBaseType
$cmax :: NumBaseType -> NumBaseType -> NumBaseType
>= :: NumBaseType -> NumBaseType -> Bool
$c>= :: NumBaseType -> NumBaseType -> Bool
> :: NumBaseType -> NumBaseType -> Bool
$c> :: NumBaseType -> NumBaseType -> Bool
<= :: NumBaseType -> NumBaseType -> Bool
$c<= :: NumBaseType -> NumBaseType -> Bool
< :: NumBaseType -> NumBaseType -> Bool
$c< :: NumBaseType -> NumBaseType -> Bool
compare :: NumBaseType -> NumBaseType -> Ordering
$ccompare :: NumBaseType -> NumBaseType -> Ordering
$cp1Ord :: Eq NumBaseType
Ord)
data SignSpec    = NoSignSpec | Signed | Unsigned deriving (SignSpec -> SignSpec -> Bool
(SignSpec -> SignSpec -> Bool)
-> (SignSpec -> SignSpec -> Bool) -> Eq SignSpec
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: SignSpec -> SignSpec -> Bool
$c/= :: SignSpec -> SignSpec -> Bool
== :: SignSpec -> SignSpec -> Bool
$c== :: SignSpec -> SignSpec -> Bool
Eq,Eq SignSpec
Eq SignSpec =>
(SignSpec -> SignSpec -> Ordering)
-> (SignSpec -> SignSpec -> Bool)
-> (SignSpec -> SignSpec -> Bool)
-> (SignSpec -> SignSpec -> Bool)
-> (SignSpec -> SignSpec -> Bool)
-> (SignSpec -> SignSpec -> SignSpec)
-> (SignSpec -> SignSpec -> SignSpec)
-> Ord SignSpec
SignSpec -> SignSpec -> Bool
SignSpec -> SignSpec -> Ordering
SignSpec -> SignSpec -> SignSpec
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: SignSpec -> SignSpec -> SignSpec
$cmin :: SignSpec -> SignSpec -> SignSpec
max :: SignSpec -> SignSpec -> SignSpec
$cmax :: SignSpec -> SignSpec -> SignSpec
>= :: SignSpec -> SignSpec -> Bool
$c>= :: SignSpec -> SignSpec -> Bool
> :: SignSpec -> SignSpec -> Bool
$c> :: SignSpec -> SignSpec -> Bool
<= :: SignSpec -> SignSpec -> Bool
$c<= :: SignSpec -> SignSpec -> Bool
< :: SignSpec -> SignSpec -> Bool
$c< :: SignSpec -> SignSpec -> Bool
compare :: SignSpec -> SignSpec -> Ordering
$ccompare :: SignSpec -> SignSpec -> Ordering
$cp1Ord :: Eq SignSpec
Ord)
data SizeMod     = NoSizeMod | ShortMod | LongMod | LongLongMod deriving (SizeMod -> SizeMod -> Bool
(SizeMod -> SizeMod -> Bool)
-> (SizeMod -> SizeMod -> Bool) -> Eq SizeMod
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: SizeMod -> SizeMod -> Bool
$c/= :: SizeMod -> SizeMod -> Bool
== :: SizeMod -> SizeMod -> Bool
$c== :: SizeMod -> SizeMod -> Bool
Eq,Eq SizeMod
Eq SizeMod =>
(SizeMod -> SizeMod -> Ordering)
-> (SizeMod -> SizeMod -> Bool)
-> (SizeMod -> SizeMod -> Bool)
-> (SizeMod -> SizeMod -> Bool)
-> (SizeMod -> SizeMod -> Bool)
-> (SizeMod -> SizeMod -> SizeMod)
-> (SizeMod -> SizeMod -> SizeMod)
-> Ord SizeMod
SizeMod -> SizeMod -> Bool
SizeMod -> SizeMod -> Ordering
SizeMod -> SizeMod -> SizeMod
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: SizeMod -> SizeMod -> SizeMod
$cmin :: SizeMod -> SizeMod -> SizeMod
max :: SizeMod -> SizeMod -> SizeMod
$cmax :: SizeMod -> SizeMod -> SizeMod
>= :: SizeMod -> SizeMod -> Bool
$c>= :: SizeMod -> SizeMod -> Bool
> :: SizeMod -> SizeMod -> Bool
$c> :: SizeMod -> SizeMod -> Bool
<= :: SizeMod -> SizeMod -> Bool
$c<= :: SizeMod -> SizeMod -> Bool
< :: SizeMod -> SizeMod -> Bool
$c< :: SizeMod -> SizeMod -> Bool
compare :: SizeMod -> SizeMod -> Ordering
$ccompare :: SizeMod -> SizeMod -> Ordering
$cp1Ord :: Eq SizeMod
Ord)
data NumTypeSpec = NumTypeSpec { NumTypeSpec -> NumBaseType
base :: NumBaseType, NumTypeSpec -> SignSpec
signSpec :: SignSpec, NumTypeSpec -> SizeMod
sizeMod :: SizeMod, NumTypeSpec -> Bool
isComplex :: Bool  }
emptyNumTypeSpec :: NumTypeSpec
emptyNumTypeSpec :: NumTypeSpec
emptyNumTypeSpec = NumTypeSpec :: NumBaseType -> SignSpec -> SizeMod -> Bool -> NumTypeSpec
NumTypeSpec { base :: NumBaseType
base = NumBaseType
NoBaseType, signSpec :: SignSpec
signSpec = SignSpec
NoSignSpec, sizeMod :: SizeMod
sizeMod = SizeMod
NoSizeMod, isComplex :: Bool
isComplex = Bool
False }
data TypeSpecAnalysis =
  TSNone | TSVoid | TSBool | TSNum NumTypeSpec |
  TSTypeDef TypeDefRef | TSType Type | TSNonBasic CTypeSpec

canonicalTypeSpec :: (MonadTrav m) => [CTypeSpec] -> m TypeSpecAnalysis
canonicalTypeSpec :: [CTypeSpecifier NodeInfo] -> m TypeSpecAnalysis
canonicalTypeSpec = (CTypeSpecifier NodeInfo -> TypeSpecAnalysis -> m TypeSpecAnalysis)
-> TypeSpecAnalysis
-> [CTypeSpecifier NodeInfo]
-> m TypeSpecAnalysis
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> b -> m b) -> b -> t a -> m b
foldrM CTypeSpecifier NodeInfo -> TypeSpecAnalysis -> m TypeSpecAnalysis
forall (m :: * -> *).
MonadTrav m =>
CTypeSpecifier NodeInfo -> TypeSpecAnalysis -> m TypeSpecAnalysis
go TypeSpecAnalysis
TSNone where
    getNTS :: TypeSpecAnalysis -> Maybe NumTypeSpec
getNTS TSNone = NumTypeSpec -> Maybe NumTypeSpec
forall a. a -> Maybe a
Just NumTypeSpec
emptyNumTypeSpec
    getNTS (TSNum nts :: NumTypeSpec
nts) = NumTypeSpec -> Maybe NumTypeSpec
forall a. a -> Maybe a
Just NumTypeSpec
nts
    getNTS _ = Maybe NumTypeSpec
forall a. Maybe a
Nothing
    updLongMod :: SizeMod -> Maybe SizeMod
updLongMod NoSizeMod = SizeMod -> Maybe SizeMod
forall a. a -> Maybe a
Just SizeMod
LongMod
    updLongMod LongMod   = SizeMod -> Maybe SizeMod
forall a. a -> Maybe a
Just SizeMod
LongLongMod
    updLongMod _         = Maybe SizeMod
forall a. Maybe a
Nothing
    go :: (MonadTrav m) => CTypeSpec -> TypeSpecAnalysis -> m TypeSpecAnalysis
    go :: CTypeSpecifier NodeInfo -> TypeSpecAnalysis -> m TypeSpecAnalysis
go (CVoidType _)    TSNone = TypeSpecAnalysis -> m TypeSpecAnalysis
forall (m :: * -> *) a. Monad m => a -> m a
return TypeSpecAnalysis
TSVoid
    go (CBoolType _)    TSNone = TypeSpecAnalysis -> m TypeSpecAnalysis
forall (m :: * -> *) a. Monad m => a -> m a
return TypeSpecAnalysis
TSBool
    go (CCharType _)    tsa :: TypeSpecAnalysis
tsa | (Just nts :: NumTypeSpec
nts@(NumTypeSpec { base :: NumTypeSpec -> NumBaseType
base = NumBaseType
NoBaseType })) <- TypeSpecAnalysis -> Maybe NumTypeSpec
getNTS TypeSpecAnalysis
tsa
                            = TypeSpecAnalysis -> m TypeSpecAnalysis
forall (m :: * -> *) a. Monad m => a -> m a
return(TypeSpecAnalysis -> m TypeSpecAnalysis)
-> TypeSpecAnalysis -> m TypeSpecAnalysis
forall a b. (a -> b) -> a -> b
$  NumTypeSpec -> TypeSpecAnalysis
TSNum(NumTypeSpec -> TypeSpecAnalysis)
-> NumTypeSpec -> TypeSpecAnalysis
forall a b. (a -> b) -> a -> b
$ NumTypeSpec
nts { base :: NumBaseType
base = NumBaseType
BaseChar }
    go (CIntType _)     tsa :: TypeSpecAnalysis
tsa | (Just nts :: NumTypeSpec
nts@(NumTypeSpec { base :: NumTypeSpec -> NumBaseType
base = NumBaseType
NoBaseType })) <- TypeSpecAnalysis -> Maybe NumTypeSpec
getNTS TypeSpecAnalysis
tsa
                            = TypeSpecAnalysis -> m TypeSpecAnalysis
forall (m :: * -> *) a. Monad m => a -> m a
return(TypeSpecAnalysis -> m TypeSpecAnalysis)
-> TypeSpecAnalysis -> m TypeSpecAnalysis
forall a b. (a -> b) -> a -> b
$  NumTypeSpec -> TypeSpecAnalysis
TSNum(NumTypeSpec -> TypeSpecAnalysis)
-> NumTypeSpec -> TypeSpecAnalysis
forall a b. (a -> b) -> a -> b
$ NumTypeSpec
nts { base :: NumBaseType
base = NumBaseType
BaseInt }
    go (CInt128Type _)  tsa :: TypeSpecAnalysis
tsa | (Just nts :: NumTypeSpec
nts@(NumTypeSpec { base :: NumTypeSpec -> NumBaseType
base = NumBaseType
NoBaseType })) <- TypeSpecAnalysis -> Maybe NumTypeSpec
getNTS TypeSpecAnalysis
tsa
                            = TypeSpecAnalysis -> m TypeSpecAnalysis
forall (m :: * -> *) a. Monad m => a -> m a
return(TypeSpecAnalysis -> m TypeSpecAnalysis)
-> TypeSpecAnalysis -> m TypeSpecAnalysis
forall a b. (a -> b) -> a -> b
$  NumTypeSpec -> TypeSpecAnalysis
TSNum(NumTypeSpec -> TypeSpecAnalysis)
-> NumTypeSpec -> TypeSpecAnalysis
forall a b. (a -> b) -> a -> b
$ NumTypeSpec
nts { base :: NumBaseType
base = NumBaseType
BaseInt128 }
    go (CFloatType _)   tsa :: TypeSpecAnalysis
tsa | (Just nts :: NumTypeSpec
nts@(NumTypeSpec { base :: NumTypeSpec -> NumBaseType
base = NumBaseType
NoBaseType })) <- TypeSpecAnalysis -> Maybe NumTypeSpec
getNTS TypeSpecAnalysis
tsa
                            = TypeSpecAnalysis -> m TypeSpecAnalysis
forall (m :: * -> *) a. Monad m => a -> m a
return(TypeSpecAnalysis -> m TypeSpecAnalysis)
-> TypeSpecAnalysis -> m TypeSpecAnalysis
forall a b. (a -> b) -> a -> b
$  NumTypeSpec -> TypeSpecAnalysis
TSNum(NumTypeSpec -> TypeSpecAnalysis)
-> NumTypeSpec -> TypeSpecAnalysis
forall a b. (a -> b) -> a -> b
$ NumTypeSpec
nts { base :: NumBaseType
base = NumBaseType
BaseFloat }
    go (CFloatNType n :: Int
n x :: Bool
x _) tsa :: TypeSpecAnalysis
tsa | (Just nts :: NumTypeSpec
nts@(NumTypeSpec { base :: NumTypeSpec -> NumBaseType
base = NumBaseType
NoBaseType })) <- TypeSpecAnalysis -> Maybe NumTypeSpec
getNTS TypeSpecAnalysis
tsa
                            = TypeSpecAnalysis -> m TypeSpecAnalysis
forall (m :: * -> *) a. Monad m => a -> m a
return(TypeSpecAnalysis -> m TypeSpecAnalysis)
-> TypeSpecAnalysis -> m TypeSpecAnalysis
forall a b. (a -> b) -> a -> b
$  NumTypeSpec -> TypeSpecAnalysis
TSNum(NumTypeSpec -> TypeSpecAnalysis)
-> NumTypeSpec -> TypeSpecAnalysis
forall a b. (a -> b) -> a -> b
$ NumTypeSpec
nts { base :: NumBaseType
base = Int -> Bool -> NumBaseType
BaseFloatN Int
n Bool
x }
    go (CDoubleType _)  tsa :: TypeSpecAnalysis
tsa | (Just nts :: NumTypeSpec
nts@(NumTypeSpec { base :: NumTypeSpec -> NumBaseType
base = NumBaseType
NoBaseType })) <- TypeSpecAnalysis -> Maybe NumTypeSpec
getNTS TypeSpecAnalysis
tsa
                            = TypeSpecAnalysis -> m TypeSpecAnalysis
forall (m :: * -> *) a. Monad m => a -> m a
return(TypeSpecAnalysis -> m TypeSpecAnalysis)
-> TypeSpecAnalysis -> m TypeSpecAnalysis
forall a b. (a -> b) -> a -> b
$  NumTypeSpec -> TypeSpecAnalysis
TSNum(NumTypeSpec -> TypeSpecAnalysis)
-> NumTypeSpec -> TypeSpecAnalysis
forall a b. (a -> b) -> a -> b
$ NumTypeSpec
nts { base :: NumBaseType
base = NumBaseType
BaseDouble }
    go (CShortType _)   tsa :: TypeSpecAnalysis
tsa | (Just nts :: NumTypeSpec
nts@(NumTypeSpec { sizeMod :: NumTypeSpec -> SizeMod
sizeMod = SizeMod
NoSizeMod })) <- TypeSpecAnalysis -> Maybe NumTypeSpec
getNTS TypeSpecAnalysis
tsa
                            = TypeSpecAnalysis -> m TypeSpecAnalysis
forall (m :: * -> *) a. Monad m => a -> m a
return(TypeSpecAnalysis -> m TypeSpecAnalysis)
-> TypeSpecAnalysis -> m TypeSpecAnalysis
forall a b. (a -> b) -> a -> b
$  NumTypeSpec -> TypeSpecAnalysis
TSNum(NumTypeSpec -> TypeSpecAnalysis)
-> NumTypeSpec -> TypeSpecAnalysis
forall a b. (a -> b) -> a -> b
$NumTypeSpec
nts { sizeMod :: SizeMod
sizeMod = SizeMod
ShortMod }
    go (CLongType _)    tsa :: TypeSpecAnalysis
tsa | (Just nts :: NumTypeSpec
nts@(NumTypeSpec { sizeMod :: NumTypeSpec -> SizeMod
sizeMod = SizeMod
szMod })) <- TypeSpecAnalysis -> Maybe NumTypeSpec
getNTS TypeSpecAnalysis
tsa,
                              (Just szMod' :: SizeMod
szMod') <- SizeMod -> Maybe SizeMod
updLongMod SizeMod
szMod
                            = TypeSpecAnalysis -> m TypeSpecAnalysis
forall (m :: * -> *) a. Monad m => a -> m a
return(TypeSpecAnalysis -> m TypeSpecAnalysis)
-> TypeSpecAnalysis -> m TypeSpecAnalysis
forall a b. (a -> b) -> a -> b
$  NumTypeSpec -> TypeSpecAnalysis
TSNum(NumTypeSpec -> TypeSpecAnalysis)
-> NumTypeSpec -> TypeSpecAnalysis
forall a b. (a -> b) -> a -> b
$ NumTypeSpec
nts { sizeMod :: SizeMod
sizeMod = SizeMod
szMod' }
    go (CSignedType _)  tsa :: TypeSpecAnalysis
tsa | (Just nts :: NumTypeSpec
nts@(NumTypeSpec { signSpec :: NumTypeSpec -> SignSpec
signSpec = SignSpec
NoSignSpec })) <- TypeSpecAnalysis -> Maybe NumTypeSpec
getNTS TypeSpecAnalysis
tsa
                            = TypeSpecAnalysis -> m TypeSpecAnalysis
forall (m :: * -> *) a. Monad m => a -> m a
return(TypeSpecAnalysis -> m TypeSpecAnalysis)
-> TypeSpecAnalysis -> m TypeSpecAnalysis
forall a b. (a -> b) -> a -> b
$  NumTypeSpec -> TypeSpecAnalysis
TSNum(NumTypeSpec -> TypeSpecAnalysis)
-> NumTypeSpec -> TypeSpecAnalysis
forall a b. (a -> b) -> a -> b
$ NumTypeSpec
nts { signSpec :: SignSpec
signSpec = SignSpec
Signed }
    go (CUnsigType _)   tsa :: TypeSpecAnalysis
tsa | (Just nts :: NumTypeSpec
nts@(NumTypeSpec { signSpec :: NumTypeSpec -> SignSpec
signSpec = SignSpec
NoSignSpec })) <- TypeSpecAnalysis -> Maybe NumTypeSpec
getNTS TypeSpecAnalysis
tsa
                            = TypeSpecAnalysis -> m TypeSpecAnalysis
forall (m :: * -> *) a. Monad m => a -> m a
return(TypeSpecAnalysis -> m TypeSpecAnalysis)
-> TypeSpecAnalysis -> m TypeSpecAnalysis
forall a b. (a -> b) -> a -> b
$  NumTypeSpec -> TypeSpecAnalysis
TSNum(NumTypeSpec -> TypeSpecAnalysis)
-> NumTypeSpec -> TypeSpecAnalysis
forall a b. (a -> b) -> a -> b
$ NumTypeSpec
nts { signSpec :: SignSpec
signSpec = SignSpec
Unsigned }
    go (CComplexType _) tsa :: TypeSpecAnalysis
tsa | (Just nts :: NumTypeSpec
nts@(NumTypeSpec { isComplex :: NumTypeSpec -> Bool
isComplex = Bool
False })) <- TypeSpecAnalysis -> Maybe NumTypeSpec
getNTS TypeSpecAnalysis
tsa
                            = TypeSpecAnalysis -> m TypeSpecAnalysis
forall (m :: * -> *) a. Monad m => a -> m a
return(TypeSpecAnalysis -> m TypeSpecAnalysis)
-> TypeSpecAnalysis -> m TypeSpecAnalysis
forall a b. (a -> b) -> a -> b
$  NumTypeSpec -> TypeSpecAnalysis
TSNum(NumTypeSpec -> TypeSpecAnalysis)
-> NumTypeSpec -> TypeSpecAnalysis
forall a b. (a -> b) -> a -> b
$ NumTypeSpec
nts { isComplex :: Bool
isComplex = Bool
True }
    go (CTypeDef i :: Ident
i ni :: NodeInfo
ni) TSNone = (TypeDefRef -> TypeSpecAnalysis)
-> m TypeDefRef -> m TypeSpecAnalysis
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM TypeDefRef -> TypeSpecAnalysis
TSTypeDef (m TypeDefRef -> m TypeSpecAnalysis)
-> m TypeDefRef -> m TypeSpecAnalysis
forall a b. (a -> b) -> a -> b
$ NodeInfo -> Ident -> m TypeDefRef
forall (m :: * -> *).
(MonadCError m, MonadSymtab m) =>
NodeInfo -> Ident -> m TypeDefRef
typeDefRef NodeInfo
ni Ident
i
    go (CTypeOfType d :: CDecl
d _ni :: NodeInfo
_ni) TSNone = (Type -> TypeSpecAnalysis) -> m Type -> m TypeSpecAnalysis
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM Type -> TypeSpecAnalysis
TSType (m Type -> m TypeSpecAnalysis) -> m Type -> m TypeSpecAnalysis
forall a b. (a -> b) -> a -> b
$ CDecl -> m Type
forall (m :: * -> *). MonadTrav m => CDecl -> m Type
analyseTypeDecl CDecl
d
    go (CTypeOfExpr e :: CExpression NodeInfo
e _) TSNone = (Type -> TypeSpecAnalysis) -> m Type -> m TypeSpecAnalysis
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM Type -> TypeSpecAnalysis
TSType (m Type -> m TypeSpecAnalysis) -> m Type -> m TypeSpecAnalysis
forall a b. (a -> b) -> a -> b
$ [StmtCtx] -> ExprSide -> CExpression NodeInfo -> m Type
forall (m :: * -> *).
MonadTrav m =>
[StmtCtx] -> ExprSide -> CExpression NodeInfo -> m Type
tExpr [] ExprSide
RValue CExpression NodeInfo
e
    -- todo: atomic qualifier discarded
    go (CAtomicType d :: CDecl
d _ni :: NodeInfo
_ni) TSNone = (Type -> TypeSpecAnalysis) -> m Type -> m TypeSpecAnalysis
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM Type -> TypeSpecAnalysis
TSType (m Type -> m TypeSpecAnalysis) -> m Type -> m TypeSpecAnalysis
forall a b. (a -> b) -> a -> b
$ CDecl -> m Type
forall (m :: * -> *). MonadTrav m => CDecl -> m Type
analyseTypeDecl CDecl
d
    go otherType :: CTypeSpecifier NodeInfo
otherType  TSNone    = TypeSpecAnalysis -> m TypeSpecAnalysis
forall (m :: * -> *) a. Monad m => a -> m a
return(TypeSpecAnalysis -> m TypeSpecAnalysis)
-> TypeSpecAnalysis -> m TypeSpecAnalysis
forall a b. (a -> b) -> a -> b
$  CTypeSpecifier NodeInfo -> TypeSpecAnalysis
TSNonBasic CTypeSpecifier NodeInfo
otherType
    go ty :: CTypeSpecifier NodeInfo
ty _ts :: TypeSpecAnalysis
_ts = NodeInfo -> String -> m TypeSpecAnalysis
forall (m :: * -> *) a. MonadCError m => NodeInfo -> String -> m a
astError (CTypeSpecifier NodeInfo -> NodeInfo
forall a. CNode a => a -> NodeInfo
nodeInfo CTypeSpecifier NodeInfo
ty) "Invalid type specifier"

-- compute storage given storage specifiers
canonicalStorageSpec :: (MonadCError m) =>[CStorageSpec] -> m StorageSpec
canonicalStorageSpec :: [CStorageSpecifier NodeInfo] -> m StorageSpec
canonicalStorageSpec storagespecs :: [CStorageSpecifier NodeInfo]
storagespecs = (StorageSpec -> StorageSpec) -> m StorageSpec -> m StorageSpec
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM StorageSpec -> StorageSpec
elideAuto (m StorageSpec -> m StorageSpec) -> m StorageSpec -> m StorageSpec
forall a b. (a -> b) -> a -> b
$ (CStorageSpecifier NodeInfo -> StorageSpec -> m StorageSpec)
-> StorageSpec -> [CStorageSpecifier NodeInfo] -> m StorageSpec
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> b -> m b) -> b -> t a -> m b
foldrM CStorageSpecifier NodeInfo -> StorageSpec -> m StorageSpec
forall (m :: * -> *) a.
(MonadCError m, CNode a, Pretty (CStorageSpecifier a)) =>
CStorageSpecifier a -> StorageSpec -> m StorageSpec
updStorage StorageSpec
NoStorageSpec [CStorageSpecifier NodeInfo]
storagespecs where
        updStorage :: CStorageSpecifier a -> StorageSpec -> m StorageSpec
updStorage (CAuto _) NoStorageSpec     = StorageSpec -> m StorageSpec
forall (m :: * -> *) a. Monad m => a -> m a
return StorageSpec
AutoSpec
        updStorage (CRegister _) NoStorageSpec = StorageSpec -> m StorageSpec
forall (m :: * -> *) a. Monad m => a -> m a
return StorageSpec
RegSpec
        updStorage (CThread _) NoStorageSpec   = StorageSpec -> m StorageSpec
forall (m :: * -> *) a. Monad m => a -> m a
return StorageSpec
ThreadSpec
        updStorage (CClKernel _) NoStorageSpec = StorageSpec -> m StorageSpec
forall (m :: * -> *) a. Monad m => a -> m a
return StorageSpec
ClKernelSpec
        updStorage (CClGlobal _) NoStorageSpec = StorageSpec -> m StorageSpec
forall (m :: * -> *) a. Monad m => a -> m a
return StorageSpec
ClGlobalSpec
        updStorage (CClLocal  _) NoStorageSpec = StorageSpec -> m StorageSpec
forall (m :: * -> *) a. Monad m => a -> m a
return StorageSpec
ClLocalSpec
        updStorage (CThread _) (StaticSpec _)  = StorageSpec -> m StorageSpec
forall (m :: * -> *) a. Monad m => a -> m a
return(StorageSpec -> m StorageSpec) -> StorageSpec -> m StorageSpec
forall a b. (a -> b) -> a -> b
$ Bool -> StorageSpec
StaticSpec Bool
True
        updStorage (CThread _) (ExternSpec _)  = StorageSpec -> m StorageSpec
forall (m :: * -> *) a. Monad m => a -> m a
return(StorageSpec -> m StorageSpec) -> StorageSpec -> m StorageSpec
forall a b. (a -> b) -> a -> b
$ Bool -> StorageSpec
ExternSpec Bool
True
        updStorage (CStatic _) NoStorageSpec   = StorageSpec -> m StorageSpec
forall (m :: * -> *) a. Monad m => a -> m a
return(StorageSpec -> m StorageSpec) -> StorageSpec -> m StorageSpec
forall a b. (a -> b) -> a -> b
$ Bool -> StorageSpec
StaticSpec Bool
False
        updStorage (CExtern _) NoStorageSpec   = StorageSpec -> m StorageSpec
forall (m :: * -> *) a. Monad m => a -> m a
return(StorageSpec -> m StorageSpec) -> StorageSpec -> m StorageSpec
forall a b. (a -> b) -> a -> b
$ Bool -> StorageSpec
ExternSpec Bool
False
        updStorage (CStatic _) ThreadSpec      = StorageSpec -> m StorageSpec
forall (m :: * -> *) a. Monad m => a -> m a
return(StorageSpec -> m StorageSpec) -> StorageSpec -> m StorageSpec
forall a b. (a -> b) -> a -> b
$ Bool -> StorageSpec
StaticSpec Bool
True
        updStorage (CExtern _) ThreadSpec      = StorageSpec -> m StorageSpec
forall (m :: * -> *) a. Monad m => a -> m a
return(StorageSpec -> m StorageSpec) -> StorageSpec -> m StorageSpec
forall a b. (a -> b) -> a -> b
$ Bool -> StorageSpec
ExternSpec Bool
True
        updStorage badSpec :: CStorageSpecifier a
badSpec old :: StorageSpec
old
            = NodeInfo -> String -> m StorageSpec
forall (m :: * -> *) a. MonadCError m => NodeInfo -> String -> m a
astError (CStorageSpecifier a -> NodeInfo
forall a. CNode a => a -> NodeInfo
nodeInfo CStorageSpecifier a
badSpec) (String -> m StorageSpec) -> String -> m StorageSpec
forall a b. (a -> b) -> a -> b
$ "Invalid storage specifier "String -> String -> String
forall a. [a] -> [a] -> [a]
++Doc -> String
render (CStorageSpecifier a -> Doc
forall p. Pretty p => p -> Doc
pretty CStorageSpecifier a
badSpec)String -> String -> String
forall a. [a] -> [a] -> [a]
++" in combination with "String -> String -> String
forall a. [a] -> [a] -> [a]
++StorageSpec -> String
forall a. Show a => a -> String
show StorageSpec
old
        elideAuto :: StorageSpec -> StorageSpec
elideAuto AutoSpec = StorageSpec
NoStorageSpec
        elideAuto spec :: StorageSpec
spec = StorageSpec
spec

-- | convert old style parameters
--
-- This requires matching parameter names and declarations, as in the following example:
--
-- > int f(d,c,a,b)
-- > char a,*b;
-- > int c;
-- > { }
--
-- is converted to
--
-- > int f(int d, int c, char a, char* b)
--
-- TODO: This could be moved to syntax, as it operates on the AST only
mergeOldStyle :: (MonadCError m) => NodeInfo -> [CDecl] -> [CDerivedDeclr] -> m [CDerivedDeclr]
mergeOldStyle :: NodeInfo -> [CDecl] -> [CDerivedDeclr] -> m [CDerivedDeclr]
mergeOldStyle _node :: NodeInfo
_node [] declrs :: [CDerivedDeclr]
declrs = [CDerivedDeclr] -> m [CDerivedDeclr]
forall (m :: * -> *) a. Monad m => a -> m a
return [CDerivedDeclr]
declrs
mergeOldStyle node :: NodeInfo
node oldstyle_params :: [CDecl]
oldstyle_params (CFunDeclr params :: Either [Ident] ([CDecl], Bool)
params attrs :: [CAttribute NodeInfo]
attrs fdnode :: NodeInfo
fdnode : dds :: [CDerivedDeclr]
dds) =
    case Either [Ident] ([CDecl], Bool)
params of
        Left list :: [Ident]
list -> do
            -- FIXME: This translation doesn't work in the following example
            -- [| int f(b,a) struct x { }; int b,a; { struct x local; return local.x } |]
            [CDecl]
oldstyle_params' <- ([[CDecl]] -> [CDecl]) -> m [[CDecl]] -> m [CDecl]
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM [[CDecl]] -> [CDecl]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (m [[CDecl]] -> m [CDecl]) -> m [[CDecl]] -> m [CDecl]
forall a b. (a -> b) -> a -> b
$ (CDecl -> m [CDecl]) -> [CDecl] -> m [[CDecl]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM CDecl -> m [CDecl]
forall (m :: * -> *). MonadCError m => CDecl -> m [CDecl]
splitCDecl [CDecl]
oldstyle_params
            Map Ident CDecl
param_map <- ([(Ident, CDecl)] -> Map Ident CDecl)
-> m [(Ident, CDecl)] -> m (Map Ident CDecl)
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM [(Ident, CDecl)] -> Map Ident CDecl
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList (m [(Ident, CDecl)] -> m (Map Ident CDecl))
-> m [(Ident, CDecl)] -> m (Map Ident CDecl)
forall a b. (a -> b) -> a -> b
$ (CDecl -> m (Ident, CDecl)) -> [CDecl] -> m [(Ident, CDecl)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM CDecl -> m (Ident, CDecl)
forall (m :: * -> *). MonadCError m => CDecl -> m (Ident, CDecl)
attachNameOfDecl [CDecl]
oldstyle_params'
            (newstyle_params :: [CDecl]
newstyle_params,param_map' :: Map Ident CDecl
param_map') <- (Ident
 -> ([CDecl], Map Ident CDecl) -> m ([CDecl], Map Ident CDecl))
-> ([CDecl], Map Ident CDecl)
-> [Ident]
-> m ([CDecl], Map Ident CDecl)
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> b -> m b) -> b -> t a -> m b
foldrM Ident -> ([CDecl], Map Ident CDecl) -> m ([CDecl], Map Ident CDecl)
forall (m :: * -> *).
Monad m =>
Ident -> ([CDecl], Map Ident CDecl) -> m ([CDecl], Map Ident CDecl)
insertParamDecl ([],Map Ident CDecl
param_map) [Ident]
list
            Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Map Ident CDecl -> Bool
forall k a. Map k a -> Bool
Map.null Map Ident CDecl
param_map') (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
              NodeInfo -> String -> m ()
forall (m :: * -> *) a. MonadCError m => NodeInfo -> String -> m a
astError NodeInfo
node (String -> m ()) -> String -> m ()
forall a b. (a -> b) -> a -> b
$ "declarations for parameter(s) "String -> String -> String
forall a. [a] -> [a] -> [a]
++ Map Ident CDecl -> String
forall a. Map Ident a -> String
showParamMap Map Ident CDecl
param_map' String -> String -> String
forall a. [a] -> [a] -> [a]
++" but no such parameter"
            [CDerivedDeclr] -> m [CDerivedDeclr]
forall (m :: * -> *) a. Monad m => a -> m a
return (Either [Ident] ([CDecl], Bool)
-> [CAttribute NodeInfo] -> NodeInfo -> CDerivedDeclr
forall a.
Either [Ident] ([CDeclaration a], Bool)
-> [CAttribute a] -> a -> CDerivedDeclarator a
CFunDeclr (([CDecl], Bool) -> Either [Ident] ([CDecl], Bool)
forall a b. b -> Either a b
Right ([CDecl]
newstyle_params, Bool
False)) [CAttribute NodeInfo]
attrs NodeInfo
fdnode CDerivedDeclr -> [CDerivedDeclr] -> [CDerivedDeclr]
forall a. a -> [a] -> [a]
: [CDerivedDeclr]
dds)
        Right _newstyle :: ([CDecl], Bool)
_newstyle -> NodeInfo -> String -> m [CDerivedDeclr]
forall (m :: * -> *) a. MonadCError m => NodeInfo -> String -> m a
astError NodeInfo
node "oldstyle parameter list, but newstyle function declaration"
    where
        attachNameOfDecl :: CDecl -> m (Ident, CDecl)
attachNameOfDecl decl :: CDecl
decl = CDecl -> m Ident
forall (m :: * -> *). MonadCError m => CDecl -> m Ident
nameOfDecl CDecl
decl m Ident -> (Ident -> m (Ident, CDecl)) -> m (Ident, CDecl)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \n :: Ident
n -> (Ident, CDecl) -> m (Ident, CDecl)
forall (m :: * -> *) a. Monad m => a -> m a
return (Ident
n,CDecl
decl)
        insertParamDecl :: Ident -> ([CDecl], Map Ident CDecl) -> m ([CDecl], Map Ident CDecl)
insertParamDecl param_name :: Ident
param_name (ps :: [CDecl]
ps, param_map :: Map Ident CDecl
param_map)
            = case Ident -> Map Ident CDecl -> Maybe CDecl
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Ident
param_name Map Ident CDecl
param_map of
                Just p :: CDecl
p -> ([CDecl], Map Ident CDecl) -> m ([CDecl], Map Ident CDecl)
forall (m :: * -> *) a. Monad m => a -> m a
return (CDecl
pCDecl -> [CDecl] -> [CDecl]
forall a. a -> [a] -> [a]
:[CDecl]
ps, Ident -> Map Ident CDecl -> Map Ident CDecl
forall k a. Ord k => k -> Map k a -> Map k a
Map.delete Ident
param_name Map Ident CDecl
param_map)
                Nothing -> ([CDecl], Map Ident CDecl) -> m ([CDecl], Map Ident CDecl)
forall (m :: * -> *) a. Monad m => a -> m a
return (Ident -> CDecl
implicitIntParam Ident
param_name CDecl -> [CDecl] -> [CDecl]
forall a. a -> [a] -> [a]
: [CDecl]
ps, Map Ident CDecl
param_map)
        implicitIntParam :: Ident -> CDecl
implicitIntParam param_name :: Ident
param_name =
            let nInfo :: NodeInfo
nInfo = Ident -> NodeInfo
forall a. CNode a => a -> NodeInfo
nodeInfo Ident
param_name in
            [CDeclarationSpecifier NodeInfo]
-> [(Maybe (CDeclarator NodeInfo), Maybe (CInitializer NodeInfo),
     Maybe (CExpression NodeInfo))]
-> NodeInfo
-> CDecl
forall a.
[CDeclarationSpecifier a]
-> [(Maybe (CDeclarator a), Maybe (CInitializer a),
     Maybe (CExpression a))]
-> a
-> CDeclaration a
CDecl [CTypeSpecifier NodeInfo -> CDeclarationSpecifier NodeInfo
forall a. CTypeSpecifier a -> CDeclarationSpecifier a
CTypeSpec (NodeInfo -> CTypeSpecifier NodeInfo
forall a. a -> CTypeSpecifier a
CIntType NodeInfo
nInfo)] [(CDeclarator NodeInfo -> Maybe (CDeclarator NodeInfo)
forall a. a -> Maybe a
Just (Maybe Ident
-> [CDerivedDeclr]
-> Maybe (CStringLiteral NodeInfo)
-> [CAttribute NodeInfo]
-> NodeInfo
-> CDeclarator NodeInfo
forall a.
Maybe Ident
-> [CDerivedDeclarator a]
-> Maybe (CStringLiteral a)
-> [CAttribute a]
-> a
-> CDeclarator a
CDeclr (Ident -> Maybe Ident
forall a. a -> Maybe a
Just Ident
param_name) [] Maybe (CStringLiteral NodeInfo)
forall a. Maybe a
Nothing [] NodeInfo
nInfo),Maybe (CInitializer NodeInfo)
forall a. Maybe a
Nothing,Maybe (CExpression NodeInfo)
forall a. Maybe a
Nothing)] NodeInfo
nInfo
        showParamMap :: Map Ident a -> String
showParamMap = String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate ", " ([String] -> String)
-> (Map Ident a -> [String]) -> Map Ident a -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Ident -> String) -> [Ident] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Ident -> String
identToString ([Ident] -> [String])
-> (Map Ident a -> [Ident]) -> Map Ident a -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map Ident a -> [Ident]
forall k a. Map k a -> [k]
Map.keys
mergeOldStyle node :: NodeInfo
node _ _ = NodeInfo -> String -> m [CDerivedDeclr]
forall (m :: * -> *) a. MonadCError m => NodeInfo -> String -> m a
astError NodeInfo
node "oldstyle parameter list, but not function type"

-- | split a CDecl into declarators, hereby eliding SUE defs from the second declarator on.
--
--   There are several reasons why this isn't the preferred way for handling multiple-declarator declarations,
--   but it can be convinient some times.
--
-- > splitCDecl [d| struct x { int z; } a,*b; |]
-- > [ [d| struct x { int z; } a, struct x *b; |] ]
--
-- /TODO/: This could be moved to syntax, as it operates on the AST only
splitCDecl :: (MonadCError m) => CDecl -> m [CDecl]
splitCDecl :: CDecl -> m [CDecl]
splitCDecl decl :: CDecl
decl@(CStaticAssert _ _ _) = [CDecl] -> m [CDecl]
forall (m :: * -> *) a. Monad m => a -> m a
return [CDecl
decl]
splitCDecl decl :: CDecl
decl@(CDecl declspecs :: [CDeclarationSpecifier NodeInfo]
declspecs declrs :: [(Maybe (CDeclarator NodeInfo), Maybe (CInitializer NodeInfo),
  Maybe (CExpression NodeInfo))]
declrs node :: NodeInfo
node) =
    case [(Maybe (CDeclarator NodeInfo), Maybe (CInitializer NodeInfo),
  Maybe (CExpression NodeInfo))]
declrs of
        []      -> String -> m [CDecl]
forall a. String -> a
internalErr "splitCDecl applied to empty declaration"
        -- single declarator, not need to split
        [_declr :: (Maybe (CDeclarator NodeInfo), Maybe (CInitializer NodeInfo),
 Maybe (CExpression NodeInfo))
_declr] -> [CDecl] -> m [CDecl]
forall (m :: * -> *) a. Monad m => a -> m a
return [CDecl
decl]
        -- more than one declarator
        (d1 :: (Maybe (CDeclarator NodeInfo), Maybe (CInitializer NodeInfo),
 Maybe (CExpression NodeInfo))
d1:ds :: [(Maybe (CDeclarator NodeInfo), Maybe (CInitializer NodeInfo),
  Maybe (CExpression NodeInfo))]
ds) ->
            let declspecs' :: [CDeclarationSpecifier NodeInfo]
declspecs' = (CDeclarationSpecifier NodeInfo -> CDeclarationSpecifier NodeInfo)
-> [CDeclarationSpecifier NodeInfo]
-> [CDeclarationSpecifier NodeInfo]
forall a b. (a -> b) -> [a] -> [b]
map CDeclarationSpecifier NodeInfo -> CDeclarationSpecifier NodeInfo
forall a. CDeclarationSpecifier a -> CDeclarationSpecifier a
elideSUEDef [CDeclarationSpecifier NodeInfo]
declspecs in
            [CDecl] -> m [CDecl]
forall (m :: * -> *) a. Monad m => a -> m a
return([CDecl] -> m [CDecl]) -> [CDecl] -> m [CDecl]
forall a b. (a -> b) -> a -> b
$ ([CDeclarationSpecifier NodeInfo]
-> [(Maybe (CDeclarator NodeInfo), Maybe (CInitializer NodeInfo),
     Maybe (CExpression NodeInfo))]
-> NodeInfo
-> CDecl
forall a.
[CDeclarationSpecifier a]
-> [(Maybe (CDeclarator a), Maybe (CInitializer a),
     Maybe (CExpression a))]
-> a
-> CDeclaration a
CDecl [CDeclarationSpecifier NodeInfo]
declspecs [(Maybe (CDeclarator NodeInfo), Maybe (CInitializer NodeInfo),
 Maybe (CExpression NodeInfo))
d1] NodeInfo
node) CDecl -> [CDecl] -> [CDecl]
forall a. a -> [a] -> [a]
: [ [CDeclarationSpecifier NodeInfo]
-> [(Maybe (CDeclarator NodeInfo), Maybe (CInitializer NodeInfo),
     Maybe (CExpression NodeInfo))]
-> NodeInfo
-> CDecl
forall a.
[CDeclarationSpecifier a]
-> [(Maybe (CDeclarator a), Maybe (CInitializer a),
     Maybe (CExpression a))]
-> a
-> CDeclaration a
CDecl [CDeclarationSpecifier NodeInfo]
declspecs' [(Maybe (CDeclarator NodeInfo), Maybe (CInitializer NodeInfo),
 Maybe (CExpression NodeInfo))
declr] NodeInfo
node | (Maybe (CDeclarator NodeInfo), Maybe (CInitializer NodeInfo),
 Maybe (CExpression NodeInfo))
declr <- [(Maybe (CDeclarator NodeInfo), Maybe (CInitializer NodeInfo),
  Maybe (CExpression NodeInfo))]
ds ]
    where
    elideSUEDef :: CDeclarationSpecifier a -> CDeclarationSpecifier a
elideSUEDef declspec :: CDeclarationSpecifier a
declspec@(CTypeSpec tyspec :: CTypeSpecifier a
tyspec) =
        case CTypeSpecifier a
tyspec of
            (CEnumType (CEnum name :: Maybe Ident
name _def :: Maybe [(Ident, Maybe (CExpression a))]
_def _attrs :: [CAttribute a]
_attrs enum_node :: a
enum_node) node_info :: a
node_info) ->
                CTypeSpecifier a -> CDeclarationSpecifier a
forall a. CTypeSpecifier a -> CDeclarationSpecifier a
CTypeSpec (CEnumeration a -> a -> CTypeSpecifier a
forall a. CEnumeration a -> a -> CTypeSpecifier a
CEnumType (Maybe Ident
-> Maybe [(Ident, Maybe (CExpression a))]
-> [CAttribute a]
-> a
-> CEnumeration a
forall a.
Maybe Ident
-> Maybe [(Ident, Maybe (CExpression a))]
-> [CAttribute a]
-> a
-> CEnumeration a
CEnum Maybe Ident
name Maybe [(Ident, Maybe (CExpression a))]
forall a. Maybe a
Nothing [] a
enum_node) a
node_info)
            (CSUType (CStruct tag :: CStructTag
tag name :: Maybe Ident
name _def :: Maybe [CDeclaration a]
_def _attrs :: [CAttribute a]
_attrs su_node :: a
su_node) node_info :: a
node_info) ->
                CTypeSpecifier a -> CDeclarationSpecifier a
forall a. CTypeSpecifier a -> CDeclarationSpecifier a
CTypeSpec (CStructureUnion a -> a -> CTypeSpecifier a
forall a. CStructureUnion a -> a -> CTypeSpecifier a
CSUType (CStructTag
-> Maybe Ident
-> Maybe [CDeclaration a]
-> [CAttribute a]
-> a
-> CStructureUnion a
forall a.
CStructTag
-> Maybe Ident
-> Maybe [CDeclaration a]
-> [CAttribute a]
-> a
-> CStructureUnion a
CStruct CStructTag
tag Maybe Ident
name Maybe [CDeclaration a]
forall a. Maybe a
Nothing [] a
su_node) a
node_info)
            _ -> CDeclarationSpecifier a
declspec
    elideSUEDef declspec :: CDeclarationSpecifier a
declspec = CDeclarationSpecifier a
declspec


-- | translate @__attribute__@ annotations
-- TODO: This is a unwrap and wrap stub
tAttr :: (MonadCError m, MonadSymtab m) => CAttr -> m Attr
tAttr :: CAttribute NodeInfo -> m Attr
tAttr (CAttr name :: Ident
name cexpr :: [CExpression NodeInfo]
cexpr node :: NodeInfo
node) = Attr -> m Attr
forall (m :: * -> *) a. Monad m => a -> m a
return(Attr -> m Attr) -> Attr -> m Attr
forall a b. (a -> b) -> a -> b
$ Ident -> [CExpression NodeInfo] -> NodeInfo -> Attr
Attr Ident
name [CExpression NodeInfo]
cexpr NodeInfo
node


-- | construct a name for a variable
-- TODO: more or less bogus
mkVarName :: (MonadCError m, MonadSymtab m) =>
             NodeInfo -> Maybe Ident -> Maybe AsmName -> m VarName
mkVarName :: NodeInfo
-> Maybe Ident -> Maybe (CStringLiteral NodeInfo) -> m VarName
mkVarName  _node :: NodeInfo
_node Nothing _ = VarName -> m VarName
forall (m :: * -> *) a. Monad m => a -> m a
return VarName
NoName
mkVarName  _node :: NodeInfo
_node (Just n :: Ident
n) asm :: Maybe (CStringLiteral NodeInfo)
asm = VarName -> m VarName
forall (m :: * -> *) a. Monad m => a -> m a
return (VarName -> m VarName) -> VarName -> m VarName
forall a b. (a -> b) -> a -> b
$ Ident -> Maybe (CStringLiteral NodeInfo) -> VarName
VarName Ident
n Maybe (CStringLiteral NodeInfo)
asm

-- helpers
nameOfDecl :: (MonadCError m) => CDecl -> m Ident
nameOfDecl :: CDecl -> m Ident
nameOfDecl d :: CDecl
d = CDecl -> m (CDeclarator NodeInfo)
forall (m :: * -> *).
MonadCError m =>
CDecl -> m (CDeclarator NodeInfo)
getOnlyDeclr CDecl
d m (CDeclarator NodeInfo)
-> (CDeclarator NodeInfo -> m Ident) -> m Ident
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \declr :: CDeclarator NodeInfo
declr ->
    case CDeclarator NodeInfo
declr of
        (CDeclr (Just name :: Ident
name) _ _ _ _node :: NodeInfo
_node) -> Ident -> m Ident
forall (m :: * -> *) a. Monad m => a -> m a
return Ident
name
        (CDeclr Nothing _ _ _ _node :: NodeInfo
_node)     -> String -> m Ident
forall a. String -> a
internalErr "nameOfDecl: abstract declarator"
emptyDeclr :: NodeInfo -> CDeclr
emptyDeclr :: NodeInfo -> CDeclarator NodeInfo
emptyDeclr node :: NodeInfo
node = Maybe Ident
-> [CDerivedDeclr]
-> Maybe (CStringLiteral NodeInfo)
-> [CAttribute NodeInfo]
-> NodeInfo
-> CDeclarator NodeInfo
forall a.
Maybe Ident
-> [CDerivedDeclarator a]
-> Maybe (CStringLiteral a)
-> [CAttribute a]
-> a
-> CDeclarator a
CDeclr Maybe Ident
forall a. Maybe a
Nothing [] Maybe (CStringLiteral NodeInfo)
forall a. Maybe a
Nothing [] NodeInfo
node
getOnlyDeclr :: (MonadCError m) => CDecl -> m CDeclr
getOnlyDeclr :: CDecl -> m (CDeclarator NodeInfo)
getOnlyDeclr (CDecl _ [(Just declr :: CDeclarator NodeInfo
declr,_,_)] _) = CDeclarator NodeInfo -> m (CDeclarator NodeInfo)
forall (m :: * -> *) a. Monad m => a -> m a
return CDeclarator NodeInfo
declr
getOnlyDeclr (CDecl _ _ _node :: NodeInfo
_node) = String -> m (CDeclarator NodeInfo)
forall a. String -> a
internalErr "getOnlyDeclr: declaration doesn't have a unique declarator"
getOnlyDeclr (CStaticAssert _ _ _) = String -> m (CDeclarator NodeInfo)
forall a. String -> a
internalErr "getOnlyDeclr: static assertion doesn't have a unique declarator"