{-# 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 :: forall (m :: * -> *). MonadTrav m => CDecl -> m ParamDecl
tParamDecl (CStaticAssert CExpression NodeInfo
_ CStringLiteral NodeInfo
_ NodeInfo
node) =
  forall (m :: * -> *) a. MonadCError m => NodeInfo -> String -> m a
astError NodeInfo
node String
"expected parameter, not static assertion"
tParamDecl (CDecl [CDeclarationSpecifier NodeInfo]
declspecs [(Maybe (CDeclarator NodeInfo), Maybe (CInitializer NodeInfo),
  Maybe (CExpression NodeInfo))]
declrs NodeInfo
node) =
  do CDeclarator NodeInfo
declr <- m (CDeclarator NodeInfo)
getParamDeclr
     -- analyse the variable declaration
     (VarDeclInfo VarName
name FunctionAttrs
fun_spec  StorageSpec
storage_spec Attributes
attrs Type
ty NodeInfo
declr_node) <- forall (m :: * -> *).
MonadTrav m =>
Bool
-> [CDeclarationSpecifier NodeInfo]
-> CDeclarator NodeInfo
-> [CDecl]
-> Maybe (CInitializer NodeInfo)
-> m VarDeclInfo
analyseVarDecl' Bool
True [CDeclarationSpecifier NodeInfo]
declspecs CDeclarator NodeInfo
declr [] forall a. Maybe a
Nothing
     forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (FunctionAttrs -> Bool
isInline FunctionAttrs
fun_spec Bool -> Bool -> Bool
|| FunctionAttrs -> Bool
isNoreturn FunctionAttrs
fun_spec) forall a b. (a -> b) -> a -> b
$
       forall (m :: * -> *) e a. (MonadCError m, Error e) => e -> m a
throwTravError (NodeInfo -> String -> BadSpecifierError
badSpecifierError NodeInfo
node String
"parameter declaration with function specifier")
     -- compute storage of parameter (NoStorage, but might have a register specifier)
     Storage
storage <- forall (m :: * -> *) e a.
(MonadCError m, Error e) =>
Either e a -> m a
throwOnLeft 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
     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
          [] -> forall (m :: * -> *) a. Monad m => a -> m a
return (NodeInfo -> CDeclarator NodeInfo
emptyDeclr NodeInfo
node)
          [(Just CDeclarator NodeInfo
declr,Maybe (CInitializer NodeInfo)
Nothing,Maybe (CExpression NodeInfo)
Nothing)] -> forall (m :: * -> *) a. Monad m => a -> m a
return CDeclarator NodeInfo
declr
          [(Maybe (CDeclarator NodeInfo), Maybe (CInitializer NodeInfo),
  Maybe (CExpression NodeInfo))]
_ -> forall (m :: * -> *) a. MonadCError m => NodeInfo -> String -> m a
astError NodeInfo
node String
"bad parameter declaration: multiple decls / bitfield or initializer present"
  mkParamDecl :: VarName -> Storage -> Attributes -> Type -> NodeInfo -> ParamDecl
mkParamDecl VarName
name Storage
storage Attributes
attrs Type
ty 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
      VarName
NoName -> VarDecl -> NodeInfo -> ParamDecl
AbstractParamDecl VarDecl
vd NodeInfo
declr_node
      VarName
_ -> 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 NodeInfo
_ StorageSpec
NoStorageSpec = forall a b. b -> Either a b
Right (Bool -> Storage
Auto Bool
False)
computeParamStorage NodeInfo
_ StorageSpec
RegSpec       = forall a b. b -> Either a b
Right (Bool -> Storage
Auto Bool
True)
computeParamStorage NodeInfo
_ StorageSpec
ClGlobalSpec  = forall a b. b -> Either a b
Right (Linkage -> Bool -> Storage
Static Linkage
NoLinkage Bool
False)
computeParamStorage NodeInfo
_ StorageSpec
ClLocalSpec   = forall a b. b -> Either a b
Right (Linkage -> Bool -> Storage
Static Linkage
NoLinkage Bool
True)
computeParamStorage NodeInfo
node StorageSpec
spec       = forall a b. a -> Either a b
Left forall b c a. (b -> c) -> (a -> b) -> a -> c
. NodeInfo -> String -> BadSpecifierError
badSpecifierError NodeInfo
node forall a b. (a -> b) -> a -> b
$ String
"Bad storage specified for parameter: " forall a. [a] -> [a] -> [a]
++ 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 :: forall (m :: * -> *). MonadTrav m => CDecl -> m [MemberDecl]
tMemberDecls (CStaticAssert CExpression NodeInfo
_ CStringLiteral NodeInfo
_ NodeInfo
node) =
  forall (m :: * -> *) a. MonadCError m => NodeInfo -> String -> m a
astError NodeInfo
node String
"expected struct or union member, found static assertion"
tMemberDecls (CDecl [CDeclarationSpecifier NodeInfo]
declspecs [] NodeInfo
node) =
  do let ([CStorageSpecifier NodeInfo]
_storage_specs, [CAttribute NodeInfo]
_attrs, [CTypeQualifier NodeInfo]
typequals, [CTypeSpecifier NodeInfo]
typespecs, [CFunctionSpecifier NodeInfo]
funspecs, [CAlignmentSpecifier NodeInfo]
_alignspecs) =
           forall a.
[CDeclarationSpecifier a]
-> ([CStorageSpecifier a], [CAttribute a], [CTypeQualifier a],
    [CTypeSpecifier a], [CFunctionSpecifier a],
    [CAlignmentSpecifier a])
partitionDeclSpecs [CDeclarationSpecifier NodeInfo]
declspecs
     forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [CFunctionSpecifier NodeInfo]
funspecs) forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadCError m => NodeInfo -> String -> m a
astError NodeInfo
node String
"member declaration with function specifier"
     TypeSpecAnalysis
canonTySpecs <- forall (m :: * -> *).
MonadTrav m =>
[CTypeSpecifier NodeInfo] -> m TypeSpecAnalysis
canonicalTypeSpec [CTypeSpecifier NodeInfo]
typespecs
     Type
ty <- 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 CompTypeRef
_) TypeQuals
_ Attributes
_ ->
         forall (m :: * -> *) a. Monad m => a -> m a
return 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)
                   forall a. Maybe a
Nothing NodeInfo
node]
       Type
_ -> forall (m :: * -> *) a. MonadCError m => NodeInfo -> String -> m a
astError NodeInfo
node String
"anonymous member has a non-composite type"
-- Named members
tMemberDecls (CDecl [CDeclarationSpecifier NodeInfo]
declspecs [(Maybe (CDeclarator NodeInfo), Maybe (CInitializer NodeInfo),
  Maybe (CExpression NodeInfo))]
declrs NodeInfo
node) = forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m [c]
zipWithM forall {m :: * -> *} {a}.
MonadTrav m =>
Bool
-> (Maybe (CDeclarator NodeInfo), Maybe a,
    Maybe (CExpression NodeInfo))
