--  C->Haskell Compiler: traversals of C structure tree
--
--  Author : Manuel M. T. Chakravarty
--  Created: 16 October 99
--
--  Version $Revision: 1.1 $ from $Date: 2004/11/21 21:05:27 $
--
--  Copyright (c) [1999..2001] 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 ---------------------------------------------------------------
--
--  This modules provides for traversals of C structure trees.  The C
--  traversal monad supports traversals that need convenient access to the
--  attributes of an attributed C structure tree.  The monads state can still
--  be extended.
--
--- DOCU ----------------------------------------------------------------------
--
--  language: Haskell 98
--
--  Handling of redefined tag values
--  --------------------------------
--
--  Structures allow both
--
--    struct s {...} ...;
--    struct s       ...;
--
--  and
--
--    struct s       ...;       /* this is called a forward reference */
--    struct s {...} ...;
--
--  In contrast enumerations only allow (in ANSI C)
--
--    enum e {...} ...;
--    enum e       ...;
--
--  The function `defTag' handles both types and establishes an object
--  association from the tag identifier in the empty declaration (ie, the one
--  without `{...}') to the actually definition of the structure of
--  enumeration.  This implies that when looking for the details of a
--  structure or enumeration, possibly a chain of references on tag
--  identifiers has to be chased.  Note that the object association attribute
--  is _not_defined_ when the `{...}'  part is present in a declaration.
--
--- TODO ----------------------------------------------------------------------
--
--  * `extractStruct' doesn't account for forward declarations that have no
--   full declaration yet; if `extractStruct' is called on such a declaration, 
--   we have a user error, but currently an internal error is raised
--

module CTrav (CT, readCT, transCT, getCHeaderCT, runCT, throwCTExc, ifCTExc,
              raiseErrorCTExc,
              enter, enterObjs, leave, leaveObjs, defObj, findObj,
              findObjShadow, defTag, findTag, findTagShadow,
              applyPrefixToNameSpaces, getDefOf, refersToDef, refersToNewDef,
              getDeclOf, findTypeObjMaybe, findTypeObj, findValueObj,
              findFunObj,
              --
              -- C structure tree query functions
              --
              isTypedef, simplifyDecl, declrFromDecl, declrNamed,
              declaredDeclr, declaredName, structMembers, expandDecl,
              structName, enumName, tagName, isArrDeclr, isPtrDeclr, dropPtrDeclr,
              isPtrDecl, isFunDeclr, structFromDecl, funResultAndArgs,
              chaseDecl, findAndChaseDecl, checkForAlias,
              checkForOneAliasName, lookupEnum, lookupStructUnion,
              lookupDeclOrTag)
where

import Data.List       (find)
import Data.Maybe         (fromMaybe)
import Control.Monad      (liftM)
import Control.Exception (assert)

import Position   (Position, Pos(..), nopos)
import Errors     (interr)
import Idents     (Ident, dumpIdent, identToLexeme)
import Attributes (Attr(..), newAttrsOnlyPos)

import C2HSState  (CST, nop, readCST, transCST, runCST, raiseError, catchExc,
                   throwExc, Traces(..), putTraceStr)
import CAST
import CAttrs     (AttrC, getCHeader, enterNewRangeC, enterNewObjRangeC,
                   leaveRangeC, leaveObjRangeC, addDefObjC, lookupDefObjC,
                   lookupDefObjCShadow, addDefTagC, lookupDefTagC,
                   lookupDefTagCShadow, applyPrefix, getDefOfIdentC,
                   setDefOfIdentC, updDefOfIdentC, CObj(..), CTag(..),
                   CDef(..)) 


-- the C traversal monad
-- ---------------------

-- C traversal monad (EXPORTED ABSTRACTLY)
--
type CState s    = (AttrC, s)
type CT     s a  = CST (CState s) a

-- read attributed structure tree
--
readAttrCCT        :: (AttrC -> a) -> CT s a
readAttrCCT :: forall a s. (AttrC -> a) -> CT s a
readAttrCCT AttrC -> a
reader  = (CState s -> a) -> PreCST SwitchBoard (CState s) a
forall s a e. (s -> a) -> PreCST e s a
readCST ((CState s -> a) -> PreCST SwitchBoard (CState s) a)
-> (CState s -> a) -> PreCST SwitchBoard (CState s) a
forall a b. (a -> b) -> a -> b
$ \(AttrC
ac, s
_) -> AttrC -> a
reader AttrC
ac

-- transform attributed structure tree
--
transAttrCCT       :: (AttrC -> (AttrC, a)) -> CT s a
transAttrCCT :: forall a s. (AttrC -> (AttrC, a)) -> CT s a
transAttrCCT AttrC -> (AttrC, a)
trans  = (CState s -> (CState s, a)) -> PreCST SwitchBoard (CState s) a
forall s a e. (s -> (s, a)) -> PreCST e s a
transCST ((CState s -> (CState s, a)) -> PreCST SwitchBoard (CState s) a)
-> (CState s -> (CState s, a)) -> PreCST SwitchBoard (CState s) a
forall a b. (a -> b) -> a -> b
$ \(AttrC
ac, s
s) -> let
                                               (AttrC
ac', a
r) = AttrC -> (AttrC, a)
trans AttrC
ac
                                             in
                                             ((AttrC
ac', s
s), a
r)

-- access to the user-defined state
--

-- read user-defined state (EXPORTED)
--
readCT        :: (s -> a) -> CT s a
readCT :: forall s a. (s -> a) -> CT s a
readCT s -> a
reader  = (CState s -> a) -> PreCST SwitchBoard (CState s) a
forall s a e. (s -> a) -> PreCST e s a
readCST ((CState s -> a) -> PreCST SwitchBoard (CState s) a)
-> (CState s -> a) -> PreCST SwitchBoard (CState s) a
forall a b. (a -> b) -> a -> b
$ \(AttrC
_, s
s) -> s -> a
reader s
s

-- transform user-defined state (EXPORTED)
--
transCT       :: (s -> (s, a)) -> CT s a
transCT :: forall s a. (s -> (s, a)) -> CT s a
transCT s -> (s, a)
trans  = (CState s -> (CState s, a)) -> PreCST SwitchBoard (CState s) a
forall s a e. (s -> (s, a)) -> PreCST e s a
transCST ((CState s -> (CState s, a)) -> PreCST SwitchBoard (CState s) a)
-> (CState s -> (CState s, a)) -> PreCST SwitchBoard (CState s) a
forall a b. (a -> b) -> a -> b
$ \(AttrC
ac, s
s) -> let
                                          (s
s', a
r) = s -> (s, a)
trans s
s
                                        in
                                        ((AttrC
ac, s
s'), a
r)

-- usage of a traversal monad
--

-- get the raw C header from the monad (EXPORTED)
--
getCHeaderCT :: CT s CHeader
getCHeaderCT :: forall s. CT s CHeader
getCHeaderCT  = (AttrC -> CHeader) -> CT s CHeader
forall a s. (AttrC -> a) -> CT s a
readAttrCCT AttrC -> CHeader
getCHeader

-- execute a traversal monad (EXPORTED)
--
--  * given a traversal monad, an attribute structure tree, and a user
--   state, the transformed structure tree and monads result are returned
--
runCT        :: CT s a -> AttrC -> s -> CST t (AttrC, a)
runCT :: forall s a t. CT s a -> AttrC -> s -> CST t (AttrC, a)
runCT CT s a
m AttrC
ac s
s  = PreCST SwitchBoard (CState s) (AttrC, a)
-> CState s -> PreCST SwitchBoard t (AttrC, a)
forall e s a s'. PreCST e s a -> s -> PreCST e s' a
runCST PreCST SwitchBoard (CState s) (AttrC, a)
m' (AttrC
ac, s
s)
                where
                  m' :: PreCST SwitchBoard (CState s) (AttrC, a)
m' = do
                         r <- CT s a
m
                         (ac, _) <- readCST id
                         return (ac, r)


-- exception handling
-- ------------------

-- exception identifier
--
ctExc :: String
ctExc :: String
ctExc  = String
"ctExc"

-- throw an exception  (EXPORTED)
--
throwCTExc :: CT s a
throwCTExc :: forall s a. CT s a
throwCTExc  = String -> String -> PreCST SwitchBoard (CState s) a
forall e s a. String -> String -> PreCST e s a
throwExc String
ctExc String
"Error during traversal of a C structure tree"

-- catch a `ctExc'  (EXPORTED)
--
ifCTExc           :: CT s a -> CT s a -> CT s a
ifCTExc :: forall s a. CT s a -> CT s a -> CT s a
ifCTExc CT s a
m CT s a
handler  = CT s a
m CT s a -> (String, String -> CT s a) -> CT s a
forall e s a.
PreCST e s a -> (String, String -> PreCST e s a) -> PreCST e s a
`catchExc` (String
ctExc, CT s a -> String -> CT s a
forall a b. a -> b -> a
const CT s a
handler)

