--  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 ac  = do
		     (ac', _) <- runCT naCHeader ac ()
		     return ac'


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

-- traverse a complete header file
--
-- * in case of an error, back off the current declaration
--
naCHeader :: NA ()
naCHeader  = do
	       -- establish definitions for builtins
	       --
	       mapM_ (uncurry defObjOrErr) builtinTypeNames
	       --
	       -- analyse the header
	       --
	       CHeader decls _ <- getCHeaderCT
	       mapM_ (\decl -> naCExtDecl decl `ifCTExc` nop) decls

-- Processing of toplevel declarations
--
-- * We turn function definitions into prototypes, as we are not interested in
--   function bodies.
--
naCExtDecl :: CExtDecl -> NA ()
naCExtDecl (CDeclExt decl                        ) = naCDecl decl
naCExtDecl (CFDefExt (CFunDef specs declr _ _ at)) = 
  naCDecl $ CDecl specs [(Just declr, Nothing, Nothing)] at
naCExtDecl (CAsmExt at                           ) = return ()

naCDecl :: CDecl -> NA ()
naCDecl decl@(CDecl specs decls _) =
  do
    mapM_ naCDeclSpec specs
    mapM_ naTriple decls
  where
    naTriple (odeclr, oinit, oexpr) =
      do
	let obj = if isTypedef decl then TypeCO decl else ObjCO decl
        mapMaybeM_ (naCDeclr obj) odeclr
	mapMaybeM_ naCInit	  oinit
	mapMaybeM_ naCExpr	  oexpr

naCDeclSpec :: CDeclSpec -> NA ()
naCDeclSpec (CTypeSpec tspec) = naCTypeSpec tspec
naCDeclSpec _		      = nop

naCTypeSpec :: CTypeSpec -> NA ()
naCTypeSpec (CSUType   su   _) = naCStructUnion (StructUnionCT su) su
naCTypeSpec (CEnumType enum _) = naCEnum (EnumCT enum) enum
naCTypeSpec (CTypeDef  ide  _) = do
				   (obj, _) <- findTypeObj ide False
				   ide `refersToDef` ObjCD obj
naCTypeSpec _		       = nop

naCStructUnion :: CTag -> CStructUnion -> NA ()
naCStructUnion tag (CStruct _ oide decls _) =
  do
    mapMaybeM_ (`defTagOrErr` tag) oide
    enterObjs				-- enter local struct range for objects
    mapM_ naCDecl decls
    leaveObjs				-- leave range

naCEnum :: CTag -> CEnum -> NA ()
naCEnum tag enum@(CEnum oide enumrs _) =
  do
    mapMaybeM_ (`defTagOrErr` tag) oide
    mapM_ naEnumr enumrs
  where
    naEnumr (ide, oexpr) = do
			     ide `defObjOrErr` EnumCO ide enum
			     mapMaybeM_ naCExpr oexpr

naCDeclr :: CObj -> CDeclr -> NA ()
naCDeclr obj (CVarDeclr oide _) =
  mapMaybeM_ (`defObjOrErr` obj) oide
naCDeclr obj (CPtrDeclr _ declr _   ) =
  naCDeclr obj declr
naCDeclr obj (CArrDeclr declr _ oexpr _   ) =
  do
    naCDeclr obj declr
    mapMaybeM_ naCExpr oexpr
naCDeclr obj (CFunDeclr declr decls _ _ ) =
  do
    naCDeclr obj declr
    enterObjs				-- enter range of function arguments
    mapM_ naCDecl decls
    leaveObjs				-- end of function arguments

naCInit :: CInit -> NA ()
naCInit (CInitExpr expr  _) = naCExpr expr
naCInit (CInitList inits _) = mapM_ (naCInit . snd) inits

naCExpr :: CExpr -> NA ()
naCExpr (CComma      exprs             _) = mapM_ naCExpr exprs
naCExpr (CAssign     _ expr1 expr2     _) = naCExpr expr1 >> naCExpr expr2
naCExpr (CCond       expr1 expr2 expr3 _) = naCExpr expr1 >> mapMaybeM_ naCExpr expr2
					    >> naCExpr expr3
naCExpr (CBinary     _ expr1 expr2     _) = naCExpr expr1 >> naCExpr expr2
naCExpr (CCast       decl expr	       _) = naCDecl decl >> naCExpr expr
naCExpr (CUnary      _ expr	       _) = naCExpr expr
naCExpr (CSizeofExpr expr              _) = naCExpr expr
naCExpr (CSizeofType decl	       _) = naCDecl decl
naCExpr (CAlignofExpr expr             _) = naCExpr expr
naCExpr (CAlignofType decl	       _) = naCDecl decl
naCExpr (CIndex	      expr1 expr2      _) = naCExpr expr1 >> naCExpr expr2
naCExpr (CCall	      expr exprs       _) = naCExpr expr >> mapM_ naCExpr exprs
naCExpr (CMember      expr ide _       _) = naCExpr expr
naCExpr (CVar	      ide	       _) = do
					     (obj, _) <- findValueObj ide False
					     ide `refersToDef` ObjCD obj
naCExpr (CConst	      _		       _) = nop
naCExpr (CCompoundLit _ inits          _) = mapM_ (naCInit . snd) inits


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

-- raise an error and exception if the identifier is defined twice
--
defTagOrErr           :: Ident -> CTag -> NA ()
ide `defTagOrErr` tag  = do
			   otag <- ide `defTag` tag
			   case otag of
			     Nothing   -> nop
			     Just tag' -> declaredTwiceErr ide (posOf 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 `defObjOrErr` obj  = ide `defObj` obj >> nop

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


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

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