-> m MemberDecl
tMemberDecl (Bool
Trueforall a. a -> [a] -> [a]
: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 Bool
handle_sue_def (Just CDeclarator NodeInfo
member_declr,Maybe a
Nothing,Maybe (CExpression NodeInfo)
bit_field_size_opt) =
        -- TODO: use analyseVarDecl here, not analyseVarDecl'
        do VarDeclInfo
var_decl <- 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 [] forall a. Maybe a
Nothing
           let (VarDeclInfo VarName
name FunctionAttrs
fun_spec StorageSpec
storage_spec Attributes
attrs Type
ty NodeInfo
_node_info) = VarDeclInfo
var_decl
           --
           forall {m :: * -> *}.
MonadCError m =>
FunctionAttrs -> StorageSpec -> m ()
checkValidMemberSpec FunctionAttrs
fun_spec StorageSpec
storage_spec
           forall (m :: * -> *) a. Monad m => a -> m a
return 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 Bool
handle_sue_def (Maybe (CDeclarator NodeInfo)
Nothing,Maybe a
Nothing,Just CExpression NodeInfo
bit_field_size) =
        do let ([CStorageSpecifier NodeInfo]
storage_specs, [CAttribute NodeInfo]
_attrs, [CTypeQualifier NodeInfo]
typequals, [CTypeSpecifier NodeInfo]
typespecs, [CFunctionSpecifier NodeInfo]
_funspecs, [CAlignmentSpecifier NodeInfo]
_alignspecs) = 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  <- forall (m :: * -> *).
MonadCError m =>
[CStorageSpecifier NodeInfo] -> m StorageSpec
canonicalStorageSpec [CStorageSpecifier NodeInfo]
storage_specs
           -- TODO: storage_spec not used
           TypeSpecAnalysis
canonTySpecs  <- forall (m :: * -> *).
MonadTrav m =>
[CTypeSpecifier NodeInfo] -> m TypeSpecAnalysis
canonicalTypeSpec [CTypeSpecifier NodeInfo]
typespecs
           Type
typ           <- 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 [] []
           --
           forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Type -> CExpression NodeInfo -> NodeInfo -> MemberDecl
AnonBitField Type
typ CExpression NodeInfo
bit_field_size NodeInfo
node
    tMemberDecl Bool
_ (Maybe (CDeclarator NodeInfo), Maybe a,
 Maybe (CExpression NodeInfo))
_ = forall (m :: * -> *) a. MonadCError m => NodeInfo -> String -> m a
astError NodeInfo
node String
"Bad member declaration"
    checkValidMemberSpec :: FunctionAttrs -> StorageSpec -> m ()
checkValidMemberSpec FunctionAttrs
fun_spec StorageSpec
storage_spec =
        do  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (FunctionAttrs
fun_spec forall a. Eq a => a -> a -> Bool
/= FunctionAttrs
noFunctionAttrs)   forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadCError m => NodeInfo -> String -> m a
astError NodeInfo
node String
"member declaration with inline specifier"
            forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (StorageSpec
storage_spec forall a. Eq a => a -> a -> Bool
/= StorageSpec
NoStorageSpec) forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadCError m => NodeInfo -> String -> m a
astError NodeInfo
node String
"storage specifier for member"
            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
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
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
Ord,Int -> StorageSpec -> ShowS
[StorageSpec] -> ShowS
StorageSpec -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [StorageSpec] -> ShowS
$cshowList :: [StorageSpec] -> ShowS
show :: StorageSpec -> String
$cshow :: StorageSpec -> String
showsPrec :: Int -> StorageSpec -> ShowS
$cshowsPrec :: Int -> StorageSpec -> ShowS
Show,ReadPrec [StorageSpec]
ReadPrec StorageSpec
Int -> ReadS StorageSpec
ReadS [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 StorageSpec
ThreadSpec = Bool
True
hasThreadLocalSpec StorageSpec
ClLocalSpec = Bool
True
hasThreadLocalSpec (StaticSpec Bool
b) = Bool
b
hasThreadLocalSpec (ExternSpec Bool
b) = Bool
b
hasThreadLocalSpec StorageSpec
_  = Bool
False

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

data VarDeclInfo = VarDeclInfo VarName FunctionAttrs StorageSpec Attributes Type NodeInfo

analyseVarDecl' :: (MonadTrav m) =>
                  Bool -> [CDeclSpec] ->
                  CDeclr -> [CDecl] -> Maybe CInit -> m VarDeclInfo
analyseVarDecl' :: 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
declr [CDecl]
oldstyle Maybe (CInitializer NodeInfo)
init_opt =
  do let ([CStorageSpecifier NodeInfo]
storage_specs, [CAttribute NodeInfo]
attrs, [CTypeQualifier NodeInfo]
type_quals, [CTypeSpecifier NodeInfo]
type_specs, [CFunctionSpecifier NodeInfo]
funspecs, [CAlignmentSpecifier NodeInfo]
_alignspecs) =
           forall a.
[CDeclarationSpecifier a]
-> ([CStorageSpecifier a], [CAttribute a], [CTypeQualifier a],
    [CTypeSpecifier a], [CFunctionSpecifier a],
    [CAlignmentSpecifier a])
partitionDeclSpecs [CDeclarationSpecifier NodeInfo]
declspecs
     TypeSpecAnalysis
canonTySpecs <- forall (m :: * -> *).
MonadTrav m =>
[CTypeSpecifier NodeInfo] -> m TypeSpecAnalysis
canonicalTypeSpec [CTypeSpecifier NodeInfo]
type_specs
     -- TODO: alignspecs not yet processed
     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 :: 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]
decl_attrs [CTypeQualifier NodeInfo]
typequals TypeSpecAnalysis
canonTySpecs [CFunctionSpecifier NodeInfo]
fun_specs
               (CDeclr Maybe Ident
name_opt [CDerivedDeclr]
derived_declrs Maybe (CStringLiteral NodeInfo)
asmname_opt [CAttribute NodeInfo]
declr_attrs NodeInfo
node)
               [CDecl]
oldstyle_params Maybe (CInitializer NodeInfo)
_init_opt
    = do -- analyse the storage specifiers
         StorageSpec
storage_spec  <- forall (m :: * -> *).
MonadCError m =>
[CStorageSpecifier NodeInfo] -> m StorageSpec
canonicalStorageSpec [CStorageSpecifier NodeInfo]
storage_specs
         -- translate the type into semantic representation
         Type
typ          <- 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'       <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall (m :: * -> *).
(MonadCError m, MonadSymtab m) =>
CAttribute NodeInfo -> m Attr
tAttr ([CAttribute NodeInfo]
decl_attrs forall a. [a] -> [a] -> [a]
++ [CAttribute NodeInfo]
declr_attrs)
         -- make name
         VarName
name         <- 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
         forall (m :: * -> *) a. Monad m => a -> m a
return 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 a
_) FunctionAttrs
f = FunctionAttrs
f { isInline :: Bool
isInline = Bool
True }
        updateFunSpec (CNoreturnQual a
_) FunctionAttrs
f = FunctionAttrs
f { isNoreturn :: Bool
isNoreturn = Bool
True }
        function_spec :: FunctionAttrs
function_spec = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr 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 [CDeclarationSpecifier NodeInfo]
declspecs = Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ NodeInfo
n | (CStorageSpec (CTypedef 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 :: forall (m :: * -> *). MonadTrav m => CDecl -> m Type
analyseTypeDecl (CStaticAssert CExpression NodeInfo
_ CStringLiteral NodeInfo
_ NodeInfo
node) =
  forall (m :: * -> *) a. MonadCError m => NodeInfo -> String -> m a
astError NodeInfo
node String
"Expected type declaration, found static assert"
analyseTypeDecl (CDecl [CDeclarationSpecifier NodeInfo]
declspecs [(Maybe (CDeclarator NodeInfo), Maybe (CInitializer NodeInfo),
  Maybe (CExpression NodeInfo))]
declrs NodeInfo
node)
    | [] <- [(Maybe (CDeclarator NodeInfo), Maybe (CInitializer NodeInfo),
  Maybe (CExpression NodeInfo))]
declrs = forall {m :: * -> *}. MonadTrav m => CDeclarator NodeInfo -> m Type
analyseTyDeclr (NodeInfo -> CDeclarator NodeInfo
emptyDeclr NodeInfo
node)
    | [(Just CDeclarator NodeInfo
declr,Maybe (CInitializer NodeInfo)
Nothing,Maybe (CExpression NodeInfo)
Nothing)] <- [(Maybe (CDeclarator NodeInfo), Maybe (CInitializer NodeInfo),
  Maybe (CExpression NodeInfo))]
declrs = forall {m :: * -> *}. MonadTrav m => CDeclarator NodeInfo -> m Type
analyseTyDeclr CDeclarator NodeInfo
declr
    | Bool
otherwise = forall (m :: * -> *) a. MonadCError m => NodeInfo -> String -> m a
astError NodeInfo
node String
"Bad declarator for type declaration"
    where
    analyseTyDeclr :: CDeclarator NodeInfo -> m Type
analyseTyDeclr (CDeclr Maybe Ident
Nothing [CDerivedDeclr]
derived_declrs Maybe (CStringLiteral NodeInfo)
Nothing [CAttribute NodeInfo]
attrs NodeInfo
_declrnode)
        | (Bool -> Bool
not (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [CStorageSpecifier NodeInfo]
storagespec) Bool -> Bool -> Bool
|| Bool -> Bool
not (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [CFunctionSpecifier NodeInfo]
funspecs) Bool -> Bool -> Bool
|| Bool -> Bool
not (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [CAlignmentSpecifier NodeInfo]
alignspecs)) =
            forall (m :: * -> *) a. MonadCError m => NodeInfo -> String -> m a
astError NodeInfo
node String
"storage, function or alignment specifier for type declaration"
        | Bool
otherwise                          =
          do TypeSpecAnalysis
canonTySpecs <- forall (m :: * -> *).
MonadTrav m =>
[CTypeSpecifier NodeInfo] -> m TypeSpecAnalysis
canonicalTypeSpec [CTypeSpecifier NodeInfo]
typespecs
             Type
t <- forall (m :: * -> *).
MonadTrav m =>
Bool
-> NodeInfo
-> [CTypeQualifier NodeInfo]
-> TypeSpecAnalysis
-> [CDerivedDeclr]
-> [CDecl]
-> m Type
tType Bool
True NodeInfo
node (forall a b. (a -> b) -> [a] -> [b]
map forall a. CAttribute a -> CTypeQualifier a
CAttrQual ([CAttribute NodeInfo]
attrsforall a. [a] -> [a] -> [a]
++[CAttribute NodeInfo]
attrs_decl) forall a. [a] -> [a] -> [a]
++ [CTypeQualifier NodeInfo]
typequals)
                   TypeSpecAnalysis
canonTySpecs [CDerivedDeclr]
derived_declrs []
             case NodeInfo -> Maybe Name
nameOfNode NodeInfo
node of
               Just Name
n -> forall (m :: * -> *) a.
MonadSymtab m =>
(DefTable -> (a, DefTable)) -> m a
withDefTable (\DefTable
dt -> (Type
t, DefTable -> Name -> Type -> DefTable
insertType DefTable
dt Name
n Type
t))
               Maybe Name
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return Type
t
        where
        ([CStorageSpecifier NodeInfo]
storagespec, [CAttribute NodeInfo]
attrs_decl, [CTypeQualifier NodeInfo]
typequals, [CTypeSpecifier NodeInfo]
typespecs, [CFunctionSpecifier NodeInfo]
funspecs, [CAlignmentSpecifier NodeInfo]
alignspecs) = forall a.
[CDeclarationSpecifier a]
-> ([CStorageSpecifier a], [CAttribute a], [CTypeQualifier a],
    [CTypeSpecifier a], [CFunctionSpecifier a],
    [CAlignmentSpecifier a])
partitionDeclSpecs [CDeclarationSpecifier NodeInfo]
declspecs
    analyseTyDeclr CDeclarator NodeInfo
_ = forall (m :: * -> *) a. MonadCError m => NodeInfo -> String -> m a
astError NodeInfo
node String
"Non-abstract declarator in type declaration"


-- | translate a type
tType :: (MonadTrav m) => Bool -> NodeInfo -> [CTypeQual] -> TypeSpecAnalysis -> [CDerivedDeclr] -> [CDecl] -> m Type
tType :: forall (m :: * -> *).
MonadTrav m =>
Bool
-> NodeInfo
-> [CTypeQualifier NodeInfo]
-> TypeSpecAnalysis
-> [CDerivedDeclr]
-> [CDecl]
-> m Type
tType Bool
handle_sue_def NodeInfo
top_node [CTypeQualifier NodeInfo]
typequals TypeSpecAnalysis
canonTySpecs [CDerivedDeclr]
derived_declrs [CDecl]
oldstyle_params
    = forall (m :: * -> *).
MonadCError m =>
NodeInfo -> [CDecl] -> [CDerivedDeclr] -> m [CDerivedDeclr]
mergeOldStyle NodeInfo
top_node [CDecl]
oldstyle_params [CDerivedDeclr]
derived_declrs forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall {m :: * -> *}. MonadTrav m => [CDerivedDeclr] -> m Type
buildType
    where
    buildType :: [CDerivedDeclr] -> m Type
buildType [] =
        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 [CTypeQualifier NodeInfo]
ptrquals NodeInfo
node : [CDerivedDeclr]
dds) =
        [CDerivedDeclr] -> m Type
buildType [CDerivedDeclr]
dds forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall {m :: * -> *} {p}.
MonadTrav m =>
[CTypeQualifier NodeInfo] -> p -> Type -> m Type
buildPointerType [CTypeQualifier NodeInfo]
ptrquals NodeInfo
node
    buildType (CArrDeclr [CTypeQualifier NodeInfo]
arrquals CArraySize NodeInfo
size NodeInfo
node : [CDerivedDeclr]
dds)
        = [CDerivedDeclr] -> m Type
buildType [CDerivedDeclr]
dds forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= 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 ([CDecl]
params, Bool
isVariadic)) [CAttribute NodeInfo]
attrs NodeInfo
node : [CDerivedDeclr]
dds)
        = [CDerivedDeclr] -> m Type