-- raise an error followed by throwing a CT exception (EXPORTED)
--
raiseErrorCTExc          :: Position -> [String] -> CT s a
raiseErrorCTExc :: forall s a. Position -> [String] -> CT s a
raiseErrorCTExc Position
pos [String]
errs  = Position -> [String] -> PreCST SwitchBoard (CState s) ()
forall e s. Position -> [String] -> PreCST e s ()
raiseError Position
pos [String]
errs PreCST SwitchBoard (CState s) ()
-> PreCST SwitchBoard (CState s) a
-> PreCST SwitchBoard (CState s) a
forall a b.
PreCST SwitchBoard (CState s) a
-> PreCST SwitchBoard (CState s) b
-> PreCST SwitchBoard (CState s) b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> PreCST SwitchBoard (CState s) a
forall s a. CT s a
throwCTExc


-- attribute manipulation
-- ----------------------

-- name spaces
--

-- enter a new local range (EXPORTED)
--
enter :: CT s ()
enter :: forall s. CT s ()
enter  = (AttrC -> (AttrC, ())) -> CT s ()
forall a s. (AttrC -> (AttrC, a)) -> CT s a
transAttrCCT ((AttrC -> (AttrC, ())) -> CT s ())
-> (AttrC -> (AttrC, ())) -> CT s ()
forall a b. (a -> b) -> a -> b
$ \AttrC
ac -> (AttrC -> AttrC
enterNewRangeC AttrC
ac, ())

-- enter a new local range, only for objects (EXPORTED)
--
enterObjs :: CT s ()
enterObjs :: forall s. CT s ()
enterObjs  = (AttrC -> (AttrC, ())) -> CT s ()
forall a s. (AttrC -> (AttrC, a)) -> CT s a
transAttrCCT ((AttrC -> (AttrC, ())) -> CT s ())
-> (AttrC -> (AttrC, ())) -> CT s ()
forall a b. (a -> b) -> a -> b
$ \AttrC
ac -> (AttrC -> AttrC
enterNewObjRangeC AttrC
ac, ())

-- leave the current local range (EXPORTED)
--
leave :: CT s ()
leave :: forall s. CT s ()
leave  = (AttrC -> (AttrC, ())) -> CT s ()
forall a s. (AttrC -> (AttrC, a)) -> CT s a
transAttrCCT ((AttrC -> (AttrC, ())) -> CT s ())
-> (AttrC -> (AttrC, ())) -> CT s ()
forall a b. (a -> b) -> a -> b
$ \AttrC
ac -> (AttrC -> AttrC
leaveRangeC AttrC
ac, ())

