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,
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(..))
type CState s = (AttrC, s)
type CT s a = CST (CState s) a
readAttrCCT :: (AttrC -> a) -> CT s a
readAttrCCT reader = readCST $ \(ac, _) -> reader ac
transAttrCCT :: (AttrC -> (AttrC, a)) -> CT s a
transAttrCCT trans = transCST $ \(ac, s) -> let
(ac', r) = trans ac
in
((ac', s), r)
readCT :: (s -> a) -> CT s a
readCT reader = readCST $ \(_, s) -> reader s
transCT :: (s -> (s, a)) -> CT s a
transCT trans = transCST $ \(ac, s) -> let
(s', r) = trans s
in
((ac, s'), r)
getCHeaderCT :: CT s CHeader
getCHeaderCT = readAttrCCT getCHeader
runCT :: CT s a -> AttrC -> s -> CST t (AttrC, a)
runCT m ac s = runCST m' (ac, s)
where
m' = do
r <- m
(ac, _) <- readCST id
return (ac, r)
ctExc :: String
ctExc = "ctExc"
throwCTExc :: CT s a
throwCTExc = throwExc ctExc "Error during traversal of a C structure tree"
ifCTExc :: CT s a -> CT s a -> CT s a
ifCTExc m handler = m `catchExc` (ctExc, const handler)
raiseErrorCTExc :: Position -> [String] -> CT s a
raiseErrorCTExc pos errs = raiseError pos errs >> throwCTExc
enter :: CT s ()
enter = transAttrCCT $ \ac -> (enterNewRangeC ac, ())
enterObjs :: CT s ()
enterObjs = transAttrCCT $ \ac -> (enterNewObjRangeC ac, ())
leave :: CT s ()
leave = transAttrCCT $ \ac -> (leaveRangeC ac, ())
leaveObjs :: CT s ()
leaveObjs = transAttrCCT $ \ac -> (leaveObjRangeC ac, ())
defObj :: Ident -> CObj -> CT s (Maybe CObj)
defObj ide obj = transAttrCCT $ \ac -> addDefObjC ac ide obj
findObj :: Ident -> CT s (Maybe CObj)
findObj ide = readAttrCCT $ \ac -> lookupDefObjC ac ide
findObjShadow :: Ident -> CT s (Maybe (CObj, Ident))
findObjShadow ide = readAttrCCT $ \ac -> lookupDefObjCShadow ac ide
defTag :: Ident -> CTag -> CT s (Maybe CTag)
defTag ide tag =
do
otag <- transAttrCCT $ \ac -> addDefTagC ac ide tag
case otag of
Nothing -> do
assertIfEnumThenFull tag
return Nothing
Just prevTag -> case isRefinedOrUse prevTag tag of
Nothing -> return otag
Just (fullTag, foreIde) -> do
transAttrCCT $ \ac -> addDefTagC ac ide fullTag
foreIde `refersToDef` TagCD fullTag
return Nothing
where
isRefinedOrUse (StructUnionCT (CStruct _ (Just ide) [] _))
tag@(StructUnionCT (CStruct _ (Just _ ) _ _)) =
Just (tag, ide)
isRefinedOrUse tag@(StructUnionCT (CStruct _ (Just _ ) _ _))
(StructUnionCT (CStruct _ (Just ide) [] _)) =
Just (tag, ide)
isRefinedOrUse tag@(EnumCT (CEnum (Just _ ) _ _))
(EnumCT (CEnum (Just ide) [] _)) =
Just (tag, ide)
isRefinedOrUse _ _ = Nothing
findTag :: Ident -> CT s (Maybe CTag)
findTag ide = readAttrCCT $ \ac -> lookupDefTagC ac ide
findTagShadow :: Ident -> CT s (Maybe (CTag, Ident))
findTagShadow ide = readAttrCCT $ \ac -> lookupDefTagCShadow ac ide
applyPrefixToNameSpaces :: String -> CT s ()
applyPrefixToNameSpaces prefix =
transAttrCCT $ \ac -> (applyPrefix ac prefix, ())
getDefOf :: Ident -> CT s CDef
getDefOf ide = do
def <- readAttrCCT $ \ac -> getDefOfIdentC ac ide
assert (not . isUndef $ def) $
return def
refersToDef :: Ident -> CDef -> CT s ()
refersToDef ide def = transAttrCCT $ \akl -> (setDefOfIdentC akl ide def, ())
refersToNewDef :: Ident -> CDef -> CT s ()
refersToNewDef ide def =
transAttrCCT $ \akl -> (updDefOfIdentC akl ide def, ())
getDeclOf :: Ident -> CT s CDecl
getDeclOf ide =
do
traceEnter
def <- getDefOf ide
case def of
UndefCD -> interr "CTrav.getDeclOf: Undefined!"
DontCareCD -> interr "CTrav.getDeclOf: Don't care!"
TagCD _ -> interr "CTrav.getDeclOf: Illegal tag!"
ObjCD obj -> case obj of
TypeCO decl -> traceTypeCO >>
return decl
ObjCO decl -> traceObjCO >>
return decl
EnumCO _ _ -> illegalEnum
BuiltinCO -> illegalBuiltin
where
illegalEnum = interr "CTrav.getDeclOf: Illegal enum!"
illegalBuiltin = interr "CTrav.getDeclOf: Attempted to get declarator of \
\builtin entity!"
traceEnter = traceCTrav $
"Entering `getDeclOf' for `" ++ identToLexeme ide
++ "'...\n"
traceTypeCO = traceCTrav $
"...found a type object.\n"
traceObjCO = traceCTrav $
"...found a vanilla object.\n"
findTypeObjMaybe :: Ident -> Bool -> CT s (Maybe (CObj, Ident))
findTypeObjMaybe ide useShadows =
do
oobj <- if useShadows
then findObjShadow ide
else liftM (fmap (\obj -> (obj, ide))) $ findObj ide
case oobj of
Just obj@(TypeCO _ , _) -> return $ Just obj
Just obj@(BuiltinCO, _) -> return $ Just obj
Just _ -> typedefExpectedErr ide
Nothing -> return $ Nothing
findTypeObj :: Ident -> Bool -> CT s (CObj, Ident)
findTypeObj ide useShadows = do
oobj <- findTypeObjMaybe ide useShadows
case oobj of
Nothing -> unknownObjErr ide
Just obj -> return obj
findValueObj :: Ident -> Bool -> CT s (CObj, Ident)
findValueObj ide useShadows =
do
oobj <- if useShadows
then findObjShadow ide
else liftM (fmap (\obj -> (obj, ide))) $ findObj ide
case oobj of
Just obj@(ObjCO _ , _) -> return obj
Just obj@(EnumCO _ _, _) -> return obj
Just _ -> unexpectedTypedefErr (posOf ide)
Nothing -> unknownObjErr ide
findFunObj :: Ident -> Bool -> CT s (CObj, Ident)
findFunObj ide useShadows =
do
(obj, ide') <- findValueObj ide useShadows
case obj of
EnumCO _ _ -> funExpectedErr (posOf ide)
ObjCO decl -> do
let declr = ide' `declrFromDecl` decl
assertFunDeclr (posOf ide) declr
return (obj, ide')
isTypedef :: CDecl -> Bool
isTypedef (CDecl specs _ _) =
not . null $ [() | CStorageSpec (CTypedef _) <- specs]
simplifyDecl :: Ident -> CDecl -> CDecl
ide `simplifyDecl` (CDecl specs declrs at) =
case find (`declrPlusNamed` ide) declrs of
Nothing -> err
Just declr -> CDecl specs [declr] at
where
(Just declr, _, _) `declrPlusNamed` ide = declr `declrNamed` ide
_ `declrPlusNamed` _ = False
err = interr $ "CTrav.simplifyDecl: Wrong C object!\n\
\ Looking for `" ++ identToLexeme ide ++ "' in decl \
\at " ++ show (posOf at)
declrFromDecl :: Ident -> CDecl -> CDeclr
ide `declrFromDecl` decl =
let CDecl _ [(Just declr, _, _)] _ = ide `simplifyDecl` decl
in
declr
declrNamed :: CDeclr -> Ident -> Bool
declr `declrNamed` ide = declrName declr == Just ide
declaredDeclr :: CDecl -> Maybe CDeclr
declaredDeclr (CDecl _ [] _) = Nothing
declaredDeclr (CDecl _ [(odeclr, _, _)] _) = odeclr
declaredDeclr decl =
interr $ "CTrav.declaredDeclr: Too many declarators!\n\
\ Declaration at " ++ show (posOf decl)
declaredName :: CDecl -> Maybe Ident
declaredName decl = declaredDeclr decl >>= declrName
structMembers :: CStructUnion -> ([CDecl], CStructTag)
structMembers (CStruct tag _ members _) = (concat . map expandDecl $ members,
tag)
expandDecl :: CDecl -> [CDecl]
expandDecl (CDecl specs decls at) =
map (\decl -> CDecl specs [decl] at) decls
structName :: CStructUnion -> Maybe Ident
structName (CStruct _ oide _ _) = oide
enumName :: CEnum -> Maybe Ident
enumName (CEnum oide _ _) = oide
tagName :: CTag -> Ident
tagName tag =
case tag of
StructUnionCT struct -> maybe err id $ structName struct
EnumCT enum -> maybe err id $ enumName enum
where
err = interr "CTrav.tagName: Anonymous tag definition"
isPtrDeclr :: CDeclr -> Bool
isPtrDeclr (CPtrDeclr _ (CVarDeclr _ _) _) = True
isPtrDeclr (CPtrDeclr _ declr _) = isPtrDeclr declr
isPtrDeclr (CArrDeclr (CVarDeclr _ _) _ _ _) = True
isPtrDeclr (CArrDeclr declr _ _ _) = isPtrDeclr declr
isPtrDeclr (CFunDeclr declr _ _ _) = isPtrDeclr declr
isPtrDeclr _ = False
isArrDeclr :: CDeclr -> Bool
isArrDeclr (CArrDeclr declr _ _ _) = True
isArrDeclr _ = False
dropPtrDeclr :: CDeclr -> CDeclr
dropPtrDeclr (CPtrDeclr qs declr@(CVarDeclr _ _) ats) = declr
dropPtrDeclr (CPtrDeclr qs declr ats) =
let declr' = dropPtrDeclr declr
in
CPtrDeclr qs declr' ats
dropPtrDeclr (CArrDeclr declr@(CVarDeclr _ _) _ _ _) = declr
dropPtrDeclr (CArrDeclr declr tq e ats) =
let declr' = dropPtrDeclr declr
in
CArrDeclr declr' tq e ats
dropPtrDeclr (CFunDeclr declr args vari ats) =
let declr' = dropPtrDeclr declr
in
CFunDeclr declr' args vari ats
dropPtrDeclr _ =
interr "CTrav.dropPtrDeclr: No pointer!"
isPtrDecl :: CDecl -> Bool
isPtrDecl (CDecl _ [] _) = False
isPtrDecl (CDecl _ [(Just declr, _, _)] _) = isPtrDeclr declr
isPtrDecl _ =
interr "CTrav.isPtrDecl: There was more than one declarator!"
isFunDeclr :: CDeclr -> Bool
isFunDeclr (CPtrDeclr _ declr _) = isFunDeclr declr
isFunDeclr (CArrDeclr declr _ _ _) = isFunDeclr declr
isFunDeclr (CFunDeclr (CVarDeclr _ _) _ _ _) = True
isFunDeclr (CFunDeclr declr _ _ _) = isFunDeclr declr
isFunDeclr _ = False
structFromDecl :: Position -> CDecl -> CT s CStructUnion
structFromDecl pos (CDecl specs _ _) =
case head [ts | CTypeSpec ts <- specs] of
CSUType su _ -> extractStruct pos (StructUnionCT su)
_ -> structExpectedErr pos
funResultAndArgs :: CDecl -> ([CDecl], CDecl, Bool)
funResultAndArgs (CDecl specs [(Just declr, _, _)] _) =
let (args, declr', variadic) = funArgs declr
result = CDecl specs [(Just declr', Nothing, Nothing)]
(newAttrsOnlyPos nopos)
in
(args, result, variadic)
where
funArgs (CFunDeclr var@(CVarDeclr _ _) args variadic _) =
(args, var, variadic)
funArgs (CPtrDeclr qs declr at) =
let (args, declr', variadic) = funArgs declr
in
(args, CPtrDeclr qs declr' at, variadic)
funArgs (CArrDeclr declr tqs oe at) =
let (args, declr', variadic) = funArgs declr
in
(args, CArrDeclr declr' tqs oe at, variadic)
funArgs (CFunDeclr declr args var at) =
let (args, declr', variadic) = funArgs declr
in
(args, CFunDeclr declr' args var at, variadic)
funArgs _ =
interr "CTrav.funResultAndArgs: Illegal declarator!"
chaseDecl :: Ident -> Bool -> CT s CDecl
chaseDecl ide ind =
do
traceEnter
cdecl <- getDeclOf ide
let sdecl = ide `simplifyDecl` cdecl
case extractAlias sdecl ind of
Just (ide', ind') -> chaseDecl ide' ind'
Nothing -> return sdecl
where
traceEnter = traceCTrav $
"Entering `chaseDecl' for `" ++ identToLexeme ide
++ "' " ++ (if ind then "" else "not ")
++ "following indirections...\n"
findAndChaseDecl :: Ident -> Bool -> Bool -> CT s CDecl
findAndChaseDecl ide ind useShadows =
do
(obj, ide') <- findTypeObj ide useShadows
ide `refersToNewDef` ObjCD obj
ide' `refersToNewDef` ObjCD obj
chaseDecl ide' ind
checkForAlias :: CDecl -> CT s (Maybe CDecl)
checkForAlias decl =
case extractAlias decl False of
Nothing -> return Nothing
Just (ide', _) -> liftM Just $ chaseDecl ide' False
checkForOneAliasName :: CDecl -> Maybe Ident
checkForOneAliasName decl = fmap fst $ extractAlias decl False
lookupEnum :: Ident -> Bool -> CT s CEnum
lookupEnum ide useShadows =
do
otag <- if useShadows
then liftM (fmap fst) $ findTagShadow ide
else findTag ide
case otag of
Just (StructUnionCT _ ) -> enumExpectedErr ide
Just (EnumCT enum) -> return enum
Nothing -> do
(CDecl specs _ _) <- findAndChaseDecl ide False useShadows
case head [ts | CTypeSpec ts <- specs] of
CEnumType enum _ -> return enum
_ -> enumExpectedErr ide
lookupStructUnion :: Ident -> Bool -> Bool -> CT s CStructUnion
lookupStructUnion ide ind useShadows
| ind = chase
| otherwise =
do
otag <- if useShadows
then liftM (fmap fst) $ findTagShadow ide
else findTag ide
maybe chase (extractStruct (posOf ide)) otag
where
chase =
do
decl <- findAndChaseDecl ide ind useShadows
structFromDecl (posOf ide) decl
lookupDeclOrTag :: Ident -> Bool -> CT s (Either CDecl CTag)
lookupDeclOrTag ide useShadows = do
oobj <- findTypeObjMaybe ide useShadows
case oobj of
Just (_, ide) -> liftM Left $ findAndChaseDecl ide False False
Nothing -> do
otag <- if useShadows
then liftM (fmap fst) $ findTagShadow ide
else findTag ide
case otag of
Nothing -> unknownObjErr ide
Just tag -> return $ Right tag
extractAlias :: CDecl -> Bool -> Maybe (Ident, Bool)
extractAlias decl@(CDecl specs _ _) ind =
case [ts | CTypeSpec ts <- specs] of
[CTypeDef ide' _] ->
case declaredDeclr decl of
Nothing -> Just (ide', ind)
Just (CVarDeclr _ _ ) -> Just (ide', ind)
Just (CPtrDeclr [_] (CVarDeclr _ _) _)
| ind -> Just (ide', False)
| otherwise -> Nothing
_ -> Nothing
_ -> Nothing
extractStruct :: Position -> CTag -> CT s CStructUnion
extractStruct pos (EnumCT _ ) = structExpectedErr pos
extractStruct pos (StructUnionCT su) =
case su of
CStruct _ (Just ide') [] _ -> do
def <- getDefOf ide'
case def of
TagCD tag -> extractStruct pos tag
_ -> err
_ -> return su
where
err = interr "CTrav.extractStruct: Illegal reference!"
declrName :: CDeclr -> Maybe Ident
declrName (CVarDeclr oide _) = oide
declrName (CPtrDeclr _ declr _) = declrName declr
declrName (CArrDeclr declr _ _ _) = declrName declr
declrName (CFunDeclr declr _ _ _) = declrName declr
assertFunDeclr :: Position -> CDeclr -> CT s ()
assertFunDeclr pos (CArrDeclr (CFunDeclr (CVarDeclr _ _) _ _ _) _ _ _) =
illegalFunResultErr pos
assertFunDeclr pos (CFunDeclr (CVarDeclr _ _) _ _ _) =
nop
assertFunDeclr pos (CFunDeclr declr _ _ _) =
assertFunDeclr pos declr
assertFunDeclr pos (CPtrDeclr _ declr _) =
assertFunDeclr pos declr
assertFunDeclr pos (CArrDeclr declr _ _ _) =
assertFunDeclr pos declr
assertFunDeclr pos _ =
funExpectedErr pos
assertIfEnumThenFull :: CTag -> CT s ()
assertIfEnumThenFull (EnumCT (CEnum _ [] at)) = enumForwardErr (posOf at)
assertIfEnumThenFull _ = nop
traceCTrav :: String -> CT s ()
traceCTrav = putTraceStr traceCTravSW
unknownObjErr :: Ident -> CT s a
unknownObjErr ide =
raiseErrorCTExc (posOf ide)
["Unknown identifier!",
"Cannot find a definition for `" ++ identToLexeme ide ++ "' in the \
\header file."]
typedefExpectedErr :: Ident -> CT s a
typedefExpectedErr ide =
raiseErrorCTExc (posOf ide)
["Expected type definition!",
"The identifier `" ++ identToLexeme ide ++ "' needs to be a C type name."]
unexpectedTypedefErr :: Position -> CT s a
unexpectedTypedefErr pos =
raiseErrorCTExc pos
["Unexpected type name!",
"An object, function, or enum constant is required here."]
illegalFunResultErr :: Position -> CT s a
illegalFunResultErr pos =
raiseErrorCTExc pos ["Function cannot return an array!",
"ANSI C does not allow functions to return an array."]
funExpectedErr :: Position -> CT s a
funExpectedErr pos =
raiseErrorCTExc pos
["Function expected!",
"A function is needed here, but this declarator does not declare",
"a function."]
enumExpectedErr :: Ident -> CT s a
enumExpectedErr ide =
raiseErrorCTExc (posOf ide)
["Expected enum!",
"Expected `" ++ identToLexeme ide ++ "' to denote an enum; instead found",
"a struct, union, or object."]
structExpectedErr :: Position -> CT s a
structExpectedErr pos =
raiseErrorCTExc pos
["Expected a struct!",
"Expected a structure or union; instead found an enum or basic type."]
enumForwardErr :: Position -> CT s a
enumForwardErr pos =
raiseErrorCTExc pos
["Forward definition of enumeration!",
"ANSI C does not permit foreward definitions of enumerations!"]