1------------------------------------------------------------------------------ 2-- -- 3-- ASIS-for-GNAT IMPLEMENTATION COMPONENTS -- 4-- -- 5-- A 4 G . A _ S E M -- 6-- -- 7-- B o d y -- 8-- -- 9-- Copyright (C) 1995-2015, Free Software Foundation, Inc. -- 10-- -- 11-- ASIS-for-GNAT 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. ASIS-for-GNAT is distributed in the hope that it will be -- 15-- useful, but WITHOUT ANY WARRANTY; without even the implied warranty of -- 16-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. -- 17-- -- 18-- -- 19-- -- 20-- -- 21-- -- 22-- You should have received a copy of the GNU General Public License and -- 23-- a copy of the GCC Runtime Library Exception distributed with GNAT; see -- 24-- the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- 25-- <http://www.gnu.org/licenses/>. -- 26-- -- 27-- ASIS-for-GNAT was originally developed by the ASIS-for-GNAT team at the -- 28-- Software Engineering Laboratory of the Swiss Federal Institute of -- 29-- Technology (LGL-EPFL) in Lausanne, Switzerland, in cooperation with the -- 30-- Scientific Research Computer Center of Moscow State University (SRCC -- 31-- MSU), Russia, with funding partially provided by grants from the Swiss -- 32-- National Science Foundation and the Swiss Academy of Engineering -- 33-- Sciences. ASIS-for-GNAT is now maintained by AdaCore -- 34-- (http://www.adacore.com). -- 35-- -- 36------------------------------------------------------------------------------ 37 38pragma Ada_2012; 39 40with Asis.Declarations; use Asis.Declarations; 41with Asis.Elements; use Asis.Elements; 42with Asis.Expressions; use Asis.Expressions; 43with Asis.Extensions; use Asis.Extensions; 44with Asis.Iterator; use Asis.Iterator; 45 46with Asis.Set_Get; use Asis.Set_Get; 47 48with A4G.A_Types; use A4G.A_Types; 49with A4G.Contt.TT; use A4G.Contt.TT; use A4G.Contt; 50with A4G.Contt.UT; use A4G.Contt.UT; 51with A4G.Mapping; use A4G.Mapping; 52 53with Aspects; 54with Atree; use Atree; 55with Namet; use Namet; 56with Nlists; use Nlists; 57with Sem_Aux; use Sem_Aux; 58with Sinfo; use Sinfo; 59with Sinput; use Sinput; 60with Snames; use Snames; 61 62package body A4G.A_Sem is 63 64 ---------------------- 65 -- Local subprogram -- 66 ---------------------- 67 68 function Is_Importing_Pragma 69 (N : Node_Id; 70 For_Name : Name_Id) 71 return Boolean; 72 -- Checks if N is a node representing Import or Interface pragma that 73 -- is applied to the name For_Name 74 75 ----------------------------- 76 -- Belongs_To_Limited_View -- 77 ----------------------------- 78 79 function Belongs_To_Limited_View (Decl : Asis.Element) return Boolean is 80 Result : Boolean := False; 81 begin 82 case Declaration_Kind (Decl) is 83 when An_Ordinary_Type_Declaration | 84 A_Task_Type_Declaration | 85 A_Protected_Type_Declaration | 86 An_Incomplete_Type_Declaration | 87 A_Tagged_Incomplete_Type_Declaration | 88 A_Private_Type_Declaration | 89 A_Private_Extension_Declaration | 90 A_Package_Declaration => 91 Result := True; 92 when others => 93 null; 94 end case; 95 96 return Result; 97 end Belongs_To_Limited_View; 98 99 ------------------------------ 100 -- Char_Defined_In_Standard -- 101 ------------------------------ 102 103 function Char_Defined_In_Standard (N : Node_Id) return Boolean is 104 N_Etype : Node_Id; 105 begin 106 N_Etype := Etype (N); 107 108 if No (N_Etype) then 109 -- It may happen for array literal rewritten into a string literal, 110 -- so some additional digging is needed 111 N_Etype := Parent (N); 112 113 if Nkind (N_Etype) = N_String_Literal then 114 N_Etype := Etype (N_Etype); 115 116 if Ekind (N_Etype) = E_String_Literal_Subtype then 117 N_Etype := Component_Type (N_Etype); 118 end if; 119 120 else 121 N_Etype := Empty; 122 end if; 123 124 end if; 125 126 return Present (N_Etype) and then 127 Sloc (N_Etype) <= Standard_Location; 128 end Char_Defined_In_Standard; 129 130 ------------------------- 131 -- Char_Needs_Charcode -- 132 ------------------------- 133 134 function Char_Needs_Charcode (N : Node_Id) return Boolean is 135 N_Etype : Node_Id; 136 begin 137 N_Etype := Etype (N); 138 139 if No (N_Etype) then 140 -- It may happen for array literal rewritten into a string literal, 141 -- so some additional digging is needed 142 N_Etype := Parent (N); 143 144 if Nkind (N_Etype) = N_String_Literal then 145 N_Etype := Etype (N_Etype); 146 147 if Ekind (N_Etype) = E_String_Literal_Subtype then 148 N_Etype := Component_Type (N_Etype); 149 end if; 150 151 else 152 N_Etype := Empty; 153 end if; 154 155 end if; 156 157 if Present (N_Etype) then 158 while Etype (N_Etype) /= N_Etype loop 159 N_Etype := Etype (N_Etype); 160 end loop; 161 end if; 162 163 return Present (N_Etype) and then 164 Sloc (N_Etype) <= Standard_Location; 165 end Char_Needs_Charcode; 166 167 ------------------------ 168 -- Corr_Decl_For_Stub -- 169 ------------------------ 170 171 function Corr_Decl_For_Stub (Stub_Node : Node_Id) return Node_Id is 172 Result_Node : Node_Id := Empty; 173 Stub_Entity_Node : Node_Id; 174 Scope_Node : Node_Id; 175 Search_Node : Node_Id; 176 Search_Node_Kind : Node_Kind; 177 List_To_Search : List_Id; 178 Search_In_Package : Boolean; 179 Decl_Found : Boolean := False; 180 Priv_Decl_Passed : Boolean := False; 181 Body_Passed : Boolean := False; 182 183 procedure Search_In_List; 184 -- looks for a possible subprogram declaration node for which 185 -- the given stub is a completion, using global settings for 186 -- List_To_Search and Search_Node 187 188 function Is_Spec_For_Stub 189 (Search_Node : Node_Id; 190 Stub_Node : Node_Id; 191 Stub_Entity_Node : Node_Id) 192 return Boolean; 193 -- check if the current Search_Node is a corresponding definition 194 -- for a given stub. We cannot directly use the Corresponding_Body 195 -- field here, because in case when subunits are around, this field 196 -- will point to a proper body of a subunit, but not to a stub 197 -- This function is called only for those nodes for which 198 -- Corresponding_Body field makes sense 199 200 function Is_Spec_For_Stub 201 (Search_Node : Node_Id; 202 Stub_Node : Node_Id; 203 Stub_Entity_Node : Node_Id) 204 return Boolean 205 is 206 Corr_Body_Node : constant Node_Id := Corresponding_Body (Search_Node); 207 N : Node_Id; 208 begin 209 210 if Corr_Body_Node = Stub_Entity_Node then 211 return True; 212 else 213 -- we have to check if we are in the proper body of a subunit 214 N := Parent (Corr_Body_Node); 215 216 if Nkind (N) = N_Procedure_Specification or else 217 Nkind (N) = N_Function_Specification 218 then 219 N := Parent (N); 220 end if; 221 222 N := Parent (N); 223 -- now, in case of subunit's parent body, we should be in 224 -- N_Subunit node 225 226 if Nkind (N) = N_Subunit then 227 return Corresponding_Stub (N) = Stub_Node; 228 else 229 return False; 230 end if; 231 232 end if; 233 234 end Is_Spec_For_Stub; 235 236 procedure Search_In_List is 237 begin 238 239 while Present (Search_Node) loop 240 Search_Node_Kind := Nkind (Search_Node); 241 242 if (Search_Node_Kind = N_Subprogram_Declaration or else 243 Search_Node_Kind = N_Generic_Subprogram_Declaration or else 244 Search_Node_Kind = N_Package_Declaration or else 245 Search_Node_Kind = N_Generic_Package_Declaration or else 246 Search_Node_Kind = N_Single_Task_Declaration or else 247 Search_Node_Kind = N_Task_Type_Declaration or else 248 Search_Node_Kind = N_Single_Protected_Declaration or else 249 Search_Node_Kind = N_Protected_Type_Declaration) 250 and then 251 Is_Spec_For_Stub (Search_Node, Stub_Node, Stub_Entity_Node) 252 -- ???Corresponding_Body (Search_Node) = Stub_Entity_Node 253 then 254 -- the corresponding declaration for the stub is found 255 Result_Node := Search_Node; 256 Decl_Found := True; 257 258 return; 259 260 elsif Search_Node = Stub_Node then 261 -- no need to search any mode, no declaration exists, 262 -- the stub itself works as a declaration 263 Decl_Found := True; 264 265 return; 266 267 end if; 268 269 Search_Node := Next_Non_Pragma (Search_Node); 270 end loop; 271 272 end Search_In_List; 273 274 begin -- Corr_Decl_For_Stub 275 276 -- first, setting Stub_Entity_Node: 277 if Nkind (Stub_Node) = N_Subprogram_Body_Stub then 278 Stub_Entity_Node := Defining_Unit_Name (Specification (Stub_Node)); 279 else 280 Stub_Entity_Node := Defining_Identifier (Stub_Node); 281 end if; 282 283 -- then, defining the scope node and list to search in: 284 Scope_Node := Scope (Stub_Entity_Node); 285 286 if No (Scope_Node) then 287 -- Unfortunately, this is the case for stubs of generic units 288 -- with no (non-generic) parameters 289 Scope_Node := Stub_Entity_Node; 290 291 while not (Nkind (Scope_Node) = N_Package_Body or else 292 Nkind (Scope_Node) = N_Subprogram_Body) 293 loop 294 Scope_Node := Parent (Scope_Node); 295 end loop; 296 297 if Nkind (Scope_Node) = N_Package_Body then 298 Scope_Node := Corresponding_Spec (Scope_Node); 299 else 300 Scope_Node := Defining_Unit_Name (Specification (Scope_Node)); 301 end if; 302 303 end if; 304 305 if Ekind (Scope_Node) = E_Generic_Package or else 306 Ekind (Scope_Node) = E_Package 307 then 308 Search_In_Package := True; 309 Scope_Node := Parent (Scope_Node); 310 311 if Nkind (Scope_Node) = N_Defining_Program_Unit_Name then 312 -- we are in a child library package 313 Scope_Node := Parent (Scope_Node); 314 end if; 315 316 -- now we are in the package spec 317 List_To_Search := Visible_Declarations (Scope_Node); 318 319 if No (List_To_Search) then 320 List_To_Search := Private_Declarations (Scope_Node); 321 Priv_Decl_Passed := True; 322 323 if No (List_To_Search) then 324 List_To_Search := List_Containing (Stub_Node); 325 -- what else could it be? 326 Body_Passed := True; 327 end if; 328 329 end if; 330 331 else 332 333 Search_In_Package := False; 334 List_To_Search := List_Containing (Stub_Node); 335 336 -- The following code was here for many years, but it seems that the 337 -- only effect of this conditional processing is failures in case 338 -- if we have a stub following the corresponding declaration in the 339 -- body of library generic subprogram. We keep it commented out just 340 -- in case. 341 342-- -- The situation of the stub for generic subprogram having 343-- -- (non-generic) parameters makes a special case: 344-- if Ekind (Scope_Node) in Generic_Unit_Kind 345-- and then 346-- Corresponding_Stub (Parent (Parent (Parent (Corresponding_Body 347-- (Parent (Parent (Scope_Node))))))) = 348-- Stub_Node 349-- then 350-- return Parent (Parent (Scope_Node)); 351-- else 352-- Search_In_Package := False; 353-- List_To_Search := List_Containing (Stub_Node); 354-- end if; 355 356 end if; 357 358 Search_Node := First_Non_Pragma (List_To_Search); 359 Search_In_List; 360 361 -- now, if we are in a package, and if we have not found the result 362 -- (or passed the stub node), we have to continue: 363 364 if Search_In_Package and then not Decl_Found then 365 -- where should we continue the search? 366 367 if not Priv_Decl_Passed then 368 List_To_Search := Private_Declarations (Scope_Node); 369 Priv_Decl_Passed := True; 370 371 if No (List_To_Search) then 372 List_To_Search := List_Containing (Stub_Node); 373 Body_Passed := True; 374 end if; 375 376 elsif not Body_Passed then 377 List_To_Search := List_Containing (Stub_Node); 378 Body_Passed := True; 379 end if; 380 381 Search_Node := First_Non_Pragma (List_To_Search); 382 Search_In_List; 383 384 if not Decl_Found then 385 -- if we are here, we have to search the package body, 386 -- where the stub itself is 387 List_To_Search := List_Containing (Stub_Node); 388 Search_Node := First_Non_Pragma (List_To_Search); 389 Search_In_List; 390 end if; 391 392 end if; 393 394 return Result_Node; 395 396 end Corr_Decl_For_Stub; 397 398 ------------------------- 399 -- Defined_In_Standard -- 400 ------------------------- 401 402 function Defined_In_Standard (N : Node_Id) return Boolean is 403 N_Entity : Node_Id := Empty; 404 N_Etype : Node_Id := Empty; 405 Result : Boolean := False; 406 begin 407 408 if Nkind (N) in N_Has_Entity then 409 N_Entity := Entity (N); 410 elsif Nkind (N) in Sinfo.N_Entity then 411 N_Entity := N; 412 end if; 413 414 if Present (N_Entity) then 415 N_Etype := Etype (N_Entity); 416 end if; 417 418 Result := 419 Present (N_Entity) and then 420 Present (N_Etype) and then 421 Sloc (N_Entity) <= Standard_Location and then 422 Sloc (N_Etype) <= Standard_Location; 423 424 return Result; 425 end Defined_In_Standard; 426 427 -------------------- 428 -- Entity_Present -- 429 -------------------- 430 431 function Entity_Present (N : Node_Id) return Boolean is 432 Result : Boolean := Present (Entity (N)); 433 begin 434 if Result then 435 Result := Nkind (Entity (N)) in N_Entity; 436 end if; 437 438 return Result; 439 end Entity_Present; 440 441 -------------------------------- 442 -- Explicit_Parent_Subprogram -- 443 -------------------------------- 444 445 function Explicit_Parent_Subprogram (E : Entity_Id) return Entity_Id is 446 Result : Entity_Id := Empty; 447 E_Ekind : constant Entity_Kind := Ekind (E); 448 Parent_Type : Entity_Id; 449 Tmp_Res : Entity_Id; 450 begin 451 452 -- The problem here is that we can not just traverse the Alias chain, 453 -- because in case if the parent subprogram is declared by the 454 -- subprogram renaming and the renamed entity is an intrinsic 455 -- subprogram, the Alias field of the derived subprogram will 456 -- point not to the parent renaming declaration, but to this 457 -- intrinsic subprogram (see F407-016). 458 459 if Is_Intrinsic_Subprogram (E) 460 and then 461 Present (Alias (E)) 462 and then 463 Defined_In_Standard (Alias (E)) 464 then 465 -- Here we may have a renaming declaration, and the renamed entity 466 -- is a predefined operation. So we have to traverse the derivation 467 -- chain and to try to locate the explicit renaming that is the cause 468 -- of the existing of this derived subprogram. 469 470 Parent_Type := Etype (E); 471 Parent_Type := Etype (Parent_Type); 472 Parent_Type := Parent (Parent_Type); 473 Parent_Type := Defining_Identifier (Parent_Type); 474 475 -- Here we should have Parent_Type pointing to the entity of the 476 -- parent type 477 478 Tmp_Res := Next_Entity (Parent_Type); 479 480 while Present (Tmp_Res) loop 481 482 if Ekind (Tmp_Res) = E_Ekind 483 and then 484 Is_Intrinsic_Subprogram (Tmp_Res) 485 and then 486 Chars (Tmp_Res) = Chars (E) 487 and then 488 Alias (Tmp_Res) = Alias (E) 489 then 490 Result := Tmp_Res; 491 exit; 492 end if; 493 494 Tmp_Res := Next_Entity (Tmp_Res); 495 end loop; 496 497 if Present (Result) 498 and then 499 not Comes_From_Source (Result) 500 then 501 Result := Explicit_Parent_Subprogram (Result); 502 end if; 503 504 else 505 Result := Alias (E); 506 507 while Present (Alias (Result)) 508 and then 509 not Comes_From_Source (Result) 510 loop 511 Result := Alias (Result); 512 end loop; 513 end if; 514 515 return Result; 516 end Explicit_Parent_Subprogram; 517 518 -------------------------- 519 -- Get_Actual_Type_Name -- 520 -------------------------- 521 522 function Get_Actual_Type_Name (Type_Mark_Node : Node_Id) return Node_Id is 523 Result : Node_Id := Type_Mark_Node; 524 Tmp_Node : Node_Id; 525 begin 526 527 if Is_From_Instance (Type_Mark_Node) then 528 Tmp_Node := Entity (Type_Mark_Node); 529 530 if Present (Tmp_Node) 531 and then 532 Ekind (Tmp_Node) in Einfo.Type_Kind 533 then 534 Tmp_Node := Parent (Tmp_Node); 535 end if; 536 537 if Nkind (Tmp_Node) = N_Subtype_Declaration 538 and then 539 not Is_Rewrite_Substitution (Tmp_Node) 540 and then 541 not Comes_From_Source (Tmp_Node) 542 then 543 Result := Sinfo.Subtype_Indication (Tmp_Node); 544 -- In case of nested instantiations, we have to traverse 545 -- the chain of subtype declarations created by the compiler 546 -- for actual types 547 while Is_From_Instance (Result) 548 and then 549 Nkind (Parent (Entity (Result))) = N_Subtype_Declaration 550 and then 551 not Comes_From_Source (Parent (Entity (Result))) 552 loop 553 Result := Parent (Entity (Result)); 554 555 if Is_Rewrite_Substitution (Result) then 556 -- The case when the actual type is a derived type. Here 557 -- the chain of subtypes leads to the artificial internal 558 -- type created by the compiler, but not to the actual type 559 -- (8924-006) 560 Result := Sinfo.Defining_Identifier (Result); 561 562 while Present (Homonym (Result)) loop 563 Result := Homonym (Result); 564 end loop; 565 566 exit; 567 568 end if; 569 570 Result := Sinfo.Subtype_Indication (Result); 571 end loop; 572 573 end if; 574 575 end if; 576 577 return Result; 578 579 end Get_Actual_Type_Name; 580 581 ---------------------------- 582 -- Get_Corr_Called_Entity -- 583 ---------------------------- 584 585 function Get_Corr_Called_Entity 586 (Call : Asis.Element) 587 return Asis.Declaration 588 is 589 Arg_Node : Node_Id; 590 Arg_Node_Kind : Node_Kind; 591 Result_Node : Node_Id; 592 Result_Unit : Compilation_Unit; 593 Special_Case : Special_Cases := Not_A_Special_Case; 594 Result_Kind : Internal_Element_Kinds := Not_An_Element; 595 Inherited : Boolean := False; 596 Res_Node_Field_1 : Node_Id := Empty; 597 Tmp_Node : Node_Id; 598 Is_Call_To_Implicit_Neq : Boolean := False; 599 600 Result_El : Asis.Element; 601 begin 602 603 -- The general implementation approach is: 604 -- 605 -- 1. First, we try to define Result_Node as pointing to the tree 606 -- node on which the resulting ASIS Element should be based. 607 -- During this step Arg_Node is also set (and probably adjusted) 608 -- 609 -- 2. If the result looks like representing an Ada implicit construct 610 -- (for now the main and the only check is 611 -- Comes_From_Source (Result_Node)), at the second step we 612 -- form the representation of the implicit inherited user-defined 613 -- subprogram by setting Result_Node pointing to the explicit 614 -- declaration of the subprogram being inherited, and 615 -- Res_Node_Field_1 pointing to the defining identifier node 616 -- corresponding to the given implicit subprogram. Note, that 617 -- at the moment implicit predefined operations are not 618 -- implemented. 619 -- 620 -- 3. On the last step we compute additional attributes of the 621 -- resulting Element. 622 623 ------------------------------------------------------------------ 624 -- 1. Defining Result_Node (and adjusting Arg_Node, if needed) -- 625 ------------------------------------------------------------------ 626 627 Arg_Node := R_Node (Call); 628 Arg_Node_Kind := Nkind (Arg_Node); 629 Tmp_Node := Node (Call); 630 -- Rewritten node should know everything. But if in case of a function 631 -- call this node is the result of compile-time optimization, 632 -- we have to work with original node only: 633 634 if Arg_Node_Kind = N_String_Literal or else 635 Arg_Node_Kind = N_Integer_Literal or else 636 Arg_Node_Kind = N_Real_Literal or else 637 Arg_Node_Kind = N_Character_Literal or else 638 Arg_Node_Kind = N_Raise_Constraint_Error or else 639 Arg_Node_Kind = N_Raise_Program_Error or else 640 Arg_Node_Kind = N_If_Expression or else 641 Arg_Node_Kind = N_Explicit_Dereference or else 642 Arg_Node_Kind = N_Type_Conversion or else 643 Arg_Node_Kind = N_Unchecked_Type_Conversion or else 644 Arg_Node_Kind = N_Identifier or else 645 (Arg_Node_Kind in N_Op 646 and then 647 (Nkind (Tmp_Node) = N_Function_Call 648 or else 649 (Nkind (Tmp_Node) in N_Op 650 and then 651 Entity_Present (Tmp_Node) 652 and then 653 (Pass_Generic_Actual (Parent (Parent ((Entity (Tmp_Node))))))))) 654 then 655 Arg_Node := Node (Call); 656 Arg_Node_Kind := Nkind (Arg_Node); 657 end if; 658 659 case Arg_Node_Kind is 660 661 when N_Attribute_Reference => 662 663 return Nil_Element; 664 665 -- call to a procedure-attribute or to a function-attribute 666 -- but in case when a representation clause was applied 667 -- to define stream IOU attributes, we can return something 668 -- more interesting, then Nil_Element, see the corresponding 669 -- Aladdin's message 670 671 when N_Entry_Call_Statement | 672 N_Procedure_Call_Statement | 673 N_Function_Call => 674 -- here we have to filter out the case when Nil_Element 675 -- should be returned for a call through access-to-function: 676 677 if Nkind (Sinfo.Name (Arg_Node)) = N_Explicit_Dereference then 678 679 return Nil_Element; 680 end if; 681 682 if Arg_Node_Kind = N_Entry_Call_Statement then 683 Arg_Node := Sinfo.Name (Arg_Node); 684 -- Arg_Node points to the name of the called entry 685 686 if Nkind (Arg_Node) = N_Indexed_Component then 687 -- this is the case for a call to an entry from an 688 -- entry family 689 Arg_Node := Prefix (Arg_Node); 690 end if; 691 692 Result_Node := Entity (Selector_Name (Arg_Node)); 693 694 else 695 -- here we have Arg_Node_Kind equal to 696 -- N_Procedure_Call_Statement or to N_Function_Call, and this 697 -- is the right place to check if this is a dispatching call. 698 -- We do not want to use Asis.Extensions.Is_Dispatching_Call 699 -- query here to avoid introducing dependency on 700 -- Asis.Extensions 701 702 if Present (Controlling_Argument (Arg_Node)) then 703 return Nil_Element; 704 end if; 705 706 Arg_Node := Sinfo.Name (Arg_Node); 707 708 if Nkind (Arg_Node) = N_Selected_Component then 709 -- this is the case for calls to protected subprograms 710 Result_Node := Entity (Selector_Name (Arg_Node)); 711 else 712 Result_Node := Entity (Arg_Node); 713 end if; 714 715 end if; 716 717 if No (Result_Node) 718 and then 719 Arg_Node_Kind = N_Function_Call 720 and then 721 Is_From_Unknown_Pragma (R_Node (Call)) 722 then 723 return Nil_Element; 724 end if; 725 726 when N_Op => 727 -- all the predefined operations (??) 728 729 -- Take into account rewritting A /= B into 'not (A = B) in case 730 -- of a tagged type 731 732 if Nkind (Arg_Node) = N_Op_Not 733 and then 734 Is_Rewrite_Substitution (Arg_Node) 735 and then 736 Nkind (Original_Node (Arg_Node)) = N_Op_Ne 737 then 738 Arg_Node := Right_Opnd (Arg_Node); 739 740 if Nkind (Arg_Node) = N_Op_Eq 741 and then 742 Defined_In_Standard (Arg_Node) 743 then 744 return Nil_Element; 745 else 746 Arg_Node := Sinfo.Name (Arg_Node); 747 Is_Call_To_Implicit_Neq := True; 748 end if; 749 end if; 750 751 Result_Node := Entity (Arg_Node); 752 753 if No (Result_Node) and then Is_From_SPARK_Aspect (Call) then 754 return Nil_Element; 755 end if; 756 757 when N_Indexed_Component => 758 Result_Node := Generalized_Indexing (Arg_Node); 759 Result_Node := Prefix (Prefix (Result_Node)); 760 Result_Node := Sinfo.Name (Result_Node); 761 Result_Node := Entity (Result_Node); 762 when others => 763 pragma Assert (False); 764 null; 765 end case; 766 767 if Present (Result_Node) 768 and then 769 not Comes_From_Source (Result_Node) 770 and then 771 Nkind (Parent (Result_Node)) = N_Defining_Program_Unit_Name 772 then 773 -- Case of a child subprogram for that an explicit separate spec is 774 -- not given. Result_Node points to the defining identifier from 775 -- the subprogram spec artificially created by the compiler. We 776 -- reset it to point to the proper defining identifier from the 777 -- explicitly given body 778 Result_Node := Parent (Parent (Parent (Result_Node))); 779 pragma Assert (Nkind (Result_Node) = N_Subprogram_Declaration); 780 Result_Node := Corresponding_Body (Result_Node); 781 end if; 782 783 pragma Assert (Present (Result_Node)); 784 785 -- it is possible, that for a subprogram defined by a stub, the 786 -- subprogram body declaration from the corresponding subunit is 787 -- returned. In this case we have to go to the corresponding 788 -- stub (the subprogram body which is the proper body from a 789 -- subunit can never be returned as a corresponding called entity) 790 791 Set_Stub_For_Subunit_If_Any (Result_Node); 792 793 if Is_Generic_Instance (Result_Node) then 794 Result_Node := Get_Instance_Name (Result_Node); 795 end if; 796 797 Tmp_Node := Original_Node (Parent (Parent (Result_Node))); 798 799 while Nkind (Tmp_Node) = N_Subprogram_Renaming_Declaration 800 and then 801 not (Comes_From_Source (Tmp_Node)) 802 and then 803 not Pass_Generic_Actual (Tmp_Node) 804 loop 805 -- Result_Node is a defining name from the artificial renaming 806 -- declarations created by the compiler in the for wrapper 807 -- package for expanded subprogram instantiation. We 808 -- have to go to expanded subprogram spec which is renamed. 809 -- 810 -- We have to do this in a loop in case of nested instantiations 811 812 Result_Node := Sinfo.Name (Tmp_Node); 813 814 if Nkind (Result_Node) = N_Selected_Component then 815 Result_Node := Selector_Name (Result_Node); 816 end if; 817 818 Result_Node := Entity (Result_Node); 819 820 Tmp_Node := Parent (Parent (Result_Node)); 821 end loop; 822 823 -- F703-020: operations of an actual type provided for the formal 824 -- derived type (we are in the expanded generic) 825 826 if not Comes_From_Source (Result_Node) 827 and then 828 Present (Alias (Result_Node)) 829 and then 830 not (Is_Intrinsic_Subprogram (Result_Node)) 831 and then 832 Pass_Generic_Actual (Parent (Result_Node)) 833 then 834 -- This means that we have an operation of an actual that corresponds 835 -- to the generic formal derived type. In the tree, these operations 836 -- are "(re)defined" for the artificial subtype declaration used to 837 -- pass the actual type into expanded template. We go one step up 838 -- the aliases chain to get to the proper declaration of the type 839 -- operation 840 841 Result_Node := Alias (Result_Node); 842 end if; 843 844 -- the code below is very similar to what we have in 845 -- A4G.Expr_Sem.Identifier_Name_Definition (this name may be changed)! 846 -- In future we'll probably have to re-study this again (???) 847 848 -- first, defining the Enclosing Unit and doing the consistency check 849 850 ----------------------------------------------------------- 851 -- 2. Defining Association_Etype as the type "producing" -- 852 -- a given implicit construct (if needed) -- 853 ----------------------------------------------------------- 854 855 -- We have to turn off for a while the full processing of the 856 -- implicit elements (Hope to fix this soon). 857 858 if (not Comes_From_Source (Result_Node) 859 or else 860 Is_Artificial_Protected_Op_Item_Spec (Result_Node)) 861 and then 862 not (Pass_Generic_Actual (Parent (Parent (Result_Node))) 863 or else 864 Is_Implicit_Null_Procedure (Parent (Parent (Result_Node)))) 865 then 866 867 if Present (Alias (Result_Node)) 868 and then 869 Nkind (Original_Node (Parent (Result_Node))) in 870 N_Formal_Type_Declaration | 871 N_Full_Type_Declaration | 872 N_Incomplete_Type_Declaration | 873 N_Protected_Type_Declaration | 874 N_Private_Extension_Declaration 875 then 876 -- ???Is this the right test for implicit inherited user-defined 877 -- subprogram??? 878 Inherited := True; 879 Res_Node_Field_1 := Result_Node; 880 881 while Present (Alias (Result_Node)) 882 and then 883 not Comes_From_Source (Result_Node) 884 loop 885 Result_Node := Alias (Result_Node); 886 end loop; 887 888 elsif Is_Generic_Instance (Result_Node) then 889 890 Special_Case := Expanded_Subprogram_Instantiation; 891 892 elsif Is_Artificial_Protected_Op_Item_Spec (Result_Node) then 893 Result_Node := Corresponding_Body (Parent (Parent (Result_Node))); 894 895 elsif Ekind (Result_Node) = E_Function 896 and then 897 not Comes_From_Source (Result_Node) 898 and then 899 Chars (Result_Node) = Name_Op_Ne 900 and then 901 Present (Corresponding_Equality (Result_Node)) 902 then 903 Special_Case := Is_From_Imp_Neq_Declaration; 904-- |A2012 start 905 elsif Nkind (Original_Node ((Parent (Parent (Result_Node))))) = 906 N_Expression_Function 907 then 908 null; 909-- |A2012 end 910 elsif Ekind (Result_Node) in E_Function | E_Procedure 911 and then 912 Nkind (Parent (Parent (Result_Node))) in 913 N_Formal_Concrete_Subprogram_Declaration | 914 N_Formal_Abstract_Subprogram_Declaration 915 and then 916 Pass_Generic_Actual (Parent (Parent (Result_Node))) 917 then 918 -- This may happen in expanded formal package with a box, when 919 -- its formal subprogram is not specified 920 null; 921 else 922 923 return Nil_Element; 924 -- ???!!! this turns off all the predefined operations!!! 925 926 end if; 927 928 end if; 929 930 -- Now, checking if we have a call to an entry/procedure/function of 931 -- derived task/protected type 932 Tmp_Node := Arg_Node; 933 934 if Nkind (Tmp_Node) = N_Selected_Component then 935 Tmp_Node := Prefix (Tmp_Node); 936 Tmp_Node := Etype (Tmp_Node); 937 938 if Ekind (Tmp_Node) in Concurrent_Kind then 939 940 while not Comes_From_Source (Original_Node (Parent (Tmp_Node))) 941 loop 942 Tmp_Node := Etype (Tmp_Node); 943 end loop; 944 945 Tmp_Node := Parent (Tmp_Node); 946 947 if Nkind (Tmp_Node) = N_Full_Type_Declaration 948 and then 949 Nkind (Sinfo.Type_Definition (Tmp_Node)) = 950 N_Derived_Type_Definition 951 then 952 Inherited := True; 953 Res_Node_Field_1 := Tmp_Node; 954 end if; 955 956 end if; 957 958 end if; 959 960 if Present (Res_Node_Field_1) then 961 Result_Unit := 962 Enclosing_Unit (Encl_Cont_Id (Call), Res_Node_Field_1); 963 else 964 Result_Unit := 965 Enclosing_Unit (Encl_Cont_Id (Call), Result_Node); 966 end if; 967 -- ??? should be changed when full processing of implicit elements 968 -- will be ready 969 970 -- And now - from a defining name to a declaration itself 971 -- (this also may need adjustment for the full implementation 972 -- of the implicit stuff) 973 974 if Inherited then 975 976 -- For inherited subprograms we have to set the result kind manually 977 -- to get subprogram declarations in case of inheriting from 978 -- subprogram ransoming (8728-023) 979 980 if Ekind (Result_Node) = E_Function or else 981 Ekind (Result_Node) = E_Operator 982 then 983 Result_Kind := A_Function_Declaration; 984 985 Tmp_Node := Parent (Parent (Result_Node)); 986 987 if Nkind (Original_Node (Tmp_Node)) = N_Expression_Function then 988 Result_Kind := An_Expression_Function_Declaration; 989 end if; 990 elsif Ekind (Result_Node) = E_Procedure then 991 Result_Kind := A_Procedure_Declaration; 992 end if; 993 994 end if; 995 996 if Special_Case not in Predefined then 997 998 if Nkind (Result_Node) in N_Entity 999 and then 1000 Ekind (Result_Node) = E_Enumeration_Literal 1001 then 1002 -- This happens if an enumeration literal is used as an actual for 1003 -- a formal function, and if we process the corresponding function 1004 -- call in the instantiation. See EBB11-004 1005 1006 Result_Kind := An_Enumeration_Literal_Specification; 1007 else 1008 Result_Node := Parent (Result_Node); 1009 1010 if Nkind (Result_Node) = N_Defining_Program_Unit_Name then 1011 Result_Node := Parent (Result_Node); 1012 end if; 1013 1014 if Nkind (Result_Node) = N_Procedure_Specification or else 1015 Nkind (Result_Node) = N_Function_Specification 1016 then 1017 Result_Node := Parent (Result_Node); 1018 end if; 1019 1020 end if; 1021 1022 elsif Special_Case in Predefined then 1023 Result_Kind := A_Function_Declaration; 1024 end if; 1025 1026 Result_El := 1027 Node_To_Element_New 1028 (Node => Result_Node, 1029 Node_Field_1 => Res_Node_Field_1, 1030 Internal_Kind => Result_Kind, 1031 Spec_Case => Special_Case, 1032 Inherited => Inherited, 1033 In_Unit => Result_Unit); 1034 1035 -- Fix for C125-002: Is_Part_Of_Instance of the result is defined on 1036 -- the base of Result_Node which points to the explicit subprogram. 1037 -- That is, if we define the type derived from some other type declared 1038 -- inside the instance, we will get all its inherited subprograms 1039 -- being Is_Part_Of_Instance even if the derived type is not declared 1040 -- inside any instance. And the other way around. 1041 1042 if Present (Res_Node_Field_1) then 1043 1044 if Is_From_Instance (Res_Node_Field_1) then 1045 Set_From_Instance (Result_El, True); 1046 else 1047 Set_From_Instance (Result_El, False); 1048 end if; 1049 1050 end if; 1051 1052 if Is_Call_To_Implicit_Neq then 1053 Set_From_Implicit (Result_El, True); 1054 Set_Special_Case (Result_El, Is_From_Imp_Neq_Declaration); 1055 end if; 1056 1057 if Is_Implicit_Null_Procedure (Result_Node) then 1058 Set_Int_Kind (Result_El, A_Null_Procedure_Declaration); 1059 end if; 1060 1061 return Result_El; 1062 end Get_Corr_Called_Entity; 1063 1064 ---------------------- 1065 -- Get_Derived_Type -- 1066 ---------------------- 1067 1068 function Get_Derived_Type 1069 (Type_Entity : Entity_Id; 1070 Inherited_Subpr : Entity_Id) 1071 return Entity_Id 1072 is 1073 Result : Entity_Id := Type_Entity; 1074 Derived_Type : Entity_Id; 1075 Next_Derived_Type : Entity_Id; 1076 begin 1077 Derived_Type := Original_Node (Parent (Inherited_Subpr)); 1078 1079 Next_Derived_Type := Derived_Type; 1080 1081 if Nkind (Next_Derived_Type) = N_Full_Type_Declaration then 1082 Next_Derived_Type := Sinfo.Type_Definition (Next_Derived_Type); 1083 elsif Nkind (Next_Derived_Type) = N_Formal_Type_Declaration then 1084 Next_Derived_Type := Sinfo.Formal_Type_Definition (Next_Derived_Type); 1085 end if; 1086 1087 if Nkind (Next_Derived_Type) = N_Formal_Derived_Type_Definition then 1088 Next_Derived_Type := Sinfo.Subtype_Mark (Next_Derived_Type); 1089 else 1090 Next_Derived_Type := Sinfo.Subtype_Indication (Next_Derived_Type); 1091 end if; 1092 1093 Derived_Type := Defining_Identifier (Derived_Type); 1094 1095 if Nkind (Next_Derived_Type) = N_Subtype_Indication then 1096 Next_Derived_Type := Sinfo.Subtype_Mark (Next_Derived_Type); 1097 end if; 1098 1099 Next_Derived_Type := Entity (Next_Derived_Type); 1100 1101 loop 1102 1103 if Next_Derived_Type = Type_Entity then 1104 Result := Derived_Type; 1105 exit; 1106 1107 elsif Is_Derived_Type (Next_Derived_Type) then 1108 1109 Next_Derived_Type := Original_Node (Parent (Next_Derived_Type)); 1110 1111 if Nkind (Next_Derived_Type) = N_Full_Type_Declaration then 1112 Next_Derived_Type := Sinfo.Type_Definition (Next_Derived_Type); 1113 end if; 1114 1115 if Nkind (Next_Derived_Type) = N_Formal_Type_Declaration then 1116 Next_Derived_Type := 1117 Sinfo.Formal_Type_Definition (Next_Derived_Type); 1118 Next_Derived_Type := Sinfo.Subtype_Mark (Next_Derived_Type); 1119 else 1120 Next_Derived_Type := 1121 Sinfo.Subtype_Indication (Next_Derived_Type); 1122 end if; 1123 1124 if Nkind (Next_Derived_Type) = N_Subtype_Indication then 1125 Next_Derived_Type := Sinfo.Subtype_Mark (Next_Derived_Type); 1126 end if; 1127 1128 Next_Derived_Type := Entity (Next_Derived_Type); 1129 1130 else 1131 exit; 1132 end if; 1133 1134 end loop; 1135 1136 return Result; 1137 1138 end Get_Derived_Type; 1139 1140 -------------------------- 1141 -- Get_Importing_Pragma -- 1142 -------------------------- 1143 1144 function Get_Importing_Pragma (E : Entity_Id) return Node_Id is 1145 pragma Assert (Is_Imported (E)); 1146 1147 Result : Node_Id := Empty; 1148 Tmp_Node : Node_Id; 1149 Pragma_Node : Node_Id; 1150 Arg_Chars : constant Name_Id := Chars (E); 1151 1152 begin 1153 -- The simplest case first, but it does not work for generic 1154 -- subprograms: 1155 1156 if Is_Subprogram (E) then 1157 Result := Import_Pragma (E); 1158 1159 if Present (Result) and then Comes_From_Source (Result) then 1160 return Result; 1161 end if; 1162 1163 end if; 1164 1165 -- Then, try to locate an aspect definition 1166 Tmp_Node := Parent (E); 1167 1168 if Nkind (Tmp_Node) in 1169 N_Procedure_Specification | N_Function_Specification 1170 then 1171 Tmp_Node := Parent (Tmp_Node); 1172 1173 if Present (Aspects.Aspect_Specifications (Tmp_Node)) then 1174 Tmp_Node := First (Aspects.Aspect_Specifications (Tmp_Node)); 1175 1176 while Present (Tmp_Node) loop 1177 if Chars (Sinfo.Identifier (Tmp_Node)) = Name_Import then 1178 return Tmp_Node; 1179 end if; 1180 1181 Tmp_Node := Next (Tmp_Node); 1182 end loop; 1183 1184 end if; 1185 1186 end if; 1187 1188 -- Check if we have the corresponding pragma in the list of 1189 -- representation items applied to the argument node: 1190 1191 Pragma_Node := First_Rep_Item (E); 1192 1193 while Present (Pragma_Node) loop 1194 1195 if Is_Importing_Pragma (Pragma_Node, Arg_Chars) then 1196 Result := Pragma_Node; 1197 exit; 1198 else 1199 Pragma_Node := Next_Rep_Item (Pragma_Node); 1200 end if; 1201 1202 end loop; 1203 1204 if No (Result) then 1205 -- That means that Import or Interface pragma is applied to an 1206 -- overloaded entities 1207 Pragma_Node := Next (Parent (Parent (E))); 1208 1209 while Present (Pragma_Node) loop 1210 1211 if Is_Importing_Pragma (Pragma_Node, Arg_Chars) then 1212 Result := Pragma_Node; 1213 exit; 1214 else 1215 Next (Pragma_Node); 1216 end if; 1217 1218 end loop; 1219 1220 end if; 1221 1222 if No (Result) then 1223 Tmp_Node := Parent (Parent (Parent (E))); 1224 1225 if Nkind (Tmp_Node) = N_Package_Specification 1226 and then 1227 List_Containing (Parent (Parent (E))) = 1228 Visible_Declarations (Tmp_Node) 1229 then 1230 -- this is a somewhat exotic case - a subprogram declaration in 1231 -- the visible part of a package spec, and the corresponding 1232 -- pragma is in the corresponding private part. 1233 Pragma_Node := First (Private_Declarations (Tmp_Node)); 1234 1235 while Present (Pragma_Node) loop 1236 1237 if Is_Importing_Pragma (Pragma_Node, Arg_Chars) then 1238 Result := Pragma_Node; 1239 exit; 1240 else 1241 Next (Pragma_Node); 1242 end if; 1243 1244 end loop; 1245 1246 end if; 1247 1248 end if; 1249 1250 pragma Assert (Present (Result)); 1251 return Result; 1252 end Get_Importing_Pragma; 1253 1254 ----------------------- 1255 -- Get_Instance_Name -- 1256 ----------------------- 1257 1258 function Get_Instance_Name (Int_Name : Node_Id) return Node_Id is 1259 Result_Node : Node_Id := Empty; 1260 Decl_Node : Node_Id; 1261 begin 1262 1263 Decl_Node := Parent (Int_Name); 1264 1265 if Nkind (Decl_Node) = N_Defining_Program_Unit_Name then 1266 Decl_Node := Parent (Decl_Node); 1267 end if; 1268 1269 Decl_Node := Parent (Decl_Node); 1270 1271 if Nkind (Decl_Node) = N_Subprogram_Declaration then 1272 Decl_Node := Parent (Parent (Decl_Node)); 1273 end if; 1274 1275 if (not Is_List_Member (Decl_Node) 1276 and then 1277 not Is_Rewrite_Substitution (Decl_Node)) 1278 or else 1279 (Is_List_Member (Decl_Node) 1280 and then 1281 Nkind (Original_Node (Decl_Node)) = N_Formal_Package_Declaration) 1282 then 1283 -- The first condition corresponds to the case when a library 1284 -- package is instantiated at library level - no artificial package 1285 -- is created in this case. 1286 -- The second condition corresponds to the defining name from 1287 -- a formal package declaration (it is also classified as 1288 -- Is_Generic_Instance) 1289 1290 return Int_Name; 1291 1292 end if; 1293 -- now Decl_Node points to the declaration of an artificial package 1294 -- created by the compiler for the instantiation 1295 1296 if Is_Rewrite_Substitution (Decl_Node) then 1297 Decl_Node := Original_Node (Decl_Node); 1298 1299 if Is_Rewrite_Substitution (Decl_Node) then 1300 -- The node can be rewritten twice in case when a library-level 1301 -- instantiation is a supporter of a main unit, and the expanded 1302 -- body of this instantiation is required according to Lib (h), 1303 -- see 9418-015, 9416-A01 and 9426-A13 1304 Decl_Node := Original_Node (Decl_Node); 1305 end if; 1306 1307 if Nkind (Original_Node (Decl_Node)) = 1308 N_Formal_Package_Declaration 1309 then 1310 Result_Node := Defining_Identifier (Original_Node (Decl_Node)); 1311 else 1312 Result_Node := Defining_Unit_Name (Original_Node (Decl_Node)); 1313 end if; 1314 1315 else 1316 1317 Decl_Node := Next_Non_Pragma (Decl_Node); 1318 1319 while Present (Decl_Node) loop 1320 if Nkind (Decl_Node) in N_Generic_Instantiation then 1321 Result_Node := Defining_Unit_Name (Decl_Node); 1322 exit; 1323 1324 else 1325 Decl_Node := Next_Non_Pragma (Decl_Node); 1326 end if; 1327 1328 end loop; 1329 1330 end if; 1331 1332 pragma Assert (Present (Result_Node)); 1333 1334 return Result_Node; 1335 1336 end Get_Instance_Name; 1337 1338 ------------------ 1339 -- Is_Anonymous -- 1340 ------------------ 1341 1342 function Is_Anonymous (E : Entity_Kind) return Boolean is 1343 Result : Boolean := False; 1344 begin 1345 case E is 1346 when E_Anonymous_Access_Subprogram_Type | 1347 E_Anonymous_Access_Protected_Subprogram_Type | 1348 E_Anonymous_Access_Type => 1349 Result := True; 1350 when others => 1351 null; 1352 end case; 1353 1354 return Result; 1355 end Is_Anonymous; 1356 1357 ------------------- 1358 -- Is_Applied_To -- 1359 ------------------- 1360 1361 function Is_Applied_To 1362 (Pragma_Node : Node_Id; 1363 Entity_Node : Entity_Id) 1364 return Boolean 1365 is 1366 Result : Boolean := False; 1367 Pragma_Arg : Node_Id := Empty; 1368 Entity_Decl : Node_Id; 1369 begin 1370 1371 case Pragma_Name (Pragma_Node) is 1372 1373 -- Cases when the second pragma argument indicates the entity 1374 -- the pragma is applied to: 1375 when Name_Component_Alignment | 1376 Name_Convention | 1377 Name_Export | 1378 Name_External | 1379 Name_Import | 1380 Name_Interface => 1381 1382 Pragma_Arg := First (Pragma_Argument_Associations (Pragma_Node)); 1383 Pragma_Arg := Sinfo.Expression (Next (Pragma_Arg)); 1384 1385 if Entity (Pragma_Arg) = Entity_Node 1386 or else 1387 Chars (Pragma_Arg) = Chars (Entity_Node) 1388 then 1389 Result := True; 1390 end if; 1391 1392 -- Cases when a pragma may have several arguments, and any of then 1393 -- may indicate the entity the pragma is applied to 1394 when Name_Inline | 1395 Name_Inline_Always | 1396 Name_No_Return | 1397 Name_Unmodified | 1398 Name_Unreferenced | 1399 Name_Unreferenced_Objects => 1400 Pragma_Arg := First (Pragma_Argument_Associations (Pragma_Node)); 1401 1402 while Present (Pragma_Arg) loop 1403 Pragma_Arg := Sinfo.Expression (Pragma_Arg); 1404 1405 if Entity (Pragma_Arg) = Entity_Node 1406 or else 1407 Chars (Pragma_Arg) = Chars (Entity_Node) 1408 then 1409 Result := True; 1410 exit; 1411 end if; 1412 1413 Pragma_Arg := Next (Parent (Pragma_Arg)); 1414 end loop; 1415 1416 -- Cases when only the first argument of a pragma may indicate the 1417 -- entity the pragma is applied to 1418 when -- GNAT-specific pragmas first 1419 Name_Common_Object | 1420 Name_Complex_Representation | 1421 Name_CPP_Class | 1422 Name_CPP_Constructor | 1423 Name_Export_Function | 1424 Name_Export_Object | 1425 Name_Export_Procedure | 1426 Name_Export_Valued_Procedure | 1427 Name_Favor_Top_Level | 1428 Name_Finalize_Storage_Only | 1429 Name_Import_Function | 1430 Name_Import_Object | 1431 Name_Import_Procedure | 1432 Name_Import_Valued_Procedure | 1433 Name_Inline_Generic | 1434 Name_Interface_Name | 1435 Name_Keep_Names | 1436 Name_Linker_Alias | 1437 Name_Linker_Constructor | 1438 Name_Linker_Destructor | 1439 Name_Linker_Section | 1440 Name_Machine_Attribute | 1441 Name_No_Strict_Aliasing | 1442 Name_Persistent_BSS | 1443 Name_Psect_Object | 1444 Name_Pure_Function | 1445 Name_Shared | 1446 Name_Stream_Convert | 1447 Name_Suppress_Initialization | 1448 Name_Task_Storage | 1449 Name_Universal_Aliasing | 1450 Name_Weak_External | 1451 -- Standard Ada 2005 pragmas 1452 Name_Asynchronous | 1453 Name_Atomic | 1454 Name_Atomic_Components | 1455 Name_Attach_Handler | 1456 Name_Controlled | 1457 Name_Discard_Names | 1458 Name_Interrupt_Handler | 1459 Name_Pack | 1460 Name_Preelaborable_Initialization | 1461 Name_Unchecked_Union | 1462 Name_Volatile | 1463 Name_Volatile_Components => 1464 Pragma_Arg := First (Pragma_Argument_Associations (Pragma_Node)); 1465 Pragma_Arg := Sinfo.Expression (Pragma_Arg); 1466 1467 if Entity (Pragma_Arg) = Entity_Node 1468 or else 1469 Chars (Pragma_Arg) = Chars (Entity_Node) 1470 then 1471 Result := True; 1472 end if; 1473 1474 when Name_Obsolescent => 1475 1476 if Is_Obsolescent (Entity_Node) then 1477 -- This pragma may or may not contain the reference to the 1478 -- entity it is applied to. The pragma may or may not contain 1479 -- arguments 1480 if Present (Pragma_Argument_Associations (Pragma_Node)) 1481 and then 1482 List_Length (Pragma_Argument_Associations (Pragma_Node)) >= 2 1483 then 1484 Pragma_Arg := 1485 First (Pragma_Argument_Associations (Pragma_Node)); 1486 Pragma_Arg := Sinfo.Expression (Pragma_Arg); 1487 end if; 1488 1489 if No (Pragma_Arg) 1490 or else 1491 Chars (Pragma_Arg) = Chars (Entity_Node) 1492 then 1493 -- here we have to check if the pragma immediately follows 1494 -- the declaration that defines Entity_Node, or the pragma 1495 -- is the first declarative element in the package spec and 1496 -- Entity_Node defines this package. Pragma_Arg is used as 1497 -- temporary node below 1498 Pragma_Arg := Prev (Pragma_Node); 1499 1500 if Present (Pragma_Arg) then 1501 -- Go to the declaration that declares Entity_Node 1502 Entity_Decl := Parent (Entity_Node); 1503 1504 while Present (Entity_Decl) 1505 and then 1506 not Is_List_Member (Entity_Decl) 1507 loop 1508 Entity_Decl := Parent (Entity_Decl); 1509 end loop; 1510 1511 Result := Entity_Decl = Pragma_Arg; 1512 else 1513 -- With the current implementation of the ASIS 1514 -- Corresponding_Pragmas query this code never works! 1515 1516 -- Check if the pragma Obsolescent is the program unit 1517 -- pragma: 1518 Pragma_Arg := Parent (Pragma_Node); 1519 1520 if Nkind (Pragma_Arg) = N_Package_Specification then 1521 1522 if Nkind (Parent (Pragma_Arg)) = 1523 N_Package_Declaration 1524 then 1525 -- To filter out the case of generic packages 1526 Pragma_Arg := Defining_Unit_Name (Pragma_Arg); 1527 1528 if Nkind (Pragma_Arg) = 1529 N_Defining_Program_Unit_Name 1530 then 1531 Pragma_Arg := Defining_Identifier (Pragma_Arg); 1532 end if; 1533 1534 Result := Pragma_Arg = Entity_Node; 1535 end if; 1536 1537 end if; 1538 1539 end if; 1540 1541 else 1542 -- With the current implementation of the ASIS 1543 -- Corresponding_Pragmas query this code never works! 1544 1545 -- Case when a pragma may be applied to an enumeration 1546 -- literal. 1547 1548 if Ekind (Entity_Node) = E_Enumeration_Literal then 1549 Entity_Decl := Parent (Parent (Entity_Node)); 1550 1551 Result := Next (Entity_Decl) = Pragma_Node; 1552 end if; 1553 end if; 1554 1555 end if; 1556 1557 -- All the other pragmas cannot be a part of the result 1558 when others => 1559 null; 1560 end case; 1561 1562 return Result; 1563 end Is_Applied_To; 1564 1565 ------------------------------------------ 1566 -- Is_Artificial_Protected_Op_Item_Spec -- 1567 ------------------------------------------ 1568 1569 function Is_Artificial_Protected_Op_Item_Spec 1570 (E : Entity_Id) 1571 return Boolean 1572 is 1573 Arg : Entity_Id := E; 1574 Result : Boolean := False; 1575 begin 1576 if Nkind (Arg) = N_Defining_Identifier then 1577 -- No need to consider defining expanded names 1578 1579 if Ekind (Arg) in Formal_Kind then 1580 Arg := Parent (Parent (Arg)); 1581 1582 if Nkind (Arg) in N_Subprogram_Specification then 1583 Arg := Defining_Unit_Name (Arg); 1584 end if; 1585 1586 end if; 1587 1588 if Nkind (Arg) in N_Entity 1589 and then 1590 (Ekind (Arg) in Formal_Kind or else Ekind (Arg) in Subprogram_Kind) 1591 and then 1592 not Comes_From_Source (Parent (Arg)) 1593 and then 1594 Nkind (Parent (Parent (Parent (Arg)))) = N_Protected_Body 1595 then 1596 Result := True; 1597 end if; 1598 1599 end if; 1600 1601 return Result; 1602 end Is_Artificial_Protected_Op_Item_Spec; 1603 1604 --------------------------- 1605 -- Is_Based_On_Same_Node -- 1606 --------------------------- 1607 1608 function Is_Based_On_Same_Node (E : Asis.Element) return Boolean is 1609 N : Node_Id; 1610 Result : Boolean := False; 1611 begin 1612 if Is_Implicit_Neq_Declaration (E) then 1613 -- The implementation may be incomplete: not all of the possible 1614 -- cases may be processed 1615 1616 N := R_Node (E); 1617 1618 case Nkind (N) is 1619 when N_Subprogram_Declaration => 1620 N := Defining_Unit_Name (Specification (N)); 1621 1622 if Nkind (N) = N_Defining_Program_Unit_Name then 1623 N := Defining_Identifier (N); 1624 end if; 1625 1626 if Chars (N) = Name_Op_Eq then 1627 Result := True; 1628 end if; 1629 1630 when others => 1631 return False; 1632 end case; 1633 1634 end if; 1635 1636 return Result; 1637 end Is_Based_On_Same_Node; 1638 1639 ------------------------- 1640 -- Is_Derived_Rep_Item -- 1641 ------------------------- 1642 1643 function Is_Derived_Rep_Item 1644 (Type_Entity : Entity_Id; 1645 Rep_Item : Node_Id) 1646 return Boolean 1647 is 1648 Result : Boolean := True; 1649 Type_Ard : Node_Id := Empty; 1650 begin 1651 1652 case Nkind (Rep_Item) is 1653 1654 when N_Attribute_Definition_Clause => 1655 1656 if Entity (Sinfo.Name (Rep_Item)) = Type_Entity then 1657 Result := False; 1658 end if; 1659 1660 when N_Pragma => 1661 1662 Type_Ard := Sinfo.Expression 1663 (First (Pragma_Argument_Associations (Rep_Item))); 1664 1665 if Entity (Type_Ard) = Type_Entity then 1666 Result := False; 1667 end if; 1668 1669 when N_Enumeration_Representation_Clause | 1670 N_Record_Representation_Clause => 1671 1672 if Entity (Sinfo.Identifier (Rep_Item)) = Type_Entity then 1673 Result := False; 1674 end if; 1675 1676 when others => 1677 null; 1678 pragma Assert (False); 1679 end case; 1680 1681 return Result; 1682 end Is_Derived_Rep_Item; 1683 1684 ---------------------- 1685 -- Is_From_Instance -- 1686 ---------------------- 1687 1688 function Is_From_Instance (Node : Node_Id) return Boolean is 1689 begin 1690 1691 return 1692 (Sloc (Node) > Standard_Location 1693 and then 1694 Instantiation (Get_Source_File_Index (Sloc (Node))) /= No_Location) 1695 or else 1696 (Present (Parent (Node)) 1697 and then 1698 Nkind (Parent (Node)) = N_Package_Specification 1699 and then 1700 Is_From_Instance ((Parent (Node)))); 1701 1702 end Is_From_Instance; 1703 1704 --------------------------------- 1705 -- Is_From_Rewritten_Aggregate -- 1706 --------------------------------- 1707 1708 function Is_From_Rewritten_Aggregate (Node : Node_Id) return Boolean is 1709 Result : Boolean := False; 1710 Next_Aggr : Node_Id; 1711 begin 1712 if Nkind (Node) = N_Component_Association then 1713 Next_Aggr := Parent (Node); 1714 1715 while Nkind (Next_Aggr) = N_Aggregate 1716 or else 1717 Nkind (Next_Aggr) = N_Extension_Aggregate 1718 or else 1719 Nkind (Next_Aggr) = N_Component_Association 1720 loop 1721 if Is_Rewrite_Substitution (Next_Aggr) then 1722 Result := True; 1723 exit; 1724 end if; 1725 1726 Next_Aggr := Parent (Next_Aggr); 1727 end loop; 1728 end if; 1729 1730 return Result; 1731 end Is_From_Rewritten_Aggregate; 1732 1733 ---------------------------- 1734 -- Is_From_Unknown_Pragma -- 1735 ---------------------------- 1736 1737 function Is_From_Unknown_Pragma (Node : Node_Id) return Boolean is 1738 Result : Boolean := False; 1739 Tmp : Node_Id := Parent (Node); 1740 N : Name_Id; 1741 begin 1742 loop 1743 1744 case Nkind (Tmp) is 1745 1746 when N_Compilation_Unit | N_Empty => 1747 exit; 1748 1749 when N_Pragma => 1750 1751 N := Pragma_Name (Tmp); 1752 1753 -- See Snames.Get_Pragma_Id 1754 if not ( 1755 N in First_Pragma_Name .. Last_Pragma_Name 1756 or else 1757 N = Name_CPU 1758 or else 1759 N = Name_Interface 1760 or else 1761 N = Name_Interrupt_Priority 1762 or else 1763 N = Name_Priority 1764 or else 1765 N = Name_Storage_Size) 1766 then 1767 Result := True; 1768 end if; 1769 1770 exit; 1771 1772 when N_Statement_Other_Than_Procedure_Call | 1773 N_Procedure_Call_Statement | 1774 N_Representation_Clause | 1775 N_Declaration | 1776 N_Access_To_Subprogram_Definition | 1777 N_Later_Decl_Item | 1778 N_Array_Type_Definition | 1779 N_Renaming_Declaration => 1780 1781 exit; 1782 1783 when others => 1784 Tmp := Parent (Tmp); 1785 end case; 1786 1787 end loop; 1788 1789 return Result; 1790 end Is_From_Unknown_Pragma; 1791 1792 -------------------------------- 1793 -- Is_Implicit_Null_Procedure -- 1794 -------------------------------- 1795 1796 function Is_Implicit_Null_Procedure (N : Node_Id) return Boolean is 1797 Result : Boolean; 1798 Tmp : Node_Id; 1799 begin 1800 1801 Result := 1802 Nkind (N) = N_Subprogram_Body 1803 and then 1804 not Comes_From_Source (N) 1805 and then 1806 Nkind (Specification (N)) = N_Procedure_Specification 1807 and then 1808 Null_Present (Specification (N)) 1809 and then 1810 Is_Intrinsic_Subprogram (Defining_Unit_Name (Specification (N))); 1811 1812 if Result then 1813 Tmp := Parent (N); 1814 1815 if Nkind (Tmp) = N_Package_Specification then 1816 Tmp := Parent (Tmp); 1817 end if; 1818 1819 if Nkind (Tmp) in N_Package_Body | N_Package_Declaration then 1820 1821 if Is_List_Member (Tmp) then 1822 if Nkind (Tmp) = N_Package_Declaration then 1823 Tmp := Next (Tmp); 1824 end if; 1825 1826 if Nkind (Tmp) = N_Package_Body then 1827 Tmp := Next (Tmp); 1828 end if; 1829 1830 else 1831 -- Possible library-level instantiation 1832 if Nkind (Tmp) = N_Package_Declaration 1833 and then 1834 Present (Corresponding_Body (Tmp)) 1835 then 1836 Tmp := Parent (Corresponding_Body (Tmp)); 1837 Tmp := Original_Node (Tmp); 1838 end if; 1839 end if; 1840 1841 Result := 1842 Nkind (Tmp) in 1843 N_Package_Instantiation | 1844 N_Function_Instantiation | 1845 N_Procedure_Instantiation; 1846 else 1847 Result := False; 1848 end if; 1849 end if; 1850 1851 return Result; 1852 end Is_Implicit_Null_Procedure; 1853 1854 ----------------- 1855 -- Is_Impl_Neq -- 1856 ----------------- 1857 1858 function Is_Impl_Neq (Def_Op : Entity_Id) return Boolean is 1859 Result : Boolean := False; 1860 begin 1861 1862 if Nkind (Def_Op) in N_Entity 1863 and then Ekind (Def_Op) = E_Function 1864 and then not Comes_From_Source (Def_Op) 1865 and then Chars (Def_Op) = Name_Op_Ne 1866 and then Present (Corresponding_Equality (Def_Op)) 1867 then 1868 Result := True; 1869 end if; 1870 1871 return Result; 1872 end Is_Impl_Neq; 1873 1874 ------------------------- 1875 -- Is_Importing_Pragma -- 1876 ------------------------- 1877 1878 function Is_Importing_Pragma 1879 (N : Node_Id; 1880 For_Name : Name_Id) 1881 return Boolean 1882 is 1883 Result : Boolean := False; 1884 Tmp : Node_Id; 1885 begin 1886 1887 if Nkind (N) = N_Pragma 1888 and then 1889 (Pragma_Name (N) = Name_Import 1890 or else 1891 Pragma_Name (N) = Name_Interface 1892 or else 1893 Pragma_Name (N) = Name_CPP_Constructor) 1894 then 1895 Tmp := First (Pragma_Argument_Associations (N)); 1896 Tmp := Sinfo.Expression (Next (Tmp)); 1897 1898 Result := Chars (Tmp) = For_Name; 1899 end if; 1900 1901 return Result; 1902 end Is_Importing_Pragma; 1903 1904 ------------------------------------ 1905 -- Is_Name_Of_Expanded_Subprogram -- 1906 ------------------------------------- 1907 1908 function Is_Name_Of_Expanded_Subprogram (Node : Node_Id) return Boolean is 1909 Result : Boolean := False; 1910 begin 1911 if Nkind (Node) = N_Defining_Identifier 1912 and then 1913 Is_Generic_Instance (Node) 1914 and then 1915 Ekind (Node) in Subprogram_Kind 1916 then 1917 Result := True; 1918 end if; 1919 1920 return Result; 1921 end Is_Name_Of_Expanded_Subprogram; 1922 1923 ------------------- 1924 -- Is_Predefined -- 1925 ------------------- 1926 1927 function Is_Predefined (Def_Op : Node_Id) return Boolean is 1928 Result : Boolean := False; 1929 Tmp : Entity_Id; 1930 begin 1931 1932 if Ekind (Def_Op) in E_Function | E_Operator 1933 and then 1934 not Comes_From_Source (Def_Op) 1935 and then 1936 not Is_Impl_Neq (Def_Op) 1937 then 1938 1939 if Sloc (Def_Op) <= Standard_Location 1940 or else 1941 No (Alias (Def_Op)) 1942 or else 1943 No (Parent (Def_Op)) 1944 then 1945 Result := True; 1946 1947 elsif Present (Alias (Def_Op)) then 1948 Tmp := Alias (Def_Op); 1949 1950 while Present (Alias (Tmp)) loop 1951 Tmp := Alias (Tmp); 1952 end loop; 1953 1954 if not Comes_From_Source (Tmp) 1955 and then 1956 No (Parent (Tmp)) 1957 then 1958 Result := True; 1959 end if; 1960 1961 end if; 1962 1963 end if; 1964 1965 return Result; 1966 end Is_Predefined; 1967 1968 ------------------------------ 1969 -- Is_Range_Memberchip_Test -- 1970 ------------------------------ 1971 1972 function Is_Range_Memberchip_Test (E : Asis.Element) return Boolean is 1973 Tmp : Asis.Element; 1974 Result : Boolean := False; 1975 begin 1976 if No (Alternatives (Node (E))) then 1977 Tmp := Membership_Test_Choices (E) (1); 1978 Result := Constraint_Kind (Tmp) in 1979 A_Range_Attribute_Reference .. A_Simple_Expression_Range; 1980 end if; 1981 1982 return Result; 1983 end Is_Range_Memberchip_Test; 1984 1985 ---------------------------------- 1986 -- Is_Rewritten_SPARK_Construct -- 1987 ---------------------------------- 1988 1989 function Is_Rewritten_SPARK_Construct (N : Node_Id) return Boolean is 1990 Tmp : Node_Id; 1991 Result : Boolean := False; 1992 begin 1993 if not Is_Rewrite_Substitution (N) then 1994 return False; 1995 end if; 1996 1997 case Nkind (N) is 1998 when N_Pragma => 1999 Tmp := Pragma_Identifier (N); 2000 2001 case Chars (Tmp) is 2002 when Name_Abstract_State | 2003 Name_Contract_Cases | 2004 Name_Depends | 2005 Name_Extensions_Visible | 2006 Name_Global | 2007 Name_Initial_Condition | 2008 Name_Initializes | 2009 Name_Post | 2010 Name_Post_Class | 2011 Name_Postcondition | 2012 Name_Pre | 2013 Name_Pre_Class | 2014 Name_Precondition | 2015 Name_Refined_Depends | 2016 Name_Refined_Global | 2017 Name_Refined_Post | 2018 Name_Refined_State | 2019 Name_Test_Case => 2020 Result := True; 2021 when others => 2022 null; 2023 end case; 2024 2025 when others => 2026 null; 2027 end case; 2028 2029 return Result; 2030 end Is_Rewritten_SPARK_Construct; 2031 2032 --------------------------- 2033 -- Is_Root_Standard_Type -- 2034 --------------------------- 2035 2036 function Is_Root_Standard_Type (E : Entity_Id) return Boolean is 2037 Result : Boolean := False; 2038 begin 2039 if Sloc (E) <= Standard_Location 2040 and then 2041 Nkind (E) = N_Defining_Identifier 2042 and then 2043 Ekind (E) /= E_Void 2044 and then 2045 Parent (E) = Empty 2046 then 2047 Result := True; 2048 end if; 2049 2050 return Result; 2051 end Is_Root_Standard_Type; 2052 2053 ----------------------------- 2054 -- Is_Type_Memberchip_Test -- 2055 ----------------------------- 2056 2057 function Is_Type_Memberchip_Test (E : Asis.Element) return Boolean is 2058 Tmp_El : Asis.Element; 2059 Result : Boolean := False; 2060 begin 2061 if No (Alternatives (Node (E))) then 2062 Tmp_El := Membership_Test_Choices (E) (1); 2063 2064 case Expression_Kind (Tmp_El) is 2065 when An_Identifier | 2066 A_Selected_Component | 2067 An_Attribute_Reference => 2068 Tmp_El := Normalize_Reference (Tmp_El); 2069 Result := Is_Type (Entity (R_Node (Tmp_El))); 2070 when others => null; 2071 end case; 2072 2073 end if; 2074 2075 return Result; 2076 end Is_Type_Memberchip_Test; 2077 2078 ----------------------- 2079 -- Limited_View_Kind -- 2080 ----------------------- 2081 2082 function Limited_View_Kind 2083 (Decl : Asis.Element) 2084 return Internal_Element_Kinds 2085 is 2086 Result : Internal_Element_Kinds := Int_Kind (Decl); 2087 Type_Def : Asis.Element; 2088 begin 2089 case Result is 2090 when A_Private_Extension_Declaration => 2091 Result := A_Tagged_Incomplete_Type_Declaration; 2092 2093 when A_Task_Type_Declaration | 2094 A_Protected_Type_Declaration => 2095 Result := An_Incomplete_Type_Declaration; 2096 2097 when An_Ordinary_Type_Declaration | 2098 A_Private_Type_Declaration => 2099 Type_Def := Type_Declaration_View (Decl); 2100 2101 case Int_Kind (Type_Def) is 2102 when A_Derived_Record_Extension_Definition | 2103 A_Tagged_Record_Type_Definition | 2104 Internal_Interface_Kinds | 2105 A_Tagged_Private_Type_Definition => 2106 Result := A_Tagged_Incomplete_Type_Declaration; 2107 when others => 2108 Result := An_Incomplete_Type_Declaration; 2109 end case; 2110 2111 when others => 2112 null; 2113 end case; 2114 2115 return Result; 2116 end Limited_View_Kind; 2117 2118 ------------------------------- 2119 -- Not_Overriden_By_Explicit -- 2120 ------------------------------- 2121 2122 function Not_Overriden_By_Explicit (E : Entity_Id) return Boolean is 2123 Result : Boolean := True; 2124 Alias_E : Entity_Id; 2125 Next_E : Entity_Id; 2126 begin 2127 if not Comes_From_Source (E) 2128 and then 2129 Nkind (E) in N_Entity 2130 and then 2131 Ekind (E) in E_Procedure | E_Function 2132 and then 2133 Nkind (Parent (E)) not in 2134 N_Function_Specification | N_Procedure_Specification 2135 and then 2136 Present (Alias (E)) 2137 then 2138 Alias_E := Alias (E); 2139 Next_E := Next_Entity (E); 2140 2141 while Present (Next_E) loop 2142 if Next_E = Alias_E then 2143-- if not Is_Redefined_For_Full_View (E, Alias_E) then 2144 Result := False; 2145-- end if; 2146 2147 exit; 2148 end if; 2149 2150 Next_E := Next_Entity (Next_E); 2151 end loop; 2152 2153 end if; 2154 2155 return Result; 2156 end Not_Overriden_By_Explicit; 2157 2158 ------------------------- 2159 -- Pass_Generic_Actual -- 2160 ------------------------- 2161 2162 function Pass_Generic_Actual (N : Node_Id) return Boolean is 2163 Arg_Node : constant Node_Id := Original_Node (N); 2164 Result : Boolean := False; 2165 begin 2166 2167 -- See the discussion in F424-031 and F427-008 2168 case Nkind (Arg_Node) is 2169 when N_Subtype_Declaration => 2170 Result := 2171 not Comes_From_Source (Arg_Node) 2172 and then 2173 not Is_Internal_Name (Chars (Defining_Identifier (Arg_Node))) 2174 and then 2175 Is_From_Instance (Defining_Identifier (Arg_Node)); 2176 2177 when N_Subprogram_Renaming_Declaration => 2178 Result := Present (Corresponding_Formal_Spec (Arg_Node)); 2179 when N_Object_Renaming_Declaration | 2180 N_Object_Declaration => 2181 Result := 2182 Present (Corresponding_Generic_Association (Arg_Node)) 2183 or else 2184 (not Comes_From_Source (Arg_Node) 2185 and then 2186 Is_From_Instance (Defining_Identifier (Arg_Node))); 2187 when N_Formal_Object_Declaration => 2188 -- Here we should correctly process the situation in the expanded 2189 -- spec that corresponds to a formal package. In case if the 2190 -- given generic formal parameter of the formal package is not 2191 -- specified in the formal package declaration, the corresponding 2192 -- parameter is presented in the expanded spec as a formal 2193 -- parameter, but not as a renaming 2194 Result := 2195 Is_From_Instance (Arg_Node) 2196 and then 2197 Comes_From_Source (Arg_Node) 2198 and then 2199 not Comes_From_Source (Defining_Identifier (Arg_Node)); 2200 when N_Formal_Concrete_Subprogram_Declaration | 2201 N_Formal_Abstract_Subprogram_Declaration => 2202 -- Similar to previous case, but for formal subprograms 2203 Result := 2204 Is_From_Instance (Arg_Node) 2205 and then 2206 Comes_From_Source (Arg_Node) 2207 and then 2208 not Comes_From_Source 2209 (Defining_Unit_Name (Specification (Arg_Node))); 2210 2211 when N_Package_Renaming_Declaration => 2212 -- Formal package... 2213 Result := 2214 not Comes_From_Source (Arg_Node) 2215 and then 2216 Present 2217 (Associated_Formal_Package (Defining_Unit_Name (Arg_Node))); 2218 when others => 2219 null; 2220 end case; 2221 2222 return Result; 2223 end Pass_Generic_Actual; 2224 2225 --------------------------------- 2226 -- Part_Of_Pass_Generic_Actual -- 2227 --------------------------------- 2228 2229 function Part_Of_Pass_Generic_Actual (N : Node_Id) return Boolean is 2230 Result : Boolean := Pass_Generic_Actual (N); 2231 Tmp_N : Node_Id := Parent (N); 2232 begin 2233 2234 if not Result then 2235 2236 while Present (Tmp_N) loop 2237 2238 if Pass_Generic_Actual (Tmp_N) then 2239 Result := True; 2240 exit; 2241 else 2242 2243 case Nkind (Tmp_N) is 2244 -- The idea is to stop tree traversing as soon as possible 2245 when N_Statement_Other_Than_Procedure_Call | 2246 N_Renaming_Declaration | 2247 N_Later_Decl_Item | 2248 N_Component_Declaration | 2249 N_Entry_Declaration | 2250 N_Expression_Function | 2251 N_Formal_Object_Declaration | 2252 N_Formal_Type_Declaration | 2253 N_Full_Type_Declaration | 2254 N_Incomplete_Type_Declaration | 2255 N_Iterator_Specification | 2256 N_Loop_Parameter_Specification | 2257 N_Object_Declaration | 2258 N_Protected_Type_Declaration | 2259 N_Private_Extension_Declaration | 2260 N_Private_Type_Declaration | 2261 N_Formal_Subprogram_Declaration => 2262 exit; 2263 when others => 2264 null; 2265 end case; 2266 2267 end if; 2268 2269 Tmp_N := Parent (Tmp_N); 2270 end loop; 2271 2272 end if; 2273 2274 return Result; 2275 end Part_Of_Pass_Generic_Actual; 2276 2277 ------------------------------- 2278 -- Patched_Comes_From_Source -- 2279 ------------------------------- 2280 2281 function Patched_Comes_From_Source (N : Node_Id) return Boolean is 2282 Tmp : Node_Id; 2283 begin 2284 2285 if Atree.Comes_From_Source (N) then 2286 return True; 2287 else 2288 Tmp := Parent (Parent (N)); 2289 2290 return Present (Tmp) 2291 and then 2292 Nkind (Tmp) = N_Formal_Concrete_Subprogram_Declaration 2293 and then 2294 Atree.Comes_From_Source (Tmp) 2295 and then 2296 Is_From_Instance (Tmp); 2297 end if; 2298 2299 end Patched_Comes_From_Source; 2300 2301 -------------------------------------------- 2302 -- Represents_Class_Wide_Type_In_Instance -- 2303 -------------------------------------------- 2304 2305 function Represents_Class_Wide_Type_In_Instance 2306 (N : Node_Id) 2307 return Boolean 2308 is 2309 Result : Boolean := False; 2310 A_Node : Node_Id; 2311 begin 2312 if Nkind (N) = N_Identifier then 2313 A_Node := Associated_Node (N); 2314 2315 if Present (A_Node) 2316 and then 2317 Nkind (A_Node) in N_Entity 2318 and then 2319 Ekind (A_Node) in Class_Wide_Kind 2320 then 2321 Result := True; 2322 end if; 2323 end if; 2324 2325 return Result; 2326 end Represents_Class_Wide_Type_In_Instance; 2327 2328 -------------------------------------- 2329 -- Represents_Base_Type_In_Instance -- 2330 -------------------------------------- 2331 2332 function Represents_Base_Type_In_Instance (N : Node_Id) return Boolean is 2333 Result : Boolean := False; 2334 begin 2335 if Nkind (N) = N_Identifier 2336 and then 2337 not Comes_From_Source (N) 2338 and then 2339 Is_Internal_Name (Chars (N)) 2340 and then 2341 Present (Associated_Node (N)) 2342 and then 2343 Ekind (Associated_Node (N)) in 2344 Discrete_Or_Fixed_Point_Kind | 2345 E_Floating_Point_Type | 2346 E_Floating_Point_Subtype 2347 then 2348 Result := True; 2349 end if; 2350 2351 return Result; 2352 end Represents_Base_Type_In_Instance; 2353 2354 -------------------- 2355 -- Reset_For_Body -- 2356 -------------------- 2357 2358 procedure Reset_For_Body 2359 (El : in out Asis.Element; 2360 Body_Unit : Asis.Compilation_Unit) 2361 is 2362 Spec_CU : constant Unit_Id := Encl_Unit_Id (El); 2363 Arg_Tree : constant Tree_Id := Encl_Tree (El); 2364 Body_Tree : Tree_Id; 2365 Result_El : Asis.Element := Nil_Element; 2366 2367 -- and the rest of the local declarations is needed for traversal 2368 Spec_El : Asis.Element; 2369 2370 My_State : No_State := Not_Used; 2371 Control : Asis.Traverse_Control := Continue; 2372 2373 procedure Pre_Op 2374 (Element : Asis.Element; 2375 Control : in out Traverse_Control; 2376 State : in out No_State); 2377 2378 procedure Pre_Op 2379 (Element : Asis.Element; 2380 Control : in out Traverse_Control; 2381 State : in out No_State) 2382 is 2383 pragma Unreferenced (State); 2384 2385 El_Kind : constant Internal_Element_Kinds := Int_Kind (Element); 2386 begin 2387 2388 case El_Kind is 2389 when A_Task_Type_Declaration | 2390 A_Single_Task_Declaration | 2391 An_Incomplete_Type_Declaration | 2392 A_Procedure_Declaration | 2393 A_Function_Declaration | 2394 An_Entry_Declaration | 2395 A_Generic_Procedure_Declaration | 2396 A_Generic_Function_Declaration 2397 => 2398 -- here we have declarations which may have completion in the 2399 -- package body, but their subcomponents cannot have a 2400 -- completion 2401 2402 if Is_Equal (Element, El) then 2403 Result_El := Element; 2404 Control := Terminate_Immediately; 2405 else 2406 Control := Abandon_Children; 2407 end if; 2408 2409 when A_Protected_Type_Declaration | 2410 A_Single_Protected_Declaration | 2411 A_Package_Declaration | 2412 A_Generic_Package_Declaration 2413 => 2414 -- here we have declarations which may have completion in the 2415 -- package body, their subcomponents also can have a completion 2416 2417 if Is_Equal (Element, El) then 2418 Result_El := Element; 2419 Control := Terminate_Immediately; 2420 end if; 2421 2422 when A_Protected_Definition => 2423 Control := Continue; 2424 -- To look for protected entries and subprograms 2425 2426 when others => 2427 Control := Abandon_Children; 2428 end case; 2429 2430 end Pre_Op; 2431 2432 procedure Find_For_Reset is new Traverse_Element 2433 (State_Information => No_State, 2434 Pre_Operation => Pre_Op, 2435 Post_Operation => No_Op); 2436 2437 begin 2438 Reset_Tree_For_Unit (Body_Unit); 2439 Body_Tree := Get_Current_Tree; 2440 2441 if Arg_Tree = Body_Tree then 2442 return; 2443 end if; 2444 2445 Spec_El := Node_To_Element_New 2446 (Node => Unit (Top (Spec_CU)), 2447 Starting_Element => El); 2448 2449 Find_For_Reset (Spec_El, Control, My_State); 2450 2451 pragma Assert (not Is_Nil (Result_El)); 2452 2453 El := Result_El; 2454 2455 end Reset_For_Body; 2456 2457 --------------------------------- 2458 -- Set_Stub_For_Subunit_If_Any -- 2459 --------------------------------- 2460 2461 procedure Set_Stub_For_Subunit_If_Any (Def_Name : in out Node_Id) 2462 is 2463 Stub_Node : Node_Id; 2464 Decl_Node : Node_Id; 2465 Node_Context : constant Node_Id := Parent (Parent (Parent (Def_Name))); 2466 begin 2467 2468 if not (Nkind (Def_Name) = N_Defining_Identifier and then 2469 Nkind (Node_Context) = N_Subunit and then 2470 Nkind (Proper_Body (Node_Context)) = N_Subprogram_Body and then 2471 Def_Name = Defining_Unit_Name (Specification 2472 (Proper_Body (Node_Context)))) 2473 then 2474 -- nothing to change 2475 return; 2476 2477 else 2478 Def_Name := Defining_Unit_Name 2479 (Specification (Corresponding_Stub (Node_Context))); 2480 Stub_Node := Parent (Parent (Def_Name)); 2481 Decl_Node := Corr_Decl_For_Stub (Stub_Node); 2482 2483 if Present (Decl_Node) then 2484 Def_Name := Defining_Unit_Name (Specification (Decl_Node)); 2485 end if; 2486 2487 end if; 2488 2489 end Set_Stub_For_Subunit_If_Any; 2490 2491 -------------------------- 2492 -- Type_Def_in_Standard -- 2493 -------------------------- 2494 2495 function Type_Def_in_Standard (E : Entity_Id) return Boolean is 2496 Result : Boolean := False; 2497 begin 2498 if Sloc (E) <= Standard_Location 2499 and then 2500 Nkind (E) = N_Defining_Identifier 2501 and then 2502 Nkind (Parent (E)) = N_Full_Type_Declaration 2503 then 2504 Result := True; 2505 end if; 2506 2507 return Result; 2508 end Type_Def_in_Standard; 2509 2510 --------------------- 2511 -- Unwind_Renaming -- 2512 --------------------- 2513 2514 function Unwind_Renaming (Def_Name : Node_Id) return Node_Id is 2515 Parent_Decl : Node_Id; 2516 Result_Node : Node_Id; 2517 begin 2518 -- a recursive algorithm is probably not the most effective, 2519 -- but it is easy-to-maintain. Moreover, we do not really 2520 -- expect long renaming chains in not-crazy programs 2521 -- When the implementation of this function is stable, we probably 2522 -- should replace the recursive code by the iteration-based code 2523 2524 Result_Node := Def_Name; 2525 Parent_Decl := Parent (Result_Node); 2526 2527 case Nkind (Parent_Decl) is 2528 2529 when N_Renaming_Declaration => 2530 -- unwinding once again 2531 Result_Node := Sinfo.Name (Entity (Parent_Decl)); 2532 2533 return Unwind_Renaming (Result_Node); 2534 2535 when N_Function_Specification | N_Procedure_Specification => 2536 -- two cases are possible: if this subprogram specification 2537 -- is the component of another (subprogram) renaming 2538 -- declaration, we should unwind again, 2539 -- otherwise we have got the result: 2540 2541 if Nkind (Parent (Parent_Decl)) = 2542 N_Subprogram_Renaming_Declaration 2543 then 2544 -- unwinding once again 2545 -- Result_Node := Sinfo.Name (Entity (Parent (Parent_Decl))); 2546 Result_Node := Entity (Sinfo.Name (Parent (Parent_Decl))); 2547 2548 return Unwind_Renaming (Result_Node); 2549 2550 else 2551 2552 if Is_Rewrite_Substitution (Parent (Parent_Decl)) and then 2553 Nkind (Original_Node (Parent (Parent_Decl))) = 2554 N_Subprogram_Renaming_Declaration 2555 then 2556 -- this means, that we have met the renaming of a 2557 -- subprogram-attribute, so 2558 return Empty; 2559 2560 else 2561 -- all the ransoming (if any) have already been unwounded 2562 return Result_Node; 2563 2564 end if; 2565 2566 end if; 2567 2568 when others => 2569 2570 return Result_Node; 2571 2572 end case; 2573 2574 end Unwind_Renaming; 2575 2576end A4G.A_Sem; 2577