-- leave the current local range, only for objects (EXPORTED)
--
leaveObjs :: CT s ()
leaveObjs :: forall s. CT s ()
leaveObjs  = (AttrC -> (AttrC, ())) -> CT s ()
forall a s. (AttrC -> (AttrC, a)) -> CT s a
transAttrCCT ((AttrC -> (AttrC, ())) -> CT s ())
-> (AttrC -> (AttrC, ())) -> CT s ()
forall a b. (a -> b) -> a -> b
$ \AttrC
ac -> (AttrC -> AttrC
leaveObjRangeC AttrC
ac, ())

-- enter an object definition into the object name space (EXPORTED)
--
--  * if a definition of the same name was already present, it is returned 
--
defObj         :: Ident -> CObj -> CT s (Maybe CObj)
defObj :: forall s. Ident -> CObj -> CT s (Maybe CObj)
defObj Ident
ide CObj
obj  = (AttrC -> (AttrC, Maybe CObj)) -> CT s (Maybe CObj)
forall a s. (AttrC -> (AttrC, a)) -> CT s a
transAttrCCT ((AttrC -> (AttrC, Maybe CObj)) -> CT s (Maybe CObj))
-> (AttrC -> (AttrC, Maybe CObj)) -> CT s (Maybe CObj)
forall a b. (a -> b) -> a -> b
$ \AttrC
ac -> AttrC -> Ident -> CObj -> (AttrC, Maybe CObj)
addDefObjC AttrC
ac Ident
ide CObj
obj

-- find a definition in the object name space (EXPORTED)
--
findObj     :: Ident -> CT s (Maybe CObj)
findObj :: forall s. Ident -> CT s (Maybe CObj)
findObj Ident
ide  = (AttrC -> Maybe CObj) -> CT s (Maybe CObj)
forall a s. (AttrC -> a) -> CT s a
readAttrCCT ((AttrC -> Maybe CObj) -> CT s (Maybe CObj))
-> (AttrC -> Maybe CObj) -> CT s (Maybe CObj)
forall a b. (a -> b) -> a -> b
$ \AttrC
ac -> AttrC -> Ident -> Maybe CObj
lookupDefObjC AttrC
ac Ident
ide

-- find a definition in the object name space; if nothing found, try 
-- whether there is a shadow identifier that matches (EXPORTED)
--
findObjShadow     :: Ident -> CT s (Maybe (CObj, Ident))
findObjShadow :: forall s. Ident -> CT s (Maybe (CObj, Ident))
findObjShadow Ident
ide  = (AttrC -> Maybe (CObj, Ident)) -> CT s (Maybe (CObj, Ident))
forall a s. (AttrC -> a) -> CT s a
readAttrCCT ((AttrC -> Maybe (CObj, Ident)) -> CT s (Maybe (CObj, Ident)))
-> (AttrC -> Maybe (CObj, Ident)) -> CT s (Maybe (CObj, Ident))
forall a b. (a -> b) -> a -> b
$ \AttrC
ac -> AttrC -> Ident -> Maybe (CObj, Ident)
lookupDefObjCShadow AttrC
ac Ident
ide

-- enter a tag definition into the tag name space (EXPORTED)
--
--  * empty definitions of structures get overwritten with complete ones and a
--   forward reference is added to their tag identifier; furthermore, both
--   structures and enums may be referenced using an empty definition when
--   there was a full definition earlier and in this case there is also an
--   object association added; otherwise, if a definition of the same name was
--   already present, it is returned (see DOCU section)
--
--  * it is checked that the first occurrence of an enumeration tag is
--   accompanied by a full definition of the enumeration
--
defTag         :: Ident -> CTag -> CT s (Maybe CTag)
defTag :: forall s. Ident -> CTag -> CT s (Maybe CTag)
defTag Ident
ide CTag
tag  = 
  do
    otag <- (AttrC -> (AttrC, Maybe CTag)) -> CT s (Maybe CTag)
forall a s. (AttrC -> (AttrC, a)) -> CT s a
transAttrCCT ((AttrC -> (AttrC, Maybe CTag)) -> CT s (Maybe CTag))
-> (AttrC -> (AttrC, Maybe CTag)) -> CT s (Maybe CTag)
forall a b. (a -> b) -> a -> b
$ \AttrC
ac -> AttrC -> Ident -> CTag -> (AttrC, Maybe CTag)
addDefTagC AttrC
ac Ident
ide CTag
tag
    case otag of
      Maybe CTag
Nothing      -> do
                        CTag -> CT s ()
forall s. CTag -> CT s ()
assertIfEnumThenFull CTag
tag
                        Maybe CTag -> CT s (Maybe CTag)
forall a. a -> PreCST SwitchBoard (CState s) a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe CTag
forall a. Maybe a
Nothing                  -- no collision
      Just CTag
prevTag -> case CTag -> CTag -> Maybe (CTag, Ident)
isRefinedOrUse CTag
prevTag CTag
tag of
                         Maybe (CTag, Ident)
Nothing                 -> Maybe CTag -> CT s (Maybe CTag)
forall a. a -> PreCST SwitchBoard (CState s) a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe CTag
otag
                         Just (CTag
fullTag, Ident
foreIde) -> do
                           (AttrC -> (AttrC, Maybe CTag)) -> CT s (Maybe CTag)
forall a s. (AttrC -> (AttrC, a)) -> CT s a
transAttrCCT ((AttrC -> (AttrC, Maybe CTag)) -> CT s (Maybe CTag))
-> (AttrC -> (AttrC, Maybe CTag)) -> CT s (Maybe CTag)
forall a b. (a -> b) -> a -> b
$ \AttrC
ac -> AttrC -> Ident -> CTag -> (AttrC, Maybe CTag)
addDefTagC AttrC
ac Ident
ide CTag
fullTag
                           Ident
