1-- C->Haskell Compiler: traversals of C structure tree 2-- 3-- Author : Manuel M. T. Chakravarty 4-- Created: 16 October 99 5-- 6-- Copyright (c) [1999..2001] Manuel M. T. Chakravarty 7-- 8-- This file is free software; you can redistribute it and/or modify 9-- it under the terms of the GNU General Public License as published by 10-- the Free Software Foundation; either version 2 of the License, or 11-- (at your option) any later version. 12-- 13-- This file is distributed in the hope that it will be useful, 14-- but WITHOUT ANY WARRANTY; without even the implied warranty of 15-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 16-- GNU General Public License for more details. 17-- 18--- DESCRIPTION --------------------------------------------------------------- 19-- 20-- This modules provides for traversals of C structure trees. The C 21-- traversal monad supports traversals that need convenient access to the 22-- attributes of an attributed C structure tree. The monads state can still 23-- be extended. 24-- 25--- DOCU ---------------------------------------------------------------------- 26-- 27-- language: Haskell 98 28-- 29-- Handling of redefined tag values 30-- -------------------------------- 31-- 32-- Structures allow both 33-- 34-- struct s {...} ...; 35-- struct s ...; 36-- 37-- and 38-- 39-- struct s ...; /* this is called a forward reference */ 40-- struct s {...} ...; 41-- 42-- In contrast enumerations only allow (in ANSI C) 43-- 44-- enum e {...} ...; 45-- enum e ...; 46-- 47-- The function `defTag' handles both types and establishes an object 48-- association from the tag identifier in the empty declaration (ie, the one 49-- without `{...}') to the actually definition of the structure of 50-- enumeration. This implies that when looking for the details of a 51-- structure or enumeration, possibly a chain of references on tag 52-- identifiers has to be chased. Note that the object association attribute 53-- is _not_defined_ when the `{...}' part is present in a declaration. 54-- 55--- TODO ---------------------------------------------------------------------- 56-- 57-- * `extractStruct' doesn't account for forward declarations that have no 58-- full declaration yet; if `extractStruct' is called on such a declaration, 59-- we have a user error, but currently an internal error is raised 60-- 61 62module C2HS.C.Trav (CT, readCT, transCT, runCT, throwCTExc, ifCTExc, 63 raiseErrorCTExc, 64 enter, enterObjs, leave, leaveObjs, defObj, findObj, 65 findObjShadow, defTag, findTag, findTagShadow, 66 applyPrefixToNameSpaces, getDefOf, refersToDef, refersToNewDef, 67 getDeclOf, findTypeObjMaybe, findTypeObj, findValueObj, 68 findFunObj, 69 -- 70 -- C structure tree query functions 71 -- 72 isTypedef, simplifyDecl, declrFromDecl, declrNamed, 73 declaredDeclr, initDeclr, declaredName, structMembers, expandDecl, 74 structName, enumName, tagName, isPtrDeclr, isArrDeclr, 75 dropPtrDeclr, isPtrDecl, isArrDecl, isFunDeclr, structFromDecl, 76 funResultAndArgs, chaseDecl, findAndChaseDecl, 77 findAndChaseDeclOrTag, checkForAlias, checkForOneCUName, 78 checkForOneAliasName, lookupEnum, lookupStructUnion, 79 lookupDeclOrTag) 80where 81 82import Data.List (find) 83import Control.Monad (liftM) 84import Control.Exception (assert) 85 86import Language.C.Data 87import Language.C.Data.Ident (dumpIdent) 88import Language.C.Syntax 89 90import Data.Attributes 91import Data.Errors 92 93import C2HS.State (CST, readCST, transCST, runCST, raiseError, catchExc, 94 throwExc, Traces(..), putTraceStr) 95import C2HS.C.Attrs (AttrC(..), enterNewRangeC, enterNewObjRangeC, 96 leaveRangeC, leaveObjRangeC, addDefObjC, lookupDefObjC, 97 lookupDefObjCShadow, addDefTagC, lookupDefTagC, 98 lookupDefTagCShadow, applyPrefix, getDefOfIdentC, 99 setDefOfIdentC, updDefOfIdentC, CObj(..), CTag(..), 100 CDef(..)) 101 102 103-- the C traversal monad 104-- --------------------- 105 106-- | C traversal monad 107-- 108type CState s = (AttrC, s) 109type CT s a = CST (CState s) a 110 111-- | read attributed struture tree 112-- 113readAttrCCT :: (AttrC -> a) -> CT s a 114readAttrCCT reader = readCST $ \(ac, _) -> reader ac 115 116-- | transform attributed structure tree 117-- 118transAttrCCT :: (AttrC -> (AttrC, a)) -> CT s a 119transAttrCCT trans = transCST $ \(ac, s) -> let 120 (ac', r) = trans ac 121 in 122 ((ac', s), r) 123 124-- | access to the user-defined state 125-- 126 127-- | read user-defined state 128-- 129readCT :: (s -> a) -> CT s a 130readCT reader = readCST $ \(_, s) -> reader s 131 132-- | transform user-defined state 133-- 134transCT :: (s -> (s, a)) -> CT s a 135transCT trans = transCST $ \(ac, s) -> let 136 (s', r) = trans s 137 in 138 ((ac, s'), r) 139 140-- usage of a traversal monad 141-- 142 143-- | execute a traversal monad 144-- 145-- * given a traversal monad, an attribute structure tree, and a user 146-- state, the transformed structure tree and monads result are returned 147-- 148runCT :: CT s a -> AttrC -> s -> CST t (AttrC, a) 149runCT m ac s = runCST m' (ac, s) 150 where 151 m' = do 152 r <- m 153 (ac', _) <- readCST id 154 return (ac', r) 155 156 157-- exception handling 158-- ------------------ 159 160-- | exception identifier 161-- 162ctExc :: String 163ctExc = "ctExc" 164 165-- | throw an exception 166-- 167throwCTExc :: CT s a 168throwCTExc = throwExc ctExc "Error during traversal of a C structure tree" 169 170-- | catch a `ctExc' 171-- 172ifCTExc :: CT s a -> CT s a -> CT s a 173ifCTExc m handler = m `catchExc` (ctExc, const handler) 174 175-- | raise an error followed by throwing a CT exception 176-- 177raiseErrorCTExc :: Position -> [String] -> CT s a 178raiseErrorCTExc pos errs = raiseError pos errs >> throwCTExc 179 180 181-- attribute manipulation 182-- ---------------------- 183 184-- name spaces 185-- 186 187-- | enter a new local range 188-- 189enter :: CT s () 190enter = transAttrCCT $ \ac -> (enterNewRangeC ac, ()) 191 192-- | enter a new local range, only for objects 193-- 194enterObjs :: CT s () 195enterObjs = transAttrCCT $ \ac -> (enterNewObjRangeC ac, ()) 196 197-- | leave the current local range 198-- 199leave :: CT s () 200leave = transAttrCCT $ \ac -> (leaveRangeC ac, ()) 201 202-- | leave the current local range, only for objects 203-- 204leaveObjs :: CT s () 205leaveObjs = transAttrCCT $ \ac -> (leaveObjRangeC ac, ()) 206 207-- | enter an object definition into the object name space 208-- 209-- * if a definition of the same name was already present, it is returned 210-- 211defObj :: Ident -> CObj -> CT s (Maybe CObj) 212defObj ide obj = do 213 traceCTrav $ "Defining object "++show ide++"...\n" 214 transAttrCCT $ \ac -> addDefObjC ac ide obj 215 216-- | find a definition in the object name space 217-- 218findObj :: Ident -> CT s (Maybe CObj) 219findObj ide = readAttrCCT $ \ac -> lookupDefObjC ac ide 220 221-- | find a definition in the object name space; if nothing found, try 222-- whether there is a shadow identifier that matches 223-- 224findObjShadow :: Ident -> CT s (Maybe (CObj, Ident)) 225findObjShadow ide = readAttrCCT $ \ac -> lookupDefObjCShadow ac ide 226 227-- | enter a tag definition into the tag name space 228-- 229-- * empty definitions of structures get overwritten with complete ones and a 230-- forward reference is added to their tag identifier; furthermore, both 231-- structures and enums may be referenced using an empty definition when 232-- there was a full definition earlier and in this case there is also an 233-- object association added; otherwise, if a definition of the same name was 234-- already present, it is returned (see DOCU section) 235-- 236-- * it is checked that the first occurence of an enumeration tag is 237-- accompanied by a full definition of the enumeration 238-- 239defTag :: Ident -> CTag -> CT s (Maybe CTag) 240defTag ide tag = 241 do 242 traceCTrav $ "Defining tag "++show ide++"...\n" 243 otag <- transAttrCCT $ \ac -> addDefTagC ac ide tag 244 case otag of 245 Nothing -> return Nothing -- no collision 246 Just prevTag -> case isRefinedOrUse prevTag tag of 247 Nothing -> return otag 248 Just (fullTag, foreIde) -> do 249 _ <- transAttrCCT $ \ac -> addDefTagC ac ide fullTag 250 foreIde `refersToDef` TagCD fullTag 251 return Nothing -- transparent for env 252 where 253 -- compute whether we have the case of a non-conflicting redefined tag 254 -- definition, and if so, return the full definition and the foreward 255 -- definition's tag identifier 256 -- 257 -- * the first argument contains the _previous_ definition 258 -- 259 -- * in the case of a structure, a foreward definition after a full 260 -- definition is allowed, so we have to handle this case; enumerations 261 -- don't allow foreward definitions 262 -- 263 -- * there may also be multiple foreward definition; if we have two of 264 -- them here, one is arbitrarily selected to take the role of the full 265 -- definition 266 -- 267 isRefinedOrUse (StructUnionCT (CStruct _ (Just ide') Nothing _ _)) 268 tag'@(StructUnionCT (CStruct _ (Just _ ) _ _ _)) = 269 Just (tag', ide') 270 isRefinedOrUse tag'@(StructUnionCT (CStruct _ (Just _ ) _ _ _)) 271 (StructUnionCT (CStruct _ (Just ide') Nothing _ _)) = 272 Just (tag', ide') 273 isRefinedOrUse (EnumCT (CEnum (Just ide') Nothing _ _)) 274 tag'@(EnumCT (CEnum (Just _ ) _ _ _)) = 275 Just (tag', ide') 276 isRefinedOrUse tag'@(EnumCT (CEnum (Just ide') _ _ _)) 277 (EnumCT (CEnum (Just _ ) _ _ _)) = 278 Just (tag', ide') 279 isRefinedOrUse _ _ = Nothing 280 281-- | find an definition in the tag name space 282-- 283findTag :: Ident -> CT s (Maybe CTag) 284findTag ide = readAttrCCT $ \ac -> lookupDefTagC ac ide 285 286-- | find an definition in the tag name space; if nothing found, try 287-- whether there is a shadow identifier that matches 288-- 289findTagShadow :: Ident -> CT s (Maybe (CTag, Ident)) 290findTagShadow ide = readAttrCCT $ \ac -> lookupDefTagCShadow ac ide 291 292-- | enrich the object and tag name space with identifiers obtained by dropping 293-- the given prefix from the identifiers already in the name space 294-- 295-- * if a new identifier would collides with an existing one, the new one is 296-- discarded, ie, all associations that existed before the transformation 297-- started are still in effect after the transformation 298-- 299applyPrefixToNameSpaces :: String -> String -> CT s () 300applyPrefixToNameSpaces prefix repprefix = 301 transAttrCCT $ \ac -> (applyPrefix ac prefix repprefix, ()) 302 303-- definition attribute 304-- 305 306-- | get the definition of an identifier 307-- 308-- * the attribute must be defined, ie, a definition must be associated with 309-- the given identifier 310-- 311getDefOf :: Ident -> CT s CDef 312getDefOf ide = do 313 def <- readAttrCCT $ \ac -> getDefOfIdentC ac ide 314 assert (not . isUndef $ def) $ 315 return def 316 317 318-- | set the definition of an identifier 319-- 320refersToDef :: Ident -> CDef -> CT s () 321refersToDef ide def = 322 do traceCTrav $ "linking identifier: "++ dumpIdent ide ++ " --> " ++ show def 323 transAttrCCT $ \akl -> (setDefOfIdentC akl ide def, ()) 324 325-- | update the definition of an identifier 326-- 327refersToNewDef :: Ident -> CDef -> CT s () 328refersToNewDef ide def = 329 transAttrCCT $ \akl -> (updDefOfIdentC akl ide def, ()) 330 331-- | get the declarator of an identifier 332-- 333getDeclOf :: Ident -> CT s CDecl 334getDeclOf ide = 335 do 336 traceEnter 337 def <- getDefOf ide 338 case def of 339 UndefCD -> interr "CTrav.getDeclOf: Undefined!" 340 DontCareCD -> interr "CTrav.getDeclOf: Don't care!" 341 TagCD _ -> interr "CTrav.getDeclOf: Illegal tag!" 342 ObjCD obj -> case obj of 343 TypeCO decl -> traceTypeCO decl >> 344 return decl 345 ObjCO decl -> traceObjCO decl >> 346 return decl 347 EnumCO _ _ -> illegalEnum 348 BuiltinCO Nothing -> illegalBuiltin 349 BuiltinCO (Just decl) -> traceBuiltinCO >> 350 return decl 351 where 352 illegalEnum = interr "CTrav.getDeclOf: Illegal enum!" 353 illegalBuiltin = interr "CTrav.getDeclOf: Attempted to get declarator of \ 354 \builtin entity!" 355 -- if the latter ever becomes necessary, we have to 356 -- change the representation of builtins and give them 357 -- some dummy declarator 358 traceEnter = traceCTrav 359 $ "Entering `getDeclOf' for `" ++ identToString ide 360 ++ "'...\n" 361 traceTypeCO decl = traceCTrav 362 $ "...found a type object:\n" ++ show decl ++ "\n" 363 traceObjCO decl = traceCTrav 364 $ "...found a vanilla object:\n" ++ show decl ++ "\n" 365 traceBuiltinCO = traceCTrav 366 $ "...found a builtin object with a proxy decl.\n" 367 368-- convenience functions 369-- 370 371findTypeObjMaybeWith :: Bool -> Ident -> Bool -> CT s (Maybe (CObj, Ident)) 372findTypeObjMaybeWith soft ide useShadows = 373 do 374 oobj <- if useShadows 375 then findObjShadow ide 376 else liftM (fmap (\obj -> (obj, ide))) $ findObj ide 377 case oobj of 378 Just obj@(TypeCO _ , _) -> return $ Just obj 379 Just obj@(BuiltinCO _, _) -> return $ Just obj 380 Just _ -> if soft 381 then return Nothing 382 else typedefExpectedErr ide 383 Nothing -> return $ Nothing 384 385-- | find a type object in the object name space; returns 'Nothing' if the 386-- identifier is not defined 387-- 388-- * if the second argument is 'True', use 'findObjShadow' 389-- 390findTypeObjMaybe :: Ident -> Bool -> CT s (Maybe (CObj, Ident)) 391findTypeObjMaybe = findTypeObjMaybeWith False 392 393-- | find a type object in the object name space; raises an error and exception 394-- if the identifier is not defined 395-- 396-- * if the second argument is 'True', use 'findObjShadow' 397-- 398findTypeObj :: Ident -> Bool -> CT s (CObj, Ident) 399findTypeObj ide useShadows = do 400 oobj <- findTypeObjMaybe ide useShadows 401 case oobj of 402 Nothing -> unknownObjErr ide 403 Just obj -> return obj 404 405-- | find an object, function, or enumerator in the object name space; raises an 406-- error and exception if the identifier is not defined 407-- 408-- * if the second argument is 'True', use 'findObjShadow' 409-- 410findValueObj :: Ident -> Bool -> CT s (CObj, Ident) 411findValueObj ide useShadows = 412 do 413 oobj <- if useShadows 414 then findObjShadow ide 415 else liftM (fmap (\obj -> (obj, ide))) $ findObj ide 416 case oobj of 417 Just obj@(ObjCO _ , _) -> return obj 418 Just obj@(EnumCO _ _, _) -> return obj 419 Just _ -> unexpectedTypedefErr (posOf ide) 420 Nothing -> unknownObjErr ide 421 422-- | find a function in the object name space; raises an error and exception if 423-- the identifier is not defined 424-- 425-- * if the second argument is 'True', use 'findObjShadow' 426-- 427findFunObj :: Ident -> Bool -> CT s (CObj, Ident) 428findFunObj ide useShadows = 429 do 430 (obj, ide') <- findValueObj ide useShadows 431 case obj of 432 EnumCO _ _ -> funExpectedErr (posOf ide) 433 ObjCO decl -> do 434 let declr = ide' `declrFromDecl` decl 435 assertFunDeclr (posOf ide) declr 436 return (obj, ide') 437 438 439-- C structure tree query routines 440-- ------------------------------- 441 442-- | test if this is a type definition specification 443-- 444isTypedef :: CDecl -> Bool 445isTypedef (CDecl specs _ _) = 446 not . null $ [() | CStorageSpec (CTypedef _) <- specs] 447 448-- | discard all declarators but the one declaring the given identifier 449-- 450-- * the declaration must contain the identifier 451-- 452simplifyDecl :: Ident -> CDecl -> CDecl 453ide `simplifyDecl` (CDecl specs declrs at) = 454 case find (`declrPlusNamed` ide) declrs of 455 Nothing -> err 456 Just declr -> CDecl specs [declr] at 457 where 458 (Just declr, _, _) `declrPlusNamed` ide' = declr `declrNamed` ide' 459 _ `declrPlusNamed` _ = False 460 -- 461 err = interr $ "CTrav.simplifyDecl: Wrong C object!\n\ 462 \ Looking for `" ++ identToString ide ++ "' in decl \ 463 \at " ++ show (posOf at) 464 465-- | extract the declarator that declares the given identifier 466-- 467-- * the declaration must contain the identifier 468-- 469declrFromDecl :: Ident -> CDecl -> CDeclr 470ide `declrFromDecl` decl = 471 let CDecl _ [(Just declr, _, _)] _ = ide `simplifyDecl` decl 472 in 473 declr 474 475-- | tests whether the given declarator has the given name 476-- 477declrNamed :: CDeclr -> Ident -> Bool 478declr `declrNamed` ide = declrName declr == Just ide 479 480-- | get the declarator of a declaration that has at most one declarator 481-- 482declaredDeclr :: CDecl -> Maybe CDeclr 483declaredDeclr (CDecl _ [] _) = Nothing 484declaredDeclr (CDecl _ [(odeclr, _, _)] _) = odeclr 485declaredDeclr decl = 486 interr $ "CTrav.declaredDeclr: Too many declarators!\n\ 487 \ Declaration at " ++ show (posOf decl) 488 489-- | get the initialiser of a declaration that has at most one initialiser 490-- 491initDeclr :: CDecl -> Maybe (CInitializer NodeInfo) 492initDeclr (CDecl _ [] _) = Nothing 493initDeclr (CDecl _ [(_, ini, _)] _) = ini 494initDeclr decl = 495 interr $ "CTrav.initDeclr: Too many declarators!\n\ 496 \ Declaration at " ++ show (posOf decl) 497 498-- | get the name declared by a declaration that has exactly one declarator 499-- 500declaredName :: CDecl -> Maybe Ident 501declaredName decl = declaredDeclr decl >>= declrName 502 503-- | obtains the member definitions and the tag of a struct 504-- 505-- * member definitions are expanded 506-- 507structMembers :: CStructUnion -> ([CDecl], CStructTag) 508structMembers (CStruct tag _ members _ _) = (concat . map expandDecl $ maybe [] id members, tag) 509 510-- | expand declarators declaring more than one identifier into multiple 511-- declarators, eg, `int x, y;' becomes `int x; int y;' 512-- For case of a declarator that declares no identifier, preserve the no-identifier decl. 513-- 514expandDecl :: CDecl -> [CDecl] 515expandDecl decl@(CDecl _ [] _) = 516 [decl] -- no name member stays as member without a name. 517expandDecl (CDecl specs decls at) = 518 map (\decl -> CDecl specs [decl] at) decls 519 520-- | get a struct's name 521-- 522structName :: CStructUnion -> Maybe Ident 523structName (CStruct _ oide _ _ _) = oide 524 525-- | get an enum's name 526-- 527enumName :: CEnum -> Maybe Ident 528enumName (CEnum oide _ _ _) = oide 529 530-- | get a tag's name 531-- 532-- * fail if the tag is anonymous 533-- 534tagName :: CTag -> Ident 535tagName tag = 536 case tag of 537 StructUnionCT struct -> maybe err id $ structName struct 538 EnumCT enum -> maybe err id $ enumName enum 539 where 540 err = interr "CTrav.tagName: Anonymous tag definition" 541 542-- | checks whether the given declarator defines an object that is a pointer to 543-- some other type 544-- 545-- * as far as parameter passing is concerned, arrays are also pointer 546-- 547isPtrDeclr :: CDeclr -> Bool 548isPtrDeclr (CDeclr _ (CPtrDeclr _ _:_) _ _ _) = True 549isPtrDeclr (CDeclr _ (CArrDeclr _ _ _:_) _ _ _) = True 550isPtrDeclr _ = False 551 552-- | Need to distinguish between pointer and array declarations within 553-- structures. 554-- 555isArrDeclr :: CDeclr -> Maybe Int 556isArrDeclr (CDeclr _ (CArrDeclr _ sz _:_) _ _ _) = Just $ szToInt sz 557 where szToInt (CArrSize _ (CConst (CIntConst s _))) = 558 fromIntegral $ getCInteger s 559 szToInt _ = 1 560isArrDeclr _ = Nothing 561 562 563-- | drops the first pointer level from the given declarator 564-- 565-- * the declarator must declare a pointer object 566-- 567-- * arrays are considered to be pointers 568-- 569-- FIXME: this implementation isn't nice, because we retain the 'CVarDeclr' 570-- unchanged; as the declarator is changed, we should maybe make this 571-- into an anonymous declarator and also change its attributes 572-- 573dropPtrDeclr :: CDeclr -> CDeclr 574dropPtrDeclr (CDeclr ide (outermost:derived) asm ats node) = 575 case outermost of 576 (CPtrDeclr _ _) -> CDeclr ide derived asm ats node 577 (CArrDeclr _ _ _) -> CDeclr ide derived asm ats node 578 _ -> interr "CTrav.dropPtrDeclr: No pointer!" 579 580-- | checks whether the given declaration defines a pointer object 581-- 582-- * there may only be a single declarator in the declaration 583-- 584isPtrDecl :: CDecl -> Bool 585isPtrDecl (CDecl _ [] _) = False 586isPtrDecl (CDecl _ [(Just declr, _, _)] _) = isPtrDeclr declr 587isPtrDecl _ = 588 interr "CTrav.isPtrDecl: There was more than one declarator!" 589 590isArrDecl :: CDecl -> Maybe Int 591isArrDecl (CDecl _ [] _) = Nothing 592isArrDecl (CDecl _ [(Just declr, _, _)] _) = isArrDeclr declr 593isArrDecl _ = 594 interr "CTrav.isArrDecl: There was more than one declarator!" 595 596-- | checks whether the given declarator defines a function object 597-- 598isFunDeclr :: CDeclr -> Bool 599isFunDeclr (CDeclr _ (CFunDeclr _ _ _:_) _ _ _) = True 600isFunDeclr _ = False 601 602-- | extract the structure from the type specifiers of a declaration 603-- 604structFromDecl :: Position -> CDecl -> CT s CStructUnion 605structFromDecl pos (CDecl specs _ _) = 606 case head [ts | CTypeSpec ts <- specs] of 607 CSUType su _ -> extractStruct pos (StructUnionCT su) 608 _ -> structExpectedErr pos 609 610structFromDecl' :: Position -> CDecl -> CT s (Maybe CStructUnion) 611structFromDecl' pos (CDecl specs _ _) = 612 case head [ts | CTypeSpec ts <- specs] of 613 CSUType su _ -> extractStruct' pos (StructUnionCT su) 614 _ -> structExpectedErr pos 615 616-- | extracts the arguments from a function declaration (must be a unique 617-- declarator) and constructs a declaration for the result of the function 618-- 619-- * the boolean result indicates whether the function is variadic 620-- 621-- * returns an abstract declarator 622funResultAndArgs :: CDecl -> ([CDecl], CDecl, Bool) 623funResultAndArgs cdecl@(CDecl specs [(Just declr, _, _)] _) = 624 let (args, declr', variadic) = funArgs declr 625 result = CDecl specs [(Just declr', Nothing, Nothing)] 626 (newAttrsOnlyPos (posOf cdecl)) 627 in 628 (args, result, variadic) 629 where 630 funArgs (CDeclr _ide derived _asm _ats node) = 631 case derived of 632 (CFunDeclr (Right (args,variadic)) _ats' _dnode : derived') -> 633 (args, CDeclr Nothing derived' Nothing [] node, variadic) 634 (CFunDeclr (Left _) _ _ : _) -> 635 interr "CTrav.funResultAndArgs: Old style function definition" 636 _ -> interr "CTrav.funResultAndArgs: Illegal declarator!" 637 638-- name chasing 639-- 640 641-- | find the declarator identified by the given identifier; if the declarator 642-- is itself only a 'typedef'ed name, the operation recursively searches for 643-- the declarator associated with that name (this is called ``typedef 644-- chasing'') 645-- 646-- * if `ind = True', we have to hop over one indirection 647-- 648-- * remove all declarators except the one we just looked up 649-- 650chaseDecl :: Ident -> Bool -> CT s CDecl 651-- 652-- * cycles are no issue, as they cannot occur in a correct C header (we would 653-- have spotted the problem during name analysis) 654-- 655chaseDecl ide ind = 656 do 657 traceEnter 658 cdecl <- getDeclOf ide 659 let sdecl = ide `simplifyDecl` cdecl 660 case extractAlias sdecl ind of 661 Just (ide', ind') -> chaseDecl ide' ind' 662 Nothing -> return sdecl 663 where 664 traceEnter = traceCTrav $ 665 "Entering `chaseDecl' for `" ++ identToString ide 666 ++ "' " ++ (if ind then "" else "not ") 667 ++ "following indirections...\n" 668 669-- | find type object in object name space and then chase it 670-- 671-- * see also 'chaseDecl' 672-- 673-- * also create an object association from the given identifier to the object 674-- that it _directly_ represents 675-- 676-- * if the third argument is 'True', use 'findObjShadow' 677-- 678findAndChaseDecl :: Ident -> Bool -> Bool -> CT s CDecl 679findAndChaseDecl ide ind useShadows = 680 do 681 traceCTrav $ "findAndChaseDecl: " ++ show ide ++ " (" ++ 682 show useShadows ++ ")\n" 683 (obj, ide') <- findTypeObj ide useShadows -- is there an object def? 684 ide `refersToNewDef` ObjCD obj 685 ide' `refersToNewDef` ObjCD obj -- assoc needed for chasing 686 chaseDecl ide' ind 687 688findAndChaseDeclOrTag :: Ident -> Bool -> Bool -> CT s CDecl 689findAndChaseDeclOrTag ide ind useShadows = 690 do 691 traceCTrav $ "findAndChaseDeclOrTag: " ++ show ide ++ " (" ++ 692 show useShadows ++ ")\n" 693 mobjide <- findTypeObjMaybeWith True ide useShadows -- is there an object def? 694 case mobjide of 695 Just (obj, ide') -> do 696 ide `refersToNewDef` ObjCD obj 697 ide' `refersToNewDef` ObjCD obj -- assoc needed for chasing 698 chaseDecl ide' ind 699 Nothing -> do 700 otag <- if useShadows 701 then findTagShadow ide 702 else liftM (fmap (\tag -> (tag, ide))) $ findTag ide 703 case otag of 704 Just (StructUnionCT su, _) -> do 705 let (CStruct _ _ _ _ nodeinfo) = su 706 return $ CDecl [CTypeSpec (CSUType su nodeinfo)] [] nodeinfo 707 _ -> unknownObjErr ide 708 709-- | given a declaration (which must have exactly one declarator), if the 710-- declarator is an alias, chase it to the actual declaration 711-- 712checkForAlias :: CDecl -> CT s (Maybe CDecl) 713checkForAlias decl = 714 case extractAlias decl False of 715 Nothing -> return Nothing 716 Just (ide', _) -> liftM Just $ chaseDecl ide' False 717 718-- | given a declaration (which must have exactly one declarator), if the 719-- declarator is an alias, yield the alias name; *no* chasing 720-- 721checkForOneAliasName :: CDecl -> Maybe Ident 722checkForOneAliasName decl = fmap fst $ extractAlias decl False 723 724-- | given a declaration, find the name of the struct/union type 725checkForOneCUName :: CDecl -> Maybe Ident 726checkForOneCUName decl@(CDecl specs _ _) = 727 case [ts | CTypeSpec ts <- specs] of 728 [CSUType (CStruct _ n _ _ _) _] -> 729 case declaredDeclr decl of 730 Nothing -> n 731 Just (CDeclr _ [] _ _ _) -> n -- no type derivations 732 _ -> Nothing 733 _ -> Nothing 734 735-- smart lookup 736-- 737 738-- | for the given identifier, either find an enumeration in the tag name space 739-- or a type definition referring to an enumeration in the object name space; 740-- raises an error and exception if the identifier is not defined 741-- 742-- * if the second argument is 'True', use 'findTagShadow' 743-- 744lookupEnum :: Ident -> Bool -> CT s CEnum 745lookupEnum ide useShadows = 746 do 747 otag <- if useShadows 748 then liftM (fmap fst) $ findTagShadow ide 749 else findTag ide 750 case otag of 751 Just (StructUnionCT _ ) -> enumExpectedErr ide -- wrong tag definition 752 Just (EnumCT enum) -> return enum -- enum tag definition 753 Nothing -> do -- no tag definition 754 oobj <- if useShadows 755 then liftM (fmap fst) $ findObjShadow ide 756 else findObj ide 757 case oobj of 758 Just (EnumCO _ enum) -> return enum -- anonymous enum 759 _ -> do -- no value definition 760 (CDecl specs _ _) <- findAndChaseDecl ide False useShadows 761 case head [ts | CTypeSpec ts <- specs] of 762 CEnumType enum _ -> return enum 763 _ -> enumExpectedErr ide 764 765-- | for the given identifier, either find a struct/union in the tag name space 766-- or a type definition referring to a struct/union in the object name space; 767-- raises an error and exception if the identifier is not defined 768-- 769-- * the parameter `preferTag' determines whether tags or typedefs are 770-- searched first 771-- 772-- * if the third argument is `True', use `findTagShadow' 773-- 774-- * when finding a forward definition of a tag, follow it to the real 775-- definition 776-- 777lookupStructUnion :: Ident -> Bool -> Bool -> CT s CStructUnion 778lookupStructUnion ide preferTag useShadows = do 779 traceCTrav $ "lookupStructUnion: ide=" ++ show ide ++ " preferTag=" ++ 780 show preferTag ++ " useShadows=" ++ show useShadows ++ "\n" 781 otag <- if useShadows 782 then liftM (fmap fst) $ findTagShadow ide 783 else findTag ide 784 mobj <- if useShadows 785 then findObjShadow ide 786 else liftM (fmap (\obj -> (obj, ide))) $ findObj ide 787 let oobj = case mobj of 788 Just obj@(TypeCO{}, _) -> Just obj 789 Just obj@(BuiltinCO{}, _) -> Just obj 790 _ -> Nothing 791 case preferTag of 792 True -> case otag of 793 Just tag -> extractStruct (posOf ide) tag 794 Nothing -> do 795 decl <- findAndChaseDecl ide True useShadows 796 structFromDecl (posOf ide) decl 797 False -> case oobj of 798 Just _ -> do 799 decl <- findAndChaseDecl ide True useShadows 800 mres <- structFromDecl' (posOf ide) decl 801 case mres of 802 Just su -> return su 803 Nothing -> case otag of 804 Just tag -> extractStruct (posOf ide) tag 805 Nothing -> unknownObjErr ide 806 Nothing -> case otag of 807 Just tag -> extractStruct (posOf ide) tag 808 Nothing -> unknownObjErr ide 809 810-- | for the given identifier, check for the existance of both a type definition 811-- or a struct, union, or enum definition 812-- 813-- * if a typedef and a tag exists, the typedef takes precedence 814-- 815-- * typedefs are chased 816-- 817-- * if the second argument is `True', look for shadows, too 818-- 819lookupDeclOrTag :: Ident -> Bool -> CT s (Either CDecl CTag) 820lookupDeclOrTag ide useShadows = do 821 oobj <- findTypeObjMaybeWith True ide useShadows 822 case oobj of 823 Just (_, ide') -> liftM Left $ findAndChaseDecl ide' False False 824 -- already did check shadows 825 Nothing -> do 826 otag <- if useShadows 827 then liftM (fmap fst) $ findTagShadow ide 828 else findTag ide 829 case otag of 830 Nothing -> unknownObjErr ide 831 Just tag -> return $ Right tag 832 833 834-- auxiliary routines (internal) 835-- 836 837-- | if the given declaration (which may have at most one declarator) is a 838-- `typedef' alias, yield the referenced name 839-- 840-- * a `typedef' alias has one of the following forms 841-- 842-- <specs> at x, ...; 843-- <specs> at *x, ...; 844-- 845-- where `at' is the alias type, which has been defined by a `typedef', and 846-- <specs> are arbitrary specifiers and qualifiers. Note that `x' may be a 847-- variable, a type name (if `typedef' is in <specs>), or be entirely 848-- omitted. 849-- 850-- * if `ind = True', the alias may be via an indirection 851-- 852-- * if `ind = True' and the alias is _not_ over an indirection, yield `True'; 853-- otherwise `False' (ie, the ability to hop over an indirection is consumed) 854-- 855-- * this may be an anonymous declaration, ie, the name in `CVarDeclr' may be 856-- omitted or there may be no declarator at all 857-- 858extractAlias :: CDecl -> Bool -> Maybe (Ident, Bool) 859extractAlias decl@(CDecl specs _ _) ind = 860 case [ts | CTypeSpec ts <- specs] of 861 [CTypeDef ide' _] -> -- type spec is aliased ident 862 case declaredDeclr decl of 863 Nothing -> Just (ide', ind) 864 Just (CDeclr _ [] _ _ _) -> Just (ide', ind) -- no type derivations 865 Just (CDeclr _ [CPtrDeclr _ _] _ _ _) -- one pointer indirection 866 | ind -> Just (ide', False) 867 | otherwise -> Nothing 868 _ -> Nothing 869 _ -> Nothing 870 871-- | if the given tag is a forward declaration of a structure, follow the 872-- reference to the full declaration 873-- 874-- * the recursive call is not dangerous as there can't be any cycles 875-- 876extractStruct :: Position -> CTag -> CT s CStructUnion 877extractStruct pos (EnumCT _ ) = structExpectedErr pos 878extractStruct pos (StructUnionCT su) = do 879 traceCTrav $ "extractStruct: " ++ show su ++ "\n" 880 case su of 881 CStruct _ (Just ide') Nothing _ _ -> do -- found forward definition 882 def <- getDefOf ide' 883 traceCTrav $ "def=" ++ show def ++ "\n" 884 case def of 885 TagCD tag -> extractStruct pos tag 886 UndefCD -> incompleteTypeErr pos 887 bad_obj -> err ide' bad_obj 888 _ -> return su 889 where 890 err ide bad_obj = 891 do interr $ "CTrav.extractStruct: Illegal reference! Expected " ++ dumpIdent ide ++ 892 " to link to TagCD but refers to "++ (show bad_obj) ++ "\n" 893 894extractStruct' :: Position -> CTag -> CT s (Maybe CStructUnion) 895extractStruct' pos (EnumCT _ ) = structExpectedErr pos 896extractStruct' pos (StructUnionCT su) = do 897 traceCTrav $ "extractStruct': " ++ show su ++ "\n" 898 case su of 899 CStruct _ (Just ide') Nothing _ _ -> do 900 def <- getDefOf ide' 901 traceCTrav $ "def=" ++ show def ++ "\n" 902 case def of 903 TagCD tag -> do 904 res <- extractStruct pos tag 905 return . Just $ res 906 _ -> return Nothing 907 _ -> return . Just $ su 908 909-- | yield the name declared by a declarator if any 910-- 911declrName :: CDeclr -> Maybe Ident 912declrName (CDeclr oide _ _ _ _) = oide 913 914-- | raise an error if the given declarator does not declare a C function or if 915-- the function is supposed to return an array (the latter is illegal in C) 916-- 917assertFunDeclr :: Position -> CDeclr -> CT s () 918assertFunDeclr pos (CDeclr _ (CFunDeclr _ _ _:retderiv) _ _ _) = 919 case retderiv of 920 (CArrDeclr _ _ _:_) -> illegalFunResultErr pos 921 _ -> return () -- ok, we have a function which doesn't return an array 922assertFunDeclr pos _ = 923 funExpectedErr pos 924 925-- | trace for this module 926-- 927traceCTrav :: String -> CT s () 928traceCTrav = putTraceStr traceCTravSW 929 930 931-- error messages 932-- -------------- 933 934unknownObjErr :: Ident -> CT s a 935unknownObjErr ide = 936 raiseErrorCTExc (posOf ide) 937 ["Unknown identifier!", 938 "Cannot find a definition for `" ++ identToString ide ++ "' in the \ 939 \header file."] 940 941typedefExpectedErr :: Ident -> CT s a 942typedefExpectedErr ide = 943 raiseErrorCTExc (posOf ide) 944 ["Expected type definition!", 945 "The identifier `" ++ identToString ide ++ "' needs to be a C type name."] 946 947unexpectedTypedefErr :: Position -> CT s a 948unexpectedTypedefErr pos = 949 raiseErrorCTExc pos 950 ["Unexpected type name!", 951 "An object, function, or enum constant is required here."] 952 953illegalFunResultErr :: Position -> CT s a 954illegalFunResultErr pos = 955 raiseErrorCTExc pos ["Function cannot return an array!", 956 "ANSI C does not allow functions to return an array."] 957 958funExpectedErr :: Position -> CT s a 959funExpectedErr pos = 960 raiseErrorCTExc pos 961 ["Function expected!", 962 "A function is needed here, but this declarator does not declare", 963 "a function."] 964 965enumExpectedErr :: Ident -> CT s a 966enumExpectedErr ide = 967 raiseErrorCTExc (posOf ide) 968 ["Expected enum!", 969 "Expected `" ++ identToString ide ++ "' to denote an enum; instead found", 970 "a struct, union, or object."] 971 972structExpectedErr :: Position -> CT s a 973structExpectedErr pos = 974 raiseErrorCTExc pos 975 ["Expected a struct!", 976 "Expected a structure or union; instead found an enum or basic type."] 977 978incompleteTypeErr :: Position -> CT s a 979incompleteTypeErr pos = 980 raiseErrorCTExc pos 981 ["Illegal use of incomplete type!", 982 "Expected a fully defined structure or union tag; instead found incomplete type."] 983