buildType [CDerivedDeclr]
dds forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM  (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry FunType -> Attributes -> Type
FunctionType) forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 [Ident]
_) [CAttribute NodeInfo]
_ NodeInfo
_ : [CDerivedDeclr]
_)
        -- /FIXME/: this is really an internal error, not an AST error.
        = forall (m :: * -> *) a. MonadCError m => NodeInfo -> String -> m a
astError NodeInfo
top_node String
"old-style parameters remaining after mergeOldStyle"
    buildPointerType :: [CTypeQualifier NodeInfo] -> p -> Type -> m Type
buildPointerType [CTypeQualifier NodeInfo]
ptrquals p
_node Type
inner_ty
        = forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (\(TypeQuals
quals,Attributes
attrs) -> Type -> TypeQuals -> Attributes -> Type
PtrType Type
inner_ty TypeQuals
quals Attributes
attrs) (forall (m :: * -> *).
MonadTrav m =>
[CTypeQualifier NodeInfo] -> m (TypeQuals, Attributes)
tTypeQuals [CTypeQualifier NodeInfo]
ptrquals)
    buildArrayType :: [CTypeQualifier NodeInfo]
-> CArraySize NodeInfo -> p -> Type -> m Type
buildArrayType [CTypeQualifier NodeInfo]
arr_quals CArraySize NodeInfo
size p
_node Type
inner_ty
        = do (TypeQuals
quals,Attributes
attrs) <- forall (m :: * -> *).
MonadTrav m =>
[CTypeQualifier NodeInfo] -> m (TypeQuals, Attributes)
tTypeQuals [CTypeQualifier NodeInfo]
arr_quals
             ArraySize
arr_sz        <- forall (m :: * -> *).
MonadTrav m =>
CArraySize NodeInfo -> m ArraySize
tArraySize CArraySize NodeInfo
size
             forall (m :: * -> *) a. Monad m => a -> m a
returnforall 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 [CDecl]
params Bool
is_variadic t (CAttribute NodeInfo)
attrs p
_node Type
return_ty
        = do forall (m :: * -> *). MonadSymtab m => m ()
enterPrototypeScope
             [ParamDecl]
params' <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall (m :: * -> *). MonadTrav m => CDecl -> m ParamDecl
tParamDecl [CDecl]
params
             forall (m :: * -> *). MonadSymtab m => m ()
leavePrototypeScope
             t Attr