foreIde Ident -> CDef -> CT s ()
forall s. Ident -> CDef -> CT s ()
`refersToDef` CTag -> CDef
TagCD CTag
fullTag
                           Maybe CTag -> CT s (Maybe CTag)
forall a. a -> PreCST SwitchBoard (CState s) a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe CTag
forall a. Maybe a
Nothing               -- transparent for env
  where
    -- compute whether we have the case of a non-conflicting redefined tag
    -- definition, and if so, return the full definition and the forward 
    -- definition's tag identifier
    --
    --  * the first argument contains the _previous_ definition
    --
    --  * in the case of a structure, a forward definition after a full
    --   definition is allowed, so we have to handle this case; enumerations
    --   don't allow forward definitions
    --
    --  * there may also be multiple forward definition; if we have two of
    --   them here, one is arbitrarily selected to take the role of the full
    --   definition 
    --
    isRefinedOrUse :: CTag -> CTag -> Maybe (CTag, Ident)
isRefinedOrUse     (StructUnionCT (CStruct CStructTag
_ (Just Ident
ide) [] Attrs
_))
                   tag :: CTag
tag@(StructUnionCT (CStruct CStructTag
_ (Just Ident
_  ) [CDecl]
_  Attrs
_)) = 
      (CTag, Ident) -> Maybe (CTag, Ident)
forall a. a -> Maybe a
Just (CTag
tag, Ident
ide)
    isRefinedOrUse tag :: CTag
tag@(StructUnionCT (CStruct CStructTag
_ (Just Ident
_  ) [CDecl]
_  Attrs
_))
                       (StructUnionCT (CStruct CStructTag
_ (Just Ident
ide) [] Attrs
_)) = 
      (CTag, Ident) -> Maybe (CTag, Ident)
forall a. a -> Maybe a
Just (CTag
tag, Ident
ide)
    isRefinedOrUse tag :: CTag
tag@(EnumCT        (CEnum (Just Ident
_  ) [(Ident, Maybe CExpr)]
_  Attrs
_))
                       (EnumCT        (CEnum (Just Ident
ide) [] Attrs
_))     = 
      (CTag, Ident) -> Maybe (CTag, Ident)
forall a. a -> Maybe a
Just (CTag
tag, Ident
ide)
    isRefinedOrUse CTag
_ CTag
_                                             = Maybe (CTag, Ident)
forall a. Maybe a
Nothing

-- find an definition in the tag name space (EXPORTED)
--
findTag     :: Ident -> CT s (Maybe CTag)
findTag :: forall s. Ident -> CT s (Maybe CTag)
findTag Ident
ide  = (AttrC -> Maybe CTag) -> CT s (Maybe CTag)
forall a s. (AttrC -> a) -> CT s a
readAttrCCT ((AttrC -> Maybe CTag) -> CT s (Maybe CTag))
-> (AttrC -> Maybe CTag) -> CT s (Maybe CTag)
forall a b. (a -> b) -> a -> b
$ \AttrC
ac -> AttrC -> Ident -> Maybe CTag
lookupDefTagC AttrC
ac Ident
ide

-- find an definition in the tag name space; if nothing found, try 
-- whether there is a shadow identifier that matches (EXPORTED)
--
findTagShadow     :: Ident -> CT s (Maybe (CTag, Ident))
findTagShadow :: forall s. Ident -> CT s (Maybe (CTag, Ident))
findTagShadow Ident
ide  = (AttrC -> Maybe (CTag, Ident)) -> CT s (Maybe (CTag, Ident))
forall a s. (AttrC -> a) -> CT s a
readAttrCCT ((AttrC -> Maybe (CTag, Ident)) -> CT s (Maybe (CTag, Ident)))
-> (AttrC -> Maybe (CTag, Ident)) -> CT s (Maybe (CTag, Ident))
forall a b. (a -> b) -> a -> b
$ \AttrC
ac -> AttrC -> Ident -> Maybe (CTag, Ident)
lookupDefTagCShadow AttrC
ac Ident
ide

-- enrich the object and tag name space with identifiers obtained by dropping
-- the given prefix from the identifiers already in the name space (EXPORTED)
--
--  * if a new identifier would collides with an existing one, the new one is
--   discarded, ie, all associations that existed before the transformation
--   started are still in effect after the transformation
-- 
applyPrefixToNameSpaces        :: String -> CT s ()
applyPrefixToNameSpaces :: forall s. String -> CT s ()
applyPrefixToNameSpaces String
prefix  = 
  (AttrC -> (AttrC, ())) -> CT s ()
forall a s. (AttrC -> (AttrC, a)) -> CT s a
transAttrCCT ((AttrC -> (AttrC, ())) -> CT s ())
-> (AttrC -> (AttrC, ())) -> CT s ()
forall a b. (a -> b) -> a -> b
$ \AttrC
ac -> (AttrC -> String -> AttrC
applyPrefix AttrC
ac String
prefix, ())

-- definition attribute
--

-- get the definition of an identifier (EXPORTED) 
--
--  * the attribute must be defined, ie, a definition must be associated with
--   the given identifier
--
getDefOf     :: Ident -> CT s CDef
getDefOf :: forall s. Ident -> CT s CDef
getDefOf Ident
ide  = do
                  def <- (AttrC -> CDef) -> CT s CDef
