1---------------------------------------------------------------------- 2-- Rules.Max_Call_Depth - Package body -- 3-- -- 4-- This software is (c) SAGEM DS and Adalog 2004-2006. The Ada -- 5-- Controller is free software; you can redistribute it and/or -- 6-- Controller is free software; you can redistribute it and/or -- 7-- modify it under terms of the GNU General Public License as -- 8-- published by the Free Software Foundation; either version 2, or -- 9-- (at your option) any later version. This unit is distributed -- 10-- in the hope that it will be useful, but WITHOUT ANY WARRANTY; -- 11-- without even the implied warranty of MERCHANTABILITY or FITNESS -- 12-- FOR A PARTICULAR PURPOSE. See the GNU General Public License -- 13-- for more details. You should have received a copy of the GNU -- 14-- General Public License distributed with this program; see file -- 15-- COPYING. If not, write to the Free Software Foundation, 59 -- 16-- Temple Place - Suite 330, Boston, MA 02111-1307, USA. -- 17-- -- 18-- As a special exception, if other files instantiate generics -- 19-- from the units of this program, or if you link this unit with -- 20-- other files to produce an executable, this unit does not by -- 21-- itself cause the resulting executable to be covered by the GNU -- 22-- General Public License. This exception does not however -- 23-- invalidate any other reasons why the executable file might be -- 24-- covered by the GNU Public License. -- 25-- -- 26-- This software is distributed in the hope that it will be -- 27-- useful, but WITHOUT ANY WARRANTY; without even the implied -- 28-- warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR -- 29-- PURPOSE. -- 30---------------------------------------------------------------------- 31 32-- Ada 33with 34 Ada.Strings.Wide_Unbounded; 35 36-- ASIS 37with 38 Asis.Declarations, 39 Asis.Elements, 40 Asis.Errors, 41 Asis.Exceptions, 42 Asis.Implementation, 43 Asis.Iterator; 44 45-- Adalog 46with 47 Binary_Map, 48 Thick_Queries, 49 Utilities; 50 51-- AdaControl 52with 53 Framework.Variables, 54 Framework.Variables.Shared_Types; 55 56package body Rules.Max_Call_Depth is 57 use Ada.Strings.Wide_Unbounded; 58 use Framework, Framework.Variables, Framework.Variables.Shared_Types; 59 60 -- Algorithm: 61 -- 62 -- The function Call_Depth computes the maximum depth of a *call*, i.e. it returns 63 -- at least 1. 64 -- Since the call depth is a property of the callable entity, the value is kept in the 65 -- Call_Depths map to avoid analyzing the same callable entity twice. 66 -- "Forced" entities provided as parameters are kept in a separate context store (Forced_Entities), and 67 -- entered into Call_Depths as they are encountered. 68 -- 69 -- The Call_Depths map is reset between runs only if there are forced entities; otherwise, it is a static 70 -- property, once you have it, it won't change. 71 -- 72 -- The "call depth" is defined as the number of frames pushed on the stack, therefore: 73 -- - A task entry call counts always for 1, irrespectively of what happens in the accept body, 74 -- since the accept is executed on a different stack. Of course, the same does /not/ apply 75 -- to protected entries. 76 -- - Similarly, calls during the elaboration of task bodies are not counted. 77 -- - Calls to non-statically determinable callable entities (access to SP, dispatching calls, 78 -- calls to imported SP) are deemed to have a depth of 1, short of a better solution. 79 -- - Operands of a call do not add extra depth, i.e. a call to P(F(X)) has a depth of 1 (operands 80 -- are evaluated by the caller before the call, so there is only one frame stacked at a time) 81 -- - Calls happening during the elaboration of nested packages must be counted, but not calls 82 -- that are part of any other nested program unit. 83 -- - Calls that are part of the elaboration of types, subtypes, and objects must be counted, 84 -- but not those that are part of the default expression of components and discriminants. 85 -- Strictly speaking, calls that appear as part of per-object constraints should not be counted 86 -- here, but at the place where an object is defined; we'll forget about this because it is 87 -- not worth the complication. 88 -- 89 -- We don't need to do anything special for generics, since we are starting from calls, they will 90 -- always refer to (parts of) instantiations. 91 92 Rule_Used : Boolean := False; 93 Save_Used : Boolean; 94 Ctl_Labels : array (Control_Kinds) of Unbounded_Wide_String; 95 96 -- Rule variables 97 Count_Expr_Fun_Calls : aliased Switch_Type.Object := (Value => On); 98 99 Infinite : constant Asis.ASIS_Natural := Asis.ASIS_Natural'Last; 100 Unused : constant Asis.ASIS_Integer := Asis.ASIS_Integer'Val(-1); 101 Depths : array (Control_Kinds) of Asis.ASIS_Integer := (others => Unused); 102 -- Depth that triggers the message, i.e. allowed depth + 1 103 104 type Called_Kind is (Regular, Inline, Recursive, Banned, Formal, Unavailable, Unknown, Dynamic); 105 subtype Unexplored is Called_Kind range Banned .. Unavailable; 106 -- Regular .. Imported are really properties of the called entity 107 -- Dynamic .. Unknown are properties of the call. 108 -- But it's not worth making two different types for this subtility 109 -- 110 -- A value in Unexplored is returned by Call_Depth if it is a direct call to a subprogram with the 111 -- corresponding property. 112 -- If the call is to something that indirectly calls an Unexplored SP, the returned kind is Unknown. 113 114 type Depth_Descriptor is 115 record 116 Kind : Called_Kind; 117 Depth : Asis.ASIS_Natural; 118 -- Infinite for Recursive 119 -- Actual depth for Regular 120 -- Minimum depth for unknown 121 end record; 122 package Depth_Map is new Binary_Map (Unbounded_Wide_String, Depth_Descriptor); 123 Call_Depths : Depth_Map.Map; 124 125 Forced_Entities : Control_Manager.Context_Store; 126 127 ---------- 128 -- Help -- 129 ---------- 130 131 procedure Help is 132 use Utilities; 133 begin 134 User_Message ("Rule: " & Rule_Id); 135 User_Message ("Control maximum call depth"); 136 User_Message; 137 User_Message ("Parameter (1): <Allowed depth> | finite"); 138 User_Message ("Parameter (2..): <Forced entity>"); 139 end Help; 140 141 ----------------- 142 -- Add_Control -- 143 ----------------- 144 145 procedure Add_Control (Ctl_Label : in Wide_String; Ctl_Kind : in Control_Kinds) is 146 use Framework.Language, Framework.Control_Manager; 147 use Depth_Map; 148 149 use type Asis.ASIS_Integer; -- Gela-ASIS compatibility 150 begin 151 if not Parameter_Exists then 152 Parameter_Error (Rule_Id, "at least one parameter required"); 153 end if; 154 155 if Depths (Ctl_Kind) /= Unused then 156 Parameter_Error (Rule_Id, "rule already specified"); 157 end if; 158 159 if Is_Integer_Parameter then 160 -- We limit max to Infinite-2 so that there can be no confusion with Infinite after adding 1. 161 -- Should be more than enough anyway... 162 Depths (Ctl_Kind) := Get_Integer_Parameter (Min => 0, Max => Infinite-2) + 1; 163 -- + 1 since we store the depth wich is an error 164 else 165 declare 166 Param : constant Wide_String := Get_Name_Parameter; 167 begin 168 if Param /= "FINITE" then 169 Parameter_Error (Rule_Id, "depth or ""finite"" expected for parameter"); 170 end if; 171 Depths (Ctl_Kind) := Infinite; 172 end; 173 end if; 174 175 if Parameter_Exists then 176 -- Forced entities provided: cannot keep previous Call_Depths 177 Clear (Call_Depths); 178 179 while Parameter_Exists loop 180 Associate (Forced_Entities, Get_Entity_Parameter, Null_Context); 181 end loop; 182 end if; 183 184 Ctl_Labels (Ctl_Kind) := To_Unbounded_Wide_String (Ctl_Label); 185 Rule_Used := True; 186 end Add_Control; 187 188 ------------- 189 -- Command -- 190 ------------- 191 192 procedure Command (Action : Framework.Rules_Manager.Rule_Action) is 193 use Framework.Rules_Manager, Framework.Control_Manager; 194 use Depth_Map; 195 begin 196 case Action is 197 when Clear => 198 Rule_Used := False; 199 Depths := (others => Unused); 200 if not Is_Empty (Forced_Entities) then 201 -- we had forced entities, need to clear Call_Depths 202 Clear (Call_Depths); 203 end if; 204 Clear (Forced_Entities); 205 when Suspend => 206 Save_Used := Rule_Used; 207 Rule_Used := False; 208 when Resume => 209 Rule_Used := Save_Used; 210 end case; 211 end Command; 212 213 ------------- 214 -- Prepare -- 215 ------------- 216 217 procedure Prepare is 218 use Framework.Control_Manager; 219 begin 220 Balance (Forced_Entities); 221 end Prepare; 222 223 224 ------------------------ 225 -- Report_Uncheckable -- 226 ------------------------ 227 228 procedure Report_Uncheckable (Call : Asis.Element; Message : Wide_String; Assumed : Asis.ASIS_Natural) is 229 use Asis.Elements; 230 use Framework.Reports, Thick_Queries, Utilities; 231 begin 232 if Is_Part_Of_Instance (Call) then 233 -- Unfortunately, Corresponding_Generic_Element does not work on call. 234 -- Let the message reference the instantiation instead 235 Uncheckable (Rule_Id, 236 False_Negative, 237 Get_Location (Ultimate_Enclosing_Instantiation (Call)), 238 Message & " in generic; assuming depth of " & ASIS_Integer_Img (Assumed)); 239 else 240 Uncheckable (Rule_Id, 241 False_Negative, 242 Get_Location (Call), 243 Message & "; assuming depth of " & ASIS_Integer_Img (Assumed)); 244 end if; 245 end Report_Uncheckable; 246 247 ---------------- 248 -- Call_Depth -- 249 ---------------- 250 251 function Entity_Call_Depth (Decl : Asis.Declaration) return Depth_Descriptor; 252 253 function Call_Depth (Call : Asis.Element) return Depth_Descriptor is 254 -- Computes the depth of a call, including itself 255 use Asis, Asis.Elements; 256 use Depth_Map, Framework.Control_Manager, Thick_Queries, Utilities; 257 258 Called : constant Asis.Expression := Ultimate_Name (Called_Simple_Name (Call)); 259 Called_Name : Unbounded_Wide_String; 260 Called_Descr : Call_Descriptor; 261 Called_Depth : Depth_Descriptor; 262 begin 263 if Is_Nil (Called) then 264 return (Dynamic, 1); 265 end if; 266 267 Called_Name := To_Unbounded_Wide_String (Full_Name_Image (Called, With_Profile => True)); 268 if Is_Present (Call_Depths, Called_Name) then 269 Called_Depth := Fetch (Call_Depths, Called_Name); 270 271 elsif Matching_Context (Forced_Entities, Called, Extend_To => All_Extensions) /= No_Matching_Context then 272 Called_Depth := (Regular, 0); 273 Add (Call_Depths, Called_Name, Called_Depth); -- will be found faster next time 274 275 else 276 Called_Descr := Corresponding_Call_Description (Call); 277 case Called_Descr.Kind is 278 when An_Attribute_Call => 279 -- Short of knowing, assume they are implemented with a regular call, with no further calls 280 Called_Depth := (Regular, 0); 281 282 when A_Predefined_Entity_Call => 283 -- Assume these are generated in-line 284 Called_Depth := (Inline, 0); 285 286 when A_Dereference_Call | A_Dispatching_Call => 287 -- Short of knowing, assume depth of 1 288 -- Return directly, since there is no name to add to Call_Depths in this case 289 return (Dynamic, 1); 290 291 when An_Enumeration_Literal => 292 -- Do not even count these as calls 293 Called_Depth := (Inline, 0); 294 295 when A_Regular_Call => 296 -- Normal case 297 Called_Depth := Entity_Call_Depth (Called_Descr.Declaration); 298 if Called_Depth.Kind = Regular 299 and then Declaration_Kind (Called_Descr.Declaration) = An_Expression_Function_Declaration 300 and then Count_Expr_Fun_Calls.Value = Off 301 then 302 Called_Depth.Kind := Inline; 303 end if; 304 end case; 305 306 -- This may seem redundant with the call to Add in Entity_Call_Depth, but it isn't if 307 -- the Called_Name is a renaming, since we register here the new name, and Entity_Call_Depth 308 -- does the same for the ultimate name. Granted, for regular calls it is added twice, but this 309 -- happens only once. 310 Add (Call_Depths, Called_Name, Called_Depth); 311 end if; 312 313 case Called_Depth.Kind is 314 when Inline | Recursive => 315 return Called_Depth; 316 when Dynamic => 317 Failure ("Dynamic kind returned by Entity_Call_Depth - 1"); 318 when Regular | Unexplored | Unknown => 319 -- All cases where something is actually called (although we may not know very well what) 320 return (Called_Depth.Kind, Called_Depth.Depth + 1); 321 end case; 322 end Call_Depth; 323 324 ----------------------- 325 -- Entity_Call_Depth -- 326 ----------------------- 327 328 procedure Pre_Procedure (Element : in Asis.Element; 329 Control : in out Asis.Traverse_Control; 330 Descr : in out Depth_Descriptor); 331 procedure Post_Procedure (Element : in Asis.Element; 332 Control : in out Asis.Traverse_Control; 333 Descr : in out Depth_Descriptor); 334 procedure Traverse is new Asis.Iterator.Traverse_Element (Depth_Descriptor, Pre_Procedure, Post_Procedure); 335 -- Computes the maximum depth of all calls encountered in the body. 336 337 procedure Pre_Procedure (Element : in Asis.Element; 338 Control : in out Asis.Traverse_Control; 339 Descr : in out Depth_Descriptor) 340 is 341 use Thick_Queries, Utilities; 342 use Asis, Asis.Declarations, Asis.Elements; 343 344 Temp : Asis.Element; 345 This_Descr : Depth_Descriptor; 346 begin 347 case Element_Kind (Element) is 348 when An_Expression => 349 case Expression_Kind (Element) is 350 when A_Function_Call => 351 This_Descr := Call_Depth (Element); 352 case This_Descr.Kind is 353 when Recursive => 354 Descr := This_Descr; 355 -- No need to investigate any further 356 Control := Terminate_Immediately; 357 when Regular | Inline => 358 -- If Descr.Kind = Unknown, it stays this way 359 Descr.Depth := Asis.ASIS_Natural'Max (Descr.Depth, This_Descr.Depth); 360 when Unexplored | Unknown | Dynamic => 361 -- All cases where the body is unknown are turned to Unknown at this point 362 Descr := (Unknown, Asis.ASIS_Natural'Max (Descr.Depth, This_Descr.Depth)); 363 end case; 364 when others => 365 null; 366 end case; 367 368 when A_Statement => 369 case Statement_Kind (Element) is 370 when A_Procedure_Call_Statement 371 | An_Entry_Call_Statement 372 => 373 This_Descr := Call_Depth (Element); 374 case This_Descr.Kind is 375 when Recursive => 376 Descr := This_Descr; 377 -- No need to investigate any further 378 Control := Terminate_Immediately; 379 when Regular | Inline => 380 -- If Descr.Kind = Unknown, it stays this way 381 Descr.Depth := Asis.ASIS_Natural'Max (Descr.Depth, This_Descr.Depth); 382 when Unexplored | Unknown | Dynamic => 383 -- All cases where the body is unknown are turned to Unknown at this point 384 Descr := (Unknown, Asis.ASIS_Natural'Max (Descr.Depth, This_Descr.Depth)); 385 end case; 386 when others => 387 null; 388 end case; 389 390 when A_Declaration => 391 case Declaration_Kind (Element) is 392 when Not_A_Declaration => 393 Failure ("not a declaration"); 394 when An_Ordinary_Type_Declaration 395 | A_Task_Type_Declaration 396 | A_Protected_Type_Declaration 397 | A_Private_Type_Declaration 398 | A_Private_Extension_Declaration 399 | A_Subtype_Declaration 400 => 401 -- Traverse the definition, but not the discriminant part 402 Temp := Type_Declaration_View (Element); 403 if not Is_Nil (Temp) 404 and then Access_Type_Kind (Temp) not in Access_To_Subprogram_Definition 405 then 406 -- Temp is nil for an empty task type declaration (task T;) 407 -- We're not supposed to traverse formal parameters that are part of access to SP 408 Traverse (Temp, Control, Descr); 409 end if; 410 Control := Abandon_Children; 411 when An_Incomplete_Type_Declaration 412 | A_Tagged_Incomplete_Type_Declaration 413 | A_Deferred_Constant_Declaration 414 | An_Integer_Number_Declaration 415 | A_Real_Number_Declaration 416 | An_Enumeration_Literal_Specification 417 | A_Discriminant_Specification 418 | A_Procedure_Declaration 419 | A_Null_Procedure_Declaration 420 | A_Function_Declaration 421 | An_Expression_Function_Declaration -- Ada 2012 422 | A_Procedure_Body_Declaration 423 | A_Function_Body_Declaration 424 | A_Task_Body_Declaration 425 | A_Protected_Body_Declaration 426 | An_Entry_Declaration 427 | An_Entry_Body_Declaration 428 | A_Body_Stub 429 | An_Exception_Declaration 430 | A_Choice_Parameter_Specification 431 | A_Generic_Declaration 432 => 433 -- Nothing interesting here for us 434 Control := Abandon_Children; 435 when A_Variable_Declaration 436 | A_Constant_Declaration 437 | A_Single_Task_Declaration 438 | A_Single_Protected_Declaration 439 | A_Loop_Parameter_Specification 440 | A_Package_Declaration 441 | A_Generic_Instantiation 442 => 443 -- Let's recurse normally 444 null; 445 when A_Renaming_Declaration => 446 -- Traverse only the renamed entity (not the new name) 447 Traverse (Renamed_Entity (Element), Control, Descr); 448 Control := Abandon_Children; 449 when A_Package_Body_Declaration => 450 -- Recurse normally if it is not a generic body 451 if Is_Generic_Unit (Element) then 452 Control := Abandon_Children; 453 end if; 454 when A_Component_Declaration => 455 -- Traverse the declaration, but not the initialization expression 456 Traverse (Object_Declaration_View (Element), Control, Descr); 457 Control := Abandon_Children; 458 when A_Parameter_Specification 459 | An_Entry_Index_Specification 460 | A_Formal_Declaration 461 => 462 -- Should not happen since we don't traverse the corresponding parent node 463 Failure ("Unexpected declaration: " 464 & Declaration_Kinds'Wide_Image (Declaration_Kind (Element)), Element); 465 when others => 466 -- Ada 2005 declaration kinds 467 null; 468 end case; 469 470 when A_Definition => 471 case Definition_Kind (Element) is 472 when An_Aspect_Specification => 473 -- 2012, ignored for the moment 474 Control := Abandon_Children; 475 when An_Access_Definition => 476 -- Nothing can make a call here, and traversing it would make problems with 477 -- access to subprograms (we assume the formals are not traversed) 478 Control := Abandon_Children; 479 when others => 480 null; 481 end case; 482 483 when others => 484 null; 485 end case; 486 487 exception 488 when Asis.Exceptions.ASIS_Failed => 489 declare 490 use Asis.Errors, Asis.Implementation; 491 begin 492 if Status /= Not_Implemented_Error then 493 raise; 494 end if; 495 496 -- Not_Implemented_Error 497 -- Presumably a use of a "non official" construct (conditional expression...) 498 -- This is known to happen in recent versions of the GNAT run-time 499 -- Short of any other solution, consider it does not include any call 500 -- (i.e. do nothing) 501 end; 502 end Pre_Procedure; 503 504 procedure Post_Procedure (Element : in Asis.Element; 505 Control : in out Asis.Traverse_Control; 506 Descr : in out Depth_Descriptor) 507 is 508 pragma Unreferenced (Element, Control, Descr); 509 begin 510 null; 511 end Post_Procedure; 512 513 function Entity_Call_Depth (Decl : Asis.Declaration) return Depth_Descriptor is 514 -- The call depth of an entity is the maximum of all calls inside it, i.e.: 515 -- returns 0 if Decl is the declaration of a callable_entity that calls nothing 516 -- returns 1 if Decl is the declaration of a callable_entity that calls only entities of depth 0 517 -- ... 518 -- returns Infinite if Decl is the declaration of a callable_entity that is directly or indirectly recursive 519 -- 520 -- Precondition: Decl is the declaration of a real subprogram, not of a renaming 521 use Asis, Asis.Declarations, Asis.Elements; 522 use Depth_Map, Framework.Rules_Manager, Thick_Queries, Utilities; 523 524 Called_Name : constant Unbounded_Wide_String := To_Unbounded_Wide_String (Full_Name_Image (Names (Decl)(1), 525 With_Profile => True)); 526 Called_Body : Asis.Declaration; 527 Control : Traverse_Control := Continue; 528 Result : Depth_Descriptor; 529 530 procedure Analyze_Body is 531 Recursivity_Found : exception; 532 begin 533 -- Initialize to Infinite before traversing. This way, if it is truly recursive, 534 -- it will be found in the map and the result will be Infinite. 535 Add (Call_Depths, Called_Name, (Recursive, Infinite)); 536 Result := (Regular, 0); 537 538 -- We cannot directly traverse the whole body, since bodies are discarded 539 -- We traverse all the parts manually (except formal parameters, of course) 540 -- Of course, we can stop the traversal as soon as we determine that the 541 -- SP is recursive. 542 declare 543 Body_Decls : constant Asis.Declaration_List := Body_Declarative_Items (Called_Body); 544 begin 545 for I in Body_Decls'Range loop 546 Traverse (Body_Decls (I), Control, Result); 547 if Result.Kind = Recursive then 548 raise Recursivity_Found; 549 end if; 550 end loop; 551 end; 552 declare 553 Body_Stats : constant Asis.Statement_List := Body_Statements (Called_Body); 554 begin 555 for I in Body_Stats'Range loop 556 Traverse (Body_Stats (I), Control, Result); 557 if Result.Kind = Recursive then 558 raise Recursivity_Found; 559 end if; 560 end loop; 561 end; 562 declare 563 Body_Handlers : constant Asis.Exception_Handler_List := Body_Exception_Handlers (Called_Body); 564 begin 565 for I in Body_Handlers'Range loop 566 Traverse (Body_Handlers (I), Control, Result); 567 if Result.Kind = Recursive then 568 raise Recursivity_Found; 569 end if; 570 end loop; 571 end; 572 573 exception 574 when Recursivity_Found => 575 Result := (Recursive, Infinite); 576 end Analyze_Body; 577 578 begin -- Entity_Call_Depth 579 -- Called_Body walks the structure until we find the real body corresponding to Decl 580 -- So, it is really the called body only after this loop! 581 Called_Body := Decl; 582 583 loop 584 if Is_Nil (Called_Body) then 585 -- body not in context 586 Result := (Unavailable, 0); 587 exit; 588 elsif Element_Kind (Called_Body) = A_Pragma or Definition_Kind (Called_Body) = An_Aspect_Specification then 589 -- body given by a pragma (or aspect) import 590 Result := (Unavailable, 0); 591 exit; 592 elsif Is_Banned (Called_Body, Rule_Id) then 593 Result := (Banned, 0); 594 exit; 595 end if; 596 597 case Declaration_Kind (Called_Body) is 598 when A_Procedure_Declaration 599 | A_Function_Declaration 600 | A_Generic_Procedure_Declaration 601 | A_Generic_Function_Declaration 602 | A_Procedure_Instantiation 603 | A_Function_Instantiation 604 => 605 Called_Body := Corresponding_Body (Called_Body); 606 607 when A_Null_Procedure_Declaration => 608 Result := (Regular, 0); 609 exit; 610 611 when An_Expression_Function_Declaration => -- Ada 2012 612 -- Like Analyze_Body, on the result expression 613 Add (Call_Depths, Called_Name, (Recursive, Infinite)); 614 Result := (Regular, 0); 615 Traverse (Result_Expression (Called_Body), Control, Result); 616 exit; 617 618 when An_Entry_Declaration => 619 if Is_Task_Entry (Called_Body) then 620 -- A task entry => not followed 621 Result := (Regular, 0); 622 exit; 623 end if; 624 Called_Body := Corresponding_Body (Called_Body); 625 626 when A_Procedure_Body_Declaration 627 | A_Function_Body_Declaration 628 | An_Entry_Body_Declaration 629 => 630 -- A real body (at last!) 631 Analyze_Body; 632 exit; 633 634 when A_Procedure_Body_Stub 635 | A_Function_Body_Stub 636 => 637 Called_Body := Corresponding_Subunit (Called_Body); 638 639 when A_Procedure_Renaming_Declaration 640 | A_Function_Renaming_Declaration 641 => 642 Failure ("renaming declaration in Entity_Call_Depth", Called_Body); 643 644 when A_Formal_Function_Declaration 645 | A_Formal_Procedure_Declaration 646 => 647 Result := (Formal, 0); 648 exit; 649 650 when others => 651 Failure ("not a callable entity declaration", Called_Body); 652 end case; 653 end loop; 654 655 Add (Call_Depths, Called_Name, Result); 656 return Result; 657 end Entity_Call_Depth; 658 659 660 ------------------ 661 -- Process_Call -- 662 ------------------ 663 664 procedure Process_Call (Call : in Asis.Element) is 665 Descr : Depth_Descriptor; 666 667 procedure Do_Report (Ctl_Kind : Control_Kinds) is 668 use Framework.Reports, Utilities; 669 begin 670 case Descr.Kind is 671 when Regular | Inline => 672 Report (Rule_Id, 673 To_Wide_String (Ctl_Labels (Ctl_Kind)), 674 Ctl_Kind, 675 Get_Location (Call), 676 "Call has a depth of " & ASIS_Integer_Img (Descr.Depth)); 677 when Dynamic => 678 Report (Rule_Id, 679 To_Wide_String (Ctl_Labels (Ctl_Kind)), 680 Ctl_Kind, 681 Get_Location (Call), 682 "Dynamic or dispatching call has a depth of at least " & ASIS_Integer_Img (Descr.Depth)); 683 when Unexplored | Unknown => 684 Report (Rule_Id, 685 To_Wide_String (Ctl_Labels (Ctl_Kind)), 686 Ctl_Kind, 687 Get_Location (Call), 688 "Call has a depth of at least " & ASIS_Integer_Img (Descr.Depth)); 689 when Recursive => 690 Report (Rule_Id, 691 To_Wide_String (Ctl_Labels (Ctl_Kind)), 692 Ctl_Kind, 693 Get_Location (Call), 694 "Call to recursive entity"); 695 end case; 696 end Do_Report; 697 698 use type Asis.ASIS_Integer; -- Gela-ASIS compatibility 699 begin -- Process_Call 700 if not Rule_Used then 701 return; 702 end if; 703 Rules_Manager.Enter (Rule_Id); 704 705 Descr := Call_Depth (Call); 706 if Depths (Check) /= Unused and then Descr.Depth >= Depths (Check) then 707 Do_Report (Check); 708 elsif Depths (Search) /= Unused and then Descr.Depth >= Depths (Search) then 709 Do_Report (Search); 710 else 711 case Descr.Kind is 712 when Unknown => 713 Report_Uncheckable (Call, "depth unknown for some elements in call chain", Descr.Depth); 714 when Dynamic => 715 Report_Uncheckable (Call, "dynamic or dispatching call", Descr.Depth); 716 when Banned => 717 Report_Uncheckable (Call, "call to a inhibited subprogram", Descr.Depth); 718 when Formal => 719 Report_Uncheckable (Call, "call to a generic formal subprogram", Descr.Depth); 720 when Unavailable => 721 Report_Uncheckable (Call, 722 "call to a subprogram whose body is not available (imported, predefined...)", 723 Descr.Depth); 724 when Regular | Inline | Recursive => 725 null; 726 end case; 727 end if; 728 729 if Depths (Count) /= Unused and then Descr.Depth >= Depths (Count) then 730 Do_Report (Count); 731 end if; 732 733 end Process_Call; 734 735begin -- Rules.Max_Call_Depth 736 Framework.Rules_Manager.Register (Rule_Id, 737 Rules_Manager.Semantic, 738 Help_CB => Help'Access, 739 Add_Control_CB => Add_Control'Access, 740 Command_CB => Command'Access, 741 Prepare_CB => Prepare'Access); 742 Framework.Variables.Register (Count_Expr_Fun_Calls'Access, 743 Variable_Name => Rule_Id & ".COUNT_EXPR_FUN_CALLS"); 744end Rules.Max_Call_Depth; 745