attrs'  <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall (m :: * -> *).
(MonadCError m, MonadSymtab m) =>
CAttribute NodeInfo -> m Attr
tAttr t (CAttribute NodeInfo)
attrs
             forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ (\FunType
t -> (FunType
t,t Attr
attrs')) forall a b. (a -> b) -> a -> b
$
                case (forall a b. (a -> b) -> [a] -> [b]
map forall n. Declaration n => n -> Type
declType [ParamDecl]
params',Bool
is_variadic) of
                    ([],Bool
False) -> Type -> FunType
FunTypeIncomplete Type
return_ty  -- may be improved later on
                    ([DirectType TypeName
TyVoid TypeQuals
_ Attributes
_],Bool
False) -> Type -> [ParamDecl] -> Bool -> FunType
FunType Type
return_ty [] Bool
False
                    ([Type], Bool)
_ -> 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 :: forall (m :: * -> *).
MonadTrav m =>
Bool
-> NodeInfo
-> [CTypeQualifier NodeInfo]
-> TypeSpecAnalysis
-> m Type
tDirectType Bool
handle_sue_def NodeInfo
node [CTypeQualifier NodeInfo]
ty_quals TypeSpecAnalysis
canonTySpec = do
    (TypeQuals
quals,Attributes
attrs) <- forall (m :: * -> *).
MonadTrav m =>
[CTypeQualifier NodeInfo] -> m (TypeQuals, Attributes)
tTypeQuals [CTypeQualifier NodeInfo]
ty_quals
    let baseType :: TypeName -> Type
baseType TypeName
ty_name = TypeName -> TypeQuals -> Attributes -> Type
DirectType TypeName
ty_name TypeQuals
quals Attributes
attrs
    case TypeSpecAnalysis
canonTySpec of
        TypeSpecAnalysis
TSNone -> forall (m :: * -> *) a. Monad m => a -> m a
returnforall a b. (a -> b) -> a -> b
$ TypeName -> Type
baseType (IntType -> TypeName
TyIntegral IntType
TyInt)
        TypeSpecAnalysis
TSVoid -> forall (m :: * -> *) a. Monad m => a -> m a
returnforall a b. (a -> b) -> a -> b
$ TypeName -> Type
baseType TypeName
TyVoid
        TypeSpecAnalysis
TSBool -> forall (m :: * -> *) a. Monad m => a -> m a
returnforall a b. (a -> b) -> a -> b
$ TypeName -> Type
baseType (IntType -> TypeName
TyIntegral IntType
TyBool)
        TSNum NumTypeSpec
tsnum -> do
            Either (FloatType, Bool) IntType
numType <- forall (m :: * -> *).
MonadCError m =>
NumTypeSpec -> m (Either (FloatType, Bool) IntType)
tNumType NumTypeSpec
tsnum
            forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. TypeName -> Type
baseType forall a b. (a -> b) -> a -> b
$
                case Either (FloatType, Bool) IntType
numType of
                    Left (FloatType
floatType,Bool
iscomplex) | Bool
iscomplex -> FloatType -> TypeName
TyComplex FloatType
floatType
                                               | Bool
otherwise -> FloatType -> TypeName
TyFloating FloatType
floatType
                    Right IntType
intType  -> IntType -> TypeName
TyIntegral IntType
intType
        TSTypeDef TypeDefRef
tdr -> forall (m :: * -> *) a. Monad m => a -> m a
returnforall a b. (a -> b) -> a -> b
$ TypeDefRef -> TypeQuals -> Attributes -> Type
TypeDefType TypeDefRef
tdr TypeQuals
quals Attributes
attrs
        TSNonBasic (CSUType CStructureUnion NodeInfo
su NodeInfo
_tnode)       -> forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (TypeName -> Type
baseType forall b c a. (b -> c) -> (a -> b) -> a -> c
. CompTypeRef -> TypeName
TyComp) forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
MonadTrav m =>
Bool -> CStructureUnion NodeInfo -> m CompTypeRef
tCompTypeDecl Bool
handle_sue_def CStructureUnion NodeInfo
su
        TSNonBasic (CEnumType CEnumeration NodeInfo
enum NodeInfo
_tnode)   -> forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (TypeName -> Type
baseType forall b c a. (b -> c) -> (a -> b) -> a -> c
. EnumTypeRef -> TypeName
TyEnum) forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
MonadTrav m =>
Bool -> CEnumeration NodeInfo -> m EnumTypeRef
tEnumTypeDecl Bool
handle_sue_def CEnumeration NodeInfo
enum
        TSType Type
t                             ->  forall (m :: * -> *).
MonadCError m =>
NodeInfo -> TypeQuals -> Attributes -> Type -> m Type
mergeTypeAttributes NodeInfo
node TypeQuals
quals Attributes
attrs Type
t
        TSNonBasic CTypeSpecifier NodeInfo
t -> forall (m :: * -> *) a. MonadCError m => NodeInfo -> String -> m a
astError NodeInfo
node (String
"Unexpected typespec: " forall a. [a] -> [a] -> [a]
++ 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 :: forall (m :: * -> *).
MonadCError m =>
NodeInfo -> TypeQuals -> Attributes -> Type -> m Type
mergeTypeAttributes NodeInfo
node_info TypeQuals
quals Attributes
attrs Type
typ =
    case Type
typ of
        DirectType TypeName
ty_name TypeQuals
quals' Attributes
attrs' -> forall {m :: * -> *} {a}.
Monad m =>
TypeQuals -> Attributes -> (TypeQuals -> Attributes -> a) -> m a
merge TypeQuals
quals' Attributes
attrs' forall a b. (a -> b) -> a -> b
$ TypeName -> TypeQuals -> Attributes -> Type
DirectType TypeName
ty_name
        PtrType Type
ty TypeQuals
quals' Attributes
attrs'  -> forall {m :: * -> *} {a}.
Monad m =>
TypeQuals -> Attributes -> (TypeQuals -> Attributes -> a) -> m a
merge TypeQuals
quals' Attributes
attrs' forall a b. (a -> b) -> a -> b
$ Type -> TypeQuals -> Attributes -> Type
PtrType Type
ty
        ArrayType Type
ty ArraySize
array_sz TypeQuals
quals' Attributes
attrs' -> forall {m :: * -> *} {a}.
Monad m =>
TypeQuals -> Attributes -> (TypeQuals -> Attributes -> a) -> m a
merge TypeQuals
quals' Attributes
attrs' forall a b. (a -> b) -> a -> b
$ Type -> ArraySize -> TypeQuals -> Attributes -> Type
ArrayType Type
ty ArraySize
array_sz
        FunctionType FunType
fty Attributes
attrs'
             | TypeQuals
quals forall a. Eq a => a -> a -> Bool
/= TypeQuals
noTypeQuals -> forall (m :: * -> *) a. MonadCError m => NodeInfo -> String -> m a
astError NodeInfo
node_info String
"type qualifiers for function type"
             | Bool
otherwise            -> forall (m :: * -> *) a. Monad m => a -> m a
returnforall a b. (a -> b) -> a -> b
$ FunType -> Attributes -> Type
FunctionType FunType
fty (Attributes
attrs' forall a. [a] -> [a] -> [a]
++ Attributes
attrs)
        TypeDefType TypeDefRef
tdr TypeQuals
quals' Attributes
attrs'
            -> forall {m :: * -> *} {a}.
Monad m =>
TypeQuals -> Attributes -> (TypeQuals -> Attributes -> a) -> m a
merge TypeQuals
quals' Attributes
attrs' forall a b. (a -> b) -> a -> b
$ TypeDefRef -> TypeQuals -> Attributes -> Type
TypeDefType TypeDefRef
tdr
    where
    merge :: TypeQuals -> Attributes -> (TypeQuals -> Attributes -> a) -> m a
merge TypeQuals
quals' Attributes
attrs' TypeQuals -> Attributes -> a
tyf = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ TypeQuals -> Attributes -> a
tyf (TypeQuals -> TypeQuals -> TypeQuals
mergeTypeQuals TypeQuals
quals TypeQuals
quals') (Attributes
attrs' forall a. [a] -> [a] -> [a]
++ Attributes
attrs)

typeDefRef :: (MonadCError m, MonadSymtab m) => NodeInfo -> Ident -> m TypeDefRef
typeDefRef :: forall (m :: * -> *).
(MonadCError m, MonadSymtab m) =>
NodeInfo -> Ident -> m TypeDefRef
typeDefRef NodeInfo
t_node Ident
name = forall (m :: * -> *).
(MonadCError m, MonadSymtab m) =>
Ident -> m Type
lookupTypeDef Ident
name forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Type
ty -> 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 :: forall (m :: * -> *).
MonadTrav m =>
Bool -> CStructureUnion NodeInfo -> m CompTypeRef
tCompTypeDecl Bool
handle_def (CStruct CStructTag
tag Maybe Ident
ident_opt Maybe [CDecl]
member_decls_opt [CAttribute NodeInfo]
attrs NodeInfo
node_info) = do
    -- create reference
    SUERef
sue_ref <- 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' <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM 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
    forall (m :: * -> *).
(MonadCError m, MonadSymtab m) =>
TagFwdDecl -> m ()
handleTagDecl (CompTypeRef -> TagFwdDecl
CompDecl CompTypeRef
decl)
    -- when handle_def is true, enter the definition
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
handle_def forall a b. (a -> b) -> a -> b
$
        forall (m :: * -> *) a. Monad m => Maybe a -> (a -> m ()) -> m ()
maybeM Maybe [CDecl]
member_decls_opt forall a b. (a -> b) -> a -> b
$ \[CDecl]
decls ->
                forall (m :: * -> *).
MonadTrav m =>
SUERef
-> CompTyKind -> [CDecl] -> Attributes -> NodeInfo -> m CompType
tCompType SUERef
sue_ref CompTyKind
tag' [CDecl]
decls Attributes
attrs' NodeInfo
node_info
            forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (forall (m :: * -> *). MonadTrav m => TagDef -> m ()
handleTagDefforall b c a. (b -> c) -> (a -> b) -> a -> c
.CompType -> TagDef
CompDef)
    forall (m :: * -> *) a. Monad m => a -> m a
return CompTypeRef
decl

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

tCompType :: (MonadTrav m) => SUERef -> CompTyKind -> [CDecl] -> Attributes -> NodeInfo -> m CompType
tCompType :: forall (m :: * -> *).
MonadTrav m =>
SUERef
-> CompTyKind -> [CDecl] -> Attributes -> NodeInfo -> m CompType
tCompType SUERef
tag CompTyKind
sue_ref [CDecl]
member_decls Attributes
attrs NodeInfo
node
    = forall (m :: * -> *) a. Monad m => a -> m a
return (SUERef
-> CompTyKind -> [MemberDecl] -> Attributes -> NodeInfo -> CompType
CompType SUERef
tag CompTyKind
sue_ref) forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
`ap`
        (forall (m :: * -> *) a b. Monad m => (a -> m [b]) -> [a] -> m [b]
concatMapM forall (m :: * -> *). MonadTrav m => CDecl -> m [MemberDecl]
tMemberDecls [CDecl]
member_decls) forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
`ap`
        (forall (m :: * -> *) a. Monad m => a -> m a
return Attributes
attrs) forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
`ap`
        (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 :: forall (m :: * -> *).
MonadTrav m =>
Bool -> CEnumeration NodeInfo -> m EnumTypeRef
tEnumTypeDecl Bool
handle_def (CEnum Maybe Ident
ident_opt Maybe [(Ident, Maybe (CExpression NodeInfo))]
enumerators_opt [CAttribute NodeInfo]
attrs NodeInfo
node_info)
    | (Maybe Ident
Nothing, Maybe [(Ident, Maybe (CExpression NodeInfo))]
Nothing) <- (Maybe Ident
ident_opt, Maybe [(Ident, Maybe (CExpression NodeInfo))]
enumerators_opt) = forall (m :: * -> *) a. MonadCError m => NodeInfo -> String -> m a
astError NodeInfo
node_info String
"both definition and name of enum missing"
    | Just [] <- Maybe [(Ident, Maybe (CExpression NodeInfo))]
enumerators_opt                         = forall (m :: * -> *) a. MonadCError m => NodeInfo -> String -> m a
astError NodeInfo
node_info String
"empty enumerator list"
    | Bool
otherwise
        = do SUERef
sue_ref <- forall (m :: * -> *).
(MonadCError m, MonadSymtab m) =>
NodeInfo -> Maybe Ident -> m SUERef
createSUERef NodeInfo
node_info Maybe Ident
ident_opt
             Attributes
attrs' <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM 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
             forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
handle_def forall a b. (a -> b) -> a -> b
$
                 forall (m :: * -> *) a. Monad m => Maybe a -> (a -> m ()) -> m ()
maybeM Maybe [(Ident, Maybe (CExpression NodeInfo))]
enumerators_opt forall a b. (a -> b) -> a -> b
$ \[(Ident, Maybe (CExpression NodeInfo))]
enumerators ->
                         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
                    forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=  (forall (m :: * -> *). MonadTrav m => TagDef -> m ()
handleTagDef forall b c a. (b -> c) -> (a -> b) -> a -> c
. EnumType -> TagDef
EnumDef)
             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 :: 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 = do
    forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ forall (m :: * -> *).
(MonadCError m, MonadSymtab m) =>
Enumerator -> m ()
handleEnumeratorDef [Enumerator]
enumerators'
    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
    (Either Integer (CExpression NodeInfo, Integer)
_,[Enumerator]
enumerators') = forall (t :: * -> *) s a b.
Traversable t =>
(s -> a -> (s, b)) -> s -> t a -> (s, t b)
mapAccumL Either Integer (CExpression NodeInfo, Integer)
-> (Ident, Maybe (CExpression NodeInfo))
-> (Either Integer (CExpression NodeInfo, Integer), Enumerator)
nextEnumerator (forall a b. a -> Either a b
Left Integer
0) [(Ident, Maybe (CExpression NodeInfo))]
enumerators
    nextEnumerator :: Either Integer (CExpression NodeInfo, Integer)
-> (Ident, Maybe (CExpression NodeInfo))
-> (Either Integer (CExpression NodeInfo, Integer), Enumerator)
nextEnumerator Either Integer (CExpression NodeInfo, Integer)
memo (Ident
ident,Maybe (CExpression NodeInfo)
e) =
      let (Either Integer (CExpression NodeInfo, Integer)
memo',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 (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 Integer
i) Maybe (CExpression NodeInfo)
Nothing = (forall a b. a -> Either a b
Left (forall a. Enum a => a -> a
succ Integer
i), Integer -> CExpression NodeInfo
intExpr Integer
i)
    nextEnrExpr (Right (CExpression NodeInfo
e,Integer
offs)) Maybe (CExpression NodeInfo)
Nothing = (forall a b. b -> Either a b
Right (CExpression NodeInfo
e, forall a. Enum a => a -> a
succ Integer
offs), CExpression NodeInfo -> Integer -> CExpression NodeInfo
offsExpr CExpression NodeInfo
e Integer
offs)
    nextEnrExpr Either Integer (CExpression NodeInfo, Integer)
_ (Just CExpression NodeInfo
e) = (forall a b. b -> Either a b
Right (CExpression NodeInfo
e,Integer
1), CExpression NodeInfo
e)
    intExpr :: Integer -> CExpression NodeInfo
intExpr Integer
i = forall a. CConstant a -> CExpression a
CConst (forall a. CInteger -> a -> CConstant a
CIntConst (Integer -> CInteger
cInteger Integer
i) NodeInfo
undefNode)
    offsExpr :: CExpression NodeInfo -> Integer -> CExpression NodeInfo
offsExpr CExpression NodeInfo
e Integer
offs = 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 :: forall (m :: * -> *).
MonadCError m =>
NumTypeSpec -> m (Either (FloatType, Bool) IntType)
tNumType (NumTypeSpec NumBaseType
basetype SignSpec
sgn SizeMod
sz Bool
iscomplex) =
    case (NumBaseType
basetype,SignSpec
sgn,SizeMod
sz) of
        (NumBaseType
BaseChar,SignSpec
_,SizeMod
NoSizeMod)      | SignSpec
Signed <- SignSpec
sgn   -> forall {a} {a}. a -> m (Either a a)
intType IntType
TySChar
                                    | SignSpec
Unsigned <- SignSpec
sgn -> forall {a} {a}. a -> m (Either a a)
intType IntType
TyUChar
                                    | Bool
otherwise       -> forall {a} {a}. a -> m (Either a a)
intType IntType
TyChar
        (NumBaseType
intbase, SignSpec
_, SizeMod
NoSizeMod)  | NumBaseType -> NumBaseType -> Bool
optBase NumBaseType
BaseInt NumBaseType
intbase ->
            forall {a} {a}. a -> m (Either a a)
intTypeforall a b. (a -> b) -> a -> b
$ case SignSpec
sgn of
                            SignSpec
Unsigned -> IntType
TyUInt
                            SignSpec
_        -> IntType
TyInt
        (NumBaseType
intbase, SignSpec
_, SizeMod
NoSizeMod)  | NumBaseType -> NumBaseType -> Bool
optBase NumBaseType
BaseInt128 NumBaseType
intbase ->
            forall {a} {a}. a -> m (Either a a)
intTypeforall a b. (a -> b) -> a -> b
$ case SignSpec
sgn of
                            SignSpec
Unsigned -> IntType
TyUInt128
                            SignSpec
_        -> IntType
TyInt128
        (NumBaseType
intbase, SignSpec
signed, SizeMod
sizemod)    | NumBaseType -> NumBaseType -> Bool
optBase NumBaseType
BaseInt NumBaseType
intbase, SignSpec -> SignSpec -> Bool
optSign SignSpec
Signed SignSpec
signed ->
            forall {a} {a}. a -> m (Either a a)
intTypeforall a b. (a -> b) -> a -> b
$ case SizeMod
sizemod of SizeMod
ShortMod    -> IntType
TyShort
                                     SizeMod
LongMod     -> IntType
TyLong
                                     SizeMod
LongLongMod -> IntType
TyLLong
                                     SizeMod
_ -> forall a. String -> a
internalErr String
"numTypeMapping: unexpected pattern matching error"
        (NumBaseType
intbase, SignSpec
Unsigned, SizeMod
sizemod) | NumBaseType -> NumBaseType -> Bool
optBase NumBaseType
BaseInt NumBaseType
intbase ->
            forall {a} {a}. a -> m (Either a a)
intTypeforall a b. (a -> b) -> a -> b
$ case SizeMod
sizemod of SizeMod
ShortMod    -> IntType
TyUShort
                                     SizeMod
LongMod     -> IntType
TyULong
                                     SizeMod
LongLongMod -> IntType
TyULLong
                                     SizeMod
_ -> forall a. String -> a
internalErr String
"numTypeMapping: unexpected pattern matching error"
        (NumBaseType
BaseFloat, SignSpec
NoSignSpec, SizeMod
NoSizeMod)  -> forall {m :: * -> *} {a} {b}.
Monad m =>
a -> m (Either (a, Bool) b)
floatType FloatType
TyFloat
        (NumBaseType
BaseDouble, SignSpec
NoSignSpec, SizeMod
NoSizeMod) -> forall {m :: * -> *} {a} {b}.
Monad m =>
a -> m (Either (a, Bool) b)
floatType FloatType
TyDouble
        (NumBaseType
BaseDouble, SignSpec
NoSignSpec, SizeMod
LongMod)   -> forall {m :: * -> *} {a} {b}.
Monad m =>
a -> m (Either (a, Bool) b)
floatType FloatType
TyLDouble
        (BaseFloatN Int
n Bool
x, SignSpec
NoSignSpec, SizeMod
NoSizeMod) -> forall {m :: * -> *} {a} {b}.
Monad m =>
a -> m (Either (a, Bool) b)
floatType (Int -> Bool -> FloatType
TyFloatN Int
n Bool
x)
        -- TODO: error analysis
        (NumBaseType
_,SignSpec
_,SizeMod
_)   -> forall a. HasCallStack => String -> a
error String
"Bad AST analysis"
    where
    optBase :: NumBaseType -> NumBaseType -> Bool
optBase NumBaseType
_ NumBaseType
NoBaseType = Bool
True
    optBase NumBaseType
expect NumBaseType
baseTy = NumBaseType
expect forall a. Eq a => a -> a -> Bool
== NumBaseType
baseTy
    optSign :: SignSpec -> SignSpec -> Bool
optSign SignSpec
_ SignSpec
NoSignSpec = Bool
True
    optSign SignSpec
expect SignSpec
sign = SignSpec
expect forall a. Eq a => a -> a -> Bool
== SignSpec
sign
    intType :: a -> m (Either a a)
intType = forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. b -> Either a b
Right
    floatType :: a -> m (Either (a, Bool) b)
floatType a
ft = forall (m :: * -> *) a. Monad m => a -> m a
return (forall a b. a -> Either a b
Left (a
ft,Bool
iscomplex))

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

tTypeQuals :: (MonadTrav m) => [CTypeQual] -> m (TypeQuals,Attributes)
tTypeQuals :: forall (m :: * -> *).
MonadTrav m =>
[CTypeQualifier NodeInfo] -> m (TypeQuals, Attributes)
tTypeQuals = forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> b -> m b) -> b -> t a -> m b
foldrM 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 NodeInfo
_) (TypeQuals
tq,Attributes
attrs) = forall (m :: * -> *) a. Monad m => a -> m a
return (TypeQuals
tq { constant :: Bool
constant = Bool
True },Attributes
attrs)
    go (CVolatQual NodeInfo
_) (TypeQuals
tq,Attributes
attrs) = forall (m :: * -> *) a. Monad m => a -> m a
return (TypeQuals
tq { volatile :: Bool
volatile = Bool
True },Attributes
attrs)
    go (CRestrQual NodeInfo
_) (TypeQuals
tq,Attributes
attrs) = forall (m :: * -> *) a. Monad m => a -> m a
return (TypeQuals
tq { restrict :: Bool
restrict = Bool
True },Attributes
attrs)
    go (CAtomicQual NodeInfo
_) (TypeQuals
tq,Attributes
attrs) = forall (m :: * -> *) a. Monad m => a -> m a
return (TypeQuals
tq { atomic :: Bool
atomic = Bool
True },Attributes
attrs)
    go (CAttrQual CAttribute NodeInfo
attr) (TypeQuals
tq,Attributes
attrs) = forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (\Attr
attr' -> (TypeQuals
tq,Attr
attr'forall a. a -> [a] -> [a]
:Attributes
attrs)) (forall (m :: * -> *).
(MonadCError m, MonadSymtab m) =>
CAttribute NodeInfo -> m Attr
tAttr CAttribute NodeInfo
attr)
    go (CNullableQual NodeInfo
_) (TypeQuals
tq,Attributes
attrs) = forall (m :: * -> *) a. Monad m => a -> m a
return (TypeQuals
tq { nullable :: Bool
nullable = Bool
True }, Attributes
attrs)
    go (CNonnullQual NodeInfo
_) (TypeQuals
tq,Attributes
attrs) = forall (m :: * -> *) a. Monad m => a -> m a
return (TypeQuals
tq { nonnull :: Bool
nonnull = Bool
True }, Attributes
attrs)
    go (CClRdOnlyQual NodeInfo
_) (TypeQuals
tq,Attributes
attrs) = forall (m :: * -> *) a. Monad m => a -> m a
return (TypeQuals
tq { clrdonly :: Bool
clrdonly = Bool
True },Attributes
attrs)
    go (CClWrOnlyQual NodeInfo
_) (TypeQuals
tq,Attributes
attrs) = 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
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
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
Ord)
data SignSpec    = NoSignSpec | Signed | Unsigned deriving (SignSpec -> SignSpec -> Bool
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
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
Ord)
data SizeMod     = NoSizeMod | ShortMod | LongMod | LongLongMod deriving (SizeMod -> SizeMod -> Bool
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
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
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 { 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 :: forall (m :: * -> *).
MonadTrav m =>
[CTypeSpecifier NodeInfo] -> m TypeSpecAnalysis
canonicalTypeSpec = forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> b -> m b) -> b -> t a -> m b
foldrM forall (m :: * -> *).
MonadTrav m =>
CTypeSpecifier NodeInfo -> TypeSpecAnalysis -> m TypeSpecAnalysis
go TypeSpecAnalysis
TSNone where
    getNTS :: TypeSpecAnalysis -> Maybe NumTypeSpec
getNTS TypeSpecAnalysis
TSNone = forall a. a -> Maybe a
Just NumTypeSpec
emptyNumTypeSpec
    getNTS (TSNum NumTypeSpec
nts) = forall a. a -> Maybe a
Just NumTypeSpec
nts
    getNTS TypeSpecAnalysis
_ = forall a. Maybe a
Nothing
    updLongMod :: SizeMod -> Maybe SizeMod
updLongMod SizeMod
NoSizeMod = forall a. a -> Maybe a
Just SizeMod
LongMod
    updLongMod SizeMod
LongMod   = forall a. a -> Maybe a
Just SizeMod
LongLongMod
    updLongMod SizeMod
_         = forall a. Maybe a
Nothing
    go :: (MonadTrav m) => CTypeSpec -> TypeSpecAnalysis -> m TypeSpecAnalysis
    go :: forall (m :: * -> *).
MonadTrav m =>
CTypeSpecifier NodeInfo -> TypeSpecAnalysis -> m TypeSpecAnalysis
go (CVoidType NodeInfo
_)    TypeSpecAnalysis
TSNone = forall (m :: * -> *) a. Monad m => a -> m a
return TypeSpecAnalysis
TSVoid
    go (CBoolType NodeInfo
_)    TypeSpecAnalysis
TSNone = forall (m :: * -> *) a. Monad m => a -> m a
return TypeSpecAnalysis
TSBool
    go (CCharType NodeInfo
_)    TypeSpecAnalysis
tsa | (Just nts :: NumTypeSpec
nts@(NumTypeSpec { base :: NumTypeSpec -> NumBaseType
base = NumBaseType
NoBaseType })) <- TypeSpecAnalysis -> Maybe NumTypeSpec
getNTS TypeSpecAnalysis
tsa
                            = forall (m :: * -> *) a. Monad m => a -> m a
returnforall a b. (a -> b) -> a -> b
$  NumTypeSpec -> TypeSpecAnalysis
TSNumforall a b. (a -> b) -> a -> b
$ NumTypeSpec
nts { base :: NumBaseType
base = NumBaseType
BaseChar }
    go (CIntType NodeInfo
_)     TypeSpecAnalysis
tsa | (Just nts :: NumTypeSpec
nts@(NumTypeSpec { base :: NumTypeSpec -> NumBaseType
base = NumBaseType
NoBaseType })) <- TypeSpecAnalysis -> Maybe NumTypeSpec
getNTS TypeSpecAnalysis
tsa
                            = forall (m :: * -> *) a. Monad m => a -> m a
returnforall a b. (a -> b) -> a -> b
$  NumTypeSpec -> TypeSpecAnalysis
TSNumforall a b. (a -> b) -> a -> b
$ NumTypeSpec
nts { base :: NumBaseType
base = NumBaseType
BaseInt }
    go (CInt128Type NodeInfo
_)  TypeSpecAnalysis
tsa | (Just nts :: NumTypeSpec
nts@(NumTypeSpec { base :: NumTypeSpec -> NumBaseType
base = NumBaseType
NoBaseType })) <- TypeSpecAnalysis -> Maybe NumTypeSpec
getNTS TypeSpecAnalysis
tsa
                            = forall (m :: * -> *) a. Monad m => a -> m a
returnforall a b. (a -> b) -> a -> b
$  NumTypeSpec -> TypeSpecAnalysis
TSNumforall a b. (a -> b) -> a -> b
$ NumTypeSpec
nts { base :: NumBaseType
base = NumBaseType
BaseInt128 }
    go (CFloatType NodeInfo
_)   TypeSpecAnalysis
tsa | (Just nts :: NumTypeSpec
nts@(NumTypeSpec { base :: NumTypeSpec -> NumBaseType
base = NumBaseType
NoBaseType })) <- TypeSpecAnalysis -> Maybe NumTypeSpec
getNTS TypeSpecAnalysis
tsa
                            = forall (m :: * -> *) a. Monad m => a -> m a
returnforall a b. (a -> b) -> a -> b
$  NumTypeSpec -> TypeSpecAnalysis
TSNumforall a b. (a -> b) -> a -> b
$ NumTypeSpec
nts { base :: NumBaseType
base = NumBaseType
BaseFloat }
    go (CFloatNType Int
n Bool
x NodeInfo
_) TypeSpecAnalysis
tsa | (Just nts :: NumTypeSpec
nts@(NumTypeSpec { base :: NumTypeSpec -> NumBaseType
base = NumBaseType
NoBaseType })) <- TypeSpecAnalysis -> Maybe NumTypeSpec
getNTS TypeSpecAnalysis
tsa
                            = forall (m :: * -> *) a. Monad m => a -> m a
returnforall a b. (a -> b) -> a -> b
$  NumTypeSpec -> TypeSpecAnalysis
TSNumforall a b. (a -> b) -> a -> b
$ NumTypeSpec
nts { base :: NumBaseType
base = Int -> Bool -> NumBaseType
BaseFloatN Int
n Bool
x }
    go (CDoubleType NodeInfo
_)  TypeSpecAnalysis
tsa | (Just nts :: NumTypeSpec
nts@(NumTypeSpec { base :: NumTypeSpec -> NumBaseType
base = NumBaseType
NoBaseType })) <- TypeSpecAnalysis -> Maybe NumTypeSpec
getNTS TypeSpecAnalysis
tsa
                            = forall (m :: * -> *) a. Monad m => a -> m a
returnforall a b. (a -> b) -> a -> b
$  NumTypeSpec -> TypeSpecAnalysis
TSNumforall a b. (a -> b) -> a -> b
$ NumTypeSpec
nts { base :: NumBaseType
base = NumBaseType
BaseDouble }
    go (CShortType NodeInfo
_)   TypeSpecAnalysis
tsa | (Just nts :: NumTypeSpec
nts@(NumTypeSpec { sizeMod :: NumTypeSpec -> SizeMod
sizeMod = SizeMod
NoSizeMod })) <- TypeSpecAnalysis -> Maybe NumTypeSpec
getNTS TypeSpecAnalysis
tsa
                            = forall (m :: * -> *) a. Monad m => a -> m a
returnforall a b. (a -> b) -> a -> b
$  NumTypeSpec -> TypeSpecAnalysis
TSNumforall a b. (a -> b) -> a -> b
$NumTypeSpec
nts { sizeMod :: SizeMod
sizeMod = SizeMod
ShortMod }
    go (CLongType NodeInfo
_)    TypeSpecAnalysis
tsa | (Just nts :: NumTypeSpec
nts@(NumTypeSpec { sizeMod :: NumTypeSpec -> SizeMod
sizeMod = SizeMod
szMod })) <- TypeSpecAnalysis -> Maybe NumTypeSpec
getNTS TypeSpecAnalysis
tsa,
                              (Just SizeMod
szMod') <- SizeMod -> Maybe SizeMod
updLongMod SizeMod
szMod
                            = forall (m :: * -> *) a. Monad m => a -> m a
returnforall a b. (a -> b) -> a -> b
$  NumTypeSpec -> TypeSpecAnalysis
TSNumforall a b. (a -> b) -> a -> b
$ NumTypeSpec
nts { sizeMod :: SizeMod
sizeMod = SizeMod
szMod' }
    go (CSignedType NodeInfo
_)  TypeSpecAnalysis
tsa | (Just nts :: NumTypeSpec
nts@(NumTypeSpec { signSpec :: NumTypeSpec -> SignSpec
signSpec = SignSpec
NoSignSpec })) <- TypeSpecAnalysis -> Maybe NumTypeSpec
getNTS TypeSpecAnalysis
tsa
                            = forall (m :: * -> *) a. Monad m => a -> m a
returnforall a b. (a -> b) -> a -> b
$  NumTypeSpec -> TypeSpecAnalysis
TSNumforall a b. (a -> b) -> a -> b
$ NumTypeSpec
nts { signSpec :: SignSpec
signSpec = SignSpec
Signed }
    go (CUnsigType NodeInfo
_)   TypeSpecAnalysis
tsa | (Just nts :: NumTypeSpec
nts@(NumTypeSpec { signSpec :: NumTypeSpec -> SignSpec
signSpec = SignSpec
NoSignSpec })) <- TypeSpecAnalysis -> Maybe NumTypeSpec
getNTS TypeSpecAnalysis
tsa
                            = forall (m :: * -> *) a. Monad m => a -> m a
returnforall a b. (a -> b) -> a -> b
$  NumTypeSpec -> TypeSpecAnalysis
TSNumforall a b. (a -> b) -> a -> b
$ NumTypeSpec
nts { signSpec :: SignSpec
signSpec = SignSpec
Unsigned }
    go (CComplexType NodeInfo
_) TypeSpecAnalysis
tsa | (Just nts :: NumTypeSpec
nts@(NumTypeSpec { isComplex :: NumTypeSpec -> Bool
isComplex = Bool
False })) <- TypeSpecAnalysis -> Maybe NumTypeSpec
getNTS TypeSpecAnalysis
tsa
                            = forall (m :: * -> *) a. Monad m => a -> m a
returnforall a b. (a -> b) -> a -> b
$  NumTypeSpec -> TypeSpecAnalysis
TSNumforall a b. (a -> b) -> a -> b
$ NumTypeSpec
nts { isComplex :: Bool
isComplex = Bool
True }
    go (CTypeDef Ident
i NodeInfo
ni) TypeSpecAnalysis
TSNone = forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM TypeDefRef -> TypeSpecAnalysis
TSTypeDef forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
(MonadCError m, MonadSymtab m) =>
NodeInfo -> Ident -> m TypeDefRef
typeDefRef NodeInfo
ni Ident
i
    go (CTypeOfType CDecl
d NodeInfo
_ni) TypeSpecAnalysis
TSNone = forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM Type -> TypeSpecAnalysis
TSType forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). MonadTrav m => CDecl -> m Type
analyseTypeDecl CDecl
d
    go (CTypeOfExpr CExpression NodeInfo
e NodeInfo
_) TypeSpecAnalysis
TSNone = forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM Type -> TypeSpecAnalysis
TSType forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
MonadTrav m =>
[StmtCtx] -> ExprSide -> CExpression NodeInfo -> m Type
tExpr [] ExprSide
RValue CExpression NodeInfo
e
    -- todo: atomic qualifier discarded
    go (CAtomicType CDecl
d NodeInfo
_ni) TypeSpecAnalysis
TSNone = forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM Type -> TypeSpecAnalysis
TSType forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). MonadTrav m => CDecl -> m Type
analyseTypeDecl CDecl
d
    go CTypeSpecifier NodeInfo
otherType  TypeSpecAnalysis
TSNone    = forall (m :: * -> *) a. Monad m => a -> m a
returnforall a b. (a -> b) -> a -> b
$  CTypeSpecifier NodeInfo -> TypeSpecAnalysis
TSNonBasic CTypeSpecifier NodeInfo
otherType
    go CTypeSpecifier NodeInfo
ty TypeSpecAnalysis
_ts = forall (m :: * -> *) a. MonadCError m => NodeInfo -> String -> m a
astError (forall a. CNode a => a -> NodeInfo
nodeInfo CTypeSpecifier NodeInfo
ty) String
"Invalid type specifier"

-- compute storage given storage specifiers
canonicalStorageSpec :: (MonadCError m) =>[CStorageSpec] -> m StorageSpec
canonicalStorageSpec :: forall (m :: * -> *).
MonadCError m =>
[CStorageSpecifier NodeInfo] -> m StorageSpec
canonicalStorageSpec [CStorageSpecifier NodeInfo]
storagespecs = forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM StorageSpec -> StorageSpec
elideAuto forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> b -> m b) -> b -> t a -> m b
foldrM 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 a
_) StorageSpec
NoStorageSpec     = forall (m :: * -> *) a. Monad m => a -> m a
return StorageSpec
AutoSpec
        updStorage (CRegister a
_) StorageSpec
NoStorageSpec = forall (m :: * -> *) a. Monad m => a -> m a
return StorageSpec
RegSpec
        updStorage (CThread a
_) StorageSpec
NoStorageSpec   = forall (m :: * -> *) a. Monad m => a -> m a
return StorageSpec
ThreadSpec
        updStorage (CClKernel a
_) StorageSpec
NoStorageSpec = forall (m :: * -> *) a. Monad m => a -> m a
return StorageSpec
ClKernelSpec
        updStorage (CClGlobal a
_) StorageSpec
NoStorageSpec = forall (m :: * -> *) a. Monad m => a -> m a
return StorageSpec
ClGlobalSpec
        updStorage (CClLocal  a
_) StorageSpec
NoStorageSpec = forall (m :: * -> *) a. Monad m => a -> m a
return StorageSpec
ClLocalSpec
        updStorage (CThread a
_) (StaticSpec Bool
_)  = forall (m :: * -> *) a. Monad m => a -> m a
returnforall a b. (a -> b) -> a -> b
$ Bool -> StorageSpec
StaticSpec Bool
True
        updStorage (CThread a
_) (ExternSpec Bool
_)  = forall (m :: * -> *) a. Monad m => a -> m a
returnforall a b. (a -> b) -> a -> b
$ Bool -> StorageSpec
ExternSpec Bool
True
        updStorage (CStatic a
_) StorageSpec
NoStorageSpec   = forall (m :: * -> *) a. Monad m => a -> m a
returnforall a b. (a -> b) -> a -> b
$ Bool -> StorageSpec
StaticSpec Bool
False
        updStorage (CExtern a
_) StorageSpec
NoStorageSpec   = forall (m :: * -> *) a. Monad m => a -> m a
returnforall a b. (a -> b) -> a -> b
$ Bool -> StorageSpec
ExternSpec Bool
False
        updStorage (CStatic a
_) StorageSpec
ThreadSpec      = forall (m :: * -> *) a. Monad m => a -> m a
returnforall a b. (a -> b) -> a -> b
$ Bool -> StorageSpec
StaticSpec Bool
True
        updStorage (CExtern a
_) StorageSpec
ThreadSpec      = forall (m :: * -> *) a. Monad m => a -> m a
returnforall a b. (a -> b) -> a -> b
$ Bool -> StorageSpec
ExternSpec Bool
True
        updStorage CStorageSpecifier a