forall a s. (AttrC -> a) -> CT s a
readAttrCCT ((AttrC -> CDef) -> CT s CDef) -> (AttrC -> CDef) -> CT s CDef
forall a b. (a -> b) -> a -> b
$ \AttrC
ac -> AttrC -> Ident -> CDef
getDefOfIdentC AttrC
ac Ident
ide
                  assert (not . isUndef $ def) $
                    return def

-- set the definition of an identifier (EXPORTED) 
--
refersToDef         :: Ident -> CDef -> CT s ()
refersToDef :: forall s. Ident -> CDef -> CT s ()
refersToDef Ident
ide CDef
def  = (AttrC -> (AttrC, ())) -> CT s ()
forall a s. (AttrC -> (AttrC, a)) -> CT s a
transAttrCCT ((AttrC -> (AttrC, ())) -> CT s ())
-> (AttrC -> (AttrC, ())) -> CT s ()
forall a b. (a -> b) -> a -> b
$ \AttrC
akl -> (AttrC -> Ident -> CDef -> AttrC
setDefOfIdentC AttrC
akl Ident
ide CDef
def, ())

-- update the definition of an identifier (EXPORTED) 
--
refersToNewDef         :: Ident -> CDef -> CT s ()
refersToNewDef :: forall s. Ident -> CDef -> CT s ()
refersToNewDef Ident
ide CDef
def  = 
  (AttrC -> (AttrC, ())) -> CT s ()
forall a s. (AttrC -> (AttrC, a)) -> CT s a
transAttrCCT ((AttrC -> (AttrC, ())) -> CT s ())
-> (AttrC -> (AttrC, ())) -> CT s ()
forall a b. (a -> b) -> a -> b
$ \AttrC
akl -> (AttrC -> Ident -> CDef -> AttrC
updDefOfIdentC AttrC
akl Ident
ide CDef
def, ())

-- get the declarator of an identifier (EXPORTED)
--
getDeclOf     :: Ident -> CT s CDecl
getDeclOf :: forall s. Ident -> CT s CDecl
getDeclOf Ident
ide  = 
  do
    CT s ()
forall s. CT s ()
traceEnter
    def <- Ident -> CT s CDef
forall s. Ident -> CT s CDef
getDefOf Ident
ide
    case def of
      CDef
UndefCD    -> String -> PreCST SwitchBoard (CState s) CDecl
forall a. String -> a
interr String
"CTrav.getDeclOf: Undefined!"
      CDef
DontCareCD -> String -> PreCST SwitchBoard (CState s) CDecl
forall a. String -> a
interr String
"CTrav.getDeclOf: Don't care!"
      TagCD CTag
_    -> String -> PreCST SwitchBoard (CState s) CDecl
forall a. String -> a
interr String
"CTrav.getDeclOf: Illegal tag!"
      ObjCD CObj
obj  -> case CObj
obj of
                      TypeCO    CDecl
decl -> CT s ()
forall s. CT s ()
traceTypeCO CT s ()
-> PreCST SwitchBoard (CState s) CDecl
-> PreCST SwitchBoard (CState s) CDecl
forall a b.
PreCST SwitchBoard (CState s) a
-> PreCST SwitchBoard (CState s) b
-> PreCST SwitchBoard (CState s) b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>>
                                        CDecl -> PreCST SwitchBoard (CState s) CDecl
forall a. a -> PreCST SwitchBoard (CState s) a
forall (m :: * -> *) a. Monad m => a -> m a
return CDecl
decl
                      ObjCO     CDecl
decl -> CT s ()
forall s. CT s ()
traceObjCO CT s ()
-> PreCST SwitchBoard (CState s) CDecl
-> PreCST SwitchBoard (CState s) CDecl
forall a b.
PreCST SwitchBoard (CState s) a
-> PreCST SwitchBoard (CState s) b
-> PreCST SwitchBoard (CState s) b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>>
                                        CDecl -> PreCST SwitchBoard (CState s) CDecl
forall a. a -> PreCST SwitchBoard (CState s) a
forall (m :: * -> *) a. Monad m => a -> m a
return CDecl
decl
                      EnumCO    Ident
_ CEnum
_  -> PreCST SwitchBoard (CState s) CDecl
forall {a}. a
illegalEnum
                      CObj
BuiltinCO      -> PreCST SwitchBoard (CState s) CDecl
forall {a}. a
illegalBuiltin
  where
    illegalEnum :: a
illegalEnum    = String -> a
forall a. String -> a
interr String
"CTrav.getDeclOf: Illegal enum!"
    illegalBuiltin :: a
illegalBuiltin = String -> a
forall a. String -> a
interr String
"CTrav.getDeclOf: Attempted to get declarator of \
                            \builtin entity!"
                     -- if the latter ever becomes necessary, we have to
                     -- change the representation of builtins and give them
                     -- some dummy declarator
    traceEnter :: CT s ()
traceEnter  = String -> CT s ()
forall s. String -> CT s ()
traceCTrav (String -> CT s ()) -> String -> CT s ()
forall a b. (a -> b) -> a -> b
$ 
                    String
"Entering `getDeclOf' for `" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Ident -> String
identToLexeme Ident
ide 
                    String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"'...\n"
    traceTypeCO :: CT s ()
traceTypeCO = String -> CT s ()
forall s. String -> CT s ()
traceCTrav (String -> CT s ()) -> String -> CT s ()
forall a b. (a -> b) -> a -> b
$ 
                    String
"...found a type object.\n"
    traceObjCO :: CT s ()
traceObjCO  = String -> CT s ()
forall s. String -> CT s ()
traceCTrav (String -> CT s ()) -> String -> CT s ()
forall a b. (a -> b) -> a -> b
$ 
                    String
"...found a vanilla object.\n"


-- convenience functions
--

