--  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 :: AttrC -> CST s AttrC
nameAnalysis ac :: AttrC
ac  = do
                     (ac' :: AttrC
ac', _) <- CT () () -> AttrC -> () -> CST s (AttrC, ())
forall s a t. CT s a -> AttrC -> s -> CST t (AttrC, a)
runCT CT () ()
naCHeader AttrC
ac ()
                     AttrC -> CST s AttrC
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 :: CT () ()
naCHeader  = do
               -- establish definitions for builtins
               --
               ((Ident, CObj) -> CT () ()) -> [(Ident, CObj)] -> CT () ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ((Ident -> CObj -> CT () ()) -> (Ident, CObj) -> CT () ()
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Ident -> CObj -> CT () ()
defObjOrErr) [(Ident, CObj)]
builtinTypeNames
               --
               -- analyse the header
               --
               CHeader decls :: [CExtDecl]
decls _ <- CT () CHeader
forall s. CT s CHeader
getCHeaderCT
               (CExtDecl -> CT () ()) -> [CExtDecl] -> CT () ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (\decl :: CExtDecl
decl -> CExtDecl -> CT () ()
naCExtDecl CExtDecl
decl CT () () -> CT () () -> CT () ()
forall s a. CT s a -> CT s a -> CT s a
`ifCTExc` CT () ()
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 -> CT () ()
naCExtDecl (CDeclExt decl :: CDecl
decl                        ) = CDecl -> CT () ()
naCDecl CDecl
decl
naCExtDecl (CFDefExt (CFunDef specs :: [CDeclSpec]
specs declr :: CDeclr
declr _ _ at :: Attrs
at)) = 
  CDecl -> CT () ()
naCDecl (CDecl -> CT () ()) -> CDecl -> CT () ()
forall a b. (a -> b) -> a -> b
$ [CDeclSpec]
-> [(Maybe CDeclr, Maybe CInit, Maybe CExpr)] -> Attrs -> CDecl
CDecl [CDeclSpec]
specs [(CDeclr -> Maybe CDeclr
forall a. a -> Maybe a
Just CDeclr
declr, Maybe CInit
forall a. Maybe a
Nothing, Maybe CExpr
forall a. Maybe a
Nothing)] Attrs
at
naCExtDecl (CAsmExt at :: Attrs
at                           ) = () -> CT () ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

naCDecl :: CDecl -> NA ()
naCDecl :: CDecl -> CT () ()
naCDecl decl :: CDecl
decl@(CDecl specs :: [CDeclSpec]
specs decls :: [(Maybe CDeclr, Maybe CInit, Maybe CExpr)]
decls _) =
  do
    (CDeclSpec -> CT () ()) -> [CDeclSpec] -> CT () ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ CDeclSpec -> CT () ()
naCDeclSpec [CDeclSpec]
specs
    ((Maybe CDeclr, Maybe CInit, Maybe CExpr) -> CT () ())
-> [(Maybe CDeclr, Maybe CInit, Maybe CExpr)] -> CT () ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Maybe CDeclr, Maybe CInit, Maybe CExpr) -> CT () ()
naTriple [(Maybe CDeclr, Maybe CInit, Maybe CExpr)]
decls
  where
    naTriple :: (Maybe CDeclr, Maybe CInit, Maybe CExpr) -> CT () ()
naTriple (odeclr :: Maybe CDeclr
odeclr, oinit :: Maybe CInit
oinit, oexpr :: 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
        (CDeclr -> CT () ()) -> Maybe CDeclr -> CT () ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> Maybe a -> m ()
mapMaybeM_ (CObj -> CDeclr -> CT () ()
naCDeclr CObj
obj) Maybe CDeclr
odeclr
        (CInit -> CT () ()) -> Maybe CInit -> CT () ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> Maybe a -> m ()
mapMaybeM_ CInit -> CT () ()
naCInit        Maybe CInit
oinit
        (CExpr -> CT () ()) -> Maybe CExpr -> CT () ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> Maybe a -> m ()
mapMaybeM_ CExpr -> CT () ()
naCExpr        Maybe CExpr
oexpr

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

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

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

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

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

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

naCExpr :: CExpr -> NA ()
naCExpr :: CExpr -> CT () ()
naCExpr (CComma      exprs :: [CExpr]
exprs             _) = (CExpr -> CT () ()) -> [CExpr] -> CT () ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ CExpr -> CT () ()
naCExpr [CExpr]
exprs
naCExpr (CAssign     _ expr1 :: CExpr
expr1 expr2 :: CExpr
expr2     _) = CExpr -> CT () ()
naCExpr CExpr
expr1 CT () () -> CT () () -> CT () ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> CExpr -> CT () ()
naCExpr CExpr
expr2
naCExpr (CCond       expr1 :: CExpr
expr1 expr2 :: Maybe CExpr
expr2 expr3 :: CExpr
expr3 _) = CExpr -> CT () ()
naCExpr CExpr
expr1 CT () () -> CT () () -> CT () ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (CExpr -> CT () ()) -> Maybe CExpr -> CT () ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> Maybe a -> m ()
mapMaybeM_ CExpr -> CT () ()
naCExpr Maybe CExpr
expr2
                                            CT () () -> CT () () -> CT () ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> CExpr -> CT () ()
naCExpr CExpr
expr3
naCExpr (CBinary     _ expr1 :: CExpr
expr1 expr2 :: CExpr
expr2     _) = CExpr -> CT () ()
naCExpr CExpr
expr1 CT () () -> CT () () -> CT () ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> CExpr -> CT () ()
naCExpr CExpr
expr2
naCExpr (CCast       decl :: CDecl
decl expr :: CExpr
expr         _) = CDecl -> CT () ()
naCDecl CDecl
decl CT () () -> CT () () -> CT () ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> CExpr -> CT () ()
naCExpr CExpr
expr
naCExpr (CUnary      _ expr :: CExpr
expr            _) = CExpr -> CT () ()
naCExpr CExpr
expr
naCExpr (CSizeofExpr expr :: CExpr
expr              _) = CExpr -> CT () ()
naCExpr CExpr
expr
naCExpr (CSizeofType decl :: CDecl
decl              _) = CDecl -> CT () ()
naCDecl CDecl
decl
naCExpr (CAlignofExpr expr :: CExpr
expr             _) = CExpr -> CT () ()
naCExpr CExpr
expr
naCExpr (CAlignofType decl :: CDecl
decl             _) = CDecl -> CT () ()
naCDecl CDecl
decl
naCExpr (CIndex       expr1 :: CExpr
expr1 expr2 :: CExpr
expr2      _) = CExpr -> CT () ()
naCExpr CExpr
expr1 CT () () -> CT () () -> CT () ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> CExpr -> CT () ()
naCExpr CExpr
expr2
naCExpr (CCall        expr :: CExpr
expr exprs :: [CExpr]
exprs       _) = CExpr -> CT () ()
naCExpr CExpr
expr CT () () -> CT () () -> CT () ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (CExpr -> CT () ()) -> [CExpr] -> CT () ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ CExpr -> CT () ()
naCExpr [CExpr]
exprs
naCExpr (CMember      expr :: CExpr
expr ide :: Ident
ide _       _) = CExpr -> CT () ()
naCExpr CExpr
expr
naCExpr (CVar         ide :: Ident
ide              _) = do
                                             (obj :: CObj
obj, _) <- Ident -> Bool -> CT () (CObj, Ident)
forall s. Ident -> Bool -> CT s (CObj, Ident)
findValueObj Ident
ide Bool
False
                                             Ident
ide Ident -> CDef -> CT () ()
forall s. Ident -> CDef -> CT s ()
`refersToDef` CObj -> CDef
ObjCD CObj
obj
naCExpr (CConst       _                _) = CT () ()
forall e s. PreCST e s ()
nop
naCExpr (CCompoundLit _ inits :: CInitList
inits          _) = (([CDesignator], CInit) -> CT () ()) -> CInitList -> CT () ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (CInit -> CT () ()
naCInit (CInit -> CT () ())
-> (([CDesignator], CInit) -> CInit)
-> ([CDesignator], CInit)
-> CT () ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([CDesignator], CInit) -> CInit
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 ()
ide :: Ident
ide defTagOrErr :: Ident -> CTag -> CT () ()
`defTagOrErr` tag :: CTag
tag  = do
                           Maybe CTag
otag <- Ident
ide Ident -> CTag -> CT () (Maybe CTag)
forall s. Ident -> CTag -> CT s (Maybe CTag)
`defTag` CTag
tag
                           case Maybe CTag
otag of
                             Nothing   -> CT () ()
forall e s. PreCST e s ()
nop
                             Just tag' :: CTag
tag' -> Ident -> Position -> CT () ()
forall a. Ident -> Position -> NA a
declaredTwiceErr Ident
ide (CTag -> Position
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 ()
ide :: Ident
ide defObjOrErr :: Ident -> CObj -> CT () ()
`defObjOrErr` obj :: CObj
obj  = Ident
ide Ident -> CObj -> CT () (Maybe CObj)
forall s. Ident -> CObj -> CT s (Maybe CObj)
`defObj` CObj
obj CT () (Maybe CObj) -> CT () () -> CT () ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> CT () ()
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_ :: (a -> m b) -> Maybe a -> m ()
mapMaybeM_ m :: a -> m b
m Nothing   =        () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
mapMaybeM_ m :: a -> m b
m (Just a :: a
a)  = a -> m b
m a
a m b -> m () -> m ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()


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

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