badSpec StorageSpec
old
            = forall (m :: * -> *) a. MonadCError m => NodeInfo -> String -> m a
astError (forall a. CNode a => a -> NodeInfo
nodeInfo CStorageSpecifier a
badSpec) forall a b. (a -> b) -> a -> b
$ String
"Invalid storage specifier "forall a. [a] -> [a] -> [a]
++Doc -> String
render (forall p. Pretty p => p -> Doc
pretty CStorageSpecifier a
badSpec)forall a. [a] -> [a] -> [a]
++String
" in combination with "forall a. [a] -> [a] -> [a]
++forall a. Show a => a -> String
show StorageSpec
old
        elideAuto :: StorageSpec -> StorageSpec
elideAuto StorageSpec
AutoSpec = StorageSpec
NoStorageSpec
        elideAuto 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 :: forall (m :: * -> *).
MonadCError m =>
NodeInfo -> [CDecl] -> [CDerivedDeclr] -> m [CDerivedDeclr]
mergeOldStyle NodeInfo
_node [] [CDerivedDeclr]
declrs = forall (m :: * -> *) a. Monad m => a -> m a
return [CDerivedDeclr]
declrs
mergeOldStyle NodeInfo
node [CDecl]
oldstyle_params (CFunDeclr Either [Ident] ([CDecl], Bool)
params [CAttribute NodeInfo]
attrs NodeInfo
fdnode : [CDerivedDeclr]
dds) =
    case Either [Ident] ([CDecl], Bool)