-- find a type object in the object name space; returns `nothing' if the
-- identifier is not defined (EXPORTED)
--
--  * if the second argument is `True', use `findObjShadow'
--
findTypeObjMaybe                :: Ident -> Bool -> CT s (Maybe (CObj, Ident))
findTypeObjMaybe :: forall s. Ident -> Bool -> CT s (Maybe (CObj, Ident))
findTypeObjMaybe Ident
ide Bool
useShadows  = 
  do
    oobj <- if Bool
useShadows 
            then Ident -> CT s (Maybe (CObj, Ident))
forall s. Ident -> CT s (Maybe (CObj, Ident))
findObjShadow Ident
ide 
            else (Maybe CObj -> Maybe (CObj, Ident))
-> PreCST SwitchBoard (CState s) (Maybe CObj)
-> CT s (Maybe (CObj, Ident))
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM ((CObj -> (CObj, Ident)) -> Maybe CObj -> Maybe (CObj, Ident)
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\CObj
obj -> (CObj
obj, Ident
ide))) (PreCST SwitchBoard (CState s) (Maybe CObj)
 -> CT s (Maybe (CObj, Ident)))
-> PreCST SwitchBoard (CState s) (Maybe CObj)
-> CT s (Maybe (CObj, Ident))
forall a b. (a -> b) -> a -> b
$ Ident -> PreCST SwitchBoard (CState s) (Maybe CObj)
forall s. Ident -> CT s (Maybe CObj)
findObj Ident
ide
    case oobj of
      Just obj :: (CObj, Ident)
obj@(TypeCO CDecl
_ , Ident
_) -> Maybe (CObj, Ident) -> CT s (Maybe (CObj, Ident))
forall a. a -> PreCST SwitchBoard (CState s) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (CObj, Ident) -> CT s (Maybe (CObj, Ident)))
-> Maybe (CObj, Ident) -> CT s (Maybe (CObj, Ident))
forall a b. (a -> b) -> a -> b
$ (CObj, Ident) -> Maybe (CObj, Ident)
forall a. a -> Maybe a
Just (CObj, Ident)
obj
      Just obj :: (CObj, Ident)
obj@(CObj
BuiltinCO, Ident
_) -> Maybe (CObj, Ident) -> CT s (Maybe (CObj, Ident))
forall a. a -> PreCST SwitchBoard (CState s) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (CObj, Ident) -> CT s (Maybe (CObj, Ident)))
-> Maybe (CObj, Ident) -> CT s (Maybe (CObj, Ident))
forall a b. (a -> b) -> a -> b
$ (CObj, Ident) -> Maybe (CObj, Ident)
forall a. a -> Maybe a
Just (CObj, Ident)
obj
      Just (CObj, Ident)
_                  -> Ident -> CT s (Maybe (CObj, Ident))
forall s a. Ident -> CT s a
typedefExpectedErr Ident
ide
      Maybe (CObj, Ident)
Nothing                 -> Maybe (CObj, Ident) -> CT s (Maybe (CObj, Ident))
forall a. a -> PreCST SwitchBoard (CState s) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (CObj, Ident) -> CT s (Maybe (CObj, Ident)))
-> Maybe (CObj, Ident) -> CT s (Maybe (CObj, Ident))
forall a b. (a -> b) -> a -> b
$ Maybe (CObj, Ident)
forall a. Maybe a
Nothing

-- find a type object in the object name space; raises an error and exception
-- if the identifier is not defined (EXPORTED)
--
--  * if the second argument is `True', use `findObjShadow'
--
findTypeObj                :: Ident -> Bool -> CT s (CObj, Ident)
findTypeObj :: forall s. Ident -> Bool -> CT s (CObj, Ident)
findTypeObj Ident
ide Bool
useShadows  = do
  oobj <- Ident -> Bool -> CT s (Maybe (CObj, Ident))
forall s. Ident -> Bool -> CT s (Maybe (CObj, Ident))
findTypeObjMaybe Ident
ide Bool
useShadows
  case oobj of
    Maybe (CObj, Ident)
Nothing  -> Ident -> PreCST SwitchBoard (CState s) (CObj, Ident)
forall s a. Ident -> CT s a
unknownObjErr Ident
ide
    Just (CObj, Ident)
obj -> (CObj, Ident) -> PreCST SwitchBoard (CState s) (CObj, Ident)
forall a. a -> PreCST SwitchBoard (CState s) a
forall (m :: * -> *) a. Monad m => a -> m a
return (CObj, Ident)
obj

-- find an object, function, or enumerator in the object name space; raises an
-- error and exception if the identifier is not defined (EXPORTED)
--
--  * if the second argument is `True', use `findObjShadow'
--
findValueObj                :: Ident -> Bool -> CT s (CObj, Ident)
findValueObj :: forall s. Ident -> Bool -> CT s (CObj, Ident)
findValueObj Ident
ide Bool
useShadows  = 
  do
    oobj <- if Bool
useShadows 
            then Ident -> CT s (Maybe (CObj, Ident))
forall s. Ident -> CT s (Maybe (CObj, Ident))
findObjShadow Ident
ide 
            else (Maybe CObj -> Maybe (CObj, Ident))
-> PreCST SwitchBoard (CState s) (Maybe CObj)
-> CT s (Maybe (CObj, Ident))
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM ((CObj -> (CObj, Ident)) -> Maybe CObj -> Maybe (CObj, Ident)
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\CObj
obj -> (CObj
obj, Ident
ide))) (PreCST SwitchBoard (CState s) (Maybe CObj)
 -> CT s (Maybe (CObj, Ident)))
-> PreCST SwitchBoard (CState s) (Maybe CObj)
-> CT s (Maybe (CObj, Ident))
forall a b. (a -> b) -> a -> b
$ Ident -> PreCST SwitchBoard (CState s) (Maybe CObj)
forall s. Ident -> CT s (Maybe CObj)
findObj Ident
ide
    case oobj of
      Just obj :: (CObj, Ident)
