1------------------------------------------------------------------------------ 2-- -- 3-- GNATCHECK COMPONENTS -- 4-- -- 5-- G N A T C H E C K . A S I S _ U T I L I T I E S -- 6-- -- 7-- B o d y -- 8-- -- 9-- Copyright (C) 2004-2015, AdaCore -- 10-- -- 11-- GNATCHECK is free software; you can redistribute it and/or modify it -- 12-- under terms of the GNU General Public License as published by the Free -- 13-- Software Foundation; either version 3, or ( at your option) any later -- 14-- version. GNATCHECK is distributed in the hope that it will be useful, -- 15-- but WITHOUT ANY WARRANTY; without even the implied warranty of -- 16-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General -- 17-- Public License for more details. You should have received a copy of the -- 18-- GNU General Public License distributed with GNAT; see file COPYING3. If -- 19-- not, go to http://www.gnu.org/licenses for a complete copy of the -- 20-- license. -- 21-- -- 22-- GNATCHECK is maintained by AdaCore (http://www.adacore.com). -- 23-- -- 24------------------------------------------------------------------------------ 25 26pragma Ada_2012; 27 28with Ada.Wide_Text_IO; use Ada.Wide_Text_IO; 29-- with GNAT.Directory_Operations; use GNAT.Directory_Operations; 30-- with GNAT.OS_Lib; use GNAT.OS_Lib; 31 32with Asis.Clauses; use Asis.Clauses; 33with Asis.Compilation_Units; use Asis.Compilation_Units; 34with Asis.Declarations; use Asis.Declarations; 35with Asis.Definitions; use Asis.Definitions; 36with Asis.Elements; use Asis.Elements; 37with Asis.Exceptions; 38with Asis.Expressions; use Asis.Expressions; 39with Asis.Extensions; use Asis.Extensions; 40with Asis.Extensions.Flat_Kinds; use Asis.Extensions.Flat_Kinds; 41with Asis.Iterator; use Asis.Iterator; 42with Asis.Statements; use Asis.Statements; 43with Asis.Text; use Asis.Text; 44 45-- with ASIS_UL.Compiler_Options; use ASIS_UL.Compiler_Options; 46-- with ASIS_UL.Source_Table; use ASIS_UL.Source_Table; 47with ASIS_UL.Utilities; use ASIS_UL.Utilities; 48 49with Table; 50 51with Atree; use Atree; 52with Einfo; use Einfo; 53with Namet; use Namet; 54with Nlists; use Nlists; 55with Sem_Aux; use Sem_Aux; 56with Sinfo; use Sinfo; 57with Snames; use Snames; 58with Stand; use Stand; 59with Types; use Types; 60 61with Asis.Set_Get; use Asis.Set_Get; 62 63with A4G.A_Sem; use A4G.A_Sem; 64with A4G.Vcheck; use A4G.Vcheck; 65 66with Gnatcheck.Traversal_Stack; use Gnatcheck.Traversal_Stack; 67 68package body Gnatcheck.ASIS_Utilities is 69 Package_Name : constant String := "Gnatcheck.ASIS_Utilities"; 70 71 ------------------------- 72 -- ASIS Elements Table -- 73 ------------------------- 74 75 -- Here we define the same structure as A4G.Asis_Tables.Asis_Element_Table. 76 -- We need it to create the results of the functions returning 77 -- Element_List, but we can not reuse A4G.Asis_Tables.Asis_Element_Table 78 -- because it may be used by the standard ASIS queries we may need for our 79 -- gnatcheck ASIS utilities. 80 81 package Gnatcheck_Element_Table is new Table.Table ( 82 Table_Component_Type => Asis.Element, 83 Table_Index_Type => Natural, 84 Table_Low_Bound => 1, 85 Table_Initial => 100, 86 Table_Increment => 100, 87 Table_Name => "GNATCHECK Element List"); 88 89 ----------------------- 90 -- Local subprograms -- 91 ----------------------- 92 93 function Is_Limited (SM : Asis.Element) return Boolean; 94 -- Supposing that SM represent a subtype mark, checks if the denoted type 95 -- is limited. Returns False for any unexpected element. 96 -- 97 -- Expected Expression_Kinds: 98 -- An_Identifier 99 -- A_Selected_Component 100 -- An_Attribute_Reference 101 102 function Is_Constr_Error_Declaration (Decl : Asis.Element) return Boolean; 103 function Is_Num_Error_Declaration (Decl : Asis.Element) return Boolean; 104 -- Checks if the argument represents the declaration of the predefined 105 -- exception Constraint_Error/Numeric_Error 106 107 function Is_Task_Object_Declaration (Expr : Asis.Element) return Boolean; 108 -- Check if the element if a declaration of (one or more) task object(s) 109 -- Returns False for any unexpected object 110 -- 111 -- Expected Declaration_Kinds: 112 -- A_Variable_Declaration 113 -- A_Constant_Declaration 114 115 function Get_Called_Task (Call : Asis.Element) return Asis.Element; 116 pragma Unreferenced (Get_Called_Task); 117 -- Provided that Is_Task_Entry_Call (Call) computes the called 118 -- task. 119 -- What is "the called task" for different ways of defining a task 120 -- object ??? 121 122 procedure Look_For_Loop_Pre_Op 123 (Element : Asis.Element; 124 Control : in out Traverse_Control; 125 State : in out Boolean); 126 -- Actual for Traverse_Element instantiation. 127 -- Terminates the traversal and sets State ON when visiting a loop 128 -- statement. Skips traversal of declarations, expressions and simple 129 -- statements 130 131 procedure Empty_Bool_Post_Op 132 (Element : Asis.Element; 133 Control : in out Traverse_Control; 134 State : in out Boolean); 135 -- Actual for Traverse_Element instantiation. 136 -- Does nothing. 137 138 procedure Look_For_Loop is new Traverse_Element 139 (State_Information => Boolean, 140 Pre_Operation => Look_For_Loop_Pre_Op, 141 Post_Operation => Empty_Bool_Post_Op); 142 -- Looks for a lood statement enclosed by its Element argument and sets 143 -- the result of the search to its State parameter. Declarations are not 144 -- searched. 145 146 procedure Check_For_Discr_Reference 147 (Element : Asis.Element; 148 Control : in out Traverse_Control; 149 State : in out Boolean); 150 -- If Element is An_Identifier, checks if it is reference to discriminant; 151 -- and if it is - sets State ON and terminates traversing 152 153 procedure Check_For_Discriminant_Reference is new Traverse_Element 154 (State_Information => Boolean, 155 Pre_Operation => Check_For_Discr_Reference, 156 Post_Operation => Empty_Bool_Post_Op); 157 -- Checks if Element has a reference to a discriminant 158 159 --------------------------- 160 -- Can_Cause_Side_Effect -- 161 --------------------------- 162 163 function Can_Cause_Side_Effect (El : Asis.Element) return Boolean is 164 Arg_Kind : constant Flat_Element_Kinds := Flat_Element_Kind (El); 165 Result : Boolean := False; 166 begin 167 -- !!! Only partial implementation for now!!! 168 169 case Arg_Kind is 170 when An_Assignment_Statement | 171 A_Procedure_Call_Statement | 172 A_Function_Call => 173 -- What about entry calls??? 174 Result := True; 175-- when => 176 when others => 177 null; 178 end case; 179 180 return Result; 181 end Can_Cause_Side_Effect; 182 183 ---------------------------------------------- 184 -- Call_To_Complicated_Cuncurrent_Structure -- 185 ---------------------------------------------- 186 187 function Call_To_Complicated_Cuncurrent_Structure 188 (Call : Asis.Element) 189 return Boolean 190 is 191 Arg_Kind : constant Flat_Element_Kinds := Flat_Element_Kind (Call); 192 Result : Boolean := True; 193 Called_Pref : Asis.Element := Nil_Element; 194 Called_Obj : Asis.Element := Nil_Element; 195 Tmp_El : Asis.Element; 196 begin 197 198 case Arg_Kind is 199 when An_Entry_Call_Statement | 200 A_Procedure_Call_Statement => 201 Called_Pref := Called_Name (Call); 202 203 if Arg_Kind = An_Entry_Call_Statement 204 and then 205 Flat_Element_Kind (Called_Pref) = An_Indexed_Component 206 then 207 -- Call to an entry from an entry family 208 Called_Pref := Prefix (Called_Pref); 209 end if; 210 211 when A_Function_Call => 212 Called_Pref := Prefix (Call); 213 when others => 214 null; 215 end case; 216 217 -- Called_Pref should be of A_Selected_Component kind. We are interested 218 -- in task or protected object now 219 220 if Flat_Element_Kind (Called_Pref) = A_Selected_Component then 221 Called_Pref := Prefix (Called_Pref); 222 223 if Flat_Element_Kind (Called_Pref) = A_Selected_Component then 224 Called_Pref := Selector (Called_Pref); 225 end if; 226 227 end if; 228 229 if Expression_Kind (Called_Pref) = An_Identifier then 230 231 begin 232 Called_Obj := Corresponding_Name_Definition (Called_Pref); 233 exception 234 when others => 235 Called_Obj := Nil_Element; 236 end; 237 238 end if; 239 240 if not Is_Nil (Called_Obj) then 241 Tmp_El := Enclosing_Element (Called_Obj); 242 243 case Declaration_Kind (Tmp_El) is 244 when A_Single_Task_Declaration .. A_Single_Protected_Declaration => 245 Result := False; 246 247 when A_Variable_Declaration | A_Constant_Declaration => 248 Tmp_El := Object_Declaration_View (Tmp_El); 249 250 Tmp_El := Asis.Definitions.Subtype_Mark (Tmp_El); 251 252 if Expression_Kind (Tmp_El) = A_Selected_Component then 253 Tmp_El := Selector (Tmp_El); 254 end if; 255 256 Tmp_El := Corresponding_Name_Declaration (Tmp_El); 257 258 -- Now we check that the type of the object is a task or 259 -- protected type 260 261 Tmp_El := Corresponding_First_Subtype (Tmp_El); 262 263 -- We can n0t have a private type here. 264 265 if Declaration_Kind (Tmp_El) in 266 A_Task_Type_Declaration .. A_Protected_Type_Declaration 267 then 268 Result := False; 269 else 270 Tmp_El := Type_Declaration_View (Tmp_El); 271 272 if Asis.Elements.Type_Kind (Tmp_El) = 273 A_Derived_Type_Definition 274 then 275 Tmp_El := Corresponding_Root_Type (Tmp_El); 276 277 if Declaration_Kind (Tmp_El) in 278 A_Task_Type_Declaration .. A_Protected_Type_Declaration 279 then 280 Result := False; 281 end if; 282 283 end if; 284 end if; 285 286 when others => 287 null; 288 end case; 289 290 end if; 291 292 return Result; 293 end Call_To_Complicated_Cuncurrent_Structure; 294 295 ----------------------------------- 296 -- Can_Be_Replaced_With_Function -- 297 ----------------------------------- 298 299 function Can_Be_Replaced_With_Function 300 (Decl : Asis.Element) 301 return Boolean 302 is 303 Out_Par : Asis.Element := Nil_Element; 304 Result : Boolean := False; 305 begin 306 307 case Declaration_Kind (Decl) is 308 when A_Procedure_Declaration | 309 A_Procedure_Body_Declaration | 310 A_Procedure_Body_Stub | 311 A_Generic_Procedure_Declaration | 312 A_Formal_Procedure_Declaration => 313 314 declare 315 Params : constant Asis.Element_List := Parameter_Profile (Decl); 316 begin 317 318 for J in Params'Range loop 319 320 case Mode_Kind (Params (J)) is 321 when An_Out_Mode => 322 323 if Names (Params (J))'Length > 1 then 324 Result := False; 325 exit; 326 end if; 327 328 if Is_Nil (Out_Par) then 329 Out_Par := Object_Declaration_View (Params (J)); 330 331 if Definition_Kind (Out_Par) = 332 An_Access_Definition 333 then 334 Result := True; 335 else 336 -- If we are here, Out_Par represents a subtype 337 -- mark 338 Result := not Is_Limited (Out_Par); 339 340 exit when not Result; 341 342 end if; 343 344 else 345 Result := False; 346 exit; 347 end if; 348 349 when An_In_Out_Mode => 350 Result := False; 351 exit; 352 when others => 353 null; 354 end case; 355 356 end loop; 357 358 end; 359 360 when others => 361 null; 362 end case; 363 364 return Result; 365 end Can_Be_Replaced_With_Function; 366 367 --------------------- 368 -- Changed_Element -- 369 --------------------- 370 371 function Changed_Element (El : Asis.Element) return Asis.Element is 372 Arg_Elem : Asis.Element := El; 373 Arg_Kind : constant Flat_Element_Kinds := Flat_Element_Kind (El); 374 Result : Asis.Element := Nil_Element; 375 begin 376 377 -- Problem with access types!!!??? 378 379 case Arg_Kind is 380 when An_Identifier => 381 -- Nothing to do: 382 null; 383 when A_Selected_Component => 384 Arg_Elem := Get_Whole_Object (Arg_Elem); 385 386 when An_Indexed_Component | 387 A_Slice | 388 An_Explicit_Dereference => 389 390 while not (Expression_Kind (Arg_Elem) = A_Selected_Component 391 or else 392 Expression_Kind (Arg_Elem) = An_Identifier) 393 loop 394 Arg_Elem := Prefix (Arg_Elem); 395 end loop; 396 397 if Expression_Kind (Arg_Elem) = A_Selected_Component then 398 Arg_Elem := Get_Whole_Object (Arg_Elem); 399 end if; 400 401 when A_Type_Conversion => 402 return Changed_Element (Converted_Or_Qualified_Expression (El)); 403 404-- when => 405 when others => 406 pragma Assert (False); 407 null; 408 end case; 409 410 if Expression_Kind (Arg_Elem) = An_Identifier then 411 Result := Corresponding_Name_Definition (Arg_Elem); 412 else 413 Result := Arg_Elem; 414 end if; 415 416 return Result; 417 end Changed_Element; 418 419 ------------------------------- 420 -- Check_For_Discr_Reference -- 421 ------------------------------- 422 423 procedure Check_For_Discr_Reference 424 (Element : Asis.Element; 425 Control : in out Traverse_Control; 426 State : in out Boolean) 427 is 428 begin 429 430 case Expression_Kind (Element) is 431 when An_Identifier => 432 433 begin 434 if Declaration_Kind (Corresponding_Name_Declaration (Element)) = 435 A_Discriminant_Specification 436 then 437 State := True; 438 Control := Terminate_Immediately; 439 end if; 440 exception 441 when Asis.Exceptions.ASIS_Inappropriate_Element => 442 null; 443 end; 444 445 when Not_An_Expression => 446 null; 447 when others => 448 Control := Abandon_Children; 449 end case; 450 451 end Check_For_Discr_Reference; 452 453 ---------------------------------------- 454 -- Constraint_Depends_On_Discriminant -- 455 ---------------------------------------- 456 457 function Constraint_Depends_On_Discriminant 458 (Constr : Asis.Element) 459 return Boolean 460 is 461 Control : Traverse_Control := Continue; 462 Result : Boolean := False; 463 begin 464 465 if Constraint_Kind (Constr) in 466 An_Index_Constraint .. A_Discriminant_Constraint 467 and then 468 Definition_Kind (Enclosing_Element (Enclosing_Element (Constr))) = 469 A_Component_Definition 470 then 471 Check_For_Discriminant_Reference 472 (Element => Constr, 473 Control => Control, 474 State => Result); 475 end if; 476 477 return Result; 478 end Constraint_Depends_On_Discriminant; 479 480 ------------------- 481 -- Contains_Loop -- 482 ------------------- 483 484 function Contains_Loop (El : Asis.Element) return Boolean is 485 Control : Traverse_Control := Continue; 486 Result : Boolean := False; 487 488 Comps : constant Asis.Element_List := Components (El); 489 begin 490 491 -- We can not just apply Look_For_Loop tp El - if El itself is a loop 492 -- statement, then Result will alvays be True: 493 for J in Comps'Range loop 494 Look_For_Loop (Comps (J), Control, Result); 495 exit when Result; 496 end loop; 497 498 return Result; 499 500 end Contains_Loop; 501 502 ------------------------------------ 503 -- Corresponding_Protected_Object -- 504 ------------------------------------ 505 506 function Corresponding_Protected_Object 507 (Pref : Asis.Element) 508 return Asis.Element 509 is 510 Tmp : Asis.Element := Pref; 511 Result : Asis.Element := Nil_Element; 512 begin 513 514 if Expression_Kind (Tmp) = A_Function_Call then 515 Tmp := Prefix (Tmp); 516 else 517 Tmp := Called_Name (Tmp); 518 end if; 519 520 -- At the moment the simplest case only is implemented: we can process 521 -- only the argument Element of the form P_Obj_Name.P_Op_Name 522 523 if Expression_Kind (Tmp) = A_Selected_Component then 524 Tmp := Prefix (Tmp); 525 526 if Expression_Kind (Tmp) = A_Selected_Component then 527 Tmp := Selector (Tmp); 528 end if; 529 530 pragma Assert (Expression_Kind (Tmp) = An_Identifier); 531 532 Result := Corresponding_Name_Definition (Tmp); 533 534 if Declaration_Kind (Enclosing_Element (Result)) = 535 A_Single_Protected_Declaration 536 then 537 Result := Enclosing_Element (Result); 538 end if; 539 540 end if; 541 542 pragma Assert (not Is_Nil (Result)); 543 544 return Result; 545 546 end Corresponding_Protected_Object; 547 548 ----------------------------------- 549 -- Declaration_Of_Renamed_Entity -- 550 ----------------------------------- 551 552 function Declaration_Of_Renamed_Entity 553 (R : Asis.Element) 554 return Asis.Element 555 is 556 Arg_Element : Asis.Element := Renamed_Entity (R); 557 Result : Asis.Element := Nil_Element; 558 begin 559 560 if Expression_Kind (Arg_Element) = A_Selected_Component then 561 Arg_Element := Selector (Arg_Element); 562 end if; 563 564 case Expression_Kind (Arg_Element) is 565 when An_Identifier | 566 An_Operator_Symbol | 567 A_Character_Literal | 568 An_Enumeration_Literal => 569 Result := Corresponding_Name_Declaration (Arg_Element); 570 when others => 571 null; 572 end case; 573 574 return Result; 575 exception 576 when others => 577 return Nil_Element; 578 end Declaration_Of_Renamed_Entity; 579 580 ------------------------ 581 -- Defines_Components -- 582 ------------------------ 583 584 function Defines_Components (Decl : Asis.Element) return Boolean is 585 Type_Def : Asis.Element; 586 Result : Boolean := False; 587 begin 588 589 if Declaration_Kind (Decl) = An_Ordinary_Type_Declaration then 590 591 Type_Def := Type_Declaration_View (Decl); 592 593 case Asis.Elements.Type_Kind (Type_Def) is 594 when A_Derived_Record_Extension_Definition | 595 A_Record_Type_Definition | 596 A_Tagged_Record_Type_Definition => 597 Result := True; 598 when others => 599 null; 600 end case; 601 602 end if; 603 604 return Result; 605 606 end Defines_Components; 607 608 ---------------------------- 609 -- Denotes_Access_Subtype -- 610 ---------------------------- 611 612 function Denotes_Access_Subtype (N : Asis.Element) return Boolean is 613 begin 614 return Ekind (Node (N)) in Access_Kind; 615 end Denotes_Access_Subtype; 616 617 -------------------------------- 618 -- Denotes_Class_Wide_Subtype -- 619 -------------------------------- 620 621 function Denotes_Class_Wide_Subtype (N : Asis.Element) return Boolean is 622 E : Entity_Id; 623 Result : Boolean := False; 624 begin 625 626 E := R_Node (N); 627 628 if Nkind (E) in N_Expanded_Name | N_Identifier then 629 E := Entity (E); 630 631 if Present (E) then 632 Result := Ekind (E) = E_Class_Wide_Subtype; 633 end if; 634 end if; 635 636 return Result; 637 end Denotes_Class_Wide_Subtype; 638 639 --------------------------- 640 -- Empty_Bool_Post_Op -- 641 --------------------------- 642 643 procedure Empty_Bool_Post_Op 644 (Element : Asis.Element; 645 Control : in out Traverse_Control; 646 State : in out Boolean) 647 is 648 pragma Unreferenced (Element, Control, State); 649 begin 650 null; 651 end Empty_Bool_Post_Op; 652 653 ----------------------- 654 -- Full_View_Visible -- 655 ----------------------- 656 657 function Full_View_Visible 658 (Type_Decl : Asis.Declaration; 659 At_Place : Asis.Element) 660 return Boolean 661 is 662 Result : Boolean := False; 663 Full_View : Asis.Declaration; 664 Enclosing_Pack_Spec : Asis.Declaration; 665 Enclosing_Pack_Body : Asis.Declaration; 666 667 Type_Spec_CU : Asis.Compilation_Unit; 668 Type_Body_CU : Asis.Compilation_Unit := Nil_Compilation_Unit; 669 Location_CU : Asis.Compilation_Unit; 670 Next_Parent : Asis.Compilation_Unit; 671 672 Stub_El : Asis.Element; 673 begin 674 -- First, check if we have expected elements and return False if we 675 -- do not. 676 677 if Declaration_Kind (Type_Decl) not in 678 A_Private_Type_Declaration .. A_Private_Extension_Declaration 679 or else 680 Is_Part_Of_Implicit (Type_Decl) 681 or else 682 Is_Part_Of_Implicit (At_Place) 683 or else 684 Is_Part_Of_Instance (Type_Decl) 685 or else 686 Is_Part_Of_Instance (At_Place) 687 then 688 return False; 689 end if; 690 691 Full_View := Corresponding_Type_Declaration (Type_Decl); 692 Enclosing_Pack_Spec := Enclosing_Element (Type_Decl); 693 Enclosing_Pack_Body := Corresponding_Body (Enclosing_Pack_Spec); 694 695 if Declaration_Kind (Enclosing_Pack_Body) = A_Package_Body_Stub then 696 Enclosing_Pack_Body := Corresponding_Subunit (Enclosing_Pack_Body); 697 end if; 698 699 Type_Spec_CU := Enclosing_Compilation_Unit (Enclosing_Pack_Spec); 700 Location_CU := Enclosing_Compilation_Unit (At_Place); 701 702 if not Is_Nil (Enclosing_Pack_Body) then 703 Type_Body_CU := Enclosing_Compilation_Unit (Enclosing_Pack_Body); 704 end if; 705 706 -- Type declaration and location to check are in the same CU: 707 708 if Is_Equal (Type_Spec_CU, Location_CU) then 709 if In_Private_Part (Enclosing_Pack_Spec, At_Place) then 710 Result := Before (Full_View, At_Place); 711 elsif Is_Equal (Type_Body_CU, Location_CU) then 712 Result := 713 Inclides (Whole => Enclosing_Pack_Body, Part => At_Place); 714 end if; 715 716 return Result; 717 end if; 718 719 -- If we are here, then type declaration and location to check are 720 -- in different compilation units. First, check if location is in 721 -- the body of the package that defines the type. (Subunits are a 722 -- pain in this case) 723 724 if not Is_Nil (Type_Body_CU) then 725 726 if not Is_Equal (Type_Body_CU, Location_CU) then 727 728 if Unit_Kind (Location_CU) in A_Subunit then 729 Stub_El := Unit_Declaration (Location_CU); 730 Stub_El := Corresponding_Body_Stub (Stub_El); 731 end if; 732 733 while Unit_Kind (Location_CU) in A_Subunit loop 734 exit when Is_Equal (Type_Body_CU, Location_CU); 735 736 Stub_El := Unit_Declaration (Location_CU); 737 Stub_El := Corresponding_Body_Stub (Stub_El); 738 Location_CU := Corresponding_Subunit_Parent_Body (Location_CU); 739 740 end loop; 741 742 else 743 Stub_El := At_Place; 744 end if; 745 746 if Is_Equal (Type_Body_CU, Location_CU) then 747 Result := Inclides (Whole => Enclosing_Pack_Body, Part => Stub_El); 748 return Result; 749 end if; 750 751 end if; 752 753 -- If we are here, the only possibility when the full view is visible 754 -- at a given place is: 755 -- 756 -- - Type_Decl is declared in a visible part of a library package 757 -- 758 -- - At_Place is either in the child unit of this package - either in 759 -- the body, or in the private part of the public child, or in the 760 -- spec of a private child. 761 762 if (Unit_Kind (Type_Spec_CU) = A_Package 763 or else 764 Unit_Kind (Type_Spec_CU) = A_Generic_Package) 765 and then 766 Is_Equal (Enclosing_Element (Type_Decl), 767 Unit_Declaration (Type_Spec_CU)) 768 then 769 770 while Unit_Kind (Location_CU) in A_Subunit loop 771 Location_CU := Corresponding_Subunit_Parent_Body (Location_CU); 772 end loop; 773 774 Next_Parent := Location_CU; 775 776 while not Is_Nil (Next_Parent) loop 777 exit when Is_Equal (Next_Parent, Type_Spec_CU); 778 Next_Parent := Corresponding_Parent_Declaration (Next_Parent); 779 end loop; 780 781 if not Is_Equal (Next_Parent, Type_Spec_CU) then 782 return False; 783 elsif Unit_Kind (Location_CU) in A_Library_Unit_Body then 784 return True; 785 elsif Unit_Kind (Location_CU) = A_Package 786 or else 787 Unit_Kind (Location_CU) = A_Generic_Package 788 then 789 if Unit_Class (Location_CU) = A_Private_Declaration 790 and then 791 Is_Equal (Corresponding_Parent_Declaration (Location_CU), 792 Type_Spec_CU) 793 then 794 return True; 795 else 796 Result := 797 In_Private_Part (Pack => Unit_Declaration (Location_CU), 798 Element => At_Place); 799 return Result; 800 end if; 801 end if; 802 803 pragma Assert (False); 804 return False; 805 end if; 806 807 return False; 808 end Full_View_Visible; 809 810 ---------------------- 811 -- Get_Associations -- 812 ---------------------- 813 814 function Get_Associations (El : Asis.Element) return Asis.Element_List is 815 begin 816 817 case Flat_Element_Kind (El) is 818 when A_Record_Aggregate | 819 An_Extension_Aggregate => 820 return Record_Component_Associations (El); 821 when A_Positional_Array_Aggregate | 822 A_Named_Array_Aggregate => 823 return Array_Component_Associations (El); 824-- when => 825-- return (El); 826 when others => 827 return Nil_Element_List; 828 end case; 829 830 end Get_Associations; 831 832 ---------------------- 833 -- Get_Call_Element -- 834 ---------------------- 835 836 function Get_Call_Element return Asis.Element is 837 Steps_Up : Elmt_Idx := 0; 838 Result : Asis.Element := Get_Enclosing_Element (Steps_Up); 839 begin 840 loop 841 exit when 842 Expression_Kind (Result) = A_Function_Call 843 or else 844 Element_Kind (Result) /= An_Expression; 845 846 Steps_Up := Steps_Up + 1; 847 Result := Get_Enclosing_Element (Steps_Up); 848 end loop; 849 850 return Result; 851 end Get_Call_Element; 852 853 --------------------- 854 -- Get_Called_Task -- 855 --------------------- 856 857 function Get_Called_Task (Call : Asis.Element) return Asis.Element is 858 Result : Asis.Element := Nil_Element; 859 Tmp : Asis.Element; 860 Tmp1 : Asis.Element; 861 begin 862 -- For now - the simplest case. We consider that the prefix has 863 -- the form of Task_Name.Entry_Name 864 865 Tmp := Called_Name (Call); 866 867 if Expression_Kind (Tmp) = An_Indexed_Component then 868 -- A call to an entry from an entry family 869 Tmp := Prefix (Tmp); 870 end if; 871 872 if Expression_Kind (Tmp) = A_Selected_Component then 873 Tmp := Prefix (Tmp); 874 875 if Expression_Kind (Tmp) = A_Selected_Component then 876 Tmp := Asis.Expressions.Selector (Tmp); 877 end if; 878 879 Tmp := Corresponding_Name_Definition (Tmp); 880 881 if not Is_Nil (Tmp) then 882 -- For a task declared by a single task declaration we return this 883 -- single task declaration, otherwise we return a task defining 884 -- identifier 885 Tmp1 := Enclosing_Element (Tmp); 886 887 if Declaration_Kind (Tmp1) = A_Single_Task_Declaration then 888 Tmp := Tmp1; 889 end if; 890 891 Result := Tmp; 892 end if; 893 894 end if; 895 896 pragma Assert (not Is_Nil (Result)); 897 -- A null result requires a special processing, so for the development 898 -- period we just blow up 899 900 return Result; 901 end Get_Called_Task; 902 903 ----------------- 904 -- Get_Choices -- 905 ----------------- 906 907 function Get_Choices (El : Asis.Element) return Asis.Element_List is 908 begin 909 910 case Association_Kind (El) is 911 when An_Array_Component_Association => 912 return Array_Component_Choices (El); 913 when A_Record_Component_Association => 914 return Record_Component_Choices (El); 915 when others => 916 return Nil_Element_List; 917 end case; 918 919 end Get_Choices; 920 921 ---------------------------------- 922 -- Get_Corresponding_Definition -- 923 ---------------------------------- 924 925 function Get_Corresponding_Definition 926 (El : Asis.Element) 927 return Asis.Element 928 is 929 Arg_Kind : constant Expression_Kinds := Expression_Kind (El); 930 Result : Asis.Element; 931 begin 932 933 if not (Arg_Kind = An_Identifier 934 or else 935 Arg_Kind = An_Operator_Symbol 936 or else 937 Arg_Kind = A_Character_Literal 938 or else 939 Arg_Kind = An_Enumeration_Literal) 940 then 941 -- To avoid junk use of this query 942 Raise_ASIS_Inappropriate_Element 943 (Diagnosis => 944 "Gnatcheck.ASIS_Utilities.Get_Corresponding_Definition", 945 Wrong_Kind => Int_Kind (El)); 946 end if; 947 948 begin 949 Result := Corresponding_Name_Definition (El); 950 exception 951 when Asis.Exceptions.ASIS_Inappropriate_Element => 952 Result := Nil_Element; 953 end; 954 955 return Result; 956 end Get_Corresponding_Definition; 957 958 ------------------ 959 -- Get_Handlers -- 960 ------------------ 961 962 function Get_Handlers 963 (El : Asis.Element; 964 Include_Pragmas : Boolean := False) 965 return Asis.Element_List 966 is 967 begin 968 969 case Flat_Element_Kind (El) is 970 when A_Procedure_Body_Declaration | 971 A_Function_Body_Declaration | 972 A_Package_Body_Declaration | 973 An_Entry_Body_Declaration | 974 A_Task_Body_Declaration => 975 return Body_Exception_Handlers (El, Include_Pragmas); 976 977 when A_Block_Statement => 978 return Block_Exception_Handlers (El, Include_Pragmas); 979 980 when An_Extended_Return_Statement => 981 return Extended_Return_Exception_Handlers (El, Include_Pragmas); 982 983 when An_Accept_Statement => 984 return Accept_Body_Exception_Handlers (El, Include_Pragmas); 985 986 when others => 987 return Nil_Element_List; 988 end case; 989 990 end Get_Handlers; 991 992 ------------------------- 993 -- Get_Name_Definition -- 994 ------------------------- 995 996 function Get_Name_Definition (Ref : Asis.Element) return Asis.Element is 997 Result : Asis.Element := Normalize_Reference (Ref); 998 begin 999 1000 Result := Corresponding_Name_Definition (Result); 1001 1002 if Declaration_Kind (Enclosing_Element (Result)) in 1003 A_Renaming_Declaration 1004 then 1005 Result := Corresponding_Base_Entity (Enclosing_Element (Result)); 1006 Result := Normalize_Reference (Result); 1007 Result := Corresponding_Name_Definition (Result); 1008 end if; 1009 1010 return Result; 1011 end Get_Name_Definition; 1012 1013 ------------------- 1014 -- Get_Root_Type -- 1015 ------------------- 1016 1017 function Get_Root_Type (Decl : Asis.Element) return Asis.Element is 1018 Arg_Kind : constant Flat_Element_Kinds := Flat_Element_Kind (Decl); 1019 Type_Def : Asis.Element; 1020 Result : Asis.Element; 1021 begin 1022 1023 case Arg_Kind is 1024 when A_Variable_Declaration | 1025 A_Constant_Declaration => 1026 null; 1027 when others => 1028 Raise_ASIS_Inappropriate_Element 1029 (Package_Name & "Get_Root_Type", 1030 Wrong_Kind => Int_Kind (Decl)); 1031 end case; 1032 1033 Result := Object_Declaration_View (Decl); 1034 Result := Asis.Definitions.Subtype_Mark (Result); 1035 1036 if Expression_Kind (Result) = A_Selected_Component then 1037 Result := Selector (Result); 1038 end if; 1039 1040 Result := Corresponding_Name_Declaration (Result); 1041 1042 if Declaration_Kind (Result) = A_Subtype_Declaration then 1043 Result := Corresponding_First_Subtype (Result); 1044 end if; 1045 1046 if Declaration_Kind (Result) = An_Ordinary_Type_Declaration then 1047 Type_Def := Type_Declaration_View (Result); 1048 1049 if Asis.Elements.Type_Kind (Type_Def) in 1050 A_Derived_Type_Definition .. A_Derived_Record_Extension_Definition 1051 then 1052 Result := Corresponding_Root_Type (Type_Def); 1053 end if; 1054 1055 end if; 1056 1057 return Result; 1058 1059 end Get_Root_Type; 1060 1061 ------------------------- 1062 -- Get_Type_Components -- 1063 ------------------------- 1064 1065 function Get_Type_Components 1066 (El : Asis.Element; 1067 Include_Discriminants : Boolean) 1068 return Asis.Element_List 1069 is 1070 Type_Def : Asis.Element; 1071 1072 procedure Add_Components (Comps : Asis.Element_List); 1073 -- Adds record components to the result, recursively going down into 1074 -- variant part(s) 1075 1076 procedure Add_Components (Comps : Asis.Element_List) is 1077 begin 1078 1079 for J in Comps'Range loop 1080 1081 if Declaration_Kind (Comps (J)) = A_Component_Declaration then 1082 Gnatcheck_Element_Table.Append (Comps (J)); 1083 elsif Definition_Kind (Comps (J)) = A_Variant_Part then 1084 1085 declare 1086 Vars : constant Asis.Element_List := Variants (Comps (J)); 1087 begin 1088 for K in Vars'Range loop 1089 Add_Components (Record_Components (Vars (K))); 1090 end loop; 1091 end; 1092 1093 end if; 1094 1095 end loop; 1096 1097 end Add_Components; 1098 1099 begin 1100 Gnatcheck_Element_Table.Init; 1101 1102 if Include_Discriminants then 1103 1104 Type_Def := Discriminant_Part (El); 1105 1106 if Definition_Kind (Type_Def) = A_Known_Discriminant_Part then 1107 1108 declare 1109 Discr_List : constant Asis.Element_List := 1110 Discriminants (Type_Def); 1111 begin 1112 1113 for J in Discr_List'Range loop 1114 Gnatcheck_Element_Table.Append (Discr_List (J)); 1115 end loop; 1116 1117 end; 1118 1119 end if; 1120 1121 end if; 1122 1123 Type_Def := Type_Declaration_View (El); 1124 1125 case Flat_Element_Kind (Type_Def) is 1126 when A_Protected_Definition => 1127 1128 declare 1129 Items : constant Asis.Element_List := 1130 Private_Part_Items (Type_Def); 1131 begin 1132 1133 for J in Items'Range loop 1134 1135 if Declaration_Kind (Items (J)) = 1136 A_Component_Declaration 1137 then 1138 Gnatcheck_Element_Table.Append (Items (J)); 1139 end if; 1140 1141 end loop; 1142 1143 end; 1144 1145 when A_Derived_Type_Definition .. 1146 A_Derived_Record_Extension_Definition => 1147 1148 declare 1149 Items : constant Asis.Element_List := 1150 Implicit_Inherited_Declarations (Type_Def); 1151 begin 1152 1153 for J in Items'Range loop 1154 1155 if Declaration_Kind (Items (J)) = 1156 A_Component_Declaration 1157 then 1158 Gnatcheck_Element_Table.Append (Items (J)); 1159 end if; 1160 1161 end loop; 1162 1163 end; 1164 1165 when others => 1166 null; 1167 end case; 1168 1169 -- Now add explicit record components, if any 1170 1171 if Asis.Elements.Type_Kind (Type_Def) = 1172 A_Derived_Record_Extension_Definition 1173 or else 1174 Asis.Elements.Type_Kind (Type_Def) = A_Record_Type_Definition 1175 or else 1176 Asis.Elements.Type_Kind (Type_Def) = A_Tagged_Record_Type_Definition 1177 then 1178 Type_Def := Asis.Definitions.Record_Definition (Type_Def); 1179 1180 if Definition_Kind (Type_Def) /= A_Null_Record_Definition then 1181 1182 declare 1183 Comps : constant Asis.Element_List := 1184 Record_Components (Type_Def); 1185 begin 1186 Add_Components (Comps); 1187 end; 1188 1189 end if; 1190 1191 end if; 1192 1193 return Asis.Element_List 1194 (Gnatcheck_Element_Table.Table (1 .. Gnatcheck_Element_Table.Last)); 1195 end Get_Type_Components; 1196 1197 ------------------------------------- 1198 -- Get_Type_Decl_From_Subtype_Mark -- 1199 ------------------------------------- 1200 1201 function Get_Type_Decl_From_Subtype_Mark 1202 (SM : Asis.Element) 1203 return Asis.Element 1204 is 1205 Result : Asis.Element := SM; 1206 begin 1207 1208 if Expression_Kind (Result) = A_Selected_Component then 1209 Result := Selector (Result); 1210 end if; 1211 1212 Result := Corresponding_Name_Declaration (Result); 1213 1214 if Declaration_Kind (Result) = A_Subtype_Declaration then 1215 Result := Corresponding_First_Subtype (Result); 1216 end if; 1217 1218 if Declaration_Kind (Result) in 1219 A_Private_Type_Declaration .. A_Private_Extension_Declaration 1220 then 1221 Result := Corresponding_Type_Declaration (Result); 1222 end if; 1223 1224 return Result; 1225 end Get_Type_Decl_From_Subtype_Mark; 1226 1227 ---------------------- 1228 -- Get_Whole_Object -- 1229 ---------------------- 1230 1231 function Get_Whole_Object (El : Asis.Element) return Asis.Element is 1232 Pref : Asis.Element := El; 1233 -- Pref represents the (left) part of the argument name that has not 1234 -- been traversed yet 1235 1236 Result : Asis.Element := Selector (El); 1237 -- The selector part of the current Pref 1238 1239 procedure Step_To_The_Left; 1240 -- Resets the values of Pref and Result, moving them to the beginning 1241 -- (that is - to the left end) of the name represented by El: as a 1242 -- result of calling this procedure we should always have Result to be 1243 -- Selector (Prefix) except we are in the very beginning of El 1244 1245 procedure Step_To_The_Left is 1246 begin 1247 case Expression_Kind (Pref) is 1248 when Not_An_Expression => 1249 -- That is, Pref just is Nil_Element, and we have traversed the 1250 -- whole name represented by El 1251 1252 Result := Nil_Element; 1253 1254 when An_Identifier => 1255 -- Approaching the left part of El 1256 Result := Pref; 1257 Pref := Nil_Element; 1258 when A_Selected_Component => 1259 Pref := Prefix (Pref); 1260 1261 if Expression_Kind (Pref) = An_Identifier then 1262 Result := Pref; 1263 Pref := Nil_Element; 1264 elsif Expression_Kind (Pref) = A_Selected_Component then 1265 Result := Selector (Pref); 1266 else 1267 pragma Warnings (Off); 1268 Step_To_The_Left; 1269 pragma Warnings (On); 1270 end if; 1271 1272 when A_Slice | 1273 An_Explicit_Dereference | 1274 An_Indexed_Component => 1275 Pref := Prefix (Pref); 1276 1277 pragma Warnings (Off); 1278 Step_To_The_Left; 1279 pragma Warnings (ON); 1280 1281 when A_Function_Call => 1282 -- A rather exotic case - a function call (or a component 1283 -- therteof) as a changen element... 1284 Result := Corresponding_Called_Function (Pref); 1285 1286 when A_Type_Conversion => 1287 1288 Pref := Converted_Or_Qualified_Expression (Pref); 1289 1290 pragma Warnings (Off); 1291 Step_To_The_Left; 1292 pragma Warnings (ON); 1293 1294 when others => 1295 Put_Line (Standard_Error, Debug_Image (Pref)); 1296 1297 if Is_Text_Available (Pref) then 1298 Put_Line (Standard_Error, Element_Image (Pref)); 1299 end if; 1300 1301 pragma Assert (False); 1302 end case; 1303 1304 end Step_To_The_Left; 1305 1306 begin 1307 1308 while not Is_Nil (Result) loop 1309 1310 if Is_Function_Declaration (Result) then 1311 -- Actually, a more detailed analyzis is possible for this case 1312 exit; 1313 elsif No (Entity (R_Node (Result))) 1314 and then 1315 not Is_Nil (Pref) 1316 then 1317 -- We have a case of an expaded name - the Entity field is not 1318 -- set for a selector, but it is set for a whole expanded name. 1319 -- So what we now have in Result is what we are looking for: 1320 exit; 1321 1322 elsif Is_Nil (Pref) then 1323 -- That means that we get to the beginning (rightmost identifier) 1324 -- in the expanded name. It can not be a subcomponent, so: 1325 exit; 1326 end if; 1327 1328 Step_To_The_Left; 1329 1330 end loop; 1331 1332 return Result; 1333 end Get_Whole_Object; 1334 1335 ------------------------ 1336 -- Has_Address_Clause -- 1337 ------------------------ 1338 1339 function Has_Address_Clause (Def_Name : Asis.Element) return Boolean is 1340 Object_Decl : constant Asis.Element := Enclosing_Element (Def_Name); 1341 1342 Corr_Rep_Clauses : constant Asis.Element_List := 1343 Corresponding_Representation_Clauses (Object_Decl); 1344 1345 Result : Boolean := False; 1346 begin 1347 1348 for J in Corr_Rep_Clauses'Range loop 1349 1350 if Representation_Clause_Kind (Corr_Rep_Clauses (J)) = 1351 An_Attribute_Definition_Clause 1352 and then 1353 Attribute_Kind 1354 (Representation_Clause_Name (Corr_Rep_Clauses (J))) = 1355 An_Address_Attribute 1356 and then 1357 Is_Equal 1358 (Corresponding_Name_Definition 1359 (Prefix (Representation_Clause_Name 1360 (Corr_Rep_Clauses (J)))), 1361 Def_Name) 1362 then 1363 Result := True; 1364 exit; 1365 end if; 1366 1367 end loop; 1368 1369 return Result; 1370 end Has_Address_Clause; 1371 1372 ----------------------- 1373 -- Has_One_Parameter -- 1374 ----------------------- 1375 1376 function Has_One_Parameter (El : Asis.Element) return Boolean is 1377 Template_El : Asis.Element; 1378 Call_Node : Node_Id; 1379 Result : Boolean := False; 1380 begin 1381 1382 if Expression_Kind (El) = A_Function_Call 1383 or else 1384 Statement_Kind (El) = A_Procedure_Call_Statement 1385 or else 1386 Statement_Kind (El) = An_Entry_Call_Statement 1387 then 1388 Call_Node := Node (El); 1389 1390 if Nkind (Call_Node) = N_Attribute_Reference then 1391 1392 if Sinfo.Expressions (Call_Node) /= No_List 1393 and then 1394 List_Length (Sinfo.Expressions (Call_Node)) = 1 1395 then 1396 Result := True; 1397 end if; 1398 1399 else 1400 1401 if Parameter_Associations (Call_Node) /= No_List 1402 and then 1403 List_Length (Parameter_Associations (Call_Node)) = 1 1404 then 1405 Result := True; 1406 end if; 1407 1408 end if; 1409 1410 elsif Declaration_Kind (El) in A_Generic_Instantiation then 1411 Template_El := Normalize_Reference (Generic_Unit_Name (El)); 1412 Template_El := Corresponding_Name_Declaration (Template_El); 1413 1414 if Declaration_Kind (Template_El) in 1415 A_Generic_Package_Renaming_Declaration .. 1416 A_Generic_Function_Renaming_Declaration 1417 then 1418 Template_El := Corresponding_Base_Entity (Template_El); 1419 Template_El := Normalize_Reference (Template_El); 1420 Template_El := Corresponding_Name_Declaration (Template_El); 1421 end if; 1422 1423 Result := Generic_Formal_Part (Template_El)'Length = 1; 1424 end if; 1425 1426 return Result; 1427 end Has_One_Parameter; 1428 1429 -------------------------------- 1430 -- Has_Positional_Association -- 1431 -------------------------------- 1432 1433 function Has_Positional_Association (El : Asis.Element) return Boolean is 1434 Result : Boolean := False; 1435 begin 1436 1437 if Expression_Kind (El) in 1438 A_Record_Aggregate .. An_Extension_Aggregate 1439 -- The condition can be extended 1440 then 1441 1442 declare 1443 Associations : constant Asis.Element_List := Get_Associations (El); 1444 begin 1445 if Associations'Length > 0 then 1446 Result := Is_Positional (Associations (Associations'First)); 1447 end if; 1448 end; 1449 1450 end if; 1451 1452 return Result; 1453 end Has_Positional_Association; 1454 1455 ------------------------------ 1456 -- Has_Statements_And_Decls -- 1457 ------------------------------ 1458 1459 function Has_Statements_And_Decls (Decl : Asis.Element) return Boolean is 1460 Result : Boolean := False; 1461 begin 1462 1463 Result := not Is_Nil (Body_Statements (Decl)) 1464 and then 1465 not Is_Nil (Body_Declarative_Items (Decl)); 1466 1467 return Result; 1468 end Has_Statements_And_Decls; 1469 1470 ------------- 1471 -- Is_Body -- 1472 ------------- 1473 1474 function Is_Body (El : Asis.Element) return Boolean is 1475 Result : Boolean := False; 1476 begin 1477 1478 case Flat_Element_Kind (El) is 1479 when A_Procedure_Body_Declaration | 1480 A_Function_Body_Declaration | 1481 A_Package_Body_Declaration | 1482 A_Task_Body_Declaration | 1483 An_Entry_Body_Declaration => 1484 Result := True; 1485 when others => 1486 null; 1487 end case; 1488 1489 return Result; 1490 1491 end Is_Body; 1492 1493 --------------------------- 1494 -- Is_Boolean_Logical_Op -- 1495 --------------------------- 1496 1497 function Is_Boolean_Logical_Op (Op : Asis.Element) return Boolean is 1498 Entity_N : Entity_Id; 1499 Call : Asis.Element; 1500 Arg_Node : Node_Id := Node (Op); 1501 Result : Boolean := False; 1502 begin 1503 1504 if Operator_Kind (Op) in An_And_Operator .. An_Xor_Operator then 1505 1506 Call := Enclosing_Element (Op); 1507 1508 if Is_Prefix_Call (Call) then 1509 Arg_Node := R_Node (Call); 1510 1511 end if; 1512 1513 if Nkind (Arg_Node) = N_Op_And 1514 or else 1515 Nkind (Arg_Node) = N_Op_Or 1516 or else 1517 Nkind (Arg_Node) = N_Op_Xor 1518 then 1519 Entity_N := Entity (Arg_Node); 1520 1521 if Present (Entity_N) 1522 and then 1523 Sloc (Entity_N) <= Standard_Location 1524 and then 1525 Ekind (Etype (Arg_Node)) = E_Enumeration_Type 1526 then 1527 Result := True; 1528 end if; 1529 end if; 1530 1531 end if; 1532 1533 return Result; 1534 end Is_Boolean_Logical_Op; 1535 1536 ---------------------------------- 1537 -- Is_Call_To_Operator_Function -- 1538 ---------------------------------- 1539 1540 function Is_Call_To_Operator_Function (El : Asis.Element) return Boolean is 1541 Pref : Asis.Element; 1542 Result : Boolean := False; 1543 begin 1544 1545 if Expression_Kind (El) = A_Function_Call then 1546 1547 if not Is_Prefix_Call (El) then 1548 Result := True; 1549 else 1550 Pref := Prefix (El); 1551 1552 if Expression_Kind (Pref) = A_Selected_Component then 1553 Pref := Selector (Pref); 1554 end if; 1555 1556 Result := Expression_Kind (Pref) = An_Operator_Symbol; 1557 1558 end if; 1559 1560 end if; 1561 1562 return Result; 1563 end Is_Call_To_Operator_Function; 1564 1565 --------------- 1566 -- Is_Caller -- 1567 --------------- 1568 1569-- function Is_Caller (El : Asis.Element) return Boolean is 1570-- Spec_El : Asis.Element; 1571-- Result : Boolean := False; 1572-- begin 1573-- -- Implementation is incomplete!!! ??? 1574-- -- Protected operations is a huge hole!!! 1575 1576-- case Flat_Element_Kind (El) is 1577-- when A_Procedure_Declaration | 1578-- A_Function_Declaration => 1579 1580-- Result := Trait_Kind (El) /= An_Abstract_Trait; 1581 1582-- when An_Entry_Body_Declaration => 1583 1584-- Result := True; 1585 1586-- when A_Procedure_Body_Declaration | 1587-- A_Function_Body_Declaration | 1588-- A_Procedure_Body_Stub | 1589-- A_Function_Body_Stub => 1590 1591-- Spec_El := El; 1592 1593-- if Is_Subunit (El) then 1594-- Spec_El := Corresponding_Body_Stub (El); 1595-- end if; 1596 1597-- Spec_El := Corresponding_Declaration (El); 1598 1599-- Result := 1600-- Declaration_Kind (Spec_El) not in 1601-- A_Generic_Procedure_Declaration .. 1602-- A_Generic_Function_Declaration; 1603 1604-- when An_Entry_Declaration => 1605 1606-- if Definition_Kind (Get_Enclosing_Element) = 1607-- A_Protected_Definition 1608-- then 1609-- Result := True; 1610-- end if; 1611 1612-- when others => 1613-- null; 1614-- end case; 1615 1616-- return Result; 1617-- end Is_Caller; 1618 1619 ----------------- 1620 -- Is_Constant -- 1621 ----------------- 1622 1623 function Is_Constant (E : Asis.Element) return Boolean is 1624 Result : Boolean := False; 1625 begin 1626 if Defining_Name_Kind (E) = A_Defining_Identifier then 1627 Result := Ekind (Node (E)) = E_Constant; 1628 end if; 1629 1630 return Result; 1631 end Is_Constant; 1632 1633 --------------------------------- 1634 -- Is_Constr_Error_Declaration -- 1635 --------------------------------- 1636 1637 function Is_Constr_Error_Declaration (Decl : Asis.Element) return Boolean is 1638 Result : Boolean := False; 1639 begin 1640 1641 if Declaration_Kind (Decl) = An_Exception_Declaration 1642 and then 1643 Is_Standard (Enclosing_Compilation_Unit (Decl)) 1644 and then 1645 Defining_Name_Image (First_Name (Decl)) = "Constraint_Error" 1646 then 1647 Result := True; 1648 end if; 1649 1650 return Result; 1651 end Is_Constr_Error_Declaration; 1652 1653 ------------------------- 1654 -- Is_Constraint_Error -- 1655 ------------------------- 1656 1657 function Is_Constraint_Error (Ref : Asis.Element) return Boolean is 1658 Next_Exception_Decl : Asis.Element; 1659 1660 Result : Boolean := False; 1661 begin 1662 Next_Exception_Decl := Corresponding_Name_Declaration (Ref); 1663 1664 while not Is_Nil (Next_Exception_Decl) loop 1665 1666 if Is_Constr_Error_Declaration (Next_Exception_Decl) then 1667 Result := True; 1668 exit; 1669 elsif Is_Num_Error_Declaration (Next_Exception_Decl) then 1670 exit; 1671 elsif Declaration_Kind (Next_Exception_Decl) = 1672 An_Exception_Renaming_Declaration 1673 then 1674 Next_Exception_Decl := Renamed_Entity (Next_Exception_Decl); 1675 Next_Exception_Decl := Normalize_Reference (Next_Exception_Decl); 1676 Next_Exception_Decl := 1677 Corresponding_Name_Declaration (Next_Exception_Decl); 1678 else 1679 exit; 1680 end if; 1681 1682 end loop; 1683 1684 return Result; 1685 end Is_Constraint_Error; 1686 1687 -------------------------- 1688 -- Is_Control_Structure -- 1689 -------------------------- 1690 1691 function Is_Control_Structure (Stmt : Asis.Element) return Boolean is 1692 Result : Boolean := False; 1693 begin 1694 1695 case Statement_Kind (Stmt) is 1696 when An_If_Statement | 1697 A_Case_Statement | 1698 A_Loop_Statement | 1699 A_While_Loop_Statement | 1700 A_For_Loop_Statement | 1701 A_Selective_Accept_Statement | 1702 A_Timed_Entry_Call_Statement | 1703 A_Conditional_Entry_Call_Statement | 1704 An_Asynchronous_Select_Statement => 1705 Result := True; 1706 when others => 1707 null; 1708 end case; 1709 1710 return Result; 1711 end Is_Control_Structure; 1712 1713 -------------- 1714 -- Is_Frame -- 1715 -------------- 1716 1717 function Is_Frame (El : Asis.Element) return Boolean is 1718 Result : Boolean := False; 1719 begin 1720 1721 case Flat_Element_Kind (El) is 1722 when A_Procedure_Body_Declaration | 1723 A_Function_Body_Declaration | 1724 A_Package_Body_Declaration | 1725 An_Entry_Body_Declaration | 1726 A_Task_Body_Declaration | 1727 A_Block_Statement | 1728 An_Extended_Return_Statement | 1729 An_Accept_Statement => 1730 1731 Result := True; 1732 when others => 1733 null; 1734 end case; 1735 1736 return Result; 1737 end Is_Frame; 1738 1739 ---------------------- 1740 -- Is_From_Standard -- 1741 ---------------------- 1742 1743 function Is_From_Standard (El : Asis.Element) return Boolean is 1744 Result : Boolean := False; 1745 begin 1746 1747 if not Is_Nil (El) then 1748 Result := Sloc (Node (El)) <= Standard_Location; 1749 end if; 1750 1751 return Result; 1752 end Is_From_Standard; 1753 1754 ----------------------------- 1755 -- Is_Function_Declaration -- 1756 ----------------------------- 1757 1758 function Is_Function_Declaration (El : Asis.Element) return Boolean is 1759 Result : Boolean := False; 1760 begin 1761 1762 case Declaration_Kind (El) is 1763 when A_Function_Declaration | 1764 A_Function_Body_Declaration | 1765 A_Function_Body_Stub | 1766 A_Function_Renaming_Declaration | 1767 A_Function_Instantiation | 1768 A_Formal_Function_Declaration | 1769 A_Generic_Function_Declaration => 1770 1771 Result := True; 1772 1773 when others => 1774 null; 1775 end case; 1776 1777 return Result; 1778 end Is_Function_Declaration; 1779 1780 --------------------- 1781 -- Is_Dynamic_Call -- 1782 --------------------- 1783 1784 function Is_Dynamic_Call (Call : Asis.Element) return Boolean is 1785 Tmp : Asis.Element; 1786 Result : Boolean := False; 1787 begin 1788 1789 if Expression_Kind (Call) = A_Function_Call then 1790 Tmp := Prefix (Call); 1791 else 1792 Tmp := Called_Name (Call); 1793 end if; 1794 1795 if Expression_Kind (Tmp) = An_Explicit_Dereference 1796 or else 1797 Is_True_Expression (Tmp) 1798 then 1799 -- If the prefix of a (procedure or function) call is a true 1800 -- expression that is, if it has a type, the only possibility for 1801 -- this prefix is to be of an access to procedure/function type, so 1802 Result := True; 1803 end if; 1804 1805 return Result; 1806 end Is_Dynamic_Call; 1807 1808 ------------------------------ 1809 -- Is_Enum_Literal_Renaming -- 1810 ------------------------------ 1811 1812 function Is_Enum_Literal_Renaming (El : Asis.Element) return Boolean is 1813 Result : Boolean := False; 1814 Renamed_Entity : Entity_Id; 1815 begin 1816 if Declaration_Kind (El) = A_Function_Renaming_Declaration then 1817 1818 Renamed_Entity := Sinfo.Name (Node (El)); 1819 Renamed_Entity := Entity (Renamed_Entity); 1820 1821 if Present (Renamed_Entity) 1822 and then 1823 Ekind (Renamed_Entity) = E_Enumeration_Literal 1824 then 1825 Result := True; 1826 end if; 1827 1828 end if; 1829 1830 return Result; 1831 end Is_Enum_Literal_Renaming; 1832 1833 -------------- 1834 -- Is_Float -- 1835 -------------- 1836 1837 function Is_Float (Expr : Asis.Element) return Boolean is 1838 Result : Boolean := False; 1839 Type_Entity : Entity_Id; 1840 begin 1841 1842 if Asis.Extensions.Is_True_Expression (Expr) then 1843 Type_Entity := Etype (R_Node (Expr)); 1844 Result := Ekind (Type_Entity) in Float_Kind; 1845 end if; 1846 1847 return Result; 1848 1849 end Is_Float; 1850 1851 ---------------- 1852 -- Is_Handled -- 1853 ---------------- 1854 1855 function Is_Handled 1856 (Exc : Asis.Element; 1857 By : Asis.Element_List) 1858 return Boolean 1859 is 1860 Exc_To_Catch : Asis.Element := Exc; 1861 Result : Boolean := False; 1862 Last_Handler : Boolean := True; 1863 begin 1864 1865 if By'Length > 0 then 1866 1867 if Declaration_Kind (Enclosing_Element (Exc_To_Catch)) = 1868 An_Exception_Renaming_Declaration 1869 then 1870 Exc_To_Catch := 1871 Get_Name_Definition 1872 (Renamed_Entity (Enclosing_Element (Exc_To_Catch))); 1873 end if; 1874 1875 Traverse_Handlers : for J in reverse By'Range loop 1876 1877 declare 1878 Handled_Excs : constant Asis.Element_List := 1879 Exception_Choices (By (J)); 1880 begin 1881 1882 if Last_Handler 1883 and then 1884 Definition_Kind (Handled_Excs (Handled_Excs'Last)) = 1885 An_Others_Choice 1886 then 1887 Result := True; 1888 exit Traverse_Handlers; 1889 end if; 1890 1891 Last_Handler := False; 1892 1893 for K in Handled_Excs'Range loop 1894 1895 if Is_Equal 1896 (Get_Name_Definition (Handled_Excs (K)), 1897 Exc_To_Catch) 1898 then 1899 Result := True; 1900 exit Traverse_Handlers; 1901 end if; 1902 1903 end loop; 1904 1905 end; 1906 1907 end loop Traverse_Handlers; 1908 1909 end if; 1910 1911 return Result; 1912 end Is_Handled; 1913 1914 ---------------- 1915 -- Is_Limited -- 1916 ---------------- 1917 1918 function Is_Limited (SM : Asis.Element) return Boolean is 1919 Type_Entity : Entity_Id; 1920 Result : Boolean := False; 1921 begin 1922 1923 case Expression_Kind (SM) is 1924 when An_Identifier | 1925 A_Selected_Component | 1926 An_Attribute_Reference => 1927 1928 Type_Entity := Etype (R_Node (SM)); 1929 1930 Result := 1931 Is_Limited_Type (Type_Entity) 1932 or else 1933 (Is_Interface (Type_Entity) 1934 and then 1935 Is_Limited_Interface (Type_Entity)); 1936 1937 when others => 1938 null; 1939 end case; 1940 1941 return Result; 1942 end Is_Limited; 1943 1944 ------------------------------ 1945 -- Is_Num_Error_Declaration -- 1946 ------------------------------ 1947 1948 function Is_Num_Error_Declaration (Decl : Asis.Element) return Boolean is 1949 Result : Boolean := False; 1950 begin 1951 1952 if Declaration_Kind (Decl) = An_Exception_Renaming_Declaration 1953 and then 1954 Is_Standard (Enclosing_Compilation_Unit (Decl)) 1955 and then 1956 Defining_Name_Image (First_Name (Decl)) = "Numeric_Error" 1957 then 1958 Result := True; 1959 end if; 1960 1961 return Result; 1962 end Is_Num_Error_Declaration; 1963 1964 ---------------------- 1965 -- Is_Numeric_Error -- 1966 ---------------------- 1967 1968 function Is_Numeric_Error (Ref : Asis.Element) return Boolean is 1969 Next_Exception_Decl : Asis.Element; 1970 1971 Result : Boolean := False; 1972 begin 1973 Next_Exception_Decl := Corresponding_Name_Declaration (Ref); 1974 1975 while not Is_Nil (Next_Exception_Decl) loop 1976 1977 if Is_Num_Error_Declaration (Next_Exception_Decl) then 1978 Result := True; 1979 exit; 1980 elsif Declaration_Kind (Next_Exception_Decl) = 1981 An_Exception_Renaming_Declaration 1982 then 1983 Next_Exception_Decl := Renamed_Entity (Next_Exception_Decl); 1984 Next_Exception_Decl := Normalize_Reference (Next_Exception_Decl); 1985 Next_Exception_Decl := 1986 Corresponding_Name_Declaration (Next_Exception_Decl); 1987 else 1988 exit; 1989 end if; 1990 1991 end loop; 1992 1993 return Result; 1994 end Is_Numeric_Error; 1995 1996 ------------------- 1997 -- Is_Positional -- 1998 ------------------- 1999 2000 function Is_Positional (El : Asis.Element) return Boolean is 2001 Result : Boolean := False; 2002 begin 2003 2004 if not Is_Normalized (El) then 2005 2006 case Association_Kind (El) is 2007 when A_Pragma_Argument_Association | 2008 A_Parameter_Association | 2009 A_Generic_Association => 2010 Result := Is_Nil (Formal_Parameter (El)); 2011 when A_Discriminant_Association => 2012 Result := Is_Nil (Discriminant_Selector_Names (El)); 2013 when A_Record_Component_Association => 2014 Result := Is_Nil (Record_Component_Choices (El)); 2015 when An_Array_Component_Association => 2016 Result := Is_Nil (Array_Component_Choices (El)); 2017 when others => 2018 null; 2019 end case; 2020 2021 end if; 2022 2023 return Result; 2024 end Is_Positional; 2025 2026 ------------------- 2027 -- Is_Predefined -- 2028 ------------------- 2029 2030 function Is_Predefined (Operation : Asis.Element) return Boolean is 2031 Tmp_Element : Asis.Element; 2032 Op_Entity : Entity_Id := Empty; 2033 Result : Boolean := False; 2034 begin 2035 2036 if Expression_Kind (Operation) = An_Operator_Symbol 2037 and then 2038 Is_Uniquely_Defined (Operation) 2039 then 2040 2041 Tmp_Element := Corresponding_Name_Definition (Operation); 2042 2043 if Is_Nil (Tmp_Element) then 2044 -- This also includes the case of "/=" implicitly declared by 2045 -- an explicit declaration of "=" 2046 2047 Tmp_Element := Enclosing_Element (Operation); 2048 2049 if Expression_Kind (Tmp_Element) = A_Selected_Component then 2050 Op_Entity := R_Node (Tmp_Element); 2051 else 2052 Op_Entity := R_Node (Operation); 2053 end if; 2054 2055 if Nkind (Op_Entity) = N_Raise_Constraint_Error then 2056 Op_Entity := Node (Operation); 2057 end if; 2058 2059 if Nkind (Op_Entity) = N_Function_Call then 2060 Op_Entity := Sinfo.Name (Op_Entity); 2061 end if; 2062 2063 Op_Entity := Entity (Op_Entity); 2064 2065 Result := Sloc (Op_Entity) = Standard_Location; 2066 2067 end if; 2068 end if; 2069 2070 return Result; 2071 2072 end Is_Predefined; 2073 2074 -------------------------- 2075 -- Is_Predefined_String -- 2076 -------------------------- 2077 2078 function Is_Predefined_String (Type_Decl : Asis.Element) return Boolean is 2079 Type_Entity : Entity_Id; 2080 Result : Boolean := False; 2081 begin 2082 2083 if Declaration_Kind (Type_Decl) = An_Ordinary_Type_Declaration 2084 or else 2085 Declaration_Kind (Type_Decl) = A_Subtype_Declaration 2086 then 2087 Type_Entity := R_Node (Names (Type_Decl) (1)); 2088 2089 while Etype (Type_Entity) /= Type_Entity loop 2090 Type_Entity := Etype (Type_Entity); 2091 end loop; 2092 2093 Result := Type_Entity = Stand.Standard_String; 2094 2095 end if; 2096 2097 return Result; 2098 2099 end Is_Predefined_String; 2100 2101 ---------------------------------- 2102 -- Is_Prefix_Notation_Exception -- 2103 ---------------------------------- 2104 2105 function Is_Prefix_Notation_Exception 2106 (El : Asis.Element; 2107 Exclude_Second_Par : Boolean) 2108 return Boolean 2109 is 2110 Call_Node : Node_Id; 2111 Par_Node : Node_Id; 2112 Firts_Par_Node : Node_Id; 2113 2114 Result : Boolean := False; 2115 begin 2116 Call_Node := Parent (R_Node (El)); 2117 2118 -- We can be sure, that El is a subprogram call that has at least one 2119 -- parameter, so Parameter_Associations (Call_Node) definitely presents. 2120 if List_Length (Parameter_Associations (Call_Node)) = 1 then 2121 Result := True; 2122 else 2123 Par_Node := R_Node (El); 2124 Firts_Par_Node := First (Parameter_Associations (Call_Node)); 2125 2126 if Par_Node = Firts_Par_Node then 2127 Result := True; 2128 elsif List_Length (Parameter_Associations (Call_Node)) = 2 2129 and then 2130 Exclude_Second_Par 2131 then 2132 Result := Par_Node = Next (Firts_Par_Node); 2133 end if; 2134 2135 end if; 2136 2137 return Result; 2138 end Is_Prefix_Notation_Exception; 2139 2140 --------------------------------- 2141 -- Is_Protected_Operation_Call -- 2142 --------------------------------- 2143 2144 function Is_Protected_Operation_Call (Call : Asis.Element) return Boolean is 2145 Tmp_Node : Node_Id; 2146 Result : Boolean := False; 2147 begin 2148 Tmp_Node := R_Node (Call); 2149 2150 if Nkind (Tmp_Node) = N_Entry_Call_Statement then 2151 Tmp_Node := Prefix (Sinfo.Name (Tmp_Node)); 2152 Tmp_Node := Etype (Tmp_Node); 2153 2154 if Ekind (Tmp_Node) in Private_Kind then 2155 Tmp_Node := Full_View (Tmp_Node); 2156 end if; 2157 2158 Result := Ekind (Tmp_Node) in Protected_Kind; 2159 end if; 2160 2161 return Result; 2162 end Is_Protected_Operation_Call; 2163 2164 ------------------------------------ 2165 -- Is_Ref_To_Standard_Num_Subtype -- 2166 ------------------------------------ 2167 2168 function Is_Ref_To_Standard_Num_Subtype 2169 (Ref : Asis.Element) 2170 return Boolean 2171 is 2172 Result : Boolean := False; 2173 Arg_Entity : Entity_Id; 2174 begin 2175 Arg_Entity := Node (Ref); 2176 2177 if Nkind (Arg_Entity) in N_Has_Entity then 2178 2179 if No (Entity (Arg_Entity)) 2180 and then 2181 Nkind (Parent (Arg_Entity)) = N_Expanded_Name 2182 and then 2183 Arg_Entity = Selector_Name (Parent (Arg_Entity)) 2184 then 2185 Arg_Entity := Parent (Arg_Entity); 2186 end if; 2187 2188 Arg_Entity := Entity (Arg_Entity); 2189 2190 if Present (Arg_Entity) 2191 and then 2192 Sloc (Arg_Entity) = Standard_Location 2193 and then 2194 Ekind (Arg_Entity) in Numeric_Kind 2195 then 2196 Result := True; 2197 end if; 2198 2199 end if; 2200 2201 return Result; 2202 2203 end Is_Ref_To_Standard_Num_Subtype; 2204 2205 --------------- 2206 -- Is_Public -- 2207 --------------- 2208 2209 function Is_Public (Def_Name : Asis.Element) return Boolean is 2210 Result : Boolean := False; 2211 begin 2212 2213 case Defining_Name_Kind (Def_Name) is 2214 when A_Defining_Identifier .. A_Defining_Operator_Symbol => 2215 Result := not Is_Hidden (Node (Def_Name)); 2216 when A_Defining_Expanded_Name => 2217 Result := not Is_Hidden (Node (Defining_Selector (Def_Name))); 2218 when others => 2219 null; 2220 end case; 2221 2222 return Result; 2223 end Is_Public; 2224 2225 ----------------- 2226 -- Is_Renaming -- 2227 ----------------- 2228 2229 function Is_Renaming (El : Asis.Element) return Boolean is 2230 Result : Boolean := False; 2231 begin 2232 -- A very simple test at the moment 2233 2234 case Flat_Element_Kind (El) is 2235 when A_Procedure_Renaming_Declaration | 2236 A_Function_Renaming_Declaration => 2237 Result := True; 2238 when others => 2239 null; 2240 end case; 2241 2242 return Result; 2243 end Is_Renaming; 2244 2245 ------------------------- 2246 -- Is_Standard_Boolean -- 2247 ------------------------- 2248 2249 function Is_Standard_Boolean (Expr : Asis.Element) return Boolean is 2250 Result : Boolean := False; 2251 Type_Entity : Entity_Id; 2252 begin 2253 2254 if Asis.Extensions.Is_True_Expression (Expr) then 2255 Type_Entity := Etype (R_Node (Expr)); 2256 2257 while Present (Type_Entity) 2258 and then 2259 Type_Entity /= Etype (Type_Entity) 2260 and then 2261 Ekind (Type_Entity) /= E_Enumeration_Type 2262 loop 2263 Type_Entity := Etype (Type_Entity); 2264 end loop; 2265 2266 Result := Type_Entity = Standard_Boolean; 2267 end if; 2268 2269 return Result; 2270 2271 end Is_Standard_Boolean; 2272 2273 ---------------------- 2274 -- Is_Task_Creation -- 2275 ---------------------- 2276 2277 function Is_Task_Creation (El : Asis.Element) return Boolean is 2278 Arg_Kind : constant Flat_Element_Kinds := Flat_Element_Kind (El); 2279 Result : Boolean := False; 2280 begin 2281 2282 case Arg_Kind is 2283 when A_Variable_Declaration | 2284 A_Constant_Declaration => 2285 Result := Is_Task_Object_Declaration (El); 2286 when A_Single_Task_Declaration => 2287 Result := True; 2288 when others => 2289 null; 2290 end case; 2291 2292 return Result; 2293 end Is_Task_Creation; 2294 2295 ------------------------ 2296 -- Is_Task_Entry_Call -- 2297 ------------------------ 2298 2299 function Is_Task_Entry_Call (Call : Asis.Element) return Boolean is 2300 Pref_Node : Node_Id; 2301 Pref_Type_Node : Entity_Id; 2302 Result : Boolean := False; 2303 begin 2304 2305 if Statement_Kind (Call) = An_Entry_Call_Statement then 2306 Pref_Node := Node (Called_Name (Call)); 2307 2308 if Nkind (Pref_Node) = N_Indexed_Component then 2309 -- Call to an entry from an entrty family 2310 Pref_Node := Prefix (Pref_Node); 2311 end if; 2312 2313 Pref_Type_Node := Etype (Pref_Node); 2314 2315 if (No (Pref_Type_Node) 2316 or else 2317 Ekind (Pref_Type_Node) = E_Void) 2318 and then 2319 Nkind (Pref_Node) = N_Selected_Component 2320 then 2321 Pref_Node := Sinfo.Prefix (Pref_Node); 2322 Pref_Type_Node := Etype (Pref_Node); 2323 end if; 2324 2325 if Present (Pref_Type_Node) 2326 and then 2327 Ekind (Pref_Type_Node) in 2328 E_Private_Type | 2329 E_Private_Subtype | 2330 E_Limited_Private_Type | 2331 E_Limited_Private_Subtype 2332 then 2333 Pref_Type_Node := Full_View (Pref_Type_Node); 2334 end if; 2335 2336 Result := Ekind (Pref_Type_Node) in Task_Kind; 2337 end if; 2338 2339 return Result; 2340 end Is_Task_Entry_Call; 2341 2342 -------------------------------- 2343 -- Is_Task_Object_Declaration -- 2344 -------------------------------- 2345 2346 function Is_Task_Object_Declaration (Expr : Asis.Element) return Boolean is 2347 N : Node_Id; 2348 Result : Boolean := False; 2349 begin 2350 2351 case Flat_Element_Kind (Expr) is 2352 when A_Variable_Declaration | 2353 A_Constant_Declaration => 2354 2355 N := Defining_Identifier (R_Node (Expr)); 2356 N := Etype (N); 2357 2358 Result := Ekind (N) in Task_Kind; 2359 when others => 2360 null; 2361 end case; 2362 2363 return Result; 2364 end Is_Task_Object_Declaration; 2365 2366 ------------------------ 2367 -- Is_Template_Caller -- 2368 ------------------------ 2369 2370 function Is_Template_Caller (El : Asis.Element) return Boolean is 2371 Result : Boolean := False; 2372 begin 2373 case Flat_Element_Kind (El) is 2374 when A_Task_Type_Declaration => 2375 Result := True; 2376 when others => 2377 null; 2378 end case; 2379 2380 return Result; 2381 end Is_Template_Caller; 2382 2383 ---------------------------- 2384 -- Is_Unconstrained_Array -- 2385 ---------------------------- 2386 2387 function Is_Unconstrained_Array (Type_Decl : Asis.Element) return Boolean is 2388 Type_Entity : Entity_Id; 2389 Result : Boolean := False; 2390 begin 2391 2392 if Declaration_Kind (Type_Decl) = An_Ordinary_Type_Declaration 2393 or else 2394 Declaration_Kind (Type_Decl) = A_Subtype_Declaration 2395 then 2396 Type_Entity := R_Node (Names (Type_Decl) (1)); 2397 2398 if Is_Array_Type (Type_Entity) 2399 and then 2400 not Is_Constrained (Type_Entity) 2401 then 2402 Result := True; 2403 end if; 2404 2405 end if; 2406 2407 return Result; 2408 2409 end Is_Unconstrained_Array; 2410 2411 -------------------------- 2412 -- Look_For_Loop_Pre_Op -- 2413 -------------------------- 2414 2415 procedure Look_For_Loop_Pre_Op 2416 (Element : Asis.Element; 2417 Control : in out Traverse_Control; 2418 State : in out Boolean) 2419 is 2420 begin 2421 2422 case Element_Kind (Element) is 2423 when A_Statement => 2424 2425 case Statement_Kind (Element) is 2426 when An_If_Statement | 2427 A_Case_Statement | 2428 A_Block_Statement | 2429 An_Extended_Return_Statement | 2430 An_Accept_Statement | 2431 A_Selective_Accept_Statement | 2432 A_Timed_Entry_Call_Statement | 2433 A_Conditional_Entry_Call_Statement | 2434 An_Asynchronous_Select_Statement => 2435 null; 2436 when A_Loop_Statement | 2437 A_While_Loop_Statement | 2438 A_For_Loop_Statement => 2439 2440 State := True; 2441 Control := Terminate_Immediately; 2442 2443 when others => 2444 Control := Abandon_Children; 2445 end case; 2446 2447 when A_Path => 2448 null; 2449 when others => 2450 Control := Abandon_Children; 2451 end case; 2452 2453 end Look_For_Loop_Pre_Op; 2454 2455 ---------------------- 2456 -- Needs_Completion -- 2457 ---------------------- 2458 2459 function Needs_Completion (El : Asis.Element) return Boolean is 2460 Arg_Kind : constant Flat_Element_Kinds := Flat_Element_Kind (El); 2461 Result : Boolean := False; 2462 Entity_N : Entity_Id; 2463 begin 2464 2465 case Arg_Kind is 2466 when A_Task_Type_Declaration | 2467 A_Protected_Type_Declaration | 2468 A_Single_Task_Declaration | 2469 A_Single_Protected_Declaration | 2470 A_Procedure_Body_Stub | 2471 A_Function_Body_Stub | 2472 A_Package_Body_Stub | 2473 A_Task_Body_Stub | 2474 A_Protected_Body_Stub => 2475 Result := True; 2476 2477 when A_Package_Declaration | 2478 A_Generic_Package_Declaration => 2479 2480 -- Now we make the check for library packages only! 2481 2482 if Is_Nil (Enclosing_Element (El)) then 2483 Result := 2484 Asis.Compilation_Units.Is_Body_Required 2485 (Enclosing_Compilation_Unit (El)); 2486 end if; 2487 2488 when A_Generic_Procedure_Declaration | 2489 A_Generic_Function_Declaration | 2490 A_Procedure_Declaration | 2491 A_Function_Declaration => 2492 2493 Entity_N := Defining_Unit_Name (Specification (Node (El))); 2494 2495 if Nkind (Entity_N) = N_Defining_Program_Unit_Name then 2496 Entity_N := Defining_Identifier (Entity_N); 2497 end if; 2498 2499 if not (Is_Intrinsic_Subprogram (Entity_N) 2500 or else 2501 Is_Imported (Entity_N)) 2502 then 2503 Result := True; 2504 end if; 2505 2506 when others => 2507 null; 2508 end case; 2509 2510 return Result; 2511 end Needs_Completion; 2512 2513 ---------------------- 2514 -- Raises_Exception -- 2515 ---------------------- 2516 2517 function Raises_Exception (El : Asis.Element) return Boolean is 2518 Result : Boolean := False; 2519 First_Handler : Boolean := Element_Kind (El) = An_Exception_Handler; 2520 First_Body_Decl : Boolean := 2521 Declaration_Kind (El) in 2522 A_Procedure_Body_Declaration .. A_Function_Body_Declaration; 2523 2524 procedure Check_Construct 2525 (Element : Asis.Element; 2526 Control : in out Traverse_Control; 2527 State : in out Boolean); 2528 -- Checks if we have a raise statement or a construct that should be 2529 -- skipped in the analysis; 2530 procedure No_Op 2531 (Element : Asis.Element; 2532 Control : in out Traverse_Control; 2533 State : in out Boolean); 2534 2535 procedure Check_For_Raise_Statement is new Traverse_Element 2536 (Pre_Operation => Check_Construct, 2537 Post_Operation => No_Op, 2538 State_Information => Boolean); 2539 2540 Control : Traverse_Control := Continue; 2541 2542 procedure Check_Construct 2543 (Element : Asis.Element; 2544 Control : in out Traverse_Control; 2545 State : in out Boolean) 2546 is 2547 begin 2548 case Element_Kind (Element) is 2549 when A_Declaration => 2550 2551 case Declaration_Kind (Element) is 2552 when A_Procedure_Body_Declaration | 2553 A_Function_Body_Declaration => 2554 2555 if First_Body_Decl then 2556 First_Body_Decl := False; 2557 else 2558 Control := Abandon_Children; 2559 end if; 2560 2561 when others => 2562 Control := Abandon_Children; 2563 end case; 2564 2565 when A_Statement => 2566 if Statement_Kind (Element) = A_Raise_Statement then 2567 State := True; 2568 Control := Terminate_Immediately; 2569 end if; 2570 when A_Path => 2571 null; 2572 when An_Exception_Handler => 2573 if First_Handler then 2574 First_Handler := False; 2575 else 2576 Control := Abandon_Children; 2577 end if; 2578 2579 when others => 2580 Control := Abandon_Children; 2581 end case; 2582 end Check_Construct; 2583 2584 procedure No_Op 2585 (Element : Asis.Element; 2586 Control : in out Traverse_Control; 2587 State : in out Boolean) 2588 is 2589 begin 2590 null; 2591 end No_Op; 2592 2593 begin 2594 Check_For_Raise_Statement (El, Control, Result); 2595 2596 return Result; 2597 end Raises_Exception; 2598 2599 ------------------------------------- 2600 -- Storage_Order_Defined_By_Pragma -- 2601 ------------------------------------- 2602 2603 function Storage_Order_Defined_By_Pragma 2604 (E : Asis.Element) 2605 return Boolean 2606 is 2607 Type_Entity : Entity_Id; 2608 Next_Pragma : Node_Id; 2609 Pragma_Arg : Node_Id; 2610 Result : Boolean := False; 2611 begin 2612 Type_Entity := R_Node (E); 2613 Next_Pragma := Next (Type_Entity); 2614 Type_Entity := Defining_Identifier (Type_Entity); 2615 2616 while Present (Next_Pragma) loop 2617 if Nkind (Next_Pragma) = N_Attribute_Definition_Clause 2618 and then 2619 Is_Rewrite_Substitution (Next_Pragma) 2620 and then 2621 Nkind (Original_Node (Next_Pragma)) = N_Pragma 2622 and then 2623 Chars (Next_Pragma) = Name_Scalar_Storage_Order 2624 then 2625 Pragma_Arg := Sinfo.Name (Next_Pragma); 2626 2627 if Nkind (Pragma_Arg) = N_Identifier 2628 and then 2629 Entity (Pragma_Arg) = Type_Entity 2630 then 2631 Result := True; 2632 exit; 2633 end if; 2634 end if; 2635 2636 Next_Pragma := Next (Next_Pragma); 2637 end loop; 2638 2639 return Result; 2640 end Storage_Order_Defined_By_Pragma; 2641 2642 ------------------------------- 2643 -- Used_To_Pass_Actual_Subpr -- 2644 ------------------------------- 2645 2646 function Used_To_Pass_Actual_Subpr (El : Asis.Element) return Boolean is 2647 Result : Boolean := False; 2648 begin 2649 2650 if Declaration_Kind (El) in A_Procedure_Renaming_Declaration .. 2651 A_Function_Renaming_Declaration 2652 then 2653 Result := Pass_Generic_Actual (Node (El)); 2654 end if; 2655 2656 return Result; 2657 end Used_To_Pass_Actual_Subpr; 2658 2659end Gnatcheck.ASIS_Utilities; 2660