1------------------------------------------------------------------------------ 2-- -- 3-- GNATCHECK COMPONENTS -- 4-- -- 5-- A S I S _ U L . G L O B A L _ S T A T E . C G -- 6-- -- 7-- B o d y -- 8-- -- 9-- Copyright (C) 2007-2015, AdaCore -- 10-- -- 11-- Asis Utility Library (ASIS UL) is free software; you can redistribute it -- 12-- and/or modify it under terms of the GNU General Public License as -- 13-- published by the Free Software Foundation; either version 3, or (at your -- 14-- option) any later version. ASIS UL is distributed in the hope that it -- 15-- will be useful, but WITHOUT ANY WARRANTY; without even the implied -- 16-- warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -- 17-- GNU General Public License for more details. You should have received a -- 18-- copy of the GNU General Public License distributed with GNAT; see file -- 19-- COPYING3. If not, go to http://www.gnu.org/licenses for a complete copy -- 20-- of the license. -- 21-- -- 22-- ASIS UL is maintained by AdaCore (http://www.adacore.com). -- 23-- -- 24------------------------------------------------------------------------------ 25 26with GNAT.Directory_Operations; use GNAT.Directory_Operations; 27with GNAT.OS_Lib; use GNAT.OS_Lib; 28 29with Asis; use Asis; 30with Asis.Clauses; use Asis.Clauses; 31with Asis.Compilation_Units; use Asis.Compilation_Units; 32with Asis.Declarations; use Asis.Declarations; 33with Asis.Definitions; use Asis.Definitions; 34with Asis.Elements; use Asis.Elements; 35with Asis.Expressions; use Asis.Expressions; 36with Asis.Extensions; use Asis.Extensions; 37with Asis.Extensions.Flat_Kinds; use Asis.Extensions.Flat_Kinds; 38with Asis.Iterator; use Asis.Iterator; 39with Asis.Statements; use Asis.Statements; 40 41with Asis.Set_Get; use Asis.Set_Get; 42 43with ASIS_UL.Common; 44with ASIS_UL.Global_State.CG.Conditions; 45use ASIS_UL.Global_State.CG.Conditions; 46with ASIS_UL.Options; use ASIS_UL.Options; 47with ASIS_UL.Output; use ASIS_UL.Output; 48with ASIS_UL.Utilities; use ASIS_UL.Utilities; 49 50with ASIS_UL.Global_State.Utilities; use ASIS_UL.Global_State.Utilities; 51with ASIS_UL.Global_State.Data; use ASIS_UL.Global_State.Data; 52 53package body ASIS_UL.Global_State.CG is 54 55 ---------------------------------------------------------------- 56 -- Processing of dispatching operations and dispatching calls -- 57 ---------------------------------------------------------------- 58 59 --------------------------------------------------------------------------- 60 -- Existing approach is not 100% correct and does not work for the case -- 61 -- of multiple inheritance: ??? -- 62 --------------------------------------------------------------------------- 63 64 -- For a dispatching call, the link to the corresponding dispatching 65 -- operation (RM05 3.9.2 (1/2)) is stored as an ordinary call. 66 -- 67 -- For each dispatching operation, if the operation overrides some other 68 -- (dispatching) operation, a call from overriden operation to the 69 -- overriding one is stored. The call graph stores only explicetely (???) 70 -- declared entities, so if P(1) is an eplicitely declared dispatching 71 -- operation, P(2) is the corresponding implicetely declared inherited 72 -- operation, and P(3) is overriding dispatching operation that actually 73 -- overrides what could be inherited from P(2), then the link (the call) 74 -- from P(1) to P(3) will be stored. 75 76 ------------------------- 77 -- To be implemented: -- 78 ------------------------- 79 80 -- ????? 81 82 -- Dispatching operations and dispatching calls make the following problem 83 -- for the call graph: 84 -- 85 -- * At the place of a dispatching call, any of the operations that 86 -- overrides the given operation can be called, BUT: 87 -- 88 -- * when processing a dispatching call, we do not have a full set of 89 -- operations to that the call can be dispatched 90 -- 91 -- * when processing a dispatching operation that overrides some other 92 -- dispatching operation, we do not know if the overridden operation is 93 -- a root of some dispatching call. An implicit inherited operation is 94 -- not stored in the call graph if it is not a root of some dispatching 95 -- call (???); 96 -- 97 -- The following way of representing dispatching operations in the call 98 -- graph is suggested 99 -- 100 -- * all the dispatching operations are stored in the call graph (including 101 -- implicit inherited operations and abstract operations); 102 -- 103 -- * for each dispatching operations, a list of corresponding operations 104 -- of the types directly derived from the type that "owns" this operation 105 -- is stored (corresponding operation here is either the inherited 106 -- operation corresponding to this operation, or an explicitly declared 107 -- operatation that overrides it. For this list we will be using the 108 -- term "operations implementing the given dispatching operation". Term 109 -- is not really good, but we try to express the following: if 110 -- implemented operation is a dispatching root, then implementing 111 -- operation can be called as the result of dispatching. 112 -- 113 -- * for multiple inheritance,one operation can be implementing operation 114 -- for more than one "parent" implemented operations; 115 -- 116 -- * dispatching calls are stored as separate lists. For each dispatching 117 -- call, the corresponding dispatching operation is stored in the list 118 -- of dispatching calls. If dispatching operation is not abstract 119 -- operation, the dispatching call is stored as an ordinary 120 -- non-dispatching call in the list of direct calls (that is, the result 121 -- of node representing the result of Corresponding_Element applied to 122 -- the dispatching operation is stored; 123 -- 124 -- * call graph transitive closure is performed in two steps: 125 -- 126 -- 1. for each dispatching operation, the list of all the operations that 127 -- implement the given dispatching operation, directly or indirectly, 128 -- is created; 129 -- 130 -- 2. for each node N, for each node M from the list of dispatching calls 131 -- issued by N, the list of 132 -- operations implementing the corresponding dispatching operation M 133 -- (that is, the list of operations to that the call can be dispatched) 134 -- is added to the list of direct calls issued by N 135 -- 136 -- 3. Normal transitive closure of the call graph is performed. 137 -- 138 -- ??? 139 140 ----------------------- 141 -- Local subprograms -- 142 ----------------------- 143 144 procedure Process_Call 145 (Element : Asis.Element; 146 At_SLOC : String_Loc := Nil_String_Loc); 147 -- Analyzes a subprogram call. If the call cannot be statically analyzed, 148 -- ??????????????????????? 149 -- generates the corresponding diagnostic message in case if ??? is ON. 150 -- IF At_SLOC is equal to Nil_String_Loc, the SLOC of the call is the SLOC 151 -- of the argument Element, otherwise At_SLOC is used as the SLOC of the 152 -- call (see the documentation for Add_CG_Info). 153 154 procedure Process_Callable_Entity (El : Asis.Element); 155 -- Stores (if needed) in the call graph the information about the 156 -- callable entity. In case of a single task declaration, this procedure 157 -- also stores the call link from the current scope to the task entity 158 159 procedure Process_Elaboration_Calls (Element : Asis.Element); 160 -- For the argument Element that should be 161 -- ASIS_UL.Utilities.May_Contain_Elaboration_Calls, tries to find implicit 162 -- calls that are made during the elaboration and for each of these calls 163 -- processes this call as a regular call. 164 165 procedure Process_Type_Default_Expressions 166 (Type_To_Analyze : Asis.Element; 167 Call_At_SLOC : String_Loc); 168 -- Implements a part of the functionality of Process_Elaboration_Calls 169 -- Recursively traverses the type structure of the type represented by 170 -- Type_To_Analyze argument (note that this type should not be private or 171 -- derived type!) and adds all the fucntion calls from the component 172 -- expressions in the call graph. At_SLOC parameter represents the location 173 -- of the calls to store (because these calls are issued as a part of 174 -- object declaration elaboration declaration or allocator evaluation). 175 176 procedure Process_Init_Expressions_In_Record_Components 177 (Component_List : Asis.Element_List; 178 Call_At_SLOC : String_Loc); 179 -- Implements a part of the functionality of 180 -- Process_Type_Default_Expressions. Traverses the argument list and do 181 -- the following: 182 -- 183 -- - if a list element is a component definition and it contains an 184 -- initialization expression, traverses this expression to locate 185 -- function calls; 186 -- 187 -- - if a list element is a component definition and it does not contain an 188 -- initialization expression, analyzes the component type to get 189 -- initialization expressions for suncomponents and to extract function 190 -- calls from them; 191 -- 192 -- - if a list elemen is a variant part, recursively gets into the variant 193 -- part strcture to get and to analyze the variant components; 194 -- 195 -- For errey compoenets, the component type is analyzed for possible 196 -- default initialization expressions. 197 198 procedure Process_Renaming_As_Body (El : Asis.Element); 199 -- If we have renaming-as-body, this means that we have the corresponding 200 -- subprigram declaration, so - the corresponding node in the call graph. 201 -- This subprogram detects (and creates, if needed) the corresponding node 202 -- in the call graph and sets for this node Is_Renaming ON. Then in tries 203 -- to unwind the renaming, and if the renamed entity can be statically 204 -- defined, stores the ID of this entity in the Calls_Chain for the node. 205 -- (That is, if we have a subprogram that has renaming-as-body as its 206 -- completion, we represent this in the call graph as if this subprogram 207 -- calls the renamed subprogram. The case of renaming a task entry as a 208 -- subprogram is not implemented yet.) 209 210 procedure Process_Task_Components 211 (Type_Decl : Asis.Element; 212 Call_At_SLOC : String_Loc; 213 Recursive_Call : Boolean := False); 214 -- Analyze the argument type declaration and defines the tasks that are 215 -- created when creating the value of this type. It is supposed that 216 -- Get_Type_Structure function has already been applied to the argument 217 -- type declaration. The actual for Call_At_SLOC should indicate the source 218 -- location of the construct that initiate task creations (e.g. SLOC of an 219 -- object declaration that contains task components). 220 -- 221 -- The problem of this procedure is that it can get into cycles in case of 222 -- recursive record types. Two cases of recursion are possible: 223 -- 224 -- type Rec_1 is record 225 -- ... 226 -- C : access Rec_1; 227 -- ... 228 -- end record 229 -- 230 -- and 231 -- 232 -- type Rec_2; 233 -- type Rec_3; 234 -- 235 -- type Access_Rec_2 is access Rec_2 236 -- type Access_Rec_3 is access Rec_3 237 -- 238 -- type Rec_2 is record 239 -- C : Access_Rec_3; 240 -- .... 241 -- end record; 242 -- 243 -- type Rec_3 is record 244 -- C : Access_Rec_2; 245 -- .... 246 -- end record; 247 -- 248 -- The break this cycling, Recursive_Call parameter is used. When this 249 -- parameter is False, the query starts from cleaning the set of processed 250 -- types, otherwise it does not do this. Before strarting processing a type 251 -- declaration, the qery checks if it already stored in the set of 252 -- processed types, and if it is, skips this type. 253 -- 254 -- All the calls to this query from the code that builds the call graph 255 -- should be with Recursive_Call => False to avoid cycling 256 257 Processed_Types : Asis.Extensions.Element_Containers.Set; 258 259 procedure Process_Record_Task_Components 260 (Component_List : Asis.Element_List; 261 Call_At_SLOC : String_Loc); 262 -- Similar to the Process_Task_Components procedure, but works on a list of 263 -- record components (more exactly, on the list returned by the 264 -- Asis.Definitions.Record_Components query. 265 266 procedure Process_Task_Creation (El : Asis.Element); 267 -- Supposing that Can_Create_Tasks (El), recursively traverse the type 268 -- declaration of the object or value representing by El and stores the 269 -- information about all the tasks (if any) that are created when the 270 -- object/value is cretaed. 271 -- (Suppose we have: 272 -- 273 -- task type T is ,.. end T; 274 -- type Rec is record 275 -- Comp_I : Integer; 276 -- Comp_T : T; 277 -- end record; 278 -- 279 -- Var : Rec; -- here a task of type T is created, 280 -- 281 -- This procedure should get from the declaration of Var the information 282 -- that a task of the type T is created as a result of elaboration this 283 -- declaration. 284 285 procedure Process_Stream_Attribute_Redefinition 286 (Element : Asis.Element; 287 At_SLOC : String_Loc); 288 -- Assuming that El is an attribute definition clause that redefines a 289 -- stream attribute, tries to define the procedure used for the 290 -- redefinition and if it is possible, creates a link that represents the 291 -- call to this procedure from the current scope. (The redefined attribute 292 -- can be used only within the current scope). 293 294 procedure Process_Reference_To_Subprogram 295 (Element : Asis.Element; 296 At_SLOC : String_Loc); 297 -- Assuming that El is a construct that can create a reference to a 298 -- subprogram that can be used for indirect subprogram call, tries to 299 -- define the refered subprogram and if it is indeed a subprogram, creates 300 -- a link that represents the call to this subprogram from its enclosing 301 -- scope. 302 -- 303 -- !!! Note, that there are also references to tasks and to entries, and we 304 -- do not process these cases at the moment! 305 306 procedure Process_Discr_Init_Proc (El : Asis.Element); 307 -- Provided that Has_Discr_Init_Proc (El) is True, creates the 308 -- representation of the discriminant initialization procedure for this 309 -- type. This includes storing the information about all the (direct) calls 310 -- issuing by this initialization procedure. 311 312 procedure Process_Type_Init_Proc (El : Asis.Element); 313 -- Provided that Has_Type_Init_Proc (El) is True, creates the 314 -- representation of the component initialization procedure for this type. 315 -- This includes storing the information about all the (direct) calls 316 -- issuing by this initialization procedure. 317 318 procedure Process_Scope (El : Asis.Element); 319 -- Stores in the call graph the information about the scope (that is - 320 -- about the body of a callable entity) and updates Current_Scope and 321 -- the scope stack. 322 323 procedure Store_Dispatching_Operations (El : Asis.Element); 324 -- Provided that El is a type definition that may have dispatching 325 -- operations, stores all the dispatching operations in the call graph. 326 327 procedure Store_Arc 328 (Called_Entity : Asis.Element; 329 At_SLOC : String_Loc; 330 Calling_Entity : Asis.Element := Nil_Element); 331 -- Supposing that Called_Entity is an Element that can be stored as a node 332 -- of the Call Graph (that is, Corresponding_Element has already been 333 -- applied to it), stores the call arc from Calling_Entity (or from the 334 -- current scope if Calling_Entity is Nil_Element) to the node 335 -- corresponding to this element using At_SLOC as the SLOC of the place 336 -- where the call takes place. Only one (the first) call from the scope to 337 -- the given Element is stored. 338 339 procedure Check_Call_Graph_Completeness; 340 -- Checks if the call information stored in the global data structure is 341 -- complete and allows to construct the full Call Graph. Generates a 342 -- diagnostic message each time when any incompleteness is detected. 343 344 procedure Set_Is_Renaming (N : GS_Node_Id; Val : Boolean := True); 345 -- Set the flag indicating if the callable entity is a renaming of another 346 -- callable entity (only renamings-as-bodies are represented in the call 347 -- graph), 348 349 function First_Direct_Call (N : GS_Node_Id) return GS_Node_Id; 350 -- Returns the first node from the direct call list of N. Returns 351 -- No_GS_Node if the list of direcr calls for N is empty 352 353 procedure Traverse_Construct_For_CG_Info is new Traverse_Element 354 (State_Information => String_Loc, 355 Pre_Operation => Add_CG_Info_Pre_Op, 356 Post_Operation => Complete_CG_Info_Post_Op); 357 -- Traverses the argument Element in ordrer to collect call graph 358 -- information. Usded as internal traversal routine for the implementation 359 360 procedure Unconditionally_Traverse_Construct_For_CG_Info is new 361 Traverse_Element (State_Information => String_Loc, 362 Pre_Operation => Unconditionally_Add_CG_Info_Pre_Op, 363 Post_Operation => Complete_CG_Info_Post_Op); 364 -- Traverses the argument Element in ordrer to collect call graph 365 -- information. Usded as internal traversal routine for the implementation 366 -- of Collect_CG_Info_From_Construct. 367 -- of Collect_CG_Info_From_Construct. 368 369 --------------------------------------------------- 370 -- Dispatching calls and dispatching operations -- 371 --------------------------------------------------- 372 373 procedure Add_Possible_Calls 374 (Calling_Node : GS_Node_Id; 375 Disp_Operation : GS_Node_Id); 376 -- This procedure assumes that Calling_Node issues a dispatching call and 377 -- this call is dispatched to Disp_Operation. It adds all the subprograms 378 -- that can be called as the result of dispatching call to Disp_Operation 379 -- to the list of direct calls of Calling_Node (using placeholder SLOC 380 -- (0, 0)) 381 382 ------------------------------------------------------------ 383 -- Data structures used for call graph transitive closure -- 384 ------------------------------------------------------------ 385 386 -- The following variables are used by Close_Node procedure, we define them 387 -- as global to avoid elaboration expances for each call of Close_Node. 388 389 New_Set : Node_Lists.Set; 390 -- A set of nodes that are added to All_Call. For each of the nodes from 391 -- this set we should analyse its direct calls and then remove the node 392 -- fron this set. We stop the loop for the next node when this set is 393 -- empty, 394 395 Newer_Set : Node_Lists.Set; 396 -- Nodes that are added for All_Call at the last iteration of the 397 -- processing of New_Set for the given node. They should be added to 398 -- New_Set to process their direct calls. 399 400 Next_Direct_Call : Node_Lists.Cursor; 401 Next_Call : SLOC_Node_Lists.Cursor; 402 Next_All_Call : Node_Lists.Cursor; 403 Next_Ref : SLOC_Node_Lists.Cursor; 404 Link_Tmp : SLOC_Link; 405 406 Traverse_Renamings_Done_Flag : Boolean := False; 407 Transitive_Closure_Done_Flag : Boolean := False; 408 -- Flags that indicates that the corresponding operation has been done 409 410 -- !!!! Start of the junc patch code to be removed as soon as possible! 411 -- See I106-005 412 procedure Patch_For_Default_Parameter_Initialization 413 (Element : Asis.Element); 414 pragma Unreferenced (Patch_For_Default_Parameter_Initialization); 415 -- This is a temporary patch for the compiler problem described in 416 -- I106-005: if Element is a parameter specification from a subprogram 417 -- or an entry, then all the function called in the default initialization 418 -- expressions (if any) are unconditionally marked as used. 419 420 procedure Mark_Called_Function_Used 421 (Element : Asis.Element; 422 Control : in out Traverse_Control; 423 State : in out No_State); 424 -- If Element is a function call, tries to define the called function and 425 -- mark it as used. 426 427 procedure Mark_All_Called_Functions_Used is new Traverse_Element 428 (Pre_Operation => Mark_Called_Function_Used, 429 Post_Operation => No_Op, 430 State_Information => No_State); 431 -- !!!! End of the junc patch code to be removed as soon as possible! 432 433 ----------------- 434 -- Add_CG_Info -- 435 ----------------- 436 437 procedure Add_CG_Info 438 (Element : Asis.Element; 439 At_SLOC : String_Loc := Nil_String_Loc) 440 is 441 begin 442 443 if Can_Have_Elaboration_Calls (Element) then 444 -- Is_Call and Can_Create_Tasks Elements can have elaboration calls, 445 -- so we have to process elaboration calls in a separate IF 446 -- statement. 447 Process_Elaboration_Calls (Element); 448 end if; 449 450 if Is_Scope (Element) then 451 Process_Scope (Element); 452 elsif Is_Declaration_Of_Callable_Entity (Element) then 453 Process_Callable_Entity (Element); 454 455 elsif Asis.Extensions.Is_Renaming_As_Body (Element) then 456 Process_Renaming_As_Body (Element); 457 -- At the moment, we just unwind renamings to the called subprogram 458 459 elsif Is_Call (Element) then 460 Process_Call (Element, At_SLOC => At_SLOC); 461 elsif Can_Create_Tasks (Element) then 462 Process_Task_Creation (Element); 463 elsif Is_Stream_Attribute_Redefinition (Element) then 464 Process_Stream_Attribute_Redefinition (Element, At_SLOC); 465 elsif Can_Create_Reference_To_Subprogram (Element) then 466 Process_Reference_To_Subprogram (Element, At_SLOC); 467 elsif Represent_Dispatching_Calls 468 and then 469 Can_Have_Dispatching_Operations (Element) 470 then 471 Store_Dispatching_Operations (Element); 472 end if; 473 474 if Has_Type_Init_Proc (Element) then 475 Process_Type_Init_Proc (Element); 476 end if; 477 478 if Has_Discr_Init_Proc (Element) then 479 Process_Discr_Init_Proc (Element); 480 end if; 481 end Add_CG_Info; 482 483 ------------------------ 484 -- Add_CG_Info_Pre_Op -- 485 ------------------------ 486 487 Definition : Asis.Element; 488 Is_Global_Reference : Boolean; 489 Can_Be_Accessed_By_Local_Task : Boolean; 490 Reference_Kind : Reference_Kinds; 491 -- We define these variables as global for Pre_Operation because of 492 -- performance reasons (to awoind their allocation for each identifier 493 -- element being visited during traversal) 494 495 procedure Add_CG_Info_Pre_Op 496 (Element : Asis.Element; 497 Control : in out Traverse_Control; 498 State : in out String_Loc) 499 is 500 Expanded_Code : Asis.Element; 501 502 procedure Treat_Element (Element : Asis.Element); 503 504 procedure Treat_Element (Element : Asis.Element) is 505 begin 506 if (Flat_Element_Kind (Element) = A_Defining_Identifier and then 507 (Flat_Element_Kind (Enclosing_Element (Element)) = 508 A_Variable_Declaration or else 509 Flat_Element_Kind (Enclosing_Element (Element)) = 510 A_Formal_Object_Declaration)) 511 -- Possible initialization in the declaration of a package-level 512 -- global variable, which counts as a write 513 or else 514 Flat_Element_Kind (Element) = An_Identifier 515 -- Possible read or write to a variable 516 then 517 518 Check_If_Global_Reference 519 (Element => Element, 520 Definition => Definition, 521 Is_Global_Reference => Is_Global_Reference, 522 Can_Be_Accessed_By_Local_Task => 523 Can_Be_Accessed_By_Local_Task, 524 Reference_Kind => Reference_Kind, 525 Compute_Reference_Kind => True); 526 527 if Is_Global_Reference and then 528 Reference_Kind /= Not_A_Reference 529 then 530 Process_Global_Reference 531 (Element, 532 Definition, 533 Reference_Kind); 534 end if; 535 536 end if; 537 end Treat_Element; 538 begin 539 -- !!!! To be removed as soon as possible! See I106-005 540 -- Patch_For_Default_Parameter_Initialization (Element); 541 542 if not Compute_Global_Objects_Accessed and then 543 Is_Non_Executable_Construct (Element) 544 then 545 Control := Abandon_Children; 546 return; 547 end if; 548 549 Add_CG_Info (Element, State); 550 551 if Compute_Global_Objects_Accessed then 552 if Flat_Element_Kind (Element) = A_Parameter_Association then 553 Traverse_Construct_For_CG_Info 554 (Element => Actual_Parameter (Element), 555 Control => Control, 556 State => State); 557 -- Avoid traversing the formal parameter of an association 558 Control := Abandon_Children; 559 end if; 560 561 Treat_Element (Element); 562 end if; 563 564 if Declaration_Kind (Element) in 565 A_Package_Instantiation .. A_Function_Instantiation 566 then 567 Expanded_Code := Corresponding_Declaration (Element); 568 569 Traverse_Construct_For_CG_Info 570 (Element => Expanded_Code, 571 Control => Control, 572 State => State); 573 574 Expanded_Code := Corresponding_Body (Element); 575 576 if not Is_Nil (Expanded_Code) then 577 Traverse_Construct_For_CG_Info 578 (Element => Expanded_Code, 579 Control => Control, 580 State => State); 581 end if; 582 583 end if; 584 585 exception 586 when Ex : others => 587 ASIS_UL.Common.Tool_Failures := ASIS_UL.Common.Tool_Failures + 1; 588 589 ASIS_UL.Output.Error ("call graph info collection failed"); 590 ASIS_UL.Output.Error (Build_GNAT_Location (Element)); 591 ASIS_UL.Output.Report_Unhandled_Exception (Ex); 592 593 end Add_CG_Info_Pre_Op; 594 595 ------------------------ 596 -- Add_Possible_Calls -- 597 ------------------------ 598 599 procedure Add_Possible_Calls 600 (Calling_Node : GS_Node_Id; 601 Disp_Operation : GS_Node_Id) 602 is 603 Next_Impl_Subpr : Node_Lists.Cursor; 604 Next_Impl_Node : GS_Node_Id; 605 begin 606 Next_Impl_Subpr := Node_Lists.First (Table (Disp_Operation).Node_List_3); 607 608 while Node_Lists.Has_Element (Next_Impl_Subpr) loop 609 Next_Impl_Node := Node_Lists.Element (Next_Impl_Subpr); 610 611 Add_Link_To_SLOC_List 612 (To_Node => Calling_Node, 613 Link_To_Add => (Next_Impl_Node, Nil_String_Loc)); 614 615 Next_Impl_Subpr := Node_Lists.Next (Next_Impl_Subpr); 616 end loop; 617 618 end Add_Possible_Calls; 619 620 ------------------- 621 -- Body_Analyzed -- 622 ------------------- 623 624 function Body_Analyzed (N : GS_Node_Id) return Boolean is 625 begin 626 pragma Assert (GS_Node_Kind (N) in Callable_Nodes); 627 return Table (N).Bool_Flag_1; 628 end Body_Analyzed; 629 630 ----------------------------------- 631 -- Check_Call_Graph_Completeness -- 632 ----------------------------------- 633 634 procedure Check_Call_Graph_Completeness is 635 begin 636 637 for Node in First_GS_Node .. Last_Node loop 638 639 if Is_Callable_Node (Node) 640 and then 641 not Is_Of_No_Interest (Node) 642 and then 643 not Body_Analyzed (Node) 644 then 645 ASIS_UL.Output.Warning 646 ("body is not analyzed for " & 647 Get_String (GS_Node_SLOC (Node))); 648 end if; 649 650 end loop; 651 652 end Check_Call_Graph_Completeness; 653 654 ------------------------- 655 -- Check_For_Main_Unit -- 656 ------------------------- 657 658 Main_Unit_Already_Processed : Boolean := False; 659 -- As soon as the source file with the name coresponding to 660 -- ASIS_UL.Options.Main_Subprogram_Name is processed, we do not need to 661 -- check anything in Check_For_Main_Unit any more 662 663 procedure Check_For_Main_Unit 664 (SF : SF_Id; 665 CU : Asis.Compilation_Unit; 666 Unit : Asis.Element) 667 is 668 Main_Unit_Node : GS_Node_Id; 669 begin 670 671 if not Main_Unit_Already_Processed 672 and then 673 ASIS_UL.Options.Main_Subprogram_Name /= null 674 and then 675 Base_Name (ASIS_UL.Options.Main_Subprogram_Name.all) = 676 Base_Name (Source_Name (SF)) 677 then 678 679 Main_Unit_Already_Processed := True; 680 681 if not Can_Be_Main_Program (CU) then 682 ASIS_UL.Output.Error 683 ("file specified as main unit cannot be main subprogram"); 684 ASIS_UL.Common.Tool_Failures := ASIS_UL.Common.Tool_Failures + 1; 685 686 return; 687 end if; 688 689 Main_Unit_Node := Corresponding_Node (Unit); 690 pragma Assert (Present (Main_Unit_Node)); 691 692 Add_Link_To_SLOC_List 693 (To_Node => Environment_Task_Node, 694 Link_To_Add => (Main_Unit_Node, Build_GNAT_Location (Unit))); 695 696 end if; 697 698 end Check_For_Main_Unit; 699 700 ---------------- 701 -- Close_Node -- 702 ---------------- 703 704 procedure Close_Node (Node : GS_Node_Id) is 705 begin 706 707 -- SLOC_Node_List_1 <--> Direct calls 708 -- Node_List_1 <--> All calls 709 710 Node_Lists.Clear (New_Set); 711 Node_Lists.Clear (Newer_Set); 712 713 Add_SLOC_Node_List_To_Node_List 714 (Table (Node).Node_List_1, 715 Table (Node).SLOC_Node_List_1); 716 717 Add_SLOC_Node_List_To_Node_List 718 (New_Set, 719 Table (Node).SLOC_Node_List_1); 720 721 while not Node_Lists.Is_Empty (New_Set) loop 722 Next_Direct_Call := Node_Lists.First (New_Set); 723 724 Next_Call := 725 SLOC_Node_Lists.First 726 (Table (Node_Lists.Element (Next_Direct_Call)). 727 SLOC_Node_List_1); 728 729 while SLOC_Node_Lists.Has_Element (Next_Call) loop 730 731 if not Node_Lists.Contains 732 (Table (Node).Node_List_1, 733 SLOC_Node_Lists.Element (Next_Call).Node) 734 then 735 Node_Lists.Insert 736 (Newer_Set, SLOC_Node_Lists.Element (Next_Call).Node); 737 end if; 738 739 Next_Call := SLOC_Node_Lists.Next (Next_Call); 740 end loop; 741 742 Node_Lists.Delete_First (New_Set); 743 744 if not Node_Lists.Is_Empty (Newer_Set) then 745 Node_Lists.Union (Table (Node).Node_List_1, 746 Newer_Set); 747 Node_Lists.Union (New_Set, Newer_Set); 748 Node_Lists.Clear (Newer_Set); 749 end if; 750 751 end loop; 752 753 -- SLOC_Node_List_2 <--> Direct reads 754 -- SLOC_Node_List_3 <--> Direct writes 755 -- Node_List_1 <--> All calls 756 757 if Compute_Global_Objects_Accessed then 758 759 for Node in First_GS_Node .. Last_Node loop 760 761 -- Output_Node (Node); 762 763 -- Traverse the set of all calls: 764 765 Next_All_Call := 766 Node_Lists.First (Table (Node).Node_List_1); 767 768 while Node_Lists.Has_Element (Next_All_Call) loop 769 770 if not Is_Of_No_Interest 771 (Node_Lists.Element (Next_All_Call)) 772 then 773 774 -- Read references 775 Next_Ref := 776 SLOC_Node_Lists.First 777 (Table (Node_Lists.Element (Next_All_Call)). 778 SLOC_Node_List_2); 779 780 while SLOC_Node_Lists.Has_Element (Next_Ref) loop 781 782 if not SLOC_Node_Lists.Contains 783 (Table (Node).SLOC_Node_List_2, 784 SLOC_Node_Lists.Element (Next_Ref)) 785 and then 786 Is_Global_For 787 (Node => SLOC_Node_Lists.Element (Next_Ref).Node, 788 Scope => Node) 789-- or else 790-- GS_Is_Local_Var_Accessed_By_Local_Tasks 791-- (SLOC_Node_Lists.Element (Next_Ref).Node)) 792 then 793 Link_Tmp := SLOC_Node_Lists.Element (Next_Ref); 794 795 Add_Link_To_SLOC_List 796 (To_Node => Node, 797 To_List => Indirect_Read_References, 798 Link_To_Add => Link_Tmp); 799 800 Add_Link_To_SLOC_List 801 (To_Node => Link_Tmp.Node, 802 To_List => Indirect_Read_References, 803 Link_To_Add => (Node => Node, 804 SLOC => Nil_String_Loc)); 805 end if; 806 807 Next_Ref := SLOC_Node_Lists.Next (Next_Ref); 808 end loop; 809 810 -- Write references 811 Next_Ref := 812 SLOC_Node_Lists.First 813 (Table (Node_Lists.Element (Next_All_Call)). 814 SLOC_Node_List_3); 815 816 while SLOC_Node_Lists.Has_Element (Next_Ref) loop 817 818 if not SLOC_Node_Lists.Contains 819 (Table (Node).SLOC_Node_List_3, 820 SLOC_Node_Lists.Element (Next_Ref)) 821 and then 822 Is_Global_For 823 (Node => SLOC_Node_Lists.Element (Next_Ref).Node, 824 Scope => Node) 825-- or else 826-- GS_Is_Local_Var_Accessed_By_Local_Tasks 827-- (SLOC_Node_Lists.Element (Next_Ref).Node)) 828 then 829 Link_Tmp := SLOC_Node_Lists.Element (Next_Ref); 830 831 Add_Link_To_SLOC_List 832 (To_Node => Node, 833 To_List => Indirect_Write_References, 834 Link_To_Add => Link_Tmp); 835 836 Add_Link_To_SLOC_List 837 (To_Node => Link_Tmp.Node, 838 To_List => Indirect_Write_References, 839 Link_To_Add => (Node => Node, 840 SLOC => Nil_String_Loc)); 841 end if; 842 843 Next_Ref := SLOC_Node_Lists.Next (Next_Ref); 844 end loop; 845 846 end if; 847 848 Next_All_Call := Node_Lists.Next (Next_All_Call); 849 end loop; 850 851 end loop; 852 853 end if; 854 855 end Close_Node; 856 857 ------------------------------------ 858 -- Collect_CG_Info_From_Construct -- 859 ------------------------------------ 860 861 procedure Collect_CG_Info_From_Construct 862 (Element : Asis.Element; 863 At_SLOC : String_Loc := Nil_String_Loc) 864 is 865 State : String_Loc := At_SLOC; 866 Control : Traverse_Control := Continue; 867 begin 868 Traverse_Construct_For_CG_Info (Element, Control, State); 869 end Collect_CG_Info_From_Construct; 870 871 ---------------------- 872 -- Complete_CG_Info -- 873 ---------------------- 874 875 procedure Complete_CG_Info (El : Asis.Element) is 876 begin 877 878 if Is_Scope (El) 879 and then 880 Should_Be_In_CG (El) 881 then 882 Remove_Current_Scope; 883 end if; 884 885 end Complete_CG_Info; 886 887 ------------------------------ 888 -- Complete_CG_Info_Post_Op -- 889 ------------------------------ 890 891 procedure Complete_CG_Info_Post_Op 892 (Element : Asis.Element; 893 Control : in out Traverse_Control; 894 State : in out String_Loc) 895 is 896 pragma Unreferenced (Control, State); 897 begin 898 Complete_CG_Info (Element); 899 end Complete_CG_Info_Post_Op; 900 901 ------------------------------ 902 -- Expand_Dispatching_Calls -- 903 ------------------------------ 904 905 procedure Expand_Dispatching_Calls is 906 Next_Disp_Call : Node_Lists.Cursor; 907 Next_Call_Node : GS_Node_Id; 908 begin 909 910 for Node in First_GS_Node .. Last_Node loop 911 Next_Disp_Call := Node_Lists.First (Table (Node).Node_List_2); 912 913 while Node_Lists.Has_Element (Next_Disp_Call) loop 914 Next_Call_Node := Node_Lists.Element (Next_Disp_Call); 915 916 Add_Possible_Calls 917 (Calling_Node => Node, 918 Disp_Operation => Next_Call_Node); 919 920 Next_Disp_Call := Node_Lists.Next (Next_Disp_Call); 921 end loop; 922 923 end loop; 924 925 end Expand_Dispatching_Calls; 926 927 ----------------------- 928 -- First_Direct_Call -- 929 ----------------------- 930 931 function First_Direct_Call (N : GS_Node_Id) return GS_Node_Id is 932 Result : GS_Node_Id := No_GS_Node; 933 begin 934 935 pragma Assert (Is_Callable_Node (N)); 936 937 if not SLOC_Node_Lists.Is_Empty (Table (N).SLOC_Node_List_1) then 938 Result := 939 SLOC_Node_Lists.First_Element (Table (N).SLOC_Node_List_1).Node; 940 end if; 941 942 return Result; 943 end First_Direct_Call; 944 945 -------------------- 946 -- GS_Is_Renaming -- 947 -------------------- 948 949 function GS_Is_Renaming (N : GS_Node_Id) return Boolean is 950 begin 951 pragma Assert (GS_Node_Kind (N) in Callable_Nodes); 952 return Table (N).Bool_Flag_2; 953 end GS_Is_Renaming; 954 955 --------------------- 956 -- GS_Is_Task_Type -- 957 --------------------- 958 959 function GS_Is_Task_Type (N : GS_Node_Id) return Boolean is 960 begin 961 pragma Assert (GS_Node_Kind (N) in Callable_Nodes); 962 963 return GS_Node_Kind (N) = A_Task 964 and then 965 Table (N).Bool_Flag_3; 966 end GS_Is_Task_Type; 967 968 ----------------------------------- 969 -- Is_Called_By_Environment_Task -- 970 ----------------------------------- 971 972 function Is_Called_By_Environment_Task (N : GS_Node_Id) return Boolean is 973 Result : Boolean := False; 974 begin 975 if Present (N) then 976 Result := 977 Node_Lists.Contains 978 (Container => Table (Environment_Task_Node).Node_List_1, 979 Item => N); 980 end if; 981 982 return Result; 983 end Is_Called_By_Environment_Task; 984 985 --------------------------------- 986 -- Is_Library_Level_Subprogram -- 987 --------------------------------- 988 989 function Is_Library_Level_Subprogram (N : GS_Node_Id) return Boolean is 990 Result : Boolean := False; 991 begin 992 if Present (N) 993 and then 994 GS_Node_Kind (N) in Subprogram_Nodes 995 and then 996 GS_Node_Enclosing_Scope (N) = Environment_Task_Node 997 then 998 -- The only possibility that we have at the moment is to compare 999 -- the name of the subprogram 1000 Result := GS_Node_Name (N) = GS_Enclosed_CU_Name (N); 1001 end if; 1002 1003 return Result; 1004 end Is_Library_Level_Subprogram; 1005 1006 ----------------------- 1007 -- Is_Recursive_Node -- 1008 ----------------------- 1009 1010 function Is_Recursive_Node (N : GS_Node_Id) return Boolean is 1011 begin 1012 1013 return Node_Lists.Contains 1014 (Container => Table (N).Node_List_1, -- all calls 1015 Item => N); 1016 end Is_Recursive_Node; 1017 1018 ------------------------------- 1019 -- Mark_Called_Function_Used -- 1020 ------------------------------- 1021 1022 procedure Mark_Called_Function_Used 1023 (Element : Asis.Element; 1024 Control : in out Traverse_Control; 1025 State : in out No_State) 1026 is 1027 pragma Unreferenced (Control, State); 1028 Called_El : Asis.Element; 1029 Called_Node : GS_Node_Id; 1030 begin 1031 1032 if Expression_Kind (Element) = A_Function_Call then 1033 Called_El := Get_Called_Element (Element); 1034 1035 if Declaration_Kind (Called_El) = An_Enumeration_Literal_Specification 1036 or else 1037 Is_Predefined_Operation_Renaming (Called_El) 1038 then 1039 return; 1040 end if; 1041 1042 Called_El := Corresponding_Element (Called_El); 1043 1044 if Is_Nil (Called_El) 1045 or else 1046 Expression_Kind (Called_El) = An_Attribute_Reference 1047 or else 1048 Expression_Kind (Called_El) = An_Enumeration_Literal 1049 then 1050 return; 1051 end if; 1052 1053 Called_Node := Corresponding_Node (Called_El); 1054 1055 if Present (Called_Node) then 1056 Set_Application_Flag_1 (Called_Node, True); 1057 end if; 1058 1059 end if; 1060 1061 end Mark_Called_Function_Used; 1062 1063 ------------------------------------------------ 1064 -- Patch_For_Default_Parameter_Initialization -- 1065 ------------------------------------------------ 1066 1067 procedure Patch_For_Default_Parameter_Initialization 1068 (Element : Asis.Element) 1069 is 1070 Tmp : Asis.Element; 1071 Control : Traverse_Control := Continue; 1072 State : No_State := Not_Used; 1073 begin 1074 1075 if Declaration_Kind (Element) = A_Parameter_Specification then 1076 Tmp := Enclosing_Element (Element); 1077 1078 if Is_Declaration_Of_Callable_Entity (Tmp) or else 1079 Declaration_Kind (Tmp) in 1080 An_Entry_Declaration .. An_Entry_Body_Declaration 1081 then 1082 Tmp := Initialization_Expression (Element); 1083 1084 if not Is_Nil (Tmp) then 1085 Mark_All_Called_Functions_Used (Tmp, Control, State); 1086 end if; 1087 1088 end if; 1089 end if; 1090 1091 end Patch_For_Default_Parameter_Initialization; 1092 1093 ------------------ 1094 -- Process_Call -- 1095 ------------------ 1096 1097 procedure Process_Call 1098 (Element : Asis.Element; 1099 At_SLOC : String_Loc := Nil_String_Loc) 1100 is 1101 Called_El : Asis.Element := Get_Called_Element (Element); 1102 Called_Node : GS_Node_Id; 1103 1104 Tmp_Cursor : Node_Lists.Cursor; 1105 Tmp_Success : Boolean; 1106 begin 1107 1108 if Is_Nil (Called_El) then 1109 1110 if Is_Call_To_Predefined_Operation (Element) 1111 or else 1112 Is_Call_To_Attribute_Subprogram (Element) 1113 or else 1114 Is_Call_To_Default_Null_Procedure (Element) 1115 then 1116 -- We do not consider such calls at all 1117 return; 1118 elsif Generate_Global_Structure_Warnings then 1119 ASIS_UL.Output.Error (Build_GNAT_Location (Element) & 1120 ": call can not be resolved statically"); 1121 end if; 1122 1123 elsif Declaration_Kind (Called_El) = 1124 An_Enumeration_Literal_Specification 1125 then 1126 -- This may happen in instantiation if an enumeration literal is 1127 -- used as an actual for a formal function. 1128 return; 1129 else 1130 1131 if Is_Predefined_Operation_Renaming (Called_El) then 1132 -- We do not consider such calls at all 1133 return; 1134 end if; 1135 1136 if Is_Renaming_Of_Null_Proc_Default (Called_El) then 1137 -- May take place in nested generic when formal subprogram with 1138 -- null default is used to instantiate another generic inside the 1139 -- template code. 1140 return; 1141 end if; 1142 1143 Called_El := Corresponding_Element (Called_El); 1144 1145 if Is_Nil (Called_El) then 1146 -- Subprogram renaming cannot be resolved statically. We do not 1147 -- generate any diagnstic here, because the cubprogram to be 1148 -- called here shall be marked as used anyway (if we have a 1149 -- explicit dereference here, then the renamed subprogram is 1150 -- marked as used when 'Access attribute is applied to it 1151 return; 1152 elsif Expression_Kind (Called_El) = An_Attribute_Reference 1153 or else 1154 Expression_Kind (Called_El) = An_Enumeration_Literal 1155 then 1156 -- These calls are of no interest 1157 return; 1158 end if; 1159 1160 if not Should_Be_In_CG (Called_El) then 1161 return; 1162 end if; 1163 1164 pragma Assert 1165 (Is_Declaration_Of_Callable_Entity (Called_El) 1166 or else 1167 Is_Scope (Called_El)); 1168 1169 if ASIS_UL.Options.Represent_Dispatching_Calls 1170 and then 1171 Is_Dispatching_Call (Element) 1172 then 1173 Called_Node := Corresponding_Node (Called_El); 1174 1175 Node_Lists.Insert 1176 (Container => Table (Current_Scope).Node_List_2, 1177 New_Item => Called_Node, 1178 Position => Tmp_Cursor, 1179 Inserted => Tmp_Success); 1180 end if; 1181 1182 if Is_Part_Of_Inherited (Called_El) then 1183 Called_El := Corresponding_Declaration (Called_El); 1184 end if; 1185 1186 if At_SLOC = Nil_String_Loc then 1187 Store_Arc 1188 (Called_Entity => Called_El, 1189 At_SLOC => Build_GNAT_Location (Element)); 1190 else 1191 Store_Arc 1192 (Called_Entity => Called_El, 1193 At_SLOC => At_SLOC); 1194 end if; 1195 1196 end if; 1197 1198 end Process_Call; 1199 1200 ----------------------------- 1201 -- Process_Callable_Entity -- 1202 ----------------------------- 1203 1204 procedure Process_Callable_Entity (El : Asis.Element) is 1205 Tmp : GS_Node_Id; 1206 begin 1207 Tmp := Corresponding_Node (El, Current_Scope); 1208 1209 if Present (Tmp) 1210 and then 1211 Declaration_Kind (El) = A_Single_Task_Declaration 1212 then 1213 Store_Arc (Called_Entity => El, At_SLOC => Build_GNAT_Location (El)); 1214 end if; 1215 1216 end Process_Callable_Entity; 1217 1218 ----------------------------- 1219 -- Process_Discr_Init_Proc -- 1220 ----------------------------- 1221 1222 procedure Process_Discr_Init_Proc (El : Asis.Element) is 1223 Proc_Node : constant GS_Node_Id := 1224 Corresponding_Node (El, Expected_Kind => A_Type_Discr_Init_Procedure); 1225 pragma Unreferenced (Proc_Node); 1226 begin 1227 null; 1228 end Process_Discr_Init_Proc; 1229 1230 ------------------------------- 1231 -- Process_Elaboration_Calls -- 1232 ------------------------------- 1233 1234 procedure Process_Elaboration_Calls (Element : Asis.Element) is 1235 Arg_Kind : constant Flat_Element_Kinds := Flat_Element_Kind (Element); 1236 Call_AT_SLOC : constant String_Loc := Build_GNAT_Location (Element); 1237 1238 Type_To_Analyze : Asis.Element := Nil_Element; 1239 -- To be set to point to the (full) type declaration of the type 1240 -- for that we have to process default (sub)component initialization 1241 -- expressions 1242 1243 Tmp_El : Asis.Element; 1244 1245 Process_Discriminants : Boolean := False; 1246 -- In case if the discriminant constraint is present, we do not have to 1247 -- process default expressions for discriminants 1248 1249 begin 1250 1251 case Arg_Kind is 1252 when A_Variable_Declaration | 1253 An_Allocation_From_Subtype => 1254 1255 if Arg_Kind = A_Variable_Declaration then 1256 Type_To_Analyze := Object_Declaration_View (Element); 1257 else 1258 Type_To_Analyze := Allocator_Subtype_Indication (Element); 1259 end if; 1260 1261 if Type_Kind (Type_To_Analyze) in 1262 An_Unconstrained_Array_Definition .. 1263 A_Constrained_Array_Definition 1264 then 1265 Type_To_Analyze := Array_Component_Definition (Type_To_Analyze); 1266 Type_To_Analyze := 1267 Component_Definition_View (Type_To_Analyze); 1268 end if; 1269 1270 case Flat_Element_Kind (Type_To_Analyze) is 1271 when A_Subtype_Indication => 1272 Tmp_El := Asis.Definitions.Subtype_Mark (Type_To_Analyze); 1273 when An_Anonymous_Access_To_Procedure | 1274 An_Anonymous_Access_To_Protected_Procedure | 1275 An_Anonymous_Access_To_Function | 1276 An_Anonymous_Access_To_Protected_Function => 1277 return; 1278 when others => 1279 Tmp_El := 1280 Anonymous_Access_To_Object_Subtype_Mark (Type_To_Analyze); 1281 end case; 1282 1283 if Expression_Kind (Tmp_El) /= An_Attribute_Reference then 1284 -- In case of a attribute reference as a subtype mark the 1285 -- only possible case is 'Base, so we have a scalar type 1286 -- here, therefore it can be no default initialization 1287 1288 Process_Discriminants := 1289 Definition_Kind (Type_To_Analyze) = A_Subtype_Indication 1290 and then 1291 Is_Nil (Subtype_Constraint (Type_To_Analyze)) 1292 and then 1293 Is_Indefinite_Subtype (Tmp_El); 1294 else 1295 Process_Discriminants := False; 1296 end if; 1297 1298 Type_To_Analyze := Get_Subtype_Structure (Type_To_Analyze); 1299 1300 -- First, check discriminants: 1301 1302 if Process_Discriminants then 1303 1304 Add_Link_To_SLOC_List 1305 (To_Node => Current_Scope, 1306 To_List => Calls, 1307 Link_To_Add => 1308 (Node => Corresponding_Node 1309 (El => Type_To_Analyze, 1310 Expected_Kind => A_Type_Discr_Init_Procedure), 1311 SLOC => Build_GNAT_Location (Element))); 1312 1313 end if; 1314 1315 -- Now, check if we have record components with defaul 1316 -- initialization expressions 1317 1318 if Has_Type_Init_Proc (Type_To_Analyze) then 1319 Add_Link_To_SLOC_List 1320 (To_Node => Current_Scope, 1321 To_List => Calls, 1322 Link_To_Add => 1323 (Node => Corresponding_Node 1324 (El => Type_To_Analyze, 1325 Expected_Kind => A_Type_Init_Procedure), 1326 SLOC => Build_GNAT_Location (Element))); 1327 1328 end if; 1329 1330 when An_Entry_Call_Statement | 1331 A_Procedure_Call_Statement | 1332 A_Function_Call => 1333 1334 declare 1335 Call_Parameters : constant Asis.Element_List := 1336 Get_Call_Parameters (Element, Normalized => True); 1337 -- Note that if Elemnent is a dispatching or dynamic call, 1338 -- Call_Parameters are Nil_Element_List! 1339 begin 1340 1341 for J in Call_Parameters'Range loop 1342 1343 if Is_Defaulted_Association (Call_Parameters (J)) then 1344 Tmp_El := Actual_Parameter (Call_Parameters (J)); 1345 1346 Unconditionally_Collect_CG_Info_From_Construct 1347 (Element => Tmp_El, 1348 At_SLOC => Call_AT_SLOC); 1349 end if; 1350 1351 end loop; 1352 1353 end; 1354 1355 when A_Procedure_Instantiation | 1356 A_Function_Instantiation => 1357 1358 declare 1359 Inst_Parameters : constant Asis.Element_List := 1360 Generic_Actual_Part (Element, Normalized => True); 1361 begin 1362 1363 for J in Inst_Parameters'Range loop 1364 1365 if Is_Defaulted_Association (Inst_Parameters (J)) 1366 and then 1367 Declaration_Kind (Enclosing_Element 1368 (Formal_Parameter (Inst_Parameters (J)))) = 1369 A_Formal_Object_Declaration 1370 then 1371 -- Note the condition expression: we check that we have 1372 -- an association corresponding to formal object by 1373 -- querying the kind of Enclosing_Element of a formal, 1374 -- but not actual parameter of the association, because 1375 -- the ASIS Standard does not define exactly the effect 1376 -- of Enclosing_Element for an actual parameter from a 1377 -- normalized association 1378 1379 Tmp_El := Actual_Parameter (Inst_Parameters (J)); 1380 1381 Unconditionally_Collect_CG_Info_From_Construct 1382 (Element => Tmp_El, 1383 At_SLOC => Call_AT_SLOC); 1384 end if; 1385 1386 end loop; 1387 1388 end; 1389 1390 when others => 1391 null; 1392 -- Not implemented yet 1393 end case; 1394 1395 end Process_Elaboration_Calls; 1396 1397 --------------------------------------------------- 1398 -- Process_Init_Expressions_In_Record_Components -- 1399 --------------------------------------------------- 1400 1401 procedure Process_Init_Expressions_In_Record_Components 1402 (Component_List : Asis.Element_List; 1403 Call_At_SLOC : String_Loc) 1404 is 1405 Comp_Def : Asis.Element; 1406 begin 1407 1408 for J in Component_List'Range loop 1409 1410 case Flat_Element_Kind (Component_List (J)) is 1411 when Flat_Clause_Kinds | 1412 A_Null_Component => 1413 null; 1414 when A_Variant_Part => 1415 1416 Process_Init_Expressions_In_Record_Components 1417 (Component_List => 1418 Asis.Definitions.Variants (Component_List (J)), 1419 Call_At_SLOC => Call_At_SLOC); 1420 1421 when A_Variant => 1422 1423 Process_Init_Expressions_In_Record_Components 1424 (Component_List => 1425 Asis.Definitions.Record_Components (Component_List (J)), 1426 Call_At_SLOC => Call_At_SLOC); 1427 1428 when A_Component_Declaration => 1429 1430 Comp_Def := Initialization_Expression (Component_List (J)); 1431 1432 if Is_Nil (Comp_Def) then 1433 -- No initialization here, but we have to go down the 1434 -- component structure: 1435 1436 Comp_Def := Object_Declaration_View (Component_List (J)); 1437 Comp_Def := Component_Definition_View (Comp_Def); 1438 1439 if Definition_Kind (Comp_Def) = An_Access_Definition then 1440 return; 1441 end if; 1442 1443 Comp_Def := Get_Subtype_Structure (Comp_Def); 1444 1445 Process_Type_Default_Expressions 1446 (Type_To_Analyze => Comp_Def, 1447 Call_At_SLOC => Call_At_SLOC); 1448 else 1449 Collect_CG_Info_From_Construct 1450 (Element => Comp_Def, 1451 At_SLOC => Call_At_SLOC); 1452 end if; 1453 1454 when others => 1455 -- Just in case... 1456 pragma Assert (False); 1457 null; 1458 end case; 1459 end loop; 1460 1461 end Process_Init_Expressions_In_Record_Components; 1462 1463 ---------------------------- 1464 -- Process_Type_Init_Proc -- 1465 ---------------------------- 1466 1467 procedure Process_Type_Init_Proc (El : Asis.Element) is 1468 Proc_Node : constant GS_Node_Id := 1469 Corresponding_Node (El, Expected_Kind => A_Type_Init_Procedure); 1470 pragma Unreferenced (Proc_Node); 1471 begin 1472 null; 1473 end Process_Type_Init_Proc; 1474 1475 ------------------------------------ 1476 -- Process_Record_Task_Components -- 1477 ------------------------------------ 1478 1479 procedure Process_Record_Task_Components 1480 (Component_List : Asis.Element_List; 1481 Call_At_SLOC : String_Loc) 1482 is 1483 Comp_Def : Asis.Element; 1484 begin 1485 1486 for J in Component_List'Range loop 1487 1488 case Flat_Element_Kind (Component_List (J)) is 1489 when Flat_Clause_Kinds | 1490 A_Null_Component => 1491 null; 1492 when A_Variant_Part => 1493 1494 Process_Record_Task_Components 1495 (Component_List => 1496 Asis.Definitions.Variants (Component_List (J)), 1497 Call_At_SLOC => Call_At_SLOC); 1498 1499 when A_Variant => 1500 1501 Process_Record_Task_Components 1502 (Component_List => 1503 Asis.Definitions.Record_Components (Component_List (J)), 1504 Call_At_SLOC => Call_At_SLOC); 1505 1506 when A_Component_Declaration => 1507 Comp_Def := Object_Declaration_View (Component_List (J)); 1508 Comp_Def := Component_Definition_View (Comp_Def); 1509 1510 if Definition_Kind (Comp_Def) = A_Subtype_Indication 1511 or else 1512 Access_Definition_Kind (Comp_Def) in 1513 An_Anonymous_Access_To_Variable .. 1514 An_Anonymous_Access_To_Constant 1515 then 1516 Comp_Def := Get_Subtype_Structure (Comp_Def); 1517 1518 Process_Task_Components 1519 (Type_Decl => Comp_Def, 1520 Call_At_SLOC => Call_At_SLOC); 1521 end if; 1522 when others => 1523 -- Just in case... 1524 pragma Assert (False); 1525 null; 1526 end case; 1527 end loop; 1528 1529 end Process_Record_Task_Components; 1530 1531 ------------------------------------- 1532 -- Process_Reference_To_Subprogram -- 1533 ------------------------------------- 1534 1535 procedure Process_Reference_To_Subprogram 1536 (Element : Asis.Element; 1537 At_SLOC : String_Loc) 1538 is 1539 Subpr : Asis.Element := Prefix (Element); 1540 Call_Sloc : String_Loc := At_SLOC; 1541 begin 1542 Subpr := Normalize_Reference (Subpr); 1543 1544 if Expression_Kind (Subpr) not in 1545 An_Identifier .. An_Operator_Symbol 1546 then 1547 -- No interest for call graph, so 1548 return; 1549 end if; 1550 1551 Subpr := Corresponding_Name_Declaration (Subpr); 1552 1553 case Declaration_Kind (Subpr) is 1554 when A_Procedure_Instantiation | 1555 A_Function_Instantiation | 1556 A_Procedure_Declaration | 1557 A_Function_Declaration | 1558 A_Procedure_Body_Declaration | 1559 A_Function_Body_Declaration => 1560 -- Continue processing... 1561 null; 1562 when A_Procedure_Body_Stub | 1563 A_Function_Body_Stub => 1564 1565 if Declaration_Kind (Corresponding_Declaration (Subpr)) in 1566 A_Generic_Declaration 1567 then 1568 -- No interest for a call graph 1569 return; 1570 end if; 1571 when others => 1572 -- Nothing interesting for a call graph 1573 return; 1574 end case; 1575 1576 if Should_Be_In_CG (Subpr) then 1577 1578 if Call_Sloc = Nil_String_Loc then 1579 Call_Sloc := Build_GNAT_Location (Element); 1580 end if; 1581 1582 Store_Arc 1583 (Called_Entity => Subpr, 1584 At_SLOC => At_SLOC, 1585 Calling_Entity => Enclosing_Scope (Subpr)); 1586 1587 end if; 1588 1589 end Process_Reference_To_Subprogram; 1590 1591 ------------------------------ 1592 -- Process_Renaming_As_Body -- 1593 ------------------------------ 1594 1595 procedure Process_Renaming_As_Body (El : Asis.Element) is 1596 Subprogram_Node : constant GS_Node_Id := 1597 Corresponding_Node (Corresponding_Declaration (El)); 1598 1599 Renamed_Subprogram : Asis.Element := Get_Renamed_Subprogram (El); 1600 1601 Renamed_Subprogram_Node : GS_Node_Id; 1602 1603 Is_Of_No_Interest : Boolean := True; 1604 begin 1605 if not (Should_Be_In_CG (El) 1606 and then 1607 Should_Be_In_CG (Renamed_Subprogram)) 1608 then 1609 return; 1610 end if; 1611 1612 Set_Is_Renaming (Subprogram_Node); 1613 1614 case Declaration_Kind (Renamed_Subprogram) is 1615 1616 when A_Procedure_Declaration | 1617 A_Function_Declaration | 1618 A_Procedure_Body_Declaration | 1619 A_Function_Body_Declaration | 1620 A_Procedure_Body_Stub | 1621 A_Function_Body_Stub | 1622 A_Procedure_Instantiation | 1623 A_Function_Instantiation => 1624 Is_Of_No_Interest := False; 1625 1626 when An_Entry_Declaration => 1627 -- Task entry is renamed as a subprogram - we cannot process 1628 -- this case yet: 1629 Set_Is_Of_No_Interest (Subprogram_Node); 1630 raise ASIS_UL.Common.Non_Implemented_Error; 1631 1632 when others => 1633 -- Is_Of_No_Interest remains ON. Here we have all the cases of 1634 -- attrubute subprogram renamings 1635 null; 1636 end case; 1637 1638 if Is_Of_No_Interest then 1639 Set_Is_Of_No_Interest (Subprogram_Node); 1640 else 1641 if Is_Part_Of_Inherited (Renamed_Subprogram) then 1642 Renamed_Subprogram := 1643 Corresponding_Declaration (Renamed_Subprogram); 1644 end if; 1645 1646 Renamed_Subprogram_Node := Corresponding_Node (Renamed_Subprogram); 1647 1648 -- Add the "call" from a renaming to the renamed subprogram 1649 Add_Link_To_SLOC_List 1650 (To_Node => Subprogram_Node, 1651 To_List => Calls, 1652 Link_To_Add => (Node => Renamed_Subprogram_Node, 1653 SLOC => Build_GNAT_Location (El))); 1654 end if; 1655 1656 end Process_Renaming_As_Body; 1657 1658 ------------------- 1659 -- Process_Scope -- 1660 ------------------- 1661 1662 procedure Process_Scope (El : Asis.Element) is 1663 Tmp : GS_Node_Id; 1664 Scope_El : Asis.Element; 1665 begin 1666 1667 Scope_El := Corresponding_Element (El); 1668 1669 if not Should_Be_In_CG (Scope_El) then 1670 -- Is it OK? What about the enclosing scope references? 1671 return; 1672 end if; 1673 1674 if Is_Subunit (El) then 1675 Tmp := Corresponding_Node (Scope_El); 1676 else 1677 Tmp := Corresponding_Node (Scope_El, Current_Scope); 1678 end if; 1679 1680 if Declaration_Kind (El) = A_Task_Body_Declaration 1681 and then 1682 Declaration_Kind (Corresponding_Declaration (Scope_El)) = 1683 A_Task_Type_Declaration 1684 then 1685 -- Task type differs from a single anonymously typed task object in 1686 -- respect of the scope node. For a task object, the front-end 1687 -- creates an inplicit task type using the defining identifier node 1688 -- from the task body as the defining identifier node for this type, 1689 -- so the defining identifier from the body works as a top of the 1690 -- scope for bodies corresponding to single task declarations. But 1691 -- for a body that corresponds to a task type we have to go to the 1692 -- task type declaration to get the scope node. 1693 1694 Scope_El := Corresponding_Declaration (Scope_El); 1695 end if; 1696 1697 Scope_El := First_Name (Scope_El); 1698 1699 Set_Current_Scope (Tmp, Node (Scope_El)); 1700 Set_Body_Analyzed (Tmp); 1701 1702 if Represent_Dispatching_Calls 1703 and then 1704 Is_Dispatching_Operation (Scope_El) 1705 and then 1706 Is_Overriding_Operation (Scope_El) 1707 then 1708 Set_Implementing_Node (Implemented_Operations (Scope_El), Tmp); 1709 end if; 1710 1711 -- If we have a body of a user-defined "=" operation that can be used 1712 -- as a part of the implementation of some other predefined "=" 1713 -- according to RM 2012 4.5.2 (14/3 .. 15/3) and 3.4 (17/2), then we 1714 -- mark it as used by creating the call link from environment task node 1715 -- to the corresponding function declaration. 1716 1717 if Can_Be_Embedded_In_Equiality (Enclosing_Element (Scope_El)) then 1718 Add_Link_To_SLOC_List 1719 (To_Node => Environment_Task_Node, 1720 Link_To_Add => (Tmp, Build_GNAT_Location (Scope_El))); 1721 end if; 1722 1723 end Process_Scope; 1724 1725 ------------------------------------------- 1726 -- Process_Stream_Attribute_Redefinition -- 1727 ------------------------------------------- 1728 1729 procedure Process_Stream_Attribute_Redefinition 1730 (Element : Asis.Element; 1731 At_SLOC : String_Loc) 1732 is 1733 Subpr : Asis.Element := Representation_Clause_Expression (Element); 1734 begin 1735 if Expression_Kind (Subpr) = An_Explicit_Dereference then 1736 return; 1737 else 1738 Subpr := Normalize_Reference (Subpr); 1739 end if; 1740 1741 Subpr := Corresponding_Name_Definition (Subpr); 1742 Subpr := Enclosing_Element (Subpr); 1743 1744 pragma Assert 1745 (Is_Declaration_Of_Callable_Entity (Subpr) 1746 or else 1747 Is_Scope (Subpr)); 1748 1749 if Should_Be_In_CG (Subpr) then 1750 1751 if At_SLOC = Nil_String_Loc then 1752 Store_Arc 1753 (Called_Entity => Subpr, 1754 At_SLOC => Build_GNAT_Location (Element)); 1755 else 1756 Store_Arc 1757 (Called_Entity => Subpr, 1758 At_SLOC => At_SLOC); 1759 end if; 1760 1761 end if; 1762 1763 end Process_Stream_Attribute_Redefinition; 1764 1765 ----------------------------- 1766 -- Process_Task_Components -- 1767 ----------------------------- 1768 1769 procedure Process_Task_Components 1770 (Type_Decl : Asis.Element; 1771 Call_At_SLOC : String_Loc; 1772 Recursive_Call : Boolean := False) 1773 is 1774 T_Def : Asis.Element; 1775 Tmp : Asis.Element; 1776 1777 Unused_Cursor : Element_Containers.Cursor; 1778 Inserted : Boolean; 1779 begin 1780 1781 if Recursive_Call then 1782 Element_Containers.Clear (Processed_Types); 1783 end if; 1784 1785 Element_Containers.Insert 1786 (Container => Processed_Types, 1787 New_Item => Type_Decl, 1788 Position => Unused_Cursor, 1789 Inserted => Inserted); 1790 1791 if not Inserted then 1792 -- To avoid recursion 1793 return; 1794 end if; 1795 1796 case Declaration_Kind (Type_Decl) is 1797 when A_Task_Type_Declaration => 1798 1799 if Should_Be_In_CG (Type_Decl) then 1800 Store_Arc 1801 (Called_Entity => Type_Decl, 1802 At_SLOC => Call_At_SLOC); 1803 end if; 1804 1805 when A_Protected_Type_Declaration | 1806 A_Formal_Type_Declaration => 1807 null; 1808 when An_Ordinary_Type_Declaration => 1809 T_Def := Type_Declaration_View (Type_Decl); 1810 1811 case Type_Kind (T_Def) is 1812 when A_Derived_Record_Extension_Definition => 1813 1814 Tmp := Asis.Definitions.Record_Definition (T_Def); 1815 1816 if Definition_Kind (Tmp) /= A_Null_Record_Definition then 1817 Process_Record_Task_Components 1818 (Component_List => Record_Components (Tmp), 1819 Call_At_SLOC => Call_At_SLOC); 1820 end if; 1821 1822 Tmp := Parent_Subtype_Indication (T_Def); 1823 Tmp := Get_Subtype_Structure (Tmp); 1824 Process_Task_Components (Tmp, Call_At_SLOC => Call_At_SLOC); 1825 1826 when An_Unconstrained_Array_Definition | 1827 A_Constrained_Array_Definition => 1828 1829 Tmp := Array_Component_Definition (T_Def); 1830 Tmp := Component_Definition_View (Tmp); 1831 1832 if Definition_Kind (Tmp) = A_Subtype_Indication then 1833 -- we are not interested in components that are defined 1834 -- by An_Access_Definition 1835 Tmp := Get_Subtype_Structure (Tmp); 1836 1837 Process_Task_Components 1838 (Tmp, 1839 Call_At_SLOC => Call_At_SLOC); 1840 end if; 1841 1842 when A_Record_Type_Definition | 1843 A_Tagged_Record_Type_Definition => 1844 1845 -- Note: we do not process discriminant components! 1846 1847 Tmp := Asis.Definitions.Record_Definition (T_Def); 1848 1849 if Definition_Kind (Tmp) /= A_Null_Record_Definition then 1850 Process_Record_Task_Components 1851 (Component_List => Record_Components (Tmp), 1852 Call_At_SLOC => Call_At_SLOC); 1853 end if; 1854 1855 when A_Derived_Type_Definition => 1856 -- Just in case... 1857 pragma Assert (False); 1858 null; 1859 1860 when others => 1861 null; 1862 end case; 1863 1864 when An_Incomplete_Type_Declaration | 1865 A_Tagged_Incomplete_Type_Declaration => 1866 Process_Task_Components 1867 (Type_Decl => Corresponding_Type_Declaration (Type_Decl), 1868 Call_At_SLOC => Call_At_SLOC); 1869 1870 when others => 1871 pragma Assert (False); 1872 null; 1873 end case; 1874 1875 end Process_Task_Components; 1876 1877 --------------------------- 1878 -- Process_Task_Creation -- 1879 --------------------------- 1880 1881 procedure Process_Task_Creation (El : Asis.Element) is 1882 Type_To_Analyze : Asis.Element; 1883 begin 1884 1885 case Flat_Element_Kind (El) is 1886 when A_Variable_Declaration | 1887 A_Constant_Declaration => 1888 Type_To_Analyze := Object_Declaration_View (El); 1889 1890 if Type_Kind (Type_To_Analyze) in 1891 An_Unconstrained_Array_Definition .. 1892 A_Constrained_Array_Definition 1893 then 1894 Type_To_Analyze := Array_Component_Definition (Type_To_Analyze); 1895 Type_To_Analyze := 1896 Component_Definition_View (Type_To_Analyze); 1897 end if; 1898 1899 when An_Allocation_From_Subtype => 1900 Type_To_Analyze := Allocator_Subtype_Indication (El); 1901 when others => 1902 pragma Assert (False); 1903 null; 1904 end case; 1905 1906 if Definition_Kind (Type_To_Analyze) = An_Access_Definition 1907 and then 1908 Access_Definition_Kind (Type_To_Analyze) not in 1909 An_Anonymous_Access_To_Variable .. An_Anonymous_Access_To_Constant 1910 then 1911 return; 1912 end if; 1913 1914 Type_To_Analyze := Get_Subtype_Structure (Type_To_Analyze); 1915 1916 Process_Task_Components 1917 (Type_To_Analyze, 1918 Call_At_SLOC => Build_GNAT_Location (El), 1919 Recursive_Call => True); 1920 end Process_Task_Creation; 1921 1922 -------------------------------------- 1923 -- Process_Type_Default_Expressions -- 1924 -------------------------------------- 1925 1926 procedure Process_Type_Default_Expressions 1927 (Type_To_Analyze : Asis.Element; 1928 Call_At_SLOC : String_Loc) 1929 is 1930 Type_Def : constant Asis.Element := 1931 Type_Declaration_View (Type_To_Analyze); 1932 1933 Tmp : Asis.Element; 1934 begin 1935 1936 -- Note: we do not process discriminant components! 1937 1938 case Definition_Kind (Type_Def) is 1939 when A_Protected_Definition => 1940 Process_Init_Expressions_In_Record_Components 1941 (Component_List => Private_Part_Items (Type_Def), 1942 Call_At_SLOC => Call_At_SLOC); 1943 1944 when A_Type_Definition => 1945 1946 case Type_Kind (Type_Def) is 1947 1948 when A_Derived_Record_Extension_Definition => 1949 1950 Tmp := Asis.Definitions.Record_Definition (Type_Def); 1951 1952 if Definition_Kind (Tmp) = A_Null_Record_Definition then 1953 Process_Init_Expressions_In_Record_Components 1954 (Component_List => Record_Components (Tmp), 1955 Call_At_SLOC => Call_At_SLOC); 1956 end if; 1957 1958 Tmp := Parent_Subtype_Indication (Type_Def); 1959 Tmp := Get_Subtype_Structure (Tmp); 1960 1961 Process_Type_Default_Expressions 1962 (Type_To_Analyze => Tmp, 1963 Call_At_SLOC => Call_At_SLOC); 1964 1965 when An_Unconstrained_Array_Definition | 1966 A_Constrained_Array_Definition => 1967 1968 Tmp := Array_Component_Definition (Type_Def); 1969 Tmp := Component_Definition_View (Tmp); 1970 1971 if Definition_Kind (Tmp) = A_Subtype_Indication then 1972 -- we are not interested in components that are defined 1973 -- by An_Access_Definition 1974 Tmp := Get_Subtype_Structure (Tmp); 1975 1976 Process_Type_Default_Expressions 1977 (Type_To_Analyze => Tmp, 1978 Call_At_SLOC => Call_At_SLOC); 1979 end if; 1980 1981 when A_Record_Type_Definition | 1982 A_Tagged_Record_Type_Definition => 1983 1984 Tmp := Asis.Definitions.Record_Definition (Type_Def); 1985 1986 if Definition_Kind (Tmp) /= A_Null_Record_Definition then 1987 Process_Init_Expressions_In_Record_Components 1988 (Component_List => Record_Components (Tmp), 1989 Call_At_SLOC => Call_At_SLOC); 1990 end if; 1991 1992 when others => 1993 -- No default initialization expression in this case! 1994 null; 1995 end case; 1996 1997 when others => 1998 -- No default initialization expression in this case! 1999 null; 2000 end case; 2001 2002 end Process_Type_Default_Expressions; 2003 2004 ----------------------- 2005 -- Set_Body_Analyzed -- 2006 ----------------------- 2007 2008 procedure Set_Body_Analyzed (N : GS_Node_Id; Val : Boolean := True) is 2009 begin 2010 pragma Assert (GS_Node_Kind (N) in Callable_Nodes); 2011 Set_Bool_Flag_1 (N, Val); 2012 end Set_Body_Analyzed; 2013 2014 --------------------------- 2015 -- Set_Implementing_Node -- 2016 --------------------------- 2017 2018 procedure Set_Implementing_Node 2019 (Implementred_Operations : Asis.Element_List; 2020 Implemeting_Node : GS_Node_Id) 2021 is 2022 Next_Implemented_Op : GS_Node_Id; 2023 begin 2024 2025 for Op in Implementred_Operations'Range loop 2026 Next_Implemented_Op := 2027 Corresponding_Node (Corresponding_Element 2028 (Implementred_Operations (Op))); 2029 2030 Node_Lists.Insert 2031 (Table (Next_Implemented_Op).Node_List_3, 2032 Implemeting_Node); 2033 end loop; 2034 2035 end Set_Implementing_Node; 2036 2037 --------------------- 2038 -- Set_Is_Renaming -- 2039 --------------------- 2040 2041 procedure Set_Is_Renaming (N : GS_Node_Id; Val : Boolean := True) is 2042 begin 2043 pragma Assert (GS_Node_Kind (N) in Callable_Nodes); 2044 Set_Bool_Flag_2 (N, Val); 2045 end Set_Is_Renaming; 2046 2047 ---------------------- 2048 -- Set_Is_Task_Type -- 2049 ---------------------- 2050 2051 procedure Set_Is_Task_Type (N : GS_Node_Id; Val : Boolean := True) is 2052 begin 2053 pragma Assert (GS_Node_Kind (N) = A_Task); 2054 Set_Bool_Flag_3 (N, Val); 2055 end Set_Is_Task_Type; 2056 2057 --------------- 2058 -- Store_Arc -- 2059 --------------- 2060 2061 procedure Store_Arc 2062 (Called_Entity : Asis.Element; 2063 At_SLOC : String_Loc; 2064 Calling_Entity : Asis.Element := Nil_Element) 2065 is 2066 Called_Node : constant GS_Node_Id := Corresponding_Node (Called_Entity); 2067 Calling_Node : GS_Node_Id := Current_Scope; 2068 begin 2069 2070 if not Is_Nil (Calling_Entity) then 2071 Calling_Node := Corresponding_Node 2072 (Corresponding_Element (Calling_Entity), Unconditionally => True); 2073 pragma Assert (Present (Calling_Node)); 2074 end if; 2075 2076 pragma Assert 2077 (First_GS_Node < Called_Node 2078 and then 2079 Called_Node <= Last_Node); 2080 2081 Add_Link_To_SLOC_List 2082 (To_Node => Calling_Node, 2083 To_List => Calls, 2084 Link_To_Add => (Node => Called_Node, SLOC => At_SLOC)); 2085 2086 end Store_Arc; 2087 2088 ---------------------------------- 2089 -- Store_Dispatching_Operations -- 2090 ---------------------------------- 2091 2092 procedure Store_Dispatching_Operations (El : Asis.Element) is 2093 Disp_Ops : constant Asis.Element_List := 2094 Dispatching_Operations (El); 2095 2096 Tmp_Node : GS_Node_Id; 2097 pragma Unreferenced (Tmp_Node); 2098 begin 2099 2100 for Op in Disp_Ops'Range loop 2101 if not Is_Predefined_Operation_Renaming (Disp_Ops (Op)) then 2102 Tmp_Node := Corresponding_Node (Disp_Ops (Op)); 2103 end if; 2104 end loop; 2105 2106 end Store_Dispatching_Operations; 2107 2108 ------------------------ 2109 -- Transitive_Closure -- 2110 ------------------------ 2111 2112 procedure Transitive_Closure is 2113 begin 2114 2115 if not Traverse_Renamings_Done then 2116 Traverse_Renamings; 2117 end if; 2118 2119 if Represent_Dispatching_Calls then 2120 Expand_Dispatching_Calls; 2121 end if; 2122 2123 Check_Call_Graph_Completeness; 2124 2125 for Node in First_GS_Node .. Last_Node loop 2126 2127 if Is_Callable_Node (Node) 2128 and then 2129 not Is_Of_No_Interest (Node) 2130 then 2131 Close_Node (Node); 2132 end if; 2133 2134 end loop; 2135 2136 Transitive_Closure_Done_Flag := True; 2137 2138 end Transitive_Closure; 2139 2140 ----------------------------- 2141 -- Transitive_Closure_Done -- 2142 ----------------------------- 2143 2144 function Transitive_Closure_Done return Boolean is 2145 begin 2146 return Transitive_Closure_Done_Flag; 2147 end Transitive_Closure_Done; 2148 2149 ------------------------ 2150 -- Traverse_Renamings -- 2151 ------------------------ 2152 2153 procedure Traverse_Renamings is 2154 Already_Processed_Renamings : Node_Lists.Set; 2155 2156 procedure Process_Renaming (Node : GS_Node_Id); 2157 -- Processes one renaming node and after that add node to 2158 -- Already_Processed_Renamings set. This procedure recursively traverses 2159 -- renaming chains (we suppose that these chains do not contain loops, 2160 -- any loop definitely means an elaboration problem!). 2161 2162 procedure Process_Renaming (Node : GS_Node_Id) is 2163 Renamed_Node : constant GS_Node_Id := First_Direct_Call (Node); 2164 begin 2165 2166 Node_Lists.Insert (Already_Processed_Renamings, Node); 2167 2168 if Is_Of_No_Interest (Renamed_Node) then 2169 Set_Is_Of_No_Interest (Node); 2170 return; 2171 end if; 2172 2173 if GS_Is_Renaming (Renamed_Node) 2174 and then 2175 not Node_Lists.Contains 2176 (Already_Processed_Renamings, Renamed_Node) 2177 then 2178 Process_Renaming (Renamed_Node); 2179 -- This may define that Renamed_Node is of no interest, so: 2180 2181 if Is_Of_No_Interest (Renamed_Node) then 2182 Set_Is_Of_No_Interest (Node); 2183 return; 2184 end if; 2185 2186 end if; 2187 2188 Set_Body_Analyzed (Node, Body_Analyzed (Renamed_Node)); 2189 2190 end Process_Renaming; 2191 2192 begin 2193 Node_Lists.Clear (Already_Processed_Renamings); 2194 2195 for Node in First_GS_Node .. Last_Node loop 2196 2197 if Is_Callable_Node (Node) 2198 and then 2199 GS_Is_Renaming (Node) 2200 and then 2201 not Is_Of_No_Interest (Node) 2202 and then 2203 not Node_Lists.Contains (Already_Processed_Renamings, Node) 2204 then 2205 Process_Renaming (Node); 2206 end if; 2207 2208 end loop; 2209 2210 Traverse_Renamings_Done_Flag := True; 2211 end Traverse_Renamings; 2212 2213 ----------------------------- 2214 -- Traverse_Renamings_Done -- 2215 ----------------------------- 2216 2217 function Traverse_Renamings_Done return Boolean is 2218 begin 2219 return Traverse_Renamings_Done_Flag; 2220 end Traverse_Renamings_Done; 2221 2222 ---------------------------------------- 2223 -- Unconditionally_Add_CG_Info_Pre_Op -- 2224 ---------------------------------------- 2225 2226 procedure Unconditionally_Add_CG_Info_Pre_Op 2227 (Element : Asis.Element; 2228 Control : in out Traverse_Control; 2229 State : in out String_Loc) 2230 is 2231 Expanded_Code : Asis.Element; 2232 2233 begin 2234 2235 Add_CG_Info (Element, State); 2236 2237 if Declaration_Kind (Element) in 2238 A_Package_Instantiation .. A_Function_Instantiation 2239 then 2240 Expanded_Code := Corresponding_Declaration (Element); 2241 2242 Traverse_Construct_For_CG_Info 2243 (Element => Expanded_Code, 2244 Control => Control, 2245 State => State); 2246 2247 Expanded_Code := Corresponding_Body (Element); 2248 2249 if not Is_Nil (Expanded_Code) then 2250 Traverse_Construct_For_CG_Info 2251 (Element => Expanded_Code, 2252 Control => Control, 2253 State => State); 2254 end if; 2255 2256 end if; 2257 2258 exception 2259 when Ex : others => 2260 ASIS_UL.Common.Tool_Failures := ASIS_UL.Common.Tool_Failures + 1; 2261 2262 ASIS_UL.Output.Error ("call graph info collection failed"); 2263 ASIS_UL.Output.Error (Build_GNAT_Location (Element)); 2264 ASIS_UL.Output.Report_Unhandled_Exception (Ex); 2265 2266 end Unconditionally_Add_CG_Info_Pre_Op; 2267 2268 ---------------------------------------------------- 2269 -- Unconditionally_Collect_CG_Info_From_Construct -- 2270 ---------------------------------------------------- 2271 2272 procedure Unconditionally_Collect_CG_Info_From_Construct 2273 (Element : Asis.Element; 2274 At_SLOC : String_Loc := Nil_String_Loc) 2275 is 2276 State : String_Loc := At_SLOC; 2277 Control : Traverse_Control := Continue; 2278 begin 2279 Unconditionally_Traverse_Construct_For_CG_Info (Element, Control, State); 2280 end Unconditionally_Collect_CG_Info_From_Construct; 2281 2282end ASIS_UL.Global_State.CG; 2283