obj@(ObjCO  CDecl
_  , Ident
_) -> (CObj, Ident) -> PreCST SwitchBoard (CState s) (CObj, Ident)
forall a. a -> PreCST SwitchBoard (CState s) a
forall (m :: * -> *) a. Monad m => a -> m a
return (CObj, Ident)
obj
      Just obj :: (CObj, Ident)
obj@(EnumCO Ident
_ CEnum
_, Ident
_) -> (CObj, Ident) -> PreCST SwitchBoard (CState s) (CObj, Ident)
forall a. a -> PreCST SwitchBoard (CState s) a
forall (m :: * -> *) a. Monad m => a -> m a
return (CObj, Ident)
obj
      Just (CObj, Ident)
_                   -> Position -> PreCST SwitchBoard (CState s) (CObj, Ident)
forall s a. Position -> CT s a
unexpectedTypedefErr (Ident -> Position
forall a. Pos a => a -> Position
posOf Ident
ide)
      Maybe (CObj, Ident)
Nothing                  -> Ident -> PreCST SwitchBoard (CState s) (CObj, Ident)
forall s a. Ident -> CT s a
unknownObjErr Ident
ide

-- find a function in the object name space; raises an error and exception if
-- the identifier is not defined (EXPORTED) 
--
--  * if the second argument is `True', use `findObjShadow'
--
findFunObj               :: Ident -> Bool -> CT s  (CObj, Ident)
findFunObj :: forall s. Ident -> Bool -> CT s (CObj, Ident)
findFunObj Ident
ide Bool
useShadows = 
  do
    (obj, ide') <- Ident -> Bool -> CT s (CObj, Ident)
forall s. Ident -> Bool -> CT s (CObj, Ident)
findValueObj Ident
ide Bool
useShadows
    case obj of
      EnumCO Ident
_ CEnum
_  -> Position -> CT s (CObj, Ident)
forall s a. Position -> CT s a
funExpectedErr (Ident -> Position
forall a. Pos a => a -> Position
posOf Ident
ide)
      ObjCO  CDecl
decl -> do
                       let declr :: CDeclr
declr = Ident
ide' Ident -> CDecl -> CDeclr
`declrFromDecl` CDecl
decl
                       Position -> CDeclr -> CT s ()
forall s. Position -> CDeclr -> CT s ()
assertFunDeclr (Ident -> Position
forall a. Pos a => a -> Position
posOf Ident
ide) CDeclr
declr
                       (CObj, Ident) -> CT s (CObj, Ident)
forall a. a -> PreCST SwitchBoard (CState s) a
forall (m :: * -> *) a. Monad m => a -> m a
return (CObj
obj, Ident
ide')


-- C structure tree query routines
-- -------------------------------

-- test if this is a type definition specification (EXPORTED)
--
isTypedef                   :: CDecl -> Bool
isTypedef :: CDecl -> Bool
isTypedef (CDecl [CDeclSpec]
specs [(Maybe CDeclr, Maybe CInit, Maybe CExpr)]
_ Attrs
_)  = 
  Bool -> Bool
not (Bool -> Bool) -> ([()] -> Bool) -> [()] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [()] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([()] -> Bool) -> [()] -> Bool
forall a b. (a -> b) -> a -> b
$ [() | CStorageSpec (CTypedef Attrs
_) <- [CDeclSpec]
specs]

-- discard all declarators but the one declaring the given identifier
-- (EXPORTED) 
--
--  * the declaration must contain the identifier
--
simplifyDecl :: Ident -> CDecl -> CDecl
Ident
ide simplifyDecl :: Ident -> CDecl -> CDecl
`simplifyDecl` (CDecl [CDeclSpec]
specs [(Maybe CDeclr, Maybe CInit, Maybe CExpr)]
declrs Attrs
at) =
  case ((Maybe CDeclr, Maybe CInit, Maybe CExpr) -> Bool)
-> [(Maybe CDeclr, Maybe CInit, Maybe CExpr)]
-> Maybe (Maybe CDeclr, Maybe CInit, Maybe CExpr)
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find ((Maybe CDeclr, Maybe CInit, Maybe CExpr) -> Ident -> Bool
forall {b} {c}. (Maybe CDeclr, b, c) -> Ident -> Bool
`declrPlusNamed` Ident
ide) [(Maybe CDeclr, Maybe CInit, Maybe CExpr)]
declrs of
    Maybe (Maybe CDeclr, Maybe CInit, Maybe CExpr)
Nothing    -> CDecl
forall {a}. a
err
    Just (Maybe CDeclr, Maybe CInit, Maybe CExpr)
declr -> [CDeclSpec]
-> [(Maybe CDeclr, Maybe CInit, Maybe CExpr)] -> Attrs -> CDecl
CDecl [CDeclSpec]
specs [(Maybe CDeclr, Maybe CInit, Maybe CExpr)
declr] Attrs
at
  where
    (Just CDeclr
declr, b
_, c
_) declrPlusNamed :: (Maybe CDeclr, b, c) -> Ident -> Bool
`declrPlusNamed` Ident
ide = CDeclr
declr CDeclr -> Ident -> Bool
`declrNamed` Ident
ide
    (Maybe CDeclr, b, c)
_                  `declrPlusNamed` Ident
_   = Bool
False
    --
    err :: a
err = String -> a
forall a. String -> a
interr (String -> a) -> String -> a
forall a b. (a -> b) -> a -> b
$ String
"CTrav.simplifyDecl: Wrong C object!\n\
                   \  Looking for `" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Ident -> String
identToLexeme Ident
ide String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"' in decl \
                   \at " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Position -> String
forall a. Show a => a -> String
show (Attrs -> Position
forall a. Pos a => a -> Position
posOf Attrs
at)

-- extract the declarator that declares the given identifier (EXPORTED)
--
--  * the declaration must contain the identifier
--
declrFromDecl            :: Ident -> CDecl -> CDeclr
Ident
ide declrFromDecl :: Ident -> CDecl -> CDeclr
`declrFromDecl` CDecl
decl  = 
  let CDecl [CDeclSpec]
_ [(Just CDeclr
declr, Maybe CInit
_, Maybe CExpr
_)] Attrs
_ = Ident
ide Ident -> CDecl -> CDecl
`simplifyDecl` CDecl
decl
  in
  CDeclr
declr

-- tests whether the given declarator has the given name (EXPORTED)
--
declrNamed             :: CDeclr -> Ident -> Bool
CDeclr
declr declrNamed :: CDeclr -> Ident -> Bool
`declrNamed` Ident
ide  = CDeclr -> Maybe Ident
declrName CDeclr
declr Maybe Ident -> Maybe Ident -> Bool
forall a. Eq a => a -> a -> Bool
== Ident -> Maybe Ident
forall a. a -> Maybe a
Just Ident
ide

-- get the declarator of a declaration that has at most one declarator
-- (EXPORTED) 
--
declaredDeclr                              :: CDecl -> Maybe CDeclr
declaredDeclr :: CDecl -> Maybe CDeclr
declaredDeclr (CDecl [CDeclSpec]
_ []               Attrs
_)  = Maybe CDeclr
forall a. Maybe a
Nothing
declaredDeclr (CDecl [CDeclSpec]
_ [(Maybe CDeclr
odeclr, Maybe CInit
_, Maybe CExpr
_)] Attrs
_)  = Maybe CDeclr
odeclr
declaredDeclr CDecl
decl                          = 
  String -> Maybe CDeclr
forall a. String -> a
interr (String -> Maybe CDeclr) -> String -> Maybe CDeclr
forall a b. (a -> b) -> a -> b
$ String
"CTrav.declaredDeclr: Too many declarators!\n\
           \  Declaration at " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Position -> String
forall a. Show a => a -> String
show (CDecl -> Position
forall a. Pos a => a -> Position
posOf CDecl
decl)

-- get the name declared by a declaration that has exactly one declarator
-- (EXPORTED) 
--
declaredName      :: CDecl -> Maybe Ident
declaredName :: CDecl -> Maybe Ident
declaredName CDecl
decl  = CDecl -> Maybe CDeclr
declaredDeclr CDecl
decl Maybe CDeclr -> (CDeclr -> Maybe Ident) -> Maybe Ident
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= CDeclr -> Maybe Ident
declrName

-- obtains the member definitions and the tag of a struct (EXPORTED)
--
--  * member definitions are expanded
--
structMembers :: CStructUnion -> ([CDecl], CStructTag)
structMembers :: CStructUnion -> ([CDecl], CStructTag)
structMembers (CStruct CStructTag
tag Maybe Ident
_ [CDecl]
members Attrs
_) = ([[CDecl]] -> [CDecl]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[CDecl]] -> [CDecl])
-> ([CDecl] -> [[CDecl]]) -> [CDecl] -> [CDecl]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (CDecl -> [CDecl]) -> [CDecl] -> [[CDecl]]
forall a b. (a -> b) -> [a] -> [b]
map CDecl -> [CDecl]
expandDecl ([CDecl] -> [CDecl]) -> [CDecl] -> [CDecl]
forall a b. (a -> b) -> a -> b
$ [CDecl]
members,
                                           CStructTag
tag)