params of
        Left [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' <- forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall (m :: * -> *). MonadCError m => CDecl -> m [CDecl]
splitCDecl [CDecl]
oldstyle_params
            Map Ident CDecl
param_map <- forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall {m :: * -> *}. MonadCError m => CDecl -> m (Ident, CDecl)
attachNameOfDecl [CDecl]
oldstyle_params'
            ([CDecl]
newstyle_params,Map Ident CDecl
param_map') <- forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> b -> m b) -> b -> t a -> m b
foldrM forall {m :: * -> *}.
Monad m =>
Ident -> ([CDecl], Map Ident CDecl) -> m ([CDecl], Map Ident CDecl)
insertParamDecl ([],Map Ident CDecl
param_map) [Ident]
list
            forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall k a. Map k a -> Bool
Map.null Map Ident CDecl
param_map') forall a b. (a -> b) -> a -> b
$
              forall (m :: * -> *) a. MonadCError m => NodeInfo -> String -> m a
astError NodeInfo
node forall a b. (a -> b) -> a -> b
$ String
"declarations for parameter(s) "forall a. [a] -> [a] -> [a]
++ forall {a}. Map Ident a -> String
showParamMap Map Ident CDecl
param_map' forall a. [a] -> [a] -> [a]
++String
" but no such parameter"
            forall (m :: * -> *) a. Monad m => a -> m a
return (forall a.
Either [Ident] ([CDeclaration a], Bool)
-> [CAttribute a] -> a -> CDerivedDeclarator a
CFunDeclr (forall a b. b -> Either a b
Right ([CDecl]
newstyle_params, Bool
False)) [CAttribute NodeInfo]
attrs NodeInfo
fdnode forall a. a -> [a] -> [a]
: [CDerivedDeclr]
dds)
        Right ([CDecl], Bool)
_newstyle -> forall (m :: * -> *) a. MonadCError m => NodeInfo -> String -> m a
astError NodeInfo
node String
"oldstyle parameter list, but newstyle function declaration"
    where
        attachNameOfDecl :: CDecl -> m (Ident, CDecl)
attachNameOfDecl CDecl
decl = forall (m :: * -> *). MonadCError m => CDecl -> m Ident
nameOfDecl CDecl
decl forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Ident
n -> 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 Ident
param_name ([CDecl]
ps, Map Ident CDecl
param_map)
            = case forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Ident
param_name Map Ident CDecl
param_map of
                Just CDecl
p -> forall (m :: * -> *) a. Monad m => a -> m a
return (CDecl
pforall a. a -> [a] -> [a]
:[CDecl]
ps, forall k a. Ord k => k -> Map k a -> Map k a
Map.delete Ident
param_name Map Ident CDecl
param_map)
                Maybe CDecl
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return (Ident -> CDecl
implicitIntParam Ident
param_name forall a. a -> [a] -> [a]
: [CDecl]
ps, Map Ident CDecl
param_map)
        implicitIntParam :: Ident -> CDecl
implicitIntParam Ident
param_name =
            let nInfo :: NodeInfo
nInfo = forall a. CNode a => a -> NodeInfo
nodeInfo Ident
param_name in
            forall a.
[CDeclarationSpecifier a]
-> [(Maybe (CDeclarator a), Maybe (CInitializer a),
     Maybe (CExpression a))]
-> a
-> CDeclaration a
CDecl [forall a. CTypeSpecifier a -> CDeclarationSpecifier a
CTypeSpec (forall a. a -> CTypeSpecifier a
CIntType NodeInfo
nInfo)] [(forall a. a -> Maybe a
Just (forall a.
Maybe Ident
-> [CDerivedDeclarator a]
-> Maybe (CStringLiteral a)
-> [CAttribute a]
-> a
-> CDeclarator a
CDeclr (forall a. a -> Maybe a
Just Ident
param_name) [] forall a. Maybe a
Nothing [] NodeInfo
nInfo),forall a. Maybe a
Nothing,forall a. Maybe a
Nothing)] NodeInfo
nInfo
        showParamMap :: Map Ident a -> String
showParamMap = forall a. [a] -> [[a]] -> [a]
intercalate String
", " forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map Ident -> String
identToString forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k a. Map k a -> [k]
Map.keys
mergeOldStyle NodeInfo
node [CDecl]
_ [CDerivedDeclr]
_ = forall (m :: * -> *) a. MonadCError m => NodeInfo -> String -> m a
astError NodeInfo
node String
"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 :: forall (m :: * -> *). MonadCError m => CDecl -> m [CDecl]
splitCDecl decl :: CDecl
decl@(CStaticAssert CExpression NodeInfo
_ CStringLiteral NodeInfo
_ NodeInfo
_) = forall (m :: * -> *) a. Monad m => a -> m a
return [CDecl
decl]
splitCDecl decl :: CDecl
decl@(CDecl [CDeclarationSpecifier NodeInfo]
declspecs [(Maybe (CDeclarator NodeInfo), Maybe (CInitializer NodeInfo),
  Maybe (CExpression NodeInfo))]
declrs NodeInfo
node) =
    case [(Maybe (CDeclarator NodeInfo), Maybe (CInitializer NodeInfo),
  Maybe (CExpression NodeInfo))]
declrs of
        []      -> forall a. String -> a
internalErr String
"splitCDecl applied to empty declaration"
        -- single declarator, not need to split
        [(Maybe (CDeclarator NodeInfo), Maybe (CInitializer NodeInfo),
 Maybe (CExpression NodeInfo))
_declr] -> forall (m :: * -> *) a. Monad m => a -> m a
return [CDecl
decl]
        -- more than one declarator
        ((Maybe (CDeclarator NodeInfo), Maybe (CInitializer NodeInfo),
 Maybe (CExpression NodeInfo))
d1:[(Maybe (CDeclarator NodeInfo), Maybe (CInitializer NodeInfo),
  Maybe (CExpression NodeInfo))]
ds) ->
            let declspecs' :: [CDeclarationSpecifier NodeInfo]
declspecs' = forall a b. (a -> b) -> [a] -> [b]
map forall {a}. CDeclarationSpecifier a -> CDeclarationSpecifier a
elideSUEDef [CDeclarationSpecifier NodeInfo]
declspecs in
            forall (m :: * -> *) a. Monad m => a -> m a
returnforall a b. (a -> b) -> a -> b
$ (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) forall a. a -> [a] -> [a]
: [ 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 CTypeSpecifier a
tyspec) =
        case CTypeSpecifier a
tyspec of
            (CEnumType (CEnum Maybe Ident
name Maybe [(Ident, Maybe (CExpression a))]
_def [CAttribute a]
_attrs a
enum_node) a
node_info) ->
                forall a. CTypeSpecifier a -> CDeclarationSpecifier a
CTypeSpec (forall a. CEnumeration a -> a -> CTypeSpecifier a
CEnumType (forall a.
Maybe Ident
-> Maybe [(Ident, Maybe (CExpression a))]
-> [CAttribute a]
-> a
-> CEnumeration a
CEnum Maybe Ident
name forall a. Maybe a
Nothing [] a
enum_node) a
node_info)
            (CSUType (CStruct CStructTag
tag Maybe Ident
name Maybe [CDeclaration a]
_def [CAttribute a]
_attrs a
su_node) a
node_info) ->
                forall a. CTypeSpecifier a -> CDeclarationSpecifier a
CTypeSpec (forall a. CStructureUnion a -> a -> CTypeSpecifier a
CSUType (forall a.
CStructTag
-> Maybe Ident
-> Maybe [CDeclaration a]
-> [CAttribute a]
-> a
-> CStructureUnion a
CStruct CStructTag
tag Maybe Ident
name forall a. Maybe a
Nothing [] a
su_node) a
node_info)
            CTypeSpecifier a
_ -> CDeclarationSpecifier a
declspec
    elideSUEDef 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 :: forall (m :: * -> *).
(MonadCError m, MonadSymtab m) =>
CAttribute NodeInfo -> m Attr
tAttr (CAttr Ident
name [CExpression NodeInfo]
cexpr NodeInfo
node) = forall (m :: * -> *) a. Monad m => a -> m a
returnforall 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 :: forall (m :: * -> *).
(MonadCError m, MonadSymtab m) =>
NodeInfo
-> Maybe Ident -> Maybe (CStringLiteral NodeInfo) -> m VarName
mkVarName  NodeInfo
_node Maybe Ident
Nothing Maybe (CStringLiteral NodeInfo)
_ = forall (m :: * -> *) a. Monad m => a -> m a
return VarName
NoName
mkVarName  NodeInfo
_node (Just Ident
n) Maybe (CStringLiteral NodeInfo)
asm = forall (m :: * -> *) a. Monad m => a -> m a
return 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 :: forall (m :: * -> *). MonadCError m => CDecl -> m Ident
nameOfDecl CDecl
d = forall (m :: * -> *).
MonadCError m =>
CDecl -> m (CDeclarator NodeInfo)
getOnlyDeclr CDecl
d forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \CDeclarator NodeInfo
declr ->
    case CDeclarator NodeInfo
declr of
        (CDeclr (Just Ident
name) [CDerivedDeclr]
_ Maybe (CStringLiteral NodeInfo)
_ [CAttribute NodeInfo]
_ NodeInfo
_node) -> forall (m :: * -> *) a. Monad m => a -> m a
return Ident
name
        (CDeclr Maybe Ident
Nothing [CDerivedDeclr]
_ Maybe (CStringLiteral NodeInfo)
_ [CAttribute NodeInfo]
_ NodeInfo
_node)     -> forall a. String -> a
internalErr String
"nameOfDecl: abstract declarator"
emptyDeclr :: NodeInfo -> CDeclr
emptyDeclr :: NodeInfo -> CDeclarator NodeInfo
emptyDeclr NodeInfo
node = forall a.
Maybe Ident
-> [CDerivedDeclarator a]
-> Maybe (CStringLiteral a)
-> [CAttribute a]
-> a
-> CDeclarator a
CDeclr forall a. Maybe a
Nothing [] forall a. Maybe a
Nothing [] NodeInfo
node
getOnlyDeclr :: (MonadCError m) => CDecl -> m CDeclr
getOnlyDeclr :: forall (m :: * -> *).
MonadCError m =>
CDecl -> m (CDeclarator NodeInfo)
getOnlyDeclr (CDecl [CDeclarationSpecifier NodeInfo]
_ [(Just CDeclarator NodeInfo
declr,Maybe (CInitializer NodeInfo)
_,Maybe (CExpression NodeInfo)
_)] NodeInfo
_) = forall (m :: * -> *) a. Monad m => a -> m a
return CDeclarator NodeInfo
declr
getOnlyDeclr (CDecl [CDeclarationSpecifier NodeInfo]
_ [(Maybe (CDeclarator NodeInfo), Maybe (CInitializer NodeInfo),
  Maybe (CExpression NodeInfo))]
_ NodeInfo
_node) = forall a. String -> a
internalErr String
"getOnlyDeclr: declaration doesn't have a unique declarator"
getOnlyDeclr (CStaticAssert CExpression NodeInfo
_ CStringLiteral NodeInfo
_ NodeInfo
_) = forall a. String -> a
internalErr String
"getOnlyDeclr: static assertion doesn't have a unique declarator"