1------------------------------------------------------------------------------ 2-- -- 3-- GNAT COMPILER COMPONENTS -- 4-- -- 5-- S E M _ U T I L -- 6-- -- 7-- B o d y -- 8-- -- 9-- Copyright (C) 1992-2013, Free Software Foundation, Inc. -- 10-- -- 11-- GNAT is free software; you can redistribute it and/or modify it under -- 12-- terms of the GNU General Public License as published by the Free Soft- -- 13-- ware Foundation; either version 3, or (at your option) any later ver- -- 14-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- 15-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- 16-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- 17-- for more details. You should have received a copy of the GNU General -- 18-- Public License distributed with GNAT; see file COPYING3. If not, go to -- 19-- http://www.gnu.org/licenses for a complete copy of the license. -- 20-- -- 21-- GNAT was originally developed by the GNAT team at New York University. -- 22-- Extensive contributions were provided by Ada Core Technologies Inc. -- 23-- -- 24------------------------------------------------------------------------------ 25 26with Atree; use Atree; 27with Casing; use Casing; 28with Checks; use Checks; 29with Debug; use Debug; 30with Errout; use Errout; 31with Elists; use Elists; 32with Exp_Ch11; use Exp_Ch11; 33with Exp_Disp; use Exp_Disp; 34with Exp_Util; use Exp_Util; 35with Fname; use Fname; 36with Freeze; use Freeze; 37with Lib; use Lib; 38with Lib.Xref; use Lib.Xref; 39with Namet.Sp; use Namet.Sp; 40with Nlists; use Nlists; 41with Nmake; use Nmake; 42with Output; use Output; 43with Opt; use Opt; 44with Restrict; use Restrict; 45with Rident; use Rident; 46with Rtsfind; use Rtsfind; 47with Sem; use Sem; 48with Sem_Aux; use Sem_Aux; 49with Sem_Attr; use Sem_Attr; 50with Sem_Ch8; use Sem_Ch8; 51with Sem_Disp; use Sem_Disp; 52with Sem_Eval; use Sem_Eval; 53with Sem_Res; use Sem_Res; 54with Sem_Type; use Sem_Type; 55with Sinfo; use Sinfo; 56with Sinput; use Sinput; 57with Stand; use Stand; 58with Style; 59with Stringt; use Stringt; 60with Targparm; use Targparm; 61with Tbuild; use Tbuild; 62with Ttypes; use Ttypes; 63with Uname; use Uname; 64 65with GNAT.HTable; use GNAT.HTable; 66 67package body Sem_Util is 68 69 ---------------------------------------- 70 -- Global_Variables for New_Copy_Tree -- 71 ---------------------------------------- 72 73 -- These global variables are used by New_Copy_Tree. See description 74 -- of the body of this subprogram for details. Global variables can be 75 -- safely used by New_Copy_Tree, since there is no case of a recursive 76 -- call from the processing inside New_Copy_Tree. 77 78 NCT_Hash_Threshold : constant := 20; 79 -- If there are more than this number of pairs of entries in the 80 -- map, then Hash_Tables_Used will be set, and the hash tables will 81 -- be initialized and used for the searches. 82 83 NCT_Hash_Tables_Used : Boolean := False; 84 -- Set to True if hash tables are in use 85 86 NCT_Table_Entries : Nat; 87 -- Count entries in table to see if threshold is reached 88 89 NCT_Hash_Table_Setup : Boolean := False; 90 -- Set to True if hash table contains data. We set this True if we 91 -- setup the hash table with data, and leave it set permanently 92 -- from then on, this is a signal that second and subsequent users 93 -- of the hash table must clear the old entries before reuse. 94 95 subtype NCT_Header_Num is Int range 0 .. 511; 96 -- Defines range of headers in hash tables (512 headers) 97 98 ----------------------- 99 -- Local Subprograms -- 100 ----------------------- 101 102 function Build_Component_Subtype 103 (C : List_Id; 104 Loc : Source_Ptr; 105 T : Entity_Id) return Node_Id; 106 -- This function builds the subtype for Build_Actual_Subtype_Of_Component 107 -- and Build_Discriminal_Subtype_Of_Component. C is a list of constraints, 108 -- Loc is the source location, T is the original subtype. 109 110 function Is_Fully_Initialized_Variant (Typ : Entity_Id) return Boolean; 111 -- Subsidiary to Is_Fully_Initialized_Type. For an unconstrained type 112 -- with discriminants whose default values are static, examine only the 113 -- components in the selected variant to determine whether all of them 114 -- have a default. 115 116 function Has_Null_Extension (T : Entity_Id) return Boolean; 117 -- T is a derived tagged type. Check whether the type extension is null. 118 -- If the parent type is fully initialized, T can be treated as such. 119 120 ------------------------------ 121 -- Abstract_Interface_List -- 122 ------------------------------ 123 124 function Abstract_Interface_List (Typ : Entity_Id) return List_Id is 125 Nod : Node_Id; 126 127 begin 128 if Is_Concurrent_Type (Typ) then 129 130 -- If we are dealing with a synchronized subtype, go to the base 131 -- type, whose declaration has the interface list. 132 133 -- Shouldn't this be Declaration_Node??? 134 135 Nod := Parent (Base_Type (Typ)); 136 137 if Nkind (Nod) = N_Full_Type_Declaration then 138 return Empty_List; 139 end if; 140 141 elsif Ekind (Typ) = E_Record_Type_With_Private then 142 if Nkind (Parent (Typ)) = N_Full_Type_Declaration then 143 Nod := Type_Definition (Parent (Typ)); 144 145 elsif Nkind (Parent (Typ)) = N_Private_Type_Declaration then 146 if Present (Full_View (Typ)) 147 and then Nkind (Parent (Full_View (Typ))) 148 = N_Full_Type_Declaration 149 then 150 Nod := Type_Definition (Parent (Full_View (Typ))); 151 152 -- If the full-view is not available we cannot do anything else 153 -- here (the source has errors). 154 155 else 156 return Empty_List; 157 end if; 158 159 -- Support for generic formals with interfaces is still missing ??? 160 161 elsif Nkind (Parent (Typ)) = N_Formal_Type_Declaration then 162 return Empty_List; 163 164 else 165 pragma Assert 166 (Nkind (Parent (Typ)) = N_Private_Extension_Declaration); 167 Nod := Parent (Typ); 168 end if; 169 170 elsif Ekind (Typ) = E_Record_Subtype then 171 Nod := Type_Definition (Parent (Etype (Typ))); 172 173 elsif Ekind (Typ) = E_Record_Subtype_With_Private then 174 175 -- Recurse, because parent may still be a private extension. Also 176 -- note that the full view of the subtype or the full view of its 177 -- base type may (both) be unavailable. 178 179 return Abstract_Interface_List (Etype (Typ)); 180 181 else pragma Assert ((Ekind (Typ)) = E_Record_Type); 182 if Nkind (Parent (Typ)) = N_Formal_Type_Declaration then 183 Nod := Formal_Type_Definition (Parent (Typ)); 184 else 185 Nod := Type_Definition (Parent (Typ)); 186 end if; 187 end if; 188 189 return Interface_List (Nod); 190 end Abstract_Interface_List; 191 192 -------------------------------- 193 -- Add_Access_Type_To_Process -- 194 -------------------------------- 195 196 procedure Add_Access_Type_To_Process (E : Entity_Id; A : Entity_Id) is 197 L : Elist_Id; 198 199 begin 200 Ensure_Freeze_Node (E); 201 L := Access_Types_To_Process (Freeze_Node (E)); 202 203 if No (L) then 204 L := New_Elmt_List; 205 Set_Access_Types_To_Process (Freeze_Node (E), L); 206 end if; 207 208 Append_Elmt (A, L); 209 end Add_Access_Type_To_Process; 210 211 ---------------------------- 212 -- Add_Global_Declaration -- 213 ---------------------------- 214 215 procedure Add_Global_Declaration (N : Node_Id) is 216 Aux_Node : constant Node_Id := Aux_Decls_Node (Cunit (Current_Sem_Unit)); 217 218 begin 219 if No (Declarations (Aux_Node)) then 220 Set_Declarations (Aux_Node, New_List); 221 end if; 222 223 Append_To (Declarations (Aux_Node), N); 224 Analyze (N); 225 end Add_Global_Declaration; 226 227 ----------------- 228 -- Addressable -- 229 ----------------- 230 231 -- For now, just 8/16/32/64. but analyze later if AAMP is special??? 232 233 function Addressable (V : Uint) return Boolean is 234 begin 235 return V = Uint_8 or else 236 V = Uint_16 or else 237 V = Uint_32 or else 238 V = Uint_64; 239 end Addressable; 240 241 function Addressable (V : Int) return Boolean is 242 begin 243 return V = 8 or else 244 V = 16 or else 245 V = 32 or else 246 V = 64; 247 end Addressable; 248 249 ----------------------- 250 -- Alignment_In_Bits -- 251 ----------------------- 252 253 function Alignment_In_Bits (E : Entity_Id) return Uint is 254 begin 255 return Alignment (E) * System_Storage_Unit; 256 end Alignment_In_Bits; 257 258 --------------------------------- 259 -- Append_Inherited_Subprogram -- 260 --------------------------------- 261 262 procedure Append_Inherited_Subprogram (S : Entity_Id) is 263 Par : constant Entity_Id := Alias (S); 264 -- The parent subprogram 265 266 Scop : constant Entity_Id := Scope (Par); 267 -- The scope of definition of the parent subprogram 268 269 Typ : constant Entity_Id := Defining_Entity (Parent (S)); 270 -- The derived type of which S is a primitive operation 271 272 Decl : Node_Id; 273 Next_E : Entity_Id; 274 275 begin 276 if Ekind (Current_Scope) = E_Package 277 and then In_Private_Part (Current_Scope) 278 and then Has_Private_Declaration (Typ) 279 and then Is_Tagged_Type (Typ) 280 and then Scop = Current_Scope 281 then 282 -- The inherited operation is available at the earliest place after 283 -- the derived type declaration ( RM 7.3.1 (6/1)). This is only 284 -- relevant for type extensions. If the parent operation appears 285 -- after the type extension, the operation is not visible. 286 287 Decl := First 288 (Visible_Declarations 289 (Specification (Unit_Declaration_Node (Current_Scope)))); 290 while Present (Decl) loop 291 if Nkind (Decl) = N_Private_Extension_Declaration 292 and then Defining_Entity (Decl) = Typ 293 then 294 if Sloc (Decl) > Sloc (Par) then 295 Next_E := Next_Entity (Par); 296 Set_Next_Entity (Par, S); 297 Set_Next_Entity (S, Next_E); 298 return; 299 300 else 301 exit; 302 end if; 303 end if; 304 305 Next (Decl); 306 end loop; 307 end if; 308 309 -- If partial view is not a type extension, or it appears before the 310 -- subprogram declaration, insert normally at end of entity list. 311 312 Append_Entity (S, Current_Scope); 313 end Append_Inherited_Subprogram; 314 315 ----------------------------------------- 316 -- Apply_Compile_Time_Constraint_Error -- 317 ----------------------------------------- 318 319 procedure Apply_Compile_Time_Constraint_Error 320 (N : Node_Id; 321 Msg : String; 322 Reason : RT_Exception_Code; 323 Ent : Entity_Id := Empty; 324 Typ : Entity_Id := Empty; 325 Loc : Source_Ptr := No_Location; 326 Rep : Boolean := True; 327 Warn : Boolean := False) 328 is 329 Stat : constant Boolean := Is_Static_Expression (N); 330 R_Stat : constant Node_Id := 331 Make_Raise_Constraint_Error (Sloc (N), Reason => Reason); 332 Rtyp : Entity_Id; 333 334 begin 335 if No (Typ) then 336 Rtyp := Etype (N); 337 else 338 Rtyp := Typ; 339 end if; 340 341 Discard_Node 342 (Compile_Time_Constraint_Error (N, Msg, Ent, Loc, Warn => Warn)); 343 344 if not Rep then 345 return; 346 end if; 347 348 -- Now we replace the node by an N_Raise_Constraint_Error node 349 -- This does not need reanalyzing, so set it as analyzed now. 350 351 Rewrite (N, R_Stat); 352 Set_Analyzed (N, True); 353 354 Set_Etype (N, Rtyp); 355 Set_Raises_Constraint_Error (N); 356 357 -- Now deal with possible local raise handling 358 359 Possible_Local_Raise (N, Standard_Constraint_Error); 360 361 -- If the original expression was marked as static, the result is 362 -- still marked as static, but the Raises_Constraint_Error flag is 363 -- always set so that further static evaluation is not attempted. 364 365 if Stat then 366 Set_Is_Static_Expression (N); 367 end if; 368 end Apply_Compile_Time_Constraint_Error; 369 370 -------------------------------------- 371 -- Available_Full_View_Of_Component -- 372 -------------------------------------- 373 374 function Available_Full_View_Of_Component (T : Entity_Id) return Boolean is 375 ST : constant Entity_Id := Scope (T); 376 SCT : constant Entity_Id := Scope (Component_Type (T)); 377 begin 378 return In_Open_Scopes (ST) 379 and then In_Open_Scopes (SCT) 380 and then Scope_Depth (ST) >= Scope_Depth (SCT); 381 end Available_Full_View_Of_Component; 382 383 ------------------- 384 -- Bad_Attribute -- 385 ------------------- 386 387 procedure Bad_Attribute 388 (N : Node_Id; 389 Nam : Name_Id; 390 Warn : Boolean := False) 391 is 392 begin 393 Error_Msg_Warn := Warn; 394 Error_Msg_N ("unrecognized attribute&<", N); 395 396 -- Check for possible misspelling 397 398 Error_Msg_Name_1 := First_Attribute_Name; 399 while Error_Msg_Name_1 <= Last_Attribute_Name loop 400 if Is_Bad_Spelling_Of (Nam, Error_Msg_Name_1) then 401 Error_Msg_N -- CODEFIX 402 ("\possible misspelling of %<", N); 403 exit; 404 end if; 405 406 Error_Msg_Name_1 := Error_Msg_Name_1 + 1; 407 end loop; 408 end Bad_Attribute; 409 410 -------------------------------- 411 -- Bad_Predicated_Subtype_Use -- 412 -------------------------------- 413 414 procedure Bad_Predicated_Subtype_Use 415 (Msg : String; 416 N : Node_Id; 417 Typ : Entity_Id) 418 is 419 begin 420 if Has_Predicates (Typ) then 421 if Is_Generic_Actual_Type (Typ) then 422 Error_Msg_FE (Msg & "??", N, Typ); 423 Error_Msg_F ("\Program_Error will be raised at run time??", N); 424 Insert_Action (N, 425 Make_Raise_Program_Error (Sloc (N), 426 Reason => PE_Bad_Predicated_Generic_Type)); 427 428 else 429 Error_Msg_FE (Msg, N, Typ); 430 end if; 431 end if; 432 end Bad_Predicated_Subtype_Use; 433 434 -------------------------- 435 -- Build_Actual_Subtype -- 436 -------------------------- 437 438 function Build_Actual_Subtype 439 (T : Entity_Id; 440 N : Node_Or_Entity_Id) return Node_Id 441 is 442 Loc : Source_Ptr; 443 -- Normally Sloc (N), but may point to corresponding body in some cases 444 445 Constraints : List_Id; 446 Decl : Node_Id; 447 Discr : Entity_Id; 448 Hi : Node_Id; 449 Lo : Node_Id; 450 Subt : Entity_Id; 451 Disc_Type : Entity_Id; 452 Obj : Node_Id; 453 454 begin 455 Loc := Sloc (N); 456 457 if Nkind (N) = N_Defining_Identifier then 458 Obj := New_Reference_To (N, Loc); 459 460 -- If this is a formal parameter of a subprogram declaration, and 461 -- we are compiling the body, we want the declaration for the 462 -- actual subtype to carry the source position of the body, to 463 -- prevent anomalies in gdb when stepping through the code. 464 465 if Is_Formal (N) then 466 declare 467 Decl : constant Node_Id := Unit_Declaration_Node (Scope (N)); 468 begin 469 if Nkind (Decl) = N_Subprogram_Declaration 470 and then Present (Corresponding_Body (Decl)) 471 then 472 Loc := Sloc (Corresponding_Body (Decl)); 473 end if; 474 end; 475 end if; 476 477 else 478 Obj := N; 479 end if; 480 481 if Is_Array_Type (T) then 482 Constraints := New_List; 483 for J in 1 .. Number_Dimensions (T) loop 484 485 -- Build an array subtype declaration with the nominal subtype and 486 -- the bounds of the actual. Add the declaration in front of the 487 -- local declarations for the subprogram, for analysis before any 488 -- reference to the formal in the body. 489 490 Lo := 491 Make_Attribute_Reference (Loc, 492 Prefix => 493 Duplicate_Subexpr_No_Checks (Obj, Name_Req => True), 494 Attribute_Name => Name_First, 495 Expressions => New_List ( 496 Make_Integer_Literal (Loc, J))); 497 498 Hi := 499 Make_Attribute_Reference (Loc, 500 Prefix => 501 Duplicate_Subexpr_No_Checks (Obj, Name_Req => True), 502 Attribute_Name => Name_Last, 503 Expressions => New_List ( 504 Make_Integer_Literal (Loc, J))); 505 506 Append (Make_Range (Loc, Lo, Hi), Constraints); 507 end loop; 508 509 -- If the type has unknown discriminants there is no constrained 510 -- subtype to build. This is never called for a formal or for a 511 -- lhs, so returning the type is ok ??? 512 513 elsif Has_Unknown_Discriminants (T) then 514 return T; 515 516 else 517 Constraints := New_List; 518 519 -- Type T is a generic derived type, inherit the discriminants from 520 -- the parent type. 521 522 if Is_Private_Type (T) 523 and then No (Full_View (T)) 524 525 -- T was flagged as an error if it was declared as a formal 526 -- derived type with known discriminants. In this case there 527 -- is no need to look at the parent type since T already carries 528 -- its own discriminants. 529 530 and then not Error_Posted (T) 531 then 532 Disc_Type := Etype (Base_Type (T)); 533 else 534 Disc_Type := T; 535 end if; 536 537 Discr := First_Discriminant (Disc_Type); 538 while Present (Discr) loop 539 Append_To (Constraints, 540 Make_Selected_Component (Loc, 541 Prefix => 542 Duplicate_Subexpr_No_Checks (Obj), 543 Selector_Name => New_Occurrence_Of (Discr, Loc))); 544 Next_Discriminant (Discr); 545 end loop; 546 end if; 547 548 Subt := Make_Temporary (Loc, 'S', Related_Node => N); 549 Set_Is_Internal (Subt); 550 551 Decl := 552 Make_Subtype_Declaration (Loc, 553 Defining_Identifier => Subt, 554 Subtype_Indication => 555 Make_Subtype_Indication (Loc, 556 Subtype_Mark => New_Reference_To (T, Loc), 557 Constraint => 558 Make_Index_Or_Discriminant_Constraint (Loc, 559 Constraints => Constraints))); 560 561 Mark_Rewrite_Insertion (Decl); 562 return Decl; 563 end Build_Actual_Subtype; 564 565 --------------------------------------- 566 -- Build_Actual_Subtype_Of_Component -- 567 --------------------------------------- 568 569 function Build_Actual_Subtype_Of_Component 570 (T : Entity_Id; 571 N : Node_Id) return Node_Id 572 is 573 Loc : constant Source_Ptr := Sloc (N); 574 P : constant Node_Id := Prefix (N); 575 D : Elmt_Id; 576 Id : Node_Id; 577 Index_Typ : Entity_Id; 578 579 Desig_Typ : Entity_Id; 580 -- This is either a copy of T, or if T is an access type, then it is 581 -- the directly designated type of this access type. 582 583 function Build_Actual_Array_Constraint return List_Id; 584 -- If one or more of the bounds of the component depends on 585 -- discriminants, build actual constraint using the discriminants 586 -- of the prefix. 587 588 function Build_Actual_Record_Constraint return List_Id; 589 -- Similar to previous one, for discriminated components constrained 590 -- by the discriminant of the enclosing object. 591 592 ----------------------------------- 593 -- Build_Actual_Array_Constraint -- 594 ----------------------------------- 595 596 function Build_Actual_Array_Constraint return List_Id is 597 Constraints : constant List_Id := New_List; 598 Indx : Node_Id; 599 Hi : Node_Id; 600 Lo : Node_Id; 601 Old_Hi : Node_Id; 602 Old_Lo : Node_Id; 603 604 begin 605 Indx := First_Index (Desig_Typ); 606 while Present (Indx) loop 607 Old_Lo := Type_Low_Bound (Etype (Indx)); 608 Old_Hi := Type_High_Bound (Etype (Indx)); 609 610 if Denotes_Discriminant (Old_Lo) then 611 Lo := 612 Make_Selected_Component (Loc, 613 Prefix => New_Copy_Tree (P), 614 Selector_Name => New_Occurrence_Of (Entity (Old_Lo), Loc)); 615 616 else 617 Lo := New_Copy_Tree (Old_Lo); 618 619 -- The new bound will be reanalyzed in the enclosing 620 -- declaration. For literal bounds that come from a type 621 -- declaration, the type of the context must be imposed, so 622 -- insure that analysis will take place. For non-universal 623 -- types this is not strictly necessary. 624 625 Set_Analyzed (Lo, False); 626 end if; 627 628 if Denotes_Discriminant (Old_Hi) then 629 Hi := 630 Make_Selected_Component (Loc, 631 Prefix => New_Copy_Tree (P), 632 Selector_Name => New_Occurrence_Of (Entity (Old_Hi), Loc)); 633 634 else 635 Hi := New_Copy_Tree (Old_Hi); 636 Set_Analyzed (Hi, False); 637 end if; 638 639 Append (Make_Range (Loc, Lo, Hi), Constraints); 640 Next_Index (Indx); 641 end loop; 642 643 return Constraints; 644 end Build_Actual_Array_Constraint; 645 646 ------------------------------------ 647 -- Build_Actual_Record_Constraint -- 648 ------------------------------------ 649 650 function Build_Actual_Record_Constraint return List_Id is 651 Constraints : constant List_Id := New_List; 652 D : Elmt_Id; 653 D_Val : Node_Id; 654 655 begin 656 D := First_Elmt (Discriminant_Constraint (Desig_Typ)); 657 while Present (D) loop 658 if Denotes_Discriminant (Node (D)) then 659 D_Val := Make_Selected_Component (Loc, 660 Prefix => New_Copy_Tree (P), 661 Selector_Name => New_Occurrence_Of (Entity (Node (D)), Loc)); 662 663 else 664 D_Val := New_Copy_Tree (Node (D)); 665 end if; 666 667 Append (D_Val, Constraints); 668 Next_Elmt (D); 669 end loop; 670 671 return Constraints; 672 end Build_Actual_Record_Constraint; 673 674 -- Start of processing for Build_Actual_Subtype_Of_Component 675 676 begin 677 -- Why the test for Spec_Expression mode here??? 678 679 if In_Spec_Expression then 680 return Empty; 681 682 -- More comments for the rest of this body would be good ??? 683 684 elsif Nkind (N) = N_Explicit_Dereference then 685 if Is_Composite_Type (T) 686 and then not Is_Constrained (T) 687 and then not (Is_Class_Wide_Type (T) 688 and then Is_Constrained (Root_Type (T))) 689 and then not Has_Unknown_Discriminants (T) 690 then 691 -- If the type of the dereference is already constrained, it is an 692 -- actual subtype. 693 694 if Is_Array_Type (Etype (N)) 695 and then Is_Constrained (Etype (N)) 696 then 697 return Empty; 698 else 699 Remove_Side_Effects (P); 700 return Build_Actual_Subtype (T, N); 701 end if; 702 else 703 return Empty; 704 end if; 705 end if; 706 707 if Ekind (T) = E_Access_Subtype then 708 Desig_Typ := Designated_Type (T); 709 else 710 Desig_Typ := T; 711 end if; 712 713 if Ekind (Desig_Typ) = E_Array_Subtype then 714 Id := First_Index (Desig_Typ); 715 while Present (Id) loop 716 Index_Typ := Underlying_Type (Etype (Id)); 717 718 if Denotes_Discriminant (Type_Low_Bound (Index_Typ)) 719 or else 720 Denotes_Discriminant (Type_High_Bound (Index_Typ)) 721 then 722 Remove_Side_Effects (P); 723 return 724 Build_Component_Subtype 725 (Build_Actual_Array_Constraint, Loc, Base_Type (T)); 726 end if; 727 728 Next_Index (Id); 729 end loop; 730 731 elsif Is_Composite_Type (Desig_Typ) 732 and then Has_Discriminants (Desig_Typ) 733 and then not Has_Unknown_Discriminants (Desig_Typ) 734 then 735 if Is_Private_Type (Desig_Typ) 736 and then No (Discriminant_Constraint (Desig_Typ)) 737 then 738 Desig_Typ := Full_View (Desig_Typ); 739 end if; 740 741 D := First_Elmt (Discriminant_Constraint (Desig_Typ)); 742 while Present (D) loop 743 if Denotes_Discriminant (Node (D)) then 744 Remove_Side_Effects (P); 745 return 746 Build_Component_Subtype ( 747 Build_Actual_Record_Constraint, Loc, Base_Type (T)); 748 end if; 749 750 Next_Elmt (D); 751 end loop; 752 end if; 753 754 -- If none of the above, the actual and nominal subtypes are the same 755 756 return Empty; 757 end Build_Actual_Subtype_Of_Component; 758 759 ----------------------------- 760 -- Build_Component_Subtype -- 761 ----------------------------- 762 763 function Build_Component_Subtype 764 (C : List_Id; 765 Loc : Source_Ptr; 766 T : Entity_Id) return Node_Id 767 is 768 Subt : Entity_Id; 769 Decl : Node_Id; 770 771 begin 772 -- Unchecked_Union components do not require component subtypes 773 774 if Is_Unchecked_Union (T) then 775 return Empty; 776 end if; 777 778 Subt := Make_Temporary (Loc, 'S'); 779 Set_Is_Internal (Subt); 780 781 Decl := 782 Make_Subtype_Declaration (Loc, 783 Defining_Identifier => Subt, 784 Subtype_Indication => 785 Make_Subtype_Indication (Loc, 786 Subtype_Mark => New_Reference_To (Base_Type (T), Loc), 787 Constraint => 788 Make_Index_Or_Discriminant_Constraint (Loc, 789 Constraints => C))); 790 791 Mark_Rewrite_Insertion (Decl); 792 return Decl; 793 end Build_Component_Subtype; 794 795 --------------------------- 796 -- Build_Default_Subtype -- 797 --------------------------- 798 799 function Build_Default_Subtype 800 (T : Entity_Id; 801 N : Node_Id) return Entity_Id 802 is 803 Loc : constant Source_Ptr := Sloc (N); 804 Disc : Entity_Id; 805 806 Bas : Entity_Id; 807 -- The base type that is to be constrained by the defaults 808 809 begin 810 if not Has_Discriminants (T) or else Is_Constrained (T) then 811 return T; 812 end if; 813 814 Bas := Base_Type (T); 815 816 -- If T is non-private but its base type is private, this is the 817 -- completion of a subtype declaration whose parent type is private 818 -- (see Complete_Private_Subtype in Sem_Ch3). The proper discriminants 819 -- are to be found in the full view of the base. 820 821 if Is_Private_Type (Bas) and then Present (Full_View (Bas)) then 822 Bas := Full_View (Bas); 823 end if; 824 825 Disc := First_Discriminant (T); 826 827 if No (Discriminant_Default_Value (Disc)) then 828 return T; 829 end if; 830 831 declare 832 Act : constant Entity_Id := Make_Temporary (Loc, 'S'); 833 Constraints : constant List_Id := New_List; 834 Decl : Node_Id; 835 836 begin 837 while Present (Disc) loop 838 Append_To (Constraints, 839 New_Copy_Tree (Discriminant_Default_Value (Disc))); 840 Next_Discriminant (Disc); 841 end loop; 842 843 Decl := 844 Make_Subtype_Declaration (Loc, 845 Defining_Identifier => Act, 846 Subtype_Indication => 847 Make_Subtype_Indication (Loc, 848 Subtype_Mark => New_Occurrence_Of (Bas, Loc), 849 Constraint => 850 Make_Index_Or_Discriminant_Constraint (Loc, 851 Constraints => Constraints))); 852 853 Insert_Action (N, Decl); 854 Analyze (Decl); 855 return Act; 856 end; 857 end Build_Default_Subtype; 858 859 -------------------------------------------- 860 -- Build_Discriminal_Subtype_Of_Component -- 861 -------------------------------------------- 862 863 function Build_Discriminal_Subtype_Of_Component 864 (T : Entity_Id) return Node_Id 865 is 866 Loc : constant Source_Ptr := Sloc (T); 867 D : Elmt_Id; 868 Id : Node_Id; 869 870 function Build_Discriminal_Array_Constraint return List_Id; 871 -- If one or more of the bounds of the component depends on 872 -- discriminants, build actual constraint using the discriminants 873 -- of the prefix. 874 875 function Build_Discriminal_Record_Constraint return List_Id; 876 -- Similar to previous one, for discriminated components constrained by 877 -- the discriminant of the enclosing object. 878 879 ---------------------------------------- 880 -- Build_Discriminal_Array_Constraint -- 881 ---------------------------------------- 882 883 function Build_Discriminal_Array_Constraint return List_Id is 884 Constraints : constant List_Id := New_List; 885 Indx : Node_Id; 886 Hi : Node_Id; 887 Lo : Node_Id; 888 Old_Hi : Node_Id; 889 Old_Lo : Node_Id; 890 891 begin 892 Indx := First_Index (T); 893 while Present (Indx) loop 894 Old_Lo := Type_Low_Bound (Etype (Indx)); 895 Old_Hi := Type_High_Bound (Etype (Indx)); 896 897 if Denotes_Discriminant (Old_Lo) then 898 Lo := New_Occurrence_Of (Discriminal (Entity (Old_Lo)), Loc); 899 900 else 901 Lo := New_Copy_Tree (Old_Lo); 902 end if; 903 904 if Denotes_Discriminant (Old_Hi) then 905 Hi := New_Occurrence_Of (Discriminal (Entity (Old_Hi)), Loc); 906 907 else 908 Hi := New_Copy_Tree (Old_Hi); 909 end if; 910 911 Append (Make_Range (Loc, Lo, Hi), Constraints); 912 Next_Index (Indx); 913 end loop; 914 915 return Constraints; 916 end Build_Discriminal_Array_Constraint; 917 918 ----------------------------------------- 919 -- Build_Discriminal_Record_Constraint -- 920 ----------------------------------------- 921 922 function Build_Discriminal_Record_Constraint return List_Id is 923 Constraints : constant List_Id := New_List; 924 D : Elmt_Id; 925 D_Val : Node_Id; 926 927 begin 928 D := First_Elmt (Discriminant_Constraint (T)); 929 while Present (D) loop 930 if Denotes_Discriminant (Node (D)) then 931 D_Val := 932 New_Occurrence_Of (Discriminal (Entity (Node (D))), Loc); 933 934 else 935 D_Val := New_Copy_Tree (Node (D)); 936 end if; 937 938 Append (D_Val, Constraints); 939 Next_Elmt (D); 940 end loop; 941 942 return Constraints; 943 end Build_Discriminal_Record_Constraint; 944 945 -- Start of processing for Build_Discriminal_Subtype_Of_Component 946 947 begin 948 if Ekind (T) = E_Array_Subtype then 949 Id := First_Index (T); 950 while Present (Id) loop 951 if Denotes_Discriminant (Type_Low_Bound (Etype (Id))) or else 952 Denotes_Discriminant (Type_High_Bound (Etype (Id))) 953 then 954 return Build_Component_Subtype 955 (Build_Discriminal_Array_Constraint, Loc, T); 956 end if; 957 958 Next_Index (Id); 959 end loop; 960 961 elsif Ekind (T) = E_Record_Subtype 962 and then Has_Discriminants (T) 963 and then not Has_Unknown_Discriminants (T) 964 then 965 D := First_Elmt (Discriminant_Constraint (T)); 966 while Present (D) loop 967 if Denotes_Discriminant (Node (D)) then 968 return Build_Component_Subtype 969 (Build_Discriminal_Record_Constraint, Loc, T); 970 end if; 971 972 Next_Elmt (D); 973 end loop; 974 end if; 975 976 -- If none of the above, the actual and nominal subtypes are the same 977 978 return Empty; 979 end Build_Discriminal_Subtype_Of_Component; 980 981 ------------------------------ 982 -- Build_Elaboration_Entity -- 983 ------------------------------ 984 985 procedure Build_Elaboration_Entity (N : Node_Id; Spec_Id : Entity_Id) is 986 Loc : constant Source_Ptr := Sloc (N); 987 Decl : Node_Id; 988 Elab_Ent : Entity_Id; 989 990 procedure Set_Package_Name (Ent : Entity_Id); 991 -- Given an entity, sets the fully qualified name of the entity in 992 -- Name_Buffer, with components separated by double underscores. This 993 -- is a recursive routine that climbs the scope chain to Standard. 994 995 ---------------------- 996 -- Set_Package_Name -- 997 ---------------------- 998 999 procedure Set_Package_Name (Ent : Entity_Id) is 1000 begin 1001 if Scope (Ent) /= Standard_Standard then 1002 Set_Package_Name (Scope (Ent)); 1003 1004 declare 1005 Nam : constant String := Get_Name_String (Chars (Ent)); 1006 begin 1007 Name_Buffer (Name_Len + 1) := '_'; 1008 Name_Buffer (Name_Len + 2) := '_'; 1009 Name_Buffer (Name_Len + 3 .. Name_Len + Nam'Length + 2) := Nam; 1010 Name_Len := Name_Len + Nam'Length + 2; 1011 end; 1012 1013 else 1014 Get_Name_String (Chars (Ent)); 1015 end if; 1016 end Set_Package_Name; 1017 1018 -- Start of processing for Build_Elaboration_Entity 1019 1020 begin 1021 -- Ignore if already constructed 1022 1023 if Present (Elaboration_Entity (Spec_Id)) then 1024 return; 1025 end if; 1026 1027 -- Construct name of elaboration entity as xxx_E, where xxx is the unit 1028 -- name with dots replaced by double underscore. We have to manually 1029 -- construct this name, since it will be elaborated in the outer scope, 1030 -- and thus will not have the unit name automatically prepended. 1031 1032 Set_Package_Name (Spec_Id); 1033 Add_Str_To_Name_Buffer ("_E"); 1034 1035 -- Create elaboration counter 1036 1037 Elab_Ent := Make_Defining_Identifier (Loc, Chars => Name_Find); 1038 Set_Elaboration_Entity (Spec_Id, Elab_Ent); 1039 1040 Decl := 1041 Make_Object_Declaration (Loc, 1042 Defining_Identifier => Elab_Ent, 1043 Object_Definition => 1044 New_Occurrence_Of (Standard_Short_Integer, Loc), 1045 Expression => Make_Integer_Literal (Loc, Uint_0)); 1046 1047 Push_Scope (Standard_Standard); 1048 Add_Global_Declaration (Decl); 1049 Pop_Scope; 1050 1051 -- Reset True_Constant indication, since we will indeed assign a value 1052 -- to the variable in the binder main. We also kill the Current_Value 1053 -- and Last_Assignment fields for the same reason. 1054 1055 Set_Is_True_Constant (Elab_Ent, False); 1056 Set_Current_Value (Elab_Ent, Empty); 1057 Set_Last_Assignment (Elab_Ent, Empty); 1058 1059 -- We do not want any further qualification of the name (if we did not 1060 -- do this, we would pick up the name of the generic package in the case 1061 -- of a library level generic instantiation). 1062 1063 Set_Has_Qualified_Name (Elab_Ent); 1064 Set_Has_Fully_Qualified_Name (Elab_Ent); 1065 end Build_Elaboration_Entity; 1066 1067 -------------------------------- 1068 -- Build_Explicit_Dereference -- 1069 -------------------------------- 1070 1071 procedure Build_Explicit_Dereference 1072 (Expr : Node_Id; 1073 Disc : Entity_Id) 1074 is 1075 Loc : constant Source_Ptr := Sloc (Expr); 1076 begin 1077 1078 -- An entity of a type with a reference aspect is overloaded with 1079 -- both interpretations: with and without the dereference. Now that 1080 -- the dereference is made explicit, set the type of the node properly, 1081 -- to prevent anomalies in the backend. Same if the expression is an 1082 -- overloaded function call whose return type has a reference aspect. 1083 1084 if Is_Entity_Name (Expr) then 1085 Set_Etype (Expr, Etype (Entity (Expr))); 1086 1087 elsif Nkind (Expr) = N_Function_Call then 1088 Set_Etype (Expr, Etype (Name (Expr))); 1089 end if; 1090 1091 Set_Is_Overloaded (Expr, False); 1092 Rewrite (Expr, 1093 Make_Explicit_Dereference (Loc, 1094 Prefix => 1095 Make_Selected_Component (Loc, 1096 Prefix => Relocate_Node (Expr), 1097 Selector_Name => New_Occurrence_Of (Disc, Loc)))); 1098 Set_Etype (Prefix (Expr), Etype (Disc)); 1099 Set_Etype (Expr, Designated_Type (Etype (Disc))); 1100 end Build_Explicit_Dereference; 1101 1102 ----------------------------------- 1103 -- Cannot_Raise_Constraint_Error -- 1104 ----------------------------------- 1105 1106 function Cannot_Raise_Constraint_Error (Expr : Node_Id) return Boolean is 1107 begin 1108 if Compile_Time_Known_Value (Expr) then 1109 return True; 1110 1111 elsif Do_Range_Check (Expr) then 1112 return False; 1113 1114 elsif Raises_Constraint_Error (Expr) then 1115 return False; 1116 1117 else 1118 case Nkind (Expr) is 1119 when N_Identifier => 1120 return True; 1121 1122 when N_Expanded_Name => 1123 return True; 1124 1125 when N_Selected_Component => 1126 return not Do_Discriminant_Check (Expr); 1127 1128 when N_Attribute_Reference => 1129 if Do_Overflow_Check (Expr) then 1130 return False; 1131 1132 elsif No (Expressions (Expr)) then 1133 return True; 1134 1135 else 1136 declare 1137 N : Node_Id; 1138 1139 begin 1140 N := First (Expressions (Expr)); 1141 while Present (N) loop 1142 if Cannot_Raise_Constraint_Error (N) then 1143 Next (N); 1144 else 1145 return False; 1146 end if; 1147 end loop; 1148 1149 return True; 1150 end; 1151 end if; 1152 1153 when N_Type_Conversion => 1154 if Do_Overflow_Check (Expr) 1155 or else Do_Length_Check (Expr) 1156 or else Do_Tag_Check (Expr) 1157 then 1158 return False; 1159 else 1160 return Cannot_Raise_Constraint_Error (Expression (Expr)); 1161 end if; 1162 1163 when N_Unchecked_Type_Conversion => 1164 return Cannot_Raise_Constraint_Error (Expression (Expr)); 1165 1166 when N_Unary_Op => 1167 if Do_Overflow_Check (Expr) then 1168 return False; 1169 else 1170 return Cannot_Raise_Constraint_Error (Right_Opnd (Expr)); 1171 end if; 1172 1173 when N_Op_Divide | 1174 N_Op_Mod | 1175 N_Op_Rem 1176 => 1177 if Do_Division_Check (Expr) 1178 or else Do_Overflow_Check (Expr) 1179 then 1180 return False; 1181 else 1182 return 1183 Cannot_Raise_Constraint_Error (Left_Opnd (Expr)) 1184 and then 1185 Cannot_Raise_Constraint_Error (Right_Opnd (Expr)); 1186 end if; 1187 1188 when N_Op_Add | 1189 N_Op_And | 1190 N_Op_Concat | 1191 N_Op_Eq | 1192 N_Op_Expon | 1193 N_Op_Ge | 1194 N_Op_Gt | 1195 N_Op_Le | 1196 N_Op_Lt | 1197 N_Op_Multiply | 1198 N_Op_Ne | 1199 N_Op_Or | 1200 N_Op_Rotate_Left | 1201 N_Op_Rotate_Right | 1202 N_Op_Shift_Left | 1203 N_Op_Shift_Right | 1204 N_Op_Shift_Right_Arithmetic | 1205 N_Op_Subtract | 1206 N_Op_Xor 1207 => 1208 if Do_Overflow_Check (Expr) then 1209 return False; 1210 else 1211 return 1212 Cannot_Raise_Constraint_Error (Left_Opnd (Expr)) 1213 and then 1214 Cannot_Raise_Constraint_Error (Right_Opnd (Expr)); 1215 end if; 1216 1217 when others => 1218 return False; 1219 end case; 1220 end if; 1221 end Cannot_Raise_Constraint_Error; 1222 1223 ------------------------------------- 1224 -- Check_Function_Writable_Actuals -- 1225 ------------------------------------- 1226 1227 procedure Check_Function_Writable_Actuals (N : Node_Id) is 1228 Writable_Actuals_List : Elist_Id := No_Elist; 1229 Identifiers_List : Elist_Id := No_Elist; 1230 Error_Node : Node_Id := Empty; 1231 1232 procedure Collect_Identifiers (N : Node_Id); 1233 -- In a single traversal of subtree N collect in Writable_Actuals_List 1234 -- all the actuals of functions with writable actuals, and in the list 1235 -- Identifiers_List collect all the identifiers that are not actuals of 1236 -- functions with writable actuals. If a writable actual is referenced 1237 -- twice as writable actual then Error_Node is set to reference its 1238 -- second occurrence, the error is reported, and the tree traversal 1239 -- is abandoned. 1240 1241 function Get_Function_Id (Call : Node_Id) return Entity_Id; 1242 -- Return the entity associated with the function call 1243 1244 procedure Preanalyze_Without_Errors (N : Node_Id); 1245 -- Preanalyze N without reporting errors. Very dubious, you can't just 1246 -- go analyzing things more than once??? 1247 1248 ------------------------- 1249 -- Collect_Identifiers -- 1250 ------------------------- 1251 1252 procedure Collect_Identifiers (N : Node_Id) is 1253 1254 function Check_Node (N : Node_Id) return Traverse_Result; 1255 -- Process a single node during the tree traversal to collect the 1256 -- writable actuals of functions and all the identifiers which are 1257 -- not writable actuals of functions. 1258 1259 function Contains (List : Elist_Id; N : Node_Id) return Boolean; 1260 -- Returns True if List has a node whose Entity is Entity (N) 1261 1262 ------------------------- 1263 -- Check_Function_Call -- 1264 ------------------------- 1265 1266 function Check_Node (N : Node_Id) return Traverse_Result is 1267 Is_Writable_Actual : Boolean := False; 1268 1269 begin 1270 if Nkind (N) = N_Identifier then 1271 1272 -- No analysis possible if the entity is not decorated 1273 1274 if No (Entity (N)) then 1275 return Skip; 1276 1277 -- Don't collect identifiers of packages, called functions, etc 1278 1279 elsif Ekind_In (Entity (N), E_Package, 1280 E_Function, 1281 E_Procedure, 1282 E_Entry) 1283 then 1284 return Skip; 1285 1286 -- Analyze if N is a writable actual of a function 1287 1288 elsif Nkind (Parent (N)) = N_Function_Call then 1289 declare 1290 Call : constant Node_Id := Parent (N); 1291 Id : constant Entity_Id := Get_Function_Id (Call); 1292 Actual : Node_Id; 1293 Formal : Node_Id; 1294 1295 begin 1296 Formal := First_Formal (Id); 1297 Actual := First_Actual (Call); 1298 while Present (Actual) and then Present (Formal) loop 1299 if Actual = N then 1300 if Ekind_In (Formal, E_Out_Parameter, 1301 E_In_Out_Parameter) 1302 then 1303 Is_Writable_Actual := True; 1304 end if; 1305 1306 exit; 1307 end if; 1308 1309 Next_Formal (Formal); 1310 Next_Actual (Actual); 1311 end loop; 1312 end; 1313 end if; 1314 1315 if Is_Writable_Actual then 1316 if Contains (Writable_Actuals_List, N) then 1317 Error_Msg_N 1318 ("conflict of writable function parameter in " 1319 & "construct with arbitrary order of evaluation", N); 1320 Error_Node := N; 1321 return Abandon; 1322 end if; 1323 1324 if Writable_Actuals_List = No_Elist then 1325 Writable_Actuals_List := New_Elmt_List; 1326 end if; 1327 1328 Append_Elmt (N, Writable_Actuals_List); 1329 else 1330 if Identifiers_List = No_Elist then 1331 Identifiers_List := New_Elmt_List; 1332 end if; 1333 1334 Append_Unique_Elmt (N, Identifiers_List); 1335 end if; 1336 end if; 1337 1338 return OK; 1339 end Check_Node; 1340 1341 -------------- 1342 -- Contains -- 1343 -------------- 1344 1345 function Contains 1346 (List : Elist_Id; 1347 N : Node_Id) return Boolean 1348 is 1349 pragma Assert (Nkind (N) in N_Has_Entity); 1350 1351 Elmt : Elmt_Id; 1352 1353 begin 1354 if List = No_Elist then 1355 return False; 1356 end if; 1357 1358 Elmt := First_Elmt (List); 1359 while Present (Elmt) loop 1360 if Entity (Node (Elmt)) = Entity (N) then 1361 return True; 1362 else 1363 Next_Elmt (Elmt); 1364 end if; 1365 end loop; 1366 1367 return False; 1368 end Contains; 1369 1370 ------------------ 1371 -- Do_Traversal -- 1372 ------------------ 1373 1374 procedure Do_Traversal is new Traverse_Proc (Check_Node); 1375 -- The traversal procedure 1376 1377 -- Start of processing for Collect_Identifiers 1378 1379 begin 1380 if Present (Error_Node) then 1381 return; 1382 end if; 1383 1384 if Nkind (N) in N_Subexpr 1385 and then Is_Static_Expression (N) 1386 then 1387 return; 1388 end if; 1389 1390 Do_Traversal (N); 1391 end Collect_Identifiers; 1392 1393 --------------------- 1394 -- Get_Function_Id -- 1395 --------------------- 1396 1397 function Get_Function_Id (Call : Node_Id) return Entity_Id is 1398 Nam : constant Node_Id := Name (Call); 1399 Id : Entity_Id; 1400 1401 begin 1402 if Nkind (Nam) = N_Explicit_Dereference then 1403 Id := Etype (Nam); 1404 pragma Assert (Ekind (Id) = E_Subprogram_Type); 1405 1406 elsif Nkind (Nam) = N_Selected_Component then 1407 Id := Entity (Selector_Name (Nam)); 1408 1409 elsif Nkind (Nam) = N_Indexed_Component then 1410 Id := Entity (Selector_Name (Prefix (Nam))); 1411 1412 else 1413 Id := Entity (Nam); 1414 end if; 1415 1416 return Id; 1417 end Get_Function_Id; 1418 1419 --------------------------- 1420 -- Preanalyze_Expression -- 1421 --------------------------- 1422 1423 procedure Preanalyze_Without_Errors (N : Node_Id) is 1424 Status : constant Boolean := Get_Ignore_Errors; 1425 begin 1426 Set_Ignore_Errors (True); 1427 Preanalyze (N); 1428 Set_Ignore_Errors (Status); 1429 end Preanalyze_Without_Errors; 1430 1431 -- Start of processing for Check_Function_Writable_Actuals 1432 1433 begin 1434 if Ada_Version < Ada_2012 1435 or else (not (Nkind (N) in N_Op) 1436 and then not (Nkind (N) in N_Membership_Test) 1437 and then not Nkind_In (N, N_Range, 1438 N_Aggregate, 1439 N_Extension_Aggregate, 1440 N_Full_Type_Declaration, 1441 N_Function_Call, 1442 N_Procedure_Call_Statement, 1443 N_Entry_Call_Statement)) 1444 or else (Nkind (N) = N_Full_Type_Declaration 1445 and then not Is_Record_Type (Defining_Identifier (N))) 1446 then 1447 return; 1448 end if; 1449 1450 -- If a construct C has two or more direct constituents that are names 1451 -- or expressions whose evaluation may occur in an arbitrary order, at 1452 -- least one of which contains a function call with an in out or out 1453 -- parameter, then the construct is legal only if: for each name N that 1454 -- is passed as a parameter of mode in out or out to some inner function 1455 -- call C2 (not including the construct C itself), there is no other 1456 -- name anywhere within a direct constituent of the construct C other 1457 -- than the one containing C2, that is known to refer to the same 1458 -- object (RM 6.4.1(6.17/3)). 1459 1460 case Nkind (N) is 1461 when N_Range => 1462 Collect_Identifiers (Low_Bound (N)); 1463 Collect_Identifiers (High_Bound (N)); 1464 1465 when N_Op | N_Membership_Test => 1466 declare 1467 Expr : Node_Id; 1468 begin 1469 Collect_Identifiers (Left_Opnd (N)); 1470 1471 if Present (Right_Opnd (N)) then 1472 Collect_Identifiers (Right_Opnd (N)); 1473 end if; 1474 1475 if Nkind_In (N, N_In, N_Not_In) 1476 and then Present (Alternatives (N)) 1477 then 1478 Expr := First (Alternatives (N)); 1479 while Present (Expr) loop 1480 Collect_Identifiers (Expr); 1481 1482 Next (Expr); 1483 end loop; 1484 end if; 1485 end; 1486 1487 when N_Full_Type_Declaration => 1488 declare 1489 function Get_Record_Part (N : Node_Id) return Node_Id; 1490 -- Return the record part of this record type definition 1491 1492 function Get_Record_Part (N : Node_Id) return Node_Id is 1493 Type_Def : constant Node_Id := Type_Definition (N); 1494 begin 1495 if Nkind (Type_Def) = N_Derived_Type_Definition then 1496 return Record_Extension_Part (Type_Def); 1497 else 1498 return Type_Def; 1499 end if; 1500 end Get_Record_Part; 1501 1502 Comp : Node_Id; 1503 Def_Id : Entity_Id := Defining_Identifier (N); 1504 Rec : Node_Id := Get_Record_Part (N); 1505 1506 begin 1507 -- No need to perform any analysis if the record has no 1508 -- components 1509 1510 if No (Rec) or else No (Component_List (Rec)) then 1511 return; 1512 end if; 1513 1514 -- Collect the identifiers starting from the deepest 1515 -- derivation. Done to report the error in the deepest 1516 -- derivation. 1517 1518 loop 1519 if Present (Component_List (Rec)) then 1520 Comp := First (Component_Items (Component_List (Rec))); 1521 while Present (Comp) loop 1522 if Nkind (Comp) = N_Component_Declaration 1523 and then Present (Expression (Comp)) 1524 then 1525 Collect_Identifiers (Expression (Comp)); 1526 end if; 1527 1528 Next (Comp); 1529 end loop; 1530 end if; 1531 1532 exit when No (Underlying_Type (Etype (Def_Id))) 1533 or else Base_Type (Underlying_Type (Etype (Def_Id))) 1534 = Def_Id; 1535 1536 Def_Id := Base_Type (Underlying_Type (Etype (Def_Id))); 1537 Rec := Get_Record_Part (Parent (Def_Id)); 1538 end loop; 1539 end; 1540 1541 when N_Subprogram_Call | 1542 N_Entry_Call_Statement => 1543 declare 1544 Id : constant Entity_Id := Get_Function_Id (N); 1545 Formal : Node_Id; 1546 Actual : Node_Id; 1547 1548 begin 1549 Formal := First_Formal (Id); 1550 Actual := First_Actual (N); 1551 while Present (Actual) and then Present (Formal) loop 1552 if Ekind_In (Formal, E_Out_Parameter, 1553 E_In_Out_Parameter) 1554 then 1555 Collect_Identifiers (Actual); 1556 end if; 1557 1558 Next_Formal (Formal); 1559 Next_Actual (Actual); 1560 end loop; 1561 end; 1562 1563 when N_Aggregate | 1564 N_Extension_Aggregate => 1565 declare 1566 Assoc : Node_Id; 1567 Choice : Node_Id; 1568 Comp_Expr : Node_Id; 1569 1570 begin 1571 -- Handle the N_Others_Choice of array aggregates with static 1572 -- bounds. There is no need to perform this analysis in 1573 -- aggregates without static bounds since we cannot evaluate 1574 -- if the N_Others_Choice covers several elements. There is 1575 -- no need to handle the N_Others choice of record aggregates 1576 -- since at this stage it has been already expanded by 1577 -- Resolve_Record_Aggregate. 1578 1579 if Is_Array_Type (Etype (N)) 1580 and then Nkind (N) = N_Aggregate 1581 and then Present (Aggregate_Bounds (N)) 1582 and then Compile_Time_Known_Bounds (Etype (N)) 1583 and then Expr_Value (High_Bound (Aggregate_Bounds (N))) 1584 > Expr_Value (Low_Bound (Aggregate_Bounds (N))) 1585 then 1586 declare 1587 Count_Components : Uint := Uint_0; 1588 Num_Components : Uint; 1589 Others_Assoc : Node_Id; 1590 Others_Choice : Node_Id := Empty; 1591 Others_Box_Present : Boolean := False; 1592 1593 begin 1594 -- Count positional associations 1595 1596 if Present (Expressions (N)) then 1597 Comp_Expr := First (Expressions (N)); 1598 while Present (Comp_Expr) loop 1599 Count_Components := Count_Components + 1; 1600 Next (Comp_Expr); 1601 end loop; 1602 end if; 1603 1604 -- Count the rest of elements and locate the N_Others 1605 -- choice (if any) 1606 1607 Assoc := First (Component_Associations (N)); 1608 while Present (Assoc) loop 1609 Choice := First (Choices (Assoc)); 1610 while Present (Choice) loop 1611 if Nkind (Choice) = N_Others_Choice then 1612 Others_Assoc := Assoc; 1613 Others_Choice := Choice; 1614 Others_Box_Present := Box_Present (Assoc); 1615 1616 -- Count several components 1617 1618 elsif Nkind_In (Choice, N_Range, 1619 N_Subtype_Indication) 1620 or else (Is_Entity_Name (Choice) 1621 and then Is_Type (Entity (Choice))) 1622 then 1623 declare 1624 L, H : Node_Id; 1625 begin 1626 Get_Index_Bounds (Choice, L, H); 1627 pragma Assert 1628 (Compile_Time_Known_Value (L) 1629 and then Compile_Time_Known_Value (H)); 1630 Count_Components := 1631 Count_Components 1632 + Expr_Value (H) - Expr_Value (L) + 1; 1633 end; 1634 1635 -- Count single component. No other case available 1636 -- since we are handling an aggregate with static 1637 -- bounds. 1638 1639 else 1640 pragma Assert (Is_Static_Expression (Choice) 1641 or else Nkind (Choice) = N_Identifier 1642 or else Nkind (Choice) = N_Integer_Literal); 1643 1644 Count_Components := Count_Components + 1; 1645 end if; 1646 1647 Next (Choice); 1648 end loop; 1649 1650 Next (Assoc); 1651 end loop; 1652 1653 Num_Components := 1654 Expr_Value (High_Bound (Aggregate_Bounds (N))) - 1655 Expr_Value (Low_Bound (Aggregate_Bounds (N))) + 1; 1656 1657 pragma Assert (Count_Components <= Num_Components); 1658 1659 -- Handle the N_Others choice if it covers several 1660 -- components 1661 1662 if Present (Others_Choice) 1663 and then (Num_Components - Count_Components) > 1 1664 then 1665 if not Others_Box_Present then 1666 1667 -- At this stage, if expansion is active, the 1668 -- expression of the others choice has not been 1669 -- analyzed. Hence we generate a duplicate and 1670 -- we analyze it silently to have available the 1671 -- minimum decoration required to collect the 1672 -- identifiers. 1673 1674 if not Expander_Active then 1675 Comp_Expr := Expression (Others_Assoc); 1676 else 1677 Comp_Expr := 1678 New_Copy_Tree (Expression (Others_Assoc)); 1679 Preanalyze_Without_Errors (Comp_Expr); 1680 end if; 1681 1682 Collect_Identifiers (Comp_Expr); 1683 1684 if Writable_Actuals_List /= No_Elist then 1685 1686 -- As suggested by Robert, at current stage we 1687 -- report occurrences of this case as warnings. 1688 1689 Error_Msg_N 1690 ("conflict of writable function parameter in " 1691 & "construct with arbitrary order of " 1692 & "evaluation?", 1693 Node (First_Elmt (Writable_Actuals_List))); 1694 end if; 1695 end if; 1696 end if; 1697 end; 1698 end if; 1699 1700 -- Handle ancestor part of extension aggregates 1701 1702 if Nkind (N) = N_Extension_Aggregate then 1703 Collect_Identifiers (Ancestor_Part (N)); 1704 end if; 1705 1706 -- Handle positional associations 1707 1708 if Present (Expressions (N)) then 1709 Comp_Expr := First (Expressions (N)); 1710 while Present (Comp_Expr) loop 1711 if not Is_Static_Expression (Comp_Expr) then 1712 Collect_Identifiers (Comp_Expr); 1713 end if; 1714 1715 Next (Comp_Expr); 1716 end loop; 1717 end if; 1718 1719 -- Handle discrete associations 1720 1721 if Present (Component_Associations (N)) then 1722 Assoc := First (Component_Associations (N)); 1723 while Present (Assoc) loop 1724 1725 if not Box_Present (Assoc) then 1726 Choice := First (Choices (Assoc)); 1727 while Present (Choice) loop 1728 1729 -- For now we skip discriminants since it requires 1730 -- performing the analysis in two phases: first one 1731 -- analyzing discriminants and second one analyzing 1732 -- the rest of components since discriminants are 1733 -- evaluated prior to components: too much extra 1734 -- work to detect a corner case??? 1735 1736 if Nkind (Choice) in N_Has_Entity 1737 and then Present (Entity (Choice)) 1738 and then Ekind (Entity (Choice)) = E_Discriminant 1739 then 1740 null; 1741 1742 elsif Box_Present (Assoc) then 1743 null; 1744 1745 else 1746 if not Analyzed (Expression (Assoc)) then 1747 Comp_Expr := 1748 New_Copy_Tree (Expression (Assoc)); 1749 Set_Parent (Comp_Expr, Parent (N)); 1750 Preanalyze_Without_Errors (Comp_Expr); 1751 else 1752 Comp_Expr := Expression (Assoc); 1753 end if; 1754 1755 Collect_Identifiers (Comp_Expr); 1756 end if; 1757 1758 Next (Choice); 1759 end loop; 1760 end if; 1761 1762 Next (Assoc); 1763 end loop; 1764 end if; 1765 end; 1766 1767 when others => 1768 return; 1769 end case; 1770 1771 -- No further action needed if we already reported an error 1772 1773 if Present (Error_Node) then 1774 return; 1775 end if; 1776 1777 -- Check if some writable argument of a function is referenced 1778 1779 if Writable_Actuals_List /= No_Elist 1780 and then Identifiers_List /= No_Elist 1781 then 1782 declare 1783 Elmt_1 : Elmt_Id; 1784 Elmt_2 : Elmt_Id; 1785 1786 begin 1787 Elmt_1 := First_Elmt (Writable_Actuals_List); 1788 while Present (Elmt_1) loop 1789 Elmt_2 := First_Elmt (Identifiers_List); 1790 while Present (Elmt_2) loop 1791 if Entity (Node (Elmt_1)) = Entity (Node (Elmt_2)) then 1792 Error_Msg_N 1793 ("conflict of writable function parameter in construct " 1794 & "with arbitrary order of evaluation", 1795 Node (Elmt_1)); 1796 end if; 1797 1798 Next_Elmt (Elmt_2); 1799 end loop; 1800 1801 Next_Elmt (Elmt_1); 1802 end loop; 1803 end; 1804 end if; 1805 end Check_Function_Writable_Actuals; 1806 1807 -------------------------------- 1808 -- Check_Implicit_Dereference -- 1809 -------------------------------- 1810 1811 procedure Check_Implicit_Dereference (Nam : Node_Id; Typ : Entity_Id) is 1812 Disc : Entity_Id; 1813 Desig : Entity_Id; 1814 1815 begin 1816 if Ada_Version < Ada_2012 1817 or else not Has_Implicit_Dereference (Base_Type (Typ)) 1818 then 1819 return; 1820 1821 elsif not Comes_From_Source (Nam) then 1822 return; 1823 1824 elsif Is_Entity_Name (Nam) 1825 and then Is_Type (Entity (Nam)) 1826 then 1827 null; 1828 1829 else 1830 Disc := First_Discriminant (Typ); 1831 while Present (Disc) loop 1832 if Has_Implicit_Dereference (Disc) then 1833 Desig := Designated_Type (Etype (Disc)); 1834 Add_One_Interp (Nam, Disc, Desig); 1835 exit; 1836 end if; 1837 1838 Next_Discriminant (Disc); 1839 end loop; 1840 end if; 1841 end Check_Implicit_Dereference; 1842 1843 ---------------------------------- 1844 -- Check_Internal_Protected_Use -- 1845 ---------------------------------- 1846 1847 procedure Check_Internal_Protected_Use (N : Node_Id; Nam : Entity_Id) is 1848 S : Entity_Id; 1849 Prot : Entity_Id; 1850 1851 begin 1852 S := Current_Scope; 1853 while Present (S) loop 1854 if S = Standard_Standard then 1855 return; 1856 1857 elsif Ekind (S) = E_Function 1858 and then Ekind (Scope (S)) = E_Protected_Type 1859 then 1860 Prot := Scope (S); 1861 exit; 1862 end if; 1863 1864 S := Scope (S); 1865 end loop; 1866 1867 if Scope (Nam) = Prot and then Ekind (Nam) /= E_Function then 1868 if Nkind (N) = N_Subprogram_Renaming_Declaration then 1869 Error_Msg_N 1870 ("within protected function cannot use protected " 1871 & "procedure in renaming or as generic actual", N); 1872 1873 elsif Nkind (N) = N_Attribute_Reference then 1874 Error_Msg_N 1875 ("within protected function cannot take access of " 1876 & " protected procedure", N); 1877 1878 else 1879 Error_Msg_N 1880 ("within protected function, protected object is constant", N); 1881 Error_Msg_N 1882 ("\cannot call operation that may modify it", N); 1883 end if; 1884 end if; 1885 end Check_Internal_Protected_Use; 1886 1887 --------------------------------------- 1888 -- Check_Later_Vs_Basic_Declarations -- 1889 --------------------------------------- 1890 1891 procedure Check_Later_Vs_Basic_Declarations 1892 (Decls : List_Id; 1893 During_Parsing : Boolean) 1894 is 1895 Body_Sloc : Source_Ptr; 1896 Decl : Node_Id; 1897 1898 function Is_Later_Declarative_Item (Decl : Node_Id) return Boolean; 1899 -- Return whether Decl is considered as a declarative item. 1900 -- When During_Parsing is True, the semantics of Ada 83 is followed. 1901 -- When During_Parsing is False, the semantics of SPARK is followed. 1902 1903 ------------------------------- 1904 -- Is_Later_Declarative_Item -- 1905 ------------------------------- 1906 1907 function Is_Later_Declarative_Item (Decl : Node_Id) return Boolean is 1908 begin 1909 if Nkind (Decl) in N_Later_Decl_Item then 1910 return True; 1911 1912 elsif Nkind (Decl) = N_Pragma then 1913 return True; 1914 1915 elsif During_Parsing then 1916 return False; 1917 1918 -- In SPARK, a package declaration is not considered as a later 1919 -- declarative item. 1920 1921 elsif Nkind (Decl) = N_Package_Declaration then 1922 return False; 1923 1924 -- In SPARK, a renaming is considered as a later declarative item 1925 1926 elsif Nkind (Decl) in N_Renaming_Declaration then 1927 return True; 1928 1929 else 1930 return False; 1931 end if; 1932 end Is_Later_Declarative_Item; 1933 1934 -- Start of Check_Later_Vs_Basic_Declarations 1935 1936 begin 1937 Decl := First (Decls); 1938 1939 -- Loop through sequence of basic declarative items 1940 1941 Outer : while Present (Decl) loop 1942 if not Nkind_In (Decl, N_Subprogram_Body, N_Package_Body, N_Task_Body) 1943 and then Nkind (Decl) not in N_Body_Stub 1944 then 1945 Next (Decl); 1946 1947 -- Once a body is encountered, we only allow later declarative 1948 -- items. The inner loop checks the rest of the list. 1949 1950 else 1951 Body_Sloc := Sloc (Decl); 1952 1953 Inner : while Present (Decl) loop 1954 if not Is_Later_Declarative_Item (Decl) then 1955 if During_Parsing then 1956 if Ada_Version = Ada_83 then 1957 Error_Msg_Sloc := Body_Sloc; 1958 Error_Msg_N 1959 ("(Ada 83) decl cannot appear after body#", Decl); 1960 end if; 1961 else 1962 Error_Msg_Sloc := Body_Sloc; 1963 Check_SPARK_Restriction 1964 ("decl cannot appear after body#", Decl); 1965 end if; 1966 end if; 1967 1968 Next (Decl); 1969 end loop Inner; 1970 end if; 1971 end loop Outer; 1972 end Check_Later_Vs_Basic_Declarations; 1973 1974 ----------------------------------------- 1975 -- Check_Dynamically_Tagged_Expression -- 1976 ----------------------------------------- 1977 1978 procedure Check_Dynamically_Tagged_Expression 1979 (Expr : Node_Id; 1980 Typ : Entity_Id; 1981 Related_Nod : Node_Id) 1982 is 1983 begin 1984 pragma Assert (Is_Tagged_Type (Typ)); 1985 1986 -- In order to avoid spurious errors when analyzing the expanded code, 1987 -- this check is done only for nodes that come from source and for 1988 -- actuals of generic instantiations. 1989 1990 if (Comes_From_Source (Related_Nod) 1991 or else In_Generic_Actual (Expr)) 1992 and then (Is_Class_Wide_Type (Etype (Expr)) 1993 or else Is_Dynamically_Tagged (Expr)) 1994 and then Is_Tagged_Type (Typ) 1995 and then not Is_Class_Wide_Type (Typ) 1996 then 1997 Error_Msg_N ("dynamically tagged expression not allowed!", Expr); 1998 end if; 1999 end Check_Dynamically_Tagged_Expression; 2000 2001 -------------------------- 2002 -- Check_Fully_Declared -- 2003 -------------------------- 2004 2005 procedure Check_Fully_Declared (T : Entity_Id; N : Node_Id) is 2006 begin 2007 if Ekind (T) = E_Incomplete_Type then 2008 2009 -- Ada 2005 (AI-50217): If the type is available through a limited 2010 -- with_clause, verify that its full view has been analyzed. 2011 2012 if From_With_Type (T) 2013 and then Present (Non_Limited_View (T)) 2014 and then Ekind (Non_Limited_View (T)) /= E_Incomplete_Type 2015 then 2016 -- The non-limited view is fully declared 2017 null; 2018 2019 else 2020 Error_Msg_NE 2021 ("premature usage of incomplete}", N, First_Subtype (T)); 2022 end if; 2023 2024 -- Need comments for these tests ??? 2025 2026 elsif Has_Private_Component (T) 2027 and then not Is_Generic_Type (Root_Type (T)) 2028 and then not In_Spec_Expression 2029 then 2030 -- Special case: if T is the anonymous type created for a single 2031 -- task or protected object, use the name of the source object. 2032 2033 if Is_Concurrent_Type (T) 2034 and then not Comes_From_Source (T) 2035 and then Nkind (N) = N_Object_Declaration 2036 then 2037 Error_Msg_NE ("type of& has incomplete component", N, 2038 Defining_Identifier (N)); 2039 2040 else 2041 Error_Msg_NE 2042 ("premature usage of incomplete}", N, First_Subtype (T)); 2043 end if; 2044 end if; 2045 end Check_Fully_Declared; 2046 2047 ------------------------- 2048 -- Check_Nested_Access -- 2049 ------------------------- 2050 2051 procedure Check_Nested_Access (Ent : Entity_Id) is 2052 Scop : constant Entity_Id := Current_Scope; 2053 Current_Subp : Entity_Id; 2054 Enclosing : Entity_Id; 2055 2056 begin 2057 -- Currently only enabled for VM back-ends for efficiency, should we 2058 -- enable it more systematically ??? 2059 2060 -- Check for Is_Imported needs commenting below ??? 2061 2062 if VM_Target /= No_VM 2063 and then (Ekind (Ent) = E_Variable 2064 or else 2065 Ekind (Ent) = E_Constant 2066 or else 2067 Ekind (Ent) = E_Loop_Parameter) 2068 and then Scope (Ent) /= Empty 2069 and then not Is_Library_Level_Entity (Ent) 2070 and then not Is_Imported (Ent) 2071 then 2072 if Is_Subprogram (Scop) 2073 or else Is_Generic_Subprogram (Scop) 2074 or else Is_Entry (Scop) 2075 then 2076 Current_Subp := Scop; 2077 else 2078 Current_Subp := Current_Subprogram; 2079 end if; 2080 2081 Enclosing := Enclosing_Subprogram (Ent); 2082 2083 if Enclosing /= Empty 2084 and then Enclosing /= Current_Subp 2085 then 2086 Set_Has_Up_Level_Access (Ent, True); 2087 end if; 2088 end if; 2089 end Check_Nested_Access; 2090 2091 ------------------------------------------ 2092 -- Check_Potentially_Blocking_Operation -- 2093 ------------------------------------------ 2094 2095 procedure Check_Potentially_Blocking_Operation (N : Node_Id) is 2096 S : Entity_Id; 2097 2098 begin 2099 -- N is one of the potentially blocking operations listed in 9.5.1(8). 2100 -- When pragma Detect_Blocking is active, the run time will raise 2101 -- Program_Error. Here we only issue a warning, since we generally 2102 -- support the use of potentially blocking operations in the absence 2103 -- of the pragma. 2104 2105 -- Indirect blocking through a subprogram call cannot be diagnosed 2106 -- statically without interprocedural analysis, so we do not attempt 2107 -- to do it here. 2108 2109 S := Scope (Current_Scope); 2110 while Present (S) and then S /= Standard_Standard loop 2111 if Is_Protected_Type (S) then 2112 Error_Msg_N 2113 ("potentially blocking operation in protected operation??", N); 2114 return; 2115 end if; 2116 2117 S := Scope (S); 2118 end loop; 2119 end Check_Potentially_Blocking_Operation; 2120 2121 ------------------------------ 2122 -- Check_Unprotected_Access -- 2123 ------------------------------ 2124 2125 procedure Check_Unprotected_Access 2126 (Context : Node_Id; 2127 Expr : Node_Id) 2128 is 2129 Cont_Encl_Typ : Entity_Id; 2130 Pref_Encl_Typ : Entity_Id; 2131 2132 function Enclosing_Protected_Type (Obj : Node_Id) return Entity_Id; 2133 -- Check whether Obj is a private component of a protected object. 2134 -- Return the protected type where the component resides, Empty 2135 -- otherwise. 2136 2137 function Is_Public_Operation return Boolean; 2138 -- Verify that the enclosing operation is callable from outside the 2139 -- protected object, to minimize false positives. 2140 2141 ------------------------------ 2142 -- Enclosing_Protected_Type -- 2143 ------------------------------ 2144 2145 function Enclosing_Protected_Type (Obj : Node_Id) return Entity_Id is 2146 begin 2147 if Is_Entity_Name (Obj) then 2148 declare 2149 Ent : Entity_Id := Entity (Obj); 2150 2151 begin 2152 -- The object can be a renaming of a private component, use 2153 -- the original record component. 2154 2155 if Is_Prival (Ent) then 2156 Ent := Prival_Link (Ent); 2157 end if; 2158 2159 if Is_Protected_Type (Scope (Ent)) then 2160 return Scope (Ent); 2161 end if; 2162 end; 2163 end if; 2164 2165 -- For indexed and selected components, recursively check the prefix 2166 2167 if Nkind_In (Obj, N_Indexed_Component, N_Selected_Component) then 2168 return Enclosing_Protected_Type (Prefix (Obj)); 2169 2170 -- The object does not denote a protected component 2171 2172 else 2173 return Empty; 2174 end if; 2175 end Enclosing_Protected_Type; 2176 2177 ------------------------- 2178 -- Is_Public_Operation -- 2179 ------------------------- 2180 2181 function Is_Public_Operation return Boolean is 2182 S : Entity_Id; 2183 E : Entity_Id; 2184 2185 begin 2186 S := Current_Scope; 2187 while Present (S) 2188 and then S /= Pref_Encl_Typ 2189 loop 2190 if Scope (S) = Pref_Encl_Typ then 2191 E := First_Entity (Pref_Encl_Typ); 2192 while Present (E) 2193 and then E /= First_Private_Entity (Pref_Encl_Typ) 2194 loop 2195 if E = S then 2196 return True; 2197 end if; 2198 Next_Entity (E); 2199 end loop; 2200 end if; 2201 2202 S := Scope (S); 2203 end loop; 2204 2205 return False; 2206 end Is_Public_Operation; 2207 2208 -- Start of processing for Check_Unprotected_Access 2209 2210 begin 2211 if Nkind (Expr) = N_Attribute_Reference 2212 and then Attribute_Name (Expr) = Name_Unchecked_Access 2213 then 2214 Cont_Encl_Typ := Enclosing_Protected_Type (Context); 2215 Pref_Encl_Typ := Enclosing_Protected_Type (Prefix (Expr)); 2216 2217 -- Check whether we are trying to export a protected component to a 2218 -- context with an equal or lower access level. 2219 2220 if Present (Pref_Encl_Typ) 2221 and then No (Cont_Encl_Typ) 2222 and then Is_Public_Operation 2223 and then Scope_Depth (Pref_Encl_Typ) >= 2224 Object_Access_Level (Context) 2225 then 2226 Error_Msg_N 2227 ("??possible unprotected access to protected data", Expr); 2228 end if; 2229 end if; 2230 end Check_Unprotected_Access; 2231 2232 --------------- 2233 -- Check_VMS -- 2234 --------------- 2235 2236 procedure Check_VMS (Construct : Node_Id) is 2237 begin 2238 if not OpenVMS_On_Target then 2239 Error_Msg_N 2240 ("this construct is allowed only in Open'V'M'S", Construct); 2241 end if; 2242 end Check_VMS; 2243 2244 ------------------------ 2245 -- Collect_Interfaces -- 2246 ------------------------ 2247 2248 procedure Collect_Interfaces 2249 (T : Entity_Id; 2250 Ifaces_List : out Elist_Id; 2251 Exclude_Parents : Boolean := False; 2252 Use_Full_View : Boolean := True) 2253 is 2254 procedure Collect (Typ : Entity_Id); 2255 -- Subsidiary subprogram used to traverse the whole list 2256 -- of directly and indirectly implemented interfaces 2257 2258 ------------- 2259 -- Collect -- 2260 ------------- 2261 2262 procedure Collect (Typ : Entity_Id) is 2263 Ancestor : Entity_Id; 2264 Full_T : Entity_Id; 2265 Id : Node_Id; 2266 Iface : Entity_Id; 2267 2268 begin 2269 Full_T := Typ; 2270 2271 -- Handle private types 2272 2273 if Use_Full_View 2274 and then Is_Private_Type (Typ) 2275 and then Present (Full_View (Typ)) 2276 then 2277 Full_T := Full_View (Typ); 2278 end if; 2279 2280 -- Include the ancestor if we are generating the whole list of 2281 -- abstract interfaces. 2282 2283 if Etype (Full_T) /= Typ 2284 2285 -- Protect the frontend against wrong sources. For example: 2286 2287 -- package P is 2288 -- type A is tagged null record; 2289 -- type B is new A with private; 2290 -- type C is new A with private; 2291 -- private 2292 -- type B is new C with null record; 2293 -- type C is new B with null record; 2294 -- end P; 2295 2296 and then Etype (Full_T) /= T 2297 then 2298 Ancestor := Etype (Full_T); 2299 Collect (Ancestor); 2300 2301 if Is_Interface (Ancestor) 2302 and then not Exclude_Parents 2303 then 2304 Append_Unique_Elmt (Ancestor, Ifaces_List); 2305 end if; 2306 end if; 2307 2308 -- Traverse the graph of ancestor interfaces 2309 2310 if Is_Non_Empty_List (Abstract_Interface_List (Full_T)) then 2311 Id := First (Abstract_Interface_List (Full_T)); 2312 while Present (Id) loop 2313 Iface := Etype (Id); 2314 2315 -- Protect against wrong uses. For example: 2316 -- type I is interface; 2317 -- type O is tagged null record; 2318 -- type Wrong is new I and O with null record; -- ERROR 2319 2320 if Is_Interface (Iface) then 2321 if Exclude_Parents 2322 and then Etype (T) /= T 2323 and then Interface_Present_In_Ancestor (Etype (T), Iface) 2324 then 2325 null; 2326 else 2327 Collect (Iface); 2328 Append_Unique_Elmt (Iface, Ifaces_List); 2329 end if; 2330 end if; 2331 2332 Next (Id); 2333 end loop; 2334 end if; 2335 end Collect; 2336 2337 -- Start of processing for Collect_Interfaces 2338 2339 begin 2340 pragma Assert (Is_Tagged_Type (T) or else Is_Concurrent_Type (T)); 2341 Ifaces_List := New_Elmt_List; 2342 Collect (T); 2343 end Collect_Interfaces; 2344 2345 ---------------------------------- 2346 -- Collect_Interface_Components -- 2347 ---------------------------------- 2348 2349 procedure Collect_Interface_Components 2350 (Tagged_Type : Entity_Id; 2351 Components_List : out Elist_Id) 2352 is 2353 procedure Collect (Typ : Entity_Id); 2354 -- Subsidiary subprogram used to climb to the parents 2355 2356 ------------- 2357 -- Collect -- 2358 ------------- 2359 2360 procedure Collect (Typ : Entity_Id) is 2361 Tag_Comp : Entity_Id; 2362 Parent_Typ : Entity_Id; 2363 2364 begin 2365 -- Handle private types 2366 2367 if Present (Full_View (Etype (Typ))) then 2368 Parent_Typ := Full_View (Etype (Typ)); 2369 else 2370 Parent_Typ := Etype (Typ); 2371 end if; 2372 2373 if Parent_Typ /= Typ 2374 2375 -- Protect the frontend against wrong sources. For example: 2376 2377 -- package P is 2378 -- type A is tagged null record; 2379 -- type B is new A with private; 2380 -- type C is new A with private; 2381 -- private 2382 -- type B is new C with null record; 2383 -- type C is new B with null record; 2384 -- end P; 2385 2386 and then Parent_Typ /= Tagged_Type 2387 then 2388 Collect (Parent_Typ); 2389 end if; 2390 2391 -- Collect the components containing tags of secondary dispatch 2392 -- tables. 2393 2394 Tag_Comp := Next_Tag_Component (First_Tag_Component (Typ)); 2395 while Present (Tag_Comp) loop 2396 pragma Assert (Present (Related_Type (Tag_Comp))); 2397 Append_Elmt (Tag_Comp, Components_List); 2398 2399 Tag_Comp := Next_Tag_Component (Tag_Comp); 2400 end loop; 2401 end Collect; 2402 2403 -- Start of processing for Collect_Interface_Components 2404 2405 begin 2406 pragma Assert (Ekind (Tagged_Type) = E_Record_Type 2407 and then Is_Tagged_Type (Tagged_Type)); 2408 2409 Components_List := New_Elmt_List; 2410 Collect (Tagged_Type); 2411 end Collect_Interface_Components; 2412 2413 ----------------------------- 2414 -- Collect_Interfaces_Info -- 2415 ----------------------------- 2416 2417 procedure Collect_Interfaces_Info 2418 (T : Entity_Id; 2419 Ifaces_List : out Elist_Id; 2420 Components_List : out Elist_Id; 2421 Tags_List : out Elist_Id) 2422 is 2423 Comps_List : Elist_Id; 2424 Comp_Elmt : Elmt_Id; 2425 Comp_Iface : Entity_Id; 2426 Iface_Elmt : Elmt_Id; 2427 Iface : Entity_Id; 2428 2429 function Search_Tag (Iface : Entity_Id) return Entity_Id; 2430 -- Search for the secondary tag associated with the interface type 2431 -- Iface that is implemented by T. 2432 2433 ---------------- 2434 -- Search_Tag -- 2435 ---------------- 2436 2437 function Search_Tag (Iface : Entity_Id) return Entity_Id is 2438 ADT : Elmt_Id; 2439 begin 2440 if not Is_CPP_Class (T) then 2441 ADT := Next_Elmt (Next_Elmt (First_Elmt (Access_Disp_Table (T)))); 2442 else 2443 ADT := Next_Elmt (First_Elmt (Access_Disp_Table (T))); 2444 end if; 2445 2446 while Present (ADT) 2447 and then Is_Tag (Node (ADT)) 2448 and then Related_Type (Node (ADT)) /= Iface 2449 loop 2450 -- Skip secondary dispatch table referencing thunks to user 2451 -- defined primitives covered by this interface. 2452 2453 pragma Assert (Has_Suffix (Node (ADT), 'P')); 2454 Next_Elmt (ADT); 2455 2456 -- Skip secondary dispatch tables of Ada types 2457 2458 if not Is_CPP_Class (T) then 2459 2460 -- Skip secondary dispatch table referencing thunks to 2461 -- predefined primitives. 2462 2463 pragma Assert (Has_Suffix (Node (ADT), 'Y')); 2464 Next_Elmt (ADT); 2465 2466 -- Skip secondary dispatch table referencing user-defined 2467 -- primitives covered by this interface. 2468 2469 pragma Assert (Has_Suffix (Node (ADT), 'D')); 2470 Next_Elmt (ADT); 2471 2472 -- Skip secondary dispatch table referencing predefined 2473 -- primitives. 2474 2475 pragma Assert (Has_Suffix (Node (ADT), 'Z')); 2476 Next_Elmt (ADT); 2477 end if; 2478 end loop; 2479 2480 pragma Assert (Is_Tag (Node (ADT))); 2481 return Node (ADT); 2482 end Search_Tag; 2483 2484 -- Start of processing for Collect_Interfaces_Info 2485 2486 begin 2487 Collect_Interfaces (T, Ifaces_List); 2488 Collect_Interface_Components (T, Comps_List); 2489 2490 -- Search for the record component and tag associated with each 2491 -- interface type of T. 2492 2493 Components_List := New_Elmt_List; 2494 Tags_List := New_Elmt_List; 2495 2496 Iface_Elmt := First_Elmt (Ifaces_List); 2497 while Present (Iface_Elmt) loop 2498 Iface := Node (Iface_Elmt); 2499 2500 -- Associate the primary tag component and the primary dispatch table 2501 -- with all the interfaces that are parents of T 2502 2503 if Is_Ancestor (Iface, T, Use_Full_View => True) then 2504 Append_Elmt (First_Tag_Component (T), Components_List); 2505 Append_Elmt (Node (First_Elmt (Access_Disp_Table (T))), Tags_List); 2506 2507 -- Otherwise search for the tag component and secondary dispatch 2508 -- table of Iface 2509 2510 else 2511 Comp_Elmt := First_Elmt (Comps_List); 2512 while Present (Comp_Elmt) loop 2513 Comp_Iface := Related_Type (Node (Comp_Elmt)); 2514 2515 if Comp_Iface = Iface 2516 or else Is_Ancestor (Iface, Comp_Iface, Use_Full_View => True) 2517 then 2518 Append_Elmt (Node (Comp_Elmt), Components_List); 2519 Append_Elmt (Search_Tag (Comp_Iface), Tags_List); 2520 exit; 2521 end if; 2522 2523 Next_Elmt (Comp_Elmt); 2524 end loop; 2525 pragma Assert (Present (Comp_Elmt)); 2526 end if; 2527 2528 Next_Elmt (Iface_Elmt); 2529 end loop; 2530 end Collect_Interfaces_Info; 2531 2532 --------------------- 2533 -- Collect_Parents -- 2534 --------------------- 2535 2536 procedure Collect_Parents 2537 (T : Entity_Id; 2538 List : out Elist_Id; 2539 Use_Full_View : Boolean := True) 2540 is 2541 Current_Typ : Entity_Id := T; 2542 Parent_Typ : Entity_Id; 2543 2544 begin 2545 List := New_Elmt_List; 2546 2547 -- No action if the if the type has no parents 2548 2549 if T = Etype (T) then 2550 return; 2551 end if; 2552 2553 loop 2554 Parent_Typ := Etype (Current_Typ); 2555 2556 if Is_Private_Type (Parent_Typ) 2557 and then Present (Full_View (Parent_Typ)) 2558 and then Use_Full_View 2559 then 2560 Parent_Typ := Full_View (Base_Type (Parent_Typ)); 2561 end if; 2562 2563 Append_Elmt (Parent_Typ, List); 2564 2565 exit when Parent_Typ = Current_Typ; 2566 Current_Typ := Parent_Typ; 2567 end loop; 2568 end Collect_Parents; 2569 2570 ---------------------------------- 2571 -- Collect_Primitive_Operations -- 2572 ---------------------------------- 2573 2574 function Collect_Primitive_Operations (T : Entity_Id) return Elist_Id is 2575 B_Type : constant Entity_Id := Base_Type (T); 2576 B_Decl : constant Node_Id := Original_Node (Parent (B_Type)); 2577 B_Scope : Entity_Id := Scope (B_Type); 2578 Op_List : Elist_Id; 2579 Formal : Entity_Id; 2580 Is_Prim : Boolean; 2581 Is_Type_In_Pkg : Boolean; 2582 Formal_Derived : Boolean := False; 2583 Id : Entity_Id; 2584 2585 function Match (E : Entity_Id) return Boolean; 2586 -- True if E's base type is B_Type, or E is of an anonymous access type 2587 -- and the base type of its designated type is B_Type. 2588 2589 ----------- 2590 -- Match -- 2591 ----------- 2592 2593 function Match (E : Entity_Id) return Boolean is 2594 Etyp : Entity_Id := Etype (E); 2595 2596 begin 2597 if Ekind (Etyp) = E_Anonymous_Access_Type then 2598 Etyp := Designated_Type (Etyp); 2599 end if; 2600 2601 return Base_Type (Etyp) = B_Type; 2602 end Match; 2603 2604 -- Start of processing for Collect_Primitive_Operations 2605 2606 begin 2607 -- For tagged types, the primitive operations are collected as they 2608 -- are declared, and held in an explicit list which is simply returned. 2609 2610 if Is_Tagged_Type (B_Type) then 2611 return Primitive_Operations (B_Type); 2612 2613 -- An untagged generic type that is a derived type inherits the 2614 -- primitive operations of its parent type. Other formal types only 2615 -- have predefined operators, which are not explicitly represented. 2616 2617 elsif Is_Generic_Type (B_Type) then 2618 if Nkind (B_Decl) = N_Formal_Type_Declaration 2619 and then Nkind (Formal_Type_Definition (B_Decl)) 2620 = N_Formal_Derived_Type_Definition 2621 then 2622 Formal_Derived := True; 2623 else 2624 return New_Elmt_List; 2625 end if; 2626 end if; 2627 2628 Op_List := New_Elmt_List; 2629 2630 if B_Scope = Standard_Standard then 2631 if B_Type = Standard_String then 2632 Append_Elmt (Standard_Op_Concat, Op_List); 2633 2634 elsif B_Type = Standard_Wide_String then 2635 Append_Elmt (Standard_Op_Concatw, Op_List); 2636 2637 else 2638 null; 2639 end if; 2640 2641 -- Locate the primitive subprograms of the type 2642 2643 else 2644 -- The primitive operations appear after the base type, except 2645 -- if the derivation happens within the private part of B_Scope 2646 -- and the type is a private type, in which case both the type 2647 -- and some primitive operations may appear before the base 2648 -- type, and the list of candidates starts after the type. 2649 2650 if In_Open_Scopes (B_Scope) 2651 and then Scope (T) = B_Scope 2652 and then In_Private_Part (B_Scope) 2653 then 2654 Id := Next_Entity (T); 2655 else 2656 Id := Next_Entity (B_Type); 2657 end if; 2658 2659 -- Set flag if this is a type in a package spec 2660 2661 Is_Type_In_Pkg := 2662 Is_Package_Or_Generic_Package (B_Scope) 2663 and then 2664 Nkind (Parent (Declaration_Node (First_Subtype (T)))) /= 2665 N_Package_Body; 2666 2667 while Present (Id) loop 2668 2669 -- Test whether the result type or any of the parameter types of 2670 -- each subprogram following the type match that type when the 2671 -- type is declared in a package spec, is a derived type, or the 2672 -- subprogram is marked as primitive. (The Is_Primitive test is 2673 -- needed to find primitives of nonderived types in declarative 2674 -- parts that happen to override the predefined "=" operator.) 2675 2676 -- Note that generic formal subprograms are not considered to be 2677 -- primitive operations and thus are never inherited. 2678 2679 if Is_Overloadable (Id) 2680 and then (Is_Type_In_Pkg 2681 or else Is_Derived_Type (B_Type) 2682 or else Is_Primitive (Id)) 2683 and then Nkind (Parent (Parent (Id))) 2684 not in N_Formal_Subprogram_Declaration 2685 then 2686 Is_Prim := False; 2687 2688 if Match (Id) then 2689 Is_Prim := True; 2690 2691 else 2692 Formal := First_Formal (Id); 2693 while Present (Formal) loop 2694 if Match (Formal) then 2695 Is_Prim := True; 2696 exit; 2697 end if; 2698 2699 Next_Formal (Formal); 2700 end loop; 2701 end if; 2702 2703 -- For a formal derived type, the only primitives are the ones 2704 -- inherited from the parent type. Operations appearing in the 2705 -- package declaration are not primitive for it. 2706 2707 if Is_Prim 2708 and then (not Formal_Derived 2709 or else Present (Alias (Id))) 2710 then 2711 -- In the special case of an equality operator aliased to 2712 -- an overriding dispatching equality belonging to the same 2713 -- type, we don't include it in the list of primitives. 2714 -- This avoids inheriting multiple equality operators when 2715 -- deriving from untagged private types whose full type is 2716 -- tagged, which can otherwise cause ambiguities. Note that 2717 -- this should only happen for this kind of untagged parent 2718 -- type, since normally dispatching operations are inherited 2719 -- using the type's Primitive_Operations list. 2720 2721 if Chars (Id) = Name_Op_Eq 2722 and then Is_Dispatching_Operation (Id) 2723 and then Present (Alias (Id)) 2724 and then Present (Overridden_Operation (Alias (Id))) 2725 and then Base_Type (Etype (First_Entity (Id))) = 2726 Base_Type (Etype (First_Entity (Alias (Id)))) 2727 then 2728 null; 2729 2730 -- Include the subprogram in the list of primitives 2731 2732 else 2733 Append_Elmt (Id, Op_List); 2734 end if; 2735 end if; 2736 end if; 2737 2738 Next_Entity (Id); 2739 2740 -- For a type declared in System, some of its operations may 2741 -- appear in the target-specific extension to System. 2742 2743 if No (Id) 2744 and then B_Scope = RTU_Entity (System) 2745 and then Present_System_Aux 2746 then 2747 B_Scope := System_Aux_Id; 2748 Id := First_Entity (System_Aux_Id); 2749 end if; 2750 end loop; 2751 end if; 2752 2753 return Op_List; 2754 end Collect_Primitive_Operations; 2755 2756 ----------------------------------- 2757 -- Compile_Time_Constraint_Error -- 2758 ----------------------------------- 2759 2760 function Compile_Time_Constraint_Error 2761 (N : Node_Id; 2762 Msg : String; 2763 Ent : Entity_Id := Empty; 2764 Loc : Source_Ptr := No_Location; 2765 Warn : Boolean := False) return Node_Id 2766 is 2767 Msgc : String (1 .. Msg'Length + 3); 2768 -- Copy of message, with room for possible ?? and ! at end 2769 2770 Msgl : Natural; 2771 Wmsg : Boolean; 2772 P : Node_Id; 2773 OldP : Node_Id; 2774 Msgs : Boolean; 2775 Eloc : Source_Ptr; 2776 2777 begin 2778 -- A static constraint error in an instance body is not a fatal error. 2779 -- we choose to inhibit the message altogether, because there is no 2780 -- obvious node (for now) on which to post it. On the other hand the 2781 -- offending node must be replaced with a constraint_error in any case. 2782 2783 -- No messages are generated if we already posted an error on this node 2784 2785 if not Error_Posted (N) then 2786 if Loc /= No_Location then 2787 Eloc := Loc; 2788 else 2789 Eloc := Sloc (N); 2790 end if; 2791 2792 Msgc (1 .. Msg'Length) := Msg; 2793 Msgl := Msg'Length; 2794 2795 -- Message is a warning, even in Ada 95 case 2796 2797 if Msg (Msg'Last) = '?' then 2798 Wmsg := True; 2799 2800 -- In Ada 83, all messages are warnings. In the private part and 2801 -- the body of an instance, constraint_checks are only warnings. 2802 -- We also make this a warning if the Warn parameter is set. 2803 2804 elsif Warn 2805 or else (Ada_Version = Ada_83 and then Comes_From_Source (N)) 2806 then 2807 Msgl := Msgl + 1; 2808 Msgc (Msgl) := '?'; 2809 Msgl := Msgl + 1; 2810 Msgc (Msgl) := '?'; 2811 Wmsg := True; 2812 2813 elsif In_Instance_Not_Visible then 2814 Msgl := Msgl + 1; 2815 Msgc (Msgl) := '?'; 2816 Msgl := Msgl + 1; 2817 Msgc (Msgl) := '?'; 2818 Wmsg := True; 2819 2820 -- Otherwise we have a real error message (Ada 95 static case) 2821 -- and we make this an unconditional message. Note that in the 2822 -- warning case we do not make the message unconditional, it seems 2823 -- quite reasonable to delete messages like this (about exceptions 2824 -- that will be raised) in dead code. 2825 2826 else 2827 Wmsg := False; 2828 Msgl := Msgl + 1; 2829 Msgc (Msgl) := '!'; 2830 end if; 2831 2832 -- Should we generate a warning? The answer is not quite yes. The 2833 -- very annoying exception occurs in the case of a short circuit 2834 -- operator where the left operand is static and decisive. Climb 2835 -- parents to see if that is the case we have here. Conditional 2836 -- expressions with decisive conditions are a similar situation. 2837 2838 Msgs := True; 2839 P := N; 2840 loop 2841 OldP := P; 2842 P := Parent (P); 2843 2844 -- And then with False as left operand 2845 2846 if Nkind (P) = N_And_Then 2847 and then Compile_Time_Known_Value (Left_Opnd (P)) 2848 and then Is_False (Expr_Value (Left_Opnd (P))) 2849 then 2850 Msgs := False; 2851 exit; 2852 2853 -- OR ELSE with True as left operand 2854 2855 elsif Nkind (P) = N_Or_Else 2856 and then Compile_Time_Known_Value (Left_Opnd (P)) 2857 and then Is_True (Expr_Value (Left_Opnd (P))) 2858 then 2859 Msgs := False; 2860 exit; 2861 2862 -- If expression 2863 2864 elsif Nkind (P) = N_If_Expression then 2865 declare 2866 Cond : constant Node_Id := First (Expressions (P)); 2867 Texp : constant Node_Id := Next (Cond); 2868 Fexp : constant Node_Id := Next (Texp); 2869 2870 begin 2871 if Compile_Time_Known_Value (Cond) then 2872 2873 -- Condition is True and we are in the right operand 2874 2875 if Is_True (Expr_Value (Cond)) 2876 and then OldP = Fexp 2877 then 2878 Msgs := False; 2879 exit; 2880 2881 -- Condition is False and we are in the left operand 2882 2883 elsif Is_False (Expr_Value (Cond)) 2884 and then OldP = Texp 2885 then 2886 Msgs := False; 2887 exit; 2888 end if; 2889 end if; 2890 end; 2891 2892 -- Special case for component association in aggregates, where 2893 -- we want to keep climbing up to the parent aggregate. 2894 2895 elsif Nkind (P) = N_Component_Association 2896 and then Nkind (Parent (P)) = N_Aggregate 2897 then 2898 null; 2899 2900 -- Keep going if within subexpression 2901 2902 else 2903 exit when Nkind (P) not in N_Subexpr; 2904 end if; 2905 end loop; 2906 2907 if Msgs then 2908 if Present (Ent) then 2909 Error_Msg_NEL (Msgc (1 .. Msgl), N, Ent, Eloc); 2910 else 2911 Error_Msg_NEL (Msgc (1 .. Msgl), N, Etype (N), Eloc); 2912 end if; 2913 2914 if Wmsg then 2915 2916 -- Check whether the context is an Init_Proc 2917 2918 if Inside_Init_Proc then 2919 declare 2920 Conc_Typ : constant Entity_Id := 2921 Corresponding_Concurrent_Type 2922 (Entity (Parameter_Type (First 2923 (Parameter_Specifications 2924 (Parent (Current_Scope)))))); 2925 2926 begin 2927 -- Don't complain if the corresponding concurrent type 2928 -- doesn't come from source (i.e. a single task/protected 2929 -- object). 2930 2931 if Present (Conc_Typ) 2932 and then not Comes_From_Source (Conc_Typ) 2933 then 2934 Error_Msg_NEL 2935 ("\??& will be raised at run time", 2936 N, Standard_Constraint_Error, Eloc); 2937 2938 else 2939 Error_Msg_NEL 2940 ("\??& will be raised for objects of this type", 2941 N, Standard_Constraint_Error, Eloc); 2942 end if; 2943 end; 2944 2945 else 2946 Error_Msg_NEL 2947 ("\??& will be raised at run time", 2948 N, Standard_Constraint_Error, Eloc); 2949 end if; 2950 2951 else 2952 Error_Msg 2953 ("\static expression fails Constraint_Check", Eloc); 2954 Set_Error_Posted (N); 2955 end if; 2956 end if; 2957 end if; 2958 2959 return N; 2960 end Compile_Time_Constraint_Error; 2961 2962 ----------------------- 2963 -- Conditional_Delay -- 2964 ----------------------- 2965 2966 procedure Conditional_Delay (New_Ent, Old_Ent : Entity_Id) is 2967 begin 2968 if Has_Delayed_Freeze (Old_Ent) and then not Is_Frozen (Old_Ent) then 2969 Set_Has_Delayed_Freeze (New_Ent); 2970 end if; 2971 end Conditional_Delay; 2972 2973 ------------------------- 2974 -- Copy_Component_List -- 2975 ------------------------- 2976 2977 function Copy_Component_List 2978 (R_Typ : Entity_Id; 2979 Loc : Source_Ptr) return List_Id 2980 is 2981 Comp : Node_Id; 2982 Comps : constant List_Id := New_List; 2983 2984 begin 2985 Comp := First_Component (Underlying_Type (R_Typ)); 2986 while Present (Comp) loop 2987 if Comes_From_Source (Comp) then 2988 declare 2989 Comp_Decl : constant Node_Id := Declaration_Node (Comp); 2990 begin 2991 Append_To (Comps, 2992 Make_Component_Declaration (Loc, 2993 Defining_Identifier => 2994 Make_Defining_Identifier (Loc, Chars (Comp)), 2995 Component_Definition => 2996 New_Copy_Tree 2997 (Component_Definition (Comp_Decl), New_Sloc => Loc))); 2998 end; 2999 end if; 3000 3001 Next_Component (Comp); 3002 end loop; 3003 3004 return Comps; 3005 end Copy_Component_List; 3006 3007 ------------------------- 3008 -- Copy_Parameter_List -- 3009 ------------------------- 3010 3011 function Copy_Parameter_List (Subp_Id : Entity_Id) return List_Id is 3012 Loc : constant Source_Ptr := Sloc (Subp_Id); 3013 Plist : List_Id; 3014 Formal : Entity_Id; 3015 3016 begin 3017 if No (First_Formal (Subp_Id)) then 3018 return No_List; 3019 else 3020 Plist := New_List; 3021 Formal := First_Formal (Subp_Id); 3022 while Present (Formal) loop 3023 Append 3024 (Make_Parameter_Specification (Loc, 3025 Defining_Identifier => 3026 Make_Defining_Identifier (Sloc (Formal), 3027 Chars => Chars (Formal)), 3028 In_Present => In_Present (Parent (Formal)), 3029 Out_Present => Out_Present (Parent (Formal)), 3030 Parameter_Type => 3031 New_Reference_To (Etype (Formal), Loc), 3032 Expression => 3033 New_Copy_Tree (Expression (Parent (Formal)))), 3034 Plist); 3035 3036 Next_Formal (Formal); 3037 end loop; 3038 end if; 3039 3040 return Plist; 3041 end Copy_Parameter_List; 3042 3043 -------------------------------- 3044 -- Corresponding_Generic_Type -- 3045 -------------------------------- 3046 3047 function Corresponding_Generic_Type (T : Entity_Id) return Entity_Id is 3048 Inst : Entity_Id; 3049 Gen : Entity_Id; 3050 Typ : Entity_Id; 3051 3052 begin 3053 if not Is_Generic_Actual_Type (T) then 3054 return Any_Type; 3055 3056 -- If the actual is the actual of an enclosing instance, resolution 3057 -- was correct in the generic. 3058 3059 elsif Nkind (Parent (T)) = N_Subtype_Declaration 3060 and then Is_Entity_Name (Subtype_Indication (Parent (T))) 3061 and then 3062 Is_Generic_Actual_Type (Entity (Subtype_Indication (Parent (T)))) 3063 then 3064 return Any_Type; 3065 3066 else 3067 Inst := Scope (T); 3068 3069 if Is_Wrapper_Package (Inst) then 3070 Inst := Related_Instance (Inst); 3071 end if; 3072 3073 Gen := 3074 Generic_Parent 3075 (Specification (Unit_Declaration_Node (Inst))); 3076 3077 -- Generic actual has the same name as the corresponding formal 3078 3079 Typ := First_Entity (Gen); 3080 while Present (Typ) loop 3081 if Chars (Typ) = Chars (T) then 3082 return Typ; 3083 end if; 3084 3085 Next_Entity (Typ); 3086 end loop; 3087 3088 return Any_Type; 3089 end if; 3090 end Corresponding_Generic_Type; 3091 3092 -------------------- 3093 -- Current_Entity -- 3094 -------------------- 3095 3096 -- The currently visible definition for a given identifier is the 3097 -- one most chained at the start of the visibility chain, i.e. the 3098 -- one that is referenced by the Node_Id value of the name of the 3099 -- given identifier. 3100 3101 function Current_Entity (N : Node_Id) return Entity_Id is 3102 begin 3103 return Get_Name_Entity_Id (Chars (N)); 3104 end Current_Entity; 3105 3106 ----------------------------- 3107 -- Current_Entity_In_Scope -- 3108 ----------------------------- 3109 3110 function Current_Entity_In_Scope (N : Node_Id) return Entity_Id is 3111 E : Entity_Id; 3112 CS : constant Entity_Id := Current_Scope; 3113 3114 Transient_Case : constant Boolean := Scope_Is_Transient; 3115 3116 begin 3117 E := Get_Name_Entity_Id (Chars (N)); 3118 while Present (E) 3119 and then Scope (E) /= CS 3120 and then (not Transient_Case or else Scope (E) /= Scope (CS)) 3121 loop 3122 E := Homonym (E); 3123 end loop; 3124 3125 return E; 3126 end Current_Entity_In_Scope; 3127 3128 ------------------- 3129 -- Current_Scope -- 3130 ------------------- 3131 3132 function Current_Scope return Entity_Id is 3133 begin 3134 if Scope_Stack.Last = -1 then 3135 return Standard_Standard; 3136 else 3137 declare 3138 C : constant Entity_Id := 3139 Scope_Stack.Table (Scope_Stack.Last).Entity; 3140 begin 3141 if Present (C) then 3142 return C; 3143 else 3144 return Standard_Standard; 3145 end if; 3146 end; 3147 end if; 3148 end Current_Scope; 3149 3150 ------------------------ 3151 -- Current_Subprogram -- 3152 ------------------------ 3153 3154 function Current_Subprogram return Entity_Id is 3155 Scop : constant Entity_Id := Current_Scope; 3156 begin 3157 if Is_Subprogram (Scop) or else Is_Generic_Subprogram (Scop) then 3158 return Scop; 3159 else 3160 return Enclosing_Subprogram (Scop); 3161 end if; 3162 end Current_Subprogram; 3163 3164 ---------------------------------- 3165 -- Deepest_Type_Access_Level -- 3166 ---------------------------------- 3167 3168 function Deepest_Type_Access_Level (Typ : Entity_Id) return Uint is 3169 begin 3170 if Ekind (Typ) = E_Anonymous_Access_Type 3171 and then not Is_Local_Anonymous_Access (Typ) 3172 and then Nkind (Associated_Node_For_Itype (Typ)) = N_Object_Declaration 3173 then 3174 -- Typ is the type of an Ada 2012 stand-alone object of an anonymous 3175 -- access type. 3176 3177 return 3178 Scope_Depth (Enclosing_Dynamic_Scope 3179 (Defining_Identifier 3180 (Associated_Node_For_Itype (Typ)))); 3181 3182 -- For generic formal type, return Int'Last (infinite). 3183 -- See comment preceding Is_Generic_Type call in Type_Access_Level. 3184 3185 elsif Is_Generic_Type (Root_Type (Typ)) then 3186 return UI_From_Int (Int'Last); 3187 3188 else 3189 return Type_Access_Level (Typ); 3190 end if; 3191 end Deepest_Type_Access_Level; 3192 3193 --------------------- 3194 -- Defining_Entity -- 3195 --------------------- 3196 3197 function Defining_Entity (N : Node_Id) return Entity_Id is 3198 K : constant Node_Kind := Nkind (N); 3199 Err : Entity_Id := Empty; 3200 3201 begin 3202 case K is 3203 when 3204 N_Subprogram_Declaration | 3205 N_Abstract_Subprogram_Declaration | 3206 N_Subprogram_Body | 3207 N_Package_Declaration | 3208 N_Subprogram_Renaming_Declaration | 3209 N_Subprogram_Body_Stub | 3210 N_Generic_Subprogram_Declaration | 3211 N_Generic_Package_Declaration | 3212 N_Formal_Subprogram_Declaration | 3213 N_Expression_Function 3214 => 3215 return Defining_Entity (Specification (N)); 3216 3217 when 3218 N_Component_Declaration | 3219 N_Defining_Program_Unit_Name | 3220 N_Discriminant_Specification | 3221 N_Entry_Body | 3222 N_Entry_Declaration | 3223 N_Entry_Index_Specification | 3224 N_Exception_Declaration | 3225 N_Exception_Renaming_Declaration | 3226 N_Formal_Object_Declaration | 3227 N_Formal_Package_Declaration | 3228 N_Formal_Type_Declaration | 3229 N_Full_Type_Declaration | 3230 N_Implicit_Label_Declaration | 3231 N_Incomplete_Type_Declaration | 3232 N_Loop_Parameter_Specification | 3233 N_Number_Declaration | 3234 N_Object_Declaration | 3235 N_Object_Renaming_Declaration | 3236 N_Package_Body_Stub | 3237 N_Parameter_Specification | 3238 N_Private_Extension_Declaration | 3239 N_Private_Type_Declaration | 3240 N_Protected_Body | 3241 N_Protected_Body_Stub | 3242 N_Protected_Type_Declaration | 3243 N_Single_Protected_Declaration | 3244 N_Single_Task_Declaration | 3245 N_Subtype_Declaration | 3246 N_Task_Body | 3247 N_Task_Body_Stub | 3248 N_Task_Type_Declaration 3249 => 3250 return Defining_Identifier (N); 3251 3252 when N_Subunit => 3253 return Defining_Entity (Proper_Body (N)); 3254 3255 when 3256 N_Function_Instantiation | 3257 N_Function_Specification | 3258 N_Generic_Function_Renaming_Declaration | 3259 N_Generic_Package_Renaming_Declaration | 3260 N_Generic_Procedure_Renaming_Declaration | 3261 N_Package_Body | 3262 N_Package_Instantiation | 3263 N_Package_Renaming_Declaration | 3264 N_Package_Specification | 3265 N_Procedure_Instantiation | 3266 N_Procedure_Specification 3267 => 3268 declare 3269 Nam : constant Node_Id := Defining_Unit_Name (N); 3270 3271 begin 3272 if Nkind (Nam) in N_Entity then 3273 return Nam; 3274 3275 -- For Error, make up a name and attach to declaration 3276 -- so we can continue semantic analysis 3277 3278 elsif Nam = Error then 3279 Err := Make_Temporary (Sloc (N), 'T'); 3280 Set_Defining_Unit_Name (N, Err); 3281 3282 return Err; 3283 -- If not an entity, get defining identifier 3284 3285 else 3286 return Defining_Identifier (Nam); 3287 end if; 3288 end; 3289 3290 when N_Block_Statement => 3291 return Entity (Identifier (N)); 3292 3293 when others => 3294 raise Program_Error; 3295 3296 end case; 3297 end Defining_Entity; 3298 3299 -------------------------- 3300 -- Denotes_Discriminant -- 3301 -------------------------- 3302 3303 function Denotes_Discriminant 3304 (N : Node_Id; 3305 Check_Concurrent : Boolean := False) return Boolean 3306 is 3307 E : Entity_Id; 3308 begin 3309 if not Is_Entity_Name (N) 3310 or else No (Entity (N)) 3311 then 3312 return False; 3313 else 3314 E := Entity (N); 3315 end if; 3316 3317 -- If we are checking for a protected type, the discriminant may have 3318 -- been rewritten as the corresponding discriminal of the original type 3319 -- or of the corresponding concurrent record, depending on whether we 3320 -- are in the spec or body of the protected type. 3321 3322 return Ekind (E) = E_Discriminant 3323 or else 3324 (Check_Concurrent 3325 and then Ekind (E) = E_In_Parameter 3326 and then Present (Discriminal_Link (E)) 3327 and then 3328 (Is_Concurrent_Type (Scope (Discriminal_Link (E))) 3329 or else 3330 Is_Concurrent_Record_Type (Scope (Discriminal_Link (E))))); 3331 3332 end Denotes_Discriminant; 3333 3334 ------------------------- 3335 -- Denotes_Same_Object -- 3336 ------------------------- 3337 3338 function Denotes_Same_Object (A1, A2 : Node_Id) return Boolean is 3339 Obj1 : Node_Id := A1; 3340 Obj2 : Node_Id := A2; 3341 3342 function Has_Prefix (N : Node_Id) return Boolean; 3343 -- Return True if N has attribute Prefix 3344 3345 function Is_Renaming (N : Node_Id) return Boolean; 3346 -- Return true if N names a renaming entity 3347 3348 function Is_Valid_Renaming (N : Node_Id) return Boolean; 3349 -- For renamings, return False if the prefix of any dereference within 3350 -- the renamed object_name is a variable, or any expression within the 3351 -- renamed object_name contains references to variables or calls on 3352 -- nonstatic functions; otherwise return True (RM 6.4.1(6.10/3)) 3353 3354 ---------------- 3355 -- Has_Prefix -- 3356 ---------------- 3357 3358 function Has_Prefix (N : Node_Id) return Boolean is 3359 begin 3360 return 3361 Nkind_In (N, 3362 N_Attribute_Reference, 3363 N_Expanded_Name, 3364 N_Explicit_Dereference, 3365 N_Indexed_Component, 3366 N_Reference, 3367 N_Selected_Component, 3368 N_Slice); 3369 end Has_Prefix; 3370 3371 ----------------- 3372 -- Is_Renaming -- 3373 ----------------- 3374 3375 function Is_Renaming (N : Node_Id) return Boolean is 3376 begin 3377 return Is_Entity_Name (N) 3378 and then Present (Renamed_Entity (Entity (N))); 3379 end Is_Renaming; 3380 3381 ----------------------- 3382 -- Is_Valid_Renaming -- 3383 ----------------------- 3384 3385 function Is_Valid_Renaming (N : Node_Id) return Boolean is 3386 3387 function Check_Renaming (N : Node_Id) return Boolean; 3388 -- Recursive function used to traverse all the prefixes of N 3389 3390 function Check_Renaming (N : Node_Id) return Boolean is 3391 begin 3392 if Is_Renaming (N) 3393 and then not Check_Renaming (Renamed_Entity (Entity (N))) 3394 then 3395 return False; 3396 end if; 3397 3398 if Nkind (N) = N_Indexed_Component then 3399 declare 3400 Indx : Node_Id; 3401 3402 begin 3403 Indx := First (Expressions (N)); 3404 while Present (Indx) loop 3405 if not Is_OK_Static_Expression (Indx) then 3406 return False; 3407 end if; 3408 3409 Next_Index (Indx); 3410 end loop; 3411 end; 3412 end if; 3413 3414 if Has_Prefix (N) then 3415 declare 3416 P : constant Node_Id := Prefix (N); 3417 3418 begin 3419 if Nkind (N) = N_Explicit_Dereference 3420 and then Is_Variable (P) 3421 then 3422 return False; 3423 3424 elsif Is_Entity_Name (P) 3425 and then Ekind (Entity (P)) = E_Function 3426 then 3427 return False; 3428 3429 elsif Nkind (P) = N_Function_Call then 3430 return False; 3431 end if; 3432 3433 -- Recursion to continue traversing the prefix of the 3434 -- renaming expression 3435 3436 return Check_Renaming (P); 3437 end; 3438 end if; 3439 3440 return True; 3441 end Check_Renaming; 3442 3443 -- Start of processing for Is_Valid_Renaming 3444 3445 begin 3446 return Check_Renaming (N); 3447 end Is_Valid_Renaming; 3448 3449 -- Start of processing for Denotes_Same_Object 3450 3451 begin 3452 -- Both names statically denote the same stand-alone object or parameter 3453 -- (RM 6.4.1(6.5/3)) 3454 3455 if Is_Entity_Name (Obj1) 3456 and then Is_Entity_Name (Obj2) 3457 and then Entity (Obj1) = Entity (Obj2) 3458 then 3459 return True; 3460 end if; 3461 3462 -- For renamings, the prefix of any dereference within the renamed 3463 -- object_name is not a variable, and any expression within the 3464 -- renamed object_name contains no references to variables nor 3465 -- calls on nonstatic functions (RM 6.4.1(6.10/3)). 3466 3467 if Is_Renaming (Obj1) then 3468 if Is_Valid_Renaming (Obj1) then 3469 Obj1 := Renamed_Entity (Entity (Obj1)); 3470 else 3471 return False; 3472 end if; 3473 end if; 3474 3475 if Is_Renaming (Obj2) then 3476 if Is_Valid_Renaming (Obj2) then 3477 Obj2 := Renamed_Entity (Entity (Obj2)); 3478 else 3479 return False; 3480 end if; 3481 end if; 3482 3483 -- No match if not same node kind (such cases are handled by 3484 -- Denotes_Same_Prefix) 3485 3486 if Nkind (Obj1) /= Nkind (Obj2) then 3487 return False; 3488 3489 -- After handling valid renamings, one of the two names statically 3490 -- denoted a renaming declaration whose renamed object_name is known 3491 -- to denote the same object as the other (RM 6.4.1(6.10/3)) 3492 3493 elsif Is_Entity_Name (Obj1) then 3494 if Is_Entity_Name (Obj2) then 3495 return Entity (Obj1) = Entity (Obj2); 3496 else 3497 return False; 3498 end if; 3499 3500 -- Both names are selected_components, their prefixes are known to 3501 -- denote the same object, and their selector_names denote the same 3502 -- component (RM 6.4.1(6.6/3) 3503 3504 elsif Nkind (Obj1) = N_Selected_Component then 3505 return Denotes_Same_Object (Prefix (Obj1), Prefix (Obj2)) 3506 and then 3507 Entity (Selector_Name (Obj1)) = Entity (Selector_Name (Obj2)); 3508 3509 -- Both names are dereferences and the dereferenced names are known to 3510 -- denote the same object (RM 6.4.1(6.7/3)) 3511 3512 elsif Nkind (Obj1) = N_Explicit_Dereference then 3513 return Denotes_Same_Object (Prefix (Obj1), Prefix (Obj2)); 3514 3515 -- Both names are indexed_components, their prefixes are known to denote 3516 -- the same object, and each of the pairs of corresponding index values 3517 -- are either both static expressions with the same static value or both 3518 -- names that are known to denote the same object (RM 6.4.1(6.8/3)) 3519 3520 elsif Nkind (Obj1) = N_Indexed_Component then 3521 if not Denotes_Same_Object (Prefix (Obj1), Prefix (Obj2)) then 3522 return False; 3523 else 3524 declare 3525 Indx1 : Node_Id; 3526 Indx2 : Node_Id; 3527 3528 begin 3529 Indx1 := First (Expressions (Obj1)); 3530 Indx2 := First (Expressions (Obj2)); 3531 while Present (Indx1) loop 3532 3533 -- Indexes must denote the same static value or same object 3534 3535 if Is_OK_Static_Expression (Indx1) then 3536 if not Is_OK_Static_Expression (Indx2) then 3537 return False; 3538 3539 elsif Expr_Value (Indx1) /= Expr_Value (Indx2) then 3540 return False; 3541 end if; 3542 3543 elsif not Denotes_Same_Object (Indx1, Indx2) then 3544 return False; 3545 end if; 3546 3547 Next (Indx1); 3548 Next (Indx2); 3549 end loop; 3550 3551 return True; 3552 end; 3553 end if; 3554 3555 -- Both names are slices, their prefixes are known to denote the same 3556 -- object, and the two slices have statically matching index constraints 3557 -- (RM 6.4.1(6.9/3)) 3558 3559 elsif Nkind (Obj1) = N_Slice 3560 and then Denotes_Same_Object (Prefix (Obj1), Prefix (Obj2)) 3561 then 3562 declare 3563 Lo1, Lo2, Hi1, Hi2 : Node_Id; 3564 3565 begin 3566 Get_Index_Bounds (Etype (Obj1), Lo1, Hi1); 3567 Get_Index_Bounds (Etype (Obj2), Lo2, Hi2); 3568 3569 -- Check whether bounds are statically identical. There is no 3570 -- attempt to detect partial overlap of slices. 3571 3572 return Denotes_Same_Object (Lo1, Lo2) 3573 and then Denotes_Same_Object (Hi1, Hi2); 3574 end; 3575 3576 -- In the recursion, literals appear as indexes. 3577 3578 elsif Nkind (Obj1) = N_Integer_Literal 3579 and then Nkind (Obj2) = N_Integer_Literal 3580 then 3581 return Intval (Obj1) = Intval (Obj2); 3582 3583 else 3584 return False; 3585 end if; 3586 end Denotes_Same_Object; 3587 3588 ------------------------- 3589 -- Denotes_Same_Prefix -- 3590 ------------------------- 3591 3592 function Denotes_Same_Prefix (A1, A2 : Node_Id) return Boolean is 3593 3594 begin 3595 if Is_Entity_Name (A1) then 3596 if Nkind_In (A2, N_Selected_Component, N_Indexed_Component) 3597 and then not Is_Access_Type (Etype (A1)) 3598 then 3599 return Denotes_Same_Object (A1, Prefix (A2)) 3600 or else Denotes_Same_Prefix (A1, Prefix (A2)); 3601 else 3602 return False; 3603 end if; 3604 3605 elsif Is_Entity_Name (A2) then 3606 return Denotes_Same_Prefix (A1 => A2, A2 => A1); 3607 3608 elsif Nkind_In (A1, N_Selected_Component, N_Indexed_Component, N_Slice) 3609 and then 3610 Nkind_In (A2, N_Selected_Component, N_Indexed_Component, N_Slice) 3611 then 3612 declare 3613 Root1, Root2 : Node_Id; 3614 Depth1, Depth2 : Int := 0; 3615 3616 begin 3617 Root1 := Prefix (A1); 3618 while not Is_Entity_Name (Root1) loop 3619 if not Nkind_In 3620 (Root1, N_Selected_Component, N_Indexed_Component) 3621 then 3622 return False; 3623 else 3624 Root1 := Prefix (Root1); 3625 end if; 3626 3627 Depth1 := Depth1 + 1; 3628 end loop; 3629 3630 Root2 := Prefix (A2); 3631 while not Is_Entity_Name (Root2) loop 3632 if not Nkind_In 3633 (Root2, N_Selected_Component, N_Indexed_Component) 3634 then 3635 return False; 3636 else 3637 Root2 := Prefix (Root2); 3638 end if; 3639 3640 Depth2 := Depth2 + 1; 3641 end loop; 3642 3643 -- If both have the same depth and they do not denote the same 3644 -- object, they are disjoint and no warning is needed. 3645 3646 if Depth1 = Depth2 then 3647 return False; 3648 3649 elsif Depth1 > Depth2 then 3650 Root1 := Prefix (A1); 3651 for I in 1 .. Depth1 - Depth2 - 1 loop 3652 Root1 := Prefix (Root1); 3653 end loop; 3654 3655 return Denotes_Same_Object (Root1, A2); 3656 3657 else 3658 Root2 := Prefix (A2); 3659 for I in 1 .. Depth2 - Depth1 - 1 loop 3660 Root2 := Prefix (Root2); 3661 end loop; 3662 3663 return Denotes_Same_Object (A1, Root2); 3664 end if; 3665 end; 3666 3667 else 3668 return False; 3669 end if; 3670 end Denotes_Same_Prefix; 3671 3672 ---------------------- 3673 -- Denotes_Variable -- 3674 ---------------------- 3675 3676 function Denotes_Variable (N : Node_Id) return Boolean is 3677 begin 3678 return Is_Variable (N) and then Paren_Count (N) = 0; 3679 end Denotes_Variable; 3680 3681 ----------------------------- 3682 -- Depends_On_Discriminant -- 3683 ----------------------------- 3684 3685 function Depends_On_Discriminant (N : Node_Id) return Boolean is 3686 L : Node_Id; 3687 H : Node_Id; 3688 3689 begin 3690 Get_Index_Bounds (N, L, H); 3691 return Denotes_Discriminant (L) or else Denotes_Discriminant (H); 3692 end Depends_On_Discriminant; 3693 3694 ------------------------- 3695 -- Designate_Same_Unit -- 3696 ------------------------- 3697 3698 function Designate_Same_Unit 3699 (Name1 : Node_Id; 3700 Name2 : Node_Id) return Boolean 3701 is 3702 K1 : constant Node_Kind := Nkind (Name1); 3703 K2 : constant Node_Kind := Nkind (Name2); 3704 3705 function Prefix_Node (N : Node_Id) return Node_Id; 3706 -- Returns the parent unit name node of a defining program unit name 3707 -- or the prefix if N is a selected component or an expanded name. 3708 3709 function Select_Node (N : Node_Id) return Node_Id; 3710 -- Returns the defining identifier node of a defining program unit 3711 -- name or the selector node if N is a selected component or an 3712 -- expanded name. 3713 3714 ----------------- 3715 -- Prefix_Node -- 3716 ----------------- 3717 3718 function Prefix_Node (N : Node_Id) return Node_Id is 3719 begin 3720 if Nkind (N) = N_Defining_Program_Unit_Name then 3721 return Name (N); 3722 3723 else 3724 return Prefix (N); 3725 end if; 3726 end Prefix_Node; 3727 3728 ----------------- 3729 -- Select_Node -- 3730 ----------------- 3731 3732 function Select_Node (N : Node_Id) return Node_Id is 3733 begin 3734 if Nkind (N) = N_Defining_Program_Unit_Name then 3735 return Defining_Identifier (N); 3736 3737 else 3738 return Selector_Name (N); 3739 end if; 3740 end Select_Node; 3741 3742 -- Start of processing for Designate_Next_Unit 3743 3744 begin 3745 if (K1 = N_Identifier or else 3746 K1 = N_Defining_Identifier) 3747 and then 3748 (K2 = N_Identifier or else 3749 K2 = N_Defining_Identifier) 3750 then 3751 return Chars (Name1) = Chars (Name2); 3752 3753 elsif 3754 (K1 = N_Expanded_Name or else 3755 K1 = N_Selected_Component or else 3756 K1 = N_Defining_Program_Unit_Name) 3757 and then 3758 (K2 = N_Expanded_Name or else 3759 K2 = N_Selected_Component or else 3760 K2 = N_Defining_Program_Unit_Name) 3761 then 3762 return 3763 (Chars (Select_Node (Name1)) = Chars (Select_Node (Name2))) 3764 and then 3765 Designate_Same_Unit (Prefix_Node (Name1), Prefix_Node (Name2)); 3766 3767 else 3768 return False; 3769 end if; 3770 end Designate_Same_Unit; 3771 3772 ------------------------------------------ 3773 -- function Dynamic_Accessibility_Level -- 3774 ------------------------------------------ 3775 3776 function Dynamic_Accessibility_Level (Expr : Node_Id) return Node_Id is 3777 E : Entity_Id; 3778 Loc : constant Source_Ptr := Sloc (Expr); 3779 3780 function Make_Level_Literal (Level : Uint) return Node_Id; 3781 -- Construct an integer literal representing an accessibility level 3782 -- with its type set to Natural. 3783 3784 ------------------------ 3785 -- Make_Level_Literal -- 3786 ------------------------ 3787 3788 function Make_Level_Literal (Level : Uint) return Node_Id is 3789 Result : constant Node_Id := Make_Integer_Literal (Loc, Level); 3790 begin 3791 Set_Etype (Result, Standard_Natural); 3792 return Result; 3793 end Make_Level_Literal; 3794 3795 -- Start of processing for Dynamic_Accessibility_Level 3796 3797 begin 3798 if Is_Entity_Name (Expr) then 3799 E := Entity (Expr); 3800 3801 if Present (Renamed_Object (E)) then 3802 return Dynamic_Accessibility_Level (Renamed_Object (E)); 3803 end if; 3804 3805 if Is_Formal (E) or else Ekind_In (E, E_Variable, E_Constant) then 3806 if Present (Extra_Accessibility (E)) then 3807 return New_Occurrence_Of (Extra_Accessibility (E), Loc); 3808 end if; 3809 end if; 3810 end if; 3811 3812 -- Unimplemented: Ptr.all'Access, where Ptr has Extra_Accessibility ??? 3813 3814 case Nkind (Expr) is 3815 3816 -- For access discriminant, the level of the enclosing object 3817 3818 when N_Selected_Component => 3819 if Ekind (Entity (Selector_Name (Expr))) = E_Discriminant 3820 and then Ekind (Etype (Entity (Selector_Name (Expr)))) = 3821 E_Anonymous_Access_Type 3822 then 3823 return Make_Level_Literal (Object_Access_Level (Expr)); 3824 end if; 3825 3826 when N_Attribute_Reference => 3827 case Get_Attribute_Id (Attribute_Name (Expr)) is 3828 3829 -- For X'Access, the level of the prefix X 3830 3831 when Attribute_Access => 3832 return Make_Level_Literal 3833 (Object_Access_Level (Prefix (Expr))); 3834 3835 -- Treat the unchecked attributes as library-level 3836 3837 when Attribute_Unchecked_Access | 3838 Attribute_Unrestricted_Access => 3839 return Make_Level_Literal (Scope_Depth (Standard_Standard)); 3840 3841 -- No other access-valued attributes 3842 3843 when others => 3844 raise Program_Error; 3845 end case; 3846 3847 when N_Allocator => 3848 3849 -- Unimplemented: depends on context. As an actual parameter where 3850 -- formal type is anonymous, use 3851 -- Scope_Depth (Current_Scope) + 1. 3852 -- For other cases, see 3.10.2(14/3) and following. ??? 3853 3854 null; 3855 3856 when N_Type_Conversion => 3857 if not Is_Local_Anonymous_Access (Etype (Expr)) then 3858 3859 -- Handle type conversions introduced for a rename of an 3860 -- Ada 2012 stand-alone object of an anonymous access type. 3861 3862 return Dynamic_Accessibility_Level (Expression (Expr)); 3863 end if; 3864 3865 when others => 3866 null; 3867 end case; 3868 3869 return Make_Level_Literal (Type_Access_Level (Etype (Expr))); 3870 end Dynamic_Accessibility_Level; 3871 3872 ----------------------------------- 3873 -- Effective_Extra_Accessibility -- 3874 ----------------------------------- 3875 3876 function Effective_Extra_Accessibility (Id : Entity_Id) return Entity_Id is 3877 begin 3878 if Present (Renamed_Object (Id)) 3879 and then Is_Entity_Name (Renamed_Object (Id)) 3880 then 3881 return Effective_Extra_Accessibility (Entity (Renamed_Object (Id))); 3882 else 3883 return Extra_Accessibility (Id); 3884 end if; 3885 end Effective_Extra_Accessibility; 3886 3887 ------------------------------ 3888 -- Enclosing_Comp_Unit_Node -- 3889 ------------------------------ 3890 3891 function Enclosing_Comp_Unit_Node (N : Node_Id) return Node_Id is 3892 Current_Node : Node_Id; 3893 3894 begin 3895 Current_Node := N; 3896 while Present (Current_Node) 3897 and then Nkind (Current_Node) /= N_Compilation_Unit 3898 loop 3899 Current_Node := Parent (Current_Node); 3900 end loop; 3901 3902 if Nkind (Current_Node) /= N_Compilation_Unit then 3903 return Empty; 3904 else 3905 return Current_Node; 3906 end if; 3907 end Enclosing_Comp_Unit_Node; 3908 3909 -------------------------- 3910 -- Enclosing_CPP_Parent -- 3911 -------------------------- 3912 3913 function Enclosing_CPP_Parent (Typ : Entity_Id) return Entity_Id is 3914 Parent_Typ : Entity_Id := Typ; 3915 3916 begin 3917 while not Is_CPP_Class (Parent_Typ) 3918 and then Etype (Parent_Typ) /= Parent_Typ 3919 loop 3920 Parent_Typ := Etype (Parent_Typ); 3921 3922 if Is_Private_Type (Parent_Typ) then 3923 Parent_Typ := Full_View (Base_Type (Parent_Typ)); 3924 end if; 3925 end loop; 3926 3927 pragma Assert (Is_CPP_Class (Parent_Typ)); 3928 return Parent_Typ; 3929 end Enclosing_CPP_Parent; 3930 3931 ---------------------------- 3932 -- Enclosing_Generic_Body -- 3933 ---------------------------- 3934 3935 function Enclosing_Generic_Body 3936 (N : Node_Id) return Node_Id 3937 is 3938 P : Node_Id; 3939 Decl : Node_Id; 3940 Spec : Node_Id; 3941 3942 begin 3943 P := Parent (N); 3944 while Present (P) loop 3945 if Nkind (P) = N_Package_Body 3946 or else Nkind (P) = N_Subprogram_Body 3947 then 3948 Spec := Corresponding_Spec (P); 3949 3950 if Present (Spec) then 3951 Decl := Unit_Declaration_Node (Spec); 3952 3953 if Nkind (Decl) = N_Generic_Package_Declaration 3954 or else Nkind (Decl) = N_Generic_Subprogram_Declaration 3955 then 3956 return P; 3957 end if; 3958 end if; 3959 end if; 3960 3961 P := Parent (P); 3962 end loop; 3963 3964 return Empty; 3965 end Enclosing_Generic_Body; 3966 3967 ---------------------------- 3968 -- Enclosing_Generic_Unit -- 3969 ---------------------------- 3970 3971 function Enclosing_Generic_Unit 3972 (N : Node_Id) return Node_Id 3973 is 3974 P : Node_Id; 3975 Decl : Node_Id; 3976 Spec : Node_Id; 3977 3978 begin 3979 P := Parent (N); 3980 while Present (P) loop 3981 if Nkind (P) = N_Generic_Package_Declaration 3982 or else Nkind (P) = N_Generic_Subprogram_Declaration 3983 then 3984 return P; 3985 3986 elsif Nkind (P) = N_Package_Body 3987 or else Nkind (P) = N_Subprogram_Body 3988 then 3989 Spec := Corresponding_Spec (P); 3990 3991 if Present (Spec) then 3992 Decl := Unit_Declaration_Node (Spec); 3993 3994 if Nkind (Decl) = N_Generic_Package_Declaration 3995 or else Nkind (Decl) = N_Generic_Subprogram_Declaration 3996 then 3997 return Decl; 3998 end if; 3999 end if; 4000 end if; 4001 4002 P := Parent (P); 4003 end loop; 4004 4005 return Empty; 4006 end Enclosing_Generic_Unit; 4007 4008 ------------------------------- 4009 -- Enclosing_Lib_Unit_Entity -- 4010 ------------------------------- 4011 4012 function Enclosing_Lib_Unit_Entity 4013 (E : Entity_Id := Current_Scope) return Entity_Id 4014 is 4015 Unit_Entity : Entity_Id; 4016 4017 begin 4018 -- Look for enclosing library unit entity by following scope links. 4019 -- Equivalent to, but faster than indexing through the scope stack. 4020 4021 Unit_Entity := E; 4022 while (Present (Scope (Unit_Entity)) 4023 and then Scope (Unit_Entity) /= Standard_Standard) 4024 and not Is_Child_Unit (Unit_Entity) 4025 loop 4026 Unit_Entity := Scope (Unit_Entity); 4027 end loop; 4028 4029 return Unit_Entity; 4030 end Enclosing_Lib_Unit_Entity; 4031 4032 ----------------------- 4033 -- Enclosing_Package -- 4034 ----------------------- 4035 4036 function Enclosing_Package (E : Entity_Id) return Entity_Id is 4037 Dynamic_Scope : constant Entity_Id := Enclosing_Dynamic_Scope (E); 4038 4039 begin 4040 if Dynamic_Scope = Standard_Standard then 4041 return Standard_Standard; 4042 4043 elsif Dynamic_Scope = Empty then 4044 return Empty; 4045 4046 elsif Ekind_In (Dynamic_Scope, E_Package, E_Package_Body, 4047 E_Generic_Package) 4048 then 4049 return Dynamic_Scope; 4050 4051 else 4052 return Enclosing_Package (Dynamic_Scope); 4053 end if; 4054 end Enclosing_Package; 4055 4056 -------------------------- 4057 -- Enclosing_Subprogram -- 4058 -------------------------- 4059 4060 function Enclosing_Subprogram (E : Entity_Id) return Entity_Id is 4061 Dynamic_Scope : constant Entity_Id := Enclosing_Dynamic_Scope (E); 4062 4063 begin 4064 if Dynamic_Scope = Standard_Standard then 4065 return Empty; 4066 4067 elsif Dynamic_Scope = Empty then 4068 return Empty; 4069 4070 elsif Ekind (Dynamic_Scope) = E_Subprogram_Body then 4071 return Corresponding_Spec (Parent (Parent (Dynamic_Scope))); 4072 4073 elsif Ekind (Dynamic_Scope) = E_Block 4074 or else Ekind (Dynamic_Scope) = E_Return_Statement 4075 then 4076 return Enclosing_Subprogram (Dynamic_Scope); 4077 4078 elsif Ekind (Dynamic_Scope) = E_Task_Type then 4079 return Get_Task_Body_Procedure (Dynamic_Scope); 4080 4081 elsif Ekind (Dynamic_Scope) = E_Limited_Private_Type 4082 and then Present (Full_View (Dynamic_Scope)) 4083 and then Ekind (Full_View (Dynamic_Scope)) = E_Task_Type 4084 then 4085 return Get_Task_Body_Procedure (Full_View (Dynamic_Scope)); 4086 4087 -- No body is generated if the protected operation is eliminated 4088 4089 elsif Convention (Dynamic_Scope) = Convention_Protected 4090 and then not Is_Eliminated (Dynamic_Scope) 4091 and then Present (Protected_Body_Subprogram (Dynamic_Scope)) 4092 then 4093 return Protected_Body_Subprogram (Dynamic_Scope); 4094 4095 else 4096 return Dynamic_Scope; 4097 end if; 4098 end Enclosing_Subprogram; 4099 4100 ------------------------ 4101 -- Ensure_Freeze_Node -- 4102 ------------------------ 4103 4104 procedure Ensure_Freeze_Node (E : Entity_Id) is 4105 FN : Node_Id; 4106 4107 begin 4108 if No (Freeze_Node (E)) then 4109 FN := Make_Freeze_Entity (Sloc (E)); 4110 Set_Has_Delayed_Freeze (E); 4111 Set_Freeze_Node (E, FN); 4112 Set_Access_Types_To_Process (FN, No_Elist); 4113 Set_TSS_Elist (FN, No_Elist); 4114 Set_Entity (FN, E); 4115 end if; 4116 end Ensure_Freeze_Node; 4117 4118 ---------------- 4119 -- Enter_Name -- 4120 ---------------- 4121 4122 procedure Enter_Name (Def_Id : Entity_Id) is 4123 C : constant Entity_Id := Current_Entity (Def_Id); 4124 E : constant Entity_Id := Current_Entity_In_Scope (Def_Id); 4125 S : constant Entity_Id := Current_Scope; 4126 4127 begin 4128 Generate_Definition (Def_Id); 4129 4130 -- Add new name to current scope declarations. Check for duplicate 4131 -- declaration, which may or may not be a genuine error. 4132 4133 if Present (E) then 4134 4135 -- Case of previous entity entered because of a missing declaration 4136 -- or else a bad subtype indication. Best is to use the new entity, 4137 -- and make the previous one invisible. 4138 4139 if Etype (E) = Any_Type then 4140 Set_Is_Immediately_Visible (E, False); 4141 4142 -- Case of renaming declaration constructed for package instances. 4143 -- if there is an explicit declaration with the same identifier, 4144 -- the renaming is not immediately visible any longer, but remains 4145 -- visible through selected component notation. 4146 4147 elsif Nkind (Parent (E)) = N_Package_Renaming_Declaration 4148 and then not Comes_From_Source (E) 4149 then 4150 Set_Is_Immediately_Visible (E, False); 4151 4152 -- The new entity may be the package renaming, which has the same 4153 -- same name as a generic formal which has been seen already. 4154 4155 elsif Nkind (Parent (Def_Id)) = N_Package_Renaming_Declaration 4156 and then not Comes_From_Source (Def_Id) 4157 then 4158 Set_Is_Immediately_Visible (E, False); 4159 4160 -- For a fat pointer corresponding to a remote access to subprogram, 4161 -- we use the same identifier as the RAS type, so that the proper 4162 -- name appears in the stub. This type is only retrieved through 4163 -- the RAS type and never by visibility, and is not added to the 4164 -- visibility list (see below). 4165 4166 elsif Nkind (Parent (Def_Id)) = N_Full_Type_Declaration 4167 and then Present (Corresponding_Remote_Type (Def_Id)) 4168 then 4169 null; 4170 4171 -- Case of an implicit operation or derived literal. The new entity 4172 -- hides the implicit one, which is removed from all visibility, 4173 -- i.e. the entity list of its scope, and homonym chain of its name. 4174 4175 elsif (Is_Overloadable (E) and then Is_Inherited_Operation (E)) 4176 or else Is_Internal (E) 4177 then 4178 declare 4179 Prev : Entity_Id; 4180 Prev_Vis : Entity_Id; 4181 Decl : constant Node_Id := Parent (E); 4182 4183 begin 4184 -- If E is an implicit declaration, it cannot be the first 4185 -- entity in the scope. 4186 4187 Prev := First_Entity (Current_Scope); 4188 while Present (Prev) 4189 and then Next_Entity (Prev) /= E 4190 loop 4191 Next_Entity (Prev); 4192 end loop; 4193 4194 if No (Prev) then 4195 4196 -- If E is not on the entity chain of the current scope, 4197 -- it is an implicit declaration in the generic formal 4198 -- part of a generic subprogram. When analyzing the body, 4199 -- the generic formals are visible but not on the entity 4200 -- chain of the subprogram. The new entity will become 4201 -- the visible one in the body. 4202 4203 pragma Assert 4204 (Nkind (Parent (Decl)) = N_Generic_Subprogram_Declaration); 4205 null; 4206 4207 else 4208 Set_Next_Entity (Prev, Next_Entity (E)); 4209 4210 if No (Next_Entity (Prev)) then 4211 Set_Last_Entity (Current_Scope, Prev); 4212 end if; 4213 4214 if E = Current_Entity (E) then 4215 Prev_Vis := Empty; 4216 4217 else 4218 Prev_Vis := Current_Entity (E); 4219 while Homonym (Prev_Vis) /= E loop 4220 Prev_Vis := Homonym (Prev_Vis); 4221 end loop; 4222 end if; 4223 4224 if Present (Prev_Vis) then 4225 4226 -- Skip E in the visibility chain 4227 4228 Set_Homonym (Prev_Vis, Homonym (E)); 4229 4230 else 4231 Set_Name_Entity_Id (Chars (E), Homonym (E)); 4232 end if; 4233 end if; 4234 end; 4235 4236 -- This section of code could use a comment ??? 4237 4238 elsif Present (Etype (E)) 4239 and then Is_Concurrent_Type (Etype (E)) 4240 and then E = Def_Id 4241 then 4242 return; 4243 4244 -- If the homograph is a protected component renaming, it should not 4245 -- be hiding the current entity. Such renamings are treated as weak 4246 -- declarations. 4247 4248 elsif Is_Prival (E) then 4249 Set_Is_Immediately_Visible (E, False); 4250 4251 -- In this case the current entity is a protected component renaming. 4252 -- Perform minimal decoration by setting the scope and return since 4253 -- the prival should not be hiding other visible entities. 4254 4255 elsif Is_Prival (Def_Id) then 4256 Set_Scope (Def_Id, Current_Scope); 4257 return; 4258 4259 -- Analogous to privals, the discriminal generated for an entry index 4260 -- parameter acts as a weak declaration. Perform minimal decoration 4261 -- to avoid bogus errors. 4262 4263 elsif Is_Discriminal (Def_Id) 4264 and then Ekind (Discriminal_Link (Def_Id)) = E_Entry_Index_Parameter 4265 then 4266 Set_Scope (Def_Id, Current_Scope); 4267 return; 4268 4269 -- In the body or private part of an instance, a type extension may 4270 -- introduce a component with the same name as that of an actual. The 4271 -- legality rule is not enforced, but the semantics of the full type 4272 -- with two components of same name are not clear at this point??? 4273 4274 elsif In_Instance_Not_Visible then 4275 null; 4276 4277 -- When compiling a package body, some child units may have become 4278 -- visible. They cannot conflict with local entities that hide them. 4279 4280 elsif Is_Child_Unit (E) 4281 and then In_Open_Scopes (Scope (E)) 4282 and then not Is_Immediately_Visible (E) 4283 then 4284 null; 4285 4286 -- Conversely, with front-end inlining we may compile the parent body 4287 -- first, and a child unit subsequently. The context is now the 4288 -- parent spec, and body entities are not visible. 4289 4290 elsif Is_Child_Unit (Def_Id) 4291 and then Is_Package_Body_Entity (E) 4292 and then not In_Package_Body (Current_Scope) 4293 then 4294 null; 4295 4296 -- Case of genuine duplicate declaration 4297 4298 else 4299 Error_Msg_Sloc := Sloc (E); 4300 4301 -- If the previous declaration is an incomplete type declaration 4302 -- this may be an attempt to complete it with a private type. The 4303 -- following avoids confusing cascaded errors. 4304 4305 if Nkind (Parent (E)) = N_Incomplete_Type_Declaration 4306 and then Nkind (Parent (Def_Id)) = N_Private_Type_Declaration 4307 then 4308 Error_Msg_N 4309 ("incomplete type cannot be completed with a private " & 4310 "declaration", Parent (Def_Id)); 4311 Set_Is_Immediately_Visible (E, False); 4312 Set_Full_View (E, Def_Id); 4313 4314 -- An inherited component of a record conflicts with a new 4315 -- discriminant. The discriminant is inserted first in the scope, 4316 -- but the error should be posted on it, not on the component. 4317 4318 elsif Ekind (E) = E_Discriminant 4319 and then Present (Scope (Def_Id)) 4320 and then Scope (Def_Id) /= Current_Scope 4321 then 4322 Error_Msg_Sloc := Sloc (Def_Id); 4323 Error_Msg_N ("& conflicts with declaration#", E); 4324 return; 4325 4326 -- If the name of the unit appears in its own context clause, a 4327 -- dummy package with the name has already been created, and the 4328 -- error emitted. Try to continue quietly. 4329 4330 elsif Error_Posted (E) 4331 and then Sloc (E) = No_Location 4332 and then Nkind (Parent (E)) = N_Package_Specification 4333 and then Current_Scope = Standard_Standard 4334 then 4335 Set_Scope (Def_Id, Current_Scope); 4336 return; 4337 4338 else 4339 Error_Msg_N ("& conflicts with declaration#", Def_Id); 4340 4341 -- Avoid cascaded messages with duplicate components in 4342 -- derived types. 4343 4344 if Ekind_In (E, E_Component, E_Discriminant) then 4345 return; 4346 end if; 4347 end if; 4348 4349 if Nkind (Parent (Parent (Def_Id))) = 4350 N_Generic_Subprogram_Declaration 4351 and then Def_Id = 4352 Defining_Entity (Specification (Parent (Parent (Def_Id)))) 4353 then 4354 Error_Msg_N ("\generic units cannot be overloaded", Def_Id); 4355 end if; 4356 4357 -- If entity is in standard, then we are in trouble, because it 4358 -- means that we have a library package with a duplicated name. 4359 -- That's hard to recover from, so abort! 4360 4361 if S = Standard_Standard then 4362 raise Unrecoverable_Error; 4363 4364 -- Otherwise we continue with the declaration. Having two 4365 -- identical declarations should not cause us too much trouble! 4366 4367 else 4368 null; 4369 end if; 4370 end if; 4371 end if; 4372 4373 -- If we fall through, declaration is OK, at least OK enough to continue 4374 4375 -- If Def_Id is a discriminant or a record component we are in the midst 4376 -- of inheriting components in a derived record definition. Preserve 4377 -- their Ekind and Etype. 4378 4379 if Ekind_In (Def_Id, E_Discriminant, E_Component) then 4380 null; 4381 4382 -- If a type is already set, leave it alone (happens when a type 4383 -- declaration is reanalyzed following a call to the optimizer). 4384 4385 elsif Present (Etype (Def_Id)) then 4386 null; 4387 4388 -- Otherwise, the kind E_Void insures that premature uses of the entity 4389 -- will be detected. Any_Type insures that no cascaded errors will occur 4390 4391 else 4392 Set_Ekind (Def_Id, E_Void); 4393 Set_Etype (Def_Id, Any_Type); 4394 end if; 4395 4396 -- Inherited discriminants and components in derived record types are 4397 -- immediately visible. Itypes are not. 4398 4399 if Ekind_In (Def_Id, E_Discriminant, E_Component) 4400 or else (No (Corresponding_Remote_Type (Def_Id)) 4401 and then not Is_Itype (Def_Id)) 4402 then 4403 Set_Is_Immediately_Visible (Def_Id); 4404 Set_Current_Entity (Def_Id); 4405 end if; 4406 4407 Set_Homonym (Def_Id, C); 4408 Append_Entity (Def_Id, S); 4409 Set_Public_Status (Def_Id); 4410 4411 -- Declaring a homonym is not allowed in SPARK ... 4412 4413 if Present (C) 4414 and then Restriction_Check_Required (SPARK) 4415 then 4416 declare 4417 Enclosing_Subp : constant Node_Id := Enclosing_Subprogram (Def_Id); 4418 Enclosing_Pack : constant Node_Id := Enclosing_Package (Def_Id); 4419 Other_Scope : constant Node_Id := Enclosing_Dynamic_Scope (C); 4420 4421 begin 4422 -- ... unless the new declaration is in a subprogram, and the 4423 -- visible declaration is a variable declaration or a parameter 4424 -- specification outside that subprogram. 4425 4426 if Present (Enclosing_Subp) 4427 and then Nkind_In (Parent (C), N_Object_Declaration, 4428 N_Parameter_Specification) 4429 and then not Scope_Within_Or_Same (Other_Scope, Enclosing_Subp) 4430 then 4431 null; 4432 4433 -- ... or the new declaration is in a package, and the visible 4434 -- declaration occurs outside that package. 4435 4436 elsif Present (Enclosing_Pack) 4437 and then not Scope_Within_Or_Same (Other_Scope, Enclosing_Pack) 4438 then 4439 null; 4440 4441 -- ... or the new declaration is a component declaration in a 4442 -- record type definition. 4443 4444 elsif Nkind (Parent (Def_Id)) = N_Component_Declaration then 4445 null; 4446 4447 -- Don't issue error for non-source entities 4448 4449 elsif Comes_From_Source (Def_Id) 4450 and then Comes_From_Source (C) 4451 then 4452 Error_Msg_Sloc := Sloc (C); 4453 Check_SPARK_Restriction 4454 ("redeclaration of identifier &#", Def_Id); 4455 end if; 4456 end; 4457 end if; 4458 4459 -- Warn if new entity hides an old one 4460 4461 if Warn_On_Hiding and then Present (C) 4462 4463 -- Don't warn for record components since they always have a well 4464 -- defined scope which does not confuse other uses. Note that in 4465 -- some cases, Ekind has not been set yet. 4466 4467 and then Ekind (C) /= E_Component 4468 and then Ekind (C) /= E_Discriminant 4469 and then Nkind (Parent (C)) /= N_Component_Declaration 4470 and then Ekind (Def_Id) /= E_Component 4471 and then Ekind (Def_Id) /= E_Discriminant 4472 and then Nkind (Parent (Def_Id)) /= N_Component_Declaration 4473 4474 -- Don't warn for one character variables. It is too common to use 4475 -- such variables as locals and will just cause too many false hits. 4476 4477 and then Length_Of_Name (Chars (C)) /= 1 4478 4479 -- Don't warn for non-source entities 4480 4481 and then Comes_From_Source (C) 4482 and then Comes_From_Source (Def_Id) 4483 4484 -- Don't warn unless entity in question is in extended main source 4485 4486 and then In_Extended_Main_Source_Unit (Def_Id) 4487 4488 -- Finally, the hidden entity must be either immediately visible or 4489 -- use visible (i.e. from a used package). 4490 4491 and then 4492 (Is_Immediately_Visible (C) 4493 or else 4494 Is_Potentially_Use_Visible (C)) 4495 then 4496 Error_Msg_Sloc := Sloc (C); 4497 Error_Msg_N ("declaration hides &#?h?", Def_Id); 4498 end if; 4499 end Enter_Name; 4500 4501 -------------------------- 4502 -- Explain_Limited_Type -- 4503 -------------------------- 4504 4505 procedure Explain_Limited_Type (T : Entity_Id; N : Node_Id) is 4506 C : Entity_Id; 4507 4508 begin 4509 -- For array, component type must be limited 4510 4511 if Is_Array_Type (T) then 4512 Error_Msg_Node_2 := T; 4513 Error_Msg_NE 4514 ("\component type& of type& is limited", N, Component_Type (T)); 4515 Explain_Limited_Type (Component_Type (T), N); 4516 4517 elsif Is_Record_Type (T) then 4518 4519 -- No need for extra messages if explicit limited record 4520 4521 if Is_Limited_Record (Base_Type (T)) then 4522 return; 4523 end if; 4524 4525 -- Otherwise find a limited component. Check only components that 4526 -- come from source, or inherited components that appear in the 4527 -- source of the ancestor. 4528 4529 C := First_Component (T); 4530 while Present (C) loop 4531 if Is_Limited_Type (Etype (C)) 4532 and then 4533 (Comes_From_Source (C) 4534 or else 4535 (Present (Original_Record_Component (C)) 4536 and then 4537 Comes_From_Source (Original_Record_Component (C)))) 4538 then 4539 Error_Msg_Node_2 := T; 4540 Error_Msg_NE ("\component& of type& has limited type", N, C); 4541 Explain_Limited_Type (Etype (C), N); 4542 return; 4543 end if; 4544 4545 Next_Component (C); 4546 end loop; 4547 4548 -- The type may be declared explicitly limited, even if no component 4549 -- of it is limited, in which case we fall out of the loop. 4550 return; 4551 end if; 4552 end Explain_Limited_Type; 4553 4554 ----------------- 4555 -- Find_Actual -- 4556 ----------------- 4557 4558 procedure Find_Actual 4559 (N : Node_Id; 4560 Formal : out Entity_Id; 4561 Call : out Node_Id) 4562 is 4563 Parnt : constant Node_Id := Parent (N); 4564 Actual : Node_Id; 4565 4566 begin 4567 if (Nkind (Parnt) = N_Indexed_Component 4568 or else 4569 Nkind (Parnt) = N_Selected_Component) 4570 and then N = Prefix (Parnt) 4571 then 4572 Find_Actual (Parnt, Formal, Call); 4573 return; 4574 4575 elsif Nkind (Parnt) = N_Parameter_Association 4576 and then N = Explicit_Actual_Parameter (Parnt) 4577 then 4578 Call := Parent (Parnt); 4579 4580 elsif Nkind (Parnt) in N_Subprogram_Call then 4581 Call := Parnt; 4582 4583 else 4584 Formal := Empty; 4585 Call := Empty; 4586 return; 4587 end if; 4588 4589 -- If we have a call to a subprogram look for the parameter. Note that 4590 -- we exclude overloaded calls, since we don't know enough to be sure 4591 -- of giving the right answer in this case. 4592 4593 if Is_Entity_Name (Name (Call)) 4594 and then Present (Entity (Name (Call))) 4595 and then Is_Overloadable (Entity (Name (Call))) 4596 and then not Is_Overloaded (Name (Call)) 4597 then 4598 -- Fall here if we are definitely a parameter 4599 4600 Actual := First_Actual (Call); 4601 Formal := First_Formal (Entity (Name (Call))); 4602 while Present (Formal) and then Present (Actual) loop 4603 if Actual = N then 4604 return; 4605 else 4606 Actual := Next_Actual (Actual); 4607 Formal := Next_Formal (Formal); 4608 end if; 4609 end loop; 4610 end if; 4611 4612 -- Fall through here if we did not find matching actual 4613 4614 Formal := Empty; 4615 Call := Empty; 4616 end Find_Actual; 4617 4618 --------------------------- 4619 -- Find_Body_Discriminal -- 4620 --------------------------- 4621 4622 function Find_Body_Discriminal 4623 (Spec_Discriminant : Entity_Id) return Entity_Id 4624 is 4625 Tsk : Entity_Id; 4626 Disc : Entity_Id; 4627 4628 begin 4629 -- If expansion is suppressed, then the scope can be the concurrent type 4630 -- itself rather than a corresponding concurrent record type. 4631 4632 if Is_Concurrent_Type (Scope (Spec_Discriminant)) then 4633 Tsk := Scope (Spec_Discriminant); 4634 4635 else 4636 pragma Assert (Is_Concurrent_Record_Type (Scope (Spec_Discriminant))); 4637 4638 Tsk := Corresponding_Concurrent_Type (Scope (Spec_Discriminant)); 4639 end if; 4640 4641 -- Find discriminant of original concurrent type, and use its current 4642 -- discriminal, which is the renaming within the task/protected body. 4643 4644 Disc := First_Discriminant (Tsk); 4645 while Present (Disc) loop 4646 if Chars (Disc) = Chars (Spec_Discriminant) then 4647 return Discriminal (Disc); 4648 end if; 4649 4650 Next_Discriminant (Disc); 4651 end loop; 4652 4653 -- That loop should always succeed in finding a matching entry and 4654 -- returning. Fatal error if not. 4655 4656 raise Program_Error; 4657 end Find_Body_Discriminal; 4658 4659 ------------------------------------- 4660 -- Find_Corresponding_Discriminant -- 4661 ------------------------------------- 4662 4663 function Find_Corresponding_Discriminant 4664 (Id : Node_Id; 4665 Typ : Entity_Id) return Entity_Id 4666 is 4667 Par_Disc : Entity_Id; 4668 Old_Disc : Entity_Id; 4669 New_Disc : Entity_Id; 4670 4671 begin 4672 Par_Disc := Original_Record_Component (Original_Discriminant (Id)); 4673 4674 -- The original type may currently be private, and the discriminant 4675 -- only appear on its full view. 4676 4677 if Is_Private_Type (Scope (Par_Disc)) 4678 and then not Has_Discriminants (Scope (Par_Disc)) 4679 and then Present (Full_View (Scope (Par_Disc))) 4680 then 4681 Old_Disc := First_Discriminant (Full_View (Scope (Par_Disc))); 4682 else 4683 Old_Disc := First_Discriminant (Scope (Par_Disc)); 4684 end if; 4685 4686 if Is_Class_Wide_Type (Typ) then 4687 New_Disc := First_Discriminant (Root_Type (Typ)); 4688 else 4689 New_Disc := First_Discriminant (Typ); 4690 end if; 4691 4692 while Present (Old_Disc) and then Present (New_Disc) loop 4693 if Old_Disc = Par_Disc then 4694 return New_Disc; 4695 else 4696 Next_Discriminant (Old_Disc); 4697 Next_Discriminant (New_Disc); 4698 end if; 4699 end loop; 4700 4701 -- Should always find it 4702 4703 raise Program_Error; 4704 end Find_Corresponding_Discriminant; 4705 4706 -------------------------- 4707 -- Find_Overlaid_Entity -- 4708 -------------------------- 4709 4710 procedure Find_Overlaid_Entity 4711 (N : Node_Id; 4712 Ent : out Entity_Id; 4713 Off : out Boolean) 4714 is 4715 Expr : Node_Id; 4716 4717 begin 4718 -- We are looking for one of the two following forms: 4719 4720 -- for X'Address use Y'Address 4721 4722 -- or 4723 4724 -- Const : constant Address := expr; 4725 -- ... 4726 -- for X'Address use Const; 4727 4728 -- In the second case, the expr is either Y'Address, or recursively a 4729 -- constant that eventually references Y'Address. 4730 4731 Ent := Empty; 4732 Off := False; 4733 4734 if Nkind (N) = N_Attribute_Definition_Clause 4735 and then Chars (N) = Name_Address 4736 then 4737 Expr := Expression (N); 4738 4739 -- This loop checks the form of the expression for Y'Address, 4740 -- using recursion to deal with intermediate constants. 4741 4742 loop 4743 -- Check for Y'Address 4744 4745 if Nkind (Expr) = N_Attribute_Reference 4746 and then Attribute_Name (Expr) = Name_Address 4747 then 4748 Expr := Prefix (Expr); 4749 exit; 4750 4751 -- Check for Const where Const is a constant entity 4752 4753 elsif Is_Entity_Name (Expr) 4754 and then Ekind (Entity (Expr)) = E_Constant 4755 then 4756 Expr := Constant_Value (Entity (Expr)); 4757 4758 -- Anything else does not need checking 4759 4760 else 4761 return; 4762 end if; 4763 end loop; 4764 4765 -- This loop checks the form of the prefix for an entity, using 4766 -- recursion to deal with intermediate components. 4767 4768 loop 4769 -- Check for Y where Y is an entity 4770 4771 if Is_Entity_Name (Expr) then 4772 Ent := Entity (Expr); 4773 return; 4774 4775 -- Check for components 4776 4777 elsif 4778 Nkind_In (Expr, N_Selected_Component, N_Indexed_Component) 4779 then 4780 Expr := Prefix (Expr); 4781 Off := True; 4782 4783 -- Anything else does not need checking 4784 4785 else 4786 return; 4787 end if; 4788 end loop; 4789 end if; 4790 end Find_Overlaid_Entity; 4791 4792 ------------------------- 4793 -- Find_Parameter_Type -- 4794 ------------------------- 4795 4796 function Find_Parameter_Type (Param : Node_Id) return Entity_Id is 4797 begin 4798 if Nkind (Param) /= N_Parameter_Specification then 4799 return Empty; 4800 4801 -- For an access parameter, obtain the type from the formal entity 4802 -- itself, because access to subprogram nodes do not carry a type. 4803 -- Shouldn't we always use the formal entity ??? 4804 4805 elsif Nkind (Parameter_Type (Param)) = N_Access_Definition then 4806 return Etype (Defining_Identifier (Param)); 4807 4808 else 4809 return Etype (Parameter_Type (Param)); 4810 end if; 4811 end Find_Parameter_Type; 4812 4813 ----------------------------- 4814 -- Find_Static_Alternative -- 4815 ----------------------------- 4816 4817 function Find_Static_Alternative (N : Node_Id) return Node_Id is 4818 Expr : constant Node_Id := Expression (N); 4819 Val : constant Uint := Expr_Value (Expr); 4820 Alt : Node_Id; 4821 Choice : Node_Id; 4822 4823 begin 4824 Alt := First (Alternatives (N)); 4825 4826 Search : loop 4827 if Nkind (Alt) /= N_Pragma then 4828 Choice := First (Discrete_Choices (Alt)); 4829 while Present (Choice) loop 4830 4831 -- Others choice, always matches 4832 4833 if Nkind (Choice) = N_Others_Choice then 4834 exit Search; 4835 4836 -- Range, check if value is in the range 4837 4838 elsif Nkind (Choice) = N_Range then 4839 exit Search when 4840 Val >= Expr_Value (Low_Bound (Choice)) 4841 and then 4842 Val <= Expr_Value (High_Bound (Choice)); 4843 4844 -- Choice is a subtype name. Note that we know it must 4845 -- be a static subtype, since otherwise it would have 4846 -- been diagnosed as illegal. 4847 4848 elsif Is_Entity_Name (Choice) 4849 and then Is_Type (Entity (Choice)) 4850 then 4851 exit Search when Is_In_Range (Expr, Etype (Choice), 4852 Assume_Valid => False); 4853 4854 -- Choice is a subtype indication 4855 4856 elsif Nkind (Choice) = N_Subtype_Indication then 4857 declare 4858 C : constant Node_Id := Constraint (Choice); 4859 R : constant Node_Id := Range_Expression (C); 4860 4861 begin 4862 exit Search when 4863 Val >= Expr_Value (Low_Bound (R)) 4864 and then 4865 Val <= Expr_Value (High_Bound (R)); 4866 end; 4867 4868 -- Choice is a simple expression 4869 4870 else 4871 exit Search when Val = Expr_Value (Choice); 4872 end if; 4873 4874 Next (Choice); 4875 end loop; 4876 end if; 4877 4878 Next (Alt); 4879 pragma Assert (Present (Alt)); 4880 end loop Search; 4881 4882 -- The above loop *must* terminate by finding a match, since 4883 -- we know the case statement is valid, and the value of the 4884 -- expression is known at compile time. When we fall out of 4885 -- the loop, Alt points to the alternative that we know will 4886 -- be selected at run time. 4887 4888 return Alt; 4889 end Find_Static_Alternative; 4890 4891 ------------------ 4892 -- First_Actual -- 4893 ------------------ 4894 4895 function First_Actual (Node : Node_Id) return Node_Id is 4896 N : Node_Id; 4897 4898 begin 4899 if No (Parameter_Associations (Node)) then 4900 return Empty; 4901 end if; 4902 4903 N := First (Parameter_Associations (Node)); 4904 4905 if Nkind (N) = N_Parameter_Association then 4906 return First_Named_Actual (Node); 4907 else 4908 return N; 4909 end if; 4910 end First_Actual; 4911 4912 ----------------------- 4913 -- Gather_Components -- 4914 ----------------------- 4915 4916 procedure Gather_Components 4917 (Typ : Entity_Id; 4918 Comp_List : Node_Id; 4919 Governed_By : List_Id; 4920 Into : Elist_Id; 4921 Report_Errors : out Boolean) 4922 is 4923 Assoc : Node_Id; 4924 Variant : Node_Id; 4925 Discrete_Choice : Node_Id; 4926 Comp_Item : Node_Id; 4927 4928 Discrim : Entity_Id; 4929 Discrim_Name : Node_Id; 4930 Discrim_Value : Node_Id; 4931 4932 begin 4933 Report_Errors := False; 4934 4935 if No (Comp_List) or else Null_Present (Comp_List) then 4936 return; 4937 4938 elsif Present (Component_Items (Comp_List)) then 4939 Comp_Item := First (Component_Items (Comp_List)); 4940 4941 else 4942 Comp_Item := Empty; 4943 end if; 4944 4945 while Present (Comp_Item) loop 4946 4947 -- Skip the tag of a tagged record, the interface tags, as well 4948 -- as all items that are not user components (anonymous types, 4949 -- rep clauses, Parent field, controller field). 4950 4951 if Nkind (Comp_Item) = N_Component_Declaration then 4952 declare 4953 Comp : constant Entity_Id := Defining_Identifier (Comp_Item); 4954 begin 4955 if not Is_Tag (Comp) 4956 and then Chars (Comp) /= Name_uParent 4957 then 4958 Append_Elmt (Comp, Into); 4959 end if; 4960 end; 4961 end if; 4962 4963 Next (Comp_Item); 4964 end loop; 4965 4966 if No (Variant_Part (Comp_List)) then 4967 return; 4968 else 4969 Discrim_Name := Name (Variant_Part (Comp_List)); 4970 Variant := First_Non_Pragma (Variants (Variant_Part (Comp_List))); 4971 end if; 4972 4973 -- Look for the discriminant that governs this variant part. 4974 -- The discriminant *must* be in the Governed_By List 4975 4976 Assoc := First (Governed_By); 4977 Find_Constraint : loop 4978 Discrim := First (Choices (Assoc)); 4979 exit Find_Constraint when Chars (Discrim_Name) = Chars (Discrim) 4980 or else (Present (Corresponding_Discriminant (Entity (Discrim))) 4981 and then 4982 Chars (Corresponding_Discriminant (Entity (Discrim))) 4983 = Chars (Discrim_Name)) 4984 or else Chars (Original_Record_Component (Entity (Discrim))) 4985 = Chars (Discrim_Name); 4986 4987 if No (Next (Assoc)) then 4988 if not Is_Constrained (Typ) 4989 and then Is_Derived_Type (Typ) 4990 and then Present (Stored_Constraint (Typ)) 4991 then 4992 -- If the type is a tagged type with inherited discriminants, 4993 -- use the stored constraint on the parent in order to find 4994 -- the values of discriminants that are otherwise hidden by an 4995 -- explicit constraint. Renamed discriminants are handled in 4996 -- the code above. 4997 4998 -- If several parent discriminants are renamed by a single 4999 -- discriminant of the derived type, the call to obtain the 5000 -- Corresponding_Discriminant field only retrieves the last 5001 -- of them. We recover the constraint on the others from the 5002 -- Stored_Constraint as well. 5003 5004 declare 5005 D : Entity_Id; 5006 C : Elmt_Id; 5007 5008 begin 5009 D := First_Discriminant (Etype (Typ)); 5010 C := First_Elmt (Stored_Constraint (Typ)); 5011 while Present (D) and then Present (C) loop 5012 if Chars (Discrim_Name) = Chars (D) then 5013 if Is_Entity_Name (Node (C)) 5014 and then Entity (Node (C)) = Entity (Discrim) 5015 then 5016 -- D is renamed by Discrim, whose value is given in 5017 -- Assoc. 5018 5019 null; 5020 5021 else 5022 Assoc := 5023 Make_Component_Association (Sloc (Typ), 5024 New_List 5025 (New_Occurrence_Of (D, Sloc (Typ))), 5026 Duplicate_Subexpr_No_Checks (Node (C))); 5027 end if; 5028 exit Find_Constraint; 5029 end if; 5030 5031 Next_Discriminant (D); 5032 Next_Elmt (C); 5033 end loop; 5034 end; 5035 end if; 5036 end if; 5037 5038 if No (Next (Assoc)) then 5039 Error_Msg_NE (" missing value for discriminant&", 5040 First (Governed_By), Discrim_Name); 5041 Report_Errors := True; 5042 return; 5043 end if; 5044 5045 Next (Assoc); 5046 end loop Find_Constraint; 5047 5048 Discrim_Value := Expression (Assoc); 5049 5050 if not Is_OK_Static_Expression (Discrim_Value) then 5051 Error_Msg_FE 5052 ("value for discriminant & must be static!", 5053 Discrim_Value, Discrim); 5054 Why_Not_Static (Discrim_Value); 5055 Report_Errors := True; 5056 return; 5057 end if; 5058 5059 Search_For_Discriminant_Value : declare 5060 Low : Node_Id; 5061 High : Node_Id; 5062 5063 UI_High : Uint; 5064 UI_Low : Uint; 5065 UI_Discrim_Value : constant Uint := Expr_Value (Discrim_Value); 5066 5067 begin 5068 Find_Discrete_Value : while Present (Variant) loop 5069 Discrete_Choice := First (Discrete_Choices (Variant)); 5070 while Present (Discrete_Choice) loop 5071 5072 exit Find_Discrete_Value when 5073 Nkind (Discrete_Choice) = N_Others_Choice; 5074 5075 Get_Index_Bounds (Discrete_Choice, Low, High); 5076 5077 UI_Low := Expr_Value (Low); 5078 UI_High := Expr_Value (High); 5079 5080 exit Find_Discrete_Value when 5081 UI_Low <= UI_Discrim_Value 5082 and then 5083 UI_High >= UI_Discrim_Value; 5084 5085 Next (Discrete_Choice); 5086 end loop; 5087 5088 Next_Non_Pragma (Variant); 5089 end loop Find_Discrete_Value; 5090 end Search_For_Discriminant_Value; 5091 5092 if No (Variant) then 5093 Error_Msg_NE 5094 ("value of discriminant & is out of range", Discrim_Value, Discrim); 5095 Report_Errors := True; 5096 return; 5097 end if; 5098 5099 -- If we have found the corresponding choice, recursively add its 5100 -- components to the Into list. 5101 5102 Gather_Components (Empty, 5103 Component_List (Variant), Governed_By, Into, Report_Errors); 5104 end Gather_Components; 5105 5106 ------------------------ 5107 -- Get_Actual_Subtype -- 5108 ------------------------ 5109 5110 function Get_Actual_Subtype (N : Node_Id) return Entity_Id is 5111 Typ : constant Entity_Id := Etype (N); 5112 Utyp : Entity_Id := Underlying_Type (Typ); 5113 Decl : Node_Id; 5114 Atyp : Entity_Id; 5115 5116 begin 5117 if No (Utyp) then 5118 Utyp := Typ; 5119 end if; 5120 5121 -- If what we have is an identifier that references a subprogram 5122 -- formal, or a variable or constant object, then we get the actual 5123 -- subtype from the referenced entity if one has been built. 5124 5125 if Nkind (N) = N_Identifier 5126 and then 5127 (Is_Formal (Entity (N)) 5128 or else Ekind (Entity (N)) = E_Constant 5129 or else Ekind (Entity (N)) = E_Variable) 5130 and then Present (Actual_Subtype (Entity (N))) 5131 then 5132 return Actual_Subtype (Entity (N)); 5133 5134 -- Actual subtype of unchecked union is always itself. We never need 5135 -- the "real" actual subtype. If we did, we couldn't get it anyway 5136 -- because the discriminant is not available. The restrictions on 5137 -- Unchecked_Union are designed to make sure that this is OK. 5138 5139 elsif Is_Unchecked_Union (Base_Type (Utyp)) then 5140 return Typ; 5141 5142 -- Here for the unconstrained case, we must find actual subtype 5143 -- No actual subtype is available, so we must build it on the fly. 5144 5145 -- Checking the type, not the underlying type, for constrainedness 5146 -- seems to be necessary. Maybe all the tests should be on the type??? 5147 5148 elsif (not Is_Constrained (Typ)) 5149 and then (Is_Array_Type (Utyp) 5150 or else (Is_Record_Type (Utyp) 5151 and then Has_Discriminants (Utyp))) 5152 and then not Has_Unknown_Discriminants (Utyp) 5153 and then not (Ekind (Utyp) = E_String_Literal_Subtype) 5154 then 5155 -- Nothing to do if in spec expression (why not???) 5156 5157 if In_Spec_Expression then 5158 return Typ; 5159 5160 elsif Is_Private_Type (Typ) 5161 and then not Has_Discriminants (Typ) 5162 then 5163 -- If the type has no discriminants, there is no subtype to 5164 -- build, even if the underlying type is discriminated. 5165 5166 return Typ; 5167 5168 -- Else build the actual subtype 5169 5170 else 5171 Decl := Build_Actual_Subtype (Typ, N); 5172 Atyp := Defining_Identifier (Decl); 5173 5174 -- If Build_Actual_Subtype generated a new declaration then use it 5175 5176 if Atyp /= Typ then 5177 5178 -- The actual subtype is an Itype, so analyze the declaration, 5179 -- but do not attach it to the tree, to get the type defined. 5180 5181 Set_Parent (Decl, N); 5182 Set_Is_Itype (Atyp); 5183 Analyze (Decl, Suppress => All_Checks); 5184 Set_Associated_Node_For_Itype (Atyp, N); 5185 Set_Has_Delayed_Freeze (Atyp, False); 5186 5187 -- We need to freeze the actual subtype immediately. This is 5188 -- needed, because otherwise this Itype will not get frozen 5189 -- at all, and it is always safe to freeze on creation because 5190 -- any associated types must be frozen at this point. 5191 5192 Freeze_Itype (Atyp, N); 5193 return Atyp; 5194 5195 -- Otherwise we did not build a declaration, so return original 5196 5197 else 5198 return Typ; 5199 end if; 5200 end if; 5201 5202 -- For all remaining cases, the actual subtype is the same as 5203 -- the nominal type. 5204 5205 else 5206 return Typ; 5207 end if; 5208 end Get_Actual_Subtype; 5209 5210 ------------------------------------- 5211 -- Get_Actual_Subtype_If_Available -- 5212 ------------------------------------- 5213 5214 function Get_Actual_Subtype_If_Available (N : Node_Id) return Entity_Id is 5215 Typ : constant Entity_Id := Etype (N); 5216 5217 begin 5218 -- If what we have is an identifier that references a subprogram 5219 -- formal, or a variable or constant object, then we get the actual 5220 -- subtype from the referenced entity if one has been built. 5221 5222 if Nkind (N) = N_Identifier 5223 and then 5224 (Is_Formal (Entity (N)) 5225 or else Ekind (Entity (N)) = E_Constant 5226 or else Ekind (Entity (N)) = E_Variable) 5227 and then Present (Actual_Subtype (Entity (N))) 5228 then 5229 return Actual_Subtype (Entity (N)); 5230 5231 -- Otherwise the Etype of N is returned unchanged 5232 5233 else 5234 return Typ; 5235 end if; 5236 end Get_Actual_Subtype_If_Available; 5237 5238 ------------------------ 5239 -- Get_Body_From_Stub -- 5240 ------------------------ 5241 5242 function Get_Body_From_Stub (N : Node_Id) return Node_Id is 5243 begin 5244 return Proper_Body (Unit (Library_Unit (N))); 5245 end Get_Body_From_Stub; 5246 5247 ------------------------------- 5248 -- Get_Default_External_Name -- 5249 ------------------------------- 5250 5251 function Get_Default_External_Name (E : Node_Or_Entity_Id) return Node_Id is 5252 begin 5253 Get_Decoded_Name_String (Chars (E)); 5254 5255 if Opt.External_Name_Imp_Casing = Uppercase then 5256 Set_Casing (All_Upper_Case); 5257 else 5258 Set_Casing (All_Lower_Case); 5259 end if; 5260 5261 return 5262 Make_String_Literal (Sloc (E), 5263 Strval => String_From_Name_Buffer); 5264 end Get_Default_External_Name; 5265 5266 -------------------------- 5267 -- Get_Enclosing_Object -- 5268 -------------------------- 5269 5270 function Get_Enclosing_Object (N : Node_Id) return Entity_Id is 5271 begin 5272 if Is_Entity_Name (N) then 5273 return Entity (N); 5274 else 5275 case Nkind (N) is 5276 when N_Indexed_Component | 5277 N_Slice | 5278 N_Selected_Component => 5279 5280 -- If not generating code, a dereference may be left implicit. 5281 -- In thoses cases, return Empty. 5282 5283 if Is_Access_Type (Etype (Prefix (N))) then 5284 return Empty; 5285 else 5286 return Get_Enclosing_Object (Prefix (N)); 5287 end if; 5288 5289 when N_Type_Conversion => 5290 return Get_Enclosing_Object (Expression (N)); 5291 5292 when others => 5293 return Empty; 5294 end case; 5295 end if; 5296 end Get_Enclosing_Object; 5297 5298 --------------------------- 5299 -- Get_Enum_Lit_From_Pos -- 5300 --------------------------- 5301 5302 function Get_Enum_Lit_From_Pos 5303 (T : Entity_Id; 5304 Pos : Uint; 5305 Loc : Source_Ptr) return Node_Id 5306 is 5307 Btyp : Entity_Id := Base_Type (T); 5308 Lit : Node_Id; 5309 5310 begin 5311 -- In the case where the literal is of type Character, Wide_Character 5312 -- or Wide_Wide_Character or of a type derived from them, there needs 5313 -- to be some special handling since there is no explicit chain of 5314 -- literals to search. Instead, an N_Character_Literal node is created 5315 -- with the appropriate Char_Code and Chars fields. 5316 5317 if Is_Standard_Character_Type (T) then 5318 Set_Character_Literal_Name (UI_To_CC (Pos)); 5319 return 5320 Make_Character_Literal (Loc, 5321 Chars => Name_Find, 5322 Char_Literal_Value => Pos); 5323 5324 -- For all other cases, we have a complete table of literals, and 5325 -- we simply iterate through the chain of literal until the one 5326 -- with the desired position value is found. 5327 -- 5328 5329 else 5330 if Is_Private_Type (Btyp) and then Present (Full_View (Btyp)) then 5331 Btyp := Full_View (Btyp); 5332 end if; 5333 5334 Lit := First_Literal (Btyp); 5335 for J in 1 .. UI_To_Int (Pos) loop 5336 Next_Literal (Lit); 5337 end loop; 5338 5339 return New_Occurrence_Of (Lit, Loc); 5340 end if; 5341 end Get_Enum_Lit_From_Pos; 5342 5343 --------------------------------- 5344 -- Get_Ensures_From_CTC_Pragma -- 5345 --------------------------------- 5346 5347 function Get_Ensures_From_CTC_Pragma (N : Node_Id) return Node_Id is 5348 Args : constant List_Id := Pragma_Argument_Associations (N); 5349 Res : Node_Id; 5350 5351 begin 5352 if List_Length (Args) = 4 then 5353 Res := Pick (Args, 4); 5354 5355 elsif List_Length (Args) = 3 then 5356 Res := Pick (Args, 3); 5357 5358 if Chars (Res) /= Name_Ensures then 5359 Res := Empty; 5360 end if; 5361 5362 else 5363 Res := Empty; 5364 end if; 5365 5366 return Res; 5367 end Get_Ensures_From_CTC_Pragma; 5368 5369 ------------------------ 5370 -- Get_Generic_Entity -- 5371 ------------------------ 5372 5373 function Get_Generic_Entity (N : Node_Id) return Entity_Id is 5374 Ent : constant Entity_Id := Entity (Name (N)); 5375 begin 5376 if Present (Renamed_Object (Ent)) then 5377 return Renamed_Object (Ent); 5378 else 5379 return Ent; 5380 end if; 5381 end Get_Generic_Entity; 5382 5383 ---------------------- 5384 -- Get_Index_Bounds -- 5385 ---------------------- 5386 5387 procedure Get_Index_Bounds (N : Node_Id; L, H : out Node_Id) is 5388 Kind : constant Node_Kind := Nkind (N); 5389 R : Node_Id; 5390 5391 begin 5392 if Kind = N_Range then 5393 L := Low_Bound (N); 5394 H := High_Bound (N); 5395 5396 elsif Kind = N_Subtype_Indication then 5397 R := Range_Expression (Constraint (N)); 5398 5399 if R = Error then 5400 L := Error; 5401 H := Error; 5402 return; 5403 5404 else 5405 L := Low_Bound (Range_Expression (Constraint (N))); 5406 H := High_Bound (Range_Expression (Constraint (N))); 5407 end if; 5408 5409 elsif Is_Entity_Name (N) and then Is_Type (Entity (N)) then 5410 if Error_Posted (Scalar_Range (Entity (N))) then 5411 L := Error; 5412 H := Error; 5413 5414 elsif Nkind (Scalar_Range (Entity (N))) = N_Subtype_Indication then 5415 Get_Index_Bounds (Scalar_Range (Entity (N)), L, H); 5416 5417 else 5418 L := Low_Bound (Scalar_Range (Entity (N))); 5419 H := High_Bound (Scalar_Range (Entity (N))); 5420 end if; 5421 5422 else 5423 -- N is an expression, indicating a range with one value 5424 5425 L := N; 5426 H := N; 5427 end if; 5428 end Get_Index_Bounds; 5429 5430 ---------------------------------- 5431 -- Get_Library_Unit_Name_string -- 5432 ---------------------------------- 5433 5434 procedure Get_Library_Unit_Name_String (Decl_Node : Node_Id) is 5435 Unit_Name_Id : constant Unit_Name_Type := Get_Unit_Name (Decl_Node); 5436 5437 begin 5438 Get_Unit_Name_String (Unit_Name_Id); 5439 5440 -- Remove seven last character (" (spec)" or " (body)") 5441 5442 Name_Len := Name_Len - 7; 5443 pragma Assert (Name_Buffer (Name_Len + 1) = ' '); 5444 end Get_Library_Unit_Name_String; 5445 5446 ------------------------ 5447 -- Get_Name_Entity_Id -- 5448 ------------------------ 5449 5450 function Get_Name_Entity_Id (Id : Name_Id) return Entity_Id is 5451 begin 5452 return Entity_Id (Get_Name_Table_Info (Id)); 5453 end Get_Name_Entity_Id; 5454 5455 ------------------------------ 5456 -- Get_Name_From_CTC_Pragma -- 5457 ------------------------------ 5458 5459 function Get_Name_From_CTC_Pragma (N : Node_Id) return String_Id is 5460 Arg : constant Node_Id := 5461 Get_Pragma_Arg (First (Pragma_Argument_Associations (N))); 5462 begin 5463 return Strval (Expr_Value_S (Arg)); 5464 end Get_Name_From_CTC_Pragma; 5465 5466 ------------------- 5467 -- Get_Pragma_Id -- 5468 ------------------- 5469 5470 function Get_Pragma_Id (N : Node_Id) return Pragma_Id is 5471 begin 5472 return Get_Pragma_Id (Pragma_Name (N)); 5473 end Get_Pragma_Id; 5474 5475 --------------------------- 5476 -- Get_Referenced_Object -- 5477 --------------------------- 5478 5479 function Get_Referenced_Object (N : Node_Id) return Node_Id is 5480 R : Node_Id; 5481 5482 begin 5483 R := N; 5484 while Is_Entity_Name (R) 5485 and then Present (Renamed_Object (Entity (R))) 5486 loop 5487 R := Renamed_Object (Entity (R)); 5488 end loop; 5489 5490 return R; 5491 end Get_Referenced_Object; 5492 5493 ------------------------ 5494 -- Get_Renamed_Entity -- 5495 ------------------------ 5496 5497 function Get_Renamed_Entity (E : Entity_Id) return Entity_Id is 5498 R : Entity_Id; 5499 5500 begin 5501 R := E; 5502 while Present (Renamed_Entity (R)) loop 5503 R := Renamed_Entity (R); 5504 end loop; 5505 5506 return R; 5507 end Get_Renamed_Entity; 5508 5509 ---------------------------------- 5510 -- Get_Requires_From_CTC_Pragma -- 5511 ---------------------------------- 5512 5513 function Get_Requires_From_CTC_Pragma (N : Node_Id) return Node_Id is 5514 Args : constant List_Id := Pragma_Argument_Associations (N); 5515 Res : Node_Id; 5516 5517 begin 5518 if List_Length (Args) >= 3 then 5519 Res := Pick (Args, 3); 5520 5521 if Chars (Res) /= Name_Requires then 5522 Res := Empty; 5523 end if; 5524 5525 else 5526 Res := Empty; 5527 end if; 5528 5529 return Res; 5530 end Get_Requires_From_CTC_Pragma; 5531 5532 ------------------------- 5533 -- Get_Subprogram_Body -- 5534 ------------------------- 5535 5536 function Get_Subprogram_Body (E : Entity_Id) return Node_Id is 5537 Decl : Node_Id; 5538 5539 begin 5540 Decl := Unit_Declaration_Node (E); 5541 5542 if Nkind (Decl) = N_Subprogram_Body then 5543 return Decl; 5544 5545 -- The below comment is bad, because it is possible for 5546 -- Nkind (Decl) to be an N_Subprogram_Body_Stub ??? 5547 5548 else -- Nkind (Decl) = N_Subprogram_Declaration 5549 5550 if Present (Corresponding_Body (Decl)) then 5551 return Unit_Declaration_Node (Corresponding_Body (Decl)); 5552 5553 -- Imported subprogram case 5554 5555 else 5556 return Empty; 5557 end if; 5558 end if; 5559 end Get_Subprogram_Body; 5560 5561 --------------------------- 5562 -- Get_Subprogram_Entity -- 5563 --------------------------- 5564 5565 function Get_Subprogram_Entity (Nod : Node_Id) return Entity_Id is 5566 Nam : Node_Id; 5567 Proc : Entity_Id; 5568 5569 begin 5570 if Nkind (Nod) = N_Accept_Statement then 5571 Nam := Entry_Direct_Name (Nod); 5572 5573 -- For an entry call, the prefix of the call is a selected component. 5574 -- Need additional code for internal calls ??? 5575 5576 elsif Nkind (Nod) = N_Entry_Call_Statement then 5577 if Nkind (Name (Nod)) = N_Selected_Component then 5578 Nam := Entity (Selector_Name (Name (Nod))); 5579 else 5580 Nam := Empty; 5581 end if; 5582 5583 else 5584 Nam := Name (Nod); 5585 end if; 5586 5587 if Nkind (Nam) = N_Explicit_Dereference then 5588 Proc := Etype (Prefix (Nam)); 5589 elsif Is_Entity_Name (Nam) then 5590 Proc := Entity (Nam); 5591 else 5592 return Empty; 5593 end if; 5594 5595 if Is_Object (Proc) then 5596 Proc := Etype (Proc); 5597 end if; 5598 5599 if Ekind (Proc) = E_Access_Subprogram_Type then 5600 Proc := Directly_Designated_Type (Proc); 5601 end if; 5602 5603 if not Is_Subprogram (Proc) 5604 and then Ekind (Proc) /= E_Subprogram_Type 5605 then 5606 return Empty; 5607 else 5608 return Proc; 5609 end if; 5610 end Get_Subprogram_Entity; 5611 5612 ----------------------------- 5613 -- Get_Task_Body_Procedure -- 5614 ----------------------------- 5615 5616 function Get_Task_Body_Procedure (E : Entity_Id) return Node_Id is 5617 begin 5618 -- Note: A task type may be the completion of a private type with 5619 -- discriminants. When performing elaboration checks on a task 5620 -- declaration, the current view of the type may be the private one, 5621 -- and the procedure that holds the body of the task is held in its 5622 -- underlying type. 5623 5624 -- This is an odd function, why not have Task_Body_Procedure do 5625 -- the following digging??? 5626 5627 return Task_Body_Procedure (Underlying_Type (Root_Type (E))); 5628 end Get_Task_Body_Procedure; 5629 5630 ----------------------- 5631 -- Has_Access_Values -- 5632 ----------------------- 5633 5634 function Has_Access_Values (T : Entity_Id) return Boolean is 5635 Typ : constant Entity_Id := Underlying_Type (T); 5636 5637 begin 5638 -- Case of a private type which is not completed yet. This can only 5639 -- happen in the case of a generic format type appearing directly, or 5640 -- as a component of the type to which this function is being applied 5641 -- at the top level. Return False in this case, since we certainly do 5642 -- not know that the type contains access types. 5643 5644 if No (Typ) then 5645 return False; 5646 5647 elsif Is_Access_Type (Typ) then 5648 return True; 5649 5650 elsif Is_Array_Type (Typ) then 5651 return Has_Access_Values (Component_Type (Typ)); 5652 5653 elsif Is_Record_Type (Typ) then 5654 declare 5655 Comp : Entity_Id; 5656 5657 begin 5658 -- Loop to Check components 5659 5660 Comp := First_Component_Or_Discriminant (Typ); 5661 while Present (Comp) loop 5662 5663 -- Check for access component, tag field does not count, even 5664 -- though it is implemented internally using an access type. 5665 5666 if Has_Access_Values (Etype (Comp)) 5667 and then Chars (Comp) /= Name_uTag 5668 then 5669 return True; 5670 end if; 5671 5672 Next_Component_Or_Discriminant (Comp); 5673 end loop; 5674 end; 5675 5676 return False; 5677 5678 else 5679 return False; 5680 end if; 5681 end Has_Access_Values; 5682 5683 ------------------------------ 5684 -- Has_Compatible_Alignment -- 5685 ------------------------------ 5686 5687 function Has_Compatible_Alignment 5688 (Obj : Entity_Id; 5689 Expr : Node_Id) return Alignment_Result 5690 is 5691 function Has_Compatible_Alignment_Internal 5692 (Obj : Entity_Id; 5693 Expr : Node_Id; 5694 Default : Alignment_Result) return Alignment_Result; 5695 -- This is the internal recursive function that actually does the work. 5696 -- There is one additional parameter, which says what the result should 5697 -- be if no alignment information is found, and there is no definite 5698 -- indication of compatible alignments. At the outer level, this is set 5699 -- to Unknown, but for internal recursive calls in the case where types 5700 -- are known to be correct, it is set to Known_Compatible. 5701 5702 --------------------------------------- 5703 -- Has_Compatible_Alignment_Internal -- 5704 --------------------------------------- 5705 5706 function Has_Compatible_Alignment_Internal 5707 (Obj : Entity_Id; 5708 Expr : Node_Id; 5709 Default : Alignment_Result) return Alignment_Result 5710 is 5711 Result : Alignment_Result := Known_Compatible; 5712 -- Holds the current status of the result. Note that once a value of 5713 -- Known_Incompatible is set, it is sticky and does not get changed 5714 -- to Unknown (the value in Result only gets worse as we go along, 5715 -- never better). 5716 5717 Offs : Uint := No_Uint; 5718 -- Set to a factor of the offset from the base object when Expr is a 5719 -- selected or indexed component, based on Component_Bit_Offset and 5720 -- Component_Size respectively. A negative value is used to represent 5721 -- a value which is not known at compile time. 5722 5723 procedure Check_Prefix; 5724 -- Checks the prefix recursively in the case where the expression 5725 -- is an indexed or selected component. 5726 5727 procedure Set_Result (R : Alignment_Result); 5728 -- If R represents a worse outcome (unknown instead of known 5729 -- compatible, or known incompatible), then set Result to R. 5730 5731 ------------------ 5732 -- Check_Prefix -- 5733 ------------------ 5734 5735 procedure Check_Prefix is 5736 begin 5737 -- The subtlety here is that in doing a recursive call to check 5738 -- the prefix, we have to decide what to do in the case where we 5739 -- don't find any specific indication of an alignment problem. 5740 5741 -- At the outer level, we normally set Unknown as the result in 5742 -- this case, since we can only set Known_Compatible if we really 5743 -- know that the alignment value is OK, but for the recursive 5744 -- call, in the case where the types match, and we have not 5745 -- specified a peculiar alignment for the object, we are only 5746 -- concerned about suspicious rep clauses, the default case does 5747 -- not affect us, since the compiler will, in the absence of such 5748 -- rep clauses, ensure that the alignment is correct. 5749 5750 if Default = Known_Compatible 5751 or else 5752 (Etype (Obj) = Etype (Expr) 5753 and then (Unknown_Alignment (Obj) 5754 or else 5755 Alignment (Obj) = Alignment (Etype (Obj)))) 5756 then 5757 Set_Result 5758 (Has_Compatible_Alignment_Internal 5759 (Obj, Prefix (Expr), Known_Compatible)); 5760 5761 -- In all other cases, we need a full check on the prefix 5762 5763 else 5764 Set_Result 5765 (Has_Compatible_Alignment_Internal 5766 (Obj, Prefix (Expr), Unknown)); 5767 end if; 5768 end Check_Prefix; 5769 5770 ---------------- 5771 -- Set_Result -- 5772 ---------------- 5773 5774 procedure Set_Result (R : Alignment_Result) is 5775 begin 5776 if R > Result then 5777 Result := R; 5778 end if; 5779 end Set_Result; 5780 5781 -- Start of processing for Has_Compatible_Alignment_Internal 5782 5783 begin 5784 -- If Expr is a selected component, we must make sure there is no 5785 -- potentially troublesome component clause, and that the record is 5786 -- not packed. 5787 5788 if Nkind (Expr) = N_Selected_Component then 5789 5790 -- Packed record always generate unknown alignment 5791 5792 if Is_Packed (Etype (Prefix (Expr))) then 5793 Set_Result (Unknown); 5794 end if; 5795 5796 -- Check prefix and component offset 5797 5798 Check_Prefix; 5799 Offs := Component_Bit_Offset (Entity (Selector_Name (Expr))); 5800 5801 -- If Expr is an indexed component, we must make sure there is no 5802 -- potentially troublesome Component_Size clause and that the array 5803 -- is not bit-packed. 5804 5805 elsif Nkind (Expr) = N_Indexed_Component then 5806 declare 5807 Typ : constant Entity_Id := Etype (Prefix (Expr)); 5808 Ind : constant Node_Id := First_Index (Typ); 5809 5810 begin 5811 -- Bit packed array always generates unknown alignment 5812 5813 if Is_Bit_Packed_Array (Typ) then 5814 Set_Result (Unknown); 5815 end if; 5816 5817 -- Check prefix and component offset 5818 5819 Check_Prefix; 5820 Offs := Component_Size (Typ); 5821 5822 -- Small optimization: compute the full offset when possible 5823 5824 if Offs /= No_Uint 5825 and then Offs > Uint_0 5826 and then Present (Ind) 5827 and then Nkind (Ind) = N_Range 5828 and then Compile_Time_Known_Value (Low_Bound (Ind)) 5829 and then Compile_Time_Known_Value (First (Expressions (Expr))) 5830 then 5831 Offs := Offs * (Expr_Value (First (Expressions (Expr))) 5832 - Expr_Value (Low_Bound ((Ind)))); 5833 end if; 5834 end; 5835 end if; 5836 5837 -- If we have a null offset, the result is entirely determined by 5838 -- the base object and has already been computed recursively. 5839 5840 if Offs = Uint_0 then 5841 null; 5842 5843 -- Case where we know the alignment of the object 5844 5845 elsif Known_Alignment (Obj) then 5846 declare 5847 ObjA : constant Uint := Alignment (Obj); 5848 ExpA : Uint := No_Uint; 5849 SizA : Uint := No_Uint; 5850 5851 begin 5852 -- If alignment of Obj is 1, then we are always OK 5853 5854 if ObjA = 1 then 5855 Set_Result (Known_Compatible); 5856 5857 -- Alignment of Obj is greater than 1, so we need to check 5858 5859 else 5860 -- If we have an offset, see if it is compatible 5861 5862 if Offs /= No_Uint and Offs > Uint_0 then 5863 if Offs mod (System_Storage_Unit * ObjA) /= 0 then 5864 Set_Result (Known_Incompatible); 5865 end if; 5866 5867 -- See if Expr is an object with known alignment 5868 5869 elsif Is_Entity_Name (Expr) 5870 and then Known_Alignment (Entity (Expr)) 5871 then 5872 ExpA := Alignment (Entity (Expr)); 5873 5874 -- Otherwise, we can use the alignment of the type of 5875 -- Expr given that we already checked for 5876 -- discombobulating rep clauses for the cases of indexed 5877 -- and selected components above. 5878 5879 elsif Known_Alignment (Etype (Expr)) then 5880 ExpA := Alignment (Etype (Expr)); 5881 5882 -- Otherwise the alignment is unknown 5883 5884 else 5885 Set_Result (Default); 5886 end if; 5887 5888 -- If we got an alignment, see if it is acceptable 5889 5890 if ExpA /= No_Uint and then ExpA < ObjA then 5891 Set_Result (Known_Incompatible); 5892 end if; 5893 5894 -- If Expr is not a piece of a larger object, see if size 5895 -- is given. If so, check that it is not too small for the 5896 -- required alignment. 5897 5898 if Offs /= No_Uint then 5899 null; 5900 5901 -- See if Expr is an object with known size 5902 5903 elsif Is_Entity_Name (Expr) 5904 and then Known_Static_Esize (Entity (Expr)) 5905 then 5906 SizA := Esize (Entity (Expr)); 5907 5908 -- Otherwise, we check the object size of the Expr type 5909 5910 elsif Known_Static_Esize (Etype (Expr)) then 5911 SizA := Esize (Etype (Expr)); 5912 end if; 5913 5914 -- If we got a size, see if it is a multiple of the Obj 5915 -- alignment, if not, then the alignment cannot be 5916 -- acceptable, since the size is always a multiple of the 5917 -- alignment. 5918 5919 if SizA /= No_Uint then 5920 if SizA mod (ObjA * Ttypes.System_Storage_Unit) /= 0 then 5921 Set_Result (Known_Incompatible); 5922 end if; 5923 end if; 5924 end if; 5925 end; 5926 5927 -- If we do not know required alignment, any non-zero offset is a 5928 -- potential problem (but certainly may be OK, so result is unknown). 5929 5930 elsif Offs /= No_Uint then 5931 Set_Result (Unknown); 5932 5933 -- If we can't find the result by direct comparison of alignment 5934 -- values, then there is still one case that we can determine known 5935 -- result, and that is when we can determine that the types are the 5936 -- same, and no alignments are specified. Then we known that the 5937 -- alignments are compatible, even if we don't know the alignment 5938 -- value in the front end. 5939 5940 elsif Etype (Obj) = Etype (Expr) then 5941 5942 -- Types are the same, but we have to check for possible size 5943 -- and alignments on the Expr object that may make the alignment 5944 -- different, even though the types are the same. 5945 5946 if Is_Entity_Name (Expr) then 5947 5948 -- First check alignment of the Expr object. Any alignment less 5949 -- than Maximum_Alignment is worrisome since this is the case 5950 -- where we do not know the alignment of Obj. 5951 5952 if Known_Alignment (Entity (Expr)) 5953 and then 5954 UI_To_Int (Alignment (Entity (Expr))) < 5955 Ttypes.Maximum_Alignment 5956 then 5957 Set_Result (Unknown); 5958 5959 -- Now check size of Expr object. Any size that is not an 5960 -- even multiple of Maximum_Alignment is also worrisome 5961 -- since it may cause the alignment of the object to be less 5962 -- than the alignment of the type. 5963 5964 elsif Known_Static_Esize (Entity (Expr)) 5965 and then 5966 (UI_To_Int (Esize (Entity (Expr))) mod 5967 (Ttypes.Maximum_Alignment * Ttypes.System_Storage_Unit)) 5968 /= 0 5969 then 5970 Set_Result (Unknown); 5971 5972 -- Otherwise same type is decisive 5973 5974 else 5975 Set_Result (Known_Compatible); 5976 end if; 5977 end if; 5978 5979 -- Another case to deal with is when there is an explicit size or 5980 -- alignment clause when the types are not the same. If so, then the 5981 -- result is Unknown. We don't need to do this test if the Default is 5982 -- Unknown, since that result will be set in any case. 5983 5984 elsif Default /= Unknown 5985 and then (Has_Size_Clause (Etype (Expr)) 5986 or else 5987 Has_Alignment_Clause (Etype (Expr))) 5988 then 5989 Set_Result (Unknown); 5990 5991 -- If no indication found, set default 5992 5993 else 5994 Set_Result (Default); 5995 end if; 5996 5997 -- Return worst result found 5998 5999 return Result; 6000 end Has_Compatible_Alignment_Internal; 6001 6002 -- Start of processing for Has_Compatible_Alignment 6003 6004 begin 6005 -- If Obj has no specified alignment, then set alignment from the type 6006 -- alignment. Perhaps we should always do this, but for sure we should 6007 -- do it when there is an address clause since we can do more if the 6008 -- alignment is known. 6009 6010 if Unknown_Alignment (Obj) then 6011 Set_Alignment (Obj, Alignment (Etype (Obj))); 6012 end if; 6013 6014 -- Now do the internal call that does all the work 6015 6016 return Has_Compatible_Alignment_Internal (Obj, Expr, Unknown); 6017 end Has_Compatible_Alignment; 6018 6019 ---------------------- 6020 -- Has_Declarations -- 6021 ---------------------- 6022 6023 function Has_Declarations (N : Node_Id) return Boolean is 6024 begin 6025 return Nkind_In (Nkind (N), N_Accept_Statement, 6026 N_Block_Statement, 6027 N_Compilation_Unit_Aux, 6028 N_Entry_Body, 6029 N_Package_Body, 6030 N_Protected_Body, 6031 N_Subprogram_Body, 6032 N_Task_Body, 6033 N_Package_Specification); 6034 end Has_Declarations; 6035 6036 ------------------- 6037 -- Has_Denormals -- 6038 ------------------- 6039 6040 function Has_Denormals (E : Entity_Id) return Boolean is 6041 begin 6042 return Is_Floating_Point_Type (E) 6043 and then Denorm_On_Target 6044 and then not Vax_Float (E); 6045 end Has_Denormals; 6046 6047 ------------------------------------------- 6048 -- Has_Discriminant_Dependent_Constraint -- 6049 ------------------------------------------- 6050 6051 function Has_Discriminant_Dependent_Constraint 6052 (Comp : Entity_Id) return Boolean 6053 is 6054 Comp_Decl : constant Node_Id := Parent (Comp); 6055 Subt_Indic : constant Node_Id := 6056 Subtype_Indication (Component_Definition (Comp_Decl)); 6057 Constr : Node_Id; 6058 Assn : Node_Id; 6059 6060 begin 6061 if Nkind (Subt_Indic) = N_Subtype_Indication then 6062 Constr := Constraint (Subt_Indic); 6063 6064 if Nkind (Constr) = N_Index_Or_Discriminant_Constraint then 6065 Assn := First (Constraints (Constr)); 6066 while Present (Assn) loop 6067 case Nkind (Assn) is 6068 when N_Subtype_Indication | 6069 N_Range | 6070 N_Identifier 6071 => 6072 if Depends_On_Discriminant (Assn) then 6073 return True; 6074 end if; 6075 6076 when N_Discriminant_Association => 6077 if Depends_On_Discriminant (Expression (Assn)) then 6078 return True; 6079 end if; 6080 6081 when others => 6082 null; 6083 6084 end case; 6085 6086 Next (Assn); 6087 end loop; 6088 end if; 6089 end if; 6090 6091 return False; 6092 end Has_Discriminant_Dependent_Constraint; 6093 6094 -------------------- 6095 -- Has_Infinities -- 6096 -------------------- 6097 6098 function Has_Infinities (E : Entity_Id) return Boolean is 6099 begin 6100 return 6101 Is_Floating_Point_Type (E) 6102 and then Nkind (Scalar_Range (E)) = N_Range 6103 and then Includes_Infinities (Scalar_Range (E)); 6104 end Has_Infinities; 6105 6106 -------------------- 6107 -- Has_Interfaces -- 6108 -------------------- 6109 6110 function Has_Interfaces 6111 (T : Entity_Id; 6112 Use_Full_View : Boolean := True) return Boolean 6113 is 6114 Typ : Entity_Id := Base_Type (T); 6115 6116 begin 6117 -- Handle concurrent types 6118 6119 if Is_Concurrent_Type (Typ) then 6120 Typ := Corresponding_Record_Type (Typ); 6121 end if; 6122 6123 if not Present (Typ) 6124 or else not Is_Record_Type (Typ) 6125 or else not Is_Tagged_Type (Typ) 6126 then 6127 return False; 6128 end if; 6129 6130 -- Handle private types 6131 6132 if Use_Full_View 6133 and then Present (Full_View (Typ)) 6134 then 6135 Typ := Full_View (Typ); 6136 end if; 6137 6138 -- Handle concurrent record types 6139 6140 if Is_Concurrent_Record_Type (Typ) 6141 and then Is_Non_Empty_List (Abstract_Interface_List (Typ)) 6142 then 6143 return True; 6144 end if; 6145 6146 loop 6147 if Is_Interface (Typ) 6148 or else 6149 (Is_Record_Type (Typ) 6150 and then Present (Interfaces (Typ)) 6151 and then not Is_Empty_Elmt_List (Interfaces (Typ))) 6152 then 6153 return True; 6154 end if; 6155 6156 exit when Etype (Typ) = Typ 6157 6158 -- Handle private types 6159 6160 or else (Present (Full_View (Etype (Typ))) 6161 and then Full_View (Etype (Typ)) = Typ) 6162 6163 -- Protect the frontend against wrong source with cyclic 6164 -- derivations 6165 6166 or else Etype (Typ) = T; 6167 6168 -- Climb to the ancestor type handling private types 6169 6170 if Present (Full_View (Etype (Typ))) then 6171 Typ := Full_View (Etype (Typ)); 6172 else 6173 Typ := Etype (Typ); 6174 end if; 6175 end loop; 6176 6177 return False; 6178 end Has_Interfaces; 6179 6180 ------------------------ 6181 -- Has_Null_Exclusion -- 6182 ------------------------ 6183 6184 function Has_Null_Exclusion (N : Node_Id) return Boolean is 6185 begin 6186 case Nkind (N) is 6187 when N_Access_Definition | 6188 N_Access_Function_Definition | 6189 N_Access_Procedure_Definition | 6190 N_Access_To_Object_Definition | 6191 N_Allocator | 6192 N_Derived_Type_Definition | 6193 N_Function_Specification | 6194 N_Subtype_Declaration => 6195 return Null_Exclusion_Present (N); 6196 6197 when N_Component_Definition | 6198 N_Formal_Object_Declaration | 6199 N_Object_Renaming_Declaration => 6200 if Present (Subtype_Mark (N)) then 6201 return Null_Exclusion_Present (N); 6202 else pragma Assert (Present (Access_Definition (N))); 6203 return Null_Exclusion_Present (Access_Definition (N)); 6204 end if; 6205 6206 when N_Discriminant_Specification => 6207 if Nkind (Discriminant_Type (N)) = N_Access_Definition then 6208 return Null_Exclusion_Present (Discriminant_Type (N)); 6209 else 6210 return Null_Exclusion_Present (N); 6211 end if; 6212 6213 when N_Object_Declaration => 6214 if Nkind (Object_Definition (N)) = N_Access_Definition then 6215 return Null_Exclusion_Present (Object_Definition (N)); 6216 else 6217 return Null_Exclusion_Present (N); 6218 end if; 6219 6220 when N_Parameter_Specification => 6221 if Nkind (Parameter_Type (N)) = N_Access_Definition then 6222 return Null_Exclusion_Present (Parameter_Type (N)); 6223 else 6224 return Null_Exclusion_Present (N); 6225 end if; 6226 6227 when others => 6228 return False; 6229 6230 end case; 6231 end Has_Null_Exclusion; 6232 6233 ------------------------ 6234 -- Has_Null_Extension -- 6235 ------------------------ 6236 6237 function Has_Null_Extension (T : Entity_Id) return Boolean is 6238 B : constant Entity_Id := Base_Type (T); 6239 Comps : Node_Id; 6240 Ext : Node_Id; 6241 6242 begin 6243 if Nkind (Parent (B)) = N_Full_Type_Declaration 6244 and then Present (Record_Extension_Part (Type_Definition (Parent (B)))) 6245 then 6246 Ext := Record_Extension_Part (Type_Definition (Parent (B))); 6247 6248 if Present (Ext) then 6249 if Null_Present (Ext) then 6250 return True; 6251 else 6252 Comps := Component_List (Ext); 6253 6254 -- The null component list is rewritten during analysis to 6255 -- include the parent component. Any other component indicates 6256 -- that the extension was not originally null. 6257 6258 return Null_Present (Comps) 6259 or else No (Next (First (Component_Items (Comps)))); 6260 end if; 6261 else 6262 return False; 6263 end if; 6264 6265 else 6266 return False; 6267 end if; 6268 end Has_Null_Extension; 6269 6270 ------------------------------- 6271 -- Has_Overriding_Initialize -- 6272 ------------------------------- 6273 6274 function Has_Overriding_Initialize (T : Entity_Id) return Boolean is 6275 BT : constant Entity_Id := Base_Type (T); 6276 P : Elmt_Id; 6277 6278 begin 6279 if Is_Controlled (BT) then 6280 if Is_RTU (Scope (BT), Ada_Finalization) then 6281 return False; 6282 6283 elsif Present (Primitive_Operations (BT)) then 6284 P := First_Elmt (Primitive_Operations (BT)); 6285 while Present (P) loop 6286 declare 6287 Init : constant Entity_Id := Node (P); 6288 Formal : constant Entity_Id := First_Formal (Init); 6289 begin 6290 if Ekind (Init) = E_Procedure 6291 and then Chars (Init) = Name_Initialize 6292 and then Comes_From_Source (Init) 6293 and then Present (Formal) 6294 and then Etype (Formal) = BT 6295 and then No (Next_Formal (Formal)) 6296 and then (Ada_Version < Ada_2012 6297 or else not Null_Present (Parent (Init))) 6298 then 6299 return True; 6300 end if; 6301 end; 6302 6303 Next_Elmt (P); 6304 end loop; 6305 end if; 6306 6307 -- Here if type itself does not have a non-null Initialize operation: 6308 -- check immediate ancestor. 6309 6310 if Is_Derived_Type (BT) 6311 and then Has_Overriding_Initialize (Etype (BT)) 6312 then 6313 return True; 6314 end if; 6315 end if; 6316 6317 return False; 6318 end Has_Overriding_Initialize; 6319 6320 -------------------------------------- 6321 -- Has_Preelaborable_Initialization -- 6322 -------------------------------------- 6323 6324 function Has_Preelaborable_Initialization (E : Entity_Id) return Boolean is 6325 Has_PE : Boolean; 6326 6327 procedure Check_Components (E : Entity_Id); 6328 -- Check component/discriminant chain, sets Has_PE False if a component 6329 -- or discriminant does not meet the preelaborable initialization rules. 6330 6331 ---------------------- 6332 -- Check_Components -- 6333 ---------------------- 6334 6335 procedure Check_Components (E : Entity_Id) is 6336 Ent : Entity_Id; 6337 Exp : Node_Id; 6338 6339 function Is_Preelaborable_Expression (N : Node_Id) return Boolean; 6340 -- Returns True if and only if the expression denoted by N does not 6341 -- violate restrictions on preelaborable constructs (RM-10.2.1(5-9)). 6342 6343 --------------------------------- 6344 -- Is_Preelaborable_Expression -- 6345 --------------------------------- 6346 6347 function Is_Preelaborable_Expression (N : Node_Id) return Boolean is 6348 Exp : Node_Id; 6349 Assn : Node_Id; 6350 Choice : Node_Id; 6351 Comp_Type : Entity_Id; 6352 Is_Array_Aggr : Boolean; 6353 6354 begin 6355 if Is_Static_Expression (N) then 6356 return True; 6357 6358 elsif Nkind (N) = N_Null then 6359 return True; 6360 6361 -- Attributes are allowed in general, even if their prefix is a 6362 -- formal type. (It seems that certain attributes known not to be 6363 -- static might not be allowed, but there are no rules to prevent 6364 -- them.) 6365 6366 elsif Nkind (N) = N_Attribute_Reference then 6367 return True; 6368 6369 -- The name of a discriminant evaluated within its parent type is 6370 -- defined to be preelaborable (10.2.1(8)). Note that we test for 6371 -- names that denote discriminals as well as discriminants to 6372 -- catch references occurring within init procs. 6373 6374 elsif Is_Entity_Name (N) 6375 and then 6376 (Ekind (Entity (N)) = E_Discriminant 6377 or else 6378 ((Ekind (Entity (N)) = E_Constant 6379 or else Ekind (Entity (N)) = E_In_Parameter) 6380 and then Present (Discriminal_Link (Entity (N))))) 6381 then 6382 return True; 6383 6384 elsif Nkind (N) = N_Qualified_Expression then 6385 return Is_Preelaborable_Expression (Expression (N)); 6386 6387 -- For aggregates we have to check that each of the associations 6388 -- is preelaborable. 6389 6390 elsif Nkind (N) = N_Aggregate 6391 or else Nkind (N) = N_Extension_Aggregate 6392 then 6393 Is_Array_Aggr := Is_Array_Type (Etype (N)); 6394 6395 if Is_Array_Aggr then 6396 Comp_Type := Component_Type (Etype (N)); 6397 end if; 6398 6399 -- Check the ancestor part of extension aggregates, which must 6400 -- be either the name of a type that has preelaborable init or 6401 -- an expression that is preelaborable. 6402 6403 if Nkind (N) = N_Extension_Aggregate then 6404 declare 6405 Anc_Part : constant Node_Id := Ancestor_Part (N); 6406 6407 begin 6408 if Is_Entity_Name (Anc_Part) 6409 and then Is_Type (Entity (Anc_Part)) 6410 then 6411 if not Has_Preelaborable_Initialization 6412 (Entity (Anc_Part)) 6413 then 6414 return False; 6415 end if; 6416 6417 elsif not Is_Preelaborable_Expression (Anc_Part) then 6418 return False; 6419 end if; 6420 end; 6421 end if; 6422 6423 -- Check positional associations 6424 6425 Exp := First (Expressions (N)); 6426 while Present (Exp) loop 6427 if not Is_Preelaborable_Expression (Exp) then 6428 return False; 6429 end if; 6430 6431 Next (Exp); 6432 end loop; 6433 6434 -- Check named associations 6435 6436 Assn := First (Component_Associations (N)); 6437 while Present (Assn) loop 6438 Choice := First (Choices (Assn)); 6439 while Present (Choice) loop 6440 if Is_Array_Aggr then 6441 if Nkind (Choice) = N_Others_Choice then 6442 null; 6443 6444 elsif Nkind (Choice) = N_Range then 6445 if not Is_Static_Range (Choice) then 6446 return False; 6447 end if; 6448 6449 elsif not Is_Static_Expression (Choice) then 6450 return False; 6451 end if; 6452 6453 else 6454 Comp_Type := Etype (Choice); 6455 end if; 6456 6457 Next (Choice); 6458 end loop; 6459 6460 -- If the association has a <> at this point, then we have 6461 -- to check whether the component's type has preelaborable 6462 -- initialization. Note that this only occurs when the 6463 -- association's corresponding component does not have a 6464 -- default expression, the latter case having already been 6465 -- expanded as an expression for the association. 6466 6467 if Box_Present (Assn) then 6468 if not Has_Preelaborable_Initialization (Comp_Type) then 6469 return False; 6470 end if; 6471 6472 -- In the expression case we check whether the expression 6473 -- is preelaborable. 6474 6475 elsif 6476 not Is_Preelaborable_Expression (Expression (Assn)) 6477 then 6478 return False; 6479 end if; 6480 6481 Next (Assn); 6482 end loop; 6483 6484 -- If we get here then aggregate as a whole is preelaborable 6485 6486 return True; 6487 6488 -- All other cases are not preelaborable 6489 6490 else 6491 return False; 6492 end if; 6493 end Is_Preelaborable_Expression; 6494 6495 -- Start of processing for Check_Components 6496 6497 begin 6498 -- Loop through entities of record or protected type 6499 6500 Ent := E; 6501 while Present (Ent) loop 6502 6503 -- We are interested only in components and discriminants 6504 6505 Exp := Empty; 6506 6507 case Ekind (Ent) is 6508 when E_Component => 6509 6510 -- Get default expression if any. If there is no declaration 6511 -- node, it means we have an internal entity. The parent and 6512 -- tag fields are examples of such entities. For such cases, 6513 -- we just test the type of the entity. 6514 6515 if Present (Declaration_Node (Ent)) then 6516 Exp := Expression (Declaration_Node (Ent)); 6517 end if; 6518 6519 when E_Discriminant => 6520 6521 -- Note: for a renamed discriminant, the Declaration_Node 6522 -- may point to the one from the ancestor, and have a 6523 -- different expression, so use the proper attribute to 6524 -- retrieve the expression from the derived constraint. 6525 6526 Exp := Discriminant_Default_Value (Ent); 6527 6528 when others => 6529 goto Check_Next_Entity; 6530 end case; 6531 6532 -- A component has PI if it has no default expression and the 6533 -- component type has PI. 6534 6535 if No (Exp) then 6536 if not Has_Preelaborable_Initialization (Etype (Ent)) then 6537 Has_PE := False; 6538 exit; 6539 end if; 6540 6541 -- Require the default expression to be preelaborable 6542 6543 elsif not Is_Preelaborable_Expression (Exp) then 6544 Has_PE := False; 6545 exit; 6546 end if; 6547 6548 <<Check_Next_Entity>> 6549 Next_Entity (Ent); 6550 end loop; 6551 end Check_Components; 6552 6553 -- Start of processing for Has_Preelaborable_Initialization 6554 6555 begin 6556 -- Immediate return if already marked as known preelaborable init. This 6557 -- covers types for which this function has already been called once 6558 -- and returned True (in which case the result is cached), and also 6559 -- types to which a pragma Preelaborable_Initialization applies. 6560 6561 if Known_To_Have_Preelab_Init (E) then 6562 return True; 6563 end if; 6564 6565 -- If the type is a subtype representing a generic actual type, then 6566 -- test whether its base type has preelaborable initialization since 6567 -- the subtype representing the actual does not inherit this attribute 6568 -- from the actual or formal. (but maybe it should???) 6569 6570 if Is_Generic_Actual_Type (E) then 6571 return Has_Preelaborable_Initialization (Base_Type (E)); 6572 end if; 6573 6574 -- All elementary types have preelaborable initialization 6575 6576 if Is_Elementary_Type (E) then 6577 Has_PE := True; 6578 6579 -- Array types have PI if the component type has PI 6580 6581 elsif Is_Array_Type (E) then 6582 Has_PE := Has_Preelaborable_Initialization (Component_Type (E)); 6583 6584 -- A derived type has preelaborable initialization if its parent type 6585 -- has preelaborable initialization and (in the case of a derived record 6586 -- extension) if the non-inherited components all have preelaborable 6587 -- initialization. However, a user-defined controlled type with an 6588 -- overriding Initialize procedure does not have preelaborable 6589 -- initialization. 6590 6591 elsif Is_Derived_Type (E) then 6592 6593 -- If the derived type is a private extension then it doesn't have 6594 -- preelaborable initialization. 6595 6596 if Ekind (Base_Type (E)) = E_Record_Type_With_Private then 6597 return False; 6598 end if; 6599 6600 -- First check whether ancestor type has preelaborable initialization 6601 6602 Has_PE := Has_Preelaborable_Initialization (Etype (Base_Type (E))); 6603 6604 -- If OK, check extension components (if any) 6605 6606 if Has_PE and then Is_Record_Type (E) then 6607 Check_Components (First_Entity (E)); 6608 end if; 6609 6610 -- Check specifically for 10.2.1(11.4/2) exception: a controlled type 6611 -- with a user defined Initialize procedure does not have PI. 6612 6613 if Has_PE 6614 and then Is_Controlled (E) 6615 and then Has_Overriding_Initialize (E) 6616 then 6617 Has_PE := False; 6618 end if; 6619 6620 -- Private types not derived from a type having preelaborable init and 6621 -- that are not marked with pragma Preelaborable_Initialization do not 6622 -- have preelaborable initialization. 6623 6624 elsif Is_Private_Type (E) then 6625 return False; 6626 6627 -- Record type has PI if it is non private and all components have PI 6628 6629 elsif Is_Record_Type (E) then 6630 Has_PE := True; 6631 Check_Components (First_Entity (E)); 6632 6633 -- Protected types must not have entries, and components must meet 6634 -- same set of rules as for record components. 6635 6636 elsif Is_Protected_Type (E) then 6637 if Has_Entries (E) then 6638 Has_PE := False; 6639 else 6640 Has_PE := True; 6641 Check_Components (First_Entity (E)); 6642 Check_Components (First_Private_Entity (E)); 6643 end if; 6644 6645 -- Type System.Address always has preelaborable initialization 6646 6647 elsif Is_RTE (E, RE_Address) then 6648 Has_PE := True; 6649 6650 -- In all other cases, type does not have preelaborable initialization 6651 6652 else 6653 return False; 6654 end if; 6655 6656 -- If type has preelaborable initialization, cache result 6657 6658 if Has_PE then 6659 Set_Known_To_Have_Preelab_Init (E); 6660 end if; 6661 6662 return Has_PE; 6663 end Has_Preelaborable_Initialization; 6664 6665 --------------------------- 6666 -- Has_Private_Component -- 6667 --------------------------- 6668 6669 function Has_Private_Component (Type_Id : Entity_Id) return Boolean is 6670 Btype : Entity_Id := Base_Type (Type_Id); 6671 Component : Entity_Id; 6672 6673 begin 6674 if Error_Posted (Type_Id) 6675 or else Error_Posted (Btype) 6676 then 6677 return False; 6678 end if; 6679 6680 if Is_Class_Wide_Type (Btype) then 6681 Btype := Root_Type (Btype); 6682 end if; 6683 6684 if Is_Private_Type (Btype) then 6685 declare 6686 UT : constant Entity_Id := Underlying_Type (Btype); 6687 begin 6688 if No (UT) then 6689 if No (Full_View (Btype)) then 6690 return not Is_Generic_Type (Btype) 6691 and then not Is_Generic_Type (Root_Type (Btype)); 6692 else 6693 return not Is_Generic_Type (Root_Type (Full_View (Btype))); 6694 end if; 6695 else 6696 return not Is_Frozen (UT) and then Has_Private_Component (UT); 6697 end if; 6698 end; 6699 6700 elsif Is_Array_Type (Btype) then 6701 return Has_Private_Component (Component_Type (Btype)); 6702 6703 elsif Is_Record_Type (Btype) then 6704 Component := First_Component (Btype); 6705 while Present (Component) loop 6706 if Has_Private_Component (Etype (Component)) then 6707 return True; 6708 end if; 6709 6710 Next_Component (Component); 6711 end loop; 6712 6713 return False; 6714 6715 elsif Is_Protected_Type (Btype) 6716 and then Present (Corresponding_Record_Type (Btype)) 6717 then 6718 return Has_Private_Component (Corresponding_Record_Type (Btype)); 6719 6720 else 6721 return False; 6722 end if; 6723 end Has_Private_Component; 6724 6725 ---------------------- 6726 -- Has_Signed_Zeros -- 6727 ---------------------- 6728 6729 function Has_Signed_Zeros (E : Entity_Id) return Boolean is 6730 begin 6731 return Is_Floating_Point_Type (E) 6732 and then Signed_Zeros_On_Target 6733 and then not Vax_Float (E); 6734 end Has_Signed_Zeros; 6735 6736 ----------------------------- 6737 -- Has_Static_Array_Bounds -- 6738 ----------------------------- 6739 6740 function Has_Static_Array_Bounds (Typ : Node_Id) return Boolean is 6741 Ndims : constant Nat := Number_Dimensions (Typ); 6742 6743 Index : Node_Id; 6744 Low : Node_Id; 6745 High : Node_Id; 6746 6747 begin 6748 -- Unconstrained types do not have static bounds 6749 6750 if not Is_Constrained (Typ) then 6751 return False; 6752 end if; 6753 6754 -- First treat string literals specially, as the lower bound and length 6755 -- of string literals are not stored like those of arrays. 6756 6757 -- A string literal always has static bounds 6758 6759 if Ekind (Typ) = E_String_Literal_Subtype then 6760 return True; 6761 end if; 6762 6763 -- Treat all dimensions in turn 6764 6765 Index := First_Index (Typ); 6766 for Indx in 1 .. Ndims loop 6767 6768 -- In case of an erroneous index which is not a discrete type, return 6769 -- that the type is not static. 6770 6771 if not Is_Discrete_Type (Etype (Index)) 6772 or else Etype (Index) = Any_Type 6773 then 6774 return False; 6775 end if; 6776 6777 Get_Index_Bounds (Index, Low, High); 6778 6779 if Error_Posted (Low) or else Error_Posted (High) then 6780 return False; 6781 end if; 6782 6783 if Is_OK_Static_Expression (Low) 6784 and then 6785 Is_OK_Static_Expression (High) 6786 then 6787 null; 6788 else 6789 return False; 6790 end if; 6791 6792 Next (Index); 6793 end loop; 6794 6795 -- If we fall through the loop, all indexes matched 6796 6797 return True; 6798 end Has_Static_Array_Bounds; 6799 6800 ---------------- 6801 -- Has_Stream -- 6802 ---------------- 6803 6804 function Has_Stream (T : Entity_Id) return Boolean is 6805 E : Entity_Id; 6806 6807 begin 6808 if No (T) then 6809 return False; 6810 6811 elsif Is_RTE (Root_Type (T), RE_Root_Stream_Type) then 6812 return True; 6813 6814 elsif Is_Array_Type (T) then 6815 return Has_Stream (Component_Type (T)); 6816 6817 elsif Is_Record_Type (T) then 6818 E := First_Component (T); 6819 while Present (E) loop 6820 if Has_Stream (Etype (E)) then 6821 return True; 6822 else 6823 Next_Component (E); 6824 end if; 6825 end loop; 6826 6827 return False; 6828 6829 elsif Is_Private_Type (T) then 6830 return Has_Stream (Underlying_Type (T)); 6831 6832 else 6833 return False; 6834 end if; 6835 end Has_Stream; 6836 6837 ---------------- 6838 -- Has_Suffix -- 6839 ---------------- 6840 6841 function Has_Suffix (E : Entity_Id; Suffix : Character) return Boolean is 6842 begin 6843 Get_Name_String (Chars (E)); 6844 return Name_Buffer (Name_Len) = Suffix; 6845 end Has_Suffix; 6846 6847 ---------------- 6848 -- Add_Suffix -- 6849 ---------------- 6850 6851 function Add_Suffix (E : Entity_Id; Suffix : Character) return Name_Id is 6852 begin 6853 Get_Name_String (Chars (E)); 6854 Add_Char_To_Name_Buffer (Suffix); 6855 return Name_Find; 6856 end Add_Suffix; 6857 6858 ------------------- 6859 -- Remove_Suffix -- 6860 ------------------- 6861 6862 function Remove_Suffix (E : Entity_Id; Suffix : Character) return Name_Id is 6863 begin 6864 pragma Assert (Has_Suffix (E, Suffix)); 6865 Get_Name_String (Chars (E)); 6866 Name_Len := Name_Len - 1; 6867 return Name_Find; 6868 end Remove_Suffix; 6869 6870 -------------------------- 6871 -- Has_Tagged_Component -- 6872 -------------------------- 6873 6874 function Has_Tagged_Component (Typ : Entity_Id) return Boolean is 6875 Comp : Entity_Id; 6876 6877 begin 6878 if Is_Private_Type (Typ) 6879 and then Present (Underlying_Type (Typ)) 6880 then 6881 return Has_Tagged_Component (Underlying_Type (Typ)); 6882 6883 elsif Is_Array_Type (Typ) then 6884 return Has_Tagged_Component (Component_Type (Typ)); 6885 6886 elsif Is_Tagged_Type (Typ) then 6887 return True; 6888 6889 elsif Is_Record_Type (Typ) then 6890 Comp := First_Component (Typ); 6891 while Present (Comp) loop 6892 if Has_Tagged_Component (Etype (Comp)) then 6893 return True; 6894 end if; 6895 6896 Next_Component (Comp); 6897 end loop; 6898 6899 return False; 6900 6901 else 6902 return False; 6903 end if; 6904 end Has_Tagged_Component; 6905 6906 ------------------------- 6907 -- Implementation_Kind -- 6908 ------------------------- 6909 6910 function Implementation_Kind (Subp : Entity_Id) return Name_Id is 6911 Impl_Prag : constant Node_Id := Get_Rep_Pragma (Subp, Name_Implemented); 6912 Arg : Node_Id; 6913 begin 6914 pragma Assert (Present (Impl_Prag)); 6915 Arg := Last (Pragma_Argument_Associations (Impl_Prag)); 6916 return Chars (Get_Pragma_Arg (Arg)); 6917 end Implementation_Kind; 6918 6919 -------------------------- 6920 -- Implements_Interface -- 6921 -------------------------- 6922 6923 function Implements_Interface 6924 (Typ_Ent : Entity_Id; 6925 Iface_Ent : Entity_Id; 6926 Exclude_Parents : Boolean := False) return Boolean 6927 is 6928 Ifaces_List : Elist_Id; 6929 Elmt : Elmt_Id; 6930 Iface : Entity_Id := Base_Type (Iface_Ent); 6931 Typ : Entity_Id := Base_Type (Typ_Ent); 6932 6933 begin 6934 if Is_Class_Wide_Type (Typ) then 6935 Typ := Root_Type (Typ); 6936 end if; 6937 6938 if not Has_Interfaces (Typ) then 6939 return False; 6940 end if; 6941 6942 if Is_Class_Wide_Type (Iface) then 6943 Iface := Root_Type (Iface); 6944 end if; 6945 6946 Collect_Interfaces (Typ, Ifaces_List); 6947 6948 Elmt := First_Elmt (Ifaces_List); 6949 while Present (Elmt) loop 6950 if Is_Ancestor (Node (Elmt), Typ, Use_Full_View => True) 6951 and then Exclude_Parents 6952 then 6953 null; 6954 6955 elsif Node (Elmt) = Iface then 6956 return True; 6957 end if; 6958 6959 Next_Elmt (Elmt); 6960 end loop; 6961 6962 return False; 6963 end Implements_Interface; 6964 6965 ----------------- 6966 -- In_Instance -- 6967 ----------------- 6968 6969 function In_Instance return Boolean is 6970 Curr_Unit : constant Entity_Id := Cunit_Entity (Current_Sem_Unit); 6971 S : Entity_Id; 6972 6973 begin 6974 S := Current_Scope; 6975 while Present (S) 6976 and then S /= Standard_Standard 6977 loop 6978 if (Ekind (S) = E_Function 6979 or else Ekind (S) = E_Package 6980 or else Ekind (S) = E_Procedure) 6981 and then Is_Generic_Instance (S) 6982 then 6983 -- A child instance is always compiled in the context of a parent 6984 -- instance. Nevertheless, the actuals are not analyzed in an 6985 -- instance context. We detect this case by examining the current 6986 -- compilation unit, which must be a child instance, and checking 6987 -- that it is not currently on the scope stack. 6988 6989 if Is_Child_Unit (Curr_Unit) 6990 and then 6991 Nkind (Unit (Cunit (Current_Sem_Unit))) 6992 = N_Package_Instantiation 6993 and then not In_Open_Scopes (Curr_Unit) 6994 then 6995 return False; 6996 else 6997 return True; 6998 end if; 6999 end if; 7000 7001 S := Scope (S); 7002 end loop; 7003 7004 return False; 7005 end In_Instance; 7006 7007 ---------------------- 7008 -- In_Instance_Body -- 7009 ---------------------- 7010 7011 function In_Instance_Body return Boolean is 7012 S : Entity_Id; 7013 7014 begin 7015 S := Current_Scope; 7016 while Present (S) 7017 and then S /= Standard_Standard 7018 loop 7019 if (Ekind (S) = E_Function 7020 or else Ekind (S) = E_Procedure) 7021 and then Is_Generic_Instance (S) 7022 then 7023 return True; 7024 7025 elsif Ekind (S) = E_Package 7026 and then In_Package_Body (S) 7027 and then Is_Generic_Instance (S) 7028 then 7029 return True; 7030 end if; 7031 7032 S := Scope (S); 7033 end loop; 7034 7035 return False; 7036 end In_Instance_Body; 7037 7038 ----------------------------- 7039 -- In_Instance_Not_Visible -- 7040 ----------------------------- 7041 7042 function In_Instance_Not_Visible return Boolean is 7043 S : Entity_Id; 7044 7045 begin 7046 S := Current_Scope; 7047 while Present (S) 7048 and then S /= Standard_Standard 7049 loop 7050 if (Ekind (S) = E_Function 7051 or else Ekind (S) = E_Procedure) 7052 and then Is_Generic_Instance (S) 7053 then 7054 return True; 7055 7056 elsif Ekind (S) = E_Package 7057 and then (In_Package_Body (S) or else In_Private_Part (S)) 7058 and then Is_Generic_Instance (S) 7059 then 7060 return True; 7061 end if; 7062 7063 S := Scope (S); 7064 end loop; 7065 7066 return False; 7067 end In_Instance_Not_Visible; 7068 7069 ------------------------------ 7070 -- In_Instance_Visible_Part -- 7071 ------------------------------ 7072 7073 function In_Instance_Visible_Part return Boolean is 7074 S : Entity_Id; 7075 7076 begin 7077 S := Current_Scope; 7078 while Present (S) 7079 and then S /= Standard_Standard 7080 loop 7081 if Ekind (S) = E_Package 7082 and then Is_Generic_Instance (S) 7083 and then not In_Package_Body (S) 7084 and then not In_Private_Part (S) 7085 then 7086 return True; 7087 end if; 7088 7089 S := Scope (S); 7090 end loop; 7091 7092 return False; 7093 end In_Instance_Visible_Part; 7094 7095 --------------------- 7096 -- In_Package_Body -- 7097 --------------------- 7098 7099 function In_Package_Body return Boolean is 7100 S : Entity_Id; 7101 7102 begin 7103 S := Current_Scope; 7104 while Present (S) 7105 and then S /= Standard_Standard 7106 loop 7107 if Ekind (S) = E_Package 7108 and then In_Package_Body (S) 7109 then 7110 return True; 7111 else 7112 S := Scope (S); 7113 end if; 7114 end loop; 7115 7116 return False; 7117 end In_Package_Body; 7118 7119 -------------------------------- 7120 -- In_Parameter_Specification -- 7121 -------------------------------- 7122 7123 function In_Parameter_Specification (N : Node_Id) return Boolean is 7124 PN : Node_Id; 7125 7126 begin 7127 PN := Parent (N); 7128 while Present (PN) loop 7129 if Nkind (PN) = N_Parameter_Specification then 7130 return True; 7131 end if; 7132 7133 PN := Parent (PN); 7134 end loop; 7135 7136 return False; 7137 end In_Parameter_Specification; 7138 7139 ------------------------------------- 7140 -- In_Reverse_Storage_Order_Object -- 7141 ------------------------------------- 7142 7143 function In_Reverse_Storage_Order_Object (N : Node_Id) return Boolean is 7144 Pref : Node_Id; 7145 Btyp : Entity_Id := Empty; 7146 7147 begin 7148 -- Climb up indexed components 7149 7150 Pref := N; 7151 loop 7152 case Nkind (Pref) is 7153 when N_Selected_Component => 7154 Pref := Prefix (Pref); 7155 exit; 7156 7157 when N_Indexed_Component => 7158 Pref := Prefix (Pref); 7159 7160 when others => 7161 Pref := Empty; 7162 exit; 7163 end case; 7164 end loop; 7165 7166 if Present (Pref) then 7167 Btyp := Base_Type (Etype (Pref)); 7168 end if; 7169 7170 return 7171 Present (Btyp) 7172 and then (Is_Record_Type (Btyp) or else Is_Array_Type (Btyp)) 7173 and then Reverse_Storage_Order (Btyp); 7174 end In_Reverse_Storage_Order_Object; 7175 7176 -------------------------------------- 7177 -- In_Subprogram_Or_Concurrent_Unit -- 7178 -------------------------------------- 7179 7180 function In_Subprogram_Or_Concurrent_Unit return Boolean is 7181 E : Entity_Id; 7182 K : Entity_Kind; 7183 7184 begin 7185 -- Use scope chain to check successively outer scopes 7186 7187 E := Current_Scope; 7188 loop 7189 K := Ekind (E); 7190 7191 if K in Subprogram_Kind 7192 or else K in Concurrent_Kind 7193 or else K in Generic_Subprogram_Kind 7194 then 7195 return True; 7196 7197 elsif E = Standard_Standard then 7198 return False; 7199 end if; 7200 7201 E := Scope (E); 7202 end loop; 7203 end In_Subprogram_Or_Concurrent_Unit; 7204 7205 --------------------- 7206 -- In_Visible_Part -- 7207 --------------------- 7208 7209 function In_Visible_Part (Scope_Id : Entity_Id) return Boolean is 7210 begin 7211 return 7212 Is_Package_Or_Generic_Package (Scope_Id) 7213 and then In_Open_Scopes (Scope_Id) 7214 and then not In_Package_Body (Scope_Id) 7215 and then not In_Private_Part (Scope_Id); 7216 end In_Visible_Part; 7217 7218 -------------------------------- 7219 -- Incomplete_Or_Private_View -- 7220 -------------------------------- 7221 7222 function Incomplete_Or_Private_View (Typ : Entity_Id) return Entity_Id is 7223 function Inspect_Decls 7224 (Decls : List_Id; 7225 Taft : Boolean := False) return Entity_Id; 7226 -- Check whether a declarative region contains the incomplete or private 7227 -- view of Typ. 7228 7229 ------------------- 7230 -- Inspect_Decls -- 7231 ------------------- 7232 7233 function Inspect_Decls 7234 (Decls : List_Id; 7235 Taft : Boolean := False) return Entity_Id 7236 is 7237 Decl : Node_Id; 7238 Match : Node_Id; 7239 7240 begin 7241 Decl := First (Decls); 7242 while Present (Decl) loop 7243 Match := Empty; 7244 7245 if Taft then 7246 if Nkind (Decl) = N_Incomplete_Type_Declaration then 7247 Match := Defining_Identifier (Decl); 7248 end if; 7249 7250 else 7251 if Nkind_In (Decl, N_Private_Extension_Declaration, 7252 N_Private_Type_Declaration) 7253 then 7254 Match := Defining_Identifier (Decl); 7255 end if; 7256 end if; 7257 7258 if Present (Match) 7259 and then Present (Full_View (Match)) 7260 and then Full_View (Match) = Typ 7261 then 7262 return Match; 7263 end if; 7264 7265 Next (Decl); 7266 end loop; 7267 7268 return Empty; 7269 end Inspect_Decls; 7270 7271 -- Local variables 7272 7273 Prev : Entity_Id; 7274 7275 -- Start of processing for Incomplete_Or_Partial_View 7276 7277 begin 7278 -- Incomplete type case 7279 7280 Prev := Current_Entity_In_Scope (Typ); 7281 7282 if Present (Prev) 7283 and then Is_Incomplete_Type (Prev) 7284 and then Present (Full_View (Prev)) 7285 and then Full_View (Prev) = Typ 7286 then 7287 return Prev; 7288 end if; 7289 7290 -- Private or Taft amendment type case 7291 7292 declare 7293 Pkg : constant Entity_Id := Scope (Typ); 7294 Pkg_Decl : Node_Id := Pkg; 7295 7296 begin 7297 if Ekind (Pkg) = E_Package then 7298 while Nkind (Pkg_Decl) /= N_Package_Specification loop 7299 Pkg_Decl := Parent (Pkg_Decl); 7300 end loop; 7301 7302 -- It is knows that Typ has a private view, look for it in the 7303 -- visible declarations of the enclosing scope. A special case 7304 -- of this is when the two views have been exchanged - the full 7305 -- appears earlier than the private. 7306 7307 if Has_Private_Declaration (Typ) then 7308 Prev := Inspect_Decls (Visible_Declarations (Pkg_Decl)); 7309 7310 -- Exchanged view case, look in the private declarations 7311 7312 if No (Prev) then 7313 Prev := Inspect_Decls (Private_Declarations (Pkg_Decl)); 7314 end if; 7315 7316 return Prev; 7317 7318 -- Otherwise if this is the package body, then Typ is a potential 7319 -- Taft amendment type. The incomplete view should be located in 7320 -- the private declarations of the enclosing scope. 7321 7322 elsif In_Package_Body (Pkg) then 7323 return Inspect_Decls (Private_Declarations (Pkg_Decl), True); 7324 end if; 7325 end if; 7326 end; 7327 7328 -- The type has no incomplete or private view 7329 7330 return Empty; 7331 end Incomplete_Or_Private_View; 7332 7333 --------------------------------- 7334 -- Insert_Explicit_Dereference -- 7335 --------------------------------- 7336 7337 procedure Insert_Explicit_Dereference (N : Node_Id) is 7338 New_Prefix : constant Node_Id := Relocate_Node (N); 7339 Ent : Entity_Id := Empty; 7340 Pref : Node_Id; 7341 I : Interp_Index; 7342 It : Interp; 7343 T : Entity_Id; 7344 7345 begin 7346 Save_Interps (N, New_Prefix); 7347 7348 Rewrite (N, 7349 Make_Explicit_Dereference (Sloc (Parent (N)), 7350 Prefix => New_Prefix)); 7351 7352 Set_Etype (N, Designated_Type (Etype (New_Prefix))); 7353 7354 if Is_Overloaded (New_Prefix) then 7355 7356 -- The dereference is also overloaded, and its interpretations are 7357 -- the designated types of the interpretations of the original node. 7358 7359 Set_Etype (N, Any_Type); 7360 7361 Get_First_Interp (New_Prefix, I, It); 7362 while Present (It.Nam) loop 7363 T := It.Typ; 7364 7365 if Is_Access_Type (T) then 7366 Add_One_Interp (N, Designated_Type (T), Designated_Type (T)); 7367 end if; 7368 7369 Get_Next_Interp (I, It); 7370 end loop; 7371 7372 End_Interp_List; 7373 7374 else 7375 -- Prefix is unambiguous: mark the original prefix (which might 7376 -- Come_From_Source) as a reference, since the new (relocated) one 7377 -- won't be taken into account. 7378 7379 if Is_Entity_Name (New_Prefix) then 7380 Ent := Entity (New_Prefix); 7381 Pref := New_Prefix; 7382 7383 -- For a retrieval of a subcomponent of some composite object, 7384 -- retrieve the ultimate entity if there is one. 7385 7386 elsif Nkind (New_Prefix) = N_Selected_Component 7387 or else Nkind (New_Prefix) = N_Indexed_Component 7388 then 7389 Pref := Prefix (New_Prefix); 7390 while Present (Pref) 7391 and then 7392 (Nkind (Pref) = N_Selected_Component 7393 or else Nkind (Pref) = N_Indexed_Component) 7394 loop 7395 Pref := Prefix (Pref); 7396 end loop; 7397 7398 if Present (Pref) and then Is_Entity_Name (Pref) then 7399 Ent := Entity (Pref); 7400 end if; 7401 end if; 7402 7403 -- Place the reference on the entity node 7404 7405 if Present (Ent) then 7406 Generate_Reference (Ent, Pref); 7407 end if; 7408 end if; 7409 end Insert_Explicit_Dereference; 7410 7411 ------------------------------------------ 7412 -- Inspect_Deferred_Constant_Completion -- 7413 ------------------------------------------ 7414 7415 procedure Inspect_Deferred_Constant_Completion (Decls : List_Id) is 7416 Decl : Node_Id; 7417 7418 begin 7419 Decl := First (Decls); 7420 while Present (Decl) loop 7421 7422 -- Deferred constant signature 7423 7424 if Nkind (Decl) = N_Object_Declaration 7425 and then Constant_Present (Decl) 7426 and then No (Expression (Decl)) 7427 7428 -- No need to check internally generated constants 7429 7430 and then Comes_From_Source (Decl) 7431 7432 -- The constant is not completed. A full object declaration or a 7433 -- pragma Import complete a deferred constant. 7434 7435 and then not Has_Completion (Defining_Identifier (Decl)) 7436 then 7437 Error_Msg_N 7438 ("constant declaration requires initialization expression", 7439 Defining_Identifier (Decl)); 7440 end if; 7441 7442 Decl := Next (Decl); 7443 end loop; 7444 end Inspect_Deferred_Constant_Completion; 7445 7446 ----------------------------- 7447 -- Is_Actual_Out_Parameter -- 7448 ----------------------------- 7449 7450 function Is_Actual_Out_Parameter (N : Node_Id) return Boolean is 7451 Formal : Entity_Id; 7452 Call : Node_Id; 7453 begin 7454 Find_Actual (N, Formal, Call); 7455 return Present (Formal) and then Ekind (Formal) = E_Out_Parameter; 7456 end Is_Actual_Out_Parameter; 7457 7458 ------------------------- 7459 -- Is_Actual_Parameter -- 7460 ------------------------- 7461 7462 function Is_Actual_Parameter (N : Node_Id) return Boolean is 7463 PK : constant Node_Kind := Nkind (Parent (N)); 7464 7465 begin 7466 case PK is 7467 when N_Parameter_Association => 7468 return N = Explicit_Actual_Parameter (Parent (N)); 7469 7470 when N_Subprogram_Call => 7471 return Is_List_Member (N) 7472 and then 7473 List_Containing (N) = Parameter_Associations (Parent (N)); 7474 7475 when others => 7476 return False; 7477 end case; 7478 end Is_Actual_Parameter; 7479 7480 -------------------------------- 7481 -- Is_Actual_Tagged_Parameter -- 7482 -------------------------------- 7483 7484 function Is_Actual_Tagged_Parameter (N : Node_Id) return Boolean is 7485 Formal : Entity_Id; 7486 Call : Node_Id; 7487 begin 7488 Find_Actual (N, Formal, Call); 7489 return Present (Formal) and then Is_Tagged_Type (Etype (Formal)); 7490 end Is_Actual_Tagged_Parameter; 7491 7492 --------------------- 7493 -- Is_Aliased_View -- 7494 --------------------- 7495 7496 function Is_Aliased_View (Obj : Node_Id) return Boolean is 7497 E : Entity_Id; 7498 7499 begin 7500 if Is_Entity_Name (Obj) then 7501 E := Entity (Obj); 7502 7503 return 7504 (Is_Object (E) 7505 and then 7506 (Is_Aliased (E) 7507 or else (Present (Renamed_Object (E)) 7508 and then Is_Aliased_View (Renamed_Object (E))))) 7509 7510 or else ((Is_Formal (E) 7511 or else Ekind (E) = E_Generic_In_Out_Parameter 7512 or else Ekind (E) = E_Generic_In_Parameter) 7513 and then Is_Tagged_Type (Etype (E))) 7514 7515 or else (Is_Concurrent_Type (E) and then In_Open_Scopes (E)) 7516 7517 -- Current instance of type, either directly or as rewritten 7518 -- reference to the current object. 7519 7520 or else (Is_Entity_Name (Original_Node (Obj)) 7521 and then Present (Entity (Original_Node (Obj))) 7522 and then Is_Type (Entity (Original_Node (Obj)))) 7523 7524 or else (Is_Type (E) and then E = Current_Scope) 7525 7526 or else (Is_Incomplete_Or_Private_Type (E) 7527 and then Full_View (E) = Current_Scope) 7528 7529 -- Ada 2012 AI05-0053: the return object of an extended return 7530 -- statement is aliased if its type is immutably limited. 7531 7532 or else (Is_Return_Object (E) 7533 and then Is_Immutably_Limited_Type (Etype (E))); 7534 7535 elsif Nkind (Obj) = N_Selected_Component then 7536 return Is_Aliased (Entity (Selector_Name (Obj))); 7537 7538 elsif Nkind (Obj) = N_Indexed_Component then 7539 return Has_Aliased_Components (Etype (Prefix (Obj))) 7540 or else 7541 (Is_Access_Type (Etype (Prefix (Obj))) 7542 and then Has_Aliased_Components 7543 (Designated_Type (Etype (Prefix (Obj))))); 7544 7545 elsif Nkind_In (Obj, N_Unchecked_Type_Conversion, N_Type_Conversion) then 7546 return Is_Tagged_Type (Etype (Obj)) 7547 and then Is_Aliased_View (Expression (Obj)); 7548 7549 elsif Nkind (Obj) = N_Explicit_Dereference then 7550 return Nkind (Original_Node (Obj)) /= N_Function_Call; 7551 7552 else 7553 return False; 7554 end if; 7555 end Is_Aliased_View; 7556 7557 ------------------------- 7558 -- Is_Ancestor_Package -- 7559 ------------------------- 7560 7561 function Is_Ancestor_Package 7562 (E1 : Entity_Id; 7563 E2 : Entity_Id) return Boolean 7564 is 7565 Par : Entity_Id; 7566 7567 begin 7568 Par := E2; 7569 while Present (Par) 7570 and then Par /= Standard_Standard 7571 loop 7572 if Par = E1 then 7573 return True; 7574 end if; 7575 7576 Par := Scope (Par); 7577 end loop; 7578 7579 return False; 7580 end Is_Ancestor_Package; 7581 7582 ---------------------- 7583 -- Is_Atomic_Object -- 7584 ---------------------- 7585 7586 function Is_Atomic_Object (N : Node_Id) return Boolean is 7587 7588 function Object_Has_Atomic_Components (N : Node_Id) return Boolean; 7589 -- Determines if given object has atomic components 7590 7591 function Is_Atomic_Prefix (N : Node_Id) return Boolean; 7592 -- If prefix is an implicit dereference, examine designated type 7593 7594 ---------------------- 7595 -- Is_Atomic_Prefix -- 7596 ---------------------- 7597 7598 function Is_Atomic_Prefix (N : Node_Id) return Boolean is 7599 begin 7600 if Is_Access_Type (Etype (N)) then 7601 return 7602 Has_Atomic_Components (Designated_Type (Etype (N))); 7603 else 7604 return Object_Has_Atomic_Components (N); 7605 end if; 7606 end Is_Atomic_Prefix; 7607 7608 ---------------------------------- 7609 -- Object_Has_Atomic_Components -- 7610 ---------------------------------- 7611 7612 function Object_Has_Atomic_Components (N : Node_Id) return Boolean is 7613 begin 7614 if Has_Atomic_Components (Etype (N)) 7615 or else Is_Atomic (Etype (N)) 7616 then 7617 return True; 7618 7619 elsif Is_Entity_Name (N) 7620 and then (Has_Atomic_Components (Entity (N)) 7621 or else Is_Atomic (Entity (N))) 7622 then 7623 return True; 7624 7625 elsif Nkind (N) = N_Selected_Component 7626 and then Is_Atomic (Entity (Selector_Name (N))) 7627 then 7628 return True; 7629 7630 elsif Nkind (N) = N_Indexed_Component 7631 or else Nkind (N) = N_Selected_Component 7632 then 7633 return Is_Atomic_Prefix (Prefix (N)); 7634 7635 else 7636 return False; 7637 end if; 7638 end Object_Has_Atomic_Components; 7639 7640 -- Start of processing for Is_Atomic_Object 7641 7642 begin 7643 -- Predicate is not relevant to subprograms 7644 7645 if Is_Entity_Name (N) and then Is_Overloadable (Entity (N)) then 7646 return False; 7647 7648 elsif Is_Atomic (Etype (N)) 7649 or else (Is_Entity_Name (N) and then Is_Atomic (Entity (N))) 7650 then 7651 return True; 7652 7653 elsif Nkind (N) = N_Selected_Component 7654 and then Is_Atomic (Entity (Selector_Name (N))) 7655 then 7656 return True; 7657 7658 elsif Nkind (N) = N_Indexed_Component 7659 or else Nkind (N) = N_Selected_Component 7660 then 7661 return Is_Atomic_Prefix (Prefix (N)); 7662 7663 else 7664 return False; 7665 end if; 7666 end Is_Atomic_Object; 7667 7668 ----------------------- 7669 -- Is_Bounded_String -- 7670 ----------------------- 7671 7672 function Is_Bounded_String (T : Entity_Id) return Boolean is 7673 Under : constant Entity_Id := Underlying_Type (Root_Type (T)); 7674 7675 begin 7676 -- Check whether T is ultimately derived from Ada.Strings.Superbounded. 7677 -- Super_String, or one of the [Wide_]Wide_ versions. This will 7678 -- be True for all the Bounded_String types in instances of the 7679 -- Generic_Bounded_Length generics, and for types derived from those. 7680 7681 return Present (Under) 7682 and then (Is_RTE (Root_Type (Under), RO_SU_Super_String) or else 7683 Is_RTE (Root_Type (Under), RO_WI_Super_String) or else 7684 Is_RTE (Root_Type (Under), RO_WW_Super_String)); 7685 end Is_Bounded_String; 7686 7687 ----------------------------- 7688 -- Is_Concurrent_Interface -- 7689 ----------------------------- 7690 7691 function Is_Concurrent_Interface (T : Entity_Id) return Boolean is 7692 begin 7693 return 7694 Is_Interface (T) 7695 and then 7696 (Is_Protected_Interface (T) 7697 or else Is_Synchronized_Interface (T) 7698 or else Is_Task_Interface (T)); 7699 end Is_Concurrent_Interface; 7700 7701 -------------------------------------- 7702 -- Is_Controlling_Limited_Procedure -- 7703 -------------------------------------- 7704 7705 function Is_Controlling_Limited_Procedure 7706 (Proc_Nam : Entity_Id) return Boolean 7707 is 7708 Param_Typ : Entity_Id := Empty; 7709 7710 begin 7711 if Ekind (Proc_Nam) = E_Procedure 7712 and then Present (Parameter_Specifications (Parent (Proc_Nam))) 7713 then 7714 Param_Typ := Etype (Parameter_Type (First ( 7715 Parameter_Specifications (Parent (Proc_Nam))))); 7716 7717 -- In this case where an Itype was created, the procedure call has been 7718 -- rewritten. 7719 7720 elsif Present (Associated_Node_For_Itype (Proc_Nam)) 7721 and then Present (Original_Node (Associated_Node_For_Itype (Proc_Nam))) 7722 and then 7723 Present (Parameter_Associations 7724 (Associated_Node_For_Itype (Proc_Nam))) 7725 then 7726 Param_Typ := 7727 Etype (First (Parameter_Associations 7728 (Associated_Node_For_Itype (Proc_Nam)))); 7729 end if; 7730 7731 if Present (Param_Typ) then 7732 return 7733 Is_Interface (Param_Typ) 7734 and then Is_Limited_Record (Param_Typ); 7735 end if; 7736 7737 return False; 7738 end Is_Controlling_Limited_Procedure; 7739 7740 ----------------------------- 7741 -- Is_CPP_Constructor_Call -- 7742 ----------------------------- 7743 7744 function Is_CPP_Constructor_Call (N : Node_Id) return Boolean is 7745 begin 7746 return Nkind (N) = N_Function_Call 7747 and then Is_CPP_Class (Etype (Etype (N))) 7748 and then Is_Constructor (Entity (Name (N))) 7749 and then Is_Imported (Entity (Name (N))); 7750 end Is_CPP_Constructor_Call; 7751 7752 ----------------- 7753 -- Is_Delegate -- 7754 ----------------- 7755 7756 function Is_Delegate (T : Entity_Id) return Boolean is 7757 Desig_Type : Entity_Id; 7758 7759 begin 7760 if VM_Target /= CLI_Target then 7761 return False; 7762 end if; 7763 7764 -- Access-to-subprograms are delegates in CIL 7765 7766 if Ekind (T) = E_Access_Subprogram_Type then 7767 return True; 7768 end if; 7769 7770 if Ekind (T) not in Access_Kind then 7771 7772 -- A delegate is a managed pointer. If no designated type is defined 7773 -- it means that it's not a delegate. 7774 7775 return False; 7776 end if; 7777 7778 Desig_Type := Etype (Directly_Designated_Type (T)); 7779 7780 if not Is_Tagged_Type (Desig_Type) then 7781 return False; 7782 end if; 7783 7784 -- Test if the type is inherited from [mscorlib]System.Delegate 7785 7786 while Etype (Desig_Type) /= Desig_Type loop 7787 if Chars (Scope (Desig_Type)) /= No_Name 7788 and then Is_Imported (Scope (Desig_Type)) 7789 and then Get_Name_String (Chars (Scope (Desig_Type))) = "delegate" 7790 then 7791 return True; 7792 end if; 7793 7794 Desig_Type := Etype (Desig_Type); 7795 end loop; 7796 7797 return False; 7798 end Is_Delegate; 7799 7800 ---------------------------------------------- 7801 -- Is_Dependent_Component_Of_Mutable_Object -- 7802 ---------------------------------------------- 7803 7804 function Is_Dependent_Component_Of_Mutable_Object 7805 (Object : Node_Id) return Boolean 7806 is 7807 P : Node_Id; 7808 Prefix_Type : Entity_Id; 7809 P_Aliased : Boolean := False; 7810 Comp : Entity_Id; 7811 7812 function Is_Declared_Within_Variant (Comp : Entity_Id) return Boolean; 7813 -- Returns True if and only if Comp is declared within a variant part 7814 7815 -------------------------------- 7816 -- Is_Declared_Within_Variant -- 7817 -------------------------------- 7818 7819 function Is_Declared_Within_Variant (Comp : Entity_Id) return Boolean is 7820 Comp_Decl : constant Node_Id := Parent (Comp); 7821 Comp_List : constant Node_Id := Parent (Comp_Decl); 7822 begin 7823 return Nkind (Parent (Comp_List)) = N_Variant; 7824 end Is_Declared_Within_Variant; 7825 7826 -- Start of processing for Is_Dependent_Component_Of_Mutable_Object 7827 7828 begin 7829 if Is_Variable (Object) then 7830 7831 if Nkind (Object) = N_Selected_Component then 7832 P := Prefix (Object); 7833 Prefix_Type := Etype (P); 7834 7835 if Is_Entity_Name (P) then 7836 7837 if Ekind (Entity (P)) = E_Generic_In_Out_Parameter then 7838 Prefix_Type := Base_Type (Prefix_Type); 7839 end if; 7840 7841 if Is_Aliased (Entity (P)) then 7842 P_Aliased := True; 7843 end if; 7844 7845 -- A discriminant check on a selected component may be expanded 7846 -- into a dereference when removing side-effects. Recover the 7847 -- original node and its type, which may be unconstrained. 7848 7849 elsif Nkind (P) = N_Explicit_Dereference 7850 and then not (Comes_From_Source (P)) 7851 then 7852 P := Original_Node (P); 7853 Prefix_Type := Etype (P); 7854 7855 else 7856 -- Check for prefix being an aliased component??? 7857 7858 null; 7859 7860 end if; 7861 7862 -- A heap object is constrained by its initial value 7863 7864 -- Ada 2005 (AI-363): Always assume the object could be mutable in 7865 -- the dereferenced case, since the access value might denote an 7866 -- unconstrained aliased object, whereas in Ada 95 the designated 7867 -- object is guaranteed to be constrained. A worst-case assumption 7868 -- has to apply in Ada 2005 because we can't tell at compile time 7869 -- whether the object is "constrained by its initial value" 7870 -- (despite the fact that 3.10.2(26/2) and 8.5.1(5/2) are 7871 -- semantic rules -- these rules are acknowledged to need fixing). 7872 7873 if Ada_Version < Ada_2005 then 7874 if Is_Access_Type (Prefix_Type) 7875 or else Nkind (P) = N_Explicit_Dereference 7876 then 7877 return False; 7878 end if; 7879 7880 elsif Ada_Version >= Ada_2005 then 7881 if Is_Access_Type (Prefix_Type) then 7882 7883 -- If the access type is pool-specific, and there is no 7884 -- constrained partial view of the designated type, then the 7885 -- designated object is known to be constrained. 7886 7887 if Ekind (Prefix_Type) = E_Access_Type 7888 and then not Effectively_Has_Constrained_Partial_View 7889 (Typ => Designated_Type (Prefix_Type), 7890 Scop => Current_Scope) 7891 then 7892 return False; 7893 7894 -- Otherwise (general access type, or there is a constrained 7895 -- partial view of the designated type), we need to check 7896 -- based on the designated type. 7897 7898 else 7899 Prefix_Type := Designated_Type (Prefix_Type); 7900 end if; 7901 end if; 7902 end if; 7903 7904 Comp := 7905 Original_Record_Component (Entity (Selector_Name (Object))); 7906 7907 -- As per AI-0017, the renaming is illegal in a generic body, even 7908 -- if the subtype is indefinite. 7909 7910 -- Ada 2005 (AI-363): In Ada 2005 an aliased object can be mutable 7911 7912 if not Is_Constrained (Prefix_Type) 7913 and then (not Is_Indefinite_Subtype (Prefix_Type) 7914 or else 7915 (Is_Generic_Type (Prefix_Type) 7916 and then Ekind (Current_Scope) = E_Generic_Package 7917 and then In_Package_Body (Current_Scope))) 7918 7919 and then (Is_Declared_Within_Variant (Comp) 7920 or else Has_Discriminant_Dependent_Constraint (Comp)) 7921 and then (not P_Aliased or else Ada_Version >= Ada_2005) 7922 then 7923 return True; 7924 7925 else 7926 return 7927 Is_Dependent_Component_Of_Mutable_Object (Prefix (Object)); 7928 7929 end if; 7930 7931 elsif Nkind (Object) = N_Indexed_Component 7932 or else Nkind (Object) = N_Slice 7933 then 7934 return Is_Dependent_Component_Of_Mutable_Object (Prefix (Object)); 7935 7936 -- A type conversion that Is_Variable is a view conversion: 7937 -- go back to the denoted object. 7938 7939 elsif Nkind (Object) = N_Type_Conversion then 7940 return 7941 Is_Dependent_Component_Of_Mutable_Object (Expression (Object)); 7942 end if; 7943 end if; 7944 7945 return False; 7946 end Is_Dependent_Component_Of_Mutable_Object; 7947 7948 --------------------- 7949 -- Is_Dereferenced -- 7950 --------------------- 7951 7952 function Is_Dereferenced (N : Node_Id) return Boolean is 7953 P : constant Node_Id := Parent (N); 7954 begin 7955 return 7956 (Nkind (P) = N_Selected_Component 7957 or else 7958 Nkind (P) = N_Explicit_Dereference 7959 or else 7960 Nkind (P) = N_Indexed_Component 7961 or else 7962 Nkind (P) = N_Slice) 7963 and then Prefix (P) = N; 7964 end Is_Dereferenced; 7965 7966 ---------------------- 7967 -- Is_Descendent_Of -- 7968 ---------------------- 7969 7970 function Is_Descendent_Of (T1 : Entity_Id; T2 : Entity_Id) return Boolean is 7971 T : Entity_Id; 7972 Etyp : Entity_Id; 7973 7974 begin 7975 pragma Assert (Nkind (T1) in N_Entity); 7976 pragma Assert (Nkind (T2) in N_Entity); 7977 7978 T := Base_Type (T1); 7979 7980 -- Immediate return if the types match 7981 7982 if T = T2 then 7983 return True; 7984 7985 -- Comment needed here ??? 7986 7987 elsif Ekind (T) = E_Class_Wide_Type then 7988 return Etype (T) = T2; 7989 7990 -- All other cases 7991 7992 else 7993 loop 7994 Etyp := Etype (T); 7995 7996 -- Done if we found the type we are looking for 7997 7998 if Etyp = T2 then 7999 return True; 8000 8001 -- Done if no more derivations to check 8002 8003 elsif T = T1 8004 or else T = Etyp 8005 then 8006 return False; 8007 8008 -- Following test catches error cases resulting from prev errors 8009 8010 elsif No (Etyp) then 8011 return False; 8012 8013 elsif Is_Private_Type (T) and then Etyp = Full_View (T) then 8014 return False; 8015 8016 elsif Is_Private_Type (Etyp) and then Full_View (Etyp) = T then 8017 return False; 8018 end if; 8019 8020 T := Base_Type (Etyp); 8021 end loop; 8022 end if; 8023 end Is_Descendent_Of; 8024 8025 ---------------------------- 8026 -- Is_Expression_Function -- 8027 ---------------------------- 8028 8029 function Is_Expression_Function (Subp : Entity_Id) return Boolean is 8030 Decl : constant Node_Id := Unit_Declaration_Node (Subp); 8031 8032 begin 8033 return Ekind (Subp) = E_Function 8034 and then Nkind (Decl) = N_Subprogram_Declaration 8035 and then 8036 (Nkind (Original_Node (Decl)) = N_Expression_Function 8037 or else 8038 (Present (Corresponding_Body (Decl)) 8039 and then 8040 Nkind (Original_Node 8041 (Unit_Declaration_Node (Corresponding_Body (Decl)))) 8042 = N_Expression_Function)); 8043 end Is_Expression_Function; 8044 8045 -------------- 8046 -- Is_False -- 8047 -------------- 8048 8049 function Is_False (U : Uint) return Boolean is 8050 begin 8051 return (U = 0); 8052 end Is_False; 8053 8054 --------------------------- 8055 -- Is_Fixed_Model_Number -- 8056 --------------------------- 8057 8058 function Is_Fixed_Model_Number (U : Ureal; T : Entity_Id) return Boolean is 8059 S : constant Ureal := Small_Value (T); 8060 M : Urealp.Save_Mark; 8061 R : Boolean; 8062 begin 8063 M := Urealp.Mark; 8064 R := (U = UR_Trunc (U / S) * S); 8065 Urealp.Release (M); 8066 return R; 8067 end Is_Fixed_Model_Number; 8068 8069 ------------------------------- 8070 -- Is_Fully_Initialized_Type -- 8071 ------------------------------- 8072 8073 function Is_Fully_Initialized_Type (Typ : Entity_Id) return Boolean is 8074 begin 8075 -- In Ada2012, a scalar type with an aspect Default_Value 8076 -- is fully initialized. 8077 8078 if Is_Scalar_Type (Typ) then 8079 return Ada_Version >= Ada_2012 and then Has_Default_Aspect (Typ); 8080 8081 elsif Is_Access_Type (Typ) then 8082 return True; 8083 8084 elsif Is_Array_Type (Typ) then 8085 if Is_Fully_Initialized_Type (Component_Type (Typ)) 8086 or else (Ada_Version >= Ada_2012 and then Has_Default_Aspect (Typ)) 8087 then 8088 return True; 8089 end if; 8090 8091 -- An interesting case, if we have a constrained type one of whose 8092 -- bounds is known to be null, then there are no elements to be 8093 -- initialized, so all the elements are initialized! 8094 8095 if Is_Constrained (Typ) then 8096 declare 8097 Indx : Node_Id; 8098 Indx_Typ : Entity_Id; 8099 Lbd, Hbd : Node_Id; 8100 8101 begin 8102 Indx := First_Index (Typ); 8103 while Present (Indx) loop 8104 if Etype (Indx) = Any_Type then 8105 return False; 8106 8107 -- If index is a range, use directly 8108 8109 elsif Nkind (Indx) = N_Range then 8110 Lbd := Low_Bound (Indx); 8111 Hbd := High_Bound (Indx); 8112 8113 else 8114 Indx_Typ := Etype (Indx); 8115 8116 if Is_Private_Type (Indx_Typ) then 8117 Indx_Typ := Full_View (Indx_Typ); 8118 end if; 8119 8120 if No (Indx_Typ) or else Etype (Indx_Typ) = Any_Type then 8121 return False; 8122 else 8123 Lbd := Type_Low_Bound (Indx_Typ); 8124 Hbd := Type_High_Bound (Indx_Typ); 8125 end if; 8126 end if; 8127 8128 if Compile_Time_Known_Value (Lbd) 8129 and then Compile_Time_Known_Value (Hbd) 8130 then 8131 if Expr_Value (Hbd) < Expr_Value (Lbd) then 8132 return True; 8133 end if; 8134 end if; 8135 8136 Next_Index (Indx); 8137 end loop; 8138 end; 8139 end if; 8140 8141 -- If no null indexes, then type is not fully initialized 8142 8143 return False; 8144 8145 -- Record types 8146 8147 elsif Is_Record_Type (Typ) then 8148 if Has_Discriminants (Typ) 8149 and then 8150 Present (Discriminant_Default_Value (First_Discriminant (Typ))) 8151 and then Is_Fully_Initialized_Variant (Typ) 8152 then 8153 return True; 8154 end if; 8155 8156 -- We consider bounded string types to be fully initialized, because 8157 -- otherwise we get false alarms when the Data component is not 8158 -- default-initialized. 8159 8160 if Is_Bounded_String (Typ) then 8161 return True; 8162 end if; 8163 8164 -- Controlled records are considered to be fully initialized if 8165 -- there is a user defined Initialize routine. This may not be 8166 -- entirely correct, but as the spec notes, we are guessing here 8167 -- what is best from the point of view of issuing warnings. 8168 8169 if Is_Controlled (Typ) then 8170 declare 8171 Utyp : constant Entity_Id := Underlying_Type (Typ); 8172 8173 begin 8174 if Present (Utyp) then 8175 declare 8176 Init : constant Entity_Id := 8177 (Find_Prim_Op 8178 (Underlying_Type (Typ), Name_Initialize)); 8179 8180 begin 8181 if Present (Init) 8182 and then Comes_From_Source (Init) 8183 and then not 8184 Is_Predefined_File_Name 8185 (File_Name (Get_Source_File_Index (Sloc (Init)))) 8186 then 8187 return True; 8188 8189 elsif Has_Null_Extension (Typ) 8190 and then 8191 Is_Fully_Initialized_Type 8192 (Etype (Base_Type (Typ))) 8193 then 8194 return True; 8195 end if; 8196 end; 8197 end if; 8198 end; 8199 end if; 8200 8201 -- Otherwise see if all record components are initialized 8202 8203 declare 8204 Ent : Entity_Id; 8205 8206 begin 8207 Ent := First_Entity (Typ); 8208 while Present (Ent) loop 8209 if Ekind (Ent) = E_Component 8210 and then (No (Parent (Ent)) 8211 or else No (Expression (Parent (Ent)))) 8212 and then not Is_Fully_Initialized_Type (Etype (Ent)) 8213 8214 -- Special VM case for tag components, which need to be 8215 -- defined in this case, but are never initialized as VMs 8216 -- are using other dispatching mechanisms. Ignore this 8217 -- uninitialized case. Note that this applies both to the 8218 -- uTag entry and the main vtable pointer (CPP_Class case). 8219 8220 and then (Tagged_Type_Expansion or else not Is_Tag (Ent)) 8221 then 8222 return False; 8223 end if; 8224 8225 Next_Entity (Ent); 8226 end loop; 8227 end; 8228 8229 -- No uninitialized components, so type is fully initialized. 8230 -- Note that this catches the case of no components as well. 8231 8232 return True; 8233 8234 elsif Is_Concurrent_Type (Typ) then 8235 return True; 8236 8237 elsif Is_Private_Type (Typ) then 8238 declare 8239 U : constant Entity_Id := Underlying_Type (Typ); 8240 8241 begin 8242 if No (U) then 8243 return False; 8244 else 8245 return Is_Fully_Initialized_Type (U); 8246 end if; 8247 end; 8248 8249 else 8250 return False; 8251 end if; 8252 end Is_Fully_Initialized_Type; 8253 8254 ---------------------------------- 8255 -- Is_Fully_Initialized_Variant -- 8256 ---------------------------------- 8257 8258 function Is_Fully_Initialized_Variant (Typ : Entity_Id) return Boolean is 8259 Loc : constant Source_Ptr := Sloc (Typ); 8260 Constraints : constant List_Id := New_List; 8261 Components : constant Elist_Id := New_Elmt_List; 8262 Comp_Elmt : Elmt_Id; 8263 Comp_Id : Node_Id; 8264 Comp_List : Node_Id; 8265 Discr : Entity_Id; 8266 Discr_Val : Node_Id; 8267 8268 Report_Errors : Boolean; 8269 pragma Warnings (Off, Report_Errors); 8270 8271 begin 8272 if Serious_Errors_Detected > 0 then 8273 return False; 8274 end if; 8275 8276 if Is_Record_Type (Typ) 8277 and then Nkind (Parent (Typ)) = N_Full_Type_Declaration 8278 and then Nkind (Type_Definition (Parent (Typ))) = N_Record_Definition 8279 then 8280 Comp_List := Component_List (Type_Definition (Parent (Typ))); 8281 8282 Discr := First_Discriminant (Typ); 8283 while Present (Discr) loop 8284 if Nkind (Parent (Discr)) = N_Discriminant_Specification then 8285 Discr_Val := Expression (Parent (Discr)); 8286 8287 if Present (Discr_Val) 8288 and then Is_OK_Static_Expression (Discr_Val) 8289 then 8290 Append_To (Constraints, 8291 Make_Component_Association (Loc, 8292 Choices => New_List (New_Occurrence_Of (Discr, Loc)), 8293 Expression => New_Copy (Discr_Val))); 8294 else 8295 return False; 8296 end if; 8297 else 8298 return False; 8299 end if; 8300 8301 Next_Discriminant (Discr); 8302 end loop; 8303 8304 Gather_Components 8305 (Typ => Typ, 8306 Comp_List => Comp_List, 8307 Governed_By => Constraints, 8308 Into => Components, 8309 Report_Errors => Report_Errors); 8310 8311 -- Check that each component present is fully initialized 8312 8313 Comp_Elmt := First_Elmt (Components); 8314 while Present (Comp_Elmt) loop 8315 Comp_Id := Node (Comp_Elmt); 8316 8317 if Ekind (Comp_Id) = E_Component 8318 and then (No (Parent (Comp_Id)) 8319 or else No (Expression (Parent (Comp_Id)))) 8320 and then not Is_Fully_Initialized_Type (Etype (Comp_Id)) 8321 then 8322 return False; 8323 end if; 8324 8325 Next_Elmt (Comp_Elmt); 8326 end loop; 8327 8328 return True; 8329 8330 elsif Is_Private_Type (Typ) then 8331 declare 8332 U : constant Entity_Id := Underlying_Type (Typ); 8333 8334 begin 8335 if No (U) then 8336 return False; 8337 else 8338 return Is_Fully_Initialized_Variant (U); 8339 end if; 8340 end; 8341 else 8342 return False; 8343 end if; 8344 end Is_Fully_Initialized_Variant; 8345 8346 ---------------------------- 8347 -- Is_Inherited_Operation -- 8348 ---------------------------- 8349 8350 function Is_Inherited_Operation (E : Entity_Id) return Boolean is 8351 pragma Assert (Is_Overloadable (E)); 8352 Kind : constant Node_Kind := Nkind (Parent (E)); 8353 begin 8354 return Kind = N_Full_Type_Declaration 8355 or else Kind = N_Private_Extension_Declaration 8356 or else Kind = N_Subtype_Declaration 8357 or else (Ekind (E) = E_Enumeration_Literal 8358 and then Is_Derived_Type (Etype (E))); 8359 end Is_Inherited_Operation; 8360 8361 ------------------------------------- 8362 -- Is_Inherited_Operation_For_Type -- 8363 ------------------------------------- 8364 8365 function Is_Inherited_Operation_For_Type 8366 (E : Entity_Id; 8367 Typ : Entity_Id) return Boolean 8368 is 8369 begin 8370 return Is_Inherited_Operation (E) 8371 and then Etype (Parent (E)) = Typ; 8372 end Is_Inherited_Operation_For_Type; 8373 8374 ----------------- 8375 -- Is_Iterator -- 8376 ----------------- 8377 8378 function Is_Iterator (Typ : Entity_Id) return Boolean is 8379 Ifaces_List : Elist_Id; 8380 Iface_Elmt : Elmt_Id; 8381 Iface : Entity_Id; 8382 8383 begin 8384 if Is_Class_Wide_Type (Typ) 8385 and then 8386 (Chars (Etype (Typ)) = Name_Forward_Iterator 8387 or else 8388 Chars (Etype (Typ)) = Name_Reversible_Iterator) 8389 and then 8390 Is_Predefined_File_Name 8391 (Unit_File_Name (Get_Source_Unit (Etype (Typ)))) 8392 then 8393 return True; 8394 8395 elsif not Is_Tagged_Type (Typ) or else not Is_Derived_Type (Typ) then 8396 return False; 8397 8398 else 8399 Collect_Interfaces (Typ, Ifaces_List); 8400 8401 Iface_Elmt := First_Elmt (Ifaces_List); 8402 while Present (Iface_Elmt) loop 8403 Iface := Node (Iface_Elmt); 8404 if Chars (Iface) = Name_Forward_Iterator 8405 and then 8406 Is_Predefined_File_Name 8407 (Unit_File_Name (Get_Source_Unit (Iface))) 8408 then 8409 return True; 8410 end if; 8411 8412 Next_Elmt (Iface_Elmt); 8413 end loop; 8414 8415 return False; 8416 end if; 8417 end Is_Iterator; 8418 8419 ------------ 8420 -- Is_LHS -- 8421 ------------ 8422 8423 -- We seem to have a lot of overlapping functions that do similar things 8424 -- (testing for left hand sides or lvalues???). Anyway, since this one is 8425 -- purely syntactic, it should be in Sem_Aux I would think??? 8426 8427 function Is_LHS (N : Node_Id) return Boolean is 8428 P : constant Node_Id := Parent (N); 8429 8430 begin 8431 if Nkind (P) = N_Assignment_Statement then 8432 return Name (P) = N; 8433 8434 elsif 8435 Nkind_In (P, N_Indexed_Component, N_Selected_Component, N_Slice) 8436 then 8437 return N = Prefix (P) and then Is_LHS (P); 8438 8439 else 8440 return False; 8441 end if; 8442 end Is_LHS; 8443 8444 ----------------------------- 8445 -- Is_Library_Level_Entity -- 8446 ----------------------------- 8447 8448 function Is_Library_Level_Entity (E : Entity_Id) return Boolean is 8449 begin 8450 -- The following is a small optimization, and it also properly handles 8451 -- discriminals, which in task bodies might appear in expressions before 8452 -- the corresponding procedure has been created, and which therefore do 8453 -- not have an assigned scope. 8454 8455 if Is_Formal (E) then 8456 return False; 8457 end if; 8458 8459 -- Normal test is simply that the enclosing dynamic scope is Standard 8460 8461 return Enclosing_Dynamic_Scope (E) = Standard_Standard; 8462 end Is_Library_Level_Entity; 8463 8464 -------------------------------- 8465 -- Is_Limited_Class_Wide_Type -- 8466 -------------------------------- 8467 8468 function Is_Limited_Class_Wide_Type (Typ : Entity_Id) return Boolean is 8469 begin 8470 return 8471 Is_Class_Wide_Type (Typ) 8472 and then Is_Limited_Type (Typ); 8473 end Is_Limited_Class_Wide_Type; 8474 8475 --------------------------------- 8476 -- Is_Local_Variable_Reference -- 8477 --------------------------------- 8478 8479 function Is_Local_Variable_Reference (Expr : Node_Id) return Boolean is 8480 begin 8481 if not Is_Entity_Name (Expr) then 8482 return False; 8483 8484 else 8485 declare 8486 Ent : constant Entity_Id := Entity (Expr); 8487 Sub : constant Entity_Id := Enclosing_Subprogram (Ent); 8488 begin 8489 if not Ekind_In (Ent, E_Variable, E_In_Out_Parameter) then 8490 return False; 8491 else 8492 return Present (Sub) and then Sub = Current_Subprogram; 8493 end if; 8494 end; 8495 end if; 8496 end Is_Local_Variable_Reference; 8497 8498 ------------------------- 8499 -- Is_Object_Reference -- 8500 ------------------------- 8501 8502 function Is_Object_Reference (N : Node_Id) return Boolean is 8503 8504 function Is_Internally_Generated_Renaming (N : Node_Id) return Boolean; 8505 -- Determine whether N is the name of an internally-generated renaming 8506 8507 -------------------------------------- 8508 -- Is_Internally_Generated_Renaming -- 8509 -------------------------------------- 8510 8511 function Is_Internally_Generated_Renaming (N : Node_Id) return Boolean is 8512 P : Node_Id; 8513 8514 begin 8515 P := N; 8516 while Present (P) loop 8517 if Nkind (P) = N_Object_Renaming_Declaration then 8518 return not Comes_From_Source (P); 8519 elsif Is_List_Member (P) then 8520 return False; 8521 end if; 8522 8523 P := Parent (P); 8524 end loop; 8525 8526 return False; 8527 end Is_Internally_Generated_Renaming; 8528 8529 -- Start of processing for Is_Object_Reference 8530 8531 begin 8532 if Is_Entity_Name (N) then 8533 return Present (Entity (N)) and then Is_Object (Entity (N)); 8534 8535 else 8536 case Nkind (N) is 8537 when N_Indexed_Component | N_Slice => 8538 return 8539 Is_Object_Reference (Prefix (N)) 8540 or else Is_Access_Type (Etype (Prefix (N))); 8541 8542 -- In Ada 95, a function call is a constant object; a procedure 8543 -- call is not. 8544 8545 when N_Function_Call => 8546 return Etype (N) /= Standard_Void_Type; 8547 8548 -- Attributes 'Input and 'Result produce objects 8549 8550 when N_Attribute_Reference => 8551 return Attribute_Name (N) = Name_Input 8552 or else 8553 Attribute_Name (N) = Name_Result; 8554 8555 when N_Selected_Component => 8556 return 8557 Is_Object_Reference (Selector_Name (N)) 8558 and then 8559 (Is_Object_Reference (Prefix (N)) 8560 or else Is_Access_Type (Etype (Prefix (N)))); 8561 8562 when N_Explicit_Dereference => 8563 return True; 8564 8565 -- A view conversion of a tagged object is an object reference 8566 8567 when N_Type_Conversion => 8568 return Is_Tagged_Type (Etype (Subtype_Mark (N))) 8569 and then Is_Tagged_Type (Etype (Expression (N))) 8570 and then Is_Object_Reference (Expression (N)); 8571 8572 -- An unchecked type conversion is considered to be an object if 8573 -- the operand is an object (this construction arises only as a 8574 -- result of expansion activities). 8575 8576 when N_Unchecked_Type_Conversion => 8577 return True; 8578 8579 -- Allow string literals to act as objects as long as they appear 8580 -- in internally-generated renamings. The expansion of iterators 8581 -- may generate such renamings when the range involves a string 8582 -- literal. 8583 8584 when N_String_Literal => 8585 return Is_Internally_Generated_Renaming (Parent (N)); 8586 8587 -- AI05-0003: In Ada 2012 a qualified expression is a name. 8588 -- This allows disambiguation of function calls and the use 8589 -- of aggregates in more contexts. 8590 8591 when N_Qualified_Expression => 8592 if Ada_Version < Ada_2012 then 8593 return False; 8594 else 8595 return Is_Object_Reference (Expression (N)) 8596 or else Nkind (Expression (N)) = N_Aggregate; 8597 end if; 8598 8599 when others => 8600 return False; 8601 end case; 8602 end if; 8603 end Is_Object_Reference; 8604 8605 ----------------------------------- 8606 -- Is_OK_Variable_For_Out_Formal -- 8607 ----------------------------------- 8608 8609 function Is_OK_Variable_For_Out_Formal (AV : Node_Id) return Boolean is 8610 begin 8611 Note_Possible_Modification (AV, Sure => True); 8612 8613 -- We must reject parenthesized variable names. The check for 8614 -- Comes_From_Source is present because there are currently 8615 -- cases where the compiler violates this rule (e.g. passing 8616 -- a task object to its controlled Initialize routine). 8617 8618 if Paren_Count (AV) > 0 and then Comes_From_Source (AV) then 8619 return False; 8620 8621 -- A variable is always allowed 8622 8623 elsif Is_Variable (AV) then 8624 return True; 8625 8626 -- Unchecked conversions are allowed only if they come from the 8627 -- generated code, which sometimes uses unchecked conversions for out 8628 -- parameters in cases where code generation is unaffected. We tell 8629 -- source unchecked conversions by seeing if they are rewrites of an 8630 -- original Unchecked_Conversion function call, or of an explicit 8631 -- conversion of a function call. 8632 8633 elsif Nkind (AV) = N_Unchecked_Type_Conversion then 8634 if Nkind (Original_Node (AV)) = N_Function_Call then 8635 return False; 8636 8637 elsif Comes_From_Source (AV) 8638 and then Nkind (Original_Node (Expression (AV))) = N_Function_Call 8639 then 8640 return False; 8641 8642 elsif Nkind (Original_Node (AV)) = N_Type_Conversion then 8643 return Is_OK_Variable_For_Out_Formal (Expression (AV)); 8644 8645 else 8646 return True; 8647 end if; 8648 8649 -- Normal type conversions are allowed if argument is a variable 8650 8651 elsif Nkind (AV) = N_Type_Conversion then 8652 if Is_Variable (Expression (AV)) 8653 and then Paren_Count (Expression (AV)) = 0 8654 then 8655 Note_Possible_Modification (Expression (AV), Sure => True); 8656 return True; 8657 8658 -- We also allow a non-parenthesized expression that raises 8659 -- constraint error if it rewrites what used to be a variable 8660 8661 elsif Raises_Constraint_Error (Expression (AV)) 8662 and then Paren_Count (Expression (AV)) = 0 8663 and then Is_Variable (Original_Node (Expression (AV))) 8664 then 8665 return True; 8666 8667 -- Type conversion of something other than a variable 8668 8669 else 8670 return False; 8671 end if; 8672 8673 -- If this node is rewritten, then test the original form, if that is 8674 -- OK, then we consider the rewritten node OK (for example, if the 8675 -- original node is a conversion, then Is_Variable will not be true 8676 -- but we still want to allow the conversion if it converts a variable). 8677 8678 elsif Original_Node (AV) /= AV then 8679 8680 -- In Ada 2012, the explicit dereference may be a rewritten call to a 8681 -- Reference function. 8682 8683 if Ada_Version >= Ada_2012 8684 and then Nkind (Original_Node (AV)) = N_Function_Call 8685 and then 8686 Has_Implicit_Dereference (Etype (Name (Original_Node (AV)))) 8687 then 8688 return True; 8689 8690 else 8691 return Is_OK_Variable_For_Out_Formal (Original_Node (AV)); 8692 end if; 8693 8694 -- All other non-variables are rejected 8695 8696 else 8697 return False; 8698 end if; 8699 end Is_OK_Variable_For_Out_Formal; 8700 8701 ----------------------------------- 8702 -- Is_Partially_Initialized_Type -- 8703 ----------------------------------- 8704 8705 function Is_Partially_Initialized_Type 8706 (Typ : Entity_Id; 8707 Include_Implicit : Boolean := True) return Boolean 8708 is 8709 begin 8710 if Is_Scalar_Type (Typ) then 8711 return False; 8712 8713 elsif Is_Access_Type (Typ) then 8714 return Include_Implicit; 8715 8716 elsif Is_Array_Type (Typ) then 8717 8718 -- If component type is partially initialized, so is array type 8719 8720 if Is_Partially_Initialized_Type 8721 (Component_Type (Typ), Include_Implicit) 8722 then 8723 return True; 8724 8725 -- Otherwise we are only partially initialized if we are fully 8726 -- initialized (this is the empty array case, no point in us 8727 -- duplicating that code here). 8728 8729 else 8730 return Is_Fully_Initialized_Type (Typ); 8731 end if; 8732 8733 elsif Is_Record_Type (Typ) then 8734 8735 -- A discriminated type is always partially initialized if in 8736 -- all mode 8737 8738 if Has_Discriminants (Typ) and then Include_Implicit then 8739 return True; 8740 8741 -- A tagged type is always partially initialized 8742 8743 elsif Is_Tagged_Type (Typ) then 8744 return True; 8745 8746 -- Case of non-discriminated record 8747 8748 else 8749 declare 8750 Ent : Entity_Id; 8751 8752 Component_Present : Boolean := False; 8753 -- Set True if at least one component is present. If no 8754 -- components are present, then record type is fully 8755 -- initialized (another odd case, like the null array). 8756 8757 begin 8758 -- Loop through components 8759 8760 Ent := First_Entity (Typ); 8761 while Present (Ent) loop 8762 if Ekind (Ent) = E_Component then 8763 Component_Present := True; 8764 8765 -- If a component has an initialization expression then 8766 -- the enclosing record type is partially initialized 8767 8768 if Present (Parent (Ent)) 8769 and then Present (Expression (Parent (Ent))) 8770 then 8771 return True; 8772 8773 -- If a component is of a type which is itself partially 8774 -- initialized, then the enclosing record type is also. 8775 8776 elsif Is_Partially_Initialized_Type 8777 (Etype (Ent), Include_Implicit) 8778 then 8779 return True; 8780 end if; 8781 end if; 8782 8783 Next_Entity (Ent); 8784 end loop; 8785 8786 -- No initialized components found. If we found any components 8787 -- they were all uninitialized so the result is false. 8788 8789 if Component_Present then 8790 return False; 8791 8792 -- But if we found no components, then all the components are 8793 -- initialized so we consider the type to be initialized. 8794 8795 else 8796 return True; 8797 end if; 8798 end; 8799 end if; 8800 8801 -- Concurrent types are always fully initialized 8802 8803 elsif Is_Concurrent_Type (Typ) then 8804 return True; 8805 8806 -- For a private type, go to underlying type. If there is no underlying 8807 -- type then just assume this partially initialized. Not clear if this 8808 -- can happen in a non-error case, but no harm in testing for this. 8809 8810 elsif Is_Private_Type (Typ) then 8811 declare 8812 U : constant Entity_Id := Underlying_Type (Typ); 8813 begin 8814 if No (U) then 8815 return True; 8816 else 8817 return Is_Partially_Initialized_Type (U, Include_Implicit); 8818 end if; 8819 end; 8820 8821 -- For any other type (are there any?) assume partially initialized 8822 8823 else 8824 return True; 8825 end if; 8826 end Is_Partially_Initialized_Type; 8827 8828 ------------------------------------ 8829 -- Is_Potentially_Persistent_Type -- 8830 ------------------------------------ 8831 8832 function Is_Potentially_Persistent_Type (T : Entity_Id) return Boolean is 8833 Comp : Entity_Id; 8834 Indx : Node_Id; 8835 8836 begin 8837 -- For private type, test corresponding full type 8838 8839 if Is_Private_Type (T) then 8840 return Is_Potentially_Persistent_Type (Full_View (T)); 8841 8842 -- Scalar types are potentially persistent 8843 8844 elsif Is_Scalar_Type (T) then 8845 return True; 8846 8847 -- Record type is potentially persistent if not tagged and the types of 8848 -- all it components are potentially persistent, and no component has 8849 -- an initialization expression. 8850 8851 elsif Is_Record_Type (T) 8852 and then not Is_Tagged_Type (T) 8853 and then not Is_Partially_Initialized_Type (T) 8854 then 8855 Comp := First_Component (T); 8856 while Present (Comp) loop 8857 if not Is_Potentially_Persistent_Type (Etype (Comp)) then 8858 return False; 8859 else 8860 Next_Entity (Comp); 8861 end if; 8862 end loop; 8863 8864 return True; 8865 8866 -- Array type is potentially persistent if its component type is 8867 -- potentially persistent and if all its constraints are static. 8868 8869 elsif Is_Array_Type (T) then 8870 if not Is_Potentially_Persistent_Type (Component_Type (T)) then 8871 return False; 8872 end if; 8873 8874 Indx := First_Index (T); 8875 while Present (Indx) loop 8876 if not Is_OK_Static_Subtype (Etype (Indx)) then 8877 return False; 8878 else 8879 Next_Index (Indx); 8880 end if; 8881 end loop; 8882 8883 return True; 8884 8885 -- All other types are not potentially persistent 8886 8887 else 8888 return False; 8889 end if; 8890 end Is_Potentially_Persistent_Type; 8891 8892 --------------------------------- 8893 -- Is_Protected_Self_Reference -- 8894 --------------------------------- 8895 8896 function Is_Protected_Self_Reference (N : Node_Id) return Boolean is 8897 8898 function In_Access_Definition (N : Node_Id) return Boolean; 8899 -- Returns true if N belongs to an access definition 8900 8901 -------------------------- 8902 -- In_Access_Definition -- 8903 -------------------------- 8904 8905 function In_Access_Definition (N : Node_Id) return Boolean is 8906 P : Node_Id; 8907 8908 begin 8909 P := Parent (N); 8910 while Present (P) loop 8911 if Nkind (P) = N_Access_Definition then 8912 return True; 8913 end if; 8914 8915 P := Parent (P); 8916 end loop; 8917 8918 return False; 8919 end In_Access_Definition; 8920 8921 -- Start of processing for Is_Protected_Self_Reference 8922 8923 begin 8924 -- Verify that prefix is analyzed and has the proper form. Note that 8925 -- the attributes Elab_Spec, Elab_Body, Elab_Subp_Body and UET_Address, 8926 -- which also produce the address of an entity, do not analyze their 8927 -- prefix because they denote entities that are not necessarily visible. 8928 -- Neither of them can apply to a protected type. 8929 8930 return Ada_Version >= Ada_2005 8931 and then Is_Entity_Name (N) 8932 and then Present (Entity (N)) 8933 and then Is_Protected_Type (Entity (N)) 8934 and then In_Open_Scopes (Entity (N)) 8935 and then not In_Access_Definition (N); 8936 end Is_Protected_Self_Reference; 8937 8938 ----------------------------- 8939 -- Is_RCI_Pkg_Spec_Or_Body -- 8940 ----------------------------- 8941 8942 function Is_RCI_Pkg_Spec_Or_Body (Cunit : Node_Id) return Boolean is 8943 8944 function Is_RCI_Pkg_Decl_Cunit (Cunit : Node_Id) return Boolean; 8945 -- Return True if the unit of Cunit is an RCI package declaration 8946 8947 --------------------------- 8948 -- Is_RCI_Pkg_Decl_Cunit -- 8949 --------------------------- 8950 8951 function Is_RCI_Pkg_Decl_Cunit (Cunit : Node_Id) return Boolean is 8952 The_Unit : constant Node_Id := Unit (Cunit); 8953 8954 begin 8955 if Nkind (The_Unit) /= N_Package_Declaration then 8956 return False; 8957 end if; 8958 8959 return Is_Remote_Call_Interface (Defining_Entity (The_Unit)); 8960 end Is_RCI_Pkg_Decl_Cunit; 8961 8962 -- Start of processing for Is_RCI_Pkg_Spec_Or_Body 8963 8964 begin 8965 return Is_RCI_Pkg_Decl_Cunit (Cunit) 8966 or else 8967 (Nkind (Unit (Cunit)) = N_Package_Body 8968 and then Is_RCI_Pkg_Decl_Cunit (Library_Unit (Cunit))); 8969 end Is_RCI_Pkg_Spec_Or_Body; 8970 8971 ----------------------------------------- 8972 -- Is_Remote_Access_To_Class_Wide_Type -- 8973 ----------------------------------------- 8974 8975 function Is_Remote_Access_To_Class_Wide_Type 8976 (E : Entity_Id) return Boolean 8977 is 8978 begin 8979 -- A remote access to class-wide type is a general access to object type 8980 -- declared in the visible part of a Remote_Types or Remote_Call_ 8981 -- Interface unit. 8982 8983 return Ekind (E) = E_General_Access_Type 8984 and then (Is_Remote_Call_Interface (E) or else Is_Remote_Types (E)); 8985 end Is_Remote_Access_To_Class_Wide_Type; 8986 8987 ----------------------------------------- 8988 -- Is_Remote_Access_To_Subprogram_Type -- 8989 ----------------------------------------- 8990 8991 function Is_Remote_Access_To_Subprogram_Type 8992 (E : Entity_Id) return Boolean 8993 is 8994 begin 8995 return (Ekind (E) = E_Access_Subprogram_Type 8996 or else (Ekind (E) = E_Record_Type 8997 and then Present (Corresponding_Remote_Type (E)))) 8998 and then (Is_Remote_Call_Interface (E) or else Is_Remote_Types (E)); 8999 end Is_Remote_Access_To_Subprogram_Type; 9000 9001 -------------------- 9002 -- Is_Remote_Call -- 9003 -------------------- 9004 9005 function Is_Remote_Call (N : Node_Id) return Boolean is 9006 begin 9007 if Nkind (N) not in N_Subprogram_Call then 9008 9009 -- An entry call cannot be remote 9010 9011 return False; 9012 9013 elsif Nkind (Name (N)) in N_Has_Entity 9014 and then Is_Remote_Call_Interface (Entity (Name (N))) 9015 then 9016 -- A subprogram declared in the spec of a RCI package is remote 9017 9018 return True; 9019 9020 elsif Nkind (Name (N)) = N_Explicit_Dereference 9021 and then Is_Remote_Access_To_Subprogram_Type 9022 (Etype (Prefix (Name (N)))) 9023 then 9024 -- The dereference of a RAS is a remote call 9025 9026 return True; 9027 9028 elsif Present (Controlling_Argument (N)) 9029 and then Is_Remote_Access_To_Class_Wide_Type 9030 (Etype (Controlling_Argument (N))) 9031 then 9032 -- Any primitive operation call with a controlling argument of 9033 -- a RACW type is a remote call. 9034 9035 return True; 9036 end if; 9037 9038 -- All other calls are local calls 9039 9040 return False; 9041 end Is_Remote_Call; 9042 9043 ---------------------- 9044 -- Is_Renamed_Entry -- 9045 ---------------------- 9046 9047 function Is_Renamed_Entry (Proc_Nam : Entity_Id) return Boolean is 9048 Orig_Node : Node_Id := Empty; 9049 Subp_Decl : Node_Id := Parent (Parent (Proc_Nam)); 9050 9051 function Is_Entry (Nam : Node_Id) return Boolean; 9052 -- Determine whether Nam is an entry. Traverse selectors if there are 9053 -- nested selected components. 9054 9055 -------------- 9056 -- Is_Entry -- 9057 -------------- 9058 9059 function Is_Entry (Nam : Node_Id) return Boolean is 9060 begin 9061 if Nkind (Nam) = N_Selected_Component then 9062 return Is_Entry (Selector_Name (Nam)); 9063 end if; 9064 9065 return Ekind (Entity (Nam)) = E_Entry; 9066 end Is_Entry; 9067 9068 -- Start of processing for Is_Renamed_Entry 9069 9070 begin 9071 if Present (Alias (Proc_Nam)) then 9072 Subp_Decl := Parent (Parent (Alias (Proc_Nam))); 9073 end if; 9074 9075 -- Look for a rewritten subprogram renaming declaration 9076 9077 if Nkind (Subp_Decl) = N_Subprogram_Declaration 9078 and then Present (Original_Node (Subp_Decl)) 9079 then 9080 Orig_Node := Original_Node (Subp_Decl); 9081 end if; 9082 9083 -- The rewritten subprogram is actually an entry 9084 9085 if Present (Orig_Node) 9086 and then Nkind (Orig_Node) = N_Subprogram_Renaming_Declaration 9087 and then Is_Entry (Name (Orig_Node)) 9088 then 9089 return True; 9090 end if; 9091 9092 return False; 9093 end Is_Renamed_Entry; 9094 9095 ---------------------------- 9096 -- Is_Reversible_Iterator -- 9097 ---------------------------- 9098 9099 function Is_Reversible_Iterator (Typ : Entity_Id) return Boolean is 9100 Ifaces_List : Elist_Id; 9101 Iface_Elmt : Elmt_Id; 9102 Iface : Entity_Id; 9103 9104 begin 9105 if Is_Class_Wide_Type (Typ) 9106 and then Chars (Etype (Typ)) = Name_Reversible_Iterator 9107 and then 9108 Is_Predefined_File_Name 9109 (Unit_File_Name (Get_Source_Unit (Etype (Typ)))) 9110 then 9111 return True; 9112 9113 elsif not Is_Tagged_Type (Typ) 9114 or else not Is_Derived_Type (Typ) 9115 then 9116 return False; 9117 9118 else 9119 Collect_Interfaces (Typ, Ifaces_List); 9120 9121 Iface_Elmt := First_Elmt (Ifaces_List); 9122 while Present (Iface_Elmt) loop 9123 Iface := Node (Iface_Elmt); 9124 if Chars (Iface) = Name_Reversible_Iterator 9125 and then 9126 Is_Predefined_File_Name 9127 (Unit_File_Name (Get_Source_Unit (Iface))) 9128 then 9129 return True; 9130 end if; 9131 9132 Next_Elmt (Iface_Elmt); 9133 end loop; 9134 end if; 9135 9136 return False; 9137 end Is_Reversible_Iterator; 9138 9139 ---------------------- 9140 -- Is_Selector_Name -- 9141 ---------------------- 9142 9143 function Is_Selector_Name (N : Node_Id) return Boolean is 9144 begin 9145 if not Is_List_Member (N) then 9146 declare 9147 P : constant Node_Id := Parent (N); 9148 K : constant Node_Kind := Nkind (P); 9149 begin 9150 return 9151 (K = N_Expanded_Name or else 9152 K = N_Generic_Association or else 9153 K = N_Parameter_Association or else 9154 K = N_Selected_Component) 9155 and then Selector_Name (P) = N; 9156 end; 9157 9158 else 9159 declare 9160 L : constant List_Id := List_Containing (N); 9161 P : constant Node_Id := Parent (L); 9162 begin 9163 return (Nkind (P) = N_Discriminant_Association 9164 and then Selector_Names (P) = L) 9165 or else 9166 (Nkind (P) = N_Component_Association 9167 and then Choices (P) = L); 9168 end; 9169 end if; 9170 end Is_Selector_Name; 9171 9172 ---------------------------------- 9173 -- Is_SPARK_Initialization_Expr -- 9174 ---------------------------------- 9175 9176 function Is_SPARK_Initialization_Expr (N : Node_Id) return Boolean is 9177 Is_Ok : Boolean; 9178 Expr : Node_Id; 9179 Comp_Assn : Node_Id; 9180 Orig_N : constant Node_Id := Original_Node (N); 9181 9182 begin 9183 Is_Ok := True; 9184 9185 if not Comes_From_Source (Orig_N) then 9186 goto Done; 9187 end if; 9188 9189 pragma Assert (Nkind (Orig_N) in N_Subexpr); 9190 9191 case Nkind (Orig_N) is 9192 when N_Character_Literal | 9193 N_Integer_Literal | 9194 N_Real_Literal | 9195 N_String_Literal => 9196 null; 9197 9198 when N_Identifier | 9199 N_Expanded_Name => 9200 if Is_Entity_Name (Orig_N) 9201 and then Present (Entity (Orig_N)) -- needed in some cases 9202 then 9203 case Ekind (Entity (Orig_N)) is 9204 when E_Constant | 9205 E_Enumeration_Literal | 9206 E_Named_Integer | 9207 E_Named_Real => 9208 null; 9209 when others => 9210 if Is_Type (Entity (Orig_N)) then 9211 null; 9212 else 9213 Is_Ok := False; 9214 end if; 9215 end case; 9216 end if; 9217 9218 when N_Qualified_Expression | 9219 N_Type_Conversion => 9220 Is_Ok := Is_SPARK_Initialization_Expr (Expression (Orig_N)); 9221 9222 when N_Unary_Op => 9223 Is_Ok := Is_SPARK_Initialization_Expr (Right_Opnd (Orig_N)); 9224 9225 when N_Binary_Op | 9226 N_Short_Circuit | 9227 N_Membership_Test => 9228 Is_Ok := Is_SPARK_Initialization_Expr (Left_Opnd (Orig_N)) 9229 and then Is_SPARK_Initialization_Expr (Right_Opnd (Orig_N)); 9230 9231 when N_Aggregate | 9232 N_Extension_Aggregate => 9233 if Nkind (Orig_N) = N_Extension_Aggregate then 9234 Is_Ok := Is_SPARK_Initialization_Expr (Ancestor_Part (Orig_N)); 9235 end if; 9236 9237 Expr := First (Expressions (Orig_N)); 9238 while Present (Expr) loop 9239 if not Is_SPARK_Initialization_Expr (Expr) then 9240 Is_Ok := False; 9241 goto Done; 9242 end if; 9243 9244 Next (Expr); 9245 end loop; 9246 9247 Comp_Assn := First (Component_Associations (Orig_N)); 9248 while Present (Comp_Assn) loop 9249 Expr := Expression (Comp_Assn); 9250 if Present (Expr) -- needed for box association 9251 and then not Is_SPARK_Initialization_Expr (Expr) 9252 then 9253 Is_Ok := False; 9254 goto Done; 9255 end if; 9256 9257 Next (Comp_Assn); 9258 end loop; 9259 9260 when N_Attribute_Reference => 9261 if Nkind (Prefix (Orig_N)) in N_Subexpr then 9262 Is_Ok := Is_SPARK_Initialization_Expr (Prefix (Orig_N)); 9263 end if; 9264 9265 Expr := First (Expressions (Orig_N)); 9266 while Present (Expr) loop 9267 if not Is_SPARK_Initialization_Expr (Expr) then 9268 Is_Ok := False; 9269 goto Done; 9270 end if; 9271 9272 Next (Expr); 9273 end loop; 9274 9275 -- Selected components might be expanded named not yet resolved, so 9276 -- default on the safe side. (Eg on sparklex.ads) 9277 9278 when N_Selected_Component => 9279 null; 9280 9281 when others => 9282 Is_Ok := False; 9283 end case; 9284 9285 <<Done>> 9286 return Is_Ok; 9287 end Is_SPARK_Initialization_Expr; 9288 9289 ------------------------------- 9290 -- Is_SPARK_Object_Reference -- 9291 ------------------------------- 9292 9293 function Is_SPARK_Object_Reference (N : Node_Id) return Boolean is 9294 begin 9295 if Is_Entity_Name (N) then 9296 return Present (Entity (N)) 9297 and then 9298 (Ekind_In (Entity (N), E_Constant, E_Variable) 9299 or else Ekind (Entity (N)) in Formal_Kind); 9300 9301 else 9302 case Nkind (N) is 9303 when N_Selected_Component => 9304 return Is_SPARK_Object_Reference (Prefix (N)); 9305 9306 when others => 9307 return False; 9308 end case; 9309 end if; 9310 end Is_SPARK_Object_Reference; 9311 9312 ------------------ 9313 -- Is_Statement -- 9314 ------------------ 9315 9316 function Is_Statement (N : Node_Id) return Boolean is 9317 begin 9318 return 9319 Nkind (N) in N_Statement_Other_Than_Procedure_Call 9320 or else Nkind (N) = N_Procedure_Call_Statement; 9321 end Is_Statement; 9322 9323 -------------------------------------------------- 9324 -- Is_Subprogram_Stub_Without_Prior_Declaration -- 9325 -------------------------------------------------- 9326 9327 function Is_Subprogram_Stub_Without_Prior_Declaration 9328 (N : Node_Id) return Boolean 9329 is 9330 begin 9331 -- A subprogram stub without prior declaration serves as declaration for 9332 -- the actual subprogram body. As such, it has an attached defining 9333 -- entity of E_[Generic_]Function or E_[Generic_]Procedure. 9334 9335 return Nkind (N) = N_Subprogram_Body_Stub 9336 and then Ekind (Defining_Entity (N)) /= E_Subprogram_Body; 9337 end Is_Subprogram_Stub_Without_Prior_Declaration; 9338 9339 --------------------------------- 9340 -- Is_Synchronized_Tagged_Type -- 9341 --------------------------------- 9342 9343 function Is_Synchronized_Tagged_Type (E : Entity_Id) return Boolean is 9344 Kind : constant Entity_Kind := Ekind (Base_Type (E)); 9345 9346 begin 9347 -- A task or protected type derived from an interface is a tagged type. 9348 -- Such a tagged type is called a synchronized tagged type, as are 9349 -- synchronized interfaces and private extensions whose declaration 9350 -- includes the reserved word synchronized. 9351 9352 return (Is_Tagged_Type (E) 9353 and then (Kind = E_Task_Type 9354 or else Kind = E_Protected_Type)) 9355 or else 9356 (Is_Interface (E) 9357 and then Is_Synchronized_Interface (E)) 9358 or else 9359 (Ekind (E) = E_Record_Type_With_Private 9360 and then Nkind (Parent (E)) = N_Private_Extension_Declaration 9361 and then (Synchronized_Present (Parent (E)) 9362 or else Is_Synchronized_Interface (Etype (E)))); 9363 end Is_Synchronized_Tagged_Type; 9364 9365 ----------------- 9366 -- Is_Transfer -- 9367 ----------------- 9368 9369 function Is_Transfer (N : Node_Id) return Boolean is 9370 Kind : constant Node_Kind := Nkind (N); 9371 9372 begin 9373 if Kind = N_Simple_Return_Statement 9374 or else 9375 Kind = N_Extended_Return_Statement 9376 or else 9377 Kind = N_Goto_Statement 9378 or else 9379 Kind = N_Raise_Statement 9380 or else 9381 Kind = N_Requeue_Statement 9382 then 9383 return True; 9384 9385 elsif (Kind = N_Exit_Statement or else Kind in N_Raise_xxx_Error) 9386 and then No (Condition (N)) 9387 then 9388 return True; 9389 9390 elsif Kind = N_Procedure_Call_Statement 9391 and then Is_Entity_Name (Name (N)) 9392 and then Present (Entity (Name (N))) 9393 and then No_Return (Entity (Name (N))) 9394 then 9395 return True; 9396 9397 elsif Nkind (Original_Node (N)) = N_Raise_Statement then 9398 return True; 9399 9400 else 9401 return False; 9402 end if; 9403 end Is_Transfer; 9404 9405 ------------- 9406 -- Is_True -- 9407 ------------- 9408 9409 function Is_True (U : Uint) return Boolean is 9410 begin 9411 return (U /= 0); 9412 end Is_True; 9413 9414 ------------------------------- 9415 -- Is_Universal_Numeric_Type -- 9416 ------------------------------- 9417 9418 function Is_Universal_Numeric_Type (T : Entity_Id) return Boolean is 9419 begin 9420 return T = Universal_Integer or else T = Universal_Real; 9421 end Is_Universal_Numeric_Type; 9422 9423 ------------------- 9424 -- Is_Value_Type -- 9425 ------------------- 9426 9427 function Is_Value_Type (T : Entity_Id) return Boolean is 9428 begin 9429 return VM_Target = CLI_Target 9430 and then Nkind (T) in N_Has_Chars 9431 and then Chars (T) /= No_Name 9432 and then Get_Name_String (Chars (T)) = "valuetype"; 9433 end Is_Value_Type; 9434 9435 --------------------- 9436 -- Is_VMS_Operator -- 9437 --------------------- 9438 9439 function Is_VMS_Operator (Op : Entity_Id) return Boolean is 9440 begin 9441 -- The VMS operators are declared in a child of System that is loaded 9442 -- through pragma Extend_System. In some rare cases a program is run 9443 -- with this extension but without indicating that the target is VMS. 9444 9445 return Ekind (Op) = E_Function 9446 and then Is_Intrinsic_Subprogram (Op) 9447 and then 9448 ((Present_System_Aux 9449 and then Scope (Op) = System_Aux_Id) 9450 or else 9451 (True_VMS_Target 9452 and then Scope (Scope (Op)) = RTU_Entity (System))); 9453 end Is_VMS_Operator; 9454 9455 ----------------- 9456 -- Is_Variable -- 9457 ----------------- 9458 9459 function Is_Variable 9460 (N : Node_Id; 9461 Use_Original_Node : Boolean := True) return Boolean 9462 is 9463 Orig_Node : Node_Id; 9464 9465 function In_Protected_Function (E : Entity_Id) return Boolean; 9466 -- Within a protected function, the private components of the enclosing 9467 -- protected type are constants. A function nested within a (protected) 9468 -- procedure is not itself protected. 9469 9470 function Is_Variable_Prefix (P : Node_Id) return Boolean; 9471 -- Prefixes can involve implicit dereferences, in which case we must 9472 -- test for the case of a reference of a constant access type, which can 9473 -- can never be a variable. 9474 9475 --------------------------- 9476 -- In_Protected_Function -- 9477 --------------------------- 9478 9479 function In_Protected_Function (E : Entity_Id) return Boolean is 9480 Prot : constant Entity_Id := Scope (E); 9481 S : Entity_Id; 9482 9483 begin 9484 if not Is_Protected_Type (Prot) then 9485 return False; 9486 else 9487 S := Current_Scope; 9488 while Present (S) and then S /= Prot loop 9489 if Ekind (S) = E_Function and then Scope (S) = Prot then 9490 return True; 9491 end if; 9492 9493 S := Scope (S); 9494 end loop; 9495 9496 return False; 9497 end if; 9498 end In_Protected_Function; 9499 9500 ------------------------ 9501 -- Is_Variable_Prefix -- 9502 ------------------------ 9503 9504 function Is_Variable_Prefix (P : Node_Id) return Boolean is 9505 begin 9506 if Is_Access_Type (Etype (P)) then 9507 return not Is_Access_Constant (Root_Type (Etype (P))); 9508 9509 -- For the case of an indexed component whose prefix has a packed 9510 -- array type, the prefix has been rewritten into a type conversion. 9511 -- Determine variable-ness from the converted expression. 9512 9513 elsif Nkind (P) = N_Type_Conversion 9514 and then not Comes_From_Source (P) 9515 and then Is_Array_Type (Etype (P)) 9516 and then Is_Packed (Etype (P)) 9517 then 9518 return Is_Variable (Expression (P)); 9519 9520 else 9521 return Is_Variable (P); 9522 end if; 9523 end Is_Variable_Prefix; 9524 9525 -- Start of processing for Is_Variable 9526 9527 begin 9528 -- Check if we perform the test on the original node since this may be a 9529 -- test of syntactic categories which must not be disturbed by whatever 9530 -- rewriting might have occurred. For example, an aggregate, which is 9531 -- certainly NOT a variable, could be turned into a variable by 9532 -- expansion. 9533 9534 if Use_Original_Node then 9535 Orig_Node := Original_Node (N); 9536 else 9537 Orig_Node := N; 9538 end if; 9539 9540 -- Definitely OK if Assignment_OK is set. Since this is something that 9541 -- only gets set for expanded nodes, the test is on N, not Orig_Node. 9542 9543 if Nkind (N) in N_Subexpr and then Assignment_OK (N) then 9544 return True; 9545 9546 -- Normally we go to the original node, but there is one exception where 9547 -- we use the rewritten node, namely when it is an explicit dereference. 9548 -- The generated code may rewrite a prefix which is an access type with 9549 -- an explicit dereference. The dereference is a variable, even though 9550 -- the original node may not be (since it could be a constant of the 9551 -- access type). 9552 9553 -- In Ada 2005 we have a further case to consider: the prefix may be a 9554 -- function call given in prefix notation. The original node appears to 9555 -- be a selected component, but we need to examine the call. 9556 9557 elsif Nkind (N) = N_Explicit_Dereference 9558 and then Nkind (Orig_Node) /= N_Explicit_Dereference 9559 and then Present (Etype (Orig_Node)) 9560 and then Is_Access_Type (Etype (Orig_Node)) 9561 then 9562 -- Note that if the prefix is an explicit dereference that does not 9563 -- come from source, we must check for a rewritten function call in 9564 -- prefixed notation before other forms of rewriting, to prevent a 9565 -- compiler crash. 9566 9567 return 9568 (Nkind (Orig_Node) = N_Function_Call 9569 and then not Is_Access_Constant (Etype (Prefix (N)))) 9570 or else 9571 Is_Variable_Prefix (Original_Node (Prefix (N))); 9572 9573 -- in Ada 2012, the dereference may have been added for a type with 9574 -- a declared implicit dereference aspect. 9575 9576 elsif Nkind (N) = N_Explicit_Dereference 9577 and then Present (Etype (Orig_Node)) 9578 and then Ada_Version >= Ada_2012 9579 and then Has_Implicit_Dereference (Etype (Orig_Node)) 9580 then 9581 return True; 9582 9583 -- A function call is never a variable 9584 9585 elsif Nkind (N) = N_Function_Call then 9586 return False; 9587 9588 -- All remaining checks use the original node 9589 9590 elsif Is_Entity_Name (Orig_Node) 9591 and then Present (Entity (Orig_Node)) 9592 then 9593 declare 9594 E : constant Entity_Id := Entity (Orig_Node); 9595 K : constant Entity_Kind := Ekind (E); 9596 9597 begin 9598 return (K = E_Variable 9599 and then Nkind (Parent (E)) /= N_Exception_Handler) 9600 or else (K = E_Component 9601 and then not In_Protected_Function (E)) 9602 or else K = E_Out_Parameter 9603 or else K = E_In_Out_Parameter 9604 or else K = E_Generic_In_Out_Parameter 9605 9606 -- Current instance of type 9607 9608 or else (Is_Type (E) and then In_Open_Scopes (E)) 9609 or else (Is_Incomplete_Or_Private_Type (E) 9610 and then In_Open_Scopes (Full_View (E))); 9611 end; 9612 9613 else 9614 case Nkind (Orig_Node) is 9615 when N_Indexed_Component | N_Slice => 9616 return Is_Variable_Prefix (Prefix (Orig_Node)); 9617 9618 when N_Selected_Component => 9619 return Is_Variable_Prefix (Prefix (Orig_Node)) 9620 and then Is_Variable (Selector_Name (Orig_Node)); 9621 9622 -- For an explicit dereference, the type of the prefix cannot 9623 -- be an access to constant or an access to subprogram. 9624 9625 when N_Explicit_Dereference => 9626 declare 9627 Typ : constant Entity_Id := Etype (Prefix (Orig_Node)); 9628 begin 9629 return Is_Access_Type (Typ) 9630 and then not Is_Access_Constant (Root_Type (Typ)) 9631 and then Ekind (Typ) /= E_Access_Subprogram_Type; 9632 end; 9633 9634 -- The type conversion is the case where we do not deal with the 9635 -- context dependent special case of an actual parameter. Thus 9636 -- the type conversion is only considered a variable for the 9637 -- purposes of this routine if the target type is tagged. However, 9638 -- a type conversion is considered to be a variable if it does not 9639 -- come from source (this deals for example with the conversions 9640 -- of expressions to their actual subtypes). 9641 9642 when N_Type_Conversion => 9643 return Is_Variable (Expression (Orig_Node)) 9644 and then 9645 (not Comes_From_Source (Orig_Node) 9646 or else 9647 (Is_Tagged_Type (Etype (Subtype_Mark (Orig_Node))) 9648 and then 9649 Is_Tagged_Type (Etype (Expression (Orig_Node))))); 9650 9651 -- GNAT allows an unchecked type conversion as a variable. This 9652 -- only affects the generation of internal expanded code, since 9653 -- calls to instantiations of Unchecked_Conversion are never 9654 -- considered variables (since they are function calls). 9655 9656 when N_Unchecked_Type_Conversion => 9657 return Is_Variable (Expression (Orig_Node)); 9658 9659 when others => 9660 return False; 9661 end case; 9662 end if; 9663 end Is_Variable; 9664 9665 --------------------------- 9666 -- Is_Visibly_Controlled -- 9667 --------------------------- 9668 9669 function Is_Visibly_Controlled (T : Entity_Id) return Boolean is 9670 Root : constant Entity_Id := Root_Type (T); 9671 begin 9672 return Chars (Scope (Root)) = Name_Finalization 9673 and then Chars (Scope (Scope (Root))) = Name_Ada 9674 and then Scope (Scope (Scope (Root))) = Standard_Standard; 9675 end Is_Visibly_Controlled; 9676 9677 ------------------------ 9678 -- Is_Volatile_Object -- 9679 ------------------------ 9680 9681 function Is_Volatile_Object (N : Node_Id) return Boolean is 9682 9683 function Object_Has_Volatile_Components (N : Node_Id) return Boolean; 9684 -- Determines if given object has volatile components 9685 9686 function Is_Volatile_Prefix (N : Node_Id) return Boolean; 9687 -- If prefix is an implicit dereference, examine designated type 9688 9689 ------------------------ 9690 -- Is_Volatile_Prefix -- 9691 ------------------------ 9692 9693 function Is_Volatile_Prefix (N : Node_Id) return Boolean is 9694 Typ : constant Entity_Id := Etype (N); 9695 9696 begin 9697 if Is_Access_Type (Typ) then 9698 declare 9699 Dtyp : constant Entity_Id := Designated_Type (Typ); 9700 9701 begin 9702 return Is_Volatile (Dtyp) 9703 or else Has_Volatile_Components (Dtyp); 9704 end; 9705 9706 else 9707 return Object_Has_Volatile_Components (N); 9708 end if; 9709 end Is_Volatile_Prefix; 9710 9711 ------------------------------------ 9712 -- Object_Has_Volatile_Components -- 9713 ------------------------------------ 9714 9715 function Object_Has_Volatile_Components (N : Node_Id) return Boolean is 9716 Typ : constant Entity_Id := Etype (N); 9717 9718 begin 9719 if Is_Volatile (Typ) 9720 or else Has_Volatile_Components (Typ) 9721 then 9722 return True; 9723 9724 elsif Is_Entity_Name (N) 9725 and then (Has_Volatile_Components (Entity (N)) 9726 or else Is_Volatile (Entity (N))) 9727 then 9728 return True; 9729 9730 elsif Nkind (N) = N_Indexed_Component 9731 or else Nkind (N) = N_Selected_Component 9732 then 9733 return Is_Volatile_Prefix (Prefix (N)); 9734 9735 else 9736 return False; 9737 end if; 9738 end Object_Has_Volatile_Components; 9739 9740 -- Start of processing for Is_Volatile_Object 9741 9742 begin 9743 if Is_Volatile (Etype (N)) 9744 or else (Is_Entity_Name (N) and then Is_Volatile (Entity (N))) 9745 then 9746 return True; 9747 9748 elsif Nkind_In (N, N_Indexed_Component, N_Selected_Component) 9749 and then Is_Volatile_Prefix (Prefix (N)) 9750 then 9751 return True; 9752 9753 elsif Nkind (N) = N_Selected_Component 9754 and then Is_Volatile (Entity (Selector_Name (N))) 9755 then 9756 return True; 9757 9758 else 9759 return False; 9760 end if; 9761 end Is_Volatile_Object; 9762 9763 --------------------------- 9764 -- Itype_Has_Declaration -- 9765 --------------------------- 9766 9767 function Itype_Has_Declaration (Id : Entity_Id) return Boolean is 9768 begin 9769 pragma Assert (Is_Itype (Id)); 9770 return Present (Parent (Id)) 9771 and then Nkind_In (Parent (Id), N_Full_Type_Declaration, 9772 N_Subtype_Declaration) 9773 and then Defining_Entity (Parent (Id)) = Id; 9774 end Itype_Has_Declaration; 9775 9776 ------------------------- 9777 -- Kill_Current_Values -- 9778 ------------------------- 9779 9780 procedure Kill_Current_Values 9781 (Ent : Entity_Id; 9782 Last_Assignment_Only : Boolean := False) 9783 is 9784 begin 9785 -- ??? do we have to worry about clearing cached checks? 9786 9787 if Is_Assignable (Ent) then 9788 Set_Last_Assignment (Ent, Empty); 9789 end if; 9790 9791 if Is_Object (Ent) then 9792 if not Last_Assignment_Only then 9793 Kill_Checks (Ent); 9794 Set_Current_Value (Ent, Empty); 9795 9796 if not Can_Never_Be_Null (Ent) then 9797 Set_Is_Known_Non_Null (Ent, False); 9798 end if; 9799 9800 Set_Is_Known_Null (Ent, False); 9801 9802 -- Reset Is_Known_Valid unless type is always valid, or if we have 9803 -- a loop parameter (loop parameters are always valid, since their 9804 -- bounds are defined by the bounds given in the loop header). 9805 9806 if not Is_Known_Valid (Etype (Ent)) 9807 and then Ekind (Ent) /= E_Loop_Parameter 9808 then 9809 Set_Is_Known_Valid (Ent, False); 9810 end if; 9811 end if; 9812 end if; 9813 end Kill_Current_Values; 9814 9815 procedure Kill_Current_Values (Last_Assignment_Only : Boolean := False) is 9816 S : Entity_Id; 9817 9818 procedure Kill_Current_Values_For_Entity_Chain (E : Entity_Id); 9819 -- Clear current value for entity E and all entities chained to E 9820 9821 ------------------------------------------ 9822 -- Kill_Current_Values_For_Entity_Chain -- 9823 ------------------------------------------ 9824 9825 procedure Kill_Current_Values_For_Entity_Chain (E : Entity_Id) is 9826 Ent : Entity_Id; 9827 begin 9828 Ent := E; 9829 while Present (Ent) loop 9830 Kill_Current_Values (Ent, Last_Assignment_Only); 9831 Next_Entity (Ent); 9832 end loop; 9833 end Kill_Current_Values_For_Entity_Chain; 9834 9835 -- Start of processing for Kill_Current_Values 9836 9837 begin 9838 -- Kill all saved checks, a special case of killing saved values 9839 9840 if not Last_Assignment_Only then 9841 Kill_All_Checks; 9842 end if; 9843 9844 -- Loop through relevant scopes, which includes the current scope and 9845 -- any parent scopes if the current scope is a block or a package. 9846 9847 S := Current_Scope; 9848 Scope_Loop : loop 9849 9850 -- Clear current values of all entities in current scope 9851 9852 Kill_Current_Values_For_Entity_Chain (First_Entity (S)); 9853 9854 -- If scope is a package, also clear current values of all private 9855 -- entities in the scope. 9856 9857 if Is_Package_Or_Generic_Package (S) 9858 or else Is_Concurrent_Type (S) 9859 then 9860 Kill_Current_Values_For_Entity_Chain (First_Private_Entity (S)); 9861 end if; 9862 9863 -- If this is a not a subprogram, deal with parents 9864 9865 if not Is_Subprogram (S) then 9866 S := Scope (S); 9867 exit Scope_Loop when S = Standard_Standard; 9868 else 9869 exit Scope_Loop; 9870 end if; 9871 end loop Scope_Loop; 9872 end Kill_Current_Values; 9873 9874 -------------------------- 9875 -- Kill_Size_Check_Code -- 9876 -------------------------- 9877 9878 procedure Kill_Size_Check_Code (E : Entity_Id) is 9879 begin 9880 if (Ekind (E) = E_Constant or else Ekind (E) = E_Variable) 9881 and then Present (Size_Check_Code (E)) 9882 then 9883 Remove (Size_Check_Code (E)); 9884 Set_Size_Check_Code (E, Empty); 9885 end if; 9886 end Kill_Size_Check_Code; 9887 9888 -------------------------- 9889 -- Known_To_Be_Assigned -- 9890 -------------------------- 9891 9892 function Known_To_Be_Assigned (N : Node_Id) return Boolean is 9893 P : constant Node_Id := Parent (N); 9894 9895 begin 9896 case Nkind (P) is 9897 9898 -- Test left side of assignment 9899 9900 when N_Assignment_Statement => 9901 return N = Name (P); 9902 9903 -- Function call arguments are never lvalues 9904 9905 when N_Function_Call => 9906 return False; 9907 9908 -- Positional parameter for procedure or accept call 9909 9910 when N_Procedure_Call_Statement | 9911 N_Accept_Statement 9912 => 9913 declare 9914 Proc : Entity_Id; 9915 Form : Entity_Id; 9916 Act : Node_Id; 9917 9918 begin 9919 Proc := Get_Subprogram_Entity (P); 9920 9921 if No (Proc) then 9922 return False; 9923 end if; 9924 9925 -- If we are not a list member, something is strange, so 9926 -- be conservative and return False. 9927 9928 if not Is_List_Member (N) then 9929 return False; 9930 end if; 9931 9932 -- We are going to find the right formal by stepping forward 9933 -- through the formals, as we step backwards in the actuals. 9934 9935 Form := First_Formal (Proc); 9936 Act := N; 9937 loop 9938 -- If no formal, something is weird, so be conservative 9939 -- and return False. 9940 9941 if No (Form) then 9942 return False; 9943 end if; 9944 9945 Prev (Act); 9946 exit when No (Act); 9947 Next_Formal (Form); 9948 end loop; 9949 9950 return Ekind (Form) /= E_In_Parameter; 9951 end; 9952 9953 -- Named parameter for procedure or accept call 9954 9955 when N_Parameter_Association => 9956 declare 9957 Proc : Entity_Id; 9958 Form : Entity_Id; 9959 9960 begin 9961 Proc := Get_Subprogram_Entity (Parent (P)); 9962 9963 if No (Proc) then 9964 return False; 9965 end if; 9966 9967 -- Loop through formals to find the one that matches 9968 9969 Form := First_Formal (Proc); 9970 loop 9971 -- If no matching formal, that's peculiar, some kind of 9972 -- previous error, so return False to be conservative. 9973 -- Actually this also happens in legal code in the case 9974 -- where P is a parameter association for an Extra_Formal??? 9975 9976 if No (Form) then 9977 return False; 9978 end if; 9979 9980 -- Else test for match 9981 9982 if Chars (Form) = Chars (Selector_Name (P)) then 9983 return Ekind (Form) /= E_In_Parameter; 9984 end if; 9985 9986 Next_Formal (Form); 9987 end loop; 9988 end; 9989 9990 -- Test for appearing in a conversion that itself appears 9991 -- in an lvalue context, since this should be an lvalue. 9992 9993 when N_Type_Conversion => 9994 return Known_To_Be_Assigned (P); 9995 9996 -- All other references are definitely not known to be modifications 9997 9998 when others => 9999 return False; 10000 10001 end case; 10002 end Known_To_Be_Assigned; 10003 10004 --------------------------- 10005 -- Last_Source_Statement -- 10006 --------------------------- 10007 10008 function Last_Source_Statement (HSS : Node_Id) return Node_Id is 10009 N : Node_Id; 10010 10011 begin 10012 N := Last (Statements (HSS)); 10013 while Present (N) loop 10014 exit when Comes_From_Source (N); 10015 Prev (N); 10016 end loop; 10017 10018 return N; 10019 end Last_Source_Statement; 10020 10021 ---------------------------------- 10022 -- Matching_Static_Array_Bounds -- 10023 ---------------------------------- 10024 10025 function Matching_Static_Array_Bounds 10026 (L_Typ : Node_Id; 10027 R_Typ : Node_Id) return Boolean 10028 is 10029 L_Ndims : constant Nat := Number_Dimensions (L_Typ); 10030 R_Ndims : constant Nat := Number_Dimensions (R_Typ); 10031 10032 L_Index : Node_Id; 10033 R_Index : Node_Id; 10034 L_Low : Node_Id; 10035 L_High : Node_Id; 10036 L_Len : Uint; 10037 R_Low : Node_Id; 10038 R_High : Node_Id; 10039 R_Len : Uint; 10040 10041 begin 10042 if L_Ndims /= R_Ndims then 10043 return False; 10044 end if; 10045 10046 -- Unconstrained types do not have static bounds 10047 10048 if not Is_Constrained (L_Typ) or else not Is_Constrained (R_Typ) then 10049 return False; 10050 end if; 10051 10052 -- First treat specially the first dimension, as the lower bound and 10053 -- length of string literals are not stored like those of arrays. 10054 10055 if Ekind (L_Typ) = E_String_Literal_Subtype then 10056 L_Low := String_Literal_Low_Bound (L_Typ); 10057 L_Len := String_Literal_Length (L_Typ); 10058 else 10059 L_Index := First_Index (L_Typ); 10060 Get_Index_Bounds (L_Index, L_Low, L_High); 10061 10062 if Is_OK_Static_Expression (L_Low) 10063 and then Is_OK_Static_Expression (L_High) 10064 then 10065 if Expr_Value (L_High) < Expr_Value (L_Low) then 10066 L_Len := Uint_0; 10067 else 10068 L_Len := (Expr_Value (L_High) - Expr_Value (L_Low)) + 1; 10069 end if; 10070 else 10071 return False; 10072 end if; 10073 end if; 10074 10075 if Ekind (R_Typ) = E_String_Literal_Subtype then 10076 R_Low := String_Literal_Low_Bound (R_Typ); 10077 R_Len := String_Literal_Length (R_Typ); 10078 else 10079 R_Index := First_Index (R_Typ); 10080 Get_Index_Bounds (R_Index, R_Low, R_High); 10081 10082 if Is_OK_Static_Expression (R_Low) 10083 and then Is_OK_Static_Expression (R_High) 10084 then 10085 if Expr_Value (R_High) < Expr_Value (R_Low) then 10086 R_Len := Uint_0; 10087 else 10088 R_Len := (Expr_Value (R_High) - Expr_Value (R_Low)) + 1; 10089 end if; 10090 else 10091 return False; 10092 end if; 10093 end if; 10094 10095 if Is_OK_Static_Expression (L_Low) 10096 and then Is_OK_Static_Expression (R_Low) 10097 and then Expr_Value (L_Low) = Expr_Value (R_Low) 10098 and then L_Len = R_Len 10099 then 10100 null; 10101 else 10102 return False; 10103 end if; 10104 10105 -- Then treat all other dimensions 10106 10107 for Indx in 2 .. L_Ndims loop 10108 Next (L_Index); 10109 Next (R_Index); 10110 10111 Get_Index_Bounds (L_Index, L_Low, L_High); 10112 Get_Index_Bounds (R_Index, R_Low, R_High); 10113 10114 if Is_OK_Static_Expression (L_Low) 10115 and then Is_OK_Static_Expression (L_High) 10116 and then Is_OK_Static_Expression (R_Low) 10117 and then Is_OK_Static_Expression (R_High) 10118 and then Expr_Value (L_Low) = Expr_Value (R_Low) 10119 and then Expr_Value (L_High) = Expr_Value (R_High) 10120 then 10121 null; 10122 else 10123 return False; 10124 end if; 10125 end loop; 10126 10127 -- If we fall through the loop, all indexes matched 10128 10129 return True; 10130 end Matching_Static_Array_Bounds; 10131 10132 ------------------- 10133 -- May_Be_Lvalue -- 10134 ------------------- 10135 10136 function May_Be_Lvalue (N : Node_Id) return Boolean is 10137 P : constant Node_Id := Parent (N); 10138 10139 begin 10140 case Nkind (P) is 10141 10142 -- Test left side of assignment 10143 10144 when N_Assignment_Statement => 10145 return N = Name (P); 10146 10147 -- Test prefix of component or attribute. Note that the prefix of an 10148 -- explicit or implicit dereference cannot be an l-value. 10149 10150 when N_Attribute_Reference => 10151 return N = Prefix (P) 10152 and then Name_Implies_Lvalue_Prefix (Attribute_Name (P)); 10153 10154 -- For an expanded name, the name is an lvalue if the expanded name 10155 -- is an lvalue, but the prefix is never an lvalue, since it is just 10156 -- the scope where the name is found. 10157 10158 when N_Expanded_Name => 10159 if N = Prefix (P) then 10160 return May_Be_Lvalue (P); 10161 else 10162 return False; 10163 end if; 10164 10165 -- For a selected component A.B, A is certainly an lvalue if A.B is. 10166 -- B is a little interesting, if we have A.B := 3, there is some 10167 -- discussion as to whether B is an lvalue or not, we choose to say 10168 -- it is. Note however that A is not an lvalue if it is of an access 10169 -- type since this is an implicit dereference. 10170 10171 when N_Selected_Component => 10172 if N = Prefix (P) 10173 and then Present (Etype (N)) 10174 and then Is_Access_Type (Etype (N)) 10175 then 10176 return False; 10177 else 10178 return May_Be_Lvalue (P); 10179 end if; 10180 10181 -- For an indexed component or slice, the index or slice bounds is 10182 -- never an lvalue. The prefix is an lvalue if the indexed component 10183 -- or slice is an lvalue, except if it is an access type, where we 10184 -- have an implicit dereference. 10185 10186 when N_Indexed_Component | N_Slice => 10187 if N /= Prefix (P) 10188 or else (Present (Etype (N)) and then Is_Access_Type (Etype (N))) 10189 then 10190 return False; 10191 else 10192 return May_Be_Lvalue (P); 10193 end if; 10194 10195 -- Prefix of a reference is an lvalue if the reference is an lvalue 10196 10197 when N_Reference => 10198 return May_Be_Lvalue (P); 10199 10200 -- Prefix of explicit dereference is never an lvalue 10201 10202 when N_Explicit_Dereference => 10203 return False; 10204 10205 -- Positional parameter for subprogram, entry, or accept call. 10206 -- In older versions of Ada function call arguments are never 10207 -- lvalues. In Ada 2012 functions can have in-out parameters. 10208 10209 when N_Subprogram_Call | 10210 N_Entry_Call_Statement | 10211 N_Accept_Statement 10212 => 10213 if Nkind (P) = N_Function_Call and then Ada_Version < Ada_2012 then 10214 return False; 10215 end if; 10216 10217 -- The following mechanism is clumsy and fragile. A single flag 10218 -- set in Resolve_Actuals would be preferable ??? 10219 10220 declare 10221 Proc : Entity_Id; 10222 Form : Entity_Id; 10223 Act : Node_Id; 10224 10225 begin 10226 Proc := Get_Subprogram_Entity (P); 10227 10228 if No (Proc) then 10229 return True; 10230 end if; 10231 10232 -- If we are not a list member, something is strange, so be 10233 -- conservative and return True. 10234 10235 if not Is_List_Member (N) then 10236 return True; 10237 end if; 10238 10239 -- We are going to find the right formal by stepping forward 10240 -- through the formals, as we step backwards in the actuals. 10241 10242 Form := First_Formal (Proc); 10243 Act := N; 10244 loop 10245 -- If no formal, something is weird, so be conservative and 10246 -- return True. 10247 10248 if No (Form) then 10249 return True; 10250 end if; 10251 10252 Prev (Act); 10253 exit when No (Act); 10254 Next_Formal (Form); 10255 end loop; 10256 10257 return Ekind (Form) /= E_In_Parameter; 10258 end; 10259 10260 -- Named parameter for procedure or accept call 10261 10262 when N_Parameter_Association => 10263 declare 10264 Proc : Entity_Id; 10265 Form : Entity_Id; 10266 10267 begin 10268 Proc := Get_Subprogram_Entity (Parent (P)); 10269 10270 if No (Proc) then 10271 return True; 10272 end if; 10273 10274 -- Loop through formals to find the one that matches 10275 10276 Form := First_Formal (Proc); 10277 loop 10278 -- If no matching formal, that's peculiar, some kind of 10279 -- previous error, so return True to be conservative. 10280 -- Actually happens with legal code for an unresolved call 10281 -- where we may get the wrong homonym??? 10282 10283 if No (Form) then 10284 return True; 10285 end if; 10286 10287 -- Else test for match 10288 10289 if Chars (Form) = Chars (Selector_Name (P)) then 10290 return Ekind (Form) /= E_In_Parameter; 10291 end if; 10292 10293 Next_Formal (Form); 10294 end loop; 10295 end; 10296 10297 -- Test for appearing in a conversion that itself appears in an 10298 -- lvalue context, since this should be an lvalue. 10299 10300 when N_Type_Conversion => 10301 return May_Be_Lvalue (P); 10302 10303 -- Test for appearance in object renaming declaration 10304 10305 when N_Object_Renaming_Declaration => 10306 return True; 10307 10308 -- All other references are definitely not lvalues 10309 10310 when others => 10311 return False; 10312 10313 end case; 10314 end May_Be_Lvalue; 10315 10316 ----------------------- 10317 -- Mark_Coextensions -- 10318 ----------------------- 10319 10320 procedure Mark_Coextensions (Context_Nod : Node_Id; Root_Nod : Node_Id) is 10321 Is_Dynamic : Boolean; 10322 -- Indicates whether the context causes nested coextensions to be 10323 -- dynamic or static 10324 10325 function Mark_Allocator (N : Node_Id) return Traverse_Result; 10326 -- Recognize an allocator node and label it as a dynamic coextension 10327 10328 -------------------- 10329 -- Mark_Allocator -- 10330 -------------------- 10331 10332 function Mark_Allocator (N : Node_Id) return Traverse_Result is 10333 begin 10334 if Nkind (N) = N_Allocator then 10335 if Is_Dynamic then 10336 Set_Is_Dynamic_Coextension (N); 10337 10338 -- If the allocator expression is potentially dynamic, it may 10339 -- be expanded out of order and require dynamic allocation 10340 -- anyway, so we treat the coextension itself as dynamic. 10341 -- Potential optimization ??? 10342 10343 elsif Nkind (Expression (N)) = N_Qualified_Expression 10344 and then Nkind (Expression (Expression (N))) = N_Op_Concat 10345 then 10346 Set_Is_Dynamic_Coextension (N); 10347 else 10348 Set_Is_Static_Coextension (N); 10349 end if; 10350 end if; 10351 10352 return OK; 10353 end Mark_Allocator; 10354 10355 procedure Mark_Allocators is new Traverse_Proc (Mark_Allocator); 10356 10357 -- Start of processing Mark_Coextensions 10358 10359 begin 10360 case Nkind (Context_Nod) is 10361 10362 -- Comment here ??? 10363 10364 when N_Assignment_Statement => 10365 Is_Dynamic := Nkind (Expression (Context_Nod)) = N_Allocator; 10366 10367 -- An allocator that is a component of a returned aggregate 10368 -- must be dynamic. 10369 10370 when N_Simple_Return_Statement => 10371 declare 10372 Expr : constant Node_Id := Expression (Context_Nod); 10373 begin 10374 Is_Dynamic := 10375 Nkind (Expr) = N_Allocator 10376 or else 10377 (Nkind (Expr) = N_Qualified_Expression 10378 and then Nkind (Expression (Expr)) = N_Aggregate); 10379 end; 10380 10381 -- An alloctor within an object declaration in an extended return 10382 -- statement is of necessity dynamic. 10383 10384 when N_Object_Declaration => 10385 Is_Dynamic := Nkind (Root_Nod) = N_Allocator 10386 or else 10387 Nkind (Parent (Context_Nod)) = N_Extended_Return_Statement; 10388 10389 -- This routine should not be called for constructs which may not 10390 -- contain coextensions. 10391 10392 when others => 10393 raise Program_Error; 10394 end case; 10395 10396 Mark_Allocators (Root_Nod); 10397 end Mark_Coextensions; 10398 10399 ----------------- 10400 -- Must_Inline -- 10401 ----------------- 10402 10403 function Must_Inline (Subp : Entity_Id) return Boolean is 10404 begin 10405 return 10406 (Optimization_Level = 0 10407 10408 -- AAMP and VM targets have no support for inlining in the backend. 10409 -- Hence we do as much inlining as possible in the front end. 10410 10411 or else AAMP_On_Target 10412 or else VM_Target /= No_VM) 10413 and then Has_Pragma_Inline (Subp) 10414 and then (Has_Pragma_Inline_Always (Subp) or else Front_End_Inlining); 10415 end Must_Inline; 10416 10417 ---------------------- 10418 -- Needs_One_Actual -- 10419 ---------------------- 10420 10421 function Needs_One_Actual (E : Entity_Id) return Boolean is 10422 Formal : Entity_Id; 10423 10424 begin 10425 -- Ada 2005 or later, and formals present 10426 10427 if Ada_Version >= Ada_2005 and then Present (First_Formal (E)) then 10428 Formal := Next_Formal (First_Formal (E)); 10429 while Present (Formal) loop 10430 if No (Default_Value (Formal)) then 10431 return False; 10432 end if; 10433 10434 Next_Formal (Formal); 10435 end loop; 10436 10437 return True; 10438 10439 -- Ada 83/95 or no formals 10440 10441 else 10442 return False; 10443 end if; 10444 end Needs_One_Actual; 10445 10446 ------------------------ 10447 -- New_Copy_List_Tree -- 10448 ------------------------ 10449 10450 function New_Copy_List_Tree (List : List_Id) return List_Id is 10451 NL : List_Id; 10452 E : Node_Id; 10453 10454 begin 10455 if List = No_List then 10456 return No_List; 10457 10458 else 10459 NL := New_List; 10460 E := First (List); 10461 10462 while Present (E) loop 10463 Append (New_Copy_Tree (E), NL); 10464 E := Next (E); 10465 end loop; 10466 10467 return NL; 10468 end if; 10469 end New_Copy_List_Tree; 10470 10471 ------------------- 10472 -- New_Copy_Tree -- 10473 ------------------- 10474 10475 use Atree.Unchecked_Access; 10476 use Atree_Private_Part; 10477 10478 -- Our approach here requires a two pass traversal of the tree. The 10479 -- first pass visits all nodes that eventually will be copied looking 10480 -- for defining Itypes. If any defining Itypes are found, then they are 10481 -- copied, and an entry is added to the replacement map. In the second 10482 -- phase, the tree is copied, using the replacement map to replace any 10483 -- Itype references within the copied tree. 10484 10485 -- The following hash tables are used if the Map supplied has more 10486 -- than hash threshold entries to speed up access to the map. If 10487 -- there are fewer entries, then the map is searched sequentially 10488 -- (because setting up a hash table for only a few entries takes 10489 -- more time than it saves. 10490 10491 function New_Copy_Hash (E : Entity_Id) return NCT_Header_Num; 10492 -- Hash function used for hash operations 10493 10494 ------------------- 10495 -- New_Copy_Hash -- 10496 ------------------- 10497 10498 function New_Copy_Hash (E : Entity_Id) return NCT_Header_Num is 10499 begin 10500 return Nat (E) mod (NCT_Header_Num'Last + 1); 10501 end New_Copy_Hash; 10502 10503 --------------- 10504 -- NCT_Assoc -- 10505 --------------- 10506 10507 -- The hash table NCT_Assoc associates old entities in the table 10508 -- with their corresponding new entities (i.e. the pairs of entries 10509 -- presented in the original Map argument are Key-Element pairs). 10510 10511 package NCT_Assoc is new Simple_HTable ( 10512 Header_Num => NCT_Header_Num, 10513 Element => Entity_Id, 10514 No_Element => Empty, 10515 Key => Entity_Id, 10516 Hash => New_Copy_Hash, 10517 Equal => Types."="); 10518 10519 --------------------- 10520 -- NCT_Itype_Assoc -- 10521 --------------------- 10522 10523 -- The hash table NCT_Itype_Assoc contains entries only for those 10524 -- old nodes which have a non-empty Associated_Node_For_Itype set. 10525 -- The key is the associated node, and the element is the new node 10526 -- itself (NOT the associated node for the new node). 10527 10528 package NCT_Itype_Assoc is new Simple_HTable ( 10529 Header_Num => NCT_Header_Num, 10530 Element => Entity_Id, 10531 No_Element => Empty, 10532 Key => Entity_Id, 10533 Hash => New_Copy_Hash, 10534 Equal => Types."="); 10535 10536 -- Start of processing for New_Copy_Tree function 10537 10538 function New_Copy_Tree 10539 (Source : Node_Id; 10540 Map : Elist_Id := No_Elist; 10541 New_Sloc : Source_Ptr := No_Location; 10542 New_Scope : Entity_Id := Empty) return Node_Id 10543 is 10544 Actual_Map : Elist_Id := Map; 10545 -- This is the actual map for the copy. It is initialized with the 10546 -- given elements, and then enlarged as required for Itypes that are 10547 -- copied during the first phase of the copy operation. The visit 10548 -- procedures add elements to this map as Itypes are encountered. 10549 -- The reason we cannot use Map directly, is that it may well be 10550 -- (and normally is) initialized to No_Elist, and if we have mapped 10551 -- entities, we have to reset it to point to a real Elist. 10552 10553 function Assoc (N : Node_Or_Entity_Id) return Node_Id; 10554 -- Called during second phase to map entities into their corresponding 10555 -- copies using Actual_Map. If the argument is not an entity, or is not 10556 -- in Actual_Map, then it is returned unchanged. 10557 10558 procedure Build_NCT_Hash_Tables; 10559 -- Builds hash tables (number of elements >= threshold value) 10560 10561 function Copy_Elist_With_Replacement 10562 (Old_Elist : Elist_Id) return Elist_Id; 10563 -- Called during second phase to copy element list doing replacements 10564 10565 procedure Copy_Itype_With_Replacement (New_Itype : Entity_Id); 10566 -- Called during the second phase to process a copied Itype. The actual 10567 -- copy happened during the first phase (so that we could make the entry 10568 -- in the mapping), but we still have to deal with the descendents of 10569 -- the copied Itype and copy them where necessary. 10570 10571 function Copy_List_With_Replacement (Old_List : List_Id) return List_Id; 10572 -- Called during second phase to copy list doing replacements 10573 10574 function Copy_Node_With_Replacement (Old_Node : Node_Id) return Node_Id; 10575 -- Called during second phase to copy node doing replacements 10576 10577 procedure Visit_Elist (E : Elist_Id); 10578 -- Called during first phase to visit all elements of an Elist 10579 10580 procedure Visit_Field (F : Union_Id; N : Node_Id); 10581 -- Visit a single field, recursing to call Visit_Node or Visit_List 10582 -- if the field is a syntactic descendent of the current node (i.e. 10583 -- its parent is Node N). 10584 10585 procedure Visit_Itype (Old_Itype : Entity_Id); 10586 -- Called during first phase to visit subsidiary fields of a defining 10587 -- Itype, and also create a copy and make an entry in the replacement 10588 -- map for the new copy. 10589 10590 procedure Visit_List (L : List_Id); 10591 -- Called during first phase to visit all elements of a List 10592 10593 procedure Visit_Node (N : Node_Or_Entity_Id); 10594 -- Called during first phase to visit a node and all its subtrees 10595 10596 ----------- 10597 -- Assoc -- 10598 ----------- 10599 10600 function Assoc (N : Node_Or_Entity_Id) return Node_Id is 10601 E : Elmt_Id; 10602 Ent : Entity_Id; 10603 10604 begin 10605 if not Has_Extension (N) or else No (Actual_Map) then 10606 return N; 10607 10608 elsif NCT_Hash_Tables_Used then 10609 Ent := NCT_Assoc.Get (Entity_Id (N)); 10610 10611 if Present (Ent) then 10612 return Ent; 10613 else 10614 return N; 10615 end if; 10616 10617 -- No hash table used, do serial search 10618 10619 else 10620 E := First_Elmt (Actual_Map); 10621 while Present (E) loop 10622 if Node (E) = N then 10623 return Node (Next_Elmt (E)); 10624 else 10625 E := Next_Elmt (Next_Elmt (E)); 10626 end if; 10627 end loop; 10628 end if; 10629 10630 return N; 10631 end Assoc; 10632 10633 --------------------------- 10634 -- Build_NCT_Hash_Tables -- 10635 --------------------------- 10636 10637 procedure Build_NCT_Hash_Tables is 10638 Elmt : Elmt_Id; 10639 Ent : Entity_Id; 10640 begin 10641 if NCT_Hash_Table_Setup then 10642 NCT_Assoc.Reset; 10643 NCT_Itype_Assoc.Reset; 10644 end if; 10645 10646 Elmt := First_Elmt (Actual_Map); 10647 while Present (Elmt) loop 10648 Ent := Node (Elmt); 10649 10650 -- Get new entity, and associate old and new 10651 10652 Next_Elmt (Elmt); 10653 NCT_Assoc.Set (Ent, Node (Elmt)); 10654 10655 if Is_Type (Ent) then 10656 declare 10657 Anode : constant Entity_Id := 10658 Associated_Node_For_Itype (Ent); 10659 10660 begin 10661 if Present (Anode) then 10662 10663 -- Enter a link between the associated node of the 10664 -- old Itype and the new Itype, for updating later 10665 -- when node is copied. 10666 10667 NCT_Itype_Assoc.Set (Anode, Node (Elmt)); 10668 end if; 10669 end; 10670 end if; 10671 10672 Next_Elmt (Elmt); 10673 end loop; 10674 10675 NCT_Hash_Tables_Used := True; 10676 NCT_Hash_Table_Setup := True; 10677 end Build_NCT_Hash_Tables; 10678 10679 --------------------------------- 10680 -- Copy_Elist_With_Replacement -- 10681 --------------------------------- 10682 10683 function Copy_Elist_With_Replacement 10684 (Old_Elist : Elist_Id) return Elist_Id 10685 is 10686 M : Elmt_Id; 10687 New_Elist : Elist_Id; 10688 10689 begin 10690 if No (Old_Elist) then 10691 return No_Elist; 10692 10693 else 10694 New_Elist := New_Elmt_List; 10695 10696 M := First_Elmt (Old_Elist); 10697 while Present (M) loop 10698 Append_Elmt (Copy_Node_With_Replacement (Node (M)), New_Elist); 10699 Next_Elmt (M); 10700 end loop; 10701 end if; 10702 10703 return New_Elist; 10704 end Copy_Elist_With_Replacement; 10705 10706 --------------------------------- 10707 -- Copy_Itype_With_Replacement -- 10708 --------------------------------- 10709 10710 -- This routine exactly parallels its phase one analog Visit_Itype, 10711 10712 procedure Copy_Itype_With_Replacement (New_Itype : Entity_Id) is 10713 begin 10714 -- Translate Next_Entity, Scope and Etype fields, in case they 10715 -- reference entities that have been mapped into copies. 10716 10717 Set_Next_Entity (New_Itype, Assoc (Next_Entity (New_Itype))); 10718 Set_Etype (New_Itype, Assoc (Etype (New_Itype))); 10719 10720 if Present (New_Scope) then 10721 Set_Scope (New_Itype, New_Scope); 10722 else 10723 Set_Scope (New_Itype, Assoc (Scope (New_Itype))); 10724 end if; 10725 10726 -- Copy referenced fields 10727 10728 if Is_Discrete_Type (New_Itype) then 10729 Set_Scalar_Range (New_Itype, 10730 Copy_Node_With_Replacement (Scalar_Range (New_Itype))); 10731 10732 elsif Has_Discriminants (Base_Type (New_Itype)) then 10733 Set_Discriminant_Constraint (New_Itype, 10734 Copy_Elist_With_Replacement 10735 (Discriminant_Constraint (New_Itype))); 10736 10737 elsif Is_Array_Type (New_Itype) then 10738 if Present (First_Index (New_Itype)) then 10739 Set_First_Index (New_Itype, 10740 First (Copy_List_With_Replacement 10741 (List_Containing (First_Index (New_Itype))))); 10742 end if; 10743 10744 if Is_Packed (New_Itype) then 10745 Set_Packed_Array_Type (New_Itype, 10746 Copy_Node_With_Replacement 10747 (Packed_Array_Type (New_Itype))); 10748 end if; 10749 end if; 10750 end Copy_Itype_With_Replacement; 10751 10752 -------------------------------- 10753 -- Copy_List_With_Replacement -- 10754 -------------------------------- 10755 10756 function Copy_List_With_Replacement 10757 (Old_List : List_Id) return List_Id 10758 is 10759 New_List : List_Id; 10760 E : Node_Id; 10761 10762 begin 10763 if Old_List = No_List then 10764 return No_List; 10765 10766 else 10767 New_List := Empty_List; 10768 10769 E := First (Old_List); 10770 while Present (E) loop 10771 Append (Copy_Node_With_Replacement (E), New_List); 10772 Next (E); 10773 end loop; 10774 10775 return New_List; 10776 end if; 10777 end Copy_List_With_Replacement; 10778 10779 -------------------------------- 10780 -- Copy_Node_With_Replacement -- 10781 -------------------------------- 10782 10783 function Copy_Node_With_Replacement 10784 (Old_Node : Node_Id) return Node_Id 10785 is 10786 New_Node : Node_Id; 10787 10788 procedure Adjust_Named_Associations 10789 (Old_Node : Node_Id; 10790 New_Node : Node_Id); 10791 -- If a call node has named associations, these are chained through 10792 -- the First_Named_Actual, Next_Named_Actual links. These must be 10793 -- propagated separately to the new parameter list, because these 10794 -- are not syntactic fields. 10795 10796 function Copy_Field_With_Replacement 10797 (Field : Union_Id) return Union_Id; 10798 -- Given Field, which is a field of Old_Node, return a copy of it 10799 -- if it is a syntactic field (i.e. its parent is Node), setting 10800 -- the parent of the copy to poit to New_Node. Otherwise returns 10801 -- the field (possibly mapped if it is an entity). 10802 10803 ------------------------------- 10804 -- Adjust_Named_Associations -- 10805 ------------------------------- 10806 10807 procedure Adjust_Named_Associations 10808 (Old_Node : Node_Id; 10809 New_Node : Node_Id) 10810 is 10811 Old_E : Node_Id; 10812 New_E : Node_Id; 10813 10814 Old_Next : Node_Id; 10815 New_Next : Node_Id; 10816 10817 begin 10818 Old_E := First (Parameter_Associations (Old_Node)); 10819 New_E := First (Parameter_Associations (New_Node)); 10820 while Present (Old_E) loop 10821 if Nkind (Old_E) = N_Parameter_Association 10822 and then Present (Next_Named_Actual (Old_E)) 10823 then 10824 if First_Named_Actual (Old_Node) 10825 = Explicit_Actual_Parameter (Old_E) 10826 then 10827 Set_First_Named_Actual 10828 (New_Node, Explicit_Actual_Parameter (New_E)); 10829 end if; 10830 10831 -- Now scan parameter list from the beginning,to locate 10832 -- next named actual, which can be out of order. 10833 10834 Old_Next := First (Parameter_Associations (Old_Node)); 10835 New_Next := First (Parameter_Associations (New_Node)); 10836 10837 while Nkind (Old_Next) /= N_Parameter_Association 10838 or else Explicit_Actual_Parameter (Old_Next) 10839 /= Next_Named_Actual (Old_E) 10840 loop 10841 Next (Old_Next); 10842 Next (New_Next); 10843 end loop; 10844 10845 Set_Next_Named_Actual 10846 (New_E, Explicit_Actual_Parameter (New_Next)); 10847 end if; 10848 10849 Next (Old_E); 10850 Next (New_E); 10851 end loop; 10852 end Adjust_Named_Associations; 10853 10854 --------------------------------- 10855 -- Copy_Field_With_Replacement -- 10856 --------------------------------- 10857 10858 function Copy_Field_With_Replacement 10859 (Field : Union_Id) return Union_Id 10860 is 10861 begin 10862 if Field = Union_Id (Empty) then 10863 return Field; 10864 10865 elsif Field in Node_Range then 10866 declare 10867 Old_N : constant Node_Id := Node_Id (Field); 10868 New_N : Node_Id; 10869 10870 begin 10871 -- If syntactic field, as indicated by the parent pointer 10872 -- being set, then copy the referenced node recursively. 10873 10874 if Parent (Old_N) = Old_Node then 10875 New_N := Copy_Node_With_Replacement (Old_N); 10876 10877 if New_N /= Old_N then 10878 Set_Parent (New_N, New_Node); 10879 end if; 10880 10881 -- For semantic fields, update possible entity reference 10882 -- from the replacement map. 10883 10884 else 10885 New_N := Assoc (Old_N); 10886 end if; 10887 10888 return Union_Id (New_N); 10889 end; 10890 10891 elsif Field in List_Range then 10892 declare 10893 Old_L : constant List_Id := List_Id (Field); 10894 New_L : List_Id; 10895 10896 begin 10897 -- If syntactic field, as indicated by the parent pointer, 10898 -- then recursively copy the entire referenced list. 10899 10900 if Parent (Old_L) = Old_Node then 10901 New_L := Copy_List_With_Replacement (Old_L); 10902 Set_Parent (New_L, New_Node); 10903 10904 -- For semantic list, just returned unchanged 10905 10906 else 10907 New_L := Old_L; 10908 end if; 10909 10910 return Union_Id (New_L); 10911 end; 10912 10913 -- Anything other than a list or a node is returned unchanged 10914 10915 else 10916 return Field; 10917 end if; 10918 end Copy_Field_With_Replacement; 10919 10920 -- Start of processing for Copy_Node_With_Replacement 10921 10922 begin 10923 if Old_Node <= Empty_Or_Error then 10924 return Old_Node; 10925 10926 elsif Has_Extension (Old_Node) then 10927 return Assoc (Old_Node); 10928 10929 else 10930 New_Node := New_Copy (Old_Node); 10931 10932 -- If the node we are copying is the associated node of a 10933 -- previously copied Itype, then adjust the associated node 10934 -- of the copy of that Itype accordingly. 10935 10936 if Present (Actual_Map) then 10937 declare 10938 E : Elmt_Id; 10939 Ent : Entity_Id; 10940 10941 begin 10942 -- Case of hash table used 10943 10944 if NCT_Hash_Tables_Used then 10945 Ent := NCT_Itype_Assoc.Get (Old_Node); 10946 10947 if Present (Ent) then 10948 Set_Associated_Node_For_Itype (Ent, New_Node); 10949 end if; 10950 10951 -- Case of no hash table used 10952 10953 else 10954 E := First_Elmt (Actual_Map); 10955 while Present (E) loop 10956 if Is_Itype (Node (E)) 10957 and then 10958 Old_Node = Associated_Node_For_Itype (Node (E)) 10959 then 10960 Set_Associated_Node_For_Itype 10961 (Node (Next_Elmt (E)), New_Node); 10962 end if; 10963 10964 E := Next_Elmt (Next_Elmt (E)); 10965 end loop; 10966 end if; 10967 end; 10968 end if; 10969 10970 -- Recursively copy descendents 10971 10972 Set_Field1 10973 (New_Node, Copy_Field_With_Replacement (Field1 (New_Node))); 10974 Set_Field2 10975 (New_Node, Copy_Field_With_Replacement (Field2 (New_Node))); 10976 Set_Field3 10977 (New_Node, Copy_Field_With_Replacement (Field3 (New_Node))); 10978 Set_Field4 10979 (New_Node, Copy_Field_With_Replacement (Field4 (New_Node))); 10980 Set_Field5 10981 (New_Node, Copy_Field_With_Replacement (Field5 (New_Node))); 10982 10983 -- Adjust Sloc of new node if necessary 10984 10985 if New_Sloc /= No_Location then 10986 Set_Sloc (New_Node, New_Sloc); 10987 10988 -- If we adjust the Sloc, then we are essentially making 10989 -- a completely new node, so the Comes_From_Source flag 10990 -- should be reset to the proper default value. 10991 10992 Nodes.Table (New_Node).Comes_From_Source := 10993 Default_Node.Comes_From_Source; 10994 end if; 10995 10996 -- If the node is call and has named associations, 10997 -- set the corresponding links in the copy. 10998 10999 if (Nkind (Old_Node) = N_Function_Call 11000 or else Nkind (Old_Node) = N_Entry_Call_Statement 11001 or else 11002 Nkind (Old_Node) = N_Procedure_Call_Statement) 11003 and then Present (First_Named_Actual (Old_Node)) 11004 then 11005 Adjust_Named_Associations (Old_Node, New_Node); 11006 end if; 11007 11008 -- Reset First_Real_Statement for Handled_Sequence_Of_Statements. 11009 -- The replacement mechanism applies to entities, and is not used 11010 -- here. Eventually we may need a more general graph-copying 11011 -- routine. For now, do a sequential search to find desired node. 11012 11013 if Nkind (Old_Node) = N_Handled_Sequence_Of_Statements 11014 and then Present (First_Real_Statement (Old_Node)) 11015 then 11016 declare 11017 Old_F : constant Node_Id := First_Real_Statement (Old_Node); 11018 N1, N2 : Node_Id; 11019 11020 begin 11021 N1 := First (Statements (Old_Node)); 11022 N2 := First (Statements (New_Node)); 11023 11024 while N1 /= Old_F loop 11025 Next (N1); 11026 Next (N2); 11027 end loop; 11028 11029 Set_First_Real_Statement (New_Node, N2); 11030 end; 11031 end if; 11032 end if; 11033 11034 -- All done, return copied node 11035 11036 return New_Node; 11037 end Copy_Node_With_Replacement; 11038 11039 ----------------- 11040 -- Visit_Elist -- 11041 ----------------- 11042 11043 procedure Visit_Elist (E : Elist_Id) is 11044 Elmt : Elmt_Id; 11045 begin 11046 if Present (E) then 11047 Elmt := First_Elmt (E); 11048 11049 while Elmt /= No_Elmt loop 11050 Visit_Node (Node (Elmt)); 11051 Next_Elmt (Elmt); 11052 end loop; 11053 end if; 11054 end Visit_Elist; 11055 11056 ----------------- 11057 -- Visit_Field -- 11058 ----------------- 11059 11060 procedure Visit_Field (F : Union_Id; N : Node_Id) is 11061 begin 11062 if F = Union_Id (Empty) then 11063 return; 11064 11065 elsif F in Node_Range then 11066 11067 -- Copy node if it is syntactic, i.e. its parent pointer is 11068 -- set to point to the field that referenced it (certain 11069 -- Itypes will also meet this criterion, which is fine, since 11070 -- these are clearly Itypes that do need to be copied, since 11071 -- we are copying their parent.) 11072 11073 if Parent (Node_Id (F)) = N then 11074 Visit_Node (Node_Id (F)); 11075 return; 11076 11077 -- Another case, if we are pointing to an Itype, then we want 11078 -- to copy it if its associated node is somewhere in the tree 11079 -- being copied. 11080 11081 -- Note: the exclusion of self-referential copies is just an 11082 -- optimization, since the search of the already copied list 11083 -- would catch it, but it is a common case (Etype pointing 11084 -- to itself for an Itype that is a base type). 11085 11086 elsif Has_Extension (Node_Id (F)) 11087 and then Is_Itype (Entity_Id (F)) 11088 and then Node_Id (F) /= N 11089 then 11090 declare 11091 P : Node_Id; 11092 11093 begin 11094 P := Associated_Node_For_Itype (Node_Id (F)); 11095 while Present (P) loop 11096 if P = Source then 11097 Visit_Node (Node_Id (F)); 11098 return; 11099 else 11100 P := Parent (P); 11101 end if; 11102 end loop; 11103 11104 -- An Itype whose parent is not being copied definitely 11105 -- should NOT be copied, since it does not belong in any 11106 -- sense to the copied subtree. 11107 11108 return; 11109 end; 11110 end if; 11111 11112 elsif F in List_Range 11113 and then Parent (List_Id (F)) = N 11114 then 11115 Visit_List (List_Id (F)); 11116 return; 11117 end if; 11118 end Visit_Field; 11119 11120 ----------------- 11121 -- Visit_Itype -- 11122 ----------------- 11123 11124 procedure Visit_Itype (Old_Itype : Entity_Id) is 11125 New_Itype : Entity_Id; 11126 E : Elmt_Id; 11127 Ent : Entity_Id; 11128 11129 begin 11130 -- Itypes that describe the designated type of access to subprograms 11131 -- have the structure of subprogram declarations, with signatures, 11132 -- etc. Either we duplicate the signatures completely, or choose to 11133 -- share such itypes, which is fine because their elaboration will 11134 -- have no side effects. 11135 11136 if Ekind (Old_Itype) = E_Subprogram_Type then 11137 return; 11138 end if; 11139 11140 New_Itype := New_Copy (Old_Itype); 11141 11142 -- The new Itype has all the attributes of the old one, and 11143 -- we just copy the contents of the entity. However, the back-end 11144 -- needs different names for debugging purposes, so we create a 11145 -- new internal name for it in all cases. 11146 11147 Set_Chars (New_Itype, New_Internal_Name ('T')); 11148 11149 -- If our associated node is an entity that has already been copied, 11150 -- then set the associated node of the copy to point to the right 11151 -- copy. If we have copied an Itype that is itself the associated 11152 -- node of some previously copied Itype, then we set the right 11153 -- pointer in the other direction. 11154 11155 if Present (Actual_Map) then 11156 11157 -- Case of hash tables used 11158 11159 if NCT_Hash_Tables_Used then 11160 11161 Ent := NCT_Assoc.Get (Associated_Node_For_Itype (Old_Itype)); 11162 11163 if Present (Ent) then 11164 Set_Associated_Node_For_Itype (New_Itype, Ent); 11165 end if; 11166 11167 Ent := NCT_Itype_Assoc.Get (Old_Itype); 11168 if Present (Ent) then 11169 Set_Associated_Node_For_Itype (Ent, New_Itype); 11170 11171 -- If the hash table has no association for this Itype and 11172 -- its associated node, enter one now. 11173 11174 else 11175 NCT_Itype_Assoc.Set 11176 (Associated_Node_For_Itype (Old_Itype), New_Itype); 11177 end if; 11178 11179 -- Case of hash tables not used 11180 11181 else 11182 E := First_Elmt (Actual_Map); 11183 while Present (E) loop 11184 if Associated_Node_For_Itype (Old_Itype) = Node (E) then 11185 Set_Associated_Node_For_Itype 11186 (New_Itype, Node (Next_Elmt (E))); 11187 end if; 11188 11189 if Is_Type (Node (E)) 11190 and then 11191 Old_Itype = Associated_Node_For_Itype (Node (E)) 11192 then 11193 Set_Associated_Node_For_Itype 11194 (Node (Next_Elmt (E)), New_Itype); 11195 end if; 11196 11197 E := Next_Elmt (Next_Elmt (E)); 11198 end loop; 11199 end if; 11200 end if; 11201 11202 if Present (Freeze_Node (New_Itype)) then 11203 Set_Is_Frozen (New_Itype, False); 11204 Set_Freeze_Node (New_Itype, Empty); 11205 end if; 11206 11207 -- Add new association to map 11208 11209 if No (Actual_Map) then 11210 Actual_Map := New_Elmt_List; 11211 end if; 11212 11213 Append_Elmt (Old_Itype, Actual_Map); 11214 Append_Elmt (New_Itype, Actual_Map); 11215 11216 if NCT_Hash_Tables_Used then 11217 NCT_Assoc.Set (Old_Itype, New_Itype); 11218 11219 else 11220 NCT_Table_Entries := NCT_Table_Entries + 1; 11221 11222 if NCT_Table_Entries > NCT_Hash_Threshold then 11223 Build_NCT_Hash_Tables; 11224 end if; 11225 end if; 11226 11227 -- If a record subtype is simply copied, the entity list will be 11228 -- shared. Thus cloned_Subtype must be set to indicate the sharing. 11229 11230 if Ekind_In (Old_Itype, E_Record_Subtype, E_Class_Wide_Subtype) then 11231 Set_Cloned_Subtype (New_Itype, Old_Itype); 11232 end if; 11233 11234 -- Visit descendents that eventually get copied 11235 11236 Visit_Field (Union_Id (Etype (Old_Itype)), Old_Itype); 11237 11238 if Is_Discrete_Type (Old_Itype) then 11239 Visit_Field (Union_Id (Scalar_Range (Old_Itype)), Old_Itype); 11240 11241 elsif Has_Discriminants (Base_Type (Old_Itype)) then 11242 -- ??? This should involve call to Visit_Field 11243 Visit_Elist (Discriminant_Constraint (Old_Itype)); 11244 11245 elsif Is_Array_Type (Old_Itype) then 11246 if Present (First_Index (Old_Itype)) then 11247 Visit_Field (Union_Id (List_Containing 11248 (First_Index (Old_Itype))), 11249 Old_Itype); 11250 end if; 11251 11252 if Is_Packed (Old_Itype) then 11253 Visit_Field (Union_Id (Packed_Array_Type (Old_Itype)), 11254 Old_Itype); 11255 end if; 11256 end if; 11257 end Visit_Itype; 11258 11259 ---------------- 11260 -- Visit_List -- 11261 ---------------- 11262 11263 procedure Visit_List (L : List_Id) is 11264 N : Node_Id; 11265 begin 11266 if L /= No_List then 11267 N := First (L); 11268 11269 while Present (N) loop 11270 Visit_Node (N); 11271 Next (N); 11272 end loop; 11273 end if; 11274 end Visit_List; 11275 11276 ---------------- 11277 -- Visit_Node -- 11278 ---------------- 11279 11280 procedure Visit_Node (N : Node_Or_Entity_Id) is 11281 11282 -- Start of processing for Visit_Node 11283 11284 begin 11285 -- Handle case of an Itype, which must be copied 11286 11287 if Has_Extension (N) 11288 and then Is_Itype (N) 11289 then 11290 -- Nothing to do if already in the list. This can happen with an 11291 -- Itype entity that appears more than once in the tree. 11292 -- Note that we do not want to visit descendents in this case. 11293 11294 -- Test for already in list when hash table is used 11295 11296 if NCT_Hash_Tables_Used then 11297 if Present (NCT_Assoc.Get (Entity_Id (N))) then 11298 return; 11299 end if; 11300 11301 -- Test for already in list when hash table not used 11302 11303 else 11304 declare 11305 E : Elmt_Id; 11306 begin 11307 if Present (Actual_Map) then 11308 E := First_Elmt (Actual_Map); 11309 while Present (E) loop 11310 if Node (E) = N then 11311 return; 11312 else 11313 E := Next_Elmt (Next_Elmt (E)); 11314 end if; 11315 end loop; 11316 end if; 11317 end; 11318 end if; 11319 11320 Visit_Itype (N); 11321 end if; 11322 11323 -- Visit descendents 11324 11325 Visit_Field (Field1 (N), N); 11326 Visit_Field (Field2 (N), N); 11327 Visit_Field (Field3 (N), N); 11328 Visit_Field (Field4 (N), N); 11329 Visit_Field (Field5 (N), N); 11330 end Visit_Node; 11331 11332 -- Start of processing for New_Copy_Tree 11333 11334 begin 11335 Actual_Map := Map; 11336 11337 -- See if we should use hash table 11338 11339 if No (Actual_Map) then 11340 NCT_Hash_Tables_Used := False; 11341 11342 else 11343 declare 11344 Elmt : Elmt_Id; 11345 11346 begin 11347 NCT_Table_Entries := 0; 11348 11349 Elmt := First_Elmt (Actual_Map); 11350 while Present (Elmt) loop 11351 NCT_Table_Entries := NCT_Table_Entries + 1; 11352 Next_Elmt (Elmt); 11353 Next_Elmt (Elmt); 11354 end loop; 11355 11356 if NCT_Table_Entries > NCT_Hash_Threshold then 11357 Build_NCT_Hash_Tables; 11358 else 11359 NCT_Hash_Tables_Used := False; 11360 end if; 11361 end; 11362 end if; 11363 11364 -- Hash table set up if required, now start phase one by visiting 11365 -- top node (we will recursively visit the descendents). 11366 11367 Visit_Node (Source); 11368 11369 -- Now the second phase of the copy can start. First we process 11370 -- all the mapped entities, copying their descendents. 11371 11372 if Present (Actual_Map) then 11373 declare 11374 Elmt : Elmt_Id; 11375 New_Itype : Entity_Id; 11376 begin 11377 Elmt := First_Elmt (Actual_Map); 11378 while Present (Elmt) loop 11379 Next_Elmt (Elmt); 11380 New_Itype := Node (Elmt); 11381 Copy_Itype_With_Replacement (New_Itype); 11382 Next_Elmt (Elmt); 11383 end loop; 11384 end; 11385 end if; 11386 11387 -- Now we can copy the actual tree 11388 11389 return Copy_Node_With_Replacement (Source); 11390 end New_Copy_Tree; 11391 11392 ------------------------- 11393 -- New_External_Entity -- 11394 ------------------------- 11395 11396 function New_External_Entity 11397 (Kind : Entity_Kind; 11398 Scope_Id : Entity_Id; 11399 Sloc_Value : Source_Ptr; 11400 Related_Id : Entity_Id; 11401 Suffix : Character; 11402 Suffix_Index : Nat := 0; 11403 Prefix : Character := ' ') return Entity_Id 11404 is 11405 N : constant Entity_Id := 11406 Make_Defining_Identifier (Sloc_Value, 11407 New_External_Name 11408 (Chars (Related_Id), Suffix, Suffix_Index, Prefix)); 11409 11410 begin 11411 Set_Ekind (N, Kind); 11412 Set_Is_Internal (N, True); 11413 Append_Entity (N, Scope_Id); 11414 Set_Public_Status (N); 11415 11416 if Kind in Type_Kind then 11417 Init_Size_Align (N); 11418 end if; 11419 11420 return N; 11421 end New_External_Entity; 11422 11423 ------------------------- 11424 -- New_Internal_Entity -- 11425 ------------------------- 11426 11427 function New_Internal_Entity 11428 (Kind : Entity_Kind; 11429 Scope_Id : Entity_Id; 11430 Sloc_Value : Source_Ptr; 11431 Id_Char : Character) return Entity_Id 11432 is 11433 N : constant Entity_Id := Make_Temporary (Sloc_Value, Id_Char); 11434 11435 begin 11436 Set_Ekind (N, Kind); 11437 Set_Is_Internal (N, True); 11438 Append_Entity (N, Scope_Id); 11439 11440 if Kind in Type_Kind then 11441 Init_Size_Align (N); 11442 end if; 11443 11444 return N; 11445 end New_Internal_Entity; 11446 11447 ----------------- 11448 -- Next_Actual -- 11449 ----------------- 11450 11451 function Next_Actual (Actual_Id : Node_Id) return Node_Id is 11452 N : Node_Id; 11453 11454 begin 11455 -- If we are pointing at a positional parameter, it is a member of a 11456 -- node list (the list of parameters), and the next parameter is the 11457 -- next node on the list, unless we hit a parameter association, then 11458 -- we shift to using the chain whose head is the First_Named_Actual in 11459 -- the parent, and then is threaded using the Next_Named_Actual of the 11460 -- Parameter_Association. All this fiddling is because the original node 11461 -- list is in the textual call order, and what we need is the 11462 -- declaration order. 11463 11464 if Is_List_Member (Actual_Id) then 11465 N := Next (Actual_Id); 11466 11467 if Nkind (N) = N_Parameter_Association then 11468 return First_Named_Actual (Parent (Actual_Id)); 11469 else 11470 return N; 11471 end if; 11472 11473 else 11474 return Next_Named_Actual (Parent (Actual_Id)); 11475 end if; 11476 end Next_Actual; 11477 11478 procedure Next_Actual (Actual_Id : in out Node_Id) is 11479 begin 11480 Actual_Id := Next_Actual (Actual_Id); 11481 end Next_Actual; 11482 11483 --------------------- 11484 -- No_Scalar_Parts -- 11485 --------------------- 11486 11487 function No_Scalar_Parts (T : Entity_Id) return Boolean is 11488 C : Entity_Id; 11489 11490 begin 11491 if Is_Scalar_Type (T) then 11492 return False; 11493 11494 elsif Is_Array_Type (T) then 11495 return No_Scalar_Parts (Component_Type (T)); 11496 11497 elsif Is_Record_Type (T) or else Has_Discriminants (T) then 11498 C := First_Component_Or_Discriminant (T); 11499 while Present (C) loop 11500 if not No_Scalar_Parts (Etype (C)) then 11501 return False; 11502 else 11503 Next_Component_Or_Discriminant (C); 11504 end if; 11505 end loop; 11506 end if; 11507 11508 return True; 11509 end No_Scalar_Parts; 11510 11511 ----------------------- 11512 -- Normalize_Actuals -- 11513 ----------------------- 11514 11515 -- Chain actuals according to formals of subprogram. If there are no named 11516 -- associations, the chain is simply the list of Parameter Associations, 11517 -- since the order is the same as the declaration order. If there are named 11518 -- associations, then the First_Named_Actual field in the N_Function_Call 11519 -- or N_Procedure_Call_Statement node points to the Parameter_Association 11520 -- node for the parameter that comes first in declaration order. The 11521 -- remaining named parameters are then chained in declaration order using 11522 -- Next_Named_Actual. 11523 11524 -- This routine also verifies that the number of actuals is compatible with 11525 -- the number and default values of formals, but performs no type checking 11526 -- (type checking is done by the caller). 11527 11528 -- If the matching succeeds, Success is set to True and the caller proceeds 11529 -- with type-checking. If the match is unsuccessful, then Success is set to 11530 -- False, and the caller attempts a different interpretation, if there is 11531 -- one. 11532 11533 -- If the flag Report is on, the call is not overloaded, and a failure to 11534 -- match can be reported here, rather than in the caller. 11535 11536 procedure Normalize_Actuals 11537 (N : Node_Id; 11538 S : Entity_Id; 11539 Report : Boolean; 11540 Success : out Boolean) 11541 is 11542 Actuals : constant List_Id := Parameter_Associations (N); 11543 Actual : Node_Id := Empty; 11544 Formal : Entity_Id; 11545 Last : Node_Id := Empty; 11546 First_Named : Node_Id := Empty; 11547 Found : Boolean; 11548 11549 Formals_To_Match : Integer := 0; 11550 Actuals_To_Match : Integer := 0; 11551 11552 procedure Chain (A : Node_Id); 11553 -- Add named actual at the proper place in the list, using the 11554 -- Next_Named_Actual link. 11555 11556 function Reporting return Boolean; 11557 -- Determines if an error is to be reported. To report an error, we 11558 -- need Report to be True, and also we do not report errors caused 11559 -- by calls to init procs that occur within other init procs. Such 11560 -- errors must always be cascaded errors, since if all the types are 11561 -- declared correctly, the compiler will certainly build decent calls! 11562 11563 ----------- 11564 -- Chain -- 11565 ----------- 11566 11567 procedure Chain (A : Node_Id) is 11568 begin 11569 if No (Last) then 11570 11571 -- Call node points to first actual in list 11572 11573 Set_First_Named_Actual (N, Explicit_Actual_Parameter (A)); 11574 11575 else 11576 Set_Next_Named_Actual (Last, Explicit_Actual_Parameter (A)); 11577 end if; 11578 11579 Last := A; 11580 Set_Next_Named_Actual (Last, Empty); 11581 end Chain; 11582 11583 --------------- 11584 -- Reporting -- 11585 --------------- 11586 11587 function Reporting return Boolean is 11588 begin 11589 if not Report then 11590 return False; 11591 11592 elsif not Within_Init_Proc then 11593 return True; 11594 11595 elsif Is_Init_Proc (Entity (Name (N))) then 11596 return False; 11597 11598 else 11599 return True; 11600 end if; 11601 end Reporting; 11602 11603 -- Start of processing for Normalize_Actuals 11604 11605 begin 11606 if Is_Access_Type (S) then 11607 11608 -- The name in the call is a function call that returns an access 11609 -- to subprogram. The designated type has the list of formals. 11610 11611 Formal := First_Formal (Designated_Type (S)); 11612 else 11613 Formal := First_Formal (S); 11614 end if; 11615 11616 while Present (Formal) loop 11617 Formals_To_Match := Formals_To_Match + 1; 11618 Next_Formal (Formal); 11619 end loop; 11620 11621 -- Find if there is a named association, and verify that no positional 11622 -- associations appear after named ones. 11623 11624 if Present (Actuals) then 11625 Actual := First (Actuals); 11626 end if; 11627 11628 while Present (Actual) 11629 and then Nkind (Actual) /= N_Parameter_Association 11630 loop 11631 Actuals_To_Match := Actuals_To_Match + 1; 11632 Next (Actual); 11633 end loop; 11634 11635 if No (Actual) and Actuals_To_Match = Formals_To_Match then 11636 11637 -- Most common case: positional notation, no defaults 11638 11639 Success := True; 11640 return; 11641 11642 elsif Actuals_To_Match > Formals_To_Match then 11643 11644 -- Too many actuals: will not work 11645 11646 if Reporting then 11647 if Is_Entity_Name (Name (N)) then 11648 Error_Msg_N ("too many arguments in call to&", Name (N)); 11649 else 11650 Error_Msg_N ("too many arguments in call", N); 11651 end if; 11652 end if; 11653 11654 Success := False; 11655 return; 11656 end if; 11657 11658 First_Named := Actual; 11659 11660 while Present (Actual) loop 11661 if Nkind (Actual) /= N_Parameter_Association then 11662 Error_Msg_N 11663 ("positional parameters not allowed after named ones", Actual); 11664 Success := False; 11665 return; 11666 11667 else 11668 Actuals_To_Match := Actuals_To_Match + 1; 11669 end if; 11670 11671 Next (Actual); 11672 end loop; 11673 11674 if Present (Actuals) then 11675 Actual := First (Actuals); 11676 end if; 11677 11678 Formal := First_Formal (S); 11679 while Present (Formal) loop 11680 11681 -- Match the formals in order. If the corresponding actual is 11682 -- positional, nothing to do. Else scan the list of named actuals 11683 -- to find the one with the right name. 11684 11685 if Present (Actual) 11686 and then Nkind (Actual) /= N_Parameter_Association 11687 then 11688 Next (Actual); 11689 Actuals_To_Match := Actuals_To_Match - 1; 11690 Formals_To_Match := Formals_To_Match - 1; 11691 11692 else 11693 -- For named parameters, search the list of actuals to find 11694 -- one that matches the next formal name. 11695 11696 Actual := First_Named; 11697 Found := False; 11698 while Present (Actual) loop 11699 if Chars (Selector_Name (Actual)) = Chars (Formal) then 11700 Found := True; 11701 Chain (Actual); 11702 Actuals_To_Match := Actuals_To_Match - 1; 11703 Formals_To_Match := Formals_To_Match - 1; 11704 exit; 11705 end if; 11706 11707 Next (Actual); 11708 end loop; 11709 11710 if not Found then 11711 if Ekind (Formal) /= E_In_Parameter 11712 or else No (Default_Value (Formal)) 11713 then 11714 if Reporting then 11715 if (Comes_From_Source (S) 11716 or else Sloc (S) = Standard_Location) 11717 and then Is_Overloadable (S) 11718 then 11719 if No (Actuals) 11720 and then 11721 (Nkind (Parent (N)) = N_Procedure_Call_Statement 11722 or else 11723 (Nkind (Parent (N)) = N_Function_Call 11724 or else 11725 Nkind (Parent (N)) = N_Parameter_Association)) 11726 and then Ekind (S) /= E_Function 11727 then 11728 Set_Etype (N, Etype (S)); 11729 else 11730 Error_Msg_Name_1 := Chars (S); 11731 Error_Msg_Sloc := Sloc (S); 11732 Error_Msg_NE 11733 ("missing argument for parameter & " & 11734 "in call to % declared #", N, Formal); 11735 end if; 11736 11737 elsif Is_Overloadable (S) then 11738 Error_Msg_Name_1 := Chars (S); 11739 11740 -- Point to type derivation that generated the 11741 -- operation. 11742 11743 Error_Msg_Sloc := Sloc (Parent (S)); 11744 11745 Error_Msg_NE 11746 ("missing argument for parameter & " & 11747 "in call to % (inherited) #", N, Formal); 11748 11749 else 11750 Error_Msg_NE 11751 ("missing argument for parameter &", N, Formal); 11752 end if; 11753 end if; 11754 11755 Success := False; 11756 return; 11757 11758 else 11759 Formals_To_Match := Formals_To_Match - 1; 11760 end if; 11761 end if; 11762 end if; 11763 11764 Next_Formal (Formal); 11765 end loop; 11766 11767 if Formals_To_Match = 0 and then Actuals_To_Match = 0 then 11768 Success := True; 11769 return; 11770 11771 else 11772 if Reporting then 11773 11774 -- Find some superfluous named actual that did not get 11775 -- attached to the list of associations. 11776 11777 Actual := First (Actuals); 11778 while Present (Actual) loop 11779 if Nkind (Actual) = N_Parameter_Association 11780 and then Actual /= Last 11781 and then No (Next_Named_Actual (Actual)) 11782 then 11783 Error_Msg_N ("unmatched actual & in call", 11784 Selector_Name (Actual)); 11785 exit; 11786 end if; 11787 11788 Next (Actual); 11789 end loop; 11790 end if; 11791 11792 Success := False; 11793 return; 11794 end if; 11795 end Normalize_Actuals; 11796 11797 -------------------------------- 11798 -- Note_Possible_Modification -- 11799 -------------------------------- 11800 11801 procedure Note_Possible_Modification (N : Node_Id; Sure : Boolean) is 11802 Modification_Comes_From_Source : constant Boolean := 11803 Comes_From_Source (Parent (N)); 11804 11805 Ent : Entity_Id; 11806 Exp : Node_Id; 11807 11808 begin 11809 -- Loop to find referenced entity, if there is one 11810 11811 Exp := N; 11812 loop 11813 <<Continue>> 11814 Ent := Empty; 11815 11816 if Is_Entity_Name (Exp) then 11817 Ent := Entity (Exp); 11818 11819 -- If the entity is missing, it is an undeclared identifier, 11820 -- and there is nothing to annotate. 11821 11822 if No (Ent) then 11823 return; 11824 end if; 11825 11826 elsif Nkind (Exp) = N_Explicit_Dereference then 11827 declare 11828 P : constant Node_Id := Prefix (Exp); 11829 11830 begin 11831 -- In formal verification mode, keep track of all reads and 11832 -- writes through explicit dereferences. 11833 11834 if Alfa_Mode then 11835 Alfa.Generate_Dereference (N, 'm'); 11836 end if; 11837 11838 if Nkind (P) = N_Selected_Component 11839 and then Present ( 11840 Entry_Formal (Entity (Selector_Name (P)))) 11841 then 11842 -- Case of a reference to an entry formal 11843 11844 Ent := Entry_Formal (Entity (Selector_Name (P))); 11845 11846 elsif Nkind (P) = N_Identifier 11847 and then Nkind (Parent (Entity (P))) = N_Object_Declaration 11848 and then Present (Expression (Parent (Entity (P)))) 11849 and then Nkind (Expression (Parent (Entity (P)))) 11850 = N_Reference 11851 then 11852 -- Case of a reference to a value on which side effects have 11853 -- been removed. 11854 11855 Exp := Prefix (Expression (Parent (Entity (P)))); 11856 goto Continue; 11857 11858 else 11859 return; 11860 11861 end if; 11862 end; 11863 11864 elsif Nkind (Exp) = N_Type_Conversion 11865 or else Nkind (Exp) = N_Unchecked_Type_Conversion 11866 then 11867 Exp := Expression (Exp); 11868 goto Continue; 11869 11870 elsif Nkind (Exp) = N_Slice 11871 or else Nkind (Exp) = N_Indexed_Component 11872 or else Nkind (Exp) = N_Selected_Component 11873 then 11874 Exp := Prefix (Exp); 11875 goto Continue; 11876 11877 else 11878 return; 11879 end if; 11880 11881 -- Now look for entity being referenced 11882 11883 if Present (Ent) then 11884 if Is_Object (Ent) then 11885 if Comes_From_Source (Exp) 11886 or else Modification_Comes_From_Source 11887 then 11888 -- Give warning if pragma unmodified given and we are 11889 -- sure this is a modification. 11890 11891 if Has_Pragma_Unmodified (Ent) and then Sure then 11892 Error_Msg_NE 11893 ("??pragma Unmodified given for &!", N, Ent); 11894 end if; 11895 11896 Set_Never_Set_In_Source (Ent, False); 11897 end if; 11898 11899 Set_Is_True_Constant (Ent, False); 11900 Set_Current_Value (Ent, Empty); 11901 Set_Is_Known_Null (Ent, False); 11902 11903 if not Can_Never_Be_Null (Ent) then 11904 Set_Is_Known_Non_Null (Ent, False); 11905 end if; 11906 11907 -- Follow renaming chain 11908 11909 if (Ekind (Ent) = E_Variable or else Ekind (Ent) = E_Constant) 11910 and then Present (Renamed_Object (Ent)) 11911 then 11912 Exp := Renamed_Object (Ent); 11913 goto Continue; 11914 11915 -- The expression may be the renaming of a subcomponent of an 11916 -- array or container. The assignment to the subcomponent is 11917 -- a modification of the container. 11918 11919 elsif Comes_From_Source (Original_Node (Exp)) 11920 and then Nkind_In (Original_Node (Exp), N_Selected_Component, 11921 N_Indexed_Component) 11922 then 11923 Exp := Prefix (Original_Node (Exp)); 11924 goto Continue; 11925 end if; 11926 11927 -- Generate a reference only if the assignment comes from 11928 -- source. This excludes, for example, calls to a dispatching 11929 -- assignment operation when the left-hand side is tagged. 11930 11931 if Modification_Comes_From_Source or else Alfa_Mode then 11932 Generate_Reference (Ent, Exp, 'm'); 11933 11934 -- If the target of the assignment is the bound variable 11935 -- in an iterator, indicate that the corresponding array 11936 -- or container is also modified. 11937 11938 if Ada_Version >= Ada_2012 11939 and then 11940 Nkind (Parent (Ent)) = N_Iterator_Specification 11941 then 11942 declare 11943 Domain : constant Node_Id := Name (Parent (Ent)); 11944 11945 begin 11946 -- TBD : in the full version of the construct, the 11947 -- domain of iteration can be given by an expression. 11948 11949 if Is_Entity_Name (Domain) then 11950 Generate_Reference (Entity (Domain), Exp, 'm'); 11951 Set_Is_True_Constant (Entity (Domain), False); 11952 Set_Never_Set_In_Source (Entity (Domain), False); 11953 end if; 11954 end; 11955 end if; 11956 end if; 11957 11958 Check_Nested_Access (Ent); 11959 end if; 11960 11961 Kill_Checks (Ent); 11962 11963 -- If we are sure this is a modification from source, and we know 11964 -- this modifies a constant, then give an appropriate warning. 11965 11966 if Overlays_Constant (Ent) 11967 and then Modification_Comes_From_Source 11968 and then Sure 11969 then 11970 declare 11971 A : constant Node_Id := Address_Clause (Ent); 11972 begin 11973 if Present (A) then 11974 declare 11975 Exp : constant Node_Id := Expression (A); 11976 begin 11977 if Nkind (Exp) = N_Attribute_Reference 11978 and then Attribute_Name (Exp) = Name_Address 11979 and then Is_Entity_Name (Prefix (Exp)) 11980 then 11981 Error_Msg_Sloc := Sloc (A); 11982 Error_Msg_NE 11983 ("constant& may be modified via address " 11984 & "clause#??", N, Entity (Prefix (Exp))); 11985 end if; 11986 end; 11987 end if; 11988 end; 11989 end if; 11990 11991 return; 11992 end if; 11993 end loop; 11994 end Note_Possible_Modification; 11995 11996 ------------------------- 11997 -- Object_Access_Level -- 11998 ------------------------- 11999 12000 -- Returns the static accessibility level of the view denoted by Obj. Note 12001 -- that the value returned is the result of a call to Scope_Depth. Only 12002 -- scope depths associated with dynamic scopes can actually be returned. 12003 -- Since only relative levels matter for accessibility checking, the fact 12004 -- that the distance between successive levels of accessibility is not 12005 -- always one is immaterial (invariant: if level(E2) is deeper than 12006 -- level(E1), then Scope_Depth(E1) < Scope_Depth(E2)). 12007 12008 function Object_Access_Level (Obj : Node_Id) return Uint is 12009 function Is_Interface_Conversion (N : Node_Id) return Boolean; 12010 -- Determine whether N is a construct of the form 12011 -- Some_Type (Operand._tag'Address) 12012 -- This construct appears in the context of dispatching calls 12013 12014 function Reference_To (Obj : Node_Id) return Node_Id; 12015 -- An explicit dereference is created when removing side-effects from 12016 -- expressions for constraint checking purposes. In this case a local 12017 -- access type is created for it. The correct access level is that of 12018 -- the original source node. We detect this case by noting that the 12019 -- prefix of the dereference is created by an object declaration whose 12020 -- initial expression is a reference. 12021 12022 ----------------------------- 12023 -- Is_Interface_Conversion -- 12024 ----------------------------- 12025 12026 function Is_Interface_Conversion (N : Node_Id) return Boolean is 12027 begin 12028 return 12029 Nkind (N) = N_Unchecked_Type_Conversion 12030 and then Nkind (Expression (N)) = N_Attribute_Reference 12031 and then Attribute_Name (Expression (N)) = Name_Address; 12032 end Is_Interface_Conversion; 12033 12034 ------------------ 12035 -- Reference_To -- 12036 ------------------ 12037 12038 function Reference_To (Obj : Node_Id) return Node_Id is 12039 Pref : constant Node_Id := Prefix (Obj); 12040 begin 12041 if Is_Entity_Name (Pref) 12042 and then Nkind (Parent (Entity (Pref))) = N_Object_Declaration 12043 and then Present (Expression (Parent (Entity (Pref)))) 12044 and then Nkind (Expression (Parent (Entity (Pref)))) = N_Reference 12045 then 12046 return (Prefix (Expression (Parent (Entity (Pref))))); 12047 else 12048 return Empty; 12049 end if; 12050 end Reference_To; 12051 12052 -- Local variables 12053 12054 E : Entity_Id; 12055 12056 -- Start of processing for Object_Access_Level 12057 12058 begin 12059 if Nkind (Obj) = N_Defining_Identifier 12060 or else Is_Entity_Name (Obj) 12061 then 12062 if Nkind (Obj) = N_Defining_Identifier then 12063 E := Obj; 12064 else 12065 E := Entity (Obj); 12066 end if; 12067 12068 if Is_Prival (E) then 12069 E := Prival_Link (E); 12070 end if; 12071 12072 -- If E is a type then it denotes a current instance. For this case 12073 -- we add one to the normal accessibility level of the type to ensure 12074 -- that current instances are treated as always being deeper than 12075 -- than the level of any visible named access type (see 3.10.2(21)). 12076 12077 if Is_Type (E) then 12078 return Type_Access_Level (E) + 1; 12079 12080 elsif Present (Renamed_Object (E)) then 12081 return Object_Access_Level (Renamed_Object (E)); 12082 12083 -- Similarly, if E is a component of the current instance of a 12084 -- protected type, any instance of it is assumed to be at a deeper 12085 -- level than the type. For a protected object (whose type is an 12086 -- anonymous protected type) its components are at the same level 12087 -- as the type itself. 12088 12089 elsif not Is_Overloadable (E) 12090 and then Ekind (Scope (E)) = E_Protected_Type 12091 and then Comes_From_Source (Scope (E)) 12092 then 12093 return Type_Access_Level (Scope (E)) + 1; 12094 12095 else 12096 return Scope_Depth (Enclosing_Dynamic_Scope (E)); 12097 end if; 12098 12099 elsif Nkind (Obj) = N_Selected_Component then 12100 if Is_Access_Type (Etype (Prefix (Obj))) then 12101 return Type_Access_Level (Etype (Prefix (Obj))); 12102 else 12103 return Object_Access_Level (Prefix (Obj)); 12104 end if; 12105 12106 elsif Nkind (Obj) = N_Indexed_Component then 12107 if Is_Access_Type (Etype (Prefix (Obj))) then 12108 return Type_Access_Level (Etype (Prefix (Obj))); 12109 else 12110 return Object_Access_Level (Prefix (Obj)); 12111 end if; 12112 12113 elsif Nkind (Obj) = N_Explicit_Dereference then 12114 12115 -- If the prefix is a selected access discriminant then we make a 12116 -- recursive call on the prefix, which will in turn check the level 12117 -- of the prefix object of the selected discriminant. 12118 12119 if Nkind (Prefix (Obj)) = N_Selected_Component 12120 and then Ekind (Etype (Prefix (Obj))) = E_Anonymous_Access_Type 12121 and then 12122 Ekind (Entity (Selector_Name (Prefix (Obj)))) = E_Discriminant 12123 then 12124 return Object_Access_Level (Prefix (Obj)); 12125 12126 -- Detect an interface conversion in the context of a dispatching 12127 -- call. Use the original form of the conversion to find the access 12128 -- level of the operand. 12129 12130 elsif Is_Interface (Etype (Obj)) 12131 and then Is_Interface_Conversion (Prefix (Obj)) 12132 and then Nkind (Original_Node (Obj)) = N_Type_Conversion 12133 then 12134 return Object_Access_Level (Original_Node (Obj)); 12135 12136 elsif not Comes_From_Source (Obj) then 12137 declare 12138 Ref : constant Node_Id := Reference_To (Obj); 12139 begin 12140 if Present (Ref) then 12141 return Object_Access_Level (Ref); 12142 else 12143 return Type_Access_Level (Etype (Prefix (Obj))); 12144 end if; 12145 end; 12146 12147 else 12148 return Type_Access_Level (Etype (Prefix (Obj))); 12149 end if; 12150 12151 elsif Nkind_In (Obj, N_Type_Conversion, N_Unchecked_Type_Conversion) then 12152 return Object_Access_Level (Expression (Obj)); 12153 12154 elsif Nkind (Obj) = N_Function_Call then 12155 12156 -- Function results are objects, so we get either the access level of 12157 -- the function or, in the case of an indirect call, the level of the 12158 -- access-to-subprogram type. (This code is used for Ada 95, but it 12159 -- looks wrong, because it seems that we should be checking the level 12160 -- of the call itself, even for Ada 95. However, using the Ada 2005 12161 -- version of the code causes regressions in several tests that are 12162 -- compiled with -gnat95. ???) 12163 12164 if Ada_Version < Ada_2005 then 12165 if Is_Entity_Name (Name (Obj)) then 12166 return Subprogram_Access_Level (Entity (Name (Obj))); 12167 else 12168 return Type_Access_Level (Etype (Prefix (Name (Obj)))); 12169 end if; 12170 12171 -- For Ada 2005, the level of the result object of a function call is 12172 -- defined to be the level of the call's innermost enclosing master. 12173 -- We determine that by querying the depth of the innermost enclosing 12174 -- dynamic scope. 12175 12176 else 12177 Return_Master_Scope_Depth_Of_Call : declare 12178 12179 function Innermost_Master_Scope_Depth 12180 (N : Node_Id) return Uint; 12181 -- Returns the scope depth of the given node's innermost 12182 -- enclosing dynamic scope (effectively the accessibility 12183 -- level of the innermost enclosing master). 12184 12185 ---------------------------------- 12186 -- Innermost_Master_Scope_Depth -- 12187 ---------------------------------- 12188 12189 function Innermost_Master_Scope_Depth 12190 (N : Node_Id) return Uint 12191 is 12192 Node_Par : Node_Id := Parent (N); 12193 12194 begin 12195 -- Locate the nearest enclosing node (by traversing Parents) 12196 -- that Defining_Entity can be applied to, and return the 12197 -- depth of that entity's nearest enclosing dynamic scope. 12198 12199 while Present (Node_Par) loop 12200 case Nkind (Node_Par) is 12201 when N_Component_Declaration | 12202 N_Entry_Declaration | 12203 N_Formal_Object_Declaration | 12204 N_Formal_Type_Declaration | 12205 N_Full_Type_Declaration | 12206 N_Incomplete_Type_Declaration | 12207 N_Loop_Parameter_Specification | 12208 N_Object_Declaration | 12209 N_Protected_Type_Declaration | 12210 N_Private_Extension_Declaration | 12211 N_Private_Type_Declaration | 12212 N_Subtype_Declaration | 12213 N_Function_Specification | 12214 N_Procedure_Specification | 12215 N_Task_Type_Declaration | 12216 N_Body_Stub | 12217 N_Generic_Instantiation | 12218 N_Proper_Body | 12219 N_Implicit_Label_Declaration | 12220 N_Package_Declaration | 12221 N_Single_Task_Declaration | 12222 N_Subprogram_Declaration | 12223 N_Generic_Declaration | 12224 N_Renaming_Declaration | 12225 N_Block_Statement | 12226 N_Formal_Subprogram_Declaration | 12227 N_Abstract_Subprogram_Declaration | 12228 N_Entry_Body | 12229 N_Exception_Declaration | 12230 N_Formal_Package_Declaration | 12231 N_Number_Declaration | 12232 N_Package_Specification | 12233 N_Parameter_Specification | 12234 N_Single_Protected_Declaration | 12235 N_Subunit => 12236 12237 return Scope_Depth 12238 (Nearest_Dynamic_Scope 12239 (Defining_Entity (Node_Par))); 12240 12241 when others => 12242 null; 12243 end case; 12244 12245 Node_Par := Parent (Node_Par); 12246 end loop; 12247 12248 pragma Assert (False); 12249 12250 -- Should never reach the following return 12251 12252 return Scope_Depth (Current_Scope) + 1; 12253 end Innermost_Master_Scope_Depth; 12254 12255 -- Start of processing for Return_Master_Scope_Depth_Of_Call 12256 12257 begin 12258 return Innermost_Master_Scope_Depth (Obj); 12259 end Return_Master_Scope_Depth_Of_Call; 12260 end if; 12261 12262 -- For convenience we handle qualified expressions, even though they 12263 -- aren't technically object names. 12264 12265 elsif Nkind (Obj) = N_Qualified_Expression then 12266 return Object_Access_Level (Expression (Obj)); 12267 12268 -- Otherwise return the scope level of Standard. (If there are cases 12269 -- that fall through to this point they will be treated as having 12270 -- global accessibility for now. ???) 12271 12272 else 12273 return Scope_Depth (Standard_Standard); 12274 end if; 12275 end Object_Access_Level; 12276 12277 -------------------------------------- 12278 -- Original_Corresponding_Operation -- 12279 -------------------------------------- 12280 12281 function Original_Corresponding_Operation (S : Entity_Id) return Entity_Id 12282 is 12283 Typ : constant Entity_Id := Find_Dispatching_Type (S); 12284 12285 begin 12286 -- If S is an inherited primitive S2 the original corresponding 12287 -- operation of S is the original corresponding operation of S2 12288 12289 if Present (Alias (S)) 12290 and then Find_Dispatching_Type (Alias (S)) /= Typ 12291 then 12292 return Original_Corresponding_Operation (Alias (S)); 12293 12294 -- If S overrides an inherited subprogram S2 the original corresponding 12295 -- operation of S is the original corresponding operation of S2 12296 12297 elsif Present (Overridden_Operation (S)) then 12298 return Original_Corresponding_Operation (Overridden_Operation (S)); 12299 12300 -- otherwise it is S itself 12301 12302 else 12303 return S; 12304 end if; 12305 end Original_Corresponding_Operation; 12306 12307 ----------------------- 12308 -- Private_Component -- 12309 ----------------------- 12310 12311 function Private_Component (Type_Id : Entity_Id) return Entity_Id is 12312 Ancestor : constant Entity_Id := Base_Type (Type_Id); 12313 12314 function Trace_Components 12315 (T : Entity_Id; 12316 Check : Boolean) return Entity_Id; 12317 -- Recursive function that does the work, and checks against circular 12318 -- definition for each subcomponent type. 12319 12320 ---------------------- 12321 -- Trace_Components -- 12322 ---------------------- 12323 12324 function Trace_Components 12325 (T : Entity_Id; 12326 Check : Boolean) return Entity_Id 12327 is 12328 Btype : constant Entity_Id := Base_Type (T); 12329 Component : Entity_Id; 12330 P : Entity_Id; 12331 Candidate : Entity_Id := Empty; 12332 12333 begin 12334 if Check and then Btype = Ancestor then 12335 Error_Msg_N ("circular type definition", Type_Id); 12336 return Any_Type; 12337 end if; 12338 12339 if Is_Private_Type (Btype) 12340 and then not Is_Generic_Type (Btype) 12341 then 12342 if Present (Full_View (Btype)) 12343 and then Is_Record_Type (Full_View (Btype)) 12344 and then not Is_Frozen (Btype) 12345 then 12346 -- To indicate that the ancestor depends on a private type, the 12347 -- current Btype is sufficient. However, to check for circular 12348 -- definition we must recurse on the full view. 12349 12350 Candidate := Trace_Components (Full_View (Btype), True); 12351 12352 if Candidate = Any_Type then 12353 return Any_Type; 12354 else 12355 return Btype; 12356 end if; 12357 12358 else 12359 return Btype; 12360 end if; 12361 12362 elsif Is_Array_Type (Btype) then 12363 return Trace_Components (Component_Type (Btype), True); 12364 12365 elsif Is_Record_Type (Btype) then 12366 Component := First_Entity (Btype); 12367 while Present (Component) 12368 and then Comes_From_Source (Component) 12369 loop 12370 -- Skip anonymous types generated by constrained components 12371 12372 if not Is_Type (Component) then 12373 P := Trace_Components (Etype (Component), True); 12374 12375 if Present (P) then 12376 if P = Any_Type then 12377 return P; 12378 else 12379 Candidate := P; 12380 end if; 12381 end if; 12382 end if; 12383 12384 Next_Entity (Component); 12385 end loop; 12386 12387 return Candidate; 12388 12389 else 12390 return Empty; 12391 end if; 12392 end Trace_Components; 12393 12394 -- Start of processing for Private_Component 12395 12396 begin 12397 return Trace_Components (Type_Id, False); 12398 end Private_Component; 12399 12400 --------------------------- 12401 -- Primitive_Names_Match -- 12402 --------------------------- 12403 12404 function Primitive_Names_Match (E1, E2 : Entity_Id) return Boolean is 12405 12406 function Non_Internal_Name (E : Entity_Id) return Name_Id; 12407 -- Given an internal name, returns the corresponding non-internal name 12408 12409 ------------------------ 12410 -- Non_Internal_Name -- 12411 ------------------------ 12412 12413 function Non_Internal_Name (E : Entity_Id) return Name_Id is 12414 begin 12415 Get_Name_String (Chars (E)); 12416 Name_Len := Name_Len - 1; 12417 return Name_Find; 12418 end Non_Internal_Name; 12419 12420 -- Start of processing for Primitive_Names_Match 12421 12422 begin 12423 pragma Assert (Present (E1) and then Present (E2)); 12424 12425 return Chars (E1) = Chars (E2) 12426 or else 12427 (not Is_Internal_Name (Chars (E1)) 12428 and then Is_Internal_Name (Chars (E2)) 12429 and then Non_Internal_Name (E2) = Chars (E1)) 12430 or else 12431 (not Is_Internal_Name (Chars (E2)) 12432 and then Is_Internal_Name (Chars (E1)) 12433 and then Non_Internal_Name (E1) = Chars (E2)) 12434 or else 12435 (Is_Predefined_Dispatching_Operation (E1) 12436 and then Is_Predefined_Dispatching_Operation (E2) 12437 and then Same_TSS (E1, E2)) 12438 or else 12439 (Is_Init_Proc (E1) and then Is_Init_Proc (E2)); 12440 end Primitive_Names_Match; 12441 12442 ----------------------- 12443 -- Process_End_Label -- 12444 ----------------------- 12445 12446 procedure Process_End_Label 12447 (N : Node_Id; 12448 Typ : Character; 12449 Ent : Entity_Id) 12450 is 12451 Loc : Source_Ptr; 12452 Nam : Node_Id; 12453 Scop : Entity_Id; 12454 12455 Label_Ref : Boolean; 12456 -- Set True if reference to end label itself is required 12457 12458 Endl : Node_Id; 12459 -- Gets set to the operator symbol or identifier that references the 12460 -- entity Ent. For the child unit case, this is the identifier from the 12461 -- designator. For other cases, this is simply Endl. 12462 12463 procedure Generate_Parent_Ref (N : Node_Id; E : Entity_Id); 12464 -- N is an identifier node that appears as a parent unit reference in 12465 -- the case where Ent is a child unit. This procedure generates an 12466 -- appropriate cross-reference entry. E is the corresponding entity. 12467 12468 ------------------------- 12469 -- Generate_Parent_Ref -- 12470 ------------------------- 12471 12472 procedure Generate_Parent_Ref (N : Node_Id; E : Entity_Id) is 12473 begin 12474 -- If names do not match, something weird, skip reference 12475 12476 if Chars (E) = Chars (N) then 12477 12478 -- Generate the reference. We do NOT consider this as a reference 12479 -- for unreferenced symbol purposes. 12480 12481 Generate_Reference (E, N, 'r', Set_Ref => False, Force => True); 12482 12483 if Style_Check then 12484 Style.Check_Identifier (N, E); 12485 end if; 12486 end if; 12487 end Generate_Parent_Ref; 12488 12489 -- Start of processing for Process_End_Label 12490 12491 begin 12492 -- If no node, ignore. This happens in some error situations, and 12493 -- also for some internally generated structures where no end label 12494 -- references are required in any case. 12495 12496 if No (N) then 12497 return; 12498 end if; 12499 12500 -- Nothing to do if no End_Label, happens for internally generated 12501 -- constructs where we don't want an end label reference anyway. Also 12502 -- nothing to do if Endl is a string literal, which means there was 12503 -- some prior error (bad operator symbol) 12504 12505 Endl := End_Label (N); 12506 12507 if No (Endl) or else Nkind (Endl) = N_String_Literal then 12508 return; 12509 end if; 12510 12511 -- Reference node is not in extended main source unit 12512 12513 if not In_Extended_Main_Source_Unit (N) then 12514 12515 -- Generally we do not collect references except for the extended 12516 -- main source unit. The one exception is the 'e' entry for a 12517 -- package spec, where it is useful for a client to have the 12518 -- ending information to define scopes. 12519 12520 if Typ /= 'e' then 12521 return; 12522 12523 else 12524 Label_Ref := False; 12525 12526 -- For this case, we can ignore any parent references, but we 12527 -- need the package name itself for the 'e' entry. 12528 12529 if Nkind (Endl) = N_Designator then 12530 Endl := Identifier (Endl); 12531 end if; 12532 end if; 12533 12534 -- Reference is in extended main source unit 12535 12536 else 12537 Label_Ref := True; 12538 12539 -- For designator, generate references for the parent entries 12540 12541 if Nkind (Endl) = N_Designator then 12542 12543 -- Generate references for the prefix if the END line comes from 12544 -- source (otherwise we do not need these references) We climb the 12545 -- scope stack to find the expected entities. 12546 12547 if Comes_From_Source (Endl) then 12548 Nam := Name (Endl); 12549 Scop := Current_Scope; 12550 while Nkind (Nam) = N_Selected_Component loop 12551 Scop := Scope (Scop); 12552 exit when No (Scop); 12553 Generate_Parent_Ref (Selector_Name (Nam), Scop); 12554 Nam := Prefix (Nam); 12555 end loop; 12556 12557 if Present (Scop) then 12558 Generate_Parent_Ref (Nam, Scope (Scop)); 12559 end if; 12560 end if; 12561 12562 Endl := Identifier (Endl); 12563 end if; 12564 end if; 12565 12566 -- If the end label is not for the given entity, then either we have 12567 -- some previous error, or this is a generic instantiation for which 12568 -- we do not need to make a cross-reference in this case anyway. In 12569 -- either case we simply ignore the call. 12570 12571 if Chars (Ent) /= Chars (Endl) then 12572 return; 12573 end if; 12574 12575 -- If label was really there, then generate a normal reference and then 12576 -- adjust the location in the end label to point past the name (which 12577 -- should almost always be the semicolon). 12578 12579 Loc := Sloc (Endl); 12580 12581 if Comes_From_Source (Endl) then 12582 12583 -- If a label reference is required, then do the style check and 12584 -- generate an l-type cross-reference entry for the label 12585 12586 if Label_Ref then 12587 if Style_Check then 12588 Style.Check_Identifier (Endl, Ent); 12589 end if; 12590 12591 Generate_Reference (Ent, Endl, 'l', Set_Ref => False); 12592 end if; 12593 12594 -- Set the location to point past the label (normally this will 12595 -- mean the semicolon immediately following the label). This is 12596 -- done for the sake of the 'e' or 't' entry generated below. 12597 12598 Get_Decoded_Name_String (Chars (Endl)); 12599 Set_Sloc (Endl, Sloc (Endl) + Source_Ptr (Name_Len)); 12600 12601 else 12602 -- In SPARK mode, no missing label is allowed for packages and 12603 -- subprogram bodies. Detect those cases by testing whether 12604 -- Process_End_Label was called for a body (Typ = 't') or a package. 12605 12606 if Restriction_Check_Required (SPARK) 12607 and then (Typ = 't' or else Ekind (Ent) = E_Package) 12608 then 12609 Error_Msg_Node_1 := Endl; 12610 Check_SPARK_Restriction ("`END &` required", Endl, Force => True); 12611 end if; 12612 end if; 12613 12614 -- Now generate the e/t reference 12615 12616 Generate_Reference (Ent, Endl, Typ, Set_Ref => False, Force => True); 12617 12618 -- Restore Sloc, in case modified above, since we have an identifier 12619 -- and the normal Sloc should be left set in the tree. 12620 12621 Set_Sloc (Endl, Loc); 12622 end Process_End_Label; 12623 12624 ------------------------------------ 12625 -- References_Generic_Formal_Type -- 12626 ------------------------------------ 12627 12628 function References_Generic_Formal_Type (N : Node_Id) return Boolean is 12629 12630 function Process (N : Node_Id) return Traverse_Result; 12631 -- Process one node in search for generic formal type 12632 12633 ------------- 12634 -- Process -- 12635 ------------- 12636 12637 function Process (N : Node_Id) return Traverse_Result is 12638 begin 12639 if Nkind (N) in N_Has_Entity then 12640 declare 12641 E : constant Entity_Id := Entity (N); 12642 begin 12643 if Present (E) then 12644 if Is_Generic_Type (E) then 12645 return Abandon; 12646 elsif Present (Etype (E)) 12647 and then Is_Generic_Type (Etype (E)) 12648 then 12649 return Abandon; 12650 end if; 12651 end if; 12652 end; 12653 end if; 12654 12655 return Atree.OK; 12656 end Process; 12657 12658 function Traverse is new Traverse_Func (Process); 12659 -- Traverse tree to look for generic type 12660 12661 begin 12662 if Inside_A_Generic then 12663 return Traverse (N) = Abandon; 12664 else 12665 return False; 12666 end if; 12667 end References_Generic_Formal_Type; 12668 12669 -------------------- 12670 -- Remove_Homonym -- 12671 -------------------- 12672 12673 procedure Remove_Homonym (E : Entity_Id) is 12674 Prev : Entity_Id := Empty; 12675 H : Entity_Id; 12676 12677 begin 12678 if E = Current_Entity (E) then 12679 if Present (Homonym (E)) then 12680 Set_Current_Entity (Homonym (E)); 12681 else 12682 Set_Name_Entity_Id (Chars (E), Empty); 12683 end if; 12684 12685 else 12686 H := Current_Entity (E); 12687 while Present (H) and then H /= E loop 12688 Prev := H; 12689 H := Homonym (H); 12690 end loop; 12691 12692 -- If E is not on the homonym chain, nothing to do 12693 12694 if Present (H) then 12695 Set_Homonym (Prev, Homonym (E)); 12696 end if; 12697 end if; 12698 end Remove_Homonym; 12699 12700 --------------------- 12701 -- Rep_To_Pos_Flag -- 12702 --------------------- 12703 12704 function Rep_To_Pos_Flag (E : Entity_Id; Loc : Source_Ptr) return Node_Id is 12705 begin 12706 return New_Occurrence_Of 12707 (Boolean_Literals (not Range_Checks_Suppressed (E)), Loc); 12708 end Rep_To_Pos_Flag; 12709 12710 -------------------- 12711 -- Require_Entity -- 12712 -------------------- 12713 12714 procedure Require_Entity (N : Node_Id) is 12715 begin 12716 if Is_Entity_Name (N) and then No (Entity (N)) then 12717 if Total_Errors_Detected /= 0 then 12718 Set_Entity (N, Any_Id); 12719 else 12720 raise Program_Error; 12721 end if; 12722 end if; 12723 end Require_Entity; 12724 12725 ------------------------------ 12726 -- Requires_Transient_Scope -- 12727 ------------------------------ 12728 12729 -- A transient scope is required when variable-sized temporaries are 12730 -- allocated in the primary or secondary stack, or when finalization 12731 -- actions must be generated before the next instruction. 12732 12733 function Requires_Transient_Scope (Id : Entity_Id) return Boolean is 12734 Typ : constant Entity_Id := Underlying_Type (Id); 12735 12736 -- Start of processing for Requires_Transient_Scope 12737 12738 begin 12739 -- This is a private type which is not completed yet. This can only 12740 -- happen in a default expression (of a formal parameter or of a 12741 -- record component). Do not expand transient scope in this case 12742 12743 if No (Typ) then 12744 return False; 12745 12746 -- Do not expand transient scope for non-existent procedure return 12747 12748 elsif Typ = Standard_Void_Type then 12749 return False; 12750 12751 -- Elementary types do not require a transient scope 12752 12753 elsif Is_Elementary_Type (Typ) then 12754 return False; 12755 12756 -- Generally, indefinite subtypes require a transient scope, since the 12757 -- back end cannot generate temporaries, since this is not a valid type 12758 -- for declaring an object. It might be possible to relax this in the 12759 -- future, e.g. by declaring the maximum possible space for the type. 12760 12761 elsif Is_Indefinite_Subtype (Typ) then 12762 return True; 12763 12764 -- Functions returning tagged types may dispatch on result so their 12765 -- returned value is allocated on the secondary stack. Controlled 12766 -- type temporaries need finalization. 12767 12768 elsif Is_Tagged_Type (Typ) 12769 or else Has_Controlled_Component (Typ) 12770 then 12771 return not Is_Value_Type (Typ); 12772 12773 -- Record type 12774 12775 elsif Is_Record_Type (Typ) then 12776 declare 12777 Comp : Entity_Id; 12778 begin 12779 Comp := First_Entity (Typ); 12780 while Present (Comp) loop 12781 if Ekind (Comp) = E_Component 12782 and then Requires_Transient_Scope (Etype (Comp)) 12783 then 12784 return True; 12785 else 12786 Next_Entity (Comp); 12787 end if; 12788 end loop; 12789 end; 12790 12791 return False; 12792 12793 -- String literal types never require transient scope 12794 12795 elsif Ekind (Typ) = E_String_Literal_Subtype then 12796 return False; 12797 12798 -- Array type. Note that we already know that this is a constrained 12799 -- array, since unconstrained arrays will fail the indefinite test. 12800 12801 elsif Is_Array_Type (Typ) then 12802 12803 -- If component type requires a transient scope, the array does too 12804 12805 if Requires_Transient_Scope (Component_Type (Typ)) then 12806 return True; 12807 12808 -- Otherwise, we only need a transient scope if the size depends on 12809 -- the value of one or more discriminants. 12810 12811 else 12812 return Size_Depends_On_Discriminant (Typ); 12813 end if; 12814 12815 -- All other cases do not require a transient scope 12816 12817 else 12818 return False; 12819 end if; 12820 end Requires_Transient_Scope; 12821 12822 -------------------------- 12823 -- Reset_Analyzed_Flags -- 12824 -------------------------- 12825 12826 procedure Reset_Analyzed_Flags (N : Node_Id) is 12827 12828 function Clear_Analyzed (N : Node_Id) return Traverse_Result; 12829 -- Function used to reset Analyzed flags in tree. Note that we do 12830 -- not reset Analyzed flags in entities, since there is no need to 12831 -- reanalyze entities, and indeed, it is wrong to do so, since it 12832 -- can result in generating auxiliary stuff more than once. 12833 12834 -------------------- 12835 -- Clear_Analyzed -- 12836 -------------------- 12837 12838 function Clear_Analyzed (N : Node_Id) return Traverse_Result is 12839 begin 12840 if not Has_Extension (N) then 12841 Set_Analyzed (N, False); 12842 end if; 12843 12844 return OK; 12845 end Clear_Analyzed; 12846 12847 procedure Reset_Analyzed is new Traverse_Proc (Clear_Analyzed); 12848 12849 -- Start of processing for Reset_Analyzed_Flags 12850 12851 begin 12852 Reset_Analyzed (N); 12853 end Reset_Analyzed_Flags; 12854 12855 -------------------------------- 12856 -- Returns_Unconstrained_Type -- 12857 -------------------------------- 12858 12859 function Returns_Unconstrained_Type (Subp : Entity_Id) return Boolean is 12860 begin 12861 return Ekind (Subp) = E_Function 12862 and then not Is_Scalar_Type (Etype (Subp)) 12863 and then not Is_Access_Type (Etype (Subp)) 12864 and then not Is_Constrained (Etype (Subp)); 12865 end Returns_Unconstrained_Type; 12866 12867 --------------------------- 12868 -- Safe_To_Capture_Value -- 12869 --------------------------- 12870 12871 function Safe_To_Capture_Value 12872 (N : Node_Id; 12873 Ent : Entity_Id; 12874 Cond : Boolean := False) return Boolean 12875 is 12876 begin 12877 -- The only entities for which we track constant values are variables 12878 -- which are not renamings, constants, out parameters, and in out 12879 -- parameters, so check if we have this case. 12880 12881 -- Note: it may seem odd to track constant values for constants, but in 12882 -- fact this routine is used for other purposes than simply capturing 12883 -- the value. In particular, the setting of Known[_Non]_Null. 12884 12885 if (Ekind (Ent) = E_Variable and then No (Renamed_Object (Ent))) 12886 or else 12887 Ekind (Ent) = E_Constant 12888 or else 12889 Ekind (Ent) = E_Out_Parameter 12890 or else 12891 Ekind (Ent) = E_In_Out_Parameter 12892 then 12893 null; 12894 12895 -- For conditionals, we also allow loop parameters and all formals, 12896 -- including in parameters. 12897 12898 elsif Cond 12899 and then 12900 (Ekind (Ent) = E_Loop_Parameter 12901 or else 12902 Ekind (Ent) = E_In_Parameter) 12903 then 12904 null; 12905 12906 -- For all other cases, not just unsafe, but impossible to capture 12907 -- Current_Value, since the above are the only entities which have 12908 -- Current_Value fields. 12909 12910 else 12911 return False; 12912 end if; 12913 12914 -- Skip if volatile or aliased, since funny things might be going on in 12915 -- these cases which we cannot necessarily track. Also skip any variable 12916 -- for which an address clause is given, or whose address is taken. Also 12917 -- never capture value of library level variables (an attempt to do so 12918 -- can occur in the case of package elaboration code). 12919 12920 if Treat_As_Volatile (Ent) 12921 or else Is_Aliased (Ent) 12922 or else Present (Address_Clause (Ent)) 12923 or else Address_Taken (Ent) 12924 or else (Is_Library_Level_Entity (Ent) 12925 and then Ekind (Ent) = E_Variable) 12926 then 12927 return False; 12928 end if; 12929 12930 -- OK, all above conditions are met. We also require that the scope of 12931 -- the reference be the same as the scope of the entity, not counting 12932 -- packages and blocks and loops. 12933 12934 declare 12935 E_Scope : constant Entity_Id := Scope (Ent); 12936 R_Scope : Entity_Id; 12937 12938 begin 12939 R_Scope := Current_Scope; 12940 while R_Scope /= Standard_Standard loop 12941 exit when R_Scope = E_Scope; 12942 12943 if not Ekind_In (R_Scope, E_Package, E_Block, E_Loop) then 12944 return False; 12945 else 12946 R_Scope := Scope (R_Scope); 12947 end if; 12948 end loop; 12949 end; 12950 12951 -- We also require that the reference does not appear in a context 12952 -- where it is not sure to be executed (i.e. a conditional context 12953 -- or an exception handler). We skip this if Cond is True, since the 12954 -- capturing of values from conditional tests handles this ok. 12955 12956 if Cond then 12957 return True; 12958 end if; 12959 12960 declare 12961 Desc : Node_Id; 12962 P : Node_Id; 12963 12964 begin 12965 Desc := N; 12966 12967 -- Seems dubious that case expressions are not handled here ??? 12968 12969 P := Parent (N); 12970 while Present (P) loop 12971 if Nkind (P) = N_If_Statement 12972 or else Nkind (P) = N_Case_Statement 12973 or else (Nkind (P) in N_Short_Circuit 12974 and then Desc = Right_Opnd (P)) 12975 or else (Nkind (P) = N_If_Expression 12976 and then Desc /= First (Expressions (P))) 12977 or else Nkind (P) = N_Exception_Handler 12978 or else Nkind (P) = N_Selective_Accept 12979 or else Nkind (P) = N_Conditional_Entry_Call 12980 or else Nkind (P) = N_Timed_Entry_Call 12981 or else Nkind (P) = N_Asynchronous_Select 12982 then 12983 return False; 12984 else 12985 Desc := P; 12986 P := Parent (P); 12987 end if; 12988 end loop; 12989 end; 12990 12991 -- OK, looks safe to set value 12992 12993 return True; 12994 end Safe_To_Capture_Value; 12995 12996 --------------- 12997 -- Same_Name -- 12998 --------------- 12999 13000 function Same_Name (N1, N2 : Node_Id) return Boolean is 13001 K1 : constant Node_Kind := Nkind (N1); 13002 K2 : constant Node_Kind := Nkind (N2); 13003 13004 begin 13005 if (K1 = N_Identifier or else K1 = N_Defining_Identifier) 13006 and then (K2 = N_Identifier or else K2 = N_Defining_Identifier) 13007 then 13008 return Chars (N1) = Chars (N2); 13009 13010 elsif (K1 = N_Selected_Component or else K1 = N_Expanded_Name) 13011 and then (K2 = N_Selected_Component or else K2 = N_Expanded_Name) 13012 then 13013 return Same_Name (Selector_Name (N1), Selector_Name (N2)) 13014 and then Same_Name (Prefix (N1), Prefix (N2)); 13015 13016 else 13017 return False; 13018 end if; 13019 end Same_Name; 13020 13021 ----------------- 13022 -- Same_Object -- 13023 ----------------- 13024 13025 function Same_Object (Node1, Node2 : Node_Id) return Boolean is 13026 N1 : constant Node_Id := Original_Node (Node1); 13027 N2 : constant Node_Id := Original_Node (Node2); 13028 -- We do the tests on original nodes, since we are most interested 13029 -- in the original source, not any expansion that got in the way. 13030 13031 K1 : constant Node_Kind := Nkind (N1); 13032 K2 : constant Node_Kind := Nkind (N2); 13033 13034 begin 13035 -- First case, both are entities with same entity 13036 13037 if K1 in N_Has_Entity and then K2 in N_Has_Entity then 13038 declare 13039 EN1 : constant Entity_Id := Entity (N1); 13040 EN2 : constant Entity_Id := Entity (N2); 13041 begin 13042 if Present (EN1) and then Present (EN2) 13043 and then (Ekind_In (EN1, E_Variable, E_Constant) 13044 or else Is_Formal (EN1)) 13045 and then EN1 = EN2 13046 then 13047 return True; 13048 end if; 13049 end; 13050 end if; 13051 13052 -- Second case, selected component with same selector, same record 13053 13054 if K1 = N_Selected_Component 13055 and then K2 = N_Selected_Component 13056 and then Chars (Selector_Name (N1)) = Chars (Selector_Name (N2)) 13057 then 13058 return Same_Object (Prefix (N1), Prefix (N2)); 13059 13060 -- Third case, indexed component with same subscripts, same array 13061 13062 elsif K1 = N_Indexed_Component 13063 and then K2 = N_Indexed_Component 13064 and then Same_Object (Prefix (N1), Prefix (N2)) 13065 then 13066 declare 13067 E1, E2 : Node_Id; 13068 begin 13069 E1 := First (Expressions (N1)); 13070 E2 := First (Expressions (N2)); 13071 while Present (E1) loop 13072 if not Same_Value (E1, E2) then 13073 return False; 13074 else 13075 Next (E1); 13076 Next (E2); 13077 end if; 13078 end loop; 13079 13080 return True; 13081 end; 13082 13083 -- Fourth case, slice of same array with same bounds 13084 13085 elsif K1 = N_Slice 13086 and then K2 = N_Slice 13087 and then Nkind (Discrete_Range (N1)) = N_Range 13088 and then Nkind (Discrete_Range (N2)) = N_Range 13089 and then Same_Value (Low_Bound (Discrete_Range (N1)), 13090 Low_Bound (Discrete_Range (N2))) 13091 and then Same_Value (High_Bound (Discrete_Range (N1)), 13092 High_Bound (Discrete_Range (N2))) 13093 then 13094 return Same_Name (Prefix (N1), Prefix (N2)); 13095 13096 -- All other cases, not clearly the same object 13097 13098 else 13099 return False; 13100 end if; 13101 end Same_Object; 13102 13103 --------------- 13104 -- Same_Type -- 13105 --------------- 13106 13107 function Same_Type (T1, T2 : Entity_Id) return Boolean is 13108 begin 13109 if T1 = T2 then 13110 return True; 13111 13112 elsif not Is_Constrained (T1) 13113 and then not Is_Constrained (T2) 13114 and then Base_Type (T1) = Base_Type (T2) 13115 then 13116 return True; 13117 13118 -- For now don't bother with case of identical constraints, to be 13119 -- fiddled with later on perhaps (this is only used for optimization 13120 -- purposes, so it is not critical to do a best possible job) 13121 13122 else 13123 return False; 13124 end if; 13125 end Same_Type; 13126 13127 ---------------- 13128 -- Same_Value -- 13129 ---------------- 13130 13131 function Same_Value (Node1, Node2 : Node_Id) return Boolean is 13132 begin 13133 if Compile_Time_Known_Value (Node1) 13134 and then Compile_Time_Known_Value (Node2) 13135 and then Expr_Value (Node1) = Expr_Value (Node2) 13136 then 13137 return True; 13138 elsif Same_Object (Node1, Node2) then 13139 return True; 13140 else 13141 return False; 13142 end if; 13143 end Same_Value; 13144 13145 ------------------------ 13146 -- Scope_Is_Transient -- 13147 ------------------------ 13148 13149 function Scope_Is_Transient return Boolean is 13150 begin 13151 return Scope_Stack.Table (Scope_Stack.Last).Is_Transient; 13152 end Scope_Is_Transient; 13153 13154 ------------------ 13155 -- Scope_Within -- 13156 ------------------ 13157 13158 function Scope_Within (Scope1, Scope2 : Entity_Id) return Boolean is 13159 Scop : Entity_Id; 13160 13161 begin 13162 Scop := Scope1; 13163 while Scop /= Standard_Standard loop 13164 Scop := Scope (Scop); 13165 13166 if Scop = Scope2 then 13167 return True; 13168 end if; 13169 end loop; 13170 13171 return False; 13172 end Scope_Within; 13173 13174 -------------------------- 13175 -- Scope_Within_Or_Same -- 13176 -------------------------- 13177 13178 function Scope_Within_Or_Same (Scope1, Scope2 : Entity_Id) return Boolean is 13179 Scop : Entity_Id; 13180 13181 begin 13182 Scop := Scope1; 13183 while Scop /= Standard_Standard loop 13184 if Scop = Scope2 then 13185 return True; 13186 else 13187 Scop := Scope (Scop); 13188 end if; 13189 end loop; 13190 13191 return False; 13192 end Scope_Within_Or_Same; 13193 13194 -------------------- 13195 -- Set_Convention -- 13196 -------------------- 13197 13198 procedure Set_Convention (E : Entity_Id; Val : Snames.Convention_Id) is 13199 begin 13200 Basic_Set_Convention (E, Val); 13201 13202 if Is_Type (E) 13203 and then Is_Access_Subprogram_Type (Base_Type (E)) 13204 and then Has_Foreign_Convention (E) 13205 then 13206 Set_Can_Use_Internal_Rep (E, False); 13207 end if; 13208 end Set_Convention; 13209 13210 ------------------------ 13211 -- Set_Current_Entity -- 13212 ------------------------ 13213 13214 -- The given entity is to be set as the currently visible definition of its 13215 -- associated name (i.e. the Node_Id associated with its name). All we have 13216 -- to do is to get the name from the identifier, and then set the 13217 -- associated Node_Id to point to the given entity. 13218 13219 procedure Set_Current_Entity (E : Entity_Id) is 13220 begin 13221 Set_Name_Entity_Id (Chars (E), E); 13222 end Set_Current_Entity; 13223 13224 --------------------------- 13225 -- Set_Debug_Info_Needed -- 13226 --------------------------- 13227 13228 procedure Set_Debug_Info_Needed (T : Entity_Id) is 13229 13230 procedure Set_Debug_Info_Needed_If_Not_Set (E : Entity_Id); 13231 pragma Inline (Set_Debug_Info_Needed_If_Not_Set); 13232 -- Used to set debug info in a related node if not set already 13233 13234 -------------------------------------- 13235 -- Set_Debug_Info_Needed_If_Not_Set -- 13236 -------------------------------------- 13237 13238 procedure Set_Debug_Info_Needed_If_Not_Set (E : Entity_Id) is 13239 begin 13240 if Present (E) 13241 and then not Needs_Debug_Info (E) 13242 then 13243 Set_Debug_Info_Needed (E); 13244 13245 -- For a private type, indicate that the full view also needs 13246 -- debug information. 13247 13248 if Is_Type (E) 13249 and then Is_Private_Type (E) 13250 and then Present (Full_View (E)) 13251 then 13252 Set_Debug_Info_Needed (Full_View (E)); 13253 end if; 13254 end if; 13255 end Set_Debug_Info_Needed_If_Not_Set; 13256 13257 -- Start of processing for Set_Debug_Info_Needed 13258 13259 begin 13260 -- Nothing to do if argument is Empty or has Debug_Info_Off set, which 13261 -- indicates that Debug_Info_Needed is never required for the entity. 13262 13263 if No (T) 13264 or else Debug_Info_Off (T) 13265 then 13266 return; 13267 end if; 13268 13269 -- Set flag in entity itself. Note that we will go through the following 13270 -- circuitry even if the flag is already set on T. That's intentional, 13271 -- it makes sure that the flag will be set in subsidiary entities. 13272 13273 Set_Needs_Debug_Info (T); 13274 13275 -- Set flag on subsidiary entities if not set already 13276 13277 if Is_Object (T) then 13278 Set_Debug_Info_Needed_If_Not_Set (Etype (T)); 13279 13280 elsif Is_Type (T) then 13281 Set_Debug_Info_Needed_If_Not_Set (Etype (T)); 13282 13283 if Is_Record_Type (T) then 13284 declare 13285 Ent : Entity_Id := First_Entity (T); 13286 begin 13287 while Present (Ent) loop 13288 Set_Debug_Info_Needed_If_Not_Set (Ent); 13289 Next_Entity (Ent); 13290 end loop; 13291 end; 13292 13293 -- For a class wide subtype, we also need debug information 13294 -- for the equivalent type. 13295 13296 if Ekind (T) = E_Class_Wide_Subtype then 13297 Set_Debug_Info_Needed_If_Not_Set (Equivalent_Type (T)); 13298 end if; 13299 13300 elsif Is_Array_Type (T) then 13301 Set_Debug_Info_Needed_If_Not_Set (Component_Type (T)); 13302 13303 declare 13304 Indx : Node_Id := First_Index (T); 13305 begin 13306 while Present (Indx) loop 13307 Set_Debug_Info_Needed_If_Not_Set (Etype (Indx)); 13308 Indx := Next_Index (Indx); 13309 end loop; 13310 end; 13311 13312 -- For a packed array type, we also need debug information for 13313 -- the type used to represent the packed array. Conversely, we 13314 -- also need it for the former if we need it for the latter. 13315 13316 if Is_Packed (T) then 13317 Set_Debug_Info_Needed_If_Not_Set (Packed_Array_Type (T)); 13318 end if; 13319 13320 if Is_Packed_Array_Type (T) then 13321 Set_Debug_Info_Needed_If_Not_Set (Original_Array_Type (T)); 13322 end if; 13323 13324 elsif Is_Access_Type (T) then 13325 Set_Debug_Info_Needed_If_Not_Set (Directly_Designated_Type (T)); 13326 13327 elsif Is_Private_Type (T) then 13328 Set_Debug_Info_Needed_If_Not_Set (Full_View (T)); 13329 13330 elsif Is_Protected_Type (T) then 13331 Set_Debug_Info_Needed_If_Not_Set (Corresponding_Record_Type (T)); 13332 end if; 13333 end if; 13334 end Set_Debug_Info_Needed; 13335 13336 --------------------------------- 13337 -- Set_Entity_With_Style_Check -- 13338 --------------------------------- 13339 13340 procedure Set_Entity_With_Style_Check (N : Node_Id; Val : Entity_Id) is 13341 Val_Actual : Entity_Id; 13342 Nod : Node_Id; 13343 13344 begin 13345 -- Unconditionally set the entity 13346 13347 Set_Entity (N, Val); 13348 13349 -- Check for No_Implementation_Identifiers 13350 13351 if Restriction_Check_Required (No_Implementation_Identifiers) then 13352 13353 -- We have an implementation defined entity if it is marked as 13354 -- implementation defined, or is defined in a package marked as 13355 -- implementation defined. However, library packages themselves 13356 -- are excluded (we don't want to flag Interfaces itself, just 13357 -- the entities within it). 13358 13359 if (Is_Implementation_Defined (Val) 13360 and then not (Ekind_In (Val, E_Package, E_Generic_Package) 13361 and then Is_Library_Level_Entity (Val))) 13362 or else Is_Implementation_Defined (Scope (Val)) 13363 then 13364 Check_Restriction (No_Implementation_Identifiers, N); 13365 end if; 13366 end if; 13367 13368 -- Do the style check 13369 13370 if Style_Check 13371 and then not Suppress_Style_Checks (Val) 13372 and then not In_Instance 13373 then 13374 if Nkind (N) = N_Identifier then 13375 Nod := N; 13376 elsif Nkind (N) = N_Expanded_Name then 13377 Nod := Selector_Name (N); 13378 else 13379 return; 13380 end if; 13381 13382 -- A special situation arises for derived operations, where we want 13383 -- to do the check against the parent (since the Sloc of the derived 13384 -- operation points to the derived type declaration itself). 13385 13386 Val_Actual := Val; 13387 while not Comes_From_Source (Val_Actual) 13388 and then Nkind (Val_Actual) in N_Entity 13389 and then (Ekind (Val_Actual) = E_Enumeration_Literal 13390 or else Is_Subprogram (Val_Actual) 13391 or else Is_Generic_Subprogram (Val_Actual)) 13392 and then Present (Alias (Val_Actual)) 13393 loop 13394 Val_Actual := Alias (Val_Actual); 13395 end loop; 13396 13397 -- Renaming declarations for generic actuals do not come from source, 13398 -- and have a different name from that of the entity they rename, so 13399 -- there is no style check to perform here. 13400 13401 if Chars (Nod) = Chars (Val_Actual) then 13402 Style.Check_Identifier (Nod, Val_Actual); 13403 end if; 13404 end if; 13405 13406 Set_Entity (N, Val); 13407 end Set_Entity_With_Style_Check; 13408 13409 ------------------------ 13410 -- Set_Name_Entity_Id -- 13411 ------------------------ 13412 13413 procedure Set_Name_Entity_Id (Id : Name_Id; Val : Entity_Id) is 13414 begin 13415 Set_Name_Table_Info (Id, Int (Val)); 13416 end Set_Name_Entity_Id; 13417 13418 --------------------- 13419 -- Set_Next_Actual -- 13420 --------------------- 13421 13422 procedure Set_Next_Actual (Ass1_Id : Node_Id; Ass2_Id : Node_Id) is 13423 begin 13424 if Nkind (Parent (Ass1_Id)) = N_Parameter_Association then 13425 Set_First_Named_Actual (Parent (Ass1_Id), Ass2_Id); 13426 end if; 13427 end Set_Next_Actual; 13428 13429 ---------------------------------- 13430 -- Set_Optimize_Alignment_Flags -- 13431 ---------------------------------- 13432 13433 procedure Set_Optimize_Alignment_Flags (E : Entity_Id) is 13434 begin 13435 if Optimize_Alignment = 'S' then 13436 Set_Optimize_Alignment_Space (E); 13437 elsif Optimize_Alignment = 'T' then 13438 Set_Optimize_Alignment_Time (E); 13439 end if; 13440 end Set_Optimize_Alignment_Flags; 13441 13442 ----------------------- 13443 -- Set_Public_Status -- 13444 ----------------------- 13445 13446 procedure Set_Public_Status (Id : Entity_Id) is 13447 S : constant Entity_Id := Current_Scope; 13448 13449 function Within_HSS_Or_If (E : Entity_Id) return Boolean; 13450 -- Determines if E is defined within handled statement sequence or 13451 -- an if statement, returns True if so, False otherwise. 13452 13453 ---------------------- 13454 -- Within_HSS_Or_If -- 13455 ---------------------- 13456 13457 function Within_HSS_Or_If (E : Entity_Id) return Boolean is 13458 N : Node_Id; 13459 begin 13460 N := Declaration_Node (E); 13461 loop 13462 N := Parent (N); 13463 13464 if No (N) then 13465 return False; 13466 13467 elsif Nkind_In (N, N_Handled_Sequence_Of_Statements, 13468 N_If_Statement) 13469 then 13470 return True; 13471 end if; 13472 end loop; 13473 end Within_HSS_Or_If; 13474 13475 -- Start of processing for Set_Public_Status 13476 13477 begin 13478 -- Everything in the scope of Standard is public 13479 13480 if S = Standard_Standard then 13481 Set_Is_Public (Id); 13482 13483 -- Entity is definitely not public if enclosing scope is not public 13484 13485 elsif not Is_Public (S) then 13486 return; 13487 13488 -- An object or function declaration that occurs in a handled sequence 13489 -- of statements or within an if statement is the declaration for a 13490 -- temporary object or local subprogram generated by the expander. It 13491 -- never needs to be made public and furthermore, making it public can 13492 -- cause back end problems. 13493 13494 elsif Nkind_In (Parent (Id), N_Object_Declaration, 13495 N_Function_Specification) 13496 and then Within_HSS_Or_If (Id) 13497 then 13498 return; 13499 13500 -- Entities in public packages or records are public 13501 13502 elsif Ekind (S) = E_Package or Is_Record_Type (S) then 13503 Set_Is_Public (Id); 13504 13505 -- The bounds of an entry family declaration can generate object 13506 -- declarations that are visible to the back-end, e.g. in the 13507 -- the declaration of a composite type that contains tasks. 13508 13509 elsif Is_Concurrent_Type (S) 13510 and then not Has_Completion (S) 13511 and then Nkind (Parent (Id)) = N_Object_Declaration 13512 then 13513 Set_Is_Public (Id); 13514 end if; 13515 end Set_Public_Status; 13516 13517 ----------------------------- 13518 -- Set_Referenced_Modified -- 13519 ----------------------------- 13520 13521 procedure Set_Referenced_Modified (N : Node_Id; Out_Param : Boolean) is 13522 Pref : Node_Id; 13523 13524 begin 13525 -- Deal with indexed or selected component where prefix is modified 13526 13527 if Nkind_In (N, N_Indexed_Component, N_Selected_Component) then 13528 Pref := Prefix (N); 13529 13530 -- If prefix is access type, then it is the designated object that is 13531 -- being modified, which means we have no entity to set the flag on. 13532 13533 if No (Etype (Pref)) or else Is_Access_Type (Etype (Pref)) then 13534 return; 13535 13536 -- Otherwise chase the prefix 13537 13538 else 13539 Set_Referenced_Modified (Pref, Out_Param); 13540 end if; 13541 13542 -- Otherwise see if we have an entity name (only other case to process) 13543 13544 elsif Is_Entity_Name (N) and then Present (Entity (N)) then 13545 Set_Referenced_As_LHS (Entity (N), not Out_Param); 13546 Set_Referenced_As_Out_Parameter (Entity (N), Out_Param); 13547 end if; 13548 end Set_Referenced_Modified; 13549 13550 ---------------------------- 13551 -- Set_Scope_Is_Transient -- 13552 ---------------------------- 13553 13554 procedure Set_Scope_Is_Transient (V : Boolean := True) is 13555 begin 13556 Scope_Stack.Table (Scope_Stack.Last).Is_Transient := V; 13557 end Set_Scope_Is_Transient; 13558 13559 ------------------- 13560 -- Set_Size_Info -- 13561 ------------------- 13562 13563 procedure Set_Size_Info (T1, T2 : Entity_Id) is 13564 begin 13565 -- We copy Esize, but not RM_Size, since in general RM_Size is 13566 -- subtype specific and does not get inherited by all subtypes. 13567 13568 Set_Esize (T1, Esize (T2)); 13569 Set_Has_Biased_Representation (T1, Has_Biased_Representation (T2)); 13570 13571 if Is_Discrete_Or_Fixed_Point_Type (T1) 13572 and then 13573 Is_Discrete_Or_Fixed_Point_Type (T2) 13574 then 13575 Set_Is_Unsigned_Type (T1, Is_Unsigned_Type (T2)); 13576 end if; 13577 13578 Set_Alignment (T1, Alignment (T2)); 13579 end Set_Size_Info; 13580 13581 -------------------- 13582 -- Static_Boolean -- 13583 -------------------- 13584 13585 function Static_Boolean (N : Node_Id) return Uint is 13586 begin 13587 Analyze_And_Resolve (N, Standard_Boolean); 13588 13589 if N = Error 13590 or else Error_Posted (N) 13591 or else Etype (N) = Any_Type 13592 then 13593 return No_Uint; 13594 end if; 13595 13596 if Is_Static_Expression (N) then 13597 if not Raises_Constraint_Error (N) then 13598 return Expr_Value (N); 13599 else 13600 return No_Uint; 13601 end if; 13602 13603 elsif Etype (N) = Any_Type then 13604 return No_Uint; 13605 13606 else 13607 Flag_Non_Static_Expr 13608 ("static boolean expression required here", N); 13609 return No_Uint; 13610 end if; 13611 end Static_Boolean; 13612 13613 -------------------- 13614 -- Static_Integer -- 13615 -------------------- 13616 13617 function Static_Integer (N : Node_Id) return Uint is 13618 begin 13619 Analyze_And_Resolve (N, Any_Integer); 13620 13621 if N = Error 13622 or else Error_Posted (N) 13623 or else Etype (N) = Any_Type 13624 then 13625 return No_Uint; 13626 end if; 13627 13628 if Is_Static_Expression (N) then 13629 if not Raises_Constraint_Error (N) then 13630 return Expr_Value (N); 13631 else 13632 return No_Uint; 13633 end if; 13634 13635 elsif Etype (N) = Any_Type then 13636 return No_Uint; 13637 13638 else 13639 Flag_Non_Static_Expr 13640 ("static integer expression required here", N); 13641 return No_Uint; 13642 end if; 13643 end Static_Integer; 13644 13645 -------------------------- 13646 -- Statically_Different -- 13647 -------------------------- 13648 13649 function Statically_Different (E1, E2 : Node_Id) return Boolean is 13650 R1 : constant Node_Id := Get_Referenced_Object (E1); 13651 R2 : constant Node_Id := Get_Referenced_Object (E2); 13652 begin 13653 return Is_Entity_Name (R1) 13654 and then Is_Entity_Name (R2) 13655 and then Entity (R1) /= Entity (R2) 13656 and then not Is_Formal (Entity (R1)) 13657 and then not Is_Formal (Entity (R2)); 13658 end Statically_Different; 13659 13660 ----------------------------- 13661 -- Subprogram_Access_Level -- 13662 ----------------------------- 13663 13664 function Subprogram_Access_Level (Subp : Entity_Id) return Uint is 13665 begin 13666 if Present (Alias (Subp)) then 13667 return Subprogram_Access_Level (Alias (Subp)); 13668 else 13669 return Scope_Depth (Enclosing_Dynamic_Scope (Subp)); 13670 end if; 13671 end Subprogram_Access_Level; 13672 13673 ------------------------------- 13674 -- Support_Atomic_Primitives -- 13675 ------------------------------- 13676 13677 function Support_Atomic_Primitives (Typ : Entity_Id) return Boolean is 13678 Size : Int; 13679 13680 begin 13681 -- Verify the alignment of Typ is known 13682 13683 if not Known_Alignment (Typ) then 13684 return False; 13685 end if; 13686 13687 if Known_Static_Esize (Typ) then 13688 Size := UI_To_Int (Esize (Typ)); 13689 13690 -- If the Esize (Object_Size) is unknown at compile-time, look at the 13691 -- RM_Size (Value_Size) since it may have been set by an explicit rep 13692 -- item. 13693 13694 elsif Known_Static_RM_Size (Typ) then 13695 Size := UI_To_Int (RM_Size (Typ)); 13696 13697 -- Otherwise, the size is considered to be unknown. 13698 13699 else 13700 return False; 13701 end if; 13702 13703 -- Check that the size of the component is 8, 16, 32 or 64 bits and that 13704 -- Typ is properly aligned. 13705 13706 case Size is 13707 when 8 | 16 | 32 | 64 => 13708 return Size = UI_To_Int (Alignment (Typ)) * 8; 13709 when others => 13710 return False; 13711 end case; 13712 end Support_Atomic_Primitives; 13713 13714 ----------------- 13715 -- Trace_Scope -- 13716 ----------------- 13717 13718 procedure Trace_Scope (N : Node_Id; E : Entity_Id; Msg : String) is 13719 begin 13720 if Debug_Flag_W then 13721 for J in 0 .. Scope_Stack.Last loop 13722 Write_Str (" "); 13723 end loop; 13724 13725 Write_Str (Msg); 13726 Write_Name (Chars (E)); 13727 Write_Str (" from "); 13728 Write_Location (Sloc (N)); 13729 Write_Eol; 13730 end if; 13731 end Trace_Scope; 13732 13733 ----------------------- 13734 -- Transfer_Entities -- 13735 ----------------------- 13736 13737 procedure Transfer_Entities (From : Entity_Id; To : Entity_Id) is 13738 Ent : Entity_Id := First_Entity (From); 13739 13740 begin 13741 if No (Ent) then 13742 return; 13743 end if; 13744 13745 if (Last_Entity (To)) = Empty then 13746 Set_First_Entity (To, Ent); 13747 else 13748 Set_Next_Entity (Last_Entity (To), Ent); 13749 end if; 13750 13751 Set_Last_Entity (To, Last_Entity (From)); 13752 13753 while Present (Ent) loop 13754 Set_Scope (Ent, To); 13755 13756 if not Is_Public (Ent) then 13757 Set_Public_Status (Ent); 13758 13759 if Is_Public (Ent) 13760 and then Ekind (Ent) = E_Record_Subtype 13761 13762 then 13763 -- The components of the propagated Itype must be public 13764 -- as well. 13765 13766 declare 13767 Comp : Entity_Id; 13768 begin 13769 Comp := First_Entity (Ent); 13770 while Present (Comp) loop 13771 Set_Is_Public (Comp); 13772 Next_Entity (Comp); 13773 end loop; 13774 end; 13775 end if; 13776 end if; 13777 13778 Next_Entity (Ent); 13779 end loop; 13780 13781 Set_First_Entity (From, Empty); 13782 Set_Last_Entity (From, Empty); 13783 end Transfer_Entities; 13784 13785 ----------------------- 13786 -- Type_Access_Level -- 13787 ----------------------- 13788 13789 function Type_Access_Level (Typ : Entity_Id) return Uint is 13790 Btyp : Entity_Id; 13791 13792 begin 13793 Btyp := Base_Type (Typ); 13794 13795 -- Ada 2005 (AI-230): For most cases of anonymous access types, we 13796 -- simply use the level where the type is declared. This is true for 13797 -- stand-alone object declarations, and for anonymous access types 13798 -- associated with components the level is the same as that of the 13799 -- enclosing composite type. However, special treatment is needed for 13800 -- the cases of access parameters, return objects of an anonymous access 13801 -- type, and, in Ada 95, access discriminants of limited types. 13802 13803 if Ekind (Btyp) in Access_Kind then 13804 if Ekind (Btyp) = E_Anonymous_Access_Type then 13805 13806 -- If the type is a nonlocal anonymous access type (such as for 13807 -- an access parameter) we treat it as being declared at the 13808 -- library level to ensure that names such as X.all'access don't 13809 -- fail static accessibility checks. 13810 13811 if not Is_Local_Anonymous_Access (Typ) then 13812 return Scope_Depth (Standard_Standard); 13813 13814 -- If this is a return object, the accessibility level is that of 13815 -- the result subtype of the enclosing function. The test here is 13816 -- little complicated, because we have to account for extended 13817 -- return statements that have been rewritten as blocks, in which 13818 -- case we have to find and the Is_Return_Object attribute of the 13819 -- itype's associated object. It would be nice to find a way to 13820 -- simplify this test, but it doesn't seem worthwhile to add a new 13821 -- flag just for purposes of this test. ??? 13822 13823 elsif Ekind (Scope (Btyp)) = E_Return_Statement 13824 or else 13825 (Is_Itype (Btyp) 13826 and then Nkind (Associated_Node_For_Itype (Btyp)) = 13827 N_Object_Declaration 13828 and then Is_Return_Object 13829 (Defining_Identifier 13830 (Associated_Node_For_Itype (Btyp)))) 13831 then 13832 declare 13833 Scop : Entity_Id; 13834 13835 begin 13836 Scop := Scope (Scope (Btyp)); 13837 while Present (Scop) loop 13838 exit when Ekind (Scop) = E_Function; 13839 Scop := Scope (Scop); 13840 end loop; 13841 13842 -- Treat the return object's type as having the level of the 13843 -- function's result subtype (as per RM05-6.5(5.3/2)). 13844 13845 return Type_Access_Level (Etype (Scop)); 13846 end; 13847 end if; 13848 end if; 13849 13850 Btyp := Root_Type (Btyp); 13851 13852 -- The accessibility level of anonymous access types associated with 13853 -- discriminants is that of the current instance of the type, and 13854 -- that's deeper than the type itself (AARM 3.10.2 (12.3.21)). 13855 13856 -- AI-402: access discriminants have accessibility based on the 13857 -- object rather than the type in Ada 2005, so the above paragraph 13858 -- doesn't apply. 13859 13860 -- ??? Needs completion with rules from AI-416 13861 13862 if Ada_Version <= Ada_95 13863 and then Ekind (Typ) = E_Anonymous_Access_Type 13864 and then Present (Associated_Node_For_Itype (Typ)) 13865 and then Nkind (Associated_Node_For_Itype (Typ)) = 13866 N_Discriminant_Specification 13867 then 13868 return Scope_Depth (Enclosing_Dynamic_Scope (Btyp)) + 1; 13869 end if; 13870 end if; 13871 13872 -- Return library level for a generic formal type. This is done because 13873 -- RM(10.3.2) says that "The statically deeper relationship does not 13874 -- apply to ... a descendant of a generic formal type". Rather than 13875 -- checking at each point where a static accessibility check is 13876 -- performed to see if we are dealing with a formal type, this rule is 13877 -- implemented by having Type_Access_Level and Deepest_Type_Access_Level 13878 -- return extreme values for a formal type; Deepest_Type_Access_Level 13879 -- returns Int'Last. By calling the appropriate function from among the 13880 -- two, we ensure that the static accessibility check will pass if we 13881 -- happen to run into a formal type. More specifically, we should call 13882 -- Deepest_Type_Access_Level instead of Type_Access_Level whenever the 13883 -- call occurs as part of a static accessibility check and the error 13884 -- case is the case where the type's level is too shallow (as opposed 13885 -- to too deep). 13886 13887 if Is_Generic_Type (Root_Type (Btyp)) then 13888 return Scope_Depth (Standard_Standard); 13889 end if; 13890 13891 return Scope_Depth (Enclosing_Dynamic_Scope (Btyp)); 13892 end Type_Access_Level; 13893 13894 ------------------------------------ 13895 -- Type_Without_Stream_Operation -- 13896 ------------------------------------ 13897 13898 function Type_Without_Stream_Operation 13899 (T : Entity_Id; 13900 Op : TSS_Name_Type := TSS_Null) return Entity_Id 13901 is 13902 BT : constant Entity_Id := Base_Type (T); 13903 Op_Missing : Boolean; 13904 13905 begin 13906 if not Restriction_Active (No_Default_Stream_Attributes) then 13907 return Empty; 13908 end if; 13909 13910 if Is_Elementary_Type (T) then 13911 if Op = TSS_Null then 13912 Op_Missing := 13913 No (TSS (BT, TSS_Stream_Read)) 13914 or else No (TSS (BT, TSS_Stream_Write)); 13915 13916 else 13917 Op_Missing := No (TSS (BT, Op)); 13918 end if; 13919 13920 if Op_Missing then 13921 return T; 13922 else 13923 return Empty; 13924 end if; 13925 13926 elsif Is_Array_Type (T) then 13927 return Type_Without_Stream_Operation (Component_Type (T), Op); 13928 13929 elsif Is_Record_Type (T) then 13930 declare 13931 Comp : Entity_Id; 13932 C_Typ : Entity_Id; 13933 13934 begin 13935 Comp := First_Component (T); 13936 while Present (Comp) loop 13937 C_Typ := Type_Without_Stream_Operation (Etype (Comp), Op); 13938 13939 if Present (C_Typ) then 13940 return C_Typ; 13941 end if; 13942 13943 Next_Component (Comp); 13944 end loop; 13945 13946 return Empty; 13947 end; 13948 13949 elsif Is_Private_Type (T) 13950 and then Present (Full_View (T)) 13951 then 13952 return Type_Without_Stream_Operation (Full_View (T), Op); 13953 else 13954 return Empty; 13955 end if; 13956 end Type_Without_Stream_Operation; 13957 13958 ---------------------------- 13959 -- Unique_Defining_Entity -- 13960 ---------------------------- 13961 13962 function Unique_Defining_Entity (N : Node_Id) return Entity_Id is 13963 begin 13964 return Unique_Entity (Defining_Entity (N)); 13965 end Unique_Defining_Entity; 13966 13967 ------------------- 13968 -- Unique_Entity -- 13969 ------------------- 13970 13971 function Unique_Entity (E : Entity_Id) return Entity_Id is 13972 U : Entity_Id := E; 13973 P : Node_Id; 13974 13975 begin 13976 case Ekind (E) is 13977 when E_Constant => 13978 if Present (Full_View (E)) then 13979 U := Full_View (E); 13980 end if; 13981 13982 when Type_Kind => 13983 if Present (Full_View (E)) then 13984 U := Full_View (E); 13985 end if; 13986 13987 when E_Package_Body => 13988 P := Parent (E); 13989 13990 if Nkind (P) = N_Defining_Program_Unit_Name then 13991 P := Parent (P); 13992 end if; 13993 13994 U := Corresponding_Spec (P); 13995 13996 when E_Subprogram_Body => 13997 P := Parent (E); 13998 13999 if Nkind (P) = N_Defining_Program_Unit_Name then 14000 P := Parent (P); 14001 end if; 14002 14003 P := Parent (P); 14004 14005 if Nkind (P) = N_Subprogram_Body_Stub then 14006 if Present (Library_Unit (P)) then 14007 14008 -- Get to the function or procedure (generic) entity through 14009 -- the body entity. 14010 14011 U := 14012 Unique_Entity (Defining_Entity (Get_Body_From_Stub (P))); 14013 end if; 14014 else 14015 U := Corresponding_Spec (P); 14016 end if; 14017 14018 when Formal_Kind => 14019 if Present (Spec_Entity (E)) then 14020 U := Spec_Entity (E); 14021 end if; 14022 14023 when others => 14024 null; 14025 end case; 14026 14027 return U; 14028 end Unique_Entity; 14029 14030 ----------------- 14031 -- Unique_Name -- 14032 ----------------- 14033 14034 function Unique_Name (E : Entity_Id) return String is 14035 14036 -- Names of E_Subprogram_Body or E_Package_Body entities are not 14037 -- reliable, as they may not include the overloading suffix. Instead, 14038 -- when looking for the name of E or one of its enclosing scope, we get 14039 -- the name of the corresponding Unique_Entity. 14040 14041 function Get_Scoped_Name (E : Entity_Id) return String; 14042 -- Return the name of E prefixed by all the names of the scopes to which 14043 -- E belongs, except for Standard. 14044 14045 --------------------- 14046 -- Get_Scoped_Name -- 14047 --------------------- 14048 14049 function Get_Scoped_Name (E : Entity_Id) return String is 14050 Name : constant String := Get_Name_String (Chars (E)); 14051 begin 14052 if Has_Fully_Qualified_Name (E) 14053 or else Scope (E) = Standard_Standard 14054 then 14055 return Name; 14056 else 14057 return Get_Scoped_Name (Unique_Entity (Scope (E))) & "__" & Name; 14058 end if; 14059 end Get_Scoped_Name; 14060 14061 -- Start of processing for Unique_Name 14062 14063 begin 14064 if E = Standard_Standard then 14065 return Get_Name_String (Name_Standard); 14066 14067 elsif Scope (E) = Standard_Standard 14068 and then not (Ekind (E) = E_Package or else Is_Subprogram (E)) 14069 then 14070 return Get_Name_String (Name_Standard) & "__" & 14071 Get_Name_String (Chars (E)); 14072 14073 elsif Ekind (E) = E_Enumeration_Literal then 14074 return Unique_Name (Etype (E)) & "__" & Get_Name_String (Chars (E)); 14075 14076 else 14077 return Get_Scoped_Name (Unique_Entity (E)); 14078 end if; 14079 end Unique_Name; 14080 14081 --------------------- 14082 -- Unit_Is_Visible -- 14083 --------------------- 14084 14085 function Unit_Is_Visible (U : Entity_Id) return Boolean is 14086 Curr : constant Node_Id := Cunit (Current_Sem_Unit); 14087 Curr_Entity : constant Entity_Id := Cunit_Entity (Current_Sem_Unit); 14088 14089 function Unit_In_Parent_Context (Par_Unit : Node_Id) return Boolean; 14090 -- For a child unit, check whether unit appears in a with_clause 14091 -- of a parent. 14092 14093 function Unit_In_Context (Comp_Unit : Node_Id) return Boolean; 14094 -- Scan the context clause of one compilation unit looking for a 14095 -- with_clause for the unit in question. 14096 14097 ---------------------------- 14098 -- Unit_In_Parent_Context -- 14099 ---------------------------- 14100 14101 function Unit_In_Parent_Context (Par_Unit : Node_Id) return Boolean is 14102 begin 14103 if Unit_In_Context (Par_Unit) then 14104 return True; 14105 14106 elsif Is_Child_Unit (Defining_Entity (Unit (Par_Unit))) then 14107 return Unit_In_Parent_Context (Parent_Spec (Unit (Par_Unit))); 14108 14109 else 14110 return False; 14111 end if; 14112 end Unit_In_Parent_Context; 14113 14114 --------------------- 14115 -- Unit_In_Context -- 14116 --------------------- 14117 14118 function Unit_In_Context (Comp_Unit : Node_Id) return Boolean is 14119 Clause : Node_Id; 14120 14121 begin 14122 Clause := First (Context_Items (Comp_Unit)); 14123 while Present (Clause) loop 14124 if Nkind (Clause) = N_With_Clause then 14125 if Library_Unit (Clause) = U then 14126 return True; 14127 14128 -- The with_clause may denote a renaming of the unit we are 14129 -- looking for, eg. Text_IO which renames Ada.Text_IO. 14130 14131 elsif 14132 Renamed_Entity (Entity (Name (Clause))) = 14133 Defining_Entity (Unit (U)) 14134 then 14135 return True; 14136 end if; 14137 end if; 14138 14139 Next (Clause); 14140 end loop; 14141 14142 return False; 14143 end Unit_In_Context; 14144 14145 -- Start of processing for Unit_Is_Visible 14146 14147 begin 14148 -- The currrent unit is directly visible 14149 14150 if Curr = U then 14151 return True; 14152 14153 elsif Unit_In_Context (Curr) then 14154 return True; 14155 14156 -- If the current unit is a body, check the context of the spec 14157 14158 elsif Nkind (Unit (Curr)) = N_Package_Body 14159 or else 14160 (Nkind (Unit (Curr)) = N_Subprogram_Body 14161 and then not Acts_As_Spec (Unit (Curr))) 14162 then 14163 if Unit_In_Context (Library_Unit (Curr)) then 14164 return True; 14165 end if; 14166 end if; 14167 14168 -- If the spec is a child unit, examine the parents 14169 14170 if Is_Child_Unit (Curr_Entity) then 14171 if Nkind (Unit (Curr)) in N_Unit_Body then 14172 return 14173 Unit_In_Parent_Context 14174 (Parent_Spec (Unit (Library_Unit (Curr)))); 14175 else 14176 return Unit_In_Parent_Context (Parent_Spec (Unit (Curr))); 14177 end if; 14178 14179 else 14180 return False; 14181 end if; 14182 end Unit_Is_Visible; 14183 14184 ------------------------------ 14185 -- Universal_Interpretation -- 14186 ------------------------------ 14187 14188 function Universal_Interpretation (Opnd : Node_Id) return Entity_Id is 14189 Index : Interp_Index; 14190 It : Interp; 14191 14192 begin 14193 -- The argument may be a formal parameter of an operator or subprogram 14194 -- with multiple interpretations, or else an expression for an actual. 14195 14196 if Nkind (Opnd) = N_Defining_Identifier 14197 or else not Is_Overloaded (Opnd) 14198 then 14199 if Etype (Opnd) = Universal_Integer 14200 or else Etype (Opnd) = Universal_Real 14201 then 14202 return Etype (Opnd); 14203 else 14204 return Empty; 14205 end if; 14206 14207 else 14208 Get_First_Interp (Opnd, Index, It); 14209 while Present (It.Typ) loop 14210 if It.Typ = Universal_Integer 14211 or else It.Typ = Universal_Real 14212 then 14213 return It.Typ; 14214 end if; 14215 14216 Get_Next_Interp (Index, It); 14217 end loop; 14218 14219 return Empty; 14220 end if; 14221 end Universal_Interpretation; 14222 14223 --------------- 14224 -- Unqualify -- 14225 --------------- 14226 14227 function Unqualify (Expr : Node_Id) return Node_Id is 14228 begin 14229 -- Recurse to handle unlikely case of multiple levels of qualification 14230 14231 if Nkind (Expr) = N_Qualified_Expression then 14232 return Unqualify (Expression (Expr)); 14233 14234 -- Normal case, not a qualified expression 14235 14236 else 14237 return Expr; 14238 end if; 14239 end Unqualify; 14240 14241 ----------------------- 14242 -- Visible_Ancestors -- 14243 ----------------------- 14244 14245 function Visible_Ancestors (Typ : Entity_Id) return Elist_Id is 14246 List_1 : Elist_Id; 14247 List_2 : Elist_Id; 14248 Elmt : Elmt_Id; 14249 14250 begin 14251 pragma Assert (Is_Record_Type (Typ) 14252 and then Is_Tagged_Type (Typ)); 14253 14254 -- Collect all the parents and progenitors of Typ. If the full-view of 14255 -- private parents and progenitors is available then it is used to 14256 -- generate the list of visible ancestors; otherwise their partial 14257 -- view is added to the resulting list. 14258 14259 Collect_Parents 14260 (T => Typ, 14261 List => List_1, 14262 Use_Full_View => True); 14263 14264 Collect_Interfaces 14265 (T => Typ, 14266 Ifaces_List => List_2, 14267 Exclude_Parents => True, 14268 Use_Full_View => True); 14269 14270 -- Join the two lists. Avoid duplications because an interface may 14271 -- simultaneously be parent and progenitor of a type. 14272 14273 Elmt := First_Elmt (List_2); 14274 while Present (Elmt) loop 14275 Append_Unique_Elmt (Node (Elmt), List_1); 14276 Next_Elmt (Elmt); 14277 end loop; 14278 14279 return List_1; 14280 end Visible_Ancestors; 14281 14282 ---------------------- 14283 -- Within_Init_Proc -- 14284 ---------------------- 14285 14286 function Within_Init_Proc return Boolean is 14287 S : Entity_Id; 14288 14289 begin 14290 S := Current_Scope; 14291 while not Is_Overloadable (S) loop 14292 if S = Standard_Standard then 14293 return False; 14294 else 14295 S := Scope (S); 14296 end if; 14297 end loop; 14298 14299 return Is_Init_Proc (S); 14300 end Within_Init_Proc; 14301 14302 ---------------- 14303 -- Wrong_Type -- 14304 ---------------- 14305 14306 procedure Wrong_Type (Expr : Node_Id; Expected_Type : Entity_Id) is 14307 Found_Type : constant Entity_Id := First_Subtype (Etype (Expr)); 14308 Expec_Type : constant Entity_Id := First_Subtype (Expected_Type); 14309 14310 Matching_Field : Entity_Id; 14311 -- Entity to give a more precise suggestion on how to write a one- 14312 -- element positional aggregate. 14313 14314 function Has_One_Matching_Field return Boolean; 14315 -- Determines if Expec_Type is a record type with a single component or 14316 -- discriminant whose type matches the found type or is one dimensional 14317 -- array whose component type matches the found type. In the case of 14318 -- one discriminant, we ignore the variant parts. That's not accurate, 14319 -- but good enough for the warning. 14320 14321 ---------------------------- 14322 -- Has_One_Matching_Field -- 14323 ---------------------------- 14324 14325 function Has_One_Matching_Field return Boolean is 14326 E : Entity_Id; 14327 14328 begin 14329 Matching_Field := Empty; 14330 14331 if Is_Array_Type (Expec_Type) 14332 and then Number_Dimensions (Expec_Type) = 1 14333 and then 14334 Covers (Etype (Component_Type (Expec_Type)), Found_Type) 14335 then 14336 -- Use type name if available. This excludes multidimensional 14337 -- arrays and anonymous arrays. 14338 14339 if Comes_From_Source (Expec_Type) then 14340 Matching_Field := Expec_Type; 14341 14342 -- For an assignment, use name of target 14343 14344 elsif Nkind (Parent (Expr)) = N_Assignment_Statement 14345 and then Is_Entity_Name (Name (Parent (Expr))) 14346 then 14347 Matching_Field := Entity (Name (Parent (Expr))); 14348 end if; 14349 14350 return True; 14351 14352 elsif not Is_Record_Type (Expec_Type) then 14353 return False; 14354 14355 else 14356 E := First_Entity (Expec_Type); 14357 loop 14358 if No (E) then 14359 return False; 14360 14361 elsif not Ekind_In (E, E_Discriminant, E_Component) 14362 or else (Chars (E) = Name_uTag 14363 or else 14364 Chars (E) = Name_uParent) 14365 then 14366 Next_Entity (E); 14367 14368 else 14369 exit; 14370 end if; 14371 end loop; 14372 14373 if not Covers (Etype (E), Found_Type) then 14374 return False; 14375 14376 elsif Present (Next_Entity (E)) 14377 and then (Ekind (E) = E_Component 14378 or else Ekind (Next_Entity (E)) = E_Discriminant) 14379 then 14380 return False; 14381 14382 else 14383 Matching_Field := E; 14384 return True; 14385 end if; 14386 end if; 14387 end Has_One_Matching_Field; 14388 14389 -- Start of processing for Wrong_Type 14390 14391 begin 14392 -- Don't output message if either type is Any_Type, or if a message 14393 -- has already been posted for this node. We need to do the latter 14394 -- check explicitly (it is ordinarily done in Errout), because we 14395 -- are using ! to force the output of the error messages. 14396 14397 if Expec_Type = Any_Type 14398 or else Found_Type = Any_Type 14399 or else Error_Posted (Expr) 14400 then 14401 return; 14402 14403 -- If one of the types is a Taft-Amendment type and the other it its 14404 -- completion, it must be an illegal use of a TAT in the spec, for 14405 -- which an error was already emitted. Avoid cascaded errors. 14406 14407 elsif Is_Incomplete_Type (Expec_Type) 14408 and then Has_Completion_In_Body (Expec_Type) 14409 and then Full_View (Expec_Type) = Etype (Expr) 14410 then 14411 return; 14412 14413 elsif Is_Incomplete_Type (Etype (Expr)) 14414 and then Has_Completion_In_Body (Etype (Expr)) 14415 and then Full_View (Etype (Expr)) = Expec_Type 14416 then 14417 return; 14418 14419 -- In an instance, there is an ongoing problem with completion of 14420 -- type derived from private types. Their structure is what Gigi 14421 -- expects, but the Etype is the parent type rather than the 14422 -- derived private type itself. Do not flag error in this case. The 14423 -- private completion is an entity without a parent, like an Itype. 14424 -- Similarly, full and partial views may be incorrect in the instance. 14425 -- There is no simple way to insure that it is consistent ??? 14426 14427 elsif In_Instance then 14428 if Etype (Etype (Expr)) = Etype (Expected_Type) 14429 and then 14430 (Has_Private_Declaration (Expected_Type) 14431 or else Has_Private_Declaration (Etype (Expr))) 14432 and then No (Parent (Expected_Type)) 14433 then 14434 return; 14435 end if; 14436 end if; 14437 14438 -- An interesting special check. If the expression is parenthesized 14439 -- and its type corresponds to the type of the sole component of the 14440 -- expected record type, or to the component type of the expected one 14441 -- dimensional array type, then assume we have a bad aggregate attempt. 14442 14443 if Nkind (Expr) in N_Subexpr 14444 and then Paren_Count (Expr) /= 0 14445 and then Has_One_Matching_Field 14446 then 14447 Error_Msg_N ("positional aggregate cannot have one component", Expr); 14448 if Present (Matching_Field) then 14449 if Is_Array_Type (Expec_Type) then 14450 Error_Msg_NE 14451 ("\write instead `&''First ='> ...`", Expr, Matching_Field); 14452 14453 else 14454 Error_Msg_NE 14455 ("\write instead `& ='> ...`", Expr, Matching_Field); 14456 end if; 14457 end if; 14458 14459 -- Another special check, if we are looking for a pool-specific access 14460 -- type and we found an E_Access_Attribute_Type, then we have the case 14461 -- of an Access attribute being used in a context which needs a pool- 14462 -- specific type, which is never allowed. The one extra check we make 14463 -- is that the expected designated type covers the Found_Type. 14464 14465 elsif Is_Access_Type (Expec_Type) 14466 and then Ekind (Found_Type) = E_Access_Attribute_Type 14467 and then Ekind (Base_Type (Expec_Type)) /= E_General_Access_Type 14468 and then Ekind (Base_Type (Expec_Type)) /= E_Anonymous_Access_Type 14469 and then Covers 14470 (Designated_Type (Expec_Type), Designated_Type (Found_Type)) 14471 then 14472 Error_Msg_N -- CODEFIX 14473 ("result must be general access type!", Expr); 14474 Error_Msg_NE -- CODEFIX 14475 ("add ALL to }!", Expr, Expec_Type); 14476 14477 -- Another special check, if the expected type is an integer type, 14478 -- but the expression is of type System.Address, and the parent is 14479 -- an addition or subtraction operation whose left operand is the 14480 -- expression in question and whose right operand is of an integral 14481 -- type, then this is an attempt at address arithmetic, so give 14482 -- appropriate message. 14483 14484 elsif Is_Integer_Type (Expec_Type) 14485 and then Is_RTE (Found_Type, RE_Address) 14486 and then (Nkind (Parent (Expr)) = N_Op_Add 14487 or else 14488 Nkind (Parent (Expr)) = N_Op_Subtract) 14489 and then Expr = Left_Opnd (Parent (Expr)) 14490 and then Is_Integer_Type (Etype (Right_Opnd (Parent (Expr)))) 14491 then 14492 Error_Msg_N 14493 ("address arithmetic not predefined in package System", 14494 Parent (Expr)); 14495 Error_Msg_N 14496 ("\possible missing with/use of System.Storage_Elements", 14497 Parent (Expr)); 14498 return; 14499 14500 -- If the expected type is an anonymous access type, as for access 14501 -- parameters and discriminants, the error is on the designated types. 14502 14503 elsif Ekind (Expec_Type) = E_Anonymous_Access_Type then 14504 if Comes_From_Source (Expec_Type) then 14505 Error_Msg_NE ("expected}!", Expr, Expec_Type); 14506 else 14507 Error_Msg_NE 14508 ("expected an access type with designated}", 14509 Expr, Designated_Type (Expec_Type)); 14510 end if; 14511 14512 if Is_Access_Type (Found_Type) 14513 and then not Comes_From_Source (Found_Type) 14514 then 14515 Error_Msg_NE 14516 ("\\found an access type with designated}!", 14517 Expr, Designated_Type (Found_Type)); 14518 else 14519 if From_With_Type (Found_Type) then 14520 Error_Msg_NE ("\\found incomplete}!", Expr, Found_Type); 14521 Error_Msg_Qual_Level := 99; 14522 Error_Msg_NE -- CODEFIX 14523 ("\\missing `WITH &;", Expr, Scope (Found_Type)); 14524 Error_Msg_Qual_Level := 0; 14525 else 14526 Error_Msg_NE ("found}!", Expr, Found_Type); 14527 end if; 14528 end if; 14529 14530 -- Normal case of one type found, some other type expected 14531 14532 else 14533 -- If the names of the two types are the same, see if some number 14534 -- of levels of qualification will help. Don't try more than three 14535 -- levels, and if we get to standard, it's no use (and probably 14536 -- represents an error in the compiler) Also do not bother with 14537 -- internal scope names. 14538 14539 declare 14540 Expec_Scope : Entity_Id; 14541 Found_Scope : Entity_Id; 14542 14543 begin 14544 Expec_Scope := Expec_Type; 14545 Found_Scope := Found_Type; 14546 14547 for Levels in Int range 0 .. 3 loop 14548 if Chars (Expec_Scope) /= Chars (Found_Scope) then 14549 Error_Msg_Qual_Level := Levels; 14550 exit; 14551 end if; 14552 14553 Expec_Scope := Scope (Expec_Scope); 14554 Found_Scope := Scope (Found_Scope); 14555 14556 exit when Expec_Scope = Standard_Standard 14557 or else Found_Scope = Standard_Standard 14558 or else not Comes_From_Source (Expec_Scope) 14559 or else not Comes_From_Source (Found_Scope); 14560 end loop; 14561 end; 14562 14563 if Is_Record_Type (Expec_Type) 14564 and then Present (Corresponding_Remote_Type (Expec_Type)) 14565 then 14566 Error_Msg_NE ("expected}!", Expr, 14567 Corresponding_Remote_Type (Expec_Type)); 14568 else 14569 Error_Msg_NE ("expected}!", Expr, Expec_Type); 14570 end if; 14571 14572 if Is_Entity_Name (Expr) 14573 and then Is_Package_Or_Generic_Package (Entity (Expr)) 14574 then 14575 Error_Msg_N ("\\found package name!", Expr); 14576 14577 elsif Is_Entity_Name (Expr) 14578 and then 14579 (Ekind (Entity (Expr)) = E_Procedure 14580 or else 14581 Ekind (Entity (Expr)) = E_Generic_Procedure) 14582 then 14583 if Ekind (Expec_Type) = E_Access_Subprogram_Type then 14584 Error_Msg_N 14585 ("found procedure name, possibly missing Access attribute!", 14586 Expr); 14587 else 14588 Error_Msg_N 14589 ("\\found procedure name instead of function!", Expr); 14590 end if; 14591 14592 elsif Nkind (Expr) = N_Function_Call 14593 and then Ekind (Expec_Type) = E_Access_Subprogram_Type 14594 and then Etype (Designated_Type (Expec_Type)) = Etype (Expr) 14595 and then No (Parameter_Associations (Expr)) 14596 then 14597 Error_Msg_N 14598 ("found function name, possibly missing Access attribute!", 14599 Expr); 14600 14601 -- Catch common error: a prefix or infix operator which is not 14602 -- directly visible because the type isn't. 14603 14604 elsif Nkind (Expr) in N_Op 14605 and then Is_Overloaded (Expr) 14606 and then not Is_Immediately_Visible (Expec_Type) 14607 and then not Is_Potentially_Use_Visible (Expec_Type) 14608 and then not In_Use (Expec_Type) 14609 and then Has_Compatible_Type (Right_Opnd (Expr), Expec_Type) 14610 then 14611 Error_Msg_N 14612 ("operator of the type is not directly visible!", Expr); 14613 14614 elsif Ekind (Found_Type) = E_Void 14615 and then Present (Parent (Found_Type)) 14616 and then Nkind (Parent (Found_Type)) = N_Full_Type_Declaration 14617 then 14618 Error_Msg_NE ("\\found premature usage of}!", Expr, Found_Type); 14619 14620 else 14621 Error_Msg_NE ("\\found}!", Expr, Found_Type); 14622 end if; 14623 14624 -- A special check for cases like M1 and M2 = 0 where M1 and M2 are 14625 -- of the same modular type, and (M1 and M2) = 0 was intended. 14626 14627 if Expec_Type = Standard_Boolean 14628 and then Is_Modular_Integer_Type (Found_Type) 14629 and then Nkind_In (Parent (Expr), N_Op_And, N_Op_Or, N_Op_Xor) 14630 and then Nkind (Right_Opnd (Parent (Expr))) in N_Op_Compare 14631 then 14632 declare 14633 Op : constant Node_Id := Right_Opnd (Parent (Expr)); 14634 L : constant Node_Id := Left_Opnd (Op); 14635 R : constant Node_Id := Right_Opnd (Op); 14636 begin 14637 -- The case for the message is when the left operand of the 14638 -- comparison is the same modular type, or when it is an 14639 -- integer literal (or other universal integer expression), 14640 -- which would have been typed as the modular type if the 14641 -- parens had been there. 14642 14643 if (Etype (L) = Found_Type 14644 or else 14645 Etype (L) = Universal_Integer) 14646 and then Is_Integer_Type (Etype (R)) 14647 then 14648 Error_Msg_N 14649 ("\\possible missing parens for modular operation", Expr); 14650 end if; 14651 end; 14652 end if; 14653 14654 -- Reset error message qualification indication 14655 14656 Error_Msg_Qual_Level := 0; 14657 end if; 14658 end Wrong_Type; 14659 14660end Sem_Util; 14661