-- expand declarators declaring more than one identifier into multiple
-- declarators, eg, `int x, y;' becomes `int x; int y;' (EXPORTED)
--
expandDecl                        :: CDecl -> [CDecl]
expandDecl :: CDecl -> [CDecl]
expandDecl (CDecl [CDeclSpec]
specs [(Maybe CDeclr, Maybe CInit, Maybe CExpr)]
decls Attrs
at)  = 
  ((Maybe CDeclr, Maybe CInit, Maybe CExpr) -> CDecl)
-> [(Maybe CDeclr, Maybe CInit, Maybe CExpr)] -> [CDecl]
forall a b. (a -> b) -> [a] -> [b]
map (\(Maybe CDeclr, Maybe CInit, Maybe CExpr)
decl -> [CDeclSpec]
-> [(Maybe CDeclr, Maybe CInit, Maybe CExpr)] -> Attrs -> CDecl
CDecl [CDeclSpec]
specs [(Maybe CDeclr, Maybe CInit, Maybe CExpr)
decl] Attrs
at) [(Maybe CDeclr, Maybe CInit, Maybe CExpr)]
decls

-- get a struct's name (EXPORTED)
--
structName                      :: CStructUnion -> Maybe Ident
structName :: CStructUnion -> Maybe Ident
structName (CStruct CStructTag
_ Maybe Ident
oide [CDecl]
_ Attrs
_)  = Maybe Ident
oide

-- get an enum's name (EXPORTED)
--
enumName                  :: CEnum -> Maybe Ident
enumName :: CEnum -> Maybe Ident
enumName (CEnum Maybe Ident
oide [(Ident, Maybe CExpr)]
_ Attrs
_)  = Maybe Ident
oide

-- get a tag's name (EXPORTED)
--
--  * fail if the tag is anonymous
--
tagName     :: CTag -> Ident
tagName :: CTag -> Ident
tagName CTag
tag  =
  case CTag
tag of
   StructUnionCT CStructUnion
struct -> Ident -> (Ident -> Ident) -> Maybe Ident -> Ident
forall b a. b -> (a -> b) -> Maybe a -> b