--  C->Haskell Compiler: C name analysis
--
--  Author : Manuel M. T. Chakravarty
--  Created: 16 October 99
--
--  Version $Revision: 1.2 $ from $Date: 2005/07/29 01:26:56 $
--
--  Copyright (c) 1999 Manuel M. T. Chakravarty
--
--  This file is free software; you can redistribute it and/or modify
--  it under the terms of the GNU General Public License as published by
--  the Free Software Foundation; either version 2 of the License, or
--  (at your option) any later version.
--
--  This file is distributed in the hope that it will be useful,
--  but WITHOUT ANY WARRANTY; without even the implied warranty of
--  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
--  GNU General Public License for more details.
--
--- DESCRIPTION ---------------------------------------------------------------
--
--  Name analysis of C header files.
--
--- DOCU ----------------------------------------------------------------------
--
--  language: Haskell 98
--
--  * Member names are not looked up, because this requires type information
--    about the expressions before the `.' or `->'.
--
--- TODO ----------------------------------------------------------------------
--
--  * `defObjOrErr': currently, repeated declarations are completely ignored;
--   eventually, the consistency of the declarations should be checked
--

module CNames (nameAnalysis)
where

import Control.Monad     (when, mapM_)

import Position  (Position, posOf)
import Idents    (Ident, identToLexeme)

import C2HSState (CST, nop)
import CAST
import CAttrs    (AttrC, CObj(..), CTag(..), CDef(..))
import CBuiltin  (builtinTypeNames)
import CTrav     (CT, getCHeaderCT, runCT, enter, enterObjs, leave, leaveObjs,
                  ifCTExc, raiseErrorCTExc, defObj, findTypeObj, findValueObj,
                  defTag, refersToDef, isTypedef) 


-- monad and wrapper
-- -----------------

-- local instance of the C traversal monad
--
type NA a = CT () a

-- name analysis of C header files (EXPORTED)
--
nameAnalysis    :: AttrC -> CST s AttrC
nameAnalysis :: forall s. AttrC -> CST s AttrC
nameAnalysis AttrC
ac  = do
                     (AttrC
ac', ()
_) <- forall s a t. CT s a -> AttrC -> s -> CST t (AttrC, a)
runCT NA ()
naCHeader AttrC
ac ()
                     forall (m :: * -> *) a. Monad m => a -> m a
return AttrC
ac'


-- name analyis traversal
-- ----------------------

-- traverse a complete header file
--
--  * in case of an error, back off the current declaration
--
naCHeader :: NA ()
naCHeader :: NA ()
naCHeader  = do
               -- establish definitions for builtins
               --
               forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Ident -> CObj -> NA ()
defObjOrErr) [(Ident, CObj)]
builtinTypeNames
               --
               -- analyse the header
               --
               CHeader [CExtDecl]
decls Attrs
_ <- forall s. CT s CHeader
getCHeaderCT
               forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (\CExtDecl
decl -> CExtDecl -> NA ()
naCExtDecl CExtDecl
decl forall s a. CT s a -> CT s a -> CT s a
`ifCTExc` forall e s. PreCST e s ()
nop) [CExtDecl]
decls

-- Processing of toplevel declarations
--
--  * We turn function definitions into prototypes, as we are not interested in
--   function bodies.
--
naCExtDecl :: CExtDecl -> NA ()
naCExtDecl :: CExtDecl -> NA ()
naCExtDecl (CDeclExt CDecl
decl                        ) = CDecl -> NA ()
naCDecl CDecl
decl
naCExtDecl (CFDefExt (CFunDef [CDeclSpec]
specs CDeclr
declr [CDecl]
_ CStat
_ Attrs
at)) = 
  CDecl -> NA ()
naCDecl forall a b. (a -> b) -> a -> b
$ [CDeclSpec]
-> [(Maybe CDeclr, Maybe CInit, Maybe CExpr)] -> Attrs -> CDecl
CDecl [CDeclSpec]
specs [(forall a. a -> Maybe a
Just CDeclr
declr, forall a. Maybe a
Nothing, forall a. Maybe a
Nothing)] Attrs
at
naCExtDecl (CAsmExt Attrs
at                           ) = forall (m :: * -> *) a. Monad m => a -> m a
return ()

naCDecl :: CDecl -> NA ()
naCDecl :: CDecl -> NA ()
naCDecl decl :: CDecl
decl@(CDecl [CDeclSpec]
specs [(Maybe CDeclr, Maybe CInit, Maybe CExpr)]
decls Attrs
_) =
  do
    forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ CDeclSpec -> NA ()
naCDeclSpec [CDeclSpec]
specs
    forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Maybe CDeclr, Maybe CInit, Maybe CExpr) -> NA ()
naTriple [(Maybe CDeclr, Maybe CInit, Maybe CExpr)]
decls
  where
    naTriple :: (Maybe CDeclr, Maybe CInit, Maybe CExpr) -> NA ()
naTriple (Maybe CDeclr
odeclr, Maybe CInit
oinit, Maybe CExpr
oexpr) =
      do
        let obj :: CObj
obj = if CDecl -> Bool
isTypedef CDecl
decl then CDecl -> CObj
TypeCO CDecl
decl else CDecl -> CObj
ObjCO CDecl
decl
        forall (m :: * -> *) a b. Monad m => (a -> m b) -> Maybe a -> m ()
mapMaybeM_ (CObj -> CDeclr -> NA ()
naCDeclr CObj
obj) Maybe CDeclr
odeclr
        forall (m :: * -> *) a b. Monad m => (a -> m b) -> Maybe a -> m ()
mapMaybeM_ CInit -> NA ()
naCInit        Maybe CInit
oinit
        forall (m :: * -> *) a b. Monad m => (a -> m b) -> Maybe a -> m ()
mapMaybeM_ CExpr -> NA ()
naCExpr        Maybe CExpr
oexpr

naCDeclSpec :: CDeclSpec -> NA ()
naCDeclSpec :: CDeclSpec -> NA ()
naCDeclSpec (CTypeSpec CTypeSpec
tspec) = CTypeSpec -> NA ()
naCTypeSpec CTypeSpec
tspec
naCDeclSpec CDeclSpec
_                 = forall e s. PreCST e s ()
nop

naCTypeSpec :: CTypeSpec -> NA ()
naCTypeSpec :: CTypeSpec -> NA ()
naCTypeSpec (CSUType   CStructUnion
su   Attrs
_) = CTag -> CStructUnion -> NA ()
naCStructUnion (CStructUnion -> CTag
StructUnionCT CStructUnion
su) CStructUnion
su
naCTypeSpec (CEnumType CEnum
enum Attrs
_) = CTag -> CEnum -> NA ()
naCEnum (CEnum -> CTag
EnumCT CEnum
enum) CEnum
enum
naCTypeSpec (CTypeDef  Ident
ide  Attrs
_) = do
                                   (CObj
obj, Ident
_) <- forall s. Ident -> Bool -> CT s (CObj, Ident)
findTypeObj Ident
ide Bool
False
                                   Ident
ide forall s. Ident -> CDef -> CT s ()
`refersToDef` CObj -> CDef
ObjCD CObj
obj
naCTypeSpec CTypeSpec
_                  = forall e s. PreCST e s ()
nop

naCStructUnion :: CTag -> CStructUnion -> NA ()
naCStructUnion :: CTag -> CStructUnion -> NA ()
naCStructUnion CTag
tag (CStruct CStructTag
_ Maybe Ident
oide [CDecl]
decls Attrs
_) =
  do
    forall (m :: * -> *) a b. Monad m => (a -> m b) -> Maybe a -> m ()
mapMaybeM_ (Ident -> CTag -> NA ()
`defTagOrErr` CTag
tag) Maybe Ident
oide
    forall s. CT s ()
enterObjs                           -- enter local struct range for objects
    forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ CDecl -> NA ()
naCDecl [CDecl]
decls
    forall s. CT s ()
leaveObjs                           -- leave range

naCEnum :: CTag -> CEnum -> NA ()
naCEnum :: CTag -> CEnum -> NA ()
naCEnum CTag
tag enum :: CEnum
enum@(CEnum Maybe Ident
oide [(Ident, Maybe CExpr)]
enumrs Attrs
_) =
  do
    forall (m :: * -> *) a b. Monad m => (a -> m b) -> Maybe a -> m ()
mapMaybeM_ (Ident -> CTag -> NA ()
`defTagOrErr` CTag
tag) Maybe Ident
oide
    forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Ident, Maybe CExpr) -> NA ()
naEnumr [(Ident, Maybe CExpr)]
enumrs
  where
    naEnumr :: (Ident, Maybe CExpr) -> NA ()
naEnumr (Ident
ide, Maybe CExpr
oexpr) = do
                             Ident
ide Ident -> CObj -> NA ()
`defObjOrErr` Ident -> CEnum -> CObj
EnumCO Ident
ide CEnum
enum
                             forall (m :: * -> *) a b. Monad m => (a -> m b) -> Maybe a -> m ()
mapMaybeM_ CExpr -> NA ()
naCExpr Maybe CExpr
oexpr

naCDeclr :: CObj -> CDeclr -> NA ()
naCDeclr :: CObj -> CDeclr -> NA ()
naCDeclr CObj
obj (CVarDeclr Maybe Ident
oide Attrs
_) =
  forall (m :: * -> *) a b. Monad m => (a -> m b) -> Maybe a -> m ()
mapMaybeM_ (Ident -> CObj -> NA ()
`defObjOrErr` CObj
obj) Maybe Ident
oide
naCDeclr CObj
obj (CPtrDeclr [CTypeQual]
_ CDeclr
declr Attrs
_   ) =
  CObj -> CDeclr -> NA ()
naCDeclr CObj
obj CDeclr
declr
naCDeclr CObj
obj (CArrDeclr CDeclr
declr [CTypeQual]
_ Maybe CExpr
oexpr Attrs
_   ) =
  do
    CObj -> CDeclr -> NA ()
naCDeclr CObj
obj CDeclr
declr
    forall (m :: * -> *) a b. Monad m => (a -> m b) -> Maybe a -> m ()
mapMaybeM_ CExpr -> NA ()
naCExpr Maybe CExpr
oexpr
naCDeclr CObj
obj (CFunDeclr CDeclr
declr [CDecl]
decls Bool
_ Attrs
_ ) =
  do
    CObj -> CDeclr -> NA ()
naCDeclr CObj
obj CDeclr
declr
    forall s. CT s ()
enterObjs                           -- enter range of function arguments
    forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ CDecl -> NA ()
naCDecl [CDecl]
decls
    forall s. CT s ()
leaveObjs                           -- end of function arguments

naCInit :: CInit -> NA ()
naCInit :: CInit -> NA ()
naCInit (CInitExpr CExpr
expr  Attrs
_) = CExpr -> NA ()
naCExpr CExpr
expr
naCInit (CInitList CInitList
inits Attrs
_) = forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (CInit -> NA ()
naCInit forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) CInitList
inits

naCExpr :: CExpr -> NA ()
naCExpr :: CExpr -> NA ()
naCExpr (CComma      [CExpr]
exprs             Attrs
_) = forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ CExpr -> NA ()
naCExpr [CExpr]
exprs
naCExpr (CAssign     CAssignOp
_ CExpr
expr1 CExpr
expr2     Attrs
_) = CExpr -> NA ()
naCExpr CExpr
expr1 forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> CExpr -> NA ()
naCExpr CExpr
expr2
naCExpr (CCond       CExpr
expr1 Maybe CExpr
expr2 CExpr
expr3 Attrs
_) = CExpr -> NA ()
naCExpr CExpr
expr1 forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a b. Monad m => (a -> m b) -> Maybe a -> m ()
mapMaybeM_ CExpr -> NA ()
naCExpr Maybe CExpr
expr2
                                            forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> CExpr -> NA ()
naCExpr CExpr
expr3
naCExpr (CBinary     CBinaryOp
_ CExpr
expr1 CExpr
expr2     Attrs
_) = CExpr -> NA ()
naCExpr CExpr
expr1 forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> CExpr -> NA ()
naCExpr CExpr
expr2
naCExpr (CCast       CDecl
decl CExpr
expr         Attrs
_) = CDecl -> NA ()
naCDecl CDecl
decl forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> CExpr -> NA ()
naCExpr CExpr
expr
naCExpr (CUnary      CUnaryOp
_ CExpr
expr            Attrs
_) = CExpr -> NA ()
naCExpr CExpr
expr
naCExpr (CSizeofExpr CExpr
expr              Attrs
_) = CExpr -> NA ()
naCExpr CExpr
expr
naCExpr (CSizeofType CDecl
decl              Attrs
_) = CDecl -> NA ()
naCDecl CDecl
decl
naCExpr (CAlignofExpr CExpr
expr             Attrs
_) = CExpr -> NA ()
naCExpr CExpr
expr
naCExpr (CAlignofType CDecl
decl             Attrs
_) = CDecl -> NA ()
naCDecl CDecl
decl
naCExpr (CIndex       CExpr
expr1 CExpr
expr2      Attrs
_) = CExpr -> NA ()
naCExpr CExpr
expr1 forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> CExpr -> NA ()
naCExpr CExpr
expr2
naCExpr (CCall        CExpr
expr [CExpr]
exprs       Attrs
_) = CExpr -> NA ()
naCExpr CExpr
expr forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ CExpr -> NA ()
naCExpr [CExpr]
exprs
naCExpr (CMember      CExpr
expr Ident
ide Bool
_       Attrs
_) = CExpr -> NA ()
naCExpr CExpr
expr
naCExpr (CVar         Ident
ide              Attrs
_) = do
                                             (CObj
obj, Ident
_) <- forall s. Ident -> Bool -> CT s (CObj, Ident)
findValueObj Ident
ide Bool
False
                                             Ident
ide forall s. Ident -> CDef -> CT s ()
`refersToDef` CObj -> CDef
ObjCD CObj
obj
naCExpr (CConst       CConst
_                Attrs
_) = forall e s. PreCST e s ()
nop
naCExpr (CCompoundLit CDecl
_ CInitList
inits          Attrs
_) = forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (CInit -> NA ()
naCInit forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) CInitList
inits


-- auxilliary functions
-- --------------------

-- raise an error and exception if the identifier is defined twice
--
defTagOrErr           :: Ident -> CTag -> NA ()
Ident
ide defTagOrErr :: Ident -> CTag -> NA ()
`defTagOrErr` CTag
tag  = do
                           Maybe CTag
otag <- Ident
ide forall s. Ident -> CTag -> CT s (Maybe CTag)
`defTag` CTag
tag
                           case Maybe CTag
otag of
                             Maybe CTag
Nothing   -> forall e s. PreCST e s ()
nop
                             Just CTag
tag' -> forall a. Ident -> Position -> NA a
declaredTwiceErr Ident
ide (forall a. Pos a => a -> Position
posOf CTag
tag')

-- associate an object with a referring identifier
--
--  * currently, repeated declarations are completely ignored; eventually, the
--   consistency of the declarations should be checked
--
defObjOrErr           :: Ident -> CObj -> NA ()
Ident
ide defObjOrErr :: Ident -> CObj -> NA ()
`defObjOrErr` CObj
obj  = Ident
ide forall s. Ident -> CObj -> CT s (Maybe CObj)
`defObj` CObj
obj forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall e s. PreCST e s ()
nop

-- maps some monad operation into a `Maybe', discarding the result
--
mapMaybeM_ :: Monad m => (a -> m b) -> Maybe a -> m ()
mapMaybeM_ :: forall (m :: * -> *) a b. Monad m => (a -> m b) -> Maybe a -> m ()
mapMaybeM_ a -> m b
m Maybe a
Nothing   =        forall (m :: * -> *) a. Monad m => a -> m a
return ()
mapMaybeM_ a -> m b
m (Just a
a)  = a -> m b
m a
a forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return ()


-- error messages
-- --------------

declaredTwiceErr              :: Ident -> Position -> NA a
declaredTwiceErr :: forall a. Ident -> Position -> NA a
declaredTwiceErr Ident
ide Position
otherPos  =
  forall s a. Position -> [String] -> CT s a
raiseErrorCTExc (forall a. Pos a => a -> Position
posOf Ident
ide) 
    [String
"Identifier declared twice!",
     String
"The identifier `" forall a. [a] -> [a] -> [a]
++ Ident -> String
identToLexeme Ident
ide forall a. [a] -> [a] -> [a]
++ String
"' was already declared at " 
     forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Position
otherPos forall a. [a] -> [a] -> [a]
++ String
"."]