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-2015, 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 Treepr; -- ???For debugging code below 27 28with Aspects; use Aspects; 29with Atree; use Atree; 30with Casing; use Casing; 31with Checks; use Checks; 32with Debug; use Debug; 33with Elists; use Elists; 34with Errout; use Errout; 35with Exp_Ch11; use Exp_Ch11; 36with Exp_Disp; use Exp_Disp; 37with Exp_Util; use Exp_Util; 38with Fname; use Fname; 39with Freeze; use Freeze; 40with Ghost; use Ghost; 41with Lib; use Lib; 42with Lib.Xref; use Lib.Xref; 43with Namet.Sp; use Namet.Sp; 44with Nlists; use Nlists; 45with Nmake; use Nmake; 46with Output; use Output; 47with Restrict; use Restrict; 48with Rident; use Rident; 49with Rtsfind; use Rtsfind; 50with Sem; use Sem; 51with Sem_Aux; use Sem_Aux; 52with Sem_Attr; use Sem_Attr; 53with Sem_Ch6; use Sem_Ch6; 54with Sem_Ch8; use Sem_Ch8; 55with Sem_Ch13; use Sem_Ch13; 56with Sem_Disp; use Sem_Disp; 57with Sem_Eval; use Sem_Eval; 58with Sem_Prag; use Sem_Prag; 59with Sem_Res; use Sem_Res; 60with Sem_Warn; use Sem_Warn; 61with Sem_Type; use Sem_Type; 62with Sinfo; use Sinfo; 63with Sinput; use Sinput; 64with Stand; use Stand; 65with Style; 66with Stringt; use Stringt; 67with Targparm; use Targparm; 68with Tbuild; use Tbuild; 69with Ttypes; use Ttypes; 70with Uname; use Uname; 71 72with GNAT.HTable; use GNAT.HTable; 73 74package body Sem_Util is 75 76 ---------------------------------------- 77 -- Global Variables for New_Copy_Tree -- 78 ---------------------------------------- 79 80 -- These global variables are used by New_Copy_Tree. See description of the 81 -- body of this subprogram for details. Global variables can be safely used 82 -- by New_Copy_Tree, since there is no case of a recursive call from the 83 -- processing inside New_Copy_Tree. 84 85 NCT_Hash_Threshold : constant := 20; 86 -- If there are more than this number of pairs of entries in the map, then 87 -- Hash_Tables_Used will be set, and the hash tables will be initialized 88 -- and used for the searches. 89 90 NCT_Hash_Tables_Used : Boolean := False; 91 -- Set to True if hash tables are in use 92 93 NCT_Table_Entries : Nat := 0; 94 -- Count entries in table to see if threshold is reached 95 96 NCT_Hash_Table_Setup : Boolean := False; 97 -- Set to True if hash table contains data. We set this True if we setup 98 -- the hash table with data, and leave it set permanently from then on, 99 -- this is a signal that second and subsequent users of the hash table 100 -- must clear the old entries before reuse. 101 102 subtype NCT_Header_Num is Int range 0 .. 511; 103 -- Defines range of headers in hash tables (512 headers) 104 105 ----------------------- 106 -- Local Subprograms -- 107 ----------------------- 108 109 function Build_Component_Subtype 110 (C : List_Id; 111 Loc : Source_Ptr; 112 T : Entity_Id) return Node_Id; 113 -- This function builds the subtype for Build_Actual_Subtype_Of_Component 114 -- and Build_Discriminal_Subtype_Of_Component. C is a list of constraints, 115 -- Loc is the source location, T is the original subtype. 116 117 function Has_Enabled_Property 118 (Item_Id : Entity_Id; 119 Property : Name_Id) return Boolean; 120 -- Subsidiary to routines Async_xxx_Enabled and Effective_xxx_Enabled. 121 -- Determine whether an abstract state or a variable denoted by entity 122 -- Item_Id has enabled property Property. 123 124 function Has_Null_Extension (T : Entity_Id) return Boolean; 125 -- T is a derived tagged type. Check whether the type extension is null. 126 -- If the parent type is fully initialized, T can be treated as such. 127 128 function Is_Fully_Initialized_Variant (Typ : Entity_Id) return Boolean; 129 -- Subsidiary to Is_Fully_Initialized_Type. For an unconstrained type 130 -- with discriminants whose default values are static, examine only the 131 -- components in the selected variant to determine whether all of them 132 -- have a default. 133 134 ------------------------------ 135 -- Abstract_Interface_List -- 136 ------------------------------ 137 138 function Abstract_Interface_List (Typ : Entity_Id) return List_Id is 139 Nod : Node_Id; 140 141 begin 142 if Is_Concurrent_Type (Typ) then 143 144 -- If we are dealing with a synchronized subtype, go to the base 145 -- type, whose declaration has the interface list. 146 147 -- Shouldn't this be Declaration_Node??? 148 149 Nod := Parent (Base_Type (Typ)); 150 151 if Nkind (Nod) = N_Full_Type_Declaration then 152 return Empty_List; 153 end if; 154 155 elsif Ekind (Typ) = E_Record_Type_With_Private then 156 if Nkind (Parent (Typ)) = N_Full_Type_Declaration then 157 Nod := Type_Definition (Parent (Typ)); 158 159 elsif Nkind (Parent (Typ)) = N_Private_Type_Declaration then 160 if Present (Full_View (Typ)) 161 and then 162 Nkind (Parent (Full_View (Typ))) = N_Full_Type_Declaration 163 then 164 Nod := Type_Definition (Parent (Full_View (Typ))); 165 166 -- If the full-view is not available we cannot do anything else 167 -- here (the source has errors). 168 169 else 170 return Empty_List; 171 end if; 172 173 -- Support for generic formals with interfaces is still missing ??? 174 175 elsif Nkind (Parent (Typ)) = N_Formal_Type_Declaration then 176 return Empty_List; 177 178 else 179 pragma Assert 180 (Nkind (Parent (Typ)) = N_Private_Extension_Declaration); 181 Nod := Parent (Typ); 182 end if; 183 184 elsif Ekind (Typ) = E_Record_Subtype then 185 Nod := Type_Definition (Parent (Etype (Typ))); 186 187 elsif Ekind (Typ) = E_Record_Subtype_With_Private then 188 189 -- Recurse, because parent may still be a private extension. Also 190 -- note that the full view of the subtype or the full view of its 191 -- base type may (both) be unavailable. 192 193 return Abstract_Interface_List (Etype (Typ)); 194 195 else pragma Assert ((Ekind (Typ)) = E_Record_Type); 196 if Nkind (Parent (Typ)) = N_Formal_Type_Declaration then 197 Nod := Formal_Type_Definition (Parent (Typ)); 198 else 199 Nod := Type_Definition (Parent (Typ)); 200 end if; 201 end if; 202 203 return Interface_List (Nod); 204 end Abstract_Interface_List; 205 206 -------------------------------- 207 -- Add_Access_Type_To_Process -- 208 -------------------------------- 209 210 procedure Add_Access_Type_To_Process (E : Entity_Id; A : Entity_Id) is 211 L : Elist_Id; 212 213 begin 214 Ensure_Freeze_Node (E); 215 L := Access_Types_To_Process (Freeze_Node (E)); 216 217 if No (L) then 218 L := New_Elmt_List; 219 Set_Access_Types_To_Process (Freeze_Node (E), L); 220 end if; 221 222 Append_Elmt (A, L); 223 end Add_Access_Type_To_Process; 224 225 -------------------------- 226 -- Add_Block_Identifier -- 227 -------------------------- 228 229 procedure Add_Block_Identifier (N : Node_Id; Id : out Entity_Id) is 230 Loc : constant Source_Ptr := Sloc (N); 231 232 begin 233 pragma Assert (Nkind (N) = N_Block_Statement); 234 235 -- The block already has a label, return its entity 236 237 if Present (Identifier (N)) then 238 Id := Entity (Identifier (N)); 239 240 -- Create a new block label and set its attributes 241 242 else 243 Id := New_Internal_Entity (E_Block, Current_Scope, Loc, 'B'); 244 Set_Etype (Id, Standard_Void_Type); 245 Set_Parent (Id, N); 246 247 Set_Identifier (N, New_Occurrence_Of (Id, Loc)); 248 Set_Block_Node (Id, Identifier (N)); 249 end if; 250 end Add_Block_Identifier; 251 252 ---------------------------- 253 -- Add_Global_Declaration -- 254 ---------------------------- 255 256 procedure Add_Global_Declaration (N : Node_Id) is 257 Aux_Node : constant Node_Id := Aux_Decls_Node (Cunit (Current_Sem_Unit)); 258 259 begin 260 if No (Declarations (Aux_Node)) then 261 Set_Declarations (Aux_Node, New_List); 262 end if; 263 264 Append_To (Declarations (Aux_Node), N); 265 Analyze (N); 266 end Add_Global_Declaration; 267 268 -------------------------------- 269 -- Address_Integer_Convert_OK -- 270 -------------------------------- 271 272 function Address_Integer_Convert_OK (T1, T2 : Entity_Id) return Boolean is 273 begin 274 if Allow_Integer_Address 275 and then ((Is_Descendent_Of_Address (T1) 276 and then Is_Private_Type (T1) 277 and then Is_Integer_Type (T2)) 278 or else 279 (Is_Descendent_Of_Address (T2) 280 and then Is_Private_Type (T2) 281 and then Is_Integer_Type (T1))) 282 then 283 return True; 284 else 285 return False; 286 end if; 287 end Address_Integer_Convert_OK; 288 289 ----------------- 290 -- Addressable -- 291 ----------------- 292 293 -- For now, just 8/16/32/64. but analyze later if AAMP is special??? 294 295 function Addressable (V : Uint) return Boolean is 296 begin 297 return V = Uint_8 or else 298 V = Uint_16 or else 299 V = Uint_32 or else 300 V = Uint_64; 301 end Addressable; 302 303 function Addressable (V : Int) return Boolean is 304 begin 305 return V = 8 or else 306 V = 16 or else 307 V = 32 or else 308 V = 64; 309 end Addressable; 310 311 --------------------------------- 312 -- Aggregate_Constraint_Checks -- 313 --------------------------------- 314 315 procedure Aggregate_Constraint_Checks 316 (Exp : Node_Id; 317 Check_Typ : Entity_Id) 318 is 319 Exp_Typ : constant Entity_Id := Etype (Exp); 320 321 begin 322 if Raises_Constraint_Error (Exp) then 323 return; 324 end if; 325 326 -- Ada 2005 (AI-230): Generate a conversion to an anonymous access 327 -- component's type to force the appropriate accessibility checks. 328 329 -- Ada 2005 (AI-231): Generate conversion to the null-excluding 330 -- type to force the corresponding run-time check 331 332 if Is_Access_Type (Check_Typ) 333 and then ((Is_Local_Anonymous_Access (Check_Typ)) 334 or else (Can_Never_Be_Null (Check_Typ) 335 and then not Can_Never_Be_Null (Exp_Typ))) 336 then 337 Rewrite (Exp, Convert_To (Check_Typ, Relocate_Node (Exp))); 338 Analyze_And_Resolve (Exp, Check_Typ); 339 Check_Unset_Reference (Exp); 340 end if; 341 342 -- This is really expansion activity, so make sure that expansion is 343 -- on and is allowed. In GNATprove mode, we also want check flags to 344 -- be added in the tree, so that the formal verification can rely on 345 -- those to be present. In GNATprove mode for formal verification, some 346 -- treatment typically only done during expansion needs to be performed 347 -- on the tree, but it should not be applied inside generics. Otherwise, 348 -- this breaks the name resolution mechanism for generic instances. 349 350 if not Expander_Active 351 and (Inside_A_Generic or not Full_Analysis or not GNATprove_Mode) 352 then 353 return; 354 end if; 355 356 -- First check if we have to insert discriminant checks 357 358 if Has_Discriminants (Exp_Typ) then 359 Apply_Discriminant_Check (Exp, Check_Typ); 360 361 -- Next emit length checks for array aggregates 362 363 elsif Is_Array_Type (Exp_Typ) then 364 Apply_Length_Check (Exp, Check_Typ); 365 366 -- Finally emit scalar and string checks. If we are dealing with a 367 -- scalar literal we need to check by hand because the Etype of 368 -- literals is not necessarily correct. 369 370 elsif Is_Scalar_Type (Exp_Typ) 371 and then Compile_Time_Known_Value (Exp) 372 then 373 if Is_Out_Of_Range (Exp, Base_Type (Check_Typ)) then 374 Apply_Compile_Time_Constraint_Error 375 (Exp, "value not in range of}??", CE_Range_Check_Failed, 376 Ent => Base_Type (Check_Typ), 377 Typ => Base_Type (Check_Typ)); 378 379 elsif Is_Out_Of_Range (Exp, Check_Typ) then 380 Apply_Compile_Time_Constraint_Error 381 (Exp, "value not in range of}??", CE_Range_Check_Failed, 382 Ent => Check_Typ, 383 Typ => Check_Typ); 384 385 elsif not Range_Checks_Suppressed (Check_Typ) then 386 Apply_Scalar_Range_Check (Exp, Check_Typ); 387 end if; 388 389 -- Verify that target type is also scalar, to prevent view anomalies 390 -- in instantiations. 391 392 elsif (Is_Scalar_Type (Exp_Typ) 393 or else Nkind (Exp) = N_String_Literal) 394 and then Is_Scalar_Type (Check_Typ) 395 and then Exp_Typ /= Check_Typ 396 then 397 if Is_Entity_Name (Exp) 398 and then Ekind (Entity (Exp)) = E_Constant 399 then 400 -- If expression is a constant, it is worthwhile checking whether 401 -- it is a bound of the type. 402 403 if (Is_Entity_Name (Type_Low_Bound (Check_Typ)) 404 and then Entity (Exp) = Entity (Type_Low_Bound (Check_Typ))) 405 or else 406 (Is_Entity_Name (Type_High_Bound (Check_Typ)) 407 and then Entity (Exp) = Entity (Type_High_Bound (Check_Typ))) 408 then 409 return; 410 411 else 412 Rewrite (Exp, Convert_To (Check_Typ, Relocate_Node (Exp))); 413 Analyze_And_Resolve (Exp, Check_Typ); 414 Check_Unset_Reference (Exp); 415 end if; 416 417 -- Could use a comment on this case ??? 418 419 else 420 Rewrite (Exp, Convert_To (Check_Typ, Relocate_Node (Exp))); 421 Analyze_And_Resolve (Exp, Check_Typ); 422 Check_Unset_Reference (Exp); 423 end if; 424 425 end if; 426 end Aggregate_Constraint_Checks; 427 428 ----------------------- 429 -- Alignment_In_Bits -- 430 ----------------------- 431 432 function Alignment_In_Bits (E : Entity_Id) return Uint is 433 begin 434 return Alignment (E) * System_Storage_Unit; 435 end Alignment_In_Bits; 436 437 -------------------------------------- 438 -- All_Composite_Constraints_Static -- 439 -------------------------------------- 440 441 function All_Composite_Constraints_Static 442 (Constr : Node_Id) return Boolean 443 is 444 begin 445 if No (Constr) or else Error_Posted (Constr) then 446 return True; 447 end if; 448 449 case Nkind (Constr) is 450 when N_Subexpr => 451 if Nkind (Constr) in N_Has_Entity 452 and then Present (Entity (Constr)) 453 then 454 if Is_Type (Entity (Constr)) then 455 return 456 not Is_Discrete_Type (Entity (Constr)) 457 or else Is_OK_Static_Subtype (Entity (Constr)); 458 end if; 459 460 elsif Nkind (Constr) = N_Range then 461 return 462 Is_OK_Static_Expression (Low_Bound (Constr)) 463 and then 464 Is_OK_Static_Expression (High_Bound (Constr)); 465 466 elsif Nkind (Constr) = N_Attribute_Reference 467 and then Attribute_Name (Constr) = Name_Range 468 then 469 return 470 Is_OK_Static_Expression 471 (Type_Low_Bound (Etype (Prefix (Constr)))) 472 and then 473 Is_OK_Static_Expression 474 (Type_High_Bound (Etype (Prefix (Constr)))); 475 end if; 476 477 return 478 not Present (Etype (Constr)) -- previous error 479 or else not Is_Discrete_Type (Etype (Constr)) 480 or else Is_OK_Static_Expression (Constr); 481 482 when N_Discriminant_Association => 483 return All_Composite_Constraints_Static (Expression (Constr)); 484 485 when N_Range_Constraint => 486 return 487 All_Composite_Constraints_Static (Range_Expression (Constr)); 488 489 when N_Index_Or_Discriminant_Constraint => 490 declare 491 One_Cstr : Entity_Id; 492 begin 493 One_Cstr := First (Constraints (Constr)); 494 while Present (One_Cstr) loop 495 if not All_Composite_Constraints_Static (One_Cstr) then 496 return False; 497 end if; 498 499 Next (One_Cstr); 500 end loop; 501 end; 502 503 return True; 504 505 when N_Subtype_Indication => 506 return 507 All_Composite_Constraints_Static (Subtype_Mark (Constr)) 508 and then 509 All_Composite_Constraints_Static (Constraint (Constr)); 510 511 when others => 512 raise Program_Error; 513 end case; 514 end All_Composite_Constraints_Static; 515 516 --------------------------------- 517 -- Append_Inherited_Subprogram -- 518 --------------------------------- 519 520 procedure Append_Inherited_Subprogram (S : Entity_Id) is 521 Par : constant Entity_Id := Alias (S); 522 -- The parent subprogram 523 524 Scop : constant Entity_Id := Scope (Par); 525 -- The scope of definition of the parent subprogram 526 527 Typ : constant Entity_Id := Defining_Entity (Parent (S)); 528 -- The derived type of which S is a primitive operation 529 530 Decl : Node_Id; 531 Next_E : Entity_Id; 532 533 begin 534 if Ekind (Current_Scope) = E_Package 535 and then In_Private_Part (Current_Scope) 536 and then Has_Private_Declaration (Typ) 537 and then Is_Tagged_Type (Typ) 538 and then Scop = Current_Scope 539 then 540 -- The inherited operation is available at the earliest place after 541 -- the derived type declaration ( RM 7.3.1 (6/1)). This is only 542 -- relevant for type extensions. If the parent operation appears 543 -- after the type extension, the operation is not visible. 544 545 Decl := First 546 (Visible_Declarations 547 (Package_Specification (Current_Scope))); 548 while Present (Decl) loop 549 if Nkind (Decl) = N_Private_Extension_Declaration 550 and then Defining_Entity (Decl) = Typ 551 then 552 if Sloc (Decl) > Sloc (Par) then 553 Next_E := Next_Entity (Par); 554 Set_Next_Entity (Par, S); 555 Set_Next_Entity (S, Next_E); 556 return; 557 558 else 559 exit; 560 end if; 561 end if; 562 563 Next (Decl); 564 end loop; 565 end if; 566 567 -- If partial view is not a type extension, or it appears before the 568 -- subprogram declaration, insert normally at end of entity list. 569 570 Append_Entity (S, Current_Scope); 571 end Append_Inherited_Subprogram; 572 573 ----------------------------------------- 574 -- Apply_Compile_Time_Constraint_Error -- 575 ----------------------------------------- 576 577 procedure Apply_Compile_Time_Constraint_Error 578 (N : Node_Id; 579 Msg : String; 580 Reason : RT_Exception_Code; 581 Ent : Entity_Id := Empty; 582 Typ : Entity_Id := Empty; 583 Loc : Source_Ptr := No_Location; 584 Rep : Boolean := True; 585 Warn : Boolean := False) 586 is 587 Stat : constant Boolean := Is_Static_Expression (N); 588 R_Stat : constant Node_Id := 589 Make_Raise_Constraint_Error (Sloc (N), Reason => Reason); 590 Rtyp : Entity_Id; 591 592 begin 593 if No (Typ) then 594 Rtyp := Etype (N); 595 else 596 Rtyp := Typ; 597 end if; 598 599 Discard_Node 600 (Compile_Time_Constraint_Error (N, Msg, Ent, Loc, Warn => Warn)); 601 602 if not Rep then 603 return; 604 end if; 605 606 -- Now we replace the node by an N_Raise_Constraint_Error node 607 -- This does not need reanalyzing, so set it as analyzed now. 608 609 Rewrite (N, R_Stat); 610 Set_Analyzed (N, True); 611 612 Set_Etype (N, Rtyp); 613 Set_Raises_Constraint_Error (N); 614 615 -- Now deal with possible local raise handling 616 617 Possible_Local_Raise (N, Standard_Constraint_Error); 618 619 -- If the original expression was marked as static, the result is 620 -- still marked as static, but the Raises_Constraint_Error flag is 621 -- always set so that further static evaluation is not attempted. 622 623 if Stat then 624 Set_Is_Static_Expression (N); 625 end if; 626 end Apply_Compile_Time_Constraint_Error; 627 628 --------------------------- 629 -- Async_Readers_Enabled -- 630 --------------------------- 631 632 function Async_Readers_Enabled (Id : Entity_Id) return Boolean is 633 begin 634 return Has_Enabled_Property (Id, Name_Async_Readers); 635 end Async_Readers_Enabled; 636 637 --------------------------- 638 -- Async_Writers_Enabled -- 639 --------------------------- 640 641 function Async_Writers_Enabled (Id : Entity_Id) return Boolean is 642 begin 643 return Has_Enabled_Property (Id, Name_Async_Writers); 644 end Async_Writers_Enabled; 645 646 -------------------------------------- 647 -- Available_Full_View_Of_Component -- 648 -------------------------------------- 649 650 function Available_Full_View_Of_Component (T : Entity_Id) return Boolean is 651 ST : constant Entity_Id := Scope (T); 652 SCT : constant Entity_Id := Scope (Component_Type (T)); 653 begin 654 return In_Open_Scopes (ST) 655 and then In_Open_Scopes (SCT) 656 and then Scope_Depth (ST) >= Scope_Depth (SCT); 657 end Available_Full_View_Of_Component; 658 659 ------------------- 660 -- Bad_Attribute -- 661 ------------------- 662 663 procedure Bad_Attribute 664 (N : Node_Id; 665 Nam : Name_Id; 666 Warn : Boolean := False) 667 is 668 begin 669 Error_Msg_Warn := Warn; 670 Error_Msg_N ("unrecognized attribute&<<", N); 671 672 -- Check for possible misspelling 673 674 Error_Msg_Name_1 := First_Attribute_Name; 675 while Error_Msg_Name_1 <= Last_Attribute_Name loop 676 if Is_Bad_Spelling_Of (Nam, Error_Msg_Name_1) then 677 Error_Msg_N -- CODEFIX 678 ("\possible misspelling of %<<", N); 679 exit; 680 end if; 681 682 Error_Msg_Name_1 := Error_Msg_Name_1 + 1; 683 end loop; 684 end Bad_Attribute; 685 686 -------------------------------- 687 -- Bad_Predicated_Subtype_Use -- 688 -------------------------------- 689 690 procedure Bad_Predicated_Subtype_Use 691 (Msg : String; 692 N : Node_Id; 693 Typ : Entity_Id; 694 Suggest_Static : Boolean := False) 695 is 696 Gen : Entity_Id; 697 698 begin 699 -- Avoid cascaded errors 700 701 if Error_Posted (N) then 702 return; 703 end if; 704 705 if Inside_A_Generic then 706 Gen := Current_Scope; 707 while Present (Gen) and then Ekind (Gen) /= E_Generic_Package loop 708 Gen := Scope (Gen); 709 end loop; 710 711 if No (Gen) then 712 return; 713 end if; 714 715 if Is_Generic_Formal (Typ) and then Is_Discrete_Type (Typ) then 716 Set_No_Predicate_On_Actual (Typ); 717 end if; 718 719 elsif Has_Predicates (Typ) then 720 if Is_Generic_Actual_Type (Typ) then 721 722 -- The restriction on loop parameters is only that the type 723 -- should have no dynamic predicates. 724 725 if Nkind (Parent (N)) = N_Loop_Parameter_Specification 726 and then not Has_Dynamic_Predicate_Aspect (Typ) 727 and then Is_OK_Static_Subtype (Typ) 728 then 729 return; 730 end if; 731 732 Gen := Current_Scope; 733 while not Is_Generic_Instance (Gen) loop 734 Gen := Scope (Gen); 735 end loop; 736 737 pragma Assert (Present (Gen)); 738 739 if Ekind (Gen) = E_Package and then In_Package_Body (Gen) then 740 Error_Msg_Warn := SPARK_Mode /= On; 741 Error_Msg_FE (Msg & "<<", N, Typ); 742 Error_Msg_F ("\Program_Error [<<", N); 743 744 Insert_Action (N, 745 Make_Raise_Program_Error (Sloc (N), 746 Reason => PE_Bad_Predicated_Generic_Type)); 747 748 else 749 Error_Msg_FE (Msg & "<<", N, Typ); 750 end if; 751 752 else 753 Error_Msg_FE (Msg, N, Typ); 754 end if; 755 756 -- Emit an optional suggestion on how to remedy the error if the 757 -- context warrants it. 758 759 if Suggest_Static and then Has_Static_Predicate (Typ) then 760 Error_Msg_FE ("\predicate of & should be marked static", N, Typ); 761 end if; 762 end if; 763 end Bad_Predicated_Subtype_Use; 764 765 ----------------------------------------- 766 -- Bad_Unordered_Enumeration_Reference -- 767 ----------------------------------------- 768 769 function Bad_Unordered_Enumeration_Reference 770 (N : Node_Id; 771 T : Entity_Id) return Boolean 772 is 773 begin 774 return Is_Enumeration_Type (T) 775 and then Warn_On_Unordered_Enumeration_Type 776 and then not Is_Generic_Type (T) 777 and then Comes_From_Source (N) 778 and then not Has_Pragma_Ordered (T) 779 and then not In_Same_Extended_Unit (N, T); 780 end Bad_Unordered_Enumeration_Reference; 781 782 -------------------------- 783 -- Build_Actual_Subtype -- 784 -------------------------- 785 786 function Build_Actual_Subtype 787 (T : Entity_Id; 788 N : Node_Or_Entity_Id) return Node_Id 789 is 790 Loc : Source_Ptr; 791 -- Normally Sloc (N), but may point to corresponding body in some cases 792 793 Constraints : List_Id; 794 Decl : Node_Id; 795 Discr : Entity_Id; 796 Hi : Node_Id; 797 Lo : Node_Id; 798 Subt : Entity_Id; 799 Disc_Type : Entity_Id; 800 Obj : Node_Id; 801 802 begin 803 Loc := Sloc (N); 804 805 if Nkind (N) = N_Defining_Identifier then 806 Obj := New_Occurrence_Of (N, Loc); 807 808 -- If this is a formal parameter of a subprogram declaration, and 809 -- we are compiling the body, we want the declaration for the 810 -- actual subtype to carry the source position of the body, to 811 -- prevent anomalies in gdb when stepping through the code. 812 813 if Is_Formal (N) then 814 declare 815 Decl : constant Node_Id := Unit_Declaration_Node (Scope (N)); 816 begin 817 if Nkind (Decl) = N_Subprogram_Declaration 818 and then Present (Corresponding_Body (Decl)) 819 then 820 Loc := Sloc (Corresponding_Body (Decl)); 821 end if; 822 end; 823 end if; 824 825 else 826 Obj := N; 827 end if; 828 829 if Is_Array_Type (T) then 830 Constraints := New_List; 831 for J in 1 .. Number_Dimensions (T) loop 832 833 -- Build an array subtype declaration with the nominal subtype and 834 -- the bounds of the actual. Add the declaration in front of the 835 -- local declarations for the subprogram, for analysis before any 836 -- reference to the formal in the body. 837 838 Lo := 839 Make_Attribute_Reference (Loc, 840 Prefix => 841 Duplicate_Subexpr_No_Checks (Obj, Name_Req => True), 842 Attribute_Name => Name_First, 843 Expressions => New_List ( 844 Make_Integer_Literal (Loc, J))); 845 846 Hi := 847 Make_Attribute_Reference (Loc, 848 Prefix => 849 Duplicate_Subexpr_No_Checks (Obj, Name_Req => True), 850 Attribute_Name => Name_Last, 851 Expressions => New_List ( 852 Make_Integer_Literal (Loc, J))); 853 854 Append (Make_Range (Loc, Lo, Hi), Constraints); 855 end loop; 856 857 -- If the type has unknown discriminants there is no constrained 858 -- subtype to build. This is never called for a formal or for a 859 -- lhs, so returning the type is ok ??? 860 861 elsif Has_Unknown_Discriminants (T) then 862 return T; 863 864 else 865 Constraints := New_List; 866 867 -- Type T is a generic derived type, inherit the discriminants from 868 -- the parent type. 869 870 if Is_Private_Type (T) 871 and then No (Full_View (T)) 872 873 -- T was flagged as an error if it was declared as a formal 874 -- derived type with known discriminants. In this case there 875 -- is no need to look at the parent type since T already carries 876 -- its own discriminants. 877 878 and then not Error_Posted (T) 879 then 880 Disc_Type := Etype (Base_Type (T)); 881 else 882 Disc_Type := T; 883 end if; 884 885 Discr := First_Discriminant (Disc_Type); 886 while Present (Discr) loop 887 Append_To (Constraints, 888 Make_Selected_Component (Loc, 889 Prefix => 890 Duplicate_Subexpr_No_Checks (Obj), 891 Selector_Name => New_Occurrence_Of (Discr, Loc))); 892 Next_Discriminant (Discr); 893 end loop; 894 end if; 895 896 Subt := Make_Temporary (Loc, 'S', Related_Node => N); 897 Set_Is_Internal (Subt); 898 899 Decl := 900 Make_Subtype_Declaration (Loc, 901 Defining_Identifier => Subt, 902 Subtype_Indication => 903 Make_Subtype_Indication (Loc, 904 Subtype_Mark => New_Occurrence_Of (T, Loc), 905 Constraint => 906 Make_Index_Or_Discriminant_Constraint (Loc, 907 Constraints => Constraints))); 908 909 Mark_Rewrite_Insertion (Decl); 910 return Decl; 911 end Build_Actual_Subtype; 912 913 --------------------------------------- 914 -- Build_Actual_Subtype_Of_Component -- 915 --------------------------------------- 916 917 function Build_Actual_Subtype_Of_Component 918 (T : Entity_Id; 919 N : Node_Id) return Node_Id 920 is 921 Loc : constant Source_Ptr := Sloc (N); 922 P : constant Node_Id := Prefix (N); 923 D : Elmt_Id; 924 Id : Node_Id; 925 Index_Typ : Entity_Id; 926 927 Desig_Typ : Entity_Id; 928 -- This is either a copy of T, or if T is an access type, then it is 929 -- the directly designated type of this access type. 930 931 function Build_Actual_Array_Constraint return List_Id; 932 -- If one or more of the bounds of the component depends on 933 -- discriminants, build actual constraint using the discriminants 934 -- of the prefix. 935 936 function Build_Actual_Record_Constraint return List_Id; 937 -- Similar to previous one, for discriminated components constrained 938 -- by the discriminant of the enclosing object. 939 940 ----------------------------------- 941 -- Build_Actual_Array_Constraint -- 942 ----------------------------------- 943 944 function Build_Actual_Array_Constraint return List_Id is 945 Constraints : constant List_Id := New_List; 946 Indx : Node_Id; 947 Hi : Node_Id; 948 Lo : Node_Id; 949 Old_Hi : Node_Id; 950 Old_Lo : Node_Id; 951 952 begin 953 Indx := First_Index (Desig_Typ); 954 while Present (Indx) loop 955 Old_Lo := Type_Low_Bound (Etype (Indx)); 956 Old_Hi := Type_High_Bound (Etype (Indx)); 957 958 if Denotes_Discriminant (Old_Lo) then 959 Lo := 960 Make_Selected_Component (Loc, 961 Prefix => New_Copy_Tree (P), 962 Selector_Name => New_Occurrence_Of (Entity (Old_Lo), Loc)); 963 964 else 965 Lo := New_Copy_Tree (Old_Lo); 966 967 -- The new bound will be reanalyzed in the enclosing 968 -- declaration. For literal bounds that come from a type 969 -- declaration, the type of the context must be imposed, so 970 -- insure that analysis will take place. For non-universal 971 -- types this is not strictly necessary. 972 973 Set_Analyzed (Lo, False); 974 end if; 975 976 if Denotes_Discriminant (Old_Hi) then 977 Hi := 978 Make_Selected_Component (Loc, 979 Prefix => New_Copy_Tree (P), 980 Selector_Name => New_Occurrence_Of (Entity (Old_Hi), Loc)); 981 982 else 983 Hi := New_Copy_Tree (Old_Hi); 984 Set_Analyzed (Hi, False); 985 end if; 986 987 Append (Make_Range (Loc, Lo, Hi), Constraints); 988 Next_Index (Indx); 989 end loop; 990 991 return Constraints; 992 end Build_Actual_Array_Constraint; 993 994 ------------------------------------ 995 -- Build_Actual_Record_Constraint -- 996 ------------------------------------ 997 998 function Build_Actual_Record_Constraint return List_Id is 999 Constraints : constant List_Id := New_List; 1000 D : Elmt_Id; 1001 D_Val : Node_Id; 1002 1003 begin 1004 D := First_Elmt (Discriminant_Constraint (Desig_Typ)); 1005 while Present (D) loop 1006 if Denotes_Discriminant (Node (D)) then 1007 D_Val := Make_Selected_Component (Loc, 1008 Prefix => New_Copy_Tree (P), 1009 Selector_Name => New_Occurrence_Of (Entity (Node (D)), Loc)); 1010 1011 else 1012 D_Val := New_Copy_Tree (Node (D)); 1013 end if; 1014 1015 Append (D_Val, Constraints); 1016 Next_Elmt (D); 1017 end loop; 1018 1019 return Constraints; 1020 end Build_Actual_Record_Constraint; 1021 1022 -- Start of processing for Build_Actual_Subtype_Of_Component 1023 1024 begin 1025 -- Why the test for Spec_Expression mode here??? 1026 1027 if In_Spec_Expression then 1028 return Empty; 1029 1030 -- More comments for the rest of this body would be good ??? 1031 1032 elsif Nkind (N) = N_Explicit_Dereference then 1033 if Is_Composite_Type (T) 1034 and then not Is_Constrained (T) 1035 and then not (Is_Class_Wide_Type (T) 1036 and then Is_Constrained (Root_Type (T))) 1037 and then not Has_Unknown_Discriminants (T) 1038 then 1039 -- If the type of the dereference is already constrained, it is an 1040 -- actual subtype. 1041 1042 if Is_Array_Type (Etype (N)) 1043 and then Is_Constrained (Etype (N)) 1044 then 1045 return Empty; 1046 else 1047 Remove_Side_Effects (P); 1048 return Build_Actual_Subtype (T, N); 1049 end if; 1050 else 1051 return Empty; 1052 end if; 1053 end if; 1054 1055 if Ekind (T) = E_Access_Subtype then 1056 Desig_Typ := Designated_Type (T); 1057 else 1058 Desig_Typ := T; 1059 end if; 1060 1061 if Ekind (Desig_Typ) = E_Array_Subtype then 1062 Id := First_Index (Desig_Typ); 1063 while Present (Id) loop 1064 Index_Typ := Underlying_Type (Etype (Id)); 1065 1066 if Denotes_Discriminant (Type_Low_Bound (Index_Typ)) 1067 or else 1068 Denotes_Discriminant (Type_High_Bound (Index_Typ)) 1069 then 1070 Remove_Side_Effects (P); 1071 return 1072 Build_Component_Subtype 1073 (Build_Actual_Array_Constraint, Loc, Base_Type (T)); 1074 end if; 1075 1076 Next_Index (Id); 1077 end loop; 1078 1079 elsif Is_Composite_Type (Desig_Typ) 1080 and then Has_Discriminants (Desig_Typ) 1081 and then not Has_Unknown_Discriminants (Desig_Typ) 1082 then 1083 if Is_Private_Type (Desig_Typ) 1084 and then No (Discriminant_Constraint (Desig_Typ)) 1085 then 1086 Desig_Typ := Full_View (Desig_Typ); 1087 end if; 1088 1089 D := First_Elmt (Discriminant_Constraint (Desig_Typ)); 1090 while Present (D) loop 1091 if Denotes_Discriminant (Node (D)) then 1092 Remove_Side_Effects (P); 1093 return 1094 Build_Component_Subtype ( 1095 Build_Actual_Record_Constraint, Loc, Base_Type (T)); 1096 end if; 1097 1098 Next_Elmt (D); 1099 end loop; 1100 end if; 1101 1102 -- If none of the above, the actual and nominal subtypes are the same 1103 1104 return Empty; 1105 end Build_Actual_Subtype_Of_Component; 1106 1107 ----------------------------- 1108 -- Build_Component_Subtype -- 1109 ----------------------------- 1110 1111 function Build_Component_Subtype 1112 (C : List_Id; 1113 Loc : Source_Ptr; 1114 T : Entity_Id) return Node_Id 1115 is 1116 Subt : Entity_Id; 1117 Decl : Node_Id; 1118 1119 begin 1120 -- Unchecked_Union components do not require component subtypes 1121 1122 if Is_Unchecked_Union (T) then 1123 return Empty; 1124 end if; 1125 1126 Subt := Make_Temporary (Loc, 'S'); 1127 Set_Is_Internal (Subt); 1128 1129 Decl := 1130 Make_Subtype_Declaration (Loc, 1131 Defining_Identifier => Subt, 1132 Subtype_Indication => 1133 Make_Subtype_Indication (Loc, 1134 Subtype_Mark => New_Occurrence_Of (Base_Type (T), Loc), 1135 Constraint => 1136 Make_Index_Or_Discriminant_Constraint (Loc, 1137 Constraints => C))); 1138 1139 Mark_Rewrite_Insertion (Decl); 1140 return Decl; 1141 end Build_Component_Subtype; 1142 1143 ---------------------------------- 1144 -- Build_Default_Init_Cond_Call -- 1145 ---------------------------------- 1146 1147 function Build_Default_Init_Cond_Call 1148 (Loc : Source_Ptr; 1149 Obj_Id : Entity_Id; 1150 Typ : Entity_Id) return Node_Id 1151 is 1152 Proc_Id : constant Entity_Id := Default_Init_Cond_Procedure (Typ); 1153 Formal_Typ : constant Entity_Id := Etype (First_Formal (Proc_Id)); 1154 1155 begin 1156 return 1157 Make_Procedure_Call_Statement (Loc, 1158 Name => New_Occurrence_Of (Proc_Id, Loc), 1159 Parameter_Associations => New_List ( 1160 Make_Unchecked_Type_Conversion (Loc, 1161 Subtype_Mark => New_Occurrence_Of (Formal_Typ, Loc), 1162 Expression => New_Occurrence_Of (Obj_Id, Loc)))); 1163 end Build_Default_Init_Cond_Call; 1164 1165 ---------------------------------------------- 1166 -- Build_Default_Init_Cond_Procedure_Bodies -- 1167 ---------------------------------------------- 1168 1169 procedure Build_Default_Init_Cond_Procedure_Bodies (Priv_Decls : List_Id) is 1170 procedure Build_Default_Init_Cond_Procedure_Body (Typ : Entity_Id); 1171 -- If type Typ is subject to pragma Default_Initial_Condition, build the 1172 -- body of the procedure which verifies the assumption of the pragma at 1173 -- run time. The generated body is added after the type declaration. 1174 1175 -------------------------------------------- 1176 -- Build_Default_Init_Cond_Procedure_Body -- 1177 -------------------------------------------- 1178 1179 procedure Build_Default_Init_Cond_Procedure_Body (Typ : Entity_Id) is 1180 Param_Id : Entity_Id; 1181 -- The entity of the sole formal parameter of the default initial 1182 -- condition procedure. 1183 1184 procedure Replace_Type_Reference (N : Node_Id); 1185 -- Replace a single reference to type Typ with a reference to formal 1186 -- parameter Param_Id. 1187 1188 ---------------------------- 1189 -- Replace_Type_Reference -- 1190 ---------------------------- 1191 1192 procedure Replace_Type_Reference (N : Node_Id) is 1193 begin 1194 Rewrite (N, New_Occurrence_Of (Param_Id, Sloc (N))); 1195 end Replace_Type_Reference; 1196 1197 procedure Replace_Type_References is 1198 new Replace_Type_References_Generic (Replace_Type_Reference); 1199 1200 -- Local variables 1201 1202 Loc : constant Source_Ptr := Sloc (Typ); 1203 Prag : constant Node_Id := 1204 Get_Pragma (Typ, Pragma_Default_Initial_Condition); 1205 Proc_Id : constant Entity_Id := Default_Init_Cond_Procedure (Typ); 1206 Spec_Decl : constant Node_Id := Unit_Declaration_Node (Proc_Id); 1207 Body_Decl : Node_Id; 1208 Expr : Node_Id; 1209 Stmt : Node_Id; 1210 1211 Save_Ghost_Mode : constant Ghost_Mode_Type := Ghost_Mode; 1212 1213 -- Start of processing for Build_Default_Init_Cond_Procedure_Body 1214 1215 begin 1216 -- The procedure should be generated only for [sub]types subject to 1217 -- pragma Default_Initial_Condition. Types that inherit the pragma do 1218 -- not get this specialized procedure. 1219 1220 pragma Assert (Has_Default_Init_Cond (Typ)); 1221 pragma Assert (Present (Prag)); 1222 pragma Assert (Present (Proc_Id)); 1223 1224 -- Nothing to do if the body was already built 1225 1226 if Present (Corresponding_Body (Spec_Decl)) then 1227 return; 1228 end if; 1229 1230 -- The related type may be subject to pragma Ghost. Set the mode now 1231 -- to ensure that the analysis and expansion produce Ghost nodes. 1232 1233 Set_Ghost_Mode_From_Entity (Typ); 1234 1235 Param_Id := First_Formal (Proc_Id); 1236 1237 -- The pragma has an argument. Note that the argument is analyzed 1238 -- after all references to the current instance of the type are 1239 -- replaced. 1240 1241 if Present (Pragma_Argument_Associations (Prag)) then 1242 Expr := 1243 Get_Pragma_Arg (First (Pragma_Argument_Associations (Prag))); 1244 1245 if Nkind (Expr) = N_Null then 1246 Stmt := Make_Null_Statement (Loc); 1247 1248 -- Preserve the original argument of the pragma by replicating it. 1249 -- Replace all references to the current instance of the type with 1250 -- references to the formal parameter. 1251 1252 else 1253 Expr := New_Copy_Tree (Expr); 1254 Replace_Type_References (Expr, Typ); 1255 1256 -- Generate: 1257 -- pragma Check (Default_Initial_Condition, <Expr>); 1258 1259 Stmt := 1260 Make_Pragma (Loc, 1261 Pragma_Identifier => 1262 Make_Identifier (Loc, Name_Check), 1263 1264 Pragma_Argument_Associations => New_List ( 1265 Make_Pragma_Argument_Association (Loc, 1266 Expression => 1267 Make_Identifier (Loc, 1268 Chars => Name_Default_Initial_Condition)), 1269 Make_Pragma_Argument_Association (Loc, 1270 Expression => Expr))); 1271 end if; 1272 1273 -- Otherwise the pragma appears without an argument 1274 1275 else 1276 Stmt := Make_Null_Statement (Loc); 1277 end if; 1278 1279 -- Generate: 1280 -- procedure <Typ>Default_Init_Cond (I : <Typ>) is 1281 -- begin 1282 -- <Stmt>; 1283 -- end <Typ>Default_Init_Cond; 1284 1285 Body_Decl := 1286 Make_Subprogram_Body (Loc, 1287 Specification => 1288 Copy_Separate_Tree (Specification (Spec_Decl)), 1289 Declarations => Empty_List, 1290 Handled_Statement_Sequence => 1291 Make_Handled_Sequence_Of_Statements (Loc, 1292 Statements => New_List (Stmt))); 1293 1294 -- Link the spec and body of the default initial condition procedure 1295 -- to prevent the generation of a duplicate body. 1296 1297 Set_Corresponding_Body (Spec_Decl, Defining_Entity (Body_Decl)); 1298 Set_Corresponding_Spec (Body_Decl, Proc_Id); 1299 1300 Insert_After_And_Analyze (Declaration_Node (Typ), Body_Decl); 1301 Ghost_Mode := Save_Ghost_Mode; 1302 end Build_Default_Init_Cond_Procedure_Body; 1303 1304 -- Local variables 1305 1306 Decl : Node_Id; 1307 Typ : Entity_Id; 1308 1309 -- Start of processing for Build_Default_Init_Cond_Procedure_Bodies 1310 1311 begin 1312 -- Inspect the private declarations looking for [sub]type declarations 1313 1314 Decl := First (Priv_Decls); 1315 while Present (Decl) loop 1316 if Nkind_In (Decl, N_Full_Type_Declaration, 1317 N_Subtype_Declaration) 1318 then 1319 Typ := Defining_Entity (Decl); 1320 1321 -- Guard against partially decorate types due to previous errors 1322 1323 if Is_Type (Typ) then 1324 1325 -- If the type is subject to pragma Default_Initial_Condition, 1326 -- generate the body of the internal procedure which verifies 1327 -- the assertion of the pragma at run time. 1328 1329 if Has_Default_Init_Cond (Typ) then 1330 Build_Default_Init_Cond_Procedure_Body (Typ); 1331 1332 -- A derived type inherits the default initial condition 1333 -- procedure from its parent type. 1334 1335 elsif Has_Inherited_Default_Init_Cond (Typ) then 1336 Inherit_Default_Init_Cond_Procedure (Typ); 1337 end if; 1338 end if; 1339 end if; 1340 1341 Next (Decl); 1342 end loop; 1343 end Build_Default_Init_Cond_Procedure_Bodies; 1344 1345 --------------------------------------------------- 1346 -- Build_Default_Init_Cond_Procedure_Declaration -- 1347 --------------------------------------------------- 1348 1349 procedure Build_Default_Init_Cond_Procedure_Declaration (Typ : Entity_Id) is 1350 Loc : constant Source_Ptr := Sloc (Typ); 1351 Prag : constant Node_Id := 1352 Get_Pragma (Typ, Pragma_Default_Initial_Condition); 1353 1354 Save_Ghost_Mode : constant Ghost_Mode_Type := Ghost_Mode; 1355 1356 Proc_Id : Entity_Id; 1357 1358 begin 1359 -- The procedure should be generated only for types subject to pragma 1360 -- Default_Initial_Condition. Types that inherit the pragma do not get 1361 -- this specialized procedure. 1362 1363 pragma Assert (Has_Default_Init_Cond (Typ)); 1364 pragma Assert (Present (Prag)); 1365 1366 -- Nothing to do if default initial condition procedure already built 1367 1368 if Present (Default_Init_Cond_Procedure (Typ)) then 1369 return; 1370 end if; 1371 1372 -- The related type may be subject to pragma Ghost. Set the mode now to 1373 -- ensure that the analysis and expansion produce Ghost nodes. 1374 1375 Set_Ghost_Mode_From_Entity (Typ); 1376 1377 Proc_Id := 1378 Make_Defining_Identifier (Loc, 1379 Chars => New_External_Name (Chars (Typ), "Default_Init_Cond")); 1380 1381 -- Associate default initial condition procedure with the private type 1382 1383 Set_Ekind (Proc_Id, E_Procedure); 1384 Set_Is_Default_Init_Cond_Procedure (Proc_Id); 1385 Set_Default_Init_Cond_Procedure (Typ, Proc_Id); 1386 1387 -- Mark the default initial condition procedure explicitly as Ghost 1388 -- because it does not come from source. 1389 1390 if Ghost_Mode > None then 1391 Set_Is_Ghost_Entity (Proc_Id); 1392 end if; 1393 1394 -- Generate: 1395 -- procedure <Typ>Default_Init_Cond (Inn : <Typ>); 1396 1397 Insert_After_And_Analyze (Prag, 1398 Make_Subprogram_Declaration (Loc, 1399 Specification => 1400 Make_Procedure_Specification (Loc, 1401 Defining_Unit_Name => Proc_Id, 1402 Parameter_Specifications => New_List ( 1403 Make_Parameter_Specification (Loc, 1404 Defining_Identifier => Make_Temporary (Loc, 'I'), 1405 Parameter_Type => New_Occurrence_Of (Typ, Loc)))))); 1406 1407 Ghost_Mode := Save_Ghost_Mode; 1408 end Build_Default_Init_Cond_Procedure_Declaration; 1409 1410 --------------------------- 1411 -- Build_Default_Subtype -- 1412 --------------------------- 1413 1414 function Build_Default_Subtype 1415 (T : Entity_Id; 1416 N : Node_Id) return Entity_Id 1417 is 1418 Loc : constant Source_Ptr := Sloc (N); 1419 Disc : Entity_Id; 1420 1421 Bas : Entity_Id; 1422 -- The base type that is to be constrained by the defaults 1423 1424 begin 1425 if not Has_Discriminants (T) or else Is_Constrained (T) then 1426 return T; 1427 end if; 1428 1429 Bas := Base_Type (T); 1430 1431 -- If T is non-private but its base type is private, this is the 1432 -- completion of a subtype declaration whose parent type is private 1433 -- (see Complete_Private_Subtype in Sem_Ch3). The proper discriminants 1434 -- are to be found in the full view of the base. Check that the private 1435 -- status of T and its base differ. 1436 1437 if Is_Private_Type (Bas) 1438 and then not Is_Private_Type (T) 1439 and then Present (Full_View (Bas)) 1440 then 1441 Bas := Full_View (Bas); 1442 end if; 1443 1444 Disc := First_Discriminant (T); 1445 1446 if No (Discriminant_Default_Value (Disc)) then 1447 return T; 1448 end if; 1449 1450 declare 1451 Act : constant Entity_Id := Make_Temporary (Loc, 'S'); 1452 Constraints : constant List_Id := New_List; 1453 Decl : Node_Id; 1454 1455 begin 1456 while Present (Disc) loop 1457 Append_To (Constraints, 1458 New_Copy_Tree (Discriminant_Default_Value (Disc))); 1459 Next_Discriminant (Disc); 1460 end loop; 1461 1462 Decl := 1463 Make_Subtype_Declaration (Loc, 1464 Defining_Identifier => Act, 1465 Subtype_Indication => 1466 Make_Subtype_Indication (Loc, 1467 Subtype_Mark => New_Occurrence_Of (Bas, Loc), 1468 Constraint => 1469 Make_Index_Or_Discriminant_Constraint (Loc, 1470 Constraints => Constraints))); 1471 1472 Insert_Action (N, Decl); 1473 1474 -- If the context is a component declaration the subtype declaration 1475 -- will be analyzed when the enclosing type is frozen, otherwise do 1476 -- it now. 1477 1478 if Ekind (Current_Scope) /= E_Record_Type then 1479 Analyze (Decl); 1480 end if; 1481 1482 return Act; 1483 end; 1484 end Build_Default_Subtype; 1485 1486 -------------------------------------------- 1487 -- Build_Discriminal_Subtype_Of_Component -- 1488 -------------------------------------------- 1489 1490 function Build_Discriminal_Subtype_Of_Component 1491 (T : Entity_Id) return Node_Id 1492 is 1493 Loc : constant Source_Ptr := Sloc (T); 1494 D : Elmt_Id; 1495 Id : Node_Id; 1496 1497 function Build_Discriminal_Array_Constraint return List_Id; 1498 -- If one or more of the bounds of the component depends on 1499 -- discriminants, build actual constraint using the discriminants 1500 -- of the prefix. 1501 1502 function Build_Discriminal_Record_Constraint return List_Id; 1503 -- Similar to previous one, for discriminated components constrained by 1504 -- the discriminant of the enclosing object. 1505 1506 ---------------------------------------- 1507 -- Build_Discriminal_Array_Constraint -- 1508 ---------------------------------------- 1509 1510 function Build_Discriminal_Array_Constraint return List_Id is 1511 Constraints : constant List_Id := New_List; 1512 Indx : Node_Id; 1513 Hi : Node_Id; 1514 Lo : Node_Id; 1515 Old_Hi : Node_Id; 1516 Old_Lo : Node_Id; 1517 1518 begin 1519 Indx := First_Index (T); 1520 while Present (Indx) loop 1521 Old_Lo := Type_Low_Bound (Etype (Indx)); 1522 Old_Hi := Type_High_Bound (Etype (Indx)); 1523 1524 if Denotes_Discriminant (Old_Lo) then 1525 Lo := New_Occurrence_Of (Discriminal (Entity (Old_Lo)), Loc); 1526 1527 else 1528 Lo := New_Copy_Tree (Old_Lo); 1529 end if; 1530 1531 if Denotes_Discriminant (Old_Hi) then 1532 Hi := New_Occurrence_Of (Discriminal (Entity (Old_Hi)), Loc); 1533 1534 else 1535 Hi := New_Copy_Tree (Old_Hi); 1536 end if; 1537 1538 Append (Make_Range (Loc, Lo, Hi), Constraints); 1539 Next_Index (Indx); 1540 end loop; 1541 1542 return Constraints; 1543 end Build_Discriminal_Array_Constraint; 1544 1545 ----------------------------------------- 1546 -- Build_Discriminal_Record_Constraint -- 1547 ----------------------------------------- 1548 1549 function Build_Discriminal_Record_Constraint return List_Id is 1550 Constraints : constant List_Id := New_List; 1551 D : Elmt_Id; 1552 D_Val : Node_Id; 1553 1554 begin 1555 D := First_Elmt (Discriminant_Constraint (T)); 1556 while Present (D) loop 1557 if Denotes_Discriminant (Node (D)) then 1558 D_Val := 1559 New_Occurrence_Of (Discriminal (Entity (Node (D))), Loc); 1560 else 1561 D_Val := New_Copy_Tree (Node (D)); 1562 end if; 1563 1564 Append (D_Val, Constraints); 1565 Next_Elmt (D); 1566 end loop; 1567 1568 return Constraints; 1569 end Build_Discriminal_Record_Constraint; 1570 1571 -- Start of processing for Build_Discriminal_Subtype_Of_Component 1572 1573 begin 1574 if Ekind (T) = E_Array_Subtype then 1575 Id := First_Index (T); 1576 while Present (Id) loop 1577 if Denotes_Discriminant (Type_Low_Bound (Etype (Id))) 1578 or else 1579 Denotes_Discriminant (Type_High_Bound (Etype (Id))) 1580 then 1581 return Build_Component_Subtype 1582 (Build_Discriminal_Array_Constraint, Loc, T); 1583 end if; 1584 1585 Next_Index (Id); 1586 end loop; 1587 1588 elsif Ekind (T) = E_Record_Subtype 1589 and then Has_Discriminants (T) 1590 and then not Has_Unknown_Discriminants (T) 1591 then 1592 D := First_Elmt (Discriminant_Constraint (T)); 1593 while Present (D) loop 1594 if Denotes_Discriminant (Node (D)) then 1595 return Build_Component_Subtype 1596 (Build_Discriminal_Record_Constraint, Loc, T); 1597 end if; 1598 1599 Next_Elmt (D); 1600 end loop; 1601 end if; 1602 1603 -- If none of the above, the actual and nominal subtypes are the same 1604 1605 return Empty; 1606 end Build_Discriminal_Subtype_Of_Component; 1607 1608 ------------------------------ 1609 -- Build_Elaboration_Entity -- 1610 ------------------------------ 1611 1612 procedure Build_Elaboration_Entity (N : Node_Id; Spec_Id : Entity_Id) is 1613 Loc : constant Source_Ptr := Sloc (N); 1614 Decl : Node_Id; 1615 Elab_Ent : Entity_Id; 1616 1617 procedure Set_Package_Name (Ent : Entity_Id); 1618 -- Given an entity, sets the fully qualified name of the entity in 1619 -- Name_Buffer, with components separated by double underscores. This 1620 -- is a recursive routine that climbs the scope chain to Standard. 1621 1622 ---------------------- 1623 -- Set_Package_Name -- 1624 ---------------------- 1625 1626 procedure Set_Package_Name (Ent : Entity_Id) is 1627 begin 1628 if Scope (Ent) /= Standard_Standard then 1629 Set_Package_Name (Scope (Ent)); 1630 1631 declare 1632 Nam : constant String := Get_Name_String (Chars (Ent)); 1633 begin 1634 Name_Buffer (Name_Len + 1) := '_'; 1635 Name_Buffer (Name_Len + 2) := '_'; 1636 Name_Buffer (Name_Len + 3 .. Name_Len + Nam'Length + 2) := Nam; 1637 Name_Len := Name_Len + Nam'Length + 2; 1638 end; 1639 1640 else 1641 Get_Name_String (Chars (Ent)); 1642 end if; 1643 end Set_Package_Name; 1644 1645 -- Start of processing for Build_Elaboration_Entity 1646 1647 begin 1648 -- Ignore call if already constructed 1649 1650 if Present (Elaboration_Entity (Spec_Id)) then 1651 return; 1652 1653 -- Ignore in ASIS mode, elaboration entity is not in source and plays 1654 -- no role in analysis. 1655 1656 elsif ASIS_Mode then 1657 return; 1658 1659 -- See if we need elaboration entity. We always need it for the dynamic 1660 -- elaboration model, since it is needed to properly generate the PE 1661 -- exception for access before elaboration. 1662 1663 elsif Dynamic_Elaboration_Checks then 1664 null; 1665 1666 -- For the static model, we don't need the elaboration counter if this 1667 -- unit is sure to have no elaboration code, since that means there 1668 -- is no elaboration unit to be called. Note that we can't just decide 1669 -- after the fact by looking to see whether there was elaboration code, 1670 -- because that's too late to make this decision. 1671 1672 elsif Restriction_Active (No_Elaboration_Code) then 1673 return; 1674 1675 -- Similarly, for the static model, we can skip the elaboration counter 1676 -- if we have the No_Multiple_Elaboration restriction, since for the 1677 -- static model, that's the only purpose of the counter (to avoid 1678 -- multiple elaboration). 1679 1680 elsif Restriction_Active (No_Multiple_Elaboration) then 1681 return; 1682 end if; 1683 1684 -- Here we need the elaboration entity 1685 1686 -- Construct name of elaboration entity as xxx_E, where xxx is the unit 1687 -- name with dots replaced by double underscore. We have to manually 1688 -- construct this name, since it will be elaborated in the outer scope, 1689 -- and thus will not have the unit name automatically prepended. 1690 1691 Set_Package_Name (Spec_Id); 1692 Add_Str_To_Name_Buffer ("_E"); 1693 1694 -- Create elaboration counter 1695 1696 Elab_Ent := Make_Defining_Identifier (Loc, Chars => Name_Find); 1697 Set_Elaboration_Entity (Spec_Id, Elab_Ent); 1698 1699 Decl := 1700 Make_Object_Declaration (Loc, 1701 Defining_Identifier => Elab_Ent, 1702 Object_Definition => 1703 New_Occurrence_Of (Standard_Short_Integer, Loc), 1704 Expression => Make_Integer_Literal (Loc, Uint_0)); 1705 1706 Push_Scope (Standard_Standard); 1707 Add_Global_Declaration (Decl); 1708 Pop_Scope; 1709 1710 -- Reset True_Constant indication, since we will indeed assign a value 1711 -- to the variable in the binder main. We also kill the Current_Value 1712 -- and Last_Assignment fields for the same reason. 1713 1714 Set_Is_True_Constant (Elab_Ent, False); 1715 Set_Current_Value (Elab_Ent, Empty); 1716 Set_Last_Assignment (Elab_Ent, Empty); 1717 1718 -- We do not want any further qualification of the name (if we did not 1719 -- do this, we would pick up the name of the generic package in the case 1720 -- of a library level generic instantiation). 1721 1722 Set_Has_Qualified_Name (Elab_Ent); 1723 Set_Has_Fully_Qualified_Name (Elab_Ent); 1724 end Build_Elaboration_Entity; 1725 1726 -------------------------------- 1727 -- Build_Explicit_Dereference -- 1728 -------------------------------- 1729 1730 procedure Build_Explicit_Dereference 1731 (Expr : Node_Id; 1732 Disc : Entity_Id) 1733 is 1734 Loc : constant Source_Ptr := Sloc (Expr); 1735 I : Interp_Index; 1736 It : Interp; 1737 1738 begin 1739 -- An entity of a type with a reference aspect is overloaded with 1740 -- both interpretations: with and without the dereference. Now that 1741 -- the dereference is made explicit, set the type of the node properly, 1742 -- to prevent anomalies in the backend. Same if the expression is an 1743 -- overloaded function call whose return type has a reference aspect. 1744 1745 if Is_Entity_Name (Expr) then 1746 Set_Etype (Expr, Etype (Entity (Expr))); 1747 1748 elsif Nkind (Expr) = N_Function_Call then 1749 1750 -- If the name of the indexing function is overloaded, locate the one 1751 -- whose return type has an implicit dereference on the desired 1752 -- discriminant, and set entity and type of function call. 1753 1754 if Is_Overloaded (Name (Expr)) then 1755 Get_First_Interp (Name (Expr), I, It); 1756 1757 while Present (It.Nam) loop 1758 if Ekind ((It.Typ)) = E_Record_Type 1759 and then First_Entity ((It.Typ)) = Disc 1760 then 1761 Set_Entity (Name (Expr), It.Nam); 1762 Set_Etype (Name (Expr), Etype (It.Nam)); 1763 exit; 1764 end if; 1765 1766 Get_Next_Interp (I, It); 1767 end loop; 1768 end if; 1769 1770 -- Set type of call from resolved function name. 1771 1772 Set_Etype (Expr, Etype (Name (Expr))); 1773 end if; 1774 1775 Set_Is_Overloaded (Expr, False); 1776 1777 -- The expression will often be a generalized indexing that yields a 1778 -- container element that is then dereferenced, in which case the 1779 -- generalized indexing call is also non-overloaded. 1780 1781 if Nkind (Expr) = N_Indexed_Component 1782 and then Present (Generalized_Indexing (Expr)) 1783 then 1784 Set_Is_Overloaded (Generalized_Indexing (Expr), False); 1785 end if; 1786 1787 Rewrite (Expr, 1788 Make_Explicit_Dereference (Loc, 1789 Prefix => 1790 Make_Selected_Component (Loc, 1791 Prefix => Relocate_Node (Expr), 1792 Selector_Name => New_Occurrence_Of (Disc, Loc)))); 1793 Set_Etype (Prefix (Expr), Etype (Disc)); 1794 Set_Etype (Expr, Designated_Type (Etype (Disc))); 1795 end Build_Explicit_Dereference; 1796 1797 ----------------------------------- 1798 -- Cannot_Raise_Constraint_Error -- 1799 ----------------------------------- 1800 1801 function Cannot_Raise_Constraint_Error (Expr : Node_Id) return Boolean is 1802 begin 1803 if Compile_Time_Known_Value (Expr) then 1804 return True; 1805 1806 elsif Do_Range_Check (Expr) then 1807 return False; 1808 1809 elsif Raises_Constraint_Error (Expr) then 1810 return False; 1811 1812 else 1813 case Nkind (Expr) is 1814 when N_Identifier => 1815 return True; 1816 1817 when N_Expanded_Name => 1818 return True; 1819 1820 when N_Selected_Component => 1821 return not Do_Discriminant_Check (Expr); 1822 1823 when N_Attribute_Reference => 1824 if Do_Overflow_Check (Expr) then 1825 return False; 1826 1827 elsif No (Expressions (Expr)) then 1828 return True; 1829 1830 else 1831 declare 1832 N : Node_Id; 1833 1834 begin 1835 N := First (Expressions (Expr)); 1836 while Present (N) loop 1837 if Cannot_Raise_Constraint_Error (N) then 1838 Next (N); 1839 else 1840 return False; 1841 end if; 1842 end loop; 1843 1844 return True; 1845 end; 1846 end if; 1847 1848 when N_Type_Conversion => 1849 if Do_Overflow_Check (Expr) 1850 or else Do_Length_Check (Expr) 1851 or else Do_Tag_Check (Expr) 1852 then 1853 return False; 1854 else 1855 return Cannot_Raise_Constraint_Error (Expression (Expr)); 1856 end if; 1857 1858 when N_Unchecked_Type_Conversion => 1859 return Cannot_Raise_Constraint_Error (Expression (Expr)); 1860 1861 when N_Unary_Op => 1862 if Do_Overflow_Check (Expr) then 1863 return False; 1864 else 1865 return Cannot_Raise_Constraint_Error (Right_Opnd (Expr)); 1866 end if; 1867 1868 when N_Op_Divide | 1869 N_Op_Mod | 1870 N_Op_Rem 1871 => 1872 if Do_Division_Check (Expr) 1873 or else 1874 Do_Overflow_Check (Expr) 1875 then 1876 return False; 1877 else 1878 return 1879 Cannot_Raise_Constraint_Error (Left_Opnd (Expr)) 1880 and then 1881 Cannot_Raise_Constraint_Error (Right_Opnd (Expr)); 1882 end if; 1883 1884 when N_Op_Add | 1885 N_Op_And | 1886 N_Op_Concat | 1887 N_Op_Eq | 1888 N_Op_Expon | 1889 N_Op_Ge | 1890 N_Op_Gt | 1891 N_Op_Le | 1892 N_Op_Lt | 1893 N_Op_Multiply | 1894 N_Op_Ne | 1895 N_Op_Or | 1896 N_Op_Rotate_Left | 1897 N_Op_Rotate_Right | 1898 N_Op_Shift_Left | 1899 N_Op_Shift_Right | 1900 N_Op_Shift_Right_Arithmetic | 1901 N_Op_Subtract | 1902 N_Op_Xor 1903 => 1904 if Do_Overflow_Check (Expr) then 1905 return False; 1906 else 1907 return 1908 Cannot_Raise_Constraint_Error (Left_Opnd (Expr)) 1909 and then 1910 Cannot_Raise_Constraint_Error (Right_Opnd (Expr)); 1911 end if; 1912 1913 when others => 1914 return False; 1915 end case; 1916 end if; 1917 end Cannot_Raise_Constraint_Error; 1918 1919 ----------------------------- 1920 -- Check_Part_Of_Reference -- 1921 ----------------------------- 1922 1923 procedure Check_Part_Of_Reference (Var_Id : Entity_Id; Ref : Node_Id) is 1924 Conc_Typ : constant Entity_Id := Encapsulating_State (Var_Id); 1925 Decl : Node_Id; 1926 OK_Use : Boolean := False; 1927 Par : Node_Id; 1928 Prag_Nam : Name_Id; 1929 Spec_Id : Entity_Id; 1930 1931 begin 1932 -- Traverse the parent chain looking for a suitable context for the 1933 -- reference to the concurrent constituent. 1934 1935 Par := Parent (Ref); 1936 while Present (Par) loop 1937 if Nkind (Par) = N_Pragma then 1938 Prag_Nam := Pragma_Name (Par); 1939 1940 -- A concurrent constituent is allowed to appear in pragmas 1941 -- Initial_Condition and Initializes as this is part of the 1942 -- elaboration checks for the constituent (SPARK RM 9.3). 1943 1944 if Nam_In (Prag_Nam, Name_Initial_Condition, Name_Initializes) then 1945 OK_Use := True; 1946 exit; 1947 1948 -- When the reference appears within pragma Depends or Global, 1949 -- check whether the pragma applies to a single task type. Note 1950 -- that the pragma is not encapsulated by the type definition, 1951 -- but this is still a valid context. 1952 1953 elsif Nam_In (Prag_Nam, Name_Depends, Name_Global) then 1954 Decl := Find_Related_Declaration_Or_Body (Par); 1955 1956 if Nkind (Decl) = N_Object_Declaration 1957 and then Defining_Entity (Decl) = Conc_Typ 1958 then 1959 OK_Use := True; 1960 exit; 1961 end if; 1962 end if; 1963 1964 -- The reference appears somewhere in the definition of the single 1965 -- protected/task type (SPARK RM 9.3). 1966 1967 elsif Nkind_In (Par, N_Single_Protected_Declaration, 1968 N_Single_Task_Declaration) 1969 and then Defining_Entity (Par) = Conc_Typ 1970 then 1971 OK_Use := True; 1972 exit; 1973 1974 -- The reference appears within the expanded declaration or the body 1975 -- of the single protected/task type (SPARK RM 9.3). 1976 1977 elsif Nkind_In (Par, N_Protected_Body, 1978 N_Protected_Type_Declaration, 1979 N_Task_Body, 1980 N_Task_Type_Declaration) 1981 then 1982 Spec_Id := Unique_Defining_Entity (Par); 1983 1984 if Present (Anonymous_Object (Spec_Id)) 1985 and then Anonymous_Object (Spec_Id) = Conc_Typ 1986 then 1987 OK_Use := True; 1988 exit; 1989 end if; 1990 1991 -- The reference has been relocated within an internally generated 1992 -- package or subprogram. Assume that the reference is legal as the 1993 -- real check was already performed in the original context of the 1994 -- reference. 1995 1996 elsif Nkind_In (Par, N_Package_Body, 1997 N_Package_Declaration, 1998 N_Subprogram_Body, 1999 N_Subprogram_Declaration) 2000 and then not Comes_From_Source (Par) 2001 then 2002 OK_Use := True; 2003 exit; 2004 2005 -- The reference has been relocated to an inlined body for GNATprove. 2006 -- Assume that the reference is legal as the real check was already 2007 -- performed in the original context of the reference. 2008 2009 elsif GNATprove_Mode 2010 and then Nkind (Par) = N_Subprogram_Body 2011 and then Chars (Defining_Entity (Par)) = Name_uParent 2012 then 2013 OK_Use := True; 2014 exit; 2015 end if; 2016 2017 Par := Parent (Par); 2018 end loop; 2019 2020 -- The reference is illegal as it appears outside the definition or 2021 -- body of the single protected/task type. 2022 2023 if not OK_Use then 2024 Error_Msg_NE 2025 ("reference to variable & cannot appear in this context", 2026 Ref, Var_Id); 2027 Error_Msg_Name_1 := Chars (Var_Id); 2028 2029 if Ekind (Conc_Typ) = E_Protected_Type then 2030 Error_Msg_NE 2031 ("\% is constituent of single protected type &", Ref, Conc_Typ); 2032 else 2033 Error_Msg_NE 2034 ("\% is constituent of single task type &", Ref, Conc_Typ); 2035 end if; 2036 end if; 2037 end Check_Part_Of_Reference; 2038 2039 ----------------------------------------- 2040 -- Check_Dynamically_Tagged_Expression -- 2041 ----------------------------------------- 2042 2043 procedure Check_Dynamically_Tagged_Expression 2044 (Expr : Node_Id; 2045 Typ : Entity_Id; 2046 Related_Nod : Node_Id) 2047 is 2048 begin 2049 pragma Assert (Is_Tagged_Type (Typ)); 2050 2051 -- In order to avoid spurious errors when analyzing the expanded code, 2052 -- this check is done only for nodes that come from source and for 2053 -- actuals of generic instantiations. 2054 2055 if (Comes_From_Source (Related_Nod) 2056 or else In_Generic_Actual (Expr)) 2057 and then (Is_Class_Wide_Type (Etype (Expr)) 2058 or else Is_Dynamically_Tagged (Expr)) 2059 and then Is_Tagged_Type (Typ) 2060 and then not Is_Class_Wide_Type (Typ) 2061 then 2062 Error_Msg_N ("dynamically tagged expression not allowed!", Expr); 2063 end if; 2064 end Check_Dynamically_Tagged_Expression; 2065 2066 -------------------------- 2067 -- Check_Fully_Declared -- 2068 -------------------------- 2069 2070 procedure Check_Fully_Declared (T : Entity_Id; N : Node_Id) is 2071 begin 2072 if Ekind (T) = E_Incomplete_Type then 2073 2074 -- Ada 2005 (AI-50217): If the type is available through a limited 2075 -- with_clause, verify that its full view has been analyzed. 2076 2077 if From_Limited_With (T) 2078 and then Present (Non_Limited_View (T)) 2079 and then Ekind (Non_Limited_View (T)) /= E_Incomplete_Type 2080 then 2081 -- The non-limited view is fully declared 2082 2083 null; 2084 2085 else 2086 Error_Msg_NE 2087 ("premature usage of incomplete}", N, First_Subtype (T)); 2088 end if; 2089 2090 -- Need comments for these tests ??? 2091 2092 elsif Has_Private_Component (T) 2093 and then not Is_Generic_Type (Root_Type (T)) 2094 and then not In_Spec_Expression 2095 then 2096 -- Special case: if T is the anonymous type created for a single 2097 -- task or protected object, use the name of the source object. 2098 2099 if Is_Concurrent_Type (T) 2100 and then not Comes_From_Source (T) 2101 and then Nkind (N) = N_Object_Declaration 2102 then 2103 Error_Msg_NE 2104 ("type of& has incomplete component", 2105 N, Defining_Identifier (N)); 2106 else 2107 Error_Msg_NE 2108 ("premature usage of incomplete}", 2109 N, First_Subtype (T)); 2110 end if; 2111 end if; 2112 end Check_Fully_Declared; 2113 2114 ------------------------------------------- 2115 -- Check_Function_With_Address_Parameter -- 2116 ------------------------------------------- 2117 2118 procedure Check_Function_With_Address_Parameter (Subp_Id : Entity_Id) is 2119 F : Entity_Id; 2120 T : Entity_Id; 2121 2122 begin 2123 F := First_Formal (Subp_Id); 2124 while Present (F) loop 2125 T := Etype (F); 2126 2127 if Is_Private_Type (T) and then Present (Full_View (T)) then 2128 T := Full_View (T); 2129 end if; 2130 2131 if Is_Descendent_Of_Address (T) or else Is_Limited_Type (T) then 2132 Set_Is_Pure (Subp_Id, False); 2133 exit; 2134 end if; 2135 2136 Next_Formal (F); 2137 end loop; 2138 end Check_Function_With_Address_Parameter; 2139 2140 ------------------------------------- 2141 -- Check_Function_Writable_Actuals -- 2142 ------------------------------------- 2143 2144 procedure Check_Function_Writable_Actuals (N : Node_Id) is 2145 Writable_Actuals_List : Elist_Id := No_Elist; 2146 Identifiers_List : Elist_Id := No_Elist; 2147 Aggr_Error_Node : Node_Id := Empty; 2148 Error_Node : Node_Id := Empty; 2149 2150 procedure Collect_Identifiers (N : Node_Id); 2151 -- In a single traversal of subtree N collect in Writable_Actuals_List 2152 -- all the actuals of functions with writable actuals, and in the list 2153 -- Identifiers_List collect all the identifiers that are not actuals of 2154 -- functions with writable actuals. If a writable actual is referenced 2155 -- twice as writable actual then Error_Node is set to reference its 2156 -- second occurrence, the error is reported, and the tree traversal 2157 -- is abandoned. 2158 2159 function Get_Function_Id (Call : Node_Id) return Entity_Id; 2160 -- Return the entity associated with the function call 2161 2162 procedure Preanalyze_Without_Errors (N : Node_Id); 2163 -- Preanalyze N without reporting errors. Very dubious, you can't just 2164 -- go analyzing things more than once??? 2165 2166 ------------------------- 2167 -- Collect_Identifiers -- 2168 ------------------------- 2169 2170 procedure Collect_Identifiers (N : Node_Id) is 2171 2172 function Check_Node (N : Node_Id) return Traverse_Result; 2173 -- Process a single node during the tree traversal to collect the 2174 -- writable actuals of functions and all the identifiers which are 2175 -- not writable actuals of functions. 2176 2177 function Contains (List : Elist_Id; N : Node_Id) return Boolean; 2178 -- Returns True if List has a node whose Entity is Entity (N) 2179 2180 ------------------------- 2181 -- Check_Function_Call -- 2182 ------------------------- 2183 2184 function Check_Node (N : Node_Id) return Traverse_Result is 2185 Is_Writable_Actual : Boolean := False; 2186 Id : Entity_Id; 2187 2188 begin 2189 if Nkind (N) = N_Identifier then 2190 2191 -- No analysis possible if the entity is not decorated 2192 2193 if No (Entity (N)) then 2194 return Skip; 2195 2196 -- Don't collect identifiers of packages, called functions, etc 2197 2198 elsif Ekind_In (Entity (N), E_Package, 2199 E_Function, 2200 E_Procedure, 2201 E_Entry) 2202 then 2203 return Skip; 2204 2205 -- For rewritten nodes, continue the traversal in the original 2206 -- subtree. Needed to handle aggregates in original expressions 2207 -- extracted from the tree by Remove_Side_Effects. 2208 2209 elsif Is_Rewrite_Substitution (N) then 2210 Collect_Identifiers (Original_Node (N)); 2211 return Skip; 2212 2213 -- For now we skip aggregate discriminants, since they require 2214 -- performing the analysis in two phases to identify conflicts: 2215 -- first one analyzing discriminants and second one analyzing 2216 -- the rest of components (since at run time, discriminants are 2217 -- evaluated prior to components): too much computation cost 2218 -- to identify a corner case??? 2219 2220 elsif Nkind (Parent (N)) = N_Component_Association 2221 and then Nkind_In (Parent (Parent (N)), 2222 N_Aggregate, 2223 N_Extension_Aggregate) 2224 then 2225 declare 2226 Choice : constant Node_Id := First (Choices (Parent (N))); 2227 2228 begin 2229 if Ekind (Entity (N)) = E_Discriminant then 2230 return Skip; 2231 2232 elsif Expression (Parent (N)) = N 2233 and then Nkind (Choice) = N_Identifier 2234 and then Ekind (Entity (Choice)) = E_Discriminant 2235 then 2236 return Skip; 2237 end if; 2238 end; 2239 2240 -- Analyze if N is a writable actual of a function 2241 2242 elsif Nkind (Parent (N)) = N_Function_Call then 2243 declare 2244 Call : constant Node_Id := Parent (N); 2245 Actual : Node_Id; 2246 Formal : Node_Id; 2247 2248 begin 2249 Id := Get_Function_Id (Call); 2250 2251 -- In case of previous error, no check is possible 2252 2253 if No (Id) then 2254 return Abandon; 2255 end if; 2256 2257 if Ekind_In (Id, E_Function, E_Generic_Function) 2258 and then Has_Out_Or_In_Out_Parameter (Id) 2259 then 2260 Formal := First_Formal (Id); 2261 Actual := First_Actual (Call); 2262 while Present (Actual) and then Present (Formal) loop 2263 if Actual = N then 2264 if Ekind_In (Formal, E_Out_Parameter, 2265 E_In_Out_Parameter) 2266 then 2267 Is_Writable_Actual := True; 2268 end if; 2269 2270 exit; 2271 end if; 2272 2273 Next_Formal (Formal); 2274 Next_Actual (Actual); 2275 end loop; 2276 end if; 2277 end; 2278 end if; 2279 2280 if Is_Writable_Actual then 2281 2282 -- Skip checking the error in non-elementary types since 2283 -- RM 6.4.1(6.15/3) is restricted to elementary types, but 2284 -- store this actual in Writable_Actuals_List since it is 2285 -- needed to perform checks on other constructs that have 2286 -- arbitrary order of evaluation (for example, aggregates). 2287 2288 if not Is_Elementary_Type (Etype (N)) then 2289 if not Contains (Writable_Actuals_List, N) then 2290 Append_New_Elmt (N, To => Writable_Actuals_List); 2291 end if; 2292 2293 -- Second occurrence of an elementary type writable actual 2294 2295 elsif Contains (Writable_Actuals_List, N) then 2296 2297 -- Report the error on the second occurrence of the 2298 -- identifier. We cannot assume that N is the second 2299 -- occurrence (according to their location in the 2300 -- sources), since Traverse_Func walks through Field2 2301 -- last (see comment in the body of Traverse_Func). 2302 2303 declare 2304 Elmt : Elmt_Id; 2305 2306 begin 2307 Elmt := First_Elmt (Writable_Actuals_List); 2308 while Present (Elmt) 2309 and then Entity (Node (Elmt)) /= Entity (N) 2310 loop 2311 Next_Elmt (Elmt); 2312 end loop; 2313 2314 if Sloc (N) > Sloc (Node (Elmt)) then 2315 Error_Node := N; 2316 else 2317 Error_Node := Node (Elmt); 2318 end if; 2319 2320 Error_Msg_NE 2321 ("value may be affected by call to & " 2322 & "because order of evaluation is arbitrary", 2323 Error_Node, Id); 2324 return Abandon; 2325 end; 2326 2327 -- First occurrence of a elementary type writable actual 2328 2329 else 2330 Append_New_Elmt (N, To => Writable_Actuals_List); 2331 end if; 2332 2333 else 2334 if Identifiers_List = No_Elist then 2335 Identifiers_List := New_Elmt_List; 2336 end if; 2337 2338 Append_Unique_Elmt (N, Identifiers_List); 2339 end if; 2340 end if; 2341 2342 return OK; 2343 end Check_Node; 2344 2345 -------------- 2346 -- Contains -- 2347 -------------- 2348 2349 function Contains 2350 (List : Elist_Id; 2351 N : Node_Id) return Boolean 2352 is 2353 pragma Assert (Nkind (N) in N_Has_Entity); 2354 2355 Elmt : Elmt_Id; 2356 2357 begin 2358 if List = No_Elist then 2359 return False; 2360 end if; 2361 2362 Elmt := First_Elmt (List); 2363 while Present (Elmt) loop 2364 if Entity (Node (Elmt)) = Entity (N) then 2365 return True; 2366 else 2367 Next_Elmt (Elmt); 2368 end if; 2369 end loop; 2370 2371 return False; 2372 end Contains; 2373 2374 ------------------ 2375 -- Do_Traversal -- 2376 ------------------ 2377 2378 procedure Do_Traversal is new Traverse_Proc (Check_Node); 2379 -- The traversal procedure 2380 2381 -- Start of processing for Collect_Identifiers 2382 2383 begin 2384 if Present (Error_Node) then 2385 return; 2386 end if; 2387 2388 if Nkind (N) in N_Subexpr and then Is_OK_Static_Expression (N) then 2389 return; 2390 end if; 2391 2392 Do_Traversal (N); 2393 end Collect_Identifiers; 2394 2395 --------------------- 2396 -- Get_Function_Id -- 2397 --------------------- 2398 2399 function Get_Function_Id (Call : Node_Id) return Entity_Id is 2400 Nam : constant Node_Id := Name (Call); 2401 Id : Entity_Id; 2402 2403 begin 2404 if Nkind (Nam) = N_Explicit_Dereference then 2405 Id := Etype (Nam); 2406 pragma Assert (Ekind (Id) = E_Subprogram_Type); 2407 2408 elsif Nkind (Nam) = N_Selected_Component then 2409 Id := Entity (Selector_Name (Nam)); 2410 2411 elsif Nkind (Nam) = N_Indexed_Component then 2412 Id := Entity (Selector_Name (Prefix (Nam))); 2413 2414 else 2415 Id := Entity (Nam); 2416 end if; 2417 2418 return Id; 2419 end Get_Function_Id; 2420 2421 ------------------------------- 2422 -- Preanalyze_Without_Errors -- 2423 ------------------------------- 2424 2425 procedure Preanalyze_Without_Errors (N : Node_Id) is 2426 Status : constant Boolean := Get_Ignore_Errors; 2427 begin 2428 Set_Ignore_Errors (True); 2429 Preanalyze (N); 2430 Set_Ignore_Errors (Status); 2431 end Preanalyze_Without_Errors; 2432 2433 -- Start of processing for Check_Function_Writable_Actuals 2434 2435 begin 2436 -- The check only applies to Ada 2012 code on which Check_Actuals has 2437 -- been set, and only to constructs that have multiple constituents 2438 -- whose order of evaluation is not specified by the language. 2439 2440 if Ada_Version < Ada_2012 2441 or else not Check_Actuals (N) 2442 or else (not (Nkind (N) in N_Op) 2443 and then not (Nkind (N) in N_Membership_Test) 2444 and then not Nkind_In (N, N_Range, 2445 N_Aggregate, 2446 N_Extension_Aggregate, 2447 N_Full_Type_Declaration, 2448 N_Function_Call, 2449 N_Procedure_Call_Statement, 2450 N_Entry_Call_Statement)) 2451 or else (Nkind (N) = N_Full_Type_Declaration 2452 and then not Is_Record_Type (Defining_Identifier (N))) 2453 2454 -- In addition, this check only applies to source code, not to code 2455 -- generated by constraint checks. 2456 2457 or else not Comes_From_Source (N) 2458 then 2459 return; 2460 end if; 2461 2462 -- If a construct C has two or more direct constituents that are names 2463 -- or expressions whose evaluation may occur in an arbitrary order, at 2464 -- least one of which contains a function call with an in out or out 2465 -- parameter, then the construct is legal only if: for each name N that 2466 -- is passed as a parameter of mode in out or out to some inner function 2467 -- call C2 (not including the construct C itself), there is no other 2468 -- name anywhere within a direct constituent of the construct C other 2469 -- than the one containing C2, that is known to refer to the same 2470 -- object (RM 6.4.1(6.17/3)). 2471 2472 case Nkind (N) is 2473 when N_Range => 2474 Collect_Identifiers (Low_Bound (N)); 2475 Collect_Identifiers (High_Bound (N)); 2476 2477 when N_Op | N_Membership_Test => 2478 declare 2479 Expr : Node_Id; 2480 2481 begin 2482 Collect_Identifiers (Left_Opnd (N)); 2483 2484 if Present (Right_Opnd (N)) then 2485 Collect_Identifiers (Right_Opnd (N)); 2486 end if; 2487 2488 if Nkind_In (N, N_In, N_Not_In) 2489 and then Present (Alternatives (N)) 2490 then 2491 Expr := First (Alternatives (N)); 2492 while Present (Expr) loop 2493 Collect_Identifiers (Expr); 2494 2495 Next (Expr); 2496 end loop; 2497 end if; 2498 end; 2499 2500 when N_Full_Type_Declaration => 2501 declare 2502 function Get_Record_Part (N : Node_Id) return Node_Id; 2503 -- Return the record part of this record type definition 2504 2505 function Get_Record_Part (N : Node_Id) return Node_Id is 2506 Type_Def : constant Node_Id := Type_Definition (N); 2507 begin 2508 if Nkind (Type_Def) = N_Derived_Type_Definition then 2509 return Record_Extension_Part (Type_Def); 2510 else 2511 return Type_Def; 2512 end if; 2513 end Get_Record_Part; 2514 2515 Comp : Node_Id; 2516 Def_Id : Entity_Id := Defining_Identifier (N); 2517 Rec : Node_Id := Get_Record_Part (N); 2518 2519 begin 2520 -- No need to perform any analysis if the record has no 2521 -- components 2522 2523 if No (Rec) or else No (Component_List (Rec)) then 2524 return; 2525 end if; 2526 2527 -- Collect the identifiers starting from the deepest 2528 -- derivation. Done to report the error in the deepest 2529 -- derivation. 2530 2531 loop 2532 if Present (Component_List (Rec)) then 2533 Comp := First (Component_Items (Component_List (Rec))); 2534 while Present (Comp) loop 2535 if Nkind (Comp) = N_Component_Declaration 2536 and then Present (Expression (Comp)) 2537 then 2538 Collect_Identifiers (Expression (Comp)); 2539 end if; 2540 2541 Next (Comp); 2542 end loop; 2543 end if; 2544 2545 exit when No (Underlying_Type (Etype (Def_Id))) 2546 or else Base_Type (Underlying_Type (Etype (Def_Id))) 2547 = Def_Id; 2548 2549 Def_Id := Base_Type (Underlying_Type (Etype (Def_Id))); 2550 Rec := Get_Record_Part (Parent (Def_Id)); 2551 end loop; 2552 end; 2553 2554 when N_Subprogram_Call | 2555 N_Entry_Call_Statement => 2556 declare 2557 Id : constant Entity_Id := Get_Function_Id (N); 2558 Formal : Node_Id; 2559 Actual : Node_Id; 2560 2561 begin 2562 Formal := First_Formal (Id); 2563 Actual := First_Actual (N); 2564 while Present (Actual) and then Present (Formal) loop 2565 if Ekind_In (Formal, E_Out_Parameter, 2566 E_In_Out_Parameter) 2567 then 2568 Collect_Identifiers (Actual); 2569 end if; 2570 2571 Next_Formal (Formal); 2572 Next_Actual (Actual); 2573 end loop; 2574 end; 2575 2576 when N_Aggregate | 2577 N_Extension_Aggregate => 2578 declare 2579 Assoc : Node_Id; 2580 Choice : Node_Id; 2581 Comp_Expr : Node_Id; 2582 2583 begin 2584 -- Handle the N_Others_Choice of array aggregates with static 2585 -- bounds. There is no need to perform this analysis in 2586 -- aggregates without static bounds since we cannot evaluate 2587 -- if the N_Others_Choice covers several elements. There is 2588 -- no need to handle the N_Others choice of record aggregates 2589 -- since at this stage it has been already expanded by 2590 -- Resolve_Record_Aggregate. 2591 2592 if Is_Array_Type (Etype (N)) 2593 and then Nkind (N) = N_Aggregate 2594 and then Present (Aggregate_Bounds (N)) 2595 and then Compile_Time_Known_Bounds (Etype (N)) 2596 and then Expr_Value (High_Bound (Aggregate_Bounds (N))) 2597 > 2598 Expr_Value (Low_Bound (Aggregate_Bounds (N))) 2599 then 2600 declare 2601 Count_Components : Uint := Uint_0; 2602 Num_Components : Uint; 2603 Others_Assoc : Node_Id; 2604 Others_Choice : Node_Id := Empty; 2605 Others_Box_Present : Boolean := False; 2606 2607 begin 2608 -- Count positional associations 2609 2610 if Present (Expressions (N)) then 2611 Comp_Expr := First (Expressions (N)); 2612 while Present (Comp_Expr) loop 2613 Count_Components := Count_Components + 1; 2614 Next (Comp_Expr); 2615 end loop; 2616 end if; 2617 2618 -- Count the rest of elements and locate the N_Others 2619 -- choice (if any) 2620 2621 Assoc := First (Component_Associations (N)); 2622 while Present (Assoc) loop 2623 Choice := First (Choices (Assoc)); 2624 while Present (Choice) loop 2625 if Nkind (Choice) = N_Others_Choice then 2626 Others_Assoc := Assoc; 2627 Others_Choice := Choice; 2628 Others_Box_Present := Box_Present (Assoc); 2629 2630 -- Count several components 2631 2632 elsif Nkind_In (Choice, N_Range, 2633 N_Subtype_Indication) 2634 or else (Is_Entity_Name (Choice) 2635 and then Is_Type (Entity (Choice))) 2636 then 2637 declare 2638 L, H : Node_Id; 2639 begin 2640 Get_Index_Bounds (Choice, L, H); 2641 pragma Assert 2642 (Compile_Time_Known_Value (L) 2643 and then Compile_Time_Known_Value (H)); 2644 Count_Components := 2645 Count_Components 2646 + Expr_Value (H) - Expr_Value (L) + 1; 2647 end; 2648 2649 -- Count single component. No other case available 2650 -- since we are handling an aggregate with static 2651 -- bounds. 2652 2653 else 2654 pragma Assert (Is_OK_Static_Expression (Choice) 2655 or else Nkind (Choice) = N_Identifier 2656 or else Nkind (Choice) = N_Integer_Literal); 2657 2658 Count_Components := Count_Components + 1; 2659 end if; 2660 2661 Next (Choice); 2662 end loop; 2663 2664 Next (Assoc); 2665 end loop; 2666 2667 Num_Components := 2668 Expr_Value (High_Bound (Aggregate_Bounds (N))) - 2669 Expr_Value (Low_Bound (Aggregate_Bounds (N))) + 1; 2670 2671 pragma Assert (Count_Components <= Num_Components); 2672 2673 -- Handle the N_Others choice if it covers several 2674 -- components 2675 2676 if Present (Others_Choice) 2677 and then (Num_Components - Count_Components) > 1 2678 then 2679 if not Others_Box_Present then 2680 2681 -- At this stage, if expansion is active, the 2682 -- expression of the others choice has not been 2683 -- analyzed. Hence we generate a duplicate and 2684 -- we analyze it silently to have available the 2685 -- minimum decoration required to collect the 2686 -- identifiers. 2687 2688 if not Expander_Active then 2689 Comp_Expr := Expression (Others_Assoc); 2690 else 2691 Comp_Expr := 2692 New_Copy_Tree (Expression (Others_Assoc)); 2693 Preanalyze_Without_Errors (Comp_Expr); 2694 end if; 2695 2696 Collect_Identifiers (Comp_Expr); 2697 2698 if Writable_Actuals_List /= No_Elist then 2699 2700 -- As suggested by Robert, at current stage we 2701 -- report occurrences of this case as warnings. 2702 2703 Error_Msg_N 2704 ("writable function parameter may affect " 2705 & "value in other component because order " 2706 & "of evaluation is unspecified??", 2707 Node (First_Elmt (Writable_Actuals_List))); 2708 end if; 2709 end if; 2710 end if; 2711 end; 2712 2713 -- For an array aggregate, a discrete_choice_list that has 2714 -- a nonstatic range is considered as two or more separate 2715 -- occurrences of the expression (RM 6.4.1(20/3)). 2716 2717 elsif Is_Array_Type (Etype (N)) 2718 and then Nkind (N) = N_Aggregate 2719 and then Present (Aggregate_Bounds (N)) 2720 and then not Compile_Time_Known_Bounds (Etype (N)) 2721 then 2722 -- Collect identifiers found in the dynamic bounds 2723 2724 declare 2725 Count_Components : Natural := 0; 2726 Low, High : Node_Id; 2727 2728 begin 2729 Assoc := First (Component_Associations (N)); 2730 while Present (Assoc) loop 2731 Choice := First (Choices (Assoc)); 2732 while Present (Choice) loop 2733 if Nkind_In (Choice, N_Range, 2734 N_Subtype_Indication) 2735 or else (Is_Entity_Name (Choice) 2736 and then Is_Type (Entity (Choice))) 2737 then 2738 Get_Index_Bounds (Choice, Low, High); 2739 2740 if not Compile_Time_Known_Value (Low) then 2741 Collect_Identifiers (Low); 2742 2743 if No (Aggr_Error_Node) then 2744 Aggr_Error_Node := Low; 2745 end if; 2746 end if; 2747 2748 if not Compile_Time_Known_Value (High) then 2749 Collect_Identifiers (High); 2750 2751 if No (Aggr_Error_Node) then 2752 Aggr_Error_Node := High; 2753 end if; 2754 end if; 2755 2756 -- The RM rule is violated if there is more than 2757 -- a single choice in a component association. 2758 2759 else 2760 Count_Components := Count_Components + 1; 2761 2762 if No (Aggr_Error_Node) 2763 and then Count_Components > 1 2764 then 2765 Aggr_Error_Node := Choice; 2766 end if; 2767 2768 if not Compile_Time_Known_Value (Choice) then 2769 Collect_Identifiers (Choice); 2770 end if; 2771 end if; 2772 2773 Next (Choice); 2774 end loop; 2775 2776 Next (Assoc); 2777 end loop; 2778 end; 2779 end if; 2780 2781 -- Handle ancestor part of extension aggregates 2782 2783 if Nkind (N) = N_Extension_Aggregate then 2784 Collect_Identifiers (Ancestor_Part (N)); 2785 end if; 2786 2787 -- Handle positional associations 2788 2789 if Present (Expressions (N)) then 2790 Comp_Expr := First (Expressions (N)); 2791 while Present (Comp_Expr) loop 2792 if not Is_OK_Static_Expression (Comp_Expr) then 2793 Collect_Identifiers (Comp_Expr); 2794 end if; 2795 2796 Next (Comp_Expr); 2797 end loop; 2798 end if; 2799 2800 -- Handle discrete associations 2801 2802 if Present (Component_Associations (N)) then 2803 Assoc := First (Component_Associations (N)); 2804 while Present (Assoc) loop 2805 2806 if not Box_Present (Assoc) then 2807 Choice := First (Choices (Assoc)); 2808 while Present (Choice) loop 2809 2810 -- For now we skip discriminants since it requires 2811 -- performing the analysis in two phases: first one 2812 -- analyzing discriminants and second one analyzing 2813 -- the rest of components since discriminants are 2814 -- evaluated prior to components: too much extra 2815 -- work to detect a corner case??? 2816 2817 if Nkind (Choice) in N_Has_Entity 2818 and then Present (Entity (Choice)) 2819 and then Ekind (Entity (Choice)) = E_Discriminant 2820 then 2821 null; 2822 2823 elsif Box_Present (Assoc) then 2824 null; 2825 2826 else 2827 if not Analyzed (Expression (Assoc)) then 2828 Comp_Expr := 2829 New_Copy_Tree (Expression (Assoc)); 2830 Set_Parent (Comp_Expr, Parent (N)); 2831 Preanalyze_Without_Errors (Comp_Expr); 2832 else 2833 Comp_Expr := Expression (Assoc); 2834 end if; 2835 2836 Collect_Identifiers (Comp_Expr); 2837 end if; 2838 2839 Next (Choice); 2840 end loop; 2841 end if; 2842 2843 Next (Assoc); 2844 end loop; 2845 end if; 2846 end; 2847 2848 when others => 2849 return; 2850 end case; 2851 2852 -- No further action needed if we already reported an error 2853 2854 if Present (Error_Node) then 2855 return; 2856 end if; 2857 2858 -- Check violation of RM 6.20/3 in aggregates 2859 2860 if Present (Aggr_Error_Node) 2861 and then Writable_Actuals_List /= No_Elist 2862 then 2863 Error_Msg_N 2864 ("value may be affected by call in other component because they " 2865 & "are evaluated in unspecified order", 2866 Node (First_Elmt (Writable_Actuals_List))); 2867 return; 2868 end if; 2869 2870 -- Check if some writable argument of a function is referenced 2871 2872 if Writable_Actuals_List /= No_Elist 2873 and then Identifiers_List /= No_Elist 2874 then 2875 declare 2876 Elmt_1 : Elmt_Id; 2877 Elmt_2 : Elmt_Id; 2878 2879 begin 2880 Elmt_1 := First_Elmt (Writable_Actuals_List); 2881 while Present (Elmt_1) loop 2882 Elmt_2 := First_Elmt (Identifiers_List); 2883 while Present (Elmt_2) loop 2884 if Entity (Node (Elmt_1)) = Entity (Node (Elmt_2)) then 2885 case Nkind (Parent (Node (Elmt_2))) is 2886 when N_Aggregate | 2887 N_Component_Association | 2888 N_Component_Declaration => 2889 Error_Msg_N 2890 ("value may be affected by call in other " 2891 & "component because they are evaluated " 2892 & "in unspecified order", 2893 Node (Elmt_2)); 2894 2895 when N_In | N_Not_In => 2896 Error_Msg_N 2897 ("value may be affected by call in other " 2898 & "alternative because they are evaluated " 2899 & "in unspecified order", 2900 Node (Elmt_2)); 2901 2902 when others => 2903 Error_Msg_N 2904 ("value of actual may be affected by call in " 2905 & "other actual because they are evaluated " 2906 & "in unspecified order", 2907 Node (Elmt_2)); 2908 end case; 2909 end if; 2910 2911 Next_Elmt (Elmt_2); 2912 end loop; 2913 2914 Next_Elmt (Elmt_1); 2915 end loop; 2916 end; 2917 end if; 2918 end Check_Function_Writable_Actuals; 2919 2920 -------------------------------- 2921 -- Check_Implicit_Dereference -- 2922 -------------------------------- 2923 2924 procedure Check_Implicit_Dereference (N : Node_Id; Typ : Entity_Id) is 2925 Disc : Entity_Id; 2926 Desig : Entity_Id; 2927 Nam : Node_Id; 2928 2929 begin 2930 if Nkind (N) = N_Indexed_Component 2931 and then Present (Generalized_Indexing (N)) 2932 then 2933 Nam := Generalized_Indexing (N); 2934 else 2935 Nam := N; 2936 end if; 2937 2938 if Ada_Version < Ada_2012 2939 or else not Has_Implicit_Dereference (Base_Type (Typ)) 2940 then 2941 return; 2942 2943 elsif not Comes_From_Source (N) 2944 and then Nkind (N) /= N_Indexed_Component 2945 then 2946 return; 2947 2948 elsif Is_Entity_Name (Nam) and then Is_Type (Entity (Nam)) then 2949 null; 2950 2951 else 2952 Disc := First_Discriminant (Typ); 2953 while Present (Disc) loop 2954 if Has_Implicit_Dereference (Disc) then 2955 Desig := Designated_Type (Etype (Disc)); 2956 Add_One_Interp (Nam, Disc, Desig); 2957 2958 -- If the node is a generalized indexing, add interpretation 2959 -- to that node as well, for subsequent resolution. 2960 2961 if Nkind (N) = N_Indexed_Component then 2962 Add_One_Interp (N, Disc, Desig); 2963 end if; 2964 2965 -- If the operation comes from a generic unit and the context 2966 -- is a selected component, the selector name may be global 2967 -- and set in the instance already. Remove the entity to 2968 -- force resolution of the selected component, and the 2969 -- generation of an explicit dereference if needed. 2970 2971 if In_Instance 2972 and then Nkind (Parent (Nam)) = N_Selected_Component 2973 then 2974 Set_Entity (Selector_Name (Parent (Nam)), Empty); 2975 end if; 2976 2977 exit; 2978 end if; 2979 2980 Next_Discriminant (Disc); 2981 end loop; 2982 end if; 2983 end Check_Implicit_Dereference; 2984 2985 ---------------------------------- 2986 -- Check_Internal_Protected_Use -- 2987 ---------------------------------- 2988 2989 procedure Check_Internal_Protected_Use (N : Node_Id; Nam : Entity_Id) is 2990 S : Entity_Id; 2991 Prot : Entity_Id; 2992 2993 begin 2994 S := Current_Scope; 2995 while Present (S) loop 2996 if S = Standard_Standard then 2997 return; 2998 2999 elsif Ekind (S) = E_Function 3000 and then Ekind (Scope (S)) = E_Protected_Type 3001 then 3002 Prot := Scope (S); 3003 exit; 3004 end if; 3005 3006 S := Scope (S); 3007 end loop; 3008 3009 if Scope (Nam) = Prot and then Ekind (Nam) /= E_Function then 3010 3011 -- An indirect function call (e.g. a callback within a protected 3012 -- function body) is not statically illegal. If the access type is 3013 -- anonymous and is the type of an access parameter, the scope of Nam 3014 -- will be the protected type, but it is not a protected operation. 3015 3016 if Ekind (Nam) = E_Subprogram_Type 3017 and then 3018 Nkind (Associated_Node_For_Itype (Nam)) = N_Function_Specification 3019 then 3020 null; 3021 3022 elsif Nkind (N) = N_Subprogram_Renaming_Declaration then 3023 Error_Msg_N 3024 ("within protected function cannot use protected " 3025 & "procedure in renaming or as generic actual", N); 3026 3027 elsif Nkind (N) = N_Attribute_Reference then 3028 Error_Msg_N 3029 ("within protected function cannot take access of " 3030 & " protected procedure", N); 3031 3032 else 3033 Error_Msg_N 3034 ("within protected function, protected object is constant", N); 3035 Error_Msg_N 3036 ("\cannot call operation that may modify it", N); 3037 end if; 3038 end if; 3039 end Check_Internal_Protected_Use; 3040 3041 --------------------------------------- 3042 -- Check_Later_Vs_Basic_Declarations -- 3043 --------------------------------------- 3044 3045 procedure Check_Later_Vs_Basic_Declarations 3046 (Decls : List_Id; 3047 During_Parsing : Boolean) 3048 is 3049 Body_Sloc : Source_Ptr; 3050 Decl : Node_Id; 3051 3052 function Is_Later_Declarative_Item (Decl : Node_Id) return Boolean; 3053 -- Return whether Decl is considered as a declarative item. 3054 -- When During_Parsing is True, the semantics of Ada 83 is followed. 3055 -- When During_Parsing is False, the semantics of SPARK is followed. 3056 3057 ------------------------------- 3058 -- Is_Later_Declarative_Item -- 3059 ------------------------------- 3060 3061 function Is_Later_Declarative_Item (Decl : Node_Id) return Boolean is 3062 begin 3063 if Nkind (Decl) in N_Later_Decl_Item then 3064 return True; 3065 3066 elsif Nkind (Decl) = N_Pragma then 3067 return True; 3068 3069 elsif During_Parsing then 3070 return False; 3071 3072 -- In SPARK, a package declaration is not considered as a later 3073 -- declarative item. 3074 3075 elsif Nkind (Decl) = N_Package_Declaration then 3076 return False; 3077 3078 -- In SPARK, a renaming is considered as a later declarative item 3079 3080 elsif Nkind (Decl) in N_Renaming_Declaration then 3081 return True; 3082 3083 else 3084 return False; 3085 end if; 3086 end Is_Later_Declarative_Item; 3087 3088 -- Start of processing for Check_Later_Vs_Basic_Declarations 3089 3090 begin 3091 Decl := First (Decls); 3092 3093 -- Loop through sequence of basic declarative items 3094 3095 Outer : while Present (Decl) loop 3096 if not Nkind_In (Decl, N_Subprogram_Body, N_Package_Body, N_Task_Body) 3097 and then Nkind (Decl) not in N_Body_Stub 3098 then 3099 Next (Decl); 3100 3101 -- Once a body is encountered, we only allow later declarative 3102 -- items. The inner loop checks the rest of the list. 3103 3104 else 3105 Body_Sloc := Sloc (Decl); 3106 3107 Inner : while Present (Decl) loop 3108 if not Is_Later_Declarative_Item (Decl) then 3109 if During_Parsing then 3110 if Ada_Version = Ada_83 then 3111 Error_Msg_Sloc := Body_Sloc; 3112 Error_Msg_N 3113 ("(Ada 83) decl cannot appear after body#", Decl); 3114 end if; 3115 else 3116 Error_Msg_Sloc := Body_Sloc; 3117 Check_SPARK_05_Restriction 3118 ("decl cannot appear after body#", Decl); 3119 end if; 3120 end if; 3121 3122 Next (Decl); 3123 end loop Inner; 3124 end if; 3125 end loop Outer; 3126 end Check_Later_Vs_Basic_Declarations; 3127 3128 --------------------------- 3129 -- Check_No_Hidden_State -- 3130 --------------------------- 3131 3132 procedure Check_No_Hidden_State (Id : Entity_Id) is 3133 function Has_Null_Abstract_State (Pkg : Entity_Id) return Boolean; 3134 -- Determine whether the entity of a package denoted by Pkg has a null 3135 -- abstract state. 3136 3137 ----------------------------- 3138 -- Has_Null_Abstract_State -- 3139 ----------------------------- 3140 3141 function Has_Null_Abstract_State (Pkg : Entity_Id) return Boolean is 3142 States : constant Elist_Id := Abstract_States (Pkg); 3143 3144 begin 3145 -- Check first available state of related package. A null abstract 3146 -- state always appears as the sole element of the state list. 3147 3148 return 3149 Present (States) 3150 and then Is_Null_State (Node (First_Elmt (States))); 3151 end Has_Null_Abstract_State; 3152 3153 -- Local variables 3154 3155 Context : Entity_Id := Empty; 3156 Not_Visible : Boolean := False; 3157 Scop : Entity_Id; 3158 3159 -- Start of processing for Check_No_Hidden_State 3160 3161 begin 3162 pragma Assert (Ekind_In (Id, E_Abstract_State, E_Variable)); 3163 3164 -- Find the proper context where the object or state appears 3165 3166 Scop := Scope (Id); 3167 while Present (Scop) loop 3168 Context := Scop; 3169 3170 -- Keep track of the context's visibility 3171 3172 Not_Visible := Not_Visible or else In_Private_Part (Context); 3173 3174 -- Prevent the search from going too far 3175 3176 if Context = Standard_Standard then 3177 return; 3178 3179 -- Objects and states that appear immediately within a subprogram or 3180 -- inside a construct nested within a subprogram do not introduce a 3181 -- hidden state. They behave as local variable declarations. 3182 3183 elsif Is_Subprogram (Context) then 3184 return; 3185 3186 -- When examining a package body, use the entity of the spec as it 3187 -- carries the abstract state declarations. 3188 3189 elsif Ekind (Context) = E_Package_Body then 3190 Context := Spec_Entity (Context); 3191 end if; 3192 3193 -- Stop the traversal when a package subject to a null abstract state 3194 -- has been found. 3195 3196 if Ekind_In (Context, E_Generic_Package, E_Package) 3197 and then Has_Null_Abstract_State (Context) 3198 then 3199 exit; 3200 end if; 3201 3202 Scop := Scope (Scop); 3203 end loop; 3204 3205 -- At this point we know that there is at least one package with a null 3206 -- abstract state in visibility. Emit an error message unconditionally 3207 -- if the entity being processed is a state because the placement of the 3208 -- related package is irrelevant. This is not the case for objects as 3209 -- the intermediate context matters. 3210 3211 if Present (Context) 3212 and then (Ekind (Id) = E_Abstract_State or else Not_Visible) 3213 then 3214 Error_Msg_N ("cannot introduce hidden state &", Id); 3215 Error_Msg_NE ("\package & has null abstract state", Id, Context); 3216 end if; 3217 end Check_No_Hidden_State; 3218 3219 ---------------------------------------- 3220 -- Check_Nonvolatile_Function_Profile -- 3221 ---------------------------------------- 3222 3223 procedure Check_Nonvolatile_Function_Profile (Func_Id : Entity_Id) is 3224 Formal : Entity_Id; 3225 3226 begin 3227 -- Inspect all formal parameters 3228 3229 Formal := First_Formal (Func_Id); 3230 while Present (Formal) loop 3231 if Is_Effectively_Volatile (Etype (Formal)) then 3232 Error_Msg_NE 3233 ("nonvolatile function & cannot have a volatile parameter", 3234 Formal, Func_Id); 3235 end if; 3236 3237 Next_Formal (Formal); 3238 end loop; 3239 3240 -- Inspect the return type 3241 3242 if Is_Effectively_Volatile (Etype (Func_Id)) then 3243 Error_Msg_NE 3244 ("nonvolatile function & cannot have a volatile return type", 3245 Result_Definition (Parent (Func_Id)), Func_Id); 3246 end if; 3247 end Check_Nonvolatile_Function_Profile; 3248 3249 ------------------------------------------ 3250 -- Check_Potentially_Blocking_Operation -- 3251 ------------------------------------------ 3252 3253 procedure Check_Potentially_Blocking_Operation (N : Node_Id) is 3254 S : Entity_Id; 3255 3256 begin 3257 -- N is one of the potentially blocking operations listed in 9.5.1(8). 3258 -- When pragma Detect_Blocking is active, the run time will raise 3259 -- Program_Error. Here we only issue a warning, since we generally 3260 -- support the use of potentially blocking operations in the absence 3261 -- of the pragma. 3262 3263 -- Indirect blocking through a subprogram call cannot be diagnosed 3264 -- statically without interprocedural analysis, so we do not attempt 3265 -- to do it here. 3266 3267 S := Scope (Current_Scope); 3268 while Present (S) and then S /= Standard_Standard loop 3269 if Is_Protected_Type (S) then 3270 Error_Msg_N 3271 ("potentially blocking operation in protected operation??", N); 3272 return; 3273 end if; 3274 3275 S := Scope (S); 3276 end loop; 3277 end Check_Potentially_Blocking_Operation; 3278 3279 --------------------------------- 3280 -- Check_Result_And_Post_State -- 3281 --------------------------------- 3282 3283 procedure Check_Result_And_Post_State (Subp_Id : Entity_Id) is 3284 procedure Check_Result_And_Post_State_In_Pragma 3285 (Prag : Node_Id; 3286 Result_Seen : in out Boolean); 3287 -- Determine whether pragma Prag mentions attribute 'Result and whether 3288 -- the pragma contains an expression that evaluates differently in pre- 3289 -- and post-state. Prag is a [refined] postcondition or a contract-cases 3290 -- pragma. Result_Seen is set when the pragma mentions attribute 'Result 3291 3292 function Has_In_Out_Parameter (Subp_Id : Entity_Id) return Boolean; 3293 -- Determine whether subprogram Subp_Id contains at least one IN OUT 3294 -- formal parameter. 3295 3296 ------------------------------------------- 3297 -- Check_Result_And_Post_State_In_Pragma -- 3298 ------------------------------------------- 3299 3300 procedure Check_Result_And_Post_State_In_Pragma 3301 (Prag : Node_Id; 3302 Result_Seen : in out Boolean) 3303 is 3304 procedure Check_Expression (Expr : Node_Id); 3305 -- Perform the 'Result and post-state checks on a given expression 3306 3307 function Is_Function_Result (N : Node_Id) return Traverse_Result; 3308 -- Attempt to find attribute 'Result in a subtree denoted by N 3309 3310 function Is_Trivial_Boolean (N : Node_Id) return Boolean; 3311 -- Determine whether source node N denotes "True" or "False" 3312 3313 function Mentions_Post_State (N : Node_Id) return Boolean; 3314 -- Determine whether a subtree denoted by N mentions any construct 3315 -- that denotes a post-state. 3316 3317 procedure Check_Function_Result is 3318 new Traverse_Proc (Is_Function_Result); 3319 3320 ---------------------- 3321 -- Check_Expression -- 3322 ---------------------- 3323 3324 procedure Check_Expression (Expr : Node_Id) is 3325 begin 3326 if not Is_Trivial_Boolean (Expr) then 3327 Check_Function_Result (Expr); 3328 3329 if not Mentions_Post_State (Expr) then 3330 if Pragma_Name (Prag) = Name_Contract_Cases then 3331 Error_Msg_NE 3332 ("contract case does not check the outcome of calling " 3333 & "&?T?", Expr, Subp_Id); 3334 3335 elsif Pragma_Name (Prag) = Name_Refined_Post then 3336 Error_Msg_NE 3337 ("refined postcondition does not check the outcome of " 3338 & "calling &?T?", Prag, Subp_Id); 3339 3340 else 3341 Error_Msg_NE 3342 ("postcondition does not check the outcome of calling " 3343 & "&?T?", Prag, Subp_Id); 3344 end if; 3345 end if; 3346 end if; 3347 end Check_Expression; 3348 3349 ------------------------ 3350 -- Is_Function_Result -- 3351 ------------------------ 3352 3353 function Is_Function_Result (N : Node_Id) return Traverse_Result is 3354 begin 3355 if Is_Attribute_Result (N) then 3356 Result_Seen := True; 3357 return Abandon; 3358 3359 -- Continue the traversal 3360 3361 else 3362 return OK; 3363 end if; 3364 end Is_Function_Result; 3365 3366 ------------------------ 3367 -- Is_Trivial_Boolean -- 3368 ------------------------ 3369 3370 function Is_Trivial_Boolean (N : Node_Id) return Boolean is 3371 begin 3372 return 3373 Comes_From_Source (N) 3374 and then Is_Entity_Name (N) 3375 and then (Entity (N) = Standard_True 3376 or else 3377 Entity (N) = Standard_False); 3378 end Is_Trivial_Boolean; 3379 3380 ------------------------- 3381 -- Mentions_Post_State -- 3382 ------------------------- 3383 3384 function Mentions_Post_State (N : Node_Id) return Boolean is 3385 Post_State_Seen : Boolean := False; 3386 3387 function Is_Post_State (N : Node_Id) return Traverse_Result; 3388 -- Attempt to find a construct that denotes a post-state. If this 3389 -- is the case, set flag Post_State_Seen. 3390 3391 ------------------- 3392 -- Is_Post_State -- 3393 ------------------- 3394 3395 function Is_Post_State (N : Node_Id) return Traverse_Result is 3396 Ent : Entity_Id; 3397 3398 begin 3399 if Nkind_In (N, N_Explicit_Dereference, N_Function_Call) then 3400 Post_State_Seen := True; 3401 return Abandon; 3402 3403 elsif Nkind_In (N, N_Expanded_Name, N_Identifier) then 3404 Ent := Entity (N); 3405 3406 -- The entity may be modifiable through an implicit 3407 -- dereference. 3408 3409 if No (Ent) 3410 or else Ekind (Ent) in Assignable_Kind 3411 or else (Is_Access_Type (Etype (Ent)) 3412 and then Nkind (Parent (N)) = 3413 N_Selected_Component) 3414 then 3415 Post_State_Seen := True; 3416 return Abandon; 3417 end if; 3418 3419 elsif Nkind (N) = N_Attribute_Reference then 3420 if Attribute_Name (N) = Name_Old then 3421 return Skip; 3422 3423 elsif Attribute_Name (N) = Name_Result then 3424 Post_State_Seen := True; 3425 return Abandon; 3426 end if; 3427 end if; 3428 3429 return OK; 3430 end Is_Post_State; 3431 3432 procedure Find_Post_State is new Traverse_Proc (Is_Post_State); 3433 3434 -- Start of processing for Mentions_Post_State 3435 3436 begin 3437 Find_Post_State (N); 3438 3439 return Post_State_Seen; 3440 end Mentions_Post_State; 3441 3442 -- Local variables 3443 3444 Expr : constant Node_Id := 3445 Get_Pragma_Arg 3446 (First (Pragma_Argument_Associations (Prag))); 3447 Nam : constant Name_Id := Pragma_Name (Prag); 3448 CCase : Node_Id; 3449 3450 -- Start of processing for Check_Result_And_Post_State_In_Pragma 3451 3452 begin 3453 -- Examine all consequences 3454 3455 if Nam = Name_Contract_Cases then 3456 CCase := First (Component_Associations (Expr)); 3457 while Present (CCase) loop 3458 Check_Expression (Expression (CCase)); 3459 3460 Next (CCase); 3461 end loop; 3462 3463 -- Examine the expression of a postcondition 3464 3465 else pragma Assert (Nam_In (Nam, Name_Postcondition, 3466 Name_Refined_Post)); 3467 Check_Expression (Expr); 3468 end if; 3469 end Check_Result_And_Post_State_In_Pragma; 3470 3471 -------------------------- 3472 -- Has_In_Out_Parameter -- 3473 -------------------------- 3474 3475 function Has_In_Out_Parameter (Subp_Id : Entity_Id) return Boolean is 3476 Formal : Entity_Id; 3477 3478 begin 3479 -- Traverse the formals looking for an IN OUT parameter 3480 3481 Formal := First_Formal (Subp_Id); 3482 while Present (Formal) loop 3483 if Ekind (Formal) = E_In_Out_Parameter then 3484 return True; 3485 end if; 3486 3487 Next_Formal (Formal); 3488 end loop; 3489 3490 return False; 3491 end Has_In_Out_Parameter; 3492 3493 -- Local variables 3494 3495 Items : constant Node_Id := Contract (Subp_Id); 3496 Subp_Decl : constant Node_Id := Unit_Declaration_Node (Subp_Id); 3497 Case_Prag : Node_Id := Empty; 3498 Post_Prag : Node_Id := Empty; 3499 Prag : Node_Id; 3500 Seen_In_Case : Boolean := False; 3501 Seen_In_Post : Boolean := False; 3502 Spec_Id : Entity_Id; 3503 3504 -- Start of processing for Check_Result_And_Post_State 3505 3506 begin 3507 -- The lack of attribute 'Result or a post-state is classified as a 3508 -- suspicious contract. Do not perform the check if the corresponding 3509 -- swich is not set. 3510 3511 if not Warn_On_Suspicious_Contract then 3512 return; 3513 3514 -- Nothing to do if there is no contract 3515 3516 elsif No (Items) then 3517 return; 3518 end if; 3519 3520 -- Retrieve the entity of the subprogram spec (if any) 3521 3522 if Nkind (Subp_Decl) = N_Subprogram_Body 3523 and then Present (Corresponding_Spec (Subp_Decl)) 3524 then 3525 Spec_Id := Corresponding_Spec (Subp_Decl); 3526 3527 elsif Nkind (Subp_Decl) = N_Subprogram_Body_Stub 3528 and then Present (Corresponding_Spec_Of_Stub (Subp_Decl)) 3529 then 3530 Spec_Id := Corresponding_Spec_Of_Stub (Subp_Decl); 3531 3532 else 3533 Spec_Id := Subp_Id; 3534 end if; 3535 3536 -- Examine all postconditions for attribute 'Result and a post-state 3537 3538 Prag := Pre_Post_Conditions (Items); 3539 while Present (Prag) loop 3540 if Nam_In (Pragma_Name (Prag), Name_Postcondition, 3541 Name_Refined_Post) 3542 and then not Error_Posted (Prag) 3543 then 3544 Post_Prag := Prag; 3545 Check_Result_And_Post_State_In_Pragma (Prag, Seen_In_Post); 3546 end if; 3547 3548 Prag := Next_Pragma (Prag); 3549 end loop; 3550 3551 -- Examine the contract cases of the subprogram for attribute 'Result 3552 -- and a post-state. 3553 3554 Prag := Contract_Test_Cases (Items); 3555 while Present (Prag) loop 3556 if Pragma_Name (Prag) = Name_Contract_Cases 3557 and then not Error_Posted (Prag) 3558 then 3559 Case_Prag := Prag; 3560 Check_Result_And_Post_State_In_Pragma (Prag, Seen_In_Case); 3561 end if; 3562 3563 Prag := Next_Pragma (Prag); 3564 end loop; 3565 3566 -- Do not emit any errors if the subprogram is not a function 3567 3568 if not Ekind_In (Spec_Id, E_Function, E_Generic_Function) then 3569 null; 3570 3571 -- Regardless of whether the function has postconditions or contract 3572 -- cases, or whether they mention attribute 'Result, an IN OUT formal 3573 -- parameter is always treated as a result. 3574 3575 elsif Has_In_Out_Parameter (Spec_Id) then 3576 null; 3577 3578 -- The function has both a postcondition and contract cases and they do 3579 -- not mention attribute 'Result. 3580 3581 elsif Present (Case_Prag) 3582 and then not Seen_In_Case 3583 and then Present (Post_Prag) 3584 and then not Seen_In_Post 3585 then 3586 Error_Msg_N 3587 ("neither postcondition nor contract cases mention function " 3588 & "result?T?", Post_Prag); 3589 3590 -- The function has contract cases only and they do not mention 3591 -- attribute 'Result. 3592 3593 elsif Present (Case_Prag) and then not Seen_In_Case then 3594 Error_Msg_N ("contract cases do not mention result?T?", Case_Prag); 3595 3596 -- The function has postconditions only and they do not mention 3597 -- attribute 'Result. 3598 3599 elsif Present (Post_Prag) and then not Seen_In_Post then 3600 Error_Msg_N 3601 ("postcondition does not mention function result?T?", Post_Prag); 3602 end if; 3603 end Check_Result_And_Post_State; 3604 3605 ------------------------------ 3606 -- Check_Unprotected_Access -- 3607 ------------------------------ 3608 3609 procedure Check_Unprotected_Access 3610 (Context : Node_Id; 3611 Expr : Node_Id) 3612 is 3613 Cont_Encl_Typ : Entity_Id; 3614 Pref_Encl_Typ : Entity_Id; 3615 3616 function Enclosing_Protected_Type (Obj : Node_Id) return Entity_Id; 3617 -- Check whether Obj is a private component of a protected object. 3618 -- Return the protected type where the component resides, Empty 3619 -- otherwise. 3620 3621 function Is_Public_Operation return Boolean; 3622 -- Verify that the enclosing operation is callable from outside the 3623 -- protected object, to minimize false positives. 3624 3625 ------------------------------ 3626 -- Enclosing_Protected_Type -- 3627 ------------------------------ 3628 3629 function Enclosing_Protected_Type (Obj : Node_Id) return Entity_Id is 3630 begin 3631 if Is_Entity_Name (Obj) then 3632 declare 3633 Ent : Entity_Id := Entity (Obj); 3634 3635 begin 3636 -- The object can be a renaming of a private component, use 3637 -- the original record component. 3638 3639 if Is_Prival (Ent) then 3640 Ent := Prival_Link (Ent); 3641 end if; 3642 3643 if Is_Protected_Type (Scope (Ent)) then 3644 return Scope (Ent); 3645 end if; 3646 end; 3647 end if; 3648 3649 -- For indexed and selected components, recursively check the prefix 3650 3651 if Nkind_In (Obj, N_Indexed_Component, N_Selected_Component) then 3652 return Enclosing_Protected_Type (Prefix (Obj)); 3653 3654 -- The object does not denote a protected component 3655 3656 else 3657 return Empty; 3658 end if; 3659 end Enclosing_Protected_Type; 3660 3661 ------------------------- 3662 -- Is_Public_Operation -- 3663 ------------------------- 3664 3665 function Is_Public_Operation return Boolean is 3666 S : Entity_Id; 3667 E : Entity_Id; 3668 3669 begin 3670 S := Current_Scope; 3671 while Present (S) and then S /= Pref_Encl_Typ loop 3672 if Scope (S) = Pref_Encl_Typ then 3673 E := First_Entity (Pref_Encl_Typ); 3674 while Present (E) 3675 and then E /= First_Private_Entity (Pref_Encl_Typ) 3676 loop 3677 if E = S then 3678 return True; 3679 end if; 3680 3681 Next_Entity (E); 3682 end loop; 3683 end if; 3684 3685 S := Scope (S); 3686 end loop; 3687 3688 return False; 3689 end Is_Public_Operation; 3690 3691 -- Start of processing for Check_Unprotected_Access 3692 3693 begin 3694 if Nkind (Expr) = N_Attribute_Reference 3695 and then Attribute_Name (Expr) = Name_Unchecked_Access 3696 then 3697 Cont_Encl_Typ := Enclosing_Protected_Type (Context); 3698 Pref_Encl_Typ := Enclosing_Protected_Type (Prefix (Expr)); 3699 3700 -- Check whether we are trying to export a protected component to a 3701 -- context with an equal or lower access level. 3702 3703 if Present (Pref_Encl_Typ) 3704 and then No (Cont_Encl_Typ) 3705 and then Is_Public_Operation 3706 and then Scope_Depth (Pref_Encl_Typ) >= 3707 Object_Access_Level (Context) 3708 then 3709 Error_Msg_N 3710 ("??possible unprotected access to protected data", Expr); 3711 end if; 3712 end if; 3713 end Check_Unprotected_Access; 3714 3715 ------------------------------ 3716 -- Check_Unused_Body_States -- 3717 ------------------------------ 3718 3719 procedure Check_Unused_Body_States (Body_Id : Entity_Id) is 3720 procedure Process_Refinement_Clause 3721 (Clause : Node_Id; 3722 States : Elist_Id); 3723 -- Inspect all constituents of refinement clause Clause and remove any 3724 -- matches from body state list States. 3725 3726 procedure Report_Unused_Body_States (States : Elist_Id); 3727 -- Emit errors for each abstract state or object found in list States 3728 3729 ------------------------------- 3730 -- Process_Refinement_Clause -- 3731 ------------------------------- 3732 3733 procedure Process_Refinement_Clause 3734 (Clause : Node_Id; 3735 States : Elist_Id) 3736 is 3737 procedure Process_Constituent (Constit : Node_Id); 3738 -- Remove constituent Constit from body state list States 3739 3740 ------------------------- 3741 -- Process_Constituent -- 3742 ------------------------- 3743 3744 procedure Process_Constituent (Constit : Node_Id) is 3745 Constit_Id : Entity_Id; 3746 3747 begin 3748 -- Guard against illegal constituents. Only abstract states and 3749 -- objects can appear on the right hand side of a refinement. 3750 3751 if Is_Entity_Name (Constit) then 3752 Constit_Id := Entity_Of (Constit); 3753 3754 if Present (Constit_Id) 3755 and then Ekind_In (Constit_Id, E_Abstract_State, 3756 E_Constant, 3757 E_Variable) 3758 then 3759 Remove (States, Constit_Id); 3760 end if; 3761 end if; 3762 end Process_Constituent; 3763 3764 -- Local variables 3765 3766 Constit : Node_Id; 3767 3768 -- Start of processing for Process_Refinement_Clause 3769 3770 begin 3771 if Nkind (Clause) = N_Component_Association then 3772 Constit := Expression (Clause); 3773 3774 -- Multiple constituents appear as an aggregate 3775 3776 if Nkind (Constit) = N_Aggregate then 3777 Constit := First (Expressions (Constit)); 3778 while Present (Constit) loop 3779 Process_Constituent (Constit); 3780 Next (Constit); 3781 end loop; 3782 3783 -- Various forms of a single constituent 3784 3785 else 3786 Process_Constituent (Constit); 3787 end if; 3788 end if; 3789 end Process_Refinement_Clause; 3790 3791 ------------------------------- 3792 -- Report_Unused_Body_States -- 3793 ------------------------------- 3794 3795 procedure Report_Unused_Body_States (States : Elist_Id) is 3796 Posted : Boolean := False; 3797 State_Elmt : Elmt_Id; 3798 State_Id : Entity_Id; 3799 3800 begin 3801 if Present (States) then 3802 State_Elmt := First_Elmt (States); 3803 while Present (State_Elmt) loop 3804 State_Id := Node (State_Elmt); 3805 3806 -- Constants are part of the hidden state of a package, but the 3807 -- compiler cannot determine whether they have variable input 3808 -- (SPARK RM 7.1.1(2)) and cannot classify them properly as a 3809 -- hidden state. Do not emit an error when a constant does not 3810 -- participate in a state refinement, even though it acts as a 3811 -- hidden state. 3812 3813 if Ekind (State_Id) = E_Constant then 3814 null; 3815 3816 -- Generate an error message of the form: 3817 3818 -- body of package ... has unused hidden states 3819 -- abstract state ... defined at ... 3820 -- variable ... defined at ... 3821 3822 else 3823 if not Posted then 3824 Posted := True; 3825 SPARK_Msg_N 3826 ("body of package & has unused hidden states", Body_Id); 3827 end if; 3828 3829 Error_Msg_Sloc := Sloc (State_Id); 3830 3831 if Ekind (State_Id) = E_Abstract_State then 3832 SPARK_Msg_NE 3833 ("\abstract state & defined #", Body_Id, State_Id); 3834 3835 else 3836 SPARK_Msg_NE ("\variable & defined #", Body_Id, State_Id); 3837 end if; 3838 end if; 3839 3840 Next_Elmt (State_Elmt); 3841 end loop; 3842 end if; 3843 end Report_Unused_Body_States; 3844 3845 -- Local variables 3846 3847 Prag : constant Node_Id := Get_Pragma (Body_Id, Pragma_Refined_State); 3848 Spec_Id : constant Entity_Id := Spec_Entity (Body_Id); 3849 Clause : Node_Id; 3850 States : Elist_Id; 3851 3852 -- Start of processing for Check_Unused_Body_States 3853 3854 begin 3855 -- Inspect the clauses of pragma Refined_State and determine whether all 3856 -- visible states declared within the package body participate in the 3857 -- refinement. 3858 3859 if Present (Prag) then 3860 Clause := Expression (Get_Argument (Prag, Spec_Id)); 3861 States := Collect_Body_States (Body_Id); 3862 3863 -- Multiple non-null state refinements appear as an aggregate 3864 3865 if Nkind (Clause) = N_Aggregate then 3866 Clause := First (Component_Associations (Clause)); 3867 while Present (Clause) loop 3868 Process_Refinement_Clause (Clause, States); 3869 Next (Clause); 3870 end loop; 3871 3872 -- Various forms of a single state refinement 3873 3874 else 3875 Process_Refinement_Clause (Clause, States); 3876 end if; 3877 3878 -- Ensure that all abstract states and objects declared in the 3879 -- package body state space are utilized as constituents. 3880 3881 Report_Unused_Body_States (States); 3882 end if; 3883 end Check_Unused_Body_States; 3884 3885 ------------------------- 3886 -- Collect_Body_States -- 3887 ------------------------- 3888 3889 function Collect_Body_States (Body_Id : Entity_Id) return Elist_Id is 3890 function Is_Visible_Object (Obj_Id : Entity_Id) return Boolean; 3891 -- Determine whether object Obj_Id is a suitable visible state of a 3892 -- package body. 3893 3894 procedure Collect_Visible_States 3895 (Pack_Id : Entity_Id; 3896 States : in out Elist_Id); 3897 -- Gather the entities of all abstract states and objects declared in 3898 -- the visible state space of package Pack_Id. 3899 3900 ---------------------------- 3901 -- Collect_Visible_States -- 3902 ---------------------------- 3903 3904 procedure Collect_Visible_States 3905 (Pack_Id : Entity_Id; 3906 States : in out Elist_Id) 3907 is 3908 Item_Id : Entity_Id; 3909 3910 begin 3911 -- Traverse the entity chain of the package and inspect all visible 3912 -- items. 3913 3914 Item_Id := First_Entity (Pack_Id); 3915 while Present (Item_Id) and then not In_Private_Part (Item_Id) loop 3916 3917 -- Do not consider internally generated items as those cannot be 3918 -- named and participate in refinement. 3919 3920 if not Comes_From_Source (Item_Id) then 3921 null; 3922 3923 elsif Ekind (Item_Id) = E_Abstract_State then 3924 Append_New_Elmt (Item_Id, States); 3925 3926 elsif Ekind_In (Item_Id, E_Constant, E_Variable) 3927 and then Is_Visible_Object (Item_Id) 3928 then 3929 Append_New_Elmt (Item_Id, States); 3930 3931 -- Recursively gather the visible states of a nested package 3932 3933 elsif Ekind (Item_Id) = E_Package then 3934 Collect_Visible_States (Item_Id, States); 3935 end if; 3936 3937 Next_Entity (Item_Id); 3938 end loop; 3939 end Collect_Visible_States; 3940 3941 ----------------------- 3942 -- Is_Visible_Object -- 3943 ----------------------- 3944 3945 function Is_Visible_Object (Obj_Id : Entity_Id) return Boolean is 3946 begin 3947 -- Objects that map generic formals to their actuals are not visible 3948 -- from outside the generic instantiation. 3949 3950 if Present (Corresponding_Generic_Association 3951 (Declaration_Node (Obj_Id))) 3952 then 3953 return False; 3954 3955 -- Constituents of a single protected/task type act as components of 3956 -- the type and are not visible from outside the type. 3957 3958 elsif Ekind (Obj_Id) = E_Variable 3959 and then Present (Encapsulating_State (Obj_Id)) 3960 and then Is_Single_Concurrent_Object (Encapsulating_State (Obj_Id)) 3961 then 3962 return False; 3963 3964 else 3965 return True; 3966 end if; 3967 end Is_Visible_Object; 3968 3969 -- Local variables 3970 3971 Body_Decl : constant Node_Id := Unit_Declaration_Node (Body_Id); 3972 Decl : Node_Id; 3973 Item_Id : Entity_Id; 3974 States : Elist_Id := No_Elist; 3975 3976 -- Start of processing for Collect_Body_States 3977 3978 begin 3979 -- Inspect the declarations of the body looking for source objects, 3980 -- packages and package instantiations. Note that even though this 3981 -- processing is very similar to Collect_Visible_States, a package 3982 -- body does not have a First/Next_Entity list. 3983 3984 Decl := First (Declarations (Body_Decl)); 3985 while Present (Decl) loop 3986 3987 -- Capture source objects as internally generated temporaries cannot 3988 -- be named and participate in refinement. 3989 3990 if Nkind (Decl) = N_Object_Declaration then 3991 Item_Id := Defining_Entity (Decl); 3992 3993 if Comes_From_Source (Item_Id) 3994 and then Is_Visible_Object (Item_Id) 3995 then 3996 Append_New_Elmt (Item_Id, States); 3997 end if; 3998 3999 -- Capture the visible abstract states and objects of a source 4000 -- package [instantiation]. 4001 4002 elsif Nkind (Decl) = N_Package_Declaration then 4003 Item_Id := Defining_Entity (Decl); 4004 4005 if Comes_From_Source (Item_Id) then 4006 Collect_Visible_States (Item_Id, States); 4007 end if; 4008 end if; 4009 4010 Next (Decl); 4011 end loop; 4012 4013 return States; 4014 end Collect_Body_States; 4015 4016 ------------------------ 4017 -- Collect_Interfaces -- 4018 ------------------------ 4019 4020 procedure Collect_Interfaces 4021 (T : Entity_Id; 4022 Ifaces_List : out Elist_Id; 4023 Exclude_Parents : Boolean := False; 4024 Use_Full_View : Boolean := True) 4025 is 4026 procedure Collect (Typ : Entity_Id); 4027 -- Subsidiary subprogram used to traverse the whole list 4028 -- of directly and indirectly implemented interfaces 4029 4030 ------------- 4031 -- Collect -- 4032 ------------- 4033 4034 procedure Collect (Typ : Entity_Id) is 4035 Ancestor : Entity_Id; 4036 Full_T : Entity_Id; 4037 Id : Node_Id; 4038 Iface : Entity_Id; 4039 4040 begin 4041 Full_T := Typ; 4042 4043 -- Handle private types and subtypes 4044 4045 if Use_Full_View 4046 and then Is_Private_Type (Typ) 4047 and then Present (Full_View (Typ)) 4048 then 4049 Full_T := Full_View (Typ); 4050 4051 if Ekind (Full_T) = E_Record_Subtype then 4052 Full_T := Full_View (Etype (Typ)); 4053 end if; 4054 end if; 4055 4056 -- Include the ancestor if we are generating the whole list of 4057 -- abstract interfaces. 4058 4059 if Etype (Full_T) /= Typ 4060 4061 -- Protect the frontend against wrong sources. For example: 4062 4063 -- package P is 4064 -- type A is tagged null record; 4065 -- type B is new A with private; 4066 -- type C is new A with private; 4067 -- private 4068 -- type B is new C with null record; 4069 -- type C is new B with null record; 4070 -- end P; 4071 4072 and then Etype (Full_T) /= T 4073 then 4074 Ancestor := Etype (Full_T); 4075 Collect (Ancestor); 4076 4077 if Is_Interface (Ancestor) and then not Exclude_Parents then 4078 Append_Unique_Elmt (Ancestor, Ifaces_List); 4079 end if; 4080 end if; 4081 4082 -- Traverse the graph of ancestor interfaces 4083 4084 if Is_Non_Empty_List (Abstract_Interface_List (Full_T)) then 4085 Id := First (Abstract_Interface_List (Full_T)); 4086 while Present (Id) loop 4087 Iface := Etype (Id); 4088 4089 -- Protect against wrong uses. For example: 4090 -- type I is interface; 4091 -- type O is tagged null record; 4092 -- type Wrong is new I and O with null record; -- ERROR 4093 4094 if Is_Interface (Iface) then 4095 if Exclude_Parents 4096 and then Etype (T) /= T 4097 and then Interface_Present_In_Ancestor (Etype (T), Iface) 4098 then 4099 null; 4100 else 4101 Collect (Iface); 4102 Append_Unique_Elmt (Iface, Ifaces_List); 4103 end if; 4104 end if; 4105 4106 Next (Id); 4107 end loop; 4108 end if; 4109 end Collect; 4110 4111 -- Start of processing for Collect_Interfaces 4112 4113 begin 4114 pragma Assert (Is_Tagged_Type (T) or else Is_Concurrent_Type (T)); 4115 Ifaces_List := New_Elmt_List; 4116 Collect (T); 4117 end Collect_Interfaces; 4118 4119 ---------------------------------- 4120 -- Collect_Interface_Components -- 4121 ---------------------------------- 4122 4123 procedure Collect_Interface_Components 4124 (Tagged_Type : Entity_Id; 4125 Components_List : out Elist_Id) 4126 is 4127 procedure Collect (Typ : Entity_Id); 4128 -- Subsidiary subprogram used to climb to the parents 4129 4130 ------------- 4131 -- Collect -- 4132 ------------- 4133 4134 procedure Collect (Typ : Entity_Id) is 4135 Tag_Comp : Entity_Id; 4136 Parent_Typ : Entity_Id; 4137 4138 begin 4139 -- Handle private types 4140 4141 if Present (Full_View (Etype (Typ))) then 4142 Parent_Typ := Full_View (Etype (Typ)); 4143 else 4144 Parent_Typ := Etype (Typ); 4145 end if; 4146 4147 if Parent_Typ /= Typ 4148 4149 -- Protect the frontend against wrong sources. For example: 4150 4151 -- package P is 4152 -- type A is tagged null record; 4153 -- type B is new A with private; 4154 -- type C is new A with private; 4155 -- private 4156 -- type B is new C with null record; 4157 -- type C is new B with null record; 4158 -- end P; 4159 4160 and then Parent_Typ /= Tagged_Type 4161 then 4162 Collect (Parent_Typ); 4163 end if; 4164 4165 -- Collect the components containing tags of secondary dispatch 4166 -- tables. 4167 4168 Tag_Comp := Next_Tag_Component (First_Tag_Component (Typ)); 4169 while Present (Tag_Comp) loop 4170 pragma Assert (Present (Related_Type (Tag_Comp))); 4171 Append_Elmt (Tag_Comp, Components_List); 4172 4173 Tag_Comp := Next_Tag_Component (Tag_Comp); 4174 end loop; 4175 end Collect; 4176 4177 -- Start of processing for Collect_Interface_Components 4178 4179 begin 4180 pragma Assert (Ekind (Tagged_Type) = E_Record_Type 4181 and then Is_Tagged_Type (Tagged_Type)); 4182 4183 Components_List := New_Elmt_List; 4184 Collect (Tagged_Type); 4185 end Collect_Interface_Components; 4186 4187 ----------------------------- 4188 -- Collect_Interfaces_Info -- 4189 ----------------------------- 4190 4191 procedure Collect_Interfaces_Info 4192 (T : Entity_Id; 4193 Ifaces_List : out Elist_Id; 4194 Components_List : out Elist_Id; 4195 Tags_List : out Elist_Id) 4196 is 4197 Comps_List : Elist_Id; 4198 Comp_Elmt : Elmt_Id; 4199 Comp_Iface : Entity_Id; 4200 Iface_Elmt : Elmt_Id; 4201 Iface : Entity_Id; 4202 4203 function Search_Tag (Iface : Entity_Id) return Entity_Id; 4204 -- Search for the secondary tag associated with the interface type 4205 -- Iface that is implemented by T. 4206 4207 ---------------- 4208 -- Search_Tag -- 4209 ---------------- 4210 4211 function Search_Tag (Iface : Entity_Id) return Entity_Id is 4212 ADT : Elmt_Id; 4213 begin 4214 if not Is_CPP_Class (T) then 4215 ADT := Next_Elmt (Next_Elmt (First_Elmt (Access_Disp_Table (T)))); 4216 else 4217 ADT := Next_Elmt (First_Elmt (Access_Disp_Table (T))); 4218 end if; 4219 4220 while Present (ADT) 4221 and then Is_Tag (Node (ADT)) 4222 and then Related_Type (Node (ADT)) /= Iface 4223 loop 4224 -- Skip secondary dispatch table referencing thunks to user 4225 -- defined primitives covered by this interface. 4226 4227 pragma Assert (Has_Suffix (Node (ADT), 'P')); 4228 Next_Elmt (ADT); 4229 4230 -- Skip secondary dispatch tables of Ada types 4231 4232 if not Is_CPP_Class (T) then 4233 4234 -- Skip secondary dispatch table referencing thunks to 4235 -- predefined primitives. 4236 4237 pragma Assert (Has_Suffix (Node (ADT), 'Y')); 4238 Next_Elmt (ADT); 4239 4240 -- Skip secondary dispatch table referencing user-defined 4241 -- primitives covered by this interface. 4242 4243 pragma Assert (Has_Suffix (Node (ADT), 'D')); 4244 Next_Elmt (ADT); 4245 4246 -- Skip secondary dispatch table referencing predefined 4247 -- primitives. 4248 4249 pragma Assert (Has_Suffix (Node (ADT), 'Z')); 4250 Next_Elmt (ADT); 4251 end if; 4252 end loop; 4253 4254 pragma Assert (Is_Tag (Node (ADT))); 4255 return Node (ADT); 4256 end Search_Tag; 4257 4258 -- Start of processing for Collect_Interfaces_Info 4259 4260 begin 4261 Collect_Interfaces (T, Ifaces_List); 4262 Collect_Interface_Components (T, Comps_List); 4263 4264 -- Search for the record component and tag associated with each 4265 -- interface type of T. 4266 4267 Components_List := New_Elmt_List; 4268 Tags_List := New_Elmt_List; 4269 4270 Iface_Elmt := First_Elmt (Ifaces_List); 4271 while Present (Iface_Elmt) loop 4272 Iface := Node (Iface_Elmt); 4273 4274 -- Associate the primary tag component and the primary dispatch table 4275 -- with all the interfaces that are parents of T 4276 4277 if Is_Ancestor (Iface, T, Use_Full_View => True) then 4278 Append_Elmt (First_Tag_Component (T), Components_List); 4279 Append_Elmt (Node (First_Elmt (Access_Disp_Table (T))), Tags_List); 4280 4281 -- Otherwise search for the tag component and secondary dispatch 4282 -- table of Iface 4283 4284 else 4285 Comp_Elmt := First_Elmt (Comps_List); 4286 while Present (Comp_Elmt) loop 4287 Comp_Iface := Related_Type (Node (Comp_Elmt)); 4288 4289 if Comp_Iface = Iface 4290 or else Is_Ancestor (Iface, Comp_Iface, Use_Full_View => True) 4291 then 4292 Append_Elmt (Node (Comp_Elmt), Components_List); 4293 Append_Elmt (Search_Tag (Comp_Iface), Tags_List); 4294 exit; 4295 end if; 4296 4297 Next_Elmt (Comp_Elmt); 4298 end loop; 4299 pragma Assert (Present (Comp_Elmt)); 4300 end if; 4301 4302 Next_Elmt (Iface_Elmt); 4303 end loop; 4304 end Collect_Interfaces_Info; 4305 4306 --------------------- 4307 -- Collect_Parents -- 4308 --------------------- 4309 4310 procedure Collect_Parents 4311 (T : Entity_Id; 4312 List : out Elist_Id; 4313 Use_Full_View : Boolean := True) 4314 is 4315 Current_Typ : Entity_Id := T; 4316 Parent_Typ : Entity_Id; 4317 4318 begin 4319 List := New_Elmt_List; 4320 4321 -- No action if the if the type has no parents 4322 4323 if T = Etype (T) then 4324 return; 4325 end if; 4326 4327 loop 4328 Parent_Typ := Etype (Current_Typ); 4329 4330 if Is_Private_Type (Parent_Typ) 4331 and then Present (Full_View (Parent_Typ)) 4332 and then Use_Full_View 4333 then 4334 Parent_Typ := Full_View (Base_Type (Parent_Typ)); 4335 end if; 4336 4337 Append_Elmt (Parent_Typ, List); 4338 4339 exit when Parent_Typ = Current_Typ; 4340 Current_Typ := Parent_Typ; 4341 end loop; 4342 end Collect_Parents; 4343 4344 ---------------------------------- 4345 -- Collect_Primitive_Operations -- 4346 ---------------------------------- 4347 4348 function Collect_Primitive_Operations (T : Entity_Id) return Elist_Id is 4349 B_Type : constant Entity_Id := Base_Type (T); 4350 B_Decl : constant Node_Id := Original_Node (Parent (B_Type)); 4351 B_Scope : Entity_Id := Scope (B_Type); 4352 Op_List : Elist_Id; 4353 Formal : Entity_Id; 4354 Is_Prim : Boolean; 4355 Is_Type_In_Pkg : Boolean; 4356 Formal_Derived : Boolean := False; 4357 Id : Entity_Id; 4358 4359 function Match (E : Entity_Id) return Boolean; 4360 -- True if E's base type is B_Type, or E is of an anonymous access type 4361 -- and the base type of its designated type is B_Type. 4362 4363 ----------- 4364 -- Match -- 4365 ----------- 4366 4367 function Match (E : Entity_Id) return Boolean is 4368 Etyp : Entity_Id := Etype (E); 4369 4370 begin 4371 if Ekind (Etyp) = E_Anonymous_Access_Type then 4372 Etyp := Designated_Type (Etyp); 4373 end if; 4374 4375 -- In Ada 2012 a primitive operation may have a formal of an 4376 -- incomplete view of the parent type. 4377 4378 return Base_Type (Etyp) = B_Type 4379 or else 4380 (Ada_Version >= Ada_2012 4381 and then Ekind (Etyp) = E_Incomplete_Type 4382 and then Full_View (Etyp) = B_Type); 4383 end Match; 4384 4385 -- Start of processing for Collect_Primitive_Operations 4386 4387 begin 4388 -- For tagged types, the primitive operations are collected as they 4389 -- are declared, and held in an explicit list which is simply returned. 4390 4391 if Is_Tagged_Type (B_Type) then 4392 return Primitive_Operations (B_Type); 4393 4394 -- An untagged generic type that is a derived type inherits the 4395 -- primitive operations of its parent type. Other formal types only 4396 -- have predefined operators, which are not explicitly represented. 4397 4398 elsif Is_Generic_Type (B_Type) then 4399 if Nkind (B_Decl) = N_Formal_Type_Declaration 4400 and then Nkind (Formal_Type_Definition (B_Decl)) = 4401 N_Formal_Derived_Type_Definition 4402 then 4403 Formal_Derived := True; 4404 else 4405 return New_Elmt_List; 4406 end if; 4407 end if; 4408 4409 Op_List := New_Elmt_List; 4410 4411 if B_Scope = Standard_Standard then 4412 if B_Type = Standard_String then 4413 Append_Elmt (Standard_Op_Concat, Op_List); 4414 4415 elsif B_Type = Standard_Wide_String then 4416 Append_Elmt (Standard_Op_Concatw, Op_List); 4417 4418 else 4419 null; 4420 end if; 4421 4422 -- Locate the primitive subprograms of the type 4423 4424 else 4425 -- The primitive operations appear after the base type, except 4426 -- if the derivation happens within the private part of B_Scope 4427 -- and the type is a private type, in which case both the type 4428 -- and some primitive operations may appear before the base 4429 -- type, and the list of candidates starts after the type. 4430 4431 if In_Open_Scopes (B_Scope) 4432 and then Scope (T) = B_Scope 4433 and then In_Private_Part (B_Scope) 4434 then 4435 Id := Next_Entity (T); 4436 4437 -- In Ada 2012, If the type has an incomplete partial view, there 4438 -- may be primitive operations declared before the full view, so 4439 -- we need to start scanning from the incomplete view, which is 4440 -- earlier on the entity chain. 4441 4442 elsif Nkind (Parent (B_Type)) = N_Full_Type_Declaration 4443 and then Present (Incomplete_View (Parent (B_Type))) 4444 then 4445 Id := Defining_Entity (Incomplete_View (Parent (B_Type))); 4446 4447 -- If T is a derived from a type with an incomplete view declared 4448 -- elsewhere, that incomplete view is irrelevant, we want the 4449 -- operations in the scope of T. 4450 4451 if Scope (Id) /= Scope (B_Type) then 4452 Id := Next_Entity (B_Type); 4453 end if; 4454 4455 else 4456 Id := Next_Entity (B_Type); 4457 end if; 4458 4459 -- Set flag if this is a type in a package spec 4460 4461 Is_Type_In_Pkg := 4462 Is_Package_Or_Generic_Package (B_Scope) 4463 and then 4464 Nkind (Parent (Declaration_Node (First_Subtype (T)))) /= 4465 N_Package_Body; 4466 4467 while Present (Id) loop 4468 4469 -- Test whether the result type or any of the parameter types of 4470 -- each subprogram following the type match that type when the 4471 -- type is declared in a package spec, is a derived type, or the 4472 -- subprogram is marked as primitive. (The Is_Primitive test is 4473 -- needed to find primitives of nonderived types in declarative 4474 -- parts that happen to override the predefined "=" operator.) 4475 4476 -- Note that generic formal subprograms are not considered to be 4477 -- primitive operations and thus are never inherited. 4478 4479 if Is_Overloadable (Id) 4480 and then (Is_Type_In_Pkg 4481 or else Is_Derived_Type (B_Type) 4482 or else Is_Primitive (Id)) 4483 and then Nkind (Parent (Parent (Id))) 4484 not in N_Formal_Subprogram_Declaration 4485 then 4486 Is_Prim := False; 4487 4488 if Match (Id) then 4489 Is_Prim := True; 4490 4491 else 4492 Formal := First_Formal (Id); 4493 while Present (Formal) loop 4494 if Match (Formal) then 4495 Is_Prim := True; 4496 exit; 4497 end if; 4498 4499 Next_Formal (Formal); 4500 end loop; 4501 end if; 4502 4503 -- For a formal derived type, the only primitives are the ones 4504 -- inherited from the parent type. Operations appearing in the 4505 -- package declaration are not primitive for it. 4506 4507 if Is_Prim 4508 and then (not Formal_Derived or else Present (Alias (Id))) 4509 then 4510 -- In the special case of an equality operator aliased to 4511 -- an overriding dispatching equality belonging to the same 4512 -- type, we don't include it in the list of primitives. 4513 -- This avoids inheriting multiple equality operators when 4514 -- deriving from untagged private types whose full type is 4515 -- tagged, which can otherwise cause ambiguities. Note that 4516 -- this should only happen for this kind of untagged parent 4517 -- type, since normally dispatching operations are inherited 4518 -- using the type's Primitive_Operations list. 4519 4520 if Chars (Id) = Name_Op_Eq 4521 and then Is_Dispatching_Operation (Id) 4522 and then Present (Alias (Id)) 4523 and then Present (Overridden_Operation (Alias (Id))) 4524 and then Base_Type (Etype (First_Entity (Id))) = 4525 Base_Type (Etype (First_Entity (Alias (Id)))) 4526 then 4527 null; 4528 4529 -- Include the subprogram in the list of primitives 4530 4531 else 4532 Append_Elmt (Id, Op_List); 4533 end if; 4534 end if; 4535 end if; 4536 4537 Next_Entity (Id); 4538 4539 -- For a type declared in System, some of its operations may 4540 -- appear in the target-specific extension to System. 4541 4542 if No (Id) 4543 and then B_Scope = RTU_Entity (System) 4544 and then Present_System_Aux 4545 then 4546 B_Scope := System_Aux_Id; 4547 Id := First_Entity (System_Aux_Id); 4548 end if; 4549 end loop; 4550 end if; 4551 4552 return Op_List; 4553 end Collect_Primitive_Operations; 4554 4555 ----------------------------------- 4556 -- Compile_Time_Constraint_Error -- 4557 ----------------------------------- 4558 4559 function Compile_Time_Constraint_Error 4560 (N : Node_Id; 4561 Msg : String; 4562 Ent : Entity_Id := Empty; 4563 Loc : Source_Ptr := No_Location; 4564 Warn : Boolean := False) return Node_Id 4565 is 4566 Msgc : String (1 .. Msg'Length + 3); 4567 -- Copy of message, with room for possible ?? or << and ! at end 4568 4569 Msgl : Natural; 4570 Wmsg : Boolean; 4571 Eloc : Source_Ptr; 4572 4573 -- Start of processing for Compile_Time_Constraint_Error 4574 4575 begin 4576 -- If this is a warning, convert it into an error if we are in code 4577 -- subject to SPARK_Mode being set ON. 4578 4579 Error_Msg_Warn := SPARK_Mode /= On; 4580 4581 -- A static constraint error in an instance body is not a fatal error. 4582 -- we choose to inhibit the message altogether, because there is no 4583 -- obvious node (for now) on which to post it. On the other hand the 4584 -- offending node must be replaced with a constraint_error in any case. 4585 4586 -- No messages are generated if we already posted an error on this node 4587 4588 if not Error_Posted (N) then 4589 if Loc /= No_Location then 4590 Eloc := Loc; 4591 else 4592 Eloc := Sloc (N); 4593 end if; 4594 4595 -- Copy message to Msgc, converting any ? in the message into 4596 -- < instead, so that we have an error in GNATprove mode. 4597 4598 Msgl := Msg'Length; 4599 4600 for J in 1 .. Msgl loop 4601 if Msg (J) = '?' and then (J = 1 or else Msg (J) /= ''') then 4602 Msgc (J) := '<'; 4603 else 4604 Msgc (J) := Msg (J); 4605 end if; 4606 end loop; 4607 4608 -- Message is a warning, even in Ada 95 case 4609 4610 if Msg (Msg'Last) = '?' or else Msg (Msg'Last) = '<' then 4611 Wmsg := True; 4612 4613 -- In Ada 83, all messages are warnings. In the private part and 4614 -- the body of an instance, constraint_checks are only warnings. 4615 -- We also make this a warning if the Warn parameter is set. 4616 4617 elsif Warn 4618 or else (Ada_Version = Ada_83 and then Comes_From_Source (N)) 4619 then 4620 Msgl := Msgl + 1; 4621 Msgc (Msgl) := '<'; 4622 Msgl := Msgl + 1; 4623 Msgc (Msgl) := '<'; 4624 Wmsg := True; 4625 4626 elsif In_Instance_Not_Visible then 4627 Msgl := Msgl + 1; 4628 Msgc (Msgl) := '<'; 4629 Msgl := Msgl + 1; 4630 Msgc (Msgl) := '<'; 4631 Wmsg := True; 4632 4633 -- Otherwise we have a real error message (Ada 95 static case) 4634 -- and we make this an unconditional message. Note that in the 4635 -- warning case we do not make the message unconditional, it seems 4636 -- quite reasonable to delete messages like this (about exceptions 4637 -- that will be raised) in dead code. 4638 4639 else 4640 Wmsg := False; 4641 Msgl := Msgl + 1; 4642 Msgc (Msgl) := '!'; 4643 end if; 4644 4645 -- One more test, skip the warning if the related expression is 4646 -- statically unevaluated, since we don't want to warn about what 4647 -- will happen when something is evaluated if it never will be 4648 -- evaluated. 4649 4650 if not Is_Statically_Unevaluated (N) then 4651 Error_Msg_Warn := SPARK_Mode /= On; 4652 4653 if Present (Ent) then 4654 Error_Msg_NEL (Msgc (1 .. Msgl), N, Ent, Eloc); 4655 else 4656 Error_Msg_NEL (Msgc (1 .. Msgl), N, Etype (N), Eloc); 4657 end if; 4658 4659 if Wmsg then 4660 4661 -- Check whether the context is an Init_Proc 4662 4663 if Inside_Init_Proc then 4664 declare 4665 Conc_Typ : constant Entity_Id := 4666 Corresponding_Concurrent_Type 4667 (Entity (Parameter_Type (First 4668 (Parameter_Specifications 4669 (Parent (Current_Scope)))))); 4670 4671 begin 4672 -- Don't complain if the corresponding concurrent type 4673 -- doesn't come from source (i.e. a single task/protected 4674 -- object). 4675 4676 if Present (Conc_Typ) 4677 and then not Comes_From_Source (Conc_Typ) 4678 then 4679 Error_Msg_NEL 4680 ("\& [<<", N, Standard_Constraint_Error, Eloc); 4681 4682 else 4683 if GNATprove_Mode then 4684 Error_Msg_NEL 4685 ("\& would have been raised for objects of this " 4686 & "type", N, Standard_Constraint_Error, Eloc); 4687 else 4688 Error_Msg_NEL 4689 ("\& will be raised for objects of this type??", 4690 N, Standard_Constraint_Error, Eloc); 4691 end if; 4692 end if; 4693 end; 4694 4695 else 4696 Error_Msg_NEL ("\& [<<", N, Standard_Constraint_Error, Eloc); 4697 end if; 4698 4699 else 4700 Error_Msg ("\static expression fails Constraint_Check", Eloc); 4701 Set_Error_Posted (N); 4702 end if; 4703 end if; 4704 end if; 4705 4706 return N; 4707 end Compile_Time_Constraint_Error; 4708 4709 ----------------------- 4710 -- Conditional_Delay -- 4711 ----------------------- 4712 4713 procedure Conditional_Delay (New_Ent, Old_Ent : Entity_Id) is 4714 begin 4715 if Has_Delayed_Freeze (Old_Ent) and then not Is_Frozen (Old_Ent) then 4716 Set_Has_Delayed_Freeze (New_Ent); 4717 end if; 4718 end Conditional_Delay; 4719 4720 ---------------------------- 4721 -- Contains_Refined_State -- 4722 ---------------------------- 4723 4724 function Contains_Refined_State (Prag : Node_Id) return Boolean is 4725 function Has_State_In_Dependency (List : Node_Id) return Boolean; 4726 -- Determine whether a dependency list mentions a state with a visible 4727 -- refinement. 4728 4729 function Has_State_In_Global (List : Node_Id) return Boolean; 4730 -- Determine whether a global list mentions a state with a visible 4731 -- refinement. 4732 4733 function Is_Refined_State (Item : Node_Id) return Boolean; 4734 -- Determine whether Item is a reference to an abstract state with a 4735 -- visible refinement. 4736 4737 ----------------------------- 4738 -- Has_State_In_Dependency -- 4739 ----------------------------- 4740 4741 function Has_State_In_Dependency (List : Node_Id) return Boolean is 4742 Clause : Node_Id; 4743 Output : Node_Id; 4744 4745 begin 4746 -- A null dependency list does not mention any states 4747 4748 if Nkind (List) = N_Null then 4749 return False; 4750 4751 -- Dependency clauses appear as component associations of an 4752 -- aggregate. 4753 4754 elsif Nkind (List) = N_Aggregate 4755 and then Present (Component_Associations (List)) 4756 then 4757 Clause := First (Component_Associations (List)); 4758 while Present (Clause) loop 4759 4760 -- Inspect the outputs of a dependency clause 4761 4762 Output := First (Choices (Clause)); 4763 while Present (Output) loop 4764 if Is_Refined_State (Output) then 4765 return True; 4766 end if; 4767 4768 Next (Output); 4769 end loop; 4770 4771 -- Inspect the outputs of a dependency clause 4772 4773 if Is_Refined_State (Expression (Clause)) then 4774 return True; 4775 end if; 4776 4777 Next (Clause); 4778 end loop; 4779 4780 -- If we get here, then none of the dependency clauses mention a 4781 -- state with visible refinement. 4782 4783 return False; 4784 4785 -- An illegal pragma managed to sneak in 4786 4787 else 4788 raise Program_Error; 4789 end if; 4790 end Has_State_In_Dependency; 4791 4792 ------------------------- 4793 -- Has_State_In_Global -- 4794 ------------------------- 4795 4796 function Has_State_In_Global (List : Node_Id) return Boolean is 4797 Item : Node_Id; 4798 4799 begin 4800 -- A null global list does not mention any states 4801 4802 if Nkind (List) = N_Null then 4803 return False; 4804 4805 -- Simple global list or moded global list declaration 4806 4807 elsif Nkind (List) = N_Aggregate then 4808 4809 -- The declaration of a simple global list appear as a collection 4810 -- of expressions. 4811 4812 if Present (Expressions (List)) then 4813 Item := First (Expressions (List)); 4814 while Present (Item) loop 4815 if Is_Refined_State (Item) then 4816 return True; 4817 end if; 4818 4819 Next (Item); 4820 end loop; 4821 4822 -- The declaration of a moded global list appears as a collection 4823 -- of component associations where individual choices denote 4824 -- modes. 4825 4826 else 4827 Item := First (Component_Associations (List)); 4828 while Present (Item) loop 4829 if Has_State_In_Global (Expression (Item)) then 4830 return True; 4831 end if; 4832 4833 Next (Item); 4834 end loop; 4835 end if; 4836 4837 -- If we get here, then the simple/moded global list did not 4838 -- mention any states with a visible refinement. 4839 4840 return False; 4841 4842 -- Single global item declaration 4843 4844 elsif Is_Entity_Name (List) then 4845 return Is_Refined_State (List); 4846 4847 -- An illegal pragma managed to sneak in 4848 4849 else 4850 raise Program_Error; 4851 end if; 4852 end Has_State_In_Global; 4853 4854 ---------------------- 4855 -- Is_Refined_State -- 4856 ---------------------- 4857 4858 function Is_Refined_State (Item : Node_Id) return Boolean is 4859 Elmt : Node_Id; 4860 Item_Id : Entity_Id; 4861 4862 begin 4863 if Nkind (Item) = N_Null then 4864 return False; 4865 4866 -- States cannot be subject to attribute 'Result. This case arises 4867 -- in dependency relations. 4868 4869 elsif Nkind (Item) = N_Attribute_Reference 4870 and then Attribute_Name (Item) = Name_Result 4871 then 4872 return False; 4873 4874 -- Multiple items appear as an aggregate. This case arises in 4875 -- dependency relations. 4876 4877 elsif Nkind (Item) = N_Aggregate 4878 and then Present (Expressions (Item)) 4879 then 4880 Elmt := First (Expressions (Item)); 4881 while Present (Elmt) loop 4882 if Is_Refined_State (Elmt) then 4883 return True; 4884 end if; 4885 4886 Next (Elmt); 4887 end loop; 4888 4889 -- If we get here, then none of the inputs or outputs reference a 4890 -- state with visible refinement. 4891 4892 return False; 4893 4894 -- Single item 4895 4896 else 4897 Item_Id := Entity_Of (Item); 4898 4899 return 4900 Present (Item_Id) 4901 and then Ekind (Item_Id) = E_Abstract_State 4902 and then Has_Visible_Refinement (Item_Id); 4903 end if; 4904 end Is_Refined_State; 4905 4906 -- Local variables 4907 4908 Arg : constant Node_Id := 4909 Get_Pragma_Arg (First (Pragma_Argument_Associations (Prag))); 4910 Nam : constant Name_Id := Pragma_Name (Prag); 4911 4912 -- Start of processing for Contains_Refined_State 4913 4914 begin 4915 if Nam = Name_Depends then 4916 return Has_State_In_Dependency (Arg); 4917 4918 else pragma Assert (Nam = Name_Global); 4919 return Has_State_In_Global (Arg); 4920 end if; 4921 end Contains_Refined_State; 4922 4923 ------------------------- 4924 -- Copy_Component_List -- 4925 ------------------------- 4926 4927 function Copy_Component_List 4928 (R_Typ : Entity_Id; 4929 Loc : Source_Ptr) return List_Id 4930 is 4931 Comp : Node_Id; 4932 Comps : constant List_Id := New_List; 4933 4934 begin 4935 Comp := First_Component (Underlying_Type (R_Typ)); 4936 while Present (Comp) loop 4937 if Comes_From_Source (Comp) then 4938 declare 4939 Comp_Decl : constant Node_Id := Declaration_Node (Comp); 4940 begin 4941 Append_To (Comps, 4942 Make_Component_Declaration (Loc, 4943 Defining_Identifier => 4944 Make_Defining_Identifier (Loc, Chars (Comp)), 4945 Component_Definition => 4946 New_Copy_Tree 4947 (Component_Definition (Comp_Decl), New_Sloc => Loc))); 4948 end; 4949 end if; 4950 4951 Next_Component (Comp); 4952 end loop; 4953 4954 return Comps; 4955 end Copy_Component_List; 4956 4957 ------------------------- 4958 -- Copy_Parameter_List -- 4959 ------------------------- 4960 4961 function Copy_Parameter_List (Subp_Id : Entity_Id) return List_Id is 4962 Loc : constant Source_Ptr := Sloc (Subp_Id); 4963 Plist : List_Id; 4964 Formal : Entity_Id; 4965 4966 begin 4967 if No (First_Formal (Subp_Id)) then 4968 return No_List; 4969 else 4970 Plist := New_List; 4971 Formal := First_Formal (Subp_Id); 4972 while Present (Formal) loop 4973 Append_To (Plist, 4974 Make_Parameter_Specification (Loc, 4975 Defining_Identifier => 4976 Make_Defining_Identifier (Sloc (Formal), Chars (Formal)), 4977 In_Present => In_Present (Parent (Formal)), 4978 Out_Present => Out_Present (Parent (Formal)), 4979 Parameter_Type => 4980 New_Occurrence_Of (Etype (Formal), Loc), 4981 Expression => 4982 New_Copy_Tree (Expression (Parent (Formal))))); 4983 4984 Next_Formal (Formal); 4985 end loop; 4986 end if; 4987 4988 return Plist; 4989 end Copy_Parameter_List; 4990 4991 -------------------------- 4992 -- Copy_Subprogram_Spec -- 4993 -------------------------- 4994 4995 function Copy_Subprogram_Spec (Spec : Node_Id) return Node_Id is 4996 Def_Id : Node_Id; 4997 Formal_Spec : Node_Id; 4998 Result : Node_Id; 4999 5000 begin 5001 -- The structure of the original tree must be replicated without any 5002 -- alterations. Use New_Copy_Tree for this purpose. 5003 5004 Result := New_Copy_Tree (Spec); 5005 5006 -- Create a new entity for the defining unit name 5007 5008 Def_Id := Defining_Unit_Name (Result); 5009 Set_Defining_Unit_Name (Result, 5010 Make_Defining_Identifier (Sloc (Def_Id), Chars (Def_Id))); 5011 5012 -- Create new entities for the formal parameters 5013 5014 if Present (Parameter_Specifications (Result)) then 5015 Formal_Spec := First (Parameter_Specifications (Result)); 5016 while Present (Formal_Spec) loop 5017 Def_Id := Defining_Identifier (Formal_Spec); 5018 Set_Defining_Identifier (Formal_Spec, 5019 Make_Defining_Identifier (Sloc (Def_Id), Chars (Def_Id))); 5020 5021 Next (Formal_Spec); 5022 end loop; 5023 end if; 5024 5025 return Result; 5026 end Copy_Subprogram_Spec; 5027 5028 -------------------------------- 5029 -- Corresponding_Generic_Type -- 5030 -------------------------------- 5031 5032 function Corresponding_Generic_Type (T : Entity_Id) return Entity_Id is 5033 Inst : Entity_Id; 5034 Gen : Entity_Id; 5035 Typ : Entity_Id; 5036 5037 begin 5038 if not Is_Generic_Actual_Type (T) then 5039 return Any_Type; 5040 5041 -- If the actual is the actual of an enclosing instance, resolution 5042 -- was correct in the generic. 5043 5044 elsif Nkind (Parent (T)) = N_Subtype_Declaration 5045 and then Is_Entity_Name (Subtype_Indication (Parent (T))) 5046 and then 5047 Is_Generic_Actual_Type (Entity (Subtype_Indication (Parent (T)))) 5048 then 5049 return Any_Type; 5050 5051 else 5052 Inst := Scope (T); 5053 5054 if Is_Wrapper_Package (Inst) then 5055 Inst := Related_Instance (Inst); 5056 end if; 5057 5058 Gen := 5059 Generic_Parent 5060 (Specification (Unit_Declaration_Node (Inst))); 5061 5062 -- Generic actual has the same name as the corresponding formal 5063 5064 Typ := First_Entity (Gen); 5065 while Present (Typ) loop 5066 if Chars (Typ) = Chars (T) then 5067 return Typ; 5068 end if; 5069 5070 Next_Entity (Typ); 5071 end loop; 5072 5073 return Any_Type; 5074 end if; 5075 end Corresponding_Generic_Type; 5076 5077 -------------------- 5078 -- Current_Entity -- 5079 -------------------- 5080 5081 -- The currently visible definition for a given identifier is the 5082 -- one most chained at the start of the visibility chain, i.e. the 5083 -- one that is referenced by the Node_Id value of the name of the 5084 -- given identifier. 5085 5086 function Current_Entity (N : Node_Id) return Entity_Id is 5087 begin 5088 return Get_Name_Entity_Id (Chars (N)); 5089 end Current_Entity; 5090 5091 ----------------------------- 5092 -- Current_Entity_In_Scope -- 5093 ----------------------------- 5094 5095 function Current_Entity_In_Scope (N : Node_Id) return Entity_Id is 5096 E : Entity_Id; 5097 CS : constant Entity_Id := Current_Scope; 5098 5099 Transient_Case : constant Boolean := Scope_Is_Transient; 5100 5101 begin 5102 E := Get_Name_Entity_Id (Chars (N)); 5103 while Present (E) 5104 and then Scope (E) /= CS 5105 and then (not Transient_Case or else Scope (E) /= Scope (CS)) 5106 loop 5107 E := Homonym (E); 5108 end loop; 5109 5110 return E; 5111 end Current_Entity_In_Scope; 5112 5113 ------------------- 5114 -- Current_Scope -- 5115 ------------------- 5116 5117 function Current_Scope return Entity_Id is 5118 begin 5119 if Scope_Stack.Last = -1 then 5120 return Standard_Standard; 5121 else 5122 declare 5123 C : constant Entity_Id := 5124 Scope_Stack.Table (Scope_Stack.Last).Entity; 5125 begin 5126 if Present (C) then 5127 return C; 5128 else 5129 return Standard_Standard; 5130 end if; 5131 end; 5132 end if; 5133 end Current_Scope; 5134 5135 ------------------------ 5136 -- Current_Subprogram -- 5137 ------------------------ 5138 5139 function Current_Subprogram return Entity_Id is 5140 Scop : constant Entity_Id := Current_Scope; 5141 begin 5142 if Is_Subprogram_Or_Generic_Subprogram (Scop) then 5143 return Scop; 5144 else 5145 return Enclosing_Subprogram (Scop); 5146 end if; 5147 end Current_Subprogram; 5148 5149 ---------------------------------- 5150 -- Deepest_Type_Access_Level -- 5151 ---------------------------------- 5152 5153 function Deepest_Type_Access_Level (Typ : Entity_Id) return Uint is 5154 begin 5155 if Ekind (Typ) = E_Anonymous_Access_Type 5156 and then not Is_Local_Anonymous_Access (Typ) 5157 and then Nkind (Associated_Node_For_Itype (Typ)) = N_Object_Declaration 5158 then 5159 -- Typ is the type of an Ada 2012 stand-alone object of an anonymous 5160 -- access type. 5161 5162 return 5163 Scope_Depth (Enclosing_Dynamic_Scope 5164 (Defining_Identifier 5165 (Associated_Node_For_Itype (Typ)))); 5166 5167 -- For generic formal type, return Int'Last (infinite). 5168 -- See comment preceding Is_Generic_Type call in Type_Access_Level. 5169 5170 elsif Is_Generic_Type (Root_Type (Typ)) then 5171 return UI_From_Int (Int'Last); 5172 5173 else 5174 return Type_Access_Level (Typ); 5175 end if; 5176 end Deepest_Type_Access_Level; 5177 5178 --------------------- 5179 -- Defining_Entity -- 5180 --------------------- 5181 5182 function Defining_Entity 5183 (N : Node_Id; 5184 Empty_On_Errors : Boolean := False) return Entity_Id 5185 is 5186 Err : Entity_Id := Empty; 5187 5188 begin 5189 case Nkind (N) is 5190 when N_Abstract_Subprogram_Declaration | 5191 N_Expression_Function | 5192 N_Formal_Subprogram_Declaration | 5193 N_Generic_Package_Declaration | 5194 N_Generic_Subprogram_Declaration | 5195 N_Package_Declaration | 5196 N_Subprogram_Body | 5197 N_Subprogram_Body_Stub | 5198 N_Subprogram_Declaration | 5199 N_Subprogram_Renaming_Declaration 5200 => 5201 return Defining_Entity (Specification (N)); 5202 5203 when N_Component_Declaration | 5204 N_Defining_Program_Unit_Name | 5205 N_Discriminant_Specification | 5206 N_Entry_Body | 5207 N_Entry_Declaration | 5208 N_Entry_Index_Specification | 5209 N_Exception_Declaration | 5210 N_Exception_Renaming_Declaration | 5211 N_Formal_Object_Declaration | 5212 N_Formal_Package_Declaration | 5213 N_Formal_Type_Declaration | 5214 N_Full_Type_Declaration | 5215 N_Implicit_Label_Declaration | 5216 N_Incomplete_Type_Declaration | 5217 N_Loop_Parameter_Specification | 5218 N_Number_Declaration | 5219 N_Object_Declaration | 5220 N_Object_Renaming_Declaration | 5221 N_Package_Body_Stub | 5222 N_Parameter_Specification | 5223 N_Private_Extension_Declaration | 5224 N_Private_Type_Declaration | 5225 N_Protected_Body | 5226 N_Protected_Body_Stub | 5227 N_Protected_Type_Declaration | 5228 N_Single_Protected_Declaration | 5229 N_Single_Task_Declaration | 5230 N_Subtype_Declaration | 5231 N_Task_Body | 5232 N_Task_Body_Stub | 5233 N_Task_Type_Declaration 5234 => 5235 return Defining_Identifier (N); 5236 5237 when N_Subunit => 5238 return Defining_Entity (Proper_Body (N)); 5239 5240 when N_Function_Instantiation | 5241 N_Function_Specification | 5242 N_Generic_Function_Renaming_Declaration | 5243 N_Generic_Package_Renaming_Declaration | 5244 N_Generic_Procedure_Renaming_Declaration | 5245 N_Package_Body | 5246 N_Package_Instantiation | 5247 N_Package_Renaming_Declaration | 5248 N_Package_Specification | 5249 N_Procedure_Instantiation | 5250 N_Procedure_Specification 5251 => 5252 declare 5253 Nam : constant Node_Id := Defining_Unit_Name (N); 5254 5255 begin 5256 if Nkind (Nam) in N_Entity then 5257 return Nam; 5258 5259 -- For Error, make up a name and attach to declaration so we 5260 -- can continue semantic analysis. 5261 5262 elsif Nam = Error then 5263 if Empty_On_Errors then 5264 return Empty; 5265 else 5266 Err := Make_Temporary (Sloc (N), 'T'); 5267 Set_Defining_Unit_Name (N, Err); 5268 5269 return Err; 5270 end if; 5271 5272 -- If not an entity, get defining identifier 5273 5274 else 5275 return Defining_Identifier (Nam); 5276 end if; 5277 end; 5278 5279 when N_Block_Statement | 5280 N_Loop_Statement => 5281 return Entity (Identifier (N)); 5282 5283 when others => 5284 if Empty_On_Errors then 5285 return Empty; 5286 else 5287 raise Program_Error; 5288 end if; 5289 5290 end case; 5291 end Defining_Entity; 5292 5293 -------------------------- 5294 -- Denotes_Discriminant -- 5295 -------------------------- 5296 5297 function Denotes_Discriminant 5298 (N : Node_Id; 5299 Check_Concurrent : Boolean := False) return Boolean 5300 is 5301 E : Entity_Id; 5302 5303 begin 5304 if not Is_Entity_Name (N) or else No (Entity (N)) then 5305 return False; 5306 else 5307 E := Entity (N); 5308 end if; 5309 5310 -- If we are checking for a protected type, the discriminant may have 5311 -- been rewritten as the corresponding discriminal of the original type 5312 -- or of the corresponding concurrent record, depending on whether we 5313 -- are in the spec or body of the protected type. 5314 5315 return Ekind (E) = E_Discriminant 5316 or else 5317 (Check_Concurrent 5318 and then Ekind (E) = E_In_Parameter 5319 and then Present (Discriminal_Link (E)) 5320 and then 5321 (Is_Concurrent_Type (Scope (Discriminal_Link (E))) 5322 or else 5323 Is_Concurrent_Record_Type (Scope (Discriminal_Link (E))))); 5324 end Denotes_Discriminant; 5325 5326 ------------------------- 5327 -- Denotes_Same_Object -- 5328 ------------------------- 5329 5330 function Denotes_Same_Object (A1, A2 : Node_Id) return Boolean is 5331 Obj1 : Node_Id := A1; 5332 Obj2 : Node_Id := A2; 5333 5334 function Has_Prefix (N : Node_Id) return Boolean; 5335 -- Return True if N has attribute Prefix 5336 5337 function Is_Renaming (N : Node_Id) return Boolean; 5338 -- Return true if N names a renaming entity 5339 5340 function Is_Valid_Renaming (N : Node_Id) return Boolean; 5341 -- For renamings, return False if the prefix of any dereference within 5342 -- the renamed object_name is a variable, or any expression within the 5343 -- renamed object_name contains references to variables or calls on 5344 -- nonstatic functions; otherwise return True (RM 6.4.1(6.10/3)) 5345 5346 ---------------- 5347 -- Has_Prefix -- 5348 ---------------- 5349 5350 function Has_Prefix (N : Node_Id) return Boolean is 5351 begin 5352 return 5353 Nkind_In (N, 5354 N_Attribute_Reference, 5355 N_Expanded_Name, 5356 N_Explicit_Dereference, 5357 N_Indexed_Component, 5358 N_Reference, 5359 N_Selected_Component, 5360 N_Slice); 5361 end Has_Prefix; 5362 5363 ----------------- 5364 -- Is_Renaming -- 5365 ----------------- 5366 5367 function Is_Renaming (N : Node_Id) return Boolean is 5368 begin 5369 return Is_Entity_Name (N) 5370 and then Present (Renamed_Entity (Entity (N))); 5371 end Is_Renaming; 5372 5373 ----------------------- 5374 -- Is_Valid_Renaming -- 5375 ----------------------- 5376 5377 function Is_Valid_Renaming (N : Node_Id) return Boolean is 5378 5379 function Check_Renaming (N : Node_Id) return Boolean; 5380 -- Recursive function used to traverse all the prefixes of N 5381 5382 function Check_Renaming (N : Node_Id) return Boolean is 5383 begin 5384 if Is_Renaming (N) 5385 and then not Check_Renaming (Renamed_Entity (Entity (N))) 5386 then 5387 return False; 5388 end if; 5389 5390 if Nkind (N) = N_Indexed_Component then 5391 declare 5392 Indx : Node_Id; 5393 5394 begin 5395 Indx := First (Expressions (N)); 5396 while Present (Indx) loop 5397 if not Is_OK_Static_Expression (Indx) then 5398 return False; 5399 end if; 5400 5401 Next_Index (Indx); 5402 end loop; 5403 end; 5404 end if; 5405 5406 if Has_Prefix (N) then 5407 declare 5408 P : constant Node_Id := Prefix (N); 5409 5410 begin 5411 if Nkind (N) = N_Explicit_Dereference 5412 and then Is_Variable (P) 5413 then 5414 return False; 5415 5416 elsif Is_Entity_Name (P) 5417 and then Ekind (Entity (P)) = E_Function 5418 then 5419 return False; 5420 5421 elsif Nkind (P) = N_Function_Call then 5422 return False; 5423 end if; 5424 5425 -- Recursion to continue traversing the prefix of the 5426 -- renaming expression 5427 5428 return Check_Renaming (P); 5429 end; 5430 end if; 5431 5432 return True; 5433 end Check_Renaming; 5434 5435 -- Start of processing for Is_Valid_Renaming 5436 5437 begin 5438 return Check_Renaming (N); 5439 end Is_Valid_Renaming; 5440 5441 -- Start of processing for Denotes_Same_Object 5442 5443 begin 5444 -- Both names statically denote the same stand-alone object or parameter 5445 -- (RM 6.4.1(6.5/3)) 5446 5447 if Is_Entity_Name (Obj1) 5448 and then Is_Entity_Name (Obj2) 5449 and then Entity (Obj1) = Entity (Obj2) 5450 then 5451 return True; 5452 end if; 5453 5454 -- For renamings, the prefix of any dereference within the renamed 5455 -- object_name is not a variable, and any expression within the 5456 -- renamed object_name contains no references to variables nor 5457 -- calls on nonstatic functions (RM 6.4.1(6.10/3)). 5458 5459 if Is_Renaming (Obj1) then 5460 if Is_Valid_Renaming (Obj1) then 5461 Obj1 := Renamed_Entity (Entity (Obj1)); 5462 else 5463 return False; 5464 end if; 5465 end if; 5466 5467 if Is_Renaming (Obj2) then 5468 if Is_Valid_Renaming (Obj2) then 5469 Obj2 := Renamed_Entity (Entity (Obj2)); 5470 else 5471 return False; 5472 end if; 5473 end if; 5474 5475 -- No match if not same node kind (such cases are handled by 5476 -- Denotes_Same_Prefix) 5477 5478 if Nkind (Obj1) /= Nkind (Obj2) then 5479 return False; 5480 5481 -- After handling valid renamings, one of the two names statically 5482 -- denoted a renaming declaration whose renamed object_name is known 5483 -- to denote the same object as the other (RM 6.4.1(6.10/3)) 5484 5485 elsif Is_Entity_Name (Obj1) then 5486 if Is_Entity_Name (Obj2) then 5487 return Entity (Obj1) = Entity (Obj2); 5488 else 5489 return False; 5490 end if; 5491 5492 -- Both names are selected_components, their prefixes are known to 5493 -- denote the same object, and their selector_names denote the same 5494 -- component (RM 6.4.1(6.6/3)). 5495 5496 elsif Nkind (Obj1) = N_Selected_Component then 5497 return Denotes_Same_Object (Prefix (Obj1), Prefix (Obj2)) 5498 and then 5499 Entity (Selector_Name (Obj1)) = Entity (Selector_Name (Obj2)); 5500 5501 -- Both names are dereferences and the dereferenced names are known to 5502 -- denote the same object (RM 6.4.1(6.7/3)) 5503 5504 elsif Nkind (Obj1) = N_Explicit_Dereference then 5505 return Denotes_Same_Object (Prefix (Obj1), Prefix (Obj2)); 5506 5507 -- Both names are indexed_components, their prefixes are known to denote 5508 -- the same object, and each of the pairs of corresponding index values 5509 -- are either both static expressions with the same static value or both 5510 -- names that are known to denote the same object (RM 6.4.1(6.8/3)) 5511 5512 elsif Nkind (Obj1) = N_Indexed_Component then 5513 if not Denotes_Same_Object (Prefix (Obj1), Prefix (Obj2)) then 5514 return False; 5515 else 5516 declare 5517 Indx1 : Node_Id; 5518 Indx2 : Node_Id; 5519 5520 begin 5521 Indx1 := First (Expressions (Obj1)); 5522 Indx2 := First (Expressions (Obj2)); 5523 while Present (Indx1) loop 5524 5525 -- Indexes must denote the same static value or same object 5526 5527 if Is_OK_Static_Expression (Indx1) then 5528 if not Is_OK_Static_Expression (Indx2) then 5529 return False; 5530 5531 elsif Expr_Value (Indx1) /= Expr_Value (Indx2) then 5532 return False; 5533 end if; 5534 5535 elsif not Denotes_Same_Object (Indx1, Indx2) then 5536 return False; 5537 end if; 5538 5539 Next (Indx1); 5540 Next (Indx2); 5541 end loop; 5542 5543 return True; 5544 end; 5545 end if; 5546 5547 -- Both names are slices, their prefixes are known to denote the same 5548 -- object, and the two slices have statically matching index constraints 5549 -- (RM 6.4.1(6.9/3)) 5550 5551 elsif Nkind (Obj1) = N_Slice 5552 and then Denotes_Same_Object (Prefix (Obj1), Prefix (Obj2)) 5553 then 5554 declare 5555 Lo1, Lo2, Hi1, Hi2 : Node_Id; 5556 5557 begin 5558 Get_Index_Bounds (Etype (Obj1), Lo1, Hi1); 5559 Get_Index_Bounds (Etype (Obj2), Lo2, Hi2); 5560 5561 -- Check whether bounds are statically identical. There is no 5562 -- attempt to detect partial overlap of slices. 5563 5564 return Denotes_Same_Object (Lo1, Lo2) 5565 and then 5566 Denotes_Same_Object (Hi1, Hi2); 5567 end; 5568 5569 -- In the recursion, literals appear as indexes 5570 5571 elsif Nkind (Obj1) = N_Integer_Literal 5572 and then 5573 Nkind (Obj2) = N_Integer_Literal 5574 then 5575 return Intval (Obj1) = Intval (Obj2); 5576 5577 else 5578 return False; 5579 end if; 5580 end Denotes_Same_Object; 5581 5582 ------------------------- 5583 -- Denotes_Same_Prefix -- 5584 ------------------------- 5585 5586 function Denotes_Same_Prefix (A1, A2 : Node_Id) return Boolean is 5587 begin 5588 if Is_Entity_Name (A1) then 5589 if Nkind_In (A2, N_Selected_Component, N_Indexed_Component) 5590 and then not Is_Access_Type (Etype (A1)) 5591 then 5592 return Denotes_Same_Object (A1, Prefix (A2)) 5593 or else Denotes_Same_Prefix (A1, Prefix (A2)); 5594 else 5595 return False; 5596 end if; 5597 5598 elsif Is_Entity_Name (A2) then 5599 return Denotes_Same_Prefix (A1 => A2, A2 => A1); 5600 5601 elsif Nkind_In (A1, N_Selected_Component, N_Indexed_Component, N_Slice) 5602 and then 5603 Nkind_In (A2, N_Selected_Component, N_Indexed_Component, N_Slice) 5604 then 5605 declare 5606 Root1, Root2 : Node_Id; 5607 Depth1, Depth2 : Int := 0; 5608 5609 begin 5610 Root1 := Prefix (A1); 5611 while not Is_Entity_Name (Root1) loop 5612 if not Nkind_In 5613 (Root1, N_Selected_Component, N_Indexed_Component) 5614 then 5615 return False; 5616 else 5617 Root1 := Prefix (Root1); 5618 end if; 5619 5620 Depth1 := Depth1 + 1; 5621 end loop; 5622 5623 Root2 := Prefix (A2); 5624 while not Is_Entity_Name (Root2) loop 5625 if not Nkind_In (Root2, N_Selected_Component, 5626 N_Indexed_Component) 5627 then 5628 return False; 5629 else 5630 Root2 := Prefix (Root2); 5631 end if; 5632 5633 Depth2 := Depth2 + 1; 5634 end loop; 5635 5636 -- If both have the same depth and they do not denote the same 5637 -- object, they are disjoint and no warning is needed. 5638 5639 if Depth1 = Depth2 then 5640 return False; 5641 5642 elsif Depth1 > Depth2 then 5643 Root1 := Prefix (A1); 5644 for J in 1 .. Depth1 - Depth2 - 1 loop 5645 Root1 := Prefix (Root1); 5646 end loop; 5647 5648 return Denotes_Same_Object (Root1, A2); 5649 5650 else 5651 Root2 := Prefix (A2); 5652 for J in 1 .. Depth2 - Depth1 - 1 loop 5653 Root2 := Prefix (Root2); 5654 end loop; 5655 5656 return Denotes_Same_Object (A1, Root2); 5657 end if; 5658 end; 5659 5660 else 5661 return False; 5662 end if; 5663 end Denotes_Same_Prefix; 5664 5665 ---------------------- 5666 -- Denotes_Variable -- 5667 ---------------------- 5668 5669 function Denotes_Variable (N : Node_Id) return Boolean is 5670 begin 5671 return Is_Variable (N) and then Paren_Count (N) = 0; 5672 end Denotes_Variable; 5673 5674 ----------------------------- 5675 -- Depends_On_Discriminant -- 5676 ----------------------------- 5677 5678 function Depends_On_Discriminant (N : Node_Id) return Boolean is 5679 L : Node_Id; 5680 H : Node_Id; 5681 5682 begin 5683 Get_Index_Bounds (N, L, H); 5684 return Denotes_Discriminant (L) or else Denotes_Discriminant (H); 5685 end Depends_On_Discriminant; 5686 5687 ------------------------- 5688 -- Designate_Same_Unit -- 5689 ------------------------- 5690 5691 function Designate_Same_Unit 5692 (Name1 : Node_Id; 5693 Name2 : Node_Id) return Boolean 5694 is 5695 K1 : constant Node_Kind := Nkind (Name1); 5696 K2 : constant Node_Kind := Nkind (Name2); 5697 5698 function Prefix_Node (N : Node_Id) return Node_Id; 5699 -- Returns the parent unit name node of a defining program unit name 5700 -- or the prefix if N is a selected component or an expanded name. 5701 5702 function Select_Node (N : Node_Id) return Node_Id; 5703 -- Returns the defining identifier node of a defining program unit 5704 -- name or the selector node if N is a selected component or an 5705 -- expanded name. 5706 5707 ----------------- 5708 -- Prefix_Node -- 5709 ----------------- 5710 5711 function Prefix_Node (N : Node_Id) return Node_Id is 5712 begin 5713 if Nkind (N) = N_Defining_Program_Unit_Name then 5714 return Name (N); 5715 else 5716 return Prefix (N); 5717 end if; 5718 end Prefix_Node; 5719 5720 ----------------- 5721 -- Select_Node -- 5722 ----------------- 5723 5724 function Select_Node (N : Node_Id) return Node_Id is 5725 begin 5726 if Nkind (N) = N_Defining_Program_Unit_Name then 5727 return Defining_Identifier (N); 5728 else 5729 return Selector_Name (N); 5730 end if; 5731 end Select_Node; 5732 5733 -- Start of processing for Designate_Same_Unit 5734 5735 begin 5736 if Nkind_In (K1, N_Identifier, N_Defining_Identifier) 5737 and then 5738 Nkind_In (K2, N_Identifier, N_Defining_Identifier) 5739 then 5740 return Chars (Name1) = Chars (Name2); 5741 5742 elsif Nkind_In (K1, N_Expanded_Name, 5743 N_Selected_Component, 5744 N_Defining_Program_Unit_Name) 5745 and then 5746 Nkind_In (K2, N_Expanded_Name, 5747 N_Selected_Component, 5748 N_Defining_Program_Unit_Name) 5749 then 5750 return 5751 (Chars (Select_Node (Name1)) = Chars (Select_Node (Name2))) 5752 and then 5753 Designate_Same_Unit (Prefix_Node (Name1), Prefix_Node (Name2)); 5754 5755 else 5756 return False; 5757 end if; 5758 end Designate_Same_Unit; 5759 5760 ------------------------------------------ 5761 -- function Dynamic_Accessibility_Level -- 5762 ------------------------------------------ 5763 5764 function Dynamic_Accessibility_Level (Expr : Node_Id) return Node_Id is 5765 E : Entity_Id; 5766 Loc : constant Source_Ptr := Sloc (Expr); 5767 5768 function Make_Level_Literal (Level : Uint) return Node_Id; 5769 -- Construct an integer literal representing an accessibility level 5770 -- with its type set to Natural. 5771 5772 ------------------------ 5773 -- Make_Level_Literal -- 5774 ------------------------ 5775 5776 function Make_Level_Literal (Level : Uint) return Node_Id is 5777 Result : constant Node_Id := Make_Integer_Literal (Loc, Level); 5778 begin 5779 Set_Etype (Result, Standard_Natural); 5780 return Result; 5781 end Make_Level_Literal; 5782 5783 -- Start of processing for Dynamic_Accessibility_Level 5784 5785 begin 5786 if Is_Entity_Name (Expr) then 5787 E := Entity (Expr); 5788 5789 if Present (Renamed_Object (E)) then 5790 return Dynamic_Accessibility_Level (Renamed_Object (E)); 5791 end if; 5792 5793 if Is_Formal (E) or else Ekind_In (E, E_Variable, E_Constant) then 5794 if Present (Extra_Accessibility (E)) then 5795 return New_Occurrence_Of (Extra_Accessibility (E), Loc); 5796 end if; 5797 end if; 5798 end if; 5799 5800 -- Unimplemented: Ptr.all'Access, where Ptr has Extra_Accessibility ??? 5801 5802 case Nkind (Expr) is 5803 5804 -- For access discriminant, the level of the enclosing object 5805 5806 when N_Selected_Component => 5807 if Ekind (Entity (Selector_Name (Expr))) = E_Discriminant 5808 and then Ekind (Etype (Entity (Selector_Name (Expr)))) = 5809 E_Anonymous_Access_Type 5810 then 5811 return Make_Level_Literal (Object_Access_Level (Expr)); 5812 end if; 5813 5814 when N_Attribute_Reference => 5815 case Get_Attribute_Id (Attribute_Name (Expr)) is 5816 5817 -- For X'Access, the level of the prefix X 5818 5819 when Attribute_Access => 5820 return Make_Level_Literal 5821 (Object_Access_Level (Prefix (Expr))); 5822 5823 -- Treat the unchecked attributes as library-level 5824 5825 when Attribute_Unchecked_Access | 5826 Attribute_Unrestricted_Access => 5827 return Make_Level_Literal (Scope_Depth (Standard_Standard)); 5828 5829 -- No other access-valued attributes 5830 5831 when others => 5832 raise Program_Error; 5833 end case; 5834 5835 when N_Allocator => 5836 5837 -- Unimplemented: depends on context. As an actual parameter where 5838 -- formal type is anonymous, use 5839 -- Scope_Depth (Current_Scope) + 1. 5840 -- For other cases, see 3.10.2(14/3) and following. ??? 5841 5842 null; 5843 5844 when N_Type_Conversion => 5845 if not Is_Local_Anonymous_Access (Etype (Expr)) then 5846 5847 -- Handle type conversions introduced for a rename of an 5848 -- Ada 2012 stand-alone object of an anonymous access type. 5849 5850 return Dynamic_Accessibility_Level (Expression (Expr)); 5851 end if; 5852 5853 when others => 5854 null; 5855 end case; 5856 5857 return Make_Level_Literal (Type_Access_Level (Etype (Expr))); 5858 end Dynamic_Accessibility_Level; 5859 5860 ----------------------------------- 5861 -- Effective_Extra_Accessibility -- 5862 ----------------------------------- 5863 5864 function Effective_Extra_Accessibility (Id : Entity_Id) return Entity_Id is 5865 begin 5866 if Present (Renamed_Object (Id)) 5867 and then Is_Entity_Name (Renamed_Object (Id)) 5868 then 5869 return Effective_Extra_Accessibility (Entity (Renamed_Object (Id))); 5870 else 5871 return Extra_Accessibility (Id); 5872 end if; 5873 end Effective_Extra_Accessibility; 5874 5875 ----------------------------- 5876 -- Effective_Reads_Enabled -- 5877 ----------------------------- 5878 5879 function Effective_Reads_Enabled (Id : Entity_Id) return Boolean is 5880 begin 5881 return Has_Enabled_Property (Id, Name_Effective_Reads); 5882 end Effective_Reads_Enabled; 5883 5884 ------------------------------ 5885 -- Effective_Writes_Enabled -- 5886 ------------------------------ 5887 5888 function Effective_Writes_Enabled (Id : Entity_Id) return Boolean is 5889 begin 5890 return Has_Enabled_Property (Id, Name_Effective_Writes); 5891 end Effective_Writes_Enabled; 5892 5893 ------------------------------ 5894 -- Enclosing_Comp_Unit_Node -- 5895 ------------------------------ 5896 5897 function Enclosing_Comp_Unit_Node (N : Node_Id) return Node_Id is 5898 Current_Node : Node_Id; 5899 5900 begin 5901 Current_Node := N; 5902 while Present (Current_Node) 5903 and then Nkind (Current_Node) /= N_Compilation_Unit 5904 loop 5905 Current_Node := Parent (Current_Node); 5906 end loop; 5907 5908 if Nkind (Current_Node) /= N_Compilation_Unit then 5909 return Empty; 5910 else 5911 return Current_Node; 5912 end if; 5913 end Enclosing_Comp_Unit_Node; 5914 5915 -------------------------- 5916 -- Enclosing_CPP_Parent -- 5917 -------------------------- 5918 5919 function Enclosing_CPP_Parent (Typ : Entity_Id) return Entity_Id is 5920 Parent_Typ : Entity_Id := Typ; 5921 5922 begin 5923 while not Is_CPP_Class (Parent_Typ) 5924 and then Etype (Parent_Typ) /= Parent_Typ 5925 loop 5926 Parent_Typ := Etype (Parent_Typ); 5927 5928 if Is_Private_Type (Parent_Typ) then 5929 Parent_Typ := Full_View (Base_Type (Parent_Typ)); 5930 end if; 5931 end loop; 5932 5933 pragma Assert (Is_CPP_Class (Parent_Typ)); 5934 return Parent_Typ; 5935 end Enclosing_CPP_Parent; 5936 5937 --------------------------- 5938 -- Enclosing_Declaration -- 5939 --------------------------- 5940 5941 function Enclosing_Declaration (N : Node_Id) return Node_Id is 5942 Decl : Node_Id := N; 5943 5944 begin 5945 while Present (Decl) 5946 and then not (Nkind (Decl) in N_Declaration 5947 or else 5948 Nkind (Decl) in N_Later_Decl_Item) 5949 loop 5950 Decl := Parent (Decl); 5951 end loop; 5952 5953 return Decl; 5954 end Enclosing_Declaration; 5955 5956 ---------------------------- 5957 -- Enclosing_Generic_Body -- 5958 ---------------------------- 5959 5960 function Enclosing_Generic_Body 5961 (N : Node_Id) return Node_Id 5962 is 5963 P : Node_Id; 5964 Decl : Node_Id; 5965 Spec : Node_Id; 5966 5967 begin 5968 P := Parent (N); 5969 while Present (P) loop 5970 if Nkind (P) = N_Package_Body 5971 or else Nkind (P) = N_Subprogram_Body 5972 then 5973 Spec := Corresponding_Spec (P); 5974 5975 if Present (Spec) then 5976 Decl := Unit_Declaration_Node (Spec); 5977 5978 if Nkind (Decl) = N_Generic_Package_Declaration 5979 or else Nkind (Decl) = N_Generic_Subprogram_Declaration 5980 then 5981 return P; 5982 end if; 5983 end if; 5984 end if; 5985 5986 P := Parent (P); 5987 end loop; 5988 5989 return Empty; 5990 end Enclosing_Generic_Body; 5991 5992 ---------------------------- 5993 -- Enclosing_Generic_Unit -- 5994 ---------------------------- 5995 5996 function Enclosing_Generic_Unit 5997 (N : Node_Id) return Node_Id 5998 is 5999 P : Node_Id; 6000 Decl : Node_Id; 6001 Spec : Node_Id; 6002 6003 begin 6004 P := Parent (N); 6005 while Present (P) loop 6006 if Nkind (P) = N_Generic_Package_Declaration 6007 or else Nkind (P) = N_Generic_Subprogram_Declaration 6008 then 6009 return P; 6010 6011 elsif Nkind (P) = N_Package_Body 6012 or else Nkind (P) = N_Subprogram_Body 6013 then 6014 Spec := Corresponding_Spec (P); 6015 6016 if Present (Spec) then 6017 Decl := Unit_Declaration_Node (Spec); 6018 6019 if Nkind (Decl) = N_Generic_Package_Declaration 6020 or else Nkind (Decl) = N_Generic_Subprogram_Declaration 6021 then 6022 return Decl; 6023 end if; 6024 end if; 6025 end if; 6026 6027 P := Parent (P); 6028 end loop; 6029 6030 return Empty; 6031 end Enclosing_Generic_Unit; 6032 6033 ------------------------------- 6034 -- Enclosing_Lib_Unit_Entity -- 6035 ------------------------------- 6036 6037 function Enclosing_Lib_Unit_Entity 6038 (E : Entity_Id := Current_Scope) return Entity_Id 6039 is 6040 Unit_Entity : Entity_Id; 6041 6042 begin 6043 -- Look for enclosing library unit entity by following scope links. 6044 -- Equivalent to, but faster than indexing through the scope stack. 6045 6046 Unit_Entity := E; 6047 while (Present (Scope (Unit_Entity)) 6048 and then Scope (Unit_Entity) /= Standard_Standard) 6049 and not Is_Child_Unit (Unit_Entity) 6050 loop 6051 Unit_Entity := Scope (Unit_Entity); 6052 end loop; 6053 6054 return Unit_Entity; 6055 end Enclosing_Lib_Unit_Entity; 6056 6057 ----------------------------- 6058 -- Enclosing_Lib_Unit_Node -- 6059 ----------------------------- 6060 6061 function Enclosing_Lib_Unit_Node (N : Node_Id) return Node_Id is 6062 Encl_Unit : Node_Id; 6063 6064 begin 6065 Encl_Unit := Enclosing_Comp_Unit_Node (N); 6066 while Present (Encl_Unit) 6067 and then Nkind (Unit (Encl_Unit)) = N_Subunit 6068 loop 6069 Encl_Unit := Library_Unit (Encl_Unit); 6070 end loop; 6071 6072 return Encl_Unit; 6073 end Enclosing_Lib_Unit_Node; 6074 6075 ----------------------- 6076 -- Enclosing_Package -- 6077 ----------------------- 6078 6079 function Enclosing_Package (E : Entity_Id) return Entity_Id is 6080 Dynamic_Scope : constant Entity_Id := Enclosing_Dynamic_Scope (E); 6081 6082 begin 6083 if Dynamic_Scope = Standard_Standard then 6084 return Standard_Standard; 6085 6086 elsif Dynamic_Scope = Empty then 6087 return Empty; 6088 6089 elsif Ekind_In (Dynamic_Scope, E_Package, E_Package_Body, 6090 E_Generic_Package) 6091 then 6092 return Dynamic_Scope; 6093 6094 else 6095 return Enclosing_Package (Dynamic_Scope); 6096 end if; 6097 end Enclosing_Package; 6098 6099 ------------------------------------- 6100 -- Enclosing_Package_Or_Subprogram -- 6101 ------------------------------------- 6102 6103 function Enclosing_Package_Or_Subprogram (E : Entity_Id) return Entity_Id is 6104 S : Entity_Id; 6105 6106 begin 6107 S := Scope (E); 6108 while Present (S) loop 6109 if Is_Package_Or_Generic_Package (S) 6110 or else Ekind (S) = E_Package_Body 6111 then 6112 return S; 6113 6114 elsif Is_Subprogram_Or_Generic_Subprogram (S) 6115 or else Ekind (S) = E_Subprogram_Body 6116 then 6117 return S; 6118 6119 else 6120 S := Scope (S); 6121 end if; 6122 end loop; 6123 6124 return Empty; 6125 end Enclosing_Package_Or_Subprogram; 6126 6127 -------------------------- 6128 -- Enclosing_Subprogram -- 6129 -------------------------- 6130 6131 function Enclosing_Subprogram (E : Entity_Id) return Entity_Id is 6132 Dynamic_Scope : constant Entity_Id := Enclosing_Dynamic_Scope (E); 6133 6134 begin 6135 if Dynamic_Scope = Standard_Standard then 6136 return Empty; 6137 6138 elsif Dynamic_Scope = Empty then 6139 return Empty; 6140 6141 elsif Ekind (Dynamic_Scope) = E_Subprogram_Body then 6142 return Corresponding_Spec (Parent (Parent (Dynamic_Scope))); 6143 6144 elsif Ekind (Dynamic_Scope) = E_Block 6145 or else Ekind (Dynamic_Scope) = E_Return_Statement 6146 then 6147 return Enclosing_Subprogram (Dynamic_Scope); 6148 6149 elsif Ekind (Dynamic_Scope) = E_Task_Type then 6150 return Get_Task_Body_Procedure (Dynamic_Scope); 6151 6152 elsif Ekind (Dynamic_Scope) = E_Limited_Private_Type 6153 and then Present (Full_View (Dynamic_Scope)) 6154 and then Ekind (Full_View (Dynamic_Scope)) = E_Task_Type 6155 then 6156 return Get_Task_Body_Procedure (Full_View (Dynamic_Scope)); 6157 6158 -- No body is generated if the protected operation is eliminated 6159 6160 elsif Convention (Dynamic_Scope) = Convention_Protected 6161 and then not Is_Eliminated (Dynamic_Scope) 6162 and then Present (Protected_Body_Subprogram (Dynamic_Scope)) 6163 then 6164 return Protected_Body_Subprogram (Dynamic_Scope); 6165 6166 else 6167 return Dynamic_Scope; 6168 end if; 6169 end Enclosing_Subprogram; 6170 6171 ------------------------ 6172 -- Ensure_Freeze_Node -- 6173 ------------------------ 6174 6175 procedure Ensure_Freeze_Node (E : Entity_Id) is 6176 FN : Node_Id; 6177 begin 6178 if No (Freeze_Node (E)) then 6179 FN := Make_Freeze_Entity (Sloc (E)); 6180 Set_Has_Delayed_Freeze (E); 6181 Set_Freeze_Node (E, FN); 6182 Set_Access_Types_To_Process (FN, No_Elist); 6183 Set_TSS_Elist (FN, No_Elist); 6184 Set_Entity (FN, E); 6185 end if; 6186 end Ensure_Freeze_Node; 6187 6188 ---------------- 6189 -- Enter_Name -- 6190 ---------------- 6191 6192 procedure Enter_Name (Def_Id : Entity_Id) is 6193 C : constant Entity_Id := Current_Entity (Def_Id); 6194 E : constant Entity_Id := Current_Entity_In_Scope (Def_Id); 6195 S : constant Entity_Id := Current_Scope; 6196 6197 begin 6198 Generate_Definition (Def_Id); 6199 6200 -- Add new name to current scope declarations. Check for duplicate 6201 -- declaration, which may or may not be a genuine error. 6202 6203 if Present (E) then 6204 6205 -- Case of previous entity entered because of a missing declaration 6206 -- or else a bad subtype indication. Best is to use the new entity, 6207 -- and make the previous one invisible. 6208 6209 if Etype (E) = Any_Type then 6210 Set_Is_Immediately_Visible (E, False); 6211 6212 -- Case of renaming declaration constructed for package instances. 6213 -- if there is an explicit declaration with the same identifier, 6214 -- the renaming is not immediately visible any longer, but remains 6215 -- visible through selected component notation. 6216 6217 elsif Nkind (Parent (E)) = N_Package_Renaming_Declaration 6218 and then not Comes_From_Source (E) 6219 then 6220 Set_Is_Immediately_Visible (E, False); 6221 6222 -- The new entity may be the package renaming, which has the same 6223 -- same name as a generic formal which has been seen already. 6224 6225 elsif Nkind (Parent (Def_Id)) = N_Package_Renaming_Declaration 6226 and then not Comes_From_Source (Def_Id) 6227 then 6228 Set_Is_Immediately_Visible (E, False); 6229 6230 -- For a fat pointer corresponding to a remote access to subprogram, 6231 -- we use the same identifier as the RAS type, so that the proper 6232 -- name appears in the stub. This type is only retrieved through 6233 -- the RAS type and never by visibility, and is not added to the 6234 -- visibility list (see below). 6235 6236 elsif Nkind (Parent (Def_Id)) = N_Full_Type_Declaration 6237 and then Ekind (Def_Id) = E_Record_Type 6238 and then Present (Corresponding_Remote_Type (Def_Id)) 6239 then 6240 null; 6241 6242 -- Case of an implicit operation or derived literal. The new entity 6243 -- hides the implicit one, which is removed from all visibility, 6244 -- i.e. the entity list of its scope, and homonym chain of its name. 6245 6246 elsif (Is_Overloadable (E) and then Is_Inherited_Operation (E)) 6247 or else Is_Internal (E) 6248 then 6249 declare 6250 Prev : Entity_Id; 6251 Prev_Vis : Entity_Id; 6252 Decl : constant Node_Id := Parent (E); 6253 6254 begin 6255 -- If E is an implicit declaration, it cannot be the first 6256 -- entity in the scope. 6257 6258 Prev := First_Entity (Current_Scope); 6259 while Present (Prev) and then Next_Entity (Prev) /= E loop 6260 Next_Entity (Prev); 6261 end loop; 6262 6263 if No (Prev) then 6264 6265 -- If E is not on the entity chain of the current scope, 6266 -- it is an implicit declaration in the generic formal 6267 -- part of a generic subprogram. When analyzing the body, 6268 -- the generic formals are visible but not on the entity 6269 -- chain of the subprogram. The new entity will become 6270 -- the visible one in the body. 6271 6272 pragma Assert 6273 (Nkind (Parent (Decl)) = N_Generic_Subprogram_Declaration); 6274 null; 6275 6276 else 6277 Set_Next_Entity (Prev, Next_Entity (E)); 6278 6279 if No (Next_Entity (Prev)) then 6280 Set_Last_Entity (Current_Scope, Prev); 6281 end if; 6282 6283 if E = Current_Entity (E) then 6284 Prev_Vis := Empty; 6285 6286 else 6287 Prev_Vis := Current_Entity (E); 6288 while Homonym (Prev_Vis) /= E loop 6289 Prev_Vis := Homonym (Prev_Vis); 6290 end loop; 6291 end if; 6292 6293 if Present (Prev_Vis) then 6294 6295 -- Skip E in the visibility chain 6296 6297 Set_Homonym (Prev_Vis, Homonym (E)); 6298 6299 else 6300 Set_Name_Entity_Id (Chars (E), Homonym (E)); 6301 end if; 6302 end if; 6303 end; 6304 6305 -- This section of code could use a comment ??? 6306 6307 elsif Present (Etype (E)) 6308 and then Is_Concurrent_Type (Etype (E)) 6309 and then E = Def_Id 6310 then 6311 return; 6312 6313 -- If the homograph is a protected component renaming, it should not 6314 -- be hiding the current entity. Such renamings are treated as weak 6315 -- declarations. 6316 6317 elsif Is_Prival (E) then 6318 Set_Is_Immediately_Visible (E, False); 6319 6320 -- In this case the current entity is a protected component renaming. 6321 -- Perform minimal decoration by setting the scope and return since 6322 -- the prival should not be hiding other visible entities. 6323 6324 elsif Is_Prival (Def_Id) then 6325 Set_Scope (Def_Id, Current_Scope); 6326 return; 6327 6328 -- Analogous to privals, the discriminal generated for an entry index 6329 -- parameter acts as a weak declaration. Perform minimal decoration 6330 -- to avoid bogus errors. 6331 6332 elsif Is_Discriminal (Def_Id) 6333 and then Ekind (Discriminal_Link (Def_Id)) = E_Entry_Index_Parameter 6334 then 6335 Set_Scope (Def_Id, Current_Scope); 6336 return; 6337 6338 -- In the body or private part of an instance, a type extension may 6339 -- introduce a component with the same name as that of an actual. The 6340 -- legality rule is not enforced, but the semantics of the full type 6341 -- with two components of same name are not clear at this point??? 6342 6343 elsif In_Instance_Not_Visible then 6344 null; 6345 6346 -- When compiling a package body, some child units may have become 6347 -- visible. They cannot conflict with local entities that hide them. 6348 6349 elsif Is_Child_Unit (E) 6350 and then In_Open_Scopes (Scope (E)) 6351 and then not Is_Immediately_Visible (E) 6352 then 6353 null; 6354 6355 -- Conversely, with front-end inlining we may compile the parent body 6356 -- first, and a child unit subsequently. The context is now the 6357 -- parent spec, and body entities are not visible. 6358 6359 elsif Is_Child_Unit (Def_Id) 6360 and then Is_Package_Body_Entity (E) 6361 and then not In_Package_Body (Current_Scope) 6362 then 6363 null; 6364 6365 -- Case of genuine duplicate declaration 6366 6367 else 6368 Error_Msg_Sloc := Sloc (E); 6369 6370 -- If the previous declaration is an incomplete type declaration 6371 -- this may be an attempt to complete it with a private type. The 6372 -- following avoids confusing cascaded errors. 6373 6374 if Nkind (Parent (E)) = N_Incomplete_Type_Declaration 6375 and then Nkind (Parent (Def_Id)) = N_Private_Type_Declaration 6376 then 6377 Error_Msg_N 6378 ("incomplete type cannot be completed with a private " & 6379 "declaration", Parent (Def_Id)); 6380 Set_Is_Immediately_Visible (E, False); 6381 Set_Full_View (E, Def_Id); 6382 6383 -- An inherited component of a record conflicts with a new 6384 -- discriminant. The discriminant is inserted first in the scope, 6385 -- but the error should be posted on it, not on the component. 6386 6387 elsif Ekind (E) = E_Discriminant 6388 and then Present (Scope (Def_Id)) 6389 and then Scope (Def_Id) /= Current_Scope 6390 then 6391 Error_Msg_Sloc := Sloc (Def_Id); 6392 Error_Msg_N ("& conflicts with declaration#", E); 6393 return; 6394 6395 -- If the name of the unit appears in its own context clause, a 6396 -- dummy package with the name has already been created, and the 6397 -- error emitted. Try to continue quietly. 6398 6399 elsif Error_Posted (E) 6400 and then Sloc (E) = No_Location 6401 and then Nkind (Parent (E)) = N_Package_Specification 6402 and then Current_Scope = Standard_Standard 6403 then 6404 Set_Scope (Def_Id, Current_Scope); 6405 return; 6406 6407 else 6408 Error_Msg_N ("& conflicts with declaration#", Def_Id); 6409 6410 -- Avoid cascaded messages with duplicate components in 6411 -- derived types. 6412 6413 if Ekind_In (E, E_Component, E_Discriminant) then 6414 return; 6415 end if; 6416 end if; 6417 6418 if Nkind (Parent (Parent (Def_Id))) = 6419 N_Generic_Subprogram_Declaration 6420 and then Def_Id = 6421 Defining_Entity (Specification (Parent (Parent (Def_Id)))) 6422 then 6423 Error_Msg_N ("\generic units cannot be overloaded", Def_Id); 6424 end if; 6425 6426 -- If entity is in standard, then we are in trouble, because it 6427 -- means that we have a library package with a duplicated name. 6428 -- That's hard to recover from, so abort. 6429 6430 if S = Standard_Standard then 6431 raise Unrecoverable_Error; 6432 6433 -- Otherwise we continue with the declaration. Having two 6434 -- identical declarations should not cause us too much trouble. 6435 6436 else 6437 null; 6438 end if; 6439 end if; 6440 end if; 6441 6442 -- If we fall through, declaration is OK, at least OK enough to continue 6443 6444 -- If Def_Id is a discriminant or a record component we are in the midst 6445 -- of inheriting components in a derived record definition. Preserve 6446 -- their Ekind and Etype. 6447 6448 if Ekind_In (Def_Id, E_Discriminant, E_Component) then 6449 null; 6450 6451 -- If a type is already set, leave it alone (happens when a type 6452 -- declaration is reanalyzed following a call to the optimizer). 6453 6454 elsif Present (Etype (Def_Id)) then 6455 null; 6456 6457 -- Otherwise, the kind E_Void insures that premature uses of the entity 6458 -- will be detected. Any_Type insures that no cascaded errors will occur 6459 6460 else 6461 Set_Ekind (Def_Id, E_Void); 6462 Set_Etype (Def_Id, Any_Type); 6463 end if; 6464 6465 -- Inherited discriminants and components in derived record types are 6466 -- immediately visible. Itypes are not. 6467 6468 -- Unless the Itype is for a record type with a corresponding remote 6469 -- type (what is that about, it was not commented ???) 6470 6471 if Ekind_In (Def_Id, E_Discriminant, E_Component) 6472 or else 6473 ((not Is_Record_Type (Def_Id) 6474 or else No (Corresponding_Remote_Type (Def_Id))) 6475 and then not Is_Itype (Def_Id)) 6476 then 6477 Set_Is_Immediately_Visible (Def_Id); 6478 Set_Current_Entity (Def_Id); 6479 end if; 6480 6481 Set_Homonym (Def_Id, C); 6482 Append_Entity (Def_Id, S); 6483 Set_Public_Status (Def_Id); 6484 6485 -- Declaring a homonym is not allowed in SPARK ... 6486 6487 if Present (C) and then Restriction_Check_Required (SPARK_05) then 6488 declare 6489 Enclosing_Subp : constant Node_Id := Enclosing_Subprogram (Def_Id); 6490 Enclosing_Pack : constant Node_Id := Enclosing_Package (Def_Id); 6491 Other_Scope : constant Node_Id := Enclosing_Dynamic_Scope (C); 6492 6493 begin 6494 -- ... unless the new declaration is in a subprogram, and the 6495 -- visible declaration is a variable declaration or a parameter 6496 -- specification outside that subprogram. 6497 6498 if Present (Enclosing_Subp) 6499 and then Nkind_In (Parent (C), N_Object_Declaration, 6500 N_Parameter_Specification) 6501 and then not Scope_Within_Or_Same (Other_Scope, Enclosing_Subp) 6502 then 6503 null; 6504 6505 -- ... or the new declaration is in a package, and the visible 6506 -- declaration occurs outside that package. 6507 6508 elsif Present (Enclosing_Pack) 6509 and then not Scope_Within_Or_Same (Other_Scope, Enclosing_Pack) 6510 then 6511 null; 6512 6513 -- ... or the new declaration is a component declaration in a 6514 -- record type definition. 6515 6516 elsif Nkind (Parent (Def_Id)) = N_Component_Declaration then 6517 null; 6518 6519 -- Don't issue error for non-source entities 6520 6521 elsif Comes_From_Source (Def_Id) 6522 and then Comes_From_Source (C) 6523 then 6524 Error_Msg_Sloc := Sloc (C); 6525 Check_SPARK_05_Restriction 6526 ("redeclaration of identifier &#", Def_Id); 6527 end if; 6528 end; 6529 end if; 6530 6531 -- Warn if new entity hides an old one 6532 6533 if Warn_On_Hiding and then Present (C) 6534 6535 -- Don't warn for record components since they always have a well 6536 -- defined scope which does not confuse other uses. Note that in 6537 -- some cases, Ekind has not been set yet. 6538 6539 and then Ekind (C) /= E_Component 6540 and then Ekind (C) /= E_Discriminant 6541 and then Nkind (Parent (C)) /= N_Component_Declaration 6542 and then Ekind (Def_Id) /= E_Component 6543 and then Ekind (Def_Id) /= E_Discriminant 6544 and then Nkind (Parent (Def_Id)) /= N_Component_Declaration 6545 6546 -- Don't warn for one character variables. It is too common to use 6547 -- such variables as locals and will just cause too many false hits. 6548 6549 and then Length_Of_Name (Chars (C)) /= 1 6550 6551 -- Don't warn for non-source entities 6552 6553 and then Comes_From_Source (C) 6554 and then Comes_From_Source (Def_Id) 6555 6556 -- Don't warn unless entity in question is in extended main source 6557 6558 and then In_Extended_Main_Source_Unit (Def_Id) 6559 6560 -- Finally, the hidden entity must be either immediately visible or 6561 -- use visible (i.e. from a used package). 6562 6563 and then 6564 (Is_Immediately_Visible (C) 6565 or else 6566 Is_Potentially_Use_Visible (C)) 6567 then 6568 Error_Msg_Sloc := Sloc (C); 6569 Error_Msg_N ("declaration hides &#?h?", Def_Id); 6570 end if; 6571 end Enter_Name; 6572 6573 --------------- 6574 -- Entity_Of -- 6575 --------------- 6576 6577 function Entity_Of (N : Node_Id) return Entity_Id is 6578 Id : Entity_Id; 6579 6580 begin 6581 Id := Empty; 6582 6583 if Is_Entity_Name (N) then 6584 Id := Entity (N); 6585 6586 -- Follow a possible chain of renamings to reach the root renamed 6587 -- object. 6588 6589 while Present (Id) 6590 and then Is_Object (Id) 6591 and then Present (Renamed_Object (Id)) 6592 loop 6593 if Is_Entity_Name (Renamed_Object (Id)) then 6594 Id := Entity (Renamed_Object (Id)); 6595 else 6596 Id := Empty; 6597 exit; 6598 end if; 6599 end loop; 6600 end if; 6601 6602 return Id; 6603 end Entity_Of; 6604 6605 -------------------------- 6606 -- Explain_Limited_Type -- 6607 -------------------------- 6608 6609 procedure Explain_Limited_Type (T : Entity_Id; N : Node_Id) is 6610 C : Entity_Id; 6611 6612 begin 6613 -- For array, component type must be limited 6614 6615 if Is_Array_Type (T) then 6616 Error_Msg_Node_2 := T; 6617 Error_Msg_NE 6618 ("\component type& of type& is limited", N, Component_Type (T)); 6619 Explain_Limited_Type (Component_Type (T), N); 6620 6621 elsif Is_Record_Type (T) then 6622 6623 -- No need for extra messages if explicit limited record 6624 6625 if Is_Limited_Record (Base_Type (T)) then 6626 return; 6627 end if; 6628 6629 -- Otherwise find a limited component. Check only components that 6630 -- come from source, or inherited components that appear in the 6631 -- source of the ancestor. 6632 6633 C := First_Component (T); 6634 while Present (C) loop 6635 if Is_Limited_Type (Etype (C)) 6636 and then 6637 (Comes_From_Source (C) 6638 or else 6639 (Present (Original_Record_Component (C)) 6640 and then 6641 Comes_From_Source (Original_Record_Component (C)))) 6642 then 6643 Error_Msg_Node_2 := T; 6644 Error_Msg_NE ("\component& of type& has limited type", N, C); 6645 Explain_Limited_Type (Etype (C), N); 6646 return; 6647 end if; 6648 6649 Next_Component (C); 6650 end loop; 6651 6652 -- The type may be declared explicitly limited, even if no component 6653 -- of it is limited, in which case we fall out of the loop. 6654 return; 6655 end if; 6656 end Explain_Limited_Type; 6657 6658 ------------------------------- 6659 -- Extensions_Visible_Status -- 6660 ------------------------------- 6661 6662 function Extensions_Visible_Status 6663 (Id : Entity_Id) return Extensions_Visible_Mode 6664 is 6665 Arg : Node_Id; 6666 Decl : Node_Id; 6667 Expr : Node_Id; 6668 Prag : Node_Id; 6669 Subp : Entity_Id; 6670 6671 begin 6672 -- When a formal parameter is subject to Extensions_Visible, the pragma 6673 -- is stored in the contract of related subprogram. 6674 6675 if Is_Formal (Id) then 6676 Subp := Scope (Id); 6677 6678 elsif Is_Subprogram_Or_Generic_Subprogram (Id) then 6679 Subp := Id; 6680 6681 -- No other construct carries this pragma 6682 6683 else 6684 return Extensions_Visible_None; 6685 end if; 6686 6687 Prag := Get_Pragma (Subp, Pragma_Extensions_Visible); 6688 6689 -- In certain cases analysis may request the Extensions_Visible status 6690 -- of an expression function before the pragma has been analyzed yet. 6691 -- Inspect the declarative items after the expression function looking 6692 -- for the pragma (if any). 6693 6694 if No (Prag) and then Is_Expression_Function (Subp) then 6695 Decl := Next (Unit_Declaration_Node (Subp)); 6696 while Present (Decl) loop 6697 if Nkind (Decl) = N_Pragma 6698 and then Pragma_Name (Decl) = Name_Extensions_Visible 6699 then 6700 Prag := Decl; 6701 exit; 6702 6703 -- A source construct ends the region where Extensions_Visible may 6704 -- appear, stop the traversal. An expanded expression function is 6705 -- no longer a source construct, but it must still be recognized. 6706 6707 elsif Comes_From_Source (Decl) 6708 or else 6709 (Nkind_In (Decl, N_Subprogram_Body, 6710 N_Subprogram_Declaration) 6711 and then Is_Expression_Function (Defining_Entity (Decl))) 6712 then 6713 exit; 6714 end if; 6715 6716 Next (Decl); 6717 end loop; 6718 end if; 6719 6720 -- Extract the value from the Boolean expression (if any) 6721 6722 if Present (Prag) then 6723 Arg := First (Pragma_Argument_Associations (Prag)); 6724 6725 if Present (Arg) then 6726 Expr := Get_Pragma_Arg (Arg); 6727 6728 -- When the associated subprogram is an expression function, the 6729 -- argument of the pragma may not have been analyzed. 6730 6731 if not Analyzed (Expr) then 6732 Preanalyze_And_Resolve (Expr, Standard_Boolean); 6733 end if; 6734 6735 -- Guard against cascading errors when the argument of pragma 6736 -- Extensions_Visible is not a valid static Boolean expression. 6737 6738 if Error_Posted (Expr) then 6739 return Extensions_Visible_None; 6740 6741 elsif Is_True (Expr_Value (Expr)) then 6742 return Extensions_Visible_True; 6743 6744 else 6745 return Extensions_Visible_False; 6746 end if; 6747 6748 -- Otherwise the aspect or pragma defaults to True 6749 6750 else 6751 return Extensions_Visible_True; 6752 end if; 6753 6754 -- Otherwise aspect or pragma Extensions_Visible is not inherited or 6755 -- directly specified. In SPARK code, its value defaults to "False". 6756 6757 elsif SPARK_Mode = On then 6758 return Extensions_Visible_False; 6759 6760 -- In non-SPARK code, aspect or pragma Extensions_Visible defaults to 6761 -- "True". 6762 6763 else 6764 return Extensions_Visible_True; 6765 end if; 6766 end Extensions_Visible_Status; 6767 6768 ----------------- 6769 -- Find_Actual -- 6770 ----------------- 6771 6772 procedure Find_Actual 6773 (N : Node_Id; 6774 Formal : out Entity_Id; 6775 Call : out Node_Id) 6776 is 6777 Context : constant Node_Id := Parent (N); 6778 Actual : Node_Id; 6779 Call_Nam : Node_Id; 6780 6781 begin 6782 if Nkind_In (Context, N_Indexed_Component, N_Selected_Component) 6783 and then N = Prefix (Context) 6784 then 6785 Find_Actual (Context, Formal, Call); 6786 return; 6787 6788 elsif Nkind (Context) = N_Parameter_Association 6789 and then N = Explicit_Actual_Parameter (Context) 6790 then 6791 Call := Parent (Context); 6792 6793 elsif Nkind_In (Context, N_Entry_Call_Statement, 6794 N_Function_Call, 6795 N_Procedure_Call_Statement) 6796 then 6797 Call := Context; 6798 6799 else 6800 Formal := Empty; 6801 Call := Empty; 6802 return; 6803 end if; 6804 6805 -- If we have a call to a subprogram look for the parameter. Note that 6806 -- we exclude overloaded calls, since we don't know enough to be sure 6807 -- of giving the right answer in this case. 6808 6809 if Nkind_In (Call, N_Entry_Call_Statement, 6810 N_Function_Call, 6811 N_Procedure_Call_Statement) 6812 then 6813 Call_Nam := Name (Call); 6814 6815 -- A call to a protected or task entry appears as a selected 6816 -- component rather than an expanded name. 6817 6818 if Nkind (Call_Nam) = N_Selected_Component then 6819 Call_Nam := Selector_Name (Call_Nam); 6820 end if; 6821 6822 if Is_Entity_Name (Call_Nam) 6823 and then Present (Entity (Call_Nam)) 6824 and then Is_Overloadable (Entity (Call_Nam)) 6825 and then not Is_Overloaded (Call_Nam) 6826 then 6827 -- If node is name in call it is not an actual 6828 6829 if N = Call_Nam then 6830 Formal := Empty; 6831 Call := Empty; 6832 return; 6833 end if; 6834 6835 -- Fall here if we are definitely a parameter 6836 6837 Actual := First_Actual (Call); 6838 Formal := First_Formal (Entity (Call_Nam)); 6839 while Present (Formal) and then Present (Actual) loop 6840 if Actual = N then 6841 return; 6842 6843 -- An actual that is the prefix in a prefixed call may have 6844 -- been rewritten in the call, after the deferred reference 6845 -- was collected. Check if sloc and kinds and names match. 6846 6847 elsif Sloc (Actual) = Sloc (N) 6848 and then Nkind (Actual) = N_Identifier 6849 and then Nkind (Actual) = Nkind (N) 6850 and then Chars (Actual) = Chars (N) 6851 then 6852 return; 6853 6854 else 6855 Actual := Next_Actual (Actual); 6856 Formal := Next_Formal (Formal); 6857 end if; 6858 end loop; 6859 end if; 6860 end if; 6861 6862 -- Fall through here if we did not find matching actual 6863 6864 Formal := Empty; 6865 Call := Empty; 6866 end Find_Actual; 6867 6868 --------------------------- 6869 -- Find_Body_Discriminal -- 6870 --------------------------- 6871 6872 function Find_Body_Discriminal 6873 (Spec_Discriminant : Entity_Id) return Entity_Id 6874 is 6875 Tsk : Entity_Id; 6876 Disc : Entity_Id; 6877 6878 begin 6879 -- If expansion is suppressed, then the scope can be the concurrent type 6880 -- itself rather than a corresponding concurrent record type. 6881 6882 if Is_Concurrent_Type (Scope (Spec_Discriminant)) then 6883 Tsk := Scope (Spec_Discriminant); 6884 6885 else 6886 pragma Assert (Is_Concurrent_Record_Type (Scope (Spec_Discriminant))); 6887 6888 Tsk := Corresponding_Concurrent_Type (Scope (Spec_Discriminant)); 6889 end if; 6890 6891 -- Find discriminant of original concurrent type, and use its current 6892 -- discriminal, which is the renaming within the task/protected body. 6893 6894 Disc := First_Discriminant (Tsk); 6895 while Present (Disc) loop 6896 if Chars (Disc) = Chars (Spec_Discriminant) then 6897 return Discriminal (Disc); 6898 end if; 6899 6900 Next_Discriminant (Disc); 6901 end loop; 6902 6903 -- That loop should always succeed in finding a matching entry and 6904 -- returning. Fatal error if not. 6905 6906 raise Program_Error; 6907 end Find_Body_Discriminal; 6908 6909 ------------------------------------- 6910 -- Find_Corresponding_Discriminant -- 6911 ------------------------------------- 6912 6913 function Find_Corresponding_Discriminant 6914 (Id : Node_Id; 6915 Typ : Entity_Id) return Entity_Id 6916 is 6917 Par_Disc : Entity_Id; 6918 Old_Disc : Entity_Id; 6919 New_Disc : Entity_Id; 6920 6921 begin 6922 Par_Disc := Original_Record_Component (Original_Discriminant (Id)); 6923 6924 -- The original type may currently be private, and the discriminant 6925 -- only appear on its full view. 6926 6927 if Is_Private_Type (Scope (Par_Disc)) 6928 and then not Has_Discriminants (Scope (Par_Disc)) 6929 and then Present (Full_View (Scope (Par_Disc))) 6930 then 6931 Old_Disc := First_Discriminant (Full_View (Scope (Par_Disc))); 6932 else 6933 Old_Disc := First_Discriminant (Scope (Par_Disc)); 6934 end if; 6935 6936 if Is_Class_Wide_Type (Typ) then 6937 New_Disc := First_Discriminant (Root_Type (Typ)); 6938 else 6939 New_Disc := First_Discriminant (Typ); 6940 end if; 6941 6942 while Present (Old_Disc) and then Present (New_Disc) loop 6943 if Old_Disc = Par_Disc then 6944 return New_Disc; 6945 end if; 6946 6947 Next_Discriminant (Old_Disc); 6948 Next_Discriminant (New_Disc); 6949 end loop; 6950 6951 -- Should always find it 6952 6953 raise Program_Error; 6954 end Find_Corresponding_Discriminant; 6955 6956 ---------------------------------- 6957 -- Find_Enclosing_Iterator_Loop -- 6958 ---------------------------------- 6959 6960 function Find_Enclosing_Iterator_Loop (Id : Entity_Id) return Entity_Id is 6961 Constr : Node_Id; 6962 S : Entity_Id; 6963 6964 begin 6965 -- Traverse the scope chain looking for an iterator loop. Such loops are 6966 -- usually transformed into blocks, hence the use of Original_Node. 6967 6968 S := Id; 6969 while Present (S) and then S /= Standard_Standard loop 6970 if Ekind (S) = E_Loop 6971 and then Nkind (Parent (S)) = N_Implicit_Label_Declaration 6972 then 6973 Constr := Original_Node (Label_Construct (Parent (S))); 6974 6975 if Nkind (Constr) = N_Loop_Statement 6976 and then Present (Iteration_Scheme (Constr)) 6977 and then Nkind (Iterator_Specification 6978 (Iteration_Scheme (Constr))) = 6979 N_Iterator_Specification 6980 then 6981 return S; 6982 end if; 6983 end if; 6984 6985 S := Scope (S); 6986 end loop; 6987 6988 return Empty; 6989 end Find_Enclosing_Iterator_Loop; 6990 6991 ------------------------------------ 6992 -- Find_Loop_In_Conditional_Block -- 6993 ------------------------------------ 6994 6995 function Find_Loop_In_Conditional_Block (N : Node_Id) return Node_Id is 6996 Stmt : Node_Id; 6997 6998 begin 6999 Stmt := N; 7000 7001 if Nkind (Stmt) = N_If_Statement then 7002 Stmt := First (Then_Statements (Stmt)); 7003 end if; 7004 7005 pragma Assert (Nkind (Stmt) = N_Block_Statement); 7006 7007 -- Inspect the statements of the conditional block. In general the loop 7008 -- should be the first statement in the statement sequence of the block, 7009 -- but the finalization machinery may have introduced extra object 7010 -- declarations. 7011 7012 Stmt := First (Statements (Handled_Statement_Sequence (Stmt))); 7013 while Present (Stmt) loop 7014 if Nkind (Stmt) = N_Loop_Statement then 7015 return Stmt; 7016 end if; 7017 7018 Next (Stmt); 7019 end loop; 7020 7021 -- The expansion of attribute 'Loop_Entry produced a malformed block 7022 7023 raise Program_Error; 7024 end Find_Loop_In_Conditional_Block; 7025 7026 -------------------------- 7027 -- Find_Overlaid_Entity -- 7028 -------------------------- 7029 7030 procedure Find_Overlaid_Entity 7031 (N : Node_Id; 7032 Ent : out Entity_Id; 7033 Off : out Boolean) 7034 is 7035 Expr : Node_Id; 7036 7037 begin 7038 -- We are looking for one of the two following forms: 7039 7040 -- for X'Address use Y'Address 7041 7042 -- or 7043 7044 -- Const : constant Address := expr; 7045 -- ... 7046 -- for X'Address use Const; 7047 7048 -- In the second case, the expr is either Y'Address, or recursively a 7049 -- constant that eventually references Y'Address. 7050 7051 Ent := Empty; 7052 Off := False; 7053 7054 if Nkind (N) = N_Attribute_Definition_Clause 7055 and then Chars (N) = Name_Address 7056 then 7057 Expr := Expression (N); 7058 7059 -- This loop checks the form of the expression for Y'Address, 7060 -- using recursion to deal with intermediate constants. 7061 7062 loop 7063 -- Check for Y'Address 7064 7065 if Nkind (Expr) = N_Attribute_Reference 7066 and then Attribute_Name (Expr) = Name_Address 7067 then 7068 Expr := Prefix (Expr); 7069 exit; 7070 7071 -- Check for Const where Const is a constant entity 7072 7073 elsif Is_Entity_Name (Expr) 7074 and then Ekind (Entity (Expr)) = E_Constant 7075 then 7076 Expr := Constant_Value (Entity (Expr)); 7077 7078 -- Anything else does not need checking 7079 7080 else 7081 return; 7082 end if; 7083 end loop; 7084 7085 -- This loop checks the form of the prefix for an entity, using 7086 -- recursion to deal with intermediate components. 7087 7088 loop 7089 -- Check for Y where Y is an entity 7090 7091 if Is_Entity_Name (Expr) then 7092 Ent := Entity (Expr); 7093 return; 7094 7095 -- Check for components 7096 7097 elsif 7098 Nkind_In (Expr, N_Selected_Component, N_Indexed_Component) 7099 then 7100 Expr := Prefix (Expr); 7101 Off := True; 7102 7103 -- Anything else does not need checking 7104 7105 else 7106 return; 7107 end if; 7108 end loop; 7109 end if; 7110 end Find_Overlaid_Entity; 7111 7112 ------------------------- 7113 -- Find_Parameter_Type -- 7114 ------------------------- 7115 7116 function Find_Parameter_Type (Param : Node_Id) return Entity_Id is 7117 begin 7118 if Nkind (Param) /= N_Parameter_Specification then 7119 return Empty; 7120 7121 -- For an access parameter, obtain the type from the formal entity 7122 -- itself, because access to subprogram nodes do not carry a type. 7123 -- Shouldn't we always use the formal entity ??? 7124 7125 elsif Nkind (Parameter_Type (Param)) = N_Access_Definition then 7126 return Etype (Defining_Identifier (Param)); 7127 7128 else 7129 return Etype (Parameter_Type (Param)); 7130 end if; 7131 end Find_Parameter_Type; 7132 7133 ----------------------------------- 7134 -- Find_Placement_In_State_Space -- 7135 ----------------------------------- 7136 7137 procedure Find_Placement_In_State_Space 7138 (Item_Id : Entity_Id; 7139 Placement : out State_Space_Kind; 7140 Pack_Id : out Entity_Id) 7141 is 7142 Context : Entity_Id; 7143 7144 begin 7145 -- Assume that the item does not appear in the state space of a package 7146 7147 Placement := Not_In_Package; 7148 Pack_Id := Empty; 7149 7150 -- Climb the scope stack and examine the enclosing context 7151 7152 Context := Scope (Item_Id); 7153 while Present (Context) and then Context /= Standard_Standard loop 7154 if Ekind (Context) = E_Package then 7155 Pack_Id := Context; 7156 7157 -- A package body is a cut off point for the traversal as the item 7158 -- cannot be visible to the outside from this point on. Note that 7159 -- this test must be done first as a body is also classified as a 7160 -- private part. 7161 7162 if In_Package_Body (Context) then 7163 Placement := Body_State_Space; 7164 return; 7165 7166 -- The private part of a package is a cut off point for the 7167 -- traversal as the item cannot be visible to the outside from 7168 -- this point on. 7169 7170 elsif In_Private_Part (Context) then 7171 Placement := Private_State_Space; 7172 return; 7173 7174 -- When the item appears in the visible state space of a package, 7175 -- continue to climb the scope stack as this may not be the final 7176 -- state space. 7177 7178 else 7179 Placement := Visible_State_Space; 7180 7181 -- The visible state space of a child unit acts as the proper 7182 -- placement of an item. 7183 7184 if Is_Child_Unit (Context) then 7185 return; 7186 end if; 7187 end if; 7188 7189 -- The item or its enclosing package appear in a construct that has 7190 -- no state space. 7191 7192 else 7193 Placement := Not_In_Package; 7194 return; 7195 end if; 7196 7197 Context := Scope (Context); 7198 end loop; 7199 end Find_Placement_In_State_Space; 7200 7201 ------------------------ 7202 -- Find_Specific_Type -- 7203 ------------------------ 7204 7205 function Find_Specific_Type (CW : Entity_Id) return Entity_Id is 7206 Typ : Entity_Id := Root_Type (CW); 7207 7208 begin 7209 if Ekind (Typ) = E_Incomplete_Type then 7210 if From_Limited_With (Typ) then 7211 Typ := Non_Limited_View (Typ); 7212 else 7213 Typ := Full_View (Typ); 7214 end if; 7215 end if; 7216 7217 if Is_Private_Type (Typ) 7218 and then not Is_Tagged_Type (Typ) 7219 and then Present (Full_View (Typ)) 7220 then 7221 return Full_View (Typ); 7222 else 7223 return Typ; 7224 end if; 7225 end Find_Specific_Type; 7226 7227 ----------------------------- 7228 -- Find_Static_Alternative -- 7229 ----------------------------- 7230 7231 function Find_Static_Alternative (N : Node_Id) return Node_Id is 7232 Expr : constant Node_Id := Expression (N); 7233 Val : constant Uint := Expr_Value (Expr); 7234 Alt : Node_Id; 7235 Choice : Node_Id; 7236 7237 begin 7238 Alt := First (Alternatives (N)); 7239 7240 Search : loop 7241 if Nkind (Alt) /= N_Pragma then 7242 Choice := First (Discrete_Choices (Alt)); 7243 while Present (Choice) loop 7244 7245 -- Others choice, always matches 7246 7247 if Nkind (Choice) = N_Others_Choice then 7248 exit Search; 7249 7250 -- Range, check if value is in the range 7251 7252 elsif Nkind (Choice) = N_Range then 7253 exit Search when 7254 Val >= Expr_Value (Low_Bound (Choice)) 7255 and then 7256 Val <= Expr_Value (High_Bound (Choice)); 7257 7258 -- Choice is a subtype name. Note that we know it must 7259 -- be a static subtype, since otherwise it would have 7260 -- been diagnosed as illegal. 7261 7262 elsif Is_Entity_Name (Choice) 7263 and then Is_Type (Entity (Choice)) 7264 then 7265 exit Search when Is_In_Range (Expr, Etype (Choice), 7266 Assume_Valid => False); 7267 7268 -- Choice is a subtype indication 7269 7270 elsif Nkind (Choice) = N_Subtype_Indication then 7271 declare 7272 C : constant Node_Id := Constraint (Choice); 7273 R : constant Node_Id := Range_Expression (C); 7274 7275 begin 7276 exit Search when 7277 Val >= Expr_Value (Low_Bound (R)) 7278 and then 7279 Val <= Expr_Value (High_Bound (R)); 7280 end; 7281 7282 -- Choice is a simple expression 7283 7284 else 7285 exit Search when Val = Expr_Value (Choice); 7286 end if; 7287 7288 Next (Choice); 7289 end loop; 7290 end if; 7291 7292 Next (Alt); 7293 pragma Assert (Present (Alt)); 7294 end loop Search; 7295 7296 -- The above loop *must* terminate by finding a match, since 7297 -- we know the case statement is valid, and the value of the 7298 -- expression is known at compile time. When we fall out of 7299 -- the loop, Alt points to the alternative that we know will 7300 -- be selected at run time. 7301 7302 return Alt; 7303 end Find_Static_Alternative; 7304 7305 ------------------ 7306 -- First_Actual -- 7307 ------------------ 7308 7309 function First_Actual (Node : Node_Id) return Node_Id is 7310 N : Node_Id; 7311 7312 begin 7313 if No (Parameter_Associations (Node)) then 7314 return Empty; 7315 end if; 7316 7317 N := First (Parameter_Associations (Node)); 7318 7319 if Nkind (N) = N_Parameter_Association then 7320 return First_Named_Actual (Node); 7321 else 7322 return N; 7323 end if; 7324 end First_Actual; 7325 7326 ------------- 7327 -- Fix_Msg -- 7328 ------------- 7329 7330 function Fix_Msg (Id : Entity_Id; Msg : String) return String is 7331 Is_Task : constant Boolean := 7332 Ekind_In (Id, E_Task_Body, E_Task_Type) 7333 or else Is_Single_Task_Object (Id); 7334 Msg_Last : constant Natural := Msg'Last; 7335 Msg_Index : Natural; 7336 Res : String (Msg'Range) := (others => ' '); 7337 Res_Index : Natural; 7338 7339 begin 7340 -- Copy all characters from the input message Msg to result Res with 7341 -- suitable replacements. 7342 7343 Msg_Index := Msg'First; 7344 Res_Index := Res'First; 7345 while Msg_Index <= Msg_Last loop 7346 7347 -- Replace "subprogram" with a different word 7348 7349 if Msg_Index <= Msg_Last - 10 7350 and then Msg (Msg_Index .. Msg_Index + 9) = "subprogram" 7351 then 7352 if Ekind_In (Id, E_Entry, E_Entry_Family) then 7353 Res (Res_Index .. Res_Index + 4) := "entry"; 7354 Res_Index := Res_Index + 5; 7355 7356 elsif Is_Task then 7357 Res (Res_Index .. Res_Index + 8) := "task type"; 7358 Res_Index := Res_Index + 9; 7359 7360 else 7361 Res (Res_Index .. Res_Index + 9) := "subprogram"; 7362 Res_Index := Res_Index + 10; 7363 end if; 7364 7365 Msg_Index := Msg_Index + 10; 7366 7367 -- Replace "protected" with a different word 7368 7369 elsif Msg_Index <= Msg_Last - 9 7370 and then Msg (Msg_Index .. Msg_Index + 8) = "protected" 7371 and then Is_Task 7372 then 7373 Res (Res_Index .. Res_Index + 3) := "task"; 7374 Res_Index := Res_Index + 4; 7375 Msg_Index := Msg_Index + 9; 7376 7377 -- Otherwise copy the character 7378 7379 else 7380 Res (Res_Index) := Msg (Msg_Index); 7381 Msg_Index := Msg_Index + 1; 7382 Res_Index := Res_Index + 1; 7383 end if; 7384 end loop; 7385 7386 return Res (Res'First .. Res_Index - 1); 7387 end Fix_Msg; 7388 7389 ----------------------- 7390 -- Gather_Components -- 7391 ----------------------- 7392 7393 procedure Gather_Components 7394 (Typ : Entity_Id; 7395 Comp_List : Node_Id; 7396 Governed_By : List_Id; 7397 Into : Elist_Id; 7398 Report_Errors : out Boolean) 7399 is 7400 Assoc : Node_Id; 7401 Variant : Node_Id; 7402 Discrete_Choice : Node_Id; 7403 Comp_Item : Node_Id; 7404 7405 Discrim : Entity_Id; 7406 Discrim_Name : Node_Id; 7407 Discrim_Value : Node_Id; 7408 7409 begin 7410 Report_Errors := False; 7411 7412 if No (Comp_List) or else Null_Present (Comp_List) then 7413 return; 7414 7415 elsif Present (Component_Items (Comp_List)) then 7416 Comp_Item := First (Component_Items (Comp_List)); 7417 7418 else 7419 Comp_Item := Empty; 7420 end if; 7421 7422 while Present (Comp_Item) loop 7423 7424 -- Skip the tag of a tagged record, the interface tags, as well 7425 -- as all items that are not user components (anonymous types, 7426 -- rep clauses, Parent field, controller field). 7427 7428 if Nkind (Comp_Item) = N_Component_Declaration then 7429 declare 7430 Comp : constant Entity_Id := Defining_Identifier (Comp_Item); 7431 begin 7432 if not Is_Tag (Comp) and then Chars (Comp) /= Name_uParent then 7433 Append_Elmt (Comp, Into); 7434 end if; 7435 end; 7436 end if; 7437 7438 Next (Comp_Item); 7439 end loop; 7440 7441 if No (Variant_Part (Comp_List)) then 7442 return; 7443 else 7444 Discrim_Name := Name (Variant_Part (Comp_List)); 7445 Variant := First_Non_Pragma (Variants (Variant_Part (Comp_List))); 7446 end if; 7447 7448 -- Look for the discriminant that governs this variant part. 7449 -- The discriminant *must* be in the Governed_By List 7450 7451 Assoc := First (Governed_By); 7452 Find_Constraint : loop 7453 Discrim := First (Choices (Assoc)); 7454 exit Find_Constraint when Chars (Discrim_Name) = Chars (Discrim) 7455 or else (Present (Corresponding_Discriminant (Entity (Discrim))) 7456 and then 7457 Chars (Corresponding_Discriminant (Entity (Discrim))) = 7458 Chars (Discrim_Name)) 7459 or else Chars (Original_Record_Component (Entity (Discrim))) 7460 = Chars (Discrim_Name); 7461 7462 if No (Next (Assoc)) then 7463 if not Is_Constrained (Typ) 7464 and then Is_Derived_Type (Typ) 7465 and then Present (Stored_Constraint (Typ)) 7466 then 7467 -- If the type is a tagged type with inherited discriminants, 7468 -- use the stored constraint on the parent in order to find 7469 -- the values of discriminants that are otherwise hidden by an 7470 -- explicit constraint. Renamed discriminants are handled in 7471 -- the code above. 7472 7473 -- If several parent discriminants are renamed by a single 7474 -- discriminant of the derived type, the call to obtain the 7475 -- Corresponding_Discriminant field only retrieves the last 7476 -- of them. We recover the constraint on the others from the 7477 -- Stored_Constraint as well. 7478 7479 declare 7480 D : Entity_Id; 7481 C : Elmt_Id; 7482 7483 begin 7484 D := First_Discriminant (Etype (Typ)); 7485 C := First_Elmt (Stored_Constraint (Typ)); 7486 while Present (D) and then Present (C) loop 7487 if Chars (Discrim_Name) = Chars (D) then 7488 if Is_Entity_Name (Node (C)) 7489 and then Entity (Node (C)) = Entity (Discrim) 7490 then 7491 -- D is renamed by Discrim, whose value is given in 7492 -- Assoc. 7493 7494 null; 7495 7496 else 7497 Assoc := 7498 Make_Component_Association (Sloc (Typ), 7499 New_List 7500 (New_Occurrence_Of (D, Sloc (Typ))), 7501 Duplicate_Subexpr_No_Checks (Node (C))); 7502 end if; 7503 exit Find_Constraint; 7504 end if; 7505 7506 Next_Discriminant (D); 7507 Next_Elmt (C); 7508 end loop; 7509 end; 7510 end if; 7511 end if; 7512 7513 if No (Next (Assoc)) then 7514 Error_Msg_NE (" missing value for discriminant&", 7515 First (Governed_By), Discrim_Name); 7516 Report_Errors := True; 7517 return; 7518 end if; 7519 7520 Next (Assoc); 7521 end loop Find_Constraint; 7522 7523 Discrim_Value := Expression (Assoc); 7524 7525 if not Is_OK_Static_Expression (Discrim_Value) then 7526 7527 -- If the variant part is governed by a discriminant of the type 7528 -- this is an error. If the variant part and the discriminant are 7529 -- inherited from an ancestor this is legal (AI05-120) unless the 7530 -- components are being gathered for an aggregate, in which case 7531 -- the caller must check Report_Errors. 7532 7533 if Scope (Original_Record_Component 7534 ((Entity (First (Choices (Assoc)))))) = Typ 7535 then 7536 Error_Msg_FE 7537 ("value for discriminant & must be static!", 7538 Discrim_Value, Discrim); 7539 Why_Not_Static (Discrim_Value); 7540 end if; 7541 7542 Report_Errors := True; 7543 return; 7544 end if; 7545 7546 Search_For_Discriminant_Value : declare 7547 Low : Node_Id; 7548 High : Node_Id; 7549 7550 UI_High : Uint; 7551 UI_Low : Uint; 7552 UI_Discrim_Value : constant Uint := Expr_Value (Discrim_Value); 7553 7554 begin 7555 Find_Discrete_Value : while Present (Variant) loop 7556 Discrete_Choice := First (Discrete_Choices (Variant)); 7557 while Present (Discrete_Choice) loop 7558 exit Find_Discrete_Value when 7559 Nkind (Discrete_Choice) = N_Others_Choice; 7560 7561 Get_Index_Bounds (Discrete_Choice, Low, High); 7562 7563 UI_Low := Expr_Value (Low); 7564 UI_High := Expr_Value (High); 7565 7566 exit Find_Discrete_Value when 7567 UI_Low <= UI_Discrim_Value 7568 and then 7569 UI_High >= UI_Discrim_Value; 7570 7571 Next (Discrete_Choice); 7572 end loop; 7573 7574 Next_Non_Pragma (Variant); 7575 end loop Find_Discrete_Value; 7576 end Search_For_Discriminant_Value; 7577 7578 if No (Variant) then 7579 Error_Msg_NE 7580 ("value of discriminant & is out of range", Discrim_Value, Discrim); 7581 Report_Errors := True; 7582 return; 7583 end if; 7584 7585 -- If we have found the corresponding choice, recursively add its 7586 -- components to the Into list. The nested components are part of 7587 -- the same record type. 7588 7589 Gather_Components 7590 (Typ, Component_List (Variant), Governed_By, Into, Report_Errors); 7591 end Gather_Components; 7592 7593 ------------------------ 7594 -- Get_Actual_Subtype -- 7595 ------------------------ 7596 7597 function Get_Actual_Subtype (N : Node_Id) return Entity_Id is 7598 Typ : constant Entity_Id := Etype (N); 7599 Utyp : Entity_Id := Underlying_Type (Typ); 7600 Decl : Node_Id; 7601 Atyp : Entity_Id; 7602 7603 begin 7604 if No (Utyp) then 7605 Utyp := Typ; 7606 end if; 7607 7608 -- If what we have is an identifier that references a subprogram 7609 -- formal, or a variable or constant object, then we get the actual 7610 -- subtype from the referenced entity if one has been built. 7611 7612 if Nkind (N) = N_Identifier 7613 and then 7614 (Is_Formal (Entity (N)) 7615 or else Ekind (Entity (N)) = E_Constant 7616 or else Ekind (Entity (N)) = E_Variable) 7617 and then Present (Actual_Subtype (Entity (N))) 7618 then 7619 return Actual_Subtype (Entity (N)); 7620 7621 -- Actual subtype of unchecked union is always itself. We never need 7622 -- the "real" actual subtype. If we did, we couldn't get it anyway 7623 -- because the discriminant is not available. The restrictions on 7624 -- Unchecked_Union are designed to make sure that this is OK. 7625 7626 elsif Is_Unchecked_Union (Base_Type (Utyp)) then 7627 return Typ; 7628 7629 -- Here for the unconstrained case, we must find actual subtype 7630 -- No actual subtype is available, so we must build it on the fly. 7631 7632 -- Checking the type, not the underlying type, for constrainedness 7633 -- seems to be necessary. Maybe all the tests should be on the type??? 7634 7635 elsif (not Is_Constrained (Typ)) 7636 and then (Is_Array_Type (Utyp) 7637 or else (Is_Record_Type (Utyp) 7638 and then Has_Discriminants (Utyp))) 7639 and then not Has_Unknown_Discriminants (Utyp) 7640 and then not (Ekind (Utyp) = E_String_Literal_Subtype) 7641 then 7642 -- Nothing to do if in spec expression (why not???) 7643 7644 if In_Spec_Expression then 7645 return Typ; 7646 7647 elsif Is_Private_Type (Typ) and then not Has_Discriminants (Typ) then 7648 7649 -- If the type has no discriminants, there is no subtype to 7650 -- build, even if the underlying type is discriminated. 7651 7652 return Typ; 7653 7654 -- Else build the actual subtype 7655 7656 else 7657 Decl := Build_Actual_Subtype (Typ, N); 7658 Atyp := Defining_Identifier (Decl); 7659 7660 -- If Build_Actual_Subtype generated a new declaration then use it 7661 7662 if Atyp /= Typ then 7663 7664 -- The actual subtype is an Itype, so analyze the declaration, 7665 -- but do not attach it to the tree, to get the type defined. 7666 7667 Set_Parent (Decl, N); 7668 Set_Is_Itype (Atyp); 7669 Analyze (Decl, Suppress => All_Checks); 7670 Set_Associated_Node_For_Itype (Atyp, N); 7671 Set_Has_Delayed_Freeze (Atyp, False); 7672 7673 -- We need to freeze the actual subtype immediately. This is 7674 -- needed, because otherwise this Itype will not get frozen 7675 -- at all, and it is always safe to freeze on creation because 7676 -- any associated types must be frozen at this point. 7677 7678 Freeze_Itype (Atyp, N); 7679 return Atyp; 7680 7681 -- Otherwise we did not build a declaration, so return original 7682 7683 else 7684 return Typ; 7685 end if; 7686 end if; 7687 7688 -- For all remaining cases, the actual subtype is the same as 7689 -- the nominal type. 7690 7691 else 7692 return Typ; 7693 end if; 7694 end Get_Actual_Subtype; 7695 7696 ------------------------------------- 7697 -- Get_Actual_Subtype_If_Available -- 7698 ------------------------------------- 7699 7700 function Get_Actual_Subtype_If_Available (N : Node_Id) return Entity_Id is 7701 Typ : constant Entity_Id := Etype (N); 7702 7703 begin 7704 -- If what we have is an identifier that references a subprogram 7705 -- formal, or a variable or constant object, then we get the actual 7706 -- subtype from the referenced entity if one has been built. 7707 7708 if Nkind (N) = N_Identifier 7709 and then 7710 (Is_Formal (Entity (N)) 7711 or else Ekind (Entity (N)) = E_Constant 7712 or else Ekind (Entity (N)) = E_Variable) 7713 and then Present (Actual_Subtype (Entity (N))) 7714 then 7715 return Actual_Subtype (Entity (N)); 7716 7717 -- Otherwise the Etype of N is returned unchanged 7718 7719 else 7720 return Typ; 7721 end if; 7722 end Get_Actual_Subtype_If_Available; 7723 7724 ------------------------ 7725 -- Get_Body_From_Stub -- 7726 ------------------------ 7727 7728 function Get_Body_From_Stub (N : Node_Id) return Node_Id is 7729 begin 7730 return Proper_Body (Unit (Library_Unit (N))); 7731 end Get_Body_From_Stub; 7732 7733 --------------------- 7734 -- Get_Cursor_Type -- 7735 --------------------- 7736 7737 function Get_Cursor_Type 7738 (Aspect : Node_Id; 7739 Typ : Entity_Id) return Entity_Id 7740 is 7741 Assoc : Node_Id; 7742 Func : Entity_Id; 7743 First_Op : Entity_Id; 7744 Cursor : Entity_Id; 7745 7746 begin 7747 -- If error already detected, return 7748 7749 if Error_Posted (Aspect) then 7750 return Any_Type; 7751 end if; 7752 7753 -- The cursor type for an Iterable aspect is the return type of a 7754 -- non-overloaded First primitive operation. Locate association for 7755 -- First. 7756 7757 Assoc := First (Component_Associations (Expression (Aspect))); 7758 First_Op := Any_Id; 7759 while Present (Assoc) loop 7760 if Chars (First (Choices (Assoc))) = Name_First then 7761 First_Op := Expression (Assoc); 7762 exit; 7763 end if; 7764 7765 Next (Assoc); 7766 end loop; 7767 7768 if First_Op = Any_Id then 7769 Error_Msg_N ("aspect Iterable must specify First operation", Aspect); 7770 return Any_Type; 7771 end if; 7772 7773 Cursor := Any_Type; 7774 7775 -- Locate function with desired name and profile in scope of type 7776 -- In the rare case where the type is an integer type, a base type 7777 -- is created for it, check that the base type of the first formal 7778 -- of First matches the base type of the domain. 7779 7780 Func := First_Entity (Scope (Typ)); 7781 while Present (Func) loop 7782 if Chars (Func) = Chars (First_Op) 7783 and then Ekind (Func) = E_Function 7784 and then Present (First_Formal (Func)) 7785 and then Base_Type (Etype (First_Formal (Func))) = Base_Type (Typ) 7786 and then No (Next_Formal (First_Formal (Func))) 7787 then 7788 if Cursor /= Any_Type then 7789 Error_Msg_N 7790 ("Operation First for iterable type must be unique", Aspect); 7791 return Any_Type; 7792 else 7793 Cursor := Etype (Func); 7794 end if; 7795 end if; 7796 7797 Next_Entity (Func); 7798 end loop; 7799 7800 -- If not found, no way to resolve remaining primitives. 7801 7802 if Cursor = Any_Type then 7803 Error_Msg_N 7804 ("No legal primitive operation First for Iterable type", Aspect); 7805 end if; 7806 7807 return Cursor; 7808 end Get_Cursor_Type; 7809 7810 function Get_Cursor_Type (Typ : Entity_Id) return Entity_Id is 7811 begin 7812 return Etype (Get_Iterable_Type_Primitive (Typ, Name_First)); 7813 end Get_Cursor_Type; 7814 7815 ------------------------------- 7816 -- Get_Default_External_Name -- 7817 ------------------------------- 7818 7819 function Get_Default_External_Name (E : Node_Or_Entity_Id) return Node_Id is 7820 begin 7821 Get_Decoded_Name_String (Chars (E)); 7822 7823 if Opt.External_Name_Imp_Casing = Uppercase then 7824 Set_Casing (All_Upper_Case); 7825 else 7826 Set_Casing (All_Lower_Case); 7827 end if; 7828 7829 return 7830 Make_String_Literal (Sloc (E), 7831 Strval => String_From_Name_Buffer); 7832 end Get_Default_External_Name; 7833 7834 -------------------------- 7835 -- Get_Enclosing_Object -- 7836 -------------------------- 7837 7838 function Get_Enclosing_Object (N : Node_Id) return Entity_Id is 7839 begin 7840 if Is_Entity_Name (N) then 7841 return Entity (N); 7842 else 7843 case Nkind (N) is 7844 when N_Indexed_Component | 7845 N_Slice | 7846 N_Selected_Component => 7847 7848 -- If not generating code, a dereference may be left implicit. 7849 -- In thoses cases, return Empty. 7850 7851 if Is_Access_Type (Etype (Prefix (N))) then 7852 return Empty; 7853 else 7854 return Get_Enclosing_Object (Prefix (N)); 7855 end if; 7856 7857 when N_Type_Conversion => 7858 return Get_Enclosing_Object (Expression (N)); 7859 7860 when others => 7861 return Empty; 7862 end case; 7863 end if; 7864 end Get_Enclosing_Object; 7865 7866 --------------------------- 7867 -- Get_Enum_Lit_From_Pos -- 7868 --------------------------- 7869 7870 function Get_Enum_Lit_From_Pos 7871 (T : Entity_Id; 7872 Pos : Uint; 7873 Loc : Source_Ptr) return Node_Id 7874 is 7875 Btyp : Entity_Id := Base_Type (T); 7876 Lit : Node_Id; 7877 7878 begin 7879 -- In the case where the literal is of type Character, Wide_Character 7880 -- or Wide_Wide_Character or of a type derived from them, there needs 7881 -- to be some special handling since there is no explicit chain of 7882 -- literals to search. Instead, an N_Character_Literal node is created 7883 -- with the appropriate Char_Code and Chars fields. 7884 7885 if Is_Standard_Character_Type (T) then 7886 Set_Character_Literal_Name (UI_To_CC (Pos)); 7887 return 7888 Make_Character_Literal (Loc, 7889 Chars => Name_Find, 7890 Char_Literal_Value => Pos); 7891 7892 -- For all other cases, we have a complete table of literals, and 7893 -- we simply iterate through the chain of literal until the one 7894 -- with the desired position value is found. 7895 7896 else 7897 if Is_Private_Type (Btyp) and then Present (Full_View (Btyp)) then 7898 Btyp := Full_View (Btyp); 7899 end if; 7900 7901 Lit := First_Literal (Btyp); 7902 for J in 1 .. UI_To_Int (Pos) loop 7903 Next_Literal (Lit); 7904 end loop; 7905 7906 return New_Occurrence_Of (Lit, Loc); 7907 end if; 7908 end Get_Enum_Lit_From_Pos; 7909 7910 ------------------------ 7911 -- Get_Generic_Entity -- 7912 ------------------------ 7913 7914 function Get_Generic_Entity (N : Node_Id) return Entity_Id is 7915 Ent : constant Entity_Id := Entity (Name (N)); 7916 begin 7917 if Present (Renamed_Object (Ent)) then 7918 return Renamed_Object (Ent); 7919 else 7920 return Ent; 7921 end if; 7922 end Get_Generic_Entity; 7923 7924 ------------------------------------- 7925 -- Get_Incomplete_View_Of_Ancestor -- 7926 ------------------------------------- 7927 7928 function Get_Incomplete_View_Of_Ancestor (E : Entity_Id) return Entity_Id is 7929 Cur_Unit : constant Entity_Id := Cunit_Entity (Current_Sem_Unit); 7930 Par_Scope : Entity_Id; 7931 Par_Type : Entity_Id; 7932 7933 begin 7934 -- The incomplete view of an ancestor is only relevant for private 7935 -- derived types in child units. 7936 7937 if not Is_Derived_Type (E) 7938 or else not Is_Child_Unit (Cur_Unit) 7939 then 7940 return Empty; 7941 7942 else 7943 Par_Scope := Scope (Cur_Unit); 7944 if No (Par_Scope) then 7945 return Empty; 7946 end if; 7947 7948 Par_Type := Etype (Base_Type (E)); 7949 7950 -- Traverse list of ancestor types until we find one declared in 7951 -- a parent or grandparent unit (two levels seem sufficient). 7952 7953 while Present (Par_Type) loop 7954 if Scope (Par_Type) = Par_Scope 7955 or else Scope (Par_Type) = Scope (Par_Scope) 7956 then 7957 return Par_Type; 7958 7959 elsif not Is_Derived_Type (Par_Type) then 7960 return Empty; 7961 7962 else 7963 Par_Type := Etype (Base_Type (Par_Type)); 7964 end if; 7965 end loop; 7966 7967 -- If none found, there is no relevant ancestor type. 7968 7969 return Empty; 7970 end if; 7971 end Get_Incomplete_View_Of_Ancestor; 7972 7973 ---------------------- 7974 -- Get_Index_Bounds -- 7975 ---------------------- 7976 7977 procedure Get_Index_Bounds (N : Node_Id; L, H : out Node_Id) is 7978 Kind : constant Node_Kind := Nkind (N); 7979 R : Node_Id; 7980 7981 begin 7982 if Kind = N_Range then 7983 L := Low_Bound (N); 7984 H := High_Bound (N); 7985 7986 elsif Kind = N_Subtype_Indication then 7987 R := Range_Expression (Constraint (N)); 7988 7989 if R = Error then 7990 L := Error; 7991 H := Error; 7992 return; 7993 7994 else 7995 L := Low_Bound (Range_Expression (Constraint (N))); 7996 H := High_Bound (Range_Expression (Constraint (N))); 7997 end if; 7998 7999 elsif Is_Entity_Name (N) and then Is_Type (Entity (N)) then 8000 if Error_Posted (Scalar_Range (Entity (N))) then 8001 L := Error; 8002 H := Error; 8003 8004 elsif Nkind (Scalar_Range (Entity (N))) = N_Subtype_Indication then 8005 Get_Index_Bounds (Scalar_Range (Entity (N)), L, H); 8006 8007 else 8008 L := Low_Bound (Scalar_Range (Entity (N))); 8009 H := High_Bound (Scalar_Range (Entity (N))); 8010 end if; 8011 8012 else 8013 -- N is an expression, indicating a range with one value 8014 8015 L := N; 8016 H := N; 8017 end if; 8018 end Get_Index_Bounds; 8019 8020 --------------------------------- 8021 -- Get_Iterable_Type_Primitive -- 8022 --------------------------------- 8023 8024 function Get_Iterable_Type_Primitive 8025 (Typ : Entity_Id; 8026 Nam : Name_Id) return Entity_Id 8027 is 8028 Funcs : constant Node_Id := Find_Value_Of_Aspect (Typ, Aspect_Iterable); 8029 Assoc : Node_Id; 8030 8031 begin 8032 if No (Funcs) then 8033 return Empty; 8034 8035 else 8036 Assoc := First (Component_Associations (Funcs)); 8037 while Present (Assoc) loop 8038 if Chars (First (Choices (Assoc))) = Nam then 8039 return Entity (Expression (Assoc)); 8040 end if; 8041 8042 Assoc := Next (Assoc); 8043 end loop; 8044 8045 return Empty; 8046 end if; 8047 end Get_Iterable_Type_Primitive; 8048 8049 ---------------------------------- 8050 -- Get_Library_Unit_Name_string -- 8051 ---------------------------------- 8052 8053 procedure Get_Library_Unit_Name_String (Decl_Node : Node_Id) is 8054 Unit_Name_Id : constant Unit_Name_Type := Get_Unit_Name (Decl_Node); 8055 8056 begin 8057 Get_Unit_Name_String (Unit_Name_Id); 8058 8059 -- Remove seven last character (" (spec)" or " (body)") 8060 8061 Name_Len := Name_Len - 7; 8062 pragma Assert (Name_Buffer (Name_Len + 1) = ' '); 8063 end Get_Library_Unit_Name_String; 8064 8065 ------------------------ 8066 -- Get_Name_Entity_Id -- 8067 ------------------------ 8068 8069 function Get_Name_Entity_Id (Id : Name_Id) return Entity_Id is 8070 begin 8071 return Entity_Id (Get_Name_Table_Int (Id)); 8072 end Get_Name_Entity_Id; 8073 8074 ------------------------------ 8075 -- Get_Name_From_CTC_Pragma -- 8076 ------------------------------ 8077 8078 function Get_Name_From_CTC_Pragma (N : Node_Id) return String_Id is 8079 Arg : constant Node_Id := 8080 Get_Pragma_Arg (First (Pragma_Argument_Associations (N))); 8081 begin 8082 return Strval (Expr_Value_S (Arg)); 8083 end Get_Name_From_CTC_Pragma; 8084 8085 ----------------------- 8086 -- Get_Parent_Entity -- 8087 ----------------------- 8088 8089 function Get_Parent_Entity (Unit : Node_Id) return Entity_Id is 8090 begin 8091 if Nkind (Unit) = N_Package_Body 8092 and then Nkind (Original_Node (Unit)) = N_Package_Instantiation 8093 then 8094 return Defining_Entity 8095 (Specification (Instance_Spec (Original_Node (Unit)))); 8096 elsif Nkind (Unit) = N_Package_Instantiation then 8097 return Defining_Entity (Specification (Instance_Spec (Unit))); 8098 else 8099 return Defining_Entity (Unit); 8100 end if; 8101 end Get_Parent_Entity; 8102 8103 ------------------- 8104 -- Get_Pragma_Id -- 8105 ------------------- 8106 8107 function Get_Pragma_Id (N : Node_Id) return Pragma_Id is 8108 begin 8109 return Get_Pragma_Id (Pragma_Name (N)); 8110 end Get_Pragma_Id; 8111 8112 ----------------------- 8113 -- Get_Reason_String -- 8114 ----------------------- 8115 8116 procedure Get_Reason_String (N : Node_Id) is 8117 begin 8118 if Nkind (N) = N_String_Literal then 8119 Store_String_Chars (Strval (N)); 8120 8121 elsif Nkind (N) = N_Op_Concat then 8122 Get_Reason_String (Left_Opnd (N)); 8123 Get_Reason_String (Right_Opnd (N)); 8124 8125 -- If not of required form, error 8126 8127 else 8128 Error_Msg_N 8129 ("Reason for pragma Warnings has wrong form", N); 8130 Error_Msg_N 8131 ("\must be string literal or concatenation of string literals", N); 8132 return; 8133 end if; 8134 end Get_Reason_String; 8135 8136 -------------------------------- 8137 -- Get_Reference_Discriminant -- 8138 -------------------------------- 8139 8140 function Get_Reference_Discriminant (Typ : Entity_Id) return Entity_Id is 8141 D : Entity_Id; 8142 8143 begin 8144 D := First_Discriminant (Typ); 8145 while Present (D) loop 8146 if Has_Implicit_Dereference (D) then 8147 return D; 8148 end if; 8149 Next_Discriminant (D); 8150 end loop; 8151 8152 return Empty; 8153 end Get_Reference_Discriminant; 8154 8155 --------------------------- 8156 -- Get_Referenced_Object -- 8157 --------------------------- 8158 8159 function Get_Referenced_Object (N : Node_Id) return Node_Id is 8160 R : Node_Id; 8161 8162 begin 8163 R := N; 8164 while Is_Entity_Name (R) 8165 and then Present (Renamed_Object (Entity (R))) 8166 loop 8167 R := Renamed_Object (Entity (R)); 8168 end loop; 8169 8170 return R; 8171 end Get_Referenced_Object; 8172 8173 ------------------------ 8174 -- Get_Renamed_Entity -- 8175 ------------------------ 8176 8177 function Get_Renamed_Entity (E : Entity_Id) return Entity_Id is 8178 R : Entity_Id; 8179 8180 begin 8181 R := E; 8182 while Present (Renamed_Entity (R)) loop 8183 R := Renamed_Entity (R); 8184 end loop; 8185 8186 return R; 8187 end Get_Renamed_Entity; 8188 8189 ----------------------- 8190 -- Get_Return_Object -- 8191 ----------------------- 8192 8193 function Get_Return_Object (N : Node_Id) return Entity_Id is 8194 Decl : Node_Id; 8195 8196 begin 8197 Decl := First (Return_Object_Declarations (N)); 8198 while Present (Decl) loop 8199 exit when Nkind (Decl) = N_Object_Declaration 8200 and then Is_Return_Object (Defining_Identifier (Decl)); 8201 Next (Decl); 8202 end loop; 8203 8204 pragma Assert (Present (Decl)); 8205 return Defining_Identifier (Decl); 8206 end Get_Return_Object; 8207 8208 --------------------------- 8209 -- Get_Subprogram_Entity -- 8210 --------------------------- 8211 8212 function Get_Subprogram_Entity (Nod : Node_Id) return Entity_Id is 8213 Subp : Node_Id; 8214 Subp_Id : Entity_Id; 8215 8216 begin 8217 if Nkind (Nod) = N_Accept_Statement then 8218 Subp := Entry_Direct_Name (Nod); 8219 8220 elsif Nkind (Nod) = N_Slice then 8221 Subp := Prefix (Nod); 8222 8223 else 8224 Subp := Name (Nod); 8225 end if; 8226 8227 -- Strip the subprogram call 8228 8229 loop 8230 if Nkind_In (Subp, N_Explicit_Dereference, 8231 N_Indexed_Component, 8232 N_Selected_Component) 8233 then 8234 Subp := Prefix (Subp); 8235 8236 elsif Nkind_In (Subp, N_Type_Conversion, 8237 N_Unchecked_Type_Conversion) 8238 then 8239 Subp := Expression (Subp); 8240 8241 else 8242 exit; 8243 end if; 8244 end loop; 8245 8246 -- Extract the entity of the subprogram call 8247 8248 if Is_Entity_Name (Subp) then 8249 Subp_Id := Entity (Subp); 8250 8251 if Ekind (Subp_Id) = E_Access_Subprogram_Type then 8252 Subp_Id := Directly_Designated_Type (Subp_Id); 8253 end if; 8254 8255 if Is_Subprogram (Subp_Id) then 8256 return Subp_Id; 8257 else 8258 return Empty; 8259 end if; 8260 8261 -- The search did not find a construct that denotes a subprogram 8262 8263 else 8264 return Empty; 8265 end if; 8266 end Get_Subprogram_Entity; 8267 8268 ----------------------------- 8269 -- Get_Task_Body_Procedure -- 8270 ----------------------------- 8271 8272 function Get_Task_Body_Procedure (E : Entity_Id) return Node_Id is 8273 begin 8274 -- Note: A task type may be the completion of a private type with 8275 -- discriminants. When performing elaboration checks on a task 8276 -- declaration, the current view of the type may be the private one, 8277 -- and the procedure that holds the body of the task is held in its 8278 -- underlying type. 8279 8280 -- This is an odd function, why not have Task_Body_Procedure do 8281 -- the following digging??? 8282 8283 return Task_Body_Procedure (Underlying_Type (Root_Type (E))); 8284 end Get_Task_Body_Procedure; 8285 8286 ------------------------- 8287 -- Get_User_Defined_Eq -- 8288 ------------------------- 8289 8290 function Get_User_Defined_Eq (E : Entity_Id) return Entity_Id is 8291 Prim : Elmt_Id; 8292 Op : Entity_Id; 8293 8294 begin 8295 Prim := First_Elmt (Collect_Primitive_Operations (E)); 8296 while Present (Prim) loop 8297 Op := Node (Prim); 8298 8299 if Chars (Op) = Name_Op_Eq 8300 and then Etype (Op) = Standard_Boolean 8301 and then Etype (First_Formal (Op)) = E 8302 and then Etype (Next_Formal (First_Formal (Op))) = E 8303 then 8304 return Op; 8305 end if; 8306 8307 Next_Elmt (Prim); 8308 end loop; 8309 8310 return Empty; 8311 end Get_User_Defined_Eq; 8312 8313 ----------------------- 8314 -- Has_Access_Values -- 8315 ----------------------- 8316 8317 function Has_Access_Values (T : Entity_Id) return Boolean is 8318 Typ : constant Entity_Id := Underlying_Type (T); 8319 8320 begin 8321 -- Case of a private type which is not completed yet. This can only 8322 -- happen in the case of a generic format type appearing directly, or 8323 -- as a component of the type to which this function is being applied 8324 -- at the top level. Return False in this case, since we certainly do 8325 -- not know that the type contains access types. 8326 8327 if No (Typ) then 8328 return False; 8329 8330 elsif Is_Access_Type (Typ) then 8331 return True; 8332 8333 elsif Is_Array_Type (Typ) then 8334 return Has_Access_Values (Component_Type (Typ)); 8335 8336 elsif Is_Record_Type (Typ) then 8337 declare 8338 Comp : Entity_Id; 8339 8340 begin 8341 -- Loop to Check components 8342 8343 Comp := First_Component_Or_Discriminant (Typ); 8344 while Present (Comp) loop 8345 8346 -- Check for access component, tag field does not count, even 8347 -- though it is implemented internally using an access type. 8348 8349 if Has_Access_Values (Etype (Comp)) 8350 and then Chars (Comp) /= Name_uTag 8351 then 8352 return True; 8353 end if; 8354 8355 Next_Component_Or_Discriminant (Comp); 8356 end loop; 8357 end; 8358 8359 return False; 8360 8361 else 8362 return False; 8363 end if; 8364 end Has_Access_Values; 8365 8366 ------------------------------ 8367 -- Has_Compatible_Alignment -- 8368 ------------------------------ 8369 8370 function Has_Compatible_Alignment 8371 (Obj : Entity_Id; 8372 Expr : Node_Id; 8373 Layout_Done : Boolean) return Alignment_Result 8374 is 8375 function Has_Compatible_Alignment_Internal 8376 (Obj : Entity_Id; 8377 Expr : Node_Id; 8378 Layout_Done : Boolean; 8379 Default : Alignment_Result) return Alignment_Result; 8380 -- This is the internal recursive function that actually does the work. 8381 -- There is one additional parameter, which says what the result should 8382 -- be if no alignment information is found, and there is no definite 8383 -- indication of compatible alignments. At the outer level, this is set 8384 -- to Unknown, but for internal recursive calls in the case where types 8385 -- are known to be correct, it is set to Known_Compatible. 8386 8387 --------------------------------------- 8388 -- Has_Compatible_Alignment_Internal -- 8389 --------------------------------------- 8390 8391 function Has_Compatible_Alignment_Internal 8392 (Obj : Entity_Id; 8393 Expr : Node_Id; 8394 Layout_Done : Boolean; 8395 Default : Alignment_Result) return Alignment_Result 8396 is 8397 Result : Alignment_Result := Known_Compatible; 8398 -- Holds the current status of the result. Note that once a value of 8399 -- Known_Incompatible is set, it is sticky and does not get changed 8400 -- to Unknown (the value in Result only gets worse as we go along, 8401 -- never better). 8402 8403 Offs : Uint := No_Uint; 8404 -- Set to a factor of the offset from the base object when Expr is a 8405 -- selected or indexed component, based on Component_Bit_Offset and 8406 -- Component_Size respectively. A negative value is used to represent 8407 -- a value which is not known at compile time. 8408 8409 procedure Check_Prefix; 8410 -- Checks the prefix recursively in the case where the expression 8411 -- is an indexed or selected component. 8412 8413 procedure Set_Result (R : Alignment_Result); 8414 -- If R represents a worse outcome (unknown instead of known 8415 -- compatible, or known incompatible), then set Result to R. 8416 8417 ------------------ 8418 -- Check_Prefix -- 8419 ------------------ 8420 8421 procedure Check_Prefix is 8422 begin 8423 -- The subtlety here is that in doing a recursive call to check 8424 -- the prefix, we have to decide what to do in the case where we 8425 -- don't find any specific indication of an alignment problem. 8426 8427 -- At the outer level, we normally set Unknown as the result in 8428 -- this case, since we can only set Known_Compatible if we really 8429 -- know that the alignment value is OK, but for the recursive 8430 -- call, in the case where the types match, and we have not 8431 -- specified a peculiar alignment for the object, we are only 8432 -- concerned about suspicious rep clauses, the default case does 8433 -- not affect us, since the compiler will, in the absence of such 8434 -- rep clauses, ensure that the alignment is correct. 8435 8436 if Default = Known_Compatible 8437 or else 8438 (Etype (Obj) = Etype (Expr) 8439 and then (Unknown_Alignment (Obj) 8440 or else 8441 Alignment (Obj) = Alignment (Etype (Obj)))) 8442 then 8443 Set_Result 8444 (Has_Compatible_Alignment_Internal 8445 (Obj, Prefix (Expr), Layout_Done, Known_Compatible)); 8446 8447 -- In all other cases, we need a full check on the prefix 8448 8449 else 8450 Set_Result 8451 (Has_Compatible_Alignment_Internal 8452 (Obj, Prefix (Expr), Layout_Done, Unknown)); 8453 end if; 8454 end Check_Prefix; 8455 8456 ---------------- 8457 -- Set_Result -- 8458 ---------------- 8459 8460 procedure Set_Result (R : Alignment_Result) is 8461 begin 8462 if R > Result then 8463 Result := R; 8464 end if; 8465 end Set_Result; 8466 8467 -- Start of processing for Has_Compatible_Alignment_Internal 8468 8469 begin 8470 -- If Expr is a selected component, we must make sure there is no 8471 -- potentially troublesome component clause and that the record is 8472 -- not packed if the layout is not done. 8473 8474 if Nkind (Expr) = N_Selected_Component then 8475 8476 -- Packing generates unknown alignment if layout is not done 8477 8478 if Is_Packed (Etype (Prefix (Expr))) and then not Layout_Done then 8479 Set_Result (Unknown); 8480 end if; 8481 8482 -- Check prefix and component offset 8483 8484 Check_Prefix; 8485 Offs := Component_Bit_Offset (Entity (Selector_Name (Expr))); 8486 8487 -- If Expr is an indexed component, we must make sure there is no 8488 -- potentially troublesome Component_Size clause and that the array 8489 -- is not bit-packed if the layout is not done. 8490 8491 elsif Nkind (Expr) = N_Indexed_Component then 8492 declare 8493 Typ : constant Entity_Id := Etype (Prefix (Expr)); 8494 Ind : constant Node_Id := First_Index (Typ); 8495 8496 begin 8497 -- Packing generates unknown alignment if layout is not done 8498 8499 if Is_Bit_Packed_Array (Typ) and then not Layout_Done then 8500 Set_Result (Unknown); 8501 end if; 8502 8503 -- Check prefix and component offset 8504 8505 Check_Prefix; 8506 Offs := Component_Size (Typ); 8507 8508 -- Small optimization: compute the full offset when possible 8509 8510 if Offs /= No_Uint 8511 and then Offs > Uint_0 8512 and then Present (Ind) 8513 and then Nkind (Ind) = N_Range 8514 and then Compile_Time_Known_Value (Low_Bound (Ind)) 8515 and then Compile_Time_Known_Value (First (Expressions (Expr))) 8516 then 8517 Offs := Offs * (Expr_Value (First (Expressions (Expr))) 8518 - Expr_Value (Low_Bound ((Ind)))); 8519 end if; 8520 end; 8521 end if; 8522 8523 -- If we have a null offset, the result is entirely determined by 8524 -- the base object and has already been computed recursively. 8525 8526 if Offs = Uint_0 then 8527 null; 8528 8529 -- Case where we know the alignment of the object 8530 8531 elsif Known_Alignment (Obj) then 8532 declare 8533 ObjA : constant Uint := Alignment (Obj); 8534 ExpA : Uint := No_Uint; 8535 SizA : Uint := No_Uint; 8536 8537 begin 8538 -- If alignment of Obj is 1, then we are always OK 8539 8540 if ObjA = 1 then 8541 Set_Result (Known_Compatible); 8542 8543 -- Alignment of Obj is greater than 1, so we need to check 8544 8545 else 8546 -- If we have an offset, see if it is compatible 8547 8548 if Offs /= No_Uint and Offs > Uint_0 then 8549 if Offs mod (System_Storage_Unit * ObjA) /= 0 then 8550 Set_Result (Known_Incompatible); 8551 end if; 8552 8553 -- See if Expr is an object with known alignment 8554 8555 elsif Is_Entity_Name (Expr) 8556 and then Known_Alignment (Entity (Expr)) 8557 then 8558 ExpA := Alignment (Entity (Expr)); 8559 8560 -- Otherwise, we can use the alignment of the type of 8561 -- Expr given that we already checked for 8562 -- discombobulating rep clauses for the cases of indexed 8563 -- and selected components above. 8564 8565 elsif Known_Alignment (Etype (Expr)) then 8566 ExpA := Alignment (Etype (Expr)); 8567 8568 -- Otherwise the alignment is unknown 8569 8570 else 8571 Set_Result (Default); 8572 end if; 8573 8574 -- If we got an alignment, see if it is acceptable 8575 8576 if ExpA /= No_Uint and then ExpA < ObjA then 8577 Set_Result (Known_Incompatible); 8578 end if; 8579 8580 -- If Expr is not a piece of a larger object, see if size 8581 -- is given. If so, check that it is not too small for the 8582 -- required alignment. 8583 8584 if Offs /= No_Uint then 8585 null; 8586 8587 -- See if Expr is an object with known size 8588 8589 elsif Is_Entity_Name (Expr) 8590 and then Known_Static_Esize (Entity (Expr)) 8591 then 8592 SizA := Esize (Entity (Expr)); 8593 8594 -- Otherwise, we check the object size of the Expr type 8595 8596 elsif Known_Static_Esize (Etype (Expr)) then 8597 SizA := Esize (Etype (Expr)); 8598 end if; 8599 8600 -- If we got a size, see if it is a multiple of the Obj 8601 -- alignment, if not, then the alignment cannot be 8602 -- acceptable, since the size is always a multiple of the 8603 -- alignment. 8604 8605 if SizA /= No_Uint then 8606 if SizA mod (ObjA * Ttypes.System_Storage_Unit) /= 0 then 8607 Set_Result (Known_Incompatible); 8608 end if; 8609 end if; 8610 end if; 8611 end; 8612 8613 -- If we do not know required alignment, any non-zero offset is a 8614 -- potential problem (but certainly may be OK, so result is unknown). 8615 8616 elsif Offs /= No_Uint then 8617 Set_Result (Unknown); 8618 8619 -- If we can't find the result by direct comparison of alignment 8620 -- values, then there is still one case that we can determine known 8621 -- result, and that is when we can determine that the types are the 8622 -- same, and no alignments are specified. Then we known that the 8623 -- alignments are compatible, even if we don't know the alignment 8624 -- value in the front end. 8625 8626 elsif Etype (Obj) = Etype (Expr) then 8627 8628 -- Types are the same, but we have to check for possible size 8629 -- and alignments on the Expr object that may make the alignment 8630 -- different, even though the types are the same. 8631 8632 if Is_Entity_Name (Expr) then 8633 8634 -- First check alignment of the Expr object. Any alignment less 8635 -- than Maximum_Alignment is worrisome since this is the case 8636 -- where we do not know the alignment of Obj. 8637 8638 if Known_Alignment (Entity (Expr)) 8639 and then UI_To_Int (Alignment (Entity (Expr))) < 8640 Ttypes.Maximum_Alignment 8641 then 8642 Set_Result (Unknown); 8643 8644 -- Now check size of Expr object. Any size that is not an 8645 -- even multiple of Maximum_Alignment is also worrisome 8646 -- since it may cause the alignment of the object to be less 8647 -- than the alignment of the type. 8648 8649 elsif Known_Static_Esize (Entity (Expr)) 8650 and then 8651 (UI_To_Int (Esize (Entity (Expr))) mod 8652 (Ttypes.Maximum_Alignment * Ttypes.System_Storage_Unit)) 8653 /= 0 8654 then 8655 Set_Result (Unknown); 8656 8657 -- Otherwise same type is decisive 8658 8659 else 8660 Set_Result (Known_Compatible); 8661 end if; 8662 end if; 8663 8664 -- Another case to deal with is when there is an explicit size or 8665 -- alignment clause when the types are not the same. If so, then the 8666 -- result is Unknown. We don't need to do this test if the Default is 8667 -- Unknown, since that result will be set in any case. 8668 8669 elsif Default /= Unknown 8670 and then (Has_Size_Clause (Etype (Expr)) 8671 or else 8672 Has_Alignment_Clause (Etype (Expr))) 8673 then 8674 Set_Result (Unknown); 8675 8676 -- If no indication found, set default 8677 8678 else 8679 Set_Result (Default); 8680 end if; 8681 8682 -- Return worst result found 8683 8684 return Result; 8685 end Has_Compatible_Alignment_Internal; 8686 8687 -- Start of processing for Has_Compatible_Alignment 8688 8689 begin 8690 -- If Obj has no specified alignment, then set alignment from the type 8691 -- alignment. Perhaps we should always do this, but for sure we should 8692 -- do it when there is an address clause since we can do more if the 8693 -- alignment is known. 8694 8695 if Unknown_Alignment (Obj) then 8696 Set_Alignment (Obj, Alignment (Etype (Obj))); 8697 end if; 8698 8699 -- Now do the internal call that does all the work 8700 8701 return 8702 Has_Compatible_Alignment_Internal (Obj, Expr, Layout_Done, Unknown); 8703 end Has_Compatible_Alignment; 8704 8705 ---------------------- 8706 -- Has_Declarations -- 8707 ---------------------- 8708 8709 function Has_Declarations (N : Node_Id) return Boolean is 8710 begin 8711 return Nkind_In (Nkind (N), N_Accept_Statement, 8712 N_Block_Statement, 8713 N_Compilation_Unit_Aux, 8714 N_Entry_Body, 8715 N_Package_Body, 8716 N_Protected_Body, 8717 N_Subprogram_Body, 8718 N_Task_Body, 8719 N_Package_Specification); 8720 end Has_Declarations; 8721 8722 --------------------------------- 8723 -- Has_Defaulted_Discriminants -- 8724 --------------------------------- 8725 8726 function Has_Defaulted_Discriminants (Typ : Entity_Id) return Boolean is 8727 begin 8728 return Has_Discriminants (Typ) 8729 and then Present (First_Discriminant (Typ)) 8730 and then Present (Discriminant_Default_Value 8731 (First_Discriminant (Typ))); 8732 end Has_Defaulted_Discriminants; 8733 8734 ------------------- 8735 -- Has_Denormals -- 8736 ------------------- 8737 8738 function Has_Denormals (E : Entity_Id) return Boolean is 8739 begin 8740 return Is_Floating_Point_Type (E) and then Denorm_On_Target; 8741 end Has_Denormals; 8742 8743 ------------------------------------------- 8744 -- Has_Discriminant_Dependent_Constraint -- 8745 ------------------------------------------- 8746 8747 function Has_Discriminant_Dependent_Constraint 8748 (Comp : Entity_Id) return Boolean 8749 is 8750 Comp_Decl : constant Node_Id := Parent (Comp); 8751 Subt_Indic : Node_Id; 8752 Constr : Node_Id; 8753 Assn : Node_Id; 8754 8755 begin 8756 -- Discriminants can't depend on discriminants 8757 8758 if Ekind (Comp) = E_Discriminant then 8759 return False; 8760 8761 else 8762 Subt_Indic := Subtype_Indication (Component_Definition (Comp_Decl)); 8763 8764 if Nkind (Subt_Indic) = N_Subtype_Indication then 8765 Constr := Constraint (Subt_Indic); 8766 8767 if Nkind (Constr) = N_Index_Or_Discriminant_Constraint then 8768 Assn := First (Constraints (Constr)); 8769 while Present (Assn) loop 8770 case Nkind (Assn) is 8771 when N_Subtype_Indication | 8772 N_Range | 8773 N_Identifier 8774 => 8775 if Depends_On_Discriminant (Assn) then 8776 return True; 8777 end if; 8778 8779 when N_Discriminant_Association => 8780 if Depends_On_Discriminant (Expression (Assn)) then 8781 return True; 8782 end if; 8783 8784 when others => 8785 null; 8786 end case; 8787 8788 Next (Assn); 8789 end loop; 8790 end if; 8791 end if; 8792 end if; 8793 8794 return False; 8795 end Has_Discriminant_Dependent_Constraint; 8796 8797 -------------------------------------- 8798 -- Has_Effectively_Volatile_Profile -- 8799 -------------------------------------- 8800 8801 function Has_Effectively_Volatile_Profile 8802 (Subp_Id : Entity_Id) return Boolean 8803 is 8804 Formal : Entity_Id; 8805 8806 begin 8807 -- Inspect the formal parameters looking for an effectively volatile 8808 -- type. 8809 8810 Formal := First_Formal (Subp_Id); 8811 while Present (Formal) loop 8812 if Is_Effectively_Volatile (Etype (Formal)) then 8813 return True; 8814 end if; 8815 8816 Next_Formal (Formal); 8817 end loop; 8818 8819 -- Inspect the return type of functions 8820 8821 if Ekind_In (Subp_Id, E_Function, E_Generic_Function) 8822 and then Is_Effectively_Volatile (Etype (Subp_Id)) 8823 then 8824 return True; 8825 end if; 8826 8827 return False; 8828 end Has_Effectively_Volatile_Profile; 8829 8830 -------------------------- 8831 -- Has_Enabled_Property -- 8832 -------------------------- 8833 8834 function Has_Enabled_Property 8835 (Item_Id : Entity_Id; 8836 Property : Name_Id) return Boolean 8837 is 8838 function State_Has_Enabled_Property return Boolean; 8839 -- Determine whether a state denoted by Item_Id has the property enabled 8840 8841 function Variable_Has_Enabled_Property return Boolean; 8842 -- Determine whether a variable denoted by Item_Id has the property 8843 -- enabled. 8844 8845 -------------------------------- 8846 -- State_Has_Enabled_Property -- 8847 -------------------------------- 8848 8849 function State_Has_Enabled_Property return Boolean is 8850 Decl : constant Node_Id := Parent (Item_Id); 8851 Opt : Node_Id; 8852 Opt_Nam : Node_Id; 8853 Prop : Node_Id; 8854 Prop_Nam : Node_Id; 8855 Props : Node_Id; 8856 8857 begin 8858 -- The declaration of an external abstract state appears as an 8859 -- extension aggregate. If this is not the case, properties can never 8860 -- be set. 8861 8862 if Nkind (Decl) /= N_Extension_Aggregate then 8863 return False; 8864 end if; 8865 8866 -- When External appears as a simple option, it automatically enables 8867 -- all properties. 8868 8869 Opt := First (Expressions (Decl)); 8870 while Present (Opt) loop 8871 if Nkind (Opt) = N_Identifier 8872 and then Chars (Opt) = Name_External 8873 then 8874 return True; 8875 end if; 8876 8877 Next (Opt); 8878 end loop; 8879 8880 -- When External specifies particular properties, inspect those and 8881 -- find the desired one (if any). 8882 8883 Opt := First (Component_Associations (Decl)); 8884 while Present (Opt) loop 8885 Opt_Nam := First (Choices (Opt)); 8886 8887 if Nkind (Opt_Nam) = N_Identifier 8888 and then Chars (Opt_Nam) = Name_External 8889 then 8890 Props := Expression (Opt); 8891 8892 -- Multiple properties appear as an aggregate 8893 8894 if Nkind (Props) = N_Aggregate then 8895 8896 -- Simple property form 8897 8898 Prop := First (Expressions (Props)); 8899 while Present (Prop) loop 8900 if Chars (Prop) = Property then 8901 return True; 8902 end if; 8903 8904 Next (Prop); 8905 end loop; 8906 8907 -- Property with expression form 8908 8909 Prop := First (Component_Associations (Props)); 8910 while Present (Prop) loop 8911 Prop_Nam := First (Choices (Prop)); 8912 8913 -- The property can be represented in two ways: 8914 -- others => <value> 8915 -- <property> => <value> 8916 8917 if Nkind (Prop_Nam) = N_Others_Choice 8918 or else (Nkind (Prop_Nam) = N_Identifier 8919 and then Chars (Prop_Nam) = Property) 8920 then 8921 return Is_True (Expr_Value (Expression (Prop))); 8922 end if; 8923 8924 Next (Prop); 8925 end loop; 8926 8927 -- Single property 8928 8929 else 8930 return Chars (Props) = Property; 8931 end if; 8932 end if; 8933 8934 Next (Opt); 8935 end loop; 8936 8937 return False; 8938 end State_Has_Enabled_Property; 8939 8940 ----------------------------------- 8941 -- Variable_Has_Enabled_Property -- 8942 ----------------------------------- 8943 8944 function Variable_Has_Enabled_Property return Boolean is 8945 function Is_Enabled (Prag : Node_Id) return Boolean; 8946 -- Determine whether property pragma Prag (if present) denotes an 8947 -- enabled property. 8948 8949 ---------------- 8950 -- Is_Enabled -- 8951 ---------------- 8952 8953 function Is_Enabled (Prag : Node_Id) return Boolean is 8954 Arg1 : Node_Id; 8955 8956 begin 8957 if Present (Prag) then 8958 Arg1 := First (Pragma_Argument_Associations (Prag)); 8959 8960 -- The pragma has an optional Boolean expression, the related 8961 -- property is enabled only when the expression evaluates to 8962 -- True. 8963 8964 if Present (Arg1) then 8965 return Is_True (Expr_Value (Get_Pragma_Arg (Arg1))); 8966 8967 -- Otherwise the lack of expression enables the property by 8968 -- default. 8969 8970 else 8971 return True; 8972 end if; 8973 8974 -- The property was never set in the first place 8975 8976 else 8977 return False; 8978 end if; 8979 end Is_Enabled; 8980 8981 -- Local variables 8982 8983 AR : constant Node_Id := 8984 Get_Pragma (Item_Id, Pragma_Async_Readers); 8985 AW : constant Node_Id := 8986 Get_Pragma (Item_Id, Pragma_Async_Writers); 8987 ER : constant Node_Id := 8988 Get_Pragma (Item_Id, Pragma_Effective_Reads); 8989 EW : constant Node_Id := 8990 Get_Pragma (Item_Id, Pragma_Effective_Writes); 8991 8992 -- Start of processing for Variable_Has_Enabled_Property 8993 8994 begin 8995 -- A non-effectively volatile object can never possess external 8996 -- properties. 8997 8998 if not Is_Effectively_Volatile (Item_Id) then 8999 return False; 9000 9001 -- External properties related to variables come in two flavors - 9002 -- explicit and implicit. The explicit case is characterized by the 9003 -- presence of a property pragma with an optional Boolean flag. The 9004 -- property is enabled when the flag evaluates to True or the flag is 9005 -- missing altogether. 9006 9007 elsif Property = Name_Async_Readers and then Is_Enabled (AR) then 9008 return True; 9009 9010 elsif Property = Name_Async_Writers and then Is_Enabled (AW) then 9011 return True; 9012 9013 elsif Property = Name_Effective_Reads and then Is_Enabled (ER) then 9014 return True; 9015 9016 elsif Property = Name_Effective_Writes and then Is_Enabled (EW) then 9017 return True; 9018 9019 -- The implicit case lacks all property pragmas 9020 9021 elsif No (AR) and then No (AW) and then No (ER) and then No (EW) then 9022 return True; 9023 9024 else 9025 return False; 9026 end if; 9027 end Variable_Has_Enabled_Property; 9028 9029 -- Start of processing for Has_Enabled_Property 9030 9031 begin 9032 -- Abstract states and variables have a flexible scheme of specifying 9033 -- external properties. 9034 9035 if Ekind (Item_Id) = E_Abstract_State then 9036 return State_Has_Enabled_Property; 9037 9038 elsif Ekind (Item_Id) = E_Variable then 9039 return Variable_Has_Enabled_Property; 9040 9041 -- Otherwise a property is enabled when the related item is effectively 9042 -- volatile. 9043 9044 else 9045 return Is_Effectively_Volatile (Item_Id); 9046 end if; 9047 end Has_Enabled_Property; 9048 9049 ------------------------------------- 9050 -- Has_Full_Default_Initialization -- 9051 ------------------------------------- 9052 9053 function Has_Full_Default_Initialization (Typ : Entity_Id) return Boolean is 9054 Arg : Node_Id; 9055 Comp : Entity_Id; 9056 Prag : Node_Id; 9057 9058 begin 9059 -- A private type and its full view is fully default initialized when it 9060 -- is subject to pragma Default_Initial_Condition without an argument or 9061 -- with a non-null argument. Since any type may act as the full view of 9062 -- a private type, this check must be performed prior to the specialized 9063 -- tests below. 9064 9065 if Has_Default_Init_Cond (Typ) 9066 or else Has_Inherited_Default_Init_Cond (Typ) 9067 then 9068 Prag := Get_Pragma (Typ, Pragma_Default_Initial_Condition); 9069 9070 -- Pragma Default_Initial_Condition must be present if one of the 9071 -- related entity flags is set. 9072 9073 pragma Assert (Present (Prag)); 9074 Arg := First (Pragma_Argument_Associations (Prag)); 9075 9076 -- A non-null argument guarantees full default initialization 9077 9078 if Present (Arg) then 9079 return Nkind (Arg) /= N_Null; 9080 9081 -- Otherwise the missing argument defaults the pragma to "True" which 9082 -- is considered a non-null argument (see above). 9083 9084 else 9085 return True; 9086 end if; 9087 end if; 9088 9089 -- A scalar type is fully default initialized if it is subject to aspect 9090 -- Default_Value. 9091 9092 if Is_Scalar_Type (Typ) then 9093 return Has_Default_Aspect (Typ); 9094 9095 -- An array type is fully default initialized if its element type is 9096 -- scalar and the array type carries aspect Default_Component_Value or 9097 -- the element type is fully default initialized. 9098 9099 elsif Is_Array_Type (Typ) then 9100 return 9101 Has_Default_Aspect (Typ) 9102 or else Has_Full_Default_Initialization (Component_Type (Typ)); 9103 9104 -- A protected type, record type or type extension is fully default 9105 -- initialized if all its components either carry an initialization 9106 -- expression or have a type that is fully default initialized. The 9107 -- parent type of a type extension must be fully default initialized. 9108 9109 elsif Is_Record_Type (Typ) or else Is_Protected_Type (Typ) then 9110 9111 -- Inspect all entities defined in the scope of the type, looking for 9112 -- uninitialized components. 9113 9114 Comp := First_Entity (Typ); 9115 while Present (Comp) loop 9116 if Ekind (Comp) = E_Component 9117 and then Comes_From_Source (Comp) 9118 and then No (Expression (Parent (Comp))) 9119 and then not Has_Full_Default_Initialization (Etype (Comp)) 9120 then 9121 return False; 9122 end if; 9123 9124 Next_Entity (Comp); 9125 end loop; 9126 9127 -- Ensure that the parent type of a type extension is fully default 9128 -- initialized. 9129 9130 if Etype (Typ) /= Typ 9131 and then not Has_Full_Default_Initialization (Etype (Typ)) 9132 then 9133 return False; 9134 end if; 9135 9136 -- If we get here, then all components and parent portion are fully 9137 -- default initialized. 9138 9139 return True; 9140 9141 -- A task type is fully default initialized by default 9142 9143 elsif Is_Task_Type (Typ) then 9144 return True; 9145 9146 -- Otherwise the type is not fully default initialized 9147 9148 else 9149 return False; 9150 end if; 9151 end Has_Full_Default_Initialization; 9152 9153 -------------------- 9154 -- Has_Infinities -- 9155 -------------------- 9156 9157 function Has_Infinities (E : Entity_Id) return Boolean is 9158 begin 9159 return 9160 Is_Floating_Point_Type (E) 9161 and then Nkind (Scalar_Range (E)) = N_Range 9162 and then Includes_Infinities (Scalar_Range (E)); 9163 end Has_Infinities; 9164 9165 -------------------- 9166 -- Has_Interfaces -- 9167 -------------------- 9168 9169 function Has_Interfaces 9170 (T : Entity_Id; 9171 Use_Full_View : Boolean := True) return Boolean 9172 is 9173 Typ : Entity_Id := Base_Type (T); 9174 9175 begin 9176 -- Handle concurrent types 9177 9178 if Is_Concurrent_Type (Typ) then 9179 Typ := Corresponding_Record_Type (Typ); 9180 end if; 9181 9182 if not Present (Typ) 9183 or else not Is_Record_Type (Typ) 9184 or else not Is_Tagged_Type (Typ) 9185 then 9186 return False; 9187 end if; 9188 9189 -- Handle private types 9190 9191 if Use_Full_View and then Present (Full_View (Typ)) then 9192 Typ := Full_View (Typ); 9193 end if; 9194 9195 -- Handle concurrent record types 9196 9197 if Is_Concurrent_Record_Type (Typ) 9198 and then Is_Non_Empty_List (Abstract_Interface_List (Typ)) 9199 then 9200 return True; 9201 end if; 9202 9203 loop 9204 if Is_Interface (Typ) 9205 or else 9206 (Is_Record_Type (Typ) 9207 and then Present (Interfaces (Typ)) 9208 and then not Is_Empty_Elmt_List (Interfaces (Typ))) 9209 then 9210 return True; 9211 end if; 9212 9213 exit when Etype (Typ) = Typ 9214 9215 -- Handle private types 9216 9217 or else (Present (Full_View (Etype (Typ))) 9218 and then Full_View (Etype (Typ)) = Typ) 9219 9220 -- Protect frontend against wrong sources with cyclic derivations 9221 9222 or else Etype (Typ) = T; 9223 9224 -- Climb to the ancestor type handling private types 9225 9226 if Present (Full_View (Etype (Typ))) then 9227 Typ := Full_View (Etype (Typ)); 9228 else 9229 Typ := Etype (Typ); 9230 end if; 9231 end loop; 9232 9233 return False; 9234 end Has_Interfaces; 9235 9236 --------------------------------- 9237 -- Has_No_Obvious_Side_Effects -- 9238 --------------------------------- 9239 9240 function Has_No_Obvious_Side_Effects (N : Node_Id) return Boolean is 9241 begin 9242 -- For now, just handle literals, constants, and non-volatile 9243 -- variables and expressions combining these with operators or 9244 -- short circuit forms. 9245 9246 if Nkind (N) in N_Numeric_Or_String_Literal then 9247 return True; 9248 9249 elsif Nkind (N) = N_Character_Literal then 9250 return True; 9251 9252 elsif Nkind (N) in N_Unary_Op then 9253 return Has_No_Obvious_Side_Effects (Right_Opnd (N)); 9254 9255 elsif Nkind (N) in N_Binary_Op or else Nkind (N) in N_Short_Circuit then 9256 return Has_No_Obvious_Side_Effects (Left_Opnd (N)) 9257 and then 9258 Has_No_Obvious_Side_Effects (Right_Opnd (N)); 9259 9260 elsif Nkind (N) = N_Expression_With_Actions 9261 and then Is_Empty_List (Actions (N)) 9262 then 9263 return Has_No_Obvious_Side_Effects (Expression (N)); 9264 9265 elsif Nkind (N) in N_Has_Entity then 9266 return Present (Entity (N)) 9267 and then Ekind_In (Entity (N), E_Variable, 9268 E_Constant, 9269 E_Enumeration_Literal, 9270 E_In_Parameter, 9271 E_Out_Parameter, 9272 E_In_Out_Parameter) 9273 and then not Is_Volatile (Entity (N)); 9274 9275 else 9276 return False; 9277 end if; 9278 end Has_No_Obvious_Side_Effects; 9279 9280 ----------------------------- 9281 -- Has_Non_Null_Refinement -- 9282 ----------------------------- 9283 9284 function Has_Non_Null_Refinement (Id : Entity_Id) return Boolean is 9285 begin 9286 pragma Assert (Ekind (Id) = E_Abstract_State); 9287 9288 -- For a refinement to be non-null, the first constituent must be 9289 -- anything other than null. 9290 9291 if Present (Refinement_Constituents (Id)) then 9292 return 9293 Nkind (Node (First_Elmt (Refinement_Constituents (Id)))) /= N_Null; 9294 end if; 9295 9296 return False; 9297 end Has_Non_Null_Refinement; 9298 9299 ------------------------ 9300 -- Has_Null_Exclusion -- 9301 ------------------------ 9302 9303 function Has_Null_Exclusion (N : Node_Id) return Boolean is 9304 begin 9305 case Nkind (N) is 9306 when N_Access_Definition | 9307 N_Access_Function_Definition | 9308 N_Access_Procedure_Definition | 9309 N_Access_To_Object_Definition | 9310 N_Allocator | 9311 N_Derived_Type_Definition | 9312 N_Function_Specification | 9313 N_Subtype_Declaration => 9314 return Null_Exclusion_Present (N); 9315 9316 when N_Component_Definition | 9317 N_Formal_Object_Declaration | 9318 N_Object_Renaming_Declaration => 9319 if Present (Subtype_Mark (N)) then 9320 return Null_Exclusion_Present (N); 9321 else pragma Assert (Present (Access_Definition (N))); 9322 return Null_Exclusion_Present (Access_Definition (N)); 9323 end if; 9324 9325 when N_Discriminant_Specification => 9326 if Nkind (Discriminant_Type (N)) = N_Access_Definition then 9327 return Null_Exclusion_Present (Discriminant_Type (N)); 9328 else 9329 return Null_Exclusion_Present (N); 9330 end if; 9331 9332 when N_Object_Declaration => 9333 if Nkind (Object_Definition (N)) = N_Access_Definition then 9334 return Null_Exclusion_Present (Object_Definition (N)); 9335 else 9336 return Null_Exclusion_Present (N); 9337 end if; 9338 9339 when N_Parameter_Specification => 9340 if Nkind (Parameter_Type (N)) = N_Access_Definition then 9341 return Null_Exclusion_Present (Parameter_Type (N)); 9342 else 9343 return Null_Exclusion_Present (N); 9344 end if; 9345 9346 when others => 9347 return False; 9348 9349 end case; 9350 end Has_Null_Exclusion; 9351 9352 ------------------------ 9353 -- Has_Null_Extension -- 9354 ------------------------ 9355 9356 function Has_Null_Extension (T : Entity_Id) return Boolean is 9357 B : constant Entity_Id := Base_Type (T); 9358 Comps : Node_Id; 9359 Ext : Node_Id; 9360 9361 begin 9362 if Nkind (Parent (B)) = N_Full_Type_Declaration 9363 and then Present (Record_Extension_Part (Type_Definition (Parent (B)))) 9364 then 9365 Ext := Record_Extension_Part (Type_Definition (Parent (B))); 9366 9367 if Present (Ext) then 9368 if Null_Present (Ext) then 9369 return True; 9370 else 9371 Comps := Component_List (Ext); 9372 9373 -- The null component list is rewritten during analysis to 9374 -- include the parent component. Any other component indicates 9375 -- that the extension was not originally null. 9376 9377 return Null_Present (Comps) 9378 or else No (Next (First (Component_Items (Comps)))); 9379 end if; 9380 else 9381 return False; 9382 end if; 9383 9384 else 9385 return False; 9386 end if; 9387 end Has_Null_Extension; 9388 9389 ------------------------- 9390 -- Has_Null_Refinement -- 9391 ------------------------- 9392 9393 function Has_Null_Refinement (Id : Entity_Id) return Boolean is 9394 begin 9395 pragma Assert (Ekind (Id) = E_Abstract_State); 9396 9397 -- For a refinement to be null, the state's sole constituent must be a 9398 -- null. 9399 9400 if Present (Refinement_Constituents (Id)) then 9401 return 9402 Nkind (Node (First_Elmt (Refinement_Constituents (Id)))) = N_Null; 9403 end if; 9404 9405 return False; 9406 end Has_Null_Refinement; 9407 9408 ------------------------------- 9409 -- Has_Overriding_Initialize -- 9410 ------------------------------- 9411 9412 function Has_Overriding_Initialize (T : Entity_Id) return Boolean is 9413 BT : constant Entity_Id := Base_Type (T); 9414 P : Elmt_Id; 9415 9416 begin 9417 if Is_Controlled (BT) then 9418 if Is_RTU (Scope (BT), Ada_Finalization) then 9419 return False; 9420 9421 elsif Present (Primitive_Operations (BT)) then 9422 P := First_Elmt (Primitive_Operations (BT)); 9423 while Present (P) loop 9424 declare 9425 Init : constant Entity_Id := Node (P); 9426 Formal : constant Entity_Id := First_Formal (Init); 9427 begin 9428 if Ekind (Init) = E_Procedure 9429 and then Chars (Init) = Name_Initialize 9430 and then Comes_From_Source (Init) 9431 and then Present (Formal) 9432 and then Etype (Formal) = BT 9433 and then No (Next_Formal (Formal)) 9434 and then (Ada_Version < Ada_2012 9435 or else not Null_Present (Parent (Init))) 9436 then 9437 return True; 9438 end if; 9439 end; 9440 9441 Next_Elmt (P); 9442 end loop; 9443 end if; 9444 9445 -- Here if type itself does not have a non-null Initialize operation: 9446 -- check immediate ancestor. 9447 9448 if Is_Derived_Type (BT) 9449 and then Has_Overriding_Initialize (Etype (BT)) 9450 then 9451 return True; 9452 end if; 9453 end if; 9454 9455 return False; 9456 end Has_Overriding_Initialize; 9457 9458 -------------------------------------- 9459 -- Has_Preelaborable_Initialization -- 9460 -------------------------------------- 9461 9462 function Has_Preelaborable_Initialization (E : Entity_Id) return Boolean is 9463 Has_PE : Boolean; 9464 9465 procedure Check_Components (E : Entity_Id); 9466 -- Check component/discriminant chain, sets Has_PE False if a component 9467 -- or discriminant does not meet the preelaborable initialization rules. 9468 9469 ---------------------- 9470 -- Check_Components -- 9471 ---------------------- 9472 9473 procedure Check_Components (E : Entity_Id) is 9474 Ent : Entity_Id; 9475 Exp : Node_Id; 9476 9477 function Is_Preelaborable_Expression (N : Node_Id) return Boolean; 9478 -- Returns True if and only if the expression denoted by N does not 9479 -- violate restrictions on preelaborable constructs (RM-10.2.1(5-9)). 9480 9481 --------------------------------- 9482 -- Is_Preelaborable_Expression -- 9483 --------------------------------- 9484 9485 function Is_Preelaborable_Expression (N : Node_Id) return Boolean is 9486 Exp : Node_Id; 9487 Assn : Node_Id; 9488 Choice : Node_Id; 9489 Comp_Type : Entity_Id; 9490 Is_Array_Aggr : Boolean; 9491 9492 begin 9493 if Is_OK_Static_Expression (N) then 9494 return True; 9495 9496 elsif Nkind (N) = N_Null then 9497 return True; 9498 9499 -- Attributes are allowed in general, even if their prefix is a 9500 -- formal type. (It seems that certain attributes known not to be 9501 -- static might not be allowed, but there are no rules to prevent 9502 -- them.) 9503 9504 elsif Nkind (N) = N_Attribute_Reference then 9505 return True; 9506 9507 -- The name of a discriminant evaluated within its parent type is 9508 -- defined to be preelaborable (10.2.1(8)). Note that we test for 9509 -- names that denote discriminals as well as discriminants to 9510 -- catch references occurring within init procs. 9511 9512 elsif Is_Entity_Name (N) 9513 and then 9514 (Ekind (Entity (N)) = E_Discriminant 9515 or else (Ekind_In (Entity (N), E_Constant, E_In_Parameter) 9516 and then Present (Discriminal_Link (Entity (N))))) 9517 then 9518 return True; 9519 9520 elsif Nkind (N) = N_Qualified_Expression then 9521 return Is_Preelaborable_Expression (Expression (N)); 9522 9523 -- For aggregates we have to check that each of the associations 9524 -- is preelaborable. 9525 9526 elsif Nkind_In (N, N_Aggregate, N_Extension_Aggregate) then 9527 Is_Array_Aggr := Is_Array_Type (Etype (N)); 9528 9529 if Is_Array_Aggr then 9530 Comp_Type := Component_Type (Etype (N)); 9531 end if; 9532 9533 -- Check the ancestor part of extension aggregates, which must 9534 -- be either the name of a type that has preelaborable init or 9535 -- an expression that is preelaborable. 9536 9537 if Nkind (N) = N_Extension_Aggregate then 9538 declare 9539 Anc_Part : constant Node_Id := Ancestor_Part (N); 9540 9541 begin 9542 if Is_Entity_Name (Anc_Part) 9543 and then Is_Type (Entity (Anc_Part)) 9544 then 9545 if not Has_Preelaborable_Initialization 9546 (Entity (Anc_Part)) 9547 then 9548 return False; 9549 end if; 9550 9551 elsif not Is_Preelaborable_Expression (Anc_Part) then 9552 return False; 9553 end if; 9554 end; 9555 end if; 9556 9557 -- Check positional associations 9558 9559 Exp := First (Expressions (N)); 9560 while Present (Exp) loop 9561 if not Is_Preelaborable_Expression (Exp) then 9562 return False; 9563 end if; 9564 9565 Next (Exp); 9566 end loop; 9567 9568 -- Check named associations 9569 9570 Assn := First (Component_Associations (N)); 9571 while Present (Assn) loop 9572 Choice := First (Choices (Assn)); 9573 while Present (Choice) loop 9574 if Is_Array_Aggr then 9575 if Nkind (Choice) = N_Others_Choice then 9576 null; 9577 9578 elsif Nkind (Choice) = N_Range then 9579 if not Is_OK_Static_Range (Choice) then 9580 return False; 9581 end if; 9582 9583 elsif not Is_OK_Static_Expression (Choice) then 9584 return False; 9585 end if; 9586 9587 else 9588 Comp_Type := Etype (Choice); 9589 end if; 9590 9591 Next (Choice); 9592 end loop; 9593 9594 -- If the association has a <> at this point, then we have 9595 -- to check whether the component's type has preelaborable 9596 -- initialization. Note that this only occurs when the 9597 -- association's corresponding component does not have a 9598 -- default expression, the latter case having already been 9599 -- expanded as an expression for the association. 9600 9601 if Box_Present (Assn) then 9602 if not Has_Preelaborable_Initialization (Comp_Type) then 9603 return False; 9604 end if; 9605 9606 -- In the expression case we check whether the expression 9607 -- is preelaborable. 9608 9609 elsif 9610 not Is_Preelaborable_Expression (Expression (Assn)) 9611 then 9612 return False; 9613 end if; 9614 9615 Next (Assn); 9616 end loop; 9617 9618 -- If we get here then aggregate as a whole is preelaborable 9619 9620 return True; 9621 9622 -- All other cases are not preelaborable 9623 9624 else 9625 return False; 9626 end if; 9627 end Is_Preelaborable_Expression; 9628 9629 -- Start of processing for Check_Components 9630 9631 begin 9632 -- Loop through entities of record or protected type 9633 9634 Ent := E; 9635 while Present (Ent) loop 9636 9637 -- We are interested only in components and discriminants 9638 9639 Exp := Empty; 9640 9641 case Ekind (Ent) is 9642 when E_Component => 9643 9644 -- Get default expression if any. If there is no declaration 9645 -- node, it means we have an internal entity. The parent and 9646 -- tag fields are examples of such entities. For such cases, 9647 -- we just test the type of the entity. 9648 9649 if Present (Declaration_Node (Ent)) then 9650 Exp := Expression (Declaration_Node (Ent)); 9651 end if; 9652 9653 when E_Discriminant => 9654 9655 -- Note: for a renamed discriminant, the Declaration_Node 9656 -- may point to the one from the ancestor, and have a 9657 -- different expression, so use the proper attribute to 9658 -- retrieve the expression from the derived constraint. 9659 9660 Exp := Discriminant_Default_Value (Ent); 9661 9662 when others => 9663 goto Check_Next_Entity; 9664 end case; 9665 9666 -- A component has PI if it has no default expression and the 9667 -- component type has PI. 9668 9669 if No (Exp) then 9670 if not Has_Preelaborable_Initialization (Etype (Ent)) then 9671 Has_PE := False; 9672 exit; 9673 end if; 9674 9675 -- Require the default expression to be preelaborable 9676 9677 elsif not Is_Preelaborable_Expression (Exp) then 9678 Has_PE := False; 9679 exit; 9680 end if; 9681 9682 <<Check_Next_Entity>> 9683 Next_Entity (Ent); 9684 end loop; 9685 end Check_Components; 9686 9687 -- Start of processing for Has_Preelaborable_Initialization 9688 9689 begin 9690 -- Immediate return if already marked as known preelaborable init. This 9691 -- covers types for which this function has already been called once 9692 -- and returned True (in which case the result is cached), and also 9693 -- types to which a pragma Preelaborable_Initialization applies. 9694 9695 if Known_To_Have_Preelab_Init (E) then 9696 return True; 9697 end if; 9698 9699 -- If the type is a subtype representing a generic actual type, then 9700 -- test whether its base type has preelaborable initialization since 9701 -- the subtype representing the actual does not inherit this attribute 9702 -- from the actual or formal. (but maybe it should???) 9703 9704 if Is_Generic_Actual_Type (E) then 9705 return Has_Preelaborable_Initialization (Base_Type (E)); 9706 end if; 9707 9708 -- All elementary types have preelaborable initialization 9709 9710 if Is_Elementary_Type (E) then 9711 Has_PE := True; 9712 9713 -- Array types have PI if the component type has PI 9714 9715 elsif Is_Array_Type (E) then 9716 Has_PE := Has_Preelaborable_Initialization (Component_Type (E)); 9717 9718 -- A derived type has preelaborable initialization if its parent type 9719 -- has preelaborable initialization and (in the case of a derived record 9720 -- extension) if the non-inherited components all have preelaborable 9721 -- initialization. However, a user-defined controlled type with an 9722 -- overriding Initialize procedure does not have preelaborable 9723 -- initialization. 9724 9725 elsif Is_Derived_Type (E) then 9726 9727 -- If the derived type is a private extension then it doesn't have 9728 -- preelaborable initialization. 9729 9730 if Ekind (Base_Type (E)) = E_Record_Type_With_Private then 9731 return False; 9732 end if; 9733 9734 -- First check whether ancestor type has preelaborable initialization 9735 9736 Has_PE := Has_Preelaborable_Initialization (Etype (Base_Type (E))); 9737 9738 -- If OK, check extension components (if any) 9739 9740 if Has_PE and then Is_Record_Type (E) then 9741 Check_Components (First_Entity (E)); 9742 end if; 9743 9744 -- Check specifically for 10.2.1(11.4/2) exception: a controlled type 9745 -- with a user defined Initialize procedure does not have PI. If 9746 -- the type is untagged, the control primitives come from a component 9747 -- that has already been checked. 9748 9749 if Has_PE 9750 and then Is_Controlled (E) 9751 and then Is_Tagged_Type (E) 9752 and then Has_Overriding_Initialize (E) 9753 then 9754 Has_PE := False; 9755 end if; 9756 9757 -- Private types not derived from a type having preelaborable init and 9758 -- that are not marked with pragma Preelaborable_Initialization do not 9759 -- have preelaborable initialization. 9760 9761 elsif Is_Private_Type (E) then 9762 return False; 9763 9764 -- Record type has PI if it is non private and all components have PI 9765 9766 elsif Is_Record_Type (E) then 9767 Has_PE := True; 9768 Check_Components (First_Entity (E)); 9769 9770 -- Protected types must not have entries, and components must meet 9771 -- same set of rules as for record components. 9772 9773 elsif Is_Protected_Type (E) then 9774 if Has_Entries (E) then 9775 Has_PE := False; 9776 else 9777 Has_PE := True; 9778 Check_Components (First_Entity (E)); 9779 Check_Components (First_Private_Entity (E)); 9780 end if; 9781 9782 -- Type System.Address always has preelaborable initialization 9783 9784 elsif Is_RTE (E, RE_Address) then 9785 Has_PE := True; 9786 9787 -- In all other cases, type does not have preelaborable initialization 9788 9789 else 9790 return False; 9791 end if; 9792 9793 -- If type has preelaborable initialization, cache result 9794 9795 if Has_PE then 9796 Set_Known_To_Have_Preelab_Init (E); 9797 end if; 9798 9799 return Has_PE; 9800 end Has_Preelaborable_Initialization; 9801 9802 --------------------------- 9803 -- Has_Private_Component -- 9804 --------------------------- 9805 9806 function Has_Private_Component (Type_Id : Entity_Id) return Boolean is 9807 Btype : Entity_Id := Base_Type (Type_Id); 9808 Component : Entity_Id; 9809 9810 begin 9811 if Error_Posted (Type_Id) 9812 or else Error_Posted (Btype) 9813 then 9814 return False; 9815 end if; 9816 9817 if Is_Class_Wide_Type (Btype) then 9818 Btype := Root_Type (Btype); 9819 end if; 9820 9821 if Is_Private_Type (Btype) then 9822 declare 9823 UT : constant Entity_Id := Underlying_Type (Btype); 9824 begin 9825 if No (UT) then 9826 if No (Full_View (Btype)) then 9827 return not Is_Generic_Type (Btype) 9828 and then 9829 not Is_Generic_Type (Root_Type (Btype)); 9830 else 9831 return not Is_Generic_Type (Root_Type (Full_View (Btype))); 9832 end if; 9833 else 9834 return not Is_Frozen (UT) and then Has_Private_Component (UT); 9835 end if; 9836 end; 9837 9838 elsif Is_Array_Type (Btype) then 9839 return Has_Private_Component (Component_Type (Btype)); 9840 9841 elsif Is_Record_Type (Btype) then 9842 Component := First_Component (Btype); 9843 while Present (Component) loop 9844 if Has_Private_Component (Etype (Component)) then 9845 return True; 9846 end if; 9847 9848 Next_Component (Component); 9849 end loop; 9850 9851 return False; 9852 9853 elsif Is_Protected_Type (Btype) 9854 and then Present (Corresponding_Record_Type (Btype)) 9855 then 9856 return Has_Private_Component (Corresponding_Record_Type (Btype)); 9857 9858 else 9859 return False; 9860 end if; 9861 end Has_Private_Component; 9862 9863 ---------------------- 9864 -- Has_Signed_Zeros -- 9865 ---------------------- 9866 9867 function Has_Signed_Zeros (E : Entity_Id) return Boolean is 9868 begin 9869 return Is_Floating_Point_Type (E) and then Signed_Zeros_On_Target; 9870 end Has_Signed_Zeros; 9871 9872 ------------------------------ 9873 -- Has_Significant_Contract -- 9874 ------------------------------ 9875 9876 function Has_Significant_Contract (Subp_Id : Entity_Id) return Boolean is 9877 Subp_Nam : constant Name_Id := Chars (Subp_Id); 9878 9879 begin 9880 -- _Finalizer procedure 9881 9882 if Subp_Nam = Name_uFinalizer then 9883 return False; 9884 9885 -- _Postconditions procedure 9886 9887 elsif Subp_Nam = Name_uPostconditions then 9888 return False; 9889 9890 -- Predicate function 9891 9892 elsif Ekind (Subp_Id) = E_Function 9893 and then Is_Predicate_Function (Subp_Id) 9894 then 9895 return False; 9896 9897 -- TSS subprogram 9898 9899 elsif Get_TSS_Name (Subp_Id) /= TSS_Null then 9900 return False; 9901 9902 else 9903 return True; 9904 end if; 9905 end Has_Significant_Contract; 9906 9907 ----------------------------- 9908 -- Has_Static_Array_Bounds -- 9909 ----------------------------- 9910 9911 function Has_Static_Array_Bounds (Typ : Node_Id) return Boolean is 9912 Ndims : constant Nat := Number_Dimensions (Typ); 9913 9914 Index : Node_Id; 9915 Low : Node_Id; 9916 High : Node_Id; 9917 9918 begin 9919 -- Unconstrained types do not have static bounds 9920 9921 if not Is_Constrained (Typ) then 9922 return False; 9923 end if; 9924 9925 -- First treat string literals specially, as the lower bound and length 9926 -- of string literals are not stored like those of arrays. 9927 9928 -- A string literal always has static bounds 9929 9930 if Ekind (Typ) = E_String_Literal_Subtype then 9931 return True; 9932 end if; 9933 9934 -- Treat all dimensions in turn 9935 9936 Index := First_Index (Typ); 9937 for Indx in 1 .. Ndims loop 9938 9939 -- In case of an illegal index which is not a discrete type, return 9940 -- that the type is not static. 9941 9942 if not Is_Discrete_Type (Etype (Index)) 9943 or else Etype (Index) = Any_Type 9944 then 9945 return False; 9946 end if; 9947 9948 Get_Index_Bounds (Index, Low, High); 9949 9950 if Error_Posted (Low) or else Error_Posted (High) then 9951 return False; 9952 end if; 9953 9954 if Is_OK_Static_Expression (Low) 9955 and then 9956 Is_OK_Static_Expression (High) 9957 then 9958 null; 9959 else 9960 return False; 9961 end if; 9962 9963 Next (Index); 9964 end loop; 9965 9966 -- If we fall through the loop, all indexes matched 9967 9968 return True; 9969 end Has_Static_Array_Bounds; 9970 9971 ---------------- 9972 -- Has_Stream -- 9973 ---------------- 9974 9975 function Has_Stream (T : Entity_Id) return Boolean is 9976 E : Entity_Id; 9977 9978 begin 9979 if No (T) then 9980 return False; 9981 9982 elsif Is_RTE (Root_Type (T), RE_Root_Stream_Type) then 9983 return True; 9984 9985 elsif Is_Array_Type (T) then 9986 return Has_Stream (Component_Type (T)); 9987 9988 elsif Is_Record_Type (T) then 9989 E := First_Component (T); 9990 while Present (E) loop 9991 if Has_Stream (Etype (E)) then 9992 return True; 9993 else 9994 Next_Component (E); 9995 end if; 9996 end loop; 9997 9998 return False; 9999 10000 elsif Is_Private_Type (T) then 10001 return Has_Stream (Underlying_Type (T)); 10002 10003 else 10004 return False; 10005 end if; 10006 end Has_Stream; 10007 10008 ---------------- 10009 -- Has_Suffix -- 10010 ---------------- 10011 10012 function Has_Suffix (E : Entity_Id; Suffix : Character) return Boolean is 10013 begin 10014 Get_Name_String (Chars (E)); 10015 return Name_Buffer (Name_Len) = Suffix; 10016 end Has_Suffix; 10017 10018 ---------------- 10019 -- Add_Suffix -- 10020 ---------------- 10021 10022 function Add_Suffix (E : Entity_Id; Suffix : Character) return Name_Id is 10023 begin 10024 Get_Name_String (Chars (E)); 10025 Add_Char_To_Name_Buffer (Suffix); 10026 return Name_Find; 10027 end Add_Suffix; 10028 10029 ------------------- 10030 -- Remove_Suffix -- 10031 ------------------- 10032 10033 function Remove_Suffix (E : Entity_Id; Suffix : Character) return Name_Id is 10034 begin 10035 pragma Assert (Has_Suffix (E, Suffix)); 10036 Get_Name_String (Chars (E)); 10037 Name_Len := Name_Len - 1; 10038 return Name_Find; 10039 end Remove_Suffix; 10040 10041 -------------------------- 10042 -- Has_Tagged_Component -- 10043 -------------------------- 10044 10045 function Has_Tagged_Component (Typ : Entity_Id) return Boolean is 10046 Comp : Entity_Id; 10047 10048 begin 10049 if Is_Private_Type (Typ) and then Present (Underlying_Type (Typ)) then 10050 return Has_Tagged_Component (Underlying_Type (Typ)); 10051 10052 elsif Is_Array_Type (Typ) then 10053 return Has_Tagged_Component (Component_Type (Typ)); 10054 10055 elsif Is_Tagged_Type (Typ) then 10056 return True; 10057 10058 elsif Is_Record_Type (Typ) then 10059 Comp := First_Component (Typ); 10060 while Present (Comp) loop 10061 if Has_Tagged_Component (Etype (Comp)) then 10062 return True; 10063 end if; 10064 10065 Next_Component (Comp); 10066 end loop; 10067 10068 return False; 10069 10070 else 10071 return False; 10072 end if; 10073 end Has_Tagged_Component; 10074 10075 ----------------------------- 10076 -- Has_Undefined_Reference -- 10077 ----------------------------- 10078 10079 function Has_Undefined_Reference (Expr : Node_Id) return Boolean is 10080 Has_Undef_Ref : Boolean := False; 10081 -- Flag set when expression Expr contains at least one undefined 10082 -- reference. 10083 10084 function Is_Undefined_Reference (N : Node_Id) return Traverse_Result; 10085 -- Determine whether N denotes a reference and if it does, whether it is 10086 -- undefined. 10087 10088 ---------------------------- 10089 -- Is_Undefined_Reference -- 10090 ---------------------------- 10091 10092 function Is_Undefined_Reference (N : Node_Id) return Traverse_Result is 10093 begin 10094 if Is_Entity_Name (N) 10095 and then Present (Entity (N)) 10096 and then Entity (N) = Any_Id 10097 then 10098 Has_Undef_Ref := True; 10099 return Abandon; 10100 end if; 10101 10102 return OK; 10103 end Is_Undefined_Reference; 10104 10105 procedure Find_Undefined_References is 10106 new Traverse_Proc (Is_Undefined_Reference); 10107 10108 -- Start of processing for Has_Undefined_Reference 10109 10110 begin 10111 Find_Undefined_References (Expr); 10112 10113 return Has_Undef_Ref; 10114 end Has_Undefined_Reference; 10115 10116 ---------------------------- 10117 -- Has_Volatile_Component -- 10118 ---------------------------- 10119 10120 function Has_Volatile_Component (Typ : Entity_Id) return Boolean is 10121 Comp : Entity_Id; 10122 10123 begin 10124 if Has_Volatile_Components (Typ) then 10125 return True; 10126 10127 elsif Is_Array_Type (Typ) then 10128 return Is_Volatile (Component_Type (Typ)); 10129 10130 elsif Is_Record_Type (Typ) then 10131 Comp := First_Component (Typ); 10132 while Present (Comp) loop 10133 if Is_Volatile_Object (Comp) then 10134 return True; 10135 end if; 10136 10137 Comp := Next_Component (Comp); 10138 end loop; 10139 end if; 10140 10141 return False; 10142 end Has_Volatile_Component; 10143 10144 ------------------------- 10145 -- Implementation_Kind -- 10146 ------------------------- 10147 10148 function Implementation_Kind (Subp : Entity_Id) return Name_Id is 10149 Impl_Prag : constant Node_Id := Get_Rep_Pragma (Subp, Name_Implemented); 10150 Arg : Node_Id; 10151 begin 10152 pragma Assert (Present (Impl_Prag)); 10153 Arg := Last (Pragma_Argument_Associations (Impl_Prag)); 10154 return Chars (Get_Pragma_Arg (Arg)); 10155 end Implementation_Kind; 10156 10157 -------------------------- 10158 -- Implements_Interface -- 10159 -------------------------- 10160 10161 function Implements_Interface 10162 (Typ_Ent : Entity_Id; 10163 Iface_Ent : Entity_Id; 10164 Exclude_Parents : Boolean := False) return Boolean 10165 is 10166 Ifaces_List : Elist_Id; 10167 Elmt : Elmt_Id; 10168 Iface : Entity_Id := Base_Type (Iface_Ent); 10169 Typ : Entity_Id := Base_Type (Typ_Ent); 10170 10171 begin 10172 if Is_Class_Wide_Type (Typ) then 10173 Typ := Root_Type (Typ); 10174 end if; 10175 10176 if not Has_Interfaces (Typ) then 10177 return False; 10178 end if; 10179 10180 if Is_Class_Wide_Type (Iface) then 10181 Iface := Root_Type (Iface); 10182 end if; 10183 10184 Collect_Interfaces (Typ, Ifaces_List); 10185 10186 Elmt := First_Elmt (Ifaces_List); 10187 while Present (Elmt) loop 10188 if Is_Ancestor (Node (Elmt), Typ, Use_Full_View => True) 10189 and then Exclude_Parents 10190 then 10191 null; 10192 10193 elsif Node (Elmt) = Iface then 10194 return True; 10195 end if; 10196 10197 Next_Elmt (Elmt); 10198 end loop; 10199 10200 return False; 10201 end Implements_Interface; 10202 10203 ------------------------------------ 10204 -- In_Assertion_Expression_Pragma -- 10205 ------------------------------------ 10206 10207 function In_Assertion_Expression_Pragma (N : Node_Id) return Boolean is 10208 Par : Node_Id; 10209 Prag : Node_Id := Empty; 10210 10211 begin 10212 -- Climb the parent chain looking for an enclosing pragma 10213 10214 Par := N; 10215 while Present (Par) loop 10216 if Nkind (Par) = N_Pragma then 10217 Prag := Par; 10218 exit; 10219 10220 -- Precondition-like pragmas are expanded into if statements, check 10221 -- the original node instead. 10222 10223 elsif Nkind (Original_Node (Par)) = N_Pragma then 10224 Prag := Original_Node (Par); 10225 exit; 10226 10227 -- The expansion of attribute 'Old generates a constant to capture 10228 -- the result of the prefix. If the parent traversal reaches 10229 -- one of these constants, then the node technically came from a 10230 -- postcondition-like pragma. Note that the Ekind is not tested here 10231 -- because N may be the expression of an object declaration which is 10232 -- currently being analyzed. Such objects carry Ekind of E_Void. 10233 10234 elsif Nkind (Par) = N_Object_Declaration 10235 and then Constant_Present (Par) 10236 and then Stores_Attribute_Old_Prefix (Defining_Entity (Par)) 10237 then 10238 return True; 10239 10240 -- Prevent the search from going too far 10241 10242 elsif Is_Body_Or_Package_Declaration (Par) then 10243 return False; 10244 end if; 10245 10246 Par := Parent (Par); 10247 end loop; 10248 10249 return 10250 Present (Prag) 10251 and then Assertion_Expression_Pragma (Get_Pragma_Id (Prag)); 10252 end In_Assertion_Expression_Pragma; 10253 10254 ----------------- 10255 -- In_Instance -- 10256 ----------------- 10257 10258 function In_Instance return Boolean is 10259 Curr_Unit : constant Entity_Id := Cunit_Entity (Current_Sem_Unit); 10260 S : Entity_Id; 10261 10262 begin 10263 S := Current_Scope; 10264 while Present (S) and then S /= Standard_Standard loop 10265 if Ekind_In (S, E_Function, E_Package, E_Procedure) 10266 and then Is_Generic_Instance (S) 10267 then 10268 -- A child instance is always compiled in the context of a parent 10269 -- instance. Nevertheless, the actuals are not analyzed in an 10270 -- instance context. We detect this case by examining the current 10271 -- compilation unit, which must be a child instance, and checking 10272 -- that it is not currently on the scope stack. 10273 10274 if Is_Child_Unit (Curr_Unit) 10275 and then Nkind (Unit (Cunit (Current_Sem_Unit))) = 10276 N_Package_Instantiation 10277 and then not In_Open_Scopes (Curr_Unit) 10278 then 10279 return False; 10280 else 10281 return True; 10282 end if; 10283 end if; 10284 10285 S := Scope (S); 10286 end loop; 10287 10288 return False; 10289 end In_Instance; 10290 10291 ---------------------- 10292 -- In_Instance_Body -- 10293 ---------------------- 10294 10295 function In_Instance_Body return Boolean is 10296 S : Entity_Id; 10297 10298 begin 10299 S := Current_Scope; 10300 while Present (S) and then S /= Standard_Standard loop 10301 if Ekind_In (S, E_Function, E_Procedure) 10302 and then Is_Generic_Instance (S) 10303 then 10304 return True; 10305 10306 elsif Ekind (S) = E_Package 10307 and then In_Package_Body (S) 10308 and then Is_Generic_Instance (S) 10309 then 10310 return True; 10311 end if; 10312 10313 S := Scope (S); 10314 end loop; 10315 10316 return False; 10317 end In_Instance_Body; 10318 10319 ----------------------------- 10320 -- In_Instance_Not_Visible -- 10321 ----------------------------- 10322 10323 function In_Instance_Not_Visible return Boolean is 10324 S : Entity_Id; 10325 10326 begin 10327 S := Current_Scope; 10328 while Present (S) and then S /= Standard_Standard loop 10329 if Ekind_In (S, E_Function, E_Procedure) 10330 and then Is_Generic_Instance (S) 10331 then 10332 return True; 10333 10334 elsif Ekind (S) = E_Package 10335 and then (In_Package_Body (S) or else In_Private_Part (S)) 10336 and then Is_Generic_Instance (S) 10337 then 10338 return True; 10339 end if; 10340 10341 S := Scope (S); 10342 end loop; 10343 10344 return False; 10345 end In_Instance_Not_Visible; 10346 10347 ------------------------------ 10348 -- In_Instance_Visible_Part -- 10349 ------------------------------ 10350 10351 function In_Instance_Visible_Part return Boolean is 10352 S : Entity_Id; 10353 10354 begin 10355 S := Current_Scope; 10356 while Present (S) and then S /= Standard_Standard loop 10357 if Ekind (S) = E_Package 10358 and then Is_Generic_Instance (S) 10359 and then not In_Package_Body (S) 10360 and then not In_Private_Part (S) 10361 then 10362 return True; 10363 end if; 10364 10365 S := Scope (S); 10366 end loop; 10367 10368 return False; 10369 end In_Instance_Visible_Part; 10370 10371 --------------------- 10372 -- In_Package_Body -- 10373 --------------------- 10374 10375 function In_Package_Body return Boolean is 10376 S : Entity_Id; 10377 10378 begin 10379 S := Current_Scope; 10380 while Present (S) and then S /= Standard_Standard loop 10381 if Ekind (S) = E_Package and then In_Package_Body (S) then 10382 return True; 10383 else 10384 S := Scope (S); 10385 end if; 10386 end loop; 10387 10388 return False; 10389 end In_Package_Body; 10390 10391 -------------------------------- 10392 -- In_Parameter_Specification -- 10393 -------------------------------- 10394 10395 function In_Parameter_Specification (N : Node_Id) return Boolean is 10396 PN : Node_Id; 10397 10398 begin 10399 PN := Parent (N); 10400 while Present (PN) loop 10401 if Nkind (PN) = N_Parameter_Specification then 10402 return True; 10403 end if; 10404 10405 PN := Parent (PN); 10406 end loop; 10407 10408 return False; 10409 end In_Parameter_Specification; 10410 10411 -------------------------- 10412 -- In_Pragma_Expression -- 10413 -------------------------- 10414 10415 function In_Pragma_Expression (N : Node_Id; Nam : Name_Id) return Boolean is 10416 P : Node_Id; 10417 begin 10418 P := Parent (N); 10419 loop 10420 if No (P) then 10421 return False; 10422 elsif Nkind (P) = N_Pragma and then Pragma_Name (P) = Nam then 10423 return True; 10424 else 10425 P := Parent (P); 10426 end if; 10427 end loop; 10428 end In_Pragma_Expression; 10429 10430 ------------------------------------- 10431 -- In_Reverse_Storage_Order_Object -- 10432 ------------------------------------- 10433 10434 function In_Reverse_Storage_Order_Object (N : Node_Id) return Boolean is 10435 Pref : Node_Id; 10436 Btyp : Entity_Id := Empty; 10437 10438 begin 10439 -- Climb up indexed components 10440 10441 Pref := N; 10442 loop 10443 case Nkind (Pref) is 10444 when N_Selected_Component => 10445 Pref := Prefix (Pref); 10446 exit; 10447 10448 when N_Indexed_Component => 10449 Pref := Prefix (Pref); 10450 10451 when others => 10452 Pref := Empty; 10453 exit; 10454 end case; 10455 end loop; 10456 10457 if Present (Pref) then 10458 Btyp := Base_Type (Etype (Pref)); 10459 end if; 10460 10461 return Present (Btyp) 10462 and then (Is_Record_Type (Btyp) or else Is_Array_Type (Btyp)) 10463 and then Reverse_Storage_Order (Btyp); 10464 end In_Reverse_Storage_Order_Object; 10465 10466 -------------------------------------- 10467 -- In_Subprogram_Or_Concurrent_Unit -- 10468 -------------------------------------- 10469 10470 function In_Subprogram_Or_Concurrent_Unit return Boolean is 10471 E : Entity_Id; 10472 K : Entity_Kind; 10473 10474 begin 10475 -- Use scope chain to check successively outer scopes 10476 10477 E := Current_Scope; 10478 loop 10479 K := Ekind (E); 10480 10481 if K in Subprogram_Kind 10482 or else K in Concurrent_Kind 10483 or else K in Generic_Subprogram_Kind 10484 then 10485 return True; 10486 10487 elsif E = Standard_Standard then 10488 return False; 10489 end if; 10490 10491 E := Scope (E); 10492 end loop; 10493 end In_Subprogram_Or_Concurrent_Unit; 10494 10495 --------------------- 10496 -- In_Visible_Part -- 10497 --------------------- 10498 10499 function In_Visible_Part (Scope_Id : Entity_Id) return Boolean is 10500 begin 10501 return Is_Package_Or_Generic_Package (Scope_Id) 10502 and then In_Open_Scopes (Scope_Id) 10503 and then not In_Package_Body (Scope_Id) 10504 and then not In_Private_Part (Scope_Id); 10505 end In_Visible_Part; 10506 10507 -------------------------------- 10508 -- Incomplete_Or_Partial_View -- 10509 -------------------------------- 10510 10511 function Incomplete_Or_Partial_View (Id : Entity_Id) return Entity_Id is 10512 function Inspect_Decls 10513 (Decls : List_Id; 10514 Taft : Boolean := False) return Entity_Id; 10515 -- Check whether a declarative region contains the incomplete or partial 10516 -- view of Id. 10517 10518 ------------------- 10519 -- Inspect_Decls -- 10520 ------------------- 10521 10522 function Inspect_Decls 10523 (Decls : List_Id; 10524 Taft : Boolean := False) return Entity_Id 10525 is 10526 Decl : Node_Id; 10527 Match : Node_Id; 10528 10529 begin 10530 Decl := First (Decls); 10531 while Present (Decl) loop 10532 Match := Empty; 10533 10534 if Taft then 10535 if Nkind (Decl) = N_Incomplete_Type_Declaration then 10536 Match := Defining_Identifier (Decl); 10537 end if; 10538 10539 else 10540 if Nkind_In (Decl, N_Private_Extension_Declaration, 10541 N_Private_Type_Declaration) 10542 then 10543 Match := Defining_Identifier (Decl); 10544 end if; 10545 end if; 10546 10547 if Present (Match) 10548 and then Present (Full_View (Match)) 10549 and then Full_View (Match) = Id 10550 then 10551 return Match; 10552 end if; 10553 10554 Next (Decl); 10555 end loop; 10556 10557 return Empty; 10558 end Inspect_Decls; 10559 10560 -- Local variables 10561 10562 Prev : Entity_Id; 10563 10564 -- Start of processing for Incomplete_Or_Partial_View 10565 10566 begin 10567 -- Deferred constant or incomplete type case 10568 10569 Prev := Current_Entity_In_Scope (Id); 10570 10571 if Present (Prev) 10572 and then (Is_Incomplete_Type (Prev) or else Ekind (Prev) = E_Constant) 10573 and then Present (Full_View (Prev)) 10574 and then Full_View (Prev) = Id 10575 then 10576 return Prev; 10577 end if; 10578 10579 -- Private or Taft amendment type case 10580 10581 declare 10582 Pkg : constant Entity_Id := Scope (Id); 10583 Pkg_Decl : Node_Id := Pkg; 10584 10585 begin 10586 if Present (Pkg) and then Ekind (Pkg) = E_Package then 10587 while Nkind (Pkg_Decl) /= N_Package_Specification loop 10588 Pkg_Decl := Parent (Pkg_Decl); 10589 end loop; 10590 10591 -- It is knows that Typ has a private view, look for it in the 10592 -- visible declarations of the enclosing scope. A special case 10593 -- of this is when the two views have been exchanged - the full 10594 -- appears earlier than the private. 10595 10596 if Has_Private_Declaration (Id) then 10597 Prev := Inspect_Decls (Visible_Declarations (Pkg_Decl)); 10598 10599 -- Exchanged view case, look in the private declarations 10600 10601 if No (Prev) then 10602 Prev := Inspect_Decls (Private_Declarations (Pkg_Decl)); 10603 end if; 10604 10605 return Prev; 10606 10607 -- Otherwise if this is the package body, then Typ is a potential 10608 -- Taft amendment type. The incomplete view should be located in 10609 -- the private declarations of the enclosing scope. 10610 10611 elsif In_Package_Body (Pkg) then 10612 return Inspect_Decls (Private_Declarations (Pkg_Decl), True); 10613 end if; 10614 end if; 10615 end; 10616 10617 -- The type has no incomplete or private view 10618 10619 return Empty; 10620 end Incomplete_Or_Partial_View; 10621 10622 ----------------------------------------- 10623 -- Inherit_Default_Init_Cond_Procedure -- 10624 ----------------------------------------- 10625 10626 procedure Inherit_Default_Init_Cond_Procedure (Typ : Entity_Id) is 10627 Par_Typ : constant Entity_Id := Etype (Typ); 10628 10629 begin 10630 -- A derived type inherits the default initial condition procedure of 10631 -- its parent type. 10632 10633 if No (Default_Init_Cond_Procedure (Typ)) then 10634 Set_Default_Init_Cond_Procedure 10635 (Typ, Default_Init_Cond_Procedure (Par_Typ)); 10636 end if; 10637 end Inherit_Default_Init_Cond_Procedure; 10638 10639 ---------------------------- 10640 -- Inherit_Rep_Item_Chain -- 10641 ---------------------------- 10642 10643 procedure Inherit_Rep_Item_Chain (Typ : Entity_Id; From_Typ : Entity_Id) is 10644 From_Item : constant Node_Id := First_Rep_Item (From_Typ); 10645 Item : Node_Id := Empty; 10646 Last_Item : Node_Id := Empty; 10647 10648 begin 10649 -- Reach the end of the destination type's chain (if any) and capture 10650 -- the last item. 10651 10652 Item := First_Rep_Item (Typ); 10653 while Present (Item) loop 10654 10655 -- Do not inherit a chain that has been inherited already 10656 10657 if Item = From_Item then 10658 return; 10659 end if; 10660 10661 Last_Item := Item; 10662 Item := Next_Rep_Item (Item); 10663 end loop; 10664 10665 Item := First_Rep_Item (From_Typ); 10666 10667 -- Additional check when both parent and current type have rep. 10668 -- items, to prevent circularities when the derivation completes 10669 -- a private declaration and inherits from both views of the parent. 10670 -- There may be a remaining problem with the proper ordering of 10671 -- attribute specifications and aspects on the chains of the four 10672 -- entities involved. ??? 10673 10674 if Present (Item) and then Present (From_Item) then 10675 while Present (Item) loop 10676 if Item = First_Rep_Item (Typ) then 10677 return; 10678 end if; 10679 10680 Item := Next_Rep_Item (Item); 10681 end loop; 10682 end if; 10683 10684 -- When the destination type has a rep item chain, the chain of the 10685 -- source type is appended to it. 10686 10687 if Present (Last_Item) then 10688 Set_Next_Rep_Item (Last_Item, From_Item); 10689 10690 -- Otherwise the destination type directly inherits the rep item chain 10691 -- of the source type (if any). 10692 10693 else 10694 Set_First_Rep_Item (Typ, From_Item); 10695 end if; 10696 end Inherit_Rep_Item_Chain; 10697 10698 --------------------------------- 10699 -- Insert_Explicit_Dereference -- 10700 --------------------------------- 10701 10702 procedure Insert_Explicit_Dereference (N : Node_Id) is 10703 New_Prefix : constant Node_Id := Relocate_Node (N); 10704 Ent : Entity_Id := Empty; 10705 Pref : Node_Id; 10706 I : Interp_Index; 10707 It : Interp; 10708 T : Entity_Id; 10709 10710 begin 10711 Save_Interps (N, New_Prefix); 10712 10713 Rewrite (N, 10714 Make_Explicit_Dereference (Sloc (Parent (N)), 10715 Prefix => New_Prefix)); 10716 10717 Set_Etype (N, Designated_Type (Etype (New_Prefix))); 10718 10719 if Is_Overloaded (New_Prefix) then 10720 10721 -- The dereference is also overloaded, and its interpretations are 10722 -- the designated types of the interpretations of the original node. 10723 10724 Set_Etype (N, Any_Type); 10725 10726 Get_First_Interp (New_Prefix, I, It); 10727 while Present (It.Nam) loop 10728 T := It.Typ; 10729 10730 if Is_Access_Type (T) then 10731 Add_One_Interp (N, Designated_Type (T), Designated_Type (T)); 10732 end if; 10733 10734 Get_Next_Interp (I, It); 10735 end loop; 10736 10737 End_Interp_List; 10738 10739 else 10740 -- Prefix is unambiguous: mark the original prefix (which might 10741 -- Come_From_Source) as a reference, since the new (relocated) one 10742 -- won't be taken into account. 10743 10744 if Is_Entity_Name (New_Prefix) then 10745 Ent := Entity (New_Prefix); 10746 Pref := New_Prefix; 10747 10748 -- For a retrieval of a subcomponent of some composite object, 10749 -- retrieve the ultimate entity if there is one. 10750 10751 elsif Nkind_In (New_Prefix, N_Selected_Component, 10752 N_Indexed_Component) 10753 then 10754 Pref := Prefix (New_Prefix); 10755 while Present (Pref) 10756 and then Nkind_In (Pref, N_Selected_Component, 10757 N_Indexed_Component) 10758 loop 10759 Pref := Prefix (Pref); 10760 end loop; 10761 10762 if Present (Pref) and then Is_Entity_Name (Pref) then 10763 Ent := Entity (Pref); 10764 end if; 10765 end if; 10766 10767 -- Place the reference on the entity node 10768 10769 if Present (Ent) then 10770 Generate_Reference (Ent, Pref); 10771 end if; 10772 end if; 10773 end Insert_Explicit_Dereference; 10774 10775 ------------------------------------------ 10776 -- Inspect_Deferred_Constant_Completion -- 10777 ------------------------------------------ 10778 10779 procedure Inspect_Deferred_Constant_Completion (Decls : List_Id) is 10780 Decl : Node_Id; 10781 10782 begin 10783 Decl := First (Decls); 10784 while Present (Decl) loop 10785 10786 -- Deferred constant signature 10787 10788 if Nkind (Decl) = N_Object_Declaration 10789 and then Constant_Present (Decl) 10790 and then No (Expression (Decl)) 10791 10792 -- No need to check internally generated constants 10793 10794 and then Comes_From_Source (Decl) 10795 10796 -- The constant is not completed. A full object declaration or a 10797 -- pragma Import complete a deferred constant. 10798 10799 and then not Has_Completion (Defining_Identifier (Decl)) 10800 then 10801 Error_Msg_N 10802 ("constant declaration requires initialization expression", 10803 Defining_Identifier (Decl)); 10804 end if; 10805 10806 Decl := Next (Decl); 10807 end loop; 10808 end Inspect_Deferred_Constant_Completion; 10809 10810 ----------------------------- 10811 -- Install_Generic_Formals -- 10812 ----------------------------- 10813 10814 procedure Install_Generic_Formals (Subp_Id : Entity_Id) is 10815 E : Entity_Id; 10816 10817 begin 10818 pragma Assert (Is_Generic_Subprogram (Subp_Id)); 10819 10820 E := First_Entity (Subp_Id); 10821 while Present (E) loop 10822 Install_Entity (E); 10823 Next_Entity (E); 10824 end loop; 10825 end Install_Generic_Formals; 10826 10827 ----------------------------- 10828 -- Is_Actual_Out_Parameter -- 10829 ----------------------------- 10830 10831 function Is_Actual_Out_Parameter (N : Node_Id) return Boolean is 10832 Formal : Entity_Id; 10833 Call : Node_Id; 10834 begin 10835 Find_Actual (N, Formal, Call); 10836 return Present (Formal) and then Ekind (Formal) = E_Out_Parameter; 10837 end Is_Actual_Out_Parameter; 10838 10839 ------------------------- 10840 -- Is_Actual_Parameter -- 10841 ------------------------- 10842 10843 function Is_Actual_Parameter (N : Node_Id) return Boolean is 10844 PK : constant Node_Kind := Nkind (Parent (N)); 10845 10846 begin 10847 case PK is 10848 when N_Parameter_Association => 10849 return N = Explicit_Actual_Parameter (Parent (N)); 10850 10851 when N_Subprogram_Call => 10852 return Is_List_Member (N) 10853 and then 10854 List_Containing (N) = Parameter_Associations (Parent (N)); 10855 10856 when others => 10857 return False; 10858 end case; 10859 end Is_Actual_Parameter; 10860 10861 -------------------------------- 10862 -- Is_Actual_Tagged_Parameter -- 10863 -------------------------------- 10864 10865 function Is_Actual_Tagged_Parameter (N : Node_Id) return Boolean is 10866 Formal : Entity_Id; 10867 Call : Node_Id; 10868 begin 10869 Find_Actual (N, Formal, Call); 10870 return Present (Formal) and then Is_Tagged_Type (Etype (Formal)); 10871 end Is_Actual_Tagged_Parameter; 10872 10873 --------------------- 10874 -- Is_Aliased_View -- 10875 --------------------- 10876 10877 function Is_Aliased_View (Obj : Node_Id) return Boolean is 10878 E : Entity_Id; 10879 10880 begin 10881 if Is_Entity_Name (Obj) then 10882 E := Entity (Obj); 10883 10884 return 10885 (Is_Object (E) 10886 and then 10887 (Is_Aliased (E) 10888 or else (Present (Renamed_Object (E)) 10889 and then Is_Aliased_View (Renamed_Object (E))))) 10890 10891 or else ((Is_Formal (E) 10892 or else Ekind_In (E, E_Generic_In_Out_Parameter, 10893 E_Generic_In_Parameter)) 10894 and then Is_Tagged_Type (Etype (E))) 10895 10896 or else (Is_Concurrent_Type (E) and then In_Open_Scopes (E)) 10897 10898 -- Current instance of type, either directly or as rewritten 10899 -- reference to the current object. 10900 10901 or else (Is_Entity_Name (Original_Node (Obj)) 10902 and then Present (Entity (Original_Node (Obj))) 10903 and then Is_Type (Entity (Original_Node (Obj)))) 10904 10905 or else (Is_Type (E) and then E = Current_Scope) 10906 10907 or else (Is_Incomplete_Or_Private_Type (E) 10908 and then Full_View (E) = Current_Scope) 10909 10910 -- Ada 2012 AI05-0053: the return object of an extended return 10911 -- statement is aliased if its type is immutably limited. 10912 10913 or else (Is_Return_Object (E) 10914 and then Is_Limited_View (Etype (E))); 10915 10916 elsif Nkind (Obj) = N_Selected_Component then 10917 return Is_Aliased (Entity (Selector_Name (Obj))); 10918 10919 elsif Nkind (Obj) = N_Indexed_Component then 10920 return Has_Aliased_Components (Etype (Prefix (Obj))) 10921 or else 10922 (Is_Access_Type (Etype (Prefix (Obj))) 10923 and then Has_Aliased_Components 10924 (Designated_Type (Etype (Prefix (Obj))))); 10925 10926 elsif Nkind_In (Obj, N_Unchecked_Type_Conversion, N_Type_Conversion) then 10927 return Is_Tagged_Type (Etype (Obj)) 10928 and then Is_Aliased_View (Expression (Obj)); 10929 10930 elsif Nkind (Obj) = N_Explicit_Dereference then 10931 return Nkind (Original_Node (Obj)) /= N_Function_Call; 10932 10933 else 10934 return False; 10935 end if; 10936 end Is_Aliased_View; 10937 10938 ------------------------- 10939 -- Is_Ancestor_Package -- 10940 ------------------------- 10941 10942 function Is_Ancestor_Package 10943 (E1 : Entity_Id; 10944 E2 : Entity_Id) return Boolean 10945 is 10946 Par : Entity_Id; 10947 10948 begin 10949 Par := E2; 10950 while Present (Par) and then Par /= Standard_Standard loop 10951 if Par = E1 then 10952 return True; 10953 end if; 10954 10955 Par := Scope (Par); 10956 end loop; 10957 10958 return False; 10959 end Is_Ancestor_Package; 10960 10961 ---------------------- 10962 -- Is_Atomic_Object -- 10963 ---------------------- 10964 10965 function Is_Atomic_Object (N : Node_Id) return Boolean is 10966 10967 function Object_Has_Atomic_Components (N : Node_Id) return Boolean; 10968 -- Determines if given object has atomic components 10969 10970 function Is_Atomic_Prefix (N : Node_Id) return Boolean; 10971 -- If prefix is an implicit dereference, examine designated type 10972 10973 ---------------------- 10974 -- Is_Atomic_Prefix -- 10975 ---------------------- 10976 10977 function Is_Atomic_Prefix (N : Node_Id) return Boolean is 10978 begin 10979 if Is_Access_Type (Etype (N)) then 10980 return 10981 Has_Atomic_Components (Designated_Type (Etype (N))); 10982 else 10983 return Object_Has_Atomic_Components (N); 10984 end if; 10985 end Is_Atomic_Prefix; 10986 10987 ---------------------------------- 10988 -- Object_Has_Atomic_Components -- 10989 ---------------------------------- 10990 10991 function Object_Has_Atomic_Components (N : Node_Id) return Boolean is 10992 begin 10993 if Has_Atomic_Components (Etype (N)) 10994 or else Is_Atomic (Etype (N)) 10995 then 10996 return True; 10997 10998 elsif Is_Entity_Name (N) 10999 and then (Has_Atomic_Components (Entity (N)) 11000 or else Is_Atomic (Entity (N))) 11001 then 11002 return True; 11003 11004 elsif Nkind (N) = N_Selected_Component 11005 and then Is_Atomic (Entity (Selector_Name (N))) 11006 then 11007 return True; 11008 11009 elsif Nkind (N) = N_Indexed_Component 11010 or else Nkind (N) = N_Selected_Component 11011 then 11012 return Is_Atomic_Prefix (Prefix (N)); 11013 11014 else 11015 return False; 11016 end if; 11017 end Object_Has_Atomic_Components; 11018 11019 -- Start of processing for Is_Atomic_Object 11020 11021 begin 11022 -- Predicate is not relevant to subprograms 11023 11024 if Is_Entity_Name (N) and then Is_Overloadable (Entity (N)) then 11025 return False; 11026 11027 elsif Is_Atomic (Etype (N)) 11028 or else (Is_Entity_Name (N) and then Is_Atomic (Entity (N))) 11029 then 11030 return True; 11031 11032 elsif Nkind (N) = N_Selected_Component 11033 and then Is_Atomic (Entity (Selector_Name (N))) 11034 then 11035 return True; 11036 11037 elsif Nkind (N) = N_Indexed_Component 11038 or else Nkind (N) = N_Selected_Component 11039 then 11040 return Is_Atomic_Prefix (Prefix (N)); 11041 11042 else 11043 return False; 11044 end if; 11045 end Is_Atomic_Object; 11046 11047 ----------------------------- 11048 -- Is_Atomic_Or_VFA_Object -- 11049 ----------------------------- 11050 11051 function Is_Atomic_Or_VFA_Object (N : Node_Id) return Boolean is 11052 begin 11053 return Is_Atomic_Object (N) 11054 or else (Is_Object_Reference (N) 11055 and then Is_Entity_Name (N) 11056 and then (Is_Volatile_Full_Access (Entity (N)) 11057 or else 11058 Is_Volatile_Full_Access (Etype (Entity (N))))); 11059 end Is_Atomic_Or_VFA_Object; 11060 11061 ------------------------- 11062 -- Is_Attribute_Result -- 11063 ------------------------- 11064 11065 function Is_Attribute_Result (N : Node_Id) return Boolean is 11066 begin 11067 return Nkind (N) = N_Attribute_Reference 11068 and then Attribute_Name (N) = Name_Result; 11069 end Is_Attribute_Result; 11070 11071 ------------------------- 11072 -- Is_Attribute_Update -- 11073 ------------------------- 11074 11075 function Is_Attribute_Update (N : Node_Id) return Boolean is 11076 begin 11077 return Nkind (N) = N_Attribute_Reference 11078 and then Attribute_Name (N) = Name_Update; 11079 end Is_Attribute_Update; 11080 11081 ------------------------------------ 11082 -- Is_Body_Or_Package_Declaration -- 11083 ------------------------------------ 11084 11085 function Is_Body_Or_Package_Declaration (N : Node_Id) return Boolean is 11086 begin 11087 return Nkind_In (N, N_Entry_Body, 11088 N_Package_Body, 11089 N_Package_Declaration, 11090 N_Protected_Body, 11091 N_Subprogram_Body, 11092 N_Task_Body); 11093 end Is_Body_Or_Package_Declaration; 11094 11095 ----------------------- 11096 -- Is_Bounded_String -- 11097 ----------------------- 11098 11099 function Is_Bounded_String (T : Entity_Id) return Boolean is 11100 Under : constant Entity_Id := Underlying_Type (Root_Type (T)); 11101 11102 begin 11103 -- Check whether T is ultimately derived from Ada.Strings.Superbounded. 11104 -- Super_String, or one of the [Wide_]Wide_ versions. This will 11105 -- be True for all the Bounded_String types in instances of the 11106 -- Generic_Bounded_Length generics, and for types derived from those. 11107 11108 return Present (Under) 11109 and then (Is_RTE (Root_Type (Under), RO_SU_Super_String) or else 11110 Is_RTE (Root_Type (Under), RO_WI_Super_String) or else 11111 Is_RTE (Root_Type (Under), RO_WW_Super_String)); 11112 end Is_Bounded_String; 11113 11114 ------------------------- 11115 -- Is_Child_Or_Sibling -- 11116 ------------------------- 11117 11118 function Is_Child_Or_Sibling 11119 (Pack_1 : Entity_Id; 11120 Pack_2 : Entity_Id) return Boolean 11121 is 11122 function Distance_From_Standard (Pack : Entity_Id) return Nat; 11123 -- Given an arbitrary package, return the number of "climbs" necessary 11124 -- to reach scope Standard_Standard. 11125 11126 procedure Equalize_Depths 11127 (Pack : in out Entity_Id; 11128 Depth : in out Nat; 11129 Depth_To_Reach : Nat); 11130 -- Given an arbitrary package, its depth and a target depth to reach, 11131 -- climb the scope chain until the said depth is reached. The pointer 11132 -- to the package and its depth a modified during the climb. 11133 11134 ---------------------------- 11135 -- Distance_From_Standard -- 11136 ---------------------------- 11137 11138 function Distance_From_Standard (Pack : Entity_Id) return Nat is 11139 Dist : Nat; 11140 Scop : Entity_Id; 11141 11142 begin 11143 Dist := 0; 11144 Scop := Pack; 11145 while Present (Scop) and then Scop /= Standard_Standard loop 11146 Dist := Dist + 1; 11147 Scop := Scope (Scop); 11148 end loop; 11149 11150 return Dist; 11151 end Distance_From_Standard; 11152 11153 --------------------- 11154 -- Equalize_Depths -- 11155 --------------------- 11156 11157 procedure Equalize_Depths 11158 (Pack : in out Entity_Id; 11159 Depth : in out Nat; 11160 Depth_To_Reach : Nat) 11161 is 11162 begin 11163 -- The package must be at a greater or equal depth 11164 11165 if Depth < Depth_To_Reach then 11166 raise Program_Error; 11167 end if; 11168 11169 -- Climb the scope chain until the desired depth is reached 11170 11171 while Present (Pack) and then Depth /= Depth_To_Reach loop 11172 Pack := Scope (Pack); 11173 Depth := Depth - 1; 11174 end loop; 11175 end Equalize_Depths; 11176 11177 -- Local variables 11178 11179 P_1 : Entity_Id := Pack_1; 11180 P_1_Child : Boolean := False; 11181 P_1_Depth : Nat := Distance_From_Standard (P_1); 11182 P_2 : Entity_Id := Pack_2; 11183 P_2_Child : Boolean := False; 11184 P_2_Depth : Nat := Distance_From_Standard (P_2); 11185 11186 -- Start of processing for Is_Child_Or_Sibling 11187 11188 begin 11189 pragma Assert 11190 (Ekind (Pack_1) = E_Package and then Ekind (Pack_2) = E_Package); 11191 11192 -- Both packages denote the same entity, therefore they cannot be 11193 -- children or siblings. 11194 11195 if P_1 = P_2 then 11196 return False; 11197 11198 -- One of the packages is at a deeper level than the other. Note that 11199 -- both may still come from differen hierarchies. 11200 11201 -- (root) P_2 11202 -- / \ : 11203 -- X P_2 or X 11204 -- : : 11205 -- P_1 P_1 11206 11207 elsif P_1_Depth > P_2_Depth then 11208 Equalize_Depths 11209 (Pack => P_1, 11210 Depth => P_1_Depth, 11211 Depth_To_Reach => P_2_Depth); 11212 P_1_Child := True; 11213 11214 -- (root) P_1 11215 -- / \ : 11216 -- P_1 X or X 11217 -- : : 11218 -- P_2 P_2 11219 11220 elsif P_2_Depth > P_1_Depth then 11221 Equalize_Depths 11222 (Pack => P_2, 11223 Depth => P_2_Depth, 11224 Depth_To_Reach => P_1_Depth); 11225 P_2_Child := True; 11226 end if; 11227 11228 -- At this stage the package pointers have been elevated to the same 11229 -- depth. If the related entities are the same, then one package is a 11230 -- potential child of the other: 11231 11232 -- P_1 11233 -- : 11234 -- X became P_1 P_2 or vica versa 11235 -- : 11236 -- P_2 11237 11238 if P_1 = P_2 then 11239 if P_1_Child then 11240 return Is_Child_Unit (Pack_1); 11241 11242 else pragma Assert (P_2_Child); 11243 return Is_Child_Unit (Pack_2); 11244 end if; 11245 11246 -- The packages may come from the same package chain or from entirely 11247 -- different hierarcies. To determine this, climb the scope stack until 11248 -- a common root is found. 11249 11250 -- (root) (root 1) (root 2) 11251 -- / \ | | 11252 -- P_1 P_2 P_1 P_2 11253 11254 else 11255 while Present (P_1) and then Present (P_2) loop 11256 11257 -- The two packages may be siblings 11258 11259 if P_1 = P_2 then 11260 return Is_Child_Unit (Pack_1) and then Is_Child_Unit (Pack_2); 11261 end if; 11262 11263 P_1 := Scope (P_1); 11264 P_2 := Scope (P_2); 11265 end loop; 11266 end if; 11267 11268 return False; 11269 end Is_Child_Or_Sibling; 11270 11271 ----------------------------- 11272 -- Is_Concurrent_Interface -- 11273 ----------------------------- 11274 11275 function Is_Concurrent_Interface (T : Entity_Id) return Boolean is 11276 begin 11277 return Is_Interface (T) 11278 and then 11279 (Is_Protected_Interface (T) 11280 or else Is_Synchronized_Interface (T) 11281 or else Is_Task_Interface (T)); 11282 end Is_Concurrent_Interface; 11283 11284 ----------------------- 11285 -- Is_Constant_Bound -- 11286 ----------------------- 11287 11288 function Is_Constant_Bound (Exp : Node_Id) return Boolean is 11289 begin 11290 if Compile_Time_Known_Value (Exp) then 11291 return True; 11292 11293 elsif Is_Entity_Name (Exp) and then Present (Entity (Exp)) then 11294 return Is_Constant_Object (Entity (Exp)) 11295 or else Ekind (Entity (Exp)) = E_Enumeration_Literal; 11296 11297 elsif Nkind (Exp) in N_Binary_Op then 11298 return Is_Constant_Bound (Left_Opnd (Exp)) 11299 and then Is_Constant_Bound (Right_Opnd (Exp)) 11300 and then Scope (Entity (Exp)) = Standard_Standard; 11301 11302 else 11303 return False; 11304 end if; 11305 end Is_Constant_Bound; 11306 11307 --------------------------- 11308 -- Is_Container_Element -- 11309 --------------------------- 11310 11311 function Is_Container_Element (Exp : Node_Id) return Boolean is 11312 Loc : constant Source_Ptr := Sloc (Exp); 11313 Pref : constant Node_Id := Prefix (Exp); 11314 11315 Call : Node_Id; 11316 -- Call to an indexing aspect 11317 11318 Cont_Typ : Entity_Id; 11319 -- The type of the container being accessed 11320 11321 Elem_Typ : Entity_Id; 11322 -- Its element type 11323 11324 Indexing : Entity_Id; 11325 Is_Const : Boolean; 11326 -- Indicates that constant indexing is used, and the element is thus 11327 -- a constant. 11328 11329 Ref_Typ : Entity_Id; 11330 -- The reference type returned by the indexing operation 11331 11332 begin 11333 -- If C is a container, in a context that imposes the element type of 11334 -- that container, the indexing notation C (X) is rewritten as: 11335 11336 -- Indexing (C, X).Discr.all 11337 11338 -- where Indexing is one of the indexing aspects of the container. 11339 -- If the context does not require a reference, the construct can be 11340 -- rewritten as 11341 11342 -- Element (C, X) 11343 11344 -- First, verify that the construct has the proper form 11345 11346 if not Expander_Active then 11347 return False; 11348 11349 elsif Nkind (Pref) /= N_Selected_Component then 11350 return False; 11351 11352 elsif Nkind (Prefix (Pref)) /= N_Function_Call then 11353 return False; 11354 11355 else 11356 Call := Prefix (Pref); 11357 Ref_Typ := Etype (Call); 11358 end if; 11359 11360 if not Has_Implicit_Dereference (Ref_Typ) 11361 or else No (First (Parameter_Associations (Call))) 11362 or else not Is_Entity_Name (Name (Call)) 11363 then 11364 return False; 11365 end if; 11366 11367 -- Retrieve type of container object, and its iterator aspects 11368 11369 Cont_Typ := Etype (First (Parameter_Associations (Call))); 11370 Indexing := Find_Value_Of_Aspect (Cont_Typ, Aspect_Constant_Indexing); 11371 Is_Const := False; 11372 11373 if No (Indexing) then 11374 11375 -- Container should have at least one indexing operation 11376 11377 return False; 11378 11379 elsif Entity (Name (Call)) /= Entity (Indexing) then 11380 11381 -- This may be a variable indexing operation 11382 11383 Indexing := Find_Value_Of_Aspect (Cont_Typ, Aspect_Variable_Indexing); 11384 11385 if No (Indexing) 11386 or else Entity (Name (Call)) /= Entity (Indexing) 11387 then 11388 return False; 11389 end if; 11390 11391 else 11392 Is_Const := True; 11393 end if; 11394 11395 Elem_Typ := Find_Value_Of_Aspect (Cont_Typ, Aspect_Iterator_Element); 11396 11397 if No (Elem_Typ) or else Entity (Elem_Typ) /= Etype (Exp) then 11398 return False; 11399 end if; 11400 11401 -- Check that the expression is not the target of an assignment, in 11402 -- which case the rewriting is not possible. 11403 11404 if not Is_Const then 11405 declare 11406 Par : Node_Id; 11407 11408 begin 11409 Par := Exp; 11410 while Present (Par) 11411 loop 11412 if Nkind (Parent (Par)) = N_Assignment_Statement 11413 and then Par = Name (Parent (Par)) 11414 then 11415 return False; 11416 11417 -- A renaming produces a reference, and the transformation 11418 -- does not apply. 11419 11420 elsif Nkind (Parent (Par)) = N_Object_Renaming_Declaration then 11421 return False; 11422 11423 elsif Nkind_In 11424 (Nkind (Parent (Par)), N_Function_Call, 11425 N_Procedure_Call_Statement, 11426 N_Entry_Call_Statement) 11427 then 11428 -- Check that the element is not part of an actual for an 11429 -- in-out parameter. 11430 11431 declare 11432 F : Entity_Id; 11433 A : Node_Id; 11434 11435 begin 11436 F := First_Formal (Entity (Name (Parent (Par)))); 11437 A := First (Parameter_Associations (Parent (Par))); 11438 while Present (F) loop 11439 if A = Par and then Ekind (F) /= E_In_Parameter then 11440 return False; 11441 end if; 11442 11443 Next_Formal (F); 11444 Next (A); 11445 end loop; 11446 end; 11447 11448 -- E_In_Parameter in a call: element is not modified. 11449 11450 exit; 11451 end if; 11452 11453 Par := Parent (Par); 11454 end loop; 11455 end; 11456 end if; 11457 11458 -- The expression has the proper form and the context requires the 11459 -- element type. Retrieve the Element function of the container and 11460 -- rewrite the construct as a call to it. 11461 11462 declare 11463 Op : Elmt_Id; 11464 11465 begin 11466 Op := First_Elmt (Primitive_Operations (Cont_Typ)); 11467 while Present (Op) loop 11468 exit when Chars (Node (Op)) = Name_Element; 11469 Next_Elmt (Op); 11470 end loop; 11471 11472 if No (Op) then 11473 return False; 11474 11475 else 11476 Rewrite (Exp, 11477 Make_Function_Call (Loc, 11478 Name => New_Occurrence_Of (Node (Op), Loc), 11479 Parameter_Associations => Parameter_Associations (Call))); 11480 Analyze_And_Resolve (Exp, Entity (Elem_Typ)); 11481 return True; 11482 end if; 11483 end; 11484 end Is_Container_Element; 11485 11486 ---------------------------- 11487 -- Is_Contract_Annotation -- 11488 ---------------------------- 11489 11490 function Is_Contract_Annotation (Item : Node_Id) return Boolean is 11491 begin 11492 return Is_Package_Contract_Annotation (Item) 11493 or else 11494 Is_Subprogram_Contract_Annotation (Item); 11495 end Is_Contract_Annotation; 11496 11497 -------------------------------------- 11498 -- Is_Controlling_Limited_Procedure -- 11499 -------------------------------------- 11500 11501 function Is_Controlling_Limited_Procedure 11502 (Proc_Nam : Entity_Id) return Boolean 11503 is 11504 Param_Typ : Entity_Id := Empty; 11505 11506 begin 11507 if Ekind (Proc_Nam) = E_Procedure 11508 and then Present (Parameter_Specifications (Parent (Proc_Nam))) 11509 then 11510 Param_Typ := Etype (Parameter_Type (First ( 11511 Parameter_Specifications (Parent (Proc_Nam))))); 11512 11513 -- In this case where an Itype was created, the procedure call has been 11514 -- rewritten. 11515 11516 elsif Present (Associated_Node_For_Itype (Proc_Nam)) 11517 and then Present (Original_Node (Associated_Node_For_Itype (Proc_Nam))) 11518 and then 11519 Present (Parameter_Associations 11520 (Associated_Node_For_Itype (Proc_Nam))) 11521 then 11522 Param_Typ := 11523 Etype (First (Parameter_Associations 11524 (Associated_Node_For_Itype (Proc_Nam)))); 11525 end if; 11526 11527 if Present (Param_Typ) then 11528 return 11529 Is_Interface (Param_Typ) 11530 and then Is_Limited_Record (Param_Typ); 11531 end if; 11532 11533 return False; 11534 end Is_Controlling_Limited_Procedure; 11535 11536 ----------------------------- 11537 -- Is_CPP_Constructor_Call -- 11538 ----------------------------- 11539 11540 function Is_CPP_Constructor_Call (N : Node_Id) return Boolean is 11541 begin 11542 return Nkind (N) = N_Function_Call 11543 and then Is_CPP_Class (Etype (Etype (N))) 11544 and then Is_Constructor (Entity (Name (N))) 11545 and then Is_Imported (Entity (Name (N))); 11546 end Is_CPP_Constructor_Call; 11547 11548 ------------------------- 11549 -- Is_Current_Instance -- 11550 ------------------------- 11551 11552 function Is_Current_Instance (N : Node_Id) return Boolean is 11553 Typ : constant Entity_Id := Entity (N); 11554 P : Node_Id; 11555 11556 begin 11557 -- Simplest case: entity is a concurrent type and we are currently 11558 -- inside the body. This will eventually be expanded into a 11559 -- call to Self (for tasks) or _object (for protected objects). 11560 11561 if Is_Concurrent_Type (Typ) and then In_Open_Scopes (Typ) then 11562 return True; 11563 11564 else 11565 -- Check whether the context is a (sub)type declaration for the 11566 -- type entity. 11567 11568 P := Parent (N); 11569 while Present (P) loop 11570 if Nkind_In (P, N_Full_Type_Declaration, 11571 N_Private_Type_Declaration, 11572 N_Subtype_Declaration) 11573 and then Comes_From_Source (P) 11574 and then Defining_Entity (P) = Typ 11575 then 11576 return True; 11577 end if; 11578 11579 P := Parent (P); 11580 end loop; 11581 end if; 11582 11583 -- In any other context this is not a current occurrence 11584 11585 return False; 11586 end Is_Current_Instance; 11587 11588 -------------------- 11589 -- Is_Declaration -- 11590 -------------------- 11591 11592 function Is_Declaration (N : Node_Id) return Boolean is 11593 begin 11594 case Nkind (N) is 11595 when N_Abstract_Subprogram_Declaration | 11596 N_Exception_Declaration | 11597 N_Exception_Renaming_Declaration | 11598 N_Full_Type_Declaration | 11599 N_Generic_Function_Renaming_Declaration | 11600 N_Generic_Package_Declaration | 11601 N_Generic_Package_Renaming_Declaration | 11602 N_Generic_Procedure_Renaming_Declaration | 11603 N_Generic_Subprogram_Declaration | 11604 N_Number_Declaration | 11605 N_Object_Declaration | 11606 N_Object_Renaming_Declaration | 11607 N_Package_Declaration | 11608 N_Package_Renaming_Declaration | 11609 N_Private_Extension_Declaration | 11610 N_Private_Type_Declaration | 11611 N_Subprogram_Declaration | 11612 N_Subprogram_Renaming_Declaration | 11613 N_Subtype_Declaration => 11614 return True; 11615 11616 when others => 11617 return False; 11618 end case; 11619 end Is_Declaration; 11620 11621 -------------------------------- 11622 -- Is_Declared_Within_Variant -- 11623 -------------------------------- 11624 11625 function Is_Declared_Within_Variant (Comp : Entity_Id) return Boolean is 11626 Comp_Decl : constant Node_Id := Parent (Comp); 11627 Comp_List : constant Node_Id := Parent (Comp_Decl); 11628 begin 11629 return Nkind (Parent (Comp_List)) = N_Variant; 11630 end Is_Declared_Within_Variant; 11631 11632 ---------------------------------------------- 11633 -- Is_Dependent_Component_Of_Mutable_Object -- 11634 ---------------------------------------------- 11635 11636 function Is_Dependent_Component_Of_Mutable_Object 11637 (Object : Node_Id) return Boolean 11638 is 11639 P : Node_Id; 11640 Prefix_Type : Entity_Id; 11641 P_Aliased : Boolean := False; 11642 Comp : Entity_Id; 11643 11644 Deref : Node_Id := Object; 11645 -- Dereference node, in something like X.all.Y(2) 11646 11647 -- Start of processing for Is_Dependent_Component_Of_Mutable_Object 11648 11649 begin 11650 -- Find the dereference node if any 11651 11652 while Nkind_In (Deref, N_Indexed_Component, 11653 N_Selected_Component, 11654 N_Slice) 11655 loop 11656 Deref := Prefix (Deref); 11657 end loop; 11658 11659 -- Ada 2005: If we have a component or slice of a dereference, 11660 -- something like X.all.Y (2), and the type of X is access-to-constant, 11661 -- Is_Variable will return False, because it is indeed a constant 11662 -- view. But it might be a view of a variable object, so we want the 11663 -- following condition to be True in that case. 11664 11665 if Is_Variable (Object) 11666 or else (Ada_Version >= Ada_2005 11667 and then Nkind (Deref) = N_Explicit_Dereference) 11668 then 11669 if Nkind (Object) = N_Selected_Component then 11670 P := Prefix (Object); 11671 Prefix_Type := Etype (P); 11672 11673 if Is_Entity_Name (P) then 11674 if Ekind (Entity (P)) = E_Generic_In_Out_Parameter then 11675 Prefix_Type := Base_Type (Prefix_Type); 11676 end if; 11677 11678 if Is_Aliased (Entity (P)) then 11679 P_Aliased := True; 11680 end if; 11681 11682 -- A discriminant check on a selected component may be expanded 11683 -- into a dereference when removing side-effects. Recover the 11684 -- original node and its type, which may be unconstrained. 11685 11686 elsif Nkind (P) = N_Explicit_Dereference 11687 and then not (Comes_From_Source (P)) 11688 then 11689 P := Original_Node (P); 11690 Prefix_Type := Etype (P); 11691 11692 else 11693 -- Check for prefix being an aliased component??? 11694 11695 null; 11696 11697 end if; 11698 11699 -- A heap object is constrained by its initial value 11700 11701 -- Ada 2005 (AI-363): Always assume the object could be mutable in 11702 -- the dereferenced case, since the access value might denote an 11703 -- unconstrained aliased object, whereas in Ada 95 the designated 11704 -- object is guaranteed to be constrained. A worst-case assumption 11705 -- has to apply in Ada 2005 because we can't tell at compile 11706 -- time whether the object is "constrained by its initial value" 11707 -- (despite the fact that 3.10.2(26/2) and 8.5.1(5/2) are semantic 11708 -- rules (these rules are acknowledged to need fixing). 11709 11710 if Ada_Version < Ada_2005 then 11711 if Is_Access_Type (Prefix_Type) 11712 or else Nkind (P) = N_Explicit_Dereference 11713 then 11714 return False; 11715 end if; 11716 11717 else pragma Assert (Ada_Version >= Ada_2005); 11718 if Is_Access_Type (Prefix_Type) then 11719 11720 -- If the access type is pool-specific, and there is no 11721 -- constrained partial view of the designated type, then the 11722 -- designated object is known to be constrained. 11723 11724 if Ekind (Prefix_Type) = E_Access_Type 11725 and then not Object_Type_Has_Constrained_Partial_View 11726 (Typ => Designated_Type (Prefix_Type), 11727 Scop => Current_Scope) 11728 then 11729 return False; 11730 11731 -- Otherwise (general access type, or there is a constrained 11732 -- partial view of the designated type), we need to check 11733 -- based on the designated type. 11734 11735 else 11736 Prefix_Type := Designated_Type (Prefix_Type); 11737 end if; 11738 end if; 11739 end if; 11740 11741 Comp := 11742 Original_Record_Component (Entity (Selector_Name (Object))); 11743 11744 -- As per AI-0017, the renaming is illegal in a generic body, even 11745 -- if the subtype is indefinite. 11746 11747 -- Ada 2005 (AI-363): In Ada 2005 an aliased object can be mutable 11748 11749 if not Is_Constrained (Prefix_Type) 11750 and then (Is_Definite_Subtype (Prefix_Type) 11751 or else 11752 (Is_Generic_Type (Prefix_Type) 11753 and then Ekind (Current_Scope) = E_Generic_Package 11754 and then In_Package_Body (Current_Scope))) 11755 11756 and then (Is_Declared_Within_Variant (Comp) 11757 or else Has_Discriminant_Dependent_Constraint (Comp)) 11758 and then (not P_Aliased or else Ada_Version >= Ada_2005) 11759 then 11760 return True; 11761 11762 -- If the prefix is of an access type at this point, then we want 11763 -- to return False, rather than calling this function recursively 11764 -- on the access object (which itself might be a discriminant- 11765 -- dependent component of some other object, but that isn't 11766 -- relevant to checking the object passed to us). This avoids 11767 -- issuing wrong errors when compiling with -gnatc, where there 11768 -- can be implicit dereferences that have not been expanded. 11769 11770 elsif Is_Access_Type (Etype (Prefix (Object))) then 11771 return False; 11772 11773 else 11774 return 11775 Is_Dependent_Component_Of_Mutable_Object (Prefix (Object)); 11776 end if; 11777 11778 elsif Nkind (Object) = N_Indexed_Component 11779 or else Nkind (Object) = N_Slice 11780 then 11781 return Is_Dependent_Component_Of_Mutable_Object (Prefix (Object)); 11782 11783 -- A type conversion that Is_Variable is a view conversion: 11784 -- go back to the denoted object. 11785 11786 elsif Nkind (Object) = N_Type_Conversion then 11787 return 11788 Is_Dependent_Component_Of_Mutable_Object (Expression (Object)); 11789 end if; 11790 end if; 11791 11792 return False; 11793 end Is_Dependent_Component_Of_Mutable_Object; 11794 11795 --------------------- 11796 -- Is_Dereferenced -- 11797 --------------------- 11798 11799 function Is_Dereferenced (N : Node_Id) return Boolean is 11800 P : constant Node_Id := Parent (N); 11801 begin 11802 return Nkind_In (P, N_Selected_Component, 11803 N_Explicit_Dereference, 11804 N_Indexed_Component, 11805 N_Slice) 11806 and then Prefix (P) = N; 11807 end Is_Dereferenced; 11808 11809 ---------------------- 11810 -- Is_Descendent_Of -- 11811 ---------------------- 11812 11813 function Is_Descendent_Of (T1 : Entity_Id; T2 : Entity_Id) return Boolean is 11814 T : Entity_Id; 11815 Etyp : Entity_Id; 11816 11817 begin 11818 pragma Assert (Nkind (T1) in N_Entity); 11819 pragma Assert (Nkind (T2) in N_Entity); 11820 11821 T := Base_Type (T1); 11822 11823 -- Immediate return if the types match 11824 11825 if T = T2 then 11826 return True; 11827 11828 -- Comment needed here ??? 11829 11830 elsif Ekind (T) = E_Class_Wide_Type then 11831 return Etype (T) = T2; 11832 11833 -- All other cases 11834 11835 else 11836 loop 11837 Etyp := Etype (T); 11838 11839 -- Done if we found the type we are looking for 11840 11841 if Etyp = T2 then 11842 return True; 11843 11844 -- Done if no more derivations to check 11845 11846 elsif T = T1 11847 or else T = Etyp 11848 then 11849 return False; 11850 11851 -- Following test catches error cases resulting from prev errors 11852 11853 elsif No (Etyp) then 11854 return False; 11855 11856 elsif Is_Private_Type (T) and then Etyp = Full_View (T) then 11857 return False; 11858 11859 elsif Is_Private_Type (Etyp) and then Full_View (Etyp) = T then 11860 return False; 11861 end if; 11862 11863 T := Base_Type (Etyp); 11864 end loop; 11865 end if; 11866 end Is_Descendent_Of; 11867 11868 ---------------------------------------- 11869 -- Is_Descendant_Of_Suspension_Object -- 11870 ---------------------------------------- 11871 11872 function Is_Descendant_Of_Suspension_Object 11873 (Typ : Entity_Id) return Boolean 11874 is 11875 Cur_Typ : Entity_Id; 11876 Par_Typ : Entity_Id; 11877 11878 begin 11879 -- Climb the type derivation chain checking each parent type against 11880 -- Suspension_Object. 11881 11882 Cur_Typ := Base_Type (Typ); 11883 while Present (Cur_Typ) loop 11884 Par_Typ := Etype (Cur_Typ); 11885 11886 -- The current type is a match 11887 11888 if Is_Suspension_Object (Cur_Typ) then 11889 return True; 11890 11891 -- Stop the traversal once the root of the derivation chain has been 11892 -- reached. In that case the current type is its own base type. 11893 11894 elsif Cur_Typ = Par_Typ then 11895 exit; 11896 end if; 11897 11898 Cur_Typ := Base_Type (Par_Typ); 11899 end loop; 11900 11901 return False; 11902 end Is_Descendant_Of_Suspension_Object; 11903 11904 --------------------------------------------- 11905 -- Is_Double_Precision_Floating_Point_Type -- 11906 --------------------------------------------- 11907 11908 function Is_Double_Precision_Floating_Point_Type 11909 (E : Entity_Id) return Boolean is 11910 begin 11911 return Is_Floating_Point_Type (E) 11912 and then Machine_Radix_Value (E) = Uint_2 11913 and then Machine_Mantissa_Value (E) = UI_From_Int (53) 11914 and then Machine_Emax_Value (E) = Uint_2 ** Uint_10 11915 and then Machine_Emin_Value (E) = Uint_3 - (Uint_2 ** Uint_10); 11916 end Is_Double_Precision_Floating_Point_Type; 11917 11918 ----------------------------- 11919 -- Is_Effectively_Volatile -- 11920 ----------------------------- 11921 11922 function Is_Effectively_Volatile (Id : Entity_Id) return Boolean is 11923 begin 11924 if Is_Type (Id) then 11925 11926 -- An arbitrary type is effectively volatile when it is subject to 11927 -- pragma Atomic or Volatile. 11928 11929 if Is_Volatile (Id) then 11930 return True; 11931 11932 -- An array type is effectively volatile when it is subject to pragma 11933 -- Atomic_Components or Volatile_Components or its compolent type is 11934 -- effectively volatile. 11935 11936 elsif Is_Array_Type (Id) then 11937 return 11938 Has_Volatile_Components (Id) 11939 or else 11940 Is_Effectively_Volatile (Component_Type (Base_Type (Id))); 11941 11942 -- A protected type is always volatile 11943 11944 elsif Is_Protected_Type (Id) then 11945 return True; 11946 11947 -- A descendant of Ada.Synchronous_Task_Control.Suspension_Object is 11948 -- automatically volatile. 11949 11950 elsif Is_Descendant_Of_Suspension_Object (Id) then 11951 return True; 11952 11953 -- Otherwise the type is not effectively volatile 11954 11955 else 11956 return False; 11957 end if; 11958 11959 -- Otherwise Id denotes an object 11960 11961 else 11962 return 11963 Is_Volatile (Id) 11964 or else Has_Volatile_Components (Id) 11965 or else Is_Effectively_Volatile (Etype (Id)); 11966 end if; 11967 end Is_Effectively_Volatile; 11968 11969 ------------------------------------ 11970 -- Is_Effectively_Volatile_Object -- 11971 ------------------------------------ 11972 11973 function Is_Effectively_Volatile_Object (N : Node_Id) return Boolean is 11974 begin 11975 if Is_Entity_Name (N) then 11976 return Is_Effectively_Volatile (Entity (N)); 11977 11978 elsif Nkind (N) = N_Expanded_Name then 11979 return Is_Effectively_Volatile (Entity (N)); 11980 11981 elsif Nkind (N) = N_Indexed_Component then 11982 return Is_Effectively_Volatile_Object (Prefix (N)); 11983 11984 elsif Nkind (N) = N_Selected_Component then 11985 return 11986 Is_Effectively_Volatile_Object (Prefix (N)) 11987 or else 11988 Is_Effectively_Volatile_Object (Selector_Name (N)); 11989 11990 else 11991 return False; 11992 end if; 11993 end Is_Effectively_Volatile_Object; 11994 11995 ------------------- 11996 -- Is_Entry_Body -- 11997 ------------------- 11998 11999 function Is_Entry_Body (Id : Entity_Id) return Boolean is 12000 begin 12001 return 12002 Ekind_In (Id, E_Entry, E_Entry_Family) 12003 and then Nkind (Unit_Declaration_Node (Id)) = N_Entry_Body; 12004 end Is_Entry_Body; 12005 12006 -------------------------- 12007 -- Is_Entry_Declaration -- 12008 -------------------------- 12009 12010 function Is_Entry_Declaration (Id : Entity_Id) return Boolean is 12011 begin 12012 return 12013 Ekind_In (Id, E_Entry, E_Entry_Family) 12014 and then Nkind (Unit_Declaration_Node (Id)) = N_Entry_Declaration; 12015 end Is_Entry_Declaration; 12016 12017 ---------------------------- 12018 -- Is_Expression_Function -- 12019 ---------------------------- 12020 12021 function Is_Expression_Function (Subp : Entity_Id) return Boolean is 12022 begin 12023 if Ekind_In (Subp, E_Function, E_Subprogram_Body) then 12024 return 12025 Nkind (Original_Node (Unit_Declaration_Node (Subp))) = 12026 N_Expression_Function; 12027 else 12028 return False; 12029 end if; 12030 end Is_Expression_Function; 12031 12032 ------------------------------------------ 12033 -- Is_Expression_Function_Or_Completion -- 12034 ------------------------------------------ 12035 12036 function Is_Expression_Function_Or_Completion 12037 (Subp : Entity_Id) return Boolean 12038 is 12039 Subp_Decl : Node_Id; 12040 12041 begin 12042 if Ekind (Subp) = E_Function then 12043 Subp_Decl := Unit_Declaration_Node (Subp); 12044 12045 -- The function declaration is either an expression function or is 12046 -- completed by an expression function body. 12047 12048 return 12049 Is_Expression_Function (Subp) 12050 or else (Nkind (Subp_Decl) = N_Subprogram_Declaration 12051 and then Present (Corresponding_Body (Subp_Decl)) 12052 and then Is_Expression_Function 12053 (Corresponding_Body (Subp_Decl))); 12054 12055 elsif Ekind (Subp) = E_Subprogram_Body then 12056 return Is_Expression_Function (Subp); 12057 12058 else 12059 return False; 12060 end if; 12061 end Is_Expression_Function_Or_Completion; 12062 12063 ----------------------- 12064 -- Is_EVF_Expression -- 12065 ----------------------- 12066 12067 function Is_EVF_Expression (N : Node_Id) return Boolean is 12068 Orig_N : constant Node_Id := Original_Node (N); 12069 Alt : Node_Id; 12070 Expr : Node_Id; 12071 Id : Entity_Id; 12072 12073 begin 12074 -- Detect a reference to a formal parameter of a specific tagged type 12075 -- whose related subprogram is subject to pragma Expresions_Visible with 12076 -- value "False". 12077 12078 if Is_Entity_Name (N) and then Present (Entity (N)) then 12079 Id := Entity (N); 12080 12081 return 12082 Is_Formal (Id) 12083 and then Is_Specific_Tagged_Type (Etype (Id)) 12084 and then Extensions_Visible_Status (Id) = 12085 Extensions_Visible_False; 12086 12087 -- A case expression is an EVF expression when it contains at least one 12088 -- EVF dependent_expression. Note that a case expression may have been 12089 -- expanded, hence the use of Original_Node. 12090 12091 elsif Nkind (Orig_N) = N_Case_Expression then 12092 Alt := First (Alternatives (Orig_N)); 12093 while Present (Alt) loop 12094 if Is_EVF_Expression (Expression (Alt)) then 12095 return True; 12096 end if; 12097 12098 Next (Alt); 12099 end loop; 12100 12101 -- An if expression is an EVF expression when it contains at least one 12102 -- EVF dependent_expression. Note that an if expression may have been 12103 -- expanded, hence the use of Original_Node. 12104 12105 elsif Nkind (Orig_N) = N_If_Expression then 12106 Expr := Next (First (Expressions (Orig_N))); 12107 while Present (Expr) loop 12108 if Is_EVF_Expression (Expr) then 12109 return True; 12110 end if; 12111 12112 Next (Expr); 12113 end loop; 12114 12115 -- A qualified expression or a type conversion is an EVF expression when 12116 -- its operand is an EVF expression. 12117 12118 elsif Nkind_In (N, N_Qualified_Expression, 12119 N_Unchecked_Type_Conversion, 12120 N_Type_Conversion) 12121 then 12122 return Is_EVF_Expression (Expression (N)); 12123 12124 -- Attributes 'Loop_Entry, 'Old, and 'Update are EVF expressions when 12125 -- their prefix denotes an EVF expression. 12126 12127 elsif Nkind (N) = N_Attribute_Reference 12128 and then Nam_In (Attribute_Name (N), Name_Loop_Entry, 12129 Name_Old, 12130 Name_Update) 12131 then 12132 return Is_EVF_Expression (Prefix (N)); 12133 end if; 12134 12135 return False; 12136 end Is_EVF_Expression; 12137 12138 -------------- 12139 -- Is_False -- 12140 -------------- 12141 12142 function Is_False (U : Uint) return Boolean is 12143 begin 12144 return (U = 0); 12145 end Is_False; 12146 12147 --------------------------- 12148 -- Is_Fixed_Model_Number -- 12149 --------------------------- 12150 12151 function Is_Fixed_Model_Number (U : Ureal; T : Entity_Id) return Boolean is 12152 S : constant Ureal := Small_Value (T); 12153 M : Urealp.Save_Mark; 12154 R : Boolean; 12155 begin 12156 M := Urealp.Mark; 12157 R := (U = UR_Trunc (U / S) * S); 12158 Urealp.Release (M); 12159 return R; 12160 end Is_Fixed_Model_Number; 12161 12162 ------------------------------- 12163 -- Is_Fully_Initialized_Type -- 12164 ------------------------------- 12165 12166 function Is_Fully_Initialized_Type (Typ : Entity_Id) return Boolean is 12167 begin 12168 -- Scalar types 12169 12170 if Is_Scalar_Type (Typ) then 12171 12172 -- A scalar type with an aspect Default_Value is fully initialized 12173 12174 -- Note: Iniitalize/Normalize_Scalars also ensure full initialization 12175 -- of a scalar type, but we don't take that into account here, since 12176 -- we don't want these to affect warnings. 12177 12178 return Has_Default_Aspect (Typ); 12179 12180 elsif Is_Access_Type (Typ) then 12181 return True; 12182 12183 elsif Is_Array_Type (Typ) then 12184 if Is_Fully_Initialized_Type (Component_Type (Typ)) 12185 or else (Ada_Version >= Ada_2012 and then Has_Default_Aspect (Typ)) 12186 then 12187 return True; 12188 end if; 12189 12190 -- An interesting case, if we have a constrained type one of whose 12191 -- bounds is known to be null, then there are no elements to be 12192 -- initialized, so all the elements are initialized. 12193 12194 if Is_Constrained (Typ) then 12195 declare 12196 Indx : Node_Id; 12197 Indx_Typ : Entity_Id; 12198 Lbd, Hbd : Node_Id; 12199 12200 begin 12201 Indx := First_Index (Typ); 12202 while Present (Indx) loop 12203 if Etype (Indx) = Any_Type then 12204 return False; 12205 12206 -- If index is a range, use directly 12207 12208 elsif Nkind (Indx) = N_Range then 12209 Lbd := Low_Bound (Indx); 12210 Hbd := High_Bound (Indx); 12211 12212 else 12213 Indx_Typ := Etype (Indx); 12214 12215 if Is_Private_Type (Indx_Typ) then 12216 Indx_Typ := Full_View (Indx_Typ); 12217 end if; 12218 12219 if No (Indx_Typ) or else Etype (Indx_Typ) = Any_Type then 12220 return False; 12221 else 12222 Lbd := Type_Low_Bound (Indx_Typ); 12223 Hbd := Type_High_Bound (Indx_Typ); 12224 end if; 12225 end if; 12226 12227 if Compile_Time_Known_Value (Lbd) 12228 and then 12229 Compile_Time_Known_Value (Hbd) 12230 then 12231 if Expr_Value (Hbd) < Expr_Value (Lbd) then 12232 return True; 12233 end if; 12234 end if; 12235 12236 Next_Index (Indx); 12237 end loop; 12238 end; 12239 end if; 12240 12241 -- If no null indexes, then type is not fully initialized 12242 12243 return False; 12244 12245 -- Record types 12246 12247 elsif Is_Record_Type (Typ) then 12248 if Has_Discriminants (Typ) 12249 and then 12250 Present (Discriminant_Default_Value (First_Discriminant (Typ))) 12251 and then Is_Fully_Initialized_Variant (Typ) 12252 then 12253 return True; 12254 end if; 12255 12256 -- We consider bounded string types to be fully initialized, because 12257 -- otherwise we get false alarms when the Data component is not 12258 -- default-initialized. 12259 12260 if Is_Bounded_String (Typ) then 12261 return True; 12262 end if; 12263 12264 -- Controlled records are considered to be fully initialized if 12265 -- there is a user defined Initialize routine. This may not be 12266 -- entirely correct, but as the spec notes, we are guessing here 12267 -- what is best from the point of view of issuing warnings. 12268 12269 if Is_Controlled (Typ) then 12270 declare 12271 Utyp : constant Entity_Id := Underlying_Type (Typ); 12272 12273 begin 12274 if Present (Utyp) then 12275 declare 12276 Init : constant Entity_Id := 12277 (Find_Optional_Prim_Op 12278 (Underlying_Type (Typ), Name_Initialize)); 12279 12280 begin 12281 if Present (Init) 12282 and then Comes_From_Source (Init) 12283 and then not 12284 Is_Predefined_File_Name 12285 (File_Name (Get_Source_File_Index (Sloc (Init)))) 12286 then 12287 return True; 12288 12289 elsif Has_Null_Extension (Typ) 12290 and then 12291 Is_Fully_Initialized_Type 12292 (Etype (Base_Type (Typ))) 12293 then 12294 return True; 12295 end if; 12296 end; 12297 end if; 12298 end; 12299 end if; 12300 12301 -- Otherwise see if all record components are initialized 12302 12303 declare 12304 Ent : Entity_Id; 12305 12306 begin 12307 Ent := First_Entity (Typ); 12308 while Present (Ent) loop 12309 if Ekind (Ent) = E_Component 12310 and then (No (Parent (Ent)) 12311 or else No (Expression (Parent (Ent)))) 12312 and then not Is_Fully_Initialized_Type (Etype (Ent)) 12313 12314 -- Special VM case for tag components, which need to be 12315 -- defined in this case, but are never initialized as VMs 12316 -- are using other dispatching mechanisms. Ignore this 12317 -- uninitialized case. Note that this applies both to the 12318 -- uTag entry and the main vtable pointer (CPP_Class case). 12319 12320 and then (Tagged_Type_Expansion or else not Is_Tag (Ent)) 12321 then 12322 return False; 12323 end if; 12324 12325 Next_Entity (Ent); 12326 end loop; 12327 end; 12328 12329 -- No uninitialized components, so type is fully initialized. 12330 -- Note that this catches the case of no components as well. 12331 12332 return True; 12333 12334 elsif Is_Concurrent_Type (Typ) then 12335 return True; 12336 12337 elsif Is_Private_Type (Typ) then 12338 declare 12339 U : constant Entity_Id := Underlying_Type (Typ); 12340 12341 begin 12342 if No (U) then 12343 return False; 12344 else 12345 return Is_Fully_Initialized_Type (U); 12346 end if; 12347 end; 12348 12349 else 12350 return False; 12351 end if; 12352 end Is_Fully_Initialized_Type; 12353 12354 ---------------------------------- 12355 -- Is_Fully_Initialized_Variant -- 12356 ---------------------------------- 12357 12358 function Is_Fully_Initialized_Variant (Typ : Entity_Id) return Boolean is 12359 Loc : constant Source_Ptr := Sloc (Typ); 12360 Constraints : constant List_Id := New_List; 12361 Components : constant Elist_Id := New_Elmt_List; 12362 Comp_Elmt : Elmt_Id; 12363 Comp_Id : Node_Id; 12364 Comp_List : Node_Id; 12365 Discr : Entity_Id; 12366 Discr_Val : Node_Id; 12367 12368 Report_Errors : Boolean; 12369 pragma Warnings (Off, Report_Errors); 12370 12371 begin 12372 if Serious_Errors_Detected > 0 then 12373 return False; 12374 end if; 12375 12376 if Is_Record_Type (Typ) 12377 and then Nkind (Parent (Typ)) = N_Full_Type_Declaration 12378 and then Nkind (Type_Definition (Parent (Typ))) = N_Record_Definition 12379 then 12380 Comp_List := Component_List (Type_Definition (Parent (Typ))); 12381 12382 Discr := First_Discriminant (Typ); 12383 while Present (Discr) loop 12384 if Nkind (Parent (Discr)) = N_Discriminant_Specification then 12385 Discr_Val := Expression (Parent (Discr)); 12386 12387 if Present (Discr_Val) 12388 and then Is_OK_Static_Expression (Discr_Val) 12389 then 12390 Append_To (Constraints, 12391 Make_Component_Association (Loc, 12392 Choices => New_List (New_Occurrence_Of (Discr, Loc)), 12393 Expression => New_Copy (Discr_Val))); 12394 else 12395 return False; 12396 end if; 12397 else 12398 return False; 12399 end if; 12400 12401 Next_Discriminant (Discr); 12402 end loop; 12403 12404 Gather_Components 12405 (Typ => Typ, 12406 Comp_List => Comp_List, 12407 Governed_By => Constraints, 12408 Into => Components, 12409 Report_Errors => Report_Errors); 12410 12411 -- Check that each component present is fully initialized 12412 12413 Comp_Elmt := First_Elmt (Components); 12414 while Present (Comp_Elmt) loop 12415 Comp_Id := Node (Comp_Elmt); 12416 12417 if Ekind (Comp_Id) = E_Component 12418 and then (No (Parent (Comp_Id)) 12419 or else No (Expression (Parent (Comp_Id)))) 12420 and then not Is_Fully_Initialized_Type (Etype (Comp_Id)) 12421 then 12422 return False; 12423 end if; 12424 12425 Next_Elmt (Comp_Elmt); 12426 end loop; 12427 12428 return True; 12429 12430 elsif Is_Private_Type (Typ) then 12431 declare 12432 U : constant Entity_Id := Underlying_Type (Typ); 12433 12434 begin 12435 if No (U) then 12436 return False; 12437 else 12438 return Is_Fully_Initialized_Variant (U); 12439 end if; 12440 end; 12441 12442 else 12443 return False; 12444 end if; 12445 end Is_Fully_Initialized_Variant; 12446 12447 ------------------------------------ 12448 -- Is_Generic_Declaration_Or_Body -- 12449 ------------------------------------ 12450 12451 function Is_Generic_Declaration_Or_Body (Decl : Node_Id) return Boolean is 12452 Spec_Decl : Node_Id; 12453 12454 begin 12455 -- Package/subprogram body 12456 12457 if Nkind_In (Decl, N_Package_Body, N_Subprogram_Body) 12458 and then Present (Corresponding_Spec (Decl)) 12459 then 12460 Spec_Decl := Unit_Declaration_Node (Corresponding_Spec (Decl)); 12461 12462 -- Package/subprogram body stub 12463 12464 elsif Nkind_In (Decl, N_Package_Body_Stub, N_Subprogram_Body_Stub) 12465 and then Present (Corresponding_Spec_Of_Stub (Decl)) 12466 then 12467 Spec_Decl := 12468 Unit_Declaration_Node (Corresponding_Spec_Of_Stub (Decl)); 12469 12470 -- All other cases 12471 12472 else 12473 Spec_Decl := Decl; 12474 end if; 12475 12476 -- Rather than inspecting the defining entity of the spec declaration, 12477 -- look at its Nkind. This takes care of the case where the analysis of 12478 -- a generic body modifies the Ekind of its spec to allow for recursive 12479 -- calls. 12480 12481 return 12482 Nkind_In (Spec_Decl, N_Generic_Package_Declaration, 12483 N_Generic_Subprogram_Declaration); 12484 end Is_Generic_Declaration_Or_Body; 12485 12486 ---------------------------- 12487 -- Is_Inherited_Operation -- 12488 ---------------------------- 12489 12490 function Is_Inherited_Operation (E : Entity_Id) return Boolean is 12491 pragma Assert (Is_Overloadable (E)); 12492 Kind : constant Node_Kind := Nkind (Parent (E)); 12493 begin 12494 return Kind = N_Full_Type_Declaration 12495 or else Kind = N_Private_Extension_Declaration 12496 or else Kind = N_Subtype_Declaration 12497 or else (Ekind (E) = E_Enumeration_Literal 12498 and then Is_Derived_Type (Etype (E))); 12499 end Is_Inherited_Operation; 12500 12501 ------------------------------------- 12502 -- Is_Inherited_Operation_For_Type -- 12503 ------------------------------------- 12504 12505 function Is_Inherited_Operation_For_Type 12506 (E : Entity_Id; 12507 Typ : Entity_Id) return Boolean 12508 is 12509 begin 12510 -- Check that the operation has been created by the type declaration 12511 12512 return Is_Inherited_Operation (E) 12513 and then Defining_Identifier (Parent (E)) = Typ; 12514 end Is_Inherited_Operation_For_Type; 12515 12516 ----------------- 12517 -- Is_Iterator -- 12518 ----------------- 12519 12520 function Is_Iterator (Typ : Entity_Id) return Boolean is 12521 function Denotes_Iterator (Iter_Typ : Entity_Id) return Boolean; 12522 -- Determine whether type Iter_Typ is a predefined forward or reversible 12523 -- iterator. 12524 12525 ---------------------- 12526 -- Denotes_Iterator -- 12527 ---------------------- 12528 12529 function Denotes_Iterator (Iter_Typ : Entity_Id) return Boolean is 12530 begin 12531 return 12532 Nam_In (Chars (Iter_Typ), Name_Forward_Iterator, 12533 Name_Reversible_Iterator) 12534 and then Is_Predefined_File_Name 12535 (Unit_File_Name (Get_Source_Unit (Iter_Typ))); 12536 end Denotes_Iterator; 12537 12538 -- Local variables 12539 12540 Iface_Elmt : Elmt_Id; 12541 Ifaces : Elist_Id; 12542 12543 -- Start of processing for Is_Iterator 12544 12545 begin 12546 -- The type may be a subtype of a descendant of the proper instance of 12547 -- the predefined interface type, so we must use the root type of the 12548 -- given type. The same is done for Is_Reversible_Iterator. 12549 12550 if Is_Class_Wide_Type (Typ) 12551 and then Denotes_Iterator (Root_Type (Typ)) 12552 then 12553 return True; 12554 12555 elsif not Is_Tagged_Type (Typ) or else not Is_Derived_Type (Typ) then 12556 return False; 12557 12558 elsif Present (Find_Value_Of_Aspect (Typ, Aspect_Iterable)) then 12559 return True; 12560 12561 else 12562 Collect_Interfaces (Typ, Ifaces); 12563 12564 Iface_Elmt := First_Elmt (Ifaces); 12565 while Present (Iface_Elmt) loop 12566 if Denotes_Iterator (Node (Iface_Elmt)) then 12567 return True; 12568 end if; 12569 12570 Next_Elmt (Iface_Elmt); 12571 end loop; 12572 12573 return False; 12574 end if; 12575 end Is_Iterator; 12576 12577 ---------------------------- 12578 -- Is_Iterator_Over_Array -- 12579 ---------------------------- 12580 12581 function Is_Iterator_Over_Array (N : Node_Id) return Boolean is 12582 Container : constant Node_Id := Name (N); 12583 Container_Typ : constant Entity_Id := Base_Type (Etype (Container)); 12584 begin 12585 return Is_Array_Type (Container_Typ); 12586 end Is_Iterator_Over_Array; 12587 12588 ------------ 12589 -- Is_LHS -- 12590 ------------ 12591 12592 -- We seem to have a lot of overlapping functions that do similar things 12593 -- (testing for left hand sides or lvalues???). 12594 12595 function Is_LHS (N : Node_Id) return Is_LHS_Result is 12596 P : constant Node_Id := Parent (N); 12597 12598 begin 12599 -- Return True if we are the left hand side of an assignment statement 12600 12601 if Nkind (P) = N_Assignment_Statement then 12602 if Name (P) = N then 12603 return Yes; 12604 else 12605 return No; 12606 end if; 12607 12608 -- Case of prefix of indexed or selected component or slice 12609 12610 elsif Nkind_In (P, N_Indexed_Component, N_Selected_Component, N_Slice) 12611 and then N = Prefix (P) 12612 then 12613 -- Here we have the case where the parent P is N.Q or N(Q .. R). 12614 -- If P is an LHS, then N is also effectively an LHS, but there 12615 -- is an important exception. If N is of an access type, then 12616 -- what we really have is N.all.Q (or N.all(Q .. R)). In either 12617 -- case this makes N.all a left hand side but not N itself. 12618 12619 -- If we don't know the type yet, this is the case where we return 12620 -- Unknown, since the answer depends on the type which is unknown. 12621 12622 if No (Etype (N)) then 12623 return Unknown; 12624 12625 -- We have an Etype set, so we can check it 12626 12627 elsif Is_Access_Type (Etype (N)) then 12628 return No; 12629 12630 -- OK, not access type case, so just test whole expression 12631 12632 else 12633 return Is_LHS (P); 12634 end if; 12635 12636 -- All other cases are not left hand sides 12637 12638 else 12639 return No; 12640 end if; 12641 end Is_LHS; 12642 12643 ----------------------------- 12644 -- Is_Library_Level_Entity -- 12645 ----------------------------- 12646 12647 function Is_Library_Level_Entity (E : Entity_Id) return Boolean is 12648 begin 12649 -- The following is a small optimization, and it also properly handles 12650 -- discriminals, which in task bodies might appear in expressions before 12651 -- the corresponding procedure has been created, and which therefore do 12652 -- not have an assigned scope. 12653 12654 if Is_Formal (E) then 12655 return False; 12656 end if; 12657 12658 -- Normal test is simply that the enclosing dynamic scope is Standard 12659 12660 return Enclosing_Dynamic_Scope (E) = Standard_Standard; 12661 end Is_Library_Level_Entity; 12662 12663 -------------------------------- 12664 -- Is_Limited_Class_Wide_Type -- 12665 -------------------------------- 12666 12667 function Is_Limited_Class_Wide_Type (Typ : Entity_Id) return Boolean is 12668 begin 12669 return 12670 Is_Class_Wide_Type (Typ) 12671 and then (Is_Limited_Type (Typ) or else From_Limited_With (Typ)); 12672 end Is_Limited_Class_Wide_Type; 12673 12674 --------------------------------- 12675 -- Is_Local_Variable_Reference -- 12676 --------------------------------- 12677 12678 function Is_Local_Variable_Reference (Expr : Node_Id) return Boolean is 12679 begin 12680 if not Is_Entity_Name (Expr) then 12681 return False; 12682 12683 else 12684 declare 12685 Ent : constant Entity_Id := Entity (Expr); 12686 Sub : constant Entity_Id := Enclosing_Subprogram (Ent); 12687 begin 12688 if not Ekind_In (Ent, E_Variable, E_In_Out_Parameter) then 12689 return False; 12690 else 12691 return Present (Sub) and then Sub = Current_Subprogram; 12692 end if; 12693 end; 12694 end if; 12695 end Is_Local_Variable_Reference; 12696 12697 ----------------------------------------------- 12698 -- Is_Nontrivial_Default_Init_Cond_Procedure -- 12699 ----------------------------------------------- 12700 12701 function Is_Nontrivial_Default_Init_Cond_Procedure 12702 (Id : Entity_Id) return Boolean 12703 is 12704 Body_Decl : Node_Id; 12705 Stmt : Node_Id; 12706 12707 begin 12708 if Ekind (Id) = E_Procedure 12709 and then Is_Default_Init_Cond_Procedure (Id) 12710 then 12711 Body_Decl := 12712 Unit_Declaration_Node 12713 (Corresponding_Body (Unit_Declaration_Node (Id))); 12714 12715 -- The body of the Default_Initial_Condition procedure must contain 12716 -- at least one statement, otherwise the generation of the subprogram 12717 -- body failed. 12718 12719 pragma Assert (Present (Handled_Statement_Sequence (Body_Decl))); 12720 12721 -- To qualify as nontrivial, the first statement of the procedure 12722 -- must be a check in the form of an if statement. If the original 12723 -- Default_Initial_Condition expression was folded, then the first 12724 -- statement is not a check. 12725 12726 Stmt := First (Statements (Handled_Statement_Sequence (Body_Decl))); 12727 12728 return 12729 Nkind (Stmt) = N_If_Statement 12730 and then Nkind (Original_Node (Stmt)) = N_Pragma; 12731 end if; 12732 12733 return False; 12734 end Is_Nontrivial_Default_Init_Cond_Procedure; 12735 12736 ------------------------- 12737 -- Is_Object_Reference -- 12738 ------------------------- 12739 12740 function Is_Object_Reference (N : Node_Id) return Boolean is 12741 function Is_Internally_Generated_Renaming (N : Node_Id) return Boolean; 12742 -- Determine whether N is the name of an internally-generated renaming 12743 12744 -------------------------------------- 12745 -- Is_Internally_Generated_Renaming -- 12746 -------------------------------------- 12747 12748 function Is_Internally_Generated_Renaming (N : Node_Id) return Boolean is 12749 P : Node_Id; 12750 12751 begin 12752 P := N; 12753 while Present (P) loop 12754 if Nkind (P) = N_Object_Renaming_Declaration then 12755 return not Comes_From_Source (P); 12756 elsif Is_List_Member (P) then 12757 return False; 12758 end if; 12759 12760 P := Parent (P); 12761 end loop; 12762 12763 return False; 12764 end Is_Internally_Generated_Renaming; 12765 12766 -- Start of processing for Is_Object_Reference 12767 12768 begin 12769 if Is_Entity_Name (N) then 12770 return Present (Entity (N)) and then Is_Object (Entity (N)); 12771 12772 else 12773 case Nkind (N) is 12774 when N_Indexed_Component | N_Slice => 12775 return 12776 Is_Object_Reference (Prefix (N)) 12777 or else Is_Access_Type (Etype (Prefix (N))); 12778 12779 -- In Ada 95, a function call is a constant object; a procedure 12780 -- call is not. 12781 12782 when N_Function_Call => 12783 return Etype (N) /= Standard_Void_Type; 12784 12785 -- Attributes 'Input, 'Loop_Entry, 'Old and 'Result produce 12786 -- objects. 12787 12788 when N_Attribute_Reference => 12789 return 12790 Nam_In (Attribute_Name (N), Name_Input, 12791 Name_Loop_Entry, 12792 Name_Old, 12793 Name_Result); 12794 12795 when N_Selected_Component => 12796 return 12797 Is_Object_Reference (Selector_Name (N)) 12798 and then 12799 (Is_Object_Reference (Prefix (N)) 12800 or else Is_Access_Type (Etype (Prefix (N)))); 12801 12802 when N_Explicit_Dereference => 12803 return True; 12804 12805 -- A view conversion of a tagged object is an object reference 12806 12807 when N_Type_Conversion => 12808 return Is_Tagged_Type (Etype (Subtype_Mark (N))) 12809 and then Is_Tagged_Type (Etype (Expression (N))) 12810 and then Is_Object_Reference (Expression (N)); 12811 12812 -- An unchecked type conversion is considered to be an object if 12813 -- the operand is an object (this construction arises only as a 12814 -- result of expansion activities). 12815 12816 when N_Unchecked_Type_Conversion => 12817 return True; 12818 12819 -- Allow string literals to act as objects as long as they appear 12820 -- in internally-generated renamings. The expansion of iterators 12821 -- may generate such renamings when the range involves a string 12822 -- literal. 12823 12824 when N_String_Literal => 12825 return Is_Internally_Generated_Renaming (Parent (N)); 12826 12827 -- AI05-0003: In Ada 2012 a qualified expression is a name. 12828 -- This allows disambiguation of function calls and the use 12829 -- of aggregates in more contexts. 12830 12831 when N_Qualified_Expression => 12832 if Ada_Version < Ada_2012 then 12833 return False; 12834 else 12835 return Is_Object_Reference (Expression (N)) 12836 or else Nkind (Expression (N)) = N_Aggregate; 12837 end if; 12838 12839 when others => 12840 return False; 12841 end case; 12842 end if; 12843 end Is_Object_Reference; 12844 12845 ----------------------------------- 12846 -- Is_OK_Variable_For_Out_Formal -- 12847 ----------------------------------- 12848 12849 function Is_OK_Variable_For_Out_Formal (AV : Node_Id) return Boolean is 12850 begin 12851 Note_Possible_Modification (AV, Sure => True); 12852 12853 -- We must reject parenthesized variable names. Comes_From_Source is 12854 -- checked because there are currently cases where the compiler violates 12855 -- this rule (e.g. passing a task object to its controlled Initialize 12856 -- routine). This should be properly documented in sinfo??? 12857 12858 if Paren_Count (AV) > 0 and then Comes_From_Source (AV) then 12859 return False; 12860 12861 -- A variable is always allowed 12862 12863 elsif Is_Variable (AV) then 12864 return True; 12865 12866 -- Generalized indexing operations are rewritten as explicit 12867 -- dereferences, and it is only during resolution that we can 12868 -- check whether the context requires an access_to_variable type. 12869 12870 elsif Nkind (AV) = N_Explicit_Dereference 12871 and then Ada_Version >= Ada_2012 12872 and then Nkind (Original_Node (AV)) = N_Indexed_Component 12873 and then Present (Etype (Original_Node (AV))) 12874 and then Has_Implicit_Dereference (Etype (Original_Node (AV))) 12875 then 12876 return not Is_Access_Constant (Etype (Prefix (AV))); 12877 12878 -- Unchecked conversions are allowed only if they come from the 12879 -- generated code, which sometimes uses unchecked conversions for out 12880 -- parameters in cases where code generation is unaffected. We tell 12881 -- source unchecked conversions by seeing if they are rewrites of 12882 -- an original Unchecked_Conversion function call, or of an explicit 12883 -- conversion of a function call or an aggregate (as may happen in the 12884 -- expansion of a packed array aggregate). 12885 12886 elsif Nkind (AV) = N_Unchecked_Type_Conversion then 12887 if Nkind_In (Original_Node (AV), N_Function_Call, N_Aggregate) then 12888 return False; 12889 12890 elsif Comes_From_Source (AV) 12891 and then Nkind (Original_Node (Expression (AV))) = N_Function_Call 12892 then 12893 return False; 12894 12895 elsif Nkind (Original_Node (AV)) = N_Type_Conversion then 12896 return Is_OK_Variable_For_Out_Formal (Expression (AV)); 12897 12898 else 12899 return True; 12900 end if; 12901 12902 -- Normal type conversions are allowed if argument is a variable 12903 12904 elsif Nkind (AV) = N_Type_Conversion then 12905 if Is_Variable (Expression (AV)) 12906 and then Paren_Count (Expression (AV)) = 0 12907 then 12908 Note_Possible_Modification (Expression (AV), Sure => True); 12909 return True; 12910 12911 -- We also allow a non-parenthesized expression that raises 12912 -- constraint error if it rewrites what used to be a variable 12913 12914 elsif Raises_Constraint_Error (Expression (AV)) 12915 and then Paren_Count (Expression (AV)) = 0 12916 and then Is_Variable (Original_Node (Expression (AV))) 12917 then 12918 return True; 12919 12920 -- Type conversion of something other than a variable 12921 12922 else 12923 return False; 12924 end if; 12925 12926 -- If this node is rewritten, then test the original form, if that is 12927 -- OK, then we consider the rewritten node OK (for example, if the 12928 -- original node is a conversion, then Is_Variable will not be true 12929 -- but we still want to allow the conversion if it converts a variable). 12930 12931 elsif Original_Node (AV) /= AV then 12932 12933 -- In Ada 2012, the explicit dereference may be a rewritten call to a 12934 -- Reference function. 12935 12936 if Ada_Version >= Ada_2012 12937 and then Nkind (Original_Node (AV)) = N_Function_Call 12938 and then 12939 Has_Implicit_Dereference (Etype (Name (Original_Node (AV)))) 12940 then 12941 12942 -- Check that this is not a constant reference. 12943 12944 return not Is_Access_Constant (Etype (Prefix (AV))); 12945 12946 elsif Has_Implicit_Dereference (Etype (Original_Node (AV))) then 12947 return 12948 not Is_Access_Constant (Etype 12949 (Get_Reference_Discriminant (Etype (Original_Node (AV))))); 12950 12951 else 12952 return Is_OK_Variable_For_Out_Formal (Original_Node (AV)); 12953 end if; 12954 12955 -- All other non-variables are rejected 12956 12957 else 12958 return False; 12959 end if; 12960 end Is_OK_Variable_For_Out_Formal; 12961 12962 ------------------------------------ 12963 -- Is_Package_Contract_Annotation -- 12964 ------------------------------------ 12965 12966 function Is_Package_Contract_Annotation (Item : Node_Id) return Boolean is 12967 Nam : Name_Id; 12968 12969 begin 12970 if Nkind (Item) = N_Aspect_Specification then 12971 Nam := Chars (Identifier (Item)); 12972 12973 else pragma Assert (Nkind (Item) = N_Pragma); 12974 Nam := Pragma_Name (Item); 12975 end if; 12976 12977 return Nam = Name_Abstract_State 12978 or else Nam = Name_Initial_Condition 12979 or else Nam = Name_Initializes 12980 or else Nam = Name_Refined_State; 12981 end Is_Package_Contract_Annotation; 12982 12983 ----------------------------------- 12984 -- Is_Partially_Initialized_Type -- 12985 ----------------------------------- 12986 12987 function Is_Partially_Initialized_Type 12988 (Typ : Entity_Id; 12989 Include_Implicit : Boolean := True) return Boolean 12990 is 12991 begin 12992 if Is_Scalar_Type (Typ) then 12993 return False; 12994 12995 elsif Is_Access_Type (Typ) then 12996 return Include_Implicit; 12997 12998 elsif Is_Array_Type (Typ) then 12999 13000 -- If component type is partially initialized, so is array type 13001 13002 if Is_Partially_Initialized_Type 13003 (Component_Type (Typ), Include_Implicit) 13004 then 13005 return True; 13006 13007 -- Otherwise we are only partially initialized if we are fully 13008 -- initialized (this is the empty array case, no point in us 13009 -- duplicating that code here). 13010 13011 else 13012 return Is_Fully_Initialized_Type (Typ); 13013 end if; 13014 13015 elsif Is_Record_Type (Typ) then 13016 13017 -- A discriminated type is always partially initialized if in 13018 -- all mode 13019 13020 if Has_Discriminants (Typ) and then Include_Implicit then 13021 return True; 13022 13023 -- A tagged type is always partially initialized 13024 13025 elsif Is_Tagged_Type (Typ) then 13026 return True; 13027 13028 -- Case of non-discriminated record 13029 13030 else 13031 declare 13032 Ent : Entity_Id; 13033 13034 Component_Present : Boolean := False; 13035 -- Set True if at least one component is present. If no 13036 -- components are present, then record type is fully 13037 -- initialized (another odd case, like the null array). 13038 13039 begin 13040 -- Loop through components 13041 13042 Ent := First_Entity (Typ); 13043 while Present (Ent) loop 13044 if Ekind (Ent) = E_Component then 13045 Component_Present := True; 13046 13047 -- If a component has an initialization expression then 13048 -- the enclosing record type is partially initialized 13049 13050 if Present (Parent (Ent)) 13051 and then Present (Expression (Parent (Ent))) 13052 then 13053 return True; 13054 13055 -- If a component is of a type which is itself partially 13056 -- initialized, then the enclosing record type is also. 13057 13058 elsif Is_Partially_Initialized_Type 13059 (Etype (Ent), Include_Implicit) 13060 then 13061 return True; 13062 end if; 13063 end if; 13064 13065 Next_Entity (Ent); 13066 end loop; 13067 13068 -- No initialized components found. If we found any components 13069 -- they were all uninitialized so the result is false. 13070 13071 if Component_Present then 13072 return False; 13073 13074 -- But if we found no components, then all the components are 13075 -- initialized so we consider the type to be initialized. 13076 13077 else 13078 return True; 13079 end if; 13080 end; 13081 end if; 13082 13083 -- Concurrent types are always fully initialized 13084 13085 elsif Is_Concurrent_Type (Typ) then 13086 return True; 13087 13088 -- For a private type, go to underlying type. If there is no underlying 13089 -- type then just assume this partially initialized. Not clear if this 13090 -- can happen in a non-error case, but no harm in testing for this. 13091 13092 elsif Is_Private_Type (Typ) then 13093 declare 13094 U : constant Entity_Id := Underlying_Type (Typ); 13095 begin 13096 if No (U) then 13097 return True; 13098 else 13099 return Is_Partially_Initialized_Type (U, Include_Implicit); 13100 end if; 13101 end; 13102 13103 -- For any other type (are there any?) assume partially initialized 13104 13105 else 13106 return True; 13107 end if; 13108 end Is_Partially_Initialized_Type; 13109 13110 ------------------------------------ 13111 -- Is_Potentially_Persistent_Type -- 13112 ------------------------------------ 13113 13114 function Is_Potentially_Persistent_Type (T : Entity_Id) return Boolean is 13115 Comp : Entity_Id; 13116 Indx : Node_Id; 13117 13118 begin 13119 -- For private type, test corresponding full type 13120 13121 if Is_Private_Type (T) then 13122 return Is_Potentially_Persistent_Type (Full_View (T)); 13123 13124 -- Scalar types are potentially persistent 13125 13126 elsif Is_Scalar_Type (T) then 13127 return True; 13128 13129 -- Record type is potentially persistent if not tagged and the types of 13130 -- all it components are potentially persistent, and no component has 13131 -- an initialization expression. 13132 13133 elsif Is_Record_Type (T) 13134 and then not Is_Tagged_Type (T) 13135 and then not Is_Partially_Initialized_Type (T) 13136 then 13137 Comp := First_Component (T); 13138 while Present (Comp) loop 13139 if not Is_Potentially_Persistent_Type (Etype (Comp)) then 13140 return False; 13141 else 13142 Next_Entity (Comp); 13143 end if; 13144 end loop; 13145 13146 return True; 13147 13148 -- Array type is potentially persistent if its component type is 13149 -- potentially persistent and if all its constraints are static. 13150 13151 elsif Is_Array_Type (T) then 13152 if not Is_Potentially_Persistent_Type (Component_Type (T)) then 13153 return False; 13154 end if; 13155 13156 Indx := First_Index (T); 13157 while Present (Indx) loop 13158 if not Is_OK_Static_Subtype (Etype (Indx)) then 13159 return False; 13160 else 13161 Next_Index (Indx); 13162 end if; 13163 end loop; 13164 13165 return True; 13166 13167 -- All other types are not potentially persistent 13168 13169 else 13170 return False; 13171 end if; 13172 end Is_Potentially_Persistent_Type; 13173 13174 -------------------------------- 13175 -- Is_Potentially_Unevaluated -- 13176 -------------------------------- 13177 13178 function Is_Potentially_Unevaluated (N : Node_Id) return Boolean is 13179 Par : Node_Id; 13180 Expr : Node_Id; 13181 13182 begin 13183 Expr := N; 13184 Par := Parent (N); 13185 13186 -- A postcondition whose expression is a short-circuit is broken down 13187 -- into individual aspects for better exception reporting. The original 13188 -- short-circuit expression is rewritten as the second operand, and an 13189 -- occurrence of 'Old in that operand is potentially unevaluated. 13190 -- See Sem_ch13.adb for details of this transformation. 13191 13192 if Nkind (Original_Node (Par)) = N_And_Then then 13193 return True; 13194 end if; 13195 13196 while not Nkind_In (Par, N_If_Expression, 13197 N_Case_Expression, 13198 N_And_Then, 13199 N_Or_Else, 13200 N_In, 13201 N_Not_In) 13202 loop 13203 Expr := Par; 13204 Par := Parent (Par); 13205 13206 -- If the context is not an expression, or if is the result of 13207 -- expansion of an enclosing construct (such as another attribute) 13208 -- the predicate does not apply. 13209 13210 if Nkind (Par) not in N_Subexpr 13211 or else not Comes_From_Source (Par) 13212 then 13213 return False; 13214 end if; 13215 end loop; 13216 13217 if Nkind (Par) = N_If_Expression then 13218 return Is_Elsif (Par) or else Expr /= First (Expressions (Par)); 13219 13220 elsif Nkind (Par) = N_Case_Expression then 13221 return Expr /= Expression (Par); 13222 13223 elsif Nkind_In (Par, N_And_Then, N_Or_Else) then 13224 return Expr = Right_Opnd (Par); 13225 13226 elsif Nkind_In (Par, N_In, N_Not_In) then 13227 return Expr /= Left_Opnd (Par); 13228 13229 else 13230 return False; 13231 end if; 13232 end Is_Potentially_Unevaluated; 13233 13234 --------------------------------- 13235 -- Is_Protected_Self_Reference -- 13236 --------------------------------- 13237 13238 function Is_Protected_Self_Reference (N : Node_Id) return Boolean is 13239 13240 function In_Access_Definition (N : Node_Id) return Boolean; 13241 -- Returns true if N belongs to an access definition 13242 13243 -------------------------- 13244 -- In_Access_Definition -- 13245 -------------------------- 13246 13247 function In_Access_Definition (N : Node_Id) return Boolean is 13248 P : Node_Id; 13249 13250 begin 13251 P := Parent (N); 13252 while Present (P) loop 13253 if Nkind (P) = N_Access_Definition then 13254 return True; 13255 end if; 13256 13257 P := Parent (P); 13258 end loop; 13259 13260 return False; 13261 end In_Access_Definition; 13262 13263 -- Start of processing for Is_Protected_Self_Reference 13264 13265 begin 13266 -- Verify that prefix is analyzed and has the proper form. Note that 13267 -- the attributes Elab_Spec, Elab_Body and Elab_Subp_Body which also 13268 -- produce the address of an entity, do not analyze their prefix 13269 -- because they denote entities that are not necessarily visible. 13270 -- Neither of them can apply to a protected type. 13271 13272 return Ada_Version >= Ada_2005 13273 and then Is_Entity_Name (N) 13274 and then Present (Entity (N)) 13275 and then Is_Protected_Type (Entity (N)) 13276 and then In_Open_Scopes (Entity (N)) 13277 and then not In_Access_Definition (N); 13278 end Is_Protected_Self_Reference; 13279 13280 ----------------------------- 13281 -- Is_RCI_Pkg_Spec_Or_Body -- 13282 ----------------------------- 13283 13284 function Is_RCI_Pkg_Spec_Or_Body (Cunit : Node_Id) return Boolean is 13285 13286 function Is_RCI_Pkg_Decl_Cunit (Cunit : Node_Id) return Boolean; 13287 -- Return True if the unit of Cunit is an RCI package declaration 13288 13289 --------------------------- 13290 -- Is_RCI_Pkg_Decl_Cunit -- 13291 --------------------------- 13292 13293 function Is_RCI_Pkg_Decl_Cunit (Cunit : Node_Id) return Boolean is 13294 The_Unit : constant Node_Id := Unit (Cunit); 13295 13296 begin 13297 if Nkind (The_Unit) /= N_Package_Declaration then 13298 return False; 13299 end if; 13300 13301 return Is_Remote_Call_Interface (Defining_Entity (The_Unit)); 13302 end Is_RCI_Pkg_Decl_Cunit; 13303 13304 -- Start of processing for Is_RCI_Pkg_Spec_Or_Body 13305 13306 begin 13307 return Is_RCI_Pkg_Decl_Cunit (Cunit) 13308 or else 13309 (Nkind (Unit (Cunit)) = N_Package_Body 13310 and then Is_RCI_Pkg_Decl_Cunit (Library_Unit (Cunit))); 13311 end Is_RCI_Pkg_Spec_Or_Body; 13312 13313 ----------------------------------------- 13314 -- Is_Remote_Access_To_Class_Wide_Type -- 13315 ----------------------------------------- 13316 13317 function Is_Remote_Access_To_Class_Wide_Type 13318 (E : Entity_Id) return Boolean 13319 is 13320 begin 13321 -- A remote access to class-wide type is a general access to object type 13322 -- declared in the visible part of a Remote_Types or Remote_Call_ 13323 -- Interface unit. 13324 13325 return Ekind (E) = E_General_Access_Type 13326 and then (Is_Remote_Call_Interface (E) or else Is_Remote_Types (E)); 13327 end Is_Remote_Access_To_Class_Wide_Type; 13328 13329 ----------------------------------------- 13330 -- Is_Remote_Access_To_Subprogram_Type -- 13331 ----------------------------------------- 13332 13333 function Is_Remote_Access_To_Subprogram_Type 13334 (E : Entity_Id) return Boolean 13335 is 13336 begin 13337 return (Ekind (E) = E_Access_Subprogram_Type 13338 or else (Ekind (E) = E_Record_Type 13339 and then Present (Corresponding_Remote_Type (E)))) 13340 and then (Is_Remote_Call_Interface (E) or else Is_Remote_Types (E)); 13341 end Is_Remote_Access_To_Subprogram_Type; 13342 13343 -------------------- 13344 -- Is_Remote_Call -- 13345 -------------------- 13346 13347 function Is_Remote_Call (N : Node_Id) return Boolean is 13348 begin 13349 if Nkind (N) not in N_Subprogram_Call then 13350 13351 -- An entry call cannot be remote 13352 13353 return False; 13354 13355 elsif Nkind (Name (N)) in N_Has_Entity 13356 and then Is_Remote_Call_Interface (Entity (Name (N))) 13357 then 13358 -- A subprogram declared in the spec of a RCI package is remote 13359 13360 return True; 13361 13362 elsif Nkind (Name (N)) = N_Explicit_Dereference 13363 and then Is_Remote_Access_To_Subprogram_Type 13364 (Etype (Prefix (Name (N)))) 13365 then 13366 -- The dereference of a RAS is a remote call 13367 13368 return True; 13369 13370 elsif Present (Controlling_Argument (N)) 13371 and then Is_Remote_Access_To_Class_Wide_Type 13372 (Etype (Controlling_Argument (N))) 13373 then 13374 -- Any primitive operation call with a controlling argument of 13375 -- a RACW type is a remote call. 13376 13377 return True; 13378 end if; 13379 13380 -- All other calls are local calls 13381 13382 return False; 13383 end Is_Remote_Call; 13384 13385 ---------------------- 13386 -- Is_Renamed_Entry -- 13387 ---------------------- 13388 13389 function Is_Renamed_Entry (Proc_Nam : Entity_Id) return Boolean is 13390 Orig_Node : Node_Id := Empty; 13391 Subp_Decl : Node_Id := Parent (Parent (Proc_Nam)); 13392 13393 function Is_Entry (Nam : Node_Id) return Boolean; 13394 -- Determine whether Nam is an entry. Traverse selectors if there are 13395 -- nested selected components. 13396 13397 -------------- 13398 -- Is_Entry -- 13399 -------------- 13400 13401 function Is_Entry (Nam : Node_Id) return Boolean is 13402 begin 13403 if Nkind (Nam) = N_Selected_Component then 13404 return Is_Entry (Selector_Name (Nam)); 13405 end if; 13406 13407 return Ekind (Entity (Nam)) = E_Entry; 13408 end Is_Entry; 13409 13410 -- Start of processing for Is_Renamed_Entry 13411 13412 begin 13413 if Present (Alias (Proc_Nam)) then 13414 Subp_Decl := Parent (Parent (Alias (Proc_Nam))); 13415 end if; 13416 13417 -- Look for a rewritten subprogram renaming declaration 13418 13419 if Nkind (Subp_Decl) = N_Subprogram_Declaration 13420 and then Present (Original_Node (Subp_Decl)) 13421 then 13422 Orig_Node := Original_Node (Subp_Decl); 13423 end if; 13424 13425 -- The rewritten subprogram is actually an entry 13426 13427 if Present (Orig_Node) 13428 and then Nkind (Orig_Node) = N_Subprogram_Renaming_Declaration 13429 and then Is_Entry (Name (Orig_Node)) 13430 then 13431 return True; 13432 end if; 13433 13434 return False; 13435 end Is_Renamed_Entry; 13436 13437 ----------------------------- 13438 -- Is_Renaming_Declaration -- 13439 ----------------------------- 13440 13441 function Is_Renaming_Declaration (N : Node_Id) return Boolean is 13442 begin 13443 case Nkind (N) is 13444 when N_Exception_Renaming_Declaration | 13445 N_Generic_Function_Renaming_Declaration | 13446 N_Generic_Package_Renaming_Declaration | 13447 N_Generic_Procedure_Renaming_Declaration | 13448 N_Object_Renaming_Declaration | 13449 N_Package_Renaming_Declaration | 13450 N_Subprogram_Renaming_Declaration => 13451 return True; 13452 13453 when others => 13454 return False; 13455 end case; 13456 end Is_Renaming_Declaration; 13457 13458 ---------------------------- 13459 -- Is_Reversible_Iterator -- 13460 ---------------------------- 13461 13462 function Is_Reversible_Iterator (Typ : Entity_Id) return Boolean is 13463 Ifaces_List : Elist_Id; 13464 Iface_Elmt : Elmt_Id; 13465 Iface : Entity_Id; 13466 13467 begin 13468 if Is_Class_Wide_Type (Typ) 13469 and then Chars (Root_Type (Typ)) = Name_Reversible_Iterator 13470 and then Is_Predefined_File_Name 13471 (Unit_File_Name (Get_Source_Unit (Root_Type (Typ)))) 13472 then 13473 return True; 13474 13475 elsif not Is_Tagged_Type (Typ) or else not Is_Derived_Type (Typ) then 13476 return False; 13477 13478 else 13479 Collect_Interfaces (Typ, Ifaces_List); 13480 13481 Iface_Elmt := First_Elmt (Ifaces_List); 13482 while Present (Iface_Elmt) loop 13483 Iface := Node (Iface_Elmt); 13484 if Chars (Iface) = Name_Reversible_Iterator 13485 and then 13486 Is_Predefined_File_Name 13487 (Unit_File_Name (Get_Source_Unit (Iface))) 13488 then 13489 return True; 13490 end if; 13491 13492 Next_Elmt (Iface_Elmt); 13493 end loop; 13494 end if; 13495 13496 return False; 13497 end Is_Reversible_Iterator; 13498 13499 ---------------------- 13500 -- Is_Selector_Name -- 13501 ---------------------- 13502 13503 function Is_Selector_Name (N : Node_Id) return Boolean is 13504 begin 13505 if not Is_List_Member (N) then 13506 declare 13507 P : constant Node_Id := Parent (N); 13508 begin 13509 return Nkind_In (P, N_Expanded_Name, 13510 N_Generic_Association, 13511 N_Parameter_Association, 13512 N_Selected_Component) 13513 and then Selector_Name (P) = N; 13514 end; 13515 13516 else 13517 declare 13518 L : constant List_Id := List_Containing (N); 13519 P : constant Node_Id := Parent (L); 13520 begin 13521 return (Nkind (P) = N_Discriminant_Association 13522 and then Selector_Names (P) = L) 13523 or else 13524 (Nkind (P) = N_Component_Association 13525 and then Choices (P) = L); 13526 end; 13527 end if; 13528 end Is_Selector_Name; 13529 13530 --------------------------------- 13531 -- Is_Single_Concurrent_Object -- 13532 --------------------------------- 13533 13534 function Is_Single_Concurrent_Object (Id : Entity_Id) return Boolean is 13535 begin 13536 return 13537 Is_Single_Protected_Object (Id) or else Is_Single_Task_Object (Id); 13538 end Is_Single_Concurrent_Object; 13539 13540 ------------------------------- 13541 -- Is_Single_Concurrent_Type -- 13542 ------------------------------- 13543 13544 function Is_Single_Concurrent_Type (Id : Entity_Id) return Boolean is 13545 begin 13546 return 13547 Ekind_In (Id, E_Protected_Type, E_Task_Type) 13548 and then Is_Single_Concurrent_Type_Declaration 13549 (Declaration_Node (Id)); 13550 end Is_Single_Concurrent_Type; 13551 13552 ------------------------------------------- 13553 -- Is_Single_Concurrent_Type_Declaration -- 13554 ------------------------------------------- 13555 13556 function Is_Single_Concurrent_Type_Declaration 13557 (N : Node_Id) return Boolean 13558 is 13559 begin 13560 return Nkind_In (Original_Node (N), N_Single_Protected_Declaration, 13561 N_Single_Task_Declaration); 13562 end Is_Single_Concurrent_Type_Declaration; 13563 13564 --------------------------------------------- 13565 -- Is_Single_Precision_Floating_Point_Type -- 13566 --------------------------------------------- 13567 13568 function Is_Single_Precision_Floating_Point_Type 13569 (E : Entity_Id) return Boolean is 13570 begin 13571 return Is_Floating_Point_Type (E) 13572 and then Machine_Radix_Value (E) = Uint_2 13573 and then Machine_Mantissa_Value (E) = Uint_24 13574 and then Machine_Emax_Value (E) = Uint_2 ** Uint_7 13575 and then Machine_Emin_Value (E) = Uint_3 - (Uint_2 ** Uint_7); 13576 end Is_Single_Precision_Floating_Point_Type; 13577 13578 -------------------------------- 13579 -- Is_Single_Protected_Object -- 13580 -------------------------------- 13581 13582 function Is_Single_Protected_Object (Id : Entity_Id) return Boolean is 13583 begin 13584 return 13585 Ekind (Id) = E_Variable 13586 and then Ekind (Etype (Id)) = E_Protected_Type 13587 and then Is_Single_Concurrent_Type (Etype (Id)); 13588 end Is_Single_Protected_Object; 13589 13590 --------------------------- 13591 -- Is_Single_Task_Object -- 13592 --------------------------- 13593 13594 function Is_Single_Task_Object (Id : Entity_Id) return Boolean is 13595 begin 13596 return 13597 Ekind (Id) = E_Variable 13598 and then Ekind (Etype (Id)) = E_Task_Type 13599 and then Is_Single_Concurrent_Type (Etype (Id)); 13600 end Is_Single_Task_Object; 13601 13602 ------------------------------------- 13603 -- Is_SPARK_05_Initialization_Expr -- 13604 ------------------------------------- 13605 13606 function Is_SPARK_05_Initialization_Expr (N : Node_Id) return Boolean is 13607 Is_Ok : Boolean; 13608 Expr : Node_Id; 13609 Comp_Assn : Node_Id; 13610 Orig_N : constant Node_Id := Original_Node (N); 13611 13612 begin 13613 Is_Ok := True; 13614 13615 if not Comes_From_Source (Orig_N) then 13616 goto Done; 13617 end if; 13618 13619 pragma Assert (Nkind (Orig_N) in N_Subexpr); 13620 13621 case Nkind (Orig_N) is 13622 when N_Character_Literal | 13623 N_Integer_Literal | 13624 N_Real_Literal | 13625 N_String_Literal => 13626 null; 13627 13628 when N_Identifier | 13629 N_Expanded_Name => 13630 if Is_Entity_Name (Orig_N) 13631 and then Present (Entity (Orig_N)) -- needed in some cases 13632 then 13633 case Ekind (Entity (Orig_N)) is 13634 when E_Constant | 13635 E_Enumeration_Literal | 13636 E_Named_Integer | 13637 E_Named_Real => 13638 null; 13639 when others => 13640 if Is_Type (Entity (Orig_N)) then 13641 null; 13642 else 13643 Is_Ok := False; 13644 end if; 13645 end case; 13646 end if; 13647 13648 when N_Qualified_Expression | 13649 N_Type_Conversion => 13650 Is_Ok := Is_SPARK_05_Initialization_Expr (Expression (Orig_N)); 13651 13652 when N_Unary_Op => 13653 Is_Ok := Is_SPARK_05_Initialization_Expr (Right_Opnd (Orig_N)); 13654 13655 when N_Binary_Op | 13656 N_Short_Circuit | 13657 N_Membership_Test => 13658 Is_Ok := Is_SPARK_05_Initialization_Expr (Left_Opnd (Orig_N)) 13659 and then 13660 Is_SPARK_05_Initialization_Expr (Right_Opnd (Orig_N)); 13661 13662 when N_Aggregate | 13663 N_Extension_Aggregate => 13664 if Nkind (Orig_N) = N_Extension_Aggregate then 13665 Is_Ok := 13666 Is_SPARK_05_Initialization_Expr (Ancestor_Part (Orig_N)); 13667 end if; 13668 13669 Expr := First (Expressions (Orig_N)); 13670 while Present (Expr) loop 13671 if not Is_SPARK_05_Initialization_Expr (Expr) then 13672 Is_Ok := False; 13673 goto Done; 13674 end if; 13675 13676 Next (Expr); 13677 end loop; 13678 13679 Comp_Assn := First (Component_Associations (Orig_N)); 13680 while Present (Comp_Assn) loop 13681 Expr := Expression (Comp_Assn); 13682 13683 -- Note: test for Present here needed for box assocation 13684 13685 if Present (Expr) 13686 and then not Is_SPARK_05_Initialization_Expr (Expr) 13687 then 13688 Is_Ok := False; 13689 goto Done; 13690 end if; 13691 13692 Next (Comp_Assn); 13693 end loop; 13694 13695 when N_Attribute_Reference => 13696 if Nkind (Prefix (Orig_N)) in N_Subexpr then 13697 Is_Ok := Is_SPARK_05_Initialization_Expr (Prefix (Orig_N)); 13698 end if; 13699 13700 Expr := First (Expressions (Orig_N)); 13701 while Present (Expr) loop 13702 if not Is_SPARK_05_Initialization_Expr (Expr) then 13703 Is_Ok := False; 13704 goto Done; 13705 end if; 13706 13707 Next (Expr); 13708 end loop; 13709 13710 -- Selected components might be expanded named not yet resolved, so 13711 -- default on the safe side. (Eg on sparklex.ads) 13712 13713 when N_Selected_Component => 13714 null; 13715 13716 when others => 13717 Is_Ok := False; 13718 end case; 13719 13720 <<Done>> 13721 return Is_Ok; 13722 end Is_SPARK_05_Initialization_Expr; 13723 13724 ---------------------------------- 13725 -- Is_SPARK_05_Object_Reference -- 13726 ---------------------------------- 13727 13728 function Is_SPARK_05_Object_Reference (N : Node_Id) return Boolean is 13729 begin 13730 if Is_Entity_Name (N) then 13731 return Present (Entity (N)) 13732 and then 13733 (Ekind_In (Entity (N), E_Constant, E_Variable) 13734 or else Ekind (Entity (N)) in Formal_Kind); 13735 13736 else 13737 case Nkind (N) is 13738 when N_Selected_Component => 13739 return Is_SPARK_05_Object_Reference (Prefix (N)); 13740 13741 when others => 13742 return False; 13743 end case; 13744 end if; 13745 end Is_SPARK_05_Object_Reference; 13746 13747 ----------------------------- 13748 -- Is_Specific_Tagged_Type -- 13749 ----------------------------- 13750 13751 function Is_Specific_Tagged_Type (Typ : Entity_Id) return Boolean is 13752 Full_Typ : Entity_Id; 13753 13754 begin 13755 -- Handle private types 13756 13757 if Is_Private_Type (Typ) and then Present (Full_View (Typ)) then 13758 Full_Typ := Full_View (Typ); 13759 else 13760 Full_Typ := Typ; 13761 end if; 13762 13763 -- A specific tagged type is a non-class-wide tagged type 13764 13765 return Is_Tagged_Type (Full_Typ) and not Is_Class_Wide_Type (Full_Typ); 13766 end Is_Specific_Tagged_Type; 13767 13768 ------------------ 13769 -- Is_Statement -- 13770 ------------------ 13771 13772 function Is_Statement (N : Node_Id) return Boolean is 13773 begin 13774 return 13775 Nkind (N) in N_Statement_Other_Than_Procedure_Call 13776 or else Nkind (N) = N_Procedure_Call_Statement; 13777 end Is_Statement; 13778 13779 --------------------------------------- 13780 -- Is_Subprogram_Contract_Annotation -- 13781 --------------------------------------- 13782 13783 function Is_Subprogram_Contract_Annotation 13784 (Item : Node_Id) return Boolean 13785 is 13786 Nam : Name_Id; 13787 13788 begin 13789 if Nkind (Item) = N_Aspect_Specification then 13790 Nam := Chars (Identifier (Item)); 13791 13792 else pragma Assert (Nkind (Item) = N_Pragma); 13793 Nam := Pragma_Name (Item); 13794 end if; 13795 13796 return Nam = Name_Contract_Cases 13797 or else Nam = Name_Depends 13798 or else Nam = Name_Extensions_Visible 13799 or else Nam = Name_Global 13800 or else Nam = Name_Post 13801 or else Nam = Name_Post_Class 13802 or else Nam = Name_Postcondition 13803 or else Nam = Name_Pre 13804 or else Nam = Name_Pre_Class 13805 or else Nam = Name_Precondition 13806 or else Nam = Name_Refined_Depends 13807 or else Nam = Name_Refined_Global 13808 or else Nam = Name_Refined_Post 13809 or else Nam = Name_Test_Case; 13810 end Is_Subprogram_Contract_Annotation; 13811 13812 -------------------------------------------------- 13813 -- Is_Subprogram_Stub_Without_Prior_Declaration -- 13814 -------------------------------------------------- 13815 13816 function Is_Subprogram_Stub_Without_Prior_Declaration 13817 (N : Node_Id) return Boolean 13818 is 13819 begin 13820 -- A subprogram stub without prior declaration serves as declaration for 13821 -- the actual subprogram body. As such, it has an attached defining 13822 -- entity of E_[Generic_]Function or E_[Generic_]Procedure. 13823 13824 return Nkind (N) = N_Subprogram_Body_Stub 13825 and then Ekind (Defining_Entity (N)) /= E_Subprogram_Body; 13826 end Is_Subprogram_Stub_Without_Prior_Declaration; 13827 13828 -------------------------- 13829 -- Is_Suspension_Object -- 13830 -------------------------- 13831 13832 function Is_Suspension_Object (Id : Entity_Id) return Boolean is 13833 begin 13834 -- This approach does an exact name match rather than to rely on 13835 -- RTSfind. Routine Is_Effectively_Volatile is used by clients of the 13836 -- front end at point where all auxiliary tables are locked and any 13837 -- modifications to them are treated as violations. Do not tamper with 13838 -- the tables, instead examine the Chars fields of all the scopes of Id. 13839 13840 return 13841 Chars (Id) = Name_Suspension_Object 13842 and then Present (Scope (Id)) 13843 and then Chars (Scope (Id)) = Name_Synchronous_Task_Control 13844 and then Present (Scope (Scope (Id))) 13845 and then Chars (Scope (Scope (Id))) = Name_Ada 13846 and then Present (Scope (Scope (Scope (Id)))) 13847 and then Scope (Scope (Scope (Id))) = Standard_Standard; 13848 end Is_Suspension_Object; 13849 13850 ---------------------------- 13851 -- Is_Synchronized_Object -- 13852 ---------------------------- 13853 13854 function Is_Synchronized_Object (Id : Entity_Id) return Boolean is 13855 Prag : Node_Id; 13856 13857 begin 13858 if Is_Object (Id) then 13859 13860 -- The object is synchronized if it is of a type that yields a 13861 -- synchronized object. 13862 13863 if Yields_Synchronized_Object (Etype (Id)) then 13864 return True; 13865 13866 -- The object is synchronized if it is atomic and Async_Writers is 13867 -- enabled. 13868 13869 elsif Is_Atomic (Id) and then Async_Writers_Enabled (Id) then 13870 return True; 13871 13872 -- A constant is a synchronized object by default 13873 13874 elsif Ekind (Id) = E_Constant then 13875 return True; 13876 13877 -- A variable is a synchronized object if it is subject to pragma 13878 -- Constant_After_Elaboration. 13879 13880 elsif Ekind (Id) = E_Variable then 13881 Prag := Get_Pragma (Id, Pragma_Constant_After_Elaboration); 13882 13883 return Present (Prag) and then Is_Enabled_Pragma (Prag); 13884 end if; 13885 end if; 13886 13887 -- Otherwise the input is not an object or it does not qualify as a 13888 -- synchronized object. 13889 13890 return False; 13891 end Is_Synchronized_Object; 13892 13893 --------------------------------- 13894 -- Is_Synchronized_Tagged_Type -- 13895 --------------------------------- 13896 13897 function Is_Synchronized_Tagged_Type (E : Entity_Id) return Boolean is 13898 Kind : constant Entity_Kind := Ekind (Base_Type (E)); 13899 13900 begin 13901 -- A task or protected type derived from an interface is a tagged type. 13902 -- Such a tagged type is called a synchronized tagged type, as are 13903 -- synchronized interfaces and private extensions whose declaration 13904 -- includes the reserved word synchronized. 13905 13906 return (Is_Tagged_Type (E) 13907 and then (Kind = E_Task_Type 13908 or else 13909 Kind = E_Protected_Type)) 13910 or else 13911 (Is_Interface (E) 13912 and then Is_Synchronized_Interface (E)) 13913 or else 13914 (Ekind (E) = E_Record_Type_With_Private 13915 and then Nkind (Parent (E)) = N_Private_Extension_Declaration 13916 and then (Synchronized_Present (Parent (E)) 13917 or else Is_Synchronized_Interface (Etype (E)))); 13918 end Is_Synchronized_Tagged_Type; 13919 13920 ----------------- 13921 -- Is_Transfer -- 13922 ----------------- 13923 13924 function Is_Transfer (N : Node_Id) return Boolean is 13925 Kind : constant Node_Kind := Nkind (N); 13926 13927 begin 13928 if Kind = N_Simple_Return_Statement 13929 or else 13930 Kind = N_Extended_Return_Statement 13931 or else 13932 Kind = N_Goto_Statement 13933 or else 13934 Kind = N_Raise_Statement 13935 or else 13936 Kind = N_Requeue_Statement 13937 then 13938 return True; 13939 13940 elsif (Kind = N_Exit_Statement or else Kind in N_Raise_xxx_Error) 13941 and then No (Condition (N)) 13942 then 13943 return True; 13944 13945 elsif Kind = N_Procedure_Call_Statement 13946 and then Is_Entity_Name (Name (N)) 13947 and then Present (Entity (Name (N))) 13948 and then No_Return (Entity (Name (N))) 13949 then 13950 return True; 13951 13952 elsif Nkind (Original_Node (N)) = N_Raise_Statement then 13953 return True; 13954 13955 else 13956 return False; 13957 end if; 13958 end Is_Transfer; 13959 13960 ------------- 13961 -- Is_True -- 13962 ------------- 13963 13964 function Is_True (U : Uint) return Boolean is 13965 begin 13966 return (U /= 0); 13967 end Is_True; 13968 13969 -------------------------------------- 13970 -- Is_Unchecked_Conversion_Instance -- 13971 -------------------------------------- 13972 13973 function Is_Unchecked_Conversion_Instance (Id : Entity_Id) return Boolean is 13974 Gen_Par : Entity_Id; 13975 13976 begin 13977 -- Look for a function whose generic parent is the predefined intrinsic 13978 -- function Unchecked_Conversion. 13979 13980 if Ekind (Id) = E_Function then 13981 Gen_Par := Generic_Parent (Parent (Id)); 13982 13983 return 13984 Present (Gen_Par) 13985 and then Chars (Gen_Par) = Name_Unchecked_Conversion 13986 and then Is_Intrinsic_Subprogram (Gen_Par) 13987 and then Is_Predefined_File_Name 13988 (Unit_File_Name (Get_Source_Unit (Gen_Par))); 13989 end if; 13990 13991 return False; 13992 end Is_Unchecked_Conversion_Instance; 13993 13994 ------------------------------- 13995 -- Is_Universal_Numeric_Type -- 13996 ------------------------------- 13997 13998 function Is_Universal_Numeric_Type (T : Entity_Id) return Boolean is 13999 begin 14000 return T = Universal_Integer or else T = Universal_Real; 14001 end Is_Universal_Numeric_Type; 14002 14003 ---------------------------- 14004 -- Is_Variable_Size_Array -- 14005 ---------------------------- 14006 14007 function Is_Variable_Size_Array (E : Entity_Id) return Boolean is 14008 Idx : Node_Id; 14009 14010 begin 14011 pragma Assert (Is_Array_Type (E)); 14012 14013 -- Check if some index is initialized with a non-constant value 14014 14015 Idx := First_Index (E); 14016 while Present (Idx) loop 14017 if Nkind (Idx) = N_Range then 14018 if not Is_Constant_Bound (Low_Bound (Idx)) 14019 or else not Is_Constant_Bound (High_Bound (Idx)) 14020 then 14021 return True; 14022 end if; 14023 end if; 14024 14025 Idx := Next_Index (Idx); 14026 end loop; 14027 14028 return False; 14029 end Is_Variable_Size_Array; 14030 14031 ----------------------------- 14032 -- Is_Variable_Size_Record -- 14033 ----------------------------- 14034 14035 function Is_Variable_Size_Record (E : Entity_Id) return Boolean is 14036 Comp : Entity_Id; 14037 Comp_Typ : Entity_Id; 14038 14039 begin 14040 pragma Assert (Is_Record_Type (E)); 14041 14042 Comp := First_Entity (E); 14043 while Present (Comp) loop 14044 Comp_Typ := Etype (Comp); 14045 14046 -- Recursive call if the record type has discriminants 14047 14048 if Is_Record_Type (Comp_Typ) 14049 and then Has_Discriminants (Comp_Typ) 14050 and then Is_Variable_Size_Record (Comp_Typ) 14051 then 14052 return True; 14053 14054 elsif Is_Array_Type (Comp_Typ) 14055 and then Is_Variable_Size_Array (Comp_Typ) 14056 then 14057 return True; 14058 end if; 14059 14060 Next_Entity (Comp); 14061 end loop; 14062 14063 return False; 14064 end Is_Variable_Size_Record; 14065 14066 ----------------- 14067 -- Is_Variable -- 14068 ----------------- 14069 14070 function Is_Variable 14071 (N : Node_Id; 14072 Use_Original_Node : Boolean := True) return Boolean 14073 is 14074 Orig_Node : Node_Id; 14075 14076 function In_Protected_Function (E : Entity_Id) return Boolean; 14077 -- Within a protected function, the private components of the enclosing 14078 -- protected type are constants. A function nested within a (protected) 14079 -- procedure is not itself protected. Within the body of a protected 14080 -- function the current instance of the protected type is a constant. 14081 14082 function Is_Variable_Prefix (P : Node_Id) return Boolean; 14083 -- Prefixes can involve implicit dereferences, in which case we must 14084 -- test for the case of a reference of a constant access type, which can 14085 -- can never be a variable. 14086 14087 --------------------------- 14088 -- In_Protected_Function -- 14089 --------------------------- 14090 14091 function In_Protected_Function (E : Entity_Id) return Boolean is 14092 Prot : Entity_Id; 14093 S : Entity_Id; 14094 14095 begin 14096 -- E is the current instance of a type 14097 14098 if Is_Type (E) then 14099 Prot := E; 14100 14101 -- E is an object 14102 14103 else 14104 Prot := Scope (E); 14105 end if; 14106 14107 if not Is_Protected_Type (Prot) then 14108 return False; 14109 14110 else 14111 S := Current_Scope; 14112 while Present (S) and then S /= Prot loop 14113 if Ekind (S) = E_Function and then Scope (S) = Prot then 14114 return True; 14115 end if; 14116 14117 S := Scope (S); 14118 end loop; 14119 14120 return False; 14121 end if; 14122 end In_Protected_Function; 14123 14124 ------------------------ 14125 -- Is_Variable_Prefix -- 14126 ------------------------ 14127 14128 function Is_Variable_Prefix (P : Node_Id) return Boolean is 14129 begin 14130 if Is_Access_Type (Etype (P)) then 14131 return not Is_Access_Constant (Root_Type (Etype (P))); 14132 14133 -- For the case of an indexed component whose prefix has a packed 14134 -- array type, the prefix has been rewritten into a type conversion. 14135 -- Determine variable-ness from the converted expression. 14136 14137 elsif Nkind (P) = N_Type_Conversion 14138 and then not Comes_From_Source (P) 14139 and then Is_Array_Type (Etype (P)) 14140 and then Is_Packed (Etype (P)) 14141 then 14142 return Is_Variable (Expression (P)); 14143 14144 else 14145 return Is_Variable (P); 14146 end if; 14147 end Is_Variable_Prefix; 14148 14149 -- Start of processing for Is_Variable 14150 14151 begin 14152 -- Special check, allow x'Deref(expr) as a variable 14153 14154 if Nkind (N) = N_Attribute_Reference 14155 and then Attribute_Name (N) = Name_Deref 14156 then 14157 return True; 14158 end if; 14159 14160 -- Check if we perform the test on the original node since this may be a 14161 -- test of syntactic categories which must not be disturbed by whatever 14162 -- rewriting might have occurred. For example, an aggregate, which is 14163 -- certainly NOT a variable, could be turned into a variable by 14164 -- expansion. 14165 14166 if Use_Original_Node then 14167 Orig_Node := Original_Node (N); 14168 else 14169 Orig_Node := N; 14170 end if; 14171 14172 -- Definitely OK if Assignment_OK is set. Since this is something that 14173 -- only gets set for expanded nodes, the test is on N, not Orig_Node. 14174 14175 if Nkind (N) in N_Subexpr and then Assignment_OK (N) then 14176 return True; 14177 14178 -- Normally we go to the original node, but there is one exception where 14179 -- we use the rewritten node, namely when it is an explicit dereference. 14180 -- The generated code may rewrite a prefix which is an access type with 14181 -- an explicit dereference. The dereference is a variable, even though 14182 -- the original node may not be (since it could be a constant of the 14183 -- access type). 14184 14185 -- In Ada 2005 we have a further case to consider: the prefix may be a 14186 -- function call given in prefix notation. The original node appears to 14187 -- be a selected component, but we need to examine the call. 14188 14189 elsif Nkind (N) = N_Explicit_Dereference 14190 and then Nkind (Orig_Node) /= N_Explicit_Dereference 14191 and then Present (Etype (Orig_Node)) 14192 and then Is_Access_Type (Etype (Orig_Node)) 14193 then 14194 -- Note that if the prefix is an explicit dereference that does not 14195 -- come from source, we must check for a rewritten function call in 14196 -- prefixed notation before other forms of rewriting, to prevent a 14197 -- compiler crash. 14198 14199 return 14200 (Nkind (Orig_Node) = N_Function_Call 14201 and then not Is_Access_Constant (Etype (Prefix (N)))) 14202 or else 14203 Is_Variable_Prefix (Original_Node (Prefix (N))); 14204 14205 -- in Ada 2012, the dereference may have been added for a type with 14206 -- a declared implicit dereference aspect. Check that it is not an 14207 -- access to constant. 14208 14209 elsif Nkind (N) = N_Explicit_Dereference 14210 and then Present (Etype (Orig_Node)) 14211 and then Ada_Version >= Ada_2012 14212 and then Has_Implicit_Dereference (Etype (Orig_Node)) 14213 then 14214 return not Is_Access_Constant (Etype (Prefix (N))); 14215 14216 -- A function call is never a variable 14217 14218 elsif Nkind (N) = N_Function_Call then 14219 return False; 14220 14221 -- All remaining checks use the original node 14222 14223 elsif Is_Entity_Name (Orig_Node) 14224 and then Present (Entity (Orig_Node)) 14225 then 14226 declare 14227 E : constant Entity_Id := Entity (Orig_Node); 14228 K : constant Entity_Kind := Ekind (E); 14229 14230 begin 14231 return (K = E_Variable 14232 and then Nkind (Parent (E)) /= N_Exception_Handler) 14233 or else (K = E_Component 14234 and then not In_Protected_Function (E)) 14235 or else K = E_Out_Parameter 14236 or else K = E_In_Out_Parameter 14237 or else K = E_Generic_In_Out_Parameter 14238 14239 -- Current instance of type. If this is a protected type, check 14240 -- we are not within the body of one of its protected functions. 14241 14242 or else (Is_Type (E) 14243 and then In_Open_Scopes (E) 14244 and then not In_Protected_Function (E)) 14245 14246 or else (Is_Incomplete_Or_Private_Type (E) 14247 and then In_Open_Scopes (Full_View (E))); 14248 end; 14249 14250 else 14251 case Nkind (Orig_Node) is 14252 when N_Indexed_Component | N_Slice => 14253 return Is_Variable_Prefix (Prefix (Orig_Node)); 14254 14255 when N_Selected_Component => 14256 return (Is_Variable (Selector_Name (Orig_Node)) 14257 and then Is_Variable_Prefix (Prefix (Orig_Node))) 14258 or else 14259 (Nkind (N) = N_Expanded_Name 14260 and then Scope (Entity (N)) = Entity (Prefix (N))); 14261 14262 -- For an explicit dereference, the type of the prefix cannot 14263 -- be an access to constant or an access to subprogram. 14264 14265 when N_Explicit_Dereference => 14266 declare 14267 Typ : constant Entity_Id := Etype (Prefix (Orig_Node)); 14268 begin 14269 return Is_Access_Type (Typ) 14270 and then not Is_Access_Constant (Root_Type (Typ)) 14271 and then Ekind (Typ) /= E_Access_Subprogram_Type; 14272 end; 14273 14274 -- The type conversion is the case where we do not deal with the 14275 -- context dependent special case of an actual parameter. Thus 14276 -- the type conversion is only considered a variable for the 14277 -- purposes of this routine if the target type is tagged. However, 14278 -- a type conversion is considered to be a variable if it does not 14279 -- come from source (this deals for example with the conversions 14280 -- of expressions to their actual subtypes). 14281 14282 when N_Type_Conversion => 14283 return Is_Variable (Expression (Orig_Node)) 14284 and then 14285 (not Comes_From_Source (Orig_Node) 14286 or else 14287 (Is_Tagged_Type (Etype (Subtype_Mark (Orig_Node))) 14288 and then 14289 Is_Tagged_Type (Etype (Expression (Orig_Node))))); 14290 14291 -- GNAT allows an unchecked type conversion as a variable. This 14292 -- only affects the generation of internal expanded code, since 14293 -- calls to instantiations of Unchecked_Conversion are never 14294 -- considered variables (since they are function calls). 14295 14296 when N_Unchecked_Type_Conversion => 14297 return Is_Variable (Expression (Orig_Node)); 14298 14299 when others => 14300 return False; 14301 end case; 14302 end if; 14303 end Is_Variable; 14304 14305 --------------------------- 14306 -- Is_Visibly_Controlled -- 14307 --------------------------- 14308 14309 function Is_Visibly_Controlled (T : Entity_Id) return Boolean is 14310 Root : constant Entity_Id := Root_Type (T); 14311 begin 14312 return Chars (Scope (Root)) = Name_Finalization 14313 and then Chars (Scope (Scope (Root))) = Name_Ada 14314 and then Scope (Scope (Scope (Root))) = Standard_Standard; 14315 end Is_Visibly_Controlled; 14316 14317 -------------------------- 14318 -- Is_Volatile_Function -- 14319 -------------------------- 14320 14321 function Is_Volatile_Function (Func_Id : Entity_Id) return Boolean is 14322 begin 14323 -- The caller must ensure that Func_Id denotes a function 14324 14325 pragma Assert (Ekind_In (Func_Id, E_Function, E_Generic_Function)); 14326 14327 -- A protected function is automatically volatile 14328 14329 if Is_Primitive (Func_Id) 14330 and then Present (First_Formal (Func_Id)) 14331 and then Is_Protected_Type (Etype (First_Formal (Func_Id))) 14332 and then Etype (First_Formal (Func_Id)) = Scope (Func_Id) 14333 then 14334 return True; 14335 14336 -- An instance of Ada.Unchecked_Conversion is a volatile function if 14337 -- either the source or the target are effectively volatile. 14338 14339 elsif Is_Unchecked_Conversion_Instance (Func_Id) 14340 and then Has_Effectively_Volatile_Profile (Func_Id) 14341 then 14342 return True; 14343 14344 -- Otherwise the function is treated as volatile if it is subject to 14345 -- enabled pragma Volatile_Function. 14346 14347 else 14348 return 14349 Is_Enabled_Pragma (Get_Pragma (Func_Id, Pragma_Volatile_Function)); 14350 end if; 14351 end Is_Volatile_Function; 14352 14353 ------------------------ 14354 -- Is_Volatile_Object -- 14355 ------------------------ 14356 14357 function Is_Volatile_Object (N : Node_Id) return Boolean is 14358 14359 function Is_Volatile_Prefix (N : Node_Id) return Boolean; 14360 -- If prefix is an implicit dereference, examine designated type 14361 14362 function Object_Has_Volatile_Components (N : Node_Id) return Boolean; 14363 -- Determines if given object has volatile components 14364 14365 ------------------------ 14366 -- Is_Volatile_Prefix -- 14367 ------------------------ 14368 14369 function Is_Volatile_Prefix (N : Node_Id) return Boolean is 14370 Typ : constant Entity_Id := Etype (N); 14371 14372 begin 14373 if Is_Access_Type (Typ) then 14374 declare 14375 Dtyp : constant Entity_Id := Designated_Type (Typ); 14376 14377 begin 14378 return Is_Volatile (Dtyp) 14379 or else Has_Volatile_Components (Dtyp); 14380 end; 14381 14382 else 14383 return Object_Has_Volatile_Components (N); 14384 end if; 14385 end Is_Volatile_Prefix; 14386 14387 ------------------------------------ 14388 -- Object_Has_Volatile_Components -- 14389 ------------------------------------ 14390 14391 function Object_Has_Volatile_Components (N : Node_Id) return Boolean is 14392 Typ : constant Entity_Id := Etype (N); 14393 14394 begin 14395 if Is_Volatile (Typ) 14396 or else Has_Volatile_Components (Typ) 14397 then 14398 return True; 14399 14400 elsif Is_Entity_Name (N) 14401 and then (Has_Volatile_Components (Entity (N)) 14402 or else Is_Volatile (Entity (N))) 14403 then 14404 return True; 14405 14406 elsif Nkind (N) = N_Indexed_Component 14407 or else Nkind (N) = N_Selected_Component 14408 then 14409 return Is_Volatile_Prefix (Prefix (N)); 14410 14411 else 14412 return False; 14413 end if; 14414 end Object_Has_Volatile_Components; 14415 14416 -- Start of processing for Is_Volatile_Object 14417 14418 begin 14419 if Nkind (N) = N_Defining_Identifier then 14420 return Is_Volatile (N) or else Is_Volatile (Etype (N)); 14421 14422 elsif Nkind (N) = N_Expanded_Name then 14423 return Is_Volatile_Object (Entity (N)); 14424 14425 elsif Is_Volatile (Etype (N)) 14426 or else (Is_Entity_Name (N) and then Is_Volatile (Entity (N))) 14427 then 14428 return True; 14429 14430 elsif Nkind_In (N, N_Indexed_Component, N_Selected_Component) 14431 and then Is_Volatile_Prefix (Prefix (N)) 14432 then 14433 return True; 14434 14435 elsif Nkind (N) = N_Selected_Component 14436 and then Is_Volatile (Entity (Selector_Name (N))) 14437 then 14438 return True; 14439 14440 else 14441 return False; 14442 end if; 14443 end Is_Volatile_Object; 14444 14445 --------------------------- 14446 -- Itype_Has_Declaration -- 14447 --------------------------- 14448 14449 function Itype_Has_Declaration (Id : Entity_Id) return Boolean is 14450 begin 14451 pragma Assert (Is_Itype (Id)); 14452 return Present (Parent (Id)) 14453 and then Nkind_In (Parent (Id), N_Full_Type_Declaration, 14454 N_Subtype_Declaration) 14455 and then Defining_Entity (Parent (Id)) = Id; 14456 end Itype_Has_Declaration; 14457 14458 ------------------------- 14459 -- Kill_Current_Values -- 14460 ------------------------- 14461 14462 procedure Kill_Current_Values 14463 (Ent : Entity_Id; 14464 Last_Assignment_Only : Boolean := False) 14465 is 14466 begin 14467 if Is_Assignable (Ent) then 14468 Set_Last_Assignment (Ent, Empty); 14469 end if; 14470 14471 if Is_Object (Ent) then 14472 if not Last_Assignment_Only then 14473 Kill_Checks (Ent); 14474 Set_Current_Value (Ent, Empty); 14475 14476 -- Do not reset the Is_Known_[Non_]Null and Is_Known_Valid flags 14477 -- for a constant. Once the constant is elaborated, its value is 14478 -- not changed, therefore the associated flags that describe the 14479 -- value should not be modified either. 14480 14481 if Ekind (Ent) = E_Constant then 14482 null; 14483 14484 -- Non-constant entities 14485 14486 else 14487 if not Can_Never_Be_Null (Ent) then 14488 Set_Is_Known_Non_Null (Ent, False); 14489 end if; 14490 14491 Set_Is_Known_Null (Ent, False); 14492 14493 -- Reset the Is_Known_Valid flag unless the type is always 14494 -- valid. This does not apply to a loop parameter because its 14495 -- bounds are defined by the loop header and therefore always 14496 -- valid. 14497 14498 if not Is_Known_Valid (Etype (Ent)) 14499 and then Ekind (Ent) /= E_Loop_Parameter 14500 then 14501 Set_Is_Known_Valid (Ent, False); 14502 end if; 14503 end if; 14504 end if; 14505 end if; 14506 end Kill_Current_Values; 14507 14508 procedure Kill_Current_Values (Last_Assignment_Only : Boolean := False) is 14509 S : Entity_Id; 14510 14511 procedure Kill_Current_Values_For_Entity_Chain (E : Entity_Id); 14512 -- Clear current value for entity E and all entities chained to E 14513 14514 ------------------------------------------ 14515 -- Kill_Current_Values_For_Entity_Chain -- 14516 ------------------------------------------ 14517 14518 procedure Kill_Current_Values_For_Entity_Chain (E : Entity_Id) is 14519 Ent : Entity_Id; 14520 begin 14521 Ent := E; 14522 while Present (Ent) loop 14523 Kill_Current_Values (Ent, Last_Assignment_Only); 14524 Next_Entity (Ent); 14525 end loop; 14526 end Kill_Current_Values_For_Entity_Chain; 14527 14528 -- Start of processing for Kill_Current_Values 14529 14530 begin 14531 -- Kill all saved checks, a special case of killing saved values 14532 14533 if not Last_Assignment_Only then 14534 Kill_All_Checks; 14535 end if; 14536 14537 -- Loop through relevant scopes, which includes the current scope and 14538 -- any parent scopes if the current scope is a block or a package. 14539 14540 S := Current_Scope; 14541 Scope_Loop : loop 14542 14543 -- Clear current values of all entities in current scope 14544 14545 Kill_Current_Values_For_Entity_Chain (First_Entity (S)); 14546 14547 -- If scope is a package, also clear current values of all private 14548 -- entities in the scope. 14549 14550 if Is_Package_Or_Generic_Package (S) 14551 or else Is_Concurrent_Type (S) 14552 then 14553 Kill_Current_Values_For_Entity_Chain (First_Private_Entity (S)); 14554 end if; 14555 14556 -- If this is a not a subprogram, deal with parents 14557 14558 if not Is_Subprogram (S) then 14559 S := Scope (S); 14560 exit Scope_Loop when S = Standard_Standard; 14561 else 14562 exit Scope_Loop; 14563 end if; 14564 end loop Scope_Loop; 14565 end Kill_Current_Values; 14566 14567 -------------------------- 14568 -- Kill_Size_Check_Code -- 14569 -------------------------- 14570 14571 procedure Kill_Size_Check_Code (E : Entity_Id) is 14572 begin 14573 if (Ekind (E) = E_Constant or else Ekind (E) = E_Variable) 14574 and then Present (Size_Check_Code (E)) 14575 then 14576 Remove (Size_Check_Code (E)); 14577 Set_Size_Check_Code (E, Empty); 14578 end if; 14579 end Kill_Size_Check_Code; 14580 14581 -------------------------- 14582 -- Known_To_Be_Assigned -- 14583 -------------------------- 14584 14585 function Known_To_Be_Assigned (N : Node_Id) return Boolean is 14586 P : constant Node_Id := Parent (N); 14587 14588 begin 14589 case Nkind (P) is 14590 14591 -- Test left side of assignment 14592 14593 when N_Assignment_Statement => 14594 return N = Name (P); 14595 14596 -- Function call arguments are never lvalues 14597 14598 when N_Function_Call => 14599 return False; 14600 14601 -- Positional parameter for procedure or accept call 14602 14603 when N_Procedure_Call_Statement | 14604 N_Accept_Statement 14605 => 14606 declare 14607 Proc : Entity_Id; 14608 Form : Entity_Id; 14609 Act : Node_Id; 14610 14611 begin 14612 Proc := Get_Subprogram_Entity (P); 14613 14614 if No (Proc) then 14615 return False; 14616 end if; 14617 14618 -- If we are not a list member, something is strange, so 14619 -- be conservative and return False. 14620 14621 if not Is_List_Member (N) then 14622 return False; 14623 end if; 14624 14625 -- We are going to find the right formal by stepping forward 14626 -- through the formals, as we step backwards in the actuals. 14627 14628 Form := First_Formal (Proc); 14629 Act := N; 14630 loop 14631 -- If no formal, something is weird, so be conservative 14632 -- and return False. 14633 14634 if No (Form) then 14635 return False; 14636 end if; 14637 14638 Prev (Act); 14639 exit when No (Act); 14640 Next_Formal (Form); 14641 end loop; 14642 14643 return Ekind (Form) /= E_In_Parameter; 14644 end; 14645 14646 -- Named parameter for procedure or accept call 14647 14648 when N_Parameter_Association => 14649 declare 14650 Proc : Entity_Id; 14651 Form : Entity_Id; 14652 14653 begin 14654 Proc := Get_Subprogram_Entity (Parent (P)); 14655 14656 if No (Proc) then 14657 return False; 14658 end if; 14659 14660 -- Loop through formals to find the one that matches 14661 14662 Form := First_Formal (Proc); 14663 loop 14664 -- If no matching formal, that's peculiar, some kind of 14665 -- previous error, so return False to be conservative. 14666 -- Actually this also happens in legal code in the case 14667 -- where P is a parameter association for an Extra_Formal??? 14668 14669 if No (Form) then 14670 return False; 14671 end if; 14672 14673 -- Else test for match 14674 14675 if Chars (Form) = Chars (Selector_Name (P)) then 14676 return Ekind (Form) /= E_In_Parameter; 14677 end if; 14678 14679 Next_Formal (Form); 14680 end loop; 14681 end; 14682 14683 -- Test for appearing in a conversion that itself appears 14684 -- in an lvalue context, since this should be an lvalue. 14685 14686 when N_Type_Conversion => 14687 return Known_To_Be_Assigned (P); 14688 14689 -- All other references are definitely not known to be modifications 14690 14691 when others => 14692 return False; 14693 14694 end case; 14695 end Known_To_Be_Assigned; 14696 14697 --------------------------- 14698 -- Last_Source_Statement -- 14699 --------------------------- 14700 14701 function Last_Source_Statement (HSS : Node_Id) return Node_Id is 14702 N : Node_Id; 14703 14704 begin 14705 N := Last (Statements (HSS)); 14706 while Present (N) loop 14707 exit when Comes_From_Source (N); 14708 Prev (N); 14709 end loop; 14710 14711 return N; 14712 end Last_Source_Statement; 14713 14714 ---------------------------------- 14715 -- Matching_Static_Array_Bounds -- 14716 ---------------------------------- 14717 14718 function Matching_Static_Array_Bounds 14719 (L_Typ : Node_Id; 14720 R_Typ : Node_Id) return Boolean 14721 is 14722 L_Ndims : constant Nat := Number_Dimensions (L_Typ); 14723 R_Ndims : constant Nat := Number_Dimensions (R_Typ); 14724 14725 L_Index : Node_Id; 14726 R_Index : Node_Id; 14727 L_Low : Node_Id; 14728 L_High : Node_Id; 14729 L_Len : Uint; 14730 R_Low : Node_Id; 14731 R_High : Node_Id; 14732 R_Len : Uint; 14733 14734 begin 14735 if L_Ndims /= R_Ndims then 14736 return False; 14737 end if; 14738 14739 -- Unconstrained types do not have static bounds 14740 14741 if not Is_Constrained (L_Typ) or else not Is_Constrained (R_Typ) then 14742 return False; 14743 end if; 14744 14745 -- First treat specially the first dimension, as the lower bound and 14746 -- length of string literals are not stored like those of arrays. 14747 14748 if Ekind (L_Typ) = E_String_Literal_Subtype then 14749 L_Low := String_Literal_Low_Bound (L_Typ); 14750 L_Len := String_Literal_Length (L_Typ); 14751 else 14752 L_Index := First_Index (L_Typ); 14753 Get_Index_Bounds (L_Index, L_Low, L_High); 14754 14755 if Is_OK_Static_Expression (L_Low) 14756 and then 14757 Is_OK_Static_Expression (L_High) 14758 then 14759 if Expr_Value (L_High) < Expr_Value (L_Low) then 14760 L_Len := Uint_0; 14761 else 14762 L_Len := (Expr_Value (L_High) - Expr_Value (L_Low)) + 1; 14763 end if; 14764 else 14765 return False; 14766 end if; 14767 end if; 14768 14769 if Ekind (R_Typ) = E_String_Literal_Subtype then 14770 R_Low := String_Literal_Low_Bound (R_Typ); 14771 R_Len := String_Literal_Length (R_Typ); 14772 else 14773 R_Index := First_Index (R_Typ); 14774 Get_Index_Bounds (R_Index, R_Low, R_High); 14775 14776 if Is_OK_Static_Expression (R_Low) 14777 and then 14778 Is_OK_Static_Expression (R_High) 14779 then 14780 if Expr_Value (R_High) < Expr_Value (R_Low) then 14781 R_Len := Uint_0; 14782 else 14783 R_Len := (Expr_Value (R_High) - Expr_Value (R_Low)) + 1; 14784 end if; 14785 else 14786 return False; 14787 end if; 14788 end if; 14789 14790 if (Is_OK_Static_Expression (L_Low) 14791 and then 14792 Is_OK_Static_Expression (R_Low)) 14793 and then Expr_Value (L_Low) = Expr_Value (R_Low) 14794 and then L_Len = R_Len 14795 then 14796 null; 14797 else 14798 return False; 14799 end if; 14800 14801 -- Then treat all other dimensions 14802 14803 for Indx in 2 .. L_Ndims loop 14804 Next (L_Index); 14805 Next (R_Index); 14806 14807 Get_Index_Bounds (L_Index, L_Low, L_High); 14808 Get_Index_Bounds (R_Index, R_Low, R_High); 14809 14810 if (Is_OK_Static_Expression (L_Low) and then 14811 Is_OK_Static_Expression (L_High) and then 14812 Is_OK_Static_Expression (R_Low) and then 14813 Is_OK_Static_Expression (R_High)) 14814 and then (Expr_Value (L_Low) = Expr_Value (R_Low) 14815 and then 14816 Expr_Value (L_High) = Expr_Value (R_High)) 14817 then 14818 null; 14819 else 14820 return False; 14821 end if; 14822 end loop; 14823 14824 -- If we fall through the loop, all indexes matched 14825 14826 return True; 14827 end Matching_Static_Array_Bounds; 14828 14829 ------------------- 14830 -- May_Be_Lvalue -- 14831 ------------------- 14832 14833 function May_Be_Lvalue (N : Node_Id) return Boolean is 14834 P : constant Node_Id := Parent (N); 14835 14836 begin 14837 case Nkind (P) is 14838 14839 -- Test left side of assignment 14840 14841 when N_Assignment_Statement => 14842 return N = Name (P); 14843 14844 -- Test prefix of component or attribute. Note that the prefix of an 14845 -- explicit or implicit dereference cannot be an l-value. 14846 14847 when N_Attribute_Reference => 14848 return N = Prefix (P) 14849 and then Name_Implies_Lvalue_Prefix (Attribute_Name (P)); 14850 14851 -- For an expanded name, the name is an lvalue if the expanded name 14852 -- is an lvalue, but the prefix is never an lvalue, since it is just 14853 -- the scope where the name is found. 14854 14855 when N_Expanded_Name => 14856 if N = Prefix (P) then 14857 return May_Be_Lvalue (P); 14858 else 14859 return False; 14860 end if; 14861 14862 -- For a selected component A.B, A is certainly an lvalue if A.B is. 14863 -- B is a little interesting, if we have A.B := 3, there is some 14864 -- discussion as to whether B is an lvalue or not, we choose to say 14865 -- it is. Note however that A is not an lvalue if it is of an access 14866 -- type since this is an implicit dereference. 14867 14868 when N_Selected_Component => 14869 if N = Prefix (P) 14870 and then Present (Etype (N)) 14871 and then Is_Access_Type (Etype (N)) 14872 then 14873 return False; 14874 else 14875 return May_Be_Lvalue (P); 14876 end if; 14877 14878 -- For an indexed component or slice, the index or slice bounds is 14879 -- never an lvalue. The prefix is an lvalue if the indexed component 14880 -- or slice is an lvalue, except if it is an access type, where we 14881 -- have an implicit dereference. 14882 14883 when N_Indexed_Component | N_Slice => 14884 if N /= Prefix (P) 14885 or else (Present (Etype (N)) and then Is_Access_Type (Etype (N))) 14886 then 14887 return False; 14888 else 14889 return May_Be_Lvalue (P); 14890 end if; 14891 14892 -- Prefix of a reference is an lvalue if the reference is an lvalue 14893 14894 when N_Reference => 14895 return May_Be_Lvalue (P); 14896 14897 -- Prefix of explicit dereference is never an lvalue 14898 14899 when N_Explicit_Dereference => 14900 return False; 14901 14902 -- Positional parameter for subprogram, entry, or accept call. 14903 -- In older versions of Ada function call arguments are never 14904 -- lvalues. In Ada 2012 functions can have in-out parameters. 14905 14906 when N_Subprogram_Call | 14907 N_Entry_Call_Statement | 14908 N_Accept_Statement 14909 => 14910 if Nkind (P) = N_Function_Call and then Ada_Version < Ada_2012 then 14911 return False; 14912 end if; 14913 14914 -- The following mechanism is clumsy and fragile. A single flag 14915 -- set in Resolve_Actuals would be preferable ??? 14916 14917 declare 14918 Proc : Entity_Id; 14919 Form : Entity_Id; 14920 Act : Node_Id; 14921 14922 begin 14923 Proc := Get_Subprogram_Entity (P); 14924 14925 if No (Proc) then 14926 return True; 14927 end if; 14928 14929 -- If we are not a list member, something is strange, so be 14930 -- conservative and return True. 14931 14932 if not Is_List_Member (N) then 14933 return True; 14934 end if; 14935 14936 -- We are going to find the right formal by stepping forward 14937 -- through the formals, as we step backwards in the actuals. 14938 14939 Form := First_Formal (Proc); 14940 Act := N; 14941 loop 14942 -- If no formal, something is weird, so be conservative and 14943 -- return True. 14944 14945 if No (Form) then 14946 return True; 14947 end if; 14948 14949 Prev (Act); 14950 exit when No (Act); 14951 Next_Formal (Form); 14952 end loop; 14953 14954 return Ekind (Form) /= E_In_Parameter; 14955 end; 14956 14957 -- Named parameter for procedure or accept call 14958 14959 when N_Parameter_Association => 14960 declare 14961 Proc : Entity_Id; 14962 Form : Entity_Id; 14963 14964 begin 14965 Proc := Get_Subprogram_Entity (Parent (P)); 14966 14967 if No (Proc) then 14968 return True; 14969 end if; 14970 14971 -- Loop through formals to find the one that matches 14972 14973 Form := First_Formal (Proc); 14974 loop 14975 -- If no matching formal, that's peculiar, some kind of 14976 -- previous error, so return True to be conservative. 14977 -- Actually happens with legal code for an unresolved call 14978 -- where we may get the wrong homonym??? 14979 14980 if No (Form) then 14981 return True; 14982 end if; 14983 14984 -- Else test for match 14985 14986 if Chars (Form) = Chars (Selector_Name (P)) then 14987 return Ekind (Form) /= E_In_Parameter; 14988 end if; 14989 14990 Next_Formal (Form); 14991 end loop; 14992 end; 14993 14994 -- Test for appearing in a conversion that itself appears in an 14995 -- lvalue context, since this should be an lvalue. 14996 14997 when N_Type_Conversion => 14998 return May_Be_Lvalue (P); 14999 15000 -- Test for appearance in object renaming declaration 15001 15002 when N_Object_Renaming_Declaration => 15003 return True; 15004 15005 -- All other references are definitely not lvalues 15006 15007 when others => 15008 return False; 15009 15010 end case; 15011 end May_Be_Lvalue; 15012 15013 ----------------------- 15014 -- Mark_Coextensions -- 15015 ----------------------- 15016 15017 procedure Mark_Coextensions (Context_Nod : Node_Id; Root_Nod : Node_Id) is 15018 Is_Dynamic : Boolean; 15019 -- Indicates whether the context causes nested coextensions to be 15020 -- dynamic or static 15021 15022 function Mark_Allocator (N : Node_Id) return Traverse_Result; 15023 -- Recognize an allocator node and label it as a dynamic coextension 15024 15025 -------------------- 15026 -- Mark_Allocator -- 15027 -------------------- 15028 15029 function Mark_Allocator (N : Node_Id) return Traverse_Result is 15030 begin 15031 if Nkind (N) = N_Allocator then 15032 if Is_Dynamic then 15033 Set_Is_Dynamic_Coextension (N); 15034 15035 -- If the allocator expression is potentially dynamic, it may 15036 -- be expanded out of order and require dynamic allocation 15037 -- anyway, so we treat the coextension itself as dynamic. 15038 -- Potential optimization ??? 15039 15040 elsif Nkind (Expression (N)) = N_Qualified_Expression 15041 and then Nkind (Expression (Expression (N))) = N_Op_Concat 15042 then 15043 Set_Is_Dynamic_Coextension (N); 15044 else 15045 Set_Is_Static_Coextension (N); 15046 end if; 15047 end if; 15048 15049 return OK; 15050 end Mark_Allocator; 15051 15052 procedure Mark_Allocators is new Traverse_Proc (Mark_Allocator); 15053 15054 -- Start of processing for Mark_Coextensions 15055 15056 begin 15057 -- An allocator that appears on the right-hand side of an assignment is 15058 -- treated as a potentially dynamic coextension when the right-hand side 15059 -- is an allocator or a qualified expression. 15060 15061 -- Obj := new ...'(new Coextension ...); 15062 15063 if Nkind (Context_Nod) = N_Assignment_Statement then 15064 Is_Dynamic := 15065 Nkind_In (Expression (Context_Nod), N_Allocator, 15066 N_Qualified_Expression); 15067 15068 -- An allocator that appears within the expression of a simple return 15069 -- statement is treated as a potentially dynamic coextension when the 15070 -- expression is either aggregate, allocator, or qualified expression. 15071 15072 -- return (new Coextension ...); 15073 -- return new ...'(new Coextension ...); 15074 15075 elsif Nkind (Context_Nod) = N_Simple_Return_Statement then 15076 Is_Dynamic := 15077 Nkind_In (Expression (Context_Nod), N_Aggregate, 15078 N_Allocator, 15079 N_Qualified_Expression); 15080 15081 -- An alloctor that appears within the initialization expression of an 15082 -- object declaration is considered a potentially dynamic coextension 15083 -- when the initialization expression is an allocator or a qualified 15084 -- expression. 15085 15086 -- Obj : ... := new ...'(new Coextension ...); 15087 15088 -- A similar case arises when the object declaration is part of an 15089 -- extended return statement. 15090 15091 -- return Obj : ... := new ...'(new Coextension ...); 15092 -- return Obj : ... := (new Coextension ...); 15093 15094 elsif Nkind (Context_Nod) = N_Object_Declaration then 15095 Is_Dynamic := 15096 Nkind_In (Root_Nod, N_Allocator, N_Qualified_Expression) 15097 or else 15098 Nkind (Parent (Context_Nod)) = N_Extended_Return_Statement; 15099 15100 -- This routine should not be called with constructs that cannot contain 15101 -- coextensions. 15102 15103 else 15104 raise Program_Error; 15105 end if; 15106 15107 Mark_Allocators (Root_Nod); 15108 end Mark_Coextensions; 15109 15110 ---------------------- 15111 -- Needs_One_Actual -- 15112 ---------------------- 15113 15114 function Needs_One_Actual (E : Entity_Id) return Boolean is 15115 Formal : Entity_Id; 15116 15117 begin 15118 -- Ada 2005 or later, and formals present 15119 15120 if Ada_Version >= Ada_2005 and then Present (First_Formal (E)) then 15121 Formal := Next_Formal (First_Formal (E)); 15122 while Present (Formal) loop 15123 if No (Default_Value (Formal)) then 15124 return False; 15125 end if; 15126 15127 Next_Formal (Formal); 15128 end loop; 15129 15130 return True; 15131 15132 -- Ada 83/95 or no formals 15133 15134 else 15135 return False; 15136 end if; 15137 end Needs_One_Actual; 15138 15139 ------------------------ 15140 -- New_Copy_List_Tree -- 15141 ------------------------ 15142 15143 function New_Copy_List_Tree (List : List_Id) return List_Id is 15144 NL : List_Id; 15145 E : Node_Id; 15146 15147 begin 15148 if List = No_List then 15149 return No_List; 15150 15151 else 15152 NL := New_List; 15153 E := First (List); 15154 15155 while Present (E) loop 15156 Append (New_Copy_Tree (E), NL); 15157 E := Next (E); 15158 end loop; 15159 15160 return NL; 15161 end if; 15162 end New_Copy_List_Tree; 15163 15164 -------------------------------------------------- 15165 -- New_Copy_Tree Auxiliary Data and Subprograms -- 15166 -------------------------------------------------- 15167 15168 use Atree.Unchecked_Access; 15169 use Atree_Private_Part; 15170 15171 -- Our approach here requires a two pass traversal of the tree. The 15172 -- first pass visits all nodes that eventually will be copied looking 15173 -- for defining Itypes. If any defining Itypes are found, then they are 15174 -- copied, and an entry is added to the replacement map. In the second 15175 -- phase, the tree is copied, using the replacement map to replace any 15176 -- Itype references within the copied tree. 15177 15178 -- The following hash tables are used if the Map supplied has more 15179 -- than hash threshold entries to speed up access to the map. If 15180 -- there are fewer entries, then the map is searched sequentially 15181 -- (because setting up a hash table for only a few entries takes 15182 -- more time than it saves. 15183 15184 function New_Copy_Hash (E : Entity_Id) return NCT_Header_Num; 15185 -- Hash function used for hash operations 15186 15187 ------------------- 15188 -- New_Copy_Hash -- 15189 ------------------- 15190 15191 function New_Copy_Hash (E : Entity_Id) return NCT_Header_Num is 15192 begin 15193 return Nat (E) mod (NCT_Header_Num'Last + 1); 15194 end New_Copy_Hash; 15195 15196 --------------- 15197 -- NCT_Assoc -- 15198 --------------- 15199 15200 -- The hash table NCT_Assoc associates old entities in the table 15201 -- with their corresponding new entities (i.e. the pairs of entries 15202 -- presented in the original Map argument are Key-Element pairs). 15203 15204 package NCT_Assoc is new Simple_HTable ( 15205 Header_Num => NCT_Header_Num, 15206 Element => Entity_Id, 15207 No_Element => Empty, 15208 Key => Entity_Id, 15209 Hash => New_Copy_Hash, 15210 Equal => Types."="); 15211 15212 --------------------- 15213 -- NCT_Itype_Assoc -- 15214 --------------------- 15215 15216 -- The hash table NCT_Itype_Assoc contains entries only for those 15217 -- old nodes which have a non-empty Associated_Node_For_Itype set. 15218 -- The key is the associated node, and the element is the new node 15219 -- itself (NOT the associated node for the new node). 15220 15221 package NCT_Itype_Assoc is new Simple_HTable ( 15222 Header_Num => NCT_Header_Num, 15223 Element => Entity_Id, 15224 No_Element => Empty, 15225 Key => Entity_Id, 15226 Hash => New_Copy_Hash, 15227 Equal => Types."="); 15228 15229 ------------------- 15230 -- New_Copy_Tree -- 15231 ------------------- 15232 15233 function New_Copy_Tree 15234 (Source : Node_Id; 15235 Map : Elist_Id := No_Elist; 15236 New_Sloc : Source_Ptr := No_Location; 15237 New_Scope : Entity_Id := Empty) return Node_Id 15238 is 15239 Actual_Map : Elist_Id := Map; 15240 -- This is the actual map for the copy. It is initialized with the 15241 -- given elements, and then enlarged as required for Itypes that are 15242 -- copied during the first phase of the copy operation. The visit 15243 -- procedures add elements to this map as Itypes are encountered. 15244 -- The reason we cannot use Map directly, is that it may well be 15245 -- (and normally is) initialized to No_Elist, and if we have mapped 15246 -- entities, we have to reset it to point to a real Elist. 15247 15248 function Assoc (N : Node_Or_Entity_Id) return Node_Id; 15249 -- Called during second phase to map entities into their corresponding 15250 -- copies using Actual_Map. If the argument is not an entity, or is not 15251 -- in Actual_Map, then it is returned unchanged. 15252 15253 procedure Build_NCT_Hash_Tables; 15254 -- Builds hash tables (number of elements >= threshold value) 15255 15256 function Copy_Elist_With_Replacement 15257 (Old_Elist : Elist_Id) return Elist_Id; 15258 -- Called during second phase to copy element list doing replacements 15259 15260 procedure Copy_Itype_With_Replacement (New_Itype : Entity_Id); 15261 -- Called during the second phase to process a copied Itype. The actual 15262 -- copy happened during the first phase (so that we could make the entry 15263 -- in the mapping), but we still have to deal with the descendents of 15264 -- the copied Itype and copy them where necessary. 15265 15266 function Copy_List_With_Replacement (Old_List : List_Id) return List_Id; 15267 -- Called during second phase to copy list doing replacements 15268 15269 function Copy_Node_With_Replacement (Old_Node : Node_Id) return Node_Id; 15270 -- Called during second phase to copy node doing replacements 15271 15272 procedure Visit_Elist (E : Elist_Id); 15273 -- Called during first phase to visit all elements of an Elist 15274 15275 procedure Visit_Field (F : Union_Id; N : Node_Id); 15276 -- Visit a single field, recursing to call Visit_Node or Visit_List 15277 -- if the field is a syntactic descendent of the current node (i.e. 15278 -- its parent is Node N). 15279 15280 procedure Visit_Itype (Old_Itype : Entity_Id); 15281 -- Called during first phase to visit subsidiary fields of a defining 15282 -- Itype, and also create a copy and make an entry in the replacement 15283 -- map for the new copy. 15284 15285 procedure Visit_List (L : List_Id); 15286 -- Called during first phase to visit all elements of a List 15287 15288 procedure Visit_Node (N : Node_Or_Entity_Id); 15289 -- Called during first phase to visit a node and all its subtrees 15290 15291 ----------- 15292 -- Assoc -- 15293 ----------- 15294 15295 function Assoc (N : Node_Or_Entity_Id) return Node_Id is 15296 E : Elmt_Id; 15297 Ent : Entity_Id; 15298 15299 begin 15300 if not Has_Extension (N) or else No (Actual_Map) then 15301 return N; 15302 15303 elsif NCT_Hash_Tables_Used then 15304 Ent := NCT_Assoc.Get (Entity_Id (N)); 15305 15306 if Present (Ent) then 15307 return Ent; 15308 else 15309 return N; 15310 end if; 15311 15312 -- No hash table used, do serial search 15313 15314 else 15315 E := First_Elmt (Actual_Map); 15316 while Present (E) loop 15317 if Node (E) = N then 15318 return Node (Next_Elmt (E)); 15319 else 15320 E := Next_Elmt (Next_Elmt (E)); 15321 end if; 15322 end loop; 15323 end if; 15324 15325 return N; 15326 end Assoc; 15327 15328 --------------------------- 15329 -- Build_NCT_Hash_Tables -- 15330 --------------------------- 15331 15332 procedure Build_NCT_Hash_Tables is 15333 Elmt : Elmt_Id; 15334 Ent : Entity_Id; 15335 begin 15336 if NCT_Hash_Table_Setup then 15337 NCT_Assoc.Reset; 15338 NCT_Itype_Assoc.Reset; 15339 end if; 15340 15341 Elmt := First_Elmt (Actual_Map); 15342 while Present (Elmt) loop 15343 Ent := Node (Elmt); 15344 15345 -- Get new entity, and associate old and new 15346 15347 Next_Elmt (Elmt); 15348 NCT_Assoc.Set (Ent, Node (Elmt)); 15349 15350 if Is_Type (Ent) then 15351 declare 15352 Anode : constant Entity_Id := 15353 Associated_Node_For_Itype (Ent); 15354 15355 begin 15356 if Present (Anode) then 15357 15358 -- Enter a link between the associated node of the 15359 -- old Itype and the new Itype, for updating later 15360 -- when node is copied. 15361 15362 NCT_Itype_Assoc.Set (Anode, Node (Elmt)); 15363 end if; 15364 end; 15365 end if; 15366 15367 Next_Elmt (Elmt); 15368 end loop; 15369 15370 NCT_Hash_Tables_Used := True; 15371 NCT_Hash_Table_Setup := True; 15372 end Build_NCT_Hash_Tables; 15373 15374 --------------------------------- 15375 -- Copy_Elist_With_Replacement -- 15376 --------------------------------- 15377 15378 function Copy_Elist_With_Replacement 15379 (Old_Elist : Elist_Id) return Elist_Id 15380 is 15381 M : Elmt_Id; 15382 New_Elist : Elist_Id; 15383 15384 begin 15385 if No (Old_Elist) then 15386 return No_Elist; 15387 15388 else 15389 New_Elist := New_Elmt_List; 15390 15391 M := First_Elmt (Old_Elist); 15392 while Present (M) loop 15393 Append_Elmt (Copy_Node_With_Replacement (Node (M)), New_Elist); 15394 Next_Elmt (M); 15395 end loop; 15396 end if; 15397 15398 return New_Elist; 15399 end Copy_Elist_With_Replacement; 15400 15401 --------------------------------- 15402 -- Copy_Itype_With_Replacement -- 15403 --------------------------------- 15404 15405 -- This routine exactly parallels its phase one analog Visit_Itype, 15406 15407 procedure Copy_Itype_With_Replacement (New_Itype : Entity_Id) is 15408 begin 15409 -- Translate Next_Entity, Scope and Etype fields, in case they 15410 -- reference entities that have been mapped into copies. 15411 15412 Set_Next_Entity (New_Itype, Assoc (Next_Entity (New_Itype))); 15413 Set_Etype (New_Itype, Assoc (Etype (New_Itype))); 15414 15415 if Present (New_Scope) then 15416 Set_Scope (New_Itype, New_Scope); 15417 else 15418 Set_Scope (New_Itype, Assoc (Scope (New_Itype))); 15419 end if; 15420 15421 -- Copy referenced fields 15422 15423 if Is_Discrete_Type (New_Itype) then 15424 Set_Scalar_Range (New_Itype, 15425 Copy_Node_With_Replacement (Scalar_Range (New_Itype))); 15426 15427 elsif Has_Discriminants (Base_Type (New_Itype)) then 15428 Set_Discriminant_Constraint (New_Itype, 15429 Copy_Elist_With_Replacement 15430 (Discriminant_Constraint (New_Itype))); 15431 15432 elsif Is_Array_Type (New_Itype) then 15433 if Present (First_Index (New_Itype)) then 15434 Set_First_Index (New_Itype, 15435 First (Copy_List_With_Replacement 15436 (List_Containing (First_Index (New_Itype))))); 15437 end if; 15438 15439 if Is_Packed (New_Itype) then 15440 Set_Packed_Array_Impl_Type (New_Itype, 15441 Copy_Node_With_Replacement 15442 (Packed_Array_Impl_Type (New_Itype))); 15443 end if; 15444 end if; 15445 end Copy_Itype_With_Replacement; 15446 15447 -------------------------------- 15448 -- Copy_List_With_Replacement -- 15449 -------------------------------- 15450 15451 function Copy_List_With_Replacement 15452 (Old_List : List_Id) return List_Id 15453 is 15454 New_List : List_Id; 15455 E : Node_Id; 15456 15457 begin 15458 if Old_List = No_List then 15459 return No_List; 15460 15461 else 15462 New_List := Empty_List; 15463 15464 E := First (Old_List); 15465 while Present (E) loop 15466 Append (Copy_Node_With_Replacement (E), New_List); 15467 Next (E); 15468 end loop; 15469 15470 return New_List; 15471 end if; 15472 end Copy_List_With_Replacement; 15473 15474 -------------------------------- 15475 -- Copy_Node_With_Replacement -- 15476 -------------------------------- 15477 15478 function Copy_Node_With_Replacement 15479 (Old_Node : Node_Id) return Node_Id 15480 is 15481 New_Node : Node_Id; 15482 15483 procedure Adjust_Named_Associations 15484 (Old_Node : Node_Id; 15485 New_Node : Node_Id); 15486 -- If a call node has named associations, these are chained through 15487 -- the First_Named_Actual, Next_Named_Actual links. These must be 15488 -- propagated separately to the new parameter list, because these 15489 -- are not syntactic fields. 15490 15491 function Copy_Field_With_Replacement 15492 (Field : Union_Id) return Union_Id; 15493 -- Given Field, which is a field of Old_Node, return a copy of it 15494 -- if it is a syntactic field (i.e. its parent is Node), setting 15495 -- the parent of the copy to poit to New_Node. Otherwise returns 15496 -- the field (possibly mapped if it is an entity). 15497 15498 ------------------------------- 15499 -- Adjust_Named_Associations -- 15500 ------------------------------- 15501 15502 procedure Adjust_Named_Associations 15503 (Old_Node : Node_Id; 15504 New_Node : Node_Id) 15505 is 15506 Old_E : Node_Id; 15507 New_E : Node_Id; 15508 15509 Old_Next : Node_Id; 15510 New_Next : Node_Id; 15511 15512 begin 15513 Old_E := First (Parameter_Associations (Old_Node)); 15514 New_E := First (Parameter_Associations (New_Node)); 15515 while Present (Old_E) loop 15516 if Nkind (Old_E) = N_Parameter_Association 15517 and then Present (Next_Named_Actual (Old_E)) 15518 then 15519 if First_Named_Actual (Old_Node) 15520 = Explicit_Actual_Parameter (Old_E) 15521 then 15522 Set_First_Named_Actual 15523 (New_Node, Explicit_Actual_Parameter (New_E)); 15524 end if; 15525 15526 -- Now scan parameter list from the beginning,to locate 15527 -- next named actual, which can be out of order. 15528 15529 Old_Next := First (Parameter_Associations (Old_Node)); 15530 New_Next := First (Parameter_Associations (New_Node)); 15531 15532 while Nkind (Old_Next) /= N_Parameter_Association 15533 or else Explicit_Actual_Parameter (Old_Next) /= 15534 Next_Named_Actual (Old_E) 15535 loop 15536 Next (Old_Next); 15537 Next (New_Next); 15538 end loop; 15539 15540 Set_Next_Named_Actual 15541 (New_E, Explicit_Actual_Parameter (New_Next)); 15542 end if; 15543 15544 Next (Old_E); 15545 Next (New_E); 15546 end loop; 15547 end Adjust_Named_Associations; 15548 15549 --------------------------------- 15550 -- Copy_Field_With_Replacement -- 15551 --------------------------------- 15552 15553 function Copy_Field_With_Replacement 15554 (Field : Union_Id) return Union_Id 15555 is 15556 begin 15557 if Field = Union_Id (Empty) then 15558 return Field; 15559 15560 elsif Field in Node_Range then 15561 declare 15562 Old_N : constant Node_Id := Node_Id (Field); 15563 New_N : Node_Id; 15564 15565 begin 15566 -- If syntactic field, as indicated by the parent pointer 15567 -- being set, then copy the referenced node recursively. 15568 15569 if Parent (Old_N) = Old_Node then 15570 New_N := Copy_Node_With_Replacement (Old_N); 15571 15572 if New_N /= Old_N then 15573 Set_Parent (New_N, New_Node); 15574 end if; 15575 15576 -- For semantic fields, update possible entity reference 15577 -- from the replacement map. 15578 15579 else 15580 New_N := Assoc (Old_N); 15581 end if; 15582 15583 return Union_Id (New_N); 15584 end; 15585 15586 elsif Field in List_Range then 15587 declare 15588 Old_L : constant List_Id := List_Id (Field); 15589 New_L : List_Id; 15590 15591 begin 15592 -- If syntactic field, as indicated by the parent pointer, 15593 -- then recursively copy the entire referenced list. 15594 15595 if Parent (Old_L) = Old_Node then 15596 New_L := Copy_List_With_Replacement (Old_L); 15597 Set_Parent (New_L, New_Node); 15598 15599 -- For semantic list, just returned unchanged 15600 15601 else 15602 New_L := Old_L; 15603 end if; 15604 15605 return Union_Id (New_L); 15606 end; 15607 15608 -- Anything other than a list or a node is returned unchanged 15609 15610 else 15611 return Field; 15612 end if; 15613 end Copy_Field_With_Replacement; 15614 15615 -- Start of processing for Copy_Node_With_Replacement 15616 15617 begin 15618 if Old_Node <= Empty_Or_Error then 15619 return Old_Node; 15620 15621 elsif Has_Extension (Old_Node) then 15622 return Assoc (Old_Node); 15623 15624 else 15625 New_Node := New_Copy (Old_Node); 15626 15627 -- If the node we are copying is the associated node of a 15628 -- previously copied Itype, then adjust the associated node 15629 -- of the copy of that Itype accordingly. 15630 15631 if Present (Actual_Map) then 15632 declare 15633 E : Elmt_Id; 15634 Ent : Entity_Id; 15635 15636 begin 15637 -- Case of hash table used 15638 15639 if NCT_Hash_Tables_Used then 15640 Ent := NCT_Itype_Assoc.Get (Old_Node); 15641 15642 if Present (Ent) then 15643 Set_Associated_Node_For_Itype (Ent, New_Node); 15644 end if; 15645 15646 -- Case of no hash table used 15647 15648 else 15649 E := First_Elmt (Actual_Map); 15650 while Present (E) loop 15651 if Is_Itype (Node (E)) 15652 and then 15653 Old_Node = Associated_Node_For_Itype (Node (E)) 15654 then 15655 Set_Associated_Node_For_Itype 15656 (Node (Next_Elmt (E)), New_Node); 15657 end if; 15658 15659 E := Next_Elmt (Next_Elmt (E)); 15660 end loop; 15661 end if; 15662 end; 15663 end if; 15664 15665 -- Recursively copy descendents 15666 15667 Set_Field1 15668 (New_Node, Copy_Field_With_Replacement (Field1 (New_Node))); 15669 Set_Field2 15670 (New_Node, Copy_Field_With_Replacement (Field2 (New_Node))); 15671 Set_Field3 15672 (New_Node, Copy_Field_With_Replacement (Field3 (New_Node))); 15673 Set_Field4 15674 (New_Node, Copy_Field_With_Replacement (Field4 (New_Node))); 15675 Set_Field5 15676 (New_Node, Copy_Field_With_Replacement (Field5 (New_Node))); 15677 15678 -- Adjust Sloc of new node if necessary 15679 15680 if New_Sloc /= No_Location then 15681 Set_Sloc (New_Node, New_Sloc); 15682 15683 -- If we adjust the Sloc, then we are essentially making 15684 -- a completely new node, so the Comes_From_Source flag 15685 -- should be reset to the proper default value. 15686 15687 Nodes.Table (New_Node).Comes_From_Source := 15688 Default_Node.Comes_From_Source; 15689 end if; 15690 15691 -- If the node is call and has named associations, 15692 -- set the corresponding links in the copy. 15693 15694 if (Nkind (Old_Node) = N_Function_Call 15695 or else Nkind (Old_Node) = N_Entry_Call_Statement 15696 or else 15697 Nkind (Old_Node) = N_Procedure_Call_Statement) 15698 and then Present (First_Named_Actual (Old_Node)) 15699 then 15700 Adjust_Named_Associations (Old_Node, New_Node); 15701 end if; 15702 15703 -- Reset First_Real_Statement for Handled_Sequence_Of_Statements. 15704 -- The replacement mechanism applies to entities, and is not used 15705 -- here. Eventually we may need a more general graph-copying 15706 -- routine. For now, do a sequential search to find desired node. 15707 15708 if Nkind (Old_Node) = N_Handled_Sequence_Of_Statements 15709 and then Present (First_Real_Statement (Old_Node)) 15710 then 15711 declare 15712 Old_F : constant Node_Id := First_Real_Statement (Old_Node); 15713 N1, N2 : Node_Id; 15714 15715 begin 15716 N1 := First (Statements (Old_Node)); 15717 N2 := First (Statements (New_Node)); 15718 15719 while N1 /= Old_F loop 15720 Next (N1); 15721 Next (N2); 15722 end loop; 15723 15724 Set_First_Real_Statement (New_Node, N2); 15725 end; 15726 end if; 15727 end if; 15728 15729 -- All done, return copied node 15730 15731 return New_Node; 15732 end Copy_Node_With_Replacement; 15733 15734 ----------------- 15735 -- Visit_Elist -- 15736 ----------------- 15737 15738 procedure Visit_Elist (E : Elist_Id) is 15739 Elmt : Elmt_Id; 15740 begin 15741 if Present (E) then 15742 Elmt := First_Elmt (E); 15743 15744 while Elmt /= No_Elmt loop 15745 Visit_Node (Node (Elmt)); 15746 Next_Elmt (Elmt); 15747 end loop; 15748 end if; 15749 end Visit_Elist; 15750 15751 ----------------- 15752 -- Visit_Field -- 15753 ----------------- 15754 15755 procedure Visit_Field (F : Union_Id; N : Node_Id) is 15756 begin 15757 if F = Union_Id (Empty) then 15758 return; 15759 15760 elsif F in Node_Range then 15761 15762 -- Copy node if it is syntactic, i.e. its parent pointer is 15763 -- set to point to the field that referenced it (certain 15764 -- Itypes will also meet this criterion, which is fine, since 15765 -- these are clearly Itypes that do need to be copied, since 15766 -- we are copying their parent.) 15767 15768 if Parent (Node_Id (F)) = N then 15769 Visit_Node (Node_Id (F)); 15770 return; 15771 15772 -- Another case, if we are pointing to an Itype, then we want 15773 -- to copy it if its associated node is somewhere in the tree 15774 -- being copied. 15775 15776 -- Note: the exclusion of self-referential copies is just an 15777 -- optimization, since the search of the already copied list 15778 -- would catch it, but it is a common case (Etype pointing 15779 -- to itself for an Itype that is a base type). 15780 15781 elsif Has_Extension (Node_Id (F)) 15782 and then Is_Itype (Entity_Id (F)) 15783 and then Node_Id (F) /= N 15784 then 15785 declare 15786 P : Node_Id; 15787 15788 begin 15789 P := Associated_Node_For_Itype (Node_Id (F)); 15790 while Present (P) loop 15791 if P = Source then 15792 Visit_Node (Node_Id (F)); 15793 return; 15794 else 15795 P := Parent (P); 15796 end if; 15797 end loop; 15798 15799 -- An Itype whose parent is not being copied definitely 15800 -- should NOT be copied, since it does not belong in any 15801 -- sense to the copied subtree. 15802 15803 return; 15804 end; 15805 end if; 15806 15807 elsif F in List_Range and then Parent (List_Id (F)) = N then 15808 Visit_List (List_Id (F)); 15809 return; 15810 end if; 15811 end Visit_Field; 15812 15813 ----------------- 15814 -- Visit_Itype -- 15815 ----------------- 15816 15817 procedure Visit_Itype (Old_Itype : Entity_Id) is 15818 New_Itype : Entity_Id; 15819 E : Elmt_Id; 15820 Ent : Entity_Id; 15821 15822 begin 15823 -- Itypes that describe the designated type of access to subprograms 15824 -- have the structure of subprogram declarations, with signatures, 15825 -- etc. Either we duplicate the signatures completely, or choose to 15826 -- share such itypes, which is fine because their elaboration will 15827 -- have no side effects. 15828 15829 if Ekind (Old_Itype) = E_Subprogram_Type then 15830 return; 15831 end if; 15832 15833 New_Itype := New_Copy (Old_Itype); 15834 15835 -- The new Itype has all the attributes of the old one, and 15836 -- we just copy the contents of the entity. However, the back-end 15837 -- needs different names for debugging purposes, so we create a 15838 -- new internal name for it in all cases. 15839 15840 Set_Chars (New_Itype, New_Internal_Name ('T')); 15841 15842 -- If our associated node is an entity that has already been copied, 15843 -- then set the associated node of the copy to point to the right 15844 -- copy. If we have copied an Itype that is itself the associated 15845 -- node of some previously copied Itype, then we set the right 15846 -- pointer in the other direction. 15847 15848 if Present (Actual_Map) then 15849 15850 -- Case of hash tables used 15851 15852 if NCT_Hash_Tables_Used then 15853 15854 Ent := NCT_Assoc.Get (Associated_Node_For_Itype (Old_Itype)); 15855 15856 if Present (Ent) then 15857 Set_Associated_Node_For_Itype (New_Itype, Ent); 15858 end if; 15859 15860 Ent := NCT_Itype_Assoc.Get (Old_Itype); 15861 if Present (Ent) then 15862 Set_Associated_Node_For_Itype (Ent, New_Itype); 15863 15864 -- If the hash table has no association for this Itype and 15865 -- its associated node, enter one now. 15866 15867 else 15868 NCT_Itype_Assoc.Set 15869 (Associated_Node_For_Itype (Old_Itype), New_Itype); 15870 end if; 15871 15872 -- Case of hash tables not used 15873 15874 else 15875 E := First_Elmt (Actual_Map); 15876 while Present (E) loop 15877 if Associated_Node_For_Itype (Old_Itype) = Node (E) then 15878 Set_Associated_Node_For_Itype 15879 (New_Itype, Node (Next_Elmt (E))); 15880 end if; 15881 15882 if Is_Type (Node (E)) 15883 and then Old_Itype = Associated_Node_For_Itype (Node (E)) 15884 then 15885 Set_Associated_Node_For_Itype 15886 (Node (Next_Elmt (E)), New_Itype); 15887 end if; 15888 15889 E := Next_Elmt (Next_Elmt (E)); 15890 end loop; 15891 end if; 15892 end if; 15893 15894 if Present (Freeze_Node (New_Itype)) then 15895 Set_Is_Frozen (New_Itype, False); 15896 Set_Freeze_Node (New_Itype, Empty); 15897 end if; 15898 15899 -- Add new association to map 15900 15901 if No (Actual_Map) then 15902 Actual_Map := New_Elmt_List; 15903 end if; 15904 15905 Append_Elmt (Old_Itype, Actual_Map); 15906 Append_Elmt (New_Itype, Actual_Map); 15907 15908 if NCT_Hash_Tables_Used then 15909 NCT_Assoc.Set (Old_Itype, New_Itype); 15910 15911 else 15912 NCT_Table_Entries := NCT_Table_Entries + 1; 15913 15914 if NCT_Table_Entries > NCT_Hash_Threshold then 15915 Build_NCT_Hash_Tables; 15916 end if; 15917 end if; 15918 15919 -- If a record subtype is simply copied, the entity list will be 15920 -- shared. Thus cloned_Subtype must be set to indicate the sharing. 15921 15922 if Ekind_In (Old_Itype, E_Record_Subtype, E_Class_Wide_Subtype) then 15923 Set_Cloned_Subtype (New_Itype, Old_Itype); 15924 end if; 15925 15926 -- Visit descendents that eventually get copied 15927 15928 Visit_Field (Union_Id (Etype (Old_Itype)), Old_Itype); 15929 15930 if Is_Discrete_Type (Old_Itype) then 15931 Visit_Field (Union_Id (Scalar_Range (Old_Itype)), Old_Itype); 15932 15933 elsif Has_Discriminants (Base_Type (Old_Itype)) then 15934 -- ??? This should involve call to Visit_Field 15935 Visit_Elist (Discriminant_Constraint (Old_Itype)); 15936 15937 elsif Is_Array_Type (Old_Itype) then 15938 if Present (First_Index (Old_Itype)) then 15939 Visit_Field (Union_Id (List_Containing 15940 (First_Index (Old_Itype))), 15941 Old_Itype); 15942 end if; 15943 15944 if Is_Packed (Old_Itype) then 15945 Visit_Field (Union_Id (Packed_Array_Impl_Type (Old_Itype)), 15946 Old_Itype); 15947 end if; 15948 end if; 15949 end Visit_Itype; 15950 15951 ---------------- 15952 -- Visit_List -- 15953 ---------------- 15954 15955 procedure Visit_List (L : List_Id) is 15956 N : Node_Id; 15957 begin 15958 if L /= No_List then 15959 N := First (L); 15960 15961 while Present (N) loop 15962 Visit_Node (N); 15963 Next (N); 15964 end loop; 15965 end if; 15966 end Visit_List; 15967 15968 ---------------- 15969 -- Visit_Node -- 15970 ---------------- 15971 15972 procedure Visit_Node (N : Node_Or_Entity_Id) is 15973 15974 -- Start of processing for Visit_Node 15975 15976 begin 15977 -- Handle case of an Itype, which must be copied 15978 15979 if Has_Extension (N) and then Is_Itype (N) then 15980 15981 -- Nothing to do if already in the list. This can happen with an 15982 -- Itype entity that appears more than once in the tree. 15983 -- Note that we do not want to visit descendents in this case. 15984 15985 -- Test for already in list when hash table is used 15986 15987 if NCT_Hash_Tables_Used then 15988 if Present (NCT_Assoc.Get (Entity_Id (N))) then 15989 return; 15990 end if; 15991 15992 -- Test for already in list when hash table not used 15993 15994 else 15995 declare 15996 E : Elmt_Id; 15997 begin 15998 if Present (Actual_Map) then 15999 E := First_Elmt (Actual_Map); 16000 while Present (E) loop 16001 if Node (E) = N then 16002 return; 16003 else 16004 E := Next_Elmt (Next_Elmt (E)); 16005 end if; 16006 end loop; 16007 end if; 16008 end; 16009 end if; 16010 16011 Visit_Itype (N); 16012 end if; 16013 16014 -- Visit descendents 16015 16016 Visit_Field (Field1 (N), N); 16017 Visit_Field (Field2 (N), N); 16018 Visit_Field (Field3 (N), N); 16019 Visit_Field (Field4 (N), N); 16020 Visit_Field (Field5 (N), N); 16021 end Visit_Node; 16022 16023 -- Start of processing for New_Copy_Tree 16024 16025 begin 16026 Actual_Map := Map; 16027 16028 -- See if we should use hash table 16029 16030 if No (Actual_Map) then 16031 NCT_Hash_Tables_Used := False; 16032 16033 else 16034 declare 16035 Elmt : Elmt_Id; 16036 16037 begin 16038 NCT_Table_Entries := 0; 16039 16040 Elmt := First_Elmt (Actual_Map); 16041 while Present (Elmt) loop 16042 NCT_Table_Entries := NCT_Table_Entries + 1; 16043 Next_Elmt (Elmt); 16044 Next_Elmt (Elmt); 16045 end loop; 16046 16047 if NCT_Table_Entries > NCT_Hash_Threshold then 16048 Build_NCT_Hash_Tables; 16049 else 16050 NCT_Hash_Tables_Used := False; 16051 end if; 16052 end; 16053 end if; 16054 16055 -- Hash table set up if required, now start phase one by visiting 16056 -- top node (we will recursively visit the descendents). 16057 16058 Visit_Node (Source); 16059 16060 -- Now the second phase of the copy can start. First we process 16061 -- all the mapped entities, copying their descendents. 16062 16063 if Present (Actual_Map) then 16064 declare 16065 Elmt : Elmt_Id; 16066 New_Itype : Entity_Id; 16067 begin 16068 Elmt := First_Elmt (Actual_Map); 16069 while Present (Elmt) loop 16070 Next_Elmt (Elmt); 16071 New_Itype := Node (Elmt); 16072 16073 if Is_Itype (New_Itype) then 16074 Copy_Itype_With_Replacement (New_Itype); 16075 end if; 16076 Next_Elmt (Elmt); 16077 end loop; 16078 end; 16079 end if; 16080 16081 -- Now we can copy the actual tree 16082 16083 return Copy_Node_With_Replacement (Source); 16084 end New_Copy_Tree; 16085 16086 ------------------------- 16087 -- New_External_Entity -- 16088 ------------------------- 16089 16090 function New_External_Entity 16091 (Kind : Entity_Kind; 16092 Scope_Id : Entity_Id; 16093 Sloc_Value : Source_Ptr; 16094 Related_Id : Entity_Id; 16095 Suffix : Character; 16096 Suffix_Index : Nat := 0; 16097 Prefix : Character := ' ') return Entity_Id 16098 is 16099 N : constant Entity_Id := 16100 Make_Defining_Identifier (Sloc_Value, 16101 New_External_Name 16102 (Chars (Related_Id), Suffix, Suffix_Index, Prefix)); 16103 16104 begin 16105 Set_Ekind (N, Kind); 16106 Set_Is_Internal (N, True); 16107 Append_Entity (N, Scope_Id); 16108 Set_Public_Status (N); 16109 16110 if Kind in Type_Kind then 16111 Init_Size_Align (N); 16112 end if; 16113 16114 return N; 16115 end New_External_Entity; 16116 16117 ------------------------- 16118 -- New_Internal_Entity -- 16119 ------------------------- 16120 16121 function New_Internal_Entity 16122 (Kind : Entity_Kind; 16123 Scope_Id : Entity_Id; 16124 Sloc_Value : Source_Ptr; 16125 Id_Char : Character) return Entity_Id 16126 is 16127 N : constant Entity_Id := Make_Temporary (Sloc_Value, Id_Char); 16128 16129 begin 16130 Set_Ekind (N, Kind); 16131 Set_Is_Internal (N, True); 16132 Append_Entity (N, Scope_Id); 16133 16134 if Kind in Type_Kind then 16135 Init_Size_Align (N); 16136 end if; 16137 16138 return N; 16139 end New_Internal_Entity; 16140 16141 ----------------- 16142 -- Next_Actual -- 16143 ----------------- 16144 16145 function Next_Actual (Actual_Id : Node_Id) return Node_Id is 16146 N : Node_Id; 16147 16148 begin 16149 -- If we are pointing at a positional parameter, it is a member of a 16150 -- node list (the list of parameters), and the next parameter is the 16151 -- next node on the list, unless we hit a parameter association, then 16152 -- we shift to using the chain whose head is the First_Named_Actual in 16153 -- the parent, and then is threaded using the Next_Named_Actual of the 16154 -- Parameter_Association. All this fiddling is because the original node 16155 -- list is in the textual call order, and what we need is the 16156 -- declaration order. 16157 16158 if Is_List_Member (Actual_Id) then 16159 N := Next (Actual_Id); 16160 16161 if Nkind (N) = N_Parameter_Association then 16162 return First_Named_Actual (Parent (Actual_Id)); 16163 else 16164 return N; 16165 end if; 16166 16167 else 16168 return Next_Named_Actual (Parent (Actual_Id)); 16169 end if; 16170 end Next_Actual; 16171 16172 procedure Next_Actual (Actual_Id : in out Node_Id) is 16173 begin 16174 Actual_Id := Next_Actual (Actual_Id); 16175 end Next_Actual; 16176 16177 ----------------------- 16178 -- Normalize_Actuals -- 16179 ----------------------- 16180 16181 -- Chain actuals according to formals of subprogram. If there are no named 16182 -- associations, the chain is simply the list of Parameter Associations, 16183 -- since the order is the same as the declaration order. If there are named 16184 -- associations, then the First_Named_Actual field in the N_Function_Call 16185 -- or N_Procedure_Call_Statement node points to the Parameter_Association 16186 -- node for the parameter that comes first in declaration order. The 16187 -- remaining named parameters are then chained in declaration order using 16188 -- Next_Named_Actual. 16189 16190 -- This routine also verifies that the number of actuals is compatible with 16191 -- the number and default values of formals, but performs no type checking 16192 -- (type checking is done by the caller). 16193 16194 -- If the matching succeeds, Success is set to True and the caller proceeds 16195 -- with type-checking. If the match is unsuccessful, then Success is set to 16196 -- False, and the caller attempts a different interpretation, if there is 16197 -- one. 16198 16199 -- If the flag Report is on, the call is not overloaded, and a failure to 16200 -- match can be reported here, rather than in the caller. 16201 16202 procedure Normalize_Actuals 16203 (N : Node_Id; 16204 S : Entity_Id; 16205 Report : Boolean; 16206 Success : out Boolean) 16207 is 16208 Actuals : constant List_Id := Parameter_Associations (N); 16209 Actual : Node_Id := Empty; 16210 Formal : Entity_Id; 16211 Last : Node_Id := Empty; 16212 First_Named : Node_Id := Empty; 16213 Found : Boolean; 16214 16215 Formals_To_Match : Integer := 0; 16216 Actuals_To_Match : Integer := 0; 16217 16218 procedure Chain (A : Node_Id); 16219 -- Add named actual at the proper place in the list, using the 16220 -- Next_Named_Actual link. 16221 16222 function Reporting return Boolean; 16223 -- Determines if an error is to be reported. To report an error, we 16224 -- need Report to be True, and also we do not report errors caused 16225 -- by calls to init procs that occur within other init procs. Such 16226 -- errors must always be cascaded errors, since if all the types are 16227 -- declared correctly, the compiler will certainly build decent calls. 16228 16229 ----------- 16230 -- Chain -- 16231 ----------- 16232 16233 procedure Chain (A : Node_Id) is 16234 begin 16235 if No (Last) then 16236 16237 -- Call node points to first actual in list 16238 16239 Set_First_Named_Actual (N, Explicit_Actual_Parameter (A)); 16240 16241 else 16242 Set_Next_Named_Actual (Last, Explicit_Actual_Parameter (A)); 16243 end if; 16244 16245 Last := A; 16246 Set_Next_Named_Actual (Last, Empty); 16247 end Chain; 16248 16249 --------------- 16250 -- Reporting -- 16251 --------------- 16252 16253 function Reporting return Boolean is 16254 begin 16255 if not Report then 16256 return False; 16257 16258 elsif not Within_Init_Proc then 16259 return True; 16260 16261 elsif Is_Init_Proc (Entity (Name (N))) then 16262 return False; 16263 16264 else 16265 return True; 16266 end if; 16267 end Reporting; 16268 16269 -- Start of processing for Normalize_Actuals 16270 16271 begin 16272 if Is_Access_Type (S) then 16273 16274 -- The name in the call is a function call that returns an access 16275 -- to subprogram. The designated type has the list of formals. 16276 16277 Formal := First_Formal (Designated_Type (S)); 16278 else 16279 Formal := First_Formal (S); 16280 end if; 16281 16282 while Present (Formal) loop 16283 Formals_To_Match := Formals_To_Match + 1; 16284 Next_Formal (Formal); 16285 end loop; 16286 16287 -- Find if there is a named association, and verify that no positional 16288 -- associations appear after named ones. 16289 16290 if Present (Actuals) then 16291 Actual := First (Actuals); 16292 end if; 16293 16294 while Present (Actual) 16295 and then Nkind (Actual) /= N_Parameter_Association 16296 loop 16297 Actuals_To_Match := Actuals_To_Match + 1; 16298 Next (Actual); 16299 end loop; 16300 16301 if No (Actual) and Actuals_To_Match = Formals_To_Match then 16302 16303 -- Most common case: positional notation, no defaults 16304 16305 Success := True; 16306 return; 16307 16308 elsif Actuals_To_Match > Formals_To_Match then 16309 16310 -- Too many actuals: will not work 16311 16312 if Reporting then 16313 if Is_Entity_Name (Name (N)) then 16314 Error_Msg_N ("too many arguments in call to&", Name (N)); 16315 else 16316 Error_Msg_N ("too many arguments in call", N); 16317 end if; 16318 end if; 16319 16320 Success := False; 16321 return; 16322 end if; 16323 16324 First_Named := Actual; 16325 16326 while Present (Actual) loop 16327 if Nkind (Actual) /= N_Parameter_Association then 16328 Error_Msg_N 16329 ("positional parameters not allowed after named ones", Actual); 16330 Success := False; 16331 return; 16332 16333 else 16334 Actuals_To_Match := Actuals_To_Match + 1; 16335 end if; 16336 16337 Next (Actual); 16338 end loop; 16339 16340 if Present (Actuals) then 16341 Actual := First (Actuals); 16342 end if; 16343 16344 Formal := First_Formal (S); 16345 while Present (Formal) loop 16346 16347 -- Match the formals in order. If the corresponding actual is 16348 -- positional, nothing to do. Else scan the list of named actuals 16349 -- to find the one with the right name. 16350 16351 if Present (Actual) 16352 and then Nkind (Actual) /= N_Parameter_Association 16353 then 16354 Next (Actual); 16355 Actuals_To_Match := Actuals_To_Match - 1; 16356 Formals_To_Match := Formals_To_Match - 1; 16357 16358 else 16359 -- For named parameters, search the list of actuals to find 16360 -- one that matches the next formal name. 16361 16362 Actual := First_Named; 16363 Found := False; 16364 while Present (Actual) loop 16365 if Chars (Selector_Name (Actual)) = Chars (Formal) then 16366 Found := True; 16367 Chain (Actual); 16368 Actuals_To_Match := Actuals_To_Match - 1; 16369 Formals_To_Match := Formals_To_Match - 1; 16370 exit; 16371 end if; 16372 16373 Next (Actual); 16374 end loop; 16375 16376 if not Found then 16377 if Ekind (Formal) /= E_In_Parameter 16378 or else No (Default_Value (Formal)) 16379 then 16380 if Reporting then 16381 if (Comes_From_Source (S) 16382 or else Sloc (S) = Standard_Location) 16383 and then Is_Overloadable (S) 16384 then 16385 if No (Actuals) 16386 and then 16387 Nkind_In (Parent (N), N_Procedure_Call_Statement, 16388 N_Function_Call, 16389 N_Parameter_Association) 16390 and then Ekind (S) /= E_Function 16391 then 16392 Set_Etype (N, Etype (S)); 16393 16394 else 16395 Error_Msg_Name_1 := Chars (S); 16396 Error_Msg_Sloc := Sloc (S); 16397 Error_Msg_NE 16398 ("missing argument for parameter & " 16399 & "in call to % declared #", N, Formal); 16400 end if; 16401 16402 elsif Is_Overloadable (S) then 16403 Error_Msg_Name_1 := Chars (S); 16404 16405 -- Point to type derivation that generated the 16406 -- operation. 16407 16408 Error_Msg_Sloc := Sloc (Parent (S)); 16409 16410 Error_Msg_NE 16411 ("missing argument for parameter & " 16412 & "in call to % (inherited) #", N, Formal); 16413 16414 else 16415 Error_Msg_NE 16416 ("missing argument for parameter &", N, Formal); 16417 end if; 16418 end if; 16419 16420 Success := False; 16421 return; 16422 16423 else 16424 Formals_To_Match := Formals_To_Match - 1; 16425 end if; 16426 end if; 16427 end if; 16428 16429 Next_Formal (Formal); 16430 end loop; 16431 16432 if Formals_To_Match = 0 and then Actuals_To_Match = 0 then 16433 Success := True; 16434 return; 16435 16436 else 16437 if Reporting then 16438 16439 -- Find some superfluous named actual that did not get 16440 -- attached to the list of associations. 16441 16442 Actual := First (Actuals); 16443 while Present (Actual) loop 16444 if Nkind (Actual) = N_Parameter_Association 16445 and then Actual /= Last 16446 and then No (Next_Named_Actual (Actual)) 16447 then 16448 Error_Msg_N ("unmatched actual & in call", 16449 Selector_Name (Actual)); 16450 exit; 16451 end if; 16452 16453 Next (Actual); 16454 end loop; 16455 end if; 16456 16457 Success := False; 16458 return; 16459 end if; 16460 end Normalize_Actuals; 16461 16462 -------------------------------- 16463 -- Note_Possible_Modification -- 16464 -------------------------------- 16465 16466 procedure Note_Possible_Modification (N : Node_Id; Sure : Boolean) is 16467 Modification_Comes_From_Source : constant Boolean := 16468 Comes_From_Source (Parent (N)); 16469 16470 Ent : Entity_Id; 16471 Exp : Node_Id; 16472 16473 begin 16474 -- Loop to find referenced entity, if there is one 16475 16476 Exp := N; 16477 loop 16478 Ent := Empty; 16479 16480 if Is_Entity_Name (Exp) then 16481 Ent := Entity (Exp); 16482 16483 -- If the entity is missing, it is an undeclared identifier, 16484 -- and there is nothing to annotate. 16485 16486 if No (Ent) then 16487 return; 16488 end if; 16489 16490 elsif Nkind (Exp) = N_Explicit_Dereference then 16491 declare 16492 P : constant Node_Id := Prefix (Exp); 16493 16494 begin 16495 -- In formal verification mode, keep track of all reads and 16496 -- writes through explicit dereferences. 16497 16498 if GNATprove_Mode then 16499 SPARK_Specific.Generate_Dereference (N, 'm'); 16500 end if; 16501 16502 if Nkind (P) = N_Selected_Component 16503 and then Present (Entry_Formal (Entity (Selector_Name (P)))) 16504 then 16505 -- Case of a reference to an entry formal 16506 16507 Ent := Entry_Formal (Entity (Selector_Name (P))); 16508 16509 elsif Nkind (P) = N_Identifier 16510 and then Nkind (Parent (Entity (P))) = N_Object_Declaration 16511 and then Present (Expression (Parent (Entity (P)))) 16512 and then Nkind (Expression (Parent (Entity (P)))) = 16513 N_Reference 16514 then 16515 -- Case of a reference to a value on which side effects have 16516 -- been removed. 16517 16518 Exp := Prefix (Expression (Parent (Entity (P)))); 16519 goto Continue; 16520 16521 else 16522 return; 16523 end if; 16524 end; 16525 16526 elsif Nkind_In (Exp, N_Type_Conversion, 16527 N_Unchecked_Type_Conversion) 16528 then 16529 Exp := Expression (Exp); 16530 goto Continue; 16531 16532 elsif Nkind_In (Exp, N_Slice, 16533 N_Indexed_Component, 16534 N_Selected_Component) 16535 then 16536 -- Special check, if the prefix is an access type, then return 16537 -- since we are modifying the thing pointed to, not the prefix. 16538 -- When we are expanding, most usually the prefix is replaced 16539 -- by an explicit dereference, and this test is not needed, but 16540 -- in some cases (notably -gnatc mode and generics) when we do 16541 -- not do full expansion, we need this special test. 16542 16543 if Is_Access_Type (Etype (Prefix (Exp))) then 16544 return; 16545 16546 -- Otherwise go to prefix and keep going 16547 16548 else 16549 Exp := Prefix (Exp); 16550 goto Continue; 16551 end if; 16552 16553 -- All other cases, not a modification 16554 16555 else 16556 return; 16557 end if; 16558 16559 -- Now look for entity being referenced 16560 16561 if Present (Ent) then 16562 if Is_Object (Ent) then 16563 if Comes_From_Source (Exp) 16564 or else Modification_Comes_From_Source 16565 then 16566 -- Give warning if pragma unmodified given and we are 16567 -- sure this is a modification. 16568 16569 if Has_Pragma_Unmodified (Ent) and then Sure then 16570 Error_Msg_NE ("??pragma Unmodified given for &!", N, Ent); 16571 end if; 16572 16573 Set_Never_Set_In_Source (Ent, False); 16574 end if; 16575 16576 Set_Is_True_Constant (Ent, False); 16577 Set_Current_Value (Ent, Empty); 16578 Set_Is_Known_Null (Ent, False); 16579 16580 if not Can_Never_Be_Null (Ent) then 16581 Set_Is_Known_Non_Null (Ent, False); 16582 end if; 16583 16584 -- Follow renaming chain 16585 16586 if (Ekind (Ent) = E_Variable or else Ekind (Ent) = E_Constant) 16587 and then Present (Renamed_Object (Ent)) 16588 then 16589 Exp := Renamed_Object (Ent); 16590 16591 -- If the entity is the loop variable in an iteration over 16592 -- a container, retrieve container expression to indicate 16593 -- possible modification. 16594 16595 if Present (Related_Expression (Ent)) 16596 and then Nkind (Parent (Related_Expression (Ent))) = 16597 N_Iterator_Specification 16598 then 16599 Exp := Original_Node (Related_Expression (Ent)); 16600 end if; 16601 16602 goto Continue; 16603 16604 -- The expression may be the renaming of a subcomponent of an 16605 -- array or container. The assignment to the subcomponent is 16606 -- a modification of the container. 16607 16608 elsif Comes_From_Source (Original_Node (Exp)) 16609 and then Nkind_In (Original_Node (Exp), N_Selected_Component, 16610 N_Indexed_Component) 16611 then 16612 Exp := Prefix (Original_Node (Exp)); 16613 goto Continue; 16614 end if; 16615 16616 -- Generate a reference only if the assignment comes from 16617 -- source. This excludes, for example, calls to a dispatching 16618 -- assignment operation when the left-hand side is tagged. In 16619 -- GNATprove mode, we need those references also on generated 16620 -- code, as these are used to compute the local effects of 16621 -- subprograms. 16622 16623 if Modification_Comes_From_Source or GNATprove_Mode then 16624 Generate_Reference (Ent, Exp, 'm'); 16625 16626 -- If the target of the assignment is the bound variable 16627 -- in an iterator, indicate that the corresponding array 16628 -- or container is also modified. 16629 16630 if Ada_Version >= Ada_2012 16631 and then Nkind (Parent (Ent)) = N_Iterator_Specification 16632 then 16633 declare 16634 Domain : constant Node_Id := Name (Parent (Ent)); 16635 16636 begin 16637 -- TBD : in the full version of the construct, the 16638 -- domain of iteration can be given by an expression. 16639 16640 if Is_Entity_Name (Domain) then 16641 Generate_Reference (Entity (Domain), Exp, 'm'); 16642 Set_Is_True_Constant (Entity (Domain), False); 16643 Set_Never_Set_In_Source (Entity (Domain), False); 16644 end if; 16645 end; 16646 end if; 16647 end if; 16648 end if; 16649 16650 Kill_Checks (Ent); 16651 16652 -- If we are sure this is a modification from source, and we know 16653 -- this modifies a constant, then give an appropriate warning. 16654 16655 if Sure 16656 and then Modification_Comes_From_Source 16657 and then Overlays_Constant (Ent) 16658 and then Address_Clause_Overlay_Warnings 16659 then 16660 declare 16661 Addr : constant Node_Id := Address_Clause (Ent); 16662 O_Ent : Entity_Id; 16663 Off : Boolean; 16664 16665 begin 16666 Find_Overlaid_Entity (Addr, O_Ent, Off); 16667 16668 Error_Msg_Sloc := Sloc (Addr); 16669 Error_Msg_NE 16670 ("??constant& may be modified via address clause#", 16671 N, O_Ent); 16672 end; 16673 end if; 16674 16675 return; 16676 end if; 16677 16678 <<Continue>> 16679 null; 16680 end loop; 16681 end Note_Possible_Modification; 16682 16683 ------------------------- 16684 -- Object_Access_Level -- 16685 ------------------------- 16686 16687 -- Returns the static accessibility level of the view denoted by Obj. Note 16688 -- that the value returned is the result of a call to Scope_Depth. Only 16689 -- scope depths associated with dynamic scopes can actually be returned. 16690 -- Since only relative levels matter for accessibility checking, the fact 16691 -- that the distance between successive levels of accessibility is not 16692 -- always one is immaterial (invariant: if level(E2) is deeper than 16693 -- level(E1), then Scope_Depth(E1) < Scope_Depth(E2)). 16694 16695 function Object_Access_Level (Obj : Node_Id) return Uint is 16696 function Is_Interface_Conversion (N : Node_Id) return Boolean; 16697 -- Determine whether N is a construct of the form 16698 -- Some_Type (Operand._tag'Address) 16699 -- This construct appears in the context of dispatching calls. 16700 16701 function Reference_To (Obj : Node_Id) return Node_Id; 16702 -- An explicit dereference is created when removing side-effects from 16703 -- expressions for constraint checking purposes. In this case a local 16704 -- access type is created for it. The correct access level is that of 16705 -- the original source node. We detect this case by noting that the 16706 -- prefix of the dereference is created by an object declaration whose 16707 -- initial expression is a reference. 16708 16709 ----------------------------- 16710 -- Is_Interface_Conversion -- 16711 ----------------------------- 16712 16713 function Is_Interface_Conversion (N : Node_Id) return Boolean is 16714 begin 16715 return Nkind (N) = N_Unchecked_Type_Conversion 16716 and then Nkind (Expression (N)) = N_Attribute_Reference 16717 and then Attribute_Name (Expression (N)) = Name_Address; 16718 end Is_Interface_Conversion; 16719 16720 ------------------ 16721 -- Reference_To -- 16722 ------------------ 16723 16724 function Reference_To (Obj : Node_Id) return Node_Id is 16725 Pref : constant Node_Id := Prefix (Obj); 16726 begin 16727 if Is_Entity_Name (Pref) 16728 and then Nkind (Parent (Entity (Pref))) = N_Object_Declaration 16729 and then Present (Expression (Parent (Entity (Pref)))) 16730 and then Nkind (Expression (Parent (Entity (Pref)))) = N_Reference 16731 then 16732 return (Prefix (Expression (Parent (Entity (Pref))))); 16733 else 16734 return Empty; 16735 end if; 16736 end Reference_To; 16737 16738 -- Local variables 16739 16740 E : Entity_Id; 16741 16742 -- Start of processing for Object_Access_Level 16743 16744 begin 16745 if Nkind (Obj) = N_Defining_Identifier 16746 or else Is_Entity_Name (Obj) 16747 then 16748 if Nkind (Obj) = N_Defining_Identifier then 16749 E := Obj; 16750 else 16751 E := Entity (Obj); 16752 end if; 16753 16754 if Is_Prival (E) then 16755 E := Prival_Link (E); 16756 end if; 16757 16758 -- If E is a type then it denotes a current instance. For this case 16759 -- we add one to the normal accessibility level of the type to ensure 16760 -- that current instances are treated as always being deeper than 16761 -- than the level of any visible named access type (see 3.10.2(21)). 16762 16763 if Is_Type (E) then 16764 return Type_Access_Level (E) + 1; 16765 16766 elsif Present (Renamed_Object (E)) then 16767 return Object_Access_Level (Renamed_Object (E)); 16768 16769 -- Similarly, if E is a component of the current instance of a 16770 -- protected type, any instance of it is assumed to be at a deeper 16771 -- level than the type. For a protected object (whose type is an 16772 -- anonymous protected type) its components are at the same level 16773 -- as the type itself. 16774 16775 elsif not Is_Overloadable (E) 16776 and then Ekind (Scope (E)) = E_Protected_Type 16777 and then Comes_From_Source (Scope (E)) 16778 then 16779 return Type_Access_Level (Scope (E)) + 1; 16780 16781 else 16782 -- Aliased formals of functions take their access level from the 16783 -- point of call, i.e. require a dynamic check. For static check 16784 -- purposes, this is smaller than the level of the subprogram 16785 -- itself. For procedures the aliased makes no difference. 16786 16787 if Is_Formal (E) 16788 and then Is_Aliased (E) 16789 and then Ekind (Scope (E)) = E_Function 16790 then 16791 return Type_Access_Level (Etype (E)); 16792 16793 else 16794 return Scope_Depth (Enclosing_Dynamic_Scope (E)); 16795 end if; 16796 end if; 16797 16798 elsif Nkind (Obj) = N_Selected_Component then 16799 if Is_Access_Type (Etype (Prefix (Obj))) then 16800 return Type_Access_Level (Etype (Prefix (Obj))); 16801 else 16802 return Object_Access_Level (Prefix (Obj)); 16803 end if; 16804 16805 elsif Nkind (Obj) = N_Indexed_Component then 16806 if Is_Access_Type (Etype (Prefix (Obj))) then 16807 return Type_Access_Level (Etype (Prefix (Obj))); 16808 else 16809 return Object_Access_Level (Prefix (Obj)); 16810 end if; 16811 16812 elsif Nkind (Obj) = N_Explicit_Dereference then 16813 16814 -- If the prefix is a selected access discriminant then we make a 16815 -- recursive call on the prefix, which will in turn check the level 16816 -- of the prefix object of the selected discriminant. 16817 16818 -- In Ada 2012, if the discriminant has implicit dereference and 16819 -- the context is a selected component, treat this as an object of 16820 -- unknown scope (see below). This is necessary in compile-only mode; 16821 -- otherwise expansion will already have transformed the prefix into 16822 -- a temporary. 16823 16824 if Nkind (Prefix (Obj)) = N_Selected_Component 16825 and then Ekind (Etype (Prefix (Obj))) = E_Anonymous_Access_Type 16826 and then 16827 Ekind (Entity (Selector_Name (Prefix (Obj)))) = E_Discriminant 16828 and then 16829 (not Has_Implicit_Dereference 16830 (Entity (Selector_Name (Prefix (Obj)))) 16831 or else Nkind (Parent (Obj)) /= N_Selected_Component) 16832 then 16833 return Object_Access_Level (Prefix (Obj)); 16834 16835 -- Detect an interface conversion in the context of a dispatching 16836 -- call. Use the original form of the conversion to find the access 16837 -- level of the operand. 16838 16839 elsif Is_Interface (Etype (Obj)) 16840 and then Is_Interface_Conversion (Prefix (Obj)) 16841 and then Nkind (Original_Node (Obj)) = N_Type_Conversion 16842 then 16843 return Object_Access_Level (Original_Node (Obj)); 16844 16845 elsif not Comes_From_Source (Obj) then 16846 declare 16847 Ref : constant Node_Id := Reference_To (Obj); 16848 begin 16849 if Present (Ref) then 16850 return Object_Access_Level (Ref); 16851 else 16852 return Type_Access_Level (Etype (Prefix (Obj))); 16853 end if; 16854 end; 16855 16856 else 16857 return Type_Access_Level (Etype (Prefix (Obj))); 16858 end if; 16859 16860 elsif Nkind_In (Obj, N_Type_Conversion, N_Unchecked_Type_Conversion) then 16861 return Object_Access_Level (Expression (Obj)); 16862 16863 elsif Nkind (Obj) = N_Function_Call then 16864 16865 -- Function results are objects, so we get either the access level of 16866 -- the function or, in the case of an indirect call, the level of the 16867 -- access-to-subprogram type. (This code is used for Ada 95, but it 16868 -- looks wrong, because it seems that we should be checking the level 16869 -- of the call itself, even for Ada 95. However, using the Ada 2005 16870 -- version of the code causes regressions in several tests that are 16871 -- compiled with -gnat95. ???) 16872 16873 if Ada_Version < Ada_2005 then 16874 if Is_Entity_Name (Name (Obj)) then 16875 return Subprogram_Access_Level (Entity (Name (Obj))); 16876 else 16877 return Type_Access_Level (Etype (Prefix (Name (Obj)))); 16878 end if; 16879 16880 -- For Ada 2005, the level of the result object of a function call is 16881 -- defined to be the level of the call's innermost enclosing master. 16882 -- We determine that by querying the depth of the innermost enclosing 16883 -- dynamic scope. 16884 16885 else 16886 Return_Master_Scope_Depth_Of_Call : declare 16887 16888 function Innermost_Master_Scope_Depth 16889 (N : Node_Id) return Uint; 16890 -- Returns the scope depth of the given node's innermost 16891 -- enclosing dynamic scope (effectively the accessibility 16892 -- level of the innermost enclosing master). 16893 16894 ---------------------------------- 16895 -- Innermost_Master_Scope_Depth -- 16896 ---------------------------------- 16897 16898 function Innermost_Master_Scope_Depth 16899 (N : Node_Id) return Uint 16900 is 16901 Node_Par : Node_Id := Parent (N); 16902 16903 begin 16904 -- Locate the nearest enclosing node (by traversing Parents) 16905 -- that Defining_Entity can be applied to, and return the 16906 -- depth of that entity's nearest enclosing dynamic scope. 16907 16908 while Present (Node_Par) loop 16909 case Nkind (Node_Par) is 16910 when N_Component_Declaration | 16911 N_Entry_Declaration | 16912 N_Formal_Object_Declaration | 16913 N_Formal_Type_Declaration | 16914 N_Full_Type_Declaration | 16915 N_Incomplete_Type_Declaration | 16916 N_Loop_Parameter_Specification | 16917 N_Object_Declaration | 16918 N_Protected_Type_Declaration | 16919 N_Private_Extension_Declaration | 16920 N_Private_Type_Declaration | 16921 N_Subtype_Declaration | 16922 N_Function_Specification | 16923 N_Procedure_Specification | 16924 N_Task_Type_Declaration | 16925 N_Body_Stub | 16926 N_Generic_Instantiation | 16927 N_Proper_Body | 16928 N_Implicit_Label_Declaration | 16929 N_Package_Declaration | 16930 N_Single_Task_Declaration | 16931 N_Subprogram_Declaration | 16932 N_Generic_Declaration | 16933 N_Renaming_Declaration | 16934 N_Block_Statement | 16935 N_Formal_Subprogram_Declaration | 16936 N_Abstract_Subprogram_Declaration | 16937 N_Entry_Body | 16938 N_Exception_Declaration | 16939 N_Formal_Package_Declaration | 16940 N_Number_Declaration | 16941 N_Package_Specification | 16942 N_Parameter_Specification | 16943 N_Single_Protected_Declaration | 16944 N_Subunit => 16945 16946 return Scope_Depth 16947 (Nearest_Dynamic_Scope 16948 (Defining_Entity (Node_Par))); 16949 16950 when others => 16951 null; 16952 end case; 16953 16954 Node_Par := Parent (Node_Par); 16955 end loop; 16956 16957 pragma Assert (False); 16958 16959 -- Should never reach the following return 16960 16961 return Scope_Depth (Current_Scope) + 1; 16962 end Innermost_Master_Scope_Depth; 16963 16964 -- Start of processing for Return_Master_Scope_Depth_Of_Call 16965 16966 begin 16967 return Innermost_Master_Scope_Depth (Obj); 16968 end Return_Master_Scope_Depth_Of_Call; 16969 end if; 16970 16971 -- For convenience we handle qualified expressions, even though they 16972 -- aren't technically object names. 16973 16974 elsif Nkind (Obj) = N_Qualified_Expression then 16975 return Object_Access_Level (Expression (Obj)); 16976 16977 -- Ditto for aggregates. They have the level of the temporary that 16978 -- will hold their value. 16979 16980 elsif Nkind (Obj) = N_Aggregate then 16981 return Object_Access_Level (Current_Scope); 16982 16983 -- Otherwise return the scope level of Standard. (If there are cases 16984 -- that fall through to this point they will be treated as having 16985 -- global accessibility for now. ???) 16986 16987 else 16988 return Scope_Depth (Standard_Standard); 16989 end if; 16990 end Object_Access_Level; 16991 16992 --------------------------------- 16993 -- Original_Aspect_Pragma_Name -- 16994 --------------------------------- 16995 16996 function Original_Aspect_Pragma_Name (N : Node_Id) return Name_Id is 16997 Item : Node_Id; 16998 Item_Nam : Name_Id; 16999 17000 begin 17001 pragma Assert (Nkind_In (N, N_Aspect_Specification, N_Pragma)); 17002 17003 Item := N; 17004 17005 -- The pragma was generated to emulate an aspect, use the original 17006 -- aspect specification. 17007 17008 if Nkind (Item) = N_Pragma and then From_Aspect_Specification (Item) then 17009 Item := Corresponding_Aspect (Item); 17010 end if; 17011 17012 -- Retrieve the name of the aspect/pragma. Note that Pre, Pre_Class, 17013 -- Post and Post_Class rewrite their pragma identifier to preserve the 17014 -- original name. 17015 -- ??? this is kludgey 17016 17017 if Nkind (Item) = N_Pragma then 17018 Item_Nam := Chars (Original_Node (Pragma_Identifier (Item))); 17019 17020 else 17021 pragma Assert (Nkind (Item) = N_Aspect_Specification); 17022 Item_Nam := Chars (Identifier (Item)); 17023 end if; 17024 17025 -- Deal with 'Class by converting the name to its _XXX form 17026 17027 if Class_Present (Item) then 17028 if Item_Nam = Name_Invariant then 17029 Item_Nam := Name_uInvariant; 17030 17031 elsif Item_Nam = Name_Post then 17032 Item_Nam := Name_uPost; 17033 17034 elsif Item_Nam = Name_Pre then 17035 Item_Nam := Name_uPre; 17036 17037 elsif Nam_In (Item_Nam, Name_Type_Invariant, 17038 Name_Type_Invariant_Class) 17039 then 17040 Item_Nam := Name_uType_Invariant; 17041 17042 -- Nothing to do for other cases (e.g. a Check that derived from 17043 -- Pre_Class and has the flag set). Also we do nothing if the name 17044 -- is already in special _xxx form. 17045 17046 end if; 17047 end if; 17048 17049 return Item_Nam; 17050 end Original_Aspect_Pragma_Name; 17051 17052 -------------------------------------- 17053 -- Original_Corresponding_Operation -- 17054 -------------------------------------- 17055 17056 function Original_Corresponding_Operation (S : Entity_Id) return Entity_Id 17057 is 17058 Typ : constant Entity_Id := Find_Dispatching_Type (S); 17059 17060 begin 17061 -- If S is an inherited primitive S2 the original corresponding 17062 -- operation of S is the original corresponding operation of S2 17063 17064 if Present (Alias (S)) 17065 and then Find_Dispatching_Type (Alias (S)) /= Typ 17066 then 17067 return Original_Corresponding_Operation (Alias (S)); 17068 17069 -- If S overrides an inherited subprogram S2 the original corresponding 17070 -- operation of S is the original corresponding operation of S2 17071 17072 elsif Present (Overridden_Operation (S)) then 17073 return Original_Corresponding_Operation (Overridden_Operation (S)); 17074 17075 -- otherwise it is S itself 17076 17077 else 17078 return S; 17079 end if; 17080 end Original_Corresponding_Operation; 17081 17082 ---------------------- 17083 -- Policy_In_Effect -- 17084 ---------------------- 17085 17086 function Policy_In_Effect (Policy : Name_Id) return Name_Id is 17087 function Policy_In_List (List : Node_Id) return Name_Id; 17088 -- Determine the mode of a policy in a N_Pragma list 17089 17090 -------------------- 17091 -- Policy_In_List -- 17092 -------------------- 17093 17094 function Policy_In_List (List : Node_Id) return Name_Id is 17095 Arg1 : Node_Id; 17096 Arg2 : Node_Id; 17097 Prag : Node_Id; 17098 17099 begin 17100 Prag := List; 17101 while Present (Prag) loop 17102 Arg1 := First (Pragma_Argument_Associations (Prag)); 17103 Arg2 := Next (Arg1); 17104 17105 Arg1 := Get_Pragma_Arg (Arg1); 17106 Arg2 := Get_Pragma_Arg (Arg2); 17107 17108 -- The current Check_Policy pragma matches the requested policy or 17109 -- appears in the single argument form (Assertion, policy_id). 17110 17111 if Nam_In (Chars (Arg1), Name_Assertion, Policy) then 17112 return Chars (Arg2); 17113 end if; 17114 17115 Prag := Next_Pragma (Prag); 17116 end loop; 17117 17118 return No_Name; 17119 end Policy_In_List; 17120 17121 -- Local variables 17122 17123 Kind : Name_Id; 17124 17125 -- Start of processing for Policy_In_Effect 17126 17127 begin 17128 if not Is_Valid_Assertion_Kind (Policy) then 17129 raise Program_Error; 17130 end if; 17131 17132 -- Inspect all policy pragmas that appear within scopes (if any) 17133 17134 Kind := Policy_In_List (Check_Policy_List); 17135 17136 -- Inspect all configuration policy pragmas (if any) 17137 17138 if Kind = No_Name then 17139 Kind := Policy_In_List (Check_Policy_List_Config); 17140 end if; 17141 17142 -- The context lacks policy pragmas, determine the mode based on whether 17143 -- assertions are enabled at the configuration level. This ensures that 17144 -- the policy is preserved when analyzing generics. 17145 17146 if Kind = No_Name then 17147 if Assertions_Enabled_Config then 17148 Kind := Name_Check; 17149 else 17150 Kind := Name_Ignore; 17151 end if; 17152 end if; 17153 17154 return Kind; 17155 end Policy_In_Effect; 17156 17157 ---------------------------------- 17158 -- Predicate_Tests_On_Arguments -- 17159 ---------------------------------- 17160 17161 function Predicate_Tests_On_Arguments (Subp : Entity_Id) return Boolean is 17162 begin 17163 -- Always test predicates on indirect call 17164 17165 if Ekind (Subp) = E_Subprogram_Type then 17166 return True; 17167 17168 -- Do not test predicates on call to generated default Finalize, since 17169 -- we are not interested in whether something we are finalizing (and 17170 -- typically destroying) satisfies its predicates. 17171 17172 elsif Chars (Subp) = Name_Finalize 17173 and then not Comes_From_Source (Subp) 17174 then 17175 return False; 17176 17177 -- Do not test predicates on any internally generated routines 17178 17179 elsif Is_Internal_Name (Chars (Subp)) then 17180 return False; 17181 17182 -- Do not test predicates on call to Init_Proc, since if needed the 17183 -- predicate test will occur at some other point. 17184 17185 elsif Is_Init_Proc (Subp) then 17186 return False; 17187 17188 -- Do not test predicates on call to predicate function, since this 17189 -- would cause infinite recursion. 17190 17191 elsif Ekind (Subp) = E_Function 17192 and then (Is_Predicate_Function (Subp) 17193 or else 17194 Is_Predicate_Function_M (Subp)) 17195 then 17196 return False; 17197 17198 -- For now, no other exceptions 17199 17200 else 17201 return True; 17202 end if; 17203 end Predicate_Tests_On_Arguments; 17204 17205 ----------------------- 17206 -- Private_Component -- 17207 ----------------------- 17208 17209 function Private_Component (Type_Id : Entity_Id) return Entity_Id is 17210 Ancestor : constant Entity_Id := Base_Type (Type_Id); 17211 17212 function Trace_Components 17213 (T : Entity_Id; 17214 Check : Boolean) return Entity_Id; 17215 -- Recursive function that does the work, and checks against circular 17216 -- definition for each subcomponent type. 17217 17218 ---------------------- 17219 -- Trace_Components -- 17220 ---------------------- 17221 17222 function Trace_Components 17223 (T : Entity_Id; 17224 Check : Boolean) return Entity_Id 17225 is 17226 Btype : constant Entity_Id := Base_Type (T); 17227 Component : Entity_Id; 17228 P : Entity_Id; 17229 Candidate : Entity_Id := Empty; 17230 17231 begin 17232 if Check and then Btype = Ancestor then 17233 Error_Msg_N ("circular type definition", Type_Id); 17234 return Any_Type; 17235 end if; 17236 17237 if Is_Private_Type (Btype) and then not Is_Generic_Type (Btype) then 17238 if Present (Full_View (Btype)) 17239 and then Is_Record_Type (Full_View (Btype)) 17240 and then not Is_Frozen (Btype) 17241 then 17242 -- To indicate that the ancestor depends on a private type, the 17243 -- current Btype is sufficient. However, to check for circular 17244 -- definition we must recurse on the full view. 17245 17246 Candidate := Trace_Components (Full_View (Btype), True); 17247 17248 if Candidate = Any_Type then 17249 return Any_Type; 17250 else 17251 return Btype; 17252 end if; 17253 17254 else 17255 return Btype; 17256 end if; 17257 17258 elsif Is_Array_Type (Btype) then 17259 return Trace_Components (Component_Type (Btype), True); 17260 17261 elsif Is_Record_Type (Btype) then 17262 Component := First_Entity (Btype); 17263 while Present (Component) 17264 and then Comes_From_Source (Component) 17265 loop 17266 -- Skip anonymous types generated by constrained components 17267 17268 if not Is_Type (Component) then 17269 P := Trace_Components (Etype (Component), True); 17270 17271 if Present (P) then 17272 if P = Any_Type then 17273 return P; 17274 else 17275 Candidate := P; 17276 end if; 17277 end if; 17278 end if; 17279 17280 Next_Entity (Component); 17281 end loop; 17282 17283 return Candidate; 17284 17285 else 17286 return Empty; 17287 end if; 17288 end Trace_Components; 17289 17290 -- Start of processing for Private_Component 17291 17292 begin 17293 return Trace_Components (Type_Id, False); 17294 end Private_Component; 17295 17296 --------------------------- 17297 -- Primitive_Names_Match -- 17298 --------------------------- 17299 17300 function Primitive_Names_Match (E1, E2 : Entity_Id) return Boolean is 17301 17302 function Non_Internal_Name (E : Entity_Id) return Name_Id; 17303 -- Given an internal name, returns the corresponding non-internal name 17304 17305 ------------------------ 17306 -- Non_Internal_Name -- 17307 ------------------------ 17308 17309 function Non_Internal_Name (E : Entity_Id) return Name_Id is 17310 begin 17311 Get_Name_String (Chars (E)); 17312 Name_Len := Name_Len - 1; 17313 return Name_Find; 17314 end Non_Internal_Name; 17315 17316 -- Start of processing for Primitive_Names_Match 17317 17318 begin 17319 pragma Assert (Present (E1) and then Present (E2)); 17320 17321 return Chars (E1) = Chars (E2) 17322 or else 17323 (not Is_Internal_Name (Chars (E1)) 17324 and then Is_Internal_Name (Chars (E2)) 17325 and then Non_Internal_Name (E2) = Chars (E1)) 17326 or else 17327 (not Is_Internal_Name (Chars (E2)) 17328 and then Is_Internal_Name (Chars (E1)) 17329 and then Non_Internal_Name (E1) = Chars (E2)) 17330 or else 17331 (Is_Predefined_Dispatching_Operation (E1) 17332 and then Is_Predefined_Dispatching_Operation (E2) 17333 and then Same_TSS (E1, E2)) 17334 or else 17335 (Is_Init_Proc (E1) and then Is_Init_Proc (E2)); 17336 end Primitive_Names_Match; 17337 17338 ----------------------- 17339 -- Process_End_Label -- 17340 ----------------------- 17341 17342 procedure Process_End_Label 17343 (N : Node_Id; 17344 Typ : Character; 17345 Ent : Entity_Id) 17346 is 17347 Loc : Source_Ptr; 17348 Nam : Node_Id; 17349 Scop : Entity_Id; 17350 17351 Label_Ref : Boolean; 17352 -- Set True if reference to end label itself is required 17353 17354 Endl : Node_Id; 17355 -- Gets set to the operator symbol or identifier that references the 17356 -- entity Ent. For the child unit case, this is the identifier from the 17357 -- designator. For other cases, this is simply Endl. 17358 17359 procedure Generate_Parent_Ref (N : Node_Id; E : Entity_Id); 17360 -- N is an identifier node that appears as a parent unit reference in 17361 -- the case where Ent is a child unit. This procedure generates an 17362 -- appropriate cross-reference entry. E is the corresponding entity. 17363 17364 ------------------------- 17365 -- Generate_Parent_Ref -- 17366 ------------------------- 17367 17368 procedure Generate_Parent_Ref (N : Node_Id; E : Entity_Id) is 17369 begin 17370 -- If names do not match, something weird, skip reference 17371 17372 if Chars (E) = Chars (N) then 17373 17374 -- Generate the reference. We do NOT consider this as a reference 17375 -- for unreferenced symbol purposes. 17376 17377 Generate_Reference (E, N, 'r', Set_Ref => False, Force => True); 17378 17379 if Style_Check then 17380 Style.Check_Identifier (N, E); 17381 end if; 17382 end if; 17383 end Generate_Parent_Ref; 17384 17385 -- Start of processing for Process_End_Label 17386 17387 begin 17388 -- If no node, ignore. This happens in some error situations, and 17389 -- also for some internally generated structures where no end label 17390 -- references are required in any case. 17391 17392 if No (N) then 17393 return; 17394 end if; 17395 17396 -- Nothing to do if no End_Label, happens for internally generated 17397 -- constructs where we don't want an end label reference anyway. Also 17398 -- nothing to do if Endl is a string literal, which means there was 17399 -- some prior error (bad operator symbol) 17400 17401 Endl := End_Label (N); 17402 17403 if No (Endl) or else Nkind (Endl) = N_String_Literal then 17404 return; 17405 end if; 17406 17407 -- Reference node is not in extended main source unit 17408 17409 if not In_Extended_Main_Source_Unit (N) then 17410 17411 -- Generally we do not collect references except for the extended 17412 -- main source unit. The one exception is the 'e' entry for a 17413 -- package spec, where it is useful for a client to have the 17414 -- ending information to define scopes. 17415 17416 if Typ /= 'e' then 17417 return; 17418 17419 else 17420 Label_Ref := False; 17421 17422 -- For this case, we can ignore any parent references, but we 17423 -- need the package name itself for the 'e' entry. 17424 17425 if Nkind (Endl) = N_Designator then 17426 Endl := Identifier (Endl); 17427 end if; 17428 end if; 17429 17430 -- Reference is in extended main source unit 17431 17432 else 17433 Label_Ref := True; 17434 17435 -- For designator, generate references for the parent entries 17436 17437 if Nkind (Endl) = N_Designator then 17438 17439 -- Generate references for the prefix if the END line comes from 17440 -- source (otherwise we do not need these references) We climb the 17441 -- scope stack to find the expected entities. 17442 17443 if Comes_From_Source (Endl) then 17444 Nam := Name (Endl); 17445 Scop := Current_Scope; 17446 while Nkind (Nam) = N_Selected_Component loop 17447 Scop := Scope (Scop); 17448 exit when No (Scop); 17449 Generate_Parent_Ref (Selector_Name (Nam), Scop); 17450 Nam := Prefix (Nam); 17451 end loop; 17452 17453 if Present (Scop) then 17454 Generate_Parent_Ref (Nam, Scope (Scop)); 17455 end if; 17456 end if; 17457 17458 Endl := Identifier (Endl); 17459 end if; 17460 end if; 17461 17462 -- If the end label is not for the given entity, then either we have 17463 -- some previous error, or this is a generic instantiation for which 17464 -- we do not need to make a cross-reference in this case anyway. In 17465 -- either case we simply ignore the call. 17466 17467 if Chars (Ent) /= Chars (Endl) then 17468 return; 17469 end if; 17470 17471 -- If label was really there, then generate a normal reference and then 17472 -- adjust the location in the end label to point past the name (which 17473 -- should almost always be the semicolon). 17474 17475 Loc := Sloc (Endl); 17476 17477 if Comes_From_Source (Endl) then 17478 17479 -- If a label reference is required, then do the style check and 17480 -- generate an l-type cross-reference entry for the label 17481 17482 if Label_Ref then 17483 if Style_Check then 17484 Style.Check_Identifier (Endl, Ent); 17485 end if; 17486 17487 Generate_Reference (Ent, Endl, 'l', Set_Ref => False); 17488 end if; 17489 17490 -- Set the location to point past the label (normally this will 17491 -- mean the semicolon immediately following the label). This is 17492 -- done for the sake of the 'e' or 't' entry generated below. 17493 17494 Get_Decoded_Name_String (Chars (Endl)); 17495 Set_Sloc (Endl, Sloc (Endl) + Source_Ptr (Name_Len)); 17496 17497 else 17498 -- In SPARK mode, no missing label is allowed for packages and 17499 -- subprogram bodies. Detect those cases by testing whether 17500 -- Process_End_Label was called for a body (Typ = 't') or a package. 17501 17502 if Restriction_Check_Required (SPARK_05) 17503 and then (Typ = 't' or else Ekind (Ent) = E_Package) 17504 then 17505 Error_Msg_Node_1 := Endl; 17506 Check_SPARK_05_Restriction 17507 ("`END &` required", Endl, Force => True); 17508 end if; 17509 end if; 17510 17511 -- Now generate the e/t reference 17512 17513 Generate_Reference (Ent, Endl, Typ, Set_Ref => False, Force => True); 17514 17515 -- Restore Sloc, in case modified above, since we have an identifier 17516 -- and the normal Sloc should be left set in the tree. 17517 17518 Set_Sloc (Endl, Loc); 17519 end Process_End_Label; 17520 17521 --------------------------------------- 17522 -- Record_Possible_Part_Of_Reference -- 17523 --------------------------------------- 17524 17525 procedure Record_Possible_Part_Of_Reference 17526 (Var_Id : Entity_Id; 17527 Ref : Node_Id) 17528 is 17529 Encap : constant Entity_Id := Encapsulating_State (Var_Id); 17530 Refs : Elist_Id; 17531 17532 begin 17533 -- The variable is a constituent of a single protected/task type. Such 17534 -- a variable acts as a component of the type and must appear within a 17535 -- specific region (SPARK RM 9.3). Instead of recording the reference, 17536 -- verify its legality now. 17537 17538 if Present (Encap) and then Is_Single_Concurrent_Object (Encap) then 17539 Check_Part_Of_Reference (Var_Id, Ref); 17540 17541 -- The variable is subject to pragma Part_Of and may eventually become a 17542 -- constituent of a single protected/task type. Record the reference to 17543 -- verify its placement when the contract of the variable is analyzed. 17544 17545 elsif Present (Get_Pragma (Var_Id, Pragma_Part_Of)) then 17546 Refs := Part_Of_References (Var_Id); 17547 17548 if No (Refs) then 17549 Refs := New_Elmt_List; 17550 Set_Part_Of_References (Var_Id, Refs); 17551 end if; 17552 17553 Append_Elmt (Ref, Refs); 17554 end if; 17555 end Record_Possible_Part_Of_Reference; 17556 17557 ---------------- 17558 -- Referenced -- 17559 ---------------- 17560 17561 function Referenced (Id : Entity_Id; Expr : Node_Id) return Boolean is 17562 Seen : Boolean := False; 17563 17564 function Is_Reference (N : Node_Id) return Traverse_Result; 17565 -- Determine whether node N denotes a reference to Id. If this is the 17566 -- case, set global flag Seen to True and stop the traversal. 17567 17568 ------------------ 17569 -- Is_Reference -- 17570 ------------------ 17571 17572 function Is_Reference (N : Node_Id) return Traverse_Result is 17573 begin 17574 if Is_Entity_Name (N) 17575 and then Present (Entity (N)) 17576 and then Entity (N) = Id 17577 then 17578 Seen := True; 17579 return Abandon; 17580 else 17581 return OK; 17582 end if; 17583 end Is_Reference; 17584 17585 procedure Inspect_Expression is new Traverse_Proc (Is_Reference); 17586 17587 -- Start of processing for Referenced 17588 17589 begin 17590 Inspect_Expression (Expr); 17591 return Seen; 17592 end Referenced; 17593 17594 ------------------------------------ 17595 -- References_Generic_Formal_Type -- 17596 ------------------------------------ 17597 17598 function References_Generic_Formal_Type (N : Node_Id) return Boolean is 17599 17600 function Process (N : Node_Id) return Traverse_Result; 17601 -- Process one node in search for generic formal type 17602 17603 ------------- 17604 -- Process -- 17605 ------------- 17606 17607 function Process (N : Node_Id) return Traverse_Result is 17608 begin 17609 if Nkind (N) in N_Has_Entity then 17610 declare 17611 E : constant Entity_Id := Entity (N); 17612 begin 17613 if Present (E) then 17614 if Is_Generic_Type (E) then 17615 return Abandon; 17616 elsif Present (Etype (E)) 17617 and then Is_Generic_Type (Etype (E)) 17618 then 17619 return Abandon; 17620 end if; 17621 end if; 17622 end; 17623 end if; 17624 17625 return Atree.OK; 17626 end Process; 17627 17628 function Traverse is new Traverse_Func (Process); 17629 -- Traverse tree to look for generic type 17630 17631 begin 17632 if Inside_A_Generic then 17633 return Traverse (N) = Abandon; 17634 else 17635 return False; 17636 end if; 17637 end References_Generic_Formal_Type; 17638 17639 -------------------- 17640 -- Remove_Homonym -- 17641 -------------------- 17642 17643 procedure Remove_Homonym (E : Entity_Id) is 17644 Prev : Entity_Id := Empty; 17645 H : Entity_Id; 17646 17647 begin 17648 if E = Current_Entity (E) then 17649 if Present (Homonym (E)) then 17650 Set_Current_Entity (Homonym (E)); 17651 else 17652 Set_Name_Entity_Id (Chars (E), Empty); 17653 end if; 17654 17655 else 17656 H := Current_Entity (E); 17657 while Present (H) and then H /= E loop 17658 Prev := H; 17659 H := Homonym (H); 17660 end loop; 17661 17662 -- If E is not on the homonym chain, nothing to do 17663 17664 if Present (H) then 17665 Set_Homonym (Prev, Homonym (E)); 17666 end if; 17667 end if; 17668 end Remove_Homonym; 17669 17670 ------------------------------ 17671 -- Remove_Overloaded_Entity -- 17672 ------------------------------ 17673 17674 procedure Remove_Overloaded_Entity (Id : Entity_Id) is 17675 procedure Remove_Primitive_Of (Typ : Entity_Id); 17676 -- Remove primitive subprogram Id from the list of primitives that 17677 -- belong to type Typ. 17678 17679 ------------------------- 17680 -- Remove_Primitive_Of -- 17681 ------------------------- 17682 17683 procedure Remove_Primitive_Of (Typ : Entity_Id) is 17684 Prims : Elist_Id; 17685 17686 begin 17687 if Is_Tagged_Type (Typ) then 17688 Prims := Direct_Primitive_Operations (Typ); 17689 17690 if Present (Prims) then 17691 Remove (Prims, Id); 17692 end if; 17693 end if; 17694 end Remove_Primitive_Of; 17695 17696 -- Local variables 17697 17698 Scop : constant Entity_Id := Scope (Id); 17699 Formal : Entity_Id; 17700 Prev_Id : Entity_Id; 17701 17702 -- Start of processing for Remove_Overloaded_Entity 17703 17704 begin 17705 -- Remove the entity from the homonym chain. When the entity is the 17706 -- head of the chain, associate the entry in the name table with its 17707 -- homonym effectively making it the new head of the chain. 17708 17709 if Current_Entity (Id) = Id then 17710 Set_Name_Entity_Id (Chars (Id), Homonym (Id)); 17711 17712 -- Otherwise link the previous and next homonyms 17713 17714 else 17715 Prev_Id := Current_Entity (Id); 17716 while Present (Prev_Id) and then Homonym (Prev_Id) /= Id loop 17717 Prev_Id := Homonym (Prev_Id); 17718 end loop; 17719 17720 Set_Homonym (Prev_Id, Homonym (Id)); 17721 end if; 17722 17723 -- Remove the entity from the scope entity chain. When the entity is 17724 -- the head of the chain, set the next entity as the new head of the 17725 -- chain. 17726 17727 if First_Entity (Scop) = Id then 17728 Prev_Id := Empty; 17729 Set_First_Entity (Scop, Next_Entity (Id)); 17730 17731 -- Otherwise the entity is either in the middle of the chain or it acts 17732 -- as its tail. Traverse and link the previous and next entities. 17733 17734 else 17735 Prev_Id := First_Entity (Scop); 17736 while Present (Prev_Id) and then Next_Entity (Prev_Id) /= Id loop 17737 Next_Entity (Prev_Id); 17738 end loop; 17739 17740 Set_Next_Entity (Prev_Id, Next_Entity (Id)); 17741 end if; 17742 17743 -- Handle the case where the entity acts as the tail of the scope entity 17744 -- chain. 17745 17746 if Last_Entity (Scop) = Id then 17747 Set_Last_Entity (Scop, Prev_Id); 17748 end if; 17749 17750 -- The entity denotes a primitive subprogram. Remove it from the list of 17751 -- primitives of the associated controlling type. 17752 17753 if Ekind_In (Id, E_Function, E_Procedure) and then Is_Primitive (Id) then 17754 Formal := First_Formal (Id); 17755 while Present (Formal) loop 17756 if Is_Controlling_Formal (Formal) then 17757 Remove_Primitive_Of (Etype (Formal)); 17758 exit; 17759 end if; 17760 17761 Next_Formal (Formal); 17762 end loop; 17763 17764 if Ekind (Id) = E_Function and then Has_Controlling_Result (Id) then 17765 Remove_Primitive_Of (Etype (Id)); 17766 end if; 17767 end if; 17768 end Remove_Overloaded_Entity; 17769 17770 --------------------- 17771 -- Rep_To_Pos_Flag -- 17772 --------------------- 17773 17774 function Rep_To_Pos_Flag (E : Entity_Id; Loc : Source_Ptr) return Node_Id is 17775 begin 17776 return New_Occurrence_Of 17777 (Boolean_Literals (not Range_Checks_Suppressed (E)), Loc); 17778 end Rep_To_Pos_Flag; 17779 17780 -------------------- 17781 -- Require_Entity -- 17782 -------------------- 17783 17784 procedure Require_Entity (N : Node_Id) is 17785 begin 17786 if Is_Entity_Name (N) and then No (Entity (N)) then 17787 if Total_Errors_Detected /= 0 then 17788 Set_Entity (N, Any_Id); 17789 else 17790 raise Program_Error; 17791 end if; 17792 end if; 17793 end Require_Entity; 17794 17795 ------------------------------- 17796 -- Requires_State_Refinement -- 17797 ------------------------------- 17798 17799 function Requires_State_Refinement 17800 (Spec_Id : Entity_Id; 17801 Body_Id : Entity_Id) return Boolean 17802 is 17803 function Mode_Is_Off (Prag : Node_Id) return Boolean; 17804 -- Given pragma SPARK_Mode, determine whether the mode is Off 17805 17806 ----------------- 17807 -- Mode_Is_Off -- 17808 ----------------- 17809 17810 function Mode_Is_Off (Prag : Node_Id) return Boolean is 17811 Mode : Node_Id; 17812 17813 begin 17814 -- The default SPARK mode is On 17815 17816 if No (Prag) then 17817 return False; 17818 end if; 17819 17820 Mode := Get_Pragma_Arg (First (Pragma_Argument_Associations (Prag))); 17821 17822 -- Then the pragma lacks an argument, the default mode is On 17823 17824 if No (Mode) then 17825 return False; 17826 else 17827 return Chars (Mode) = Name_Off; 17828 end if; 17829 end Mode_Is_Off; 17830 17831 -- Start of processing for Requires_State_Refinement 17832 17833 begin 17834 -- A package that does not define at least one abstract state cannot 17835 -- possibly require refinement. 17836 17837 if No (Abstract_States (Spec_Id)) then 17838 return False; 17839 17840 -- The package instroduces a single null state which does not merit 17841 -- refinement. 17842 17843 elsif Has_Null_Abstract_State (Spec_Id) then 17844 return False; 17845 17846 -- Check whether the package body is subject to pragma SPARK_Mode. If 17847 -- it is and the mode is Off, the package body is considered to be in 17848 -- regular Ada and does not require refinement. 17849 17850 elsif Mode_Is_Off (SPARK_Pragma (Body_Id)) then 17851 return False; 17852 17853 -- The body's SPARK_Mode may be inherited from a similar pragma that 17854 -- appears in the private declarations of the spec. The pragma we are 17855 -- interested appears as the second entry in SPARK_Pragma. 17856 17857 elsif Present (SPARK_Pragma (Spec_Id)) 17858 and then Mode_Is_Off (Next_Pragma (SPARK_Pragma (Spec_Id))) 17859 then 17860 return False; 17861 17862 -- The spec defines at least one abstract state and the body has no way 17863 -- of circumventing the refinement. 17864 17865 else 17866 return True; 17867 end if; 17868 end Requires_State_Refinement; 17869 17870 ------------------------------ 17871 -- Requires_Transient_Scope -- 17872 ------------------------------ 17873 17874 -- A transient scope is required when variable-sized temporaries are 17875 -- allocated on the secondary stack, or when finalization actions must be 17876 -- generated before the next instruction. 17877 17878 function Old_Requires_Transient_Scope (Id : Entity_Id) return Boolean; 17879 function New_Requires_Transient_Scope (Id : Entity_Id) return Boolean; 17880 -- ???We retain the old and new algorithms for Requires_Transient_Scope for 17881 -- the time being. New_Requires_Transient_Scope is used by default; the 17882 -- debug switch -gnatdQ can be used to do Old_Requires_Transient_Scope 17883 -- instead. The intent is to use this temporarily to measure before/after 17884 -- efficiency. Note: when this temporary code is removed, the documentation 17885 -- of dQ in debug.adb should be removed. 17886 17887 procedure Results_Differ (Id : Entity_Id); 17888 -- ???Debugging code. Called when the Old_ and New_ results differ. Will be 17889 -- removed when New_Requires_Transient_Scope becomes 17890 -- Requires_Transient_Scope and Old_Requires_Transient_Scope is eliminated. 17891 17892 procedure Results_Differ (Id : Entity_Id) is 17893 begin 17894 if False then -- False to disable; True for debugging 17895 Treepr.Print_Tree_Node (Id); 17896 17897 if Old_Requires_Transient_Scope (Id) = 17898 New_Requires_Transient_Scope (Id) 17899 then 17900 raise Program_Error; 17901 end if; 17902 end if; 17903 end Results_Differ; 17904 17905 function Requires_Transient_Scope (Id : Entity_Id) return Boolean is 17906 Old_Result : constant Boolean := Old_Requires_Transient_Scope (Id); 17907 17908 begin 17909 if Debug_Flag_QQ then 17910 return Old_Result; 17911 end if; 17912 17913 declare 17914 New_Result : constant Boolean := New_Requires_Transient_Scope (Id); 17915 17916 begin 17917 -- Assert that we're not putting things on the secondary stack if we 17918 -- didn't before; we are trying to AVOID secondary stack when 17919 -- possible. 17920 17921 if not Old_Result then 17922 pragma Assert (not New_Result); 17923 null; 17924 end if; 17925 17926 if New_Result /= Old_Result then 17927 Results_Differ (Id); 17928 end if; 17929 17930 return New_Result; 17931 end; 17932 end Requires_Transient_Scope; 17933 17934 ---------------------------------- 17935 -- Old_Requires_Transient_Scope -- 17936 ---------------------------------- 17937 17938 function Old_Requires_Transient_Scope (Id : Entity_Id) return Boolean is 17939 Typ : constant Entity_Id := Underlying_Type (Id); 17940 17941 begin 17942 -- This is a private type which is not completed yet. This can only 17943 -- happen in a default expression (of a formal parameter or of a 17944 -- record component). Do not expand transient scope in this case. 17945 17946 if No (Typ) then 17947 return False; 17948 17949 -- Do not expand transient scope for non-existent procedure return 17950 17951 elsif Typ = Standard_Void_Type then 17952 return False; 17953 17954 -- Elementary types do not require a transient scope 17955 17956 elsif Is_Elementary_Type (Typ) then 17957 return False; 17958 17959 -- Generally, indefinite subtypes require a transient scope, since the 17960 -- back end cannot generate temporaries, since this is not a valid type 17961 -- for declaring an object. It might be possible to relax this in the 17962 -- future, e.g. by declaring the maximum possible space for the type. 17963 17964 elsif not Is_Definite_Subtype (Typ) then 17965 return True; 17966 17967 -- Functions returning tagged types may dispatch on result so their 17968 -- returned value is allocated on the secondary stack. Controlled 17969 -- type temporaries need finalization. 17970 17971 elsif Is_Tagged_Type (Typ) or else Has_Controlled_Component (Typ) then 17972 return True; 17973 17974 -- Record type 17975 17976 elsif Is_Record_Type (Typ) then 17977 declare 17978 Comp : Entity_Id; 17979 17980 begin 17981 Comp := First_Entity (Typ); 17982 while Present (Comp) loop 17983 if Ekind (Comp) = E_Component then 17984 17985 -- ???It's not clear we need a full recursive call to 17986 -- Old_Requires_Transient_Scope here. Note that the 17987 -- following can't happen. 17988 17989 pragma Assert (Is_Definite_Subtype (Etype (Comp))); 17990 pragma Assert (not Has_Controlled_Component (Etype (Comp))); 17991 17992 if Old_Requires_Transient_Scope (Etype (Comp)) then 17993 return True; 17994 end if; 17995 end if; 17996 17997 Next_Entity (Comp); 17998 end loop; 17999 end; 18000 18001 return False; 18002 18003 -- String literal types never require transient scope 18004 18005 elsif Ekind (Typ) = E_String_Literal_Subtype then 18006 return False; 18007 18008 -- Array type. Note that we already know that this is a constrained 18009 -- array, since unconstrained arrays will fail the indefinite test. 18010 18011 elsif Is_Array_Type (Typ) then 18012 18013 -- If component type requires a transient scope, the array does too 18014 18015 if Old_Requires_Transient_Scope (Component_Type (Typ)) then 18016 return True; 18017 18018 -- Otherwise, we only need a transient scope if the size depends on 18019 -- the value of one or more discriminants. 18020 18021 else 18022 return Size_Depends_On_Discriminant (Typ); 18023 end if; 18024 18025 -- All other cases do not require a transient scope 18026 18027 else 18028 pragma Assert (Is_Protected_Type (Typ) or else Is_Task_Type (Typ)); 18029 return False; 18030 end if; 18031 end Old_Requires_Transient_Scope; 18032 18033 ---------------------------------- 18034 -- New_Requires_Transient_Scope -- 18035 ---------------------------------- 18036 18037 function New_Requires_Transient_Scope (Id : Entity_Id) return Boolean is 18038 18039 function Caller_Known_Size_Record (Typ : Entity_Id) return Boolean; 18040 -- This is called for untagged records and protected types, with 18041 -- nondefaulted discriminants. Returns True if the size of function 18042 -- results is known at the call site, False otherwise. Returns False 18043 -- if there is a variant part that depends on the discriminants of 18044 -- this type, or if there is an array constrained by the discriminants 18045 -- of this type. ???Currently, this is overly conservative (the array 18046 -- could be nested inside some other record that is constrained by 18047 -- nondiscriminants). That is, the recursive calls are too conservative. 18048 18049 function Large_Max_Size_Mutable (Typ : Entity_Id) return Boolean; 18050 -- Returns True if Typ is a nonlimited record with defaulted 18051 -- discriminants whose max size makes it unsuitable for allocating on 18052 -- the primary stack. 18053 18054 ------------------------------ 18055 -- Caller_Known_Size_Record -- 18056 ------------------------------ 18057 18058 function Caller_Known_Size_Record (Typ : Entity_Id) return Boolean is 18059 pragma Assert (Typ = Underlying_Type (Typ)); 18060 18061 begin 18062 if Has_Variant_Part (Typ) and then not Is_Definite_Subtype (Typ) then 18063 return False; 18064 end if; 18065 18066 declare 18067 Comp : Entity_Id; 18068 18069 begin 18070 Comp := First_Entity (Typ); 18071 while Present (Comp) loop 18072 18073 -- Only look at E_Component entities. No need to look at 18074 -- E_Discriminant entities, and we must ignore internal 18075 -- subtypes generated for constrained components. 18076 18077 if Ekind (Comp) = E_Component then 18078 declare 18079 Comp_Type : constant Entity_Id := 18080 Underlying_Type (Etype (Comp)); 18081 18082 begin 18083 if Is_Record_Type (Comp_Type) 18084 or else 18085 Is_Protected_Type (Comp_Type) 18086 then 18087 if not Caller_Known_Size_Record (Comp_Type) then 18088 return False; 18089 end if; 18090 18091 elsif Is_Array_Type (Comp_Type) then 18092 if Size_Depends_On_Discriminant (Comp_Type) then 18093 return False; 18094 end if; 18095 end if; 18096 end; 18097 end if; 18098 18099 Next_Entity (Comp); 18100 end loop; 18101 end; 18102 18103 return True; 18104 end Caller_Known_Size_Record; 18105 18106 ------------------------------ 18107 -- Large_Max_Size_Mutable -- 18108 ------------------------------ 18109 18110 function Large_Max_Size_Mutable (Typ : Entity_Id) return Boolean is 18111 pragma Assert (Typ = Underlying_Type (Typ)); 18112 18113 function Is_Large_Discrete_Type (T : Entity_Id) return Boolean; 18114 -- Returns true if the discrete type T has a large range 18115 18116 ---------------------------- 18117 -- Is_Large_Discrete_Type -- 18118 ---------------------------- 18119 18120 function Is_Large_Discrete_Type (T : Entity_Id) return Boolean is 18121 Threshold : constant Int := 16; 18122 -- Arbitrary threshold above which we consider it "large". We want 18123 -- a fairly large threshold, because these large types really 18124 -- shouldn't have default discriminants in the first place, in 18125 -- most cases. 18126 18127 begin 18128 return UI_To_Int (RM_Size (T)) > Threshold; 18129 end Is_Large_Discrete_Type; 18130 18131 begin 18132 if Is_Record_Type (Typ) 18133 and then not Is_Limited_View (Typ) 18134 and then Has_Defaulted_Discriminants (Typ) 18135 then 18136 -- Loop through the components, looking for an array whose upper 18137 -- bound(s) depends on discriminants, where both the subtype of 18138 -- the discriminant and the index subtype are too large. 18139 18140 declare 18141 Comp : Entity_Id; 18142 18143 begin 18144 Comp := First_Entity (Typ); 18145 while Present (Comp) loop 18146 if Ekind (Comp) = E_Component then 18147 declare 18148 Comp_Type : constant Entity_Id := 18149 Underlying_Type (Etype (Comp)); 18150 Indx : Node_Id; 18151 Ityp : Entity_Id; 18152 Hi : Node_Id; 18153 18154 begin 18155 if Is_Array_Type (Comp_Type) then 18156 Indx := First_Index (Comp_Type); 18157 18158 while Present (Indx) loop 18159 Ityp := Etype (Indx); 18160 Hi := Type_High_Bound (Ityp); 18161 18162 if Nkind (Hi) = N_Identifier 18163 and then Ekind (Entity (Hi)) = E_Discriminant 18164 and then Is_Large_Discrete_Type (Ityp) 18165 and then Is_Large_Discrete_Type 18166 (Etype (Entity (Hi))) 18167 then 18168 return True; 18169 end if; 18170 18171 Next_Index (Indx); 18172 end loop; 18173 end if; 18174 end; 18175 end if; 18176 18177 Next_Entity (Comp); 18178 end loop; 18179 end; 18180 end if; 18181 18182 return False; 18183 end Large_Max_Size_Mutable; 18184 18185 -- Local declarations 18186 18187 Typ : constant Entity_Id := Underlying_Type (Id); 18188 18189 -- Start of processing for New_Requires_Transient_Scope 18190 18191 begin 18192 -- This is a private type which is not completed yet. This can only 18193 -- happen in a default expression (of a formal parameter or of a 18194 -- record component). Do not expand transient scope in this case. 18195 18196 if No (Typ) then 18197 return False; 18198 18199 -- Do not expand transient scope for non-existent procedure return or 18200 -- string literal types. 18201 18202 elsif Typ = Standard_Void_Type 18203 or else Ekind (Typ) = E_String_Literal_Subtype 18204 then 18205 return False; 18206 18207 -- If Typ is a generic formal incomplete type, then we want to look at 18208 -- the actual type. 18209 18210 elsif Ekind (Typ) = E_Record_Subtype 18211 and then Present (Cloned_Subtype (Typ)) 18212 then 18213 return New_Requires_Transient_Scope (Cloned_Subtype (Typ)); 18214 18215 -- Functions returning specific tagged types may dispatch on result, so 18216 -- their returned value is allocated on the secondary stack, even in the 18217 -- definite case. We must treat nondispatching functions the same way, 18218 -- because access-to-function types can point at both, so the calling 18219 -- conventions must be compatible. Is_Tagged_Type includes controlled 18220 -- types and class-wide types. Controlled type temporaries need 18221 -- finalization. 18222 18223 -- ???It's not clear why we need to return noncontrolled types with 18224 -- controlled components on the secondary stack. 18225 18226 elsif Is_Tagged_Type (Typ) or else Has_Controlled_Component (Typ) then 18227 return True; 18228 18229 -- Untagged definite subtypes are known size. This includes all 18230 -- elementary [sub]types. Tasks are known size even if they have 18231 -- discriminants. So we return False here, with one exception: 18232 -- For a type like: 18233 -- type T (Last : Natural := 0) is 18234 -- X : String (1 .. Last); 18235 -- end record; 18236 -- we return True. That's because for "P(F(...));", where F returns T, 18237 -- we don't know the size of the result at the call site, so if we 18238 -- allocated it on the primary stack, we would have to allocate the 18239 -- maximum size, which is way too big. 18240 18241 elsif Is_Definite_Subtype (Typ) or else Is_Task_Type (Typ) then 18242 return Large_Max_Size_Mutable (Typ); 18243 18244 -- Indefinite (discriminated) untagged record or protected type 18245 18246 elsif Is_Record_Type (Typ) or else Is_Protected_Type (Typ) then 18247 return not Caller_Known_Size_Record (Typ); 18248 18249 -- Unconstrained array 18250 18251 else 18252 pragma Assert (Is_Array_Type (Typ) and not Is_Definite_Subtype (Typ)); 18253 return True; 18254 end if; 18255 end New_Requires_Transient_Scope; 18256 18257 -------------------------- 18258 -- Reset_Analyzed_Flags -- 18259 -------------------------- 18260 18261 procedure Reset_Analyzed_Flags (N : Node_Id) is 18262 18263 function Clear_Analyzed (N : Node_Id) return Traverse_Result; 18264 -- Function used to reset Analyzed flags in tree. Note that we do 18265 -- not reset Analyzed flags in entities, since there is no need to 18266 -- reanalyze entities, and indeed, it is wrong to do so, since it 18267 -- can result in generating auxiliary stuff more than once. 18268 18269 -------------------- 18270 -- Clear_Analyzed -- 18271 -------------------- 18272 18273 function Clear_Analyzed (N : Node_Id) return Traverse_Result is 18274 begin 18275 if not Has_Extension (N) then 18276 Set_Analyzed (N, False); 18277 end if; 18278 18279 return OK; 18280 end Clear_Analyzed; 18281 18282 procedure Reset_Analyzed is new Traverse_Proc (Clear_Analyzed); 18283 18284 -- Start of processing for Reset_Analyzed_Flags 18285 18286 begin 18287 Reset_Analyzed (N); 18288 end Reset_Analyzed_Flags; 18289 18290 ------------------------ 18291 -- Restore_SPARK_Mode -- 18292 ------------------------ 18293 18294 procedure Restore_SPARK_Mode (Mode : SPARK_Mode_Type) is 18295 begin 18296 SPARK_Mode := Mode; 18297 end Restore_SPARK_Mode; 18298 18299 -------------------------------- 18300 -- Returns_Unconstrained_Type -- 18301 -------------------------------- 18302 18303 function Returns_Unconstrained_Type (Subp : Entity_Id) return Boolean is 18304 begin 18305 return Ekind (Subp) = E_Function 18306 and then not Is_Scalar_Type (Etype (Subp)) 18307 and then not Is_Access_Type (Etype (Subp)) 18308 and then not Is_Constrained (Etype (Subp)); 18309 end Returns_Unconstrained_Type; 18310 18311 ---------------------------- 18312 -- Root_Type_Of_Full_View -- 18313 ---------------------------- 18314 18315 function Root_Type_Of_Full_View (T : Entity_Id) return Entity_Id is 18316 Rtyp : constant Entity_Id := Root_Type (T); 18317 18318 begin 18319 -- The root type of the full view may itself be a private type. Keep 18320 -- looking for the ultimate derivation parent. 18321 18322 if Is_Private_Type (Rtyp) and then Present (Full_View (Rtyp)) then 18323 return Root_Type_Of_Full_View (Full_View (Rtyp)); 18324 else 18325 return Rtyp; 18326 end if; 18327 end Root_Type_Of_Full_View; 18328 18329 --------------------------- 18330 -- Safe_To_Capture_Value -- 18331 --------------------------- 18332 18333 function Safe_To_Capture_Value 18334 (N : Node_Id; 18335 Ent : Entity_Id; 18336 Cond : Boolean := False) return Boolean 18337 is 18338 begin 18339 -- The only entities for which we track constant values are variables 18340 -- which are not renamings, constants, out parameters, and in out 18341 -- parameters, so check if we have this case. 18342 18343 -- Note: it may seem odd to track constant values for constants, but in 18344 -- fact this routine is used for other purposes than simply capturing 18345 -- the value. In particular, the setting of Known[_Non]_Null. 18346 18347 if (Ekind (Ent) = E_Variable and then No (Renamed_Object (Ent))) 18348 or else 18349 Ekind_In (Ent, E_Constant, E_Out_Parameter, E_In_Out_Parameter) 18350 then 18351 null; 18352 18353 -- For conditionals, we also allow loop parameters and all formals, 18354 -- including in parameters. 18355 18356 elsif Cond and then Ekind_In (Ent, E_Loop_Parameter, E_In_Parameter) then 18357 null; 18358 18359 -- For all other cases, not just unsafe, but impossible to capture 18360 -- Current_Value, since the above are the only entities which have 18361 -- Current_Value fields. 18362 18363 else 18364 return False; 18365 end if; 18366 18367 -- Skip if volatile or aliased, since funny things might be going on in 18368 -- these cases which we cannot necessarily track. Also skip any variable 18369 -- for which an address clause is given, or whose address is taken. Also 18370 -- never capture value of library level variables (an attempt to do so 18371 -- can occur in the case of package elaboration code). 18372 18373 if Treat_As_Volatile (Ent) 18374 or else Is_Aliased (Ent) 18375 or else Present (Address_Clause (Ent)) 18376 or else Address_Taken (Ent) 18377 or else (Is_Library_Level_Entity (Ent) 18378 and then Ekind (Ent) = E_Variable) 18379 then 18380 return False; 18381 end if; 18382 18383 -- OK, all above conditions are met. We also require that the scope of 18384 -- the reference be the same as the scope of the entity, not counting 18385 -- packages and blocks and loops. 18386 18387 declare 18388 E_Scope : constant Entity_Id := Scope (Ent); 18389 R_Scope : Entity_Id; 18390 18391 begin 18392 R_Scope := Current_Scope; 18393 while R_Scope /= Standard_Standard loop 18394 exit when R_Scope = E_Scope; 18395 18396 if not Ekind_In (R_Scope, E_Package, E_Block, E_Loop) then 18397 return False; 18398 else 18399 R_Scope := Scope (R_Scope); 18400 end if; 18401 end loop; 18402 end; 18403 18404 -- We also require that the reference does not appear in a context 18405 -- where it is not sure to be executed (i.e. a conditional context 18406 -- or an exception handler). We skip this if Cond is True, since the 18407 -- capturing of values from conditional tests handles this ok. 18408 18409 if Cond then 18410 return True; 18411 end if; 18412 18413 declare 18414 Desc : Node_Id; 18415 P : Node_Id; 18416 18417 begin 18418 Desc := N; 18419 18420 -- Seems dubious that case expressions are not handled here ??? 18421 18422 P := Parent (N); 18423 while Present (P) loop 18424 if Nkind (P) = N_If_Statement 18425 or else Nkind (P) = N_Case_Statement 18426 or else (Nkind (P) in N_Short_Circuit 18427 and then Desc = Right_Opnd (P)) 18428 or else (Nkind (P) = N_If_Expression 18429 and then Desc /= First (Expressions (P))) 18430 or else Nkind (P) = N_Exception_Handler 18431 or else Nkind (P) = N_Selective_Accept 18432 or else Nkind (P) = N_Conditional_Entry_Call 18433 or else Nkind (P) = N_Timed_Entry_Call 18434 or else Nkind (P) = N_Asynchronous_Select 18435 then 18436 return False; 18437 18438 else 18439 Desc := P; 18440 P := Parent (P); 18441 18442 -- A special Ada 2012 case: the original node may be part 18443 -- of the else_actions of a conditional expression, in which 18444 -- case it might not have been expanded yet, and appears in 18445 -- a non-syntactic list of actions. In that case it is clearly 18446 -- not safe to save a value. 18447 18448 if No (P) 18449 and then Is_List_Member (Desc) 18450 and then No (Parent (List_Containing (Desc))) 18451 then 18452 return False; 18453 end if; 18454 end if; 18455 end loop; 18456 end; 18457 18458 -- OK, looks safe to set value 18459 18460 return True; 18461 end Safe_To_Capture_Value; 18462 18463 --------------- 18464 -- Same_Name -- 18465 --------------- 18466 18467 function Same_Name (N1, N2 : Node_Id) return Boolean is 18468 K1 : constant Node_Kind := Nkind (N1); 18469 K2 : constant Node_Kind := Nkind (N2); 18470 18471 begin 18472 if (K1 = N_Identifier or else K1 = N_Defining_Identifier) 18473 and then (K2 = N_Identifier or else K2 = N_Defining_Identifier) 18474 then 18475 return Chars (N1) = Chars (N2); 18476 18477 elsif (K1 = N_Selected_Component or else K1 = N_Expanded_Name) 18478 and then (K2 = N_Selected_Component or else K2 = N_Expanded_Name) 18479 then 18480 return Same_Name (Selector_Name (N1), Selector_Name (N2)) 18481 and then Same_Name (Prefix (N1), Prefix (N2)); 18482 18483 else 18484 return False; 18485 end if; 18486 end Same_Name; 18487 18488 ----------------- 18489 -- Same_Object -- 18490 ----------------- 18491 18492 function Same_Object (Node1, Node2 : Node_Id) return Boolean is 18493 N1 : constant Node_Id := Original_Node (Node1); 18494 N2 : constant Node_Id := Original_Node (Node2); 18495 -- We do the tests on original nodes, since we are most interested 18496 -- in the original source, not any expansion that got in the way. 18497 18498 K1 : constant Node_Kind := Nkind (N1); 18499 K2 : constant Node_Kind := Nkind (N2); 18500 18501 begin 18502 -- First case, both are entities with same entity 18503 18504 if K1 in N_Has_Entity and then K2 in N_Has_Entity then 18505 declare 18506 EN1 : constant Entity_Id := Entity (N1); 18507 EN2 : constant Entity_Id := Entity (N2); 18508 begin 18509 if Present (EN1) and then Present (EN2) 18510 and then (Ekind_In (EN1, E_Variable, E_Constant) 18511 or else Is_Formal (EN1)) 18512 and then EN1 = EN2 18513 then 18514 return True; 18515 end if; 18516 end; 18517 end if; 18518 18519 -- Second case, selected component with same selector, same record 18520 18521 if K1 = N_Selected_Component 18522 and then K2 = N_Selected_Component 18523 and then Chars (Selector_Name (N1)) = Chars (Selector_Name (N2)) 18524 then 18525 return Same_Object (Prefix (N1), Prefix (N2)); 18526 18527 -- Third case, indexed component with same subscripts, same array 18528 18529 elsif K1 = N_Indexed_Component 18530 and then K2 = N_Indexed_Component 18531 and then Same_Object (Prefix (N1), Prefix (N2)) 18532 then 18533 declare 18534 E1, E2 : Node_Id; 18535 begin 18536 E1 := First (Expressions (N1)); 18537 E2 := First (Expressions (N2)); 18538 while Present (E1) loop 18539 if not Same_Value (E1, E2) then 18540 return False; 18541 else 18542 Next (E1); 18543 Next (E2); 18544 end if; 18545 end loop; 18546 18547 return True; 18548 end; 18549 18550 -- Fourth case, slice of same array with same bounds 18551 18552 elsif K1 = N_Slice 18553 and then K2 = N_Slice 18554 and then Nkind (Discrete_Range (N1)) = N_Range 18555 and then Nkind (Discrete_Range (N2)) = N_Range 18556 and then Same_Value (Low_Bound (Discrete_Range (N1)), 18557 Low_Bound (Discrete_Range (N2))) 18558 and then Same_Value (High_Bound (Discrete_Range (N1)), 18559 High_Bound (Discrete_Range (N2))) 18560 then 18561 return Same_Name (Prefix (N1), Prefix (N2)); 18562 18563 -- All other cases, not clearly the same object 18564 18565 else 18566 return False; 18567 end if; 18568 end Same_Object; 18569 18570 --------------- 18571 -- Same_Type -- 18572 --------------- 18573 18574 function Same_Type (T1, T2 : Entity_Id) return Boolean is 18575 begin 18576 if T1 = T2 then 18577 return True; 18578 18579 elsif not Is_Constrained (T1) 18580 and then not Is_Constrained (T2) 18581 and then Base_Type (T1) = Base_Type (T2) 18582 then 18583 return True; 18584 18585 -- For now don't bother with case of identical constraints, to be 18586 -- fiddled with later on perhaps (this is only used for optimization 18587 -- purposes, so it is not critical to do a best possible job) 18588 18589 else 18590 return False; 18591 end if; 18592 end Same_Type; 18593 18594 ---------------- 18595 -- Same_Value -- 18596 ---------------- 18597 18598 function Same_Value (Node1, Node2 : Node_Id) return Boolean is 18599 begin 18600 if Compile_Time_Known_Value (Node1) 18601 and then Compile_Time_Known_Value (Node2) 18602 and then Expr_Value (Node1) = Expr_Value (Node2) 18603 then 18604 return True; 18605 elsif Same_Object (Node1, Node2) then 18606 return True; 18607 else 18608 return False; 18609 end if; 18610 end Same_Value; 18611 18612 ----------------------------- 18613 -- Save_SPARK_Mode_And_Set -- 18614 ----------------------------- 18615 18616 procedure Save_SPARK_Mode_And_Set 18617 (Context : Entity_Id; 18618 Mode : out SPARK_Mode_Type) 18619 is 18620 begin 18621 -- Save the current mode in effect 18622 18623 Mode := SPARK_Mode; 18624 18625 -- Do not consider illegal or partially decorated constructs 18626 18627 if Ekind (Context) = E_Void or else Error_Posted (Context) then 18628 null; 18629 18630 elsif Present (SPARK_Pragma (Context)) then 18631 SPARK_Mode := Get_SPARK_Mode_From_Pragma (SPARK_Pragma (Context)); 18632 end if; 18633 end Save_SPARK_Mode_And_Set; 18634 18635 ------------------------- 18636 -- Scalar_Part_Present -- 18637 ------------------------- 18638 18639 function Scalar_Part_Present (T : Entity_Id) return Boolean is 18640 C : Entity_Id; 18641 18642 begin 18643 if Is_Scalar_Type (T) then 18644 return True; 18645 18646 elsif Is_Array_Type (T) then 18647 return Scalar_Part_Present (Component_Type (T)); 18648 18649 elsif Is_Record_Type (T) or else Has_Discriminants (T) then 18650 C := First_Component_Or_Discriminant (T); 18651 while Present (C) loop 18652 if Scalar_Part_Present (Etype (C)) then 18653 return True; 18654 else 18655 Next_Component_Or_Discriminant (C); 18656 end if; 18657 end loop; 18658 end if; 18659 18660 return False; 18661 end Scalar_Part_Present; 18662 18663 ------------------------ 18664 -- Scope_Is_Transient -- 18665 ------------------------ 18666 18667 function Scope_Is_Transient return Boolean is 18668 begin 18669 return Scope_Stack.Table (Scope_Stack.Last).Is_Transient; 18670 end Scope_Is_Transient; 18671 18672 ------------------ 18673 -- Scope_Within -- 18674 ------------------ 18675 18676 function Scope_Within (Scope1, Scope2 : Entity_Id) return Boolean is 18677 Scop : Entity_Id; 18678 18679 begin 18680 Scop := Scope1; 18681 while Scop /= Standard_Standard loop 18682 Scop := Scope (Scop); 18683 18684 if Scop = Scope2 then 18685 return True; 18686 end if; 18687 end loop; 18688 18689 return False; 18690 end Scope_Within; 18691 18692 -------------------------- 18693 -- Scope_Within_Or_Same -- 18694 -------------------------- 18695 18696 function Scope_Within_Or_Same (Scope1, Scope2 : Entity_Id) return Boolean is 18697 Scop : Entity_Id; 18698 18699 begin 18700 Scop := Scope1; 18701 while Scop /= Standard_Standard loop 18702 if Scop = Scope2 then 18703 return True; 18704 else 18705 Scop := Scope (Scop); 18706 end if; 18707 end loop; 18708 18709 return False; 18710 end Scope_Within_Or_Same; 18711 18712 -------------------- 18713 -- Set_Convention -- 18714 -------------------- 18715 18716 procedure Set_Convention (E : Entity_Id; Val : Snames.Convention_Id) is 18717 begin 18718 Basic_Set_Convention (E, Val); 18719 18720 if Is_Type (E) 18721 and then Is_Access_Subprogram_Type (Base_Type (E)) 18722 and then Has_Foreign_Convention (E) 18723 then 18724 18725 -- A pragma Convention in an instance may apply to the subtype 18726 -- created for a formal, in which case we have already verified 18727 -- that conventions of actual and formal match and there is nothing 18728 -- to flag on the subtype. 18729 18730 if In_Instance then 18731 null; 18732 else 18733 Set_Can_Use_Internal_Rep (E, False); 18734 end if; 18735 end if; 18736 18737 -- If E is an object or component, and the type of E is an anonymous 18738 -- access type with no convention set, then also set the convention of 18739 -- the anonymous access type. We do not do this for anonymous protected 18740 -- types, since protected types always have the default convention. 18741 18742 if Present (Etype (E)) 18743 and then (Is_Object (E) 18744 or else Ekind (E) = E_Component 18745 18746 -- Allow E_Void (happens for pragma Convention appearing 18747 -- in the middle of a record applying to a component) 18748 18749 or else Ekind (E) = E_Void) 18750 then 18751 declare 18752 Typ : constant Entity_Id := Etype (E); 18753 18754 begin 18755 if Ekind_In (Typ, E_Anonymous_Access_Type, 18756 E_Anonymous_Access_Subprogram_Type) 18757 and then not Has_Convention_Pragma (Typ) 18758 then 18759 Basic_Set_Convention (Typ, Val); 18760 Set_Has_Convention_Pragma (Typ); 18761 18762 -- And for the access subprogram type, deal similarly with the 18763 -- designated E_Subprogram_Type if it is also internal (which 18764 -- it always is?) 18765 18766 if Ekind (Typ) = E_Anonymous_Access_Subprogram_Type then 18767 declare 18768 Dtype : constant Entity_Id := Designated_Type (Typ); 18769 begin 18770 if Ekind (Dtype) = E_Subprogram_Type 18771 and then Is_Itype (Dtype) 18772 and then not Has_Convention_Pragma (Dtype) 18773 then 18774 Basic_Set_Convention (Dtype, Val); 18775 Set_Has_Convention_Pragma (Dtype); 18776 end if; 18777 end; 18778 end if; 18779 end if; 18780 end; 18781 end if; 18782 end Set_Convention; 18783 18784 ------------------------ 18785 -- Set_Current_Entity -- 18786 ------------------------ 18787 18788 -- The given entity is to be set as the currently visible definition of its 18789 -- associated name (i.e. the Node_Id associated with its name). All we have 18790 -- to do is to get the name from the identifier, and then set the 18791 -- associated Node_Id to point to the given entity. 18792 18793 procedure Set_Current_Entity (E : Entity_Id) is 18794 begin 18795 Set_Name_Entity_Id (Chars (E), E); 18796 end Set_Current_Entity; 18797 18798 --------------------------- 18799 -- Set_Debug_Info_Needed -- 18800 --------------------------- 18801 18802 procedure Set_Debug_Info_Needed (T : Entity_Id) is 18803 18804 procedure Set_Debug_Info_Needed_If_Not_Set (E : Entity_Id); 18805 pragma Inline (Set_Debug_Info_Needed_If_Not_Set); 18806 -- Used to set debug info in a related node if not set already 18807 18808 -------------------------------------- 18809 -- Set_Debug_Info_Needed_If_Not_Set -- 18810 -------------------------------------- 18811 18812 procedure Set_Debug_Info_Needed_If_Not_Set (E : Entity_Id) is 18813 begin 18814 if Present (E) and then not Needs_Debug_Info (E) then 18815 Set_Debug_Info_Needed (E); 18816 18817 -- For a private type, indicate that the full view also needs 18818 -- debug information. 18819 18820 if Is_Type (E) 18821 and then Is_Private_Type (E) 18822 and then Present (Full_View (E)) 18823 then 18824 Set_Debug_Info_Needed (Full_View (E)); 18825 end if; 18826 end if; 18827 end Set_Debug_Info_Needed_If_Not_Set; 18828 18829 -- Start of processing for Set_Debug_Info_Needed 18830 18831 begin 18832 -- Nothing to do if argument is Empty or has Debug_Info_Off set, which 18833 -- indicates that Debug_Info_Needed is never required for the entity. 18834 -- Nothing to do if entity comes from a predefined file. Library files 18835 -- are compiled without debug information, but inlined bodies of these 18836 -- routines may appear in user code, and debug information on them ends 18837 -- up complicating debugging the user code. 18838 18839 if No (T) 18840 or else Debug_Info_Off (T) 18841 then 18842 return; 18843 18844 elsif In_Inlined_Body 18845 and then Is_Predefined_File_Name 18846 (Unit_File_Name (Get_Source_Unit (Sloc (T)))) 18847 then 18848 Set_Needs_Debug_Info (T, False); 18849 end if; 18850 18851 -- Set flag in entity itself. Note that we will go through the following 18852 -- circuitry even if the flag is already set on T. That's intentional, 18853 -- it makes sure that the flag will be set in subsidiary entities. 18854 18855 Set_Needs_Debug_Info (T); 18856 18857 -- Set flag on subsidiary entities if not set already 18858 18859 if Is_Object (T) then 18860 Set_Debug_Info_Needed_If_Not_Set (Etype (T)); 18861 18862 elsif Is_Type (T) then 18863 Set_Debug_Info_Needed_If_Not_Set (Etype (T)); 18864 18865 if Is_Record_Type (T) then 18866 declare 18867 Ent : Entity_Id := First_Entity (T); 18868 begin 18869 while Present (Ent) loop 18870 Set_Debug_Info_Needed_If_Not_Set (Ent); 18871 Next_Entity (Ent); 18872 end loop; 18873 end; 18874 18875 -- For a class wide subtype, we also need debug information 18876 -- for the equivalent type. 18877 18878 if Ekind (T) = E_Class_Wide_Subtype then 18879 Set_Debug_Info_Needed_If_Not_Set (Equivalent_Type (T)); 18880 end if; 18881 18882 elsif Is_Array_Type (T) then 18883 Set_Debug_Info_Needed_If_Not_Set (Component_Type (T)); 18884 18885 declare 18886 Indx : Node_Id := First_Index (T); 18887 begin 18888 while Present (Indx) loop 18889 Set_Debug_Info_Needed_If_Not_Set (Etype (Indx)); 18890 Indx := Next_Index (Indx); 18891 end loop; 18892 end; 18893 18894 -- For a packed array type, we also need debug information for 18895 -- the type used to represent the packed array. Conversely, we 18896 -- also need it for the former if we need it for the latter. 18897 18898 if Is_Packed (T) then 18899 Set_Debug_Info_Needed_If_Not_Set (Packed_Array_Impl_Type (T)); 18900 end if; 18901 18902 if Is_Packed_Array_Impl_Type (T) then 18903 Set_Debug_Info_Needed_If_Not_Set (Original_Array_Type (T)); 18904 end if; 18905 18906 elsif Is_Access_Type (T) then 18907 Set_Debug_Info_Needed_If_Not_Set (Directly_Designated_Type (T)); 18908 18909 elsif Is_Private_Type (T) then 18910 declare 18911 FV : constant Entity_Id := Full_View (T); 18912 18913 begin 18914 Set_Debug_Info_Needed_If_Not_Set (FV); 18915 18916 -- If the full view is itself a derived private type, we need 18917 -- debug information on its underlying type. 18918 18919 if Present (FV) 18920 and then Is_Private_Type (FV) 18921 and then Present (Underlying_Full_View (FV)) 18922 then 18923 Set_Needs_Debug_Info (Underlying_Full_View (FV)); 18924 end if; 18925 end; 18926 18927 elsif Is_Protected_Type (T) then 18928 Set_Debug_Info_Needed_If_Not_Set (Corresponding_Record_Type (T)); 18929 18930 elsif Is_Scalar_Type (T) then 18931 18932 -- If the subrange bounds are materialized by dedicated constant 18933 -- objects, also include them in the debug info to make sure the 18934 -- debugger can properly use them. 18935 18936 if Present (Scalar_Range (T)) 18937 and then Nkind (Scalar_Range (T)) = N_Range 18938 then 18939 declare 18940 Low_Bnd : constant Node_Id := Type_Low_Bound (T); 18941 High_Bnd : constant Node_Id := Type_High_Bound (T); 18942 18943 begin 18944 if Is_Entity_Name (Low_Bnd) then 18945 Set_Debug_Info_Needed_If_Not_Set (Entity (Low_Bnd)); 18946 end if; 18947 18948 if Is_Entity_Name (High_Bnd) then 18949 Set_Debug_Info_Needed_If_Not_Set (Entity (High_Bnd)); 18950 end if; 18951 end; 18952 end if; 18953 end if; 18954 end if; 18955 end Set_Debug_Info_Needed; 18956 18957 ---------------------------- 18958 -- Set_Entity_With_Checks -- 18959 ---------------------------- 18960 18961 procedure Set_Entity_With_Checks (N : Node_Id; Val : Entity_Id) is 18962 Val_Actual : Entity_Id; 18963 Nod : Node_Id; 18964 Post_Node : Node_Id; 18965 18966 begin 18967 -- Unconditionally set the entity 18968 18969 Set_Entity (N, Val); 18970 18971 -- The node to post on is the selector in the case of an expanded name, 18972 -- and otherwise the node itself. 18973 18974 if Nkind (N) = N_Expanded_Name then 18975 Post_Node := Selector_Name (N); 18976 else 18977 Post_Node := N; 18978 end if; 18979 18980 -- Check for violation of No_Fixed_IO 18981 18982 if Restriction_Check_Required (No_Fixed_IO) 18983 and then 18984 ((RTU_Loaded (Ada_Text_IO) 18985 and then (Is_RTE (Val, RE_Decimal_IO) 18986 or else 18987 Is_RTE (Val, RE_Fixed_IO))) 18988 18989 or else 18990 (RTU_Loaded (Ada_Wide_Text_IO) 18991 and then (Is_RTE (Val, RO_WT_Decimal_IO) 18992 or else 18993 Is_RTE (Val, RO_WT_Fixed_IO))) 18994 18995 or else 18996 (RTU_Loaded (Ada_Wide_Wide_Text_IO) 18997 and then (Is_RTE (Val, RO_WW_Decimal_IO) 18998 or else 18999 Is_RTE (Val, RO_WW_Fixed_IO)))) 19000 19001 -- A special extra check, don't complain about a reference from within 19002 -- the Ada.Interrupts package itself! 19003 19004 and then not In_Same_Extended_Unit (N, Val) 19005 then 19006 Check_Restriction (No_Fixed_IO, Post_Node); 19007 end if; 19008 19009 -- Remaining checks are only done on source nodes. Note that we test 19010 -- for violation of No_Fixed_IO even on non-source nodes, because the 19011 -- cases for checking violations of this restriction are instantiations 19012 -- where the reference in the instance has Comes_From_Source False. 19013 19014 if not Comes_From_Source (N) then 19015 return; 19016 end if; 19017 19018 -- Check for violation of No_Abort_Statements, which is triggered by 19019 -- call to Ada.Task_Identification.Abort_Task. 19020 19021 if Restriction_Check_Required (No_Abort_Statements) 19022 and then (Is_RTE (Val, RE_Abort_Task)) 19023 19024 -- A special extra check, don't complain about a reference from within 19025 -- the Ada.Task_Identification package itself! 19026 19027 and then not In_Same_Extended_Unit (N, Val) 19028 then 19029 Check_Restriction (No_Abort_Statements, Post_Node); 19030 end if; 19031 19032 if Val = Standard_Long_Long_Integer then 19033 Check_Restriction (No_Long_Long_Integers, Post_Node); 19034 end if; 19035 19036 -- Check for violation of No_Dynamic_Attachment 19037 19038 if Restriction_Check_Required (No_Dynamic_Attachment) 19039 and then RTU_Loaded (Ada_Interrupts) 19040 and then (Is_RTE (Val, RE_Is_Reserved) or else 19041 Is_RTE (Val, RE_Is_Attached) or else 19042 Is_RTE (Val, RE_Current_Handler) or else 19043 Is_RTE (Val, RE_Attach_Handler) or else 19044 Is_RTE (Val, RE_Exchange_Handler) or else 19045 Is_RTE (Val, RE_Detach_Handler) or else 19046 Is_RTE (Val, RE_Reference)) 19047 19048 -- A special extra check, don't complain about a reference from within 19049 -- the Ada.Interrupts package itself! 19050 19051 and then not In_Same_Extended_Unit (N, Val) 19052 then 19053 Check_Restriction (No_Dynamic_Attachment, Post_Node); 19054 end if; 19055 19056 -- Check for No_Implementation_Identifiers 19057 19058 if Restriction_Check_Required (No_Implementation_Identifiers) then 19059 19060 -- We have an implementation defined entity if it is marked as 19061 -- implementation defined, or is defined in a package marked as 19062 -- implementation defined. However, library packages themselves 19063 -- are excluded (we don't want to flag Interfaces itself, just 19064 -- the entities within it). 19065 19066 if (Is_Implementation_Defined (Val) 19067 or else 19068 (Present (Scope (Val)) 19069 and then Is_Implementation_Defined (Scope (Val)))) 19070 and then not (Ekind_In (Val, E_Package, E_Generic_Package) 19071 and then Is_Library_Level_Entity (Val)) 19072 then 19073 Check_Restriction (No_Implementation_Identifiers, Post_Node); 19074 end if; 19075 end if; 19076 19077 -- Do the style check 19078 19079 if Style_Check 19080 and then not Suppress_Style_Checks (Val) 19081 and then not In_Instance 19082 then 19083 if Nkind (N) = N_Identifier then 19084 Nod := N; 19085 elsif Nkind (N) = N_Expanded_Name then 19086 Nod := Selector_Name (N); 19087 else 19088 return; 19089 end if; 19090 19091 -- A special situation arises for derived operations, where we want 19092 -- to do the check against the parent (since the Sloc of the derived 19093 -- operation points to the derived type declaration itself). 19094 19095 Val_Actual := Val; 19096 while not Comes_From_Source (Val_Actual) 19097 and then Nkind (Val_Actual) in N_Entity 19098 and then (Ekind (Val_Actual) = E_Enumeration_Literal 19099 or else Is_Subprogram_Or_Generic_Subprogram (Val_Actual)) 19100 and then Present (Alias (Val_Actual)) 19101 loop 19102 Val_Actual := Alias (Val_Actual); 19103 end loop; 19104 19105 -- Renaming declarations for generic actuals do not come from source, 19106 -- and have a different name from that of the entity they rename, so 19107 -- there is no style check to perform here. 19108 19109 if Chars (Nod) = Chars (Val_Actual) then 19110 Style.Check_Identifier (Nod, Val_Actual); 19111 end if; 19112 end if; 19113 19114 Set_Entity (N, Val); 19115 end Set_Entity_With_Checks; 19116 19117 ------------------------ 19118 -- Set_Name_Entity_Id -- 19119 ------------------------ 19120 19121 procedure Set_Name_Entity_Id (Id : Name_Id; Val : Entity_Id) is 19122 begin 19123 Set_Name_Table_Int (Id, Int (Val)); 19124 end Set_Name_Entity_Id; 19125 19126 --------------------- 19127 -- Set_Next_Actual -- 19128 --------------------- 19129 19130 procedure Set_Next_Actual (Ass1_Id : Node_Id; Ass2_Id : Node_Id) is 19131 begin 19132 if Nkind (Parent (Ass1_Id)) = N_Parameter_Association then 19133 Set_First_Named_Actual (Parent (Ass1_Id), Ass2_Id); 19134 end if; 19135 end Set_Next_Actual; 19136 19137 ---------------------------------- 19138 -- Set_Optimize_Alignment_Flags -- 19139 ---------------------------------- 19140 19141 procedure Set_Optimize_Alignment_Flags (E : Entity_Id) is 19142 begin 19143 if Optimize_Alignment = 'S' then 19144 Set_Optimize_Alignment_Space (E); 19145 elsif Optimize_Alignment = 'T' then 19146 Set_Optimize_Alignment_Time (E); 19147 end if; 19148 end Set_Optimize_Alignment_Flags; 19149 19150 ----------------------- 19151 -- Set_Public_Status -- 19152 ----------------------- 19153 19154 procedure Set_Public_Status (Id : Entity_Id) is 19155 S : constant Entity_Id := Current_Scope; 19156 19157 function Within_HSS_Or_If (E : Entity_Id) return Boolean; 19158 -- Determines if E is defined within handled statement sequence or 19159 -- an if statement, returns True if so, False otherwise. 19160 19161 ---------------------- 19162 -- Within_HSS_Or_If -- 19163 ---------------------- 19164 19165 function Within_HSS_Or_If (E : Entity_Id) return Boolean is 19166 N : Node_Id; 19167 begin 19168 N := Declaration_Node (E); 19169 loop 19170 N := Parent (N); 19171 19172 if No (N) then 19173 return False; 19174 19175 elsif Nkind_In (N, N_Handled_Sequence_Of_Statements, 19176 N_If_Statement) 19177 then 19178 return True; 19179 end if; 19180 end loop; 19181 end Within_HSS_Or_If; 19182 19183 -- Start of processing for Set_Public_Status 19184 19185 begin 19186 -- Everything in the scope of Standard is public 19187 19188 if S = Standard_Standard then 19189 Set_Is_Public (Id); 19190 19191 -- Entity is definitely not public if enclosing scope is not public 19192 19193 elsif not Is_Public (S) then 19194 return; 19195 19196 -- An object or function declaration that occurs in a handled sequence 19197 -- of statements or within an if statement is the declaration for a 19198 -- temporary object or local subprogram generated by the expander. It 19199 -- never needs to be made public and furthermore, making it public can 19200 -- cause back end problems. 19201 19202 elsif Nkind_In (Parent (Id), N_Object_Declaration, 19203 N_Function_Specification) 19204 and then Within_HSS_Or_If (Id) 19205 then 19206 return; 19207 19208 -- Entities in public packages or records are public 19209 19210 elsif Ekind (S) = E_Package or Is_Record_Type (S) then 19211 Set_Is_Public (Id); 19212 19213 -- The bounds of an entry family declaration can generate object 19214 -- declarations that are visible to the back-end, e.g. in the 19215 -- the declaration of a composite type that contains tasks. 19216 19217 elsif Is_Concurrent_Type (S) 19218 and then not Has_Completion (S) 19219 and then Nkind (Parent (Id)) = N_Object_Declaration 19220 then 19221 Set_Is_Public (Id); 19222 end if; 19223 end Set_Public_Status; 19224 19225 ----------------------------- 19226 -- Set_Referenced_Modified -- 19227 ----------------------------- 19228 19229 procedure Set_Referenced_Modified (N : Node_Id; Out_Param : Boolean) is 19230 Pref : Node_Id; 19231 19232 begin 19233 -- Deal with indexed or selected component where prefix is modified 19234 19235 if Nkind_In (N, N_Indexed_Component, N_Selected_Component) then 19236 Pref := Prefix (N); 19237 19238 -- If prefix is access type, then it is the designated object that is 19239 -- being modified, which means we have no entity to set the flag on. 19240 19241 if No (Etype (Pref)) or else Is_Access_Type (Etype (Pref)) then 19242 return; 19243 19244 -- Otherwise chase the prefix 19245 19246 else 19247 Set_Referenced_Modified (Pref, Out_Param); 19248 end if; 19249 19250 -- Otherwise see if we have an entity name (only other case to process) 19251 19252 elsif Is_Entity_Name (N) and then Present (Entity (N)) then 19253 Set_Referenced_As_LHS (Entity (N), not Out_Param); 19254 Set_Referenced_As_Out_Parameter (Entity (N), Out_Param); 19255 end if; 19256 end Set_Referenced_Modified; 19257 19258 ---------------------------- 19259 -- Set_Scope_Is_Transient -- 19260 ---------------------------- 19261 19262 procedure Set_Scope_Is_Transient (V : Boolean := True) is 19263 begin 19264 Scope_Stack.Table (Scope_Stack.Last).Is_Transient := V; 19265 end Set_Scope_Is_Transient; 19266 19267 ------------------- 19268 -- Set_Size_Info -- 19269 ------------------- 19270 19271 procedure Set_Size_Info (T1, T2 : Entity_Id) is 19272 begin 19273 -- We copy Esize, but not RM_Size, since in general RM_Size is 19274 -- subtype specific and does not get inherited by all subtypes. 19275 19276 Set_Esize (T1, Esize (T2)); 19277 Set_Has_Biased_Representation (T1, Has_Biased_Representation (T2)); 19278 19279 if Is_Discrete_Or_Fixed_Point_Type (T1) 19280 and then 19281 Is_Discrete_Or_Fixed_Point_Type (T2) 19282 then 19283 Set_Is_Unsigned_Type (T1, Is_Unsigned_Type (T2)); 19284 end if; 19285 19286 Set_Alignment (T1, Alignment (T2)); 19287 end Set_Size_Info; 19288 19289 -------------------- 19290 -- Static_Boolean -- 19291 -------------------- 19292 19293 function Static_Boolean (N : Node_Id) return Uint is 19294 begin 19295 Analyze_And_Resolve (N, Standard_Boolean); 19296 19297 if N = Error 19298 or else Error_Posted (N) 19299 or else Etype (N) = Any_Type 19300 then 19301 return No_Uint; 19302 end if; 19303 19304 if Is_OK_Static_Expression (N) then 19305 if not Raises_Constraint_Error (N) then 19306 return Expr_Value (N); 19307 else 19308 return No_Uint; 19309 end if; 19310 19311 elsif Etype (N) = Any_Type then 19312 return No_Uint; 19313 19314 else 19315 Flag_Non_Static_Expr 19316 ("static boolean expression required here", N); 19317 return No_Uint; 19318 end if; 19319 end Static_Boolean; 19320 19321 -------------------- 19322 -- Static_Integer -- 19323 -------------------- 19324 19325 function Static_Integer (N : Node_Id) return Uint is 19326 begin 19327 Analyze_And_Resolve (N, Any_Integer); 19328 19329 if N = Error 19330 or else Error_Posted (N) 19331 or else Etype (N) = Any_Type 19332 then 19333 return No_Uint; 19334 end if; 19335 19336 if Is_OK_Static_Expression (N) then 19337 if not Raises_Constraint_Error (N) then 19338 return Expr_Value (N); 19339 else 19340 return No_Uint; 19341 end if; 19342 19343 elsif Etype (N) = Any_Type then 19344 return No_Uint; 19345 19346 else 19347 Flag_Non_Static_Expr 19348 ("static integer expression required here", N); 19349 return No_Uint; 19350 end if; 19351 end Static_Integer; 19352 19353 -------------------------- 19354 -- Statically_Different -- 19355 -------------------------- 19356 19357 function Statically_Different (E1, E2 : Node_Id) return Boolean is 19358 R1 : constant Node_Id := Get_Referenced_Object (E1); 19359 R2 : constant Node_Id := Get_Referenced_Object (E2); 19360 begin 19361 return Is_Entity_Name (R1) 19362 and then Is_Entity_Name (R2) 19363 and then Entity (R1) /= Entity (R2) 19364 and then not Is_Formal (Entity (R1)) 19365 and then not Is_Formal (Entity (R2)); 19366 end Statically_Different; 19367 19368 -------------------------------------- 19369 -- Subject_To_Loop_Entry_Attributes -- 19370 -------------------------------------- 19371 19372 function Subject_To_Loop_Entry_Attributes (N : Node_Id) return Boolean is 19373 Stmt : Node_Id; 19374 19375 begin 19376 Stmt := N; 19377 19378 -- The expansion mechanism transform a loop subject to at least one 19379 -- 'Loop_Entry attribute into a conditional block. Infinite loops lack 19380 -- the conditional part. 19381 19382 if Nkind_In (Stmt, N_Block_Statement, N_If_Statement) 19383 and then Nkind (Original_Node (N)) = N_Loop_Statement 19384 then 19385 Stmt := Original_Node (N); 19386 end if; 19387 19388 return 19389 Nkind (Stmt) = N_Loop_Statement 19390 and then Present (Identifier (Stmt)) 19391 and then Present (Entity (Identifier (Stmt))) 19392 and then Has_Loop_Entry_Attributes (Entity (Identifier (Stmt))); 19393 end Subject_To_Loop_Entry_Attributes; 19394 19395 ----------------------------- 19396 -- Subprogram_Access_Level -- 19397 ----------------------------- 19398 19399 function Subprogram_Access_Level (Subp : Entity_Id) return Uint is 19400 begin 19401 if Present (Alias (Subp)) then 19402 return Subprogram_Access_Level (Alias (Subp)); 19403 else 19404 return Scope_Depth (Enclosing_Dynamic_Scope (Subp)); 19405 end if; 19406 end Subprogram_Access_Level; 19407 19408 ------------------------------- 19409 -- Support_Atomic_Primitives -- 19410 ------------------------------- 19411 19412 function Support_Atomic_Primitives (Typ : Entity_Id) return Boolean is 19413 Size : Int; 19414 19415 begin 19416 -- Verify the alignment of Typ is known 19417 19418 if not Known_Alignment (Typ) then 19419 return False; 19420 end if; 19421 19422 if Known_Static_Esize (Typ) then 19423 Size := UI_To_Int (Esize (Typ)); 19424 19425 -- If the Esize (Object_Size) is unknown at compile time, look at the 19426 -- RM_Size (Value_Size) which may have been set by an explicit rep item. 19427 19428 elsif Known_Static_RM_Size (Typ) then 19429 Size := UI_To_Int (RM_Size (Typ)); 19430 19431 -- Otherwise, the size is considered to be unknown. 19432 19433 else 19434 return False; 19435 end if; 19436 19437 -- Check that the size of the component is 8, 16, 32 or 64 bits and that 19438 -- Typ is properly aligned. 19439 19440 case Size is 19441 when 8 | 16 | 32 | 64 => 19442 return Size = UI_To_Int (Alignment (Typ)) * 8; 19443 when others => 19444 return False; 19445 end case; 19446 end Support_Atomic_Primitives; 19447 19448 ----------------- 19449 -- Trace_Scope -- 19450 ----------------- 19451 19452 procedure Trace_Scope (N : Node_Id; E : Entity_Id; Msg : String) is 19453 begin 19454 if Debug_Flag_W then 19455 for J in 0 .. Scope_Stack.Last loop 19456 Write_Str (" "); 19457 end loop; 19458 19459 Write_Str (Msg); 19460 Write_Name (Chars (E)); 19461 Write_Str (" from "); 19462 Write_Location (Sloc (N)); 19463 Write_Eol; 19464 end if; 19465 end Trace_Scope; 19466 19467 ----------------------- 19468 -- Transfer_Entities -- 19469 ----------------------- 19470 19471 procedure Transfer_Entities (From : Entity_Id; To : Entity_Id) is 19472 procedure Set_Public_Status_Of (Id : Entity_Id); 19473 -- Set the Is_Public attribute of arbitrary entity Id by calling routine 19474 -- Set_Public_Status. If successfull and Id denotes a record type, set 19475 -- the Is_Public attribute of its fields. 19476 19477 -------------------------- 19478 -- Set_Public_Status_Of -- 19479 -------------------------- 19480 19481 procedure Set_Public_Status_Of (Id : Entity_Id) is 19482 Field : Entity_Id; 19483 19484 begin 19485 if not Is_Public (Id) then 19486 Set_Public_Status (Id); 19487 19488 -- When the input entity is a public record type, ensure that all 19489 -- its internal fields are also exposed to the linker. The fields 19490 -- of a class-wide type are never made public. 19491 19492 if Is_Public (Id) 19493 and then Is_Record_Type (Id) 19494 and then not Is_Class_Wide_Type (Id) 19495 then 19496 Field := First_Entity (Id); 19497 while Present (Field) loop 19498 Set_Is_Public (Field); 19499 Next_Entity (Field); 19500 end loop; 19501 end if; 19502 end if; 19503 end Set_Public_Status_Of; 19504 19505 -- Local variables 19506 19507 Full_Id : Entity_Id; 19508 Id : Entity_Id; 19509 19510 -- Start of processing for Transfer_Entities 19511 19512 begin 19513 Id := First_Entity (From); 19514 19515 if Present (Id) then 19516 19517 -- Merge the entity chain of the source scope with that of the 19518 -- destination scope. 19519 19520 if Present (Last_Entity (To)) then 19521 Set_Next_Entity (Last_Entity (To), Id); 19522 else 19523 Set_First_Entity (To, Id); 19524 end if; 19525 19526 Set_Last_Entity (To, Last_Entity (From)); 19527 19528 -- Inspect the entities of the source scope and update their Scope 19529 -- attribute. 19530 19531 while Present (Id) loop 19532 Set_Scope (Id, To); 19533 Set_Public_Status_Of (Id); 19534 19535 -- Handle an internally generated full view for a private type 19536 19537 if Is_Private_Type (Id) 19538 and then Present (Full_View (Id)) 19539 and then Is_Itype (Full_View (Id)) 19540 then 19541 Full_Id := Full_View (Id); 19542 19543 Set_Scope (Full_Id, To); 19544 Set_Public_Status_Of (Full_Id); 19545 end if; 19546 19547 Next_Entity (Id); 19548 end loop; 19549 19550 Set_First_Entity (From, Empty); 19551 Set_Last_Entity (From, Empty); 19552 end if; 19553 end Transfer_Entities; 19554 19555 ----------------------- 19556 -- Type_Access_Level -- 19557 ----------------------- 19558 19559 function Type_Access_Level (Typ : Entity_Id) return Uint is 19560 Btyp : Entity_Id; 19561 19562 begin 19563 Btyp := Base_Type (Typ); 19564 19565 -- Ada 2005 (AI-230): For most cases of anonymous access types, we 19566 -- simply use the level where the type is declared. This is true for 19567 -- stand-alone object declarations, and for anonymous access types 19568 -- associated with components the level is the same as that of the 19569 -- enclosing composite type. However, special treatment is needed for 19570 -- the cases of access parameters, return objects of an anonymous access 19571 -- type, and, in Ada 95, access discriminants of limited types. 19572 19573 if Is_Access_Type (Btyp) then 19574 if Ekind (Btyp) = E_Anonymous_Access_Type then 19575 19576 -- If the type is a nonlocal anonymous access type (such as for 19577 -- an access parameter) we treat it as being declared at the 19578 -- library level to ensure that names such as X.all'access don't 19579 -- fail static accessibility checks. 19580 19581 if not Is_Local_Anonymous_Access (Typ) then 19582 return Scope_Depth (Standard_Standard); 19583 19584 -- If this is a return object, the accessibility level is that of 19585 -- the result subtype of the enclosing function. The test here is 19586 -- little complicated, because we have to account for extended 19587 -- return statements that have been rewritten as blocks, in which 19588 -- case we have to find and the Is_Return_Object attribute of the 19589 -- itype's associated object. It would be nice to find a way to 19590 -- simplify this test, but it doesn't seem worthwhile to add a new 19591 -- flag just for purposes of this test. ??? 19592 19593 elsif Ekind (Scope (Btyp)) = E_Return_Statement 19594 or else 19595 (Is_Itype (Btyp) 19596 and then Nkind (Associated_Node_For_Itype (Btyp)) = 19597 N_Object_Declaration 19598 and then Is_Return_Object 19599 (Defining_Identifier 19600 (Associated_Node_For_Itype (Btyp)))) 19601 then 19602 declare 19603 Scop : Entity_Id; 19604 19605 begin 19606 Scop := Scope (Scope (Btyp)); 19607 while Present (Scop) loop 19608 exit when Ekind (Scop) = E_Function; 19609 Scop := Scope (Scop); 19610 end loop; 19611 19612 -- Treat the return object's type as having the level of the 19613 -- function's result subtype (as per RM05-6.5(5.3/2)). 19614 19615 return Type_Access_Level (Etype (Scop)); 19616 end; 19617 end if; 19618 end if; 19619 19620 Btyp := Root_Type (Btyp); 19621 19622 -- The accessibility level of anonymous access types associated with 19623 -- discriminants is that of the current instance of the type, and 19624 -- that's deeper than the type itself (AARM 3.10.2 (12.3.21)). 19625 19626 -- AI-402: access discriminants have accessibility based on the 19627 -- object rather than the type in Ada 2005, so the above paragraph 19628 -- doesn't apply. 19629 19630 -- ??? Needs completion with rules from AI-416 19631 19632 if Ada_Version <= Ada_95 19633 and then Ekind (Typ) = E_Anonymous_Access_Type 19634 and then Present (Associated_Node_For_Itype (Typ)) 19635 and then Nkind (Associated_Node_For_Itype (Typ)) = 19636 N_Discriminant_Specification 19637 then 19638 return Scope_Depth (Enclosing_Dynamic_Scope (Btyp)) + 1; 19639 end if; 19640 end if; 19641 19642 -- Return library level for a generic formal type. This is done because 19643 -- RM(10.3.2) says that "The statically deeper relationship does not 19644 -- apply to ... a descendant of a generic formal type". Rather than 19645 -- checking at each point where a static accessibility check is 19646 -- performed to see if we are dealing with a formal type, this rule is 19647 -- implemented by having Type_Access_Level and Deepest_Type_Access_Level 19648 -- return extreme values for a formal type; Deepest_Type_Access_Level 19649 -- returns Int'Last. By calling the appropriate function from among the 19650 -- two, we ensure that the static accessibility check will pass if we 19651 -- happen to run into a formal type. More specifically, we should call 19652 -- Deepest_Type_Access_Level instead of Type_Access_Level whenever the 19653 -- call occurs as part of a static accessibility check and the error 19654 -- case is the case where the type's level is too shallow (as opposed 19655 -- to too deep). 19656 19657 if Is_Generic_Type (Root_Type (Btyp)) then 19658 return Scope_Depth (Standard_Standard); 19659 end if; 19660 19661 return Scope_Depth (Enclosing_Dynamic_Scope (Btyp)); 19662 end Type_Access_Level; 19663 19664 ------------------------------------ 19665 -- Type_Without_Stream_Operation -- 19666 ------------------------------------ 19667 19668 function Type_Without_Stream_Operation 19669 (T : Entity_Id; 19670 Op : TSS_Name_Type := TSS_Null) return Entity_Id 19671 is 19672 BT : constant Entity_Id := Base_Type (T); 19673 Op_Missing : Boolean; 19674 19675 begin 19676 if not Restriction_Active (No_Default_Stream_Attributes) then 19677 return Empty; 19678 end if; 19679 19680 if Is_Elementary_Type (T) then 19681 if Op = TSS_Null then 19682 Op_Missing := 19683 No (TSS (BT, TSS_Stream_Read)) 19684 or else No (TSS (BT, TSS_Stream_Write)); 19685 19686 else 19687 Op_Missing := No (TSS (BT, Op)); 19688 end if; 19689 19690 if Op_Missing then 19691 return T; 19692 else 19693 return Empty; 19694 end if; 19695 19696 elsif Is_Array_Type (T) then 19697 return Type_Without_Stream_Operation (Component_Type (T), Op); 19698 19699 elsif Is_Record_Type (T) then 19700 declare 19701 Comp : Entity_Id; 19702 C_Typ : Entity_Id; 19703 19704 begin 19705 Comp := First_Component (T); 19706 while Present (Comp) loop 19707 C_Typ := Type_Without_Stream_Operation (Etype (Comp), Op); 19708 19709 if Present (C_Typ) then 19710 return C_Typ; 19711 end if; 19712 19713 Next_Component (Comp); 19714 end loop; 19715 19716 return Empty; 19717 end; 19718 19719 elsif Is_Private_Type (T) and then Present (Full_View (T)) then 19720 return Type_Without_Stream_Operation (Full_View (T), Op); 19721 else 19722 return Empty; 19723 end if; 19724 end Type_Without_Stream_Operation; 19725 19726 ---------------------------- 19727 -- Unique_Defining_Entity -- 19728 ---------------------------- 19729 19730 function Unique_Defining_Entity (N : Node_Id) return Entity_Id is 19731 begin 19732 return Unique_Entity (Defining_Entity (N)); 19733 end Unique_Defining_Entity; 19734 19735 ------------------- 19736 -- Unique_Entity -- 19737 ------------------- 19738 19739 function Unique_Entity (E : Entity_Id) return Entity_Id is 19740 U : Entity_Id := E; 19741 P : Node_Id; 19742 19743 begin 19744 case Ekind (E) is 19745 when E_Constant => 19746 if Present (Full_View (E)) then 19747 U := Full_View (E); 19748 end if; 19749 19750 when Entry_Kind => 19751 if Nkind (Parent (E)) = N_Entry_Body then 19752 declare 19753 Prot_Item : Entity_Id; 19754 begin 19755 -- Traverse the entity list of the protected type and locate 19756 -- an entry declaration which matches the entry body. 19757 19758 Prot_Item := First_Entity (Scope (E)); 19759 while Present (Prot_Item) loop 19760 if Ekind (Prot_Item) = E_Entry 19761 and then Corresponding_Body (Parent (Prot_Item)) = E 19762 then 19763 U := Prot_Item; 19764 exit; 19765 end if; 19766 19767 Next_Entity (Prot_Item); 19768 end loop; 19769 end; 19770 end if; 19771 19772 when Formal_Kind => 19773 if Present (Spec_Entity (E)) then 19774 U := Spec_Entity (E); 19775 end if; 19776 19777 when E_Package_Body => 19778 P := Parent (E); 19779 19780 if Nkind (P) = N_Defining_Program_Unit_Name then 19781 P := Parent (P); 19782 end if; 19783 19784 if Nkind (P) = N_Package_Body 19785 and then Present (Corresponding_Spec (P)) 19786 then 19787 U := Corresponding_Spec (P); 19788 19789 elsif Nkind (P) = N_Package_Body_Stub 19790 and then Present (Corresponding_Spec_Of_Stub (P)) 19791 then 19792 U := Corresponding_Spec_Of_Stub (P); 19793 end if; 19794 19795 when E_Protected_Body => 19796 P := Parent (E); 19797 19798 if Nkind (P) = N_Protected_Body 19799 and then Present (Corresponding_Spec (P)) 19800 then 19801 U := Corresponding_Spec (P); 19802 19803 elsif Nkind (P) = N_Protected_Body_Stub 19804 and then Present (Corresponding_Spec_Of_Stub (P)) 19805 then 19806 U := Corresponding_Spec_Of_Stub (P); 19807 end if; 19808 19809 when E_Subprogram_Body => 19810 P := Parent (E); 19811 19812 if Nkind (P) = N_Defining_Program_Unit_Name then 19813 P := Parent (P); 19814 end if; 19815 19816 P := Parent (P); 19817 19818 if Nkind (P) = N_Subprogram_Body 19819 and then Present (Corresponding_Spec (P)) 19820 then 19821 U := Corresponding_Spec (P); 19822 19823 elsif Nkind (P) = N_Subprogram_Body_Stub 19824 and then Present (Corresponding_Spec_Of_Stub (P)) 19825 then 19826 U := Corresponding_Spec_Of_Stub (P); 19827 end if; 19828 19829 when E_Task_Body => 19830 P := Parent (E); 19831 19832 if Nkind (P) = N_Task_Body 19833 and then Present (Corresponding_Spec (P)) 19834 then 19835 U := Corresponding_Spec (P); 19836 19837 elsif Nkind (P) = N_Task_Body_Stub 19838 and then Present (Corresponding_Spec_Of_Stub (P)) 19839 then 19840 U := Corresponding_Spec_Of_Stub (P); 19841 end if; 19842 19843 when Type_Kind => 19844 if Present (Full_View (E)) then 19845 U := Full_View (E); 19846 end if; 19847 19848 when others => 19849 null; 19850 end case; 19851 19852 return U; 19853 end Unique_Entity; 19854 19855 ----------------- 19856 -- Unique_Name -- 19857 ----------------- 19858 19859 function Unique_Name (E : Entity_Id) return String is 19860 19861 -- Names of E_Subprogram_Body or E_Package_Body entities are not 19862 -- reliable, as they may not include the overloading suffix. Instead, 19863 -- when looking for the name of E or one of its enclosing scope, we get 19864 -- the name of the corresponding Unique_Entity. 19865 19866 function Get_Scoped_Name (E : Entity_Id) return String; 19867 -- Return the name of E prefixed by all the names of the scopes to which 19868 -- E belongs, except for Standard. 19869 19870 --------------------- 19871 -- Get_Scoped_Name -- 19872 --------------------- 19873 19874 function Get_Scoped_Name (E : Entity_Id) return String is 19875 Name : constant String := Get_Name_String (Chars (E)); 19876 begin 19877 if Has_Fully_Qualified_Name (E) 19878 or else Scope (E) = Standard_Standard 19879 then 19880 return Name; 19881 else 19882 return Get_Scoped_Name (Unique_Entity (Scope (E))) & "__" & Name; 19883 end if; 19884 end Get_Scoped_Name; 19885 19886 -- Start of processing for Unique_Name 19887 19888 begin 19889 if E = Standard_Standard then 19890 return Get_Name_String (Name_Standard); 19891 19892 elsif Scope (E) = Standard_Standard 19893 and then not (Ekind (E) = E_Package or else Is_Subprogram (E)) 19894 then 19895 return Get_Name_String (Name_Standard) & "__" & 19896 Get_Name_String (Chars (E)); 19897 19898 elsif Ekind (E) = E_Enumeration_Literal then 19899 return Unique_Name (Etype (E)) & "__" & Get_Name_String (Chars (E)); 19900 19901 else 19902 return Get_Scoped_Name (Unique_Entity (E)); 19903 end if; 19904 end Unique_Name; 19905 19906 --------------------- 19907 -- Unit_Is_Visible -- 19908 --------------------- 19909 19910 function Unit_Is_Visible (U : Entity_Id) return Boolean is 19911 Curr : constant Node_Id := Cunit (Current_Sem_Unit); 19912 Curr_Entity : constant Entity_Id := Cunit_Entity (Current_Sem_Unit); 19913 19914 function Unit_In_Parent_Context (Par_Unit : Node_Id) return Boolean; 19915 -- For a child unit, check whether unit appears in a with_clause 19916 -- of a parent. 19917 19918 function Unit_In_Context (Comp_Unit : Node_Id) return Boolean; 19919 -- Scan the context clause of one compilation unit looking for a 19920 -- with_clause for the unit in question. 19921 19922 ---------------------------- 19923 -- Unit_In_Parent_Context -- 19924 ---------------------------- 19925 19926 function Unit_In_Parent_Context (Par_Unit : Node_Id) return Boolean is 19927 begin 19928 if Unit_In_Context (Par_Unit) then 19929 return True; 19930 19931 elsif Is_Child_Unit (Defining_Entity (Unit (Par_Unit))) then 19932 return Unit_In_Parent_Context (Parent_Spec (Unit (Par_Unit))); 19933 19934 else 19935 return False; 19936 end if; 19937 end Unit_In_Parent_Context; 19938 19939 --------------------- 19940 -- Unit_In_Context -- 19941 --------------------- 19942 19943 function Unit_In_Context (Comp_Unit : Node_Id) return Boolean is 19944 Clause : Node_Id; 19945 19946 begin 19947 Clause := First (Context_Items (Comp_Unit)); 19948 while Present (Clause) loop 19949 if Nkind (Clause) = N_With_Clause then 19950 if Library_Unit (Clause) = U then 19951 return True; 19952 19953 -- The with_clause may denote a renaming of the unit we are 19954 -- looking for, eg. Text_IO which renames Ada.Text_IO. 19955 19956 elsif 19957 Renamed_Entity (Entity (Name (Clause))) = 19958 Defining_Entity (Unit (U)) 19959 then 19960 return True; 19961 end if; 19962 end if; 19963 19964 Next (Clause); 19965 end loop; 19966 19967 return False; 19968 end Unit_In_Context; 19969 19970 -- Start of processing for Unit_Is_Visible 19971 19972 begin 19973 -- The currrent unit is directly visible 19974 19975 if Curr = U then 19976 return True; 19977 19978 elsif Unit_In_Context (Curr) then 19979 return True; 19980 19981 -- If the current unit is a body, check the context of the spec 19982 19983 elsif Nkind (Unit (Curr)) = N_Package_Body 19984 or else 19985 (Nkind (Unit (Curr)) = N_Subprogram_Body 19986 and then not Acts_As_Spec (Unit (Curr))) 19987 then 19988 if Unit_In_Context (Library_Unit (Curr)) then 19989 return True; 19990 end if; 19991 end if; 19992 19993 -- If the spec is a child unit, examine the parents 19994 19995 if Is_Child_Unit (Curr_Entity) then 19996 if Nkind (Unit (Curr)) in N_Unit_Body then 19997 return 19998 Unit_In_Parent_Context 19999 (Parent_Spec (Unit (Library_Unit (Curr)))); 20000 else 20001 return Unit_In_Parent_Context (Parent_Spec (Unit (Curr))); 20002 end if; 20003 20004 else 20005 return False; 20006 end if; 20007 end Unit_Is_Visible; 20008 20009 ------------------------------ 20010 -- Universal_Interpretation -- 20011 ------------------------------ 20012 20013 function Universal_Interpretation (Opnd : Node_Id) return Entity_Id is 20014 Index : Interp_Index; 20015 It : Interp; 20016 20017 begin 20018 -- The argument may be a formal parameter of an operator or subprogram 20019 -- with multiple interpretations, or else an expression for an actual. 20020 20021 if Nkind (Opnd) = N_Defining_Identifier 20022 or else not Is_Overloaded (Opnd) 20023 then 20024 if Etype (Opnd) = Universal_Integer 20025 or else Etype (Opnd) = Universal_Real 20026 then 20027 return Etype (Opnd); 20028 else 20029 return Empty; 20030 end if; 20031 20032 else 20033 Get_First_Interp (Opnd, Index, It); 20034 while Present (It.Typ) loop 20035 if It.Typ = Universal_Integer 20036 or else It.Typ = Universal_Real 20037 then 20038 return It.Typ; 20039 end if; 20040 20041 Get_Next_Interp (Index, It); 20042 end loop; 20043 20044 return Empty; 20045 end if; 20046 end Universal_Interpretation; 20047 20048 --------------- 20049 -- Unqualify -- 20050 --------------- 20051 20052 function Unqualify (Expr : Node_Id) return Node_Id is 20053 begin 20054 -- Recurse to handle unlikely case of multiple levels of qualification 20055 20056 if Nkind (Expr) = N_Qualified_Expression then 20057 return Unqualify (Expression (Expr)); 20058 20059 -- Normal case, not a qualified expression 20060 20061 else 20062 return Expr; 20063 end if; 20064 end Unqualify; 20065 20066 ----------------------- 20067 -- Visible_Ancestors -- 20068 ----------------------- 20069 20070 function Visible_Ancestors (Typ : Entity_Id) return Elist_Id is 20071 List_1 : Elist_Id; 20072 List_2 : Elist_Id; 20073 Elmt : Elmt_Id; 20074 20075 begin 20076 pragma Assert (Is_Record_Type (Typ) and then Is_Tagged_Type (Typ)); 20077 20078 -- Collect all the parents and progenitors of Typ. If the full-view of 20079 -- private parents and progenitors is available then it is used to 20080 -- generate the list of visible ancestors; otherwise their partial 20081 -- view is added to the resulting list. 20082 20083 Collect_Parents 20084 (T => Typ, 20085 List => List_1, 20086 Use_Full_View => True); 20087 20088 Collect_Interfaces 20089 (T => Typ, 20090 Ifaces_List => List_2, 20091 Exclude_Parents => True, 20092 Use_Full_View => True); 20093 20094 -- Join the two lists. Avoid duplications because an interface may 20095 -- simultaneously be parent and progenitor of a type. 20096 20097 Elmt := First_Elmt (List_2); 20098 while Present (Elmt) loop 20099 Append_Unique_Elmt (Node (Elmt), List_1); 20100 Next_Elmt (Elmt); 20101 end loop; 20102 20103 return List_1; 20104 end Visible_Ancestors; 20105 20106 ---------------------- 20107 -- Within_Init_Proc -- 20108 ---------------------- 20109 20110 function Within_Init_Proc return Boolean is 20111 S : Entity_Id; 20112 20113 begin 20114 S := Current_Scope; 20115 while not Is_Overloadable (S) loop 20116 if S = Standard_Standard then 20117 return False; 20118 else 20119 S := Scope (S); 20120 end if; 20121 end loop; 20122 20123 return Is_Init_Proc (S); 20124 end Within_Init_Proc; 20125 20126 ------------------ 20127 -- Within_Scope -- 20128 ------------------ 20129 20130 function Within_Scope (E : Entity_Id; S : Entity_Id) return Boolean is 20131 SE : Entity_Id; 20132 begin 20133 SE := Scope (E); 20134 loop 20135 if SE = S then 20136 return True; 20137 elsif SE = Standard_Standard then 20138 return False; 20139 else 20140 SE := Scope (SE); 20141 end if; 20142 end loop; 20143 end Within_Scope; 20144 20145 ---------------- 20146 -- Wrong_Type -- 20147 ---------------- 20148 20149 procedure Wrong_Type (Expr : Node_Id; Expected_Type : Entity_Id) is 20150 Found_Type : constant Entity_Id := First_Subtype (Etype (Expr)); 20151 Expec_Type : constant Entity_Id := First_Subtype (Expected_Type); 20152 20153 Matching_Field : Entity_Id; 20154 -- Entity to give a more precise suggestion on how to write a one- 20155 -- element positional aggregate. 20156 20157 function Has_One_Matching_Field return Boolean; 20158 -- Determines if Expec_Type is a record type with a single component or 20159 -- discriminant whose type matches the found type or is one dimensional 20160 -- array whose component type matches the found type. In the case of 20161 -- one discriminant, we ignore the variant parts. That's not accurate, 20162 -- but good enough for the warning. 20163 20164 ---------------------------- 20165 -- Has_One_Matching_Field -- 20166 ---------------------------- 20167 20168 function Has_One_Matching_Field return Boolean is 20169 E : Entity_Id; 20170 20171 begin 20172 Matching_Field := Empty; 20173 20174 if Is_Array_Type (Expec_Type) 20175 and then Number_Dimensions (Expec_Type) = 1 20176 and then Covers (Etype (Component_Type (Expec_Type)), Found_Type) 20177 then 20178 -- Use type name if available. This excludes multidimensional 20179 -- arrays and anonymous arrays. 20180 20181 if Comes_From_Source (Expec_Type) then 20182 Matching_Field := Expec_Type; 20183 20184 -- For an assignment, use name of target 20185 20186 elsif Nkind (Parent (Expr)) = N_Assignment_Statement 20187 and then Is_Entity_Name (Name (Parent (Expr))) 20188 then 20189 Matching_Field := Entity (Name (Parent (Expr))); 20190 end if; 20191 20192 return True; 20193 20194 elsif not Is_Record_Type (Expec_Type) then 20195 return False; 20196 20197 else 20198 E := First_Entity (Expec_Type); 20199 loop 20200 if No (E) then 20201 return False; 20202 20203 elsif not Ekind_In (E, E_Discriminant, E_Component) 20204 or else Nam_In (Chars (E), Name_uTag, Name_uParent) 20205 then 20206 Next_Entity (E); 20207 20208 else 20209 exit; 20210 end if; 20211 end loop; 20212 20213 if not Covers (Etype (E), Found_Type) then 20214 return False; 20215 20216 elsif Present (Next_Entity (E)) 20217 and then (Ekind (E) = E_Component 20218 or else Ekind (Next_Entity (E)) = E_Discriminant) 20219 then 20220 return False; 20221 20222 else 20223 Matching_Field := E; 20224 return True; 20225 end if; 20226 end if; 20227 end Has_One_Matching_Field; 20228 20229 -- Start of processing for Wrong_Type 20230 20231 begin 20232 -- Don't output message if either type is Any_Type, or if a message 20233 -- has already been posted for this node. We need to do the latter 20234 -- check explicitly (it is ordinarily done in Errout), because we 20235 -- are using ! to force the output of the error messages. 20236 20237 if Expec_Type = Any_Type 20238 or else Found_Type = Any_Type 20239 or else Error_Posted (Expr) 20240 then 20241 return; 20242 20243 -- If one of the types is a Taft-Amendment type and the other it its 20244 -- completion, it must be an illegal use of a TAT in the spec, for 20245 -- which an error was already emitted. Avoid cascaded errors. 20246 20247 elsif Is_Incomplete_Type (Expec_Type) 20248 and then Has_Completion_In_Body (Expec_Type) 20249 and then Full_View (Expec_Type) = Etype (Expr) 20250 then 20251 return; 20252 20253 elsif Is_Incomplete_Type (Etype (Expr)) 20254 and then Has_Completion_In_Body (Etype (Expr)) 20255 and then Full_View (Etype (Expr)) = Expec_Type 20256 then 20257 return; 20258 20259 -- In an instance, there is an ongoing problem with completion of 20260 -- type derived from private types. Their structure is what Gigi 20261 -- expects, but the Etype is the parent type rather than the 20262 -- derived private type itself. Do not flag error in this case. The 20263 -- private completion is an entity without a parent, like an Itype. 20264 -- Similarly, full and partial views may be incorrect in the instance. 20265 -- There is no simple way to insure that it is consistent ??? 20266 20267 -- A similar view discrepancy can happen in an inlined body, for the 20268 -- same reason: inserted body may be outside of the original package 20269 -- and only partial views are visible at the point of insertion. 20270 20271 elsif In_Instance or else In_Inlined_Body then 20272 if Etype (Etype (Expr)) = Etype (Expected_Type) 20273 and then 20274 (Has_Private_Declaration (Expected_Type) 20275 or else Has_Private_Declaration (Etype (Expr))) 20276 and then No (Parent (Expected_Type)) 20277 then 20278 return; 20279 20280 elsif Nkind (Parent (Expr)) = N_Qualified_Expression 20281 and then Entity (Subtype_Mark (Parent (Expr))) = Expected_Type 20282 then 20283 return; 20284 20285 elsif Is_Private_Type (Expected_Type) 20286 and then Present (Full_View (Expected_Type)) 20287 and then Covers (Full_View (Expected_Type), Etype (Expr)) 20288 then 20289 return; 20290 20291 -- Conversely, type of expression may be the private one 20292 20293 elsif Is_Private_Type (Base_Type (Etype (Expr))) 20294 and then Full_View (Base_Type (Etype (Expr))) = Expected_Type 20295 then 20296 return; 20297 end if; 20298 end if; 20299 20300 -- An interesting special check. If the expression is parenthesized 20301 -- and its type corresponds to the type of the sole component of the 20302 -- expected record type, or to the component type of the expected one 20303 -- dimensional array type, then assume we have a bad aggregate attempt. 20304 20305 if Nkind (Expr) in N_Subexpr 20306 and then Paren_Count (Expr) /= 0 20307 and then Has_One_Matching_Field 20308 then 20309 Error_Msg_N ("positional aggregate cannot have one component", Expr); 20310 20311 if Present (Matching_Field) then 20312 if Is_Array_Type (Expec_Type) then 20313 Error_Msg_NE 20314 ("\write instead `&''First ='> ...`", Expr, Matching_Field); 20315 else 20316 Error_Msg_NE 20317 ("\write instead `& ='> ...`", Expr, Matching_Field); 20318 end if; 20319 end if; 20320 20321 -- Another special check, if we are looking for a pool-specific access 20322 -- type and we found an E_Access_Attribute_Type, then we have the case 20323 -- of an Access attribute being used in a context which needs a pool- 20324 -- specific type, which is never allowed. The one extra check we make 20325 -- is that the expected designated type covers the Found_Type. 20326 20327 elsif Is_Access_Type (Expec_Type) 20328 and then Ekind (Found_Type) = E_Access_Attribute_Type 20329 and then Ekind (Base_Type (Expec_Type)) /= E_General_Access_Type 20330 and then Ekind (Base_Type (Expec_Type)) /= E_Anonymous_Access_Type 20331 and then Covers 20332 (Designated_Type (Expec_Type), Designated_Type (Found_Type)) 20333 then 20334 Error_Msg_N -- CODEFIX 20335 ("result must be general access type!", Expr); 20336 Error_Msg_NE -- CODEFIX 20337 ("add ALL to }!", Expr, Expec_Type); 20338 20339 -- Another special check, if the expected type is an integer type, 20340 -- but the expression is of type System.Address, and the parent is 20341 -- an addition or subtraction operation whose left operand is the 20342 -- expression in question and whose right operand is of an integral 20343 -- type, then this is an attempt at address arithmetic, so give 20344 -- appropriate message. 20345 20346 elsif Is_Integer_Type (Expec_Type) 20347 and then Is_RTE (Found_Type, RE_Address) 20348 and then Nkind_In (Parent (Expr), N_Op_Add, N_Op_Subtract) 20349 and then Expr = Left_Opnd (Parent (Expr)) 20350 and then Is_Integer_Type (Etype (Right_Opnd (Parent (Expr)))) 20351 then 20352 Error_Msg_N 20353 ("address arithmetic not predefined in package System", 20354 Parent (Expr)); 20355 Error_Msg_N 20356 ("\possible missing with/use of System.Storage_Elements", 20357 Parent (Expr)); 20358 return; 20359 20360 -- If the expected type is an anonymous access type, as for access 20361 -- parameters and discriminants, the error is on the designated types. 20362 20363 elsif Ekind (Expec_Type) = E_Anonymous_Access_Type then 20364 if Comes_From_Source (Expec_Type) then 20365 Error_Msg_NE ("expected}!", Expr, Expec_Type); 20366 else 20367 Error_Msg_NE 20368 ("expected an access type with designated}", 20369 Expr, Designated_Type (Expec_Type)); 20370 end if; 20371 20372 if Is_Access_Type (Found_Type) 20373 and then not Comes_From_Source (Found_Type) 20374 then 20375 Error_Msg_NE 20376 ("\\found an access type with designated}!", 20377 Expr, Designated_Type (Found_Type)); 20378 else 20379 if From_Limited_With (Found_Type) then 20380 Error_Msg_NE ("\\found incomplete}!", Expr, Found_Type); 20381 Error_Msg_Qual_Level := 99; 20382 Error_Msg_NE -- CODEFIX 20383 ("\\missing `WITH &;", Expr, Scope (Found_Type)); 20384 Error_Msg_Qual_Level := 0; 20385 else 20386 Error_Msg_NE ("found}!", Expr, Found_Type); 20387 end if; 20388 end if; 20389 20390 -- Normal case of one type found, some other type expected 20391 20392 else 20393 -- If the names of the two types are the same, see if some number 20394 -- of levels of qualification will help. Don't try more than three 20395 -- levels, and if we get to standard, it's no use (and probably 20396 -- represents an error in the compiler) Also do not bother with 20397 -- internal scope names. 20398 20399 declare 20400 Expec_Scope : Entity_Id; 20401 Found_Scope : Entity_Id; 20402 20403 begin 20404 Expec_Scope := Expec_Type; 20405 Found_Scope := Found_Type; 20406 20407 for Levels in Nat range 0 .. 3 loop 20408 if Chars (Expec_Scope) /= Chars (Found_Scope) then 20409 Error_Msg_Qual_Level := Levels; 20410 exit; 20411 end if; 20412 20413 Expec_Scope := Scope (Expec_Scope); 20414 Found_Scope := Scope (Found_Scope); 20415 20416 exit when Expec_Scope = Standard_Standard 20417 or else Found_Scope = Standard_Standard 20418 or else not Comes_From_Source (Expec_Scope) 20419 or else not Comes_From_Source (Found_Scope); 20420 end loop; 20421 end; 20422 20423 if Is_Record_Type (Expec_Type) 20424 and then Present (Corresponding_Remote_Type (Expec_Type)) 20425 then 20426 Error_Msg_NE ("expected}!", Expr, 20427 Corresponding_Remote_Type (Expec_Type)); 20428 else 20429 Error_Msg_NE ("expected}!", Expr, Expec_Type); 20430 end if; 20431 20432 if Is_Entity_Name (Expr) 20433 and then Is_Package_Or_Generic_Package (Entity (Expr)) 20434 then 20435 Error_Msg_N ("\\found package name!", Expr); 20436 20437 elsif Is_Entity_Name (Expr) 20438 and then Ekind_In (Entity (Expr), E_Procedure, E_Generic_Procedure) 20439 then 20440 if Ekind (Expec_Type) = E_Access_Subprogram_Type then 20441 Error_Msg_N 20442 ("found procedure name, possibly missing Access attribute!", 20443 Expr); 20444 else 20445 Error_Msg_N 20446 ("\\found procedure name instead of function!", Expr); 20447 end if; 20448 20449 elsif Nkind (Expr) = N_Function_Call 20450 and then Ekind (Expec_Type) = E_Access_Subprogram_Type 20451 and then Etype (Designated_Type (Expec_Type)) = Etype (Expr) 20452 and then No (Parameter_Associations (Expr)) 20453 then 20454 Error_Msg_N 20455 ("found function name, possibly missing Access attribute!", 20456 Expr); 20457 20458 -- Catch common error: a prefix or infix operator which is not 20459 -- directly visible because the type isn't. 20460 20461 elsif Nkind (Expr) in N_Op 20462 and then Is_Overloaded (Expr) 20463 and then not Is_Immediately_Visible (Expec_Type) 20464 and then not Is_Potentially_Use_Visible (Expec_Type) 20465 and then not In_Use (Expec_Type) 20466 and then Has_Compatible_Type (Right_Opnd (Expr), Expec_Type) 20467 then 20468 Error_Msg_N 20469 ("operator of the type is not directly visible!", Expr); 20470 20471 elsif Ekind (Found_Type) = E_Void 20472 and then Present (Parent (Found_Type)) 20473 and then Nkind (Parent (Found_Type)) = N_Full_Type_Declaration 20474 then 20475 Error_Msg_NE ("\\found premature usage of}!", Expr, Found_Type); 20476 20477 else 20478 Error_Msg_NE ("\\found}!", Expr, Found_Type); 20479 end if; 20480 20481 -- A special check for cases like M1 and M2 = 0 where M1 and M2 are 20482 -- of the same modular type, and (M1 and M2) = 0 was intended. 20483 20484 if Expec_Type = Standard_Boolean 20485 and then Is_Modular_Integer_Type (Found_Type) 20486 and then Nkind_In (Parent (Expr), N_Op_And, N_Op_Or, N_Op_Xor) 20487 and then Nkind (Right_Opnd (Parent (Expr))) in N_Op_Compare 20488 then 20489 declare 20490 Op : constant Node_Id := Right_Opnd (Parent (Expr)); 20491 L : constant Node_Id := Left_Opnd (Op); 20492 R : constant Node_Id := Right_Opnd (Op); 20493 20494 begin 20495 -- The case for the message is when the left operand of the 20496 -- comparison is the same modular type, or when it is an 20497 -- integer literal (or other universal integer expression), 20498 -- which would have been typed as the modular type if the 20499 -- parens had been there. 20500 20501 if (Etype (L) = Found_Type 20502 or else 20503 Etype (L) = Universal_Integer) 20504 and then Is_Integer_Type (Etype (R)) 20505 then 20506 Error_Msg_N 20507 ("\\possible missing parens for modular operation", Expr); 20508 end if; 20509 end; 20510 end if; 20511 20512 -- Reset error message qualification indication 20513 20514 Error_Msg_Qual_Level := 0; 20515 end if; 20516 end Wrong_Type; 20517 20518 -------------------------------- 20519 -- Yields_Synchronized_Object -- 20520 -------------------------------- 20521 20522 function Yields_Synchronized_Object (Typ : Entity_Id) return Boolean is 20523 Has_Sync_Comp : Boolean := False; 20524 Id : Entity_Id; 20525 20526 begin 20527 -- An array type yields a synchronized object if its component type 20528 -- yields a synchronized object. 20529 20530 if Is_Array_Type (Typ) then 20531 return Yields_Synchronized_Object (Component_Type (Typ)); 20532 20533 -- A descendant of type Ada.Synchronous_Task_Control.Suspension_Object 20534 -- yields a synchronized object by default. 20535 20536 elsif Is_Descendant_Of_Suspension_Object (Typ) then 20537 return True; 20538 20539 -- A protected type yields a synchronized object by default 20540 20541 elsif Is_Protected_Type (Typ) then 20542 return True; 20543 20544 -- A record type or type extension yields a synchronized object when its 20545 -- discriminants (if any) lack default values and all components are of 20546 -- a type that yelds a synchronized object. 20547 20548 elsif Is_Record_Type (Typ) then 20549 20550 -- Inspect all entities defined in the scope of the type, looking for 20551 -- components of a type that does not yeld a synchronized object or 20552 -- for discriminants with default values. 20553 20554 Id := First_Entity (Typ); 20555 while Present (Id) loop 20556 if Comes_From_Source (Id) then 20557 if Ekind (Id) = E_Component then 20558 if Yields_Synchronized_Object (Etype (Id)) then 20559 Has_Sync_Comp := True; 20560 20561 -- The component does not yield a synchronized object 20562 20563 else 20564 return False; 20565 end if; 20566 20567 elsif Ekind (Id) = E_Discriminant 20568 and then Present (Expression (Parent (Id))) 20569 then 20570 return False; 20571 end if; 20572 end if; 20573 20574 Next_Entity (Id); 20575 end loop; 20576 20577 -- Ensure that the parent type of a type extension yields a 20578 -- synchronized object. 20579 20580 if Etype (Typ) /= Typ 20581 and then not Yields_Synchronized_Object (Etype (Typ)) 20582 then 20583 return False; 20584 end if; 20585 20586 -- If we get here, then all discriminants lack default values and all 20587 -- components are of a type that yields a synchronized object. 20588 20589 return Has_Sync_Comp; 20590 20591 -- A synchronized interface type yields a synchronized object by default 20592 20593 elsif Is_Synchronized_Interface (Typ) then 20594 return True; 20595 20596 -- A task type yelds a synchronized object by default 20597 20598 elsif Is_Task_Type (Typ) then 20599 return True; 20600 20601 -- Otherwise the type does not yield a synchronized object 20602 20603 else 20604 return False; 20605 end if; 20606 end Yields_Synchronized_Object; 20607 20608end Sem_Util; 20609